diff --git a/.github/workflows/fpm-deployment.yml b/.github/workflows/fpm-deployment.yml index 19cf58d8b..ffcd392e1 100644 --- a/.github/workflows/fpm-deployment.yml +++ b/.github/workflows/fpm-deployment.yml @@ -38,6 +38,9 @@ jobs: - run: | # Just for deployment: create stdlib-fpm folder python config/fypp_deployment.py --deploy_stdlib_fpm + - run: | # Just for deployment: create stdlib-fpm-ilp64 folder + python config/fypp_deployment.py --deploy_stdlib_fpm --with_ilp64 + - run: | # Use fpm gnu ci to check xdp and qp python config/fypp_deployment.py --with_xdp --with_qp fpm test --profile release --flag '-DWITH_XDP -DWITH_QP' @@ -48,4 +51,12 @@ jobs: if: github.event_name != 'pull_request' with: BRANCH: stdlib-fpm - FOLDER: stdlib-fpm \ No newline at end of file + FOLDER: stdlib-fpm + + # Update and deploy the f90 files generated by github-ci to the `stdlib-fpm-ilp64` branch. + - name: Deploy with 64-bit integer support 🚀 + uses: JamesIves/github-pages-deploy-action@4.1.5 + if: github.event_name != 'pull_request' + with: + BRANCH: stdlib-fpm-ilp64 + FOLDER: stdlib-fpm-ilp64 diff --git a/CMakeLists.txt b/CMakeLists.txt index b10e1f73d..d83aa205c 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -62,6 +62,7 @@ list( "-DWITH_CBOOL=$" "-DWITH_QP=$" "-DWITH_XDP=$" + "-DWITH_ILP64=$" "-DPROJECT_VERSION_MAJOR=${PROJECT_VERSION_MAJOR}" "-DPROJECT_VERSION_MINOR=${PROJECT_VERSION_MINOR}" "-DPROJECT_VERSION_PATCH=${PROJECT_VERSION_PATCH}" diff --git a/README.md b/README.md index b329d2713..7412d99aa 100644 --- a/README.md +++ b/README.md @@ -323,6 +323,34 @@ as well as a specification document or ["spec"](https://stdlib.fortran-lang.org/ Some discussions and prototypes of proposed APIs along with a list of popular open source Fortran projects are available on the [wiki](https://github.com/fortran-lang/stdlib/wiki). +## BLAS and LAPACK + +`stdlib` ships full versions of BLAS and LAPACK, for all `real` and `complex` kinds, through generalized interface modules `stdlib_linalg_blas` and `stdlib_linalg_lapack`. +The 32- and 64-bit implementations may be replaced by external optimized libraries if available, which may allow for faster code. +When linking against external BLAS/LAPACK libraries, the user should define macros `STDLIB_EXTERNAL_BLAS` and `STDLIB_EXTERNAL_LAPACK`, +to ensure that the external library version is used instead of the internal implementation. + +- In case of a CMake build, the necessary configuration can be added by ensuring both macros are defined: + ``` + add_compile_definitions(STDLIB_EXTERNAL_BLAS STDLIB_EXTERNAL_LAPACK) + ``` +- In case of an `fpm` build, the stdlib dependency should be set as follows: + ```toml + [dependencies] + stdlib = { git="https://github.com/fortran-lang/stdlib", branch="stdlib-fpm", preprocess.cpp.macros=["STDLIB_EXTERNAL_BLAS", "STDLIB_EXTERNAL_LAPACK"] } + ``` + +Support for 64-bit integer size interfaces of all BLAS and LAPACK procedures may also be enabled +by setting the CMake flag `-DWITH_ILP64=True`. The 64-bit integer version is always built in addition to +the 32-bit integer version, that is always available. Additional macros `STDLIB_EXTERNAL_BLAS_I64` and `STDLIB_EXTERNAL_LAPACK_I64` +may be defined to link against an external 64-bit integer library, such as Intel MKL. + +- In case of an `fpm` build, 64-bit integer linear algebra support is given via branch `stdlib-fpm-ilp64`: + ```toml + [dependencies] + stdlib = { git="https://github.com/fortran-lang/stdlib", branch="stdlib-fpm-ilp64", preprocess.cpp.macros=["STDLIB_EXTERNAL_BLAS_I64", "STDLIB_EXTERNAL_LAPACK"] } + ``` + ## Contributing * [Guidelines](CONTRIBUTING.md) diff --git a/config/CMakeLists.txt b/config/CMakeLists.txt index 10025c3e6..d81373a03 100644 --- a/config/CMakeLists.txt +++ b/config/CMakeLists.txt @@ -39,6 +39,11 @@ if (NOT DEFINED WITH_XDP) ) set(WITH_XDP ${WITH_XDP} PARENT_SCOPE) endif() +# Check if WITH_ILP64 is defined; if not, set it to FALSE +if (NOT DEFINED WITH_ILP64) + set(WITH_ILP64 FALSE) + set(WITH_ILP64 ${WITH_ILP64} PARENT_SCOPE) +endif() # Export a pkg-config file configure_file( diff --git a/config/fypp_deployment.py b/config/fypp_deployment.py index ee7cb02cd..6c779adf1 100644 --- a/config/fypp_deployment.py +++ b/config/fypp_deployment.py @@ -42,6 +42,8 @@ def pre_process_fypp(args): kwd.append("-DWITH_QP=True") if args.with_xdp: kwd.append("-DWITH_XDP=True") + if args.with_ilp64: + kwd.append("-DWITH_ILP64=True") optparser = fypp.get_option_parser() options, leftover = optparser.parse_args(args=kwd) @@ -78,7 +80,7 @@ def process_f(file): return -def deploy_stdlib_fpm(): +def deploy_stdlib_fpm(with_ilp64): """create the stdlib-fpm folder for backwards compatibility (to be deprecated) """ import shutil @@ -86,24 +88,30 @@ def deploy_stdlib_fpm(): "test_hash_functions.f90", "f18estop.f90", ) - if not os.path.exists('stdlib-fpm'+os.sep+'src'): - os.makedirs('stdlib-fpm'+os.sep+'src') - if not os.path.exists('stdlib-fpm'+os.sep+'test'): - os.makedirs('stdlib-fpm'+os.sep+'test') - if not os.path.exists('stdlib-fpm'+os.sep+'example'): - os.makedirs('stdlib-fpm'+os.sep+'example') + + if with_ilp64: + base_folder = 'stdlib-fpm-ilp64' + else: + base_folder = 'stdlib-fpm' + + if not os.path.exists(base_folder+os.sep+'src'): + os.makedirs(base_folder+os.sep+'src') + if not os.path.exists(base_folder+os.sep+'test'): + os.makedirs(base_folder+os.sep+'test') + if not os.path.exists(base_folder+os.sep+'example'): + os.makedirs(base_folder+os.sep+'example') def recursive_copy(folder): for root, _, files in os.walk(folder): for file in files: if file not in prune: if file.endswith(".f90") or file.endswith(".F90") or file.endswith(".dat") or file.endswith(".npy"): - shutil.copy2(os.path.join(root, file), 'stdlib-fpm'+os.sep+folder+os.sep+file) + shutil.copy2(os.path.join(root, file), base_folder+os.sep+folder+os.sep+file) recursive_copy('src') recursive_copy('test') recursive_copy('example') for file in ['.gitignore','fpm.toml','LICENSE','VERSION']: - shutil.copy2(file, 'stdlib-fpm'+os.sep+file) + shutil.copy2(file, base_folder+os.sep+file) return def fpm_build(args,unknown): @@ -140,8 +148,9 @@ def fpm_build(args,unknown): parser.add_argument("--maxrank",type=int, default=4, help="Set the maximum allowed rank for arrays") parser.add_argument("--with_qp",action='store_true', help="Include WITH_QP in the command") parser.add_argument("--with_xdp",action='store_true', help="Include WITH_XDP in the command") + parser.add_argument("--with_ilp64",action='store_true', help="Include WITH_ILP64 to build 64-bit BLAS/LAPACK") parser.add_argument("--lnumbering",action='store_true', help="Add line numbering in preprocessed files") - parser.add_argument("--deploy_stdlib_fpm",action='store_true', help="create the stdlib-fpm folder") + parser.add_argument("--deploy_stdlib_fpm",action='store_true', help="create the stdlib-fpm folder") # external libraries arguments parser.add_argument("--build", action='store_true', help="Build the project") @@ -158,8 +167,8 @@ def fpm_build(args,unknown): # pre process the meta programming fypp files pre_process_fypp(args) if args.deploy_stdlib_fpm: - deploy_stdlib_fpm() + deploy_stdlib_fpm(args.with_ilp64) #========================================== # build using fpm if args.build: - fpm_build(args,unknown) \ No newline at end of file + fpm_build(args,unknown) diff --git a/config/template.cmake b/config/template.cmake index 9a0b15e8d..576b59630 100644 --- a/config/template.cmake +++ b/config/template.cmake @@ -3,6 +3,7 @@ set("@PROJECT_NAME@_WITH_CBOOL" @WITH_CBOOL@) set("@PROJECT_NAME@_WITH_QP" @WITH_QP@) set("@PROJECT_NAME@_WITH_XDP" @WITH_XDP@) +set("@PROJECT_NAME@_WITH_ILP64" @WITH_ILP64@) if(NOT TARGET "@PROJECT_NAME@::@PROJECT_NAME@") include("${CMAKE_CURRENT_LIST_DIR}/@PROJECT_NAME@-targets.cmake") diff --git a/include/common.fypp b/include/common.fypp index 1c4efb4d3..de0a7b911 100644 --- a/include/common.fypp +++ b/include/common.fypp @@ -18,6 +18,11 @@ #:set WITH_XDP = False #:endif +#! Support for linear algebra with 64-bit integer sizes +#:if not defined("WITH_ILP64") +#:set WITH_ILP64 = False +#:endif + #! Real kinds to be considered during templating #:set REAL_KINDS = ["sp", "dp"] #:if WITH_XDP @@ -74,6 +79,16 @@ $:"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"] +#:set LINALG_INT_SUFFIX = [""] +#:if WITH_ILP64 +#:set LINALG_INT_KINDS = LINALG_INT_KINDS+["ilp64"] +#:set LINALG_INT_SUFFIX = LINALG_INT_SUFFIX+["_I64"] +#:endif +#: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, LINALG_INT_SUFFIX)) + #! 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] diff --git a/src/stdlib_linalg_blas.fypp b/src/stdlib_linalg_blas.fypp index 2c0618e8d..cdf01690f 100644 --- a/src/stdlib_linalg_blas.fypp +++ b/src/stdlib_linalg_blas.fypp @@ -7,355 +7,337 @@ module stdlib_linalg_blas use stdlib_linalg_blas_${ri}$ #:endfor implicit none(type,external) - public - + public + interface asum !! ASUM takes the sum of the absolute values. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure real(dp) function dasum( n, x, incx ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n real(dp), intent(in) :: x(*) end function dasum -#else - module procedure stdlib_dasum +#else + module procedure stdlib${ii}$_dasum #endif -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure real(dp) function dzasum( n, x, incx ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n complex(dp), intent(in) :: x(*) end function dzasum -#else - module procedure stdlib_dzasum +#else + module procedure stdlib${ii}$_dzasum #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$asum -#:endif -#:endfor -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${c2ri(ri)}$zasum -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure real(sp) function sasum( n, x, incx ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n real(sp), intent(in) :: x(*) end function sasum -#else - module procedure stdlib_sasum +#else + module procedure stdlib${ii}$_sasum #endif -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure real(sp) function scasum( n, x, incx ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n complex(sp), intent(in) :: x(*) end function scasum -#else - module procedure stdlib_scasum +#else + module procedure stdlib${ii}$_scasum #endif +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$asum +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${c2ri(ri)}$zasum +#:endif +#:endfor +#:endfor end interface asum interface axpy !! AXPY constant times a vector plus a vector. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine caxpy(n,ca,cx,incx,cy,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(sp), intent(in) :: ca,cx(*) - integer(ilp), intent(in) :: incx,incy,n + integer(${ik}$), intent(in) :: incx,incy,n complex(sp), intent(inout) :: cy(*) end subroutine caxpy -#else - module procedure stdlib_caxpy +#else + module procedure stdlib${ii}$_caxpy #endif -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine daxpy(n,da,dx,incx,dy,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: da,dx(*) - integer(ilp), intent(in) :: incx,incy,n + integer(${ik}$), intent(in) :: incx,incy,n real(dp), intent(inout) :: dy(*) end subroutine daxpy -#else - module procedure stdlib_daxpy +#else + module procedure stdlib${ii}$_daxpy #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$axpy - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine saxpy(n,sa,sx,incx,sy,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: sa,sx(*) - integer(ilp), intent(in) :: incx,incy,n + integer(${ik}$), intent(in) :: incx,incy,n real(sp), intent(inout) :: sy(*) end subroutine saxpy -#else - module procedure stdlib_saxpy +#else + module procedure stdlib${ii}$_saxpy #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$axpy - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine zaxpy(n,za,zx,incx,zy,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(dp), intent(in) :: za,zx(*) - integer(ilp), intent(in) :: incx,incy,n + integer(${ik}$), intent(in) :: incx,incy,n complex(dp), intent(inout) :: zy(*) end subroutine zaxpy -#else - module procedure stdlib_zaxpy +#else + module procedure stdlib${ii}$_zaxpy #endif - end interface axpy - +#:for rk,rt,ri in RC_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$axpy +#:endif +#:endfor +#:endfor + end interface axpy interface copy !! COPY copies a vector x to a vector y. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine ccopy(n,cx,incx,cy,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n complex(sp), intent(in) :: cx(*) complex(sp), intent(out) :: cy(*) end subroutine ccopy -#else - module procedure stdlib_ccopy +#else + module procedure stdlib${ii}$_ccopy #endif -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dcopy(n,dx,incx,dy,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n real(dp), intent(in) :: dx(*) real(dp), intent(out) :: dy(*) end subroutine dcopy -#else - module procedure stdlib_dcopy +#else + module procedure stdlib${ii}$_dcopy #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$copy - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine scopy(n,sx,incx,sy,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n real(sp), intent(in) :: sx(*) real(sp), intent(out) :: sy(*) end subroutine scopy -#else - module procedure stdlib_scopy +#else + module procedure stdlib${ii}$_scopy #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$copy - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine zcopy(n,zx,incx,zy,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n complex(dp), intent(in) :: zx(*) complex(dp), intent(out) :: zy(*) end subroutine zcopy -#else - module procedure stdlib_zcopy +#else + module procedure stdlib${ii}$_zcopy #endif - end interface copy - +#:for rk,rt,ri in RC_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$copy +#:endif +#:endfor +#:endfor + end interface copy interface dot !! DOT forms the dot product of two vectors. !! uses unrolled loops for increments equal to one. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure real(dp) function ddot(n,dx,incx,dy,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n real(dp), intent(in) :: dx(*),dy(*) end function ddot -#else - module procedure stdlib_ddot +#else + module procedure stdlib${ii}$_ddot #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$dot - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure real(sp) function sdot(n,sx,incx,sy,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n real(sp), intent(in) :: sx(*),sy(*) end function sdot -#else - module procedure stdlib_sdot +#else + module procedure stdlib${ii}$_sdot #endif +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$dot +#:endif +#:endfor +#:endfor end interface dot - - interface dotc !! DOTC forms the dot product of two complex vectors !! DOTC = X^H * Y -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure complex(sp) function cdotc(n,cx,incx,cy,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n complex(sp), intent(in) :: cx(*),cy(*) end function cdotc -#else - module procedure stdlib_cdotc +#else + module procedure stdlib${ii}$_cdotc +#endif +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ + pure complex(dp) function zdotc(n,zx,incx,zy,incy) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n + complex(dp), intent(in) :: zx(*),zy(*) + end function zdotc +#else + module procedure stdlib${ii}$_zdotc #endif #:for rk,rt,ri in CMPLX_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$dotc + module procedure stdlib${ii}$_${ri}$dotc #:endif #:endfor -#ifdef STDLIB_EXTERNAL_BLAS - pure complex(dp) function zdotc(n,zx,incx,zy,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n - complex(dp), intent(in) :: zx(*),zy(*) - end function zdotc -#else - module procedure stdlib_zdotc -#endif +#:endfor end interface dotc - - interface dotu !! DOTU forms the dot product of two complex vectors !! DOTU = X^T * Y -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure complex(sp) function cdotu(n,cx,incx,cy,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n complex(sp), intent(in) :: cx(*),cy(*) end function cdotu -#else - module procedure stdlib_cdotu +#else + module procedure stdlib${ii}$_cdotu +#endif +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ + pure complex(dp) function zdotu(n,zx,incx,zy,incy) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n + complex(dp), intent(in) :: zx(*),zy(*) + end function zdotu +#else + module procedure stdlib${ii}$_zdotu #endif #:for rk,rt,ri in CMPLX_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$dotu + module procedure stdlib${ii}$_${ri}$dotu #:endif #:endfor -#ifdef STDLIB_EXTERNAL_BLAS - pure complex(dp) function zdotu(n,zx,incx,zy,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n - complex(dp), intent(in) :: zx(*),zy(*) - end function zdotu -#else - module procedure stdlib_zdotu -#endif +#:endfor end interface dotu - - interface gbmv !! GBMV 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, !! where alpha and beta are scalars, x and y are vectors and A is an !! m by n band matrix, with kl sub-diagonals and ku super-diagonals. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine cgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(sp), intent(in) :: alpha,beta,a(lda,*),x(*) - 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 complex(sp), intent(inout) :: y(*) end subroutine cgbmv -#else - module procedure stdlib_cgbmv +#else + module procedure stdlib${ii}$_cgbmv #endif -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha,beta,a(lda,*),x(*) - 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 real(dp), intent(inout) :: y(*) end subroutine dgbmv -#else - module procedure stdlib_dgbmv +#else + module procedure stdlib${ii}$_dgbmv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gbmv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine sgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha,beta,a(lda,*),x(*) - 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 real(sp), intent(inout) :: y(*) end subroutine sgbmv -#else - module procedure stdlib_sgbmv +#else + module procedure stdlib${ii}$_sgbmv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gbmv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine zgbmv(trans,m,n,kl,ku,alpha,a,lda,x,incx,beta,y,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(dp), intent(in) :: alpha,beta,a(lda,*),x(*) - 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 complex(dp), intent(inout) :: y(*) end subroutine zgbmv -#else - module procedure stdlib_zgbmv +#else + module procedure stdlib${ii}$_zgbmv #endif +#:for rk,rt,ri in RC_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gbmv +#:endif +#:endfor +#:endfor end interface gbmv - - interface gemm !! GEMM performs one of the matrix-matrix operations !! C := alpha*op( A )*op( B ) + beta*C, @@ -363,289 +345,274 @@ module stdlib_linalg_blas !! op( X ) = X or op( X ) = X**T or op( X ) = X**H, !! alpha and beta are scalars, and A, B and C are matrices, with op( A ) !! an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine cgemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(sp), intent(in) :: alpha,beta,a(lda,*),b(ldb,*) - 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 complex(sp), intent(inout) :: c(ldc,*) end subroutine cgemm -#else - module procedure stdlib_cgemm +#else + module procedure stdlib${ii}$_cgemm #endif -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dgemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha,beta,a(lda,*),b(ldb,*) - 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 real(dp), intent(inout) :: c(ldc,*) end subroutine dgemm -#else - module procedure stdlib_dgemm +#else + module procedure stdlib${ii}$_dgemm #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gemm - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine sgemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha,beta,a(lda,*),b(ldb,*) - 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 real(sp), intent(inout) :: c(ldc,*) end subroutine sgemm -#else - module procedure stdlib_sgemm +#else + module procedure stdlib${ii}$_sgemm #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gemm - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine zgemm(transa,transb,m,n,k,alpha,a,lda,b,ldb,beta,c,ldc) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(dp), intent(in) :: alpha,beta,a(lda,*),b(ldb,*) - 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 complex(dp), intent(inout) :: c(ldc,*) end subroutine zgemm -#else - module procedure stdlib_zgemm +#else + module procedure stdlib${ii}$_zgemm #endif +#:for rk,rt,ri in RC_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gemm +#:endif +#:endfor +#:endfor end interface gemm - - interface gemv !! GEMV 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, !! where alpha and beta are scalars, x and y are vectors and A is an !! m by n matrix. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine cgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(sp), intent(in) :: alpha,beta,a(lda,*),x(*) - integer(ilp), intent(in) :: incx,incy,lda,m,n + integer(${ik}$), intent(in) :: incx,incy,lda,m,n character, intent(in) :: trans complex(sp), intent(inout) :: y(*) end subroutine cgemv -#else - module procedure stdlib_cgemv +#else + module procedure stdlib${ii}$_cgemv #endif -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha,beta,a(lda,*),x(*) - integer(ilp), intent(in) :: incx,incy,lda,m,n + integer(${ik}$), intent(in) :: incx,incy,lda,m,n character, intent(in) :: trans real(dp), intent(inout) :: y(*) end subroutine dgemv -#else - module procedure stdlib_dgemv +#else + module procedure stdlib${ii}$_dgemv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gemv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine sgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha,beta,a(lda,*),x(*) - integer(ilp), intent(in) :: incx,incy,lda,m,n + integer(${ik}$), intent(in) :: incx,incy,lda,m,n character, intent(in) :: trans real(sp), intent(inout) :: y(*) end subroutine sgemv -#else - module procedure stdlib_sgemv +#else + module procedure stdlib${ii}$_sgemv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gemv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine zgemv(trans,m,n,alpha,a,lda,x,incx,beta,y,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(dp), intent(in) :: alpha,beta,a(lda,*),x(*) - integer(ilp), intent(in) :: incx,incy,lda,m,n + integer(${ik}$), intent(in) :: incx,incy,lda,m,n character, intent(in) :: trans complex(dp), intent(inout) :: y(*) end subroutine zgemv -#else - module procedure stdlib_zgemv +#else + module procedure stdlib${ii}$_zgemv #endif +#:for rk,rt,ri in RC_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gemv +#:endif +#:endfor +#:endfor end interface gemv - - interface ger !! GER 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 !! vector and A is an m by n matrix. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dger(m,n,alpha,x,incx,y,incy,a,lda) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha,x(*),y(*) - integer(ilp), intent(in) :: incx,incy,lda,m,n + integer(${ik}$), intent(in) :: incx,incy,lda,m,n real(dp), intent(inout) :: a(lda,*) end subroutine dger -#else - module procedure stdlib_dger +#else + module procedure stdlib${ii}$_dger #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ger - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine sger(m,n,alpha,x,incx,y,incy,a,lda) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha,x(*),y(*) - integer(ilp), intent(in) :: incx,incy,lda,m,n + integer(${ik}$), intent(in) :: incx,incy,lda,m,n real(sp), intent(inout) :: a(lda,*) end subroutine sger -#else - module procedure stdlib_sger +#else + module procedure stdlib${ii}$_sger #endif +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ger +#:endif +#:endfor +#:endfor end interface ger - - interface gerc !! GERC 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 !! vector and A is an m by n matrix. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine cgerc(m,n,alpha,x,incx,y,incy,a,lda) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(sp), intent(in) :: alpha,x(*),y(*) - integer(ilp), intent(in) :: incx,incy,lda,m,n + integer(${ik}$), intent(in) :: incx,incy,lda,m,n complex(sp), intent(inout) :: a(lda,*) end subroutine cgerc -#else - module procedure stdlib_cgerc +#else + module procedure stdlib${ii}$_cgerc #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gerc - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine zgerc(m,n,alpha,x,incx,y,incy,a,lda) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(dp), intent(in) :: alpha,x(*),y(*) - integer(ilp), intent(in) :: incx,incy,lda,m,n + integer(${ik}$), intent(in) :: incx,incy,lda,m,n complex(dp), intent(inout) :: a(lda,*) end subroutine zgerc -#else - module procedure stdlib_zgerc +#else + module procedure stdlib${ii}$_zgerc #endif - end interface gerc - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gerc +#:endif +#:endfor +#:endfor + end interface gerc interface geru !! GERU 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 !! vector and A is an m by n matrix. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine cgeru(m,n,alpha,x,incx,y,incy,a,lda) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(sp), intent(in) :: alpha,x(*),y(*) - integer(ilp), intent(in) :: incx,incy,lda,m,n + integer(${ik}$), intent(in) :: incx,incy,lda,m,n complex(sp), intent(inout) :: a(lda,*) end subroutine cgeru -#else - module procedure stdlib_cgeru +#else + module procedure stdlib${ii}$_cgeru #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$geru - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine zgeru(m,n,alpha,x,incx,y,incy,a,lda) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(dp), intent(in) :: alpha,x(*),y(*) - integer(ilp), intent(in) :: incx,incy,lda,m,n + integer(${ik}$), intent(in) :: incx,incy,lda,m,n complex(dp), intent(inout) :: a(lda,*) end subroutine zgeru -#else - module procedure stdlib_zgeru +#else + module procedure stdlib${ii}$_zgeru #endif - end interface geru - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$geru +#:endif +#:endfor +#:endfor + end interface geru interface hbmv !! HBMV 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 !! A is an n by n hermitian band matrix, with k super-diagonals. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine chbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(sp), intent(in) :: alpha,beta,a(lda,*),x(*) - integer(ilp), intent(in) :: incx,incy,k,lda,n + integer(${ik}$), intent(in) :: incx,incy,k,lda,n character, intent(in) :: uplo complex(sp), intent(inout) :: y(*) end subroutine chbmv -#else - module procedure stdlib_chbmv +#else + module procedure stdlib${ii}$_chbmv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hbmv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine zhbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(dp), intent(in) :: alpha,beta,a(lda,*),x(*) - integer(ilp), intent(in) :: incx,incy,k,lda,n + integer(${ik}$), intent(in) :: incx,incy,k,lda,n character, intent(in) :: uplo complex(dp), intent(inout) :: y(*) end subroutine zhbmv -#else - module procedure stdlib_zhbmv +#else + module procedure stdlib${ii}$_zhbmv #endif - end interface hbmv - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hbmv +#:endif +#:endfor +#:endfor + end interface hbmv interface hemm !! HEMM performs one of the matrix-matrix operations @@ -654,158 +621,158 @@ module stdlib_linalg_blas !! C := alpha*B*A + beta*C, !! where alpha and beta are scalars, A is an hermitian matrix and B and !! C are m by n matrices. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine chemm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(sp), intent(in) :: alpha,beta,a(lda,*),b(ldb,*) - integer(ilp), intent(in) :: lda,ldb,ldc,m,n + integer(${ik}$), intent(in) :: lda,ldb,ldc,m,n character, intent(in) :: side,uplo complex(sp), intent(inout) :: c(ldc,*) end subroutine chemm -#else - module procedure stdlib_chemm +#else + module procedure stdlib${ii}$_chemm #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hemm - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine zhemm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(dp), intent(in) :: alpha,beta,a(lda,*),b(ldb,*) - integer(ilp), intent(in) :: lda,ldb,ldc,m,n + integer(${ik}$), intent(in) :: lda,ldb,ldc,m,n character, intent(in) :: side,uplo complex(dp), intent(inout) :: c(ldc,*) end subroutine zhemm -#else - module procedure stdlib_zhemm +#else + module procedure stdlib${ii}$_zhemm #endif - end interface hemm - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hemm +#:endif +#:endfor +#:endfor + end interface hemm interface hemv !! HEMV 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 !! A is an n by n hermitian matrix. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine chemv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(sp), intent(in) :: alpha,beta,a(lda,*),x(*) - integer(ilp), intent(in) :: incx,incy,lda,n + integer(${ik}$), intent(in) :: incx,incy,lda,n character, intent(in) :: uplo complex(sp), intent(inout) :: y(*) end subroutine chemv -#else - module procedure stdlib_chemv +#else + module procedure stdlib${ii}$_chemv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hemv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine zhemv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(dp), intent(in) :: alpha,beta,a(lda,*),x(*) - integer(ilp), intent(in) :: incx,incy,lda,n + integer(${ik}$), intent(in) :: incx,incy,lda,n character, intent(in) :: uplo complex(dp), intent(inout) :: y(*) end subroutine zhemv -#else - module procedure stdlib_zhemv +#else + module procedure stdlib${ii}$_zhemv #endif - end interface hemv - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hemv +#:endif +#:endfor +#:endfor + end interface hemv interface her !! HER 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 !! n by n hermitian matrix. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine cher(uplo,n,alpha,x,incx,a,lda) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha - integer(ilp), intent(in) :: incx,lda,n + integer(${ik}$), intent(in) :: incx,lda,n character, intent(in) :: uplo complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(in) :: x(*) end subroutine cher -#else - module procedure stdlib_cher +#else + module procedure stdlib${ii}$_cher #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$her - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine zher(uplo,n,alpha,x,incx,a,lda) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha - integer(ilp), intent(in) :: incx,lda,n + integer(${ik}$), intent(in) :: incx,lda,n character, intent(in) :: uplo complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: x(*) end subroutine zher -#else - module procedure stdlib_zher +#else + module procedure stdlib${ii}$_zher #endif - end interface her - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$her +#:endif +#:endfor +#:endfor + end interface her interface her2 !! HER2 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 !! by n hermitian matrix. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine cher2(uplo,n,alpha,x,incx,y,incy,a,lda) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(sp), intent(in) :: alpha,x(*),y(*) - integer(ilp), intent(in) :: incx,incy,lda,n + integer(${ik}$), intent(in) :: incx,incy,lda,n character, intent(in) :: uplo complex(sp), intent(inout) :: a(lda,*) end subroutine cher2 -#else - module procedure stdlib_cher2 +#else + module procedure stdlib${ii}$_cher2 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$her2 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine zher2(uplo,n,alpha,x,incx,y,incy,a,lda) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(dp), intent(in) :: alpha,x(*),y(*) - integer(ilp), intent(in) :: incx,incy,lda,n + integer(${ik}$), intent(in) :: incx,incy,lda,n character, intent(in) :: uplo complex(dp), intent(inout) :: a(lda,*) end subroutine zher2 -#else - module procedure stdlib_zher2 +#else + module procedure stdlib${ii}$_zher2 #endif - end interface her2 - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$her2 +#:endif +#:endfor +#:endfor + end interface her2 interface her2k !! HER2K performs one of the hermitian rank 2k operations @@ -815,41 +782,41 @@ module stdlib_linalg_blas !! where alpha and beta are scalars with beta real, C is an n by n !! hermitian matrix and A and B are n by k matrices in the first case !! and k by n matrices in the second case. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine cher2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(sp), intent(in) :: alpha,a(lda,*),b(ldb,*) 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 complex(sp), intent(inout) :: c(ldc,*) end subroutine cher2k -#else - module procedure stdlib_cher2k +#else + module procedure stdlib${ii}$_cher2k #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$her2k - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine zher2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(dp), intent(in) :: alpha,a(lda,*),b(ldb,*) 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 complex(dp), intent(inout) :: c(ldc,*) end subroutine zher2k -#else - module procedure stdlib_zher2k +#else + module procedure stdlib${ii}$_zher2k #endif - end interface her2k - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$her2k +#:endif +#:endfor +#:endfor + end interface her2k interface herk !! HERK performs one of the hermitian rank k operations @@ -859,253 +826,252 @@ module stdlib_linalg_blas !! where alpha and beta are real scalars, C is an n by n hermitian !! matrix and A is an n by k matrix in the first case and a k by n !! matrix in the second case. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine cherk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(in) :: a(lda,*) complex(sp), intent(inout) :: c(ldc,*) end subroutine cherk -#else - module procedure stdlib_cherk +#else + module procedure stdlib${ii}$_cherk #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$herk - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine zherk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(in) :: a(lda,*) complex(dp), intent(inout) :: c(ldc,*) end subroutine zherk -#else - module procedure stdlib_zherk +#else + module procedure stdlib${ii}$_zherk #endif - end interface herk - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$herk +#:endif +#:endfor +#:endfor + end interface herk interface hpmv !! HPMV 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 !! A is an n by n hermitian matrix, supplied in packed form. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine chpmv(uplo,n,alpha,ap,x,incx,beta,y,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(sp), intent(in) :: alpha,beta,ap(*),x(*) - integer(ilp), intent(in) :: incx,incy,n + integer(${ik}$), intent(in) :: incx,incy,n character, intent(in) :: uplo complex(sp), intent(inout) :: y(*) end subroutine chpmv -#else - module procedure stdlib_chpmv +#else + module procedure stdlib${ii}$_chpmv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hpmv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine zhpmv(uplo,n,alpha,ap,x,incx,beta,y,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(dp), intent(in) :: alpha,beta,ap(*),x(*) - integer(ilp), intent(in) :: incx,incy,n + integer(${ik}$), intent(in) :: incx,incy,n character, intent(in) :: uplo complex(dp), intent(inout) :: y(*) end subroutine zhpmv -#else - module procedure stdlib_zhpmv +#else + module procedure stdlib${ii}$_zhpmv #endif - end interface hpmv - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hpmv +#:endif +#:endfor +#:endfor + end interface hpmv interface hpr !! HPR 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 !! n by n hermitian matrix, supplied in packed form. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine chpr(uplo,n,alpha,x,incx,ap) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha - integer(ilp), intent(in) :: incx,n + integer(${ik}$), intent(in) :: incx,n character, intent(in) :: uplo complex(sp), intent(inout) :: ap(*) complex(sp), intent(in) :: x(*) end subroutine chpr -#else - module procedure stdlib_chpr +#else + module procedure stdlib${ii}$_chpr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hpr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine zhpr(uplo,n,alpha,x,incx,ap) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha - integer(ilp), intent(in) :: incx,n + integer(${ik}$), intent(in) :: incx,n character, intent(in) :: uplo complex(dp), intent(inout) :: ap(*) complex(dp), intent(in) :: x(*) end subroutine zhpr -#else - module procedure stdlib_zhpr +#else + module procedure stdlib${ii}$_zhpr #endif - end interface hpr - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hpr +#:endif +#:endfor +#:endfor + end interface hpr interface hpr2 !! HPR2 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 by n hermitian matrix, supplied in packed form. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine chpr2(uplo,n,alpha,x,incx,y,incy,ap) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(sp), intent(in) :: alpha,x(*),y(*) - integer(ilp), intent(in) :: incx,incy,n + integer(${ik}$), intent(in) :: incx,incy,n character, intent(in) :: uplo complex(sp), intent(inout) :: ap(*) end subroutine chpr2 -#else - module procedure stdlib_chpr2 +#else + module procedure stdlib${ii}$_chpr2 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hpr2 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine zhpr2(uplo,n,alpha,x,incx,y,incy,ap) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(dp), intent(in) :: alpha,x(*),y(*) - integer(ilp), intent(in) :: incx,incy,n + integer(${ik}$), intent(in) :: incx,incy,n character, intent(in) :: uplo complex(dp), intent(inout) :: ap(*) end subroutine zhpr2 -#else - module procedure stdlib_zhpr2 +#else + module procedure stdlib${ii}$_zhpr2 #endif - end interface hpr2 - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hpr2 +#:endif +#:endfor +#:endfor + end interface hpr2 interface nrm2 !! NRM2 returns the euclidean norm of a vector via the function !! name, so that !! NRM2 := sqrt( x'*x ) -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure real(dp) function dnrm2( n, x, incx ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n real(dp), intent(in) :: x(*) end function dnrm2 -#else - module procedure stdlib_dnrm2 +#else + module procedure stdlib${ii}$_dnrm2 #endif -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure real(dp) function dznrm2( n, x, incx ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n complex(dp), intent(in) :: x(*) end function dznrm2 -#else - module procedure stdlib_dznrm2 +#else + module procedure stdlib${ii}$_dznrm2 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$nrm2 -#:endif -#:endfor -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${c2ri(ri)}$znrm2 -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure real(sp) function snrm2( n, x, incx ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n real(sp), intent(in) :: x(*) end function snrm2 -#else - module procedure stdlib_snrm2 +#else + module procedure stdlib${ii}$_snrm2 #endif -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure real(sp) function scnrm2( n, x, incx ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n complex(sp), intent(in) :: x(*) end function scnrm2 -#else - module procedure stdlib_scnrm2 +#else + module procedure stdlib${ii}$_scnrm2 #endif +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$nrm2 +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${c2ri(ri)}$znrm2 +#:endif +#:endfor +#:endfor end interface nrm2 - - interface rot !! ROT applies a plane rotation. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine drot(n,dx,incx,dy,incy,c,s) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: c,s - integer(ilp), intent(in) :: incx,incy,n + integer(${ik}$), intent(in) :: incx,incy,n real(dp), intent(inout) :: dx(*),dy(*) end subroutine drot -#else - module procedure stdlib_drot +#else + module procedure stdlib${ii}$_drot #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$rot - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine srot(n,sx,incx,sy,incy,c,s) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: c,s - integer(ilp), intent(in) :: incx,incy,n + integer(${ik}$), intent(in) :: incx,incy,n real(sp), intent(inout) :: sx(*),sy(*) end subroutine srot -#else - module procedure stdlib_srot +#else + module procedure stdlib${ii}$_srot #endif +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$rot +#:endif +#:endfor +#:endfor end interface rot - - interface rotg !! The computation uses the formulas !! |x| = sqrt( Re(x)**2 + Im(x)**2 ) @@ -1120,256 +1086,251 @@ module stdlib_linalg_blas !! the same as in SROTG when |a| > |b|. When |b| >= |a|, the !! sign of c and s will be different from those computed by SROTG !! if the signs of a and b are not the same. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine crotg( a, b, c, s ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(out) :: c complex(sp), intent(inout) :: a complex(sp), intent(in) :: b complex(sp), intent(out) :: s end subroutine crotg -#else - module procedure stdlib_crotg +#:if not 'ilp64' in ik +#else + module procedure stdlib${ii}$_crotg +#:endif #endif -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine drotg( a, b, c, s ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(inout) :: a,b real(dp), intent(out) :: c,s end subroutine drotg -#else - module procedure stdlib_drotg -#endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$rotg - +#:if not 'ilp64' in ik +#else + module procedure stdlib${ii}$_drotg #:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#endif +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine srotg( a, b, c, s ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(inout) :: a,b real(sp), intent(out) :: c,s end subroutine srotg -#else - module procedure stdlib_srotg +#:if not 'ilp64' in ik +#else + module procedure stdlib${ii}$_srotg +#:endif #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$rotg - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine zrotg( a, b, c, s ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(out) :: c complex(dp), intent(inout) :: a complex(dp), intent(in) :: b complex(dp), intent(out) :: s end subroutine zrotg -#else - module procedure stdlib_zrotg +#:if not 'ilp64' in ik +#else + module procedure stdlib${ii}$_zrotg +#:endif #endif +#:endfor +#:for rk,rt,ri in RC_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$rotg +#:endif +#:endfor end interface rotg - - interface rotm - !! ROTM 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 - !! DX(LX+I*INCX), I = 0:N-1, where LX = 1 if INCX >= 0, else LX = (-INCX)*N, - !! and similarly for DY using LY and INCY. - !! With DPARAM(1)=DFLAG, \(H\) has one of the following forms: + !! ROTM 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 + !! DX(LX+I*INCX), I = 0:N-1, where LX = 1 if INCX >= 0, else LX = (-INCX)*N, + !! and similarly for DY using LY and INCY. + !! With DPARAM(1)=DFLAG, \(H\) has one of the following forms: !! $$ H=\underbrace{\begin{bmatrix}DH_{11} & DH_{12}\\DH_{21} & DH_{22}\end{bmatrix}}_{DFLAG=-1}, - !! \underbrace{\begin{bmatrix}1 & DH_{12}\\DH_{21} & 1\end{bmatrix}}_{DFLAG=0}, - !! \underbrace{\begin{bmatrix}DH_{11} & 1\\-1 & DH_{22}\end{bmatrix}}_{DFLAG=1}, - !! \underbrace{\begin{bmatrix}1 & 0\\0 & 1\end{bmatrix}}_{DFLAG=-2}. $$ - !! See ROTMG for a description of data storage in DPARAM. -#ifdef STDLIB_EXTERNAL_BLAS + !! \underbrace{\begin{bmatrix}1 & DH_{12}\\DH_{21} & 1\end{bmatrix}}_{DFLAG=0}, + !! \underbrace{\begin{bmatrix}DH_{11} & 1\\-1 & DH_{22}\end{bmatrix}}_{DFLAG=1}, + !! \underbrace{\begin{bmatrix}1 & 0\\0 & 1\end{bmatrix}}_{DFLAG=-2}. $$ + !! See ROTMG for a description of data storage in DPARAM. +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine drotm(n,dx,incx,dy,incy,dparam) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n real(dp), intent(in) :: dparam(5) real(dp), intent(inout) :: dx(*),dy(*) end subroutine drotm -#else - module procedure stdlib_drotm +#else + module procedure stdlib${ii}$_drotm #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$rotm - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine srotm(n,sx,incx,sy,incy,sparam) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n real(sp), intent(in) :: sparam(5) real(sp), intent(inout) :: sx(*),sy(*) end subroutine srotm -#else - module procedure stdlib_srotm +#else + module procedure stdlib${ii}$_srotm #endif +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$rotm +#:endif +#:endfor +#:endfor end interface rotm - - interface rotmg - !! ROTMG Constructs the modified Givens transformation matrix \(H\) which zeros the - !! second component of the 2-vector + !! ROTMG 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. $$ - !! With DPARAM(1)=DFLAG, \(H\) has one of the following forms: + !! With DPARAM(1)=DFLAG, \(H\) has one of the following forms: !! $$ H=\underbrace{\begin{bmatrix}DH_{11} & DH_{12}\\DH_{21} & DH_{22}\end{bmatrix}}_{DFLAG=-1}, - !! \underbrace{\begin{bmatrix}1 & DH_{12}\\DH_{21} & 1\end{bmatrix}}_{DFLAG=0}, - !! \underbrace{\begin{bmatrix}DH_{11} & 1\\-1 & DH_{22}\end{bmatrix}}_{DFLAG=1}, + !! \underbrace{\begin{bmatrix}1 & DH_{12}\\DH_{21} & 1\end{bmatrix}}_{DFLAG=0}, + !! \underbrace{\begin{bmatrix}DH_{11} & 1\\-1 & DH_{22}\end{bmatrix}}_{DFLAG=1}, !! \underbrace{\begin{bmatrix}1 & 0\\0 & 1\end{bmatrix}}_{DFLAG=-2}. $$ !! Locations 2-4 of DPARAM contain DH11, DH21, DH12 and DH22 respectively. !! (Values of 1.0, -1.0, or 0.0 implied by the value of DPARAM(1) are not stored in DPARAM.) - !! The values of parameters GAMSQ and RGAMSQ may be inexact. This is OK as they are only + !! The values of parameters GAMSQ and RGAMSQ may be inexact. This is OK as they are only !! used for testing the size of DD1 and DD2. All actual scaling of data is done using GAM. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine drotmg(dd1,dd2,dx1,dy1,dparam) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(inout) :: dd1,dd2,dx1 real(dp), intent(in) :: dy1 real(dp), intent(out) :: dparam(5) end subroutine drotmg -#else - module procedure stdlib_drotmg +#:if not 'ilp64' in ik +#else + module procedure stdlib${ii}$_drotmg +#:endif #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$rotmg - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine srotmg(sd1,sd2,sx1,sy1,sparam) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(inout) :: sd1,sd2,sx1 real(sp), intent(in) :: sy1 real(sp), intent(out) :: sparam(5) end subroutine srotmg -#else +#:if not 'ilp64' in ik +#else module procedure stdlib_srotmg +#:endif #endif +#:endfor +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$rotmg +#:endif +#:endfor end interface rotmg - - interface sbmv !! SBMV 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 !! A is an n by n symmetric band matrix, with k super-diagonals. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dsbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha,beta,a(lda,*),x(*) - integer(ilp), intent(in) :: incx,incy,k,lda,n + integer(${ik}$), intent(in) :: incx,incy,k,lda,n character, intent(in) :: uplo real(dp), intent(inout) :: y(*) end subroutine dsbmv -#else - module procedure stdlib_dsbmv +#else + module procedure stdlib${ii}$_dsbmv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sbmv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine ssbmv(uplo,n,k,alpha,a,lda,x,incx,beta,y,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha,beta,a(lda,*),x(*) - integer(ilp), intent(in) :: incx,incy,k,lda,n + integer(${ik}$), intent(in) :: incx,incy,k,lda,n character, intent(in) :: uplo real(sp), intent(inout) :: y(*) end subroutine ssbmv -#else - module procedure stdlib_ssbmv +#else + module procedure stdlib${ii}$_ssbmv #endif +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sbmv +#:endif +#:endfor +#:endfor end interface sbmv - - interface scal !! SCAL scales a vector by a constant. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine cscal(n,ca,cx,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(sp), intent(in) :: ca - integer(ilp), intent(in) :: incx,n + integer(${ik}$), intent(in) :: incx,n complex(sp), intent(inout) :: cx(*) end subroutine cscal -#else - module procedure stdlib_cscal +#else + module procedure stdlib${ii}$_cscal #endif -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dscal(n,da,dx,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: da - integer(ilp), intent(in) :: incx,n + integer(${ik}$), intent(in) :: incx,n real(dp), intent(inout) :: dx(*) end subroutine dscal -#else - module procedure stdlib_dscal +#else + module procedure stdlib${ii}$_dscal #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$scal - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine sscal(n,sa,sx,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: sa - integer(ilp), intent(in) :: incx,n + integer(${ik}$), intent(in) :: incx,n real(sp), intent(inout) :: sx(*) end subroutine sscal -#else - module procedure stdlib_sscal +#else + module procedure stdlib${ii}$_sscal #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$scal - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine zscal(n,za,zx,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(dp), intent(in) :: za - integer(ilp), intent(in) :: incx,n + integer(${ik}$), intent(in) :: incx,n complex(dp), intent(inout) :: zx(*) end subroutine zscal -#else - module procedure stdlib_zscal +#else + module procedure stdlib${ii}$_zscal #endif +#:for rk,rt,ri in RC_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$scal +#:endif +#:endfor +#:endfor end interface scal - - interface sdot !! Compute the inner product of two vectors with extended !! precision accumulation and result. @@ -1377,241 +1338,230 @@ module stdlib_linalg_blas !! SDOT = sum for I = 0 to N-1 of SX(LX+I*INCX) * SY(LY+I*INCY), !! where LX = 1 if INCX >= 0, else LX = 1+(1-N)*INCX, and LY is !! defined in a similar way using INCY. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#:if WITH_QP + !! Provide a unique interface to accumulate double precision reals + !! into the highest available precision. + module procedure stdlib${ii}$_qsdot +#:elif WITH_XDP + !! Provide a unique interface to accumulate double precision reals + !! into the highest available precision. + module procedure stdlib${ii}$_xsdot +#:endif +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure real(dp) function dsdot(n,sx,incx,sy,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n real(sp), intent(in) :: sx(*),sy(*) end function dsdot -#else - module procedure stdlib_dsdot +#else + module procedure stdlib${ii}$_dsdot #endif - -#:if WITH_QP - !! Provide a unique interface to accumulate double precision reals - !! into the highest available precision. - module procedure stdlib_qsdot -#:elif WITH_XDP - !! Provide a unique interface to accumulate double precision reals - !! into the highest available precision. - module procedure stdlib_xsdot -#:endif +#:endfor end interface sdot - - interface spmv !! SPMV 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 !! A is an n by n symmetric matrix, supplied in packed form. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dspmv(uplo,n,alpha,ap,x,incx,beta,y,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha,beta,ap(*),x(*) - integer(ilp), intent(in) :: incx,incy,n + integer(${ik}$), intent(in) :: incx,incy,n character, intent(in) :: uplo real(dp), intent(inout) :: y(*) end subroutine dspmv -#else - module procedure stdlib_dspmv +#else + module procedure stdlib${ii}$_dspmv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$spmv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine sspmv(uplo,n,alpha,ap,x,incx,beta,y,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha,beta,ap(*),x(*) - integer(ilp), intent(in) :: incx,incy,n + integer(${ik}$), intent(in) :: incx,incy,n character, intent(in) :: uplo real(sp), intent(inout) :: y(*) end subroutine sspmv -#else - module procedure stdlib_sspmv +#else + module procedure stdlib${ii}$_sspmv #endif +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$spmv +#:endif +#:endfor +#:endfor end interface spmv - - interface spr !! SPR 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 !! n by n symmetric matrix, supplied in packed form. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dspr(uplo,n,alpha,x,incx,ap) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha,x(*) - integer(ilp), intent(in) :: incx,n + integer(${ik}$), intent(in) :: incx,n character, intent(in) :: uplo real(dp), intent(inout) :: ap(*) end subroutine dspr -#else - module procedure stdlib_dspr -#endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$spr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#else + module procedure stdlib${ii}$_dspr +#endif +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine sspr(uplo,n,alpha,x,incx,ap) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha,x(*) - integer(ilp), intent(in) :: incx,n + integer(${ik}$), intent(in) :: incx,n character, intent(in) :: uplo real(sp), intent(inout) :: ap(*) end subroutine sspr -#else - module procedure stdlib_sspr +#else + module procedure stdlib${ii}$_sspr #endif +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$spr +#:endif +#:endfor +#:endfor end interface spr - - interface spr2 !! SPR2 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 by n symmetric matrix, supplied in packed form. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dspr2(uplo,n,alpha,x,incx,y,incy,ap) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha,x(*),y(*) - integer(ilp), intent(in) :: incx,incy,n + integer(${ik}$), intent(in) :: incx,incy,n character, intent(in) :: uplo real(dp), intent(inout) :: ap(*) end subroutine dspr2 -#else - module procedure stdlib_dspr2 +#else + module procedure stdlib${ii}$_dspr2 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$spr2 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine sspr2(uplo,n,alpha,x,incx,y,incy,ap) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha,x(*),y(*) - integer(ilp), intent(in) :: incx,incy,n + integer(${ik}$), intent(in) :: incx,incy,n character, intent(in) :: uplo real(sp), intent(inout) :: ap(*) end subroutine sspr2 -#else - module procedure stdlib_sspr2 +#else + module procedure stdlib${ii}$_sspr2 #endif +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$spr2 +#:endif +#:endfor +#:endfor end interface spr2 - - interface srot !! SROT 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. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine csrot( n, cx, incx, cy, incy, c, s ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n real(sp), intent(in) :: c,s complex(sp), intent(inout) :: cx(*),cy(*) end subroutine csrot -#else - module procedure stdlib_csrot +#else + module procedure stdlib${ii}$_csrot #endif +#:endfor end interface srot - - interface sscal !! SSCAL scales a complex vector by a real constant. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine csscal(n,sa,cx,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: sa - integer(ilp), intent(in) :: incx,n + integer(${ik}$), intent(in) :: incx,n complex(sp), intent(inout) :: cx(*) end subroutine csscal -#else - module procedure stdlib_csscal +#else + module procedure stdlib${ii}$_csscal #endif +#:endfor end interface sscal - - interface swap !! SWAP interchanges two vectors. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine cswap(n,cx,incx,cy,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n complex(sp), intent(inout) :: cx(*),cy(*) end subroutine cswap -#else - module procedure stdlib_cswap +#else + module procedure stdlib${ii}$_cswap #endif -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dswap(n,dx,incx,dy,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n real(dp), intent(inout) :: dx(*),dy(*) end subroutine dswap -#else - module procedure stdlib_dswap +#else + module procedure stdlib${ii}$_dswap #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$swap - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine sswap(n,sx,incx,sy,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n real(sp), intent(inout) :: sx(*),sy(*) end subroutine sswap -#else - module procedure stdlib_sswap +#else + module procedure stdlib${ii}$_sswap #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$swap - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine zswap(n,zx,incx,zy,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n complex(dp), intent(inout) :: zx(*),zy(*) end subroutine zswap -#else - module procedure stdlib_zswap +#else + module procedure stdlib${ii}$_zswap #endif +#:for rk,rt,ri in RC_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$swap +#:endif +#:endfor +#:endfor end interface swap - - interface symm !! SYMM performs one of the matrix-matrix operations !! C := alpha*A*B + beta*C, @@ -1619,187 +1569,177 @@ module stdlib_linalg_blas !! C := alpha*B*A + beta*C, !! where alpha and beta are scalars, A is a symmetric matrix and B and !! C are m by n matrices. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine csymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(sp), intent(in) :: alpha,beta,a(lda,*),b(ldb,*) - integer(ilp), intent(in) :: lda,ldb,ldc,m,n + integer(${ik}$), intent(in) :: lda,ldb,ldc,m,n character, intent(in) :: side,uplo complex(sp), intent(inout) :: c(ldc,*) end subroutine csymm -#else - module procedure stdlib_csymm +#else + module procedure stdlib${ii}$_csymm #endif -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dsymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha,beta,a(lda,*),b(ldb,*) - integer(ilp), intent(in) :: lda,ldb,ldc,m,n + integer(${ik}$), intent(in) :: lda,ldb,ldc,m,n character, intent(in) :: side,uplo real(dp), intent(inout) :: c(ldc,*) end subroutine dsymm -#else - module procedure stdlib_dsymm +#else + module procedure stdlib${ii}$_dsymm #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$symm - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine ssymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha,beta,a(lda,*),b(ldb,*) - integer(ilp), intent(in) :: lda,ldb,ldc,m,n + integer(${ik}$), intent(in) :: lda,ldb,ldc,m,n character, intent(in) :: side,uplo real(sp), intent(inout) :: c(ldc,*) end subroutine ssymm -#else - module procedure stdlib_ssymm +#else + module procedure stdlib${ii}$_ssymm #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$symm - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine zsymm(side,uplo,m,n,alpha,a,lda,b,ldb,beta,c,ldc) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(dp), intent(in) :: alpha,beta,a(lda,*),b(ldb,*) - integer(ilp), intent(in) :: lda,ldb,ldc,m,n + integer(${ik}$), intent(in) :: lda,ldb,ldc,m,n character, intent(in) :: side,uplo complex(dp), intent(inout) :: c(ldc,*) end subroutine zsymm -#else - module procedure stdlib_zsymm +#else + module procedure stdlib${ii}$_zsymm #endif +#:for rk,rt,ri in RC_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$symm +#:endif +#:endfor +#:endfor end interface symm - - interface symv !! SYMV 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 !! A is an n by n symmetric matrix. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dsymv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha,beta,a(lda,*),x(*) - integer(ilp), intent(in) :: incx,incy,lda,n + integer(${ik}$), intent(in) :: incx,incy,lda,n character, intent(in) :: uplo real(dp), intent(inout) :: y(*) end subroutine dsymv -#else - module procedure stdlib_dsymv +#else + module procedure stdlib${ii}$_dsymv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$symv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine ssymv(uplo,n,alpha,a,lda,x,incx,beta,y,incy) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha,beta,a(lda,*),x(*) - integer(ilp), intent(in) :: incx,incy,lda,n + integer(${ik}$), intent(in) :: incx,incy,lda,n character, intent(in) :: uplo real(sp), intent(inout) :: y(*) end subroutine ssymv -#else - module procedure stdlib_ssymv +#else + module procedure stdlib${ii}$_ssymv #endif +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$symv +#:endif +#:endfor +#:endfor end interface symv - - interface syr !! SYR 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 !! n by n symmetric matrix. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dsyr(uplo,n,alpha,x,incx,a,lda) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha,x(*) - integer(ilp), intent(in) :: incx,lda,n + integer(${ik}$), intent(in) :: incx,lda,n character, intent(in) :: uplo real(dp), intent(inout) :: a(lda,*) end subroutine dsyr -#else - module procedure stdlib_dsyr +#else + module procedure stdlib${ii}$_dsyr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$syr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine ssyr(uplo,n,alpha,x,incx,a,lda) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha,x(*) - integer(ilp), intent(in) :: incx,lda,n + integer(${ik}$), intent(in) :: incx,lda,n character, intent(in) :: uplo real(sp), intent(inout) :: a(lda,*) end subroutine ssyr -#else - module procedure stdlib_ssyr +#else + module procedure stdlib${ii}$_ssyr #endif +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$syr +#:endif +#:endfor +#:endfor end interface syr - - interface syr2 !! SYR2 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 !! by n symmetric matrix. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dsyr2(uplo,n,alpha,x,incx,y,incy,a,lda) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha,x(*),y(*) - integer(ilp), intent(in) :: incx,incy,lda,n + integer(${ik}$), intent(in) :: incx,incy,lda,n character, intent(in) :: uplo real(dp), intent(inout) :: a(lda,*) end subroutine dsyr2 -#else - module procedure stdlib_dsyr2 +#else + module procedure stdlib${ii}$_dsyr2 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$syr2 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine ssyr2(uplo,n,alpha,x,incx,y,incy,a,lda) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha,x(*),y(*) - integer(ilp), intent(in) :: incx,incy,lda,n + integer(${ik}$), intent(in) :: incx,incy,lda,n character, intent(in) :: uplo real(sp), intent(inout) :: a(lda,*) end subroutine ssyr2 -#else - module procedure stdlib_ssyr2 +#else + module procedure stdlib${ii}$_ssyr2 #endif +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$syr2 +#:endif +#:endfor +#:endfor end interface syr2 - - interface syr2k !! SYR2K performs one of the symmetric rank 2k operations !! C := alpha*A*B**T + alpha*B*A**T + beta*C, @@ -1808,70 +1748,63 @@ module stdlib_linalg_blas !! where alpha and beta are scalars, C is an n by n symmetric matrix !! and A and B are n by k matrices in the first case and k by n !! matrices in the second case. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine csyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(sp), intent(in) :: alpha,beta,a(lda,*),b(ldb,*) - integer(ilp), intent(in) :: k,lda,ldb,ldc,n + integer(${ik}$), intent(in) :: k,lda,ldb,ldc,n character, intent(in) :: trans,uplo complex(sp), intent(inout) :: c(ldc,*) end subroutine csyr2k -#else - module procedure stdlib_csyr2k +#else + module procedure stdlib${ii}$_csyr2k #endif -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dsyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha,beta,a(lda,*),b(ldb,*) - integer(ilp), intent(in) :: k,lda,ldb,ldc,n + integer(${ik}$), intent(in) :: k,lda,ldb,ldc,n character, intent(in) :: trans,uplo real(dp), intent(inout) :: c(ldc,*) end subroutine dsyr2k -#else - module procedure stdlib_dsyr2k +#else + module procedure stdlib${ii}$_dsyr2k #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$syr2k - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine ssyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha,beta,a(lda,*),b(ldb,*) - integer(ilp), intent(in) :: k,lda,ldb,ldc,n + integer(${ik}$), intent(in) :: k,lda,ldb,ldc,n character, intent(in) :: trans,uplo real(sp), intent(inout) :: c(ldc,*) end subroutine ssyr2k -#else - module procedure stdlib_ssyr2k +#else + module procedure stdlib${ii}$_ssyr2k #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$syr2k - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine zsyr2k(uplo,trans,n,k,alpha,a,lda,b,ldb,beta,c,ldc) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(dp), intent(in) :: alpha,beta,a(lda,*),b(ldb,*) - integer(ilp), intent(in) :: k,lda,ldb,ldc,n + integer(${ik}$), intent(in) :: k,lda,ldb,ldc,n character, intent(in) :: trans,uplo complex(dp), intent(inout) :: c(ldc,*) end subroutine zsyr2k -#else - module procedure stdlib_zsyr2k +#else + module procedure stdlib${ii}$_zsyr2k #endif +#:for rk,rt,ri in RC_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$syr2k +#:endif +#:endfor +#:endfor end interface syr2k - - interface syrk !! SYRK performs one of the symmetric rank k operations !! C := alpha*A*A**T + beta*C, @@ -1880,139 +1813,125 @@ module stdlib_linalg_blas !! where alpha and beta are scalars, C is an n by n symmetric matrix !! and A is an n by k matrix in the first case and a k by n matrix !! in the second case. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine csyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(sp), intent(in) :: alpha,beta,a(lda,*) - integer(ilp), intent(in) :: k,lda,ldc,n + integer(${ik}$), intent(in) :: k,lda,ldc,n character, intent(in) :: trans,uplo complex(sp), intent(inout) :: c(ldc,*) end subroutine csyrk -#else - module procedure stdlib_csyrk +#else + module procedure stdlib${ii}$_csyrk #endif -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dsyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha,beta,a(lda,*) - integer(ilp), intent(in) :: k,lda,ldc,n + integer(${ik}$), intent(in) :: k,lda,ldc,n character, intent(in) :: trans,uplo real(dp), intent(inout) :: c(ldc,*) end subroutine dsyrk -#else - module procedure stdlib_dsyrk +#else + module procedure stdlib${ii}$_dsyrk #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$syrk - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine ssyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha,beta,a(lda,*) - integer(ilp), intent(in) :: k,lda,ldc,n + integer(${ik}$), intent(in) :: k,lda,ldc,n character, intent(in) :: trans,uplo real(sp), intent(inout) :: c(ldc,*) end subroutine ssyrk -#else - module procedure stdlib_ssyrk +#else + module procedure stdlib${ii}$_ssyrk #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$syrk - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine zsyrk(uplo,trans,n,k,alpha,a,lda,beta,c,ldc) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(dp), intent(in) :: alpha,beta,a(lda,*) - integer(ilp), intent(in) :: k,lda,ldc,n + integer(${ik}$), intent(in) :: k,lda,ldc,n character, intent(in) :: trans,uplo complex(dp), intent(inout) :: c(ldc,*) end subroutine zsyrk -#else - module procedure stdlib_zsyrk +#else + module procedure stdlib${ii}$_zsyrk #endif +#:for rk,rt,ri in RC_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$syrk +#:endif +#:endfor +#:endfor end interface syrk - - interface tbmv !! TBMV 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, !! upper or lower triangular band matrix, with ( k + 1 ) diagonals. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine ctbmv(uplo,trans,diag,n,k,a,lda,x,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,k,lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,k,lda,n character, intent(in) :: diag,trans,uplo complex(sp), intent(in) :: a(lda,*) complex(sp), intent(inout) :: x(*) end subroutine ctbmv -#else - module procedure stdlib_ctbmv +#else + module procedure stdlib${ii}$_ctbmv #endif -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dtbmv(uplo,trans,diag,n,k,a,lda,x,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,k,lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,k,lda,n character, intent(in) :: diag,trans,uplo real(dp), intent(in) :: a(lda,*) real(dp), intent(inout) :: x(*) end subroutine dtbmv -#else - module procedure stdlib_dtbmv +#else + module procedure stdlib${ii}$_dtbmv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tbmv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine stbmv(uplo,trans,diag,n,k,a,lda,x,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,k,lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,k,lda,n character, intent(in) :: diag,trans,uplo real(sp), intent(in) :: a(lda,*) real(sp), intent(inout) :: x(*) end subroutine stbmv -#else - module procedure stdlib_stbmv +#else + module procedure stdlib${ii}$_stbmv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tbmv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine ztbmv(uplo,trans,diag,n,k,a,lda,x,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,k,lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,k,lda,n character, intent(in) :: diag,trans,uplo complex(dp), intent(in) :: a(lda,*) complex(dp), intent(inout) :: x(*) end subroutine ztbmv -#else - module procedure stdlib_ztbmv +#else + module procedure stdlib${ii}$_ztbmv #endif +#:for rk,rt,ri in RC_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tbmv +#:endif +#:endfor +#:endfor end interface tbmv - - interface tbsv !! TBSV solves one of the systems of equations !! A*x = b, or A**T*x = b, or A**H*x = b, @@ -2021,139 +1940,125 @@ module stdlib_linalg_blas !! diagonals. !! No test for singularity or near-singularity is included in this !! routine. Such tests must be performed before calling this routine. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine ctbsv(uplo,trans,diag,n,k,a,lda,x,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,k,lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,k,lda,n character, intent(in) :: diag,trans,uplo complex(sp), intent(in) :: a(lda,*) complex(sp), intent(inout) :: x(*) end subroutine ctbsv -#else - module procedure stdlib_ctbsv +#else + module procedure stdlib${ii}$_ctbsv #endif -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dtbsv(uplo,trans,diag,n,k,a,lda,x,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,k,lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,k,lda,n character, intent(in) :: diag,trans,uplo real(dp), intent(in) :: a(lda,*) real(dp), intent(inout) :: x(*) end subroutine dtbsv -#else - module procedure stdlib_dtbsv +#else + module procedure stdlib${ii}$_dtbsv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tbsv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine stbsv(uplo,trans,diag,n,k,a,lda,x,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,k,lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,k,lda,n character, intent(in) :: diag,trans,uplo real(sp), intent(in) :: a(lda,*) real(sp), intent(inout) :: x(*) end subroutine stbsv -#else - module procedure stdlib_stbsv +#else + module procedure stdlib${ii}$_stbsv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tbsv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine ztbsv(uplo,trans,diag,n,k,a,lda,x,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,k,lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,k,lda,n character, intent(in) :: diag,trans,uplo complex(dp), intent(in) :: a(lda,*) complex(dp), intent(inout) :: x(*) end subroutine ztbsv -#else - module procedure stdlib_ztbsv +#else + module procedure stdlib${ii}$_ztbsv #endif +#:for rk,rt,ri in RC_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tbsv +#:endif +#:endfor +#:endfor end interface tbsv - - interface tpmv !! TPMV 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, !! upper or lower triangular matrix, supplied in packed form. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine ctpmv(uplo,trans,diag,n,ap,x,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n character, intent(in) :: diag,trans,uplo complex(sp), intent(in) :: ap(*) complex(sp), intent(inout) :: x(*) end subroutine ctpmv -#else - module procedure stdlib_ctpmv +#else + module procedure stdlib${ii}$_ctpmv #endif -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dtpmv(uplo,trans,diag,n,ap,x,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n character, intent(in) :: diag,trans,uplo real(dp), intent(in) :: ap(*) real(dp), intent(inout) :: x(*) end subroutine dtpmv -#else - module procedure stdlib_dtpmv +#else + module procedure stdlib${ii}$_dtpmv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tpmv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine stpmv(uplo,trans,diag,n,ap,x,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n character, intent(in) :: diag,trans,uplo real(sp), intent(in) :: ap(*) real(sp), intent(inout) :: x(*) end subroutine stpmv -#else - module procedure stdlib_stpmv +#else + module procedure stdlib${ii}$_stpmv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tpmv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine ztpmv(uplo,trans,diag,n,ap,x,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n character, intent(in) :: diag,trans,uplo complex(dp), intent(in) :: ap(*) complex(dp), intent(inout) :: x(*) end subroutine ztpmv -#else - module procedure stdlib_ztpmv +#else + module procedure stdlib${ii}$_ztpmv #endif +#:for rk,rt,ri in RC_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tpmv +#:endif +#:endfor +#:endfor end interface tpmv - - interface tpsv !! TPSV solves one of the systems of equations !! A*x = b, or A**T*x = b, or A**H*x = b, @@ -2161,209 +2066,188 @@ module stdlib_linalg_blas !! non-unit, upper or lower triangular matrix, supplied in packed form. !! No test for singularity or near-singularity is included in this !! routine. Such tests must be performed before calling this routine. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine ctpsv(uplo,trans,diag,n,ap,x,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n character, intent(in) :: diag,trans,uplo complex(sp), intent(in) :: ap(*) complex(sp), intent(inout) :: x(*) end subroutine ctpsv -#else - module procedure stdlib_ctpsv +#else + module procedure stdlib${ii}$_ctpsv #endif -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dtpsv(uplo,trans,diag,n,ap,x,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n character, intent(in) :: diag,trans,uplo real(dp), intent(in) :: ap(*) real(dp), intent(inout) :: x(*) end subroutine dtpsv -#else - module procedure stdlib_dtpsv +#else + module procedure stdlib${ii}$_dtpsv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tpsv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine stpsv(uplo,trans,diag,n,ap,x,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n character, intent(in) :: diag,trans,uplo real(sp), intent(in) :: ap(*) real(sp), intent(inout) :: x(*) end subroutine stpsv -#else - module procedure stdlib_stpsv +#else + module procedure stdlib${ii}$_stpsv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tpsv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine ztpsv(uplo,trans,diag,n,ap,x,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n character, intent(in) :: diag,trans,uplo complex(dp), intent(in) :: ap(*) complex(dp), intent(inout) :: x(*) end subroutine ztpsv -#else - module procedure stdlib_ztpsv +#else + module procedure stdlib${ii}$_ztpsv #endif +#:for rk,rt,ri in RC_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tpsv +#:endif +#:endfor +#:endfor end interface tpsv - - interface trmm !! TRMM 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 !! non-unit, upper or lower triangular matrix and op( A ) is one of !! op( A ) = A or op( A ) = A**T or op( A ) = A**H. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine ctrmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(sp), intent(in) :: alpha,a(lda,*) - integer(ilp), intent(in) :: lda,ldb,m,n + integer(${ik}$), intent(in) :: lda,ldb,m,n character, intent(in) :: diag,side,transa,uplo complex(sp), intent(inout) :: b(ldb,*) end subroutine ctrmm -#else - module procedure stdlib_ctrmm +#else + module procedure stdlib${ii}$_ctrmm #endif -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dtrmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha,a(lda,*) - integer(ilp), intent(in) :: lda,ldb,m,n + integer(${ik}$), intent(in) :: lda,ldb,m,n character, intent(in) :: diag,side,transa,uplo real(dp), intent(inout) :: b(ldb,*) end subroutine dtrmm -#else - module procedure stdlib_dtrmm +#else + module procedure stdlib${ii}$_dtrmm #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trmm - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine strmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha,a(lda,*) - integer(ilp), intent(in) :: lda,ldb,m,n + integer(${ik}$), intent(in) :: lda,ldb,m,n character, intent(in) :: diag,side,transa,uplo real(sp), intent(inout) :: b(ldb,*) end subroutine strmm -#else - module procedure stdlib_strmm +#else + module procedure stdlib${ii}$_strmm #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trmm - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine ztrmm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(dp), intent(in) :: alpha,a(lda,*) - integer(ilp), intent(in) :: lda,ldb,m,n + integer(${ik}$), intent(in) :: lda,ldb,m,n character, intent(in) :: diag,side,transa,uplo complex(dp), intent(inout) :: b(ldb,*) end subroutine ztrmm -#else - module procedure stdlib_ztrmm +#else + module procedure stdlib${ii}$_ztrmm #endif +#:for rk,rt,ri in RC_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trmm +#:endif +#:endfor +#:endfor end interface trmm - - interface trmv !! TRMV 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, !! upper or lower triangular matrix. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine ctrmv(uplo,trans,diag,n,a,lda,x,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,lda,n character, intent(in) :: diag,trans,uplo complex(sp), intent(in) :: a(lda,*) complex(sp), intent(inout) :: x(*) end subroutine ctrmv -#else - module procedure stdlib_ctrmv +#else + module procedure stdlib${ii}$_ctrmv #endif -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dtrmv(uplo,trans,diag,n,a,lda,x,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,lda,n character, intent(in) :: diag,trans,uplo real(dp), intent(in) :: a(lda,*) real(dp), intent(inout) :: x(*) end subroutine dtrmv -#else - module procedure stdlib_dtrmv +#else + module procedure stdlib${ii}$_dtrmv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trmv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine strmv(uplo,trans,diag,n,a,lda,x,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,lda,n character, intent(in) :: diag,trans,uplo real(sp), intent(in) :: a(lda,*) real(sp), intent(inout) :: x(*) end subroutine strmv -#else - module procedure stdlib_strmv +#else + module procedure stdlib${ii}$_strmv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trmv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine ztrmv(uplo,trans,diag,n,a,lda,x,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,lda,n character, intent(in) :: diag,trans,uplo complex(dp), intent(in) :: a(lda,*) complex(dp), intent(inout) :: x(*) end subroutine ztrmv -#else - module procedure stdlib_ztrmv +#else + module procedure stdlib${ii}$_ztrmv #endif +#:for rk,rt,ri in RC_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trmv +#:endif +#:endfor +#:endfor end interface trmv - - interface trsm !! TRSM solves one of the matrix equations !! op( A )*X = alpha*B, or X*op( A ) = alpha*B, @@ -2371,70 +2255,63 @@ module stdlib_linalg_blas !! non-unit, upper or lower triangular matrix and op( A ) is one of !! op( A ) = A or op( A ) = A**T or op( A ) = A**H. !! The matrix X is overwritten on B. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine ctrsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(sp), intent(in) :: alpha,a(lda,*) - integer(ilp), intent(in) :: lda,ldb,m,n + integer(${ik}$), intent(in) :: lda,ldb,m,n character, intent(in) :: diag,side,transa,uplo complex(sp), intent(inout) :: b(ldb,*) end subroutine ctrsm -#else - module procedure stdlib_ctrsm +#else + module procedure stdlib${ii}$_ctrsm #endif -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dtrsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha,a(lda,*) - integer(ilp), intent(in) :: lda,ldb,m,n + integer(${ik}$), intent(in) :: lda,ldb,m,n character, intent(in) :: diag,side,transa,uplo real(dp), intent(inout) :: b(ldb,*) end subroutine dtrsm -#else - module procedure stdlib_dtrsm +#else + module procedure stdlib${ii}$_dtrsm #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trsm - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine strsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha,a(lda,*) - integer(ilp), intent(in) :: lda,ldb,m,n + integer(${ik}$), intent(in) :: lda,ldb,m,n character, intent(in) :: diag,side,transa,uplo real(sp), intent(inout) :: b(ldb,*) end subroutine strsm -#else - module procedure stdlib_strsm +#else + module procedure stdlib${ii}$_strsm #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trsm - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine ztrsm(side,uplo,transa,diag,m,n,alpha,a,lda,b,ldb) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(dp), intent(in) :: alpha,a(lda,*) - integer(ilp), intent(in) :: lda,ldb,m,n + integer(${ik}$), intent(in) :: lda,ldb,m,n character, intent(in) :: diag,side,transa,uplo complex(dp), intent(inout) :: b(ldb,*) end subroutine ztrsm -#else - module procedure stdlib_ztrsm +#else + module procedure stdlib${ii}$_ztrsm #endif +#:for rk,rt,ri in RC_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trsm +#:endif +#:endfor +#:endfor end interface trsm - - interface trsv !! TRSV solves one of the systems of equations !! A*x = b, or A**T*x = b, or A**H*x = b, @@ -2442,70 +2319,61 @@ module stdlib_linalg_blas !! non-unit, upper or lower triangular matrix. !! No test for singularity or near-singularity is included in this !! routine. Such tests must be performed before calling this routine. -#ifdef STDLIB_EXTERNAL_BLAS +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine ctrsv(uplo,trans,diag,n,a,lda,x,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,lda,n character, intent(in) :: diag,trans,uplo complex(sp), intent(in) :: a(lda,*) complex(sp), intent(inout) :: x(*) end subroutine ctrsv -#else - module procedure stdlib_ctrsv +#else + module procedure stdlib${ii}$_ctrsv #endif -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine dtrsv(uplo,trans,diag,n,a,lda,x,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,lda,n character, intent(in) :: diag,trans,uplo real(dp), intent(in) :: a(lda,*) real(dp), intent(inout) :: x(*) end subroutine dtrsv -#else - module procedure stdlib_dtrsv +#else + module procedure stdlib${ii}$_dtrsv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trsv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine strsv(uplo,trans,diag,n,a,lda,x,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,lda,n character, intent(in) :: diag,trans,uplo real(sp), intent(in) :: a(lda,*) real(sp), intent(inout) :: x(*) end subroutine strsv -#else - module procedure stdlib_strsv +#else + module procedure stdlib${ii}$_strsv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trsv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_BLAS +#ifdef STDLIB_EXTERNAL_BLAS${ii}$ pure subroutine ztrsv(uplo,trans,diag,n,a,lda,x,incx) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,lda,n character, intent(in) :: diag,trans,uplo complex(dp), intent(in) :: a(lda,*) complex(dp), intent(inout) :: x(*) end subroutine ztrsv -#else - module procedure stdlib_ztrsv +#else + module procedure stdlib${ii}$_ztrsv #endif +#:for rk,rt,ri in RC_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trsv +#:endif +#:endfor +#:endfor end interface trsv - - - - end module stdlib_linalg_blas diff --git a/src/stdlib_linalg_blas_aux.fypp b/src/stdlib_linalg_blas_aux.fypp index 84b2ebdec..692d7b8fa 100644 --- a/src/stdlib_linalg_blas_aux.fypp +++ b/src/stdlib_linalg_blas_aux.fypp @@ -8,19 +8,21 @@ 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 - + contains @@ -57,13 +59,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 +88,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 +100,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 +131,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 @@ -143,36 +146,36 @@ 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_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 +186,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 +230,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 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 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 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 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 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}$ 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 diff --git a/src/stdlib_linalg_constants.fypp b/src/stdlib_linalg_constants.fypp index 4f9d565b6..69071172e 100644 --- a/src/stdlib_linalg_constants.fypp +++ b/src/stdlib_linalg_constants.fypp @@ -6,9 +6,36 @@ module stdlib_linalg_constants implicit none(type,external) public + ! Checks whether BLAS is provided by an external library +#ifdef STDLIB_EXTERNAL_BLAS + logical(lk), parameter :: external_blas_ilp32 = .true._lk +#else + logical(lk), parameter :: external_blas_ilp32 = .false._lk +#endif +#ifdef STDLIB_EXTERNAL_BLAS_I64 + logical(lk), parameter :: external_blas_ilp64 = .true._lk +#else + logical(lk), parameter :: external_blas_ilp64 = .false._lk +#endif - ! Integer size support for ILP64 builds should be done here - integer, parameter :: ilp = int32 - private :: int32, int64 +#ifdef STDLIB_EXTERNAL_LAPACK + logical(lk), parameter :: external_lapack_ilp32 = .true._lk +#else + logical(lk), parameter :: external_lapack_ilp32 = .false._lk +#endif +#ifdef STDLIB_EXTERNAL_LAPACK_I64 + logical(lk), parameter :: external_lapack_ilp64 = .true._lk +#else + logical(lk), parameter :: external_lapack_ilp64 = .false._lk +#endif + + ! Generic checks for external libraries + logical(lk), parameter :: external_blas = external_blas_ilp32 .or. external_blas_ilp64 + logical(lk), parameter :: external_lapack = external_lapack_ilp32 .or. external_lapack_ilp64 + ! Support both 32-bit (ilp) and 64-bit (ilp64) integer kinds + integer, parameter :: ilp = int32 + integer, parameter :: ilp64 = #{if WITH_ILP64}# int64 #{else}# -1 #{endif}# + private :: int32, int64 + end module stdlib_linalg_constants diff --git a/src/stdlib_linalg_lapack.fypp b/src/stdlib_linalg_lapack.fypp index e24eb5496..9fcb3f001 100644 --- a/src/stdlib_linalg_lapack.fypp +++ b/src/stdlib_linalg_lapack.fypp @@ -1,4 +1,4 @@ -#:include "common.fypp" +#:include "common.fypp" #:set RC_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES module stdlib_linalg_lapack use stdlib_linalg_constants @@ -6,10 +6,10 @@ module stdlib_linalg_lapack use stdlib_linalg_lapack_aux #:for rk,rt,ri in RC_KINDS_TYPES use stdlib_linalg_lapack_${ri}$ - #:endfor + #:endfor implicit none(type,external) public - + interface bbcsd !! BBCSD computes the CS decomposition of a unitary matrix in !! bidiagonal-block form, @@ -18,7 +18,8 @@ module stdlib_linalg_lapack !! X = [----------------] !! [ B21 | B22 0 0 ] !! [ 0 | 0 0 I ] - !! [ C | -S 0 0 ] + !! [ C | -S 0 0 ] + !! !! [ U1 | ] [ 0 | 0 -I 0 ] [ V1 | ]**H !! = [---------] [---------------] [---------] . !! [ | U2 ] [ S | C 0 0 ] [ | V2 ] @@ -32,92 +33,34 @@ module stdlib_linalg_lapack !! The unitary matrices U1, U2, V1T, and V2T are input/output. !! The input matrices are pre- or post-multiplied by the appropriate !! singular vector matrices. -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine cbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, phi, & +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#:for rk,rt,ri in RC_KINDS_TYPES +#:if rk in ["sp","dp"] +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine ${ri}$bbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, phi, & u1, ldu1, u2, ldu2, v1t, ldv1t,v2t, ldv2t, b11d, b11e, b12d, b12e, b21d, b21e,b22d,& b22e, rwork, lrwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - character, intent(in) :: jobu1,jobu2,jobv1t,jobv2t,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldu1,ldu2,ldv1t,ldv2t,lrwork,m,p,q - real(sp), intent(out) :: b11d(*),b11e(*),b12d(*),b12e(*),b21d(*),b21e(*),b22d(& - *),b22e(*),rwork(*) - real(sp), intent(inout) :: phi(*),theta(*) - complex(sp), intent(inout) :: u1(ldu1,*),u2(ldu2,*),v1t(ldv1t,*),v2t(ldv2t,*) - - end subroutine cbbcsd -#else - module procedure stdlib_cbbcsd -#endif -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine dbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, phi, & - u1, ldu1, u2, ldu2, v1t, ldv1t,v2t, ldv2t, b11d, b11e, b12d, b12e, b21d, b21e,b22d,& - b22e, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobu1,jobu2,jobv1t,jobv2t,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldu1,ldu2,ldv1t,ldv2t,lwork,m,p,q - real(dp), intent(out) :: b11d(*),b11e(*),b12d(*),b12e(*),b21d(*),b21e(*),b22d(& - *),b22e(*),work(*) - real(dp), intent(inout) :: phi(*),theta(*),u1(ldu1,*),u2(ldu2,*),v1t(ldv1t,*),& - v2t(ldv2t,*) - end subroutine dbbcsd -#else - module procedure stdlib_dbbcsd -#endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$bbcsd + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldu1,ldu2,ldv1t,ldv2t,lrwork,m,p,q + real(${rk}$), intent(out) :: b11d(*),b11e(*),b12d(*),b12e(*),b21d(*),b21e(*),& + b22d(*),b22e(*),rwork(*) + real(${rk}$), intent(inout) :: phi(*),theta(*) + ${rt}$, intent(inout) :: u1(ldu1,*),u2(ldu2,*),v1t(ldv1t,*),v2t(ldv2t,*) + end subroutine ${ri}$bbcsd +#else #:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine sbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, phi, & - u1, ldu1, u2, ldu2, v1t, ldv1t,v2t, ldv2t, b11d, b11e, b12d, b12e, b21d, b21e,b22d,& - b22e, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - character, intent(in) :: jobu1,jobu2,jobv1t,jobv2t,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldu1,ldu2,ldv1t,ldv2t,lwork,m,p,q - real(sp), intent(out) :: b11d(*),b11e(*),b12d(*),b12e(*),b21d(*),b21e(*),b22d(& - *),b22e(*),work(*) - real(sp), intent(inout) :: phi(*),theta(*),u1(ldu1,*),u2(ldu2,*),v1t(ldv1t,*),& - v2t(ldv2t,*) - end subroutine sbbcsd -#else - module procedure stdlib_sbbcsd + module procedure stdlib${ii}$_${ri}$bbcsd +#:if rk in ["sp","dp"] #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$bbcsd - #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine zbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, phi, & - u1, ldu1, u2, ldu2, v1t, ldv1t,v2t, ldv2t, b11d, b11e, b12d, b12e, b21d, b21e,b22d,& - b22e, rwork, lrwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - character, intent(in) :: jobu1,jobu2,jobv1t,jobv2t,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldu1,ldu2,ldv1t,ldv2t,lrwork,m,p,q - real(dp), intent(out) :: b11d(*),b11e(*),b12d(*),b12e(*),b21d(*),b21e(*),b22d(& - *),b22e(*),rwork(*) - real(dp), intent(inout) :: phi(*),theta(*) - complex(dp), intent(inout) :: u1(ldu1,*),u2(ldu2,*),v1t(ldv1t,*),v2t(ldv2t,*) - - end subroutine zbbcsd -#else - module procedure stdlib_zbbcsd -#endif +#:endfor end interface bbcsd - - interface bdsdc !! BDSDC computes the singular value decomposition (SVD) of a real !! N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT, @@ -135,43 +78,43 @@ module stdlib_linalg_lapack !! The code currently calls DLASDQ if singular values only are desired. !! However, it can be slightly modified to compute singular values !! using the divide and conquer method. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dbdsdc( uplo, compq, n, d, e, u, ldu, vt, ldvt, q, iq,work, iwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compq,uplo - integer(ilp), intent(out) :: info,iq(*),iwork(*) - integer(ilp), intent(in) :: ldu,ldvt,n + integer(${ik}$), intent(out) :: info,iq(*),iwork(*) + integer(${ik}$), intent(in) :: ldu,ldvt,n real(dp), intent(inout) :: d(*),e(*) real(dp), intent(out) :: q(*),u(ldu,*),vt(ldvt,*),work(*) end subroutine dbdsdc -#else - module procedure stdlib_dbdsdc +#else + module procedure stdlib${ii}$_dbdsdc #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$bdsdc - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sbdsdc( uplo, compq, n, d, e, u, ldu, vt, ldvt, q, iq,work, iwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compq,uplo - integer(ilp), intent(out) :: info,iq(*),iwork(*) - integer(ilp), intent(in) :: ldu,ldvt,n + integer(${ik}$), intent(out) :: info,iq(*),iwork(*) + integer(${ik}$), intent(in) :: ldu,ldvt,n real(sp), intent(inout) :: d(*),e(*) real(sp), intent(out) :: q(*),u(ldu,*),vt(ldvt,*),work(*) end subroutine sbdsdc -#else - module procedure stdlib_sbdsdc +#else + module procedure stdlib${ii}$_sbdsdc #endif - end interface bdsdc - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$bdsdc +#:endif +#:endfor +#:endfor + end interface bdsdc interface bdsqr !! BDSQR computes the singular values and, optionally, the right and/or @@ -198,79 +141,79 @@ module stdlib_linalg_lapack !! B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics !! Department, University of California at Berkeley, July 1992 !! for a detailed description of the algorithm. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cbdsqr( uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u,ldu, c, ldc, & rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldc,ldu,ldvt,n,ncc,ncvt,nru + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldc,ldu,ldvt,n,ncc,ncvt,nru real(sp), intent(inout) :: d(*),e(*) real(sp), intent(out) :: rwork(*) complex(sp), intent(inout) :: c(ldc,*),u(ldu,*),vt(ldvt,*) end subroutine cbdsqr -#else - module procedure stdlib_cbdsqr +#else + module procedure stdlib${ii}$_cbdsqr #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dbdsqr( uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u,ldu, c, ldc, & work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldc,ldu,ldvt,n,ncc,ncvt,nru + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldc,ldu,ldvt,n,ncc,ncvt,nru real(dp), intent(inout) :: c(ldc,*),d(*),e(*),u(ldu,*),vt(ldvt,*) real(dp), intent(out) :: work(*) end subroutine dbdsqr -#else - module procedure stdlib_dbdsqr +#else + module procedure stdlib${ii}$_dbdsqr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$bdsqr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sbdsqr( uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u,ldu, c, ldc, & work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldc,ldu,ldvt,n,ncc,ncvt,nru + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldc,ldu,ldvt,n,ncc,ncvt,nru real(sp), intent(inout) :: c(ldc,*),d(*),e(*),u(ldu,*),vt(ldvt,*) real(sp), intent(out) :: work(*) end subroutine sbdsqr -#else - module procedure stdlib_sbdsqr +#else + module procedure stdlib${ii}$_sbdsqr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$bdsqr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zbdsqr( uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u,ldu, c, ldc, & rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldc,ldu,ldvt,n,ncc,ncvt,nru + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldc,ldu,ldvt,n,ncc,ncvt,nru real(dp), intent(inout) :: d(*),e(*) real(dp), intent(out) :: rwork(*) complex(dp), intent(inout) :: c(ldc,*),u(ldu,*),vt(ldvt,*) end subroutine zbdsqr -#else - module procedure stdlib_zbdsqr +#else + module procedure stdlib${ii}$_zbdsqr #endif - end interface bdsqr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$bdsqr +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$bdsqr +#:endif +#:endfor +#:endfor + end interface bdsqr interface disna !! DISNA computes the reciprocal condition numbers for the eigenvectors @@ -286,120 +229,120 @@ module stdlib_linalg_lapack !! the error bound. !! DISNA may also be used to compute error bounds for eigenvectors of !! the generalized symmetric definite eigenproblem. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ddisna( job, m, n, d, sep, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(in) :: d(*) real(dp), intent(out) :: sep(*) end subroutine ddisna -#else - module procedure stdlib_ddisna +#else + module procedure stdlib${ii}$_ddisna #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$disna - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sdisna( job, m, n, d, sep, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(in) :: d(*) real(sp), intent(out) :: sep(*) end subroutine sdisna -#else - module procedure stdlib_sdisna +#else + module procedure stdlib${ii}$_sdisna #endif - end interface disna - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$disna +#:endif +#:endfor +#:endfor + end interface disna interface gbbrd !! GBBRD reduces a complex general m-by-n band matrix A to real upper !! bidiagonal form B by a unitary transformation: Q**H * A * P = B. !! The routine computes B, and optionally forms Q or P**H, or computes !! Q**H*C for a given matrix C. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgbbrd( vect, m, n, ncc, kl, ku, ab, ldab, d, e, q,ldq, pt, ldpt, & c, ldc, work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: vect - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl,ku,ldab,ldc,ldpt,ldq,m,n,ncc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl,ku,ldab,ldc,ldpt,ldq,m,n,ncc real(sp), intent(out) :: d(*),e(*),rwork(*) complex(sp), intent(inout) :: ab(ldab,*),c(ldc,*) complex(sp), intent(out) :: pt(ldpt,*),q(ldq,*),work(*) end subroutine cgbbrd -#else - module procedure stdlib_cgbbrd +#else + module procedure stdlib${ii}$_cgbbrd #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgbbrd( vect, m, n, ncc, kl, ku, ab, ldab, d, e, q,ldq, pt, ldpt, & c, ldc, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: vect - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl,ku,ldab,ldc,ldpt,ldq,m,n,ncc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl,ku,ldab,ldc,ldpt,ldq,m,n,ncc real(dp), intent(inout) :: ab(ldab,*),c(ldc,*) real(dp), intent(out) :: d(*),e(*),pt(ldpt,*),q(ldq,*),work(*) end subroutine dgbbrd -#else - module procedure stdlib_dgbbrd +#else + module procedure stdlib${ii}$_dgbbrd #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gbbrd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgbbrd( vect, m, n, ncc, kl, ku, ab, ldab, d, e, q,ldq, pt, ldpt, & c, ldc, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: vect - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl,ku,ldab,ldc,ldpt,ldq,m,n,ncc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl,ku,ldab,ldc,ldpt,ldq,m,n,ncc real(sp), intent(inout) :: ab(ldab,*),c(ldc,*) real(sp), intent(out) :: d(*),e(*),pt(ldpt,*),q(ldq,*),work(*) end subroutine sgbbrd -#else - module procedure stdlib_sgbbrd +#else + module procedure stdlib${ii}$_sgbbrd #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gbbrd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgbbrd( vect, m, n, ncc, kl, ku, ab, ldab, d, e, q,ldq, pt, ldpt, & c, ldc, work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: vect - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl,ku,ldab,ldc,ldpt,ldq,m,n,ncc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl,ku,ldab,ldc,ldpt,ldq,m,n,ncc real(dp), intent(out) :: d(*),e(*),rwork(*) complex(dp), intent(inout) :: ab(ldab,*),c(ldc,*) complex(dp), intent(out) :: pt(ldpt,*),q(ldq,*),work(*) end subroutine zgbbrd -#else - module procedure stdlib_zgbbrd +#else + module procedure stdlib${ii}$_zgbbrd #endif - end interface gbbrd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gbbrd +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gbbrd +#:endif +#:endfor +#:endfor + end interface gbbrd interface gbcon !! GBCON estimates the reciprocal of the condition number of a complex @@ -408,81 +351,81 @@ module stdlib_linalg_lapack !! 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)) ). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond,work, rwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl,ku,ldab,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl,ku,ldab,n,ipiv(*) real(sp), intent(in) :: anorm real(sp), intent(out) :: rcond,rwork(*) complex(sp), intent(in) :: ab(ldab,*) complex(sp), intent(out) :: work(*) end subroutine cgbcon -#else - module procedure stdlib_cgbcon +#else + module procedure stdlib${ii}$_cgbcon #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond,work, iwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: kl,ku,ldab,n,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: kl,ku,ldab,n,ipiv(*) real(dp), intent(in) :: anorm,ab(ldab,*) real(dp), intent(out) :: rcond,work(*) end subroutine dgbcon -#else - module procedure stdlib_dgbcon +#else + module procedure stdlib${ii}$_dgbcon #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gbcon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond,work, iwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: kl,ku,ldab,n,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: kl,ku,ldab,n,ipiv(*) real(sp), intent(in) :: anorm,ab(ldab,*) real(sp), intent(out) :: rcond,work(*) end subroutine sgbcon -#else - module procedure stdlib_sgbcon +#else + module procedure stdlib${ii}$_sgbcon #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gbcon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond,work, rwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl,ku,ldab,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl,ku,ldab,n,ipiv(*) real(dp), intent(in) :: anorm real(dp), intent(out) :: rcond,rwork(*) complex(dp), intent(in) :: ab(ldab,*) complex(dp), intent(out) :: work(*) end subroutine zgbcon -#else - module procedure stdlib_zgbcon +#else + module procedure stdlib${ii}$_zgbcon #endif - end interface gbcon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gbcon +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gbcon +#:endif +#:endfor +#:endfor + end interface gbcon interface gbequ !! GBEQU computes row and column scalings intended to equilibrate an @@ -494,73 +437,73 @@ module stdlib_linalg_lapack !! number and BIGNUM = largest safe number. Use of these scaling !! factors is not guaranteed to reduce the condition number of A but !! works well in practice. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgbequ( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl,ku,ldab,m,n + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl,ku,ldab,m,n real(sp), intent(out) :: amax,colcnd,rowcnd,c(*),r(*) complex(sp), intent(in) :: ab(ldab,*) end subroutine cgbequ -#else - module procedure stdlib_cgbequ +#else + module procedure stdlib${ii}$_cgbequ #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgbequ( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl,ku,ldab,m,n + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl,ku,ldab,m,n real(dp), intent(out) :: amax,colcnd,rowcnd,c(*),r(*) real(dp), intent(in) :: ab(ldab,*) end subroutine dgbequ -#else - module procedure stdlib_dgbequ +#else + module procedure stdlib${ii}$_dgbequ #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gbequ - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgbequ( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl,ku,ldab,m,n + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl,ku,ldab,m,n real(sp), intent(out) :: amax,colcnd,rowcnd,c(*),r(*) real(sp), intent(in) :: ab(ldab,*) end subroutine sgbequ -#else - module procedure stdlib_sgbequ +#else + module procedure stdlib${ii}$_sgbequ #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gbequ - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgbequ( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl,ku,ldab,m,n + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl,ku,ldab,m,n real(dp), intent(out) :: amax,colcnd,rowcnd,c(*),r(*) complex(dp), intent(in) :: ab(ldab,*) end subroutine zgbequ -#else - module procedure stdlib_zgbequ +#else + module procedure stdlib${ii}$_zgbequ #endif - end interface gbequ +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gbequ +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gbequ +#:endif +#:endfor +#:endfor + end interface gbequ interface gbequb !! GBEQUB computes row and column scalings intended to equilibrate an @@ -578,155 +521,155 @@ module stdlib_linalg_lapack !! these factors introduces no additional rounding errors. However, the !! scaled entries' magnitudes are no longer approximately 1 but lie !! between sqrt(radix) and 1/sqrt(radix). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgbequb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl,ku,ldab,m,n + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl,ku,ldab,m,n real(sp), intent(out) :: amax,colcnd,rowcnd,c(*),r(*) complex(sp), intent(in) :: ab(ldab,*) end subroutine cgbequb -#else - module procedure stdlib_cgbequb +#else + module procedure stdlib${ii}$_cgbequb #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgbequb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl,ku,ldab,m,n + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl,ku,ldab,m,n real(dp), intent(out) :: amax,colcnd,rowcnd,c(*),r(*) real(dp), intent(in) :: ab(ldab,*) end subroutine dgbequb -#else - module procedure stdlib_dgbequb +#else + module procedure stdlib${ii}$_dgbequb #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gbequb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgbequb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl,ku,ldab,m,n + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl,ku,ldab,m,n real(sp), intent(out) :: amax,colcnd,rowcnd,c(*),r(*) real(sp), intent(in) :: ab(ldab,*) end subroutine sgbequb -#else - module procedure stdlib_sgbequb +#else + module procedure stdlib${ii}$_sgbequb #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gbequb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgbequb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl,ku,ldab,m,n + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl,ku,ldab,m,n real(dp), intent(out) :: amax,colcnd,rowcnd,c(*),r(*) complex(dp), intent(in) :: ab(ldab,*) end subroutine zgbequb -#else - module procedure stdlib_zgbequb +#else + module procedure stdlib${ii}$_zgbequb #endif - end interface gbequb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gbequb +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gbequb +#:endif +#:endfor +#:endfor + end interface gbequb interface gbrfs !! GBRFS 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. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb,ipiv, b, ldb, & x, ldx, ferr, berr, work, rwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl,ku,ldab,ldafb,ldb,ldx,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl,ku,ldab,ldafb,ldb,ldx,n,nrhs,ipiv(*) real(sp), intent(out) :: berr(*),ferr(*),rwork(*) complex(sp), intent(in) :: ab(ldab,*),afb(ldafb,*),b(ldb,*) complex(sp), intent(out) :: work(*) complex(sp), intent(inout) :: x(ldx,*) end subroutine cgbrfs -#else - module procedure stdlib_cgbrfs +#else + module procedure stdlib${ii}$_cgbrfs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb,ipiv, b, ldb, & x, ldx, ferr, berr, work, iwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: kl,ku,ldab,ldafb,ldb,ldx,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: kl,ku,ldab,ldafb,ldb,ldx,n,nrhs,ipiv(*) real(dp), intent(in) :: ab(ldab,*),afb(ldafb,*),b(ldb,*) real(dp), intent(out) :: berr(*),ferr(*),work(*) real(dp), intent(inout) :: x(ldx,*) end subroutine dgbrfs -#else - module procedure stdlib_dgbrfs +#else + module procedure stdlib${ii}$_dgbrfs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gbrfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb,ipiv, b, ldb, & x, ldx, ferr, berr, work, iwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: kl,ku,ldab,ldafb,ldb,ldx,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: kl,ku,ldab,ldafb,ldb,ldx,n,nrhs,ipiv(*) real(sp), intent(in) :: ab(ldab,*),afb(ldafb,*),b(ldb,*) real(sp), intent(out) :: berr(*),ferr(*),work(*) real(sp), intent(inout) :: x(ldx,*) end subroutine sgbrfs -#else - module procedure stdlib_sgbrfs +#else + module procedure stdlib${ii}$_sgbrfs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gbrfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb,ipiv, b, ldb, & x, ldx, ferr, berr, work, rwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl,ku,ldab,ldafb,ldb,ldx,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl,ku,ldab,ldafb,ldb,ldx,n,nrhs,ipiv(*) real(dp), intent(out) :: berr(*),ferr(*),rwork(*) complex(dp), intent(in) :: ab(ldab,*),afb(ldafb,*),b(ldb,*) complex(dp), intent(out) :: work(*) complex(dp), intent(inout) :: x(ldx,*) end subroutine zgbrfs -#else - module procedure stdlib_zgbrfs +#else + module procedure stdlib${ii}$_zgbrfs #endif - end interface gbrfs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gbrfs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gbrfs +#:endif +#:endfor +#:endfor + end interface gbrfs interface gbsv !! GBSV computes the solution to a complex system of linear equations @@ -737,278 +680,278 @@ module stdlib_linalg_lapack !! and unit lower triangular matrices with KL subdiagonals, and U is !! upper triangular with KL+KU superdiagonals. The factored form of A !! is then used to solve the system of equations A * X = B. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: kl,ku,ldab,ldb,n,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: kl,ku,ldab,ldb,n,nrhs complex(sp), intent(inout) :: ab(ldab,*),b(ldb,*) end subroutine cgbsv -#else - module procedure stdlib_cgbsv +#else + module procedure stdlib${ii}$_cgbsv #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: kl,ku,ldab,ldb,n,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: kl,ku,ldab,ldb,n,nrhs real(dp), intent(inout) :: ab(ldab,*),b(ldb,*) end subroutine dgbsv -#else - module procedure stdlib_dgbsv +#else + module procedure stdlib${ii}$_dgbsv +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine sgbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: kl,ku,ldab,ldb,n,nrhs + real(sp), intent(inout) :: ab(ldab,*),b(ldb,*) + end subroutine sgbsv +#else + module procedure stdlib${ii}$_sgbsv +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine zgbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: kl,ku,ldab,ldb,n,nrhs + complex(dp), intent(inout) :: ab(ldab,*),b(ldb,*) + end subroutine zgbsv +#else + module procedure stdlib${ii}$_zgbsv #endif #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gbsv + module procedure stdlib${ii}$_${ri}$gbsv #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine sgbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: kl,ku,ldab,ldb,n,nrhs - real(sp), intent(inout) :: ab(ldab,*),b(ldb,*) - end subroutine sgbsv -#else - module procedure stdlib_sgbsv -#endif #:for rk,rt,ri in CMPLX_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gbsv + module procedure stdlib${ii}$_${ri}$gbsv #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine zgbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: kl,ku,ldab,ldb,n,nrhs - complex(dp), intent(inout) :: ab(ldab,*),b(ldb,*) - end subroutine zgbsv -#else - module procedure stdlib_zgbsv -#endif +#:endfor end interface gbsv - - interface gbtrf !! GBTRF computes an LU factorization of a complex m-by-n band matrix A !! using partial pivoting with row interchanges. !! This is the blocked version of the algorithm, calling Level 3 BLAS. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgbtrf( m, n, kl, ku, ab, ldab, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: kl,ku,ldab,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: kl,ku,ldab,m,n complex(sp), intent(inout) :: ab(ldab,*) end subroutine cgbtrf -#else - module procedure stdlib_cgbtrf +#else + module procedure stdlib${ii}$_cgbtrf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgbtrf( m, n, kl, ku, ab, ldab, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: kl,ku,ldab,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: kl,ku,ldab,m,n real(dp), intent(inout) :: ab(ldab,*) end subroutine dgbtrf -#else - module procedure stdlib_dgbtrf +#else + module procedure stdlib${ii}$_dgbtrf +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine sgbtrf( m, n, kl, ku, ab, ldab, ipiv, info ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: kl,ku,ldab,m,n + real(sp), intent(inout) :: ab(ldab,*) + end subroutine sgbtrf +#else + module procedure stdlib${ii}$_sgbtrf +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine zgbtrf( m, n, kl, ku, ab, ldab, ipiv, info ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: kl,ku,ldab,m,n + complex(dp), intent(inout) :: ab(ldab,*) + end subroutine zgbtrf +#else + module procedure stdlib${ii}$_zgbtrf #endif #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gbtrf + module procedure stdlib${ii}$_${ri}$gbtrf #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine sgbtrf( m, n, kl, ku, ab, ldab, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: kl,ku,ldab,m,n - real(sp), intent(inout) :: ab(ldab,*) - end subroutine sgbtrf -#else - module procedure stdlib_sgbtrf -#endif #:for rk,rt,ri in CMPLX_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gbtrf + module procedure stdlib${ii}$_${ri}$gbtrf #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine zgbtrf( m, n, kl, ku, ab, ldab, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: kl,ku,ldab,m,n - complex(dp), intent(inout) :: ab(ldab,*) - end subroutine zgbtrf -#else - module procedure stdlib_zgbtrf -#endif +#:endfor end interface gbtrf - - interface gbtrs !! GBTRS solves a system of linear equations !! A * X = B, A**T * X = B, or A**H * X = B !! with a general band matrix A using the LU factorization computed !! by CGBTRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl,ku,ldab,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl,ku,ldab,ldb,n,nrhs,ipiv(*) complex(sp), intent(in) :: ab(ldab,*) complex(sp), intent(inout) :: b(ldb,*) end subroutine cgbtrs -#else - module procedure stdlib_cgbtrs +#else + module procedure stdlib${ii}$_cgbtrs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl,ku,ldab,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl,ku,ldab,ldb,n,nrhs,ipiv(*) real(dp), intent(in) :: ab(ldab,*) real(dp), intent(inout) :: b(ldb,*) end subroutine dgbtrs -#else - module procedure stdlib_dgbtrs +#else + module procedure stdlib${ii}$_dgbtrs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gbtrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl,ku,ldab,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl,ku,ldab,ldb,n,nrhs,ipiv(*) real(sp), intent(in) :: ab(ldab,*) real(sp), intent(inout) :: b(ldb,*) end subroutine sgbtrs -#else - module procedure stdlib_sgbtrs +#else + module procedure stdlib${ii}$_sgbtrs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gbtrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl,ku,ldab,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl,ku,ldab,ldb,n,nrhs,ipiv(*) complex(dp), intent(in) :: ab(ldab,*) complex(dp), intent(inout) :: b(ldb,*) end subroutine zgbtrs -#else - module procedure stdlib_zgbtrs +#else + module procedure stdlib${ii}$_zgbtrs #endif - end interface gbtrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gbtrs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gbtrs +#:endif +#:endfor +#:endfor + end interface gbtrs interface gebak !! GEBAK forms the right or left eigenvectors of a complex general !! matrix by backward transformation on the computed eigenvectors of the !! balanced matrix output by CGEBAL. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgebak( job, side, n, ilo, ihi, scale, m, v, ldv,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(in) :: scale(*) complex(sp), intent(inout) :: v(ldv,*) end subroutine cgebak -#else - module procedure stdlib_cgebak +#else + module procedure stdlib${ii}$_cgebak #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgebak( job, side, n, ilo, ihi, scale, m, v, ldv,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(in) :: scale(*) real(dp), intent(inout) :: v(ldv,*) end subroutine dgebak -#else - module procedure stdlib_dgebak +#else + module procedure stdlib${ii}$_dgebak #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gebak - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgebak( job, side, n, ilo, ihi, scale, m, v, ldv,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: v(ldv,*) real(sp), intent(in) :: scale(*) end subroutine sgebak -#else - module procedure stdlib_sgebak +#else + module procedure stdlib${ii}$_sgebak #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gebak - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgebak( job, side, n, ilo, ihi, scale, m, v, ldv,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(in) :: scale(*) complex(dp), intent(inout) :: v(ldv,*) end subroutine zgebak -#else - module procedure stdlib_zgebak +#else + module procedure stdlib${ii}$_zgebak #endif - end interface gebak - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gebak +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gebak + +#:endif +#:endfor +#:endfor + end interface gebak interface gebal !! GEBAL balances a general complex matrix A. This involves, first, @@ -1019,143 +962,143 @@ module stdlib_linalg_lapack !! close in norm as possible. Both steps are optional. !! Balancing may reduce the 1-norm of the matrix, and improve the !! accuracy of the computed eigenvalues and/or eigenvectors. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgebal( job, n, a, lda, ilo, ihi, scale, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: job - integer(ilp), intent(out) :: ihi,ilo,info - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: ihi,ilo,info + integer(${ik}$), intent(in) :: lda,n real(sp), intent(out) :: scale(*) complex(sp), intent(inout) :: a(lda,*) end subroutine cgebal -#else - module procedure stdlib_cgebal +#else + module procedure stdlib${ii}$_cgebal #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgebal( job, n, a, lda, ilo, ihi, scale, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: job - integer(ilp), intent(out) :: ihi,ilo,info - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: ihi,ilo,info + integer(${ik}$), intent(in) :: lda,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: scale(*) end subroutine dgebal -#else - module procedure stdlib_dgebal +#else + module procedure stdlib${ii}$_dgebal #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gebal - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgebal( job, n, a, lda, ilo, ihi, scale, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: job - integer(ilp), intent(out) :: ihi,ilo,info - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: ihi,ilo,info + integer(${ik}$), intent(in) :: lda,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: scale(*) end subroutine sgebal -#else - module procedure stdlib_sgebal +#else + module procedure stdlib${ii}$_sgebal #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gebal - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgebal( job, n, a, lda, ilo, ihi, scale, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: job - integer(ilp), intent(out) :: ihi,ilo,info - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: ihi,ilo,info + integer(${ik}$), intent(in) :: lda,n real(dp), intent(out) :: scale(*) complex(dp), intent(inout) :: a(lda,*) end subroutine zgebal -#else - module procedure stdlib_zgebal +#else + module procedure stdlib${ii}$_zgebal #endif - end interface gebal +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gebal +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gebal +#:endif +#:endfor +#:endfor + end interface gebal interface gebrd !! GEBRD reduces a general complex M-by-N matrix A to upper or lower !! bidiagonal form B by a unitary transformation: Q**H * A * P = B. !! If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgebrd( m, n, a, lda, d, e, tauq, taup, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n real(sp), intent(out) :: d(*),e(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: taup(*),tauq(*),work(*) end subroutine cgebrd -#else - module procedure stdlib_cgebrd +#else + module procedure stdlib${ii}$_cgebrd #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgebrd( m, n, a, lda, d, e, tauq, taup, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: d(*),e(*),taup(*),tauq(*),work(*) end subroutine dgebrd -#else - module procedure stdlib_dgebrd +#else + module procedure stdlib${ii}$_dgebrd #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gebrd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgebrd( m, n, a, lda, d, e, tauq, taup, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: d(*),e(*),taup(*),tauq(*),work(*) end subroutine sgebrd -#else - module procedure stdlib_sgebrd +#else + module procedure stdlib${ii}$_sgebrd #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gebrd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgebrd( m, n, a, lda, d, e, tauq, taup, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n real(dp), intent(out) :: d(*),e(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: taup(*),tauq(*),work(*) end subroutine zgebrd -#else - module procedure stdlib_zgebrd +#else + module procedure stdlib${ii}$_zgebrd #endif - end interface gebrd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gebrd +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gebrd +#:endif +#:endfor +#:endfor + end interface gebrd interface gecon !! GECON estimates the reciprocal of the condition number of a general @@ -1164,79 +1107,79 @@ module stdlib_linalg_lapack !! 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)) ). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgecon( norm, n, a, lda, anorm, rcond, work, rwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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,rwork(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: work(*) end subroutine cgecon -#else - module procedure stdlib_cgecon +#else + module procedure stdlib${ii}$_cgecon #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgecon( norm, n, a, lda, anorm, rcond, work, iwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,n real(dp), intent(in) :: anorm real(dp), intent(out) :: rcond,work(*) real(dp), intent(inout) :: a(lda,*) end subroutine dgecon -#else - module procedure stdlib_dgecon +#else + module procedure stdlib${ii}$_dgecon #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gecon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgecon( norm, n, a, lda, anorm, rcond, work, iwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,n real(sp), intent(in) :: anorm real(sp), intent(out) :: rcond,work(*) real(sp), intent(inout) :: a(lda,*) end subroutine sgecon -#else - module procedure stdlib_sgecon +#else + module procedure stdlib${ii}$_sgecon #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gecon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgecon( norm, n, a, lda, anorm, rcond, work, rwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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(dp), intent(in) :: anorm real(dp), intent(out) :: rcond,rwork(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: work(*) end subroutine zgecon -#else - module procedure stdlib_zgecon +#else + module procedure stdlib${ii}$_zgecon #endif - end interface gecon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gecon +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gecon +#:endif +#:endfor +#:endfor + end interface gecon interface geequ !! GEEQU computes row and column scalings intended to equilibrate an @@ -1248,69 +1191,69 @@ module stdlib_linalg_lapack !! number and BIGNUM = largest safe number. Use of these scaling !! factors is not guaranteed to reduce the condition number of A but !! works well in practice. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgeequ( m, n, a, lda, r, c, rowcnd, colcnd, amax,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n real(sp), intent(out) :: amax,colcnd,rowcnd,c(*),r(*) complex(sp), intent(in) :: a(lda,*) end subroutine cgeequ -#else - module procedure stdlib_cgeequ +#else + module procedure stdlib${ii}$_cgeequ #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgeequ( m, n, a, lda, r, c, rowcnd, colcnd, amax,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n real(dp), intent(out) :: amax,colcnd,rowcnd,c(*),r(*) real(dp), intent(in) :: a(lda,*) end subroutine dgeequ -#else - module procedure stdlib_dgeequ +#else + module procedure stdlib${ii}$_dgeequ #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$geequ - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgeequ( m, n, a, lda, r, c, rowcnd, colcnd, amax,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n real(sp), intent(out) :: amax,colcnd,rowcnd,c(*),r(*) real(sp), intent(in) :: a(lda,*) end subroutine sgeequ -#else - module procedure stdlib_sgeequ +#else + module procedure stdlib${ii}$_sgeequ #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$geequ - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgeequ( m, n, a, lda, r, c, rowcnd, colcnd, amax,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n real(dp), intent(out) :: amax,colcnd,rowcnd,c(*),r(*) complex(dp), intent(in) :: a(lda,*) end subroutine zgeequ -#else - module procedure stdlib_zgeequ +#else + module procedure stdlib${ii}$_zgeequ #endif - end interface geequ +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$geequ +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$geequ +#:endif +#:endfor +#:endfor + end interface geequ interface geequb !! GEEQUB computes row and column scalings intended to equilibrate an @@ -1328,69 +1271,69 @@ module stdlib_linalg_lapack !! these factors introduces no additional rounding errors. However, the !! scaled entries' magnitudes are no longer approximately 1 but lie !! between sqrt(radix) and 1/sqrt(radix). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgeequb( m, n, a, lda, r, c, rowcnd, colcnd, amax,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n real(sp), intent(out) :: amax,colcnd,rowcnd,c(*),r(*) complex(sp), intent(in) :: a(lda,*) end subroutine cgeequb -#else - module procedure stdlib_cgeequb +#else + module procedure stdlib${ii}$_cgeequb #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgeequb( m, n, a, lda, r, c, rowcnd, colcnd, amax,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n real(dp), intent(out) :: amax,colcnd,rowcnd,c(*),r(*) real(dp), intent(in) :: a(lda,*) end subroutine dgeequb -#else - module procedure stdlib_dgeequb +#else + module procedure stdlib${ii}$_dgeequb #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$geequb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgeequb( m, n, a, lda, r, c, rowcnd, colcnd, amax,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n real(sp), intent(out) :: amax,colcnd,rowcnd,c(*),r(*) real(sp), intent(in) :: a(lda,*) end subroutine sgeequb -#else - module procedure stdlib_sgeequb +#else + module procedure stdlib${ii}$_sgeequb #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$geequb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgeequb( m, n, a, lda, r, c, rowcnd, colcnd, amax,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n real(dp), intent(out) :: amax,colcnd,rowcnd,c(*),r(*) complex(dp), intent(in) :: a(lda,*) end subroutine zgeequb -#else - module procedure stdlib_zgeequb +#else + module procedure stdlib${ii}$_zgeequb #endif - end interface geequb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$geequb +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$geequb +#:endif +#:endfor +#:endfor + end interface geequb interface gees !! GEES computes for an N-by-N complex nonsymmetric matrix A, the @@ -1401,87 +1344,87 @@ module stdlib_linalg_lapack !! The leading columns of Z then form an orthonormal basis for the !! invariant subspace corresponding to the selected eigenvalues. !! A complex matrix is in Schur form if it is upper triangular. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cgees( jobvs, sort, select, n, a, lda, sdim, w, vs,ldvs, work, lwork, & rwork, bwork, info ) - import sp,dp,qp,ilp,lk,stdlib_select_c - implicit none(type,external) + import sp,dp,qp,${ik}$,lk,stdlib_select_c + implicit none(type,external) character, intent(in) :: jobvs,sort - integer(ilp), intent(out) :: info,sdim - integer(ilp), intent(in) :: lda,ldvs,lwork,n + integer(${ik}$), intent(out) :: info,sdim + integer(${ik}$), intent(in) :: lda,ldvs,lwork,n logical(lk), intent(out) :: bwork(*) real(sp), intent(out) :: rwork(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: vs(ldvs,*),w(*),work(*) procedure(stdlib_select_c) :: select end subroutine cgees -#else - module procedure stdlib_cgees +#else + module procedure stdlib${ii}$_cgees #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dgees( jobvs, sort, select, n, a, lda, sdim, wr, wi,vs, ldvs, work, & lwork, bwork, info ) - import sp,dp,qp,ilp,lk,stdlib_select_d - implicit none(type,external) + import sp,dp,qp,${ik}$,lk,stdlib_select_d + implicit none(type,external) character, intent(in) :: jobvs,sort - integer(ilp), intent(out) :: info,sdim - integer(ilp), intent(in) :: lda,ldvs,lwork,n + integer(${ik}$), intent(out) :: info,sdim + integer(${ik}$), intent(in) :: lda,ldvs,lwork,n logical(lk), intent(out) :: bwork(*) real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: vs(ldvs,*),wi(*),work(*),wr(*) procedure(stdlib_select_d) :: select end subroutine dgees -#else - module procedure stdlib_dgees +#else + module procedure stdlib${ii}$_dgees #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gees - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sgees( jobvs, sort, select, n, a, lda, sdim, wr, wi,vs, ldvs, work, & lwork, bwork, info ) - import sp,dp,qp,ilp,lk,stdlib_select_s - implicit none(type,external) + import sp,dp,qp,${ik}$,lk,stdlib_select_s + implicit none(type,external) character, intent(in) :: jobvs,sort - integer(ilp), intent(out) :: info,sdim - integer(ilp), intent(in) :: lda,ldvs,lwork,n + integer(${ik}$), intent(out) :: info,sdim + integer(${ik}$), intent(in) :: lda,ldvs,lwork,n logical(lk), intent(out) :: bwork(*) real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: vs(ldvs,*),wi(*),work(*),wr(*) procedure(stdlib_select_s) :: select end subroutine sgees -#else - module procedure stdlib_sgees +#else + module procedure stdlib${ii}$_sgees #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gees - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zgees( jobvs, sort, select, n, a, lda, sdim, w, vs,ldvs, work, lwork, & rwork, bwork, info ) - import sp,dp,qp,ilp,lk,stdlib_select_z - implicit none(type,external) + import sp,dp,qp,${ik}$,lk,stdlib_select_z + implicit none(type,external) character, intent(in) :: jobvs,sort - integer(ilp), intent(out) :: info,sdim - integer(ilp), intent(in) :: lda,ldvs,lwork,n + integer(${ik}$), intent(out) :: info,sdim + integer(${ik}$), intent(in) :: lda,ldvs,lwork,n logical(lk), intent(out) :: bwork(*) real(dp), intent(out) :: rwork(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: vs(ldvs,*),w(*),work(*) procedure(stdlib_select_z) :: select end subroutine zgees -#else - module procedure stdlib_zgees +#else + module procedure stdlib${ii}$_zgees #endif - end interface gees +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gees +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gees +#:endif +#:endfor +#:endfor + end interface gees interface geev !! GEEV computes for an N-by-N complex nonsymmetric matrix A, the @@ -1494,146 +1437,146 @@ module stdlib_linalg_lapack !! where u(j)**H denotes the conjugate transpose of u(j). !! The computed eigenvectors are normalized to have Euclidean norm !! equal to 1 and largest component real. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cgeev( jobvl, jobvr, n, a, lda, w, vl, ldvl, vr, ldvr,work, lwork, & rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobvl,jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldvl,ldvr,lwork,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldvl,ldvr,lwork,n real(sp), intent(out) :: rwork(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: vl(ldvl,*),vr(ldvr,*),w(*),work(*) end subroutine cgeev -#else - module procedure stdlib_cgeev +#else + module procedure stdlib${ii}$_cgeev #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dgeev( jobvl, jobvr, n, a, lda, wr, wi, vl, ldvl, vr,ldvr, work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobvl,jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldvl,ldvr,lwork,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldvl,ldvr,lwork,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: vl(ldvl,*),vr(ldvr,*),wi(*),work(*),wr(*) end subroutine dgeev -#else - module procedure stdlib_dgeev +#else + module procedure stdlib${ii}$_dgeev #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$geev - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sgeev( jobvl, jobvr, n, a, lda, wr, wi, vl, ldvl, vr,ldvr, work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobvl,jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldvl,ldvr,lwork,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldvl,ldvr,lwork,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: vl(ldvl,*),vr(ldvr,*),wi(*),work(*),wr(*) end subroutine sgeev -#else - module procedure stdlib_sgeev +#else + module procedure stdlib${ii}$_sgeev #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$geev - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zgeev( jobvl, jobvr, n, a, lda, w, vl, ldvl, vr, ldvr,work, lwork, & rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobvl,jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldvl,ldvr,lwork,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldvl,ldvr,lwork,n real(dp), intent(out) :: rwork(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: vl(ldvl,*),vr(ldvr,*),w(*),work(*) end subroutine zgeev -#else - module procedure stdlib_zgeev +#else + module procedure stdlib${ii}$_zgeev #endif - end interface geev +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$geev +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$geev +#:endif +#:endfor +#:endfor + end interface geev interface gehrd !! GEHRD reduces a complex general matrix A to upper Hessenberg form H by !! an unitary similarity transformation: Q**H * A * Q = H . -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgehrd( n, ilo, ihi, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihi,ilo,lda,lwork,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihi,ilo,lda,lwork,n + integer(${ik}$), intent(out) :: info complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: tau(*),work(*) end subroutine cgehrd -#else - module procedure stdlib_cgehrd +#else + module procedure stdlib${ii}$_cgehrd #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgehrd( n, ilo, ihi, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihi,ilo,lda,lwork,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihi,ilo,lda,lwork,n + integer(${ik}$), intent(out) :: info real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: tau(*),work(*) end subroutine dgehrd -#else - module procedure stdlib_dgehrd +#else + module procedure stdlib${ii}$_dgehrd #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gehrd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgehrd( n, ilo, ihi, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihi,ilo,lda,lwork,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihi,ilo,lda,lwork,n + integer(${ik}$), intent(out) :: info real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: tau(*),work(*) end subroutine sgehrd -#else - module procedure stdlib_sgehrd +#else + module procedure stdlib${ii}$_sgehrd #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gehrd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgehrd( n, ilo, ihi, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihi,ilo,lda,lwork,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihi,ilo,lda,lwork,n + integer(${ik}$), intent(out) :: info complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: tau(*),work(*) end subroutine zgehrd -#else - module procedure stdlib_zgehrd +#else + module procedure stdlib${ii}$_zgehrd #endif - end interface gehrd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gehrd +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gehrd +#:endif +#:endfor +#:endfor + end interface gehrd interface gejsv !! GEJSV computes the singular value decomposition (SVD) of a complex M-by-N @@ -1646,79 +1589,79 @@ module stdlib_linalg_lapack !! the right singular vectors of [A], respectively. The matrices [U] and [V] !! are computed and stored in the arrays U and V, respectively. The diagonal !! of [SIGMA] is computed and stored in the array SVA. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgejsv( joba, jobu, jobv, jobr, jobt, jobp,m, n, a, lda, sva, u, & ldu, v, ldv,cwork, lwork, rwork, lrwork, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,ldu,ldv,lwork,lrwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,ldu,ldv,lwork,lrwork,m,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: u(ldu,*),v(ldv,*),cwork(lwork) real(sp), intent(out) :: sva(n),rwork(lrwork) character, intent(in) :: joba,jobp,jobr,jobt,jobu,jobv end subroutine cgejsv -#else - module procedure stdlib_cgejsv +#else + module procedure stdlib${ii}$_cgejsv #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgejsv( joba, jobu, jobv, jobr, jobt, jobp,m, n, a, lda, sva, u, & ldu, v, ldv,work, lwork, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,ldu,ldv,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,ldu,ldv,lwork,m,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: sva(n),u(ldu,*),v(ldv,*),work(lwork) character, intent(in) :: joba,jobp,jobr,jobt,jobu,jobv end subroutine dgejsv -#else - module procedure stdlib_dgejsv +#else + module procedure stdlib${ii}$_dgejsv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gejsv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgejsv( joba, jobu, jobv, jobr, jobt, jobp,m, n, a, lda, sva, u, & ldu, v, ldv,work, lwork, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,ldu,ldv,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,ldu,ldv,lwork,m,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: sva(n),u(ldu,*),v(ldv,*),work(lwork) character, intent(in) :: joba,jobp,jobr,jobt,jobu,jobv end subroutine sgejsv -#else - module procedure stdlib_sgejsv +#else + module procedure stdlib${ii}$_sgejsv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gejsv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgejsv( joba, jobu, jobv, jobr, jobt, jobp,m, n, a, lda, sva, u, & ldu, v, ldv,cwork, lwork, rwork, lrwork, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,ldu,ldv,lwork,lrwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,ldu,ldv,lwork,lrwork,m,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: u(ldu,*),v(ldv,*),cwork(lwork) real(dp), intent(out) :: sva(n),rwork(lrwork) character, intent(in) :: joba,jobp,jobr,jobt,jobu,jobv end subroutine zgejsv -#else - module procedure stdlib_zgejsv +#else + module procedure stdlib${ii}$_zgejsv #endif - end interface gejsv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gejsv +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gejsv +#:endif +#:endfor +#:endfor + end interface gejsv interface gelq !! GELQ computes an LQ factorization of a complex M-by-N matrix A: @@ -1727,69 +1670,69 @@ module stdlib_linalg_lapack !! Q is a N-by-N orthogonal matrix; !! L is a lower-triangular M-by-M matrix; !! 0 is a M-by-(N-M) zero matrix, if M < N. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgelq( m, n, a, lda, t, tsize, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,tsize,lwork + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,tsize,lwork complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: t(*),work(*) end subroutine cgelq -#else - module procedure stdlib_cgelq +#else + module procedure stdlib${ii}$_cgelq #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgelq( m, n, a, lda, t, tsize, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,tsize,lwork + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,tsize,lwork real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: t(*),work(*) end subroutine dgelq -#else - module procedure stdlib_dgelq +#else + module procedure stdlib${ii}$_dgelq #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gelq - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgelq( m, n, a, lda, t, tsize, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,tsize,lwork + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,tsize,lwork real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: t(*),work(*) end subroutine sgelq -#else - module procedure stdlib_sgelq +#else + module procedure stdlib${ii}$_sgelq #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gelq - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgelq( m, n, a, lda, t, tsize, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,tsize,lwork + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,tsize,lwork complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: t(*),work(*) end subroutine zgelq -#else - module procedure stdlib_zgelq +#else + module procedure stdlib${ii}$_zgelq #endif - end interface gelq +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gelq +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gelq +#:endif +#:endfor +#:endfor + end interface gelq interface gelqf !! GELQF computes an LQ factorization of a complex M-by-N matrix A: @@ -1798,205 +1741,205 @@ module stdlib_linalg_lapack !! Q is a N-by-N orthogonal matrix; !! L is a lower-triangular M-by-M matrix; !! 0 is a M-by-(N-M) zero matrix, if M < N. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgelqf( m, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: tau(*),work(*) end subroutine cgelqf -#else - module procedure stdlib_cgelqf +#else + module procedure stdlib${ii}$_cgelqf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgelqf( m, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: tau(*),work(*) end subroutine dgelqf -#else - module procedure stdlib_dgelqf +#else + module procedure stdlib${ii}$_dgelqf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gelqf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgelqf( m, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: tau(*),work(*) end subroutine sgelqf -#else - module procedure stdlib_sgelqf +#else + module procedure stdlib${ii}$_sgelqf #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gelqf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgelqf( m, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: tau(*),work(*) end subroutine zgelqf -#else - module procedure stdlib_zgelqf +#else + module procedure stdlib${ii}$_zgelqf #endif - end interface gelqf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gelqf +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gelqf +#:endif +#:endfor +#:endfor + end interface gelqf interface gelqt !! GELQT computes a blocked LQ factorization of a complex M-by-N matrix A !! using the compact WY representation of Q. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgelqt( m, n, mb, a, lda, t, ldt, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,m,n,mb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,m,n,mb complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: t(ldt,*),work(*) end subroutine cgelqt -#else - module procedure stdlib_cgelqt +#else + module procedure stdlib${ii}$_cgelqt #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgelqt( m, n, mb, a, lda, t, ldt, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,m,n,mb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,m,n,mb real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: t(ldt,*),work(*) end subroutine dgelqt -#else - module procedure stdlib_dgelqt +#else + module procedure stdlib${ii}$_dgelqt #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gelqt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgelqt( m, n, mb, a, lda, t, ldt, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,m,n,mb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,m,n,mb real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: t(ldt,*),work(*) end subroutine sgelqt -#else - module procedure stdlib_sgelqt +#else + module procedure stdlib${ii}$_sgelqt #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gelqt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgelqt( m, n, mb, a, lda, t, ldt, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,m,n,mb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,m,n,mb complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: t(ldt,*),work(*) end subroutine zgelqt -#else - module procedure stdlib_zgelqt +#else + module procedure stdlib${ii}$_zgelqt #endif - end interface gelqt - - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gelqt - interface gelqt3 +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gelqt + +#:endif +#:endfor +#:endfor + end interface gelqt + + interface gelqt3 !! GELQT3 recursively computes a LQ factorization of a complex M-by-N !! matrix A, using the compact WY representation of Q. !! Based on the algorithm of Elmroth and Gustavson, !! IBM J. Res. Develop. Vol 44 No. 4 July 2000. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure recursive subroutine cgelqt3( m, n, a, lda, t, ldt, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,ldt + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,ldt complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: t(ldt,*) end subroutine cgelqt3 -#else - module procedure stdlib_cgelqt3 +#else + module procedure stdlib${ii}$_cgelqt3 #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure recursive subroutine dgelqt3( m, n, a, lda, t, ldt, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,ldt + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,ldt real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: t(ldt,*) end subroutine dgelqt3 -#else - module procedure stdlib_dgelqt3 +#else + module procedure stdlib${ii}$_dgelqt3 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gelqt3 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure recursive subroutine sgelqt3( m, n, a, lda, t, ldt, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,ldt + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,ldt real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: t(ldt,*) end subroutine sgelqt3 -#else - module procedure stdlib_sgelqt3 +#else + module procedure stdlib${ii}$_sgelqt3 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gelqt3 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure recursive subroutine zgelqt3( m, n, a, lda, t, ldt, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,ldt + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,ldt complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: t(ldt,*) end subroutine zgelqt3 -#else - module procedure stdlib_zgelqt3 +#else + module procedure stdlib${ii}$_zgelqt3 #endif - end interface gelqt3 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gelqt3 +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gelqt3 +#:endif +#:endfor +#:endfor + end interface gelqt3 interface gels !! GELS solves overdetermined or underdetermined complex linear systems @@ -2017,73 +1960,73 @@ module stdlib_linalg_lapack !! handled in a single call; they are stored as the columns of the !! M-by-NRHS right hand side matrix B and the N-by-NRHS solution !! matrix X. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cgels( trans, m, n, nrhs, a, lda, b, ldb, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,nrhs complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: work(*) end subroutine cgels -#else - module procedure stdlib_cgels +#else + module procedure stdlib${ii}$_cgels #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dgels( trans, m, n, nrhs, a, lda, b, ldb, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,nrhs real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(out) :: work(*) end subroutine dgels -#else - module procedure stdlib_dgels +#else + module procedure stdlib${ii}$_dgels #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gels - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sgels( trans, m, n, nrhs, a, lda, b, ldb, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,nrhs real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(out) :: work(*) end subroutine sgels -#else - module procedure stdlib_sgels +#else + module procedure stdlib${ii}$_sgels #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gels - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zgels( trans, m, n, nrhs, a, lda, b, ldb, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,nrhs complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: work(*) end subroutine zgels -#else - module procedure stdlib_zgels +#else + module procedure stdlib${ii}$_zgels #endif - end interface gels +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gels +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gels +#:endif +#:endfor +#:endfor + end interface gels interface gelsd !! GELSD computes the minimum-norm solution to a real linear least @@ -2111,79 +2054,79 @@ module stdlib_linalg_lapack !! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or !! Cray-2. It could conceivably fail on hexadecimal or decimal machines !! without guard digits, but we know of none. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cgelsd( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, rwork, & iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,rank,iwork(*) - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,rank,iwork(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,nrhs real(sp), intent(in) :: rcond real(sp), intent(out) :: rwork(*),s(*) complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: work(*) end subroutine cgelsd -#else - module procedure stdlib_cgelsd +#else + module procedure stdlib${ii}$_cgelsd #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dgelsd( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, iwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,rank,iwork(*) - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,rank,iwork(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,nrhs real(dp), intent(in) :: rcond real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(out) :: s(*),work(*) end subroutine dgelsd -#else - module procedure stdlib_dgelsd +#else + module procedure stdlib${ii}$_dgelsd #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gelsd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sgelsd( m, n, nrhs, a, lda, b, ldb, s, rcond,rank, work, lwork, iwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,rank,iwork(*) - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,rank,iwork(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,nrhs real(sp), intent(in) :: rcond real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(out) :: s(*),work(*) end subroutine sgelsd -#else - module procedure stdlib_sgelsd +#else + module procedure stdlib${ii}$_sgelsd #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gelsd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zgelsd( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, rwork, & iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,rank,iwork(*) - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,rank,iwork(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,nrhs real(dp), intent(in) :: rcond real(dp), intent(out) :: rwork(*),s(*) complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: work(*) end subroutine zgelsd -#else - module procedure stdlib_zgelsd +#else + module procedure stdlib${ii}$_zgelsd #endif - end interface gelsd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gelsd +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gelsd +#:endif +#:endfor +#:endfor + end interface gelsd interface gelss !! GELSS computes the minimum norm solution to a complex linear @@ -2198,79 +2141,79 @@ module stdlib_linalg_lapack !! The effective rank of A is determined by treating as zero those !! singular values which are less than RCOND times the largest singular !! value. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cgelss( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, rwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,rank - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,rank + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,nrhs real(sp), intent(in) :: rcond real(sp), intent(out) :: rwork(*),s(*) complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: work(*) end subroutine cgelss -#else - module procedure stdlib_cgelss +#else + module procedure stdlib${ii}$_cgelss #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dgelss( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,rank - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,nrhs + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,rank + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,nrhs real(dp), intent(in) :: rcond real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(out) :: s(*),work(*) end subroutine dgelss -#else - module procedure stdlib_dgelss +#else + module procedure stdlib${ii}$_dgelss #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gelss - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sgelss( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,rank - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,nrhs + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,rank + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,nrhs real(sp), intent(in) :: rcond real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(out) :: s(*),work(*) end subroutine sgelss -#else - module procedure stdlib_sgelss +#else + module procedure stdlib${ii}$_sgelss #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gelss - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zgelss( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, rwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,rank - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,rank + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,nrhs real(dp), intent(in) :: rcond real(dp), intent(out) :: rwork(*),s(*) complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: work(*) end subroutine zgelss -#else - module procedure stdlib_zgelss +#else + module procedure stdlib${ii}$_zgelss #endif - end interface gelss +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gelss +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gelss +#:endif +#:endfor +#:endfor + end interface gelss interface gelsy !! GELSY computes the minimum-norm solution to a complex linear least @@ -2305,83 +2248,83 @@ module stdlib_linalg_lapack !! the call to the subroutine xGEQP3. This subroutine is a Blas-3 !! version of the QR factorization with column pivoting. !! o Matrix B (the right hand side) is updated with Blas-3. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cgelsy( m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank,work, lwork, & rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,rank - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,rank + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,nrhs real(sp), intent(in) :: rcond - integer(ilp), intent(inout) :: jpvt(*) + integer(${ik}$), intent(inout) :: jpvt(*) real(sp), intent(out) :: rwork(*) complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: work(*) end subroutine cgelsy -#else - module procedure stdlib_cgelsy +#else + module procedure stdlib${ii}$_cgelsy #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dgelsy( m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank,work, lwork, info & ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,rank - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,rank + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,nrhs real(dp), intent(in) :: rcond - integer(ilp), intent(inout) :: jpvt(*) + integer(${ik}$), intent(inout) :: jpvt(*) real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(out) :: work(*) end subroutine dgelsy -#else - module procedure stdlib_dgelsy +#else + module procedure stdlib${ii}$_dgelsy #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gelsy - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sgelsy( m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank,work, lwork, info & ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,rank - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,rank + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,nrhs real(sp), intent(in) :: rcond - integer(ilp), intent(inout) :: jpvt(*) + integer(${ik}$), intent(inout) :: jpvt(*) real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(out) :: work(*) end subroutine sgelsy -#else - module procedure stdlib_sgelsy +#else + module procedure stdlib${ii}$_sgelsy #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gelsy - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zgelsy( m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank,work, lwork, & rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,rank - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,rank + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,nrhs real(dp), intent(in) :: rcond - integer(ilp), intent(inout) :: jpvt(*) + integer(${ik}$), intent(inout) :: jpvt(*) real(dp), intent(out) :: rwork(*) complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: work(*) end subroutine zgelsy -#else - module procedure stdlib_zgelsy +#else + module procedure stdlib${ii}$_zgelsy #endif - end interface gelsy +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gelsy +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gelsy +#:endif +#:endfor +#:endfor + end interface gelsy interface gemlq !! GEMLQ overwrites the general real M-by-N matrix C with @@ -2391,81 +2334,81 @@ module stdlib_linalg_lapack !! where Q is a complex unitary matrix defined as the product !! of blocked elementary reflectors computed by short wide !! LQ factorization (CGELQ) -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgemlq( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork,& info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,k,tsize,lwork,ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,k,tsize,lwork,ldc complex(sp), intent(in) :: a(lda,*),t(*) complex(sp), intent(inout) :: c(ldc,*) complex(sp), intent(out) :: work(*) end subroutine cgemlq -#else - module procedure stdlib_cgemlq +#else + module procedure stdlib${ii}$_cgemlq #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgemlq( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork,& info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,k,tsize,lwork,ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,k,tsize,lwork,ldc real(dp), intent(in) :: a(lda,*),t(*) real(dp), intent(inout) :: c(ldc,*) real(dp), intent(out) :: work(*) end subroutine dgemlq -#else - module procedure stdlib_dgemlq +#else + module procedure stdlib${ii}$_dgemlq #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gemlq - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgemlq( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork,& info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,k,tsize,lwork,ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,k,tsize,lwork,ldc real(sp), intent(in) :: a(lda,*),t(*) real(sp), intent(inout) :: c(ldc,*) real(sp), intent(out) :: work(*) end subroutine sgemlq -#else - module procedure stdlib_sgemlq +#else + module procedure stdlib${ii}$_sgemlq #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gemlq - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgemlq( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork,& info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,k,tsize,lwork,ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,k,tsize,lwork,ldc complex(dp), intent(in) :: a(lda,*),t(*) complex(dp), intent(inout) :: c(ldc,*) complex(dp), intent(out) :: work(*) end subroutine zgemlq -#else - module procedure stdlib_zgemlq +#else + module procedure stdlib${ii}$_zgemlq #endif - end interface gemlq +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gemlq +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gemlq +#:endif +#:endfor +#:endfor + end interface gemlq interface gemlqt !! GEMLQT overwrites the general complex M-by-N matrix C with @@ -2477,81 +2420,81 @@ module stdlib_linalg_lapack !! Q = H(1) H(2) . . . H(K) = I - V T V**H !! generated using the compact WY representation as returned by CGELQT. !! Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgemlqt( side, trans, m, n, k, mb, v, ldv, t, ldt,c, ldc, work, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(in) :: v(ldv,*),t(ldt,*) complex(sp), intent(inout) :: c(ldc,*) complex(sp), intent(out) :: work(*) end subroutine cgemlqt -#else - module procedure stdlib_cgemlqt +#else + module procedure stdlib${ii}$_cgemlqt #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgemlqt( side, trans, m, n, k, mb, v, ldv, t, ldt,c, ldc, work, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(in) :: v(ldv,*),t(ldt,*) real(dp), intent(inout) :: c(ldc,*) real(dp), intent(out) :: work(*) end subroutine dgemlqt -#else - module procedure stdlib_dgemlqt +#else + module procedure stdlib${ii}$_dgemlqt #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gemlqt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgemlqt( side, trans, m, n, k, mb, v, ldv, t, ldt,c, ldc, work, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(in) :: v(ldv,*),t(ldt,*) real(sp), intent(inout) :: c(ldc,*) real(sp), intent(out) :: work(*) end subroutine sgemlqt -#else - module procedure stdlib_sgemlqt +#else + module procedure stdlib${ii}$_sgemlqt #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gemlqt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgemlqt( side, trans, m, n, k, mb, v, ldv, t, ldt,c, ldc, work, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(in) :: v(ldv,*),t(ldt,*) complex(dp), intent(inout) :: c(ldc,*) complex(dp), intent(out) :: work(*) end subroutine zgemlqt -#else - module procedure stdlib_zgemlqt +#else + module procedure stdlib${ii}$_zgemlqt #endif - end interface gemlqt +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gemlqt +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gemlqt +#:endif +#:endfor +#:endfor + end interface gemlqt interface gemqr !! GEMQR overwrites the general real M-by-N matrix C with @@ -2561,81 +2504,81 @@ module stdlib_linalg_lapack !! where Q is a complex unitary matrix defined as the product !! of blocked elementary reflectors computed by tall skinny !! QR factorization (CGEQR) -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgemqr( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork,& info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,k,tsize,lwork,ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,k,tsize,lwork,ldc complex(sp), intent(in) :: a(lda,*),t(*) complex(sp), intent(inout) :: c(ldc,*) complex(sp), intent(out) :: work(*) end subroutine cgemqr -#else - module procedure stdlib_cgemqr +#else + module procedure stdlib${ii}$_cgemqr #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgemqr( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork,& info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,k,tsize,lwork,ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,k,tsize,lwork,ldc real(dp), intent(in) :: a(lda,*),t(*) real(dp), intent(inout) :: c(ldc,*) real(dp), intent(out) :: work(*) end subroutine dgemqr -#else - module procedure stdlib_dgemqr +#else + module procedure stdlib${ii}$_dgemqr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gemqr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgemqr( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork,& info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,k,tsize,lwork,ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,k,tsize,lwork,ldc real(sp), intent(in) :: a(lda,*),t(*) real(sp), intent(inout) :: c(ldc,*) real(sp), intent(out) :: work(*) end subroutine sgemqr -#else - module procedure stdlib_sgemqr +#else + module procedure stdlib${ii}$_sgemqr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gemqr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgemqr( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork,& info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,k,tsize,lwork,ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,k,tsize,lwork,ldc complex(dp), intent(in) :: a(lda,*),t(*) complex(dp), intent(inout) :: c(ldc,*) complex(dp), intent(out) :: work(*) end subroutine zgemqr -#else - module procedure stdlib_zgemqr +#else + module procedure stdlib${ii}$_zgemqr #endif - end interface gemqr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gemqr +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gemqr +#:endif +#:endfor +#:endfor + end interface gemqr interface gemqrt !! GEMQRT overwrites the general complex M-by-N matrix C with @@ -2647,148 +2590,148 @@ module stdlib_linalg_lapack !! Q = H(1) H(2) . . . H(K) = I - V T V**H !! generated using the compact WY representation as returned by CGEQRT. !! Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgemqrt( side, trans, m, n, k, nb, v, ldv, t, ldt,c, ldc, work, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,ldv,ldc,m,n,nb,ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,ldv,ldc,m,n,nb,ldt complex(sp), intent(in) :: v(ldv,*),t(ldt,*) complex(sp), intent(inout) :: c(ldc,*) complex(sp), intent(out) :: work(*) end subroutine cgemqrt -#else - module procedure stdlib_cgemqrt +#else + module procedure stdlib${ii}$_cgemqrt #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgemqrt( side, trans, m, n, k, nb, v, ldv, t, ldt,c, ldc, work, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,ldv,ldc,m,n,nb,ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,ldv,ldc,m,n,nb,ldt real(dp), intent(in) :: v(ldv,*),t(ldt,*) real(dp), intent(inout) :: c(ldc,*) real(dp), intent(out) :: work(*) end subroutine dgemqrt -#else - module procedure stdlib_dgemqrt +#else + module procedure stdlib${ii}$_dgemqrt #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gemqrt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgemqrt( side, trans, m, n, k, nb, v, ldv, t, ldt,c, ldc, work, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,ldv,ldc,m,n,nb,ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,ldv,ldc,m,n,nb,ldt real(sp), intent(in) :: v(ldv,*),t(ldt,*) real(sp), intent(inout) :: c(ldc,*) real(sp), intent(out) :: work(*) end subroutine sgemqrt -#else - module procedure stdlib_sgemqrt +#else + module procedure stdlib${ii}$_sgemqrt #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gemqrt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgemqrt( side, trans, m, n, k, nb, v, ldv, t, ldt,c, ldc, work, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,ldv,ldc,m,n,nb,ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,ldv,ldc,m,n,nb,ldt complex(dp), intent(in) :: v(ldv,*),t(ldt,*) complex(dp), intent(inout) :: c(ldc,*) complex(dp), intent(out) :: work(*) end subroutine zgemqrt -#else - module procedure stdlib_zgemqrt +#else + module procedure stdlib${ii}$_zgemqrt #endif - end interface gemqrt +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gemqrt +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gemqrt +#:endif +#:endfor +#:endfor + end interface gemqrt interface geqlf !! GEQLF computes a QL factorization of a complex M-by-N matrix A: !! A = Q * L. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgeqlf( m, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: tau(*),work(*) end subroutine cgeqlf -#else - module procedure stdlib_cgeqlf +#else + module procedure stdlib${ii}$_cgeqlf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgeqlf( m, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: tau(*),work(*) end subroutine dgeqlf -#else - module procedure stdlib_dgeqlf +#else + module procedure stdlib${ii}$_dgeqlf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$geqlf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgeqlf( m, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: tau(*),work(*) end subroutine sgeqlf -#else - module procedure stdlib_sgeqlf +#else + module procedure stdlib${ii}$_sgeqlf #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$geqlf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgeqlf( m, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: tau(*),work(*) end subroutine zgeqlf -#else - module procedure stdlib_zgeqlf +#else + module procedure stdlib${ii}$_zgeqlf #endif - end interface geqlf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$geqlf +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$geqlf +#:endif +#:endfor +#:endfor + end interface geqlf interface geqr !! GEQR computes a QR factorization of a complex M-by-N matrix A: @@ -2798,69 +2741,69 @@ module stdlib_linalg_lapack !! Q is a M-by-M orthogonal matrix; !! R is an upper-triangular N-by-N matrix; !! 0 is a (M-N)-by-N zero matrix, if M > N. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgeqr( m, n, a, lda, t, tsize, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,tsize,lwork + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,tsize,lwork complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: t(*),work(*) end subroutine cgeqr -#else - module procedure stdlib_cgeqr +#else + module procedure stdlib${ii}$_cgeqr #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgeqr( m, n, a, lda, t, tsize, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,tsize,lwork + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,tsize,lwork real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: t(*),work(*) end subroutine dgeqr -#else - module procedure stdlib_dgeqr +#else + module procedure stdlib${ii}$_dgeqr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$geqr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgeqr( m, n, a, lda, t, tsize, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,tsize,lwork + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,tsize,lwork real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: t(*),work(*) end subroutine sgeqr -#else - module procedure stdlib_sgeqr +#else + module procedure stdlib${ii}$_sgeqr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$geqr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgeqr( m, n, a, lda, t, tsize, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,tsize,lwork + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,tsize,lwork complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: t(*),work(*) end subroutine zgeqr -#else - module procedure stdlib_zgeqr +#else + module procedure stdlib${ii}$_zgeqr #endif - end interface geqr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$geqr +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$geqr +#:endif +#:endfor +#:endfor + end interface geqr interface geqr2p !! GEQR2P computes a QR factorization of a complex m-by-n matrix A: @@ -2871,69 +2814,69 @@ module stdlib_linalg_lapack !! R is an upper-triangular n-by-n matrix with nonnegative diagonal !! entries; !! 0 is a (m-n)-by-n zero matrix, if m > n. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cgeqr2p( m, n, a, lda, tau, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: tau(*),work(*) end subroutine cgeqr2p -#else - module procedure stdlib_cgeqr2p +#else + module procedure stdlib${ii}$_cgeqr2p #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dgeqr2p( m, n, a, lda, tau, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: tau(*),work(*) end subroutine dgeqr2p -#else - module procedure stdlib_dgeqr2p +#else + module procedure stdlib${ii}$_dgeqr2p #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$geqr2p - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sgeqr2p( m, n, a, lda, tau, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: tau(*),work(*) end subroutine sgeqr2p -#else - module procedure stdlib_sgeqr2p +#else + module procedure stdlib${ii}$_sgeqr2p #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$geqr2p - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zgeqr2p( m, n, a, lda, tau, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: tau(*),work(*) end subroutine zgeqr2p -#else - module procedure stdlib_zgeqr2p +#else + module procedure stdlib${ii}$_zgeqr2p #endif - end interface geqr2p - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$geqr2p + +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$geqr2p +#:endif +#:endfor +#:endfor + end interface geqr2p interface geqrf !! GEQRF computes a QR factorization of a complex M-by-N matrix A: @@ -2943,69 +2886,69 @@ module stdlib_linalg_lapack !! Q is a M-by-M orthogonal matrix; !! R is an upper-triangular N-by-N matrix; !! 0 is a (M-N)-by-N zero matrix, if M > N. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgeqrf( m, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: tau(*),work(*) end subroutine cgeqrf -#else - module procedure stdlib_cgeqrf +#else + module procedure stdlib${ii}$_cgeqrf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgeqrf( m, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: tau(*),work(*) end subroutine dgeqrf -#else - module procedure stdlib_dgeqrf +#else + module procedure stdlib${ii}$_dgeqrf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$geqrf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgeqrf( m, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: tau(*),work(*) end subroutine sgeqrf -#else - module procedure stdlib_sgeqrf +#else + module procedure stdlib${ii}$_sgeqrf #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$geqrf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgeqrf( m, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: tau(*),work(*) end subroutine zgeqrf -#else - module procedure stdlib_zgeqrf +#else + module procedure stdlib${ii}$_zgeqrf #endif - end interface geqrf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$geqrf +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$geqrf +#:endif +#:endfor +#:endfor + end interface geqrf interface geqrfp !! CGEQR2P computes a QR factorization of a complex M-by-N matrix A: @@ -3016,421 +2959,421 @@ module stdlib_linalg_lapack !! R is an upper-triangular N-by-N matrix with nonnegative diagonal !! entries; !! 0 is a (M-N)-by-N zero matrix, if M > N. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cgeqrfp( m, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: tau(*),work(*) end subroutine cgeqrfp -#else - module procedure stdlib_cgeqrfp +#else + module procedure stdlib${ii}$_cgeqrfp #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dgeqrfp( m, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: tau(*),work(*) end subroutine dgeqrfp -#else - module procedure stdlib_dgeqrfp +#else + module procedure stdlib${ii}$_dgeqrfp #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$geqrfp - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sgeqrfp( m, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: tau(*),work(*) end subroutine sgeqrfp -#else - module procedure stdlib_sgeqrfp +#else + module procedure stdlib${ii}$_sgeqrfp #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$geqrfp - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zgeqrfp( m, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: tau(*),work(*) end subroutine zgeqrfp -#else - module procedure stdlib_zgeqrfp +#else + module procedure stdlib${ii}$_zgeqrfp #endif - end interface geqrfp +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$geqrfp +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$geqrfp +#:endif +#:endfor +#:endfor + end interface geqrfp interface geqrt !! GEQRT computes a blocked QR factorization of a complex M-by-N matrix A !! using the compact WY representation of Q. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgeqrt( m, n, nb, a, lda, t, ldt, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,m,n,nb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,m,n,nb complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: t(ldt,*),work(*) end subroutine cgeqrt -#else - module procedure stdlib_cgeqrt +#else + module procedure stdlib${ii}$_cgeqrt #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgeqrt( m, n, nb, a, lda, t, ldt, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,m,n,nb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,m,n,nb real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: t(ldt,*),work(*) end subroutine dgeqrt -#else - module procedure stdlib_dgeqrt +#else + module procedure stdlib${ii}$_dgeqrt #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$geqrt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgeqrt( m, n, nb, a, lda, t, ldt, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,m,n,nb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,m,n,nb real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: t(ldt,*),work(*) end subroutine sgeqrt -#else - module procedure stdlib_sgeqrt +#else + module procedure stdlib${ii}$_sgeqrt #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$geqrt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgeqrt( m, n, nb, a, lda, t, ldt, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,m,n,nb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,m,n,nb complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: t(ldt,*),work(*) end subroutine zgeqrt -#else - module procedure stdlib_zgeqrt +#else + module procedure stdlib${ii}$_zgeqrt #endif - end interface geqrt +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$geqrt +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$geqrt +#:endif +#:endfor +#:endfor + end interface geqrt interface geqrt2 !! GEQRT2 computes a QR factorization of a complex M-by-N matrix A, !! using the compact WY representation of Q. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgeqrt2( m, n, a, lda, t, ldt, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,m,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: t(ldt,*) end subroutine cgeqrt2 -#else - module procedure stdlib_cgeqrt2 +#else + module procedure stdlib${ii}$_cgeqrt2 #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgeqrt2( m, n, a, lda, t, ldt, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,m,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: t(ldt,*) end subroutine dgeqrt2 -#else - module procedure stdlib_dgeqrt2 +#else + module procedure stdlib${ii}$_dgeqrt2 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$geqrt2 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgeqrt2( m, n, a, lda, t, ldt, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,m,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: t(ldt,*) end subroutine sgeqrt2 -#else - module procedure stdlib_sgeqrt2 +#else + module procedure stdlib${ii}$_sgeqrt2 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$geqrt2 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgeqrt2( m, n, a, lda, t, ldt, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,m,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: t(ldt,*) end subroutine zgeqrt2 -#else - module procedure stdlib_zgeqrt2 +#else + module procedure stdlib${ii}$_zgeqrt2 #endif - end interface geqrt2 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$geqrt2 +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$geqrt2 +#:endif +#:endfor +#:endfor + end interface geqrt2 interface geqrt3 !! GEQRT3 recursively computes a QR factorization of a complex M-by-N matrix A, !! using the compact WY representation of Q. !! Based on the algorithm of Elmroth and Gustavson, !! IBM J. Res. Develop. Vol 44 No. 4 July 2000. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure recursive subroutine cgeqrt3( m, n, a, lda, t, ldt, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,ldt + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,ldt complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: t(ldt,*) end subroutine cgeqrt3 -#else - module procedure stdlib_cgeqrt3 +#else + module procedure stdlib${ii}$_cgeqrt3 #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure recursive subroutine dgeqrt3( m, n, a, lda, t, ldt, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,ldt + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,ldt real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: t(ldt,*) end subroutine dgeqrt3 -#else - module procedure stdlib_dgeqrt3 +#else + module procedure stdlib${ii}$_dgeqrt3 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$geqrt3 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure recursive subroutine sgeqrt3( m, n, a, lda, t, ldt, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,ldt + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,ldt real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: t(ldt,*) end subroutine sgeqrt3 -#else - module procedure stdlib_sgeqrt3 +#else + module procedure stdlib${ii}$_sgeqrt3 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$geqrt3 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure recursive subroutine zgeqrt3( m, n, a, lda, t, ldt, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,ldt + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,ldt complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: t(ldt,*) end subroutine zgeqrt3 -#else - module procedure stdlib_zgeqrt3 +#else + module procedure stdlib${ii}$_zgeqrt3 #endif - end interface geqrt3 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$geqrt3 +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$geqrt3 +#:endif +#:endfor +#:endfor + end interface geqrt3 interface gerfs !! GERFS improves the computed solution to a system of linear !! equations and provides error bounds and backward error estimates for !! the solution. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, & ferr, berr, work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs,ipiv(*) real(sp), intent(out) :: berr(*),ferr(*),rwork(*) complex(sp), intent(in) :: a(lda,*),af(ldaf,*),b(ldb,*) complex(sp), intent(out) :: work(*) complex(sp), intent(inout) :: x(ldx,*) end subroutine cgerfs -#else - module procedure stdlib_cgerfs +#else + module procedure stdlib${ii}$_cgerfs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, & ferr, berr, work, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs,ipiv(*) real(dp), intent(in) :: a(lda,*),af(ldaf,*),b(ldb,*) real(dp), intent(out) :: berr(*),ferr(*),work(*) real(dp), intent(inout) :: x(ldx,*) end subroutine dgerfs -#else - module procedure stdlib_dgerfs +#else + module procedure stdlib${ii}$_dgerfs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gerfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, & ferr, berr, work, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs,ipiv(*) real(sp), intent(in) :: a(lda,*),af(ldaf,*),b(ldb,*) real(sp), intent(out) :: berr(*),ferr(*),work(*) real(sp), intent(inout) :: x(ldx,*) end subroutine sgerfs -#else - module procedure stdlib_sgerfs +#else + module procedure stdlib${ii}$_sgerfs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gerfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, & ferr, berr, work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs,ipiv(*) real(dp), intent(out) :: berr(*),ferr(*),rwork(*) complex(dp), intent(in) :: a(lda,*),af(ldaf,*),b(ldb,*) complex(dp), intent(out) :: work(*) complex(dp), intent(inout) :: x(ldx,*) end subroutine zgerfs -#else - module procedure stdlib_zgerfs +#else + module procedure stdlib${ii}$_zgerfs #endif - end interface gerfs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gerfs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gerfs +#:endif +#:endfor +#:endfor + end interface gerfs interface gerqf !! GERQF computes an RQ factorization of a complex M-by-N matrix A: !! A = R * Q. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgerqf( m, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: tau(*),work(*) end subroutine cgerqf -#else - module procedure stdlib_cgerqf +#else + module procedure stdlib${ii}$_cgerqf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgerqf( m, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: tau(*),work(*) end subroutine dgerqf -#else - module procedure stdlib_dgerqf +#else + module procedure stdlib${ii}$_dgerqf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gerqf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgerqf( m, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: tau(*),work(*) end subroutine sgerqf -#else - module procedure stdlib_sgerqf +#else + module procedure stdlib${ii}$_sgerqf #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gerqf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgerqf( m, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: tau(*),work(*) end subroutine zgerqf -#else - module procedure stdlib_zgerqf +#else + module procedure stdlib${ii}$_zgerqf #endif - end interface gerqf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gerqf +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gerqf +#:endif +#:endfor +#:endfor + end interface gerqf interface gesdd !! GESDD computes the singular value decomposition (SVD) of a complex @@ -3450,79 +3393,79 @@ module stdlib_linalg_lapack !! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or !! Cray-2. It could conceivably fail on hexadecimal or decimal machines !! without guard digits, but we know of none. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cgesdd( jobz, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, rwork, & iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,ldu,ldvt,lwork,m,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,ldu,ldvt,lwork,m,n real(sp), intent(out) :: rwork(*),s(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: u(ldu,*),vt(ldvt,*),work(*) end subroutine cgesdd -#else - module procedure stdlib_cgesdd +#else + module procedure stdlib${ii}$_cgesdd #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dgesdd( jobz, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, iwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,ldu,ldvt,lwork,m,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,ldu,ldvt,lwork,m,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: s(*),u(ldu,*),vt(ldvt,*),work(*) end subroutine dgesdd -#else - module procedure stdlib_dgesdd +#else + module procedure stdlib${ii}$_dgesdd #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gesdd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sgesdd( jobz, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, iwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,ldu,ldvt,lwork,m,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,ldu,ldvt,lwork,m,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: s(*),u(ldu,*),vt(ldvt,*),work(*) end subroutine sgesdd -#else - module procedure stdlib_sgesdd +#else + module procedure stdlib${ii}$_sgesdd #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gesdd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zgesdd( jobz, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, rwork, & iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,ldu,ldvt,lwork,m,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,ldu,ldvt,lwork,m,n real(dp), intent(out) :: rwork(*),s(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: u(ldu,*),vt(ldvt,*),work(*) end subroutine zgesdd -#else - module procedure stdlib_zgesdd +#else + module procedure stdlib${ii}$_zgesdd #endif - end interface gesdd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gesdd +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gesdd +#:endif +#:endfor +#:endfor + end interface gesdd interface gesv !! GESV computes the solution to a complex system of linear equations @@ -3534,66 +3477,66 @@ module stdlib_linalg_lapack !! where P is a permutation matrix, L is unit lower triangular, and U is !! upper triangular. The factored form of A is then used to solve the !! system of equations A * X = B. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgesv( n, nrhs, a, lda, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,n,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs complex(sp), intent(inout) :: a(lda,*),b(ldb,*) end subroutine cgesv -#else - module procedure stdlib_cgesv +#else + module procedure stdlib${ii}$_cgesv #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgesv( n, nrhs, a, lda, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,n,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs real(dp), intent(inout) :: a(lda,*),b(ldb,*) end subroutine dgesv -#else - module procedure stdlib_dgesv +#else + module procedure stdlib${ii}$_dgesv +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine sgesv( n, nrhs, a, lda, ipiv, b, ldb, info ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs + real(sp), intent(inout) :: a(lda,*),b(ldb,*) + end subroutine sgesv +#else + module procedure stdlib${ii}$_sgesv +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine zgesv( n, nrhs, a, lda, ipiv, b, ldb, info ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs + complex(dp), intent(inout) :: a(lda,*),b(ldb,*) + end subroutine zgesv +#else + module procedure stdlib${ii}$_zgesv #endif #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gesv + module procedure stdlib${ii}$_${ri}$gesv #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine sgesv( n, nrhs, a, lda, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,n,nrhs - real(sp), intent(inout) :: a(lda,*),b(ldb,*) - end subroutine sgesv -#else - module procedure stdlib_sgesv -#endif #:for rk,rt,ri in CMPLX_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gesv + module procedure stdlib${ii}$_${ri}$gesv #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine zgesv( n, nrhs, a, lda, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,n,nrhs - complex(dp), intent(inout) :: a(lda,*),b(ldb,*) - end subroutine zgesv -#else - module procedure stdlib_zgesv -#endif +#:endfor end interface gesv - - interface gesvd !! GESVD computes the singular value decomposition (SVD) of a complex !! M-by-N matrix A, optionally computing the left and/or right singular @@ -3606,79 +3549,79 @@ module stdlib_linalg_lapack !! are returned in descending order. The first min(m,n) columns of !! U and V are the left and right singular vectors of A. !! Note that the routine returns V**H, not V. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cgesvd( jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, & rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobu,jobvt - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldu,ldvt,lwork,m,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldu,ldvt,lwork,m,n real(sp), intent(out) :: rwork(*),s(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: u(ldu,*),vt(ldvt,*),work(*) end subroutine cgesvd -#else - module procedure stdlib_cgesvd +#else + module procedure stdlib${ii}$_cgesvd #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dgesvd( jobu, jobvt, m, n, a, lda, s, u, ldu,vt, ldvt, work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobu,jobvt - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldu,ldvt,lwork,m,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldu,ldvt,lwork,m,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: s(*),u(ldu,*),vt(ldvt,*),work(*) end subroutine dgesvd -#else - module procedure stdlib_dgesvd +#else + module procedure stdlib${ii}$_dgesvd #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gesvd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sgesvd( jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobu,jobvt - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldu,ldvt,lwork,m,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldu,ldvt,lwork,m,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: s(*),u(ldu,*),vt(ldvt,*),work(*) end subroutine sgesvd -#else - module procedure stdlib_sgesvd +#else + module procedure stdlib${ii}$_sgesvd #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gesvd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zgesvd( jobu, jobvt, m, n, a, lda, s, u, ldu,vt, ldvt, work, lwork, & rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobu,jobvt - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldu,ldvt,lwork,m,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldu,ldvt,lwork,m,n real(dp), intent(out) :: rwork(*),s(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: u(ldu,*),vt(ldvt,*),work(*) end subroutine zgesvd -#else - module procedure stdlib_zgesvd +#else + module procedure stdlib${ii}$_zgesvd #endif - end interface gesvd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gesvd +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gesvd +#:endif +#:endfor +#:endfor + end interface gesvd interface gesvdq !! GESVDQ computes the singular value decomposition (SVD) of a complex @@ -3690,83 +3633,83 @@ module stdlib_linalg_lapack !! matrix, and V is an N-by-N unitary matrix. The diagonal elements !! of SIGMA are the singular values of A. The columns of U and V are the !! left and the right singular vectors of A, respectively. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cgesvdq( joba, jobp, jobr, jobu, jobv, m, n, a, lda,s, u, ldu, v, ldv, & numrank, iwork, liwork,cwork, lcwork, rwork, lrwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: joba,jobp,jobr,jobu,jobv - integer(ilp), intent(in) :: m,n,lda,ldu,ldv,liwork,lrwork - integer(ilp), intent(out) :: numrank,info,iwork(*) - integer(ilp), intent(inout) :: lcwork + integer(${ik}$), intent(in) :: m,n,lda,ldu,ldv,liwork,lrwork + integer(${ik}$), intent(out) :: numrank,info,iwork(*) + integer(${ik}$), intent(inout) :: lcwork complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: u(ldu,*),v(ldv,*),cwork(*) real(sp), intent(out) :: s(*),rwork(*) end subroutine cgesvdq -#else - module procedure stdlib_cgesvdq +#else + module procedure stdlib${ii}$_cgesvdq #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dgesvdq( joba, jobp, jobr, jobu, jobv, m, n, a, lda,s, u, ldu, v, ldv, & numrank, iwork, liwork,work, lwork, rwork, lrwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: joba,jobp,jobr,jobu,jobv - integer(ilp), intent(in) :: m,n,lda,ldu,ldv,liwork,lrwork - integer(ilp), intent(out) :: numrank,info,iwork(*) - integer(ilp), intent(inout) :: lwork + integer(${ik}$), intent(in) :: m,n,lda,ldu,ldv,liwork,lrwork + integer(${ik}$), intent(out) :: numrank,info,iwork(*) + integer(${ik}$), intent(inout) :: lwork real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: u(ldu,*),v(ldv,*),work(*),s(*),rwork(*) end subroutine dgesvdq -#else - module procedure stdlib_dgesvdq +#else + module procedure stdlib${ii}$_dgesvdq #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gesvdq - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sgesvdq( joba, jobp, jobr, jobu, jobv, m, n, a, lda,s, u, ldu, v, ldv, & numrank, iwork, liwork,work, lwork, rwork, lrwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: joba,jobp,jobr,jobu,jobv - integer(ilp), intent(in) :: m,n,lda,ldu,ldv,liwork,lrwork - integer(ilp), intent(out) :: numrank,info,iwork(*) - integer(ilp), intent(inout) :: lwork + integer(${ik}$), intent(in) :: m,n,lda,ldu,ldv,liwork,lrwork + integer(${ik}$), intent(out) :: numrank,info,iwork(*) + integer(${ik}$), intent(inout) :: lwork real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: u(ldu,*),v(ldv,*),work(*),s(*),rwork(*) end subroutine sgesvdq -#else - module procedure stdlib_sgesvdq +#else + module procedure stdlib${ii}$_sgesvdq #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gesvdq - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zgesvdq( joba, jobp, jobr, jobu, jobv, m, n, a, lda,s, u, ldu, v, ldv, & numrank, iwork, liwork,cwork, lcwork, rwork, lrwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: joba,jobp,jobr,jobu,jobv - integer(ilp), intent(in) :: m,n,lda,ldu,ldv,liwork,lrwork - integer(ilp), intent(out) :: numrank,info,iwork(*) - integer(ilp), intent(inout) :: lcwork + integer(${ik}$), intent(in) :: m,n,lda,ldu,ldv,liwork,lrwork + integer(${ik}$), intent(out) :: numrank,info,iwork(*) + integer(${ik}$), intent(inout) :: lcwork complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: u(ldu,*),v(ldv,*),cwork(*) real(dp), intent(out) :: s(*),rwork(*) end subroutine zgesvdq -#else - module procedure stdlib_zgesvdq +#else + module procedure stdlib${ii}$_zgesvdq #endif - end interface gesvdq +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gesvdq +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gesvdq +#:endif +#:endfor +#:endfor + end interface gesvdq interface gesvj !! GESVJ computes the singular value decomposition (SVD) of a complex @@ -3778,81 +3721,81 @@ module stdlib_linalg_lapack !! matrix, and V is an N-by-N unitary matrix. The diagonal elements !! of SIGMA are the singular values of A. The columns of U and V are the !! left and the right singular vectors of A, respectively. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgesvj( joba, jobu, jobv, m, n, a, lda, sva, mv, v,ldv, cwork, & lwork, rwork, lrwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldv,lwork,lrwork,m,mv,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldv,lwork,lrwork,m,mv,n character, intent(in) :: joba,jobu,jobv complex(sp), intent(inout) :: a(lda,*),v(ldv,*),cwork(lwork) real(sp), intent(inout) :: rwork(lrwork) real(sp), intent(out) :: sva(n) end subroutine cgesvj -#else - module procedure stdlib_cgesvj +#else + module procedure stdlib${ii}$_cgesvj #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgesvj( joba, jobu, jobv, m, n, a, lda, sva, mv, v,ldv, work, & lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldv,lwork,m,mv,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldv,lwork,m,mv,n character, intent(in) :: joba,jobu,jobv real(dp), intent(inout) :: a(lda,*),v(ldv,*),work(lwork) real(dp), intent(out) :: sva(n) end subroutine dgesvj -#else - module procedure stdlib_dgesvj +#else + module procedure stdlib${ii}$_dgesvj #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gesvj - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgesvj( joba, jobu, jobv, m, n, a, lda, sva, mv, v,ldv, work, & lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldv,lwork,m,mv,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldv,lwork,m,mv,n character, intent(in) :: joba,jobu,jobv real(sp), intent(inout) :: a(lda,*),v(ldv,*),work(lwork) real(sp), intent(out) :: sva(n) end subroutine sgesvj -#else - module procedure stdlib_sgesvj +#else + module procedure stdlib${ii}$_sgesvj #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gesvj - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgesvj( joba, jobu, jobv, m, n, a, lda, sva, mv, v,ldv, cwork, & lwork, rwork, lrwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldv,lwork,lrwork,m,mv,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldv,lwork,lrwork,m,mv,n character, intent(in) :: joba,jobu,jobv complex(dp), intent(inout) :: a(lda,*),v(ldv,*),cwork(lwork) real(dp), intent(inout) :: rwork(lrwork) real(dp), intent(out) :: sva(n) end subroutine zgesvj -#else - module procedure stdlib_zgesvj +#else + module procedure stdlib${ii}$_zgesvj #endif - end interface gesvj - - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gesvj - interface getrf +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gesvj + +#:endif +#:endfor +#:endfor + end interface gesvj + + interface getrf !! GETRF computes an LU factorization of a general M-by-N matrix A !! using partial pivoting with row interchanges. !! The factorization has the form @@ -3861,66 +3804,66 @@ module stdlib_linalg_lapack !! diagonal elements (lower trapezoidal if m > n), and U is upper !! triangular (upper trapezoidal if m < n). !! This is the right-looking Level 3 BLAS version of the algorithm. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgetrf( m, n, a, lda, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,m,n complex(sp), intent(inout) :: a(lda,*) end subroutine cgetrf -#else - module procedure stdlib_cgetrf +#else + module procedure stdlib${ii}$_cgetrf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgetrf( m, n, a, lda, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,m,n real(dp), intent(inout) :: a(lda,*) end subroutine dgetrf -#else - module procedure stdlib_dgetrf +#else + module procedure stdlib${ii}$_dgetrf +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine sgetrf( m, n, a, lda, ipiv, info ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,m,n + real(sp), intent(inout) :: a(lda,*) + end subroutine sgetrf +#else + module procedure stdlib${ii}$_sgetrf +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine zgetrf( m, n, a, lda, ipiv, info ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,m,n + complex(dp), intent(inout) :: a(lda,*) + end subroutine zgetrf +#else + module procedure stdlib${ii}$_zgetrf #endif #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$getrf + module procedure stdlib${ii}$_${ri}$getrf #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine sgetrf( m, n, a, lda, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,m,n - real(sp), intent(inout) :: a(lda,*) - end subroutine sgetrf -#else - module procedure stdlib_sgetrf -#endif #:for rk,rt,ri in CMPLX_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$getrf + module procedure stdlib${ii}$_${ri}$getrf #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine zgetrf( m, n, a, lda, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,m,n - complex(dp), intent(inout) :: a(lda,*) - end subroutine zgetrf -#else - module procedure stdlib_zgetrf -#endif +#:endfor end interface getrf - - interface getrf2 !! GETRF2 computes an LU factorization of a general M-by-N matrix A !! using partial pivoting with row interchanges. @@ -3941,207 +3884,207 @@ module stdlib_linalg_lapack !! do the swaps on [ --- ], solve A12, update A22, !! [ A22 ] !! then calls itself to factor A22 and do the swaps on A21. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure recursive subroutine cgetrf2( m, n, a, lda, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,m,n complex(sp), intent(inout) :: a(lda,*) end subroutine cgetrf2 -#else - module procedure stdlib_cgetrf2 +#else + module procedure stdlib${ii}$_cgetrf2 #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure recursive subroutine dgetrf2( m, n, a, lda, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,m,n real(dp), intent(inout) :: a(lda,*) end subroutine dgetrf2 -#else - module procedure stdlib_dgetrf2 +#else + module procedure stdlib${ii}$_dgetrf2 +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure recursive subroutine sgetrf2( m, n, a, lda, ipiv, info ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,m,n + real(sp), intent(inout) :: a(lda,*) + end subroutine sgetrf2 +#else + module procedure stdlib${ii}$_sgetrf2 +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure recursive subroutine zgetrf2( m, n, a, lda, ipiv, info ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,m,n + complex(dp), intent(inout) :: a(lda,*) + end subroutine zgetrf2 +#else + module procedure stdlib${ii}$_zgetrf2 #endif #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$getrf2 + module procedure stdlib${ii}$_${ri}$getrf2 #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure recursive subroutine sgetrf2( m, n, a, lda, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,m,n - real(sp), intent(inout) :: a(lda,*) - end subroutine sgetrf2 -#else - module procedure stdlib_sgetrf2 -#endif #:for rk,rt,ri in CMPLX_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$getrf2 + module procedure stdlib${ii}$_${ri}$getrf2 #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure recursive subroutine zgetrf2( m, n, a, lda, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,m,n - complex(dp), intent(inout) :: a(lda,*) - end subroutine zgetrf2 -#else - module procedure stdlib_zgetrf2 -#endif +#:endfor end interface getrf2 - - interface getri !! GETRI computes the inverse of a matrix using the LU factorization !! computed by CGETRF. !! This method inverts U and then computes inv(A) by solving the system !! inv(A)*L = inv(U) for inv(A). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgetri( n, a, lda, ipiv, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,n,ipiv(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,n,ipiv(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: work(*) end subroutine cgetri -#else - module procedure stdlib_cgetri +#else + module procedure stdlib${ii}$_cgetri #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgetri( n, a, lda, ipiv, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,n,ipiv(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,n,ipiv(*) real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: work(*) end subroutine dgetri -#else - module procedure stdlib_dgetri +#else + module procedure stdlib${ii}$_dgetri #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$getri - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgetri( n, a, lda, ipiv, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,n,ipiv(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,n,ipiv(*) real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: work(*) end subroutine sgetri -#else - module procedure stdlib_sgetri +#else + module procedure stdlib${ii}$_sgetri #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$getri - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgetri( n, a, lda, ipiv, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,n,ipiv(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,n,ipiv(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: work(*) end subroutine zgetri -#else - module procedure stdlib_zgetri +#else + module procedure stdlib${ii}$_zgetri #endif - end interface getri +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$getri +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$getri +#:endif +#:endfor +#:endfor + end interface getri interface getrs !! GETRS solves a system of linear equations !! A * X = B, A**T * X = B, or A**H * X = B !! with a general N-by-N matrix A using the LU factorization computed !! by CGETRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgetrs( trans, n, nrhs, a, lda, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) complex(sp), intent(in) :: a(lda,*) complex(sp), intent(inout) :: b(ldb,*) end subroutine cgetrs -#else - module procedure stdlib_cgetrs +#else + module procedure stdlib${ii}$_cgetrs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgetrs( trans, n, nrhs, a, lda, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) real(dp), intent(in) :: a(lda,*) real(dp), intent(inout) :: b(ldb,*) end subroutine dgetrs -#else - module procedure stdlib_dgetrs +#else + module procedure stdlib${ii}$_dgetrs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$getrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgetrs( trans, n, nrhs, a, lda, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) real(sp), intent(in) :: a(lda,*) real(sp), intent(inout) :: b(ldb,*) end subroutine sgetrs -#else - module procedure stdlib_sgetrs +#else + module procedure stdlib${ii}$_sgetrs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$getrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgetrs( trans, n, nrhs, a, lda, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) complex(dp), intent(in) :: a(lda,*) complex(dp), intent(inout) :: b(ldb,*) end subroutine zgetrs -#else - module procedure stdlib_zgetrs +#else + module procedure stdlib${ii}$_zgetrs #endif - end interface getrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$getrs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$getrs +#:endif +#:endfor +#:endfor + end interface getrs interface getsls !! GETSLS solves overdetermined or underdetermined complex linear systems @@ -4162,73 +4105,73 @@ module stdlib_linalg_lapack !! handled in a single call; they are stored as the columns of the !! M-by-NRHS right hand side matrix B and the N-by-NRHS solution !! matrix X. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cgetsls( trans, m, n, nrhs, a, lda, b, ldb,work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,nrhs complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: work(*) end subroutine cgetsls -#else - module procedure stdlib_cgetsls +#else + module procedure stdlib${ii}$_cgetsls #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dgetsls( trans, m, n, nrhs, a, lda, b, ldb,work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,nrhs real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(out) :: work(*) end subroutine dgetsls -#else - module procedure stdlib_dgetsls +#else + module procedure stdlib${ii}$_dgetsls #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$getsls - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sgetsls( trans, m, n, nrhs, a, lda, b, ldb,work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,nrhs real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(out) :: work(*) end subroutine sgetsls -#else - module procedure stdlib_sgetsls +#else + module procedure stdlib${ii}$_sgetsls #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$getsls - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zgetsls( trans, m, n, nrhs, a, lda, b, ldb,work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,nrhs complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: work(*) end subroutine zgetsls -#else - module procedure stdlib_zgetsls +#else + module procedure stdlib${ii}$_zgetsls #endif - end interface getsls +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$getsls +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$getsls +#:endif +#:endfor +#:endfor + end interface getsls interface getsqrhrt !! GETSQRHRT computes a NB2-sized column blocked QR-factorization @@ -4243,150 +4186,150 @@ module stdlib_linalg_lapack !! The output Q and R factors are stored in the same format as in CGEQRT !! (Q is in blocked compact WY-representation). See the documentation !! of CGEQRT for more details on the format. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgetsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,lwork,m,n,nb1,nb2,mb1 + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,lwork,m,n,nb1,nb2,mb1 complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: t(ldt,*),work(*) end subroutine cgetsqrhrt -#else - module procedure stdlib_cgetsqrhrt +#else + module procedure stdlib${ii}$_cgetsqrhrt #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgetsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,lwork,m,n,nb1,nb2,mb1 + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,lwork,m,n,nb1,nb2,mb1 real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: t(ldt,*),work(*) end subroutine dgetsqrhrt -#else - module procedure stdlib_dgetsqrhrt +#else + module procedure stdlib${ii}$_dgetsqrhrt #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$getsqrhrt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgetsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,lwork,m,n,nb1,nb2,mb1 + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,lwork,m,n,nb1,nb2,mb1 real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: t(ldt,*),work(*) end subroutine sgetsqrhrt -#else - module procedure stdlib_sgetsqrhrt +#else + module procedure stdlib${ii}$_sgetsqrhrt #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$getsqrhrt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgetsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,lwork,m,n,nb1,nb2,mb1 + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,lwork,m,n,nb1,nb2,mb1 complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: t(ldt,*),work(*) end subroutine zgetsqrhrt -#else - module procedure stdlib_zgetsqrhrt +#else + module procedure stdlib${ii}$_zgetsqrhrt #endif - end interface getsqrhrt +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$getsqrhrt +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$getsqrhrt +#:endif +#:endfor +#:endfor + end interface getsqrhrt interface ggbak !! GGBAK forms the right or left eigenvectors of a complex generalized !! eigenvalue problem A*x = lambda*B*x, by backward transformation on !! the computed eigenvectors of the balanced pair of matrices output by !! CGGBAL. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cggbak( job, side, n, ilo, ihi, lscale, rscale, m, v,ldv, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(in) :: lscale(*),rscale(*) complex(sp), intent(inout) :: v(ldv,*) end subroutine cggbak -#else - module procedure stdlib_cggbak +#else + module procedure stdlib${ii}$_cggbak #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dggbak( job, side, n, ilo, ihi, lscale, rscale, m, v,ldv, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(in) :: lscale(*),rscale(*) real(dp), intent(inout) :: v(ldv,*) end subroutine dggbak -#else - module procedure stdlib_dggbak +#else + module procedure stdlib${ii}$_dggbak #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ggbak - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sggbak( job, side, n, ilo, ihi, lscale, rscale, m, v,ldv, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(in) :: lscale(*),rscale(*) real(sp), intent(inout) :: v(ldv,*) end subroutine sggbak -#else - module procedure stdlib_sggbak +#else + module procedure stdlib${ii}$_sggbak #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ggbak - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zggbak( job, side, n, ilo, ihi, lscale, rscale, m, v,ldv, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(in) :: lscale(*),rscale(*) complex(dp), intent(inout) :: v(ldv,*) end subroutine zggbak -#else - module procedure stdlib_zggbak +#else + module procedure stdlib${ii}$_zggbak #endif - end interface ggbak +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ggbak +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ggbak +#:endif +#:endfor +#:endfor + end interface ggbak interface ggbal !! GGBAL balances a pair of general complex matrices (A,B). This @@ -4398,77 +4341,77 @@ module stdlib_linalg_lapack !! Balancing may reduce the 1-norm of the matrices, and improve the !! accuracy of the computed eigenvalues and/or eigenvectors in the !! generalized eigenvalue problem A*x = lambda*B*x. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cggbal( job, n, a, lda, b, ldb, ilo, ihi, lscale,rscale, work, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: job - integer(ilp), intent(out) :: ihi,ilo,info - integer(ilp), intent(in) :: lda,ldb,n + integer(${ik}$), intent(out) :: ihi,ilo,info + integer(${ik}$), intent(in) :: lda,ldb,n real(sp), intent(out) :: lscale(*),rscale(*),work(*) complex(sp), intent(inout) :: a(lda,*),b(ldb,*) end subroutine cggbal -#else - module procedure stdlib_cggbal +#else + module procedure stdlib${ii}$_cggbal #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dggbal( job, n, a, lda, b, ldb, ilo, ihi, lscale,rscale, work, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: job - integer(ilp), intent(out) :: ihi,ilo,info - integer(ilp), intent(in) :: lda,ldb,n + integer(${ik}$), intent(out) :: ihi,ilo,info + integer(${ik}$), intent(in) :: lda,ldb,n real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(out) :: lscale(*),rscale(*),work(*) end subroutine dggbal -#else - module procedure stdlib_dggbal +#else + module procedure stdlib${ii}$_dggbal #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ggbal - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sggbal( job, n, a, lda, b, ldb, ilo, ihi, lscale,rscale, work, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: job - integer(ilp), intent(out) :: ihi,ilo,info - integer(ilp), intent(in) :: lda,ldb,n + integer(${ik}$), intent(out) :: ihi,ilo,info + integer(${ik}$), intent(in) :: lda,ldb,n real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(out) :: lscale(*),rscale(*),work(*) end subroutine sggbal -#else - module procedure stdlib_sggbal +#else + module procedure stdlib${ii}$_sggbal #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ggbal - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zggbal( job, n, a, lda, b, ldb, ilo, ihi, lscale,rscale, work, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: job - integer(ilp), intent(out) :: ihi,ilo,info - integer(ilp), intent(in) :: lda,ldb,n + integer(${ik}$), intent(out) :: ihi,ilo,info + integer(${ik}$), intent(in) :: lda,ldb,n real(dp), intent(out) :: lscale(*),rscale(*),work(*) complex(dp), intent(inout) :: a(lda,*),b(ldb,*) end subroutine zggbal -#else - module procedure stdlib_zggbal +#else + module procedure stdlib${ii}$_zggbal #endif - end interface ggbal +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ggbal +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ggbal +#:endif +#:endfor +#:endfor + end interface ggbal interface gges !! GGES computes for a pair of N-by-N complex nonsymmetric matrices @@ -4491,91 +4434,91 @@ module stdlib_linalg_lapack !! A pair of matrices (S,T) is in generalized complex Schur form if S !! and T are upper triangular and, in addition, the diagonal elements !! of T are non-negative real numbers. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cgges( jobvsl, jobvsr, sort, selctg, n, a, lda, b, ldb,sdim, alpha, & beta, vsl, ldvsl, vsr, ldvsr, work,lwork, rwork, bwork, info ) - import sp,dp,qp,ilp,lk,stdlib_selctg_c - implicit none(type,external) + import sp,dp,qp,${ik}$,lk,stdlib_selctg_c + implicit none(type,external) character, intent(in) :: jobvsl,jobvsr,sort - integer(ilp), intent(out) :: info,sdim - integer(ilp), intent(in) :: lda,ldb,ldvsl,ldvsr,lwork,n + integer(${ik}$), intent(out) :: info,sdim + integer(${ik}$), intent(in) :: lda,ldb,ldvsl,ldvsr,lwork,n logical(lk), intent(out) :: bwork(*) real(sp), intent(out) :: rwork(*) complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: alpha(*),beta(*),vsl(ldvsl,*),vsr(ldvsr,*),work(*) - + procedure(stdlib_selctg_c) :: selctg end subroutine cgges -#else - module procedure stdlib_cgges +#else + module procedure stdlib${ii}$_cgges #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dgges( jobvsl, jobvsr, sort, selctg, n, a, lda, b, ldb,sdim, alphar, & alphai, beta, vsl, ldvsl, vsr,ldvsr, work, lwork, bwork, info ) - import sp,dp,qp,ilp,lk,stdlib_selctg_d - implicit none(type,external) + import sp,dp,qp,${ik}$,lk,stdlib_selctg_d + implicit none(type,external) character, intent(in) :: jobvsl,jobvsr,sort - integer(ilp), intent(out) :: info,sdim - integer(ilp), intent(in) :: lda,ldb,ldvsl,ldvsr,lwork,n + integer(${ik}$), intent(out) :: info,sdim + integer(${ik}$), intent(in) :: lda,ldb,ldvsl,ldvsr,lwork,n logical(lk), intent(out) :: bwork(*) real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(out) :: alphai(*),alphar(*),beta(*),vsl(ldvsl,*),vsr(ldvsr,*)& ,work(*) procedure(stdlib_selctg_d) :: selctg end subroutine dgges -#else - module procedure stdlib_dgges +#else + module procedure stdlib${ii}$_dgges #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gges - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sgges( jobvsl, jobvsr, sort, selctg, n, a, lda, b, ldb,sdim, alphar, & alphai, beta, vsl, ldvsl, vsr,ldvsr, work, lwork, bwork, info ) - import sp,dp,qp,ilp,lk,stdlib_selctg_s - implicit none(type,external) + import sp,dp,qp,${ik}$,lk,stdlib_selctg_s + implicit none(type,external) character, intent(in) :: jobvsl,jobvsr,sort - integer(ilp), intent(out) :: info,sdim - integer(ilp), intent(in) :: lda,ldb,ldvsl,ldvsr,lwork,n + integer(${ik}$), intent(out) :: info,sdim + integer(${ik}$), intent(in) :: lda,ldb,ldvsl,ldvsr,lwork,n logical(lk), intent(out) :: bwork(*) real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(out) :: alphai(*),alphar(*),beta(*),vsl(ldvsl,*),vsr(ldvsr,*)& ,work(*) procedure(stdlib_selctg_s) :: selctg end subroutine sgges -#else - module procedure stdlib_sgges +#else + module procedure stdlib${ii}$_sgges #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gges - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zgges( jobvsl, jobvsr, sort, selctg, n, a, lda, b, ldb,sdim, alpha, & beta, vsl, ldvsl, vsr, ldvsr, work,lwork, rwork, bwork, info ) - import sp,dp,qp,ilp,lk,stdlib_selctg_z - implicit none(type,external) + import sp,dp,qp,${ik}$,lk,stdlib_selctg_z + implicit none(type,external) character, intent(in) :: jobvsl,jobvsr,sort - integer(ilp), intent(out) :: info,sdim - integer(ilp), intent(in) :: lda,ldb,ldvsl,ldvsr,lwork,n + integer(${ik}$), intent(out) :: info,sdim + integer(${ik}$), intent(in) :: lda,ldb,ldvsl,ldvsr,lwork,n logical(lk), intent(out) :: bwork(*) real(dp), intent(out) :: rwork(*) complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: alpha(*),beta(*),vsl(ldvsl,*),vsr(ldvsr,*),work(*) - + procedure(stdlib_selctg_z) :: selctg end subroutine zgges -#else - module procedure stdlib_zgges +#else + module procedure stdlib${ii}$_zgges #endif - end interface gges +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gges +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gges +#:endif +#:endfor +#:endfor + end interface gges interface ggev !! GGEV computes for a pair of N-by-N complex nonsymmetric matrices @@ -4593,83 +4536,83 @@ module stdlib_linalg_lapack !! generalized eigenvalues lambda(j) of (A,B) satisfies !! u(j)**H * A = lambda(j) * u(j)**H * B !! where u(j)**H is the conjugate-transpose of u(j). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cggev( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, & work, lwork, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobvl,jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,ldvl,ldvr,lwork,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,ldvl,ldvr,lwork,n real(sp), intent(out) :: rwork(*) complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: alpha(*),beta(*),vl(ldvl,*),vr(ldvr,*),work(*) - + end subroutine cggev -#else - module procedure stdlib_cggev +#else + module procedure stdlib${ii}$_cggev #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dggev( jobvl, jobvr, n, a, lda, b, ldb, alphar, alphai,beta, vl, ldvl, & vr, ldvr, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobvl,jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,ldvl,ldvr,lwork,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,ldvl,ldvr,lwork,n real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(out) :: alphai(*),alphar(*),beta(*),vl(ldvl,*),vr(ldvr,*),& work(*) end subroutine dggev -#else - module procedure stdlib_dggev +#else + module procedure stdlib${ii}$_dggev #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ggev - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sggev( jobvl, jobvr, n, a, lda, b, ldb, alphar, alphai,beta, vl, ldvl, & vr, ldvr, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobvl,jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,ldvl,ldvr,lwork,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,ldvl,ldvr,lwork,n real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(out) :: alphai(*),alphar(*),beta(*),vl(ldvl,*),vr(ldvr,*),& work(*) end subroutine sggev -#else - module procedure stdlib_sggev +#else + module procedure stdlib${ii}$_sggev #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ggev - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zggev( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, & work, lwork, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobvl,jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,ldvl,ldvr,lwork,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,ldvl,ldvr,lwork,n real(dp), intent(out) :: rwork(*) complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: alpha(*),beta(*),vl(ldvl,*),vr(ldvr,*),work(*) - + end subroutine zggev -#else - module procedure stdlib_zggev +#else + module procedure stdlib${ii}$_zggev #endif - end interface ggev +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ggev +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ggev +#:endif +#:endfor +#:endfor + end interface ggev interface ggglm !! GGGLM solves a general Gauss-Markov linear model (GLM) problem: @@ -4690,73 +4633,73 @@ module stdlib_linalg_lapack !! minimize || inv(B)*(d-A*x) ||_2 !! x !! where inv(B) denotes the inverse of B. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cggglm( n, m, p, a, lda, b, ldb, d, x, y, work, lwork,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,p + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,p complex(sp), intent(inout) :: a(lda,*),b(ldb,*),d(*) complex(sp), intent(out) :: work(*),x(*),y(*) end subroutine cggglm -#else - module procedure stdlib_cggglm +#else + module procedure stdlib${ii}$_cggglm #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dggglm( n, m, p, a, lda, b, ldb, d, x, y, work, lwork,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,p + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,p real(dp), intent(inout) :: a(lda,*),b(ldb,*),d(*) real(dp), intent(out) :: work(*),x(*),y(*) end subroutine dggglm -#else - module procedure stdlib_dggglm +#else + module procedure stdlib${ii}$_dggglm #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ggglm - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sggglm( n, m, p, a, lda, b, ldb, d, x, y, work, lwork,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,p + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,p real(sp), intent(inout) :: a(lda,*),b(ldb,*),d(*) real(sp), intent(out) :: work(*),x(*),y(*) end subroutine sggglm -#else - module procedure stdlib_sggglm +#else + module procedure stdlib${ii}$_sggglm #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ggglm - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zggglm( n, m, p, a, lda, b, ldb, d, x, y, work, lwork,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,p + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,p complex(dp), intent(inout) :: a(lda,*),b(ldb,*),d(*) complex(dp), intent(out) :: work(*),x(*),y(*) end subroutine zggglm -#else - module procedure stdlib_zggglm +#else + module procedure stdlib${ii}$_zggglm #endif - end interface ggglm +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ggglm +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ggglm +#:endif +#:endfor +#:endfor + end interface ggglm interface gghrd !! GGHRD reduces a pair of complex matrices (A,B) to generalized upper @@ -4782,73 +4725,73 @@ module stdlib_linalg_lapack !! If Q1 is the unitary matrix from the QR factorization of B in the !! original equation A*x = lambda*B*x, then GGHRD reduces the original !! problem to generalized Hessenberg form. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgghrd( compq, compz, n, ilo, ihi, a, lda, b, ldb, q,ldq, z, ldz, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compq,compz - integer(ilp), intent(in) :: ihi,ilo,lda,ldb,ldq,ldz,n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi,ilo,lda,ldb,ldq,ldz,n + integer(${ik}$), intent(out) :: info complex(sp), intent(inout) :: a(lda,*),b(ldb,*),q(ldq,*),z(ldz,*) end subroutine cgghrd -#else - module procedure stdlib_cgghrd +#else + module procedure stdlib${ii}$_cgghrd #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgghrd( compq, compz, n, ilo, ihi, a, lda, b, ldb, q,ldq, z, ldz, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compq,compz - integer(ilp), intent(in) :: ihi,ilo,lda,ldb,ldq,ldz,n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi,ilo,lda,ldb,ldq,ldz,n + integer(${ik}$), intent(out) :: info real(dp), intent(inout) :: a(lda,*),b(ldb,*),q(ldq,*),z(ldz,*) end subroutine dgghrd -#else - module procedure stdlib_dgghrd +#else + module procedure stdlib${ii}$_dgghrd #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gghrd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgghrd( compq, compz, n, ilo, ihi, a, lda, b, ldb, q,ldq, z, ldz, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compq,compz - integer(ilp), intent(in) :: ihi,ilo,lda,ldb,ldq,ldz,n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi,ilo,lda,ldb,ldq,ldz,n + integer(${ik}$), intent(out) :: info real(sp), intent(inout) :: a(lda,*),b(ldb,*),q(ldq,*),z(ldz,*) end subroutine sgghrd -#else - module procedure stdlib_sgghrd +#else + module procedure stdlib${ii}$_sgghrd #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gghrd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgghrd( compq, compz, n, ilo, ihi, a, lda, b, ldb, q,ldq, z, ldz, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compq,compz - integer(ilp), intent(in) :: ihi,ilo,lda,ldb,ldq,ldz,n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi,ilo,lda,ldb,ldq,ldz,n + integer(${ik}$), intent(out) :: info complex(dp), intent(inout) :: a(lda,*),b(ldb,*),q(ldq,*),z(ldz,*) end subroutine zgghrd -#else - module procedure stdlib_zgghrd +#else + module procedure stdlib${ii}$_zgghrd #endif - end interface gghrd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gghrd +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gghrd +#:endif +#:endfor +#:endfor + end interface gghrd interface gglse !! GGLSE solves the linear equality-constrained least squares (LSE) @@ -4863,73 +4806,73 @@ module stdlib_linalg_lapack !! which is obtained using a generalized RQ factorization of the !! matrices (B, A) given by !! B = (0 R)*Q, A = Z*T*Q. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgglse( m, n, p, a, lda, b, ldb, c, d, x, work, lwork,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,p + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,p complex(sp), intent(inout) :: a(lda,*),b(ldb,*),c(*),d(*) complex(sp), intent(out) :: work(*),x(*) end subroutine cgglse -#else - module procedure stdlib_cgglse +#else + module procedure stdlib${ii}$_cgglse #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgglse( m, n, p, a, lda, b, ldb, c, d, x, work, lwork,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,p + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,p real(dp), intent(inout) :: a(lda,*),b(ldb,*),c(*),d(*) real(dp), intent(out) :: work(*),x(*) end subroutine dgglse -#else - module procedure stdlib_dgglse +#else + module procedure stdlib${ii}$_dgglse #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gglse - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgglse( m, n, p, a, lda, b, ldb, c, d, x, work, lwork,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,p + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,p real(sp), intent(inout) :: a(lda,*),b(ldb,*),c(*),d(*) real(sp), intent(out) :: work(*),x(*) end subroutine sgglse -#else - module procedure stdlib_sgglse +#else + module procedure stdlib${ii}$_sgglse #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gglse - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgglse( m, n, p, a, lda, b, ldb, c, d, x, work, lwork,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,p + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,p complex(dp), intent(inout) :: a(lda,*),b(ldb,*),c(*),d(*) complex(dp), intent(out) :: work(*),x(*) end subroutine zgglse -#else - module procedure stdlib_zgglse +#else + module procedure stdlib${ii}$_zgglse #endif - end interface gglse +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gglse +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gglse +#:endif +#:endfor +#:endfor + end interface gglse interface ggqrf !! GGQRF computes a generalized QR factorization of an N-by-M matrix A @@ -4950,73 +4893,73 @@ module stdlib_linalg_lapack !! inv(B)*A = Z**H * (inv(T)*R) !! where inv(B) denotes the inverse of the matrix B, and Z' denotes the !! conjugate transpose of matrix Z. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cggqrf( n, m, p, a, lda, taua, b, ldb, taub, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,p + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,p complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: taua(*),taub(*),work(*) end subroutine cggqrf -#else - module procedure stdlib_cggqrf +#else + module procedure stdlib${ii}$_cggqrf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dggqrf( n, m, p, a, lda, taua, b, ldb, taub, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,p + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,p real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(out) :: taua(*),taub(*),work(*) end subroutine dggqrf -#else - module procedure stdlib_dggqrf +#else + module procedure stdlib${ii}$_dggqrf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ggqrf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sggqrf( n, m, p, a, lda, taua, b, ldb, taub, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,p + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,p real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(out) :: taua(*),taub(*),work(*) end subroutine sggqrf -#else - module procedure stdlib_sggqrf +#else + module procedure stdlib${ii}$_sggqrf #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ggqrf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zggqrf( n, m, p, a, lda, taua, b, ldb, taub, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,p + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,p complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: taua(*),taub(*),work(*) end subroutine zggqrf -#else - module procedure stdlib_zggqrf +#else + module procedure stdlib${ii}$_zggqrf #endif - end interface ggqrf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ggqrf +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ggqrf +#:endif +#:endfor +#:endfor + end interface ggqrf interface ggrqf !! GGRQF computes a generalized RQ factorization of an M-by-N matrix A @@ -5037,156 +4980,156 @@ module stdlib_linalg_lapack !! A*inv(B) = (R*inv(T))*Z**H !! where inv(B) denotes the inverse of the matrix B, and Z**H denotes the !! conjugate transpose of the matrix Z. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cggrqf( m, p, n, a, lda, taua, b, ldb, taub, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,p + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,p complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: taua(*),taub(*),work(*) end subroutine cggrqf -#else - module procedure stdlib_cggrqf +#else + module procedure stdlib${ii}$_cggrqf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dggrqf( m, p, n, a, lda, taua, b, ldb, taub, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,p + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,p real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(out) :: taua(*),taub(*),work(*) end subroutine dggrqf -#else - module procedure stdlib_dggrqf +#else + module procedure stdlib${ii}$_dggrqf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ggrqf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sggrqf( m, p, n, a, lda, taua, b, ldb, taub, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,p + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,p real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(out) :: taua(*),taub(*),work(*) end subroutine sggrqf -#else - module procedure stdlib_sggrqf +#else + module procedure stdlib${ii}$_sggrqf #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ggrqf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zggrqf( m, p, n, a, lda, taua, b, ldb, taub, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,lwork,m,n,p + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,lwork,m,n,p complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: taua(*),taub(*),work(*) end subroutine zggrqf -#else - module procedure stdlib_zggrqf +#else + module procedure stdlib${ii}$_zggrqf #endif - end interface ggrqf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ggrqf +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ggrqf +#:endif +#:endfor +#:endfor + end interface ggrqf interface gsvj0 !! GSVJ0 is called from CGESVJ as a pre-processor and that is its main !! purpose. It applies Jacobi rotations in the same way as CGESVJ does, but !! it does not check convergence (stopping criterion). Few tuning !! parameters (marked by [TP]) are available for the implementer. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgsvj0( jobv, m, n, a, lda, d, sva, mv, v, ldv, eps,sfmin, tol, & nsweep, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldv,lwork,m,mv,n,nsweep + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldv,lwork,m,mv,n,nsweep real(sp), intent(in) :: eps,sfmin,tol character, intent(in) :: jobv complex(sp), intent(inout) :: a(lda,*),d(n),v(ldv,*) complex(sp), intent(out) :: work(lwork) real(sp), intent(inout) :: sva(n) end subroutine cgsvj0 -#else - module procedure stdlib_cgsvj0 +#else + module procedure stdlib${ii}$_cgsvj0 #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgsvj0( jobv, m, n, a, lda, d, sva, mv, v, ldv, eps,sfmin, tol, & nsweep, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldv,lwork,m,mv,n,nsweep + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldv,lwork,m,mv,n,nsweep real(dp), intent(in) :: eps,sfmin,tol character, intent(in) :: jobv real(dp), intent(inout) :: a(lda,*),sva(n),d(n),v(ldv,*) real(dp), intent(out) :: work(lwork) end subroutine dgsvj0 -#else - module procedure stdlib_dgsvj0 +#else + module procedure stdlib${ii}$_dgsvj0 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gsvj0 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgsvj0( jobv, m, n, a, lda, d, sva, mv, v, ldv, eps,sfmin, tol, & nsweep, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldv,lwork,m,mv,n,nsweep + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldv,lwork,m,mv,n,nsweep real(sp), intent(in) :: eps,sfmin,tol character, intent(in) :: jobv real(sp), intent(inout) :: a(lda,*),sva(n),d(n),v(ldv,*) real(sp), intent(out) :: work(lwork) end subroutine sgsvj0 -#else - module procedure stdlib_sgsvj0 +#else + module procedure stdlib${ii}$_sgsvj0 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gsvj0 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgsvj0( jobv, m, n, a, lda, d, sva, mv, v, ldv, eps,sfmin, tol, & nsweep, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldv,lwork,m,mv,n,nsweep + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldv,lwork,m,mv,n,nsweep real(dp), intent(in) :: eps,sfmin,tol character, intent(in) :: jobv complex(dp), intent(inout) :: a(lda,*),d(n),v(ldv,*) complex(dp), intent(out) :: work(lwork) real(dp), intent(inout) :: sva(n) end subroutine zgsvj0 -#else - module procedure stdlib_zgsvj0 +#else + module procedure stdlib${ii}$_zgsvj0 #endif - end interface gsvj0 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gsvj0 +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gsvj0 +#:endif +#:endfor +#:endfor + end interface gsvj0 interface gsvj1 !! GSVJ1 is called from CGESVJ as a pre-processor and that is its main @@ -5213,83 +5156,83 @@ module stdlib_linalg_lapack !! tiled using quadratic tiles of side KBL. Here, KBL is a tuning parameter. !! The number of sweeps is given in NSWEEP and the orthogonality threshold !! is given in TOL. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgsvj1( jobv, m, n, n1, a, lda, d, sva, mv, v, ldv,eps, sfmin, tol,& nsweep, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: eps,sfmin,tol - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldv,lwork,m,mv,n,n1,nsweep + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldv,lwork,m,mv,n,n1,nsweep character, intent(in) :: jobv complex(sp), intent(inout) :: a(lda,*),d(n),v(ldv,*) complex(sp), intent(out) :: work(lwork) real(sp), intent(inout) :: sva(n) end subroutine cgsvj1 -#else - module procedure stdlib_cgsvj1 +#else + module procedure stdlib${ii}$_cgsvj1 #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgsvj1( jobv, m, n, n1, a, lda, d, sva, mv, v, ldv,eps, sfmin, tol,& nsweep, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: eps,sfmin,tol - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldv,lwork,m,mv,n,n1,nsweep + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldv,lwork,m,mv,n,n1,nsweep character, intent(in) :: jobv real(dp), intent(inout) :: a(lda,*),d(n),sva(n),v(ldv,*) real(dp), intent(out) :: work(lwork) end subroutine dgsvj1 -#else - module procedure stdlib_dgsvj1 +#else + module procedure stdlib${ii}$_dgsvj1 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gsvj1 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgsvj1( jobv, m, n, n1, a, lda, d, sva, mv, v, ldv,eps, sfmin, tol,& nsweep, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: eps,sfmin,tol - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldv,lwork,m,mv,n,n1,nsweep + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldv,lwork,m,mv,n,n1,nsweep character, intent(in) :: jobv real(sp), intent(inout) :: a(lda,*),d(n),sva(n),v(ldv,*) real(sp), intent(out) :: work(lwork) end subroutine sgsvj1 -#else - module procedure stdlib_sgsvj1 +#else + module procedure stdlib${ii}$_sgsvj1 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gsvj1 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgsvj1( jobv, m, n, n1, a, lda, d, sva, mv, v, ldv,eps, sfmin, tol,& nsweep, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: eps,sfmin,tol - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldv,lwork,m,mv,n,n1,nsweep + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldv,lwork,m,mv,n,n1,nsweep character, intent(in) :: jobv complex(dp), intent(inout) :: a(lda,*),d(n),v(ldv,*) complex(dp), intent(out) :: work(lwork) real(dp), intent(inout) :: sva(n) end subroutine zgsvj1 -#else - module procedure stdlib_zgsvj1 +#else + module procedure stdlib${ii}$_zgsvj1 #endif - end interface gsvj1 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gsvj1 +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gsvj1 +#:endif +#:endfor +#:endfor + end interface gsvj1 interface gtcon !! GTCON estimates the reciprocal of the condition number of a complex @@ -5297,167 +5240,167 @@ module stdlib_linalg_lapack !! CGTTRF. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond,work, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n,ipiv(*) real(sp), intent(in) :: anorm real(sp), intent(out) :: rcond complex(sp), intent(in) :: d(*),dl(*),du(*),du2(*) complex(sp), intent(out) :: work(*) end subroutine cgtcon -#else - module procedure stdlib_cgtcon +#else + module procedure stdlib${ii}$_cgtcon #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond,work, iwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: n,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: n,ipiv(*) real(dp), intent(in) :: anorm,d(*),dl(*),du(*),du2(*) real(dp), intent(out) :: rcond,work(*) end subroutine dgtcon -#else - module procedure stdlib_dgtcon +#else + module procedure stdlib${ii}$_dgtcon #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gtcon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond,work, iwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: n,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: n,ipiv(*) real(sp), intent(in) :: anorm,d(*),dl(*),du(*),du2(*) real(sp), intent(out) :: rcond,work(*) end subroutine sgtcon -#else - module procedure stdlib_sgtcon +#else + module procedure stdlib${ii}$_sgtcon #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gtcon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond,work, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n,ipiv(*) real(dp), intent(in) :: anorm real(dp), intent(out) :: rcond complex(dp), intent(in) :: d(*),dl(*),du(*),du2(*) complex(dp), intent(out) :: work(*) end subroutine zgtcon -#else - module procedure stdlib_zgtcon +#else + module procedure stdlib${ii}$_zgtcon #endif - end interface gtcon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gtcon +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gtcon +#:endif +#:endfor +#:endfor + end interface gtcon interface gtrfs !! GTRFS improves the computed solution to a system of linear !! equations when the coefficient matrix is tridiagonal, and provides !! error bounds and backward error estimates for the solution. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2,ipiv, b, ldb, & x, ldx, ferr, berr, work, rwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,ldx,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,ldx,n,nrhs,ipiv(*) real(sp), intent(out) :: berr(*),ferr(*),rwork(*) complex(sp), intent(in) :: b(ldb,*),d(*),df(*),dl(*),dlf(*),du(*),du2(*),duf(& *) complex(sp), intent(out) :: work(*) complex(sp), intent(inout) :: x(ldx,*) end subroutine cgtrfs -#else - module procedure stdlib_cgtrfs +#else + module procedure stdlib${ii}$_cgtrfs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2,ipiv, b, ldb, & x, ldx, ferr, berr, work, iwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldb,ldx,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldb,ldx,n,nrhs,ipiv(*) real(dp), intent(in) :: b(ldb,*),d(*),df(*),dl(*),dlf(*),du(*),du2(*),duf(*) - + real(dp), intent(out) :: berr(*),ferr(*),work(*) real(dp), intent(inout) :: x(ldx,*) end subroutine dgtrfs -#else - module procedure stdlib_dgtrfs +#else + module procedure stdlib${ii}$_dgtrfs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gtrfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2,ipiv, b, ldb, & x, ldx, ferr, berr, work, iwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldb,ldx,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldb,ldx,n,nrhs,ipiv(*) real(sp), intent(in) :: b(ldb,*),d(*),df(*),dl(*),dlf(*),du(*),du2(*),duf(*) - + real(sp), intent(out) :: berr(*),ferr(*),work(*) real(sp), intent(inout) :: x(ldx,*) end subroutine sgtrfs -#else - module procedure stdlib_sgtrfs +#else + module procedure stdlib${ii}$_sgtrfs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gtrfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2,ipiv, b, ldb, & x, ldx, ferr, berr, work, rwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,ldx,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,ldx,n,nrhs,ipiv(*) real(dp), intent(out) :: berr(*),ferr(*),rwork(*) complex(dp), intent(in) :: b(ldb,*),d(*),df(*),dl(*),dlf(*),du(*),du2(*),duf(& *) complex(dp), intent(out) :: work(*) complex(dp), intent(inout) :: x(ldx,*) end subroutine zgtrfs -#else - module procedure stdlib_zgtrfs +#else + module procedure stdlib${ii}$_zgtrfs #endif - end interface gtrfs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gtrfs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gtrfs +#:endif +#:endfor +#:endfor + end interface gtrfs interface gtsv !! GTSV solves the equation @@ -5466,66 +5409,66 @@ module stdlib_linalg_lapack !! partial pivoting. !! Note that the equation A**T *X = B may be solved by interchanging the !! order of the arguments DU and DL. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgtsv( n, nrhs, dl, d, du, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs complex(sp), intent(inout) :: b(ldb,*),d(*),dl(*),du(*) end subroutine cgtsv -#else - module procedure stdlib_cgtsv +#else + module procedure stdlib${ii}$_cgtsv #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgtsv( n, nrhs, dl, d, du, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs real(dp), intent(inout) :: b(ldb,*),d(*),dl(*),du(*) end subroutine dgtsv -#else - module procedure stdlib_dgtsv +#else + module procedure stdlib${ii}$_dgtsv +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine sgtsv( n, nrhs, dl, d, du, b, ldb, info ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs + real(sp), intent(inout) :: b(ldb,*),d(*),dl(*),du(*) + end subroutine sgtsv +#else + module procedure stdlib${ii}$_sgtsv +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine zgtsv( n, nrhs, dl, d, du, b, ldb, info ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs + complex(dp), intent(inout) :: b(ldb,*),d(*),dl(*),du(*) + end subroutine zgtsv +#else + module procedure stdlib${ii}$_zgtsv #endif #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gtsv + module procedure stdlib${ii}$_${ri}$gtsv #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine sgtsv( n, nrhs, dl, d, du, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs - real(sp), intent(inout) :: b(ldb,*),d(*),dl(*),du(*) - end subroutine sgtsv -#else - module procedure stdlib_sgtsv -#endif #:for rk,rt,ri in CMPLX_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gtsv + module procedure stdlib${ii}$_${ri}$gtsv #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine zgtsv( n, nrhs, dl, d, du, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs - complex(dp), intent(inout) :: b(ldb,*),d(*),dl(*),du(*) - end subroutine zgtsv -#else - module procedure stdlib_zgtsv -#endif +#:endfor end interface gtsv - - interface gttrf !! GTTRF computes an LU factorization of a complex tridiagonal matrix A !! using elimination with partial pivoting and row interchanges. @@ -5534,226 +5477,226 @@ module stdlib_linalg_lapack !! where L is a product of permutation and unit lower bidiagonal !! matrices and U is upper triangular with nonzeros in only the main !! diagonal and first two superdiagonals. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgttrf( n, dl, d, du, du2, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: n complex(sp), intent(inout) :: d(*),dl(*),du(*) complex(sp), intent(out) :: du2(*) end subroutine cgttrf -#else - module procedure stdlib_cgttrf +#else + module procedure stdlib${ii}$_cgttrf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgttrf( n, dl, d, du, du2, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: n real(dp), intent(inout) :: d(*),dl(*),du(*) real(dp), intent(out) :: du2(*) end subroutine dgttrf -#else - module procedure stdlib_dgttrf +#else + module procedure stdlib${ii}$_dgttrf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gttrf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgttrf( n, dl, d, du, du2, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: n real(sp), intent(inout) :: d(*),dl(*),du(*) real(sp), intent(out) :: du2(*) end subroutine sgttrf -#else - module procedure stdlib_sgttrf +#else + module procedure stdlib${ii}$_sgttrf #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gttrf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgttrf( n, dl, d, du, du2, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: n complex(dp), intent(inout) :: d(*),dl(*),du(*) complex(dp), intent(out) :: du2(*) end subroutine zgttrf -#else - module procedure stdlib_zgttrf +#else + module procedure stdlib${ii}$_zgttrf #endif - end interface gttrf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gttrf +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gttrf +#:endif +#:endfor +#:endfor + end interface gttrf interface gttrs !! GTTRS solves one of the systems of equations !! A * X = B, A**T * X = B, or A**H * X = B, !! with a tridiagonal matrix A using the LU factorization computed !! by CGTTRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cgttrs( trans, n, nrhs, dl, d, du, du2, ipiv, b, ldb,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs,ipiv(*) complex(sp), intent(inout) :: b(ldb,*) complex(sp), intent(in) :: d(*),dl(*),du(*),du2(*) end subroutine cgttrs -#else - module procedure stdlib_cgttrs +#else + module procedure stdlib${ii}$_cgttrs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dgttrs( trans, n, nrhs, dl, d, du, du2, ipiv, b, ldb,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs,ipiv(*) real(dp), intent(inout) :: b(ldb,*) real(dp), intent(in) :: d(*),dl(*),du(*),du2(*) end subroutine dgttrs -#else - module procedure stdlib_dgttrs +#else + module procedure stdlib${ii}$_dgttrs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gttrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sgttrs( trans, n, nrhs, dl, d, du, du2, ipiv, b, ldb,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs,ipiv(*) real(sp), intent(inout) :: b(ldb,*) real(sp), intent(in) :: d(*),dl(*),du(*),du2(*) end subroutine sgttrs -#else - module procedure stdlib_sgttrs +#else + module procedure stdlib${ii}$_sgttrs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$gttrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zgttrs( trans, n, nrhs, dl, d, du, du2, ipiv, b, ldb,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs,ipiv(*) complex(dp), intent(inout) :: b(ldb,*) complex(dp), intent(in) :: d(*),dl(*),du(*),du2(*) end subroutine zgttrs -#else - module procedure stdlib_zgttrs +#else + module procedure stdlib${ii}$_zgttrs #endif - end interface gttrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gttrs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$gttrs +#:endif +#:endfor +#:endfor + end interface gttrs interface hb2st_kernels !! HB2ST_KERNELS is an internal routine used by the CHETRD_HB2ST !! subroutine. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chb2st_kernels( uplo, wantz, ttype,st, ed, sweep, n, nb, ib,a, & lda, v, tau, ldvt, work) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo logical(lk), intent(in) :: wantz - integer(ilp), intent(in) :: ttype,st,ed,sweep,n,nb,ib,lda,ldvt + integer(${ik}$), intent(in) :: ttype,st,ed,sweep,n,nb,ib,lda,ldvt complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: v(*),tau(*),work(*) end subroutine chb2st_kernels -#else - module procedure stdlib_chb2st_kernels +#else + module procedure stdlib${ii}$_chb2st_kernels #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hb2st_kernels - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhb2st_kernels( uplo, wantz, ttype,st, ed, sweep, n, nb, ib,a, & lda, v, tau, ldvt, work) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo logical(lk), intent(in) :: wantz - integer(ilp), intent(in) :: ttype,st,ed,sweep,n,nb,ib,lda,ldvt + integer(${ik}$), intent(in) :: ttype,st,ed,sweep,n,nb,ib,lda,ldvt complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: v(*),tau(*),work(*) end subroutine zhb2st_kernels -#else - module procedure stdlib_zhb2st_kernels +#else + module procedure stdlib${ii}$_zhb2st_kernels #endif - end interface hb2st_kernels - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hb2st_kernels +#:endif +#:endfor +#:endfor + end interface hb2st_kernels interface hbev !! HBEV computes all the eigenvalues and, optionally, eigenvectors of !! a complex Hermitian band matrix A. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine chbev( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,rwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kd,ldab,ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kd,ldab,ldz,n real(sp), intent(out) :: rwork(*),w(*) complex(sp), intent(inout) :: ab(ldab,*) complex(sp), intent(out) :: work(*),z(ldz,*) end subroutine chbev -#else - module procedure stdlib_chbev +#else + module procedure stdlib${ii}$_chbev #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hbev - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zhbev( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,rwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kd,ldab,ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kd,ldab,ldz,n real(dp), intent(out) :: rwork(*),w(*) complex(dp), intent(inout) :: ab(ldab,*) complex(dp), intent(out) :: work(*),z(ldz,*) end subroutine zhbev -#else - module procedure stdlib_zhbev +#else + module procedure stdlib${ii}$_zhbev #endif - end interface hbev - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hbev +#:endif +#:endfor +#:endfor + end interface hbev interface hbevd !! HBEVD computes all the eigenvalues and, optionally, eigenvectors of @@ -5765,45 +5708,45 @@ module stdlib_linalg_lapack !! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or !! Cray-2. It could conceivably fail on hexadecimal or decimal machines !! without guard digits, but we know of none. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine chbevd( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,lwork, rwork, & lrwork, iwork, liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: kd,ldab,ldz,liwork,lrwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: kd,ldab,ldz,liwork,lrwork,lwork,n real(sp), intent(out) :: rwork(*),w(*) complex(sp), intent(inout) :: ab(ldab,*) complex(sp), intent(out) :: work(*),z(ldz,*) end subroutine chbevd -#else - module procedure stdlib_chbevd +#else + module procedure stdlib${ii}$_chbevd #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hbevd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zhbevd( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,lwork, rwork, & lrwork, iwork, liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: kd,ldab,ldz,liwork,lrwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: kd,ldab,ldz,liwork,lrwork,lwork,n real(dp), intent(out) :: rwork(*),w(*) complex(dp), intent(inout) :: ab(ldab,*) complex(dp), intent(out) :: work(*),z(ldz,*) end subroutine zhbevd -#else - module procedure stdlib_zhbevd +#else + module procedure stdlib${ii}$_zhbevd #endif - end interface hbevd - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hbevd +#:endif +#:endfor +#:endfor + end interface hbevd interface hbgst !! HBGST reduces a complex Hermitian-definite banded generalized @@ -5813,92 +5756,92 @@ module stdlib_linalg_lapack !! split Cholesky factorization. A is overwritten by C = X**H*A*X, where !! X = S**(-1)*Q and Q is a unitary matrix chosen to preserve the !! bandwidth of A. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chbgst( vect, uplo, n, ka, kb, ab, ldab, bb, ldbb, x,ldx, work, & rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo,vect - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ka,kb,ldab,ldbb,ldx,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ka,kb,ldab,ldbb,ldx,n real(sp), intent(out) :: rwork(*) complex(sp), intent(inout) :: ab(ldab,*) complex(sp), intent(in) :: bb(ldbb,*) complex(sp), intent(out) :: work(*),x(ldx,*) end subroutine chbgst -#else - module procedure stdlib_chbgst +#else + module procedure stdlib${ii}$_chbgst #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hbgst - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhbgst( vect, uplo, n, ka, kb, ab, ldab, bb, ldbb, x,ldx, work, & rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo,vect - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ka,kb,ldab,ldbb,ldx,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ka,kb,ldab,ldbb,ldx,n real(dp), intent(out) :: rwork(*) complex(dp), intent(inout) :: ab(ldab,*) complex(dp), intent(in) :: bb(ldbb,*) complex(dp), intent(out) :: work(*),x(ldx,*) end subroutine zhbgst -#else - module procedure stdlib_zhbgst +#else + module procedure stdlib${ii}$_zhbgst #endif - end interface hbgst - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hbgst +#:endif +#:endfor +#:endfor + end interface hbgst interface hbgv !! HBGV computes all the eigenvalues, and optionally, the eigenvectors !! of a complex generalized Hermitian-definite banded eigenproblem, of !! the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian !! and banded, and B is also positive definite. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chbgv( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z,ldz, work, & rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ka,kb,ldab,ldbb,ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ka,kb,ldab,ldbb,ldz,n real(sp), intent(out) :: rwork(*),w(*) complex(sp), intent(inout) :: ab(ldab,*),bb(ldbb,*) complex(sp), intent(out) :: work(*),z(ldz,*) end subroutine chbgv -#else - module procedure stdlib_chbgv +#else + module procedure stdlib${ii}$_chbgv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hbgv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhbgv( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z,ldz, work, & rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ka,kb,ldab,ldbb,ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ka,kb,ldab,ldbb,ldz,n real(dp), intent(out) :: rwork(*),w(*) complex(dp), intent(inout) :: ab(ldab,*),bb(ldbb,*) complex(dp), intent(out) :: work(*),z(ldz,*) end subroutine zhbgv -#else - module procedure stdlib_zhbgv +#else + module procedure stdlib${ii}$_zhbgv #endif - end interface hbgv - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hbgv +#:endif +#:endfor +#:endfor + end interface hbgv interface hbgvd !! HBGVD computes all the eigenvalues, and optionally, the eigenvectors @@ -5912,89 +5855,89 @@ module stdlib_linalg_lapack !! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or !! Cray-2. It could conceivably fail on hexadecimal or decimal machines !! without guard digits, but we know of none. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chbgvd( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w,z, ldz, work, & lwork, rwork, lrwork, iwork,liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ka,kb,ldab,ldbb,ldz,liwork,lrwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ka,kb,ldab,ldbb,ldz,liwork,lrwork,lwork,n real(sp), intent(out) :: rwork(*),w(*) complex(sp), intent(inout) :: ab(ldab,*),bb(ldbb,*) complex(sp), intent(out) :: work(*),z(ldz,*) end subroutine chbgvd -#else - module procedure stdlib_chbgvd +#else + module procedure stdlib${ii}$_chbgvd #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hbgvd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhbgvd( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w,z, ldz, work, & lwork, rwork, lrwork, iwork,liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ka,kb,ldab,ldbb,ldz,liwork,lrwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ka,kb,ldab,ldbb,ldz,liwork,lrwork,lwork,n real(dp), intent(out) :: rwork(*),w(*) complex(dp), intent(inout) :: ab(ldab,*),bb(ldbb,*) complex(dp), intent(out) :: work(*),z(ldz,*) end subroutine zhbgvd -#else - module procedure stdlib_zhbgvd +#else + module procedure stdlib${ii}$_zhbgvd #endif - end interface hbgvd - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hbgvd +#:endif +#:endfor +#:endfor + end interface hbgvd interface hbtrd !! HBTRD reduces a complex Hermitian band matrix A to real symmetric !! tridiagonal form T by a unitary similarity transformation: !! Q**H * A * Q = T. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chbtrd( vect, uplo, n, kd, ab, ldab, d, e, q, ldq,work, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(out) :: d(*),e(*) complex(sp), intent(inout) :: ab(ldab,*),q(ldq,*) complex(sp), intent(out) :: work(*) end subroutine chbtrd -#else - module procedure stdlib_chbtrd +#else + module procedure stdlib${ii}$_chbtrd #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hbtrd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhbtrd( vect, uplo, n, kd, ab, ldab, d, e, q, ldq,work, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(out) :: d(*),e(*) complex(dp), intent(inout) :: ab(ldab,*),q(ldq,*) complex(dp), intent(out) :: work(*) end subroutine zhbtrd -#else - module procedure stdlib_zhbtrd +#else + module procedure stdlib${ii}$_zhbtrd #endif - end interface hbtrd - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hbtrd +#:endif +#:endfor +#:endfor + end interface hbtrd interface hecon !! HECON estimates the reciprocal of the condition number of a complex @@ -6002,45 +5945,45 @@ module stdlib_linalg_lapack !! A = L*D*L**H computed by CHETRF. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine checon( uplo, n, a, lda, ipiv, anorm, rcond, work,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) real(sp), intent(in) :: anorm real(sp), intent(out) :: rcond complex(sp), intent(in) :: a(lda,*) complex(sp), intent(out) :: work(*) end subroutine checon -#else - module procedure stdlib_checon +#else + module procedure stdlib${ii}$_checon #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hecon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhecon( uplo, n, a, lda, ipiv, anorm, rcond, work,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) real(dp), intent(in) :: anorm real(dp), intent(out) :: rcond complex(dp), intent(in) :: a(lda,*) complex(dp), intent(out) :: work(*) end subroutine zhecon -#else - module procedure stdlib_zhecon +#else + module procedure stdlib${ii}$_zhecon #endif - end interface hecon - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hecon +#:endif +#:endfor +#:endfor + end interface hecon interface hecon_rook !! HECON_ROOK estimates the reciprocal of the condition number of a complex @@ -6048,47 +5991,47 @@ module stdlib_linalg_lapack !! A = L*D*L**H computed by CHETRF_ROOK. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine checon_rook( uplo, n, a, lda, ipiv, anorm, rcond, work,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) real(sp), intent(in) :: anorm real(sp), intent(out) :: rcond complex(sp), intent(in) :: a(lda,*) complex(sp), intent(out) :: work(*) end subroutine checon_rook -#else - module procedure stdlib_checon_rook +#else + module procedure stdlib${ii}$_checon_rook #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hecon_rook - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhecon_rook( uplo, n, a, lda, ipiv, anorm, rcond, work,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) real(dp), intent(in) :: anorm real(dp), intent(out) :: rcond complex(dp), intent(in) :: a(lda,*) complex(dp), intent(out) :: work(*) end subroutine zhecon_rook -#else - module procedure stdlib_zhecon_rook +#else + module procedure stdlib${ii}$_zhecon_rook #endif - end interface hecon_rook - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hecon_rook +#:endif +#:endfor +#:endfor + end interface hecon_rook interface heequb !! HEEQUB computes row and column scalings intended to equilibrate a @@ -6098,84 +6041,84 @@ module stdlib_linalg_lapack !! B(i,j) = S(i)*A(i,j)*S(j) has a condition number within a factor N of !! the smallest possible condition number over all possible diagonal !! scalings. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cheequb( uplo, n, a, lda, s, scond, amax, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n real(sp), intent(out) :: amax,scond,s(*) character, intent(in) :: uplo complex(sp), intent(in) :: a(lda,*) complex(sp), intent(out) :: work(*) end subroutine cheequb -#else - module procedure stdlib_cheequb +#else + module procedure stdlib${ii}$_cheequb #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$heequb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zheequb( uplo, n, a, lda, s, scond, amax, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n real(dp), intent(out) :: amax,scond,s(*) character, intent(in) :: uplo complex(dp), intent(in) :: a(lda,*) complex(dp), intent(out) :: work(*) end subroutine zheequb -#else - module procedure stdlib_zheequb +#else + module procedure stdlib${ii}$_zheequb #endif - end interface heequb - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$heequb +#:endif +#:endfor +#:endfor + end interface heequb interface heev !! HEEV computes all eigenvalues and, optionally, eigenvectors of a !! complex Hermitian matrix A. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cheev( jobz, uplo, n, a, lda, w, work, lwork, rwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,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 real(sp), intent(out) :: rwork(*),w(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: work(*) end subroutine cheev -#else - module procedure stdlib_cheev +#else + module procedure stdlib${ii}$_cheev #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$heev - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zheev( jobz, uplo, n, a, lda, w, work, lwork, rwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,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 real(dp), intent(out) :: rwork(*),w(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: work(*) end subroutine zheev -#else - module procedure stdlib_zheev +#else + module procedure stdlib${ii}$_zheev #endif - end interface heev - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$heev +#:endif +#:endfor +#:endfor + end interface heev interface heevd !! HEEVD computes all eigenvalues and, optionally, eigenvectors of a @@ -6187,45 +6130,45 @@ module stdlib_linalg_lapack !! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or !! Cray-2. It could conceivably fail on hexadecimal or decimal machines !! without guard digits, but we know of none. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cheevd( jobz, uplo, n, a, lda, w, work, lwork, rwork,lrwork, iwork, & liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,liwork,lrwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,liwork,lrwork,lwork,n real(sp), intent(out) :: rwork(*),w(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: work(*) end subroutine cheevd -#else - module procedure stdlib_cheevd +#else + module procedure stdlib${ii}$_cheevd #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$heevd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zheevd( jobz, uplo, n, a, lda, w, work, lwork, rwork,lrwork, iwork, & liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,liwork,lrwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,liwork,lrwork,lwork,n real(dp), intent(out) :: rwork(*),w(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: work(*) end subroutine zheevd -#else - module procedure stdlib_zheevd +#else + module procedure stdlib${ii}$_zheevd #endif - end interface heevd - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$heevd +#:endif +#:endfor +#:endfor + end interface heevd interface heevr !! HEEVR computes selected eigenvalues and, optionally, eigenvectors @@ -6278,47 +6221,47 @@ module stdlib_linalg_lapack !! hence may abort due to a floating point exception in environments !! which do not handle NaNs and infinities in the ieee standard default !! manner. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cheevr( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, & ldz, isuppz, work, lwork,rwork, lrwork, iwork, liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,range,uplo - integer(ilp), intent(in) :: il,iu,lda,ldz,liwork,lrwork,lwork,n - integer(ilp), intent(out) :: info,m,isuppz(*),iwork(*) + integer(${ik}$), intent(in) :: il,iu,lda,ldz,liwork,lrwork,lwork,n + integer(${ik}$), intent(out) :: info,m,isuppz(*),iwork(*) real(sp), intent(in) :: abstol,vl,vu real(sp), intent(out) :: rwork(*),w(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: work(*),z(ldz,*) end subroutine cheevr -#else - module procedure stdlib_cheevr +#else + module procedure stdlib${ii}$_cheevr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$heevr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zheevr( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, & ldz, isuppz, work, lwork,rwork, lrwork, iwork, liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,range,uplo - integer(ilp), intent(in) :: il,iu,lda,ldz,liwork,lrwork,lwork,n - integer(ilp), intent(out) :: info,m,isuppz(*),iwork(*) + integer(${ik}$), intent(in) :: il,iu,lda,ldz,liwork,lrwork,lwork,n + integer(${ik}$), intent(out) :: info,m,isuppz(*),iwork(*) real(dp), intent(in) :: abstol,vl,vu real(dp), intent(out) :: rwork(*),w(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: work(*),z(ldz,*) end subroutine zheevr -#else - module procedure stdlib_zheevr +#else + module procedure stdlib${ii}$_zheevr #endif - end interface heevr - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$heevr +#:endif +#:endfor +#:endfor + end interface heevr interface hegst !! HEGST reduces a complex Hermitian-definite generalized @@ -6328,39 +6271,39 @@ module stdlib_linalg_lapack !! If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or !! B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L. !! B must have been previously factorized as U**H*U or L*L**H by CPOTRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chegst( itype, uplo, n, a, lda, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(inout) :: a(lda,*),b(ldb,*) end subroutine chegst -#else - module procedure stdlib_chegst +#else + module procedure stdlib${ii}$_chegst #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hegst - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhegst( itype, uplo, n, a, lda, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(inout) :: a(lda,*),b(ldb,*) end subroutine zhegst -#else - module procedure stdlib_zhegst +#else + module procedure stdlib${ii}$_zhegst #endif - end interface hegst - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hegst +#:endif +#:endfor +#:endfor + end interface hegst interface hegv !! HEGV computes all the eigenvalues, and optionally, the eigenvectors @@ -6368,45 +6311,45 @@ module stdlib_linalg_lapack !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. !! Here A and B are assumed to be Hermitian and B is also !! positive definite. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine chegv( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, rwork, info & ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: itype,lda,ldb,lwork,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: itype,lda,ldb,lwork,n real(sp), intent(out) :: rwork(*),w(*) complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: work(*) end subroutine chegv -#else - module procedure stdlib_chegv +#else + module procedure stdlib${ii}$_chegv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hegv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zhegv( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, rwork, info & ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: itype,lda,ldb,lwork,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: itype,lda,ldb,lwork,n real(dp), intent(out) :: rwork(*),w(*) complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: work(*) end subroutine zhegv -#else - module procedure stdlib_zhegv +#else + module procedure stdlib${ii}$_zhegv #endif - end interface hegv - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hegv +#:endif +#:endfor +#:endfor + end interface hegv interface hegvd !! HEGVD computes all the eigenvalues, and optionally, the eigenvectors @@ -6420,91 +6363,91 @@ module stdlib_linalg_lapack !! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or !! Cray-2. It could conceivably fail on hexadecimal or decimal machines !! without guard digits, but we know of none. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine chegvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, rwork, & lrwork, iwork, liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: itype,lda,ldb,liwork,lrwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: itype,lda,ldb,liwork,lrwork,lwork,n real(sp), intent(out) :: rwork(*),w(*) complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: work(*) end subroutine chegvd -#else - module procedure stdlib_chegvd +#else + module procedure stdlib${ii}$_chegvd #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hegvd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zhegvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, rwork, & lrwork, iwork, liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: itype,lda,ldb,liwork,lrwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: itype,lda,ldb,liwork,lrwork,lwork,n real(dp), intent(out) :: rwork(*),w(*) complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: work(*) end subroutine zhegvd -#else - module procedure stdlib_zhegvd +#else + module procedure stdlib${ii}$_zhegvd #endif - end interface hegvd - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hegvd +#:endif +#:endfor +#:endfor + end interface hegvd interface herfs !! HERFS improves the computed solution to a system of linear !! equations when the coefficient matrix is Hermitian indefinite, and !! provides error bounds and backward error estimates for the solution. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cherfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr,& berr, work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs,ipiv(*) real(sp), intent(out) :: berr(*),ferr(*),rwork(*) complex(sp), intent(in) :: a(lda,*),af(ldaf,*),b(ldb,*) complex(sp), intent(out) :: work(*) complex(sp), intent(inout) :: x(ldx,*) end subroutine cherfs -#else - module procedure stdlib_cherfs +#else + module procedure stdlib${ii}$_cherfs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$herfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zherfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr,& berr, work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs,ipiv(*) real(dp), intent(out) :: berr(*),ferr(*),rwork(*) complex(dp), intent(in) :: a(lda,*),af(ldaf,*),b(ldb,*) complex(dp), intent(out) :: work(*) complex(dp), intent(inout) :: x(ldx,*) end subroutine zherfs -#else - module procedure stdlib_zherfs +#else + module procedure stdlib${ii}$_zherfs #endif - end interface herfs - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$herfs +#:endif +#:endfor +#:endfor + end interface herfs interface hesv !! HESV computes the solution to a complex system of linear equations @@ -6518,43 +6461,43 @@ module stdlib_linalg_lapack !! triangular matrices, and D is Hermitian and block diagonal with !! 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then !! used to solve the system of equations A * X = B. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chesv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,lwork,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,n,nrhs complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: work(*) end subroutine chesv -#else - module procedure stdlib_chesv +#else + module procedure stdlib${ii}$_chesv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hesv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhesv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,lwork,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,n,nrhs complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: work(*) end subroutine zhesv -#else - module procedure stdlib_zhesv +#else + module procedure stdlib${ii}$_zhesv #endif - end interface hesv - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hesv +#:endif +#:endfor +#:endfor + end interface hesv interface hesv_aa !! HESV_AA computes the solution to a complex system of linear equations @@ -6567,43 +6510,43 @@ module stdlib_linalg_lapack !! where U (or L) is a product of permutation and unit upper (lower) !! triangular matrices, and T is Hermitian and tridiagonal. The factored form !! of A is then used to solve the system of equations A * X = B. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chesv_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,lwork,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,n,nrhs complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: work(*) end subroutine chesv_aa -#else - module procedure stdlib_chesv_aa +#else + module procedure stdlib${ii}$_chesv_aa #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hesv_aa - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhesv_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,lwork,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,n,nrhs complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: work(*) end subroutine zhesv_aa -#else - module procedure stdlib_zhesv_aa +#else + module procedure stdlib${ii}$_zhesv_aa #endif - end interface hesv_aa - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hesv_aa +#:endif +#:endfor +#:endfor + end interface hesv_aa interface hesv_rk !! HESV_RK computes the solution to a complex system of linear @@ -6620,43 +6563,43 @@ module stdlib_linalg_lapack !! CHETRF_RK is called to compute the factorization of a complex !! Hermitian matrix. The factored form of A is then used to solve !! the system of equations A * X = B by calling BLAS3 routine CHETRS_3. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chesv_rk( uplo, n, nrhs, a, lda, e, ipiv, b, ldb, work,lwork, info & ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,lwork,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,n,nrhs complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: e(*),work(*) end subroutine chesv_rk -#else - module procedure stdlib_chesv_rk +#else + module procedure stdlib${ii}$_chesv_rk #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hesv_rk - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhesv_rk( uplo, n, nrhs, a, lda, e, ipiv, b, ldb, work,lwork, info & ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,lwork,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,n,nrhs complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: e(*),work(*) end subroutine zhesv_rk -#else - module procedure stdlib_zhesv_rk +#else + module procedure stdlib${ii}$_zhesv_rk #endif - end interface hesv_rk - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hesv_rk +#:endif +#:endfor +#:endfor + end interface hesv_rk interface hesv_rook !! HESV_ROOK computes the solution to a complex system of linear equations @@ -6675,78 +6618,78 @@ module stdlib_linalg_lapack !! pivoting method. !! The factored form of A is then used to solve the system !! of equations A * X = B by calling CHETRS_ROOK (uses BLAS 2). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chesv_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,lwork,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,n,nrhs complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: work(*) end subroutine chesv_rook -#else - module procedure stdlib_chesv_rook +#else + module procedure stdlib${ii}$_chesv_rook #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hesv_rook - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhesv_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,lwork,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,n,nrhs complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: work(*) end subroutine zhesv_rook -#else - module procedure stdlib_zhesv_rook +#else + module procedure stdlib${ii}$_zhesv_rook #endif - end interface hesv_rook - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hesv_rook +#:endif +#:endfor +#:endfor + end interface hesv_rook interface heswapr !! HESWAPR applies an elementary permutation on the rows and the columns of !! a hermitian matrix. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cheswapr( uplo, n, a, lda, i1, i2) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: i1,i2,lda,n + integer(${ik}$), intent(in) :: i1,i2,lda,n complex(sp), intent(inout) :: a(lda,n) end subroutine cheswapr -#else - module procedure stdlib_cheswapr +#else + module procedure stdlib${ii}$_cheswapr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$heswapr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zheswapr( uplo, n, a, lda, i1, i2) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: i1,i2,lda,n + integer(${ik}$), intent(in) :: i1,i2,lda,n complex(dp), intent(inout) :: a(lda,n) end subroutine zheswapr -#else - module procedure stdlib_zheswapr +#else + module procedure stdlib${ii}$_zheswapr #endif - end interface heswapr - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$heswapr +#:endif +#:endfor +#:endfor + end interface heswapr interface hetf2_rk !! HETF2_RK computes the factorization of a complex Hermitian matrix A @@ -6758,41 +6701,41 @@ module stdlib_linalg_lapack !! diagonal with 1-by-1 and 2-by-2 diagonal blocks. !! This is the unblocked version of the algorithm, calling Level 2 BLAS. !! For more information see Further Details section. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chetf2_rk( uplo, n, a, lda, e, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: e(*) end subroutine chetf2_rk -#else - module procedure stdlib_chetf2_rk +#else + module procedure stdlib${ii}$_chetf2_rk #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hetf2_rk - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhetf2_rk( uplo, n, a, lda, e, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: e(*) end subroutine zhetf2_rk -#else - module procedure stdlib_zhetf2_rk +#else + module procedure stdlib${ii}$_zhetf2_rk #endif - end interface hetf2_rk - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hetf2_rk +#:endif +#:endfor +#:endfor + end interface hetf2_rk interface hetf2_rook !! HETF2_ROOK computes the factorization of a complex Hermitian matrix A @@ -6802,167 +6745,167 @@ module stdlib_linalg_lapack !! triangular matrices, U**H is the conjugate transpose of U, and D is !! Hermitian 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. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chetf2_rook( uplo, n, a, lda, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,n complex(sp), intent(inout) :: a(lda,*) end subroutine chetf2_rook -#else - module procedure stdlib_chetf2_rook +#else + module procedure stdlib${ii}$_chetf2_rook #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hetf2_rook - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhetf2_rook( uplo, n, a, lda, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,n complex(dp), intent(inout) :: a(lda,*) end subroutine zhetf2_rook -#else - module procedure stdlib_zhetf2_rook +#else + module procedure stdlib${ii}$_zhetf2_rook #endif - end interface hetf2_rook - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hetf2_rook +#:endif +#:endfor +#:endfor + end interface hetf2_rook interface hetrd !! HETRD reduces a complex Hermitian matrix A to real symmetric !! tridiagonal form T by a unitary similarity transformation: !! Q**H * A * Q = T. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chetrd( uplo, n, a, lda, d, e, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(out) :: d(*),e(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: tau(*),work(*) end subroutine chetrd -#else - module procedure stdlib_chetrd +#else + module procedure stdlib${ii}$_chetrd #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hetrd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhetrd( uplo, n, a, lda, d, e, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(out) :: d(*),e(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: tau(*),work(*) end subroutine zhetrd -#else - module procedure stdlib_zhetrd +#else + module procedure stdlib${ii}$_zhetrd #endif - end interface hetrd - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hetrd +#:endif +#:endfor +#:endfor + end interface hetrd interface hetrd_hb2st !! HETRD_HB2ST reduces a complex Hermitian band matrix A to real symmetric !! tridiagonal form T by a unitary similarity transformation: !! Q**H * A * Q = T. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine chetrd_hb2st( stage1, vect, uplo, n, kd, ab, ldab,d, e, hous, & lhous, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: stage1,uplo,vect - integer(ilp), intent(in) :: n,kd,ldab,lhous,lwork - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n,kd,ldab,lhous,lwork + integer(${ik}$), intent(out) :: info real(sp), intent(out) :: d(*),e(*) complex(sp), intent(inout) :: ab(ldab,*) complex(sp), intent(out) :: hous(*),work(*) end subroutine chetrd_hb2st -#else - module procedure stdlib_chetrd_hb2st +#else + module procedure stdlib${ii}$_chetrd_hb2st #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hetrd_hb2st - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zhetrd_hb2st( stage1, vect, uplo, n, kd, ab, ldab,d, e, hous, & lhous, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: stage1,uplo,vect - integer(ilp), intent(in) :: n,kd,ldab,lhous,lwork - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n,kd,ldab,lhous,lwork + integer(${ik}$), intent(out) :: info real(dp), intent(out) :: d(*),e(*) complex(dp), intent(inout) :: ab(ldab,*) complex(dp), intent(out) :: hous(*),work(*) end subroutine zhetrd_hb2st -#else - module procedure stdlib_zhetrd_hb2st +#else + module procedure stdlib${ii}$_zhetrd_hb2st #endif - end interface hetrd_hb2st - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hetrd_hb2st +#:endif +#:endfor +#:endfor + end interface hetrd_hb2st interface hetrd_he2hb !! HETRD_HE2HB reduces a complex Hermitian matrix A to complex Hermitian !! band-diagonal form AB by a unitary similarity transformation: !! Q**H * A * Q = AB. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine chetrd_he2hb( uplo, n, kd, a, lda, ab, ldab, tau,work, lwork, info & ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldab,lwork,n,kd + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldab,lwork,n,kd complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: ab(ldab,*),tau(*),work(*) end subroutine chetrd_he2hb -#else - module procedure stdlib_chetrd_he2hb +#else + module procedure stdlib${ii}$_chetrd_he2hb #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hetrd_he2hb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zhetrd_he2hb( uplo, n, kd, a, lda, ab, ldab, tau,work, lwork, info & ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldab,lwork,n,kd + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldab,lwork,n,kd complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: ab(ldab,*),tau(*),work(*) end subroutine zhetrd_he2hb -#else - module procedure stdlib_zhetrd_he2hb +#else + module procedure stdlib${ii}$_zhetrd_he2hb #endif - end interface hetrd_he2hb - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hetrd_he2hb +#:endif +#:endfor +#:endfor + end interface hetrd_he2hb interface hetrf !! HETRF computes the factorization of a complex Hermitian matrix A @@ -6973,41 +6916,41 @@ module stdlib_linalg_lapack !! triangular matrices, and D is Hermitian 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. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chetrf( uplo, n, a, lda, ipiv, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,lwork,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,lwork,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: work(*) end subroutine chetrf -#else - module procedure stdlib_chetrf +#else + module procedure stdlib${ii}$_chetrf #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hetrf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhetrf( uplo, n, a, lda, ipiv, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,lwork,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,lwork,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: work(*) end subroutine zhetrf -#else - module procedure stdlib_zhetrf +#else + module procedure stdlib${ii}$_zhetrf #endif - end interface hetrf - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hetrf +#:endif +#:endfor +#:endfor + end interface hetrf interface hetrf_aa !! HETRF_AA computes the factorization of a complex hermitian matrix A @@ -7016,41 +6959,41 @@ module stdlib_linalg_lapack !! where U (or L) is a product of permutation and unit upper (lower) !! triangular matrices, and T is a hermitian tridiagonal matrix. !! This is the blocked version of the algorithm, calling Level 3 BLAS. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chetrf_aa( uplo, n, a, lda, ipiv, work, lwork, info) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: n,lda,lwork - integer(ilp), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: n,lda,lwork + integer(${ik}$), intent(out) :: info,ipiv(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: work(*) end subroutine chetrf_aa -#else - module procedure stdlib_chetrf_aa +#else + module procedure stdlib${ii}$_chetrf_aa #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hetrf_aa - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhetrf_aa( uplo, n, a, lda, ipiv, work, lwork, info) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: n,lda,lwork - integer(ilp), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: n,lda,lwork + integer(${ik}$), intent(out) :: info,ipiv(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: work(*) end subroutine zhetrf_aa -#else - module procedure stdlib_zhetrf_aa +#else + module procedure stdlib${ii}$_zhetrf_aa #endif - end interface hetrf_aa - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hetrf_aa +#:endif +#:endfor +#:endfor + end interface hetrf_aa interface hetrf_rk !! HETRF_RK computes the factorization of a complex Hermitian matrix A @@ -7062,41 +7005,41 @@ module stdlib_linalg_lapack !! diagonal with 1-by-1 and 2-by-2 diagonal blocks. !! This is the blocked version of the algorithm, calling Level 3 BLAS. !! For more information see Further Details section. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chetrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,lwork,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,lwork,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: e(*),work(*) end subroutine chetrf_rk -#else - module procedure stdlib_chetrf_rk +#else + module procedure stdlib${ii}$_chetrf_rk #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hetrf_rk - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhetrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,lwork,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,lwork,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: e(*),work(*) end subroutine zhetrf_rk -#else - module procedure stdlib_zhetrf_rk +#else + module procedure stdlib${ii}$_zhetrf_rk #endif - end interface hetrf_rk - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hetrf_rk +#:endif +#:endfor +#:endfor + end interface hetrf_rk interface hetrf_rook !! HETRF_ROOK computes the factorization of a complex Hermitian matrix A @@ -7107,201 +7050,201 @@ module stdlib_linalg_lapack !! triangular matrices, and D is Hermitian 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. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chetrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,lwork,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,lwork,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: work(*) end subroutine chetrf_rook -#else - module procedure stdlib_chetrf_rook +#else + module procedure stdlib${ii}$_chetrf_rook #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hetrf_rook - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhetrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,lwork,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,lwork,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: work(*) end subroutine zhetrf_rook -#else - module procedure stdlib_zhetrf_rook +#else + module procedure stdlib${ii}$_zhetrf_rook #endif - end interface hetrf_rook - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hetrf_rook +#:endif +#:endfor +#:endfor + end interface hetrf_rook interface hetri !! HETRI computes the inverse of a complex Hermitian indefinite matrix !! A using the factorization A = U*D*U**H or A = L*D*L**H computed by !! CHETRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chetri( uplo, n, a, lda, ipiv, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: work(*) end subroutine chetri -#else - module procedure stdlib_chetri +#else + module procedure stdlib${ii}$_chetri #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hetri - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhetri( uplo, n, a, lda, ipiv, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: work(*) end subroutine zhetri -#else - module procedure stdlib_zhetri +#else + module procedure stdlib${ii}$_zhetri #endif - end interface hetri - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hetri +#:endif +#:endfor +#:endfor + end interface hetri interface hetri_rook !! HETRI_ROOK computes the inverse of a complex Hermitian indefinite matrix !! A using the factorization A = U*D*U**H or A = L*D*L**H computed by !! CHETRF_ROOK. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chetri_rook( uplo, n, a, lda, ipiv, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: work(*) end subroutine chetri_rook -#else - module procedure stdlib_chetri_rook +#else + module procedure stdlib${ii}$_chetri_rook #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hetri_rook - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhetri_rook( uplo, n, a, lda, ipiv, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: work(*) end subroutine zhetri_rook -#else - module procedure stdlib_zhetri_rook +#else + module procedure stdlib${ii}$_zhetri_rook #endif - end interface hetri_rook - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hetri_rook +#:endif +#:endfor +#:endfor + end interface hetri_rook interface hetrs !! HETRS solves a system of linear equations A*X = B with a complex !! Hermitian matrix A using the factorization A = U*D*U**H or !! A = L*D*L**H computed by CHETRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chetrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) complex(sp), intent(in) :: a(lda,*) complex(sp), intent(inout) :: b(ldb,*) end subroutine chetrs -#else - module procedure stdlib_chetrs +#else + module procedure stdlib${ii}$_chetrs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hetrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhetrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) complex(dp), intent(in) :: a(lda,*) complex(dp), intent(inout) :: b(ldb,*) end subroutine zhetrs -#else - module procedure stdlib_zhetrs +#else + module procedure stdlib${ii}$_zhetrs #endif - end interface hetrs - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hetrs +#:endif +#:endfor +#:endfor + end interface hetrs interface hetrs2 !! HETRS2 solves a system of linear equations A*X = B with a complex !! Hermitian matrix A using the factorization A = U*D*U**H or !! A = L*D*L**H computed by CHETRF and converted by CSYCONV. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chetrs2( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: work(*) end subroutine chetrs2 -#else - module procedure stdlib_chetrs2 +#else + module procedure stdlib${ii}$_chetrs2 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hetrs2 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhetrs2( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: work(*) end subroutine zhetrs2 -#else - module procedure stdlib_zhetrs2 +#else + module procedure stdlib${ii}$_zhetrs2 #endif - end interface hetrs2 - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hetrs2 +#:endif +#:endfor +#:endfor + end interface hetrs2 interface hetrs_3 !! HETRS_3 solves a system of linear equations A * X = B with a complex @@ -7313,125 +7256,125 @@ module stdlib_linalg_lapack !! matrix, P**T is the transpose of P, and D is Hermitian and block !! diagonal with 1-by-1 and 2-by-2 diagonal blocks. !! This algorithm is using Level 3 BLAS. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chetrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) complex(sp), intent(in) :: a(lda,*),e(*) complex(sp), intent(inout) :: b(ldb,*) end subroutine chetrs_3 -#else - module procedure stdlib_chetrs_3 +#else + module procedure stdlib${ii}$_chetrs_3 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hetrs_3 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhetrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) complex(dp), intent(in) :: a(lda,*),e(*) complex(dp), intent(inout) :: b(ldb,*) end subroutine zhetrs_3 -#else - module procedure stdlib_zhetrs_3 +#else + module procedure stdlib${ii}$_zhetrs_3 #endif - end interface hetrs_3 - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hetrs_3 +#:endif +#:endfor +#:endfor + end interface hetrs_3 interface hetrs_aa !! HETRS_AA solves a system of linear equations A*X = B with a complex !! hermitian matrix A using the factorization A = U**H*T*U or !! A = L*T*L**H computed by CHETRF_AA. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chetrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: n,nrhs,lda,ldb,lwork,ipiv(*) - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n,nrhs,lda,ldb,lwork,ipiv(*) + integer(${ik}$), intent(out) :: info complex(sp), intent(in) :: a(lda,*) complex(sp), intent(inout) :: b(ldb,*) complex(sp), intent(out) :: work(*) end subroutine chetrs_aa -#else - module procedure stdlib_chetrs_aa +#else + module procedure stdlib${ii}$_chetrs_aa #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hetrs_aa - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhetrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: n,nrhs,lda,ldb,lwork,ipiv(*) - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n,nrhs,lda,ldb,lwork,ipiv(*) + integer(${ik}$), intent(out) :: info complex(dp), intent(in) :: a(lda,*) complex(dp), intent(inout) :: b(ldb,*) complex(dp), intent(out) :: work(*) end subroutine zhetrs_aa -#else - module procedure stdlib_zhetrs_aa +#else + module procedure stdlib${ii}$_zhetrs_aa #endif - end interface hetrs_aa - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hetrs_aa +#:endif +#:endfor +#:endfor + end interface hetrs_aa interface hetrs_rook !! HETRS_ROOK solves a system of linear equations A*X = B with a complex !! Hermitian matrix A using the factorization A = U*D*U**H or !! A = L*D*L**H computed by CHETRF_ROOK. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chetrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) complex(sp), intent(in) :: a(lda,*) complex(sp), intent(inout) :: b(ldb,*) end subroutine chetrs_rook -#else - module procedure stdlib_chetrs_rook +#else + module procedure stdlib${ii}$_chetrs_rook #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hetrs_rook - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhetrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) complex(dp), intent(in) :: a(lda,*) complex(dp), intent(inout) :: b(ldb,*) end subroutine zhetrs_rook -#else - module procedure stdlib_zhetrs_rook +#else + module procedure stdlib${ii}$_zhetrs_rook #endif - end interface hetrs_rook - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hetrs_rook +#:endif +#:endfor +#:endfor + end interface hetrs_rook interface hfrk !! Level 3 BLAS like routine for C in RFP Format. @@ -7442,41 +7385,41 @@ module stdlib_linalg_lapack !! where alpha and beta are real scalars, C is an n--by--n Hermitian !! matrix and A is an n--by--k matrix in the first case and a k--by--n !! matrix in the second case. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chfrk( transr, uplo, trans, n, k, alpha, a, lda, beta,c ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(in) :: a(lda,*) complex(sp), intent(inout) :: c(*) end subroutine chfrk -#else - module procedure stdlib_chfrk +#else + module procedure stdlib${ii}$_chfrk #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hfrk - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhfrk( transr, uplo, trans, n, k, alpha, a, lda, beta,c ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha,beta - integer(ilp), intent(in) :: k,lda,n + integer(${ik}$), intent(in) :: k,lda,n character, intent(in) :: trans,transr,uplo complex(dp), intent(in) :: a(lda,*) complex(dp), intent(inout) :: c(*) end subroutine zhfrk -#else - module procedure stdlib_zhfrk +#else + module procedure stdlib${ii}$_zhfrk #endif - end interface hfrk - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hfrk +#:endif +#:endfor +#:endfor + end interface hfrk interface hgeqz !! HGEQZ computes the eigenvalues of a complex matrix pair (H,T), @@ -7512,79 +7455,79 @@ module stdlib_linalg_lapack !! Ref: C.B. Moler !! Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), !! pp. 241--256. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine chgeqz( job, compq, compz, n, ilo, ihi, h, ldh, t, ldt,alpha, beta, q, & ldq, z, ldz, work, lwork,rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compq,compz,job - integer(ilp), intent(in) :: ihi,ilo,ldh,ldq,ldt,ldz,lwork,n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi,ilo,ldh,ldq,ldt,ldz,lwork,n + integer(${ik}$), intent(out) :: info real(sp), intent(out) :: rwork(*) complex(sp), intent(out) :: alpha(*),beta(*),work(*) complex(sp), intent(inout) :: h(ldh,*),q(ldq,*),t(ldt,*),z(ldz,*) end subroutine chgeqz -#else - module procedure stdlib_chgeqz +#else + module procedure stdlib${ii}$_chgeqz #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dhgeqz( job, compq, compz, n, ilo, ihi, h, ldh, t, ldt,alphar, alphai, & beta, q, ldq, z, ldz, work,lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compq,compz,job - integer(ilp), intent(in) :: ihi,ilo,ldh,ldq,ldt,ldz,lwork,n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi,ilo,ldh,ldq,ldt,ldz,lwork,n + integer(${ik}$), intent(out) :: info real(dp), intent(out) :: alphai(*),alphar(*),beta(*),work(*) real(dp), intent(inout) :: h(ldh,*),q(ldq,*),t(ldt,*),z(ldz,*) end subroutine dhgeqz -#else - module procedure stdlib_dhgeqz +#else + module procedure stdlib${ii}$_dhgeqz #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hgeqz - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine shgeqz( job, compq, compz, n, ilo, ihi, h, ldh, t, ldt,alphar, alphai, & beta, q, ldq, z, ldz, work,lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compq,compz,job - integer(ilp), intent(in) :: ihi,ilo,ldh,ldq,ldt,ldz,lwork,n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi,ilo,ldh,ldq,ldt,ldz,lwork,n + integer(${ik}$), intent(out) :: info real(sp), intent(out) :: alphai(*),alphar(*),beta(*),work(*) real(sp), intent(inout) :: h(ldh,*),q(ldq,*),t(ldt,*),z(ldz,*) end subroutine shgeqz -#else - module procedure stdlib_shgeqz +#else + module procedure stdlib${ii}$_shgeqz #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hgeqz - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zhgeqz( job, compq, compz, n, ilo, ihi, h, ldh, t, ldt,alpha, beta, q, & ldq, z, ldz, work, lwork,rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compq,compz,job - integer(ilp), intent(in) :: ihi,ilo,ldh,ldq,ldt,ldz,lwork,n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi,ilo,ldh,ldq,ldt,ldz,lwork,n + integer(${ik}$), intent(out) :: info real(dp), intent(out) :: rwork(*) complex(dp), intent(out) :: alpha(*),beta(*),work(*) complex(dp), intent(inout) :: h(ldh,*),q(ldq,*),t(ldt,*),z(ldz,*) end subroutine zhgeqz -#else - module procedure stdlib_zhgeqz +#else + module procedure stdlib${ii}$_zhgeqz #endif - end interface hgeqz +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hgeqz +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hgeqz +#:endif +#:endfor +#:endfor + end interface hgeqz interface hpcon !! HPCON estimates the reciprocal of the condition number of a complex @@ -7592,86 +7535,86 @@ module stdlib_linalg_lapack !! A = L*D*L**H computed by CHPTRF. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chpcon( uplo, n, ap, ipiv, anorm, rcond, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n,ipiv(*) real(sp), intent(in) :: anorm real(sp), intent(out) :: rcond complex(sp), intent(in) :: ap(*) complex(sp), intent(out) :: work(*) end subroutine chpcon -#else - module procedure stdlib_chpcon +#else + module procedure stdlib${ii}$_chpcon #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hpcon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhpcon( uplo, n, ap, ipiv, anorm, rcond, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n,ipiv(*) real(dp), intent(in) :: anorm real(dp), intent(out) :: rcond complex(dp), intent(in) :: ap(*) complex(dp), intent(out) :: work(*) end subroutine zhpcon -#else - module procedure stdlib_zhpcon +#else + module procedure stdlib${ii}$_zhpcon #endif - end interface hpcon - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hpcon +#:endif +#:endfor +#:endfor + end interface hpcon interface hpev !! HPEV computes all the eigenvalues and, optionally, eigenvectors of a !! complex Hermitian matrix in packed storage. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine chpev( jobz, uplo, n, ap, w, z, ldz, work, rwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldz,n real(sp), intent(out) :: rwork(*),w(*) complex(sp), intent(inout) :: ap(*) complex(sp), intent(out) :: work(*),z(ldz,*) end subroutine chpev -#else - module procedure stdlib_chpev +#else + module procedure stdlib${ii}$_chpev #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hpev - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zhpev( jobz, uplo, n, ap, w, z, ldz, work, rwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldz,n real(dp), intent(out) :: rwork(*),w(*) complex(dp), intent(inout) :: ap(*) complex(dp), intent(out) :: work(*),z(ldz,*) end subroutine zhpev -#else - module procedure stdlib_zhpev +#else + module procedure stdlib${ii}$_zhpev #endif - end interface hpev - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hpev +#:endif +#:endfor +#:endfor + end interface hpev interface hpevd !! HPEVD computes all the eigenvalues and, optionally, eigenvectors of @@ -7683,45 +7626,45 @@ module stdlib_linalg_lapack !! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or !! Cray-2. It could conceivably fail on hexadecimal or decimal machines !! without guard digits, but we know of none. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine chpevd( jobz, uplo, n, ap, w, z, ldz, work, lwork,rwork, lrwork, iwork, & liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldz,liwork,lrwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldz,liwork,lrwork,lwork,n real(sp), intent(out) :: rwork(*),w(*) complex(sp), intent(inout) :: ap(*) complex(sp), intent(out) :: work(*),z(ldz,*) end subroutine chpevd -#else - module procedure stdlib_chpevd +#else + module procedure stdlib${ii}$_chpevd #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hpevd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zhpevd( jobz, uplo, n, ap, w, z, ldz, work, lwork,rwork, lrwork, iwork, & liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldz,liwork,lrwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldz,liwork,lrwork,lwork,n real(dp), intent(out) :: rwork(*),w(*) complex(dp), intent(inout) :: ap(*) complex(dp), intent(out) :: work(*),z(ldz,*) end subroutine zhpevd -#else - module procedure stdlib_zhpevd +#else + module procedure stdlib${ii}$_zhpevd #endif - end interface hpevd - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hpevd +#:endif +#:endfor +#:endfor + end interface hpevd interface hpgst !! HPGST reduces a complex Hermitian-definite generalized @@ -7731,41 +7674,41 @@ module stdlib_linalg_lapack !! If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or !! B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L. !! B must have been previously factorized as U**H*U or L*L**H by CPPTRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chpgst( itype, uplo, n, ap, bp, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: itype,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: itype,n complex(sp), intent(inout) :: ap(*) complex(sp), intent(in) :: bp(*) end subroutine chpgst -#else - module procedure stdlib_chpgst +#else + module procedure stdlib${ii}$_chpgst #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hpgst - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhpgst( itype, uplo, n, ap, bp, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: itype,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: itype,n complex(dp), intent(inout) :: ap(*) complex(dp), intent(in) :: bp(*) end subroutine zhpgst -#else - module procedure stdlib_zhpgst +#else + module procedure stdlib${ii}$_zhpgst #endif - end interface hpgst - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hpgst +#:endif +#:endfor +#:endfor + end interface hpgst interface hpgv !! HPGV computes all the eigenvalues and, optionally, the eigenvectors @@ -7773,45 +7716,45 @@ module stdlib_linalg_lapack !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. !! Here A and B are assumed to be Hermitian, stored in packed format, !! and B is also positive definite. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine chpgv( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,rwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: itype,ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: itype,ldz,n real(sp), intent(out) :: rwork(*),w(*) complex(sp), intent(inout) :: ap(*),bp(*) complex(sp), intent(out) :: work(*),z(ldz,*) end subroutine chpgv -#else - module procedure stdlib_chpgv +#else + module procedure stdlib${ii}$_chpgv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hpgv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zhpgv( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,rwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: itype,ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: itype,ldz,n real(dp), intent(out) :: rwork(*),w(*) complex(dp), intent(inout) :: ap(*),bp(*) complex(dp), intent(out) :: work(*),z(ldz,*) end subroutine zhpgv -#else - module procedure stdlib_zhpgv +#else + module procedure stdlib${ii}$_zhpgv #endif - end interface hpgv - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hpgv +#:endif +#:endfor +#:endfor + end interface hpgv interface hpgvd !! HPGVD computes all the eigenvalues and, optionally, the eigenvectors @@ -7826,92 +7769,92 @@ module stdlib_linalg_lapack !! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or !! Cray-2. It could conceivably fail on hexadecimal or decimal machines !! without guard digits, but we know of none. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine chpgvd( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,lwork, rwork, & lrwork, iwork, liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: itype,ldz,liwork,lrwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: itype,ldz,liwork,lrwork,lwork,n real(sp), intent(out) :: rwork(*),w(*) complex(sp), intent(inout) :: ap(*),bp(*) complex(sp), intent(out) :: work(*),z(ldz,*) end subroutine chpgvd -#else - module procedure stdlib_chpgvd +#else + module procedure stdlib${ii}$_chpgvd #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hpgvd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zhpgvd( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,lwork, rwork, & lrwork, iwork, liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: itype,ldz,liwork,lrwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: itype,ldz,liwork,lrwork,lwork,n real(dp), intent(out) :: rwork(*),w(*) complex(dp), intent(inout) :: ap(*),bp(*) complex(dp), intent(out) :: work(*),z(ldz,*) end subroutine zhpgvd -#else - module procedure stdlib_zhpgvd +#else + module procedure stdlib${ii}$_zhpgvd #endif - end interface hpgvd - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hpgvd +#:endif +#:endfor +#:endfor + end interface hpgvd interface hprfs !! HPRFS improves the computed solution to a system of linear !! equations when the coefficient matrix is Hermitian indefinite !! and packed, and provides error bounds and backward error estimates !! for the solution. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, & work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,ldx,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,ldx,n,nrhs,ipiv(*) real(sp), intent(out) :: berr(*),ferr(*),rwork(*) complex(sp), intent(in) :: afp(*),ap(*),b(ldb,*) complex(sp), intent(out) :: work(*) complex(sp), intent(inout) :: x(ldx,*) end subroutine chprfs -#else - module procedure stdlib_chprfs +#else + module procedure stdlib${ii}$_chprfs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hprfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, & work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,ldx,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,ldx,n,nrhs,ipiv(*) real(dp), intent(out) :: berr(*),ferr(*),rwork(*) complex(dp), intent(in) :: afp(*),ap(*),b(ldb,*) complex(dp), intent(out) :: work(*) complex(dp), intent(inout) :: x(ldx,*) end subroutine zhprfs -#else - module procedure stdlib_zhprfs +#else + module procedure stdlib${ii}$_zhprfs #endif - end interface hprfs - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hprfs +#:endif +#:endfor +#:endfor + end interface hprfs interface hpsv !! HPSV computes the solution to a complex system of linear equations @@ -7925,81 +7868,81 @@ module stdlib_linalg_lapack !! triangular matrices, D is Hermitian and block diagonal with 1-by-1 !! and 2-by-2 diagonal blocks. The factored form of A is then used to !! solve the system of equations A * X = B. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chpsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: ldb,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: ldb,n,nrhs complex(sp), intent(inout) :: ap(*),b(ldb,*) end subroutine chpsv -#else - module procedure stdlib_chpsv +#else + module procedure stdlib${ii}$_chpsv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hpsv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhpsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: ldb,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: ldb,n,nrhs complex(dp), intent(inout) :: ap(*),b(ldb,*) end subroutine zhpsv -#else - module procedure stdlib_zhpsv +#else + module procedure stdlib${ii}$_zhpsv #endif - end interface hpsv - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hpsv +#:endif +#:endfor +#:endfor + end interface hpsv interface hptrd !! HPTRD reduces a complex Hermitian matrix A stored in packed form to !! real symmetric tridiagonal form T by a unitary similarity !! transformation: Q**H * A * Q = T. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chptrd( uplo, n, ap, d, e, tau, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: 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) :: d(*),e(*) complex(sp), intent(inout) :: ap(*) complex(sp), intent(out) :: tau(*) end subroutine chptrd -#else - module procedure stdlib_chptrd +#else + module procedure stdlib${ii}$_chptrd #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hptrd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhptrd( uplo, n, ap, d, e, tau, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(dp), intent(out) :: d(*),e(*) complex(dp), intent(inout) :: ap(*) complex(dp), intent(out) :: tau(*) end subroutine zhptrd -#else - module procedure stdlib_zhptrd +#else + module procedure stdlib${ii}$_zhptrd #endif - end interface hptrd - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hptrd +#:endif +#:endfor +#:endfor + end interface hptrd interface hptrf !! HPTRF computes the factorization of a complex Hermitian packed @@ -8008,119 +7951,119 @@ module stdlib_linalg_lapack !! where U (or L) is a product of permutation and unit upper (lower) !! triangular matrices, and D is Hermitian and block diagonal with !! 1-by-1 and 2-by-2 diagonal blocks. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chptrf( uplo, n, ap, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: n complex(sp), intent(inout) :: ap(*) end subroutine chptrf -#else - module procedure stdlib_chptrf +#else + module procedure stdlib${ii}$_chptrf #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hptrf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhptrf( uplo, n, ap, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: n complex(dp), intent(inout) :: ap(*) end subroutine zhptrf -#else - module procedure stdlib_zhptrf +#else + module procedure stdlib${ii}$_zhptrf #endif - end interface hptrf - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hptrf +#:endif +#:endfor +#:endfor + end interface hptrf interface hptri !! HPTRI computes the inverse of a complex Hermitian indefinite matrix !! A in packed storage using the factorization A = U*D*U**H or !! A = L*D*L**H computed by CHPTRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chptri( uplo, n, ap, ipiv, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n,ipiv(*) complex(sp), intent(inout) :: ap(*) complex(sp), intent(out) :: work(*) end subroutine chptri -#else - module procedure stdlib_chptri +#else + module procedure stdlib${ii}$_chptri #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hptri - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhptri( uplo, n, ap, ipiv, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n,ipiv(*) complex(dp), intent(inout) :: ap(*) complex(dp), intent(out) :: work(*) end subroutine zhptri -#else - module procedure stdlib_zhptri +#else + module procedure stdlib${ii}$_zhptri #endif - end interface hptri - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hptri +#:endif +#:endfor +#:endfor + end interface hptri interface hptrs !! HPTRS solves a system of linear equations A*X = B with a complex !! Hermitian matrix A stored in packed format using the factorization !! A = U*D*U**H or A = L*D*L**H computed by CHPTRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs,ipiv(*) complex(sp), intent(in) :: ap(*) complex(sp), intent(inout) :: b(ldb,*) end subroutine chptrs -#else - module procedure stdlib_chptrs +#else + module procedure stdlib${ii}$_chptrs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hptrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs,ipiv(*) complex(dp), intent(in) :: ap(*) complex(dp), intent(inout) :: b(ldb,*) end subroutine zhptrs -#else - module procedure stdlib_zhptrs +#else + module procedure stdlib${ii}$_zhptrs #endif - end interface hptrs - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hptrs +#:endif +#:endfor +#:endfor + end interface hptrs interface hsein !! HSEIN uses inverse iteration to find specified right and/or left @@ -8129,87 +8072,87 @@ module stdlib_linalg_lapack !! corresponding to an eigenvalue w are defined by: !! H * x = w * x, y**h * H = w * y**h !! where y**h denotes the conjugate transpose of the vector y. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine chsein( side, eigsrc, initv, select, n, h, ldh, w, vl,ldvl, vr, ldvr, & mm, m, work, rwork, ifaill,ifailr, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: eigsrc,initv,side - integer(ilp), intent(out) :: info,m,ifaill(*),ifailr(*) - integer(ilp), intent(in) :: ldh,ldvl,ldvr,mm,n + integer(${ik}$), intent(out) :: info,m,ifaill(*),ifailr(*) + integer(${ik}$), intent(in) :: ldh,ldvl,ldvr,mm,n logical(lk), intent(in) :: select(*) real(sp), intent(out) :: rwork(*) complex(sp), intent(in) :: h(ldh,*) complex(sp), intent(inout) :: vl(ldvl,*),vr(ldvr,*),w(*) complex(sp), intent(out) :: work(*) end subroutine chsein -#else - module procedure stdlib_chsein +#else + module procedure stdlib${ii}$_chsein #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dhsein( side, eigsrc, initv, select, n, h, ldh, wr, wi,vl, ldvl, vr, & ldvr, mm, m, work, ifaill,ifailr, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: eigsrc,initv,side - integer(ilp), intent(out) :: info,m,ifaill(*),ifailr(*) - integer(ilp), intent(in) :: ldh,ldvl,ldvr,mm,n + integer(${ik}$), intent(out) :: info,m,ifaill(*),ifailr(*) + integer(${ik}$), intent(in) :: ldh,ldvl,ldvr,mm,n logical(lk), intent(inout) :: select(*) real(dp), intent(in) :: h(ldh,*),wi(*) real(dp), intent(inout) :: vl(ldvl,*),vr(ldvr,*),wr(*) real(dp), intent(out) :: work(*) end subroutine dhsein -#else - module procedure stdlib_dhsein +#else + module procedure stdlib${ii}$_dhsein #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hsein - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine shsein( side, eigsrc, initv, select, n, h, ldh, wr, wi,vl, ldvl, vr, & ldvr, mm, m, work, ifaill,ifailr, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: eigsrc,initv,side - integer(ilp), intent(out) :: info,m,ifaill(*),ifailr(*) - integer(ilp), intent(in) :: ldh,ldvl,ldvr,mm,n + integer(${ik}$), intent(out) :: info,m,ifaill(*),ifailr(*) + integer(${ik}$), intent(in) :: ldh,ldvl,ldvr,mm,n logical(lk), intent(inout) :: select(*) real(sp), intent(in) :: h(ldh,*),wi(*) real(sp), intent(inout) :: vl(ldvl,*),vr(ldvr,*),wr(*) real(sp), intent(out) :: work(*) end subroutine shsein -#else - module procedure stdlib_shsein +#else + module procedure stdlib${ii}$_shsein #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hsein - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zhsein( side, eigsrc, initv, select, n, h, ldh, w, vl,ldvl, vr, ldvr, & mm, m, work, rwork, ifaill,ifailr, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: eigsrc,initv,side - integer(ilp), intent(out) :: info,m,ifaill(*),ifailr(*) - integer(ilp), intent(in) :: ldh,ldvl,ldvr,mm,n + integer(${ik}$), intent(out) :: info,m,ifaill(*),ifailr(*) + integer(${ik}$), intent(in) :: ldh,ldvl,ldvr,mm,n logical(lk), intent(in) :: select(*) real(dp), intent(out) :: rwork(*) complex(dp), intent(in) :: h(ldh,*) complex(dp), intent(inout) :: vl(ldvl,*),vr(ldvr,*),w(*) complex(dp), intent(out) :: work(*) end subroutine zhsein -#else - module procedure stdlib_zhsein +#else + module procedure stdlib${ii}$_zhsein #endif - end interface hsein +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hsein +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hsein +#:endif +#:endfor +#:endfor + end interface hsein interface hseqr !! HSEQR computes the eigenvalues of a Hessenberg matrix H @@ -8220,110 +8163,113 @@ module stdlib_linalg_lapack !! matrix Q so that this routine can give the Schur factorization !! of a matrix A which has been reduced to the Hessenberg form H !! by the unitary matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine chseqr( job, compz, n, ilo, ihi, h, ldh, w, z, ldz,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihi,ilo,ldh,ldz,lwork,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihi,ilo,ldh,ldz,lwork,n + integer(${ik}$), intent(out) :: info character, intent(in) :: compz,job complex(sp), intent(inout) :: h(ldh,*),z(ldz,*) complex(sp), intent(out) :: w(*),work(*) end subroutine chseqr -#else - module procedure stdlib_chseqr +#else + module procedure stdlib${ii}$_chseqr #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dhseqr( job, compz, n, ilo, ihi, h, ldh, wr, wi, z,ldz, work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihi,ilo,ldh,ldz,lwork,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihi,ilo,ldh,ldz,lwork,n + integer(${ik}$), intent(out) :: info character, intent(in) :: compz,job real(dp), intent(inout) :: h(ldh,*),z(ldz,*) real(dp), intent(out) :: wi(*),work(*),wr(*) end subroutine dhseqr -#else - module procedure stdlib_dhseqr +#else + module procedure stdlib${ii}$_dhseqr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hseqr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine shseqr( job, compz, n, ilo, ihi, h, ldh, wr, wi, z,ldz, work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihi,ilo,ldh,ldz,lwork,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihi,ilo,ldh,ldz,lwork,n + integer(${ik}$), intent(out) :: info character, intent(in) :: compz,job real(sp), intent(inout) :: h(ldh,*),z(ldz,*) real(sp), intent(out) :: wi(*),work(*),wr(*) end subroutine shseqr -#else - module procedure stdlib_shseqr +#else + module procedure stdlib${ii}$_shseqr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$hseqr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zhseqr( job, compz, n, ilo, ihi, h, ldh, w, z, ldz,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihi,ilo,ldh,ldz,lwork,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihi,ilo,ldh,ldz,lwork,n + integer(${ik}$), intent(out) :: info character, intent(in) :: compz,job complex(dp), intent(inout) :: h(ldh,*),z(ldz,*) complex(dp), intent(out) :: w(*),work(*) end subroutine zhseqr -#else - module procedure stdlib_zhseqr +#else + module procedure stdlib${ii}$_zhseqr #endif - end interface hseqr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hseqr +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$hseqr +#:endif +#:endfor +#:endfor + end interface hseqr interface isnan !! ISNAN returns .TRUE. if its argument is NaN, and .FALSE. !! otherwise. To be replaced by the Fortran 2003 intrinsic in the !! future. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure logical(lk) function disnan( din ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: din end function disnan -#else - module procedure stdlib_disnan +#:if not 'ilp64' in ik +#else + module procedure stdlib${ii}$_disnan +#:endif +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure logical(lk) function sisnan( sin ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + real(sp), intent(in) :: sin + end function sisnan +#:if not 'ilp64' in ik +#else + module procedure stdlib${ii}$_sisnan +#:endif #endif +#:endfor #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] module procedure stdlib_${ri}$isnan - #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure logical(lk) function sisnan( sin ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - real(sp), intent(in) :: sin - end function sisnan -#else - module procedure stdlib_sisnan -#endif end interface isnan - - interface la_gbamv !! LA_GBAMV performs one of the matrix-vector operations !! y := alpha*abs(A)*abs(x) + beta*abs(y), @@ -8338,71 +8284,71 @@ module stdlib_linalg_lapack !! "symbolically" zero components are not perturbed. A zero !! entry is considered "symbolic" if all multiplications involved !! in computing that entry have at least one zero multiplicand. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cla_gbamv( trans, m, n, kl, ku, alpha, ab, ldab, x,incx, beta, y, incy ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(in) :: ab(ldab,*),x(*) real(sp), intent(inout) :: y(*) end subroutine cla_gbamv -#else - module procedure stdlib_cla_gbamv +#else + module procedure stdlib${ii}$_cla_gbamv #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dla_gbamv( trans, m, n, kl, ku, alpha, ab, ldab, x,incx, beta, y, incy ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha,beta,ab(ldab,*),x(*) - integer(ilp), intent(in) :: incx,incy,ldab,m,n,kl,ku,trans + integer(${ik}$), intent(in) :: incx,incy,ldab,m,n,kl,ku,trans real(dp), intent(inout) :: y(*) end subroutine dla_gbamv -#else - module procedure stdlib_dla_gbamv +#else + module procedure stdlib${ii}$_dla_gbamv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_gbamv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sla_gbamv( trans, m, n, kl, ku, alpha, ab, ldab, x,incx, beta, y, incy ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha,beta,ab(ldab,*),x(*) - integer(ilp), intent(in) :: incx,incy,ldab,m,n,kl,ku,trans + integer(${ik}$), intent(in) :: incx,incy,ldab,m,n,kl,ku,trans real(sp), intent(inout) :: y(*) end subroutine sla_gbamv -#else - module procedure stdlib_sla_gbamv +#else + module procedure stdlib${ii}$_sla_gbamv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_gbamv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zla_gbamv( trans, m, n, kl, ku, alpha, ab, ldab, x,incx, beta, y, incy ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), 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 complex(dp), intent(in) :: ab(ldab,*),x(*) real(dp), intent(inout) :: y(*) end subroutine zla_gbamv -#else - module procedure stdlib_zla_gbamv +#else + module procedure stdlib${ii}$_zla_gbamv #endif - end interface la_gbamv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_gbamv +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_gbamv +#:endif +#:endfor +#:endfor + end interface la_gbamv interface la_gbrcond !! LA_GBRCOND Estimates the Skeel condition number of op(A) * op2(C) @@ -8414,90 +8360,90 @@ module stdlib_linalg_lapack !! is computed by computing scaling factors R such that !! diag(R)*A*op2(C) is row equilibrated and computing the standard !! infinity-norm condition number. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function dla_gbrcond( trans, n, kl, ku, ab, ldab,afb, ldafb, ipiv, cmode, & c,info, work, iwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(in) :: n,ldab,ldafb,kl,ku,cmode,ipiv(*) - integer(ilp), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: n,ldab,ldafb,kl,ku,cmode,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) real(dp), intent(in) :: ab(ldab,*),afb(ldafb,*),c(*) real(dp), intent(out) :: work(*) end function dla_gbrcond -#else - module procedure stdlib_dla_gbrcond +#else + module procedure stdlib${ii}$_dla_gbrcond #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_gbrcond - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function sla_gbrcond( trans, n, kl, ku, ab, ldab, afb, ldafb,ipiv, cmode, & c, info, work, iwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(in) :: n,ldab,ldafb,kl,ku,cmode,ipiv(*) - integer(ilp), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: n,ldab,ldafb,kl,ku,cmode,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) real(sp), intent(in) :: ab(ldab,*),afb(ldafb,*),c(*) real(sp), intent(out) :: work(*) end function sla_gbrcond -#else - module procedure stdlib_sla_gbrcond +#else + module procedure stdlib${ii}$_sla_gbrcond #endif - end interface la_gbrcond - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_gbrcond +#:endif +#:endfor +#:endfor + end interface la_gbrcond interface la_gbrcond_c !! LA_GBRCOND_C Computes the infinity norm condition number of !! op(A) * inv(diag(C)) where C is a REAL vector. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function cla_gbrcond_c( trans, n, kl, ku, ab, ldab, afb,ldafb, ipiv, c, & capply, info, work,rwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans logical(lk), intent(in) :: capply - integer(ilp), intent(in) :: n,kl,ku,ldab,ldafb,ipiv(*) - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n,kl,ku,ldab,ldafb,ipiv(*) + integer(${ik}$), intent(out) :: info complex(sp), intent(in) :: ab(ldab,*),afb(ldafb,*) complex(sp), intent(out) :: work(*) real(sp), intent(in) :: c(*) real(sp), intent(out) :: rwork(*) end function cla_gbrcond_c -#else - module procedure stdlib_cla_gbrcond_c +#else + module procedure stdlib${ii}$_cla_gbrcond_c #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_gbrcond_c - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function zla_gbrcond_c( trans, n, kl, ku, ab,ldab, afb, ldafb, ipiv,c, & capply, info, work,rwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans logical(lk), intent(in) :: capply - integer(ilp), intent(in) :: n,kl,ku,ldab,ldafb,ipiv(*) - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n,kl,ku,ldab,ldafb,ipiv(*) + integer(${ik}$), intent(out) :: info complex(dp), intent(in) :: ab(ldab,*),afb(ldafb,*) complex(dp), intent(out) :: work(*) real(dp), intent(in) :: c(*) real(dp), intent(out) :: rwork(*) end function zla_gbrcond_c -#else - module procedure stdlib_zla_gbrcond_c +#else + module procedure stdlib${ii}$_zla_gbrcond_c #endif - end interface la_gbrcond_c - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_gbrcond_c +#:endif +#:endfor +#:endfor + end interface la_gbrcond_c interface la_gbrpvgrw !! LA_GBRPVGRW computes the reciprocal pivot growth factor @@ -8506,66 +8452,66 @@ module stdlib_linalg_lapack !! (equilibrated) matrix A could be poor. This also means that the !! solution X, estimated condition numbers, and error bounds could be !! unreliable. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure real(sp) function cla_gbrpvgrw( n, kl, ku, ncols, ab, ldab, afb,ldafb ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: n,kl,ku,ncols,ldab,ldafb + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: n,kl,ku,ncols,ldab,ldafb complex(sp), intent(in) :: ab(ldab,*),afb(ldafb,*) end function cla_gbrpvgrw -#else - module procedure stdlib_cla_gbrpvgrw +#else + module procedure stdlib${ii}$_cla_gbrpvgrw #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure real(dp) function dla_gbrpvgrw( n, kl, ku, ncols, ab,ldab, afb, ldafb ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: n,kl,ku,ncols,ldab,ldafb + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: n,kl,ku,ncols,ldab,ldafb real(dp), intent(in) :: ab(ldab,*),afb(ldafb,*) end function dla_gbrpvgrw -#else - module procedure stdlib_dla_gbrpvgrw +#else + module procedure stdlib${ii}$_dla_gbrpvgrw +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure real(sp) function sla_gbrpvgrw( n, kl, ku, ncols, ab, ldab, afb,ldafb ) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: n,kl,ku,ncols,ldab,ldafb + real(sp), intent(in) :: ab(ldab,*),afb(ldafb,*) + end function sla_gbrpvgrw +#else + module procedure stdlib${ii}$_sla_gbrpvgrw +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure real(dp) function zla_gbrpvgrw( n, kl, ku, ncols, ab,ldab, afb, ldafb ) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: n,kl,ku,ncols,ldab,ldafb + complex(dp), intent(in) :: ab(ldab,*),afb(ldafb,*) + end function zla_gbrpvgrw +#else + module procedure stdlib${ii}$_zla_gbrpvgrw #endif #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_gbrpvgrw + module procedure stdlib${ii}$_${ri}$la_gbrpvgrw #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure real(sp) function sla_gbrpvgrw( n, kl, ku, ncols, ab, ldab, afb,ldafb ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: n,kl,ku,ncols,ldab,ldafb - real(sp), intent(in) :: ab(ldab,*),afb(ldafb,*) - end function sla_gbrpvgrw -#else - module procedure stdlib_sla_gbrpvgrw -#endif #:for rk,rt,ri in CMPLX_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_gbrpvgrw + module procedure stdlib${ii}$_${ri}$la_gbrpvgrw #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure real(dp) function zla_gbrpvgrw( n, kl, ku, ncols, ab,ldab, afb, ldafb ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: n,kl,ku,ncols,ldab,ldafb - complex(dp), intent(in) :: ab(ldab,*),afb(ldafb,*) - end function zla_gbrpvgrw -#else - module procedure stdlib_zla_gbrpvgrw -#endif +#:endfor end interface la_gbrpvgrw - - interface la_geamv !! LA_GEAMV performs one of the matrix-vector operations !! y := alpha*abs(A)*abs(x) + beta*abs(y), @@ -8580,67 +8526,67 @@ module stdlib_linalg_lapack !! "symbolically" zero components are not perturbed. A zero !! entry is considered "symbolic" if all multiplications involved !! in computing that entry have at least one zero multiplicand. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cla_geamv( trans, m, n, alpha, a, lda, x, incx, beta,y, incy ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha,beta - integer(ilp), intent(in) :: incx,incy,lda,m,n,trans + integer(${ik}$), intent(in) :: incx,incy,lda,m,n,trans complex(sp), intent(in) :: a(lda,*),x(*) real(sp), intent(inout) :: y(*) end subroutine cla_geamv -#else - module procedure stdlib_cla_geamv +#else + module procedure stdlib${ii}$_cla_geamv #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dla_geamv ( trans, m, n, alpha, a, lda, x, incx, beta,y, incy ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha,beta,a(lda,*),x(*) - integer(ilp), intent(in) :: incx,incy,lda,m,n,trans + integer(${ik}$), intent(in) :: incx,incy,lda,m,n,trans real(dp), intent(inout) :: y(*) end subroutine dla_geamv -#else - module procedure stdlib_dla_geamv +#else + module procedure stdlib${ii}$_dla_geamv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_geamv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sla_geamv( trans, m, n, alpha, a, lda, x, incx, beta,y, incy ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha,beta,a(lda,*),x(*) - integer(ilp), intent(in) :: incx,incy,lda,m,n,trans + integer(${ik}$), intent(in) :: incx,incy,lda,m,n,trans real(sp), intent(inout) :: y(*) end subroutine sla_geamv -#else - module procedure stdlib_sla_geamv +#else + module procedure stdlib${ii}$_sla_geamv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_geamv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zla_geamv( trans, m, n, alpha, a, lda, x, incx, beta,y, incy ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha,beta - integer(ilp), intent(in) :: incx,incy,lda,m,n,trans + integer(${ik}$), intent(in) :: incx,incy,lda,m,n,trans complex(dp), intent(in) :: a(lda,*),x(*) real(dp), intent(inout) :: y(*) end subroutine zla_geamv -#else - module procedure stdlib_zla_geamv +#else + module procedure stdlib${ii}$_zla_geamv #endif - end interface la_geamv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_geamv +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_geamv +#:endif +#:endfor +#:endfor + end interface la_geamv interface la_gercond !! LA_GERCOND estimates the Skeel condition number of op(A) * op2(C) @@ -8652,90 +8598,90 @@ module stdlib_linalg_lapack !! is computed by computing scaling factors R such that !! diag(R)*A*op2(C) is row equilibrated and computing the standard !! infinity-norm condition number. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function dla_gercond( trans, n, a, lda, af,ldaf, ipiv, cmode, c,info, & work, iwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(in) :: n,lda,ldaf,cmode,ipiv(*) - integer(ilp), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: n,lda,ldaf,cmode,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) real(dp), intent(in) :: a(lda,*),af(ldaf,*),c(*) real(dp), intent(out) :: work(*) end function dla_gercond -#else - module procedure stdlib_dla_gercond +#else + module procedure stdlib${ii}$_dla_gercond #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_gercond - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function sla_gercond( trans, n, a, lda, af, ldaf, ipiv,cmode, c, info, & work, iwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(in) :: n,lda,ldaf,cmode,ipiv(*) - integer(ilp), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: n,lda,ldaf,cmode,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) real(sp), intent(in) :: a(lda,*),af(ldaf,*),c(*) real(sp), intent(out) :: work(*) end function sla_gercond -#else - module procedure stdlib_sla_gercond +#else + module procedure stdlib${ii}$_sla_gercond #endif - end interface la_gercond - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_gercond +#:endif +#:endfor +#:endfor + end interface la_gercond interface la_gercond_c !! LA_GERCOND_C computes the infinity norm condition number of !! op(A) * inv(diag(C)) where C is a REAL vector. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function cla_gercond_c( trans, n, a, lda, af, ldaf, ipiv, c,capply, info, & work, rwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans logical(lk), intent(in) :: capply - integer(ilp), intent(in) :: n,lda,ldaf,ipiv(*) - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n,lda,ldaf,ipiv(*) + integer(${ik}$), intent(out) :: info complex(sp), intent(in) :: a(lda,*),af(ldaf,*) complex(sp), intent(out) :: work(*) real(sp), intent(in) :: c(*) real(sp), intent(out) :: rwork(*) end function cla_gercond_c -#else - module procedure stdlib_cla_gercond_c +#else + module procedure stdlib${ii}$_cla_gercond_c #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_gercond_c - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function zla_gercond_c( trans, n, a, lda, af,ldaf, ipiv, c, capply,info, & work, rwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans logical(lk), intent(in) :: capply - integer(ilp), intent(in) :: n,lda,ldaf,ipiv(*) - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n,lda,ldaf,ipiv(*) + integer(${ik}$), intent(out) :: info complex(dp), intent(in) :: a(lda,*),af(ldaf,*) complex(dp), intent(out) :: work(*) real(dp), intent(in) :: c(*) real(dp), intent(out) :: rwork(*) end function zla_gercond_c -#else - module procedure stdlib_zla_gercond_c +#else + module procedure stdlib${ii}$_zla_gercond_c #endif - end interface la_gercond_c - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_gercond_c +#:endif +#:endfor +#:endfor + end interface la_gercond_c interface la_gerpvgrw !! LA_GERPVGRW computes the reciprocal pivot growth factor @@ -8744,62 +8690,62 @@ module stdlib_linalg_lapack !! (equilibrated) matrix A could be poor. This also means that the !! solution X, estimated condition numbers, and error bounds could be !! unreliable. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure real(sp) function cla_gerpvgrw( n, ncols, a, lda, af, ldaf ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: n,ncols,lda,ldaf + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: n,ncols,lda,ldaf complex(sp), intent(in) :: a(lda,*),af(ldaf,*) end function cla_gerpvgrw -#else - module procedure stdlib_cla_gerpvgrw +#else + module procedure stdlib${ii}$_cla_gerpvgrw #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure real(dp) function dla_gerpvgrw( n, ncols, a, lda, af,ldaf ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: n,ncols,lda,ldaf + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: n,ncols,lda,ldaf real(dp), intent(in) :: a(lda,*),af(ldaf,*) end function dla_gerpvgrw -#else - module procedure stdlib_dla_gerpvgrw +#else + module procedure stdlib${ii}$_dla_gerpvgrw +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure real(sp) function sla_gerpvgrw( n, ncols, a, lda, af, ldaf ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: n,ncols,lda,ldaf + real(sp), intent(in) :: a(lda,*),af(ldaf,*) + end function sla_gerpvgrw +#else + module procedure stdlib${ii}$_sla_gerpvgrw +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure real(dp) function zla_gerpvgrw( n, ncols, a, lda, af,ldaf ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: n,ncols,lda,ldaf + complex(dp), intent(in) :: a(lda,*),af(ldaf,*) + end function zla_gerpvgrw +#else + module procedure stdlib${ii}$_zla_gerpvgrw #endif #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_gerpvgrw + module procedure stdlib${ii}$_${ri}$la_gerpvgrw #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure real(sp) function sla_gerpvgrw( n, ncols, a, lda, af, ldaf ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: n,ncols,lda,ldaf - real(sp), intent(in) :: a(lda,*),af(ldaf,*) - end function sla_gerpvgrw -#else - module procedure stdlib_sla_gerpvgrw -#endif #:for rk,rt,ri in CMPLX_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_gerpvgrw + module procedure stdlib${ii}$_${ri}$la_gerpvgrw #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure real(dp) function zla_gerpvgrw( n, ncols, a, lda, af,ldaf ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: n,ncols,lda,ldaf - complex(dp), intent(in) :: a(lda,*),af(ldaf,*) - end function zla_gerpvgrw -#else - module procedure stdlib_zla_gerpvgrw -#endif +#:endfor end interface la_gerpvgrw - - interface la_heamv !! CLA_SYAMV performs the matrix-vector operation !! y := alpha*abs(A)*abs(x) + beta*abs(y), @@ -8813,86 +8759,86 @@ module stdlib_linalg_lapack !! "symbolically" zero components are not perturbed. A zero !! entry is considered "symbolic" if all multiplications involved !! in computing that entry have at least one zero multiplicand. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cla_heamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha,beta - integer(ilp), intent(in) :: incx,incy,lda,n,uplo + integer(${ik}$), intent(in) :: incx,incy,lda,n,uplo complex(sp), intent(in) :: a(lda,*),x(*) real(sp), intent(inout) :: y(*) end subroutine cla_heamv -#else - module procedure stdlib_cla_heamv +#else + module procedure stdlib${ii}$_cla_heamv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_heamv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zla_heamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha,beta - integer(ilp), intent(in) :: incx,incy,lda,n,uplo + integer(${ik}$), intent(in) :: incx,incy,lda,n,uplo complex(dp), intent(in) :: a(lda,*),x(*) real(dp), intent(inout) :: y(*) end subroutine zla_heamv -#else - module procedure stdlib_zla_heamv +#else + module procedure stdlib${ii}$_zla_heamv #endif - end interface la_heamv - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_heamv +#:endif +#:endfor +#:endfor + end interface la_heamv interface la_hercond_c !! LA_HERCOND_C computes the infinity norm condition number of !! op(A) * inv(diag(C)) where C is a REAL vector. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function cla_hercond_c( uplo, n, a, lda, af, ldaf, ipiv, c,capply, info, & work, rwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo logical(lk), intent(in) :: capply - integer(ilp), intent(in) :: n,lda,ldaf,ipiv(*) - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n,lda,ldaf,ipiv(*) + integer(${ik}$), intent(out) :: info complex(sp), intent(in) :: a(lda,*),af(ldaf,*) complex(sp), intent(out) :: work(*) real(sp), intent(in) :: c(*) real(sp), intent(out) :: rwork(*) end function cla_hercond_c -#else - module procedure stdlib_cla_hercond_c +#else + module procedure stdlib${ii}$_cla_hercond_c #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_hercond_c - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function zla_hercond_c( uplo, n, a, lda, af,ldaf, ipiv, c, capply,info, & work, rwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo logical(lk), intent(in) :: capply - integer(ilp), intent(in) :: n,lda,ldaf,ipiv(*) - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n,lda,ldaf,ipiv(*) + integer(${ik}$), intent(out) :: info complex(dp), intent(in) :: a(lda,*),af(ldaf,*) complex(dp), intent(out) :: work(*) real(dp), intent(in) :: c(*) real(dp), intent(out) :: rwork(*) end function zla_hercond_c -#else - module procedure stdlib_zla_hercond_c +#else + module procedure stdlib${ii}$_zla_hercond_c #endif - end interface la_hercond_c - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_hercond_c +#:endif +#:endfor +#:endfor + end interface la_hercond_c interface la_herpvgrw !! LA_HERPVGRW computes the reciprocal pivot growth factor @@ -8901,41 +8847,41 @@ module stdlib_linalg_lapack !! (equilibrated) matrix A could be poor. This also means that the !! solution X, estimated condition numbers, and error bounds could be !! unreliable. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function cla_herpvgrw( uplo, n, info, a, lda, af, ldaf, ipiv,work ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: n,info,lda,ldaf,ipiv(*) + integer(${ik}$), intent(in) :: n,info,lda,ldaf,ipiv(*) complex(sp), intent(in) :: a(lda,*),af(ldaf,*) real(sp), intent(out) :: work(*) end function cla_herpvgrw -#else - module procedure stdlib_cla_herpvgrw +#else + module procedure stdlib${ii}$_cla_herpvgrw #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_herpvgrw - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function zla_herpvgrw( uplo, n, info, a, lda, af,ldaf, ipiv, work ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: n,info,lda,ldaf,ipiv(*) + integer(${ik}$), intent(in) :: n,info,lda,ldaf,ipiv(*) complex(dp), intent(in) :: a(lda,*),af(ldaf,*) real(dp), intent(out) :: work(*) end function zla_herpvgrw -#else - module procedure stdlib_zla_herpvgrw +#else + module procedure stdlib${ii}$_zla_herpvgrw #endif - end interface la_herpvgrw - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_herpvgrw +#:endif +#:endfor +#:endfor + end interface la_herpvgrw interface la_lin_berr !! LA_LIN_BERR computes componentwise relative backward error from @@ -8943,67 +8889,67 @@ module stdlib_linalg_lapack !! max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) !! where abs(Z) is the componentwise absolute value of the matrix !! or vector Z. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cla_lin_berr( n, nz, nrhs, res, ayb, berr ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: n,nz,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: n,nz,nrhs real(sp), intent(in) :: ayb(n,nrhs) real(sp), intent(out) :: berr(nrhs) complex(sp), intent(in) :: res(n,nrhs) end subroutine cla_lin_berr -#else - module procedure stdlib_cla_lin_berr +#else + module procedure stdlib${ii}$_cla_lin_berr #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dla_lin_berr ( n, nz, nrhs, res, ayb, berr ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: n,nz,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: n,nz,nrhs real(dp), intent(in) :: ayb(n,nrhs),res(n,nrhs) real(dp), intent(out) :: berr(nrhs) end subroutine dla_lin_berr -#else - module procedure stdlib_dla_lin_berr +#else + module procedure stdlib${ii}$_dla_lin_berr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_lin_berr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sla_lin_berr( n, nz, nrhs, res, ayb, berr ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: n,nz,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: n,nz,nrhs real(sp), intent(in) :: ayb(n,nrhs),res(n,nrhs) real(sp), intent(out) :: berr(nrhs) end subroutine sla_lin_berr -#else - module procedure stdlib_sla_lin_berr +#else + module procedure stdlib${ii}$_sla_lin_berr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_lin_berr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zla_lin_berr( n, nz, nrhs, res, ayb, berr ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: n,nz,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: n,nz,nrhs real(dp), intent(in) :: ayb(n,nrhs) real(dp), intent(out) :: berr(nrhs) complex(dp), intent(in) :: res(n,nrhs) end subroutine zla_lin_berr -#else - module procedure stdlib_zla_lin_berr +#else + module procedure stdlib${ii}$_zla_lin_berr #endif - end interface la_lin_berr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_lin_berr +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_lin_berr +#:endif +#:endfor +#:endfor + end interface la_lin_berr interface la_porcond !! LA_PORCOND Estimates the Skeel condition number of op(A) * op2(C) @@ -9015,90 +8961,90 @@ module stdlib_linalg_lapack !! is computed by computing scaling factors R such that !! diag(R)*A*op2(C) is row equilibrated and computing the standard !! infinity-norm condition number. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function dla_porcond( uplo, n, a, lda, af, ldaf,cmode, c, info, work,& iwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: n,lda,ldaf,cmode - integer(ilp), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: n,lda,ldaf,cmode + integer(${ik}$), intent(out) :: info,iwork(*) real(dp), intent(in) :: a(lda,*),af(ldaf,*),c(*) real(dp), intent(out) :: work(*) end function dla_porcond -#else - module procedure stdlib_dla_porcond +#else + module procedure stdlib${ii}$_dla_porcond #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_porcond - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function sla_porcond( uplo, n, a, lda, af, ldaf, cmode, c,info, work, & iwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: n,lda,ldaf,cmode - integer(ilp), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: n,lda,ldaf,cmode + integer(${ik}$), intent(out) :: info,iwork(*) real(sp), intent(in) :: a(lda,*),af(ldaf,*),c(*) real(sp), intent(out) :: work(*) end function sla_porcond -#else - module procedure stdlib_sla_porcond +#else + module procedure stdlib${ii}$_sla_porcond #endif - end interface la_porcond - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_porcond +#:endif +#:endfor +#:endfor + end interface la_porcond interface la_porcond_c !! LA_PORCOND_C Computes the infinity norm condition number of !! op(A) * inv(diag(C)) where C is a REAL vector -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function cla_porcond_c( uplo, n, a, lda, af, ldaf, c, capply,info, work, & rwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo logical(lk), intent(in) :: capply - integer(ilp), intent(in) :: n,lda,ldaf - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n,lda,ldaf + integer(${ik}$), intent(out) :: info complex(sp), intent(in) :: a(lda,*),af(ldaf,*) complex(sp), intent(out) :: work(*) real(sp), intent(in) :: c(*) real(sp), intent(out) :: rwork(*) end function cla_porcond_c -#else - module procedure stdlib_cla_porcond_c +#else + module procedure stdlib${ii}$_cla_porcond_c #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_porcond_c - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function zla_porcond_c( uplo, n, a, lda, af,ldaf, c, capply, info,work, & rwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo logical(lk), intent(in) :: capply - integer(ilp), intent(in) :: n,lda,ldaf - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n,lda,ldaf + integer(${ik}$), intent(out) :: info complex(dp), intent(in) :: a(lda,*),af(ldaf,*) complex(dp), intent(out) :: work(*) real(dp), intent(in) :: c(*) real(dp), intent(out) :: rwork(*) end function zla_porcond_c -#else - module procedure stdlib_zla_porcond_c +#else + module procedure stdlib${ii}$_zla_porcond_c #endif - end interface la_porcond_c - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_porcond_c +#:endif +#:endfor +#:endfor + end interface la_porcond_c interface la_porpvgrw !! LA_PORPVGRW computes the reciprocal pivot growth factor @@ -9107,69 +9053,69 @@ module stdlib_linalg_lapack !! (equilibrated) matrix A could be poor. This also means that the !! solution X, estimated condition numbers, and error bounds could be !! unreliable. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function cla_porpvgrw( uplo, ncols, a, lda, af, ldaf, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: ncols,lda,ldaf + integer(${ik}$), intent(in) :: ncols,lda,ldaf complex(sp), intent(in) :: a(lda,*),af(ldaf,*) real(sp), intent(out) :: work(*) end function cla_porpvgrw -#else - module procedure stdlib_cla_porpvgrw +#else + module procedure stdlib${ii}$_cla_porpvgrw #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function dla_porpvgrw( uplo, ncols, a, lda, af,ldaf, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: ncols,lda,ldaf + integer(${ik}$), intent(in) :: ncols,lda,ldaf real(dp), intent(in) :: a(lda,*),af(ldaf,*) real(dp), intent(out) :: work(*) end function dla_porpvgrw -#else - module procedure stdlib_dla_porpvgrw +#else + module procedure stdlib${ii}$_dla_porpvgrw #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_porpvgrw - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function sla_porpvgrw( uplo, ncols, a, lda, af, ldaf, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: ncols,lda,ldaf + integer(${ik}$), intent(in) :: ncols,lda,ldaf real(sp), intent(in) :: a(lda,*),af(ldaf,*) real(sp), intent(out) :: work(*) end function sla_porpvgrw -#else - module procedure stdlib_sla_porpvgrw +#else + module procedure stdlib${ii}$_sla_porpvgrw #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_porpvgrw - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function zla_porpvgrw( uplo, ncols, a, lda, af,ldaf, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: ncols,lda,ldaf + integer(${ik}$), intent(in) :: ncols,lda,ldaf complex(dp), intent(in) :: a(lda,*),af(ldaf,*) real(dp), intent(out) :: work(*) end function zla_porpvgrw -#else - module procedure stdlib_zla_porpvgrw +#else + module procedure stdlib${ii}$_zla_porpvgrw #endif - end interface la_porpvgrw +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_porpvgrw +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_porpvgrw +#:endif +#:endfor +#:endfor + end interface la_porpvgrw interface la_syamv !! LA_SYAMV performs the matrix-vector operation @@ -9184,67 +9130,67 @@ module stdlib_linalg_lapack !! "symbolically" zero components are not perturbed. A zero !! entry is considered "symbolic" if all multiplications involved !! in computing that entry have at least one zero multiplicand. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cla_syamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha,beta - integer(ilp), intent(in) :: incx,incy,lda,n,uplo + integer(${ik}$), intent(in) :: incx,incy,lda,n,uplo complex(sp), intent(in) :: a(lda,*),x(*) real(sp), intent(inout) :: y(*) end subroutine cla_syamv -#else - module procedure stdlib_cla_syamv +#else + module procedure stdlib${ii}$_cla_syamv #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dla_syamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha,beta,a(lda,*),x(*) - integer(ilp), intent(in) :: incx,incy,lda,n,uplo + integer(${ik}$), intent(in) :: incx,incy,lda,n,uplo real(dp), intent(inout) :: y(*) end subroutine dla_syamv -#else - module procedure stdlib_dla_syamv +#else + module procedure stdlib${ii}$_dla_syamv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_syamv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sla_syamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha,beta,a(lda,*),x(*) - integer(ilp), intent(in) :: incx,incy,lda,n,uplo + integer(${ik}$), intent(in) :: incx,incy,lda,n,uplo real(sp), intent(inout) :: y(*) end subroutine sla_syamv -#else - module procedure stdlib_sla_syamv +#else + module procedure stdlib${ii}$_sla_syamv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_syamv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zla_syamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha,beta - integer(ilp), intent(in) :: incx,incy,lda,n,uplo + integer(${ik}$), intent(in) :: incx,incy,lda,n,uplo complex(dp), intent(in) :: a(lda,*),x(*) real(dp), intent(inout) :: y(*) end subroutine zla_syamv -#else - module procedure stdlib_zla_syamv +#else + module procedure stdlib${ii}$_zla_syamv #endif - end interface la_syamv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_syamv +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_syamv +#:endif +#:endfor +#:endfor + end interface la_syamv interface la_syrcond !! LA_SYRCOND estimates the Skeel condition number of op(A) * op2(C) @@ -9256,90 +9202,90 @@ module stdlib_linalg_lapack !! is computed by computing scaling factors R such that !! diag(R)*A*op2(C) is row equilibrated and computing the standard !! infinity-norm condition number. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function dla_syrcond( uplo, n, a, lda, af, ldaf,ipiv, cmode, c, info, & work,iwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: n,lda,ldaf,cmode,ipiv(*) - integer(ilp), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: n,lda,ldaf,cmode,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) real(dp), intent(in) :: a(lda,*),af(ldaf,*),c(*) real(dp), intent(out) :: work(*) end function dla_syrcond -#else - module procedure stdlib_dla_syrcond +#else + module procedure stdlib${ii}$_dla_syrcond #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_syrcond - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function sla_syrcond( uplo, n, a, lda, af, ldaf, ipiv, cmode,c, info, & work, iwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: n,lda,ldaf,cmode,ipiv(*) - integer(ilp), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: n,lda,ldaf,cmode,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) real(sp), intent(in) :: a(lda,*),af(ldaf,*),c(*) real(sp), intent(out) :: work(*) end function sla_syrcond -#else - module procedure stdlib_sla_syrcond +#else + module procedure stdlib${ii}$_sla_syrcond #endif - end interface la_syrcond - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_syrcond +#:endif +#:endfor +#:endfor + end interface la_syrcond interface la_syrcond_c !! LA_SYRCOND_C Computes the infinity norm condition number of !! op(A) * inv(diag(C)) where C is a REAL vector. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function cla_syrcond_c( uplo, n, a, lda, af, ldaf, ipiv, c,capply, info, & work, rwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo logical(lk), intent(in) :: capply - integer(ilp), intent(in) :: n,lda,ldaf,ipiv(*) - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n,lda,ldaf,ipiv(*) + integer(${ik}$), intent(out) :: info complex(sp), intent(in) :: a(lda,*),af(ldaf,*) complex(sp), intent(out) :: work(*) real(sp), intent(in) :: c(*) real(sp), intent(out) :: rwork(*) end function cla_syrcond_c -#else - module procedure stdlib_cla_syrcond_c +#else + module procedure stdlib${ii}$_cla_syrcond_c #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_syrcond_c - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function zla_syrcond_c( uplo, n, a, lda, af,ldaf, ipiv, c, capply,info, & work, rwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo logical(lk), intent(in) :: capply - integer(ilp), intent(in) :: n,lda,ldaf,ipiv(*) - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n,lda,ldaf,ipiv(*) + integer(${ik}$), intent(out) :: info complex(dp), intent(in) :: a(lda,*),af(ldaf,*) complex(dp), intent(out) :: work(*) real(dp), intent(in) :: c(*) real(dp), intent(out) :: rwork(*) end function zla_syrcond_c -#else - module procedure stdlib_zla_syrcond_c +#else + module procedure stdlib${ii}$_zla_syrcond_c #endif - end interface la_syrcond_c - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_syrcond_c +#:endif +#:endfor +#:endfor + end interface la_syrcond_c interface la_syrpvgrw !! LA_SYRPVGRW computes the reciprocal pivot growth factor @@ -9348,137 +9294,137 @@ module stdlib_linalg_lapack !! (equilibrated) matrix A could be poor. This also means that the !! solution X, estimated condition numbers, and error bounds could be !! unreliable. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function cla_syrpvgrw( uplo, n, info, a, lda, af, ldaf, ipiv,work ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: n,info,lda,ldaf,ipiv(*) + integer(${ik}$), intent(in) :: n,info,lda,ldaf,ipiv(*) complex(sp), intent(in) :: a(lda,*),af(ldaf,*) real(sp), intent(out) :: work(*) end function cla_syrpvgrw -#else - module procedure stdlib_cla_syrpvgrw +#else + module procedure stdlib${ii}$_cla_syrpvgrw #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function dla_syrpvgrw( uplo, n, info, a, lda, af,ldaf, ipiv, work ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: n,info,lda,ldaf,ipiv(*) + integer(${ik}$), intent(in) :: n,info,lda,ldaf,ipiv(*) real(dp), intent(in) :: a(lda,*),af(ldaf,*) real(dp), intent(out) :: work(*) end function dla_syrpvgrw -#else - module procedure stdlib_dla_syrpvgrw +#else + module procedure stdlib${ii}$_dla_syrpvgrw #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_syrpvgrw - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function sla_syrpvgrw( uplo, n, info, a, lda, af, ldaf, ipiv,work ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: n,info,lda,ldaf,ipiv(*) + integer(${ik}$), intent(in) :: n,info,lda,ldaf,ipiv(*) real(sp), intent(in) :: a(lda,*),af(ldaf,*) real(sp), intent(out) :: work(*) end function sla_syrpvgrw -#else - module procedure stdlib_sla_syrpvgrw +#else + module procedure stdlib${ii}$_sla_syrpvgrw #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_syrpvgrw - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function zla_syrpvgrw( uplo, n, info, a, lda, af,ldaf, ipiv, work ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: n,info,lda,ldaf,ipiv(*) + integer(${ik}$), intent(in) :: n,info,lda,ldaf,ipiv(*) complex(dp), intent(in) :: a(lda,*),af(ldaf,*) real(dp), intent(out) :: work(*) end function zla_syrpvgrw -#else - module procedure stdlib_zla_syrpvgrw +#else + module procedure stdlib${ii}$_zla_syrpvgrw #endif - end interface la_syrpvgrw +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_syrpvgrw +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_syrpvgrw +#:endif +#:endfor +#:endfor + end interface la_syrpvgrw interface la_wwaddw !! LA_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. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cla_wwaddw( n, x, y, w ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: n complex(sp), intent(inout) :: x(*),y(*) complex(sp), intent(in) :: w(*) end subroutine cla_wwaddw -#else - module procedure stdlib_cla_wwaddw +#else + module procedure stdlib${ii}$_cla_wwaddw #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dla_wwaddw( n, x, y, w ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: n real(dp), intent(inout) :: x(*),y(*) real(dp), intent(in) :: w(*) end subroutine dla_wwaddw -#else - module procedure stdlib_dla_wwaddw +#else + module procedure stdlib${ii}$_dla_wwaddw #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_wwaddw - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sla_wwaddw( n, x, y, w ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: n real(sp), intent(inout) :: x(*),y(*) real(sp), intent(in) :: w(*) end subroutine sla_wwaddw -#else - module procedure stdlib_sla_wwaddw +#else + module procedure stdlib${ii}$_sla_wwaddw #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$la_wwaddw - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zla_wwaddw( n, x, y, w ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: n complex(dp), intent(inout) :: x(*),y(*) complex(dp), intent(in) :: w(*) end subroutine zla_wwaddw -#else - module procedure stdlib_zla_wwaddw +#else + module procedure stdlib${ii}$_zla_wwaddw #endif - end interface la_wwaddw +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_wwaddw +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$la_wwaddw +#:endif +#:endfor +#:endfor + end interface la_wwaddw interface labad !! LABAD takes as input the values computed by DLAMCH for underflow and @@ -9489,34 +9435,37 @@ module stdlib_linalg_lapack !! the values computed by DLAMCH. This subroutine is needed because !! DLAMCH does not compensate for poor arithmetic in the upper half of !! the exponent range, as is found on a Cray. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlabad( small, large ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(inout) :: large,small end subroutine dlabad -#else - module procedure stdlib_dlabad +#:if not 'ilp64' in ik +#else + module procedure stdlib${ii}$_dlabad +#:endif +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine slabad( small, large ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + real(sp), intent(inout) :: large,small + end subroutine slabad +#:if not 'ilp64' in ik +#else + module procedure stdlib${ii}$_slabad +#:endif #endif +#:endfor #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] module procedure stdlib_${ri}$labad - #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine slabad( small, large ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - real(sp), intent(inout) :: large,small - end subroutine slabad -#else - module procedure stdlib_slabad -#endif end interface labad - - interface labrd !! LABRD reduces the first NB rows and columns of a complex general !! m by n matrix A to upper or lower real bidiagonal form by a unitary @@ -9525,348 +9474,351 @@ module stdlib_linalg_lapack !! If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower !! bidiagonal form. !! This is an auxiliary routine called by CGEBRD -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clabrd( m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y,ldy ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: lda,ldx,ldy,m,n,nb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: lda,ldx,ldy,m,n,nb real(sp), intent(out) :: d(*),e(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: taup(*),tauq(*),x(ldx,*),y(ldy,*) end subroutine clabrd -#else - module procedure stdlib_clabrd +#else + module procedure stdlib${ii}$_clabrd #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlabrd( m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y,ldy ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: lda,ldx,ldy,m,n,nb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: lda,ldx,ldy,m,n,nb real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: d(*),e(*),taup(*),tauq(*),x(ldx,*),y(ldy,*) end subroutine dlabrd -#else - module procedure stdlib_dlabrd +#else + module procedure stdlib${ii}$_dlabrd #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$labrd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slabrd( m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y,ldy ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: lda,ldx,ldy,m,n,nb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: lda,ldx,ldy,m,n,nb real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: d(*),e(*),taup(*),tauq(*),x(ldx,*),y(ldy,*) end subroutine slabrd -#else - module procedure stdlib_slabrd +#else + module procedure stdlib${ii}$_slabrd #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$labrd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlabrd( m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y,ldy ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: lda,ldx,ldy,m,n,nb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: lda,ldx,ldy,m,n,nb real(dp), intent(out) :: d(*),e(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: taup(*),tauq(*),x(ldx,*),y(ldy,*) end subroutine zlabrd -#else - module procedure stdlib_zlabrd +#else + module procedure stdlib${ii}$_zlabrd #endif - end interface labrd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$labrd +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$labrd +#:endif +#:endfor +#:endfor + end interface labrd interface lacgv !! LACGV conjugates a complex vector of length N. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clacgv( n, x, incx ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n complex(sp), intent(inout) :: x(*) end subroutine clacgv -#else - module procedure stdlib_clacgv +#else + module procedure stdlib${ii}$_clacgv +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine zlacgv( n, x, incx ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n + complex(dp), intent(inout) :: x(*) + end subroutine zlacgv +#else + module procedure stdlib${ii}$_zlacgv #endif #:for rk,rt,ri in CMPLX_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lacgv + module procedure stdlib${ii}$_${ri}$lacgv #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine zlacgv( n, x, incx ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n - complex(dp), intent(inout) :: x(*) - end subroutine zlacgv -#else - module procedure stdlib_zlacgv -#endif +#:endfor end interface lacgv - - interface lacon !! LACON estimates the 1-norm of a square, complex matrix A. !! Reverse communication is used for evaluating matrix-vector products. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine clacon( n, v, x, est, kase ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(inout) :: kase - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(inout) :: kase + integer(${ik}$), intent(in) :: n real(sp), intent(inout) :: est complex(sp), intent(out) :: v(n) complex(sp), intent(inout) :: x(n) end subroutine clacon -#else - module procedure stdlib_clacon +#else + module procedure stdlib${ii}$_clacon #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dlacon( n, v, x, isgn, est, kase ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(inout) :: kase - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(inout) :: kase + integer(${ik}$), intent(in) :: n real(dp), intent(inout) :: est,x(*) - integer(ilp), intent(out) :: isgn(*) + integer(${ik}$), intent(out) :: isgn(*) real(dp), intent(out) :: v(*) end subroutine dlacon -#else - module procedure stdlib_dlacon +#else + module procedure stdlib${ii}$_dlacon #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lacon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine slacon( n, v, x, isgn, est, kase ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(inout) :: kase - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(inout) :: kase + integer(${ik}$), intent(in) :: n real(sp), intent(inout) :: est,x(*) - integer(ilp), intent(out) :: isgn(*) + integer(${ik}$), intent(out) :: isgn(*) real(sp), intent(out) :: v(*) end subroutine slacon -#else - module procedure stdlib_slacon +#else + module procedure stdlib${ii}$_slacon #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lacon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zlacon( n, v, x, est, kase ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(inout) :: kase - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(inout) :: kase + integer(${ik}$), intent(in) :: n real(dp), intent(inout) :: est complex(dp), intent(out) :: v(n) complex(dp), intent(inout) :: x(n) end subroutine zlacon -#else - module procedure stdlib_zlacon +#else + module procedure stdlib${ii}$_zlacon #endif - end interface lacon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lacon +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lacon +#:endif +#:endfor +#:endfor + end interface lacon interface lacpy !! LACPY copies all or part of a two-dimensional matrix A to another !! matrix B. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clacpy( uplo, m, n, a, lda, b, ldb ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: lda,ldb,m,n + integer(${ik}$), intent(in) :: lda,ldb,m,n complex(sp), intent(in) :: a(lda,*) complex(sp), intent(out) :: b(ldb,*) end subroutine clacpy -#else - module procedure stdlib_clacpy +#else + module procedure stdlib${ii}$_clacpy #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlacpy( uplo, m, n, a, lda, b, ldb ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: lda,ldb,m,n + integer(${ik}$), intent(in) :: lda,ldb,m,n real(dp), intent(in) :: a(lda,*) real(dp), intent(out) :: b(ldb,*) end subroutine dlacpy -#else - module procedure stdlib_dlacpy +#else + module procedure stdlib${ii}$_dlacpy #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lacpy - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slacpy( uplo, m, n, a, lda, b, ldb ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: lda,ldb,m,n + integer(${ik}$), intent(in) :: lda,ldb,m,n real(sp), intent(in) :: a(lda,*) real(sp), intent(out) :: b(ldb,*) end subroutine slacpy -#else - module procedure stdlib_slacpy +#else + module procedure stdlib${ii}$_slacpy #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lacpy - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlacpy( uplo, m, n, a, lda, b, ldb ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: lda,ldb,m,n + integer(${ik}$), intent(in) :: lda,ldb,m,n complex(dp), intent(in) :: a(lda,*) complex(dp), intent(out) :: b(ldb,*) end subroutine zlacpy -#else - module procedure stdlib_zlacpy +#else + module procedure stdlib${ii}$_zlacpy #endif - end interface lacpy +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lacpy +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lacpy +#:endif +#:endfor +#:endfor + end interface lacpy interface lacrm !! LACRM performs a very simple matrix-matrix multiplication: !! C := A * B, !! where A is M by N and complex; B is N by N and real; !! C is M by N and complex. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clacrm( m, n, a, lda, b, ldb, c, ldc, rwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: lda,ldb,ldc,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: lda,ldb,ldc,m,n real(sp), intent(in) :: b(ldb,*) real(sp), intent(out) :: rwork(*) complex(sp), intent(in) :: a(lda,*) complex(sp), intent(out) :: c(ldc,*) end subroutine clacrm -#else - module procedure stdlib_clacrm +#else + module procedure stdlib${ii}$_clacrm #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lacrm - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlacrm( m, n, a, lda, b, ldb, c, ldc, rwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: lda,ldb,ldc,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: lda,ldb,ldc,m,n real(dp), intent(in) :: b(ldb,*) real(dp), intent(out) :: rwork(*) complex(dp), intent(in) :: a(lda,*) complex(dp), intent(out) :: c(ldc,*) end subroutine zlacrm -#else - module procedure stdlib_zlacrm +#else + module procedure stdlib${ii}$_zlacrm #endif - end interface lacrm - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lacrm +#:endif +#:endfor +#:endfor + end interface lacrm interface lacrt !! LACRT performs the operation !! ( c s )( x ) ==> ( x ) !! ( -s c )( y ) ( y ) !! where c and s are complex and the vectors x and y are complex. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clacrt( n, cx, incx, cy, incy, c, s ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n complex(sp), intent(in) :: c,s complex(sp), intent(inout) :: cx(*),cy(*) end subroutine clacrt -#else - module procedure stdlib_clacrt +#else + module procedure stdlib${ii}$_clacrt #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lacrt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlacrt( n, cx, incx, cy, incy, c, s ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n complex(dp), intent(in) :: c,s complex(dp), intent(inout) :: cx(*),cy(*) end subroutine zlacrt -#else - module procedure stdlib_zlacrt +#else + module procedure stdlib${ii}$_zlacrt #endif - end interface lacrt - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lacrt +#:endif +#:endfor +#:endfor + end interface lacrt interface ladiv_f !! LADIV_F := X / Y, where X and Y are complex. The computation of X / Y !! will not overflow on an intermediary step unless the results !! overflows. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure complex(sp) function cladiv( x, y ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(sp), intent(in) :: x,y end function cladiv -#else - module procedure stdlib_cladiv +#:if not 'ilp64' in ik +#else + module procedure stdlib${ii}$_cladiv +#:endif #endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure complex(dp) function zladiv( x, y ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + complex(dp), intent(in) :: x,y + end function zladiv +#:if not 'ilp64' in ik +#else + module procedure stdlib${ii}$_zladiv +#:endif +#endif +#:endfor #:for rk,rt,ri in CMPLX_KINDS_TYPES #:if not rk in ["sp","dp"] module procedure stdlib_${ri}$ladiv - #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure complex(dp) function zladiv( x, y ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - complex(dp), intent(in) :: x,y - end function zladiv -#else - module procedure stdlib_zladiv -#endif end interface ladiv_f - - interface ladiv_s !! LADIV_S performs complex division in real arithmetic !! a + i*b @@ -9875,98 +9827,109 @@ module stdlib_linalg_lapack !! The algorithm is due to Michael Baudin and Robert L. Smith !! and can be found in the paper !! "A Robust Complex Division in Scilab" -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dladiv( a, b, c, d, p, q ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: a,b,c,d real(dp), intent(out) :: p,q end subroutine dladiv -#else - module procedure stdlib_dladiv +#:if not 'ilp64' in ik +#else + module procedure stdlib${ii}$_dladiv +#:endif +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine sladiv( a, b, c, d, p, q ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + real(sp), intent(in) :: a,b,c,d + real(sp), intent(out) :: p,q + end subroutine sladiv +#:if not 'ilp64' in ik +#else + module procedure stdlib${ii}$_sladiv +#:endif #endif +#:endfor #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] module procedure stdlib_${ri}$ladiv #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine sladiv( a, b, c, d, p, q ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - real(sp), intent(in) :: a,b,c,d - real(sp), intent(out) :: p,q - end subroutine sladiv -#else - module procedure stdlib_sladiv -#endif end interface ladiv_s - - interface ladiv1 -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dladiv1( a, b, c, d, p, q ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(inout) :: a real(dp), intent(in) :: b,c,d real(dp), intent(out) :: p,q end subroutine dladiv1 -#else - module procedure stdlib_dladiv1 +#:if not 'ilp64' in ik +#else + module procedure stdlib${ii}$_dladiv1 +#:endif #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ladiv1 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sladiv1( a, b, c, d, p, q ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(inout) :: a real(sp), intent(in) :: b,c,d real(sp), intent(out) :: p,q end subroutine sladiv1 -#else - module procedure stdlib_sladiv1 +#:if not 'ilp64' in ik +#else + module procedure stdlib${ii}$_sladiv1 +#:endif #endif +#:endfor +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$ladiv1 +#:endif +#:endfor end interface ladiv1 - - interface ladiv2 -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure real(dp) function dladiv2( a, b, c, d, r, t ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: a,b,c,d,r,t end function dladiv2 -#else - module procedure stdlib_dladiv2 +#:if not 'ilp64' in ik +#else + module procedure stdlib${ii}$_dladiv2 +#:endif #endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure real(sp) function sladiv2( a, b, c, d, r, t ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + real(sp), intent(in) :: a,b,c,d,r,t + end function sladiv2 +#:if not 'ilp64' in ik +#else + module procedure stdlib${ii}$_sladiv2 +#:endif +#endif +#:endfor #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] module procedure stdlib_${ri}$ladiv2 #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure real(sp) function sladiv2( a, b, c, d, r, t ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - real(sp), intent(in) :: a,b,c,d,r,t - end function sladiv2 -#else - module procedure stdlib_sladiv2 -#endif end interface ladiv2 - - interface laebz !! LAEBZ contains the iteration loops which compute and use the !! function N(w), which is the count of eigenvalues of a symmetric @@ -9999,122 +9962,122 @@ module stdlib_linalg_lapack !! University, July 21, 1966 !! Note: the arguments are, in general, *not* checked for unreasonable !! values. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaebz( ijob, nitmax, n, mmax, minp, nbmin, abstol,reltol, pivmin, & d, e, e2, nval, ab, c, mout,nab, work, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ijob,minp,mmax,n,nbmin,nitmax - integer(ilp), intent(out) :: info,mout,iwork(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ijob,minp,mmax,n,nbmin,nitmax + integer(${ik}$), intent(out) :: info,mout,iwork(*) real(dp), intent(in) :: abstol,pivmin,reltol,d(*),e(*),e2(*) - integer(ilp), intent(inout) :: nab(mmax,*),nval(*) + integer(${ik}$), intent(inout) :: nab(mmax,*),nval(*) real(dp), intent(inout) :: ab(mmax,*),c(*) real(dp), intent(out) :: work(*) end subroutine dlaebz -#else - module procedure stdlib_dlaebz +#else + module procedure stdlib${ii}$_dlaebz #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laebz - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaebz( ijob, nitmax, n, mmax, minp, nbmin, abstol,reltol, pivmin, & d, e, e2, nval, ab, c, mout,nab, work, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ijob,minp,mmax,n,nbmin,nitmax - integer(ilp), intent(out) :: info,mout,iwork(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ijob,minp,mmax,n,nbmin,nitmax + integer(${ik}$), intent(out) :: info,mout,iwork(*) real(sp), intent(in) :: abstol,pivmin,reltol,d(*),e(*),e2(*) - integer(ilp), intent(inout) :: nab(mmax,*),nval(*) + integer(${ik}$), intent(inout) :: nab(mmax,*),nval(*) real(sp), intent(inout) :: ab(mmax,*),c(*) real(sp), intent(out) :: work(*) end subroutine slaebz -#else - module procedure stdlib_slaebz +#else + module procedure stdlib${ii}$_slaebz #endif - end interface laebz - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laebz +#:endif +#:endfor +#:endfor + end interface laebz interface laed0 !! Using the divide and conquer method, LAED0: computes all eigenvalues !! of a symmetric tridiagonal matrix which is one diagonal block of !! those from reducing a dense or band Hermitian matrix and !! corresponding eigenvectors of the dense or band matrix. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine claed0( qsiz, n, d, e, q, ldq, qstore, ldqs, rwork,iwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldq,ldqs,n,qsiz + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldq,ldqs,n,qsiz real(sp), intent(inout) :: d(*),e(*) real(sp), intent(out) :: rwork(*) complex(sp), intent(inout) :: q(ldq,*) complex(sp), intent(out) :: qstore(ldqs,*) end subroutine claed0 -#else - module procedure stdlib_claed0 +#else + module procedure stdlib${ii}$_claed0 #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaed0( icompq, qsiz, n, d, e, q, ldq, qstore, ldqs,work, iwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: icompq,ldq,ldqs,n,qsiz - integer(ilp), intent(out) :: info,iwork(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: icompq,ldq,ldqs,n,qsiz + integer(${ik}$), intent(out) :: info,iwork(*) real(dp), intent(inout) :: d(*),e(*),q(ldq,*) real(dp), intent(out) :: qstore(ldqs,*),work(*) end subroutine dlaed0 -#else - module procedure stdlib_dlaed0 +#else + module procedure stdlib${ii}$_dlaed0 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laed0 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaed0( icompq, qsiz, n, d, e, q, ldq, qstore, ldqs,work, iwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: icompq,ldq,ldqs,n,qsiz - integer(ilp), intent(out) :: info,iwork(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: icompq,ldq,ldqs,n,qsiz + integer(${ik}$), intent(out) :: info,iwork(*) real(sp), intent(inout) :: d(*),e(*),q(ldq,*) real(sp), intent(out) :: qstore(ldqs,*),work(*) end subroutine slaed0 -#else - module procedure stdlib_slaed0 +#else + module procedure stdlib${ii}$_slaed0 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laed0 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlaed0( qsiz, n, d, e, q, ldq, qstore, ldqs, rwork,iwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldq,ldqs,n,qsiz + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldq,ldqs,n,qsiz real(dp), intent(inout) :: d(*),e(*) real(dp), intent(out) :: rwork(*) complex(dp), intent(inout) :: q(ldq,*) complex(dp), intent(out) :: qstore(ldqs,*) end subroutine zlaed0 -#else - module procedure stdlib_zlaed0 +#else + module procedure stdlib${ii}$_zlaed0 #endif - end interface laed0 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laed0 +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laed0 +#:endif +#:endfor +#:endfor + end interface laed0 interface laed1 !! LAED1 computes the updated eigensystem of a diagonal @@ -10143,43 +10106,43 @@ module stdlib_linalg_lapack !! directly using the updated eigenvalues. The eigenvectors for !! the current problem are multiplied with the eigenvectors from !! the overall problem. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaed1( n, d, q, ldq, indxq, rho, cutpnt, work, iwork,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: cutpnt,ldq,n - integer(ilp), intent(out) :: info,iwork(*) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: cutpnt,ldq,n + integer(${ik}$), intent(out) :: info,iwork(*) real(dp), intent(inout) :: rho,d(*),q(ldq,*) - integer(ilp), intent(inout) :: indxq(*) + integer(${ik}$), intent(inout) :: indxq(*) real(dp), intent(out) :: work(*) end subroutine dlaed1 -#else - module procedure stdlib_dlaed1 +#else + module procedure stdlib${ii}$_dlaed1 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laed1 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaed1( n, d, q, ldq, indxq, rho, cutpnt, work, iwork,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: cutpnt,ldq,n - integer(ilp), intent(out) :: info,iwork(*) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: cutpnt,ldq,n + integer(${ik}$), intent(out) :: info,iwork(*) real(sp), intent(inout) :: rho,d(*),q(ldq,*) - integer(ilp), intent(inout) :: indxq(*) + integer(${ik}$), intent(inout) :: indxq(*) real(sp), intent(out) :: work(*) end subroutine slaed1 -#else - module procedure stdlib_slaed1 +#else + module procedure stdlib${ii}$_slaed1 #endif - end interface laed1 - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laed1 +#:endif +#:endfor +#:endfor + end interface laed1 interface laed4 !! This subroutine computes the I-th updated eigenvalue of a symmetric @@ -10192,39 +10155,39 @@ module stdlib_linalg_lapack !! where we assume the Euclidean norm of Z is 1. !! The method consists of approximating the rational functions in the !! secular equation by simpler interpolating rational functions. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaed4( n, i, d, z, delta, rho, dlam, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: i,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: i,n + integer(${ik}$), intent(out) :: info real(dp), intent(out) :: dlam,delta(*) real(dp), intent(in) :: rho,d(*),z(*) end subroutine dlaed4 -#else - module procedure stdlib_dlaed4 +#else + module procedure stdlib${ii}$_dlaed4 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laed4 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaed4( n, i, d, z, delta, rho, dlam, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: i,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: i,n + integer(${ik}$), intent(out) :: info real(sp), intent(out) :: dlam,delta(*) real(sp), intent(in) :: rho,d(*),z(*) end subroutine slaed4 -#else - module procedure stdlib_slaed4 +#else + module procedure stdlib${ii}$_slaed4 #endif - end interface laed4 - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laed4 +#:endif +#:endfor +#:endfor + end interface laed4 interface laed5 !! This subroutine computes the I-th eigenvalue of a symmetric rank-one @@ -10234,37 +10197,37 @@ module stdlib_linalg_lapack !! D(i) < D(j) for i < j . !! We also assume RHO > 0 and that the Euclidean norm of the vector !! Z is one. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaed5( i, d, z, delta, rho, dlam ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: i + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: i real(dp), intent(out) :: dlam,delta(2) real(dp), intent(in) :: rho,d(2),z(2) end subroutine dlaed5 -#else - module procedure stdlib_dlaed5 +#else + module procedure stdlib${ii}$_dlaed5 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laed5 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaed5( i, d, z, delta, rho, dlam ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: i + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: i real(sp), intent(out) :: dlam,delta(2) real(sp), intent(in) :: rho,d(2),z(2) end subroutine slaed5 -#else - module procedure stdlib_slaed5 +#else + module procedure stdlib${ii}$_slaed5 #endif - end interface laed5 - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laed5 +#:endif +#:endfor +#:endfor + end interface laed5 interface laed6 !! LAED6 computes the positive or negative root (closest to the origin) @@ -10278,41 +10241,41 @@ module stdlib_linalg_lapack !! This routine will be called by DLAED4 when necessary. In most cases, !! the root sought is the smallest in magnitude, though it might not be !! in some extremely rare situations. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaed6( kniter, orgati, rho, d, z, finit, tau, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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(dp), intent(in) :: finit,rho,d(3),z(3) real(dp), intent(out) :: tau end subroutine dlaed6 -#else - module procedure stdlib_dlaed6 +#else + module procedure stdlib${ii}$_dlaed6 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laed6 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaed6( kniter, orgati, rho, d, z, finit, tau, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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,d(3),z(3) real(sp), intent(out) :: tau end subroutine slaed6 -#else - module procedure stdlib_slaed6 +#else + module procedure stdlib${ii}$_slaed6 #endif - end interface laed6 - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laed6 +#:endif +#:endfor +#:endfor + end interface laed6 interface laed7 !! LAED7 computes the updated eigensystem of a diagonal @@ -10339,91 +10302,91 @@ module stdlib_linalg_lapack !! directly using the updated eigenvalues. The eigenvectors for !! the current problem are multiplied with the eigenvectors from !! the overall problem. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine claed7( n, cutpnt, qsiz, tlvls, curlvl, curpbm, d, q,ldq, rho, & indxq, qstore, qptr, prmptr, perm,givptr, givcol, givnum, work, rwork, iwork,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: curlvl,curpbm,cutpnt,ldq,n,qsiz,tlvls - integer(ilp), intent(out) :: info,indxq(*),iwork(*) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: curlvl,curpbm,cutpnt,ldq,n,qsiz,tlvls + integer(${ik}$), intent(out) :: info,indxq(*),iwork(*) real(sp), intent(inout) :: rho,d(*),givnum(2,*),qstore(*) - integer(ilp), intent(inout) :: givcol(2,*),givptr(*),perm(*),prmptr(*),qptr(*) - + integer(${ik}$), intent(inout) :: givcol(2,*),givptr(*),perm(*),prmptr(*),qptr(*) + real(sp), intent(out) :: rwork(*) complex(sp), intent(inout) :: q(ldq,*) complex(sp), intent(out) :: work(*) end subroutine claed7 -#else - module procedure stdlib_claed7 +#else + module procedure stdlib${ii}$_claed7 #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaed7( icompq, n, qsiz, tlvls, curlvl, curpbm, d, q,ldq, indxq, & rho, cutpnt, qstore, qptr, prmptr,perm, givptr, givcol, givnum, work, iwork,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: curlvl,curpbm,cutpnt,icompq,ldq,n,qsiz,& + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: curlvl,curpbm,cutpnt,icompq,ldq,n,qsiz,& tlvls - integer(ilp), intent(out) :: info,indxq(*),iwork(*) + integer(${ik}$), intent(out) :: info,indxq(*),iwork(*) real(dp), intent(inout) :: rho,d(*),givnum(2,*),q(ldq,*),qstore(*) - integer(ilp), intent(inout) :: givcol(2,*),givptr(*),perm(*),prmptr(*),qptr(*) - + integer(${ik}$), intent(inout) :: givcol(2,*),givptr(*),perm(*),prmptr(*),qptr(*) + real(dp), intent(out) :: work(*) end subroutine dlaed7 -#else - module procedure stdlib_dlaed7 +#else + module procedure stdlib${ii}$_dlaed7 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laed7 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaed7( icompq, n, qsiz, tlvls, curlvl, curpbm, d, q,ldq, indxq, & rho, cutpnt, qstore, qptr, prmptr,perm, givptr, givcol, givnum, work, iwork,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: curlvl,curpbm,cutpnt,icompq,ldq,n,qsiz,& + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: curlvl,curpbm,cutpnt,icompq,ldq,n,qsiz,& tlvls - integer(ilp), intent(out) :: info,indxq(*),iwork(*) + integer(${ik}$), intent(out) :: info,indxq(*),iwork(*) real(sp), intent(inout) :: rho,d(*),givnum(2,*),q(ldq,*),qstore(*) - integer(ilp), intent(inout) :: givcol(2,*),givptr(*),perm(*),prmptr(*),qptr(*) - + integer(${ik}$), intent(inout) :: givcol(2,*),givptr(*),perm(*),prmptr(*),qptr(*) + real(sp), intent(out) :: work(*) end subroutine slaed7 -#else - module procedure stdlib_slaed7 +#else + module procedure stdlib${ii}$_slaed7 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laed7 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlaed7( n, cutpnt, qsiz, tlvls, curlvl, curpbm, d, q,ldq, rho, & indxq, qstore, qptr, prmptr, perm,givptr, givcol, givnum, work, rwork, iwork,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: curlvl,curpbm,cutpnt,ldq,n,qsiz,tlvls - integer(ilp), intent(out) :: info,indxq(*),iwork(*) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: curlvl,curpbm,cutpnt,ldq,n,qsiz,tlvls + integer(${ik}$), intent(out) :: info,indxq(*),iwork(*) real(dp), intent(inout) :: rho,d(*),givnum(2,*),qstore(*) - integer(ilp), intent(inout) :: givcol(2,*),givptr(*),perm(*),prmptr(*),qptr(*) - + integer(${ik}$), intent(inout) :: givcol(2,*),givptr(*),perm(*),prmptr(*),qptr(*) + real(dp), intent(out) :: rwork(*) complex(dp), intent(inout) :: q(ldq,*) complex(dp), intent(out) :: work(*) end subroutine zlaed7 -#else - module procedure stdlib_zlaed7 +#else + module procedure stdlib${ii}$_zlaed7 #endif - end interface laed7 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laed7 +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laed7 +#:endif +#:endfor +#:endfor + end interface laed7 interface laed8 !! LAED8 merges the two sets of eigenvalues together into a single @@ -10432,254 +10395,254 @@ module stdlib_linalg_lapack !! eigenvalues are close together or if there is a tiny element in the !! Z vector. For each such occurrence the order of the related secular !! equation problem is reduced by one. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine claed8( k, n, qsiz, q, ldq, d, rho, cutpnt, z, dlamda,q2, ldq2, w, & indxp, indx, indxq, perm, givptr,givcol, givnum, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: cutpnt,ldq,ldq2,n,qsiz - integer(ilp), intent(out) :: givptr,info,k,givcol(2,*),indx(*),indxp(*),perm(& + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: cutpnt,ldq,ldq2,n,qsiz + integer(${ik}$), intent(out) :: givptr,info,k,givcol(2,*),indx(*),indxp(*),perm(& *) real(sp), intent(inout) :: rho,d(*),z(*) - integer(ilp), intent(inout) :: indxq(*) + integer(${ik}$), intent(inout) :: indxq(*) real(sp), intent(out) :: dlamda(*),givnum(2,*),w(*) complex(sp), intent(inout) :: q(ldq,*) complex(sp), intent(out) :: q2(ldq2,*) end subroutine claed8 -#else - module procedure stdlib_claed8 +#else + module procedure stdlib${ii}$_claed8 #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaed8( icompq, k, n, qsiz, d, q, ldq, indxq, rho,cutpnt, z, & dlamda, q2, ldq2, w, perm, givptr,givcol, givnum, indxp, indx, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: cutpnt,icompq,ldq,ldq2,n,qsiz - integer(ilp), intent(out) :: givptr,info,k,givcol(2,*),indx(*),indxp(*),perm(& + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: cutpnt,icompq,ldq,ldq2,n,qsiz + integer(${ik}$), intent(out) :: givptr,info,k,givcol(2,*),indx(*),indxp(*),perm(& *) real(dp), intent(inout) :: rho,d(*),q(ldq,*),z(*) - integer(ilp), intent(inout) :: indxq(*) + integer(${ik}$), intent(inout) :: indxq(*) real(dp), intent(out) :: dlamda(*),givnum(2,*),q2(ldq2,*),w(*) end subroutine dlaed8 -#else - module procedure stdlib_dlaed8 +#else + module procedure stdlib${ii}$_dlaed8 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laed8 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaed8( icompq, k, n, qsiz, d, q, ldq, indxq, rho,cutpnt, z, & dlamda, q2, ldq2, w, perm, givptr,givcol, givnum, indxp, indx, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: cutpnt,icompq,ldq,ldq2,n,qsiz - integer(ilp), intent(out) :: givptr,info,k,givcol(2,*),indx(*),indxp(*),perm(& + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: cutpnt,icompq,ldq,ldq2,n,qsiz + integer(${ik}$), intent(out) :: givptr,info,k,givcol(2,*),indx(*),indxp(*),perm(& *) real(sp), intent(inout) :: rho,d(*),q(ldq,*),z(*) - integer(ilp), intent(inout) :: indxq(*) + integer(${ik}$), intent(inout) :: indxq(*) real(sp), intent(out) :: dlamda(*),givnum(2,*),q2(ldq2,*),w(*) end subroutine slaed8 -#else - module procedure stdlib_slaed8 +#else + module procedure stdlib${ii}$_slaed8 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laed8 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlaed8( k, n, qsiz, q, ldq, d, rho, cutpnt, z, dlamda,q2, ldq2, w, & indxp, indx, indxq, perm, givptr,givcol, givnum, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: cutpnt,ldq,ldq2,n,qsiz - integer(ilp), intent(out) :: givptr,info,k,givcol(2,*),indx(*),indxp(*),perm(& + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: cutpnt,ldq,ldq2,n,qsiz + integer(${ik}$), intent(out) :: givptr,info,k,givcol(2,*),indx(*),indxp(*),perm(& *) real(dp), intent(inout) :: rho,d(*),z(*) - integer(ilp), intent(inout) :: indxq(*) + integer(${ik}$), intent(inout) :: indxq(*) real(dp), intent(out) :: dlamda(*),givnum(2,*),w(*) complex(dp), intent(inout) :: q(ldq,*) complex(dp), intent(out) :: q2(ldq2,*) end subroutine zlaed8 -#else - module procedure stdlib_zlaed8 +#else + module procedure stdlib${ii}$_zlaed8 #endif - end interface laed8 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laed8 +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laed8 +#:endif +#:endfor +#:endfor + end interface laed8 interface laed9 !! LAED9 finds the roots of the secular equation, as defined by the !! values in D, Z, and RHO, between KSTART and KSTOP. It makes the !! appropriate calls to DLAED4 and then stores the new matrix of !! eigenvectors for use in calculating the next level of Z vectors. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaed9( k, kstart, kstop, n, d, q, ldq, rho, dlamda, w,s, lds, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,kstart,kstop,ldq,lds,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,kstart,kstop,ldq,lds,n real(dp), intent(in) :: rho real(dp), intent(out) :: d(*),q(ldq,*),s(lds,*) real(dp), intent(inout) :: dlamda(*),w(*) end subroutine dlaed9 -#else - module procedure stdlib_dlaed9 +#else + module procedure stdlib${ii}$_dlaed9 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laed9 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaed9( k, kstart, kstop, n, d, q, ldq, rho, dlamda, w,s, lds, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,kstart,kstop,ldq,lds,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,kstart,kstop,ldq,lds,n real(sp), intent(in) :: rho real(sp), intent(out) :: d(*),q(ldq,*),s(lds,*) real(sp), intent(inout) :: dlamda(*),w(*) end subroutine slaed9 -#else - module procedure stdlib_slaed9 +#else + module procedure stdlib${ii}$_slaed9 #endif - end interface laed9 - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laed9 +#:endif +#:endfor +#:endfor + end interface laed9 interface laeda !! LAEDA computes the Z vector corresponding to the merge step in the !! CURLVLth step of the merge process with TLVLS steps for the CURPBMth !! problem. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaeda( n, tlvls, curlvl, curpbm, prmptr, perm, givptr,givcol, & givnum, q, qptr, z, ztemp, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: curlvl,curpbm,n,tlvls,givcol(2,*),givptr(*),perm(& + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: curlvl,curpbm,n,tlvls,givcol(2,*),givptr(*),perm(& *),prmptr(*),qptr(*) - integer(ilp), intent(out) :: info + integer(${ik}$), intent(out) :: info real(dp), intent(in) :: givnum(2,*),q(*) real(dp), intent(out) :: z(*),ztemp(*) end subroutine dlaeda -#else - module procedure stdlib_dlaeda +#else + module procedure stdlib${ii}$_dlaeda #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laeda - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaeda( n, tlvls, curlvl, curpbm, prmptr, perm, givptr,givcol, & givnum, q, qptr, z, ztemp, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: curlvl,curpbm,n,tlvls,givcol(2,*),givptr(*),perm(& + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: curlvl,curpbm,n,tlvls,givcol(2,*),givptr(*),perm(& *),prmptr(*),qptr(*) - integer(ilp), intent(out) :: info + integer(${ik}$), intent(out) :: info real(sp), intent(in) :: givnum(2,*),q(*) real(sp), intent(out) :: z(*),ztemp(*) end subroutine slaeda -#else - module procedure stdlib_slaeda +#else + module procedure stdlib${ii}$_slaeda #endif - end interface laeda - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laeda +#:endif +#:endfor +#:endfor + end interface laeda interface laein !! LAEIN uses inverse iteration to find a right or left eigenvector !! corresponding to the eigenvalue W of a complex upper Hessenberg !! matrix H. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine claein( rightv, noinit, n, h, ldh, w, v, b, ldb, rwork,eps3, & smlnum, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: noinit,rightv - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,ldh,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,ldh,n real(sp), intent(in) :: eps3,smlnum complex(sp), intent(in) :: w,h(ldh,*) real(sp), intent(out) :: rwork(*) complex(sp), intent(out) :: b(ldb,*) complex(sp), intent(inout) :: v(*) end subroutine claein -#else - module procedure stdlib_claein +#else + module procedure stdlib${ii}$_claein #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaein( rightv, noinit, n, h, ldh, wr, wi, vr, vi, b,ldb, work, & eps3, smlnum, bignum, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: noinit,rightv - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,ldh,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,ldh,n real(dp), intent(in) :: bignum,eps3,smlnum,wi,wr,h(ldh,*) real(dp), intent(out) :: b(ldb,*),work(*) - real(dp), intent(inout) :: vi(*),vr(*) - end subroutine dlaein -#else - module procedure stdlib_dlaein -#endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laein - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK + real(dp), intent(inout) :: vi(*),vr(*) + end subroutine dlaein +#else + module procedure stdlib${ii}$_dlaein +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaein( rightv, noinit, n, h, ldh, wr, wi, vr, vi, b,ldb, work, & eps3, smlnum, bignum, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: noinit,rightv - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,ldh,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,ldh,n real(sp), intent(in) :: bignum,eps3,smlnum,wi,wr,h(ldh,*) real(sp), intent(out) :: b(ldb,*),work(*) real(sp), intent(inout) :: vi(*),vr(*) end subroutine slaein -#else - module procedure stdlib_slaein +#else + module procedure stdlib${ii}$_slaein #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laein - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlaein( rightv, noinit, n, h, ldh, w, v, b, ldb, rwork,eps3, & smlnum, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: noinit,rightv - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,ldh,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,ldh,n real(dp), intent(in) :: eps3,smlnum complex(dp), intent(in) :: w,h(ldh,*) real(dp), intent(out) :: rwork(*) complex(dp), intent(out) :: b(ldb,*) complex(dp), intent(inout) :: v(*) end subroutine zlaein -#else - module procedure stdlib_zlaein +#else + module procedure stdlib${ii}$_zlaein #endif - end interface laein +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laein +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laein +#:endif +#:endfor +#:endfor + end interface laein interface laesy !! LAESY computes the eigendecomposition of a 2-by-2 symmetric matrix @@ -10691,36 +10654,39 @@ module stdlib_linalg_lapack !! on return ( CS1, SN1 ) is the unit eigenvector for RT1, hence !! [ CS1 SN1 ] . [ A B ] . [ CS1 -SN1 ] = [ RT1 0 ] !! [ -SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ] -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine claesy( a, b, c, rt1, rt2, evscal, cs1, sn1 ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(sp), intent(in) :: a,b,c complex(sp), intent(out) :: cs1,evscal,rt1,rt2,sn1 end subroutine claesy -#else - module procedure stdlib_claesy +#:if not 'ilp64' in ik +#else + module procedure stdlib${ii}$_claesy +#:endif #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laesy - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlaesy( a, b, c, rt1, rt2, evscal, cs1, sn1 ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(dp), intent(in) :: a,b,c complex(dp), intent(out) :: cs1,evscal,rt1,rt2,sn1 end subroutine zlaesy -#else - module procedure stdlib_zlaesy +#:if not 'ilp64' in ik +#else + module procedure stdlib${ii}$_zlaesy +#:endif #endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib_${ri}$laesy +#:endif +#:endfor end interface laesy - - interface laexc !! LAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in !! an upper quasi-triangular matrix T by an orthogonal similarity @@ -10729,41 +10695,41 @@ module stdlib_linalg_lapack !! with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block !! has its diagonal elements equal and its off-diagonal elements of !! opposite sign. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dlaexc( wantq, n, t, ldt, q, ldq, j1, n1, n2, work,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: wantq - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: j1,ldq,ldt,n,n1,n2 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: j1,ldq,ldt,n,n1,n2 real(dp), intent(inout) :: q(ldq,*),t(ldt,*) real(dp), intent(out) :: work(*) end subroutine dlaexc -#else - module procedure stdlib_dlaexc +#else + module procedure stdlib${ii}$_dlaexc #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laexc - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine slaexc( wantq, n, t, ldt, q, ldq, j1, n1, n2, work,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: wantq - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: j1,ldq,ldt,n,n1,n2 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: j1,ldq,ldt,n,n1,n2 real(sp), intent(inout) :: q(ldq,*),t(ldt,*) real(sp), intent(out) :: work(*) end subroutine slaexc -#else - module procedure stdlib_slaexc +#else + module procedure stdlib${ii}$_slaexc #endif - end interface laexc - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laexc +#:endif +#:endfor +#:endfor + end interface laexc interface lagtf !! LAGTF factorizes the matrix (T - lambda*I), where T is an n by n @@ -10778,41 +10744,41 @@ module stdlib_linalg_lapack !! The parameter LAMBDA is included in the routine so that LAGTF may !! be used, in conjunction with DLAGTS, to obtain eigenvectors of T by !! inverse iteration. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlagtf( n, a, lambda, b, c, tol, d, in, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,in(*) - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,in(*) + integer(${ik}$), intent(in) :: n real(dp), intent(in) :: lambda,tol real(dp), intent(inout) :: a(*),b(*),c(*) real(dp), intent(out) :: d(*) end subroutine dlagtf -#else - module procedure stdlib_dlagtf +#else + module procedure stdlib${ii}$_dlagtf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lagtf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slagtf( n, a, lambda, b, c, tol, d, in, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,in(*) - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,in(*) + integer(${ik}$), intent(in) :: n real(sp), intent(in) :: lambda,tol real(sp), intent(inout) :: a(*),b(*),c(*) real(sp), intent(out) :: d(*) end subroutine slagtf -#else - module procedure stdlib_slagtf +#else + module procedure stdlib${ii}$_slagtf #endif - end interface lagtf - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lagtf +#:endif +#:endfor +#:endfor + end interface lagtf interface lagtm !! LAGTM performs a matrix-vector product of the form @@ -10820,75 +10786,75 @@ module stdlib_linalg_lapack !! where A is a tridiagonal matrix of order N, B and X are N by NRHS !! matrices, and alpha and beta are real scalars, each of which may be !! 0., 1., or -1. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clagtm( trans, n, nrhs, alpha, dl, d, du, x, ldx, beta,b, ldb ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(inout) :: b(ldb,*) complex(sp), intent(in) :: d(*),dl(*),du(*),x(ldx,*) end subroutine clagtm -#else - module procedure stdlib_clagtm +#else + module procedure stdlib${ii}$_clagtm #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlagtm( trans, n, nrhs, alpha, dl, d, du, x, ldx, beta,b, ldb ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(in) :: ldb,ldx,n,nrhs + integer(${ik}$), intent(in) :: ldb,ldx,n,nrhs real(dp), intent(in) :: alpha,beta,d(*),dl(*),du(*),x(ldx,*) real(dp), intent(inout) :: b(ldb,*) end subroutine dlagtm -#else - module procedure stdlib_dlagtm +#else + module procedure stdlib${ii}$_dlagtm #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lagtm - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slagtm( trans, n, nrhs, alpha, dl, d, du, x, ldx, beta,b, ldb ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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,d(*),dl(*),du(*),x(ldx,*) real(sp), intent(inout) :: b(ldb,*) end subroutine slagtm -#else - module procedure stdlib_slagtm +#else + module procedure stdlib${ii}$_slagtm #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lagtm - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlagtm( trans, n, nrhs, alpha, dl, d, du, x, ldx, beta,b, ldb ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(in) :: ldb,ldx,n,nrhs + integer(${ik}$), intent(in) :: ldb,ldx,n,nrhs real(dp), intent(in) :: alpha,beta complex(dp), intent(inout) :: b(ldb,*) complex(dp), intent(in) :: d(*),dl(*),du(*),x(ldx,*) end subroutine zlagtm -#else - module procedure stdlib_zlagtm +#else + module procedure stdlib${ii}$_zlagtm #endif - end interface lagtm +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lagtm +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lagtm +#:endif +#:endfor +#:endfor + end interface lagtm interface lagts !! LAGTS may be used to solve one of the systems of equations @@ -10900,39 +10866,39 @@ module stdlib_linalg_lapack !! controlled by the argument JOB, and in each case there is an option !! to perturb zero or very small diagonal elements of U, this option !! being intended for use in applications such as inverse iteration. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlagts( job, n, a, b, c, d, in, y, tol, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: job,n,in(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: job,n,in(*) real(dp), intent(inout) :: tol,y(*) real(dp), intent(in) :: a(*),b(*),c(*),d(*) end subroutine dlagts -#else - module procedure stdlib_dlagts +#else + module procedure stdlib${ii}$_dlagts #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lagts - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slagts( job, n, a, b, c, d, in, y, tol, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: job,n,in(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: job,n,in(*) real(sp), intent(inout) :: tol,y(*) real(sp), intent(in) :: a(*),b(*),c(*),d(*) end subroutine slagts -#else - module procedure stdlib_slagts +#else + module procedure stdlib${ii}$_slagts #endif - end interface lagts - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lagts +#:endif +#:endfor +#:endfor + end interface lagts interface lahef !! LAHEF computes a partial factorization of a complex Hermitian @@ -10948,41 +10914,41 @@ module stdlib_linalg_lapack !! LAHEF is an auxiliary routine called by CHETRF. It uses blocked code !! (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or !! A22 (if UPLO = 'L'). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clahef( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,kb,ipiv(*) - integer(ilp), intent(in) :: lda,ldw,n,nb + integer(${ik}$), intent(out) :: info,kb,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldw,n,nb complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: w(ldw,*) end subroutine clahef -#else - module procedure stdlib_clahef +#else + module procedure stdlib${ii}$_clahef #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lahef - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlahef( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,kb,ipiv(*) - integer(ilp), intent(in) :: lda,ldw,n,nb + integer(${ik}$), intent(out) :: info,kb,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldw,n,nb complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: w(ldw,*) end subroutine zlahef -#else - module procedure stdlib_zlahef +#else + module procedure stdlib${ii}$_zlahef #endif - end interface lahef - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lahef +#:endif +#:endfor +#:endfor + end interface lahef interface lahef_aa !! LAHEF_AA factorizes a panel of a complex hermitian matrix A using @@ -10995,41 +10961,41 @@ module stdlib_linalg_lapack !! The resulting J-th row of U, or J-th column of L, is stored in the !! (J-1)-th row, or column, of A (without the unit diagonals), while !! the diagonal and subdiagonal of A are overwritten by those of T. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clahef_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: m,nb,j1,lda,ldh - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(in) :: m,nb,j1,lda,ldh + integer(${ik}$), intent(out) :: ipiv(*) complex(sp), intent(inout) :: a(lda,*),h(ldh,*) complex(sp), intent(out) :: work(*) end subroutine clahef_aa -#else - module procedure stdlib_clahef_aa +#else + module procedure stdlib${ii}$_clahef_aa #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lahef_aa - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlahef_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: m,nb,j1,lda,ldh - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(in) :: m,nb,j1,lda,ldh + integer(${ik}$), intent(out) :: ipiv(*) complex(dp), intent(inout) :: a(lda,*),h(ldh,*) complex(dp), intent(out) :: work(*) end subroutine zlahef_aa -#else - module procedure stdlib_zlahef_aa +#else + module procedure stdlib${ii}$_zlahef_aa #endif - end interface lahef_aa - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lahef_aa +#:endif +#:endfor +#:endfor + end interface lahef_aa interface lahef_rk !! LAHEF_RK computes a partial factorization of a complex Hermitian @@ -11044,41 +11010,41 @@ module stdlib_linalg_lapack !! LAHEF_RK is an auxiliary routine called by CHETRF_RK. It uses !! blocked code (calling Level 3 BLAS) to update the submatrix !! A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clahef_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,kb,ipiv(*) - integer(ilp), intent(in) :: lda,ldw,n,nb + integer(${ik}$), intent(out) :: info,kb,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldw,n,nb complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: w(ldw,*),e(*) end subroutine clahef_rk -#else - module procedure stdlib_clahef_rk +#else + module procedure stdlib${ii}$_clahef_rk #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lahef_rk - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlahef_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,kb,ipiv(*) - integer(ilp), intent(in) :: lda,ldw,n,nb + integer(${ik}$), intent(out) :: info,kb,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldw,n,nb complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: w(ldw,*),e(*) end subroutine zlahef_rk -#else - module procedure stdlib_zlahef_rk +#else + module procedure stdlib${ii}$_zlahef_rk #endif - end interface lahef_rk - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lahef_rk +#:endif +#:endfor +#:endfor + end interface lahef_rk interface lahef_rook !! LAHEF_ROOK computes a partial factorization of a complex Hermitian @@ -11094,118 +11060,118 @@ module stdlib_linalg_lapack !! LAHEF_ROOK is an auxiliary routine called by CHETRF_ROOK. It uses !! blocked code (calling Level 3 BLAS) to update the submatrix !! A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clahef_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,kb,ipiv(*) - integer(ilp), intent(in) :: lda,ldw,n,nb + integer(${ik}$), intent(out) :: info,kb,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldw,n,nb complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: w(ldw,*) end subroutine clahef_rook -#else - module procedure stdlib_clahef_rook +#else + module procedure stdlib${ii}$_clahef_rook #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lahef_rook - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlahef_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,kb,ipiv(*) - integer(ilp), intent(in) :: lda,ldw,n,nb + integer(${ik}$), intent(out) :: info,kb,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldw,n,nb complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: w(ldw,*) end subroutine zlahef_rook -#else - module procedure stdlib_zlahef_rook +#else + module procedure stdlib${ii}$_zlahef_rook #endif - end interface lahef_rook - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lahef_rook +#:endif +#:endfor +#:endfor + end interface lahef_rook interface lahqr !! LAHQR is an auxiliary routine called by CHSEQR to update the !! eigenvalues and Schur decomposition already computed by CHSEQR, by !! dealing with the Hessenberg submatrix in rows and columns ILO to !! IHI. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihi,ihiz,ilo,iloz,ldh,ldz,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihi,ihiz,ilo,iloz,ldh,ldz,n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt,wantz complex(sp), intent(inout) :: h(ldh,*),z(ldz,*) complex(sp), intent(out) :: w(*) end subroutine clahqr -#else - module procedure stdlib_clahqr +#else + module procedure stdlib${ii}$_clahqr #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, & ldz, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihi,ihiz,ilo,iloz,ldh,ldz,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihi,ihiz,ilo,iloz,ldh,ldz,n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt,wantz real(dp), intent(inout) :: h(ldh,*),z(ldz,*) real(dp), intent(out) :: wi(*),wr(*) end subroutine dlahqr -#else - module procedure stdlib_dlahqr +#else + module procedure stdlib${ii}$_dlahqr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lahqr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, & ldz, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihi,ihiz,ilo,iloz,ldh,ldz,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihi,ihiz,ilo,iloz,ldh,ldz,n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt,wantz real(sp), intent(inout) :: h(ldh,*),z(ldz,*) real(sp), intent(out) :: wi(*),wr(*) end subroutine slahqr -#else - module procedure stdlib_slahqr +#else + module procedure stdlib${ii}$_slahqr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lahqr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihi,ihiz,ilo,iloz,ldh,ldz,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihi,ihiz,ilo,iloz,ldh,ldz,n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt,wantz complex(dp), intent(inout) :: h(ldh,*),z(ldz,*) complex(dp), intent(out) :: w(*) end subroutine zlahqr -#else - module procedure stdlib_zlahqr +#else + module procedure stdlib${ii}$_zlahqr #endif - end interface lahqr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lahqr +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lahqr +#:endif +#:endfor +#:endfor + end interface lahqr interface laic1 !! LAIC1 applies one step of incremental condition estimation in @@ -11228,69 +11194,69 @@ module stdlib_linalg_lapack !! diag(sest*sest, 0) + [alpha gamma] * [ conjg(alpha) ] !! [ conjg(gamma) ] !! where alpha = x**H*w. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine claic1( job, j, x, sest, w, gamma, sestpr, s, c ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: j,job + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: j,job real(sp), intent(in) :: sest real(sp), intent(out) :: sestpr complex(sp), intent(out) :: c,s complex(sp), intent(in) :: gamma,w(j),x(j) end subroutine claic1 -#else - module procedure stdlib_claic1 +#else + module procedure stdlib${ii}$_claic1 #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaic1( job, j, x, sest, w, gamma, sestpr, s, c ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: j,job + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: j,job real(dp), intent(out) :: c,s,sestpr real(dp), intent(in) :: gamma,sest,w(j),x(j) end subroutine dlaic1 -#else - module procedure stdlib_dlaic1 +#else + module procedure stdlib${ii}$_dlaic1 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laic1 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaic1( job, j, x, sest, w, gamma, sestpr, s, c ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: j,job + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: j,job real(sp), intent(out) :: c,s,sestpr real(sp), intent(in) :: gamma,sest,w(j),x(j) end subroutine slaic1 -#else - module procedure stdlib_slaic1 +#else + module procedure stdlib${ii}$_slaic1 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laic1 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlaic1( job, j, x, sest, w, gamma, sestpr, s, c ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: j,job + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: j,job real(dp), intent(in) :: sest real(dp), intent(out) :: sestpr complex(dp), intent(out) :: c,s complex(dp), intent(in) :: gamma,w(j),x(j) end subroutine zlaic1 -#else - module procedure stdlib_zlaic1 +#else + module procedure stdlib${ii}$_zlaic1 #endif - end interface laic1 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laic1 +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laic1 +#:endif +#:endfor +#:endfor + end interface laic1 interface laisnan !! This routine is not for general use. It exists solely to avoid @@ -11304,34 +11270,37 @@ module stdlib_linalg_lapack !! 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. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure logical(lk) function dlaisnan( din1, din2 ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: din1,din2 end function dlaisnan -#else - module procedure stdlib_dlaisnan +#:if not 'ilp64' in ik +#else + module procedure stdlib${ii}$_dlaisnan +#:endif +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure logical(lk) function slaisnan( sin1, sin2 ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + real(sp), intent(in) :: sin1,sin2 + end function slaisnan +#:if not 'ilp64' in ik +#else + module procedure stdlib${ii}$_slaisnan +#:endif #endif +#:endfor #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] module procedure stdlib_${ri}$laisnan - #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure logical(lk) function slaisnan( sin1, sin2 ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - real(sp), intent(in) :: sin1,sin2 - end function slaisnan -#else - module procedure stdlib_slaisnan -#endif end interface laisnan - - interface lals0 !! LALS0 applies back the multiplying factors of either the left or the !! right singular vector matrix of a diagonal matrix appended by a row @@ -11353,87 +11322,87 @@ module stdlib_linalg_lapack !! null space. !! (3R) The inverse transformation of (2L). !! (4R) The inverse transformation of (1L). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clals0( icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx,perm, givptr, & givcol, ldgcol, givnum, ldgnum,poles, difl, difr, z, k, c, s, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: givptr,icompq,k,ldb,ldbx,ldgcol,ldgnum,nl,nr,nrhs,& + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: givptr,icompq,k,ldb,ldbx,ldgcol,ldgnum,nl,nr,nrhs,& sqre,givcol(ldgcol,*),perm(*) - integer(ilp), intent(out) :: info + integer(${ik}$), intent(out) :: info real(sp), intent(in) :: c,s,difl(*),difr(ldgnum,*),givnum(ldgnum,*),poles(& ldgnum,*),z(*) real(sp), intent(out) :: rwork(*) complex(sp), intent(inout) :: b(ldb,*) complex(sp), intent(out) :: bx(ldbx,*) end subroutine clals0 -#else - module procedure stdlib_clals0 +#else + module procedure stdlib${ii}$_clals0 #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlals0( icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx,perm, givptr, & givcol, ldgcol, givnum, ldgnum,poles, difl, difr, z, k, c, s, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: givptr,icompq,k,ldb,ldbx,ldgcol,ldgnum,nl,nr,nrhs,& + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: givptr,icompq,k,ldb,ldbx,ldgcol,ldgnum,nl,nr,nrhs,& sqre,givcol(ldgcol,*),perm(*) - integer(ilp), intent(out) :: info + integer(${ik}$), intent(out) :: info real(dp), intent(in) :: c,s,difl(*),difr(ldgnum,*),givnum(ldgnum,*),poles(& ldgnum,*),z(*) real(dp), intent(inout) :: b(ldb,*) real(dp), intent(out) :: bx(ldbx,*),work(*) end subroutine dlals0 -#else - module procedure stdlib_dlals0 +#else + module procedure stdlib${ii}$_dlals0 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lals0 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slals0( icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx,perm, givptr, & givcol, ldgcol, givnum, ldgnum,poles, difl, difr, z, k, c, s, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: givptr,icompq,k,ldb,ldbx,ldgcol,ldgnum,nl,nr,nrhs,& + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: givptr,icompq,k,ldb,ldbx,ldgcol,ldgnum,nl,nr,nrhs,& sqre,givcol(ldgcol,*),perm(*) - integer(ilp), intent(out) :: info + integer(${ik}$), intent(out) :: info real(sp), intent(in) :: c,s,difl(*),difr(ldgnum,*),givnum(ldgnum,*),poles(& ldgnum,*),z(*) real(sp), intent(inout) :: b(ldb,*) real(sp), intent(out) :: bx(ldbx,*),work(*) end subroutine slals0 -#else - module procedure stdlib_slals0 +#else + module procedure stdlib${ii}$_slals0 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lals0 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlals0( icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx,perm, givptr, & givcol, ldgcol, givnum, ldgnum,poles, difl, difr, z, k, c, s, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: givptr,icompq,k,ldb,ldbx,ldgcol,ldgnum,nl,nr,nrhs,& + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: givptr,icompq,k,ldb,ldbx,ldgcol,ldgnum,nl,nr,nrhs,& sqre,givcol(ldgcol,*),perm(*) - integer(ilp), intent(out) :: info + integer(${ik}$), intent(out) :: info real(dp), intent(in) :: c,s,difl(*),difr(ldgnum,*),givnum(ldgnum,*),poles(& ldgnum,*),z(*) real(dp), intent(out) :: rwork(*) complex(dp), intent(inout) :: b(ldb,*) complex(dp), intent(out) :: bx(ldbx,*) end subroutine zlals0 -#else - module procedure stdlib_zlals0 +#else + module procedure stdlib${ii}$_zlals0 #endif - end interface lals0 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lals0 +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lals0 +#:endif +#:endfor +#:endfor + end interface lals0 interface lalsa !! LALSA is an itermediate step in solving the least squares problem @@ -11445,91 +11414,91 @@ module stdlib_linalg_lapack !! ICOMPQ = 1, LALSA applies the right singular vector matrix to the !! right hand side. The singular vector matrices were generated in !! compact form by LALSA. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clalsa( icompq, smlsiz, n, nrhs, b, ldb, bx, ldbx, u,ldu, vt, k, & difl, difr, z, poles, givptr,givcol, ldgcol, perm, givnum, c, s, rwork,iwork, info & ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: icompq,ldb,ldbx,ldgcol,ldu,n,nrhs,smlsiz,givcol(& + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: icompq,ldb,ldbx,ldgcol,ldu,n,nrhs,smlsiz,givcol(& ldgcol,*),givptr(*),k(*),perm(ldgcol,*) - integer(ilp), intent(out) :: info,iwork(*) + integer(${ik}$), intent(out) :: info,iwork(*) real(sp), intent(in) :: c(*),difl(ldu,*),difr(ldu,*),givnum(ldu,*),poles(ldu,& *),s(*),u(ldu,*),vt(ldu,*),z(ldu,*) real(sp), intent(out) :: rwork(*) complex(sp), intent(inout) :: b(ldb,*) complex(sp), intent(out) :: bx(ldbx,*) end subroutine clalsa -#else - module procedure stdlib_clalsa +#else + module procedure stdlib${ii}$_clalsa #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlalsa( icompq, smlsiz, n, nrhs, b, ldb, bx, ldbx, u,ldu, vt, k, & difl, difr, z, poles, givptr,givcol, ldgcol, perm, givnum, c, s, work,iwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: icompq,ldb,ldbx,ldgcol,ldu,n,nrhs,smlsiz,givcol(& + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: icompq,ldb,ldbx,ldgcol,ldu,n,nrhs,smlsiz,givcol(& ldgcol,*),givptr(*),k(*),perm(ldgcol,*) - integer(ilp), intent(out) :: info,iwork(*) + integer(${ik}$), intent(out) :: info,iwork(*) real(dp), intent(inout) :: b(ldb,*) real(dp), intent(out) :: bx(ldbx,*),work(*) real(dp), intent(in) :: c(*),difl(ldu,*),difr(ldu,*),givnum(ldu,*),poles(ldu,& *),s(*),u(ldu,*),vt(ldu,*),z(ldu,*) end subroutine dlalsa -#else - module procedure stdlib_dlalsa +#else + module procedure stdlib${ii}$_dlalsa #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lalsa - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slalsa( icompq, smlsiz, n, nrhs, b, ldb, bx, ldbx, u,ldu, vt, k, & difl, difr, z, poles, givptr,givcol, ldgcol, perm, givnum, c, s, work,iwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: icompq,ldb,ldbx,ldgcol,ldu,n,nrhs,smlsiz,givcol(& + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: icompq,ldb,ldbx,ldgcol,ldu,n,nrhs,smlsiz,givcol(& ldgcol,*),givptr(*),k(*),perm(ldgcol,*) - integer(ilp), intent(out) :: info,iwork(*) + integer(${ik}$), intent(out) :: info,iwork(*) real(sp), intent(inout) :: b(ldb,*) real(sp), intent(out) :: bx(ldbx,*),work(*) real(sp), intent(in) :: c(*),difl(ldu,*),difr(ldu,*),givnum(ldu,*),poles(ldu,& *),s(*),u(ldu,*),vt(ldu,*),z(ldu,*) end subroutine slalsa -#else - module procedure stdlib_slalsa +#else + module procedure stdlib${ii}$_slalsa #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lalsa - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlalsa( icompq, smlsiz, n, nrhs, b, ldb, bx, ldbx, u,ldu, vt, k, & difl, difr, z, poles, givptr,givcol, ldgcol, perm, givnum, c, s, rwork,iwork, info & ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: icompq,ldb,ldbx,ldgcol,ldu,n,nrhs,smlsiz,givcol(& + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: icompq,ldb,ldbx,ldgcol,ldu,n,nrhs,smlsiz,givcol(& ldgcol,*),givptr(*),k(*),perm(ldgcol,*) - integer(ilp), intent(out) :: info,iwork(*) + integer(${ik}$), intent(out) :: info,iwork(*) real(dp), intent(in) :: c(*),difl(ldu,*),difr(ldu,*),givnum(ldu,*),poles(ldu,& *),s(*),u(ldu,*),vt(ldu,*),z(ldu,*) real(dp), intent(out) :: rwork(*) complex(dp), intent(inout) :: b(ldb,*) complex(dp), intent(out) :: bx(ldbx,*) end subroutine zlalsa -#else - module procedure stdlib_zlalsa +#else + module procedure stdlib${ii}$_zlalsa #endif - end interface lalsa +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lalsa +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lalsa +#:endif +#:endfor +#:endfor + end interface lalsa interface lalsd !! LALSD uses the singular value decomposition of A to solve the least @@ -11546,122 +11515,122 @@ module stdlib_linalg_lapack !! which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. !! It could conceivably fail on hexadecimal or decimal machines !! without guard digits, but we know of none. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clalsd( uplo, smlsiz, n, nrhs, d, e, b, ldb, rcond,rank, work, & rwork, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,rank,iwork(*) - integer(ilp), intent(in) :: ldb,n,nrhs,smlsiz + integer(${ik}$), intent(out) :: info,rank,iwork(*) + integer(${ik}$), intent(in) :: ldb,n,nrhs,smlsiz real(sp), intent(in) :: rcond real(sp), intent(inout) :: d(*),e(*) real(sp), intent(out) :: rwork(*) complex(sp), intent(inout) :: b(ldb,*) complex(sp), intent(out) :: work(*) end subroutine clalsd -#else - module procedure stdlib_clalsd +#else + module procedure stdlib${ii}$_clalsd #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlalsd( uplo, smlsiz, n, nrhs, d, e, b, ldb, rcond,rank, work, & iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,rank,iwork(*) - integer(ilp), intent(in) :: ldb,n,nrhs,smlsiz + integer(${ik}$), intent(out) :: info,rank,iwork(*) + integer(${ik}$), intent(in) :: ldb,n,nrhs,smlsiz real(dp), intent(in) :: rcond - real(dp), intent(inout) :: b(ldb,*),d(*),e(*) - real(dp), intent(out) :: work(*) - end subroutine dlalsd -#else - module procedure stdlib_dlalsd -#endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lalsd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK + real(dp), intent(inout) :: b(ldb,*),d(*),e(*) + real(dp), intent(out) :: work(*) + end subroutine dlalsd +#else + module procedure stdlib${ii}$_dlalsd +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slalsd( uplo, smlsiz, n, nrhs, d, e, b, ldb, rcond,rank, work, & iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,rank,iwork(*) - integer(ilp), intent(in) :: ldb,n,nrhs,smlsiz + integer(${ik}$), intent(out) :: info,rank,iwork(*) + integer(${ik}$), intent(in) :: ldb,n,nrhs,smlsiz real(sp), intent(in) :: rcond real(sp), intent(inout) :: b(ldb,*),d(*),e(*) real(sp), intent(out) :: work(*) end subroutine slalsd -#else - module procedure stdlib_slalsd +#else + module procedure stdlib${ii}$_slalsd #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lalsd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlalsd( uplo, smlsiz, n, nrhs, d, e, b, ldb, rcond,rank, work, & rwork, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,rank,iwork(*) - integer(ilp), intent(in) :: ldb,n,nrhs,smlsiz + integer(${ik}$), intent(out) :: info,rank,iwork(*) + integer(${ik}$), intent(in) :: ldb,n,nrhs,smlsiz real(dp), intent(in) :: rcond real(dp), intent(inout) :: d(*),e(*) real(dp), intent(out) :: rwork(*) complex(dp), intent(inout) :: b(ldb,*) complex(dp), intent(out) :: work(*) end subroutine zlalsd -#else - module procedure stdlib_zlalsd +#else + module procedure stdlib${ii}$_zlalsd #endif - end interface lalsd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lalsd +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lalsd +#:endif +#:endfor +#:endfor + end interface lalsd interface lamrg !! LAMRG 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. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlamrg( n1, n2, a, dtrd1, dtrd2, index ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: dtrd1,dtrd2,n1,n2 - integer(ilp), intent(out) :: index(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: dtrd1,dtrd2,n1,n2 + integer(${ik}$), intent(out) :: index(*) real(dp), intent(in) :: a(*) end subroutine dlamrg -#else - module procedure stdlib_dlamrg +#else + module procedure stdlib${ii}$_dlamrg +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine slamrg( n1, n2, a, strd1, strd2, index ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: n1,n2,strd1,strd2 + integer(${ik}$), intent(out) :: index(*) + real(sp), intent(in) :: a(*) + end subroutine slamrg +#else + module procedure stdlib${ii}$_slamrg #endif #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lamrg + module procedure stdlib${ii}$_${ri}$lamrg #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine slamrg( n1, n2, a, strd1, strd2, index ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: n1,n2,strd1,strd2 - integer(ilp), intent(out) :: index(*) - real(sp), intent(in) :: a(*) - end subroutine slamrg -#else - module procedure stdlib_slamrg -#endif +#:endfor end interface lamrg - - interface lamswlq !! LAMSWLQ overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' @@ -11670,81 +11639,81 @@ module stdlib_linalg_lapack !! where Q is a complex unitary matrix defined as the product of blocked !! elementary reflectors computed by short wide LQ !! factorization (CLASWLQ) -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clamswlq( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, & work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,k,mb,nb,ldt,lwork,ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,k,mb,nb,ldt,lwork,ldc complex(sp), intent(in) :: a(lda,*),t(ldt,*) complex(sp), intent(out) :: work(*) complex(sp), intent(inout) :: c(ldc,*) end subroutine clamswlq -#else - module procedure stdlib_clamswlq +#else + module procedure stdlib${ii}$_clamswlq #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlamswlq( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, & work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,k,mb,nb,ldt,lwork,ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,k,mb,nb,ldt,lwork,ldc real(dp), intent(in) :: a(lda,*),t(ldt,*) real(dp), intent(out) :: work(*) real(dp), intent(inout) :: c(ldc,*) end subroutine dlamswlq -#else - module procedure stdlib_dlamswlq +#else + module procedure stdlib${ii}$_dlamswlq #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lamswlq - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slamswlq( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, & work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,k,mb,nb,ldt,lwork,ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,k,mb,nb,ldt,lwork,ldc real(sp), intent(in) :: a(lda,*),t(ldt,*) real(sp), intent(out) :: work(*) real(sp), intent(inout) :: c(ldc,*) end subroutine slamswlq -#else - module procedure stdlib_slamswlq +#else + module procedure stdlib${ii}$_slamswlq #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lamswlq - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlamswlq( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, & work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,k,mb,nb,ldt,lwork,ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,k,mb,nb,ldt,lwork,ldc complex(dp), intent(in) :: a(lda,*),t(ldt,*) complex(dp), intent(out) :: work(*) complex(dp), intent(inout) :: c(ldc,*) end subroutine zlamswlq -#else - module procedure stdlib_zlamswlq +#else + module procedure stdlib${ii}$_zlamswlq #endif - end interface lamswlq +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lamswlq +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lamswlq +#:endif +#:endfor +#:endfor + end interface lamswlq interface lamtsqr !! LAMTSQR overwrites the general complex M-by-N matrix C with @@ -11754,81 +11723,81 @@ module stdlib_linalg_lapack !! where Q is a complex unitary matrix defined as the product !! of blocked elementary reflectors computed by tall skinny !! QR factorization (CLATSQR) -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, & work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,k,mb,nb,ldt,lwork,ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,k,mb,nb,ldt,lwork,ldc complex(sp), intent(in) :: a(lda,*),t(ldt,*) complex(sp), intent(out) :: work(*) complex(sp), intent(inout) :: c(ldc,*) end subroutine clamtsqr -#else - module procedure stdlib_clamtsqr +#else + module procedure stdlib${ii}$_clamtsqr #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, & work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,k,mb,nb,ldt,lwork,ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,k,mb,nb,ldt,lwork,ldc real(dp), intent(in) :: a(lda,*),t(ldt,*) real(dp), intent(out) :: work(*) real(dp), intent(inout) :: c(ldc,*) end subroutine dlamtsqr -#else - module procedure stdlib_dlamtsqr +#else + module procedure stdlib${ii}$_dlamtsqr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lamtsqr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, & work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,k,mb,nb,ldt,lwork,ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,k,mb,nb,ldt,lwork,ldc real(sp), intent(in) :: a(lda,*),t(ldt,*) real(sp), intent(out) :: work(*) real(sp), intent(inout) :: c(ldc,*) end subroutine slamtsqr -#else - module procedure stdlib_slamtsqr +#else + module procedure stdlib${ii}$_slamtsqr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lamtsqr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, & work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,k,mb,nb,ldt,lwork,ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,k,mb,nb,ldt,lwork,ldc complex(dp), intent(in) :: a(lda,*),t(ldt,*) complex(dp), intent(out) :: work(*) complex(dp), intent(inout) :: c(ldc,*) end subroutine zlamtsqr -#else - module procedure stdlib_zlamtsqr +#else + module procedure stdlib${ii}$_zlamtsqr #endif - end interface lamtsqr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lamtsqr +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lamtsqr +#:endif +#:endfor +#:endfor + end interface lamtsqr interface laneg !! LANEG computes the Sturm count, the number of negative pivots @@ -11846,977 +11815,977 @@ module stdlib_linalg_lapack !! 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.) -#ifdef STDLIB_EXTERNAL_LAPACK - pure integer(ilp) function dlaneg( n, d, lld, sigma, pivmin, r ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: n,r +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure integer(${ik}$) function dlaneg( n, d, lld, sigma, pivmin, r ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: n,r real(dp), intent(in) :: pivmin,sigma,d(*),lld(*) end function dlaneg -#else - module procedure stdlib_dlaneg +#else + module procedure stdlib${ii}$_dlaneg +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure integer(${ik}$) function slaneg( n, d, lld, sigma, pivmin, r ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: n,r + real(sp), intent(in) :: pivmin,sigma,d(*),lld(*) + end function slaneg +#else + module procedure stdlib${ii}$_slaneg #endif #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laneg + module procedure stdlib${ii}$_${ri}$laneg #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure integer(ilp) function slaneg( n, d, lld, sigma, pivmin, r ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: n,r - real(sp), intent(in) :: pivmin,sigma,d(*),lld(*) - end function slaneg -#else - module procedure stdlib_slaneg -#endif +#:endfor end interface laneg - - interface langb !! LANGB returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of an !! n by n band matrix A, with kl sub-diagonals and ku super-diagonals. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function clangb( norm, n, kl, ku, ab, ldab,work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(in) :: kl,ku,ldab,n + integer(${ik}$), intent(in) :: kl,ku,ldab,n real(sp), intent(out) :: work(*) complex(sp), intent(in) :: ab(ldab,*) end function clangb -#else - module procedure stdlib_clangb +#else + module procedure stdlib${ii}$_clangb #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function dlangb( norm, n, kl, ku, ab, ldab,work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(in) :: kl,ku,ldab,n + integer(${ik}$), intent(in) :: kl,ku,ldab,n real(dp), intent(in) :: ab(ldab,*) real(dp), intent(out) :: work(*) end function dlangb -#else - module procedure stdlib_dlangb +#else + module procedure stdlib${ii}$_dlangb #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$langb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function slangb( norm, n, kl, ku, ab, ldab,work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(in) :: kl,ku,ldab,n + integer(${ik}$), intent(in) :: kl,ku,ldab,n real(sp), intent(in) :: ab(ldab,*) real(sp), intent(out) :: work(*) end function slangb -#else - module procedure stdlib_slangb +#else + module procedure stdlib${ii}$_slangb #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$langb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function zlangb( norm, n, kl, ku, ab, ldab,work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(in) :: kl,ku,ldab,n + integer(${ik}$), intent(in) :: kl,ku,ldab,n real(dp), intent(out) :: work(*) complex(dp), intent(in) :: ab(ldab,*) end function zlangb -#else - module procedure stdlib_zlangb +#else + module procedure stdlib${ii}$_zlangb #endif - end interface langb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$langb +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$langb +#:endif +#:endfor +#:endfor + end interface langb interface lange !! LANGE returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! complex matrix A. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function clange( norm, m, n, a, lda, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(in) :: lda,m,n + integer(${ik}$), intent(in) :: lda,m,n real(sp), intent(out) :: work(*) complex(sp), intent(in) :: a(lda,*) end function clange -#else - module procedure stdlib_clange +#else + module procedure stdlib${ii}$_clange #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function dlange( norm, m, n, a, lda, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(in) :: lda,m,n + integer(${ik}$), intent(in) :: lda,m,n real(dp), intent(in) :: a(lda,*) real(dp), intent(out) :: work(*) end function dlange -#else - module procedure stdlib_dlange +#else + module procedure stdlib${ii}$_dlange #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lange - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function slange( norm, m, n, a, lda, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(in) :: lda,m,n + integer(${ik}$), intent(in) :: lda,m,n real(sp), intent(in) :: a(lda,*) real(sp), intent(out) :: work(*) end function slange -#else - module procedure stdlib_slange +#else + module procedure stdlib${ii}$_slange #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lange - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function zlange( norm, m, n, a, lda, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(in) :: lda,m,n + integer(${ik}$), intent(in) :: lda,m,n real(dp), intent(out) :: work(*) complex(dp), intent(in) :: a(lda,*) end function zlange -#else - module procedure stdlib_zlange +#else + module procedure stdlib${ii}$_zlange #endif - end interface lange +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lange +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lange +#:endif +#:endfor +#:endfor + end interface lange interface langt !! LANGT returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! complex tridiagonal matrix A. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure real(sp) function clangt( norm, n, dl, d, du ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n complex(sp), intent(in) :: d(*),dl(*),du(*) end function clangt -#else - module procedure stdlib_clangt +#else + module procedure stdlib${ii}$_clangt #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure real(dp) function dlangt( norm, n, dl, d, du ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(dp), intent(in) :: d(*),dl(*),du(*) end function dlangt -#else - module procedure stdlib_dlangt +#else + module procedure stdlib${ii}$_dlangt #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$langt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure real(sp) function slangt( norm, n, dl, d, du ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(sp), intent(in) :: d(*),dl(*),du(*) end function slangt -#else - module procedure stdlib_slangt +#else + module procedure stdlib${ii}$_slangt #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$langt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure real(dp) function zlangt( norm, n, dl, d, du ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n complex(dp), intent(in) :: d(*),dl(*),du(*) end function zlangt -#else - module procedure stdlib_zlangt +#else + module procedure stdlib${ii}$_zlangt #endif - end interface langt +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$langt +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$langt +#:endif +#:endfor +#:endfor + end interface langt interface lanhb !! LANHB returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of an !! n by n hermitian band matrix A, with k super-diagonals. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function clanhb( norm, uplo, n, k, ab, ldab,work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm,uplo - integer(ilp), intent(in) :: k,ldab,n + integer(${ik}$), intent(in) :: k,ldab,n real(sp), intent(out) :: work(*) complex(sp), intent(in) :: ab(ldab,*) end function clanhb -#else - module procedure stdlib_clanhb +#else + module procedure stdlib${ii}$_clanhb #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lanhb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function zlanhb( norm, uplo, n, k, ab, ldab,work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm,uplo - integer(ilp), intent(in) :: k,ldab,n + integer(${ik}$), intent(in) :: k,ldab,n real(dp), intent(out) :: work(*) complex(dp), intent(in) :: ab(ldab,*) end function zlanhb -#else - module procedure stdlib_zlanhb +#else + module procedure stdlib${ii}$_zlanhb #endif - end interface lanhb - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lanhb +#:endif +#:endfor +#:endfor + end interface lanhb interface lanhe !! LANHE returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! complex hermitian matrix A. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function clanhe( norm, uplo, n, a, lda, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm,uplo - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(in) :: lda,n real(sp), intent(out) :: work(*) complex(sp), intent(in) :: a(lda,*) end function clanhe -#else - module procedure stdlib_clanhe +#else + module procedure stdlib${ii}$_clanhe #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lanhe - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function zlanhe( norm, uplo, n, a, lda, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm,uplo - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(in) :: lda,n real(dp), intent(out) :: work(*) complex(dp), intent(in) :: a(lda,*) end function zlanhe -#else - module procedure stdlib_zlanhe +#else + module procedure stdlib${ii}$_zlanhe #endif - end interface lanhe - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lanhe +#:endif +#:endfor +#:endfor + end interface lanhe interface lanhf !! LANHF returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! complex Hermitian matrix A in RFP format. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function clanhf( norm, transr, uplo, n, a, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm,transr,uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(sp), intent(out) :: work(0:*) complex(sp), intent(in) :: a(0:*) end function clanhf -#else - module procedure stdlib_clanhf +#else + module procedure stdlib${ii}$_clanhf #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lanhf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function zlanhf( norm, transr, uplo, n, a, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm,transr,uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(dp), intent(out) :: work(0:*) complex(dp), intent(in) :: a(0:*) end function zlanhf -#else - module procedure stdlib_zlanhf +#else + module procedure stdlib${ii}$_zlanhf #endif - end interface lanhf - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lanhf +#:endif +#:endfor +#:endfor + end interface lanhf interface lanhp !! LANHP returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! complex hermitian matrix A, supplied in packed form. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function clanhp( norm, uplo, n, ap, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm,uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(sp), intent(out) :: work(*) complex(sp), intent(in) :: ap(*) end function clanhp -#else - module procedure stdlib_clanhp +#else + module procedure stdlib${ii}$_clanhp #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lanhp - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function zlanhp( norm, uplo, n, ap, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm,uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(dp), intent(out) :: work(*) complex(dp), intent(in) :: ap(*) end function zlanhp -#else - module procedure stdlib_zlanhp +#else + module procedure stdlib${ii}$_zlanhp #endif - end interface lanhp - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lanhp +#:endif +#:endfor +#:endfor + end interface lanhp interface lanhs !! LANHS 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. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function clanhs( norm, n, a, lda, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(in) :: lda,n real(sp), intent(out) :: work(*) complex(sp), intent(in) :: a(lda,*) end function clanhs -#else - module procedure stdlib_clanhs +#else + module procedure stdlib${ii}$_clanhs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function dlanhs( norm, n, a, lda, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(in) :: lda,n real(dp), intent(in) :: a(lda,*) real(dp), intent(out) :: work(*) end function dlanhs -#else - module procedure stdlib_dlanhs +#else + module procedure stdlib${ii}$_dlanhs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lanhs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function slanhs( norm, n, a, lda, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(in) :: lda,n real(sp), intent(in) :: a(lda,*) real(sp), intent(out) :: work(*) end function slanhs -#else - module procedure stdlib_slanhs +#else + module procedure stdlib${ii}$_slanhs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lanhs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function zlanhs( norm, n, a, lda, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(in) :: lda,n real(dp), intent(out) :: work(*) complex(dp), intent(in) :: a(lda,*) end function zlanhs -#else - module procedure stdlib_zlanhs +#else + module procedure stdlib${ii}$_zlanhs #endif - end interface lanhs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lanhs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lanhs +#:endif +#:endfor +#:endfor + end interface lanhs interface lanht !! LANHT returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! complex Hermitian tridiagonal matrix A. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure real(sp) function clanht( norm, n, d, e ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(sp), intent(in) :: d(*) complex(sp), intent(in) :: e(*) end function clanht -#else - module procedure stdlib_clanht +#else + module procedure stdlib${ii}$_clanht #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lanht - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure real(dp) function zlanht( norm, n, d, e ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(dp), intent(in) :: d(*) complex(dp), intent(in) :: e(*) end function zlanht -#else - module procedure stdlib_zlanht +#else + module procedure stdlib${ii}$_zlanht #endif - end interface lanht - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lanht +#:endif +#:endfor +#:endfor + end interface lanht interface lansb !! LANSB 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. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function clansb( norm, uplo, n, k, ab, ldab,work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm,uplo - integer(ilp), intent(in) :: k,ldab,n + integer(${ik}$), intent(in) :: k,ldab,n real(sp), intent(out) :: work(*) complex(sp), intent(in) :: ab(ldab,*) end function clansb -#else - module procedure stdlib_clansb +#else + module procedure stdlib${ii}$_clansb #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function dlansb( norm, uplo, n, k, ab, ldab,work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm,uplo - integer(ilp), intent(in) :: k,ldab,n + integer(${ik}$), intent(in) :: k,ldab,n real(dp), intent(in) :: ab(ldab,*) real(dp), intent(out) :: work(*) end function dlansb -#else - module procedure stdlib_dlansb +#else + module procedure stdlib${ii}$_dlansb #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lansb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function slansb( norm, uplo, n, k, ab, ldab,work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm,uplo - integer(ilp), intent(in) :: k,ldab,n + integer(${ik}$), intent(in) :: k,ldab,n real(sp), intent(in) :: ab(ldab,*) real(sp), intent(out) :: work(*) end function slansb -#else - module procedure stdlib_slansb +#else + module procedure stdlib${ii}$_slansb #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lansb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function zlansb( norm, uplo, n, k, ab, ldab,work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm,uplo - integer(ilp), intent(in) :: k,ldab,n + integer(${ik}$), intent(in) :: k,ldab,n real(dp), intent(out) :: work(*) complex(dp), intent(in) :: ab(ldab,*) end function zlansb -#else - module procedure stdlib_zlansb +#else + module procedure stdlib${ii}$_zlansb #endif - end interface lansb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lansb +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lansb +#:endif +#:endfor +#:endfor + end interface lansb interface lansf !! LANSF 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. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function dlansf( norm, transr, uplo, n, a, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm,transr,uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(dp), intent(in) :: a(0:*) real(dp), intent(out) :: work(0:*) end function dlansf -#else - module procedure stdlib_dlansf +#else + module procedure stdlib${ii}$_dlansf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lansf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function slansf( norm, transr, uplo, n, a, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm,transr,uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(sp), intent(in) :: a(0:*) real(sp), intent(out) :: work(0:*) end function slansf -#else - module procedure stdlib_slansf +#else + module procedure stdlib${ii}$_slansf #endif - end interface lansf - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lansf +#:endif +#:endfor +#:endfor + end interface lansf interface lansp !! LANSP returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! complex symmetric matrix A, supplied in packed form. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function clansp( norm, uplo, n, ap, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm,uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(sp), intent(out) :: work(*) complex(sp), intent(in) :: ap(*) end function clansp -#else - module procedure stdlib_clansp +#else + module procedure stdlib${ii}$_clansp #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function dlansp( norm, uplo, n, ap, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm,uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(dp), intent(in) :: ap(*) real(dp), intent(out) :: work(*) end function dlansp -#else - module procedure stdlib_dlansp +#else + module procedure stdlib${ii}$_dlansp #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lansp - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function slansp( norm, uplo, n, ap, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm,uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(sp), intent(in) :: ap(*) real(sp), intent(out) :: work(*) end function slansp -#else - module procedure stdlib_slansp +#else + module procedure stdlib${ii}$_slansp #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lansp - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function zlansp( norm, uplo, n, ap, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm,uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(dp), intent(out) :: work(*) complex(dp), intent(in) :: ap(*) end function zlansp -#else - module procedure stdlib_zlansp +#else + module procedure stdlib${ii}$_zlansp #endif - end interface lansp +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lansp +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lansp +#:endif +#:endfor +#:endfor + end interface lansp interface lanst !! LANST returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! real symmetric tridiagonal matrix A. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure real(dp) function dlanst( norm, n, d, e ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(dp), intent(in) :: d(*),e(*) end function dlanst -#else - module procedure stdlib_dlanst +#else + module procedure stdlib${ii}$_dlanst #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lanst - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure real(sp) function slanst( norm, n, d, e ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(sp), intent(in) :: d(*),e(*) end function slanst -#else - module procedure stdlib_slanst +#else + module procedure stdlib${ii}$_slanst #endif - end interface lanst - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lanst +#:endif +#:endfor +#:endfor + end interface lanst interface lansy !! LANSY returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! complex symmetric matrix A. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function clansy( norm, uplo, n, a, lda, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm,uplo - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(in) :: lda,n real(sp), intent(out) :: work(*) complex(sp), intent(in) :: a(lda,*) end function clansy -#else - module procedure stdlib_clansy +#else + module procedure stdlib${ii}$_clansy #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function dlansy( norm, uplo, n, a, lda, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm,uplo - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(in) :: lda,n real(dp), intent(in) :: a(lda,*) real(dp), intent(out) :: work(*) end function dlansy -#else - module procedure stdlib_dlansy +#else + module procedure stdlib${ii}$_dlansy #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lansy - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function slansy( norm, uplo, n, a, lda, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm,uplo - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(in) :: lda,n real(sp), intent(in) :: a(lda,*) real(sp), intent(out) :: work(*) end function slansy -#else - module procedure stdlib_slansy +#else + module procedure stdlib${ii}$_slansy #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lansy - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function zlansy( norm, uplo, n, a, lda, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: norm,uplo - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(in) :: lda,n real(dp), intent(out) :: work(*) complex(dp), intent(in) :: a(lda,*) end function zlansy -#else - module procedure stdlib_zlansy +#else + module procedure stdlib${ii}$_zlansy #endif - end interface lansy +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lansy +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lansy +#:endif +#:endfor +#:endfor + end interface lansy interface lantb !! LANTB 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. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function clantb( norm, uplo, diag, n, k, ab,ldab, work ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,norm,uplo - integer(ilp), intent(in) :: k,ldab,n + integer(${ik}$), intent(in) :: k,ldab,n real(sp), intent(out) :: work(*) complex(sp), intent(in) :: ab(ldab,*) end function clantb -#else - module procedure stdlib_clantb +#else + module procedure stdlib${ii}$_clantb #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function dlantb( norm, uplo, diag, n, k, ab,ldab, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,norm,uplo - integer(ilp), intent(in) :: k,ldab,n + integer(${ik}$), intent(in) :: k,ldab,n real(dp), intent(in) :: ab(ldab,*) real(dp), intent(out) :: work(*) end function dlantb -#else - module procedure stdlib_dlantb +#else + module procedure stdlib${ii}$_dlantb #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lantb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function slantb( norm, uplo, diag, n, k, ab,ldab, work ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,norm,uplo - integer(ilp), intent(in) :: k,ldab,n + integer(${ik}$), intent(in) :: k,ldab,n real(sp), intent(in) :: ab(ldab,*) real(sp), intent(out) :: work(*) end function slantb -#else - module procedure stdlib_slantb +#else + module procedure stdlib${ii}$_slantb #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lantb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function zlantb( norm, uplo, diag, n, k, ab,ldab, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,norm,uplo - integer(ilp), intent(in) :: k,ldab,n + integer(${ik}$), intent(in) :: k,ldab,n real(dp), intent(out) :: work(*) complex(dp), intent(in) :: ab(ldab,*) end function zlantb -#else - module procedure stdlib_zlantb +#else + module procedure stdlib${ii}$_zlantb #endif - end interface lantb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lantb +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lantb +#:endif +#:endfor +#:endfor + end interface lantb interface lantp !! LANTP 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. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function clantp( norm, uplo, diag, n, ap, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,norm,uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(sp), intent(out) :: work(*) complex(sp), intent(in) :: ap(*) end function clantp -#else - module procedure stdlib_clantp +#else + module procedure stdlib${ii}$_clantp #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function dlantp( norm, uplo, diag, n, ap, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,norm,uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(dp), intent(in) :: ap(*) real(dp), intent(out) :: work(*) end function dlantp -#else - module procedure stdlib_dlantp +#else + module procedure stdlib${ii}$_dlantp #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lantp - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function slantp( norm, uplo, diag, n, ap, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,norm,uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(sp), intent(in) :: ap(*) real(sp), intent(out) :: work(*) end function slantp -#else - module procedure stdlib_slantp +#else + module procedure stdlib${ii}$_slantp #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lantp - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function zlantp( norm, uplo, diag, n, ap, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,norm,uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(dp), intent(out) :: work(*) complex(dp), intent(in) :: ap(*) end function zlantp -#else - module procedure stdlib_zlantp +#else + module procedure stdlib${ii}$_zlantp #endif - end interface lantp +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lantp +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lantp +#:endif +#:endfor +#:endfor + end interface lantp interface lantr !! LANTR 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. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function clantr( norm, uplo, diag, m, n, a, lda,work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,norm,uplo - integer(ilp), intent(in) :: lda,m,n + integer(${ik}$), intent(in) :: lda,m,n real(sp), intent(out) :: work(*) complex(sp), intent(in) :: a(lda,*) end function clantr -#else - module procedure stdlib_clantr +#else + module procedure stdlib${ii}$_clantr #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function dlantr( norm, uplo, diag, m, n, a, lda,work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,norm,uplo - integer(ilp), intent(in) :: lda,m,n + integer(${ik}$), intent(in) :: lda,m,n real(dp), intent(in) :: a(lda,*) real(dp), intent(out) :: work(*) end function dlantr -#else - module procedure stdlib_dlantr +#else + module procedure stdlib${ii}$_dlantr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lantr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(sp) function slantr( norm, uplo, diag, m, n, a, lda,work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,norm,uplo - integer(ilp), intent(in) :: lda,m,n + integer(${ik}$), intent(in) :: lda,m,n real(sp), intent(in) :: a(lda,*) real(sp), intent(out) :: work(*) end function slantr -#else - module procedure stdlib_slantr +#else + module procedure stdlib${ii}$_slantr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lantr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ real(dp) function zlantr( norm, uplo, diag, m, n, a, lda,work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,norm,uplo - integer(ilp), intent(in) :: lda,m,n + integer(${ik}$), intent(in) :: lda,m,n real(dp), intent(out) :: work(*) complex(dp), intent(in) :: a(lda,*) end function zlantr -#else - module procedure stdlib_zlantr +#else + module procedure stdlib${ii}$_zlantr #endif - end interface lantr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lantr +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lantr +#:endif +#:endfor +#:endfor + end interface lantr interface laorhr_col_getrfnp !! LAORHR_COL_GETRFNP computes the modified LU factorization without @@ -12852,39 +12821,39 @@ module stdlib_linalg_lapack !! G. Ballard, J. Demmel, L. Grigori, M. Jacquelin, H.D. Nguyen, !! E. Solomonik, J. Parallel Distrib. Comput., !! vol. 85, pp. 3-31, 2015. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaorhr_col_getrfnp( m, n, a, lda, d, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: d(*) end subroutine dlaorhr_col_getrfnp -#else - module procedure stdlib_dlaorhr_col_getrfnp +#else + module procedure stdlib${ii}$_dlaorhr_col_getrfnp #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laorhr_col_getrfnp - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaorhr_col_getrfnp( m, n, a, lda, d, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: d(*) end subroutine slaorhr_col_getrfnp -#else - module procedure stdlib_slaorhr_col_getrfnp +#else + module procedure stdlib${ii}$_slaorhr_col_getrfnp #endif - end interface laorhr_col_getrfnp - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laorhr_col_getrfnp +#:endif +#:endfor +#:endfor + end interface laorhr_col_getrfnp interface laorhr_col_getrfnp2 !! LAORHR_COL_GETRFNP2 computes the modified LU factorization without @@ -12935,39 +12904,39 @@ module stdlib_linalg_lapack !! [2] "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. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure recursive subroutine dlaorhr_col_getrfnp2( m, n, a, lda, d, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: d(*) end subroutine dlaorhr_col_getrfnp2 -#else - module procedure stdlib_dlaorhr_col_getrfnp2 +#else + module procedure stdlib${ii}$_dlaorhr_col_getrfnp2 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laorhr_col_getrfnp2 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure recursive subroutine slaorhr_col_getrfnp2( m, n, a, lda, d, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: d(*) end subroutine slaorhr_col_getrfnp2 -#else - module procedure stdlib_slaorhr_col_getrfnp2 +#else + module procedure stdlib${ii}$_slaorhr_col_getrfnp2 #endif - end interface laorhr_col_getrfnp2 - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laorhr_col_getrfnp2 +#:endif +#:endfor +#:endfor + end interface laorhr_col_getrfnp2 interface lapll !! Given two column vectors X and Y, let @@ -12976,65 +12945,65 @@ module stdlib_linalg_lapack !! and then computes the SVD of the 2-by-2 upper triangular matrix R. !! The smaller singular value of R is returned in SSMIN, which is used !! as the measurement of the linear dependency of the vectors X and Y. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clapll( n, x, incx, y, incy, ssmin ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n real(sp), intent(out) :: ssmin complex(sp), intent(inout) :: x(*),y(*) end subroutine clapll -#else - module procedure stdlib_clapll +#else + module procedure stdlib${ii}$_clapll #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlapll( n, x, incx, y, incy, ssmin ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n real(dp), intent(out) :: ssmin real(dp), intent(inout) :: x(*),y(*) end subroutine dlapll -#else - module procedure stdlib_dlapll +#else + module procedure stdlib${ii}$_dlapll #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lapll - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slapll( n, x, incx, y, incy, ssmin ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n real(sp), intent(out) :: ssmin real(sp), intent(inout) :: x(*),y(*) end subroutine slapll -#else - module procedure stdlib_slapll +#else + module procedure stdlib${ii}$_slapll #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lapll - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlapll( n, x, incx, y, incy, ssmin ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n real(dp), intent(out) :: ssmin complex(dp), intent(inout) :: x(*),y(*) end subroutine zlapll -#else - module procedure stdlib_zlapll +#else + module procedure stdlib${ii}$_zlapll #endif - end interface lapll +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lapll +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lapll +#:endif +#:endfor +#:endfor + end interface lapll interface lapmr !! LAPMR rearranges the rows of the M by N matrix X as specified @@ -13043,69 +13012,69 @@ module stdlib_linalg_lapack !! X(K(I),*) is moved X(I,*) for I = 1,2,...,M. !! If FORWRD = .FALSE., backward permutation: !! X(I,*) is moved to X(K(I),*) for I = 1,2,...,M. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clapmr( forwrd, m, n, x, ldx, k ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: forwrd - integer(ilp), intent(in) :: ldx,m,n - integer(ilp), intent(inout) :: k(*) + integer(${ik}$), intent(in) :: ldx,m,n + integer(${ik}$), intent(inout) :: k(*) complex(sp), intent(inout) :: x(ldx,*) end subroutine clapmr -#else - module procedure stdlib_clapmr +#else + module procedure stdlib${ii}$_clapmr #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlapmr( forwrd, m, n, x, ldx, k ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: forwrd - integer(ilp), intent(in) :: ldx,m,n - integer(ilp), intent(inout) :: k(*) + integer(${ik}$), intent(in) :: ldx,m,n + integer(${ik}$), intent(inout) :: k(*) real(dp), intent(inout) :: x(ldx,*) end subroutine dlapmr -#else - module procedure stdlib_dlapmr +#else + module procedure stdlib${ii}$_dlapmr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lapmr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slapmr( forwrd, m, n, x, ldx, k ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: forwrd - integer(ilp), intent(in) :: ldx,m,n - integer(ilp), intent(inout) :: k(*) + integer(${ik}$), intent(in) :: ldx,m,n + integer(${ik}$), intent(inout) :: k(*) real(sp), intent(inout) :: x(ldx,*) end subroutine slapmr -#else - module procedure stdlib_slapmr +#else + module procedure stdlib${ii}$_slapmr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lapmr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlapmr( forwrd, m, n, x, ldx, k ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: forwrd - integer(ilp), intent(in) :: ldx,m,n - integer(ilp), intent(inout) :: k(*) + integer(${ik}$), intent(in) :: ldx,m,n + integer(${ik}$), intent(inout) :: k(*) complex(dp), intent(inout) :: x(ldx,*) end subroutine zlapmr -#else - module procedure stdlib_zlapmr +#else + module procedure stdlib${ii}$_zlapmr #endif - end interface lapmr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lapmr +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lapmr +#:endif +#:endfor +#:endfor + end interface lapmr interface lapmt !! LAPMT rearranges the columns of the M by N matrix X as specified @@ -13114,327 +13083,327 @@ module stdlib_linalg_lapack !! X(*,K(J)) is moved X(*,J) for J = 1,2,...,N. !! If FORWRD = .FALSE., backward permutation: !! X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clapmt( forwrd, m, n, x, ldx, k ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: forwrd - integer(ilp), intent(in) :: ldx,m,n - integer(ilp), intent(inout) :: k(*) + integer(${ik}$), intent(in) :: ldx,m,n + integer(${ik}$), intent(inout) :: k(*) complex(sp), intent(inout) :: x(ldx,*) end subroutine clapmt -#else - module procedure stdlib_clapmt +#else + module procedure stdlib${ii}$_clapmt #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlapmt( forwrd, m, n, x, ldx, k ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: forwrd - integer(ilp), intent(in) :: ldx,m,n - integer(ilp), intent(inout) :: k(*) + integer(${ik}$), intent(in) :: ldx,m,n + integer(${ik}$), intent(inout) :: k(*) real(dp), intent(inout) :: x(ldx,*) end subroutine dlapmt -#else - module procedure stdlib_dlapmt +#else + module procedure stdlib${ii}$_dlapmt #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lapmt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slapmt( forwrd, m, n, x, ldx, k ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: forwrd - integer(ilp), intent(in) :: ldx,m,n - integer(ilp), intent(inout) :: k(*) + integer(${ik}$), intent(in) :: ldx,m,n + integer(${ik}$), intent(inout) :: k(*) real(sp), intent(inout) :: x(ldx,*) end subroutine slapmt -#else - module procedure stdlib_slapmt +#else + module procedure stdlib${ii}$_slapmt #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lapmt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlapmt( forwrd, m, n, x, ldx, k ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: forwrd - integer(ilp), intent(in) :: ldx,m,n - integer(ilp), intent(inout) :: k(*) + integer(${ik}$), intent(in) :: ldx,m,n + integer(${ik}$), intent(inout) :: k(*) complex(dp), intent(inout) :: x(ldx,*) end subroutine zlapmt -#else - module procedure stdlib_zlapmt +#else + module procedure stdlib${ii}$_zlapmt #endif - end interface lapmt +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lapmt +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lapmt +#:endif +#:endfor +#:endfor + end interface lapmt interface laqgb !! LAQGB 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. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine claqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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,c(*),r(*) complex(sp), intent(inout) :: ab(ldab,*) end subroutine claqgb -#else - module procedure stdlib_claqgb +#else + module procedure stdlib${ii}$_claqgb #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(out) :: equed - integer(ilp), intent(in) :: kl,ku,ldab,m,n + integer(${ik}$), intent(in) :: kl,ku,ldab,m,n real(dp), intent(in) :: amax,colcnd,rowcnd,c(*),r(*) real(dp), intent(inout) :: ab(ldab,*) end subroutine dlaqgb -#else - module procedure stdlib_dlaqgb +#else + module procedure stdlib${ii}$_dlaqgb #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqgb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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,c(*),r(*) real(sp), intent(inout) :: ab(ldab,*) end subroutine slaqgb -#else - module procedure stdlib_slaqgb +#else + module procedure stdlib${ii}$_slaqgb #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqgb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlaqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(out) :: equed - integer(ilp), intent(in) :: kl,ku,ldab,m,n + integer(${ik}$), intent(in) :: kl,ku,ldab,m,n real(dp), intent(in) :: amax,colcnd,rowcnd,c(*),r(*) complex(dp), intent(inout) :: ab(ldab,*) end subroutine zlaqgb -#else - module procedure stdlib_zlaqgb +#else + module procedure stdlib${ii}$_zlaqgb #endif - end interface laqgb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqgb +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqgb +#:endif +#:endfor +#:endfor + end interface laqgb interface laqge !! LAQGE equilibrates a general M by N matrix A using the row and !! column scaling factors in the vectors R and C. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine claqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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,c(*),r(*) complex(sp), intent(inout) :: a(lda,*) end subroutine claqge -#else - module procedure stdlib_claqge +#else + module procedure stdlib${ii}$_claqge #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(out) :: equed - integer(ilp), intent(in) :: lda,m,n + integer(${ik}$), intent(in) :: lda,m,n real(dp), intent(in) :: amax,colcnd,rowcnd,c(*),r(*) real(dp), intent(inout) :: a(lda,*) end subroutine dlaqge -#else - module procedure stdlib_dlaqge +#else + module procedure stdlib${ii}$_dlaqge #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqge - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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,c(*),r(*) real(sp), intent(inout) :: a(lda,*) end subroutine slaqge -#else - module procedure stdlib_slaqge +#else + module procedure stdlib${ii}$_slaqge #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqge - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlaqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(out) :: equed - integer(ilp), intent(in) :: lda,m,n + integer(${ik}$), intent(in) :: lda,m,n real(dp), intent(in) :: amax,colcnd,rowcnd,c(*),r(*) complex(dp), intent(inout) :: a(lda,*) end subroutine zlaqge -#else - module procedure stdlib_zlaqge +#else + module procedure stdlib${ii}$_zlaqge #endif - end interface laqge +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqge +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqge +#:endif +#:endfor +#:endfor + end interface laqge interface laqhb !! LAQHB equilibrates an Hermitian band matrix A using the scaling !! factors in the vector S. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine claqhb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(out) :: s(*) complex(sp), intent(inout) :: ab(ldab,*) end subroutine claqhb -#else - module procedure stdlib_claqhb +#else + module procedure stdlib${ii}$_claqhb #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqhb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlaqhb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: kd,ldab,n + integer(${ik}$), intent(in) :: kd,ldab,n real(dp), intent(in) :: amax,scond real(dp), intent(out) :: s(*) complex(dp), intent(inout) :: ab(ldab,*) end subroutine zlaqhb -#else - module procedure stdlib_zlaqhb +#else + module procedure stdlib${ii}$_zlaqhb #endif - end interface laqhb - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqhb +#:endif +#:endfor +#:endfor + end interface laqhb interface laqhe !! LAQHE equilibrates a Hermitian matrix A using the scaling factors !! in the vector S. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine claqhe( uplo, n, a, lda, s, scond, amax, equed ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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,s(*) complex(sp), intent(inout) :: a(lda,*) end subroutine claqhe -#else - module procedure stdlib_claqhe +#else + module procedure stdlib${ii}$_claqhe #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqhe - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlaqhe( uplo, n, a, lda, s, scond, amax, equed ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(in) :: lda,n real(dp), intent(in) :: amax,scond,s(*) complex(dp), intent(inout) :: a(lda,*) end subroutine zlaqhe -#else - module procedure stdlib_zlaqhe +#else + module procedure stdlib${ii}$_zlaqhe #endif - end interface laqhe - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqhe +#:endif +#:endfor +#:endfor + end interface laqhe interface laqhp !! LAQHP equilibrates a Hermitian matrix A using the scaling factors !! in the vector S. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine claqhp( uplo, n, ap, s, scond, amax, equed ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(sp), intent(in) :: amax,scond,s(*) complex(sp), intent(inout) :: ap(*) end subroutine claqhp -#else - module procedure stdlib_claqhp +#else + module procedure stdlib${ii}$_claqhp #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqhp - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlaqhp( uplo, n, ap, s, scond, amax, equed ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(dp), intent(in) :: amax,scond,s(*) complex(dp), intent(inout) :: ap(*) end subroutine zlaqhp -#else - module procedure stdlib_zlaqhp +#else + module procedure stdlib${ii}$_zlaqhp #endif - end interface laqhp - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqhp +#:endif +#:endfor +#:endfor + end interface laqhp interface laqps !! LAQPS computes a step of QR factorization with column pivoting @@ -13445,79 +13414,79 @@ module stdlib_linalg_lapack !! factorize NB columns. Hence, the actual number of factorized !! columns is returned in KB. !! Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine claqps( m, n, offset, nb, kb, a, lda, jpvt, tau, vn1,vn2, auxv, f, & ldf ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: kb - integer(ilp), intent(in) :: lda,ldf,m,n,nb,offset - integer(ilp), intent(inout) :: jpvt(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: kb + integer(${ik}$), intent(in) :: lda,ldf,m,n,nb,offset + integer(${ik}$), intent(inout) :: jpvt(*) real(sp), intent(inout) :: vn1(*),vn2(*) complex(sp), intent(inout) :: a(lda,*),auxv(*),f(ldf,*) complex(sp), intent(out) :: tau(*) end subroutine claqps -#else - module procedure stdlib_claqps +#else + module procedure stdlib${ii}$_claqps #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaqps( m, n, offset, nb, kb, a, lda, jpvt, tau, vn1,vn2, auxv, f, & ldf ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: kb - integer(ilp), intent(in) :: lda,ldf,m,n,nb,offset - integer(ilp), intent(inout) :: jpvt(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: kb + integer(${ik}$), intent(in) :: lda,ldf,m,n,nb,offset + integer(${ik}$), intent(inout) :: jpvt(*) real(dp), intent(inout) :: a(lda,*),auxv(*),f(ldf,*),vn1(*),vn2(*) real(dp), intent(out) :: tau(*) end subroutine dlaqps -#else - module procedure stdlib_dlaqps +#else + module procedure stdlib${ii}$_dlaqps #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqps - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaqps( m, n, offset, nb, kb, a, lda, jpvt, tau, vn1,vn2, auxv, f, & ldf ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: kb - integer(ilp), intent(in) :: lda,ldf,m,n,nb,offset - integer(ilp), intent(inout) :: jpvt(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: kb + integer(${ik}$), intent(in) :: lda,ldf,m,n,nb,offset + integer(${ik}$), intent(inout) :: jpvt(*) real(sp), intent(inout) :: a(lda,*),auxv(*),f(ldf,*),vn1(*),vn2(*) real(sp), intent(out) :: tau(*) end subroutine slaqps -#else - module procedure stdlib_slaqps +#else + module procedure stdlib${ii}$_slaqps #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqps - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlaqps( m, n, offset, nb, kb, a, lda, jpvt, tau, vn1,vn2, auxv, f, & ldf ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: kb - integer(ilp), intent(in) :: lda,ldf,m,n,nb,offset - integer(ilp), intent(inout) :: jpvt(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: kb + integer(${ik}$), intent(in) :: lda,ldf,m,n,nb,offset + integer(${ik}$), intent(inout) :: jpvt(*) real(dp), intent(inout) :: vn1(*),vn2(*) complex(dp), intent(inout) :: a(lda,*),auxv(*),f(ldf,*) complex(dp), intent(out) :: tau(*) end subroutine zlaqps -#else - module procedure stdlib_zlaqps +#else + module procedure stdlib${ii}$_zlaqps #endif - end interface laqps +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqps +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqps +#:endif +#:endfor +#:endfor + end interface laqps interface laqr0 !! LAQR0 computes the eigenvalues of a Hessenberg matrix H @@ -13528,77 +13497,77 @@ module stdlib_linalg_lapack !! matrix Q so that this routine can give the Schur factorization !! of a matrix A which has been reduced to the Hessenberg form H !! by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine claqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, & work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihi,ihiz,ilo,iloz,ldh,ldz,lwork,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihi,ihiz,ilo,iloz,ldh,ldz,lwork,n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt,wantz complex(sp), intent(inout) :: h(ldh,*),z(ldz,*) complex(sp), intent(out) :: w(*),work(*) end subroutine claqr0 -#else - module procedure stdlib_claqr0 +#else + module procedure stdlib${ii}$_claqr0 #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, & work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihi,ihiz,ilo,iloz,ldh,ldz,lwork,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihi,ihiz,ilo,iloz,ldh,ldz,lwork,n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt,wantz real(dp), intent(inout) :: h(ldh,*),z(ldz,*) real(dp), intent(out) :: wi(*),work(*),wr(*) end subroutine dlaqr0 -#else - module procedure stdlib_dlaqr0 +#else + module procedure stdlib${ii}$_dlaqr0 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqr0 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine slaqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, & work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihi,ihiz,ilo,iloz,ldh,ldz,lwork,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihi,ihiz,ilo,iloz,ldh,ldz,lwork,n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt,wantz real(sp), intent(inout) :: h(ldh,*),z(ldz,*) real(sp), intent(out) :: wi(*),work(*),wr(*) end subroutine slaqr0 -#else - module procedure stdlib_slaqr0 +#else + module procedure stdlib${ii}$_slaqr0 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqr0 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, & work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihi,ihiz,ilo,iloz,ldh,ldz,lwork,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihi,ihiz,ilo,iloz,ldh,ldz,lwork,n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt,wantz complex(dp), intent(inout) :: h(ldh,*),z(ldz,*) complex(dp), intent(out) :: w(*),work(*) end subroutine zlaqr0 -#else - module procedure stdlib_zlaqr0 +#else + module procedure stdlib${ii}$_zlaqr0 #endif - end interface laqr0 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqr0 +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqr0 +#:endif +#:endfor +#:endfor + end interface laqr0 interface laqr1 !! Given a 2-by-2 or 3-by-3 matrix H, LAQR1: sets v to a @@ -13607,65 +13576,65 @@ module stdlib_linalg_lapack !! scaling to avoid overflows and most underflows. !! This is useful for starting double implicit shift bulges !! in the QR algorithm. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine claqr1( n, h, ldh, s1, s2, v ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(sp), intent(in) :: s1,s2,h(ldh,*) - integer(ilp), intent(in) :: ldh,n + integer(${ik}$), intent(in) :: ldh,n complex(sp), intent(out) :: v(*) end subroutine claqr1 -#else - module procedure stdlib_claqr1 +#else + module procedure stdlib${ii}$_claqr1 #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaqr1( n, h, ldh, sr1, si1, sr2, si2, v ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: si1,si2,sr1,sr2,h(ldh,*) - integer(ilp), intent(in) :: ldh,n + integer(${ik}$), intent(in) :: ldh,n real(dp), intent(out) :: v(*) end subroutine dlaqr1 -#else - module procedure stdlib_dlaqr1 +#else + module procedure stdlib${ii}$_dlaqr1 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqr1 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaqr1( n, h, ldh, sr1, si1, sr2, si2, v ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: si1,si2,sr1,sr2,h(ldh,*) - integer(ilp), intent(in) :: ldh,n + integer(${ik}$), intent(in) :: ldh,n real(sp), intent(out) :: v(*) end subroutine slaqr1 -#else - module procedure stdlib_slaqr1 +#else + module procedure stdlib${ii}$_slaqr1 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqr1 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlaqr1( n, h, ldh, s1, s2, v ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) complex(dp), intent(in) :: s1,s2,h(ldh,*) - integer(ilp), intent(in) :: ldh,n + integer(${ik}$), intent(in) :: ldh,n complex(dp), intent(out) :: v(*) end subroutine zlaqr1 -#else - module procedure stdlib_zlaqr1 +#else + module procedure stdlib${ii}$_zlaqr1 #endif - end interface laqr1 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqr1 +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqr1 +#:endif +#:endfor +#:endfor + end interface laqr1 interface laqr4 !! LAQR4 implements one level of recursion for CLAQR0. @@ -13682,365 +13651,365 @@ module stdlib_linalg_lapack !! matrix Q so that this routine can give the Schur factorization !! of a matrix A which has been reduced to the Hessenberg form H !! by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine claqr4( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, & work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihi,ihiz,ilo,iloz,ldh,ldz,lwork,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihi,ihiz,ilo,iloz,ldh,ldz,lwork,n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt,wantz complex(sp), intent(inout) :: h(ldh,*),z(ldz,*) complex(sp), intent(out) :: w(*),work(*) end subroutine claqr4 -#else - module procedure stdlib_claqr4 +#else + module procedure stdlib${ii}$_claqr4 #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dlaqr4( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, & work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihi,ihiz,ilo,iloz,ldh,ldz,lwork,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihi,ihiz,ilo,iloz,ldh,ldz,lwork,n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt,wantz real(dp), intent(inout) :: h(ldh,*),z(ldz,*) real(dp), intent(out) :: wi(*),work(*),wr(*) end subroutine dlaqr4 -#else - module procedure stdlib_dlaqr4 +#else + module procedure stdlib${ii}$_dlaqr4 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqr4 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine slaqr4( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, & work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihi,ihiz,ilo,iloz,ldh,ldz,lwork,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihi,ihiz,ilo,iloz,ldh,ldz,lwork,n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt,wantz real(sp), intent(inout) :: h(ldh,*),z(ldz,*) real(sp), intent(out) :: wi(*),work(*),wr(*) end subroutine slaqr4 -#else - module procedure stdlib_slaqr4 +#else + module procedure stdlib${ii}$_slaqr4 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqr4 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlaqr4( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, & work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihi,ihiz,ilo,iloz,ldh,ldz,lwork,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihi,ihiz,ilo,iloz,ldh,ldz,lwork,n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt,wantz complex(dp), intent(inout) :: h(ldh,*),z(ldz,*) complex(dp), intent(out) :: w(*),work(*) end subroutine zlaqr4 -#else - module procedure stdlib_zlaqr4 +#else + module procedure stdlib${ii}$_zlaqr4 #endif - end interface laqr4 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqr4 +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqr4 +#:endif +#:endfor +#:endfor + end interface laqr4 interface laqr5 !! LAQR5 called by CLAQR0 performs a !! single small-bulge multi-shift QR sweep. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine claqr5( wantt, wantz, kacc22, n, ktop, kbot, nshfts, s,h, ldh, & iloz, ihiz, z, ldz, v, ldv, u, ldu, nv,wv, ldwv, nh, wh, ldwh ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihiz,iloz,kacc22,kbot,ktop,ldh,ldu,ldv,ldwh,ldwv,& + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihiz,iloz,kacc22,kbot,ktop,ldh,ldu,ldv,ldwh,ldwv,& ldz,n,nh,nshfts,nv logical(lk), intent(in) :: wantt,wantz complex(sp), intent(inout) :: h(ldh,*),s(*),z(ldz,*) complex(sp), intent(out) :: u(ldu,*),v(ldv,*),wh(ldwh,*),wv(ldwv,*) end subroutine claqr5 -#else - module procedure stdlib_claqr5 +#else + module procedure stdlib${ii}$_claqr5 #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaqr5( wantt, wantz, kacc22, n, ktop, kbot, nshfts,sr, si, h, ldh,& iloz, ihiz, z, ldz, v, ldv, u,ldu, nv, wv, ldwv, nh, wh, ldwh ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihiz,iloz,kacc22,kbot,ktop,ldh,ldu,ldv,ldwh,ldwv,& + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihiz,iloz,kacc22,kbot,ktop,ldh,ldu,ldv,ldwh,ldwv,& ldz,n,nh,nshfts,nv logical(lk), intent(in) :: wantt,wantz real(dp), intent(inout) :: h(ldh,*),si(*),sr(*),z(ldz,*) real(dp), intent(out) :: u(ldu,*),v(ldv,*),wh(ldwh,*),wv(ldwv,*) end subroutine dlaqr5 -#else - module procedure stdlib_dlaqr5 +#else + module procedure stdlib${ii}$_dlaqr5 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqr5 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaqr5( wantt, wantz, kacc22, n, ktop, kbot, nshfts,sr, si, h, ldh,& iloz, ihiz, z, ldz, v, ldv, u,ldu, nv, wv, ldwv, nh, wh, ldwh ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihiz,iloz,kacc22,kbot,ktop,ldh,ldu,ldv,ldwh,ldwv,& + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihiz,iloz,kacc22,kbot,ktop,ldh,ldu,ldv,ldwh,ldwv,& ldz,n,nh,nshfts,nv logical(lk), intent(in) :: wantt,wantz real(sp), intent(inout) :: h(ldh,*),si(*),sr(*),z(ldz,*) real(sp), intent(out) :: u(ldu,*),v(ldv,*),wh(ldwh,*),wv(ldwv,*) end subroutine slaqr5 -#else - module procedure stdlib_slaqr5 +#else + module procedure stdlib${ii}$_slaqr5 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqr5 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlaqr5( wantt, wantz, kacc22, n, ktop, kbot, nshfts, s,h, ldh, & iloz, ihiz, z, ldz, v, ldv, u, ldu, nv,wv, ldwv, nh, wh, ldwh ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihiz,iloz,kacc22,kbot,ktop,ldh,ldu,ldv,ldwh,ldwv,& + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihiz,iloz,kacc22,kbot,ktop,ldh,ldu,ldv,ldwh,ldwv,& ldz,n,nh,nshfts,nv logical(lk), intent(in) :: wantt,wantz complex(dp), intent(inout) :: h(ldh,*),s(*),z(ldz,*) complex(dp), intent(out) :: u(ldu,*),v(ldv,*),wh(ldwh,*),wv(ldwv,*) end subroutine zlaqr5 -#else - module procedure stdlib_zlaqr5 +#else + module procedure stdlib${ii}$_zlaqr5 #endif - end interface laqr5 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqr5 +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqr5 +#:endif +#:endfor +#:endfor + end interface laqr5 interface laqsb !! LAQSB equilibrates a symmetric band matrix A using the scaling !! factors in the vector S. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine claqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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,s(*) complex(sp), intent(inout) :: ab(ldab,*) end subroutine claqsb -#else - module procedure stdlib_claqsb +#else + module procedure stdlib${ii}$_claqsb #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: kd,ldab,n + integer(${ik}$), intent(in) :: kd,ldab,n real(dp), intent(in) :: amax,scond,s(*) real(dp), intent(inout) :: ab(ldab,*) end subroutine dlaqsb -#else - module procedure stdlib_dlaqsb +#else + module procedure stdlib${ii}$_dlaqsb #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqsb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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,s(*) real(sp), intent(inout) :: ab(ldab,*) end subroutine slaqsb -#else - module procedure stdlib_slaqsb +#else + module procedure stdlib${ii}$_slaqsb #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqsb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlaqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: kd,ldab,n + integer(${ik}$), intent(in) :: kd,ldab,n real(dp), intent(in) :: amax,scond,s(*) complex(dp), intent(inout) :: ab(ldab,*) end subroutine zlaqsb -#else - module procedure stdlib_zlaqsb +#else + module procedure stdlib${ii}$_zlaqsb #endif - end interface laqsb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqsb +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqsb +#:endif +#:endfor +#:endfor + end interface laqsb interface laqsp !! LAQSP equilibrates a symmetric matrix A using the scaling factors !! in the vector S. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine claqsp( uplo, n, ap, s, scond, amax, equed ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(sp), intent(in) :: amax,scond,s(*) complex(sp), intent(inout) :: ap(*) end subroutine claqsp -#else - module procedure stdlib_claqsp +#else + module procedure stdlib${ii}$_claqsp #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaqsp( uplo, n, ap, s, scond, amax, equed ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(dp), intent(in) :: amax,scond,s(*) real(dp), intent(inout) :: ap(*) end subroutine dlaqsp -#else - module procedure stdlib_dlaqsp +#else + module procedure stdlib${ii}$_dlaqsp #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqsp - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaqsp( uplo, n, ap, s, scond, amax, equed ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(sp), intent(in) :: amax,scond,s(*) real(sp), intent(inout) :: ap(*) end subroutine slaqsp -#else - module procedure stdlib_slaqsp +#else + module procedure stdlib${ii}$_slaqsp #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqsp - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlaqsp( uplo, n, ap, s, scond, amax, equed ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(dp), intent(in) :: amax,scond,s(*) complex(dp), intent(inout) :: ap(*) end subroutine zlaqsp -#else - module procedure stdlib_zlaqsp +#else + module procedure stdlib${ii}$_zlaqsp #endif - end interface laqsp +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqsp +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqsp +#:endif +#:endfor +#:endfor + end interface laqsp interface laqsy !! LAQSY equilibrates a symmetric matrix A using the scaling factors !! in the vector S. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine claqsy( uplo, n, a, lda, s, scond, amax, equed ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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,s(*) complex(sp), intent(inout) :: a(lda,*) end subroutine claqsy -#else - module procedure stdlib_claqsy +#else + module procedure stdlib${ii}$_claqsy #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaqsy( uplo, n, a, lda, s, scond, amax, equed ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(in) :: lda,n real(dp), intent(in) :: amax,scond,s(*) real(dp), intent(inout) :: a(lda,*) end subroutine dlaqsy -#else - module procedure stdlib_dlaqsy +#else + module procedure stdlib${ii}$_dlaqsy #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqsy - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaqsy( uplo, n, a, lda, s, scond, amax, equed ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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,s(*) real(sp), intent(inout) :: a(lda,*) end subroutine slaqsy -#else - module procedure stdlib_slaqsy +#else + module procedure stdlib${ii}$_slaqsy #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqsy - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlaqsy( uplo, n, a, lda, s, scond, amax, equed ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(in) :: lda,n real(dp), intent(in) :: amax,scond,s(*) complex(dp), intent(inout) :: a(lda,*) end subroutine zlaqsy -#else - module procedure stdlib_zlaqsy +#else + module procedure stdlib${ii}$_zlaqsy #endif - end interface laqsy +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqsy +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqsy +#:endif +#:endfor +#:endfor + end interface laqsy interface laqtr !! LAQTR solves the real quasi-triangular system @@ -14061,43 +14030,43 @@ module stdlib_linalg_lapack !! [ d ] [ q ] !! This subroutine is designed for the condition number estimation !! in routine DTRSNA. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dlaqtr( ltran, lreal, n, t, ldt, b, w, scale, x, work,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: lreal,ltran - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldt,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldt,n real(dp), intent(out) :: scale,work(*) real(dp), intent(in) :: w,b(*),t(ldt,*) real(dp), intent(inout) :: x(*) end subroutine dlaqtr -#else - module procedure stdlib_dlaqtr +#else + module procedure stdlib${ii}$_dlaqtr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqtr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine slaqtr( ltran, lreal, n, t, ldt, b, w, scale, x, work,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: lreal,ltran - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldt,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldt,n real(sp), intent(out) :: scale,work(*) real(sp), intent(in) :: w,b(*),t(ldt,*) real(sp), intent(inout) :: x(*) end subroutine slaqtr -#else - module procedure stdlib_slaqtr +#else + module procedure stdlib${ii}$_slaqtr #endif - end interface laqtr - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqtr +#:endif +#:endfor +#:endfor + end interface laqtr interface laqz0 !! LAQZ0 computes the eigenvalues of a matrix pair (H,T), @@ -14140,193 +14109,193 @@ module stdlib_linalg_lapack !! Anal., 29(2006), pp. 199--227. !! Ref: T. Steel, D. Camps, K. Meerbergen, R. Vandebril "A multishift, !! multipole rational QZ method with agressive early deflation" -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ recursive subroutine claqz0( wants, wantq, wantz, n, ilo, ihi, a,lda, b, ldb, & alpha, beta, q, ldq, z,ldz, work, lwork, rwork, rec,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: wants,wantq,wantz - integer(ilp), intent(in) :: n,ilo,ihi,lda,ldb,ldq,ldz,lwork,rec - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n,ilo,ihi,lda,ldb,ldq,ldz,lwork,rec + integer(${ik}$), intent(out) :: info complex(sp), intent(inout) :: a(lda,*),b(ldb,*),q(ldq,*),z(ldz,*) complex(sp), intent(inout) :: alpha(*),beta(*),work(*) real(sp), intent(out) :: rwork(*) end subroutine claqz0 -#else - module procedure stdlib_claqz0 +#else + module procedure stdlib${ii}$_claqz0 #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ recursive subroutine dlaqz0( wants, wantq, wantz, n, ilo, ihi, a,lda, b, ldb, & alphar, alphai, beta,q, ldq, z, ldz, work, lwork, rec,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: wants,wantq,wantz - integer(ilp), intent(in) :: n,ilo,ihi,lda,ldb,ldq,ldz,lwork,rec - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n,ilo,ihi,lda,ldb,ldq,ldz,lwork,rec + integer(${ik}$), intent(out) :: info real(dp), intent(inout) :: a(lda,*),b(ldb,*),q(ldq,*),z(ldz,*) real(dp), intent(inout) :: alphar(*),alphai(*),beta(*),work(*) end subroutine dlaqz0 -#else - module procedure stdlib_dlaqz0 +#else + module procedure stdlib${ii}$_dlaqz0 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqz0 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ recursive subroutine slaqz0( wants, wantq, wantz, n, ilo, ihi, a,lda, b, ldb, & alphar, alphai, beta,q, ldq, z, ldz, work, lwork, rec,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: wants,wantq,wantz - integer(ilp), intent(in) :: n,ilo,ihi,lda,ldb,ldq,ldz,lwork,rec - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n,ilo,ihi,lda,ldb,ldq,ldz,lwork,rec + integer(${ik}$), intent(out) :: info real(sp), intent(inout) :: a(lda,*),b(ldb,*),q(ldq,*),z(ldz,*) real(sp), intent(inout) :: alphar(*),alphai(*),beta(*),work(*) end subroutine slaqz0 -#else - module procedure stdlib_slaqz0 +#else + module procedure stdlib${ii}$_slaqz0 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqz0 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ recursive subroutine zlaqz0( wants, wantq, wantz, n, ilo, ihi, a,lda, b, ldb, & alpha, beta, q, ldq, z,ldz, work, lwork, rwork, rec,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: wants,wantq,wantz - integer(ilp), intent(in) :: n,ilo,ihi,lda,ldb,ldq,ldz,lwork,rec - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n,ilo,ihi,lda,ldb,ldq,ldz,lwork,rec + integer(${ik}$), intent(out) :: info complex(dp), intent(inout) :: a(lda,*),b(ldb,*),q(ldq,*),z(ldz,*) complex(dp), intent(inout) :: alpha(*),beta(*),work(*) real(dp), intent(out) :: rwork(*) end subroutine zlaqz0 -#else - module procedure stdlib_zlaqz0 +#else + module procedure stdlib${ii}$_zlaqz0 #endif - end interface laqz0 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqz0 +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqz0 +#:endif +#:endfor +#:endfor + end interface laqz0 interface laqz1 !! LAQZ1 chases a 1x1 shift bulge in a matrix pencil down a single position -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine claqz1( ilq, ilz, k, istartm, istopm, ihi, a, lda, b,ldb, nq, & qstart, q, ldq, nz, zstart, z, ldz ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(inout) :: a(lda,*),b(ldb,*),q(ldq,*),z(ldz,*) end subroutine claqz1 -#else - module procedure stdlib_claqz1 +#else + module procedure stdlib${ii}$_claqz1 #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaqz1( a, lda, b, ldb, sr1, sr2, si, beta1, beta2,v ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: lda,ldb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: lda,ldb real(dp), intent(in) :: a(lda,*),b(ldb,*),sr1,sr2,si,beta1,beta2 - real(dp), intent(out) :: v(*) - end subroutine dlaqz1 -#else - module procedure stdlib_dlaqz1 -#endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqz1 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK + real(dp), intent(out) :: v(*) + end subroutine dlaqz1 +#else + module procedure stdlib${ii}$_dlaqz1 +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaqz1( a, lda, b, ldb, sr1, sr2, si, beta1, beta2,v ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: lda,ldb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: lda,ldb real(sp), intent(in) :: a(lda,*),b(ldb,*),sr1,sr2,si,beta1,beta2 real(sp), intent(out) :: v(*) end subroutine slaqz1 -#else - module procedure stdlib_slaqz1 +#else + module procedure stdlib${ii}$_slaqz1 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqz1 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlaqz1( ilq, ilz, k, istartm, istopm, ihi, a, lda, b,ldb, nq, & qstart, q, ldq, nz, zstart, z, ldz ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(inout) :: a(lda,*),b(ldb,*),q(ldq,*),z(ldz,*) end subroutine zlaqz1 -#else - module procedure stdlib_zlaqz1 +#else + module procedure stdlib${ii}$_zlaqz1 #endif - end interface laqz1 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqz1 +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqz1 +#:endif +#:endfor +#:endfor + end interface laqz1 interface laqz4 !! LAQZ4 Executes a single multishift QZ sweep -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaqz4( ilschur, ilq, ilz, n, ilo, ihi, nshifts,nblock_desired, sr,& si, ss, a, lda, b, ldb, q,ldq, z, ldz, qc, ldqc, zc, ldzc, work, lwork,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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(dp), intent(inout) :: a(lda,*),b(ldb,*),q(ldq,*),z(ldz,*),qc(ldqc,*),zc(& ldzc,*) real(dp), intent(inout) :: work(*) real(dp), intent(inout) :: sr(*),si(*),ss(*) - integer(ilp), intent(out) :: info + integer(${ik}$), intent(out) :: info end subroutine dlaqz4 -#else - module procedure stdlib_dlaqz4 +#else + module procedure stdlib${ii}$_dlaqz4 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laqz4 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaqz4( ilschur, ilq, ilz, n, ilo, ihi, nshifts,nblock_desired, sr,& si, ss, a, lda, b, ldb, q,ldq, z, ldz, qc, ldqc, zc, ldzc, work, lwork,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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,*) real(sp), intent(inout) :: work(*) real(sp), intent(inout) :: sr(*),si(*),ss(*) - integer(ilp), intent(out) :: info + integer(${ik}$), intent(out) :: info end subroutine slaqz4 -#else - module procedure stdlib_slaqz4 +#else + module procedure stdlib${ii}$_slaqz4 #endif - end interface laqz4 - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laqz4 +#:endif +#:endfor +#:endfor + end interface laqz4 interface lar1v !! LAR1V computes the (scaled) r-th column of the inverse of @@ -14344,85 +14313,85 @@ module stdlib_linalg_lapack !! (d) Computation of the (scaled) r-th column of the inverse using the !! twisted factorization obtained by combining the top part of the !! the stationary and the bottom part of the progressive transform. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clar1v( n, b1, bn, lambda, d, l, ld, lld,pivmin, gaptol, z, wantnc,& negcnt, ztz, mingma,r, isuppz, nrminv, resid, rqcorr, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: wantnc - integer(ilp), intent(in) :: b1,bn,n - integer(ilp), intent(out) :: negcnt,isuppz(*) - integer(ilp), intent(inout) :: r + integer(${ik}$), intent(in) :: b1,bn,n + integer(${ik}$), intent(out) :: negcnt,isuppz(*) + integer(${ik}$), intent(inout) :: r real(sp), intent(in) :: gaptol,lambda,pivmin,d(*),l(*),ld(*),lld(*) real(sp), intent(out) :: mingma,nrminv,resid,rqcorr,ztz,work(*) complex(sp), intent(inout) :: z(*) end subroutine clar1v -#else - module procedure stdlib_clar1v +#else + module procedure stdlib${ii}$_clar1v #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlar1v( n, b1, bn, lambda, d, l, ld, lld,pivmin, gaptol, z, wantnc,& negcnt, ztz, mingma,r, isuppz, nrminv, resid, rqcorr, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: wantnc - integer(ilp), intent(in) :: b1,bn,n - integer(ilp), intent(out) :: negcnt,isuppz(*) - integer(ilp), intent(inout) :: r + integer(${ik}$), intent(in) :: b1,bn,n + integer(${ik}$), intent(out) :: negcnt,isuppz(*) + integer(${ik}$), intent(inout) :: r real(dp), intent(in) :: gaptol,lambda,pivmin,d(*),l(*),ld(*),lld(*) real(dp), intent(out) :: mingma,nrminv,resid,rqcorr,ztz,work(*) real(dp), intent(inout) :: z(*) end subroutine dlar1v -#else - module procedure stdlib_dlar1v +#else + module procedure stdlib${ii}$_dlar1v #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lar1v - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slar1v( n, b1, bn, lambda, d, l, ld, lld,pivmin, gaptol, z, wantnc,& negcnt, ztz, mingma,r, isuppz, nrminv, resid, rqcorr, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: wantnc - integer(ilp), intent(in) :: b1,bn,n - integer(ilp), intent(out) :: negcnt,isuppz(*) - integer(ilp), intent(inout) :: r + integer(${ik}$), intent(in) :: b1,bn,n + integer(${ik}$), intent(out) :: negcnt,isuppz(*) + integer(${ik}$), intent(inout) :: r real(sp), intent(in) :: gaptol,lambda,pivmin,d(*),l(*),ld(*),lld(*) real(sp), intent(out) :: mingma,nrminv,resid,rqcorr,ztz,work(*) real(sp), intent(inout) :: z(*) end subroutine slar1v -#else - module procedure stdlib_slar1v +#else + module procedure stdlib${ii}$_slar1v #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lar1v - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlar1v( n, b1, bn, lambda, d, l, ld, lld,pivmin, gaptol, z, wantnc,& negcnt, ztz, mingma,r, isuppz, nrminv, resid, rqcorr, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: wantnc - integer(ilp), intent(in) :: b1,bn,n - integer(ilp), intent(out) :: negcnt,isuppz(*) - integer(ilp), intent(inout) :: r + integer(${ik}$), intent(in) :: b1,bn,n + integer(${ik}$), intent(out) :: negcnt,isuppz(*) + integer(${ik}$), intent(inout) :: r real(dp), intent(in) :: gaptol,lambda,pivmin,d(*),l(*),ld(*),lld(*) real(dp), intent(out) :: mingma,nrminv,resid,rqcorr,ztz,work(*) complex(dp), intent(inout) :: z(*) end subroutine zlar1v -#else - module procedure stdlib_zlar1v +#else + module procedure stdlib${ii}$_zlar1v #endif - end interface lar1v +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lar1v +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lar1v +#:endif +#:endfor +#:endfor + end interface lar1v interface lar2v !! LAR2V applies a vector of complex plane rotations with real cosines @@ -14432,108 +14401,108 @@ module stdlib_linalg_lapack !! ( conjg(z(i)) y(i) ) !! ( c(i) conjg(s(i)) ) ( x(i) z(i) ) ( c(i) -conjg(s(i)) ) !! ( -s(i) c(i) ) ( conjg(z(i)) y(i) ) ( s(i) c(i) ) -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clar2v( n, x, y, z, incx, c, s, incc ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incc,incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incc,incx,n real(sp), intent(in) :: c(*) complex(sp), intent(in) :: s(*) complex(sp), intent(inout) :: x(*),y(*),z(*) end subroutine clar2v -#else - module procedure stdlib_clar2v +#else + module procedure stdlib${ii}$_clar2v #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlar2v( n, x, y, z, incx, c, s, incc ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incc,incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incc,incx,n real(dp), intent(in) :: c(*),s(*) real(dp), intent(inout) :: x(*),y(*),z(*) end subroutine dlar2v -#else - module procedure stdlib_dlar2v +#else + module procedure stdlib${ii}$_dlar2v #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lar2v - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slar2v( n, x, y, z, incx, c, s, incc ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incc,incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incc,incx,n real(sp), intent(in) :: c(*),s(*) real(sp), intent(inout) :: x(*),y(*),z(*) end subroutine slar2v -#else - module procedure stdlib_slar2v +#else + module procedure stdlib${ii}$_slar2v #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lar2v - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlar2v( n, x, y, z, incx, c, s, incc ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incc,incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incc,incx,n real(dp), intent(in) :: c(*) complex(dp), intent(in) :: s(*) complex(dp), intent(inout) :: x(*),y(*),z(*) end subroutine zlar2v -#else - module procedure stdlib_zlar2v +#else + module procedure stdlib${ii}$_zlar2v #endif - end interface lar2v +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lar2v +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lar2v +#:endif +#:endfor +#:endfor + end interface lar2v interface larcm !! LARCM performs a very simple matrix-matrix multiplication: !! C := A * B, !! where A is M by M and real; B is M by N and complex; !! C is M by N and complex. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clarcm( m, n, a, lda, b, ldb, c, ldc, rwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: lda,ldb,ldc,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: lda,ldb,ldc,m,n real(sp), intent(in) :: a(lda,*) real(sp), intent(out) :: rwork(*) complex(sp), intent(in) :: b(ldb,*) complex(sp), intent(out) :: c(ldc,*) end subroutine clarcm -#else - module procedure stdlib_clarcm +#else + module procedure stdlib${ii}$_clarcm #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larcm - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlarcm( m, n, a, lda, b, ldb, c, ldc, rwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: lda,ldb,ldc,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: lda,ldb,ldc,m,n real(dp), intent(in) :: a(lda,*) real(dp), intent(out) :: rwork(*) complex(dp), intent(in) :: b(ldb,*) complex(dp), intent(out) :: c(ldc,*) end subroutine zlarcm -#else - module procedure stdlib_zlarcm +#else + module procedure stdlib${ii}$_zlarcm #endif - end interface larcm - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larcm +#:endif +#:endfor +#:endfor + end interface larcm interface larf !! LARF applies a complex elementary reflector H to a complex M-by-N @@ -14544,148 +14513,148 @@ module stdlib_linalg_lapack !! If tau = 0, then H is taken to be the unit matrix. !! To apply H**H (the conjugate transpose of H), supply conjg(tau) instead !! tau. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clarf( side, m, n, v, incv, tau, c, ldc, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side - integer(ilp), intent(in) :: incv,ldc,m,n + integer(${ik}$), intent(in) :: incv,ldc,m,n complex(sp), intent(in) :: tau,v(*) complex(sp), intent(inout) :: c(ldc,*) complex(sp), intent(out) :: work(*) end subroutine clarf -#else - module procedure stdlib_clarf +#else + module procedure stdlib${ii}$_clarf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlarf( side, m, n, v, incv, tau, c, ldc, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side - integer(ilp), intent(in) :: incv,ldc,m,n + integer(${ik}$), intent(in) :: incv,ldc,m,n real(dp), intent(in) :: tau,v(*) real(dp), intent(inout) :: c(ldc,*) real(dp), intent(out) :: work(*) end subroutine dlarf -#else - module procedure stdlib_dlarf +#else + module procedure stdlib${ii}$_dlarf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slarf( side, m, n, v, incv, tau, c, ldc, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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,v(*) real(sp), intent(inout) :: c(ldc,*) real(sp), intent(out) :: work(*) end subroutine slarf -#else - module procedure stdlib_slarf +#else + module procedure stdlib${ii}$_slarf #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlarf( side, m, n, v, incv, tau, c, ldc, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side - integer(ilp), intent(in) :: incv,ldc,m,n + integer(${ik}$), intent(in) :: incv,ldc,m,n complex(dp), intent(in) :: tau,v(*) complex(dp), intent(inout) :: c(ldc,*) complex(dp), intent(out) :: work(*) end subroutine zlarf -#else - module procedure stdlib_zlarf +#else + module procedure stdlib${ii}$_zlarf #endif - end interface larf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larf +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larf +#:endif +#:endfor +#:endfor + end interface larf interface larfb !! LARFB applies a complex block reflector H or its transpose H**H to a !! complex M-by-N matrix C, from either the left or the right. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clarfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, & ldc, work, ldwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(inout) :: c(ldc,*) complex(sp), intent(in) :: t(ldt,*),v(ldv,*) complex(sp), intent(out) :: work(ldwork,*) end subroutine clarfb -#else - module procedure stdlib_clarfb +#else + module procedure stdlib${ii}$_clarfb #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlarfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, & ldc, work, ldwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(inout) :: c(ldc,*) real(dp), intent(in) :: t(ldt,*),v(ldv,*) real(dp), intent(out) :: work(ldwork,*) end subroutine dlarfb -#else - module procedure stdlib_dlarfb +#else + module procedure stdlib${ii}$_dlarfb #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larfb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slarfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, & ldc, work, ldwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: c(ldc,*) real(sp), intent(in) :: t(ldt,*),v(ldv,*) real(sp), intent(out) :: work(ldwork,*) end subroutine slarfb -#else - module procedure stdlib_slarfb +#else + module procedure stdlib${ii}$_slarfb #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larfb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlarfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, & ldc, work, ldwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(inout) :: c(ldc,*) complex(dp), intent(in) :: t(ldt,*),v(ldv,*) complex(dp), intent(out) :: work(ldwork,*) end subroutine zlarfb -#else - module procedure stdlib_zlarfb +#else + module procedure stdlib${ii}$_zlarfb #endif - end interface larfb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larfb +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larfb +#:endif +#:endfor +#:endfor + end interface larfb interface larfb_gett !! LARFB_GETT applies a complex Householder block reflector H from the @@ -14695,77 +14664,77 @@ module stdlib_linalg_lapack !! in the array B. The block reflector H is stored in a compact !! WY-representation, where the elementary reflectors are in the !! arrays A, B and T. See Further Details section. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clarfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(in) :: t(ldt,*) complex(sp), intent(out) :: work(ldwork,*) end subroutine clarfb_gett -#else - module procedure stdlib_clarfb_gett +#else + module procedure stdlib${ii}$_clarfb_gett #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlarfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(in) :: t(ldt,*) real(dp), intent(out) :: work(ldwork,*) end subroutine dlarfb_gett -#else - module procedure stdlib_dlarfb_gett +#else + module procedure stdlib${ii}$_dlarfb_gett #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larfb_gett - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slarfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(in) :: t(ldt,*) real(sp), intent(out) :: work(ldwork,*) end subroutine slarfb_gett -#else - module procedure stdlib_slarfb_gett +#else + module procedure stdlib${ii}$_slarfb_gett #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larfb_gett - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlarfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(in) :: t(ldt,*) complex(dp), intent(out) :: work(ldwork,*) end subroutine zlarfb_gett -#else - module procedure stdlib_zlarfb_gett +#else + module procedure stdlib${ii}$_zlarfb_gett #endif - end interface larfb_gett +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larfb_gett +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larfb_gett +#:endif +#:endfor +#:endfor + end interface larfb_gett interface larfg !! LARFG generates a complex elementary reflector H of order n, such @@ -14781,65 +14750,65 @@ module stdlib_linalg_lapack !! If the elements of x are all zero and alpha is real, then tau = 0 !! and H is taken to be the unit matrix. !! Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clarfg( n, alpha, x, incx, tau ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n complex(sp), intent(inout) :: alpha,x(*) complex(sp), intent(out) :: tau end subroutine clarfg -#else - module procedure stdlib_clarfg +#else + module procedure stdlib${ii}$_clarfg #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlarfg( n, alpha, x, incx, tau ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n real(dp), intent(inout) :: alpha,x(*) real(dp), intent(out) :: tau end subroutine dlarfg -#else - module procedure stdlib_dlarfg +#else + module procedure stdlib${ii}$_dlarfg #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larfg - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slarfg( n, alpha, x, incx, tau ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n real(sp), intent(inout) :: alpha,x(*) real(sp), intent(out) :: tau end subroutine slarfg -#else - module procedure stdlib_slarfg +#else + module procedure stdlib${ii}$_slarfg #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larfg - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlarfg( n, alpha, x, incx, tau ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n complex(dp), intent(inout) :: alpha,x(*) complex(dp), intent(out) :: tau end subroutine zlarfg -#else - module procedure stdlib_zlarfg +#else + module procedure stdlib${ii}$_zlarfg #endif - end interface larfg +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larfg +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larfg +#:endif +#:endfor +#:endfor + end interface larfg interface larfgp !! LARFGP generates a complex elementary reflector H of order n, such @@ -14854,65 +14823,65 @@ module stdlib_linalg_lapack !! vector. Note that H is not hermitian. !! If the elements of x are all zero and alpha is real, then tau = 0 !! and H is taken to be the unit matrix. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine clarfgp( n, alpha, x, incx, tau ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n complex(sp), intent(inout) :: alpha,x(*) complex(sp), intent(out) :: tau end subroutine clarfgp -#else - module procedure stdlib_clarfgp +#else + module procedure stdlib${ii}$_clarfgp #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dlarfgp( n, alpha, x, incx, tau ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n real(dp), intent(inout) :: alpha,x(*) real(dp), intent(out) :: tau end subroutine dlarfgp -#else - module procedure stdlib_dlarfgp +#else + module procedure stdlib${ii}$_dlarfgp #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larfgp - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine slarfgp( n, alpha, x, incx, tau ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n real(sp), intent(inout) :: alpha,x(*) real(sp), intent(out) :: tau end subroutine slarfgp -#else - module procedure stdlib_slarfgp +#else + module procedure stdlib${ii}$_slarfgp #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larfgp - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zlarfgp( n, alpha, x, incx, tau ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n complex(dp), intent(inout) :: alpha,x(*) complex(dp), intent(out) :: tau end subroutine zlarfgp -#else - module procedure stdlib_zlarfgp +#else + module procedure stdlib${ii}$_zlarfgp #endif - end interface larfgp +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larfgp +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larfgp +#:endif +#:endfor +#:endfor + end interface larfgp interface larft !! LARFT forms the triangular factor T of a complex block reflector H @@ -14925,69 +14894,69 @@ module stdlib_linalg_lapack !! If STOREV = 'R', the vector which defines the elementary reflector !! H(i) is stored in the i-th row of the array V, and !! H = I - V**H * T * V -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clarft( direct, storev, n, k, v, ldv, tau, t, ldt ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: direct,storev - integer(ilp), intent(in) :: k,ldt,ldv,n + integer(${ik}$), intent(in) :: k,ldt,ldv,n complex(sp), intent(out) :: t(ldt,*) complex(sp), intent(in) :: tau(*),v(ldv,*) end subroutine clarft -#else - module procedure stdlib_clarft +#else + module procedure stdlib${ii}$_clarft #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlarft( direct, storev, n, k, v, ldv, tau, t, ldt ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: direct,storev - integer(ilp), intent(in) :: k,ldt,ldv,n + integer(${ik}$), intent(in) :: k,ldt,ldv,n real(dp), intent(out) :: t(ldt,*) real(dp), intent(in) :: tau(*),v(ldv,*) end subroutine dlarft -#else - module procedure stdlib_dlarft +#else + module procedure stdlib${ii}$_dlarft #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larft - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slarft( direct, storev, n, k, v, ldv, tau, t, ldt ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: direct,storev - integer(ilp), intent(in) :: k,ldt,ldv,n + integer(${ik}$), intent(in) :: k,ldt,ldv,n real(sp), intent(out) :: t(ldt,*) real(sp), intent(in) :: tau(*),v(ldv,*) end subroutine slarft -#else - module procedure stdlib_slarft +#else + module procedure stdlib${ii}$_slarft #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larft - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlarft( direct, storev, n, k, v, ldv, tau, t, ldt ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: direct,storev - integer(ilp), intent(in) :: k,ldt,ldv,n + integer(${ik}$), intent(in) :: k,ldt,ldv,n complex(dp), intent(out) :: t(ldt,*) complex(dp), intent(in) :: tau(*),v(ldv,*) end subroutine zlarft -#else - module procedure stdlib_zlarft +#else + module procedure stdlib${ii}$_zlarft #endif - end interface larft +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larft +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larft +#:endif +#:endfor +#:endfor + end interface larft interface larfy !! LARFY applies an elementary reflector, or Householder matrix, H, @@ -14996,73 +14965,73 @@ module stdlib_linalg_lapack !! H = I - tau * v * v' !! where tau is a scalar and v is a vector. !! If tau is zero, then H is taken to be the unit matrix. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clarfy( uplo, n, v, incv, tau, c, ldc, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: incv,ldc,n + integer(${ik}$), intent(in) :: incv,ldc,n complex(sp), intent(in) :: tau,v(*) complex(sp), intent(inout) :: c(ldc,*) complex(sp), intent(out) :: work(*) end subroutine clarfy -#else - module procedure stdlib_clarfy +#else + module procedure stdlib${ii}$_clarfy #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlarfy( uplo, n, v, incv, tau, c, ldc, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: incv,ldc,n + integer(${ik}$), intent(in) :: incv,ldc,n real(dp), intent(in) :: tau,v(*) real(dp), intent(inout) :: c(ldc,*) real(dp), intent(out) :: work(*) end subroutine dlarfy -#else - module procedure stdlib_dlarfy +#else + module procedure stdlib${ii}$_dlarfy #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larfy - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slarfy( uplo, n, v, incv, tau, c, ldc, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: incv,ldc,n + integer(${ik}$), intent(in) :: incv,ldc,n real(sp), intent(in) :: tau,v(*) real(sp), intent(inout) :: c(ldc,*) real(sp), intent(out) :: work(*) end subroutine slarfy -#else - module procedure stdlib_slarfy +#else + module procedure stdlib${ii}$_slarfy #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larfy - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlarfy( uplo, n, v, incv, tau, c, ldc, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: incv,ldc,n + integer(${ik}$), intent(in) :: incv,ldc,n complex(dp), intent(in) :: tau,v(*) complex(dp), intent(inout) :: c(ldc,*) complex(dp), intent(out) :: work(*) end subroutine zlarfy -#else - module procedure stdlib_zlarfy +#else + module procedure stdlib${ii}$_zlarfy #endif - end interface larfy +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larfy +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larfy +#:endif +#:endfor +#:endfor + end interface larfy interface largv !! LARGV generates a vector of complex plane rotations with real @@ -15075,165 +15044,165 @@ module stdlib_linalg_lapack !! but differ from the BLAS1 routine CROTG): !! If y(i)=0, then c(i)=1 and s(i)=0. !! If x(i)=0, then c(i)=0 and s(i) is chosen so that r(i) is real. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clargv( n, x, incx, y, incy, c, incc ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incc,incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incc,incx,incy,n real(sp), intent(out) :: c(*) complex(sp), intent(inout) :: x(*),y(*) end subroutine clargv -#else - module procedure stdlib_clargv +#else + module procedure stdlib${ii}$_clargv #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlargv( n, x, incx, y, incy, c, incc ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incc,incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incc,incx,incy,n real(dp), intent(out) :: c(*) real(dp), intent(inout) :: x(*),y(*) end subroutine dlargv -#else - module procedure stdlib_dlargv +#else + module procedure stdlib${ii}$_dlargv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$largv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slargv( n, x, incx, y, incy, c, incc ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incc,incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incc,incx,incy,n real(sp), intent(out) :: c(*) real(sp), intent(inout) :: x(*),y(*) end subroutine slargv -#else - module procedure stdlib_slargv +#else + module procedure stdlib${ii}$_slargv +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine zlargv( n, x, incx, y, incy, c, incc ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incc,incx,incy,n + real(dp), intent(out) :: c(*) + complex(dp), intent(inout) :: x(*),y(*) + end subroutine zlargv +#else + module procedure stdlib${ii}$_zlargv #endif +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$largv + +#:endif +#:endfor #:for rk,rt,ri in CMPLX_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$largv + module procedure stdlib${ii}$_${ri}$largv #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine zlargv( n, x, incx, y, incy, c, incc ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incc,incx,incy,n - real(dp), intent(out) :: c(*) - complex(dp), intent(inout) :: x(*),y(*) - end subroutine zlargv -#else - module procedure stdlib_zlargv -#endif +#:endfor end interface largv - - interface larnv !! LARNV returns a vector of n random complex numbers from a uniform or !! normal distribution. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clarnv( idist, iseed, n, x ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: idist,n - integer(ilp), intent(inout) :: iseed(4) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: idist,n + integer(${ik}$), intent(inout) :: iseed(4) complex(sp), intent(out) :: x(*) end subroutine clarnv -#else - module procedure stdlib_clarnv +#else + module procedure stdlib${ii}$_clarnv #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlarnv( idist, iseed, n, x ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: idist,n - integer(ilp), intent(inout) :: iseed(4) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: idist,n + integer(${ik}$), intent(inout) :: iseed(4) real(dp), intent(out) :: x(*) end subroutine dlarnv -#else - module procedure stdlib_dlarnv +#else + module procedure stdlib${ii}$_dlarnv +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine slarnv( idist, iseed, n, x ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: idist,n + integer(${ik}$), intent(inout) :: iseed(4) + real(sp), intent(out) :: x(*) + end subroutine slarnv +#else + module procedure stdlib${ii}$_slarnv +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine zlarnv( idist, iseed, n, x ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: idist,n + integer(${ik}$), intent(inout) :: iseed(4) + complex(dp), intent(out) :: x(*) + end subroutine zlarnv +#else + module procedure stdlib${ii}$_zlarnv #endif #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larnv + module procedure stdlib${ii}$_${ri}$larnv #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine slarnv( idist, iseed, n, x ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: idist,n - integer(ilp), intent(inout) :: iseed(4) - real(sp), intent(out) :: x(*) - end subroutine slarnv -#else - module procedure stdlib_slarnv -#endif #:for rk,rt,ri in CMPLX_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larnv + module procedure stdlib${ii}$_${ri}$larnv #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine zlarnv( idist, iseed, n, x ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: idist,n - integer(ilp), intent(inout) :: iseed(4) - complex(dp), intent(out) :: x(*) - end subroutine zlarnv -#else - module procedure stdlib_zlarnv -#endif +#:endfor end interface larnv - - interface larra !! Compute the splitting points with threshold SPLTOL. !! LARRA sets any "small" off-diagonal elements to zero. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlarra( n, d, e, e2, spltol, tnrm,nsplit, isplit, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,nsplit,isplit(*) - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,nsplit,isplit(*) + integer(${ik}$), intent(in) :: n real(dp), intent(in) :: spltol,tnrm,d(*) real(dp), intent(inout) :: e(*),e2(*) end subroutine dlarra -#else - module procedure stdlib_dlarra +#else + module procedure stdlib${ii}$_dlarra #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larra - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slarra( n, d, e, e2, spltol, tnrm,nsplit, isplit, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,nsplit,isplit(*) - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,nsplit,isplit(*) + integer(${ik}$), intent(in) :: n real(sp), intent(in) :: spltol,tnrm,d(*) real(sp), intent(inout) :: e(*),e2(*) end subroutine slarra -#else - module procedure stdlib_slarra +#else + module procedure stdlib${ii}$_slarra #endif - end interface larra - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larra +#:endif +#:endfor +#:endfor + end interface larra interface larrb !! Given the relatively robust representation(RRR) L D L^T, LARRB: @@ -15244,83 +15213,83 @@ module stdlib_linalg_lapack !! and WGAP, respectively. During bisection, intervals !! [left, right] are maintained by storing their mid-points and !! semi-widths in the arrays W and WERR respectively. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlarrb( n, d, lld, ifirst, ilast, rtol1,rtol2, offset, w, wgap, & werr, work, iwork,pivmin, spdiam, twist, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ifirst,ilast,n,offset,twist - integer(ilp), intent(out) :: info,iwork(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ifirst,ilast,n,offset,twist + integer(${ik}$), intent(out) :: info,iwork(*) real(dp), intent(in) :: pivmin,rtol1,rtol2,spdiam,d(*),lld(*) real(dp), intent(inout) :: w(*),werr(*),wgap(*) real(dp), intent(out) :: work(*) end subroutine dlarrb -#else - module procedure stdlib_dlarrb +#else + module procedure stdlib${ii}$_dlarrb #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larrb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slarrb( n, d, lld, ifirst, ilast, rtol1,rtol2, offset, w, wgap, & werr, work, iwork,pivmin, spdiam, twist, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ifirst,ilast,n,offset,twist - integer(ilp), intent(out) :: info,iwork(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ifirst,ilast,n,offset,twist + integer(${ik}$), intent(out) :: info,iwork(*) real(sp), intent(in) :: pivmin,rtol1,rtol2,spdiam,d(*),lld(*) real(sp), intent(inout) :: w(*),werr(*),wgap(*) real(sp), intent(out) :: work(*) end subroutine slarrb -#else - module procedure stdlib_slarrb +#else + module procedure stdlib${ii}$_slarrb #endif - end interface larrb - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larrb +#:endif +#:endfor +#:endfor + end interface larrb interface larrc !! Find the number of eigenvalues of the symmetric tridiagonal matrix T !! that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T !! if JOBT = 'L'. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlarrc( jobt, n, vl, vu, d, e, pivmin,eigcnt, lcnt, rcnt, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobt - integer(ilp), intent(out) :: eigcnt,info,lcnt,rcnt - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: eigcnt,info,lcnt,rcnt + integer(${ik}$), intent(in) :: n real(dp), intent(in) :: pivmin,vl,vu,d(*),e(*) end subroutine dlarrc -#else - module procedure stdlib_dlarrc +#else + module procedure stdlib${ii}$_dlarrc #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larrc - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slarrc( jobt, n, vl, vu, d, e, pivmin,eigcnt, lcnt, rcnt, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobt - integer(ilp), intent(out) :: eigcnt,info,lcnt,rcnt - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: eigcnt,info,lcnt,rcnt + integer(${ik}$), intent(in) :: n real(sp), intent(in) :: pivmin,vl,vu,d(*),e(*) end subroutine slarrc -#else - module procedure stdlib_slarrc +#else + module procedure stdlib${ii}$_slarrc #endif - end interface larrc - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larrc +#:endif +#:endfor +#:endfor + end interface larrc interface larrd !! LARRD computes the eigenvalues of a symmetric tridiagonal @@ -15335,45 +15304,45 @@ module stdlib_linalg_lapack !! See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal !! Matrix", Report CS41, Computer Science Dept., Stanford !! University, July 21, 1966. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlarrd( range, order, n, vl, vu, il, iu, gers,reltol, d, e, e2, & pivmin, nsplit, isplit,m, w, werr, wl, wu, iblock, indexw,work, iwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: order,range - integer(ilp), intent(in) :: il,iu,n,nsplit,isplit(*) - integer(ilp), intent(out) :: info,m,iblock(*),indexw(*),iwork(*) + integer(${ik}$), intent(in) :: il,iu,n,nsplit,isplit(*) + integer(${ik}$), intent(out) :: info,m,iblock(*),indexw(*),iwork(*) real(dp), intent(in) :: pivmin,reltol,vl,vu,d(*),e(*),e2(*),gers(*) real(dp), intent(out) :: wl,wu,w(*),werr(*),work(*) end subroutine dlarrd -#else - module procedure stdlib_dlarrd +#else + module procedure stdlib${ii}$_dlarrd #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larrd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slarrd( range, order, n, vl, vu, il, iu, gers,reltol, d, e, e2, & pivmin, nsplit, isplit,m, w, werr, wl, wu, iblock, indexw,work, iwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: order,range - integer(ilp), intent(in) :: il,iu,n,nsplit,isplit(*) - integer(ilp), intent(out) :: info,m,iblock(*),indexw(*),iwork(*) + integer(${ik}$), intent(in) :: il,iu,n,nsplit,isplit(*) + integer(${ik}$), intent(out) :: info,m,iblock(*),indexw(*),iwork(*) real(sp), intent(in) :: pivmin,reltol,vl,vu,d(*),e(*),e2(*),gers(*) real(sp), intent(out) :: wl,wu,w(*),werr(*),work(*) end subroutine slarrd -#else - module procedure stdlib_slarrd +#else + module procedure stdlib${ii}$_slarrd #endif - end interface larrd - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larrd +#:endif +#:endfor +#:endfor + end interface larrd interface larre !! To find the desired eigenvalues of a given real symmetric @@ -15389,49 +15358,49 @@ module stdlib_linalg_lapack !! conpute all and then discard any unwanted one. !! As an added benefit, LARRE also outputs the n !! Gerschgorin intervals for the matrices L_i D_i L_i^T. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlarre( range, n, vl, vu, il, iu, d, e, e2,rtol1, rtol2, spltol, & nsplit, isplit, m,w, werr, wgap, iblock, indexw, gers, pivmin,work, iwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: range - integer(ilp), intent(in) :: il,iu,n - integer(ilp), intent(out) :: info,m,nsplit,iblock(*),isplit(*),iwork(*),& + integer(${ik}$), intent(in) :: il,iu,n + integer(${ik}$), intent(out) :: info,m,nsplit,iblock(*),isplit(*),iwork(*),& indexw(*) real(dp), intent(out) :: pivmin,gers(*),w(*),werr(*),wgap(*),work(*) real(dp), intent(in) :: rtol1,rtol2,spltol real(dp), intent(inout) :: vl,vu,d(*),e(*),e2(*) end subroutine dlarre -#else - module procedure stdlib_dlarre +#else + module procedure stdlib${ii}$_dlarre #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larre - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slarre( range, n, vl, vu, il, iu, d, e, e2,rtol1, rtol2, spltol, & nsplit, isplit, m,w, werr, wgap, iblock, indexw, gers, pivmin,work, iwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: range - integer(ilp), intent(in) :: il,iu,n - integer(ilp), intent(out) :: info,m,nsplit,iblock(*),isplit(*),iwork(*),& + integer(${ik}$), intent(in) :: il,iu,n + integer(${ik}$), intent(out) :: info,m,nsplit,iblock(*),isplit(*),iwork(*),& indexw(*) real(sp), intent(out) :: pivmin,gers(*),w(*),werr(*),wgap(*),work(*) real(sp), intent(in) :: rtol1,rtol2,spltol real(sp), intent(inout) :: vl,vu,d(*),e(*),e2(*) end subroutine slarre -#else - module procedure stdlib_slarre +#else + module procedure stdlib${ii}$_slarre #endif - end interface larre - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larre +#:endif +#:endfor +#:endfor + end interface larre interface larrf !! Given the initial representation L D L^T and its cluster of close @@ -15439,45 +15408,45 @@ module stdlib_linalg_lapack !! W( CLEND ), LARRF: finds a new relatively robust representation !! L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the !! eigenvalues of L(+) D(+) L(+)^T is relatively isolated. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlarrf( n, d, l, ld, clstrt, clend,w, wgap, werr,spdiam, clgapl, & clgapr, pivmin, sigma,dplus, lplus, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: clstrt,clend,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: clstrt,clend,n + integer(${ik}$), intent(out) :: info real(dp), intent(in) :: clgapl,clgapr,pivmin,spdiam,d(*),l(*),ld(*),w(*),werr(& *) real(dp), intent(out) :: sigma,dplus(*),lplus(*),work(*) real(dp), intent(inout) :: wgap(*) end subroutine dlarrf -#else - module procedure stdlib_dlarrf +#else + module procedure stdlib${ii}$_dlarrf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larrf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slarrf( n, d, l, ld, clstrt, clend,w, wgap, werr,spdiam, clgapl, & clgapr, pivmin, sigma,dplus, lplus, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: clstrt,clend,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: clstrt,clend,n + integer(${ik}$), intent(out) :: info real(sp), intent(in) :: clgapl,clgapr,pivmin,spdiam,d(*),l(*),ld(*),w(*),werr(& *) real(sp), intent(out) :: sigma,dplus(*),lplus(*),work(*) real(sp), intent(inout) :: wgap(*) end subroutine slarrf -#else - module procedure stdlib_slarrf +#else + module procedure stdlib${ii}$_slarrf #endif - end interface larrf - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larrf +#:endif +#:endfor +#:endfor + end interface larrf interface larrj !! Given the initial eigenvalue approximations of T, LARRJ: @@ -15487,43 +15456,43 @@ module stdlib_linalg_lapack !! of the error in these guesses in WERR. During bisection, intervals !! [left, right] are maintained by storing their mid-points and !! semi-widths in the arrays W and WERR respectively. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlarrj( n, d, e2, ifirst, ilast,rtol, offset, w, werr, work, iwork,& pivmin, spdiam, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ifirst,ilast,n,offset - integer(ilp), intent(out) :: info,iwork(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ifirst,ilast,n,offset + integer(${ik}$), intent(out) :: info,iwork(*) real(dp), intent(in) :: pivmin,rtol,spdiam,d(*),e2(*) real(dp), intent(inout) :: w(*),werr(*) real(dp), intent(out) :: work(*) end subroutine dlarrj -#else - module procedure stdlib_dlarrj +#else + module procedure stdlib${ii}$_dlarrj #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larrj - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slarrj( n, d, e2, ifirst, ilast,rtol, offset, w, werr, work, iwork,& pivmin, spdiam, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ifirst,ilast,n,offset - integer(ilp), intent(out) :: info,iwork(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ifirst,ilast,n,offset + integer(${ik}$), intent(out) :: info,iwork(*) real(sp), intent(in) :: pivmin,rtol,spdiam,d(*),e2(*) real(sp), intent(inout) :: w(*),werr(*) real(sp), intent(out) :: work(*) end subroutine slarrj -#else - module procedure stdlib_slarrj +#else + module procedure stdlib${ii}$_slarrj #endif - end interface larrj - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larrj +#:endif +#:endfor +#:endfor + end interface larrj interface larrk !! LARRK computes one eigenvalue of a symmetric tridiagonal @@ -15535,163 +15504,163 @@ module stdlib_linalg_lapack !! See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal !! Matrix", Report CS41, Computer Science Dept., Stanford !! University, July 21, 1966. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlarrk( n, iw, gl, gu,d, e2, pivmin, reltol, w, werr, info) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: iw,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: iw,n real(dp), intent(in) :: pivmin,reltol,gl,gu,d(*),e2(*) real(dp), intent(out) :: w,werr end subroutine dlarrk -#else - module procedure stdlib_dlarrk +#else + module procedure stdlib${ii}$_dlarrk #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larrk - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slarrk( n, iw, gl, gu,d, e2, pivmin, reltol, w, werr, info) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: iw,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: iw,n real(sp), intent(in) :: pivmin,reltol,gl,gu,d(*),e2(*) real(sp), intent(out) :: w,werr end subroutine slarrk -#else - module procedure stdlib_slarrk +#else + module procedure stdlib${ii}$_slarrk #endif - end interface larrk - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larrk +#:endif +#:endfor +#:endfor + end interface larrk interface larrr !! Perform tests to decide whether the symmetric tridiagonal matrix T !! warrants expensive computations which guarantee high relative accuracy !! in the eigenvalues. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlarrr( n, d, e, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: n + integer(${ik}$), intent(out) :: info real(dp), intent(in) :: d(*) real(dp), intent(inout) :: e(*) end subroutine dlarrr -#else - module procedure stdlib_dlarrr +#else + module procedure stdlib${ii}$_dlarrr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larrr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slarrr( n, d, e, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: n + integer(${ik}$), intent(out) :: info real(sp), intent(in) :: d(*) real(sp), intent(inout) :: e(*) end subroutine slarrr -#else - module procedure stdlib_slarrr +#else + module procedure stdlib${ii}$_slarrr #endif - end interface larrr - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larrr +#:endif +#:endfor +#:endfor + end interface larrr interface larrv !! LARRV computes the eigenvectors of the tridiagonal matrix !! T = L D L**T given L, D and APPROXIMATIONS to the eigenvalues of L D L**T. !! The input eigenvalues should have been computed by SLARRE. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clarrv( n, vl, vu, d, l, pivmin,isplit, m, dol, dou, minrgp,rtol1, & rtol2, w, werr, wgap,iblock, indexw, gers, z, ldz, isuppz,work, iwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: dol,dou,ldz,m,n,iblock(*),indexw(*),isplit(*) - - integer(ilp), intent(out) :: info,isuppz(*),iwork(*) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: dol,dou,ldz,m,n,iblock(*),indexw(*),isplit(*) + + integer(${ik}$), intent(out) :: info,isuppz(*),iwork(*) real(sp), intent(in) :: minrgp,pivmin,vl,vu,gers(*) real(sp), intent(inout) :: rtol1,rtol2,d(*),l(*),w(*),werr(*),wgap(*) real(sp), intent(out) :: work(*) complex(sp), intent(out) :: z(ldz,*) end subroutine clarrv -#else - module procedure stdlib_clarrv +#else + module procedure stdlib${ii}$_clarrv #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlarrv( n, vl, vu, d, l, pivmin,isplit, m, dol, dou, minrgp,rtol1, & rtol2, w, werr, wgap,iblock, indexw, gers, z, ldz, isuppz,work, iwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: dol,dou,ldz,m,n,iblock(*),indexw(*),isplit(*) - - integer(ilp), intent(out) :: info,isuppz(*),iwork(*) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: dol,dou,ldz,m,n,iblock(*),indexw(*),isplit(*) + + integer(${ik}$), intent(out) :: info,isuppz(*),iwork(*) real(dp), intent(in) :: minrgp,pivmin,vl,vu,gers(*) real(dp), intent(inout) :: rtol1,rtol2,d(*),l(*),w(*),werr(*),wgap(*) real(dp), intent(out) :: work(*),z(ldz,*) end subroutine dlarrv -#else - module procedure stdlib_dlarrv +#else + module procedure stdlib${ii}$_dlarrv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larrv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slarrv( n, vl, vu, d, l, pivmin,isplit, m, dol, dou, minrgp,rtol1, & rtol2, w, werr, wgap,iblock, indexw, gers, z, ldz, isuppz,work, iwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: dol,dou,ldz,m,n,iblock(*),indexw(*),isplit(*) - - integer(ilp), intent(out) :: info,isuppz(*),iwork(*) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: dol,dou,ldz,m,n,iblock(*),indexw(*),isplit(*) + + integer(${ik}$), intent(out) :: info,isuppz(*),iwork(*) real(sp), intent(in) :: minrgp,pivmin,vl,vu,gers(*) real(sp), intent(inout) :: rtol1,rtol2,d(*),l(*),w(*),werr(*),wgap(*) real(sp), intent(out) :: work(*),z(ldz,*) end subroutine slarrv -#else - module procedure stdlib_slarrv +#else + module procedure stdlib${ii}$_slarrv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larrv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlarrv( n, vl, vu, d, l, pivmin,isplit, m, dol, dou, minrgp,rtol1, & rtol2, w, werr, wgap,iblock, indexw, gers, z, ldz, isuppz,work, iwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: dol,dou,ldz,m,n,iblock(*),indexw(*),isplit(*) - - integer(ilp), intent(out) :: info,isuppz(*),iwork(*) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: dol,dou,ldz,m,n,iblock(*),indexw(*),isplit(*) + + integer(${ik}$), intent(out) :: info,isuppz(*),iwork(*) real(dp), intent(in) :: minrgp,pivmin,vl,vu,gers(*) real(dp), intent(inout) :: rtol1,rtol2,d(*),l(*),w(*),werr(*),wgap(*) real(dp), intent(out) :: work(*) complex(dp), intent(out) :: z(ldz,*) end subroutine zlarrv -#else - module procedure stdlib_zlarrv +#else + module procedure stdlib${ii}$_zlarrv #endif - end interface larrv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larrv +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larrv +#:endif +#:endfor +#:endfor + end interface larrv interface lartg !! LARTG generates a plane rotation so that @@ -15716,64 +15685,29 @@ module stdlib_linalg_lapack !! If G=0, then C=1 and S=0. !! If F=0, then C=0 and S is chosen so that R is real. !! Below, wp=>sp stands for single precision from LA_CONSTANTS module. -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine clartg( f, g, c, s, r ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - real(sp), intent(out) :: c - complex(sp), intent(in) :: f,g - complex(sp), intent(out) :: r,s - end subroutine clartg -#else - module procedure stdlib_clartg -#endif -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine dlartg( f, g, c, s, r ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - real(dp), intent(out) :: c,r,s - real(dp), intent(in) :: f,g - end subroutine dlartg -#else - module procedure stdlib_dlartg -#endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lartg - +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#:for rk,rt,ri in RC_KINDS_TYPES +#:if rk in ["sp","dp"] +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine ${ri}$lartg( f, g, c, s, r ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + real(${rk}$), intent(out) :: c + ${rt}$, intent(in) :: f,g + ${rt}$, intent(out) :: r,s + end subroutine ${ri}$lartg +#:if not 'ilp64' in ik +#else + module procedure stdlib${ii}$_${ri}$lartg +#:endif +#endif +#:elif not 'ilp64' in ik + module procedure stdlib${ii}$_${ri}$lartg #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine slartg( f, g, c, s, r ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - real(sp), intent(out) :: c,r,s - real(sp), intent(in) :: f,g - end subroutine slartg -#else - module procedure stdlib_slartg -#endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lartg - -#:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine zlartg( f, g, c, s, r ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - real(dp), intent(out) :: c - complex(dp), intent(in) :: f,g - complex(dp), intent(out) :: r,s - end subroutine zlartg -#else - module procedure stdlib_zlartg -#endif end interface lartg - - interface lartgp !! LARTGP generates a plane rotation so that !! [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. @@ -15784,36 +15718,28 @@ module stdlib_linalg_lapack !! If G=0, then CS=(+/-)1 and SN=0. !! If F=0 and (G .ne. 0), then CS=0 and SN=(+/-)1. !! The sign is chosen so that R >= 0. -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine dlartgp( f, g, cs, sn, r ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - real(dp), intent(out) :: cs,r,sn - real(dp), intent(in) :: f,g - end subroutine dlartgp -#else - module procedure stdlib_dlartgp -#endif +#:for ik,it,ii in LINALG_INT_KINDS_TYPES #:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lartgp - +#:if rk in ["sp","dp"] +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine ${ri}$lartgp( f, g, cs, sn, r ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + ${rt}$, intent(out) :: cs,r,sn + ${rt}$, intent(in) :: f,g + end subroutine ${ri}$lartgp +#:if not 'ilp64' in ik +#else + module procedure stdlib${ii}$_${ri}$lartgp +#:endif +#endif +#:elif not 'ilp64' in ik + module procedure stdlib${ii}$_${ri}$lartgp #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine slartgp( f, g, cs, sn, r ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - real(sp), intent(out) :: cs,r,sn - real(sp), intent(in) :: f,g - end subroutine slartgp -#else - module procedure stdlib_slartgp -#endif +#:endfor end interface lartgp - - interface lartgs !! LARTGS generates a plane rotation designed to introduce a bulge in !! Golub-Reinsch-style implicit QR iteration for the bidiagonal SVD @@ -15823,139 +15749,131 @@ module stdlib_linalg_lapack !! [ -SN CS ] [ X * Y ] [ 0 ] !! with R nonnegative. If X^2 - SIGMA and X * Y are 0, then the !! rotation is by PI/2. -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine dlartgs( x, y, sigma, cs, sn ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - real(dp), intent(out) :: cs,sn - real(dp), intent(in) :: sigma,x,y - end subroutine dlartgs -#else - module procedure stdlib_dlartgs -#endif +#:for ik,it,ii in LINALG_INT_KINDS_TYPES #:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lartgs - +#:if rk in ["sp","dp"] +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine ${ri}$lartgs( x, y, sigma, cs, sn ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + ${rt}$, intent(out) :: cs,sn + ${rt}$, intent(in) :: sigma,x,y + end subroutine ${ri}$lartgs +#:if not 'ilp64' in ik +#else + module procedure stdlib${ii}$_${ri}$lartgs +#:endif +#endif +#:elif not 'ilp64' in ik + module procedure stdlib${ii}$_${ri}$lartgs #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine slartgs( x, y, sigma, cs, sn ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - real(sp), intent(out) :: cs,sn - real(sp), intent(in) :: sigma,x,y - end subroutine slartgs -#else - module procedure stdlib_slartgs -#endif +#:endfor end interface lartgs - - interface lartv !! LARTV applies a vector of complex plane rotations with real cosines !! to elements of the complex vectors x and y. For i = 1,2,...,n !! ( x(i) ) := ( c(i) s(i) ) ( x(i) ) !! ( y(i) ) ( -conjg(s(i)) c(i) ) ( y(i) ) -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clartv( n, x, incx, y, incy, c, s, incc ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incc,incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incc,incx,incy,n real(sp), intent(in) :: c(*) complex(sp), intent(in) :: s(*) complex(sp), intent(inout) :: x(*),y(*) end subroutine clartv -#else - module procedure stdlib_clartv +#else + module procedure stdlib${ii}$_clartv #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlartv( n, x, incx, y, incy, c, s, incc ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incc,incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incc,incx,incy,n real(dp), intent(in) :: c(*),s(*) real(dp), intent(inout) :: x(*),y(*) end subroutine dlartv -#else - module procedure stdlib_dlartv +#else + module procedure stdlib${ii}$_dlartv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lartv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slartv( n, x, incx, y, incy, c, s, incc ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incc,incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incc,incx,incy,n real(sp), intent(in) :: c(*),s(*) real(sp), intent(inout) :: x(*),y(*) end subroutine slartv -#else - module procedure stdlib_slartv +#else + module procedure stdlib${ii}$_slartv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lartv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlartv( n, x, incx, y, incy, c, s, incc ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incc,incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incc,incx,incy,n real(dp), intent(in) :: c(*) complex(dp), intent(in) :: s(*) complex(dp), intent(inout) :: x(*),y(*) end subroutine zlartv -#else - module procedure stdlib_zlartv +#else + module procedure stdlib${ii}$_zlartv #endif - end interface lartv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lartv +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lartv +#:endif +#:endfor +#:endfor + end interface lartv interface laruv !! LARUV returns a vector of n random real numbers from a uniform (0,1) !! distribution (n <= 128). !! This is an auxiliary routine called by DLARNV and ZLARNV. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaruv( iseed, n, x ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: n - integer(ilp), intent(inout) :: iseed(4) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: n + integer(${ik}$), intent(inout) :: iseed(4) real(dp), intent(out) :: x(n) end subroutine dlaruv -#else - module procedure stdlib_dlaruv +#else + module procedure stdlib${ii}$_dlaruv +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine slaruv( iseed, n, x ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: n + integer(${ik}$), intent(inout) :: iseed(4) + real(sp), intent(out) :: x(n) + end subroutine slaruv +#else + module procedure stdlib${ii}$_slaruv #endif #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laruv + module procedure stdlib${ii}$_${ri}$laruv #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine slaruv( iseed, n, x ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: n - integer(ilp), intent(inout) :: iseed(4) - real(sp), intent(out) :: x(n) - end subroutine slaruv -#else - module procedure stdlib_slaruv -#endif +#:endfor end interface laruv - - interface larz !! LARZ applies a complex elementary reflector H to a complex !! M-by-N matrix C, from either the left or the right. H is represented @@ -15966,145 +15884,145 @@ module stdlib_linalg_lapack !! To apply H**H (the conjugate transpose of H), supply conjg(tau) instead !! tau. !! H is a product of k elementary reflectors as returned by CTZRZF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clarz( side, m, n, l, v, incv, tau, c, ldc, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side - integer(ilp), intent(in) :: incv,l,ldc,m,n + integer(${ik}$), intent(in) :: incv,l,ldc,m,n complex(sp), intent(in) :: tau,v(*) complex(sp), intent(inout) :: c(ldc,*) complex(sp), intent(out) :: work(*) end subroutine clarz -#else - module procedure stdlib_clarz +#else + module procedure stdlib${ii}$_clarz #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlarz( side, m, n, l, v, incv, tau, c, ldc, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side - integer(ilp), intent(in) :: incv,l,ldc,m,n + integer(${ik}$), intent(in) :: incv,l,ldc,m,n real(dp), intent(in) :: tau,v(*) real(dp), intent(inout) :: c(ldc,*) real(dp), intent(out) :: work(*) end subroutine dlarz -#else - module procedure stdlib_dlarz +#else + module procedure stdlib${ii}$_dlarz #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larz - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slarz( side, m, n, l, v, incv, tau, c, ldc, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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,v(*) real(sp), intent(inout) :: c(ldc,*) real(sp), intent(out) :: work(*) end subroutine slarz -#else - module procedure stdlib_slarz +#else + module procedure stdlib${ii}$_slarz +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine zlarz( side, m, n, l, v, incv, tau, c, ldc, work ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + character, intent(in) :: side + integer(${ik}$), intent(in) :: incv,l,ldc,m,n + complex(dp), intent(in) :: tau,v(*) + complex(dp), intent(inout) :: c(ldc,*) + complex(dp), intent(out) :: work(*) + end subroutine zlarz +#else + module procedure stdlib${ii}$_zlarz #endif +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larz + +#:endif +#:endfor #:for rk,rt,ri in CMPLX_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larz + module procedure stdlib${ii}$_${ri}$larz #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine zlarz( side, m, n, l, v, incv, tau, c, ldc, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - character, intent(in) :: side - integer(ilp), intent(in) :: incv,l,ldc,m,n - complex(dp), intent(in) :: tau,v(*) - complex(dp), intent(inout) :: c(ldc,*) - complex(dp), intent(out) :: work(*) - end subroutine zlarz -#else - module procedure stdlib_zlarz -#endif +#:endfor end interface larz - - interface larzb !! LARZB applies a complex block reflector H or its transpose H**H !! to a complex distributed M-by-N C from the left or the right. !! Currently, only STOREV = 'R' and DIRECT = 'B' are supported. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clarzb( side, trans, direct, storev, m, n, k, l, v,ldv, t, ldt, c, & ldc, work, ldwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(inout) :: c(ldc,*),t(ldt,*),v(ldv,*) complex(sp), intent(out) :: work(ldwork,*) end subroutine clarzb -#else - module procedure stdlib_clarzb +#else + module procedure stdlib${ii}$_clarzb #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlarzb( side, trans, direct, storev, m, n, k, l, v,ldv, t, ldt, c, & ldc, work, ldwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(inout) :: c(ldc,*),t(ldt,*),v(ldv,*) real(dp), intent(out) :: work(ldwork,*) end subroutine dlarzb -#else - module procedure stdlib_dlarzb +#else + module procedure stdlib${ii}$_dlarzb #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larzb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slarzb( side, trans, direct, storev, m, n, k, l, v,ldv, t, ldt, c, & ldc, work, ldwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: c(ldc,*),t(ldt,*),v(ldv,*) real(sp), intent(out) :: work(ldwork,*) end subroutine slarzb -#else - module procedure stdlib_slarzb +#else + module procedure stdlib${ii}$_slarzb #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larzb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlarzb( side, trans, direct, storev, m, n, k, l, v,ldv, t, ldt, c, & ldc, work, ldwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(inout) :: c(ldc,*),t(ldt,*),v(ldv,*) complex(dp), intent(out) :: work(ldwork,*) end subroutine zlarzb -#else - module procedure stdlib_zlarzb +#else + module procedure stdlib${ii}$_zlarzb #endif - end interface larzb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larzb +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larzb +#:endif +#:endfor +#:endfor + end interface larzb interface larzt !! LARZT forms the triangular factor T of a complex block reflector @@ -16119,73 +16037,73 @@ module stdlib_linalg_lapack !! H(i) is stored in the i-th row of the array V, and !! H = I - V**H * T * V !! Currently, only STOREV = 'R' and DIRECT = 'B' are supported. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clarzt( direct, storev, n, k, v, ldv, tau, t, ldt ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: direct,storev - integer(ilp), intent(in) :: k,ldt,ldv,n + integer(${ik}$), intent(in) :: k,ldt,ldv,n complex(sp), intent(out) :: t(ldt,*) complex(sp), intent(in) :: tau(*) complex(sp), intent(inout) :: v(ldv,*) end subroutine clarzt -#else - module procedure stdlib_clarzt +#else + module procedure stdlib${ii}$_clarzt #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlarzt( direct, storev, n, k, v, ldv, tau, t, ldt ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: direct,storev - integer(ilp), intent(in) :: k,ldt,ldv,n + integer(${ik}$), intent(in) :: k,ldt,ldv,n real(dp), intent(out) :: t(ldt,*) real(dp), intent(in) :: tau(*) real(dp), intent(inout) :: v(ldv,*) end subroutine dlarzt -#else - module procedure stdlib_dlarzt +#else + module procedure stdlib${ii}$_dlarzt #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larzt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slarzt( direct, storev, n, k, v, ldv, tau, t, ldt ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: direct,storev - integer(ilp), intent(in) :: k,ldt,ldv,n + integer(${ik}$), intent(in) :: k,ldt,ldv,n real(sp), intent(out) :: t(ldt,*) real(sp), intent(in) :: tau(*) real(sp), intent(inout) :: v(ldv,*) end subroutine slarzt -#else - module procedure stdlib_slarzt +#else + module procedure stdlib${ii}$_slarzt #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$larzt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlarzt( direct, storev, n, k, v, ldv, tau, t, ldt ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: direct,storev - integer(ilp), intent(in) :: k,ldt,ldv,n + integer(${ik}$), intent(in) :: k,ldt,ldv,n complex(dp), intent(out) :: t(ldt,*) complex(dp), intent(in) :: tau(*) complex(dp), intent(inout) :: v(ldv,*) end subroutine zlarzt -#else - module procedure stdlib_zlarzt +#else + module procedure stdlib${ii}$_zlarzt #endif - end interface larzt +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larzt +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$larzt +#:endif +#:endfor +#:endfor + end interface larzt interface lascl !! LASCL multiplies the M by N complex matrix A by the real scalar @@ -16193,73 +16111,73 @@ module stdlib_linalg_lapack !! result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that !! A may be full, upper triangular, lower triangular, upper Hessenberg, !! or banded. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clascl( type, kl, ku, cfrom, cto, m, n, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(inout) :: a(lda,*) end subroutine clascl -#else - module procedure stdlib_clascl +#else + module procedure stdlib${ii}$_clascl #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlascl( type, kl, ku, cfrom, cto, m, n, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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(dp), intent(in) :: cfrom,cto real(dp), intent(inout) :: a(lda,*) end subroutine dlascl -#else - module procedure stdlib_dlascl +#else + module procedure stdlib${ii}$_dlascl #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lascl - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slascl( type, kl, ku, cfrom, cto, m, n, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: a(lda,*) end subroutine slascl -#else - module procedure stdlib_slascl +#else + module procedure stdlib${ii}$_slascl #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lascl - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlascl( type, kl, ku, cfrom, cto, m, n, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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(dp), intent(in) :: cfrom,cto complex(dp), intent(inout) :: a(lda,*) end subroutine zlascl -#else - module procedure stdlib_zlascl +#else + module procedure stdlib${ii}$_zlascl #endif - end interface lascl +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lascl +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lascl +#:endif +#:endfor +#:endfor + end interface lascl interface lasd0 !! Using a divide and conquer approach, LASD0: computes the singular @@ -16269,41 +16187,41 @@ module stdlib_linalg_lapack !! B = U * S * VT. The singular values S are overwritten on D. !! A related subroutine, DLASDA, computes only the singular values, !! and optionally, the singular vectors in compact form. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlasd0( n, sqre, d, e, u, ldu, vt, ldvt, smlsiz, iwork,work, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldu,ldvt,n,smlsiz,sqre + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldu,ldvt,n,smlsiz,sqre real(dp), intent(inout) :: d(*),e(*) real(dp), intent(out) :: u(ldu,*),vt(ldvt,*),work(*) end subroutine dlasd0 -#else - module procedure stdlib_dlasd0 +#else + module procedure stdlib${ii}$_dlasd0 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lasd0 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slasd0( n, sqre, d, e, u, ldu, vt, ldvt, smlsiz, iwork,work, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldu,ldvt,n,smlsiz,sqre + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldu,ldvt,n,smlsiz,sqre real(sp), intent(inout) :: d(*),e(*) real(sp), intent(out) :: u(ldu,*),vt(ldvt,*),work(*) end subroutine slasd0 -#else - module procedure stdlib_slasd0 +#else + module procedure stdlib${ii}$_slasd0 #endif - end interface lasd0 - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lasd0 +#:endif +#:endfor +#:endfor + end interface lasd0 interface lasd1 !! LASD1 computes the SVD of an upper bidiagonal N-by-M matrix B, @@ -16335,43 +16253,43 @@ module stdlib_linalg_lapack !! directly using the updated singular values. The singular vectors !! for the current problem are multiplied with the singular vectors !! from the overall problem. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlasd1( nl, nr, sqre, d, alpha, beta, u, ldu, vt, ldvt,idxq, iwork,& work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldu,ldvt,nl,nr,sqre + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldu,ldvt,nl,nr,sqre real(dp), intent(inout) :: alpha,beta,d(*),u(ldu,*),vt(ldvt,*) - integer(ilp), intent(inout) :: idxq(*) + integer(${ik}$), intent(inout) :: idxq(*) real(dp), intent(out) :: work(*) end subroutine dlasd1 -#else - module procedure stdlib_dlasd1 +#else + module procedure stdlib${ii}$_dlasd1 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lasd1 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slasd1( nl, nr, sqre, d, alpha, beta, u, ldu, vt, ldvt,idxq, iwork,& work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldu,ldvt,nl,nr,sqre + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldu,ldvt,nl,nr,sqre real(sp), intent(inout) :: alpha,beta,d(*),u(ldu,*),vt(ldvt,*) - integer(ilp), intent(inout) :: idxq(*) + integer(${ik}$), intent(inout) :: idxq(*) real(sp), intent(out) :: work(*) end subroutine slasd1 -#else - module procedure stdlib_slasd1 +#else + module procedure stdlib${ii}$_slasd1 #endif - end interface lasd1 - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lasd1 +#:endif +#:endfor +#:endfor + end interface lasd1 interface lasd4 !! This subroutine computes the square root of the I-th updated @@ -16385,39 +16303,39 @@ module stdlib_linalg_lapack !! where we assume the Euclidean norm of Z is 1. !! The method consists of approximating the rational functions in the !! secular equation by simpler interpolating rational functions. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlasd4( n, i, d, z, delta, rho, sigma, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: i,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: i,n + integer(${ik}$), intent(out) :: info real(dp), intent(in) :: rho,d(*),z(*) real(dp), intent(out) :: sigma,delta(*),work(*) end subroutine dlasd4 -#else - module procedure stdlib_dlasd4 +#else + module procedure stdlib${ii}$_dlasd4 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lasd4 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slasd4( n, i, d, z, delta, rho, sigma, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: i,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: i,n + integer(${ik}$), intent(out) :: info real(sp), intent(in) :: rho,d(*),z(*) real(sp), intent(out) :: sigma,delta(*),work(*) end subroutine slasd4 -#else - module procedure stdlib_slasd4 +#else + module procedure stdlib${ii}$_slasd4 #endif - end interface lasd4 - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lasd4 +#:endif +#:endfor +#:endfor + end interface lasd4 interface lasd5 !! This subroutine computes the square root of the I-th eigenvalue @@ -16428,37 +16346,37 @@ module stdlib_linalg_lapack !! 0 <= D(i) < D(j) for i < j . !! We also assume RHO > 0 and that the Euclidean norm of the vector !! Z is one. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlasd5( i, d, z, delta, rho, dsigma, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: i + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: i real(dp), intent(out) :: dsigma,delta(2),work(2) real(dp), intent(in) :: rho,d(2),z(2) end subroutine dlasd5 -#else - module procedure stdlib_dlasd5 +#else + module procedure stdlib${ii}$_dlasd5 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lasd5 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slasd5( i, d, z, delta, rho, dsigma, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: i + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: i real(sp), intent(out) :: dsigma,delta(2),work(2) real(sp), intent(in) :: rho,d(2),z(2) end subroutine slasd5 -#else - module procedure stdlib_slasd5 +#else + module procedure stdlib${ii}$_slasd5 #endif - end interface lasd5 - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lasd5 +#:endif +#:endfor +#:endfor + end interface lasd5 interface lasd6 !! LASD6 computes the SVD of an updated upper bidiagonal matrix B @@ -16496,49 +16414,49 @@ module stdlib_linalg_lapack !! between the updated singular values and the old singular !! values. !! LASD6 is called from DLASDA. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlasd6( icompq, nl, nr, sqre, d, vf, vl, alpha, beta,idxq, perm, & givptr, givcol, ldgcol, givnum,ldgnum, poles, difl, difr, z, k, c, s, work,iwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: givptr,info,k,givcol(ldgcol,*),iwork(*),perm(*) - - integer(ilp), intent(in) :: icompq,ldgcol,ldgnum,nl,nr,sqre + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: givptr,info,k,givcol(ldgcol,*),iwork(*),perm(*) + + integer(${ik}$), intent(in) :: icompq,ldgcol,ldgnum,nl,nr,sqre real(dp), intent(inout) :: alpha,beta,d(*),vf(*),vl(*) real(dp), intent(out) :: c,s,difl(*),difr(*),givnum(ldgnum,*),poles(ldgnum,*),& work(*),z(*) - integer(ilp), intent(inout) :: idxq(*) + integer(${ik}$), intent(inout) :: idxq(*) end subroutine dlasd6 -#else - module procedure stdlib_dlasd6 +#else + module procedure stdlib${ii}$_dlasd6 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lasd6 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slasd6( icompq, nl, nr, sqre, d, vf, vl, alpha, beta,idxq, perm, & givptr, givcol, ldgcol, givnum,ldgnum, poles, difl, difr, z, k, c, s, work,iwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: givptr,info,k,givcol(ldgcol,*),iwork(*),perm(*) - - integer(ilp), intent(in) :: icompq,ldgcol,ldgnum,nl,nr,sqre + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: givptr,info,k,givcol(ldgcol,*),iwork(*),perm(*) + + integer(${ik}$), intent(in) :: icompq,ldgcol,ldgnum,nl,nr,sqre real(sp), intent(inout) :: alpha,beta,d(*),vf(*),vl(*) real(sp), intent(out) :: c,s,difl(*),difr(*),givnum(ldgnum,*),poles(ldgnum,*),& work(*),z(*) - integer(ilp), intent(inout) :: idxq(*) + integer(${ik}$), intent(inout) :: idxq(*) end subroutine slasd6 -#else - module procedure stdlib_slasd6 +#else + module procedure stdlib${ii}$_slasd6 #endif - end interface lasd6 - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lasd6 +#:endif +#:endfor +#:endfor + end interface lasd6 interface lasd7 !! LASD7 merges the two sets of singular values together into a single @@ -16548,51 +16466,51 @@ module stdlib_linalg_lapack !! vector. For each such occurrence the order of the related !! secular equation problem is reduced by one. !! LASD7 is called from DLASD6. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlasd7( icompq, nl, nr, sqre, k, d, z, zw, vf, vfw, vl,vlw, alpha, & beta, dsigma, idx, idxp, idxq,perm, givptr, givcol, ldgcol, givnum, ldgnum,c, s, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: givptr,info,k,givcol(ldgcol,*),idx(*),idxp(*),& + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: givptr,info,k,givcol(ldgcol,*),idx(*),idxp(*),& perm(*) - integer(ilp), intent(in) :: icompq,ldgcol,ldgnum,nl,nr,sqre + integer(${ik}$), intent(in) :: icompq,ldgcol,ldgnum,nl,nr,sqre real(dp), intent(in) :: alpha,beta real(dp), intent(out) :: c,s,dsigma(*),givnum(ldgnum,*),vfw(*),vlw(*),z(*),zw(& *) - integer(ilp), intent(inout) :: idxq(*) + integer(${ik}$), intent(inout) :: idxq(*) real(dp), intent(inout) :: d(*),vf(*),vl(*) end subroutine dlasd7 -#else - module procedure stdlib_dlasd7 +#else + module procedure stdlib${ii}$_dlasd7 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lasd7 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slasd7( icompq, nl, nr, sqre, k, d, z, zw, vf, vfw, vl,vlw, alpha, & beta, dsigma, idx, idxp, idxq,perm, givptr, givcol, ldgcol, givnum, ldgnum,c, s, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: givptr,info,k,givcol(ldgcol,*),idx(*),idxp(*),& + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: givptr,info,k,givcol(ldgcol,*),idx(*),idxp(*),& perm(*) - integer(ilp), intent(in) :: icompq,ldgcol,ldgnum,nl,nr,sqre + integer(${ik}$), intent(in) :: icompq,ldgcol,ldgnum,nl,nr,sqre real(sp), intent(in) :: alpha,beta real(sp), intent(out) :: c,s,dsigma(*),givnum(ldgnum,*),vfw(*),vlw(*),z(*),zw(& *) - integer(ilp), intent(inout) :: idxq(*) + integer(${ik}$), intent(inout) :: idxq(*) real(sp), intent(inout) :: d(*),vf(*),vl(*) end subroutine slasd7 -#else - module procedure stdlib_slasd7 +#else + module procedure stdlib${ii}$_slasd7 #endif - end interface lasd7 - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lasd7 +#:endif +#:endfor +#:endfor + end interface lasd7 interface lasd8 !! LASD8 finds the square roots of the roots of the secular equation, @@ -16602,41 +16520,41 @@ module stdlib_linalg_lapack !! the arrays VF and VL, the first and last components of all the !! right singular vectors of the original bidiagonal matrix. !! LASD8 is called from DLASD6. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlasd8( icompq, k, d, z, vf, vl, difl, difr, lddifr,dsigma, work, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: icompq,k,lddifr - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: icompq,k,lddifr + integer(${ik}$), intent(out) :: info real(dp), intent(out) :: d(*),difl(*),difr(lddifr,*),work(*) real(dp), intent(inout) :: dsigma(*),vf(*),vl(*),z(*) end subroutine dlasd8 -#else - module procedure stdlib_dlasd8 +#else + module procedure stdlib${ii}$_dlasd8 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lasd8 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slasd8( icompq, k, d, z, vf, vl, difl, difr, lddifr,dsigma, work, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: icompq,k,lddifr - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: icompq,k,lddifr + integer(${ik}$), intent(out) :: info real(sp), intent(out) :: d(*),difl(*),difr(lddifr,*),work(*) real(sp), intent(inout) :: dsigma(*),vf(*),vl(*),z(*) end subroutine slasd8 -#else - module procedure stdlib_slasd8 +#else + module procedure stdlib${ii}$_slasd8 #endif - end interface lasd8 - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lasd8 +#:endif +#:endfor +#:endfor + end interface lasd8 interface lasda !! Using a divide and conquer approach, LASDA: computes the singular @@ -16647,45 +16565,45 @@ module stdlib_linalg_lapack !! compact form. !! A related subroutine, DLASD0, computes the singular values and !! the singular vectors in explicit form. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlasda( icompq, smlsiz, n, sqre, d, e, u, ldu, vt, k,difl, difr, z,& poles, givptr, givcol, ldgcol,perm, givnum, c, s, work, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: icompq,ldgcol,ldu,n,smlsiz,sqre - integer(ilp), intent(out) :: info,givcol(ldgcol,*),givptr(*),iwork(*),k(*),& + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: icompq,ldgcol,ldu,n,smlsiz,sqre + integer(${ik}$), intent(out) :: info,givcol(ldgcol,*),givptr(*),iwork(*),k(*),& perm(ldgcol,*) real(dp), intent(out) :: c(*),difl(ldu,*),difr(ldu,*),givnum(ldu,*),poles(ldu,& *),s(*),u(ldu,*),vt(ldu,*),work(*),z(ldu,*) real(dp), intent(inout) :: d(*),e(*) end subroutine dlasda -#else - module procedure stdlib_dlasda +#else + module procedure stdlib${ii}$_dlasda #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lasda - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slasda( icompq, smlsiz, n, sqre, d, e, u, ldu, vt, k,difl, difr, z,& poles, givptr, givcol, ldgcol,perm, givnum, c, s, work, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: icompq,ldgcol,ldu,n,smlsiz,sqre - integer(ilp), intent(out) :: info,givcol(ldgcol,*),givptr(*),iwork(*),k(*),& + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: icompq,ldgcol,ldu,n,smlsiz,sqre + integer(${ik}$), intent(out) :: info,givcol(ldgcol,*),givptr(*),iwork(*),k(*),& perm(ldgcol,*) real(sp), intent(out) :: c(*),difl(ldu,*),difr(ldu,*),givnum(ldu,*),poles(ldu,& *),s(*),u(ldu,*),vt(ldu,*),work(*),z(ldu,*) real(sp), intent(inout) :: d(*),e(*) end subroutine slasda -#else - module procedure stdlib_slasda +#else + module procedure stdlib${ii}$_slasda #endif - end interface lasda - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lasda +#:endif +#:endfor +#:endfor + end interface lasda interface lasdq !! LASDQ computes the singular value decomposition (SVD) of a real @@ -16700,110 +16618,110 @@ module stdlib_linalg_lapack !! See "Computing Small Singular Values of Bidiagonal Matrices With !! Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, !! LAPACK Working Note #3, for a detailed description of the algorithm. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlasdq( uplo, sqre, n, ncvt, nru, ncc, d, e, vt, ldvt,u, ldu, c, & ldc, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldc,ldu,ldvt,n,ncc,ncvt,nru,sqre + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldc,ldu,ldvt,n,ncc,ncvt,nru,sqre real(dp), intent(inout) :: c(ldc,*),d(*),e(*),u(ldu,*),vt(ldvt,*) real(dp), intent(out) :: work(*) end subroutine dlasdq -#else - module procedure stdlib_dlasdq +#else + module procedure stdlib${ii}$_dlasdq #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lasdq - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slasdq( uplo, sqre, n, ncvt, nru, ncc, d, e, vt, ldvt,u, ldu, c, & ldc, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldc,ldu,ldvt,n,ncc,ncvt,nru,sqre + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldc,ldu,ldvt,n,ncc,ncvt,nru,sqre real(sp), intent(inout) :: c(ldc,*),d(*),e(*),u(ldu,*),vt(ldvt,*) real(sp), intent(out) :: work(*) end subroutine slasdq -#else - module procedure stdlib_slasdq +#else + module procedure stdlib${ii}$_slasdq #endif - end interface lasdq - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lasdq +#:endif +#:endfor +#:endfor + end interface lasdq interface laset !! LASET initializes a 2-D array A to BETA on the diagonal and !! ALPHA on the offdiagonals. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine claset( uplo, m, n, alpha, beta, a, lda ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: lda,m,n + integer(${ik}$), intent(in) :: lda,m,n complex(sp), intent(in) :: alpha,beta complex(sp), intent(out) :: a(lda,*) end subroutine claset -#else - module procedure stdlib_claset +#else + module procedure stdlib${ii}$_claset #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaset( uplo, m, n, alpha, beta, a, lda ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: lda,m,n + integer(${ik}$), intent(in) :: lda,m,n real(dp), intent(in) :: alpha,beta real(dp), intent(out) :: a(lda,*) end subroutine dlaset -#else - module procedure stdlib_dlaset +#else + module procedure stdlib${ii}$_dlaset #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laset - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaset( uplo, m, n, alpha, beta, a, lda ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: lda,m,n + integer(${ik}$), intent(in) :: lda,m,n real(sp), intent(in) :: alpha,beta real(sp), intent(out) :: a(lda,*) end subroutine slaset -#else - module procedure stdlib_slaset +#else + module procedure stdlib${ii}$_slaset #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laset - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlaset( uplo, m, n, alpha, beta, a, lda ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: lda,m,n + integer(${ik}$), intent(in) :: lda,m,n complex(dp), intent(in) :: alpha,beta complex(dp), intent(out) :: a(lda,*) end subroutine zlaset -#else - module procedure stdlib_zlaset +#else + module procedure stdlib${ii}$_zlaset #endif - end interface laset +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laset +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laset +#:endif +#:endfor +#:endfor + end interface laset interface lasq1 !! LASQ1 computes the singular values of a real N-by-N bidiagonal @@ -16816,157 +16734,157 @@ module stdlib_linalg_lapack !! 1994, !! and the present implementation is described in "An implementation of !! the dqds Algorithm (Positive Case)", LAPACK Working Note. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlasq1( n, d, e, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(dp), intent(inout) :: d(*),e(*) real(dp), intent(out) :: work(*) end subroutine dlasq1 -#else - module procedure stdlib_dlasq1 +#else + module procedure stdlib${ii}$_dlasq1 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lasq1 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slasq1( n, d, e, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(sp), intent(inout) :: d(*),e(*) real(sp), intent(out) :: work(*) end subroutine slasq1 -#else - module procedure stdlib_slasq1 +#else + module procedure stdlib${ii}$_slasq1 #endif - end interface lasq1 - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lasq1 +#:endif +#:endfor +#:endfor + end interface lasq1 interface lasq4 !! LASQ4 computes an approximation TAU to the smallest eigenvalue !! using values of d from the previous transform. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlasq4( i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn,dn1, dn2, tau, & ttype, g ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: i0,n0,n0in,pp - integer(ilp), intent(out) :: ttype + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: i0,n0,n0in,pp + integer(${ik}$), intent(out) :: ttype real(dp), intent(in) :: dmin,dmin1,dmin2,dn,dn1,dn2,z(*) real(dp), intent(inout) :: g real(dp), intent(out) :: tau end subroutine dlasq4 -#else - module procedure stdlib_dlasq4 +#else + module procedure stdlib${ii}$_dlasq4 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lasq4 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slasq4( i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn,dn1, dn2, tau, & ttype, g ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: i0,n0,n0in,pp - integer(ilp), intent(out) :: ttype + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: i0,n0,n0in,pp + integer(${ik}$), intent(out) :: ttype real(sp), intent(in) :: dmin,dmin1,dmin2,dn,dn1,dn2,z(*) real(sp), intent(inout) :: g real(sp), intent(out) :: tau end subroutine slasq4 -#else - module procedure stdlib_slasq4 +#else + module procedure stdlib${ii}$_slasq4 #endif - end interface lasq4 - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lasq4 +#:endif +#:endfor +#:endfor + end interface lasq4 interface lasq5 !! LASQ5 computes one dqds transform in ping-pong form, one !! version for IEEE machines another for non IEEE machines. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlasq5( i0, n0, z, pp, tau, sigma, dmin, dmin1, dmin2,dn, dnm1, & dnm2, ieee, eps ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: ieee - integer(ilp), intent(in) :: i0,n0,pp + integer(${ik}$), intent(in) :: i0,n0,pp real(dp), intent(out) :: dmin,dmin1,dmin2,dn,dnm1,dnm2 real(dp), intent(inout) :: tau,z(*) real(dp), intent(in) :: sigma,eps end subroutine dlasq5 -#else - module procedure stdlib_dlasq5 +#else + module procedure stdlib${ii}$_dlasq5 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lasq5 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slasq5( i0, n0, z, pp, tau, sigma, dmin, dmin1, dmin2,dn, dnm1, & dnm2, ieee, eps ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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,z(*) real(sp), intent(in) :: sigma,eps end subroutine slasq5 -#else - module procedure stdlib_slasq5 +#else + module procedure stdlib${ii}$_slasq5 #endif - end interface lasq5 - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lasq5 +#:endif +#:endfor +#:endfor + end interface lasq5 interface lasq6 !! LASQ6 computes one dqd (shift equal to zero) transform in !! ping-pong form, with protection against underflow and overflow. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlasq6( i0, n0, z, pp, dmin, dmin1, dmin2, dn,dnm1, dnm2 ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: i0,n0,pp + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: i0,n0,pp real(dp), intent(out) :: dmin,dmin1,dmin2,dn,dnm1,dnm2 real(dp), intent(inout) :: z(*) end subroutine dlasq6 -#else - module procedure stdlib_dlasq6 +#else + module procedure stdlib${ii}$_dlasq6 +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine slasq6( i0, n0, z, pp, dmin, dmin1, dmin2, dn,dnm1, dnm2 ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: i0,n0,pp + real(sp), intent(out) :: dmin,dmin1,dmin2,dn,dnm1,dnm2 + real(sp), intent(inout) :: z(*) + end subroutine slasq6 +#else + module procedure stdlib${ii}$_slasq6 #endif #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lasq6 + module procedure stdlib${ii}$_${ri}$lasq6 #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine slasq6( i0, n0, z, pp, dmin, dmin1, dmin2, dn,dnm1, dnm2 ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: i0,n0,pp - real(sp), intent(out) :: dmin,dmin1,dmin2,dn,dnm1,dnm2 - real(sp), intent(inout) :: z(*) - end subroutine slasq6 -#else - module procedure stdlib_slasq6 -#endif +#:endfor end interface lasq6 - - interface lasr !! LASR applies a sequence of real plane rotations to a complex matrix !! A, from either the left or the right. @@ -17019,108 +16937,108 @@ module stdlib_linalg_lapack !! ( -s(k) c(k) ) !! where R(k) appears in rows and columns k and z. The rotations are !! performed without ever forming P(k) explicitly. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clasr( side, pivot, direct, m, n, c, s, a, lda ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: direct,pivot,side - integer(ilp), intent(in) :: lda,m,n + integer(${ik}$), intent(in) :: lda,m,n real(sp), intent(in) :: c(*),s(*) complex(sp), intent(inout) :: a(lda,*) end subroutine clasr -#else - module procedure stdlib_clasr +#else + module procedure stdlib${ii}$_clasr #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlasr( side, pivot, direct, m, n, c, s, a, lda ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: direct,pivot,side - integer(ilp), intent(in) :: lda,m,n + integer(${ik}$), intent(in) :: lda,m,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: c(*),s(*) end subroutine dlasr -#else - module procedure stdlib_dlasr +#else + module procedure stdlib${ii}$_dlasr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lasr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slasr( side, pivot, direct, m, n, c, s, a, lda ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: direct,pivot,side - integer(ilp), intent(in) :: lda,m,n + integer(${ik}$), intent(in) :: lda,m,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(in) :: c(*),s(*) end subroutine slasr -#else - module procedure stdlib_slasr +#else + module procedure stdlib${ii}$_slasr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lasr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlasr( side, pivot, direct, m, n, c, s, a, lda ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: direct,pivot,side - integer(ilp), intent(in) :: lda,m,n + integer(${ik}$), intent(in) :: lda,m,n real(dp), intent(in) :: c(*),s(*) complex(dp), intent(inout) :: a(lda,*) end subroutine zlasr -#else - module procedure stdlib_zlasr +#else + module procedure stdlib${ii}$_zlasr #endif - end interface lasr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lasr +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lasr +#:endif +#:endfor +#:endfor + end interface lasr interface lasrt !! Sort the numbers in D in increasing order (if ID = 'I') or !! in decreasing order (if ID = 'D' ). !! Use Quick Sort, reverting to Insertion sort on arrays of !! size <= 20. Dimension of STACK limits N to about 2**32. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlasrt( id, n, d, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: id - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(dp), intent(inout) :: d(*) end subroutine dlasrt -#else - module procedure stdlib_dlasrt +#else + module procedure stdlib${ii}$_dlasrt #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lasrt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slasrt( id, n, d, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: id - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(sp), intent(inout) :: d(*) end subroutine slasrt -#else - module procedure stdlib_slasrt +#else + module procedure stdlib${ii}$_slasrt #endif - end interface lasrt - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lasrt +#:endif +#:endfor +#:endfor + end interface lasrt interface lassq !! LASSQ returns the values scl and smsq such that @@ -17141,65 +17059,65 @@ module stdlib_linalg_lapack !! and !! TINY*EPS -- tiniest representable number; !! HUGE -- biggest representable number. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine classq( n, x, incx, scl, sumsq ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n real(sp), intent(inout) :: scl,sumsq complex(sp), intent(in) :: x(*) end subroutine classq -#else - module procedure stdlib_classq +#else + module procedure stdlib${ii}$_classq #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlassq( n, x, incx, scl, sumsq ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n real(dp), intent(inout) :: scl,sumsq real(dp), intent(in) :: x(*) end subroutine dlassq -#else - module procedure stdlib_dlassq +#else + module procedure stdlib${ii}$_dlassq #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lassq - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slassq( n, x, incx, scl, sumsq ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n real(sp), intent(inout) :: scl,sumsq real(sp), intent(in) :: x(*) end subroutine slassq -#else - module procedure stdlib_slassq +#else + module procedure stdlib${ii}$_slassq #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lassq - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlassq( n, x, incx, scl, sumsq ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n real(dp), intent(inout) :: scl,sumsq complex(dp), intent(in) :: x(*) end subroutine zlassq -#else - module procedure stdlib_zlassq +#else + module procedure stdlib${ii}$_zlassq #endif - end interface lassq +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lassq +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lassq +#:endif +#:endfor +#:endfor + end interface lassq interface laswlq !! LASWLQ computes a blocked Tall-Skinny LQ factorization of @@ -17212,129 +17130,129 @@ module stdlib_linalg_lapack !! L is a lower-triangular M-by-M matrix stored on exit in !! the elements on and below the diagonal of the array A. !! 0 is a M-by-(N-M) zero matrix, if M < N, and is not stored. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine claswlq( m, n, mb, nb, a, lda, t, ldt, work, lwork,info) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,mb,nb,lwork,ldt + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,mb,nb,lwork,ldt complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: work(*),t(ldt,*) end subroutine claswlq -#else - module procedure stdlib_claswlq +#else + module procedure stdlib${ii}$_claswlq #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaswlq( m, n, mb, nb, a, lda, t, ldt, work, lwork,info) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,mb,nb,lwork,ldt + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,mb,nb,lwork,ldt real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: work(*),t(ldt,*) end subroutine dlaswlq -#else - module procedure stdlib_dlaswlq +#else + module procedure stdlib${ii}$_dlaswlq #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laswlq - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slaswlq( m, n, mb, nb, a, lda, t, ldt, work, lwork,info) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,mb,nb,lwork,ldt + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,mb,nb,lwork,ldt real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: work(*),t(ldt,*) end subroutine slaswlq -#else - module procedure stdlib_slaswlq +#else + module procedure stdlib${ii}$_slaswlq #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laswlq - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlaswlq( m, n, mb, nb, a, lda, t, ldt, work, lwork,info) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,mb,nb,lwork,ldt + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,mb,nb,lwork,ldt complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: work(*),t(ldt,*) end subroutine zlaswlq -#else - module procedure stdlib_zlaswlq +#else + module procedure stdlib${ii}$_zlaswlq #endif - end interface laswlq +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laswlq +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$laswlq +#:endif +#:endfor +#:endfor + end interface laswlq interface laswp !! LASWP performs a series of row interchanges on the matrix A. !! One row interchange is initiated for each of rows K1 through K2 of A. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine claswp( n, a, lda, k1, k2, ipiv, incx ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,k1,k2,lda,n,ipiv(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,k1,k2,lda,n,ipiv(*) complex(sp), intent(inout) :: a(lda,*) end subroutine claswp -#else - module procedure stdlib_claswp +#else + module procedure stdlib${ii}$_claswp #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlaswp( n, a, lda, k1, k2, ipiv, incx ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,k1,k2,lda,n,ipiv(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,k1,k2,lda,n,ipiv(*) real(dp), intent(inout) :: a(lda,*) end subroutine dlaswp -#else - module procedure stdlib_dlaswp +#else + module procedure stdlib${ii}$_dlaswp +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine slaswp( n, a, lda, k1, k2, ipiv, incx ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,k1,k2,lda,n,ipiv(*) + real(sp), intent(inout) :: a(lda,*) + end subroutine slaswp +#else + module procedure stdlib${ii}$_slaswp +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine zlaswp( n, a, lda, k1, k2, ipiv, incx ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,k1,k2,lda,n,ipiv(*) + complex(dp), intent(inout) :: a(lda,*) + end subroutine zlaswp +#else + module procedure stdlib${ii}$_zlaswp #endif #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laswp + module procedure stdlib${ii}$_${ri}$laswp #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine slaswp( n, a, lda, k1, k2, ipiv, incx ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,k1,k2,lda,n,ipiv(*) - real(sp), intent(inout) :: a(lda,*) - end subroutine slaswp -#else - module procedure stdlib_slaswp -#endif #:for rk,rt,ri in CMPLX_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$laswp + module procedure stdlib${ii}$_${ri}$laswp #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine zlaswp( n, a, lda, k1, k2, ipiv, incx ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,k1,k2,lda,n,ipiv(*) - complex(dp), intent(inout) :: a(lda,*) - end subroutine zlaswp -#else - module procedure stdlib_zlaswp -#endif +#:endfor end interface laswp - - interface lasyf !! LASYF computes a partial factorization of a complex symmetric matrix !! A using the Bunch-Kaufman diagonal pivoting method. The partial @@ -17349,73 +17267,73 @@ module stdlib_linalg_lapack !! LASYF is an auxiliary routine called by CSYTRF. It uses blocked code !! (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or !! A22 (if UPLO = 'L'). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clasyf( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,kb,ipiv(*) - integer(ilp), intent(in) :: lda,ldw,n,nb + integer(${ik}$), intent(out) :: info,kb,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldw,n,nb complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: w(ldw,*) end subroutine clasyf -#else - module procedure stdlib_clasyf +#else + module procedure stdlib${ii}$_clasyf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlasyf( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,kb,ipiv(*) - integer(ilp), intent(in) :: lda,ldw,n,nb + integer(${ik}$), intent(out) :: info,kb,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldw,n,nb real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: w(ldw,*) end subroutine dlasyf -#else - module procedure stdlib_dlasyf +#else + module procedure stdlib${ii}$_dlasyf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lasyf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slasyf( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,kb,ipiv(*) - integer(ilp), intent(in) :: lda,ldw,n,nb + integer(${ik}$), intent(out) :: info,kb,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldw,n,nb real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: w(ldw,*) end subroutine slasyf -#else - module procedure stdlib_slasyf +#else + module procedure stdlib${ii}$_slasyf #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lasyf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlasyf( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,kb,ipiv(*) - integer(ilp), intent(in) :: lda,ldw,n,nb + integer(${ik}$), intent(out) :: info,kb,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldw,n,nb complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: w(ldw,*) end subroutine zlasyf -#else - module procedure stdlib_zlasyf +#else + module procedure stdlib${ii}$_zlasyf #endif - end interface lasyf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lasyf +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lasyf +#:endif +#:endfor +#:endfor + end interface lasyf interface lasyf_aa !! DLATRF_AA factorizes a panel of a complex symmetric matrix A using @@ -17428,73 +17346,73 @@ module stdlib_linalg_lapack !! The resulting J-th row of U, or J-th column of L, is stored in the !! (J-1)-th row, or column, of A (without the unit diagonals), while !! the diagonal and subdiagonal of A are overwritten by those of T. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clasyf_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: m,nb,j1,lda,ldh - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(in) :: m,nb,j1,lda,ldh + integer(${ik}$), intent(out) :: ipiv(*) complex(sp), intent(inout) :: a(lda,*),h(ldh,*) complex(sp), intent(out) :: work(*) end subroutine clasyf_aa -#else - module procedure stdlib_clasyf_aa +#else + module procedure stdlib${ii}$_clasyf_aa #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlasyf_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: m,nb,j1,lda,ldh - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(in) :: m,nb,j1,lda,ldh + integer(${ik}$), intent(out) :: ipiv(*) real(dp), intent(inout) :: a(lda,*),h(ldh,*) real(dp), intent(out) :: work(*) end subroutine dlasyf_aa -#else - module procedure stdlib_dlasyf_aa +#else + module procedure stdlib${ii}$_dlasyf_aa #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lasyf_aa - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slasyf_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: m,nb,j1,lda,ldh - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(in) :: m,nb,j1,lda,ldh + integer(${ik}$), intent(out) :: ipiv(*) real(sp), intent(inout) :: a(lda,*),h(ldh,*) real(sp), intent(out) :: work(*) end subroutine slasyf_aa -#else - module procedure stdlib_slasyf_aa +#else + module procedure stdlib${ii}$_slasyf_aa #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lasyf_aa - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlasyf_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: m,nb,j1,lda,ldh - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(in) :: m,nb,j1,lda,ldh + integer(${ik}$), intent(out) :: ipiv(*) complex(dp), intent(inout) :: a(lda,*),h(ldh,*) complex(dp), intent(out) :: work(*) end subroutine zlasyf_aa -#else - module procedure stdlib_zlasyf_aa +#else + module procedure stdlib${ii}$_zlasyf_aa #endif - end interface lasyf_aa +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lasyf_aa +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lasyf_aa +#:endif +#:endfor +#:endfor + end interface lasyf_aa interface lasyf_rk !! LASYF_RK computes a partial factorization of a complex symmetric @@ -17509,73 +17427,73 @@ module stdlib_linalg_lapack !! LASYF_RK is an auxiliary routine called by CSYTRF_RK. It uses !! blocked code (calling Level 3 BLAS) to update the submatrix !! A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clasyf_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,kb,ipiv(*) - integer(ilp), intent(in) :: lda,ldw,n,nb + integer(${ik}$), intent(out) :: info,kb,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldw,n,nb complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: e(*),w(ldw,*) end subroutine clasyf_rk -#else - module procedure stdlib_clasyf_rk +#else + module procedure stdlib${ii}$_clasyf_rk #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlasyf_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,kb,ipiv(*) - integer(ilp), intent(in) :: lda,ldw,n,nb + integer(${ik}$), intent(out) :: info,kb,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldw,n,nb real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: e(*),w(ldw,*) end subroutine dlasyf_rk -#else - module procedure stdlib_dlasyf_rk +#else + module procedure stdlib${ii}$_dlasyf_rk #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lasyf_rk - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slasyf_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,kb,ipiv(*) - integer(ilp), intent(in) :: lda,ldw,n,nb + integer(${ik}$), intent(out) :: info,kb,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldw,n,nb real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: e(*),w(ldw,*) end subroutine slasyf_rk -#else - module procedure stdlib_slasyf_rk +#else + module procedure stdlib${ii}$_slasyf_rk #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lasyf_rk - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlasyf_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,kb,ipiv(*) - integer(ilp), intent(in) :: lda,ldw,n,nb + integer(${ik}$), intent(out) :: info,kb,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldw,n,nb complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: e(*),w(ldw,*) end subroutine zlasyf_rk -#else - module procedure stdlib_zlasyf_rk +#else + module procedure stdlib${ii}$_zlasyf_rk #endif - end interface lasyf_rk +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lasyf_rk +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lasyf_rk +#:endif +#:endfor +#:endfor + end interface lasyf_rk interface lasyf_rook !! LASYF_ROOK computes a partial factorization of a complex symmetric @@ -17590,73 +17508,73 @@ module stdlib_linalg_lapack !! LASYF_ROOK is an auxiliary routine called by CSYTRF_ROOK. It uses !! blocked code (calling Level 3 BLAS) to update the submatrix !! A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,kb,ipiv(*) - integer(ilp), intent(in) :: lda,ldw,n,nb + integer(${ik}$), intent(out) :: info,kb,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldw,n,nb complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: w(ldw,*) end subroutine clasyf_rook -#else - module procedure stdlib_clasyf_rook +#else + module procedure stdlib${ii}$_clasyf_rook #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,kb,ipiv(*) - integer(ilp), intent(in) :: lda,ldw,n,nb + integer(${ik}$), intent(out) :: info,kb,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldw,n,nb real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: w(ldw,*) end subroutine dlasyf_rook -#else - module procedure stdlib_dlasyf_rook +#else + module procedure stdlib${ii}$_dlasyf_rook #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lasyf_rook - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,kb,ipiv(*) - integer(ilp), intent(in) :: lda,ldw,n,nb + integer(${ik}$), intent(out) :: info,kb,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldw,n,nb real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: w(ldw,*) end subroutine slasyf_rook -#else - module procedure stdlib_slasyf_rook +#else + module procedure stdlib${ii}$_slasyf_rook #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lasyf_rook - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,kb,ipiv(*) - integer(ilp), intent(in) :: lda,ldw,n,nb + integer(${ik}$), intent(out) :: info,kb,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldw,n,nb complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: w(ldw,*) end subroutine zlasyf_rook -#else - module procedure stdlib_zlasyf_rook +#else + module procedure stdlib${ii}$_zlasyf_rook #endif - end interface lasyf_rook +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lasyf_rook +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lasyf_rook +#:endif +#:endfor +#:endfor + end interface lasyf_rook interface latbs !! LATBS solves one of the triangular systems @@ -17669,83 +17587,83 @@ module stdlib_linalg_lapack !! overflow, the Level 2 BLAS routine CTBSV 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. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clatbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm,& info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: cnorm(*) complex(sp), intent(in) :: ab(ldab,*) complex(sp), intent(inout) :: x(*) end subroutine clatbs -#else - module procedure stdlib_clatbs +#else + module procedure stdlib${ii}$_clatbs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlatbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm,& info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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(dp), intent(out) :: scale real(dp), intent(in) :: ab(ldab,*) real(dp), intent(inout) :: cnorm(*),x(*) end subroutine dlatbs -#else - module procedure stdlib_dlatbs +#else + module procedure stdlib${ii}$_dlatbs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$latbs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slatbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm,& info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(in) :: ab(ldab,*) real(sp), intent(inout) :: cnorm(*),x(*) end subroutine slatbs -#else - module procedure stdlib_slatbs +#else + module procedure stdlib${ii}$_slatbs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$latbs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlatbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm,& info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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(dp), intent(out) :: scale real(dp), intent(inout) :: cnorm(*) complex(dp), intent(in) :: ab(ldab,*) complex(dp), intent(inout) :: x(*) end subroutine zlatbs -#else - module procedure stdlib_zlatbs +#else + module procedure stdlib${ii}$_zlatbs #endif - end interface latbs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$latbs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$latbs +#:endif +#:endfor +#:endfor + end interface latbs interface latdf !! LATDF computes the contribution to the reciprocal Dif-estimate @@ -17756,63 +17674,63 @@ module stdlib_linalg_lapack !! The factorization of Z returned by CGETC2 has the form !! Z = P * L * U * Q, where P and Q are permutation matrices. L is lower !! triangular with unit diagonal elements and U is upper triangular. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clatdf( ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv,jpiv ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ijob,ldz,n,ipiv(*),jpiv(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ijob,ldz,n,ipiv(*),jpiv(*) real(sp), intent(inout) :: rdscal,rdsum complex(sp), intent(inout) :: rhs(*),z(ldz,*) end subroutine clatdf -#else - module procedure stdlib_clatdf +#else + module procedure stdlib${ii}$_clatdf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlatdf( ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv,jpiv ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ijob,ldz,n,ipiv(*),jpiv(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ijob,ldz,n,ipiv(*),jpiv(*) real(dp), intent(inout) :: rdscal,rdsum,rhs(*),z(ldz,*) end subroutine dlatdf -#else - module procedure stdlib_dlatdf +#else + module procedure stdlib${ii}$_dlatdf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$latdf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slatdf( ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv,jpiv ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ijob,ldz,n,ipiv(*),jpiv(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ijob,ldz,n,ipiv(*),jpiv(*) real(sp), intent(inout) :: rdscal,rdsum,rhs(*),z(ldz,*) end subroutine slatdf -#else - module procedure stdlib_slatdf +#else + module procedure stdlib${ii}$_slatdf #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$latdf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlatdf( ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv,jpiv ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ijob,ldz,n,ipiv(*),jpiv(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ijob,ldz,n,ipiv(*),jpiv(*) real(dp), intent(inout) :: rdscal,rdsum complex(dp), intent(inout) :: rhs(*),z(ldz,*) end subroutine zlatdf -#else - module procedure stdlib_zlatdf +#else + module procedure stdlib${ii}$_zlatdf #endif - end interface latdf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$latdf +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$latdf +#:endif +#:endfor +#:endfor + end interface latdf interface latps !! LATPS solves one of the triangular systems @@ -17826,83 +17744,83 @@ module stdlib_linalg_lapack !! overflow, the Level 2 BLAS routine CTPSV 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. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clatps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: cnorm(*) complex(sp), intent(in) :: ap(*) complex(sp), intent(inout) :: x(*) end subroutine clatps -#else - module procedure stdlib_clatps +#else + module procedure stdlib${ii}$_clatps #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlatps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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(dp), intent(out) :: scale real(dp), intent(in) :: ap(*) real(dp), intent(inout) :: cnorm(*),x(*) end subroutine dlatps -#else - module procedure stdlib_dlatps +#else + module procedure stdlib${ii}$_dlatps #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$latps - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slatps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(in) :: ap(*) real(sp), intent(inout) :: cnorm(*),x(*) end subroutine slatps -#else - module procedure stdlib_slatps +#else + module procedure stdlib${ii}$_slatps #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$latps - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlatps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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(dp), intent(out) :: scale real(dp), intent(inout) :: cnorm(*) complex(dp), intent(in) :: ap(*) complex(dp), intent(inout) :: x(*) end subroutine zlatps -#else - module procedure stdlib_zlatps +#else + module procedure stdlib${ii}$_zlatps #endif - end interface latps +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$latps +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$latps +#:endif +#:endfor +#:endfor + end interface latps interface latrd !! LATRD reduces NB rows and columns of a complex Hermitian matrix A to @@ -17914,71 +17832,71 @@ module stdlib_linalg_lapack !! if UPLO = 'L', LATRD reduces the first NB rows and columns of a !! matrix, of which the lower triangle is supplied. !! This is an auxiliary routine called by CHETRD. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clatrd( uplo, n, nb, a, lda, e, tau, w, ldw ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: lda,ldw,n,nb + integer(${ik}$), intent(in) :: lda,ldw,n,nb real(sp), intent(out) :: e(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: tau(*),w(ldw,*) end subroutine clatrd -#else - module procedure stdlib_clatrd +#else + module procedure stdlib${ii}$_clatrd #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlatrd( uplo, n, nb, a, lda, e, tau, w, ldw ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: lda,ldw,n,nb + integer(${ik}$), intent(in) :: lda,ldw,n,nb real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: e(*),tau(*),w(ldw,*) end subroutine dlatrd -#else - module procedure stdlib_dlatrd +#else + module procedure stdlib${ii}$_dlatrd #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$latrd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slatrd( uplo, n, nb, a, lda, e, tau, w, ldw ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: lda,ldw,n,nb + integer(${ik}$), intent(in) :: lda,ldw,n,nb real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: e(*),tau(*),w(ldw,*) end subroutine slatrd -#else - module procedure stdlib_slatrd +#else + module procedure stdlib${ii}$_slatrd #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$latrd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlatrd( uplo, n, nb, a, lda, e, tau, w, ldw ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: lda,ldw,n,nb + integer(${ik}$), intent(in) :: lda,ldw,n,nb real(dp), intent(out) :: e(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: tau(*),w(ldw,*) end subroutine zlatrd -#else - module procedure stdlib_zlatrd +#else + module procedure stdlib${ii}$_zlatrd #endif - end interface latrd +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$latrd +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$latrd +#:endif +#:endfor +#:endfor + end interface latrd interface latrs !! LATRS solves one of the triangular systems @@ -17991,148 +17909,148 @@ module stdlib_linalg_lapack !! unscaled problem will not cause overflow, the Level 2 BLAS routine !! CTRSV 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. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clatrs( uplo, trans, diag, normin, n, a, lda, x, scale,cnorm, info & ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: cnorm(*) complex(sp), intent(in) :: a(lda,*) complex(sp), intent(inout) :: x(*) end subroutine clatrs -#else - module procedure stdlib_clatrs +#else + module procedure stdlib${ii}$_clatrs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlatrs( uplo, trans, diag, normin, n, a, lda, x, scale,cnorm, info & ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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(dp), intent(out) :: scale real(dp), intent(in) :: a(lda,*) real(dp), intent(inout) :: cnorm(*),x(*) end subroutine dlatrs -#else - module procedure stdlib_dlatrs +#else + module procedure stdlib${ii}$_dlatrs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$latrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slatrs( uplo, trans, diag, normin, n, a, lda, x, scale,cnorm, info & ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(in) :: a(lda,*) real(sp), intent(inout) :: cnorm(*),x(*) end subroutine slatrs -#else - module procedure stdlib_slatrs +#else + module procedure stdlib${ii}$_slatrs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$latrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlatrs( uplo, trans, diag, normin, n, a, lda, x, scale,cnorm, info & ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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(dp), intent(out) :: scale real(dp), intent(inout) :: cnorm(*) complex(dp), intent(in) :: a(lda,*) complex(dp), intent(inout) :: x(*) end subroutine zlatrs -#else - module procedure stdlib_zlatrs +#else + module procedure stdlib${ii}$_zlatrs #endif - end interface latrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$latrs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$latrs +#:endif +#:endfor +#:endfor + end interface latrs interface latrz !! LATRZ factors the M-by-(M+L) complex upper trapezoidal matrix !! [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z by means !! of unitary transformations, where Z is an (M+L)-by-(M+L) unitary !! matrix and, R and A1 are M-by-M upper triangular matrices. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clatrz( m, n, l, a, lda, tau, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: l,lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: l,lda,m,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: tau(*),work(*) end subroutine clatrz -#else - module procedure stdlib_clatrz +#else + module procedure stdlib${ii}$_clatrz #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlatrz( m, n, l, a, lda, tau, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: l,lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: l,lda,m,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: tau(*),work(*) end subroutine dlatrz -#else - module procedure stdlib_dlatrz +#else + module procedure stdlib${ii}$_dlatrz #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$latrz - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slatrz( m, n, l, a, lda, tau, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: l,lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: l,lda,m,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: tau(*),work(*) end subroutine slatrz -#else - module procedure stdlib_slatrz +#else + module procedure stdlib${ii}$_slatrz #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$latrz - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlatrz( m, n, l, a, lda, tau, work ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: l,lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: l,lda,m,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: tau(*),work(*) end subroutine zlatrz -#else - module procedure stdlib_zlatrz +#else + module procedure stdlib${ii}$_zlatrz #endif - end interface latrz +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$latrz +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$latrz +#:endif +#:endfor +#:endfor + end interface latrz interface latsqr !! LATSQR computes a blocked Tall-Skinny QR factorization of @@ -18146,69 +18064,69 @@ module stdlib_linalg_lapack !! R is an upper-triangular N-by-N matrix, stored on exit in !! the elements on and above the diagonal of the array A. !! 0 is a (M-N)-by-N zero matrix, and is not stored. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clatsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,mb,nb,ldt,lwork + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,mb,nb,ldt,lwork complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: work(*),t(ldt,*) end subroutine clatsqr -#else - module procedure stdlib_clatsqr +#else + module procedure stdlib${ii}$_clatsqr #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlatsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,mb,nb,ldt,lwork + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,mb,nb,ldt,lwork real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: work(*),t(ldt,*) end subroutine dlatsqr -#else - module procedure stdlib_dlatsqr +#else + module procedure stdlib${ii}$_dlatsqr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$latsqr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slatsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,mb,nb,ldt,lwork + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,mb,nb,ldt,lwork real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: work(*),t(ldt,*) end subroutine slatsqr -#else - module procedure stdlib_slatsqr +#else + module procedure stdlib${ii}$_slatsqr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$latsqr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlatsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n,mb,nb,ldt,lwork + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n,mb,nb,ldt,lwork complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: work(*),t(ldt,*) end subroutine zlatsqr -#else - module procedure stdlib_zlatsqr +#else + module procedure stdlib${ii}$_zlatsqr #endif - end interface latsqr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$latsqr +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$latsqr +#:endif +#:endfor +#:endfor + end interface latsqr interface launhr_col_getrfnp !! LAUNHR_COL_GETRFNP computes the modified LU factorization without @@ -18244,39 +18162,39 @@ module stdlib_linalg_lapack !! G. Ballard, J. Demmel, L. Grigori, M. Jacquelin, H.D. Nguyen, !! E. Solomonik, J. Parallel Distrib. Comput., !! vol. 85, pp. 3-31, 2015. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine claunhr_col_getrfnp( m, n, a, lda, d, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: d(*) end subroutine claunhr_col_getrfnp -#else - module procedure stdlib_claunhr_col_getrfnp +#else + module procedure stdlib${ii}$_claunhr_col_getrfnp #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$launhr_col_getrfnp - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlaunhr_col_getrfnp( m, n, a, lda, d, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: d(*) end subroutine zlaunhr_col_getrfnp -#else - module procedure stdlib_zlaunhr_col_getrfnp +#else + module procedure stdlib${ii}$_zlaunhr_col_getrfnp #endif - end interface launhr_col_getrfnp - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$launhr_col_getrfnp +#:endif +#:endfor +#:endfor + end interface launhr_col_getrfnp interface launhr_col_getrfnp2 !! LAUNHR_COL_GETRFNP2 computes the modified LU factorization without @@ -18327,39 +18245,39 @@ module stdlib_linalg_lapack !! [2] "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. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure recursive subroutine claunhr_col_getrfnp2( m, n, a, lda, d, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: d(*) end subroutine claunhr_col_getrfnp2 -#else - module procedure stdlib_claunhr_col_getrfnp2 +#else + module procedure stdlib${ii}$_claunhr_col_getrfnp2 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$launhr_col_getrfnp2 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure recursive subroutine zlaunhr_col_getrfnp2( m, n, a, lda, d, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,m,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: d(*) end subroutine zlaunhr_col_getrfnp2 -#else - module procedure stdlib_zlaunhr_col_getrfnp2 +#else + module procedure stdlib${ii}$_zlaunhr_col_getrfnp2 #endif - end interface launhr_col_getrfnp2 - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$launhr_col_getrfnp2 +#:endif +#:endfor +#:endfor + end interface launhr_col_getrfnp2 interface lauum !! LAUUM computes the product U * U**H or L**H * L, where the triangular @@ -18370,69 +18288,69 @@ module stdlib_linalg_lapack !! If UPLO = 'L' or 'l' then the lower triangle of the result is stored, !! overwriting the factor L in A. !! This is the blocked form of the algorithm, calling Level 3 BLAS. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine clauum( uplo, n, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(inout) :: a(lda,*) end subroutine clauum -#else - module procedure stdlib_clauum +#else + module procedure stdlib${ii}$_clauum #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dlauum( uplo, n, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(inout) :: a(lda,*) end subroutine dlauum -#else - module procedure stdlib_dlauum +#else + module procedure stdlib${ii}$_dlauum #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lauum - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine slauum( uplo, n, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: a(lda,*) end subroutine slauum -#else - module procedure stdlib_slauum +#else + module procedure stdlib${ii}$_slauum #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$lauum - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zlauum( uplo, n, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(inout) :: a(lda,*) end subroutine zlauum -#else - module procedure stdlib_zlauum +#else + module procedure stdlib${ii}$_zlauum #endif - end interface lauum +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lauum +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$lauum +#:endif +#:endfor +#:endfor + end interface lauum interface opgtr !! OPGTR generates a real orthogonal matrix Q which is defined as the @@ -18440,41 +18358,41 @@ module stdlib_linalg_lapack !! DSPTRD using packed storage: !! if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), !! if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dopgtr( uplo, n, ap, tau, q, ldq, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldq,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldq,n real(dp), intent(in) :: ap(*),tau(*) real(dp), intent(out) :: q(ldq,*),work(*) end subroutine dopgtr -#else - module procedure stdlib_dopgtr +#else + module procedure stdlib${ii}$_dopgtr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$opgtr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sopgtr( uplo, n, ap, tau, q, ldq, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldq,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldq,n real(sp), intent(in) :: ap(*),tau(*) real(sp), intent(out) :: q(ldq,*),work(*) end subroutine sopgtr -#else - module procedure stdlib_sopgtr +#else + module procedure stdlib${ii}$_sopgtr #endif - end interface opgtr - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$opgtr +#:endif +#:endfor +#:endfor + end interface opgtr interface opmtr !! OPMTR overwrites the general real M-by-N matrix C with @@ -18487,45 +18405,45 @@ module stdlib_linalg_lapack !! storage: !! if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); !! if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dopmtr( side, uplo, trans, m, n, ap, tau, c, ldc, work,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldc,m,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldc,m,n real(dp), intent(inout) :: ap(*),c(ldc,*) real(dp), intent(in) :: tau(*) real(dp), intent(out) :: work(*) end subroutine dopmtr -#else - module procedure stdlib_dopmtr +#else + module procedure stdlib${ii}$_dopmtr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$opmtr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sopmtr( side, uplo, trans, m, n, ap, tau, c, ldc, work,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldc,m,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldc,m,n real(sp), intent(inout) :: ap(*),c(ldc,*) real(sp), intent(in) :: tau(*) real(sp), intent(out) :: work(*) end subroutine sopmtr -#else - module procedure stdlib_sopmtr +#else + module procedure stdlib${ii}$_sopmtr #endif - end interface opmtr - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$opmtr +#:endif +#:endfor +#:endfor + end interface opmtr interface orbdb !! ORBDB simultaneously bidiagonalizes the blocks of an M-by-M @@ -18544,47 +18462,47 @@ module stdlib_linalg_lapack !! represented implicitly by Householder vectors. !! B11, B12, B21, and B22 are Q-by-Q bidiagonal matrices represented !! implicitly by angles THETA, PHI. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dorbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & ldx22, theta, phi, taup1,taup2, tauq1, tauq2, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: signs,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldx11,ldx12,ldx21,ldx22,lwork,m,p,q + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldx11,ldx12,ldx21,ldx22,lwork,m,p,q real(dp), intent(out) :: phi(*),theta(*),taup1(*),taup2(*),tauq1(*),tauq2(*),& work(*) real(dp), intent(inout) :: x11(ldx11,*),x12(ldx12,*),x21(ldx21,*),x22(ldx22,*) - + end subroutine dorbdb -#else - module procedure stdlib_dorbdb +#else + module procedure stdlib${ii}$_dorbdb #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$orbdb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sorbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & ldx22, theta, phi, taup1,taup2, tauq1, tauq2, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: signs,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldx11,ldx12,ldx21,ldx22,lwork,m,p,q + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldx11,ldx12,ldx21,ldx22,lwork,m,p,q real(sp), intent(out) :: phi(*),theta(*),taup1(*),taup2(*),tauq1(*),tauq2(*),& work(*) real(sp), intent(inout) :: x11(ldx11,*),x12(ldx12,*),x21(ldx21,*),x22(ldx22,*) - + end subroutine sorbdb -#else - module procedure stdlib_sorbdb +#else + module procedure stdlib${ii}$_sorbdb #endif - end interface orbdb - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$orbdb +#:endif +#:endfor +#:endfor + end interface orbdb interface orbdb1 !! ORBDB1 simultaneously bidiagonalizes the blocks of a tall and skinny @@ -18602,43 +18520,43 @@ module stdlib_linalg_lapack !! Householder vectors. !! B11 and B12 are Q-by-Q bidiagonal matrices represented implicitly by !! angles THETA, PHI. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dorbdb1( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, & tauq1, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lwork,m,p,q,ldx11,ldx21 + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork,m,p,q,ldx11,ldx21 real(dp), intent(out) :: phi(*),theta(*),taup1(*),taup2(*),tauq1(*),work(*) - + real(dp), intent(inout) :: x11(ldx11,*),x21(ldx21,*) end subroutine dorbdb1 -#else - module procedure stdlib_dorbdb1 +#else + module procedure stdlib${ii}$_dorbdb1 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$orbdb1 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sorbdb1( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, & tauq1, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lwork,m,p,q,ldx11,ldx21 + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork,m,p,q,ldx11,ldx21 real(sp), intent(out) :: phi(*),theta(*),taup1(*),taup2(*),tauq1(*),work(*) - + real(sp), intent(inout) :: x11(ldx11,*),x21(ldx21,*) end subroutine sorbdb1 -#else - module procedure stdlib_sorbdb1 +#else + module procedure stdlib${ii}$_sorbdb1 #endif - end interface orbdb1 - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$orbdb1 +#:endif +#:endfor +#:endfor + end interface orbdb1 interface orbdb2 !! ORBDB2 simultaneously bidiagonalizes the blocks of a tall and skinny @@ -18656,43 +18574,43 @@ module stdlib_linalg_lapack !! Householder vectors. !! B11 and B12 are P-by-P bidiagonal matrices represented implicitly by !! angles THETA, PHI. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dorbdb2( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, & tauq1, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lwork,m,p,q,ldx11,ldx21 + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork,m,p,q,ldx11,ldx21 real(dp), intent(out) :: phi(*),theta(*),taup1(*),taup2(*),tauq1(*),work(*) - + real(dp), intent(inout) :: x11(ldx11,*),x21(ldx21,*) end subroutine dorbdb2 -#else - module procedure stdlib_dorbdb2 +#else + module procedure stdlib${ii}$_dorbdb2 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$orbdb2 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sorbdb2( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, & tauq1, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lwork,m,p,q,ldx11,ldx21 + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork,m,p,q,ldx11,ldx21 real(sp), intent(out) :: phi(*),theta(*),taup1(*),taup2(*),tauq1(*),work(*) - + real(sp), intent(inout) :: x11(ldx11,*),x21(ldx21,*) end subroutine sorbdb2 -#else - module procedure stdlib_sorbdb2 +#else + module procedure stdlib${ii}$_sorbdb2 #endif - end interface orbdb2 - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$orbdb2 +#:endif +#:endfor +#:endfor + end interface orbdb2 interface orbdb3 !! ORBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny @@ -18710,43 +18628,43 @@ module stdlib_linalg_lapack !! Householder vectors. !! B11 and B12 are (M-P)-by-(M-P) bidiagonal matrices represented !! implicitly by angles THETA, PHI. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dorbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, & tauq1, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lwork,m,p,q,ldx11,ldx21 + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork,m,p,q,ldx11,ldx21 real(dp), intent(out) :: phi(*),theta(*),taup1(*),taup2(*),tauq1(*),work(*) - + real(dp), intent(inout) :: x11(ldx11,*),x21(ldx21,*) end subroutine dorbdb3 -#else - module procedure stdlib_dorbdb3 +#else + module procedure stdlib${ii}$_dorbdb3 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$orbdb3 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sorbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, & tauq1, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lwork,m,p,q,ldx11,ldx21 + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork,m,p,q,ldx11,ldx21 real(sp), intent(out) :: phi(*),theta(*),taup1(*),taup2(*),tauq1(*),work(*) - + real(sp), intent(inout) :: x11(ldx11,*),x21(ldx21,*) end subroutine sorbdb3 -#else - module procedure stdlib_sorbdb3 +#else + module procedure stdlib${ii}$_sorbdb3 #endif - end interface orbdb3 - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$orbdb3 +#:endif +#:endfor +#:endfor + end interface orbdb3 interface orbdb4 !! ORBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny @@ -18764,43 +18682,43 @@ module stdlib_linalg_lapack !! Householder vectors. !! B11 and B12 are (M-Q)-by-(M-Q) bidiagonal matrices represented !! implicitly by angles THETA, PHI. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dorbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, & tauq1, phantom, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lwork,m,p,q,ldx11,ldx21 + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork,m,p,q,ldx11,ldx21 real(dp), intent(out) :: phi(*),theta(*),phantom(*),taup1(*),taup2(*),tauq1(*)& ,work(*) real(dp), intent(inout) :: x11(ldx11,*),x21(ldx21,*) end subroutine dorbdb4 -#else - module procedure stdlib_dorbdb4 +#else + module procedure stdlib${ii}$_dorbdb4 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$orbdb4 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sorbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, & tauq1, phantom, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lwork,m,p,q,ldx11,ldx21 + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork,m,p,q,ldx11,ldx21 real(sp), intent(out) :: phi(*),theta(*),phantom(*),taup1(*),taup2(*),tauq1(*)& ,work(*) real(sp), intent(inout) :: x11(ldx11,*),x21(ldx21,*) end subroutine sorbdb4 -#else - module procedure stdlib_sorbdb4 +#else + module procedure stdlib${ii}$_sorbdb4 #endif - end interface orbdb4 - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$orbdb4 +#:endif +#:endfor +#:endfor + end interface orbdb4 interface orbdb5 !! ORBDB5 orthogonalizes the column vector @@ -18814,43 +18732,43 @@ module stdlib_linalg_lapack !! criterion, then some other vector from the orthogonal complement !! is returned. This vector is chosen in an arbitrary but deterministic !! way. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dorbdb5( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx1,incx2,ldq1,ldq2,lwork,m1,m2,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx1,incx2,ldq1,ldq2,lwork,m1,m2,n + integer(${ik}$), intent(out) :: info real(dp), intent(in) :: q1(ldq1,*),q2(ldq2,*) real(dp), intent(out) :: work(*) real(dp), intent(inout) :: x1(*),x2(*) end subroutine dorbdb5 -#else - module procedure stdlib_dorbdb5 +#else + module procedure stdlib${ii}$_dorbdb5 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$orbdb5 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sorbdb5( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx1,incx2,ldq1,ldq2,lwork,m1,m2,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx1,incx2,ldq1,ldq2,lwork,m1,m2,n + integer(${ik}$), intent(out) :: info real(sp), intent(in) :: q1(ldq1,*),q2(ldq2,*) real(sp), intent(out) :: work(*) real(sp), intent(inout) :: x1(*),x2(*) end subroutine sorbdb5 -#else - module procedure stdlib_sorbdb5 +#else + module procedure stdlib${ii}$_sorbdb5 #endif - end interface orbdb5 - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$orbdb5 +#:endif +#:endfor +#:endfor + end interface orbdb5 interface orbdb6 !! ORBDB6 orthogonalizes the column vector @@ -18862,44 +18780,44 @@ module stdlib_linalg_lapack !! The columns of Q must be orthonormal. !! If the projection is zero according to Kahan's "twice is enough" !! criterion, then the zero vector is returned. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dorbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx1,incx2,ldq1,ldq2,lwork,m1,m2,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx1,incx2,ldq1,ldq2,lwork,m1,m2,n + integer(${ik}$), intent(out) :: info real(dp), intent(in) :: q1(ldq1,*),q2(ldq2,*) real(dp), intent(out) :: work(*) real(dp), intent(inout) :: x1(*),x2(*) end subroutine dorbdb6 -#else - module procedure stdlib_dorbdb6 +#else + module procedure stdlib${ii}$_dorbdb6 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$orbdb6 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sorbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx1,incx2,ldq1,ldq2,lwork,m1,m2,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx1,incx2,ldq1,ldq2,lwork,m1,m2,n + integer(${ik}$), intent(out) :: info real(sp), intent(in) :: q1(ldq1,*),q2(ldq2,*) real(sp), intent(out) :: work(*) real(sp), intent(inout) :: x1(*),x2(*) end subroutine sorbdb6 -#else - module procedure stdlib_sorbdb6 +#else + module procedure stdlib${ii}$_sorbdb6 #endif +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$orbdb6 + +#:endif +#:endfor +#:endfor end interface orbdb6 - - interface orcsd !! ORCSD computes the CS decomposition of an M-by-M partitioned !! orthogonal matrix X: @@ -18914,51 +18832,51 @@ module stdlib_linalg_lapack !! (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are !! R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in !! which R = MIN(P,M-P,Q,M-Q). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ recursive subroutine dorcsd( jobu1, jobu2, jobv1t, jobv2t, trans,signs, m, p, q, & x11, ldx11, x12,ldx12, x21, ldx21, x22, ldx22, theta,u1, ldu1, u2, ldu2, v1t, & ldv1t, v2t,ldv2t, work, lwork, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobu1,jobu2,jobv1t,jobv2t,signs,trans - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldu1,ldu2,ldv1t,ldv2t,ldx11,ldx12,ldx21,ldx22,& + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldu1,ldu2,ldv1t,ldv2t,ldx11,ldx12,ldx21,ldx22,& lwork,m,p,q real(dp), intent(out) :: theta(*),u1(ldu1,*),u2(ldu2,*),v1t(ldv1t,*),v2t(& ldv2t,*),work(*) real(dp), intent(inout) :: x11(ldx11,*),x12(ldx12,*),x21(ldx21,*),x22(ldx22,*) - + end subroutine dorcsd -#else - module procedure stdlib_dorcsd +#else + module procedure stdlib${ii}$_dorcsd #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$orcsd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ recursive subroutine sorcsd( jobu1, jobu2, jobv1t, jobv2t, trans,signs, m, p, q, & x11, ldx11, x12,ldx12, x21, ldx21, x22, ldx22, theta,u1, ldu1, u2, ldu2, v1t, & ldv1t, v2t,ldv2t, work, lwork, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobu1,jobu2,jobv1t,jobv2t,signs,trans - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldu1,ldu2,ldv1t,ldv2t,ldx11,ldx12,ldx21,ldx22,& + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldu1,ldu2,ldv1t,ldv2t,ldx11,ldx12,ldx21,ldx22,& lwork,m,p,q real(sp), intent(out) :: theta(*),u1(ldu1,*),u2(ldu2,*),v1t(ldv1t,*),v2t(& ldv2t,*),work(*) real(sp), intent(inout) :: x11(ldx11,*),x12(ldx12,*),x21(ldx21,*),x22(ldx22,*) - + end subroutine sorcsd -#else - module procedure stdlib_sorcsd +#else + module procedure stdlib${ii}$_sorcsd #endif - end interface orcsd - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$orcsd +#:endif +#:endfor +#:endfor + end interface orcsd interface orcsd2by1 !! ORCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with @@ -18976,45 +18894,45 @@ module stdlib_linalg_lapack !! nonnegative diagonal matrices satisfying C^2 + S^2 = I, in which !! R = MIN(P,M-P,Q,M-Q). I1 is a K1-by-K1 identity matrix and I2 is a !! K2-by-K2 identity matrix, where K1 = MAX(Q+P-M,0), K2 = MAX(Q-P,0). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dorcsd2by1( jobu1, jobu2, jobv1t, m, p, q, x11, ldx11,x21, ldx21, theta,& u1, ldu1, u2, ldu2, v1t,ldv1t, work, lwork, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobu1,jobu2,jobv1t - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldu1,ldu2,ldv1t,lwork,ldx11,ldx21,m,p,q + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldu1,ldu2,ldv1t,lwork,ldx11,ldx21,m,p,q real(dp), intent(out) :: theta(*),u1(ldu1,*),u2(ldu2,*),v1t(ldv1t,*),work(*) - + real(dp), intent(inout) :: x11(ldx11,*),x21(ldx21,*) end subroutine dorcsd2by1 -#else - module procedure stdlib_dorcsd2by1 +#else + module procedure stdlib${ii}$_dorcsd2by1 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$orcsd2by1 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sorcsd2by1( jobu1, jobu2, jobv1t, m, p, q, x11, ldx11,x21, ldx21, theta,& u1, ldu1, u2, ldu2, v1t,ldv1t, work, lwork, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobu1,jobu2,jobv1t - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldu1,ldu2,ldv1t,lwork,ldx11,ldx21,m,p,q + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldu1,ldu2,ldv1t,lwork,ldx11,ldx21,m,p,q real(sp), intent(out) :: theta(*),u1(ldu1,*),u2(ldu2,*),v1t(ldv1t,*),work(*) - + real(sp), intent(inout) :: x11(ldx11,*),x21(ldx21,*) end subroutine sorcsd2by1 -#else - module procedure stdlib_sorcsd2by1 +#else + module procedure stdlib${ii}$_sorcsd2by1 #endif - end interface orcsd2by1 - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$orcsd2by1 +#:endif +#:endfor +#:endfor + end interface orcsd2by1 interface org2l !! ORG2L generates an m by n real matrix Q with orthonormal columns, @@ -19022,41 +18940,41 @@ module stdlib_linalg_lapack !! reflectors of order m !! Q = H(k) . . . H(2) H(1) !! as returned by DGEQLF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dorg2l( m, n, k, a, lda, tau, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,lda,m,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: tau(*) real(dp), intent(out) :: work(*) end subroutine dorg2l -#else - module procedure stdlib_dorg2l +#else + module procedure stdlib${ii}$_dorg2l #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$org2l - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sorg2l( m, n, k, a, lda, tau, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,lda,m,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(in) :: tau(*) real(sp), intent(out) :: work(*) end subroutine sorg2l -#else - module procedure stdlib_sorg2l +#else + module procedure stdlib${ii}$_sorg2l #endif - end interface org2l - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$org2l +#:endif +#:endfor +#:endfor + end interface org2l interface org2r !! ORG2R generates an m by n real matrix Q with orthonormal columns, @@ -19064,41 +18982,41 @@ module stdlib_linalg_lapack !! reflectors of order m !! Q = H(1) H(2) . . . H(k) !! as returned by DGEQRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dorg2r( m, n, k, a, lda, tau, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,lda,m,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: tau(*) real(dp), intent(out) :: work(*) end subroutine dorg2r -#else - module procedure stdlib_dorg2r +#else + module procedure stdlib${ii}$_dorg2r #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$org2r - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sorg2r( m, n, k, a, lda, tau, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,lda,m,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(in) :: tau(*) real(sp), intent(out) :: work(*) end subroutine sorg2r -#else - module procedure stdlib_sorg2r +#else + module procedure stdlib${ii}$_sorg2r #endif - end interface org2r - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$org2r +#:endif +#:endfor +#:endfor + end interface org2r interface orgbr !! ORGBR generates one of the real orthogonal matrices Q or P**T @@ -19117,84 +19035,84 @@ module stdlib_linalg_lapack !! rows of P**T, where n >= m >= k; !! if k >= n, P**T = G(n-1) . . . G(2) G(1) and ORGBR returns P**T as !! an N-by-N matrix. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dorgbr( vect, m, n, k, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: vect - 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 real(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: tau(*) real(dp), intent(out) :: work(*) end subroutine dorgbr -#else - module procedure stdlib_dorgbr +#else + module procedure stdlib${ii}$_dorgbr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$orgbr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sorgbr( vect, m, n, k, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: vect - 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 real(sp), intent(inout) :: a(lda,*) real(sp), intent(in) :: tau(*) real(sp), intent(out) :: work(*) end subroutine sorgbr -#else - module procedure stdlib_sorgbr +#else + module procedure stdlib${ii}$_sorgbr #endif - end interface orgbr - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$orgbr +#:endif +#:endfor +#:endfor + end interface orgbr interface orghr !! ORGHR generates a real orthogonal matrix Q which is defined as the !! product of IHI-ILO elementary reflectors of order N, as returned by !! DGEHRD: !! Q = H(ilo) H(ilo+1) . . . H(ihi-1). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dorghr( n, ilo, ihi, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihi,ilo,lda,lwork,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihi,ilo,lda,lwork,n + integer(${ik}$), intent(out) :: info real(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: tau(*) real(dp), intent(out) :: work(*) end subroutine dorghr -#else - module procedure stdlib_dorghr +#else + module procedure stdlib${ii}$_dorghr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$orghr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sorghr( n, ilo, ihi, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihi,ilo,lda,lwork,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihi,ilo,lda,lwork,n + integer(${ik}$), intent(out) :: info real(sp), intent(inout) :: a(lda,*) real(sp), intent(in) :: tau(*) real(sp), intent(out) :: work(*) end subroutine sorghr -#else - module procedure stdlib_sorghr +#else + module procedure stdlib${ii}$_sorghr #endif - end interface orghr - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$orghr +#:endif +#:endfor +#:endfor + end interface orghr interface orglq !! ORGLQ generates an M-by-N real matrix Q with orthonormal rows, @@ -19202,41 +19120,41 @@ module stdlib_linalg_lapack !! reflectors of order N !! Q = H(k) . . . H(2) H(1) !! as returned by DGELQF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dorglq( m, n, k, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,lda,lwork,m,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: tau(*) real(dp), intent(out) :: work(*) end subroutine dorglq -#else - module procedure stdlib_dorglq +#else + module procedure stdlib${ii}$_dorglq #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$orglq - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sorglq( m, n, k, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,lda,lwork,m,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(in) :: tau(*) real(sp), intent(out) :: work(*) end subroutine sorglq -#else - module procedure stdlib_sorglq +#else + module procedure stdlib${ii}$_sorglq #endif - end interface orglq - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$orglq +#:endif +#:endfor +#:endfor + end interface orglq interface orgql !! ORGQL generates an M-by-N real matrix Q with orthonormal columns, @@ -19244,41 +19162,41 @@ module stdlib_linalg_lapack !! reflectors of order M !! Q = H(k) . . . H(2) H(1) !! as returned by DGEQLF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dorgql( m, n, k, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,lda,lwork,m,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: tau(*) real(dp), intent(out) :: work(*) end subroutine dorgql -#else - module procedure stdlib_dorgql +#else + module procedure stdlib${ii}$_dorgql #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$orgql - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sorgql( m, n, k, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,lda,lwork,m,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(in) :: tau(*) real(sp), intent(out) :: work(*) end subroutine sorgql -#else - module procedure stdlib_sorgql +#else + module procedure stdlib${ii}$_sorgql #endif - end interface orgql - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$orgql +#:endif +#:endfor +#:endfor + end interface orgql interface orgqr !! ORGQR generates an M-by-N real matrix Q with orthonormal columns, @@ -19286,41 +19204,41 @@ module stdlib_linalg_lapack !! reflectors of order M !! Q = H(1) H(2) . . . H(k) !! as returned by DGEQRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dorgqr( m, n, k, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,lda,lwork,m,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: tau(*) real(dp), intent(out) :: work(*) end subroutine dorgqr -#else - module procedure stdlib_dorgqr +#else + module procedure stdlib${ii}$_dorgqr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$orgqr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sorgqr( m, n, k, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,lda,lwork,m,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(in) :: tau(*) real(sp), intent(out) :: work(*) end subroutine sorgqr -#else - module procedure stdlib_sorgqr +#else + module procedure stdlib${ii}$_sorgqr #endif - end interface orgqr - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$orgqr +#:endif +#:endfor +#:endfor + end interface orgqr interface orgrq !! ORGRQ generates an M-by-N real matrix Q with orthonormal rows, @@ -19328,41 +19246,41 @@ module stdlib_linalg_lapack !! reflectors of order N !! Q = H(1) H(2) . . . H(k) !! as returned by DGERQF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dorgrq( m, n, k, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,lda,lwork,m,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: tau(*) real(dp), intent(out) :: work(*) end subroutine dorgrq -#else - module procedure stdlib_dorgrq +#else + module procedure stdlib${ii}$_dorgrq #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$orgrq - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sorgrq( m, n, k, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,lda,lwork,m,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(in) :: tau(*) real(sp), intent(out) :: work(*) end subroutine sorgrq -#else - module procedure stdlib_sorgrq +#else + module procedure stdlib${ii}$_sorgrq #endif - end interface orgrq - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$orgrq +#:endif +#:endfor +#:endfor + end interface orgrq interface orgtr !! ORGTR generates a real orthogonal matrix Q which is defined as the @@ -19370,43 +19288,43 @@ module stdlib_linalg_lapack !! DSYTRD: !! if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), !! if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dorgtr( uplo, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: tau(*) real(dp), intent(out) :: work(*) end subroutine dorgtr -#else - module procedure stdlib_dorgtr +#else + module procedure stdlib${ii}$_dorgtr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$orgtr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sorgtr( uplo, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: a(lda,*) real(sp), intent(in) :: tau(*) real(sp), intent(out) :: work(*) end subroutine sorgtr -#else - module procedure stdlib_sorgtr +#else + module procedure stdlib${ii}$_sorgtr #endif - end interface orgtr - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$orgtr +#:endif +#:endfor +#:endfor + end interface orgtr interface orgtsqr !! ORGTSQR generates an M-by-N real matrix Q_out with orthonormal columns, @@ -19414,41 +19332,41 @@ module stdlib_linalg_lapack !! matrices of order M which are returned by DLATSQR !! Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ). !! See the documentation for DLATSQR. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dorgtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,lwork,m,n,mb,nb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,lwork,m,n,mb,nb real(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: t(ldt,*) real(dp), intent(out) :: work(*) end subroutine dorgtsqr -#else - module procedure stdlib_dorgtsqr +#else + module procedure stdlib${ii}$_dorgtsqr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$orgtsqr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sorgtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,lwork,m,n,mb,nb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,lwork,m,n,mb,nb real(sp), intent(inout) :: a(lda,*) real(sp), intent(in) :: t(ldt,*) real(sp), intent(out) :: work(*) end subroutine sorgtsqr -#else - module procedure stdlib_sorgtsqr +#else + module procedure stdlib${ii}$_sorgtsqr #endif - end interface orgtsqr - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$orgtsqr +#:endif +#:endfor +#:endfor + end interface orgtsqr interface orgtsqr_row !! ORGTSQR_ROW generates an M-by-N real matrix Q_out with @@ -19466,43 +19384,43 @@ module stdlib_linalg_lapack !! starting in the bottom row block and continues to the top row block !! (hence _ROW in the routine name). This sweep is in reverse order of !! the order in which DLATSQR generates the output blocks. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dorgtsqr_row( m, n, mb, nb, a, lda, t, ldt, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,lwork,m,n,mb,nb + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,lwork,m,n,mb,nb real(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: t(ldt,*) real(dp), intent(out) :: work(*) end subroutine dorgtsqr_row -#else - module procedure stdlib_dorgtsqr_row +#else + module procedure stdlib${ii}$_dorgtsqr_row #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$orgtsqr_row - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sorgtsqr_row( m, n, mb, nb, a, lda, t, ldt, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,lwork,m,n,mb,nb + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,lwork,m,n,mb,nb real(sp), intent(inout) :: a(lda,*) real(sp), intent(in) :: t(ldt,*) real(sp), intent(out) :: work(*) end subroutine sorgtsqr_row -#else - module procedure stdlib_sorgtsqr_row +#else + module procedure stdlib${ii}$_sorgtsqr_row #endif - end interface orgtsqr_row - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$orgtsqr_row +#:endif +#:endfor +#:endfor + end interface orgtsqr_row interface orhr_col !! ORHR_COL takes an M-by-N real matrix Q_in with orthonormal columns @@ -19514,39 +19432,39 @@ module stdlib_linalg_lapack !! stored in A on output, and the diagonal entries of S are stored in D. !! Block reflectors are also returned in T !! (same output format as DGEQRT). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dorhr_col( m, n, nb, a, lda, t, ldt, d, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,m,n,nb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,m,n,nb real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: d(*),t(ldt,*) end subroutine dorhr_col -#else - module procedure stdlib_dorhr_col +#else + module procedure stdlib${ii}$_dorhr_col #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$orhr_col - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sorhr_col( m, n, nb, a, lda, t, ldt, d, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,m,n,nb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,m,n,nb real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: d(*),t(ldt,*) end subroutine sorhr_col -#else - module procedure stdlib_sorhr_col +#else + module procedure stdlib${ii}$_sorhr_col #endif - end interface orhr_col - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$orhr_col +#:endif +#:endfor +#:endfor + end interface orhr_col interface orm2l !! ORM2L overwrites the general real m by n matrix C with @@ -19559,45 +19477,45 @@ module stdlib_linalg_lapack !! Q = H(k) . . . H(2) H(1) !! as returned by DGEQLF. Q is of order m if SIDE = 'L' and of order n !! if SIDE = 'R'. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dorm2l( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(inout) :: a(lda,*),c(ldc,*) real(dp), intent(in) :: tau(*) real(dp), intent(out) :: work(*) end subroutine dorm2l -#else - module procedure stdlib_dorm2l +#else + module procedure stdlib${ii}$_dorm2l #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$orm2l - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sorm2l( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: a(lda,*),c(ldc,*) real(sp), intent(in) :: tau(*) real(sp), intent(out) :: work(*) end subroutine sorm2l -#else - module procedure stdlib_sorm2l +#else + module procedure stdlib${ii}$_sorm2l #endif - end interface orm2l - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$orm2l +#:endif +#:endfor +#:endfor + end interface orm2l interface orm2r !! ORM2R overwrites the general real m by n matrix C with @@ -19610,45 +19528,45 @@ module stdlib_linalg_lapack !! Q = H(1) H(2) . . . H(k) !! as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n !! if SIDE = 'R'. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dorm2r( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(inout) :: a(lda,*),c(ldc,*) real(dp), intent(in) :: tau(*) real(dp), intent(out) :: work(*) end subroutine dorm2r -#else - module procedure stdlib_dorm2r +#else + module procedure stdlib${ii}$_dorm2r #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$orm2r - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sorm2r( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: a(lda,*),c(ldc,*) real(sp), intent(in) :: tau(*) real(sp), intent(out) :: work(*) end subroutine sorm2r -#else - module procedure stdlib_sorm2r +#else + module procedure stdlib${ii}$_sorm2r #endif - end interface orm2r - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$orm2r +#:endif +#:endfor +#:endfor + end interface orm2r interface ormbr !! If VECT = 'Q', ORMBR: overwrites the general real M-by-N matrix C @@ -19673,45 +19591,45 @@ module stdlib_linalg_lapack !! If VECT = 'P', A is assumed to have been a K-by-NQ matrix: !! if k < nq, P = G(1) G(2) . . . G(k); !! if k >= nq, P = G(1) G(2) . . . G(nq-1). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dormbr( vect, side, trans, m, n, k, a, lda, tau, c,ldc, work, & lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans,vect - 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 real(dp), intent(inout) :: a(lda,*),c(ldc,*) real(dp), intent(in) :: tau(*) real(dp), intent(out) :: work(*) end subroutine dormbr -#else - module procedure stdlib_dormbr +#else + module procedure stdlib${ii}$_dormbr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ormbr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sormbr( vect, side, trans, m, n, k, a, lda, tau, c,ldc, work, & lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans,vect - 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 real(sp), intent(inout) :: a(lda,*),c(ldc,*) real(sp), intent(in) :: tau(*) real(sp), intent(out) :: work(*) end subroutine sormbr -#else - module procedure stdlib_sormbr +#else + module procedure stdlib${ii}$_sormbr #endif - end interface ormbr - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ormbr +#:endif +#:endfor +#:endfor + end interface ormbr interface ormhr !! ORMHR overwrites the general real M-by-N matrix C with @@ -19722,45 +19640,45 @@ module stdlib_linalg_lapack !! SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of !! IHI-ILO elementary reflectors, as returned by DGEHRD: !! Q = H(ilo) H(ilo+1) . . . H(ihi-1). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dormhr( side, trans, m, n, ilo, ihi, a, lda, tau, c,ldc, work, & lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(in) :: ihi,ilo,lda,ldc,lwork,m,n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi,ilo,lda,ldc,lwork,m,n + integer(${ik}$), intent(out) :: info real(dp), intent(inout) :: a(lda,*),c(ldc,*) real(dp), intent(in) :: tau(*) real(dp), intent(out) :: work(*) end subroutine dormhr -#else - module procedure stdlib_dormhr +#else + module procedure stdlib${ii}$_dormhr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ormhr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sormhr( side, trans, m, n, ilo, ihi, a, lda, tau, c,ldc, work, & lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(in) :: ihi,ilo,lda,ldc,lwork,m,n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi,ilo,lda,ldc,lwork,m,n + integer(${ik}$), intent(out) :: info real(sp), intent(inout) :: a(lda,*),c(ldc,*) real(sp), intent(in) :: tau(*) real(sp), intent(out) :: work(*) end subroutine sormhr -#else - module procedure stdlib_sormhr +#else + module procedure stdlib${ii}$_sormhr #endif - end interface ormhr - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ormhr +#:endif +#:endfor +#:endfor + end interface ormhr interface ormlq !! ORMLQ overwrites the general real M-by-N matrix C with @@ -19772,45 +19690,45 @@ module stdlib_linalg_lapack !! Q = H(k) . . . H(2) H(1) !! as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N !! if SIDE = 'R'. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dormlq( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(inout) :: a(lda,*),c(ldc,*) real(dp), intent(in) :: tau(*) real(dp), intent(out) :: work(*) end subroutine dormlq -#else - module procedure stdlib_dormlq +#else + module procedure stdlib${ii}$_dormlq #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ormlq - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sormlq( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: a(lda,*),c(ldc,*) real(sp), intent(in) :: tau(*) real(sp), intent(out) :: work(*) end subroutine sormlq -#else - module procedure stdlib_sormlq +#else + module procedure stdlib${ii}$_sormlq #endif - end interface ormlq - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ormlq +#:endif +#:endfor +#:endfor + end interface ormlq interface ormql !! ORMQL overwrites the general real M-by-N matrix C with @@ -19822,45 +19740,45 @@ module stdlib_linalg_lapack !! Q = H(k) . . . H(2) H(1) !! as returned by DGEQLF. Q is of order M if SIDE = 'L' and of order N !! if SIDE = 'R'. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dormql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(inout) :: a(lda,*),c(ldc,*) real(dp), intent(in) :: tau(*) real(dp), intent(out) :: work(*) end subroutine dormql -#else - module procedure stdlib_dormql +#else + module procedure stdlib${ii}$_dormql #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ormql - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sormql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: a(lda,*),c(ldc,*) real(sp), intent(in) :: tau(*) real(sp), intent(out) :: work(*) end subroutine sormql -#else - module procedure stdlib_sormql +#else + module procedure stdlib${ii}$_sormql #endif - end interface ormql - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ormql +#:endif +#:endfor +#:endfor + end interface ormql interface ormqr !! ORMQR overwrites the general real M-by-N matrix C with @@ -19872,45 +19790,45 @@ module stdlib_linalg_lapack !! Q = H(1) H(2) . . . H(k) !! as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N !! if SIDE = 'R'. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dormqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(inout) :: a(lda,*),c(ldc,*) real(dp), intent(in) :: tau(*) real(dp), intent(out) :: work(*) end subroutine dormqr -#else - module procedure stdlib_dormqr +#else + module procedure stdlib${ii}$_dormqr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ormqr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sormqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: a(lda,*),c(ldc,*) real(sp), intent(in) :: tau(*) real(sp), intent(out) :: work(*) end subroutine sormqr -#else - module procedure stdlib_sormqr +#else + module procedure stdlib${ii}$_sormqr #endif - end interface ormqr - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ormqr +#:endif +#:endfor +#:endfor + end interface ormqr interface ormrq !! ORMRQ overwrites the general real M-by-N matrix C with @@ -19922,45 +19840,45 @@ module stdlib_linalg_lapack !! Q = H(1) H(2) . . . H(k) !! as returned by DGERQF. Q is of order M if SIDE = 'L' and of order N !! if SIDE = 'R'. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dormrq( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(inout) :: a(lda,*),c(ldc,*) real(dp), intent(in) :: tau(*) real(dp), intent(out) :: work(*) end subroutine dormrq -#else - module procedure stdlib_dormrq +#else + module procedure stdlib${ii}$_dormrq #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ormrq - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sormrq( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: a(lda,*),c(ldc,*) real(sp), intent(in) :: tau(*) real(sp), intent(out) :: work(*) end subroutine sormrq -#else - module procedure stdlib_sormrq +#else + module procedure stdlib${ii}$_sormrq #endif - end interface ormrq - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ormrq +#:endif +#:endfor +#:endfor + end interface ormrq interface ormrz !! ORMRZ overwrites the general real M-by-N matrix C with @@ -19972,45 +19890,45 @@ module stdlib_linalg_lapack !! Q = H(1) H(2) . . . H(k) !! as returned by DTZRZF. Q is of order M if SIDE = 'L' and of order N !! if SIDE = 'R'. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dormrz( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(inout) :: a(lda,*),c(ldc,*) real(dp), intent(in) :: tau(*) real(dp), intent(out) :: work(*) end subroutine dormrz -#else - module procedure stdlib_dormrz +#else + module procedure stdlib${ii}$_dormrz #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ormrz - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sormrz( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: a(lda,*),c(ldc,*) real(sp), intent(in) :: tau(*) real(sp), intent(out) :: work(*) end subroutine sormrz -#else - module procedure stdlib_sormrz +#else + module procedure stdlib${ii}$_sormrz #endif - end interface ormrz - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ormrz +#:endif +#:endfor +#:endfor + end interface ormrz interface ormtr !! ORMTR overwrites the general real M-by-N matrix C with @@ -20022,45 +19940,45 @@ module stdlib_linalg_lapack !! nq-1 elementary reflectors, as returned by DSYTRD: !! if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); !! if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dormtr( side, uplo, trans, m, n, a, lda, tau, c, ldc,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldc,lwork,m,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldc,lwork,m,n real(dp), intent(inout) :: a(lda,*),c(ldc,*) real(dp), intent(in) :: tau(*) real(dp), intent(out) :: work(*) end subroutine dormtr -#else - module procedure stdlib_dormtr +#else + module procedure stdlib${ii}$_dormtr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ormtr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sormtr( side, uplo, trans, m, n, a, lda, tau, c, ldc,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldc,lwork,m,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldc,lwork,m,n real(sp), intent(inout) :: a(lda,*),c(ldc,*) real(sp), intent(in) :: tau(*) real(sp), intent(out) :: work(*) end subroutine sormtr -#else - module procedure stdlib_sormtr +#else + module procedure stdlib${ii}$_sormtr #endif - end interface ormtr - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ormtr +#:endif +#:endfor +#:endfor + end interface ormtr interface pbcon !! PBCON estimates the reciprocal of the condition number (in the @@ -20069,81 +19987,81 @@ module stdlib_linalg_lapack !! CPBTRF. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cpbcon( uplo, n, kd, ab, ldab, anorm, rcond, work,rwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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(in) :: anorm real(sp), intent(out) :: rcond,rwork(*) complex(sp), intent(in) :: ab(ldab,*) complex(sp), intent(out) :: work(*) end subroutine cpbcon -#else - module procedure stdlib_cpbcon +#else + module procedure stdlib${ii}$_cpbcon #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dpbcon( uplo, n, kd, ab, ldab, anorm, rcond, work,iwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: kd,ldab,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: kd,ldab,n real(dp), intent(in) :: anorm,ab(ldab,*) real(dp), intent(out) :: rcond,work(*) end subroutine dpbcon -#else - module procedure stdlib_dpbcon +#else + module procedure stdlib${ii}$_dpbcon #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pbcon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine spbcon( uplo, n, kd, ab, ldab, anorm, rcond, work,iwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: kd,ldab,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: kd,ldab,n real(sp), intent(in) :: anorm,ab(ldab,*) real(sp), intent(out) :: rcond,work(*) end subroutine spbcon -#else - module procedure stdlib_spbcon +#else + module procedure stdlib${ii}$_spbcon #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pbcon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zpbcon( uplo, n, kd, ab, ldab, anorm, rcond, work,rwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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(dp), intent(in) :: anorm real(dp), intent(out) :: rcond,rwork(*) complex(dp), intent(in) :: ab(ldab,*) complex(dp), intent(out) :: work(*) end subroutine zpbcon -#else - module procedure stdlib_zpbcon +#else + module procedure stdlib${ii}$_zpbcon #endif - end interface pbcon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pbcon +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pbcon +#:endif +#:endfor +#:endfor + end interface pbcon interface pbequ !! PBEQU computes row and column scalings intended to equilibrate a @@ -20154,156 +20072,156 @@ module stdlib_linalg_lapack !! choice of S puts the condition number of B within a factor N of the !! smallest possible condition number over all possible diagonal !! scalings. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cpbequ( uplo, n, kd, ab, ldab, s, scond, amax, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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,s(*) complex(sp), intent(in) :: ab(ldab,*) end subroutine cpbequ -#else - module procedure stdlib_cpbequ +#else + module procedure stdlib${ii}$_cpbequ #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dpbequ( uplo, n, kd, ab, ldab, s, scond, amax, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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(dp), intent(out) :: amax,scond,s(*) real(dp), intent(in) :: ab(ldab,*) end subroutine dpbequ -#else - module procedure stdlib_dpbequ +#else + module procedure stdlib${ii}$_dpbequ #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pbequ - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine spbequ( uplo, n, kd, ab, ldab, s, scond, amax, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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,s(*) real(sp), intent(in) :: ab(ldab,*) end subroutine spbequ -#else - module procedure stdlib_spbequ +#else + module procedure stdlib${ii}$_spbequ #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pbequ - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zpbequ( uplo, n, kd, ab, ldab, s, scond, amax, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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(dp), intent(out) :: amax,scond,s(*) complex(dp), intent(in) :: ab(ldab,*) end subroutine zpbequ -#else - module procedure stdlib_zpbequ +#else + module procedure stdlib${ii}$_zpbequ #endif - end interface pbequ +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pbequ +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pbequ +#:endif +#:endfor +#:endfor + end interface pbequ interface pbrfs !! PBRFS improves the computed solution to a system of linear !! equations when the coefficient matrix is Hermitian positive definite !! and banded, and provides error bounds and backward error estimates !! for the solution. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cpbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b,ldb, x, ldx, & ferr, berr, work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kd,ldab,ldafb,ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kd,ldab,ldafb,ldb,ldx,n,nrhs real(sp), intent(out) :: berr(*),ferr(*),rwork(*) complex(sp), intent(in) :: ab(ldab,*),afb(ldafb,*),b(ldb,*) complex(sp), intent(out) :: work(*) complex(sp), intent(inout) :: x(ldx,*) end subroutine cpbrfs -#else - module procedure stdlib_cpbrfs +#else + module procedure stdlib${ii}$_cpbrfs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dpbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b,ldb, x, ldx, & ferr, berr, work, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: kd,ldab,ldafb,ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: kd,ldab,ldafb,ldb,ldx,n,nrhs real(dp), intent(in) :: ab(ldab,*),afb(ldafb,*),b(ldb,*) real(dp), intent(out) :: berr(*),ferr(*),work(*) real(dp), intent(inout) :: x(ldx,*) end subroutine dpbrfs -#else - module procedure stdlib_dpbrfs +#else + module procedure stdlib${ii}$_dpbrfs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pbrfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine spbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b,ldb, x, ldx, & ferr, berr, work, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: kd,ldab,ldafb,ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: kd,ldab,ldafb,ldb,ldx,n,nrhs real(sp), intent(in) :: ab(ldab,*),afb(ldafb,*),b(ldb,*) real(sp), intent(out) :: berr(*),ferr(*),work(*) real(sp), intent(inout) :: x(ldx,*) end subroutine spbrfs -#else - module procedure stdlib_spbrfs +#else + module procedure stdlib${ii}$_spbrfs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pbrfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zpbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b,ldb, x, ldx, & ferr, berr, work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kd,ldab,ldafb,ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kd,ldab,ldafb,ldb,ldx,n,nrhs real(dp), intent(out) :: berr(*),ferr(*),rwork(*) complex(dp), intent(in) :: ab(ldab,*),afb(ldafb,*),b(ldb,*) complex(dp), intent(out) :: work(*) complex(dp), intent(inout) :: x(ldx,*) end subroutine zpbrfs -#else - module procedure stdlib_zpbrfs +#else + module procedure stdlib${ii}$_zpbrfs #endif - end interface pbrfs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pbrfs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pbrfs +#:endif +#:endfor +#:endfor + end interface pbrfs interface pbstf !! PBSTF computes a split Cholesky factorization of a complex @@ -20315,69 +20233,69 @@ module stdlib_linalg_lapack !! ( M L ) !! where U is upper triangular of order m = (n+kd)/2, and L is lower !! triangular of order n-m. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cpbstf( uplo, n, kd, ab, ldab, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(inout) :: ab(ldab,*) end subroutine cpbstf -#else - module procedure stdlib_cpbstf +#else + module procedure stdlib${ii}$_cpbstf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dpbstf( uplo, n, kd, ab, ldab, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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(dp), intent(inout) :: ab(ldab,*) end subroutine dpbstf -#else - module procedure stdlib_dpbstf +#else + module procedure stdlib${ii}$_dpbstf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pbstf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine spbstf( uplo, n, kd, ab, ldab, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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(inout) :: ab(ldab,*) end subroutine spbstf -#else - module procedure stdlib_spbstf +#else + module procedure stdlib${ii}$_spbstf #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pbstf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zpbstf( uplo, n, kd, ab, ldab, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(inout) :: ab(ldab,*) end subroutine zpbstf -#else - module procedure stdlib_zpbstf +#else + module procedure stdlib${ii}$_zpbstf #endif - end interface pbstf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pbstf +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pbstf +#:endif +#:endfor +#:endfor + end interface pbstf interface pbsv !! PBSV computes the solution to a complex system of linear equations @@ -20391,69 +20309,69 @@ module stdlib_linalg_lapack !! triangular band matrix, with the same number of superdiagonals or !! subdiagonals as A. The factored form of A is then used to solve the !! system of equations A * X = B. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cpbsv( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(inout) :: ab(ldab,*),b(ldb,*) end subroutine cpbsv -#else - module procedure stdlib_cpbsv +#else + module procedure stdlib${ii}$_cpbsv #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dpbsv( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(inout) :: ab(ldab,*),b(ldb,*) end subroutine dpbsv -#else - module procedure stdlib_dpbsv +#else + module procedure stdlib${ii}$_dpbsv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pbsv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine spbsv( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: ab(ldab,*),b(ldb,*) end subroutine spbsv -#else - module procedure stdlib_spbsv +#else + module procedure stdlib${ii}$_spbsv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pbsv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zpbsv( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(inout) :: ab(ldab,*),b(ldb,*) end subroutine zpbsv -#else - module procedure stdlib_zpbsv +#else + module procedure stdlib${ii}$_zpbsv #endif - end interface pbsv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pbsv +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pbsv +#:endif +#:endfor +#:endfor + end interface pbsv interface pbtrf !! PBTRF computes the Cholesky factorization of a complex Hermitian @@ -20462,141 +20380,141 @@ module stdlib_linalg_lapack !! A = U**H * U, if UPLO = 'U', or !! A = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cpbtrf( uplo, n, kd, ab, ldab, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(inout) :: ab(ldab,*) end subroutine cpbtrf -#else - module procedure stdlib_cpbtrf +#else + module procedure stdlib${ii}$_cpbtrf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dpbtrf( uplo, n, kd, ab, ldab, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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(dp), intent(inout) :: ab(ldab,*) end subroutine dpbtrf -#else - module procedure stdlib_dpbtrf +#else + module procedure stdlib${ii}$_dpbtrf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pbtrf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine spbtrf( uplo, n, kd, ab, ldab, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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(inout) :: ab(ldab,*) end subroutine spbtrf -#else - module procedure stdlib_spbtrf +#else + module procedure stdlib${ii}$_spbtrf #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pbtrf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zpbtrf( uplo, n, kd, ab, ldab, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(inout) :: ab(ldab,*) end subroutine zpbtrf -#else - module procedure stdlib_zpbtrf +#else + module procedure stdlib${ii}$_zpbtrf #endif - end interface pbtrf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pbtrf +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pbtrf +#:endif +#:endfor +#:endfor + end interface pbtrf interface pbtrs !! PBTRS solves a system of linear equations A*X = B with a Hermitian !! positive definite band matrix A using the Cholesky factorization !! A = U**H*U or A = L*L**H computed by CPBTRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cpbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(in) :: ab(ldab,*) complex(sp), intent(inout) :: b(ldb,*) end subroutine cpbtrs -#else - module procedure stdlib_cpbtrs +#else + module procedure stdlib${ii}$_cpbtrs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dpbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(in) :: ab(ldab,*) real(dp), intent(inout) :: b(ldb,*) end subroutine dpbtrs -#else - module procedure stdlib_dpbtrs +#else + module procedure stdlib${ii}$_dpbtrs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pbtrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine spbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(in) :: ab(ldab,*) real(sp), intent(inout) :: b(ldb,*) end subroutine spbtrs -#else - module procedure stdlib_spbtrs +#else + module procedure stdlib${ii}$_spbtrs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pbtrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zpbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(in) :: ab(ldab,*) complex(dp), intent(inout) :: b(ldb,*) end subroutine zpbtrs -#else - module procedure stdlib_zpbtrs +#else + module procedure stdlib${ii}$_zpbtrs #endif - end interface pbtrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pbtrs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pbtrs +#:endif +#:endfor +#:endfor + end interface pbtrs interface pftrf !! PFTRF computes the Cholesky factorization of a complex Hermitian @@ -20606,209 +20524,209 @@ module stdlib_linalg_lapack !! A = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the block version of the algorithm, calling Level 3 BLAS. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cpftrf( transr, uplo, n, a, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,uplo - integer(ilp), intent(in) :: n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n + integer(${ik}$), intent(out) :: info complex(sp), intent(inout) :: a(0:*) end subroutine cpftrf -#else - module procedure stdlib_cpftrf +#else + module procedure stdlib${ii}$_cpftrf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dpftrf( transr, uplo, n, a, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,uplo - integer(ilp), intent(in) :: n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n + integer(${ik}$), intent(out) :: info real(dp), intent(inout) :: a(0:*) end subroutine dpftrf -#else - module procedure stdlib_dpftrf +#else + module procedure stdlib${ii}$_dpftrf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pftrf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine spftrf( transr, uplo, n, a, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,uplo - integer(ilp), intent(in) :: n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n + integer(${ik}$), intent(out) :: info real(sp), intent(inout) :: a(0:*) end subroutine spftrf -#else - module procedure stdlib_spftrf +#else + module procedure stdlib${ii}$_spftrf #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pftrf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zpftrf( transr, uplo, n, a, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,uplo - integer(ilp), intent(in) :: n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n + integer(${ik}$), intent(out) :: info complex(dp), intent(inout) :: a(0:*) end subroutine zpftrf -#else - module procedure stdlib_zpftrf +#else + module procedure stdlib${ii}$_zpftrf #endif - end interface pftrf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pftrf +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pftrf +#:endif +#:endfor +#:endfor + end interface pftrf interface pftri !! PFTRI computes the inverse of a complex Hermitian positive definite !! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H !! computed by CPFTRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cpftri( transr, uplo, n, a, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n complex(sp), intent(inout) :: a(0:*) end subroutine cpftri -#else - module procedure stdlib_cpftri +#else + module procedure stdlib${ii}$_cpftri #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dpftri( transr, uplo, n, a, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(dp), intent(inout) :: a(0:*) end subroutine dpftri -#else - module procedure stdlib_dpftri +#else + module procedure stdlib${ii}$_dpftri #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pftri - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine spftri( transr, uplo, n, a, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(sp), intent(inout) :: a(0:*) end subroutine spftri -#else - module procedure stdlib_spftri +#else + module procedure stdlib${ii}$_spftri +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine zpftri( transr, uplo, n, a, info ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + character, intent(in) :: transr,uplo + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n + complex(dp), intent(inout) :: a(0:*) + end subroutine zpftri +#else + module procedure stdlib${ii}$_zpftri #endif +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pftri + +#:endif +#:endfor #:for rk,rt,ri in CMPLX_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pftri + module procedure stdlib${ii}$_${ri}$pftri #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine zpftri( transr, uplo, n, a, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - character, intent(in) :: transr,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n - complex(dp), intent(inout) :: a(0:*) - end subroutine zpftri -#else - module procedure stdlib_zpftri -#endif +#:endfor end interface pftri - - interface pftrs !! PFTRS solves a system of linear equations A*X = B with a Hermitian !! positive definite matrix A using the Cholesky factorization !! A = U**H*U or A = L*L**H computed by CPFTRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cpftrs( transr, uplo, n, nrhs, a, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs complex(sp), intent(in) :: a(0:*) complex(sp), intent(inout) :: b(ldb,*) end subroutine cpftrs -#else - module procedure stdlib_cpftrs +#else + module procedure stdlib${ii}$_cpftrs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dpftrs( transr, uplo, n, nrhs, a, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs real(dp), intent(in) :: a(0:*) real(dp), intent(inout) :: b(ldb,*) end subroutine dpftrs -#else - module procedure stdlib_dpftrs +#else + module procedure stdlib${ii}$_dpftrs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pftrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine spftrs( transr, uplo, n, nrhs, a, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs real(sp), intent(in) :: a(0:*) real(sp), intent(inout) :: b(ldb,*) end subroutine spftrs -#else - module procedure stdlib_spftrs +#else + module procedure stdlib${ii}$_spftrs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pftrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zpftrs( transr, uplo, n, nrhs, a, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs complex(dp), intent(in) :: a(0:*) complex(dp), intent(inout) :: b(ldb,*) end subroutine zpftrs -#else - module procedure stdlib_zpftrs +#else + module procedure stdlib${ii}$_zpftrs #endif - end interface pftrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pftrs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pftrs +#:endif +#:endfor +#:endfor + end interface pftrs interface pocon !! POCON estimates the reciprocal of the condition number (in the @@ -20816,79 +20734,79 @@ module stdlib_linalg_lapack !! Cholesky factorization A = U**H*U or A = L*L**H computed by CPOTRF. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cpocon( uplo, n, a, lda, anorm, rcond, work, rwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(in) :: anorm real(sp), intent(out) :: rcond,rwork(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: work(*) end subroutine cpocon -#else - module procedure stdlib_cpocon +#else + module procedure stdlib${ii}$_cpocon #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dpocon( uplo, n, a, lda, anorm, rcond, work, iwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,n real(dp), intent(in) :: anorm real(dp), intent(out) :: rcond,work(*) real(dp), intent(inout) :: a(lda,*) end subroutine dpocon -#else - module procedure stdlib_dpocon +#else + module procedure stdlib${ii}$_dpocon #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pocon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine spocon( uplo, n, a, lda, anorm, rcond, work, iwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,n real(sp), intent(in) :: anorm real(sp), intent(out) :: rcond,work(*) real(sp), intent(inout) :: a(lda,*) end subroutine spocon -#else - module procedure stdlib_spocon +#else + module procedure stdlib${ii}$_spocon #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pocon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zpocon( uplo, n, a, lda, anorm, rcond, work, rwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(in) :: anorm real(dp), intent(out) :: rcond,rwork(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: work(*) end subroutine zpocon -#else - module procedure stdlib_zpocon +#else + module procedure stdlib${ii}$_zpocon #endif - end interface pocon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pocon +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pocon +#:endif +#:endfor +#:endfor + end interface pocon interface poequ !! POEQU computes row and column scalings intended to equilibrate a @@ -20899,69 +20817,69 @@ module stdlib_linalg_lapack !! choice of S puts the condition number of B within a factor N of the !! smallest possible condition number over all possible diagonal !! scalings. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cpoequ( n, a, lda, s, scond, amax, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n real(sp), intent(out) :: amax,scond,s(*) complex(sp), intent(in) :: a(lda,*) end subroutine cpoequ -#else - module procedure stdlib_cpoequ +#else + module procedure stdlib${ii}$_cpoequ #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dpoequ( n, a, lda, s, scond, amax, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n real(dp), intent(out) :: amax,scond,s(*) real(dp), intent(in) :: a(lda,*) end subroutine dpoequ -#else - module procedure stdlib_dpoequ +#else + module procedure stdlib${ii}$_dpoequ #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$poequ - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine spoequ( n, a, lda, s, scond, amax, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n real(sp), intent(out) :: amax,scond,s(*) real(sp), intent(in) :: a(lda,*) end subroutine spoequ -#else - module procedure stdlib_spoequ +#else + module procedure stdlib${ii}$_spoequ #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$poequ - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zpoequ( n, a, lda, s, scond, amax, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n real(dp), intent(out) :: amax,scond,s(*) complex(dp), intent(in) :: a(lda,*) end subroutine zpoequ -#else - module procedure stdlib_zpoequ +#else + module procedure stdlib${ii}$_zpoequ #endif - end interface poequ +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$poequ +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$poequ +#:endif +#:endfor +#:endfor + end interface poequ interface poequb !! POEQUB computes row and column scalings intended to equilibrate a @@ -20977,152 +20895,152 @@ module stdlib_linalg_lapack !! these factors introduces no additional rounding errors. However, the !! scaled diagonal entries are no longer approximately 1 but lie !! between sqrt(radix) and 1/sqrt(radix). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cpoequb( n, a, lda, s, scond, amax, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n real(sp), intent(out) :: amax,scond,s(*) complex(sp), intent(in) :: a(lda,*) end subroutine cpoequb -#else - module procedure stdlib_cpoequb +#else + module procedure stdlib${ii}$_cpoequb #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dpoequb( n, a, lda, s, scond, amax, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n real(dp), intent(out) :: amax,scond,s(*) real(dp), intent(in) :: a(lda,*) end subroutine dpoequb -#else - module procedure stdlib_dpoequb +#else + module procedure stdlib${ii}$_dpoequb #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$poequb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine spoequb( n, a, lda, s, scond, amax, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n real(sp), intent(out) :: amax,scond,s(*) real(sp), intent(in) :: a(lda,*) end subroutine spoequb -#else - module procedure stdlib_spoequb +#else + module procedure stdlib${ii}$_spoequb #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$poequb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zpoequb( n, a, lda, s, scond, amax, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n real(dp), intent(out) :: amax,scond,s(*) complex(dp), intent(in) :: a(lda,*) end subroutine zpoequb -#else - module procedure stdlib_zpoequb +#else + module procedure stdlib${ii}$_zpoequb #endif - end interface poequb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$poequb +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$poequb +#:endif +#:endfor +#:endfor + end interface poequb interface porfs !! PORFS improves the computed solution to a system of linear !! equations when the coefficient matrix is Hermitian positive definite, !! and provides error bounds and backward error estimates for the !! solution. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x,ldx, ferr, berr,& work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs real(sp), intent(out) :: berr(*),ferr(*),rwork(*) complex(sp), intent(in) :: a(lda,*),af(ldaf,*),b(ldb,*) complex(sp), intent(out) :: work(*) complex(sp), intent(inout) :: x(ldx,*) end subroutine cporfs -#else - module procedure stdlib_cporfs +#else + module procedure stdlib${ii}$_cporfs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x,ldx, ferr, berr,& work, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs real(dp), intent(in) :: a(lda,*),af(ldaf,*),b(ldb,*) real(dp), intent(out) :: berr(*),ferr(*),work(*) real(dp), intent(inout) :: x(ldx,*) end subroutine dporfs -#else - module procedure stdlib_dporfs +#else + module procedure stdlib${ii}$_dporfs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$porfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x,ldx, ferr, berr,& work, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs real(sp), intent(in) :: a(lda,*),af(ldaf,*),b(ldb,*) real(sp), intent(out) :: berr(*),ferr(*),work(*) real(sp), intent(inout) :: x(ldx,*) end subroutine sporfs -#else - module procedure stdlib_sporfs +#else + module procedure stdlib${ii}$_sporfs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$porfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x,ldx, ferr, berr,& work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs real(dp), intent(out) :: berr(*),ferr(*),rwork(*) complex(dp), intent(in) :: a(lda,*),af(ldaf,*),b(ldb,*) complex(dp), intent(out) :: work(*) complex(dp), intent(inout) :: x(ldx,*) end subroutine zporfs -#else - module procedure stdlib_zporfs +#else + module procedure stdlib${ii}$_zporfs #endif - end interface porfs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$porfs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$porfs +#:endif +#:endfor +#:endfor + end interface porfs interface posv !! POSV computes the solution to a complex system of linear equations @@ -21135,69 +21053,69 @@ module stdlib_linalg_lapack !! where U is an upper triangular matrix and L is a lower triangular !! matrix. The factored form of A is then used to solve the system of !! equations A * X = B. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cposv( uplo, n, nrhs, a, lda, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(inout) :: a(lda,*),b(ldb,*) end subroutine cposv -#else - module procedure stdlib_cposv +#else + module procedure stdlib${ii}$_cposv #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dposv( uplo, n, nrhs, a, lda, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(inout) :: a(lda,*),b(ldb,*) end subroutine dposv -#else - module procedure stdlib_dposv +#else + module procedure stdlib${ii}$_dposv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$posv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sposv( uplo, n, nrhs, a, lda, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: a(lda,*),b(ldb,*) end subroutine sposv -#else - module procedure stdlib_sposv +#else + module procedure stdlib${ii}$_sposv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$posv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zposv( uplo, n, nrhs, a, lda, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(inout) :: a(lda,*),b(ldb,*) end subroutine zposv -#else - module procedure stdlib_zposv +#else + module procedure stdlib${ii}$_zposv #endif - end interface posv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$posv +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$posv +#:endif +#:endfor +#:endfor + end interface posv interface potrf !! POTRF computes the Cholesky factorization of a complex Hermitian @@ -21207,69 +21125,69 @@ module stdlib_linalg_lapack !! A = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. !! This is the block version of the algorithm, calling Level 3 BLAS. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cpotrf( uplo, n, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(inout) :: a(lda,*) end subroutine cpotrf -#else - module procedure stdlib_cpotrf +#else + module procedure stdlib${ii}$_cpotrf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dpotrf( uplo, n, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(inout) :: a(lda,*) end subroutine dpotrf -#else - module procedure stdlib_dpotrf +#else + module procedure stdlib${ii}$_dpotrf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$potrf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine spotrf( uplo, n, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: a(lda,*) end subroutine spotrf -#else - module procedure stdlib_spotrf +#else + module procedure stdlib${ii}$_spotrf #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$potrf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zpotrf( uplo, n, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(inout) :: a(lda,*) end subroutine zpotrf -#else - module procedure stdlib_zpotrf +#else + module procedure stdlib${ii}$_zpotrf #endif - end interface potrf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$potrf +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$potrf +#:endif +#:endfor +#:endfor + end interface potrf interface potrf2 !! POTRF2 computes the Cholesky factorization of a Hermitian @@ -21285,209 +21203,209 @@ module stdlib_linalg_lapack !! [ A21 | A22 ] n2 = n-n1 !! The subroutine calls itself to factor A11. Update and scale A21 !! or A12, update A22 then calls itself to factor A22. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure recursive subroutine cpotrf2( uplo, n, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(inout) :: a(lda,*) end subroutine cpotrf2 -#else - module procedure stdlib_cpotrf2 +#else + module procedure stdlib${ii}$_cpotrf2 #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure recursive subroutine dpotrf2( uplo, n, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(inout) :: a(lda,*) end subroutine dpotrf2 -#else - module procedure stdlib_dpotrf2 +#else + module procedure stdlib${ii}$_dpotrf2 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$potrf2 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure recursive subroutine spotrf2( uplo, n, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: a(lda,*) end subroutine spotrf2 -#else - module procedure stdlib_spotrf2 +#else + module procedure stdlib${ii}$_spotrf2 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$potrf2 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure recursive subroutine zpotrf2( uplo, n, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(inout) :: a(lda,*) end subroutine zpotrf2 -#else - module procedure stdlib_zpotrf2 +#else + module procedure stdlib${ii}$_zpotrf2 #endif - end interface potrf2 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$potrf2 +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$potrf2 +#:endif +#:endfor +#:endfor + end interface potrf2 interface potri !! POTRI computes the inverse of a complex Hermitian positive definite !! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H !! computed by CPOTRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cpotri( uplo, n, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(inout) :: a(lda,*) end subroutine cpotri -#else - module procedure stdlib_cpotri +#else + module procedure stdlib${ii}$_cpotri #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dpotri( uplo, n, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(inout) :: a(lda,*) end subroutine dpotri -#else - module procedure stdlib_dpotri +#else + module procedure stdlib${ii}$_dpotri #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$potri - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine spotri( uplo, n, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: a(lda,*) end subroutine spotri -#else - module procedure stdlib_spotri +#else + module procedure stdlib${ii}$_spotri #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$potri - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zpotri( uplo, n, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(inout) :: a(lda,*) end subroutine zpotri -#else - module procedure stdlib_zpotri +#else + module procedure stdlib${ii}$_zpotri #endif - end interface potri +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$potri +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$potri +#:endif +#:endfor +#:endfor + end interface potri interface potrs !! POTRS solves a system of linear equations A*X = B with a Hermitian !! positive definite matrix A using the Cholesky factorization !! A = U**H*U or A = L*L**H computed by CPOTRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cpotrs( uplo, n, nrhs, a, lda, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(in) :: a(lda,*) complex(sp), intent(inout) :: b(ldb,*) end subroutine cpotrs -#else - module procedure stdlib_cpotrs +#else + module procedure stdlib${ii}$_cpotrs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dpotrs( uplo, n, nrhs, a, lda, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(in) :: a(lda,*) real(dp), intent(inout) :: b(ldb,*) end subroutine dpotrs -#else - module procedure stdlib_dpotrs +#else + module procedure stdlib${ii}$_dpotrs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$potrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine spotrs( uplo, n, nrhs, a, lda, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(in) :: a(lda,*) real(sp), intent(inout) :: b(ldb,*) end subroutine spotrs -#else - module procedure stdlib_spotrs +#else + module procedure stdlib${ii}$_spotrs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$potrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zpotrs( uplo, n, nrhs, a, lda, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(in) :: a(lda,*) complex(dp), intent(inout) :: b(ldb,*) end subroutine zpotrs -#else - module procedure stdlib_zpotrs +#else + module procedure stdlib${ii}$_zpotrs #endif - end interface potrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$potrs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$potrs +#:endif +#:endfor +#:endfor + end interface potrs interface ppcon !! PPCON estimates the reciprocal of the condition number (in the @@ -21496,77 +21414,77 @@ module stdlib_linalg_lapack !! CPPTRF. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cppcon( uplo, n, ap, anorm, rcond, work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(sp), intent(in) :: anorm real(sp), intent(out) :: rcond,rwork(*) complex(sp), intent(in) :: ap(*) complex(sp), intent(out) :: work(*) end subroutine cppcon -#else - module procedure stdlib_cppcon +#else + module procedure stdlib${ii}$_cppcon #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dppcon( uplo, n, ap, anorm, rcond, work, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: n real(dp), intent(in) :: anorm,ap(*) real(dp), intent(out) :: rcond,work(*) end subroutine dppcon -#else - module procedure stdlib_dppcon +#else + module procedure stdlib${ii}$_dppcon #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ppcon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sppcon( uplo, n, ap, anorm, rcond, work, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: n real(sp), intent(in) :: anorm,ap(*) real(sp), intent(out) :: rcond,work(*) end subroutine sppcon -#else - module procedure stdlib_sppcon +#else + module procedure stdlib${ii}$_sppcon #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ppcon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zppcon( uplo, n, ap, anorm, rcond, work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(dp), intent(in) :: anorm real(dp), intent(out) :: rcond,rwork(*) complex(dp), intent(in) :: ap(*) complex(dp), intent(out) :: work(*) end subroutine zppcon -#else - module procedure stdlib_zppcon +#else + module procedure stdlib${ii}$_zppcon #endif - end interface ppcon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ppcon +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ppcon +#:endif +#:endfor +#:endfor + end interface ppcon interface ppequ !! PPEQU computes row and column scalings intended to equilibrate a @@ -21577,156 +21495,156 @@ module stdlib_linalg_lapack !! This choice of S puts the condition number of B within a factor N of !! the smallest possible condition number over all possible diagonal !! scalings. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cppequ( uplo, n, ap, s, scond, amax, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: 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) :: amax,scond,s(*) complex(sp), intent(in) :: ap(*) end subroutine cppequ -#else - module procedure stdlib_cppequ +#else + module procedure stdlib${ii}$_cppequ #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dppequ( uplo, n, ap, s, scond, amax, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(dp), intent(out) :: amax,scond,s(*) real(dp), intent(in) :: ap(*) end subroutine dppequ -#else - module procedure stdlib_dppequ +#else + module procedure stdlib${ii}$_dppequ #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ppequ - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sppequ( uplo, n, ap, s, scond, amax, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: 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) :: amax,scond,s(*) real(sp), intent(in) :: ap(*) end subroutine sppequ -#else - module procedure stdlib_sppequ +#else + module procedure stdlib${ii}$_sppequ #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ppequ - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zppequ( uplo, n, ap, s, scond, amax, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(dp), intent(out) :: amax,scond,s(*) complex(dp), intent(in) :: ap(*) end subroutine zppequ -#else - module procedure stdlib_zppequ +#else + module procedure stdlib${ii}$_zppequ #endif - end interface ppequ +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ppequ +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ppequ +#:endif +#:endfor +#:endfor + end interface ppequ interface pprfs !! PPRFS improves the computed solution to a system of linear !! equations when the coefficient matrix is Hermitian positive definite !! and packed, and provides error bounds and backward error estimates !! for the solution. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cpprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr,berr, work, & rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,ldx,n,nrhs real(sp), intent(out) :: berr(*),ferr(*),rwork(*) complex(sp), intent(in) :: afp(*),ap(*),b(ldb,*) complex(sp), intent(out) :: work(*) complex(sp), intent(inout) :: x(ldx,*) end subroutine cpprfs -#else - module procedure stdlib_cpprfs +#else + module procedure stdlib${ii}$_cpprfs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dpprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr,berr, work, & iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldb,ldx,n,nrhs real(dp), intent(in) :: afp(*),ap(*),b(ldb,*) real(dp), intent(out) :: berr(*),ferr(*),work(*) real(dp), intent(inout) :: x(ldx,*) end subroutine dpprfs -#else - module procedure stdlib_dpprfs +#else + module procedure stdlib${ii}$_dpprfs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pprfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine spprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr,berr, work, & iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldb,ldx,n,nrhs real(sp), intent(in) :: afp(*),ap(*),b(ldb,*) real(sp), intent(out) :: berr(*),ferr(*),work(*) real(sp), intent(inout) :: x(ldx,*) end subroutine spprfs -#else - module procedure stdlib_spprfs +#else + module procedure stdlib${ii}$_spprfs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pprfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zpprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr,berr, work, & rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,ldx,n,nrhs real(dp), intent(out) :: berr(*),ferr(*),rwork(*) complex(dp), intent(in) :: afp(*),ap(*),b(ldb,*) complex(dp), intent(out) :: work(*) complex(dp), intent(inout) :: x(ldx,*) end subroutine zpprfs -#else - module procedure stdlib_zpprfs +#else + module procedure stdlib${ii}$_zpprfs #endif - end interface pprfs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pprfs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pprfs +#:endif +#:endfor +#:endfor + end interface pprfs interface ppsv !! PPSV computes the solution to a complex system of linear equations @@ -21739,69 +21657,69 @@ module stdlib_linalg_lapack !! where U is an upper triangular matrix and L is a lower triangular !! matrix. The factored form of A is then used to solve the system of !! equations A * X = B. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cppsv( uplo, n, nrhs, ap, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs complex(sp), intent(inout) :: ap(*),b(ldb,*) end subroutine cppsv -#else - module procedure stdlib_cppsv +#else + module procedure stdlib${ii}$_cppsv #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dppsv( uplo, n, nrhs, ap, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs real(dp), intent(inout) :: ap(*),b(ldb,*) end subroutine dppsv -#else - module procedure stdlib_dppsv +#else + module procedure stdlib${ii}$_dppsv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ppsv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sppsv( uplo, n, nrhs, ap, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs real(sp), intent(inout) :: ap(*),b(ldb,*) end subroutine sppsv -#else - module procedure stdlib_sppsv +#else + module procedure stdlib${ii}$_sppsv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ppsv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zppsv( uplo, n, nrhs, ap, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs complex(dp), intent(inout) :: ap(*),b(ldb,*) end subroutine zppsv -#else - module procedure stdlib_zppsv +#else + module procedure stdlib${ii}$_zppsv #endif - end interface ppsv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ppsv +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ppsv +#:endif +#:endfor +#:endfor + end interface ppsv interface pptrf !! PPTRF computes the Cholesky factorization of a complex Hermitian @@ -21810,209 +21728,209 @@ module stdlib_linalg_lapack !! A = U**H * U, if UPLO = 'U', or !! A = L * L**H, if UPLO = 'L', !! where U is an upper triangular matrix and L is lower triangular. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cpptrf( uplo, n, ap, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n complex(sp), intent(inout) :: ap(*) end subroutine cpptrf -#else - module procedure stdlib_cpptrf +#else + module procedure stdlib${ii}$_cpptrf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dpptrf( uplo, n, ap, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(dp), intent(inout) :: ap(*) end subroutine dpptrf -#else - module procedure stdlib_dpptrf +#else + module procedure stdlib${ii}$_dpptrf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pptrf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine spptrf( uplo, n, ap, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(sp), intent(inout) :: ap(*) end subroutine spptrf -#else - module procedure stdlib_spptrf +#else + module procedure stdlib${ii}$_spptrf #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pptrf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zpptrf( uplo, n, ap, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n complex(dp), intent(inout) :: ap(*) end subroutine zpptrf -#else - module procedure stdlib_zpptrf +#else + module procedure stdlib${ii}$_zpptrf #endif - end interface pptrf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pptrf +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pptrf +#:endif +#:endfor +#:endfor + end interface pptrf interface pptri !! PPTRI computes the inverse of a complex Hermitian positive definite !! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H !! computed by CPPTRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cpptri( uplo, n, ap, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n complex(sp), intent(inout) :: ap(*) end subroutine cpptri -#else - module procedure stdlib_cpptri +#else + module procedure stdlib${ii}$_cpptri #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dpptri( uplo, n, ap, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(dp), intent(inout) :: ap(*) end subroutine dpptri -#else - module procedure stdlib_dpptri +#else + module procedure stdlib${ii}$_dpptri #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pptri - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine spptri( uplo, n, ap, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(sp), intent(inout) :: ap(*) end subroutine spptri -#else - module procedure stdlib_spptri +#else + module procedure stdlib${ii}$_spptri #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pptri - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zpptri( uplo, n, ap, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n complex(dp), intent(inout) :: ap(*) end subroutine zpptri -#else - module procedure stdlib_zpptri +#else + module procedure stdlib${ii}$_zpptri #endif - end interface pptri +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pptri +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pptri +#:endif +#:endfor +#:endfor + end interface pptri interface pptrs !! PPTRS solves a system of linear equations A*X = B with a Hermitian !! positive definite matrix A in packed storage using the Cholesky !! factorization A = U**H*U or A = L*L**H computed by CPPTRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cpptrs( uplo, n, nrhs, ap, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs complex(sp), intent(in) :: ap(*) complex(sp), intent(inout) :: b(ldb,*) end subroutine cpptrs -#else - module procedure stdlib_cpptrs +#else + module procedure stdlib${ii}$_cpptrs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dpptrs( uplo, n, nrhs, ap, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs real(dp), intent(in) :: ap(*) real(dp), intent(inout) :: b(ldb,*) end subroutine dpptrs -#else - module procedure stdlib_dpptrs +#else + module procedure stdlib${ii}$_dpptrs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pptrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine spptrs( uplo, n, nrhs, ap, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs real(sp), intent(in) :: ap(*) real(sp), intent(inout) :: b(ldb,*) end subroutine spptrs -#else - module procedure stdlib_spptrs +#else + module procedure stdlib${ii}$_spptrs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pptrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zpptrs( uplo, n, nrhs, ap, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs complex(dp), intent(in) :: ap(*) complex(dp), intent(inout) :: b(ldb,*) end subroutine zpptrs -#else - module procedure stdlib_zpptrs +#else + module procedure stdlib${ii}$_zpptrs #endif - end interface pptrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pptrs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pptrs +#:endif +#:endfor +#:endfor + end interface pptrs interface pstrf !! PSTRF computes the Cholesky factorization with complete @@ -22024,77 +21942,77 @@ module stdlib_linalg_lapack !! P is stored as vector PIV. !! This algorithm does not attempt to check that A is positive !! semidefinite. This version of the algorithm calls level 3 BLAS. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cpstrf( uplo, n, a, lda, piv, rank, tol, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: tol - integer(ilp), intent(out) :: info,rank,piv(n) - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info,rank,piv(n) + integer(${ik}$), intent(in) :: lda,n character, intent(in) :: uplo complex(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: work(2*n) end subroutine cpstrf -#else - module procedure stdlib_cpstrf +#else + module procedure stdlib${ii}$_cpstrf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dpstrf( uplo, n, a, lda, piv, rank, tol, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: tol - integer(ilp), intent(out) :: info,rank,piv(n) - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info,rank,piv(n) + integer(${ik}$), intent(in) :: lda,n character, intent(in) :: uplo real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: work(2*n) end subroutine dpstrf -#else - module procedure stdlib_dpstrf +#else + module procedure stdlib${ii}$_dpstrf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pstrf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine spstrf( uplo, n, a, lda, piv, rank, tol, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: tol - integer(ilp), intent(out) :: info,rank,piv(n) - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info,rank,piv(n) + integer(${ik}$), intent(in) :: lda,n character, intent(in) :: uplo real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: work(2*n) end subroutine spstrf -#else - module procedure stdlib_spstrf +#else + module procedure stdlib${ii}$_spstrf #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pstrf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zpstrf( uplo, n, a, lda, piv, rank, tol, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: tol - integer(ilp), intent(out) :: info,rank,piv(n) - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info,rank,piv(n) + integer(${ik}$), intent(in) :: lda,n character, intent(in) :: uplo complex(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: work(2*n) end subroutine zpstrf -#else - module procedure stdlib_zpstrf +#else + module procedure stdlib${ii}$_zpstrf #endif - end interface pstrf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pstrf +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pstrf +#:endif +#:endfor +#:endfor + end interface pstrf interface ptcon !! PTCON computes the reciprocal of the condition number (in the @@ -22104,71 +22022,71 @@ module stdlib_linalg_lapack !! Norm(inv(A)) is computed by a direct method, and the reciprocal of !! the condition number is computed as !! RCOND = 1 / (ANORM * norm(inv(A))). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cptcon( n, d, e, anorm, rcond, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(sp), intent(in) :: anorm,d(*) real(sp), intent(out) :: rcond,rwork(*) complex(sp), intent(in) :: e(*) end subroutine cptcon -#else - module procedure stdlib_cptcon +#else + module procedure stdlib${ii}$_cptcon #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dptcon( n, d, e, anorm, rcond, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(dp), intent(in) :: anorm,d(*),e(*) real(dp), intent(out) :: rcond,work(*) end subroutine dptcon -#else - module procedure stdlib_dptcon +#else + module procedure stdlib${ii}$_dptcon #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ptcon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sptcon( n, d, e, anorm, rcond, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(sp), intent(in) :: anorm,d(*),e(*) real(sp), intent(out) :: rcond,work(*) end subroutine sptcon -#else - module procedure stdlib_sptcon +#else + module procedure stdlib${ii}$_sptcon #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ptcon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zptcon( n, d, e, anorm, rcond, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(dp), intent(in) :: anorm,d(*) real(dp), intent(out) :: rcond,rwork(*) complex(dp), intent(in) :: e(*) end subroutine zptcon -#else - module procedure stdlib_zptcon +#else + module procedure stdlib${ii}$_zptcon #endif - end interface ptcon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ptcon +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ptcon +#:endif +#:endfor +#:endfor + end interface ptcon interface pteqr !! PTEQR computes all eigenvalues and, optionally, eigenvectors of a @@ -22186,158 +22104,158 @@ module stdlib_linalg_lapack !! tridiagonal form, however, may preclude the possibility of obtaining !! high relative accuracy in the small eigenvalues of the original !! matrix, if these eigenvalues range over many orders of magnitude.) -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cpteqr( compz, n, d, e, z, ldz, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldz,n real(sp), intent(inout) :: d(*),e(*) real(sp), intent(out) :: work(*) complex(sp), intent(inout) :: z(ldz,*) end subroutine cpteqr -#else - module procedure stdlib_cpteqr +#else + module procedure stdlib${ii}$_cpteqr #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dpteqr( compz, n, d, e, z, ldz, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldz,n real(dp), intent(inout) :: d(*),e(*),z(ldz,*) real(dp), intent(out) :: work(*) end subroutine dpteqr -#else - module procedure stdlib_dpteqr +#else + module procedure stdlib${ii}$_dpteqr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pteqr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine spteqr( compz, n, d, e, z, ldz, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldz,n real(sp), intent(inout) :: d(*),e(*),z(ldz,*) real(sp), intent(out) :: work(*) end subroutine spteqr -#else - module procedure stdlib_spteqr +#else + module procedure stdlib${ii}$_spteqr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pteqr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zpteqr( compz, n, d, e, z, ldz, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldz,n real(dp), intent(inout) :: d(*),e(*) real(dp), intent(out) :: work(*) complex(dp), intent(inout) :: z(ldz,*) end subroutine zpteqr -#else - module procedure stdlib_zpteqr +#else + module procedure stdlib${ii}$_zpteqr #endif - end interface pteqr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pteqr +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pteqr +#:endif +#:endfor +#:endfor + end interface pteqr interface ptrfs !! PTRFS improves the computed solution to a system of linear !! equations when the coefficient matrix is Hermitian positive definite !! and tridiagonal, and provides error bounds and backward error !! estimates for the solution. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cptrfs( uplo, n, nrhs, d, e, df, ef, b, ldb, x, ldx,ferr, berr, & work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,ldx,n,nrhs real(sp), intent(out) :: berr(*),ferr(*),rwork(*) real(sp), intent(in) :: d(*),df(*) complex(sp), intent(in) :: b(ldb,*),e(*),ef(*) complex(sp), intent(out) :: work(*) complex(sp), intent(inout) :: x(ldx,*) end subroutine cptrfs -#else - module procedure stdlib_cptrfs +#else + module procedure stdlib${ii}$_cptrfs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dptrfs( n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr,berr, work, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,ldx,n,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,ldx,n,nrhs real(dp), intent(in) :: b(ldb,*),d(*),df(*),e(*),ef(*) real(dp), intent(out) :: berr(*),ferr(*),work(*) real(dp), intent(inout) :: x(ldx,*) end subroutine dptrfs -#else - module procedure stdlib_dptrfs +#else + module procedure stdlib${ii}$_dptrfs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ptrfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sptrfs( n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr,berr, work, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,ldx,n,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,ldx,n,nrhs real(sp), intent(in) :: b(ldb,*),d(*),df(*),e(*),ef(*) real(sp), intent(out) :: berr(*),ferr(*),work(*) real(sp), intent(inout) :: x(ldx,*) end subroutine sptrfs -#else - module procedure stdlib_sptrfs +#else + module procedure stdlib${ii}$_sptrfs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ptrfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zptrfs( uplo, n, nrhs, d, e, df, ef, b, ldb, x, ldx,ferr, berr, & work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,ldx,n,nrhs real(dp), intent(out) :: berr(*),ferr(*),rwork(*) real(dp), intent(in) :: d(*),df(*) complex(dp), intent(in) :: b(ldb,*),e(*),ef(*) complex(dp), intent(out) :: work(*) complex(dp), intent(inout) :: x(ldx,*) end subroutine zptrfs -#else - module procedure stdlib_zptrfs +#else + module procedure stdlib${ii}$_zptrfs #endif - end interface ptrfs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ptrfs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ptrfs +#:endif +#:endfor +#:endfor + end interface ptrfs interface ptsv !! PTSV computes the solution to a complex system of linear equations @@ -22345,133 +22263,133 @@ module stdlib_linalg_lapack !! matrix, and X and B are N-by-NRHS matrices. !! A is factored as A = L*D*L**H, and the factored form of A is then !! used to solve the system of equations. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cptsv( n, nrhs, d, e, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs real(sp), intent(inout) :: d(*) complex(sp), intent(inout) :: b(ldb,*),e(*) end subroutine cptsv -#else - module procedure stdlib_cptsv +#else + module procedure stdlib${ii}$_cptsv #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dptsv( n, nrhs, d, e, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs real(dp), intent(inout) :: b(ldb,*),d(*),e(*) end subroutine dptsv -#else - module procedure stdlib_dptsv +#else + module procedure stdlib${ii}$_dptsv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ptsv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sptsv( n, nrhs, d, e, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs real(sp), intent(inout) :: b(ldb,*),d(*),e(*) end subroutine sptsv -#else - module procedure stdlib_sptsv +#else + module procedure stdlib${ii}$_sptsv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ptsv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zptsv( n, nrhs, d, e, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs real(dp), intent(inout) :: d(*) complex(dp), intent(inout) :: b(ldb,*),e(*) end subroutine zptsv -#else - module procedure stdlib_zptsv +#else + module procedure stdlib${ii}$_zptsv #endif - end interface ptsv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ptsv +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ptsv +#:endif +#:endfor +#:endfor + end interface ptsv interface pttrf !! PTTRF computes the L*D*L**H factorization of a complex Hermitian !! positive definite tridiagonal matrix A. The factorization may also !! be regarded as having the form A = U**H *D*U. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cpttrf( n, d, e, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(sp), intent(inout) :: d(*) complex(sp), intent(inout) :: e(*) end subroutine cpttrf -#else - module procedure stdlib_cpttrf +#else + module procedure stdlib${ii}$_cpttrf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dpttrf( n, d, e, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(dp), intent(inout) :: d(*),e(*) end subroutine dpttrf -#else - module procedure stdlib_dpttrf +#else + module procedure stdlib${ii}$_dpttrf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pttrf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine spttrf( n, d, e, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(sp), intent(inout) :: d(*),e(*) end subroutine spttrf -#else - module procedure stdlib_spttrf +#else + module procedure stdlib${ii}$_spttrf #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pttrf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zpttrf( n, d, e, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(dp), intent(inout) :: d(*) complex(dp), intent(inout) :: e(*) end subroutine zpttrf -#else - module procedure stdlib_zpttrf +#else + module procedure stdlib${ii}$_zpttrf #endif - end interface pttrf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pttrf +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pttrf +#:endif +#:endfor +#:endfor + end interface pttrf interface pttrs !! PTTRS solves a tridiagonal system of the form @@ -22480,226 +22398,226 @@ module stdlib_linalg_lapack !! D is a diagonal matrix specified in the vector D, U (or L) is a unit !! bidiagonal matrix whose superdiagonal (subdiagonal) is specified in !! the vector E, and X and B are N by NRHS matrices. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cpttrs( uplo, n, nrhs, d, e, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs real(sp), intent(in) :: d(*) complex(sp), intent(inout) :: b(ldb,*) complex(sp), intent(in) :: e(*) end subroutine cpttrs -#else - module procedure stdlib_cpttrs +#else + module procedure stdlib${ii}$_cpttrs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dpttrs( n, nrhs, d, e, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs real(dp), intent(inout) :: b(ldb,*) real(dp), intent(in) :: d(*),e(*) end subroutine dpttrs -#else - module procedure stdlib_dpttrs +#else + module procedure stdlib${ii}$_dpttrs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pttrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine spttrs( n, nrhs, d, e, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs real(sp), intent(inout) :: b(ldb,*) real(sp), intent(in) :: d(*),e(*) end subroutine spttrs -#else - module procedure stdlib_spttrs +#else + module procedure stdlib${ii}$_spttrs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$pttrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zpttrs( uplo, n, nrhs, d, e, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs real(dp), intent(in) :: d(*) complex(dp), intent(inout) :: b(ldb,*) complex(dp), intent(in) :: e(*) end subroutine zpttrs -#else - module procedure stdlib_zpttrs +#else + module procedure stdlib${ii}$_zpttrs #endif +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pttrs + +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$pttrs + +#:endif +#:endfor +#:endfor end interface pttrs - - interface rot !! ROT applies a plane rotation, where the cos (C) is real and the !! sin (S) is complex, and the vectors CX and CY are complex. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine crot( n, cx, incx, cy, incy, c, s ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n real(sp), intent(in) :: c complex(sp), intent(in) :: s complex(sp), intent(inout) :: cx(*),cy(*) end subroutine crot -#else - module procedure stdlib_crot +#else + module procedure stdlib${ii}$_crot #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$rot - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zrot( n, cx, incx, cy, incy, c, s ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,incy,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,incy,n real(dp), intent(in) :: c complex(dp), intent(in) :: s complex(dp), intent(inout) :: cx(*),cy(*) end subroutine zrot -#else - module procedure stdlib_zrot +#else + module procedure stdlib${ii}$_zrot #endif - end interface rot - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$rot +#:endif +#:endfor +#:endfor + end interface rot interface rscl !! RSCL multiplies an n-element real vector x by the real scalar 1/a. !! This is done without overflow or underflow as long as !! the final result x/a does not overflow or underflow. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine drscl( n, sa, sx, incx ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n real(dp), intent(in) :: sa real(dp), intent(inout) :: sx(*) end subroutine drscl -#else - module procedure stdlib_drscl +#else + module procedure stdlib${ii}$_drscl #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$rscl - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine srscl( n, sa, sx, incx ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx,n real(sp), intent(in) :: sa real(sp), intent(inout) :: sx(*) end subroutine srscl -#else - module procedure stdlib_srscl +#else + module procedure stdlib${ii}$_srscl #endif - end interface rscl - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$rscl +#:endif +#:endfor +#:endfor + end interface rscl interface sb2st_kernels !! SB2ST_KERNELS is an internal routine used by the DSYTRD_SB2ST !! subroutine. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsb2st_kernels( uplo, wantz, ttype,st, ed, sweep, n, nb, ib,a, & lda, v, tau, ldvt, work) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo logical(lk), intent(in) :: wantz - integer(ilp), intent(in) :: ttype,st,ed,sweep,n,nb,ib,lda,ldvt + integer(${ik}$), intent(in) :: ttype,st,ed,sweep,n,nb,ib,lda,ldvt real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: v(*),tau(*),work(*) end subroutine dsb2st_kernels -#else - module procedure stdlib_dsb2st_kernels +#else + module procedure stdlib${ii}$_dsb2st_kernels #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sb2st_kernels - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssb2st_kernels( uplo, wantz, ttype,st, ed, sweep, n, nb, ib,a, & lda, v, tau, ldvt, work) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo logical(lk), intent(in) :: wantz - integer(ilp), intent(in) :: ttype,st,ed,sweep,n,nb,ib,lda,ldvt + integer(${ik}$), intent(in) :: ttype,st,ed,sweep,n,nb,ib,lda,ldvt real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: v(*),tau(*),work(*) end subroutine ssb2st_kernels -#else - module procedure stdlib_ssb2st_kernels +#else + module procedure stdlib${ii}$_ssb2st_kernels #endif - end interface sb2st_kernels - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sb2st_kernels +#:endif +#:endfor +#:endfor + end interface sb2st_kernels interface sbev !! SBEV computes all the eigenvalues and, optionally, eigenvectors of !! a real symmetric band matrix A. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dsbev( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kd,ldab,ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kd,ldab,ldz,n real(dp), intent(inout) :: ab(ldab,*) real(dp), intent(out) :: w(*),work(*),z(ldz,*) end subroutine dsbev -#else - module procedure stdlib_dsbev +#else + module procedure stdlib${ii}$_dsbev #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sbev - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine ssbev( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kd,ldab,ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kd,ldab,ldz,n real(sp), intent(inout) :: ab(ldab,*) real(sp), intent(out) :: w(*),work(*),z(ldz,*) end subroutine ssbev -#else - module procedure stdlib_ssbev +#else + module procedure stdlib${ii}$_ssbev #endif - end interface sbev - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sbev +#:endif +#:endfor +#:endfor + end interface sbev interface sbevd !! SBEVD computes all the eigenvalues and, optionally, eigenvectors of @@ -22711,43 +22629,43 @@ module stdlib_linalg_lapack !! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or !! Cray-2. It could conceivably fail on hexadecimal or decimal machines !! without guard digits, but we know of none. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dsbevd( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,lwork, iwork, & liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: kd,ldab,ldz,liwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: kd,ldab,ldz,liwork,lwork,n real(dp), intent(inout) :: ab(ldab,*) real(dp), intent(out) :: w(*),work(*),z(ldz,*) end subroutine dsbevd -#else - module procedure stdlib_dsbevd +#else + module procedure stdlib${ii}$_dsbevd #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sbevd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine ssbevd( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,lwork, iwork, & liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: kd,ldab,ldz,liwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: kd,ldab,ldz,liwork,lwork,n real(sp), intent(inout) :: ab(ldab,*) real(sp), intent(out) :: w(*),work(*),z(ldz,*) end subroutine ssbevd -#else - module procedure stdlib_ssbevd +#else + module procedure stdlib${ii}$_ssbevd #endif - end interface sbevd - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sbevd +#:endif +#:endfor +#:endfor + end interface sbevd interface sbgst !! SBGST reduces a real symmetric-definite banded generalized @@ -22757,88 +22675,88 @@ module stdlib_linalg_lapack !! split Cholesky factorization. A is overwritten by C = X**T*A*X, where !! X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the !! bandwidth of A. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsbgst( vect, uplo, n, ka, kb, ab, ldab, bb, ldbb, x,ldx, work, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo,vect - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ka,kb,ldab,ldbb,ldx,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ka,kb,ldab,ldbb,ldx,n real(dp), intent(inout) :: ab(ldab,*) real(dp), intent(in) :: bb(ldbb,*) real(dp), intent(out) :: work(*),x(ldx,*) end subroutine dsbgst -#else - module procedure stdlib_dsbgst +#else + module procedure stdlib${ii}$_dsbgst #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sbgst - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssbgst( vect, uplo, n, ka, kb, ab, ldab, bb, ldbb, x,ldx, work, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo,vect - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ka,kb,ldab,ldbb,ldx,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ka,kb,ldab,ldbb,ldx,n real(sp), intent(inout) :: ab(ldab,*) real(sp), intent(in) :: bb(ldbb,*) real(sp), intent(out) :: work(*),x(ldx,*) end subroutine ssbgst -#else - module procedure stdlib_ssbgst +#else + module procedure stdlib${ii}$_ssbgst #endif - end interface sbgst - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sbgst +#:endif +#:endfor +#:endfor + end interface sbgst interface sbgv !! SBGV computes all the eigenvalues, and optionally, the eigenvectors !! of a real generalized symmetric-definite banded eigenproblem, of !! the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric !! and banded, and B is also positive definite. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsbgv( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z,ldz, work, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ka,kb,ldab,ldbb,ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ka,kb,ldab,ldbb,ldz,n real(dp), intent(inout) :: ab(ldab,*),bb(ldbb,*) real(dp), intent(out) :: w(*),work(*),z(ldz,*) end subroutine dsbgv -#else - module procedure stdlib_dsbgv +#else + module procedure stdlib${ii}$_dsbgv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sbgv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssbgv( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z,ldz, work, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ka,kb,ldab,ldbb,ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ka,kb,ldab,ldbb,ldz,n real(sp), intent(inout) :: ab(ldab,*),bb(ldbb,*) real(sp), intent(out) :: w(*),work(*),z(ldz,*) end subroutine ssbgv -#else - module procedure stdlib_ssbgv +#else + module procedure stdlib${ii}$_ssbgv #endif - end interface sbgv - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sbgv +#:endif +#:endfor +#:endfor + end interface sbgv interface sbgvd !! SBGVD computes all the eigenvalues, and optionally, the eigenvectors @@ -22852,85 +22770,85 @@ module stdlib_linalg_lapack !! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or !! Cray-2. It could conceivably fail on hexadecimal or decimal machines !! without guard digits, but we know of none. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsbgvd( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w,z, ldz, work, & lwork, iwork, liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ka,kb,ldab,ldbb,ldz,liwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ka,kb,ldab,ldbb,ldz,liwork,lwork,n real(dp), intent(inout) :: ab(ldab,*),bb(ldbb,*) real(dp), intent(out) :: w(*),work(*),z(ldz,*) end subroutine dsbgvd -#else - module procedure stdlib_dsbgvd +#else + module procedure stdlib${ii}$_dsbgvd #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sbgvd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssbgvd( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w,z, ldz, work, & lwork, iwork, liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ka,kb,ldab,ldbb,ldz,liwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ka,kb,ldab,ldbb,ldz,liwork,lwork,n real(sp), intent(inout) :: ab(ldab,*),bb(ldbb,*) real(sp), intent(out) :: w(*),work(*),z(ldz,*) end subroutine ssbgvd -#else - module procedure stdlib_ssbgvd +#else + module procedure stdlib${ii}$_ssbgvd #endif - end interface sbgvd - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sbgvd +#:endif +#:endfor +#:endfor + end interface sbgvd interface sbtrd !! SBTRD reduces a real symmetric band matrix A to symmetric !! tridiagonal form T by an orthogonal similarity transformation: !! Q**T * A * Q = T. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsbtrd( vect, uplo, n, kd, ab, ldab, d, e, q, ldq,work, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(inout) :: ab(ldab,*),q(ldq,*) real(dp), intent(out) :: d(*),e(*),work(*) end subroutine dsbtrd -#else - module procedure stdlib_dsbtrd +#else + module procedure stdlib${ii}$_dsbtrd #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sbtrd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssbtrd( vect, uplo, n, kd, ab, ldab, d, e, q, ldq,work, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: ab(ldab,*),q(ldq,*) real(sp), intent(out) :: d(*),e(*),work(*) end subroutine ssbtrd -#else - module procedure stdlib_ssbtrd +#else + module procedure stdlib${ii}$_ssbtrd #endif - end interface sbtrd - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sbtrd +#:endif +#:endfor +#:endfor + end interface sbtrd interface sfrk !! Level 3 BLAS like routine for C in RFP Format. @@ -22941,39 +22859,39 @@ module stdlib_linalg_lapack !! where alpha and beta are real scalars, C is an n--by--n symmetric !! matrix and A is an n--by--k matrix in the first case and a k--by--n !! matrix in the second case. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsfrk( transr, uplo, trans, n, k, alpha, a, lda, beta,c ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(dp), intent(in) :: alpha,beta,a(lda,*) - integer(ilp), intent(in) :: k,lda,n + integer(${ik}$), intent(in) :: k,lda,n character, intent(in) :: trans,transr,uplo real(dp), intent(inout) :: c(*) end subroutine dsfrk -#else - module procedure stdlib_dsfrk +#else + module procedure stdlib${ii}$_dsfrk #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sfrk - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssfrk( transr, uplo, trans, n, k, alpha, a, lda, beta,c ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) real(sp), intent(in) :: alpha,beta,a(lda,*) - integer(ilp), intent(in) :: k,lda,n + integer(${ik}$), intent(in) :: k,lda,n character, intent(in) :: trans,transr,uplo real(sp), intent(inout) :: c(*) end subroutine ssfrk -#else - module procedure stdlib_ssfrk +#else + module procedure stdlib${ii}$_ssfrk #endif - end interface sfrk - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sfrk +#:endif +#:endfor +#:endfor + end interface sfrk interface spcon !! SPCON estimates the reciprocal of the condition number (in the @@ -22981,116 +22899,116 @@ module stdlib_linalg_lapack !! factorization A = U*D*U**T or A = L*D*L**T computed by CSPTRF. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cspcon( uplo, n, ap, ipiv, anorm, rcond, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n,ipiv(*) real(sp), intent(in) :: anorm real(sp), intent(out) :: rcond complex(sp), intent(in) :: ap(*) complex(sp), intent(out) :: work(*) end subroutine cspcon -#else - module procedure stdlib_cspcon +#else + module procedure stdlib${ii}$_cspcon #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dspcon( uplo, n, ap, ipiv, anorm, rcond, work, iwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: n,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: n,ipiv(*) real(dp), intent(in) :: anorm,ap(*) real(dp), intent(out) :: rcond,work(*) end subroutine dspcon -#else - module procedure stdlib_dspcon +#else + module procedure stdlib${ii}$_dspcon #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$spcon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sspcon( uplo, n, ap, ipiv, anorm, rcond, work, iwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: n,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: n,ipiv(*) real(sp), intent(in) :: anorm,ap(*) real(sp), intent(out) :: rcond,work(*) end subroutine sspcon -#else - module procedure stdlib_sspcon +#else + module procedure stdlib${ii}$_sspcon #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$spcon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zspcon( uplo, n, ap, ipiv, anorm, rcond, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n,ipiv(*) real(dp), intent(in) :: anorm real(dp), intent(out) :: rcond complex(dp), intent(in) :: ap(*) complex(dp), intent(out) :: work(*) end subroutine zspcon -#else - module procedure stdlib_zspcon +#else + module procedure stdlib${ii}$_zspcon #endif - end interface spcon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$spcon +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$spcon +#:endif +#:endfor +#:endfor + end interface spcon interface spev !! SPEV computes all the eigenvalues and, optionally, eigenvectors of a !! real symmetric matrix A in packed storage. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dspev( jobz, uplo, n, ap, w, z, ldz, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldz,n real(dp), intent(inout) :: ap(*) real(dp), intent(out) :: w(*),work(*),z(ldz,*) end subroutine dspev -#else - module procedure stdlib_dspev +#else + module procedure stdlib${ii}$_dspev #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$spev - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sspev( jobz, uplo, n, ap, w, z, ldz, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldz,n real(sp), intent(inout) :: ap(*) real(sp), intent(out) :: w(*),work(*),z(ldz,*) end subroutine sspev -#else - module procedure stdlib_sspev +#else + module procedure stdlib${ii}$_sspev #endif - end interface spev - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$spev +#:endif +#:endfor +#:endfor + end interface spev interface spevd !! SPEVD computes all the eigenvalues and, optionally, eigenvectors @@ -23102,43 +23020,43 @@ module stdlib_linalg_lapack !! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or !! Cray-2. It could conceivably fail on hexadecimal or decimal machines !! without guard digits, but we know of none. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dspevd( jobz, uplo, n, ap, w, z, ldz, work, lwork,iwork, liwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldz,liwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldz,liwork,lwork,n real(dp), intent(inout) :: ap(*) real(dp), intent(out) :: w(*),work(*),z(ldz,*) end subroutine dspevd -#else - module procedure stdlib_dspevd +#else + module procedure stdlib${ii}$_dspevd #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$spevd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sspevd( jobz, uplo, n, ap, w, z, ldz, work, lwork,iwork, liwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldz,liwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldz,liwork,lwork,n real(sp), intent(inout) :: ap(*) real(sp), intent(out) :: w(*),work(*),z(ldz,*) end subroutine sspevd -#else - module procedure stdlib_sspevd +#else + module procedure stdlib${ii}$_sspevd #endif - end interface spevd - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$spevd +#:endif +#:endfor +#:endfor + end interface spevd interface spgst !! SPGST reduces a real symmetric-definite generalized eigenproblem @@ -23148,41 +23066,41 @@ module stdlib_linalg_lapack !! If ITYPE = 2 or 3, 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 DPPTRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dspgst( itype, uplo, n, ap, bp, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: itype,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: itype,n real(dp), intent(inout) :: ap(*) real(dp), intent(in) :: bp(*) end subroutine dspgst -#else - module procedure stdlib_dspgst +#else + module procedure stdlib${ii}$_dspgst #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$spgst - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sspgst( itype, uplo, n, ap, bp, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: itype,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: itype,n real(sp), intent(inout) :: ap(*) real(sp), intent(in) :: bp(*) end subroutine sspgst -#else - module procedure stdlib_sspgst +#else + module procedure stdlib${ii}$_sspgst #endif - end interface spgst - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$spgst +#:endif +#:endfor +#:endfor + end interface spgst interface spgv !! SPGV computes all the eigenvalues and, optionally, the eigenvectors @@ -23190,41 +23108,41 @@ module stdlib_linalg_lapack !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. !! Here A and B are assumed to be symmetric, stored in packed format, !! and B is also positive definite. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dspgv( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: itype,ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: itype,ldz,n real(dp), intent(inout) :: ap(*),bp(*) real(dp), intent(out) :: w(*),work(*),z(ldz,*) end subroutine dspgv -#else - module procedure stdlib_dspgv +#else + module procedure stdlib${ii}$_dspgv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$spgv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sspgv( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: itype,ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: itype,ldz,n real(sp), intent(inout) :: ap(*),bp(*) real(sp), intent(out) :: w(*),work(*),z(ldz,*) end subroutine sspgv -#else - module procedure stdlib_sspgv +#else + module procedure stdlib${ii}$_sspgv #endif - end interface spgv - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$spgv +#:endif +#:endfor +#:endfor + end interface spgv interface spgvd !! SPGVD computes all the eigenvalues, and optionally, the eigenvectors @@ -23239,204 +23157,204 @@ module stdlib_linalg_lapack !! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or !! Cray-2. It could conceivably fail on hexadecimal or decimal machines !! without guard digits, but we know of none. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dspgvd( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,lwork, iwork, & liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: itype,ldz,liwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: itype,ldz,liwork,lwork,n real(dp), intent(inout) :: ap(*),bp(*) real(dp), intent(out) :: w(*),work(*),z(ldz,*) end subroutine dspgvd -#else - module procedure stdlib_dspgvd +#else + module procedure stdlib${ii}$_dspgvd #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$spgvd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine sspgvd( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,lwork, iwork, & liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: itype,ldz,liwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: itype,ldz,liwork,lwork,n real(sp), intent(inout) :: ap(*),bp(*) real(sp), intent(out) :: w(*),work(*),z(ldz,*) end subroutine sspgvd -#else - module procedure stdlib_sspgvd +#else + module procedure stdlib${ii}$_sspgvd #endif - end interface spgvd - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$spgvd +#:endif +#:endfor +#:endfor + end interface spgvd interface spmv !! SPMV 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 !! A is an n by n symmetric matrix, supplied in packed form. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cspmv( uplo, n, alpha, ap, x, incx, beta, y, incy ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: incx,incy,n + integer(${ik}$), intent(in) :: incx,incy,n complex(sp), intent(in) :: alpha,beta,ap(*),x(*) complex(sp), intent(inout) :: y(*) end subroutine cspmv -#else - module procedure stdlib_cspmv +#else + module procedure stdlib${ii}$_cspmv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$spmv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zspmv( uplo, n, alpha, ap, x, incx, beta, y, incy ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: incx,incy,n + integer(${ik}$), intent(in) :: incx,incy,n complex(dp), intent(in) :: alpha,beta,ap(*),x(*) complex(dp), intent(inout) :: y(*) end subroutine zspmv -#else - module procedure stdlib_zspmv +#else + module procedure stdlib${ii}$_zspmv #endif - end interface spmv - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$spmv +#:endif +#:endfor +#:endfor + end interface spmv interface spr !! SPR performs the symmetric rank 1 operation !! A := alpha*x*x**H + A, !! where alpha is a complex scalar, x is an n element vector and A is an !! n by n symmetric matrix, supplied in packed form. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cspr( uplo, n, alpha, x, incx, ap ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: incx,n + integer(${ik}$), intent(in) :: incx,n complex(sp), intent(in) :: alpha,x(*) complex(sp), intent(inout) :: ap(*) end subroutine cspr -#else - module procedure stdlib_cspr +#else + module procedure stdlib${ii}$_cspr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$spr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zspr( uplo, n, alpha, x, incx, ap ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: incx,n + integer(${ik}$), intent(in) :: incx,n complex(dp), intent(in) :: alpha,x(*) complex(dp), intent(inout) :: ap(*) end subroutine zspr -#else - module procedure stdlib_zspr +#else + module procedure stdlib${ii}$_zspr #endif - end interface spr - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$spr +#:endif +#:endfor +#:endfor + end interface spr interface sprfs !! SPRFS improves the computed solution to a system of linear !! equations when the coefficient matrix is symmetric indefinite !! and packed, and provides error bounds and backward error estimates !! for the solution. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, & work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,ldx,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,ldx,n,nrhs,ipiv(*) real(sp), intent(out) :: berr(*),ferr(*),rwork(*) complex(sp), intent(in) :: afp(*),ap(*),b(ldb,*) complex(sp), intent(out) :: work(*) complex(sp), intent(inout) :: x(ldx,*) end subroutine csprfs -#else - module procedure stdlib_csprfs +#else + module procedure stdlib${ii}$_csprfs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, & work, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldb,ldx,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldb,ldx,n,nrhs,ipiv(*) real(dp), intent(in) :: afp(*),ap(*),b(ldb,*) real(dp), intent(out) :: berr(*),ferr(*),work(*) - real(dp), intent(inout) :: x(ldx,*) - end subroutine dsprfs -#else - module procedure stdlib_dsprfs -#endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sprfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK + real(dp), intent(inout) :: x(ldx,*) + end subroutine dsprfs +#else + module procedure stdlib${ii}$_dsprfs +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, & work, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldb,ldx,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldb,ldx,n,nrhs,ipiv(*) real(sp), intent(in) :: afp(*),ap(*),b(ldb,*) real(sp), intent(out) :: berr(*),ferr(*),work(*) real(sp), intent(inout) :: x(ldx,*) end subroutine ssprfs -#else - module procedure stdlib_ssprfs +#else + module procedure stdlib${ii}$_ssprfs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sprfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, & work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,ldx,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,ldx,n,nrhs,ipiv(*) real(dp), intent(out) :: berr(*),ferr(*),rwork(*) complex(dp), intent(in) :: afp(*),ap(*),b(ldb,*) complex(dp), intent(out) :: work(*) complex(dp), intent(inout) :: x(ldx,*) end subroutine zsprfs -#else - module procedure stdlib_zsprfs +#else + module procedure stdlib${ii}$_zsprfs #endif - end interface sprfs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sprfs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sprfs +#:endif +#:endfor +#:endfor + end interface sprfs interface spsv !! SPSV computes the solution to a complex system of linear equations @@ -23450,109 +23368,109 @@ module stdlib_linalg_lapack !! triangular matrices, D is symmetric and block diagonal with 1-by-1 !! and 2-by-2 diagonal blocks. The factored form of A is then used to !! solve the system of equations A * X = B. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cspsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: ldb,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: ldb,n,nrhs complex(sp), intent(inout) :: ap(*),b(ldb,*) end subroutine cspsv -#else - module procedure stdlib_cspsv +#else + module procedure stdlib${ii}$_cspsv #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dspsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: ldb,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: ldb,n,nrhs real(dp), intent(inout) :: ap(*),b(ldb,*) end subroutine dspsv -#else - module procedure stdlib_dspsv +#else + module procedure stdlib${ii}$_dspsv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$spsv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sspsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: ldb,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: ldb,n,nrhs real(sp), intent(inout) :: ap(*),b(ldb,*) end subroutine sspsv -#else - module procedure stdlib_sspsv +#else + module procedure stdlib${ii}$_sspsv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$spsv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zspsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: ldb,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: ldb,n,nrhs complex(dp), intent(inout) :: ap(*),b(ldb,*) end subroutine zspsv -#else - module procedure stdlib_zspsv +#else + module procedure stdlib${ii}$_zspsv #endif - end interface spsv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$spsv +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$spsv +#:endif +#:endfor +#:endfor + end interface spsv interface sptrd !! SPTRD reduces a real symmetric matrix A stored in packed form to !! symmetric tridiagonal form T by an orthogonal similarity !! transformation: Q**T * A * Q = T. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsptrd( uplo, n, ap, d, e, tau, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(dp), intent(inout) :: ap(*) real(dp), intent(out) :: d(*),e(*),tau(*) end subroutine dsptrd -#else - module procedure stdlib_dsptrd +#else + module procedure stdlib${ii}$_dsptrd #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sptrd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssptrd( uplo, n, ap, d, e, tau, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(sp), intent(inout) :: ap(*) real(sp), intent(out) :: d(*),e(*),tau(*) end subroutine ssptrd -#else - module procedure stdlib_ssptrd +#else + module procedure stdlib${ii}$_ssptrd #endif - end interface sptrd - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sptrd +#:endif +#:endfor +#:endfor + end interface sptrd interface sptrf !! SPTRF computes the factorization of a complex symmetric matrix A @@ -23562,213 +23480,213 @@ module stdlib_linalg_lapack !! 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. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csptrf( uplo, n, ap, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: n complex(sp), intent(inout) :: ap(*) end subroutine csptrf -#else - module procedure stdlib_csptrf +#else + module procedure stdlib${ii}$_csptrf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsptrf( uplo, n, ap, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: n real(dp), intent(inout) :: ap(*) end subroutine dsptrf -#else - module procedure stdlib_dsptrf +#else + module procedure stdlib${ii}$_dsptrf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sptrf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssptrf( uplo, n, ap, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: n real(sp), intent(inout) :: ap(*) end subroutine ssptrf -#else - module procedure stdlib_ssptrf +#else + module procedure stdlib${ii}$_ssptrf #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sptrf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsptrf( uplo, n, ap, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: n complex(dp), intent(inout) :: ap(*) end subroutine zsptrf -#else - module procedure stdlib_zsptrf +#else + module procedure stdlib${ii}$_zsptrf #endif - end interface sptrf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sptrf +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sptrf +#:endif +#:endfor +#:endfor + end interface sptrf interface sptri !! SPTRI computes the inverse of a complex symmetric indefinite matrix !! A in packed storage using the factorization A = U*D*U**T or !! A = L*D*L**T computed by CSPTRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csptri( uplo, n, ap, ipiv, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n,ipiv(*) complex(sp), intent(inout) :: ap(*) complex(sp), intent(out) :: work(*) end subroutine csptri -#else - module procedure stdlib_csptri +#else + module procedure stdlib${ii}$_csptri #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsptri( uplo, n, ap, ipiv, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n,ipiv(*) real(dp), intent(inout) :: ap(*) real(dp), intent(out) :: work(*) end subroutine dsptri -#else - module procedure stdlib_dsptri +#else + module procedure stdlib${ii}$_dsptri #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sptri - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssptri( uplo, n, ap, ipiv, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n,ipiv(*) real(sp), intent(inout) :: ap(*) real(sp), intent(out) :: work(*) end subroutine ssptri -#else - module procedure stdlib_ssptri +#else + module procedure stdlib${ii}$_ssptri #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sptri - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsptri( uplo, n, ap, ipiv, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n,ipiv(*) complex(dp), intent(inout) :: ap(*) complex(dp), intent(out) :: work(*) end subroutine zsptri -#else - module procedure stdlib_zsptri +#else + module procedure stdlib${ii}$_zsptri #endif - end interface sptri +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sptri +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sptri +#:endif +#:endfor +#:endfor + end interface sptri interface sptrs !! SPTRS solves a system of linear equations A*X = B with a complex !! symmetric matrix A stored in packed format using the factorization !! A = U*D*U**T or A = L*D*L**T computed by CSPTRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs,ipiv(*) complex(sp), intent(in) :: ap(*) complex(sp), intent(inout) :: b(ldb,*) end subroutine csptrs -#else - module procedure stdlib_csptrs +#else + module procedure stdlib${ii}$_csptrs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs,ipiv(*) real(dp), intent(in) :: ap(*) real(dp), intent(inout) :: b(ldb,*) end subroutine dsptrs -#else - module procedure stdlib_dsptrs +#else + module procedure stdlib${ii}$_dsptrs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sptrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs,ipiv(*) real(sp), intent(in) :: ap(*) real(sp), intent(inout) :: b(ldb,*) end subroutine ssptrs -#else - module procedure stdlib_ssptrs +#else + module procedure stdlib${ii}$_ssptrs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sptrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs,ipiv(*) complex(dp), intent(in) :: ap(*) complex(dp), intent(inout) :: b(ldb,*) end subroutine zsptrs -#else - module procedure stdlib_zsptrs +#else + module procedure stdlib${ii}$_zsptrs #endif - end interface sptrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sptrs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sptrs +#:endif +#:endfor +#:endfor + end interface sptrs interface stebz !! STEBZ computes the eigenvalues of a symmetric tridiagonal @@ -23781,45 +23699,45 @@ module stdlib_linalg_lapack !! See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal !! Matrix", Report CS41, Computer Science Dept., Stanford !! University, July 21, 1966. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dstebz( range, order, n, vl, vu, il, iu, abstol, d, e,m, nsplit, w,& iblock, isplit, work, iwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: order,range - integer(ilp), intent(in) :: il,iu,n - integer(ilp), intent(out) :: info,m,nsplit,iblock(*),isplit(*),iwork(*) - + integer(${ik}$), intent(in) :: il,iu,n + integer(${ik}$), intent(out) :: info,m,nsplit,iblock(*),isplit(*),iwork(*) + real(dp), intent(in) :: abstol,vl,vu,d(*),e(*) real(dp), intent(out) :: w(*),work(*) end subroutine dstebz -#else - module procedure stdlib_dstebz +#else + module procedure stdlib${ii}$_dstebz #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$stebz - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sstebz( range, order, n, vl, vu, il, iu, abstol, d, e,m, nsplit, w,& iblock, isplit, work, iwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: order,range - integer(ilp), intent(in) :: il,iu,n - integer(ilp), intent(out) :: info,m,nsplit,iblock(*),isplit(*),iwork(*) - + integer(${ik}$), intent(in) :: il,iu,n + integer(${ik}$), intent(out) :: info,m,nsplit,iblock(*),isplit(*),iwork(*) + real(sp), intent(in) :: abstol,vl,vu,d(*),e(*) real(sp), intent(out) :: w(*),work(*) end subroutine sstebz -#else - module procedure stdlib_sstebz +#else + module procedure stdlib${ii}$_sstebz #endif - end interface stebz - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$stebz +#:endif +#:endfor +#:endfor + end interface stebz interface stedc !! STEDC computes all eigenvalues and, optionally, eigenvectors of a @@ -23833,81 +23751,81 @@ module stdlib_linalg_lapack !! which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. !! It could conceivably fail on hexadecimal or decimal machines !! without guard digits, but we know of none. See SLAED3 for details. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cstedc( compz, n, d, e, z, ldz, work, lwork, rwork,lrwork, iwork, & liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compz - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldz,liwork,lrwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldz,liwork,lrwork,lwork,n real(sp), intent(inout) :: d(*),e(*) real(sp), intent(out) :: rwork(*) complex(sp), intent(out) :: work(*) complex(sp), intent(inout) :: z(ldz,*) end subroutine cstedc -#else - module procedure stdlib_cstedc +#else + module procedure stdlib${ii}$_cstedc #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dstedc( compz, n, d, e, z, ldz, work, lwork, iwork,liwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compz - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldz,liwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldz,liwork,lwork,n real(dp), intent(inout) :: d(*),e(*),z(ldz,*) real(dp), intent(out) :: work(*) end subroutine dstedc -#else - module procedure stdlib_dstedc +#else + module procedure stdlib${ii}$_dstedc #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$stedc - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sstedc( compz, n, d, e, z, ldz, work, lwork, iwork,liwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compz - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldz,liwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldz,liwork,lwork,n real(sp), intent(inout) :: d(*),e(*),z(ldz,*) real(sp), intent(out) :: work(*) end subroutine sstedc -#else - module procedure stdlib_sstedc +#else + module procedure stdlib${ii}$_sstedc #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$stedc - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zstedc( compz, n, d, e, z, ldz, work, lwork, rwork,lrwork, iwork, & liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compz - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldz,liwork,lrwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldz,liwork,lrwork,lwork,n real(dp), intent(inout) :: d(*),e(*) real(dp), intent(out) :: rwork(*) complex(dp), intent(out) :: work(*) complex(dp), intent(inout) :: z(ldz,*) end subroutine zstedc -#else - module procedure stdlib_zstedc +#else + module procedure stdlib${ii}$_zstedc #endif - end interface stedc +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$stedc +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$stedc +#:endif +#:endfor +#:endfor + end interface stedc interface stegr !! STEGR computes selected eigenvalues and, optionally, eigenvectors @@ -23926,83 +23844,83 @@ module stdlib_linalg_lapack !! NaNs. Normal execution may create these exceptiona values and hence !! may abort due to a floating point exception in environments which !! do not conform to the IEEE-754 standard. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cstegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, & isuppz, work, lwork, iwork,liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,range - integer(ilp), intent(in) :: il,iu,ldz,liwork,lwork,n - integer(ilp), intent(out) :: info,m,isuppz(*),iwork(*) + integer(${ik}$), intent(in) :: il,iu,ldz,liwork,lwork,n + integer(${ik}$), intent(out) :: info,m,isuppz(*),iwork(*) real(sp), intent(in) :: abstol,vl,vu real(sp), intent(inout) :: d(*),e(*) real(sp), intent(out) :: w(*),work(*) complex(sp), intent(out) :: z(ldz,*) end subroutine cstegr -#else - module procedure stdlib_cstegr +#else + module procedure stdlib${ii}$_cstegr #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dstegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, & isuppz, work, lwork, iwork,liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,range - integer(ilp), intent(in) :: il,iu,ldz,liwork,lwork,n - integer(ilp), intent(out) :: info,m,isuppz(*),iwork(*) + integer(${ik}$), intent(in) :: il,iu,ldz,liwork,lwork,n + integer(${ik}$), intent(out) :: info,m,isuppz(*),iwork(*) real(dp), intent(in) :: abstol,vl,vu real(dp), intent(inout) :: d(*),e(*) real(dp), intent(out) :: w(*),work(*),z(ldz,*) end subroutine dstegr -#else - module procedure stdlib_dstegr +#else + module procedure stdlib${ii}$_dstegr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$stegr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sstegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, & isuppz, work, lwork, iwork,liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,range - integer(ilp), intent(in) :: il,iu,ldz,liwork,lwork,n - integer(ilp), intent(out) :: info,m,isuppz(*),iwork(*) + integer(${ik}$), intent(in) :: il,iu,ldz,liwork,lwork,n + integer(${ik}$), intent(out) :: info,m,isuppz(*),iwork(*) real(sp), intent(in) :: abstol,vl,vu real(sp), intent(inout) :: d(*),e(*) real(sp), intent(out) :: w(*),work(*),z(ldz,*) end subroutine sstegr -#else - module procedure stdlib_sstegr +#else + module procedure stdlib${ii}$_sstegr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$stegr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zstegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, & isuppz, work, lwork, iwork,liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,range - integer(ilp), intent(in) :: il,iu,ldz,liwork,lwork,n - integer(ilp), intent(out) :: info,m,isuppz(*),iwork(*) + integer(${ik}$), intent(in) :: il,iu,ldz,liwork,lwork,n + integer(${ik}$), intent(out) :: info,m,isuppz(*),iwork(*) real(dp), intent(in) :: abstol,vl,vu real(dp), intent(inout) :: d(*),e(*) real(dp), intent(out) :: w(*),work(*) complex(dp), intent(out) :: z(ldz,*) end subroutine zstegr -#else - module procedure stdlib_zstegr +#else + module procedure stdlib${ii}$_zstegr #endif - end interface stegr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$stegr +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$stegr +#:endif +#:endfor +#:endfor + end interface stegr interface stein !! STEIN computes the eigenvectors of a real symmetric tridiagonal @@ -24014,75 +23932,75 @@ module stdlib_linalg_lapack !! array, which may be passed to CUNMTR or CUPMTR for back !! transformation to the eigenvectors of a complex Hermitian matrix !! which was reduced to tridiagonal form. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cstein( n, d, e, m, w, iblock, isplit, z, ldz, work,iwork, ifail, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ifail(*),iwork(*) - integer(ilp), intent(in) :: ldz,m,n,iblock(*),isplit(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ifail(*),iwork(*) + integer(${ik}$), intent(in) :: ldz,m,n,iblock(*),isplit(*) real(sp), intent(in) :: d(*),e(*),w(*) real(sp), intent(out) :: work(*) complex(sp), intent(out) :: z(ldz,*) end subroutine cstein -#else - module procedure stdlib_cstein +#else + module procedure stdlib${ii}$_cstein #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dstein( n, d, e, m, w, iblock, isplit, z, ldz, work,iwork, ifail, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ifail(*),iwork(*) - integer(ilp), intent(in) :: ldz,m,n,iblock(*),isplit(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ifail(*),iwork(*) + integer(${ik}$), intent(in) :: ldz,m,n,iblock(*),isplit(*) real(dp), intent(in) :: d(*),e(*),w(*) real(dp), intent(out) :: work(*),z(ldz,*) end subroutine dstein -#else - module procedure stdlib_dstein +#else + module procedure stdlib${ii}$_dstein #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$stein - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sstein( n, d, e, m, w, iblock, isplit, z, ldz, work,iwork, ifail, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ifail(*),iwork(*) - integer(ilp), intent(in) :: ldz,m,n,iblock(*),isplit(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ifail(*),iwork(*) + integer(${ik}$), intent(in) :: ldz,m,n,iblock(*),isplit(*) real(sp), intent(in) :: d(*),e(*),w(*) real(sp), intent(out) :: work(*),z(ldz,*) end subroutine sstein -#else - module procedure stdlib_sstein +#else + module procedure stdlib${ii}$_sstein #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$stein - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zstein( n, d, e, m, w, iblock, isplit, z, ldz, work,iwork, ifail, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info,ifail(*),iwork(*) - integer(ilp), intent(in) :: ldz,m,n,iblock(*),isplit(*) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info,ifail(*),iwork(*) + integer(${ik}$), intent(in) :: ldz,m,n,iblock(*),isplit(*) real(dp), intent(in) :: d(*),e(*),w(*) real(dp), intent(out) :: work(*) complex(dp), intent(out) :: z(ldz,*) end subroutine zstein -#else - module procedure stdlib_zstein +#else + module procedure stdlib${ii}$_zstein #endif - end interface stein +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$stein +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$stein +#:endif +#:endfor +#:endfor + end interface stein interface stemr !! STEMR computes selected eigenvalues and, optionally, eigenvectors @@ -24144,87 +24062,87 @@ module stdlib_linalg_lapack !! Since LAPACK drivers overwrite the matrix data with the eigenvectors, !! STEMR accepts complex workspace to facilitate interoperability !! with CUNMTR or CUPMTR. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, nzc, & isuppz, tryrac, work, lwork,iwork, liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,range logical(lk), intent(inout) :: tryrac - integer(ilp), intent(in) :: il,iu,ldz,nzc,liwork,lwork,n - integer(ilp), intent(out) :: info,m,isuppz(*),iwork(*) + integer(${ik}$), intent(in) :: il,iu,ldz,nzc,liwork,lwork,n + integer(${ik}$), intent(out) :: info,m,isuppz(*),iwork(*) real(sp), intent(in) :: vl,vu real(sp), intent(inout) :: d(*),e(*) real(sp), intent(out) :: w(*),work(*) complex(sp), intent(out) :: z(ldz,*) end subroutine cstemr -#else - module procedure stdlib_cstemr +#else + module procedure stdlib${ii}$_cstemr #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, nzc, & isuppz, tryrac, work, lwork,iwork, liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,range logical(lk), intent(inout) :: tryrac - integer(ilp), intent(in) :: il,iu,ldz,nzc,liwork,lwork,n - integer(ilp), intent(out) :: info,m,isuppz(*),iwork(*) + integer(${ik}$), intent(in) :: il,iu,ldz,nzc,liwork,lwork,n + integer(${ik}$), intent(out) :: info,m,isuppz(*),iwork(*) real(dp), intent(in) :: vl,vu real(dp), intent(inout) :: d(*),e(*) real(dp), intent(out) :: w(*),work(*),z(ldz,*) end subroutine dstemr -#else - module procedure stdlib_dstemr +#else + module procedure stdlib${ii}$_dstemr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$stemr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, nzc, & isuppz, tryrac, work, lwork,iwork, liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,range logical(lk), intent(inout) :: tryrac - integer(ilp), intent(in) :: il,iu,ldz,nzc,liwork,lwork,n - integer(ilp), intent(out) :: info,m,isuppz(*),iwork(*) + integer(${ik}$), intent(in) :: il,iu,ldz,nzc,liwork,lwork,n + integer(${ik}$), intent(out) :: info,m,isuppz(*),iwork(*) real(sp), intent(in) :: vl,vu real(sp), intent(inout) :: d(*),e(*) real(sp), intent(out) :: w(*),work(*),z(ldz,*) end subroutine sstemr -#else - module procedure stdlib_sstemr +#else + module procedure stdlib${ii}$_sstemr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$stemr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, nzc, & isuppz, tryrac, work, lwork,iwork, liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,range logical(lk), intent(inout) :: tryrac - integer(ilp), intent(in) :: il,iu,ldz,nzc,liwork,lwork,n - integer(ilp), intent(out) :: info,m,isuppz(*),iwork(*) + integer(${ik}$), intent(in) :: il,iu,ldz,nzc,liwork,lwork,n + integer(${ik}$), intent(out) :: info,m,isuppz(*),iwork(*) real(dp), intent(in) :: vl,vu real(dp), intent(inout) :: d(*),e(*) real(dp), intent(out) :: w(*),work(*) complex(dp), intent(out) :: z(ldz,*) end subroutine zstemr -#else - module procedure stdlib_zstemr +#else + module procedure stdlib${ii}$_zstemr #endif - end interface stemr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$stemr +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$stemr +#:endif +#:endfor +#:endfor + end interface stemr interface steqr !! STEQR computes all eigenvalues and, optionally, eigenvectors of a @@ -24232,149 +24150,149 @@ module stdlib_linalg_lapack !! The eigenvectors of a full or band complex Hermitian matrix can also !! be found if CHETRD or CHPTRD or CHBTRD has been used to reduce this !! matrix to tridiagonal form. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csteqr( compz, n, d, e, z, ldz, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldz,n real(sp), intent(inout) :: d(*),e(*) real(sp), intent(out) :: work(*) complex(sp), intent(inout) :: z(ldz,*) end subroutine csteqr -#else - module procedure stdlib_csteqr +#else + module procedure stdlib${ii}$_csteqr #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsteqr( compz, n, d, e, z, ldz, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldz,n real(dp), intent(inout) :: d(*),e(*),z(ldz,*) real(dp), intent(out) :: work(*) end subroutine dsteqr -#else - module procedure stdlib_dsteqr +#else + module procedure stdlib${ii}$_dsteqr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$steqr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssteqr( compz, n, d, e, z, ldz, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldz,n real(sp), intent(inout) :: d(*),e(*),z(ldz,*) real(sp), intent(out) :: work(*) end subroutine ssteqr -#else - module procedure stdlib_ssteqr +#else + module procedure stdlib${ii}$_ssteqr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$steqr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsteqr( compz, n, d, e, z, ldz, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldz,n real(dp), intent(inout) :: d(*),e(*) real(dp), intent(out) :: work(*) complex(dp), intent(inout) :: z(ldz,*) end subroutine zsteqr -#else - module procedure stdlib_zsteqr +#else + module procedure stdlib${ii}$_zsteqr #endif - end interface steqr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$steqr +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$steqr +#:endif +#:endfor +#:endfor + end interface steqr interface sterf !! STERF computes all eigenvalues of a symmetric tridiagonal matrix !! using the Pal-Walker-Kahan variant of the QL or QR algorithm. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsterf( n, d, e, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(dp), intent(inout) :: d(*),e(*) end subroutine dsterf -#else - module procedure stdlib_dsterf +#else + module procedure stdlib${ii}$_dsterf +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine ssterf( n, d, e, info ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n + real(sp), intent(inout) :: d(*),e(*) + end subroutine ssterf +#else + module procedure stdlib${ii}$_ssterf #endif #:for rk,rt,ri in REAL_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sterf + module procedure stdlib${ii}$_${ri}$sterf #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine ssterf( n, d, e, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n - real(sp), intent(inout) :: d(*),e(*) - end subroutine ssterf -#else - module procedure stdlib_ssterf -#endif +#:endfor end interface sterf - - interface stev !! STEV computes all eigenvalues and, optionally, eigenvectors of a !! real symmetric tridiagonal matrix A. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dstev( jobz, n, d, e, z, ldz, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldz,n real(dp), intent(inout) :: d(*),e(*) real(dp), intent(out) :: work(*),z(ldz,*) - end subroutine dstev -#else - module procedure stdlib_dstev -#endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$stev - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK + end subroutine dstev +#else + module procedure stdlib${ii}$_dstev +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sstev( jobz, n, d, e, z, ldz, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldz,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldz,n real(sp), intent(inout) :: d(*),e(*) real(sp), intent(out) :: work(*),z(ldz,*) end subroutine sstev -#else - module procedure stdlib_sstev +#else + module procedure stdlib${ii}$_sstev #endif - end interface stev - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$stev +#:endif +#:endfor +#:endfor + end interface stev interface stevd !! STEVD computes all eigenvalues and, optionally, eigenvectors of a @@ -24386,43 +24304,43 @@ module stdlib_linalg_lapack !! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or !! Cray-2. It could conceivably fail on hexadecimal or decimal machines !! without guard digits, but we know of none. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dstevd( jobz, n, d, e, z, ldz, work, lwork, iwork,liwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldz,liwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldz,liwork,lwork,n real(dp), intent(inout) :: d(*),e(*) real(dp), intent(out) :: work(*),z(ldz,*) end subroutine dstevd -#else - module procedure stdlib_dstevd +#else + module procedure stdlib${ii}$_dstevd #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$stevd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sstevd( jobz, n, d, e, z, ldz, work, lwork, iwork,liwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldz,liwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldz,liwork,lwork,n real(sp), intent(inout) :: d(*),e(*) real(sp), intent(out) :: work(*),z(ldz,*) end subroutine sstevd -#else - module procedure stdlib_sstevd +#else + module procedure stdlib${ii}$_sstevd #endif - end interface stevd - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$stevd +#:endif +#:endfor +#:endfor + end interface stevd interface stevr !! STEVR computes selected eigenvalues and, optionally, eigenvectors @@ -24460,45 +24378,45 @@ module stdlib_linalg_lapack !! hence may abort due to a floating point exception in environments !! which do not handle NaNs and infinities in the ieee standard default !! manner. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dstevr( jobz, range, n, d, e, vl, vu, il, iu, abstol,m, w, z, ldz, & isuppz, work, lwork, iwork,liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,range - integer(ilp), intent(in) :: il,iu,ldz,liwork,lwork,n - integer(ilp), intent(out) :: info,m,isuppz(*),iwork(*) + integer(${ik}$), intent(in) :: il,iu,ldz,liwork,lwork,n + integer(${ik}$), intent(out) :: info,m,isuppz(*),iwork(*) real(dp), intent(in) :: abstol,vl,vu real(dp), intent(inout) :: d(*),e(*) real(dp), intent(out) :: w(*),work(*),z(ldz,*) end subroutine dstevr -#else - module procedure stdlib_dstevr +#else + module procedure stdlib${ii}$_dstevr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$stevr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine sstevr( jobz, range, n, d, e, vl, vu, il, iu, abstol,m, w, z, ldz, & isuppz, work, lwork, iwork,liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,range - integer(ilp), intent(in) :: il,iu,ldz,liwork,lwork,n - integer(ilp), intent(out) :: info,m,isuppz(*),iwork(*) + integer(${ik}$), intent(in) :: il,iu,ldz,liwork,lwork,n + integer(${ik}$), intent(out) :: info,m,isuppz(*),iwork(*) real(sp), intent(in) :: abstol,vl,vu real(sp), intent(inout) :: d(*),e(*) real(sp), intent(out) :: w(*),work(*),z(ldz,*) end subroutine sstevr -#else - module procedure stdlib_sstevr +#else + module procedure stdlib${ii}$_sstevr #endif - end interface stevr - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$stevr +#:endif +#:endfor +#:endfor + end interface stevr interface sycon !! SYCON estimates the reciprocal of the condition number (in the @@ -24506,79 +24424,79 @@ module stdlib_linalg_lapack !! A = U*D*U**T or A = L*D*L**T computed by CSYTRF. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csycon( uplo, n, a, lda, ipiv, anorm, rcond, work,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) real(sp), intent(in) :: anorm real(sp), intent(out) :: rcond complex(sp), intent(in) :: a(lda,*) complex(sp), intent(out) :: work(*) end subroutine csycon -#else - module procedure stdlib_csycon +#else + module procedure stdlib${ii}$_csycon #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsycon( uplo, n, a, lda, ipiv, anorm, rcond, work,iwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,n,ipiv(*) real(dp), intent(in) :: anorm,a(lda,*) real(dp), intent(out) :: rcond,work(*) end subroutine dsycon -#else - module procedure stdlib_dsycon +#else + module procedure stdlib${ii}$_dsycon #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sycon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssycon( uplo, n, a, lda, ipiv, anorm, rcond, work,iwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,n,ipiv(*) real(sp), intent(in) :: anorm,a(lda,*) real(sp), intent(out) :: rcond,work(*) end subroutine ssycon -#else - module procedure stdlib_ssycon +#else + module procedure stdlib${ii}$_ssycon #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sycon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsycon( uplo, n, a, lda, ipiv, anorm, rcond, work,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) real(dp), intent(in) :: anorm real(dp), intent(out) :: rcond complex(dp), intent(in) :: a(lda,*) complex(dp), intent(out) :: work(*) end subroutine zsycon -#else - module procedure stdlib_zsycon +#else + module procedure stdlib${ii}$_zsycon #endif - end interface sycon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sycon +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sycon +#:endif +#:endfor +#:endfor + end interface sycon interface sycon_rook !! SYCON_ROOK estimates the reciprocal of the condition number (in the @@ -24586,153 +24504,153 @@ module stdlib_linalg_lapack !! A = U*D*U**T or A = L*D*L**T computed by CSYTRF_ROOK. !! An estimate is obtained for norm(inv(A)), and the reciprocal of the !! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csycon_rook( uplo, n, a, lda, ipiv, anorm, rcond, work,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) real(sp), intent(in) :: anorm real(sp), intent(out) :: rcond complex(sp), intent(in) :: a(lda,*) complex(sp), intent(out) :: work(*) end subroutine csycon_rook -#else - module procedure stdlib_csycon_rook +#else + module procedure stdlib${ii}$_csycon_rook #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsycon_rook( uplo, n, a, lda, ipiv, anorm, rcond, work,iwork, info & ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,n,ipiv(*) real(dp), intent(in) :: anorm,a(lda,*) real(dp), intent(out) :: rcond,work(*) end subroutine dsycon_rook -#else - module procedure stdlib_dsycon_rook +#else + module procedure stdlib${ii}$_dsycon_rook #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sycon_rook - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssycon_rook( uplo, n, a, lda, ipiv, anorm, rcond, work,iwork, info & ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,n,ipiv(*) real(sp), intent(in) :: anorm,a(lda,*) real(sp), intent(out) :: rcond,work(*) end subroutine ssycon_rook -#else - module procedure stdlib_ssycon_rook +#else + module procedure stdlib${ii}$_ssycon_rook #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sycon_rook - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsycon_rook( uplo, n, a, lda, ipiv, anorm, rcond, work,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) real(dp), intent(in) :: anorm real(dp), intent(out) :: rcond complex(dp), intent(in) :: a(lda,*) complex(dp), intent(out) :: work(*) end subroutine zsycon_rook -#else - module procedure stdlib_zsycon_rook +#else + module procedure stdlib${ii}$_zsycon_rook #endif - end interface sycon_rook +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sycon_rook +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sycon_rook +#:endif +#:endfor +#:endfor + end interface sycon_rook interface syconv !! SYCONV convert A given by TRF into L and D and vice-versa. !! Get Non-diag elements of D (returned in workspace) and !! apply or reverse permutation done in TRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csyconv( uplo, way, n, a, lda, ipiv, e, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo,way - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: e(*) end subroutine csyconv -#else - module procedure stdlib_csyconv +#else + module procedure stdlib${ii}$_csyconv #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsyconv( uplo, way, n, a, lda, ipiv, e, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo,way - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: e(*) end subroutine dsyconv -#else - module procedure stdlib_dsyconv +#else + module procedure stdlib${ii}$_dsyconv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$syconv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssyconv( uplo, way, n, a, lda, ipiv, e, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo,way - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: e(*) end subroutine ssyconv -#else - module procedure stdlib_ssyconv +#else + module procedure stdlib${ii}$_ssyconv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$syconv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsyconv( uplo, way, n, a, lda, ipiv, e, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo,way - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: e(*) end subroutine zsyconv -#else - module procedure stdlib_zsyconv +#else + module procedure stdlib${ii}$_zsyconv #endif - end interface syconv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$syconv +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$syconv +#:endif +#:endfor +#:endfor + end interface syconv interface syconvf !! If parameter WAY = 'C': @@ -24752,73 +24670,73 @@ module stdlib_linalg_lapack !! (or CSYTRF_BK) into the format used in CSYTRF. !! SYCONVF can also convert in Hermitian matrix case, i.e. between !! formats used in CHETRF and CHETRF_RK (or CHETRF_BK). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csyconvf( uplo, way, n, a, lda, e, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo,way - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n - integer(ilp), intent(inout) :: ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n + integer(${ik}$), intent(inout) :: ipiv(*) complex(sp), intent(inout) :: a(lda,*),e(*) end subroutine csyconvf -#else - module procedure stdlib_csyconvf +#else + module procedure stdlib${ii}$_csyconvf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsyconvf( uplo, way, n, a, lda, e, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo,way - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n - integer(ilp), intent(inout) :: ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n + integer(${ik}$), intent(inout) :: ipiv(*) real(dp), intent(inout) :: a(lda,*),e(*) end subroutine dsyconvf -#else - module procedure stdlib_dsyconvf +#else + module procedure stdlib${ii}$_dsyconvf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$syconvf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssyconvf( uplo, way, n, a, lda, e, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo,way - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n - integer(ilp), intent(inout) :: ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n + integer(${ik}$), intent(inout) :: ipiv(*) real(sp), intent(inout) :: a(lda,*),e(*) end subroutine ssyconvf -#else - module procedure stdlib_ssyconvf +#else + module procedure stdlib${ii}$_ssyconvf #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$syconvf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsyconvf( uplo, way, n, a, lda, e, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo,way - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n - integer(ilp), intent(inout) :: ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n + integer(${ik}$), intent(inout) :: ipiv(*) complex(dp), intent(inout) :: a(lda,*),e(*) end subroutine zsyconvf -#else - module procedure stdlib_zsyconvf +#else + module procedure stdlib${ii}$_zsyconvf #endif - end interface syconvf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$syconvf +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$syconvf +#:endif +#:endfor +#:endfor + end interface syconvf interface syconvf_rook !! If parameter WAY = 'C': @@ -24836,69 +24754,69 @@ module stdlib_linalg_lapack !! CSYTRF_RK (or CSYTRF_BK) is the same and is not converted. !! SYCONVF_ROOK can also convert in Hermitian matrix case, i.e. between !! formats used in CHETRF_ROOK and CHETRF_RK (or CHETRF_BK). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csyconvf_rook( uplo, way, n, a, lda, e, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo,way - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) complex(sp), intent(inout) :: a(lda,*),e(*) end subroutine csyconvf_rook -#else - module procedure stdlib_csyconvf_rook +#else + module procedure stdlib${ii}$_csyconvf_rook #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsyconvf_rook( uplo, way, n, a, lda, e, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo,way - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) real(dp), intent(inout) :: a(lda,*),e(*) end subroutine dsyconvf_rook -#else - module procedure stdlib_dsyconvf_rook +#else + module procedure stdlib${ii}$_dsyconvf_rook #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$syconvf_rook - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssyconvf_rook( uplo, way, n, a, lda, e, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo,way - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) real(sp), intent(inout) :: a(lda,*),e(*) end subroutine ssyconvf_rook -#else - module procedure stdlib_ssyconvf_rook +#else + module procedure stdlib${ii}$_ssyconvf_rook #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$syconvf_rook - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsyconvf_rook( uplo, way, n, a, lda, e, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo,way - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) complex(dp), intent(inout) :: a(lda,*),e(*) end subroutine zsyconvf_rook -#else - module procedure stdlib_zsyconvf_rook +#else + module procedure stdlib${ii}$_zsyconvf_rook #endif - end interface syconvf_rook +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$syconvf_rook +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$syconvf_rook +#:endif +#:endfor +#:endfor + end interface syconvf_rook interface syequb !! SYEQUB computes row and column scalings intended to equilibrate a @@ -24908,114 +24826,114 @@ module stdlib_linalg_lapack !! B(i,j) = S(i)*A(i,j)*S(j) has a condition number within a factor N of !! the smallest possible condition number over all possible diagonal !! scalings. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csyequb( uplo, n, a, lda, s, scond, amax, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n real(sp), intent(out) :: amax,scond,s(*) character, intent(in) :: uplo complex(sp), intent(in) :: a(lda,*) complex(sp), intent(out) :: work(*) end subroutine csyequb -#else - module procedure stdlib_csyequb +#else + module procedure stdlib${ii}$_csyequb #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsyequb( uplo, n, a, lda, s, scond, amax, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n real(dp), intent(out) :: amax,scond,s(*),work(*) character, intent(in) :: uplo real(dp), intent(in) :: a(lda,*) end subroutine dsyequb -#else - module procedure stdlib_dsyequb +#else + module procedure stdlib${ii}$_dsyequb #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$syequb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssyequb( uplo, n, a, lda, s, scond, amax, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n real(sp), intent(out) :: amax,scond,s(*),work(*) character, intent(in) :: uplo real(sp), intent(in) :: a(lda,*) end subroutine ssyequb -#else - module procedure stdlib_ssyequb +#else + module procedure stdlib${ii}$_ssyequb #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$syequb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsyequb( uplo, n, a, lda, s, scond, amax, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n real(dp), intent(out) :: amax,scond,s(*) character, intent(in) :: uplo complex(dp), intent(in) :: a(lda,*) complex(dp), intent(out) :: work(*) end subroutine zsyequb -#else - module procedure stdlib_zsyequb +#else + module procedure stdlib${ii}$_zsyequb #endif - end interface syequb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$syequb +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$syequb +#:endif +#:endfor +#:endfor + end interface syequb interface syev !! SYEV computes all eigenvalues and, optionally, eigenvectors of a !! real symmetric matrix A. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dsyev( jobz, uplo, n, a, lda, w, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,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 real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: w(*),work(*) end subroutine dsyev -#else - module procedure stdlib_dsyev +#else + module procedure stdlib${ii}$_dsyev #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$syev - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine ssyev( jobz, uplo, n, a, lda, w, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,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 real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: w(*),work(*) end subroutine ssyev -#else - module procedure stdlib_ssyev +#else + module procedure stdlib${ii}$_ssyev #endif - end interface syev - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$syev +#:endif +#:endfor +#:endfor + end interface syev interface syevd !! SYEVD computes all eigenvalues and, optionally, eigenvectors of a @@ -25029,43 +24947,43 @@ module stdlib_linalg_lapack !! without guard digits, but we know of none. !! Because of large use of BLAS of level 3, SYEVD needs N**2 more !! workspace than DSYEVX. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dsyevd( jobz, uplo, n, a, lda, w, work, lwork, iwork,liwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,liwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,liwork,lwork,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: w(*),work(*) end subroutine dsyevd -#else - module procedure stdlib_dsyevd +#else + module procedure stdlib${ii}$_dsyevd #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$syevd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine ssyevd( jobz, uplo, n, a, lda, w, work, lwork, iwork,liwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,liwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,liwork,lwork,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: w(*),work(*) end subroutine ssyevd -#else - module procedure stdlib_ssyevd +#else + module procedure stdlib${ii}$_ssyevd #endif - end interface syevd - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$syevd +#:endif +#:endfor +#:endfor + end interface syevd interface syevr !! SYEVR computes selected eigenvalues and, optionally, eigenvectors @@ -25118,45 +25036,45 @@ module stdlib_linalg_lapack !! hence may abort due to a floating point exception in environments !! which do not handle NaNs and infinities in the ieee standard default !! manner. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dsyevr( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, & ldz, isuppz, work, lwork,iwork, liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,range,uplo - integer(ilp), intent(in) :: il,iu,lda,ldz,liwork,lwork,n - integer(ilp), intent(out) :: info,m,isuppz(*),iwork(*) + integer(${ik}$), intent(in) :: il,iu,lda,ldz,liwork,lwork,n + integer(${ik}$), intent(out) :: info,m,isuppz(*),iwork(*) real(dp), intent(in) :: abstol,vl,vu real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: w(*),work(*),z(ldz,*) end subroutine dsyevr -#else - module procedure stdlib_dsyevr +#else + module procedure stdlib${ii}$_dsyevr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$syevr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine ssyevr( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, & ldz, isuppz, work, lwork,iwork, liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,range,uplo - integer(ilp), intent(in) :: il,iu,lda,ldz,liwork,lwork,n - integer(ilp), intent(out) :: info,m,isuppz(*),iwork(*) + integer(${ik}$), intent(in) :: il,iu,lda,ldz,liwork,lwork,n + integer(${ik}$), intent(out) :: info,m,isuppz(*),iwork(*) real(sp), intent(in) :: abstol,vl,vu real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: w(*),work(*),z(ldz,*) end subroutine ssyevr -#else - module procedure stdlib_ssyevr +#else + module procedure stdlib${ii}$_ssyevr #endif - end interface syevr - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$syevr +#:endif +#:endfor +#:endfor + end interface syevr interface sygst !! SYGST reduces a real symmetric-definite generalized eigenproblem @@ -25166,41 +25084,41 @@ module stdlib_linalg_lapack !! If ITYPE = 2 or 3, 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 DPOTRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsygst( itype, uplo, n, a, lda, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: b(ldb,*) end subroutine dsygst -#else - module procedure stdlib_dsygst +#else + module procedure stdlib${ii}$_dsygst #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sygst - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssygst( itype, uplo, n, a, lda, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: a(lda,*) real(sp), intent(in) :: b(ldb,*) end subroutine ssygst -#else - module procedure stdlib_ssygst +#else + module procedure stdlib${ii}$_ssygst #endif - end interface sygst - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sygst +#:endif +#:endfor +#:endfor + end interface sygst interface sygv !! SYGV computes all the eigenvalues, and optionally, the eigenvectors @@ -25208,43 +25126,43 @@ module stdlib_linalg_lapack !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. !! Here A and B are assumed to be symmetric and B is also !! positive definite. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dsygv( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: itype,lda,ldb,lwork,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: itype,lda,ldb,lwork,n real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(out) :: w(*),work(*) end subroutine dsygv -#else - module procedure stdlib_dsygv +#else + module procedure stdlib${ii}$_dsygv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sygv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine ssygv( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: itype,lda,ldb,lwork,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: itype,lda,ldb,lwork,n real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(out) :: w(*),work(*) end subroutine ssygv -#else - module procedure stdlib_ssygv +#else + module procedure stdlib${ii}$_ssygv #endif - end interface sygv - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sygv +#:endif +#:endfor +#:endfor + end interface sygv interface sygvd !! SYGVD computes all the eigenvalues, and optionally, the eigenvectors @@ -25258,203 +25176,203 @@ module stdlib_linalg_lapack !! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or !! Cray-2. It could conceivably fail on hexadecimal or decimal machines !! without guard digits, but we know of none. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dsygvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, iwork, & liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: itype,lda,ldb,liwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: itype,lda,ldb,liwork,lwork,n real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(out) :: w(*),work(*) end subroutine dsygvd -#else - module procedure stdlib_dsygvd +#else + module procedure stdlib${ii}$_dsygvd #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sygvd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine ssygvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, iwork, & liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobz,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: itype,lda,ldb,liwork,lwork,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: itype,lda,ldb,liwork,lwork,n real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(out) :: w(*),work(*) end subroutine ssygvd -#else - module procedure stdlib_ssygvd +#else + module procedure stdlib${ii}$_ssygvd #endif - end interface sygvd - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sygvd +#:endif +#:endfor +#:endfor + end interface sygvd interface symv !! SYMV 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 !! A is an n by n symmetric matrix. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csymv( uplo, n, alpha, a, lda, x, incx, beta, y, incy ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: incx,incy,lda,n + integer(${ik}$), intent(in) :: incx,incy,lda,n complex(sp), intent(in) :: alpha,beta,a(lda,*),x(*) complex(sp), intent(inout) :: y(*) end subroutine csymv -#else - module procedure stdlib_csymv -#endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$symv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#else + module procedure stdlib${ii}$_csymv +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsymv( uplo, n, alpha, a, lda, x, incx, beta, y, incy ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: incx,incy,lda,n + integer(${ik}$), intent(in) :: incx,incy,lda,n complex(dp), intent(in) :: alpha,beta,a(lda,*),x(*) complex(dp), intent(inout) :: y(*) end subroutine zsymv -#else - module procedure stdlib_zsymv +#else + module procedure stdlib${ii}$_zsymv #endif - end interface symv - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$symv +#:endif +#:endfor +#:endfor + end interface symv interface syr !! SYR performs the symmetric rank 1 operation !! A := alpha*x*x**H + A, !! where alpha is a complex scalar, x is an n element vector and A is an !! n by n symmetric matrix. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csyr( uplo, n, alpha, x, incx, a, lda ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: incx,lda,n + integer(${ik}$), intent(in) :: incx,lda,n complex(sp), intent(in) :: alpha,x(*) complex(sp), intent(inout) :: a(lda,*) end subroutine csyr -#else - module procedure stdlib_csyr +#else + module procedure stdlib${ii}$_csyr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$syr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsyr( uplo, n, alpha, x, incx, a, lda ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: incx,lda,n + integer(${ik}$), intent(in) :: incx,lda,n complex(dp), intent(in) :: alpha,x(*) complex(dp), intent(inout) :: a(lda,*) end subroutine zsyr -#else - module procedure stdlib_zsyr +#else + module procedure stdlib${ii}$_zsyr #endif - end interface syr - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$syr +#:endif +#:endfor +#:endfor + end interface syr interface syrfs !! SYRFS improves the computed solution to a system of linear !! equations when the coefficient matrix is symmetric indefinite, and !! provides error bounds and backward error estimates for the solution. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csyrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr,& berr, work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs,ipiv(*) real(sp), intent(out) :: berr(*),ferr(*),rwork(*) complex(sp), intent(in) :: a(lda,*),af(ldaf,*),b(ldb,*) complex(sp), intent(out) :: work(*) complex(sp), intent(inout) :: x(ldx,*) end subroutine csyrfs -#else - module procedure stdlib_csyrfs +#else + module procedure stdlib${ii}$_csyrfs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsyrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr,& berr, work, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs,ipiv(*) real(dp), intent(in) :: a(lda,*),af(ldaf,*),b(ldb,*) real(dp), intent(out) :: berr(*),ferr(*),work(*) real(dp), intent(inout) :: x(ldx,*) end subroutine dsyrfs -#else - module procedure stdlib_dsyrfs +#else + module procedure stdlib${ii}$_dsyrfs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$syrfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssyrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr,& berr, work, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs,ipiv(*) real(sp), intent(in) :: a(lda,*),af(ldaf,*),b(ldb,*) real(sp), intent(out) :: berr(*),ferr(*),work(*) real(sp), intent(inout) :: x(ldx,*) end subroutine ssyrfs -#else - module procedure stdlib_ssyrfs +#else + module procedure stdlib${ii}$_ssyrfs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$syrfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsyrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr,& berr, work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldaf,ldb,ldx,n,nrhs,ipiv(*) real(dp), intent(out) :: berr(*),ferr(*),rwork(*) complex(dp), intent(in) :: a(lda,*),af(ldaf,*),b(ldb,*) complex(dp), intent(out) :: work(*) complex(dp), intent(inout) :: x(ldx,*) end subroutine zsyrfs -#else - module procedure stdlib_zsyrfs +#else + module procedure stdlib${ii}$_zsyrfs #endif - end interface syrfs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$syrfs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$syrfs +#:endif +#:endfor +#:endfor + end interface syrfs interface sysv !! SYSV computes the solution to a complex system of linear equations @@ -25468,77 +25386,77 @@ module stdlib_linalg_lapack !! triangular matrices, and D is symmetric and block diagonal with !! 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then !! used to solve the system of equations A * X = B. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,lwork,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,n,nrhs complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: work(*) end subroutine csysv -#else - module procedure stdlib_csysv +#else + module procedure stdlib${ii}$_csysv #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,lwork,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,n,nrhs real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(out) :: work(*) end subroutine dsysv -#else - module procedure stdlib_dsysv +#else + module procedure stdlib${ii}$_dsysv #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sysv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,lwork,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,n,nrhs real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(out) :: work(*) end subroutine ssysv -#else - module procedure stdlib_ssysv +#else + module procedure stdlib${ii}$_ssysv #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sysv - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,lwork,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,n,nrhs complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: work(*) end subroutine zsysv -#else - module procedure stdlib_zsysv +#else + module procedure stdlib${ii}$_zsysv #endif - end interface sysv +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sysv +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sysv +#:endif +#:endfor +#:endfor + end interface sysv interface sysv_aa !! CSYSV computes the solution to a complex system of linear equations @@ -25551,77 +25469,77 @@ module stdlib_linalg_lapack !! where U (or L) is a product of permutation and unit upper (lower) !! triangular matrices, and T is symmetric tridiagonal. The factored !! form of A is then used to solve the system of equations A * X = B. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csysv_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,lwork,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,n,nrhs complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: work(*) end subroutine csysv_aa -#else - module procedure stdlib_csysv_aa +#else + module procedure stdlib${ii}$_csysv_aa #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsysv_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,lwork,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,n,nrhs real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(out) :: work(*) end subroutine dsysv_aa -#else - module procedure stdlib_dsysv_aa +#else + module procedure stdlib${ii}$_dsysv_aa #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sysv_aa - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssysv_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,lwork,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,n,nrhs real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(out) :: work(*) end subroutine ssysv_aa -#else - module procedure stdlib_ssysv_aa +#else + module procedure stdlib${ii}$_ssysv_aa #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sysv_aa - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsysv_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,lwork,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,n,nrhs complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: work(*) end subroutine zsysv_aa -#else - module procedure stdlib_zsysv_aa +#else + module procedure stdlib${ii}$_zsysv_aa #endif - end interface sysv_aa +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sysv_aa +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sysv_aa +#:endif +#:endfor +#:endfor + end interface sysv_aa interface sysv_rk !! SYSV_RK computes the solution to a complex system of linear @@ -25638,77 +25556,77 @@ module stdlib_linalg_lapack !! CSYTRF_RK is called to compute the factorization of a complex !! symmetric matrix. The factored form of A is then used to solve !! the system of equations A * X = B by calling BLAS3 routine CSYTRS_3. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csysv_rk( uplo, n, nrhs, a, lda, e, ipiv, b, ldb, work,lwork, info & ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,lwork,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,n,nrhs complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: e(*),work(*) end subroutine csysv_rk -#else - module procedure stdlib_csysv_rk +#else + module procedure stdlib${ii}$_csysv_rk #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsysv_rk( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,work, lwork, info & ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,lwork,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,n,nrhs real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(out) :: e(*),work(*) end subroutine dsysv_rk -#else - module procedure stdlib_dsysv_rk +#else + module procedure stdlib${ii}$_dsysv_rk #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sysv_rk - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssysv_rk( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,work, lwork, info & ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,lwork,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,n,nrhs real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(out) :: e(*),work(*) end subroutine ssysv_rk -#else - module procedure stdlib_ssysv_rk +#else + module procedure stdlib${ii}$_ssysv_rk #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sysv_rk - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsysv_rk( uplo, n, nrhs, a, lda, e, ipiv, b, ldb, work,lwork, info & ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,lwork,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,n,nrhs complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: e(*),work(*) end subroutine zsysv_rk -#else - module procedure stdlib_zsysv_rk +#else + module procedure stdlib${ii}$_zsysv_rk #endif - end interface sysv_rk +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sysv_rk +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sysv_rk +#:endif +#:endfor +#:endfor + end interface sysv_rk interface sysv_rook !! SYSV_ROOK computes the solution to a complex system of linear @@ -25727,140 +25645,140 @@ module stdlib_linalg_lapack !! pivoting method. !! The factored form of A is then used to solve the system !! of equations A * X = B by calling CSYTRS_ROOK. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csysv_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,lwork,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,n,nrhs complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: work(*) end subroutine csysv_rook -#else - module procedure stdlib_csysv_rook +#else + module procedure stdlib${ii}$_csysv_rook #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsysv_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,lwork,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,n,nrhs real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(out) :: work(*) end subroutine dsysv_rook -#else - module procedure stdlib_dsysv_rook +#else + module procedure stdlib${ii}$_dsysv_rook #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sysv_rook - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssysv_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,lwork,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,n,nrhs real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(out) :: work(*) end subroutine ssysv_rook -#else - module procedure stdlib_ssysv_rook +#else + module procedure stdlib${ii}$_ssysv_rook #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sysv_rook - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsysv_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,ldb,lwork,n,nrhs + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,ldb,lwork,n,nrhs complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: work(*) end subroutine zsysv_rook -#else - module procedure stdlib_zsysv_rook +#else + module procedure stdlib${ii}$_zsysv_rook #endif - end interface sysv_rook +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sysv_rook +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sysv_rook +#:endif +#:endfor +#:endfor + end interface sysv_rook interface syswapr !! SYSWAPR applies an elementary permutation on the rows and the columns of !! a symmetric matrix. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csyswapr( uplo, n, a, lda, i1, i2) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: i1,i2,lda,n + integer(${ik}$), intent(in) :: i1,i2,lda,n complex(sp), intent(inout) :: a(lda,n) end subroutine csyswapr -#else - module procedure stdlib_csyswapr +#else + module procedure stdlib${ii}$_csyswapr #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsyswapr( uplo, n, a, lda, i1, i2) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: i1,i2,lda,n + integer(${ik}$), intent(in) :: i1,i2,lda,n real(dp), intent(inout) :: a(lda,n) end subroutine dsyswapr -#else - module procedure stdlib_dsyswapr +#else + module procedure stdlib${ii}$_dsyswapr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$syswapr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssyswapr( uplo, n, a, lda, i1, i2) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: i1,i2,lda,n + integer(${ik}$), intent(in) :: i1,i2,lda,n real(sp), intent(inout) :: a(lda,n) end subroutine ssyswapr -#else - module procedure stdlib_ssyswapr +#else + module procedure stdlib${ii}$_ssyswapr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$syswapr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsyswapr( uplo, n, a, lda, i1, i2) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: i1,i2,lda,n + integer(${ik}$), intent(in) :: i1,i2,lda,n complex(dp), intent(inout) :: a(lda,n) end subroutine zsyswapr -#else - module procedure stdlib_zsyswapr +#else + module procedure stdlib${ii}$_zsyswapr #endif - end interface syswapr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$syswapr +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$syswapr +#:endif +#:endfor +#:endfor + end interface syswapr interface sytf2_rk !! SYTF2_RK computes the factorization of a complex symmetric matrix A @@ -25872,73 +25790,73 @@ module stdlib_linalg_lapack !! diagonal with 1-by-1 and 2-by-2 diagonal blocks. !! This is the unblocked version of the algorithm, calling Level 2 BLAS. !! For more information see Further Details section. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csytf2_rk( uplo, n, a, lda, e, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: e(*) end subroutine csytf2_rk -#else - module procedure stdlib_csytf2_rk +#else + module procedure stdlib${ii}$_csytf2_rk #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsytf2_rk( uplo, n, a, lda, e, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: e(*) end subroutine dsytf2_rk -#else - module procedure stdlib_dsytf2_rk +#else + module procedure stdlib${ii}$_dsytf2_rk #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytf2_rk - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssytf2_rk( uplo, n, a, lda, e, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: e(*) end subroutine ssytf2_rk -#else - module procedure stdlib_ssytf2_rk +#else + module procedure stdlib${ii}$_ssytf2_rk #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytf2_rk - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsytf2_rk( uplo, n, a, lda, e, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: e(*) end subroutine zsytf2_rk -#else - module procedure stdlib_zsytf2_rk +#else + module procedure stdlib${ii}$_zsytf2_rk #endif - end interface sytf2_rk +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytf2_rk +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytf2_rk +#:endif +#:endfor +#:endfor + end interface sytf2_rk interface sytf2_rook !! SYTF2_ROOK computes the factorization of a complex symmetric matrix A @@ -25948,193 +25866,193 @@ module stdlib_linalg_lapack !! 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. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csytf2_rook( uplo, n, a, lda, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,n complex(sp), intent(inout) :: a(lda,*) end subroutine csytf2_rook -#else - module procedure stdlib_csytf2_rook +#else + module procedure stdlib${ii}$_csytf2_rook #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsytf2_rook( uplo, n, a, lda, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,n real(dp), intent(inout) :: a(lda,*) end subroutine dsytf2_rook -#else - module procedure stdlib_dsytf2_rook +#else + module procedure stdlib${ii}$_dsytf2_rook #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytf2_rook - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssytf2_rook( uplo, n, a, lda, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,n real(sp), intent(inout) :: a(lda,*) end subroutine ssytf2_rook -#else - module procedure stdlib_ssytf2_rook +#else + module procedure stdlib${ii}$_ssytf2_rook #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytf2_rook - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsytf2_rook( uplo, n, a, lda, ipiv, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,n complex(dp), intent(inout) :: a(lda,*) end subroutine zsytf2_rook -#else - module procedure stdlib_zsytf2_rook +#else + module procedure stdlib${ii}$_zsytf2_rook #endif - end interface sytf2_rook +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytf2_rook +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytf2_rook +#:endif +#:endfor +#:endfor + end interface sytf2_rook interface sytrd !! SYTRD reduces a real symmetric matrix A to real symmetric !! tridiagonal form T by an orthogonal similarity transformation: !! Q**T * A * Q = T. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsytrd( uplo, n, a, lda, d, e, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: d(*),e(*),tau(*),work(*) end subroutine dsytrd -#else - module procedure stdlib_dsytrd +#else + module procedure stdlib${ii}$_dsytrd #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytrd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssytrd( uplo, n, a, lda, d, e, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: d(*),e(*),tau(*),work(*) end subroutine ssytrd -#else - module procedure stdlib_ssytrd +#else + module procedure stdlib${ii}$_ssytrd #endif - end interface sytrd - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytrd +#:endif +#:endfor +#:endfor + end interface sytrd interface sytrd_sb2st !! SYTRD_SB2ST reduces a real symmetric band matrix A to real symmetric !! tridiagonal form T by a orthogonal similarity transformation: !! Q**T * A * Q = T. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dsytrd_sb2st( stage1, vect, uplo, n, kd, ab, ldab,d, e, hous, & lhous, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: stage1,uplo,vect - integer(ilp), intent(in) :: n,kd,ldab,lhous,lwork - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n,kd,ldab,lhous,lwork + integer(${ik}$), intent(out) :: info real(dp), intent(out) :: d(*),e(*),hous(*),work(*) real(dp), intent(inout) :: ab(ldab,*) end subroutine dsytrd_sb2st -#else - module procedure stdlib_dsytrd_sb2st +#else + module procedure stdlib${ii}$_dsytrd_sb2st #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytrd_sb2st - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine ssytrd_sb2st( stage1, vect, uplo, n, kd, ab, ldab,d, e, hous, & lhous, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: stage1,uplo,vect - integer(ilp), intent(in) :: n,kd,ldab,lhous,lwork - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n,kd,ldab,lhous,lwork + integer(${ik}$), intent(out) :: info real(sp), intent(out) :: d(*),e(*),hous(*),work(*) real(sp), intent(inout) :: ab(ldab,*) end subroutine ssytrd_sb2st -#else - module procedure stdlib_ssytrd_sb2st +#else + module procedure stdlib${ii}$_ssytrd_sb2st #endif - end interface sytrd_sb2st - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytrd_sb2st +#:endif +#:endfor +#:endfor + end interface sytrd_sb2st interface sytrd_sy2sb !! SYTRD_SY2SB reduces a real symmetric matrix A to real symmetric !! band-diagonal form AB by a orthogonal similarity transformation: !! Q**T * A * Q = AB. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dsytrd_sy2sb( uplo, n, kd, a, lda, ab, ldab, tau,work, lwork, info & ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldab,lwork,n,kd + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldab,lwork,n,kd real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: ab(ldab,*),tau(*),work(*) end subroutine dsytrd_sy2sb -#else - module procedure stdlib_dsytrd_sy2sb +#else + module procedure stdlib${ii}$_dsytrd_sy2sb #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytrd_sy2sb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine ssytrd_sy2sb( uplo, n, kd, a, lda, ab, ldab, tau,work, lwork, info & ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldab,lwork,n,kd + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldab,lwork,n,kd real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: ab(ldab,*),tau(*),work(*) end subroutine ssytrd_sy2sb -#else - module procedure stdlib_ssytrd_sy2sb +#else + module procedure stdlib${ii}$_ssytrd_sy2sb #endif - end interface sytrd_sy2sb - +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytrd_sy2sb +#:endif +#:endfor +#:endfor + end interface sytrd_sy2sb interface sytrf !! SYTRF computes the factorization of a complex symmetric matrix A @@ -26145,74 +26063,74 @@ module stdlib_linalg_lapack !! 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. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csytrf( uplo, n, a, lda, ipiv, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,lwork,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,lwork,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: work(*) end subroutine csytrf -#else - module procedure stdlib_csytrf +#else + module procedure stdlib${ii}$_csytrf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsytrf( uplo, n, a, lda, ipiv, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,lwork,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,lwork,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: work(*) end subroutine dsytrf -#else - module procedure stdlib_dsytrf +#else + module procedure stdlib${ii}$_dsytrf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytrf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssytrf( uplo, n, a, lda, ipiv, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,lwork,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,lwork,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: work(*) end subroutine ssytrf -#else - module procedure stdlib_ssytrf +#else + module procedure stdlib${ii}$_ssytrf +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ + pure subroutine zsytrf( uplo, n, a, lda, ipiv, work, lwork, info ) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + character, intent(in) :: uplo + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,lwork,n + complex(dp), intent(inout) :: a(lda,*) + complex(dp), intent(out) :: work(*) + end subroutine zsytrf +#else + module procedure stdlib${ii}$_zsytrf #endif +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytrf + +#:endif +#:endfor #:for rk,rt,ri in CMPLX_KINDS_TYPES #:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytrf + module procedure stdlib${ii}$_${ri}$sytrf #:endif #:endfor -#ifdef STDLIB_EXTERNAL_LAPACK - pure subroutine zsytrf( uplo, n, a, lda, ipiv, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,lwork,n - complex(dp), intent(inout) :: a(lda,*) - complex(dp), intent(out) :: work(*) - end subroutine zsytrf -#else - module procedure stdlib_zsytrf -#endif +#:endfor end interface sytrf - - interface sytrf_aa !! SYTRF_AA computes the factorization of a complex symmetric matrix A !! using the Aasen's algorithm. The form of the factorization is @@ -26220,73 +26138,73 @@ module stdlib_linalg_lapack !! where U (or L) is a product of permutation and unit upper (lower) !! triangular matrices, and T is a complex symmetric tridiagonal matrix. !! This is the blocked version of the algorithm, calling Level 3 BLAS. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csytrf_aa( uplo, n, a, lda, ipiv, work, lwork, info) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: n,lda,lwork - integer(ilp), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: n,lda,lwork + integer(${ik}$), intent(out) :: info,ipiv(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: work(*) end subroutine csytrf_aa -#else - module procedure stdlib_csytrf_aa +#else + module procedure stdlib${ii}$_csytrf_aa #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsytrf_aa( uplo, n, a, lda, ipiv, work, lwork, info) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: n,lda,lwork - integer(ilp), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: n,lda,lwork + integer(${ik}$), intent(out) :: info,ipiv(*) real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: work(*) end subroutine dsytrf_aa -#else - module procedure stdlib_dsytrf_aa +#else + module procedure stdlib${ii}$_dsytrf_aa #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytrf_aa - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssytrf_aa( uplo, n, a, lda, ipiv, work, lwork, info) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: n,lda,lwork - integer(ilp), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: n,lda,lwork + integer(${ik}$), intent(out) :: info,ipiv(*) real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: work(*) end subroutine ssytrf_aa -#else - module procedure stdlib_ssytrf_aa +#else + module procedure stdlib${ii}$_ssytrf_aa #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytrf_aa - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsytrf_aa( uplo, n, a, lda, ipiv, work, lwork, info) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: n,lda,lwork - integer(ilp), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: n,lda,lwork + integer(${ik}$), intent(out) :: info,ipiv(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: work(*) end subroutine zsytrf_aa -#else - module procedure stdlib_zsytrf_aa +#else + module procedure stdlib${ii}$_zsytrf_aa #endif - end interface sytrf_aa +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytrf_aa +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytrf_aa +#:endif +#:endfor +#:endfor + end interface sytrf_aa interface sytrf_rk !! SYTRF_RK computes the factorization of a complex symmetric matrix A @@ -26298,73 +26216,73 @@ module stdlib_linalg_lapack !! diagonal with 1-by-1 and 2-by-2 diagonal blocks. !! This is the blocked version of the algorithm, calling Level 3 BLAS. !! For more information see Further Details section. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,lwork,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,lwork,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: e(*),work(*) end subroutine csytrf_rk -#else - module procedure stdlib_csytrf_rk +#else + module procedure stdlib${ii}$_csytrf_rk #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,lwork,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,lwork,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: e(*),work(*) end subroutine dsytrf_rk -#else - module procedure stdlib_dsytrf_rk +#else + module procedure stdlib${ii}$_dsytrf_rk #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytrf_rk - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,lwork,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,lwork,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: e(*),work(*) end subroutine ssytrf_rk -#else - module procedure stdlib_ssytrf_rk +#else + module procedure stdlib${ii}$_ssytrf_rk #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytrf_rk - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,lwork,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,lwork,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: e(*),work(*) end subroutine zsytrf_rk -#else - module procedure stdlib_zsytrf_rk +#else + module procedure stdlib${ii}$_zsytrf_rk #endif - end interface sytrf_rk +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytrf_rk +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytrf_rk +#:endif +#:endfor +#:endfor + end interface sytrf_rk interface sytrf_rook !! SYTRF_ROOK computes the factorization of a complex symmetric matrix A @@ -26375,361 +26293,361 @@ module stdlib_linalg_lapack !! 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. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,lwork,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,lwork,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: work(*) end subroutine csytrf_rook -#else - module procedure stdlib_csytrf_rook +#else + module procedure stdlib${ii}$_csytrf_rook #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,lwork,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,lwork,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: work(*) end subroutine dsytrf_rook -#else - module procedure stdlib_dsytrf_rook +#else + module procedure stdlib${ii}$_dsytrf_rook #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytrf_rook - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,lwork,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,lwork,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: work(*) end subroutine ssytrf_rook -#else - module procedure stdlib_ssytrf_rook +#else + module procedure stdlib${ii}$_ssytrf_rook #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytrf_rook - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info,ipiv(*) - integer(ilp), intent(in) :: lda,lwork,n + integer(${ik}$), intent(out) :: info,ipiv(*) + integer(${ik}$), intent(in) :: lda,lwork,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: work(*) end subroutine zsytrf_rook -#else - module procedure stdlib_zsytrf_rook +#else + module procedure stdlib${ii}$_zsytrf_rook #endif - end interface sytrf_rook +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytrf_rook +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytrf_rook +#:endif +#:endfor +#:endfor + end interface sytrf_rook interface sytri !! SYTRI computes the inverse of a complex symmetric indefinite matrix !! A using the factorization A = U*D*U**T or A = L*D*L**T computed by !! CSYTRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csytri( uplo, n, a, lda, ipiv, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: work(*) end subroutine csytri -#else - module procedure stdlib_csytri +#else + module procedure stdlib${ii}$_csytri #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsytri( uplo, n, a, lda, ipiv, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: work(*) end subroutine dsytri -#else - module procedure stdlib_dsytri +#else + module procedure stdlib${ii}$_dsytri #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytri - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssytri( uplo, n, a, lda, ipiv, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: work(*) end subroutine ssytri -#else - module procedure stdlib_ssytri +#else + module procedure stdlib${ii}$_ssytri #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytri - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsytri( uplo, n, a, lda, ipiv, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: work(*) end subroutine zsytri -#else - module procedure stdlib_zsytri +#else + module procedure stdlib${ii}$_zsytri #endif - end interface sytri +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytri +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytri +#:endif +#:endfor +#:endfor + end interface sytri interface sytri_rook !! SYTRI_ROOK computes the inverse of a complex symmetric !! matrix A using the factorization A = U*D*U**T or A = L*D*L**T !! computed by CSYTRF_ROOK. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csytri_rook( uplo, n, a, lda, ipiv, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: work(*) end subroutine csytri_rook -#else - module procedure stdlib_csytri_rook +#else + module procedure stdlib${ii}$_csytri_rook #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsytri_rook( uplo, n, a, lda, ipiv, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: work(*) end subroutine dsytri_rook -#else - module procedure stdlib_dsytri_rook +#else + module procedure stdlib${ii}$_dsytri_rook #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytri_rook - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssytri_rook( uplo, n, a, lda, ipiv, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: work(*) end subroutine ssytri_rook -#else - module procedure stdlib_ssytri_rook +#else + module procedure stdlib${ii}$_ssytri_rook #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytri_rook - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsytri_rook( uplo, n, a, lda, ipiv, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n,ipiv(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: work(*) end subroutine zsytri_rook -#else - module procedure stdlib_zsytri_rook +#else + module procedure stdlib${ii}$_zsytri_rook #endif - end interface sytri_rook +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytri_rook +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytri_rook +#:endif +#:endfor +#:endfor + end interface sytri_rook interface sytrs !! SYTRS solves a system of linear equations A*X = B with a complex !! symmetric matrix A using the factorization A = U*D*U**T or !! A = L*D*L**T computed by CSYTRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csytrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) complex(sp), intent(in) :: a(lda,*) complex(sp), intent(inout) :: b(ldb,*) end subroutine csytrs -#else - module procedure stdlib_csytrs +#else + module procedure stdlib${ii}$_csytrs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsytrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) real(dp), intent(in) :: a(lda,*) real(dp), intent(inout) :: b(ldb,*) end subroutine dsytrs -#else - module procedure stdlib_dsytrs +#else + module procedure stdlib${ii}$_dsytrs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssytrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) real(sp), intent(in) :: a(lda,*) real(sp), intent(inout) :: b(ldb,*) end subroutine ssytrs -#else - module procedure stdlib_ssytrs +#else + module procedure stdlib${ii}$_ssytrs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsytrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) complex(dp), intent(in) :: a(lda,*) complex(dp), intent(inout) :: b(ldb,*) end subroutine zsytrs -#else - module procedure stdlib_zsytrs +#else + module procedure stdlib${ii}$_zsytrs #endif - end interface sytrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytrs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytrs +#:endif +#:endfor +#:endfor + end interface sytrs interface sytrs2 !! SYTRS2 solves a system of linear equations A*X = B with a complex !! symmetric matrix A using the factorization A = U*D*U**T or !! A = L*D*L**T computed by CSYTRF and converted by CSYCONV. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csytrs2( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: work(*) end subroutine csytrs2 -#else - module procedure stdlib_csytrs2 +#else + module procedure stdlib${ii}$_csytrs2 #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsytrs2( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(out) :: work(*) end subroutine dsytrs2 -#else - module procedure stdlib_dsytrs2 +#else + module procedure stdlib${ii}$_dsytrs2 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytrs2 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssytrs2( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(out) :: work(*) end subroutine ssytrs2 -#else - module procedure stdlib_ssytrs2 +#else + module procedure stdlib${ii}$_ssytrs2 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytrs2 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsytrs2( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: work(*) end subroutine zsytrs2 -#else - module procedure stdlib_zsytrs2 +#else + module procedure stdlib${ii}$_zsytrs2 #endif - end interface sytrs2 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytrs2 +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytrs2 +#:endif +#:endfor +#:endfor + end interface sytrs2 interface sytrs_3 !! SYTRS_3 solves a system of linear equations A * X = B with a complex @@ -26741,225 +26659,225 @@ module stdlib_linalg_lapack !! 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. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) complex(sp), intent(in) :: a(lda,*),e(*) complex(sp), intent(inout) :: b(ldb,*) end subroutine csytrs_3 -#else - module procedure stdlib_csytrs_3 +#else + module procedure stdlib${ii}$_csytrs_3 #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) real(dp), intent(in) :: a(lda,*),e(*) real(dp), intent(inout) :: b(ldb,*) end subroutine dsytrs_3 -#else - module procedure stdlib_dsytrs_3 +#else + module procedure stdlib${ii}$_dsytrs_3 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytrs_3 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) real(sp), intent(in) :: a(lda,*),e(*) real(sp), intent(inout) :: b(ldb,*) end subroutine ssytrs_3 -#else - module procedure stdlib_ssytrs_3 +#else + module procedure stdlib${ii}$_ssytrs_3 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytrs_3 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) complex(dp), intent(in) :: a(lda,*),e(*) complex(dp), intent(inout) :: b(ldb,*) end subroutine zsytrs_3 -#else - module procedure stdlib_zsytrs_3 +#else + module procedure stdlib${ii}$_zsytrs_3 #endif - end interface sytrs_3 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytrs_3 +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytrs_3 +#:endif +#:endfor +#:endfor + end interface sytrs_3 interface sytrs_aa !! SYTRS_AA solves a system of linear equations A*X = B with a complex !! symmetric matrix A using the factorization A = U**T*T*U or !! A = L*T*L**T computed by CSYTRF_AA. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: n,nrhs,lda,ldb,lwork,ipiv(*) - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n,nrhs,lda,ldb,lwork,ipiv(*) + integer(${ik}$), intent(out) :: info complex(sp), intent(in) :: a(lda,*) complex(sp), intent(inout) :: b(ldb,*) complex(sp), intent(out) :: work(*) end subroutine csytrs_aa -#else - module procedure stdlib_csytrs_aa +#else + module procedure stdlib${ii}$_csytrs_aa #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: n,nrhs,lda,ldb,lwork,ipiv(*) - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n,nrhs,lda,ldb,lwork,ipiv(*) + integer(${ik}$), intent(out) :: info real(dp), intent(in) :: a(lda,*) real(dp), intent(inout) :: b(ldb,*) real(dp), intent(out) :: work(*) end subroutine dsytrs_aa -#else - module procedure stdlib_dsytrs_aa +#else + module procedure stdlib${ii}$_dsytrs_aa #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytrs_aa - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: n,nrhs,lda,ldb,lwork,ipiv(*) - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n,nrhs,lda,ldb,lwork,ipiv(*) + integer(${ik}$), intent(out) :: info real(sp), intent(in) :: a(lda,*) real(sp), intent(inout) :: b(ldb,*) real(sp), intent(out) :: work(*) end subroutine ssytrs_aa -#else - module procedure stdlib_ssytrs_aa +#else + module procedure stdlib${ii}$_ssytrs_aa #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytrs_aa - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(in) :: n,nrhs,lda,ldb,lwork,ipiv(*) - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n,nrhs,lda,ldb,lwork,ipiv(*) + integer(${ik}$), intent(out) :: info complex(dp), intent(in) :: a(lda,*) complex(dp), intent(inout) :: b(ldb,*) complex(dp), intent(out) :: work(*) end subroutine zsytrs_aa -#else - module procedure stdlib_zsytrs_aa +#else + module procedure stdlib${ii}$_zsytrs_aa #endif - end interface sytrs_aa +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytrs_aa +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytrs_aa +#:endif +#:endfor +#:endfor + end interface sytrs_aa interface sytrs_rook !! SYTRS_ROOK solves a system of linear equations A*X = B with !! a complex symmetric matrix A using the factorization A = U*D*U**T or !! A = L*D*L**T computed by CSYTRF_ROOK. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine csytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) complex(sp), intent(in) :: a(lda,*) complex(sp), intent(inout) :: b(ldb,*) end subroutine csytrs_rook -#else - module procedure stdlib_csytrs_rook +#else + module procedure stdlib${ii}$_csytrs_rook #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dsytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) real(dp), intent(in) :: a(lda,*) real(dp), intent(inout) :: b(ldb,*) end subroutine dsytrs_rook -#else - module procedure stdlib_dsytrs_rook +#else + module procedure stdlib${ii}$_dsytrs_rook #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytrs_rook - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ssytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) real(sp), intent(in) :: a(lda,*) real(sp), intent(inout) :: b(ldb,*) end subroutine ssytrs_rook -#else - module procedure stdlib_ssytrs_rook +#else + module procedure stdlib${ii}$_ssytrs_rook #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$sytrs_rook - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zsytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,n,nrhs,ipiv(*) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,n,nrhs,ipiv(*) complex(dp), intent(in) :: a(lda,*) complex(dp), intent(inout) :: b(ldb,*) end subroutine zsytrs_rook -#else - module procedure stdlib_zsytrs_rook +#else + module procedure stdlib${ii}$_zsytrs_rook #endif - end interface sytrs_rook +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytrs_rook +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$sytrs_rook +#:endif +#:endfor +#:endfor + end interface sytrs_rook interface tbcon !! TBCON estimates the reciprocal of the condition number of a @@ -26968,79 +26886,79 @@ module stdlib_linalg_lapack !! norm(inv(A)), then the reciprocal of the condition number is !! computed as !! RCOND = 1 / ( norm(A) * norm(inv(A)) ). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine ctbcon( norm, uplo, diag, n, kd, ab, ldab, rcond, work,rwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,norm,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) :: rcond,rwork(*) complex(sp), intent(in) :: ab(ldab,*) complex(sp), intent(out) :: work(*) end subroutine ctbcon -#else - module procedure stdlib_ctbcon +#else + module procedure stdlib${ii}$_ctbcon #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dtbcon( norm, uplo, diag, n, kd, ab, ldab, rcond, work,iwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,norm,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: kd,ldab,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: kd,ldab,n real(dp), intent(out) :: rcond,work(*) real(dp), intent(in) :: ab(ldab,*) end subroutine dtbcon -#else - module procedure stdlib_dtbcon +#else + module procedure stdlib${ii}$_dtbcon #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tbcon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine stbcon( norm, uplo, diag, n, kd, ab, ldab, rcond, work,iwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,norm,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: kd,ldab,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: kd,ldab,n real(sp), intent(out) :: rcond,work(*) real(sp), intent(in) :: ab(ldab,*) end subroutine stbcon -#else - module procedure stdlib_stbcon +#else + module procedure stdlib${ii}$_stbcon #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tbcon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine ztbcon( norm, uplo, diag, n, kd, ab, ldab, rcond, work,rwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,norm,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(dp), intent(out) :: rcond,rwork(*) complex(dp), intent(in) :: ab(ldab,*) complex(dp), intent(out) :: work(*) end subroutine ztbcon -#else - module procedure stdlib_ztbcon +#else + module procedure stdlib${ii}$_ztbcon #endif - end interface tbcon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tbcon +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tbcon +#:endif +#:endfor +#:endfor + end interface tbcon interface tbrfs !! TBRFS provides error bounds and backward error estimates for the @@ -27049,156 +26967,156 @@ module stdlib_linalg_lapack !! The solution matrix X must be computed by CTBTRS or some other !! means before entering this routine. TBRFS does not do iterative !! refinement because doing so cannot improve the backward error. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctbrfs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b,ldb, x, ldx, & ferr, berr, work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,trans,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kd,ldab,ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kd,ldab,ldb,ldx,n,nrhs real(sp), intent(out) :: berr(*),ferr(*),rwork(*) complex(sp), intent(in) :: ab(ldab,*),b(ldb,*),x(ldx,*) complex(sp), intent(out) :: work(*) end subroutine ctbrfs -#else - module procedure stdlib_ctbrfs +#else + module procedure stdlib${ii}$_ctbrfs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtbrfs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b,ldb, x, ldx, & ferr, berr, work, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,trans,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: kd,ldab,ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: kd,ldab,ldb,ldx,n,nrhs real(dp), intent(in) :: ab(ldab,*),b(ldb,*),x(ldx,*) real(dp), intent(out) :: berr(*),ferr(*),work(*) - end subroutine dtbrfs -#else - module procedure stdlib_dtbrfs -#endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tbrfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK + end subroutine dtbrfs +#else + module procedure stdlib${ii}$_dtbrfs +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stbrfs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b,ldb, x, ldx, & ferr, berr, work, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,trans,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: kd,ldab,ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: kd,ldab,ldb,ldx,n,nrhs real(sp), intent(in) :: ab(ldab,*),b(ldb,*),x(ldx,*) real(sp), intent(out) :: berr(*),ferr(*),work(*) end subroutine stbrfs -#else - module procedure stdlib_stbrfs +#else + module procedure stdlib${ii}$_stbrfs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tbrfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztbrfs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b,ldb, x, ldx, & ferr, berr, work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,trans,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kd,ldab,ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kd,ldab,ldb,ldx,n,nrhs real(dp), intent(out) :: berr(*),ferr(*),rwork(*) complex(dp), intent(in) :: ab(ldab,*),b(ldb,*),x(ldx,*) complex(dp), intent(out) :: work(*) end subroutine ztbrfs -#else - module procedure stdlib_ztbrfs +#else + module procedure stdlib${ii}$_ztbrfs #endif - end interface tbrfs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tbrfs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tbrfs +#:endif +#:endfor +#:endfor + end interface tbrfs interface tbtrs !! TBTRS solves a triangular system of the form !! A * X = B, A**T * X = B, or A**H * X = B, !! where A is a triangular band matrix of order N, and B is an !! N-by-NRHS matrix. A check is made to verify that A is nonsingular. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctbtrs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b,ldb, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,trans,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 complex(sp), intent(in) :: ab(ldab,*) complex(sp), intent(inout) :: b(ldb,*) end subroutine ctbtrs -#else - module procedure stdlib_ctbtrs +#else + module procedure stdlib${ii}$_ctbtrs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtbtrs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b,ldb, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,trans,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 real(dp), intent(in) :: ab(ldab,*) real(dp), intent(inout) :: b(ldb,*) end subroutine dtbtrs -#else - module procedure stdlib_dtbtrs +#else + module procedure stdlib${ii}$_dtbtrs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tbtrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stbtrs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b,ldb, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,trans,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 real(sp), intent(in) :: ab(ldab,*) real(sp), intent(inout) :: b(ldb,*) end subroutine stbtrs -#else - module procedure stdlib_stbtrs +#else + module procedure stdlib${ii}$_stbtrs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tbtrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztbtrs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b,ldb, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,trans,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 complex(dp), intent(in) :: ab(ldab,*) complex(dp), intent(inout) :: b(ldb,*) end subroutine ztbtrs -#else - module procedure stdlib_ztbtrs +#else + module procedure stdlib${ii}$_ztbtrs #endif - end interface tbtrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tbtrs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tbtrs +#:endif +#:endfor +#:endfor + end interface tbtrs interface tfsm !! Level 3 BLAS like routine for A in RFP Format. @@ -27209,283 +27127,283 @@ module stdlib_linalg_lapack !! op( A ) = A or op( A ) = A**H. !! A is in Rectangular Full Packed (RFP) Format. !! The matrix X is overwritten on B. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctfsm( transr, side, uplo, trans, diag, m, n, alpha, a,b, ldb ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,diag,side,trans,uplo - integer(ilp), intent(in) :: ldb,m,n + integer(${ik}$), intent(in) :: ldb,m,n complex(sp), intent(in) :: alpha,a(0:*) complex(sp), intent(inout) :: b(0:ldb-1,0:*) end subroutine ctfsm -#else - module procedure stdlib_ctfsm +#else + module procedure stdlib${ii}$_ctfsm #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtfsm( transr, side, uplo, trans, diag, m, n, alpha, a,b, ldb ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,diag,side,trans,uplo - integer(ilp), intent(in) :: ldb,m,n + integer(${ik}$), intent(in) :: ldb,m,n real(dp), intent(in) :: alpha,a(0:*) real(dp), intent(inout) :: b(0:ldb-1,0:*) end subroutine dtfsm -#else - module procedure stdlib_dtfsm +#else + module procedure stdlib${ii}$_dtfsm #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tfsm - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stfsm( transr, side, uplo, trans, diag, m, n, alpha, a,b, ldb ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,diag,side,trans,uplo - integer(ilp), intent(in) :: ldb,m,n + integer(${ik}$), intent(in) :: ldb,m,n real(sp), intent(in) :: alpha,a(0:*) real(sp), intent(inout) :: b(0:ldb-1,0:*) end subroutine stfsm -#else - module procedure stdlib_stfsm +#else + module procedure stdlib${ii}$_stfsm #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tfsm - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztfsm( transr, side, uplo, trans, diag, m, n, alpha, a,b, ldb ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,diag,side,trans,uplo - integer(ilp), intent(in) :: ldb,m,n + integer(${ik}$), intent(in) :: ldb,m,n complex(dp), intent(in) :: alpha,a(0:*) complex(dp), intent(inout) :: b(0:ldb-1,0:*) end subroutine ztfsm -#else - module procedure stdlib_ztfsm +#else + module procedure stdlib${ii}$_ztfsm #endif - end interface tfsm +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tfsm +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tfsm +#:endif +#:endfor +#:endfor + end interface tfsm interface tftri !! TFTRI computes the inverse of a triangular matrix A stored in RFP !! format. !! This is a Level 3 BLAS version of the algorithm. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctftri( transr, uplo, diag, n, a, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,uplo,diag - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n complex(sp), intent(inout) :: a(0:*) end subroutine ctftri -#else - module procedure stdlib_ctftri +#else + module procedure stdlib${ii}$_ctftri #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtftri( transr, uplo, diag, n, a, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,uplo,diag - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(dp), intent(inout) :: a(0:*) end subroutine dtftri -#else - module procedure stdlib_dtftri +#else + module procedure stdlib${ii}$_dtftri #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tftri - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stftri( transr, uplo, diag, n, a, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,uplo,diag - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(sp), intent(inout) :: a(0:*) end subroutine stftri -#else - module procedure stdlib_stftri +#else + module procedure stdlib${ii}$_stftri #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tftri - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztftri( transr, uplo, diag, n, a, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,uplo,diag - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n complex(dp), intent(inout) :: a(0:*) end subroutine ztftri -#else - module procedure stdlib_ztftri +#else + module procedure stdlib${ii}$_ztftri #endif - end interface tftri +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tftri +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tftri +#:endif +#:endfor +#:endfor + end interface tftri interface tfttp !! TFTTP copies a triangular matrix A from rectangular full packed !! format (TF) to standard packed format (TP). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctfttp( transr, uplo, n, arf, ap, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n complex(sp), intent(out) :: ap(0:*) complex(sp), intent(in) :: arf(0:*) end subroutine ctfttp -#else - module procedure stdlib_ctfttp +#else + module procedure stdlib${ii}$_ctfttp #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtfttp( transr, uplo, n, arf, ap, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(dp), intent(out) :: ap(0:*) real(dp), intent(in) :: arf(0:*) end subroutine dtfttp -#else - module procedure stdlib_dtfttp +#else + module procedure stdlib${ii}$_dtfttp #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tfttp - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stfttp( transr, uplo, n, arf, ap, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,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) :: ap(0:*) real(sp), intent(in) :: arf(0:*) end subroutine stfttp -#else - module procedure stdlib_stfttp +#else + module procedure stdlib${ii}$_stfttp #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tfttp - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztfttp( transr, uplo, n, arf, ap, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n complex(dp), intent(out) :: ap(0:*) complex(dp), intent(in) :: arf(0:*) end subroutine ztfttp -#else - module procedure stdlib_ztfttp +#else + module procedure stdlib${ii}$_ztfttp #endif - end interface tfttp +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tfttp +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tfttp +#:endif +#:endfor +#:endfor + end interface tfttp interface tfttr !! TFTTR copies a triangular matrix A from rectangular full packed !! format (TF) to standard full format (TR). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctfttr( transr, uplo, n, arf, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(out) :: a(0:lda-1,0:*) complex(sp), intent(in) :: arf(0:*) end subroutine ctfttr -#else - module procedure stdlib_ctfttr +#else + module procedure stdlib${ii}$_ctfttr #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtfttr( transr, uplo, n, arf, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(out) :: a(0:lda-1,0:*) real(dp), intent(in) :: arf(0:*) end subroutine dtfttr -#else - module procedure stdlib_dtfttr +#else + module procedure stdlib${ii}$_dtfttr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tfttr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stfttr( transr, uplo, n, arf, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(out) :: a(0:lda-1,0:*) real(sp), intent(in) :: arf(0:*) end subroutine stfttr -#else - module procedure stdlib_stfttr +#else + module procedure stdlib${ii}$_stfttr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tfttr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztfttr( transr, uplo, n, arf, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(out) :: a(0:lda-1,0:*) complex(dp), intent(in) :: arf(0:*) end subroutine ztfttr -#else - module procedure stdlib_ztfttr +#else + module procedure stdlib${ii}$_ztfttr #endif - end interface tfttr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tfttr +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tfttr +#:endif +#:endfor +#:endfor + end interface tfttr interface tgevc !! TGEVC computes some or all of the right and/or left eigenvectors of @@ -27506,87 +27424,87 @@ module stdlib_linalg_lapack !! If Q and Z are the unitary factors from the generalized Schur !! factorization of a matrix pair (A,B), then Z*X and Q*Y !! are the matrices of right and left eigenvectors of (A,B). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctgevc( side, howmny, select, n, s, lds, p, ldp, vl,ldvl, vr, ldvr,& mm, m, work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: howmny,side - integer(ilp), intent(out) :: info,m - integer(ilp), intent(in) :: ldp,lds,ldvl,ldvr,mm,n + integer(${ik}$), intent(out) :: info,m + integer(${ik}$), intent(in) :: ldp,lds,ldvl,ldvr,mm,n logical(lk), intent(in) :: select(*) real(sp), intent(out) :: rwork(*) complex(sp), intent(in) :: p(ldp,*),s(lds,*) complex(sp), intent(inout) :: vl(ldvl,*),vr(ldvr,*) complex(sp), intent(out) :: work(*) end subroutine ctgevc -#else - module procedure stdlib_ctgevc +#else + module procedure stdlib${ii}$_ctgevc #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtgevc( side, howmny, select, n, s, lds, p, ldp, vl,ldvl, vr, ldvr,& mm, m, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: howmny,side - integer(ilp), intent(out) :: info,m - integer(ilp), intent(in) :: ldp,lds,ldvl,ldvr,mm,n + integer(${ik}$), intent(out) :: info,m + integer(${ik}$), intent(in) :: ldp,lds,ldvl,ldvr,mm,n logical(lk), intent(in) :: select(*) real(dp), intent(in) :: p(ldp,*),s(lds,*) real(dp), intent(inout) :: vl(ldvl,*),vr(ldvr,*) real(dp), intent(out) :: work(*) end subroutine dtgevc -#else - module procedure stdlib_dtgevc +#else + module procedure stdlib${ii}$_dtgevc #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tgevc - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stgevc( side, howmny, select, n, s, lds, p, ldp, vl,ldvl, vr, ldvr,& mm, m, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: howmny,side - integer(ilp), intent(out) :: info,m - integer(ilp), intent(in) :: ldp,lds,ldvl,ldvr,mm,n + integer(${ik}$), intent(out) :: info,m + integer(${ik}$), intent(in) :: ldp,lds,ldvl,ldvr,mm,n logical(lk), intent(in) :: select(*) real(sp), intent(in) :: p(ldp,*),s(lds,*) real(sp), intent(inout) :: vl(ldvl,*),vr(ldvr,*) real(sp), intent(out) :: work(*) end subroutine stgevc -#else - module procedure stdlib_stgevc +#else + module procedure stdlib${ii}$_stgevc #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tgevc - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztgevc( side, howmny, select, n, s, lds, p, ldp, vl,ldvl, vr, ldvr,& mm, m, work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: howmny,side - integer(ilp), intent(out) :: info,m - integer(ilp), intent(in) :: ldp,lds,ldvl,ldvr,mm,n + integer(${ik}$), intent(out) :: info,m + integer(${ik}$), intent(in) :: ldp,lds,ldvl,ldvr,mm,n logical(lk), intent(in) :: select(*) real(dp), intent(out) :: rwork(*) complex(dp), intent(in) :: p(ldp,*),s(lds,*) complex(dp), intent(inout) :: vl(ldvl,*),vr(ldvr,*) complex(dp), intent(out) :: work(*) end subroutine ztgevc -#else - module procedure stdlib_ztgevc +#else + module procedure stdlib${ii}$_ztgevc #endif - end interface tgevc +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tgevc +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tgevc +#:endif +#:endfor +#:endfor + end interface tgevc interface tgexc !! TGEXC reorders the generalized Schur decomposition of a complex @@ -27599,79 +27517,79 @@ module stdlib_linalg_lapack !! updated. !! Q(in) * A(in) * Z(in)**H = Q(out) * A(out) * Z(out)**H !! Q(in) * B(in) * Z(in)**H = Q(out) * B(out) * Z(out)**H -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, ifst, ilst,& info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: wantq,wantz - integer(ilp), intent(in) :: ifst,lda,ldb,ldq,ldz,n - integer(ilp), intent(inout) :: ilst - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ifst,lda,ldb,ldq,ldz,n + integer(${ik}$), intent(inout) :: ilst + integer(${ik}$), intent(out) :: info complex(sp), intent(inout) :: a(lda,*),b(ldb,*),q(ldq,*),z(ldz,*) end subroutine ctgexc -#else - module procedure stdlib_ctgexc +#else + module procedure stdlib${ii}$_ctgexc #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, ifst, ilst,& work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: wantq,wantz - integer(ilp), intent(inout) :: ifst,ilst - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,ldq,ldz,lwork,n + integer(${ik}$), intent(inout) :: ifst,ilst + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,ldq,ldz,lwork,n real(dp), intent(inout) :: a(lda,*),b(ldb,*),q(ldq,*),z(ldz,*) real(dp), intent(out) :: work(*) end subroutine dtgexc -#else - module procedure stdlib_dtgexc +#else + module procedure stdlib${ii}$_dtgexc #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tgexc - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, ifst, ilst,& work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: wantq,wantz - integer(ilp), intent(inout) :: ifst,ilst - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,ldq,ldz,lwork,n + integer(${ik}$), intent(inout) :: ifst,ilst + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,ldq,ldz,lwork,n real(sp), intent(inout) :: a(lda,*),b(ldb,*),q(ldq,*),z(ldz,*) real(sp), intent(out) :: work(*) end subroutine stgexc -#else - module procedure stdlib_stgexc +#else + module procedure stdlib${ii}$_stgexc #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tgexc - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, ifst, ilst,& info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: wantq,wantz - integer(ilp), intent(in) :: ifst,lda,ldb,ldq,ldz,n - integer(ilp), intent(inout) :: ilst - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ifst,lda,ldb,ldq,ldz,n + integer(${ik}$), intent(inout) :: ilst + integer(${ik}$), intent(out) :: info complex(dp), intent(inout) :: a(lda,*),b(ldb,*),q(ldq,*),z(ldz,*) end subroutine ztgexc -#else - module procedure stdlib_ztgexc +#else + module procedure stdlib${ii}$_ztgexc #endif - end interface tgexc +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tgexc +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tgexc +#:endif +#:endfor +#:endfor + end interface tgexc interface tgsen !! TGSEN reorders the generalized Schur decomposition of a complex @@ -27692,83 +27610,83 @@ module stdlib_linalg_lapack !! the selected cluster and the eigenvalues outside the cluster, resp., !! and norms of "projections" onto left and right eigenspaces w.r.t. !! the selected cluster in the (1,1)-block. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctgsen( ijob, wantq, wantz, select, n, a, lda, b, ldb,alpha, beta, & q, ldq, z, ldz, m, pl, pr, dif,work, lwork, iwork, liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: wantq,wantz,select(*) - integer(ilp), intent(in) :: ijob,lda,ldb,ldq,ldz,liwork,lwork,n - integer(ilp), intent(out) :: info,m,iwork(*) + integer(${ik}$), intent(in) :: ijob,lda,ldb,ldq,ldz,liwork,lwork,n + integer(${ik}$), intent(out) :: info,m,iwork(*) real(sp), intent(out) :: pl,pr,dif(*) complex(sp), intent(inout) :: a(lda,*),b(ldb,*),q(ldq,*),z(ldz,*) complex(sp), intent(out) :: alpha(*),beta(*),work(*) end subroutine ctgsen -#else - module procedure stdlib_ctgsen +#else + module procedure stdlib${ii}$_ctgsen #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtgsen( ijob, wantq, wantz, select, n, a, lda, b, ldb,alphar, & alphai, beta, q, ldq, z, ldz, m, pl,pr, dif, work, lwork, iwork, liwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: wantq,wantz,select(*) - integer(ilp), intent(in) :: ijob,lda,ldb,ldq,ldz,liwork,lwork,n - integer(ilp), intent(out) :: info,m,iwork(*) + integer(${ik}$), intent(in) :: ijob,lda,ldb,ldq,ldz,liwork,lwork,n + integer(${ik}$), intent(out) :: info,m,iwork(*) real(dp), intent(out) :: pl,pr,alphai(*),alphar(*),beta(*),dif(*),work(*) - + real(dp), intent(inout) :: a(lda,*),b(ldb,*),q(ldq,*),z(ldz,*) end subroutine dtgsen -#else - module procedure stdlib_dtgsen +#else + module procedure stdlib${ii}$_dtgsen #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tgsen - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stgsen( ijob, wantq, wantz, select, n, a, lda, b, ldb,alphar, & alphai, beta, q, ldq, z, ldz, m, pl,pr, dif, work, lwork, iwork, liwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: wantq,wantz,select(*) - integer(ilp), intent(in) :: ijob,lda,ldb,ldq,ldz,liwork,lwork,n - integer(ilp), intent(out) :: info,m,iwork(*) + integer(${ik}$), intent(in) :: ijob,lda,ldb,ldq,ldz,liwork,lwork,n + integer(${ik}$), intent(out) :: info,m,iwork(*) real(sp), intent(out) :: pl,pr,alphai(*),alphar(*),beta(*),dif(*),work(*) - + real(sp), intent(inout) :: a(lda,*),b(ldb,*),q(ldq,*),z(ldz,*) end subroutine stgsen -#else - module procedure stdlib_stgsen +#else + module procedure stdlib${ii}$_stgsen #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tgsen - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztgsen( ijob, wantq, wantz, select, n, a, lda, b, ldb,alpha, beta, & q, ldq, z, ldz, m, pl, pr, dif,work, lwork, iwork, liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) logical(lk), intent(in) :: wantq,wantz,select(*) - integer(ilp), intent(in) :: ijob,lda,ldb,ldq,ldz,liwork,lwork,n - integer(ilp), intent(out) :: info,m,iwork(*) + integer(${ik}$), intent(in) :: ijob,lda,ldb,ldq,ldz,liwork,lwork,n + integer(${ik}$), intent(out) :: info,m,iwork(*) real(dp), intent(out) :: pl,pr,dif(*) complex(dp), intent(inout) :: a(lda,*),b(ldb,*),q(ldq,*),z(ldz,*) complex(dp), intent(out) :: alpha(*),beta(*),work(*) end subroutine ztgsen -#else - module procedure stdlib_ztgsen +#else + module procedure stdlib${ii}$_ztgsen #endif - end interface tgsen +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tgsen +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tgsen +#:endif +#:endfor +#:endfor + end interface tgsen interface tgsja !! TGSJA computes the generalized singular value decomposition (GSVD) @@ -27833,170 +27751,170 @@ module stdlib_linalg_lapack !! The computation of the unitary transformation matrices U, V or Q !! is optional. These matrices may either be formed explicitly, or they !! may be postmultiplied into input matrices U1, V1, or Q1. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctgsja( jobu, jobv, jobq, m, p, n, k, l, a, lda, b,ldb, tola, tolb,& alpha, beta, u, ldu, v, ldv,q, ldq, work, ncycle, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobq,jobu,jobv - integer(ilp), intent(out) :: info,ncycle - integer(ilp), intent(in) :: k,l,lda,ldb,ldq,ldu,ldv,m,n,p + integer(${ik}$), intent(out) :: info,ncycle + integer(${ik}$), intent(in) :: k,l,lda,ldb,ldq,ldu,ldv,m,n,p real(sp), intent(in) :: tola,tolb real(sp), intent(out) :: alpha(*),beta(*) complex(sp), intent(inout) :: a(lda,*),b(ldb,*),q(ldq,*),u(ldu,*),v(ldv,*) - + complex(sp), intent(out) :: work(*) end subroutine ctgsja -#else - module procedure stdlib_ctgsja +#else + module procedure stdlib${ii}$_ctgsja #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtgsja( jobu, jobv, jobq, m, p, n, k, l, a, lda, b,ldb, tola, tolb,& alpha, beta, u, ldu, v, ldv,q, ldq, work, ncycle, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobq,jobu,jobv - integer(ilp), intent(out) :: info,ncycle - integer(ilp), intent(in) :: k,l,lda,ldb,ldq,ldu,ldv,m,n,p + integer(${ik}$), intent(out) :: info,ncycle + integer(${ik}$), intent(in) :: k,l,lda,ldb,ldq,ldu,ldv,m,n,p real(dp), intent(in) :: tola,tolb real(dp), intent(inout) :: a(lda,*),b(ldb,*),q(ldq,*),u(ldu,*),v(ldv,*) - + real(dp), intent(out) :: alpha(*),beta(*),work(*) end subroutine dtgsja -#else - module procedure stdlib_dtgsja +#else + module procedure stdlib${ii}$_dtgsja #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tgsja - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stgsja( jobu, jobv, jobq, m, p, n, k, l, a, lda, b,ldb, tola, tolb,& alpha, beta, u, ldu, v, ldv,q, ldq, work, ncycle, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobq,jobu,jobv - integer(ilp), intent(out) :: info,ncycle - integer(ilp), intent(in) :: k,l,lda,ldb,ldq,ldu,ldv,m,n,p + integer(${ik}$), intent(out) :: info,ncycle + integer(${ik}$), intent(in) :: k,l,lda,ldb,ldq,ldu,ldv,m,n,p real(sp), intent(in) :: tola,tolb real(sp), intent(inout) :: a(lda,*),b(ldb,*),q(ldq,*),u(ldu,*),v(ldv,*) - + real(sp), intent(out) :: alpha(*),beta(*),work(*) end subroutine stgsja -#else - module procedure stdlib_stgsja +#else + module procedure stdlib${ii}$_stgsja #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tgsja - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztgsja( jobu, jobv, jobq, m, p, n, k, l, a, lda, b,ldb, tola, tolb,& alpha, beta, u, ldu, v, ldv,q, ldq, work, ncycle, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobq,jobu,jobv - integer(ilp), intent(out) :: info,ncycle - integer(ilp), intent(in) :: k,l,lda,ldb,ldq,ldu,ldv,m,n,p + integer(${ik}$), intent(out) :: info,ncycle + integer(${ik}$), intent(in) :: k,l,lda,ldb,ldq,ldu,ldv,m,n,p real(dp), intent(in) :: tola,tolb real(dp), intent(out) :: alpha(*),beta(*) complex(dp), intent(inout) :: a(lda,*),b(ldb,*),q(ldq,*),u(ldu,*),v(ldv,*) - + complex(dp), intent(out) :: work(*) end subroutine ztgsja -#else - module procedure stdlib_ztgsja +#else + module procedure stdlib${ii}$_ztgsja #endif - end interface tgsja +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tgsja +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tgsja +#:endif +#:endfor +#:endfor + end interface tgsja interface tgsna !! TGSNA estimates reciprocal condition numbers for specified !! eigenvalues and/or eigenvectors of a matrix pair (A, B). !! (A, B) must be in generalized Schur canonical form, that is, A and !! B are both upper triangular. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctgsna( job, howmny, select, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, & s, dif, mm, m, work, lwork,iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: howmny,job - integer(ilp), intent(out) :: info,m,iwork(*) - integer(ilp), intent(in) :: lda,ldb,ldvl,ldvr,lwork,mm,n + integer(${ik}$), intent(out) :: info,m,iwork(*) + integer(${ik}$), intent(in) :: lda,ldb,ldvl,ldvr,lwork,mm,n logical(lk), intent(in) :: select(*) real(sp), intent(out) :: dif(*),s(*) complex(sp), intent(in) :: a(lda,*),b(ldb,*),vl(ldvl,*),vr(ldvr,*) complex(sp), intent(out) :: work(*) end subroutine ctgsna -#else - module procedure stdlib_ctgsna +#else + module procedure stdlib${ii}$_ctgsna #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtgsna( job, howmny, select, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, & s, dif, mm, m, work, lwork,iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: howmny,job - integer(ilp), intent(out) :: info,m,iwork(*) - integer(ilp), intent(in) :: lda,ldb,ldvl,ldvr,lwork,mm,n + integer(${ik}$), intent(out) :: info,m,iwork(*) + integer(${ik}$), intent(in) :: lda,ldb,ldvl,ldvr,lwork,mm,n logical(lk), intent(in) :: select(*) real(dp), intent(in) :: a(lda,*),b(ldb,*),vl(ldvl,*),vr(ldvr,*) real(dp), intent(out) :: dif(*),s(*),work(*) end subroutine dtgsna -#else - module procedure stdlib_dtgsna +#else + module procedure stdlib${ii}$_dtgsna #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tgsna - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stgsna( job, howmny, select, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, & s, dif, mm, m, work, lwork,iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: howmny,job - integer(ilp), intent(out) :: info,m,iwork(*) - integer(ilp), intent(in) :: lda,ldb,ldvl,ldvr,lwork,mm,n + integer(${ik}$), intent(out) :: info,m,iwork(*) + integer(${ik}$), intent(in) :: lda,ldb,ldvl,ldvr,lwork,mm,n logical(lk), intent(in) :: select(*) real(sp), intent(in) :: a(lda,*),b(ldb,*),vl(ldvl,*),vr(ldvr,*) real(sp), intent(out) :: dif(*),s(*),work(*) end subroutine stgsna -#else - module procedure stdlib_stgsna +#else + module procedure stdlib${ii}$_stgsna #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tgsna - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztgsna( job, howmny, select, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, & s, dif, mm, m, work, lwork,iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: howmny,job - integer(ilp), intent(out) :: info,m,iwork(*) - integer(ilp), intent(in) :: lda,ldb,ldvl,ldvr,lwork,mm,n + integer(${ik}$), intent(out) :: info,m,iwork(*) + integer(${ik}$), intent(in) :: lda,ldb,ldvl,ldvr,lwork,mm,n logical(lk), intent(in) :: select(*) real(dp), intent(out) :: dif(*),s(*) complex(dp), intent(in) :: a(lda,*),b(ldb,*),vl(ldvl,*),vr(ldvr,*) complex(dp), intent(out) :: work(*) end subroutine ztgsna -#else - module procedure stdlib_ztgsna +#else + module procedure stdlib${ii}$_ztgsna #endif - end interface tgsna +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tgsna +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tgsna +#:endif +#:endfor +#:endfor + end interface tgsna interface tgsyl !! TGSYL solves the generalized Sylvester equation: @@ -28026,83 +27944,83 @@ module stdlib_linalg_lapack !! Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the !! reciprocal of the smallest singular value of Z. !! This is a level-3 BLAS algorithm. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctgsyl( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, & f, ldf, scale, dif, work, lwork,iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(in) :: ijob,lda,ldb,ldc,ldd,lde,ldf,lwork,m,n - integer(ilp), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ijob,lda,ldb,ldc,ldd,lde,ldf,lwork,m,n + integer(${ik}$), intent(out) :: info,iwork(*) real(sp), intent(out) :: dif,scale complex(sp), intent(in) :: a(lda,*),b(ldb,*),d(ldd,*),e(lde,*) complex(sp), intent(inout) :: c(ldc,*),f(ldf,*) complex(sp), intent(out) :: work(*) end subroutine ctgsyl -#else - module procedure stdlib_ctgsyl +#else + module procedure stdlib${ii}$_ctgsyl #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtgsyl( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, & f, ldf, scale, dif, work, lwork,iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(in) :: ijob,lda,ldb,ldc,ldd,lde,ldf,lwork,m,n - integer(ilp), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ijob,lda,ldb,ldc,ldd,lde,ldf,lwork,m,n + integer(${ik}$), intent(out) :: info,iwork(*) real(dp), intent(out) :: dif,scale,work(*) real(dp), intent(in) :: a(lda,*),b(ldb,*),d(ldd,*),e(lde,*) real(dp), intent(inout) :: c(ldc,*),f(ldf,*) end subroutine dtgsyl -#else - module procedure stdlib_dtgsyl +#else + module procedure stdlib${ii}$_dtgsyl #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tgsyl - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stgsyl( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, & f, ldf, scale, dif, work, lwork,iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(in) :: ijob,lda,ldb,ldc,ldd,lde,ldf,lwork,m,n - integer(ilp), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ijob,lda,ldb,ldc,ldd,lde,ldf,lwork,m,n + integer(${ik}$), intent(out) :: info,iwork(*) real(sp), intent(out) :: dif,scale,work(*) real(sp), intent(in) :: a(lda,*),b(ldb,*),d(ldd,*),e(lde,*) real(sp), intent(inout) :: c(ldc,*),f(ldf,*) - end subroutine stgsyl -#else - module procedure stdlib_stgsyl -#endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tgsyl - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK + end subroutine stgsyl +#else + module procedure stdlib${ii}$_stgsyl +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztgsyl( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, & f, ldf, scale, dif, work, lwork,iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trans - integer(ilp), intent(in) :: ijob,lda,ldb,ldc,ldd,lde,ldf,lwork,m,n - integer(ilp), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ijob,lda,ldb,ldc,ldd,lde,ldf,lwork,m,n + integer(${ik}$), intent(out) :: info,iwork(*) real(dp), intent(out) :: dif,scale complex(dp), intent(in) :: a(lda,*),b(ldb,*),d(ldd,*),e(lde,*) complex(dp), intent(inout) :: c(ldc,*),f(ldf,*) complex(dp), intent(out) :: work(*) end subroutine ztgsyl -#else - module procedure stdlib_ztgsyl +#else + module procedure stdlib${ii}$_ztgsyl #endif - end interface tgsyl +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tgsyl +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tgsyl +#:endif +#:endfor +#:endfor + end interface tgsyl interface tpcon !! TPCON estimates the reciprocal of the condition number of a packed @@ -28111,585 +28029,585 @@ module stdlib_linalg_lapack !! norm(inv(A)), then the reciprocal of the condition number is !! computed as !! RCOND = 1 / ( norm(A) * norm(inv(A)) ). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine ctpcon( norm, uplo, diag, n, ap, rcond, work, rwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,norm,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) :: rcond,rwork(*) complex(sp), intent(in) :: ap(*) complex(sp), intent(out) :: work(*) end subroutine ctpcon -#else - module procedure stdlib_ctpcon +#else + module procedure stdlib${ii}$_ctpcon #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dtpcon( norm, uplo, diag, n, ap, rcond, work, iwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,norm,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: n real(dp), intent(out) :: rcond,work(*) real(dp), intent(in) :: ap(*) end subroutine dtpcon -#else - module procedure stdlib_dtpcon +#else + module procedure stdlib${ii}$_dtpcon #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tpcon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine stpcon( norm, uplo, diag, n, ap, rcond, work, iwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,norm,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: n real(sp), intent(out) :: rcond,work(*) real(sp), intent(in) :: ap(*) end subroutine stpcon -#else - module procedure stdlib_stpcon +#else + module procedure stdlib${ii}$_stpcon #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tpcon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine ztpcon( norm, uplo, diag, n, ap, rcond, work, rwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,norm,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(dp), intent(out) :: rcond,rwork(*) complex(dp), intent(in) :: ap(*) complex(dp), intent(out) :: work(*) end subroutine ztpcon -#else - module procedure stdlib_ztpcon +#else + module procedure stdlib${ii}$_ztpcon #endif - end interface tpcon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tpcon +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tpcon +#:endif +#:endfor +#:endfor + end interface tpcon interface tplqt !! TPLQT computes a blocked LQ factorization of a complex !! "triangular-pentagonal" matrix C, which is composed of a !! triangular block A and pentagonal block B, using the compact !! WY representation for Q. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctplqt( m, n, l, mb, a, lda, b, ldb, t, ldt, work,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,ldt,n,m,l,mb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,ldt,n,m,l,mb complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: t(ldt,*),work(*) end subroutine ctplqt -#else - module procedure stdlib_ctplqt +#else + module procedure stdlib${ii}$_ctplqt #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtplqt( m, n, l, mb, a, lda, b, ldb, t, ldt, work,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,ldt,n,m,l,mb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,ldt,n,m,l,mb real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(out) :: t(ldt,*),work(*) end subroutine dtplqt -#else - module procedure stdlib_dtplqt +#else + module procedure stdlib${ii}$_dtplqt #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tplqt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stplqt( m, n, l, mb, a, lda, b, ldb, t, ldt, work,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,ldt,n,m,l,mb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,ldt,n,m,l,mb real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(out) :: t(ldt,*),work(*) end subroutine stplqt -#else - module procedure stdlib_stplqt +#else + module procedure stdlib${ii}$_stplqt #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tplqt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztplqt( m, n, l, mb, a, lda, b, ldb, t, ldt, work,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,ldt,n,m,l,mb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,ldt,n,m,l,mb complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: t(ldt,*),work(*) end subroutine ztplqt -#else - module procedure stdlib_ztplqt +#else + module procedure stdlib${ii}$_ztplqt #endif - end interface tplqt +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tplqt +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tplqt +#:endif +#:endfor +#:endfor + end interface tplqt interface tplqt2 !! TPLQT2 computes a LQ a factorization of a complex "triangular-pentagonal" !! matrix C, which is composed of a triangular block A and pentagonal block B, !! using the compact WY representation for Q. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctplqt2( m, n, l, a, lda, b, ldb, t, ldt, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,ldt,n,m,l + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,ldt,n,m,l complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: t(ldt,*) end subroutine ctplqt2 -#else - module procedure stdlib_ctplqt2 +#else + module procedure stdlib${ii}$_ctplqt2 #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtplqt2( m, n, l, a, lda, b, ldb, t, ldt, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,ldt,n,m,l + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,ldt,n,m,l real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(out) :: t(ldt,*) end subroutine dtplqt2 -#else - module procedure stdlib_dtplqt2 +#else + module procedure stdlib${ii}$_dtplqt2 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tplqt2 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stplqt2( m, n, l, a, lda, b, ldb, t, ldt, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,ldt,n,m,l + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,ldt,n,m,l real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(out) :: t(ldt,*) end subroutine stplqt2 -#else - module procedure stdlib_stplqt2 +#else + module procedure stdlib${ii}$_stplqt2 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tplqt2 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztplqt2( m, n, l, a, lda, b, ldb, t, ldt, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,ldt,n,m,l + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,ldt,n,m,l complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: t(ldt,*) end subroutine ztplqt2 -#else - module procedure stdlib_ztplqt2 +#else + module procedure stdlib${ii}$_ztplqt2 #endif - end interface tplqt2 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tplqt2 +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tplqt2 +#:endif +#:endfor +#:endfor + end interface tplqt2 interface tpmlqt !! TPMLQT applies a complex unitary matrix Q obtained from a !! "triangular-pentagonal" complex block reflector H to a general !! complex matrix C, which consists of two blocks A and B. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctpmlqt( side, trans, m, n, k, l, mb, v, ldv, t, ldt,a, lda, b, & ldb, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,ldv,lda,ldb,m,n,l,mb,ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,ldv,lda,ldb,m,n,l,mb,ldt complex(sp), intent(in) :: v(ldv,*),t(ldt,*) complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: work(*) end subroutine ctpmlqt -#else - module procedure stdlib_ctpmlqt +#else + module procedure stdlib${ii}$_ctpmlqt #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtpmlqt( side, trans, m, n, k, l, mb, v, ldv, t, ldt,a, lda, b, & ldb, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,ldv,lda,ldb,m,n,l,mb,ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,ldv,lda,ldb,m,n,l,mb,ldt real(dp), intent(in) :: v(ldv,*),t(ldt,*) real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(out) :: work(*) end subroutine dtpmlqt -#else - module procedure stdlib_dtpmlqt +#else + module procedure stdlib${ii}$_dtpmlqt #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tpmlqt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stpmlqt( side, trans, m, n, k, l, mb, v, ldv, t, ldt,a, lda, b, & ldb, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,ldv,lda,ldb,m,n,l,mb,ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,ldv,lda,ldb,m,n,l,mb,ldt real(sp), intent(in) :: v(ldv,*),t(ldt,*) real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(out) :: work(*) end subroutine stpmlqt -#else - module procedure stdlib_stpmlqt +#else + module procedure stdlib${ii}$_stpmlqt #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tpmlqt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztpmlqt( side, trans, m, n, k, l, mb, v, ldv, t, ldt,a, lda, b, & ldb, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,ldv,lda,ldb,m,n,l,mb,ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,ldv,lda,ldb,m,n,l,mb,ldt complex(dp), intent(in) :: v(ldv,*),t(ldt,*) complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: work(*) end subroutine ztpmlqt -#else - module procedure stdlib_ztpmlqt +#else + module procedure stdlib${ii}$_ztpmlqt #endif - end interface tpmlqt +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tpmlqt +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tpmlqt +#:endif +#:endfor +#:endfor + end interface tpmlqt interface tpmqrt !! TPMQRT applies a complex orthogonal matrix Q obtained from a !! "triangular-pentagonal" complex block reflector H to a general !! complex matrix C, which consists of two blocks A and B. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctpmqrt( side, trans, m, n, k, l, nb, v, ldv, t, ldt,a, lda, b, & ldb, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,ldv,lda,ldb,m,n,l,nb,ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,ldv,lda,ldb,m,n,l,nb,ldt complex(sp), intent(in) :: v(ldv,*),t(ldt,*) complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: work(*) end subroutine ctpmqrt -#else - module procedure stdlib_ctpmqrt +#else + module procedure stdlib${ii}$_ctpmqrt #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtpmqrt( side, trans, m, n, k, l, nb, v, ldv, t, ldt,a, lda, b, & ldb, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,ldv,lda,ldb,m,n,l,nb,ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,ldv,lda,ldb,m,n,l,nb,ldt real(dp), intent(in) :: v(ldv,*),t(ldt,*) real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(out) :: work(*) end subroutine dtpmqrt -#else - module procedure stdlib_dtpmqrt +#else + module procedure stdlib${ii}$_dtpmqrt #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tpmqrt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stpmqrt( side, trans, m, n, k, l, nb, v, ldv, t, ldt,a, lda, b, & ldb, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,ldv,lda,ldb,m,n,l,nb,ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,ldv,lda,ldb,m,n,l,nb,ldt real(sp), intent(in) :: v(ldv,*),t(ldt,*) real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(out) :: work(*) end subroutine stpmqrt -#else - module procedure stdlib_stpmqrt +#else + module procedure stdlib${ii}$_stpmqrt #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tpmqrt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztpmqrt( side, trans, m, n, k, l, nb, v, ldv, t, ldt,a, lda, b, & ldb, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,ldv,lda,ldb,m,n,l,nb,ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,ldv,lda,ldb,m,n,l,nb,ldt complex(dp), intent(in) :: v(ldv,*),t(ldt,*) complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: work(*) end subroutine ztpmqrt -#else - module procedure stdlib_ztpmqrt +#else + module procedure stdlib${ii}$_ztpmqrt #endif - end interface tpmqrt +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tpmqrt +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tpmqrt +#:endif +#:endfor +#:endfor + end interface tpmqrt interface tpqrt !! TPQRT computes a blocked QR factorization of a complex !! "triangular-pentagonal" matrix C, which is composed of a !! triangular block A and pentagonal block B, using the compact !! WY representation for Q. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctpqrt( m, n, l, nb, a, lda, b, ldb, t, ldt, work,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,ldt,n,m,l,nb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,ldt,n,m,l,nb complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: t(ldt,*),work(*) end subroutine ctpqrt -#else - module procedure stdlib_ctpqrt +#else + module procedure stdlib${ii}$_ctpqrt #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtpqrt( m, n, l, nb, a, lda, b, ldb, t, ldt, work,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,ldt,n,m,l,nb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,ldt,n,m,l,nb real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(out) :: t(ldt,*),work(*) end subroutine dtpqrt -#else - module procedure stdlib_dtpqrt +#else + module procedure stdlib${ii}$_dtpqrt #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tpqrt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stpqrt( m, n, l, nb, a, lda, b, ldb, t, ldt, work,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,ldt,n,m,l,nb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,ldt,n,m,l,nb real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(out) :: t(ldt,*),work(*) end subroutine stpqrt -#else - module procedure stdlib_stpqrt +#else + module procedure stdlib${ii}$_stpqrt #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tpqrt - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztpqrt( m, n, l, nb, a, lda, b, ldb, t, ldt, work,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,ldt,n,m,l,nb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,ldt,n,m,l,nb complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: t(ldt,*),work(*) end subroutine ztpqrt -#else - module procedure stdlib_ztpqrt +#else + module procedure stdlib${ii}$_ztpqrt #endif - end interface tpqrt +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tpqrt +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tpqrt +#:endif +#:endfor +#:endfor + end interface tpqrt interface tpqrt2 !! TPQRT2 computes a QR factorization of a complex "triangular-pentagonal" !! matrix C, which is composed of a triangular block A and pentagonal block B, !! using the compact WY representation for Q. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctpqrt2( m, n, l, a, lda, b, ldb, t, ldt, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,ldt,n,m,l + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,ldt,n,m,l complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(out) :: t(ldt,*) end subroutine ctpqrt2 -#else - module procedure stdlib_ctpqrt2 +#else + module procedure stdlib${ii}$_ctpqrt2 #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtpqrt2( m, n, l, a, lda, b, ldb, t, ldt, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,ldt,n,m,l + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,ldt,n,m,l real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(out) :: t(ldt,*) end subroutine dtpqrt2 -#else - module procedure stdlib_dtpqrt2 +#else + module procedure stdlib${ii}$_dtpqrt2 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tpqrt2 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stpqrt2( m, n, l, a, lda, b, ldb, t, ldt, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,ldt,n,m,l + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,ldt,n,m,l real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(out) :: t(ldt,*) end subroutine stpqrt2 -#else - module procedure stdlib_stpqrt2 +#else + module procedure stdlib${ii}$_stpqrt2 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tpqrt2 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztpqrt2( m, n, l, a, lda, b, ldb, t, ldt, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,ldt,n,m,l + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,ldt,n,m,l complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(out) :: t(ldt,*) end subroutine ztpqrt2 -#else - module procedure stdlib_ztpqrt2 +#else + module procedure stdlib${ii}$_ztpqrt2 #endif - end interface tpqrt2 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tpqrt2 +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tpqrt2 +#:endif +#:endfor +#:endfor + end interface tpqrt2 interface tprfb !! TPRFB applies a complex "triangular-pentagonal" block reflector H or its !! conjugate transpose H**H to a complex matrix C, which is composed of two !! blocks A and B, either from the left or right. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctprfb( side, trans, direct, storev, m, n, k, l,v, ldv, t, ldt, a, & lda, b, ldb, work, ldwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: direct,side,storev,trans - integer(ilp), intent(in) :: k,l,lda,ldb,ldt,ldv,ldwork,m,n + integer(${ik}$), intent(in) :: k,l,lda,ldb,ldt,ldv,ldwork,m,n complex(sp), intent(inout) :: a(lda,*),b(ldb,*) complex(sp), intent(in) :: t(ldt,*),v(ldv,*) complex(sp), intent(out) :: work(ldwork,*) end subroutine ctprfb -#else - module procedure stdlib_ctprfb +#else + module procedure stdlib${ii}$_ctprfb #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtprfb( side, trans, direct, storev, m, n, k, l,v, ldv, t, ldt, a, & lda, b, ldb, work, ldwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: direct,side,storev,trans - integer(ilp), intent(in) :: k,l,lda,ldb,ldt,ldv,ldwork,m,n + integer(${ik}$), intent(in) :: k,l,lda,ldb,ldt,ldv,ldwork,m,n real(dp), intent(inout) :: a(lda,*),b(ldb,*) real(dp), intent(in) :: t(ldt,*),v(ldv,*) real(dp), intent(out) :: work(ldwork,*) end subroutine dtprfb -#else - module procedure stdlib_dtprfb +#else + module procedure stdlib${ii}$_dtprfb #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tprfb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stprfb( side, trans, direct, storev, m, n, k, l,v, ldv, t, ldt, a, & lda, b, ldb, work, ldwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: direct,side,storev,trans - integer(ilp), intent(in) :: k,l,lda,ldb,ldt,ldv,ldwork,m,n + integer(${ik}$), intent(in) :: k,l,lda,ldb,ldt,ldv,ldwork,m,n real(sp), intent(inout) :: a(lda,*),b(ldb,*) real(sp), intent(in) :: t(ldt,*),v(ldv,*) real(sp), intent(out) :: work(ldwork,*) end subroutine stprfb -#else - module procedure stdlib_stprfb +#else + module procedure stdlib${ii}$_stprfb #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tprfb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztprfb( side, trans, direct, storev, m, n, k, l,v, ldv, t, ldt, a, & lda, b, ldb, work, ldwork ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: direct,side,storev,trans - integer(ilp), intent(in) :: k,l,lda,ldb,ldt,ldv,ldwork,m,n + integer(${ik}$), intent(in) :: k,l,lda,ldb,ldt,ldv,ldwork,m,n complex(dp), intent(inout) :: a(lda,*),b(ldb,*) complex(dp), intent(in) :: t(ldt,*),v(ldv,*) complex(dp), intent(out) :: work(ldwork,*) end subroutine ztprfb -#else - module procedure stdlib_ztprfb +#else + module procedure stdlib${ii}$_ztprfb #endif - end interface tprfb +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tprfb +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tprfb +#:endif +#:endfor +#:endfor + end interface tprfb interface tprfs !! TPRFS provides error bounds and backward error estimates for the @@ -28698,146 +28616,146 @@ module stdlib_linalg_lapack !! The solution matrix X must be computed by CTPTRS or some other !! means before entering this routine. TPRFS does not do iterative !! refinement because doing so cannot improve the backward error. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctprfs( uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx,ferr, berr, & work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,trans,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,ldx,n,nrhs real(sp), intent(out) :: berr(*),ferr(*),rwork(*) complex(sp), intent(in) :: ap(*),b(ldb,*),x(ldx,*) complex(sp), intent(out) :: work(*) end subroutine ctprfs -#else - module procedure stdlib_ctprfs +#else + module procedure stdlib${ii}$_ctprfs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtprfs( uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx,ferr, berr, & work, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,trans,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldb,ldx,n,nrhs real(dp), intent(in) :: ap(*),b(ldb,*),x(ldx,*) real(dp), intent(out) :: berr(*),ferr(*),work(*) end subroutine dtprfs -#else - module procedure stdlib_dtprfs +#else + module procedure stdlib${ii}$_dtprfs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tprfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stprfs( uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx,ferr, berr, & work, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,trans,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldb,ldx,n,nrhs real(sp), intent(in) :: ap(*),b(ldb,*),x(ldx,*) real(sp), intent(out) :: berr(*),ferr(*),work(*) end subroutine stprfs -#else - module procedure stdlib_stprfs +#else + module procedure stdlib${ii}$_stprfs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tprfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztprfs( uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx,ferr, berr, & work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,trans,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,ldx,n,nrhs real(dp), intent(out) :: berr(*),ferr(*),rwork(*) complex(dp), intent(in) :: ap(*),b(ldb,*),x(ldx,*) complex(dp), intent(out) :: work(*) end subroutine ztprfs -#else - module procedure stdlib_ztprfs +#else + module procedure stdlib${ii}$_ztprfs #endif - end interface tprfs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tprfs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tprfs +#:endif +#:endfor +#:endfor + end interface tprfs interface tptri !! TPTRI computes the inverse of a complex upper or lower triangular !! matrix A stored in packed format. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctptri( uplo, diag, n, ap, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n complex(sp), intent(inout) :: ap(*) end subroutine ctptri -#else - module procedure stdlib_ctptri +#else + module procedure stdlib${ii}$_ctptri #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtptri( uplo, diag, n, ap, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(dp), intent(inout) :: ap(*) end subroutine dtptri -#else - module procedure stdlib_dtptri +#else + module procedure stdlib${ii}$_dtptri #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tptri - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stptri( uplo, diag, n, ap, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(sp), intent(inout) :: ap(*) end subroutine stptri -#else - module procedure stdlib_stptri +#else + module procedure stdlib${ii}$_stptri #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tptri - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztptri( uplo, diag, n, ap, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n complex(dp), intent(inout) :: ap(*) end subroutine ztptri -#else - module procedure stdlib_ztptri +#else + module procedure stdlib${ii}$_ztptri #endif - end interface tptri +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tptri +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tptri +#:endif +#:endfor +#:endfor + end interface tptri interface tptrs !! TPTRS solves a triangular system of the form @@ -28845,215 +28763,215 @@ module stdlib_linalg_lapack !! where A is a triangular matrix of order N stored in packed format, !! and B is an N-by-NRHS matrix. A check is made to verify that A is !! nonsingular. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctptrs( uplo, trans, diag, n, nrhs, ap, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,trans,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs complex(sp), intent(in) :: ap(*) complex(sp), intent(inout) :: b(ldb,*) end subroutine ctptrs -#else - module procedure stdlib_ctptrs +#else + module procedure stdlib${ii}$_ctptrs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtptrs( uplo, trans, diag, n, nrhs, ap, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,trans,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs real(dp), intent(in) :: ap(*) real(dp), intent(inout) :: b(ldb,*) end subroutine dtptrs -#else - module procedure stdlib_dtptrs +#else + module procedure stdlib${ii}$_dtptrs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tptrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stptrs( uplo, trans, diag, n, nrhs, ap, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,trans,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs real(sp), intent(in) :: ap(*) real(sp), intent(inout) :: b(ldb,*) end subroutine stptrs -#else - module procedure stdlib_stptrs +#else + module procedure stdlib${ii}$_stptrs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tptrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztptrs( uplo, trans, diag, n, nrhs, ap, b, ldb, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,trans,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb,n,nrhs complex(dp), intent(in) :: ap(*) complex(dp), intent(inout) :: b(ldb,*) end subroutine ztptrs -#else - module procedure stdlib_ztptrs +#else + module procedure stdlib${ii}$_ztptrs #endif - end interface tptrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tptrs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tptrs +#:endif +#:endfor +#:endfor + end interface tptrs interface tpttf !! TPTTF copies a triangular matrix A from standard packed format (TP) !! to rectangular full packed format (TF). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctpttf( transr, uplo, n, ap, arf, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n complex(sp), intent(in) :: ap(0:*) complex(sp), intent(out) :: arf(0:*) end subroutine ctpttf -#else - module procedure stdlib_ctpttf +#else + module procedure stdlib${ii}$_ctpttf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtpttf( transr, uplo, n, ap, arf, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(dp), intent(in) :: ap(0:*) real(dp), intent(out) :: arf(0:*) end subroutine dtpttf -#else - module procedure stdlib_dtpttf +#else + module procedure stdlib${ii}$_dtpttf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tpttf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stpttf( transr, uplo, n, ap, arf, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(sp), intent(in) :: ap(0:*) real(sp), intent(out) :: arf(0:*) - end subroutine stpttf -#else - module procedure stdlib_stpttf -#endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tpttf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK + end subroutine stpttf +#else + module procedure stdlib${ii}$_stpttf +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztpttf( transr, uplo, n, ap, arf, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: transr,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n complex(dp), intent(in) :: ap(0:*) complex(dp), intent(out) :: arf(0:*) end subroutine ztpttf -#else - module procedure stdlib_ztpttf +#else + module procedure stdlib${ii}$_ztpttf #endif - end interface tpttf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tpttf +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tpttf +#:endif +#:endfor +#:endfor + end interface tpttf interface tpttr !! TPTTR copies a triangular matrix A from standard packed format (TP) !! to standard full format (TR). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctpttr( uplo, n, ap, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n,lda + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n,lda complex(sp), intent(out) :: a(lda,*) complex(sp), intent(in) :: ap(*) end subroutine ctpttr -#else - module procedure stdlib_ctpttr +#else + module procedure stdlib${ii}$_ctpttr #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtpttr( uplo, n, ap, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n,lda + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n,lda real(dp), intent(out) :: a(lda,*) real(dp), intent(in) :: ap(*) end subroutine dtpttr -#else - module procedure stdlib_dtpttr +#else + module procedure stdlib${ii}$_dtpttr #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tpttr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stpttr( uplo, n, ap, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n,lda + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n,lda real(sp), intent(out) :: a(lda,*) real(sp), intent(in) :: ap(*) end subroutine stpttr -#else - module procedure stdlib_stpttr +#else + module procedure stdlib${ii}$_stpttr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tpttr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztpttr( uplo, n, ap, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n,lda + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n,lda complex(dp), intent(out) :: a(lda,*) complex(dp), intent(in) :: ap(*) end subroutine ztpttr -#else - module procedure stdlib_ztpttr +#else + module procedure stdlib${ii}$_ztpttr #endif - end interface tpttr +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tpttr +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tpttr +#:endif +#:endfor +#:endfor + end interface tpttr interface trcon !! TRCON estimates the reciprocal of the condition number of a @@ -29062,75 +28980,75 @@ module stdlib_linalg_lapack !! norm(inv(A)), then the reciprocal of the condition number is !! computed as !! RCOND = 1 / ( norm(A) * norm(inv(A)) ). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine ctrcon( norm, uplo, diag, n, a, lda, rcond, work,rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,norm,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) :: rcond,rwork(*) complex(sp), intent(in) :: a(lda,*) complex(sp), intent(out) :: work(*) end subroutine ctrcon -#else - module procedure stdlib_ctrcon +#else + module procedure stdlib${ii}$_ctrcon #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dtrcon( norm, uplo, diag, n, a, lda, rcond, work,iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,norm,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,n real(dp), intent(out) :: rcond,work(*) real(dp), intent(in) :: a(lda,*) end subroutine dtrcon -#else - module procedure stdlib_dtrcon +#else + module procedure stdlib${ii}$_dtrcon #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trcon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine strcon( norm, uplo, diag, n, a, lda, rcond, work,iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,norm,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,n real(sp), intent(out) :: rcond,work(*) real(sp), intent(in) :: a(lda,*) end subroutine strcon -#else - module procedure stdlib_strcon +#else + module procedure stdlib${ii}$_strcon #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trcon - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine ztrcon( norm, uplo, diag, n, a, lda, rcond, work,rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,norm,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n real(dp), intent(out) :: rcond,rwork(*) complex(dp), intent(in) :: a(lda,*) complex(dp), intent(out) :: work(*) end subroutine ztrcon -#else - module procedure stdlib_ztrcon +#else + module procedure stdlib${ii}$_ztrcon #endif - end interface trcon +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trcon +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trcon +#:endif +#:endfor +#:endfor + end interface trcon interface trevc !! TREVC computes some or all of the right and/or left eigenvectors of @@ -29148,85 +29066,85 @@ module stdlib_linalg_lapack !! input matrix. If Q is the unitary factor that reduces a matrix A to !! Schur form T, then Q*X and Q*Y are the matrices of right and left !! eigenvectors of A. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctrevc( side, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, mm, m, & work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: howmny,side - integer(ilp), intent(out) :: info,m - integer(ilp), intent(in) :: ldt,ldvl,ldvr,mm,n + integer(${ik}$), intent(out) :: info,m + integer(${ik}$), intent(in) :: ldt,ldvl,ldvr,mm,n logical(lk), intent(in) :: select(*) real(sp), intent(out) :: rwork(*) complex(sp), intent(inout) :: t(ldt,*),vl(ldvl,*),vr(ldvr,*) complex(sp), intent(out) :: work(*) end subroutine ctrevc -#else - module procedure stdlib_ctrevc +#else + module procedure stdlib${ii}$_ctrevc #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtrevc( side, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, mm, m, & work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: howmny,side - integer(ilp), intent(out) :: info,m - integer(ilp), intent(in) :: ldt,ldvl,ldvr,mm,n + integer(${ik}$), intent(out) :: info,m + integer(${ik}$), intent(in) :: ldt,ldvl,ldvr,mm,n logical(lk), intent(inout) :: select(*) real(dp), intent(in) :: t(ldt,*) real(dp), intent(inout) :: vl(ldvl,*),vr(ldvr,*) real(dp), intent(out) :: work(*) end subroutine dtrevc -#else - module procedure stdlib_dtrevc +#else + module procedure stdlib${ii}$_dtrevc #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trevc - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine strevc( side, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, mm, m, & work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: howmny,side - integer(ilp), intent(out) :: info,m - integer(ilp), intent(in) :: ldt,ldvl,ldvr,mm,n + integer(${ik}$), intent(out) :: info,m + integer(${ik}$), intent(in) :: ldt,ldvl,ldvr,mm,n logical(lk), intent(inout) :: select(*) real(sp), intent(in) :: t(ldt,*) real(sp), intent(inout) :: vl(ldvl,*),vr(ldvr,*) real(sp), intent(out) :: work(*) end subroutine strevc -#else - module procedure stdlib_strevc +#else + module procedure stdlib${ii}$_strevc #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trevc - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztrevc( side, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, mm, m, & work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: howmny,side - integer(ilp), intent(out) :: info,m - integer(ilp), intent(in) :: ldt,ldvl,ldvr,mm,n + integer(${ik}$), intent(out) :: info,m + integer(${ik}$), intent(in) :: ldt,ldvl,ldvr,mm,n logical(lk), intent(in) :: select(*) real(dp), intent(out) :: rwork(*) complex(dp), intent(inout) :: t(ldt,*),vl(ldvl,*),vr(ldvr,*) complex(dp), intent(out) :: work(*) end subroutine ztrevc -#else - module procedure stdlib_ztrevc +#else + module procedure stdlib${ii}$_ztrevc #endif - end interface trevc +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trevc +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trevc +#:endif +#:endfor +#:endfor + end interface trevc interface trevc3 !! TREVC3 computes some or all of the right and/or left eigenvectors of @@ -29245,85 +29163,85 @@ module stdlib_linalg_lapack !! Schur form T, then Q*X and Q*Y are the matrices of right and left !! eigenvectors of A. !! This uses a Level 3 BLAS version of the back transformation. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctrevc3( side, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, mm, m,& work, lwork, rwork, lrwork, info) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: howmny,side - integer(ilp), intent(out) :: info,m - integer(ilp), intent(in) :: ldt,ldvl,ldvr,lwork,lrwork,mm,n + integer(${ik}$), intent(out) :: info,m + integer(${ik}$), intent(in) :: ldt,ldvl,ldvr,lwork,lrwork,mm,n logical(lk), intent(in) :: select(*) real(sp), intent(out) :: rwork(*) complex(sp), intent(inout) :: t(ldt,*),vl(ldvl,*),vr(ldvr,*) complex(sp), intent(out) :: work(*) end subroutine ctrevc3 -#else - module procedure stdlib_ctrevc3 +#else + module procedure stdlib${ii}$_ctrevc3 #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtrevc3( side, howmny, select, n, t, ldt, vl, ldvl,vr, ldvr, mm, m,& work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: howmny,side - integer(ilp), intent(out) :: info,m - integer(ilp), intent(in) :: ldt,ldvl,ldvr,lwork,mm,n + integer(${ik}$), intent(out) :: info,m + integer(${ik}$), intent(in) :: ldt,ldvl,ldvr,lwork,mm,n logical(lk), intent(inout) :: select(*) real(dp), intent(in) :: t(ldt,*) real(dp), intent(inout) :: vl(ldvl,*),vr(ldvr,*) real(dp), intent(out) :: work(*) end subroutine dtrevc3 -#else - module procedure stdlib_dtrevc3 +#else + module procedure stdlib${ii}$_dtrevc3 #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trevc3 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine strevc3( side, howmny, select, n, t, ldt, vl, ldvl,vr, ldvr, mm, m,& work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: howmny,side - integer(ilp), intent(out) :: info,m - integer(ilp), intent(in) :: ldt,ldvl,ldvr,lwork,mm,n + integer(${ik}$), intent(out) :: info,m + integer(${ik}$), intent(in) :: ldt,ldvl,ldvr,lwork,mm,n logical(lk), intent(inout) :: select(*) real(sp), intent(in) :: t(ldt,*) real(sp), intent(inout) :: vl(ldvl,*),vr(ldvr,*) real(sp), intent(out) :: work(*) end subroutine strevc3 -#else - module procedure stdlib_strevc3 +#else + module procedure stdlib${ii}$_strevc3 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trevc3 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztrevc3( side, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, mm, m,& work, lwork, rwork, lrwork, info) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: howmny,side - integer(ilp), intent(out) :: info,m - integer(ilp), intent(in) :: ldt,ldvl,ldvr,lwork,lrwork,mm,n + integer(${ik}$), intent(out) :: info,m + integer(${ik}$), intent(in) :: ldt,ldvl,ldvr,lwork,lrwork,mm,n logical(lk), intent(in) :: select(*) real(dp), intent(out) :: rwork(*) complex(dp), intent(inout) :: t(ldt,*),vl(ldvl,*),vr(ldvr,*) complex(dp), intent(out) :: work(*) end subroutine ztrevc3 -#else - module procedure stdlib_ztrevc3 +#else + module procedure stdlib${ii}$_ztrevc3 #endif - end interface trevc3 +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trevc3 +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trevc3 +#:endif +#:endfor +#:endfor + end interface trevc3 interface trexc !! TREXC reorders the Schur factorization of a complex matrix @@ -29332,73 +29250,73 @@ module stdlib_linalg_lapack !! The Schur form T is reordered by a unitary similarity transformation !! Z**H*T*Z, and optionally the matrix Q of Schur vectors is updated by !! postmultplying it with Z. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctrexc( compq, n, t, ldt, q, ldq, ifst, ilst, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compq - integer(ilp), intent(in) :: ifst,ilst,ldq,ldt,n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ifst,ilst,ldq,ldt,n + integer(${ik}$), intent(out) :: info complex(sp), intent(inout) :: q(ldq,*),t(ldt,*) end subroutine ctrexc -#else - module procedure stdlib_ctrexc +#else + module procedure stdlib${ii}$_ctrexc #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dtrexc( compq, n, t, ldt, q, ldq, ifst, ilst, work,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compq - integer(ilp), intent(inout) :: ifst,ilst - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldq,ldt,n + integer(${ik}$), intent(inout) :: ifst,ilst + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldq,ldt,n real(dp), intent(inout) :: q(ldq,*),t(ldt,*) real(dp), intent(out) :: work(*) end subroutine dtrexc -#else - module procedure stdlib_dtrexc +#else + module procedure stdlib${ii}$_dtrexc #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trexc - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine strexc( compq, n, t, ldt, q, ldq, ifst, ilst, work,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compq - integer(ilp), intent(inout) :: ifst,ilst - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldq,ldt,n + integer(${ik}$), intent(inout) :: ifst,ilst + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldq,ldt,n real(sp), intent(inout) :: q(ldq,*),t(ldt,*) real(sp), intent(out) :: work(*) end subroutine strexc -#else - module procedure stdlib_strexc +#else + module procedure stdlib${ii}$_strexc #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trexc - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztrexc( compq, n, t, ldt, q, ldq, ifst, ilst, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compq - integer(ilp), intent(in) :: ifst,ilst,ldq,ldt,n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ifst,ilst,ldq,ldt,n + integer(${ik}$), intent(out) :: info complex(dp), intent(inout) :: q(ldq,*),t(ldt,*) end subroutine ztrexc -#else - module procedure stdlib_ztrexc +#else + module procedure stdlib${ii}$_ztrexc #endif - end interface trexc +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trexc +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trexc +#:endif +#:endfor +#:endfor + end interface trexc interface trrfs !! TRRFS provides error bounds and backward error estimates for the @@ -29407,79 +29325,79 @@ module stdlib_linalg_lapack !! The solution matrix X must be computed by CTRTRS or some other !! means before entering this routine. TRRFS does not do iterative !! refinement because doing so cannot improve the backward error. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctrrfs( uplo, trans, diag, n, nrhs, a, lda, b, ldb, x,ldx, ferr, & berr, work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,trans,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,ldx,n,nrhs real(sp), intent(out) :: berr(*),ferr(*),rwork(*) complex(sp), intent(in) :: a(lda,*),b(ldb,*),x(ldx,*) complex(sp), intent(out) :: work(*) end subroutine ctrrfs -#else - module procedure stdlib_ctrrfs +#else + module procedure stdlib${ii}$_ctrrfs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtrrfs( uplo, trans, diag, n, nrhs, a, lda, b, ldb, x,ldx, ferr, & berr, work, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,trans,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,ldb,ldx,n,nrhs real(dp), intent(in) :: a(lda,*),b(ldb,*),x(ldx,*) real(dp), intent(out) :: berr(*),ferr(*),work(*) end subroutine dtrrfs -#else - module procedure stdlib_dtrrfs +#else + module procedure stdlib${ii}$_dtrrfs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trrfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine strrfs( uplo, trans, diag, n, nrhs, a, lda, b, ldb, x,ldx, ferr, & berr, work, iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,trans,uplo - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: lda,ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: lda,ldb,ldx,n,nrhs real(sp), intent(in) :: a(lda,*),b(ldb,*),x(ldx,*) real(sp), intent(out) :: berr(*),ferr(*),work(*) end subroutine strrfs -#else - module procedure stdlib_strrfs +#else + module procedure stdlib${ii}$_strrfs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trrfs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztrrfs( uplo, trans, diag, n, nrhs, a, lda, b, ldb, x,ldx, ferr, & berr, work, rwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,trans,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldb,ldx,n,nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldb,ldx,n,nrhs real(dp), intent(out) :: berr(*),ferr(*),rwork(*) complex(dp), intent(in) :: a(lda,*),b(ldb,*),x(ldx,*) complex(dp), intent(out) :: work(*) end subroutine ztrrfs -#else - module procedure stdlib_ztrrfs +#else + module procedure stdlib${ii}$_ztrrfs #endif - end interface trrfs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trrfs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trrfs +#:endif +#:endfor +#:endfor + end interface trrfs interface trsen !! TRSEN reorders the Schur factorization of a complex matrix @@ -29489,165 +29407,165 @@ module stdlib_linalg_lapack !! corresponding right invariant subspace. !! Optionally the routine computes the reciprocal condition numbers of !! the cluster of eigenvalues and/or the invariant subspace. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine ctrsen( job, compq, select, n, t, ldt, q, ldq, w, m, s,sep, work, lwork,& info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compq,job - integer(ilp), intent(out) :: info,m - integer(ilp), intent(in) :: ldq,ldt,lwork,n + integer(${ik}$), intent(out) :: info,m + integer(${ik}$), intent(in) :: ldq,ldt,lwork,n real(sp), intent(out) :: s,sep logical(lk), intent(in) :: select(*) complex(sp), intent(inout) :: q(ldq,*),t(ldt,*) complex(sp), intent(out) :: w(*),work(*) end subroutine ctrsen -#else - module procedure stdlib_ctrsen +#else + module procedure stdlib${ii}$_ctrsen #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dtrsen( job, compq, select, n, t, ldt, q, ldq, wr, wi,m, s, sep, work, & lwork, iwork, liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compq,job - integer(ilp), intent(out) :: info,m,iwork(*) - integer(ilp), intent(in) :: ldq,ldt,liwork,lwork,n + integer(${ik}$), intent(out) :: info,m,iwork(*) + integer(${ik}$), intent(in) :: ldq,ldt,liwork,lwork,n real(dp), intent(out) :: s,sep,wi(*),work(*),wr(*) logical(lk), intent(in) :: select(*) real(dp), intent(inout) :: q(ldq,*),t(ldt,*) end subroutine dtrsen -#else - module procedure stdlib_dtrsen +#else + module procedure stdlib${ii}$_dtrsen #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trsen - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine strsen( job, compq, select, n, t, ldt, q, ldq, wr, wi,m, s, sep, work, & lwork, iwork, liwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compq,job - integer(ilp), intent(out) :: info,m,iwork(*) - integer(ilp), intent(in) :: ldq,ldt,liwork,lwork,n + integer(${ik}$), intent(out) :: info,m,iwork(*) + integer(${ik}$), intent(in) :: ldq,ldt,liwork,lwork,n real(sp), intent(out) :: s,sep,wi(*),work(*),wr(*) logical(lk), intent(in) :: select(*) real(sp), intent(inout) :: q(ldq,*),t(ldt,*) end subroutine strsen -#else - module procedure stdlib_strsen +#else + module procedure stdlib${ii}$_strsen #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trsen - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine ztrsen( job, compq, select, n, t, ldt, q, ldq, w, m, s,sep, work, lwork,& info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: compq,job - integer(ilp), intent(out) :: info,m - integer(ilp), intent(in) :: ldq,ldt,lwork,n + integer(${ik}$), intent(out) :: info,m + integer(${ik}$), intent(in) :: ldq,ldt,lwork,n real(dp), intent(out) :: s,sep logical(lk), intent(in) :: select(*) complex(dp), intent(inout) :: q(ldq,*),t(ldt,*) complex(dp), intent(out) :: w(*),work(*) end subroutine ztrsen -#else - module procedure stdlib_ztrsen +#else + module procedure stdlib${ii}$_ztrsen #endif - end interface trsen +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trsen +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trsen +#:endif +#:endfor +#:endfor + end interface trsen interface trsna !! TRSNA estimates reciprocal condition numbers for specified !! eigenvalues and/or right eigenvectors of a complex upper triangular !! matrix T (or of any matrix Q*T*Q**H with Q unitary). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctrsna( job, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, s, sep, & mm, m, work, ldwork, rwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: howmny,job - integer(ilp), intent(out) :: info,m - integer(ilp), intent(in) :: ldt,ldvl,ldvr,ldwork,mm,n + integer(${ik}$), intent(out) :: info,m + integer(${ik}$), intent(in) :: ldt,ldvl,ldvr,ldwork,mm,n logical(lk), intent(in) :: select(*) real(sp), intent(out) :: rwork(*),s(*),sep(*) complex(sp), intent(in) :: t(ldt,*),vl(ldvl,*),vr(ldvr,*) complex(sp), intent(out) :: work(ldwork,*) end subroutine ctrsna -#else - module procedure stdlib_ctrsna +#else + module procedure stdlib${ii}$_ctrsna #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dtrsna( job, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, s, sep, mm, & m, work, ldwork, iwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: howmny,job - integer(ilp), intent(out) :: info,m,iwork(*) - integer(ilp), intent(in) :: ldt,ldvl,ldvr,ldwork,mm,n + integer(${ik}$), intent(out) :: info,m,iwork(*) + integer(${ik}$), intent(in) :: ldt,ldvl,ldvr,ldwork,mm,n logical(lk), intent(in) :: select(*) real(dp), intent(out) :: s(*),sep(*),work(ldwork,*) real(dp), intent(in) :: t(ldt,*),vl(ldvl,*),vr(ldvr,*) end subroutine dtrsna -#else - module procedure stdlib_dtrsna +#else + module procedure stdlib${ii}$_dtrsna #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trsna - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine strsna( job, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, s, sep, mm, & m, work, ldwork, iwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: howmny,job - integer(ilp), intent(out) :: info,m,iwork(*) - integer(ilp), intent(in) :: ldt,ldvl,ldvr,ldwork,mm,n + integer(${ik}$), intent(out) :: info,m,iwork(*) + integer(${ik}$), intent(in) :: ldt,ldvl,ldvr,ldwork,mm,n logical(lk), intent(in) :: select(*) real(sp), intent(out) :: s(*),sep(*),work(ldwork,*) real(sp), intent(in) :: t(ldt,*),vl(ldvl,*),vr(ldvr,*) end subroutine strsna -#else - module procedure stdlib_strsna +#else + module procedure stdlib${ii}$_strsna #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trsna - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztrsna( job, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, s, sep, & mm, m, work, ldwork, rwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: howmny,job - integer(ilp), intent(out) :: info,m - integer(ilp), intent(in) :: ldt,ldvl,ldvr,ldwork,mm,n + integer(${ik}$), intent(out) :: info,m + integer(${ik}$), intent(in) :: ldt,ldvl,ldvr,ldwork,mm,n logical(lk), intent(in) :: select(*) real(dp), intent(out) :: rwork(*),s(*),sep(*) complex(dp), intent(in) :: t(ldt,*),vl(ldvl,*),vr(ldvr,*) complex(dp), intent(out) :: work(ldwork,*) end subroutine ztrsna -#else - module procedure stdlib_ztrsna +#else + module procedure stdlib${ii}$_ztrsna #endif - end interface trsna +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trsna +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trsna +#:endif +#:endfor +#:endfor + end interface trsna interface trsyl !! TRSYL solves the complex Sylvester matrix equation: @@ -29657,364 +29575,364 @@ module stdlib_linalg_lapack !! M-by-M and B is N-by-N; the right hand side C and the solution X are !! M-by-N; and scale is an output scale factor, set <= 1 to avoid !! overflow in X. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine ctrsyl( trana, tranb, isgn, m, n, a, lda, b, ldb, c,ldc, scale, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trana,tranb - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: isgn,lda,ldb,ldc,m,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: isgn,lda,ldb,ldc,m,n real(sp), intent(out) :: scale complex(sp), intent(in) :: a(lda,*),b(ldb,*) complex(sp), intent(inout) :: c(ldc,*) end subroutine ctrsyl -#else - module procedure stdlib_ctrsyl +#else + module procedure stdlib${ii}$_ctrsyl #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine dtrsyl( trana, tranb, isgn, m, n, a, lda, b, ldb, c,ldc, scale, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trana,tranb - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: isgn,lda,ldb,ldc,m,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: isgn,lda,ldb,ldc,m,n real(dp), intent(out) :: scale real(dp), intent(in) :: a(lda,*),b(ldb,*) real(dp), intent(inout) :: c(ldc,*) end subroutine dtrsyl -#else - module procedure stdlib_dtrsyl +#else + module procedure stdlib${ii}$_dtrsyl #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trsyl - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine strsyl( trana, tranb, isgn, m, n, a, lda, b, ldb, c,ldc, scale, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trana,tranb - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: isgn,lda,ldb,ldc,m,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: isgn,lda,ldb,ldc,m,n real(sp), intent(out) :: scale real(sp), intent(in) :: a(lda,*),b(ldb,*) real(sp), intent(inout) :: c(ldc,*) end subroutine strsyl -#else - module procedure stdlib_strsyl +#else + module procedure stdlib${ii}$_strsyl #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trsyl - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine ztrsyl( trana, tranb, isgn, m, n, a, lda, b, ldb, c,ldc, scale, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: trana,tranb - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: isgn,lda,ldb,ldc,m,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: isgn,lda,ldb,ldc,m,n real(dp), intent(out) :: scale complex(dp), intent(in) :: a(lda,*),b(ldb,*) complex(dp), intent(inout) :: c(ldc,*) end subroutine ztrsyl -#else - module procedure stdlib_ztrsyl +#else + module procedure stdlib${ii}$_ztrsyl #endif - end interface trsyl +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trsyl +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trsyl +#:endif +#:endfor +#:endfor + end interface trsyl interface trtri !! TRTRI computes the inverse of a complex upper or lower triangular !! matrix A. !! This is the Level 3 BLAS version of the algorithm. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctrtri( uplo, diag, n, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n complex(sp), intent(inout) :: a(lda,*) end subroutine ctrtri -#else - module procedure stdlib_ctrtri +#else + module procedure stdlib${ii}$_ctrtri #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtrtri( uplo, diag, n, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n real(dp), intent(inout) :: a(lda,*) end subroutine dtrtri -#else - module procedure stdlib_dtrtri +#else + module procedure stdlib${ii}$_dtrtri #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trtri - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine strtri( uplo, diag, n, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,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(inout) :: a(lda,*) end subroutine strtri -#else - module procedure stdlib_strtri +#else + module procedure stdlib${ii}$_strtri #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trtri - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztrtri( uplo, diag, n, a, lda, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: diag,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,n complex(dp), intent(inout) :: a(lda,*) end subroutine ztrtri -#else - module procedure stdlib_ztrtri +#else + module procedure stdlib${ii}$_ztrtri #endif - end interface trtri +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trtri +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trtri +#:endif +#:endfor +#:endfor + end interface trtri interface trtrs !! TRTRS solves a triangular system of the form !! A * X = B, A**T * X = B, or A**H * X = B, !! where A is a triangular matrix of order N, and B is an N-by-NRHS !! matrix. A check is made to verify that A is nonsingular. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctrtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(in) :: a(lda,*) complex(sp), intent(inout) :: b(ldb,*) end subroutine ctrtrs -#else - module procedure stdlib_ctrtrs +#else + module procedure stdlib${ii}$_ctrtrs #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtrtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(in) :: a(lda,*) real(dp), intent(inout) :: b(ldb,*) end subroutine dtrtrs -#else - module procedure stdlib_dtrtrs +#else + module procedure stdlib${ii}$_dtrtrs #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trtrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine strtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(in) :: a(lda,*) real(sp), intent(inout) :: b(ldb,*) end subroutine strtrs -#else - module procedure stdlib_strtrs +#else + module procedure stdlib${ii}$_strtrs #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trtrs - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztrtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(in) :: a(lda,*) complex(dp), intent(inout) :: b(ldb,*) end subroutine ztrtrs -#else - module procedure stdlib_ztrtrs +#else + module procedure stdlib${ii}$_ztrtrs #endif - end interface trtrs +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trtrs +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trtrs +#:endif +#:endfor +#:endfor + end interface trtrs interface trttf !! TRTTF copies a triangular matrix A from standard full format (TR) !! to rectangular full packed format (TF) . -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctrttf( transr, uplo, n, a, lda, arf, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(in) :: a(0:lda-1,0:*) complex(sp), intent(out) :: arf(0:*) end subroutine ctrttf -#else - module procedure stdlib_ctrttf +#else + module procedure stdlib${ii}$_ctrttf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtrttf( transr, uplo, n, a, lda, arf, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(dp), intent(in) :: a(0:lda-1,0:*) - real(dp), intent(out) :: arf(0:*) - end subroutine dtrttf -#else - module procedure stdlib_dtrttf -#endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trttf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK + real(dp), intent(out) :: arf(0:*) + end subroutine dtrttf +#else + module procedure stdlib${ii}$_dtrttf +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine strttf( transr, uplo, n, a, lda, arf, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 real(sp), intent(in) :: a(0:lda-1,0:*) real(sp), intent(out) :: arf(0:*) end subroutine strttf -#else - module procedure stdlib_strttf +#else + module procedure stdlib${ii}$_strttf #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trttf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztrttf( transr, uplo, n, a, lda, arf, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(in) :: a(0:lda-1,0:*) complex(dp), intent(out) :: arf(0:*) end subroutine ztrttf -#else - module procedure stdlib_ztrttf +#else + module procedure stdlib${ii}$_ztrttf #endif - end interface trttf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trttf +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trttf +#:endif +#:endfor +#:endfor + end interface trttf interface trttp !! TRTTP copies a triangular matrix A from full format (TR) to standard !! packed format (TP). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctrttp( uplo, n, a, lda, ap, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n,lda + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n,lda complex(sp), intent(in) :: a(lda,*) complex(sp), intent(out) :: ap(*) end subroutine ctrttp -#else - module procedure stdlib_ctrttp +#else + module procedure stdlib${ii}$_ctrttp #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtrttp( uplo, n, a, lda, ap, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n,lda + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n,lda real(dp), intent(in) :: a(lda,*) real(dp), intent(out) :: ap(*) end subroutine dtrttp -#else - module procedure stdlib_dtrttp +#else + module procedure stdlib${ii}$_dtrttp #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trttp - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine strttp( uplo, n, a, lda, ap, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n,lda + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n,lda real(sp), intent(in) :: a(lda,*) real(sp), intent(out) :: ap(*) end subroutine strttp -#else - module procedure stdlib_strttp +#else + module procedure stdlib${ii}$_strttp #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$trttp - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztrttp( uplo, n, a, lda, ap, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: n,lda + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n,lda complex(dp), intent(in) :: a(lda,*) complex(dp), intent(out) :: ap(*) end subroutine ztrttp -#else - module procedure stdlib_ztrttp +#else + module procedure stdlib${ii}$_ztrttp #endif - end interface trttp +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trttp +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$trttp +#:endif +#:endfor +#:endfor + end interface trttp interface tzrzf !! TZRZF reduces the M-by-N ( M<=N ) complex upper trapezoidal matrix A @@ -30023,69 +29941,69 @@ module stdlib_linalg_lapack !! A = ( R 0 ) * Z, !! where Z is an N-by-N unitary matrix and R is an M-by-M upper !! triangular matrix. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ctzrzf( m, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: tau(*),work(*) end subroutine ctzrzf -#else - module procedure stdlib_ctzrzf +#else + module procedure stdlib${ii}$_ctzrzf #endif -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine dtzrzf( m, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: tau(*),work(*) end subroutine dtzrzf -#else - module procedure stdlib_dtzrzf +#else + module procedure stdlib${ii}$_dtzrzf #endif -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tzrzf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine stzrzf( m, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: tau(*),work(*) end subroutine stzrzf -#else - module procedure stdlib_stzrzf +#else + module procedure stdlib${ii}$_stzrzf #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$tzrzf - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine ztzrzf( m, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,lwork,m,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: tau(*),work(*) end subroutine ztzrzf -#else - module procedure stdlib_ztzrzf +#else + module procedure stdlib${ii}$_ztzrzf #endif - end interface tzrzf +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tzrzf +#:endif +#:endfor +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$tzrzf +#:endif +#:endfor +#:endfor + end interface tzrzf interface unbdb !! UNBDB simultaneously bidiagonalizes the blocks of an M-by-M @@ -30104,49 +30022,49 @@ module stdlib_linalg_lapack !! represented implicitly by Householder vectors. !! B11, B12, B21, and B22 are Q-by-Q bidiagonal matrices represented !! implicitly by angles THETA, PHI. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cunbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & ldx22, theta, phi, taup1,taup2, tauq1, tauq2, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: signs,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldx11,ldx12,ldx21,ldx22,lwork,m,p,q + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldx11,ldx12,ldx21,ldx22,lwork,m,p,q real(sp), intent(out) :: phi(*),theta(*) complex(sp), intent(out) :: taup1(*),taup2(*),tauq1(*),tauq2(*),work(*) - + complex(sp), intent(inout) :: x11(ldx11,*),x12(ldx12,*),x21(ldx21,*),x22(& ldx22,*) end subroutine cunbdb -#else - module procedure stdlib_cunbdb +#else + module procedure stdlib${ii}$_cunbdb #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$unbdb - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zunbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & ldx22, theta, phi, taup1,taup2, tauq1, tauq2, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: signs,trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldx11,ldx12,ldx21,ldx22,lwork,m,p,q + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldx11,ldx12,ldx21,ldx22,lwork,m,p,q real(dp), intent(out) :: phi(*),theta(*) complex(dp), intent(out) :: taup1(*),taup2(*),tauq1(*),tauq2(*),work(*) - + complex(dp), intent(inout) :: x11(ldx11,*),x12(ldx12,*),x21(ldx21,*),x22(& ldx22,*) end subroutine zunbdb -#else - module procedure stdlib_zunbdb +#else + module procedure stdlib${ii}$_zunbdb #endif - end interface unbdb - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$unbdb +#:endif +#:endfor +#:endfor + end interface unbdb interface unbdb1 !! UNBDB1 simultaneously bidiagonalizes the blocks of a tall and skinny @@ -30164,43 +30082,43 @@ module stdlib_linalg_lapack !! Householder vectors. !! B11 and B12 are Q-by-Q bidiagonal matrices represented implicitly by !! angles THETA, PHI. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cunbdb1( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, & tauq1, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lwork,m,p,q,ldx11,ldx21 + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork,m,p,q,ldx11,ldx21 real(sp), intent(out) :: phi(*),theta(*) complex(sp), intent(out) :: taup1(*),taup2(*),tauq1(*),work(*) complex(sp), intent(inout) :: x11(ldx11,*),x21(ldx21,*) end subroutine cunbdb1 -#else - module procedure stdlib_cunbdb1 +#else + module procedure stdlib${ii}$_cunbdb1 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$unbdb1 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zunbdb1( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, & tauq1, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lwork,m,p,q,ldx11,ldx21 + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork,m,p,q,ldx11,ldx21 real(dp), intent(out) :: phi(*),theta(*) complex(dp), intent(out) :: taup1(*),taup2(*),tauq1(*),work(*) complex(dp), intent(inout) :: x11(ldx11,*),x21(ldx21,*) end subroutine zunbdb1 -#else - module procedure stdlib_zunbdb1 +#else + module procedure stdlib${ii}$_zunbdb1 #endif - end interface unbdb1 - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$unbdb1 +#:endif +#:endfor +#:endfor + end interface unbdb1 interface unbdb2 !! UNBDB2 simultaneously bidiagonalizes the blocks of a tall and skinny @@ -30218,43 +30136,43 @@ module stdlib_linalg_lapack !! Householder vectors. !! B11 and B12 are P-by-P bidiagonal matrices represented implicitly by !! angles THETA, PHI. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cunbdb2( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, & tauq1, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lwork,m,p,q,ldx11,ldx21 + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork,m,p,q,ldx11,ldx21 real(sp), intent(out) :: phi(*),theta(*) complex(sp), intent(out) :: taup1(*),taup2(*),tauq1(*),work(*) complex(sp), intent(inout) :: x11(ldx11,*),x21(ldx21,*) end subroutine cunbdb2 -#else - module procedure stdlib_cunbdb2 +#else + module procedure stdlib${ii}$_cunbdb2 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$unbdb2 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zunbdb2( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, & tauq1, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lwork,m,p,q,ldx11,ldx21 + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork,m,p,q,ldx11,ldx21 real(dp), intent(out) :: phi(*),theta(*) complex(dp), intent(out) :: taup1(*),taup2(*),tauq1(*),work(*) complex(dp), intent(inout) :: x11(ldx11,*),x21(ldx21,*) end subroutine zunbdb2 -#else - module procedure stdlib_zunbdb2 +#else + module procedure stdlib${ii}$_zunbdb2 #endif - end interface unbdb2 - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$unbdb2 +#:endif +#:endfor +#:endfor + end interface unbdb2 interface unbdb3 !! UNBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny @@ -30272,43 +30190,43 @@ module stdlib_linalg_lapack !! Householder vectors. !! B11 and B12 are (M-P)-by-(M-P) bidiagonal matrices represented !! implicitly by angles THETA, PHI. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cunbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, & tauq1, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lwork,m,p,q,ldx11,ldx21 + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork,m,p,q,ldx11,ldx21 real(sp), intent(out) :: phi(*),theta(*) complex(sp), intent(out) :: taup1(*),taup2(*),tauq1(*),work(*) complex(sp), intent(inout) :: x11(ldx11,*),x21(ldx21,*) end subroutine cunbdb3 -#else - module procedure stdlib_cunbdb3 +#else + module procedure stdlib${ii}$_cunbdb3 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$unbdb3 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zunbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, & tauq1, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lwork,m,p,q,ldx11,ldx21 + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork,m,p,q,ldx11,ldx21 real(dp), intent(out) :: phi(*),theta(*) complex(dp), intent(out) :: taup1(*),taup2(*),tauq1(*),work(*) complex(dp), intent(inout) :: x11(ldx11,*),x21(ldx21,*) end subroutine zunbdb3 -#else - module procedure stdlib_zunbdb3 +#else + module procedure stdlib${ii}$_zunbdb3 #endif - end interface unbdb3 - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$unbdb3 +#:endif +#:endfor +#:endfor + end interface unbdb3 interface unbdb4 !! UNBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny @@ -30326,45 +30244,45 @@ module stdlib_linalg_lapack !! Householder vectors. !! B11 and B12 are (M-Q)-by-(M-Q) bidiagonal matrices represented !! implicitly by angles THETA, PHI. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cunbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, & tauq1, phantom, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lwork,m,p,q,ldx11,ldx21 + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork,m,p,q,ldx11,ldx21 real(sp), intent(out) :: phi(*),theta(*) complex(sp), intent(out) :: phantom(*),taup1(*),taup2(*),tauq1(*),work(*) - + complex(sp), intent(inout) :: x11(ldx11,*),x21(ldx21,*) end subroutine cunbdb4 -#else - module procedure stdlib_cunbdb4 +#else + module procedure stdlib${ii}$_cunbdb4 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$unbdb4 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zunbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, & tauq1, phantom, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lwork,m,p,q,ldx11,ldx21 + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork,m,p,q,ldx11,ldx21 real(dp), intent(out) :: phi(*),theta(*) complex(dp), intent(out) :: phantom(*),taup1(*),taup2(*),tauq1(*),work(*) - + complex(dp), intent(inout) :: x11(ldx11,*),x21(ldx21,*) end subroutine zunbdb4 -#else - module procedure stdlib_zunbdb4 +#else + module procedure stdlib${ii}$_zunbdb4 #endif - end interface unbdb4 - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$unbdb4 +#:endif +#:endfor +#:endfor + end interface unbdb4 interface unbdb5 !! UNBDB5 orthogonalizes the column vector @@ -30378,43 +30296,43 @@ module stdlib_linalg_lapack !! criterion, then some other vector from the orthogonal complement !! is returned. This vector is chosen in an arbitrary but deterministic !! way. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cunbdb5( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx1,incx2,ldq1,ldq2,lwork,m1,m2,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx1,incx2,ldq1,ldq2,lwork,m1,m2,n + integer(${ik}$), intent(out) :: info complex(sp), intent(in) :: q1(ldq1,*),q2(ldq2,*) complex(sp), intent(out) :: work(*) complex(sp), intent(inout) :: x1(*),x2(*) end subroutine cunbdb5 -#else - module procedure stdlib_cunbdb5 +#else + module procedure stdlib${ii}$_cunbdb5 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$unbdb5 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zunbdb5( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx1,incx2,ldq1,ldq2,lwork,m1,m2,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx1,incx2,ldq1,ldq2,lwork,m1,m2,n + integer(${ik}$), intent(out) :: info complex(dp), intent(in) :: q1(ldq1,*),q2(ldq2,*) complex(dp), intent(out) :: work(*) complex(dp), intent(inout) :: x1(*),x2(*) end subroutine zunbdb5 -#else - module procedure stdlib_zunbdb5 +#else + module procedure stdlib${ii}$_zunbdb5 #endif - end interface unbdb5 - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$unbdb5 +#:endif +#:endfor +#:endfor + end interface unbdb5 interface unbdb6 !! UNBDB6 orthogonalizes the column vector @@ -30426,43 +30344,43 @@ module stdlib_linalg_lapack !! The columns of Q must be orthonormal. !! If the projection is zero according to Kahan's "twice is enough" !! criterion, then the zero vector is returned. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx1,incx2,ldq1,ldq2,lwork,m1,m2,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx1,incx2,ldq1,ldq2,lwork,m1,m2,n + integer(${ik}$), intent(out) :: info complex(sp), intent(in) :: q1(ldq1,*),q2(ldq2,*) complex(sp), intent(out) :: work(*) complex(sp), intent(inout) :: x1(*),x2(*) end subroutine cunbdb6 -#else - module procedure stdlib_cunbdb6 +#else + module procedure stdlib${ii}$_cunbdb6 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$unbdb6 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: incx1,incx2,ldq1,ldq2,lwork,m1,m2,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: incx1,incx2,ldq1,ldq2,lwork,m1,m2,n + integer(${ik}$), intent(out) :: info complex(dp), intent(in) :: q1(ldq1,*),q2(ldq2,*) complex(dp), intent(out) :: work(*) complex(dp), intent(inout) :: x1(*),x2(*) end subroutine zunbdb6 -#else - module procedure stdlib_zunbdb6 +#else + module procedure stdlib${ii}$_zunbdb6 #endif - end interface unbdb6 - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$unbdb6 +#:endif +#:endfor +#:endfor + end interface unbdb6 interface uncsd !! UNCSD computes the CS decomposition of an M-by-M partitioned @@ -30478,15 +30396,16 @@ module stdlib_linalg_lapack !! (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are !! R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in !! which R = MIN(P,M-P,Q,M-Q). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ recursive subroutine cuncsd( jobu1, jobu2, jobv1t, jobv2t, trans,signs, m, p, q, & x11, ldx11, x12,ldx12, x21, ldx21, x22, ldx22, theta,u1, ldu1, u2, ldu2, v1t, & ldv1t, v2t,ldv2t, work, lwork, rwork, lrwork,iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobu1,jobu2,jobv1t,jobv2t,signs,trans - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldu1,ldu2,ldv1t,ldv2t,ldx11,ldx12,ldx21,ldx22,& + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldu1,ldu2,ldv1t,ldv2t,ldx11,ldx12,ldx21,ldx22,& lrwork,lwork,m,p,q real(sp), intent(out) :: theta(*),rwork(*) complex(sp), intent(out) :: u1(ldu1,*),u2(ldu2,*),v1t(ldv1t,*),v2t(ldv2t,*),& @@ -30494,24 +30413,18 @@ module stdlib_linalg_lapack complex(sp), intent(inout) :: x11(ldx11,*),x12(ldx12,*),x21(ldx21,*),x22(& ldx22,*) end subroutine cuncsd -#else - module procedure stdlib_cuncsd +#else + module procedure stdlib${ii}$_cuncsd #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$uncsd - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ recursive subroutine zuncsd( jobu1, jobu2, jobv1t, jobv2t, trans,signs, m, p, q, & x11, ldx11, x12,ldx12, x21, ldx21, x22, ldx22, theta,u1, ldu1, u2, ldu2, v1t, & ldv1t, v2t,ldv2t, work, lwork, rwork, lrwork,iwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobu1,jobu2,jobv1t,jobv2t,signs,trans - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldu1,ldu2,ldv1t,ldv2t,ldx11,ldx12,ldx21,ldx22,& + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldu1,ldu2,ldv1t,ldv2t,ldx11,ldx12,ldx21,ldx22,& lrwork,lwork,m,p,q real(dp), intent(out) :: theta(*),rwork(*) complex(dp), intent(out) :: u1(ldu1,*),u2(ldu2,*),v1t(ldv1t,*),v2t(ldv2t,*),& @@ -30519,12 +30432,17 @@ module stdlib_linalg_lapack complex(dp), intent(inout) :: x11(ldx11,*),x12(ldx12,*),x21(ldx21,*),x22(& ldx22,*) end subroutine zuncsd -#else - module procedure stdlib_zuncsd +#else + module procedure stdlib${ii}$_zuncsd #endif - end interface uncsd - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$uncsd +#:endif +#:endfor +#:endfor + end interface uncsd interface uncsd2by1 !! UNCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with @@ -30542,47 +30460,47 @@ module stdlib_linalg_lapack !! nonnegative diagonal matrices satisfying C^2 + S^2 = I, in which !! R = MIN(P,M-P,Q,M-Q). I1 is a K1-by-K1 identity matrix and I2 is a !! K2-by-K2 identity matrix, where K1 = MAX(Q+P-M,0), K2 = MAX(Q-P,0). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine cuncsd2by1( jobu1, jobu2, jobv1t, m, p, q, x11, ldx11,x21, ldx21, theta,& u1, ldu1, u2, ldu2, v1t,ldv1t, work, lwork, rwork, lrwork, iwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobu1,jobu2,jobv1t - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldu1,ldu2,ldv1t,lwork,ldx11,ldx21,m,p,q,& + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldu1,ldu2,ldv1t,lwork,ldx11,ldx21,m,p,q,& lrwork real(sp), intent(out) :: rwork(*),theta(*) complex(sp), intent(out) :: u1(ldu1,*),u2(ldu2,*),v1t(ldv1t,*),work(*) complex(sp), intent(inout) :: x11(ldx11,*),x21(ldx21,*) end subroutine cuncsd2by1 -#else - module procedure stdlib_cuncsd2by1 +#else + module procedure stdlib${ii}$_cuncsd2by1 #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$uncsd2by1 - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ subroutine zuncsd2by1( jobu1, jobu2, jobv1t, m, p, q, x11, ldx11,x21, ldx21, theta,& u1, ldu1, u2, ldu2, v1t,ldv1t, work, lwork, rwork, lrwork, iwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: jobu1,jobu2,jobv1t - integer(ilp), intent(out) :: info,iwork(*) - integer(ilp), intent(in) :: ldu1,ldu2,ldv1t,lwork,ldx11,ldx21,m,p,q,& + integer(${ik}$), intent(out) :: info,iwork(*) + integer(${ik}$), intent(in) :: ldu1,ldu2,ldv1t,lwork,ldx11,ldx21,m,p,q,& lrwork real(dp), intent(out) :: rwork(*),theta(*) complex(dp), intent(out) :: u1(ldu1,*),u2(ldu2,*),v1t(ldv1t,*),work(*) complex(dp), intent(inout) :: x11(ldx11,*),x21(ldx21,*) end subroutine zuncsd2by1 -#else - module procedure stdlib_zuncsd2by1 +#else + module procedure stdlib${ii}$_zuncsd2by1 #endif - end interface uncsd2by1 - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$uncsd2by1 +#:endif +#:endfor +#:endfor + end interface uncsd2by1 interface ung2l !! UNG2L generates an m by n complex matrix Q with orthonormal columns, @@ -30590,41 +30508,41 @@ module stdlib_linalg_lapack !! reflectors of order m !! Q = H(k) . . . H(2) H(1) !! as returned by CGEQLF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cung2l( m, n, k, a, lda, tau, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,lda,m,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(in) :: tau(*) complex(sp), intent(out) :: work(*) end subroutine cung2l -#else - module procedure stdlib_cung2l +#else + module procedure stdlib${ii}$_cung2l #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ung2l - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zung2l( m, n, k, a, lda, tau, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,lda,m,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: tau(*) complex(dp), intent(out) :: work(*) end subroutine zung2l -#else - module procedure stdlib_zung2l +#else + module procedure stdlib${ii}$_zung2l #endif - end interface ung2l - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ung2l +#:endif +#:endfor +#:endfor + end interface ung2l interface ung2r !! UNG2R generates an m by n complex matrix Q with orthonormal columns, @@ -30632,41 +30550,41 @@ module stdlib_linalg_lapack !! reflectors of order m !! Q = H(1) H(2) . . . H(k) !! as returned by CGEQRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cung2r( m, n, k, a, lda, tau, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,lda,m,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(in) :: tau(*) complex(sp), intent(out) :: work(*) end subroutine cung2r -#else - module procedure stdlib_cung2r +#else + module procedure stdlib${ii}$_cung2r #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ung2r - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zung2r( m, n, k, a, lda, tau, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,lda,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,lda,m,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: tau(*) complex(dp), intent(out) :: work(*) end subroutine zung2r -#else - module procedure stdlib_zung2r +#else + module procedure stdlib${ii}$_zung2r #endif - end interface ung2r - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ung2r +#:endif +#:endfor +#:endfor + end interface ung2r interface ungbr !! UNGBR generates one of the complex unitary matrices Q or P**H @@ -30685,84 +30603,84 @@ module stdlib_linalg_lapack !! rows of P**H, where n >= m >= k; !! if k >= n, P**H = G(n-1) . . . G(2) G(1) and UNGBR returns P**H as !! an N-by-N matrix. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cungbr( vect, m, n, k, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: vect - 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 complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(in) :: tau(*) complex(sp), intent(out) :: work(*) end subroutine cungbr -#else - module procedure stdlib_cungbr +#else + module procedure stdlib${ii}$_cungbr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ungbr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zungbr( vect, m, n, k, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: vect - 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 complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: tau(*) complex(dp), intent(out) :: work(*) end subroutine zungbr -#else - module procedure stdlib_zungbr +#else + module procedure stdlib${ii}$_zungbr #endif - end interface ungbr - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ungbr +#:endif +#:endfor +#:endfor + end interface ungbr interface unghr !! UNGHR generates a complex unitary matrix Q which is defined as the !! product of IHI-ILO elementary reflectors of order N, as returned by !! CGEHRD: !! Q = H(ilo) H(ilo+1) . . . H(ihi-1). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cunghr( n, ilo, ihi, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihi,ilo,lda,lwork,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihi,ilo,lda,lwork,n + integer(${ik}$), intent(out) :: info complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(in) :: tau(*) complex(sp), intent(out) :: work(*) end subroutine cunghr -#else - module procedure stdlib_cunghr +#else + module procedure stdlib${ii}$_cunghr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$unghr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zunghr( n, ilo, ihi, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(in) :: ihi,ilo,lda,lwork,n - integer(ilp), intent(out) :: info + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(in) :: ihi,ilo,lda,lwork,n + integer(${ik}$), intent(out) :: info complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: tau(*) complex(dp), intent(out) :: work(*) end subroutine zunghr -#else - module procedure stdlib_zunghr +#else + module procedure stdlib${ii}$_zunghr #endif - end interface unghr - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$unghr +#:endif +#:endfor +#:endfor + end interface unghr interface unglq !! UNGLQ generates an M-by-N complex matrix Q with orthonormal rows, @@ -30770,41 +30688,41 @@ module stdlib_linalg_lapack !! reflectors of order N !! Q = H(k)**H . . . H(2)**H H(1)**H !! as returned by CGELQF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cunglq( m, n, k, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,lda,lwork,m,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(in) :: tau(*) complex(sp), intent(out) :: work(*) end subroutine cunglq -#else - module procedure stdlib_cunglq +#else + module procedure stdlib${ii}$_cunglq #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$unglq - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zunglq( m, n, k, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,lda,lwork,m,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: tau(*) complex(dp), intent(out) :: work(*) end subroutine zunglq -#else - module procedure stdlib_zunglq +#else + module procedure stdlib${ii}$_zunglq #endif - end interface unglq - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$unglq +#:endif +#:endfor +#:endfor + end interface unglq interface ungql !! UNGQL generates an M-by-N complex matrix Q with orthonormal columns, @@ -30812,41 +30730,41 @@ module stdlib_linalg_lapack !! reflectors of order M !! Q = H(k) . . . H(2) H(1) !! as returned by CGEQLF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cungql( m, n, k, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,lda,lwork,m,n complex(sp), intent(inout) :: a(lda,*) - complex(sp), intent(in) :: tau(*) - complex(sp), intent(out) :: work(*) - end subroutine cungql -#else - module procedure stdlib_cungql -#endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ungql - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK + complex(sp), intent(in) :: tau(*) + complex(sp), intent(out) :: work(*) + end subroutine cungql +#else + module procedure stdlib${ii}$_cungql +#endif +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zungql( m, n, k, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,lda,lwork,m,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: tau(*) complex(dp), intent(out) :: work(*) end subroutine zungql -#else - module procedure stdlib_zungql +#else + module procedure stdlib${ii}$_zungql #endif - end interface ungql - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ungql +#:endif +#:endfor +#:endfor + end interface ungql interface ungqr !! UNGQR generates an M-by-N complex matrix Q with orthonormal columns, @@ -30854,41 +30772,41 @@ module stdlib_linalg_lapack !! reflectors of order M !! Q = H(1) H(2) . . . H(k) !! as returned by CGEQRF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cungqr( m, n, k, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,lda,lwork,m,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(in) :: tau(*) complex(sp), intent(out) :: work(*) end subroutine cungqr -#else - module procedure stdlib_cungqr +#else + module procedure stdlib${ii}$_cungqr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ungqr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zungqr( m, n, k, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,lda,lwork,m,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: tau(*) complex(dp), intent(out) :: work(*) end subroutine zungqr -#else - module procedure stdlib_zungqr +#else + module procedure stdlib${ii}$_zungqr #endif - end interface ungqr - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ungqr +#:endif +#:endfor +#:endfor + end interface ungqr interface ungrq !! UNGRQ generates an M-by-N complex matrix Q with orthonormal rows, @@ -30896,41 +30814,41 @@ module stdlib_linalg_lapack !! reflectors of order N !! Q = H(1)**H H(2)**H . . . H(k)**H !! as returned by CGERQF. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cungrq( m, n, k, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,lda,lwork,m,n complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(in) :: tau(*) complex(sp), intent(out) :: work(*) end subroutine cungrq -#else - module procedure stdlib_cungrq +#else + module procedure stdlib${ii}$_cungrq #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ungrq - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zungrq( m, n, k, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: k,lda,lwork,m,n + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k,lda,lwork,m,n complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: tau(*) complex(dp), intent(out) :: work(*) end subroutine zungrq -#else - module procedure stdlib_zungrq +#else + module procedure stdlib${ii}$_zungrq #endif - end interface ungrq - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ungrq +#:endif +#:endfor +#:endfor + end interface ungrq interface ungtr !! UNGTR generates a complex unitary matrix Q which is defined as the @@ -30938,43 +30856,43 @@ module stdlib_linalg_lapack !! CHETRD: !! if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), !! if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cungtr( uplo, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(in) :: tau(*) complex(sp), intent(out) :: work(*) end subroutine cungtr -#else - module procedure stdlib_cungtr +#else + module procedure stdlib${ii}$_cungtr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ungtr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zungtr( uplo, n, a, lda, tau, work, lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: tau(*) complex(dp), intent(out) :: work(*) end subroutine zungtr -#else - module procedure stdlib_zungtr +#else + module procedure stdlib${ii}$_zungtr #endif - end interface ungtr - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ungtr +#:endif +#:endfor +#:endfor + end interface ungtr interface ungtsqr !! UNGTSQR generates an M-by-N complex matrix Q_out with orthonormal @@ -30982,41 +30900,41 @@ module stdlib_linalg_lapack !! matrices of order M which are returned by CLATSQR !! Q_out = first_N_columns_of( Q(1)_in * Q(2)_in * ... * Q(k)_in ). !! See the documentation for CLATSQR. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cungtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,lwork,m,n,mb,nb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,lwork,m,n,mb,nb complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(in) :: t(ldt,*) complex(sp), intent(out) :: work(*) end subroutine cungtsqr -#else - module procedure stdlib_cungtsqr +#else + module procedure stdlib${ii}$_cungtsqr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ungtsqr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zungtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,lwork,m,n,mb,nb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,lwork,m,n,mb,nb complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: t(ldt,*) complex(dp), intent(out) :: work(*) end subroutine zungtsqr -#else - module procedure stdlib_zungtsqr +#else + module procedure stdlib${ii}$_zungtsqr #endif - end interface ungtsqr - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ungtsqr +#:endif +#:endfor +#:endfor + end interface ungtsqr interface ungtsqr_row !! UNGTSQR_ROW generates an M-by-N complex matrix Q_out with @@ -31034,43 +30952,43 @@ module stdlib_linalg_lapack !! starting in the bottom row block and continues to the top row block !! (hence _ROW in the routine name). This sweep is in reverse order of !! the order in which CLATSQR generates the output blocks. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cungtsqr_row( m, n, mb, nb, a, lda, t, ldt, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,lwork,m,n,mb,nb + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,lwork,m,n,mb,nb complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(in) :: t(ldt,*) complex(sp), intent(out) :: work(*) end subroutine cungtsqr_row -#else - module procedure stdlib_cungtsqr_row +#else + module procedure stdlib${ii}$_cungtsqr_row #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$ungtsqr_row - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zungtsqr_row( m, n, mb, nb, a, lda, t, ldt, work,lwork, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,lwork,m,n,mb,nb + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,lwork,m,n,mb,nb complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: t(ldt,*) complex(dp), intent(out) :: work(*) end subroutine zungtsqr_row -#else - module procedure stdlib_zungtsqr_row +#else + module procedure stdlib${ii}$_zungtsqr_row #endif - end interface ungtsqr_row - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$ungtsqr_row +#:endif +#:endfor +#:endfor + end interface ungtsqr_row interface unhr_col !! UNHR_COL takes an M-by-N complex matrix Q_in with orthonormal columns @@ -31082,39 +31000,39 @@ module stdlib_linalg_lapack !! stored in A on output, and the diagonal entries of S are stored in D. !! Block reflectors are also returned in T !! (same output format as CGEQRT). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cunhr_col( m, n, nb, a, lda, t, ldt, d, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,m,n,nb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,m,n,nb complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: d(*),t(ldt,*) end subroutine cunhr_col -#else - module procedure stdlib_cunhr_col +#else + module procedure stdlib${ii}$_cunhr_col #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$unhr_col - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zunhr_col( m, n, nb, a, lda, t, ldt, d, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldt,m,n,nb + import sp,dp,qp,${ik}$,lk + implicit none(type,external) + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldt,m,n,nb complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: d(*),t(ldt,*) end subroutine zunhr_col -#else - module procedure stdlib_zunhr_col +#else + module procedure stdlib${ii}$_zunhr_col #endif - end interface unhr_col - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$unhr_col +#:endif +#:endfor +#:endfor + end interface unhr_col interface unm2l !! UNM2L overwrites the general complex m-by-n matrix C with @@ -31127,45 +31045,45 @@ module stdlib_linalg_lapack !! Q = H(k) . . . H(2) H(1) !! as returned by CGEQLF. Q is of order m if SIDE = 'L' and of order n !! if SIDE = 'R'. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cunm2l( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(inout) :: a(lda,*),c(ldc,*) complex(sp), intent(in) :: tau(*) complex(sp), intent(out) :: work(*) end subroutine cunm2l -#else - module procedure stdlib_cunm2l +#else + module procedure stdlib${ii}$_cunm2l #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$unm2l - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zunm2l( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(inout) :: a(lda,*),c(ldc,*) complex(dp), intent(in) :: tau(*) complex(dp), intent(out) :: work(*) end subroutine zunm2l -#else - module procedure stdlib_zunm2l +#else + module procedure stdlib${ii}$_zunm2l #endif - end interface unm2l - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$unm2l +#:endif +#:endfor +#:endfor + end interface unm2l interface unm2r !! UNM2R overwrites the general complex m-by-n matrix C with @@ -31178,45 +31096,45 @@ module stdlib_linalg_lapack !! Q = H(1) H(2) . . . H(k) !! as returned by CGEQRF. Q is of order m if SIDE = 'L' and of order n !! if SIDE = 'R'. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cunm2r( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(inout) :: a(lda,*),c(ldc,*) complex(sp), intent(in) :: tau(*) complex(sp), intent(out) :: work(*) end subroutine cunm2r -#else - module procedure stdlib_cunm2r +#else + module procedure stdlib${ii}$_cunm2r #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$unm2r - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zunm2r( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(inout) :: a(lda,*),c(ldc,*) complex(dp), intent(in) :: tau(*) complex(dp), intent(out) :: work(*) end subroutine zunm2r -#else - module procedure stdlib_zunm2r +#else + module procedure stdlib${ii}$_zunm2r #endif - end interface unm2r - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$unm2r +#:endif +#:endfor +#:endfor + end interface unm2r interface unmbr !! If VECT = 'Q', UNMBR: overwrites the general complex M-by-N matrix C @@ -31241,45 +31159,45 @@ module stdlib_linalg_lapack !! If VECT = 'P', A is assumed to have been a K-by-NQ matrix: !! if k < nq, P = G(1) G(2) . . . G(k); !! if k >= nq, P = G(1) G(2) . . . G(nq-1). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cunmbr( vect, side, trans, m, n, k, a, lda, tau, c,ldc, work, & lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans,vect - 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 complex(sp), intent(inout) :: a(lda,*),c(ldc,*) complex(sp), intent(in) :: tau(*) complex(sp), intent(out) :: work(*) end subroutine cunmbr -#else - module procedure stdlib_cunmbr +#else + module procedure stdlib${ii}$_cunmbr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$unmbr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zunmbr( vect, side, trans, m, n, k, a, lda, tau, c,ldc, work, & lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans,vect - 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 complex(dp), intent(inout) :: a(lda,*),c(ldc,*) complex(dp), intent(in) :: tau(*) complex(dp), intent(out) :: work(*) end subroutine zunmbr -#else - module procedure stdlib_zunmbr +#else + module procedure stdlib${ii}$_zunmbr #endif - end interface unmbr - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$unmbr +#:endif +#:endfor +#:endfor + end interface unmbr interface unmhr !! UNMHR overwrites the general complex M-by-N matrix C with @@ -31290,45 +31208,45 @@ module stdlib_linalg_lapack !! SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of !! IHI-ILO elementary reflectors, as returned by CGEHRD: !! Q = H(ilo) H(ilo+1) . . . H(ihi-1). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cunmhr( side, trans, m, n, ilo, ihi, a, lda, tau, c,ldc, work, & lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(in) :: ihi,ilo,lda,ldc,lwork,m,n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi,ilo,lda,ldc,lwork,m,n + integer(${ik}$), intent(out) :: info complex(sp), intent(inout) :: a(lda,*),c(ldc,*) complex(sp), intent(in) :: tau(*) complex(sp), intent(out) :: work(*) end subroutine cunmhr -#else - module procedure stdlib_cunmhr +#else + module procedure stdlib${ii}$_cunmhr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$unmhr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zunmhr( side, trans, m, n, ilo, ihi, a, lda, tau, c,ldc, work, & lwork, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans - integer(ilp), intent(in) :: ihi,ilo,lda,ldc,lwork,m,n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi,ilo,lda,ldc,lwork,m,n + integer(${ik}$), intent(out) :: info complex(dp), intent(inout) :: a(lda,*),c(ldc,*) complex(dp), intent(in) :: tau(*) complex(dp), intent(out) :: work(*) end subroutine zunmhr -#else - module procedure stdlib_zunmhr +#else + module procedure stdlib${ii}$_zunmhr #endif - end interface unmhr - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$unmhr +#:endif +#:endfor +#:endfor + end interface unmhr interface unmlq !! UNMLQ overwrites the general complex M-by-N matrix C with @@ -31340,45 +31258,45 @@ module stdlib_linalg_lapack !! Q = H(k)**H . . . H(2)**H H(1)**H !! as returned by CGELQF. Q is of order M if SIDE = 'L' and of order N !! if SIDE = 'R'. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cunmlq( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(inout) :: a(lda,*),c(ldc,*) complex(sp), intent(in) :: tau(*) complex(sp), intent(out) :: work(*) end subroutine cunmlq -#else - module procedure stdlib_cunmlq +#else + module procedure stdlib${ii}$_cunmlq #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$unmlq - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zunmlq( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(inout) :: a(lda,*),c(ldc,*) complex(dp), intent(in) :: tau(*) complex(dp), intent(out) :: work(*) end subroutine zunmlq -#else - module procedure stdlib_zunmlq +#else + module procedure stdlib${ii}$_zunmlq #endif - end interface unmlq - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$unmlq +#:endif +#:endfor +#:endfor + end interface unmlq interface unmql !! UNMQL overwrites the general complex M-by-N matrix C with @@ -31390,45 +31308,45 @@ module stdlib_linalg_lapack !! Q = H(k) . . . H(2) H(1) !! as returned by CGEQLF. Q is of order M if SIDE = 'L' and of order N !! if SIDE = 'R'. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cunmql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(inout) :: a(lda,*),c(ldc,*) complex(sp), intent(in) :: tau(*) complex(sp), intent(out) :: work(*) end subroutine cunmql -#else - module procedure stdlib_cunmql +#else + module procedure stdlib${ii}$_cunmql #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$unmql - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zunmql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(inout) :: a(lda,*),c(ldc,*) complex(dp), intent(in) :: tau(*) complex(dp), intent(out) :: work(*) end subroutine zunmql -#else - module procedure stdlib_zunmql +#else + module procedure stdlib${ii}$_zunmql #endif - end interface unmql - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$unmql +#:endif +#:endfor +#:endfor + end interface unmql interface unmqr !! UNMQR overwrites the general complex M-by-N matrix C with @@ -31440,45 +31358,45 @@ module stdlib_linalg_lapack !! Q = H(1) H(2) . . . H(k) !! as returned by CGEQRF. Q is of order M if SIDE = 'L' and of order N !! if SIDE = 'R'. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cunmqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(inout) :: a(lda,*),c(ldc,*) complex(sp), intent(in) :: tau(*) complex(sp), intent(out) :: work(*) end subroutine cunmqr -#else - module procedure stdlib_cunmqr +#else + module procedure stdlib${ii}$_cunmqr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$unmqr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zunmqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(inout) :: a(lda,*),c(ldc,*) complex(dp), intent(in) :: tau(*) complex(dp), intent(out) :: work(*) end subroutine zunmqr -#else - module procedure stdlib_zunmqr +#else + module procedure stdlib${ii}$_zunmqr #endif - end interface unmqr - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$unmqr +#:endif +#:endfor +#:endfor + end interface unmqr interface unmrq !! UNMRQ overwrites the general complex M-by-N matrix C with @@ -31490,45 +31408,45 @@ module stdlib_linalg_lapack !! Q = H(1)**H H(2)**H . . . H(k)**H !! as returned by CGERQF. Q is of order M if SIDE = 'L' and of order N !! if SIDE = 'R'. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cunmrq( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(inout) :: a(lda,*),c(ldc,*) complex(sp), intent(in) :: tau(*) complex(sp), intent(out) :: work(*) end subroutine cunmrq -#else - module procedure stdlib_cunmrq +#else + module procedure stdlib${ii}$_cunmrq #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$unmrq - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zunmrq( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(inout) :: a(lda,*),c(ldc,*) complex(dp), intent(in) :: tau(*) complex(dp), intent(out) :: work(*) end subroutine zunmrq -#else - module procedure stdlib_zunmrq +#else + module procedure stdlib${ii}$_zunmrq #endif - end interface unmrq - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$unmrq +#:endif +#:endfor +#:endfor + end interface unmrq interface unmrz !! UNMRZ overwrites the general complex M-by-N matrix C with @@ -31540,45 +31458,45 @@ module stdlib_linalg_lapack !! Q = H(1) H(2) . . . H(k) !! as returned by CTZRZF. Q is of order M if SIDE = 'L' and of order N !! if SIDE = 'R'. -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cunmrz( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(sp), intent(inout) :: a(lda,*),c(ldc,*) complex(sp), intent(in) :: tau(*) complex(sp), intent(out) :: work(*) end subroutine cunmrz -#else - module procedure stdlib_cunmrz +#else + module procedure stdlib${ii}$_cunmrz #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$unmrz - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zunmrz( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) 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 complex(dp), intent(inout) :: a(lda,*),c(ldc,*) complex(dp), intent(in) :: tau(*) complex(dp), intent(out) :: work(*) end subroutine zunmrz -#else - module procedure stdlib_zunmrz +#else + module procedure stdlib${ii}$_zunmrz #endif - end interface unmrz - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$unmrz +#:endif +#:endfor +#:endfor + end interface unmrz interface unmtr !! UNMTR overwrites the general complex M-by-N matrix C with @@ -31590,45 +31508,45 @@ module stdlib_linalg_lapack !! nq-1 elementary reflectors, as returned by CHETRD: !! if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); !! if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cunmtr( side, uplo, trans, m, n, a, lda, tau, c, ldc,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldc,lwork,m,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldc,lwork,m,n complex(sp), intent(inout) :: a(lda,*),c(ldc,*) complex(sp), intent(in) :: tau(*) complex(sp), intent(out) :: work(*) end subroutine cunmtr -#else - module procedure stdlib_cunmtr +#else + module procedure stdlib${ii}$_cunmtr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$unmtr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zunmtr( side, uplo, trans, m, n, a, lda, tau, c, ldc,work, lwork, & info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda,ldc,lwork,m,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda,ldc,lwork,m,n complex(dp), intent(inout) :: a(lda,*),c(ldc,*) complex(dp), intent(in) :: tau(*) complex(dp), intent(out) :: work(*) end subroutine zunmtr -#else - module procedure stdlib_zunmtr +#else + module procedure stdlib${ii}$_zunmtr #endif - end interface unmtr - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$unmtr +#:endif +#:endfor +#:endfor + end interface unmtr interface upgtr !! UPGTR generates a complex unitary matrix Q which is defined as the @@ -31636,41 +31554,41 @@ module stdlib_linalg_lapack !! CHPTRD using packed storage: !! if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), !! if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cupgtr( uplo, n, ap, tau, q, ldq, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldq,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldq,n complex(sp), intent(in) :: ap(*),tau(*) complex(sp), intent(out) :: q(ldq,*),work(*) end subroutine cupgtr -#else - module procedure stdlib_cupgtr +#else + module procedure stdlib${ii}$_cupgtr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$upgtr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zupgtr( uplo, n, ap, tau, q, ldq, work, info ) - import sp,dp,qp,ilp,lk - implicit none(type,external) + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldq,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldq,n complex(dp), intent(in) :: ap(*),tau(*) complex(dp), intent(out) :: q(ldq,*),work(*) end subroutine zupgtr -#else - module procedure stdlib_zupgtr +#else + module procedure stdlib${ii}$_zupgtr #endif - end interface upgtr - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$upgtr +#:endif +#:endfor +#:endfor + end interface upgtr interface upmtr !! UPMTR overwrites the general complex M-by-N matrix C with @@ -31683,46 +31601,44 @@ module stdlib_linalg_lapack !! storage: !! if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); !! if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). -#ifdef STDLIB_EXTERNAL_LAPACK +#:for ik,it,ii in LINALG_INT_KINDS_TYPES +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine cupmtr( side, uplo, trans, m, n, ap, tau, c, ldc, work,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldc,m,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldc,m,n complex(sp), intent(inout) :: ap(*),c(ldc,*) complex(sp), intent(in) :: tau(*) complex(sp), intent(out) :: work(*) end subroutine cupmtr -#else - module procedure stdlib_cupmtr +#else + module procedure stdlib${ii}$_cupmtr #endif -#:for rk,rt,ri in CMPLX_KINDS_TYPES -#:if not rk in ["sp","dp"] - module procedure stdlib_${ri}$upmtr - -#:endif -#:endfor -#ifdef STDLIB_EXTERNAL_LAPACK +#ifdef STDLIB_EXTERNAL_LAPACK${ii}$ pure subroutine zupmtr( side, uplo, trans, m, n, ap, tau, c, ldc, work,info ) - - import sp,dp,qp,ilp,lk - implicit none(type,external) + + import sp,dp,qp,${ik}$,lk + implicit none(type,external) character, intent(in) :: side,trans,uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldc,m,n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldc,m,n complex(dp), intent(inout) :: ap(*),c(ldc,*) complex(dp), intent(in) :: tau(*) complex(dp), intent(out) :: work(*) end subroutine zupmtr -#else - module procedure stdlib_zupmtr +#else + module procedure stdlib${ii}$_zupmtr #endif - end interface upmtr - - - +#:for rk,rt,ri in CMPLX_KINDS_TYPES +#:if not rk in ["sp","dp"] + module procedure stdlib${ii}$_${ri}$upmtr +#:endif +#:endfor +#:endfor + end interface upmtr end module stdlib_linalg_lapack 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 diff --git a/src/stdlib_linalg_lapack_c.fypp b/src/stdlib_linalg_lapack_c.fypp index f7a3891f1..d9f50b293 100644 --- a/src/stdlib_linalg_lapack_c.fypp +++ b/src/stdlib_linalg_lapack_c.fypp @@ -8,454 +8,456 @@ module stdlib_linalg_lapack_c private - public :: sp,dp,qp,lk,ilp - public :: stdlib_cbbcsd - public :: stdlib_cbdsqr - public :: stdlib_cgbbrd - public :: stdlib_cgbcon - public :: stdlib_cgbequ - public :: stdlib_cgbequb - public :: stdlib_cgbrfs - public :: stdlib_cgbsv - public :: stdlib_cgbsvx - public :: stdlib_cgbtf2 - public :: stdlib_cgbtrf - public :: stdlib_cgbtrs - public :: stdlib_cgebak - public :: stdlib_cgebal - public :: stdlib_cgebd2 - public :: stdlib_cgebrd - public :: stdlib_cgecon - public :: stdlib_cgeequ - public :: stdlib_cgeequb - public :: stdlib_cgees - public :: stdlib_cgeesx - public :: stdlib_cgeev - public :: stdlib_cgeevx - public :: stdlib_cgehd2 - public :: stdlib_cgehrd - public :: stdlib_cgejsv - public :: stdlib_cgelq - public :: stdlib_cgelq2 - public :: stdlib_cgelqf - public :: stdlib_cgelqt - public :: stdlib_cgelqt3 - public :: stdlib_cgels - public :: stdlib_cgelsd - public :: stdlib_cgelss - public :: stdlib_cgelsy - public :: stdlib_cgemlq - public :: stdlib_cgemlqt - public :: stdlib_cgemqr - public :: stdlib_cgemqrt - public :: stdlib_cgeql2 - public :: stdlib_cgeqlf - public :: stdlib_cgeqp3 - public :: stdlib_cgeqr - public :: stdlib_cgeqr2 - public :: stdlib_cgeqr2p - public :: stdlib_cgeqrf - public :: stdlib_cgeqrfp - public :: stdlib_cgeqrt - public :: stdlib_cgeqrt2 - public :: stdlib_cgeqrt3 - public :: stdlib_cgerfs - public :: stdlib_cgerq2 - public :: stdlib_cgerqf - public :: stdlib_cgesc2 - public :: stdlib_cgesdd - public :: stdlib_cgesv - public :: stdlib_cgesvd - public :: stdlib_cgesvdq - public :: stdlib_cgesvj - public :: stdlib_cgesvx - public :: stdlib_cgetc2 - public :: stdlib_cgetf2 - public :: stdlib_cgetrf - public :: stdlib_cgetrf2 - public :: stdlib_cgetri - public :: stdlib_cgetrs - public :: stdlib_cgetsls - public :: stdlib_cgetsqrhrt - public :: stdlib_cggbak - public :: stdlib_cggbal - public :: stdlib_cgges - public :: stdlib_cgges3 - public :: stdlib_cggesx - public :: stdlib_cggev - public :: stdlib_cggev3 - public :: stdlib_cggevx - public :: stdlib_cggglm - public :: stdlib_cgghd3 - public :: stdlib_cgghrd - public :: stdlib_cgglse - public :: stdlib_cggqrf - public :: stdlib_cggrqf - public :: stdlib_cgsvj0 - public :: stdlib_cgsvj1 - public :: stdlib_cgtcon - public :: stdlib_cgtrfs - public :: stdlib_cgtsv - public :: stdlib_cgtsvx - public :: stdlib_cgttrf - public :: stdlib_cgttrs - public :: stdlib_cgtts2 - public :: stdlib_chb2st_kernels - public :: stdlib_chbev - public :: stdlib_chbevd - public :: stdlib_chbevx - public :: stdlib_chbgst - public :: stdlib_chbgv - public :: stdlib_chbgvd - public :: stdlib_chbgvx - public :: stdlib_chbtrd - public :: stdlib_checon - public :: stdlib_checon_rook - public :: stdlib_cheequb - public :: stdlib_cheev - public :: stdlib_cheevd - public :: stdlib_cheevr - public :: stdlib_cheevx - public :: stdlib_chegs2 - public :: stdlib_chegst - public :: stdlib_chegv - public :: stdlib_chegvd - public :: stdlib_chegvx - public :: stdlib_cherfs - public :: stdlib_chesv - public :: stdlib_chesv_aa - public :: stdlib_chesv_rk - public :: stdlib_chesv_rook - public :: stdlib_chesvx - public :: stdlib_cheswapr - public :: stdlib_chetd2 - public :: stdlib_chetf2 - public :: stdlib_chetf2_rk - public :: stdlib_chetf2_rook - public :: stdlib_chetrd - public :: stdlib_chetrd_hb2st - public :: stdlib_chetrd_he2hb - public :: stdlib_chetrf - public :: stdlib_chetrf_aa - public :: stdlib_chetrf_rk - public :: stdlib_chetrf_rook - public :: stdlib_chetri - public :: stdlib_chetri_rook - public :: stdlib_chetrs - public :: stdlib_chetrs2 - public :: stdlib_chetrs_3 - public :: stdlib_chetrs_aa - public :: stdlib_chetrs_rook - public :: stdlib_chfrk - public :: stdlib_chgeqz - public :: stdlib_chpcon - public :: stdlib_chpev - public :: stdlib_chpevd - public :: stdlib_chpevx - public :: stdlib_chpgst - public :: stdlib_chpgv - public :: stdlib_chpgvd - public :: stdlib_chpgvx - public :: stdlib_chprfs - public :: stdlib_chpsv - public :: stdlib_chpsvx - public :: stdlib_chptrd - public :: stdlib_chptrf - public :: stdlib_chptri - public :: stdlib_chptrs - public :: stdlib_chsein - public :: stdlib_chseqr - public :: stdlib_cla_gbamv - public :: stdlib_cla_gbrcond_c - public :: stdlib_cla_gbrpvgrw - public :: stdlib_cla_geamv - public :: stdlib_cla_gercond_c - public :: stdlib_cla_gerpvgrw - public :: stdlib_cla_heamv - public :: stdlib_cla_hercond_c - public :: stdlib_cla_herpvgrw - public :: stdlib_cla_lin_berr - public :: stdlib_cla_porcond_c - public :: stdlib_cla_porpvgrw - public :: stdlib_cla_syamv - public :: stdlib_cla_syrcond_c - public :: stdlib_cla_syrpvgrw - public :: stdlib_cla_wwaddw - public :: stdlib_clabrd - public :: stdlib_clacgv - public :: stdlib_clacn2 - public :: stdlib_clacon - public :: stdlib_clacp2 - public :: stdlib_clacpy - public :: stdlib_clacrm - public :: stdlib_clacrt - public :: stdlib_cladiv - public :: stdlib_claed0 - public :: stdlib_claed7 - public :: stdlib_claed8 - public :: stdlib_claein - public :: stdlib_claesy - public :: stdlib_claev2 - public :: stdlib_clag2z - public :: stdlib_clags2 - public :: stdlib_clagtm - public :: stdlib_clahef - public :: stdlib_clahef_aa - public :: stdlib_clahef_rk - public :: stdlib_clahef_rook - public :: stdlib_clahqr - public :: stdlib_clahr2 - public :: stdlib_claic1 - public :: stdlib_clals0 - public :: stdlib_clalsa - public :: stdlib_clalsd - public :: stdlib_clamswlq - public :: stdlib_clamtsqr - public :: stdlib_clangb - public :: stdlib_clange - public :: stdlib_clangt - public :: stdlib_clanhb - public :: stdlib_clanhe - public :: stdlib_clanhf - public :: stdlib_clanhp - public :: stdlib_clanhs - public :: stdlib_clanht - public :: stdlib_clansb - public :: stdlib_clansp - public :: stdlib_clansy - public :: stdlib_clantb - public :: stdlib_clantp - public :: stdlib_clantr - public :: stdlib_clapll - public :: stdlib_clapmr - public :: stdlib_clapmt - public :: stdlib_claqgb - public :: stdlib_claqge - public :: stdlib_claqhb - public :: stdlib_claqhe - public :: stdlib_claqhp - public :: stdlib_claqp2 - public :: stdlib_claqps - public :: stdlib_claqr0 - public :: stdlib_claqr1 - public :: stdlib_claqr2 - public :: stdlib_claqr3 - public :: stdlib_claqr4 - public :: stdlib_claqr5 - public :: stdlib_claqsb - public :: stdlib_claqsp - public :: stdlib_claqsy - public :: stdlib_claqz0 - public :: stdlib_claqz1 - public :: stdlib_claqz2 - public :: stdlib_claqz3 - public :: stdlib_clar1v - public :: stdlib_clar2v - public :: stdlib_clarcm - public :: stdlib_clarf - public :: stdlib_clarfb - public :: stdlib_clarfb_gett - public :: stdlib_clarfg - public :: stdlib_clarfgp - public :: stdlib_clarft - public :: stdlib_clarfx - public :: stdlib_clarfy - public :: stdlib_clargv - public :: stdlib_clarnv - public :: stdlib_clarrv - public :: stdlib_clartg - public :: stdlib_clartv - public :: stdlib_clarz - public :: stdlib_clarzb - public :: stdlib_clarzt - public :: stdlib_clascl - public :: stdlib_claset - public :: stdlib_clasr - public :: stdlib_classq - public :: stdlib_claswlq - public :: stdlib_claswp - public :: stdlib_clasyf - public :: stdlib_clasyf_aa - public :: stdlib_clasyf_rk - public :: stdlib_clasyf_rook - public :: stdlib_clatbs - public :: stdlib_clatdf - public :: stdlib_clatps - public :: stdlib_clatrd - public :: stdlib_clatrs - public :: stdlib_clatrz - public :: stdlib_clatsqr - public :: stdlib_claunhr_col_getrfnp - public :: stdlib_claunhr_col_getrfnp2 - public :: stdlib_clauu2 - public :: stdlib_clauum - public :: stdlib_cpbcon - public :: stdlib_cpbequ - public :: stdlib_cpbrfs - public :: stdlib_cpbstf - public :: stdlib_cpbsv - public :: stdlib_cpbsvx - public :: stdlib_cpbtf2 - public :: stdlib_cpbtrf - public :: stdlib_cpbtrs - public :: stdlib_cpftrf - public :: stdlib_cpftri - public :: stdlib_cpftrs - public :: stdlib_cpocon - public :: stdlib_cpoequ - public :: stdlib_cpoequb - public :: stdlib_cporfs - public :: stdlib_cposv - public :: stdlib_cposvx - public :: stdlib_cpotf2 - public :: stdlib_cpotrf - public :: stdlib_cpotrf2 - public :: stdlib_cpotri - public :: stdlib_cpotrs - public :: stdlib_cppcon - public :: stdlib_cppequ - public :: stdlib_cpprfs - public :: stdlib_cppsv - public :: stdlib_cppsvx - public :: stdlib_cpptrf - public :: stdlib_cpptri - public :: stdlib_cpptrs - public :: stdlib_cpstf2 - public :: stdlib_cpstrf - public :: stdlib_cptcon - public :: stdlib_cpteqr - public :: stdlib_cptrfs - public :: stdlib_cptsv - public :: stdlib_cptsvx - public :: stdlib_cpttrf - public :: stdlib_cpttrs - public :: stdlib_cptts2 - public :: stdlib_crot - public :: stdlib_cspcon - public :: stdlib_cspmv - public :: stdlib_cspr - public :: stdlib_csprfs - public :: stdlib_cspsv - public :: stdlib_cspsvx - public :: stdlib_csptrf - public :: stdlib_csptri - public :: stdlib_csptrs - public :: stdlib_csrscl - public :: stdlib_cstedc - public :: stdlib_cstegr - public :: stdlib_cstein - public :: stdlib_cstemr - public :: stdlib_csteqr - public :: stdlib_csycon - public :: stdlib_csycon_rook - public :: stdlib_csyconv - public :: stdlib_csyconvf - public :: stdlib_csyconvf_rook - public :: stdlib_csyequb - public :: stdlib_csymv - public :: stdlib_csyr - public :: stdlib_csyrfs - public :: stdlib_csysv - public :: stdlib_csysv_aa - public :: stdlib_csysv_rk - public :: stdlib_csysv_rook - public :: stdlib_csysvx - public :: stdlib_csyswapr - public :: stdlib_csytf2 - public :: stdlib_csytf2_rk - public :: stdlib_csytf2_rook - public :: stdlib_csytrf - public :: stdlib_csytrf_aa - public :: stdlib_csytrf_rk - public :: stdlib_csytrf_rook - public :: stdlib_csytri - public :: stdlib_csytri_rook - public :: stdlib_csytrs - public :: stdlib_csytrs2 - public :: stdlib_csytrs_3 - public :: stdlib_csytrs_aa - public :: stdlib_csytrs_rook - public :: stdlib_ctbcon - public :: stdlib_ctbrfs - public :: stdlib_ctbtrs - public :: stdlib_ctfsm - public :: stdlib_ctftri - public :: stdlib_ctfttp - public :: stdlib_ctfttr - public :: stdlib_ctgevc - public :: stdlib_ctgex2 - public :: stdlib_ctgexc - public :: stdlib_ctgsen - public :: stdlib_ctgsja - public :: stdlib_ctgsna - public :: stdlib_ctgsy2 - public :: stdlib_ctgsyl - public :: stdlib_ctpcon - public :: stdlib_ctplqt - public :: stdlib_ctplqt2 - public :: stdlib_ctpmlqt - public :: stdlib_ctpmqrt - public :: stdlib_ctpqrt - public :: stdlib_ctpqrt2 - public :: stdlib_ctprfb - public :: stdlib_ctprfs - public :: stdlib_ctptri - public :: stdlib_ctptrs - public :: stdlib_ctpttf - public :: stdlib_ctpttr - public :: stdlib_ctrcon - public :: stdlib_ctrevc - public :: stdlib_ctrevc3 - public :: stdlib_ctrexc - public :: stdlib_ctrrfs - public :: stdlib_ctrsen - public :: stdlib_ctrsna - public :: stdlib_ctrsyl - public :: stdlib_ctrti2 - public :: stdlib_ctrtri - public :: stdlib_ctrtrs - public :: stdlib_ctrttf - public :: stdlib_ctrttp - public :: stdlib_ctzrzf - public :: stdlib_cunbdb - public :: stdlib_cunbdb1 - public :: stdlib_cunbdb2 - public :: stdlib_cunbdb3 - public :: stdlib_cunbdb4 - public :: stdlib_cunbdb5 - public :: stdlib_cunbdb6 - public :: stdlib_cuncsd - public :: stdlib_cuncsd2by1 - public :: stdlib_cung2l - public :: stdlib_cung2r - public :: stdlib_cungbr - public :: stdlib_cunghr - public :: stdlib_cungl2 - public :: stdlib_cunglq - public :: stdlib_cungql - public :: stdlib_cungqr - public :: stdlib_cungr2 - public :: stdlib_cungrq - public :: stdlib_cungtr - public :: stdlib_cungtsqr - public :: stdlib_cungtsqr_row - public :: stdlib_cunhr_col - public :: stdlib_cunm22 - public :: stdlib_cunm2l - public :: stdlib_cunm2r - public :: stdlib_cunmbr - public :: stdlib_cunmhr - public :: stdlib_cunml2 - public :: stdlib_cunmlq - public :: stdlib_cunmql - public :: stdlib_cunmqr - public :: stdlib_cunmr2 - public :: stdlib_cunmr3 - public :: stdlib_cunmrq - public :: stdlib_cunmrz - public :: stdlib_cunmtr - public :: stdlib_cupgtr - public :: stdlib_cupmtr + public :: sp,dp,qp,lk,ilp,ilp64 + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + public :: stdlib${ii}$_cbbcsd + public :: stdlib${ii}$_cbdsqr + public :: stdlib${ii}$_cgbbrd + public :: stdlib${ii}$_cgbcon + public :: stdlib${ii}$_cgbequ + public :: stdlib${ii}$_cgbequb + public :: stdlib${ii}$_cgbrfs + public :: stdlib${ii}$_cgbsv + public :: stdlib${ii}$_cgbsvx + public :: stdlib${ii}$_cgbtf2 + public :: stdlib${ii}$_cgbtrf + public :: stdlib${ii}$_cgbtrs + public :: stdlib${ii}$_cgebak + public :: stdlib${ii}$_cgebal + public :: stdlib${ii}$_cgebd2 + public :: stdlib${ii}$_cgebrd + public :: stdlib${ii}$_cgecon + public :: stdlib${ii}$_cgeequ + public :: stdlib${ii}$_cgeequb + public :: stdlib${ii}$_cgees + public :: stdlib${ii}$_cgeesx + public :: stdlib${ii}$_cgeev + public :: stdlib${ii}$_cgeevx + public :: stdlib${ii}$_cgehd2 + public :: stdlib${ii}$_cgehrd + public :: stdlib${ii}$_cgejsv + public :: stdlib${ii}$_cgelq + public :: stdlib${ii}$_cgelq2 + public :: stdlib${ii}$_cgelqf + public :: stdlib${ii}$_cgelqt + public :: stdlib${ii}$_cgelqt3 + public :: stdlib${ii}$_cgels + public :: stdlib${ii}$_cgelsd + public :: stdlib${ii}$_cgelss + public :: stdlib${ii}$_cgelsy + public :: stdlib${ii}$_cgemlq + public :: stdlib${ii}$_cgemlqt + public :: stdlib${ii}$_cgemqr + public :: stdlib${ii}$_cgemqrt + public :: stdlib${ii}$_cgeql2 + public :: stdlib${ii}$_cgeqlf + public :: stdlib${ii}$_cgeqp3 + public :: stdlib${ii}$_cgeqr + public :: stdlib${ii}$_cgeqr2 + public :: stdlib${ii}$_cgeqr2p + public :: stdlib${ii}$_cgeqrf + public :: stdlib${ii}$_cgeqrfp + public :: stdlib${ii}$_cgeqrt + public :: stdlib${ii}$_cgeqrt2 + public :: stdlib${ii}$_cgeqrt3 + public :: stdlib${ii}$_cgerfs + public :: stdlib${ii}$_cgerq2 + public :: stdlib${ii}$_cgerqf + public :: stdlib${ii}$_cgesc2 + public :: stdlib${ii}$_cgesdd + public :: stdlib${ii}$_cgesv + public :: stdlib${ii}$_cgesvd + public :: stdlib${ii}$_cgesvdq + public :: stdlib${ii}$_cgesvj + public :: stdlib${ii}$_cgesvx + public :: stdlib${ii}$_cgetc2 + public :: stdlib${ii}$_cgetf2 + public :: stdlib${ii}$_cgetrf + public :: stdlib${ii}$_cgetrf2 + public :: stdlib${ii}$_cgetri + public :: stdlib${ii}$_cgetrs + public :: stdlib${ii}$_cgetsls + public :: stdlib${ii}$_cgetsqrhrt + public :: stdlib${ii}$_cggbak + public :: stdlib${ii}$_cggbal + public :: stdlib${ii}$_cgges + public :: stdlib${ii}$_cgges3 + public :: stdlib${ii}$_cggesx + public :: stdlib${ii}$_cggev + public :: stdlib${ii}$_cggev3 + public :: stdlib${ii}$_cggevx + public :: stdlib${ii}$_cggglm + public :: stdlib${ii}$_cgghd3 + public :: stdlib${ii}$_cgghrd + public :: stdlib${ii}$_cgglse + public :: stdlib${ii}$_cggqrf + public :: stdlib${ii}$_cggrqf + public :: stdlib${ii}$_cgsvj0 + public :: stdlib${ii}$_cgsvj1 + public :: stdlib${ii}$_cgtcon + public :: stdlib${ii}$_cgtrfs + public :: stdlib${ii}$_cgtsv + public :: stdlib${ii}$_cgtsvx + public :: stdlib${ii}$_cgttrf + public :: stdlib${ii}$_cgttrs + public :: stdlib${ii}$_cgtts2 + public :: stdlib${ii}$_chb2st_kernels + public :: stdlib${ii}$_chbev + public :: stdlib${ii}$_chbevd + public :: stdlib${ii}$_chbevx + public :: stdlib${ii}$_chbgst + public :: stdlib${ii}$_chbgv + public :: stdlib${ii}$_chbgvd + public :: stdlib${ii}$_chbgvx + public :: stdlib${ii}$_chbtrd + public :: stdlib${ii}$_checon + public :: stdlib${ii}$_checon_rook + public :: stdlib${ii}$_cheequb + public :: stdlib${ii}$_cheev + public :: stdlib${ii}$_cheevd + public :: stdlib${ii}$_cheevr + public :: stdlib${ii}$_cheevx + public :: stdlib${ii}$_chegs2 + public :: stdlib${ii}$_chegst + public :: stdlib${ii}$_chegv + public :: stdlib${ii}$_chegvd + public :: stdlib${ii}$_chegvx + public :: stdlib${ii}$_cherfs + public :: stdlib${ii}$_chesv + public :: stdlib${ii}$_chesv_aa + public :: stdlib${ii}$_chesv_rk + public :: stdlib${ii}$_chesv_rook + public :: stdlib${ii}$_chesvx + public :: stdlib${ii}$_cheswapr + public :: stdlib${ii}$_chetd2 + public :: stdlib${ii}$_chetf2 + public :: stdlib${ii}$_chetf2_rk + public :: stdlib${ii}$_chetf2_rook + public :: stdlib${ii}$_chetrd + public :: stdlib${ii}$_chetrd_hb2st + public :: stdlib${ii}$_chetrd_he2hb + public :: stdlib${ii}$_chetrf + public :: stdlib${ii}$_chetrf_aa + public :: stdlib${ii}$_chetrf_rk + public :: stdlib${ii}$_chetrf_rook + public :: stdlib${ii}$_chetri + public :: stdlib${ii}$_chetri_rook + public :: stdlib${ii}$_chetrs + public :: stdlib${ii}$_chetrs2 + public :: stdlib${ii}$_chetrs_3 + public :: stdlib${ii}$_chetrs_aa + public :: stdlib${ii}$_chetrs_rook + public :: stdlib${ii}$_chfrk + public :: stdlib${ii}$_chgeqz + public :: stdlib${ii}$_chpcon + public :: stdlib${ii}$_chpev + public :: stdlib${ii}$_chpevd + public :: stdlib${ii}$_chpevx + public :: stdlib${ii}$_chpgst + public :: stdlib${ii}$_chpgv + public :: stdlib${ii}$_chpgvd + public :: stdlib${ii}$_chpgvx + public :: stdlib${ii}$_chprfs + public :: stdlib${ii}$_chpsv + public :: stdlib${ii}$_chpsvx + public :: stdlib${ii}$_chptrd + public :: stdlib${ii}$_chptrf + public :: stdlib${ii}$_chptri + public :: stdlib${ii}$_chptrs + public :: stdlib${ii}$_chsein + public :: stdlib${ii}$_chseqr + public :: stdlib${ii}$_cla_gbamv + public :: stdlib${ii}$_cla_gbrcond_c + public :: stdlib${ii}$_cla_gbrpvgrw + public :: stdlib${ii}$_cla_geamv + public :: stdlib${ii}$_cla_gercond_c + public :: stdlib${ii}$_cla_gerpvgrw + public :: stdlib${ii}$_cla_heamv + public :: stdlib${ii}$_cla_hercond_c + public :: stdlib${ii}$_cla_herpvgrw + public :: stdlib${ii}$_cla_lin_berr + public :: stdlib${ii}$_cla_porcond_c + public :: stdlib${ii}$_cla_porpvgrw + public :: stdlib${ii}$_cla_syamv + public :: stdlib${ii}$_cla_syrcond_c + public :: stdlib${ii}$_cla_syrpvgrw + public :: stdlib${ii}$_cla_wwaddw + public :: stdlib${ii}$_clabrd + public :: stdlib${ii}$_clacgv + public :: stdlib${ii}$_clacn2 + public :: stdlib${ii}$_clacon + public :: stdlib${ii}$_clacp2 + public :: stdlib${ii}$_clacpy + public :: stdlib${ii}$_clacrm + public :: stdlib${ii}$_clacrt + public :: stdlib${ii}$_cladiv + public :: stdlib${ii}$_claed0 + public :: stdlib${ii}$_claed7 + public :: stdlib${ii}$_claed8 + public :: stdlib${ii}$_claein + public :: stdlib${ii}$_claesy + public :: stdlib${ii}$_claev2 + public :: stdlib${ii}$_clag2z + public :: stdlib${ii}$_clags2 + public :: stdlib${ii}$_clagtm + public :: stdlib${ii}$_clahef + public :: stdlib${ii}$_clahef_aa + public :: stdlib${ii}$_clahef_rk + public :: stdlib${ii}$_clahef_rook + public :: stdlib${ii}$_clahqr + public :: stdlib${ii}$_clahr2 + public :: stdlib${ii}$_claic1 + public :: stdlib${ii}$_clals0 + public :: stdlib${ii}$_clalsa + public :: stdlib${ii}$_clalsd + public :: stdlib${ii}$_clamswlq + public :: stdlib${ii}$_clamtsqr + public :: stdlib${ii}$_clangb + public :: stdlib${ii}$_clange + public :: stdlib${ii}$_clangt + public :: stdlib${ii}$_clanhb + public :: stdlib${ii}$_clanhe + public :: stdlib${ii}$_clanhf + public :: stdlib${ii}$_clanhp + public :: stdlib${ii}$_clanhs + public :: stdlib${ii}$_clanht + public :: stdlib${ii}$_clansb + public :: stdlib${ii}$_clansp + public :: stdlib${ii}$_clansy + public :: stdlib${ii}$_clantb + public :: stdlib${ii}$_clantp + public :: stdlib${ii}$_clantr + public :: stdlib${ii}$_clapll + public :: stdlib${ii}$_clapmr + public :: stdlib${ii}$_clapmt + public :: stdlib${ii}$_claqgb + public :: stdlib${ii}$_claqge + public :: stdlib${ii}$_claqhb + public :: stdlib${ii}$_claqhe + public :: stdlib${ii}$_claqhp + public :: stdlib${ii}$_claqp2 + public :: stdlib${ii}$_claqps + public :: stdlib${ii}$_claqr0 + public :: stdlib${ii}$_claqr1 + public :: stdlib${ii}$_claqr2 + public :: stdlib${ii}$_claqr3 + public :: stdlib${ii}$_claqr4 + public :: stdlib${ii}$_claqr5 + public :: stdlib${ii}$_claqsb + public :: stdlib${ii}$_claqsp + public :: stdlib${ii}$_claqsy + public :: stdlib${ii}$_claqz0 + public :: stdlib${ii}$_claqz1 + public :: stdlib${ii}$_claqz2 + public :: stdlib${ii}$_claqz3 + public :: stdlib${ii}$_clar1v + public :: stdlib${ii}$_clar2v + public :: stdlib${ii}$_clarcm + public :: stdlib${ii}$_clarf + public :: stdlib${ii}$_clarfb + public :: stdlib${ii}$_clarfb_gett + public :: stdlib${ii}$_clarfg + public :: stdlib${ii}$_clarfgp + public :: stdlib${ii}$_clarft + public :: stdlib${ii}$_clarfx + public :: stdlib${ii}$_clarfy + public :: stdlib${ii}$_clargv + public :: stdlib${ii}$_clarnv + public :: stdlib${ii}$_clarrv + public :: stdlib${ii}$_clartg + public :: stdlib${ii}$_clartv + public :: stdlib${ii}$_clarz + public :: stdlib${ii}$_clarzb + public :: stdlib${ii}$_clarzt + public :: stdlib${ii}$_clascl + public :: stdlib${ii}$_claset + public :: stdlib${ii}$_clasr + public :: stdlib${ii}$_classq + public :: stdlib${ii}$_claswlq + public :: stdlib${ii}$_claswp + public :: stdlib${ii}$_clasyf + public :: stdlib${ii}$_clasyf_aa + public :: stdlib${ii}$_clasyf_rk + public :: stdlib${ii}$_clasyf_rook + public :: stdlib${ii}$_clatbs + public :: stdlib${ii}$_clatdf + public :: stdlib${ii}$_clatps + public :: stdlib${ii}$_clatrd + public :: stdlib${ii}$_clatrs + public :: stdlib${ii}$_clatrz + public :: stdlib${ii}$_clatsqr + public :: stdlib${ii}$_claunhr_col_getrfnp + public :: stdlib${ii}$_claunhr_col_getrfnp2 + public :: stdlib${ii}$_clauu2 + public :: stdlib${ii}$_clauum + public :: stdlib${ii}$_cpbcon + public :: stdlib${ii}$_cpbequ + public :: stdlib${ii}$_cpbrfs + public :: stdlib${ii}$_cpbstf + public :: stdlib${ii}$_cpbsv + public :: stdlib${ii}$_cpbsvx + public :: stdlib${ii}$_cpbtf2 + public :: stdlib${ii}$_cpbtrf + public :: stdlib${ii}$_cpbtrs + public :: stdlib${ii}$_cpftrf + public :: stdlib${ii}$_cpftri + public :: stdlib${ii}$_cpftrs + public :: stdlib${ii}$_cpocon + public :: stdlib${ii}$_cpoequ + public :: stdlib${ii}$_cpoequb + public :: stdlib${ii}$_cporfs + public :: stdlib${ii}$_cposv + public :: stdlib${ii}$_cposvx + public :: stdlib${ii}$_cpotf2 + public :: stdlib${ii}$_cpotrf + public :: stdlib${ii}$_cpotrf2 + public :: stdlib${ii}$_cpotri + public :: stdlib${ii}$_cpotrs + public :: stdlib${ii}$_cppcon + public :: stdlib${ii}$_cppequ + public :: stdlib${ii}$_cpprfs + public :: stdlib${ii}$_cppsv + public :: stdlib${ii}$_cppsvx + public :: stdlib${ii}$_cpptrf + public :: stdlib${ii}$_cpptri + public :: stdlib${ii}$_cpptrs + public :: stdlib${ii}$_cpstf2 + public :: stdlib${ii}$_cpstrf + public :: stdlib${ii}$_cptcon + public :: stdlib${ii}$_cpteqr + public :: stdlib${ii}$_cptrfs + public :: stdlib${ii}$_cptsv + public :: stdlib${ii}$_cptsvx + public :: stdlib${ii}$_cpttrf + public :: stdlib${ii}$_cpttrs + public :: stdlib${ii}$_cptts2 + public :: stdlib${ii}$_crot + public :: stdlib${ii}$_cspcon + public :: stdlib${ii}$_cspmv + public :: stdlib${ii}$_cspr + public :: stdlib${ii}$_csprfs + public :: stdlib${ii}$_cspsv + public :: stdlib${ii}$_cspsvx + public :: stdlib${ii}$_csptrf + public :: stdlib${ii}$_csptri + public :: stdlib${ii}$_csptrs + public :: stdlib${ii}$_csrscl + public :: stdlib${ii}$_cstedc + public :: stdlib${ii}$_cstegr + public :: stdlib${ii}$_cstein + public :: stdlib${ii}$_cstemr + public :: stdlib${ii}$_csteqr + public :: stdlib${ii}$_csycon + public :: stdlib${ii}$_csycon_rook + public :: stdlib${ii}$_csyconv + public :: stdlib${ii}$_csyconvf + public :: stdlib${ii}$_csyconvf_rook + public :: stdlib${ii}$_csyequb + public :: stdlib${ii}$_csymv + public :: stdlib${ii}$_csyr + public :: stdlib${ii}$_csyrfs + public :: stdlib${ii}$_csysv + public :: stdlib${ii}$_csysv_aa + public :: stdlib${ii}$_csysv_rk + public :: stdlib${ii}$_csysv_rook + public :: stdlib${ii}$_csysvx + public :: stdlib${ii}$_csyswapr + public :: stdlib${ii}$_csytf2 + public :: stdlib${ii}$_csytf2_rk + public :: stdlib${ii}$_csytf2_rook + public :: stdlib${ii}$_csytrf + public :: stdlib${ii}$_csytrf_aa + public :: stdlib${ii}$_csytrf_rk + public :: stdlib${ii}$_csytrf_rook + public :: stdlib${ii}$_csytri + public :: stdlib${ii}$_csytri_rook + public :: stdlib${ii}$_csytrs + public :: stdlib${ii}$_csytrs2 + public :: stdlib${ii}$_csytrs_3 + public :: stdlib${ii}$_csytrs_aa + public :: stdlib${ii}$_csytrs_rook + public :: stdlib${ii}$_ctbcon + public :: stdlib${ii}$_ctbrfs + public :: stdlib${ii}$_ctbtrs + public :: stdlib${ii}$_ctfsm + public :: stdlib${ii}$_ctftri + public :: stdlib${ii}$_ctfttp + public :: stdlib${ii}$_ctfttr + public :: stdlib${ii}$_ctgevc + public :: stdlib${ii}$_ctgex2 + public :: stdlib${ii}$_ctgexc + public :: stdlib${ii}$_ctgsen + public :: stdlib${ii}$_ctgsja + public :: stdlib${ii}$_ctgsna + public :: stdlib${ii}$_ctgsy2 + public :: stdlib${ii}$_ctgsyl + public :: stdlib${ii}$_ctpcon + public :: stdlib${ii}$_ctplqt + public :: stdlib${ii}$_ctplqt2 + public :: stdlib${ii}$_ctpmlqt + public :: stdlib${ii}$_ctpmqrt + public :: stdlib${ii}$_ctpqrt + public :: stdlib${ii}$_ctpqrt2 + public :: stdlib${ii}$_ctprfb + public :: stdlib${ii}$_ctprfs + public :: stdlib${ii}$_ctptri + public :: stdlib${ii}$_ctptrs + public :: stdlib${ii}$_ctpttf + public :: stdlib${ii}$_ctpttr + public :: stdlib${ii}$_ctrcon + public :: stdlib${ii}$_ctrevc + public :: stdlib${ii}$_ctrevc3 + public :: stdlib${ii}$_ctrexc + public :: stdlib${ii}$_ctrrfs + public :: stdlib${ii}$_ctrsen + public :: stdlib${ii}$_ctrsna + public :: stdlib${ii}$_ctrsyl + public :: stdlib${ii}$_ctrti2 + public :: stdlib${ii}$_ctrtri + public :: stdlib${ii}$_ctrtrs + public :: stdlib${ii}$_ctrttf + public :: stdlib${ii}$_ctrttp + public :: stdlib${ii}$_ctzrzf + public :: stdlib${ii}$_cunbdb + public :: stdlib${ii}$_cunbdb1 + public :: stdlib${ii}$_cunbdb2 + public :: stdlib${ii}$_cunbdb3 + public :: stdlib${ii}$_cunbdb4 + public :: stdlib${ii}$_cunbdb5 + public :: stdlib${ii}$_cunbdb6 + public :: stdlib${ii}$_cuncsd + public :: stdlib${ii}$_cuncsd2by1 + public :: stdlib${ii}$_cung2l + public :: stdlib${ii}$_cung2r + public :: stdlib${ii}$_cungbr + public :: stdlib${ii}$_cunghr + public :: stdlib${ii}$_cungl2 + public :: stdlib${ii}$_cunglq + public :: stdlib${ii}$_cungql + public :: stdlib${ii}$_cungqr + public :: stdlib${ii}$_cungr2 + public :: stdlib${ii}$_cungrq + public :: stdlib${ii}$_cungtr + public :: stdlib${ii}$_cungtsqr + public :: stdlib${ii}$_cungtsqr_row + public :: stdlib${ii}$_cunhr_col + public :: stdlib${ii}$_cunm22 + public :: stdlib${ii}$_cunm2l + public :: stdlib${ii}$_cunm2r + public :: stdlib${ii}$_cunmbr + public :: stdlib${ii}$_cunmhr + public :: stdlib${ii}$_cunml2 + public :: stdlib${ii}$_cunmlq + public :: stdlib${ii}$_cunmql + public :: stdlib${ii}$_cunmqr + public :: stdlib${ii}$_cunmr2 + public :: stdlib${ii}$_cunmr3 + public :: stdlib${ii}$_cunmrq + public :: stdlib${ii}$_cunmrz + public :: stdlib${ii}$_cunmtr + public :: stdlib${ii}$_cupgtr + public :: stdlib${ii}$_cupmtr + #:endfor ! 32-bit real constants real(sp), parameter, private :: negone = -1.00_sp @@ -480,7 +482,7 @@ module stdlib_linalg_lapack_c 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 @@ -490,15 +492,15 @@ module stdlib_linalg_lapack_c ! 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 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 subroutine stdlib_cgbequ( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info ) + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + pure subroutine stdlib${ii}$_cgbequ( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info ) !! CGBEQU computes row and column scalings intended to equilibrate an !! M-by-N band matrix A and reduce its condition number. R returns the !! row scale factors and C the column scale factors, chosen to try to @@ -513,8 +515,8 @@ module stdlib_linalg_lapack_c ! -- 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 real(sp), intent(out) :: amax, colcnd, rowcnd ! Array Arguments real(sp), intent(out) :: c(*), r(*) @@ -522,7 +524,7 @@ module stdlib_linalg_lapack_c ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, kd + integer(${ik}$) :: i, j, kd real(sp) :: bignum, rcmax, rcmin, smlnum complex(sp) :: zdum ! Intrinsic Functions @@ -533,38 +535,38 @@ module stdlib_linalg_lapack_c cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) ) ! Executable Statements ! 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( ldabzero ) 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. @@ -753,7 +755,7 @@ module stdlib_linalg_lapack_c c( j ) = max( c( j ), cabs1( 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. @@ -780,10 +782,10 @@ module stdlib_linalg_lapack_c colcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) end if return - end subroutine stdlib_cgbequb + end subroutine stdlib${ii}$_cgbequb - pure subroutine stdlib_cgbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) + pure subroutine stdlib${ii}$_cgbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) !! CGBTF2 computes an LU factorization of a complex m-by-n band matrix !! A using partial pivoting with row interchanges. !! This is the unblocked version of the algorithm, calling Level 2 BLAS. @@ -791,15 +793,15 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(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 @@ -807,20 +809,20 @@ module stdlib_linalg_lapack_c ! 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}$_cswap( 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_cscal( km, cone / ab( kv+1, j ), ab( kv+2, j ), 1 ) + call stdlib${ii}$_cscal( km, cone / ab( kv+1, j ), ab( kv+2, j ), 1_${ik}$ ) ! update trailing submatrix within the band. - if( ju>j )call stdlib_cgeru( km, ju-j, -cone, ab( kv+2, j ), 1,ab( kv, j+1 ), & + if( ju>j )call stdlib${ii}$_cgeru( km, ju-j, -cone, 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 czero, set info to the index of the pivot ! unless a czero 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_cgbtf2 + end subroutine stdlib${ii}$_cgbtf2 - pure subroutine stdlib_cgebak( job, side, n, ilo, ihi, scale, m, v, ldv,info ) + pure subroutine stdlib${ii}$_cgebak( job, side, n, ilo, ihi, scale, m, v, ldv,info ) !! CGEBAK forms the right or left eigenvectors of a complex general !! matrix by backward transformation on the computed eigenvectors of the !! balanced matrix output by CGEBAL. @@ -878,8 +880,8 @@ module stdlib_linalg_lapack_c ! -- 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(in) :: scale(*) complex(sp), intent(inout) :: v(ldv,*) @@ -887,7 +889,7 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: leftv, rightv - integer(ilp) :: i, ii, k + integer(${ik}$) :: i, ii, k real(sp) :: s ! Intrinsic Functions intrinsic :: max,min @@ -895,25 +897,25 @@ module stdlib_linalg_lapack_c ! 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( ldv=g .or. max( f, c, ca )>=sfmax2 .or.min( r, g, ra )<=sfmin2 )go to 170 - if( stdlib_sisnan( c+f+ca+r+g+ra ) ) then + if( stdlib${ii}$_sisnan( c+f+ca+r+g+ra ) ) then ! exit if nan to avoid infinite loop - info = -3 - call stdlib_xerbla( 'CGEBAL', -info ) + info = -3_${ik}$ + call stdlib${ii}$_xerbla( 'CGEBAL', -info ) return end if f = f*sclfac @@ -1125,18 +1127,18 @@ module stdlib_linalg_lapack_c g = one / f scale( i ) = scale( i )*f noconv = .true. - call stdlib_csscal( n-k+1, g, a( i, k ), lda ) - call stdlib_csscal( l, f, a( 1, i ), 1 ) + call stdlib${ii}$_csscal( n-k+1, g, a( i, k ), lda ) + call stdlib${ii}$_csscal( l, f, a( 1_${ik}$, i ), 1_${ik}$ ) end do loop_200 if( noconv )go to 140 210 continue ilo = k ihi = l return - end subroutine stdlib_cgebal + end subroutine stdlib${ii}$_cgebal - pure subroutine stdlib_cgeequ( m, n, a, lda, r, c, rowcnd, colcnd, amax,info ) + pure subroutine stdlib${ii}$_cgeequ( m, n, a, lda, r, c, rowcnd, colcnd, amax,info ) !! CGEEQU computes row and column scalings intended to equilibrate an !! M-by-N matrix A and reduce its condition number. R returns the row !! scale factors and C the column scale factors, chosen to try to make @@ -1150,8 +1152,8 @@ module stdlib_linalg_lapack_c ! -- 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 real(sp), intent(out) :: amax, colcnd, rowcnd ! Array Arguments real(sp), intent(out) :: c(*), r(*) @@ -1159,7 +1161,7 @@ module stdlib_linalg_lapack_c ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(sp) :: bignum, rcmax, rcmin, smlnum complex(sp) :: zdum ! Intrinsic Functions @@ -1170,27 +1172,27 @@ module stdlib_linalg_lapack_c cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. - info = 0 - if( m<0 ) 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. @@ -1378,7 +1380,7 @@ module stdlib_linalg_lapack_c c( j ) = max( c( j ), cabs1( 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. @@ -1405,10 +1407,10 @@ module stdlib_linalg_lapack_c colcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) end if return - end subroutine stdlib_cgeequb + end subroutine stdlib${ii}$_cgeequb - pure subroutine stdlib_cgetc2( n, a, lda, ipiv, jpiv, info ) + pure subroutine stdlib${ii}$_cgetc2( n, a, lda, ipiv, jpiv, info ) !! CGETC2 computes an LU factorization, using 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 @@ -1418,34 +1420,34 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(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,cmplx,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 ) + call stdlib${ii}$_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 ) )= sfmin ) then - call stdlib_cscal( m-j, cone / a( j, j ), a( j+1, j ), 1 ) + call stdlib${ii}$_cscal( m-j, cone / 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( j0 .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( ldv1 )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 k = n - 2, 1, -1 b( k, j ) = ( b( k, j )-du( k )*b( k+1, j )-dl( k )*b( k+2, j ) ) / d( k ) end do end do return - end subroutine stdlib_cgtsv + end subroutine stdlib${ii}$_cgtsv - pure subroutine stdlib_cgttrf( n, dl, d, du, du2, ipiv, info ) + pure subroutine stdlib${ii}$_cgttrf( n, dl, d, du, du2, ipiv, info ) !! CGTTRF computes an LU factorization of a complex tridiagonal matrix A !! using elimination with partial pivoting and row interchanges. !! The factorization has the form @@ -2086,16 +2088,16 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(inout) :: d(*), dl(*), du(*) complex(sp), intent(out) :: du2(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i complex(sp) :: fact, temp, zdum ! Intrinsic Functions intrinsic :: abs,aimag,real @@ -2104,10 +2106,10 @@ module stdlib_linalg_lapack_c ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) ) ! Executable Statements - info = 0 - if( n<0 ) then - info = -1 - call stdlib_xerbla( 'CGTTRF', -info ) + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -1_${ik}$ + call stdlib${ii}$_xerbla( 'CGTTRF', -info ) return end if ! quick return if possible @@ -2137,11 +2139,11 @@ module stdlib_linalg_lapack_c 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( cabs1( d( i ) )>=cabs1( dl( i ) ) ) then if( cabs1( d( i ) )/=zero ) then fact = dl( i ) / d( i ) @@ -2155,7 +2157,7 @@ module stdlib_linalg_lapack_c 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. @@ -2167,10 +2169,10 @@ module stdlib_linalg_lapack_c end do 50 continue return - end subroutine stdlib_cgttrf + end subroutine stdlib${ii}$_cgttrf - pure subroutine stdlib_cgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) + pure subroutine stdlib${ii}$_cgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) !! CGTTS2 solves one of the systems of equations !! A * X = B, A**T * X = B, or A**H * X = B, !! with a tridiagonal matrix A using the LU factorization computed @@ -2179,25 +2181,25 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(inout) :: b(ldb,*) complex(sp), intent(in) :: d(*), dl(*), du(*), du2(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j complex(sp) :: temp ! Intrinsic Functions intrinsic :: conjg ! 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 @@ -2211,13 +2213,13 @@ module stdlib_linalg_lapack_c 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 ) end do end do end if - else if( itrans==1 ) then + else if( itrans==1_${ik}$ ) then ! solve a**t * x = b. - if( nrhs<=1 ) then - j = 1 + if( nrhs<=1_${ik}$ ) then + j = 1_${ik}$ 70 continue ! solve u**t * x = b. - 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 & ) @@ -2264,14 +2266,14 @@ module stdlib_linalg_lapack_c end if 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 ) @@ -2290,12 +2292,12 @@ module stdlib_linalg_lapack_c end if else ! solve a**h * x = b. - if( nrhs<=1 ) then - j = 1 + if( nrhs<=1_${ik}$ ) then + j = 1_${ik}$ 130 continue ! solve u**h * x = b. - b( 1, j ) = b( 1, j ) / conjg( d( 1 ) ) - if( n>1 )b( 2, j ) = ( b( 2, j )-conjg( du( 1 ) )*b( 1, j ) ) /conjg( d( 2 ) ) + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / conjg( d( 1_${ik}$ ) ) + if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-conjg( du( 1_${ik}$ ) )*b( 1_${ik}$, j ) ) /conjg( d( 2_${ik}$ ) ) do i = 3, n b( i, j ) = ( b( i, j )-conjg( du( i-1 ) )*b( i-1, j )-conjg( du2( i-2 ) )*b( & @@ -2312,14 +2314,14 @@ module stdlib_linalg_lapack_c end if end do if( j1 )b( 2, j ) = ( b( 2, j )-conjg( du( 1 ) )*b( 1, j ) ) /conjg( d( 2 ) ) + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / conjg( d( 1_${ik}$ ) ) + if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-conjg( du( 1_${ik}$ ) )*b( 1_${ik}$, j ) ) /conjg( d( 2_${ik}$ ) ) do i = 3, n b( i, j ) = ( b( i, j )-conjg( du( i-1 ) )*b( i-1, j )-conjg( du2( i-2 ) )& @@ -2338,10 +2340,10 @@ module stdlib_linalg_lapack_c end do end if end if - end subroutine stdlib_cgtts2 + end subroutine stdlib${ii}$_cgtts2 - pure subroutine stdlib_cheswapr( uplo, n, a, lda, i1, i2) + pure subroutine stdlib${ii}$_cheswapr( uplo, n, a, lda, i1, i2) !! CHESWAPR applies an elementary permutation on the rows and the columns of !! a hermitian matrix. ! -- lapack auxiliary routine -- @@ -2349,13 +2351,13 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: a(lda,n) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: i + integer(${ik}$) :: i complex(sp) :: tmp ! Executable Statements upper = stdlib_lsame( uplo, 'U' ) @@ -2363,7 +2365,7 @@ module stdlib_linalg_lapack_c ! upper ! first swap ! - swap column i1 and i2 from i1 to i1-1 - call stdlib_cswap( i1-1, a(1,i1), 1, a(1,i2), 1 ) + call stdlib${ii}$_cswap( 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 @@ -2388,7 +2390,7 @@ module stdlib_linalg_lapack_c ! lower ! first swap ! - swap row i1 and i2 from 1 to i1-1 - call stdlib_cswap ( i1-1, a(i1,1), lda, a(i2,1), lda ) + call stdlib${ii}$_cswap ( 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 @@ -2410,10 +2412,10 @@ module stdlib_linalg_lapack_c a(i,i2)=tmp end do endif - end subroutine stdlib_cheswapr + end subroutine stdlib${ii}$_cheswapr - pure subroutine stdlib_chetf2( uplo, n, a, lda, ipiv, info ) + pure subroutine stdlib${ii}$_chetf2( uplo, n, a, lda, ipiv, info ) !! CHETF2 computes the factorization of a complex Hermitian matrix A !! using the Bunch-Kaufman diagonal pivoting method: !! A = U*D*U**H or A = L*D*L**H @@ -2426,10 +2428,10 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(inout) :: a(lda,*) ! ===================================================================== ! Parameters @@ -2438,7 +2440,7 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: upper - integer(ilp) :: i, imax, j, jmax, k, kk, kp, kstep + integer(${ik}$) :: i, imax, j, jmax, k, kk, kp, kstep real(sp) :: absakk, alpha, colmax, d, d11, d22, r1, rowmax, tt complex(sp) :: d12, d21, t, wk, wkm1, wkp1, zdum ! Intrinsic Functions @@ -2449,17 +2451,17 @@ module stdlib_linalg_lapack_c cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) ) ! 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_icamax( k-1, a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_icamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ ) colmax = cabs1( a( imax, k ) ) else colmax = zero end if - if( (max( absakk, colmax )==zero) .or. stdlib_sisnan(absakk) ) then + if( (max( absakk, colmax )==zero) .or. stdlib${ii}$_sisnan(absakk) ) then ! column k is or underflow, or contains a nan: ! set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k a( k, k ) = real( a( k, k ),KIND=sp) else @@ -2498,10 +2500,10 @@ module stdlib_linalg_lapack_c else ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value - jmax = imax + stdlib_icamax( k-imax, a( imax, imax+1 ), lda ) + jmax = imax + stdlib${ii}$_icamax( k-imax, a( imax, imax+1 ), lda ) rowmax = cabs1( a( imax, jmax ) ) - if( imax>1 ) then - jmax = stdlib_icamax( imax-1, a( 1, imax ), 1 ) + if( imax>1_${ik}$ ) then + jmax = stdlib${ii}$_icamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ ) rowmax = max( rowmax, cabs1( a( jmax, imax ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then @@ -2515,14 +2517,14 @@ module stdlib_linalg_lapack_c ! interchange rows and columns k-1 and imax, use 2-by-2 ! pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ end if end if - 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) - call stdlib_cswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_cswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) do j = kp + 1, kk - 1 t = conjg( a( j, kk ) ) a( j, kk ) = conjg( a( kp, j ) ) @@ -2532,7 +2534,7 @@ module stdlib_linalg_lapack_c r1 = real( a( kk, kk ),KIND=sp) a( kk, kk ) = real( a( kp, kp ),KIND=sp) a( kp, kp ) = r1 - if( kstep==2 ) then + if( kstep==2_${ik}$ ) then a( k, k ) = real( a( k, k ),KIND=sp) t = a( k-1, k ) a( k-1, k ) = a( kp, k ) @@ -2540,19 +2542,19 @@ module stdlib_linalg_lapack_c end if else a( k, k ) = real( a( k, k ),KIND=sp) - if( kstep==2 )a( k-1, k-1 ) = real( a( k-1, k-1 ),KIND=sp) + if( kstep==2_${ik}$ )a( k-1, k-1 ) = real( a( k-1, k-1 ),KIND=sp) end if ! update the leading submatrix - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u ! perform a rank-1 update of a(1:k-1,1:k-1) as ! a := a - u(k)*d(k)*u(k)**h = a - w(k)*1/d(k)*w(k)**h r1 = one / real( a( k, k ),KIND=sp) - call stdlib_cher( uplo, k-1, -r1, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_cher( uplo, k-1, -r1, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) ! store u(k) in column k - call stdlib_csscal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_csscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) else ! 2-by-2 pivot block d(k): columns k and k-1 now hold ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k) @@ -2561,8 +2563,8 @@ module stdlib_linalg_lapack_c ! perform a rank-2 update of a(1:k-2,1:k-2) as ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**h ! = a - ( w(k-1) w(k) )*inv(d(k))*( w(k-1) w(k) )**h - if( k>2 ) then - d = stdlib_slapy2( real( a( k-1, k ),KIND=sp),aimag( a( k-1, k ) ) ) + if( k>2_${ik}$ ) then + d = stdlib${ii}$_slapy2( real( a( k-1, k ),KIND=sp),aimag( a( k-1, k ) ) ) d22 = real( a( k-1, k-1 ),KIND=sp) / d d11 = real( a( k, k ),KIND=sp) / d @@ -2584,7 +2586,7 @@ module stdlib_linalg_lapack_c 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 @@ -2597,11 +2599,11 @@ module stdlib_linalg_lapack_c ! factorize a as l*d*l**h using the lower triangle of a ! k is the main loop index, increasing from 1 to n in steps of ! 1 or 2 - k = 1 + k = 1_${ik}$ 50 continue ! if k > n, exit from loop if( k>n )go to 90 - 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 absakk = abs( real( a( k, k ),KIND=sp) ) @@ -2609,15 +2611,15 @@ module stdlib_linalg_lapack_c ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k=alpha*colmax*( colmax / rowmax ) ) then @@ -2644,14 +2646,14 @@ module stdlib_linalg_lapack_c ! interchange rows and columns k+1 and imax, use 2-by-2 ! pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ end if end if - 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( kp1 ) then - imax = stdlib_icamax( k-1, a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_icamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ ) colmax = cabs1( a( imax, k ) ) else colmax = zero end if if( ( max( absakk, colmax )==zero ) ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k a( k, k ) = real( a( k, k ),KIND=sp) ! set e( k ) to zero - if( k>1 )e( k ) = czero + if( k>1_${ik}$ )e( k ) = czero else ! ============================================================ ! begin pivot search @@ -2838,13 +2840,13 @@ module stdlib_linalg_lapack_c ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = imax + stdlib_icamax( k-imax, a( imax, imax+1 ),lda ) + jmax = imax + stdlib${ii}$_icamax( k-imax, a( imax, imax+1 ),lda ) rowmax = cabs1( a( imax, jmax ) ) else rowmax = zero end if - if( imax>1 ) then - itemp = stdlib_icamax( imax-1, a( 1, imax ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_icamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ ) stemp = cabs1( a( itemp, imax ) ) if( stemp>rowmax ) then rowmax = stemp @@ -2868,7 +2870,7 @@ module stdlib_linalg_lapack_c ! interchange rows and columns k-1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. ! case(4) else @@ -2883,12 +2885,12 @@ module stdlib_linalg_lapack_c ! end pivot search ! ============================================================ ! kk is the column of a where pivoting step stopped - kk = k - kstep + 1 + kk = k - kstep + 1_${ik}$ ! for only a 2x2 pivot, interchange rows and columns k and p ! in the leading submatrix a(1:k,1:k) - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! (1) swap columnar parts - if( p>1 )call stdlib_cswap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) + if( p>1_${ik}$ )call stdlib${ii}$_cswap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) ! (2) swap and conjugate middle parts do j = p + 1, k - 1 t = conjg( a( j, k ) ) @@ -2903,13 +2905,13 @@ module stdlib_linalg_lapack_c a( p, p ) = r1 ! convert upper triangle of a into u form by applying ! the interchanges in columns k+1:n. - if( k1 )call stdlib_cswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + if( kp>1_${ik}$ )call stdlib${ii}$_cswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) ! (2) swap and conjugate middle parts do j = kp + 1, kk - 1 t = conjg( a( j, kk ) ) @@ -2922,7 +2924,7 @@ module stdlib_linalg_lapack_c r1 = real( a( kk, kk ),KIND=sp) a( kk, kk ) = real( a( kp, kp ),KIND=sp) a( kp, kp ) = r1 - if( kstep==2 ) then + if( kstep==2_${ik}$ ) then ! (*) make sure that diagonal element of pivot is real a( k, k ) = real( a( k, k ),KIND=sp) ! (5) swap row elements @@ -2932,18 +2934,18 @@ module stdlib_linalg_lapack_c end if ! convert upper triangle of a into u form by applying ! the interchanges in columns k+1:n. - if( k1 ) then + if( k>1_${ik}$ ) then ! perform a rank-1 update of a(1:k-1,1:k-1) and ! store u(k) in column k if( abs( real( a( k, k ),KIND=sp) )>=sfmin ) then @@ -2951,9 +2953,9 @@ module stdlib_linalg_lapack_c ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*1/d(k)*w(k)**t d11 = one / real( a( k, k ),KIND=sp) - call stdlib_cher( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_cher( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) ! store u(k) in column k - call stdlib_csscal( k-1, d11, a( 1, k ), 1 ) + call stdlib${ii}$_csscal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = real( a( k, k ),KIND=sp) @@ -2964,7 +2966,7 @@ module stdlib_linalg_lapack_c ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_cher( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_cher( 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 ) = czero @@ -2978,9 +2980,9 @@ module stdlib_linalg_lapack_c ! 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 ! d = |a12| - d = stdlib_slapy2( real( a( k-1, k ),KIND=sp),aimag( a( k-1, k ) ) ) + d = stdlib${ii}$_slapy2( real( a( k-1, k ),KIND=sp),aimag( a( k-1, k ) ) ) d11 = real( a( k, k ) / d,KIND=sp) d22 = real( a( k-1, k-1 ) / d,KIND=sp) @@ -3011,7 +3013,7 @@ module stdlib_linalg_lapack_c ! 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 @@ -3027,11 +3029,11 @@ module stdlib_linalg_lapack_c e( n ) = czero ! k is the main loop index, increasing from 1 to n in steps of ! 1 or 2 - k = 1 + 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 @@ -3040,14 +3042,14 @@ module stdlib_linalg_lapack_c ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( krowmax ) then rowmax = stemp @@ -3100,7 +3102,7 @@ module stdlib_linalg_lapack_c ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. ! case(4) else @@ -3115,12 +3117,12 @@ module stdlib_linalg_lapack_c ! end pivot search ! ============================================================ ! kk is the column of a where pivoting step stopped - kk = k + kstep - 1 + kk = k + kstep - 1_${ik}$ ! for only a 2x2 pivot, interchange rows and columns k and p ! in the trailing submatrix a(k:n,k:n) - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! (1) swap columnar parts - if( p1 )call stdlib_cswap( k-1, a( k, 1 ), lda, a( p, 1 ), lda ) + if ( k>1_${ik}$ )call stdlib${ii}$_cswap( k-1, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda ) end if ! for both 1x1 and 2x2 pivots, interchange rows and ! columns kk and kp in the trailing submatrix a(k:n,k:n) if( kp/=kk ) then ! (1) swap columnar parts - if( kp1 )call stdlib_cswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) + if ( k>1_${ik}$ )call stdlib${ii}$_cswap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) else ! (*) make sure that diagonal element of pivot is real a( k, k ) = real( a( k, k ),KIND=sp) - if( kstep==2 )a( k+1, k+1 ) = real( a( k+1, k+1 ),KIND=sp) + if( kstep==2_${ik}$ )a( k+1, k+1 ) = real( a( k+1, k+1 ),KIND=sp) end if ! update the trailing submatrix - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of a now holds ! w(k) = l(k)*d(k), ! where l(k) is the k-th column of l @@ -3185,10 +3187,10 @@ module stdlib_linalg_lapack_c ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t d11 = one / real( a( k, k ),KIND=sp) - call stdlib_cher( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_cher( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda ) ! store l(k) in column k - call stdlib_csscal( n-k, d11, a( k+1, k ), 1 ) + call stdlib${ii}$_csscal( n-k, d11, a( k+1, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = real( a( k, k ),KIND=sp) @@ -3199,7 +3201,7 @@ module stdlib_linalg_lapack_c ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_cher( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_cher( 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 @@ -3216,7 +3218,7 @@ module stdlib_linalg_lapack_c ! and store l(k) and l(k+1) in columns k and k+1 if( k1 ) then - imax = stdlib_icamax( k-1, a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_icamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ ) colmax = cabs1( a( imax, k ) ) else colmax = zero end if if( ( max( absakk, colmax )==zero ) ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k a( k, k ) = real( a( k, k ),KIND=sp) else @@ -3360,13 +3362,13 @@ module stdlib_linalg_lapack_c ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = imax + stdlib_icamax( k-imax, a( imax, imax+1 ),lda ) + jmax = imax + stdlib${ii}$_icamax( k-imax, a( imax, imax+1 ),lda ) rowmax = cabs1( a( imax, jmax ) ) else rowmax = zero end if - if( imax>1 ) then - itemp = stdlib_icamax( imax-1, a( 1, imax ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_icamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ ) stemp = cabs1( a( itemp, imax ) ) if( stemp>rowmax ) then rowmax = stemp @@ -3390,7 +3392,7 @@ module stdlib_linalg_lapack_c ! interchange rows and columns k-1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. ! case(4) else @@ -3405,12 +3407,12 @@ module stdlib_linalg_lapack_c ! end pivot search ! ============================================================ ! kk is the column of a where pivoting step stopped - kk = k - kstep + 1 + kk = k - kstep + 1_${ik}$ ! for only a 2x2 pivot, interchange rows and columns k and p ! in the leading submatrix a(1:k,1:k) - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! (1) swap columnar parts - if( p>1 )call stdlib_cswap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) + if( p>1_${ik}$ )call stdlib${ii}$_cswap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) ! (2) swap and conjugate middle parts do j = p + 1, k - 1 t = conjg( a( j, k ) ) @@ -3428,7 +3430,7 @@ module stdlib_linalg_lapack_c ! columns kk and kp in the leading submatrix a(1:k,1:k) if( kp/=kk ) then ! (1) swap columnar parts - if( kp>1 )call stdlib_cswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + if( kp>1_${ik}$ )call stdlib${ii}$_cswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) ! (2) swap and conjugate middle parts do j = kp + 1, kk - 1 t = conjg( a( j, kk ) ) @@ -3441,7 +3443,7 @@ module stdlib_linalg_lapack_c r1 = real( a( kk, kk ),KIND=sp) a( kk, kk ) = real( a( kp, kp ),KIND=sp) a( kp, kp ) = r1 - if( kstep==2 ) then + if( kstep==2_${ik}$ ) then ! (*) make sure that diagonal element of pivot is real a( k, k ) = real( a( k, k ),KIND=sp) ! (5) swap row elements @@ -3452,14 +3454,14 @@ module stdlib_linalg_lapack_c else ! (*) make sure that diagonal element of pivot is real a( k, k ) = real( a( k, k ),KIND=sp) - if( kstep==2 )a( k-1, k-1 ) = real( a( k-1, k-1 ),KIND=sp) + if( kstep==2_${ik}$ )a( k-1, k-1 ) = real( a( k-1, k-1 ),KIND=sp) end if ! update the leading submatrix - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u - if( k>1 ) then + if( k>1_${ik}$ ) then ! perform a rank-1 update of a(1:k-1,1:k-1) and ! store u(k) in column k if( abs( real( a( k, k ),KIND=sp) )>=sfmin ) then @@ -3467,9 +3469,9 @@ module stdlib_linalg_lapack_c ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*1/d(k)*w(k)**t d11 = one / real( a( k, k ),KIND=sp) - call stdlib_cher( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_cher( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) ! store u(k) in column k - call stdlib_csscal( k-1, d11, a( 1, k ), 1 ) + call stdlib${ii}$_csscal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = real( a( k, k ),KIND=sp) @@ -3480,7 +3482,7 @@ module stdlib_linalg_lapack_c ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_cher( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_cher( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) end if end if else @@ -3492,9 +3494,9 @@ module stdlib_linalg_lapack_c ! 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 ! d = |a12| - d = stdlib_slapy2( real( a( k-1, k ),KIND=sp),aimag( a( k-1, k ) ) ) + d = stdlib${ii}$_slapy2( real( a( k-1, k ),KIND=sp),aimag( a( k-1, k ) ) ) d11 = real( a( k, k ) / d,KIND=sp) d22 = real( a( k-1, k-1 ) / d,KIND=sp) @@ -3519,7 +3521,7 @@ module stdlib_linalg_lapack_c 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 @@ -3532,11 +3534,11 @@ module stdlib_linalg_lapack_c ! factorize a as l*d*l**h using the lower triangle of a ! k is the main loop index, increasing from 1 to n in steps of ! 1 or 2 - k = 1 + 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 @@ -3545,14 +3547,14 @@ module stdlib_linalg_lapack_c ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( krowmax ) then rowmax = stemp @@ -3603,7 +3605,7 @@ module stdlib_linalg_lapack_c ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. ! case(4) else @@ -3618,12 +3620,12 @@ module stdlib_linalg_lapack_c ! end pivot search ! ============================================================ ! kk is the column of a where pivoting step stopped - kk = k + kstep - 1 + kk = k + kstep - 1_${ik}$ ! for only a 2x2 pivot, interchange rows and columns k and p ! in the trailing submatrix a(k:n,k:n) - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! (1) swap columnar parts - if( p0 .and. a( info, info )==czero )return end do end if - info = 0 + info = 0_${ik}$ if( upper ) then ! compute inv(a) from the factorization a = u*d*u**h. ! 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 = 1_${ik}$ 30 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = one / real( a( k, k ),KIND=sp) ! compute column k of the inverse. - if( k>1 ) then - call stdlib_ccopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_chemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_ccopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_chemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - real( stdlib_cdotc( k-1, work, 1, a( 1,k ), 1 ),& + a( k, k ) = a( k, k ) - real( stdlib${ii}$_cdotc( k-1, work, 1_${ik}$, a( 1_${ik}$,k ), 1_${ik}$ ),& KIND=sp) end if - kstep = 1 + kstep = 1_${ik}$ else ! 2 x 2 diagonal block ! invert the diagonal block. @@ -3839,27 +3841,27 @@ module stdlib_linalg_lapack_c 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_ccopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_chemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_ccopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_chemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - real( stdlib_cdotc( k-1, work, 1, a( 1,k ), 1 ),& + a( k, k ) = a( k, k ) - real( stdlib${ii}$_cdotc( k-1, work, 1_${ik}$, a( 1_${ik}$,k ), 1_${ik}$ ),& KIND=sp) - a( k, k+1 ) = a( k, k+1 ) -stdlib_cdotc( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) + a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_cdotc( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) - call stdlib_ccopy( k-1, a( 1, k+1 ), 1, work, 1 ) - call stdlib_chemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k+1 ), 1 ) + call stdlib${ii}$_ccopy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_chemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k+1 ), 1_${ik}$ ) - a( k+1, k+1 ) = a( k+1, k+1 ) -real( stdlib_cdotc( k-1, work, 1, a( 1, k+1 ),& - 1 ),KIND=sp) + a( k+1, k+1 ) = a( k+1, k+1 ) -real( stdlib${ii}$_cdotc( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ),& + 1_${ik}$ ),KIND=sp) 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_cswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_cswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) do j = kp + 1, k - 1 temp = conjg( a( j, k ) ) a( j, k ) = conjg( a( kp, j ) ) @@ -3869,7 +3871,7 @@ module stdlib_linalg_lapack_c 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 @@ -3886,19 +3888,19 @@ module stdlib_linalg_lapack_c 60 continue ! if k < 1, exit from loop. if( k<1 )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = one / real( a( k, k ),KIND=sp) ! compute column k of the inverse. if( k0 .and. a( info, info )==czero )return end do end if - info = 0 + info = 0_${ik}$ if( upper ) then ! compute inv(a) from the factorization a = u*d*u**h. ! 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 = 1_${ik}$ 30 continue ! if k > n, exit from loop. if( k>n )go to 70 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = one / real( a( k, k ),KIND=sp) ! compute column k of the inverse. - if( k>1 ) then - call stdlib_ccopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_chemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_ccopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_chemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - real( stdlib_cdotc( k-1, work, 1, a( 1,k ), 1 ),& + a( k, k ) = a( k, k ) - real( stdlib${ii}$_cdotc( k-1, work, 1_${ik}$, a( 1_${ik}$,k ), 1_${ik}$ ),& KIND=sp) end if - kstep = 1 + kstep = 1_${ik}$ else ! 2 x 2 diagonal block ! invert the diagonal block. @@ -4043,28 +4045,28 @@ module stdlib_linalg_lapack_c 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_ccopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_chemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_ccopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_chemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - real( stdlib_cdotc( k-1, work, 1, a( 1,k ), 1 ),& + a( k, k ) = a( k, k ) - real( stdlib${ii}$_cdotc( k-1, work, 1_${ik}$, a( 1_${ik}$,k ), 1_${ik}$ ),& KIND=sp) - a( k, k+1 ) = a( k, k+1 ) -stdlib_cdotc( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) + a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_cdotc( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) - call stdlib_ccopy( k-1, a( 1, k+1 ), 1, work, 1 ) - call stdlib_chemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k+1 ), 1 ) + call stdlib${ii}$_ccopy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_chemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k+1 ), 1_${ik}$ ) - a( k+1, k+1 ) = a( k+1, k+1 ) -real( stdlib_cdotc( k-1, work, 1, a( 1, k+1 ),& - 1 ),KIND=sp) + a( k+1, k+1 ) = a( k+1, k+1 ) -real( stdlib${ii}$_cdotc( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ),& + 1_${ik}$ ),KIND=sp) 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:k) kp = ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_cswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) + if( kp>1_${ik}$ )call stdlib${ii}$_cswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) do j = kp + 1, k - 1 temp = conjg( a( j, k ) ) a( j, k ) = conjg( a( kp, j ) ) @@ -4081,7 +4083,7 @@ module stdlib_linalg_lapack_c ! (1) interchange rows and columns k and -ipiv(k) kp = -ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_cswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) + if( kp>1_${ik}$ )call stdlib${ii}$_cswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) do j = kp + 1, k - 1 temp = conjg( a( j, k ) ) a( j, k ) = conjg( a( kp, j ) ) @@ -4096,10 +4098,10 @@ module stdlib_linalg_lapack_c a( kp, k+1 ) = temp end if ! (2) interchange rows and columns k+1 and -ipiv(k+1) - k = k + 1 + k = k + 1_${ik}$ kp = -ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_cswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) + if( kp>1_${ik}$ )call stdlib${ii}$_cswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) do j = kp + 1, k - 1 temp = conjg( a( j, k ) ) a( j, k ) = conjg( a( kp, j ) ) @@ -4111,7 +4113,7 @@ module stdlib_linalg_lapack_c a( kp, kp ) = temp end if end if - k = k + 1 + k = k + 1_${ik}$ go to 30 70 continue else @@ -4122,19 +4124,19 @@ module stdlib_linalg_lapack_c 80 continue ! if k < 1, exit from loop. if( k<1 )go to 120 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = one / real( a( k, k ),KIND=sp) ! compute column k of the inverse. if( k b [ (u \p**t * b) ] - call stdlib_ctrsm( 'L', 'U', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib${ii}$_ctrsm( 'L', 'U', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) ! compute d \ b -> b [ d \ (u \p**t * b) ] i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then + if( ipiv( i )>0_${ik}$ ) then s = real( cone,KIND=sp) / real( a( i, i ),KIND=sp) - call stdlib_csscal( nrhs, s, b( i, 1 ), ldb ) - else if ( i>1 ) then + call stdlib${ii}$_csscal( nrhs, s, 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 ) / conjg( akm1k ) @@ -4307,12 +4309,12 @@ module stdlib_linalg_lapack_c 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**h \ b) -> b [ u**h \ (d \ (u \p**t * b) ) ] - call stdlib_ctrsm( 'L', 'U', 'C', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib${ii}$_ctrsm( 'L', 'U', 'C', 'U', n, nrhs, cone, a, lda, b, ldb ) ! p * b [ p * (u**h \ (d \ (u \p**t * b) )) ] ! interchange rows k and ipiv(k) of matrix b in reverse order ! from the formation order of ipiv(i) vector for upper case. @@ -4322,7 +4324,7 @@ module stdlib_linalg_lapack_c do k = 1, n, 1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end if end do else @@ -4337,17 +4339,17 @@ module stdlib_linalg_lapack_c do k = 1, n, 1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib${ii}$_cswap( 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_ctrsm( 'L', 'L', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib${ii}$_ctrsm( 'L', 'L', 'N', 'U', n, nrhs, cone, 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 + if( ipiv( i )>0_${ik}$ ) then s = real( cone,KIND=sp) / real( a( i, i ),KIND=sp) - call stdlib_csscal( nrhs, s, b( i, 1 ), ldb ) + call stdlib${ii}$_csscal( nrhs, s, b( i, 1_${ik}$ ), ldb ) else if( i b [ l**h \ (d \ (l \p**t * b) ) ] - call stdlib_ctrsm('L', 'L', 'C', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib${ii}$_ctrsm('L', 'L', 'C', 'U', n, nrhs, cone, a, lda, b, ldb ) ! p * b [ p * (l**h \ (d \ (l \p**t * b) )) ] ! interchange rows k and ipiv(k) of matrix b in reverse order ! from the formation order of ipiv(i) vector for lower case. @@ -4374,16 +4376,16 @@ module stdlib_linalg_lapack_c do k = n, 1, -1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end if end do ! end lower end if return - end subroutine stdlib_chetrs_3 + end subroutine stdlib${ii}$_chetrs_3 - pure subroutine stdlib_chfrk( transr, uplo, trans, n, k, alpha, a, lda, beta,c ) + pure subroutine stdlib${ii}$_chfrk( transr, uplo, trans, n, k, alpha, a, lda, beta,c ) !! Level 3 BLAS like routine for C in RFP Format. !! CHFRK performs one of the Hermitian rank--k operations !! C := alpha*A*A**H + beta*C, @@ -4397,7 +4399,7 @@ module stdlib_linalg_lapack_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, n + integer(${ik}$), intent(in) :: k, lda, n character, intent(in) :: trans, transr, uplo ! Array Arguments complex(sp), intent(in) :: a(lda,*) @@ -4407,13 +4409,13 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: lower, normaltransr, nisodd, notrans - integer(ilp) :: info, nrowa, j, nk, n1, n2 + integer(${ik}$) :: info, nrowa, j, nk, n1, n2 complex(sp) :: calpha, cbeta ! Intrinsic Functions intrinsic :: max,cmplx ! 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' ) @@ -4423,26 +4425,26 @@ module stdlib_linalg_lapack_c nrowa = k end if if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'C' ) ) 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, 'C' ) ) 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( 'CHPGST', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'CHPGST', -info ) return end if - if( itype==1 ) then + if( itype==1_${ik}$ ) then if( upper ) then ! compute inv(u**h)*a*inv(u) ! j1 and jj are the indices of a(1,j) and a(j,j) - jj = 0 + 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 ap( jj ) = real( ap( jj ),KIND=sp) bjj = real( bp( jj ),KIND=sp) - call stdlib_ctpsv( uplo, 'CONJUGATE TRANSPOSE', 'NON-UNIT', j,bp, ap( j1 ), 1 & + call stdlib${ii}$_ctpsv( uplo, 'CONJUGATE TRANSPOSE', 'NON-UNIT', j,bp, ap( j1 ), 1_${ik}$ & ) - call stdlib_chpmv( uplo, j-1, -cone, ap, bp( j1 ), 1, cone,ap( j1 ), 1 ) + call stdlib${ii}$_chpmv( uplo, j-1, -cone, ap, bp( j1 ), 1_${ik}$, cone,ap( j1 ), 1_${ik}$ ) - call stdlib_csscal( j-1, one / bjj, ap( j1 ), 1 ) - ap( jj ) = ( ap( jj )-stdlib_cdotc( j-1, ap( j1 ), 1, bp( j1 ),1 ) ) / & + call stdlib${ii}$_csscal( j-1, one / bjj, ap( j1 ), 1_${ik}$ ) + ap( jj ) = ( ap( jj )-stdlib${ii}$_cdotc( j-1, ap( j1 ), 1_${ik}$, bp( j1 ),1_${ik}$ ) ) / & bjj end do else ! compute inv(l)*a*inv(l**h) ! 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 = real( ap( kk ),KIND=sp) bkk = real( bp( kk ),KIND=sp) - akk = akk / bkk**2 + akk = akk / bkk**2_${ik}$ ap( kk ) = akk if( k1 ) then - imax = stdlib_icamax( k-1, ap( kc ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_icamax( k-1, ap( kc ), 1_${ik}$ ) colmax = cabs1( 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 ap( kc+k-1 ) = real( ap( kc+k-1 ),KIND=sp) else @@ -4856,7 +4858,7 @@ module stdlib_linalg_lapack_c ! element in row imax, and rowmax is its absolute value rowmax = zero jmax = imax - kx = imax*( imax+1 ) / 2 + imax + kx = imax*( imax+1 ) / 2_${ik}$ + imax do j = imax + 1, k if( cabs1( ap( kx ) )>rowmax ) then rowmax = cabs1( ap( kx ) ) @@ -4864,9 +4866,9 @@ module stdlib_linalg_lapack_c end if kx = kx + j end do - kpc = ( imax-1 )*imax / 2 + 1 - if( imax>1 ) then - jmax = stdlib_icamax( imax-1, ap( kpc ), 1 ) + kpc = ( imax-1 )*imax / 2_${ik}$ + 1_${ik}$ + if( imax>1_${ik}$ ) then + jmax = stdlib${ii}$_icamax( imax-1, ap( kpc ), 1_${ik}$ ) rowmax = max( rowmax, cabs1( ap( kpc+jmax-1 ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then @@ -4880,18 +4882,18 @@ module stdlib_linalg_lapack_c ! interchange rows and columns k-1 and imax, use 2-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_cswap( kp-1, ap( knc ), 1, ap( kpc ), 1 ) - kx = kpc + kp - 1 + call stdlib${ii}$_cswap( 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 = conjg( ap( knc+j-1 ) ) ap( knc+j-1 ) = conjg( ap( kx ) ) ap( kx ) = t @@ -4900,7 +4902,7 @@ module stdlib_linalg_lapack_c r1 = real( ap( knc+kk-1 ),KIND=sp) ap( knc+kk-1 ) = real( ap( kpc+kp-1 ),KIND=sp) ap( kpc+kp-1 ) = r1 - if( kstep==2 ) then + if( kstep==2_${ik}$ ) then ap( kc+k-1 ) = real( ap( kc+k-1 ),KIND=sp) t = ap( kc+k-2 ) ap( kc+k-2 ) = ap( kc+kp-1 ) @@ -4908,19 +4910,19 @@ module stdlib_linalg_lapack_c end if else ap( kc+k-1 ) = real( ap( kc+k-1 ),KIND=sp) - if( kstep==2 )ap( kc-1 ) = real( ap( kc-1 ),KIND=sp) + if( kstep==2_${ik}$ )ap( kc-1 ) = real( ap( kc-1 ),KIND=sp) end if ! update the leading submatrix - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u ! perform a rank-1 update of a(1:k-1,1:k-1) as ! a := a - u(k)*d(k)*u(k)**h = a - w(k)*1/d(k)*w(k)**h r1 = one / real( ap( kc+k-1 ),KIND=sp) - call stdlib_chpr( uplo, k-1, -r1, ap( kc ), 1, ap ) + call stdlib${ii}$_chpr( uplo, k-1, -r1, ap( kc ), 1_${ik}$, ap ) ! store u(k) in column k - call stdlib_csscal( k-1, r1, ap( kc ), 1 ) + call stdlib${ii}$_csscal( k-1, r1, ap( kc ), 1_${ik}$ ) else ! 2-by-2 pivot block d(k): columns k and k-1 now hold ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k) @@ -4929,33 +4931,33 @@ module stdlib_linalg_lapack_c ! perform a rank-2 update of a(1:k-2,1:k-2) as ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**h ! = a - ( w(k-1) w(k) )*inv(d(k))*( w(k-1) w(k) )**h - if( k>2 ) then - d = stdlib_slapy2( real( ap( k-1+( k-1 )*k / 2 ),KIND=sp),aimag( ap( k-1+( & - k-1 )*k / 2 ) ) ) - d22 = real( ap( k-1+( k-2 )*( k-1 ) / 2 ),KIND=sp) / d - d11 = real( ap( k+( k-1 )*k / 2 ),KIND=sp) / d + if( k>2_${ik}$ ) then + d = stdlib${ii}$_slapy2( real( ap( k-1+( k-1 )*k / 2_${ik}$ ),KIND=sp),aimag( ap( k-1+( & + k-1 )*k / 2_${ik}$ ) ) ) + d22 = real( ap( k-1+( k-2 )*( k-1 ) / 2_${ik}$ ),KIND=sp) / d + d11 = real( ap( k+( k-1 )*k / 2_${ik}$ ),KIND=sp) / d tt = one / ( d11*d22-one ) - d12 = ap( k-1+( k-1 )*k / 2 ) / d + d12 = ap( k-1+( k-1 )*k / 2_${ik}$ ) / d d = tt / d do j = k - 2, 1, -1 - wkm1 = d*( d11*ap( j+( k-2 )*( k-1 ) / 2 )-conjg( d12 )*ap( j+( k-1 )*k & - / 2 ) ) - wk = d*( d22*ap( j+( k-1 )*k / 2 )-d12*ap( j+( k-2 )*( k-1 ) / 2 ) ) + wkm1 = d*( d11*ap( j+( k-2 )*( k-1 ) / 2_${ik}$ )-conjg( d12 )*ap( j+( k-1 )*k & + / 2_${ik}$ ) ) + wk = d*( d22*ap( j+( k-1 )*k / 2_${ik}$ )-d12*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 )& - *conjg( wk ) -ap( i+( k-2 )*( k-1 ) / 2 )*conjg( wkm1 ) + ap( i+( j-1 )*j / 2_${ik}$ ) = ap( i+( j-1 )*j / 2_${ik}$ ) -ap( i+( k-1 )*k / 2_${ik}$ )& + *conjg( wk ) -ap( i+( k-2 )*( k-1 ) / 2_${ik}$ )*conjg( wkm1 ) end do - ap( j+( k-1 )*k / 2 ) = wk - ap( j+( k-2 )*( k-1 ) / 2 ) = wkm1 - ap( j+( j-1 )*j / 2 ) = cmplx( real( ap( j+( j-1 )*j / 2 ),KIND=sp), & + ap( j+( k-1 )*k / 2_${ik}$ ) = wk + ap( j+( k-2 )*( k-1 ) / 2_${ik}$ ) = wkm1 + ap( j+( j-1 )*j / 2_${ik}$ ) = cmplx( real( ap( j+( j-1 )*j / 2_${ik}$ ),KIND=sp), & zero,KIND=sp) 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 @@ -4969,28 +4971,28 @@ module stdlib_linalg_lapack_c ! factorize a as l*d*l**h using the lower triangle of a ! k is the main loop index, increasing from 1 to n in steps of ! 1 or 2 - k = 1 - kc = 1 - npp = n*( n+1 ) / 2 + 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 absakk = abs( real( ap( kc ),KIND=sp) ) ! imax is the row-index of the largest off-diagonal element in ! column k, and colmax is its absolute value if( k=alpha*colmax*( colmax / rowmax ) ) then @@ -5025,19 +5027,19 @@ module stdlib_linalg_lapack_c ! interchange rows and columns k+1 and imax, use 2-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 )==czero )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 )==czero )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**h. ! 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 = 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. ap( kc+k-1 ) = one / real( ap( kc+k-1 ),KIND=sp) ! compute column k of the inverse. - if( k>1 ) then - call stdlib_ccopy( k-1, ap( kc ), 1, work, 1 ) - call stdlib_chpmv( uplo, k-1, -cone, ap, work, 1, czero,ap( kc ), 1 ) - ap( kc+k-1 ) = ap( kc+k-1 ) -real( stdlib_cdotc( k-1, work, 1, ap( kc ), 1 ),& + if( k>1_${ik}$ ) then + call stdlib${ii}$_ccopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_chpmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kc ), 1_${ik}$ ) + ap( kc+k-1 ) = ap( kc+k-1 ) -real( stdlib${ii}$_cdotc( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ ),& KIND=sp) end if - kstep = 1 + kstep = 1_${ik}$ else ! 2 x 2 diagonal block ! invert the diagonal block. @@ -5213,31 +5215,31 @@ module stdlib_linalg_lapack_c 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_ccopy( k-1, ap( kc ), 1, work, 1 ) - call stdlib_chpmv( uplo, k-1, -cone, ap, work, 1, czero,ap( kc ), 1 ) - ap( kc+k-1 ) = ap( kc+k-1 ) -real( stdlib_cdotc( k-1, work, 1, ap( kc ), 1 ),& + if( k>1_${ik}$ ) then + call stdlib${ii}$_ccopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_chpmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kc ), 1_${ik}$ ) + ap( kc+k-1 ) = ap( kc+k-1 ) -real( stdlib${ii}$_cdotc( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ ),& KIND=sp) - ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib_cdotc( k-1, ap( kc ), 1, ap( & - kcnext ),1 ) - call stdlib_ccopy( k-1, ap( kcnext ), 1, work, 1 ) - call stdlib_chpmv( uplo, k-1, -cone, ap, work, 1, czero,ap( kcnext ), 1 ) + ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib${ii}$_cdotc( k-1, ap( kc ), 1_${ik}$, ap( & + kcnext ),1_${ik}$ ) + call stdlib${ii}$_ccopy( k-1, ap( kcnext ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_chpmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kcnext ), 1_${ik}$ ) - ap( kcnext+k ) = ap( kcnext+k ) -real( stdlib_cdotc( k-1, work, 1, ap( kcnext & - ),1 ),KIND=sp) + ap( kcnext+k ) = ap( kcnext+k ) -real( stdlib${ii}$_cdotc( k-1, work, 1_${ik}$, ap( kcnext & + ),1_${ik}$ ),KIND=sp) 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_cswap( kp-1, ap( kc ), 1, ap( kpc ), 1 ) - kx = kpc + kp - 1 + kpc = ( kp-1 )*kp / 2_${ik}$ + 1_${ik}$ + call stdlib${ii}$_cswap( kp-1, ap( kc ), 1_${ik}$, ap( kpc ), 1_${ik}$ ) + kx = kpc + kp - 1_${ik}$ do j = kp + 1, k - 1 - kx = kx + j - 1 + kx = kx + j - 1_${ik}$ temp = conjg( ap( kc+j-1 ) ) ap( kc+j-1 ) = conjg( ap( kx ) ) ap( kx ) = temp @@ -5246,7 +5248,7 @@ module stdlib_linalg_lapack_c 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 @@ -5260,26 +5262,26 @@ module stdlib_linalg_lapack_c ! compute inv(a) from the factorization a = l*d*l**h. ! 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 + 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. ap( kc ) = one / real( ap( kc ),KIND=sp) ! compute column k of the inverse. if( km-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 == 0.0_sp ) then symb_zero = .true. @@ -5482,7 +5484,7 @@ module stdlib_linalg_lapack_c end do end if else - if( trans==stdlib_ilatrans( 'N' ) )then + if( trans==stdlib${ii}$_ilatrans( 'N' ) )then do i = 1, leny if ( beta == 0.0_sp ) then symb_zero = .true. @@ -5533,10 +5535,10 @@ module stdlib_linalg_lapack_c end if end if return - end subroutine stdlib_cla_gbamv + end subroutine stdlib${ii}$_cla_gbamv - pure real(sp) function stdlib_cla_gbrpvgrw( n, kl, ku, ncols, ab, ldab, afb,ldafb ) + pure real(sp) function stdlib${ii}$_cla_gbrpvgrw( n, kl, ku, ncols, ab, ldab, afb,ldafb ) !! CLA_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 @@ -5547,12 +5549,12 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(in) :: ab(ldab,*), afb(ldafb,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, kd + integer(${ik}$) :: i, j, kd real(sp) :: amax, umax, rpvgrw complex(sp) :: zdum ! Intrinsic Functions @@ -5563,7 +5565,7 @@ module stdlib_linalg_lapack_c cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) ) ! Executable Statements rpvgrw = one - kd = ku + 1 + kd = ku + 1_${ik}$ do j = 1, ncols amax = zero umax = zero @@ -5577,11 +5579,11 @@ module stdlib_linalg_lapack_c rpvgrw = min( amax / umax, rpvgrw ) end if end do - stdlib_cla_gbrpvgrw = rpvgrw - end function stdlib_cla_gbrpvgrw + stdlib${ii}$_cla_gbrpvgrw = rpvgrw + end function stdlib${ii}$_cla_gbrpvgrw - subroutine stdlib_cla_geamv( trans, m, n, alpha, a, lda, x, incx, beta,y, incy ) + subroutine stdlib${ii}$_cla_geamv( trans, m, n, alpha, a, lda, x, incx, beta,y, incy ) !! CLA_GEAMV performs one of the matrix-vector operations !! y := alpha*abs(A)*abs(x) + beta*abs(y), !! or y := alpha*abs(A)**T*abs(x) + beta*abs(y), @@ -5600,8 +5602,8 @@ module stdlib_linalg_lapack_c ! -- 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(ilp), intent(in) :: trans + integer(${ik}$), intent(in) :: incx, incy, lda, m, n + integer(${ik}$), intent(in) :: trans ! Array Arguments complex(sp), intent(in) :: a(lda,*), x(*) real(sp), intent(inout) :: y(*) @@ -5610,7 +5612,7 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: symb_zero real(sp) :: temp, safe1 - integer(ilp) :: i, info, iy, j, jx, kx, ky, lenx, leny + integer(${ik}$) :: i, info, iy, j, jx, kx, ky, lenx, leny complex(sp) :: cdum ! Intrinsic Functions intrinsic :: max,abs,real,aimag,sign @@ -5620,57 +5622,57 @@ module stdlib_linalg_lapack_c cabs1( cdum ) = abs( real( cdum,KIND=sp) ) + abs( aimag( cdum ) ) ! 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( lda0 )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 == 0.0_sp ) then symb_zero = .true. @@ -5716,7 +5718,7 @@ module stdlib_linalg_lapack_c end do end if else - if( trans==stdlib_ilatrans( 'N' ) )then + if( trans==stdlib${ii}$_ilatrans( 'N' ) )then do i = 1, leny if ( beta == 0.0_sp ) then symb_zero = .true. @@ -5767,10 +5769,10 @@ module stdlib_linalg_lapack_c end if end if return - end subroutine stdlib_cla_geamv + end subroutine stdlib${ii}$_cla_geamv - pure real(sp) function stdlib_cla_gerpvgrw( n, ncols, a, lda, af, ldaf ) + pure real(sp) function stdlib${ii}$_cla_gerpvgrw( n, ncols, a, lda, af, ldaf ) !! CLA_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 @@ -5781,12 +5783,12 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(in) :: a(lda,*), af(ldaf,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(sp) :: amax, umax, rpvgrw complex(sp) :: zdum ! Intrinsic Functions @@ -5810,11 +5812,11 @@ module stdlib_linalg_lapack_c rpvgrw = min( amax / umax, rpvgrw ) end if end do - stdlib_cla_gerpvgrw = rpvgrw - end function stdlib_cla_gerpvgrw + stdlib${ii}$_cla_gerpvgrw = rpvgrw + end function stdlib${ii}$_cla_gerpvgrw - subroutine stdlib_cla_heamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy ) + subroutine stdlib${ii}$_cla_heamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy ) !! CLA_SYAMV performs the matrix-vector operation !! y := alpha*abs(A)*abs(x) + beta*abs(y), !! where alpha and beta are scalars, x and y are vectors and A is an @@ -5832,7 +5834,7 @@ module stdlib_linalg_lapack_c ! -- 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, uplo + integer(${ik}$), intent(in) :: incx, incy, lda, n, uplo ! Array Arguments complex(sp), intent(in) :: a(lda,*), x(*) real(sp), intent(inout) :: y(*) @@ -5841,7 +5843,7 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: symb_zero real(sp) :: temp, safe1 - integer(ilp) :: i, info, iy, j, jx, kx, ky + integer(${ik}$) :: i, info, iy, j, jx, kx, ky complex(sp) :: zdum ! Intrinsic Functions intrinsic :: max,abs,sign,real,aimag @@ -5851,46 +5853,46 @@ module stdlib_linalg_lapack_c cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag ( zdum ) ) ! Executable Statements ! test the input parameters. - info = 0 - if ( uplo/=stdlib_ilauplo( 'U' ) .and.uplo/=stdlib_ilauplo( 'L' ) )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 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. @@ -5944,7 +5946,7 @@ module stdlib_linalg_lapack_c 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. @@ -6005,10 +6007,10 @@ module stdlib_linalg_lapack_c end if end if return - end subroutine stdlib_cla_heamv + end subroutine stdlib${ii}$_cla_heamv - pure subroutine stdlib_cla_lin_berr( n, nz, nrhs, res, ayb, berr ) + pure subroutine stdlib${ii}$_cla_lin_berr( n, nz, nrhs, res, ayb, berr ) !! CLA_LIN_BERR computes componentwise relative backward error from !! the formula !! max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) @@ -6018,7 +6020,7 @@ module stdlib_linalg_lapack_c ! -- 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, nz, nrhs + integer(${ik}$), intent(in) :: n, nz, nrhs ! Array Arguments real(sp), intent(in) :: ayb(n,nrhs) real(sp), intent(out) :: berr(nrhs) @@ -6026,7 +6028,7 @@ module stdlib_linalg_lapack_c ! ===================================================================== ! Local Scalars real(sp) :: tmp,safe1 - integer(ilp) :: i, j + integer(${ik}$) :: i, j complex(sp) :: cdum ! Intrinsic Functions intrinsic :: abs,real,aimag,max @@ -6038,7 +6040,7 @@ module stdlib_linalg_lapack_c ! adding safe1 to the numerator guards against spuriously zero ! residuals. a similar safeguard is in the cla_yyamv routine used ! to compute ayb. - safe1 = stdlib_slamch( 'SAFE MINIMUM' ) + safe1 = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) safe1 = (nz+1)*safe1 do j = 1, nrhs berr(j) = zero @@ -6051,10 +6053,10 @@ module stdlib_linalg_lapack_c ! the true residual also must be exactly zero. end do end do - end subroutine stdlib_cla_lin_berr + end subroutine stdlib${ii}$_cla_lin_berr - real(sp) function stdlib_cla_porpvgrw( uplo, ncols, a, lda, af, ldaf, work ) + real(sp) function stdlib${ii}$_cla_porpvgrw( uplo, ncols, a, lda, af, ldaf, work ) !! CLA_PORPVGRW computes the reciprocal pivot growth factor !! norm(A)/norm(U). The "max absolute element" norm is used. If this is !! much less than 1, the stability of the LU factorization of the @@ -6066,13 +6068,13 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: ncols, lda, ldaf + integer(${ik}$), intent(in) :: ncols, lda, ldaf ! Array Arguments complex(sp), intent(in) :: a(lda,*), af(ldaf,*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(sp) :: amax, umax, rpvgrw logical(lk) :: upper complex(sp) :: zdum @@ -6084,7 +6086,7 @@ module stdlib_linalg_lapack_c cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) ) ! Executable Statements upper = stdlib_lsame( 'UPPER', uplo ) - ! stdlib_spotrf will have factored only the ncolsxncols leading minor, so + ! stdlib${ii}$_spotrf will have factored only the ncolsxncols leading minor, so ! we restrict the growth search to that minor and use only the first ! 2*ncols workspace entries. rpvgrw = one @@ -6143,11 +6145,11 @@ module stdlib_linalg_lapack_c end if end do end if - stdlib_cla_porpvgrw = rpvgrw - end function stdlib_cla_porpvgrw + stdlib${ii}$_cla_porpvgrw = rpvgrw + end function stdlib${ii}$_cla_porpvgrw - subroutine stdlib_cla_syamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy ) + subroutine stdlib${ii}$_cla_syamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy ) !! CLA_SYAMV performs the matrix-vector operation !! y := alpha*abs(A)*abs(x) + beta*abs(y), !! where alpha and beta are scalars, x and y are vectors and A is an @@ -6165,8 +6167,8 @@ module stdlib_linalg_lapack_c ! -- 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(ilp), intent(in) :: uplo + integer(${ik}$), intent(in) :: incx, incy, lda, n + integer(${ik}$), intent(in) :: uplo ! Array Arguments complex(sp), intent(in) :: a(lda,*), x(*) real(sp), intent(inout) :: y(*) @@ -6175,7 +6177,7 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: symb_zero real(sp) :: temp, safe1 - integer(ilp) :: i, info, iy, j, jx, kx, ky + integer(${ik}$) :: i, info, iy, j, jx, kx, ky complex(sp) :: zdum ! Intrinsic Functions intrinsic :: max,abs,sign,real,aimag @@ -6185,46 +6187,46 @@ module stdlib_linalg_lapack_c cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag ( zdum ) ) ! Executable Statements ! test the input parameters. - info = 0 - if ( uplo/=stdlib_ilauplo( 'U' ) .and.uplo/=stdlib_ilauplo( 'L' ) )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 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. @@ -6278,7 +6280,7 @@ module stdlib_linalg_lapack_c 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. @@ -6339,10 +6341,10 @@ module stdlib_linalg_lapack_c end if end if return - end subroutine stdlib_cla_syamv + end subroutine stdlib${ii}$_cla_syamv - pure subroutine stdlib_cla_wwaddw( n, x, y, w ) + pure subroutine stdlib${ii}$_cla_wwaddw( n, x, y, w ) !! CLA_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. @@ -6350,14 +6352,14 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: x(*), y(*) complex(sp), intent(in) :: w(*) ! ===================================================================== ! Local Scalars complex(sp) :: s - integer(ilp) :: i + integer(${ik}$) :: i ! Executable Statements do 10 i = 1, n s = x(i) + w(i) @@ -6366,86 +6368,86 @@ module stdlib_linalg_lapack_c x(i) = s 10 continue return - end subroutine stdlib_cla_wwaddw + end subroutine stdlib${ii}$_cla_wwaddw - pure subroutine stdlib_clacgv( n, x, incx ) + pure subroutine stdlib${ii}$_clacgv( n, x, incx ) !! CLACGV conjugates a complex vector of length 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 - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n ! Array Arguments complex(sp), intent(inout) :: x(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ioff + integer(${ik}$) :: i, ioff ! Intrinsic Functions intrinsic :: conjg ! Executable Statements - if( incx==1 ) then + if( incx==1_${ik}$ ) then do i = 1, n x( i ) = conjg( x( i ) ) end do else - ioff = 1 - if( incx<0 )ioff = 1 - ( n-1 )*incx + ioff = 1_${ik}$ + if( incx<0_${ik}$ )ioff = 1_${ik}$ - ( n-1 )*incx do i = 1, n x( ioff ) = conjg( x( ioff ) ) ioff = ioff + incx end do end if return - end subroutine stdlib_clacgv + end subroutine stdlib${ii}$_clacgv - pure subroutine stdlib_clacn2( n, v, x, est, kase, isave ) + pure subroutine stdlib${ii}$_clacn2( n, v, x, est, kase, isave ) !! CLACN2 estimates the 1-norm of a square, complex 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(inout) :: isave(3) + integer(${ik}$), intent(inout) :: isave(3_${ik}$) complex(sp), intent(out) :: v(*) complex(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) :: absxi, altsgn, estold, safmin, temp ! Intrinsic Functions intrinsic :: abs,aimag,cmplx,real ! Executable Statements - safmin = stdlib_slamch( 'SAFE MINIMUM' ) - if( kase==0 ) then + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) + if( kase==0_${ik}$ ) then do i = 1, n x( i ) = cmplx( one / real( n,KIND=sp),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, 90, 120 )isave( 1 ) ! ................ entry (isave( 1 ) = 1) ! 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 130 end if - est = stdlib_scsum1( n, x, 1 ) + est = stdlib${ii}$_scsum1( n, x, 1_${ik}$ ) do i = 1, n absxi = abs( x( i ) ) if( absxi>safmin ) then @@ -6455,29 +6457,29 @@ module stdlib_linalg_lapack_c x( i ) = cone end if end do - kase = 2 - isave( 1 ) = 2 + kase = 2_${ik}$ + isave( 1_${ik}$ ) = 2_${ik}$ return ! ................ entry (isave( 1 ) = 2) ! first iteration. x has been overwritten by ctrans(a)*x. 40 continue - isave( 2 ) = stdlib_icmax1( n, x, 1 ) - isave( 3 ) = 2 + isave( 2_${ik}$ ) = stdlib${ii}$_icmax1( n, x, 1_${ik}$ ) + isave( 3_${ik}$ ) = 2_${ik}$ ! main loop - iterations 2,3,...,itmax. 50 continue do i = 1, n x( i ) = czero end do - x( isave( 2 ) ) = cone - kase = 1 - isave( 1 ) = 3 + x( isave( 2_${ik}$ ) ) = cone + kase = 1_${ik}$ + isave( 1_${ik}$ ) = 3_${ik}$ return ! ................ entry (isave( 1 ) = 3) ! x has been overwritten by a*x. 70 continue - call stdlib_ccopy( n, x, 1, v, 1 ) + call stdlib${ii}$_ccopy( n, x, 1_${ik}$, v, 1_${ik}$ ) estold = est - est = stdlib_scsum1( n, v, 1 ) + est = stdlib${ii}$_scsum1( n, v, 1_${ik}$ ) ! test for cycling. if( est<=estold )go to 100 do i = 1, n @@ -6489,17 +6491,17 @@ module stdlib_linalg_lapack_c x( i ) = cone end if end do - kase = 2 - isave( 1 ) = 4 + kase = 2_${ik}$ + isave( 1_${ik}$ ) = 4_${ik}$ return ! ................ entry (isave( 1 ) = 4) ! x has been overwritten by ctrans(a)*x. 90 continue - jlast = isave( 2 ) - isave( 2 ) = stdlib_icmax1( n, x, 1 ) - if( ( abs( x( jlast ) )/=abs( x( isave( 2 ) ) ) ) .and.( isave( 3 )est ) then - call stdlib_ccopy( n, x, 1, v, 1 ) + call stdlib${ii}$_ccopy( n, x, 1_${ik}$, v, 1_${ik}$ ) est = temp end if 130 continue - kase = 0 + kase = 0_${ik}$ return - end subroutine stdlib_clacn2 + end subroutine stdlib${ii}$_clacn2 - subroutine stdlib_clacon( n, v, x, est, kase ) + subroutine stdlib${ii}$_clacon( n, v, x, est, kase ) !! CLACON estimates the 1-norm of a square, complex 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 complex(sp), intent(out) :: v(n) complex(sp), intent(inout) :: x(n) ! ===================================================================== ! 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) :: absxi, altsgn, estold, safmin, temp ! Intrinsic Functions intrinsic :: abs,aimag,cmplx,real ! Save Statement save ! Executable Statements - safmin = stdlib_slamch( 'SAFE MINIMUM' ) - if( kase==0 ) then + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) + if( kase==0_${ik}$ ) then do i = 1, n x( i ) = cmplx( one / real( n,KIND=sp),KIND=sp) end do - kase = 1 - jump = 1 + kase = 1_${ik}$ + jump = 1_${ik}$ return end if go to ( 20, 40, 70, 90, 120 )jump ! ................ entry (jump = 1) ! 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 130 end if - est = stdlib_scsum1( n, x, 1 ) + est = stdlib${ii}$_scsum1( n, x, 1_${ik}$ ) do i = 1, n absxi = abs( x( i ) ) if( absxi>safmin ) then @@ -6583,29 +6585,29 @@ module stdlib_linalg_lapack_c x( i ) = cone end if end do - kase = 2 - jump = 2 + kase = 2_${ik}$ + jump = 2_${ik}$ return ! ................ entry (jump = 2) ! first iteration. x has been overwritten by ctrans(a)*x. 40 continue - j = stdlib_icmax1( n, x, 1 ) - iter = 2 + j = stdlib${ii}$_icmax1( n, x, 1_${ik}$ ) + iter = 2_${ik}$ ! main loop - iterations 2,3,...,itmax. 50 continue do i = 1, n x( i ) = czero end do x( j ) = cone - kase = 1 - jump = 3 + kase = 1_${ik}$ + jump = 3_${ik}$ return ! ................ entry (jump = 3) ! x has been overwritten by a*x. 70 continue - call stdlib_ccopy( n, x, 1, v, 1 ) + call stdlib${ii}$_ccopy( n, x, 1_${ik}$, v, 1_${ik}$ ) estold = est - est = stdlib_scsum1( n, v, 1 ) + est = stdlib${ii}$_scsum1( n, v, 1_${ik}$ ) ! test for cycling. if( est<=estold )go to 100 do i = 1, n @@ -6617,16 +6619,16 @@ module stdlib_linalg_lapack_c x( i ) = cone end if end do - kase = 2 - jump = 4 + kase = 2_${ik}$ + jump = 4_${ik}$ return ! ................ entry (jump = 4) ! x has been overwritten by ctrans(a)*x. 90 continue jlast = j - j = stdlib_icmax1( n, x, 1 ) + j = stdlib${ii}$_icmax1( n, x, 1_${ik}$ ) if( ( abs( x( jlast ) )/=abs( x( j ) ) ) .and.( iterest ) then - call stdlib_ccopy( n, x, 1, v, 1 ) + call stdlib${ii}$_ccopy( n, x, 1_${ik}$, v, 1_${ik}$ ) est = temp end if 130 continue - kase = 0 + kase = 0_${ik}$ return - end subroutine stdlib_clacon + end subroutine stdlib${ii}$_clacon - pure subroutine stdlib_clacp2( uplo, m, n, a, lda, b, ldb ) + pure subroutine stdlib${ii}$_clacp2( uplo, m, n, a, lda, b, ldb ) !! CLACP2 copies all or part of a real two-dimensional matrix A to a !! complex matrix B. ! -- lapack auxiliary routine -- @@ -6662,13 +6664,13 @@ module stdlib_linalg_lapack_c ! -- 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,*) complex(sp), intent(out) :: b(ldb,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -6692,10 +6694,10 @@ module stdlib_linalg_lapack_c end do end if return - end subroutine stdlib_clacp2 + end subroutine stdlib${ii}$_clacp2 - pure subroutine stdlib_clacpy( uplo, m, n, a, lda, b, ldb ) + pure subroutine stdlib${ii}$_clacpy( uplo, m, n, a, lda, b, ldb ) !! CLACPY copies all or part of a two-dimensional matrix A to another !! matrix B. ! -- lapack auxiliary routine -- @@ -6703,13 +6705,13 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(in) :: a(lda,*) complex(sp), intent(out) :: b(ldb,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -6733,10 +6735,10 @@ module stdlib_linalg_lapack_c end do end if return - end subroutine stdlib_clacpy + end subroutine stdlib${ii}$_clacpy - pure subroutine stdlib_clacrm( m, n, a, lda, b, ldb, c, ldc, rwork ) + pure subroutine stdlib${ii}$_clacrm( m, n, a, lda, b, ldb, c, ldc, rwork ) !! CLACRM performs a very simple matrix-matrix multiplication: !! C := A * B, !! where A is M by N and complex; B is N by N and real; @@ -6745,7 +6747,7 @@ module stdlib_linalg_lapack_c ! -- 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, ldc, m, n + integer(${ik}$), intent(in) :: lda, ldb, ldc, m, n ! Array Arguments real(sp), intent(in) :: b(ldb,*) real(sp), intent(out) :: rwork(*) @@ -6754,7 +6756,7 @@ module stdlib_linalg_lapack_c ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, l + integer(${ik}$) :: i, j, l ! Intrinsic Functions intrinsic :: aimag,cmplx,real ! Executable Statements @@ -6765,8 +6767,8 @@ module stdlib_linalg_lapack_c rwork( ( j-1 )*m+i ) = real( a( i, j ),KIND=sp) end do end do - l = m*n + 1 - call stdlib_sgemm( 'N', 'N', m, n, n, one, rwork, m, b, ldb, zero,rwork( l ), m ) + l = m*n + 1_${ik}$ + call stdlib${ii}$_sgemm( 'N', 'N', m, n, n, one, rwork, m, b, ldb, zero,rwork( l ), m ) do j = 1, n do i = 1, m @@ -6778,7 +6780,7 @@ module stdlib_linalg_lapack_c rwork( ( j-1 )*m+i ) = aimag( a( i, j ) ) end do end do - call stdlib_sgemm( 'N', 'N', m, n, n, one, rwork, m, b, ldb, zero,rwork( l ), m ) + call stdlib${ii}$_sgemm( 'N', 'N', m, n, n, one, rwork, m, b, ldb, zero,rwork( l ), m ) do j = 1, n do i = 1, m @@ -6787,10 +6789,10 @@ module stdlib_linalg_lapack_c end do end do return - end subroutine stdlib_clacrm + end subroutine stdlib${ii}$_clacrm - pure subroutine stdlib_clacrt( n, cx, incx, cy, incy, c, s ) + pure subroutine stdlib${ii}$_clacrt( n, cx, incx, cy, incy, c, s ) !! CLACRT performs the operation !! ( c s )( x ) ==> ( x ) !! ( -s c )( y ) ( y ) @@ -6799,22 +6801,22 @@ module stdlib_linalg_lapack_c ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n complex(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 if( incx==1 .and. incy==1 )go to 20 ! code for unequal increments or equal increments not equal to 1 - ix = 1 - iy = 1 - if( incx<0 )ix = ( -n+1 )*incx + 1 - if( incy<0 )iy = ( -n+1 )*incy + 1 + ix = 1_${ik}$ + iy = 1_${ik}$ + if( incx<0_${ik}$ )ix = ( -n+1 )*incx + 1_${ik}$ + if( incy<0_${ik}$ )iy = ( -n+1 )*incy + 1_${ik}$ do i = 1, n ctemp = c*cx( ix ) + s*cy( iy ) cy( iy ) = c*cy( iy ) - s*cx( ix ) @@ -6831,10 +6833,10 @@ module stdlib_linalg_lapack_c cx( i ) = ctemp end do return - end subroutine stdlib_clacrt + end subroutine stdlib${ii}$_clacrt - pure complex(sp) function stdlib_cladiv( x, y ) + pure complex(sp) function stdlib${ii}$_cladiv( x, y ) !! CLADIV := X / Y, where X and Y are complex. The computation of X / Y !! will not overflow on an intermediary step unless the results !! overflows. @@ -6849,14 +6851,14 @@ module stdlib_linalg_lapack_c ! Intrinsic Functions intrinsic :: aimag,cmplx,real ! Executable Statements - call stdlib_sladiv( real( x,KIND=sp), aimag( x ), real( y,KIND=sp), aimag( y ), zr,zi ) + call stdlib${ii}$_sladiv( real( x,KIND=sp), aimag( x ), real( y,KIND=sp), aimag( y ), zr,zi ) - stdlib_cladiv = cmplx( zr, zi,KIND=sp) + stdlib${ii}$_cladiv = cmplx( zr, zi,KIND=sp) return - end function stdlib_cladiv + end function stdlib${ii}$_cladiv - pure subroutine stdlib_claed8( k, n, qsiz, q, ldq, d, rho, cutpnt, z, dlamda,q2, ldq2, w, & + pure subroutine stdlib${ii}$_claed8( k, n, qsiz, q, ldq, d, rho, cutpnt, z, dlamda,q2, ldq2, w, & !! CLAED8 merges the two sets of eigenvalues 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 @@ -6868,14 +6870,14 @@ module stdlib_linalg_lapack_c ! -- 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) :: cutpnt, ldq, ldq2, n, qsiz - integer(ilp), intent(out) :: givptr, info, k + integer(${ik}$), intent(in) :: cutpnt, ldq, ldq2, n, qsiz + integer(${ik}$), intent(out) :: givptr, info, k real(sp), intent(inout) :: rho ! Array Arguments - integer(ilp), intent(out) :: givcol(2,*), indx(*), indxp(*), perm(*) - integer(ilp), intent(inout) :: indxq(*) + integer(${ik}$), intent(out) :: givcol(2_${ik}$,*), indx(*), indxp(*), perm(*) + integer(${ik}$), intent(inout) :: indxq(*) real(sp), intent(inout) :: d(*), z(*) - real(sp), intent(out) :: dlamda(*), givnum(2,*), w(*) + real(sp), intent(out) :: dlamda(*), givnum(2_${ik}$,*), w(*) complex(sp), intent(inout) :: q(ldq,*) complex(sp), intent(out) :: q2(ldq2,*) ! ===================================================================== @@ -6883,47 +6885,47 @@ module stdlib_linalg_lapack_c real(sp), parameter :: mone = -1.0_sp ! Local Scalars - integer(ilp) :: i, imax, j, jlam, jmax, jp, k2, n1, n1p1, n2 + integer(${ik}$) :: i, imax, j, jlam, jmax, jp, k2, n1, n1p1, n2 real(sp) :: c, eps, s, t, tau, tol ! Intrinsic Functions intrinsic :: abs,max,min,sqrt ! Executable Statements ! test the input parameters. - info = 0 - if( n<0 ) then - info = -2 + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -2_${ik}$ else if( qsizn ) then - info = -8 - else if( ldq2n ) then + info = -8_${ik}$ + else if( ldq2n )go to 90 if( rho*abs( z( j ) )<=tol ) then ! deflate due to small z component. - k2 = k2 - 1 + k2 = k2 - 1_${ik}$ indxp( k2 ) = j else ! check if eigenvalues are close enough to allow deflation. @@ -6988,7 +6990,7 @@ module stdlib_linalg_lapack_c c = z( j ) ! find sqrt(a**2+b**2) without overflow or ! destructive underflow. - tau = stdlib_slapy2( c, s ) + tau = stdlib${ii}$_slapy2( c, s ) t = d( j ) - d( jlam ) c = c / tau s = -s / tau @@ -6997,24 +6999,24 @@ module stdlib_linalg_lapack_c z( j ) = tau z( jlam ) = zero ! record the appropriate givens rotation - givptr = givptr + 1 - givcol( 1, givptr ) = indxq( indx( jlam ) ) - givcol( 2, givptr ) = indxq( indx( j ) ) - givnum( 1, givptr ) = c - givnum( 2, givptr ) = s - call stdlib_csrot( qsiz, q( 1, indxq( indx( jlam ) ) ), 1,q( 1, indxq( indx( j ) & - ) ), 1, c, s ) + givptr = givptr + 1_${ik}$ + givcol( 1_${ik}$, givptr ) = indxq( indx( jlam ) ) + givcol( 2_${ik}$, givptr ) = indxq( indx( j ) ) + givnum( 1_${ik}$, givptr ) = c + givnum( 2_${ik}$, givptr ) = s + call stdlib${ii}$_csrot( qsiz, q( 1_${ik}$, indxq( indx( jlam ) ) ), 1_${ik}$,q( 1_${ik}$, indxq( indx( j ) & + ) ), 1_${ik}$, c, s ) t = d( jlam )*c*c + d( j )*s*s d( j ) = d( jlam )*s*s + d( j )*c*c d( jlam ) = t - k2 = k2 - 1 - i = 1 + k2 = k2 - 1_${ik}$ + i = 1_${ik}$ 80 continue if( k2+i<=n ) then if( d( jlam )zero )t = z*sqrt( ( t / z )**2+( b / z )**2 ) + if( z>zero )t = z*sqrt( ( t / z )**2_${ik}$+( b / z )**2_${ik}$ ) ! compute the two eigenvalues. rt1 and rt2 are exchanged ! if necessary so that rt1 will have the greater magnitude. rt1 = s + t @@ -7132,7 +7134,7 @@ module stdlib_linalg_lapack_c sn1 = ( rt1-a ) / b tabs = abs( sn1 ) if( tabs>one ) then - t = tabs*sqrt( ( one / tabs )**2+( sn1 / tabs )**2 ) + t = tabs*sqrt( ( one / tabs )**2_${ik}$+( sn1 / tabs )**2_${ik}$ ) else t = sqrt( cone+sn1*sn1 ) end if @@ -7146,10 +7148,10 @@ module stdlib_linalg_lapack_c end if end if return - end subroutine stdlib_claesy + end subroutine stdlib${ii}$_claesy - pure subroutine stdlib_claev2( a, b, c, rt1, rt2, cs1, sn1 ) + pure subroutine stdlib${ii}$_claev2( a, b, c, rt1, rt2, cs1, sn1 ) !! CLAEV2 computes the eigendecomposition of a 2-by-2 Hermitian matrix !! [ A B ] !! [ CONJG(B) C ]. @@ -7179,14 +7181,14 @@ module stdlib_linalg_lapack_c else w = conjg( b ) / abs( b ) end if - call stdlib_slaev2( real( a,KIND=sp), abs( b ), real( c,KIND=sp), rt1, rt2, cs1, t ) + call stdlib${ii}$_slaev2( real( a,KIND=sp), abs( b ), real( c,KIND=sp), rt1, rt2, cs1, t ) sn1 = w*t return - end subroutine stdlib_claev2 + end subroutine stdlib${ii}$_claev2 - pure subroutine stdlib_clag2z( m, n, sa, ldsa, a, lda, info ) + pure subroutine stdlib${ii}$_clag2z( m, n, sa, ldsa, a, lda, info ) !! CLAG2Z converts a COMPLEX matrix, SA, to a COMPLEX*16 matrix, A. !! Note that while it is possible to overflow while converting !! from double to single, it is not possible to overflow when @@ -7196,26 +7198,26 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(in) :: sa(ldsa,*) complex(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_clag2z + end subroutine stdlib${ii}$_clag2z - pure subroutine stdlib_clagtm( trans, n, nrhs, alpha, dl, d, du, x, ldx, beta,b, ldb ) + pure subroutine stdlib${ii}$_clagtm( trans, n, nrhs, alpha, dl, d, du, x, ldx, beta,b, ldb ) !! CLAGTM 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 @@ -7227,7 +7229,7 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: b(ldb,*) @@ -7235,7 +7237,7 @@ module stdlib_linalg_lapack_c ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Intrinsic Functions intrinsic :: conjg ! Executable Statements @@ -7258,10 +7260,10 @@ module stdlib_linalg_lapack_c 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 & @@ -7272,10 +7274,10 @@ module stdlib_linalg_lapack_c else if( stdlib_lsame( trans, 'T' ) ) then ! 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 & @@ -7286,10 +7288,10 @@ module stdlib_linalg_lapack_c else if( stdlib_lsame( trans, 'C' ) ) then ! compute b := b + a**h * x do j = 1, nrhs - if( n==1 ) then - b( 1, j ) = b( 1, j ) + conjg( d( 1 ) )*x( 1, j ) + if( n==1_${ik}$ ) then + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) + conjg( d( 1_${ik}$ ) )*x( 1_${ik}$, j ) else - b( 1, j ) = b( 1, j ) + conjg( d( 1 ) )*x( 1, j ) +conjg( dl( 1 ) )*x( 2, & + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) + conjg( d( 1_${ik}$ ) )*x( 1_${ik}$, j ) +conjg( dl( 1_${ik}$ ) )*x( 2_${ik}$, & j ) b( n, j ) = b( n, j ) + conjg( du( n-1 ) )*x( n-1, j ) + conjg( d( n ) )*x(& n, j ) @@ -7304,10 +7306,10 @@ module stdlib_linalg_lapack_c 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 & @@ -7318,10 +7320,10 @@ module stdlib_linalg_lapack_c else if( stdlib_lsame( trans, 'T' ) ) then ! 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 & @@ -7332,10 +7334,10 @@ module stdlib_linalg_lapack_c else if( stdlib_lsame( trans, 'C' ) ) then ! compute b := b - a**h*x do j = 1, nrhs - if( n==1 ) then - b( 1, j ) = b( 1, j ) - conjg( d( 1 ) )*x( 1, j ) + if( n==1_${ik}$ ) then + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) - conjg( d( 1_${ik}$ ) )*x( 1_${ik}$, j ) else - b( 1, j ) = b( 1, j ) - conjg( d( 1 ) )*x( 1, j ) -conjg( dl( 1 ) )*x( 2, & + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) - conjg( d( 1_${ik}$ ) )*x( 1_${ik}$, j ) -conjg( dl( 1_${ik}$ ) )*x( 2_${ik}$, & j ) b( n, j ) = b( n, j ) - conjg( du( n-1 ) )*x( n-1, j ) - conjg( d( n ) )*x(& n, j ) @@ -7348,10 +7350,10 @@ module stdlib_linalg_lapack_c end if end if return - end subroutine stdlib_clagtm + end subroutine stdlib${ii}$_clagtm - pure subroutine stdlib_clahef( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) + pure subroutine stdlib${ii}$_clahef( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) !! CLAHEF computes a partial factorization of a complex Hermitian !! matrix A using the Bunch-Kaufman diagonal pivoting method. The !! partial factorization has the form: @@ -7370,10 +7372,10 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: w(ldw,*) ! ===================================================================== @@ -7383,7 +7385,7 @@ module stdlib_linalg_lapack_c ! 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, r1, rowmax, t complex(sp) :: d11, d21, d22, z ! Intrinsic Functions @@ -7393,7 +7395,7 @@ module stdlib_linalg_lapack_c ! Statement Function Definitions cabs1( z ) = abs( real( z,KIND=sp) ) + abs( aimag( z ) ) ! 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 @@ -7407,13 +7409,13 @@ module stdlib_linalg_lapack_c kw = nb + k - n ! exit from loop if( ( k<=n-nb+1 .and. nb1 ) then - imax = stdlib_icamax( k-1, w( 1, kw ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_icamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) colmax = cabs1( w( imax, kw ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k a( k, k ) = real( a( k, k ),KIND=sp) else @@ -7443,23 +7445,23 @@ module stdlib_linalg_lapack_c else ! begin pivot search along imax row ! copy column imax to column kw-1 of w and update it - call stdlib_ccopy( imax-1, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) + call stdlib${ii}$_ccopy( imax-1, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) w( imax, kw-1 ) = real( a( imax, imax ),KIND=sp) - call stdlib_ccopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_ccopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ ) - call stdlib_clacgv( k-imax, w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_clacgv( k-imax, w( imax+1, kw-1 ), 1_${ik}$ ) if( k1 ) then - jmax = stdlib_icamax( imax-1, w( 1, kw-1 ), 1 ) + if( imax>1_${ik}$ ) then + jmax = stdlib${ii}$_icamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) rowmax = max( rowmax, cabs1( w( jmax, kw-1 ) ) ) end if ! case(2) @@ -7472,20 +7474,20 @@ module stdlib_linalg_lapack_c ! pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_ccopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) ! case(4) else ! interchange rows and columns k-1 and imax, use 2-by-2 ! pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ end if ! end pivot search along imax row end if ! end pivot search ! ============================================================ ! 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. @@ -7496,17 +7498,17 @@ module stdlib_linalg_lapack_c ! (or k and k-1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = real( a( kk, kk ),KIND=sp) - call stdlib_ccopy( kk-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - call stdlib_clacgv( kk-1-kp, a( kp, kp+1 ), lda ) - if( kp>1 )call stdlib_ccopy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_ccopy( kk-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) + call stdlib${ii}$_clacgv( kk-1-kp, a( kp, kp+1 ), lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_ccopy( 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 ! later overwritten). interchange rows kk and kp ! in last kkw to nb columns of w. - if( k1 ) then + call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) + if( k>1_${ik}$ ) then ! (note: no need to check if a(k,k) is not zero, ! since that was ensured earlier in pivot search: ! case a(k,k) = 0 falls into 2x2 pivot case(4)) r1 = one / real( a( k, k ),KIND=sp) - call stdlib_csscal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_csscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) ! (2) conjugate column w(kw) - call stdlib_clacgv( k-1, w( 1, kw ), 1 ) + call stdlib${ii}$_clacgv( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) end if else ! 2-by-2 pivot block d(k): columns kw and kw-1 of w now hold @@ -7541,7 +7543,7 @@ module stdlib_linalg_lapack_c ! a(k-1:k,k-1:k) := d(k-1:k,k-1:k) = w(k-1:k,kw-1:kw) ! a(1:k-2,k-1:k) := u(1:k-2,k:k-1:k) = ! = w(1:k-2,kw-1:kw) * ( d(k-1:k,k-1:k)**(-1) ) - if( k>2 ) then + if( k>2_${ik}$ ) then ! factor out the columns of the inverse of 2-by-2 pivot ! block d, so that each column contains 1, to reduce the ! number of flops when we multiply panel @@ -7590,12 +7592,12 @@ module stdlib_linalg_lapack_c a( k-1, k ) = w( k-1, kw ) a( k, k ) = w( k, kw ) ! (2) conjugate columns w(kw) and w(kw-1) - call stdlib_clacgv( k-1, w( 1, kw ), 1 ) - call stdlib_clacgv( k-2, w( 1, kw-1 ), 1 ) + call stdlib${ii}$_clacgv( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) + call stdlib${ii}$_clacgv( k-2, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) 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 @@ -7614,32 +7616,32 @@ module stdlib_linalg_lapack_c ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 a( jj, jj ) = real( a( jj, jj ),KIND=sp) - call stdlib_cgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& - kw+1 ), ldw, cone,a( j, jj ), 1 ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& + kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ ) a( jj, jj ) = real( a( jj, jj ),KIND=sp) end do ! update the rectangular superdiagonal block - call stdlib_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( 1, k+1 ), & - lda, w( j, kw+1 ), ldw,cone, a( 1, j ), lda ) + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( 1_${ik}$, k+1 ), & + lda, w( j, kw+1 ), ldw,cone, a( 1_${ik}$, j ), lda ) end do ! put u12 in standard form by partially undoing the interchanges ! in of rows 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 j 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_cswap( n-j+1, a( jp, j ), lda, a( jj, j ), & + j = j + 1_${ik}$ + if( jp/=jj .and. j<=n )call stdlib${ii}$_cswap( n-j+1, a( jp, j ), lda, a( jj, j ), & lda ) if( j<=n )go to 60 ! set kb to the number of columns factorized @@ -7649,16 +7651,16 @@ module stdlib_linalg_lapack_c ! of a and working forwards, and compute the matrix w = l21*d ! for use in updating a22 (note that conjg(w) is actually stored) ! k is the main loop index, increasing from 1 in steps of 1 or 2 - k = 1 + k = 1_${ik}$ 70 continue ! exit from loop if( ( k>=nb .and. nbn )go to 90 - kstep = 1 + kstep = 1_${ik}$ ! copy column k of a to column k of w and update it w( k, k ) = real( a( k, k ),KIND=sp) - if( k1 )call stdlib_cswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_cswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + if( k>1_${ik}$ )call stdlib${ii}$_cswap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) + call stdlib${ii}$_cswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of w now holds ! w(k) = l(k)*d(k), ! where l(k) is the k-th column of l @@ -7760,15 +7762,15 @@ module stdlib_linalg_lapack_c ! (note: no need to use for hermitian matrix ! a( k, k ) = real( w( k, k),KIND=sp) to separately copy diagonal ! element d(k,k) from w (potentially saves only one load)) - call stdlib_ccopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib${ii}$_ccopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ ) if( k=1 )call stdlib_cswap( j, a( jp, 1 ), lda, a( jj, 1 ), lda ) + j = j - 1_${ik}$ + if( jp/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_cswap( 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_clahef + end subroutine stdlib${ii}$_clahef - pure subroutine stdlib_clahef_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info ) + pure subroutine stdlib${ii}$_clahef_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info ) !! CLAHEF_RK computes a partial factorization of a complex Hermitian !! matrix A using the bounded Bunch-Kaufman (rook) diagonal !! pivoting method. The partial factorization has the form: @@ -7908,10 +7910,10 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: w(ldw,*), e(*) ! ===================================================================== @@ -7922,7 +7924,7 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: done - integer(ilp) :: imax, itemp, ii, j, jb, jj, jmax, k, kk, kkw, kp, kstep, kw, p + integer(${ik}$) :: imax, itemp, ii, j, jb, jj, jmax, k, kk, kkw, kp, kstep, kw, p real(sp) :: absakk, alpha, colmax, stemp, r1, rowmax, t, sfmin complex(sp) :: d11, d21, d22, z ! Intrinsic Functions @@ -7932,18 +7934,18 @@ module stdlib_linalg_lapack_c ! Statement Function Definitions cabs1( z ) = abs( real( z,KIND=sp) ) + abs( aimag( z ) ) ! 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 (note that conjg(w) is actually stored) ! initialize the first entry of array e, where superdiagonal ! elements of d are stored - e( 1 ) = czero + e( 1_${ik}$ ) = czero ! k is the main loop index, decreasing from n in steps of 1 or 2 k = n 10 continue @@ -7951,14 +7953,14 @@ module stdlib_linalg_lapack_c kw = nb + k - n ! exit from loop if( ( k<=n-nb+1 .and. nb1 )call stdlib_ccopy( k-1, a( 1, k ), 1, w( 1, kw ), 1 ) + if( k>1_${ik}$ )call stdlib${ii}$_ccopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) w( k, kw ) = real( a( k, k ),KIND=sp) if( k1 ) then - imax = stdlib_icamax( k-1, w( 1, kw ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_icamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) colmax = cabs1( w( imax, kw ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k a( k, k ) = real( w( k, kw ),KIND=sp) - if( k>1 )call stdlib_ccopy( k-1, w( 1, kw ), 1, a( 1, k ), 1 ) + if( k>1_${ik}$ )call stdlib${ii}$_ccopy( k-1, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) ! set e( k ) to zero - if( k>1 )e( k ) = czero + if( k>1_${ik}$ )e( k ) = czero else ! ============================================================ ! begin pivot search @@ -7996,28 +7998,28 @@ module stdlib_linalg_lapack_c 12 continue ! begin pivot search loop body ! copy column imax to column kw-1 of w and update it - if( imax>1 )call stdlib_ccopy( imax-1, a( 1, imax ), 1, w( 1, kw-1 ),1 ) + if( imax>1_${ik}$ )call stdlib${ii}$_ccopy( imax-1, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ),1_${ik}$ ) w( imax, kw-1 ) = real( a( imax, imax ),KIND=sp) - call stdlib_ccopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_ccopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ ) - call stdlib_clacgv( k-imax, w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_clacgv( k-imax, w( imax+1, kw-1 ), 1_${ik}$ ) if( k1 ) then - itemp = stdlib_icamax( imax-1, w( 1, kw-1 ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_icamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) stemp = cabs1( w( itemp, kw-1 ) ) if( stemp>rowmax ) then rowmax = stemp @@ -8034,7 +8036,7 @@ module stdlib_linalg_lapack_c ! use 1-by-1 pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_ccopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) done = .true. ! case(3) ! equivalent to testing for rowmax==colmax, @@ -8043,7 +8045,7 @@ module stdlib_linalg_lapack_c ! interchange rows and columns k-1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. ! case(4) else @@ -8052,7 +8054,7 @@ module stdlib_linalg_lapack_c colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_ccopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) end if ! end pivot search loop body if( .not.done ) goto 12 @@ -8060,26 +8062,26 @@ module stdlib_linalg_lapack_c ! end pivot search ! ============================================================ ! 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 p and k. ! updated column p is already stored in column kw of w. - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p of submatrix a ! at step k. no need to copy element into columns ! k and k-1 of a for 2-by-2 pivot, since these columns ! will be later overwritten. a( p, p ) = real( a( k, k ),KIND=sp) - call stdlib_ccopy( k-1-p, a( p+1, k ), 1, a( p, p+1 ),lda ) - call stdlib_clacgv( k-1-p, a( p, p+1 ), lda ) - if( p>1 )call stdlib_ccopy( p-1, a( 1, k ), 1, a( 1, p ), 1 ) + call stdlib${ii}$_ccopy( k-1-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda ) + call stdlib${ii}$_clacgv( k-1-p, a( p, p+1 ), lda ) + if( p>1_${ik}$ )call stdlib${ii}$_ccopy( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) ! interchange rows k and p in the last k+1 to n columns of a ! (columns k and k-1 of a for 2-by-2 pivot will be ! later overwritten). interchange rows k and p ! in last kkw to nb columns of w. - if( k1 )call stdlib_ccopy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_ccopy( kk-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) + call stdlib${ii}$_clacgv( kk-1-kp, a( kp, kp+1 ), lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_ccopy( 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 ! later overwritten). interchange rows kk and kp ! in last kkw to nb columns of w. - if( k1 ) then + call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) + if( k>1_${ik}$ ) then ! (note: no need to check if a(k,k) is not zero, ! since that was ensured earlier in pivot search: ! case a(k,k) = 0 falls into 2x2 pivot case(3)) @@ -8121,14 +8123,14 @@ module stdlib_linalg_lapack_c t = real( a( k, k ),KIND=sp) if( abs( t )>=sfmin ) then r1 = one / t - call stdlib_csscal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_csscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) else do ii = 1, k-1 a( ii, k ) = a( ii, k ) / t end do end if ! (2) conjugate column w(kw) - call stdlib_clacgv( k-1, w( 1, kw ), 1 ) + call stdlib${ii}$_clacgv( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) ! store the superdiagonal element of d in array e e( k ) = czero end if @@ -8144,7 +8146,7 @@ module stdlib_linalg_lapack_c ! a(k-1:k,k-1:k) := d(k-1:k,k-1:k) = w(k-1:k,kw-1:kw) ! a(1:k-2,k-1:k) := u(1:k-2,k:k-1:k) = ! = w(1:k-2,kw-1:kw) * ( d(k-1:k,k-1:k)**(-1) ) - if( k>2 ) then + if( k>2_${ik}$ ) then ! factor out the columns of the inverse of 2-by-2 pivot ! block d, so that each column contains 1, to reduce the ! number of flops when we multiply panel @@ -8198,13 +8200,13 @@ module stdlib_linalg_lapack_c e( k ) = w( k-1, kw ) e( k-1 ) = czero ! (2) conjugate columns w(kw) and w(kw-1) - call stdlib_clacgv( k-1, w( 1, kw ), 1 ) - call stdlib_clacgv( k-2, w( 1, kw-1 ), 1 ) + call stdlib${ii}$_clacgv( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) + call stdlib${ii}$_clacgv( k-2, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) end if ! 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 @@ -8223,13 +8225,13 @@ module stdlib_linalg_lapack_c ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 a( jj, jj ) = real( a( jj, jj ),KIND=sp) - call stdlib_cgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& - kw+1 ), ldw, cone,a( j, jj ), 1 ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& + kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ ) a( jj, jj ) = real( a( jj, jj ),KIND=sp) end do ! update the rectangular superdiagonal block - if( j>=2 )call stdlib_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( & - 1, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1, j ), lda ) + if( j>=2_${ik}$ )call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( & + 1_${ik}$, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1_${ik}$, j ), lda ) end do ! set kb to the number of columns factorized kb = n - k @@ -8240,18 +8242,18 @@ module stdlib_linalg_lapack_c ! initialize the unused last entry of the subdiagonal array e. e( n ) = czero ! k is the main loop index, increasing from 1 in steps of 1 or 2 - k = 1 + 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 column k of w w( k, k ) = real( a( k, k ),KIND=sp) - if( k1 ) then - call stdlib_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ),lda, w( k, 1 ), & - ldw, cone, w( k, k ), 1 ) + if( k1_${ik}$ ) then + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ),lda, w( k, 1_${ik}$ ), & + ldw, cone, w( k, k ), 1_${ik}$ ) w( k, k ) = real( w( k, k ),KIND=sp) end if ! determine rows and columns to be interchanged and whether @@ -8261,17 +8263,17 @@ module stdlib_linalg_lapack_c ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k1 ) then - call stdlib_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1 ), lda, w( & - imax, 1 ), ldw,cone, w( k, k+1 ), 1 ) + if( imax1_${ik}$ ) then + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1_${ik}$ ), lda, w( & + imax, 1_${ik}$ ), ldw,cone, w( k, k+1 ), 1_${ik}$ ) w( imax, k+1 ) = real( w( imax, k+1 ),KIND=sp) end if ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = k - 1 + stdlib_icamax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1_${ik}$ + stdlib${ii}$_icamax( imax-k, w( k, k+1 ), 1_${ik}$ ) rowmax = cabs1( w( jmax, k+1 ) ) else rowmax = zero end if if( imaxrowmax ) then rowmax = stemp @@ -8326,7 +8328,7 @@ module stdlib_linalg_lapack_c ! use 1-by-1 pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_ccopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_ccopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) done = .true. ! case(3) ! equivalent to testing for rowmax==colmax, @@ -8335,7 +8337,7 @@ module stdlib_linalg_lapack_c ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. ! case(4) else @@ -8344,7 +8346,7 @@ module stdlib_linalg_lapack_c colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_ccopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_ccopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) end if ! end pivot search loop body if( .not.done ) goto 72 @@ -8352,24 +8354,24 @@ module stdlib_linalg_lapack_c ! end pivot search ! ============================================================ ! kk is the column of a where pivoting step stopped - kk = k + kstep - 1 + kk = k + kstep - 1_${ik}$ ! interchange rows and columns p and k (only for 2-by-2 pivot). ! updated column p is already stored in column k of w. - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column kk-1 to column p of submatrix a ! at step k. no need to copy element into columns ! k and k+1 of a for 2-by-2 pivot, since these columns ! will be later overwritten. a( p, p ) = real( a( k, k ),KIND=sp) - call stdlib_ccopy( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) - call stdlib_clacgv( p-k-1, a( p, k+1 ), lda ) - if( p1 )call stdlib_cswap( k-1, a( k, 1 ), lda, a( p, 1 ), lda ) - call stdlib_cswap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw ) + if( k>1_${ik}$ )call stdlib${ii}$_cswap( k-1, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda ) + call stdlib${ii}$_cswap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw ) end if ! interchange rows and columns kp and kk. ! updated column kp is already stored in column kk of w. @@ -8379,18 +8381,18 @@ module stdlib_linalg_lapack_c ! (or k and k+1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = real( a( kk, kk ),KIND=sp) - call stdlib_ccopy( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),lda ) - call stdlib_clacgv( kp-kk-1, a( kp, kk+1 ), lda ) - if( kp1 )call stdlib_cswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_cswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + if( k>1_${ik}$ )call stdlib${ii}$_cswap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) + call stdlib${ii}$_cswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of w now holds ! w(k) = l(k)*d(k), ! where l(k) is the k-th column of l @@ -8403,7 +8405,7 @@ module stdlib_linalg_lapack_c ! (note: no need to use for hermitian matrix ! a( k, k ) = real( w( k, k),KIND=sp) to separately copy diagonal ! element d(k,k) from w (potentially saves only one load)) - call stdlib_ccopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib${ii}$_ccopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ ) if( k=sfmin ) then r1 = one / t - call stdlib_csscal( n-k, r1, a( k+1, k ), 1 ) + call stdlib${ii}$_csscal( n-k, r1, a( k+1, k ), 1_${ik}$ ) else do ii = k + 1, n a( ii, k ) = a( ii, k ) / t end do end if ! (2) conjugate column w(k) - call stdlib_clacgv( n-k, w( k+1, k ), 1 ) + call stdlib${ii}$_clacgv( n-k, w( k+1, k ), 1_${ik}$ ) ! store the subdiagonal element of d in array e e( k ) = czero end if @@ -8489,13 +8491,13 @@ module stdlib_linalg_lapack_c e( k ) = w( k+1, k ) e( k+1 ) = czero ! (2) conjugate columns w(k) and w(k+1) - call stdlib_clacgv( n-k, w( k+1, k ), 1 ) - call stdlib_clacgv( n-k-1, w( k+2, k+1 ), 1 ) + call stdlib${ii}$_clacgv( n-k, w( k+1, k ), 1_${ik}$ ) + call stdlib${ii}$_clacgv( n-k-1, w( k+2, k+1 ), 1_${ik}$ ) end if ! 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 @@ -8514,22 +8516,22 @@ module stdlib_linalg_lapack_c ! update the lower triangle of the diagonal block do jj = j, j + jb - 1 a( jj, jj ) = real( a( jj, jj ),KIND=sp) - call stdlib_cgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1 ), lda, w( jj,& - 1 ), ldw, cone,a( jj, jj ), 1 ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1_${ik}$ ), lda, w( jj,& + 1_${ik}$ ), ldw, cone,a( jj, jj ), 1_${ik}$ ) a( jj, jj ) = real( a( jj, jj ),KIND=sp) end do ! update the rectangular subdiagonal block - if( j+jb<=n )call stdlib_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& - cone, a( j+jb, 1 ), lda, w( j, 1 ),ldw, cone, a( j+jb, j ), lda ) + if( j+jb<=n )call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& + cone, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ),ldw, cone, a( j+jb, j ), lda ) end do ! set kb to the number of columns factorized - kb = k - 1 + kb = k - 1_${ik}$ end if return - end subroutine stdlib_clahef_rk + end subroutine stdlib${ii}$_clahef_rk - pure subroutine stdlib_clahef_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) + pure subroutine stdlib${ii}$_clahef_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) !! CLAHEF_ROOK computes a partial factorization of a complex Hermitian !! matrix A using the bounded Bunch-Kaufman ("rook") diagonal pivoting !! method. The partial factorization has the form: @@ -8548,10 +8550,10 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: w(ldw,*) ! ===================================================================== @@ -8562,7 +8564,7 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: done - integer(ilp) :: imax, itemp, ii, j, jb, jj, jmax, jp1, jp2, k, kk, kkw, kp, kstep, kw, & + integer(${ik}$) :: imax, itemp, ii, j, jb, jj, jmax, jp1, jp2, k, kk, kkw, kp, kstep, kw, & p real(sp) :: absakk, alpha, colmax, stemp, r1, rowmax, t, sfmin complex(sp) :: d11, d21, d22, z @@ -8573,11 +8575,11 @@ module stdlib_linalg_lapack_c ! Statement Function Definitions cabs1( z ) = abs( real( z,KIND=sp) ) + abs( aimag( z ) ) ! 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 @@ -8589,14 +8591,14 @@ module stdlib_linalg_lapack_c kw = nb + k - n ! exit from loop if( ( k<=n-nb+1 .and. nb1 )call stdlib_ccopy( k-1, a( 1, k ), 1, w( 1, kw ), 1 ) + if( k>1_${ik}$ )call stdlib${ii}$_ccopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) w( k, kw ) = real( a( k, k ),KIND=sp) if( k1 ) then - imax = stdlib_icamax( k-1, w( 1, kw ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_icamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) colmax = cabs1( w( imax, kw ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k a( k, k ) = real( w( k, kw ),KIND=sp) - if( k>1 )call stdlib_ccopy( k-1, w( 1, kw ), 1, a( 1, k ), 1 ) + if( k>1_${ik}$ )call stdlib${ii}$_ccopy( k-1, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) else ! ============================================================ ! begin pivot search @@ -8632,28 +8634,28 @@ module stdlib_linalg_lapack_c 12 continue ! begin pivot search loop body ! copy column imax to column kw-1 of w and update it - if( imax>1 )call stdlib_ccopy( imax-1, a( 1, imax ), 1, w( 1, kw-1 ),1 ) + if( imax>1_${ik}$ )call stdlib${ii}$_ccopy( imax-1, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ),1_${ik}$ ) w( imax, kw-1 ) = real( a( imax, imax ),KIND=sp) - call stdlib_ccopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_ccopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ ) - call stdlib_clacgv( k-imax, w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_clacgv( k-imax, w( imax+1, kw-1 ), 1_${ik}$ ) if( k1 ) then - itemp = stdlib_icamax( imax-1, w( 1, kw-1 ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_icamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) stemp = cabs1( w( itemp, kw-1 ) ) if( stemp>rowmax ) then rowmax = stemp @@ -8670,7 +8672,7 @@ module stdlib_linalg_lapack_c ! use 1-by-1 pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_ccopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) done = .true. ! case(3) ! equivalent to testing for rowmax==colmax, @@ -8679,7 +8681,7 @@ module stdlib_linalg_lapack_c ! interchange rows and columns k-1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. ! case(4) else @@ -8688,7 +8690,7 @@ module stdlib_linalg_lapack_c colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_ccopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) end if ! end pivot search loop body if( .not.done ) goto 12 @@ -8696,26 +8698,26 @@ module stdlib_linalg_lapack_c ! end pivot search ! ============================================================ ! 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 p and k. ! updated column p is already stored in column kw of w. - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p of submatrix a ! at step k. no need to copy element into columns ! k and k-1 of a for 2-by-2 pivot, since these columns ! will be later overwritten. a( p, p ) = real( a( k, k ),KIND=sp) - call stdlib_ccopy( k-1-p, a( p+1, k ), 1, a( p, p+1 ),lda ) - call stdlib_clacgv( k-1-p, a( p, p+1 ), lda ) - if( p>1 )call stdlib_ccopy( p-1, a( 1, k ), 1, a( 1, p ), 1 ) + call stdlib${ii}$_ccopy( k-1-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda ) + call stdlib${ii}$_clacgv( k-1-p, a( p, p+1 ), lda ) + if( p>1_${ik}$ )call stdlib${ii}$_ccopy( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) ! interchange rows k and p in the last k+1 to n columns of a ! (columns k and k-1 of a for 2-by-2 pivot will be ! later overwritten). interchange rows k and p ! in last kkw to nb columns of w. - if( k1 )call stdlib_ccopy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_ccopy( kk-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) + call stdlib${ii}$_clacgv( kk-1-kp, a( kp, kp+1 ), lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_ccopy( 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 ! later overwritten). interchange rows kk and kp ! in last kkw to nb columns of w. - if( k1 ) then + call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) + if( k>1_${ik}$ ) then ! (note: no need to check if a(k,k) is not zero, ! since that was ensured earlier in pivot search: ! case a(k,k) = 0 falls into 2x2 pivot case(3)) @@ -8757,14 +8759,14 @@ module stdlib_linalg_lapack_c t = real( a( k, k ),KIND=sp) if( abs( t )>=sfmin ) then r1 = one / t - call stdlib_csscal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_csscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) else do ii = 1, k-1 a( ii, k ) = a( ii, k ) / t end do end if ! (2) conjugate column w(kw) - call stdlib_clacgv( k-1, w( 1, kw ), 1 ) + call stdlib${ii}$_clacgv( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) end if else ! 2-by-2 pivot block d(k): columns kw and kw-1 of w now hold @@ -8778,7 +8780,7 @@ module stdlib_linalg_lapack_c ! a(k-1:k,k-1:k) := d(k-1:k,k-1:k) = w(k-1:k,kw-1:kw) ! a(1:k-2,k-1:k) := u(1:k-2,k:k-1:k) = ! = w(1:k-2,kw-1:kw) * ( d(k-1:k,k-1:k)**(-1) ) - if( k>2 ) then + if( k>2_${ik}$ ) then ! factor out the columns of the inverse of 2-by-2 pivot ! block d, so that each column contains 1, to reduce the ! number of flops when we multiply panel @@ -8828,12 +8830,12 @@ module stdlib_linalg_lapack_c a( k-1, k ) = w( k-1, kw ) a( k, k ) = w( k, kw ) ! (2) conjugate columns w(kw) and w(kw-1) - call stdlib_clacgv( k-1, w( 1, kw ), 1 ) - call stdlib_clacgv( k-2, w( 1, kw-1 ), 1 ) + call stdlib${ii}$_clacgv( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) + call stdlib${ii}$_clacgv( k-2, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) 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 @@ -8852,39 +8854,39 @@ module stdlib_linalg_lapack_c ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 a( jj, jj ) = real( a( jj, jj ),KIND=sp) - call stdlib_cgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& - kw+1 ), ldw, cone,a( j, jj ), 1 ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& + kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ ) a( jj, jj ) = real( a( jj, jj ),KIND=sp) end do ! update the rectangular superdiagonal block - if( j>=2 )call stdlib_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( & - 1, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1, j ), lda ) + if( j>=2_${ik}$ )call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( & + 1_${ik}$, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1_${ik}$, j ), lda ) end do ! put u12 in standard form by partially undoing the interchanges ! in of rows 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 j and jp2 ! (or j and jp2, and j+1 and jp1) at each step j - kstep = 1 - jp1 = 1 + kstep = 1_${ik}$ + jp1 = 1_${ik}$ ! (here, j is a diagonal index) jj = j jp2 = ipiv( j ) - if( jp2<0 ) then + if( jp2<0_${ik}$ ) then jp2 = -jp2 ! (here, j is a diagonal index) - j = j + 1 + j = j + 1_${ik}$ jp1 = -ipiv( j ) - kstep = 2 + kstep = 2_${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( jp2/=jj .and. j<=n )call stdlib_cswap( n-j+1, a( jp2, j ), lda, a( jj, j ), & + j = j + 1_${ik}$ + if( jp2/=jj .and. j<=n )call stdlib${ii}$_cswap( n-j+1, a( jp2, j ), lda, a( jj, j ), & lda ) - jj = jj + 1 - if( kstep==2 .and. jp1/=jj .and. j<=n )call stdlib_cswap( n-j+1, a( jp1, j ), & + jj = jj + 1_${ik}$ + if( kstep==2_${ik}$ .and. jp1/=jj .and. j<=n )call stdlib${ii}$_cswap( n-j+1, a( jp1, j ), & lda, a( jj, j ), lda ) if( j=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 column k of w w( k, k ) = real( a( k, k ),KIND=sp) - if( k1 ) then - call stdlib_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ),lda, w( k, 1 ), & - ldw, cone, w( k, k ), 1 ) + if( k1_${ik}$ ) then + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ),lda, w( k, 1_${ik}$ ), & + ldw, cone, w( k, k ), 1_${ik}$ ) w( k, k ) = real( w( k, k ),KIND=sp) end if ! determine rows and columns to be interchanged and whether @@ -8915,17 +8917,17 @@ module stdlib_linalg_lapack_c ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k1 ) then - call stdlib_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1 ), lda, w( & - imax, 1 ), ldw,cone, w( k, k+1 ), 1 ) + if( imax1_${ik}$ ) then + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1_${ik}$ ), lda, w( & + imax, 1_${ik}$ ), ldw,cone, w( k, k+1 ), 1_${ik}$ ) w( imax, k+1 ) = real( w( imax, k+1 ),KIND=sp) end if ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = k - 1 + stdlib_icamax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1_${ik}$ + stdlib${ii}$_icamax( imax-k, w( k, k+1 ), 1_${ik}$ ) rowmax = cabs1( w( jmax, k+1 ) ) else rowmax = zero end if if( imaxrowmax ) then rowmax = stemp @@ -8978,7 +8980,7 @@ module stdlib_linalg_lapack_c ! use 1-by-1 pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_ccopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_ccopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) done = .true. ! case(3) ! equivalent to testing for rowmax==colmax, @@ -8987,7 +8989,7 @@ module stdlib_linalg_lapack_c ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. ! case(4) else @@ -8996,7 +8998,7 @@ module stdlib_linalg_lapack_c colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_ccopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_ccopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) end if ! end pivot search loop body if( .not.done ) goto 72 @@ -9004,24 +9006,24 @@ module stdlib_linalg_lapack_c ! end pivot search ! ============================================================ ! kk is the column of a where pivoting step stopped - kk = k + kstep - 1 + kk = k + kstep - 1_${ik}$ ! interchange rows and columns p and k (only for 2-by-2 pivot). ! updated column p is already stored in column k of w. - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column kk-1 to column p of submatrix a ! at step k. no need to copy element into columns ! k and k+1 of a for 2-by-2 pivot, since these columns ! will be later overwritten. a( p, p ) = real( a( k, k ),KIND=sp) - call stdlib_ccopy( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) - call stdlib_clacgv( p-k-1, a( p, k+1 ), lda ) - if( p1 )call stdlib_cswap( k-1, a( k, 1 ), lda, a( p, 1 ), lda ) - call stdlib_cswap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw ) + if( k>1_${ik}$ )call stdlib${ii}$_cswap( k-1, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda ) + call stdlib${ii}$_cswap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw ) end if ! interchange rows and columns kp and kk. ! updated column kp is already stored in column kk of w. @@ -9031,18 +9033,18 @@ module stdlib_linalg_lapack_c ! (or k and k+1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = real( a( kk, kk ),KIND=sp) - call stdlib_ccopy( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),lda ) - call stdlib_clacgv( kp-kk-1, a( kp, kk+1 ), lda ) - if( kp1 )call stdlib_cswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_cswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + if( k>1_${ik}$ )call stdlib${ii}$_cswap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) + call stdlib${ii}$_cswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of w now holds ! w(k) = l(k)*d(k), ! where l(k) is the k-th column of l @@ -9055,7 +9057,7 @@ module stdlib_linalg_lapack_c ! (note: no need to use for hermitian matrix ! a( k, k ) = real( w( k, k),KIND=sp) to separately copy diagonal ! element d(k,k) from w (potentially saves only one load)) - call stdlib_ccopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib${ii}$_ccopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ ) if( k=sfmin ) then r1 = one / t - call stdlib_csscal( n-k, r1, a( k+1, k ), 1 ) + call stdlib${ii}$_csscal( n-k, r1, a( k+1, k ), 1_${ik}$ ) else do ii = k + 1, n a( ii, k ) = a( ii, k ) / t end do end if ! (2) conjugate column w(k) - call stdlib_clacgv( n-k, w( k+1, k ), 1 ) + call stdlib${ii}$_clacgv( n-k, w( k+1, k ), 1_${ik}$ ) end if else ! 2-by-2 pivot block d(k): columns k and k+1 of w now hold @@ -9135,12 +9137,12 @@ module stdlib_linalg_lapack_c a( k+1, k ) = w( k+1, k ) a( k+1, k+1 ) = w( k+1, k+1 ) ! (2) conjugate columns w(k) and w(k+1) - call stdlib_clacgv( n-k, w( k+1, k ), 1 ) - call stdlib_clacgv( n-k-1, w( k+2, k+1 ), 1 ) + call stdlib${ii}$_clacgv( n-k, w( k+1, k ), 1_${ik}$ ) + call stdlib${ii}$_clacgv( n-k-1, w( k+2, k+1 ), 1_${ik}$ ) 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 @@ -9159,49 +9161,49 @@ module stdlib_linalg_lapack_c ! update the lower triangle of the diagonal block do jj = j, j + jb - 1 a( jj, jj ) = real( a( jj, jj ),KIND=sp) - call stdlib_cgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1 ), lda, w( jj,& - 1 ), ldw, cone,a( jj, jj ), 1 ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1_${ik}$ ), lda, w( jj,& + 1_${ik}$ ), ldw, cone,a( jj, jj ), 1_${ik}$ ) a( jj, jj ) = real( a( jj, jj ),KIND=sp) end do ! update the rectangular subdiagonal block - if( j+jb<=n )call stdlib_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& - cone, a( j+jb, 1 ), lda, w( j, 1 ),ldw, cone, a( j+jb, j ), lda ) + if( j+jb<=n )call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& + cone, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ),ldw, cone, a( j+jb, j ), lda ) end do ! put l21 in standard form by partially undoing the interchanges ! of rows in columns 1:k-1 looping backwards from k-1 to 1 - j = k - 1 + j = k - 1_${ik}$ 120 continue ! undo the interchanges (if any) of rows j and jp2 ! (or j and jp2, and j-1 and jp1) at each step j - kstep = 1 - jp1 = 1 + kstep = 1_${ik}$ + jp1 = 1_${ik}$ ! (here, j is a diagonal index) jj = j jp2 = ipiv( j ) - if( jp2<0 ) then + if( jp2<0_${ik}$ ) then jp2 = -jp2 ! (here, j is a diagonal index) - j = j - 1 + j = j - 1_${ik}$ jp1 = -ipiv( j ) - kstep = 2 + kstep = 2_${ik}$ end if ! (note: here, j is used to determine row length. length j ! of the rows to swap back doesn't include diagonal element) - j = j - 1 - if( jp2/=jj .and. j>=1 )call stdlib_cswap( j, a( jp2, 1 ), lda, a( jj, 1 ), lda ) + j = j - 1_${ik}$ + if( jp2/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_cswap( j, a( jp2, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda ) - jj = jj -1 - if( kstep==2 .and. jp1/=jj .and. j>=1 )call stdlib_cswap( j, a( jp1, 1 ), lda, a(& - jj, 1 ), lda ) + jj = jj -1_${ik}$ + if( kstep==2_${ik}$ .and. jp1/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_cswap( j, a( jp1, 1_${ik}$ ), lda, a(& + jj, 1_${ik}$ ), lda ) if( j>1 )go to 120 ! set kb to the number of columns factorized - kb = k - 1 + kb = k - 1_${ik}$ end if return - end subroutine stdlib_clahef_rook + end subroutine stdlib${ii}$_clahef_rook - pure subroutine stdlib_claic1( job, j, x, sest, w, gamma, sestpr, s, c ) + pure subroutine stdlib${ii}$_claic1( job, j, x, sest, w, gamma, sestpr, s, c ) !! CLAIC1 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 @@ -9226,7 +9228,7 @@ module stdlib_linalg_lapack_c ! -- 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(in) :: sest real(sp), intent(out) :: sestpr complex(sp), intent(out) :: c, s @@ -9243,12 +9245,12 @@ module stdlib_linalg_lapack_c ! Intrinsic Functions intrinsic :: abs,conjg,max,sqrt ! Executable Statements - eps = stdlib_slamch( 'EPSILON' ) - alpha = stdlib_cdotc( j, x, 1, w, 1 ) + eps = stdlib${ii}$_slamch( 'EPSILON' ) + alpha = stdlib${ii}$_cdotc( 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 @@ -9324,7 +9326,7 @@ module stdlib_linalg_lapack_c 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 @@ -9414,10 +9416,10 @@ module stdlib_linalg_lapack_c end if end if return - end subroutine stdlib_claic1 + end subroutine stdlib${ii}$_claic1 - pure subroutine stdlib_clapmr( forwrd, m, n, x, ldx, k ) + pure subroutine stdlib${ii}$_clapmr( forwrd, m, n, x, ldx, k ) !! CLAPMR rearranges the rows of the M by N matrix X as specified !! by the permutation K(1),K(2),...,K(M) of the integers 1,...,M. !! If FORWRD = .TRUE., forward permutation: @@ -9429,13 +9431,13 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(inout) :: x(ldx,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, in, j, jj + integer(${ik}$) :: i, in, j, jj complex(sp) :: temp ! Executable Statements if( m<=1 )return @@ -9482,10 +9484,10 @@ module stdlib_linalg_lapack_c end do end if return - end subroutine stdlib_clapmr + end subroutine stdlib${ii}$_clapmr - pure subroutine stdlib_clapmt( forwrd, m, n, x, ldx, k ) + pure subroutine stdlib${ii}$_clapmt( forwrd, m, n, x, ldx, k ) !! CLAPMT rearranges the columns of the M by N matrix X as specified !! by the permutation K(1),K(2),...,K(N) of the integers 1,...,N. !! If FORWRD = .TRUE., forward permutation: @@ -9497,13 +9499,13 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(inout) :: x(ldx,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ii, j, in + integer(${ik}$) :: i, ii, j, in complex(sp) :: temp ! Executable Statements if( n<=1 )return @@ -9550,10 +9552,10 @@ module stdlib_linalg_lapack_c end do end if return - end subroutine stdlib_clapmt + end subroutine stdlib${ii}$_clapmt - pure subroutine stdlib_claqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) + pure subroutine stdlib${ii}$_claqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) !! CLAQGB 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. @@ -9563,7 +9565,7 @@ module stdlib_linalg_lapack_c ! -- 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(in) :: c(*), r(*) @@ -9573,18 +9575,18 @@ module stdlib_linalg_lapack_c 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 @@ -9620,10 +9622,10 @@ module stdlib_linalg_lapack_c equed = 'B' end if return - end subroutine stdlib_claqgb + end subroutine stdlib${ii}$_claqgb - pure subroutine stdlib_claqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed ) + pure subroutine stdlib${ii}$_claqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed ) !! CLAQGE equilibrates a general M by N matrix A using the row and !! column scaling factors in the vectors R and C. ! -- lapack auxiliary routine -- @@ -9631,7 +9633,7 @@ module stdlib_linalg_lapack_c ! -- 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(in) :: c(*), r(*) @@ -9641,16 +9643,16 @@ module stdlib_linalg_lapack_c 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 @@ -9686,10 +9688,10 @@ module stdlib_linalg_lapack_c equed = 'B' end if return - end subroutine stdlib_claqge + end subroutine stdlib${ii}$_claqge - pure subroutine stdlib_claqhb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_claqhb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) !! CLAQHB equilibrates an Hermitian band matrix A using the scaling !! factors in the vector S. ! -- lapack auxiliary routine -- @@ -9698,7 +9700,7 @@ module stdlib_linalg_lapack_c ! 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(out) :: s(*) @@ -9708,18 +9710,18 @@ module stdlib_linalg_lapack_c 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,real ! 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 @@ -9739,19 +9741,19 @@ module stdlib_linalg_lapack_c ! lower triangle of a is stored. do j = 1, n cj = s( j ) - ab( 1, j ) = cj*cj*real( ab( 1, j ),KIND=sp) + ab( 1_${ik}$, j ) = cj*cj*real( ab( 1_${ik}$, j ),KIND=sp) do i = j + 1, 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_claqhb + end subroutine stdlib${ii}$_claqhb - pure subroutine stdlib_claqhe( uplo, n, a, lda, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_claqhe( uplo, n, a, lda, s, scond, amax, equed ) !! CLAQHE equilibrates a Hermitian matrix A using the scaling factors !! in the vector S. ! -- lapack auxiliary routine -- @@ -9760,7 +9762,7 @@ module stdlib_linalg_lapack_c ! 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(in) :: s(*) @@ -9770,18 +9772,18 @@ module stdlib_linalg_lapack_c 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 :: real ! 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 @@ -9810,10 +9812,10 @@ module stdlib_linalg_lapack_c equed = 'Y' end if return - end subroutine stdlib_claqhe + end subroutine stdlib${ii}$_claqhe - pure subroutine stdlib_claqhp( uplo, n, ap, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_claqhp( uplo, n, ap, s, scond, amax, equed ) !! CLAQHP equilibrates a Hermitian matrix A using the scaling factors !! in the vector S. ! -- lapack auxiliary routine -- @@ -9822,7 +9824,7 @@ module stdlib_linalg_lapack_c ! 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(in) :: s(*) @@ -9832,18 +9834,18 @@ module stdlib_linalg_lapack_c 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 ! Intrinsic Functions intrinsic :: real ! 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 @@ -9852,7 +9854,7 @@ module stdlib_linalg_lapack_c ! 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 - 1 @@ -9863,23 +9865,23 @@ module stdlib_linalg_lapack_c end do else ! lower triangle of a is stored. - jc = 1 + jc = 1_${ik}$ do j = 1, n cj = s( j ) ap( jc ) = cj*cj*real( ap( jc ),KIND=sp) do i = j + 1, n ap( jc+i-j ) = cj*s( i )*ap( jc+i-j ) end do - jc = jc + n - j + 1 + jc = jc + n - j + 1_${ik}$ end do end if equed = 'Y' end if return - end subroutine stdlib_claqhp + end subroutine stdlib${ii}$_claqhp - pure subroutine stdlib_claqr1( n, h, ldh, s1, s2, v ) + pure subroutine stdlib${ii}$_claqr1( n, h, ldh, s1, s2, v ) !! Given a 2-by-2 or 3-by-3 matrix H, CLAQR1: sets v to a !! scalar multiple of the first column of the product !! (*) K = (H - s1*I)*(H - s2*I) @@ -9891,7 +9893,7 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(sp), intent(in) :: s1, s2 - integer(ilp), intent(in) :: ldh, n + integer(${ik}$), intent(in) :: ldh, n ! Array Arguments complex(sp), intent(in) :: h(ldh,*) complex(sp), intent(out) :: v(*) @@ -9911,38 +9913,38 @@ module stdlib_linalg_lapack_c cabs1( cdum ) = abs( real( cdum,KIND=sp) ) + abs( aimag( cdum ) ) ! 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 = cabs1( h( 1, 1 )-s2 ) + cabs1( h( 2, 1 ) ) + if( n==2_${ik}$ ) then + s = cabs1( h( 1_${ik}$, 1_${ik}$ )-s2 ) + cabs1( h( 2_${ik}$, 1_${ik}$ ) ) if( s==rzero ) then - v( 1 ) = czero - v( 2 ) = czero + v( 1_${ik}$ ) = czero + v( 2_${ik}$ ) = czero else - h21s = h( 2, 1 ) / s - v( 1 ) = h21s*h( 1, 2 ) + ( h( 1, 1 )-s1 )*( ( h( 1, 1 )-s2 ) / s ) - v( 2 ) = h21s*( h( 1, 1 )+h( 2, 2 )-s1-s2 ) + h21s = h( 2_${ik}$, 1_${ik}$ ) / s + v( 1_${ik}$ ) = h21s*h( 1_${ik}$, 2_${ik}$ ) + ( h( 1_${ik}$, 1_${ik}$ )-s1 )*( ( h( 1_${ik}$, 1_${ik}$ )-s2 ) / s ) + v( 2_${ik}$ ) = h21s*( h( 1_${ik}$, 1_${ik}$ )+h( 2_${ik}$, 2_${ik}$ )-s1-s2 ) end if else - s = cabs1( h( 1, 1 )-s2 ) + cabs1( h( 2, 1 ) ) +cabs1( h( 3, 1 ) ) + s = cabs1( h( 1_${ik}$, 1_${ik}$ )-s2 ) + cabs1( h( 2_${ik}$, 1_${ik}$ ) ) +cabs1( h( 3_${ik}$, 1_${ik}$ ) ) if( s==czero ) then - v( 1 ) = czero - v( 2 ) = czero - v( 3 ) = czero + v( 1_${ik}$ ) = czero + v( 2_${ik}$ ) = czero + v( 3_${ik}$ ) = czero else - h21s = h( 2, 1 ) / s - h31s = h( 3, 1 ) / s - v( 1 ) = ( h( 1, 1 )-s1 )*( ( h( 1, 1 )-s2 ) / s ) +h( 1, 2 )*h21s + h( 1, 3 )& + h21s = h( 2_${ik}$, 1_${ik}$ ) / s + h31s = h( 3_${ik}$, 1_${ik}$ ) / s + v( 1_${ik}$ ) = ( h( 1_${ik}$, 1_${ik}$ )-s1 )*( ( h( 1_${ik}$, 1_${ik}$ )-s2 ) / s ) +h( 1_${ik}$, 2_${ik}$ )*h21s + h( 1_${ik}$, 3_${ik}$ )& *h31s - v( 2 ) = h21s*( h( 1, 1 )+h( 2, 2 )-s1-s2 ) + h( 2, 3 )*h31s - v( 3 ) = h31s*( h( 1, 1 )+h( 3, 3 )-s1-s2 ) + h21s*h( 3, 2 ) + v( 2_${ik}$ ) = h21s*( h( 1_${ik}$, 1_${ik}$ )+h( 2_${ik}$, 2_${ik}$ )-s1-s2 ) + h( 2_${ik}$, 3_${ik}$ )*h31s + v( 3_${ik}$ ) = h31s*( h( 1_${ik}$, 1_${ik}$ )+h( 3_${ik}$, 3_${ik}$ )-s1-s2 ) + h21s*h( 3_${ik}$, 2_${ik}$ ) end if end if - end subroutine stdlib_claqr1 + end subroutine stdlib${ii}$_claqr1 - pure subroutine stdlib_claqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_claqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) !! CLAQSB equilibrates a symmetric band matrix A using the scaling !! factors in the vector S. ! -- lapack auxiliary routine -- @@ -9951,7 +9953,7 @@ module stdlib_linalg_lapack_c ! 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(in) :: s(*) @@ -9961,18 +9963,18 @@ module stdlib_linalg_lapack_c 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 @@ -9992,17 +9994,17 @@ module stdlib_linalg_lapack_c 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_claqsb + end subroutine stdlib${ii}$_claqsb - pure subroutine stdlib_claqsp( uplo, n, ap, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_claqsp( uplo, n, ap, s, scond, amax, equed ) !! CLAQSP equilibrates a symmetric matrix A using the scaling factors !! in the vector S. ! -- lapack auxiliary routine -- @@ -10011,7 +10013,7 @@ module stdlib_linalg_lapack_c ! 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(in) :: s(*) @@ -10021,16 +10023,16 @@ module stdlib_linalg_lapack_c 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 @@ -10039,7 +10041,7 @@ module stdlib_linalg_lapack_c ! 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 @@ -10049,22 +10051,22 @@ module stdlib_linalg_lapack_c 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_claqsp + end subroutine stdlib${ii}$_claqsp - pure subroutine stdlib_claqsy( uplo, n, a, lda, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_claqsy( uplo, n, a, lda, s, scond, amax, equed ) !! CLAQSY equilibrates a symmetric matrix A using the scaling factors !! in the vector S. ! -- lapack auxiliary routine -- @@ -10073,7 +10075,7 @@ module stdlib_linalg_lapack_c ! 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(in) :: s(*) @@ -10083,16 +10085,16 @@ module stdlib_linalg_lapack_c 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 @@ -10119,10 +10121,10 @@ module stdlib_linalg_lapack_c equed = 'Y' end if return - end subroutine stdlib_claqsy + end subroutine stdlib${ii}$_claqsy - pure subroutine stdlib_clar1v( n, b1, bn, lambda, d, l, ld, lld,pivmin, gaptol, z, wantnc, & + pure subroutine stdlib${ii}$_clar1v( n, b1, bn, lambda, d, l, ld, lld,pivmin, gaptol, z, wantnc, & !! CLAR1V 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 @@ -10144,13 +10146,13 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(inout) :: z(*) @@ -10159,13 +10161,13 @@ module stdlib_linalg_lapack_c ! 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,real ! 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 @@ -10173,12 +10175,12 @@ module stdlib_linalg_lapack_c 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 ) @@ -10186,16 +10188,16 @@ module stdlib_linalg_lapack_c ! 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(dplus0 ) 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-czero row in v. do while( lastv>0 .and. v( i )==czero ) - lastv = lastv - 1 + lastv = lastv - 1_${ik}$ i = i - incv end do if( applyleft ) then ! scan for the last non-czero column in c(1:lastv,:). - lastc = stdlib_ilaclc(lastv, n, c, ldc) + lastc = stdlib${ii}$_ilaclc(lastv, n, c, ldc) else ! scan for the last non-czero row in c(:,1:lastv). - lastc = stdlib_ilaclr(m, lastv, c, ldc) + lastc = stdlib${ii}$_ilaclr(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 + if( lastv>0_${ik}$ ) then ! w(1:lastc,1) := c(1:lastv,1:lastc)**h * v(1:lastv,1) - call stdlib_cgemv( 'CONJUGATE TRANSPOSE', lastv, lastc, cone,c, ldc, v, incv, & - czero, work, 1 ) + call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', lastv, lastc, cone,c, ldc, v, incv, & + czero, work, 1_${ik}$ ) ! c(1:lastv,1:lastc) := c(...) - v(1:lastv,1) * w(1:lastc,1)**h - call stdlib_cgerc( lastv, lastc, -tau, v, incv, work, 1, c, ldc ) + call stdlib${ii}$_cgerc( lastv, lastc, -tau, v, incv, work, 1_${ik}$, c, ldc ) end if else ! form c * h - if( lastv>0 ) then + if( lastv>0_${ik}$ ) then ! w(1:lastc,1) := c(1:lastc,1:lastv) * v(1:lastv,1) - call stdlib_cgemv( 'NO TRANSPOSE', lastc, lastv, cone, c, ldc,v, incv, czero, & - work, 1 ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', lastc, lastv, cone, c, ldc,v, incv, czero, & + work, 1_${ik}$ ) ! c(1:lastc,1:lastv) := c(...) - w(1:lastc,1) * v(1:lastv,1)**h - call stdlib_cgerc( lastc, lastv, -tau, work, 1, v, incv, c, ldc ) + call stdlib${ii}$_cgerc( lastc, lastv, -tau, work, 1_${ik}$, v, incv, c, ldc ) end if end if return - end subroutine stdlib_clarf + end subroutine stdlib${ii}$_clarf - pure subroutine stdlib_clarfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, ldc, & + pure subroutine stdlib${ii}$_clarfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, ldc, & !! CLARFB applies a complex block reflector H or its transpose H**H to a !! complex M-by-N matrix C, from either the left or the right. work, ldwork ) @@ -10542,7 +10544,7 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: c(ldc,*) complex(sp), intent(in) :: t(ldt,*), v(ldv,*) @@ -10551,7 +10553,7 @@ module stdlib_linalg_lapack_c ! Local Scalars character :: transt - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Intrinsic Functions intrinsic :: conjg ! Executable Statements @@ -10573,28 +10575,28 @@ module stdlib_linalg_lapack_c ! w := c**h * v = (c1**h * v1 + c2**h * v2) (stored in work) ! w := c1**h do j = 1, k - call stdlib_ccopy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) - call stdlib_clacgv( n, work( 1, j ), 1 ) + call stdlib${ii}$_ccopy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_clacgv( n, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v1 - call stdlib_ctrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v, & + call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v, & ldv, work, ldwork ) if( m>k ) then ! w := w + c2**h *v2 - call stdlib_cgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', n,k, m-k, cone, & - c( k+1, 1 ), ldc,v( k+1, 1 ), ldv, cone, work, ldwork ) + call stdlib${ii}$_cgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', n,k, m-k, cone, & + c( k+1, 1_${ik}$ ), ldc,v( k+1, 1_${ik}$ ), ldv, cone, work, ldwork ) end if ! w := w * t**h or w * t - call stdlib_ctrmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,cone, t, ldt, & + call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,cone, t, ldt, & work, ldwork ) ! c := c - v * w**h if( m>k ) then ! c2 := c2 - v2 * w**h - call stdlib_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',m-k, n, k, -cone, & - v( k+1, 1 ), ldv, work,ldwork, cone, c( k+1, 1 ), ldc ) + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',m-k, n, k, -cone, & + v( k+1, 1_${ik}$ ), ldv, work,ldwork, cone, c( k+1, 1_${ik}$ ), ldc ) end if ! w := w * v1**h - call stdlib_ctrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& + call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& v, ldv, work, ldwork ) ! c1 := c1 - w**h do j = 1, k @@ -10607,27 +10609,27 @@ module stdlib_linalg_lapack_c ! w := c * v = (c1*v1 + c2*v2) (stored in work) ! w := c1 do j = 1, k - call stdlib_ccopy( m, c( 1, j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_ccopy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v1 - call stdlib_ctrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v, & + call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v, & ldv, work, ldwork ) if( n>k ) then ! w := w + c2 * v2 - call stdlib_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,cone, c( 1, k+& - 1 ), ldc, v( k+1, 1 ), ldv,cone, work, ldwork ) + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,cone, c( 1_${ik}$, k+& + 1_${ik}$ ), ldc, v( k+1, 1_${ik}$ ), ldv,cone, work, ldwork ) end if ! w := w * t or w * t**h - call stdlib_ctrmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,cone, t, ldt, & + call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,cone, t, ldt, & work, ldwork ) ! c := c - w * v**h if( n>k ) then ! c2 := c2 - w * v2**h - call stdlib_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,n-k, k, -cone, & - work, ldwork, v( k+1, 1 ),ldv, cone, c( 1, k+1 ), ldc ) + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,n-k, k, -cone, & + work, ldwork, v( k+1, 1_${ik}$ ),ldv, cone, c( 1_${ik}$, k+1 ), ldc ) end if ! w := w * v1**h - call stdlib_ctrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& + call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& v, ldv, work, ldwork ) ! c1 := c1 - w do j = 1, k @@ -10646,29 +10648,29 @@ module stdlib_linalg_lapack_c ! w := c**h * v = (c1**h * v1 + c2**h * v2) (stored in work) ! w := c2**h do j = 1, k - call stdlib_ccopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 ) - call stdlib_clacgv( n, work( 1, j ), 1 ) + call stdlib${ii}$_ccopy( n, c( m-k+j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_clacgv( n, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v2 - call stdlib_ctrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v( m-& - k+1, 1 ), ldv, work, ldwork ) + call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v( m-& + k+1, 1_${ik}$ ), ldv, work, ldwork ) if( m>k ) then ! w := w + c1**h * v1 - call stdlib_cgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', n,k, m-k, cone, & + call stdlib${ii}$_cgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', n,k, m-k, cone, & c, ldc, v, ldv, cone, work,ldwork ) end if ! w := w * t**h or w * t - call stdlib_ctrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,cone, t, ldt, & + call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,cone, t, ldt, & work, ldwork ) ! c := c - v * w**h if( m>k ) then ! c1 := c1 - v1 * w**h - call stdlib_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',m-k, n, k, -cone, & + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',m-k, n, k, -cone, & v, ldv, work, ldwork,cone, c, ldc ) end if ! w := w * v2**h - call stdlib_ctrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& - v( m-k+1, 1 ), ldv, work,ldwork ) + call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& + v( m-k+1, 1_${ik}$ ), ldv, work,ldwork ) ! c2 := c2 - w**h do j = 1, k do i = 1, n @@ -10680,28 +10682,28 @@ module stdlib_linalg_lapack_c ! w := c * v = (c1*v1 + c2*v2) (stored in work) ! w := c2 do j = 1, k - call stdlib_ccopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_ccopy( m, c( 1_${ik}$, n-k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v2 - call stdlib_ctrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v( n-& - k+1, 1 ), ldv, work, ldwork ) + call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v( n-& + k+1, 1_${ik}$ ), ldv, work, ldwork ) if( n>k ) then ! w := w + c1 * v1 - call stdlib_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,cone, c, ldc, & + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,cone, c, ldc, & v, ldv, cone, work, ldwork ) end if ! w := w * t or w * t**h - call stdlib_ctrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,cone, t, ldt, & + call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,cone, t, ldt, & work, ldwork ) ! c := c - w * v**h if( n>k ) then ! c1 := c1 - w * v1**h - call stdlib_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,n-k, k, -cone, & + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,n-k, k, -cone, & work, ldwork, v, ldv, cone,c, ldc ) end if ! w := w * v2**h - call stdlib_ctrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& - v( n-k+1, 1 ), ldv, work,ldwork ) + call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& + v( n-k+1, 1_${ik}$ ), ldv, work,ldwork ) ! c2 := c2 - w do j = 1, k do i = 1, m @@ -10720,28 +10722,28 @@ module stdlib_linalg_lapack_c ! w := c**h * v**h = (c1**h * v1**h + c2**h * v2**h) (stored in work) ! w := c1**h do j = 1, k - call stdlib_ccopy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) - call stdlib_clacgv( n, work( 1, j ), 1 ) + call stdlib${ii}$_ccopy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_clacgv( n, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v1**h - call stdlib_ctrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& + call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& v, ldv, work, ldwork ) if( m>k ) then ! w := w + c2**h * v2**h - call stdlib_cgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', n, k, m-k, & - cone,c( k+1, 1 ), ldc, v( 1, k+1 ), ldv, cone,work, ldwork ) + call stdlib${ii}$_cgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', n, k, m-k, & + cone,c( k+1, 1_${ik}$ ), ldc, v( 1_${ik}$, k+1 ), ldv, cone,work, ldwork ) end if ! w := w * t**h or w * t - call stdlib_ctrmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,cone, t, ldt, & + call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,cone, t, ldt, & work, ldwork ) ! c := c - v**h * w**h if( m>k ) then ! c2 := c2 - v2**h * w**h - call stdlib_cgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', m-k, n, k, & - -cone,v( 1, k+1 ), ldv, work, ldwork, cone,c( k+1, 1 ), ldc ) + call stdlib${ii}$_cgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', m-k, n, k, & + -cone,v( 1_${ik}$, k+1 ), ldv, work, ldwork, cone,c( k+1, 1_${ik}$ ), ldc ) end if ! w := w * v1 - call stdlib_ctrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v, & + call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v, & ldv, work, ldwork ) ! c1 := c1 - w**h do j = 1, k @@ -10754,27 +10756,27 @@ module stdlib_linalg_lapack_c ! w := c * v**h = (c1*v1**h + c2*v2**h) (stored in work) ! w := c1 do j = 1, k - call stdlib_ccopy( m, c( 1, j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_ccopy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v1**h - call stdlib_ctrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& + call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& v, ldv, work, ldwork ) if( n>k ) then ! w := w + c2 * v2**h - call stdlib_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,k, n-k, cone, & - c( 1, k+1 ), ldc,v( 1, k+1 ), ldv, cone, work, ldwork ) + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,k, n-k, cone, & + c( 1_${ik}$, k+1 ), ldc,v( 1_${ik}$, k+1 ), ldv, cone, work, ldwork ) end if ! w := w * t or w * t**h - call stdlib_ctrmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,cone, t, ldt, & + call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,cone, t, ldt, & work, ldwork ) ! c := c - w * v if( n>k ) then ! c2 := c2 - w * v2 - call stdlib_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-cone, work, & - ldwork, v( 1, k+1 ), ldv, cone,c( 1, k+1 ), ldc ) + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-cone, work, & + ldwork, v( 1_${ik}$, k+1 ), ldv, cone,c( 1_${ik}$, k+1 ), ldc ) end if ! w := w * v1 - call stdlib_ctrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v, & + call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v, & ldv, work, ldwork ) ! c1 := c1 - w do j = 1, k @@ -10792,28 +10794,28 @@ module stdlib_linalg_lapack_c ! w := c**h * v**h = (c1**h * v1**h + c2**h * v2**h) (stored in work) ! w := c2**h do j = 1, k - call stdlib_ccopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 ) - call stdlib_clacgv( n, work( 1, j ), 1 ) + call stdlib${ii}$_ccopy( n, c( m-k+j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_clacgv( n, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v2**h - call stdlib_ctrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& - v( 1, m-k+1 ), ldv, work,ldwork ) + call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& + v( 1_${ik}$, m-k+1 ), ldv, work,ldwork ) if( m>k ) then ! w := w + c1**h * v1**h - call stdlib_cgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', n, k, m-k, & + call stdlib${ii}$_cgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', n, k, m-k, & cone, c,ldc, v, ldv, cone, work, ldwork ) end if ! w := w * t**h or w * t - call stdlib_ctrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,cone, t, ldt, & + call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,cone, t, ldt, & work, ldwork ) ! c := c - v**h * w**h if( m>k ) then ! c1 := c1 - v1**h * w**h - call stdlib_cgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', m-k, n, k, & + call stdlib${ii}$_cgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', m-k, n, k, & -cone, v,ldv, work, ldwork, cone, c, ldc ) end if ! w := w * v2 - call stdlib_ctrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v( 1, & + call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v( 1_${ik}$, & m-k+1 ), ldv, work, ldwork ) ! c2 := c2 - w**h do j = 1, k @@ -10826,27 +10828,27 @@ module stdlib_linalg_lapack_c ! w := c * v**h = (c1*v1**h + c2*v2**h) (stored in work) ! w := c2 do j = 1, k - call stdlib_ccopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_ccopy( m, c( 1_${ik}$, n-k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v2**h - call stdlib_ctrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& - v( 1, n-k+1 ), ldv, work,ldwork ) + call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& + v( 1_${ik}$, n-k+1 ), ldv, work,ldwork ) if( n>k ) then ! w := w + c1 * v1**h - call stdlib_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,k, n-k, cone, & + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,k, n-k, cone, & c, ldc, v, ldv, cone, work,ldwork ) end if ! w := w * t or w * t**h - call stdlib_ctrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,cone, t, ldt, & + call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,cone, t, ldt, & work, ldwork ) ! c := c - w * v if( n>k ) then ! c1 := c1 - w * v1 - call stdlib_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-cone, work, & + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-cone, work, & ldwork, v, ldv, cone, c, ldc ) end if ! w := w * v2 - call stdlib_ctrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v( 1, & + call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v( 1_${ik}$, & n-k+1 ), ldv, work, ldwork ) ! c1 := c1 - w do j = 1, k @@ -10858,10 +10860,10 @@ module stdlib_linalg_lapack_c end if end if return - end subroutine stdlib_clarfb + end subroutine stdlib${ii}$_clarfb - pure subroutine stdlib_clarfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) + pure subroutine stdlib${ii}$_clarfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) !! CLARFB_GETT applies a complex Householder block reflector H from the !! left to a complex (K+M)-by-N "triangular-pentagonal" matrix !! composed of two block matrices: an upper trapezoidal K-by-N matrix A @@ -10875,7 +10877,7 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: a(lda,*), b(ldb,*) complex(sp), intent(in) :: t(ldt,*) @@ -10884,7 +10886,7 @@ module stdlib_linalg_lapack_c ! 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 @@ -10898,35 +10900,35 @@ module stdlib_linalg_lapack_c ! col2_(1) compute w2: = a2. therefore, copy a2 = a(1:k, k+1:n) ! into w2=work(1:k, 1:n-k) column-by-column. do j = 1, n-k - call stdlib_ccopy( k, a( 1, k+j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_ccopy( k, a( 1_${ik}$, k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do if( lnotident ) then ! col2_(2) compute w2: = (v1**h) * w2 = (a1**h) * w2, ! v1 is not an identy matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored). - call stdlib_ctrmm( 'L', 'L', 'C', 'U', k, n-k, cone, a, lda,work, ldwork ) + call stdlib${ii}$_ctrmm( 'L', 'L', 'C', 'U', k, n-k, cone, a, lda,work, ldwork ) end if ! col2_(3) compute w2: = w2 + (v2**h) * b2 = w2 + (b1**h) * b2 ! v2 stored in b1. - if( m>0 ) then - call stdlib_cgemm( 'C', 'N', k, n-k, m, cone, b, ldb,b( 1, k+1 ), ldb, cone, & + if( m>0_${ik}$ ) then + call stdlib${ii}$_cgemm( 'C', 'N', k, n-k, m, cone, b, ldb,b( 1_${ik}$, k+1 ), ldb, cone, & work, ldwork ) end if ! col2_(4) compute w2: = t * w2, ! t is upper-triangular. - call stdlib_ctrmm( 'L', 'U', 'N', 'N', k, n-k, cone, t, ldt,work, ldwork ) + call stdlib${ii}$_ctrmm( 'L', 'U', 'N', 'N', k, n-k, cone, t, ldt,work, ldwork ) ! col2_(5) compute b2: = b2 - v2 * w2 = b2 - b1 * w2, ! v2 stored in b1. - if( m>0 ) then - call stdlib_cgemm( 'N', 'N', m, n-k, k, -cone, b, ldb,work, ldwork, cone, b( 1, & + if( m>0_${ik}$ ) then + call stdlib${ii}$_cgemm( 'N', 'N', m, n-k, k, -cone, b, ldb,work, ldwork, cone, b( 1_${ik}$, & k+1 ), ldb ) end if if( lnotident ) then ! col2_(6) compute w2: = v1 * w2 = a1 * w2, ! v1 is not an identity matrix, but unit lower-triangular, ! v1 stored in a1 (diagonal ones are not stored). - call stdlib_ctrmm( 'L', 'L', 'N', 'U', k, n-k, cone, a, lda,work, ldwork ) + call stdlib${ii}$_ctrmm( 'L', 'L', 'N', 'U', k, n-k, cone, a, lda,work, ldwork ) end if ! col2_(7) compute a2: = a2 - w2 = @@ -10947,7 +10949,7 @@ module stdlib_linalg_lapack_c ! a1 = a(1:k, 1:k) into the upper-triangular ! w1 = work(1:k, 1:k) column-by-column. do j = 1, k - call stdlib_ccopy( j, a( 1, j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_ccopy( 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 @@ -10960,16 +10962,16 @@ module stdlib_linalg_lapack_c ! 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_ctrmm( 'L', 'L', 'C', 'U', k, k, cone, a, lda,work, ldwork ) + call stdlib${ii}$_ctrmm( 'L', 'L', 'C', 'U', k, k, cone, a, lda,work, ldwork ) end if ! col1_(3) compute w1: = t * w1, ! t is upper-triangular, ! w1 is upper-triangular with zeroes below the diagonal. - call stdlib_ctrmm( 'L', 'U', 'N', 'N', k, k, cone, t, ldt,work, ldwork ) + call stdlib${ii}$_ctrmm( 'L', 'U', 'N', 'N', k, k, cone, t, ldt,work, ldwork ) ! col1_(4) compute b1: = - v2 * w1 = - b1 * w1, ! v2 = b1, w1 is upper-triangular with zeroes below the diagonal. - if( m>0 ) then - call stdlib_ctrmm( 'R', 'U', 'N', 'N', m, k, -cone, work, ldwork,b, ldb ) + if( m>0_${ik}$ ) then + call stdlib${ii}$_ctrmm( 'R', 'U', 'N', 'N', m, k, -cone, work, ldwork,b, ldb ) end if if( lnotident ) then ! col1_(5) compute w1: = v1 * w1 = a1 * w1, @@ -10977,7 +10979,7 @@ module stdlib_linalg_lapack_c ! 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_ctrmm( 'L', 'L', 'N', 'U', k, k, cone, a, lda,work, ldwork ) + call stdlib${ii}$_ctrmm( 'L', 'L', 'N', 'U', k, k, cone, a, lda,work, ldwork ) ! col1_(6) compute a1: = a1 - w1 = a(1:k, 1:k) - work(1:k, 1:k) ! column-by-column. a1 is upper-triangular on input. ! if ident, a1 is square on output, and w1 is square, @@ -10997,10 +10999,10 @@ module stdlib_linalg_lapack_c end do end do return - end subroutine stdlib_clarfb_gett + end subroutine stdlib${ii}$_clarfb_gett - pure subroutine stdlib_clarfg( n, alpha, x, incx, tau ) + pure subroutine stdlib${ii}$_clarfg( n, alpha, x, incx, tau ) !! CLARFG generates a complex elementary reflector H of order n, such !! that !! H**H * ( alpha ) = ( beta ), H**H * H = I. @@ -11018,7 +11020,7 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: alpha complex(sp), intent(out) :: tau ! Array Arguments @@ -11026,16 +11028,16 @@ module stdlib_linalg_lapack_c ! ===================================================================== ! Local Scalars - integer(ilp) :: j, knt + integer(${ik}$) :: j, knt real(sp) :: alphi, alphr, beta, rsafmn, safmin, xnorm ! Intrinsic Functions intrinsic :: abs,aimag,cmplx,real,sign ! Executable Statements - if( n<=0 ) then + if( n<=0_${ik}$ ) then tau = zero return end if - xnorm = stdlib_scnrm2( n-1, x, incx ) + xnorm = stdlib${ii}$_scnrm2( n-1, x, incx ) alphr = real( alpha,KIND=sp) alphi = aimag( alpha ) if( xnorm==zero .and. alphi==zero ) then @@ -11043,27 +11045,27 @@ module stdlib_linalg_lapack_c tau = zero else ! general case - beta = -sign( stdlib_slapy3( alphr, alphi, xnorm ), alphr ) - safmin = stdlib_slamch( 'S' ) / stdlib_slamch( 'E' ) + beta = -sign( stdlib${ii}$_slapy3( alphr, alphi, xnorm ), alphr ) + safmin = stdlib${ii}$_slamch( 'S' ) / stdlib${ii}$_slamch( 'E' ) rsafmn = one / safmin - knt = 0 + knt = 0_${ik}$ if( abs( beta )1 ) then + if( i>1_${ik}$ ) then prevlastv = max( prevlastv, lastv ) else prevlastv = lastv @@ -11285,7 +11287,7 @@ module stdlib_linalg_lapack_c end if end do else - prevlastv = 1 + prevlastv = 1_${ik}$ do i = k, 1, -1 if( tau( i )==czero ) then ! h(i) = i @@ -11305,8 +11307,8 @@ module stdlib_linalg_lapack_c end do j = max( lastv, prevlastv ) ! t(i+1:k,i) = -tau(i) * v(j:n-k+i,i+1:k)**h * v(j:n-k+i,i) - call stdlib_cgemv( 'CONJUGATE TRANSPOSE', n-k+i-j, k-i,-tau( i ), v( j, & - i+1 ), ldv, v( j, i ),1, cone, t( i+1, i ), 1 ) + call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', n-k+i-j, k-i,-tau( i ), v( j, & + i+1 ), ldv, v( j, i ),1_${ik}$, cone, t( i+1, i ), 1_${ik}$ ) else ! skip any leading zeros. do lastv = 1, i-1 @@ -11317,13 +11319,13 @@ module stdlib_linalg_lapack_c end do j = max( lastv, prevlastv ) ! t(i+1:k,i) = -tau(i) * v(i+1:k,j:n-k+i) * v(i,j:n-k+i)**h - call stdlib_cgemm( 'N', 'C', k-i, 1, n-k+i-j, -tau( i ),v( i+1, j ), & + call stdlib${ii}$_cgemm( 'N', 'C', k-i, 1_${ik}$, n-k+i-j, -tau( i ),v( i+1, j ), & ldv, v( i, j ), ldv,cone, t( i+1, i ), ldt ) end if ! t(i+1:k,i) := t(i+1:k,i+1:k) * t(i+1:k,i) - call stdlib_ctrmv( '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}$_ctrmv( '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 @@ -11334,10 +11336,10 @@ module stdlib_linalg_lapack_c end do end if return - end subroutine stdlib_clarft + end subroutine stdlib${ii}$_clarft - pure subroutine stdlib_clarfx( side, m, n, v, tau, c, ldc, work ) + pure subroutine stdlib${ii}$_clarfx( side, m, n, v, tau, c, ldc, work ) !! CLARFX applies a complex elementary reflector H to a complex m by n !! matrix C, from either the left or the right. H is represented in the !! form @@ -11350,7 +11352,7 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(in) :: tau ! Array Arguments complex(sp), intent(inout) :: c(ldc,*) @@ -11359,7 +11361,7 @@ module stdlib_linalg_lapack_c ! ===================================================================== ! Local Scalars - integer(ilp) :: j + integer(${ik}$) :: j complex(sp) :: sum, t1, t10, t2, t3, t4, t5, t6, t7, t8, t9, v1, v10, v2, v3, v4, v5, & v6, v7, v8, v9 ! Intrinsic Functions @@ -11370,478 +11372,478 @@ module stdlib_linalg_lapack_c ! 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_clarf( side, m, n, v, 1, tau, c, ldc, work ) + call stdlib${ii}$_clarf( side, m, n, v, 1_${ik}$, tau, c, ldc, work ) go to 410 10 continue ! special code for 1 x 1 householder - t1 = cone - tau*v( 1 )*conjg( v( 1 ) ) + t1 = cone - tau*v( 1_${ik}$ )*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( v2 ) - v3 = conjg( v( 3 ) ) + v3 = conjg( v( 3_${ik}$ ) ) t3 = tau*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( v2 ) - v3 = conjg( v( 3 ) ) + v3 = conjg( v( 3_${ik}$ ) ) t3 = tau*conjg( v3 ) - v4 = conjg( v( 4 ) ) + v4 = conjg( v( 4_${ik}$ ) ) t4 = tau*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( v2 ) - v3 = conjg( v( 3 ) ) + v3 = conjg( v( 3_${ik}$ ) ) t3 = tau*conjg( v3 ) - v4 = conjg( v( 4 ) ) + v4 = conjg( v( 4_${ik}$ ) ) t4 = tau*conjg( v4 ) - v5 = conjg( v( 5 ) ) + v5 = conjg( v( 5_${ik}$ ) ) t5 = tau*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( v2 ) - v3 = conjg( v( 3 ) ) + v3 = conjg( v( 3_${ik}$ ) ) t3 = tau*conjg( v3 ) - v4 = conjg( v( 4 ) ) + v4 = conjg( v( 4_${ik}$ ) ) t4 = tau*conjg( v4 ) - v5 = conjg( v( 5 ) ) + v5 = conjg( v( 5_${ik}$ ) ) t5 = tau*conjg( v5 ) - v6 = conjg( v( 6 ) ) + v6 = conjg( v( 6_${ik}$ ) ) t6 = tau*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( v2 ) - v3 = conjg( v( 3 ) ) + v3 = conjg( v( 3_${ik}$ ) ) t3 = tau*conjg( v3 ) - v4 = conjg( v( 4 ) ) + v4 = conjg( v( 4_${ik}$ ) ) t4 = tau*conjg( v4 ) - v5 = conjg( v( 5 ) ) + v5 = conjg( v( 5_${ik}$ ) ) t5 = tau*conjg( v5 ) - v6 = conjg( v( 6 ) ) + v6 = conjg( v( 6_${ik}$ ) ) t6 = tau*conjg( v6 ) - v7 = conjg( v( 7 ) ) + v7 = conjg( v( 7_${ik}$ ) ) t7 = tau*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( v2 ) - v3 = conjg( v( 3 ) ) + v3 = conjg( v( 3_${ik}$ ) ) t3 = tau*conjg( v3 ) - v4 = conjg( v( 4 ) ) + v4 = conjg( v( 4_${ik}$ ) ) t4 = tau*conjg( v4 ) - v5 = conjg( v( 5 ) ) + v5 = conjg( v( 5_${ik}$ ) ) t5 = tau*conjg( v5 ) - v6 = conjg( v( 6 ) ) + v6 = conjg( v( 6_${ik}$ ) ) t6 = tau*conjg( v6 ) - v7 = conjg( v( 7 ) ) + v7 = conjg( v( 7_${ik}$ ) ) t7 = tau*conjg( v7 ) - v8 = conjg( v( 8 ) ) + v8 = conjg( v( 8_${ik}$ ) ) t8 = tau*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( v2 ) - v3 = conjg( v( 3 ) ) + v3 = conjg( v( 3_${ik}$ ) ) t3 = tau*conjg( v3 ) - v4 = conjg( v( 4 ) ) + v4 = conjg( v( 4_${ik}$ ) ) t4 = tau*conjg( v4 ) - v5 = conjg( v( 5 ) ) + v5 = conjg( v( 5_${ik}$ ) ) t5 = tau*conjg( v5 ) - v6 = conjg( v( 6 ) ) + v6 = conjg( v( 6_${ik}$ ) ) t6 = tau*conjg( v6 ) - v7 = conjg( v( 7 ) ) + v7 = conjg( v( 7_${ik}$ ) ) t7 = tau*conjg( v7 ) - v8 = conjg( v( 8 ) ) + v8 = conjg( v( 8_${ik}$ ) ) t8 = tau*conjg( v8 ) - v9 = conjg( v( 9 ) ) + v9 = conjg( v( 9_${ik}$ ) ) t9 = tau*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( v2 ) - v3 = conjg( v( 3 ) ) + v3 = conjg( v( 3_${ik}$ ) ) t3 = tau*conjg( v3 ) - v4 = conjg( v( 4 ) ) + v4 = conjg( v( 4_${ik}$ ) ) t4 = tau*conjg( v4 ) - v5 = conjg( v( 5 ) ) + v5 = conjg( v( 5_${ik}$ ) ) t5 = tau*conjg( v5 ) - v6 = conjg( v( 6 ) ) + v6 = conjg( v( 6_${ik}$ ) ) t6 = tau*conjg( v6 ) - v7 = conjg( v( 7 ) ) + v7 = conjg( v( 7_${ik}$ ) ) t7 = tau*conjg( v7 ) - v8 = conjg( v( 8 ) ) + v8 = conjg( v( 8_${ik}$ ) ) t8 = tau*conjg( v8 ) - v9 = conjg( v( 9 ) ) + v9 = conjg( v( 9_${ik}$ ) ) t9 = tau*conjg( v9 ) - v10 = conjg( v( 10 ) ) + v10 = conjg( v( 10_${ik}$ ) ) t10 = tau*conjg( 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_clarf( side, m, n, v, 1, tau, c, ldc, work ) + call stdlib${ii}$_clarf( side, m, n, v, 1_${ik}$, tau, c, ldc, work ) go to 410 210 continue ! special code for 1 x 1 householder - t1 = cone - tau*v( 1 )*conjg( v( 1 ) ) + t1 = cone - tau*v( 1_${ik}$ )*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( v2 ) - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( v2 ) - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*conjg( v3 ) - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( v2 ) - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*conjg( v3 ) - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*conjg( v4 ) - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( v2 ) - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*conjg( v3 ) - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*conjg( v4 ) - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*conjg( v5 ) - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( v2 ) - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*conjg( v3 ) - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*conjg( v4 ) - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*conjg( v5 ) - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*conjg( v6 ) - v7 = v( 7 ) + v7 = v( 7_${ik}$ ) t7 = tau*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( v2 ) - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*conjg( v3 ) - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*conjg( v4 ) - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*conjg( v5 ) - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*conjg( v6 ) - v7 = v( 7 ) + v7 = v( 7_${ik}$ ) t7 = tau*conjg( v7 ) - v8 = v( 8 ) + v8 = v( 8_${ik}$ ) t8 = tau*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( v2 ) - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*conjg( v3 ) - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*conjg( v4 ) - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*conjg( v5 ) - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*conjg( v6 ) - v7 = v( 7 ) + v7 = v( 7_${ik}$ ) t7 = tau*conjg( v7 ) - v8 = v( 8 ) + v8 = v( 8_${ik}$ ) t8 = tau*conjg( v8 ) - v9 = v( 9 ) + v9 = v( 9_${ik}$ ) t9 = tau*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( v2 ) - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*conjg( v3 ) - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*conjg( v4 ) - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*conjg( v5 ) - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*conjg( v6 ) - v7 = v( 7 ) + v7 = v( 7_${ik}$ ) t7 = tau*conjg( v7 ) - v8 = v( 8 ) + v8 = v( 8_${ik}$ ) t8 = tau*conjg( v8 ) - v9 = v( 9 ) + v9 = v( 9_${ik}$ ) t9 = tau*conjg( v9 ) - v10 = v( 10 ) + v10 = v( 10_${ik}$ ) t10 = tau*conjg( 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_clarfx + end subroutine stdlib${ii}$_clarfx - pure subroutine stdlib_clarfy( uplo, n, v, incv, tau, c, ldc, work ) + pure subroutine stdlib${ii}$_clarfy( uplo, n, v, incv, tau, c, ldc, work ) !! CLARFY applies an elementary reflector, or Householder matrix, H, !! to an n x n Hermitian matrix C, from both the left and the right. !! H is represented in the form @@ -11853,7 +11855,7 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(in) :: tau ! Array Arguments complex(sp), intent(inout) :: c(ldc,*) @@ -11866,81 +11868,81 @@ module stdlib_linalg_lapack_c ! Executable Statements if( tau==czero )return ! form w:= c * v - call stdlib_chemv( uplo, n, cone, c, ldc, v, incv, czero, work, 1 ) - alpha = -chalf*tau*stdlib_cdotc( n, work, 1, v, incv ) - call stdlib_caxpy( n, alpha, v, incv, work, 1 ) + call stdlib${ii}$_chemv( uplo, n, cone, c, ldc, v, incv, czero, work, 1_${ik}$ ) + alpha = -chalf*tau*stdlib${ii}$_cdotc( n, work, 1_${ik}$, v, incv ) + call stdlib${ii}$_caxpy( n, alpha, v, incv, work, 1_${ik}$ ) ! c := c - v * w' - w * v' - call stdlib_cher2( uplo, n, -tau, v, incv, work, 1, c, ldc ) + call stdlib${ii}$_cher2( uplo, n, -tau, v, incv, work, 1_${ik}$, c, ldc ) return - end subroutine stdlib_clarfy + end subroutine stdlib${ii}$_clarfy - pure subroutine stdlib_clarnv( idist, iseed, n, x ) + pure subroutine stdlib${ii}$_clarnv( idist, iseed, n, x ) !! CLARNV returns a vector of n random complex 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}$) complex(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, iv + integer(${ik}$) :: i, il, iv ! Local Arrays real(sp) :: u(lv) ! Intrinsic Functions intrinsic :: cmplx,exp,log,min,sqrt ! Executable Statements do 60 iv = 1, n, lv / 2 - il = min( lv / 2, n-iv+1 ) - ! call stdlib_slaruv to generate 2*il realnumbers from a uniform (0,1,KIND=sp) + il = min( lv / 2_${ik}$, n-iv+1 ) + ! call stdlib${ii}$_slaruv to generate 2*il realnumbers from a uniform (0,1,KIND=sp) ! distribution (2*il <= lv) - call stdlib_slaruv( iseed, 2*il, u ) - if( idist==1 ) then + call stdlib${ii}$_slaruv( iseed, 2_${ik}$*il, u ) + if( idist==1_${ik}$ ) then ! copy generated numbers do i = 1, il - x( iv+i-1 ) = cmplx( u( 2*i-1 ), u( 2*i ),KIND=sp) + x( iv+i-1 ) = cmplx( u( 2_${ik}$*i-1 ), u( 2_${ik}$*i ),KIND=sp) end do - else if( idist==2 ) then + else if( idist==2_${ik}$ ) then ! convert generated numbers to uniform (-1,1) distribution do i = 1, il - x( iv+i-1 ) = cmplx( two*u( 2*i-1 )-one,two*u( 2*i )-one,KIND=sp) + x( iv+i-1 ) = cmplx( two*u( 2_${ik}$*i-1 )-one,two*u( 2_${ik}$*i )-one,KIND=sp) end do - else if( idist==3 ) then + else if( idist==3_${ik}$ ) then ! convert generated numbers to normal (0,1) distribution do i = 1, il - x( iv+i-1 ) = sqrt( -two*log( u( 2*i-1 ) ) )*exp( cmplx( zero, twopi*u( 2*i ),& + x( iv+i-1 ) = sqrt( -two*log( u( 2_${ik}$*i-1 ) ) )*exp( cmplx( zero, twopi*u( 2_${ik}$*i ),& KIND=sp) ) end do - else if( idist==4 ) then + else if( idist==4_${ik}$ ) then ! convert generated numbers to complex numbers uniformly ! distributed on the unit disk do i = 1, il - x( iv+i-1 ) = sqrt( u( 2*i-1 ) )*exp( cmplx( zero, twopi*u( 2*i ),KIND=sp) ) + x( iv+i-1 ) = sqrt( u( 2_${ik}$*i-1 ) )*exp( cmplx( zero, twopi*u( 2_${ik}$*i ),KIND=sp) ) end do - else if( idist==5 ) then + else if( idist==5_${ik}$ ) then ! convert generated numbers to complex numbers uniformly ! distributed on the unit circle do i = 1, il - x( iv+i-1 ) = exp( cmplx( zero, twopi*u( 2*i ),KIND=sp) ) + x( iv+i-1 ) = exp( cmplx( zero, twopi*u( 2_${ik}$*i ),KIND=sp) ) end do end if 60 continue return - end subroutine stdlib_clarnv + end subroutine stdlib${ii}$_clarnv - pure subroutine stdlib_clartg( f, g, c, s, r ) + pure subroutine stdlib${ii}$_clartg( f, g, c, s, r ) !! CLARTG generates a plane rotation so that !! [ C S ] . [ F ] = [ R ] !! [ -conjg(S) C ] [ G ] [ 0 ] @@ -11979,7 +11981,7 @@ module stdlib_linalg_lapack_c ! Statement Functions real(sp) :: abssq ! Statement Function Definitions - abssq( t ) = real( t,KIND=sp)**2 + aimag( t )**2 + abssq( t ) = real( t,KIND=sp)**2_${ik}$ + aimag( t )**2_${ik}$ ! Executable Statements if( g == czero ) then c = one @@ -12017,7 +12019,7 @@ module stdlib_linalg_lapack_c else d = sqrt( f2 )*sqrt( h2 ) end if - p = 1 / d + p = 1_${ik}$ / d c = f2*p s = conjg( g )*( f*p ) r = f*( h2*p ) @@ -12035,7 +12037,7 @@ module stdlib_linalg_lapack_c w = v * uu fs = f*vv f2 = abssq( fs ) - h2 = f2*w**2 + g2 + h2 = f2*w**2_${ik}$ + g2 else ! otherwise use the same scaling for f and g. w = one @@ -12048,17 +12050,17 @@ module stdlib_linalg_lapack_c else d = sqrt( f2 )*sqrt( h2 ) end if - p = 1 / d + p = 1_${ik}$ / d c = ( f2*p )*w s = conjg( gs )*( fs*p ) r = ( fs*( h2*p ) )*u end if end if return - end subroutine stdlib_clartg + end subroutine stdlib${ii}$_clartg - pure subroutine stdlib_clartv( n, x, incx, y, incy, c, s, incc ) + pure subroutine stdlib${ii}$_clartv( n, x, incx, y, incy, c, s, incc ) !! CLARTV applies a vector of complex plane rotations with real cosines !! to elements of the complex vectors x and y. For i = 1,2,...,n !! ( x(i) ) := ( c(i) s(i) ) ( x(i) ) @@ -12067,21 +12069,21 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(in) :: s(*) complex(sp), intent(inout) :: x(*), y(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ic, ix, iy + integer(${ik}$) :: i, ic, ix, iy complex(sp) :: xi, yi ! Intrinsic Functions intrinsic :: conjg ! 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 ) @@ -12092,10 +12094,10 @@ module stdlib_linalg_lapack_c ic = ic + incc end do return - end subroutine stdlib_clartv + end subroutine stdlib${ii}$_clartv - pure subroutine stdlib_clarz( side, m, n, l, v, incv, tau, c, ldc, work ) + pure subroutine stdlib${ii}$_clarz( side, m, n, l, v, incv, tau, c, ldc, work ) !! CLARZ applies a complex elementary reflector H to a complex !! M-by-N matrix C, from either the left or the right. H is represented !! in the form @@ -12110,7 +12112,7 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(in) :: tau ! Array Arguments complex(sp), intent(inout) :: c(ldc,*) @@ -12123,38 +12125,38 @@ module stdlib_linalg_lapack_c ! form h * c if( tau/=czero ) then ! w( 1:n ) = conjg( c( 1, 1:n ) ) - call stdlib_ccopy( n, c, ldc, work, 1 ) - call stdlib_clacgv( n, work, 1 ) + call stdlib${ii}$_ccopy( n, c, ldc, work, 1_${ik}$ ) + call stdlib${ii}$_clacgv( n, work, 1_${ik}$ ) ! w( 1:n ) = conjg( w( 1:n ) + c( m-l+1:m, 1:n )**h * v( 1:l ) ) - call stdlib_cgemv( 'CONJUGATE TRANSPOSE', l, n, cone, c( m-l+1, 1 ),ldc, v, incv,& - cone, work, 1 ) - call stdlib_clacgv( n, work, 1 ) + call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', l, n, cone, c( m-l+1, 1_${ik}$ ),ldc, v, incv,& + cone, work, 1_${ik}$ ) + call stdlib${ii}$_clacgv( n, work, 1_${ik}$ ) ! c( 1, 1:n ) = c( 1, 1:n ) - tau * w( 1:n ) - call stdlib_caxpy( n, -tau, work, 1, c, ldc ) + call stdlib${ii}$_caxpy( n, -tau, work, 1_${ik}$, c, ldc ) ! c( m-l+1:m, 1:n ) = c( m-l+1:m, 1:n ) - ... ! tau * v( 1:l ) * w( 1:n )**h - call stdlib_cgeru( l, n, -tau, v, incv, work, 1, c( m-l+1, 1 ),ldc ) + call stdlib${ii}$_cgeru( l, n, -tau, v, incv, work, 1_${ik}$, c( m-l+1, 1_${ik}$ ),ldc ) end if else ! form c * h if( tau/=czero ) then ! w( 1:m ) = c( 1:m, 1 ) - call stdlib_ccopy( m, c, 1, work, 1 ) + call stdlib${ii}$_ccopy( m, c, 1_${ik}$, work, 1_${ik}$ ) ! w( 1:m ) = w( 1:m ) + c( 1:m, n-l+1:n, 1:n ) * v( 1:l ) - call stdlib_cgemv( 'NO TRANSPOSE', m, l, cone, c( 1, n-l+1 ), ldc,v, incv, cone, & - work, 1 ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', m, l, cone, c( 1_${ik}$, n-l+1 ), ldc,v, incv, cone, & + work, 1_${ik}$ ) ! c( 1:m, 1 ) = c( 1:m, 1 ) - tau * w( 1:m ) - call stdlib_caxpy( m, -tau, work, 1, c, 1 ) + call stdlib${ii}$_caxpy( m, -tau, work, 1_${ik}$, c, 1_${ik}$ ) ! c( 1:m, n-l+1:n ) = c( 1:m, n-l+1:n ) - ... ! tau * w( 1:m ) * v( 1:l )**h - call stdlib_cgerc( m, l, -tau, work, 1, v, incv, c( 1, n-l+1 ),ldc ) + call stdlib${ii}$_cgerc( m, l, -tau, work, 1_${ik}$, v, incv, c( 1_${ik}$, n-l+1 ),ldc ) end if end if return - end subroutine stdlib_clarz + end subroutine stdlib${ii}$_clarz - pure subroutine stdlib_clarzb( side, trans, direct, storev, m, n, k, l, v,ldv, t, ldt, c, & + pure subroutine stdlib${ii}$_clarzb( side, trans, direct, storev, m, n, k, l, v,ldv, t, ldt, c, & !! CLARZB applies a complex block reflector H or its transpose H**H !! to a complex distributed M-by-N C from the left or the right. !! Currently, only STOREV = 'R' and DIRECT = 'B' are supported. @@ -12164,7 +12166,7 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: c(ldc,*), t(ldt,*), v(ldv,*) complex(sp), intent(out) :: work(ldwork,*) @@ -12172,19 +12174,19 @@ module stdlib_linalg_lapack_c ! 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( 'CLARZB', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'CLARZB', -info ) return end if if( stdlib_lsame( trans, 'N' ) ) then @@ -12196,14 +12198,14 @@ module stdlib_linalg_lapack_c ! form h * c or h**h * c ! w( 1:n, 1:k ) = c( 1:k, 1:n )**h do j = 1, k - call stdlib_ccopy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib${ii}$_ccopy( 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 )**h * v( 1:k, 1:l )**t - if( l>0 )call stdlib_cgemm( 'TRANSPOSE', 'CONJUGATE TRANSPOSE', n, k, l,cone, c( m-& - l+1, 1 ), ldc, v, ldv, cone, work,ldwork ) + if( l>0_${ik}$ )call stdlib${ii}$_cgemm( 'TRANSPOSE', 'CONJUGATE TRANSPOSE', n, k, l,cone, c( m-& + l+1, 1_${ik}$ ), ldc, v, ldv, cone, work,ldwork ) ! w( 1:n, 1:k ) = w( 1:n, 1:k ) * t**t or w( 1:m, 1:k ) * t - call stdlib_ctrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k, cone, t,ldt, work, & + call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k, cone, t,ldt, work, & ldwork ) ! c( 1:k, 1:n ) = c( 1:k, 1:n ) - w( 1:n, 1:k )**h do j = 1, n @@ -12213,27 +12215,27 @@ module stdlib_linalg_lapack_c end do ! c( m-l+1:m, 1:n ) = c( m-l+1:m, 1:n ) - ... ! v( 1:k, 1:l )**h * w( 1:n, 1:k )**h - if( l>0 )call stdlib_cgemm( 'TRANSPOSE', 'TRANSPOSE', l, n, k, -cone, v, ldv,work, & - ldwork, cone, c( m-l+1, 1 ), ldc ) + if( l>0_${ik}$ )call stdlib${ii}$_cgemm( 'TRANSPOSE', 'TRANSPOSE', l, n, k, -cone, v, ldv,work, & + ldwork, cone, c( m-l+1, 1_${ik}$ ), ldc ) else if( stdlib_lsame( side, 'R' ) ) then ! form c * h or c * h**h ! w( 1:m, 1:k ) = c( 1:m, 1:k ) do j = 1, k - call stdlib_ccopy( m, c( 1, j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_ccopy( 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 )**h - if( l>0 )call stdlib_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, l, cone,c( 1, n-l+1 )& + if( l>0_${ik}$ )call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, l, cone,c( 1_${ik}$, n-l+1 )& , ldc, v, ldv, cone, work, ldwork ) ! w( 1:m, 1:k ) = w( 1:m, 1:k ) * conjg( t ) or ! w( 1:m, 1:k ) * t**h do j = 1, k - call stdlib_clacgv( k-j+1, t( j, j ), 1 ) + call stdlib${ii}$_clacgv( k-j+1, t( j, j ), 1_${ik}$ ) end do - call stdlib_ctrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k, cone, t,ldt, work, & + call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k, cone, t,ldt, work, & ldwork ) do j = 1, k - call stdlib_clacgv( k-j+1, t( j, j ), 1 ) + call stdlib${ii}$_clacgv( k-j+1, t( j, j ), 1_${ik}$ ) end do ! c( 1:m, 1:k ) = c( 1:m, 1:k ) - w( 1:m, 1:k ) do j = 1, k @@ -12244,19 +12246,19 @@ module stdlib_linalg_lapack_c ! c( 1:m, n-l+1:n ) = c( 1:m, n-l+1:n ) - ... ! w( 1:m, 1:k ) * conjg( v( 1:k, 1:l ) ) do j = 1, l - call stdlib_clacgv( k, v( 1, j ), 1 ) + call stdlib${ii}$_clacgv( k, v( 1_${ik}$, j ), 1_${ik}$ ) end do - if( l>0 )call stdlib_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, l, k, -cone,work, & - ldwork, v, ldv, cone, c( 1, n-l+1 ), ldc ) + if( l>0_${ik}$ )call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, l, k, -cone,work, & + ldwork, v, ldv, cone, c( 1_${ik}$, n-l+1 ), ldc ) do j = 1, l - call stdlib_clacgv( k, v( 1, j ), 1 ) + call stdlib${ii}$_clacgv( k, v( 1_${ik}$, j ), 1_${ik}$ ) end do end if return - end subroutine stdlib_clarzb + end subroutine stdlib${ii}$_clarzb - pure subroutine stdlib_clarzt( direct, storev, n, k, v, ldv, tau, t, ldt ) + pure subroutine stdlib${ii}$_clarzt( direct, storev, n, k, v, ldv, tau, t, ldt ) !! CLARZT forms the triangular factor T of a complex block reflector !! H of order > n, which is defined as a product of k elementary !! reflectors. @@ -12274,7 +12276,7 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(out) :: t(ldt,*) complex(sp), intent(in) :: tau(*) @@ -12282,17 +12284,17 @@ module stdlib_linalg_lapack_c ! ===================================================================== ! 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( 'CLARZT', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'CLARZT', -info ) return end if do i = k, 1, -1 @@ -12305,22 +12307,22 @@ module stdlib_linalg_lapack_c ! general case if( i=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 = -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 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 ax = abs(aimag(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 @@ -12886,12 +12888,12 @@ module stdlib_linalg_lapack_c 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 @@ -12916,7 +12918,7 @@ module stdlib_linalg_lapack_c 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 @@ -12927,42 +12929,42 @@ module stdlib_linalg_lapack_c sumsq = amed end if return - end subroutine stdlib_classq + end subroutine stdlib${ii}$_classq - pure subroutine stdlib_claswp( n, a, lda, k1, k2, ipiv, incx ) + pure subroutine stdlib${ii}$_claswp( n, a, lda, k1, k2, ipiv, incx ) !! CLASWP performs a series of row interchanges on the matrix A. !! One row interchange is initiated for each of rows K1 through K2 of A. ! -- lapack auxiliary routine -- ! -- 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, k1, k2, lda, n + integer(${ik}$), intent(in) :: incx, k1, k2, lda, n ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) complex(sp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, i1, i2, inc, ip, ix, ix0, j, k, n32 + integer(${ik}$) :: i, i1, i2, inc, ip, ix, ix0, j, k, n32 complex(sp) :: temp ! Executable Statements ! interchange row i with row ipiv(k1+(i-k1)*abs(incx)) for each of rows ! k1 through k2. - if( incx>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 @@ -12979,7 +12981,7 @@ module stdlib_linalg_lapack_c 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 ) @@ -12994,10 +12996,10 @@ module stdlib_linalg_lapack_c end do end if return - end subroutine stdlib_claswp + end subroutine stdlib${ii}$_claswp - pure subroutine stdlib_clasyf( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) + pure subroutine stdlib${ii}$_clasyf( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) !! CLASYF computes a partial factorization of a complex symmetric matrix !! A using the Bunch-Kaufman diagonal pivoting method. The partial !! factorization has the form: @@ -13016,10 +13018,10 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: w(ldw,*) ! ===================================================================== @@ -13029,7 +13031,7 @@ module stdlib_linalg_lapack_c ! 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, rowmax complex(sp) :: d11, d21, d22, r1, t, z ! Intrinsic Functions @@ -13039,7 +13041,7 @@ module stdlib_linalg_lapack_c ! Statement Function Definitions cabs1( z ) = abs( real( z,KIND=sp) ) + abs( aimag( z ) ) ! 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 @@ -13054,25 +13056,25 @@ module stdlib_linalg_lapack_c ! exit from loop if( ( k<=n-nb+1 .and. nb1 ) then - imax = stdlib_icamax( k-1, w( 1, kw ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_icamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) colmax = cabs1( w( imax, kw ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k else if( absakk>=alpha*colmax ) then @@ -13080,17 +13082,17 @@ module stdlib_linalg_lapack_c kp = k else ! copy column imax to column kw-1 of w and update it - call stdlib_ccopy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) - call stdlib_ccopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_ccopy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) + call stdlib${ii}$_ccopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ ) - if( k1 ) then - jmax = stdlib_icamax( imax-1, w( 1, kw-1 ), 1 ) + if( imax>1_${ik}$ ) then + jmax = stdlib${ii}$_icamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) rowmax = max( rowmax, cabs1( w( jmax, kw-1 ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then @@ -13101,17 +13103,17 @@ module stdlib_linalg_lapack_c ! pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_ccopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_ccopy( 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 ! 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. @@ -13122,16 +13124,16 @@ module stdlib_linalg_lapack_c ! (or k and k-1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = a( kk, kk ) - call stdlib_ccopy( kk-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - if( kp>1 )call stdlib_ccopy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_ccopy( kk-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_ccopy( 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 ! later overwritten). interchange rows kk and kp ! in last kkw to nb columns of w. - if( k2 ) then + if( k>2_${ik}$ ) then ! compose the columns of the inverse of 2-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 @@ -13194,7 +13196,7 @@ module stdlib_linalg_lapack_c 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 @@ -13211,31 +13213,31 @@ module stdlib_linalg_lapack_c jb = min( nb, k-j+1 ) ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_cgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& - kw+1 ), ldw, cone,a( j, jj ), 1 ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& + kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ ) end do ! update the rectangular superdiagonal block - call stdlib_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( 1, k+1 ), & - lda, w( j, kw+1 ), ldw,cone, a( 1, j ), lda ) + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( 1_${ik}$, k+1 ), & + lda, w( j, kw+1 ), ldw,cone, a( 1_${ik}$, j ), lda ) end do ! put u12 in standard form by partially undoing the interchanges ! in columns k+1:n 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_cswap( n-j+1, a( jp, j ), lda, a( jj, j ), & + j = j + 1_${ik}$ + if( jp/=jj .and. j<=n )call stdlib${ii}$_cswap( 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_ccopy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) - call stdlib_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ), lda,w( k, 1 ), ldw,& - cone, w( k, k ), 1 ) - kstep = 1 + call stdlib${ii}$_ccopy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ), lda,w( k, 1_${ik}$ ), ldw,& + cone, w( k, k ), 1_${ik}$ ) + 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 absakk = cabs1( w( k, k ) ) @@ -13261,14 +13263,14 @@ module stdlib_linalg_lapack_c ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k=alpha*colmax ) then @@ -13276,16 +13278,16 @@ module stdlib_linalg_lapack_c kp = k else ! copy column imax to column k+1 of w and update it - call stdlib_ccopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1 ) - call stdlib_ccopy( n-imax+1, a( imax, imax ), 1, w( imax, k+1 ),1 ) - call stdlib_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ),lda, w( imax, & - 1 ), ldw, cone, w( k, k+1 ),1 ) + call stdlib${ii}$_ccopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$ ) + call stdlib${ii}$_ccopy( n-imax+1, a( imax, imax ), 1_${ik}$, w( imax, k+1 ),1_${ik}$ ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ),lda, w( imax, & + 1_${ik}$ ), ldw, cone, w( k, k+1 ),1_${ik}$ ) ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value - jmax = k - 1 + stdlib_icamax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1_${ik}$ + stdlib${ii}$_icamax( imax-k, w( k, k+1 ), 1_${ik}$ ) rowmax = cabs1( w( jmax, k+1 ) ) if( imax=alpha*colmax*( colmax / rowmax ) ) then @@ -13296,17 +13298,17 @@ module stdlib_linalg_lapack_c ! pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_ccopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_ccopy( 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 ! 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 @@ -13315,17 +13317,17 @@ module stdlib_linalg_lapack_c ! (or k and k+1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = a( kk, kk ) - call stdlib_ccopy( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),lda ) - if( kp1 )call stdlib_cswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_cswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + if( k>1_${ik}$ )call stdlib${ii}$_cswap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) + call stdlib${ii}$_cswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of w now holds ! w(k) = l(k)*d(k), ! where l(k) is the k-th column of l @@ -13335,10 +13337,10 @@ module stdlib_linalg_lapack_c ! 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_ccopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib${ii}$_ccopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ ) if( k=1 )call stdlib_cswap( j, a( jp, 1 ), lda, a( jj, 1 ), lda ) + j = j - 1_${ik}$ + if( jp/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_cswap( 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_clasyf + end subroutine stdlib${ii}$_clasyf - pure subroutine stdlib_clasyf_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info ) + pure subroutine stdlib${ii}$_clasyf_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info ) !! CLASYF_RK computes a partial factorization of a complex symmetric !! matrix A using the bounded Bunch-Kaufman (rook) diagonal !! pivoting method. The partial factorization has the form: @@ -13459,10 +13461,10 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: e(*), w(ldw,*) ! ===================================================================== @@ -13473,7 +13475,7 @@ module stdlib_linalg_lapack_c ! 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, rowmax, sfmin, stemp complex(sp) :: d11, d12, d21, d22, r1, t, z ! Intrinsic Functions @@ -13483,18 +13485,18 @@ module stdlib_linalg_lapack_c ! Statement Function Definitions cabs1( z ) = abs( real( z,KIND=sp) ) + abs( aimag( z ) ) ! 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 ) = czero + e( 1_${ik}$ ) = czero ! k is the main loop index, decreasing from n in steps of 1 or 2 k = n 10 continue @@ -13502,31 +13504,31 @@ module stdlib_linalg_lapack_c kw = nb + k - n ! exit from loop if( ( k<=n-nb+1 .and. nb1 ) then - imax = stdlib_icamax( k-1, w( 1, kw ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_icamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) colmax = cabs1( w( imax, kw ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k - call stdlib_ccopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) + call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) ! set e( k ) to zero - if( k>1 )e( k ) = czero + if( k>1_${ik}$ )e( k ) = czero else ! ============================================================ ! test for interchange @@ -13541,22 +13543,22 @@ module stdlib_linalg_lapack_c 12 continue ! begin pivot search loop body ! copy column imax to column kw-1 of w and update it - call stdlib_ccopy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) - call stdlib_ccopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_ccopy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) + call stdlib${ii}$_ccopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ ) - if( k1 ) then - itemp = stdlib_icamax( imax-1, w( 1, kw-1 ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_icamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) stemp = cabs1( w( itemp, kw-1 ) ) if( stemp>rowmax ) then rowmax = stemp @@ -13571,7 +13573,7 @@ module stdlib_linalg_lapack_c ! use 1-by-1 pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_ccopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -13579,7 +13581,7 @@ module stdlib_linalg_lapack_c ! interchange rows and columns k-1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found: set params and repeat @@ -13587,45 +13589,45 @@ module stdlib_linalg_lapack_c colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_ccopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) end if ! end pivot search loop body if( .not. done ) goto 12 end if ! ============================================================ - kk = k - kstep + 1 + kk = k - kstep + 1_${ik}$ ! kkw is the column of w which corresponds to column kk of a kkw = nb + kk - n - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_ccopy( k-p, a( p+1, k ), 1, a( p, p+1 ), lda ) - call stdlib_ccopy( p, a( 1, k ), 1, a( 1, p ), 1 ) + call stdlib${ii}$_ccopy( k-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ), lda ) + call stdlib${ii}$_ccopy( p, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) ! interchange rows k and p in last n-k+1 columns of a ! and last n-k+2 columns of w - call stdlib_cswap( n-k+1, a( k, k ), lda, a( p, k ), lda ) - call stdlib_cswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw ) + call stdlib${ii}$_cswap( n-k+1, a( k, k ), lda, a( p, k ), lda ) + call stdlib${ii}$_cswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw ) end if ! updated column kp is already stored in column kkw of w if( kp/=kk ) then ! copy non-updated column kk to column kp a( kp, k ) = a( kk, k ) - call stdlib_ccopy( k-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - call stdlib_ccopy( kp, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_ccopy( k-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) + call stdlib${ii}$_ccopy( kp, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) ! interchange rows kk and kp in last n-kk+1 columns ! of a and w - call stdlib_cswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) - call stdlib_cswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) + call stdlib${ii}$_cswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) + call stdlib${ii}$_cswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column kw of w now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u ! store u(k) in column k of a - call stdlib_ccopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) - if( k>1 ) then + call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) + if( k>1_${ik}$ ) then if( cabs1( a( k, k ) )>=sfmin ) then r1 = cone / a( k, k ) - call stdlib_cscal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_cscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) else if( a( k, k )/=czero ) then do ii = 1, k - 1 a( ii, k ) = a( ii, k ) / a( k, k ) @@ -13640,7 +13642,7 @@ module stdlib_linalg_lapack_c ! ( 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 @@ -13663,7 +13665,7 @@ module stdlib_linalg_lapack_c ! 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 @@ -13680,12 +13682,12 @@ module stdlib_linalg_lapack_c jb = min( nb, k-j+1 ) ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_cgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& - kw+1 ), ldw, cone,a( j, jj ), 1 ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& + kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ ) end do ! update the rectangular superdiagonal block - if( j>=2 )call stdlib_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -cone, a( & - 1, k+1 ), lda, w( j, kw+1 ),ldw, cone, a( 1, j ), lda ) + if( j>=2_${ik}$ )call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -cone, a( & + 1_${ik}$, k+1 ), lda, w( j, kw+1 ),ldw, cone, a( 1_${ik}$, j ), lda ) end do ! set kb to the number of columns factorized kb = n - k @@ -13696,16 +13698,16 @@ module stdlib_linalg_lapack_c ! initialize the unused last entry of the subdiagonal array e. e( n ) = czero ! k is the main loop index, increasing from 1 in steps of 1 or 2 - k = 1 + 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_ccopy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) - if( k>1 )call stdlib_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ),lda, w( k, & - 1 ), ldw, cone, w( k, k ), 1 ) + call stdlib${ii}$_ccopy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ ) + if( k>1_${ik}$ )call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ),lda, w( k, & + 1_${ik}$ ), ldw, cone, w( k, k ), 1_${ik}$ ) ! determine rows and columns to be interchanged and whether ! a 1-by-1 or 2-by-2 pivot block will be used absakk = cabs1( w( k, k ) ) @@ -13713,16 +13715,16 @@ module stdlib_linalg_lapack_c ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k1 )call stdlib_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1 ), & - lda, w( imax, 1 ), ldw,cone, w( k, k+1 ), 1 ) + call stdlib${ii}$_ccopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$) + call stdlib${ii}$_ccopy( n-imax+1, a( imax, imax ), 1_${ik}$,w( imax, k+1 ), 1_${ik}$ ) + if( k>1_${ik}$ )call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1_${ik}$ ), & + lda, w( imax, 1_${ik}$ ), ldw,cone, w( k, k+1 ), 1_${ik}$ ) ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = k - 1 + stdlib_icamax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1_${ik}$ + stdlib${ii}$_icamax( imax-k, w( k, k+1 ), 1_${ik}$ ) rowmax = cabs1( w( jmax, k+1 ) ) else rowmax = zero end if if( imaxrowmax ) then rowmax = stemp @@ -13768,7 +13770,7 @@ module stdlib_linalg_lapack_c ! use 1-by-1 pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_ccopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_ccopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -13776,7 +13778,7 @@ module stdlib_linalg_lapack_c ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found: set params and repeat @@ -13784,42 +13786,42 @@ module stdlib_linalg_lapack_c colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_ccopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_ccopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) end if ! end pivot search loop body if( .not. done ) goto 72 end if ! ============================================================ - kk = k + kstep - 1 - if( ( kstep==2 ) .and. ( p/=k ) ) then + kk = k + kstep - 1_${ik}$ + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_ccopy( p-k, a( k, k ), 1, a( p, k ), lda ) - call stdlib_ccopy( n-p+1, a( p, k ), 1, a( p, p ), 1 ) + call stdlib${ii}$_ccopy( p-k, a( k, k ), 1_${ik}$, a( p, k ), lda ) + call stdlib${ii}$_ccopy( n-p+1, a( p, k ), 1_${ik}$, a( p, p ), 1_${ik}$ ) ! interchange rows k and p in first k columns of a ! and first k+1 columns of w - call stdlib_cswap( k, a( k, 1 ), lda, a( p, 1 ), lda ) - call stdlib_cswap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw ) + call stdlib${ii}$_cswap( k, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda ) + call stdlib${ii}$_cswap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw ) end if ! updated column kp is already stored in column kk of w if( kp/=kk ) then ! copy non-updated column kk to column kp a( kp, k ) = a( kk, k ) - call stdlib_ccopy( kp-k-1, a( k+1, kk ), 1, a( kp, k+1 ), lda ) - call stdlib_ccopy( n-kp+1, a( kp, kk ), 1, a( kp, kp ), 1 ) + call stdlib${ii}$_ccopy( kp-k-1, a( k+1, kk ), 1_${ik}$, a( kp, k+1 ), lda ) + call stdlib${ii}$_ccopy( n-kp+1, a( kp, kk ), 1_${ik}$, a( kp, kp ), 1_${ik}$ ) ! interchange rows kk and kp in first kk columns of a and w - call stdlib_cswap( kk, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_cswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + call stdlib${ii}$_cswap( kk, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) + call stdlib${ii}$_cswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of w now holds ! w(k) = l(k)*d(k) ! where l(k) is the k-th column of l ! store l(k) in column k of a - call stdlib_ccopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib${ii}$_ccopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ ) if( k=sfmin ) then r1 = cone / a( k, k ) - call stdlib_cscal( n-k, r1, a( k+1, k ), 1 ) + call stdlib${ii}$_cscal( n-k, r1, a( k+1, k ), 1_${ik}$ ) else if( a( k, k )/=czero ) then do ii = k + 1, n a( ii, k ) = a( ii, k ) / a( k, k ) @@ -13856,7 +13858,7 @@ module stdlib_linalg_lapack_c ! 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 @@ -13873,21 +13875,21 @@ module stdlib_linalg_lapack_c jb = min( nb, n-j+1 ) ! update the lower triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_cgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1 ), lda, w( jj,& - 1 ), ldw, cone,a( jj, jj ), 1 ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1_${ik}$ ), lda, w( jj,& + 1_${ik}$ ), ldw, cone,a( jj, jj ), 1_${ik}$ ) end do ! update the rectangular subdiagonal block - if( j+jb<=n )call stdlib_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& - cone, a( j+jb, 1 ), lda, w( j, 1 ),ldw, cone, a( j+jb, j ), lda ) + if( j+jb<=n )call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& + cone, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ),ldw, cone, a( j+jb, j ), lda ) end do ! set kb to the number of columns factorized - kb = k - 1 + kb = k - 1_${ik}$ end if return - end subroutine stdlib_clasyf_rk + end subroutine stdlib${ii}$_clasyf_rk - pure subroutine stdlib_clasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) + pure subroutine stdlib${ii}$_clasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) !! CLASYF_ROOK computes a partial factorization of a complex symmetric !! matrix A using the bounded Bunch-Kaufman ("rook") diagonal !! pivoting method. The partial factorization has the form: @@ -13905,10 +13907,10 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: w(ldw,*) ! ===================================================================== @@ -13919,7 +13921,7 @@ module stdlib_linalg_lapack_c ! 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, rowmax, stemp, sfmin complex(sp) :: d11, d12, d21, d22, r1, t, z @@ -13930,11 +13932,11 @@ module stdlib_linalg_lapack_c ! Statement Function Definitions cabs1( z ) = abs( real( z,KIND=sp) ) + abs( aimag( z ) ) ! 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 @@ -13946,29 +13948,29 @@ module stdlib_linalg_lapack_c kw = nb + k - n ! exit from loop if( ( k<=n-nb+1 .and. nb1 ) then - imax = stdlib_icamax( k-1, w( 1, kw ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_icamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) colmax = cabs1( w( imax, kw ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k - call stdlib_ccopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) + call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) else ! ============================================================ ! test for interchange @@ -13983,22 +13985,22 @@ module stdlib_linalg_lapack_c 12 continue ! begin pivot search loop body ! copy column imax to column kw-1 of w and update it - call stdlib_ccopy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) - call stdlib_ccopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_ccopy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) + call stdlib${ii}$_ccopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ ) - if( k1 ) then - itemp = stdlib_icamax( imax-1, w( 1, kw-1 ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_icamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) stemp = cabs1( w( itemp, kw-1 ) ) if( stemp>rowmax ) then rowmax = stemp @@ -14013,7 +14015,7 @@ module stdlib_linalg_lapack_c ! use 1-by-1 pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_ccopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -14021,7 +14023,7 @@ module stdlib_linalg_lapack_c ! interchange rows and columns k-1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found: set params and repeat @@ -14029,45 +14031,45 @@ module stdlib_linalg_lapack_c colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_ccopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) end if ! end pivot search loop body if( .not. done ) goto 12 end if ! ============================================================ - kk = k - kstep + 1 + kk = k - kstep + 1_${ik}$ ! kkw is the column of w which corresponds to column kk of a kkw = nb + kk - n - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_ccopy( k-p, a( p+1, k ), 1, a( p, p+1 ), lda ) - call stdlib_ccopy( p, a( 1, k ), 1, a( 1, p ), 1 ) + call stdlib${ii}$_ccopy( k-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ), lda ) + call stdlib${ii}$_ccopy( p, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) ! interchange rows k and p in last n-k+1 columns of a ! and last n-k+2 columns of w - call stdlib_cswap( n-k+1, a( k, k ), lda, a( p, k ), lda ) - call stdlib_cswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw ) + call stdlib${ii}$_cswap( n-k+1, a( k, k ), lda, a( p, k ), lda ) + call stdlib${ii}$_cswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw ) end if ! updated column kp is already stored in column kkw of w if( kp/=kk ) then ! copy non-updated column kk to column kp a( kp, k ) = a( kk, k ) - call stdlib_ccopy( k-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - call stdlib_ccopy( kp, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_ccopy( k-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) + call stdlib${ii}$_ccopy( kp, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) ! interchange rows kk and kp in last n-kk+1 columns ! of a and w - call stdlib_cswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) - call stdlib_cswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) + call stdlib${ii}$_cswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) + call stdlib${ii}$_cswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column kw of w now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u ! store u(k) in column k of a - call stdlib_ccopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) - if( k>1 ) then + call stdlib${ii}$_ccopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) + if( k>1_${ik}$ ) then if( cabs1( a( k, k ) )>=sfmin ) then r1 = cone / a( k, k ) - call stdlib_cscal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_cscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) else if( a( k, k )/=czero ) then do ii = 1, k - 1 a( ii, k ) = a( ii, k ) / a( k, k ) @@ -14080,7 +14082,7 @@ module stdlib_linalg_lapack_c ! ( 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 @@ -14098,7 +14100,7 @@ module stdlib_linalg_lapack_c 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 @@ -14115,32 +14117,32 @@ module stdlib_linalg_lapack_c jb = min( nb, k-j+1 ) ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_cgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& - kw+1 ), ldw, cone,a( j, jj ), 1 ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& + kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ ) end do ! update the rectangular superdiagonal block - if( j>=2 )call stdlib_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -cone, a( & - 1, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1, j ), lda ) + if( j>=2_${ik}$ )call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -cone, a( & + 1_${ik}$, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1_${ik}$, j ), lda ) end do ! put u12 in standard form by partially undoing the interchanges ! in columns k+1:n - j = k + 1 + 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_cswap( n-j+1, a( jp2, j ), lda, a( jj, j ), & + j = j + 1_${ik}$ + if( jp2/=jj .and. j<=n )call stdlib${ii}$_cswap( n-j+1, a( jp2, j ), lda, a( jj, j ), & lda ) - jj = j - 1 - if( jp1/=jj .and. kstep==2 )call stdlib_cswap( n-j+1, a( jp1, j ), lda, a( jj, j & + jj = j - 1_${ik}$ + if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_cswap( n-j+1, a( jp1, j ), lda, a( jj, j & ), lda ) if( j<=n )go to 60 ! set kb to the number of columns factorized @@ -14150,16 +14152,16 @@ module stdlib_linalg_lapack_c ! 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 = 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_ccopy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) - if( k>1 )call stdlib_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ),lda, w( k, & - 1 ), ldw, cone, w( k, k ), 1 ) + call stdlib${ii}$_ccopy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ ) + if( k>1_${ik}$ )call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ),lda, w( k, & + 1_${ik}$ ), ldw, cone, w( k, k ), 1_${ik}$ ) ! determine rows and columns to be interchanged and whether ! a 1-by-1 or 2-by-2 pivot block will be used absakk = cabs1( w( k, k ) ) @@ -14167,16 +14169,16 @@ module stdlib_linalg_lapack_c ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k1 )call stdlib_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1 ), & - lda, w( imax, 1 ), ldw,cone, w( k, k+1 ), 1 ) + call stdlib${ii}$_ccopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$) + call stdlib${ii}$_ccopy( n-imax+1, a( imax, imax ), 1_${ik}$,w( imax, k+1 ), 1_${ik}$ ) + if( k>1_${ik}$ )call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1_${ik}$ ), & + lda, w( imax, 1_${ik}$ ), ldw,cone, w( k, k+1 ), 1_${ik}$ ) ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = k - 1 + stdlib_icamax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1_${ik}$ + stdlib${ii}$_icamax( imax-k, w( k, k+1 ), 1_${ik}$ ) rowmax = cabs1( w( jmax, k+1 ) ) else rowmax = zero end if if( imaxrowmax ) then rowmax = stemp @@ -14220,7 +14222,7 @@ module stdlib_linalg_lapack_c ! use 1-by-1 pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_ccopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_ccopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -14228,7 +14230,7 @@ module stdlib_linalg_lapack_c ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found: set params and repeat @@ -14236,42 +14238,42 @@ module stdlib_linalg_lapack_c colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_ccopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_ccopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) end if ! end pivot search loop body if( .not. done ) goto 72 end if ! ============================================================ - kk = k + kstep - 1 - if( ( kstep==2 ) .and. ( p/=k ) ) then + kk = k + kstep - 1_${ik}$ + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_ccopy( p-k, a( k, k ), 1, a( p, k ), lda ) - call stdlib_ccopy( n-p+1, a( p, k ), 1, a( p, p ), 1 ) + call stdlib${ii}$_ccopy( p-k, a( k, k ), 1_${ik}$, a( p, k ), lda ) + call stdlib${ii}$_ccopy( n-p+1, a( p, k ), 1_${ik}$, a( p, p ), 1_${ik}$ ) ! interchange rows k and p in first k columns of a ! and first k+1 columns of w - call stdlib_cswap( k, a( k, 1 ), lda, a( p, 1 ), lda ) - call stdlib_cswap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw ) + call stdlib${ii}$_cswap( k, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda ) + call stdlib${ii}$_cswap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw ) end if ! updated column kp is already stored in column kk of w if( kp/=kk ) then ! copy non-updated column kk to column kp a( kp, k ) = a( kk, k ) - call stdlib_ccopy( kp-k-1, a( k+1, kk ), 1, a( kp, k+1 ), lda ) - call stdlib_ccopy( n-kp+1, a( kp, kk ), 1, a( kp, kp ), 1 ) + call stdlib${ii}$_ccopy( kp-k-1, a( k+1, kk ), 1_${ik}$, a( kp, k+1 ), lda ) + call stdlib${ii}$_ccopy( n-kp+1, a( kp, kk ), 1_${ik}$, a( kp, kp ), 1_${ik}$ ) ! interchange rows kk and kp in first kk columns of a and w - call stdlib_cswap( kk, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_cswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + call stdlib${ii}$_cswap( kk, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) + call stdlib${ii}$_cswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of w now holds ! w(k) = l(k)*d(k) ! where l(k) is the k-th column of l ! store l(k) in column k of a - call stdlib_ccopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib${ii}$_ccopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ ) if( k=sfmin ) then r1 = cone / a( k, k ) - call stdlib_cscal( n-k, r1, a( k+1, k ), 1 ) + call stdlib${ii}$_cscal( n-k, r1, a( k+1, k ), 1_${ik}$ ) else if( a( k, k )/=czero ) then do ii = k + 1, n a( ii, k ) = a( ii, k ) / a( k, k ) @@ -14301,7 +14303,7 @@ module stdlib_linalg_lapack_c 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 @@ -14318,42 +14320,42 @@ module stdlib_linalg_lapack_c jb = min( nb, n-j+1 ) ! update the lower triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_cgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1 ), lda, w( jj,& - 1 ), ldw, cone,a( jj, jj ), 1 ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1_${ik}$ ), lda, w( jj,& + 1_${ik}$ ), ldw, cone,a( jj, jj ), 1_${ik}$ ) end do ! update the rectangular subdiagonal block - if( j+jb<=n )call stdlib_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& - cone, a( j+jb, 1 ), lda, w( j, 1 ), ldw,cone, a( j+jb, j ), lda ) + if( j+jb<=n )call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& + cone, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ), ldw,cone, a( j+jb, j ), lda ) end do ! put l21 in standard form by partially undoing the interchanges ! in columns 1:k-1 - j = k - 1 + 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_cswap( j, a( jp2, 1 ), lda, a( jj, 1 ), lda ) + j = j - 1_${ik}$ + if( jp2/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_cswap( j, a( jp2, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda ) - jj = j + 1 - if( jp1/=jj .and. kstep==2 )call stdlib_cswap( j, a( jp1, 1 ), lda, a( jj, 1 ), & + jj = j + 1_${ik}$ + if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_cswap( j, a( jp1, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), & lda ) if( j>=1 )go to 120 ! set kb to the number of columns factorized - kb = k - 1 + kb = k - 1_${ik}$ end if return - end subroutine stdlib_clasyf_rook + end subroutine stdlib${ii}$_clasyf_rook - pure subroutine stdlib_clatbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm, & + pure subroutine stdlib${ii}$_clatbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm, & !! CLATBS solves one of the triangular systems !! A * x = s*b, A**T * x = s*b, or A**H * x = s*b, !! with scaling to prevent overflow, where A is an upper or lower @@ -14370,8 +14372,8 @@ module stdlib_linalg_lapack_c ! -- 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(inout) :: cnorm(*) @@ -14381,7 +14383,7 @@ module stdlib_linalg_lapack_c ! 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, tjj, tmax, tscal, xbnd, xj, xmax complex(sp) :: csumj, tjjs, uscal, zdum ! Intrinsic Functions @@ -14392,39 +14394,39 @@ module stdlib_linalg_lapack_c cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) ) cabs2( zdum ) = abs( real( zdum,KIND=sp) / 2. ) +abs( aimag( zdum ) / 2. ) ! 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_scasum( jlen, ab( 2, j ), 1 ) + if( jlen>0_${ik}$ ) then + cnorm( j ) = stdlib${ii}$_scasum( jlen, ab( 2_${ik}$, j ), 1_${ik}$ ) else cnorm( j ) = zero end if @@ -14449,16 +14451,16 @@ module stdlib_linalg_lapack_c end if ! scale the column norms by tscal if the maximum element in cnorm is ! greater than bignum/2. - imax = stdlib_isamax( n, cnorm, 1 ) + imax = stdlib${ii}$_isamax( n, cnorm, 1_${ik}$ ) tmax = cnorm( imax ) if( tmax<=bignum*half ) then tscal = one else tscal = half / ( 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_ctbsv can be used. + ! level 2 blas routine stdlib${ii}$_ctbsv can be used. xmax = zero do j = 1, n xmax = max( xmax, cabs2( x( j ) ) ) @@ -14468,14 +14470,14 @@ module stdlib_linalg_lapack_c ! 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 @@ -14523,15 +14525,15 @@ module stdlib_linalg_lapack_c else ! compute the growth in a**t * x = b or a**h * 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 @@ -14577,14 +14579,14 @@ module stdlib_linalg_lapack_c if( ( grow*tscal )>smlnum ) then ! use the level 2 blas solve if the reciprocal of the bound on ! elements of x is not too small. - call stdlib_ctbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1 ) + call stdlib${ii}$_ctbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1_${ik}$ ) else ! use a level 1 blas solve, scaling intermediate results. if( xmax>bignum*half ) then ! scale x so that its components are less than or equal to ! bignum in absolute value. scale = ( bignum*half ) / xmax - call stdlib_csscal( n, scale, x, 1 ) + call stdlib${ii}$_csscal( n, scale, x, 1_${ik}$ ) xmax = bignum else xmax = xmax*two @@ -14607,12 +14609,12 @@ module stdlib_linalg_lapack_c if( xj>tjj*bignum ) then ! scale x by 1/b(j). rec = one / xj - call stdlib_csscal( n, rec, x, 1 ) + call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_cladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) xj = cabs1( x( j ) ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: @@ -14625,11 +14627,11 @@ module stdlib_linalg_lapack_c ! multiplying x(j) times column j. rec = rec / cnorm( j ) end if - call stdlib_csscal( n, rec, x, 1 ) + call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_cladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) xj = cabs1( x( j ) ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and @@ -14650,23 +14652,23 @@ module stdlib_linalg_lapack_c if( cnorm( j )>( bignum-xmax )*rec ) then ! scale x by 1/(2*abs(x(j))). rec = rec*half - call stdlib_csscal( n, rec, x, 1 ) + call stdlib${ii}$_csscal( 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_csscal( n, half, x, 1 ) + call stdlib${ii}$_csscal( 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) jlen = min( kd, j-1 ) - call stdlib_caxpy( jlen, -x( j )*tscal,ab( kd+1-jlen, j ), 1, x( j-jlen & - ), 1 ) - i = stdlib_icamax( j-1, x, 1 ) + call stdlib${ii}$_caxpy( jlen, -x( j )*tscal,ab( kd+1-jlen, j ), 1_${ik}$, x( j-jlen & + ), 1_${ik}$ ) + i = stdlib${ii}$_icamax( j-1, x, 1_${ik}$ ) xmax = cabs1( x( i ) ) end if else if( j0 )call stdlib_caxpy( jlen, -x( j )*tscal, ab( 2, j ), 1,x( j+1 ),& - 1 ) - i = j + stdlib_icamax( n-j, x( j+1 ), 1 ) + if( jlen>0_${ik}$ )call stdlib${ii}$_caxpy( jlen, -x( j )*tscal, ab( 2_${ik}$, j ), 1_${ik}$,x( j+1 ),& + 1_${ik}$ ) + i = j + stdlib${ii}$_icamax( n-j, x( j+1 ), 1_${ik}$ ) xmax = cabs1( x( i ) ) end if end do loop_110 @@ -14700,10 +14702,10 @@ module stdlib_linalg_lapack_c if( tjj>one ) then ! divide by a(j,j) when scaling x if a(j,j) > 1. rec = min( one, rec*tjj ) - uscal = stdlib_cladiv( uscal, tjjs ) + uscal = stdlib${ii}$_cladiv( uscal, tjjs ) end if if( rec1 )csumj = stdlib_cdotu( jlen, ab( 2, j ), 1, x( j+1 ),1 ) + if( jlen>1_${ik}$ )csumj = stdlib${ii}$_cdotu( jlen, ab( 2_${ik}$, j ), 1_${ik}$, x( j+1 ),1_${ik}$ ) end if else @@ -14754,22 +14756,22 @@ module stdlib_linalg_lapack_c if( xj>tjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_csscal( n, rec, x, 1 ) + call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_cladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_csscal( n, rec, x, 1 ) + call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_cladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_cladiv( 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. @@ -14784,7 +14786,7 @@ module stdlib_linalg_lapack_c else ! compute x(j) := x(j) / a(j,j) - csumj if the dot ! product has already been divided by 1/a(j,j). - x( j ) = stdlib_cladiv( x( j ), tjjs ) - csumj + x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) - csumj end if xmax = max( xmax, cabs1( x( j ) ) ) end do loop_150 @@ -14808,10 +14810,10 @@ module stdlib_linalg_lapack_c if( tjj>one ) then ! divide by a(j,j) when scaling x if a(j,j) > 1. rec = min( one, rec*tjj ) - uscal = stdlib_cladiv( uscal, tjjs ) + uscal = stdlib${ii}$_cladiv( uscal, tjjs ) end if if( rec1 )csumj = stdlib_cdotc( jlen, ab( 2, j ), 1, x( j+1 ),1 ) + if( jlen>1_${ik}$ )csumj = stdlib${ii}$_cdotc( jlen, ab( 2_${ik}$, j ), 1_${ik}$, x( j+1 ),1_${ik}$ ) end if else @@ -14863,22 +14865,22 @@ module stdlib_linalg_lapack_c if( xj>tjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_csscal( n, rec, x, 1 ) + call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_cladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_csscal( n, rec, x, 1 ) + call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_cladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and ! scale = 0 and compute a solution to a**h *x = 0. @@ -14893,7 +14895,7 @@ module stdlib_linalg_lapack_c else ! compute x(j) := x(j) / a(j,j) - csumj if the dot ! product has already been divided by 1/a(j,j). - x( j ) = stdlib_cladiv( x( j ), tjjs ) - csumj + x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) - csumj end if xmax = max( xmax, cabs1( x( j ) ) ) end do loop_190 @@ -14902,13 +14904,13 @@ module stdlib_linalg_lapack_c 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_clatbs + end subroutine stdlib${ii}$_clatbs - pure subroutine stdlib_clatps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info ) + pure subroutine stdlib${ii}$_clatps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info ) !! CLATPS solves one of the triangular systems !! A * x = s*b, A**T * x = s*b, or A**H * x = s*b, !! with scaling to prevent overflow, where A is an upper or lower @@ -14926,8 +14928,8 @@ module stdlib_linalg_lapack_c ! -- 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(inout) :: cnorm(*) @@ -14937,7 +14939,7 @@ module stdlib_linalg_lapack_c ! 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, tjj, tmax, tscal, xbnd, xj, xmax complex(sp) :: csumj, tjjs, uscal, zdum ! Intrinsic Functions @@ -14948,68 +14950,68 @@ module stdlib_linalg_lapack_c cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) ) cabs2( zdum ) = abs( real( zdum,KIND=sp) / 2. ) +abs( aimag( zdum ) / 2. ) ! 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( 'CLATPS', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'CLATPS', -info ) return end if ! quick return if possible if( n==0 )return ! determine machine dependent parameters to control overflow. - smlnum = stdlib_slamch( 'SAFE MINIMUM' ) + smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) bignum = one / smlnum - call stdlib_slabad( smlnum, bignum ) - smlnum = smlnum / stdlib_slamch( 'PRECISION' ) + call stdlib${ii}$_slabad( smlnum, bignum ) + smlnum = smlnum / 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. if( upper ) then ! a is upper triangular. - ip = 1 + ip = 1_${ik}$ do j = 1, n - cnorm( j ) = stdlib_scasum( j-1, ap( ip ), 1 ) + cnorm( j ) = stdlib${ii}$_scasum( 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_scasum( n-j, ap( ip+1 ), 1 ) - ip = ip + n - j + 1 + cnorm( j ) = stdlib${ii}$_scasum( 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/2. - imax = stdlib_isamax( n, cnorm, 1 ) + imax = stdlib${ii}$_isamax( n, cnorm, 1_${ik}$ ) tmax = cnorm( imax ) if( tmax<=bignum*half ) then tscal = one else tscal = half / ( 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_ctpsv can be used. + ! level 2 blas routine stdlib${ii}$_ctpsv can be used. xmax = zero do j = 1, n xmax = max( xmax, cabs2( x( j ) ) ) @@ -15019,12 +15021,12 @@ module stdlib_linalg_lapack_c ! 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 @@ -15036,7 +15038,7 @@ module stdlib_linalg_lapack_c ! initially, g(0) = max{x(i), i=1,...,n}. grow = half / 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. @@ -15058,7 +15060,7 @@ module stdlib_linalg_lapack_c grow = zero end if ip = ip + jinc*jlen - jlen = jlen - 1 + jlen = jlen - 1_${ik}$ end do grow = xbnd else @@ -15076,13 +15078,13 @@ module stdlib_linalg_lapack_c else ! compute the growth in a**t * x = b or a**h * 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 @@ -15094,8 +15096,8 @@ module stdlib_linalg_lapack_c ! initially, m(0) = max{x(i), i=1,...,n}. grow = half / 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 90 @@ -15111,7 +15113,7 @@ module stdlib_linalg_lapack_c ! m(j) could overflow, set xbnd to 0. xbnd = zero end if - jlen = jlen + 1 + jlen = jlen + 1_${ik}$ ip = ip + jinc*jlen end do grow = min( grow, xbnd ) @@ -15132,21 +15134,21 @@ module stdlib_linalg_lapack_c if( ( grow*tscal )>smlnum ) then ! use the level 2 blas solve if the reciprocal of the bound on ! elements of x is not too small. - call stdlib_ctpsv( uplo, trans, diag, n, ap, x, 1 ) + call stdlib${ii}$_ctpsv( uplo, trans, diag, n, ap, x, 1_${ik}$ ) else ! use a level 1 blas solve, scaling intermediate results. if( xmax>bignum*half ) then ! scale x so that its components are less than or equal to ! bignum in absolute value. scale = ( bignum*half ) / xmax - call stdlib_csscal( n, scale, x, 1 ) + call stdlib${ii}$_csscal( n, scale, x, 1_${ik}$ ) xmax = bignum else xmax = xmax*two end if if( notran ) then ! solve a * x = b - ip = jfirst*( jfirst+1 ) / 2 + ip = jfirst*( jfirst+1 ) / 2_${ik}$ loop_110: do j = jfirst, jlast, jinc ! compute x(j) = b(j) / a(j,j), scaling x if necessary. xj = cabs1( x( j ) ) @@ -15163,12 +15165,12 @@ module stdlib_linalg_lapack_c if( xj>tjj*bignum ) then ! scale x by 1/b(j). rec = one / xj - call stdlib_csscal( n, rec, x, 1 ) + call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_cladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) xj = cabs1( x( j ) ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: @@ -15181,11 +15183,11 @@ module stdlib_linalg_lapack_c ! multiplying x(j) times column j. rec = rec / cnorm( j ) end if - call stdlib_csscal( n, rec, x, 1 ) + call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_cladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) xj = cabs1( x( j ) ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and @@ -15206,20 +15208,20 @@ module stdlib_linalg_lapack_c if( cnorm( j )>( bignum-xmax )*rec ) then ! scale x by 1/(2*abs(x(j))). rec = rec*half - call stdlib_csscal( n, rec, x, 1 ) + call stdlib${ii}$_csscal( 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_csscal( n, half, x, 1 ) + call stdlib${ii}$_csscal( 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_caxpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1, x,1 ) - i = stdlib_icamax( j-1, x, 1 ) + call stdlib${ii}$_caxpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1_${ik}$, x,1_${ik}$ ) + i = stdlib${ii}$_icamax( j-1, x, 1_${ik}$ ) xmax = cabs1( x( i ) ) end if ip = ip - j @@ -15227,18 +15229,18 @@ module stdlib_linalg_lapack_c if( jj @@ -15257,10 +15259,10 @@ module stdlib_linalg_lapack_c if( tjj>one ) then ! divide by a(j,j) when scaling x if a(j,j) > 1. rec = min( one, rec*tjj ) - uscal = stdlib_cladiv( uscal, tjjs ) + uscal = stdlib${ii}$_cladiv( uscal, tjjs ) end if if( rectjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_csscal( n, rec, x, 1 ) + call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_cladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_csscal( n, rec, x, 1 ) + call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_cladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_cladiv( 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. @@ -15335,16 +15337,16 @@ module stdlib_linalg_lapack_c else ! compute x(j) := x(j) / a(j,j) - csumj if the dot ! product has already been divided by 1/a(j,j). - x( j ) = stdlib_cladiv( x( j ), tjjs ) - csumj + x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) - csumj end if xmax = max( xmax, cabs1( x( j ) ) ) - jlen = jlen + 1 + jlen = jlen + 1_${ik}$ ip = ip + jinc*jlen end do loop_150 else ! solve a**h * x = b - ip = jfirst*( jfirst+1 ) / 2 - jlen = 1 + ip = jfirst*( jfirst+1 ) / 2_${ik}$ + jlen = 1_${ik}$ loop_190: do j = jfirst, jlast, jinc ! compute x(j) = b(j) - sum a(k,j)*x(k). ! k<>j @@ -15363,10 +15365,10 @@ module stdlib_linalg_lapack_c if( tjj>one ) then ! divide by a(j,j) when scaling x if a(j,j) > 1. rec = min( one, rec*tjj ) - uscal = stdlib_cladiv( uscal, tjjs ) + uscal = stdlib${ii}$_cladiv( uscal, tjjs ) end if if( rectjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_csscal( n, rec, x, 1 ) + call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_cladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_csscal( n, rec, x, 1 ) + call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_cladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and ! scale = 0 and compute a solution to a**h *x = 0. @@ -15441,10 +15443,10 @@ module stdlib_linalg_lapack_c else ! compute x(j) := x(j) / a(j,j) - csumj if the dot ! product has already been divided by 1/a(j,j). - x( j ) = stdlib_cladiv( x( j ), tjjs ) - csumj + x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) - csumj end if xmax = max( xmax, cabs1( x( j ) ) ) - jlen = jlen + 1 + jlen = jlen + 1_${ik}$ ip = ip + jinc*jlen end do loop_190 end if @@ -15452,13 +15454,13 @@ module stdlib_linalg_lapack_c 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_clatps + end subroutine stdlib${ii}$_clatps - pure subroutine stdlib_clatrd( uplo, n, nb, a, lda, e, tau, w, ldw ) + pure subroutine stdlib${ii}$_clatrd( uplo, n, nb, a, lda, e, tau, w, ldw ) !! CLATRD reduces NB rows and columns of a complex Hermitian matrix A to !! Hermitian tridiagonal form by a unitary similarity !! transformation Q**H * A * Q, and returns the matrices V and W which are @@ -15473,7 +15475,7 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: lda, ldw, n, nb + integer(${ik}$), intent(in) :: lda, ldw, n, nb ! Array Arguments real(sp), intent(out) :: e(*) complex(sp), intent(inout) :: a(lda,*) @@ -15481,7 +15483,7 @@ module stdlib_linalg_lapack_c ! ===================================================================== ! Local Scalars - integer(ilp) :: i, iw + integer(${ik}$) :: i, iw complex(sp) :: alpha ! Intrinsic Functions intrinsic :: min,real @@ -15495,40 +15497,40 @@ module stdlib_linalg_lapack_c if( i1 ) then + if( i>1_${ik}$ ) then ! generate elementary reflector h(i) to annihilate ! a(1:i-2,i) alpha = a( i-1, i ) - call stdlib_clarfg( i-1, alpha, a( 1, i ), 1, tau( i-1 ) ) + call stdlib${ii}$_clarfg( i-1, alpha, a( 1_${ik}$, i ), 1_${ik}$, tau( i-1 ) ) e( i-1 ) = real( alpha,KIND=sp) a( i-1, i ) = cone ! compute w(1:i-1,i) - call stdlib_chemv( 'UPPER', i-1, cone, a, lda, a( 1, i ), 1,czero, w( 1, iw ),& - 1 ) + call stdlib${ii}$_chemv( 'UPPER', i-1, cone, a, lda, a( 1_${ik}$, i ), 1_${ik}$,czero, w( 1_${ik}$, iw ),& + 1_${ik}$ ) if( ismlnum ) then ! use the level 2 blas solve if the reciprocal of the bound on ! elements of x is not too small. - call stdlib_ctrsv( uplo, trans, diag, n, a, lda, x, 1 ) + call stdlib${ii}$_ctrsv( uplo, trans, diag, n, a, lda, x, 1_${ik}$ ) else ! use a level 1 blas solve, scaling intermediate results. if( xmax>bignum*half ) then ! scale x so that its components are less than or equal to ! bignum in absolute value. scale = ( bignum*half ) / xmax - call stdlib_csscal( n, scale, x, 1 ) + call stdlib${ii}$_csscal( n, scale, x, 1_${ik}$ ) xmax = bignum else xmax = xmax*two @@ -15817,12 +15819,12 @@ module stdlib_linalg_lapack_c if( xj>tjj*bignum ) then ! scale x by 1/b(j). rec = one / xj - call stdlib_csscal( n, rec, x, 1 ) + call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_cladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) xj = cabs1( x( j ) ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: @@ -15835,11 +15837,11 @@ module stdlib_linalg_lapack_c ! multiplying x(j) times column j. rec = rec / cnorm( j ) end if - call stdlib_csscal( n, rec, x, 1 ) + call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_cladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) xj = cabs1( x( j ) ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and @@ -15860,29 +15862,29 @@ module stdlib_linalg_lapack_c if( cnorm( j )>( bignum-xmax )*rec ) then ! scale x by 1/(2*abs(x(j))). rec = rec*half - call stdlib_csscal( n, rec, x, 1 ) + call stdlib${ii}$_csscal( 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_csscal( n, half, x, 1 ) + call stdlib${ii}$_csscal( 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_caxpy( j-1, -x( j )*tscal, a( 1, j ), 1, x,1 ) - i = stdlib_icamax( j-1, x, 1 ) + call stdlib${ii}$_caxpy( j-1, -x( j )*tscal, a( 1_${ik}$, j ), 1_${ik}$, x,1_${ik}$ ) + i = stdlib${ii}$_icamax( j-1, x, 1_${ik}$ ) xmax = cabs1( x( i ) ) end if else if( jone ) then ! divide by a(j,j) when scaling x if a(j,j) > 1. rec = min( one, rec*tjj ) - uscal = stdlib_cladiv( uscal, tjjs ) + uscal = stdlib${ii}$_cladiv( uscal, tjjs ) end if if( rectjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_csscal( n, rec, x, 1 ) + call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_cladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_csscal( n, rec, x, 1 ) + call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_cladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_cladiv( 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. @@ -15985,7 +15987,7 @@ module stdlib_linalg_lapack_c else ! compute x(j) := x(j) / a(j,j) - csumj if the dot ! product has already been divided by 1/a(j,j). - x( j ) = stdlib_cladiv( x( j ), tjjs ) - csumj + x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) - csumj end if xmax = max( xmax, cabs1( x( j ) ) ) end do loop_150 @@ -16009,10 +16011,10 @@ module stdlib_linalg_lapack_c if( tjj>one ) then ! divide by a(j,j) when scaling x if a(j,j) > 1. rec = min( one, rec*tjj ) - uscal = stdlib_cladiv( uscal, tjjs ) + uscal = stdlib${ii}$_cladiv( uscal, tjjs ) end if if( rectjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_csscal( n, rec, x, 1 ) + call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_cladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_csscal( n, rec, x, 1 ) + call stdlib${ii}$_csscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_cladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and ! scale = 0 and compute a solution to a**h *x = 0. @@ -16087,7 +16089,7 @@ module stdlib_linalg_lapack_c else ! compute x(j) := x(j) / a(j,j) - csumj if the dot ! product has already been divided by 1/a(j,j). - x( j ) = stdlib_cladiv( x( j ), tjjs ) - csumj + x( j ) = stdlib${ii}$_cladiv( x( j ), tjjs ) - csumj end if xmax = max( xmax, cabs1( x( j ) ) ) end do loop_190 @@ -16096,13 +16098,13 @@ module stdlib_linalg_lapack_c 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_clatrs + end subroutine stdlib${ii}$_clatrs - pure subroutine stdlib_clatrz( m, n, l, a, lda, tau, work ) + pure subroutine stdlib${ii}$_clatrz( m, n, l, a, lda, tau, work ) !! CLATRZ factors the M-by-(M+L) complex upper trapezoidal matrix !! [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z by means !! of unitary transformations, where Z is an (M+L)-by-(M+L) unitary @@ -16111,20 +16113,20 @@ module stdlib_linalg_lapack_c ! -- 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) :: l, lda, m, n + integer(${ik}$), intent(in) :: l, lda, m, n ! Array Arguments complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i complex(sp) :: alpha ! Intrinsic Functions intrinsic :: conjg ! Executable Statements ! quick return if possible - if( m==0 ) then + if( m==0_${ik}$ ) then return else if( m==n ) then do i = 1, n @@ -16135,20 +16137,20 @@ module stdlib_linalg_lapack_c do i = m, 1, -1 ! generate elementary reflector h(i) to annihilate ! [ a(i,i) a(i,n-l+1:n) ] - call stdlib_clacgv( l, a( i, n-l+1 ), lda ) + call stdlib${ii}$_clacgv( l, a( i, n-l+1 ), lda ) alpha = conjg( a( i, i ) ) - call stdlib_clarfg( l+1, alpha, a( i, n-l+1 ), lda, tau( i ) ) + call stdlib${ii}$_clarfg( l+1, alpha, a( i, n-l+1 ), lda, tau( i ) ) tau( i ) = conjg( tau( i ) ) ! apply h(i) to a(1:i-1,i:n) from the right - call stdlib_clarz( 'RIGHT', i-1, n-i+1, l, a( i, n-l+1 ), lda,conjg( tau( i ) ), a( & - 1, i ), lda, work ) + call stdlib${ii}$_clarz( 'RIGHT', i-1, n-i+1, l, a( i, n-l+1 ), lda,conjg( tau( i ) ), a( & + 1_${ik}$, i ), lda, work ) a( i, i ) = conjg( alpha ) end do return - end subroutine stdlib_clatrz + end subroutine stdlib${ii}$_clatrz - pure recursive subroutine stdlib_claunhr_col_getrfnp2( m, n, a, lda, d, info ) + pure recursive subroutine stdlib${ii}$_claunhr_col_getrfnp2( m, n, a, lda, d, info ) !! CLAUNHR_COL_GETRFNP2 computes the modified LU factorization without !! pivoting of a complex general M-by-N matrix A. The factorization has !! the form: @@ -16201,8 +16203,8 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: d(*) @@ -16211,7 +16213,7 @@ module stdlib_linalg_lapack_c ! Local Scalars real(sp) :: sfmin - integer(ilp) :: i, iinfo, n1, n2 + integer(${ik}$) :: i, iinfo, n1, n2 complex(sp) :: z ! Intrinsic Functions intrinsic :: abs,real,cmplx,aimag,sign,max,min @@ -16221,70 +16223,70 @@ module stdlib_linalg_lapack_c cabs1( z ) = abs( real( z,KIND=sp) ) + abs( aimag( z ) ) ! 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_cscal( m-1, cone / a( 1, 1 ), a( 2, 1 ), 1 ) + if( cabs1( a( 1_${ik}$, 1_${ik}$ ) ) >= sfmin ) then + call stdlib${ii}$_cscal( m-1, cone / 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_claunhr_col_getrfnp2( n1, n1, a, lda, d, iinfo ) + call stdlib${ii}$_claunhr_col_getrfnp2( n1, n1, a, lda, d, iinfo ) ! solve for b21 - call stdlib_ctrsm( 'R', 'U', 'N', 'N', m-n1, n1, cone, a, lda,a( n1+1, 1 ), lda ) + call stdlib${ii}$_ctrsm( 'R', 'U', 'N', 'N', m-n1, n1, cone, a, lda,a( n1+1, 1_${ik}$ ), lda ) ! solve for b12 - call stdlib_ctrsm( 'L', 'L', 'N', 'U', n1, n2, cone, a, lda,a( 1, n1+1 ), lda ) + call stdlib${ii}$_ctrsm( 'L', 'L', 'N', 'U', n1, n2, cone, a, lda,a( 1_${ik}$, n1+1 ), lda ) ! update b22, i.e. compute the schur complement ! b22 := b22 - b21*b12 - call stdlib_cgemm( 'N', 'N', m-n1, n2, n1, -cone, a( n1+1, 1 ), lda,a( 1, n1+1 ), & + call stdlib${ii}$_cgemm( 'N', 'N', m-n1, n2, n1, -cone, a( n1+1, 1_${ik}$ ), lda,a( 1_${ik}$, n1+1 ), & lda, cone, a( n1+1, n1+1 ), lda ) ! factor b22, recursive call - call stdlib_claunhr_col_getrfnp2( m-n1, n2, a( n1+1, n1+1 ), lda,d( n1+1 ), iinfo ) + call stdlib${ii}$_claunhr_col_getrfnp2( m-n1, n2, a( n1+1, n1+1 ), lda,d( n1+1 ), iinfo ) end if return - end subroutine stdlib_claunhr_col_getrfnp2 + end subroutine stdlib${ii}$_claunhr_col_getrfnp2 - pure subroutine stdlib_clauu2( uplo, n, a, lda, info ) + pure subroutine stdlib${ii}$_clauu2( uplo, n, a, lda, info ) !! CLAUU2 computes the product U * U**H or L**H * L, where the triangular !! factor U or L is stored in the upper or lower triangular part of !! the array A. @@ -16298,31 +16300,31 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: i + integer(${ik}$) :: i real(sp) :: aii ! Intrinsic Functions intrinsic :: cmplx,max,real ! 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}$, 'CLAUUM', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code - call stdlib_clauu2( uplo, n, a, lda, info ) + call stdlib${ii}$_clauu2( uplo, n, a, lda, info ) else ! use blocked code if( upper ) then ! compute the product u * u**h. do i = 1, n, nb ib = min( nb, n-i+1 ) - call stdlib_ctrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', i-1, & - ib, cone, a( i, i ), lda,a( 1, i ), lda ) - call stdlib_clauu2( 'UPPER', ib, a( i, i ), lda, info ) + call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', i-1, & + ib, cone, a( i, i ), lda,a( 1_${ik}$, i ), lda ) + call stdlib${ii}$_clauu2( 'UPPER', ib, a( i, i ), lda, info ) if( i+ib<=n ) then - call stdlib_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',i-1, ib, n-i-ib+1,& - cone, a( 1, i+ib ),lda, a( i, i+ib ), lda, cone, a( 1, i ),lda ) - call stdlib_cherk( 'UPPER', 'NO TRANSPOSE', ib, n-i-ib+1,one, a( i, i+ib ),& + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',i-1, ib, n-i-ib+1,& + cone, a( 1_${ik}$, i+ib ),lda, a( i, i+ib ), lda, cone, a( 1_${ik}$, i ),lda ) + call stdlib${ii}$_cherk( 'UPPER', 'NO TRANSPOSE', ib, n-i-ib+1,one, a( i, i+ib ),& lda, one, a( i, i ),lda ) end if end do @@ -16430,23 +16432,23 @@ module stdlib_linalg_lapack_c ! compute the product l**h * l. do i = 1, n, nb ib = min( nb, n-i+1 ) - call stdlib_ctrmm( 'LEFT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', ib, i-1,& - cone, a( i, i ), lda,a( i, 1 ), lda ) - call stdlib_clauu2( 'LOWER', ib, a( i, i ), lda, info ) + call stdlib${ii}$_ctrmm( 'LEFT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', ib, i-1,& + cone, a( i, i ), lda,a( i, 1_${ik}$ ), lda ) + call stdlib${ii}$_clauu2( 'LOWER', ib, a( i, i ), lda, info ) if( i+ib<=n ) then - call stdlib_cgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', ib,i-1, n-i-ib+1,& - cone, a( i+ib, i ), lda,a( i+ib, 1 ), lda, cone, a( i, 1 ), lda ) - call stdlib_cherk( 'LOWER', 'CONJUGATE TRANSPOSE', ib,n-i-ib+1, one, a( i+& + call stdlib${ii}$_cgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', ib,i-1, n-i-ib+1,& + cone, a( i+ib, i ), lda,a( i+ib, 1_${ik}$ ), lda, cone, a( i, 1_${ik}$ ), lda ) + call stdlib${ii}$_cherk( 'LOWER', 'CONJUGATE TRANSPOSE', ib,n-i-ib+1, one, a( i+& ib, i ), lda, one,a( i, i ), lda ) end if end do end if end if return - end subroutine stdlib_clauum + end subroutine stdlib${ii}$_clauum - pure subroutine stdlib_cpbequ( uplo, n, kd, ab, ldab, s, scond, amax, info ) + pure subroutine stdlib${ii}$_cpbequ( uplo, n, kd, ab, ldab, s, scond, amax, info ) !! CPBEQU computes row and column scalings intended to equilibrate a !! Hermitian positive definite band matrix A and reduce its condition !! number (with respect to the two-norm). S contains the scale factors, @@ -16460,8 +16462,8 @@ module stdlib_linalg_lapack_c ! -- 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(out) :: s(*) @@ -16470,42 +16472,42 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: upper - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(sp) :: smin ! Intrinsic Functions intrinsic :: max,min,real,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_csscal( km, one / ajj, ab( kd, j+1 ), kld ) - call stdlib_clacgv( km, ab( kd, j+1 ), kld ) - call stdlib_cher( 'UPPER', km, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) + if( km>0_${ik}$ ) then + call stdlib${ii}$_csscal( km, one / ajj, ab( kd, j+1 ), kld ) + call stdlib${ii}$_clacgv( km, ab( kd, j+1 ), kld ) + call stdlib${ii}$_cher( 'UPPER', km, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) - call stdlib_clacgv( km, ab( kd, j+1 ), kld ) + call stdlib${ii}$_clacgv( km, ab( kd, j+1 ), kld ) end if end do else ! factorize a(m+1:n,m+1:n) as l**h*l, and update a(1:m,1:m). do j = n, m + 1, -1 ! compute s(j,j) and test for non-positive-definiteness. - ajj = real( ab( 1, j ),KIND=sp) + ajj = real( ab( 1_${ik}$, j ),KIND=sp) if( ajj<=zero ) then - ab( 1, j ) = ajj + ab( 1_${ik}$, j ) = ajj go to 50 end if 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_csscal( km, one / ajj, ab( km+1, j-km ), kld ) - call stdlib_clacgv( km, ab( km+1, j-km ), kld ) - call stdlib_cher( 'LOWER', km, -one, ab( km+1, j-km ), kld,ab( 1, j-km ), kld ) + call stdlib${ii}$_csscal( km, one / ajj, ab( km+1, j-km ), kld ) + call stdlib${ii}$_clacgv( km, ab( km+1, j-km ), kld ) + call stdlib${ii}$_cher( 'LOWER', km, -one, ab( km+1, j-km ), kld,ab( 1_${ik}$, j-km ), kld ) - call stdlib_clacgv( km, ab( km+1, j-km ), kld ) + call stdlib${ii}$_clacgv( km, ab( km+1, j-km ), kld ) end do ! factorize the updated submatrix a(1:m,1:m) as u**h*u. do j = 1, m ! compute s(j,j) and test for non-positive-definiteness. - ajj = real( ab( 1, j ),KIND=sp) + ajj = real( ab( 1_${ik}$, j ),KIND=sp) if( ajj<=zero ) then - ab( 1, j ) = ajj + ab( 1_${ik}$, j ) = ajj go to 50 end if 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_csscal( km, one / ajj, ab( 2, j ), 1 ) - call stdlib_cher( 'LOWER', km, -one, ab( 2, j ), 1,ab( 1, j+1 ), kld ) + if( km>0_${ik}$ ) then + call stdlib${ii}$_csscal( km, one / ajj, ab( 2_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_cher( 'LOWER', km, -one, ab( 2_${ik}$, j ), 1_${ik}$,ab( 1_${ik}$, j+1 ), kld ) end if end do end if @@ -16664,10 +16666,10 @@ module stdlib_linalg_lapack_c 50 continue info = j return - end subroutine stdlib_cpbstf + end subroutine stdlib${ii}$_cpbstf - pure subroutine stdlib_cpbtf2( uplo, n, kd, ab, ldab, info ) + pure subroutine stdlib${ii}$_cpbtf2( uplo, n, kd, ab, ldab, info ) !! CPBTF2 computes the Cholesky factorization of a complex Hermitian !! positive definite band matrix A. !! The factorization has the form @@ -16681,38 +16683,38 @@ module stdlib_linalg_lapack_c ! -- 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 complex(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,real,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_csscal( kn, one / ajj, ab( kd, j+1 ), kld ) - call stdlib_clacgv( kn, ab( kd, j+1 ), kld ) - call stdlib_cher( 'UPPER', kn, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) + if( kn>0_${ik}$ ) then + call stdlib${ii}$_csscal( kn, one / ajj, ab( kd, j+1 ), kld ) + call stdlib${ii}$_clacgv( kn, ab( kd, j+1 ), kld ) + call stdlib${ii}$_cher( 'UPPER', kn, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) - call stdlib_clacgv( kn, ab( kd, j+1 ), kld ) + call stdlib${ii}$_clacgv( kn, ab( kd, j+1 ), kld ) end if end do else ! compute the cholesky factorization a = l*l**h. do j = 1, n ! compute l(j,j) and test for non-positive-definiteness. - ajj = real( ab( 1, j ),KIND=sp) + ajj = real( ab( 1_${ik}$, j ),KIND=sp) if( ajj<=zero ) then - ab( 1, j ) = ajj + ab( 1_${ik}$, j ) = ajj go to 30 end if 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_csscal( kn, one / ajj, ab( 2, j ), 1 ) - call stdlib_cher( 'LOWER', kn, -one, ab( 2, j ), 1,ab( 1, j+1 ), kld ) + if( kn>0_${ik}$ ) then + call stdlib${ii}$_csscal( kn, one / ajj, ab( 2_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_cher( 'LOWER', kn, -one, ab( 2_${ik}$, j ), 1_${ik}$,ab( 1_${ik}$, j+1 ), kld ) end if end do end if @@ -16759,10 +16761,10 @@ module stdlib_linalg_lapack_c 30 continue info = j return - end subroutine stdlib_cpbtf2 + end subroutine stdlib${ii}$_cpbtf2 - pure subroutine stdlib_cpbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) + pure subroutine stdlib${ii}$_cpbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) !! CPBTRS solves a system of linear equations A*X = B with a Hermitian !! positive definite band matrix A using the Cholesky factorization !! A = U**H*U or A = L*L**H computed by CPBTRF. @@ -16771,36 +16773,36 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(in) :: ab(ldab,*) complex(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_ctpsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',j-1, ap, & - ap( jc ), 1 ) + if( j>1_${ik}$ )call stdlib${ii}$_ctpsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',j-1, ap, & + ap( jc ), 1_${ik}$ ) ! compute u(j,j) and test for non-positive-definiteness. - ajj = real( real( ap( jj ),KIND=sp) - stdlib_cdotc( j-1,ap( jc ), 1, ap( jc ), 1 & + ajj = real( real( ap( jj ),KIND=sp) - stdlib${ii}$_cdotc( j-1,ap( jc ), 1_${ik}$, ap( jc ), 1_${ik}$ & ),KIND=sp) if( ajj<=zero ) then ap( jj ) = ajj @@ -17395,7 +17397,7 @@ module stdlib_linalg_lapack_c end do else ! compute the cholesky factorization a = l * l**h. - jj = 1 + jj = 1_${ik}$ do j = 1, n ! compute l(j,j) and test for non-positive-definiteness. ajj = real( ap( jj ),KIND=sp) @@ -17408,9 +17410,9 @@ module stdlib_linalg_lapack_c ! compute elements j+1:n of column j and update the trailing ! submatrix. if( j1 ) then + if( j>1_${ik}$ ) then work( i ) = work( i ) +real( conjg( a( j-1, i ) )*a( j-1, i ),KIND=sp) end if work( n+i ) = real( a( i, i ),KIND=sp) - work( i ) end do - if( j>1 ) then - itemp = maxloc( work( (n+j):(2*n) ), 1 ) - pvt = itemp + j - 1 + if( j>1_${ik}$ ) then + itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) + pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) - if( ajj<=sstop.or.stdlib_sisnan( ajj ) ) then + if( ajj<=sstop.or.stdlib${ii}$_sisnan( ajj ) ) then a( j, j ) = ajj go to 190 end if @@ -17585,8 +17587,8 @@ module stdlib_linalg_lapack_c if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) - call stdlib_cswap( j-1, a( 1, j ), 1, a( 1, pvt ), 1 ) - if( pvt1 ) then + if( j>1_${ik}$ ) then work( i ) = work( i ) +real( conjg( a( i, j-1 ) )*a( i, j-1 ),KIND=sp) end if work( n+i ) = real( a( i, i ),KIND=sp) - work( i ) end do - if( j>1 ) then - itemp = maxloc( work( (n+j):(2*n) ), 1 ) - pvt = itemp + j - 1 + if( j>1_${ik}$ ) then + itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) + pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) - if( ajj<=sstop.or.stdlib_sisnan( ajj ) ) then + if( ajj<=sstop.or.stdlib${ii}$_sisnan( ajj ) ) then a( j, j ) = ajj go to 190 end if @@ -17638,8 +17640,8 @@ module stdlib_linalg_lapack_c if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) - call stdlib_cswap( j-1, a( j, 1 ), lda, a( pvt, 1 ), lda ) - if( pvt=n ) then + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code - call stdlib_cpstf2( uplo, n, a( 1, 1 ), lda, piv, rank, tol, work,info ) + call stdlib${ii}$_cpstf2( uplo, n, a( 1_${ik}$, 1_${ik}$ ), lda, piv, rank, tol, work,info ) go to 230 else ! initialize piv @@ -17744,16 +17746,16 @@ module stdlib_linalg_lapack_c do i = 1, n work( i ) = real( a( i, i ),KIND=sp) end do - pvt = maxloc( work( 1:n ), 1 ) + pvt = maxloc( work( 1_${ik}$:n ), 1_${ik}$ ) ajj = real( a( pvt, pvt ),KIND=sp) - if( ajj<=zero.or.stdlib_sisnan( ajj ) ) then - rank = 0 - info = 1 + if( ajj<=zero.or.stdlib${ii}$_sisnan( ajj ) ) then + rank = 0_${ik}$ + info = 1_${ik}$ go to 230 end if ! compute stopping value if not supplied if( tol1 ) then - itemp = maxloc( work( (n+j):(2*n) ), 1 ) - pvt = itemp + j - 1 + if( j>1_${ik}$ ) then + itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) + pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) - if( ajj<=sstop.or.stdlib_sisnan( ajj ) ) then + if( ajj<=sstop.or.stdlib${ii}$_sisnan( ajj ) ) then a( j, j ) = ajj go to 220 end if @@ -17790,8 +17792,8 @@ module stdlib_linalg_lapack_c if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) - call stdlib_cswap( j-1, a( 1, j ), 1, a( 1, pvt ), 1 ) - if( pvt1 ) then - itemp = maxloc( work( (n+j):(2*n) ), 1 ) - pvt = itemp + j - 1 + if( j>1_${ik}$ ) then + itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) + pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) - if( ajj<=sstop.or.stdlib_sisnan( ajj ) ) then + if( ajj<=sstop.or.stdlib${ii}$_sisnan( ajj ) ) then a( j, j ) = ajj go to 220 end if @@ -17857,9 +17859,9 @@ module stdlib_linalg_lapack_c if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) - call stdlib_cswap( j-1, a( j, 1 ), lda, a( pvt, 1 ), lda ) - if( pvt0 ) then - kx = 1 + if( incx>0_${ik}$ ) then + kx = 1_${ik}$ else - kx = 1 - ( n-1 )*incx + kx = 1_${ik}$ - ( n-1 )*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 )*incy end if ! start the operations. in this version the elements of the array ap ! are accessed sequentially with cone pass through ap. ! first form y := beta*y. if( beta/=cone ) then - if( incy==1 ) then + if( incy==1_${ik}$ ) then if( beta==czero ) then do i = 1, n y( i ) = czero @@ -18304,10 +18306,10 @@ module stdlib_linalg_lapack_c end if end if if( alpha==czero )return - kk = 1 + kk = 1_${ik}$ if( stdlib_lsame( uplo, 'U' ) ) then ! form y when ap contains the upper triangle. - if( ( incx==1 ) .and. ( incy==1 ) ) then + if( ( incx==1_${ik}$ ) .and. ( incy==1_${ik}$ ) ) then do j = 1, n temp1 = alpha*x( j ) temp2 = czero @@ -18315,7 +18317,7 @@ module stdlib_linalg_lapack_c do i = 1, j - 1 y( i ) = y( i ) + temp1*ap( k ) temp2 = temp2 + ap( k )*x( i ) - k = k + 1 + k = k + 1_${ik}$ end do y( j ) = y( j ) + temp1*ap( kk+j-1 ) + alpha*temp2 kk = kk + j @@ -18342,16 +18344,16 @@ module stdlib_linalg_lapack_c end if else ! form y when ap contains the lower triangle. - if( ( incx==1 ) .and. ( incy==1 ) ) then + if( ( incx==1_${ik}$ ) .and. ( incy==1_${ik}$ ) ) then do j = 1, n temp1 = alpha*x( j ) temp2 = czero y( j ) = y( j ) + temp1*ap( kk ) - k = kk + 1 + k = kk + 1_${ik}$ do i = j + 1, n y( i ) = y( i ) + temp1*ap( k ) temp2 = temp2 + ap( k )*x( i ) - k = k + 1 + k = k + 1_${ik}$ end do y( j ) = y( j ) + alpha*temp2 kk = kk + ( n-j+1 ) @@ -18379,10 +18381,10 @@ module stdlib_linalg_lapack_c end if end if return - end subroutine stdlib_cspmv + end subroutine stdlib${ii}$_cspmv - pure subroutine stdlib_cspr( uplo, n, alpha, x, incx, ap ) + pure subroutine stdlib${ii}$_cspr( uplo, n, alpha, x, incx, ap ) !! CSPR performs the symmetric rank 1 operation !! A := alpha*x*x**H + A, !! where alpha is a complex scalar, x is an n element vector and A is an @@ -18392,7 +18394,7 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n complex(sp), intent(in) :: alpha ! Array Arguments complex(sp), intent(inout) :: ap(*) @@ -18400,43 +18402,43 @@ module stdlib_linalg_lapack_c ! ===================================================================== ! Local Scalars - integer(ilp) :: i, info, ix, j, jx, k, kk, kx + integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx complex(sp) :: temp ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = 1 - else if( n<0 ) then - info = 2 - else if( incx==0 ) then - info = 5 + info = 1_${ik}$ + else if( n<0_${ik}$ ) then + info = 2_${ik}$ + else if( incx==0_${ik}$ ) then + info = 5_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'CSPR ', info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'CSPR ', info ) return end if ! quick return if possible. if( ( n==0 ) .or. ( alpha==czero ) )return ! set the start point in x if the increment is not unity. - if( incx<=0 ) then - kx = 1 - ( n-1 )*incx - else if( incx/=1 ) then - kx = 1 + if( incx<=0_${ik}$ ) then + kx = 1_${ik}$ - ( n-1 )*incx + else if( incx/=1_${ik}$ ) then + kx = 1_${ik}$ end if ! start the operations. in this version the elements of the array ap ! are accessed sequentially with cone pass through ap. - kk = 1 + kk = 1_${ik}$ if( stdlib_lsame( uplo, 'U' ) ) then ! form a when upper triangle is stored in ap. - if( incx==1 ) then + if( incx==1_${ik}$ ) then do j = 1, n if( x( j )/=czero ) then temp = alpha*x( j ) k = kk do i = 1, j - 1 ap( k ) = ap( k ) + x( i )*temp - k = k + 1 + k = k + 1_${ik}$ end do ap( kk+j-1 ) = ap( kk+j-1 ) + x( j )*temp else @@ -18464,20 +18466,20 @@ module stdlib_linalg_lapack_c end if else ! form a when lower triangle is stored in ap. - if( incx==1 ) then + if( incx==1_${ik}$ ) then do j = 1, n if( x( j )/=czero ) then temp = alpha*x( j ) ap( kk ) = ap( kk ) + temp*x( j ) - k = kk + 1 + k = kk + 1_${ik}$ do i = j + 1, n ap( k ) = ap( k ) + x( i )*temp - k = k + 1 + k = k + 1_${ik}$ end do else ap( kk ) = ap( kk ) end if - kk = kk + n - j + 1 + kk = kk + n - j + 1_${ik}$ end do else jx = kx @@ -18494,15 +18496,15 @@ module stdlib_linalg_lapack_c ap( kk ) = ap( kk ) end if jx = jx + incx - kk = kk + n - j + 1 + kk = kk + n - j + 1_${ik}$ end do end if end if return - end subroutine stdlib_cspr + end subroutine stdlib${ii}$_cspr - pure subroutine stdlib_csptrf( uplo, n, ap, ipiv, info ) + pure subroutine stdlib${ii}$_csptrf( uplo, n, ap, ipiv, info ) !! CSPTRF computes the factorization of a complex symmetric matrix A !! stored in packed format using the Bunch-Kaufman diagonal pivoting !! method: @@ -18515,10 +18517,10 @@ module stdlib_linalg_lapack_c ! -- 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) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(sp), intent(inout) :: ap(*) ! ===================================================================== ! Parameters @@ -18528,7 +18530,7 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: upper - integer(ilp) :: i, imax, j, jmax, k, kc, kk, knc, kp, kpc, kstep, kx, npp + integer(${ik}$) :: i, imax, j, jmax, k, kc, kk, knc, kp, kpc, kstep, kx, npp real(sp) :: absakk, alpha, colmax, rowmax complex(sp) :: d11, d12, d21, d22, r1, t, wk, wkm1, wkp1, zdum ! Intrinsic Functions @@ -18539,15 +18541,15 @@ module stdlib_linalg_lapack_c cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) ) ! 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 + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'CSPTRF', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'CSPTRF', -info ) return end if ! initialize alpha for use in choosing pivot block size. @@ -18557,26 +18559,26 @@ module stdlib_linalg_lapack_c ! k is the main loop index, decreasing from n to 1 in steps of ! 1 or 2 k = n - kc = ( n-1 )*n / 2 + 1 + kc = ( n-1 )*n / 2_${ik}$ + 1_${ik}$ 10 continue knc = kc ! if k < 1, exit from loop if( k<1 )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 absakk = cabs1( ap( kc+k-1 ) ) ! imax is the row-index of the largest off-diagonal element in ! column k, and colmax is its absolute value - if( k>1 ) then - imax = stdlib_icamax( k-1, ap( kc ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_icamax( k-1, ap( kc ), 1_${ik}$ ) colmax = cabs1( 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 @@ -18585,7 +18587,7 @@ module stdlib_linalg_lapack_c else rowmax = zero jmax = imax - kx = imax*( imax+1 ) / 2 + imax + kx = imax*( imax+1 ) / 2_${ik}$ + imax do j = imax + 1, k if( cabs1( ap( kx ) )>rowmax ) then rowmax = cabs1( ap( kx ) ) @@ -18593,9 +18595,9 @@ module stdlib_linalg_lapack_c end if kx = kx + j end do - kpc = ( imax-1 )*imax / 2 + 1 - if( imax>1 ) then - jmax = stdlib_icamax( imax-1, ap( kpc ), 1 ) + kpc = ( imax-1 )*imax / 2_${ik}$ + 1_${ik}$ + if( imax>1_${ik}$ ) then + jmax = stdlib${ii}$_icamax( imax-1, ap( kpc ), 1_${ik}$ ) rowmax = max( rowmax, cabs1( ap( kpc+jmax-1 ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then @@ -18609,18 +18611,18 @@ module stdlib_linalg_lapack_c ! interchange rows and columns k-1 and imax, use 2-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_cswap( kp-1, ap( knc ), 1, ap( kpc ), 1 ) - kx = kpc + kp - 1 + call stdlib${ii}$_cswap( 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 @@ -18628,23 +18630,23 @@ module stdlib_linalg_lapack_c 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 + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u ! perform a rank-1 update of a(1:k-1,1:k-1) as ! a := a - u(k)*d(k)*u(k)**t = a - w(k)*1/d(k)*w(k)**t r1 = cone / ap( kc+k-1 ) - call stdlib_cspr( uplo, k-1, -r1, ap( kc ), 1, ap ) + call stdlib${ii}$_cspr( uplo, k-1, -r1, ap( kc ), 1_${ik}$, ap ) ! store u(k) in column k - call stdlib_cscal( k-1, r1, ap( kc ), 1 ) + call stdlib${ii}$_cscal( k-1, r1, ap( kc ), 1_${ik}$ ) else ! 2-by-2 pivot block d(k): columns k and k-1 now hold ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k) @@ -18653,29 +18655,29 @@ module stdlib_linalg_lapack_c ! perform a rank-2 update of a(1:k-2,1:k-2) as ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**t ! = a - ( 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 = cone / ( d11*d22-cone ) 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 @@ -18689,28 +18691,28 @@ module stdlib_linalg_lapack_c ! 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 = 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 absakk = cabs1( 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 @@ -18728,9 +18730,9 @@ module stdlib_linalg_lapack_c 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 @@ -18744,19 +18746,19 @@ module stdlib_linalg_lapack_c ! interchange rows and columns k+1 and imax, use 2-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 )==czero )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 )==czero )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 = 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. ap( kc+k-1 ) = cone / ap( kc+k-1 ) ! compute column k of the inverse. - if( k>1 ) then - call stdlib_ccopy( k-1, ap( kc ), 1, work, 1 ) - call stdlib_cspmv( uplo, k-1, -cone, ap, work, 1, czero, ap( kc ),1 ) - ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib_cdotu( k-1, work, 1, ap( kc ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_ccopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_cspmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero, ap( kc ),1_${ik}$ ) + ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_cdotu( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ ) end if - kstep = 1 + kstep = 1_${ik}$ else ! 2 x 2 diagonal block ! invert the diagonal block. @@ -18919,30 +18921,30 @@ module stdlib_linalg_lapack_c 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_ccopy( k-1, ap( kc ), 1, work, 1 ) - call stdlib_cspmv( uplo, k-1, -cone, ap, work, 1, czero, ap( kc ),1 ) - ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib_cdotu( k-1, work, 1, ap( kc ), 1 ) - ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib_cdotu( k-1, ap( kc ), 1, ap( & - kcnext ),1 ) - call stdlib_ccopy( k-1, ap( kcnext ), 1, work, 1 ) - call stdlib_cspmv( uplo, k-1, -cone, ap, work, 1, czero,ap( kcnext ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_ccopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_cspmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero, ap( kc ),1_${ik}$ ) + ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_cdotu( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ ) + ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib${ii}$_cdotu( k-1, ap( kc ), 1_${ik}$, ap( & + kcnext ),1_${ik}$ ) + call stdlib${ii}$_ccopy( k-1, ap( kcnext ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_cspmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kcnext ), 1_${ik}$ ) - ap( kcnext+k ) = ap( kcnext+k ) -stdlib_cdotu( k-1, work, 1, ap( kcnext ), 1 ) + ap( kcnext+k ) = ap( kcnext+k ) -stdlib${ii}$_cdotu( 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_cswap( kp-1, ap( kc ), 1, ap( kpc ), 1 ) - kx = kpc + kp - 1 + kpc = ( kp-1 )*kp / 2_${ik}$ + 1_${ik}$ + call stdlib${ii}$_cswap( kp-1, ap( kc ), 1_${ik}$, ap( kpc ), 1_${ik}$ ) + kx = kpc + kp - 1_${ik}$ do j = kp + 1, k - 1 - kx = kx + j - 1 + kx = kx + j - 1_${ik}$ temp = ap( kc+j-1 ) ap( kc+j-1 ) = ap( kx ) ap( kx ) = temp @@ -18950,7 +18952,7 @@ module stdlib_linalg_lapack_c 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 @@ -18964,25 +18966,25 @@ module stdlib_linalg_lapack_c ! 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 + 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. ap( kc ) = cone / ap( kc ) ! compute column k of the inverse. if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_cgeru( k-1, nrhs, -cone, ap( kc ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb ) + call stdlib${ii}$_cgeru( k-1, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb ) ! multiply by the inverse of the diagonal block. - call stdlib_cscal( nrhs, cone / ap( kc+k-1 ), b( k, 1 ), ldb ) - k = k - 1 + call stdlib${ii}$_cscal( nrhs, cone / ap( kc+k-1 ), b( k, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( kp/=k-1 )call stdlib_cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib${ii}$_cswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - call stdlib_cgeru( k-2, nrhs, -cone, ap( kc ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb ) + call stdlib${ii}$_cgeru( k-2, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb ) - call stdlib_cgeru( k-2, nrhs, -cone, ap( kc-( k-1 ) ), 1,b( k-1, 1 ), ldb, b( 1, & - 1 ), ldb ) + call stdlib${ii}$_cgeru( k-2, nrhs, -cone, ap( kc-( k-1 ) ), 1_${ik}$,b( k-1, 1_${ik}$ ), ldb, b( 1_${ik}$, & + 1_${ik}$ ), ldb ) ! multiply by the inverse of the diagonal block. akm1k = ap( kc+k-2 ) akm1 = ap( kc-1 ) / akm1k @@ -19128,43 +19130,43 @@ module stdlib_linalg_lapack_c 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 = 1_${ik}$ + kc = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(u**t(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, ap( kc ),1, cone, b( k,& - 1 ), ldb ) + call stdlib${ii}$_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, ap( kc ),1_${ik}$, cone, b( k,& + 1_${ik}$ ), ldb ) ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( 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 ! 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_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, ap( kc ),1, cone, b( k,& - 1 ), ldb ) - call stdlib_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb,ap( kc+k ), 1, cone, b( & - k+1, 1 ), ldb ) + call stdlib${ii}$_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, ap( kc ),1_${ik}$, cone, b( k,& + 1_${ik}$ ), ldb ) + call stdlib${ii}$_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb,ap( kc+k ), 1_${ik}$, cone, b( & + k+1, 1_${ik}$ ), ldb ) ! interchange rows k and -ipiv(k). kp = -ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - kc = kc + 2*k + 1 - k = k + 2 + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + kc = kc + 2_${ik}$*k + 1_${ik}$ + k = k + 2_${ik}$ end if go to 40 50 continue @@ -19173,36 +19175,36 @@ module stdlib_linalg_lapack_c ! 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 = 1_${ik}$ + kc = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(l**t(k)), where l(k) is the transformation ! stored in column k of a. - if( kn ) then - info = -4 - else if( ldzn ) then + info = -4_${ik}$ + else if( ldz1 ) then + if( jblk>1_${ik}$ ) then eps1 = abs( eps*xj ) pertol = ten*eps1 sep = xj - xjm if( sepmaxits )go to 120 ! normalize and scale the righthand side vector pb. - jmax = stdlib_isamax( blksiz, work( indrv1+1 ), 1 ) + jmax = stdlib${ii}$_isamax( blksiz, work( indrv1+1 ), 1_${ik}$ ) scl = blksiz*onenrm*max( eps,abs( work( indrv4+blksiz ) ) ) /abs( work( indrv1+& jmax ) ) - call stdlib_sscal( blksiz, scl, work( indrv1+1 ), 1 ) + call stdlib${ii}$_sscal( blksiz, scl, work( indrv1+1 ), 1_${ik}$ ) ! solve the system lu = pb. - call stdlib_slagts( -1, blksiz, work( indrv4+1 ), work( indrv2+2 ),work( indrv3+& - 1 ), work( indrv5+1 ), iwork,work( indrv1+1 ), tol, iinfo ) + call stdlib${ii}$_slagts( -1_${ik}$, blksiz, work( indrv4+1 ), work( indrv2+2 ),work( indrv3+& + 1_${ik}$ ), work( indrv5+1 ), iwork,work( indrv1+1 ), tol, iinfo ) ! reorthogonalize by modified gram-schmidt if eigenvalues are ! close enough. if( jblk==1 )go to 110 @@ -19491,25 +19493,25 @@ module stdlib_linalg_lapack_c end if ! check the infinity norm of the iterate. 110 continue - jmax = stdlib_isamax( blksiz, work( indrv1+1 ), 1 ) + jmax = stdlib${ii}$_isamax( blksiz, work( indrv1+1 ), 1_${ik}$ ) nrm = abs( work( indrv1+jmax ) ) ! continue for additional iterations after norm reaches ! stopping criterion. if( nrm0 .and. ldz0_${ik}$ .and. ldzn )go to 160 - if( l1>1 )e( l1-1 ) = zero + if( l1>1_${ik}$ )e( l1-1 ) = zero if( l1<=nm1 ) then do m = l1, nm1 tst = abs( e( m ) ) @@ -19621,20 +19623,20 @@ module stdlib_linalg_lapack_c lsv = l lend = m lendsv = lend - l1 = m + 1 + l1 = m + 1_${ik}$ if( lend==l )go to 10 ! scale submatrix in rows and columns l to lend - anorm = stdlib_slanst( 'I', lend-l+1, d( l ), e( l ) ) - iscale = 0 + anorm = stdlib${ii}$_slanst( 'I', lend-l+1, d( l ), e( l ) ) + iscale = 0_${ik}$ if( anorm==zero )go to 10 if( anorm>ssfmax ) then - iscale = 1 - call stdlib_slascl( 'G', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n,info ) - call stdlib_slascl( 'G', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n,info ) + iscale = 1_${ik}$ + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmax, lend-l+1, 1_${ik}$, d( l ), n,info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmax, lend-l, 1_${ik}$, e( l ), n,info ) else if( anorm0 ) then - call stdlib_slaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s ) + if( icompz>0_${ik}$ ) then + call stdlib${ii}$_slaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s ) work( l ) = c work( n-1+l ) = s - call stdlib_clasr( 'R', 'V', 'B', n, 2, work( l ),work( n-1+l ), z( 1, l ), & + call stdlib${ii}$_clasr( 'R', 'V', 'B', n, 2_${ik}$, work( l ),work( n-1+l ), z( 1_${ik}$, l ), & ldz ) else - call stdlib_slae2( d( l ), e( l ), d( l+1 ), rt1, rt2 ) + call stdlib${ii}$_slae2( d( l ), e( l ), d( l+1 ), rt1, rt2 ) end if d( l ) = rt1 d( l+1 ) = rt2 e( l ) = zero - l = l + 2 + l = l + 2_${ik}$ if( l<=lend )go to 40 go to 140 end if if( jtot==nmaxit )go to 140 - jtot = jtot + 1 + jtot = jtot + 1_${ik}$ ! form shift. g = ( d( l+1 )-p ) / ( two*e( l ) ) - r = stdlib_slapy2( g, one ) + r = stdlib${ii}$_slapy2( g, one ) g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) ) s = one c = one p = zero ! inner loop - mm1 = m - 1 + mm1 = m - 1_${ik}$ do i = mm1, l, -1 f = s*e( i ) b = c*e( i ) - call stdlib_slartg( g, f, c, s, r ) + call stdlib${ii}$_slartg( g, f, c, s, r ) if( i/=m-1 )e( i+1 ) = r g = d( i+1 ) - p r = ( d( i )-g )*s + two*c*b @@ -19698,15 +19700,15 @@ module stdlib_linalg_lapack_c d( i+1 ) = g + p g = c*r - b ! if eigenvectors are desired, then save rotations. - if( icompz>0 ) then + if( icompz>0_${ik}$ ) then work( i ) = c work( n-1+i ) = -s end if end do ! if eigenvectors are desired, then apply saved rotations. - if( icompz>0 ) then - mm = m - l + 1 - call stdlib_clasr( 'R', 'V', 'B', n, mm, work( l ), work( n-1+l ),z( 1, l ), ldz & + if( icompz>0_${ik}$ ) then + mm = m - l + 1_${ik}$ + call stdlib${ii}$_clasr( 'R', 'V', 'B', n, mm, work( l ), work( n-1+l ),z( 1_${ik}$, l ), ldz & ) end if d( l ) = d( l ) - p @@ -19715,7 +19717,7 @@ module stdlib_linalg_lapack_c ! eigenvalue found. 80 continue d( l ) = p - l = l + 1 + l = l + 1_${ik}$ if( l<=lend )go to 40 go to 140 else @@ -19723,9 +19725,9 @@ module stdlib_linalg_lapack_c ! look for small superdiagonal element. 90 continue if( l/=lend ) then - lendp1 = lend + 1 + lendp1 = lend + 1_${ik}$ do m = l, lendp1, -1 - tst = abs( e( m-1 ) )**2 + tst = abs( e( m-1 ) )**2_${ik}$ if( tst<=( eps2*abs( d( m ) ) )*abs( d( m-1 ) )+safmin )go to 110 end do end if @@ -19734,40 +19736,40 @@ module stdlib_linalg_lapack_c if( m>lend )e( m-1 ) = zero p = d( l ) if( m==l )go to 130 - ! if remaining matrix is 2-by-2, use stdlib_slae2 or stdlib_slaev2 + ! if remaining matrix is 2-by-2, use stdlib_slae2 or stdlib${ii}$_slaev2 ! to compute its eigensystem. if( m==l-1 ) then - if( icompz>0 ) then - call stdlib_slaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s ) + if( icompz>0_${ik}$ ) then + call stdlib${ii}$_slaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s ) work( m ) = c work( n-1+m ) = s - call stdlib_clasr( 'R', 'V', 'F', n, 2, work( m ),work( n-1+m ), z( 1, l-1 ), & + call stdlib${ii}$_clasr( 'R', 'V', 'F', n, 2_${ik}$, work( m ),work( n-1+m ), z( 1_${ik}$, l-1 ), & ldz ) else - call stdlib_slae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 ) + call stdlib${ii}$_slae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 ) end if d( l-1 ) = rt1 d( l ) = rt2 e( l-1 ) = zero - l = l - 2 + l = l - 2_${ik}$ if( l>=lend )go to 90 go to 140 end if if( jtot==nmaxit )go to 140 - jtot = jtot + 1 + jtot = jtot + 1_${ik}$ ! form shift. g = ( d( l-1 )-p ) / ( two*e( l-1 ) ) - r = stdlib_slapy2( g, one ) + r = stdlib${ii}$_slapy2( g, one ) g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) ) s = one c = one p = zero ! inner loop - lm1 = l - 1 + lm1 = l - 1_${ik}$ do i = m, lm1 f = s*e( i ) b = c*e( i ) - call stdlib_slartg( g, f, c, s, r ) + call stdlib${ii}$_slartg( g, f, c, s, r ) if( i/=m )e( i-1 ) = r g = d( i ) - p r = ( d( i+1 )-g )*s + two*c*b @@ -19775,15 +19777,15 @@ module stdlib_linalg_lapack_c d( i ) = g + p g = c*r - b ! if eigenvectors are desired, then save rotations. - if( icompz>0 ) then + if( icompz>0_${ik}$ ) then work( i ) = c work( n-1+i ) = s end if end do ! if eigenvectors are desired, then apply saved rotations. - if( icompz>0 ) then - mm = l - m + 1 - call stdlib_clasr( 'R', 'V', 'F', n, mm, work( m ), work( n-1+m ),z( 1, m ), ldz & + if( icompz>0_${ik}$ ) then + mm = l - m + 1_${ik}$ + call stdlib${ii}$_clasr( 'R', 'V', 'F', n, mm, work( m ), work( n-1+m ),z( 1_${ik}$, m ), ldz & ) end if d( l ) = d( l ) - p @@ -19792,41 +19794,41 @@ module stdlib_linalg_lapack_c ! eigenvalue found. 130 continue d( l ) = p - l = l - 1 + l = l - 1_${ik}$ if( l>=lend )go to 90 go to 140 end if ! undo scaling if necessary 140 continue - if( iscale==1 ) then - call stdlib_slascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1,d( lsv ), n, info ) + if( iscale==1_${ik}$ ) then + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, ssfmax, anorm, lendsv-lsv+1, 1_${ik}$,d( lsv ), n, info ) - call stdlib_slascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv, 1, e( lsv ),n, info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, ssfmax, anorm, lendsv-lsv, 1_${ik}$, e( lsv ),n, info ) - else if( iscale==2 ) then - call stdlib_slascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1,d( lsv ), n, info ) + else if( iscale==2_${ik}$ ) then + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, ssfmin, anorm, lendsv-lsv+1, 1_${ik}$,d( lsv ), n, info ) - call stdlib_slascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv, 1, e( lsv ),n, info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, ssfmin, anorm, lendsv-lsv, 1_${ik}$, e( lsv ),n, info ) end if ! check for no convergence to an eigenvalue after a total ! of n*maxit iterations. if( jtot==nmaxit ) then do i = 1, n - 1 - if( e( i )/=zero )info = info + 1 + if( e( i )/=zero )info = info + 1_${ik}$ end do return end if go to 10 ! order eigenvalues and eigenvectors. 160 continue - if( icompz==0 ) then + if( icompz==0_${ik}$ ) then ! use quick sort - call stdlib_slasrt( 'I', n, d, info ) + call stdlib${ii}$_slasrt( 'I', n, d, info ) else ! use selection sort to minimize swaps of eigenvectors do ii = 2, n - i = ii - 1 + i = ii - 1_${ik}$ k = i p = d( i ) do j = ii, n @@ -19838,15 +19840,15 @@ module stdlib_linalg_lapack_c if( k/=i ) then d( k ) = d( i ) d( i ) = p - call stdlib_cswap( n, z( 1, i ), 1, z( 1, k ), 1 ) + call stdlib${ii}$_cswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, k ), 1_${ik}$ ) end if end do end if return - end subroutine stdlib_csteqr + end subroutine stdlib${ii}$_csteqr - pure subroutine stdlib_csyconv( uplo, way, n, a, lda, ipiv, e, info ) + pure subroutine stdlib${ii}$_csyconv( uplo, way, n, a, lda, ipiv, e, info ) !! CSYCONV convert A given by TRF into L and D and vice-versa. !! Get Non-diag elements of D (returned in workspace) and !! apply or reverse permutation done in TRF. @@ -19855,33 +19857,33 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: e(*) ! ===================================================================== ! External Subroutines logical(lk) :: upper, convert - integer(ilp) :: i, ip, j + integer(${ik}$) :: i, ip, j complex(sp) :: temp ! 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( lda 1 ) - if( ipiv(i) < 0 ) then + if( ipiv(i) < 0_${ik}$ ) then e(i)=a(i-1,i) e(i-1)=czero a(i-1,i)=czero @@ -19907,7 +19909,7 @@ module stdlib_linalg_lapack_c ! 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 @@ -19932,9 +19934,9 @@ module stdlib_linalg_lapack_c 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 @@ -19959,7 +19961,7 @@ module stdlib_linalg_lapack_c ! 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 @@ -19971,10 +19973,10 @@ module stdlib_linalg_lapack_c if ( convert ) then ! convert a (a is lower) ! convert value - i=1 + i=1_${ik}$ e(n)=czero 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) @@ -19998,7 +20000,7 @@ module stdlib_linalg_lapack_c 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) @@ -20014,9 +20016,9 @@ module stdlib_linalg_lapack_c ! 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) @@ -20026,7 +20028,7 @@ module stdlib_linalg_lapack_c 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) @@ -20037,9 +20039,9 @@ module stdlib_linalg_lapack_c 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 @@ -20048,10 +20050,10 @@ module stdlib_linalg_lapack_c end if end if return - end subroutine stdlib_csyconv + end subroutine stdlib${ii}$_csyconv - pure subroutine stdlib_csyconvf( uplo, way, n, a, lda, e, ipiv, info ) + pure subroutine stdlib${ii}$_csyconvf( uplo, way, n, a, lda, e, ipiv, info ) !! If parameter WAY = 'C': !! CSYCONVF converts the factorization output format used in !! CSYTRF provided on entry in parameter A into the factorization @@ -20074,31 +20076,31 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(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 ) = czero a( i-1, i ) = czero - i = i - 1 + i = i - 1_${ik}$ else e( i ) = czero 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 i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(1:i,n-i:n) ip = ipiv( i ) if( i0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(1: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 @@ -20211,40 +20213,40 @@ module stdlib_linalg_lapack_c ! convert value ! assign subdiagonal entries of d to array e and czero out ! corresponding entries in input storage a - i = 1 + i = 1_${ik}$ e( n ) = czero do while ( i<=n ) - if( i0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(i:n,1:i-1) ip = ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_cswap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_cswap( 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) ip = -ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=(i+1) ) then - call stdlib_cswap( i-1, a( i+1, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_cswap( i-1, a( i+1, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda ) end if end if ! convert ipiv @@ -20252,9 +20254,9 @@ module stdlib_linalg_lapack_c ! 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) @@ -20263,23 +20265,23 @@ module stdlib_linalg_lapack_c ! in reverse factorization order where i decreases from n to 1 i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(i:n,1:i-1) ip = ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_cswap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) + call stdlib${ii}$_cswap( 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 + i = i - 1_${ik}$ ip = -ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=(i+1) ) then - call stdlib_cswap( i-1, a( ip, 1 ), lda,a( i+1, 1 ), lda ) + call stdlib${ii}$_cswap( i-1, a( ip, 1_${ik}$ ), lda,a( i+1, 1_${ik}$ ), lda ) end if end if ! convert ipiv @@ -20288,27 +20290,27 @@ module stdlib_linalg_lapack_c ! 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_csyconvf + end subroutine stdlib${ii}$_csyconvf - pure subroutine stdlib_csyconvf_rook( uplo, way, n, a, lda, e, ipiv, info ) + pure subroutine stdlib${ii}$_csyconvf_rook( uplo, way, n, a, lda, e, ipiv, info ) !! If parameter WAY = 'C': !! CSYCONVF_ROOK converts the factorization output format used in !! CSYTRF_ROOK provided on entry in parameter A into the factorization @@ -20329,31 +20331,31 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(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 ) = czero a( i-1, i ) = czero - i = i - 1 + i = i - 1_${ik}$ else e( i ) = czero 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 i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(1:i,n-i:n) ip = ipiv( i ) if( i0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(1: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 @@ -20466,31 +20468,31 @@ module stdlib_linalg_lapack_c ! convert value ! assign subdiagonal entries of d to array e and czero out ! corresponding entries in input storage a - i = 1 + i = 1_${ik}$ e( n ) = czero do while ( i<=n ) - if( i0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(i:n,1:i-1) ip = ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_cswap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_cswap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda ) end if end if else @@ -20499,17 +20501,17 @@ module stdlib_linalg_lapack_c ! in a(i:n,1:i-1) ip = -ipiv( i ) ip2 = -ipiv( i+1 ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_cswap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_cswap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda ) end if if( ip2/=(i+1) ) then - call stdlib_cswap( i-1, a( i+1, 1 ), lda,a( ip2, 1 ), lda ) + call stdlib${ii}$_cswap( 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) @@ -20518,52 +20520,52 @@ module stdlib_linalg_lapack_c ! in reverse factorization order where i decreases from n to 1 i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(i:n,1:i-1) ip = ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_cswap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) + call stdlib${ii}$_cswap( 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+1) and i and ipiv(i) ! in a(i:n,1:i-1) - i = 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_cswap( i-1, a( ip2, 1 ), lda,a( i+1, 1 ), lda ) + call stdlib${ii}$_cswap( i-1, a( ip2, 1_${ik}$ ), lda,a( i+1, 1_${ik}$ ), lda ) end if if( ip/=i ) then - call stdlib_cswap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) + call stdlib${ii}$_cswap( 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_csyconvf_rook + end subroutine stdlib${ii}$_csyconvf_rook - pure subroutine stdlib_csyequb( uplo, n, a, lda, s, scond, amax, work, info ) + pure subroutine stdlib${ii}$_csyequb( uplo, n, a, lda, s, scond, amax, work, info ) !! CSYEQUB 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 @@ -20575,8 +20577,8 @@ module stdlib_linalg_lapack_c ! -- 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 @@ -20585,11 +20587,11 @@ module stdlib_linalg_lapack_c real(sp), intent(out) :: s(*) ! ===================================================================== ! 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 @@ -20602,22 +20604,22 @@ module stdlib_linalg_lapack_c cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) ) ! 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( 'CSYEQUB', -info ) + if ( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'CSYEQUB', -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 @@ -20684,7 +20686,7 @@ module stdlib_linalg_lapack_c do i = n+1, 2*n work( i ) = s( i-n ) * work( i-n ) - avg end do - call stdlib_classq( n, work( n+1 ), 1, scale, sumsq ) + call stdlib${ii}$_classq( n, work( n+1 ), 1_${ik}$, scale, sumsq ) std = scale * sqrt( sumsq / n ) if ( std < tol * avg ) goto 999 do i = 1, n @@ -20692,13 +20694,13 @@ module stdlib_linalg_lapack_c si = s( i ) c2 = ( n-1 ) * t c1 = real( n-2,KIND=sp) * ( real( work( i ),KIND=sp) - t*si ) - c0 = -(t*si)*si + 2 * real( work( i ),KIND=sp) * si - n*avg - d = c1*c1 - 4*c0*c2 - if ( d <= 0 ) then - info = -1 + c0 = -(t*si)*si + 2_${ik}$ * real( work( i ),KIND=sp) * 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 @@ -20729,23 +20731,23 @@ module stdlib_linalg_lapack_c 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_csyequb + end subroutine stdlib${ii}$_csyequb - pure subroutine stdlib_csymv( uplo, n, alpha, a, lda, x, incx, beta, y, incy ) + pure subroutine stdlib${ii}$_csymv( uplo, n, alpha, a, lda, x, incx, beta, y, incy ) !! CSYMV 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 @@ -20755,7 +20757,7 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: incx, incy, lda, n + integer(${ik}$), intent(in) :: incx, incy, lda, n complex(sp), intent(in) :: alpha, beta ! Array Arguments complex(sp), intent(in) :: a(lda,*), x(*) @@ -20764,47 +20766,47 @@ module stdlib_linalg_lapack_c ! Local Scalars - integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky complex(sp) :: temp1, temp2 ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) 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 )*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 )*incy end if ! start the operations. in this version the elements of a are ! accessed sequentially with cone pass through the triangular part ! of a. ! first form y := beta*y. if( beta/=cone ) then - if( incy==1 ) then + if( incy==1_${ik}$ ) then if( beta==czero ) then do i = 1, n y( i ) = czero @@ -20832,7 +20834,7 @@ module stdlib_linalg_lapack_c if( alpha==czero )return if( stdlib_lsame( uplo, 'U' ) ) then ! form y when a is stored in upper triangle. - if( ( incx==1 ) .and. ( incy==1 ) ) then + if( ( incx==1_${ik}$ ) .and. ( incy==1_${ik}$ ) ) then do j = 1, n temp1 = alpha*x( j ) temp2 = czero @@ -20863,7 +20865,7 @@ module stdlib_linalg_lapack_c end if else ! form y when a is stored in lower triangle. - if( ( incx==1 ) .and. ( incy==1 ) ) then + if( ( incx==1_${ik}$ ) .and. ( incy==1_${ik}$ ) ) then do j = 1, n temp1 = alpha*x( j ) temp2 = czero @@ -20896,10 +20898,10 @@ module stdlib_linalg_lapack_c end if end if return - end subroutine stdlib_csymv + end subroutine stdlib${ii}$_csymv - pure subroutine stdlib_csyr( uplo, n, alpha, x, incx, a, lda ) + pure subroutine stdlib${ii}$_csyr( uplo, n, alpha, x, incx, a, lda ) !! CSYR performs the symmetric rank 1 operation !! A := alpha*x*x**H + A, !! where alpha is a complex scalar, x is an n element vector and A is an @@ -20909,7 +20911,7 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: incx, lda, n + integer(${ik}$), intent(in) :: incx, lda, n complex(sp), intent(in) :: alpha ! Array Arguments complex(sp), intent(inout) :: a(lda,*) @@ -20917,40 +20919,40 @@ module stdlib_linalg_lapack_c ! ===================================================================== ! Local Scalars - integer(ilp) :: i, info, ix, j, jx, kx + integer(${ik}$) :: i, info, ix, j, jx, kx complex(sp) :: temp ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = 1 - else if( n<0 ) then - info = 2 - else if( incx==0 ) then - info = 5 - else if( lda1 ) then - imax = stdlib_icamax( k-1, a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_icamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ ) colmax = cabs1( a( imax, k ) ) else colmax = zero end if - if( max( absakk, colmax )==zero .or. stdlib_sisnan(absakk) ) then + if( max( absakk, colmax )==zero .or. stdlib${ii}$_sisnan(absakk) ) then ! column k is zero or underflow, or contains a nan: ! set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k else if( absakk>=alpha*colmax ) then @@ -21156,10 +21158,10 @@ module stdlib_linalg_lapack_c else ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value - jmax = imax + stdlib_icamax( k-imax, a( imax, imax+1 ), lda ) + jmax = imax + stdlib${ii}$_icamax( k-imax, a( imax, imax+1 ), lda ) rowmax = cabs1( a( imax, jmax ) ) - if( imax>1 ) then - jmax = stdlib_icamax( imax-1, a( 1, imax ), 1 ) + if( imax>1_${ik}$ ) then + jmax = stdlib${ii}$_icamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ ) rowmax = max( rowmax, cabs1( a( jmax, imax ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then @@ -21173,35 +21175,35 @@ module stdlib_linalg_lapack_c ! interchange rows and columns k-1 and imax, use 2-by-2 ! pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ end if end if - 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) - call stdlib_cswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) - call stdlib_cswap( kk-kp-1, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) + call stdlib${ii}$_cswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + call stdlib${ii}$_cswap( kk-kp-1, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t - if( kstep==2 ) 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 + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u ! perform a rank-1 update of a(1:k-1,1:k-1) as ! a := a - u(k)*d(k)*u(k)**t = a - w(k)*1/d(k)*w(k)**t r1 = cone / a( k, k ) - call stdlib_csyr( uplo, k-1, -r1, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_csyr( uplo, k-1, -r1, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) ! store u(k) in column k - call stdlib_cscal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_cscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) else ! 2-by-2 pivot block d(k): columns k and k-1 now hold ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k) @@ -21210,7 +21212,7 @@ module stdlib_linalg_lapack_c ! perform a rank-2 update of a(1:k-2,1:k-2) as ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**t ! = a - ( w(k-1) w(k) )*inv(d(k))*( w(k-1) w(k) )**t - 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 @@ -21229,7 +21231,7 @@ module stdlib_linalg_lapack_c 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 @@ -21242,11 +21244,11 @@ module stdlib_linalg_lapack_c ! 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 = 1_${ik}$ 40 continue ! if k > n, exit from loop if( k>n )go to 70 - 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 absakk = cabs1( a( k, k ) ) @@ -21254,15 +21256,15 @@ module stdlib_linalg_lapack_c ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k=alpha*colmax ) then @@ -21271,10 +21273,10 @@ module stdlib_linalg_lapack_c else ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value - jmax = k - 1 + stdlib_icamax( imax-k, a( imax, k ), lda ) + jmax = k - 1_${ik}$ + stdlib${ii}$_icamax( imax-k, a( imax, k ), lda ) rowmax = cabs1( a( imax, jmax ) ) if( imax=alpha*colmax*( colmax / rowmax ) ) then @@ -21288,27 +21290,27 @@ module stdlib_linalg_lapack_c ! interchange rows and columns k+1 and imax, use 2-by-2 ! pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ end if end if - 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( kp1 ) then - imax = stdlib_icamax( k-1, a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_icamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ ) colmax = cabs1( a( imax, k ) ) else colmax = zero end if if( (max( absakk, colmax )==zero) ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k ! set e( k ) to zero - if( k>1 )e( k ) = czero + if( k>1_${ik}$ )e( k ) = czero else ! test for interchange ! equivalent to testing for (used to handle nan and inf) @@ -21467,13 +21469,13 @@ module stdlib_linalg_lapack_c ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = imax + stdlib_icamax( k-imax, a( imax, imax+1 ),lda ) + jmax = imax + stdlib${ii}$_icamax( k-imax, a( imax, imax+1 ),lda ) rowmax = cabs1( a( imax, jmax ) ) else rowmax = zero end if - if( imax>1 ) then - itemp = stdlib_icamax( imax-1, a( 1, imax ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_icamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ ) stemp = cabs1( a( itemp, imax ) ) if( stemp>rowmax ) then rowmax = stemp @@ -21493,7 +21495,7 @@ module stdlib_linalg_lapack_c ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found, set variables and repeat @@ -21506,45 +21508,45 @@ module stdlib_linalg_lapack_c end if ! swap two rows and two columns ! first swap - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! interchange rows and column k and p in the leading ! submatrix a(1:k,1:k) if we have a 2-by-2 pivot - if( p>1 )call stdlib_cswap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) - if( p<(k-1) )call stdlib_cswap( k-p-1, a( p+1, k ), 1, a( p, p+1 ),lda ) + if( p>1_${ik}$ )call stdlib${ii}$_cswap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) + if( p<(k-1) )call stdlib${ii}$_cswap( k-p-1, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda ) t = a( k, k ) a( k, k ) = a( p, p ) a( p, p ) = t ! convert upper triangle of a into u form by applying ! the interchanges in columns k+1:n. - if( k1 )call stdlib_cswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) - if( ( kk>1 ) .and. ( kp<(kk-1) ) )call stdlib_cswap( kk-kp-1, a( kp+1, kk ), & - 1, a( kp, kp+1 ),lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_cswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + if( ( kk>1_${ik}$ ) .and. ( kp<(kk-1) ) )call stdlib${ii}$_cswap( kk-kp-1, a( kp+1, kk ), & + 1_${ik}$, a( kp, kp+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t - if( kstep==2 ) 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 + if( k>1_${ik}$ ) then ! perform a rank-1 update of a(1:k-1,1:k-1) and ! store u(k) in column k if( cabs1( a( k, k ) )>=sfmin ) then @@ -21552,9 +21554,9 @@ module stdlib_linalg_lapack_c ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*1/d(k)*w(k)**t d11 = cone / a( k, k ) - call stdlib_csyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_csyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) ! store u(k) in column k - call stdlib_cscal( k-1, d11, a( 1, k ), 1 ) + call stdlib${ii}$_cscal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = a( k, k ) @@ -21565,7 +21567,7 @@ module stdlib_linalg_lapack_c ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_csyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_csyr( 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 ) = czero @@ -21579,7 +21581,7 @@ module stdlib_linalg_lapack_c ! 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 @@ -21605,7 +21607,7 @@ module stdlib_linalg_lapack_c ! 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 @@ -21621,11 +21623,11 @@ module stdlib_linalg_lapack_c e( n ) = czero ! k is the main loop index, increasing from 1 to n in steps of ! 1 or 2 - k = 1 + 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 @@ -21634,14 +21636,14 @@ module stdlib_linalg_lapack_c ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( krowmax ) then rowmax = stemp @@ -21687,7 +21689,7 @@ module stdlib_linalg_lapack_c ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found, set variables and repeat @@ -21700,42 +21702,42 @@ module stdlib_linalg_lapack_c end if ! swap two rows and two columns ! first swap - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! interchange rows and column k and p in the trailing ! submatrix a(k:n,k:n) if we have a 2-by-2 pivot - if( p(k+1) )call stdlib_cswap( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) + if( p(k+1) )call stdlib${ii}$_cswap( p-k-1, a( k+1, k ), 1_${ik}$, a( p, k+1 ), lda ) t = a( k, k ) a( k, k ) = a( p, p ) a( p, p ) = t ! convert lower triangle of a into l form by applying ! the interchanges in columns 1:k-1. - if ( k>1 )call stdlib_cswap( k-1, a( k, 1 ), lda, a( p, 1 ), lda ) + if ( k>1_${ik}$ )call stdlib${ii}$_cswap( 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_cswap( kp-kk-1, a( kk+1, kk ), & - 1, a( kp, kk+1 ),lda ) + if( ( kk(kk+1) ) )call stdlib${ii}$_cswap( kp-kk-1, a( kk+1, kk ), & + 1_${ik}$, a( kp, kk+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t - if( kstep==2 ) 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_cswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) + if ( k>1_${ik}$ )call stdlib${ii}$_cswap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) end if ! update the trailing submatrix - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = l(k)*d(k) ! where l(k) is the k-th column of l @@ -21747,10 +21749,10 @@ module stdlib_linalg_lapack_c ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t d11 = cone / a( k, k ) - call stdlib_csyr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_csyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda ) ! store l(k) in column k - call stdlib_cscal( n-k, d11, a( k+1, k ), 1 ) + call stdlib${ii}$_cscal( n-k, d11, a( k+1, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = a( k, k ) @@ -21761,7 +21763,7 @@ module stdlib_linalg_lapack_c ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_csyr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_csyr( 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 @@ -21804,7 +21806,7 @@ module stdlib_linalg_lapack_c ! 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 @@ -21816,10 +21818,10 @@ module stdlib_linalg_lapack_c 64 continue end if return - end subroutine stdlib_csytf2_rk + end subroutine stdlib${ii}$_csytf2_rk - pure subroutine stdlib_csytf2_rook( uplo, n, a, lda, ipiv, info ) + pure subroutine stdlib${ii}$_csytf2_rook( uplo, n, a, lda, ipiv, info ) !! CSYTF2_ROOK computes the factorization of a complex symmetric matrix A !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method: !! A = U*D*U**T or A = L*D*L**T @@ -21832,10 +21834,10 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(inout) :: a(lda,*) ! ===================================================================== ! Parameters @@ -21845,7 +21847,7 @@ module stdlib_linalg_lapack_c ! 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, rowmax, stemp, sfmin complex(sp) :: d11, d12, d21, d22, t, wk, wkm1, wkp1, z ! Intrinsic Functions @@ -21856,23 +21858,23 @@ module stdlib_linalg_lapack_c cabs1( z ) = abs( real( z,KIND=sp) ) + abs( aimag( z ) ) ! 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_icamax( k-1, a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_icamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ ) colmax = cabs1( a( imax, k ) ) else colmax = zero end if if( (max( absakk, colmax )==zero) ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k else ! test for interchange @@ -21916,13 +21918,13 @@ module stdlib_linalg_lapack_c ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = imax + stdlib_icamax( k-imax, a( imax, imax+1 ),lda ) + jmax = imax + stdlib${ii}$_icamax( k-imax, a( imax, imax+1 ),lda ) rowmax = cabs1( a( imax, jmax ) ) else rowmax = zero end if - if( imax>1 ) then - itemp = stdlib_icamax( imax-1, a( 1, imax ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_icamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ ) stemp = cabs1( a( itemp, imax ) ) if( stemp>rowmax ) then rowmax = stemp @@ -21942,7 +21944,7 @@ module stdlib_linalg_lapack_c ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found, set variables and repeat @@ -21955,39 +21957,39 @@ module stdlib_linalg_lapack_c end if ! swap two rows and two columns ! first swap - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! interchange rows and column k and p in the leading ! submatrix a(1:k,1:k) if we have a 2-by-2 pivot - if( p>1 )call stdlib_cswap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) - if( p<(k-1) )call stdlib_cswap( k-p-1, a( p+1, k ), 1, a( p, p+1 ),lda ) + if( p>1_${ik}$ )call stdlib${ii}$_cswap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) + if( p<(k-1) )call stdlib${ii}$_cswap( k-p-1, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda ) t = a( k, k ) a( k, k ) = a( p, p ) a( p, p ) = t end if ! second swap - kk = k - kstep + 1 + 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_cswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) - if( ( kk>1 ) .and. ( kp<(kk-1) ) )call stdlib_cswap( kk-kp-1, a( kp+1, kk ), & - 1, a( kp, kp+1 ),lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_cswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + if( ( kk>1_${ik}$ ) .and. ( kp<(kk-1) ) )call stdlib${ii}$_cswap( kk-kp-1, a( kp+1, kk ), & + 1_${ik}$, a( kp, kp+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t - if( kstep==2 ) 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 + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u - if( k>1 ) then + if( k>1_${ik}$ ) then ! perform a rank-1 update of a(1:k-1,1:k-1) and ! store u(k) in column k if( cabs1( a( k, k ) )>=sfmin ) then @@ -21995,9 +21997,9 @@ module stdlib_linalg_lapack_c ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*1/d(k)*w(k)**t d11 = cone / a( k, k ) - call stdlib_csyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_csyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) ! store u(k) in column k - call stdlib_cscal( k-1, d11, a( 1, k ), 1 ) + call stdlib${ii}$_cscal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = a( k, k ) @@ -22008,7 +22010,7 @@ module stdlib_linalg_lapack_c ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_csyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_csyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) end if end if else @@ -22020,7 +22022,7 @@ module stdlib_linalg_lapack_c ! 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 @@ -22040,7 +22042,7 @@ module stdlib_linalg_lapack_c 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 @@ -22053,11 +22055,11 @@ module stdlib_linalg_lapack_c ! 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 = 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 @@ -22066,14 +22068,14 @@ module stdlib_linalg_lapack_c ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( krowmax ) then rowmax = stemp @@ -22117,7 +22119,7 @@ module stdlib_linalg_lapack_c ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found, set variables and repeat @@ -22130,36 +22132,36 @@ module stdlib_linalg_lapack_c end if ! swap two rows and two columns ! first swap - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! interchange rows and column k and p in the trailing ! submatrix a(k:n,k:n) if we have a 2-by-2 pivot - if( p(k+1) )call stdlib_cswap( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) + if( p(k+1) )call stdlib${ii}$_cswap( p-k-1, a( k+1, k ), 1_${ik}$, a( p, k+1 ), lda ) t = a( k, k ) a( k, k ) = a( p, p ) a( p, p ) = t end if ! second swap - kk = k + kstep - 1 + 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_cswap( kp-kk-1, a( kk+1, kk ), & - 1, a( kp, kk+1 ),lda ) + if( ( kk(kk+1) ) )call stdlib${ii}$_cswap( kp-kk-1, a( kk+1, kk ), & + 1_${ik}$, a( kp, kk+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t - if( kstep==2 ) 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 + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = l(k)*d(k) ! where l(k) is the k-th column of l @@ -22171,10 +22173,10 @@ module stdlib_linalg_lapack_c ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t d11 = cone / a( k, k ) - call stdlib_csyr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_csyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda ) ! store l(k) in column k - call stdlib_cscal( n-k, d11, a( k+1, k ), 1 ) + call stdlib${ii}$_cscal( n-k, d11, a( k+1, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = a( k, k ) @@ -22185,7 +22187,7 @@ module stdlib_linalg_lapack_c ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_csyr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_csyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda ) end if end if @@ -22220,7 +22222,7 @@ module stdlib_linalg_lapack_c 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 @@ -22232,10 +22234,10 @@ module stdlib_linalg_lapack_c end if 70 continue return - end subroutine stdlib_csytf2_rook + end subroutine stdlib${ii}$_csytf2_rook - pure subroutine stdlib_csytrf( uplo, n, a, lda, ipiv, work, lwork, info ) + pure subroutine stdlib${ii}$_csytrf( uplo, n, a, lda, ipiv, work, lwork, info ) !! CSYTRF computes the factorization of a complex symmetric matrix A !! using the Bunch-Kaufman diagonal pivoting method. The form of the !! factorization is @@ -22249,60 +22251,60 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(inout) :: a(lda,*) complex(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_clasyf( uplo, k, nb, kb, a, lda, ipiv, work, n, iinfo ) + call stdlib${ii}$_clasyf( uplo, k, nb, kb, a, lda, ipiv, work, n, iinfo ) else ! use unblocked code to factorize columns 1:k of a - call stdlib_csytf2( uplo, k, a, lda, ipiv, iinfo ) + call stdlib${ii}$_csytf2( 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 ! 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_clasyf; + ! kb, where kb is the number of columns factorized by stdlib${ii}$_clasyf; ! 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_clasyf( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, n, & + call stdlib${ii}$_clasyf( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, n, & iinfo ) else ! use unblocked code to factorize columns k:n of a - call stdlib_csytf2( uplo, n-k+1, a( k, k ), lda, ipiv( k ), iinfo ) - kb = n - k + 1 + call stdlib${ii}$_csytf2( 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 @@ -22356,12 +22358,12 @@ module stdlib_linalg_lapack_c go to 20 end if 40 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_csytrf + end subroutine stdlib${ii}$_csytrf - pure subroutine stdlib_csytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) + pure subroutine stdlib${ii}$_csytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) !! CSYTRF_RK computes the factorization of a complex symmetric matrix A !! using the bounded Bunch-Kaufman (rook) diagonal pivoting method: !! A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), @@ -22376,60 +22378,60 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(inout) :: a(lda,*) complex(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_clasyf_rk( uplo, k, nb, kb, a, lda, e,ipiv, work, ldwork, iinfo ) + call stdlib${ii}$_clasyf_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_csytf2_rk( uplo, k, a, lda, e, ipiv, iinfo ) + call stdlib${ii}$_csytf2_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 ! read ipiv from the last block factored, i.e. @@ -22459,7 +22461,7 @@ module stdlib_linalg_lapack_c do i = k, ( k - kb + 1 ), -1 ip = abs( ipiv( i ) ) if( ip/=i ) then - call stdlib_cswap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda ) + call stdlib${ii}$_cswap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda ) end if end do end if @@ -22472,31 +22474,31 @@ module stdlib_linalg_lapack_c 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_clasyf_rk; + ! kb, where kb is the number of columns factorized by stdlib${ii}$_clasyf_rk; ! 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 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_clasyf_rk( uplo, n-k+1, nb, kb, a( k, k ), lda, e( k ),ipiv( k ), & + call stdlib${ii}$_clasyf_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_csytf2_rk( uplo, n-k+1, a( k, k ), lda, e( k ),ipiv( k ), iinfo ) + call stdlib${ii}$_csytf2_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 @@ -22506,11 +22508,11 @@ module stdlib_linalg_lapack_c ! (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 + if( k>1_${ik}$ ) then do i = k, ( k + kb - 1 ), 1 ip = abs( ipiv( i ) ) if( ip/=i ) then - call stdlib_cswap( k-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_cswap( k-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda ) end if end do end if @@ -22522,12 +22524,12 @@ module stdlib_linalg_lapack_c 35 continue ! end lower end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_csytrf_rk + end subroutine stdlib${ii}$_csytrf_rk - pure subroutine stdlib_csytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) + pure subroutine stdlib${ii}$_csytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) !! CSYTRF_ROOK computes the factorization of a complex symmetric matrix A !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. !! The form of the factorization is @@ -22541,60 +22543,60 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(inout) :: a(lda,*) complex(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_clasyf_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo ) + call stdlib${ii}$_clasyf_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo ) else ! use unblocked code to factorize columns 1:k of a - call stdlib_csytf2_rook( uplo, k, a, lda, ipiv, iinfo ) + call stdlib${ii}$_csytf2_rook( uplo, k, a, lda, ipiv, iinfo ) kb = k end if ! set info on the first occurrence of a zero pivot - if( info==0 .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 @@ -22619,30 +22621,30 @@ module stdlib_linalg_lapack_c 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_clasyf_rook; + ! kb, where kb is the number of columns factorized by stdlib${ii}$_clasyf_rook; ! kb is either nb or nb-1, or n-k+1 for the last block - k = 1 + 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_clasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, & + call stdlib${ii}$_clasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, & ldwork, iinfo ) else ! use unblocked code to factorize columns k:n of a - call stdlib_csytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo ) - kb = n - k + 1 + call stdlib${ii}$_csytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo ) + kb = n - k + 1_${ik}$ end if ! set info on the first occurrence of a zero pivot - if( info==0 .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 @@ -22650,12 +22652,12 @@ module stdlib_linalg_lapack_c go to 20 end if 40 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_csytrf_rook + end subroutine stdlib${ii}$_csytrf_rook - pure subroutine stdlib_csytri( uplo, n, a, lda, ipiv, work, info ) + pure subroutine stdlib${ii}$_csytri( uplo, n, a, lda, ipiv, work, info ) !! CSYTRI computes the inverse of a complex symmetric indefinite matrix !! A using the factorization A = U*D*U**T or A = L*D*L**T computed by !! CSYTRF. @@ -22664,33 +22666,33 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: k, kp, kstep + integer(${ik}$) :: k, kp, kstep complex(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 )==czero )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 = 1_${ik}$ 30 continue ! if k > n, exit from loop. if( k>n )go to 40 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = cone / a( k, k ) ! compute column k of the inverse. - if( k>1 ) then - call stdlib_ccopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_csymv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_ccopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_csymv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - stdlib_cdotu( k-1, work, 1, a( 1, k ),1 ) + a( k, k ) = a( k, k ) - stdlib${ii}$_cdotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ ) end if - kstep = 1 + kstep = 1_${ik}$ else ! 2 x 2 diagonal block ! invert the diagonal block. @@ -22740,31 +22742,31 @@ module stdlib_linalg_lapack_c 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_ccopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_csymv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_ccopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_csymv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - stdlib_cdotu( k-1, work, 1, a( 1, k ),1 ) - a( k, k+1 ) = a( k, k+1 ) -stdlib_cdotu( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) + a( k, k ) = a( k, k ) - stdlib${ii}$_cdotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ ) + a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_cdotu( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) - call stdlib_ccopy( k-1, a( 1, k+1 ), 1, work, 1 ) - call stdlib_csymv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k+1 ), 1 ) + call stdlib${ii}$_ccopy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_csymv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k+1 ), 1_${ik}$ ) - a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib_cdotu( k-1, work, 1, a( 1, k+1 ), 1 ) + a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib${ii}$_cdotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) end if - kstep = 2 + 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_cswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_cswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + call stdlib${ii}$_cswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + call stdlib${ii}$_cswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp - 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 @@ -22781,18 +22783,18 @@ module stdlib_linalg_lapack_c 50 continue ! if k < 1, exit from loop. if( k<1 )go to 60 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = cone / a( k, k ) ! compute column k of the inverse. if( k0 .and. a( info, info )==czero )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 = 1_${ik}$ 30 continue ! if k > n, exit from loop. if( k>n )go to 40 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = cone / a( k, k ) ! compute column k of the inverse. - if( k>1 ) then - call stdlib_ccopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_csymv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_ccopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_csymv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - stdlib_cdotu( k-1, work, 1, a( 1, k ),1 ) + a( k, k ) = a( k, k ) - stdlib${ii}$_cdotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ ) end if - kstep = 1 + kstep = 1_${ik}$ else ! 2 x 2 diagonal block ! invert the diagonal block. @@ -22928,28 +22930,28 @@ module stdlib_linalg_lapack_c 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_ccopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_csymv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_ccopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_csymv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - stdlib_cdotu( k-1, work, 1, a( 1, k ),1 ) - a( k, k+1 ) = a( k, k+1 ) -stdlib_cdotu( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) + a( k, k ) = a( k, k ) - stdlib${ii}$_cdotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ ) + a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_cdotu( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) - call stdlib_ccopy( k-1, a( 1, k+1 ), 1, work, 1 ) - call stdlib_csymv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k+1 ), 1 ) + call stdlib${ii}$_ccopy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_csymv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k+1 ), 1_${ik}$ ) - a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib_cdotu( k-1, work, 1, a( 1, k+1 ), 1 ) + a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib${ii}$_cdotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) end if - kstep = 2 + 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) kp = ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_cswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_cswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_cswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + call stdlib${ii}$_cswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp @@ -22959,8 +22961,8 @@ module stdlib_linalg_lapack_c ! -ipiv(k+1)in the leading submatrix a(1:k+1,1:k+1) kp = -ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_cswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_cswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_cswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + call stdlib${ii}$_cswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp @@ -22968,17 +22970,17 @@ module stdlib_linalg_lapack_c 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_cswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_cswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_cswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + call stdlib${ii}$_cswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp end if end if - k = k + 1 + k = k + 1_${ik}$ go to 30 40 continue else @@ -22989,18 +22991,18 @@ module stdlib_linalg_lapack_c 50 continue ! if k < 1, exit from loop. if( k<1 )go to 60 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = cone / a( k, k ) ! compute column k of the inverse. if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_cgeru( k-1, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & + call stdlib${ii}$_cgeru( k-1, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb & ) ! multiply by the inverse of the diagonal block. - call stdlib_cscal( nrhs, cone / a( k, k ), b( k, 1 ), ldb ) - k = k - 1 + call stdlib${ii}$_cscal( nrhs, cone / a( k, k ), b( k, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( kp/=k-1 )call stdlib_cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib${ii}$_cswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - call stdlib_cgeru( k-2, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & + call stdlib${ii}$_cgeru( k-2, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb & ) - call stdlib_cgeru( k-2, nrhs, -cone, a( 1, k-1 ), 1, b( k-1, 1 ),ldb, b( 1, 1 ), & + call stdlib${ii}$_cgeru( k-2, nrhs, -cone, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), & ldb ) ! multiply by the inverse of the diagonal block. akm1k = a( k-1, k ) @@ -23157,39 +23159,39 @@ module stdlib_linalg_lapack_c 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 = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(u**t(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, a( 1, k ),1, cone, b( & - k, 1 ), ldb ) + call stdlib${ii}$_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, a( 1_${ik}$, k ),1_${ik}$, cone, b( & + k, 1_${ik}$ ), ldb ) ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 1 + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 1_${ik}$ else ! 2 x 2 diagonal block ! multiply by inv(u**t(k+1)), where u(k+1) is the transformation ! stored in columns k and k+1 of a. - call stdlib_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, a( 1, k ),1, cone, b( & - k, 1 ), ldb ) - call stdlib_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb,a( 1, k+1 ), 1, cone, b(& - k+1, 1 ), ldb ) + call stdlib${ii}$_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, a( 1_${ik}$, k ),1_${ik}$, cone, b( & + k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb,a( 1_${ik}$, k+1 ), 1_${ik}$, cone, b(& + k+1, 1_${ik}$ ), ldb ) ! interchange rows k and -ipiv(k). kp = -ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 2 + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 2_${ik}$ end if go to 40 50 continue @@ -23198,34 +23200,34 @@ module stdlib_linalg_lapack_c ! 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 = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(l**t(k)), where l(k) is the transformation ! stored in column k of a. - if( k= 1 ) - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k-1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( kp==-ipiv( k-1 ) )call stdlib_cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb & + if( kp==-ipiv( k-1 ) )call stdlib${ii}$_cswap( 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_ctrsm('L','U','N','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib${ii}$_ctrsm('L','U','N','U',n,nrhs,cone,a,lda,b,ldb) ! compute d \ b -> b [ d \ (u \p**t * b) ] i=n do while ( i >= 1 ) - if( ipiv(i) > 0 ) then - call stdlib_cscal( nrhs, cone / a( i, i ), b( i, 1 ), ldb ) - elseif ( i > 1) then + if( ipiv(i) > 0_${ik}$ ) then + call stdlib${ii}$_cscal( nrhs, cone / 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 @@ -23365,58 +23367,58 @@ module stdlib_linalg_lapack_c 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_ctrsm('L','U','T','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib${ii}$_ctrsm('L','U','T','U',n,nrhs,cone,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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k+1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( k < n .and. kp==-ipiv( k+1 ) )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp,& - 1 ), ldb ) + if( k < n .and. kp==-ipiv( k+1 ) )call stdlib${ii}$_cswap( 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k+1 else ! 2 x 2 diagonal block ! interchange rows k and -ipiv(k+1). kp = -ipiv( k+1 ) - if( kp==-ipiv( k ) )call stdlib_cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp==-ipiv( k ) )call stdlib${ii}$_cswap( 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_ctrsm('L','L','N','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib${ii}$_ctrsm('L','L','N','U',n,nrhs,cone,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_cscal( nrhs, cone / a( i, i ), b( i, 1 ), ldb ) + if( ipiv(i) > 0_${ik}$ ) then + call stdlib${ii}$_cscal( nrhs, cone / a( i, i ), b( i, 1_${ik}$ ), ldb ) else akm1k = work(i) akm1 = a( i, i ) / akm1k @@ -23428,38 +23430,38 @@ module stdlib_linalg_lapack_c 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_ctrsm('L','L','T','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib${ii}$_ctrsm('L','L','T','U',n,nrhs,cone,a,lda,b,ldb) ! p * b [ p * (l**t \ (d \ (l \p**t * b) )) ] k=n do while ( k >= 1 ) - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k-1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( k>1 .and. kp==-ipiv( k-1 ) )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, & - 1 ), ldb ) + if( k>1_${ik}$ .and. kp==-ipiv( k-1 ) )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, & + 1_${ik}$ ), ldb ) k=k-2 endif end do end if ! revert a - call stdlib_csyconv( uplo, 'R', n, a, lda, ipiv, work, iinfo ) + call stdlib${ii}$_csyconv( uplo, 'R', n, a, lda, ipiv, work, iinfo ) return - end subroutine stdlib_csytrs2 + end subroutine stdlib${ii}$_csytrs2 - pure subroutine stdlib_csytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) + pure subroutine stdlib${ii}$_csytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) !! CSYTRS_3 solves a system of linear equations A * X = B with a complex !! symmetric matrix A using the factorization computed !! by CSYTRF_RK or CSYTRF_BK: @@ -23474,36 +23476,36 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(in) :: a(lda,*), e(*) complex(sp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: i, j, k, kp + integer(${ik}$) :: i, j, k, kp complex(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_ctrsm( 'L', 'U', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib${ii}$_ctrsm( 'L', 'U', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) ! compute d \ b -> b [ d \ (u \p**t * b) ] i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then - call stdlib_cscal( nrhs, cone / a( i, i ), b( i, 1 ), ldb ) - else if ( i>1 ) then + if( ipiv( i )>0_${ik}$ ) then + call stdlib${ii}$_cscal( nrhs, cone / 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 @@ -23541,12 +23543,12 @@ module stdlib_linalg_lapack_c 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_ctrsm( 'L', 'U', 'T', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib${ii}$_ctrsm( 'L', 'U', 'T', 'U', n, nrhs, cone, a, lda, b, ldb ) ! p * b [ p * (u**t \ (d \ (u \p**t * b) )) ] ! interchange rows k and ipiv(k) of matrix b in reverse order ! from the formation order of ipiv(i) vector for upper case. @@ -23556,7 +23558,7 @@ module stdlib_linalg_lapack_c do k = 1, n, 1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end if end do else @@ -23571,16 +23573,16 @@ module stdlib_linalg_lapack_c do k = 1, n, 1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib${ii}$_cswap( 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_ctrsm( 'L', 'L', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib${ii}$_ctrsm( 'L', 'L', 'N', 'U', n, nrhs, cone, 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_cscal( nrhs, cone / a( i, i ), b( i, 1 ), ldb ) + if( ipiv( i )>0_${ik}$ ) then + call stdlib${ii}$_cscal( nrhs, cone / a( i, i ), b( i, 1_${ik}$ ), ldb ) else if( i b [ l**t \ (d \ (l \p**t * b) ) ] - call stdlib_ctrsm('L', 'L', 'T', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib${ii}$_ctrsm('L', 'L', 'T', 'U', n, nrhs, cone, a, lda, b, ldb ) ! p * b [ p * (l**t \ (d \ (l \p**t * b) )) ] ! interchange rows k and ipiv(k) of matrix b in reverse order ! from the formation order of ipiv(i) vector for lower case. @@ -23607,16 +23609,16 @@ module stdlib_linalg_lapack_c do k = n, 1, -1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end if end do ! end lower end if return - end subroutine stdlib_csytrs_3 + end subroutine stdlib${ii}$_csytrs_3 - pure subroutine stdlib_csytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) + pure subroutine stdlib${ii}$_csytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) !! CSYTRS_AA solves a system of linear equations A*X = B with a complex !! symmetric matrix A using the factorization A = U**T*T*U or !! A = L*T*L**T computed by CSYTRF_AA. @@ -23626,42 +23628,42 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(in) :: a(lda,*) complex(sp), intent(inout) :: b(ldb,*) complex(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 + if( n>1_${ik}$ ) then ! pivot, p**t * b -> b do k = 1, n kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end do ! compute u**t \ b -> b [ (u**t \p**t * b) ] - call stdlib_ctrsm( 'L', 'U', 'T', 'U', n-1, nrhs, cone, a( 1, 2 ),lda, b( 2, 1 ),& + call stdlib${ii}$_ctrsm( 'L', 'U', 'T', 'U', n-1, nrhs, cone, a( 1_${ik}$, 2_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),& ldb) end if ! 2) solve with triangular matrix t ! compute t \ b -> b [ t \ (u**t \p**t * b) ] - call stdlib_clacpy( 'F', 1, n, a( 1, 1 ), lda+1, work( n ), 1) - if( n>1 ) then - call stdlib_clacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 1 ), 1 ) - call stdlib_clacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 2*n ), 1 ) + call stdlib${ii}$_clacpy( 'F', 1_${ik}$, n, a( 1_${ik}$, 1_${ik}$ ), lda+1, work( n ), 1_${ik}$) + if( n>1_${ik}$ ) then + call stdlib${ii}$_clacpy( 'F', 1_${ik}$, n-1, a( 1_${ik}$, 2_${ik}$ ), lda+1, work( 1_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_clacpy( 'F', 1_${ik}$, n-1, a( 1_${ik}$, 2_${ik}$ ), lda+1, work( 2_${ik}$*n ), 1_${ik}$ ) end if - call stdlib_cgtsv( n, nrhs, work( 1 ), work( n ), work( 2*n ), b, ldb,info ) + call stdlib${ii}$_cgtsv( n, nrhs, work( 1_${ik}$ ), work( n ), work( 2_${ik}$*n ), b, ldb,info ) ! 3) backward substitution with u - if( n>1 ) then + if( n>1_${ik}$ ) then ! compute u \ b -> b [ u \ (t \ (u**t \p**t * b) ) ] - call stdlib_ctrsm( 'L', 'U', 'N', 'U', n-1, nrhs, cone, a( 1, 2 ),lda, b( 2, 1 ),& + call stdlib${ii}$_ctrsm( 'L', 'U', 'N', 'U', n-1, nrhs, cone, a( 1_${ik}$, 2_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),& ldb) ! pivot, p * b -> b [ p * (u**t \ (t \ (u \p**t * b) )) ] do k = n, 1, -1 kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end do end if else ! solve a*x = b, where a = l*t*l**t. ! 1) forward substitution with l - if( n>1 ) then + if( n>1_${ik}$ ) then ! pivot, p**t * b -> b do k = 1, n kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end do ! compute l \ b -> b [ (l \p**t * b) ] - call stdlib_ctrsm( 'L', 'L', 'N', 'U', n-1, nrhs, cone, a( 2, 1 ),lda, b( 2, 1 ),& + call stdlib${ii}$_ctrsm( 'L', 'L', 'N', 'U', n-1, nrhs, cone, a( 2_${ik}$, 1_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),& ldb) end if ! 2) solve with triangular matrix t ! compute t \ b -> b [ t \ (l \p**t * b) ] - call stdlib_clacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1) - if( n>1 ) then - call stdlib_clacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 1 ), 1 ) - call stdlib_clacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 2*n ), 1 ) + call stdlib${ii}$_clacpy( 'F', 1_${ik}$, n, a(1_${ik}$, 1_${ik}$), lda+1, work(n), 1_${ik}$) + if( n>1_${ik}$ ) then + call stdlib${ii}$_clacpy( 'F', 1_${ik}$, n-1, a( 2_${ik}$, 1_${ik}$ ), lda+1, work( 1_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_clacpy( 'F', 1_${ik}$, n-1, a( 2_${ik}$, 1_${ik}$ ), lda+1, work( 2_${ik}$*n ), 1_${ik}$ ) end if - call stdlib_cgtsv( n, nrhs, work( 1 ), work(n), work( 2*n ), b, ldb,info) + call stdlib${ii}$_cgtsv( n, nrhs, work( 1_${ik}$ ), work(n), work( 2_${ik}$*n ), b, ldb,info) ! 3) backward substitution with l**t - if( n>1 ) then + if( n>1_${ik}$ ) then ! compute (l**t \ b) -> b [ l**t \ (t \ (l \p**t * b) ) ] - call stdlib_ctrsm( 'L', 'L', 'T', 'U', n-1, nrhs, cone, a( 2, 1 ),lda, b( 2, 1 ),& + call stdlib${ii}$_ctrsm( 'L', 'L', 'T', 'U', n-1, nrhs, cone, a( 2_${ik}$, 1_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),& ldb) ! pivot, p * b -> b [ p * (l**t \ (t \ (l \p**t * b) )) ] do k = n, 1, -1 kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end do end if end if return - end subroutine stdlib_csytrs_aa + end subroutine stdlib${ii}$_csytrs_aa - pure subroutine stdlib_csytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) + pure subroutine stdlib${ii}$_csytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) !! CSYTRS_ROOK solves a system of linear equations A*X = B with !! a complex symmetric matrix A using the factorization A = U*D*U**T or !! A = L*D*L**T computed by CSYTRF_ROOK. @@ -23744,36 +23746,36 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(in) :: a(lda,*) complex(sp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: j, k, kp + integer(${ik}$) :: j, k, kp complex(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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_cgeru( k-1, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & + call stdlib${ii}$_cgeru( k-1, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb & ) ! multiply by the inverse of the diagonal block. - call stdlib_cscal( nrhs, cone / a( k, k ), b( k, 1 ), ldb ) - k = k - 1 + call stdlib${ii}$_cscal( nrhs, cone / a( k, k ), b( k, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ else ! 2 x 2 diagonal block ! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1) kp = -ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) kp = -ipiv( k-1 ) - if( kp/=k-1 )call stdlib_cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib${ii}$_cswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - if( k>2 ) then - call stdlib_cgeru( k-2, nrhs,-cone, a( 1, k ), 1, b( k, 1 ),ldb, b( 1, 1 ), & + if( k>2_${ik}$ ) then + call stdlib${ii}$_cgeru( k-2, nrhs,-cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), & ldb ) - call stdlib_cgeru( k-2, nrhs,-cone, a( 1, k-1 ), 1, b( k-1, 1 ),ldb, b( 1, 1 )& + call stdlib${ii}$_cgeru( k-2, nrhs,-cone, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ )& , ldb ) end if ! multiply by the inverse of the diagonal block. @@ -23825,43 +23827,43 @@ module stdlib_linalg_lapack_c 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 = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(u**t(k)), where u(k) is the transformation ! stored in column k of a. - if( k>1 )call stdlib_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), 1, & - cone, b( k, 1 ), ldb ) + if( k>1_${ik}$ )call stdlib${ii}$_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, & + cone, b( k, 1_${ik}$ ), ldb ) ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 1 + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 1_${ik}$ else ! 2 x 2 diagonal block ! multiply by inv(u**t(k+1)), where u(k+1) is the transformation ! stored in columns k and k+1 of a. - if( k>1 ) then - call stdlib_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), 1, cone, & - b( k, 1 ), ldb ) - call stdlib_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k+1 ), 1, cone,& - b( k+1, 1 ), ldb ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, cone, & + b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_cgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k+1 ), 1_${ik}$, cone,& + b( k+1, 1_${ik}$ ), ldb ) end if ! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1). kp = -ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) kp = -ipiv( k+1 ) - if( kp/=k+1 )call stdlib_cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 2 + if( kp/=k+1 )call stdlib${ii}$_cswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 2_${ik}$ end if go to 40 50 continue @@ -23870,36 +23872,36 @@ module stdlib_linalg_lapack_c ! 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 = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(l**t(k)), where l(k) is the transformation ! stored in column k of a. - if( k 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 + 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 @@ -24871,28 +24873,28 @@ module stdlib_linalg_lapack_c do j = 1 + i, n2 ij = i + j*lda ap( ijp ) = conjg( 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 + ijp = 0_${ik}$ do j = 0, n1 - 1 ij = n2 + j do i = 0, j ap( ijp ) = conjg( 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 @@ -24903,38 +24905,38 @@ module stdlib_linalg_lapack_c ! 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 + ijp = 0_${ik}$ do i = 0, n2 do ij = i*( lda+1 ), n*lda - 1, lda ap( ijp ) = conjg( 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 + 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 ) = conjg( arf( ij ) ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do end do end if @@ -24947,13 +24949,13 @@ module stdlib_linalg_lapack_c ! 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 + 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 @@ -24961,28 +24963,28 @@ module stdlib_linalg_lapack_c do j = i, k - 1 ij = i + j*lda ap( ijp ) = conjg( 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 + ijp = 0_${ik}$ do j = 0, k - 1 - ij = k + 1 + j + ij = k + 1_${ik}$ + j do i = 0, j ap( ijp ) = conjg( 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 @@ -24993,48 +24995,48 @@ module stdlib_linalg_lapack_c ! 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 + ijp = 0_${ik}$ do i = 0, k - 1 do ij = i + ( i+1 )*lda, ( n+1 )*lda - 1, lda ap( ijp ) = conjg( 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 + 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 ) = conjg( arf( ij ) ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do end do end if end if end if return - end subroutine stdlib_ctfttp + end subroutine stdlib${ii}$_ctfttp - pure subroutine stdlib_ctfttr( transr, uplo, n, arf, a, lda, info ) + pure subroutine stdlib${ii}$_ctfttr( transr, uplo, n, arf, a, lda, info ) !! CTFTTR copies a triangular matrix A from rectangular full packed !! format (TF) to standard full format (TR). ! -- lapack computational routine -- @@ -25042,65 +25044,65 @@ module stdlib_linalg_lapack_c ! -- 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 - complex(sp), intent(out) :: a(0:lda-1,0:*) - complex(sp), intent(in) :: arf(0:*) + complex(sp), intent(out) :: a(0_${ik}$:lda-1,0_${ik}$:*) + complex(sp), intent(in) :: arf(0_${ik}$:*) ! ===================================================================== ! Parameters ! 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 :: conjg,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, 'C' ) ) 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 a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1); lda=n - ij = 0 + ij = 0_${ik}$ do j = 0, n2 do i = n1, n2 + j a( n2+j, i ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do i = j, n - 1 a( i, j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do else @@ -25132,11 +25134,11 @@ module stdlib_linalg_lapack_c do j = n - 1, n1, -1 do i = 0, j a( i, j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do l = j - n1, n1 - 1 a( j-n1, l ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do ij = ij - nx2 end do @@ -25147,42 +25149,42 @@ module stdlib_linalg_lapack_c ! 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 - ij = 0 + ij = 0_${ik}$ do j = 0, n2 - 1 do i = 0, j a( j, i ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do i = n1 + j, n - 1 a( i, n1+j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do do j = n2, n - 1 do i = 0, n1 - 1 a( j, i ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do 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 - ij = 0 + ij = 0_${ik}$ do j = 0, n1 do i = n1, n - 1 a( j, i ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do do j = 0, n1 - 1 do i = 0, j a( i, j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do l = n2 + j, n - 1 a( n2+j, l ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do end if @@ -25195,30 +25197,30 @@ module stdlib_linalg_lapack_c ! 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); lda=n+1 - ij = 0 + ij = 0_${ik}$ do j = 0, k - 1 do i = k, k + j a( k+j, i ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do i = j, n - 1 a( i, j ) = arf( ij ) - ij = ij + 1 + ij = ij + 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); lda=n+1 - ij = nt - n - 1 + ij = nt - n - 1_${ik}$ do j = n - 1, k, -1 do i = 0, j a( i, j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do l = j - k, k - 1 a( j-k, l ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do ij = ij - np1x2 end do @@ -25229,62 +25231,62 @@ module stdlib_linalg_lapack_c ! srpa for lower, transpose and n is even (see paper, a=b) ! t1 -> a(0,1) , t2 -> a(0,0) , s -> a(0,k+1) : ! t1 -> a(0+k) , t2 -> a(0+0) , s -> a(0+k*(k+1)); lda=k - ij = 0 + ij = 0_${ik}$ j = k do i = k, n - 1 a( i, j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do j = 0, k - 2 do i = 0, j a( j, i ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do i = k + 1 + j, n - 1 a( i, k+1+j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do do j = k - 1, n - 1 do i = 0, k - 1 a( j, i ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do else ! srpa for upper, transpose and n is even (see paper, a=b) ! t1 -> a(0,k+1) , t2 -> a(0,k) , s -> a(0,0) ! t1 -> a(0+k*(k+1)) , t2 -> a(0+k*k) , s -> a(0+0)); lda=k - ij = 0 + ij = 0_${ik}$ do j = 0, k do i = k, n - 1 a( j, i ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do do j = 0, k - 2 do i = 0, j a( i, j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do l = k + 1 + j, n - 1 a( k+1+j, l ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do ! note that here j = k-1 do i = 0, j a( i, j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end if end if end if return - end subroutine stdlib_ctfttr + end subroutine stdlib${ii}$_ctfttr - pure subroutine stdlib_ctgevc( side, howmny, select, n, s, lds, p, ldp, vl,ldvl, vr, ldvr, & + pure subroutine stdlib${ii}$_ctgevc( side, howmny, select, n, s, lds, p, ldp, vl,ldvl, vr, ldvr, & !! CTGEVC computes some or all of the right and/or left eigenvectors of !! a pair of complex matrices (S,P), where S and P are upper triangular. !! Matrix pairs of this type are produced by the generalized Schur @@ -25309,8 +25311,8 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: howmny, side - integer(ilp), intent(out) :: info, m - integer(ilp), intent(in) :: ldp, lds, ldvl, ldvr, mm, n + integer(${ik}$), intent(out) :: info, m + integer(${ik}$), intent(in) :: ldp, lds, ldvl, ldvr, mm, n ! Array Arguments logical(lk), intent(in) :: select(*) real(sp), intent(out) :: rwork(*) @@ -25322,7 +25324,7 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: compl, compr, ilall, ilback, ilbbad, ilcomp, lsa, lsb - integer(ilp) :: i, ibeg, ieig, iend, ihwmny, im, iside, isrc, j, je, jr + integer(${ik}$) :: i, ibeg, ieig, iend, ihwmny, im, iside, isrc, j, je, jr real(sp) :: acoefa, acoeff, anorm, ascale, bcoefa, big, bignum, bnorm, bscale, dmin, & safmin, sbeta, scale, small, temp, ulp, xmax complex(sp) :: bcoeff, ca, cb, d, salpha, sum, suma, sumb, x @@ -25335,56 +25337,56 @@ module stdlib_linalg_lapack_c ! Executable Statements ! decode and test the input parameters if( stdlib_lsame( howmny, 'A' ) ) then - ihwmny = 1 + ihwmny = 1_${ik}$ ilall = .true. ilback = .false. else if( stdlib_lsame( howmny, 'S' ) ) then - ihwmny = 2 + ihwmny = 2_${ik}$ ilall = .false. ilback = .false. else if( stdlib_lsame( howmny, 'B' ) ) then - ihwmny = 3 + ihwmny = 3_${ik}$ ilall = .true. ilback = .true. else - ihwmny = -1 + ihwmny = -1_${ik}$ end if if( stdlib_lsame( side, 'R' ) ) then - iside = 1 + iside = 1_${ik}$ compl = .false. compr = .true. else if( stdlib_lsame( side, 'L' ) ) then - iside = 2 + iside = 2_${ik}$ compl = .true. compr = .false. else if( stdlib_lsame( side, 'B' ) ) then - iside = 3 + iside = 3_${ik}$ compl = .true. compr = .true. else - iside = -1 + iside = -1_${ik}$ end if - info = 0 - if( iside<0 ) then - info = -1 - else if( ihwmny<0 ) then - info = -2 - else if( n<0 ) then - info = -4 - else if( lds1 ) then + work( j ) = stdlib${ii}$_cladiv( -work( j ), d ) + if( j>1_${ik}$ ) then ! w = w + x(j)*(a s(*,j) - b p(*,j) ) with scaling if( abs1( work( j ) )>one ) then temp = one / abs1( work( j ) ) @@ -25666,12 +25668,12 @@ module stdlib_linalg_lapack_c end do loop_210 ! back transform eigenvector if howmny='b'. if( ilback ) then - call stdlib_cgemv( 'N', n, je, cone, vr, ldvr, work, 1,czero, work( n+1 ), & - 1 ) - isrc = 2 + call stdlib${ii}$_cgemv( 'N', n, je, cone, vr, ldvr, work, 1_${ik}$,czero, work( n+1 ), & + 1_${ik}$ ) + isrc = 2_${ik}$ iend = n else - isrc = 1 + isrc = 1_${ik}$ iend = je end if ! copy and scale eigenvector into column of vr @@ -25685,7 +25687,7 @@ module stdlib_linalg_lapack_c vr( jr, ieig ) = temp*work( ( isrc-1 )*n+jr ) end do else - iend = 0 + iend = 0_${ik}$ end if do jr = iend + 1, n vr( jr, ieig ) = czero @@ -25694,10 +25696,10 @@ module stdlib_linalg_lapack_c end do loop_250 end if return - end subroutine stdlib_ctgevc + end subroutine stdlib${ii}$_ctgevc - pure subroutine stdlib_ctgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, j1, info ) + pure subroutine stdlib${ii}$_ctgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, j1, info ) !! CTGEX2 swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22) !! in an upper triangular matrix pair (A, B) by an unitary equivalence !! transformation. @@ -25713,14 +25715,14 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: wantq, wantz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: j1, lda, ldb, ldq, ldz, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: j1, lda, ldb, ldq, ldz, n ! Array Arguments complex(sp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) ! ===================================================================== ! Parameters real(sp), parameter :: twenty = 2.0e+1_sp - integer(ilp), parameter :: ldst = 2 + integer(${ik}$), parameter :: ldst = 2_${ik}$ logical(lk), parameter :: wands = .true. @@ -25728,35 +25730,35 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: strong, weak - integer(ilp) :: i, m + integer(${ik}$) :: i, m real(sp) :: cq, cz, eps, sa, sb, scale, smlnum, sum, thresha, threshb complex(sp) :: cdum, f, g, sq, sz ! Local Arrays - complex(sp) :: s(ldst,ldst), t(ldst,ldst), work(8) + complex(sp) :: s(ldst,ldst), t(ldst,ldst), work(8_${ik}$) ! Intrinsic Functions intrinsic :: abs,conjg,max,real,sqrt ! Executable Statements - info = 0 + info = 0_${ik}$ ! quick return if possible if( n<=1 )return m = ldst weak = .false. strong = .false. ! make a local copy of selected block in (a, b) - call stdlib_clacpy( 'FULL', m, m, a( j1, j1 ), lda, s, ldst ) - call stdlib_clacpy( 'FULL', m, m, b( j1, j1 ), ldb, t, ldst ) + call stdlib${ii}$_clacpy( 'FULL', m, m, a( j1, j1 ), lda, s, ldst ) + call stdlib${ii}$_clacpy( 'FULL', m, m, b( j1, j1 ), ldb, t, ldst ) ! compute the threshold for testing the acceptance of swapping. - eps = stdlib_slamch( 'P' ) - smlnum = stdlib_slamch( 'S' ) / eps + eps = stdlib${ii}$_slamch( 'P' ) + smlnum = stdlib${ii}$_slamch( 'S' ) / eps scale = real( czero,KIND=sp) sum = real( cone,KIND=sp) - call stdlib_clacpy( 'FULL', m, m, s, ldst, work, m ) - call stdlib_clacpy( 'FULL', m, m, t, ldst, work( m*m+1 ), m ) - call stdlib_classq( m*m, work, 1, scale, sum ) + call stdlib${ii}$_clacpy( 'FULL', m, m, s, ldst, work, m ) + call stdlib${ii}$_clacpy( 'FULL', m, m, t, ldst, work( m*m+1 ), m ) + call stdlib${ii}$_classq( m*m, work, 1_${ik}$, scale, sum ) sa = scale*sqrt( sum ) scale = real( czero,KIND=sp) sum = real( cone,KIND=sp) - call stdlib_classq( m*m, work(m*m+1), 1, scale, sum ) + call stdlib${ii}$_classq( m*m, work(m*m+1), 1_${ik}$, scale, sum ) sb = scale*sqrt( sum ) ! thres has been changed from ! thresh = max( ten*eps*sa, smlnum ) @@ -25769,34 +25771,34 @@ module stdlib_linalg_lapack_c threshb = max( twenty*eps*sb, smlnum ) ! compute unitary ql and rq that swap 1-by-1 and 1-by-1 blocks ! using givens rotations and perform the swap tentatively. - f = s( 2, 2 )*t( 1, 1 ) - t( 2, 2 )*s( 1, 1 ) - g = s( 2, 2 )*t( 1, 2 ) - t( 2, 2 )*s( 1, 2 ) - sa = abs( s( 2, 2 ) ) * abs( t( 1, 1 ) ) - sb = abs( s( 1, 1 ) ) * abs( t( 2, 2 ) ) - call stdlib_clartg( g, f, cz, sz, cdum ) + f = s( 2_${ik}$, 2_${ik}$ )*t( 1_${ik}$, 1_${ik}$ ) - t( 2_${ik}$, 2_${ik}$ )*s( 1_${ik}$, 1_${ik}$ ) + g = s( 2_${ik}$, 2_${ik}$ )*t( 1_${ik}$, 2_${ik}$ ) - t( 2_${ik}$, 2_${ik}$ )*s( 1_${ik}$, 2_${ik}$ ) + sa = abs( s( 2_${ik}$, 2_${ik}$ ) ) * abs( t( 1_${ik}$, 1_${ik}$ ) ) + sb = abs( s( 1_${ik}$, 1_${ik}$ ) ) * abs( t( 2_${ik}$, 2_${ik}$ ) ) + call stdlib${ii}$_clartg( g, f, cz, sz, cdum ) sz = -sz - call stdlib_crot( 2, s( 1, 1 ), 1, s( 1, 2 ), 1, cz, conjg( sz ) ) - call stdlib_crot( 2, t( 1, 1 ), 1, t( 1, 2 ), 1, cz, conjg( sz ) ) + call stdlib${ii}$_crot( 2_${ik}$, s( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, s( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, cz, conjg( sz ) ) + call stdlib${ii}$_crot( 2_${ik}$, t( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, t( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, cz, conjg( sz ) ) if( sa>=sb ) then - call stdlib_clartg( s( 1, 1 ), s( 2, 1 ), cq, sq, cdum ) + call stdlib${ii}$_clartg( s( 1_${ik}$, 1_${ik}$ ), s( 2_${ik}$, 1_${ik}$ ), cq, sq, cdum ) else - call stdlib_clartg( t( 1, 1 ), t( 2, 1 ), cq, sq, cdum ) + call stdlib${ii}$_clartg( t( 1_${ik}$, 1_${ik}$ ), t( 2_${ik}$, 1_${ik}$ ), cq, sq, cdum ) end if - call stdlib_crot( 2, s( 1, 1 ), ldst, s( 2, 1 ), ldst, cq, sq ) - call stdlib_crot( 2, t( 1, 1 ), ldst, t( 2, 1 ), ldst, cq, sq ) + call stdlib${ii}$_crot( 2_${ik}$, s( 1_${ik}$, 1_${ik}$ ), ldst, s( 2_${ik}$, 1_${ik}$ ), ldst, cq, sq ) + call stdlib${ii}$_crot( 2_${ik}$, t( 1_${ik}$, 1_${ik}$ ), ldst, t( 2_${ik}$, 1_${ik}$ ), ldst, cq, sq ) ! weak stability test: |s21| <= o(eps f-norm((a))) ! and |t21| <= o(eps f-norm((b))) - weak = abs( s( 2, 1 ) )<=thresha .and.abs( t( 2, 1 ) )<=threshb + weak = abs( s( 2_${ik}$, 1_${ik}$ ) )<=thresha .and.abs( t( 2_${ik}$, 1_${ik}$ ) )<=threshb if( .not.weak )go to 20 if( wands ) then ! strong stability test: ! f-norm((a-ql**h*s*qr, b-ql**h*t*qr)) <= o(eps*f-norm((a, b))) - call stdlib_clacpy( 'FULL', m, m, s, ldst, work, m ) - call stdlib_clacpy( 'FULL', m, m, t, ldst, work( m*m+1 ), m ) - call stdlib_crot( 2, work, 1, work( 3 ), 1, cz, -conjg( sz ) ) - call stdlib_crot( 2, work( 5 ), 1, work( 7 ), 1, cz, -conjg( sz ) ) - call stdlib_crot( 2, work, 2, work( 2 ), 2, cq, -sq ) - call stdlib_crot( 2, work( 5 ), 2, work( 6 ), 2, cq, -sq ) + call stdlib${ii}$_clacpy( 'FULL', m, m, s, ldst, work, m ) + call stdlib${ii}$_clacpy( 'FULL', m, m, t, ldst, work( m*m+1 ), m ) + call stdlib${ii}$_crot( 2_${ik}$, work, 1_${ik}$, work( 3_${ik}$ ), 1_${ik}$, cz, -conjg( sz ) ) + call stdlib${ii}$_crot( 2_${ik}$, work( 5_${ik}$ ), 1_${ik}$, work( 7_${ik}$ ), 1_${ik}$, cz, -conjg( sz ) ) + call stdlib${ii}$_crot( 2_${ik}$, work, 2_${ik}$, work( 2_${ik}$ ), 2_${ik}$, cq, -sq ) + call stdlib${ii}$_crot( 2_${ik}$, work( 5_${ik}$ ), 2_${ik}$, work( 6_${ik}$ ), 2_${ik}$, cq, -sq ) do i = 1, 2 work( i ) = work( i ) - a( j1+i-1, j1 ) work( i+2 ) = work( i+2 ) - a( j1+i-1, j1+1 ) @@ -25805,39 +25807,39 @@ module stdlib_linalg_lapack_c end do scale = real( czero,KIND=sp) sum = real( cone,KIND=sp) - call stdlib_classq( m*m, work, 1, scale, sum ) + call stdlib${ii}$_classq( m*m, work, 1_${ik}$, scale, sum ) sa = scale*sqrt( sum ) scale = real( czero,KIND=sp) sum = real( cone,KIND=sp) - call stdlib_classq( m*m, work(m*m+1), 1, scale, sum ) + call stdlib${ii}$_classq( m*m, work(m*m+1), 1_${ik}$, scale, sum ) sb = scale*sqrt( sum ) strong = sa<=thresha .and. sb<=threshb if( .not.strong )go to 20 end if ! if the swap is accepted ("weakly" and "strongly"), apply the ! equivalence transformations to the original matrix pair (a,b) - call stdlib_crot( j1+1, a( 1, j1 ), 1, a( 1, j1+1 ), 1, cz, conjg( sz ) ) - call stdlib_crot( j1+1, b( 1, j1 ), 1, b( 1, j1+1 ), 1, cz, conjg( sz ) ) - call stdlib_crot( n-j1+1, a( j1, j1 ), lda, a( j1+1, j1 ), lda, cq, sq ) - call stdlib_crot( n-j1+1, b( j1, j1 ), ldb, b( j1+1, j1 ), ldb, cq, sq ) + call stdlib${ii}$_crot( j1+1, a( 1_${ik}$, j1 ), 1_${ik}$, a( 1_${ik}$, j1+1 ), 1_${ik}$, cz, conjg( sz ) ) + call stdlib${ii}$_crot( j1+1, b( 1_${ik}$, j1 ), 1_${ik}$, b( 1_${ik}$, j1+1 ), 1_${ik}$, cz, conjg( sz ) ) + call stdlib${ii}$_crot( n-j1+1, a( j1, j1 ), lda, a( j1+1, j1 ), lda, cq, sq ) + call stdlib${ii}$_crot( n-j1+1, b( j1, j1 ), ldb, b( j1+1, j1 ), ldb, cq, sq ) ! set n1 by n2 (2,1) blocks to 0 a( j1+1, j1 ) = czero b( j1+1, j1 ) = czero ! accumulate transformations into q and z if requested. - if( wantz )call stdlib_crot( n, z( 1, j1 ), 1, z( 1, j1+1 ), 1, cz, conjg( sz ) ) + if( wantz )call stdlib${ii}$_crot( n, z( 1_${ik}$, j1 ), 1_${ik}$, z( 1_${ik}$, j1+1 ), 1_${ik}$, cz, conjg( sz ) ) - if( wantq )call stdlib_crot( n, q( 1, j1 ), 1, q( 1, j1+1 ), 1, cq, conjg( sq ) ) + if( wantq )call stdlib${ii}$_crot( n, q( 1_${ik}$, j1 ), 1_${ik}$, q( 1_${ik}$, j1+1 ), 1_${ik}$, cq, conjg( sq ) ) ! exit with info = 0 if swap was successfully performed. return ! exit with info = 1 if swap was rejected. 20 continue - info = 1 + info = 1_${ik}$ return - end subroutine stdlib_ctgex2 + end subroutine stdlib${ii}$_ctgex2 - pure subroutine stdlib_ctgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, ifst, ilst, & + pure subroutine stdlib${ii}$_ctgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, ifst, ilst, & !! CTGEXC reorders the generalized Schur decomposition of a complex !! matrix pair (A,B), using an unitary equivalence transformation !! (A, B) := Q * (A, B) * Z**H, so that the diagonal block of (A, B) with @@ -25854,36 +25856,36 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: wantq, wantz - integer(ilp), intent(in) :: ifst, lda, ldb, ldq, ldz, n - integer(ilp), intent(inout) :: ilst - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ifst, lda, ldb, ldq, ldz, n + integer(${ik}$), intent(inout) :: ilst + integer(${ik}$), intent(out) :: info ! Array Arguments complex(sp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: here + integer(${ik}$) :: here ! Intrinsic Functions intrinsic :: max ! Executable Statements ! decode and test input arguments. - info = 0 - if( n<0 ) then - info = -3 - else if( ldan ) then - info = -12 - else if( ilst<1 .or. ilst>n ) then - info = -13 - end if - if( info/=0 ) then - call stdlib_xerbla( 'CTGEXC', -info ) + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( ldan ) then + info = -12_${ik}$ + else if( ilst<1_${ik}$ .or. ilst>n ) then + info = -13_${ik}$ + end if + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'CTGEXC', -info ) return end if ! quick return if possible @@ -25893,35 +25895,35 @@ module stdlib_linalg_lapack_c here = ifst 10 continue ! swap with next one below - call stdlib_ctgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz,here, info ) + call stdlib${ii}$_ctgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz,here, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then ilst = here return end if - here = here + 1 + here = here + 1_${ik}$ if( here=ilst )go to 20 - here = here + 1 + here = here + 1_${ik}$ end if ilst = here return - end subroutine stdlib_ctgexc + end subroutine stdlib${ii}$_ctgexc - pure subroutine stdlib_ctplqt2( m, n, l, a, lda, b, ldb, t, ldt, info ) + pure subroutine stdlib${ii}$_ctplqt2( m, n, l, a, lda, b, ldb, t, ldt, info ) !! CTPLQT2 computes a LQ a factorization of a complex "triangular-pentagonal" !! matrix C, which is composed of a triangular block A and pentagonal block B, !! using the compact WY representation for Q. @@ -25929,36 +25931,36 @@ module stdlib_linalg_lapack_c ! -- 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, ldb, ldt, n, m, l + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l ! Array Arguments complex(sp), intent(inout) :: a(lda,*), b(ldb,*) complex(sp), intent(out) :: t(ldt,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, p, mp, np + integer(${ik}$) :: i, j, p, mp, np complex(sp) :: alpha ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( l<0 .or. l>min(m,n) ) then - info = -3 - else if( ldamin(m,n) ) then + info = -3_${ik}$ + else if( ldamin(m,n) ) then - info = -3 - else if( ldamin(m,n) ) then + info = -3_${ik}$ + else if( lda 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 + ijp = 0_${ik}$ + jp = 0_${ik}$ do j = 0, n2 do i = j, n - 1 ij = i + jp arf( ij ) = ap( ijp ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do jp = jp + lda end do @@ -27057,28 +27059,28 @@ module stdlib_linalg_lapack_c do j = 1 + i, n2 ij = i + j*lda arf( ij ) = conjg( ap( ijp ) ) - 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 + ijp = 0_${ik}$ do j = 0, n1 - 1 ij = n2 + j do i = 0, j arf( ij ) = conjg( ap( ijp ) ) - 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 arf( ij ) = ap( ijp ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do js = js + lda end do @@ -27089,38 +27091,38 @@ module stdlib_linalg_lapack_c ! 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 + ijp = 0_${ik}$ do i = 0, n2 do ij = i*( lda+1 ), n*lda - 1, lda arf( ij ) = conjg( ap( ijp ) ) - 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 arf( ij ) = ap( ijp ) - 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 + ijp = 0_${ik}$ js = n2*lda do j = 0, n1 - 1 do ij = js, js + j arf( ij ) = ap( ijp ) - 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 arf( ij ) = conjg( ap( ijp ) ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do end do end if @@ -27133,13 +27135,13 @@ module stdlib_linalg_lapack_c ! 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 + 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 arf( ij ) = ap( ijp ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do jp = jp + lda end do @@ -27147,28 +27149,28 @@ module stdlib_linalg_lapack_c do j = i, k - 1 ij = i + j*lda arf( ij ) = conjg( ap( ijp ) ) - 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 + ijp = 0_${ik}$ do j = 0, k - 1 - ij = k + 1 + j + ij = k + 1_${ik}$ + j do i = 0, j arf( ij ) = conjg( ap( ijp ) ) - 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 arf( ij ) = ap( ijp ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do js = js + lda end do @@ -27179,48 +27181,48 @@ module stdlib_linalg_lapack_c ! 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 + ijp = 0_${ik}$ do i = 0, k - 1 do ij = i + ( i+1 )*lda, ( n+1 )*lda - 1, lda arf( ij ) = conjg( ap( ijp ) ) - 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 arf( ij ) = ap( ijp ) - 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 + ijp = 0_${ik}$ js = ( k+1 )*lda do j = 0, k - 1 do ij = js, js + j arf( ij ) = ap( ijp ) - 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 arf( ij ) = conjg( ap( ijp ) ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do end do end if end if end if return - end subroutine stdlib_ctpttf + end subroutine stdlib${ii}$_ctpttf - pure subroutine stdlib_ctpttr( uplo, n, ap, a, lda, info ) + pure subroutine stdlib${ii}$_ctpttr( uplo, n, ap, a, lda, info ) !! CTPTTR copies a triangular matrix A from standard packed format (TP) !! to standard full format (TR). ! -- lapack computational routine -- @@ -27228,8 +27230,8 @@ module stdlib_linalg_lapack_c ! -- 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) :: n, lda + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n, lda ! Array Arguments complex(sp), intent(out) :: a(lda,*) complex(sp), intent(in) :: ap(*) @@ -27237,44 +27239,44 @@ module stdlib_linalg_lapack_c ! Parameters ! Local Scalars logical(lk) :: lower - integer(ilp) :: i, j, k + integer(${ik}$) :: i, j, k ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ lower = stdlib_lsame( uplo, 'L' ) if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda1 ) then - call stdlib_clatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', 'Y',ki-1, t, ldt, & - work( 1 ), scale, rwork,info ) + if( ki>1_${ik}$ ) then + call stdlib${ii}$_clatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', 'Y',ki-1, t, ldt, & + work( 1_${ik}$ ), scale, rwork,info ) work( ki ) = scale end if ! copy the vector x or q*x to vr and normalize. if( .not.over ) then - call stdlib_ccopy( ki, work( 1 ), 1, vr( 1, is ), 1 ) - ii = stdlib_icamax( ki, vr( 1, is ), 1 ) + call stdlib${ii}$_ccopy( ki, work( 1_${ik}$ ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ ) + ii = stdlib${ii}$_icamax( ki, vr( 1_${ik}$, is ), 1_${ik}$ ) remax = one / cabs1( vr( ii, is ) ) - call stdlib_csscal( ki, remax, vr( 1, is ), 1 ) + call stdlib${ii}$_csscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ ) do k = ki + 1, n vr( k, is ) = cmzero end do else - if( ki>1 )call stdlib_cgemv( 'N', n, ki-1, cmone, vr, ldvr, work( 1 ),1, & - cmplx( scale,KIND=sp), vr( 1, ki ), 1 ) - ii = stdlib_icamax( n, vr( 1, ki ), 1 ) + if( ki>1_${ik}$ )call stdlib${ii}$_cgemv( 'N', n, ki-1, cmone, vr, ldvr, work( 1_${ik}$ ),1_${ik}$, & + cmplx( scale,KIND=sp), vr( 1_${ik}$, ki ), 1_${ik}$ ) + ii = stdlib${ii}$_icamax( n, vr( 1_${ik}$, ki ), 1_${ik}$ ) remax = one / cabs1( vr( ii, ki ) ) - call stdlib_csscal( n, remax, vr( 1, ki ), 1 ) + call stdlib${ii}$_csscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ ) end if ! set back the original diagonal elements of t. do k = 1, ki - 1 t( k, k ) = work( k+n ) end do - is = is - 1 + is = is - 1_${ik}$ end do loop_80 end if if( leftv ) then ! compute left eigenvectors. - is = 1 + is = 1_${ik}$ loop_130: do ki = 1, n if( somev ) then if( .not.select( ki ) )cycle loop_130 @@ -27443,38 +27445,38 @@ module stdlib_linalg_lapack_c if( cabs1( t( k, k ) )= n + 2*n*nbmin ) then - nb = (lwork - n) / (2*n) + if( over .and. lwork >= n + 2_${ik}$*n*nbmin ) then + nb = (lwork - n) / (2_${ik}$*n) nb = min( nb, nbmax ) - call stdlib_claset( 'F', n, 1+2*nb, czero, czero, work, n ) + call stdlib${ii}$_claset( 'F', n, 1_${ik}$+2*nb, czero, czero, work, n ) else - nb = 1 + nb = 1_${ik}$ end if ! set the constants to control overflow. - unfl = stdlib_slamch( 'SAFE MINIMUM' ) + unfl = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) ovfl = one / unfl - call stdlib_slabad( unfl, ovfl ) - ulp = stdlib_slamch( 'PRECISION' ) + call stdlib${ii}$_slabad( unfl, ovfl ) + ulp = stdlib${ii}$_slamch( 'PRECISION' ) smlnum = unfl*( n / ulp ) ! store the diagonal elements of t in working array work. do i = 1, n @@ -27594,9 +27596,9 @@ module stdlib_linalg_lapack_c end do ! compute 1-norm of each column of strictly upper triangular ! part of t to control overflow in triangular solver. - rwork( 1 ) = zero + rwork( 1_${ik}$ ) = zero do j = 2, n - rwork( j ) = stdlib_scasum( j-1, t( 1, j ), 1 ) + rwork( j ) = stdlib${ii}$_scasum( j-1, t( 1_${ik}$, j ), 1_${ik}$ ) end do if( rightv ) then ! ============================================================ @@ -27625,30 +27627,30 @@ module stdlib_linalg_lapack_c t( k, k ) = t( k, k ) - t( ki, ki ) if( cabs1( t( k, k ) )1 ) then - call stdlib_clatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', 'Y',ki-1, t, ldt, & - work( 1 + iv*n ), scale,rwork, info ) + if( ki>1_${ik}$ ) then + call stdlib${ii}$_clatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', 'Y',ki-1, t, ldt, & + work( 1_${ik}$ + iv*n ), scale,rwork, info ) work( ki + iv*n ) = scale end if ! copy the vector x or q*x to vr and normalize. if( .not.over ) then ! ------------------------------ ! no back-transform: copy x to vr and normalize. - call stdlib_ccopy( ki, work( 1 + iv*n ), 1, vr( 1, is ), 1 ) - ii = stdlib_icamax( ki, vr( 1, is ), 1 ) + call stdlib${ii}$_ccopy( ki, work( 1_${ik}$ + iv*n ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ ) + ii = stdlib${ii}$_icamax( ki, vr( 1_${ik}$, is ), 1_${ik}$ ) remax = one / cabs1( vr( ii, is ) ) - call stdlib_csscal( ki, remax, vr( 1, is ), 1 ) + call stdlib${ii}$_csscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ ) do k = ki + 1, n vr( k, is ) = czero end do - else if( nb==1 ) then + else if( nb==1_${ik}$ ) then ! ------------------------------ ! version 1: back-transform each vector with gemv, q*x. - if( ki>1 )call stdlib_cgemv( 'N', n, ki-1, cone, vr, ldvr,work( 1 + iv*n ), 1,& - cmplx( scale,KIND=sp),vr( 1, ki ), 1 ) - ii = stdlib_icamax( n, vr( 1, ki ), 1 ) + if( ki>1_${ik}$ )call stdlib${ii}$_cgemv( 'N', n, ki-1, cone, vr, ldvr,work( 1_${ik}$ + iv*n ), 1_${ik}$,& + cmplx( scale,KIND=sp),vr( 1_${ik}$, ki ), 1_${ik}$ ) + ii = stdlib${ii}$_icamax( n, vr( 1_${ik}$, ki ), 1_${ik}$ ) remax = one / cabs1( vr( ii, ki ) ) - call stdlib_csscal( n, remax, vr( 1, ki ), 1 ) + call stdlib${ii}$_csscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ ) else ! ------------------------------ ! version 2: back-transform block of vectors with gemm @@ -27659,27 +27661,27 @@ module stdlib_linalg_lapack_c ! columns iv:nb of work are valid vectors. ! when the number of vectors stored reaches nb, ! or if this was last vector, do the gemm - if( (iv==1) .or. (ki==1) ) then - call stdlib_cgemm( 'N', 'N', n, nb-iv+1, ki+nb-iv, cone,vr, ldvr,work( 1 + & - (iv)*n ), n,czero,work( 1 + (nb+iv)*n ), n ) + if( (iv==1_${ik}$) .or. (ki==1_${ik}$) ) then + call stdlib${ii}$_cgemm( 'N', 'N', n, nb-iv+1, ki+nb-iv, cone,vr, ldvr,work( 1_${ik}$ + & + (iv)*n ), n,czero,work( 1_${ik}$ + (nb+iv)*n ), n ) ! normalize vectors do k = iv, nb - ii = stdlib_icamax( n, work( 1 + (nb+k)*n ), 1 ) + ii = stdlib${ii}$_icamax( n, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ ) remax = one / cabs1( work( ii + (nb+k)*n ) ) - call stdlib_csscal( n, remax, work( 1 + (nb+k)*n ), 1 ) + call stdlib${ii}$_csscal( n, remax, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ ) end do - call stdlib_clacpy( 'F', n, nb-iv+1,work( 1 + (nb+iv)*n ), n,vr( 1, ki ), & + call stdlib${ii}$_clacpy( 'F', n, nb-iv+1,work( 1_${ik}$ + (nb+iv)*n ), n,vr( 1_${ik}$, ki ), & ldvr ) iv = nb else - iv = iv - 1 + iv = iv - 1_${ik}$ end if end if ! restore the original diagonal elements of t. do k = 1, ki - 1 t( k, k ) = work( k ) end do - is = is - 1 + is = is - 1_${ik}$ end do loop_80 end if if( leftv ) then @@ -27689,8 +27691,8 @@ module stdlib_linalg_lapack_c ! non-blocked version always uses iv=1; ! blocked version starts with iv=1, goes up to nb. ! (note the "0-th" column is used to store the original diagonal.) - iv = 1 - is = 1 + iv = 1_${ik}$ + is = 1_${ik}$ loop_130: do ki = 1, n if( somev ) then if( .not.select( ki ) )cycle loop_130 @@ -27710,7 +27712,7 @@ module stdlib_linalg_lapack_c if( cabs1( t( k, k ) )n ).and.( n>0 )) then - info = -7 - else if(( ilst<1 .or. ilst>n ).and.( n>0 )) then - info = -8 - end if - if( info/=0 ) then - call stdlib_xerbla( 'CTREXC', -info ) + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ + else if( ldtn ).and.( n>0_${ik}$ )) then + info = -7_${ik}$ + else if(( ilst<1_${ik}$ .or. ilst>n ).and.( n>0_${ik}$ )) then + info = -8_${ik}$ + end if + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'CTREXC', -info ) return end if ! quick return if possible if( n<=1 .or. ifst==ilst )return if( ifst=n ) then + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CTRTRI', uplo // diag, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code - call stdlib_ctrti2( uplo, diag, n, a, lda, info ) + call stdlib${ii}$_ctrti2( uplo, diag, n, a, lda, info ) else ! use blocked code if( upper ) then @@ -28373,35 +28375,35 @@ module stdlib_linalg_lapack_c do j = 1, n, nb jb = min( nb, n-j+1 ) ! compute rows 1:j-1 of current block column - call stdlib_ctrmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, cone, a, & - lda, a( 1, j ), lda ) - call stdlib_ctrsm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, -cone, a( & - j, j ), lda, a( 1, j ), lda ) + call stdlib${ii}$_ctrmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, cone, a, & + lda, a( 1_${ik}$, j ), lda ) + call stdlib${ii}$_ctrsm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, -cone, a( & + j, j ), lda, a( 1_${ik}$, j ), lda ) ! compute inverse of current diagonal block - call stdlib_ctrti2( 'UPPER', diag, jb, a( j, j ), lda, info ) + call stdlib${ii}$_ctrti2( '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_ctrmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, & + call stdlib${ii}$_ctrmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, & cone, a( j+jb, j+jb ), lda,a( j+jb, j ), lda ) - call stdlib_ctrsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, -& + call stdlib${ii}$_ctrsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, -& cone, a( j, j ), lda,a( j+jb, j ), lda ) end if ! compute inverse of current diagonal block - call stdlib_ctrti2( 'LOWER', diag, jb, a( j, j ), lda, info ) + call stdlib${ii}$_ctrti2( 'LOWER', diag, jb, a( j, j ), lda, info ) end do end if end if return - end subroutine stdlib_ctrtri + end subroutine stdlib${ii}$_ctrtri - pure subroutine stdlib_ctrtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info ) + pure subroutine stdlib${ii}$_ctrtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info ) !! CTRTRS solves a triangular system of the form !! A * X = B, A**T * X = B, or A**H * X = B, !! where A is a triangular matrix of order N, and B is an N-by-NRHS @@ -28411,8 +28413,8 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(in) :: a(lda,*) complex(sp), intent(inout) :: b(ldb,*) @@ -28424,26 +28426,26 @@ module stdlib_linalg_lapack_c 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 a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1); lda=n - ij = 0 + ij = 0_${ik}$ do j = 0, n2 do i = n1, n2 + j arf( ij ) = conjg( a( n2+j, i ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do i = j, n - 1 arf( ij ) = a( i, j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do else @@ -28558,11 +28560,11 @@ module stdlib_linalg_lapack_c do j = n - 1, n1, -1 do i = 0, j arf( ij ) = a( i, j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do l = j - n1, n1 - 1 arf( ij ) = conjg( a( j-n1, l ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do ij = ij - nx2 end do @@ -28573,42 +28575,42 @@ module stdlib_linalg_lapack_c ! 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 - ij = 0 + ij = 0_${ik}$ do j = 0, n2 - 1 do i = 0, j arf( ij ) = conjg( a( j, i ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do i = n1 + j, n - 1 arf( ij ) = a( i, n1+j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do do j = n2, n - 1 do i = 0, n1 - 1 arf( ij ) = conjg( a( j, i ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do 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 - ij = 0 + ij = 0_${ik}$ do j = 0, n1 do i = n1, n - 1 arf( ij ) = conjg( a( j, i ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do do j = 0, n1 - 1 do i = 0, j arf( ij ) = a( i, j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do l = n2 + j, n - 1 arf( ij ) = conjg( a( n2+j, l ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do end if @@ -28621,30 +28623,30 @@ module stdlib_linalg_lapack_c ! 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); lda=n+1 - ij = 0 + ij = 0_${ik}$ do j = 0, k - 1 do i = k, k + j arf( ij ) = conjg( a( k+j, i ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do i = j, n - 1 arf( ij ) = a( i, j ) - ij = ij + 1 + ij = ij + 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); lda=n+1 - ij = nt - n - 1 + ij = nt - n - 1_${ik}$ do j = n - 1, k, -1 do i = 0, j arf( ij ) = a( i, j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do l = j - k, k - 1 arf( ij ) = conjg( a( j-k, l ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do ij = ij - np1x2 end do @@ -28655,62 +28657,62 @@ module stdlib_linalg_lapack_c ! srpa for lower, transpose and n is even (see paper, a=b) ! t1 -> a(0,1) , t2 -> a(0,0) , s -> a(0,k+1) : ! t1 -> a(0+k) , t2 -> a(0+0) , s -> a(0+k*(k+1)); lda=k - ij = 0 + ij = 0_${ik}$ j = k do i = k, n - 1 arf( ij ) = a( i, j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do j = 0, k - 2 do i = 0, j arf( ij ) = conjg( a( j, i ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do i = k + 1 + j, n - 1 arf( ij ) = a( i, k+1+j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do do j = k - 1, n - 1 do i = 0, k - 1 arf( ij ) = conjg( a( j, i ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do else ! srpa for upper, transpose and n is even (see paper, a=b) ! t1 -> a(0,k+1) , t2 -> a(0,k) , s -> a(0,0) ! t1 -> a(0+k*(k+1)) , t2 -> a(0+k*k) , s -> a(0+0)); lda=k - ij = 0 + ij = 0_${ik}$ do j = 0, k do i = k, n - 1 arf( ij ) = conjg( a( j, i ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do do j = 0, k - 2 do i = 0, j arf( ij ) = a( i, j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do l = k + 1 + j, n - 1 arf( ij ) = conjg( a( k+1+j, l ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do ! note that here j = k-1 do i = 0, j arf( ij ) = a( i, j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end if end if end if return - end subroutine stdlib_ctrttf + end subroutine stdlib${ii}$_ctrttf - pure subroutine stdlib_ctrttp( uplo, n, a, lda, ap, info ) + pure subroutine stdlib${ii}$_ctrttp( uplo, n, a, lda, ap, info ) !! CTRTTP copies a triangular matrix A from full format (TR) to standard !! packed format (TP). ! -- lapack computational routine -- @@ -28718,8 +28720,8 @@ module stdlib_linalg_lapack_c ! -- 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) :: n, lda + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n, lda ! Array Arguments complex(sp), intent(in) :: a(lda,*) complex(sp), intent(out) :: ap(*) @@ -28727,44 +28729,44 @@ module stdlib_linalg_lapack_c ! Parameters ! Local Scalars logical(lk) :: lower - integer(ilp) :: i, j, k + integer(${ik}$) :: i, j, k ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ lower = stdlib_lsame( uplo, 'L' ) if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda1 .and. nb1_${ik}$ .and. nb1 ) then + call stdlib${ii}$_clatrz( ib, n-i+1, n-m, a( i, i ), lda, tau( i ),work ) + if( i>1_${ik}$ ) then ! form the triangular factor of the block reflector ! h = h(i+ib-1) . . . h(i+1) h(i) - call stdlib_clarzt( 'BACKWARD', 'ROWWISE', n-m, ib, a( i, m1 ),lda, tau( i ), & + call stdlib${ii}$_clarzt( 'BACKWARD', 'ROWWISE', n-m, ib, a( i, m1 ),lda, tau( i ), & work, ldwork ) ! apply h to a(1:i-1,i:n) from the right - call stdlib_clarzb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', i-1, n-i+1,& - ib, n-m, a( i, m1 ),lda, work, ldwork, a( 1, i ), lda,work( ib+1 ), ldwork ) + call stdlib${ii}$_clarzb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', i-1, n-i+1,& + ib, n-m, a( i, m1 ),lda, work, ldwork, a( 1_${ik}$, i ), lda,work( ib+1 ), ldwork ) end if end do - mu = i + nb - 1 + mu = i + nb - 1_${ik}$ else mu = m end if ! use unblocked code to factor the last or only block - if( mu>0 )call stdlib_clatrz( mu, n, n-m, a, lda, tau, work ) - work( 1 ) = lwkopt + if( mu>0_${ik}$ )call stdlib${ii}$_clatrz( mu, n, n-m, a, lda, tau, work ) + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_ctzrzf + end subroutine stdlib${ii}$_ctzrzf - subroutine stdlib_cunbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & + subroutine stdlib${ii}$_cunbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & !! CUNBDB simultaneously bidiagonalizes the blocks of an M-by-M !! partitioned unitary matrix X: !! [ B11 | B12 0 0 ] @@ -28903,8 +28905,8 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: signs, trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldx11, ldx12, ldx21, ldx22, lwork, m, p, q + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldx11, ldx12, ldx21, ldx22, lwork, m, p, q ! Array Arguments real(sp), intent(out) :: phi(*), theta(*) complex(sp), intent(out) :: taup1(*), taup2(*), tauq1(*), tauq2(*), work(*) @@ -28917,14 +28919,14 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: colmajor, lquery - integer(ilp) :: i, lworkmin, lworkopt + integer(${ik}$) :: i, lworkmin, lworkopt real(sp) :: z1, z2, z3, z4 ! Intrinsic Functions intrinsic :: atan2,cos,max,min,sin intrinsic :: cmplx,conjg ! Executable Statements ! test input arguments - info = 0 + info = 0_${ik}$ colmajor = .not. stdlib_lsame( trans, 'T' ) if( .not. stdlib_lsame( signs, 'O' ) ) then z1 = realone @@ -28937,41 +28939,41 @@ module stdlib_linalg_lapack_c z3 = realone z4 = -realone end if - lquery = lwork == -1 - if( m < 0 ) then - info = -3 - else if( p < 0 .or. p > m ) then - info = -4 - else if( q < 0 .or. q > p .or. q > m-p .or.q > m-q ) then - info = -5 - else if( colmajor .and. ldx11 < max( 1, p ) ) then - info = -7 - else if( .not.colmajor .and. ldx11 < max( 1, q ) ) then - info = -7 - else if( colmajor .and. ldx12 < max( 1, p ) ) then - info = -9 - else if( .not.colmajor .and. ldx12 < max( 1, m-q ) ) then - info = -9 - else if( colmajor .and. ldx21 < max( 1, m-p ) ) then - info = -11 - else if( .not.colmajor .and. ldx21 < max( 1, q ) ) then - info = -11 - else if( colmajor .and. ldx22 < max( 1, m-p ) ) then - info = -13 - else if( .not.colmajor .and. ldx22 < max( 1, m-q ) ) then - info = -13 + lquery = lwork == -1_${ik}$ + if( m < 0_${ik}$ ) then + info = -3_${ik}$ + else if( p < 0_${ik}$ .or. p > m ) then + info = -4_${ik}$ + else if( q < 0_${ik}$ .or. q > p .or. q > m-p .or.q > m-q ) then + info = -5_${ik}$ + else if( colmajor .and. ldx11 < max( 1_${ik}$, p ) ) then + info = -7_${ik}$ + else if( .not.colmajor .and. ldx11 < max( 1_${ik}$, q ) ) then + info = -7_${ik}$ + else if( colmajor .and. ldx12 < max( 1_${ik}$, p ) ) then + info = -9_${ik}$ + else if( .not.colmajor .and. ldx12 < max( 1_${ik}$, m-q ) ) then + info = -9_${ik}$ + else if( colmajor .and. ldx21 < max( 1_${ik}$, m-p ) ) then + info = -11_${ik}$ + else if( .not.colmajor .and. ldx21 < max( 1_${ik}$, q ) ) then + info = -11_${ik}$ + else if( colmajor .and. ldx22 < max( 1_${ik}$, m-p ) ) then + info = -13_${ik}$ + else if( .not.colmajor .and. ldx22 < max( 1_${ik}$, m-q ) ) then + info = -13_${ik}$ end if ! compute workspace - if( info == 0 ) then + if( info == 0_${ik}$ ) then lworkopt = m - q lworkmin = m - q - work(1) = lworkopt + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not. lquery ) then - info = -21 + info = -21_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'XORBDB', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'XORBDB', -info ) return else if( lquery ) then return @@ -28980,230 +28982,230 @@ module stdlib_linalg_lapack_c if( colmajor ) then ! reduce columns 1, ..., q of x11, x12, x21, and x22 do i = 1, q - if( i == 1 ) then - call stdlib_cscal( p-i+1, cmplx( z1, 0.0_sp,KIND=sp), x11(i,i), 1 ) + if( i == 1_${ik}$ ) then + call stdlib${ii}$_cscal( p-i+1, cmplx( z1, 0.0_sp,KIND=sp), x11(i,i), 1_${ik}$ ) else - call stdlib_cscal( p-i+1, cmplx( z1*cos(phi(i-1)), 0.0_sp,KIND=sp),x11(i,i), & - 1 ) - call stdlib_caxpy( p-i+1, cmplx( -z1*z3*z4*sin(phi(i-1)),0.0_sp,KIND=sp), x12(& - i,i-1), 1, x11(i,i), 1 ) + call stdlib${ii}$_cscal( p-i+1, cmplx( z1*cos(phi(i-1)), 0.0_sp,KIND=sp),x11(i,i), & + 1_${ik}$ ) + call stdlib${ii}$_caxpy( p-i+1, cmplx( -z1*z3*z4*sin(phi(i-1)),0.0_sp,KIND=sp), x12(& + i,i-1), 1_${ik}$, x11(i,i), 1_${ik}$ ) end if - if( i == 1 ) then - call stdlib_cscal( m-p-i+1, cmplx( z2, 0.0_sp,KIND=sp), x21(i,i), 1 ) + if( i == 1_${ik}$ ) then + call stdlib${ii}$_cscal( m-p-i+1, cmplx( z2, 0.0_sp,KIND=sp), x21(i,i), 1_${ik}$ ) else - call stdlib_cscal( m-p-i+1, cmplx( z2*cos(phi(i-1)), 0.0_sp,KIND=sp),x21(i,i),& - 1 ) - call stdlib_caxpy( m-p-i+1, cmplx( -z2*z3*z4*sin(phi(i-1)),0.0_sp,KIND=sp), & - x22(i,i-1), 1, x21(i,i), 1 ) + call stdlib${ii}$_cscal( m-p-i+1, cmplx( z2*cos(phi(i-1)), 0.0_sp,KIND=sp),x21(i,i),& + 1_${ik}$ ) + call stdlib${ii}$_caxpy( m-p-i+1, cmplx( -z2*z3*z4*sin(phi(i-1)),0.0_sp,KIND=sp), & + x22(i,i-1), 1_${ik}$, x21(i,i), 1_${ik}$ ) end if - theta(i) = atan2( stdlib_scnrm2( m-p-i+1, x21(i,i), 1 ),stdlib_scnrm2( p-i+1, & - x11(i,i), 1 ) ) + theta(i) = atan2( stdlib${ii}$_scnrm2( m-p-i+1, x21(i,i), 1_${ik}$ ),stdlib${ii}$_scnrm2( p-i+1, & + x11(i,i), 1_${ik}$ ) ) if( p > i ) then - call stdlib_clarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) + call stdlib${ii}$_clarfgp( p-i+1, x11(i,i), x11(i+1,i), 1_${ik}$, taup1(i) ) else if ( p == i ) then - call stdlib_clarfgp( p-i+1, x11(i,i), x11(i,i), 1, taup1(i) ) + call stdlib${ii}$_clarfgp( p-i+1, x11(i,i), x11(i,i), 1_${ik}$, taup1(i) ) end if x11(i,i) = cone if ( m-p > i ) then - call stdlib_clarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1,taup2(i) ) + call stdlib${ii}$_clarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1_${ik}$,taup2(i) ) else if ( m-p == i ) then - call stdlib_clarfgp( m-p-i+1, x21(i,i), x21(i,i), 1,taup2(i) ) + call stdlib${ii}$_clarfgp( m-p-i+1, x21(i,i), x21(i,i), 1_${ik}$,taup2(i) ) end if x21(i,i) = cone if ( q > i ) then - call stdlib_clarf( 'L', p-i+1, q-i, x11(i,i), 1,conjg(taup1(i)), x11(i,i+1), & + call stdlib${ii}$_clarf( 'L', p-i+1, q-i, x11(i,i), 1_${ik}$,conjg(taup1(i)), x11(i,i+1), & ldx11, work ) - call stdlib_clarf( 'L', m-p-i+1, q-i, x21(i,i), 1,conjg(taup2(i)), x21(i,i+1),& + call stdlib${ii}$_clarf( 'L', m-p-i+1, q-i, x21(i,i), 1_${ik}$,conjg(taup2(i)), x21(i,i+1),& ldx21, work ) end if if ( m-q+1 > i ) then - call stdlib_clarf( 'L', p-i+1, m-q-i+1, x11(i,i), 1,conjg(taup1(i)), x12(i,i),& + call stdlib${ii}$_clarf( 'L', p-i+1, m-q-i+1, x11(i,i), 1_${ik}$,conjg(taup1(i)), x12(i,i),& ldx12, work ) - call stdlib_clarf( 'L', m-p-i+1, m-q-i+1, x21(i,i), 1,conjg(taup2(i)), x22(i,& + call stdlib${ii}$_clarf( 'L', m-p-i+1, m-q-i+1, x21(i,i), 1_${ik}$,conjg(taup2(i)), x22(i,& i), ldx22, work ) end if if( i < q ) then - call stdlib_cscal( q-i, cmplx( -z1*z3*sin(theta(i)), 0.0_sp,KIND=sp),x11(i,i+& - 1), ldx11 ) - call stdlib_caxpy( q-i, cmplx( z2*z3*cos(theta(i)), 0.0_sp,KIND=sp),x21(i,i+1)& + call stdlib${ii}$_cscal( q-i, cmplx( -z1*z3*sin(theta(i)), 0.0_sp,KIND=sp),x11(i,i+& + 1_${ik}$), ldx11 ) + call stdlib${ii}$_caxpy( q-i, cmplx( z2*z3*cos(theta(i)), 0.0_sp,KIND=sp),x21(i,i+1)& , ldx21, x11(i,i+1), ldx11 ) end if - call stdlib_cscal( m-q-i+1, cmplx( -z1*z4*sin(theta(i)), 0.0_sp,KIND=sp),x12(i,i)& + call stdlib${ii}$_cscal( m-q-i+1, cmplx( -z1*z4*sin(theta(i)), 0.0_sp,KIND=sp),x12(i,i)& , ldx12 ) - call stdlib_caxpy( m-q-i+1, cmplx( z2*z4*cos(theta(i)), 0.0_sp,KIND=sp),x22(i,i),& + call stdlib${ii}$_caxpy( m-q-i+1, cmplx( z2*z4*cos(theta(i)), 0.0_sp,KIND=sp),x22(i,i),& ldx22, x12(i,i), ldx12 ) - if( i < q )phi(i) = atan2( stdlib_scnrm2( q-i, x11(i,i+1), ldx11 ),stdlib_scnrm2(& + if( i < q )phi(i) = atan2( stdlib${ii}$_scnrm2( q-i, x11(i,i+1), ldx11 ),stdlib${ii}$_scnrm2(& m-q-i+1, x12(i,i), ldx12 ) ) if( i < q ) then - call stdlib_clacgv( q-i, x11(i,i+1), ldx11 ) + call stdlib${ii}$_clacgv( q-i, x11(i,i+1), ldx11 ) if ( i == q-1 ) then - call stdlib_clarfgp( q-i, x11(i,i+1), x11(i,i+1), ldx11,tauq1(i) ) + call stdlib${ii}$_clarfgp( q-i, x11(i,i+1), x11(i,i+1), ldx11,tauq1(i) ) else - call stdlib_clarfgp( q-i, x11(i,i+1), x11(i,i+2), ldx11,tauq1(i) ) + call stdlib${ii}$_clarfgp( q-i, x11(i,i+1), x11(i,i+2), ldx11,tauq1(i) ) end if x11(i,i+1) = cone end if if ( m-q+1 > i ) then - call stdlib_clacgv( m-q-i+1, x12(i,i), ldx12 ) + call stdlib${ii}$_clacgv( m-q-i+1, x12(i,i), ldx12 ) if ( m-q == i ) then - call stdlib_clarfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,tauq2(i) ) + call stdlib${ii}$_clarfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,tauq2(i) ) else - call stdlib_clarfgp( m-q-i+1, x12(i,i), x12(i,i+1), ldx12,tauq2(i) ) + call stdlib${ii}$_clarfgp( m-q-i+1, x12(i,i), x12(i,i+1), ldx12,tauq2(i) ) end if end if x12(i,i) = cone if( i < q ) then - call stdlib_clarf( 'R', p-i, q-i, x11(i,i+1), ldx11, tauq1(i),x11(i+1,i+1), & + call stdlib${ii}$_clarf( 'R', p-i, q-i, x11(i,i+1), ldx11, tauq1(i),x11(i+1,i+1), & ldx11, work ) - call stdlib_clarf( 'R', m-p-i, q-i, x11(i,i+1), ldx11, tauq1(i),x21(i+1,i+1), & + call stdlib${ii}$_clarf( 'R', m-p-i, q-i, x11(i,i+1), ldx11, tauq1(i),x21(i+1,i+1), & ldx21, work ) end if if ( p > i ) then - call stdlib_clarf( 'R', p-i, m-q-i+1, x12(i,i), ldx12, tauq2(i),x12(i+1,i), & + call stdlib${ii}$_clarf( 'R', p-i, m-q-i+1, x12(i,i), ldx12, tauq2(i),x12(i+1,i), & ldx12, work ) end if if ( m-p > i ) then - call stdlib_clarf( 'R', m-p-i, m-q-i+1, x12(i,i), ldx12,tauq2(i), x22(i+1,i), & + call stdlib${ii}$_clarf( 'R', m-p-i, m-q-i+1, x12(i,i), ldx12,tauq2(i), x22(i+1,i), & ldx22, work ) end if - if( i < q )call stdlib_clacgv( q-i, x11(i,i+1), ldx11 ) - call stdlib_clacgv( m-q-i+1, x12(i,i), ldx12 ) + if( i < q )call stdlib${ii}$_clacgv( q-i, x11(i,i+1), ldx11 ) + call stdlib${ii}$_clacgv( m-q-i+1, x12(i,i), ldx12 ) end do ! reduce columns q + 1, ..., p of x12, x22 do i = q + 1, p - call stdlib_cscal( m-q-i+1, cmplx( -z1*z4, 0.0_sp,KIND=sp), x12(i,i),ldx12 ) + call stdlib${ii}$_cscal( m-q-i+1, cmplx( -z1*z4, 0.0_sp,KIND=sp), x12(i,i),ldx12 ) - call stdlib_clacgv( m-q-i+1, x12(i,i), ldx12 ) + call stdlib${ii}$_clacgv( m-q-i+1, x12(i,i), ldx12 ) if ( i >= m-q ) then - call stdlib_clarfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,tauq2(i) ) + call stdlib${ii}$_clarfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,tauq2(i) ) else - call stdlib_clarfgp( m-q-i+1, x12(i,i), x12(i,i+1), ldx12,tauq2(i) ) + call stdlib${ii}$_clarfgp( m-q-i+1, x12(i,i), x12(i,i+1), ldx12,tauq2(i) ) end if x12(i,i) = cone if ( p > i ) then - call stdlib_clarf( 'R', p-i, m-q-i+1, x12(i,i), ldx12, tauq2(i),x12(i+1,i), & + call stdlib${ii}$_clarf( 'R', p-i, m-q-i+1, x12(i,i), ldx12, tauq2(i),x12(i+1,i), & ldx12, work ) end if - if( m-p-q >= 1 )call stdlib_clarf( 'R', m-p-q, m-q-i+1, x12(i,i), ldx12,tauq2(i),& + if( m-p-q >= 1_${ik}$ )call stdlib${ii}$_clarf( 'R', m-p-q, m-q-i+1, x12(i,i), ldx12,tauq2(i),& x22(q+1,i), ldx22, work ) - call stdlib_clacgv( m-q-i+1, x12(i,i), ldx12 ) + call stdlib${ii}$_clacgv( m-q-i+1, x12(i,i), ldx12 ) end do ! reduce columns p + 1, ..., m - q of x12, x22 do i = 1, m - p - q - call stdlib_cscal( m-p-q-i+1, cmplx( z2*z4, 0.0_sp,KIND=sp),x22(q+i,p+i), ldx22 ) + call stdlib${ii}$_cscal( m-p-q-i+1, cmplx( z2*z4, 0.0_sp,KIND=sp),x22(q+i,p+i), ldx22 ) - call stdlib_clacgv( m-p-q-i+1, x22(q+i,p+i), ldx22 ) - call stdlib_clarfgp( m-p-q-i+1, x22(q+i,p+i), x22(q+i,p+i+1),ldx22, tauq2(p+i) ) + call stdlib${ii}$_clacgv( m-p-q-i+1, x22(q+i,p+i), ldx22 ) + call stdlib${ii}$_clarfgp( m-p-q-i+1, x22(q+i,p+i), x22(q+i,p+i+1),ldx22, tauq2(p+i) ) x22(q+i,p+i) = cone - call stdlib_clarf( 'R', m-p-q-i, m-p-q-i+1, x22(q+i,p+i), ldx22,tauq2(p+i), x22(& + call stdlib${ii}$_clarf( 'R', m-p-q-i, m-p-q-i+1, x22(q+i,p+i), ldx22,tauq2(p+i), x22(& q+i+1,p+i), ldx22, work ) - call stdlib_clacgv( m-p-q-i+1, x22(q+i,p+i), ldx22 ) + call stdlib${ii}$_clacgv( m-p-q-i+1, x22(q+i,p+i), ldx22 ) end do else ! reduce columns 1, ..., q of x11, x12, x21, x22 do i = 1, q - if( i == 1 ) then - call stdlib_cscal( p-i+1, cmplx( z1, 0.0_sp,KIND=sp), x11(i,i),ldx11 ) + if( i == 1_${ik}$ ) then + call stdlib${ii}$_cscal( p-i+1, cmplx( z1, 0.0_sp,KIND=sp), x11(i,i),ldx11 ) else - call stdlib_cscal( p-i+1, cmplx( z1*cos(phi(i-1)), 0.0_sp,KIND=sp),x11(i,i), & + call stdlib${ii}$_cscal( p-i+1, cmplx( z1*cos(phi(i-1)), 0.0_sp,KIND=sp),x11(i,i), & ldx11 ) - call stdlib_caxpy( p-i+1, cmplx( -z1*z3*z4*sin(phi(i-1)),0.0_sp,KIND=sp), x12(& + call stdlib${ii}$_caxpy( p-i+1, cmplx( -z1*z3*z4*sin(phi(i-1)),0.0_sp,KIND=sp), x12(& i-1,i), ldx12, x11(i,i), ldx11 ) end if - if( i == 1 ) then - call stdlib_cscal( m-p-i+1, cmplx( z2, 0.0_sp,KIND=sp), x21(i,i),ldx21 ) + if( i == 1_${ik}$ ) then + call stdlib${ii}$_cscal( m-p-i+1, cmplx( z2, 0.0_sp,KIND=sp), x21(i,i),ldx21 ) else - call stdlib_cscal( m-p-i+1, cmplx( z2*cos(phi(i-1)), 0.0_sp,KIND=sp),x21(i,i),& + call stdlib${ii}$_cscal( m-p-i+1, cmplx( z2*cos(phi(i-1)), 0.0_sp,KIND=sp),x21(i,i),& ldx21 ) - call stdlib_caxpy( m-p-i+1, cmplx( -z2*z3*z4*sin(phi(i-1)),0.0_sp,KIND=sp), & + call stdlib${ii}$_caxpy( m-p-i+1, cmplx( -z2*z3*z4*sin(phi(i-1)),0.0_sp,KIND=sp), & x22(i-1,i), ldx22, x21(i,i), ldx21 ) end if - theta(i) = atan2( stdlib_scnrm2( m-p-i+1, x21(i,i), ldx21 ),stdlib_scnrm2( p-i+1,& + theta(i) = atan2( stdlib${ii}$_scnrm2( m-p-i+1, x21(i,i), ldx21 ),stdlib${ii}$_scnrm2( p-i+1,& x11(i,i), ldx11 ) ) - call stdlib_clacgv( p-i+1, x11(i,i), ldx11 ) - call stdlib_clacgv( m-p-i+1, x21(i,i), ldx21 ) - call stdlib_clarfgp( p-i+1, x11(i,i), x11(i,i+1), ldx11, taup1(i) ) + call stdlib${ii}$_clacgv( p-i+1, x11(i,i), ldx11 ) + call stdlib${ii}$_clacgv( m-p-i+1, x21(i,i), ldx21 ) + call stdlib${ii}$_clarfgp( p-i+1, x11(i,i), x11(i,i+1), ldx11, taup1(i) ) x11(i,i) = cone if ( i == m-p ) then - call stdlib_clarfgp( m-p-i+1, x21(i,i), x21(i,i), ldx21,taup2(i) ) + call stdlib${ii}$_clarfgp( m-p-i+1, x21(i,i), x21(i,i), ldx21,taup2(i) ) else - call stdlib_clarfgp( m-p-i+1, x21(i,i), x21(i,i+1), ldx21,taup2(i) ) + call stdlib${ii}$_clarfgp( m-p-i+1, x21(i,i), x21(i,i+1), ldx21,taup2(i) ) end if x21(i,i) = cone - call stdlib_clarf( 'R', q-i, p-i+1, x11(i,i), ldx11, taup1(i),x11(i+1,i), ldx11, & + call stdlib${ii}$_clarf( 'R', q-i, p-i+1, x11(i,i), ldx11, taup1(i),x11(i+1,i), ldx11, & work ) - call stdlib_clarf( 'R', m-q-i+1, p-i+1, x11(i,i), ldx11, taup1(i),x12(i,i), & + call stdlib${ii}$_clarf( 'R', m-q-i+1, p-i+1, x11(i,i), ldx11, taup1(i),x12(i,i), & ldx12, work ) - call stdlib_clarf( 'R', q-i, m-p-i+1, x21(i,i), ldx21, taup2(i),x21(i+1,i), & + call stdlib${ii}$_clarf( 'R', q-i, m-p-i+1, x21(i,i), ldx21, taup2(i),x21(i+1,i), & ldx21, work ) - call stdlib_clarf( 'R', m-q-i+1, m-p-i+1, x21(i,i), ldx21,taup2(i), x22(i,i), & + call stdlib${ii}$_clarf( 'R', m-q-i+1, m-p-i+1, x21(i,i), ldx21,taup2(i), x22(i,i), & ldx22, work ) - call stdlib_clacgv( p-i+1, x11(i,i), ldx11 ) - call stdlib_clacgv( m-p-i+1, x21(i,i), ldx21 ) + call stdlib${ii}$_clacgv( p-i+1, x11(i,i), ldx11 ) + call stdlib${ii}$_clacgv( m-p-i+1, x21(i,i), ldx21 ) if( i < q ) then - call stdlib_cscal( q-i, cmplx( -z1*z3*sin(theta(i)), 0.0_sp,KIND=sp),x11(i+1,& - i), 1 ) - call stdlib_caxpy( q-i, cmplx( z2*z3*cos(theta(i)), 0.0_sp,KIND=sp),x21(i+1,i)& - , 1, x11(i+1,i), 1 ) - end if - call stdlib_cscal( m-q-i+1, cmplx( -z1*z4*sin(theta(i)), 0.0_sp,KIND=sp),x12(i,i)& - , 1 ) - call stdlib_caxpy( m-q-i+1, cmplx( z2*z4*cos(theta(i)), 0.0_sp,KIND=sp),x22(i,i),& - 1, x12(i,i), 1 ) - if( i < q )phi(i) = atan2( stdlib_scnrm2( q-i, x11(i+1,i), 1 ),stdlib_scnrm2( m-& - q-i+1, x12(i,i), 1 ) ) + call stdlib${ii}$_cscal( q-i, cmplx( -z1*z3*sin(theta(i)), 0.0_sp,KIND=sp),x11(i+1,& + i), 1_${ik}$ ) + call stdlib${ii}$_caxpy( q-i, cmplx( z2*z3*cos(theta(i)), 0.0_sp,KIND=sp),x21(i+1,i)& + , 1_${ik}$, x11(i+1,i), 1_${ik}$ ) + end if + call stdlib${ii}$_cscal( m-q-i+1, cmplx( -z1*z4*sin(theta(i)), 0.0_sp,KIND=sp),x12(i,i)& + , 1_${ik}$ ) + call stdlib${ii}$_caxpy( m-q-i+1, cmplx( z2*z4*cos(theta(i)), 0.0_sp,KIND=sp),x22(i,i),& + 1_${ik}$, x12(i,i), 1_${ik}$ ) + if( i < q )phi(i) = atan2( stdlib${ii}$_scnrm2( q-i, x11(i+1,i), 1_${ik}$ ),stdlib${ii}$_scnrm2( m-& + q-i+1, x12(i,i), 1_${ik}$ ) ) if( i < q ) then - call stdlib_clarfgp( q-i, x11(i+1,i), x11(i+2,i), 1, tauq1(i) ) + call stdlib${ii}$_clarfgp( q-i, x11(i+1,i), x11(i+2,i), 1_${ik}$, tauq1(i) ) x11(i+1,i) = cone end if - call stdlib_clarfgp( m-q-i+1, x12(i,i), x12(i+1,i), 1, tauq2(i) ) + call stdlib${ii}$_clarfgp( m-q-i+1, x12(i,i), x12(i+1,i), 1_${ik}$, tauq2(i) ) x12(i,i) = cone if( i < q ) then - call stdlib_clarf( 'L', q-i, p-i, x11(i+1,i), 1,conjg(tauq1(i)), x11(i+1,i+1),& + call stdlib${ii}$_clarf( 'L', q-i, p-i, x11(i+1,i), 1_${ik}$,conjg(tauq1(i)), x11(i+1,i+1),& ldx11, work ) - call stdlib_clarf( 'L', q-i, m-p-i, x11(i+1,i), 1,conjg(tauq1(i)), x21(i+1,i+& - 1), ldx21, work ) + call stdlib${ii}$_clarf( 'L', q-i, m-p-i, x11(i+1,i), 1_${ik}$,conjg(tauq1(i)), x21(i+1,i+& + 1_${ik}$), ldx21, work ) end if - call stdlib_clarf( 'L', m-q-i+1, p-i, x12(i,i), 1, conjg(tauq2(i)),x12(i,i+1), & + call stdlib${ii}$_clarf( 'L', m-q-i+1, p-i, x12(i,i), 1_${ik}$, conjg(tauq2(i)),x12(i,i+1), & ldx12, work ) if ( m-p > i ) then - call stdlib_clarf( 'L', m-q-i+1, m-p-i, x12(i,i), 1,conjg(tauq2(i)), x22(i,i+& - 1), ldx22, work ) + call stdlib${ii}$_clarf( 'L', m-q-i+1, m-p-i, x12(i,i), 1_${ik}$,conjg(tauq2(i)), x22(i,i+& + 1_${ik}$), ldx22, work ) end if end do ! reduce columns q + 1, ..., p of x12, x22 do i = q + 1, p - call stdlib_cscal( m-q-i+1, cmplx( -z1*z4, 0.0_sp,KIND=sp), x12(i,i), 1 ) - call stdlib_clarfgp( m-q-i+1, x12(i,i), x12(i+1,i), 1, tauq2(i) ) + call stdlib${ii}$_cscal( m-q-i+1, cmplx( -z1*z4, 0.0_sp,KIND=sp), x12(i,i), 1_${ik}$ ) + call stdlib${ii}$_clarfgp( m-q-i+1, x12(i,i), x12(i+1,i), 1_${ik}$, tauq2(i) ) x12(i,i) = cone if ( p > i ) then - call stdlib_clarf( 'L', m-q-i+1, p-i, x12(i,i), 1,conjg(tauq2(i)), x12(i,i+1),& + call stdlib${ii}$_clarf( 'L', m-q-i+1, p-i, x12(i,i), 1_${ik}$,conjg(tauq2(i)), x12(i,i+1),& ldx12, work ) end if - if( m-p-q >= 1 )call stdlib_clarf( 'L', m-q-i+1, m-p-q, x12(i,i), 1,conjg(tauq2(& + if( m-p-q >= 1_${ik}$ )call stdlib${ii}$_clarf( 'L', m-q-i+1, m-p-q, x12(i,i), 1_${ik}$,conjg(tauq2(& i)), x22(i,q+1), ldx22, work ) end do ! reduce columns p + 1, ..., m - q of x12, x22 do i = 1, m - p - q - call stdlib_cscal( m-p-q-i+1, cmplx( z2*z4, 0.0_sp,KIND=sp),x22(p+i,q+i), 1 ) + call stdlib${ii}$_cscal( m-p-q-i+1, cmplx( z2*z4, 0.0_sp,KIND=sp),x22(p+i,q+i), 1_${ik}$ ) - call stdlib_clarfgp( m-p-q-i+1, x22(p+i,q+i), x22(p+i+1,q+i), 1,tauq2(p+i) ) + call stdlib${ii}$_clarfgp( m-p-q-i+1, x22(p+i,q+i), x22(p+i+1,q+i), 1_${ik}$,tauq2(p+i) ) x22(p+i,q+i) = cone if ( m-p-q /= i ) then - call stdlib_clarf( 'L', m-p-q-i+1, m-p-q-i, x22(p+i,q+i), 1,conjg(tauq2(p+i)),& + call stdlib${ii}$_clarf( 'L', m-p-q-i+1, m-p-q-i, x22(p+i,q+i), 1_${ik}$,conjg(tauq2(p+i)),& x22(p+i,q+i+1), ldx22,work ) end if end do end if return - end subroutine stdlib_cunbdb + end subroutine stdlib${ii}$_cunbdb - pure subroutine stdlib_cunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & + pure subroutine stdlib${ii}$_cunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & !! CUNBDB6 orthogonalizes the column vector !! X = [ X1 ] !! [ X2 ] @@ -29218,8 +29220,8 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(in) :: q1(ldq1,*), q2(ldq2,*) complex(sp), intent(out) :: work(*) @@ -29232,60 +29234,60 @@ module stdlib_linalg_lapack_c ! 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( 'CUNBDB6', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'CUNBDB6', -info ) return end if ! first, project x onto the orthogonal complement of q's column ! space scl1 = realzero ssq1 = realone - call stdlib_classq( m1, x1, incx1, scl1, ssq1 ) + call stdlib${ii}$_classq( m1, x1, incx1, scl1, ssq1 ) scl2 = realzero ssq2 = realone - call stdlib_classq( m2, x2, incx2, scl2, ssq2 ) - normsq1 = scl1**2*ssq1 + scl2**2*ssq2 - if( m1 == 0 ) then + call stdlib${ii}$_classq( 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) = czero end do else - call stdlib_cgemv( 'C', m1, n, cone, q1, ldq1, x1, incx1, czero, work,1 ) + call stdlib${ii}$_cgemv( 'C', m1, n, cone, q1, ldq1, x1, incx1, czero, work,1_${ik}$ ) end if - call stdlib_cgemv( 'C', m2, n, cone, q2, ldq2, x2, incx2, cone, work, 1 ) - call stdlib_cgemv( 'N', m1, n, cnegone, q1, ldq1, work, 1, cone, x1,incx1 ) - call stdlib_cgemv( 'N', m2, n, cnegone, q2, ldq2, work, 1, cone, x2,incx2 ) + call stdlib${ii}$_cgemv( 'C', m2, n, cone, q2, ldq2, x2, incx2, cone, work, 1_${ik}$ ) + call stdlib${ii}$_cgemv( 'N', m1, n, cnegone, q1, ldq1, work, 1_${ik}$, cone, x1,incx1 ) + call stdlib${ii}$_cgemv( 'N', m2, n, cnegone, q2, ldq2, work, 1_${ik}$, cone, x2,incx2 ) scl1 = realzero ssq1 = realone - call stdlib_classq( m1, x1, incx1, scl1, ssq1 ) + call stdlib${ii}$_classq( m1, x1, incx1, scl1, ssq1 ) scl2 = realzero ssq2 = realone - call stdlib_classq( m2, x2, incx2, scl2, ssq2 ) - normsq2 = scl1**2*ssq1 + scl2**2*ssq2 + call stdlib${ii}$_classq( 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 czero, then stop. ! otherwise, project again. @@ -29299,23 +29301,23 @@ module stdlib_linalg_lapack_c do i = 1, n work(i) = czero end do - if( m1 == 0 ) then + if( m1 == 0_${ik}$ ) then do i = 1, n work(i) = czero end do else - call stdlib_cgemv( 'C', m1, n, cone, q1, ldq1, x1, incx1, czero, work,1 ) + call stdlib${ii}$_cgemv( 'C', m1, n, cone, q1, ldq1, x1, incx1, czero, work,1_${ik}$ ) end if - call stdlib_cgemv( 'C', m2, n, cone, q2, ldq2, x2, incx2, cone, work, 1 ) - call stdlib_cgemv( 'N', m1, n, cnegone, q1, ldq1, work, 1, cone, x1,incx1 ) - call stdlib_cgemv( 'N', m2, n, cnegone, q2, ldq2, work, 1, cone, x2,incx2 ) + call stdlib${ii}$_cgemv( 'C', m2, n, cone, q2, ldq2, x2, incx2, cone, work, 1_${ik}$ ) + call stdlib${ii}$_cgemv( 'N', m1, n, cnegone, q1, ldq1, work, 1_${ik}$, cone, x1,incx1 ) + call stdlib${ii}$_cgemv( 'N', m2, n, cnegone, q2, ldq2, work, 1_${ik}$, cone, x2,incx2 ) scl1 = realzero ssq1 = realone - call stdlib_classq( m1, x1, incx1, scl1, ssq1 ) + call stdlib${ii}$_classq( m1, x1, incx1, scl1, ssq1 ) scl2 = realzero ssq2 = realone - call stdlib_classq( m1, x1, incx1, scl1, ssq1 ) - normsq2 = scl1**2*ssq1 + scl2**2*ssq2 + call stdlib${ii}$_classq( 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 czero. @@ -29328,10 +29330,10 @@ module stdlib_linalg_lapack_c end do end if return - end subroutine stdlib_cunbdb6 + end subroutine stdlib${ii}$_cunbdb6 - pure subroutine stdlib_cung2l( m, n, k, a, lda, tau, work, info ) + pure subroutine stdlib${ii}$_cung2l( m, n, k, a, lda, tau, work, info ) !! CUNG2L generates an m by n complex matrix Q with orthonormal columns, !! which is defined as the last n columns of a product of k elementary !! reflectors of order m @@ -29341,8 +29343,8 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(in) :: tau(*) @@ -29350,23 +29352,23 @@ module stdlib_linalg_lapack_c ! ===================================================================== ! 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_clarft( 'FORWARD', 'ROWWISE', n-i+1, ib, a( i, i ),lda, tau( i ), & + call stdlib${ii}$_clarft( 'FORWARD', 'ROWWISE', n-i+1, ib, a( i, i ),lda, tau( i ), & work, ldwork ) ! apply h**h to a(i+ib:m,i:n) from the right - call stdlib_clarfb( 'RIGHT', 'CONJUGATE TRANSPOSE', 'FORWARD','ROWWISE', m-i-& + call stdlib${ii}$_clarfb( 'RIGHT', 'CONJUGATE TRANSPOSE', 'FORWARD','ROWWISE', m-i-& ib+1, n-i+1, ib, a( i, i ),lda, work, ldwork, a( i+ib, i ), lda,work( ib+1 ), & ldwork ) end if ! apply h**h to columns i:n of current block - call stdlib_cungl2( ib, n-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) + call stdlib${ii}$_cungl2( ib, n-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) ! set columns 1:i-1 of current block to czero do j = 1, i - 1 do l = i, i + ib - 1 @@ -29642,12 +29644,12 @@ module stdlib_linalg_lapack_c end do end do end if - work( 1 ) = iws + work( 1_${ik}$ ) = iws return - end subroutine stdlib_cunglq + end subroutine stdlib${ii}$_cunglq - pure subroutine stdlib_cungql( m, n, k, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_cungql( m, n, k, a, lda, tau, work, lwork, info ) !! CUNGQL generates an M-by-N complex matrix Q with orthonormal columns, !! which is defined as the last N columns of a product of K elementary !! reflectors of order M @@ -29657,8 +29659,8 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(in) :: tau(*) @@ -29667,50 +29669,50 @@ module stdlib_linalg_lapack_c ! 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}$_cung2l( 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_clarft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1, n-k+i ), & + call stdlib${ii}$_clarft( '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_clarfb( '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 ) + call stdlib${ii}$_clarfb( '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_cung2l( m-k+i+ib-1, ib, ib, a( 1, n-k+i ), lda,tau( i ), work, iinfo & + call stdlib${ii}$_cung2l( 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 czero do j = n - k + i, n - k + i + ib - 1 @@ -29763,12 +29765,12 @@ module stdlib_linalg_lapack_c end do end do end if - work( 1 ) = iws + work( 1_${ik}$ ) = iws return - end subroutine stdlib_cungql + end subroutine stdlib${ii}$_cungql - pure subroutine stdlib_cungqr( m, n, k, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_cungqr( m, n, k, a, lda, tau, work, lwork, info ) !! CUNGQR generates an M-by-N complex matrix Q with orthonormal columns, !! which is defined as the first N columns of a product of K elementary !! reflectors of order M @@ -29778,8 +29780,8 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(in) :: tau(*) @@ -29788,44 +29790,44 @@ module stdlib_linalg_lapack_c ! 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, 'CUNGQR', ' ', 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_clarft( 'FORWARD', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & + call stdlib${ii}$_clarft( '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_clarfb( 'LEFT', 'NO TRANSPOSE', 'FORWARD','COLUMNWISE', m-i+1, n-& + call stdlib${ii}$_clarfb( '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_cung2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work,iinfo ) + call stdlib${ii}$_cung2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work,iinfo ) ! set rows 1:i-1 of current block to czero do j = i, i + ib - 1 do l = 1, i - 1 @@ -29879,12 +29881,12 @@ module stdlib_linalg_lapack_c end do end do end if - work( 1 ) = iws + work( 1_${ik}$ ) = iws return - end subroutine stdlib_cungqr + end subroutine stdlib${ii}$_cungqr - pure subroutine stdlib_cungr2( m, n, k, a, lda, tau, work, info ) + pure subroutine stdlib${ii}$_cungr2( m, n, k, a, lda, tau, work, info ) !! CUNGR2 generates an m by n complex matrix Q with orthonormal rows, !! which is defined as the last m rows of a product of k elementary !! reflectors of order n @@ -29894,8 +29896,8 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(in) :: tau(*) @@ -29903,23 +29905,23 @@ module stdlib_linalg_lapack_c ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ii, j, l + integer(${ik}$) :: i, ii, j, l ! Intrinsic Functions intrinsic :: conjg,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}$_cungr2( 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_clarft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( ii, 1 ), lda, & + call stdlib${ii}$_clarft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( ii, 1_${ik}$ ), lda, & tau( i ), work, ldwork ) ! apply h**h to a(1:m-k+i-1,1:n-k+i+ib-1) from the right - call stdlib_clarfb( 'RIGHT', 'CONJUGATE TRANSPOSE', 'BACKWARD','ROWWISE', ii-& - 1, n-k+i+ib-1, ib, a( ii, 1 ),lda, work, ldwork, a, lda, work( ib+1 ),ldwork ) + call stdlib${ii}$_clarfb( 'RIGHT', 'CONJUGATE TRANSPOSE', 'BACKWARD','ROWWISE', ii-& + 1_${ik}$, n-k+i+ib-1, ib, a( ii, 1_${ik}$ ),lda, work, ldwork, a, lda, work( ib+1 ),ldwork ) end if ! apply h**h to columns 1:n-k+i+ib-1 of current block - call stdlib_cungr2( ib, n-k+i+ib-1, ib, a( ii, 1 ), lda, tau( i ),work, iinfo ) + call stdlib${ii}$_cungr2( 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 czero do l = n - k + i + ib, n @@ -30069,12 +30071,12 @@ module stdlib_linalg_lapack_c end do end do end if - work( 1 ) = iws + work( 1_${ik}$ ) = iws return - end subroutine stdlib_cungrq + end subroutine stdlib${ii}$_cungrq - pure subroutine stdlib_cungtsqr_row( m, n, mb, nb, a, lda, t, ldt, work,lwork, info ) + pure subroutine stdlib${ii}$_cungtsqr_row( m, n, mb, nb, a, lda, t, ldt, work,lwork, info ) !! CUNGTSQR_ROW generates an M-by-N complex matrix Q_out with !! orthonormal columns from the output of CLATSQR. These N orthonormal !! columns are the first N columns of a product of complex unitary @@ -30094,8 +30096,8 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(in) :: t(ldt,*) @@ -30104,55 +30106,55 @@ module stdlib_linalg_lapack_c ! 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 - complex(sp) :: dummy(1,1) + complex(sp) :: dummy(1_${ik}$,1_${ik}$) ! Intrinsic Functions intrinsic :: cmplx,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 ( mbnq ) 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_cunml2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib${ii}$_cunml2( 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 = 'C' @@ -30834,28 +30836,28 @@ module stdlib_linalg_lapack_c 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_clarft( 'FORWARD', 'ROWWISE', nq-i+1, ib, a( i, i ),lda, tau( i ), & + call stdlib${ii}$_clarft( 'FORWARD', 'ROWWISE', nq-i+1, ib, a( i, i ),lda, tau( i ), & work( iwt ), ldt ) if( left ) then ! h or h**h is applied to c(i:m,1:n) - mi = m - i + 1 + mi = m - i + 1_${ik}$ ic = i else ! h or h**h is applied to c(1:m,i:n) - ni = n - i + 1 + ni = n - i + 1_${ik}$ jc = i end if ! apply h or h**h - call stdlib_clarfb( side, transt, 'FORWARD', 'ROWWISE', mi, ni, ib,a( i, i ), & + call stdlib${ii}$_clarfb( 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_cunmlq + end subroutine stdlib${ii}$_cunmlq - pure subroutine stdlib_cunmql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) + pure subroutine stdlib${ii}$_cunmql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) !! CUNMQL overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -30871,98 +30873,98 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: a(lda,*), c(ldc,*) complex(sp), intent(in) :: tau(*) complex(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, 'C' ) ) 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_cunm2l( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib${ii}$_cunm2l( 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 @@ -30974,26 +30976,26 @@ module stdlib_linalg_lapack_c 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_clarft( 'BACKWARD', 'COLUMNWISE', nq-k+i+ib-1, ib,a( 1, i ), lda, & + call stdlib${ii}$_clarft( 'BACKWARD', 'COLUMNWISE', nq-k+i+ib-1, ib,a( 1_${ik}$, i ), lda, & tau( i ), work( iwt ), ldt ) if( left ) then ! h or h**h is applied to c(1:m-k+i+ib-1,1:n) - mi = m - k + i + ib - 1 + mi = m - k + i + ib - 1_${ik}$ else ! h or h**h is applied to c(1:m,1:n-k+i+ib-1) - ni = n - k + i + ib - 1 + ni = n - k + i + ib - 1_${ik}$ end if ! apply h or h**h - call stdlib_clarfb( side, trans, 'BACKWARD', 'COLUMNWISE', mi, ni,ib, a( 1, i ), & + call stdlib${ii}$_clarfb( 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_cunmql + end subroutine stdlib${ii}$_cunmql - pure subroutine stdlib_cunmqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) + pure subroutine stdlib${ii}$_cunmqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) !! CUNMQR overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -31009,128 +31011,128 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: a(lda,*), c(ldc,*) complex(sp), intent(in) :: tau(*) complex(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, 'C' ) ) 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_cunm2r( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib${ii}$_cunm2r( 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_clarft( 'FORWARD', 'COLUMNWISE', nq-i+1, ib, a( i, i ),lda, tau( i ),& + call stdlib${ii}$_clarft( 'FORWARD', 'COLUMNWISE', nq-i+1, ib, a( i, i ),lda, tau( i ),& work( iwt ), ldt ) if( left ) then ! h or h**h is applied to c(i:m,1:n) - mi = m - i + 1 + mi = m - i + 1_${ik}$ ic = i else ! h or h**h is applied to c(1:m,i:n) - ni = n - i + 1 + ni = n - i + 1_${ik}$ jc = i end if ! apply h or h**h - call stdlib_clarfb( side, trans, 'FORWARD', 'COLUMNWISE', mi, ni,ib, a( i, i ), & + call stdlib${ii}$_clarfb( 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_cunmqr + end subroutine stdlib${ii}$_cunmqr - pure subroutine stdlib_cunmr2( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) + pure subroutine stdlib${ii}$_cunmr2( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) !! CUNMR2 overwrites the general complex m-by-n matrix C with !! Q * C if SIDE = 'L' and TRANS = 'N', or !! Q**H* C if SIDE = 'L' and TRANS = 'C', or @@ -31146,8 +31148,8 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: a(lda,*), c(ldc,*) complex(sp), intent(in) :: tau(*) @@ -31156,13 +31158,13 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: left, notran - integer(ilp) :: i, i1, i2, i3, mi, ni, nq + integer(${ik}$) :: i, i1, i2, i3, mi, ni, nq complex(sp) :: aii, taui ! Intrinsic Functions intrinsic :: conjg,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 @@ -31172,34 +31174,34 @@ module stdlib_linalg_lapack_c 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, 'C' ) ) 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_cunmr2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib${ii}$_cunmr2( 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 @@ -31460,26 +31462,26 @@ module stdlib_linalg_lapack_c 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_clarft( 'BACKWARD', 'ROWWISE', nq-k+i+ib-1, ib,a( i, 1 ), lda, tau( & + call stdlib${ii}$_clarft( 'BACKWARD', 'ROWWISE', nq-k+i+ib-1, ib,a( i, 1_${ik}$ ), lda, tau( & i ), work( iwt ), ldt ) if( left ) then ! h or h**h is applied to c(1:m-k+i+ib-1,1:n) - mi = m - k + i + ib - 1 + mi = m - k + i + ib - 1_${ik}$ else ! h or h**h is applied to c(1:m,1:n-k+i+ib-1) - ni = n - k + i + ib - 1 + ni = n - k + i + ib - 1_${ik}$ end if ! apply h or h**h - call stdlib_clarfb( side, transt, 'BACKWARD', 'ROWWISE', mi, ni,ib, a( i, 1 ), & + call stdlib${ii}$_clarfb( 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_cunmrq + end subroutine stdlib${ii}$_cunmrq - pure subroutine stdlib_cunmrz( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, lwork, & + pure subroutine stdlib${ii}$_cunmrz( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, lwork, & !! CUNMRZ overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -31495,113 +31497,113 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: a(lda,*), c(ldc,*) complex(sp), intent(in) :: tau(*) complex(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, 'C' ) ) 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_cunmr3( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, iinfo ) + call stdlib${ii}$_cunmr3( 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 = 'C' @@ -31612,28 +31614,28 @@ module stdlib_linalg_lapack_c 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_clarzt( 'BACKWARD', 'ROWWISE', l, ib, a( i, ja ), lda,tau( i ), work(& + call stdlib${ii}$_clarzt( 'BACKWARD', 'ROWWISE', l, ib, a( i, ja ), lda,tau( i ), work(& iwt ), ldt ) if( left ) then ! h or h**h is applied to c(i:m,1:n) - mi = m - i + 1 + mi = m - i + 1_${ik}$ ic = i else ! h or h**h is applied to c(1:m,i:n) - ni = n - i + 1 + ni = n - i + 1_${ik}$ jc = i end if ! apply h or h**h - call stdlib_clarzb( side, transt, 'BACKWARD', 'ROWWISE', mi, ni,ib, l, a( i, ja )& + call stdlib${ii}$_clarzb( 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_cunmrz + end subroutine stdlib${ii}$_cunmrz - pure subroutine stdlib_cbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, phi, u1, & + pure subroutine stdlib${ii}$_cbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, phi, u1, & !! CBBCSD computes the CS decomposition of a unitary matrix in !! bidiagonal-block form, !! [ B11 | B12 0 0 ] @@ -31662,8 +31664,8 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobu1, jobu2, jobv1t, jobv2t, trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldu1, ldu2, ldv1t, ldv2t, lrwork, m, p, q + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldu1, ldu2, ldv1t, ldv2t, lrwork, m, p, q ! Array Arguments real(sp), intent(out) :: b11d(*), b11e(*), b12d(*), b12e(*), b21d(*), b21e(*), b22d(*),& b22e(*), rwork(*) @@ -31672,7 +31674,7 @@ module stdlib_linalg_lapack_c ! =================================================================== ! Parameters - integer(ilp), parameter :: maxitr = 6 + integer(${ik}$), parameter :: maxitr = 6_${ik}$ real(sp), parameter :: hundred = 100.0_sp real(sp), parameter :: meighth = -0.125_sp real(sp), parameter :: piover2 = 1.57079632679489661923132169163975144210_sp @@ -31683,7 +31685,7 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: colmajor, lquery, restart11, restart12, restart21, restart22, wantu1, & wantu2, wantv1t, wantv2t - integer(ilp) :: i, imin, imax, iter, iu1cs, iu1sn, iu2cs, iu2sn, iv1tcs, iv1tsn, & + integer(${ik}$) :: i, imin, imax, iter, iu1cs, iu1sn, iu2cs, iu2sn, iv1tcs, iv1tsn, & iv2tcs, iv2tsn, j, lrworkmin, lrworkopt, maxit, mini real(sp) :: b11bulge, b12bulge, b21bulge, b22bulge, dummy, eps, mu, nu, r, sigma11, & sigma21, temp, thetamax, thetamin, thresh, tol, tolmul, unfl, x1, x2, y1, y2 @@ -31691,39 +31693,39 @@ module stdlib_linalg_lapack_c intrinsic :: abs,atan2,cos,max,min,sin,sqrt ! Executable Statements ! test input arguments - info = 0 - lquery = lrwork == -1 + info = 0_${ik}$ + lquery = lrwork == -1_${ik}$ wantu1 = stdlib_lsame( jobu1, 'Y' ) wantu2 = stdlib_lsame( jobu2, 'Y' ) wantv1t = stdlib_lsame( jobv1t, 'Y' ) wantv2t = stdlib_lsame( jobv2t, 'Y' ) colmajor = .not. stdlib_lsame( trans, 'T' ) - if( m < 0 ) then - info = -6 - else if( p < 0 .or. p > 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 - lrworkmin = 1 - rwork(1) = lrworkmin + if( info == 0_${ik}$ .and. q == 0_${ik}$ ) then + lrworkmin = 1_${ik}$ + rwork(1_${ik}$) = lrworkmin 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 @@ -31731,22 +31733,22 @@ module stdlib_linalg_lapack_c iv1tsn = iv1tcs + q iv2tcs = iv1tsn + q iv2tsn = iv2tcs + q - lrworkopt = iv2tsn + q - 1 + lrworkopt = iv2tsn + q - 1_${ik}$ lrworkmin = lrworkopt - rwork(1) = lrworkopt + rwork(1_${ik}$) = lrworkopt if( lrwork < lrworkmin .and. .not. lquery ) then - info = -28 + info = -28_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'CBBCSD', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'CBBCSD', -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 ) @@ -31771,18 +31773,18 @@ module stdlib_linalg_lapack_c 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 @@ -31802,9 +31804,9 @@ module stdlib_linalg_lapack_c 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 @@ -31828,20 +31830,20 @@ module stdlib_linalg_lapack_c 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 @@ -31850,10 +31852,10 @@ module stdlib_linalg_lapack_c end if ! rotate to produce bulges in b11 and b21 if( mu <= nu ) then - call stdlib_slartgs( b11d(imin), b11e(imin), mu,rwork(iv1tcs+imin-1), rwork(& + call stdlib${ii}$_slartgs( b11d(imin), b11e(imin), mu,rwork(iv1tcs+imin-1), rwork(& iv1tsn+imin-1) ) else - call stdlib_slartgs( b21d(imin), b21e(imin), nu,rwork(iv1tcs+imin-1), rwork(& + call stdlib${ii}$_slartgs( b21d(imin), b21e(imin), nu,rwork(iv1tcs+imin-1), rwork(& iv1tsn+imin-1) ) end if temp = rwork(iv1tcs+imin-1)*b11d(imin) +rwork(iv1tsn+imin-1)*b11e(imin) @@ -31869,27 +31871,27 @@ module stdlib_linalg_lapack_c b21bulge = rwork(iv1tsn+imin-1)*b21d(imin+1) b21d(imin+1) = rwork(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), rwork(iu1sn+imin-1),rwork(iu1cs+imin-& - 1), r ) + if( b11d(imin)**2_${ik}$+b11bulge**2_${ik}$ > thresh**2_${ik}$ ) then + call stdlib${ii}$_slartgp( b11bulge, b11d(imin), rwork(iu1sn+imin-1),rwork(iu1cs+imin-& + 1_${ik}$), r ) else if( mu <= nu ) then - call stdlib_slartgs( b11e( imin ), b11d( imin + 1 ), mu,rwork(iu1cs+imin-1), & + call stdlib${ii}$_slartgs( b11e( imin ), b11d( imin + 1_${ik}$ ), mu,rwork(iu1cs+imin-1), & rwork(iu1sn+imin-1) ) else - call stdlib_slartgs( b12d( imin ), b12e( imin ), nu,rwork(iu1cs+imin-1), rwork(& + call stdlib${ii}$_slartgs( b12d( imin ), b12e( imin ), nu,rwork(iu1cs+imin-1), rwork(& iu1sn+imin-1) ) end if - if( b21d(imin)**2+b21bulge**2 > thresh**2 ) then - call stdlib_slartgp( b21bulge, b21d(imin), rwork(iu2sn+imin-1),rwork(iu2cs+imin-& - 1), r ) + if( b21d(imin)**2_${ik}$+b21bulge**2_${ik}$ > thresh**2_${ik}$ ) then + call stdlib${ii}$_slartgp( b21bulge, b21d(imin), rwork(iu2sn+imin-1),rwork(iu2cs+imin-& + 1_${ik}$), r ) else if( nu < mu ) then - call stdlib_slartgs( b21e( imin ), b21d( imin + 1 ), nu,rwork(iu2cs+imin-1), & + call stdlib${ii}$_slartgs( b21e( imin ), b21d( imin + 1_${ik}$ ), nu,rwork(iu2cs+imin-1), & rwork(iu2sn+imin-1) ) else - call stdlib_slartgs( b22d(imin), b22e(imin), mu,rwork(iu2cs+imin-1), rwork(iu2sn+& + call stdlib${ii}$_slartgs( b22d(imin), b22e(imin), mu,rwork(iu2cs+imin-1), rwork(iu2sn+& imin-1) ) end if rwork(iu2cs+imin-1) = -rwork(iu2cs+imin-1) @@ -31929,47 +31931,47 @@ module stdlib_linalg_lapack_c 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, rwork(iv1tsn+i-1),rwork(iv1tcs+i-1), r ) + call stdlib${ii}$_slartgp( x2, x1, rwork(iv1tsn+i-1),rwork(iv1tcs+i-1), r ) else if( .not. restart11 .and. restart21 ) then - call stdlib_slartgp( b11bulge, b11e(i-1), rwork(iv1tsn+i-1),rwork(iv1tcs+i-1),& + call stdlib${ii}$_slartgp( b11bulge, b11e(i-1), rwork(iv1tsn+i-1),rwork(iv1tcs+i-1),& r ) else if( restart11 .and. .not. restart21 ) then - call stdlib_slartgp( b21bulge, b21e(i-1), rwork(iv1tsn+i-1),rwork(iv1tcs+i-1),& + call stdlib${ii}$_slartgp( b21bulge, b21e(i-1), rwork(iv1tsn+i-1),rwork(iv1tcs+i-1),& r ) else if( mu <= nu ) then - call stdlib_slartgs( b11d(i), b11e(i), mu, rwork(iv1tcs+i-1),rwork(iv1tsn+i-1)& + call stdlib${ii}$_slartgs( b11d(i), b11e(i), mu, rwork(iv1tcs+i-1),rwork(iv1tsn+i-1)& ) else - call stdlib_slartgs( b21d(i), b21e(i), nu, rwork(iv1tcs+i-1),rwork(iv1tsn+i-1)& + call stdlib${ii}$_slartgs( b21d(i), b21e(i), nu, rwork(iv1tcs+i-1),rwork(iv1tsn+i-1)& ) end if rwork(iv1tcs+i-1) = -rwork(iv1tcs+i-1) rwork(iv1tsn+i-1) = -rwork(iv1tsn+i-1) if( .not. restart12 .and. .not. restart22 ) then - call stdlib_slartgp( y2, y1, rwork(iv2tsn+i-1-1),rwork(iv2tcs+i-1-1), r ) + call stdlib${ii}$_slartgp( y2, y1, rwork(iv2tsn+i-1-1),rwork(iv2tcs+i-1-1), r ) else if( .not. restart12 .and. restart22 ) then - call stdlib_slartgp( b12bulge, b12d(i-1), rwork(iv2tsn+i-1-1),rwork(iv2tcs+i-& - 1-1), r ) + call stdlib${ii}$_slartgp( b12bulge, b12d(i-1), rwork(iv2tsn+i-1-1),rwork(iv2tcs+i-& + 1_${ik}$-1), r ) else if( restart12 .and. .not. restart22 ) then - call stdlib_slartgp( b22bulge, b22d(i-1), rwork(iv2tsn+i-1-1),rwork(iv2tcs+i-& - 1-1), r ) + call stdlib${ii}$_slartgp( b22bulge, b22d(i-1), rwork(iv2tsn+i-1-1),rwork(iv2tcs+i-& + 1_${ik}$-1), r ) else if( nu < mu ) then - call stdlib_slartgs( b12e(i-1), b12d(i), nu,rwork(iv2tcs+i-1-1), rwork(iv2tsn+& + call stdlib${ii}$_slartgs( b12e(i-1), b12d(i), nu,rwork(iv2tcs+i-1-1), rwork(iv2tsn+& i-1-1) ) else - call stdlib_slartgs( b22e(i-1), b22d(i), mu,rwork(iv2tcs+i-1-1), rwork(iv2tsn+& + call stdlib${ii}$_slartgs( b22e(i-1), b22d(i), mu,rwork(iv2tcs+i-1-1), rwork(iv2tsn+& i-1-1) ) end if temp = rwork(iv1tcs+i-1)*b11d(i) + rwork(iv1tsn+i-1)*b11e(i) @@ -31997,44 +31999,44 @@ module stdlib_linalg_lapack_c 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, rwork(iu1sn+i-1), rwork(iu1cs+i-1),r ) + call stdlib${ii}$_slartgp( x2, x1, rwork(iu1sn+i-1), rwork(iu1cs+i-1),r ) else if( .not. restart11 .and. restart12 ) then - call stdlib_slartgp( b11bulge, b11d(i), rwork(iu1sn+i-1),rwork(iu1cs+i-1), r ) + call stdlib${ii}$_slartgp( b11bulge, b11d(i), rwork(iu1sn+i-1),rwork(iu1cs+i-1), r ) else if( restart11 .and. .not. restart12 ) then - call stdlib_slartgp( b12bulge, b12e(i-1), rwork(iu1sn+i-1),rwork(iu1cs+i-1), & + call stdlib${ii}$_slartgp( b12bulge, b12e(i-1), rwork(iu1sn+i-1),rwork(iu1cs+i-1), & r ) else if( mu <= nu ) then - call stdlib_slartgs( b11e(i), b11d(i+1), mu, rwork(iu1cs+i-1),rwork(iu1sn+i-1)& + call stdlib${ii}$_slartgs( b11e(i), b11d(i+1), mu, rwork(iu1cs+i-1),rwork(iu1sn+i-1)& ) else - call stdlib_slartgs( b12d(i), b12e(i), nu, rwork(iu1cs+i-1),rwork(iu1sn+i-1) ) + call stdlib${ii}$_slartgs( b12d(i), b12e(i), nu, rwork(iu1cs+i-1),rwork(iu1sn+i-1) ) end if if( .not. restart21 .and. .not. restart22 ) then - call stdlib_slartgp( y2, y1, rwork(iu2sn+i-1), rwork(iu2cs+i-1),r ) + call stdlib${ii}$_slartgp( y2, y1, rwork(iu2sn+i-1), rwork(iu2cs+i-1),r ) else if( .not. restart21 .and. restart22 ) then - call stdlib_slartgp( b21bulge, b21d(i), rwork(iu2sn+i-1),rwork(iu2cs+i-1), r ) + call stdlib${ii}$_slartgp( b21bulge, b21d(i), rwork(iu2sn+i-1),rwork(iu2cs+i-1), r ) else if( restart21 .and. .not. restart22 ) then - call stdlib_slartgp( b22bulge, b22e(i-1), rwork(iu2sn+i-1),rwork(iu2cs+i-1), & + call stdlib${ii}$_slartgp( b22bulge, b22e(i-1), rwork(iu2sn+i-1),rwork(iu2cs+i-1), & r ) else if( nu < mu ) then - call stdlib_slartgs( b21e(i), b21e(i+1), nu, rwork(iu2cs+i-1),rwork(iu2sn+i-1)& + call stdlib${ii}$_slartgs( b21e(i), b21e(i+1), nu, rwork(iu2cs+i-1),rwork(iu2sn+i-1)& ) else - call stdlib_slartgs( b22d(i), b22e(i), mu, rwork(iu2cs+i-1),rwork(iu2sn+i-1) ) + call stdlib${ii}$_slartgs( b22d(i), b22e(i), mu, rwork(iu2cs+i-1),rwork(iu2sn+i-1) ) end if rwork(iu2cs+i-1) = -rwork(iu2cs+i-1) @@ -32042,14 +32044,14 @@ module stdlib_linalg_lapack_c temp = rwork(iu1cs+i-1)*b11e(i) + rwork(iu1sn+i-1)*b11d(i+1) b11d(i+1) = rwork(iu1cs+i-1)*b11d(i+1) -rwork(iu1sn+i-1)*b11e(i) b11e(i) = temp - if( i < imax - 1 ) then + if( i < imax - 1_${ik}$ ) then b11bulge = rwork(iu1sn+i-1)*b11e(i+1) b11e(i+1) = rwork(iu1cs+i-1)*b11e(i+1) end if temp = rwork(iu2cs+i-1)*b21e(i) + rwork(iu2sn+i-1)*b21d(i+1) b21d(i+1) = rwork(iu2cs+i-1)*b21d(i+1) -rwork(iu2sn+i-1)*b21e(i) b21e(i) = temp - if( i < imax - 1 ) then + if( i < imax - 1_${ik}$ ) then b21bulge = rwork(iu2sn+i-1)*b21e(i+1) b21e(i+1) = rwork(iu2cs+i-1)*b21e(i+1) end if @@ -32068,24 +32070,24 @@ module stdlib_linalg_lapack_c 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, rwork(iv2tsn+imax-1-1),rwork(iv2tcs+imax-1-1), r ) + call stdlib${ii}$_slartgp( y2, y1, rwork(iv2tsn+imax-1-1),rwork(iv2tcs+imax-1-1), r ) else if( .not. restart12 .and. restart22 ) then - call stdlib_slartgp( b12bulge, b12d(imax-1),rwork(iv2tsn+imax-1-1),rwork(iv2tcs+& + call stdlib${ii}$_slartgp( b12bulge, b12d(imax-1),rwork(iv2tsn+imax-1-1),rwork(iv2tcs+& imax-1-1), r ) else if( restart12 .and. .not. restart22 ) then - call stdlib_slartgp( b22bulge, b22d(imax-1),rwork(iv2tsn+imax-1-1),rwork(iv2tcs+& + call stdlib${ii}$_slartgp( b22bulge, b22d(imax-1),rwork(iv2tsn+imax-1-1),rwork(iv2tcs+& imax-1-1), r ) else if( nu < mu ) then - call stdlib_slartgs( b12e(imax-1), b12d(imax), nu,rwork(iv2tcs+imax-1-1),rwork(& + call stdlib${ii}$_slartgs( b12e(imax-1), b12d(imax), nu,rwork(iv2tcs+imax-1-1),rwork(& iv2tsn+imax-1-1) ) else - call stdlib_slartgs( b22e(imax-1), b22d(imax), mu,rwork(iv2tcs+imax-1-1),rwork(& + call stdlib${ii}$_slartgs( b22e(imax-1), b22d(imax), mu,rwork(iv2tcs+imax-1-1),rwork(& iv2tsn+imax-1-1) ) end if temp = rwork(iv2tcs+imax-1-1)*b12e(imax-1) +rwork(iv2tsn+imax-1-1)*b12d(imax) @@ -32101,49 +32103,49 @@ module stdlib_linalg_lapack_c ! update singular vectors if( wantu1 ) then if( colmajor ) then - call stdlib_clasr( 'R', 'V', 'F', p, imax-imin+1,rwork(iu1cs+imin-1), rwork(& - iu1sn+imin-1),u1(1,imin), ldu1 ) + call stdlib${ii}$_clasr( 'R', 'V', 'F', p, imax-imin+1,rwork(iu1cs+imin-1), rwork(& + iu1sn+imin-1),u1(1_${ik}$,imin), ldu1 ) else - call stdlib_clasr( 'L', 'V', 'F', imax-imin+1, p,rwork(iu1cs+imin-1), rwork(& - iu1sn+imin-1),u1(imin,1), ldu1 ) + call stdlib${ii}$_clasr( 'L', 'V', 'F', imax-imin+1, p,rwork(iu1cs+imin-1), rwork(& + iu1sn+imin-1),u1(imin,1_${ik}$), ldu1 ) end if end if if( wantu2 ) then if( colmajor ) then - call stdlib_clasr( 'R', 'V', 'F', m-p, imax-imin+1,rwork(iu2cs+imin-1), rwork(& - iu2sn+imin-1),u2(1,imin), ldu2 ) + call stdlib${ii}$_clasr( 'R', 'V', 'F', m-p, imax-imin+1,rwork(iu2cs+imin-1), rwork(& + iu2sn+imin-1),u2(1_${ik}$,imin), ldu2 ) else - call stdlib_clasr( 'L', 'V', 'F', imax-imin+1, m-p,rwork(iu2cs+imin-1), rwork(& - iu2sn+imin-1),u2(imin,1), ldu2 ) + call stdlib${ii}$_clasr( 'L', 'V', 'F', imax-imin+1, m-p,rwork(iu2cs+imin-1), rwork(& + iu2sn+imin-1),u2(imin,1_${ik}$), ldu2 ) end if end if if( wantv1t ) then if( colmajor ) then - call stdlib_clasr( 'L', 'V', 'F', imax-imin+1, q,rwork(iv1tcs+imin-1), rwork(& - iv1tsn+imin-1),v1t(imin,1), ldv1t ) + call stdlib${ii}$_clasr( 'L', 'V', 'F', imax-imin+1, q,rwork(iv1tcs+imin-1), rwork(& + iv1tsn+imin-1),v1t(imin,1_${ik}$), ldv1t ) else - call stdlib_clasr( 'R', 'V', 'F', q, imax-imin+1,rwork(iv1tcs+imin-1), rwork(& - iv1tsn+imin-1),v1t(1,imin), ldv1t ) + call stdlib${ii}$_clasr( 'R', 'V', 'F', q, imax-imin+1,rwork(iv1tcs+imin-1), rwork(& + iv1tsn+imin-1),v1t(1_${ik}$,imin), ldv1t ) end if end if if( wantv2t ) then if( colmajor ) then - call stdlib_clasr( 'L', 'V', 'F', imax-imin+1, m-q,rwork(iv2tcs+imin-1), & - rwork(iv2tsn+imin-1),v2t(imin,1), ldv2t ) + call stdlib${ii}$_clasr( 'L', 'V', 'F', imax-imin+1, m-q,rwork(iv2tcs+imin-1), & + rwork(iv2tsn+imin-1),v2t(imin,1_${ik}$), ldv2t ) else - call stdlib_clasr( 'R', 'V', 'F', m-q, imax-imin+1,rwork(iv2tcs+imin-1), & - rwork(iv2tsn+imin-1),v2t(1,imin), ldv2t ) + call stdlib${ii}$_clasr( 'R', 'V', 'F', m-q, imax-imin+1,rwork(iv2tcs+imin-1), & + rwork(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_cscal( q, cnegone, v1t(imax,1), ldv1t ) + call stdlib${ii}$_cscal( q, cnegone, v1t(imax,1_${ik}$), ldv1t ) else - call stdlib_cscal( q, cnegone, v1t(1,imax), 1 ) + call stdlib${ii}$_cscal( q, cnegone, v1t(1_${ik}$,imax), 1_${ik}$ ) end if end if end if @@ -32153,33 +32155,33 @@ module stdlib_linalg_lapack_c 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_cscal( p, cnegone, u1(1,imax), 1 ) + call stdlib${ii}$_cscal( p, cnegone, u1(1_${ik}$,imax), 1_${ik}$ ) else - call stdlib_cscal( p, cnegone, u1(imax,1), ldu1 ) + call stdlib${ii}$_cscal( p, cnegone, 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_cscal( m-p, cnegone, u2(1,imax), 1 ) + call stdlib${ii}$_cscal( m-p, cnegone, u2(1_${ik}$,imax), 1_${ik}$ ) else - call stdlib_cscal( m-p, cnegone, u2(imax,1), ldu2 ) + call stdlib${ii}$_cscal( m-p, cnegone, 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_cscal( m-q, cnegone, v2t(imax,1), ldv2t ) + call stdlib${ii}$_cscal( m-q, cnegone, v2t(imax,1_${ik}$), ldv2t ) else - call stdlib_cscal( m-q, cnegone, v2t(1,imax), 1 ) + call stdlib${ii}$_cscal( m-q, cnegone, v2t(1_${ik}$,imax), 1_${ik}$ ) end if end if end if @@ -32199,16 +32201,16 @@ module stdlib_linalg_lapack_c 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 @@ -32228,25 +32230,25 @@ module stdlib_linalg_lapack_c theta(mini) = theta(i) theta(i) = thetamin if( colmajor ) then - if( wantu1 )call stdlib_cswap( p, u1(1,i), 1, u1(1,mini), 1 ) - if( wantu2 )call stdlib_cswap( m-p, u2(1,i), 1, u2(1,mini), 1 ) - if( wantv1t )call stdlib_cswap( q, v1t(i,1), ldv1t, v1t(mini,1), ldv1t ) + if( wantu1 )call stdlib${ii}$_cswap( p, u1(1_${ik}$,i), 1_${ik}$, u1(1_${ik}$,mini), 1_${ik}$ ) + if( wantu2 )call stdlib${ii}$_cswap( m-p, u2(1_${ik}$,i), 1_${ik}$, u2(1_${ik}$,mini), 1_${ik}$ ) + if( wantv1t )call stdlib${ii}$_cswap( q, v1t(i,1_${ik}$), ldv1t, v1t(mini,1_${ik}$), ldv1t ) - if( wantv2t )call stdlib_cswap( m-q, v2t(i,1), ldv2t, v2t(mini,1),ldv2t ) + if( wantv2t )call stdlib${ii}$_cswap( m-q, v2t(i,1_${ik}$), ldv2t, v2t(mini,1_${ik}$),ldv2t ) else - if( wantu1 )call stdlib_cswap( p, u1(i,1), ldu1, u1(mini,1), ldu1 ) - if( wantu2 )call stdlib_cswap( m-p, u2(i,1), ldu2, u2(mini,1), ldu2 ) - if( wantv1t )call stdlib_cswap( q, v1t(1,i), 1, v1t(1,mini), 1 ) - if( wantv2t )call stdlib_cswap( m-q, v2t(1,i), 1, v2t(1,mini), 1 ) + if( wantu1 )call stdlib${ii}$_cswap( p, u1(i,1_${ik}$), ldu1, u1(mini,1_${ik}$), ldu1 ) + if( wantu2 )call stdlib${ii}$_cswap( m-p, u2(i,1_${ik}$), ldu2, u2(mini,1_${ik}$), ldu2 ) + if( wantv1t )call stdlib${ii}$_cswap( q, v1t(1_${ik}$,i), 1_${ik}$, v1t(1_${ik}$,mini), 1_${ik}$ ) + if( wantv2t )call stdlib${ii}$_cswap( m-q, v2t(1_${ik}$,i), 1_${ik}$, v2t(1_${ik}$,mini), 1_${ik}$ ) end if end if end do return - end subroutine stdlib_cbbcsd + end subroutine stdlib${ii}$_cbbcsd - pure subroutine stdlib_cbdsqr( uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u,ldu, c, ldc, rwork,& + pure subroutine stdlib${ii}$_cbdsqr( uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u,ldu, c, ldc, rwork,& !! CBDSQR computes the singular values and, optionally, the right and/or !! left singular vectors from the singular value decomposition (SVD) of !! a real N-by-N (upper or lower) bidiagonal matrix B using the implicit @@ -32277,8 +32279,8 @@ module stdlib_linalg_lapack_c ! -- 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) :: ldc, ldu, ldvt, n, ncc, ncvt, nru + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldc, ldu, ldvt, n, ncc, ncvt, nru ! Array Arguments real(sp), intent(inout) :: d(*), e(*) real(sp), intent(out) :: rwork(*) @@ -32288,7 +32290,7 @@ module stdlib_linalg_lapack_c real(sp), parameter :: hndrth = 0.01_sp real(sp), parameter :: hndrd = 100.0_sp real(sp), parameter :: meigth = -0.125_sp - integer(ilp), parameter :: maxitr = 6 + integer(${ik}$), parameter :: maxitr = 6_${ik}$ @@ -32299,7 +32301,7 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: lower, rotate - integer(ilp) :: i, idir, isub, iter, j, ll, lll, m, maxit, nm1, nm12, nm13, oldll, & + integer(${ik}$) :: i, idir, isub, iter, j, ll, lll, m, maxit, nm1, nm12, nm13, oldll, & oldm real(sp) :: abse, abss, cosl, cosr, cs, eps, f, g, h, mu, oldcs, oldsn, r, shift, & sigmn, sigmx, sinl, sinr, sll, smax, smin, sminl, sminoa, sn, thresh, tol, tolmul, & @@ -32308,52 +32310,52 @@ module stdlib_linalg_lapack_c intrinsic :: abs,max,min,real,sign,sqrt ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ lower = stdlib_lsame( uplo, 'L' ) if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.lower ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( ncvt<0 ) then - info = -3 - else if( nru<0 ) then - info = -4 - else if( ncc<0 ) then - info = -5 - else if( ( ncvt==0 .and. ldvt<1 ) .or.( ncvt>0 .and. ldvt0 .and. ldc0_${ik}$ .and. ldvt0_${ik}$ .and. ldc0 ) .or. ( nru>0 ) .or. ( ncc>0 ) + rotate = ( ncvt>0_${ik}$ ) .or. ( nru>0_${ik}$ ) .or. ( ncc>0_${ik}$ ) ! if no singular vectors desired, use qd algorithm if( .not.rotate ) then - call stdlib_slasq1( n, d, e, rwork, info ) + call stdlib${ii}$_slasq1( n, d, e, rwork, info ) ! if info equals 2, dqds didn't finish, try to finish if( info /= 2 ) return - info = 0 + info = 0_${ik}$ end if - nm1 = n - 1 + nm1 = n - 1_${ik}$ nm12 = nm1 + nm1 nm13 = nm12 + nm1 - idir = 0 + idir = 0_${ik}$ ! get machine constants - eps = stdlib_slamch( 'EPSILON' ) - unfl = stdlib_slamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_slamch( 'EPSILON' ) + unfl = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) ! if matrix lower bidiagonal, rotate to be upper bidiagonal ! by applying givens rotations on the left if( lower ) then do i = 1, n - 1 - call stdlib_slartg( d( i ), e( i ), cs, sn, r ) + call stdlib${ii}$_slartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) @@ -32361,9 +32363,9 @@ module stdlib_linalg_lapack_c rwork( nm1+i ) = sn end do ! update singular vectors if desired - if( nru>0 )call stdlib_clasr( 'R', 'V', 'F', nru, n, rwork( 1 ), rwork( n ),u, ldu ) + if( nru>0_${ik}$ )call stdlib${ii}$_clasr( 'R', 'V', 'F', nru, n, rwork( 1_${ik}$ ), rwork( n ),u, ldu ) - if( ncc>0 )call stdlib_clasr( 'L', 'V', 'F', n, ncc, rwork( 1 ), rwork( n ),c, ldc ) + if( ncc>0_${ik}$ )call stdlib${ii}$_clasr( 'L', 'V', 'F', n, ncc, rwork( 1_${ik}$ ), rwork( n ),c, ldc ) end if ! compute singular values to relative accuracy tol @@ -32382,7 +32384,7 @@ module stdlib_linalg_lapack_c sminl = zero if( tol>=zero ) then ! relative accuracy desired - sminoa = abs( d( 1 ) ) + sminoa = abs( d( 1_${ik}$ ) ) if( sminoa==zero )go to 50 mu = sminoa do i = 2, n @@ -32401,9 +32403,9 @@ module stdlib_linalg_lapack_c ! (maxit is the maximum number of passes through the inner ! loop permitted before nonconvergence signalled.) maxit = maxitr*n*n - iter = 0 - oldll = -1 - oldm = -1 + iter = 0_${ik}$ + oldll = -1_${ik}$ + oldm = -1_${ik}$ ! m points to last element of unconverged part of matrix m = n ! begin main iteration loop @@ -32424,34 +32426,34 @@ module stdlib_linalg_lapack_c smin = min( smin, abss ) smax = max( smax, abss, abse ) end do - ll = 0 + ll = 0_${ik}$ go to 90 80 continue e( ll ) = zero ! matrix splits since e(ll) = 0 if( ll==m-1 ) then ! convergence of bottom singular value, return to top of loop - m = m - 1 + m = m - 1_${ik}$ go to 60 end if 90 continue - ll = ll + 1 + ll = ll + 1_${ik}$ ! e(ll) through e(m-1) are nonzero, e(ll-1) is zero if( ll==m-1 ) then ! 2 by 2 block, handle separately - call stdlib_slasv2( d( m-1 ), e( m-1 ), d( m ), sigmn, sigmx, sinr,cosr, sinl, cosl & + call stdlib${ii}$_slasv2( d( m-1 ), e( m-1 ), d( m ), sigmn, sigmx, sinr,cosr, sinl, cosl & ) d( m-1 ) = sigmx e( m-1 ) = zero d( m ) = sigmn ! compute singular vectors, if desired - if( ncvt>0 )call stdlib_csrot( ncvt, vt( m-1, 1 ), ldvt, vt( m, 1 ), ldvt,cosr, & + if( ncvt>0_${ik}$ )call stdlib${ii}$_csrot( ncvt, vt( m-1, 1_${ik}$ ), ldvt, vt( m, 1_${ik}$ ), ldvt,cosr, & sinr ) - if( nru>0 )call stdlib_csrot( nru, u( 1, m-1 ), 1, u( 1, m ), 1, cosl, sinl ) + if( nru>0_${ik}$ )call stdlib${ii}$_csrot( nru, u( 1_${ik}$, m-1 ), 1_${ik}$, u( 1_${ik}$, m ), 1_${ik}$, cosl, sinl ) - if( ncc>0 )call stdlib_csrot( ncc, c( m-1, 1 ), ldc, c( m, 1 ), ldc, cosl,sinl ) + if( ncc>0_${ik}$ )call stdlib${ii}$_csrot( ncc, c( m-1, 1_${ik}$ ), ldc, c( m, 1_${ik}$ ), ldc, cosl,sinl ) - m = m - 2 + m = m - 2_${ik}$ go to 60 end if ! if working on new submatrix, choose shift direction @@ -32459,14 +32461,14 @@ module stdlib_linalg_lapack_c if( ll>oldm .or. m=abs( d( m ) ) ) then ! chase bulge from top (big end) to bottom (small end) - idir = 1 + idir = 1_${ik}$ else ! chase bulge from bottom (big end) to top (small end) - idir = 2 + idir = 2_${ik}$ end if end if ! apply convergence tests - if( idir==1 ) then + if( idir==1_${ik}$ ) then ! run convergence test in forward direction ! first apply standard test to bottom of matrix if( abs( e( m-1 ) )<=abs( tol )*abs( d( m ) ) .or.( tolzero ) then - if( ( shift / sll )**2ll )e( i-1 ) = oldsn*r - call stdlib_slartg( oldcs*r, d( i+1 )*sn, oldcs, oldsn, d( i ) ) + call stdlib${ii}$_slartg( oldcs*r, d( i+1 )*sn, oldcs, oldsn, d( i ) ) rwork( i-ll+1 ) = cs rwork( i-ll+1+nm1 ) = sn rwork( i-ll+1+nm12 ) = oldcs @@ -32554,12 +32556,12 @@ module stdlib_linalg_lapack_c d( m ) = h*oldcs e( m-1 ) = h*oldsn ! update singular vectors - if( ncvt>0 )call stdlib_clasr( 'L', 'V', 'F', m-ll+1, ncvt, rwork( 1 ),rwork( n )& - , vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_clasr( 'R', 'V', 'F', nru, m-ll+1, rwork( nm12+1 ),rwork( & - nm13+1 ), u( 1, ll ), ldu ) - if( ncc>0 )call stdlib_clasr( 'L', 'V', 'F', m-ll+1, ncc, rwork( nm12+1 ),rwork( & - nm13+1 ), c( ll, 1 ), ldc ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_clasr( 'L', 'V', 'F', m-ll+1, ncvt, rwork( 1_${ik}$ ),rwork( n )& + , vt( ll, 1_${ik}$ ), ldvt ) + if( nru>0_${ik}$ )call stdlib${ii}$_clasr( 'R', 'V', 'F', nru, m-ll+1, rwork( nm12+1 ),rwork( & + nm13+1 ), u( 1_${ik}$, ll ), ldu ) + if( ncc>0_${ik}$ )call stdlib${ii}$_clasr( 'L', 'V', 'F', m-ll+1, ncc, rwork( nm12+1 ),rwork( & + nm13+1 ), c( ll, 1_${ik}$ ), ldc ) ! test convergence if( abs( e( m-1 ) )<=thresh )e( m-1 ) = zero else @@ -32568,9 +32570,9 @@ module stdlib_linalg_lapack_c cs = one oldcs = one do i = m, ll + 1, -1 - call stdlib_slartg( d( i )*cs, e( i-1 ), cs, sn, r ) + call stdlib${ii}$_slartg( d( i )*cs, e( i-1 ), cs, sn, r ) if( i0 )call stdlib_clasr( 'L', 'V', 'B', m-ll+1, ncvt, rwork( nm12+1 ),& - rwork( nm13+1 ), vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_clasr( 'R', 'V', 'B', nru, m-ll+1, rwork( 1 ),rwork( n ), & - u( 1, ll ), ldu ) - if( ncc>0 )call stdlib_clasr( 'L', 'V', 'B', m-ll+1, ncc, rwork( 1 ),rwork( n ), & - c( ll, 1 ), ldc ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_clasr( 'L', 'V', 'B', m-ll+1, ncvt, rwork( nm12+1 ),& + rwork( nm13+1 ), vt( ll, 1_${ik}$ ), ldvt ) + if( nru>0_${ik}$ )call stdlib${ii}$_clasr( 'R', 'V', 'B', nru, m-ll+1, rwork( 1_${ik}$ ),rwork( n ), & + u( 1_${ik}$, ll ), ldu ) + if( ncc>0_${ik}$ )call stdlib${ii}$_clasr( 'L', 'V', 'B', m-ll+1, ncc, rwork( 1_${ik}$ ),rwork( n ), & + c( ll, 1_${ik}$ ), ldc ) ! test convergence if( abs( e( ll ) )<=thresh )e( ll ) = zero end if else ! use nonzero shift - if( idir==1 ) then + if( idir==1_${ik}$ ) then ! chase bulge from top to bottom ! save cosines and sines for later singular vector updates f = ( abs( d( ll ) )-shift )*( sign( one, d( ll ) )+shift / d( ll ) ) g = e( ll ) do i = ll, m - 1 - call stdlib_slartg( f, g, cosr, sinr, r ) + call stdlib${ii}$_slartg( f, g, cosr, sinr, r ) if( i>ll )e( i-1 ) = r f = cosr*d( i ) + sinr*e( i ) e( i ) = cosr*e( i ) - sinr*d( i ) g = sinr*d( i+1 ) d( i+1 ) = cosr*d( i+1 ) - call stdlib_slartg( f, g, cosl, sinl, r ) + call stdlib${ii}$_slartg( f, g, cosl, sinl, r ) d( i ) = r f = cosl*e( i ) + sinl*d( i+1 ) d( i+1 ) = cosl*d( i+1 ) - sinl*e( i ) @@ -32618,12 +32620,12 @@ module stdlib_linalg_lapack_c end do e( m-1 ) = f ! update singular vectors - if( ncvt>0 )call stdlib_clasr( 'L', 'V', 'F', m-ll+1, ncvt, rwork( 1 ),rwork( n )& - , vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_clasr( 'R', 'V', 'F', nru, m-ll+1, rwork( nm12+1 ),rwork( & - nm13+1 ), u( 1, ll ), ldu ) - if( ncc>0 )call stdlib_clasr( 'L', 'V', 'F', m-ll+1, ncc, rwork( nm12+1 ),rwork( & - nm13+1 ), c( ll, 1 ), ldc ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_clasr( 'L', 'V', 'F', m-ll+1, ncvt, rwork( 1_${ik}$ ),rwork( n )& + , vt( ll, 1_${ik}$ ), ldvt ) + if( nru>0_${ik}$ )call stdlib${ii}$_clasr( 'R', 'V', 'F', nru, m-ll+1, rwork( nm12+1 ),rwork( & + nm13+1 ), u( 1_${ik}$, ll ), ldu ) + if( ncc>0_${ik}$ )call stdlib${ii}$_clasr( 'L', 'V', 'F', m-ll+1, ncc, rwork( nm12+1 ),rwork( & + nm13+1 ), c( ll, 1_${ik}$ ), ldc ) ! test convergence if( abs( e( m-1 ) )<=thresh )e( m-1 ) = zero else @@ -32632,13 +32634,13 @@ module stdlib_linalg_lapack_c f = ( abs( d( m ) )-shift )*( sign( one, d( m ) )+shift /d( m ) ) g = e( m-1 ) do i = m, ll + 1, -1 - call stdlib_slartg( f, g, cosr, sinr, r ) + call stdlib${ii}$_slartg( f, g, cosr, sinr, r ) if( i0 )call stdlib_clasr( 'L', 'V', 'B', m-ll+1, ncvt, rwork( nm12+1 ),& - rwork( nm13+1 ), vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_clasr( 'R', 'V', 'B', nru, m-ll+1, rwork( 1 ),rwork( n ), & - u( 1, ll ), ldu ) - if( ncc>0 )call stdlib_clasr( 'L', 'V', 'B', m-ll+1, ncc, rwork( 1 ),rwork( n ), & - c( ll, 1 ), ldc ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_clasr( 'L', 'V', 'B', m-ll+1, ncvt, rwork( nm12+1 ),& + rwork( nm13+1 ), vt( ll, 1_${ik}$ ), ldvt ) + if( nru>0_${ik}$ )call stdlib${ii}$_clasr( 'R', 'V', 'B', nru, m-ll+1, rwork( 1_${ik}$ ),rwork( n ), & + u( 1_${ik}$, ll ), ldu ) + if( ncc>0_${ik}$ )call stdlib${ii}$_clasr( 'L', 'V', 'B', m-ll+1, ncc, rwork( 1_${ik}$ ),rwork( n ), & + c( ll, 1_${ik}$ ), ldc ) end if end if ! qr iteration finished, go back and check convergence @@ -32671,15 +32673,15 @@ module stdlib_linalg_lapack_c if( d( i )0 )call stdlib_csscal( ncvt, negone, vt( i, 1 ), ldvt ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_csscal( ncvt, negone, vt( i, 1_${ik}$ ), ldvt ) end if end do ! sort the singular values into decreasing order (insertion sort on ! singular values, but only one transposition per singular vector) do i = 1, n - 1 ! scan for smallest d(i) - isub = 1 - smin = d( 1 ) + isub = 1_${ik}$ + smin = d( 1_${ik}$ ) do j = 2, n + 1 - i if( d( j )<=smin ) then isub = j @@ -32690,26 +32692,26 @@ module stdlib_linalg_lapack_c ! swap singular values and vectors d( isub ) = d( n+1-i ) d( n+1-i ) = smin - if( ncvt>0 )call stdlib_cswap( ncvt, vt( isub, 1 ), ldvt, vt( n+1-i, 1 ),ldvt ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_cswap( ncvt, vt( isub, 1_${ik}$ ), ldvt, vt( n+1-i, 1_${ik}$ ),ldvt ) - if( nru>0 )call stdlib_cswap( nru, u( 1, isub ), 1, u( 1, n+1-i ), 1 ) - if( ncc>0 )call stdlib_cswap( ncc, c( isub, 1 ), ldc, c( n+1-i, 1 ), ldc ) + if( nru>0_${ik}$ )call stdlib${ii}$_cswap( nru, u( 1_${ik}$, isub ), 1_${ik}$, u( 1_${ik}$, n+1-i ), 1_${ik}$ ) + if( ncc>0_${ik}$ )call stdlib${ii}$_cswap( ncc, c( isub, 1_${ik}$ ), ldc, c( n+1-i, 1_${ik}$ ), ldc ) end if end do go to 220 ! maximum number of iterations exceeded, failure to converge 200 continue - info = 0 + info = 0_${ik}$ do i = 1, n - 1 - if( e( i )/=zero )info = info + 1 + if( e( i )/=zero )info = info + 1_${ik}$ end do 220 continue return - end subroutine stdlib_cbdsqr + end subroutine stdlib${ii}$_cbdsqr - pure subroutine stdlib_cgbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond,work, rwork, & + pure subroutine stdlib${ii}$_cgbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond,work, rwork, & !! CGBCON estimates the reciprocal of the condition number of a complex !! general band matrix A, in either the 1-norm or the infinity-norm, !! using the LU factorization computed by CGBTRF. @@ -32722,12 +32724,12 @@ module stdlib_linalg_lapack_c ! -- 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(${ik}$), intent(in) :: ipiv(*) real(sp), intent(out) :: rwork(*) complex(sp), intent(in) :: ab(ldab,*) complex(sp), intent(out) :: work(*) @@ -32736,11 +32738,11 @@ module stdlib_linalg_lapack_c ! 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 complex(sp) :: t, zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,aimag,min,real ! Statement Functions @@ -32749,48 +32751,48 @@ module stdlib_linalg_lapack_c cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ onenrm = norm=='1' .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_clacn2( n, work( n+1 ), work, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_clacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + if( kase/=0_${ik}$ ) then if( kase==kase1 ) then ! multiply by inv(l). if( lnoti ) then @@ -32802,21 +32804,21 @@ module stdlib_linalg_lapack_c work( jp ) = work( j ) work( j ) = t end if - call stdlib_caxpy( lm, -t, ab( kd+1, j ), 1, work( j+1 ), 1 ) + call stdlib${ii}$_caxpy( lm, -t, ab( kd+1, j ), 1_${ik}$, work( j+1 ), 1_${ik}$ ) end do end if ! multiply by inv(u). - call stdlib_clatbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, & + call stdlib${ii}$_clatbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, & ldab, work, scale, rwork, info ) else ! multiply by inv(u**h). - call stdlib_clatbs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, kl+ku, & + call stdlib${ii}$_clatbs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, kl+ku, & ab, ldab, work, scale, rwork,info ) ! multiply by inv(l**h). if( lnoti ) then do j = n - 1, 1, -1 lm = min( kl, n-j ) - work( j ) = work( j ) - stdlib_cdotc( lm, ab( kd+1, j ), 1,work( j+1 ), 1 ) + work( j ) = work( j ) - stdlib${ii}$_cdotc( lm, ab( kd+1, j ), 1_${ik}$,work( j+1 ), 1_${ik}$ ) jp = ipiv( j ) if( jp/=j ) then @@ -32830,9 +32832,9 @@ module stdlib_linalg_lapack_c ! divide x by 1/scale if doing so will not cause overflow. normin = 'Y' if( scale/=one ) then - ix = stdlib_icamax( n, work, 1 ) + ix = stdlib${ii}$_icamax( n, work, 1_${ik}$ ) if( scalekl ) then + if( nb<=1_${ik}$ .or. nb>kl ) then ! use unblocked code - call stdlib_cgbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) + call stdlib${ii}$_cgbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) else ! use blocked code ! czero the superdiagonal elements of the work array work13 @@ -32924,7 +32926,7 @@ module stdlib_linalg_lapack_c 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 @@ -32950,57 +32952,57 @@ module stdlib_linalg_lapack_c ! find pivot and test for singularity. km is the number of ! subdiagonal elements in the current column. km = min( kl, m-jj ) - jp = stdlib_icamax( km+1, ab( kv+1, jj ), 1 ) + jp = stdlib${ii}$_icamax( km+1, ab( kv+1, jj ), 1_${ik}$ ) ipiv( jj ) = jp + jj - j if( ab( kv+jp, jj )/=czero ) then ju = max( ju, min( jj+ku+jp-1, n ) ) - if( jp/=1 ) then + if( jp/=1_${ik}$ ) then ! apply interchange to columns j to j+jb-1 if( jp+jj-1jj )call stdlib_cgeru( km, jm-jj, -cone, ab( kv+2, jj ), 1,ab( kv, & + if( jm>jj )call stdlib${ii}$_cgeru( km, jm-jj, -cone, ab( kv+2, jj ), 1_${ik}$,ab( kv, & jj+1 ), ldab-1,ab( kv+1, jj+1 ), ldab-1 ) else ! if pivot is czero, set info to the index of the pivot ! unless a czero 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_ccopy( nw, ab( kv+kl+1-jj+j, jj ), 1,work31( 1, jj-j+1 )& - , 1 ) + if( nw>0_${ik}$ )call stdlib${ii}$_ccopy( 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_claswp to apply the row interchanges to a12, a22, and ! a32. - call stdlib_claswp( j2, ab( kv+1-jb, j+jb ), ldab-1, 1, jb,ipiv( j ), 1 ) + call stdlib${ii}$_claswp( 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 @@ -33013,24 +33015,24 @@ module stdlib_linalg_lapack_c 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_ctrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j2, cone, & + call stdlib${ii}$_ctrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j2, cone, & ab( kv+1, j ), ldab-1,ab( kv+1-jb, j+jb ), ldab-1 ) - if( i2>0 ) then + if( i2>0_${ik}$ ) then ! update a22 - call stdlib_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j2,jb, -cone, ab(& + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j2,jb, -cone, ab(& kv+1+jb, j ), ldab-1,ab( kv+1-jb, j+jb ), ldab-1, cone,ab( kv+1, j+jb )& , ldab-1 ) end if - if( i3>0 ) then + if( i3>0_${ik}$ ) then ! update a32 - call stdlib_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j2,jb, -cone, & + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j2,jb, -cone, & work31, ldwork,ab( kv+1-jb, j+jb ), ldab-1, cone,ab( kv+kl+1-jb, j+jb ),& ldab-1 ) end if 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 @@ -33039,18 +33041,18 @@ module stdlib_linalg_lapack_c end do end do ! update a13 in the work array - call stdlib_ctrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j3, cone, & + call stdlib${ii}$_ctrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j3, cone, & ab( kv+1, j ), ldab-1,work13, ldwork ) - if( i2>0 ) then + if( i2>0_${ik}$ ) then ! update a23 - call stdlib_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j3,jb, -cone, ab(& - kv+1+jb, j ), ldab-1,work13, ldwork, cone, ab( 1+jb, j+kv ),ldab-1 ) + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j3,jb, -cone, ab(& + kv+1+jb, j ), ldab-1,work13, ldwork, cone, ab( 1_${ik}$+jb, j+kv ),ldab-1 ) end if - if( i3>0 ) then + if( i3>0_${ik}$ ) then ! update a33 - call stdlib_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j3,jb, -cone, & - work31, ldwork, work13,ldwork, cone, ab( 1+kl, j+kv ), ldab-1 ) + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j3,jb, -cone, & + work31, ldwork, work13,ldwork, cone, ab( 1_${ik}$+kl, j+kv ), ldab-1 ) end if ! copy the lower triangle of a13 back into place do jj = 1, j3 @@ -33062,38 +33064,38 @@ module stdlib_linalg_lapack_c 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_ccopy( nw, work31( 1, jj-j+1 ), 1,ab( kv+kl+1-jj+j, jj )& - , 1 ) + if( nw>0_${ik}$ )call stdlib${ii}$_ccopy( 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_cgbtrf + end subroutine stdlib${ii}$_cgbtrf - pure subroutine stdlib_cgbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info ) + pure subroutine stdlib${ii}$_cgbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info ) !! CGBTRS solves a system of linear equations !! A * X = B, A**T * X = B, or A**H * X = B !! with a general band matrix A using the LU factorization computed @@ -33103,47 +33105,47 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(in) :: ab(ldab,*) complex(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. @@ -33155,58 +33157,58 @@ module stdlib_linalg_lapack_c do j = 1, n - 1 lm = min( kl, n-j ) l = ipiv( j ) - if( l/=j )call stdlib_cswap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) - call stdlib_cgeru( lm, nrhs, -cone, ab( kd+1, j ), 1, b( j, 1 ),ldb, b( j+1, & - 1 ), ldb ) + if( l/=j )call stdlib${ii}$_cswap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb ) + call stdlib${ii}$_cgeru( lm, nrhs, -cone, 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_ctbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kl+ku,ab, ldab, b( 1, & - i ), 1 ) + call stdlib${ii}$_ctbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kl+ku,ab, ldab, b( 1_${ik}$, & + i ), 1_${ik}$ ) end do else if( stdlib_lsame( trans, 'T' ) ) then ! solve a**t * x = b. do i = 1, nrhs ! solve u**t * x = b, overwriting b with x. - call stdlib_ctbsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, kl+ku, ab,ldab, b( 1, i )& - , 1 ) + call stdlib${ii}$_ctbsv( '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_cgemv( 'TRANSPOSE', lm, nrhs, -cone, b( j+1, 1 ),ldb, ab( kd+1, j & - ), 1, cone, b( j, 1 ), ldb ) + call stdlib${ii}$_cgemv( 'TRANSPOSE', lm, nrhs, -cone, b( j+1, 1_${ik}$ ),ldb, ab( kd+1, j & + ), 1_${ik}$, cone, b( j, 1_${ik}$ ), ldb ) l = ipiv( j ) - if( l/=j )call stdlib_cswap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) + if( l/=j )call stdlib${ii}$_cswap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb ) end do end if else ! solve a**h * x = b. do i = 1, nrhs ! solve u**h * x = b, overwriting b with x. - call stdlib_ctbsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,kl+ku, ab, ldab,& - b( 1, i ), 1 ) + call stdlib${ii}$_ctbsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,kl+ku, ab, ldab,& + b( 1_${ik}$, i ), 1_${ik}$ ) end do ! solve l**h * x = b, overwriting b with x. if( lnoti ) then do j = n - 1, 1, -1 lm = min( kl, n-j ) - call stdlib_clacgv( nrhs, b( j, 1 ), ldb ) - call stdlib_cgemv( 'CONJUGATE TRANSPOSE', lm, nrhs, -cone,b( j+1, 1 ), ldb, & - ab( kd+1, j ), 1, cone,b( j, 1 ), ldb ) - call stdlib_clacgv( nrhs, b( j, 1 ), ldb ) + call stdlib${ii}$_clacgv( nrhs, b( j, 1_${ik}$ ), ldb ) + call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', lm, nrhs, -cone,b( j+1, 1_${ik}$ ), ldb, & + ab( kd+1, j ), 1_${ik}$, cone,b( j, 1_${ik}$ ), ldb ) + call stdlib${ii}$_clacgv( nrhs, b( j, 1_${ik}$ ), ldb ) l = ipiv( j ) - if( l/=j )call stdlib_cswap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) + if( l/=j )call stdlib${ii}$_cswap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb ) end do end if end if return - end subroutine stdlib_cgbtrs + end subroutine stdlib${ii}$_cgbtrs - pure subroutine stdlib_cgebd2( m, n, a, lda, d, e, tauq, taup, work, info ) + pure subroutine stdlib${ii}$_cgebd2( m, n, a, lda, d, e, tauq, taup, work, info ) !! CGEBD2 reduces a complex general m by n matrix A to upper or lower !! real bidiagonal form B by a unitary transformation: Q**H * A * P = B. !! If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. @@ -33214,8 +33216,8 @@ module stdlib_linalg_lapack_c ! -- 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(out) :: d(*), e(*) complex(sp), intent(inout) :: a(lda,*) @@ -33223,22 +33225,22 @@ module stdlib_linalg_lapack_c ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i complex(sp) :: alpha ! Intrinsic Functions intrinsic :: conjg,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=n ) then @@ -33246,25 +33248,25 @@ module stdlib_linalg_lapack_c do i = 1, n ! generate elementary reflector h(i) to annihilate a(i+1:m,i) alpha = a( i, i ) - call stdlib_clarfg( m-i+1, alpha, a( min( i+1, m ), i ), 1,tauq( i ) ) + call stdlib${ii}$_clarfg( m-i+1, alpha, a( min( i+1, m ), i ), 1_${ik}$,tauq( i ) ) d( i ) = real( alpha,KIND=sp) a( i, i ) = cone ! apply h(i)**h to a(i:m,i+1:n) from the left - if( imax( 1, n ) ) then - info = -2 + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -1_${ik}$ + else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then + info = -2_${ik}$ else if( ihin ) then - info = -3 - else if( lda1 .and. nb1_${ik}$ .and. nbq ) 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( ldv1 .and. nb1_${ik}$ .and. nb1 ) 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_clarft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1, n-k+i ), & + call stdlib${ii}$_clarft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1_${ik}$, n-k+i ), & lda, tau( i ), work, ldwork ) ! apply h**h to a(1:m-k+i+ib-1,1:n-k+i-1) from the left - call stdlib_clarfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'BACKWARD','COLUMNWISE', m-& - k+i+ib-1, n-k+i-1, ib,a( 1, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), & + call stdlib${ii}$_clarfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'BACKWARD','COLUMNWISE', m-& + k+i+ib-1, n-k+i-1, ib,a( 1_${ik}$, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), & ldwork ) end if end do - mu = m - k + i + nb - 1 - nu = n - k + i + nb - 1 + mu = m - k + i + nb - 1_${ik}$ + nu = n - k + i + nb - 1_${ik}$ else mu = m nu = n end if ! use unblocked code to factor the last or only block - if( mu>0 .and. nu>0 )call stdlib_cgeql2( mu, nu, a, lda, tau, work, iinfo ) - work( 1 ) = iws + if( mu>0_${ik}$ .and. nu>0_${ik}$ )call stdlib${ii}$_cgeql2( mu, nu, a, lda, tau, work, iinfo ) + work( 1_${ik}$ ) = iws return - end subroutine stdlib_cgeqlf + end subroutine stdlib${ii}$_cgeqlf - pure subroutine stdlib_cgeqr2( m, n, a, lda, tau, work, info ) + pure subroutine stdlib${ii}$_cgeqr2( m, n, a, lda, tau, work, info ) !! CGEQR2 computes a QR factorization of a complex m-by-n matrix A: !! A = Q * ( R ), !! ( 0 ) @@ -34068,50 +34070,50 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, k + integer(${ik}$) :: i, k complex(sp) :: alpha ! Intrinsic Functions intrinsic :: conjg,max,min ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda0 .and. lwork0_${ik}$ .and. lwork1 .and. nb1_${ik}$ .and. nb1 .and. nb1_${ik}$ .and. nb t(i,1) - call stdlib_clarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,t( i, 1 ) ) + call stdlib${ii}$_clarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,t( i, 1_${ik}$ ) ) if( i0 .and. lwork0_${ik}$ .and. lwork1 .and. nb1_${ik}$ .and. nb1 ) then + if( m-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_clarft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( m-k+i, 1 ), lda, & + call stdlib${ii}$_clarft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( m-k+i, 1_${ik}$ ), lda, & tau( i ), work, ldwork ) ! apply h to a(1:m-k+i-1,1:n-k+i+ib-1) from the right - call stdlib_clarfb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', m-k+i-1, n-& - k+i+ib-1, ib,a( m-k+i, 1 ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork ) + call stdlib${ii}$_clarfb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', m-k+i-1, n-& + k+i+ib-1, ib,a( m-k+i, 1_${ik}$ ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork ) end if end do - mu = m - k + i + nb - 1 - nu = n - k + i + nb - 1 + mu = m - k + i + nb - 1_${ik}$ + nu = n - k + i + nb - 1_${ik}$ else mu = m nu = n end if ! use unblocked code to factor the last or only block - if( mu>0 .and. nu>0 )call stdlib_cgerq2( mu, nu, a, lda, tau, work, iinfo ) - work( 1 ) = iws + if( mu>0_${ik}$ .and. nu>0_${ik}$ )call stdlib${ii}$_cgerq2( mu, nu, a, lda, tau, work, iinfo ) + work( 1_${ik}$ ) = iws return - end subroutine stdlib_cgerqf + end subroutine stdlib${ii}$_cgerqf - pure subroutine stdlib_cgesc2( n, a, lda, rhs, ipiv, jpiv, scale ) + pure subroutine stdlib${ii}$_cgesc2( n, a, lda, rhs, ipiv, jpiv, scale ) !! CGESC2 solves a system of linear equations !! A * X = scale* RHS !! with a general N-by-N matrix A using the LU factorization with @@ -34690,28 +34692,28 @@ module stdlib_linalg_lapack_c ! -- 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, n + integer(${ik}$), intent(in) :: lda, n real(sp), intent(out) :: scale ! Array Arguments - integer(ilp), intent(in) :: ipiv(*), jpiv(*) + integer(${ik}$), intent(in) :: ipiv(*), jpiv(*) complex(sp), intent(in) :: a(lda,*) complex(sp), intent(inout) :: rhs(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(sp) :: bignum, eps, smlnum complex(sp) :: temp ! Intrinsic Functions intrinsic :: abs,cmplx,real ! Executable Statements ! set constant 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 ) + call stdlib${ii}$_slabad( smlnum, bignum ) ! apply permutations ipiv to rhs - call stdlib_claswp( 1, rhs, lda, 1, n-1, ipiv, 1 ) + call stdlib${ii}$_claswp( 1_${ik}$, rhs, lda, 1_${ik}$, n-1, ipiv, 1_${ik}$ ) ! solve for l part do i = 1, n - 1 do j = i + 1, n @@ -34721,10 +34723,10 @@ module stdlib_linalg_lapack_c ! solve for u part scale = one ! check for scaling - i = stdlib_icamax( n, rhs, 1 ) + i = stdlib${ii}$_icamax( n, rhs, 1_${ik}$ ) if( two*smlnum*abs( rhs( i ) )>abs( a( n, n ) ) ) then temp = cmplx( one / two, zero,KIND=sp) / abs( rhs( i ) ) - call stdlib_cscal( n, temp, rhs( 1 ), 1 ) + call stdlib${ii}$_cscal( n, temp, rhs( 1_${ik}$ ), 1_${ik}$ ) scale = scale*real( temp,KIND=sp) end if do i = n, 1, -1 @@ -34735,12 +34737,12 @@ module stdlib_linalg_lapack_c end do end do ! apply permutations jpiv to the solution (rhs) - call stdlib_claswp( 1, rhs, lda, 1, n-1, jpiv, -1 ) + call stdlib${ii}$_claswp( 1_${ik}$, rhs, lda, 1_${ik}$, n-1, jpiv, -1_${ik}$ ) return - end subroutine stdlib_cgesc2 + end subroutine stdlib${ii}$_cgesc2 - pure recursive subroutine stdlib_cgetrf2( m, n, a, lda, ipiv, info ) + pure recursive subroutine stdlib${ii}$_cgetrf2( m, n, a, lda, ipiv, info ) !! CGETRF2 computes an LU factorization of a general M-by-N matrix A !! using partial pivoting with row interchanges. !! The factorization has the form @@ -34764,99 +34766,99 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars real(sp) :: sfmin complex(sp) :: temp - integer(ilp) :: i, iinfo, n1, n2 + integer(${ik}$) :: i, iinfo, n1, n2 ! 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_cscal( m-1, cone / a( 1, 1 ), a( 2, 1 ), 1 ) + if( abs(a( 1_${ik}$, 1_${ik}$ )) >= sfmin ) then + call stdlib${ii}$_cscal( m-1, cone / 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_cgetrf2( m, n1, a, lda, ipiv, iinfo ) - if ( info==0 .and. iinfo>0 )info = iinfo + call stdlib${ii}$_cgetrf2( m, n1, a, lda, ipiv, iinfo ) + if ( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo ! [ a12 ] ! apply interchanges to [ --- ] ! [ a22 ] - call stdlib_claswp( n2, a( 1, n1+1 ), lda, 1, n1, ipiv, 1 ) + call stdlib${ii}$_claswp( n2, a( 1_${ik}$, n1+1 ), lda, 1_${ik}$, n1, ipiv, 1_${ik}$ ) ! solve a12 - call stdlib_ctrsm( 'L', 'L', 'N', 'U', n1, n2, cone, a, lda,a( 1, n1+1 ), lda ) + call stdlib${ii}$_ctrsm( 'L', 'L', 'N', 'U', n1, n2, cone, a, lda,a( 1_${ik}$, n1+1 ), lda ) ! update a22 - call stdlib_cgemm( 'N', 'N', m-n1, n2, n1, -cone, a( n1+1, 1 ), lda,a( 1, n1+1 ), & + call stdlib${ii}$_cgemm( 'N', 'N', m-n1, n2, n1, -cone, a( n1+1, 1_${ik}$ ), lda,a( 1_${ik}$, n1+1 ), & lda, cone, a( n1+1, n1+1 ), lda ) ! factor a22 - call stdlib_cgetrf2( m-n1, n2, a( n1+1, n1+1 ), lda, ipiv( n1+1 ),iinfo ) + call stdlib${ii}$_cgetrf2( 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_claswp( n1, a( 1, 1 ), lda, n1+1, min( m, n), ipiv, 1 ) + call stdlib${ii}$_claswp( n1, a( 1_${ik}$, 1_${ik}$ ), lda, n1+1, min( m, n), ipiv, 1_${ik}$ ) end if return - end subroutine stdlib_cgetrf2 + end subroutine stdlib${ii}$_cgetrf2 - pure subroutine stdlib_cgetri( n, a, lda, ipiv, work, lwork, info ) + pure subroutine stdlib${ii}$_cgetri( n, a, lda, ipiv, work, lwork, info ) !! CGETRI computes the inverse of a matrix using the LU factorization !! computed by CGETRF. !! This method inverts U and then computes inv(A) by solving the system @@ -34865,52 +34867,52 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(inout) :: a(lda,*) complex(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, 'CGETRI', ' ', n, -1, -1, -1 ) + info = 0_${ik}$ + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CGETRI', ' ', 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_ctrtri, then u is singular, + ! form inv(u). if info > 0 from stdlib${ii}$_ctrtri, then u is singular, ! and the inverse is not computed. - call stdlib_ctrtri( 'UPPER', 'NON-UNIT', n, a, lda, info ) + call stdlib${ii}$_ctrtri( '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_cgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) + call stdlib${ii}$_cgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) else do j = 1, nrhs, nb jb = min( nrhs-j+1, nb ) - call stdlib_cgtts2( itrans, n, jb, dl, d, du, du2, ipiv, b( 1, j ),ldb ) + call stdlib${ii}$_cgtts2( itrans, n, jb, dl, d, du, du2, ipiv, b( 1_${ik}$, j ),ldb ) end do end if - end subroutine stdlib_cgttrs + end subroutine stdlib${ii}$_cgttrs - pure subroutine stdlib_chb2st_kernels( uplo, wantz, ttype,st, ed, sweep, n, nb, ib,a, lda, & + pure subroutine stdlib${ii}$_chb2st_kernels( uplo, wantz, ttype,st, ed, sweep, n, nb, ib,a, lda, & !! CHB2ST_KERNELS is an internal routine used by the CHETRD_HB2ST !! subroutine. v, tau, ldvt, work) @@ -35391,7 +35393,7 @@ module stdlib_linalg_lapack_c ! Scalar Arguments character, intent(in) :: uplo logical(lk), intent(in) :: wantz - integer(ilp), intent(in) :: ttype, st, ed, sweep, n, nb, ib, lda, ldvt + integer(${ik}$), intent(in) :: ttype, st, ed, sweep, n, nb, ib, lda, ldvt ! Array Arguments complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: v(*), tau(*), work(*) @@ -35399,7 +35401,7 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: upper - integer(ilp) :: i, j1, j2, lm, ln, vpos, taupos, dpos, ofdpos, ajeter + integer(${ik}$) :: i, j1, j2, lm, ln, vpos, taupos, dpos, ofdpos, ajeter complex(sp) :: ctmp ! Intrinsic Functions intrinsic :: conjg,mod @@ -35407,54 +35409,54 @@ module stdlib_linalg_lapack_c ajeter = ib + ldvt upper = stdlib_lsame( uplo, 'U' ) if( upper ) then - dpos = 2 * nb + 1 - ofdpos = 2 * nb + dpos = 2_${ik}$ * nb + 1_${ik}$ + ofdpos = 2_${ik}$ * nb else - dpos = 1 - ofdpos = 2 + dpos = 1_${ik}$ + ofdpos = 2_${ik}$ endif ! upper case if( upper ) then if( wantz ) then - vpos = mod( sweep-1, 2 ) * n + st - taupos = mod( sweep-1, 2 ) * n + st + vpos = mod( sweep-1, 2_${ik}$ ) * n + st + taupos = mod( sweep-1, 2_${ik}$ ) * n + st else - vpos = mod( sweep-1, 2 ) * n + st - taupos = mod( sweep-1, 2 ) * n + st + vpos = mod( sweep-1, 2_${ik}$ ) * n + st + taupos = mod( sweep-1, 2_${ik}$ ) * n + st endif - if( ttype==1 ) then - lm = ed - st + 1 + if( ttype==1_${ik}$ ) then + lm = ed - st + 1_${ik}$ v( vpos ) = cone do i = 1, lm-1 v( vpos+i ) = conjg( a( ofdpos-i, st+i ) ) a( ofdpos-i, st+i ) = czero end do ctmp = conjg( a( ofdpos, st ) ) - call stdlib_clarfg( lm, ctmp, v( vpos+1 ), 1,tau( taupos ) ) + call stdlib${ii}$_clarfg( lm, ctmp, v( vpos+1 ), 1_${ik}$,tau( taupos ) ) a( ofdpos, st ) = ctmp - lm = ed - st + 1 - call stdlib_clarfy( uplo, lm, v( vpos ), 1,conjg( tau( taupos ) ),a( dpos, st )& + lm = ed - st + 1_${ik}$ + call stdlib${ii}$_clarfy( uplo, lm, v( vpos ), 1_${ik}$,conjg( tau( taupos ) ),a( dpos, st )& , lda-1, work) endif - if( ttype==3 ) then - lm = ed - st + 1 - call stdlib_clarfy( uplo, lm, v( vpos ), 1,conjg( tau( taupos ) ),a( dpos, st )& + if( ttype==3_${ik}$ ) then + lm = ed - st + 1_${ik}$ + call stdlib${ii}$_clarfy( uplo, lm, v( vpos ), 1_${ik}$,conjg( tau( taupos ) ),a( dpos, st )& , lda-1, work) endif - if( ttype==2 ) then + if( ttype==2_${ik}$ ) then j1 = ed+1 j2 = min( ed+nb, n ) ln = ed-st+1 lm = j2-j1+1 - if( lm>0) then - call stdlib_clarfx( 'LEFT', ln, lm, v( vpos ),conjg( tau( taupos ) ),a( & + if( lm>0_${ik}$) then + call stdlib${ii}$_clarfx( 'LEFT', ln, lm, v( vpos ),conjg( tau( taupos ) ),a( & dpos-nb, j1 ), lda-1, work) if( wantz ) then - vpos = mod( sweep-1, 2 ) * n + j1 - taupos = mod( sweep-1, 2 ) * n + j1 + vpos = mod( sweep-1, 2_${ik}$ ) * n + j1 + taupos = mod( sweep-1, 2_${ik}$ ) * n + j1 else - vpos = mod( sweep-1, 2 ) * n + j1 - taupos = mod( sweep-1, 2 ) * n + j1 + vpos = mod( sweep-1, 2_${ik}$ ) * n + j1 + taupos = mod( sweep-1, 2_${ik}$ ) * n + j1 endif v( vpos ) = cone do i = 1, lm-1 @@ -35462,71 +35464,71 @@ module stdlib_linalg_lapack_c a( dpos-nb-i, j1+i ) = czero end do ctmp = conjg( a( dpos-nb, j1 ) ) - call stdlib_clarfg( lm, ctmp, v( vpos+1 ), 1, tau( taupos ) ) + call stdlib${ii}$_clarfg( lm, ctmp, v( vpos+1 ), 1_${ik}$, tau( taupos ) ) a( dpos-nb, j1 ) = ctmp - call stdlib_clarfx( 'RIGHT', ln-1, lm, v( vpos ),tau( taupos ),a( dpos-nb+& - 1, j1 ), lda-1, work) + call stdlib${ii}$_clarfx( 'RIGHT', ln-1, lm, v( vpos ),tau( taupos ),a( dpos-nb+& + 1_${ik}$, j1 ), lda-1, work) endif endif ! lower case else if( wantz ) then - vpos = mod( sweep-1, 2 ) * n + st - taupos = mod( sweep-1, 2 ) * n + st + vpos = mod( sweep-1, 2_${ik}$ ) * n + st + taupos = mod( sweep-1, 2_${ik}$ ) * n + st else - vpos = mod( sweep-1, 2 ) * n + st - taupos = mod( sweep-1, 2 ) * n + st + vpos = mod( sweep-1, 2_${ik}$ ) * n + st + taupos = mod( sweep-1, 2_${ik}$ ) * n + st endif - if( ttype==1 ) then - lm = ed - st + 1 + if( ttype==1_${ik}$ ) then + lm = ed - st + 1_${ik}$ v( vpos ) = cone do i = 1, lm-1 v( vpos+i ) = a( ofdpos+i, st-1 ) a( ofdpos+i, st-1 ) = czero end do - call stdlib_clarfg( lm, a( ofdpos, st-1 ), v( vpos+1 ), 1,tau( taupos ) ) + call stdlib${ii}$_clarfg( lm, a( ofdpos, st-1 ), v( vpos+1 ), 1_${ik}$,tau( taupos ) ) - lm = ed - st + 1 - call stdlib_clarfy( uplo, lm, v( vpos ), 1,conjg( tau( taupos ) ),a( dpos, st )& + lm = ed - st + 1_${ik}$ + call stdlib${ii}$_clarfy( uplo, lm, v( vpos ), 1_${ik}$,conjg( tau( taupos ) ),a( dpos, st )& , lda-1, work) endif - if( ttype==3 ) then - lm = ed - st + 1 - call stdlib_clarfy( uplo, lm, v( vpos ), 1,conjg( tau( taupos ) ),a( dpos, st )& + if( ttype==3_${ik}$ ) then + lm = ed - st + 1_${ik}$ + call stdlib${ii}$_clarfy( uplo, lm, v( vpos ), 1_${ik}$,conjg( tau( taupos ) ),a( dpos, st )& , lda-1, work) endif - if( ttype==2 ) then + if( ttype==2_${ik}$ ) then j1 = ed+1 j2 = min( ed+nb, n ) ln = ed-st+1 lm = j2-j1+1 - if( lm>0) then - call stdlib_clarfx( 'RIGHT', lm, ln, v( vpos ),tau( taupos ), a( dpos+nb, & + if( lm>0_${ik}$) then + call stdlib${ii}$_clarfx( 'RIGHT', lm, ln, v( vpos ),tau( taupos ), a( dpos+nb, & st ),lda-1, work) if( wantz ) then - vpos = mod( sweep-1, 2 ) * n + j1 - taupos = mod( sweep-1, 2 ) * n + j1 + vpos = mod( sweep-1, 2_${ik}$ ) * n + j1 + taupos = mod( sweep-1, 2_${ik}$ ) * n + j1 else - vpos = mod( sweep-1, 2 ) * n + j1 - taupos = mod( sweep-1, 2 ) * n + j1 + vpos = mod( sweep-1, 2_${ik}$ ) * n + j1 + taupos = mod( sweep-1, 2_${ik}$ ) * n + j1 endif v( vpos ) = cone do i = 1, lm-1 v( vpos+i ) = a( dpos+nb+i, st ) a( dpos+nb+i, st ) = czero end do - call stdlib_clarfg( lm, a( dpos+nb, st ), v( vpos+1 ), 1,tau( taupos ) ) + call stdlib${ii}$_clarfg( lm, a( dpos+nb, st ), v( vpos+1 ), 1_${ik}$,tau( taupos ) ) - call stdlib_clarfx( 'LEFT', lm, ln-1, v( vpos ),conjg( tau( taupos ) ),a( & + call stdlib${ii}$_clarfx( 'LEFT', lm, ln-1, v( vpos ),conjg( tau( taupos ) ),a( & dpos+nb-1, st+1 ), lda-1, work) endif endif endif return - end subroutine stdlib_chb2st_kernels + end subroutine stdlib${ii}$_chb2st_kernels - pure subroutine stdlib_cheequb( uplo, n, a, lda, s, scond, amax, work, info ) + pure subroutine stdlib${ii}$_cheequb( uplo, n, a, lda, s, scond, amax, work, info ) !! CHEEQUB computes row and column scalings intended to equilibrate a !! Hermitian matrix A (with respect to the Euclidean norm) and reduce !! its condition number. The scale factors S are computed by the BIN @@ -35538,8 +35540,8 @@ module stdlib_linalg_lapack_c ! -- 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 @@ -35548,11 +35550,11 @@ module stdlib_linalg_lapack_c real(sp), intent(out) :: s(*) ! ===================================================================== ! 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 @@ -35565,22 +35567,22 @@ module stdlib_linalg_lapack_c cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) ) ! 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( 'CHEEQUB', -info ) + if ( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'CHEEQUB', -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 @@ -35647,7 +35649,7 @@ module stdlib_linalg_lapack_c do i = n+1, 2*n work( i ) = s( i-n ) * work( i-n ) - avg end do - call stdlib_classq( n, work( n+1 ), 1, scale, sumsq ) + call stdlib${ii}$_classq( n, work( n+1 ), 1_${ik}$, scale, sumsq ) std = scale * sqrt( sumsq / n ) if ( std < tol * avg ) goto 999 do i = 1, n @@ -35655,13 +35657,13 @@ module stdlib_linalg_lapack_c si = s( i ) c2 = ( n-1 ) * t c1 = real( ( n-2 ) * ( work( i ) - t*si ),KIND=sp) - c0 = real( -(t*si)*si + 2*work( i )*si - n*avg,KIND=sp) - d = c1*c1 - 4*c0*c2 - if ( d <= 0 ) then - info = -1 + c0 = real( -(t*si)*si + 2_${ik}$*work( i )*si - n*avg,KIND=sp) + 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 @@ -35692,23 +35694,23 @@ module stdlib_linalg_lapack_c 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_cheequb + end subroutine stdlib${ii}$_cheequb - pure subroutine stdlib_chegs2( itype, uplo, n, a, lda, b, ldb, info ) + pure subroutine stdlib${ii}$_chegs2( itype, uplo, n, a, lda, b, ldb, info ) !! CHEGS2 reduces a complex Hermitian-definite generalized !! eigenproblem to standard form. !! If ITYPE = 1, the problem is A*x = lambda*B*x, @@ -35721,8 +35723,8 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: a(lda,*), b(ldb,*) ! ===================================================================== @@ -35730,52 +35732,52 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: upper - integer(ilp) :: k + integer(${ik}$) :: k real(sp) :: akk, bkk complex(sp) :: 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}$, 'CHEGST', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code - call stdlib_chegs2( itype, uplo, n, a, lda, b, ldb, info ) + call stdlib${ii}$_chegs2( 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**h)*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_chegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib${ii}$_chegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) if( k+kb<=n ) then - call stdlib_ctrsm( 'LEFT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', kb, & + call stdlib${ii}$_ctrsm( 'LEFT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', kb, & n-k-kb+1, cone,b( k, k ), ldb, a( k, k+kb ), lda ) - call stdlib_chemm( 'LEFT', uplo, kb, n-k-kb+1, -chalf,a( k, k ), lda, b(& + call stdlib${ii}$_chemm( 'LEFT', uplo, kb, n-k-kb+1, -chalf,a( k, k ), lda, b(& k, k+kb ), ldb,cone, a( k, k+kb ), lda ) - call stdlib_cher2k( uplo, 'CONJUGATE TRANSPOSE', n-k-kb+1,kb, -cone, a( & + call stdlib${ii}$_cher2k( uplo, 'CONJUGATE TRANSPOSE', n-k-kb+1,kb, -cone, a( & k, k+kb ), lda,b( k, k+kb ), ldb, one,a( k+kb, k+kb ), lda ) - call stdlib_chemm( 'LEFT', uplo, kb, n-k-kb+1, -chalf,a( k, k ), lda, b(& + call stdlib${ii}$_chemm( 'LEFT', uplo, kb, n-k-kb+1, -chalf,a( k, k ), lda, b(& k, k+kb ), ldb,cone, a( k, k+kb ), lda ) - call stdlib_ctrsm( 'RIGHT', uplo, 'NO TRANSPOSE','NON-UNIT', kb, n-k-kb+& - 1, cone,b( k+kb, k+kb ), ldb, a( k, k+kb ),lda ) + call stdlib${ii}$_ctrsm( 'RIGHT', uplo, 'NO TRANSPOSE','NON-UNIT', kb, n-k-kb+& + 1_${ik}$, cone,b( k+kb, k+kb ), ldb, a( k, k+kb ),lda ) end if end do else @@ -35920,18 +35922,18 @@ module stdlib_linalg_lapack_c do k = 1, n, nb kb = min( n-k+1, nb ) ! update the lower triangle of a(k:n,k:n) - call stdlib_chegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib${ii}$_chegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) if( k+kb<=n ) then - call stdlib_ctrsm( 'RIGHT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', n-k-& + call stdlib${ii}$_ctrsm( 'RIGHT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', n-k-& kb+1, kb, cone,b( k, k ), ldb, a( k+kb, k ), lda ) - call stdlib_chemm( 'RIGHT', uplo, n-k-kb+1, kb, -chalf,a( k, k ), lda, & + call stdlib${ii}$_chemm( 'RIGHT', uplo, n-k-kb+1, kb, -chalf,a( k, k ), lda, & b( k+kb, k ), ldb,cone, a( k+kb, k ), lda ) - call stdlib_cher2k( uplo, 'NO TRANSPOSE', n-k-kb+1, kb,-cone, a( k+kb, & + call stdlib${ii}$_cher2k( uplo, 'NO TRANSPOSE', n-k-kb+1, kb,-cone, a( k+kb, & k ), lda,b( k+kb, k ), ldb, one,a( k+kb, k+kb ), lda ) - call stdlib_chemm( 'RIGHT', uplo, n-k-kb+1, kb, -chalf,a( k, k ), lda, & + call stdlib${ii}$_chemm( 'RIGHT', uplo, n-k-kb+1, kb, -chalf,a( k, k ), lda, & b( k+kb, k ), ldb,cone, a( k+kb, k ), lda ) - call stdlib_ctrsm( 'LEFT', uplo, 'NO TRANSPOSE','NON-UNIT', n-k-kb+1, & + call stdlib${ii}$_ctrsm( 'LEFT', uplo, 'NO TRANSPOSE','NON-UNIT', n-k-kb+1, & kb, cone,b( k+kb, k+kb ), ldb, a( k+kb, k ),lda ) end if end do @@ -35942,17 +35944,17 @@ module stdlib_linalg_lapack_c 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_ctrmm( 'LEFT', uplo, 'NO TRANSPOSE', 'NON-UNIT',k-1, kb, cone, & - b, ldb, a( 1, k ), lda ) - call stdlib_chemm( 'RIGHT', uplo, k-1, kb, chalf, a( k, k ),lda, b( 1, k ),& - ldb, cone, a( 1, k ),lda ) - call stdlib_cher2k( uplo, 'NO TRANSPOSE', k-1, kb, cone,a( 1, k ), lda, b( & - 1, k ), ldb, one, a,lda ) - call stdlib_chemm( 'RIGHT', uplo, k-1, kb, chalf, a( k, k ),lda, b( 1, k ),& - ldb, cone, a( 1, k ),lda ) - call stdlib_ctrmm( 'RIGHT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', k-1, & - kb, cone, b( k, k ), ldb,a( 1, k ), lda ) - call stdlib_chegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib${ii}$_ctrmm( 'LEFT', uplo, 'NO TRANSPOSE', 'NON-UNIT',k-1, kb, cone, & + b, ldb, a( 1_${ik}$, k ), lda ) + call stdlib${ii}$_chemm( 'RIGHT', uplo, k-1, kb, chalf, a( k, k ),lda, b( 1_${ik}$, k ),& + ldb, cone, a( 1_${ik}$, k ),lda ) + call stdlib${ii}$_cher2k( uplo, 'NO TRANSPOSE', k-1, kb, cone,a( 1_${ik}$, k ), lda, b( & + 1_${ik}$, k ), ldb, one, a,lda ) + call stdlib${ii}$_chemm( 'RIGHT', uplo, k-1, kb, chalf, a( k, k ),lda, b( 1_${ik}$, k ),& + ldb, cone, a( 1_${ik}$, k ),lda ) + call stdlib${ii}$_ctrmm( 'RIGHT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', k-1, & + kb, cone, b( k, k ), ldb,a( 1_${ik}$, k ), lda ) + call stdlib${ii}$_chegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) end do else @@ -35960,27 +35962,27 @@ module stdlib_linalg_lapack_c 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_ctrmm( 'RIGHT', uplo, 'NO TRANSPOSE', 'NON-UNIT',kb, k-1, cone,& - b, ldb, a( k, 1 ), lda ) - call stdlib_chemm( 'LEFT', uplo, kb, k-1, chalf, a( k, k ),lda, b( k, 1 ), & - ldb, cone, a( k, 1 ),lda ) - call stdlib_cher2k( uplo, 'CONJUGATE TRANSPOSE', k-1, kb,cone, a( k, 1 ), & - lda, b( k, 1 ), ldb,one, a, lda ) - call stdlib_chemm( 'LEFT', uplo, kb, k-1, chalf, a( k, k ),lda, b( k, 1 ), & - ldb, cone, a( k, 1 ),lda ) - call stdlib_ctrmm( 'LEFT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', kb, k-1,& - cone, b( k, k ), ldb,a( k, 1 ), lda ) - call stdlib_chegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib${ii}$_ctrmm( 'RIGHT', uplo, 'NO TRANSPOSE', 'NON-UNIT',kb, k-1, cone,& + b, ldb, a( k, 1_${ik}$ ), lda ) + call stdlib${ii}$_chemm( 'LEFT', uplo, kb, k-1, chalf, a( k, k ),lda, b( k, 1_${ik}$ ), & + ldb, cone, a( k, 1_${ik}$ ),lda ) + call stdlib${ii}$_cher2k( uplo, 'CONJUGATE TRANSPOSE', k-1, kb,cone, a( k, 1_${ik}$ ), & + lda, b( k, 1_${ik}$ ), ldb,one, a, lda ) + call stdlib${ii}$_chemm( 'LEFT', uplo, kb, k-1, chalf, a( k, k ),lda, b( k, 1_${ik}$ ), & + ldb, cone, a( k, 1_${ik}$ ),lda ) + call stdlib${ii}$_ctrmm( 'LEFT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', kb, k-1,& + cone, b( k, k ), ldb,a( k, 1_${ik}$ ), lda ) + call stdlib${ii}$_chegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) end do end if end if end if return - end subroutine stdlib_chegst + end subroutine stdlib${ii}$_chegst - pure subroutine stdlib_chetd2( uplo, n, a, lda, d, e, tau, info ) + pure subroutine stdlib${ii}$_chetd2( uplo, n, a, lda, d, e, tau, info ) !! CHETD2 reduces a complex Hermitian matrix A to real symmetric !! tridiagonal form T by a unitary similarity transformation: !! Q**H * A * Q = T. @@ -35989,8 +35991,8 @@ module stdlib_linalg_lapack_c ! -- 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(out) :: d(*), e(*) complex(sp), intent(inout) :: a(lda,*) @@ -35999,23 +36001,23 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: upper - integer(ilp) :: i + integer(${ik}$) :: i complex(sp) :: alpha, taui ! Intrinsic Functions intrinsic :: max,min,real ! 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 .and. nb1_${ik}$ .and. nbed ) exit @@ -36413,24 +36415,24 @@ module stdlib_linalg_lapack_c loop_130: do sweepid = st, ed loop_140: do k = 1, grsiz myid = (i-sweepid)*(stepercol*grsiz)+ (m-1)*grsiz + k - if ( myid==1 ) then - ttype = 1 + if ( myid==1_${ik}$ ) then + ttype = 1_${ik}$ else - ttype = mod( myid, 2 ) + 2 + ttype = mod( myid, 2_${ik}$ ) + 2_${ik}$ endif - if( ttype==2 ) then - colpt = (myid/2)*kd + sweepid + if( ttype==2_${ik}$ ) then + colpt = (myid/2_${ik}$)*kd + sweepid stind = colpt-kd+1 edind = min(colpt,n) blklastind = colpt else - colpt = ((myid+1)/2)*kd + sweepid + colpt = ((myid+1)/2_${ik}$)*kd + sweepid stind = colpt-kd+1 edind = min(colpt,n) if( ( stind>=edind-1 ).and.( edind==n ) ) then blklastind = n else - blklastind = 0 + blklastind = 0_${ik}$ endif endif ! call the kernel @@ -36439,7 +36441,7 @@ module stdlib_linalg_lapack_c !$OMP& DEPEND(in:WORK(MYID-1)) & !$OMP& DEPEND(out:WORK(MYID)) !$ tid = omp_get_thread_num() - !$ call stdlib_chb2st_kernels( uplo, wantq, ttype,stind, edind, & + !$ call stdlib${ii}$_chb2st_kernels( uplo, wantq, ttype,stind, edind, & !$ sweepid, n, kd, ib,work ( inda ), lda,hous( indv ), hous( & !$ indtau ), ldv,work( indw + tid*kd ) ) !$OMP END TASK @@ -36447,13 +36449,13 @@ module stdlib_linalg_lapack_c !$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) & !$OMP& DEPEND(out:WORK(MYID)) !$ tid = omp_get_thread_num() - call stdlib_chb2st_kernels( uplo, wantq, ttype,stind, edind, & + call stdlib${ii}$_chb2st_kernels( uplo, wantq, ttype,stind, edind, & sweepid, n, kd, ib,work ( inda ), lda,hous( indv ), hous( & indtau ), ldv,work( indw + tid*kd ) ) !$OMP END TASK !$ endif if ( blklastind>=(n-1) ) then - stt = stt + 1 + stt = stt + 1_${ik}$ exit endif end do loop_140 @@ -36479,13 +36481,13 @@ module stdlib_linalg_lapack_c e( i ) = real( work( ofdpos+(i-1)*lda ),KIND=sp) end do endif - hous( 1 ) = lhmin - work( 1 ) = lwmin + hous( 1_${ik}$ ) = lhmin + work( 1_${ik}$ ) = lwmin return - end subroutine stdlib_chetrd_hb2st + end subroutine stdlib${ii}$_chetrd_hb2st - subroutine stdlib_chetrd_he2hb( uplo, n, kd, a, lda, ab, ldab, tau,work, lwork, info ) + subroutine stdlib${ii}$_chetrd_he2hb( uplo, n, kd, a, lda, ab, ldab, tau,work, lwork, info ) !! CHETRD_HE2HB reduces a complex Hermitian matrix A to complex Hermitian !! band-diagonal form AB by a unitary similarity transformation: !! Q**H * A * Q = AB. @@ -36495,8 +36497,8 @@ module stdlib_linalg_lapack_c ! -- 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, ldab, lwork, n, kd + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldab, lwork, n, kd ! Array Arguments complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: ab(ldab,*), tau(*), work(*) @@ -36507,35 +36509,35 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: lquery, upper - integer(ilp) :: i, j, iinfo, lwmin, pn, pk, llk, ldt, ldw, lds2, lds1, ls2, ls1, lw, lt,& + integer(${ik}$) :: i, j, iinfo, lwmin, pn, pk, llk, ldt, ldw, lds2, lds1, ls2, ls1, lw, lt,& tpos, wpos, s2pos, s1pos ! Intrinsic Functions intrinsic :: min,max ! Executable Statements ! determine the minimal workspace size required ! and test the input parameters - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) - lquery = ( lwork==-1 ) - lwmin = stdlib_ilaenv2stage( 4, 'CHETRD_HE2HB', '', n, kd, -1, -1 ) + lquery = ( lwork==-1_${ik}$ ) + lwmin = stdlib${ii}$_ilaenv2stage( 4_${ik}$, 'CHETRD_HE2HB', '', n, kd, -1_${ik}$, -1_${ik}$ ) 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( 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_clahef( uplo, k, nb, kb, a, lda, ipiv, work, n, iinfo ) + call stdlib${ii}$_clahef( uplo, k, nb, kb, a, lda, ipiv, work, n, iinfo ) else ! use unblocked code to factorize columns 1:k of a - call stdlib_chetf2( uplo, k, a, lda, ipiv, iinfo ) + call stdlib${ii}$_chetf2( 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 ! decrease k and return to the start of the main loop k = k - kb go to 10 else ! factorize a as l*d*l**h using the lower triangle of a ! k is the main loop index, increasing from 1 to n in steps of - ! kb, where kb is the number of columns factorized by stdlib_clahef; + ! kb, where kb is the number of columns factorized by stdlib${ii}$_clahef; ! 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_clahef( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, n, & + call stdlib${ii}$_clahef( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, n, & iinfo ) else ! use unblocked code to factorize columns k:n of a - call stdlib_chetf2( uplo, n-k+1, a( k, k ), lda, ipiv( k ), iinfo ) - kb = n - k + 1 + call stdlib${ii}$_chetf2( 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 @@ -36782,12 +36784,12 @@ module stdlib_linalg_lapack_c go to 20 end if 40 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_chetrf + end subroutine stdlib${ii}$_chetrf - pure subroutine stdlib_chetrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) + pure subroutine stdlib${ii}$_chetrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) !! CHETRF_RK computes the factorization of a complex Hermitian matrix A !! using the bounded Bunch-Kaufman (rook) diagonal pivoting method: !! A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T), @@ -36802,60 +36804,60 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(inout) :: a(lda,*) complex(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_clahef_rk( uplo, k, nb, kb, a, lda, e,ipiv, work, ldwork, iinfo ) + call stdlib${ii}$_clahef_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_chetf2_rk( uplo, k, a, lda, e, ipiv, iinfo ) + call stdlib${ii}$_chetf2_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 ! read ipiv from the last block factored, i.e. @@ -36885,7 +36887,7 @@ module stdlib_linalg_lapack_c do i = k, ( k - kb + 1 ), -1 ip = abs( ipiv( i ) ) if( ip/=i ) then - call stdlib_cswap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda ) + call stdlib${ii}$_cswap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda ) end if end do end if @@ -36898,31 +36900,31 @@ module stdlib_linalg_lapack_c 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_clahef_rk; + ! kb, where kb is the number of columns factorized by stdlib${ii}$_clahef_rk; ! 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 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_clahef_rk( uplo, n-k+1, nb, kb, a( k, k ), lda, e( k ),ipiv( k ), & + call stdlib${ii}$_clahef_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_chetf2_rk( uplo, n-k+1, a( k, k ), lda, e( k ),ipiv( k ), iinfo ) + call stdlib${ii}$_chetf2_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 @@ -36932,11 +36934,11 @@ module stdlib_linalg_lapack_c ! (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 + if( k>1_${ik}$ ) then do i = k, ( k + kb - 1 ), 1 ip = abs( ipiv( i ) ) if( ip/=i ) then - call stdlib_cswap( k-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_cswap( k-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda ) end if end do end if @@ -36948,12 +36950,12 @@ module stdlib_linalg_lapack_c 35 continue ! end lower end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_chetrf_rk + end subroutine stdlib${ii}$_chetrf_rk - pure subroutine stdlib_chetrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) + pure subroutine stdlib${ii}$_chetrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) !! CHETRF_ROOK computes the factorization of a complex Hermitian matrix A !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. !! The form of the factorization is @@ -36967,60 +36969,60 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(inout) :: a(lda,*) complex(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_clahef_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo ) + call stdlib${ii}$_clahef_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo ) else ! use unblocked code to factorize columns 1:k of a - call stdlib_chetf2_rook( uplo, k, a, lda, ipiv, iinfo ) + call stdlib${ii}$_chetf2_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 @@ -37045,30 +37047,30 @@ module stdlib_linalg_lapack_c 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_clahef_rook; + ! kb, where kb is the number of columns factorized by stdlib${ii}$_clahef_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_clahef_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, & + call stdlib${ii}$_clahef_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_chetf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo ) - kb = n - k + 1 + call stdlib${ii}$_chetf2_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 @@ -37076,12 +37078,12 @@ module stdlib_linalg_lapack_c go to 20 end if 40 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_chetrf_rook + end subroutine stdlib${ii}$_chetrf_rook - pure subroutine stdlib_chetrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info ) + pure subroutine stdlib${ii}$_chetrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info ) !! CHETRS solves a system of linear equations A*X = B with a complex !! Hermitian matrix A using the factorization A = U*D*U**H or !! A = L*D*L**H computed by CHETRF. @@ -37090,37 +37092,37 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(in) :: a(lda,*) complex(sp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: j, k, kp + integer(${ik}$) :: j, k, kp real(sp) :: s complex(sp) :: ak, akm1, akm1k, bk, bkm1, denom ! Intrinsic Functions intrinsic :: conjg,max,real ! 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_cgeru( k-1, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & + call stdlib${ii}$_cgeru( k-1, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb & ) ! multiply by the inverse of the diagonal block. s = real( cone,KIND=sp) / real( a( k, k ),KIND=sp) - call stdlib_csscal( nrhs, s, b( k, 1 ), ldb ) - k = k - 1 + call stdlib${ii}$_csscal( nrhs, s, b( k, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( kp/=k-1 )call stdlib_cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib${ii}$_cswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - call stdlib_cgeru( k-2, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & + call stdlib${ii}$_cgeru( k-2, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb & ) - call stdlib_cgeru( k-2, nrhs, -cone, a( 1, k-1 ), 1, b( k-1, 1 ),ldb, b( 1, 1 ), & + call stdlib${ii}$_cgeru( k-2, nrhs, -cone, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), & ldb ) ! multiply by the inverse of the diagonal block. akm1k = a( k-1, k ) @@ -37169,49 +37171,49 @@ module stdlib_linalg_lapack_c 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**h *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 = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(u**h(k)), where u(k) is the transformation ! stored in column k of a. - if( k>1 ) then - call stdlib_clacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_cgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), & - 1, cone, b( k, 1 ), ldb ) - call stdlib_clacgv( nrhs, b( k, 1 ), ldb ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), & + 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb ) end if ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 1 + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 1_${ik}$ else ! 2 x 2 diagonal block ! multiply by inv(u**h(k+1)), where u(k+1) is the transformation ! stored in columns k and k+1 of a. - if( k>1 ) then - call stdlib_clacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_cgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), & - 1, cone, b( k, 1 ), ldb ) - call stdlib_clacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_clacgv( nrhs, b( k+1, 1 ), ldb ) - call stdlib_cgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k+1 )& - , 1, cone, b( k+1, 1 ), ldb ) - call stdlib_clacgv( nrhs, b( k+1, 1 ), ldb ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), & + 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_clacgv( nrhs, b( k+1, 1_${ik}$ ), ldb ) + call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k+1 )& + , 1_${ik}$, cone, b( k+1, 1_${ik}$ ), ldb ) + call stdlib${ii}$_clacgv( nrhs, b( k+1, 1_${ik}$ ), ldb ) end if ! interchange rows k and -ipiv(k). kp = -ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 2 + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 2_${ik}$ end if go to 40 50 continue @@ -37220,35 +37222,35 @@ module stdlib_linalg_lapack_c ! 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 = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(l**h(k)), where l(k) is the transformation ! stored in column k of a. if( k= 1 ) - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k-1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( kp==-ipiv( k-1 ) )call stdlib_cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb & + if( kp==-ipiv( k-1 ) )call stdlib${ii}$_cswap( 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_ctrsm('L','U','N','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib${ii}$_ctrsm('L','U','N','U',n,nrhs,cone,a,lda,b,ldb) ! compute d \ b -> b [ d \ (u \p**t * b) ] i=n do while ( i >= 1 ) - if( ipiv(i) > 0 ) then + if( ipiv(i) > 0_${ik}$ ) then s = real( cone,KIND=sp) / real( a( i, i ),KIND=sp) - call stdlib_csscal( nrhs, s, b( i, 1 ), ldb ) - elseif ( i > 1) then + call stdlib${ii}$_csscal( nrhs, s, 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 @@ -37398,59 +37400,59 @@ module stdlib_linalg_lapack_c 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**h \ b) -> b [ u**h \ (d \ (u \p**t * b) ) ] - call stdlib_ctrsm('L','U','C','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib${ii}$_ctrsm('L','U','C','U',n,nrhs,cone,a,lda,b,ldb) ! p * b [ p * (u**h \ (d \ (u \p**t * b) )) ] - k=1 + k=1_${ik}$ do while ( k <= n ) - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k+1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( k < n .and. kp==-ipiv( k+1 ) )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp,& - 1 ), ldb ) + if( k < n .and. kp==-ipiv( k+1 ) )call stdlib${ii}$_cswap( 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**h. ! p**t * b - k=1 + k=1_${ik}$ do while ( k <= n ) - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k+1 else ! 2 x 2 diagonal block ! interchange rows k and -ipiv(k+1). kp = -ipiv( k+1 ) - if( kp==-ipiv( k ) )call stdlib_cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp==-ipiv( k ) )call stdlib${ii}$_cswap( 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_ctrsm('L','L','N','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib${ii}$_ctrsm('L','L','N','U',n,nrhs,cone,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 + if( ipiv(i) > 0_${ik}$ ) then s = real( cone,KIND=sp) / real( a( i, i ),KIND=sp) - call stdlib_csscal( nrhs, s, b( i, 1 ), ldb ) + call stdlib${ii}$_csscal( nrhs, s, b( i, 1_${ik}$ ), ldb ) else akm1k = work(i) akm1 = a( i, i ) / conjg( akm1k ) @@ -37462,38 +37464,38 @@ module stdlib_linalg_lapack_c 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**h \ b) -> b [ l**h \ (d \ (l \p**t * b) ) ] - call stdlib_ctrsm('L','L','C','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib${ii}$_ctrsm('L','L','C','U',n,nrhs,cone,a,lda,b,ldb) ! p * b [ p * (l**h \ (d \ (l \p**t * b) )) ] k=n do while ( k >= 1 ) - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k-1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( k>1 .and. kp==-ipiv( k-1 ) )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, & - 1 ), ldb ) + if( k>1_${ik}$ .and. kp==-ipiv( k-1 ) )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, & + 1_${ik}$ ), ldb ) k=k-2 endif end do end if ! revert a - call stdlib_csyconv( uplo, 'R', n, a, lda, ipiv, work, iinfo ) + call stdlib${ii}$_csyconv( uplo, 'R', n, a, lda, ipiv, work, iinfo ) return - end subroutine stdlib_chetrs2 + end subroutine stdlib${ii}$_chetrs2 - pure subroutine stdlib_chetrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) + pure subroutine stdlib${ii}$_chetrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) !! CHETRS_AA solves a system of linear equations A*X = B with a complex !! hermitian matrix A using the factorization A = U**H*T*U or !! A = L*T*L**H computed by CHETRF_AA. @@ -37503,42 +37505,42 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(in) :: a(lda,*) complex(sp), intent(inout) :: b(ldb,*) complex(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 + 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_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 1 + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 1_${ik}$ end do ! compute u**h \ b -> b [ (u**h \p**t * b) ] - call stdlib_ctrsm( 'L', 'U', 'C', 'U', n-1, nrhs, cone, a( 1, 2 ),lda, b( 2, 1 ),& + call stdlib${ii}$_ctrsm( 'L', 'U', 'C', 'U', n-1, nrhs, cone, a( 1_${ik}$, 2_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),& ldb) end if ! 2) solve with triangular matrix t ! compute t \ b -> b [ t \ (u**h \p**t * b) ] - call stdlib_clacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1) - if( n>1 ) then - call stdlib_clacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 2*n ), 1) - call stdlib_clacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 1 ), 1) - call stdlib_clacgv( n-1, work( 1 ), 1 ) + call stdlib${ii}$_clacpy( 'F', 1_${ik}$, n, a(1_${ik}$, 1_${ik}$), lda+1, work(n), 1_${ik}$) + if( n>1_${ik}$ ) then + call stdlib${ii}$_clacpy( 'F', 1_${ik}$, n-1, a( 1_${ik}$, 2_${ik}$ ), lda+1, work( 2_${ik}$*n ), 1_${ik}$) + call stdlib${ii}$_clacpy( 'F', 1_${ik}$, n-1, a( 1_${ik}$, 2_${ik}$ ), lda+1, work( 1_${ik}$ ), 1_${ik}$) + call stdlib${ii}$_clacgv( n-1, work( 1_${ik}$ ), 1_${ik}$ ) end if - call stdlib_cgtsv(n, nrhs, work(1), work(n), work(2*n), b, ldb,info) + call stdlib${ii}$_cgtsv(n, nrhs, work(1_${ik}$), work(n), work(2_${ik}$*n), b, ldb,info) ! 3) backward substitution with u - if( n>1 ) then + if( n>1_${ik}$ ) then ! compute u \ b -> b [ u \ (t \ (u**h \p**t * b) ) ] - call stdlib_ctrsm( 'L', 'U', 'N', 'U', n-1, nrhs, cone, a( 1, 2 ),lda, b(2, 1), & + call stdlib${ii}$_ctrsm( 'L', 'U', 'N', 'U', n-1, nrhs, cone, a( 1_${ik}$, 2_${ik}$ ),lda, b(2_${ik}$, 1_${ik}$), & ldb) ! pivot, p * b -> b [ p * (u \ (t \ (u**h \p**t * b) )) ] k = n do while ( k>=1 ) kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k - 1 + if( kp/=k )call stdlib${ii}$_cswap( 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**h. ! 1) forward substitution with l - if( n>1 ) then + 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_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 1 + if( kp/=k )call stdlib${ii}$_cswap( 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_ctrsm( 'L', 'L', 'N', 'U', n-1, nrhs, cone, a( 2, 1),lda, b(2, 1), & + call stdlib${ii}$_ctrsm( 'L', 'L', 'N', 'U', n-1, nrhs, cone, a( 2_${ik}$, 1_${ik}$),lda, b(2_${ik}$, 1_${ik}$), & ldb ) end if ! 2) solve with triangular matrix t ! compute t \ b -> b [ t \ (l \p**t * b) ] - call stdlib_clacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1) - if( n>1 ) then - call stdlib_clacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 1 ), 1 ) - call stdlib_clacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 2*n ), 1) - call stdlib_clacgv( n-1, work( 2*n ), 1 ) + call stdlib${ii}$_clacpy( 'F', 1_${ik}$, n, a(1_${ik}$, 1_${ik}$), lda+1, work(n), 1_${ik}$) + if( n>1_${ik}$ ) then + call stdlib${ii}$_clacpy( 'F', 1_${ik}$, n-1, a( 2_${ik}$, 1_${ik}$ ), lda+1, work( 1_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_clacpy( 'F', 1_${ik}$, n-1, a( 2_${ik}$, 1_${ik}$ ), lda+1, work( 2_${ik}$*n ), 1_${ik}$) + call stdlib${ii}$_clacgv( n-1, work( 2_${ik}$*n ), 1_${ik}$ ) end if - call stdlib_cgtsv(n, nrhs, work(1), work(n), work(2*n), b, ldb,info) + call stdlib${ii}$_cgtsv(n, nrhs, work(1_${ik}$), work(n), work(2_${ik}$*n), b, ldb,info) ! 3) backward substitution with l**h - if( n>1 ) then + if( n>1_${ik}$ ) then ! compute (l**h \ b) -> b [ l**h \ (t \ (l \p**t * b) ) ] - call stdlib_ctrsm( 'L', 'L', 'C', 'U', n-1, nrhs, cone, a( 2, 1 ),lda, b( 2, 1 ),& + call stdlib${ii}$_ctrsm( 'L', 'L', 'C', 'U', n-1, nrhs, cone, a( 2_${ik}$, 1_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),& ldb ) ! pivot, p * b -> b [ p * (l**h \ (t \ (l \p**t * b) )) ] k = n do while ( k>=1 ) kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k - 1 + if( kp/=k )call stdlib${ii}$_cswap( 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_chetrs_aa + end subroutine stdlib${ii}$_chetrs_aa - pure subroutine stdlib_chetrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) + pure subroutine stdlib${ii}$_chetrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) !! CHETRS_ROOK solves a system of linear equations A*X = B with a complex !! Hermitian matrix A using the factorization A = U*D*U**H or !! A = L*D*L**H computed by CHETRF_ROOK. @@ -37631,37 +37633,37 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(in) :: a(lda,*) complex(sp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: j, k, kp + integer(${ik}$) :: j, k, kp real(sp) :: s complex(sp) :: ak, akm1, akm1k, bk, bkm1, denom ! Intrinsic Functions intrinsic :: conjg,max,real ! 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_cgeru( k-1, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & + call stdlib${ii}$_cgeru( k-1, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb & ) ! multiply by the inverse of the diagonal block. s = real( cone,KIND=sp) / real( a( k, k ),KIND=sp) - call stdlib_csscal( nrhs, s, b( k, 1 ), ldb ) - k = k - 1 + call stdlib${ii}$_csscal( nrhs, s, b( k, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ else ! 2 x 2 diagonal block ! interchange rows k and -ipiv(k), then k-1 and -ipiv(k-1) kp = -ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) kp = -ipiv( k-1) - if( kp/=k-1 )call stdlib_cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib${ii}$_cswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - call stdlib_cgeru( k-2, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & + call stdlib${ii}$_cgeru( k-2, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb & ) - call stdlib_cgeru( k-2, nrhs, -cone, a( 1, k-1 ), 1, b( k-1, 1 ),ldb, b( 1, 1 ), & + call stdlib${ii}$_cgeru( k-2, nrhs, -cone, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), & ldb ) ! multiply by the inverse of the diagonal block. akm1k = a( k-1, k ) @@ -37712,51 +37714,51 @@ module stdlib_linalg_lapack_c 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**h *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 = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(u**h(k)), where u(k) is the transformation ! stored in column k of a. - if( k>1 ) then - call stdlib_clacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_cgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), & - 1, cone, b( k, 1 ), ldb ) - call stdlib_clacgv( nrhs, b( k, 1 ), ldb ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), & + 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb ) end if ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 1 + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 1_${ik}$ else ! 2 x 2 diagonal block ! multiply by inv(u**h(k+1)), where u(k+1) is the transformation ! stored in columns k and k+1 of a. - if( k>1 ) then - call stdlib_clacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_cgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), & - 1, cone, b( k, 1 ), ldb ) - call stdlib_clacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_clacgv( nrhs, b( k+1, 1 ), ldb ) - call stdlib_cgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k+1 )& - , 1, cone, b( k+1, 1 ), ldb ) - call stdlib_clacgv( nrhs, b( k+1, 1 ), ldb ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), & + 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_clacgv( nrhs, b( k+1, 1_${ik}$ ), ldb ) + call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k+1 )& + , 1_${ik}$, cone, b( k+1, 1_${ik}$ ), ldb ) + call stdlib${ii}$_clacgv( nrhs, 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_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) kp = -ipiv( k+1 ) - if( kp/=k+1 )call stdlib_cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 2 + if( kp/=k+1 )call stdlib${ii}$_cswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 2_${ik}$ end if go to 40 50 continue @@ -37765,37 +37767,37 @@ module stdlib_linalg_lapack_c ! 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 = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(l**h(k)), where l(k) is the transformation ! stored in column k of a. if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_cgeru( k-1, nrhs, -cone, ap( kc ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb ) + call stdlib${ii}$_cgeru( k-1, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb ) ! multiply by the inverse of the diagonal block. s = real( cone,KIND=sp) / real( ap( kc+k-1 ),KIND=sp) - call stdlib_csscal( nrhs, s, b( k, 1 ), ldb ) - k = k - 1 + call stdlib${ii}$_csscal( nrhs, s, b( k, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( kp/=k-1 )call stdlib_cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib${ii}$_cswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - call stdlib_cgeru( k-2, nrhs, -cone, ap( kc ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb ) + call stdlib${ii}$_cgeru( k-2, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb ) - call stdlib_cgeru( k-2, nrhs, -cone, ap( kc-( k-1 ) ), 1,b( k-1, 1 ), ldb, b( 1, & - 1 ), ldb ) + call stdlib${ii}$_cgeru( k-2, nrhs, -cone, ap( kc-( k-1 ) ), 1_${ik}$,b( k-1, 1_${ik}$ ), ldb, b( 1_${ik}$, & + 1_${ik}$ ), ldb ) ! multiply by the inverse of the diagonal block. akm1k = ap( kc+k-2 ) akm1 = ap( kc-1 ) / akm1k @@ -38053,53 +38055,53 @@ module stdlib_linalg_lapack_c 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**h *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 = 1_${ik}$ + kc = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(u**h(k)), where u(k) is the transformation ! stored in column k of a. - if( k>1 ) then - call stdlib_clacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_cgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc ), & - 1, cone, b( k, 1 ), ldb ) - call stdlib_clacgv( nrhs, b( k, 1 ), ldb ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc ), & + 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb ) end if ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( 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 ! multiply by inv(u**h(k+1)), where u(k+1) is the transformation ! stored in columns k and k+1 of a. - if( k>1 ) then - call stdlib_clacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_cgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc ), & - 1, cone, b( k, 1 ), ldb ) - call stdlib_clacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_clacgv( nrhs, b( k+1, 1 ), ldb ) - call stdlib_cgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc+k ),& - 1, cone, b( k+1, 1 ), ldb ) - call stdlib_clacgv( nrhs, b( k+1, 1 ), ldb ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc ), & + 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_clacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_clacgv( nrhs, b( k+1, 1_${ik}$ ), ldb ) + call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc+k ),& + 1_${ik}$, cone, b( k+1, 1_${ik}$ ), ldb ) + call stdlib${ii}$_clacgv( nrhs, b( k+1, 1_${ik}$ ), ldb ) end if ! interchange rows k and -ipiv(k). kp = -ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - kc = kc + 2*k + 1 - k = k + 2 + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + kc = kc + 2_${ik}$*k + 1_${ik}$ + k = k + 2_${ik}$ end if go to 40 50 continue @@ -38108,37 +38110,37 @@ module stdlib_linalg_lapack_c ! 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 = 1_${ik}$ + kc = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_cswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(l**h(k)), where l(k) is the transformation ! stored in column k of a. if( kn-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 ) - if ( ipiv( k )>0 ) then + if ( ipiv( k )>0_${ik}$ ) then ! 1x1 pivot kp = ipiv( k ) if ( kp /= k ) then @@ -38726,7 +38728,7 @@ module stdlib_linalg_lapack_c do i = 1, k work( k ) = max( cabs1( af( i, k ) ), work( k ) ) end do - k = k - 1 + k = k - 1_${ik}$ else ! 2x2 pivot kp = -ipiv( k ) @@ -38738,31 +38740,31 @@ module stdlib_linalg_lapack_c work( k-1 ) =max( cabs1( af( i, k-1 ) ), work( k-1 ) ) end do work( k ) = max( cabs1( 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 + if ( ipiv( k )>0_${ik}$ ) then ! 1x1 pivot kp = ipiv( k ) if ( kp /= k ) then @@ -38773,7 +38775,7 @@ module stdlib_linalg_lapack_c do i = k, n work( k ) = max( cabs1( af( i, k ) ), work( k ) ) end do - k = k + 1 + k = k + 1_${ik}$ else ! 2x2 pivot kp = -ipiv( k ) @@ -38785,25 +38787,25 @@ module stdlib_linalg_lapack_c work( k+1 ) =max( cabs1( af( i, k+1 ) ) , work( k+1 ) ) end do work(k) = max( cabs1( 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 @@ -38830,11 +38832,11 @@ module stdlib_linalg_lapack_c end if end do end if - stdlib_cla_herpvgrw = rpvgrw - end function stdlib_cla_herpvgrw + stdlib${ii}$_cla_herpvgrw = rpvgrw + end function stdlib${ii}$_cla_herpvgrw - real(sp) function stdlib_cla_porcond_c( uplo, n, a, lda, af, ldaf, c, capply,info, work, & + real(sp) function stdlib${ii}$_cla_porcond_c( uplo, n, a, lda, af, ldaf, c, capply,info, work, & !! CLA_PORCOND_C Computes the infinity norm condition number of !! op(A) * inv(diag(C)) where C is a REAL vector rwork ) @@ -38844,8 +38846,8 @@ module stdlib_linalg_lapack_c ! Scalar Arguments character, intent(in) :: uplo logical(lk), intent(in) :: capply - integer(ilp), intent(in) :: n, lda, ldaf - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n, lda, ldaf + integer(${ik}$), intent(out) :: info ! Array Arguments complex(sp), intent(in) :: a(lda,*), af(ldaf,*) complex(sp), intent(out) :: work(*) @@ -38853,13 +38855,13 @@ module stdlib_linalg_lapack_c real(sp), intent(out) :: rwork(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: kase + integer(${ik}$) :: kase real(sp) :: ainvnm, anorm, tmp - integer(ilp) :: i, j + integer(${ik}$) :: i, j logical(lk) :: up, upper complex(sp) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,real,aimag ! Statement Functions @@ -38867,20 +38869,20 @@ module stdlib_linalg_lapack_c ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) ) ! Executable Statements - stdlib_cla_porcond_c = zero - info = 0 + stdlib${ii}$_cla_porcond_c = zero + 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 ) - if ( ipiv( k )>0 ) then + if ( ipiv( k )>0_${ik}$ ) then ! 1x1 pivot kp = ipiv( k ) if ( kp /= k ) then @@ -39216,7 +39218,7 @@ module stdlib_linalg_lapack_c do i = 1, k work( k ) = max( cabs1( af( i, k ) ), work( k ) ) end do - k = k - 1 + k = k - 1_${ik}$ else ! 2x2 pivot kp = -ipiv( k ) @@ -39228,31 +39230,31 @@ module stdlib_linalg_lapack_c work( k-1 ) =max( cabs1( af( i, k-1 ) ), work( k-1 ) ) end do work( k ) = max( cabs1( 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 + if ( ipiv( k )>0_${ik}$ ) then ! 1x1 pivot kp = ipiv( k ) if ( kp /= k ) then @@ -39263,7 +39265,7 @@ module stdlib_linalg_lapack_c do i = k, n work( k ) = max( cabs1( af( i, k ) ), work( k ) ) end do - k = k + 1 + k = k + 1_${ik}$ else ! 2x2 pivot kp = -ipiv( k ) @@ -39275,25 +39277,25 @@ module stdlib_linalg_lapack_c work( k+1 ) =max( cabs1( af( i, k+1 ) ), work( k+1 ) ) end do work( k ) = max( cabs1( 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 @@ -39320,11 +39322,11 @@ module stdlib_linalg_lapack_c end if end do end if - stdlib_cla_syrpvgrw = rpvgrw - end function stdlib_cla_syrpvgrw + stdlib${ii}$_cla_syrpvgrw = rpvgrw + end function stdlib${ii}$_cla_syrpvgrw - pure subroutine stdlib_clabrd( m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y,ldy ) + pure subroutine stdlib${ii}$_clabrd( m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y,ldy ) !! CLABRD reduces the first NB rows and columns of a complex general !! m by n matrix A to upper or lower real bidiagonal form by a unitary !! transformation Q**H * A * P, and returns the matrices X and Y which @@ -39336,7 +39338,7 @@ module stdlib_linalg_lapack_c ! -- 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, ldx, ldy, m, n, nb + integer(${ik}$), intent(in) :: lda, ldx, ldy, m, n, nb ! Array Arguments real(sp), intent(out) :: d(*), e(*) complex(sp), intent(inout) :: a(lda,*) @@ -39344,7 +39346,7 @@ module stdlib_linalg_lapack_c ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i complex(sp) :: alpha ! Intrinsic Functions intrinsic :: min @@ -39355,126 +39357,126 @@ module stdlib_linalg_lapack_c ! reduce to upper bidiagonal form loop_10: do i = 1, nb ! update a(i:m,i) - call stdlib_clacgv( i-1, y( i, 1 ), ldy ) - call stdlib_cgemv( 'NO TRANSPOSE', m-i+1, i-1, -cone, a( i, 1 ),lda, y( i, 1 ), & - ldy, cone, a( i, i ), 1 ) - call stdlib_clacgv( i-1, y( i, 1 ), ldy ) - call stdlib_cgemv( 'NO TRANSPOSE', m-i+1, i-1, -cone, x( i, 1 ),ldx, a( 1, i ), & - 1, cone, a( i, i ), 1 ) + call stdlib${ii}$_clacgv( i-1, y( i, 1_${ik}$ ), ldy ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', m-i+1, i-1, -cone, a( i, 1_${ik}$ ),lda, y( i, 1_${ik}$ ), & + ldy, cone, a( i, i ), 1_${ik}$ ) + call stdlib${ii}$_clacgv( i-1, y( i, 1_${ik}$ ), ldy ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', m-i+1, i-1, -cone, x( i, 1_${ik}$ ),ldx, a( 1_${ik}$, i ), & + 1_${ik}$, cone, a( i, i ), 1_${ik}$ ) ! generate reflection q(i) to annihilate a(i+1:m,i) alpha = a( i, i ) - call stdlib_clarfg( m-i+1, alpha, a( min( i+1, m ), i ), 1,tauq( i ) ) + call stdlib${ii}$_clarfg( m-i+1, alpha, a( min( i+1, m ), i ), 1_${ik}$,tauq( i ) ) d( i ) = real( alpha,KIND=sp) if( i1 ) then ! info = -1 ! else if( n<0 ) then - if( n<0 ) then - info = -1 - else if( min( 1, n )>cutpnt .or. ncutpnt .or. n=growto*scale )go to 120 ! choose new orthogonal starting vector and try again. rtemp = eps3 / ( rootn+one ) - v( 1 ) = eps3 + v( 1_${ik}$ ) = eps3 do i = 2, n v( i ) = rtemp end do v( n-its+1 ) = v( n-its+1 ) - eps3*rootn end do ! failure to find eigenvector in n iterations. - info = 1 + info = 1_${ik}$ 120 continue ! normalize eigenvector. - i = stdlib_icamax( n, v, 1 ) - call stdlib_csscal( n, one / cabs1( v( i ) ), v, 1 ) + i = stdlib${ii}$_icamax( n, v, 1_${ik}$ ) + call stdlib${ii}$_csscal( n, one / cabs1( v( i ) ), v, 1_${ik}$ ) return - end subroutine stdlib_claein + end subroutine stdlib${ii}$_claein - pure subroutine stdlib_clags2( upper, a1, a2, a3, b1, b2, b3, csu, snu, csv,snv, csq, snq ) + pure subroutine stdlib${ii}$_clags2( upper, a1, a2, a3, b1, b2, b3, csu, snu, csv,snv, csq, snq ) !! CLAGS2 computes 2-by-2 unitary matrices U, V and Q, such !! that if ( UPPER ) then !! U**H *A*Q = U**H *( A1 A2 )*Q = ( x 0 ) @@ -39808,7 +39810,7 @@ module stdlib_linalg_lapack_c ! 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, fb, d, s1, s2, snr, csr, snl, csl ) + call stdlib${ii}$_slasv2( a, fb, d, s1, s2, snr, csr, snl, csl ) if( abs( csl )>=abs( snl ) .or. abs( csr )>=abs( snr ) )then ! compute the (1,1) and (1,2) elements of u**h *a and v**h *b, ! and (1,2) element of |u|**h *|a| and |v|**h *|b|. @@ -39820,17 +39822,17 @@ module stdlib_linalg_lapack_c avb12 = abs( csr )*abs1( b2 ) + abs( snr )*abs( b3 ) ! zero (1,2) elements of u**h *a and v**h *b if( ( abs( ua11r )+abs1( ua12 ) )==zero ) then - call stdlib_clartg( -cmplx( vb11r,KIND=sp), conjg( vb12 ), csq, snq,r ) + call stdlib${ii}$_clartg( -cmplx( vb11r,KIND=sp), conjg( vb12 ), csq, snq,r ) else if( ( abs( vb11r )+abs1( vb12 ) )==zero ) then - call stdlib_clartg( -cmplx( ua11r,KIND=sp), conjg( ua12 ), csq, snq,r ) + call stdlib${ii}$_clartg( -cmplx( ua11r,KIND=sp), conjg( ua12 ), csq, snq,r ) else if( aua12 / ( abs( ua11r )+abs1( ua12 ) )<=avb12 /( abs( vb11r )+abs1( vb12 & ) ) ) then - call stdlib_clartg( -cmplx( ua11r,KIND=sp), conjg( ua12 ), csq, snq,r ) + call stdlib${ii}$_clartg( -cmplx( ua11r,KIND=sp), conjg( ua12 ), csq, snq,r ) else - call stdlib_clartg( -cmplx( vb11r,KIND=sp), conjg( vb12 ), csq, snq,r ) + call stdlib${ii}$_clartg( -cmplx( vb11r,KIND=sp), conjg( vb12 ), csq, snq,r ) end if csu = csl @@ -39848,14 +39850,14 @@ module stdlib_linalg_lapack_c avb22 = abs( snr )*abs1( b2 ) + abs( csr )*abs( b3 ) ! zero (2,2) elements of u**h *a and v**h *b, and then swap. if( ( abs1( ua21 )+abs1( ua22 ) )==zero ) then - call stdlib_clartg( -conjg( vb21 ), conjg( vb22 ), csq, snq, r ) + call stdlib${ii}$_clartg( -conjg( vb21 ), conjg( vb22 ), csq, snq, r ) else if( ( abs1( vb21 )+abs( vb22 ) )==zero ) then - call stdlib_clartg( -conjg( ua21 ), conjg( ua22 ), csq, snq, r ) + call stdlib${ii}$_clartg( -conjg( ua21 ), conjg( ua22 ), csq, snq, r ) else if( aua22 / ( abs1( ua21 )+abs1( ua22 ) )<=avb22 /( abs1( vb21 )+abs1( vb22 & ) ) ) then - call stdlib_clartg( -conjg( ua21 ), conjg( ua22 ), csq, snq, r ) + call stdlib${ii}$_clartg( -conjg( ua21 ), conjg( ua22 ), csq, snq, r ) else - call stdlib_clartg( -conjg( vb21 ), conjg( vb22 ), csq, snq, r ) + call stdlib${ii}$_clartg( -conjg( vb21 ), conjg( vb22 ), csq, snq, r ) end if csu = snl snu = d1*csl @@ -39877,7 +39879,7 @@ module stdlib_linalg_lapack_c ! 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, fc, d, s1, s2, snr, csr, snl, csl ) + call stdlib${ii}$_slasv2( a, fc, d, s1, s2, snr, csr, snl, csl ) if( abs( csr )>=abs( snr ) .or. abs( csl )>=abs( snl ) )then ! compute the (2,1) and (2,2) elements of u**h *a and v**h *b, ! and (2,1) element of |u|**h *|a| and |v|**h *|b|. @@ -39889,14 +39891,14 @@ module stdlib_linalg_lapack_c avb21 = abs( snl )*abs( b1 ) + abs( csl )*abs1( b2 ) ! zero (2,1) elements of u**h *a and v**h *b. if( ( abs1( ua21 )+abs( ua22r ) )==zero ) then - call stdlib_clartg( cmplx( vb22r,KIND=sp), vb21, csq, snq, r ) + call stdlib${ii}$_clartg( cmplx( vb22r,KIND=sp), vb21, csq, snq, r ) else if( ( abs1( vb21 )+abs( vb22r ) )==zero ) then - call stdlib_clartg( cmplx( ua22r,KIND=sp), ua21, csq, snq, r ) + call stdlib${ii}$_clartg( cmplx( ua22r,KIND=sp), ua21, csq, snq, r ) else if( aua21 / ( abs1( ua21 )+abs( ua22r ) )<=avb21 /( abs1( vb21 )+abs( vb22r & ) ) ) then - call stdlib_clartg( cmplx( ua22r,KIND=sp), ua21, csq, snq, r ) + call stdlib${ii}$_clartg( cmplx( ua22r,KIND=sp), ua21, csq, snq, r ) else - call stdlib_clartg( cmplx( vb22r,KIND=sp), vb21, csq, snq, r ) + call stdlib${ii}$_clartg( cmplx( vb22r,KIND=sp), vb21, csq, snq, r ) end if csu = csr snu = -conjg( d1 )*snr @@ -39913,14 +39915,14 @@ module stdlib_linalg_lapack_c avb11 = abs( csl )*abs( b1 ) + abs( snl )*abs1( b2 ) ! zero (1,1) elements of u**h *a and v**h *b, and then swap. if( ( abs1( ua11 )+abs1( ua12 ) )==zero ) then - call stdlib_clartg( vb12, vb11, csq, snq, r ) + call stdlib${ii}$_clartg( vb12, vb11, csq, snq, r ) else if( ( abs1( vb11 )+abs1( vb12 ) )==zero ) then - call stdlib_clartg( ua12, ua11, csq, snq, r ) + call stdlib${ii}$_clartg( ua12, ua11, csq, snq, r ) else if( aua11 / ( abs1( ua11 )+abs1( ua12 ) )<=avb11 /( abs1( vb11 )+abs1( vb12 & ) ) ) then - call stdlib_clartg( ua12, ua11, csq, snq, r ) + call stdlib${ii}$_clartg( ua12, ua11, csq, snq, r ) else - call stdlib_clartg( vb12, vb11, csq, snq, r ) + call stdlib${ii}$_clartg( vb12, vb11, csq, snq, r ) end if csu = snr snu = conjg( d1 )*csr @@ -39929,10 +39931,10 @@ module stdlib_linalg_lapack_c end if end if return - end subroutine stdlib_clags2 + end subroutine stdlib${ii}$_clags2 - pure subroutine stdlib_clahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, info & + pure subroutine stdlib${ii}$_clahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, info & !! CLAHQR is an auxiliary routine called by CHSEQR to update the !! eigenvalues and Schur decomposition already computed by CHSEQR, by !! dealing with the Hessenberg submatrix in rows and columns ILO to @@ -39942,8 +39944,8 @@ module stdlib_linalg_lapack_c ! -- 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, ihiz, ilo, iloz, ldh, ldz, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ihiz, ilo, iloz, ldh, ldz, n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt, wantz ! Array Arguments complex(sp), intent(inout) :: h(ldh,*), z(ldz,*) @@ -39953,7 +39955,7 @@ module stdlib_linalg_lapack_c real(sp), parameter :: rzero = 0.0_sp real(sp), parameter :: rone = 1.0_sp real(sp), parameter :: dat1 = 3.0_sp/4.0_sp - integer(ilp), parameter :: kexsh = 10 + integer(${ik}$), parameter :: kexsh = 10_${ik}$ @@ -39962,9 +39964,9 @@ module stdlib_linalg_lapack_c complex(sp) :: cdum, h11, h11s, h22, sc, sum, t, t1, temp, u, v2, x, y real(sp) :: aa, ab, ba, bb, h10, h21, rtemp, s, safmax, safmin, smlnum, sx, t2, tst, & ulp - integer(ilp) :: i, i1, i2, its, itmax, j, jhi, jlo, k, l, m, nh, nz, kdefl + integer(${ik}$) :: i, i1, i2, its, itmax, j, jhi, jlo, k, l, m, nh, nz, kdefl ! Local Arrays - complex(sp) :: v(2) + complex(sp) :: v(2_${ik}$) ! Statement Functions real(sp) :: cabs1 ! Intrinsic Functions @@ -39972,7 +39974,7 @@ module stdlib_linalg_lapack_c ! Statement Function Definitions cabs1( cdum ) = abs( real( cdum,KIND=sp) ) + abs( aimag( cdum ) ) ! Executable Statements - info = 0 + info = 0_${ik}$ ! quick return if possible if( n==0 )return if( ilo==ihi ) then @@ -39987,7 +39989,7 @@ module stdlib_linalg_lapack_c if( ilo<=ihi-2 )h( ihi, ihi-2 ) = czero ! ==== ensure that subdiagonal entries are real ==== if( wantt ) then - jlo = 1 + jlo = 1_${ik}$ jhi = n else jlo = ilo @@ -40001,30 +40003,30 @@ module stdlib_linalg_lapack_c sc = h( i, i-1 ) / cabs1( h( i, i-1 ) ) sc = conjg( sc ) / abs( sc ) h( i, i-1 ) = abs( h( i, i-1 ) ) - call stdlib_cscal( jhi-i+1, sc, h( i, i ), ldh ) - call stdlib_cscal( min( jhi, i+1 )-jlo+1, conjg( sc ), h( jlo, i ),1 ) - if( wantz )call stdlib_cscal( ihiz-iloz+1, conjg( sc ), z( iloz, i ), 1 ) + call stdlib${ii}$_cscal( jhi-i+1, sc, h( i, i ), ldh ) + call stdlib${ii}$_cscal( min( jhi, i+1 )-jlo+1, conjg( sc ), h( jlo, i ),1_${ik}$ ) + if( wantz )call stdlib${ii}$_cscal( ihiz-iloz+1, conjg( sc ), z( iloz, i ), 1_${ik}$ ) end if end do - nh = ihi - ilo + 1 - nz = ihiz - iloz + 1 + nh = ihi - ilo + 1_${ik}$ + nz = ihiz - iloz + 1_${ik}$ ! set machine-dependent constants for the stopping criterion. - safmin = stdlib_slamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) safmax = rone / safmin - call stdlib_slabad( safmin, safmax ) - ulp = stdlib_slamch( 'PRECISION' ) + call stdlib${ii}$_slabad( safmin, safmax ) + ulp = stdlib${ii}$_slamch( 'PRECISION' ) smlnum = safmin*( real( nh,KIND=sp) / ulp ) ! i1 and i2 are the indices of the first row and last column of h ! to which transformations must be applied. if eigenvalues only are ! being computed, i1 and i2 are set inside the main loop. if( wantt ) then - i1 = 1 + i1 = 1_${ik}$ i2 = n end if ! itmax is the total number of qr iterations allowed. - itmax = 30 * max( 10, nh ) + itmax = 30_${ik}$ * max( 10_${ik}$, nh ) ! kdefl counts the number of iterations since a deflation - kdefl = 0 + kdefl = 0_${ik}$ ! the main loop begins here. i is the loop index and decreases from ! ihi to ilo in steps of 1. each iteration of the loop works ! with the active submatrix in rows and columns l to i. @@ -40067,7 +40069,7 @@ module stdlib_linalg_lapack_c end if ! exit from loop if a submatrix of order 1 has split off. if( l>=i )go to 140 - kdefl = kdefl + 1 + kdefl = kdefl + 1_${ik}$ ! now the active submatrix is in rows and columns l to i. if ! eigenvalues only are being computed, only the active submatrix ! need be transformed. @@ -40075,11 +40077,11 @@ module stdlib_linalg_lapack_c i1 = l i2 = i end if - if( mod(kdefl,2*kexsh)==0 ) then + if( mod(kdefl,2_${ik}$*kexsh)==0_${ik}$ ) then ! exceptional shift. s = dat1*abs( real( h( i, i-1 ),KIND=sp) ) t = s + h( i, i ) - else if( mod(kdefl,kexsh)==0 ) then + else if( mod(kdefl,kexsh)==0_${ik}$ ) then ! exceptional shift. s = dat1*abs( real( h( l+1, l ),KIND=sp) ) t = s + h( l, l ) @@ -40092,12 +40094,12 @@ module stdlib_linalg_lapack_c x = half*( h( i-1, i-1 )-t ) sx = cabs1( x ) s = max( s, cabs1( x ) ) - y = s*sqrt( ( x / s )**2+( u / s )**2 ) + y = s*sqrt( ( x / s )**2_${ik}$+( u / s )**2_${ik}$ ) if( sx>rzero ) then if( real( x / sx,KIND=sp)*real( y,KIND=sp)+aimag( x / sx )*aimag( y )& m )call stdlib_ccopy( 2, h( k, k-1 ), 1, v, 1 ) - call stdlib_clarfg( 2, v( 1 ), v( 2 ), 1, t1 ) + if( k>m )call stdlib${ii}$_ccopy( 2_${ik}$, h( k, k-1 ), 1_${ik}$, v, 1_${ik}$ ) + call stdlib${ii}$_clarfg( 2_${ik}$, v( 1_${ik}$ ), v( 2_${ik}$ ), 1_${ik}$, t1 ) if( k>m ) then - h( k, k-1 ) = v( 1 ) + h( k, k-1 ) = v( 1_${ik}$ ) h( k+1, k-1 ) = czero end if - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = real( t1*v2,KIND=sp) ! apply g from the left to transform the rows of the matrix ! in columns k to i2. @@ -40180,10 +40182,10 @@ module stdlib_linalg_lapack_c if( m+2<=i )h( m+2, m+1 ) = h( m+2, m+1 )*temp do j = m, i if( j/=m+1 ) then - if( i2>j )call stdlib_cscal( i2-j, temp, h( j, j+1 ), ldh ) - call stdlib_cscal( j-i1, conjg( temp ), h( i1, j ), 1 ) + if( i2>j )call stdlib${ii}$_cscal( i2-j, temp, h( j, j+1 ), ldh ) + call stdlib${ii}$_cscal( j-i1, conjg( temp ), h( i1, j ), 1_${ik}$ ) if( wantz ) then - call stdlib_cscal( nz, conjg( temp ), z( iloz, j ), 1 ) + call stdlib${ii}$_cscal( nz, conjg( temp ), z( iloz, j ), 1_${ik}$ ) end if end if end do @@ -40195,10 +40197,10 @@ module stdlib_linalg_lapack_c rtemp = abs( temp ) h( i, i-1 ) = rtemp temp = temp / rtemp - if( i2>i )call stdlib_cscal( i2-i, conjg( temp ), h( i, i+1 ), ldh ) - call stdlib_cscal( i-i1, temp, h( i1, i ), 1 ) + if( i2>i )call stdlib${ii}$_cscal( i2-i, conjg( temp ), h( i, i+1 ), ldh ) + call stdlib${ii}$_cscal( i-i1, temp, h( i1, i ), 1_${ik}$ ) if( wantz ) then - call stdlib_cscal( nz, temp, z( iloz, i ), 1 ) + call stdlib${ii}$_cscal( nz, temp, z( iloz, i ), 1_${ik}$ ) end if end if end do loop_130 @@ -40209,16 +40211,16 @@ module stdlib_linalg_lapack_c ! h(i,i-1) is negligible: cone eigenvalue has converged. w( i ) = h( i, i ) ! reset deflation counter - kdefl = 0 + kdefl = 0_${ik}$ ! return to start of the main loop with new value of i. - i = l - 1 + i = l - 1_${ik}$ go to 30 150 continue return - end subroutine stdlib_clahqr + end subroutine stdlib${ii}$_clahqr - pure subroutine stdlib_clahr2( n, k, nb, a, lda, tau, t, ldt, y, ldy ) + pure subroutine stdlib${ii}$_clahr2( n, k, nb, a, lda, tau, t, ldt, y, ldy ) !! CLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1) !! matrix A so that elements below the k-th subdiagonal are zero. The !! reduction is performed by an unitary similarity transformation @@ -40229,14 +40231,14 @@ module stdlib_linalg_lapack_c ! -- 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) :: k, lda, ldt, ldy, n, nb + integer(${ik}$), intent(in) :: k, lda, ldt, ldy, n, nb ! Array Arguments complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: t(ldt,nb), tau(nb), y(ldy,nb) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i complex(sp) :: ei ! Intrinsic Functions intrinsic :: min @@ -40244,71 +40246,71 @@ module stdlib_linalg_lapack_c ! quick return if possible if( n<=1 )return loop_10: do i = 1, nb - if( i>1 ) then + if( i>1_${ik}$ ) then ! update a(k+1:n,i) ! update i-th column of a - y * v**h - call stdlib_clacgv( i-1, a( k+i-1, 1 ), lda ) - call stdlib_cgemv( 'NO TRANSPOSE', n-k, i-1, -cone, y(k+1,1), ldy,a( k+i-1, 1 ), & - lda, cone, a( k+1, i ), 1 ) - call stdlib_clacgv( i-1, a( k+i-1, 1 ), lda ) + call stdlib${ii}$_clacgv( i-1, a( k+i-1, 1_${ik}$ ), lda ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-k, i-1, -cone, y(k+1,1_${ik}$), ldy,a( k+i-1, 1_${ik}$ ), & + lda, cone, a( k+1, i ), 1_${ik}$ ) + call stdlib${ii}$_clacgv( i-1, a( k+i-1, 1_${ik}$ ), lda ) ! apply i - v * t**h * v**h to this column (call it b) from the ! left, using the last column of t as workspace ! let v = ( v1 ) and b = ( b1 ) (first i-1 rows) ! ( v2 ) ( b2 ) ! where v1 is unit lower triangular ! w := v1**h * b1 - call stdlib_ccopy( i-1, a( k+1, i ), 1, t( 1, nb ), 1 ) - call stdlib_ctrmv( 'LOWER', 'CONJUGATE TRANSPOSE', 'UNIT',i-1, a( k+1, 1 ),lda, & - t( 1, nb ), 1 ) + call stdlib${ii}$_ccopy( i-1, a( k+1, i ), 1_${ik}$, t( 1_${ik}$, nb ), 1_${ik}$ ) + call stdlib${ii}$_ctrmv( 'LOWER', 'CONJUGATE TRANSPOSE', 'UNIT',i-1, a( k+1, 1_${ik}$ ),lda, & + t( 1_${ik}$, nb ), 1_${ik}$ ) ! w := w + v2**h * b2 - call stdlib_cgemv( 'CONJUGATE TRANSPOSE', n-k-i+1, i-1,cone, a( k+i, 1 ),lda, a( & - k+i, i ), 1, cone, t( 1, nb ), 1 ) + call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', n-k-i+1, i-1,cone, a( k+i, 1_${ik}$ ),lda, a( & + k+i, i ), 1_${ik}$, cone, t( 1_${ik}$, nb ), 1_${ik}$ ) ! w := t**h * w - call stdlib_ctrmv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1, & - nb ), 1 ) + call stdlib${ii}$_ctrmv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1_${ik}$, & + nb ), 1_${ik}$ ) ! b2 := b2 - v2*w - call stdlib_cgemv( 'NO TRANSPOSE', n-k-i+1, i-1, -cone,a( k+i, 1 ),lda, t( 1, nb & - ), 1, cone, a( k+i, i ), 1 ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-k-i+1, i-1, -cone,a( k+i, 1_${ik}$ ),lda, t( 1_${ik}$, nb & + ), 1_${ik}$, cone, a( k+i, i ), 1_${ik}$ ) ! b1 := b1 - v1*w - call stdlib_ctrmv( 'LOWER', 'NO TRANSPOSE','UNIT', i-1,a( k+1, 1 ), lda, t( 1, & - nb ), 1 ) - call stdlib_caxpy( i-1, -cone, t( 1, nb ), 1, a( k+1, i ), 1 ) + call stdlib${ii}$_ctrmv( 'LOWER', 'NO TRANSPOSE','UNIT', i-1,a( k+1, 1_${ik}$ ), lda, t( 1_${ik}$, & + nb ), 1_${ik}$ ) + call stdlib${ii}$_caxpy( i-1, -cone, t( 1_${ik}$, nb ), 1_${ik}$, a( k+1, i ), 1_${ik}$ ) a( k+i-1, i-1 ) = ei end if ! generate the elementary reflector h(i) to annihilate ! a(k+i+1:n,i) - call stdlib_clarfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1,tau( i ) ) + call stdlib${ii}$_clarfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1_${ik}$,tau( i ) ) ei = a( k+i, i ) a( k+i, i ) = cone ! compute y(k+1:n,i) - call stdlib_cgemv( 'NO TRANSPOSE', n-k, n-k-i+1,cone, a( k+1, i+1 ),lda, a( k+i, i )& - , 1, czero, y( k+1, i ), 1 ) - call stdlib_cgemv( 'CONJUGATE TRANSPOSE', n-k-i+1, i-1,cone, a( k+i, 1 ), lda,a( k+& - i, i ), 1, czero, t( 1, i ), 1 ) - call stdlib_cgemv( 'NO TRANSPOSE', n-k, i-1, -cone,y( k+1, 1 ), ldy,t( 1, i ), 1, & - cone, y( k+1, i ), 1 ) - call stdlib_cscal( n-k, tau( i ), y( k+1, i ), 1 ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-k, n-k-i+1,cone, a( k+1, i+1 ),lda, a( k+i, i )& + , 1_${ik}$, czero, y( k+1, i ), 1_${ik}$ ) + call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', n-k-i+1, i-1,cone, a( k+i, 1_${ik}$ ), lda,a( k+& + i, i ), 1_${ik}$, czero, t( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-k, i-1, -cone,y( k+1, 1_${ik}$ ), ldy,t( 1_${ik}$, i ), 1_${ik}$, & + cone, y( k+1, i ), 1_${ik}$ ) + call stdlib${ii}$_cscal( n-k, tau( i ), y( k+1, i ), 1_${ik}$ ) ! compute t(1:i,i) - call stdlib_cscal( i-1, -tau( i ), t( 1, i ), 1 ) - call stdlib_ctrmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1, i ), 1 ) + call stdlib${ii}$_cscal( i-1, -tau( i ), t( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_ctrmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1_${ik}$, i ), 1_${ik}$ ) t( i, i ) = tau( i ) end do loop_10 a( k+nb, nb ) = ei ! compute y(1:k,1:nb) - call stdlib_clacpy( 'ALL', k, nb, a( 1, 2 ), lda, y, ldy ) - call stdlib_ctrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE','UNIT', k, nb,cone, a( k+1, 1 ), & + call stdlib${ii}$_clacpy( 'ALL', k, nb, a( 1_${ik}$, 2_${ik}$ ), lda, y, ldy ) + call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE','UNIT', k, nb,cone, a( k+1, 1_${ik}$ ), & lda, y, ldy ) - if( n>k+nb )call stdlib_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,nb, n-k-nb, cone,a( 1,& - 2+nb ), lda, a( k+1+nb, 1 ), lda, cone, y,ldy ) - call stdlib_ctrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE','NON-UNIT', k, nb,cone, t, ldt, y, & + if( n>k+nb )call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,nb, n-k-nb, cone,a( 1_${ik}$,& + 2_${ik}$+nb ), lda, a( k+1+nb, 1_${ik}$ ), lda, cone, y,ldy ) + call stdlib${ii}$_ctrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE','NON-UNIT', k, nb,cone, t, ldt, y, & ldy ) return - end subroutine stdlib_clahr2 + end subroutine stdlib${ii}$_clahr2 - pure subroutine stdlib_clals0( icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx,perm, givptr, & + pure subroutine stdlib${ii}$_clals0( icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx,perm, givptr, & !! CLALS0 applies back the multiplying factors of either the left or the !! right singular vector matrix of a diagonal matrix appended by a row !! to the right hand side matrix B in solving the least squares problem @@ -40334,12 +40336,12 @@ module stdlib_linalg_lapack_c ! -- 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) :: givptr, icompq, k, ldb, ldbx, ldgcol, ldgnum, nl, nr, nrhs,& + integer(${ik}$), intent(in) :: givptr, icompq, k, ldb, ldbx, ldgcol, ldgnum, nl, nr, nrhs,& sqre - integer(ilp), intent(out) :: info + integer(${ik}$), intent(out) :: info real(sp), intent(in) :: c, s ! Array Arguments - integer(ilp), intent(in) :: givcol(ldgcol,*), perm(*) + integer(${ik}$), intent(in) :: givcol(ldgcol,*), perm(*) real(sp), intent(in) :: difl(*), difr(ldgnum,*), givnum(ldgnum,*), poles(ldgnum,*), z(& *) real(sp), intent(out) :: rwork(*) @@ -40348,179 +40350,179 @@ module stdlib_linalg_lapack_c ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, jcol, jrow, m, n, nlp1 + integer(${ik}$) :: i, j, jcol, jrow, m, n, nlp1 real(sp) :: diflj, difrj, dj, dsigj, dsigjp, temp ! Intrinsic Functions intrinsic :: aimag,cmplx,max,real ! Executable Statements ! test the input parameters. - info = 0 - n = nl + nr + 1 - 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 - else if( nrhs<1 ) then - info = -5 + info = 0_${ik}$ + n = nl + nr + 1_${ik}$ + 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( nrhs<1_${ik}$ ) then + info = -5_${ik}$ else if( ldb1 ) ) then - info = -1 - else if( smlsiz<3 ) then - info = -2 + info = 0_${ik}$ + if( ( icompq<0_${ik}$ ) .or. ( icompq>1_${ik}$ ) ) then + info = -1_${ik}$ + else if( smlsiz<3_${ik}$ ) then + info = -2_${ik}$ else if( n=one ) ) then rcnd = eps else rcnd = rcond end if - rank = 0 + rank = 0_${ik}$ ! quick return if possible. - if( n==0 ) then + if( n==0_${ik}$ ) then return - else if( n==1 ) then - if( d( 1 )==zero ) then - call stdlib_claset( 'A', 1, nrhs, czero, czero, b, ldb ) + else if( n==1_${ik}$ ) then + if( d( 1_${ik}$ )==zero ) then + call stdlib${ii}$_claset( 'A', 1_${ik}$, nrhs, czero, czero, b, ldb ) else - rank = 1 - call stdlib_clascl( 'G', 0, 0, d( 1 ), one, 1, nrhs, b, ldb, info ) - d( 1 ) = abs( d( 1 ) ) + rank = 1_${ik}$ + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, d( 1_${ik}$ ), one, 1_${ik}$, nrhs, b, ldb, info ) + d( 1_${ik}$ ) = abs( d( 1_${ik}$ ) ) end if return end if ! rotate the matrix if it is lower bidiagonal. if( uplo=='L' ) then do i = 1, n - 1 - call stdlib_slartg( d( i ), e( i ), cs, sn, r ) + call stdlib${ii}$_slartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) - if( nrhs==1 ) then - call stdlib_csrot( 1, b( i, 1 ), 1, b( i+1, 1 ), 1, cs, sn ) + if( nrhs==1_${ik}$ ) then + call stdlib${ii}$_csrot( 1_${ik}$, b( i, 1_${ik}$ ), 1_${ik}$, b( i+1, 1_${ik}$ ), 1_${ik}$, cs, sn ) else - rwork( i*2-1 ) = cs - rwork( i*2 ) = sn + rwork( i*2_${ik}$-1 ) = cs + rwork( i*2_${ik}$ ) = sn end if end do - if( nrhs>1 ) then + if( nrhs>1_${ik}$ ) then do i = 1, nrhs do j = 1, n - 1 - cs = rwork( j*2-1 ) - sn = rwork( j*2 ) - call stdlib_csrot( 1, b( j, i ), 1, b( j+1, i ), 1, cs, sn ) + cs = rwork( j*2_${ik}$-1 ) + sn = rwork( j*2_${ik}$ ) + call stdlib${ii}$_csrot( 1_${ik}$, b( j, i ), 1_${ik}$, b( j+1, i ), 1_${ik}$, cs, sn ) end do end do end if end if ! scale. - nm1 = n - 1 - orgnrm = stdlib_slanst( 'M', n, d, e ) + nm1 = n - 1_${ik}$ + orgnrm = stdlib${ii}$_slanst( 'M', n, d, e ) if( orgnrm==zero ) then - call stdlib_claset( 'A', n, nrhs, czero, czero, b, ldb ) + call stdlib${ii}$_claset( 'A', n, nrhs, czero, czero, b, ldb ) return end if - call stdlib_slascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info ) - call stdlib_slascl( 'G', 0, 0, orgnrm, one, nm1, 1, e, nm1, info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, n, 1_${ik}$, d, n, info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, nm1, 1_${ik}$, e, nm1, info ) ! if n is smaller than the minimum divide size smlsiz, then solve ! the problem with another solver. if( n<=smlsiz ) then - irwu = 1 + irwu = 1_${ik}$ irwvt = irwu + n*n irwwrk = irwvt + n*n irwrb = irwwrk irwib = irwrb + n*nrhs irwb = irwib + n*nrhs - call stdlib_slaset( 'A', n, n, zero, one, rwork( irwu ), n ) - call stdlib_slaset( 'A', n, n, zero, one, rwork( irwvt ), n ) - call stdlib_slasdq( 'U', 0, n, n, n, 0, d, e, rwork( irwvt ), n,rwork( irwu ), n, & - rwork( irwwrk ), 1,rwork( irwwrk ), info ) - if( info/=0 ) then + call stdlib${ii}$_slaset( 'A', n, n, zero, one, rwork( irwu ), n ) + call stdlib${ii}$_slaset( 'A', n, n, zero, one, rwork( irwvt ), n ) + call stdlib${ii}$_slasdq( 'U', 0_${ik}$, n, n, n, 0_${ik}$, d, e, rwork( irwvt ), n,rwork( irwu ), n, & + rwork( irwwrk ), 1_${ik}$,rwork( irwwrk ), info ) + if( info/=0_${ik}$ ) then return end if - ! in the real version, b is passed to stdlib_slasdq and multiplied + ! in the real version, b is passed to stdlib${ii}$_slasdq and multiplied ! internally by q**h. here b is complex and that product is ! computed below in two steps (real and imaginary parts). - j = irwb - 1 + j = irwb - 1_${ik}$ do jcol = 1, nrhs do jrow = 1, n - j = j + 1 + j = j + 1_${ik}$ rwork( j ) = real( b( jrow, jcol ),KIND=sp) end do end do - call stdlib_sgemm( 'T', 'N', n, nrhs, n, one, rwork( irwu ), n,rwork( irwb ), n, & + call stdlib${ii}$_sgemm( 'T', 'N', n, nrhs, n, one, rwork( irwu ), n,rwork( irwb ), n, & zero, rwork( irwrb ), n ) - j = irwb - 1 + j = irwb - 1_${ik}$ do jcol = 1, nrhs do jrow = 1, n - j = j + 1 + j = j + 1_${ik}$ rwork( j ) = aimag( b( jrow, jcol ) ) end do end do - call stdlib_sgemm( 'T', 'N', n, nrhs, n, one, rwork( irwu ), n,rwork( irwb ), n, & + call stdlib${ii}$_sgemm( 'T', 'N', n, nrhs, n, one, rwork( irwu ), n,rwork( irwb ), n, & zero, rwork( irwib ), n ) - jreal = irwrb - 1 - jimag = irwib - 1 + jreal = irwrb - 1_${ik}$ + jimag = irwib - 1_${ik}$ do jcol = 1, nrhs do jrow = 1, n - jreal = jreal + 1 - jimag = jimag + 1 + jreal = jreal + 1_${ik}$ + jimag = jimag + 1_${ik}$ b( jrow, jcol ) = cmplx( rwork( jreal ), rwork( jimag ),KIND=sp) end do end do - tol = rcnd*abs( d( stdlib_isamax( n, d, 1 ) ) ) + tol = rcnd*abs( d( stdlib${ii}$_isamax( n, d, 1_${ik}$ ) ) ) do i = 1, n if( d( i )<=tol ) then - call stdlib_claset( 'A', 1, nrhs, czero, czero, b( i, 1 ), ldb ) + call stdlib${ii}$_claset( 'A', 1_${ik}$, nrhs, czero, czero, b( i, 1_${ik}$ ), ldb ) else - call stdlib_clascl( 'G', 0, 0, d( i ), one, 1, nrhs, b( i, 1 ),ldb, info ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, d( i ), one, 1_${ik}$, nrhs, b( i, 1_${ik}$ ),ldb, info ) - rank = rank + 1 + rank = rank + 1_${ik}$ end if end do - ! since b is complex, the following call to stdlib_sgemm is performed + ! since b is complex, the following call to stdlib${ii}$_sgemm is performed ! in two steps (real and imaginary parts). that is for v * b ! (in the real version of the code v**h is stored in work). - ! call stdlib_sgemm( 't', 'n', n, nrhs, n, one, work, n, b, ldb, zero, + ! call stdlib${ii}$_sgemm( 't', 'n', n, nrhs, n, one, work, n, b, ldb, zero, ! $ work( nwork ), n ) - j = irwb - 1 + j = irwb - 1_${ik}$ do jcol = 1, nrhs do jrow = 1, n - j = j + 1 + j = j + 1_${ik}$ rwork( j ) = real( b( jrow, jcol ),KIND=sp) end do end do - call stdlib_sgemm( 'T', 'N', n, nrhs, n, one, rwork( irwvt ), n,rwork( irwb ), n, & + call stdlib${ii}$_sgemm( 'T', 'N', n, nrhs, n, one, rwork( irwvt ), n,rwork( irwb ), n, & zero, rwork( irwrb ), n ) - j = irwb - 1 + j = irwb - 1_${ik}$ do jcol = 1, nrhs do jrow = 1, n - j = j + 1 + j = j + 1_${ik}$ rwork( j ) = aimag( b( jrow, jcol ) ) end do end do - call stdlib_sgemm( 'T', 'N', n, nrhs, n, one, rwork( irwvt ), n,rwork( irwb ), n, & + call stdlib${ii}$_sgemm( 'T', 'N', n, nrhs, n, one, rwork( irwvt ), n,rwork( irwb ), n, & zero, rwork( irwib ), n ) - jreal = irwrb - 1 - jimag = irwib - 1 + jreal = irwrb - 1_${ik}$ + jimag = irwib - 1_${ik}$ do jcol = 1, nrhs do jrow = 1, n - jreal = jreal + 1 - jimag = jimag + 1 + jreal = jreal + 1_${ik}$ + jimag = jimag + 1_${ik}$ b( jrow, jcol ) = cmplx( rwork( jreal ), rwork( jimag ),KIND=sp) end do end do ! unscale. - call stdlib_slascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) - call stdlib_slasrt( 'D', n, d, info ) - call stdlib_clascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, n, 1_${ik}$, d, n, info ) + call stdlib${ii}$_slasrt( 'D', n, d, info ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, n, nrhs, b, ldb, info ) return end if ! book-keeping and setting up some constants. - nlvl = int( log( real( n,KIND=sp) / real( smlsiz+1,KIND=sp) ) / log( two ),KIND=ilp) + & - 1 - smlszp = smlsiz + 1 - u = 1 - vt = 1 + smlsiz*n + nlvl = int( log( real( n,KIND=sp) / real( smlsiz+1,KIND=sp) ) / log( two ),KIND=${ik}$) + & + 1_${ik}$ + smlszp = smlsiz + 1_${ik}$ + u = 1_${ik}$ + vt = 1_${ik}$ + smlsiz*n difl = vt + smlszp*n difr = difl + nlvl*n - z = difr + nlvl*n*2 + z = difr + nlvl*n*2_${ik}$ c = z + nlvl*n s = c + n poles = s + n - givnum = poles + 2*nlvl*n - nrwork = givnum + 2*nlvl*n - bx = 1 + givnum = poles + 2_${ik}$*nlvl*n + nrwork = givnum + 2_${ik}$*nlvl*n + bx = 1_${ik}$ irwrb = nrwork irwib = irwrb + smlsiz*nrhs irwb = irwib + smlsiz*nrhs - sizei = 1 + n + sizei = 1_${ik}$ + n k = sizei + n givptr = k + n perm = givptr + n givcol = perm + nlvl*n - iwk = givcol + nlvl*n*2 - st = 1 - sqre = 0 - icmpq1 = 1 - icmpq2 = 0 - nsub = 0 + iwk = givcol + nlvl*n*2_${ik}$ + st = 1_${ik}$ + sqre = 0_${ik}$ + icmpq1 = 1_${ik}$ + icmpq2 = 0_${ik}$ + nsub = 0_${ik}$ do i = 1, n if( abs( d( i ) )=eps ) then ! a subproblem with e(nm1) not too small but i = nm1. - nsize = n - st + 1 + nsize = n - st + 1_${ik}$ iwork( sizei+nsub-1 ) = nsize else ! a subproblem with e(nm1) small. this implies an ! 1-by-1 subproblem at d(n), which is not solved ! explicitly. - nsize = i - st + 1 + nsize = i - st + 1_${ik}$ iwork( sizei+nsub-1 ) = nsize - nsub = nsub + 1 + nsub = nsub + 1_${ik}$ iwork( nsub ) = n - iwork( sizei+nsub-1 ) = 1 - call stdlib_ccopy( nrhs, b( n, 1 ), ldb, work( bx+nm1 ), n ) + iwork( sizei+nsub-1 ) = 1_${ik}$ + call stdlib${ii}$_ccopy( nrhs, b( n, 1_${ik}$ ), ldb, work( bx+nm1 ), n ) end if - st1 = st - 1 - if( nsize==1 ) then + st1 = st - 1_${ik}$ + if( nsize==1_${ik}$ ) then ! this is a 1-by-1 subproblem and is not solved ! explicitly. - call stdlib_ccopy( nrhs, b( st, 1 ), ldb, work( bx+st1 ), n ) + call stdlib${ii}$_ccopy( nrhs, b( st, 1_${ik}$ ), ldb, work( bx+st1 ), n ) else if( nsize<=smlsiz ) then - ! this is a small subproblem and is solved by stdlib_slasdq. - call stdlib_slaset( 'A', nsize, nsize, zero, one,rwork( vt+st1 ), n ) - call stdlib_slaset( 'A', nsize, nsize, zero, one,rwork( u+st1 ), n ) - call stdlib_slasdq( 'U', 0, nsize, nsize, nsize, 0, d( st ),e( st ), rwork( & - vt+st1 ), n, rwork( u+st1 ),n, rwork( nrwork ), 1, rwork( nrwork ),info ) + ! this is a small subproblem and is solved by stdlib${ii}$_slasdq. + call stdlib${ii}$_slaset( 'A', nsize, nsize, zero, one,rwork( vt+st1 ), n ) + call stdlib${ii}$_slaset( 'A', nsize, nsize, zero, one,rwork( u+st1 ), n ) + call stdlib${ii}$_slasdq( 'U', 0_${ik}$, nsize, nsize, nsize, 0_${ik}$, d( st ),e( st ), rwork( & + vt+st1 ), n, rwork( u+st1 ),n, rwork( nrwork ), 1_${ik}$, rwork( nrwork ),info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if - ! in the real version, b is passed to stdlib_slasdq and multiplied + ! in the real version, b is passed to stdlib${ii}$_slasdq and multiplied ! internally by q**h. here b is complex and that product is ! computed below in two steps (real and imaginary parts). - j = irwb - 1 + j = irwb - 1_${ik}$ do jcol = 1, nrhs do jrow = st, st + nsize - 1 - j = j + 1 + j = j + 1_${ik}$ rwork( j ) = real( b( jrow, jcol ),KIND=sp) end do end do - call stdlib_sgemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( u+st1 ), n, rwork(& + call stdlib${ii}$_sgemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( u+st1 ), n, rwork(& irwb ), nsize,zero, rwork( irwrb ), nsize ) - j = irwb - 1 + j = irwb - 1_${ik}$ do jcol = 1, nrhs do jrow = st, st + nsize - 1 - j = j + 1 + j = j + 1_${ik}$ rwork( j ) = aimag( b( jrow, jcol ) ) end do end do - call stdlib_sgemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( u+st1 ), n, rwork(& + call stdlib${ii}$_sgemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( u+st1 ), n, rwork(& irwb ), nsize,zero, rwork( irwib ), nsize ) - jreal = irwrb - 1 - jimag = irwib - 1 + jreal = irwrb - 1_${ik}$ + jimag = irwib - 1_${ik}$ do jcol = 1, nrhs do jrow = st, st + nsize - 1 - jreal = jreal + 1 - jimag = jimag + 1 + jreal = jreal + 1_${ik}$ + jimag = jimag + 1_${ik}$ b( jrow, jcol ) = cmplx( rwork( jreal ),rwork( jimag ),KIND=sp) end do end do - call stdlib_clacpy( 'A', nsize, nrhs, b( st, 1 ), ldb,work( bx+st1 ), n ) + call stdlib${ii}$_clacpy( 'A', nsize, nrhs, b( st, 1_${ik}$ ), ldb,work( bx+st1 ), n ) else ! a large problem. solve it using divide and conquer. - call stdlib_slasda( icmpq1, smlsiz, nsize, sqre, d( st ),e( st ), rwork( u+& + call stdlib${ii}$_slasda( icmpq1, smlsiz, nsize, sqre, d( st ),e( st ), rwork( u+& st1 ), n, rwork( vt+st1 ),iwork( k+st1 ), rwork( difl+st1 ),rwork( difr+st1 ),& rwork( z+st1 ),rwork( poles+st1 ), iwork( givptr+st1 ),iwork( givcol+st1 ), & n, iwork( perm+st1 ),rwork( givnum+st1 ), rwork( c+st1 ),rwork( s+st1 ), & rwork( nrwork ),iwork( iwk ), info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if bxst = bx + st1 - call stdlib_clalsa( icmpq2, smlsiz, nsize, nrhs, b( st, 1 ),ldb, work( bxst ),& + call stdlib${ii}$_clalsa( icmpq2, smlsiz, nsize, nrhs, b( st, 1_${ik}$ ),ldb, work( bxst ),& n, rwork( u+st1 ), n,rwork( vt+st1 ), iwork( k+st1 ),rwork( difl+st1 ), & rwork( difr+st1 ),rwork( z+st1 ), rwork( poles+st1 ),iwork( givptr+st1 ), & iwork( givcol+st1 ), n,iwork( perm+st1 ), rwork( givnum+st1 ),rwork( c+st1 ),& rwork( s+st1 ),rwork( nrwork ), iwork( iwk ), info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if end if - st = i + 1 + st = i + 1_${ik}$ end if end do loop_240 ! apply the singular values and treat the tiny ones as zero. - tol = rcnd*abs( d( stdlib_isamax( n, d, 1 ) ) ) + tol = rcnd*abs( d( stdlib${ii}$_isamax( n, d, 1_${ik}$ ) ) ) do i = 1, n ! some of the elements in d can be negative because 1-by-1 ! subproblems were not solved explicitly. if( abs( d( i ) )<=tol ) then - call stdlib_claset( 'A', 1, nrhs, czero, czero, work( bx+i-1 ), n ) + call stdlib${ii}$_claset( 'A', 1_${ik}$, nrhs, czero, czero, work( bx+i-1 ), n ) else - rank = rank + 1 - call stdlib_clascl( 'G', 0, 0, d( i ), one, 1, nrhs,work( bx+i-1 ), n, info ) + rank = rank + 1_${ik}$ + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, d( i ), one, 1_${ik}$, nrhs,work( bx+i-1 ), n, info ) end if d( i ) = abs( d( i ) ) end do ! now apply back the right singular vectors. - icmpq2 = 1 + icmpq2 = 1_${ik}$ loop_320: do i = 1, nsub st = iwork( i ) - st1 = st - 1 + st1 = st - 1_${ik}$ nsize = iwork( sizei+i-1 ) bxst = bx + st1 - if( nsize==1 ) then - call stdlib_ccopy( nrhs, work( bxst ), n, b( st, 1 ), ldb ) + if( nsize==1_${ik}$ ) then + call stdlib${ii}$_ccopy( nrhs, work( bxst ), n, b( st, 1_${ik}$ ), ldb ) else if( nsize<=smlsiz ) then - ! since b and bx are complex, the following call to stdlib_sgemm + ! since b and bx are complex, the following call to stdlib${ii}$_sgemm ! is performed in two steps (real and imaginary parts). - ! call stdlib_sgemm( 't', 'n', nsize, nrhs, nsize, one, + ! call stdlib${ii}$_sgemm( 't', 'n', nsize, nrhs, nsize, one, ! $ rwork( vt+st1 ), n, rwork( bxst ), n, zero, ! $ b( st, 1 ), ldb ) - j = bxst - n - 1 - jreal = irwb - 1 + j = bxst - n - 1_${ik}$ + jreal = irwb - 1_${ik}$ do jcol = 1, nrhs j = j + n do jrow = 1, nsize - jreal = jreal + 1 + jreal = jreal + 1_${ik}$ rwork( jreal ) = real( work( j+jrow ),KIND=sp) end do end do - call stdlib_sgemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( vt+st1 ), n, rwork( & + call stdlib${ii}$_sgemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( vt+st1 ), n, rwork( & irwb ), nsize, zero,rwork( irwrb ), nsize ) - j = bxst - n - 1 - jimag = irwb - 1 + j = bxst - n - 1_${ik}$ + jimag = irwb - 1_${ik}$ do jcol = 1, nrhs j = j + n do jrow = 1, nsize - jimag = jimag + 1 + jimag = jimag + 1_${ik}$ rwork( jimag ) = aimag( work( j+jrow ) ) end do end do - call stdlib_sgemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( vt+st1 ), n, rwork( & + call stdlib${ii}$_sgemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( vt+st1 ), n, rwork( & irwb ), nsize, zero,rwork( irwib ), nsize ) - jreal = irwrb - 1 - jimag = irwib - 1 + jreal = irwrb - 1_${ik}$ + jimag = irwib - 1_${ik}$ do jcol = 1, nrhs do jrow = st, st + nsize - 1 - jreal = jreal + 1 - jimag = jimag + 1 + jreal = jreal + 1_${ik}$ + jimag = jimag + 1_${ik}$ b( jrow, jcol ) = cmplx( rwork( jreal ),rwork( jimag ),KIND=sp) end do end do else - call stdlib_clalsa( icmpq2, smlsiz, nsize, nrhs, work( bxst ), n,b( st, 1 ), ldb,& + call stdlib${ii}$_clalsa( icmpq2, smlsiz, nsize, nrhs, work( bxst ), n,b( st, 1_${ik}$ ), ldb,& rwork( u+st1 ), n,rwork( vt+st1 ), iwork( k+st1 ),rwork( difl+st1 ), rwork( & difr+st1 ),rwork( z+st1 ), rwork( poles+st1 ),iwork( givptr+st1 ), iwork( & givcol+st1 ), n,iwork( perm+st1 ), rwork( givnum+st1 ),rwork( c+st1 ), rwork( s+& st1 ),rwork( nrwork ), iwork( iwk ), info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if end if end do loop_320 ! unscale and sort the singular values. - call stdlib_slascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) - call stdlib_slasrt( 'D', n, d, info ) - call stdlib_clascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, n, 1_${ik}$, d, n, info ) + call stdlib${ii}$_slasrt( 'D', n, d, info ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, n, nrhs, b, ldb, info ) return - end subroutine stdlib_clalsd + end subroutine stdlib${ii}$_clalsd - real(sp) function stdlib_clangb( norm, n, kl, ku, ab, ldab,work ) + real(sp) function stdlib${ii}$_clangb( norm, n, kl, ku, ab, ldab,work ) !! CLANGB returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of an !! n by n band matrix A, with kl sub-diagonals and ku super-diagonals. @@ -41276,19 +41278,19 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: norm - integer(ilp), intent(in) :: kl, ku, ldab, n + integer(${ik}$), intent(in) :: kl, ku, ldab, n ! Array Arguments real(sp), intent(out) :: work(*) complex(sp), intent(in) :: ab(ldab,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, k, l + integer(${ik}$) :: i, j, k, l real(sp) :: scale, sum, value, temp ! 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))). @@ -41296,7 +41298,7 @@ module stdlib_linalg_lapack_c do j = 1, n do i = max( ku+2-j, 1 ), min( n+ku+1-j, kl+ku+1 ) temp = abs( ab( i, j ) ) - if( value1 ) then - call stdlib_classq( n-1, dl, 1, scale, sum ) - call stdlib_classq( n-1, du, 1, scale, sum ) + call stdlib${ii}$_classq( n, d, 1_${ik}$, scale, sum ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_classq( n-1, dl, 1_${ik}$, scale, sum ) + call stdlib${ii}$_classq( n-1, du, 1_${ik}$, scale, sum ) end if anorm = scale*sqrt( sum ) end if - stdlib_clangt = anorm + stdlib${ii}$_clangt = anorm return - end function stdlib_clangt + end function stdlib${ii}$_clangt - real(sp) function stdlib_clanhb( norm, uplo, n, k, ab, ldab,work ) + real(sp) function stdlib${ii}$_clanhb( norm, uplo, n, k, ab, ldab,work ) !! CLANHB returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of an !! n by n hermitian band matrix A, with k super-diagonals. @@ -41499,19 +41501,19 @@ module stdlib_linalg_lapack_c ! -- 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(out) :: work(*) complex(sp), intent(in) :: ab(ldab,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, l + integer(${ik}$) :: i, j, l real(sp) :: absa, scale, sum, value ! Intrinsic Functions intrinsic :: abs,max,min,real,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))). @@ -41520,18 +41522,18 @@ module stdlib_linalg_lapack_c 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 sum = abs( real( ab( k+1, j ),KIND=sp) ) - 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 - sum = abs( real( ab( 1, j ),KIND=sp) ) - if( value < sum .or. stdlib_sisnan( sum ) ) value = sum + sum = abs( real( ab( 1_${ik}$, j ),KIND=sp) ) + if( value < sum .or. stdlib${ii}$_sisnan( sum ) ) value = sum 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 @@ -41542,7 +41544,7 @@ module stdlib_linalg_lapack_c 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 @@ -41552,21 +41554,21 @@ module stdlib_linalg_lapack_c 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( real( ab( 1, j ),KIND=sp) ) - l = 1 - j + sum = work( j ) + abs( real( ab( 1_${ik}$, j ),KIND=sp) ) + 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' ) ) ) & @@ -41574,42 +41576,42 @@ module stdlib_linalg_lapack_c ! 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_classq( min( j-1, k ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) + call stdlib${ii}$_classq( 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_classq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) + call stdlib${ii}$_classq( 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 do j = 1, n if( real( ab( l, j ),KIND=sp)/=zero ) then absa = abs( real( ab( l, j ),KIND=sp) ) if( scale l(0,0) temp = abs( real( a( j+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp do i = 1, 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 do j = 1, k - 1 do i = 0, j - 2 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 - i = j - 1 + i = j - 1_${ik}$ ! l(k+j,k+j) temp = abs( real( a( i+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp i = j ! -> l(j,j) temp = abs( real( a( i+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp do i = j + 1, 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 @@ -41811,65 +41813,65 @@ module stdlib_linalg_lapack_c do j = 0, k - 2 do i = 0, k + j - 2 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 - i = k + j - 1 + i = k + j - 1_${ik}$ ! -> u(i,i) temp = abs( real( a( i+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp - i = i + 1 + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp + i = i + 1_${ik}$ ! =k+j; i -> u(j,j) temp = abs( real( a( i+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp do i = k + j + 1, 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 do i = 0, n - 2 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 ! j=k-1 end do ! i=n-1 -> u(n-1,n-1) temp = abs( real( a( i+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp end if else ! xpose case; a is k by n - if( ilu==1 ) then + if( ilu==1_${ik}$ ) then ! uplo ='l' do j = 0, k - 2 do i = 0, j - 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 i = j ! l(i,i) temp = abs( real( a( i+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp - i = j + 1 + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp + i = j + 1_${ik}$ ! l(j+k,j+k) temp = abs( real( a( i+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp do i = j + 2, 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 - j = k - 1 + j = k - 1_${ik}$ do i = 0, k - 2 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 - i = k - 1 + i = k - 1_${ik}$ ! -> l(i,i) is at a(i,j) temp = abs( real( a( i+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp do j = k, 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 else @@ -41877,69 +41879,69 @@ module stdlib_linalg_lapack_c do j = 0, k - 2 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 - j = k - 1 + j = k - 1_${ik}$ ! -> u(j,j) is at a(0,j) - temp = abs( real( a( 0+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + temp = abs( real( a( 0_${ik}$+j*lda ),KIND=sp) ) + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp do i = 1, 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 do j = k, n - 1 do i = 0, j - 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 i = j - k ! -> u(i,i) at a(i,j) temp = abs( real( a( i+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp - i = j - k + 1 + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp + i = j - k + 1_${ik}$ ! u(j,j) temp = abs( real( a( i+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp do i = j - k + 2, 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 ! n is even - if( ifm==1 ) then + if( ifm==1_${ik}$ ) then ! a is n+1 by k - if( ilu==1 ) then + if( ilu==1_${ik}$ ) then ! uplo ='l' - j = 0 + j = 0_${ik}$ ! -> l(k,k) temp = abs( real( a( j+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp temp = abs( real( a( j+1+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp do i = 2, 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 do j = 1, k - 1 do i = 0, j - 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 i = j ! l(k+j,k+j) temp = abs( real( a( i+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp - i = j + 1 + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp + i = j + 1_${ik}$ ! -> l(j,j) temp = abs( real( a( i+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp do i = j + 2, 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 @@ -41947,77 +41949,77 @@ module stdlib_linalg_lapack_c do j = 0, k - 2 do i = 0, k + j - 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 i = k + j ! -> u(i,i) temp = abs( real( a( i+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp - i = i + 1 + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp + i = i + 1_${ik}$ ! =k+j+1; i -> u(j,j) temp = abs( real( a( i+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp do i = k + j + 2, 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 do i = 0, n - 2 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 ! j=k-1 end do ! i=n-1 -> u(n-1,n-1) temp = abs( real( a( i+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp i = n ! -> u(k-1,k-1) temp = abs( real( a( i+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp end if else ! xpose case; a is k by n+1 - if( ilu==1 ) then + if( ilu==1_${ik}$ ) then ! uplo ='l' - j = 0 + j = 0_${ik}$ ! -> l(k,k) at a(0,0) temp = abs( real( a( j+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp do i = 1, 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 do j = 1, k - 1 do i = 0, j - 2 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 - i = j - 1 + i = j - 1_${ik}$ ! l(i,i) temp = abs( real( a( i+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp i = j ! l(j+k,j+k) temp = abs( real( a( i+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp do i = j + 1, 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 j = k do i = 0, k - 2 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 - i = k - 1 + i = k - 1_${ik}$ ! -> l(i,i) is at a(i,j) temp = abs( real( a( i+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp do j = k + 1, 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 else @@ -42025,56 +42027,56 @@ module stdlib_linalg_lapack_c do j = 0, k - 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 j = k ! -> u(j,j) is at a(0,j) - temp = abs( real( a( 0+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + temp = abs( real( a( 0_${ik}$+j*lda ),KIND=sp) ) + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp do i = 1, 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 do j = k + 1, n - 1 do i = 0, j - k - 2 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 - i = j - k - 1 + i = j - k - 1_${ik}$ ! -> u(i,i) at a(i,j) temp = abs( real( a( i+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp i = j - k ! u(j,j) temp = abs( real( a( i+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp do i = j - k + 1, 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 j = n do i = 0, k - 2 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 - i = k - 1 + i = k - 1_${ik}$ ! u(k,k) at a(i,j) temp = abs( real( a( i+j*lda ),KIND=sp) ) - if( value < temp .or. stdlib_sisnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_sisnan( temp ) )value = temp end if end if end if else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( & norm=='1' ) ) then ! find normi(a) ( = norm1(a), since a is hermitian). - if( ifm==1 ) then + if( ifm==1_${ik}$ ) then ! a is 'n' - k = n / 2 - if( noe==1 ) then + k = n / 2_${ik}$ + if( noe==1_${ik}$ ) then ! n is odd - if( ilu==0 ) then + if( ilu==0_${ik}$ ) then ! uplo = 'u' do i = 0, k - 1 work( i ) = zero @@ -42091,13 +42093,13 @@ module stdlib_linalg_lapack_c ! -> 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( real( a( i+j*lda ),KIND=sp) ) ! -> 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 @@ -42106,14 +42108,14 @@ module stdlib_linalg_lapack_c 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 = k + 1_${ik}$ ! k=(n+1)/2 for n odd and ilu=1 do i = k, n - 1 work( i ) = zero @@ -42126,20 +42128,20 @@ module stdlib_linalg_lapack_c s = s + aa work( i+k ) = work( i+k ) + aa end do - if( j>0 ) then + if( j>0_${ik}$ ) then aa = abs( real( a( i+j*lda ),KIND=sp) ) ! -> 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( real( a( i+j*lda ),KIND=sp) ) ! -> 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 @@ -42147,15 +42149,15 @@ module stdlib_linalg_lapack_c 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 ! uplo = 'u' do i = 0, k - 1 work( i ) = zero @@ -42171,13 +42173,13 @@ module stdlib_linalg_lapack_c aa = abs( real( a( i+j*lda ),KIND=sp) ) ! -> a(j+k,j+k) work( j+k ) = s + aa - i = i + 1 + i = i + 1_${ik}$ aa = abs( real( a( i+j*lda ),KIND=sp) ) ! -> 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 @@ -42185,10 +42187,10 @@ module stdlib_linalg_lapack_c 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 @@ -42208,13 +42210,13 @@ module stdlib_linalg_lapack_c s = s + aa work( i+k ) = work( i+k ) + s ! i=j - i = i + 1 + i = i + 1_${ik}$ aa = abs( real( a( i+j*lda ),KIND=sp) ) ! -> 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 @@ -42222,23 +42224,23 @@ module stdlib_linalg_lapack_c 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 + k = n / 2_${ik}$ + if( noe==1_${ik}$ ) then ! n is odd - if( ilu==0 ) then + if( ilu==0_${ik}$ ) then ! uplo = 'u' n1 = k ! n/2 - k = k + 1 + k = k + 1_${ik}$ ! k is the row size and lda do i = n1, n - 1 work( i ) = zero @@ -42254,7 +42256,7 @@ module stdlib_linalg_lapack_c work( j ) = s end do ! j=n1=k-1 is special - s = abs( real( a( 0+j*lda ),KIND=sp) ) + s = abs( real( a( 0_${ik}$+j*lda ),KIND=sp) ) ! a(k-1,k-1) do i = 1, k - 1 aa = abs( a( i+j*lda ) ) @@ -42276,11 +42278,11 @@ module stdlib_linalg_lapack_c ! a(j-k,j-k) s = s + aa work( j-k ) = work( j-k ) + s - i = i + 1 + i = i + 1_${ik}$ s = abs( real( a( i+j*lda ),KIND=sp) ) ! 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 @@ -42288,14 +42290,14 @@ module stdlib_linalg_lapack_c 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 = k + 1_${ik}$ ! k=(n+1)/2 for n odd and ilu=1 do i = k, n - 1 work( i ) = zero @@ -42314,12 +42316,12 @@ module stdlib_linalg_lapack_c 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( real( a( i+j*lda ),KIND=sp) ) 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 @@ -42352,15 +42354,15 @@ module stdlib_linalg_lapack_c 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 ! uplo = 'u' do i = k, n - 1 work( i ) = zero @@ -42376,7 +42378,7 @@ module stdlib_linalg_lapack_c work( j ) = s end do ! j=k - aa = abs( real( a( 0+j*lda ),KIND=sp) ) + aa = abs( real( a( 0_${ik}$+j*lda ),KIND=sp) ) ! a(k,k) s = aa do i = 1, k - 1 @@ -42399,12 +42401,12 @@ module stdlib_linalg_lapack_c ! 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( real( a( i+j*lda ),KIND=sp) ) ! 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 @@ -42425,10 +42427,10 @@ module stdlib_linalg_lapack_c ! 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 @@ -42436,7 +42438,7 @@ module stdlib_linalg_lapack_c work( i ) = zero end do ! j=0 is special :process col a(k:n-1,k) - s = abs( real( a( 0 ),KIND=sp) ) + s = abs( real( a( 0_${ik}$ ),KIND=sp) ) ! a(k,k) do i = 1, k - 1 aa = abs( a( i ) ) @@ -42459,12 +42461,12 @@ module stdlib_linalg_lapack_c 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( real( a( i+j*lda ),KIND=sp) ) 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 @@ -42497,10 +42499,10 @@ module stdlib_linalg_lapack_c 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 @@ -42508,80 +42510,80 @@ module stdlib_linalg_lapack_c 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_classq( k-j-2, a( k+j+1+j*lda ), 1, scale, s ) + call stdlib${ii}$_classq( k-j-2, a( k+j+1+j*lda ), 1_${ik}$, scale, s ) ! l at a(k,0) end do do j = 0, k - 1 - call stdlib_classq( k+j-1, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_classq( k+j-1, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! trap u at a(0,0) end do s = s + s ! double s for the off diagonal elements - l = k - 1 + l = k - 1_${ik}$ ! -> u(k,k) at a(k-1,0) do i = 0, k - 2 aa = real( a( l ),KIND=sp) ! u(k+i,k+i) if( aa/=zero ) then if( scale u(k-1,k-1) at a(0,k-1) aa = real( a( l ),KIND=sp) ! u(k-1,k-1) if( aa/=zero ) then if( scale u(j-k,j-k) if( aa/=zero ) then if( scale u(j,j) if( aa/=zero ) then if( scale l(0,0) at a(0,0) do i = 0, k - 2 aa = real( a( l ),KIND=sp) ! l(i,i) if( aa/=zero ) then if( scale k-1 + (k-1)*lda or l(k-1,k-1) at a(k-1,k-1) aa = real( a( l ),KIND=sp) ! l(k-1,k-1) at a(k-1,k-1) if( aa/=zero ) then if( scale l(k,k) at a(0,0) do i = 0, k - 1 aa = real( a( l ),KIND=sp) ! l(k-1+i,k-1+i) if( aa/=zero ) then if( scale u(k,k) at a(0,k) aa = real( a( l ),KIND=sp) ! u(k,k) if( aa/=zero ) then if( scale u(j-k-1,j-k-1) if( aa/=zero ) then if( scale u(j,j) if( aa/=zero ) then if( scale u(k-1,k-1) at a(k-1,n) @@ -42859,38 +42861,38 @@ module stdlib_linalg_lapack_c ! u(k,k) if( aa/=zero ) then if( scale l(k,k) at a(0,0) aa = real( a( l ),KIND=sp) ! l(k,k) at a(0,0) if( aa/=zero ) then if( scale k - 1 + k*lda or l(k-1,k-1) at a(k-1,k) aa = real( a( l ),KIND=sp) ! l(k-1,k-1) at a(k-1,k) if( aa/=zero ) then if( scale1 ) then - call stdlib_classq( n-1, e, 1, scale, sum ) - sum = 2*sum + if( n>1_${ik}$ ) then + call stdlib${ii}$_classq( 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_clanht = anorm + stdlib${ii}$_clanht = anorm return - end function stdlib_clanht + end function stdlib${ii}$_clanht - real(sp) function stdlib_clansb( norm, uplo, n, k, ab, ldab,work ) + real(sp) function stdlib${ii}$_clansb( norm, uplo, n, k, ab, ldab,work ) !! CLANSB 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. @@ -43211,19 +43213,19 @@ module stdlib_linalg_lapack_c ! -- 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(out) :: work(*) complex(sp), intent(in) :: ab(ldab,*) ! ===================================================================== ! 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))). @@ -43232,14 +43234,14 @@ module stdlib_linalg_lapack_c 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 @@ -43250,7 +43252,7 @@ module stdlib_linalg_lapack_c 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 @@ -43260,21 +43262,21 @@ module stdlib_linalg_lapack_c 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' ) ) ) & @@ -43282,32 +43284,32 @@ module stdlib_linalg_lapack_c ! 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_classq( min( j-1, k ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) + call stdlib${ii}$_classq( 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_classq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) + call stdlib${ii}$_classq( 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_classq( n, ab( l, 1 ), ldab, scale, sum ) + call stdlib${ii}$_classq( n, ab( l, 1_${ik}$ ), ldab, scale, sum ) value = scale*sqrt( sum ) end if - stdlib_clansb = value + stdlib${ii}$_clansb = value return - end function stdlib_clansb + end function stdlib${ii}$_clansb - real(sp) function stdlib_clansp( norm, uplo, n, ap, work ) + real(sp) function stdlib${ii}$_clansp( norm, uplo, n, ap, work ) !! CLANSP returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! complex symmetric matrix A, supplied in packed form. @@ -43316,47 +43318,47 @@ module stdlib_linalg_lapack_c ! -- 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(out) :: work(*) complex(sp), intent(in) :: ap(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, k + integer(${ik}$) :: i, j, k real(sp) :: absa, scale, sum, value ! Intrinsic Functions intrinsic :: abs,aimag,real,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 ! 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 @@ -43364,14 +43366,14 @@ module stdlib_linalg_lapack_c 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 @@ -43379,14 +43381,14 @@ module stdlib_linalg_lapack_c 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' ) ) ) & @@ -43394,53 +43396,53 @@ module stdlib_linalg_lapack_c ! find normf(a). scale = zero sum = one - k = 2 + k = 2_${ik}$ if( stdlib_lsame( uplo, 'U' ) ) then do j = 2, n - call stdlib_classq( j-1, ap( k ), 1, scale, sum ) + call stdlib${ii}$_classq( j-1, ap( k ), 1_${ik}$, scale, sum ) k = k + j end do else do j = 1, n - 1 - call stdlib_classq( n-j, ap( k ), 1, scale, sum ) - k = k + n - j + 1 + call stdlib${ii}$_classq( 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( real( ap( k ),KIND=sp)/=zero ) then absa = abs( real( ap( k ),KIND=sp) ) if( scale0 ) then + if( k>0_${ik}$ ) then do j = 2, n - call stdlib_classq( min( j-1, k ),ab( max( k+2-j, 1 ), j ), 1, scale,& + call stdlib${ii}$_classq( min( j-1, k ),ab( max( k+2-j, 1_${ik}$ ), j ), 1_${ik}$, scale,& sum ) end do end if @@ -43701,7 +43703,7 @@ module stdlib_linalg_lapack_c scale = zero sum = one do j = 1, n - call stdlib_classq( min( j, k+1 ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) + call stdlib${ii}$_classq( min( j, k+1 ), ab( max( k+2-j, 1_${ik}$ ), j ),1_${ik}$, scale, sum ) end do end if @@ -43709,27 +43711,27 @@ module stdlib_linalg_lapack_c 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_classq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) + call stdlib${ii}$_classq( 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_classq( min( n-j+1, k+1 ), ab( 1, j ), 1, scale,sum ) + call stdlib${ii}$_classq( 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_clantb = value + stdlib${ii}$_clantb = value return - end function stdlib_clantb + end function stdlib${ii}$_clantb - real(sp) function stdlib_clantp( norm, uplo, diag, n, ap, work ) + real(sp) function stdlib${ii}$_clantp( norm, uplo, diag, n, ap, work ) !! CLANTP 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. @@ -43738,7 +43740,7 @@ module stdlib_linalg_lapack_c ! -- 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(out) :: work(*) complex(sp), intent(in) :: ap(*) @@ -43746,23 +43748,23 @@ module stdlib_linalg_lapack_c ! 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 @@ -43770,9 +43772,9 @@ module stdlib_linalg_lapack_c 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 @@ -43781,7 +43783,7 @@ module stdlib_linalg_lapack_c 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 @@ -43789,16 +43791,16 @@ module stdlib_linalg_lapack_c 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 ! 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 @@ -43814,7 +43816,7 @@ module stdlib_linalg_lapack_c 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 @@ -43829,13 +43831,13 @@ module stdlib_linalg_lapack_c 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 @@ -43844,9 +43846,9 @@ module stdlib_linalg_lapack_c 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 @@ -43855,7 +43857,7 @@ module stdlib_linalg_lapack_c 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 @@ -43865,10 +43867,10 @@ module stdlib_linalg_lapack_c 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 @@ -43878,7 +43880,7 @@ module stdlib_linalg_lapack_c 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 @@ -43886,7 +43888,7 @@ module stdlib_linalg_lapack_c 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 @@ -43895,17 +43897,17 @@ module stdlib_linalg_lapack_c if( stdlib_lsame( diag, 'U' ) ) then scale = one sum = n - k = 2 + k = 2_${ik}$ do j = 2, n - call stdlib_classq( j-1, ap( k ), 1, scale, sum ) + call stdlib${ii}$_classq( 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_classq( j, ap( k ), 1, scale, sum ) + call stdlib${ii}$_classq( j, ap( k ), 1_${ik}$, scale, sum ) k = k + j end do end if @@ -43913,29 +43915,29 @@ module stdlib_linalg_lapack_c if( stdlib_lsame( diag, 'U' ) ) then scale = one sum = n - k = 2 + k = 2_${ik}$ do j = 1, n - 1 - call stdlib_classq( n-j, ap( k ), 1, scale, sum ) - k = k + n - j + 1 + call stdlib${ii}$_classq( 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_classq( n-j+1, ap( k ), 1, scale, sum ) - k = k + n - j + 1 + call stdlib${ii}$_classq( 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_clantp = value + stdlib${ii}$_clantp = value return - end function stdlib_clantp + end function stdlib${ii}$_clantp - real(sp) function stdlib_clantr( norm, uplo, diag, m, n, a, lda,work ) + real(sp) function stdlib${ii}$_clantr( norm, uplo, diag, m, n, a, lda,work ) !! CLANTR 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. @@ -43944,7 +43946,7 @@ module stdlib_linalg_lapack_c ! -- 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(out) :: work(*) complex(sp), intent(in) :: a(lda,*) @@ -43952,12 +43954,12 @@ module stdlib_linalg_lapack_c ! 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))). @@ -43967,14 +43969,14 @@ module stdlib_linalg_lapack_c 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 @@ -43984,14 +43986,14 @@ module stdlib_linalg_lapack_c 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 @@ -44013,7 +44015,7 @@ module stdlib_linalg_lapack_c 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 @@ -44028,7 +44030,7 @@ module stdlib_linalg_lapack_c 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 @@ -44080,7 +44082,7 @@ module stdlib_linalg_lapack_c 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 @@ -44090,13 +44092,13 @@ module stdlib_linalg_lapack_c scale = one sum = min( m, n ) do j = 2, n - call stdlib_classq( min( m, j-1 ), a( 1, j ), 1, scale, sum ) + call stdlib${ii}$_classq( 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_classq( min( m, j ), a( 1, j ), 1, scale, sum ) + call stdlib${ii}$_classq( min( m, j ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum ) end do end if else @@ -44104,24 +44106,24 @@ module stdlib_linalg_lapack_c scale = one sum = min( m, n ) do j = 1, n - call stdlib_classq( m-j, a( min( m, j+1 ), j ), 1, scale,sum ) + call stdlib${ii}$_classq( 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_classq( m-j+1, a( j, j ), 1, scale, sum ) + call stdlib${ii}$_classq( m-j+1, a( j, j ), 1_${ik}$, scale, sum ) end do end if end if value = scale*sqrt( sum ) end if - stdlib_clantr = value + stdlib${ii}$_clantr = value return - end function stdlib_clantr + end function stdlib${ii}$_clantr - pure subroutine stdlib_clapll( n, x, incx, y, incy, ssmin ) + pure subroutine stdlib${ii}$_clapll( n, x, incx, y, incy, ssmin ) !! Given two column vectors X and Y, let !! A = ( X Y ). !! The subroutine first computes the QR factorization of A = Q*R, @@ -44132,7 +44134,7 @@ module stdlib_linalg_lapack_c ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n real(sp), intent(out) :: ssmin ! Array Arguments complex(sp), intent(inout) :: x(*), y(*) @@ -44146,26 +44148,26 @@ module stdlib_linalg_lapack_c intrinsic :: abs,conjg ! Executable Statements ! quick return if possible - if( n<=1 ) then + if( n<=1_${ik}$ ) then ssmin = zero return end if ! compute the qr factorization of the n-by-2 matrix ( x y ) - call stdlib_clarfg( n, x( 1 ), x( 1+incx ), incx, tau ) - a11 = x( 1 ) - x( 1 ) = cone - c = -conjg( tau )*stdlib_cdotc( n, x, incx, y, incy ) - call stdlib_caxpy( n, c, x, incx, y, incy ) - call stdlib_clarfg( n-1, y( 1+incy ), y( 1+2*incy ), incy, tau ) - a12 = y( 1 ) - a22 = y( 1+incy ) + call stdlib${ii}$_clarfg( n, x( 1_${ik}$ ), x( 1_${ik}$+incx ), incx, tau ) + a11 = x( 1_${ik}$ ) + x( 1_${ik}$ ) = cone + c = -conjg( tau )*stdlib${ii}$_cdotc( n, x, incx, y, incy ) + call stdlib${ii}$_caxpy( n, c, x, incx, y, incy ) + call stdlib${ii}$_clarfg( n-1, y( 1_${ik}$+incy ), y( 1_${ik}$+2*incy ), incy, tau ) + a12 = y( 1_${ik}$ ) + a22 = y( 1_${ik}$+incy ) ! compute the svd of 2-by-2 upper triangular matrix. - call stdlib_slas2( abs( a11 ), abs( a12 ), abs( a22 ), ssmin, ssmax ) + call stdlib${ii}$_slas2( abs( a11 ), abs( a12 ), abs( a22 ), ssmin, ssmax ) return - end subroutine stdlib_clapll + end subroutine stdlib${ii}$_clapll - pure subroutine stdlib_claqp2( m, n, offset, a, lda, jpvt, tau, vn1, vn2,work ) + pure subroutine stdlib${ii}$_claqp2( m, n, offset, a, lda, jpvt, tau, vn1, vn2,work ) !! CLAQP2 computes a QR factorization with column pivoting of !! the block A(OFFSET+1:M,1:N). !! The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. @@ -44173,9 +44175,9 @@ module stdlib_linalg_lapack_c ! -- 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, m, n, offset + integer(${ik}$), intent(in) :: lda, m, n, offset ! Array Arguments - integer(ilp), intent(inout) :: jpvt(*) + integer(${ik}$), intent(inout) :: jpvt(*) real(sp), intent(inout) :: vn1(*), vn2(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: tau(*), work(*) @@ -44183,21 +44185,21 @@ module stdlib_linalg_lapack_c ! Local Scalars - integer(ilp) :: i, itemp, j, mn, offpi, pvt + integer(${ik}$) :: i, itemp, j, mn, offpi, pvt real(sp) :: temp, temp2, tol3z complex(sp) :: aii ! Intrinsic Functions intrinsic :: abs,conjg,max,min,sqrt ! Executable Statements mn = min( m-offset, n ) - tol3z = sqrt(stdlib_slamch('EPSILON')) + tol3z = sqrt(stdlib${ii}$_slamch('EPSILON')) ! compute factorization. loop_20: do i = 1, mn offpi = offset + i ! determine ith pivot column and swap if necessary. - pvt = ( i-1 ) + stdlib_isamax( n-i+1, vn1( i ), 1 ) + pvt = ( i-1 ) + stdlib${ii}$_isamax( n-i+1, vn1( i ), 1_${ik}$ ) if( pvt/=i ) then - call stdlib_cswap( m, a( 1, pvt ), 1, a( 1, i ), 1 ) + call stdlib${ii}$_cswap( m, a( 1_${ik}$, pvt ), 1_${ik}$, a( 1_${ik}$, i ), 1_${ik}$ ) itemp = jpvt( pvt ) jpvt( pvt ) = jpvt( i ) jpvt( i ) = itemp @@ -44206,17 +44208,17 @@ module stdlib_linalg_lapack_c end if ! generate elementary reflector h(i). if( offpi1 ) then + if( k>1_${ik}$ ) then do j = 1, k - 1 f( k, j ) = conjg( f( k, j ) ) end do - call stdlib_cgemv( 'NO TRANSPOSE', m-rk+1, k-1, -cone, a( rk, 1 ),lda, f( k, 1 ),& - ldf, cone, a( rk, k ), 1 ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', m-rk+1, k-1, -cone, a( rk, 1_${ik}$ ),lda, f( k, 1_${ik}$ ),& + ldf, cone, a( rk, k ), 1_${ik}$ ) do j = 1, k - 1 f( k, j ) = conjg( f( k, j ) ) end do end if ! generate elementary reflector h(k). if( rk1 ) then - call stdlib_cgemv( 'CONJUGATE TRANSPOSE', m-rk+1, k-1, -tau( k ),a( rk, 1 ), lda,& - a( rk, k ), 1, czero,auxv( 1 ), 1 ) - call stdlib_cgemv( 'NO TRANSPOSE', n, k-1, cone, f( 1, 1 ), ldf,auxv( 1 ), 1, & - cone, f( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_cgemv( 'CONJUGATE TRANSPOSE', m-rk+1, k-1, -tau( k ),a( rk, 1_${ik}$ ), lda,& + a( rk, k ), 1_${ik}$, czero,auxv( 1_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n, k-1, cone, f( 1_${ik}$, 1_${ik}$ ), ldf,auxv( 1_${ik}$ ), 1_${ik}$, & + cone, f( 1_${ik}$, k ), 1_${ik}$ ) end if ! update the current row of a: ! a(rk,k+1:n) := a(rk,k+1:n) - a(rk,1:k)*f(k+1:n,1:k)**h. if( k0 ) then - itemp = nint( vn2( lsticc ),KIND=ilp) - vn1( lsticc ) = stdlib_scnrm2( m-rk, a( rk+1, lsticc ), 1 ) + if( lsticc>0_${ik}$ ) then + itemp = nint( vn2( lsticc ),KIND=${ik}$) + vn1( lsticc ) = stdlib${ii}$_scnrm2( m-rk, a( rk+1, lsticc ), 1_${ik}$ ) ! note: the computation of vn1( lsticc ) relies on the fact that - ! stdlib_snrm2 does not fail on vectors with norm below the value of - ! sqrt(stdlib_dlamch('s')) + ! stdlib${ii}$_snrm2 does not fail on vectors with norm below the value of + ! sqrt(stdlib${ii}$_dlamch('s')) vn2( lsticc ) = vn1( lsticc ) lsticc = itemp go to 60 end if return - end subroutine stdlib_claqps + end subroutine stdlib${ii}$_claqps - pure subroutine stdlib_claqr5( wantt, wantz, kacc22, n, ktop, kbot, nshfts, s,h, ldh, iloz, & + pure subroutine stdlib${ii}$_claqr5( wantt, wantz, kacc22, n, ktop, kbot, nshfts, s,h, ldh, iloz, & !! CLAQR5 called by CLAQR0 performs a !! single small-bulge multi-shift QR sweep. ihiz, z, ldz, v, ldv, u, ldu, nv,wv, ldwv, nh, wh, ldwh ) @@ -44396,7 +44398,7 @@ module stdlib_linalg_lapack_c ! -- 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) :: ihiz, iloz, kacc22, kbot, ktop, ldh, ldu, ldv, ldwh, ldwv, & + integer(${ik}$), intent(in) :: ihiz, iloz, kacc22, kbot, ktop, ldh, ldu, ldv, ldwh, ldwv, & ldz, n, nh, nshfts, nv logical(lk), intent(in) :: wantt, wantz ! Array Arguments @@ -44411,13 +44413,13 @@ module stdlib_linalg_lapack_c ! Local Scalars complex(sp) :: alpha, beta, cdum, refsum real(sp) :: h11, h12, h21, h22, safmax, safmin, scl, smlnum, tst1, tst2, ulp - integer(ilp) :: i2, i4, incol, j, jbot, jcol, jlen, jrow, jtop, k, k1, kdu, kms, krcol,& + integer(${ik}$) :: i2, i4, incol, j, jbot, jcol, jlen, jrow, jtop, k, k1, kdu, kms, krcol,& m, m22, mbot, mtop, nbmps, ndcol, ns, nu logical(lk) :: accum, bmp22 ! Intrinsic Functions intrinsic :: abs,aimag,conjg,max,min,mod,real ! Local Arrays - complex(sp) :: vt(3) + complex(sp) :: vt(3_${ik}$) ! Statement Functions real(sp) :: cabs1 ! Statement Function Definitions @@ -44430,34 +44432,34 @@ module stdlib_linalg_lapack_c if( ktop>=kbot )return ! ==== nshfts is supposed to be even, but if it is odd, ! . then simply reduce it by cone. ==== - ns = nshfts - mod( nshfts, 2 ) + ns = nshfts - mod( nshfts, 2_${ik}$ ) ! ==== machine constants for deflation ==== - safmin = stdlib_slamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) safmax = rone / safmin - call stdlib_slabad( safmin, safmax ) - ulp = stdlib_slamch( 'PRECISION' ) + call stdlib${ii}$_slabad( safmin, safmax ) + ulp = stdlib${ii}$_slamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=sp) / ulp ) ! ==== use accumulated reflections to update far-from-diagonal ! . entries ? ==== - accum = ( kacc22==1 ) .or. ( kacc22==2 ) + accum = ( kacc22==1_${ik}$ ) .or. ( kacc22==2_${ik}$ ) ! ==== clear trash ==== if( ktop+2<=kbot )h( ktop+2, ktop ) = czero ! ==== nbmps = number of 2-shift bulges in the chain ==== - nbmps = ns / 2 + nbmps = ns / 2_${ik}$ ! ==== kdu = width of slab ==== - kdu = 4*nbmps + kdu = 4_${ik}$*nbmps ! ==== create and chase chains of nbmps bulges ==== loop_180: do incol = ktop - 2*nbmps + 1, kbot - 2, 2*nbmps ! jtop = index from which updates from the right start. if( accum ) then jtop = max( ktop, incol ) else if( wantt ) then - jtop = 1 + jtop = 1_${ik}$ else jtop = ktop end if ndcol = incol + kdu - if( accum )call stdlib_claset( 'ALL', kdu, kdu, czero, cone, u, ldu ) + if( accum )call stdlib${ii}$_claset( 'ALL', kdu, kdu, czero, cone, u, ldu ) ! ==== near-the-diagonal bulge chase. the following loop ! . performs the near-the-diagonal part of a small bulge ! . multi-shift qr sweep. each 4*nbmps column diagonal @@ -44476,34 +44478,34 @@ module stdlib_linalg_lapack_c ! . (if any) must wait until the active bulges have moved ! . down the diagonal to make room. the phantom matrix ! . paradigm described above helps keep track. ==== - mtop = max( 1, ( ktop-krcol ) / 2+1 ) - mbot = min( nbmps, ( kbot-krcol-1 ) / 2 ) - m22 = mbot + 1 + mtop = max( 1_${ik}$, ( ktop-krcol ) / 2_${ik}$+1 ) + mbot = min( nbmps, ( kbot-krcol-1 ) / 2_${ik}$ ) + m22 = mbot + 1_${ik}$ bmp22 = ( mbotulp*( & + if( cabs1( h( k+2, k )-refsum*vt( 2_${ik}$ ) )+cabs1( refsum*vt( 3_${ik}$ ) )>ulp*( & cabs1( h( k, k ) )+cabs1( h( k+1,k+1 ) )+cabs1( h( k+2, k+2 ) ) ) ) & then ! ==== starting a new bulge here would @@ -44630,9 +44632,9 @@ module stdlib_linalg_lapack_c h( k+1, k ) = h( k+1, k ) - refsum h( k+2, k ) = czero h( k+3, k ) = czero - v( 1, m ) = vt( 1 ) - v( 2, m ) = vt( 2 ) - v( 3, m ) = vt( 3 ) + v( 1_${ik}$, m ) = vt( 1_${ik}$ ) + v( 2_${ik}$, m ) = vt( 2_${ik}$ ) + v( 3_${ik}$, m ) = vt( 3_${ik}$ ) end if end if end if @@ -44642,19 +44644,19 @@ module stdlib_linalg_lapack_c ! . deflation check. we still delay most of the ! . updates from the left for efficiency. ==== do j = jtop, min( kbot, k+3 ) - refsum = v( 1, m )*( h( j, k+1 )+v( 2, m )*h( j, k+2 )+v( 3, m )*h( j, k+3 & + refsum = v( 1_${ik}$, m )*( h( j, k+1 )+v( 2_${ik}$, m )*h( j, k+2 )+v( 3_${ik}$, m )*h( j, k+3 & ) ) h( j, k+1 ) = h( j, k+1 ) - refsum - h( j, k+2 ) = h( j, k+2 ) -refsum*conjg( v( 2, m ) ) - h( j, k+3 ) = h( j, k+3 ) -refsum*conjg( v( 3, m ) ) + h( j, k+2 ) = h( j, k+2 ) -refsum*conjg( v( 2_${ik}$, m ) ) + h( j, k+3 ) = h( j, k+3 ) -refsum*conjg( v( 3_${ik}$, m ) ) end do ! ==== perform update from left for subsequent ! . column. ==== - refsum = conjg( v( 1, m ) )*( h( k+1, k+1 )+conjg( v( 2, m ) )*h( k+2, k+1 )+& - conjg( v( 3, m ) )*h( k+3, k+1 ) ) + refsum = conjg( v( 1_${ik}$, m ) )*( h( k+1, k+1 )+conjg( v( 2_${ik}$, m ) )*h( k+2, k+1 )+& + conjg( v( 3_${ik}$, m ) )*h( k+3, k+1 ) ) h( k+1, k+1 ) = h( k+1, k+1 ) - refsum - h( k+2, k+1 ) = h( k+2, k+1 ) - refsum*v( 2, m ) - h( k+3, k+1 ) = h( k+3, k+1 ) - refsum*v( 3, m ) + h( k+2, k+1 ) = h( k+2, k+1 ) - refsum*v( 2_${ik}$, m ) + h( k+3, k+1 ) = h( k+3, k+1 ) - refsum*v( 3_${ik}$, m ) ! ==== the following convergence test requires that ! . the tradition small-compared-to-nearby-diagonals ! . criterion and the ahues @@ -44697,13 +44699,13 @@ module stdlib_linalg_lapack_c jbot = kbot end if do m = mbot, mtop, -1 - k = krcol + 2*( m-1 ) + k = krcol + 2_${ik}$*( m-1 ) do j = max( ktop, krcol + 2*m ), jbot - refsum = conjg( v( 1, m ) )*( h( k+1, j )+conjg( v( 2, m ) )*h( k+2, j )+& - conjg( v( 3, m ) )*h( k+3, j ) ) + refsum = conjg( v( 1_${ik}$, m ) )*( h( k+1, j )+conjg( v( 2_${ik}$, m ) )*h( k+2, j )+& + conjg( v( 3_${ik}$, m ) )*h( k+3, j ) ) h( k+1, j ) = h( k+1, j ) - refsum - h( k+2, j ) = h( k+2, j ) - refsum*v( 2, m ) - h( k+3, j ) = h( k+3, j ) - refsum*v( 3, m ) + h( k+2, j ) = h( k+2, j ) - refsum*v( 2_${ik}$, m ) + h( k+3, j ) = h( k+3, j ) - refsum*v( 3_${ik}$, m ) end do end do ! ==== accumulate orthogonal transformations. ==== @@ -44712,17 +44714,17 @@ module stdlib_linalg_lapack_c ! . with an efficient matrix-matrix ! . multiply.) ==== do m = mbot, mtop, -1 - k = krcol + 2*( m-1 ) + k = krcol + 2_${ik}$*( m-1 ) kms = k - incol - i2 = max( 1, ktop-incol ) - i2 = max( i2, kms-(krcol-incol)+1 ) - i4 = min( kdu, krcol + 2*( mbot-1 ) - incol + 5 ) + i2 = max( 1_${ik}$, ktop-incol ) + i2 = max( i2, kms-(krcol-incol)+1_${ik}$ ) + i4 = min( kdu, krcol + 2_${ik}$*( mbot-1 ) - incol + 5_${ik}$ ) do j = i2, i4 - refsum = v( 1, m )*( u( j, kms+1 )+v( 2, m )*u( j, kms+2 )+v( 3, m )*u( & + refsum = v( 1_${ik}$, m )*( u( j, kms+1 )+v( 2_${ik}$, m )*u( j, kms+2 )+v( 3_${ik}$, m )*u( & j, kms+3 ) ) u( j, kms+1 ) = u( j, kms+1 ) - refsum - u( j, kms+2 ) = u( j, kms+2 ) -refsum*conjg( v( 2, m ) ) - u( j, kms+3 ) = u( j, kms+3 ) -refsum*conjg( v( 3, m ) ) + u( j, kms+2 ) = u( j, kms+2 ) -refsum*conjg( v( 2_${ik}$, m ) ) + u( j, kms+3 ) = u( j, kms+3 ) -refsum*conjg( v( 3_${ik}$, m ) ) end do end do else if( wantz ) then @@ -44730,13 +44732,13 @@ module stdlib_linalg_lapack_c ! . now by multiplying by reflections ! . from the right. ==== do m = mbot, mtop, -1 - k = krcol + 2*( m-1 ) + k = krcol + 2_${ik}$*( m-1 ) do j = iloz, ihiz - refsum = v( 1, m )*( z( j, k+1 )+v( 2, m )*z( j, k+2 )+v( 3, m )*z( j, & + refsum = v( 1_${ik}$, m )*( z( j, k+1 )+v( 2_${ik}$, m )*z( j, k+2 )+v( 3_${ik}$, m )*z( j, & k+3 ) ) z( j, k+1 ) = z( j, k+1 ) - refsum - z( j, k+2 ) = z( j, k+2 ) -refsum*conjg( v( 2, m ) ) - z( j, k+3 ) = z( j, k+3 ) -refsum*conjg( v( 3, m ) ) + z( j, k+2 ) = z( j, k+2 ) -refsum*conjg( v( 2_${ik}$, m ) ) + z( j, k+3 ) = z( j, k+3 ) -refsum*conjg( v( 3_${ik}$, m ) ) end do end do end if @@ -44747,51 +44749,51 @@ module stdlib_linalg_lapack_c ! . well. ==== if( accum ) then if( wantt ) then - jtop = 1 + jtop = 1_${ik}$ jbot = n else jtop = ktop jbot = kbot end if - k1 = max( 1, ktop-incol ) - nu = ( kdu-max( 0, ndcol-kbot ) ) - k1 + 1 + k1 = max( 1_${ik}$, ktop-incol ) + nu = ( kdu-max( 0_${ik}$, ndcol-kbot ) ) - k1 + 1_${ik}$ ! ==== horizontal multiply ==== do jcol = min( ndcol, kbot ) + 1, jbot, nh jlen = min( nh, jbot-jcol+1 ) - call stdlib_cgemm( 'C', 'N', nu, jlen, nu, cone, u( k1, k1 ),ldu, h( incol+k1,& + call stdlib${ii}$_cgemm( 'C', 'N', nu, jlen, nu, cone, u( k1, k1 ),ldu, h( incol+k1,& jcol ), ldh, czero, wh,ldwh ) - call stdlib_clacpy( 'ALL', nu, jlen, wh, ldwh,h( incol+k1, jcol ), ldh ) + call stdlib${ii}$_clacpy( 'ALL', nu, jlen, wh, ldwh,h( incol+k1, jcol ), ldh ) end do ! ==== vertical multiply ==== do jrow = jtop, max( ktop, incol ) - 1, nv jlen = min( nv, max( ktop, incol )-jrow ) - call stdlib_cgemm( 'N', 'N', jlen, nu, nu, cone,h( jrow, incol+k1 ), ldh, u( & + call stdlib${ii}$_cgemm( 'N', 'N', jlen, nu, nu, cone,h( jrow, incol+k1 ), ldh, u( & k1, k1 ),ldu, czero, wv, ldwv ) - call stdlib_clacpy( 'ALL', jlen, nu, wv, ldwv,h( jrow, incol+k1 ), ldh ) + call stdlib${ii}$_clacpy( 'ALL', jlen, nu, wv, ldwv,h( jrow, incol+k1 ), ldh ) end do ! ==== z multiply (also vertical) ==== if( wantz ) then do jrow = iloz, ihiz, nv jlen = min( nv, ihiz-jrow+1 ) - call stdlib_cgemm( 'N', 'N', jlen, nu, nu, cone,z( jrow, incol+k1 ), ldz, & + call stdlib${ii}$_cgemm( 'N', 'N', jlen, nu, nu, cone,z( jrow, incol+k1 ), ldz, & u( k1, k1 ),ldu, czero, wv, ldwv ) - call stdlib_clacpy( 'ALL', jlen, nu, wv, ldwv,z( jrow, incol+k1 ), ldz ) + call stdlib${ii}$_clacpy( 'ALL', jlen, nu, wv, ldwv,z( jrow, incol+k1 ), ldz ) end do end if end if end do loop_180 - end subroutine stdlib_claqr5 + end subroutine stdlib${ii}$_claqr5 - pure subroutine stdlib_claqz1( ilq, ilz, k, istartm, istopm, ihi, a, lda, b,ldb, nq, qstart, & + pure subroutine stdlib${ii}$_claqz1( ilq, ilz, k, istartm, istopm, ihi, a, lda, b,ldb, nq, qstart, & !! CLAQZ1 chases a 1x1 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 complex(sp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) @@ -44801,100 +44803,100 @@ module stdlib_linalg_lapack_c complex(sp) :: s, temp if( k+1 == ihi ) then ! shift is located on the edge of the matrix, remove it - call stdlib_clartg( b( ihi, ihi ), b( ihi, ihi-1 ), c, s, temp ) + call stdlib${ii}$_clartg( b( ihi, ihi ), b( ihi, ihi-1 ), c, s, temp ) b( ihi, ihi ) = temp b( ihi, ihi-1 ) = czero - call stdlib_crot( ihi-istartm, b( istartm, ihi ), 1, b( istartm,ihi-1 ), 1, c, s ) + call stdlib${ii}$_crot( ihi-istartm, b( istartm, ihi ), 1_${ik}$, b( istartm,ihi-1 ), 1_${ik}$, c, s ) - call stdlib_crot( ihi-istartm+1, a( istartm, ihi ), 1, a( istartm,ihi-1 ), 1, c, s ) + call stdlib${ii}$_crot( ihi-istartm+1, a( istartm, ihi ), 1_${ik}$, a( istartm,ihi-1 ), 1_${ik}$, c, s ) if ( ilz ) then - call stdlib_crot( nz, z( 1, ihi-zstart+1 ), 1, z( 1, ihi-1-zstart+1 ), 1, c, s ) + call stdlib${ii}$_crot( nz, z( 1_${ik}$, ihi-zstart+1 ), 1_${ik}$, z( 1_${ik}$, ihi-1-zstart+1 ), 1_${ik}$, c, s ) end if else ! normal operation, move bulge down ! apply transformation from the right - call stdlib_clartg( b( k+1, k+1 ), b( k+1, k ), c, s, temp ) + call stdlib${ii}$_clartg( b( k+1, k+1 ), b( k+1, k ), c, s, temp ) b( k+1, k+1 ) = temp b( k+1, k ) = czero - call stdlib_crot( k+2-istartm+1, a( istartm, k+1 ), 1, a( istartm,k ), 1, c, s ) + call stdlib${ii}$_crot( k+2-istartm+1, a( istartm, k+1 ), 1_${ik}$, a( istartm,k ), 1_${ik}$, c, s ) - call stdlib_crot( k-istartm+1, b( istartm, k+1 ), 1, b( istartm, k ),1, c, s ) + call stdlib${ii}$_crot( k-istartm+1, b( istartm, k+1 ), 1_${ik}$, b( istartm, k ),1_${ik}$, c, s ) if ( ilz ) then - call stdlib_crot( nz, z( 1, k+1-zstart+1 ), 1, z( 1, k-zstart+1 ),1, c, s ) + call stdlib${ii}$_crot( nz, z( 1_${ik}$, k+1-zstart+1 ), 1_${ik}$, z( 1_${ik}$, k-zstart+1 ),1_${ik}$, c, s ) end if ! apply transformation from the left - call stdlib_clartg( a( k+1, k ), a( k+2, k ), c, s, temp ) + call stdlib${ii}$_clartg( a( k+1, k ), a( k+2, k ), c, s, temp ) a( k+1, k ) = temp a( k+2, k ) = czero - call stdlib_crot( istopm-k, a( k+1, k+1 ), lda, a( k+2, k+1 ), lda, c,s ) - call stdlib_crot( istopm-k, b( k+1, k+1 ), ldb, b( k+2, k+1 ), ldb, c,s ) + call stdlib${ii}$_crot( istopm-k, a( k+1, k+1 ), lda, a( k+2, k+1 ), lda, c,s ) + call stdlib${ii}$_crot( istopm-k, b( k+1, k+1 ), ldb, b( k+2, k+1 ), ldb, c,s ) if ( ilq ) then - call stdlib_crot( nq, q( 1, k+1-qstart+1 ), 1, q( 1, k+2-qstart+1 ), 1, c, conjg(& + call stdlib${ii}$_crot( nq, q( 1_${ik}$, k+1-qstart+1 ), 1_${ik}$, q( 1_${ik}$, k+2-qstart+1 ), 1_${ik}$, c, conjg(& s ) ) end if end if - end subroutine stdlib_claqz1 + end subroutine stdlib${ii}$_claqz1 - pure subroutine stdlib_claqz3( ilschur, ilq, ilz, n, ilo, ihi, nshifts,nblock_desired, alpha,& + pure subroutine stdlib${ii}$_claqz3( ilschur, ilq, ilz, n, ilo, ihi, nshifts,nblock_desired, alpha,& !! CLAQZ3 Executes a single multishift QZ sweep beta, a, lda, b, ldb,q, ldq, z, ldz, qc, ldqc, zc, ldzc, work,lwork, info ) ! function arguments logical(lk), intent( in ) :: ilschur, ilq, ilz - integer(ilp), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,nshifts, & + integer(${ik}$), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,nshifts, & nblock_desired, ldqc, ldzc complex(sp), intent( inout ) :: a( lda, * ), b( ldb, * ), q( ldq, * ),z( ldz, * ), qc( & ldqc, * ), zc( ldzc, * ), work( * ),alpha( * ), beta( * ) - 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) :: safmin, safmax, c, scale complex(sp) :: temp, temp2, temp3, s - info = 0 + 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( 'CLAQZ3', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'CLAQZ3', -info ) return end if ! executable statements ! get machine constants - safmin = stdlib_slamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) safmax = one/safmin - call stdlib_slabad( safmin, safmax ) + call stdlib${ii}$_slabad( safmin, safmax ) if ( ilo >= ihi ) then return end if if ( ilschur ) then - istartm = 1 + istartm = 1_${ik}$ istopm = n else istartm = ilo istopm = ihi end if ns = nshifts - npos = max( nblock_desired-ns, 1 ) + 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_claset( 'FULL', ns+1, ns+1, czero, cone, qc, ldqc ) - call stdlib_claset( 'FULL', ns, ns, czero, cone, zc, ldzc ) + call stdlib${ii}$_claset( 'FULL', ns+1, ns+1, czero, cone, qc, ldqc ) + call stdlib${ii}$_claset( 'FULL', ns, ns, czero, cone, zc, ldzc ) do i = 1, ns ! introduce the shift scale = sqrt( abs( alpha( i ) ) ) * sqrt( abs( beta( i ) ) ) @@ -44908,54 +44910,54 @@ module stdlib_linalg_lapack_c temp2 = cone temp3 = czero end if - call stdlib_clartg( temp2, temp3, c, s, temp ) - call stdlib_crot( ns, a( ilo, ilo ), lda, a( ilo+1, ilo ), lda, c,s ) - call stdlib_crot( ns, b( ilo, ilo ), ldb, b( ilo+1, ilo ), ldb, c,s ) - call stdlib_crot( ns+1, qc( 1, 1 ), 1, qc( 1, 2 ), 1, c, conjg( s ) ) + call stdlib${ii}$_clartg( temp2, temp3, c, s, temp ) + call stdlib${ii}$_crot( ns, a( ilo, ilo ), lda, a( ilo+1, ilo ), lda, c,s ) + call stdlib${ii}$_crot( ns, b( ilo, ilo ), ldb, b( ilo+1, ilo ), ldb, c,s ) + call stdlib${ii}$_crot( ns+1, qc( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, qc( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, c, conjg( s ) ) ! chase the shift down do j = 1, ns-i - call stdlib_claqz1( .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}$_claqz1( .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)' sheight = ns+1 - swidth = istopm-( ilo+ns )+1 - if ( swidth > 0 ) then - call stdlib_cgemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,a( ilo, ilo+& + swidth = istopm-( ilo+ns )+1_${ik}$ + if ( swidth > 0_${ik}$ ) then + call stdlib${ii}$_cgemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,a( ilo, ilo+& ns ), lda, czero, work, sheight ) - call stdlib_clacpy( 'ALL', sheight, swidth, work, sheight, a( ilo,ilo+ns ), lda ) + call stdlib${ii}$_clacpy( 'ALL', sheight, swidth, work, sheight, a( ilo,ilo+ns ), lda ) - call stdlib_cgemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,b( ilo, ilo+& + call stdlib${ii}$_cgemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,b( ilo, ilo+& ns ), ldb, czero, work, sheight ) - call stdlib_clacpy( 'ALL', sheight, swidth, work, sheight, b( ilo,ilo+ns ), ldb ) + call stdlib${ii}$_clacpy( 'ALL', sheight, swidth, work, sheight, b( ilo,ilo+ns ), ldb ) end if if ( ilq ) then - call stdlib_cgemm( 'N', 'N', n, sheight, sheight, cone, q( 1, ilo ),ldq, qc, ldqc, & + call stdlib${ii}$_cgemm( 'N', 'N', n, sheight, sheight, cone, q( 1_${ik}$, ilo ),ldq, qc, ldqc, & czero, work, n ) - call stdlib_clacpy( 'ALL', n, sheight, work, n, q( 1, ilo ), ldq ) + call stdlib${ii}$_clacpy( '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) sheight = ilo-1-istartm+1 swidth = ns - if ( sheight > 0 ) then - call stdlib_cgemm( 'N', 'N', sheight, swidth, swidth, cone,a( istartm, ilo ), lda, & + if ( sheight > 0_${ik}$ ) then + call stdlib${ii}$_cgemm( 'N', 'N', sheight, swidth, swidth, cone,a( istartm, ilo ), lda, & zc, ldzc, czero, work,sheight ) - call stdlib_clacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ilo ), lda ) + call stdlib${ii}$_clacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ilo ), lda ) - call stdlib_cgemm( 'N', 'N', sheight, swidth, swidth, cone,b( istartm, ilo ), ldb, & + call stdlib${ii}$_cgemm( 'N', 'N', sheight, swidth, swidth, cone,b( istartm, ilo ), ldb, & zc, ldzc, czero, work,sheight ) - call stdlib_clacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ilo ), ldb ) + call stdlib${ii}$_clacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ilo ), ldb ) end if if ( ilz ) then - call stdlib_cgemm( 'N', 'N', n, swidth, swidth, cone, z( 1, ilo ),ldz, zc, ldzc, & + call stdlib${ii}$_cgemm( 'N', 'N', n, swidth, swidth, cone, z( 1_${ik}$, ilo ),ldz, zc, ldzc, & czero, work, n ) - call stdlib_clacpy( 'ALL', n, swidth, work, n, z( 1, ilo ), ldz ) + call stdlib${ii}$_clacpy( '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 @@ -44969,15 +44971,15 @@ module stdlib_linalg_lapack_c istartb = k+1 ! istopb points to the last column we will be updating istopb = k+nblock-1 - call stdlib_claset( 'FULL', ns+np, ns+np, czero, cone, qc, ldqc ) - call stdlib_claset( 'FULL', ns+np, ns+np, czero, cone, zc, ldzc ) + call stdlib${ii}$_claset( 'FULL', ns+np, ns+np, czero, cone, qc, ldqc ) + call stdlib${ii}$_claset( 'FULL', ns+np, ns+np, czero, cone, zc, ldzc ) ! near the diagonal shift chase do i = ns-1, 0, -1 do j = 0, np-1 ! move down the block with index k+i+j, updating ! the (ns+np x ns+np) block: ! (k:k+ns+np,k:k+ns+np-1) - call stdlib_claqz1( .true., .true., k+i+j, istartb, istopb, ihi,a, lda, b, & + call stdlib${ii}$_claqz1( .true., .true., k+i+j, istartb, istopb, ihi,a, lda, b, & ldb, nblock, k+1, qc, ldqc,nblock, k, zc, ldzc ) end do end do @@ -44986,47 +44988,47 @@ module stdlib_linalg_lapack_c ! b(k+1:k+ns+np, k+ns+np:istopm) ! from the left with qc(1:ns+np,1:ns+np)' sheight = ns+np - swidth = istopm-( k+ns+np )+1 - if ( swidth > 0 ) then - call stdlib_cgemm( 'C', 'N', sheight, swidth, sheight, cone, qc,ldqc, a( k+1, k+& + swidth = istopm-( k+ns+np )+1_${ik}$ + if ( swidth > 0_${ik}$ ) then + call stdlib${ii}$_cgemm( 'C', 'N', sheight, swidth, sheight, cone, qc,ldqc, a( k+1, k+& ns+np ), lda, czero, work,sheight ) - call stdlib_clacpy( 'ALL', sheight, swidth, work, sheight, a( k+1,k+ns+np ), lda & + call stdlib${ii}$_clacpy( 'ALL', sheight, swidth, work, sheight, a( k+1,k+ns+np ), lda & ) - call stdlib_cgemm( 'C', 'N', sheight, swidth, sheight, cone, qc,ldqc, b( k+1, k+& + call stdlib${ii}$_cgemm( 'C', 'N', sheight, swidth, sheight, cone, qc,ldqc, b( k+1, k+& ns+np ), ldb, czero, work,sheight ) - call stdlib_clacpy( 'ALL', sheight, swidth, work, sheight, b( k+1,k+ns+np ), ldb & + call stdlib${ii}$_clacpy( 'ALL', sheight, swidth, work, sheight, b( k+1,k+ns+np ), ldb & ) end if if ( ilq ) then - call stdlib_cgemm( 'N', 'N', n, nblock, nblock, cone, q( 1, k+1 ),ldq, qc, ldqc, & + call stdlib${ii}$_cgemm( 'N', 'N', n, nblock, nblock, cone, q( 1_${ik}$, k+1 ),ldq, qc, ldqc, & czero, work, n ) - call stdlib_clacpy( 'ALL', n, nblock, work, n, q( 1, k+1 ), ldq ) + call stdlib${ii}$_clacpy( '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) sheight = k-istartm+1 swidth = nblock - if ( sheight > 0 ) then - call stdlib_cgemm( 'N', 'N', sheight, swidth, swidth, cone,a( istartm, k ), lda, & + if ( sheight > 0_${ik}$ ) then + call stdlib${ii}$_cgemm( 'N', 'N', sheight, swidth, swidth, cone,a( istartm, k ), lda, & zc, ldzc, czero, work,sheight ) - call stdlib_clacpy( 'ALL', sheight, swidth, work, sheight,a( istartm, k ), lda ) + call stdlib${ii}$_clacpy( 'ALL', sheight, swidth, work, sheight,a( istartm, k ), lda ) - call stdlib_cgemm( 'N', 'N', sheight, swidth, swidth, cone,b( istartm, k ), ldb, & + call stdlib${ii}$_cgemm( 'N', 'N', sheight, swidth, swidth, cone,b( istartm, k ), ldb, & zc, ldzc, czero, work,sheight ) - call stdlib_clacpy( 'ALL', sheight, swidth, work, sheight,b( istartm, k ), ldb ) + call stdlib${ii}$_clacpy( 'ALL', sheight, swidth, work, sheight,b( istartm, k ), ldb ) end if if ( ilz ) then - call stdlib_cgemm( 'N', 'N', n, nblock, nblock, cone, z( 1, k ),ldz, zc, ldzc, & + call stdlib${ii}$_cgemm( 'N', 'N', n, nblock, nblock, cone, z( 1_${ik}$, k ),ldz, zc, ldzc, & czero, work, n ) - call stdlib_clacpy( 'ALL', n, nblock, work, n, z( 1, k ), ldz ) + call stdlib${ii}$_clacpy( '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_claset( 'FULL', ns, ns, czero, cone, qc, ldqc ) - call stdlib_claset( 'FULL', ns+1, ns+1, czero, cone, zc, ldzc ) + call stdlib${ii}$_claset( 'FULL', ns, ns, czero, cone, qc, ldqc ) + call stdlib${ii}$_claset( 'FULL', ns+1, ns+1, czero, cone, zc, ldzc ) ! istartb points to the first row we will be updating istartb = ihi-ns+1 ! istopb points to the last column we will be updating @@ -45034,7 +45036,7 @@ module stdlib_linalg_lapack_c do i = 1, ns ! chase the shift down to the bottom right corner do ishift = ihi-i, ihi-1 - call stdlib_claqz1( .true., .true., ishift, istartb, istopb, ihi,a, lda, b, ldb, & + call stdlib${ii}$_claqz1( .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 @@ -45042,45 +45044,45 @@ module stdlib_linalg_lapack_c ! update a(ihi-ns+1:ihi, ihi+1:istopm) ! from the left with qc(1:ns,1:ns)' sheight = ns - swidth = istopm-( ihi+1 )+1 - if ( swidth > 0 ) then - call stdlib_cgemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,a( ihi-ns+1, & + swidth = istopm-( ihi+1 )+1_${ik}$ + if ( swidth > 0_${ik}$ ) then + call stdlib${ii}$_cgemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,a( ihi-ns+1, & ihi+1 ), lda, czero, work, sheight ) - call stdlib_clacpy( 'ALL', sheight, swidth, work, sheight,a( ihi-ns+1, ihi+1 ), lda & + call stdlib${ii}$_clacpy( 'ALL', sheight, swidth, work, sheight,a( ihi-ns+1, ihi+1 ), lda & ) - call stdlib_cgemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,b( ihi-ns+1, & + call stdlib${ii}$_cgemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,b( ihi-ns+1, & ihi+1 ), ldb, czero, work, sheight ) - call stdlib_clacpy( 'ALL', sheight, swidth, work, sheight,b( ihi-ns+1, ihi+1 ), ldb & + call stdlib${ii}$_clacpy( 'ALL', sheight, swidth, work, sheight,b( ihi-ns+1, ihi+1 ), ldb & ) end if if ( ilq ) then - call stdlib_cgemm( 'N', 'N', n, ns, ns, cone, q( 1, ihi-ns+1 ), ldq,qc, ldqc, czero,& + call stdlib${ii}$_cgemm( 'N', 'N', n, ns, ns, cone, q( 1_${ik}$, ihi-ns+1 ), ldq,qc, ldqc, czero,& work, n ) - call stdlib_clacpy( 'ALL', n, ns, work, n, q( 1, ihi-ns+1 ), ldq ) + call stdlib${ii}$_clacpy( '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) sheight = ihi-ns-istartm+1 swidth = ns+1 - if ( sheight > 0 ) then - call stdlib_cgemm( 'N', 'N', sheight, swidth, swidth, cone,a( istartm, ihi-ns ), & + if ( sheight > 0_${ik}$ ) then + call stdlib${ii}$_cgemm( 'N', 'N', sheight, swidth, swidth, cone,a( istartm, ihi-ns ), & lda, zc, ldzc, czero, work,sheight ) - call stdlib_clacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ihi-ns ), lda & + call stdlib${ii}$_clacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ihi-ns ), lda & ) - call stdlib_cgemm( 'N', 'N', sheight, swidth, swidth, cone,b( istartm, ihi-ns ), & + call stdlib${ii}$_cgemm( 'N', 'N', sheight, swidth, swidth, cone,b( istartm, ihi-ns ), & ldb, zc, ldzc, czero, work,sheight ) - call stdlib_clacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ihi-ns ), ldb & + call stdlib${ii}$_clacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ihi-ns ), ldb & ) end if if ( ilz ) then - call stdlib_cgemm( 'N', 'N', n, ns+1, ns+1, cone, z( 1, ihi-ns ), ldz,zc, ldzc, & + call stdlib${ii}$_cgemm( 'N', 'N', n, ns+1, ns+1, cone, z( 1_${ik}$, ihi-ns ), ldz,zc, ldzc, & czero, work, n ) - call stdlib_clacpy( 'ALL', n, ns+1, work, n, z( 1, ihi-ns ), ldz ) + call stdlib${ii}$_clacpy( 'ALL', n, ns+1, work, n, z( 1_${ik}$, ihi-ns ), ldz ) end if - end subroutine stdlib_claqz3 + end subroutine stdlib${ii}$_claqz3 - pure subroutine stdlib_clargv( n, x, incx, y, incy, c, incc ) + pure subroutine stdlib${ii}$_clargv( n, x, incx, y, incy, c, incc ) !! CLARGV generates a vector of complex plane rotations with real !! cosines, determined by elements of the complex vectors x and y. !! For i = 1,2,...,n @@ -45095,7 +45097,7 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(inout) :: x(*), y(*) @@ -45104,7 +45106,7 @@ module stdlib_linalg_lapack_c ! Local Scalars ! logical first - integer(ilp) :: count, i, ic, ix, iy, j + integer(${ik}$) :: count, i, ic, ix, iy, j real(sp) :: cs, d, di, dr, eps, f2, f2s, g2, g2s, safmin, safmn2, safmx2, scale complex(sp) :: f, ff, fs, g, gs, r, sn ! Intrinsic Functions @@ -45117,30 +45119,30 @@ module stdlib_linalg_lapack_c ! data first / .true. / ! Statement Function Definitions abs1( ff ) = max( abs( real( ff,KIND=sp) ), abs( aimag( ff ) ) ) - abssq( ff ) = real( ff,KIND=sp)**2 + aimag( ff )**2 + abssq( ff ) = real( ff,KIND=sp)**2_${ik}$ + aimag( ff )**2_${ik}$ ! Executable Statements ! if( first ) then ! first = .false. - 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 ! end if - ix = 1 - iy = 1 - ic = 1 + ix = 1_${ik}$ + iy = 1_${ik}$ + ic = 1_${ik}$ loop_60: do i = 1, n f = x( ix ) g = y( iy ) - ! use identical algorithm as in stdlib_clartg + ! use identical algorithm as in stdlib${ii}$_clartg scale = max( abs1( f ), abs1( g ) ) fs = f gs = g - count = 0 + count = 0_${ik}$ if( scale>=safmx2 ) then 10 continue - count = count + 1 + count = count + 1_${ik}$ fs = fs*safmn2 gs = gs*safmn2 scale = scale*safmn2 @@ -45153,7 +45155,7 @@ module stdlib_linalg_lapack_c go to 50 end if 20 continue - count = count - 1 + count = count - 1_${ik}$ fs = fs*safmx2 gs = gs*safmx2 scale = scale*safmx2 @@ -45165,14 +45167,14 @@ module stdlib_linalg_lapack_c ! this is a rare case: f is very small. if( f==czero ) then cs = zero - r = stdlib_slapy2( real( g,KIND=sp), aimag( g ) ) + r = stdlib${ii}$_slapy2( real( g,KIND=sp), aimag( g ) ) ! do complex/real division explicitly with two real ! divisions - d = stdlib_slapy2( real( gs,KIND=sp), aimag( gs ) ) + d = stdlib${ii}$_slapy2( real( gs,KIND=sp), aimag( gs ) ) sn = cmplx( real( gs,KIND=sp) / d, -aimag( gs ) / d,KIND=sp) go to 50 end if - f2s = stdlib_slapy2( real( fs,KIND=sp), aimag( fs ) ) + f2s = stdlib${ii}$_slapy2( real( fs,KIND=sp), aimag( fs ) ) ! g2 and g2s are accurate ! g2 is at least safmin, and g2s is at least safmn2 g2s = sqrt( g2 ) @@ -45187,12 +45189,12 @@ module stdlib_linalg_lapack_c ! make sure abs(ff) = 1 ! do complex/real division explicitly with 2 real divisions if( abs1( f )>one ) then - d = stdlib_slapy2( real( f,KIND=sp), aimag( f ) ) + d = stdlib${ii}$_slapy2( real( f,KIND=sp), aimag( f ) ) ff = cmplx( real( f,KIND=sp) / d, aimag( f ) / d,KIND=sp) else dr = safmx2*real( f,KIND=sp) di = safmx2*aimag( f ) - d = stdlib_slapy2( dr, di ) + d = stdlib${ii}$_slapy2( dr, di ) ff = cmplx( dr / d, di / d,KIND=sp) end if sn = ff*cmplx( real( gs,KIND=sp) / g2s, -aimag( gs ) / g2s,KIND=sp) @@ -45210,8 +45212,8 @@ module stdlib_linalg_lapack_c ! do complex/real division explicitly with two real divisions sn = cmplx( real( r,KIND=sp) / d, aimag( r ) / d,KIND=sp) sn = sn*conjg( gs ) - if( count/=0 ) then - if( count>0 ) then + if( count/=0_${ik}$ ) then + if( count>0_${ik}$ ) then do j = 1, count r = r*safmx2 end do @@ -45231,10 +45233,10 @@ module stdlib_linalg_lapack_c ix = ix + incx end do loop_60 return - end subroutine stdlib_clargv + end subroutine stdlib${ii}$_clargv - pure subroutine stdlib_clarrv( n, vl, vu, d, l, pivmin,isplit, m, dol, dou, minrgp,rtol1, & + pure subroutine stdlib${ii}$_clarrv( n, vl, vu, d, l, pivmin,isplit, m, dol, dou, minrgp,rtol1, & !! CLARRV computes the eigenvectors of the tridiagonal matrix !! T = L D L**T given L, D and APPROXIMATIONS to the eigenvalues of L D L**T. !! The input eigenvalues should have been computed by SLARRE. @@ -45243,31 +45245,31 @@ module stdlib_linalg_lapack_c ! -- 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) :: dol, dou, ldz, m, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: dol, dou, ldz, m, n + integer(${ik}$), intent(out) :: info real(sp), intent(in) :: minrgp, pivmin, vl, vu real(sp), intent(inout) :: rtol1, rtol2 ! Array Arguments - integer(ilp), intent(in) :: iblock(*), indexw(*), isplit(*) - integer(ilp), intent(out) :: isuppz(*), iwork(*) + integer(${ik}$), intent(in) :: iblock(*), indexw(*), isplit(*) + integer(${ik}$), intent(out) :: isuppz(*), iwork(*) real(sp), intent(inout) :: d(*), l(*), w(*), werr(*), wgap(*) real(sp), intent(in) :: gers(*) real(sp), intent(out) :: work(*) complex(sp), intent(out) :: z(ldz,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: maxitr = 10 + integer(${ik}$), parameter :: maxitr = 10_${ik}$ ! Local Scalars logical(lk) :: eskip, needbs, stp2ii, tryrqc, usedbs, usedrq - integer(ilp) :: done, i, ibegin, idone, iend, ii, iindc1, iindc2, iindr, iindwk, iinfo,& + integer(${ik}$) :: done, i, ibegin, idone, iend, ii, iindc1, iindc2, iindr, iindwk, iinfo,& im, in, indeig, indld, indlld, indwrk, isupmn, isupmx, iter, itmp1, j, jblk, k, & miniwsize, minwsize, nclus, ndepth, negcnt, newcls, newfst, newftt, newlst, newsiz, & offset, oldcls, oldfst, oldien, oldlst, oldncl, p, parity, q, wbegin, wend, windex, & windmn, windpl, zfrom, zto, zusedl, zusedu, zusedw - integer(ilp) :: indin1, indin2 + integer(${ik}$) :: indin1, indin2 real(sp) :: bstres, bstw, eps, fudge, gap, gaptol, gl, gu, lambda, left, lgap, mingma, & nrminv, resid, rgap, right, rqcorr, rqtol, savgap, sgndef, sigma, spdiam, ssigma, tau, & tmp, tol, ztz @@ -45275,35 +45277,35 @@ module stdlib_linalg_lapack_c intrinsic :: abs,real,max,min intrinsic :: cmplx ! Executable Statements - info = 0 + info = 0_${ik}$ ! quick return if possible - if( (n<=0).or.(m<=0) ) then + if( (n<=0_${ik}$).or.(m<=0_${ik}$) ) then return end if ! the first n entries of work are reserved for the eigenvalues indld = n+1 - indlld= 2*n+1 - indin1 = 3*n + 1 - indin2 = 4*n + 1 - indwrk = 5*n + 1 - minwsize = 12 * n + indlld= 2_${ik}$*n+1 + indin1 = 3_${ik}$*n + 1_${ik}$ + indin2 = 4_${ik}$*n + 1_${ik}$ + indwrk = 5_${ik}$*n + 1_${ik}$ + minwsize = 12_${ik}$ * n do i= 1,minwsize work( i ) = zero end do ! iwork(iindr+1:iindr+n) hold the twist indices r for the ! factorization used to compute the fp vector - iindr = 0 + iindr = 0_${ik}$ ! iwork(iindc1+1:iinc2+n) are used to store the clusters of the current ! layer and the one above. iindc1 = n - iindc2 = 2*n - iindwk = 3*n + 1 - miniwsize = 7 * n + iindc2 = 2_${ik}$*n + iindwk = 3_${ik}$*n + 1_${ik}$ + miniwsize = 7_${ik}$ * n do i= 1,miniwsize - iwork( i ) = 0 + iwork( i ) = 0_${ik}$ end do - zusedl = 1 - if(dol>1) then + zusedl = 1_${ik}$ + if(dol>1_${ik}$) then ! set lower bound for use of z zusedl = dol-1 endif @@ -45313,13 +45315,13 @@ module stdlib_linalg_lapack_c zusedu = dou+1 endif ! the width of the part of z that is used - zusedw = zusedu - zusedl + 1 - call stdlib_claset( 'FULL', n, zusedw, czero, czero,z(1,zusedl), ldz ) - eps = stdlib_slamch( 'PRECISION' ) + zusedw = zusedu - zusedl + 1_${ik}$ + call stdlib${ii}$_claset( 'FULL', n, zusedw, czero, czero,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 @@ -45333,54 +45335,54 @@ module stdlib_linalg_lapack_c ! 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 + im = wend - wbegin + 1_${ik}$ ! this is for a 1x1 block if( ibegin==iend ) then done = done+1 z( ibegin, wbegin ) = cmplx( one, zero,KIND=sp) - 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) @@ -45389,24 +45391,24 @@ module stdlib_linalg_lapack_c ! 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 + ndepth = 0_${ik}$ ! parity is either 1 or 0 - parity = 1 + 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 + 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 @@ -45432,30 +45434,30 @@ module stdlib_linalg_lapack_c 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 ! 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 do k = 1, in - 1 @@ -45465,7 +45467,7 @@ module stdlib_linalg_lapack_c d( iend ) = real( z( iend, j ),KIND=sp) sigma = real( z( iend, j+1 ),KIND=sp) ! set the corresponding entries in z to zero - call stdlib_claset( 'FULL', in, 2, czero, czero,z( ibegin, j), ldz ) + call stdlib${ii}$_claset( 'FULL', in, 2_${ik}$, czero, czero,z( ibegin, j), ldz ) end if ! compute dl and dll of current rrr @@ -45474,7 +45476,7 @@ module stdlib_linalg_lapack_c 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 ) @@ -45482,29 +45484,29 @@ module stdlib_linalg_lapack_c ! 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 @@ -45521,7 +45523,7 @@ module stdlib_linalg_lapack_c ! 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 @@ -45532,25 +45534,25 @@ module stdlib_linalg_lapack_c 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. @@ -45561,7 +45563,7 @@ module stdlib_linalg_lapack_c ! 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 ) @@ -45572,13 +45574,13 @@ module stdlib_linalg_lapack_c ! 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 @@ -45589,17 +45591,17 @@ module stdlib_linalg_lapack_c ! 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*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,work( indin1 ), work( indin2 ),work( indwrk ), iinfo ) - ! in the complex case, stdlib_slarrf cannot write + ! in the complex case, stdlib${ii}$_slarrf cannot write ! the new rrr directly into z and needs an intermediate ! workspace do k = 1, in-1 @@ -45609,8 +45611,8 @@ module stdlib_linalg_lapack_c end do z( iend, newftt ) =cmplx( work( indin1+in-1 ), zero,KIND=sp) - 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 ) = cmplx( ssigma, zero,KIND=sp) @@ -45618,10 +45620,10 @@ module stdlib_linalg_lapack_c ! 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 @@ -45630,24 +45632,24 @@ module stdlib_linalg_lapack_c ! 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. @@ -45664,7 +45666,7 @@ module stdlib_linalg_lapack_c ! 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 ) @@ -45686,7 +45688,7 @@ module stdlib_linalg_lapack_c 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. @@ -45695,7 +45697,7 @@ module stdlib_linalg_lapack_c 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 @@ -45719,34 +45721,34 @@ module stdlib_linalg_lapack_c ! 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_clar1v( in, 1, in, lambda, d( ibegin ),l( ibegin ), work(& + call stdlib${ii}$_clar1v( 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 @@ -45866,25 +45868,25 @@ module stdlib_linalg_lapack_c 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_clarrv + end subroutine stdlib${ii}$_clarrv - pure subroutine stdlib_clatdf( ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv,jpiv ) + pure subroutine stdlib${ii}$_clatdf( ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv,jpiv ) !! CLATDF computes the contribution to the reciprocal Dif-estimate !! by solving for x in Z * x = b, where b is chosen such that the norm !! of x is as large as possible. It is assumed that LU decomposition @@ -45897,30 +45899,30 @@ module stdlib_linalg_lapack_c ! -- 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) :: ijob, ldz, n + integer(${ik}$), intent(in) :: ijob, ldz, n real(sp), intent(inout) :: rdscal, rdsum ! Array Arguments - integer(ilp), intent(in) :: ipiv(*), jpiv(*) + integer(${ik}$), intent(in) :: ipiv(*), jpiv(*) complex(sp), intent(inout) :: rhs(*), z(ldz,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: maxdim = 2 + integer(${ik}$), parameter :: maxdim = 2_${ik}$ ! Local Scalars - integer(ilp) :: i, info, j, k + integer(${ik}$) :: i, info, j, k real(sp) :: rtemp, scale, sminu, splus complex(sp) :: bm, bp, pmone, temp ! Local Arrays real(sp) :: rwork(maxdim) - complex(sp) :: work(4*maxdim), xm(maxdim), xp(maxdim) + complex(sp) :: work(4_${ik}$*maxdim), xm(maxdim), xp(maxdim) ! Intrinsic Functions intrinsic :: abs,real,sqrt ! Executable Statements - if( ijob/=2 ) then + if( ijob/=2_${ik}$ ) then ! apply permutations ipiv to rhs - call stdlib_claswp( 1, rhs, ldz, 1, n-1, ipiv, 1 ) + call stdlib${ii}$_claswp( 1_${ik}$, rhs, ldz, 1_${ik}$, n-1, ipiv, 1_${ik}$ ) ! solve for l-part choosing rhs either to +1 or -1. pmone = -cone loop_10: do j = 1, n - 1 @@ -45929,9 +45931,9 @@ module stdlib_linalg_lapack_c splus = one ! lockahead for l- part rhs(1:n-1) = +-1 ! splus and smin computed more efficiently than in bsolve[1]. - splus = splus + real( stdlib_cdotc( n-j, z( j+1, j ), 1, z( j+1,j ), 1 ),KIND=sp) + splus = splus + real( stdlib${ii}$_cdotc( n-j, z( j+1, j ), 1_${ik}$, z( j+1,j ), 1_${ik}$ ),KIND=sp) - sminu = real( stdlib_cdotc( n-j, z( j+1, j ), 1, rhs( j+1 ), 1 ),KIND=sp) + sminu = real( stdlib${ii}$_cdotc( n-j, z( j+1, j ), 1_${ik}$, rhs( j+1 ), 1_${ik}$ ),KIND=sp) splus = splus*real( rhs( j ),KIND=sp) if( splus>sminu ) then rhs( j ) = bp @@ -45948,13 +45950,13 @@ module stdlib_linalg_lapack_c end if ! compute the remaining r.h.s. temp = -rhs( j ) - call stdlib_caxpy( n-j, temp, z( j+1, j ), 1, rhs( j+1 ), 1 ) + call stdlib${ii}$_caxpy( n-j, temp, z( j+1, j ), 1_${ik}$, rhs( j+1 ), 1_${ik}$ ) end do loop_10 ! solve for u- part, lockahead for rhs(n) = +-1. this is not done ! in bsolve and will hopefully give us a better estimate because ! any ill-conditioning of the original matrix is transferred to u ! and not to l. u(n, n) is an approximation to sigma_min(lu). - call stdlib_ccopy( n-1, rhs, 1, work, 1 ) + call stdlib${ii}$_ccopy( n-1, rhs, 1_${ik}$, work, 1_${ik}$ ) work( n ) = rhs( n ) + cone rhs( n ) = rhs( n ) - cone splus = zero @@ -45970,35 +45972,35 @@ module stdlib_linalg_lapack_c splus = splus + abs( work( i ) ) sminu = sminu + abs( rhs( i ) ) end do - if( splus>sminu )call stdlib_ccopy( n, work, 1, rhs, 1 ) + if( splus>sminu )call stdlib${ii}$_ccopy( n, work, 1_${ik}$, rhs, 1_${ik}$ ) ! apply the permutations jpiv to the computed solution (rhs) - call stdlib_claswp( 1, rhs, ldz, 1, n-1, jpiv, -1 ) + call stdlib${ii}$_claswp( 1_${ik}$, rhs, ldz, 1_${ik}$, n-1, jpiv, -1_${ik}$ ) ! compute the sum of squares - call stdlib_classq( n, rhs, 1, rdscal, rdsum ) + call stdlib${ii}$_classq( n, rhs, 1_${ik}$, rdscal, rdsum ) return end if ! entry ijob = 2 ! compute approximate nullvector xm of z - call stdlib_cgecon( 'I', n, z, ldz, one, rtemp, work, rwork, info ) - call stdlib_ccopy( n, work( n+1 ), 1, xm, 1 ) + call stdlib${ii}$_cgecon( 'I', n, z, ldz, one, rtemp, work, rwork, info ) + call stdlib${ii}$_ccopy( n, work( n+1 ), 1_${ik}$, xm, 1_${ik}$ ) ! compute rhs - call stdlib_claswp( 1, xm, ldz, 1, n-1, ipiv, -1 ) - temp = cone / sqrt( stdlib_cdotc( n, xm, 1, xm, 1 ) ) - call stdlib_cscal( n, temp, xm, 1 ) - call stdlib_ccopy( n, xm, 1, xp, 1 ) - call stdlib_caxpy( n, cone, rhs, 1, xp, 1 ) - call stdlib_caxpy( n, -cone, xm, 1, rhs, 1 ) - call stdlib_cgesc2( n, z, ldz, rhs, ipiv, jpiv, scale ) - call stdlib_cgesc2( n, z, ldz, xp, ipiv, jpiv, scale ) - if( stdlib_scasum( n, xp, 1 )>stdlib_scasum( n, rhs, 1 ) )call stdlib_ccopy( n, xp, 1, & - rhs, 1 ) + call stdlib${ii}$_claswp( 1_${ik}$, xm, ldz, 1_${ik}$, n-1, ipiv, -1_${ik}$ ) + temp = cone / sqrt( stdlib${ii}$_cdotc( n, xm, 1_${ik}$, xm, 1_${ik}$ ) ) + call stdlib${ii}$_cscal( n, temp, xm, 1_${ik}$ ) + call stdlib${ii}$_ccopy( n, xm, 1_${ik}$, xp, 1_${ik}$ ) + call stdlib${ii}$_caxpy( n, cone, rhs, 1_${ik}$, xp, 1_${ik}$ ) + call stdlib${ii}$_caxpy( n, -cone, xm, 1_${ik}$, rhs, 1_${ik}$ ) + call stdlib${ii}$_cgesc2( n, z, ldz, rhs, ipiv, jpiv, scale ) + call stdlib${ii}$_cgesc2( n, z, ldz, xp, ipiv, jpiv, scale ) + if( stdlib${ii}$_scasum( n, xp, 1_${ik}$ )>stdlib${ii}$_scasum( n, rhs, 1_${ik}$ ) )call stdlib${ii}$_ccopy( n, xp, 1_${ik}$, & + rhs, 1_${ik}$ ) ! compute the sum of squares - call stdlib_classq( n, rhs, 1, rdscal, rdsum ) + call stdlib${ii}$_classq( n, rhs, 1_${ik}$, rdscal, rdsum ) return - end subroutine stdlib_clatdf + end subroutine stdlib${ii}$_clatdf - pure subroutine stdlib_claunhr_col_getrfnp( m, n, a, lda, d, info ) + pure subroutine stdlib${ii}$_claunhr_col_getrfnp( m, n, a, lda, d, info ) !! CLAUNHR_COL_GETRFNP computes the modified LU factorization without !! pivoting of a complex general M-by-N matrix A. The factorization has !! the form: @@ -46036,52 +46038,52 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: a(lda,*) complex(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}$, 'CLAUNHR_COL_GETRFNP', ' ', m, n, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=min( m, n ) ) then ! use unblocked code. - call stdlib_claunhr_col_getrfnp2( m, n, a, lda, d, info ) + call stdlib${ii}$_claunhr_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_claunhr_col_getrfnp2( m-j+1, jb, a( j, j ), lda,d( j ), iinfo ) + call stdlib${ii}$_claunhr_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_ctrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, cone,& + call stdlib${ii}$_ctrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, cone,& a( j, j ), lda, a( j, j+jb ),lda ) if( j+jb<=m ) then ! update trailing submatrix. - call stdlib_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& cone, a( j+jb, j ), lda,a( j, j+jb ), lda, cone, a( j+jb, j+jb ),lda ) end if @@ -46089,10 +46091,10 @@ module stdlib_linalg_lapack_c end do end if return - end subroutine stdlib_claunhr_col_getrfnp + end subroutine stdlib${ii}$_claunhr_col_getrfnp - pure subroutine stdlib_cpbcon( uplo, n, kd, ab, ldab, anorm, rcond, work,rwork, info ) + pure subroutine stdlib${ii}$_cpbcon( uplo, n, kd, ab, ldab, anorm, rcond, work,rwork, info ) !! CPBCON estimates the reciprocal of the condition number (in the !! 1-norm) of a complex Hermitian positive definite band matrix using !! the Cholesky factorization A = U**H*U or A = L*L**H computed by @@ -46105,8 +46107,8 @@ module stdlib_linalg_lapack_c ! -- 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(in) :: anorm real(sp), intent(out) :: rcond ! Array Arguments @@ -46118,11 +46120,11 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: upper character :: normin - integer(ilp) :: ix, kase + integer(${ik}$) :: ix, kase real(sp) :: ainvnm, scale, scalel, scaleu, smlnum complex(sp) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,aimag,real ! Statement Functions @@ -46131,61 +46133,61 @@ module stdlib_linalg_lapack_c cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) ) ! 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( ldabeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_cpbtrs( uplo, n, kd, 1, afb, ldafb, work, n, info ) - call stdlib_caxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_cpbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work, n, info ) + call stdlib${ii}$_caxpy( n, cone, work, 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 @@ -46364,22 +46366,22 @@ module stdlib_linalg_lapack_c rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**h). - call stdlib_cpbtrs( uplo, n, kd, 1, afb, ldafb, work, n, info ) + call stdlib${ii}$_cpbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do - else if( kase==2 ) then + else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_cpbtrs( uplo, n, kd, 1, afb, ldafb, work, n, info ) + call stdlib${ii}$_cpbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work, n, info ) end if go to 100 end if @@ -46391,10 +46393,10 @@ module stdlib_linalg_lapack_c if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_cpbrfs + end subroutine stdlib${ii}$_cpbrfs - pure subroutine stdlib_cpbtrf( uplo, n, kd, ab, ldab, info ) + pure subroutine stdlib${ii}$_cpbtrf( uplo, n, kd, ab, ldab, info ) !! CPBTRF computes the Cholesky factorization of a complex Hermitian !! positive definite band matrix A. !! The factorization has the form @@ -46406,50 +46408,50 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: ab(ldab,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: nbmax = 32 - integer(ilp), parameter :: ldwork = nbmax+1 + integer(${ik}$), parameter :: nbmax = 32_${ik}$ + integer(${ik}$), parameter :: ldwork = nbmax+1 ! Local Scalars - integer(ilp) :: i, i2, i3, ib, ii, j, jj, nb + integer(${ik}$) :: i, i2, i3, ib, ii, j, jj, nb ! Local Arrays complex(sp) :: work(ldwork,nbmax) ! Intrinsic Functions intrinsic :: min ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( ( .not.stdlib_lsame( uplo, 'U' ) ) .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( ldabkd ) then + if( nb<=1_${ik}$ .or. nb>kd ) then ! use unblocked code - call stdlib_cpbtf2( uplo, n, kd, ab, ldab, info ) + call stdlib${ii}$_cpbtf2( uplo, n, kd, ab, ldab, info ) else ! use blocked code if( stdlib_lsame( uplo, 'U' ) ) then @@ -46466,9 +46468,9 @@ module stdlib_linalg_lapack_c loop_70: do i = 1, n, nb ib = min( nb, n-i+1 ) ! factorize the diagonal block - call stdlib_cpotf2( uplo, ib, ab( kd+1, i ), ldab-1, ii ) - if( ii/=0 ) then - info = i + ii - 1 + call stdlib${ii}$_cpotf2( uplo, ib, ab( kd+1, i ), ldab-1, ii ) + if( ii/=0_${ik}$ ) then + info = i + ii - 1_${ik}$ go to 150 end if if( i+ib<=n ) then @@ -46485,15 +46487,15 @@ module stdlib_linalg_lapack_c ! lies outside the band. i2 = min( kd-ib, n-i-ib+1 ) i3 = min( ib, n-i-kd+1 ) - if( i2>0 ) then + if( i2>0_${ik}$ ) then ! update a12 - call stdlib_ctrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', & + call stdlib${ii}$_ctrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', & ib, i2, cone,ab( kd+1, i ), ldab-1,ab( kd+1-ib, i+ib ), ldab-1 ) ! update a22 - call stdlib_cherk( 'UPPER', 'CONJUGATE TRANSPOSE', i2, ib,-one, ab( kd+& - 1-ib, i+ib ), ldab-1, one,ab( kd+1, i+ib ), ldab-1 ) + call stdlib${ii}$_cherk( 'UPPER', 'CONJUGATE TRANSPOSE', i2, ib,-one, ab( kd+& + 1_${ik}$-ib, i+ib ), ldab-1, one,ab( kd+1, i+ib ), ldab-1 ) end if - if( i3>0 ) then + if( i3>0_${ik}$ ) then ! copy the lower triangle of a13 into the work array. do jj = 1, i3 do ii = jj, ib @@ -46501,14 +46503,14 @@ module stdlib_linalg_lapack_c end do end do ! update a13 (in the work array). - call stdlib_ctrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', & + call stdlib${ii}$_ctrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', & ib, i3, cone,ab( kd+1, i ), ldab-1, work, ldwork ) ! update a23 - if( i2>0 )call stdlib_cgemm( 'CONJUGATE TRANSPOSE','NO TRANSPOSE', i2, & - i3, ib, -cone,ab( kd+1-ib, i+ib ), ldab-1, work,ldwork, cone, ab( 1+ib, & + if( i2>0_${ik}$ )call stdlib${ii}$_cgemm( 'CONJUGATE TRANSPOSE','NO TRANSPOSE', i2, & + i3, ib, -cone,ab( kd+1-ib, i+ib ), ldab-1, work,ldwork, cone, ab( 1_${ik}$+ib, & i+kd ),ldab-1 ) ! update a33 - call stdlib_cherk( 'UPPER', 'CONJUGATE TRANSPOSE', i3, ib,-one, work, & + call stdlib${ii}$_cherk( 'UPPER', 'CONJUGATE TRANSPOSE', i3, ib,-one, work, & ldwork, one,ab( kd+1, i+kd ), ldab-1 ) ! copy the lower triangle of a13 back into place. do jj = 1, i3 @@ -46533,9 +46535,9 @@ module stdlib_linalg_lapack_c loop_140: do i = 1, n, nb ib = min( nb, n-i+1 ) ! factorize the diagonal block - call stdlib_cpotf2( uplo, ib, ab( 1, i ), ldab-1, ii ) - if( ii/=0 ) then - info = i + ii - 1 + call stdlib${ii}$_cpotf2( uplo, ib, ab( 1_${ik}$, i ), ldab-1, ii ) + if( ii/=0_${ik}$ ) then + info = i + ii - 1_${ik}$ go to 150 end if if( i+ib<=n ) then @@ -46552,15 +46554,15 @@ module stdlib_linalg_lapack_c ! lies outside the band. i2 = min( kd-ib, n-i-ib+1 ) i3 = min( ib, n-i-kd+1 ) - if( i2>0 ) then + if( i2>0_${ik}$ ) then ! update a21 - call stdlib_ctrsm( 'RIGHT', 'LOWER','CONJUGATE TRANSPOSE', 'NON-UNIT', & - i2,ib, cone, ab( 1, i ), ldab-1,ab( 1+ib, i ), ldab-1 ) + call stdlib${ii}$_ctrsm( 'RIGHT', 'LOWER','CONJUGATE TRANSPOSE', 'NON-UNIT', & + i2,ib, cone, ab( 1_${ik}$, i ), ldab-1,ab( 1_${ik}$+ib, i ), ldab-1 ) ! update a22 - call stdlib_cherk( 'LOWER', 'NO TRANSPOSE', i2, ib, -one,ab( 1+ib, i ), & - ldab-1, one,ab( 1, i+ib ), ldab-1 ) + call stdlib${ii}$_cherk( 'LOWER', 'NO TRANSPOSE', i2, ib, -one,ab( 1_${ik}$+ib, i ), & + ldab-1, one,ab( 1_${ik}$, i+ib ), ldab-1 ) end if - if( i3>0 ) then + if( i3>0_${ik}$ ) then ! copy the upper triangle of a31 into the work array. do jj = 1, ib do ii = 1, min( jj, i3 ) @@ -46568,15 +46570,15 @@ module stdlib_linalg_lapack_c end do end do ! update a31 (in the work array). - call stdlib_ctrsm( 'RIGHT', 'LOWER','CONJUGATE TRANSPOSE', 'NON-UNIT', & - i3,ib, cone, ab( 1, i ), ldab-1, work,ldwork ) + call stdlib${ii}$_ctrsm( 'RIGHT', 'LOWER','CONJUGATE TRANSPOSE', 'NON-UNIT', & + i3,ib, cone, ab( 1_${ik}$, i ), ldab-1, work,ldwork ) ! update a32 - if( i2>0 )call stdlib_cgemm( 'NO TRANSPOSE','CONJUGATE TRANSPOSE', i3, & - i2, ib,-cone, work, ldwork, ab( 1+ib, i ),ldab-1, cone, ab( 1+kd-ib, i+& + if( i2>0_${ik}$ )call stdlib${ii}$_cgemm( 'NO TRANSPOSE','CONJUGATE TRANSPOSE', i3, & + i2, ib,-cone, work, ldwork, ab( 1_${ik}$+ib, i ),ldab-1, cone, ab( 1_${ik}$+kd-ib, i+& ib ),ldab-1 ) ! update a33 - call stdlib_cherk( 'LOWER', 'NO TRANSPOSE', i3, ib, -one,work, ldwork, & - one, ab( 1, i+kd ),ldab-1 ) + call stdlib${ii}$_cherk( 'LOWER', 'NO TRANSPOSE', i3, ib, -one,work, ldwork, & + one, ab( 1_${ik}$, i+kd ),ldab-1 ) ! copy the upper triangle of a31 back into place. do jj = 1, ib do ii = 1, min( jj, i3 ) @@ -46591,10 +46593,10 @@ module stdlib_linalg_lapack_c return 150 continue return - end subroutine stdlib_cpbtrf + end subroutine stdlib${ii}$_cpbtrf - pure subroutine stdlib_cpftrs( transr, uplo, n, nrhs, a, b, ldb, info ) + pure subroutine stdlib${ii}$_cpftrs( transr, uplo, n, nrhs, a, b, ldb, info ) !! CPFTRS solves a system of linear equations A*X = B with a Hermitian !! positive definite matrix A using the Cholesky factorization !! A = U**H*U or A = L*L**H computed by CPFTRF. @@ -46603,10 +46605,10 @@ module stdlib_linalg_lapack_c ! -- 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) :: ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments - complex(sp), intent(in) :: a(0:*) + complex(sp), intent(in) :: a(0_${ik}$:*) complex(sp), intent(inout) :: b(ldb,*) ! ===================================================================== @@ -46616,39 +46618,39 @@ module stdlib_linalg_lapack_c intrinsic :: max ! 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, 'C' ) ) 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( nrhs<0 ) then - info = -4 - else if( ldbeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_cpotrs( uplo, n, 1, af, ldaf, work, n, info ) - call stdlib_caxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_cpotrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info ) + call stdlib${ii}$_caxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -46911,22 +46913,22 @@ module stdlib_linalg_lapack_c rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**h). - call stdlib_cpotrs( uplo, n, 1, af, ldaf, work, n, info ) + call stdlib${ii}$_cpotrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do - else if( kase==2 ) then + else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_cpotrs( uplo, n, 1, af, ldaf, work, n, info ) + call stdlib${ii}$_cpotrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info ) end if go to 100 end if @@ -46938,10 +46940,10 @@ module stdlib_linalg_lapack_c if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_cporfs + end subroutine stdlib${ii}$_cporfs - pure subroutine stdlib_cpotrf( uplo, n, a, lda, info ) + pure subroutine stdlib${ii}$_cpotrf( uplo, n, a, lda, info ) !! CPOTRF computes the Cholesky factorization of a complex Hermitian !! positive definite matrix A. !! The factorization has the form @@ -46954,8 +46956,8 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: a(lda,*) ! ===================================================================== @@ -46963,31 +46965,31 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: upper - integer(ilp) :: j, jb, nb + integer(${ik}$) :: j, jb, nb ! Intrinsic Functions intrinsic :: max,min ! 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}$, 'CPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code. - call stdlib_cpotrf2( uplo, n, a, lda, info ) + call stdlib${ii}$_cpotrf2( uplo, n, a, lda, info ) else ! use blocked code. if( upper ) then @@ -46996,15 +46998,15 @@ module stdlib_linalg_lapack_c ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) - call stdlib_cherk( 'UPPER', 'CONJUGATE TRANSPOSE', jb, j-1,-one, a( 1, j ), & + call stdlib${ii}$_cherk( 'UPPER', 'CONJUGATE TRANSPOSE', jb, j-1,-one, a( 1_${ik}$, j ), & lda, one, a( j, j ), lda ) - call stdlib_cpotrf2( 'UPPER', jb, a( j, j ), lda, info ) + call stdlib${ii}$_cpotrf2( 'UPPER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block row. - call stdlib_cgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', jb,n-j-jb+1, j-1,& - -cone, a( 1, j ), lda,a( 1, j+jb ), lda, cone, a( j, j+jb ),lda ) - call stdlib_ctrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', jb, & + call stdlib${ii}$_cgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', jb,n-j-jb+1, j-1,& + -cone, a( 1_${ik}$, j ), lda,a( 1_${ik}$, j+jb ), lda, cone, a( j, j+jb ),lda ) + call stdlib${ii}$_ctrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', jb, & n-j-jb+1, cone, a( j, j ),lda, a( j, j+jb ), lda ) end if end do @@ -47014,15 +47016,15 @@ module stdlib_linalg_lapack_c ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) - call stdlib_cherk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1 ), lda, one,& + call stdlib${ii}$_cherk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1_${ik}$ ), lda, one,& a( j, j ), lda ) - call stdlib_cpotrf2( 'LOWER', jb, a( j, j ), lda, info ) + call stdlib${ii}$_cpotrf2( 'LOWER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block column. - call stdlib_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',n-j-jb+1, jb, j-1,& - -cone, a( j+jb, 1 ),lda, a( j, 1 ), lda, cone, a( j+jb, j ),lda ) - call stdlib_ctrsm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', n-j-& + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',n-j-jb+1, jb, j-1,& + -cone, a( j+jb, 1_${ik}$ ),lda, a( j, 1_${ik}$ ), lda, cone, a( j+jb, j ),lda ) + call stdlib${ii}$_ctrsm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', n-j-& jb+1, jb, cone, a( j, j ),lda, a( j+jb, j ), lda ) end if end do @@ -47030,13 +47032,13 @@ module stdlib_linalg_lapack_c end if go to 40 30 continue - info = info + j - 1 + info = info + j - 1_${ik}$ 40 continue return - end subroutine stdlib_cpotrf + end subroutine stdlib${ii}$_cpotrf - pure subroutine stdlib_cpotri( uplo, n, a, lda, info ) + pure subroutine stdlib${ii}$_cpotri( uplo, n, a, lda, info ) !! CPOTRI computes the inverse of a complex Hermitian positive definite !! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H !! computed by CPOTRF. @@ -47045,8 +47047,8 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: a(lda,*) ! ===================================================================== @@ -47054,30 +47056,30 @@ module stdlib_linalg_lapack_c intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda0 )return ! form inv(u) * inv(u)**h or inv(l)**h * inv(l). - call stdlib_clauum( uplo, n, a, lda, info ) + call stdlib${ii}$_clauum( uplo, n, a, lda, info ) return - end subroutine stdlib_cpotri + end subroutine stdlib${ii}$_cpotri - pure subroutine stdlib_cppcon( uplo, n, ap, anorm, rcond, work, rwork, info ) + pure subroutine stdlib${ii}$_cppcon( uplo, n, ap, anorm, rcond, work, rwork, info ) !! CPPCON estimates the reciprocal of the condition number (in the !! 1-norm) of a complex Hermitian positive definite packed matrix using !! the Cholesky factorization A = U**H*U or A = L*L**H computed by @@ -47089,8 +47091,8 @@ module stdlib_linalg_lapack_c ! -- 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) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(sp), intent(in) :: anorm real(sp), intent(out) :: rcond ! Array Arguments @@ -47102,11 +47104,11 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: upper character :: normin - integer(ilp) :: ix, kase + integer(${ik}$) :: ix, kase real(sp) :: ainvnm, scale, scalel, scaleu, smlnum complex(sp) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,aimag,real ! Statement Functions @@ -47115,57 +47117,57 @@ module stdlib_linalg_lapack_c cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) ) ! 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 + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ else if( anormeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_cpptrs( uplo, n, 1, afp, work, n, info ) - call stdlib_caxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_cpptrs( uplo, n, 1_${ik}$, afp, work, n, info ) + call stdlib${ii}$_caxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -47342,22 +47344,22 @@ module stdlib_linalg_lapack_c rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**h). - call stdlib_cpptrs( uplo, n, 1, afp, work, n, info ) + call stdlib${ii}$_cpptrs( uplo, n, 1_${ik}$, afp, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do - else if( kase==2 ) then + else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_cpptrs( uplo, n, 1, afp, work, n, info ) + call stdlib${ii}$_cpptrs( uplo, n, 1_${ik}$, afp, work, n, info ) end if go to 100 end if @@ -47369,10 +47371,10 @@ module stdlib_linalg_lapack_c if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_cpprfs + end subroutine stdlib${ii}$_cpprfs - pure subroutine stdlib_cppsv( uplo, n, nrhs, ap, b, ldb, info ) + pure subroutine stdlib${ii}$_cppsv( uplo, n, nrhs, ap, b, ldb, info ) !! CPPSV computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N Hermitian positive definite matrix stored in @@ -47388,8 +47390,8 @@ module stdlib_linalg_lapack_c ! -- 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) :: ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments complex(sp), intent(inout) :: ap(*), b(ldb,*) ! ===================================================================== @@ -47397,31 +47399,31 @@ module stdlib_linalg_lapack_c intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .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( ldb0 ) then + info = -8_${ik}$ + else if( n>0_${ik}$ ) then scond = max( smin, smlnum ) / min( smax, bignum ) else scond = one end if end if - if( info==0 ) then - if( ldb0 )then + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_clanhp( 'I', uplo, n, ap, rwork ) + anorm = stdlib${ii}$_clanhp( 'I', uplo, n, ap, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_cppcon( uplo, n, afp, anorm, rcond, work, rwork, info ) + call stdlib${ii}$_cppcon( uplo, n, afp, anorm, rcond, work, rwork, info ) ! compute the solution matrix x. - call stdlib_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_cpptrs( uplo, n, nrhs, afp, x, ldx, info ) + call stdlib${ii}$_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_cpptrs( uplo, n, nrhs, afp, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_cpprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr, berr,work, rwork, & + call stdlib${ii}$_cpprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr, berr,work, rwork, & info ) ! transform the solution matrix x to a solution of the original ! system. @@ -47556,12 +47558,12 @@ module stdlib_linalg_lapack_c end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond0 )return if( upper ) then ! compute the product inv(u) * inv(u)**h. - jj = 0 + jj = 0_${ik}$ do j = 1, n - jc = jj + 1 + jc = jj + 1_${ik}$ jj = jj + j - if( j>1 )call stdlib_chpr( 'UPPER', j-1, one, ap( jc ), 1, ap ) + if( j>1_${ik}$ )call stdlib${ii}$_chpr( 'UPPER', j-1, one, ap( jc ), 1_${ik}$, ap ) ajj = real( ap( jj ),KIND=sp) - call stdlib_csscal( j, ajj, ap( jc ), 1 ) + call stdlib${ii}$_csscal( j, ajj, ap( jc ), 1_${ik}$ ) end do else ! compute the product inv(l)**h * inv(l). - jj = 1 + jj = 1_${ik}$ do j = 1, n - jjn = jj + n - j + 1 - ap( jj ) = real( stdlib_cdotc( n-j+1, ap( jj ), 1, ap( jj ), 1 ),KIND=sp) - if( j0 .and. ldz0_${ik}$ .and. ldz0 )z( 1, 1 ) = cone + if( n==1_${ik}$ ) then + if( icompz>0_${ik}$ )z( 1_${ik}$, 1_${ik}$ ) = cone return end if - if( icompz==2 )call stdlib_claset( 'FULL', n, n, czero, cone, z, ldz ) - ! call stdlib_spttrf to factor the matrix. - call stdlib_spttrf( n, d, e, info ) + if( icompz==2_${ik}$ )call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, z, ldz ) + ! call stdlib${ii}$_spttrf to factor the matrix. + call stdlib${ii}$_spttrf( n, d, e, info ) if( info/=0 )return do i = 1, n d( i ) = sqrt( d( i ) ) @@ -47699,17 +47701,17 @@ module stdlib_linalg_lapack_c do i = 1, n - 1 e( i ) = e( i )*d( i ) end do - ! call stdlib_cbdsqr to compute the singular values/vectors of the + ! call stdlib${ii}$_cbdsqr to compute the singular values/vectors of the ! bidiagonal factor. - if( icompz>0 ) then + if( icompz>0_${ik}$ ) then nru = n else - nru = 0 + nru = 0_${ik}$ end if - call stdlib_cbdsqr( 'LOWER', n, 0, nru, 0, d, e, vt, 1, z, ldz, c, 1,work, info ) + call stdlib${ii}$_cbdsqr( 'LOWER', n, 0_${ik}$, nru, 0_${ik}$, d, e, vt, 1_${ik}$, z, ldz, c, 1_${ik}$,work, info ) ! square the singular values. - if( info==0 ) then + if( info==0_${ik}$ ) then do i = 1, n d( i ) = d( i )*d( i ) end do @@ -47717,10 +47719,10 @@ module stdlib_linalg_lapack_c info = n + info end if return - end subroutine stdlib_cpteqr + end subroutine stdlib${ii}$_cpteqr - pure subroutine stdlib_cpttrs( uplo, n, nrhs, d, e, b, ldb, info ) + pure subroutine stdlib${ii}$_cpttrs( uplo, n, nrhs, d, e, b, ldb, info ) !! CPTTRS solves a tridiagonal system of the form !! A * X = B !! using the factorization A = U**H*D*U or A = L*D*L**H computed by CPTTRF. @@ -47732,8 +47734,8 @@ module stdlib_linalg_lapack_c ! -- 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) :: ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments real(sp), intent(in) :: d(*) complex(sp), intent(inout) :: b(ldb,*) @@ -47741,53 +47743,53 @@ module stdlib_linalg_lapack_c ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: iuplo, j, jb, nb + integer(${ik}$) :: iuplo, j, jb, nb ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments. - info = 0 + info = 0_${ik}$ upper = ( uplo=='U' .or. uplo=='U' ) if( .not.upper .and. .not.( uplo=='L' .or. uplo=='L' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( ldb=nrhs ) then - call stdlib_cptts2( iuplo, n, nrhs, d, e, b, ldb ) + call stdlib${ii}$_cptts2( iuplo, n, nrhs, d, e, b, ldb ) else do j = 1, nrhs, nb jb = min( nrhs-j+1, nb ) - call stdlib_cptts2( iuplo, n, jb, d, e, b( 1, j ), ldb ) + call stdlib${ii}$_cptts2( iuplo, n, jb, d, e, b( 1_${ik}$, j ), ldb ) end do end if return - end subroutine stdlib_cpttrs + end subroutine stdlib${ii}$_cpttrs - pure subroutine stdlib_cspcon( uplo, n, ap, ipiv, anorm, rcond, work, info ) + pure subroutine stdlib${ii}$_cspcon( uplo, n, ap, ipiv, anorm, rcond, work, info ) !! CSPCON estimates the reciprocal of the condition number (in the !! 1-norm) of a complex symmetric packed matrix A using the !! factorization A = U*D*U**T or A = L*D*L**T computed by CSPTRF. @@ -47798,40 +47800,40 @@ module stdlib_linalg_lapack_c ! -- 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) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(sp), intent(in) :: anorm real(sp), intent(out) :: rcond ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) complex(sp), intent(in) :: ap(*) complex(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: i, ip, kase + integer(${ik}$) :: i, ip, kase real(sp) :: ainvnm ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! 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 + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ else if( anorm0 .and. ap( ip )==zero )return ip = ip - i end do else ! lower triangular storage: examine d from top to bottom. - ip = 1 + ip = 1_${ik}$ do i = 1, n if( ipiv( i )>0 .and. ap( ip )==zero )return - ip = ip + n - i + 1 + ip = ip + n - i + 1_${ik}$ end do end if ! estimate the 1-norm of the inverse. - kase = 0 + kase = 0_${ik}$ 30 continue - call stdlib_clacn2( n, work( n+1 ), work, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_clacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + if( kase/=0_${ik}$ ) then ! multiply by inv(l*d*l**t) or inv(u*d*u**t). - call stdlib_csptrs( uplo, n, 1, ap, ipiv, work, n, info ) + call stdlib${ii}$_csptrs( uplo, n, 1_${ik}$, ap, ipiv, work, n, info ) go to 30 end if ! compute the estimate of the reciprocal condition number. if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm return - end subroutine stdlib_cspcon + end subroutine stdlib${ii}$_cspcon - pure subroutine stdlib_csprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,& + pure subroutine stdlib${ii}$_csprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,& !! CSPRFS improves the computed solution to a system of linear !! equations when the coefficient matrix is symmetric indefinite !! and packed, and provides error bounds and backward error estimates @@ -47879,17 +47881,17 @@ module stdlib_linalg_lapack_c ! -- 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) :: ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) real(sp), intent(out) :: berr(*), ferr(*), rwork(*) complex(sp), intent(in) :: afp(*), ap(*), b(ldb,*) complex(sp), intent(out) :: work(*) complex(sp), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: itmax = 5 + integer(${ik}$), parameter :: itmax = 5_${ik}$ @@ -47897,11 +47899,11 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: upper - integer(ilp) :: count, i, ik, j, k, kase, kk, nz + integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz real(sp) :: eps, lstres, s, safe1, safe2, safmin, xk complex(sp) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,aimag,max,real ! Statement Functions @@ -47910,25 +47912,25 @@ module stdlib_linalg_lapack_c cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) ) ! 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( nrhs<0 ) then - info = -3 - else if( ldbeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_csptrs( uplo, n, 1, afp, ipiv, work, n, info ) - call stdlib_caxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_csptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info ) + call stdlib${ii}$_caxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -48035,22 +48037,22 @@ module stdlib_linalg_lapack_c rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**t). - call stdlib_csptrs( uplo, n, 1, afp, ipiv, work, n, info ) + call stdlib${ii}$_csptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do - else if( kase==2 ) then + else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_csptrs( uplo, n, 1, afp, ipiv, work, n, info ) + call stdlib${ii}$_csptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info ) end if go to 100 end if @@ -48062,10 +48064,10 @@ module stdlib_linalg_lapack_c if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_csprfs + end subroutine stdlib${ii}$_csprfs - pure subroutine stdlib_cspsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) + pure subroutine stdlib${ii}$_cspsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) !! CSPSV computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N symmetric matrix stored in packed format and X @@ -48082,41 +48084,41 @@ module stdlib_linalg_lapack_c ! -- 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) :: ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(sp), intent(inout) :: ap(*), b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .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( ldb0 )then + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_clansp( 'I', uplo, n, ap, rwork ) + anorm = stdlib${ii}$_clansp( 'I', uplo, n, ap, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_cspcon( uplo, n, afp, ipiv, anorm, rcond, work, info ) + call stdlib${ii}$_cspcon( uplo, n, afp, ipiv, anorm, rcond, work, info ) ! compute the solution vectors x. - call stdlib_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_csptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info ) + call stdlib${ii}$_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_csptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_csprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, & + call stdlib${ii}$_csprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, & rwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond0 .and. wu<=wl ) then - info = -7 - else if( indeig .and. ( iil<1 .or. iil>n ) ) then - info = -8 + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( valeig .and. n>0_${ik}$ .and. wu<=wl ) then + info = -7_${ik}$ + else if( indeig .and. ( iil<1_${ik}$ .or. iil>n ) ) then + info = -8_${ik}$ else if( indeig .and. ( iiun ) ) then - info = -9 - else if( ldz<1 .or. ( wantz .and. ldz=d( 1 ) ) then - m = 1 - w( 1 ) = d( 1 ) + if( wl=d( 1_${ik}$ ) ) then + m = 1_${ik}$ + w( 1_${ik}$ ) = d( 1_${ik}$ ) end if end if if( wantz.and.(.not.zquery) ) then - z( 1, 1 ) = one - isuppz(1) = 1 - isuppz(2) = 1 + z( 1_${ik}$, 1_${ik}$ ) = one + isuppz(1_${ik}$) = 1_${ik}$ + isuppz(2_${ik}$) = 1_${ik}$ end if return end if - if( n==2 ) then + if( n==2_${ik}$ ) then if( .not.wantz ) then - call stdlib_slae2( d(1), e(1), d(2), r1, r2 ) + call stdlib${ii}$_slae2( d(1_${ik}$), e(1_${ik}$), d(2_${ik}$), r1, r2 ) else if( wantz.and.(.not.zquery) ) then - call stdlib_slaev2( d(1), e(1), d(2), r1, r2, cs, sn ) + call stdlib${ii}$_slaev2( d(1_${ik}$), e(1_${ik}$), d(2_${ik}$), r1, r2, cs, sn ) end if - if( alleig.or.(valeig.and.(r2>wl).and.(r2<=wu)).or.(indeig.and.(iil==1)) ) & + if( alleig.or.(valeig.and.(r2>wl).and.(r2<=wu)).or.(indeig.and.(iil==1_${ik}$)) ) & then m = m+1 w( m ) = r2 if( wantz.and.(.not.zquery) ) then - z( 1, m ) = -sn - z( 2, m ) = cs + z( 1_${ik}$, m ) = -sn + z( 2_${ik}$, m ) = cs ! note: at most one of sn and cs can be zero. if (sn/=zero) then if (cs/=zero) then - isuppz(2*m-1) = 1 - isuppz(2*m) = 2 + isuppz(2_${ik}$*m-1) = 1_${ik}$ + isuppz(2_${ik}$*m) = 2_${ik}$ else - isuppz(2*m-1) = 1 - isuppz(2*m) = 1 + isuppz(2_${ik}$*m-1) = 1_${ik}$ + isuppz(2_${ik}$*m) = 1_${ik}$ end if else - isuppz(2*m-1) = 2 - isuppz(2*m) = 2 + isuppz(2_${ik}$*m-1) = 2_${ik}$ + isuppz(2_${ik}$*m) = 2_${ik}$ end if endif endif - if( alleig.or.(valeig.and.(r1>wl).and.(r1<=wu)).or.(indeig.and.(iiu==2)) ) & + if( alleig.or.(valeig.and.(r1>wl).and.(r1<=wu)).or.(indeig.and.(iiu==2_${ik}$)) ) & then m = m+1 w( m ) = r1 if( wantz.and.(.not.zquery) ) then - z( 1, m ) = cs - z( 2, m ) = sn + z( 1_${ik}$, m ) = cs + z( 2_${ik}$, m ) = sn ! note: at most one of sn and cs can be zero. if (sn/=zero) then if (cs/=zero) then - isuppz(2*m-1) = 1 - isuppz(2*m) = 2 + isuppz(2_${ik}$*m-1) = 1_${ik}$ + isuppz(2_${ik}$*m) = 2_${ik}$ else - isuppz(2*m-1) = 1 - isuppz(2*m) = 1 + isuppz(2_${ik}$*m-1) = 1_${ik}$ + isuppz(2_${ik}$*m) = 1_${ik}$ end if else - isuppz(2*m-1) = 2 - isuppz(2*m) = 2 + isuppz(2_${ik}$*m-1) = 2_${ik}$ + isuppz(2_${ik}$*m) = 2_${ik}$ end if endif endif else ! continue with general n - indgrs = 1 - inderr = 2*n + 1 - indgp = 3*n + 1 - indd = 4*n + 1 - inde2 = 5*n + 1 - indwrk = 6*n + 1 - iinspl = 1 - iindbl = n + 1 - iindw = 2*n + 1 - iindwk = 3*n + 1 + indgrs = 1_${ik}$ + inderr = 2_${ik}$*n + 1_${ik}$ + indgp = 3_${ik}$*n + 1_${ik}$ + indd = 4_${ik}$*n + 1_${ik}$ + inde2 = 5_${ik}$*n + 1_${ik}$ + indwrk = 6_${ik}$*n + 1_${ik}$ + iinspl = 1_${ik}$ + iindbl = n + 1_${ik}$ + iindw = 2_${ik}$*n + 1_${ik}$ + iindwk = 3_${ik}$*n + 1_${ik}$ ! scale matrix to allowable range, if necessary. ! the allowable range is related to the pivmin parameter; see the - ! comments in stdlib_slarrd. the preference for scaling small values + ! comments in stdlib${ii}$_slarrd. the preference for scaling small values ! up is heuristic; we expect users' matrices not to be close to the ! rmax threshold. scale = one - tnrm = stdlib_slanst( 'M', n, d, e ) + tnrm = stdlib${ii}$_slanst( 'M', n, d, e ) if( tnrm>zero .and. tnrmrmax ) then scale = rmax / tnrm end if if( scale/=one ) then - call stdlib_sscal( n, scale, d, 1 ) - call stdlib_sscal( n-1, scale, e, 1 ) + call stdlib${ii}$_sscal( n, scale, d, 1_${ik}$ ) + call stdlib${ii}$_sscal( n-1, scale, e, 1_${ik}$ ) tnrm = tnrm*scale if( valeig ) then ! if eigenvalues in interval have to be found, @@ -48478,19 +48480,19 @@ module stdlib_linalg_lapack_c ! compute the desired eigenvalues of the tridiagonal after splitting ! into smaller subblocks if the corresponding off-diagonal elements ! are small - ! thresh is the splitting parameter for stdlib_slarre + ! thresh is the splitting parameter for stdlib${ii}$_slarre ! a negative thresh forces the old splitting criterion based on the ! size of the off-diagonal. a positive thresh switches to splitting ! which preserves relative accuracy. if( tryrac ) then ! test whether the matrix warrants the more expensive relative approach. - call stdlib_slarrr( n, d, e, iinfo ) + call stdlib${ii}$_slarrr( n, d, e, iinfo ) else ! the user does not care about relative accurately eigenvalues - iinfo = -1 + iinfo = -1_${ik}$ endif ! set the splitting criterion - if (iinfo==0) then + if (iinfo==0_${ik}$) then thresh = eps else thresh = -eps @@ -48499,51 +48501,51 @@ module stdlib_linalg_lapack_c endif if( tryrac ) then ! copy original diagonal, needed to guarantee relative accuracy - call stdlib_scopy(n,d,1,work(indd),1) + call stdlib${ii}$_scopy(n,d,1_${ik}$,work(indd),1_${ik}$) endif ! store the squares of the offdiagonal values of t do j = 1, n-1 - work( inde2+j-1 ) = e(j)**2 + work( inde2+j-1 ) = e(j)**2_${ik}$ end do ! set the tolerance parameters for bisection if( .not.wantz ) then - ! stdlib_slarre computes the eigenvalues to full precision. + ! stdlib${ii}$_slarre computes the eigenvalues to full precision. rtol1 = four * eps rtol2 = four * eps else - ! stdlib_slarre computes the eigenvalues to less than full precision. - ! stdlib_clarrv will refine the eigenvalue approximations, and we only - ! need less accurate initial bisection in stdlib_slarre. - ! note: these settings do only affect the subset case and stdlib_slarre + ! stdlib${ii}$_slarre computes the eigenvalues to less than full precision. + ! stdlib${ii}$_clarrv will refine the eigenvalue approximations, and we only + ! need less accurate initial bisection in stdlib${ii}$_slarre. + ! note: these settings do only affect the subset case and stdlib${ii}$_slarre rtol1 = max( sqrt(eps)*5.0e-2_sp, four * eps ) rtol2 = max( sqrt(eps)*5.0e-3_sp, four * eps ) endif - call stdlib_slarre( range, n, wl, wu, iil, iiu, d, e,work(inde2), rtol1, rtol2, & + call stdlib${ii}$_slarre( range, n, wl, wu, iil, iiu, d, e,work(inde2), rtol1, rtol2, & thresh, nsplit,iwork( iinspl ), m, w, work( inderr ),work( indgp ), iwork( iindbl ),& iwork( iindw ), work( indgrs ), pivmin,work( indwrk ), iwork( iindwk ), iinfo ) - if( iinfo/=0 ) then - info = 10 + abs( iinfo ) + if( iinfo/=0_${ik}$ ) then + info = 10_${ik}$ + abs( iinfo ) return end if - ! note that if range /= 'v', stdlib_slarre computes bounds on the desired + ! note that if range /= 'v', stdlib${ii}$_slarre computes bounds on the desired ! part of the spectrum. all desired eigenvalues are contained in ! (wl,wu] if( wantz ) then ! compute the desired eigenvectors corresponding to the computed ! eigenvalues - call stdlib_clarrv( n, wl, wu, d, e,pivmin, iwork( iinspl ), m,1, m, minrgp, & + call stdlib${ii}$_clarrv( n, wl, wu, d, e,pivmin, iwork( iinspl ), m,1_${ik}$, m, minrgp, & rtol1, rtol2,w, work( inderr ), work( indgp ), iwork( iindbl ),iwork( iindw ), & work( indgrs ), z, ldz,isuppz, work( indwrk ), iwork( iindwk ), iinfo ) - if( iinfo/=0 ) then - info = 20 + abs( iinfo ) + if( iinfo/=0_${ik}$ ) then + info = 20_${ik}$ + abs( iinfo ) return end if else - ! stdlib_slarre computes eigenvalues of the (shifted) root representation - ! stdlib_clarrv returns the eigenvalues of the unshifted matrix. + ! stdlib${ii}$_slarre computes eigenvalues of the (shifted) root representation + ! stdlib${ii}$_clarrv returns the eigenvalues of the unshifted matrix. ! however, if the eigenvectors are not desired by the user, we need - ! to apply the corresponding shifts from stdlib_slarre to obtain the + ! to apply the corresponding shifts from stdlib${ii}$_slarre to obtain the ! eigenvalues of the original matrix. do j = 1, m itmp = iwork( iindbl+j-1 ) @@ -48553,52 +48555,52 @@ module stdlib_linalg_lapack_c if ( tryrac ) then ! refine computed eigenvalues so that they are relatively accurate ! with respect to the original matrix t. - ibegin = 1 - wbegin = 1 + ibegin = 1_${ik}$ + wbegin = 1_${ik}$ loop_39: do jblk = 1, iwork( iindbl+m-1 ) iend = iwork( iinspl+jblk-1 ) - in = iend - ibegin + 1 - wend = wbegin - 1 + in = iend - ibegin + 1_${ik}$ + wend = wbegin - 1_${ik}$ ! check if any eigenvalues have to be refined in this block 36 continue if( wend1 .or. n==2 ) then + if( nsplit>1_${ik}$ .or. n==2_${ik}$ ) then if( .not. wantz ) then - call stdlib_slasrt( 'I', m, w, iinfo ) - if( iinfo/=0 ) then - info = 3 + call stdlib${ii}$_slasrt( 'I', m, w, iinfo ) + if( iinfo/=0_${ik}$ ) then + info = 3_${ik}$ return end if else do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp = w( j ) do jj = j + 1, m if( w( jj )eps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_csytrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) - call stdlib_caxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_csytrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info ) + call stdlib${ii}$_caxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -48954,22 +48956,22 @@ module stdlib_linalg_lapack_c rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**t). - call stdlib_csytrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) + call stdlib${ii}$_csytrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do - else if( kase==2 ) then + else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_csytrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) + call stdlib${ii}$_csytrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info ) end if go to 100 end if @@ -48981,10 +48983,10 @@ module stdlib_linalg_lapack_c if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_csyrfs + end subroutine stdlib${ii}$_csyrfs - pure subroutine stdlib_csysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) + pure subroutine stdlib${ii}$_csysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) !! CSYSV computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS @@ -49001,68 +49003,68 @@ module stdlib_linalg_lapack_c ! -- 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, lwork, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, lwork, n, nrhs ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(sp), intent(inout) :: a(lda,*), b(ldb,*) complex(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: lwkopt + integer(${ik}$) :: lwkopt ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) if( .not.stdlib_lsame( uplo, 'U' ) .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 + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_clansy( 'I', uplo, n, a, lda, rwork ) + anorm = stdlib${ii}$_clansy( 'I', uplo, n, a, lda, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_csycon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, info ) + call stdlib${ii}$_csycon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, info ) ! compute the solution vectors x. - call stdlib_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_csytrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info ) + call stdlib${ii}$_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_csytrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_csyrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & + call stdlib${ii}$_csyrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & work, rwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond 0. if( anorm>zero ) then ! estimate the 1-norm of the inverse of a. ainvnm = zero normin = 'N' if( onenrm ) then - kase1 = 1 + kase1 = 1_${ik}$ else - kase1 = 2 + kase1 = 2_${ik}$ end if - kase = 0 + kase = 0_${ik}$ 10 continue - call stdlib_clacn2( n, work( n+1 ), work, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_clacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + if( kase/=0_${ik}$ ) then if( kase==kase1 ) then ! multiply by inv(a). - call stdlib_clatbs( uplo, 'NO TRANSPOSE', diag, normin, n, kd,ab, ldab, work, & + call stdlib${ii}$_clatbs( uplo, 'NO TRANSPOSE', diag, normin, n, kd,ab, ldab, work, & scale, rwork, info ) else ! multiply by inv(a**h). - call stdlib_clatbs( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, kd, ab, ldab,& + call stdlib${ii}$_clatbs( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, kd, ab, ldab,& work, scale, rwork, info ) end if normin = 'Y' ! multiply by 1/scale if doing so will not cause overflow. if( scale/=one ) then - ix = stdlib_icamax( n, work, 1 ) + ix = stdlib${ii}$_icamax( n, work, 1_${ik}$ ) xnorm = cabs1( work( ix ) ) if( scale a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) - call stdlib_ctrtri( 'L', diag, n1, a( 0 ), n, info ) + call stdlib${ii}$_ctrtri( 'L', diag, n1, a( 0_${ik}$ ), n, info ) if( info>0 )return - call stdlib_ctrmm( 'R', 'L', 'N', diag, n2, n1, -cone, a( 0 ),n, a( n1 ), n ) + call stdlib${ii}$_ctrmm( 'R', 'L', 'N', diag, n2, n1, -cone, a( 0_${ik}$ ),n, a( n1 ), n ) - call stdlib_ctrtri( 'U', diag, n2, a( n ), n, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_ctrtri( 'U', diag, n2, a( n ), n, info ) + if( info>0_${ik}$ )info = info + n1 if( info>0 )return - call stdlib_ctrmm( 'L', 'U', 'C', diag, n2, n1, cone, a( n ), n,a( n1 ), n ) + call stdlib${ii}$_ctrmm( 'L', 'U', 'C', diag, n2, n1, cone, a( n ), n,a( n1 ), n ) else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) - call stdlib_ctrtri( 'L', diag, n1, a( n2 ), n, info ) + call stdlib${ii}$_ctrtri( 'L', diag, n1, a( n2 ), n, info ) if( info>0 )return - call stdlib_ctrmm( 'L', 'L', 'C', diag, n1, n2, -cone, a( n2 ),n, a( 0 ), n ) + call stdlib${ii}$_ctrmm( 'L', 'L', 'C', diag, n1, n2, -cone, a( n2 ),n, a( 0_${ik}$ ), n ) - call stdlib_ctrtri( 'U', diag, n2, a( n1 ), n, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_ctrtri( 'U', diag, n2, a( n1 ), n, info ) + if( info>0_${ik}$ )info = info + n1 if( info>0 )return - call stdlib_ctrmm( 'R', 'U', 'N', diag, n1, n2, cone, a( n1 ),n, a( 0 ), n ) + call stdlib${ii}$_ctrmm( 'R', 'U', 'N', diag, n1, n2, cone, a( n1 ),n, a( 0_${ik}$ ), n ) end if else @@ -49517,26 +49519,26 @@ module stdlib_linalg_lapack_c if( lower ) then ! srpa for lower, transpose and n is odd ! t1 -> a(0), t2 -> a(1), s -> a(0+n1*n1) - call stdlib_ctrtri( 'U', diag, n1, a( 0 ), n1, info ) + call stdlib${ii}$_ctrtri( 'U', diag, n1, a( 0_${ik}$ ), n1, info ) if( info>0 )return - call stdlib_ctrmm( 'L', 'U', 'N', diag, n1, n2, -cone, a( 0 ),n1, a( n1*n1 ), & + call stdlib${ii}$_ctrmm( 'L', 'U', 'N', diag, n1, n2, -cone, a( 0_${ik}$ ),n1, a( n1*n1 ), & n1 ) - call stdlib_ctrtri( 'L', diag, n2, a( 1 ), n1, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_ctrtri( 'L', diag, n2, a( 1_${ik}$ ), n1, info ) + if( info>0_${ik}$ )info = info + n1 if( info>0 )return - call stdlib_ctrmm( 'R', 'L', 'C', diag, n1, n2, cone, a( 1 ),n1, a( n1*n1 ), & + call stdlib${ii}$_ctrmm( 'R', 'L', 'C', diag, n1, n2, cone, a( 1_${ik}$ ),n1, a( n1*n1 ), & n1 ) else ! srpa for upper, transpose and n is odd ! t1 -> a(0+n2*n2), t2 -> a(0+n1*n2), s -> a(0) - call stdlib_ctrtri( 'U', diag, n1, a( n2*n2 ), n2, info ) + call stdlib${ii}$_ctrtri( 'U', diag, n1, a( n2*n2 ), n2, info ) if( info>0 )return - call stdlib_ctrmm( 'R', 'U', 'C', diag, n2, n1, -cone,a( n2*n2 ), n2, a( 0 ), & + call stdlib${ii}$_ctrmm( 'R', 'U', 'C', diag, n2, n1, -cone,a( n2*n2 ), n2, a( 0_${ik}$ ), & n2 ) - call stdlib_ctrtri( 'L', diag, n2, a( n1*n2 ), n2, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_ctrtri( 'L', diag, n2, a( n1*n2 ), n2, info ) + if( info>0_${ik}$ )info = info + n1 if( info>0 )return - call stdlib_ctrmm( 'L', 'L', 'N', diag, n2, n1, cone,a( n1*n2 ), n2, a( 0 ), & + call stdlib${ii}$_ctrmm( 'L', 'L', 'N', diag, n2, n1, cone,a( n1*n2 ), n2, a( 0_${ik}$ ), & n2 ) end if end if @@ -49548,27 +49550,27 @@ module stdlib_linalg_lapack_c ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) - call stdlib_ctrtri( 'L', diag, k, a( 1 ), n+1, info ) + call stdlib${ii}$_ctrtri( 'L', diag, k, a( 1_${ik}$ ), n+1, info ) if( info>0 )return - call stdlib_ctrmm( 'R', 'L', 'N', diag, k, k, -cone, a( 1 ),n+1, a( k+1 ), n+& - 1 ) - call stdlib_ctrtri( 'U', diag, k, a( 0 ), n+1, info ) - if( info>0 )info = info + k + call stdlib${ii}$_ctrmm( 'R', 'L', 'N', diag, k, k, -cone, a( 1_${ik}$ ),n+1, a( k+1 ), n+& + 1_${ik}$ ) + call stdlib${ii}$_ctrtri( 'U', diag, k, a( 0_${ik}$ ), n+1, info ) + if( info>0_${ik}$ )info = info + k if( info>0 )return - call stdlib_ctrmm( 'L', 'U', 'C', diag, k, k, cone, a( 0 ), n+1,a( k+1 ), n+1 & + call stdlib${ii}$_ctrmm( 'L', 'U', 'C', diag, k, k, cone, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 & ) else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) - call stdlib_ctrtri( 'L', diag, k, a( k+1 ), n+1, info ) + call stdlib${ii}$_ctrtri( 'L', diag, k, a( k+1 ), n+1, info ) if( info>0 )return - call stdlib_ctrmm( 'L', 'L', 'C', diag, k, k, -cone, a( k+1 ),n+1, a( 0 ), n+& - 1 ) - call stdlib_ctrtri( 'U', diag, k, a( k ), n+1, info ) - if( info>0 )info = info + k + call stdlib${ii}$_ctrmm( 'L', 'L', 'C', diag, k, k, -cone, a( k+1 ),n+1, a( 0_${ik}$ ), n+& + 1_${ik}$ ) + call stdlib${ii}$_ctrtri( 'U', diag, k, a( k ), n+1, info ) + if( info>0_${ik}$ )info = info + k if( info>0 )return - call stdlib_ctrmm( 'R', 'U', 'N', diag, k, k, cone, a( k ), n+1,a( 0 ), n+1 ) + call stdlib${ii}$_ctrmm( 'R', 'U', 'N', diag, k, k, cone, a( k ), n+1,a( 0_${ik}$ ), n+1 ) end if else @@ -49577,36 +49579,36 @@ module stdlib_linalg_lapack_c ! srpa for lower, transpose and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1) ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k - call stdlib_ctrtri( 'U', diag, k, a( k ), k, info ) + call stdlib${ii}$_ctrtri( 'U', diag, k, a( k ), k, info ) if( info>0 )return - call stdlib_ctrmm( 'L', 'U', 'N', diag, k, k, -cone, a( k ), k,a( k*( k+1 ) ),& + call stdlib${ii}$_ctrmm( 'L', 'U', 'N', diag, k, k, -cone, a( k ), k,a( k*( k+1 ) ),& k ) - call stdlib_ctrtri( 'L', diag, k, a( 0 ), k, info ) - if( info>0 )info = info + k + call stdlib${ii}$_ctrtri( 'L', diag, k, a( 0_${ik}$ ), k, info ) + if( info>0_${ik}$ )info = info + k if( info>0 )return - call stdlib_ctrmm( 'R', 'L', 'C', diag, k, k, cone, a( 0 ), k,a( k*( k+1 ) ), & + call stdlib${ii}$_ctrmm( 'R', 'L', 'C', diag, k, k, cone, a( 0_${ik}$ ), k,a( k*( k+1 ) ), & k ) else ! srpa for upper, transpose and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0) ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k - call stdlib_ctrtri( 'U', diag, k, a( k*( k+1 ) ), k, info ) + call stdlib${ii}$_ctrtri( 'U', diag, k, a( k*( k+1 ) ), k, info ) if( info>0 )return - call stdlib_ctrmm( 'R', 'U', 'C', diag, k, k, -cone,a( k*( k+1 ) ), k, a( 0 ),& + call stdlib${ii}$_ctrmm( 'R', 'U', 'C', diag, k, k, -cone,a( k*( k+1 ) ), k, a( 0_${ik}$ ),& k ) - call stdlib_ctrtri( 'L', diag, k, a( k*k ), k, info ) - if( info>0 )info = info + k + call stdlib${ii}$_ctrtri( 'L', diag, k, a( k*k ), k, info ) + if( info>0_${ik}$ )info = info + k if( info>0 )return - call stdlib_ctrmm( 'L', 'L', 'N', diag, k, k, cone, a( k*k ), k,a( 0 ), k ) + call stdlib${ii}$_ctrmm( 'L', 'L', 'N', diag, k, k, cone, a( k*k ), k,a( 0_${ik}$ ), k ) end if end if end if return - end subroutine stdlib_ctftri + end subroutine stdlib${ii}$_ctftri - pure subroutine stdlib_ctgsja( jobu, jobv, jobq, m, p, n, k, l, a, lda, b,ldb, tola, tolb, & + pure subroutine stdlib${ii}$_ctgsja( jobu, jobv, jobq, m, p, n, k, l, a, lda, b,ldb, tola, tolb, & !! CTGSJA computes the generalized singular value decomposition (GSVD) !! of two complex upper triangular (or trapezoidal) matrices A and B. !! On entry, it is assumed that matrices A and B have the following @@ -49675,8 +49677,8 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobq, jobu, jobv - integer(ilp), intent(out) :: info, ncycle - integer(ilp), intent(in) :: k, l, lda, ldb, ldq, ldu, ldv, m, n, p + integer(${ik}$), intent(out) :: info, ncycle + integer(${ik}$), intent(in) :: k, l, lda, ldb, ldq, ldu, ldv, m, n, p real(sp), intent(in) :: tola, tolb ! Array Arguments real(sp), intent(out) :: alpha(*), beta(*) @@ -49684,14 +49686,14 @@ module stdlib_linalg_lapack_c complex(sp), intent(out) :: work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: maxit = 40 + integer(${ik}$), parameter :: maxit = 40_${ik}$ real(sp), parameter :: hugenum = huge(zero) ! Local Scalars logical(lk) :: initq, initu, initv, upper, wantq, wantu, wantv - integer(ilp) :: i, j, kcycle + integer(${ik}$) :: i, j, kcycle real(sp) :: a1, a3, b1, b3, csq, csu, csv, error, gamma, rwk, ssmin complex(sp) :: a2, b2, snq, snu, snv ! Intrinsic Functions @@ -49704,38 +49706,38 @@ module stdlib_linalg_lapack_c wantv = initv .or. stdlib_lsame( jobv, 'V' ) initq = stdlib_lsame( jobq, 'I' ) wantq = initq .or. stdlib_lsame( jobq, 'Q' ) - info = 0 + info = 0_${ik}$ if( .not.( initu .or. wantu .or. stdlib_lsame( jobu, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( initv .or. wantv .or. stdlib_lsame( jobv, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( initq .or. wantq .or. stdlib_lsame( jobq, 'N' ) ) ) then - info = -3 - else if( m<0 ) then - info = -4 - else if( p<0 ) then - info = -5 - else if( n<0 ) then - info = -6 - else if( lda=-hugenum) ) then if( gamma=beta( k+i ) ) then - call stdlib_csscal( l-i+1, one / alpha( k+i ), a( k+i, n-l+i ),lda ) + call stdlib${ii}$_csscal( l-i+1, one / alpha( k+i ), a( k+i, n-l+i ),lda ) else - call stdlib_csscal( l-i+1, one / beta( k+i ), b( i, n-l+i ),ldb ) - call stdlib_ccopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) + call stdlib${ii}$_csscal( l-i+1, one / beta( k+i ), b( i, n-l+i ),ldb ) + call stdlib${ii}$_ccopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) end if else alpha( k+i ) = zero beta( k+i ) = one - call stdlib_ccopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) + call stdlib${ii}$_ccopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) end if end do ! post-assignment @@ -49852,10 +49854,10 @@ module stdlib_linalg_lapack_c 100 continue ncycle = kcycle return - end subroutine stdlib_ctgsja + end subroutine stdlib${ii}$_ctgsja - pure subroutine stdlib_ctgsy2( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f, & + pure subroutine stdlib${ii}$_ctgsy2( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f, & !! CTGSY2 solves the generalized Sylvester equation !! A * R - L * B = scale * C (1) !! D * R - L * E = scale * F @@ -49887,8 +49889,8 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: trans - integer(ilp), intent(in) :: ijob, lda, ldb, ldc, ldd, lde, ldf, m, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ijob, lda, ldb, ldc, ldd, lde, ldf, m, n + integer(${ik}$), intent(out) :: info real(sp), intent(inout) :: rdscal, rdsum real(sp), intent(out) :: scale ! Array Arguments @@ -49896,52 +49898,52 @@ module stdlib_linalg_lapack_c complex(sp), intent(inout) :: c(ldc,*), f(ldf,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: ldz = 2 + integer(${ik}$), parameter :: ldz = 2_${ik}$ ! Local Scalars logical(lk) :: notran - integer(ilp) :: i, ierr, j, k + integer(${ik}$) :: i, ierr, j, k real(sp) :: scaloc complex(sp) :: alpha ! Local Arrays - integer(ilp) :: ipiv(ldz), jpiv(ldz) + integer(${ik}$) :: ipiv(ldz), jpiv(ldz) complex(sp) :: rhs(ldz), z(ldz,ldz) ! Intrinsic Functions intrinsic :: cmplx,conjg,max ! Executable Statements ! decode and test input parameters - info = 0 - ierr = 0 + info = 0_${ik}$ + ierr = 0_${ik}$ notran = stdlib_lsame( trans, 'N' ) if( .not.notran .and. .not.stdlib_lsame( trans, 'C' ) ) then - info = -1 + info = -1_${ik}$ else if( notran ) then - if( ( ijob<0 ) .or. ( ijob>2 ) ) then - info = -2 + if( ( ijob<0_${ik}$ ) .or. ( ijob>2_${ik}$ ) ) then + info = -2_${ik}$ end if end if - if( info==0 ) then - if( m<=0 ) then - info = -3 - else if( n<=0 ) then - info = -4 - else if( lda0 )info = ierr - if( ijob==0 ) then - call stdlib_cgesc2( ldz, z, ldz, rhs, ipiv, jpiv, scaloc ) + call stdlib${ii}$_cgetc2( ldz, z, ldz, ipiv, jpiv, ierr ) + if( ierr>0_${ik}$ )info = ierr + if( ijob==0_${ik}$ ) then + call stdlib${ii}$_cgesc2( ldz, z, ldz, rhs, ipiv, jpiv, scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_cscal( m, cmplx( scaloc, zero,KIND=sp), c( 1, k ),1 ) + call stdlib${ii}$_cscal( m, cmplx( scaloc, zero,KIND=sp), c( 1_${ik}$, k ),1_${ik}$ ) - call stdlib_cscal( m, cmplx( scaloc, zero,KIND=sp), f( 1, k ),1 ) + call stdlib${ii}$_cscal( m, cmplx( scaloc, zero,KIND=sp), f( 1_${ik}$, k ),1_${ik}$ ) end do scale = scale*scaloc end if else - call stdlib_clatdf( ijob, ldz, z, ldz, rhs, rdsum, rdscal,ipiv, jpiv ) + call stdlib${ii}$_clatdf( ijob, ldz, z, ldz, rhs, rdsum, rdscal,ipiv, jpiv ) end if ! unpack solution vector(s) - c( i, j ) = rhs( 1 ) - f( i, j ) = rhs( 2 ) + c( i, j ) = rhs( 1_${ik}$ ) + f( i, j ) = rhs( 2_${ik}$ ) ! substitute r(i, j) and l(i, j) into remaining equation. - if( i>1 ) then - alpha = -rhs( 1 ) - call stdlib_caxpy( i-1, alpha, a( 1, i ), 1, c( 1, j ), 1 ) - call stdlib_caxpy( i-1, alpha, d( 1, i ), 1, f( 1, j ), 1 ) + if( i>1_${ik}$ ) then + alpha = -rhs( 1_${ik}$ ) + call stdlib${ii}$_caxpy( i-1, alpha, a( 1_${ik}$, i ), 1_${ik}$, c( 1_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_caxpy( i-1, alpha, d( 1_${ik}$, i ), 1_${ik}$, f( 1_${ik}$, j ), 1_${ik}$ ) end if if( j0 )info = ierr - call stdlib_cgesc2( ldz, z, ldz, rhs, ipiv, jpiv, scaloc ) + call stdlib${ii}$_cgetc2( ldz, z, ldz, ipiv, jpiv, ierr ) + if( ierr>0_${ik}$ )info = ierr + call stdlib${ii}$_cgesc2( ldz, z, ldz, rhs, ipiv, jpiv, scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_cscal( m, cmplx( scaloc, zero,KIND=sp), c( 1, k ),1 ) + call stdlib${ii}$_cscal( m, cmplx( scaloc, zero,KIND=sp), c( 1_${ik}$, k ),1_${ik}$ ) - call stdlib_cscal( m, cmplx( scaloc, zero,KIND=sp), f( 1, k ),1 ) + call stdlib${ii}$_cscal( m, cmplx( scaloc, zero,KIND=sp), f( 1_${ik}$, k ),1_${ik}$ ) end do scale = scale*scaloc end if ! unpack solution vector(s) - c( i, j ) = rhs( 1 ) - f( i, j ) = rhs( 2 ) + c( i, j ) = rhs( 1_${ik}$ ) + f( i, j ) = rhs( 2_${ik}$ ) ! substitute r(i, j) and l(i, j) into remaining equation. do k = 1, j - 1 - f( i, k ) = f( i, k ) + rhs( 1 )*conjg( b( k, j ) ) +rhs( 2 )*conjg( e( k, & + f( i, k ) = f( i, k ) + rhs( 1_${ik}$ )*conjg( b( k, j ) ) +rhs( 2_${ik}$ )*conjg( e( k, & j ) ) end do do k = i + 1, m - c( k, j ) = c( k, j ) - conjg( a( i, k ) )*rhs( 1 ) -conjg( d( i, k ) )& - *rhs( 2 ) + c( k, j ) = c( k, j ) - conjg( a( i, k ) )*rhs( 1_${ik}$ ) -conjg( d( i, k ) )& + *rhs( 2_${ik}$ ) end do end do loop_70 end do loop_80 end if return - end subroutine stdlib_ctgsy2 + end subroutine stdlib${ii}$_ctgsy2 - pure subroutine stdlib_ctgsyl( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f, & + pure subroutine stdlib${ii}$_ctgsyl( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f, & !! CTGSYL solves the generalized Sylvester equation: !! A * R - L * B = scale * C (1) !! D * R - L * E = scale * F @@ -50079,249 +50081,249 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: trans - integer(ilp), intent(in) :: ijob, lda, ldb, ldc, ldd, lde, ldf, lwork, m, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ijob, lda, ldb, ldc, ldd, lde, ldf, lwork, m, n + integer(${ik}$), intent(out) :: info real(sp), intent(out) :: dif, scale ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) complex(sp), intent(in) :: a(lda,*), b(ldb,*), d(ldd,*), e(lde,*) complex(sp), intent(inout) :: c(ldc,*), f(ldf,*) complex(sp), intent(out) :: work(*) ! ===================================================================== - ! replaced various illegal calls to stdlib_ccopy by calls to stdlib_claset. + ! replaced various illegal calls to stdlib${ii}$_ccopy by calls to stdlib${ii}$_claset. ! sven hammarling, 1/5/02. ! Local Scalars logical(lk) :: lquery, notran - integer(ilp) :: i, ie, ifunc, iround, is, isolve, j, je, js, k, linfo, lwmin, mb, nb, & + integer(${ik}$) :: i, ie, ifunc, iround, is, isolve, j, je, js, k, linfo, lwmin, mb, nb, & p, pq, q real(sp) :: dscale, dsum, scale2, scaloc ! Intrinsic Functions intrinsic :: cmplx,max,real,sqrt ! Executable Statements ! decode and test input parameters - info = 0 + info = 0_${ik}$ notran = stdlib_lsame( trans, 'N' ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) if( .not.notran .and. .not.stdlib_lsame( trans, 'C' ) ) then - info = -1 + info = -1_${ik}$ else if( notran ) then - if( ( ijob<0 ) .or. ( ijob>4 ) ) then - info = -2 - end if - end if - if( info==0 ) then - if( m<=0 ) then - info = -3 - else if( n<=0 ) then - info = -4 - else if( lda4_${ik}$ ) ) then + info = -2_${ik}$ + end if + end if + if( info==0_${ik}$ ) then + if( m<=0_${ik}$ ) then + info = -3_${ik}$ + else if( n<=0_${ik}$ ) then + info = -4_${ik}$ + else if( lda=3 ) then - ifunc = ijob - 2 - call stdlib_claset( 'F', m, n, czero, czero, c, ldc ) - call stdlib_claset( 'F', m, n, czero, czero, f, ldf ) - else if( ijob>=1 .and. notran ) then - isolve = 2 + if( ijob>=3_${ik}$ ) then + ifunc = ijob - 2_${ik}$ + call stdlib${ii}$_claset( 'F', m, n, czero, czero, c, ldc ) + call stdlib${ii}$_claset( 'F', m, n, czero, czero, f, ldf ) + else if( ijob>=1_${ik}$ .and. notran ) then + isolve = 2_${ik}$ end if end if - if( ( mb<=1 .and. nb<=1 ) .or. ( mb>=m .and. nb>=n ) )then + if( ( mb<=1_${ik}$ .and. nb<=1_${ik}$ ) .or. ( mb>=m .and. nb>=n ) )then ! use unblocked level 2 solver loop_30: do iround = 1, isolve scale = one dscale = zero dsum = one pq = m*n - call stdlib_ctgsy2( trans, ifunc, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f,& + call stdlib${ii}$_ctgsy2( trans, ifunc, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f,& ldf, scale, dsum, dscale,info ) if( dscale/=zero ) then - if( ijob==1 .or. ijob==3 ) then - dif = sqrt( real( 2*m*n,KIND=sp) ) / ( dscale*sqrt( dsum ) ) + if( ijob==1_${ik}$ .or. ijob==3_${ik}$ ) then + dif = sqrt( real( 2_${ik}$*m*n,KIND=sp) ) / ( dscale*sqrt( dsum ) ) else dif = sqrt( real( pq,KIND=sp) ) / ( dscale*sqrt( dsum ) ) end if end if - if( isolve==2 .and. iround==1 ) then + if( isolve==2_${ik}$ .and. iround==1_${ik}$ ) then if( notran ) then ifunc = ijob end if scale2 = scale - call stdlib_clacpy( 'F', m, n, c, ldc, work, m ) - call stdlib_clacpy( 'F', m, n, f, ldf, work( m*n+1 ), m ) - call stdlib_claset( 'F', m, n, czero, czero, c, ldc ) - call stdlib_claset( 'F', m, n, czero, czero, f, ldf ) - else if( isolve==2 .and. iround==2 ) then - call stdlib_clacpy( 'F', m, n, work, m, c, ldc ) - call stdlib_clacpy( 'F', m, n, work( m*n+1 ), m, f, ldf ) + call stdlib${ii}$_clacpy( 'F', m, n, c, ldc, work, m ) + call stdlib${ii}$_clacpy( 'F', m, n, f, ldf, work( m*n+1 ), m ) + call stdlib${ii}$_claset( 'F', m, n, czero, czero, c, ldc ) + call stdlib${ii}$_claset( 'F', m, n, czero, czero, f, ldf ) + else if( isolve==2_${ik}$ .and. iround==2_${ik}$ ) then + call stdlib${ii}$_clacpy( 'F', m, n, work, m, c, ldc ) + call stdlib${ii}$_clacpy( 'F', m, n, work( m*n+1 ), m, f, ldf ) scale = scale2 end if end do loop_30 return end if ! determine block structure of a - p = 0 - i = 1 + p = 0_${ik}$ + i = 1_${ik}$ 40 continue if( i>m )go to 50 - p = p + 1 + p = p + 1_${ik}$ iwork( p ) = i i = i + mb if( i>=m )go to 50 go to 40 50 continue - iwork( p+1 ) = m + 1 - if( iwork( p )==iwork( p+1 ) )p = p - 1 + iwork( p+1 ) = m + 1_${ik}$ + if( iwork( p )==iwork( p+1 ) )p = p - 1_${ik}$ ! determine block structure of b - q = p + 1 - j = 1 + q = p + 1_${ik}$ + j = 1_${ik}$ 60 continue if( j>n )go to 70 - q = q + 1 + q = q + 1_${ik}$ iwork( q ) = j j = j + nb if( j>=n )go to 70 go to 60 70 continue - iwork( q+1 ) = n + 1 - if( iwork( q )==iwork( q+1 ) )q = q - 1 + iwork( q+1 ) = n + 1_${ik}$ + if( iwork( q )==iwork( q+1 ) )q = q - 1_${ik}$ if( notran ) then loop_150: do iround = 1, isolve ! solve (i, j) - subsystem ! a(i, i) * r(i, j) - l(i, j) * b(j, j) = c(i, j) ! d(i, i) * r(i, j) - l(i, j) * e(j, j) = f(i, j) ! for i = p, p - 1, ..., 1; j = 1, 2, ..., q - pq = 0 + pq = 0_${ik}$ scale = one dscale = zero dsum = one loop_130: do j = p + 2, q js = iwork( j ) - je = iwork( j+1 ) - 1 - nb = je - js + 1 + je = iwork( j+1 ) - 1_${ik}$ + nb = je - js + 1_${ik}$ loop_120: do i = p, 1, -1 is = iwork( i ) - ie = iwork( i+1 ) - 1 - mb = ie - is + 1 - call stdlib_ctgsy2( trans, ifunc, mb, nb, a( is, is ), lda,b( js, js ), & + ie = iwork( i+1 ) - 1_${ik}$ + mb = ie - is + 1_${ik}$ + call stdlib${ii}$_ctgsy2( trans, ifunc, mb, nb, a( is, is ), lda,b( js, js ), & ldb, c( is, js ), ldc,d( is, is ), ldd, e( js, js ), lde,f( is, js ), ldf, & scaloc, dsum, dscale,linfo ) - if( linfo>0 )info = linfo + if( linfo>0_${ik}$ )info = linfo pq = pq + mb*nb if( scaloc/=one ) then do k = 1, js - 1 - call stdlib_cscal( m, cmplx( scaloc, zero,KIND=sp), c( 1, k ),1 ) + call stdlib${ii}$_cscal( m, cmplx( scaloc, zero,KIND=sp), c( 1_${ik}$, k ),1_${ik}$ ) - call stdlib_cscal( m, cmplx( scaloc, zero,KIND=sp), f( 1, k ),1 ) + call stdlib${ii}$_cscal( m, cmplx( scaloc, zero,KIND=sp), f( 1_${ik}$, k ),1_${ik}$ ) end do do k = js, je - call stdlib_cscal( is-1, cmplx( scaloc, zero,KIND=sp),c( 1, k ), 1 ) + call stdlib${ii}$_cscal( is-1, cmplx( scaloc, zero,KIND=sp),c( 1_${ik}$, k ), 1_${ik}$ ) - call stdlib_cscal( is-1, cmplx( scaloc, zero,KIND=sp),f( 1, k ), 1 ) + call stdlib${ii}$_cscal( is-1, cmplx( scaloc, zero,KIND=sp),f( 1_${ik}$, k ), 1_${ik}$ ) end do do k = js, je - call stdlib_cscal( m-ie, cmplx( scaloc, zero,KIND=sp),c( ie+1, k ), & - 1 ) - call stdlib_cscal( m-ie, cmplx( scaloc, zero,KIND=sp),f( ie+1, k ), & - 1 ) + call stdlib${ii}$_cscal( m-ie, cmplx( scaloc, zero,KIND=sp),c( ie+1, k ), & + 1_${ik}$ ) + call stdlib${ii}$_cscal( m-ie, cmplx( scaloc, zero,KIND=sp),f( ie+1, k ), & + 1_${ik}$ ) end do do k = je + 1, n - call stdlib_cscal( m, cmplx( scaloc, zero,KIND=sp), c( 1, k ),1 ) + call stdlib${ii}$_cscal( m, cmplx( scaloc, zero,KIND=sp), c( 1_${ik}$, k ),1_${ik}$ ) - call stdlib_cscal( m, cmplx( scaloc, zero,KIND=sp), f( 1, k ),1 ) + call stdlib${ii}$_cscal( m, cmplx( scaloc, zero,KIND=sp), f( 1_${ik}$, k ),1_${ik}$ ) end do scale = scale*scaloc end if ! substitute r(i,j) and l(i,j) into remaining equation. - if( i>1 ) then - call stdlib_cgemm( 'N', 'N', is-1, nb, mb,cmplx( -one, zero,KIND=sp), a(& - 1, is ), lda,c( is, js ), ldc, cmplx( one, zero,KIND=sp),c( 1, js ), & + if( i>1_${ik}$ ) then + call stdlib${ii}$_cgemm( 'N', 'N', is-1, nb, mb,cmplx( -one, zero,KIND=sp), a(& + 1_${ik}$, is ), lda,c( is, js ), ldc, cmplx( one, zero,KIND=sp),c( 1_${ik}$, js ), & ldc ) - call stdlib_cgemm( 'N', 'N', is-1, nb, mb,cmplx( -one, zero,KIND=sp), d(& - 1, is ), ldd,c( is, js ), ldc, cmplx( one, zero,KIND=sp),f( 1, js ), & + call stdlib${ii}$_cgemm( 'N', 'N', is-1, nb, mb,cmplx( -one, zero,KIND=sp), d(& + 1_${ik}$, is ), ldd,c( is, js ), ldc, cmplx( one, zero,KIND=sp),f( 1_${ik}$, js ), & ldf ) end if if( j0 )info = linfo + if( linfo>0_${ik}$ )info = linfo if( scaloc/=one ) then do k = 1, js - 1 - call stdlib_cscal( m, cmplx( scaloc, zero,KIND=sp), c( 1, k ),1 ) + call stdlib${ii}$_cscal( m, cmplx( scaloc, zero,KIND=sp), c( 1_${ik}$, k ),1_${ik}$ ) - call stdlib_cscal( m, cmplx( scaloc, zero,KIND=sp), f( 1, k ),1 ) + call stdlib${ii}$_cscal( m, cmplx( scaloc, zero,KIND=sp), f( 1_${ik}$, k ),1_${ik}$ ) end do do k = js, je - call stdlib_cscal( is-1, cmplx( scaloc, zero,KIND=sp), c( 1, k ),1 ) + call stdlib${ii}$_cscal( is-1, cmplx( scaloc, zero,KIND=sp), c( 1_${ik}$, k ),1_${ik}$ ) - call stdlib_cscal( is-1, cmplx( scaloc, zero,KIND=sp), f( 1, k ),1 ) + call stdlib${ii}$_cscal( is-1, cmplx( scaloc, zero,KIND=sp), f( 1_${ik}$, k ),1_${ik}$ ) end do do k = js, je - call stdlib_cscal( m-ie, cmplx( scaloc, zero,KIND=sp),c( ie+1, k ), 1 ) + call stdlib${ii}$_cscal( m-ie, cmplx( scaloc, zero,KIND=sp),c( ie+1, k ), 1_${ik}$ ) - call stdlib_cscal( m-ie, cmplx( scaloc, zero,KIND=sp),f( ie+1, k ), 1 ) + call stdlib${ii}$_cscal( m-ie, cmplx( scaloc, zero,KIND=sp),f( ie+1, k ), 1_${ik}$ ) end do do k = je + 1, n - call stdlib_cscal( m, cmplx( scaloc, zero,KIND=sp), c( 1, k ),1 ) + call stdlib${ii}$_cscal( m, cmplx( scaloc, zero,KIND=sp), c( 1_${ik}$, k ),1_${ik}$ ) - call stdlib_cscal( m, cmplx( scaloc, zero,KIND=sp), f( 1, k ),1 ) + call stdlib${ii}$_cscal( m, cmplx( scaloc, zero,KIND=sp), f( 1_${ik}$, k ),1_${ik}$ ) end do scale = scale*scaloc end if ! substitute r(i,j) and l(i,j) into remaining equation. if( j>p+2 ) then - call stdlib_cgemm( 'N', 'C', mb, js-1, nb,cmplx( one, zero,KIND=sp), c( is,& - js ), ldc,b( 1, js ), ldb, cmplx( one, zero,KIND=sp),f( is, 1 ), ldf ) + call stdlib${ii}$_cgemm( 'N', 'C', mb, js-1, nb,cmplx( one, zero,KIND=sp), c( is,& + js ), ldc,b( 1_${ik}$, js ), ldb, cmplx( one, zero,KIND=sp),f( is, 1_${ik}$ ), ldf ) - call stdlib_cgemm( 'N', 'C', mb, js-1, nb,cmplx( one, zero,KIND=sp), f( is,& - js ), ldf,e( 1, js ), lde, cmplx( one, zero,KIND=sp),f( is, 1 ), ldf ) + call stdlib${ii}$_cgemm( 'N', 'C', mb, js-1, nb,cmplx( one, zero,KIND=sp), f( is,& + js ), ldf,e( 1_${ik}$, js ), lde, cmplx( one, zero,KIND=sp),f( is, 1_${ik}$ ), ldf ) end if if( i

0. if( anorm>zero ) then ! estimate the norm of the inverse of a. ainvnm = zero normin = 'N' if( onenrm ) then - kase1 = 1 + kase1 = 1_${ik}$ else - kase1 = 2 + kase1 = 2_${ik}$ end if - kase = 0 + kase = 0_${ik}$ 10 continue - call stdlib_clacn2( n, work( n+1 ), work, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_clacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + if( kase/=0_${ik}$ ) then if( kase==kase1 ) then ! multiply by inv(a). - call stdlib_clatps( uplo, 'NO TRANSPOSE', diag, normin, n, ap,work, scale, & + call stdlib${ii}$_clatps( uplo, 'NO TRANSPOSE', diag, normin, n, ap,work, scale, & rwork, info ) else ! multiply by inv(a**h). - call stdlib_clatps( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, ap, work, & + call stdlib${ii}$_clatps( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, ap, work, & scale, rwork, info ) end if normin = 'Y' ! multiply by 1/scale if doing so will not cause overflow. if( scale/=one ) then - ix = stdlib_icamax( n, work, 1 ) + ix = stdlib${ii}$_icamax( n, work, 1_${ik}$ ) xnorm = cabs1( work( ix ) ) if( scalemin(m,n) .and. min(m,n)>=0)) then - info = -3 - else if( mb<1 .or. (mb>m .and. m>0)) then - info = -4 - else if( ldamin(m,n) .and. min(m,n)>=0_${ik}$)) then + info = -3_${ik}$ + else if( mb<1_${ik}$ .or. (mb>m .and. m>0_${ik}$)) then + info = -4_${ik}$ + else if( lda=l ) then - lb = 0 + lb = 0_${ik}$ else lb = nb-n+l-i+1 end if - call stdlib_ctplqt2( ib, nb, lb, a(i,i), lda, b( i, 1 ), ldb,t(1, i ), ldt, iinfo ) + call stdlib${ii}$_ctplqt2( ib, nb, lb, a(i,i), lda, b( i, 1_${ik}$ ), ldb,t(1_${ik}$, i ), ldt, iinfo ) ! update by applying h**t to b(i+ib:m,:) from the right if( i+ib<=m ) then - call stdlib_ctprfb( 'R', 'N', 'F', 'R', m-i-ib+1, nb, ib, lb,b( i, 1 ), ldb, t( & - 1, i ), ldt,a( i+ib, i ), lda, b( i+ib, 1 ), ldb,work, m-i-ib+1) + call stdlib${ii}$_ctprfb( 'R', 'N', 'F', 'R', m-i-ib+1, nb, ib, lb,b( i, 1_${ik}$ ), ldb, t( & + 1_${ik}$, i ), ldt,a( i+ib, i ), lda, b( i+ib, 1_${ik}$ ), ldb,work, m-i-ib+1) end if end do return - end subroutine stdlib_ctplqt + end subroutine stdlib${ii}$_ctplqt - pure subroutine stdlib_ctpmlqt( side, trans, m, n, k, l, mb, v, ldv, t, ldt,a, lda, b, ldb, & + pure subroutine stdlib${ii}$_ctpmlqt( side, trans, m, n, k, l, mb, v, ldv, t, ldt,a, lda, b, ldb, & !! CTPMLQT applies a complex unitary matrix Q obtained from a !! "triangular-pentagonal" complex block reflector H to a general !! complex matrix C, which consists of two blocks A and B. @@ -50571,8 +50573,8 @@ module stdlib_linalg_lapack_c ! -- 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, lda, ldb, m, n, l, mb, ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k, ldv, lda, ldb, m, n, l, mb, ldt ! Array Arguments complex(sp), intent(in) :: v(ldv,*), t(ldt,*) complex(sp), intent(inout) :: a(lda,*), b(ldb,*) @@ -50580,46 +50582,46 @@ module stdlib_linalg_lapack_c ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran - integer(ilp) :: i, ib, nb, lb, kf, ldaq + integer(${ik}$) :: i, ib, nb, lb, kf, ldaq ! 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, 'C' ) notran = stdlib_lsame( trans, 'N' ) if ( left ) then - ldaq = max( 1, k ) + ldaq = max( 1_${ik}$, k ) else if ( right ) then - ldaq = max( 1, m ) + ldaq = max( 1_${ik}$, m ) 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 ) then - info = -5 - else if( l<0 .or. l>k ) then - info = -6 - else if( mb<1 .or. (mb>k .and. k>0) ) then - info = -7 + info = -2_${ik}$ + else if( m<0_${ik}$ ) then + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( k<0_${ik}$ ) then + info = -5_${ik}$ + else if( l<0_${ik}$ .or. l>k ) then + info = -6_${ik}$ + else if( mb<1_${ik}$ .or. (mb>k .and. k>0_${ik}$) ) then + info = -7_${ik}$ else if( ldv=l ) then - lb = 0 + lb = 0_${ik}$ else - lb = 0 + lb = 0_${ik}$ end if - call stdlib_ctprfb( 'L', 'C', 'F', 'R', nb, n, ib, lb,v( i, 1 ), ldv, t( 1, i ), & - ldt,a( i, 1 ), lda, b, ldb, work, ib ) + call stdlib${ii}$_ctprfb( 'L', 'C', 'F', 'R', nb, n, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), & + ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib ) end do else if( right .and. tran ) then do i = 1, k, mb ib = min( mb, k-i+1 ) nb = min( n-l+i+ib-1, n ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = nb-n+l-i+1 end if - call stdlib_ctprfb( 'R', 'N', 'F', 'R', m, nb, ib, lb,v( i, 1 ), ldv, t( 1, i ), & - ldt,a( 1, i ), lda, b, ldb, work, m ) + call stdlib${ii}$_ctprfb( 'R', 'N', 'F', 'R', m, nb, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), & + ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m ) end do else if( left .and. tran ) then kf = ((k-1)/mb)*mb+1 @@ -50654,12 +50656,12 @@ module stdlib_linalg_lapack_c ib = min( mb, k-i+1 ) nb = min( m-l+i+ib-1, m ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else - lb = 0 + lb = 0_${ik}$ end if - call stdlib_ctprfb( 'L', 'N', 'F', 'R', nb, n, ib, lb,v( i, 1 ), ldv, t( 1, i ), & - ldt,a( i, 1 ), lda, b, ldb, work, ib ) + call stdlib${ii}$_ctprfb( 'L', 'N', 'F', 'R', nb, n, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), & + ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib ) end do else if( right .and. notran ) then kf = ((k-1)/mb)*mb+1 @@ -50667,19 +50669,19 @@ module stdlib_linalg_lapack_c ib = min( mb, k-i+1 ) nb = min( n-l+i+ib-1, n ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = nb-n+l-i+1 end if - call stdlib_ctprfb( 'R', 'C', 'F', 'R', m, nb, ib, lb,v( i, 1 ), ldv, t( 1, i ), & - ldt,a( 1, i ), lda, b, ldb, work, m ) + call stdlib${ii}$_ctprfb( 'R', 'C', 'F', 'R', m, nb, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), & + ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m ) end do end if return - end subroutine stdlib_ctpmlqt + end subroutine stdlib${ii}$_ctpmlqt - pure subroutine stdlib_ctpmqrt( side, trans, m, n, k, l, nb, v, ldv, t, ldt,a, lda, b, ldb, & + pure subroutine stdlib${ii}$_ctpmqrt( side, trans, m, n, k, l, nb, v, ldv, t, ldt,a, lda, b, ldb, & !! CTPMQRT applies a complex orthogonal matrix Q obtained from a !! "triangular-pentagonal" complex block reflector H to a general !! complex matrix C, which consists of two blocks A and B. @@ -50689,8 +50691,8 @@ module stdlib_linalg_lapack_c ! -- 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, lda, ldb, m, n, l, nb, ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k, ldv, lda, ldb, m, n, l, nb, ldt ! Array Arguments complex(sp), intent(in) :: v(ldv,*), t(ldt,*) complex(sp), intent(inout) :: a(lda,*), b(ldb,*) @@ -50698,48 +50700,48 @@ module stdlib_linalg_lapack_c ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran - integer(ilp) :: i, ib, mb, lb, kf, ldaq, ldvq + integer(${ik}$) :: i, ib, mb, lb, kf, ldaq, ldvq ! 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, 'C' ) notran = stdlib_lsame( trans, 'N' ) if ( left ) then - ldvq = max( 1, m ) - ldaq = max( 1, k ) + ldvq = max( 1_${ik}$, m ) + ldaq = max( 1_${ik}$, k ) else if ( right ) then - ldvq = max( 1, n ) - ldaq = max( 1, m ) + ldvq = max( 1_${ik}$, n ) + ldaq = max( 1_${ik}$, m ) 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 ) then - info = -5 - else if( l<0 .or. l>k ) then - info = -6 - else if( nb<1 .or. (nb>k .and. k>0) ) then - info = -7 + info = -2_${ik}$ + else if( m<0_${ik}$ ) then + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( k<0_${ik}$ ) then + info = -5_${ik}$ + else if( l<0_${ik}$ .or. l>k ) then + info = -6_${ik}$ + else if( nb<1_${ik}$ .or. (nb>k .and. k>0_${ik}$) ) then + info = -7_${ik}$ else if( ldv=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-m+l-i+1 end if - call stdlib_ctprfb( 'L', 'C', 'F', 'C', mb, n, ib, lb,v( 1, i ), ldv, t( 1, i ), & - ldt,a( i, 1 ), lda, b, ldb, work, ib ) + call stdlib${ii}$_ctprfb( 'L', 'C', 'F', 'C', mb, n, ib, lb,v( 1_${ik}$, i ), ldv, t( 1_${ik}$, i ), & + ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib ) end do else if( right .and. notran ) then do i = 1, k, nb ib = min( nb, k-i+1 ) mb = min( n-l+i+ib-1, n ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-n+l-i+1 end if - call stdlib_ctprfb( 'R', 'N', 'F', 'C', m, mb, ib, lb,v( 1, i ), ldv, t( 1, i ), & - ldt,a( 1, i ), lda, b, ldb, work, m ) + call stdlib${ii}$_ctprfb( 'R', 'N', 'F', 'C', m, mb, ib, lb,v( 1_${ik}$, i ), ldv, t( 1_${ik}$, i ), & + ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m ) end do else if( left .and. notran ) then kf = ((k-1)/nb)*nb+1 @@ -50774,12 +50776,12 @@ module stdlib_linalg_lapack_c ib = min( nb, k-i+1 ) mb = min( m-l+i+ib-1, m ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-m+l-i+1 end if - call stdlib_ctprfb( 'L', 'N', 'F', 'C', mb, n, ib, lb,v( 1, i ), ldv, t( 1, i ), & - ldt,a( i, 1 ), lda, b, ldb, work, ib ) + call stdlib${ii}$_ctprfb( 'L', 'N', 'F', 'C', mb, n, ib, lb,v( 1_${ik}$, i ), ldv, t( 1_${ik}$, i ), & + ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib ) end do else if( right .and. tran ) then kf = ((k-1)/nb)*nb+1 @@ -50787,19 +50789,19 @@ module stdlib_linalg_lapack_c ib = min( nb, k-i+1 ) mb = min( n-l+i+ib-1, n ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-n+l-i+1 end if - call stdlib_ctprfb( 'R', 'C', 'F', 'C', m, mb, ib, lb,v( 1, i ), ldv, t( 1, i ), & - ldt,a( 1, i ), lda, b, ldb, work, m ) + call stdlib${ii}$_ctprfb( 'R', 'C', 'F', 'C', m, mb, ib, lb,v( 1_${ik}$, i ), ldv, t( 1_${ik}$, i ), & + ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m ) end do end if return - end subroutine stdlib_ctpmqrt + end subroutine stdlib${ii}$_ctpmqrt - pure subroutine stdlib_ctpqrt( m, n, l, nb, a, lda, b, ldb, t, ldt, work,info ) + pure subroutine stdlib${ii}$_ctpqrt( m, n, l, nb, a, lda, b, ldb, t, ldt, work,info ) !! CTPQRT computes a blocked QR factorization of a complex !! "triangular-pentagonal" matrix C, which is composed of a !! triangular block A and pentagonal block B, using the compact @@ -50808,34 +50810,34 @@ module stdlib_linalg_lapack_c ! -- 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, ldb, ldt, n, m, l, nb + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l, nb ! Array Arguments complex(sp), intent(inout) :: a(lda,*), b(ldb,*) complex(sp), intent(out) :: t(ldt,*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ib, lb, mb, iinfo + integer(${ik}$) :: i, ib, lb, mb, iinfo ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( l<0 .or. (l>min(m,n) .and. min(m,n)>=0)) then - info = -3 - else if( nb<1 .or. (nb>n .and. n>0)) then - info = -4 - else if( ldamin(m,n) .and. min(m,n)>=0_${ik}$)) then + info = -3_${ik}$ + else if( nb<1_${ik}$ .or. (nb>n .and. n>0_${ik}$)) then + info = -4_${ik}$ + else if( lda=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-m+l-i+1 end if - call stdlib_ctpqrt2( mb, ib, lb, a(i,i), lda, b( 1, i ), ldb,t(1, i ), ldt, iinfo ) + call stdlib${ii}$_ctpqrt2( mb, ib, lb, a(i,i), lda, b( 1_${ik}$, i ), ldb,t(1_${ik}$, i ), ldt, iinfo ) ! update by applying h**h to b(:,i+ib:n) from the left if( i+ib<=n ) then - call stdlib_ctprfb( 'L', 'C', 'F', 'C', mb, n-i-ib+1, ib, lb,b( 1, i ), ldb, t( & - 1, i ), ldt,a( i, i+ib ), lda, b( 1, i+ib ), ldb,work, ib ) + call stdlib${ii}$_ctprfb( 'L', 'C', 'F', 'C', mb, n-i-ib+1, ib, lb,b( 1_${ik}$, i ), ldb, t( & + 1_${ik}$, i ), ldt,a( i, i+ib ), lda, b( 1_${ik}$, i+ib ), ldb,work, ib ) end if end do return - end subroutine stdlib_ctpqrt + end subroutine stdlib${ii}$_ctpqrt - subroutine stdlib_ctrcon( norm, uplo, diag, n, a, lda, rcond, work,rwork, info ) + subroutine stdlib${ii}$_ctrcon( norm, uplo, diag, n, a, lda, rcond, work,rwork, info ) !! CTRCON estimates the reciprocal of the condition number of a !! triangular matrix A, in either the 1-norm or the infinity-norm. !! The norm of A is computed and an estimate is obtained for @@ -50873,8 +50875,8 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: diag, norm, 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) :: rcond ! Array Arguments real(sp), intent(out) :: rwork(*) @@ -50885,11 +50887,11 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: nounit, onenrm, upper character :: normin - integer(ilp) :: ix, kase, kase1 + integer(${ik}$) :: ix, kase, kase1 real(sp) :: ainvnm, anorm, scale, smlnum, xnorm complex(sp) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,aimag,max,real ! Statement Functions @@ -50898,64 +50900,64 @@ module stdlib_linalg_lapack_c cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' ) nounit = stdlib_lsame( diag, 'N' ) if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) 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( lda 0. if( anorm>zero ) then ! estimate the norm of the inverse of a. ainvnm = zero normin = 'N' if( onenrm ) then - kase1 = 1 + kase1 = 1_${ik}$ else - kase1 = 2 + kase1 = 2_${ik}$ end if - kase = 0 + kase = 0_${ik}$ 10 continue - call stdlib_clacn2( n, work( n+1 ), work, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_clacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + if( kase/=0_${ik}$ ) then if( kase==kase1 ) then ! multiply by inv(a). - call stdlib_clatrs( uplo, 'NO TRANSPOSE', diag, normin, n, a,lda, work, scale,& + call stdlib${ii}$_clatrs( uplo, 'NO TRANSPOSE', diag, normin, n, a,lda, work, scale,& rwork, info ) else ! multiply by inv(a**h). - call stdlib_clatrs( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, a, lda, work,& + call stdlib${ii}$_clatrs( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, a, lda, work,& scale, rwork, info ) end if normin = 'Y' ! multiply by 1/scale if doing so will not cause overflow. if( scale/=one ) then - ix = stdlib_icamax( n, work, 1 ) + ix = stdlib${ii}$_icamax( n, work, 1_${ik}$ ) xnorm = cabs1( work( ix ) ) if( scaleone ) then if( db>bignum*da11 )scaloc = one / db end if - x11 = stdlib_cladiv( vec*cmplx( scaloc,KIND=sp), a11 ) + x11 = stdlib${ii}$_cladiv( vec*cmplx( scaloc,KIND=sp), a11 ) if( scaloc/=one ) then do j = 1, n - call stdlib_csscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_csscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if @@ -51085,8 +51087,8 @@ module stdlib_linalg_lapack_c ! i=1 j=1 loop_60: do l = 1, n do k = 1, m - suml = stdlib_cdotc( k-1, a( 1, k ), 1, c( 1, l ), 1 ) - sumr = stdlib_cdotu( l-1, c( k, 1 ), ldc, b( 1, l ), 1 ) + suml = stdlib${ii}$_cdotc( k-1, a( 1_${ik}$, k ), 1_${ik}$, c( 1_${ik}$, l ), 1_${ik}$ ) + sumr = stdlib${ii}$_cdotu( l-1, c( k, 1_${ik}$ ), ldc, b( 1_${ik}$, l ), 1_${ik}$ ) vec = c( k, l ) - ( suml+sgn*sumr ) scaloc = one a11 = conjg( a( k, k ) ) + sgn*b( l, l ) @@ -51094,16 +51096,16 @@ module stdlib_linalg_lapack_c if( da11<=smin ) then a11 = smin da11 = smin - info = 1 + info = 1_${ik}$ end if db = abs( real( vec,KIND=sp) ) + abs( aimag( vec ) ) if( da11one ) then if( db>bignum*da11 )scaloc = one / db end if - x11 = stdlib_cladiv( vec*cmplx( scaloc,KIND=sp), a11 ) + x11 = stdlib${ii}$_cladiv( vec*cmplx( scaloc,KIND=sp), a11 ) if( scaloc/=one ) then do j = 1, n - call stdlib_csscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_csscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if @@ -51124,8 +51126,8 @@ module stdlib_linalg_lapack_c ! j=l+1 loop_90: do l = n, 1, -1 do k = 1, m - suml = stdlib_cdotc( k-1, a( 1, k ), 1, c( 1, l ), 1 ) - sumr = stdlib_cdotc( n-l, c( k, min( l+1, n ) ), ldc,b( l, min( l+1, n ) ), & + suml = stdlib${ii}$_cdotc( k-1, a( 1_${ik}$, k ), 1_${ik}$, c( 1_${ik}$, l ), 1_${ik}$ ) + sumr = stdlib${ii}$_cdotc( n-l, c( k, min( l+1, n ) ), ldc,b( l, min( l+1, n ) ), & ldb ) vec = c( k, l ) - ( suml+sgn*conjg( sumr ) ) scaloc = one @@ -51134,16 +51136,16 @@ module stdlib_linalg_lapack_c if( da11<=smin ) then a11 = smin da11 = smin - info = 1 + info = 1_${ik}$ end if db = abs( real( vec,KIND=sp) ) + abs( aimag( vec ) ) if( da11one ) then if( db>bignum*da11 )scaloc = one / db end if - x11 = stdlib_cladiv( vec*cmplx( scaloc,KIND=sp), a11 ) + x11 = stdlib${ii}$_cladiv( vec*cmplx( scaloc,KIND=sp), a11 ) if( scaloc/=one ) then do j = 1, n - call stdlib_csscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_csscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if @@ -51161,9 +51163,9 @@ module stdlib_linalg_lapack_c ! i=k+1 j=l+1 loop_120: do l = n, 1, -1 do k = m, 1, -1 - suml = stdlib_cdotu( m-k, a( k, min( k+1, m ) ), lda,c( min( k+1, m ), l ), 1 & + suml = stdlib${ii}$_cdotu( m-k, a( k, min( k+1, m ) ), lda,c( min( k+1, m ), l ), 1_${ik}$ & ) - sumr = stdlib_cdotc( n-l, c( k, min( l+1, n ) ), ldc,b( l, min( l+1, n ) ), & + sumr = stdlib${ii}$_cdotc( n-l, c( k, min( l+1, n ) ), ldc,b( l, min( l+1, n ) ), & ldb ) vec = c( k, l ) - ( suml+sgn*conjg( sumr ) ) scaloc = one @@ -51172,16 +51174,16 @@ module stdlib_linalg_lapack_c if( da11<=smin ) then a11 = smin da11 = smin - info = 1 + info = 1_${ik}$ end if db = abs( real( vec,KIND=sp) ) + abs( aimag( vec ) ) if( da11one ) then if( db>bignum*da11 )scaloc = one / db end if - x11 = stdlib_cladiv( vec*cmplx( scaloc,KIND=sp), a11 ) + x11 = stdlib${ii}$_cladiv( vec*cmplx( scaloc,KIND=sp), a11 ) if( scaloc/=one ) then do j = 1, n - call stdlib_csscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_csscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if @@ -51190,10 +51192,10 @@ module stdlib_linalg_lapack_c end do loop_120 end if return - end subroutine stdlib_ctrsyl + end subroutine stdlib${ii}$_ctrsyl - pure subroutine stdlib_cunbdb5( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & + pure subroutine stdlib${ii}$_cunbdb5( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & !! CUNBDB5 orthogonalizes the column vector !! X = [ X1 ] !! [ X2 ] @@ -51210,8 +51212,8 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(in) :: q1(ldq1,*), q2(ldq2,*) complex(sp), intent(out) :: work(*) @@ -51219,38 +51221,38 @@ module stdlib_linalg_lapack_c ! ===================================================================== ! Local Scalars - integer(ilp) :: childinfo, i, j + integer(${ik}$) :: childinfo, i, j ! 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( 'CUNBDB5', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'CUNBDB5', -info ) return end if ! project x onto the orthogonal complement of q - call stdlib_cunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2,work, lwork, & + call stdlib${ii}$_cunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2,work, lwork, & childinfo ) ! if the projection is nonzero, then return - if( stdlib_scnrm2(m1,x1,incx1) /= czero.or. stdlib_scnrm2(m2,x2,incx2) /= czero ) & + if( stdlib${ii}$_scnrm2(m1,x1,incx1) /= czero.or. stdlib${ii}$_scnrm2(m2,x2,incx2) /= czero ) & then return end if @@ -51264,9 +51266,9 @@ module stdlib_linalg_lapack_c do j = 1, m2 x2(j) = czero end do - call stdlib_cunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & + call stdlib${ii}$_cunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & lwork, childinfo ) - if( stdlib_scnrm2(m1,x1,incx1) /= czero.or. stdlib_scnrm2(m2,x2,incx2) /= czero ) & + if( stdlib${ii}$_scnrm2(m1,x1,incx1) /= czero.or. stdlib${ii}$_scnrm2(m2,x2,incx2) /= czero ) & then return end if @@ -51281,18 +51283,18 @@ module stdlib_linalg_lapack_c x2(j) = czero end do x2(i) = cone - call stdlib_cunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & + call stdlib${ii}$_cunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & lwork, childinfo ) - if( stdlib_scnrm2(m1,x1,incx1) /= czero.or. stdlib_scnrm2(m2,x2,incx2) /= czero ) & + if( stdlib${ii}$_scnrm2(m1,x1,incx1) /= czero.or. stdlib${ii}$_scnrm2(m2,x2,incx2) /= czero ) & then return end if end do return - end subroutine stdlib_cunbdb5 + end subroutine stdlib${ii}$_cunbdb5 - recursive subroutine stdlib_cuncsd( jobu1, jobu2, jobv1t, jobv2t, trans,signs, m, p, q, x11, & + recursive subroutine stdlib${ii}$_cuncsd( jobu1, jobu2, jobv1t, jobv2t, trans,signs, m, p, q, x11, & !! CUNCSD computes the CS decomposition of an M-by-M partitioned !! unitary matrix X: !! [ I 0 0 | 0 0 0 ] @@ -51313,11 +51315,11 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobu1, jobu2, jobv1t, jobv2t, signs, trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldu1, ldu2, ldv1t, ldv2t, ldx11, ldx12, ldx21, ldx22, & + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldu1, ldu2, ldv1t, ldv2t, ldx11, ldx12, ldx21, ldx22, & lrwork, lwork, m, p, q ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(out) :: theta(*) real(sp), intent(out) :: rwork(*) complex(sp), intent(out) :: u1(ldu1,*), u2(ldu2,*), v1t(ldv1t,*), v2t(ldv2t,*), work(*) @@ -51328,60 +51330,60 @@ module stdlib_linalg_lapack_c ! Local Scalars character :: transt, signst - integer(ilp) :: childinfo, i, ib11d, ib11e, ib12d, ib12e, ib21d, ib21e, ib22d, ib22e, & + integer(${ik}$) :: childinfo, i, ib11d, ib11e, ib12d, ib12e, ib21d, ib21e, ib22d, ib22e, & ibbcsd, iorbdb, iorglq, iorgqr, iphi, itaup1, itaup2, itauq1, itauq2, j, lbbcsdwork, & lbbcsdworkmin, lbbcsdworkopt, lorbdbwork, lorbdbworkmin, lorbdbworkopt, lorglqwork, & lorglqworkmin, lorglqworkopt, lorgqrwork, lorgqrworkmin, lorgqrworkopt, lworkmin, & lworkopt, p1, q1 logical(lk) :: colmajor, defaultsigns, lquery, wantu1, wantu2, wantv1t, wantv2t - integer(ilp) :: lrworkmin, lrworkopt + integer(${ik}$) :: lrworkmin, lrworkopt logical(lk) :: lrquery ! Intrinsic Functions intrinsic :: int,max,min ! Executable Statements ! test input arguments - info = 0 + info = 0_${ik}$ wantu1 = stdlib_lsame( jobu1, 'Y' ) wantu2 = stdlib_lsame( jobu2, 'Y' ) wantv1t = stdlib_lsame( jobv1t, 'Y' ) wantv2t = stdlib_lsame( jobv2t, 'Y' ) colmajor = .not. stdlib_lsame( trans, 'T' ) defaultsigns = .not. stdlib_lsame( signs, 'O' ) - lquery = lwork == -1 - lrquery = lrwork == -1 - if( m < 0 ) then - info = -7 - else if( p < 0 .or. p > m ) then - info = -8 - else if( q < 0 .or. q > m ) then - info = -9 - else if ( colmajor .and. ldx11 < max( 1, p ) ) then - info = -11 - else if (.not. colmajor .and. ldx11 < max( 1, q ) ) then - info = -11 - else if (colmajor .and. ldx12 < max( 1, p ) ) then - info = -13 - else if (.not. colmajor .and. ldx12 < max( 1, m-q ) ) then - info = -13 - else if (colmajor .and. ldx21 < max( 1, m-p ) ) then - info = -15 - else if (.not. colmajor .and. ldx21 < max( 1, q ) ) then - info = -15 - else if (colmajor .and. ldx22 < max( 1, m-p ) ) then - info = -17 - else if (.not. colmajor .and. ldx22 < max( 1, m-q ) ) then - info = -17 + lquery = lwork == -1_${ik}$ + lrquery = lrwork == -1_${ik}$ + if( m < 0_${ik}$ ) then + info = -7_${ik}$ + else if( p < 0_${ik}$ .or. p > m ) then + info = -8_${ik}$ + else if( q < 0_${ik}$ .or. q > m ) then + info = -9_${ik}$ + else if ( colmajor .and. ldx11 < max( 1_${ik}$, p ) ) then + info = -11_${ik}$ + else if (.not. colmajor .and. ldx11 < max( 1_${ik}$, q ) ) then + info = -11_${ik}$ + else if (colmajor .and. ldx12 < max( 1_${ik}$, p ) ) then + info = -13_${ik}$ + else if (.not. colmajor .and. ldx12 < max( 1_${ik}$, m-q ) ) then + info = -13_${ik}$ + else if (colmajor .and. ldx21 < max( 1_${ik}$, m-p ) ) then + info = -15_${ik}$ + else if (.not. colmajor .and. ldx21 < max( 1_${ik}$, q ) ) then + info = -15_${ik}$ + else if (colmajor .and. ldx22 < max( 1_${ik}$, m-p ) ) then + info = -17_${ik}$ + else if (.not. colmajor .and. ldx22 < max( 1_${ik}$, m-q ) ) then + info = -17_${ik}$ else if( wantu1 .and. ldu1 < p ) then - info = -20 + info = -20_${ik}$ else if( wantu2 .and. ldu2 < m-p ) then - info = -22 + info = -22_${ik}$ else if( wantv1t .and. ldv1t < q ) then - info = -24 + info = -24_${ik}$ else if( wantv2t .and. ldv2t < m-q ) then - info = -26 + info = -26_${ik}$ end if ! work with transpose if convenient - if( info == 0 .and. min( p, m-p ) < min( q, m-q ) ) then + if( info == 0_${ik}$ .and. min( p, m-p ) < min( q, m-q ) ) then if( colmajor ) then transt = 'T' else @@ -51392,158 +51394,158 @@ module stdlib_linalg_lapack_c else signst = 'D' end if - call stdlib_cuncsd( jobv1t, jobv2t, jobu1, jobu2, transt, signst, m,q, p, x11, & + call stdlib${ii}$_cuncsd( jobv1t, jobv2t, jobu1, jobu2, transt, signst, m,q, p, x11, & ldx11, x21, ldx21, x12, ldx12, x22,ldx22, theta, v1t, ldv1t, v2t, ldv2t, u1, ldu1,& u2, ldu2, work, lwork, rwork, lrwork, iwork,info ) return end if ! work with permutation [ 0 i; i 0 ] * x * [ 0 i; i 0 ] if ! convenient - if( info == 0 .and. m-q < q ) then + if( info == 0_${ik}$ .and. m-q < q ) then if( defaultsigns ) then signst = 'O' else signst = 'D' end if - call stdlib_cuncsd( jobu2, jobu1, jobv2t, jobv1t, trans, signst, m,m-p, m-q, x22, & + call stdlib${ii}$_cuncsd( jobu2, jobu1, jobv2t, jobv1t, trans, signst, m,m-p, m-q, x22, & ldx22, x21, ldx21, x12, ldx12, x11,ldx11, theta, u2, ldu2, u1, ldu1, v2t, ldv2t, & v1t,ldv1t, work, lwork, rwork, lrwork, iwork, info ) return end if ! compute workspace - if( info == 0 ) then + if( info == 0_${ik}$ ) then ! real workspace - iphi = 2 - ib11d = iphi + max( 1, q - 1 ) - ib11e = ib11d + max( 1, q ) - ib12d = ib11e + max( 1, q - 1 ) - ib12e = ib12d + max( 1, q ) - ib21d = ib12e + max( 1, q - 1 ) - ib21e = ib21d + max( 1, q ) - ib22d = ib21e + max( 1, q - 1 ) - ib22e = ib22d + max( 1, q ) - ibbcsd = ib22e + max( 1, q - 1 ) - call stdlib_cbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, theta, u1, & + iphi = 2_${ik}$ + ib11d = iphi + max( 1_${ik}$, q - 1_${ik}$ ) + ib11e = ib11d + max( 1_${ik}$, q ) + ib12d = ib11e + max( 1_${ik}$, q - 1_${ik}$ ) + ib12e = ib12d + max( 1_${ik}$, q ) + ib21d = ib12e + max( 1_${ik}$, q - 1_${ik}$ ) + ib21e = ib21d + max( 1_${ik}$, q ) + ib22d = ib21e + max( 1_${ik}$, q - 1_${ik}$ ) + ib22e = ib22d + max( 1_${ik}$, q ) + ibbcsd = ib22e + max( 1_${ik}$, q - 1_${ik}$ ) + call stdlib${ii}$_cbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, theta, u1, & ldu1, u2, ldu2, v1t, ldv1t,v2t, ldv2t, theta, theta, theta, theta, theta,theta, & - theta, theta, rwork, -1, childinfo ) - lbbcsdworkopt = int( rwork(1),KIND=ilp) + theta, theta, rwork, -1_${ik}$, childinfo ) + lbbcsdworkopt = int( rwork(1_${ik}$),KIND=${ik}$) lbbcsdworkmin = lbbcsdworkopt - lrworkopt = ibbcsd + lbbcsdworkopt - 1 - lrworkmin = ibbcsd + lbbcsdworkmin - 1 - rwork(1) = lrworkopt + lrworkopt = ibbcsd + lbbcsdworkopt - 1_${ik}$ + lrworkmin = ibbcsd + lbbcsdworkmin - 1_${ik}$ + rwork(1_${ik}$) = lrworkopt ! complex workspace - itaup1 = 2 - itaup2 = itaup1 + max( 1, p ) - itauq1 = itaup2 + max( 1, m - p ) - itauq2 = itauq1 + max( 1, q ) - iorgqr = itauq2 + max( 1, m - q ) - call stdlib_cungqr( m-q, m-q, m-q, u1, max(1,m-q), u1, work, -1,childinfo ) - lorgqrworkopt = int( work(1),KIND=ilp) - lorgqrworkmin = max( 1, m - q ) - iorglq = itauq2 + max( 1, m - q ) - call stdlib_cunglq( m-q, m-q, m-q, u1, max(1,m-q), u1, work, -1,childinfo ) - lorglqworkopt = int( work(1),KIND=ilp) - lorglqworkmin = max( 1, m - q ) - iorbdb = itauq2 + max( 1, m - q ) - call stdlib_cunbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & - ldx22, theta, theta, u1, u2,v1t, v2t, work, -1, childinfo ) - lorbdbworkopt = int( work(1),KIND=ilp) + itaup1 = 2_${ik}$ + itaup2 = itaup1 + max( 1_${ik}$, p ) + itauq1 = itaup2 + max( 1_${ik}$, m - p ) + itauq2 = itauq1 + max( 1_${ik}$, q ) + iorgqr = itauq2 + max( 1_${ik}$, m - q ) + call stdlib${ii}$_cungqr( m-q, m-q, m-q, u1, max(1_${ik}$,m-q), u1, work, -1_${ik}$,childinfo ) + lorgqrworkopt = int( work(1_${ik}$),KIND=${ik}$) + lorgqrworkmin = max( 1_${ik}$, m - q ) + iorglq = itauq2 + max( 1_${ik}$, m - q ) + call stdlib${ii}$_cunglq( m-q, m-q, m-q, u1, max(1_${ik}$,m-q), u1, work, -1_${ik}$,childinfo ) + lorglqworkopt = int( work(1_${ik}$),KIND=${ik}$) + lorglqworkmin = max( 1_${ik}$, m - q ) + iorbdb = itauq2 + max( 1_${ik}$, m - q ) + call stdlib${ii}$_cunbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & + ldx22, theta, theta, u1, u2,v1t, v2t, work, -1_${ik}$, childinfo ) + lorbdbworkopt = int( work(1_${ik}$),KIND=${ik}$) lorbdbworkmin = lorbdbworkopt lworkopt = max( iorgqr + lorgqrworkopt, iorglq + lorglqworkopt,iorbdb + & - lorbdbworkopt ) - 1 + lorbdbworkopt ) - 1_${ik}$ lworkmin = max( iorgqr + lorgqrworkmin, iorglq + lorglqworkmin,iorbdb + & - lorbdbworkmin ) - 1 - work(1) = max(lworkopt,lworkmin) + lorbdbworkmin ) - 1_${ik}$ + work(1_${ik}$) = max(lworkopt,lworkmin) if( lwork < lworkmin.and. .not. ( lquery .or. lrquery ) ) then - info = -22 + info = -22_${ik}$ else if( lrwork < lrworkmin.and. .not. ( lquery .or. lrquery ) ) then - info = -24 + info = -24_${ik}$ else - lorgqrwork = lwork - iorgqr + 1 - lorglqwork = lwork - iorglq + 1 - lorbdbwork = lwork - iorbdb + 1 - lbbcsdwork = lrwork - ibbcsd + 1 + lorgqrwork = lwork - iorgqr + 1_${ik}$ + lorglqwork = lwork - iorglq + 1_${ik}$ + lorbdbwork = lwork - iorbdb + 1_${ik}$ + lbbcsdwork = lrwork - ibbcsd + 1_${ik}$ end if end if ! abort if any illegal arguments - if( info /= 0 ) then - call stdlib_xerbla( 'CUNCSD', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'CUNCSD', -info ) return else if( lquery .or. lrquery ) then return end if ! transform to bidiagonal block form - call stdlib_cunbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12, x21,ldx21, x22, & + call stdlib${ii}$_cunbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12, x21,ldx21, x22, & ldx22, theta, rwork(iphi), work(itaup1),work(itaup2), work(itauq1), work(itauq2),work(& iorbdb), lorbdbwork, childinfo ) ! accumulate householder reflectors if( colmajor ) then - if( wantu1 .and. p > 0 ) then - call stdlib_clacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) - call stdlib_cungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqrwork, & + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_clacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) + call stdlib${ii}$_cungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqrwork, & info) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_clacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) - call stdlib_cungqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqrwork,& + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_clacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) + call stdlib${ii}$_cungqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqrwork,& info ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_clacpy( 'U', q-1, q-1, x11(1,2), ldx11, v1t(2,2),ldv1t ) - v1t(1, 1) = cone + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_clacpy( 'U', q-1, q-1, x11(1_${ik}$,2_${ik}$), ldx11, v1t(2_${ik}$,2_${ik}$),ldv1t ) + v1t(1_${ik}$, 1_${ik}$) = cone do j = 2, q - v1t(1,j) = czero - v1t(j,1) = czero + v1t(1_${ik}$,j) = czero + v1t(j,1_${ik}$) = czero end do - call stdlib_cunglq( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),work(iorglq), & + call stdlib${ii}$_cunglq( q-1, q-1, q-1, v1t(2_${ik}$,2_${ik}$), ldv1t, work(itauq1),work(iorglq), & lorglqwork, info ) end if - if( wantv2t .and. m-q > 0 ) then - call stdlib_clacpy( 'U', p, m-q, x12, ldx12, v2t, ldv2t ) + if( wantv2t .and. m-q > 0_${ik}$ ) then + call stdlib${ii}$_clacpy( 'U', p, m-q, x12, ldx12, v2t, ldv2t ) if( m-p > q ) then - call stdlib_clacpy( 'U', m-p-q, m-p-q, x22(q+1,p+1), ldx22,v2t(p+1,p+1), & + call stdlib${ii}$_clacpy( 'U', m-p-q, m-p-q, x22(q+1,p+1), ldx22,v2t(p+1,p+1), & ldv2t ) end if if( m > q ) then - call stdlib_cunglq( m-q, m-q, m-q, v2t, ldv2t, work(itauq2),work(iorglq), & + call stdlib${ii}$_cunglq( m-q, m-q, m-q, v2t, ldv2t, work(itauq2),work(iorglq), & lorglqwork, info ) end if end if else - if( wantu1 .and. p > 0 ) then - call stdlib_clacpy( 'U', q, p, x11, ldx11, u1, ldu1 ) - call stdlib_cunglq( p, p, q, u1, ldu1, work(itaup1), work(iorglq),lorglqwork, & + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_clacpy( 'U', q, p, x11, ldx11, u1, ldu1 ) + call stdlib${ii}$_cunglq( p, p, q, u1, ldu1, work(itaup1), work(iorglq),lorglqwork, & info) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_clacpy( 'U', q, m-p, x21, ldx21, u2, ldu2 ) - call stdlib_cunglq( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorglq), lorglqwork,& + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_clacpy( 'U', q, m-p, x21, ldx21, u2, ldu2 ) + call stdlib${ii}$_cunglq( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorglq), lorglqwork,& info ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_clacpy( 'L', q-1, q-1, x11(2,1), ldx11, v1t(2,2),ldv1t ) - v1t(1, 1) = cone + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_clacpy( 'L', q-1, q-1, x11(2_${ik}$,1_${ik}$), ldx11, v1t(2_${ik}$,2_${ik}$),ldv1t ) + v1t(1_${ik}$, 1_${ik}$) = cone do j = 2, q - v1t(1,j) = czero - v1t(j,1) = czero + v1t(1_${ik}$,j) = czero + v1t(j,1_${ik}$) = czero end do - call stdlib_cungqr( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),work(iorgqr), & + call stdlib${ii}$_cungqr( q-1, q-1, q-1, v1t(2_${ik}$,2_${ik}$), ldv1t, work(itauq1),work(iorgqr), & lorgqrwork, info ) end if - if( wantv2t .and. m-q > 0 ) then + if( wantv2t .and. m-q > 0_${ik}$ ) then p1 = min( p+1, m ) q1 = min( q+1, m ) - call stdlib_clacpy( 'L', m-q, p, x12, ldx12, v2t, ldv2t ) + call stdlib${ii}$_clacpy( 'L', m-q, p, x12, ldx12, v2t, ldv2t ) if ( m > p+q ) then - call stdlib_clacpy( 'L', m-p-q, m-p-q, x22(p1,q1), ldx22,v2t(p+1,p+1), ldv2t ) + call stdlib${ii}$_clacpy( 'L', m-p-q, m-p-q, x22(p1,q1), ldx22,v2t(p+1,p+1), ldv2t ) end if - call stdlib_cungqr( m-q, m-q, m-q, v2t, ldv2t, work(itauq2),work(iorgqr), & + call stdlib${ii}$_cungqr( m-q, m-q, m-q, v2t, ldv2t, work(itauq2),work(iorgqr), & lorgqrwork, info ) end if end if ! compute the csd of the matrix in bidiagonal-block form - call stdlib_cbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q, theta,rwork(iphi), & + call stdlib${ii}$_cbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q, theta,rwork(iphi), & u1, ldu1, u2, ldu2, v1t, ldv1t, v2t,ldv2t, rwork(ib11d), rwork(ib11e), rwork(ib12d),& rwork(ib12e), rwork(ib21d), rwork(ib21e),rwork(ib22d), rwork(ib22e), rwork(ibbcsd),& lbbcsdwork, info ) @@ -51551,7 +51553,7 @@ module stdlib_linalg_lapack_c ! left corner of (1,1)-block and/or bottom-right corner of (1,2)- ! block and/or bottom-right corner of (2,1)-block and/or top-left ! corner of (2,2)-block - if( q > 0 .and. wantu2 ) then + if( q > 0_${ik}$ .and. wantu2 ) then do i = 1, q iwork(i) = m - p - q + i end do @@ -51559,12 +51561,12 @@ module stdlib_linalg_lapack_c iwork(i) = i - q end do if( colmajor ) then - call stdlib_clapmt( .false., m-p, m-p, u2, ldu2, iwork ) + call stdlib${ii}$_clapmt( .false., m-p, m-p, u2, ldu2, iwork ) else - call stdlib_clapmr( .false., m-p, m-p, u2, ldu2, iwork ) + call stdlib${ii}$_clapmr( .false., m-p, m-p, u2, ldu2, iwork ) end if end if - if( m > 0 .and. wantv2t ) then + if( m > 0_${ik}$ .and. wantv2t ) then do i = 1, p iwork(i) = m - p - q + i end do @@ -51572,17 +51574,17 @@ module stdlib_linalg_lapack_c iwork(i) = i - p end do if( .not. colmajor ) then - call stdlib_clapmt( .false., m-q, m-q, v2t, ldv2t, iwork ) + call stdlib${ii}$_clapmt( .false., m-q, m-q, v2t, ldv2t, iwork ) else - call stdlib_clapmr( .false., m-q, m-q, v2t, ldv2t, iwork ) + call stdlib${ii}$_clapmr( .false., m-q, m-q, v2t, ldv2t, iwork ) end if end if return - ! end stdlib_cuncsd - end subroutine stdlib_cuncsd + ! end stdlib${ii}$_cuncsd + end subroutine stdlib${ii}$_cuncsd - pure subroutine stdlib_cunghr( n, ilo, ihi, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_cunghr( n, ilo, ihi, a, lda, tau, work, lwork, info ) !! CUNGHR generates a complex unitary matrix Q which is defined as the !! product of IHI-ILO elementary reflectors of order N, as returned by !! CGEHRD: @@ -51591,8 +51593,8 @@ module stdlib_linalg_lapack_c ! -- 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, lda, lwork, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ilo, lda, lwork, n + integer(${ik}$), intent(out) :: info ! Array Arguments complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(in) :: tau(*) @@ -51601,39 +51603,39 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, iinfo, j, lwkopt, nb, nh + integer(${ik}$) :: i, iinfo, j, lwkopt, nb, nh ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ nh = ihi - ilo - lquery = ( lwork==-1 ) - if( n<0 ) then - info = -1 - else if( ilo<1 .or. ilo>max( 1, n ) ) then - info = -2 + lquery = ( lwork==-1_${ik}$ ) + if( n<0_${ik}$ ) then + info = -1_${ik}$ + else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then + info = -2_${ik}$ else if( ihin ) then - info = -3 - else if( lda0 ) then + if( nh>0_${ik}$ ) then ! generate q(ilo+1:ihi,ilo+1:ihi) - call stdlib_cungqr( nh, nh, nh, a( ilo+1, ilo+1 ), lda, tau( ilo ),work, lwork, & + call stdlib${ii}$_cungqr( nh, nh, nh, a( ilo+1, ilo+1 ), lda, tau( ilo ),work, lwork, & iinfo ) end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_cunghr + end subroutine stdlib${ii}$_cunghr - pure subroutine stdlib_cungtr( uplo, n, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_cungtr( uplo, n, a, lda, tau, work, lwork, info ) !! CUNGTR generates a complex unitary matrix Q which is defined as the !! product of n-1 elementary reflectors of order N, as returned by !! CHETRD: @@ -51683,8 +51685,8 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(in) :: tau(*) @@ -51693,45 +51695,45 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: lquery, upper - integer(ilp) :: i, iinfo, j, lwkopt, nb + integer(${ik}$) :: i, iinfo, j, lwkopt, nb ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${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 + if( n>1_${ik}$ ) then ! generate q(2:n,2:n) - call stdlib_cungqr( n-1, n-1, n-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) + call stdlib${ii}$_cungqr( n-1, n-1, n-1, a( 2_${ik}$, 2_${ik}$ ), lda, tau, work,lwork, iinfo ) end if end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_cungtr + end subroutine stdlib${ii}$_cungtr - pure subroutine stdlib_cunhr_col( m, n, nb, a, lda, t, ldt, d, info ) + pure subroutine stdlib${ii}$_cunhr_col( m, n, nb, a, lda, t, ldt, d, info ) !! CUNHR_COL takes an M-by-N complex matrix Q_in with orthonormal columns !! as input, stored in A, and performs Householder Reconstruction (HR), !! i.e. reconstructs Householder vectors V(i) implicitly representing @@ -51787,38 +51789,38 @@ module stdlib_linalg_lapack_c ! -- 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, m, n, nb + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldt, m, n, nb ! Array Arguments complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: d(*), t(ldt,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, iinfo, j, jb, jbtemp1, jbtemp2, jnb, nplusone + integer(${ik}$) :: i, iinfo, j, jb, jbtemp1, jbtemp2, jnb, nplusone ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input parameters - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 .or. n>m ) then - info = -2 - else if( nb<1 ) then - info = -3 - else if( ldam ) then + info = -2_${ik}$ + else if( nb<1_${ik}$ ) then + info = -3_${ik}$ + else if( ldan ) then - call stdlib_ctrsm( 'R', 'U', 'N', 'N', m-n, n, cone, a, lda,a( n+1, 1 ), lda ) + call stdlib${ii}$_ctrsm( 'R', 'U', 'N', 'N', m-n, n, cone, a, lda,a( n+1, 1_${ik}$ ), lda ) end if ! (2) reconstruct the block reflector t stored in t(1:nb, 1:n) @@ -51841,7 +51843,7 @@ module stdlib_linalg_lapack_c ! loop over the column blocks of size nb of the array a(1:m,1:n) ! and the array t(1:nb,1:n), jb is the column index of a column ! block, jnb is the column block size at each step jb. - nplusone = n + 1 + nplusone = n + 1_${ik}$ do jb = 1, n, nb ! (2-0) determine the column block size jnb. jnb = min( nplusone-jb, nb ) @@ -51850,9 +51852,9 @@ module stdlib_linalg_lapack_c ! in a(jb:jb+jnb-1,jb:jb+jnb-1) into the upper-triangular part ! of the current jnb-by-jnb block t(1:jnb,jb:jb+jnb-1) ! column-by-column, total jnb*(jnb+1)/2 elements. - jbtemp1 = jb - 1 + jbtemp1 = jb - 1_${ik}$ do j = jb, jb+jnb-1 - call stdlib_ccopy( j-jbtemp1, a( jb, j ), 1, t( 1, j ), 1 ) + call stdlib${ii}$_ccopy( j-jbtemp1, a( jb, j ), 1_${ik}$, t( 1_${ik}$, j ), 1_${ik}$ ) end do ! (2-2) perform on the upper-triangular part of the current ! jnb-by-jnb diagonal block u(jb) (of the n-by-n matrix u) stored @@ -51866,7 +51868,7 @@ module stdlib_linalg_lapack_c ! s(jb), i.e. s(j,j) that is stored in the array element d(j). do j = jb, jb+jnb-1 if( d( j )==cone ) then - call stdlib_cscal( j-jbtemp1, -cone, t( 1, j ), 1 ) + call stdlib${ii}$_cscal( j-jbtemp1, -cone, t( 1_${ik}$, j ), 1_${ik}$ ) end if end do ! (2-3) perform the triangular solve for the current block @@ -51890,27 +51892,27 @@ module stdlib_linalg_lapack_c ! upper-triangular block t(jb): ! t(jb) * (v1(jb)**t) = (-1)*u(jb)*s(jb). ! even though the blocks x(jb) and b(jb) are upper- - ! triangular, the routine stdlib_ctrsm will access all jnb**2 + ! triangular, the routine stdlib${ii}$_ctrsm will access all jnb**2 ! elements of the square t(1:jnb,jb:jb+jnb-1). therefore, ! we need to set to zero the elements of the block ! t(1:jnb,jb:jb+jnb-1) below the diagonal before the call - ! to stdlib_ctrsm. + ! to stdlib${ii}$_ctrsm. ! (2-3a) set the elements to zero. - jbtemp2 = jb - 2 + jbtemp2 = jb - 2_${ik}$ do j = jb, jb+jnb-2 do i = j-jbtemp2, nb t( i, j ) = czero end do end do ! (2-3b) perform the triangular solve. - call stdlib_ctrsm( 'R', 'L', 'C', 'U', jnb, jnb, cone,a( jb, jb ), lda, t( 1, jb ), & + call stdlib${ii}$_ctrsm( 'R', 'L', 'C', 'U', jnb, jnb, cone,a( jb, jb ), lda, t( 1_${ik}$, jb ), & ldt ) end do return - end subroutine stdlib_cunhr_col + end subroutine stdlib${ii}$_cunhr_col - pure subroutine stdlib_cunmhr( side, trans, m, n, ilo, ihi, a, lda, tau, c,ldc, work, lwork, & + pure subroutine stdlib${ii}$_cunmhr( side, trans, m, n, ilo, ihi, a, lda, tau, c,ldc, work, lwork, & !! CUNMHR overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -51925,8 +51927,8 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: side, trans - integer(ilp), intent(in) :: ihi, ilo, lda, ldc, lwork, m, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ilo, lda, ldc, lwork, m, n + integer(${ik}$), intent(out) :: info ! Array Arguments complex(sp), intent(inout) :: a(lda,*), c(ldc,*) complex(sp), intent(in) :: tau(*) @@ -51934,82 +51936,82 @@ module stdlib_linalg_lapack_c ! ===================================================================== ! Local Scalars logical(lk) :: left, lquery - integer(ilp) :: i1, i2, iinfo, lwkopt, mi, nb, nh, ni, nq, nw + integer(${ik}$) :: i1, i2, iinfo, lwkopt, mi, nb, nh, ni, nq, nw ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ nh = ihi - ilo left = stdlib_lsame( side, 'L' ) - 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.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'C' ) )& then - info = -2 - else if( m<0 ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( ilo<1 .or. ilo>max( 1, nq ) ) then - info = -5 + info = -2_${ik}$ + else if( m<0_${ik}$ ) then + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, nq ) ) then + info = -5_${ik}$ else if( ihinq ) then - info = -6 - else if( lda1 ) then + if( n>1_${ik}$ ) then ! generate q(2:n,2:n) - call stdlib_cung2r( n-1, n-1, n-1, q( 2, 2 ), ldq, tau, work,iinfo ) + call stdlib${ii}$_cung2r( n-1, n-1, n-1, q( 2_${ik}$, 2_${ik}$ ), ldq, tau, work,iinfo ) end if end if return - end subroutine stdlib_cupgtr + end subroutine stdlib${ii}$_cupgtr - pure subroutine stdlib_cupmtr( side, uplo, trans, m, n, ap, tau, c, ldc, work,info ) + pure subroutine stdlib${ii}$_cupmtr( side, uplo, trans, m, n, ap, tau, c, ldc, work,info ) !! CUPMTR overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -52228,8 +52230,8 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: side, trans, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldc, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldc, m, n ! Array Arguments complex(sp), intent(inout) :: ap(*), c(ldc,*) complex(sp), intent(in) :: tau(*) @@ -52238,13 +52240,13 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: forwrd, left, notran, upper - integer(ilp) :: i, i1, i2, i3, ic, ii, jc, mi, ni, nq + integer(${ik}$) :: i, i1, i2, i3, ic, ii, jc, mi, ni, nq complex(sp) :: aii, taui ! Intrinsic Functions intrinsic :: conjg,max ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ left = stdlib_lsame( side, 'L' ) notran = stdlib_lsame( trans, 'N' ) upper = stdlib_lsame( uplo, 'U' ) @@ -52255,37 +52257,37 @@ module stdlib_linalg_lapack_c nq = n end if if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -2 + info = -2_${ik}$ else if( .not.notran .and. .not.stdlib_lsame( trans, 'C' ) ) then - info = -3 - else if( m<0 ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( ldc0 - 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 + if( kl+ku>1_${ik}$ ) then ! reduce to upper bidiagonal form if ku > 0; if ku = 0, 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. @@ -52454,107 +52456,107 @@ module stdlib_linalg_lapack_c 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_clargv( nr, ab( klu1, j1-klm-1 ), inca,work( j1 ), kb1, & + if( nr>0_${ik}$ )call stdlib${ii}$_clargv( nr, ab( klu1, j1-klm-1 ), inca,work( j1 ), kb1, & rwork( 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_clartv( nrt, ab( klu1-l, j1-klm+l-1 ), inca,ab( & + if( nrt>0_${ik}$ )call stdlib${ii}$_clartv( nrt, ab( klu1-l, j1-klm+l-1 ), inca,ab( & klu1-l+1, j1-klm+l-1 ), inca,rwork( j1 ), work( j1 ), kb1 ) end do if( ml>ml0 ) then if( ml<=m-i+1 ) then ! generate plane rotation to annihilate a(i+ml-1,i) ! within the band, and apply rotation from the left - call stdlib_clartg( ab( ku+ml-1, i ), ab( ku+ml, i ),rwork( i+ml-1 ), & + call stdlib${ii}$_clartg( ab( ku+ml-1, i ), ab( ku+ml, i ),rwork( i+ml-1 ), & work( i+ml-1 ), ra ) ab( ku+ml-1, i ) = ra - if( 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 ) = rwork( j )*ab( 1, j+kun ) + work( j+kun ) = work( j )*ab( 1_${ik}$, j+kun ) + ab( 1_${ik}$, j+kun ) = rwork( 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_clargv( nr, ab( 1, j1+kun-1 ), inca,work( j1+kun ), kb1,& + if( nr>0_${ik}$ )call stdlib${ii}$_clargv( nr, ab( 1_${ik}$, j1+kun-1 ), inca,work( j1+kun ), kb1,& rwork( 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_clartv( nrt, ab( l+1, j1+kun-1 ), inca,ab( l, j1+& + if( nrt>0_${ik}$ )call stdlib${ii}$_clartv( nrt, ab( l+1, j1+kun-1 ), inca,ab( l, j1+& kun ), inca,rwork( j1+kun ), work( j1+kun ), kb1 ) end do if( ml==ml0 .and. mu>mu0 ) then if( mu<=n-i+1 ) then ! generate plane rotation to annihilate a(i,i+mu-1) ! within the band, and apply rotation from the right - call stdlib_clartg( ab( ku-mu+3, i+mu-2 ),ab( ku-mu+2, i+mu-1 ),rwork( & + call stdlib${ii}$_clartg( ab( ku-mu+3, i+mu-2 ),ab( ku-mu+2, i+mu-1 ),rwork( & i+mu-1 ), work( i+mu-1 ), ra ) ab( ku-mu+3, i+mu-2 ) = ra - call stdlib_crot( min( kl+mu-2, m-i ),ab( ku-mu+4, i+mu-2 ), 1,ab( ku-& - mu+3, i+mu-1 ), 1,rwork( i+mu-1 ), work( i+mu-1 ) ) + call stdlib${ii}$_crot( min( kl+mu-2, m-i ),ab( ku-mu+4, i+mu-2 ), 1_${ik}$,ab( ku-& + mu+3, i+mu-1 ), 1_${ik}$,rwork( 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**h do j = j1, j2, kb1 - call stdlib_crot( n, pt( j+kun-1, 1 ), ldpt,pt( j+kun, 1 ), ldpt, rwork(& + call stdlib${ii}$_crot( n, pt( j+kun-1, 1_${ik}$ ), ldpt,pt( j+kun, 1_${ik}$ ), ldpt, rwork(& j+kun ),conjg( 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 @@ -52564,52 +52566,52 @@ module stdlib_linalg_lapack_c ab( klu1, j+kun ) = rwork( 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 complex lower bidiagonal form ! transform lower bidiagonal form to upper bidiagonal by applying ! plane rotations from the left, overwriting superdiagonal ! elements on subdiagonal elements do i = 1, min( m-1, n ) - call stdlib_clartg( ab( 1, i ), ab( 2, i ), rc, rs, ra ) - ab( 1, i ) = ra + call stdlib${ii}$_clartg( ab( 1_${ik}$, i ), ab( 2_${ik}$, i ), rc, rs, ra ) + ab( 1_${ik}$, i ) = ra if( i0 .and. m0_${ik}$ .and. m1 ) then + if( i>1_${ik}$ ) then rb = -conjg( rs )*ab( ku, i ) ab( ku, i ) = rc*ab( ku, i ) end if - if( wantpt )call stdlib_crot( n, pt( i, 1 ), ldpt, pt( m+1, 1 ), ldpt,rc, & + if( wantpt )call stdlib${ii}$_crot( n, pt( i, 1_${ik}$ ), ldpt, pt( m+1, 1_${ik}$ ), ldpt,rc, & conjg( rs ) ) end do end if end if ! make diagonal and superdiagonal elements real, storing them in d ! and e - t = ab( ku+1, 1 ) + t = ab( ku+1, 1_${ik}$ ) loop_120: do i = 1, minmn abst = abs( t ) d( i ) = abst @@ -52618,15 +52620,15 @@ module stdlib_linalg_lapack_c else t = cone end if - if( wantq )call stdlib_cscal( m, t, q( 1, i ), 1 ) - if( wantc )call stdlib_cscal( ncc, conjg( t ), c( i, 1 ), ldc ) + if( wantq )call stdlib${ii}$_cscal( m, t, q( 1_${ik}$, i ), 1_${ik}$ ) + if( wantc )call stdlib${ii}$_cscal( ncc, conjg( t ), c( i, 1_${ik}$ ), ldc ) if( ieps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_cgbtrs( trans, n, kl, ku, 1, afb, ldafb, ipiv, work, n,info ) - call stdlib_caxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_cgbtrs( trans, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv, work, n,info ) + call stdlib${ii}$_caxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -52820,13 +52822,13 @@ module stdlib_linalg_lapack_c rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(op(a)**h). - call stdlib_cgbtrs( transt, n, kl, ku, 1, afb, ldafb, ipiv,work, n, info ) + call stdlib${ii}$_cgbtrs( transt, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) @@ -52836,7 +52838,7 @@ module stdlib_linalg_lapack_c do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_cgbtrs( transn, n, kl, ku, 1, afb, ldafb, ipiv,work, n, info ) + call stdlib${ii}$_cgbtrs( transn, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work, n, info ) end if go to 100 @@ -52849,10 +52851,10 @@ module stdlib_linalg_lapack_c if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_cgbrfs + end subroutine stdlib${ii}$_cgbrfs - pure subroutine stdlib_cgbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) + pure subroutine stdlib${ii}$_cgbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) !! CGBSV computes the solution to a complex system of linear equations !! A * X = B, where A is a band matrix of order N with KL subdiagonals !! and KU superdiagonals, and X and B are N-by-NRHS matrices. @@ -52865,46 +52867,46 @@ module stdlib_linalg_lapack_c ! -- 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, ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl, ku, ldab, ldb, n, nrhs ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(sp), intent(inout) :: ab(ldab,*), b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 - if( n<0 ) then - info = -1 - else if( kl<0 ) then - info = -2 - else if( ku<0 ) then - info = -3 - else if( nrhs<0 ) then - info = -4 - else if( ldab<2*kl+ku+1 ) then - info = -6 - else if( ldb0 ) then + info = -13_${ik}$ + else if( n>0_${ik}$ ) then rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) else rowcnd = one end if end if - if( colequ .and. info==0 ) then + if( colequ .and. info==0_${ik}$ ) then rcmin = bignum rcmax = zero do j = 1, n @@ -52999,32 +53001,32 @@ module stdlib_linalg_lapack_c rcmax = max( rcmax, c( j ) ) end do if( rcmin<=zero ) then - info = -14 - else if( n>0 ) then + info = -14_${ik}$ + else if( n>0_${ik}$ ) then colcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) else colcnd = one end if end if - if( info==0 ) then - if( ldb0 ) then + if( info>0_${ik}$ ) then ! compute the reciprocal pivot growth factor of the ! leading rank-deficient info columns of a. anorm = zero @@ -53065,14 +53067,14 @@ module stdlib_linalg_lapack_c anorm = max( anorm, abs( ab( i, j ) ) ) end do end do - rpvgrw = stdlib_clantb( 'M', 'U', 'N', info, min( info-1, kl+ku ),afb( max( 1, & - kl+ku+2-info ), 1 ), ldafb,rwork ) + rpvgrw = stdlib${ii}$_clantb( 'M', 'U', 'N', info, min( info-1, kl+ku ),afb( max( 1_${ik}$, & + kl+ku+2-info ), 1_${ik}$ ), ldafb,rwork ) if( rpvgrw==zero ) then rpvgrw = one else rpvgrw = anorm / rpvgrw end if - rwork( 1 ) = rpvgrw + rwork( 1_${ik}$ ) = rpvgrw rcond = zero return end if @@ -53084,22 +53086,22 @@ module stdlib_linalg_lapack_c else norm = 'I' end if - anorm = stdlib_clangb( norm, n, kl, ku, ab, ldab, rwork ) - rpvgrw = stdlib_clantb( 'M', 'U', 'N', n, kl+ku, afb, ldafb, rwork ) + anorm = stdlib${ii}$_clangb( norm, n, kl, ku, ab, ldab, rwork ) + rpvgrw = stdlib${ii}$_clantb( 'M', 'U', 'N', n, kl+ku, afb, ldafb, rwork ) if( rpvgrw==zero ) then rpvgrw = one else - rpvgrw = stdlib_clangb( 'M', n, kl, ku, ab, ldab, rwork ) / rpvgrw + rpvgrw = stdlib${ii}$_clangb( 'M', n, kl, ku, ab, ldab, rwork ) / rpvgrw end if ! compute the reciprocal of the condition number of a. - call stdlib_cgbcon( norm, n, kl, ku, afb, ldafb, ipiv, anorm, rcond,work, rwork, info ) + call stdlib${ii}$_cgbcon( norm, n, kl, ku, afb, ldafb, ipiv, anorm, rcond,work, rwork, info ) ! compute the solution matrix x. - call stdlib_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_cgbtrs( trans, n, kl, ku, nrhs, afb, ldafb, ipiv, x, ldx,info ) + call stdlib${ii}$_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_cgbtrs( trans, n, kl, ku, nrhs, afb, ldafb, ipiv, x, ldx,info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_cgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv,b, ldb, x, ldx, & + call stdlib${ii}$_cgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv,b, ldb, x, ldx, & ferr, berr, work, rwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -53125,13 +53127,13 @@ module stdlib_linalg_lapack_c end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. @@ -53139,8 +53141,8 @@ module stdlib_linalg_lapack_c ! -- 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, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, lwork, m, n ! Array Arguments real(sp), intent(out) :: d(*), e(*) complex(sp), intent(inout) :: a(lda,*) @@ -53149,54 +53151,54 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, iinfo, j, ldwrkx, ldwrky, lwkopt, minmn, nb, nbmin, nx, ws + integer(${ik}$) :: i, iinfo, j, ldwrkx, ldwrky, lwkopt, minmn, nb, nbmin, nx, ws ! Intrinsic Functions intrinsic :: max,min,real ! Executable Statements ! test the input parameters - info = 0 - nb = max( 1, stdlib_ilaenv( 1, 'CGEBRD', ' ', m, n, -1, -1 ) ) + info = 0_${ik}$ + nb = max( 1_${ik}$, stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEBRD', ' ', m, n, -1_${ik}$, -1_${ik}$ ) ) lwkopt = ( m+n )*nb - work( 1 ) = real( lwkopt,KIND=sp) - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda1 .and. nb1_${ik}$ .and. nb=( m+n )*nbmin ) then nb = lwork / ( m+n ) else - nb = 1 + nb = 1_${ik}$ nx = minmn end if end if @@ -53208,14 +53210,14 @@ module stdlib_linalg_lapack_c ! reduce rows and columns i:i+ib-1 to bidiagonal form and return ! the matrices x and y which are needed to update the unreduced ! part of the matrix - call stdlib_clabrd( m-i+1, n-i+1, nb, a( i, i ), lda, d( i ), e( i ),tauq( i ), & + call stdlib${ii}$_clabrd( m-i+1, n-i+1, nb, a( i, i ), lda, d( i ), e( i ),tauq( i ), & taup( i ), work, ldwrkx,work( ldwrkx*nb+1 ), ldwrky ) ! update the trailing submatrix a(i+ib:m,i+ib:n), using ! an update of the form a := a - v*y**h - x*u**h - call stdlib_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m-i-nb+1,n-i-nb+1, nb, -& + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m-i-nb+1,n-i-nb+1, nb, -& cone, a( i+nb, i ), lda,work( ldwrkx*nb+nb+1 ), ldwrky, cone,a( i+nb, i+nb ), lda ) - call stdlib_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-i-nb+1, n-i-nb+1,nb, -cone, & + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-i-nb+1, n-i-nb+1,nb, -cone, & work( nb+1 ), ldwrkx, a( i, i+nb ), lda,cone, a( i+nb, i+nb ), lda ) ! copy diagonal and off-diagonal elements of b back into a if( m>=n ) then @@ -53231,61 +53233,61 @@ module stdlib_linalg_lapack_c end if end do ! use unblocked code to reduce the remainder of the matrix - call stdlib_cgebd2( m-i+1, n-i+1, a( i, i ), lda, d( i ), e( i ),tauq( i ), taup( i ), & + call stdlib${ii}$_cgebd2( m-i+1, n-i+1, a( i, i ), lda, d( i ), e( i ),tauq( i ), taup( i ), & work, iinfo ) - work( 1 ) = ws + work( 1_${ik}$ ) = ws return - end subroutine stdlib_cgebrd + end subroutine stdlib${ii}$_cgebrd - pure subroutine stdlib_cgehrd( n, ilo, ihi, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_cgehrd( n, ilo, ihi, a, lda, tau, work, lwork, info ) !! CGEHRD reduces a complex general matrix A to upper Hessenberg form H by !! an unitary similarity transformation: Q**H * A * Q = H . ! -- 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) :: ihi, ilo, lda, lwork, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ilo, lda, lwork, n + integer(${ik}$), intent(out) :: info ! Array Arguments complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: tau(*), 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) :: lquery - integer(ilp) :: i, ib, iinfo, iwt, j, ldwork, lwkopt, nb, nbmin, nh, nx + integer(${ik}$) :: i, ib, iinfo, iwt, j, ldwork, lwkopt, nb, nbmin, nh, nx complex(sp) :: ei ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input parameters - info = 0 - lquery = ( lwork==-1 ) - if( n<0 ) then - info = -1 - else if( ilo<1 .or. ilo>max( 1, n ) ) then - info = -2 + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) + if( n<0_${ik}$ ) then + info = -1_${ik}$ + else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then + info = -2_${ik}$ else if( ihin ) then - info = -3 - else if( lda1 .and. nb1_${ik}$ .and. nb=(n*nbmin+tsize) ) then nb = (lwork-tsize) / n else - nb = 1 + nb = 1_${ik}$ end if end if end if @@ -53331,74 +53333,74 @@ module stdlib_linalg_lapack_c i = ilo else ! use blocked code - iwt = 1 + n*nb + iwt = 1_${ik}$ + n*nb do i = ilo, ihi - 1 - nx, nb ib = min( nb, ihi-i ) ! reduce columns i:i+ib-1 to hessenberg form, returning the ! matrices v and t of the block reflector h = i - v*t*v**h ! which performs the reduction, and also the matrix y = a*v*t - call stdlib_clahr2( ihi, i, ib, a( 1, i ), lda, tau( i ),work( iwt ), ldt, work, & + call stdlib${ii}$_clahr2( ihi, i, ib, a( 1_${ik}$, i ), lda, tau( i ),work( iwt ), ldt, work, & ldwork ) ! apply the block reflector h to a(1:ihi,i+ib:ihi) from the ! right, computing a := a - y * v**h. v(i+ib,ib-1) must be set ! to 1 ei = a( i+ib, i+ib-1 ) a( i+ib, i+ib-1 ) = cone - call stdlib_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',ihi, ihi-i-ib+1,ib, -& - cone, work, ldwork, a( i+ib, i ), lda, cone,a( 1, i+ib ), lda ) + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',ihi, ihi-i-ib+1,ib, -& + cone, work, ldwork, a( i+ib, i ), lda, cone,a( 1_${ik}$, i+ib ), lda ) a( i+ib, i+ib-1 ) = ei ! apply the block reflector h to a(1:i,i+1:i+ib-1) from the ! right - call stdlib_ctrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', i, ib-1,cone, & + call stdlib${ii}$_ctrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', i, ib-1,cone, & a( i+1, i ), lda, work, ldwork ) do j = 0, ib-2 - call stdlib_caxpy( i, -cone, work( ldwork*j+1 ), 1,a( 1, i+j+1 ), 1 ) + call stdlib${ii}$_caxpy( i, -cone, work( ldwork*j+1 ), 1_${ik}$,a( 1_${ik}$, i+j+1 ), 1_${ik}$ ) end do ! apply the block reflector h to a(i+1:ihi,i+ib:n) from the ! left - call stdlib_clarfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'FORWARD','COLUMNWISE',ihi-i, & + call stdlib${ii}$_clarfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'FORWARD','COLUMNWISE',ihi-i, & n-i-ib+1, ib, a( i+1, i ), lda,work( iwt ), ldt, a( i+1, i+ib ), lda,work, & ldwork ) end do end if ! use unblocked code to reduce the rest of the matrix - call stdlib_cgehd2( n, i, ihi, a, lda, tau, work, iinfo ) - work( 1 ) = lwkopt + call stdlib${ii}$_cgehd2( n, i, ihi, a, lda, tau, work, iinfo ) + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_cgehrd + end subroutine stdlib${ii}$_cgehrd - pure subroutine stdlib_cgelqt( m, n, mb, a, lda, t, ldt, work, info ) + pure subroutine stdlib${ii}$_cgelqt( m, n, mb, a, lda, t, ldt, work, info ) !! CGELQT computes a blocked LQ factorization of a complex M-by-N matrix A !! using the compact WY representation of Q. ! -- 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, ldt, m, n, mb + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldt, m, n, mb ! Array Arguments complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: t(ldt,*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ib, iinfo, k + integer(${ik}$) :: i, ib, iinfo, k ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( mb<1 .or. (mb>min(m,n) .and. min(m,n)>0 ))then - info = -3 - else if( ldamin(m,n) .and. min(m,n)>0_${ik}$ ))then + info = -3_${ik}$ + else if( lda=n ) then - nb = stdlib_ilaenv( 1, 'CGEQRF', ' ', m, n, -1, -1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEQRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) if( tpsd ) then - nb = max( nb, stdlib_ilaenv( 1, 'CUNMQR', 'LN', m, nrhs, n,-1 ) ) + nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMQR', 'LN', m, nrhs, n,-1_${ik}$ ) ) else - nb = max( nb, stdlib_ilaenv( 1, 'CUNMQR', 'LC', m, nrhs, n,-1 ) ) + nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMQR', 'LC', m, nrhs, n,-1_${ik}$ ) ) end if else - nb = stdlib_ilaenv( 1, 'CGELQF', ' ', m, n, -1, -1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CGELQF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) if( tpsd ) then - nb = max( nb, stdlib_ilaenv( 1, 'CUNMLQ', 'LC', n, nrhs, m,-1 ) ) + nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMLQ', 'LC', n, nrhs, m,-1_${ik}$ ) ) else - nb = max( nb, stdlib_ilaenv( 1, 'CUNMLQ', 'LN', n, nrhs, m,-1 ) ) + nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMLQ', 'LN', n, nrhs, m,-1_${ik}$ ) ) end if end if - wsize = max( 1, mn + max( mn, nrhs )*nb ) - work( 1 ) = real( wsize,KIND=sp) + wsize = max( 1_${ik}$, mn + max( mn, nrhs )*nb ) + work( 1_${ik}$ ) = real( wsize,KIND=sp) end if - if( info/=0 ) then - call stdlib_xerbla( 'CGELS ', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'CGELS ', -info ) return else if( lquery ) then return end if ! quick return if possible - if( min( m, n, nrhs )==0 ) then - call stdlib_claset( 'FULL', max( m, n ), nrhs, czero, czero, b, ldb ) + if( min( m, n, nrhs )==0_${ik}$ ) then + call stdlib${ii}$_claset( 'FULL', max( m, n ), nrhs, czero, czero, b, ldb ) return end if ! get machine parameters - smlnum = stdlib_slamch( 'S' ) / stdlib_slamch( 'P' ) + smlnum = stdlib${ii}$_slamch( 'S' ) / stdlib${ii}$_slamch( 'P' ) bignum = one / smlnum - call stdlib_slabad( smlnum, bignum ) + call stdlib${ii}$_slabad( smlnum, bignum ) ! scale a, b if max element outside range [smlnum,bignum] - anrm = stdlib_clange( 'M', m, n, a, lda, rwork ) - iascl = 0 + anrm = stdlib${ii}$_clange( 'M', m, n, a, lda, rwork ) + iascl = 0_${ik}$ if( anrm>zero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_clascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_claset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) + call stdlib${ii}$_claset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) go to 50 end if brow = m if( tpsd )brow = n - bnrm = stdlib_clange( 'M', brow, nrhs, b, ldb, rwork ) - ibscl = 0 + bnrm = stdlib${ii}$_clange( 'M', brow, nrhs, b, ldb, rwork ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_clascl( 'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,info ) - ibscl = 2 + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, brow, nrhs, b, ldb,info ) + ibscl = 2_${ik}$ end if if( m>=n ) then ! compute qr factorization of a - call stdlib_cgeqrf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,info ) + call stdlib${ii}$_cgeqrf( m, n, a, lda, work( 1_${ik}$ ), work( mn+1 ), lwork-mn,info ) ! workspace at least n, optimally n*nb if( .not.tpsd ) then ! least-squares problem min || a * x - b || ! b(1:m,1:nrhs) := q**h * b(1:m,1:nrhs) - call stdlib_cunmqr( 'LEFT', 'CONJUGATE TRANSPOSE', m, nrhs, n, a,lda, work( 1 ), & + call stdlib${ii}$_cunmqr( 'LEFT', 'CONJUGATE TRANSPOSE', m, nrhs, n, a,lda, work( 1_${ik}$ ), & b, ldb, work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb ! b(1:n,1:nrhs) := inv(r) * b(1:n,1:nrhs) - call stdlib_ctrtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, nrhs,a, lda, b, ldb, & + call stdlib${ii}$_ctrtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, nrhs,a, lda, b, ldb, & info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if scllen = n else ! underdetermined system of equations a**t * x = b ! b(1:n,1:nrhs) := inv(r**h) * b(1:n,1:nrhs) - call stdlib_ctrtrs( 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT',n, nrhs, a, lda, b,& + call stdlib${ii}$_ctrtrs( 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT',n, nrhs, a, lda, b,& ldb, info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if ! b(n+1:m,1:nrhs) = zero @@ -53577,21 +53579,21 @@ module stdlib_linalg_lapack_c end do end do ! b(1:m,1:nrhs) := q(1:n,:) * b(1:n,1:nrhs) - call stdlib_cunmqr( 'LEFT', 'NO TRANSPOSE', m, nrhs, n, a, lda,work( 1 ), b, ldb,& + call stdlib${ii}$_cunmqr( 'LEFT', 'NO TRANSPOSE', m, nrhs, n, a, lda,work( 1_${ik}$ ), b, ldb,& work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb scllen = m end if else ! compute lq factorization of a - call stdlib_cgelqf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,info ) + call stdlib${ii}$_cgelqf( m, n, a, lda, work( 1_${ik}$ ), work( mn+1 ), lwork-mn,info ) ! workspace at least m, optimally m*nb. if( .not.tpsd ) then ! underdetermined system of equations a * x = b ! b(1:m,1:nrhs) := inv(l) * b(1:m,1:nrhs) - call stdlib_ctrtrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & + call stdlib${ii}$_ctrtrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if ! b(m+1:n,1:nrhs) = 0 @@ -53601,134 +53603,134 @@ module stdlib_linalg_lapack_c end do end do ! b(1:n,1:nrhs) := q(1:n,:)**h * b(1:m,1:nrhs) - call stdlib_cunmlq( 'LEFT', 'CONJUGATE TRANSPOSE', n, nrhs, m, a,lda, work( 1 ), & + call stdlib${ii}$_cunmlq( 'LEFT', 'CONJUGATE TRANSPOSE', n, nrhs, m, a,lda, work( 1_${ik}$ ), & b, ldb, work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb scllen = n else ! overdetermined system min || a**h * x - b || ! b(1:n,1:nrhs) := q * b(1:n,1:nrhs) - call stdlib_cunmlq( 'LEFT', 'NO TRANSPOSE', n, nrhs, m, a, lda,work( 1 ), b, ldb,& + call stdlib${ii}$_cunmlq( 'LEFT', 'NO TRANSPOSE', n, nrhs, m, a, lda,work( 1_${ik}$ ), b, ldb,& work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb ! b(1:m,1:nrhs) := inv(l**h) * b(1:m,1:nrhs) - call stdlib_ctrtrs( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',m, nrhs, a, lda, & + call stdlib${ii}$_ctrtrs( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',m, nrhs, a, lda, & b, ldb, info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if scllen = m end if end if ! undo scaling - if( iascl==1 ) then - call stdlib_clascl( 'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,info ) - else if( iascl==2 ) then - call stdlib_clascl( 'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,info ) + if( iascl==1_${ik}$ ) then + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, smlnum, scllen, nrhs, b, ldb,info ) + else if( iascl==2_${ik}$ ) then + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, scllen, nrhs, b, ldb,info ) end if - if( ibscl==1 ) then - call stdlib_clascl( 'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,info ) - else if( ibscl==2 ) then - call stdlib_clascl( 'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,info ) + if( ibscl==1_${ik}$ ) then + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, bnrm, scllen, nrhs, b, ldb,info ) + else if( ibscl==2_${ik}$ ) then + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bignum, bnrm, scllen, nrhs, b, ldb,info ) end if 50 continue - work( 1 ) = real( wsize,KIND=sp) + work( 1_${ik}$ ) = real( wsize,KIND=sp) return - end subroutine stdlib_cgels + end subroutine stdlib${ii}$_cgels - pure subroutine stdlib_cgeqp3( m, n, a, lda, jpvt, tau, work, lwork, rwork,info ) + pure subroutine stdlib${ii}$_cgeqp3( m, n, a, lda, jpvt, tau, work, lwork, rwork,info ) !! CGEQP3 computes a QR factorization with column pivoting of a !! matrix A: A*P = Q*R using Level 3 BLAS. ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, lwork, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, lwork, m, n ! Array Arguments - integer(ilp), intent(inout) :: jpvt(*) + integer(${ik}$), intent(inout) :: jpvt(*) real(sp), intent(out) :: rwork(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: tau(*), work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: inb = 1 - integer(ilp), parameter :: inbmin = 2 - integer(ilp), parameter :: ixover = 3 + integer(${ik}$), parameter :: inb = 1_${ik}$ + integer(${ik}$), parameter :: inbmin = 2_${ik}$ + integer(${ik}$), parameter :: ixover = 3_${ik}$ ! Local Scalars logical(lk) :: lquery - integer(ilp) :: fjb, iws, j, jb, lwkopt, minmn, minws, na, nb, nbmin, nfxd, nx, sm, & + integer(${ik}$) :: fjb, iws, j, jb, lwkopt, minmn, minws, na, nb, nbmin, nfxd, nx, sm, & sminmn, sn, topbmn ! Intrinsic Functions intrinsic :: int,max,min ! Executable Statements ! test input arguments ! ==================== - info = 0 - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda0 ) then + if( nfxd>0_${ik}$ ) then na = min( m, nfxd ) - ! cc call stdlib_cgeqr2( m, na, a, lda, tau, work, info ) - call stdlib_cgeqrf( m, na, a, lda, tau, work, lwork, info ) - iws = max( iws, int( work( 1 ),KIND=ilp) ) + ! cc call stdlib${ii}$_cgeqr2( m, na, a, lda, tau, work, info ) + call stdlib${ii}$_cgeqrf( m, na, a, lda, tau, work, lwork, info ) + iws = max( iws, int( work( 1_${ik}$ ),KIND=${ik}$) ) if( na1 ) .and. ( nb1_${ik}$ ) .and. ( nb=nbmin ) .and. ( nbmin(m,n) .and. min(m,n)>0 ) )then - info = -3 - else if( ldamin(m,n) .and. min(m,n)>0_${ik}$ ) )then + info = -3_${ik}$ + else if( ldaeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_cgetrs( trans, n, 1, af, ldaf, ipiv, work, n, info ) - call stdlib_caxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_cgetrs( trans, n, 1_${ik}$, af, ldaf, ipiv, work, n, info ) + call stdlib${ii}$_caxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -54013,13 +54015,13 @@ module stdlib_linalg_lapack_c rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(op(a)**h). - call stdlib_cgetrs( transt, n, 1, af, ldaf, ipiv, work, n,info ) + call stdlib${ii}$_cgetrs( transt, n, 1_${ik}$, af, ldaf, ipiv, work, n,info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do @@ -54028,7 +54030,7 @@ module stdlib_linalg_lapack_c do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_cgetrs( transn, n, 1, af, ldaf, ipiv, work, n,info ) + call stdlib${ii}$_cgetrs( transn, n, 1_${ik}$, af, ldaf, ipiv, work, n,info ) end if go to 100 end if @@ -54040,10 +54042,10 @@ module stdlib_linalg_lapack_c if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_cgerfs + end subroutine stdlib${ii}$_cgerfs - pure subroutine stdlib_cgetrf( m, n, a, lda, ipiv, info ) + pure subroutine stdlib${ii}$_cgetrf( m, n, a, lda, ipiv, info ) !! CGETRF computes an LU factorization of a general M-by-N matrix A !! using partial pivoting with row interchanges. !! The factorization has the form @@ -54056,61 +54058,61 @@ module stdlib_linalg_lapack_c ! -- 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(*) complex(sp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, iinfo, j, jb, nb + integer(${ik}$) :: i, 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}$, 'CGETRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=min( m, n ) ) then ! use unblocked code. - call stdlib_cgetrf2( m, n, a, lda, ipiv, info ) + call stdlib${ii}$_cgetrf2( m, n, a, lda, ipiv, info ) else ! use blocked code. do j = 1, min( m, n ), nb jb = min( min( m, n )-j+1, nb ) ! factor diagonal and subdiagonal blocks and test for exact ! singularity. - call stdlib_cgetrf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo ) + call stdlib${ii}$_cgetrf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo ) ! adjust info and the pivot indices. - if( info==0 .and. iinfo>0 )info = iinfo + j - 1 + if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + j - 1_${ik}$ do i = j, min( m, j+jb-1 ) - ipiv( i ) = j - 1 + ipiv( i ) + ipiv( i ) = j - 1_${ik}$ + ipiv( i ) end do ! apply interchanges to columns 1:j-1. - call stdlib_claswp( j-1, a, lda, j, j+jb-1, ipiv, 1 ) + call stdlib${ii}$_claswp( j-1, a, lda, j, j+jb-1, ipiv, 1_${ik}$ ) if( j+jb<=n ) then ! apply interchanges to columns j+jb:n. - call stdlib_claswp( n-j-jb+1, a( 1, j+jb ), lda, j, j+jb-1,ipiv, 1 ) + call stdlib${ii}$_claswp( n-j-jb+1, a( 1_${ik}$, j+jb ), lda, j, j+jb-1,ipiv, 1_${ik}$ ) ! compute block row of u. - call stdlib_ctrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, cone,& + call stdlib${ii}$_ctrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, cone,& a( j, j ), lda, a( j, j+jb ),lda ) if( j+jb<=m ) then ! update trailing submatrix. - call stdlib_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& cone, a( j+jb, j ), lda,a( j, j+jb ), lda, cone, a( j+jb, j+jb ),lda ) end if @@ -54118,10 +54120,10 @@ module stdlib_linalg_lapack_c end do end if return - end subroutine stdlib_cgetrf + end subroutine stdlib${ii}$_cgetrf - pure subroutine stdlib_cggglm( n, m, p, a, lda, b, ldb, d, x, y, work, lwork,info ) + pure subroutine stdlib${ii}$_cggglm( n, m, p, a, lda, b, ldb, d, x, y, work, lwork,info ) !! CGGGLM solves a general Gauss-Markov linear model (GLM) problem: !! minimize || y ||_2 subject to d = A*x + B*y !! x @@ -54144,8 +54146,8 @@ module stdlib_linalg_lapack_c ! -- 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, ldb, lwork, m, n, p + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, p ! Array Arguments complex(sp), intent(inout) :: a(lda,*), b(ldb,*), d(*) complex(sp), intent(out) :: work(*), x(*), y(*) @@ -54153,52 +54155,52 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, lopt, lwkmin, lwkopt, nb, nb1, nb2, nb3, nb4, np + integer(${ik}$) :: i, lopt, lwkmin, lwkopt, nb, nb1, nb2, nb3, nb4, np ! Intrinsic Functions intrinsic :: int,max,min ! Executable Statements ! test the input parameters - info = 0 + info = 0_${ik}$ np = min( n, p ) - lquery = ( lwork==-1 ) - if( n<0 ) then - info = -1 - else if( m<0 .or. m>n ) then - info = -2 - else if( p<0 .or. pn ) then + info = -2_${ik}$ + else if( p<0_${ik}$ .or. pm ) then - call stdlib_ctrtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', n-m, 1,b( m+1, m+p-n+1 ), & + call stdlib${ii}$_ctrtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', n-m, 1_${ik}$,b( m+1, m+p-n+1 ), & ldb, d( m+1 ), n-m, info ) - if( info>0 ) then - info = 1 + if( info>0_${ik}$ ) then + info = 1_${ik}$ return end if - call stdlib_ccopy( n-m, d( m+1 ), 1, y( m+p-n+1 ), 1 ) + call stdlib${ii}$_ccopy( n-m, d( m+1 ), 1_${ik}$, y( m+p-n+1 ), 1_${ik}$ ) end if ! set y1 = 0 do i = 1, m + p - n y( i ) = czero end do ! update d1 = d1 - t12*y2 - call stdlib_cgemv( 'NO TRANSPOSE', m, n-m, -cone, b( 1, m+p-n+1 ), ldb,y( m+p-n+1 ), 1,& - cone, d, 1 ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', m, n-m, -cone, b( 1_${ik}$, m+p-n+1 ), ldb,y( m+p-n+1 ), 1_${ik}$,& + cone, d, 1_${ik}$ ) ! solve triangular system: r11*x = d1 - if( m>0 ) then - call stdlib_ctrtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', m, 1, a, lda,d, m, info ) + if( m>0_${ik}$ ) then + call stdlib${ii}$_ctrtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', m, 1_${ik}$, a, lda,d, m, info ) - if( info>0 ) then - info = 2 + if( info>0_${ik}$ ) then + info = 2_${ik}$ return end if ! copy d to x - call stdlib_ccopy( m, d, 1, x, 1 ) + call stdlib${ii}$_ccopy( m, d, 1_${ik}$, x, 1_${ik}$ ) end if ! backward transformation y = z**h *y - call stdlib_cunmrq( 'LEFT', 'CONJUGATE TRANSPOSE', p, 1, np,b( max( 1, n-p+1 ), 1 ), & - ldb, work( m+1 ), y,max( 1, p ), work( m+np+1 ), lwork-m-np, info ) - work( 1 ) = m + np + max( lopt, int( work( m+np+1 ),KIND=ilp) ) + call stdlib${ii}$_cunmrq( 'LEFT', 'CONJUGATE TRANSPOSE', p, 1_${ik}$, np,b( max( 1_${ik}$, n-p+1 ), 1_${ik}$ ), & + ldb, work( m+1 ), y,max( 1_${ik}$, p ), work( m+np+1 ), lwork-m-np, info ) + work( 1_${ik}$ ) = m + np + max( lopt, int( work( m+np+1 ),KIND=${ik}$) ) return - end subroutine stdlib_cggglm + end subroutine stdlib${ii}$_cggglm - pure subroutine stdlib_cgghd3( compq, compz, n, ilo, ihi, a, lda, b, ldb, q,ldq, z, ldz, & + pure subroutine stdlib${ii}$_cgghd3( compq, compz, n, ilo, ihi, a, lda, b, ldb, q,ldq, z, ldz, & !! CGGHD3 reduces a pair of complex matrices (A,B) to generalized upper !! Hessenberg form using unitary transformations, where A is a !! general matrix and B is upper triangular. The form of the @@ -54289,8 +54291,8 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: compq, compz - integer(ilp), intent(in) :: ihi, ilo, lda, ldb, ldq, ldz, n, lwork - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ilo, lda, ldb, ldq, ldz, n, lwork + integer(${ik}$), intent(out) :: info ! Array Arguments complex(sp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) complex(sp), intent(out) :: work(*) @@ -54299,7 +54301,7 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: blk22, initq, initz, lquery, wantq, wantz character :: compq2, compz2 - integer(ilp) :: cola, i, ierr, j, j0, jcol, jj, jrow, k, kacc22, len, lwkopt, n2nb, nb,& + integer(${ik}$) :: cola, i, ierr, j, j0, jcol, jj, jrow, k, kacc22, len, lwkopt, n2nb, nb,& nblst, nbmin, nh, nnb, nx, ppw, ppwo, pw, top, topq real(sp) :: c complex(sp) :: c1, c2, ctemp, s, s1, s2, temp, temp1, temp2, temp3 @@ -54307,69 +54309,69 @@ module stdlib_linalg_lapack_c intrinsic :: real,cmplx,conjg,max ! Executable Statements ! decode and test the input parameters. - info = 0 - nb = stdlib_ilaenv( 1, 'CGGHD3', ' ', n, ilo, ihi, -1 ) - lwkopt = max( 6*n*nb, 1 ) - work( 1 ) = cmplx( lwkopt,KIND=sp) + info = 0_${ik}$ + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CGGHD3', ' ', n, ilo, ihi, -1_${ik}$ ) + lwkopt = max( 6_${ik}$*n*nb, 1_${ik}$ ) + work( 1_${ik}$ ) = cmplx( lwkopt,KIND=sp) initq = stdlib_lsame( compq, 'I' ) wantq = initq .or. stdlib_lsame( compq, 'V' ) initz = stdlib_lsame( compz, 'I' ) wantz = initz .or. stdlib_lsame( compz, 'V' ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) if( .not.stdlib_lsame( compq, 'N' ) .and. .not.wantq ) then - info = -1 + info = -1_${ik}$ else if( .not.stdlib_lsame( compz, 'N' ) .and. .not.wantz ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ilo<1 ) then - info = -4 + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( ilo<1_${ik}$ ) then + info = -4_${ik}$ else if( ihi>n .or. ihi1 )call stdlib_claset( 'LOWER', n-1, n-1, czero, czero, b(2, 1), ldb ) + if( n>1_${ik}$ )call stdlib${ii}$_claset( 'LOWER', n-1, n-1, czero, czero, b(2_${ik}$, 1_${ik}$), ldb ) ! quick return if possible - nh = ihi - ilo + 1 - if( nh<=1 ) then - work( 1 ) = cone + nh = ihi - ilo + 1_${ik}$ + if( nh<=1_${ik}$ ) then + work( 1_${ik}$ ) = cone return end if ! determine the blocksize. - nbmin = stdlib_ilaenv( 2, 'CGGHD3', ' ', n, ilo, ihi, -1 ) - if( nb>1 .and. nb1_${ik}$ .and. nb=6*n*nbmin ) then - nb = lwork / ( 6*n ) + nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'CGGHD3', ' ', n, ilo, ihi,-1_${ik}$ ) ) + if( lwork>=6_${ik}$*n*nbmin ) then + nb = lwork / ( 6_${ik}$*n ) else - nb = 1 + nb = 1_${ik}$ end if end if end if @@ -54379,8 +54381,8 @@ module stdlib_linalg_lapack_c jcol = ilo else ! use blocked code - kacc22 = stdlib_ilaenv( 16, 'CGGHD3', ' ', n, ilo, ihi, -1 ) - blk22 = kacc22==2 + kacc22 = stdlib${ii}$_ilaenv( 16_${ik}$, 'CGGHD3', ' ', n, ilo, ihi, -1_${ik}$ ) + blk22 = kacc22==2_${ik}$ do jcol = ilo, ihi-2, nb nnb = min( nb, ihi-jcol-1 ) ! initialize small unitary factors that will hold the @@ -54388,14 +54390,14 @@ module stdlib_linalg_lapack_c ! n2nb denotes the number of 2*nnb-by-2*nnb factors ! nblst denotes the (possibly smaller) order of the last ! factor. - n2nb = ( ihi-jcol-1 ) / nnb - 1 + n2nb = ( ihi-jcol-1 ) / nnb - 1_${ik}$ nblst = ihi - jcol - n2nb*nnb - call stdlib_claset( 'ALL', nblst, nblst, czero, cone, work, nblst ) - pw = nblst * nblst + 1 + call stdlib${ii}$_claset( 'ALL', nblst, nblst, czero, cone, work, nblst ) + pw = nblst * nblst + 1_${ik}$ do i = 1, n2nb - call stdlib_claset( 'ALL', 2*nnb, 2*nnb, czero, cone,work( pw ), 2*nnb ) + call stdlib${ii}$_claset( 'ALL', 2_${ik}$*nnb, 2_${ik}$*nnb, czero, cone,work( pw ), 2_${ik}$*nnb ) - pw = pw + 4*nnb*nnb + pw = pw + 4_${ik}$*nnb*nnb end do ! reduce columns jcol:jcol+nnb-1 of a to hessenberg form. do j = jcol, jcol+nnb-1 @@ -54403,14 +54405,14 @@ module stdlib_linalg_lapack_c ! column of a and b, respectively. do i = ihi, j+2, -1 temp = a( i-1, j ) - call stdlib_clartg( temp, a( i, j ), c, s, a( i-1, j ) ) + call stdlib${ii}$_clartg( temp, a( i, j ), c, s, a( i-1, j ) ) a( i, j ) = cmplx( c,KIND=sp) b( i, j ) = s end do ! accumulate givens rotations into workspace array. - ppw = ( nblst + 1 )*( nblst - 2 ) - j + jcol + 1 - len = 2 + j - jcol - jrow = j + n2nb*nnb + 2 + ppw = ( nblst + 1_${ik}$ )*( nblst - 2_${ik}$ ) - j + jcol + 1_${ik}$ + len = 2_${ik}$ + j - jcol + jrow = j + n2nb*nnb + 2_${ik}$ do i = ihi, jrow, -1 ctemp = a( i, j ) s = b( i, j ) @@ -54419,31 +54421,31 @@ module stdlib_linalg_lapack_c work( jj + nblst ) = ctemp*temp - s*work( jj ) work( jj ) = conjg( s )*temp + ctemp*work( jj ) end do - len = len + 1 - ppw = ppw - nblst - 1 + len = len + 1_${ik}$ + ppw = ppw - nblst - 1_${ik}$ end do - ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2*nnb + nnb + ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2_${ik}$*nnb + nnb j0 = jrow - nnb do jrow = j0, j+2, -nnb ppw = ppwo - len = 2 + j - jcol + len = 2_${ik}$ + j - jcol do i = jrow+nnb-1, jrow, -1 ctemp = a( i, j ) s = b( i, j ) do jj = ppw, ppw+len-1 - temp = work( jj + 2*nnb ) - work( jj + 2*nnb ) = ctemp*temp - s*work( jj ) + temp = work( jj + 2_${ik}$*nnb ) + work( jj + 2_${ik}$*nnb ) = ctemp*temp - s*work( jj ) work( jj ) = conjg( s )*temp + ctemp*work( jj ) end do - len = len + 1 - ppw = ppw - 2*nnb - 1 + len = len + 1_${ik}$ + ppw = ppw - 2_${ik}$*nnb - 1_${ik}$ end do - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do ! top denotes the number of top rows in a and b that will ! not be updated during the next steps. - if( jcol<=2 ) then - top = 0 + if( jcol<=2_${ik}$ ) then + top = 0_${ik}$ else top = jcol end if @@ -54461,16 +54463,16 @@ module stdlib_linalg_lapack_c ! annihilate b( jj+1, jj ). if( jj0 ) then + if( jj>0_${ik}$ ) then do i = jj, 1, -1 c = real( a( j+1+i, j ),KIND=sp) - call stdlib_crot( ihi-top, a( top+1, j+i+1 ), 1,a( top+1, j+i ), 1, c,-& + call stdlib${ii}$_crot( ihi-top, a( top+1, j+i+1 ), 1_${ik}$,a( top+1, j+i ), 1_${ik}$, c,-& conjg( b( j+1+i, j ) ) ) end do end if ! update (j+1)th column of a by transformations from left. - if ( j < jcol + nnb - 1 ) then - len = 1 + j - jcol + if ( j < jcol + nnb - 1_${ik}$ ) then + len = 1_${ik}$ + j - jcol ! multiply with the trailing accumulated unitary ! matrix, which takes the form ! [ u11 u12 ] @@ -54508,23 +54510,23 @@ module stdlib_linalg_lapack_c ! [ u21 u22 ] ! where u21 is a len-by-len matrix and u12 is lower ! triangular. - jrow = ihi - nblst + 1 - call stdlib_cgemv( 'CONJUGATE', nblst, len, cone, work,nblst, a( jrow, j+1 & - ), 1, czero,work( pw ), 1 ) + jrow = ihi - nblst + 1_${ik}$ + call stdlib${ii}$_cgemv( 'CONJUGATE', nblst, len, cone, work,nblst, a( jrow, j+1 & + ), 1_${ik}$, czero,work( pw ), 1_${ik}$ ) ppw = pw + len do i = jrow, jrow+nblst-len-1 work( ppw ) = a( i, j+1 ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do - call stdlib_ctrmv( 'LOWER', 'CONJUGATE', 'NON-UNIT',nblst-len, work( & - len*nblst + 1 ), nblst,work( pw+len ), 1 ) - call stdlib_cgemv( 'CONJUGATE', len, nblst-len, cone,work( (len+1)*nblst - & - len + 1 ), nblst,a( jrow+nblst-len, j+1 ), 1, cone,work( pw+len ), 1 ) + call stdlib${ii}$_ctrmv( 'LOWER', 'CONJUGATE', 'NON-UNIT',nblst-len, work( & + len*nblst + 1_${ik}$ ), nblst,work( pw+len ), 1_${ik}$ ) + call stdlib${ii}$_cgemv( 'CONJUGATE', len, nblst-len, cone,work( (len+1)*nblst - & + len + 1_${ik}$ ), nblst,a( jrow+nblst-len, j+1 ), 1_${ik}$, cone,work( pw+len ), 1_${ik}$ ) ppw = pw do i = jrow, jrow+nblst-1 a( i, j+1 ) = work( ppw ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do ! multiply with the other accumulated unitary ! matrices, which take the form @@ -54536,44 +54538,44 @@ module stdlib_linalg_lapack_c ! where i denotes the (nnb-len)-by-(nnb-len) identity ! matrix, u21 is a len-by-len upper triangular matrix ! and u12 is an nnb-by-nnb lower triangular matrix. - ppwo = 1 + nblst*nblst + ppwo = 1_${ik}$ + nblst*nblst j0 = jrow - nnb do jrow = j0, jcol+1, -nnb ppw = pw + len do i = jrow, jrow+nnb-1 work( ppw ) = a( i, j+1 ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do ppw = pw do i = jrow+nnb, jrow+nnb+len-1 work( ppw ) = a( i, j+1 ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do - call stdlib_ctrmv( 'UPPER', 'CONJUGATE', 'NON-UNIT', len,work( ppwo + & - nnb ), 2*nnb, work( pw ),1 ) - call stdlib_ctrmv( 'LOWER', 'CONJUGATE', 'NON-UNIT', nnb,work( ppwo + & - 2*len*nnb ),2*nnb, work( pw + len ), 1 ) - call stdlib_cgemv( 'CONJUGATE', nnb, len, cone,work( ppwo ), 2*nnb, a( & - jrow, j+1 ), 1,cone, work( pw ), 1 ) - call stdlib_cgemv( 'CONJUGATE', len, nnb, cone,work( ppwo + 2*len*nnb + & - nnb ), 2*nnb,a( jrow+nnb, j+1 ), 1, cone,work( pw+len ), 1 ) + call stdlib${ii}$_ctrmv( 'UPPER', 'CONJUGATE', 'NON-UNIT', len,work( ppwo + & + nnb ), 2_${ik}$*nnb, work( pw ),1_${ik}$ ) + call stdlib${ii}$_ctrmv( 'LOWER', 'CONJUGATE', 'NON-UNIT', nnb,work( ppwo + & + 2_${ik}$*len*nnb ),2_${ik}$*nnb, work( pw + len ), 1_${ik}$ ) + call stdlib${ii}$_cgemv( 'CONJUGATE', nnb, len, cone,work( ppwo ), 2_${ik}$*nnb, a( & + jrow, j+1 ), 1_${ik}$,cone, work( pw ), 1_${ik}$ ) + call stdlib${ii}$_cgemv( 'CONJUGATE', len, nnb, cone,work( ppwo + 2_${ik}$*len*nnb + & + nnb ), 2_${ik}$*nnb,a( jrow+nnb, j+1 ), 1_${ik}$, cone,work( pw+len ), 1_${ik}$ ) ppw = pw do i = jrow, jrow+len+nnb-1 a( i, j+1 ) = work( ppw ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end if end do ! apply accumulated unitary matrices to a. - cola = n - jcol - nnb + 1 - j = ihi - nblst + 1 - call stdlib_cgemm( 'CONJUGATE', 'NO TRANSPOSE', nblst,cola, nblst, cone, work, & + cola = n - jcol - nnb + 1_${ik}$ + j = ihi - nblst + 1_${ik}$ + call stdlib${ii}$_cgemm( 'CONJUGATE', 'NO TRANSPOSE', nblst,cola, nblst, cone, work, & nblst,a( j, jcol+nnb ), lda, czero, work( pw ),nblst ) - call stdlib_clacpy( 'ALL', nblst, cola, work( pw ), nblst,a( j, jcol+nnb ), lda ) + call stdlib${ii}$_clacpy( 'ALL', nblst, cola, work( pw ), nblst,a( j, jcol+nnb ), lda ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( blk22 ) then @@ -54583,70 +54585,70 @@ module stdlib_linalg_lapack_c ! [ u21 u22 ], ! where all blocks are nnb-by-nnb, u21 is upper ! triangular and u12 is lower triangular. - call stdlib_cunm22( 'LEFT', 'CONJUGATE', 2*nnb, cola, nnb,nnb, work( ppwo )& - , 2*nnb,a( j, jcol+nnb ), lda, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_cunm22( 'LEFT', 'CONJUGATE', 2_${ik}$*nnb, cola, nnb,nnb, work( ppwo )& + , 2_${ik}$*nnb,a( j, jcol+nnb ), lda, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_cgemm( 'CONJUGATE', 'NO TRANSPOSE', 2*nnb,cola, 2*nnb, cone, & - work( ppwo ), 2*nnb,a( j, jcol+nnb ), lda, czero, work( pw ),2*nnb ) + call stdlib${ii}$_cgemm( 'CONJUGATE', 'NO TRANSPOSE', 2_${ik}$*nnb,cola, 2_${ik}$*nnb, cone, & + work( ppwo ), 2_${ik}$*nnb,a( j, jcol+nnb ), lda, czero, work( pw ),2_${ik}$*nnb ) - call stdlib_clacpy( 'ALL', 2*nnb, cola, work( pw ), 2*nnb,a( j, jcol+nnb ),& + call stdlib${ii}$_clacpy( 'ALL', 2_${ik}$*nnb, cola, work( pw ), 2_${ik}$*nnb,a( j, jcol+nnb ),& lda ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do ! apply accumulated unitary matrices to q. if( wantq ) then - j = ihi - nblst + 1 + j = ihi - nblst + 1_${ik}$ if ( initq ) then - topq = max( 2, j - jcol + 1 ) - nh = ihi - topq + 1 + topq = max( 2_${ik}$, j - jcol + 1_${ik}$ ) + nh = ihi - topq + 1_${ik}$ else - topq = 1 + topq = 1_${ik}$ nh = n end if - call stdlib_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, cone, q( & + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, cone, q( & topq, j ), ldq,work, nblst, czero, work( pw ), nh ) - call stdlib_clacpy( 'ALL', nh, nblst, work( pw ), nh,q( topq, j ), ldq ) + call stdlib${ii}$_clacpy( 'ALL', nh, nblst, work( pw ), nh,q( topq, j ), ldq ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( initq ) then - topq = max( 2, j - jcol + 1 ) - nh = ihi - topq + 1 + topq = max( 2_${ik}$, j - jcol + 1_${ik}$ ) + nh = ihi - topq + 1_${ik}$ end if if ( blk22 ) then ! exploit the structure of u. - call stdlib_cunm22( 'RIGHT', 'NO TRANSPOSE', nh, 2*nnb,nnb, nnb, work( & - ppwo ), 2*nnb,q( topq, j ), ldq, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_cunm22( 'RIGHT', 'NO TRANSPOSE', nh, 2_${ik}$*nnb,nnb, nnb, work( & + ppwo ), 2_${ik}$*nnb,q( topq, j ), ldq, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2*nnb, 2*nnb, & - cone, q( topq, j ), ldq,work( ppwo ), 2*nnb, czero, work( pw ),nh ) + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2_${ik}$*nnb, 2_${ik}$*nnb, & + cone, q( topq, j ), ldq,work( ppwo ), 2_${ik}$*nnb, czero, work( pw ),nh ) - call stdlib_clacpy( 'ALL', nh, 2*nnb, work( pw ), nh,q( topq, j ), ldq ) + call stdlib${ii}$_clacpy( 'ALL', nh, 2_${ik}$*nnb, work( pw ), nh,q( topq, j ), ldq ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end if ! accumulate right givens rotations if required. - if ( wantz .or. top>0 ) then + if ( wantz .or. top>0_${ik}$ ) then ! initialize small unitary factors that will hold the ! accumulated givens rotations in workspace. - call stdlib_claset( 'ALL', nblst, nblst, czero, cone, work,nblst ) - pw = nblst * nblst + 1 + call stdlib${ii}$_claset( 'ALL', nblst, nblst, czero, cone, work,nblst ) + pw = nblst * nblst + 1_${ik}$ do i = 1, n2nb - call stdlib_claset( 'ALL', 2*nnb, 2*nnb, czero, cone,work( pw ), 2*nnb ) + call stdlib${ii}$_claset( 'ALL', 2_${ik}$*nnb, 2_${ik}$*nnb, czero, cone,work( pw ), 2_${ik}$*nnb ) - pw = pw + 4*nnb*nnb + pw = pw + 4_${ik}$*nnb*nnb end do ! accumulate givens rotations into workspace array. do j = jcol, jcol+nnb-1 - ppw = ( nblst + 1 )*( nblst - 2 ) - j + jcol + 1 - len = 2 + j - jcol - jrow = j + n2nb*nnb + 2 + ppw = ( nblst + 1_${ik}$ )*( nblst - 2_${ik}$ ) - j + jcol + 1_${ik}$ + len = 2_${ik}$ + j - jcol + jrow = j + n2nb*nnb + 2_${ik}$ do i = ihi, jrow, -1 ctemp = a( i, j ) a( i, j ) = czero @@ -54657,117 +54659,117 @@ module stdlib_linalg_lapack_c work( jj + nblst ) = ctemp*temp -conjg( s )*work( jj ) work( jj ) = s*temp + ctemp*work( jj ) end do - len = len + 1 - ppw = ppw - nblst - 1 + len = len + 1_${ik}$ + ppw = ppw - nblst - 1_${ik}$ end do - ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2*nnb + nnb + ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2_${ik}$*nnb + nnb j0 = jrow - nnb do jrow = j0, j+2, -nnb ppw = ppwo - len = 2 + j - jcol + len = 2_${ik}$ + j - jcol do i = jrow+nnb-1, jrow, -1 ctemp = a( i, j ) a( i, j ) = czero s = b( i, j ) b( i, j ) = czero do jj = ppw, ppw+len-1 - temp = work( jj + 2*nnb ) - work( jj + 2*nnb ) = ctemp*temp -conjg( s )*work( jj ) + temp = work( jj + 2_${ik}$*nnb ) + work( jj + 2_${ik}$*nnb ) = ctemp*temp -conjg( s )*work( jj ) work( jj ) = s*temp + ctemp*work( jj ) end do - len = len + 1 - ppw = ppw - 2*nnb - 1 + len = len + 1_${ik}$ + ppw = ppw - 2_${ik}$*nnb - 1_${ik}$ end do - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end do else - call stdlib_claset( 'LOWER', ihi - jcol - 1, nnb, czero, czero,a( jcol + 2, & + call stdlib${ii}$_claset( 'LOWER', ihi - jcol - 1_${ik}$, nnb, czero, czero,a( jcol + 2_${ik}$, & jcol ), lda ) - call stdlib_claset( 'LOWER', ihi - jcol - 1, nnb, czero, czero,b( jcol + 2, & + call stdlib${ii}$_claset( 'LOWER', ihi - jcol - 1_${ik}$, nnb, czero, czero,b( jcol + 2_${ik}$, & jcol ), ldb ) end if ! apply accumulated unitary matrices to a and b. - if ( top>0 ) then - j = ihi - nblst + 1 - call stdlib_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, cone, a( & - 1, j ), lda,work, nblst, czero, work( pw ), top ) - call stdlib_clacpy( 'ALL', top, nblst, work( pw ), top,a( 1, j ), lda ) + if ( top>0_${ik}$ ) then + j = ihi - nblst + 1_${ik}$ + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, cone, a( & + 1_${ik}$, j ), lda,work, nblst, czero, work( pw ), top ) + call stdlib${ii}$_clacpy( 'ALL', top, nblst, work( pw ), top,a( 1_${ik}$, j ), lda ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( blk22 ) then ! exploit the structure of u. - call stdlib_cunm22( 'RIGHT', 'NO TRANSPOSE', top, 2*nnb,nnb, nnb, work( & - ppwo ), 2*nnb,a( 1, j ), lda, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_cunm22( 'RIGHT', 'NO TRANSPOSE', top, 2_${ik}$*nnb,nnb, nnb, work( & + ppwo ), 2_${ik}$*nnb,a( 1_${ik}$, j ), lda, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2*nnb, 2*nnb, & - cone, a( 1, j ), lda,work( ppwo ), 2*nnb, czero,work( pw ), top ) + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2_${ik}$*nnb, 2_${ik}$*nnb, & + cone, a( 1_${ik}$, j ), lda,work( ppwo ), 2_${ik}$*nnb, czero,work( pw ), top ) - call stdlib_clacpy( 'ALL', top, 2*nnb, work( pw ), top,a( 1, j ), lda ) + call stdlib${ii}$_clacpy( 'ALL', top, 2_${ik}$*nnb, work( pw ), top,a( 1_${ik}$, j ), lda ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do - j = ihi - nblst + 1 - call stdlib_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, cone, b( & - 1, j ), ldb,work, nblst, czero, work( pw ), top ) - call stdlib_clacpy( 'ALL', top, nblst, work( pw ), top,b( 1, j ), ldb ) + j = ihi - nblst + 1_${ik}$ + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, cone, b( & + 1_${ik}$, j ), ldb,work, nblst, czero, work( pw ), top ) + call stdlib${ii}$_clacpy( 'ALL', top, nblst, work( pw ), top,b( 1_${ik}$, j ), ldb ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( blk22 ) then ! exploit the structure of u. - call stdlib_cunm22( 'RIGHT', 'NO TRANSPOSE', top, 2*nnb,nnb, nnb, work( & - ppwo ), 2*nnb,b( 1, j ), ldb, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_cunm22( 'RIGHT', 'NO TRANSPOSE', top, 2_${ik}$*nnb,nnb, nnb, work( & + ppwo ), 2_${ik}$*nnb,b( 1_${ik}$, j ), ldb, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2*nnb, 2*nnb, & - cone, b( 1, j ), ldb,work( ppwo ), 2*nnb, czero,work( pw ), top ) + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2_${ik}$*nnb, 2_${ik}$*nnb, & + cone, b( 1_${ik}$, j ), ldb,work( ppwo ), 2_${ik}$*nnb, czero,work( pw ), top ) - call stdlib_clacpy( 'ALL', top, 2*nnb, work( pw ), top,b( 1, j ), ldb ) + call stdlib${ii}$_clacpy( 'ALL', top, 2_${ik}$*nnb, work( pw ), top,b( 1_${ik}$, j ), ldb ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end if ! apply accumulated unitary matrices to z. if( wantz ) then - j = ihi - nblst + 1 + j = ihi - nblst + 1_${ik}$ if ( initq ) then - topq = max( 2, j - jcol + 1 ) - nh = ihi - topq + 1 + topq = max( 2_${ik}$, j - jcol + 1_${ik}$ ) + nh = ihi - topq + 1_${ik}$ else - topq = 1 + topq = 1_${ik}$ nh = n end if - call stdlib_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, cone, z( & + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, cone, z( & topq, j ), ldz,work, nblst, czero, work( pw ), nh ) - call stdlib_clacpy( 'ALL', nh, nblst, work( pw ), nh,z( topq, j ), ldz ) + call stdlib${ii}$_clacpy( 'ALL', nh, nblst, work( pw ), nh,z( topq, j ), ldz ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( initq ) then - topq = max( 2, j - jcol + 1 ) - nh = ihi - topq + 1 + topq = max( 2_${ik}$, j - jcol + 1_${ik}$ ) + nh = ihi - topq + 1_${ik}$ end if if ( blk22 ) then ! exploit the structure of u. - call stdlib_cunm22( 'RIGHT', 'NO TRANSPOSE', nh, 2*nnb,nnb, nnb, work( & - ppwo ), 2*nnb,z( topq, j ), ldz, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_cunm22( 'RIGHT', 'NO TRANSPOSE', nh, 2_${ik}$*nnb,nnb, nnb, work( & + ppwo ), 2_${ik}$*nnb,z( topq, j ), ldz, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2*nnb, 2*nnb, & - cone, z( topq, j ), ldz,work( ppwo ), 2*nnb, czero, work( pw ),nh ) + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2_${ik}$*nnb, 2_${ik}$*nnb, & + cone, z( topq, j ), ldz,work( ppwo ), 2_${ik}$*nnb, czero, work( pw ),nh ) - call stdlib_clacpy( 'ALL', nh, 2*nnb, work( pw ), nh,z( topq, j ), ldz ) + call stdlib${ii}$_clacpy( 'ALL', nh, 2_${ik}$*nnb, work( pw ), nh,z( topq, j ), ldz ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end if end do @@ -54780,14 +54782,14 @@ module stdlib_linalg_lapack_c if ( wantq )compq2 = 'V' if ( wantz )compz2 = 'V' end if - if ( jcoln .or. pn .or. p0 ) then - call stdlib_ctrtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', p, 1,b( 1, n-p+1 ), ldb, d,& + if( p>0_${ik}$ ) then + call stdlib${ii}$_ctrtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', p, 1_${ik}$,b( 1_${ik}$, n-p+1 ), ldb, d,& p, info ) - if( info>0 ) then - info = 1 + if( info>0_${ik}$ ) then + info = 1_${ik}$ return end if ! put the solution in x - call stdlib_ccopy( p, d, 1, x( n-p+1 ), 1 ) + call stdlib${ii}$_ccopy( p, d, 1_${ik}$, x( n-p+1 ), 1_${ik}$ ) ! update c1 - call stdlib_cgemv( 'NO TRANSPOSE', n-p, p, -cone, a( 1, n-p+1 ), lda,d, 1, cone, c, & - 1 ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', n-p, p, -cone, a( 1_${ik}$, n-p+1 ), lda,d, 1_${ik}$, cone, c, & + 1_${ik}$ ) end if ! solve r11*x1 = c1 for x1 if( n>p ) then - call stdlib_ctrtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n-p, 1,a, lda, c, n-p, & + call stdlib${ii}$_ctrtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n-p, 1_${ik}$,a, lda, c, n-p, & info ) - if( info>0 ) then - info = 2 + if( info>0_${ik}$ ) then + info = 2_${ik}$ return end if ! put the solutions in x - call stdlib_ccopy( n-p, c, 1, x, 1 ) + call stdlib${ii}$_ccopy( n-p, c, 1_${ik}$, x, 1_${ik}$ ) end if ! compute the residual vector: if( m0 )call stdlib_cgemv( 'NO TRANSPOSE', nr, n-m, -cone, a( n-p+1, m+1 ),lda, d(& - nr+1 ), 1, cone, c( n-p+1 ), 1 ) + if( nr>0_${ik}$ )call stdlib${ii}$_cgemv( 'NO TRANSPOSE', nr, n-m, -cone, a( n-p+1, m+1 ),lda, d(& + nr+1 ), 1_${ik}$, cone, c( n-p+1 ), 1_${ik}$ ) else nr = p end if - if( nr>0 ) then - call stdlib_ctrmv( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', nr,a( n-p+1, n-p+1 ), lda, & - d, 1 ) - call stdlib_caxpy( nr, -cone, d, 1, c( n-p+1 ), 1 ) + if( nr>0_${ik}$ ) then + call stdlib${ii}$_ctrmv( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', nr,a( n-p+1, n-p+1 ), lda, & + d, 1_${ik}$ ) + call stdlib${ii}$_caxpy( nr, -cone, d, 1_${ik}$, c( n-p+1 ), 1_${ik}$ ) end if ! backward transformation x = q**h*x - call stdlib_cunmrq( 'LEFT', 'CONJUGATE TRANSPOSE', n, 1, p, b, ldb,work( 1 ), x, n, & + call stdlib${ii}$_cunmrq( 'LEFT', 'CONJUGATE TRANSPOSE', n, 1_${ik}$, p, b, ldb,work( 1_${ik}$ ), x, n, & work( p+mn+1 ), lwork-p-mn, info ) - work( 1 ) = p + mn + max( lopt, int( work( p+mn+1 ),KIND=ilp) ) + work( 1_${ik}$ ) = p + mn + max( lopt, int( work( p+mn+1 ),KIND=${ik}$) ) return - end subroutine stdlib_cgglse + end subroutine stdlib${ii}$_cgglse - pure subroutine stdlib_cgtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond,work, info ) + pure subroutine stdlib${ii}$_cgtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond,work, info ) !! CGTCON estimates the reciprocal of the condition number of a complex !! tridiagonal matrix A using the LU factorization as computed by !! CGTTRF. @@ -54931,42 +54933,42 @@ module stdlib_linalg_lapack_c ! -- 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) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(sp), intent(in) :: anorm real(sp), intent(out) :: rcond ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) complex(sp), intent(in) :: d(*), dl(*), du(*), du2(*) complex(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: onenrm - integer(ilp) :: i, kase, kase1 + integer(${ik}$) :: i, kase, kase1 real(sp) :: ainvnm ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: cmplx ! Executable Statements ! test the input arguments. - info = 0 + info = 0_${ik}$ onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' ) if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then - info = -1 - else if( n<0 ) then - info = -2 + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ else if( anormeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_cgttrs( trans, n, 1, dlf, df, duf, du2, ipiv, work, n,info ) - call stdlib_caxpy( n, cmplx( one,KIND=sp), work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_cgttrs( trans, n, 1_${ik}$, dlf, df, duf, du2, ipiv, work, n,info ) + call stdlib${ii}$_caxpy( n, cmplx( one,KIND=sp), work, 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 @@ -55178,13 +55180,13 @@ module stdlib_linalg_lapack_c rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 70 continue - call stdlib_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(op(a)**h). - call stdlib_cgttrs( transt, n, 1, dlf, df, duf, du2, ipiv, work,n, info ) + call stdlib${ii}$_cgttrs( transt, n, 1_${ik}$, dlf, df, duf, du2, ipiv, work,n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) @@ -55194,7 +55196,7 @@ module stdlib_linalg_lapack_c do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_cgttrs( transn, n, 1, dlf, df, duf, du2, ipiv, work,n, info ) + call stdlib${ii}$_cgttrs( transn, n, 1_${ik}$, dlf, df, duf, du2, ipiv, work,n, info ) end if go to 70 @@ -55207,10 +55209,10 @@ module stdlib_linalg_lapack_c if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_110 return - end subroutine stdlib_cgtrfs + end subroutine stdlib${ii}$_cgtrfs - pure subroutine stdlib_cgtsvx( fact, trans, n, nrhs, dl, d, du, dlf, df, duf,du2, ipiv, b, & + pure subroutine stdlib${ii}$_cgtsvx( fact, trans, n, nrhs, dl, d, du, dlf, df, duf,du2, ipiv, b, & !! CGTSVX uses the LU factorization to compute the solution to a complex !! system of linear equations A * X = B, A**T * X = B, or A**H * X = B, !! where A is a tridiagonal matrix of order N and X and B are N-by-NRHS @@ -55223,11 +55225,11 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: fact, trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs real(sp), intent(out) :: rcond ! Array Arguments - integer(ilp), intent(inout) :: ipiv(*) + integer(${ik}$), intent(inout) :: ipiv(*) real(sp), intent(out) :: berr(*), ferr(*), rwork(*) complex(sp), intent(in) :: b(ldb,*), d(*), dl(*), du(*) complex(sp), intent(inout) :: df(*), dlf(*), du2(*), duf(*) @@ -55241,37 +55243,37 @@ module stdlib_linalg_lapack_c ! Intrinsic Functions intrinsic :: max ! Executable Statements - info = 0 + info = 0_${ik}$ nofact = stdlib_lsame( fact, 'N' ) notran = stdlib_lsame( trans, 'N' ) if( .not.nofact .and. .not.stdlib_lsame( fact, 'F' ) ) 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 - else if( n<0 ) then - info = -3 - else if( nrhs<0 ) then - info = -4 - else if( ldb1 ) then - call stdlib_ccopy( n-1, dl, 1, dlf, 1 ) - call stdlib_ccopy( n-1, du, 1, duf, 1 ) + call stdlib${ii}$_ccopy( n, d, 1_${ik}$, df, 1_${ik}$ ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_ccopy( n-1, dl, 1_${ik}$, dlf, 1_${ik}$ ) + call stdlib${ii}$_ccopy( n-1, du, 1_${ik}$, duf, 1_${ik}$ ) end if - call stdlib_cgttrf( n, dlf, df, duf, du2, ipiv, info ) + call stdlib${ii}$_cgttrf( n, dlf, df, duf, du2, ipiv, info ) ! return if info is non-zero. - if( info>0 )then + if( info>0_${ik}$ )then rcond = zero return end if @@ -55282,23 +55284,23 @@ module stdlib_linalg_lapack_c else norm = 'I' end if - anorm = stdlib_clangt( norm, n, dl, d, du ) + anorm = stdlib${ii}$_clangt( norm, n, dl, d, du ) ! compute the reciprocal of the condition number of a. - call stdlib_cgtcon( norm, n, dlf, df, duf, du2, ipiv, anorm, rcond, work,info ) + call stdlib${ii}$_cgtcon( norm, n, dlf, df, duf, du2, ipiv, anorm, rcond, work,info ) ! compute the solution vectors x. - call stdlib_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_cgttrs( trans, n, nrhs, dlf, df, duf, du2, ipiv, x, ldx,info ) + call stdlib${ii}$_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_cgttrs( trans, n, nrhs, dlf, df, duf, du2, ipiv, x, ldx,info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_cgtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv,b, ldb, x, ldx, & + call stdlib${ii}$_cgtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv,b, ldb, x, ldx, & ferr, berr, work, rwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcondka ) 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_cgerc( n-m, kbt, -cone, x( m+1, i ), 1,bb( kb1-kbt, i )& - , 1, x( m+1, i-kbt ),ldx ) + call stdlib${ii}$_csscal( n-m, one / bii, x( m+1, i ), 1_${ik}$ ) + if( kbt>0_${ik}$ )call stdlib${ii}$_cgerc( n-m, kbt, -cone, 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 ) @@ -55475,21 +55477,21 @@ module stdlib_linalg_lapack_c 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_clartg( ab( k+1, i-k+ka ), ra1,rwork( i-k+ka-m ), work( i-k+ka-& + call stdlib${ii}$_clartg( ab( k+1, i-k+ka ), ra1,rwork( i-k+ka-m ), work( i-k+ka-& m ), ra ) ! create nonzero element a(i-k,i-k+ka+1) outside the ! band and store it in work(i-k) t = -bb( kb1-k, i )*ra1 - work( i-k ) = rwork( i-k+ka-m )*t -conjg( work( i-k+ka-m ) )*ab( 1, i-k+ka & + work( i-k ) = rwork( i-k+ka-m )*t -conjg( work( i-k+ka-m ) )*ab( 1_${ik}$, i-k+ka & ) - ab( 1, i-k+ka ) = work( i-k+ka-m )*t +rwork( i-k+ka-m )*ab( 1, i-k+ka ) + ab( 1_${ik}$, i-k+ka ) = work( i-k+ka-m )*t +rwork( 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 @@ -55501,41 +55503,41 @@ module stdlib_linalg_lapack_c 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 ) = rwork( j-m )*ab( 1, j+1 ) + work( j-m ) = work( j-m )*ab( 1_${ik}$, j+1 ) + ab( 1_${ik}$, j+1 ) = rwork( j-m )*ab( 1_${ik}$, j+1 ) end do ! generate rotations in 1st set to annihilate elements which ! have been created outside the band - if( nrt>0 )call stdlib_clargv( nrt, ab( 1, j2t ), inca, work( j2t-m ), ka1,rwork(& + if( nrt>0_${ik}$ )call stdlib${ii}$_clargv( nrt, ab( 1_${ik}$, j2t ), inca, work( j2t-m ), ka1,rwork(& j2t-m ), ka1 ) - if( nr>0 ) then + if( nr>0_${ik}$ ) then ! apply rotations in 1st set from the right do l = 1, ka - 1 - call stdlib_clartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, & + call stdlib${ii}$_clartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, & rwork( j2-m ),work( j2-m ), ka1 ) end do ! apply rotations in 1st set from both sides to diagonal ! blocks - call stdlib_clar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & + call stdlib${ii}$_clar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & rwork( j2-m ),work( j2-m ), ka1 ) - call stdlib_clacgv( nr, work( j2-m ), ka1 ) + call stdlib${ii}$_clacgv( nr, work( j2-m ), ka1 ) end if ! start applying rotations in 1st set from the left do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_clartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & + if( nrt>0_${ik}$ )call stdlib${ii}$_clartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & ), inca, rwork( j2-m ),work( j2-m ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 1st set do j = j2, j1, ka1 - call stdlib_crot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,rwork( j-m ), & + call stdlib${ii}$_crot( n-m, x( m+1, j ), 1_${ik}$, x( m+1, j+1 ), 1_${ik}$,rwork( j-m ), & conjg( 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 @@ -55543,14 +55545,14 @@ module stdlib_linalg_lapack_c 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 do l = kb - k, 1, -1 nrt = ( n-j2+ka+l ) / ka1 - if( nrt>0 )call stdlib_clartv( nrt, ab( l, j2-l+1 ), inca,ab( l+1, j2-l+1 ), & + if( nrt>0_${ik}$ )call stdlib${ii}$_clartv( nrt, ab( l, j2-l+1 ), inca,ab( l+1, j2-l+1 ), & inca, rwork( j2-ka ),work( j2-ka ), ka1 ) end do nr = ( n-j2+ka ) / ka1 @@ -55562,57 +55564,57 @@ module stdlib_linalg_lapack_c 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 ) = rwork( j )*ab( 1, j+1 ) + work( j ) = work( j )*ab( 1_${ik}$, j+1 ) + ab( 1_${ik}$, j+1 ) = rwork( j )*ab( 1_${ik}$, j+1 ) end do if( update ) then if( i-k0 ) then + if( nr>0_${ik}$ ) then ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band - call stdlib_clargv( nr, ab( 1, j2 ), inca, work( j2 ), ka1,rwork( j2 ), ka1 ) + call stdlib${ii}$_clargv( nr, ab( 1_${ik}$, j2 ), inca, work( j2 ), ka1,rwork( j2 ), ka1 ) ! apply rotations in 2nd set from the right do l = 1, ka - 1 - call stdlib_clartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, & + call stdlib${ii}$_clartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, & rwork( j2 ),work( j2 ), ka1 ) end do ! apply rotations in 2nd set from both sides to diagonal ! blocks - call stdlib_clar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & + call stdlib${ii}$_clar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & rwork( j2 ),work( j2 ), ka1 ) - call stdlib_clacgv( nr, work( j2 ), ka1 ) + call stdlib${ii}$_clacgv( nr, work( j2 ), ka1 ) end if ! start applying rotations in 2nd set from the left do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_clartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & + if( nrt>0_${ik}$ )call stdlib${ii}$_clartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & ), inca, rwork( j2 ),work( j2 ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 2nd set do j = j2, j1, ka1 - call stdlib_crot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,rwork( j ), conjg( & + call stdlib${ii}$_crot( n-m, x( m+1, j ), 1_${ik}$, x( m+1, j+1 ), 1_${ik}$,rwork( j ), conjg( & 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 + j2 = i - k - 1_${ik}$ + max( 1_${ik}$, k-i0+2 )*ka1 ! finish applying rotations in 1st set from the left do l = kb - k, 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_clartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & + if( nrt>0_${ik}$ )call stdlib${ii}$_clartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & ), inca, rwork( j2-m ),work( j2-m ), ka1 ) end do end do - if( kb>1 ) then + if( kb>1_${ik}$ ) then do j = n - 1, j2 + ka, -1 rwork( j-m ) = rwork( j-ka-m ) work( j-m ) = work( j-ka-m ) @@ -55622,8 +55624,8 @@ module stdlib_linalg_lapack_c ! transform a, working with the lower triangle if( update ) then ! form inv(s(i))**h * a * inv(s(i)) - bii = real( bb( 1, i ),KIND=sp) - ab( 1, i ) = ( real( ab( 1, i ),KIND=sp) / bii ) / bii + bii = real( bb( 1_${ik}$, i ),KIND=sp) + ab( 1_${ik}$, i ) = ( real( ab( 1_${ik}$, i ),KIND=sp) / bii ) / bii do j = i + 1, i1 ab( j-i+1, i ) = ab( j-i+1, i ) / bii end do @@ -55633,8 +55635,8 @@ module stdlib_linalg_lapack_c do k = i - kbt, i - 1 do j = i - kbt, k ab( k-j+1, j ) = ab( k-j+1, j ) -bb( i-j+1, j )*conjg( ab( i-k+1,k ) ) - & - conjg( bb( i-k+1, k ) )*ab( i-j+1, j ) + real( ab( 1, i ),KIND=sp)*bb( i-j+& - 1, j )*conjg( bb( i-k+1,k ) ) + conjg( bb( i-k+1, k ) )*ab( i-j+1, j ) + real( ab( 1_${ik}$, i ),KIND=sp)*bb( i-j+& + 1_${ik}$, j )*conjg( 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 ) -conjg( bb( i-k+1, k ) )*ab( i-j+1, j ) @@ -55648,8 +55650,8 @@ module stdlib_linalg_lapack_c end do if( wantx ) then ! post-multiply x by inv(s(i)) - call stdlib_csscal( n-m, one / bii, x( m+1, i ), 1 ) - if( kbt>0 )call stdlib_cgeru( n-m, kbt, -cone, x( m+1, i ), 1,bb( kbt+1, i-& + call stdlib${ii}$_csscal( n-m, one / bii, x( m+1, i ), 1_${ik}$ ) + if( kbt>0_${ik}$ )call stdlib${ii}$_cgeru( n-m, kbt, -cone, 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 @@ -55662,9 +55664,9 @@ module stdlib_linalg_lapack_c 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_clartg( ab( ka1-k, i ), ra1, rwork( i-k+ka-m ),work( i-k+ka-m )& + call stdlib${ii}$_clartg( ab( ka1-k, i ), ra1, rwork( i-k+ka-m ),work( i-k+ka-m )& , ra ) ! create nonzero element a(i-k+ka+1,i-k) outside the ! band and store it in work(i-k) @@ -55676,7 +55678,7 @@ module stdlib_linalg_lapack_c 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 @@ -55693,36 +55695,36 @@ module stdlib_linalg_lapack_c end do ! generate rotations in 1st set to annihilate elements which ! have been created outside the band - if( nrt>0 )call stdlib_clargv( nrt, ab( ka1, j2t-ka ), inca, work( j2t-m ),ka1, & + if( nrt>0_${ik}$ )call stdlib${ii}$_clargv( nrt, ab( ka1, j2t-ka ), inca, work( j2t-m ),ka1, & rwork( j2t-m ), ka1 ) - if( nr>0 ) then + if( nr>0_${ik}$ ) then ! apply rotations in 1st set from the left do l = 1, ka - 1 - call stdlib_clartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, rwork(& + call stdlib${ii}$_clartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, rwork(& j2-m ),work( j2-m ), ka1 ) end do ! apply rotations in 1st set from both sides to diagonal ! blocks - call stdlib_clar2v( nr, ab( 1, j2 ), ab( 1, j2+1 ), ab( 2, j2 ),inca, rwork( & + call stdlib${ii}$_clar2v( nr, ab( 1_${ik}$, j2 ), ab( 1_${ik}$, j2+1 ), ab( 2_${ik}$, j2 ),inca, rwork( & j2-m ), work( j2-m ), ka1 ) - call stdlib_clacgv( nr, work( j2-m ), ka1 ) + call stdlib${ii}$_clacgv( nr, work( j2-m ), ka1 ) end if ! start applying rotations in 1st set from the right do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_clartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& + if( nrt>0_${ik}$ )call stdlib${ii}$_clartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& inca, rwork( j2-m ),work( j2-m ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 1st set do j = j2, j1, ka1 - call stdlib_crot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,rwork( j-m ), work(& + call stdlib${ii}$_crot( n-m, x( m+1, j ), 1_${ik}$, x( m+1, j+1 ), 1_${ik}$,rwork( 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 @@ -55730,14 +55732,14 @@ module stdlib_linalg_lapack_c 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 do l = kb - k, 1, -1 nrt = ( n-j2+ka+l ) / ka1 - if( nrt>0 )call stdlib_clartv( nrt, ab( ka1-l+1, j2-ka ), inca,ab( ka1-l, j2-& + if( nrt>0_${ik}$ )call stdlib${ii}$_clartv( nrt, ab( ka1-l+1, j2-ka ), inca,ab( ka1-l, j2-& ka+1 ), inca,rwork( j2-ka ), work( j2-ka ), ka1 ) end do nr = ( n-j2+ka ) / ka1 @@ -55757,49 +55759,49 @@ module stdlib_linalg_lapack_c 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 + if( nr>0_${ik}$ ) then ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band - call stdlib_clargv( nr, ab( ka1, j2-ka ), inca, work( j2 ), ka1,rwork( j2 ), & + call stdlib${ii}$_clargv( nr, ab( ka1, j2-ka ), inca, work( j2 ), ka1,rwork( j2 ), & ka1 ) ! apply rotations in 2nd set from the left do l = 1, ka - 1 - call stdlib_clartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, rwork(& + call stdlib${ii}$_clartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, rwork(& j2 ),work( j2 ), ka1 ) end do ! apply rotations in 2nd set from both sides to diagonal ! blocks - call stdlib_clar2v( nr, ab( 1, j2 ), ab( 1, j2+1 ), ab( 2, j2 ),inca, rwork( & + call stdlib${ii}$_clar2v( nr, ab( 1_${ik}$, j2 ), ab( 1_${ik}$, j2+1 ), ab( 2_${ik}$, j2 ),inca, rwork( & j2 ), work( j2 ), ka1 ) - call stdlib_clacgv( nr, work( j2 ), ka1 ) + call stdlib${ii}$_clacgv( nr, work( j2 ), ka1 ) end if ! start applying rotations in 2nd set from the right do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_clartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& + if( nrt>0_${ik}$ )call stdlib${ii}$_clartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& inca, rwork( j2 ),work( j2 ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 2nd set do j = j2, j1, ka1 - call stdlib_crot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,rwork( j ), work( & + call stdlib${ii}$_crot( n-m, x( m+1, j ), 1_${ik}$, x( m+1, j+1 ), 1_${ik}$,rwork( 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 + j2 = i - k - 1_${ik}$ + max( 1_${ik}$, k-i0+2 )*ka1 ! finish applying rotations in 1st set from the right do l = kb - k, 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_clartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& + if( nrt>0_${ik}$ )call stdlib${ii}$_clartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& inca, rwork( j2-m ),work( j2-m ), ka1 ) end do end do - if( kb>1 ) then + if( kb>1_${ik}$ ) then do j = n - 1, j2 + ka, -1 rwork( j-m ) = rwork( j-ka-m ) work( j-m ) = work( j-ka-m ) @@ -55821,18 +55823,18 @@ module stdlib_linalg_lapack_c ! 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 @@ -55876,9 +55878,9 @@ module stdlib_linalg_lapack_c end do if( wantx ) then ! post-multiply x by inv(s(i)) - call stdlib_csscal( nx, one / bii, x( 1, i ), 1 ) - if( kbt>0 )call stdlib_cgeru( nx, kbt, -cone, x( 1, i ), 1,bb( kb, i+1 ), & - ldbb-1, x( 1, i+1 ), ldx ) + call stdlib${ii}$_csscal( nx, one / bii, x( 1_${ik}$, i ), 1_${ik}$ ) + if( kbt>0_${ik}$ )call stdlib${ii}$_cgeru( nx, kbt, -cone, x( 1_${ik}$, i ), 1_${ik}$,bb( kb, i+1 ), & + ldbb-1, 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 ) @@ -55889,20 +55891,20 @@ module stdlib_linalg_lapack_c 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_clargv( nrt, ab( 1, j1+ka ), inca, work( j1 ), ka1,rwork( & + if( nrt>0_${ik}$ )call stdlib${ii}$_clargv( nrt, ab( 1_${ik}$, j1+ka ), inca, work( j1 ), ka1,rwork( & j1 ), ka1 ) - if( nr>0 ) then + if( nr>0_${ik}$ ) then ! apply rotations in 1st set from the left do l = 1, ka - 1 - call stdlib_clartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca, & + call stdlib${ii}$_clartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca, & rwork( j1 ),work( j1 ), ka1 ) end do ! apply rotations in 1st set from both sides to diagonal ! blocks - call stdlib_clar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & + call stdlib${ii}$_clar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & rwork( j1 ), work( j1 ),ka1 ) - call stdlib_clacgv( nr, work( j1 ), ka1 ) + call stdlib${ii}$_clacgv( nr, work( j1 ), ka1 ) end if ! start applying rotations in 1st set from the right do l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_clartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& + if( nrt>0_${ik}$ )call stdlib${ii}$_clartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& rwork( j1t ),work( j1t ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 1st set do j = j1, j2, ka1 - call stdlib_crot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,rwork( j ), work( j ) ) + call stdlib${ii}$_crot( nx, x( 1_${ik}$, j ), 1_${ik}$, x( 1_${ik}$, j-1 ), 1_${ik}$,rwork( 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 @@ -55957,15 +55959,15 @@ module stdlib_linalg_lapack_c 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 do l = kb - k, 1, -1 nrt = ( j2+ka+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_clartv( nrt, ab( l, j1t+ka ), inca,ab( l+1, j1t+ka-1 ),& + if( nrt>0_${ik}$ )call stdlib${ii}$_clartv( nrt, ab( l, j1t+ka ), inca,ab( l+1, j1t+ka-1 ),& inca,rwork( m-kb+j1t+ka ),work( m-kb+j1t+ka ), ka1 ) end do nr = ( j2+ka-1 ) / ka1 @@ -55977,59 +55979,59 @@ module stdlib_linalg_lapack_c 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 ) = rwork( 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 ) = rwork( 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 + if( nr>0_${ik}$ ) then ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band - call stdlib_clargv( nr, ab( 1, j1+ka ), inca, work( m-kb+j1 ),ka1, rwork( m-& + call stdlib${ii}$_clargv( nr, ab( 1_${ik}$, j1+ka ), inca, work( m-kb+j1 ),ka1, rwork( m-& kb+j1 ), ka1 ) ! apply rotations in 2nd set from the left do l = 1, ka - 1 - call stdlib_clartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca, & + call stdlib${ii}$_clartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca, & rwork( m-kb+j1 ),work( m-kb+j1 ), ka1 ) end do ! apply rotations in 2nd set from both sides to diagonal ! blocks - call stdlib_clar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & + call stdlib${ii}$_clar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & rwork( m-kb+j1 ),work( m-kb+j1 ), ka1 ) - call stdlib_clacgv( nr, work( m-kb+j1 ), ka1 ) + call stdlib${ii}$_clacgv( nr, work( m-kb+j1 ), ka1 ) end if ! start applying rotations in 2nd set from the right do l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_clartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& + if( nrt>0_${ik}$ )call stdlib${ii}$_clartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& rwork( m-kb+j1t ), work( m-kb+j1t ),ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 2nd set do j = j1, j2, ka1 - call stdlib_crot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,rwork( m-kb+j ), work( & + call stdlib${ii}$_crot( nx, x( 1_${ik}$, j ), 1_${ik}$, x( 1_${ik}$, j-1 ), 1_${ik}$,rwork( 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 + j2 = i + k + 1_${ik}$ - max( 1_${ik}$, k+i0-m+1 )*ka1 ! finish applying rotations in 1st 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_clartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& + if( nrt>0_${ik}$ )call stdlib${ii}$_clartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& rwork( j1t ),work( j1t ), ka1 ) end do end do - if( kb>1 ) then + if( kb>1_${ik}$ ) then do j = 2, i2 - ka rwork( j ) = rwork( j+ka ) work( j ) = work( j+ka ) @@ -56039,8 +56041,8 @@ module stdlib_linalg_lapack_c ! transform a, working with the lower triangle if( update ) then ! form inv(s(i))**h * a * inv(s(i)) - bii = real( bb( 1, i ),KIND=sp) - ab( 1, i ) = ( real( ab( 1, i ),KIND=sp) / bii ) / bii + bii = real( bb( 1_${ik}$, i ),KIND=sp) + ab( 1_${ik}$, i ) = ( real( ab( 1_${ik}$, i ),KIND=sp) / bii ) / bii do j = i1, i - 1 ab( i-j+1, j ) = ab( i-j+1, j ) / bii end do @@ -56050,8 +56052,8 @@ module stdlib_linalg_lapack_c do k = i + 1, i + kbt do j = k, i + kbt ab( j-k+1, k ) = ab( j-k+1, k ) -bb( j-i+1, i )*conjg( ab( k-i+1,i ) ) - & - conjg( bb( k-i+1, i ) )*ab( j-i+1, i ) + real( ab( 1, i ),KIND=sp)*bb( j-i+& - 1, i )*conjg( bb( k-i+1,i ) ) + conjg( bb( k-i+1, i ) )*ab( j-i+1, i ) + real( ab( 1_${ik}$, i ),KIND=sp)*bb( j-i+& + 1_${ik}$, i )*conjg( 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 ) -conjg( bb( k-i+1, i ) )*ab( j-i+1, i ) @@ -56065,9 +56067,9 @@ module stdlib_linalg_lapack_c end do if( wantx ) then ! post-multiply x by inv(s(i)) - call stdlib_csscal( nx, one / bii, x( 1, i ), 1 ) - if( kbt>0 )call stdlib_cgerc( nx, kbt, -cone, x( 1, i ), 1, bb( 2, i ),1, x( & - 1, i+1 ), ldx ) + call stdlib${ii}$_csscal( nx, one / bii, x( 1_${ik}$, i ), 1_${ik}$ ) + if( kbt>0_${ik}$ )call stdlib${ii}$_cgerc( nx, kbt, -cone, 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 ra1 = ab( i-i1+1, i1 ) @@ -56078,9 +56080,9 @@ module stdlib_linalg_lapack_c 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_clargv( nrt, ab( ka1, j1 ), inca, work( j1 ), ka1,rwork( & + if( nrt>0_${ik}$ )call stdlib${ii}$_clargv( nrt, ab( ka1, j1 ), inca, work( j1 ), ka1,rwork( & j1 ), ka1 ) - if( nr>0 ) then + if( nr>0_${ik}$ ) then ! apply rotations in 1st set from the right do l = 1, ka - 1 - call stdlib_clartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, rwork( & + call stdlib${ii}$_clartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, rwork( & j1 ), work( j1 ), ka1 ) end do ! apply rotations in 1st set from both sides to diagonal ! blocks - call stdlib_clar2v( nr, ab( 1, j1 ), ab( 1, j1-1 ),ab( 2, j1-1 ), inca, rwork(& + call stdlib${ii}$_clar2v( nr, ab( 1_${ik}$, j1 ), ab( 1_${ik}$, j1-1 ),ab( 2_${ik}$, j1-1 ), inca, rwork(& j1 ),work( j1 ), ka1 ) - call stdlib_clacgv( nr, work( j1 ), ka1 ) + call stdlib${ii}$_clacgv( nr, work( j1 ), ka1 ) end if ! start applying rotations in 1st set from the left do l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_clartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & + if( nrt>0_${ik}$ )call stdlib${ii}$_clartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & j1t-ka1+l ), inca,rwork( j1t ), work( j1t ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 1st set do j = j1, j2, ka1 - call stdlib_crot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,rwork( j ), conjg( work(& + call stdlib${ii}$_crot( nx, x( 1_${ik}$, j ), 1_${ik}$, x( 1_${ik}$, j-1 ), 1_${ik}$,rwork( j ), conjg( 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 @@ -56147,15 +56149,15 @@ module stdlib_linalg_lapack_c 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 do l = kb - k, 1, -1 nrt = ( j2+ka+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_clartv( nrt, ab( ka1-l+1, j1t+l-1 ), inca,ab( ka1-l, & + if( nrt>0_${ik}$ )call stdlib${ii}$_clartv( nrt, ab( ka1-l+1, j1t+l-1 ), inca,ab( ka1-l, & j1t+l-1 ), inca,rwork( m-kb+j1t+ka ),work( m-kb+j1t+ka ), ka1 ) end do nr = ( j2+ka-1 ) / ka1 @@ -56175,51 +56177,51 @@ module stdlib_linalg_lapack_c 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 + if( nr>0_${ik}$ ) then ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band - call stdlib_clargv( nr, ab( ka1, j1 ), inca, work( m-kb+j1 ),ka1, rwork( m-kb+& + call stdlib${ii}$_clargv( nr, ab( ka1, j1 ), inca, work( m-kb+j1 ),ka1, rwork( m-kb+& j1 ), ka1 ) ! apply rotations in 2nd set from the right do l = 1, ka - 1 - call stdlib_clartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, rwork( & + call stdlib${ii}$_clartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, rwork( & m-kb+j1 ), work( m-kb+j1 ),ka1 ) end do ! apply rotations in 2nd set from both sides to diagonal ! blocks - call stdlib_clar2v( nr, ab( 1, j1 ), ab( 1, j1-1 ),ab( 2, j1-1 ), inca, rwork(& + call stdlib${ii}$_clar2v( nr, ab( 1_${ik}$, j1 ), ab( 1_${ik}$, j1-1 ),ab( 2_${ik}$, j1-1 ), inca, rwork(& m-kb+j1 ),work( m-kb+j1 ), ka1 ) - call stdlib_clacgv( nr, work( m-kb+j1 ), ka1 ) + call stdlib${ii}$_clacgv( nr, work( m-kb+j1 ), ka1 ) end if ! start applying rotations in 2nd set from the left do l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_clartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & + if( nrt>0_${ik}$ )call stdlib${ii}$_clartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & j1t-ka1+l ), inca,rwork( m-kb+j1t ), work( m-kb+j1t ),ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 2nd set do j = j1, j2, ka1 - call stdlib_crot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,rwork( m-kb+j ), conjg( & + call stdlib${ii}$_crot( nx, x( 1_${ik}$, j ), 1_${ik}$, x( 1_${ik}$, j-1 ), 1_${ik}$,rwork( m-kb+j ), conjg( & 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 + j2 = i + k + 1_${ik}$ - max( 1_${ik}$, k+i0-m+1 )*ka1 ! finish applying rotations in 1st 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_clartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & + if( nrt>0_${ik}$ )call stdlib${ii}$_clartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & j1t-ka1+l ), inca,rwork( j1t ), work( j1t ), ka1 ) end do end do - if( kb>1 ) then + if( kb>1_${ik}$ ) then do j = 2, i2 - ka rwork( j ) = rwork( j+ka ) work( j ) = work( j+ka ) @@ -56227,10 +56229,10 @@ module stdlib_linalg_lapack_c end if end if go to 490 - end subroutine stdlib_chbgst + end subroutine stdlib${ii}$_chbgst - pure subroutine stdlib_chbtrd( vect, uplo, n, kd, ab, ldab, d, e, q, ldq,work, info ) + pure subroutine stdlib${ii}$_chbtrd( vect, uplo, n, kd, ab, ldab, d, e, q, ldq,work, info ) !! CHBTRD reduces a complex Hermitian band matrix A to real symmetric !! tridiagonal form T by a unitary similarity transformation: !! Q**H * A * Q = T. @@ -56239,8 +56241,8 @@ module stdlib_linalg_lapack_c ! -- 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(out) :: d(*), e(*) complex(sp), intent(inout) :: ab(ldab,*), q(ldq,*) @@ -56250,7 +56252,7 @@ module stdlib_linalg_lapack_c ! 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) :: abst complex(sp) :: t, temp @@ -56261,32 +56263,32 @@ module stdlib_linalg_lapack_c 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 complex hermitian tridiagonal form, working with ! the upper triangle - nr = 0 - j1 = kdn + 2 - j2 = 1 - ab( kd1, 1 ) = real( ab( kd1, 1 ),KIND=sp) + nr = 0_${ik}$ + j1 = kdn + 2_${ik}$ + j2 = 1_${ik}$ + ab( kd1, 1_${ik}$ ) = real( ab( kd1, 1_${ik}$ ),KIND=sp) 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_clargv( nr, ab( 1, j1-1 ), inca, work( j1 ),kd1, d( j1 ), & + call stdlib${ii}$_clargv( 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_clartv or stdlib_crot is used - if( nr>=2*kd-1 ) then + ! stdlib${ii}$_clartv or stdlib${ii}$_crot is used + if( nr>=2_${ik}$*kd-1 ) then do l = 1, kd - 1 - call stdlib_clartv( nr, ab( l+1, j1-1 ), inca,ab( l, j1 ), inca, & + call stdlib${ii}$_clartv( 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_crot( kdm1, ab( 2, jinc-1 ), 1,ab( 1, jinc ), 1, d( & + call stdlib${ii}$_crot( 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_clartg( 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}$_clartg( 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_crot( k-3, ab( kd-k+4, i+k-2 ), 1,ab( kd-k+3, i+k-1 ), 1,& + call stdlib${ii}$_crot( 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_clar2v( nr, ab( kd1, j1-1 ), ab( kd1, j1 ),ab( kd, & + if( nr>0_${ik}$ )call stdlib${ii}$_clar2v( nr, ab( kd1, j1-1 ), ab( kd1, j1 ),ab( kd, & j1 ), inca, d( j1 ),work( j1 ), kd1 ) ! apply plane rotations from the left - if( nr>0 ) then - call stdlib_clacgv( nr, work( j1 ), kd1 ) - if( 2*kd-10_${ik}$ ) then + call stdlib${ii}$_clacgv( nr, work( j1 ), kd1 ) + if( 2_${ik}$*kd-1n ) then - nrt = nr - 1 + nrt = nr - 1_${ik}$ else nrt = nr end if - if( nrt>0 )call stdlib_clartv( nrt, ab( kd-l, j1+l ), inca,ab( kd-& + if( nrt>0_${ik}$ )call stdlib${ii}$_clartv( 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_crot( kd-1, ab( kd-1, jin+1 ), incx,ab( kd, jin+1 )& + call stdlib${ii}$_crot( 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_crot( lend, ab( kd-1, last+1 ), incx,ab( kd, & + if( lend>0_${ik}$ )call stdlib${ii}$_crot( lend, ab( kd-1, last+1 ), incx,ab( kd, & last+1 ), incx, d( last ),work( last ) ) end if end if @@ -56380,41 +56382,41 @@ module stdlib_linalg_lapack_c ! 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_crot( nq, q( iqb, j-1 ), 1, q( iqb, j ),1, d( j ), & + call stdlib${ii}$_crot( nq, q( iqb, j-1 ), 1_${ik}$, q( iqb, j ),1_${ik}$, d( j ), & conjg( work( j ) ) ) end do else do j = j1, j2, kd1 - call stdlib_crot( n, q( 1, j-1 ), 1, q( 1, j ), 1,d( j ), conjg( & + call stdlib${ii}$_crot( n, q( 1_${ik}$, j-1 ), 1_${ik}$, q( 1_${ik}$, j ), 1_${ik}$,d( j ), conjg( & 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 ! make off-diagonal elements real and copy them to e do i = 1, n - 1 t = ab( kd, i+1 ) @@ -56428,7 +56430,7 @@ module stdlib_linalg_lapack_c end if if( i1 ) then + if( kd>1_${ik}$ ) then ! reduce to complex hermitian tridiagonal form, working with ! the lower triangle - nr = 0 - j1 = kdn + 2 - j2 = 1 - ab( 1, 1 ) = real( ab( 1, 1 ),KIND=sp) + nr = 0_${ik}$ + j1 = kdn + 2_${ik}$ + j2 = 1_${ik}$ + ab( 1_${ik}$, 1_${ik}$ ) = real( ab( 1_${ik}$, 1_${ik}$ ),KIND=sp) 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_clargv( nr, ab( kd1, j1-kd1 ), inca,work( j1 ), kd1, d( j1 )& + call stdlib${ii}$_clargv( 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_clartv or stdlib_crot is used - if( nr>2*kd-1 ) then + ! stdlib${ii}$_clartv or stdlib${ii}$_crot is used + if( nr>2_${ik}$*kd-1 ) then do l = 1, kd - 1 - call stdlib_clartv( nr, ab( kd1-l, j1-kd1+l ), inca,ab( kd1-l+1, & + call stdlib${ii}$_clartv( 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_crot( kdm1, ab( kd, jinc-kd ), incx,ab( kd1, jinc-kd )& + call stdlib${ii}$_crot( 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_clartg( ab( k-1, i ), ab( k, i ),d( i+k-1 ), work( i+k-1 & + call stdlib${ii}$_clartg( 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_crot( k-3, ab( k-2, i+1 ), ldab-1,ab( k-1, i+1 ), ldab-1,& + call stdlib${ii}$_crot( 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_clar2v( nr, ab( 1, j1-1 ), ab( 1, j1 ),ab( 2, j1-1 ),& + if( nr>0_${ik}$ )call stdlib${ii}$_clar2v( 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_clartv or stdlib_crot is used - if( nr>0 ) then - call stdlib_clacgv( nr, work( j1 ), kd1 ) - if( nr>2*kd-1 ) then + ! stdlib${ii}$_clartv or stdlib${ii}$_crot is used + if( nr>0_${ik}$ ) then + call stdlib${ii}$_clacgv( nr, work( j1 ), kd1 ) + 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_clartv( nrt, ab( l+2, j1-1 ), inca,ab( l+1,& + if( nrt>0_${ik}$ )call stdlib${ii}$_clartv( 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_crot( kdm1, ab( 3, j1inc-1 ), 1,ab( 2, j1inc ), 1, & + call stdlib${ii}$_crot( 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_crot( lend, ab( 3, last-1 ), 1,ab( 2, last ),& - 1, d( last ),work( last ) ) + if( lend>0_${ik}$ )call stdlib${ii}$_crot( 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 @@ -56528,30 +56530,30 @@ module stdlib_linalg_lapack_c ! 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_crot( nq, q( iqb, j-1 ), 1, q( iqb, j ),1, d( j ), & + call stdlib${ii}$_crot( 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_crot( n, q( 1, j-1 ), 1, q( 1, j ), 1,d( j ), work( j & + call stdlib${ii}$_crot( 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 @@ -56562,21 +56564,21 @@ module stdlib_linalg_lapack_c end do loop_200 end do loop_210 end if - if( kd>0 ) then + if( kd>0_${ik}$ ) then ! make off-diagonal elements real and copy them to e do i = 1, n - 1 - t = ab( 2, i ) + t = ab( 2_${ik}$, i ) abst = abs( t ) - ab( 2, i ) = abst + ab( 2_${ik}$, i ) = abst e( i ) = abst if( abst/=zero ) then t = t / abst else t = cone end if - if( izero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 )call stdlib_clascl( uplo, 0, 0, one, sigma, n, n, a, lda, info ) - ! call stdlib_chetrd to reduce hermitian matrix to tridiagonal form. - inde = 1 - indtau = 1 + if( iscale==1_${ik}$ )call stdlib${ii}$_clascl( uplo, 0_${ik}$, 0_${ik}$, one, sigma, n, n, a, lda, info ) + ! call stdlib${ii}$_chetrd to reduce hermitian matrix to tridiagonal form. + inde = 1_${ik}$ + indtau = 1_${ik}$ indwrk = indtau + n - llwork = lwork - indwrk + 1 - call stdlib_chetrd( uplo, n, a, lda, w, rwork( inde ), work( indtau ),work( indwrk ), & + llwork = lwork - indwrk + 1_${ik}$ + call stdlib${ii}$_chetrd( uplo, n, a, lda, w, rwork( inde ), work( indtau ),work( indwrk ), & llwork, iinfo ) - ! for eigenvalues only, call stdlib_ssterf. for eigenvectors, first call - ! stdlib_cungtr to generate the unitary matrix, then call stdlib_csteqr. + ! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvectors, first call + ! stdlib${ii}$_cungtr to generate the unitary matrix, then call stdlib${ii}$_csteqr. if( .not.wantz ) then - call stdlib_ssterf( n, w, rwork( inde ), info ) + call stdlib${ii}$_ssterf( n, w, rwork( inde ), info ) else - call stdlib_cungtr( uplo, n, a, lda, work( indtau ), work( indwrk ),llwork, iinfo ) + call stdlib${ii}$_cungtr( uplo, n, a, lda, work( indtau ), work( indwrk ),llwork, iinfo ) indwrk = inde + n - call stdlib_csteqr( jobz, n, w, rwork( inde ), a, lda,rwork( indwrk ), info ) + call stdlib${ii}$_csteqr( jobz, n, w, rwork( inde ), a, lda,rwork( indwrk ), info ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = n else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_sscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ ) end if ! set work(1) to optimal complex workspace size. - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_cheev + end subroutine stdlib${ii}$_cheev - subroutine stdlib_cheevr( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, & + subroutine stdlib${ii}$_cheevr( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, & !! CHEEVR computes selected eigenvalues and, optionally, eigenvectors !! of a complex Hermitian matrix A. Eigenvalues and eigenvectors can !! be selected by specifying either a range of values or a range of @@ -56924,11 +56926,11 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range, uplo - integer(ilp), intent(in) :: il, iu, lda, ldz, liwork, lrwork, lwork, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, iu, lda, ldz, liwork, lrwork, lwork, n + integer(${ik}$), intent(out) :: info, m real(sp), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: isuppz(*), iwork(*) + integer(${ik}$), intent(out) :: isuppz(*), iwork(*) real(sp), intent(out) :: rwork(*), w(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: work(*), z(ldz,*) @@ -56937,7 +56939,7 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: alleig, indeig, lower, lquery, test, valeig, wantz, tryrac character :: order - integer(ilp) :: i, ieeeok, iinfo, imax, indibl, indifl, indisp, indiwo, indrd, indrdd, & + integer(${ik}$) :: i, ieeeok, iinfo, imax, indibl, indifl, indisp, indiwo, indrd, indrdd, & indre, indree, indrwk, indtau, indwk, indwkn, iscale, itmp1, j, jj, liwmin, llwork, & llrwork, llwrkn, lrwmin, lwkopt, lwmin, nb, nsplit real(sp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, & @@ -56946,241 +56948,241 @@ module stdlib_linalg_lapack_c intrinsic :: max,min,real,sqrt ! Executable Statements ! test the input parameters. - ieeeok = stdlib_ilaenv( 10, 'CHEEVR', 'N', 1, 2, 3, 4 ) + ieeeok = stdlib${ii}$_ilaenv( 10_${ik}$, 'CHEEVR', 'N', 1_${ik}$, 2_${ik}$, 3_${ik}$, 4_${ik}$ ) lower = stdlib_lsame( uplo, 'L' ) wantz = stdlib_lsame( jobz, 'V' ) alleig = stdlib_lsame( range, 'A' ) valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) - lquery = ( ( lwork==-1 ) .or. ( lrwork==-1 ) .or.( liwork==-1 ) ) - lrwmin = max( 1, 24*n ) - liwmin = max( 1, 10*n ) - lwmin = max( 1, 2*n ) - info = 0 + lquery = ( ( lwork==-1_${ik}$ ) .or. ( lrwork==-1_${ik}$ ) .or.( liwork==-1_${ik}$ ) ) + lrwmin = max( 1_${ik}$, 24_${ik}$*n ) + liwmin = max( 1_${ik}$, 10_${ik}$*n ) + lwmin = max( 1_${ik}$, 2_${ik}$*n ) + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( lda0 .and. vu<=vl )info = -8 + if( n>0_${ik}$ .and. vu<=vl )info = -8_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -9 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -9_${ik}$ else if( iun ) then - info = -10 + info = -10_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz=real( a( 1, 1 ),KIND=sp) )then - m = 1 - w( 1 ) = real( a( 1, 1 ),KIND=sp) + if( vl=real( a( 1_${ik}$, 1_${ik}$ ),KIND=sp) )then + m = 1_${ik}$ + w( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=sp) end if end if if( wantz ) then - z( 1, 1 ) = one - isuppz( 1 ) = 1 - isuppz( 2 ) = 1 + z( 1_${ik}$, 1_${ik}$ ) = one + isuppz( 1_${ik}$ ) = 1_${ik}$ + isuppz( 2_${ik}$ ) = 1_${ik}$ end if return end if ! get machine constants. - safmin = stdlib_slamch( 'SAFE MINIMUM' ) - eps = stdlib_slamch( 'PRECISION' ) + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_slamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) ) ! scale matrix to allowable range, if necessary. - iscale = 0 + iscale = 0_${ik}$ abstll = abstol if (valeig) then vll = vl vuu = vu end if - anrm = stdlib_clansy( 'M', uplo, n, a, lda, rwork ) + anrm = stdlib${ii}$_clansy( 'M', uplo, n, a, lda, rwork ) if( anrm>zero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then do j = 1, n - call stdlib_csscal( n-j+1, sigma, a( j, j ), 1 ) + call stdlib${ii}$_csscal( n-j+1, sigma, a( j, j ), 1_${ik}$ ) end do else do j = 1, n - call stdlib_csscal( j, sigma, a( 1, j ), 1 ) + call stdlib${ii}$_csscal( j, sigma, a( 1_${ik}$, j ), 1_${ik}$ ) end do end if - if( abstol>0 )abstll = abstol*sigma + if( abstol>0_${ik}$ )abstll = abstol*sigma if( valeig ) then vll = vl*sigma vuu = vu*sigma end if end if ! initialize indices into workspaces. note: the iwork indices are - ! used only if stdlib_ssterf or stdlib_cstemr fail. + ! used only if stdlib${ii}$_ssterf or stdlib${ii}$_cstemr fail. ! work(indtau:indtau+n-1) stores the complex scalar factors of the - ! elementary reflectors used in stdlib_chetrd. - indtau = 1 + ! elementary reflectors used in stdlib${ii}$_chetrd. + indtau = 1_${ik}$ ! indwk is the starting offset of the remaining complex workspace, ! and llwork is the remaining complex workspace size. indwk = indtau + n - llwork = lwork - indwk + 1 + llwork = lwork - indwk + 1_${ik}$ ! rwork(indrd:indrd+n-1) stores the real tridiagonal's diagonal ! entries. - indrd = 1 + indrd = 1_${ik}$ ! rwork(indre:indre+n-1) stores the off-diagonal entries of the - ! tridiagonal matrix from stdlib_chetrd. + ! tridiagonal matrix from stdlib${ii}$_chetrd. indre = indrd + n ! rwork(indrdd:indrdd+n-1) is a copy of the diagonal entries over - ! -written by stdlib_cstemr (the stdlib_ssterf path copies the diagonal to w). + ! -written by stdlib${ii}$_cstemr (the stdlib${ii}$_ssterf path copies the diagonal to w). indrdd = indre + n ! rwork(indree:indree+n-1) is a copy of the off-diagonal entries over - ! -written while computing the eigenvalues in stdlib_ssterf and stdlib_cstemr. + ! -written while computing the eigenvalues in stdlib${ii}$_ssterf and stdlib${ii}$_cstemr. indree = indrdd + n ! indrwk is the starting offset of the left-over real workspace, and ! llrwork is the remaining workspace size. indrwk = indree + n - llrwork = lrwork - indrwk + 1 - ! iwork(indibl:indibl+m-1) corresponds to iblock in stdlib_sstebz and + llrwork = lrwork - indrwk + 1_${ik}$ + ! iwork(indibl:indibl+m-1) corresponds to iblock in stdlib${ii}$_sstebz and ! stores the block indices of each of the m<=n eigenvalues. - indibl = 1 - ! iwork(indisp:indisp+nsplit-1) corresponds to isplit in stdlib_sstebz and + indibl = 1_${ik}$ + ! iwork(indisp:indisp+nsplit-1) corresponds to isplit in stdlib${ii}$_sstebz and ! stores the starting and finishing indices of each block. indisp = indibl + n ! iwork(indifl:indifl+n-1) stores the indices of eigenvectors ! that corresponding to eigenvectors that fail to converge in - ! stdlib_sstein. this information is discarded; if any fail, the driver + ! stdlib${ii}$_sstein. this information is discarded; if any fail, the driver ! returns info > 0. indifl = indisp + n ! indiwo is the offset of the remaining integer workspace. indiwo = indifl + n - ! call stdlib_chetrd to reduce hermitian matrix to tridiagonal form. - call stdlib_chetrd( uplo, n, a, lda, rwork( indrd ), rwork( indre ),work( indtau ), & + ! call stdlib${ii}$_chetrd to reduce hermitian matrix to tridiagonal form. + call stdlib${ii}$_chetrd( uplo, n, a, lda, rwork( indrd ), rwork( indre ),work( indtau ), & work( indwk ), llwork, iinfo ) ! if all eigenvalues are desired - ! then call stdlib_ssterf or stdlib_cstemr and stdlib_cunmtr. + ! then call stdlib${ii}$_ssterf or stdlib${ii}$_cstemr and stdlib${ii}$_cunmtr. test = .false. if( indeig ) then - if( il==1 .and. iu==n ) then + if( il==1_${ik}$ .and. iu==n ) then test = .true. end if end if - if( ( alleig.or.test ) .and. ( ieeeok==1 ) ) then + if( ( alleig.or.test ) .and. ( ieeeok==1_${ik}$ ) ) then if( .not.wantz ) then - call stdlib_scopy( n, rwork( indrd ), 1, w, 1 ) - call stdlib_scopy( n-1, rwork( indre ), 1, rwork( indree ), 1 ) - call stdlib_ssterf( n, w, rwork( indree ), info ) + call stdlib${ii}$_scopy( n, rwork( indrd ), 1_${ik}$, w, 1_${ik}$ ) + call stdlib${ii}$_scopy( n-1, rwork( indre ), 1_${ik}$, rwork( indree ), 1_${ik}$ ) + call stdlib${ii}$_ssterf( n, w, rwork( indree ), info ) else - call stdlib_scopy( n-1, rwork( indre ), 1, rwork( indree ), 1 ) - call stdlib_scopy( n, rwork( indrd ), 1, rwork( indrdd ), 1 ) + call stdlib${ii}$_scopy( n-1, rwork( indre ), 1_${ik}$, rwork( indree ), 1_${ik}$ ) + call stdlib${ii}$_scopy( n, rwork( indrd ), 1_${ik}$, rwork( indrdd ), 1_${ik}$ ) if (abstol <= two*n*eps) then tryrac = .true. else tryrac = .false. end if - call stdlib_cstemr( jobz, 'A', n, rwork( indrdd ),rwork( indree ), vl, vu, il, & + call stdlib${ii}$_cstemr( jobz, 'A', n, rwork( indrdd ),rwork( indree ), vl, vu, il, & iu, m, w,z, ldz, n, isuppz, tryrac,rwork( indrwk ), llrwork,iwork, liwork, info ) ! apply unitary matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_cstemr. - if( wantz .and. info==0 ) then + ! form to eigenvectors returned by stdlib${ii}$_cstemr. + if( wantz .and. info==0_${ik}$ ) then indwkn = indwk - llwrkn = lwork - indwkn + 1 - call stdlib_cunmtr( 'L', uplo, 'N', n, m, a, lda,work( indtau ), z, ldz, work(& + llwrkn = lwork - indwkn + 1_${ik}$ + call stdlib${ii}$_cunmtr( 'L', uplo, 'N', n, m, a, lda,work( indtau ), z, ldz, work(& indwkn ),llwrkn, iinfo ) end if end if - if( info==0 ) then + if( info==0_${ik}$ ) then m = n go to 30 end if - info = 0 + info = 0_${ik}$ end if - ! otherwise, call stdlib_sstebz and, if eigenvectors are desired, stdlib_cstein. - ! also call stdlib_sstebz and stdlib_cstein if stdlib_cstemr fails. + ! otherwise, call stdlib${ii}$_sstebz and, if eigenvectors are desired, stdlib${ii}$_cstein. + ! also call stdlib${ii}$_sstebz and stdlib${ii}$_cstein if stdlib${ii}$_cstemr fails. if( wantz ) then order = 'B' else order = 'E' end if - call stdlib_sstebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indrd ), rwork( & + call stdlib${ii}$_sstebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indrd ), rwork( & indre ), m, nsplit, w,iwork( indibl ), iwork( indisp ), rwork( indrwk ),iwork( indiwo )& , info ) if( wantz ) then - call stdlib_cstein( n, rwork( indrd ), rwork( indre ), m, w,iwork( indibl ), iwork( & + call stdlib${ii}$_cstein( n, rwork( indrd ), rwork( indre ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,rwork( indrwk ), iwork( indiwo ), iwork( indifl ),info ) ! apply unitary matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_cstein. + ! form to eigenvectors returned by stdlib${ii}$_cstein. indwkn = indwk - llwrkn = lwork - indwkn + 1 - call stdlib_cunmtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & + llwrkn = lwork - indwkn + 1_${ik}$ + call stdlib${ii}$_cunmtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & indwkn ), llwrkn, iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. 30 continue - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = m else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_sscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. if( wantz ) then do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp1 = w( j ) do jj = j + 1, m if( w( jj )0 .and. vu<=vl )info = -8 + if( n>0_${ik}$ .and. vu<=vl )info = -8_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -9 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -9_${ik}$ else if( iun ) then - info = -10 + info = -10_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz=real( a( 1, 1 ),KIND=sp) )then - m = 1 - w( 1 ) = real( a( 1, 1 ),KIND=sp) + if( vl=real( a( 1_${ik}$, 1_${ik}$ ),KIND=sp) )then + m = 1_${ik}$ + w( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=sp) end if end if - if( wantz )z( 1, 1 ) = cone + if( wantz )z( 1_${ik}$, 1_${ik}$ ) = cone return end if ! get machine constants. - safmin = stdlib_slamch( 'SAFE MINIMUM' ) - eps = stdlib_slamch( 'PRECISION' ) + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_slamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) ) ! scale matrix to allowable range, if necessary. - iscale = 0 + iscale = 0_${ik}$ abstll = abstol if( valeig ) then vll = vl vuu = vu end if - anrm = stdlib_clanhe( 'M', uplo, n, a, lda, rwork ) + anrm = stdlib${ii}$_clanhe( 'M', uplo, n, a, lda, rwork ) if( anrm>zero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then do j = 1, n - call stdlib_csscal( n-j+1, sigma, a( j, j ), 1 ) + call stdlib${ii}$_csscal( n-j+1, sigma, a( j, j ), 1_${ik}$ ) end do else do j = 1, n - call stdlib_csscal( j, sigma, a( 1, j ), 1 ) + call stdlib${ii}$_csscal( j, sigma, a( 1_${ik}$, j ), 1_${ik}$ ) end do end if - if( abstol>0 )abstll = abstol*sigma + if( abstol>0_${ik}$ )abstll = abstol*sigma if( valeig ) then vll = vl*sigma vuu = vu*sigma end if end if - ! call stdlib_chetrd to reduce hermitian matrix to tridiagonal form. - indd = 1 + ! call stdlib${ii}$_chetrd to reduce hermitian matrix to tridiagonal form. + indd = 1_${ik}$ inde = indd + n indrwk = inde + n - indtau = 1 + indtau = 1_${ik}$ indwrk = indtau + n - llwork = lwork - indwrk + 1 - call stdlib_chetrd( uplo, n, a, lda, rwork( indd ), rwork( inde ),work( indtau ), work(& + llwork = lwork - indwrk + 1_${ik}$ + call stdlib${ii}$_chetrd( uplo, n, a, lda, rwork( indd ), rwork( inde ),work( indtau ), work(& indwrk ), llwork, iinfo ) ! if all eigenvalues are desired and abstol is less than or equal to - ! zero, then call stdlib_ssterf or stdlib_cungtr and stdlib_csteqr. if this fails for - ! some eigenvalue, then try stdlib_sstebz. + ! zero, then call stdlib${ii}$_ssterf or stdlib${ii}$_cungtr and stdlib${ii}$_csteqr. if this fails for + ! some eigenvalue, then try stdlib${ii}$_sstebz. test = .false. if( indeig ) then - if( il==1 .and. iu==n ) then + if( il==1_${ik}$ .and. iu==n ) then test = .true. end if end if if( ( alleig .or. test ) .and. ( abstol<=zero ) ) then - call stdlib_scopy( n, rwork( indd ), 1, w, 1 ) - indee = indrwk + 2*n + call stdlib${ii}$_scopy( n, rwork( indd ), 1_${ik}$, w, 1_${ik}$ ) + indee = indrwk + 2_${ik}$*n if( .not.wantz ) then - call stdlib_scopy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) - call stdlib_ssterf( n, w, rwork( indee ), info ) + call stdlib${ii}$_scopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ ) + call stdlib${ii}$_ssterf( n, w, rwork( indee ), info ) else - call stdlib_clacpy( 'A', n, n, a, lda, z, ldz ) - call stdlib_cungtr( uplo, n, z, ldz, work( indtau ),work( indwrk ), llwork, & + call stdlib${ii}$_clacpy( 'A', n, n, a, lda, z, ldz ) + call stdlib${ii}$_cungtr( uplo, n, z, ldz, work( indtau ),work( indwrk ), llwork, & iinfo ) - call stdlib_scopy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) - call stdlib_csteqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) + call stdlib${ii}$_scopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ ) + call stdlib${ii}$_csteqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) - if( info==0 ) then + if( info==0_${ik}$ ) then do i = 1, n - ifail( i ) = 0 + ifail( i ) = 0_${ik}$ end do end if end if - if( info==0 ) then + if( info==0_${ik}$ ) then m = n go to 40 end if - info = 0 + info = 0_${ik}$ end if - ! otherwise, call stdlib_sstebz and, if eigenvectors are desired, stdlib_cstein. + ! otherwise, call stdlib${ii}$_sstebz and, if eigenvectors are desired, stdlib${ii}$_cstein. if( wantz ) then order = 'B' else order = 'E' end if - indibl = 1 + indibl = 1_${ik}$ indisp = indibl + n indiwk = indisp + n - call stdlib_sstebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indd ), rwork( & + call stdlib${ii}$_sstebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indd ), rwork( & inde ), m, nsplit, w,iwork( indibl ), iwork( indisp ), rwork( indrwk ),iwork( indiwk ),& info ) if( wantz ) then - call stdlib_cstein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & + call stdlib${ii}$_cstein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,rwork( indrwk ), iwork( indiwk ), ifail, info ) ! apply unitary matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_cstein. - call stdlib_cunmtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & + ! form to eigenvectors returned by stdlib${ii}$_cstein. + call stdlib${ii}$_cunmtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & indwrk ), llwork, iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. 40 continue - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = m else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_sscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. if( wantz ) then do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp1 = w( j ) do jj = j + 1, m if( w( jj )3 ) then - info = -1 + lquery = ( lwork== -1_${ik}$ ) + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( lda0 )neig = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )neig = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**h*y or inv(u)*y if( upper ) then @@ -57535,9 +57537,9 @@ module stdlib_linalg_lapack_c else trans = 'C' end if - call stdlib_ctrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, cone,b, ldb, a, lda & + call stdlib${ii}$_ctrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, cone,b, ldb, a, lda & ) - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**h*y if( upper ) then @@ -57545,16 +57547,16 @@ module stdlib_linalg_lapack_c else trans = 'N' end if - call stdlib_ctrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, cone,b, ldb, a, lda & + call stdlib${ii}$_ctrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, cone,b, ldb, a, lda & ) end if end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_chegv + end subroutine stdlib${ii}$_chegv - subroutine stdlib_chegvx( itype, jobz, range, uplo, n, a, lda, b, ldb,vl, vu, il, iu, abstol,& + subroutine stdlib${ii}$_chegvx( itype, jobz, range, uplo, n, a, lda, b, ldb,vl, vu, il, iu, abstol,& !! CHEGVX computes selected eigenvalues, and optionally, eigenvectors !! of a complex generalized Hermitian-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and @@ -57567,11 +57569,11 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range, uplo - integer(ilp), intent(in) :: il, itype, iu, lda, ldb, ldz, lwork, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, itype, iu, lda, ldb, ldz, lwork, n + integer(${ik}$), intent(out) :: info, m real(sp), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: ifail(*), iwork(*) + integer(${ik}$), intent(out) :: ifail(*), iwork(*) real(sp), intent(out) :: rwork(*), w(*) complex(sp), intent(inout) :: a(lda,*), b(ldb,*) complex(sp), intent(out) :: work(*), z(ldz,*) @@ -57580,7 +57582,7 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: alleig, indeig, lquery, upper, valeig, wantz character :: trans - integer(ilp) :: lwkopt, nb + integer(${ik}$) :: lwkopt, nb ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -57590,71 +57592,71 @@ module stdlib_linalg_lapack_c alleig = stdlib_lsame( range, 'A' ) valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) - lquery = ( lwork==-1 ) - info = 0 - if( itype<1 .or. itype>3 ) then - info = -1 + lquery = ( lwork==-1_${ik}$ ) + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -3 + info = -3_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( lda0 .and. vu<=vl )info = -11 + if( n>0_${ik}$ .and. vu<=vl )info = -11_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -12 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -12_${ik}$ else if( iun ) then - info = -13 + info = -13_${ik}$ end if end if end if - if (info==0) then - if (ldz<1 .or. (wantz .and. ldz0 )m = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )m = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**h*y or inv(u)*y if( upper ) then @@ -57662,9 +57664,9 @@ module stdlib_linalg_lapack_c else trans = 'C' end if - call stdlib_ctrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, cone, b,ldb, z, ldz ) + call stdlib${ii}$_ctrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, cone, b,ldb, z, ldz ) - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**h*y if( upper ) then @@ -57672,17 +57674,17 @@ module stdlib_linalg_lapack_c else trans = 'N' end if - call stdlib_ctrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, cone, b,ldb, z, ldz ) + call stdlib${ii}$_ctrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, cone, b,ldb, z, ldz ) end if end if ! set work(1) to optimal complex workspace size. - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_chegvx + end subroutine stdlib${ii}$_chegvx - pure subroutine stdlib_cherfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr, & + pure subroutine stdlib${ii}$_cherfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr, & !! CHERFS improves the computed solution to a system of linear !! equations when the coefficient matrix is Hermitian indefinite, and !! provides error bounds and backward error estimates for the solution. @@ -57692,17 +57694,17 @@ module stdlib_linalg_lapack_c ! -- 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, ldaf, ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) real(sp), intent(out) :: berr(*), ferr(*), rwork(*) complex(sp), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*) complex(sp), intent(out) :: work(*) complex(sp), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: itmax = 5 + integer(${ik}$), parameter :: itmax = 5_${ik}$ @@ -57710,11 +57712,11 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: upper - integer(ilp) :: count, i, j, k, kase, nz + integer(${ik}$) :: count, i, j, k, kase, nz real(sp) :: eps, lstres, s, safe1, safe2, safmin, xk complex(sp) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,aimag,max,real ! Statement Functions @@ -57723,29 +57725,29 @@ module stdlib_linalg_lapack_c cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) ) ! 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( nrhs<0 ) then - info = -3 - else if( ldaeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_chetrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) - call stdlib_caxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_chetrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info ) + call stdlib${ii}$_caxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -57845,22 +57847,22 @@ module stdlib_linalg_lapack_c rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**h). - call stdlib_chetrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) + call stdlib${ii}$_chetrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do - else if( kase==2 ) then + else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_chetrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) + call stdlib${ii}$_chetrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info ) end if go to 100 end if @@ -57872,10 +57874,10 @@ module stdlib_linalg_lapack_c if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_cherfs + end subroutine stdlib${ii}$_cherfs - pure subroutine stdlib_chesv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) + pure subroutine stdlib${ii}$_chesv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) !! CHESV computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS @@ -57892,68 +57894,68 @@ module stdlib_linalg_lapack_c ! -- 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, lwork, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, lwork, n, nrhs ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(sp), intent(inout) :: a(lda,*), b(ldb,*) complex(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: lwkopt, nb + integer(${ik}$) :: lwkopt, nb ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) if( .not.stdlib_lsame( uplo, 'U' ) .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 + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_clanhe( 'I', uplo, n, a, lda, rwork ) + anorm = stdlib${ii}$_clanhe( 'I', uplo, n, a, lda, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_checon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, info ) + call stdlib${ii}$_checon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, info ) ! compute the solution vectors x. - call stdlib_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_chetrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info ) + call stdlib${ii}$_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_chetrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_cherfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & + call stdlib${ii}$_cherfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & work, rwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcondn .or. ihimaxit )go to 180 @@ -58419,7 +58421,7 @@ module stdlib_linalg_lapack_c go to 60 end if end if - if( abs( t( ilast, ilast ) )<=max( safmin, ulp*(abs( t( ilast - 1, ilast ) ) + abs( & + if( abs( t( ilast, ilast ) )<=max( safmin, ulp*(abs( t( ilast - 1_${ik}$, ilast ) ) + abs( & t( ilast-1, ilast-1 )) ) ) ) then t( ilast, ilast ) = czero go to 50 @@ -58439,8 +58441,8 @@ module stdlib_linalg_lapack_c end if end if ! test 2: for t(j,j)=0 - temp = abs ( t( j, j + 1 ) ) - if ( j > ilo )temp = temp + abs ( t( j - 1, j ) ) + temp = abs ( t( j, j + 1_${ik}$ ) ) + if ( j > ilo )temp = temp + abs ( t( j - 1_${ik}$, j ) ) if( abs( t( j, j ) )=ilast ) then go to 60 else - ifirst = jch + 1 + ifirst = jch + 1_${ik}$ go to 70 end if end if @@ -58483,24 +58485,24 @@ module stdlib_linalg_lapack_c ! then process as in the case t(ilast,ilast)=0 do jch = j, ilast - 1 ctemp = t( jch, jch+1 ) - call stdlib_clartg( ctemp, t( jch+1, jch+1 ), c, s,t( jch, jch+1 ) ) + call stdlib${ii}$_clartg( ctemp, t( jch+1, jch+1 ), c, s,t( jch, jch+1 ) ) t( jch+1, jch+1 ) = czero - if( jchzero ) then if( real( x / temp2,KIND=sp)*real( y,KIND=sp)+aimag( x / temp2 )*aimag( y )& safmin ) & + if( ( iiter / 20_${ik}$ )*20_${ik}$==iiter .and.bscale*abs1(t( ilast, ilast ))>safmin ) & then eshift = eshift + ( ascale*h( ilast,ilast ) )/( bscale*t( ilast, ilast ) ) @@ -58625,12 +58627,12 @@ module stdlib_linalg_lapack_c ! do an implicit-shift qz sweep. ! initial q ctemp2 = ascale*h( istart+1, istart ) - call stdlib_clartg( ctemp, ctemp2, c, s, ctemp3 ) + call stdlib${ii}$_clartg( ctemp, ctemp2, c, s, ctemp3 ) ! sweep loop_150: do j = istart, ilast - 1 if( j>istart ) then ctemp = h( j, j-1 ) - call stdlib_clartg( ctemp, h( j+1, j-1 ), c, s, h( j, j-1 ) ) + call stdlib${ii}$_clartg( ctemp, h( j+1, j-1 ), c, s, h( j, j-1 ) ) h( j+1, j-1 ) = czero end if do jc = j, ilastm @@ -58649,7 +58651,7 @@ module stdlib_linalg_lapack_c end do end if ctemp = t( j+1, j+1 ) - call stdlib_clartg( ctemp, t( j+1, j ), c, s, t( j+1, j+1 ) ) + call stdlib${ii}$_clartg( ctemp, t( j+1, j ), c, s, t( j+1, j+1 ) ) t( j+1, j ) = czero do jr = ifrstm, min( j+2, ilast ) ctemp = c*h( jr, j+1 ) + s*h( jr, j ) @@ -58684,12 +58686,12 @@ module stdlib_linalg_lapack_c signbc = conjg( t( j, j ) / absb ) t( j, j ) = absb if( ilschr ) then - call stdlib_cscal( j-1, signbc, t( 1, j ), 1 ) - call stdlib_cscal( j, signbc, h( 1, j ), 1 ) + call stdlib${ii}$_cscal( j-1, signbc, t( 1_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_cscal( j, signbc, h( 1_${ik}$, j ), 1_${ik}$ ) else - call stdlib_cscal( 1, signbc, h( j, j ), 1 ) + call stdlib${ii}$_cscal( 1_${ik}$, signbc, h( j, j ), 1_${ik}$ ) end if - if( ilz )call stdlib_cscal( n, signbc, z( 1, j ), 1 ) + if( ilz )call stdlib${ii}$_cscal( n, signbc, z( 1_${ik}$, j ), 1_${ik}$ ) else t( j, j ) = czero end if @@ -58697,15 +58699,15 @@ module stdlib_linalg_lapack_c beta( j ) = t( j, j ) end do ! normal termination - info = 0 + info = 0_${ik}$ ! exit (other than argument error) -- return optimal workspace size 210 continue - work( 1 ) = cmplx( n,KIND=sp) + work( 1_${ik}$ ) = cmplx( n,KIND=sp) return - end subroutine stdlib_chgeqz + end subroutine stdlib${ii}$_chgeqz - pure subroutine stdlib_chpcon( uplo, n, ap, ipiv, anorm, rcond, work, info ) + pure subroutine stdlib${ii}$_chpcon( uplo, n, ap, ipiv, anorm, rcond, work, info ) !! CHPCON estimates the reciprocal of the condition number of a complex !! Hermitian packed matrix A using the factorization A = U*D*U**H or !! A = L*D*L**H computed by CHPTRF. @@ -58716,40 +58718,40 @@ module stdlib_linalg_lapack_c ! -- 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) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(sp), intent(in) :: anorm real(sp), intent(out) :: rcond ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) complex(sp), intent(in) :: ap(*) complex(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: i, ip, kase + integer(${ik}$) :: i, ip, kase real(sp) :: ainvnm ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! 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 + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ else if( anorm0 .and. ap( ip )==zero )return ip = ip - i end do else ! lower triangular storage: examine d from top to bottom. - ip = 1 + ip = 1_${ik}$ do i = 1, n if( ipiv( i )>0 .and. ap( ip )==zero )return - ip = ip + n - i + 1 + ip = ip + n - i + 1_${ik}$ end do end if ! estimate the 1-norm of the inverse. - kase = 0 + kase = 0_${ik}$ 30 continue - call stdlib_clacn2( n, work( n+1 ), work, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_clacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + if( kase/=0_${ik}$ ) then ! multiply by inv(l*d*l**h) or inv(u*d*u**h). - call stdlib_chptrs( uplo, n, 1, ap, ipiv, work, n, info ) + call stdlib${ii}$_chptrs( uplo, n, 1_${ik}$, ap, ipiv, work, n, info ) go to 30 end if ! compute the estimate of the reciprocal condition number. if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm return - end subroutine stdlib_chpcon + end subroutine stdlib${ii}$_chpcon - subroutine stdlib_chpev( jobz, uplo, n, ap, w, z, ldz, work, rwork,info ) + subroutine stdlib${ii}$_chpev( jobz, uplo, n, ap, w, z, ldz, work, rwork,info ) !! CHPEV computes all the eigenvalues and, optionally, eigenvectors of a !! complex Hermitian matrix in packed storage. ! -- lapack driver routine -- @@ -58794,8 +58796,8 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldz, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldz, n ! Array Arguments real(sp), intent(out) :: rwork(*), w(*) complex(sp), intent(inout) :: ap(*) @@ -58804,86 +58806,86 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: wantz - integer(ilp) :: iinfo, imax, inde, indrwk, indtau, indwrk, iscale + integer(${ik}$) :: iinfo, imax, inde, indrwk, indtau, indwrk, iscale real(sp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! Intrinsic Functions intrinsic :: sqrt ! Executable Statements ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) - info = 0 + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( stdlib_lsame( uplo, 'L' ) .or. stdlib_lsame( uplo, 'U' ) ) )& then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldz<1 .or. ( wantz .and. ldzzero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then - call stdlib_csscal( ( n*( n+1 ) ) / 2, sigma, ap, 1 ) + if( iscale==1_${ik}$ ) then + call stdlib${ii}$_csscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ ) end if - ! call stdlib_chptrd to reduce hermitian packed matrix to tridiagonal form. - inde = 1 - indtau = 1 - call stdlib_chptrd( uplo, n, ap, w, rwork( inde ), work( indtau ),iinfo ) - ! for eigenvalues only, call stdlib_ssterf. for eigenvectors, first call - ! stdlib_cupgtr to generate the orthogonal matrix, then call stdlib_csteqr. + ! call stdlib${ii}$_chptrd to reduce hermitian packed matrix to tridiagonal form. + inde = 1_${ik}$ + indtau = 1_${ik}$ + call stdlib${ii}$_chptrd( uplo, n, ap, w, rwork( inde ), work( indtau ),iinfo ) + ! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvectors, first call + ! stdlib${ii}$_cupgtr to generate the orthogonal matrix, then call stdlib${ii}$_csteqr. if( .not.wantz ) then - call stdlib_ssterf( n, w, rwork( inde ), info ) + call stdlib${ii}$_ssterf( n, w, rwork( inde ), info ) else indwrk = indtau + n - call stdlib_cupgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo ) + call stdlib${ii}$_cupgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo ) indrwk = inde + n - call stdlib_csteqr( jobz, n, w, rwork( inde ), z, ldz,rwork( indrwk ), info ) + call stdlib${ii}$_csteqr( jobz, n, w, rwork( inde ), z, ldz,rwork( indrwk ), info ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = n else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_sscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ ) end if return - end subroutine stdlib_chpev + end subroutine stdlib${ii}$_chpev - subroutine stdlib_chpevx( jobz, range, uplo, n, ap, vl, vu, il, iu,abstol, m, w, z, ldz, & + subroutine stdlib${ii}$_chpevx( jobz, range, uplo, n, ap, vl, vu, il, iu,abstol, m, w, z, ldz, & !! CHPEVX computes selected eigenvalues and, optionally, eigenvectors !! of a complex Hermitian matrix A in packed storage. !! Eigenvalues/vectors can be selected by specifying either a range of @@ -58894,11 +58896,11 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range, uplo - integer(ilp), intent(in) :: il, iu, ldz, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, iu, ldz, n + integer(${ik}$), intent(out) :: info, m real(sp), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: ifail(*), iwork(*) + integer(${ik}$), intent(out) :: ifail(*), iwork(*) real(sp), intent(out) :: rwork(*), w(*) complex(sp), intent(inout) :: ap(*) complex(sp), intent(out) :: work(*), z(ldz,*) @@ -58908,7 +58910,7 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: alleig, indeig, test, valeig, wantz character :: order - integer(ilp) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwk, indrwk, & + integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwk, indrwk, & indtau, indwrk, iscale, itmp1, j, jj, nsplit real(sp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, & vuu @@ -58920,59 +58922,59 @@ module stdlib_linalg_lapack_c alleig = stdlib_lsame( range, 'A' ) valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) - info = 0 + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( stdlib_lsame( uplo, 'L' ) .or. stdlib_lsame( uplo, 'U' ) ) )& then - info = -3 - else if( n<0 ) then - info = -4 + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ else if( valeig ) then - if( n>0 .and. vu<=vl )info = -7 + if( n>0_${ik}$ .and. vu<=vl )info = -7_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -8 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -8_${ik}$ else if( iun ) then - info = -9 + info = -9_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz=real( ap( 1 ),KIND=sp) ) then - m = 1 - w( 1 ) = real( ap( 1 ),KIND=sp) + if( vl=real( ap( 1_${ik}$ ),KIND=sp) ) then + m = 1_${ik}$ + w( 1_${ik}$ ) = real( ap( 1_${ik}$ ),KIND=sp) end if end if - if( wantz )z( 1, 1 ) = cone + if( wantz )z( 1_${ik}$, 1_${ik}$ ) = cone return end if ! get machine constants. - safmin = stdlib_slamch( 'SAFE MINIMUM' ) - eps = stdlib_slamch( 'PRECISION' ) + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_slamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) ) ! scale matrix to allowable range, if necessary. - iscale = 0 + iscale = 0_${ik}$ abstll = abstol if ( valeig ) then vll = vl @@ -58981,99 +58983,99 @@ module stdlib_linalg_lapack_c vll = zero vuu = zero endif - anrm = stdlib_clanhp( 'M', uplo, n, ap, rwork ) + anrm = stdlib${ii}$_clanhp( 'M', uplo, n, ap, rwork ) if( anrm>zero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then - call stdlib_csscal( ( n*( n+1 ) ) / 2, sigma, ap, 1 ) - if( abstol>0 )abstll = abstol*sigma + if( iscale==1_${ik}$ ) then + call stdlib${ii}$_csscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ ) + if( abstol>0_${ik}$ )abstll = abstol*sigma if( valeig ) then vll = vl*sigma vuu = vu*sigma end if end if - ! call stdlib_chptrd to reduce hermitian packed matrix to tridiagonal form. - indd = 1 + ! call stdlib${ii}$_chptrd to reduce hermitian packed matrix to tridiagonal form. + indd = 1_${ik}$ inde = indd + n indrwk = inde + n - indtau = 1 + indtau = 1_${ik}$ indwrk = indtau + n - call stdlib_chptrd( uplo, n, ap, rwork( indd ), rwork( inde ),work( indtau ), iinfo ) + call stdlib${ii}$_chptrd( uplo, n, ap, rwork( indd ), rwork( inde ),work( indtau ), iinfo ) ! if all eigenvalues are desired and abstol is less than or equal - ! to zero, then call stdlib_ssterf or stdlib_cupgtr and stdlib_csteqr. if this fails - ! for some eigenvalue, then try stdlib_sstebz. + ! to zero, then call stdlib${ii}$_ssterf or stdlib${ii}$_cupgtr and stdlib${ii}$_csteqr. if this fails + ! for some eigenvalue, then try stdlib${ii}$_sstebz. test = .false. if (indeig) then - if (il==1 .and. iu==n) then + if (il==1_${ik}$ .and. iu==n) then test = .true. end if end if if ((alleig .or. test) .and. (abstol<=zero)) then - call stdlib_scopy( n, rwork( indd ), 1, w, 1 ) - indee = indrwk + 2*n + call stdlib${ii}$_scopy( n, rwork( indd ), 1_${ik}$, w, 1_${ik}$ ) + indee = indrwk + 2_${ik}$*n if( .not.wantz ) then - call stdlib_scopy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) - call stdlib_ssterf( n, w, rwork( indee ), info ) + call stdlib${ii}$_scopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ ) + call stdlib${ii}$_ssterf( n, w, rwork( indee ), info ) else - call stdlib_cupgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo ) + call stdlib${ii}$_cupgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo ) - call stdlib_scopy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) - call stdlib_csteqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) + call stdlib${ii}$_scopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ ) + call stdlib${ii}$_csteqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) - if( info==0 ) then + if( info==0_${ik}$ ) then do i = 1, n - ifail( i ) = 0 + ifail( i ) = 0_${ik}$ end do end if end if - if( info==0 ) then + if( info==0_${ik}$ ) then m = n go to 20 end if - info = 0 + info = 0_${ik}$ end if - ! otherwise, call stdlib_sstebz and, if eigenvectors are desired, stdlib_cstein. + ! otherwise, call stdlib${ii}$_sstebz and, if eigenvectors are desired, stdlib${ii}$_cstein. if( wantz ) then order = 'B' else order = 'E' end if - indibl = 1 + indibl = 1_${ik}$ indisp = indibl + n indiwk = indisp + n - call stdlib_sstebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indd ), rwork( & + call stdlib${ii}$_sstebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indd ), rwork( & inde ), m, nsplit, w,iwork( indibl ), iwork( indisp ), rwork( indrwk ),iwork( indiwk ),& info ) if( wantz ) then - call stdlib_cstein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & + call stdlib${ii}$_cstein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,rwork( indrwk ), iwork( indiwk ), ifail, info ) ! apply unitary matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_cstein. + ! form to eigenvectors returned by stdlib${ii}$_cstein. indwrk = indtau + n - call stdlib_cupmtr( 'L', uplo, 'N', n, m, ap, work( indtau ), z, ldz,work( indwrk ),& + call stdlib${ii}$_cupmtr( 'L', uplo, 'N', n, m, ap, work( indtau ), z, ldz,work( indwrk ),& iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. 20 continue - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = m else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_sscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. if( wantz ) then do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp1 = w( j ) do jj = j + 1, m if( w( jj )3 ) then - info = -1 + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( ldz<1 .or. ( wantz .and. ldz0 )neig = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )neig = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**h*y or inv(u)*y if( upper ) then @@ -59166,9 +59168,9 @@ module stdlib_linalg_lapack_c trans = 'C' end if do j = 1, neig - call stdlib_ctpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_ctpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**h*y if( upper ) then @@ -59177,15 +59179,15 @@ module stdlib_linalg_lapack_c trans = 'N' end if do j = 1, neig - call stdlib_ctpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_ctpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do end if end if return - end subroutine stdlib_chpgv + end subroutine stdlib${ii}$_chpgv - subroutine stdlib_chpgvx( itype, jobz, range, uplo, n, ap, bp, vl, vu,il, iu, abstol, m, w, & + subroutine stdlib${ii}$_chpgvx( itype, jobz, range, uplo, n, ap, bp, vl, vu,il, iu, abstol, m, w, & !! CHPGVX computes selected eigenvalues and, optionally, eigenvectors !! of a complex generalized Hermitian-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and @@ -59199,11 +59201,11 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range, uplo - integer(ilp), intent(in) :: il, itype, iu, ldz, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, itype, iu, ldz, n + integer(${ik}$), intent(out) :: info, m real(sp), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: ifail(*), iwork(*) + integer(${ik}$), intent(out) :: ifail(*), iwork(*) real(sp), intent(out) :: rwork(*), w(*) complex(sp), intent(inout) :: ap(*), bp(*) complex(sp), intent(out) :: work(*), z(ldz,*) @@ -59211,7 +59213,7 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: alleig, indeig, upper, valeig, wantz character :: trans - integer(ilp) :: j + integer(${ik}$) :: j ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -59221,55 +59223,55 @@ module stdlib_linalg_lapack_c alleig = stdlib_lsame( range, 'A' ) valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) - info = 0 - if( itype<1 .or. itype>3 ) then - info = -1 + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -3 + info = -3_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -4 - else if( n<0 ) then - info = -5 + info = -4_${ik}$ + else if( n<0_${ik}$ ) then + info = -5_${ik}$ else if( valeig ) then - if( n>0 .and. vu<=vl ) then - info = -9 + if( n>0_${ik}$ .and. vu<=vl ) then + info = -9_${ik}$ end if else if( indeig ) then - if( il<1 ) then - info = -10 + if( il<1_${ik}$ ) then + info = -10_${ik}$ else if( iun ) then - info = -11 + info = -11_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz0 )m = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )m = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**h*y or inv(u)*y if( upper ) then @@ -59278,9 +59280,9 @@ module stdlib_linalg_lapack_c trans = 'C' end if do j = 1, m - call stdlib_ctpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_ctpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**h*y if( upper ) then @@ -59289,15 +59291,15 @@ module stdlib_linalg_lapack_c trans = 'N' end if do j = 1, m - call stdlib_ctpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_ctpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do end if end if return - end subroutine stdlib_chpgvx + end subroutine stdlib${ii}$_chpgvx - pure subroutine stdlib_chprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,& + pure subroutine stdlib${ii}$_chprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,& !! CHPRFS improves the computed solution to a system of linear !! equations when the coefficient matrix is Hermitian indefinite !! and packed, and provides error bounds and backward error estimates @@ -59308,17 +59310,17 @@ module stdlib_linalg_lapack_c ! -- 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) :: ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) real(sp), intent(out) :: berr(*), ferr(*), rwork(*) complex(sp), intent(in) :: afp(*), ap(*), b(ldb,*) complex(sp), intent(out) :: work(*) complex(sp), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: itmax = 5 + integer(${ik}$), parameter :: itmax = 5_${ik}$ @@ -59326,11 +59328,11 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: upper - integer(ilp) :: count, i, ik, j, k, kase, kk, nz + integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz real(sp) :: eps, lstres, s, safe1, safe2, safmin, xk complex(sp) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,aimag,max,real ! Statement Functions @@ -59339,25 +59341,25 @@ module stdlib_linalg_lapack_c cabs1( zdum ) = abs( real( zdum,KIND=sp) ) + abs( aimag( zdum ) ) ! 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( nrhs<0 ) then - info = -3 - else if( ldbeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_chptrs( uplo, n, 1, afp, ipiv, work, n, info ) - call stdlib_caxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_chptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info ) + call stdlib${ii}$_caxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -59464,22 +59466,22 @@ module stdlib_linalg_lapack_c rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_clacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**h). - call stdlib_chptrs( uplo, n, 1, afp, ipiv, work, n, info ) + call stdlib${ii}$_chptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do - else if( kase==2 ) then + else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_chptrs( uplo, n, 1, afp, ipiv, work, n, info ) + call stdlib${ii}$_chptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info ) end if go to 100 end if @@ -59491,10 +59493,10 @@ module stdlib_linalg_lapack_c if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_chprfs + end subroutine stdlib${ii}$_chprfs - pure subroutine stdlib_chpsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) + pure subroutine stdlib${ii}$_chpsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) !! CHPSV computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N Hermitian matrix stored in packed format and X @@ -59511,41 +59513,41 @@ module stdlib_linalg_lapack_c ! -- 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) :: ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(sp), intent(inout) :: ap(*), b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .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( ldb0 )then + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_clanhp( 'I', uplo, n, ap, rwork ) + anorm = stdlib${ii}$_clanhp( 'I', uplo, n, ap, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_chpcon( uplo, n, afp, ipiv, anorm, rcond, work, info ) + call stdlib${ii}$_chpcon( uplo, n, afp, ipiv, anorm, rcond, work, info ) ! compute the solution vectors x. - call stdlib_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_chptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info ) + call stdlib${ii}$_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_chptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_chprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, & + call stdlib${ii}$_chprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, & rwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcondrzero) ) then eps3 = hnorm*ulp @@ -59764,13 +59766,13 @@ module stdlib_linalg_lapack_c w( k ) = wk if( leftv ) then ! compute left eigenvector. - call stdlib_claein( .false., noinit, n-kl+1, h( kl, kl ), ldh,wk, vl( kl, ks )& + call stdlib${ii}$_claein( .false., noinit, n-kl+1, h( kl, kl ), ldh,wk, vl( kl, ks )& , work, ldwork, rwork, eps3,smlnum, iinfo ) - if( iinfo>0 ) then - info = info + 1 + if( iinfo>0_${ik}$ ) then + info = info + 1_${ik}$ ifaill( ks ) = k else - ifaill( ks ) = 0 + ifaill( ks ) = 0_${ik}$ end if do i = 1, kl - 1 vl( i, ks ) = czero @@ -59778,26 +59780,26 @@ module stdlib_linalg_lapack_c end if if( rightv ) then ! compute right eigenvector. - call stdlib_claein( .true., noinit, kr, h, ldh, wk, vr( 1, ks ),work, ldwork, & + call stdlib${ii}$_claein( .true., noinit, kr, h, ldh, wk, vr( 1_${ik}$, ks ),work, ldwork, & rwork, eps3, smlnum, iinfo ) - if( iinfo>0 ) then - info = info + 1 + if( iinfo>0_${ik}$ ) then + info = info + 1_${ik}$ ifailr( ks ) = k else - ifailr( ks ) = 0 + ifailr( ks ) = 0_${ik}$ end if do i = kr + 1, n vr( i, ks ) = czero end do end if - ks = ks + 1 + ks = ks + 1_${ik}$ end if end do loop_100 return - end subroutine stdlib_chsein + end subroutine stdlib${ii}$_chsein - pure subroutine stdlib_claed0( qsiz, n, d, e, q, ldq, qstore, ldqs, rwork,iwork, info ) + pure subroutine stdlib${ii}$_claed0( qsiz, n, d, e, q, ldq, qstore, ldqs, rwork,iwork, info ) !! Using the divide and conquer method, CLAED0: computes all eigenvalues !! of a symmetric tridiagonal matrix which is one diagonal block of !! those from reducing a dense or band Hermitian matrix and @@ -59807,10 +59809,10 @@ module stdlib_linalg_lapack_c ! -- 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) :: ldq, ldqs, n, qsiz + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldq, ldqs, n, qsiz ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(inout) :: d(*), e(*) real(sp), intent(out) :: rwork(*) complex(sp), intent(inout) :: q(ldq,*) @@ -59819,7 +59821,7 @@ module stdlib_linalg_lapack_c ! warning: n could be as big as qsiz! ! Local Scalars - integer(ilp) :: curlvl, curprb, curr, i, igivcl, igivnm, igivpt, indxq, iperm, iprmpt, & + integer(${ik}$) :: curlvl, curprb, curr, i, igivcl, igivnm, igivpt, indxq, iperm, iprmpt, & iq, iqptr, iwrem, j, k, lgn, ll, matsiz, msd2, smlsiz, smm1, spm1, spm2, submat, & subpbs, tlvls real(sp) :: temp @@ -59827,40 +59829,40 @@ module stdlib_linalg_lapack_c intrinsic :: abs,int,log,max,real ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ ! if( icompq < 0 .or. icompq > 2 ) then ! info = -1 ! else if( ( icompq == 1 ) .and. ( qsiz < max( 0, n ) ) ) ! $ then - if( qsizsmlsiz ) then do j = subpbs, 1, -1 - iwork( 2*j ) = ( iwork( j )+1 ) / 2 - iwork( 2*j-1 ) = iwork( j ) / 2 + iwork( 2_${ik}$*j ) = ( iwork( j )+1_${ik}$ ) / 2_${ik}$ + iwork( 2_${ik}$*j-1 ) = iwork( j ) / 2_${ik}$ end do - tlvls = tlvls + 1 - subpbs = 2*subpbs + tlvls = tlvls + 1_${ik}$ + subpbs = 2_${ik}$*subpbs go to 10 end if do j = 2, subpbs @@ -59868,98 +59870,98 @@ module stdlib_linalg_lapack_c end do ! divide the matrix into subpbs submatrices of size at most smlsiz+1 ! using rank-1 modifications (cuts). - spm1 = subpbs - 1 + spm1 = subpbs - 1_${ik}$ do i = 1, spm1 - submat = iwork( i ) + 1 - smm1 = submat - 1 + submat = iwork( i ) + 1_${ik}$ + smm1 = submat - 1_${ik}$ d( smm1 ) = d( smm1 ) - abs( e( smm1 ) ) d( submat ) = d( submat ) - abs( e( smm1 ) ) end do - indxq = 4*n + 3 + indxq = 4_${ik}$*n + 3_${ik}$ ! set up workspaces for eigenvalues only/accumulate new vectors ! routine temp = log( real( n,KIND=sp) ) / log( two ) - lgn = int( temp,KIND=ilp) - if( 2**lgn0 ) then - info = submat*( n+1 ) + submat + matsiz - 1 + call stdlib${ii}$_clacrm( qsiz, matsiz, q( 1_${ik}$, submat ), ldq, rwork( ll ),matsiz, qstore( & + 1_${ik}$, submat ), ldqs,rwork( iwrem ) ) + iwork( iqptr+curr+1 ) = iwork( iqptr+curr ) + matsiz**2_${ik}$ + curr = curr + 1_${ik}$ + if( info>0_${ik}$ ) then + info = submat*( n+1 ) + submat + matsiz - 1_${ik}$ return end if - k = 1 + k = 1_${ik}$ do j = submat, iwork( i+1 ) iwork( indxq+j ) = k - k = k + 1 + k = k + 1_${ik}$ end do end do ! successively merge eigensystems of adjacent submatrices ! into eigensystem for the corresponding larger matrix. ! while ( subpbs > 1 ) - curlvl = 1 + curlvl = 1_${ik}$ 80 continue - if( subpbs>1 ) then - spm2 = subpbs - 2 + if( subpbs>1_${ik}$ ) then + spm2 = subpbs - 2_${ik}$ do i = 0, spm2, 2 - if( i==0 ) then - submat = 1 - matsiz = iwork( 2 ) - msd2 = iwork( 1 ) - curprb = 0 + if( i==0_${ik}$ ) then + submat = 1_${ik}$ + matsiz = iwork( 2_${ik}$ ) + msd2 = iwork( 1_${ik}$ ) + curprb = 0_${ik}$ else - submat = iwork( i ) + 1 + submat = iwork( i ) + 1_${ik}$ matsiz = iwork( i+2 ) - iwork( i ) - msd2 = matsiz / 2 - curprb = curprb + 1 + msd2 = matsiz / 2_${ik}$ + curprb = curprb + 1_${ik}$ end if ! merge lower order eigensystems (of size msd2 and matsiz - msd2) - ! into an eigensystem of size matsiz. stdlib_claed7 handles the case + ! into an eigensystem of size matsiz. stdlib${ii}$_claed7 handles the case ! when the eigenvectors of a full or band hermitian matrix (which ! was reduced to tridiagonal form) are desired. ! i am free to use q as a valuable working space until loop 150. - call stdlib_claed7( matsiz, msd2, qsiz, tlvls, curlvl, curprb,d( submat ), & - qstore( 1, submat ), ldqs,e( submat+msd2-1 ), iwork( indxq+submat ),rwork( iq ), & + call stdlib${ii}$_claed7( matsiz, msd2, qsiz, tlvls, curlvl, curprb,d( submat ), & + qstore( 1_${ik}$, submat ), ldqs,e( submat+msd2-1 ), iwork( indxq+submat ),rwork( iq ), & iwork( iqptr ), iwork( iprmpt ),iwork( iperm ), iwork( igivpt ),iwork( igivcl ), & - rwork( igivnm ),q( 1, submat ), rwork( iwrem ),iwork( subpbs+1 ), info ) - if( info>0 ) then - info = submat*( n+1 ) + submat + matsiz - 1 + rwork( igivnm ),q( 1_${ik}$, submat ), rwork( iwrem ),iwork( subpbs+1 ), info ) + if( info>0_${ik}$ ) then + info = submat*( n+1 ) + submat + matsiz - 1_${ik}$ return end if - iwork( i / 2+1 ) = iwork( i+2 ) + iwork( i / 2_${ik}$+1 ) = iwork( i+2 ) end do - subpbs = subpbs / 2 - curlvl = curlvl + 1 + subpbs = subpbs / 2_${ik}$ + curlvl = curlvl + 1_${ik}$ go to 80 end if ! end while @@ -59968,14 +59970,14 @@ module stdlib_linalg_lapack_c do i = 1, n j = iwork( indxq+i ) rwork( i ) = d( j ) - call stdlib_ccopy( qsiz, qstore( 1, j ), 1, q( 1, i ), 1 ) + call stdlib${ii}$_ccopy( qsiz, qstore( 1_${ik}$, j ), 1_${ik}$, q( 1_${ik}$, i ), 1_${ik}$ ) end do - call stdlib_scopy( n, rwork, 1, d, 1 ) + call stdlib${ii}$_scopy( n, rwork, 1_${ik}$, d, 1_${ik}$ ) return - end subroutine stdlib_claed0 + end subroutine stdlib${ii}$_claed0 - pure subroutine stdlib_clamswlq( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & + pure subroutine stdlib${ii}$_clamswlq( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & !! CLAMSWLQ overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -59989,8 +59991,8 @@ module stdlib_linalg_lapack_c ! -- 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) :: lda, m, n, k, mb, nb, ldt, lwork, ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, k, mb, nb, ldt, lwork, ldc ! Array Arguments complex(sp), intent(in) :: a(lda,*), t(ldt,*) complex(sp), intent(out) :: work(*) @@ -59998,11 +60000,11 @@ module stdlib_linalg_lapack_c ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran, lquery - integer(ilp) :: i, ii, kk, lw, ctr + integer(${ik}$) :: i, ii, kk, lw, ctr ! External Subroutines ! Executable Statements ! test the input arguments - lquery = lwork<0 + lquery = lwork<0_${ik}$ notran = stdlib_lsame( trans, 'N' ) tran = stdlib_lsame( trans, 'C' ) left = stdlib_lsame( side, 'L' ) @@ -60012,42 +60014,42 @@ module stdlib_linalg_lapack_c else lw = m * mb end if - info = 0 + info = 0_${ik}$ if( .not.left .and. .not.right ) then - info = -1 + info = -1_${ik}$ else if( .not.tran .and. .not.notran ) then - info = -2 - else if( k<0 ) then - info = -5 + info = -2_${ik}$ + else if( k<0_${ik}$ ) then + info = -5_${ik}$ else if( m=max(m,n,k))) then - call stdlib_cgemlqt( side, trans, m, n, k, mb, a, lda,t, ldt, c, ldc, work, info) + call stdlib${ii}$_cgemlqt( side, trans, m, n, k, mb, a, lda,t, ldt, c, ldc, work, info) return end if @@ -60055,85 +60057,85 @@ module stdlib_linalg_lapack_c ! multiply q to the last block of c kk = mod((m-k),(nb-k)) ctr = (m-k)/(nb-k) - if (kk>0) then + if (kk>0_${ik}$) then ii=m-kk+1 - call stdlib_ctpmlqt('L','C',kk , n, k, 0, mb, a(1,ii), lda,t(1,ctr*k+1), ldt, c(& - 1,1), ldc,c(ii,1), ldc, work, info ) + call stdlib${ii}$_ctpmlqt('L','C',kk , n, k, 0_${ik}$, mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1), ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) else ii=m+1 end if do i=ii-(nb-k),nb+1,-(nb-k) ! multiply q to the current block of c (1:m,i:i+nb) - ctr = ctr - 1 - call stdlib_ctpmlqt('L','C',nb-k , n, k, 0,mb, a(1,i), lda,t(1,ctr*k+1),ldt, c(1,& - 1), ldc,c(i,1), ldc, work, info ) + ctr = ctr - 1_${ik}$ + call stdlib${ii}$_ctpmlqt('L','C',nb-k , n, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$,ctr*k+1),ldt, c(1_${ik}$,& + 1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info ) end do ! multiply q to the first block of c (1:m,1:nb) - call stdlib_cgemlqt('L','C',nb , n, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_cgemlqt('L','C',nb , n, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (left.and.notran) then ! multiply q to the first block of c kk = mod((m-k),(nb-k)) ii = m-kk+1 - ctr = 1 - call stdlib_cgemlqt('L','N',nb , n, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + ctr = 1_${ik}$ + call stdlib${ii}$_cgemlqt('L','N',nb , n, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=nb+1,ii-nb+k,(nb-k) ! multiply q to the current block of c (i:i+nb,1:n) - call stdlib_ctpmlqt('L','N',nb-k , n, k, 0,mb, a(1,i), lda,t(1, ctr *k+1), ldt, c(& - 1,1), ldc,c(i,1), ldc, work, info ) - ctr = ctr + 1 + call stdlib${ii}$_ctpmlqt('L','N',nb-k , n, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$, ctr *k+1), ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info ) + ctr = ctr + 1_${ik}$ end do if(ii<=m) then ! multiply q to the last block of c - call stdlib_ctpmlqt('L','N',kk , n, k, 0, mb, a(1,ii), lda,t(1, ctr*k+1), ldt, c(1,& - 1), ldc,c(ii,1), ldc, work, info ) + call stdlib${ii}$_ctpmlqt('L','N',kk , n, k, 0_${ik}$, mb, a(1_${ik}$,ii), lda,t(1_${ik}$, ctr*k+1), ldt, c(1_${ik}$,& + 1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) end if else if(right.and.notran) then ! multiply q to the last block of c kk = mod((n-k),(nb-k)) ctr = (n-k)/(nb-k) - if (kk>0) then + if (kk>0_${ik}$) then ii=n-kk+1 - call stdlib_ctpmlqt('R','N',m , kk, k, 0, mb, a(1, ii), lda,t(1,ctr*k+1), ldt, c(& - 1,1), ldc,c(1,ii), ldc, work, info ) + call stdlib${ii}$_ctpmlqt('R','N',m , kk, k, 0_${ik}$, mb, a(1_${ik}$, ii), lda,t(1_${ik}$,ctr*k+1), ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info ) else ii=n+1 end if do i=ii-(nb-k),nb+1,-(nb-k) ! multiply q to the current block of c (1:m,i:i+mb) - ctr = ctr - 1 - call stdlib_ctpmlqt('R','N', m, nb-k, k, 0, mb, a(1, i), lda,t(1,ctr*k+1), ldt,& - c(1,1), ldc,c(1,i), ldc, work, info ) + ctr = ctr - 1_${ik}$ + call stdlib${ii}$_ctpmlqt('R','N', m, nb-k, k, 0_${ik}$, mb, a(1_${ik}$, i), lda,t(1_${ik}$,ctr*k+1), ldt,& + c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info ) end do ! multiply q to the first block of c (1:m,1:mb) - call stdlib_cgemlqt('R','N',m , nb, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_cgemlqt('R','N',m , nb, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (right.and.tran) then ! multiply q to the first block of c kk = mod((n-k),(nb-k)) ii=n-kk+1 - ctr = 1 - call stdlib_cgemlqt('R','C',m , nb, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + ctr = 1_${ik}$ + call stdlib${ii}$_cgemlqt('R','C',m , nb, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=nb+1,ii-nb+k,(nb-k) ! multiply q to the current block of c (1:m,i:i+mb) - call stdlib_ctpmlqt('R','C',m , nb-k, k, 0,mb, a(1,i), lda,t(1,ctr*k+1), ldt, c(1,& - 1), ldc,c(1,i), ldc, work, info ) - ctr = ctr + 1 + call stdlib${ii}$_ctpmlqt('R','C',m , nb-k, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$,ctr*k+1), ldt, c(1_${ik}$,& + 1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info ) + ctr = ctr + 1_${ik}$ end do if(ii<=n) then ! multiply q to the last block of c - call stdlib_ctpmlqt('R','C',m , kk, k, 0,mb, a(1,ii), lda,t(1,ctr*k+1),ldt, c(1,1),& - ldc,c(1,ii), ldc, work, info ) + call stdlib${ii}$_ctpmlqt('R','C',m , kk, k, 0_${ik}$,mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1),ldt, c(1_${ik}$,1_${ik}$),& + ldc,c(1_${ik}$,ii), ldc, work, info ) end if end if - work(1) = lw + work(1_${ik}$) = lw return - end subroutine stdlib_clamswlq + end subroutine stdlib${ii}$_clamswlq - pure subroutine stdlib_clamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & + pure subroutine stdlib${ii}$_clamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & !! CLAMTSQR overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -60147,8 +60149,8 @@ module stdlib_linalg_lapack_c ! -- 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) :: lda, m, n, k, mb, nb, ldt, lwork, ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, k, mb, nb, ldt, lwork, ldc ! Array Arguments complex(sp), intent(in) :: a(lda,*), t(ldt,*) complex(sp), intent(out) :: work(*) @@ -60156,11 +60158,11 @@ module stdlib_linalg_lapack_c ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran, lquery - integer(ilp) :: i, ii, kk, lw, ctr, q + integer(${ik}$) :: i, ii, kk, lw, ctr, q ! External Subroutines ! Executable Statements ! test the input arguments - lquery = lwork<0 + lquery = lwork<0_${ik}$ notran = stdlib_lsame( trans, 'N' ) tran = stdlib_lsame( trans, 'C' ) left = stdlib_lsame( side, 'L' ) @@ -60172,44 +60174,44 @@ module stdlib_linalg_lapack_c lw = m * nb q = n end if - info = 0 + info = 0_${ik}$ if( .not.left .and. .not.right ) then - info = -1 + info = -1_${ik}$ else if( .not.tran .and. .not.notran ) then - info = -2 + info = -2_${ik}$ else if( m=max(m,n,k))) then - call stdlib_cgemqrt( side, trans, m, n, k, nb, a, lda,t, ldt, c, ldc, work, info) + call stdlib${ii}$_cgemqrt( side, trans, m, n, k, nb, a, lda,t, ldt, c, ldc, work, info) return end if @@ -60217,85 +60219,85 @@ module stdlib_linalg_lapack_c ! multiply q to the last block of c kk = mod((m-k),(mb-k)) ctr = (m-k)/(mb-k) - if (kk>0) then + if (kk>0_${ik}$) then ii=m-kk+1 - call stdlib_ctpmqrt('L','N',kk , n, k, 0, nb, a(ii,1), lda,t(1, ctr*k+1),ldt , c(& - 1,1), ldc,c(ii,1), ldc, work, info ) + call stdlib${ii}$_ctpmqrt('L','N',kk , n, k, 0_${ik}$, nb, a(ii,1_${ik}$), lda,t(1_${ik}$, ctr*k+1),ldt , c(& + 1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) else ii=m+1 end if do i=ii-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) - ctr = ctr - 1 - call stdlib_ctpmqrt('L','N',mb-k , n, k, 0,nb, a(i,1), lda,t(1,ctr*k+1),ldt, c(1,& - 1), ldc,c(i,1), ldc, work, info ) + ctr = ctr - 1_${ik}$ + call stdlib${ii}$_ctpmqrt('L','N',mb-k , n, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$,ctr*k+1),ldt, c(1_${ik}$,& + 1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info ) end do ! multiply q to the first block of c (1:mb,1:n) - call stdlib_cgemqrt('L','N',mb , n, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_cgemqrt('L','N',mb , n, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (left.and.tran) then ! multiply q to the first block of c kk = mod((m-k),(mb-k)) ii=m-kk+1 - ctr = 1 - call stdlib_cgemqrt('L','C',mb , n, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + ctr = 1_${ik}$ + call stdlib${ii}$_cgemqrt('L','C',mb , n, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) - call stdlib_ctpmqrt('L','C',mb-k , n, k, 0,nb, a(i,1), lda,t(1, ctr*k+1),ldt, c(1,& - 1), ldc,c(i,1), ldc, work, info ) - ctr = ctr + 1 + call stdlib${ii}$_ctpmqrt('L','C',mb-k , n, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$, ctr*k+1),ldt, c(1_${ik}$,& + 1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info ) + ctr = ctr + 1_${ik}$ end do if(ii<=m) then ! multiply q to the last block of c - call stdlib_ctpmqrt('L','C',kk , n, k, 0,nb, a(ii,1), lda,t(1,ctr*k+1), ldt, c(1,1)& - , ldc,c(ii,1), ldc, work, info ) + call stdlib${ii}$_ctpmqrt('L','C',kk , n, k, 0_${ik}$,nb, a(ii,1_${ik}$), lda,t(1_${ik}$,ctr*k+1), ldt, c(1_${ik}$,1_${ik}$)& + , ldc,c(ii,1_${ik}$), ldc, work, info ) end if else if(right.and.tran) then ! multiply q to the last block of c kk = mod((n-k),(mb-k)) ctr = (n-k)/(mb-k) - if (kk>0) then + if (kk>0_${ik}$) then ii=n-kk+1 - call stdlib_ctpmqrt('R','C',m , kk, k, 0, nb, a(ii,1), lda,t(1, ctr*k+1), ldt, c(& - 1,1), ldc,c(1,ii), ldc, work, info ) + call stdlib${ii}$_ctpmqrt('R','C',m , kk, k, 0_${ik}$, nb, a(ii,1_${ik}$), lda,t(1_${ik}$, ctr*k+1), ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info ) else ii=n+1 end if do i=ii-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) - ctr = ctr - 1 - call stdlib_ctpmqrt('R','C',m , mb-k, k, 0,nb, a(i,1), lda,t(1,ctr*k+1), ldt, c(& - 1,1), ldc,c(1,i), ldc, work, info ) + ctr = ctr - 1_${ik}$ + call stdlib${ii}$_ctpmqrt('R','C',m , mb-k, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$,ctr*k+1), ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info ) end do ! multiply q to the first block of c (1:m,1:mb) - call stdlib_cgemqrt('R','C',m , mb, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_cgemqrt('R','C',m , mb, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (right.and.notran) then ! multiply q to the first block of c kk = mod((n-k),(mb-k)) ii=n-kk+1 - ctr = 1 - call stdlib_cgemqrt('R','N', m, mb , k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + ctr = 1_${ik}$ + call stdlib${ii}$_cgemqrt('R','N', m, mb , k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) - call stdlib_ctpmqrt('R','N', m, mb-k, k, 0,nb, a(i,1), lda,t(1,ctr*k+1),ldt, c(1,1)& - , ldc,c(1,i), ldc, work, info ) - ctr = ctr + 1 + call stdlib${ii}$_ctpmqrt('R','N', m, mb-k, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$,ctr*k+1),ldt, c(1_${ik}$,1_${ik}$)& + , ldc,c(1_${ik}$,i), ldc, work, info ) + ctr = ctr + 1_${ik}$ end do if(ii<=n) then ! multiply q to the last block of c - call stdlib_ctpmqrt('R','N', m, kk , k, 0,nb, a(ii,1), lda,t(1,ctr*k+1),ldt, c(1,1)& - , ldc,c(1,ii), ldc, work, info ) + call stdlib${ii}$_ctpmqrt('R','N', m, kk , k, 0_${ik}$,nb, a(ii,1_${ik}$), lda,t(1_${ik}$,ctr*k+1),ldt, c(1_${ik}$,1_${ik}$)& + , ldc,c(1_${ik}$,ii), ldc, work, info ) end if end if - work(1) = lw + work(1_${ik}$) = lw return - end subroutine stdlib_clamtsqr + end subroutine stdlib${ii}$_clamtsqr - pure subroutine stdlib_claqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & + pure subroutine stdlib${ii}$_claqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & !! CLAQR2 is identical to CLAQR3 except that it avoids !! recursion by calling CLAHQR instead of CLAQR4. !! Aggressive early deflation: @@ -60312,9 +60314,9 @@ module stdlib_linalg_lapack_c ! -- 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) :: ihiz, iloz, kbot, ktop, ldh, ldt, ldv, ldwv, ldz, lwork, n,& + integer(${ik}$), intent(in) :: ihiz, iloz, kbot, ktop, ldh, ldt, ldv, ldwv, ldz, lwork, n,& nh, nv, nw - integer(ilp), intent(out) :: nd, ns + integer(${ik}$), intent(out) :: nd, ns logical(lk), intent(in) :: wantt, wantz ! Array Arguments complex(sp), intent(inout) :: h(ldh,*), z(ldz,*) @@ -60328,7 +60330,7 @@ module stdlib_linalg_lapack_c ! Local Scalars complex(sp) :: beta, cdum, s, tau real(sp) :: foo, safmax, safmin, smlnum, ulp - integer(ilp) :: i, ifst, ilst, info, infqr, j, jw, kcol, kln, knt, krow, kwtop, ltop, & + integer(${ik}$) :: i, ifst, ilst, info, infqr, j, jw, kcol, kln, knt, krow, kwtop, ltop, & lwk1, lwk2, lwkopt ! Intrinsic Functions intrinsic :: abs,aimag,cmplx,conjg,int,max,min,real @@ -60339,41 +60341,41 @@ module stdlib_linalg_lapack_c ! Executable Statements ! ==== estimate optimal workspace. ==== jw = min( nw, kbot-ktop+1 ) - if( jw<=2 ) then - lwkopt = 1 + if( jw<=2_${ik}$ ) then + lwkopt = 1_${ik}$ else - ! ==== workspace query call to stdlib_cgehrd ==== - call stdlib_cgehrd( jw, 1, jw-1, t, ldt, work, work, -1, info ) - lwk1 = int( work( 1 ),KIND=ilp) - ! ==== workspace query call to stdlib_cunmhr ==== - call stdlib_cunmhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv,work, -1, info ) + ! ==== workspace query call to stdlib${ii}$_cgehrd ==== + call stdlib${ii}$_cgehrd( jw, 1_${ik}$, jw-1, t, ldt, work, work, -1_${ik}$, info ) + lwk1 = int( work( 1_${ik}$ ),KIND=${ik}$) + ! ==== workspace query call to stdlib${ii}$_cunmhr ==== + call stdlib${ii}$_cunmhr( 'R', 'N', jw, jw, 1_${ik}$, jw-1, t, ldt, work, v, ldv,work, -1_${ik}$, info ) - lwk2 = int( work( 1 ),KIND=ilp) + lwk2 = int( work( 1_${ik}$ ),KIND=${ik}$) ! ==== optimal workspace ==== lwkopt = jw + max( lwk1, lwk2 ) end if ! ==== quick return in case of workspace query. ==== - if( lwork==-1 ) then - work( 1 ) = cmplx( lwkopt, 0,KIND=sp) + if( lwork==-1_${ik}$ ) then + work( 1_${ik}$ ) = cmplx( lwkopt, 0_${ik}$,KIND=sp) return end if ! ==== nothing to do ... ! ... for an empty active block ... ==== - ns = 0 - nd = 0 - work( 1 ) = cone + ns = 0_${ik}$ + nd = 0_${ik}$ + work( 1_${ik}$ ) = cone if( ktop>kbot )return ! ... nor for an empty deflation window. ==== if( nw<1 )return ! ==== machine constants ==== - safmin = stdlib_slamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) safmax = rone / safmin - call stdlib_slabad( safmin, safmax ) - ulp = stdlib_slamch( 'PRECISION' ) + call stdlib${ii}$_slabad( safmin, safmax ) + ulp = stdlib${ii}$_slamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=sp) / ulp ) ! ==== setup deflation window ==== jw = min( nw, kbot-ktop+1 ) - kwtop = kbot - jw + 1 + kwtop = kbot - jw + 1_${ik}$ if( kwtop==ktop ) then s = czero else @@ -60382,14 +60384,14 @@ module stdlib_linalg_lapack_c if( kbot==kwtop ) then ! ==== 1-by-1 deflation window: not much to do ==== sh( kwtop ) = h( kwtop, kwtop ) - ns = 1 - nd = 0 + ns = 1_${ik}$ + nd = 0_${ik}$ if( cabs1( s )<=max( smlnum, ulp*cabs1( h( kwtop,kwtop ) ) ) ) then - ns = 0 - nd = 1 + ns = 0_${ik}$ + nd = 1_${ik}$ if( kwtop>ktop )h( kwtop, kwtop-1 ) = czero end if - work( 1 ) = cone + work( 1_${ik}$ ) = cone return end if ! ==== convert to spike-triangular form. (in case of a @@ -60397,31 +60399,31 @@ module stdlib_linalg_lapack_c ! . aggressive early deflation using that part of ! . the deflation window that converged using infqr ! . here and there to keep track.) ==== - call stdlib_clacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) - call stdlib_ccopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 ) - call stdlib_claset( 'A', jw, jw, czero, cone, v, ldv ) - call stdlib_clahqr( .true., .true., jw, 1, jw, t, ldt, sh( kwtop ), 1,jw, v, ldv, & + call stdlib${ii}$_clacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) + call stdlib${ii}$_ccopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2_${ik}$, 1_${ik}$ ), ldt+1 ) + call stdlib${ii}$_claset( 'A', jw, jw, czero, cone, v, ldv ) + call stdlib${ii}$_clahqr( .true., .true., jw, 1_${ik}$, jw, t, ldt, sh( kwtop ), 1_${ik}$,jw, v, ldv, & infqr ) ! ==== deflation detection loop ==== ns = jw - ilst = infqr + 1 + ilst = infqr + 1_${ik}$ do knt = infqr + 1, jw ! ==== small spike tip deflation test ==== foo = cabs1( t( ns, ns ) ) if( foo==rzero )foo = cabs1( s ) - if( cabs1( s )*cabs1( v( 1, ns ) )<=max( smlnum, ulp*foo ) )then + if( cabs1( s )*cabs1( v( 1_${ik}$, ns ) )<=max( smlnum, ulp*foo ) )then ! ==== cone more converged eigenvalue ==== - ns = ns - 1 + ns = ns - 1_${ik}$ else ! ==== cone undeflatable eigenvalue. move it up out of the - ! . way. (stdlib_ctrexc can not fail in this case.) ==== + ! . way. (stdlib${ii}$_ctrexc can not fail in this case.) ==== ifst = ns - call stdlib_ctrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) - ilst = ilst + 1 + call stdlib${ii}$_ctrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) + ilst = ilst + 1_${ik}$ end if end do ! ==== return to hessenberg form ==== - if( ns==0 )s = czero + if( ns==0_${ik}$ )s = czero if( nscabs1( t( ifst, ifst ) ) )ifst = j end do ilst = i - if( ifst/=ilst )call stdlib_ctrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) + if( ifst/=ilst )call stdlib${ii}$_ctrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) end do end if @@ -60440,59 +60442,59 @@ module stdlib_linalg_lapack_c sh( kwtop+i-1 ) = t( i, i ) end do if( ns1 .and. s/=czero ) then + if( ns>1_${ik}$ .and. s/=czero ) then ! ==== reflect spike back into lower triangle ==== - call stdlib_ccopy( ns, v, ldv, work, 1 ) + call stdlib${ii}$_ccopy( ns, v, ldv, work, 1_${ik}$ ) do i = 1, ns work( i ) = conjg( work( i ) ) end do - beta = work( 1 ) - call stdlib_clarfg( ns, beta, work( 2 ), 1, tau ) - work( 1 ) = cone - call stdlib_claset( 'L', jw-2, jw-2, czero, czero, t( 3, 1 ), ldt ) - call stdlib_clarf( 'L', ns, jw, work, 1, conjg( tau ), t, ldt,work( jw+1 ) ) + beta = work( 1_${ik}$ ) + call stdlib${ii}$_clarfg( ns, beta, work( 2_${ik}$ ), 1_${ik}$, tau ) + work( 1_${ik}$ ) = cone + call stdlib${ii}$_claset( 'L', jw-2, jw-2, czero, czero, t( 3_${ik}$, 1_${ik}$ ), ldt ) + call stdlib${ii}$_clarf( 'L', ns, jw, work, 1_${ik}$, conjg( tau ), t, ldt,work( jw+1 ) ) - call stdlib_clarf( 'R', ns, ns, work, 1, tau, t, ldt,work( jw+1 ) ) - call stdlib_clarf( 'R', jw, ns, work, 1, tau, v, ldv,work( jw+1 ) ) - call stdlib_cgehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) + call stdlib${ii}$_clarf( 'R', ns, ns, work, 1_${ik}$, tau, t, ldt,work( jw+1 ) ) + call stdlib${ii}$_clarf( 'R', jw, ns, work, 1_${ik}$, tau, v, ldv,work( jw+1 ) ) + call stdlib${ii}$_cgehrd( jw, 1_${ik}$, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) end if ! ==== copy updated reduced window into place ==== - if( kwtop>1 )h( kwtop, kwtop-1 ) = s*conjg( v( 1, 1 ) ) - call stdlib_clacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) - call stdlib_ccopy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) + if( kwtop>1_${ik}$ )h( kwtop, kwtop-1 ) = s*conjg( v( 1_${ik}$, 1_${ik}$ ) ) + call stdlib${ii}$_clacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) + call stdlib${ii}$_ccopy( jw-1, t( 2_${ik}$, 1_${ik}$ ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) ! ==== accumulate orthogonal matrix in order update ! . h and z, if requested. ==== - if( ns>1 .and. s/=czero )call stdlib_cunmhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, & + if( ns>1_${ik}$ .and. s/=czero )call stdlib${ii}$_cunmhr( 'R', 'N', jw, ns, 1_${ik}$, ns, t, ldt, work, & v, ldv,work( jw+1 ), lwork-jw, info ) ! ==== update vertical slab in h ==== if( wantt ) then - ltop = 1 + ltop = 1_${ik}$ else ltop = ktop end if do krow = ltop, kwtop - 1, nv kln = min( nv, kwtop-krow ) - call stdlib_cgemm( 'N', 'N', kln, jw, jw, cone, h( krow, kwtop ),ldh, v, ldv, & + call stdlib${ii}$_cgemm( 'N', 'N', kln, jw, jw, cone, h( krow, kwtop ),ldh, v, ldv, & czero, wv, ldwv ) - call stdlib_clacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) + call stdlib${ii}$_clacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) end do ! ==== update horizontal slab in h ==== if( wantt ) then do kcol = kbot + 1, n, nh kln = min( nh, n-kcol+1 ) - call stdlib_cgemm( 'C', 'N', jw, kln, jw, cone, v, ldv,h( kwtop, kcol ), ldh, & + call stdlib${ii}$_cgemm( 'C', 'N', jw, kln, jw, cone, v, ldv,h( kwtop, kcol ), ldh, & czero, t, ldt ) - call stdlib_clacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) + call stdlib${ii}$_clacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) end do end if ! ==== update vertical slab in z ==== if( wantz ) then do krow = iloz, ihiz, nv kln = min( nv, ihiz-krow+1 ) - call stdlib_cgemm( 'N', 'N', kln, jw, jw, cone, z( krow, kwtop ),ldz, v, ldv, & + call stdlib${ii}$_cgemm( 'N', 'N', kln, jw, jw, cone, z( krow, kwtop ),ldz, v, ldv, & czero, wv, ldwv ) - call stdlib_clacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) + call stdlib${ii}$_clacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) end do end if end if @@ -60505,11 +60507,11 @@ module stdlib_linalg_lapack_c ! . window.) ==== ns = ns - infqr ! ==== return optimal workspace. ==== - work( 1 ) = cmplx( lwkopt, 0,KIND=sp) - end subroutine stdlib_claqr2 + work( 1_${ik}$ ) = cmplx( lwkopt, 0_${ik}$,KIND=sp) + end subroutine stdlib${ii}$_claqr2 - pure subroutine stdlib_claswlq( m, n, mb, nb, a, lda, t, ldt, work, lwork,info) + pure subroutine stdlib${ii}$_claswlq( m, n, mb, nb, a, lda, t, ldt, work, lwork,info) !! CLASWLQ computes a blocked Tall-Skinny LQ factorization of !! a complex M-by-N matrix A for M <= N: !! A = ( L 0 ) * Q, @@ -60524,76 +60526,76 @@ module stdlib_linalg_lapack_c ! -- 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, mb, nb, lwork, ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, mb, nb, lwork, ldt ! Array Arguments complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: work(*), t(ldt,*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, ii, kk, ctr + integer(${ik}$) :: i, ii, kk, ctr ! External Subroutines intrinsic :: max,min,mod ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 .or. nm .and. m>0 )) then - info = -3 - else if( nb<=0 ) then - info = -4 - else if( ldam .and. m>0_${ik}$ )) then + info = -3_${ik}$ + else if( nb<=0_${ik}$ ) then + info = -4_${ik}$ + else if( lda=n).or.(nb<=m).or.(nb>=n)) then - call stdlib_cgelqt( m, n, mb, a, lda, t, ldt, work, info) + call stdlib${ii}$_cgelqt( m, n, mb, a, lda, t, ldt, work, info) return end if kk = mod((n-m),(nb-m)) ii=n-kk+1 ! compute the lq factorization of the first block a(1:m,1:nb) - call stdlib_cgelqt( m, nb, mb, a(1,1), lda, t, ldt, work, info) - ctr = 1 + call stdlib${ii}$_cgelqt( m, nb, mb, a(1_${ik}$,1_${ik}$), lda, t, ldt, work, info) + ctr = 1_${ik}$ do i = nb+1, ii-nb+m , (nb-m) ! compute the qr factorization of the current block a(1:m,i:i+nb-m) - call stdlib_ctplqt( m, nb-m, 0, mb, a(1,1), lda, a( 1, i ),lda, t(1,ctr*m+1),ldt, & + call stdlib${ii}$_ctplqt( m, nb-m, 0_${ik}$, mb, a(1_${ik}$,1_${ik}$), lda, a( 1_${ik}$, i ),lda, t(1_${ik}$,ctr*m+1),ldt, & work, info ) - ctr = ctr + 1 + ctr = ctr + 1_${ik}$ end do ! compute the qr factorization of the last block a(1:m,ii:n) if (ii<=n) then - call stdlib_ctplqt( m, kk, 0, mb, a(1,1), lda, a( 1, ii ),lda, t(1,ctr*m+1), ldt,& + call stdlib${ii}$_ctplqt( m, kk, 0_${ik}$, mb, a(1_${ik}$,1_${ik}$), lda, a( 1_${ik}$, ii ),lda, t(1_${ik}$,ctr*m+1), ldt,& work, info ) end if - work( 1 ) = m * mb + work( 1_${ik}$ ) = m * mb return - end subroutine stdlib_claswlq + end subroutine stdlib${ii}$_claswlq - pure subroutine stdlib_clatsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) + pure subroutine stdlib${ii}$_clatsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) !! CLATSQR computes a blocked Tall-Skinny QR factorization of !! a complex M-by-N matrix A for M >= N: !! A = Q * ( R ), @@ -60609,76 +60611,76 @@ module stdlib_linalg_lapack_c ! -- 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, mb, nb, ldt, lwork + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, mb, nb, ldt, lwork ! Array Arguments complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: work(*), t(ldt,*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, ii, kk, ctr + integer(${ik}$) :: i, ii, kk, ctr ! External Subroutines intrinsic :: max,min,mod ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 .or. mn .and. n>0 )) then - info = -4 - else if( ldan .and. n>0_${ik}$ )) then + info = -4_${ik}$ + else if( lda=m)) then - call stdlib_cgeqrt( m, n, nb, a, lda, t, ldt, work, info) + call stdlib${ii}$_cgeqrt( m, n, nb, a, lda, t, ldt, work, info) return end if kk = mod((m-n),(mb-n)) ii=m-kk+1 ! compute the qr factorization of the first block a(1:mb,1:n) - call stdlib_cgeqrt( mb, n, nb, a(1,1), lda, t, ldt, work, info ) - ctr = 1 + call stdlib${ii}$_cgeqrt( mb, n, nb, a(1_${ik}$,1_${ik}$), lda, t, ldt, work, info ) + ctr = 1_${ik}$ do i = mb+1, ii-mb+n , (mb-n) ! compute the qr factorization of the current block a(i:i+mb-n,1:n) - call stdlib_ctpqrt( mb-n, n, 0, nb, a(1,1), lda, a( i, 1 ), lda,t(1,ctr * n + 1),& + call stdlib${ii}$_ctpqrt( mb-n, n, 0_${ik}$, nb, a(1_${ik}$,1_${ik}$), lda, a( i, 1_${ik}$ ), lda,t(1_${ik}$,ctr * n + 1_${ik}$),& ldt, work, info ) - ctr = ctr + 1 + ctr = ctr + 1_${ik}$ end do ! compute the qr factorization of the last block a(ii:m,1:n) if (ii<=m) then - call stdlib_ctpqrt( kk, n, 0, nb, a(1,1), lda, a( ii, 1 ), lda,t(1, ctr * n + 1), & + call stdlib${ii}$_ctpqrt( kk, n, 0_${ik}$, nb, a(1_${ik}$,1_${ik}$), lda, a( ii, 1_${ik}$ ), lda,t(1_${ik}$, ctr * n + 1_${ik}$), & ldt,work, info ) end if - work( 1 ) = n*nb + work( 1_${ik}$ ) = n*nb return - end subroutine stdlib_clatsqr + end subroutine stdlib${ii}$_clatsqr - pure subroutine stdlib_cpbsv( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) + pure subroutine stdlib${ii}$_cpbsv( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) !! CPBSV computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N Hermitian positive definite band matrix and X @@ -60695,8 +60697,8 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: ab(ldab,*), b(ldb,*) ! ===================================================================== @@ -60704,35 +60706,35 @@ module stdlib_linalg_lapack_c intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .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( ldab0 ) then + info = -11_${ik}$ + else if( n>0_${ik}$ ) then scond = max( smin, smlnum ) / min( smax, bignum ) else scond = one end if end if - if( info==0 ) then - if( ldb0 )then + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_clanhb( '1', uplo, n, kd, ab, ldab, rwork ) + anorm = stdlib${ii}$_clanhb( '1', uplo, n, kd, ab, ldab, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_cpbcon( uplo, n, kd, afb, ldafb, anorm, rcond, work, rwork,info ) + call stdlib${ii}$_cpbcon( uplo, n, kd, afb, ldafb, anorm, rcond, work, rwork,info ) ! compute the solution matrix x. - call stdlib_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_cpbtrs( uplo, n, kd, nrhs, afb, ldafb, x, ldx, info ) + call stdlib${ii}$_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_cpbtrs( uplo, n, kd, nrhs, afb, ldafb, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_cpbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b, ldb, x,ldx, ferr, berr,& + call stdlib${ii}$_cpbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b, ldb, x,ldx, ferr, berr,& work, rwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -60884,12 +60886,12 @@ module stdlib_linalg_lapack_c end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) - call stdlib_cpotrf( 'L', n1, a( 0 ), n, info ) + call stdlib${ii}$_cpotrf( 'L', n1, a( 0_${ik}$ ), n, info ) if( info>0 )return - call stdlib_ctrsm( 'R', 'L', 'C', 'N', n2, n1, cone, a( 0 ), n,a( n1 ), n ) + call stdlib${ii}$_ctrsm( 'R', 'L', 'C', 'N', n2, n1, cone, a( 0_${ik}$ ), n,a( n1 ), n ) - call stdlib_cherk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n ) - call stdlib_cpotrf( 'U', n2, a( n ), n, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_cherk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n ) + call stdlib${ii}$_cpotrf( 'U', n2, a( n ), n, info ) + if( info>0_${ik}$ )info = info + n1 else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) - call stdlib_cpotrf( 'L', n1, a( n2 ), n, info ) + call stdlib${ii}$_cpotrf( 'L', n1, a( n2 ), n, info ) if( info>0 )return - call stdlib_ctrsm( 'L', 'L', 'N', 'N', n1, n2, cone, a( n2 ), n,a( 0 ), n ) + call stdlib${ii}$_ctrsm( 'L', 'L', 'N', 'N', n1, n2, cone, a( n2 ), n,a( 0_${ik}$ ), n ) - call stdlib_cherk( 'U', 'C', n2, n1, -one, a( 0 ), n, one,a( n1 ), n ) - call stdlib_cpotrf( 'U', n2, a( n1 ), n, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_cherk( 'U', 'C', n2, n1, -one, a( 0_${ik}$ ), n, one,a( n1 ), n ) + call stdlib${ii}$_cpotrf( 'U', n2, a( n1 ), n, info ) + if( info>0_${ik}$ )info = info + n1 end if else ! n is odd and transr = 'c' @@ -60982,26 +60984,26 @@ module stdlib_linalg_lapack_c ! srpa for lower, transpose and n is odd ! t1 -> a(0,0) , t2 -> a(1,0) , s -> a(0,n1) ! t1 -> a(0+0) , t2 -> a(1+0) , s -> a(0+n1*n1); lda=n1 - call stdlib_cpotrf( 'U', n1, a( 0 ), n1, info ) + call stdlib${ii}$_cpotrf( 'U', n1, a( 0_${ik}$ ), n1, info ) if( info>0 )return - call stdlib_ctrsm( 'L', 'U', 'C', 'N', n1, n2, cone, a( 0 ), n1,a( n1*n1 ), & + call stdlib${ii}$_ctrsm( 'L', 'U', 'C', 'N', n1, n2, cone, a( 0_${ik}$ ), n1,a( n1*n1 ), & n1 ) - call stdlib_cherk( 'L', 'C', n2, n1, -one, a( n1*n1 ), n1, one,a( 1 ), n1 ) + call stdlib${ii}$_cherk( 'L', 'C', n2, n1, -one, a( n1*n1 ), n1, one,a( 1_${ik}$ ), n1 ) - call stdlib_cpotrf( 'L', n2, a( 1 ), n1, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_cpotrf( 'L', n2, a( 1_${ik}$ ), n1, info ) + if( info>0_${ik}$ )info = info + n1 else ! srpa for upper, transpose and n is odd ! t1 -> a(0,n1+1), t2 -> a(0,n1), s -> a(0,0) ! t1 -> a(n2*n2), t2 -> a(n1*n2), s -> a(0); lda = n2 - call stdlib_cpotrf( 'U', n1, a( n2*n2 ), n2, info ) + call stdlib${ii}$_cpotrf( 'U', n1, a( n2*n2 ), n2, info ) if( info>0 )return - call stdlib_ctrsm( 'R', 'U', 'N', 'N', n2, n1, cone, a( n2*n2 ),n2, a( 0 ), & + call stdlib${ii}$_ctrsm( 'R', 'U', 'N', 'N', n2, n1, cone, a( n2*n2 ),n2, a( 0_${ik}$ ), & n2 ) - call stdlib_cherk( 'L', 'N', n2, n1, -one, a( 0 ), n2, one,a( n1*n2 ), n2 ) + call stdlib${ii}$_cherk( 'L', 'N', n2, n1, -one, a( 0_${ik}$ ), n2, one,a( n1*n2 ), n2 ) - call stdlib_cpotrf( 'L', n2, a( n1*n2 ), n2, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_cpotrf( 'L', n2, a( n1*n2 ), n2, info ) + if( info>0_${ik}$ )info = info + n1 end if end if else @@ -61012,26 +61014,26 @@ module stdlib_linalg_lapack_c ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) - call stdlib_cpotrf( 'L', k, a( 1 ), n+1, info ) + call stdlib${ii}$_cpotrf( 'L', k, a( 1_${ik}$ ), n+1, info ) if( info>0 )return - call stdlib_ctrsm( 'R', 'L', 'C', 'N', k, k, cone, a( 1 ), n+1,a( k+1 ), n+1 ) + call stdlib${ii}$_ctrsm( 'R', 'L', 'C', 'N', k, k, cone, a( 1_${ik}$ ), n+1,a( k+1 ), n+1 ) - call stdlib_cherk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0 ), n+1 ) + call stdlib${ii}$_cherk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0_${ik}$ ), n+1 ) - call stdlib_cpotrf( 'U', k, a( 0 ), n+1, info ) - if( info>0 )info = info + k + call stdlib${ii}$_cpotrf( 'U', k, a( 0_${ik}$ ), n+1, info ) + if( info>0_${ik}$ )info = info + k else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) - call stdlib_cpotrf( 'L', k, a( k+1 ), n+1, info ) + call stdlib${ii}$_cpotrf( 'L', k, a( k+1 ), n+1, info ) if( info>0 )return - call stdlib_ctrsm( 'L', 'L', 'N', 'N', k, k, cone, a( k+1 ),n+1, a( 0 ), n+1 ) + call stdlib${ii}$_ctrsm( 'L', 'L', 'N', 'N', k, k, cone, a( k+1 ),n+1, a( 0_${ik}$ ), n+1 ) - call stdlib_cherk( 'U', 'C', k, k, -one, a( 0 ), n+1, one,a( k ), n+1 ) + call stdlib${ii}$_cherk( 'U', 'C', k, k, -one, a( 0_${ik}$ ), n+1, one,a( k ), n+1 ) - call stdlib_cpotrf( 'U', k, a( k ), n+1, info ) - if( info>0 )info = info + k + call stdlib${ii}$_cpotrf( 'U', k, a( k ), n+1, info ) + if( info>0_${ik}$ )info = info + k end if else ! n is even and transr = 'c' @@ -61039,33 +61041,33 @@ module stdlib_linalg_lapack_c ! srpa for lower, transpose and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1) ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k - call stdlib_cpotrf( 'U', k, a( 0+k ), k, info ) + call stdlib${ii}$_cpotrf( 'U', k, a( 0_${ik}$+k ), k, info ) if( info>0 )return - call stdlib_ctrsm( 'L', 'U', 'C', 'N', k, k, cone, a( k ), n1,a( k*( k+1 ) ), & + call stdlib${ii}$_ctrsm( 'L', 'U', 'C', 'N', k, k, cone, a( k ), n1,a( k*( k+1 ) ), & k ) - call stdlib_cherk( 'L', 'C', k, k, -one, a( k*( k+1 ) ), k, one,a( 0 ), k ) + call stdlib${ii}$_cherk( 'L', 'C', k, k, -one, a( k*( k+1 ) ), k, one,a( 0_${ik}$ ), k ) - call stdlib_cpotrf( 'L', k, a( 0 ), k, info ) - if( info>0 )info = info + k + call stdlib${ii}$_cpotrf( 'L', k, a( 0_${ik}$ ), k, info ) + if( info>0_${ik}$ )info = info + k else ! srpa for upper, transpose and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0) ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k - call stdlib_cpotrf( 'U', k, a( k*( k+1 ) ), k, info ) + call stdlib${ii}$_cpotrf( 'U', k, a( k*( k+1 ) ), k, info ) if( info>0 )return - call stdlib_ctrsm( 'R', 'U', 'N', 'N', k, k, cone,a( k*( k+1 ) ), k, a( 0 ), & + call stdlib${ii}$_ctrsm( 'R', 'U', 'N', 'N', k, k, cone,a( k*( k+1 ) ), k, a( 0_${ik}$ ), & k ) - call stdlib_cherk( 'L', 'N', k, k, -one, a( 0 ), k, one,a( k*k ), k ) - call stdlib_cpotrf( 'L', k, a( k*k ), k, info ) - if( info>0 )info = info + k + call stdlib${ii}$_cherk( 'L', 'N', k, k, -one, a( 0_${ik}$ ), k, one,a( k*k ), k ) + call stdlib${ii}$_cpotrf( 'L', k, a( k*k ), k, info ) + if( info>0_${ik}$ )info = info + k end if end if end if return - end subroutine stdlib_cpftrf + end subroutine stdlib${ii}$_cpftrf - pure subroutine stdlib_cpftri( transr, uplo, n, a, info ) + pure subroutine stdlib${ii}$_cpftri( transr, uplo, n, a, info ) !! CPFTRI computes the inverse of a complex Hermitian positive definite !! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H !! computed by CPFTRF. @@ -61074,53 +61076,53 @@ module stdlib_linalg_lapack_c ! -- 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 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n ! Array Arguments - complex(sp), intent(inout) :: a(0:*) + complex(sp), intent(inout) :: a(0_${ik}$:*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, nisodd, normaltransr - integer(ilp) :: n1, n2, k + integer(${ik}$) :: n1, n2, k ! Intrinsic Functions intrinsic :: 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, 'C' ) ) 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 + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'CPFTRI', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'CPFTRI', -info ) return end if ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. - call stdlib_ctftri( transr, uplo, 'N', n, a, info ) + call stdlib${ii}$_ctftri( transr, uplo, 'N', n, a, info ) if( info>0 )return ! if n is odd, set nisodd = .true. ! if n is even, set k = n/2 and nisodd = .false. - if( mod( n, 2 )==0 ) then - k = n / 2 + if( mod( n, 2_${ik}$ )==0_${ik}$ ) then + k = n / 2_${ik}$ nisodd = .false. else nisodd = .true. end if ! set n1 and n2 depending on lower if( lower ) then - n2 = n / 2 + n2 = n / 2_${ik}$ n1 = n - n2 else - n1 = n / 2 + n1 = n / 2_${ik}$ n2 = n - n1 end if ! start execution of triangular matrix multiply: inv(u)*inv(u)^c or @@ -61133,41 +61135,41 @@ module stdlib_linalg_lapack_c ! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) ) ! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) - call stdlib_clauum( 'L', n1, a( 0 ), n, info ) - call stdlib_cherk( 'L', 'C', n1, n2, one, a( n1 ), n, one,a( 0 ), n ) - call stdlib_ctrmm( 'L', 'U', 'N', 'N', n2, n1, cone, a( n ), n,a( n1 ), n ) + call stdlib${ii}$_clauum( 'L', n1, a( 0_${ik}$ ), n, info ) + call stdlib${ii}$_cherk( 'L', 'C', n1, n2, one, a( n1 ), n, one,a( 0_${ik}$ ), n ) + call stdlib${ii}$_ctrmm( 'L', 'U', 'N', 'N', n2, n1, cone, a( n ), n,a( n1 ), n ) - call stdlib_clauum( 'U', n2, a( n ), n, info ) + call stdlib${ii}$_clauum( 'U', n2, a( n ), n, info ) else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) - call stdlib_clauum( 'L', n1, a( n2 ), n, info ) - call stdlib_cherk( 'L', 'N', n1, n2, one, a( 0 ), n, one,a( n2 ), n ) - call stdlib_ctrmm( 'R', 'U', 'C', 'N', n1, n2, cone, a( n1 ), n,a( 0 ), n ) + call stdlib${ii}$_clauum( 'L', n1, a( n2 ), n, info ) + call stdlib${ii}$_cherk( 'L', 'N', n1, n2, one, a( 0_${ik}$ ), n, one,a( n2 ), n ) + call stdlib${ii}$_ctrmm( 'R', 'U', 'C', 'N', n1, n2, cone, a( n1 ), n,a( 0_${ik}$ ), n ) - call stdlib_clauum( 'U', n2, a( n1 ), n, info ) + call stdlib${ii}$_clauum( 'U', n2, a( n1 ), n, info ) end if else ! n is odd and transr = 'c' if( lower ) then ! srpa for lower, transpose, and n is odd ! t1 -> a(0), t2 -> a(1), s -> a(0+n1*n1) - call stdlib_clauum( 'U', n1, a( 0 ), n1, info ) - call stdlib_cherk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0 ), n1 ) + call stdlib${ii}$_clauum( 'U', n1, a( 0_${ik}$ ), n1, info ) + call stdlib${ii}$_cherk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0_${ik}$ ), n1 ) - call stdlib_ctrmm( 'R', 'L', 'N', 'N', n1, n2, cone, a( 1 ), n1,a( n1*n1 ), & + call stdlib${ii}$_ctrmm( 'R', 'L', 'N', 'N', n1, n2, cone, a( 1_${ik}$ ), n1,a( n1*n1 ), & n1 ) - call stdlib_clauum( 'L', n2, a( 1 ), n1, info ) + call stdlib${ii}$_clauum( 'L', n2, a( 1_${ik}$ ), n1, info ) else ! srpa for upper, transpose, and n is odd ! t1 -> a(0+n2*n2), t2 -> a(0+n1*n2), s -> a(0) - call stdlib_clauum( 'U', n1, a( n2*n2 ), n2, info ) - call stdlib_cherk( 'U', 'C', n1, n2, one, a( 0 ), n2, one,a( n2*n2 ), n2 ) + call stdlib${ii}$_clauum( 'U', n1, a( n2*n2 ), n2, info ) + call stdlib${ii}$_cherk( 'U', 'C', n1, n2, one, a( 0_${ik}$ ), n2, one,a( n2*n2 ), n2 ) - call stdlib_ctrmm( 'L', 'L', 'C', 'N', n2, n1, cone, a( n1*n2 ),n2, a( 0 ), & + call stdlib${ii}$_ctrmm( 'L', 'L', 'C', 'N', n2, n1, cone, a( n1*n2 ),n2, a( 0_${ik}$ ), & n2 ) - call stdlib_clauum( 'L', n2, a( n1*n2 ), n2, info ) + call stdlib${ii}$_clauum( 'L', n2, a( n1*n2 ), n2, info ) end if end if else @@ -61178,22 +61180,22 @@ module stdlib_linalg_lapack_c ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) - call stdlib_clauum( 'L', k, a( 1 ), n+1, info ) - call stdlib_cherk( 'L', 'C', k, k, one, a( k+1 ), n+1, one,a( 1 ), n+1 ) + call stdlib${ii}$_clauum( 'L', k, a( 1_${ik}$ ), n+1, info ) + call stdlib${ii}$_cherk( 'L', 'C', k, k, one, a( k+1 ), n+1, one,a( 1_${ik}$ ), n+1 ) - call stdlib_ctrmm( 'L', 'U', 'N', 'N', k, k, cone, a( 0 ), n+1,a( k+1 ), n+1 ) + call stdlib${ii}$_ctrmm( 'L', 'U', 'N', 'N', k, k, cone, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 ) - call stdlib_clauum( 'U', k, a( 0 ), n+1, info ) + call stdlib${ii}$_clauum( 'U', k, a( 0_${ik}$ ), n+1, info ) else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) - call stdlib_clauum( 'L', k, a( k+1 ), n+1, info ) - call stdlib_cherk( 'L', 'N', k, k, one, a( 0 ), n+1, one,a( k+1 ), n+1 ) + call stdlib${ii}$_clauum( 'L', k, a( k+1 ), n+1, info ) + call stdlib${ii}$_cherk( 'L', 'N', k, k, one, a( 0_${ik}$ ), n+1, one,a( k+1 ), n+1 ) - call stdlib_ctrmm( 'R', 'U', 'C', 'N', k, k, cone, a( k ), n+1,a( 0 ), n+1 ) + call stdlib${ii}$_ctrmm( 'R', 'U', 'C', 'N', k, k, cone, a( k ), n+1,a( 0_${ik}$ ), n+1 ) - call stdlib_clauum( 'U', k, a( k ), n+1, info ) + call stdlib${ii}$_clauum( 'U', k, a( k ), n+1, info ) end if else ! n is even and transr = 'c' @@ -61201,30 +61203,30 @@ module stdlib_linalg_lapack_c ! srpa for lower, transpose, and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1), ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k - call stdlib_clauum( 'U', k, a( k ), k, info ) - call stdlib_cherk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k ) + call stdlib${ii}$_clauum( 'U', k, a( k ), k, info ) + call stdlib${ii}$_cherk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k ) - call stdlib_ctrmm( 'R', 'L', 'N', 'N', k, k, cone, a( 0 ), k,a( k*( k+1 ) ), & + call stdlib${ii}$_ctrmm( 'R', 'L', 'N', 'N', k, k, cone, a( 0_${ik}$ ), k,a( k*( k+1 ) ), & k ) - call stdlib_clauum( 'L', k, a( 0 ), k, info ) + call stdlib${ii}$_clauum( 'L', k, a( 0_${ik}$ ), k, info ) else ! srpa for upper, transpose, and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0), ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k - call stdlib_clauum( 'U', k, a( k*( k+1 ) ), k, info ) - call stdlib_cherk( 'U', 'C', k, k, one, a( 0 ), k, one,a( k*( k+1 ) ), k ) + call stdlib${ii}$_clauum( 'U', k, a( k*( k+1 ) ), k, info ) + call stdlib${ii}$_cherk( 'U', 'C', k, k, one, a( 0_${ik}$ ), k, one,a( k*( k+1 ) ), k ) - call stdlib_ctrmm( 'L', 'L', 'C', 'N', k, k, cone, a( k*k ), k,a( 0 ), k ) + call stdlib${ii}$_ctrmm( 'L', 'L', 'C', 'N', k, k, cone, a( k*k ), k,a( 0_${ik}$ ), k ) - call stdlib_clauum( 'L', k, a( k*k ), k, info ) + call stdlib${ii}$_clauum( 'L', k, a( k*k ), k, info ) end if end if end if return - end subroutine stdlib_cpftri + end subroutine stdlib${ii}$_cpftri - pure subroutine stdlib_cposv( uplo, n, nrhs, a, lda, b, ldb, info ) + pure subroutine stdlib${ii}$_cposv( uplo, n, nrhs, a, lda, b, ldb, info ) !! CPOSV computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N Hermitian positive definite matrix and X and B @@ -61240,8 +61242,8 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: a(lda,*), b(ldb,*) ! ===================================================================== @@ -61249,33 +61251,33 @@ module stdlib_linalg_lapack_c intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .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 + info = -10_${ik}$ + else if( n>0_${ik}$ ) then scond = max( smin, smlnum ) / min( smax, bignum ) else scond = one end if end if - if( info==0 ) then - if( ldb0 )then + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_clanhe( '1', uplo, n, a, lda, rwork ) + anorm = stdlib${ii}$_clanhe( '1', uplo, n, a, lda, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_cpocon( uplo, n, af, ldaf, anorm, rcond, work, rwork, info ) + call stdlib${ii}$_cpocon( uplo, n, af, ldaf, anorm, rcond, work, rwork, info ) ! compute the solution matrix x. - call stdlib_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_cpotrs( uplo, n, nrhs, af, ldaf, x, ldx, info ) + call stdlib${ii}$_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_cpotrs( uplo, n, nrhs, af, ldaf, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_cporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x, ldx,ferr, berr, work, & + call stdlib${ii}$_cporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x, ldx,ferr, berr, work, & rwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -61414,12 +61416,12 @@ module stdlib_linalg_lapack_c end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcondeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_cpttrs( uplo, n, 1, df, ef, work, n, info ) - call stdlib_caxpy( n, cmplx( one,KIND=sp), work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_cpttrs( uplo, n, 1_${ik}$, df, ef, work, n, info ) + call stdlib${ii}$_caxpy( n, cmplx( one,KIND=sp), work, 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 @@ -61606,7 +61608,7 @@ module stdlib_linalg_lapack_c rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - ix = stdlib_isamax( n, rwork, 1 ) + ix = stdlib${ii}$_isamax( n, rwork, 1_${ik}$ ) ferr( j ) = rwork( ix ) ! estimate the norm of inv(a). ! solve m(a) * x = e, where m(a) = (m(i,j)) is given by @@ -61614,7 +61616,7 @@ module stdlib_linalg_lapack_c ! m(i,j) = -abs(a(i,j)), i .ne. j, ! and e = [ 1, 1, ..., 1 ]**t. note m(a) = m(l)*d*m(l)**h. ! solve m(l) * x = e. - rwork( 1 ) = one + rwork( 1_${ik}$ ) = one do i = 2, n rwork( i ) = one + rwork( i-1 )*abs( ef( i-1 ) ) end do @@ -61624,7 +61626,7 @@ module stdlib_linalg_lapack_c rwork( i ) = rwork( i ) / df( i ) +rwork( i+1 )*abs( ef( i ) ) end do ! compute norm(inv(a)) = max(x(i)), 1<=i<=n. - ix = stdlib_isamax( n, rwork, 1 ) + ix = stdlib${ii}$_isamax( n, rwork, 1_${ik}$ ) ferr( j ) = ferr( j )*abs( rwork( ix ) ) ! normalize error. lstres = zero @@ -61634,10 +61636,10 @@ module stdlib_linalg_lapack_c if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_100 return - end subroutine stdlib_cptrfs + end subroutine stdlib${ii}$_cptrfs - pure subroutine stdlib_cptsv( n, nrhs, d, e, b, ldb, info ) + pure subroutine stdlib${ii}$_cptsv( n, nrhs, d, e, b, ldb, info ) !! CPTSV computes the solution to a complex system of linear equations !! A*X = B, where A is an N-by-N Hermitian positive definite tridiagonal !! matrix, and X and B are N-by-NRHS matrices. @@ -61647,8 +61649,8 @@ module stdlib_linalg_lapack_c ! -- 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) :: ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments real(sp), intent(inout) :: d(*) complex(sp), intent(inout) :: b(ldb,*), e(*) @@ -61657,29 +61659,29 @@ module stdlib_linalg_lapack_c intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 - if( n<0 ) then - info = -1 - else if( nrhs<0 ) then - info = -2 - else if( ldb1 )call stdlib_ccopy( n-1, e, 1, ef, 1 ) - call stdlib_cpttrf( n, df, ef, info ) + call stdlib${ii}$_scopy( n, d, 1_${ik}$, df, 1_${ik}$ ) + if( n>1_${ik}$ )call stdlib${ii}$_ccopy( n-1, e, 1_${ik}$, ef, 1_${ik}$ ) + call stdlib${ii}$_cpttrf( n, df, ef, info ) ! return if info is non-zero. - if( info>0 )then + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_clanht( '1', n, d, e ) + anorm = stdlib${ii}$_clanht( '1', n, d, e ) ! compute the reciprocal of the condition number of a. - call stdlib_cptcon( n, df, ef, anorm, rcond, rwork, info ) + call stdlib${ii}$_cptcon( n, df, ef, anorm, rcond, rwork, info ) ! compute the solution vectors x. - call stdlib_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_cpttrs( 'LOWER', n, nrhs, df, ef, x, ldx, info ) + call stdlib${ii}$_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_cpttrs( 'LOWER', n, nrhs, df, ef, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_cptrfs( 'LOWER', n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr,berr, work, & + call stdlib${ii}$_cptrfs( 'LOWER', n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr,berr, work, & rwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond0 .and. ldz0_${ik}$ .and. ldztiny ) then - finish = finish + 1 + finish = finish + 1_${ik}$ go to 40 end if end if ! (sub) problem determined. compute its size and solve it. - m = finish - start + 1 + m = finish - start + 1_${ik}$ if( m>smlsiz ) then ! scale. - orgnrm = stdlib_slanst( 'M', m, d( start ), e( start ) ) - call stdlib_slascl( 'G', 0, 0, orgnrm, one, m, 1, d( start ), m,info ) - call stdlib_slascl( 'G', 0, 0, orgnrm, one, m-1, 1, e( start ),m-1, info ) + orgnrm = stdlib${ii}$_slanst( 'M', m, d( start ), e( start ) ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, m, 1_${ik}$, d( start ), m,info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, m-1, 1_${ik}$, e( start ),m-1, info ) - call stdlib_claed0( n, m, d( start ), e( start ), z( 1, start ),ldz, work, n, & + call stdlib${ii}$_claed0( n, m, d( start ), e( start ), z( 1_${ik}$, start ),ldz, work, n, & rwork, iwork, info ) - if( info>0 ) then + if( info>0_${ik}$ ) then info = ( info / ( m+1 )+start-1 )*( n+1 ) +mod( info, ( m+1 ) ) + start - & - 1 + 1_${ik}$ go to 70 end if ! scale back. - call stdlib_slascl( 'G', 0, 0, one, orgnrm, m, 1, d( start ), m,info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, m, 1_${ik}$, d( start ), m,info ) else - call stdlib_ssteqr( 'I', m, d( start ), e( start ), rwork, m,rwork( m*m+1 ), & + call stdlib${ii}$_ssteqr( 'I', m, d( start ), e( start ), rwork, m,rwork( m*m+1 ), & info ) - call stdlib_clacrm( n, m, z( 1, start ), ldz, rwork, m, work, n,rwork( m*m+1 )& + call stdlib${ii}$_clacrm( n, m, z( 1_${ik}$, start ), ldz, rwork, m, work, n,rwork( m*m+1 )& ) - call stdlib_clacpy( 'A', n, m, work, n, z( 1, start ), ldz ) - if( info>0 ) then + call stdlib${ii}$_clacpy( 'A', n, m, work, n, z( 1_${ik}$, start ), ldz ) + if( info>0_${ik}$ ) then info = start*( n+1 ) + finish go to 70 end if end if - start = finish + 1 + start = finish + 1_${ik}$ go to 30 end if ! endwhile ! use selection sort to minimize swaps of eigenvectors do ii = 2, n - i = ii - 1 + i = ii - 1_${ik}$ k = i p = d( i ) do j = ii, n @@ -61958,19 +61960,19 @@ module stdlib_linalg_lapack_c if( k/=i ) then d( k ) = d( i ) d( i ) = p - call stdlib_cswap( n, z( 1, i ), 1, z( 1, k ), 1 ) + call stdlib${ii}$_cswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, k ), 1_${ik}$ ) end if end do end if 70 continue - work( 1 ) = lwmin - rwork( 1 ) = lrwmin - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = lwmin + rwork( 1_${ik}$ ) = lrwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_cstedc + end subroutine stdlib${ii}$_cstedc - pure subroutine stdlib_cstegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, & + pure subroutine stdlib${ii}$_cstegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, & !! CSTEGR computes selected eigenvalues and, optionally, eigenvectors !! of a real symmetric tridiagonal matrix T. Any such unreduced matrix has !! a well defined set of pairwise different real eigenvalues, the corresponding @@ -61993,11 +61995,11 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range - integer(ilp), intent(in) :: il, iu, ldz, liwork, lwork, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, iu, ldz, liwork, lwork, n + integer(${ik}$), intent(out) :: info, m real(sp), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: isuppz(*), iwork(*) + integer(${ik}$), intent(out) :: isuppz(*), iwork(*) real(sp), intent(inout) :: d(*), e(*) real(sp), intent(out) :: w(*), work(*) complex(sp), intent(out) :: z(ldz,*) @@ -62005,14 +62007,14 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: tryrac ! Executable Statements - info = 0 + info = 0_${ik}$ tryrac = .false. - call stdlib_cstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, n, isuppz, & + call stdlib${ii}$_cstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, n, isuppz, & tryrac, work, lwork,iwork, liwork, info ) - end subroutine stdlib_cstegr + end subroutine stdlib${ii}$_cstegr - pure subroutine stdlib_ctgsen( ijob, wantq, wantz, select, n, a, lda, b, ldb,alpha, beta, q, & + pure subroutine stdlib${ii}$_ctgsen( ijob, wantq, wantz, select, n, a, lda, b, ldb,alpha, beta, q, & !! CTGSEN reorders the generalized Schur decomposition of a complex !! matrix pair (A, B) (in terms of an unitary equivalence trans- !! formation Q**H * (A, B) * Z), so that a selected cluster of eigenvalues @@ -62037,94 +62039,94 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: wantq, wantz - integer(ilp), intent(in) :: ijob, lda, ldb, ldq, ldz, liwork, lwork, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: ijob, lda, ldb, ldq, ldz, liwork, lwork, n + integer(${ik}$), intent(out) :: info, m real(sp), intent(out) :: pl, pr ! Array Arguments logical(lk), intent(in) :: select(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(out) :: dif(*) complex(sp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) complex(sp), intent(out) :: alpha(*), beta(*), work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: idifjb = 3 + integer(${ik}$), parameter :: idifjb = 3_${ik}$ ! Local Scalars logical(lk) :: lquery, swap, wantd, wantd1, wantd2, wantp - integer(ilp) :: i, ierr, ijb, k, kase, ks, liwmin, lwmin, mn2, n1, n2 + integer(${ik}$) :: i, ierr, ijb, k, kase, ks, liwmin, lwmin, mn2, n1, n2 real(sp) :: dscale, dsum, rdscal, safmin complex(sp) :: temp1, temp2 ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,cmplx,conjg,max,sqrt ! Executable Statements ! decode and test the input parameters - info = 0 - lquery = ( lwork==-1 .or. liwork==-1 ) - if( ijob<0 .or. ijob>5 ) then - info = -1 - else if( n<0 ) then - info = -5 - else if( lda=4 - wantd1 = ijob==2 .or. ijob==4 - wantd2 = ijob==3 .or. ijob==5 + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) + if( ijob<0_${ik}$ .or. ijob>5_${ik}$ ) then + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -5_${ik}$ + else if( lda=4_${ik}$ + wantd1 = ijob==2_${ik}$ .or. ijob==4_${ik}$ + wantd2 = ijob==3_${ik}$ .or. ijob==5_${ik}$ wantd = wantd1 .or. wantd2 ! set m to the dimension of the specified pair of deflating ! subspaces. - m = 0 - if( .not.lquery .or. ijob/=0 ) then + m = 0_${ik}$ + if( .not.lquery .or. ijob/=0_${ik}$ ) then do k = 1, n alpha( k ) = a( k, k ) beta( k ) = b( k, k ) if( k0 ) then + if( ierr>0_${ik}$ ) then ! swap is rejected: exit. - info = 1 + info = 1_${ik}$ if( wantp ) then pl = zero pr = zero end if if( wantd ) then - dif( 1 ) = zero - dif( 2 ) = zero + dif( 1_${ik}$ ) = zero + dif( 2_${ik}$ ) = zero end if go to 70 end if @@ -62174,18 +62176,18 @@ module stdlib_linalg_lapack_c ! b11 * r - l * b22 = b12 n1 = m n2 = n - m - i = n1 + 1 - call stdlib_clacpy( 'FULL', n1, n2, a( 1, i ), lda, work, n1 ) - call stdlib_clacpy( 'FULL', n1, n2, b( 1, i ), ldb, work( n1*n2+1 ),n1 ) - ijb = 0 - call stdlib_ctgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b( i,& - i ), ldb, work( n1*n2+1 ), n1,dscale, dif( 1 ), work( n1*n2*2+1 ),lwork-2*n1*n2, & + i = n1 + 1_${ik}$ + call stdlib${ii}$_clacpy( 'FULL', n1, n2, a( 1_${ik}$, i ), lda, work, n1 ) + call stdlib${ii}$_clacpy( 'FULL', n1, n2, b( 1_${ik}$, i ), ldb, work( n1*n2+1 ),n1 ) + ijb = 0_${ik}$ + call stdlib${ii}$_ctgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b( i,& + i ), ldb, work( n1*n2+1 ), n1,dscale, dif( 1_${ik}$ ), work( n1*n2*2_${ik}$+1 ),lwork-2*n1*n2, & iwork, ierr ) ! estimate the reciprocal of norms of "projections" onto ! left and right eigenspaces rdscal = zero dsum = one - call stdlib_classq( n1*n2, work, 1, rdscal, dsum ) + call stdlib${ii}$_classq( n1*n2, work, 1_${ik}$, rdscal, dsum ) pl = rdscal*sqrt( dsum ) if( pl==zero ) then pl = one @@ -62194,7 +62196,7 @@ module stdlib_linalg_lapack_c end if rdscal = zero dsum = one - call stdlib_classq( n1*n2, work( n1*n2+1 ), 1, rdscal, dsum ) + call stdlib${ii}$_classq( n1*n2, work( n1*n2+1 ), 1_${ik}$, rdscal, dsum ) pr = rdscal*sqrt( dsum ) if( pr==zero ) then pr = one @@ -62207,63 +62209,63 @@ module stdlib_linalg_lapack_c if( wantd1 ) then n1 = m n2 = n - m - i = n1 + 1 + i = n1 + 1_${ik}$ ijb = idifjb ! frobenius norm-based difu estimate. - call stdlib_ctgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b(& - i, i ), ldb, work( n1*n2+1 ),n1, dscale, dif( 1 ), work( n1*n2*2+1 ),lwork-& - 2*n1*n2, iwork, ierr ) + call stdlib${ii}$_ctgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b(& + i, i ), ldb, work( n1*n2+1 ),n1, dscale, dif( 1_${ik}$ ), work( n1*n2*2_${ik}$+1 ),lwork-& + 2_${ik}$*n1*n2, iwork, ierr ) ! frobenius norm-based difl estimate. - call stdlib_ctgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda, work,n2, b( i, i ),& - ldb, b, ldb, work( n1*n2+1 ),n2, dscale, dif( 2 ), work( n1*n2*2+1 ),lwork-& - 2*n1*n2, iwork, ierr ) + call stdlib${ii}$_ctgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda, work,n2, b( i, i ),& + ldb, b, ldb, work( n1*n2+1 ),n2, dscale, dif( 2_${ik}$ ), work( n1*n2*2_${ik}$+1 ),lwork-& + 2_${ik}$*n1*n2, iwork, ierr ) else ! compute 1-norm-based estimates of difu and difl using - ! reversed communication with stdlib_clacn2. in each step a + ! reversed communication with stdlib${ii}$_clacn2. in each step a ! generalized sylvester equation or a transposed variant ! is solved. - kase = 0 + kase = 0_${ik}$ n1 = m n2 = n - m - i = n1 + 1 - ijb = 0 - mn2 = 2*n1*n2 + i = n1 + 1_${ik}$ + ijb = 0_${ik}$ + mn2 = 2_${ik}$*n1*n2 ! 1-norm-based estimate of difu. 40 continue - call stdlib_clacn2( mn2, work( mn2+1 ), work, dif( 1 ), kase,isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_clacn2( mn2, work( mn2+1 ), work, dif( 1_${ik}$ ), kase,isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! solve generalized sylvester equation - call stdlib_ctgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & - ldb, b( i, i ), ldb,work( n1*n2+1 ), n1, dscale, dif( 1 ),work( n1*n2*2+1 )& + call stdlib${ii}$_ctgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & + ldb, b( i, i ), ldb,work( n1*n2+1 ), n1, dscale, dif( 1_${ik}$ ),work( n1*n2*2_${ik}$+1 )& , lwork-2*n1*n2, iwork,ierr ) else ! solve the transposed variant. - call stdlib_ctgsyl( 'C', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & - ldb, b( i, i ), ldb,work( n1*n2+1 ), n1, dscale, dif( 1 ),work( n1*n2*2+1 )& + call stdlib${ii}$_ctgsyl( 'C', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & + ldb, b( i, i ), ldb,work( n1*n2+1 ), n1, dscale, dif( 1_${ik}$ ),work( n1*n2*2_${ik}$+1 )& , lwork-2*n1*n2, iwork,ierr ) end if go to 40 end if - dif( 1 ) = dscale / dif( 1 ) + dif( 1_${ik}$ ) = dscale / dif( 1_${ik}$ ) ! 1-norm-based estimate of difl. 50 continue - call stdlib_clacn2( mn2, work( mn2+1 ), work, dif( 2 ), kase,isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_clacn2( mn2, work( mn2+1 ), work, dif( 2_${ik}$ ), kase,isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! solve generalized sylvester equation - call stdlib_ctgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b( & - i, i ), ldb, b, ldb,work( n1*n2+1 ), n2, dscale, dif( 2 ),work( n1*n2*2+1 )& + call stdlib${ii}$_ctgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b( & + i, i ), ldb, b, ldb,work( n1*n2+1 ), n2, dscale, dif( 2_${ik}$ ),work( n1*n2*2_${ik}$+1 )& , lwork-2*n1*n2, iwork,ierr ) else ! solve the transposed variant. - call stdlib_ctgsyl( 'C', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b, & - ldb, b( i, i ), ldb,work( n1*n2+1 ), n2, dscale, dif( 2 ),work( n1*n2*2+1 )& + call stdlib${ii}$_ctgsyl( 'C', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b, & + ldb, b( i, i ), ldb,work( n1*n2+1 ), n2, dscale, dif( 2_${ik}$ ),work( n1*n2*2_${ik}$+1 )& , lwork-2*n1*n2, iwork,ierr ) end if go to 50 end if - dif( 2 ) = dscale / dif( 2 ) + dif( 2_${ik}$ ) = dscale / dif( 2_${ik}$ ) end if end if ! if b(k,k) is complex, make it real and positive (normalization @@ -62275,9 +62277,9 @@ module stdlib_linalg_lapack_c temp1 = conjg( b( k, k ) / dscale ) temp2 = b( k, k ) / dscale b( k, k ) = dscale - call stdlib_cscal( n-k, temp1, b( k, k+1 ), ldb ) - call stdlib_cscal( n-k+1, temp1, a( k, k ), lda ) - if( wantq )call stdlib_cscal( n, temp2, q( 1, k ), 1 ) + call stdlib${ii}$_cscal( n-k, temp1, b( k, k+1 ), ldb ) + call stdlib${ii}$_cscal( n-k+1, temp1, a( k, k ), lda ) + if( wantq )call stdlib${ii}$_cscal( n, temp2, q( 1_${ik}$, k ), 1_${ik}$ ) else b( k, k ) = cmplx( zero, zero,KIND=sp) end if @@ -62285,13 +62287,13 @@ module stdlib_linalg_lapack_c beta( k ) = b( k, k ) end do 70 continue - work( 1 ) = lwmin - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = lwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_ctgsen + end subroutine stdlib${ii}$_ctgsen - pure subroutine stdlib_ctgsna( job, howmny, select, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, s, & + pure subroutine stdlib${ii}$_ctgsna( job, howmny, select, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, s, & !! CTGSNA estimates reciprocal condition numbers for specified !! eigenvalues and/or eigenvectors of a matrix pair (A, B). !! (A, B) must be in generalized Schur canonical form, that is, A and @@ -62302,26 +62304,26 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: howmny, job - integer(ilp), intent(out) :: info, m - integer(ilp), intent(in) :: lda, ldb, ldvl, ldvr, lwork, mm, n + integer(${ik}$), intent(out) :: info, m + integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, mm, n ! Array Arguments logical(lk), intent(in) :: select(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(out) :: dif(*), s(*) complex(sp), intent(in) :: a(lda,*), b(ldb,*), vl(ldvl,*), vr(ldvr,*) complex(sp), intent(out) :: work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: idifjb = 3 + integer(${ik}$), parameter :: idifjb = 3_${ik}$ ! Local Scalars logical(lk) :: lquery, somcon, wantbh, wantdf, wants - integer(ilp) :: i, ierr, ifst, ilst, k, ks, lwmin, n1, n2 + integer(${ik}$) :: i, ierr, ifst, ilst, k, ks, lwmin, n1, n2 real(sp) :: bignum, cond, eps, lnrm, rnrm, scale, smlnum complex(sp) :: yhax, yhbx ! Local Arrays - complex(sp) :: dummy(1), dummy1(1) + complex(sp) :: dummy(1_${ik}$), dummy1(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,cmplx,max ! Executable Statements @@ -62330,49 +62332,49 @@ module stdlib_linalg_lapack_c wants = stdlib_lsame( job, 'E' ) .or. wantbh wantdf = stdlib_lsame( job, 'V' ) .or. wantbh somcon = stdlib_lsame( howmny, 'S' ) - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) if( .not.wants .and. .not.wantdf ) then - info = -1 + info = -1_${ik}$ else if( .not.stdlib_lsame( howmny, 'A' ) .and. .not.somcon ) then - info = -2 - else if( n<0 ) then - info = -4 - else if( lda0 ) then + ilst = 1_${ik}$ + call stdlib${ii}$_ctgexc( .false., .false., n, work, n, work( n*n+1 ),n, dummy, 1_${ik}$, & + dummy1, 1_${ik}$, ifst, ilst, ierr ) + if( ierr>0_${ik}$ ) then ! ill-conditioned problem - swap rejected. dif( ks ) = zero else @@ -62433,22 +62435,22 @@ module stdlib_linalg_lapack_c ! a22 * r - l * a11 = a12 ! b22 * r - l * b11 = b12, ! and compute estimate of difl[(a11,b11), (a22, b22)]. - n1 = 1 + n1 = 1_${ik}$ n2 = n - n1 - i = n*n + 1 - call stdlib_ctgsyl( 'N', idifjb, n2, n1, work( n*n1+n1+1 ),n, work, n, & + i = n*n + 1_${ik}$ + call stdlib${ii}$_ctgsyl( 'N', idifjb, n2, n1, work( n*n1+n1+1 ),n, work, n, & work( n1+1 ), n,work( n*n1+n1+i ), n, work( i ), n,work( n1+i ), n, scale, & - dif( ks ), dummy,1, iwork, ierr ) + dif( ks ), dummy,1_${ik}$, iwork, ierr ) end if end if end if end do loop_20 - work( 1 ) = lwmin + work( 1_${ik}$ ) = lwmin return - end subroutine stdlib_ctgsna + end subroutine stdlib${ii}$_ctgsna - subroutine stdlib_ctrsen( job, compq, select, n, t, ldt, q, ldq, w, m, s,sep, work, lwork, & + subroutine stdlib${ii}$_ctrsen( job, compq, select, n, t, ldt, q, ldq, w, m, s,sep, work, lwork, & !! CTRSEN reorders the Schur factorization of a complex matrix !! A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in !! the leading positions on the diagonal of the upper triangular matrix @@ -62462,8 +62464,8 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: compq, job - integer(ilp), intent(out) :: info, m - integer(ilp), intent(in) :: ldq, ldt, lwork, n + integer(${ik}$), intent(out) :: info, m + integer(${ik}$), intent(in) :: ldq, ldt, lwork, n real(sp), intent(out) :: s, sep ! Array Arguments logical(lk), intent(in) :: select(*) @@ -62473,11 +62475,11 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: lquery, wantbh, wantq, wants, wantsp - integer(ilp) :: ierr, k, kase, ks, lwmin, n1, n2, nn + integer(${ik}$) :: ierr, k, kase, ks, lwmin, n1, n2, nn real(sp) :: est, rnorm, scale ! Local Arrays - integer(ilp) :: isave(3) - real(sp) :: rwork(1) + integer(${ik}$) :: isave(3_${ik}$) + real(sp) :: rwork(1_${ik}$) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements @@ -62487,68 +62489,68 @@ module stdlib_linalg_lapack_c wantsp = stdlib_lsame( job, 'V' ) .or. wantbh wantq = stdlib_lsame( compq, 'V' ) ! set m to the number of selected eigenvalues. - m = 0 + m = 0_${ik}$ do k = 1, n - if( select( k ) )m = m + 1 + if( select( k ) )m = m + 1_${ik}$ end do n1 = m n2 = n - m nn = n1*n2 - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) if( wantsp ) then - lwmin = max( 1, 2*nn ) + lwmin = max( 1_${ik}$, 2_${ik}$*nn ) else if( stdlib_lsame( job, 'N' ) ) then - lwmin = 1 + lwmin = 1_${ik}$ else if( stdlib_lsame( job, 'E' ) ) then - lwmin = max( 1, nn ) + lwmin = max( 1_${ik}$, nn ) end if if( .not.stdlib_lsame( job, 'N' ) .and. .not.wants .and. .not.wantsp )then - info = -1 + info = -1_${ik}$ else if( .not.stdlib_lsame( compq, 'N' ) .and. .not.wantq ) then - info = -2 - else if( n<0 ) then - info = -4 - else if( ldt m-p ) then - info = -2 - else if( q < 0 .or. q < p .or. m-q < p ) then - info = -3 - else if( ldx11 < max( 1, p ) ) then - info = -5 - else if( ldx21 < max( 1, m-p ) ) then - info = -7 + info = 0_${ik}$ + lquery = lwork == -1_${ik}$ + if( m < 0_${ik}$ ) then + info = -1_${ik}$ + else if( p < 0_${ik}$ .or. p > m-p ) then + info = -2_${ik}$ + else if( q < 0_${ik}$ .or. q < p .or. m-q < p ) then + info = -3_${ik}$ + else if( ldx11 < max( 1_${ik}$, p ) ) then + info = -5_${ik}$ + else if( ldx21 < max( 1_${ik}$, m-p ) ) then + info = -7_${ik}$ end if ! compute workspace - if( info == 0 ) then - ilarf = 2 + if( info == 0_${ik}$ ) then + ilarf = 2_${ik}$ llarf = max( p-1, m-p, q-1 ) - iorbdb5 = 2 + iorbdb5 = 2_${ik}$ lorbdb5 = q-1 lworkopt = max( ilarf+llarf-1, iorbdb5+lorbdb5-1 ) lworkmin = lworkopt - work(1) = lworkopt + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not.lquery ) then - info = -14 + info = -14_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'CUNBDB2', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'CUNBDB2', -info ) return else if( lquery ) then return end if ! reduce rows 1, ..., p of x11 and x21 do i = 1, p - if( i > 1 ) then - call stdlib_csrot( q-i+1, x11(i,i), ldx11, x21(i-1,i), ldx21, c,s ) + if( i > 1_${ik}$ ) then + call stdlib${ii}$_csrot( q-i+1, x11(i,i), ldx11, x21(i-1,i), ldx21, c,s ) end if - call stdlib_clacgv( q-i+1, x11(i,i), ldx11 ) - call stdlib_clarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) + call stdlib${ii}$_clacgv( q-i+1, x11(i,i), ldx11 ) + call stdlib${ii}$_clarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) c = real( x11(i,i),KIND=sp) x11(i,i) = cone - call stdlib_clarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & + call stdlib${ii}$_clarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & work(ilarf) ) - call stdlib_clarf( 'R', m-p-i+1, q-i+1, x11(i,i), ldx11, tauq1(i),x21(i,i), ldx21, & + call stdlib${ii}$_clarf( 'R', m-p-i+1, q-i+1, x11(i,i), ldx11, tauq1(i),x21(i,i), ldx21, & work(ilarf) ) - call stdlib_clacgv( q-i+1, x11(i,i), ldx11 ) - s = sqrt( stdlib_scnrm2( p-i, x11(i+1,i), 1 )**2+ stdlib_scnrm2( m-p-i+1, x21(i,i), & - 1 )**2 ) + call stdlib${ii}$_clacgv( q-i+1, x11(i,i), ldx11 ) + s = sqrt( stdlib${ii}$_scnrm2( p-i, x11(i+1,i), 1_${ik}$ )**2_${ik}$+ stdlib${ii}$_scnrm2( m-p-i+1, x21(i,i), & + 1_${ik}$ )**2_${ik}$ ) theta(i) = atan2( s, c ) - call stdlib_cunbdb5( p-i, m-p-i+1, q-i, x11(i+1,i), 1, x21(i,i), 1,x11(i+1,i+1), & + call stdlib${ii}$_cunbdb5( p-i, m-p-i+1, q-i, x11(i+1,i), 1_${ik}$, x21(i,i), 1_${ik}$,x11(i+1,i+1), & ldx11, x21(i,i+1), ldx21,work(iorbdb5), lorbdb5, childinfo ) - call stdlib_cscal( p-i, cnegone, x11(i+1,i), 1 ) - call stdlib_clarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) ) + call stdlib${ii}$_cscal( p-i, cnegone, x11(i+1,i), 1_${ik}$ ) + call stdlib${ii}$_clarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1_${ik}$, taup2(i) ) if( i < p ) then - call stdlib_clarfgp( p-i, x11(i+1,i), x11(i+2,i), 1, taup1(i) ) + call stdlib${ii}$_clarfgp( p-i, x11(i+1,i), x11(i+2,i), 1_${ik}$, taup1(i) ) phi(i) = atan2( real( x11(i+1,i),KIND=sp), real( x21(i,i),KIND=sp) ) c = cos( phi(i) ) s = sin( phi(i) ) x11(i+1,i) = cone - call stdlib_clarf( 'L', p-i, q-i, x11(i+1,i), 1, conjg(taup1(i)),x11(i+1,i+1), & + call stdlib${ii}$_clarf( 'L', p-i, q-i, x11(i+1,i), 1_${ik}$, conjg(taup1(i)),x11(i+1,i+1), & ldx11, work(ilarf) ) end if x21(i,i) = cone - call stdlib_clarf( 'L', m-p-i+1, q-i, x21(i,i), 1, conjg(taup2(i)),x21(i,i+1), & + call stdlib${ii}$_clarf( 'L', m-p-i+1, q-i, x21(i,i), 1_${ik}$, conjg(taup2(i)),x21(i,i+1), & ldx21, work(ilarf) ) end do ! reduce the bottom-right portion of x21 to the identity matrix do i = p + 1, q - call stdlib_clarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) ) + call stdlib${ii}$_clarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1_${ik}$, taup2(i) ) x21(i,i) = cone - call stdlib_clarf( 'L', m-p-i+1, q-i, x21(i,i), 1, conjg(taup2(i)),x21(i,i+1), & + call stdlib${ii}$_clarf( 'L', m-p-i+1, q-i, x21(i,i), 1_${ik}$, conjg(taup2(i)),x21(i,i+1), & ldx21, work(ilarf) ) end do return - end subroutine stdlib_cunbdb2 + end subroutine stdlib${ii}$_cunbdb2 - subroutine stdlib_cunbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & + subroutine stdlib${ii}$_cunbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & !! CUNBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny !! matrix X with orthonomal columns: !! [ B11 ] @@ -62826,8 +62828,8 @@ module stdlib_linalg_lapack_c ! -- 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) :: lwork, m, p, q, ldx11, ldx21 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork, m, p, q, ldx11, ldx21 ! Array Arguments real(sp), intent(out) :: phi(*), theta(*) complex(sp), intent(out) :: taup1(*), taup2(*), tauq1(*), work(*) @@ -62836,90 +62838,90 @@ module stdlib_linalg_lapack_c ! Local Scalars real(sp) :: c, s - integer(ilp) :: childinfo, i, ilarf, iorbdb5, llarf, lorbdb5, lworkmin, & + integer(${ik}$) :: childinfo, i, ilarf, iorbdb5, llarf, lorbdb5, lworkmin, & lworkopt logical(lk) :: lquery ! Intrinsic Function intrinsic :: atan2,cos,max,sin,sqrt ! Executable Statements ! test input arguments - info = 0 - lquery = lwork == -1 - if( m < 0 ) then - info = -1 - else if( 2*p < m .or. p > m ) then - info = -2 + info = 0_${ik}$ + lquery = lwork == -1_${ik}$ + if( m < 0_${ik}$ ) then + info = -1_${ik}$ + else if( 2_${ik}$*p < m .or. p > m ) then + info = -2_${ik}$ else if( q < m-p .or. m-q < m-p ) then - info = -3 - else if( ldx11 < max( 1, p ) ) then - info = -5 - else if( ldx21 < max( 1, m-p ) ) then - info = -7 + info = -3_${ik}$ + else if( ldx11 < max( 1_${ik}$, p ) ) then + info = -5_${ik}$ + else if( ldx21 < max( 1_${ik}$, m-p ) ) then + info = -7_${ik}$ end if ! compute workspace - if( info == 0 ) then - ilarf = 2 + if( info == 0_${ik}$ ) then + ilarf = 2_${ik}$ llarf = max( p, m-p-1, q-1 ) - iorbdb5 = 2 + iorbdb5 = 2_${ik}$ lorbdb5 = q-1 lworkopt = max( ilarf+llarf-1, iorbdb5+lorbdb5-1 ) lworkmin = lworkopt - work(1) = lworkopt + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not.lquery ) then - info = -14 + info = -14_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'CUNBDB3', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'CUNBDB3', -info ) return else if( lquery ) then return end if ! reduce rows 1, ..., m-p of x11 and x21 do i = 1, m-p - if( i > 1 ) then - call stdlib_csrot( q-i+1, x11(i-1,i), ldx11, x21(i,i), ldx11, c,s ) + if( i > 1_${ik}$ ) then + call stdlib${ii}$_csrot( q-i+1, x11(i-1,i), ldx11, x21(i,i), ldx11, c,s ) end if - call stdlib_clacgv( q-i+1, x21(i,i), ldx21 ) - call stdlib_clarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) + call stdlib${ii}$_clacgv( q-i+1, x21(i,i), ldx21 ) + call stdlib${ii}$_clarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) s = real( x21(i,i),KIND=sp) x21(i,i) = cone - call stdlib_clarf( 'R', p-i+1, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i,i), ldx11, & + call stdlib${ii}$_clarf( 'R', p-i+1, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i,i), ldx11, & work(ilarf) ) - call stdlib_clarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & + call stdlib${ii}$_clarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & work(ilarf) ) - call stdlib_clacgv( q-i+1, x21(i,i), ldx21 ) - c = sqrt( stdlib_scnrm2( p-i+1, x11(i,i), 1 )**2+ stdlib_scnrm2( m-p-i, x21(i+1,i), & - 1 )**2 ) + call stdlib${ii}$_clacgv( q-i+1, x21(i,i), ldx21 ) + c = sqrt( stdlib${ii}$_scnrm2( p-i+1, x11(i,i), 1_${ik}$ )**2_${ik}$+ stdlib${ii}$_scnrm2( m-p-i, x21(i+1,i), & + 1_${ik}$ )**2_${ik}$ ) theta(i) = atan2( s, c ) - call stdlib_cunbdb5( p-i+1, m-p-i, q-i, x11(i,i), 1, x21(i+1,i), 1,x11(i,i+1), & + call stdlib${ii}$_cunbdb5( p-i+1, m-p-i, q-i, x11(i,i), 1_${ik}$, x21(i+1,i), 1_${ik}$,x11(i,i+1), & ldx11, x21(i+1,i+1), ldx21,work(iorbdb5), lorbdb5, childinfo ) - call stdlib_clarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) + call stdlib${ii}$_clarfgp( p-i+1, x11(i,i), x11(i+1,i), 1_${ik}$, taup1(i) ) if( i < m-p ) then - call stdlib_clarfgp( m-p-i, x21(i+1,i), x21(i+2,i), 1, taup2(i) ) + call stdlib${ii}$_clarfgp( m-p-i, x21(i+1,i), x21(i+2,i), 1_${ik}$, taup2(i) ) phi(i) = atan2( real( x21(i+1,i),KIND=sp), real( x11(i,i),KIND=sp) ) c = cos( phi(i) ) s = sin( phi(i) ) x21(i+1,i) = cone - call stdlib_clarf( 'L', m-p-i, q-i, x21(i+1,i), 1, conjg(taup2(i)),x21(i+1,i+1), & + call stdlib${ii}$_clarf( 'L', m-p-i, q-i, x21(i+1,i), 1_${ik}$, conjg(taup2(i)),x21(i+1,i+1), & ldx21, work(ilarf) ) end if x11(i,i) = cone - call stdlib_clarf( 'L', p-i+1, q-i, x11(i,i), 1, conjg(taup1(i)),x11(i,i+1), ldx11, & + call stdlib${ii}$_clarf( 'L', p-i+1, q-i, x11(i,i), 1_${ik}$, conjg(taup1(i)),x11(i,i+1), ldx11, & work(ilarf) ) end do ! reduce the bottom-right portion of x11 to the identity matrix do i = m-p + 1, q - call stdlib_clarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) + call stdlib${ii}$_clarfgp( p-i+1, x11(i,i), x11(i+1,i), 1_${ik}$, taup1(i) ) x11(i,i) = cone - call stdlib_clarf( 'L', p-i+1, q-i, x11(i,i), 1, conjg(taup1(i)),x11(i,i+1), ldx11, & + call stdlib${ii}$_clarf( 'L', p-i+1, q-i, x11(i,i), 1_${ik}$, conjg(taup1(i)),x11(i,i+1), ldx11, & work(ilarf) ) end do return - end subroutine stdlib_cunbdb3 + end subroutine stdlib${ii}$_cunbdb3 - subroutine stdlib_cunbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & + subroutine stdlib${ii}$_cunbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & !! CUNBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny !! matrix X with orthonomal columns: !! [ B11 ] @@ -62940,8 +62942,8 @@ module stdlib_linalg_lapack_c ! -- 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) :: lwork, m, p, q, ldx11, ldx21 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork, m, p, q, ldx11, ldx21 ! Array Arguments real(sp), intent(out) :: phi(*), theta(*) complex(sp), intent(out) :: phantom(*), taup1(*), taup2(*), tauq1(*), work(*) @@ -62950,125 +62952,125 @@ module stdlib_linalg_lapack_c ! Local Scalars real(sp) :: c, s - integer(ilp) :: childinfo, i, ilarf, iorbdb5, j, llarf, lorbdb5, lworkmin, & + integer(${ik}$) :: childinfo, i, ilarf, iorbdb5, j, llarf, lorbdb5, lworkmin, & lworkopt logical(lk) :: lquery ! Intrinsic Function intrinsic :: atan2,cos,max,sin,sqrt ! Executable Statements ! test input arguments - info = 0 - lquery = lwork == -1 - if( m < 0 ) then - info = -1 + info = 0_${ik}$ + lquery = lwork == -1_${ik}$ + if( m < 0_${ik}$ ) then + info = -1_${ik}$ else if( p < m-q .or. m-p < m-q ) then - info = -2 + info = -2_${ik}$ else if( q < m-q .or. q > m ) then - info = -3 - else if( ldx11 < max( 1, p ) ) then - info = -5 - else if( ldx21 < max( 1, m-p ) ) then - info = -7 + info = -3_${ik}$ + else if( ldx11 < max( 1_${ik}$, p ) ) then + info = -5_${ik}$ + else if( ldx21 < max( 1_${ik}$, m-p ) ) then + info = -7_${ik}$ end if ! compute workspace - if( info == 0 ) then - ilarf = 2 + if( info == 0_${ik}$ ) then + ilarf = 2_${ik}$ llarf = max( q-1, p-1, m-p-1 ) - iorbdb5 = 2 + iorbdb5 = 2_${ik}$ lorbdb5 = q - lworkopt = ilarf + llarf - 1 - lworkopt = max( lworkopt, iorbdb5 + lorbdb5 - 1 ) + lworkopt = ilarf + llarf - 1_${ik}$ + lworkopt = max( lworkopt, iorbdb5 + lorbdb5 - 1_${ik}$ ) lworkmin = lworkopt - work(1) = lworkopt + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not.lquery ) then - info = -14 + info = -14_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'CUNBDB4', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'CUNBDB4', -info ) return else if( lquery ) then return end if ! reduce columns 1, ..., m-q of x11 and x21 do i = 1, m-q - if( i == 1 ) then + if( i == 1_${ik}$ ) then do j = 1, m phantom(j) = czero end do - call stdlib_cunbdb5( p, m-p, q, phantom(1), 1, phantom(p+1), 1,x11, ldx11, x21, & + call stdlib${ii}$_cunbdb5( p, m-p, q, phantom(1_${ik}$), 1_${ik}$, phantom(p+1), 1_${ik}$,x11, ldx11, x21, & ldx21, work(iorbdb5),lorbdb5, childinfo ) - call stdlib_cscal( p, cnegone, phantom(1), 1 ) - call stdlib_clarfgp( p, phantom(1), phantom(2), 1, taup1(1) ) - call stdlib_clarfgp( m-p, phantom(p+1), phantom(p+2), 1, taup2(1) ) - theta(i) = atan2( real( phantom(1),KIND=sp), real( phantom(p+1),KIND=sp) ) + call stdlib${ii}$_cscal( p, cnegone, phantom(1_${ik}$), 1_${ik}$ ) + call stdlib${ii}$_clarfgp( p, phantom(1_${ik}$), phantom(2_${ik}$), 1_${ik}$, taup1(1_${ik}$) ) + call stdlib${ii}$_clarfgp( m-p, phantom(p+1), phantom(p+2), 1_${ik}$, taup2(1_${ik}$) ) + theta(i) = atan2( real( phantom(1_${ik}$),KIND=sp), real( phantom(p+1),KIND=sp) ) c = cos( theta(i) ) s = sin( theta(i) ) - phantom(1) = cone + phantom(1_${ik}$) = cone phantom(p+1) = cone - call stdlib_clarf( 'L', p, q, phantom(1), 1, conjg(taup1(1)), x11,ldx11, work(& + call stdlib${ii}$_clarf( 'L', p, q, phantom(1_${ik}$), 1_${ik}$, conjg(taup1(1_${ik}$)), x11,ldx11, work(& ilarf) ) - call stdlib_clarf( 'L', m-p, q, phantom(p+1), 1, conjg(taup2(1)),x21, ldx21, & + call stdlib${ii}$_clarf( 'L', m-p, q, phantom(p+1), 1_${ik}$, conjg(taup2(1_${ik}$)),x21, ldx21, & work(ilarf) ) else - call stdlib_cunbdb5( p-i+1, m-p-i+1, q-i+1, x11(i,i-1), 1,x21(i,i-1), 1, x11(i,i)& + call stdlib${ii}$_cunbdb5( p-i+1, m-p-i+1, q-i+1, x11(i,i-1), 1_${ik}$,x21(i,i-1), 1_${ik}$, x11(i,i)& , ldx11, x21(i,i),ldx21, work(iorbdb5), lorbdb5, childinfo ) - call stdlib_cscal( p-i+1, cnegone, x11(i,i-1), 1 ) - call stdlib_clarfgp( p-i+1, x11(i,i-1), x11(i+1,i-1), 1, taup1(i) ) - call stdlib_clarfgp( m-p-i+1, x21(i,i-1), x21(i+1,i-1), 1,taup2(i) ) + call stdlib${ii}$_cscal( p-i+1, cnegone, x11(i,i-1), 1_${ik}$ ) + call stdlib${ii}$_clarfgp( p-i+1, x11(i,i-1), x11(i+1,i-1), 1_${ik}$, taup1(i) ) + call stdlib${ii}$_clarfgp( m-p-i+1, x21(i,i-1), x21(i+1,i-1), 1_${ik}$,taup2(i) ) theta(i) = atan2( real( x11(i,i-1),KIND=sp), real( x21(i,i-1),KIND=sp) ) c = cos( theta(i) ) s = sin( theta(i) ) x11(i,i-1) = cone x21(i,i-1) = cone - call stdlib_clarf( 'L', p-i+1, q-i+1, x11(i,i-1), 1,conjg(taup1(i)), x11(i,i), & + call stdlib${ii}$_clarf( 'L', p-i+1, q-i+1, x11(i,i-1), 1_${ik}$,conjg(taup1(i)), x11(i,i), & ldx11, work(ilarf) ) - call stdlib_clarf( 'L', m-p-i+1, q-i+1, x21(i,i-1), 1,conjg(taup2(i)), x21(i,i), & + call stdlib${ii}$_clarf( 'L', m-p-i+1, q-i+1, x21(i,i-1), 1_${ik}$,conjg(taup2(i)), x21(i,i), & ldx21, work(ilarf) ) end if - call stdlib_csrot( q-i+1, x11(i,i), ldx11, x21(i,i), ldx21, s, -c ) - call stdlib_clacgv( q-i+1, x21(i,i), ldx21 ) - call stdlib_clarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) + call stdlib${ii}$_csrot( q-i+1, x11(i,i), ldx11, x21(i,i), ldx21, s, -c ) + call stdlib${ii}$_clacgv( q-i+1, x21(i,i), ldx21 ) + call stdlib${ii}$_clarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) c = real( x21(i,i),KIND=sp) x21(i,i) = cone - call stdlib_clarf( 'R', p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i+1,i), ldx11, & + call stdlib${ii}$_clarf( 'R', p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i+1,i), ldx11, & work(ilarf) ) - call stdlib_clarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & + call stdlib${ii}$_clarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & work(ilarf) ) - call stdlib_clacgv( q-i+1, x21(i,i), ldx21 ) + call stdlib${ii}$_clacgv( q-i+1, x21(i,i), ldx21 ) if( i < m-q ) then - s = sqrt( stdlib_scnrm2( p-i, x11(i+1,i), 1 )**2+ stdlib_scnrm2( m-p-i, x21(i+1,& - i), 1 )**2 ) + s = sqrt( stdlib${ii}$_scnrm2( p-i, x11(i+1,i), 1_${ik}$ )**2_${ik}$+ stdlib${ii}$_scnrm2( m-p-i, x21(i+1,& + i), 1_${ik}$ )**2_${ik}$ ) phi(i) = atan2( s, c ) end if end do ! reduce the bottom-right portion of x11 to [ i 0 ] do i = m - q + 1, p - call stdlib_clacgv( q-i+1, x11(i,i), ldx11 ) - call stdlib_clarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) + call stdlib${ii}$_clacgv( q-i+1, x11(i,i), ldx11 ) + call stdlib${ii}$_clarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) x11(i,i) = cone - call stdlib_clarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & + call stdlib${ii}$_clarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & work(ilarf) ) - call stdlib_clarf( 'R', q-p, q-i+1, x11(i,i), ldx11, tauq1(i),x21(m-q+1,i), ldx21, & + call stdlib${ii}$_clarf( 'R', q-p, q-i+1, x11(i,i), ldx11, tauq1(i),x21(m-q+1,i), ldx21, & work(ilarf) ) - call stdlib_clacgv( q-i+1, x11(i,i), ldx11 ) + call stdlib${ii}$_clacgv( q-i+1, x11(i,i), ldx11 ) end do ! reduce the bottom-right portion of x21 to [ 0 i ] do i = p + 1, q - call stdlib_clacgv( q-i+1, x21(m-q+i-p,i), ldx21 ) - call stdlib_clarfgp( q-i+1, x21(m-q+i-p,i), x21(m-q+i-p,i+1), ldx21,tauq1(i) ) + call stdlib${ii}$_clacgv( q-i+1, x21(m-q+i-p,i), ldx21 ) + call stdlib${ii}$_clarfgp( q-i+1, x21(m-q+i-p,i), x21(m-q+i-p,i+1), ldx21,tauq1(i) ) x21(m-q+i-p,i) = cone - call stdlib_clarf( 'R', q-i, q-i+1, x21(m-q+i-p,i), ldx21, tauq1(i),x21(m-q+i-p+1,i)& + call stdlib${ii}$_clarf( 'R', q-i, q-i+1, x21(m-q+i-p,i), ldx21, tauq1(i),x21(m-q+i-p+1,i)& , ldx21, work(ilarf) ) - call stdlib_clacgv( q-i+1, x21(m-q+i-p,i), ldx21 ) + call stdlib${ii}$_clacgv( q-i+1, x21(m-q+i-p,i), ldx21 ) end do return - end subroutine stdlib_cunbdb4 + end subroutine stdlib${ii}$_cunbdb4 - subroutine stdlib_cuncsd2by1( jobu1, jobu2, jobv1t, m, p, q, x11, ldx11,x21, ldx21, theta, & + subroutine stdlib${ii}$_cuncsd2by1( jobu1, jobu2, jobv1t, m, p, q, x11, ldx11,x21, ldx21, theta, & !! CUNCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with !! orthonormal columns that has been partitioned into a 2-by-1 block !! structure: @@ -63090,52 +63092,52 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobu1, jobu2, jobv1t - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldu1, ldu2, ldv1t, lwork, ldx11, ldx21, m, p, q - integer(ilp), intent(in) :: lrwork - integer(ilp) :: lrworkmin, lrworkopt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldu1, ldu2, ldv1t, lwork, ldx11, ldx21, m, p, q + integer(${ik}$), intent(in) :: lrwork + integer(${ik}$) :: lrworkmin, lrworkopt ! Array Arguments real(sp), intent(out) :: rwork(*) real(sp), intent(out) :: theta(*) complex(sp), intent(out) :: u1(ldu1,*), u2(ldu2,*), v1t(ldv1t,*), work(*) complex(sp), intent(inout) :: x11(ldx11,*), x21(ldx21,*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: childinfo, i, ib11d, ib11e, ib12d, ib12e, ib21d, ib21e, ib22d, ib22e, & + integer(${ik}$) :: childinfo, i, ib11d, ib11e, ib12d, ib12e, ib21d, ib21e, ib22d, ib22e, & ibbcsd, iorbdb, iorglq, iorgqr, iphi, itaup1, itaup2, itauq1, j, lbbcsd, lorbdb, & lorglq, lorglqmin, lorglqopt, lorgqr, lorgqrmin, lorgqropt, lworkmin, lworkopt, & r logical(lk) :: lquery, wantu1, wantu2, wantv1t ! Local Arrays - real(sp) :: dum(1) - complex(sp) :: cdum(1,1) + real(sp) :: dum(1_${ik}$) + complex(sp) :: cdum(1_${ik}$,1_${ik}$) ! Intrinsic Function intrinsic :: int,max,min ! Executable Statements ! test input arguments - info = 0 + info = 0_${ik}$ wantu1 = stdlib_lsame( jobu1, 'Y' ) wantu2 = stdlib_lsame( jobu2, 'Y' ) wantv1t = stdlib_lsame( jobv1t, 'Y' ) - lquery = ( lwork==-1 ) .or. ( lrwork==-1 ) - if( m < 0 ) then - info = -4 - else if( p < 0 .or. p > m ) then - info = -5 - else if( q < 0 .or. q > m ) then - info = -6 - else if( ldx11 < max( 1, p ) ) then - info = -8 - else if( ldx21 < max( 1, m-p ) ) then - info = -10 - else if( wantu1 .and. ldu1 < max( 1, p ) ) then - info = -13 - else if( wantu2 .and. ldu2 < max( 1, m - p ) ) then - info = -15 - else if( wantv1t .and. ldv1t < max( 1, q ) ) then - info = -17 + lquery = ( lwork==-1_${ik}$ ) .or. ( lrwork==-1_${ik}$ ) + if( m < 0_${ik}$ ) then + info = -4_${ik}$ + else if( p < 0_${ik}$ .or. p > m ) then + info = -5_${ik}$ + else if( q < 0_${ik}$ .or. q > m ) then + info = -6_${ik}$ + else if( ldx11 < max( 1_${ik}$, p ) ) then + info = -8_${ik}$ + else if( ldx21 < max( 1_${ik}$, m-p ) ) then + info = -10_${ik}$ + else if( wantu1 .and. ldu1 < max( 1_${ik}$, p ) ) then + info = -13_${ik}$ + else if( wantu2 .and. ldu2 < max( 1_${ik}$, m - p ) ) then + info = -15_${ik}$ + else if( wantv1t .and. ldv1t < max( 1_${ik}$, q ) ) then + info = -17_${ik}$ end if r = min( p, m-p, q, m-q ) ! compute workspace @@ -63147,7 +63149,7 @@ module stdlib_linalg_lapack_c ! | taup2 (max(1,m-p)) | ! | tauq1 (max(1,q)) | ! |-----------------------------------------| - ! | stdlib_cunbdb work | stdlib_cungqr work | stdlib_cunglq work | + ! | stdlib${ii}$_cunbdb work | stdlib${ii}$_cungqr work | stdlib${ii}$_cunglq work | ! | | | | ! | | | | ! | | | | @@ -63167,143 +63169,143 @@ module stdlib_linalg_lapack_c ! | b21e (r-1) | ! | b22d (r) | ! | b22e (r-1) | - ! | stdlib_cbbcsd rwork | + ! | stdlib${ii}$_cbbcsd rwork | ! |------------------| - if( info == 0 ) then - iphi = 2 - ib11d = iphi + max( 1, r-1 ) - ib11e = ib11d + max( 1, r ) - ib12d = ib11e + max( 1, r - 1 ) - ib12e = ib12d + max( 1, r ) - ib21d = ib12e + max( 1, r - 1 ) - ib21e = ib21d + max( 1, r ) - ib22d = ib21e + max( 1, r - 1 ) - ib22e = ib22d + max( 1, r ) - ibbcsd = ib22e + max( 1, r - 1 ) - itaup1 = 2 - itaup2 = itaup1 + max( 1, p ) - itauq1 = itaup2 + max( 1, m-p ) - iorbdb = itauq1 + max( 1, q ) - iorgqr = itauq1 + max( 1, q ) - iorglq = itauq1 + max( 1, q ) - lorgqrmin = 1 - lorgqropt = 1 - lorglqmin = 1 - lorglqopt = 1 + if( info == 0_${ik}$ ) then + iphi = 2_${ik}$ + ib11d = iphi + max( 1_${ik}$, r-1 ) + ib11e = ib11d + max( 1_${ik}$, r ) + ib12d = ib11e + max( 1_${ik}$, r - 1_${ik}$ ) + ib12e = ib12d + max( 1_${ik}$, r ) + ib21d = ib12e + max( 1_${ik}$, r - 1_${ik}$ ) + ib21e = ib21d + max( 1_${ik}$, r ) + ib22d = ib21e + max( 1_${ik}$, r - 1_${ik}$ ) + ib22e = ib22d + max( 1_${ik}$, r ) + ibbcsd = ib22e + max( 1_${ik}$, r - 1_${ik}$ ) + itaup1 = 2_${ik}$ + itaup2 = itaup1 + max( 1_${ik}$, p ) + itauq1 = itaup2 + max( 1_${ik}$, m-p ) + iorbdb = itauq1 + max( 1_${ik}$, q ) + iorgqr = itauq1 + max( 1_${ik}$, q ) + iorglq = itauq1 + max( 1_${ik}$, q ) + lorgqrmin = 1_${ik}$ + lorgqropt = 1_${ik}$ + lorglqmin = 1_${ik}$ + lorglqopt = 1_${ik}$ if( r == q ) then - call stdlib_cunbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,dum, cdum, cdum, & - cdum, work, -1,childinfo ) - lorbdb = int( work(1),KIND=ilp) - if( wantu1 .and. p > 0 ) then - call stdlib_cungqr( p, p, q, u1, ldu1, cdum, work(1), -1,childinfo ) + call stdlib${ii}$_cunbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,dum, cdum, cdum, & + cdum, work, -1_${ik}$,childinfo ) + lorbdb = int( work(1_${ik}$),KIND=${ik}$) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_cungqr( p, p, q, u1, ldu1, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) endif - if( wantu2 .and. m-p > 0 ) then - call stdlib_cungqr( m-p, m-p, q, u2, ldu2, cdum, work(1), -1,childinfo ) + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_cungqr( m-p, m-p, q, u2, ldu2, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, m-p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_cunglq( q-1, q-1, q-1, v1t, ldv1t,cdum, work(1), -1, childinfo ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_cunglq( q-1, q-1, q-1, v1t, ldv1t,cdum, work(1_${ik}$), -1_${ik}$, childinfo ) lorglqmin = max( lorglqmin, q-1 ) - lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) + lorglqopt = max( lorglqopt, int( work(1_${ik}$),KIND=${ik}$) ) end if - call stdlib_cbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,dum(1), u1, & - ldu1, u2, ldu2, v1t, ldv1t, cdum,1, dum, dum, dum, dum, dum, dum, dum, dum,rwork(& - 1), -1, childinfo ) - lbbcsd = int( rwork(1),KIND=ilp) + call stdlib${ii}$_cbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,dum(1_${ik}$), u1, & + ldu1, u2, ldu2, v1t, ldv1t, cdum,1_${ik}$, dum, dum, dum, dum, dum, dum, dum, dum,rwork(& + 1_${ik}$), -1_${ik}$, childinfo ) + lbbcsd = int( rwork(1_${ik}$),KIND=${ik}$) else if( r == p ) then - call stdlib_cunbdb2( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & - cdum, work(1), -1, childinfo ) - lorbdb = int( work(1),KIND=ilp) - if( wantu1 .and. p > 0 ) then - call stdlib_cungqr( p-1, p-1, p-1, u1(2,2), ldu1, cdum, work(1),-1, childinfo & + call stdlib${ii}$_cunbdb2( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & + cdum, work(1_${ik}$), -1_${ik}$, childinfo ) + lorbdb = int( work(1_${ik}$),KIND=${ik}$) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_cungqr( p-1, p-1, p-1, u1(2_${ik}$,2_${ik}$), ldu1, cdum, work(1_${ik}$),-1_${ik}$, childinfo & ) lorgqrmin = max( lorgqrmin, p-1 ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_cungqr( m-p, m-p, q, u2, ldu2, cdum, work(1), -1,childinfo ) + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_cungqr( m-p, m-p, q, u2, ldu2, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, m-p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_cunglq( q, q, r, v1t, ldv1t, cdum, work(1), -1,childinfo ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_cunglq( q, q, r, v1t, ldv1t, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorglqmin = max( lorglqmin, q ) - lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) + lorglqopt = max( lorglqopt, int( work(1_${ik}$),KIND=${ik}$) ) end if - call stdlib_cbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,dum, v1t, & - ldv1t, cdum, 1, u1, ldu1, u2, ldu2,dum, dum, dum, dum, dum, dum, dum, dum,rwork(& - 1), -1, childinfo ) - lbbcsd = int( rwork(1),KIND=ilp) + call stdlib${ii}$_cbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,dum, v1t, & + ldv1t, cdum, 1_${ik}$, u1, ldu1, u2, ldu2,dum, dum, dum, dum, dum, dum, dum, dum,rwork(& + 1_${ik}$), -1_${ik}$, childinfo ) + lbbcsd = int( rwork(1_${ik}$),KIND=${ik}$) else if( r == m-p ) then - call stdlib_cunbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & - cdum, work(1), -1, childinfo ) - lorbdb = int( work(1),KIND=ilp) - if( wantu1 .and. p > 0 ) then - call stdlib_cungqr( p, p, q, u1, ldu1, cdum, work(1), -1,childinfo ) + call stdlib${ii}$_cunbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & + cdum, work(1_${ik}$), -1_${ik}$, childinfo ) + lorbdb = int( work(1_${ik}$),KIND=${ik}$) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_cungqr( p, p, q, u1, ldu1, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_cungqr( m-p-1, m-p-1, m-p-1, u2(2,2), ldu2, cdum,work(1), -1, & + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_cungqr( m-p-1, m-p-1, m-p-1, u2(2_${ik}$,2_${ik}$), ldu2, cdum,work(1_${ik}$), -1_${ik}$, & childinfo ) lorgqrmin = max( lorgqrmin, m-p-1 ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_cunglq( q, q, r, v1t, ldv1t, cdum, work(1), -1,childinfo ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_cunglq( q, q, r, v1t, ldv1t, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorglqmin = max( lorglqmin, q ) - lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) - end if - call stdlib_cbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, dum, cdum,& - 1, v1t, ldv1t, u2, ldu2, u1,ldu1, dum, dum, dum, dum, dum, dum, dum, dum,rwork(& - 1), -1, childinfo ) - lbbcsd = int( rwork(1),KIND=ilp) - else - call stdlib_cunbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & - cdum, cdum, work(1), -1, childinfo) - lorbdb = m + int( work(1),KIND=ilp) - if( wantu1 .and. p > 0 ) then - call stdlib_cungqr( p, p, m-q, u1, ldu1, cdum, work(1), -1,childinfo ) + lorglqopt = max( lorglqopt, int( work(1_${ik}$),KIND=${ik}$) ) + end if + call stdlib${ii}$_cbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, dum, cdum,& + 1_${ik}$, v1t, ldv1t, u2, ldu2, u1,ldu1, dum, dum, dum, dum, dum, dum, dum, dum,rwork(& + 1_${ik}$), -1_${ik}$, childinfo ) + lbbcsd = int( rwork(1_${ik}$),KIND=${ik}$) + else + call stdlib${ii}$_cunbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & + cdum, cdum, work(1_${ik}$), -1_${ik}$, childinfo) + lorbdb = m + int( work(1_${ik}$),KIND=${ik}$) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_cungqr( p, p, m-q, u1, ldu1, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_cungqr( m-p, m-p, m-q, u2, ldu2, cdum, work(1), -1,childinfo ) + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_cungqr( m-p, m-p, m-q, u2, ldu2, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, m-p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_cunglq( q, q, q, v1t, ldv1t, cdum, work(1), -1,childinfo ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_cunglq( q, q, q, v1t, ldv1t, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorglqmin = max( lorglqmin, q ) - lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) + lorglqopt = max( lorglqopt, int( work(1_${ik}$),KIND=${ik}$) ) end if - call stdlib_cbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, dum, u2, & - ldu2, u1, ldu1, cdum, 1, v1t,ldv1t, dum, dum, dum, dum, dum, dum, dum, dum,rwork(& - 1), -1, childinfo ) - lbbcsd = int( rwork(1),KIND=ilp) + call stdlib${ii}$_cbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, dum, u2, & + ldu2, u1, ldu1, cdum, 1_${ik}$, v1t,ldv1t, dum, dum, dum, dum, dum, dum, dum, dum,rwork(& + 1_${ik}$), -1_${ik}$, childinfo ) + lbbcsd = int( rwork(1_${ik}$),KIND=${ik}$) end if lrworkmin = ibbcsd+lbbcsd-1 lrworkopt = lrworkmin - rwork(1) = lrworkopt + rwork(1_${ik}$) = lrworkopt lworkmin = max( iorbdb+lorbdb-1,iorgqr+lorgqrmin-1,iorglq+lorglqmin-1 ) lworkopt = max( iorbdb+lorbdb-1,iorgqr+lorgqropt-1,iorglq+lorglqopt-1 ) - work(1) = lworkopt + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not.lquery ) then - info = -19 + info = -19_${ik}$ end if if( lrwork < lrworkmin .and. .not.lquery ) then - info = -21 + info = -21_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'CUNCSD2BY1', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'CUNCSD2BY1', -info ) return else if( lquery ) then return @@ -63315,116 +63317,116 @@ module stdlib_linalg_lapack_c if( r == q ) then ! case 1: r = q ! simultaneously bidiagonalize x11 and x21 - call stdlib_cunbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& + call stdlib${ii}$_cunbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& itaup1), work(itaup2),work(itauq1), work(iorbdb), lorbdb, childinfo ) ! accumulate householder reflectors - if( wantu1 .and. p > 0 ) then - call stdlib_clacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) - call stdlib_cungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_clacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) + call stdlib${ii}$_cungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & childinfo ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_clacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) - call stdlib_cungqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_clacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) + call stdlib${ii}$_cungqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & childinfo ) end if - if( wantv1t .and. q > 0 ) then - v1t(1,1) = cone + if( wantv1t .and. q > 0_${ik}$ ) then + v1t(1_${ik}$,1_${ik}$) = cone do j = 2, q - v1t(1,j) = czero - v1t(j,1) = czero + v1t(1_${ik}$,j) = czero + v1t(j,1_${ik}$) = czero end do - call stdlib_clacpy( 'U', q-1, q-1, x21(1,2), ldx21, v1t(2,2),ldv1t ) - call stdlib_cunglq( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),work(iorglq), & + call stdlib${ii}$_clacpy( 'U', q-1, q-1, x21(1_${ik}$,2_${ik}$), ldx21, v1t(2_${ik}$,2_${ik}$),ldv1t ) + call stdlib${ii}$_cunglq( q-1, q-1, q-1, v1t(2_${ik}$,2_${ik}$), ldv1t, work(itauq1),work(iorglq), & lorglq, childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_cbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,rwork(iphi), u1, & - ldu1, u2, ldu2, v1t, ldv1t, cdum,1, rwork(ib11d), rwork(ib11e), rwork(ib12d),rwork(& + call stdlib${ii}$_cbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,rwork(iphi), u1, & + ldu1, u2, ldu2, v1t, ldv1t, cdum,1_${ik}$, rwork(ib11d), rwork(ib11e), rwork(ib12d),rwork(& ib12e), rwork(ib21d), rwork(ib21e),rwork(ib22d), rwork(ib22e), rwork(ibbcsd),lrwork-& ibbcsd+1, childinfo ) ! permute rows and columns to place czero submatrices in ! preferred positions - if( q > 0 .and. wantu2 ) then + if( q > 0_${ik}$ .and. wantu2 ) then do i = 1, q iwork(i) = m - p - q + i end do do i = q + 1, m - p iwork(i) = i - q end do - call stdlib_clapmt( .false., m-p, m-p, u2, ldu2, iwork ) + call stdlib${ii}$_clapmt( .false., m-p, m-p, u2, ldu2, iwork ) end if else if( r == p ) then ! case 2: r = p ! simultaneously bidiagonalize x11 and x21 - call stdlib_cunbdb2( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& + call stdlib${ii}$_cunbdb2( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& itaup1), work(itaup2),work(itauq1), work(iorbdb), lorbdb, childinfo ) ! accumulate householder reflectors - if( wantu1 .and. p > 0 ) then - u1(1,1) = cone + if( wantu1 .and. p > 0_${ik}$ ) then + u1(1_${ik}$,1_${ik}$) = cone do j = 2, p - u1(1,j) = czero - u1(j,1) = czero + u1(1_${ik}$,j) = czero + u1(j,1_${ik}$) = czero end do - call stdlib_clacpy( 'L', p-1, p-1, x11(2,1), ldx11, u1(2,2), ldu1 ) - call stdlib_cungqr( p-1, p-1, p-1, u1(2,2), ldu1, work(itaup1),work(iorgqr), & + call stdlib${ii}$_clacpy( 'L', p-1, p-1, x11(2_${ik}$,1_${ik}$), ldx11, u1(2_${ik}$,2_${ik}$), ldu1 ) + call stdlib${ii}$_cungqr( p-1, p-1, p-1, u1(2_${ik}$,2_${ik}$), ldu1, work(itaup1),work(iorgqr), & lorgqr, childinfo ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_clacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) - call stdlib_cungqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_clacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) + call stdlib${ii}$_cungqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & childinfo ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_clacpy( 'U', p, q, x11, ldx11, v1t, ldv1t ) - call stdlib_cunglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_clacpy( 'U', p, q, x11, ldx11, v1t, ldv1t ) + call stdlib${ii}$_cunglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_cbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,rwork(iphi), v1t,& - ldv1t, cdum, 1, u1, ldu1, u2,ldu2, rwork(ib11d), rwork(ib11e), rwork(ib12d),rwork(& + call stdlib${ii}$_cbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,rwork(iphi), v1t,& + ldv1t, cdum, 1_${ik}$, u1, ldu1, u2,ldu2, rwork(ib11d), rwork(ib11e), rwork(ib12d),rwork(& ib12e), rwork(ib21d), rwork(ib21e),rwork(ib22d), rwork(ib22e), rwork(ibbcsd), & lbbcsd,childinfo ) ! permute rows and columns to place identity submatrices in ! preferred positions - if( q > 0 .and. wantu2 ) then + if( q > 0_${ik}$ .and. wantu2 ) then do i = 1, q iwork(i) = m - p - q + i end do do i = q + 1, m - p iwork(i) = i - q end do - call stdlib_clapmt( .false., m-p, m-p, u2, ldu2, iwork ) + call stdlib${ii}$_clapmt( .false., m-p, m-p, u2, ldu2, iwork ) end if else if( r == m-p ) then ! case 3: r = m-p ! simultaneously bidiagonalize x11 and x21 - call stdlib_cunbdb3( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& + call stdlib${ii}$_cunbdb3( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& itaup1), work(itaup2),work(itauq1), work(iorbdb), lorbdb, childinfo ) ! accumulate householder reflectors - if( wantu1 .and. p > 0 ) then - call stdlib_clacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) - call stdlib_cungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_clacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) + call stdlib${ii}$_cungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & childinfo ) end if - if( wantu2 .and. m-p > 0 ) then - u2(1,1) = cone + if( wantu2 .and. m-p > 0_${ik}$ ) then + u2(1_${ik}$,1_${ik}$) = cone do j = 2, m-p - u2(1,j) = czero - u2(j,1) = czero + u2(1_${ik}$,j) = czero + u2(j,1_${ik}$) = czero end do - call stdlib_clacpy( 'L', m-p-1, m-p-1, x21(2,1), ldx21, u2(2,2),ldu2 ) - call stdlib_cungqr( m-p-1, m-p-1, m-p-1, u2(2,2), ldu2,work(itaup2), work(iorgqr)& + call stdlib${ii}$_clacpy( 'L', m-p-1, m-p-1, x21(2_${ik}$,1_${ik}$), ldx21, u2(2_${ik}$,2_${ik}$),ldu2 ) + call stdlib${ii}$_cungqr( m-p-1, m-p-1, m-p-1, u2(2_${ik}$,2_${ik}$), ldu2,work(itaup2), work(iorgqr)& , lorgqr, childinfo ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_clacpy( 'U', m-p, q, x21, ldx21, v1t, ldv1t ) - call stdlib_cunglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_clacpy( 'U', m-p, q, x21, ldx21, v1t, ldv1t ) + call stdlib${ii}$_cunglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_cbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, rwork(iphi), & - cdum, 1, v1t, ldv1t, u2, ldu2,u1, ldu1, rwork(ib11d), rwork(ib11e),rwork(ib12d), & + call stdlib${ii}$_cbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, rwork(iphi), & + cdum, 1_${ik}$, v1t, ldv1t, u2, ldu2,u1, ldu1, rwork(ib11d), rwork(ib11e),rwork(ib12d), & rwork(ib12e), rwork(ib21d),rwork(ib21e), rwork(ib22d), rwork(ib22e),rwork(ibbcsd), & lbbcsd, childinfo ) ! permute rows and columns to place identity submatrices in @@ -63437,51 +63439,51 @@ module stdlib_linalg_lapack_c iwork(i) = i - r end do if( wantu1 ) then - call stdlib_clapmt( .false., p, q, u1, ldu1, iwork ) + call stdlib${ii}$_clapmt( .false., p, q, u1, ldu1, iwork ) end if if( wantv1t ) then - call stdlib_clapmr( .false., q, q, v1t, ldv1t, iwork ) + call stdlib${ii}$_clapmr( .false., q, q, v1t, ldv1t, iwork ) end if end if else ! case 4: r = m-q ! simultaneously bidiagonalize x11 and x21 - call stdlib_cunbdb4( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& + call stdlib${ii}$_cunbdb4( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& itaup1), work(itaup2),work(itauq1), work(iorbdb), work(iorbdb+m),lorbdb-m, & childinfo ) ! accumulate householder reflectors - if( wantu2 .and. m-p > 0 ) then - call stdlib_ccopy( m-p, work(iorbdb+p), 1, u2, 1 ) + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_ccopy( m-p, work(iorbdb+p), 1_${ik}$, u2, 1_${ik}$ ) end if - if( wantu1 .and. p > 0 ) then - call stdlib_ccopy( p, work(iorbdb), 1, u1, 1 ) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_ccopy( p, work(iorbdb), 1_${ik}$, u1, 1_${ik}$ ) do j = 2, p - u1(1,j) = czero + u1(1_${ik}$,j) = czero end do - call stdlib_clacpy( 'L', p-1, m-q-1, x11(2,1), ldx11, u1(2,2),ldu1 ) - call stdlib_cungqr( p, p, m-q, u1, ldu1, work(itaup1),work(iorgqr), lorgqr, & + call stdlib${ii}$_clacpy( 'L', p-1, m-q-1, x11(2_${ik}$,1_${ik}$), ldx11, u1(2_${ik}$,2_${ik}$),ldu1 ) + call stdlib${ii}$_cungqr( p, p, m-q, u1, ldu1, work(itaup1),work(iorgqr), lorgqr, & childinfo ) end if - if( wantu2 .and. m-p > 0 ) then + if( wantu2 .and. m-p > 0_${ik}$ ) then do j = 2, m-p - u2(1,j) = czero + u2(1_${ik}$,j) = czero end do - call stdlib_clacpy( 'L', m-p-1, m-q-1, x21(2,1), ldx21, u2(2,2),ldu2 ) - call stdlib_cungqr( m-p, m-p, m-q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & + call stdlib${ii}$_clacpy( 'L', m-p-1, m-q-1, x21(2_${ik}$,1_${ik}$), ldx21, u2(2_${ik}$,2_${ik}$),ldu2 ) + call stdlib${ii}$_cungqr( m-p, m-p, m-q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & childinfo ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_clacpy( 'U', m-q, q, x21, ldx21, v1t, ldv1t ) - call stdlib_clacpy( 'U', p-(m-q), q-(m-q), x11(m-q+1,m-q+1), ldx11,v1t(m-q+1,m-q+& - 1), ldv1t ) - call stdlib_clacpy( 'U', -p+q, q-p, x21(m-q+1,p+1), ldx21,v1t(p+1,p+1), ldv1t ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_clacpy( 'U', m-q, q, x21, ldx21, v1t, ldv1t ) + call stdlib${ii}$_clacpy( 'U', p-(m-q), q-(m-q), x11(m-q+1,m-q+1), ldx11,v1t(m-q+1,m-q+& + 1_${ik}$), ldv1t ) + call stdlib${ii}$_clacpy( 'U', -p+q, q-p, x21(m-q+1,p+1), ldx21,v1t(p+1,p+1), ldv1t ) - call stdlib_cunglq( q, q, q, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & + call stdlib${ii}$_cunglq( q, q, q, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_cbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, rwork(iphi), & - u2, ldu2, u1, ldu1, cdum, 1,v1t, ldv1t, rwork(ib11d), rwork(ib11e),rwork(ib12d), & + call stdlib${ii}$_cbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, rwork(iphi), & + u2, ldu2, u1, ldu1, cdum, 1_${ik}$,v1t, ldv1t, rwork(ib11d), rwork(ib11e),rwork(ib12d), & rwork(ib12e), rwork(ib21d),rwork(ib21e), rwork(ib22d), rwork(ib22e),rwork(ibbcsd), & lbbcsd, childinfo ) ! permute rows and columns to place identity submatrices in @@ -63494,18 +63496,18 @@ module stdlib_linalg_lapack_c iwork(i) = i - r end do if( wantu1 ) then - call stdlib_clapmt( .false., p, p, u1, ldu1, iwork ) + call stdlib${ii}$_clapmt( .false., p, p, u1, ldu1, iwork ) end if if( wantv1t ) then - call stdlib_clapmr( .false., p, q, v1t, ldv1t, iwork ) + call stdlib${ii}$_clapmr( .false., p, q, v1t, ldv1t, iwork ) end if end if end if return - end subroutine stdlib_cuncsd2by1 + end subroutine stdlib${ii}$_cuncsd2by1 - pure subroutine stdlib_cungbr( vect, m, n, k, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_cungbr( vect, m, n, k, a, lda, tau, work, lwork, info ) !! CUNGBR generates one of the complex unitary matrices Q or P**H !! determined by CGEBRD when reducing a complex matrix A to bidiagonal !! form: A = Q * B * P**H. Q and P**H are defined as products of @@ -63527,8 +63529,8 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: vect - 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 complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(in) :: tau(*) @@ -63537,124 +63539,124 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: lquery, wantq - integer(ilp) :: i, iinfo, j, lwkopt, mn + integer(${ik}$) :: i, iinfo, j, lwkopt, mn ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ wantq = stdlib_lsame( vect, 'Q' ) mn = min( m, n ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) if( .not.wantq .and. .not.stdlib_lsame( vect, 'P' ) ) then - info = -1 - else if( m<0 ) then - info = -2 - else if( n<0 .or. ( wantq .and. ( n>m .or. nm .or. nn .or. m=k ) then - call stdlib_cungqr( m, n, k, a, lda, tau, work, -1, iinfo ) + call stdlib${ii}$_cungqr( m, n, k, a, lda, tau, work, -1_${ik}$, iinfo ) else - if( m>1 ) then - call stdlib_cungqr( m-1, m-1, m-1, a, lda, tau, work, -1,iinfo ) + if( m>1_${ik}$ ) then + call stdlib${ii}$_cungqr( m-1, m-1, m-1, a, lda, tau, work, -1_${ik}$,iinfo ) end if end if else if( k1 ) then - call stdlib_cunglq( n-1, n-1, n-1, a, lda, tau, work, -1,iinfo ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_cunglq( n-1, n-1, n-1, a, lda, tau, work, -1_${ik}$,iinfo ) end if end if end if - lwkopt = real( work( 1 ),KIND=sp) + lwkopt = real( work( 1_${ik}$ ),KIND=sp) lwkopt = max (lwkopt, mn) end if - if( info/=0 ) then - call stdlib_xerbla( 'CUNGBR', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'CUNGBR', -info ) return else if( lquery ) then - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return end if ! quick return if possible - if( m==0 .or. n==0 ) then - work( 1 ) = 1 + if( m==0_${ik}$ .or. n==0_${ik}$ ) then + work( 1_${ik}$ ) = 1_${ik}$ return end if if( wantq ) then - ! form q, determined by a call to stdlib_cgebrd to reduce an m-by-k + ! form q, determined by a call to stdlib${ii}$_cgebrd to reduce an m-by-k ! matrix if( m>=k ) then ! if m >= k, assume m >= n >= k - call stdlib_cungqr( m, n, k, a, lda, tau, work, lwork, iinfo ) + call stdlib${ii}$_cungqr( m, n, k, a, lda, tau, work, lwork, iinfo ) else ! if m < k, assume m = n ! shift the vectors which define the elementary reflectors cone ! column to the right, and set the first row and column of q ! to those of the unit matrix do j = m, 2, -1 - a( 1, j ) = czero + a( 1_${ik}$, j ) = czero do i = j + 1, m a( i, j ) = a( i, j-1 ) end do end do - a( 1, 1 ) = cone + a( 1_${ik}$, 1_${ik}$ ) = cone do i = 2, m - a( i, 1 ) = czero + a( i, 1_${ik}$ ) = czero end do - if( m>1 ) then + if( m>1_${ik}$ ) then ! form q(2:m,2:m) - call stdlib_cungqr( m-1, m-1, m-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) + call stdlib${ii}$_cungqr( m-1, m-1, m-1, a( 2_${ik}$, 2_${ik}$ ), lda, tau, work,lwork, iinfo ) end if end if else - ! form p**h, determined by a call to stdlib_cgebrd to reduce a k-by-n + ! form p**h, determined by a call to stdlib${ii}$_cgebrd to reduce a k-by-n ! matrix if( k= n, assume m = n ! shift the vectors which define the elementary reflectors cone ! row downward, and set the first row and column of p**h to ! those of the unit matrix - a( 1, 1 ) = cone + a( 1_${ik}$, 1_${ik}$ ) = cone do i = 2, n - a( i, 1 ) = czero + a( i, 1_${ik}$ ) = czero end do do j = 2, n do i = j - 1, 2, -1 a( i, j ) = a( i-1, j ) end do - a( 1, j ) = czero + a( 1_${ik}$, j ) = czero end do - if( n>1 ) then + if( n>1_${ik}$ ) then ! form p**h(2:n,2:n) - call stdlib_cunglq( n-1, n-1, n-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) + call stdlib${ii}$_cunglq( n-1, n-1, n-1, a( 2_${ik}$, 2_${ik}$ ), lda, tau, work,lwork, iinfo ) end if end if end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_cungbr + end subroutine stdlib${ii}$_cungbr - pure subroutine stdlib_cungtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) + pure subroutine stdlib${ii}$_cungtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) !! CUNGTSQR generates an M-by-N complex matrix Q_out with orthonormal !! columns, which are the first N columns of a product of comlpex unitary !! matrices of order M which are returned by CLATSQR @@ -63664,8 +63666,8 @@ module stdlib_linalg_lapack_c ! -- 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 complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(in) :: t(ldt,*) @@ -63674,85 +63676,85 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: lquery - integer(ilp) :: iinfo, ldc, lworkopt, lc, lw, nblocal, j + integer(${ik}$) :: iinfo, ldc, lworkopt, lc, lw, nblocal, j ! Intrinsic Functions intrinsic :: cmplx,max,min ! Executable Statements ! test the input parameters - lquery = lwork==-1 - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 .or. m0 .and. n>0 ) then + if( info==0_${ik}$ ) then + if( m>0_${ik}$ .and. n>0_${ik}$ ) then if( applyq ) then if( left ) then - nb = stdlib_ilaenv( 1, 'CUNMQR', side // trans, m-1, n, m-1,-1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMQR', side // trans, m-1, n, m-1,-1_${ik}$ ) else - nb = stdlib_ilaenv( 1, 'CUNMQR', side // trans, m, n-1, n-1,-1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMQR', side // trans, m, n-1, n-1,-1_${ik}$ ) end if else if( left ) then - nb = stdlib_ilaenv( 1, 'CUNMLQ', side // trans, m-1, n, m-1,-1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMLQ', side // trans, m-1, n, m-1,-1_${ik}$ ) else - nb = stdlib_ilaenv( 1, 'CUNMLQ', side // trans, m, n-1, n-1,-1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMLQ', side // trans, m, n-1, n-1,-1_${ik}$ ) end if end if lwkopt = nw*nb else - lwkopt = 1 + lwkopt = 1_${ik}$ end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt end if - if( info/=0 ) then - call stdlib_xerbla( 'CUNMBR', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'CUNMBR', -info ) return else if( lquery ) then return @@ -63861,23 +63863,23 @@ module stdlib_linalg_lapack_c if( applyq ) then ! apply q if( nq>=k ) then - ! q was determined by a call to stdlib_cgebrd with nq >= k - call stdlib_cunmqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, iinfo & + ! q was determined by a call to stdlib${ii}$_cgebrd with nq >= k + call stdlib${ii}$_cunmqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, iinfo & ) - else if( nq>1 ) then - ! q was determined by a call to stdlib_cgebrd with nq < k + else if( nq>1_${ik}$ ) then + ! q was determined by a call to stdlib${ii}$_cgebrd with nq < k if( left ) then - mi = m - 1 + mi = m - 1_${ik}$ ni = n - i1 = 2 - i2 = 1 + i1 = 2_${ik}$ + i2 = 1_${ik}$ else mi = m - ni = n - 1 - i1 = 1 - i2 = 2 + ni = n - 1_${ik}$ + i1 = 1_${ik}$ + i2 = 2_${ik}$ end if - call stdlib_cunmqr( side, trans, mi, ni, nq-1, a( 2, 1 ), lda, tau,c( i1, i2 ), & + call stdlib${ii}$_cunmqr( side, trans, mi, ni, nq-1, a( 2_${ik}$, 1_${ik}$ ), lda, tau,c( i1, i2 ), & ldc, work, lwork, iinfo ) end if else @@ -63888,32 +63890,32 @@ module stdlib_linalg_lapack_c transt = 'N' end if if( nq>k ) then - ! p was determined by a call to stdlib_cgebrd with nq > k - call stdlib_cunmlq( side, transt, m, n, k, a, lda, tau, c, ldc,work, lwork, & + ! p was determined by a call to stdlib${ii}$_cgebrd with nq > k + call stdlib${ii}$_cunmlq( side, transt, m, n, k, a, lda, tau, c, ldc,work, lwork, & iinfo ) - else if( nq>1 ) then - ! p was determined by a call to stdlib_cgebrd with nq <= k + else if( nq>1_${ik}$ ) then + ! p was determined by a call to stdlib${ii}$_cgebrd with nq <= k if( left ) then - mi = m - 1 + mi = m - 1_${ik}$ ni = n - i1 = 2 - i2 = 1 + i1 = 2_${ik}$ + i2 = 1_${ik}$ else mi = m - ni = n - 1 - i1 = 1 - i2 = 2 + ni = n - 1_${ik}$ + i1 = 1_${ik}$ + i2 = 2_${ik}$ end if - call stdlib_cunmlq( side, transt, mi, ni, nq-1, a( 1, 2 ), lda,tau, c( i1, i2 ), & + call stdlib${ii}$_cunmlq( side, transt, mi, ni, nq-1, a( 1_${ik}$, 2_${ik}$ ), lda,tau, c( i1, i2 ), & ldc, work, lwork, iinfo ) end if end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_cunmbr + end subroutine stdlib${ii}$_cunmbr - pure subroutine stdlib_cgelq( m, n, a, lda, t, tsize, work, lwork,info ) + pure subroutine stdlib${ii}$_cgelq( m, n, a, lda, t, tsize, work, lwork,info ) !! CGELQ computes an LQ factorization of a complex M-by-N matrix A: !! A = ( L 0 ) * Q !! where: @@ -63924,121 +63926,121 @@ module stdlib_linalg_lapack_c ! -- 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, tsize, lwork + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, tsize, lwork ! Array Arguments complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: t(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, lminws, mint, minw - integer(ilp) :: mb, nb, mintsz, nblcks, lwmin, lwopt, lwreq + integer(${ik}$) :: mb, nb, mintsz, nblcks, lwmin, lwopt, lwreq ! Intrinsic Functions intrinsic :: max,min,mod ! Executable Statements ! test the input arguments - info = 0 - lquery = ( tsize==-1 .or. tsize==-2 .or.lwork==-1 .or. lwork==-2 ) + info = 0_${ik}$ + lquery = ( tsize==-1_${ik}$ .or. tsize==-2_${ik}$ .or.lwork==-1_${ik}$ .or. lwork==-2_${ik}$ ) mint = .false. minw = .false. - if( tsize==-2 .or. lwork==-2 ) then - if( tsize/=-1 ) mint = .true. - if( lwork/=-1 ) minw = .true. + if( tsize==-2_${ik}$ .or. lwork==-2_${ik}$ ) then + if( tsize/=-1_${ik}$ ) mint = .true. + if( lwork/=-1_${ik}$ ) minw = .true. end if ! determine the block size - if( min( m, n )>0 ) then - mb = stdlib_ilaenv( 1, 'CGELQ ', ' ', m, n, 1, -1 ) - nb = stdlib_ilaenv( 1, 'CGELQ ', ' ', m, n, 2, -1 ) + if( min( m, n )>0_${ik}$ ) then + mb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CGELQ ', ' ', m, n, 1_${ik}$, -1_${ik}$ ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CGELQ ', ' ', m, n, 2_${ik}$, -1_${ik}$ ) else - mb = 1 + mb = 1_${ik}$ nb = n end if - if( mb>min( m, n ) .or. mb<1 ) mb = 1 + if( mb>min( m, n ) .or. mb<1_${ik}$ ) mb = 1_${ik}$ if( nb>n .or. nb<=m ) nb = n - mintsz = m + 5 + mintsz = m + 5_${ik}$ if( nb>m .and. n>m ) then - if( mod( n - m, nb - m )==0 ) then + if( mod( n - m, nb - m )==0_${ik}$ ) then nblcks = ( n - m ) / ( nb - m ) else - nblcks = ( n - m ) / ( nb - m ) + 1 + nblcks = ( n - m ) / ( nb - m ) + 1_${ik}$ end if else - nblcks = 1 + nblcks = 1_${ik}$ end if ! determine if the workspace size satisfies minimal size if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then - lwmin = max( 1, n ) - lwopt = max( 1, mb*n ) + lwmin = max( 1_${ik}$, n ) + lwopt = max( 1_${ik}$, mb*n ) else - lwmin = max( 1, m ) - lwopt = max( 1, mb*m ) + lwmin = max( 1_${ik}$, m ) + lwopt = max( 1_${ik}$, mb*m ) end if lminws = .false. - if( ( tsize=lwmin ) .and. ( & + if( ( tsize=lwmin ) .and. ( & tsize>=mintsz ).and. ( .not.lquery ) ) then - if( tsize=n ) ) then - lwreq = max( 1, mb*n ) + lwreq = max( 1_${ik}$, mb*n ) else - lwreq = max( 1, mb*m ) - end if - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda=n ) ) then - call stdlib_cgelqt( m, n, mb, a, lda, t( 6 ), mb, work, info ) + call stdlib${ii}$_cgelqt( m, n, mb, a, lda, t( 6_${ik}$ ), mb, work, info ) else - call stdlib_claswlq( m, n, mb, nb, a, lda, t( 6 ), mb, work,lwork, info ) + call stdlib${ii}$_claswlq( m, n, mb, nb, a, lda, t( 6_${ik}$ ), mb, work,lwork, info ) end if - work( 1 ) = lwreq + work( 1_${ik}$ ) = lwreq return - end subroutine stdlib_cgelq + end subroutine stdlib${ii}$_cgelq - subroutine stdlib_cgelsd( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, rwork, & + subroutine stdlib${ii}$_cgelsd( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, rwork, & !! CGELSD computes the minimum-norm solution to a real linear least !! squares problem: !! minimize 2-norm(| b - A*x |) @@ -64069,11 +64071,11 @@ module stdlib_linalg_lapack_c ! -- 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, rank - integer(ilp), intent(in) :: lda, ldb, lwork, m, n, nrhs + integer(${ik}$), intent(out) :: info, rank + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, nrhs real(sp), intent(in) :: rcond ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(out) :: rwork(*), s(*) complex(sp), intent(inout) :: a(lda,*), b(ldb,*) complex(sp), intent(out) :: work(*) @@ -64082,160 +64084,160 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: lquery - integer(ilp) :: iascl, ibscl, ie, il, itau, itaup, itauq, ldwork, liwork, lrwork, & + integer(${ik}$) :: iascl, ibscl, ie, il, itau, itaup, itauq, ldwork, liwork, lrwork, & maxmn, maxwrk, minmn, minwrk, mm, mnthr, nlvl, nrwork, nwork, smlsiz real(sp) :: anrm, bignum, bnrm, eps, sfmin, smlnum ! Intrinsic Functions intrinsic :: int,log,max,min,real ! Executable Statements ! test the input arguments. - info = 0 + info = 0_${ik}$ minmn = min( m, n ) maxmn = max( m, n ) - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( lda0 ) then - smlsiz = stdlib_ilaenv( 9, 'CGELSD', ' ', 0, 0, 0, 0 ) - mnthr = stdlib_ilaenv( 6, 'CGELSD', ' ', m, n, nrhs, -1 ) - nlvl = max( int( log( real( minmn,KIND=sp) / real( smlsiz + 1,KIND=sp) ) /log( & - two ),KIND=ilp) + 1, 0 ) - liwork = 3*minmn*nlvl + 11*minmn + ! following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + liwork = 1_${ik}$ + lrwork = 1_${ik}$ + if( minmn>0_${ik}$ ) then + smlsiz = stdlib${ii}$_ilaenv( 9_${ik}$, 'CGELSD', ' ', 0_${ik}$, 0_${ik}$, 0_${ik}$, 0_${ik}$ ) + mnthr = stdlib${ii}$_ilaenv( 6_${ik}$, 'CGELSD', ' ', m, n, nrhs, -1_${ik}$ ) + nlvl = max( int( log( real( minmn,KIND=sp) / real( smlsiz + 1_${ik}$,KIND=sp) ) /log( & + two ),KIND=${ik}$) + 1_${ik}$, 0_${ik}$ ) + liwork = 3_${ik}$*minmn*nlvl + 11_${ik}$*minmn mm = m if( m>=n .and. m>=mnthr ) then ! path 1a - overdetermined, with many more rows than ! columns. mm = n - maxwrk = max( maxwrk, n*stdlib_ilaenv( 1, 'CGEQRF', ' ', m, n,-1, -1 ) ) + maxwrk = max( maxwrk, n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEQRF', ' ', m, n,-1_${ik}$, -1_${ik}$ ) ) - maxwrk = max( maxwrk, nrhs*stdlib_ilaenv( 1, 'CUNMQR', 'LC', m,nrhs, n, -1 ) ) + maxwrk = max( maxwrk, nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMQR', 'LC', m,nrhs, n, -1_${ik}$ ) ) end if if( m>=n ) then ! path 1 - overdetermined or exactly determined. - lrwork = 10*n + 2*n*smlsiz + 8*n*nlvl + 3*smlsiz*nrhs +max( (smlsiz+1)**2, n*(& - 1+nrhs) + 2*nrhs ) - maxwrk = max( maxwrk, 2*n + ( mm + n )*stdlib_ilaenv( 1,'CGEBRD', ' ', mm, n, & - -1, -1 ) ) - maxwrk = max( maxwrk, 2*n + nrhs*stdlib_ilaenv( 1, 'CUNMBR','QLC', mm, nrhs, & - n, -1 ) ) - maxwrk = max( maxwrk, 2*n + ( n - 1 )*stdlib_ilaenv( 1,'CUNMBR', 'PLN', n, & - nrhs, n, -1 ) ) - maxwrk = max( maxwrk, 2*n + n*nrhs ) - minwrk = max( 2*n + mm, 2*n + n*nrhs ) + lrwork = 10_${ik}$*n + 2_${ik}$*n*smlsiz + 8_${ik}$*n*nlvl + 3_${ik}$*smlsiz*nrhs +max( (smlsiz+1)**2_${ik}$, n*(& + 1_${ik}$+nrhs) + 2_${ik}$*nrhs ) + maxwrk = max( maxwrk, 2_${ik}$*n + ( mm + n )*stdlib${ii}$_ilaenv( 1_${ik}$,'CGEBRD', ' ', mm, n, & + -1_${ik}$, -1_${ik}$ ) ) + maxwrk = max( maxwrk, 2_${ik}$*n + nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMBR','QLC', mm, nrhs, & + n, -1_${ik}$ ) ) + maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'CUNMBR', 'PLN', n, & + nrhs, n, -1_${ik}$ ) ) + maxwrk = max( maxwrk, 2_${ik}$*n + n*nrhs ) + minwrk = max( 2_${ik}$*n + mm, 2_${ik}$*n + n*nrhs ) end if if( n>m ) then - lrwork = 10*m + 2*m*smlsiz + 8*m*nlvl + 3*smlsiz*nrhs +max( (smlsiz+1)**2, n*(& - 1+nrhs) + 2*nrhs ) + lrwork = 10_${ik}$*m + 2_${ik}$*m*smlsiz + 8_${ik}$*m*nlvl + 3_${ik}$*smlsiz*nrhs +max( (smlsiz+1)**2_${ik}$, n*(& + 1_${ik}$+nrhs) + 2_${ik}$*nrhs ) if( n>=mnthr ) then ! path 2a - underdetermined, with many more columns ! than rows. - maxwrk = m + m*stdlib_ilaenv( 1, 'CGELQF', ' ', m, n, -1,-1 ) - maxwrk = max( maxwrk, m*m + 4*m + 2*m*stdlib_ilaenv( 1,'CGEBRD', ' ', m, m,& - -1, -1 ) ) - maxwrk = max( maxwrk, m*m + 4*m + nrhs*stdlib_ilaenv( 1,'CUNMBR', 'QLC', m,& - nrhs, m, -1 ) ) - maxwrk = max( maxwrk, m*m + 4*m + ( m - 1 )*stdlib_ilaenv( 1,'CUNMLQ', & - 'LC', n, nrhs, m, -1 ) ) - if( nrhs>1 ) then + maxwrk = m + m*stdlib${ii}$_ilaenv( 1_${ik}$, 'CGELQF', ' ', m, n, -1_${ik}$,-1_${ik}$ ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + 2_${ik}$*m*stdlib${ii}$_ilaenv( 1_${ik}$,'CGEBRD', ' ', m, m,& + -1_${ik}$, -1_${ik}$ ) ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + nrhs*stdlib${ii}$_ilaenv( 1_${ik}$,'CUNMBR', 'QLC', m,& + nrhs, m, -1_${ik}$ ) ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + ( m - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'CUNMLQ', & + 'LC', n, nrhs, m, -1_${ik}$ ) ) + if( nrhs>1_${ik}$ ) then maxwrk = max( maxwrk, m*m + m + m*nrhs ) else - maxwrk = max( maxwrk, m*m + 2*m ) + maxwrk = max( maxwrk, m*m + 2_${ik}$*m ) end if - maxwrk = max( maxwrk, m*m + 4*m + m*nrhs ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + m*nrhs ) ! xxx: ensure the path 2a case below is triggered. the workspace ! calculation should use queries for all routines eventually. - maxwrk = max( maxwrk,4*m+m*m+max( m, 2*m-4, nrhs, n-3*m ) ) + maxwrk = max( maxwrk,4_${ik}$*m+m*m+max( m, 2_${ik}$*m-4, nrhs, n-3*m ) ) else ! path 2 - underdetermined. - maxwrk = 2*m + ( n + m )*stdlib_ilaenv( 1, 'CGEBRD', ' ', m,n, -1, -1 ) + maxwrk = 2_${ik}$*m + ( n + m )*stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEBRD', ' ', m,n, -1_${ik}$, -1_${ik}$ ) - maxwrk = max( maxwrk, 2*m + nrhs*stdlib_ilaenv( 1, 'CUNMBR','QLC', m, nrhs,& - m, -1 ) ) - maxwrk = max( maxwrk, 2*m + m*stdlib_ilaenv( 1, 'CUNMBR','PLN', n, nrhs, m,& - -1 ) ) - maxwrk = max( maxwrk, 2*m + m*nrhs ) + maxwrk = max( maxwrk, 2_${ik}$*m + nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMBR','QLC', m, nrhs,& + m, -1_${ik}$ ) ) + maxwrk = max( maxwrk, 2_${ik}$*m + m*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMBR','PLN', n, nrhs, m,& + -1_${ik}$ ) ) + maxwrk = max( maxwrk, 2_${ik}$*m + m*nrhs ) end if - minwrk = max( 2*m + n, 2*m + m*nrhs ) + minwrk = max( 2_${ik}$*m + n, 2_${ik}$*m + m*nrhs ) end if end if minwrk = min( minwrk, maxwrk ) - work( 1 ) = maxwrk - iwork( 1 ) = liwork - rwork( 1 ) = lrwork + work( 1_${ik}$ ) = maxwrk + iwork( 1_${ik}$ ) = liwork + rwork( 1_${ik}$ ) = lrwork if( lworkzero .and. anrmbignum ) then ! scale matrix norm down to bignum. - call stdlib_clascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_claset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) - call stdlib_slaset( 'F', minmn, 1, zero, zero, s, 1 ) - rank = 0 + call stdlib${ii}$_claset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) + call stdlib${ii}$_slaset( 'F', minmn, 1_${ik}$, zero, zero, s, 1_${ik}$ ) + rank = 0_${ik}$ go to 10 end if ! scale b if max entry outside range [smlnum,bignum]. - bnrm = stdlib_clange( 'M', m, nrhs, b, ldb, rwork ) - ibscl = 0 + bnrm = stdlib${ii}$_clange( 'M', m, nrhs, b, ldb, rwork ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum. - call stdlib_clascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) - ibscl = 2 + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, m, nrhs, b, ldb, info ) + ibscl = 2_${ik}$ end if ! if m < n make sure b(m+1:n,:) = 0 - if( m=n ) then ! path 1 - overdetermined or exactly determined. @@ -64243,140 +64245,140 @@ module stdlib_linalg_lapack_c if( m>=mnthr ) then ! path 1a - overdetermined, with many more rows than columns mm = n - itau = 1 + itau = 1_${ik}$ nwork = itau + n ! compute a=q*r. ! (rworkspace: need n) ! (cworkspace: need n, prefer n*nb) - call stdlib_cgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_cgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & info ) ! multiply b by transpose(q). ! (rworkspace: need n) ! (cworkspace: need nrhs, prefer nrhs*nb) - call stdlib_cunmqr( 'L', 'C', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & + call stdlib${ii}$_cunmqr( 'L', 'C', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & nwork ), lwork-nwork+1, info ) ! zero out below r. - if( n>1 ) then - call stdlib_claset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_claset( 'L', n-1, n-1, czero, czero, a( 2_${ik}$, 1_${ik}$ ),lda ) end if end if - itauq = 1 + itauq = 1_${ik}$ itaup = itauq + n nwork = itaup + n - ie = 1 + ie = 1_${ik}$ nrwork = ie + n ! bidiagonalize r in a. ! (rworkspace: need n) ! (cworkspace: need 2*n+mm, prefer 2*n+(mm+n)*nb) - call stdlib_cgebrd( mm, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_cgebrd( mm, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors of r. ! (cworkspace: need 2*n+nrhs, prefer 2*n+nrhs*nb) - call stdlib_cunmbr( 'Q', 'L', 'C', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib${ii}$_cunmbr( 'Q', 'L', 'C', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & nwork ), lwork-nwork+1, info ) ! solve the bidiagonal least squares problem. - call stdlib_clalsd( 'U', smlsiz, n, nrhs, s, rwork( ie ), b, ldb,rcond, rank, work( & + call stdlib${ii}$_clalsd( 'U', smlsiz, n, nrhs, s, rwork( ie ), b, ldb,rcond, rank, work( & nwork ), rwork( nrwork ),iwork, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then go to 10 end if ! multiply b by right bidiagonalizing vectors of r. - call stdlib_cunmbr( 'P', 'L', 'N', n, nrhs, n, a, lda, work( itaup ),b, ldb, work( & + call stdlib${ii}$_cunmbr( 'P', 'L', 'N', n, nrhs, n, a, lda, work( itaup ),b, ldb, work( & nwork ), lwork-nwork+1, info ) - else if( n>=mnthr .and. lwork>=4*m+m*m+max( m, 2*m-4, nrhs, n-3*m ) ) then + else if( n>=mnthr .and. lwork>=4_${ik}$*m+m*m+max( m, 2_${ik}$*m-4, nrhs, n-3*m ) ) then ! path 2a - underdetermined, with many more columns than rows ! and sufficient workspace for an efficient algorithm. ldwork = m - if( lwork>=max( 4*m+m*lda+max( m, 2*m-4, nrhs, n-3*m ),m*lda+m+m*nrhs ) )ldwork = & + if( lwork>=max( 4_${ik}$*m+m*lda+max( m, 2_${ik}$*m-4, nrhs, n-3*m ),m*lda+m+m*nrhs ) )ldwork = & lda - itau = 1 - nwork = m + 1 + itau = 1_${ik}$ + nwork = m + 1_${ik}$ ! compute a=l*q. ! (cworkspace: need 2*m, prefer m+m*nb) - call stdlib_cgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, info ) + call stdlib${ii}$_cgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, info ) il = nwork ! copy l to work(il), zeroing out above its diagonal. - call stdlib_clacpy( 'L', m, m, a, lda, work( il ), ldwork ) - call stdlib_claset( 'U', m-1, m-1, czero, czero, work( il+ldwork ),ldwork ) + call stdlib${ii}$_clacpy( 'L', m, m, a, lda, work( il ), ldwork ) + call stdlib${ii}$_claset( 'U', m-1, m-1, czero, czero, work( il+ldwork ),ldwork ) itauq = il + ldwork*m itaup = itauq + m nwork = itaup + m - ie = 1 + ie = 1_${ik}$ nrwork = ie + m ! bidiagonalize l in work(il). ! (rworkspace: need m) ! (cworkspace: need m*m+4*m, prefer m*m+4*m+2*m*nb) - call stdlib_cgebrd( m, m, work( il ), ldwork, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_cgebrd( m, m, work( il ), ldwork, s, rwork( ie ),work( itauq ), work( & itaup ), work( nwork ),lwork-nwork+1, info ) ! multiply b by transpose of left bidiagonalizing vectors of l. ! (cworkspace: need m*m+4*m+nrhs, prefer m*m+4*m+nrhs*nb) - call stdlib_cunmbr( 'Q', 'L', 'C', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & + call stdlib${ii}$_cunmbr( 'Q', 'L', 'C', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & ldb, work( nwork ),lwork-nwork+1, info ) ! solve the bidiagonal least squares problem. - call stdlib_clalsd( 'U', smlsiz, m, nrhs, s, rwork( ie ), b, ldb,rcond, rank, work( & + call stdlib${ii}$_clalsd( 'U', smlsiz, m, nrhs, s, rwork( ie ), b, ldb,rcond, rank, work( & nwork ), rwork( nrwork ),iwork, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then go to 10 end if ! multiply b by right bidiagonalizing vectors of l. - call stdlib_cunmbr( 'P', 'L', 'N', m, nrhs, m, work( il ), ldwork,work( itaup ), b, & + call stdlib${ii}$_cunmbr( 'P', 'L', 'N', m, nrhs, m, work( il ), ldwork,work( itaup ), b, & ldb, work( nwork ),lwork-nwork+1, info ) ! zero out below first m rows of b. - call stdlib_claset( 'F', n-m, nrhs, czero, czero, b( m+1, 1 ), ldb ) + call stdlib${ii}$_claset( 'F', n-m, nrhs, czero, czero, b( m+1, 1_${ik}$ ), ldb ) nwork = itau + m ! multiply transpose(q) by b. ! (cworkspace: need nrhs, prefer nrhs*nb) - call stdlib_cunmlq( 'L', 'C', n, nrhs, m, a, lda, work( itau ), b,ldb, work( nwork )& + call stdlib${ii}$_cunmlq( 'L', 'C', n, nrhs, m, a, lda, work( itau ), b,ldb, work( nwork )& , lwork-nwork+1, info ) else ! path 2 - remaining underdetermined cases. - itauq = 1 + itauq = 1_${ik}$ itaup = itauq + m nwork = itaup + m - ie = 1 + ie = 1_${ik}$ nrwork = ie + m ! bidiagonalize a. ! (rworkspace: need m) ! (cworkspace: need 2*m+n, prefer 2*m+(m+n)*nb) - call stdlib_cgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), work(& + call stdlib${ii}$_cgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), work(& nwork ), lwork-nwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors. ! (cworkspace: need 2*m+nrhs, prefer 2*m+nrhs*nb) - call stdlib_cunmbr( 'Q', 'L', 'C', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib${ii}$_cunmbr( 'Q', 'L', 'C', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & nwork ), lwork-nwork+1, info ) ! solve the bidiagonal least squares problem. - call stdlib_clalsd( 'L', smlsiz, m, nrhs, s, rwork( ie ), b, ldb,rcond, rank, work( & + call stdlib${ii}$_clalsd( 'L', smlsiz, m, nrhs, s, rwork( ie ), b, ldb,rcond, rank, work( & nwork ), rwork( nrwork ),iwork, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then go to 10 end if ! multiply b by right bidiagonalizing vectors of a. - call stdlib_cunmbr( 'P', 'L', 'N', n, nrhs, m, a, lda, work( itaup ),b, ldb, work( & + call stdlib${ii}$_cunmbr( 'P', 'L', 'N', n, nrhs, m, a, lda, work( itaup ),b, ldb, work( & nwork ), lwork-nwork+1, info ) end if ! undo scaling. - if( iascl==1 ) then - call stdlib_clascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info ) - call stdlib_slascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn,info ) - else if( iascl==2 ) then - call stdlib_clascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info ) - call stdlib_slascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,info ) - end if - if( ibscl==1 ) then - call stdlib_clascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info ) - else if( ibscl==2 ) then - call stdlib_clascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info ) + if( iascl==1_${ik}$ ) then + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, smlnum, n, nrhs, b, ldb, info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, anrm, minmn, 1_${ik}$, s, minmn,info ) + else if( iascl==2_${ik}$ ) then + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, n, nrhs, b, ldb, info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn, 1_${ik}$, s, minmn,info ) + end if + if( ibscl==1_${ik}$ ) then + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, bnrm, n, nrhs, b, ldb, info ) + else if( ibscl==2_${ik}$ ) then + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bignum, bnrm, n, nrhs, b, ldb, info ) end if 10 continue - work( 1 ) = maxwrk - iwork( 1 ) = liwork - rwork( 1 ) = lrwork + work( 1_${ik}$ ) = maxwrk + iwork( 1_${ik}$ ) = liwork + rwork( 1_${ik}$ ) = lrwork return - end subroutine stdlib_cgelsd + end subroutine stdlib${ii}$_cgelsd - subroutine stdlib_cgelss( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, rwork, & + subroutine stdlib${ii}$_cgelss( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, rwork, & !! CGELSS computes the minimum norm solution to a complex linear !! least squares problem: !! Minimize 2-norm(| b - A*x |). @@ -64394,8 +64396,8 @@ module stdlib_linalg_lapack_c ! -- 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, rank - integer(ilp), intent(in) :: lda, ldb, lwork, m, n, nrhs + integer(${ik}$), intent(out) :: info, rank + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, nrhs real(sp), intent(in) :: rcond ! Array Arguments real(sp), intent(out) :: rwork(*), s(*) @@ -64406,31 +64408,31 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: lquery - integer(ilp) :: bl, chunk, i, iascl, ibscl, ie, il, irwork, itau, itaup, itauq, iwork, & + integer(${ik}$) :: bl, chunk, i, iascl, ibscl, ie, il, irwork, itau, itaup, itauq, iwork, & ldwork, maxmn, maxwrk, minmn, minwrk, mm, mnthr - integer(ilp) :: lwork_cgeqrf, lwork_cunmqr, lwork_cgebrd, lwork_cunmbr, lwork_cungbr, & + integer(${ik}$) :: lwork_cgeqrf, lwork_cunmqr, lwork_cgebrd, lwork_cunmbr, lwork_cungbr, & lwork_cunmlq, lwork_cgelqf real(sp) :: anrm, bignum, bnrm, eps, sfmin, smlnum, thr ! Local Arrays - complex(sp) :: dum(1) + complex(sp) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ minmn = min( m, n ) maxmn = max( m, n ) - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( lda0 ) then + ! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + if( minmn>0_${ik}$ ) then mm = m - mnthr = stdlib_ilaenv( 6, 'CGELSS', ' ', m, n, nrhs, -1 ) + mnthr = stdlib${ii}$_ilaenv( 6_${ik}$, 'CGELSS', ' ', m, n, nrhs, -1_${ik}$ ) if( m>=n .and. m>=mnthr ) then ! path 1a - overdetermined, with many more rows than ! columns - ! compute space needed for stdlib_cgeqrf - call stdlib_cgeqrf( m, n, a, lda, dum(1), dum(1), -1, info ) - lwork_cgeqrf = real( dum(1),KIND=sp) - ! compute space needed for stdlib_cunmqr - call stdlib_cunmqr( 'L', 'C', m, nrhs, n, a, lda, dum(1), b,ldb, dum(1), -1, & + ! compute space needed for stdlib${ii}$_cgeqrf + call stdlib${ii}$_cgeqrf( m, n, a, lda, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, info ) + lwork_cgeqrf = real( dum(1_${ik}$),KIND=sp) + ! compute space needed for stdlib${ii}$_cunmqr + call stdlib${ii}$_cunmqr( 'L', 'C', m, nrhs, n, a, lda, dum(1_${ik}$), b,ldb, dum(1_${ik}$), -1_${ik}$, & info ) - lwork_cunmqr = real( dum(1),KIND=sp) + lwork_cunmqr = real( dum(1_${ik}$),KIND=sp) mm = n - maxwrk = max( maxwrk, n + n*stdlib_ilaenv( 1, 'CGEQRF', ' ', m,n, -1, -1 ) ) + maxwrk = max( maxwrk, n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEQRF', ' ', m,n, -1_${ik}$, -1_${ik}$ ) ) - maxwrk = max( maxwrk, n + nrhs*stdlib_ilaenv( 1, 'CUNMQR', 'LC',m, nrhs, n, -& - 1 ) ) + maxwrk = max( maxwrk, n + nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMQR', 'LC',m, nrhs, n, -& + 1_${ik}$ ) ) end if if( m>=n ) then ! path 1 - overdetermined or exactly determined - ! compute space needed for stdlib_cgebrd - call stdlib_cgebrd( mm, n, a, lda, s, s, dum(1), dum(1), dum(1),-1, info ) + ! compute space needed for stdlib${ii}$_cgebrd + call stdlib${ii}$_cgebrd( mm, n, a, lda, s, s, dum(1_${ik}$), dum(1_${ik}$), dum(1_${ik}$),-1_${ik}$, info ) - lwork_cgebrd = real( dum(1),KIND=sp) - ! compute space needed for stdlib_cunmbr - call stdlib_cunmbr( 'Q', 'L', 'C', mm, nrhs, n, a, lda, dum(1),b, ldb, dum(1),& - -1, info ) - lwork_cunmbr = real( dum(1),KIND=sp) - ! compute space needed for stdlib_cungbr - call stdlib_cungbr( 'P', n, n, n, a, lda, dum(1),dum(1), -1, info ) - lwork_cungbr = real( dum(1),KIND=sp) + lwork_cgebrd = real( dum(1_${ik}$),KIND=sp) + ! compute space needed for stdlib${ii}$_cunmbr + call stdlib${ii}$_cunmbr( 'Q', 'L', 'C', mm, nrhs, n, a, lda, dum(1_${ik}$),b, ldb, dum(1_${ik}$),& + -1_${ik}$, info ) + lwork_cunmbr = real( dum(1_${ik}$),KIND=sp) + ! compute space needed for stdlib${ii}$_cungbr + call stdlib${ii}$_cungbr( 'P', n, n, n, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, info ) + lwork_cungbr = real( dum(1_${ik}$),KIND=sp) ! compute total workspace needed - maxwrk = max( maxwrk, 2*n + lwork_cgebrd ) - maxwrk = max( maxwrk, 2*n + lwork_cunmbr ) - maxwrk = max( maxwrk, 2*n + lwork_cungbr ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_cgebrd ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_cunmbr ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_cungbr ) maxwrk = max( maxwrk, n*nrhs ) - minwrk = 2*n + max( nrhs, m ) + minwrk = 2_${ik}$*n + max( nrhs, m ) end if if( n>m ) then - minwrk = 2*m + max( nrhs, n ) + minwrk = 2_${ik}$*m + max( nrhs, n ) if( n>=mnthr ) then ! path 2a - underdetermined, with many more columns ! than rows - ! compute space needed for stdlib_cgelqf - call stdlib_cgelqf( m, n, a, lda, dum(1), dum(1),-1, info ) - lwork_cgelqf = real( dum(1),KIND=sp) - ! compute space needed for stdlib_cgebrd - call stdlib_cgebrd( m, m, a, lda, s, s, dum(1), dum(1),dum(1), -1, info ) + ! compute space needed for stdlib${ii}$_cgelqf + call stdlib${ii}$_cgelqf( m, n, a, lda, dum(1_${ik}$), dum(1_${ik}$),-1_${ik}$, info ) + lwork_cgelqf = real( dum(1_${ik}$),KIND=sp) + ! compute space needed for stdlib${ii}$_cgebrd + call stdlib${ii}$_cgebrd( m, m, a, lda, s, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, info ) - lwork_cgebrd = real( dum(1),KIND=sp) - ! compute space needed for stdlib_cunmbr - call stdlib_cunmbr( 'Q', 'L', 'C', m, nrhs, n, a, lda,dum(1), b, ldb, dum(& - 1), -1, info ) - lwork_cunmbr = real( dum(1),KIND=sp) - ! compute space needed for stdlib_cungbr - call stdlib_cungbr( 'P', m, m, m, a, lda, dum(1),dum(1), -1, info ) - lwork_cungbr = real( dum(1),KIND=sp) - ! compute space needed for stdlib_cunmlq - call stdlib_cunmlq( 'L', 'C', n, nrhs, m, a, lda, dum(1),b, ldb, dum(1), -& - 1, info ) - lwork_cunmlq = real( dum(1),KIND=sp) + lwork_cgebrd = real( dum(1_${ik}$),KIND=sp) + ! compute space needed for stdlib${ii}$_cunmbr + call stdlib${ii}$_cunmbr( 'Q', 'L', 'C', m, nrhs, n, a, lda,dum(1_${ik}$), b, ldb, dum(& + 1_${ik}$), -1_${ik}$, info ) + lwork_cunmbr = real( dum(1_${ik}$),KIND=sp) + ! compute space needed for stdlib${ii}$_cungbr + call stdlib${ii}$_cungbr( 'P', m, m, m, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, info ) + lwork_cungbr = real( dum(1_${ik}$),KIND=sp) + ! compute space needed for stdlib${ii}$_cunmlq + call stdlib${ii}$_cunmlq( 'L', 'C', n, nrhs, m, a, lda, dum(1_${ik}$),b, ldb, dum(1_${ik}$), -& + 1_${ik}$, info ) + lwork_cunmlq = real( dum(1_${ik}$),KIND=sp) ! compute total workspace needed maxwrk = m + lwork_cgelqf - maxwrk = max( maxwrk, 3*m + m*m + lwork_cgebrd ) - maxwrk = max( maxwrk, 3*m + m*m + lwork_cunmbr ) - maxwrk = max( maxwrk, 3*m + m*m + lwork_cungbr ) - if( nrhs>1 ) then + maxwrk = max( maxwrk, 3_${ik}$*m + m*m + lwork_cgebrd ) + maxwrk = max( maxwrk, 3_${ik}$*m + m*m + lwork_cunmbr ) + maxwrk = max( maxwrk, 3_${ik}$*m + m*m + lwork_cungbr ) + if( nrhs>1_${ik}$ ) then maxwrk = max( maxwrk, m*m + m + m*nrhs ) else - maxwrk = max( maxwrk, m*m + 2*m ) + maxwrk = max( maxwrk, m*m + 2_${ik}$*m ) end if maxwrk = max( maxwrk, m + lwork_cunmlq ) else ! path 2 - underdetermined - ! compute space needed for stdlib_cgebrd - call stdlib_cgebrd( m, n, a, lda, s, s, dum(1), dum(1),dum(1), -1, info ) + ! compute space needed for stdlib${ii}$_cgebrd + call stdlib${ii}$_cgebrd( m, n, a, lda, s, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, info ) - lwork_cgebrd = real( dum(1),KIND=sp) - ! compute space needed for stdlib_cunmbr - call stdlib_cunmbr( 'Q', 'L', 'C', m, nrhs, m, a, lda,dum(1), b, ldb, dum(& - 1), -1, info ) - lwork_cunmbr = real( dum(1),KIND=sp) - ! compute space needed for stdlib_cungbr - call stdlib_cungbr( 'P', m, n, m, a, lda, dum(1),dum(1), -1, info ) - lwork_cungbr = real( dum(1),KIND=sp) - maxwrk = 2*m + lwork_cgebrd - maxwrk = max( maxwrk, 2*m + lwork_cunmbr ) - maxwrk = max( maxwrk, 2*m + lwork_cungbr ) + lwork_cgebrd = real( dum(1_${ik}$),KIND=sp) + ! compute space needed for stdlib${ii}$_cunmbr + call stdlib${ii}$_cunmbr( 'Q', 'L', 'C', m, nrhs, m, a, lda,dum(1_${ik}$), b, ldb, dum(& + 1_${ik}$), -1_${ik}$, info ) + lwork_cunmbr = real( dum(1_${ik}$),KIND=sp) + ! compute space needed for stdlib${ii}$_cungbr + call stdlib${ii}$_cungbr( 'P', m, n, m, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, info ) + lwork_cungbr = real( dum(1_${ik}$),KIND=sp) + maxwrk = 2_${ik}$*m + lwork_cgebrd + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_cunmbr ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_cungbr ) maxwrk = max( maxwrk, n*nrhs ) end if end if maxwrk = max( minwrk, maxwrk ) end if - work( 1 ) = maxwrk - if( lworkzero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_clascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_claset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) - call stdlib_slaset( 'F', minmn, 1, zero, zero, s, minmn ) - rank = 0 + call stdlib${ii}$_claset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) + call stdlib${ii}$_slaset( 'F', minmn, 1_${ik}$, zero, zero, s, minmn ) + rank = 0_${ik}$ go to 70 end if ! scale b if max element outside range [smlnum,bignum] - bnrm = stdlib_clange( 'M', m, nrhs, b, ldb, rwork ) - ibscl = 0 + bnrm = stdlib${ii}$_clange( 'M', m, nrhs, b, ldb, rwork ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_clascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) - ibscl = 2 + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, m, nrhs, b, ldb, info ) + ibscl = 2_${ik}$ end if ! overdetermined case if( m>=n ) then @@ -64593,115 +64595,115 @@ module stdlib_linalg_lapack_c if( m>=mnthr ) then ! path 1a - overdetermined, with many more rows than columns mm = n - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: none) - call stdlib_cgeqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & + call stdlib${ii}$_cgeqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & info ) ! multiply b by transpose(q) ! (cworkspace: need n+nrhs, prefer n+nrhs*nb) ! (rworkspace: none) - call stdlib_cunmqr( 'L', 'C', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & + call stdlib${ii}$_cunmqr( 'L', 'C', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & iwork ), lwork-iwork+1, info ) ! zero out below r - if( n>1 )call stdlib_claset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) + if( n>1_${ik}$ )call stdlib${ii}$_claset( 'L', n-1, n-1, czero, czero, a( 2_${ik}$, 1_${ik}$ ),lda ) end if - ie = 1 - itauq = 1 + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + n iwork = itaup + n ! bidiagonalize r in a ! (cworkspace: need 2*n+mm, prefer 2*n+(mm+n)*nb) ! (rworkspace: need n) - call stdlib_cgebrd( mm, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_cgebrd( mm, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors of r ! (cworkspace: need 2*n+nrhs, prefer 2*n+nrhs*nb) ! (rworkspace: none) - call stdlib_cunmbr( 'Q', 'L', 'C', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib${ii}$_cunmbr( 'Q', 'L', 'C', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & iwork ), lwork-iwork+1, info ) ! generate right bidiagonalizing vectors of r in a ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: none) - call stdlib_cungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-iwork+& - 1, info ) + call stdlib${ii}$_cungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-iwork+& + 1_${ik}$, info ) irwork = ie + n ! perform bidiagonal qr iteration ! multiply b by transpose of left singular vectors ! compute right singular vectors in a ! (cworkspace: none) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', n, n, 0, nrhs, s, rwork( ie ), a, lda, dum,1, b, ldb, & + call stdlib${ii}$_cbdsqr( 'U', n, n, 0_${ik}$, nrhs, s, rwork( ie ), a, lda, dum,1_${ik}$, b, ldb, & rwork( irwork ), info ) if( info/=0 )go to 70 ! multiply b by reciprocals of singular values - thr = max( rcond*s( 1 ), sfmin ) - if( rcondthr ) then - call stdlib_csrscl( nrhs, s( i ), b( i, 1 ), ldb ) - rank = rank + 1 + call stdlib${ii}$_csrscl( nrhs, s( i ), b( i, 1_${ik}$ ), ldb ) + rank = rank + 1_${ik}$ else - call stdlib_claset( 'F', 1, nrhs, czero, czero, b( i, 1 ), ldb ) + call stdlib${ii}$_claset( 'F', 1_${ik}$, nrhs, czero, czero, b( i, 1_${ik}$ ), ldb ) end if end do ! multiply b by right singular vectors ! (cworkspace: need n, prefer n*nrhs) ! (rworkspace: none) - if( lwork>=ldb*nrhs .and. nrhs>1 ) then - call stdlib_cgemm( 'C', 'N', n, nrhs, n, cone, a, lda, b, ldb,czero, work, ldb ) + if( lwork>=ldb*nrhs .and. nrhs>1_${ik}$ ) then + call stdlib${ii}$_cgemm( 'C', 'N', n, nrhs, n, cone, a, lda, b, ldb,czero, work, ldb ) - call stdlib_clacpy( 'G', n, nrhs, work, ldb, b, ldb ) - else if( nrhs>1 ) then + call stdlib${ii}$_clacpy( 'G', n, nrhs, work, ldb, b, ldb ) + else if( nrhs>1_${ik}$ ) then chunk = lwork / n do i = 1, nrhs, chunk bl = min( nrhs-i+1, chunk ) - call stdlib_cgemm( 'C', 'N', n, bl, n, cone, a, lda, b( 1, i ),ldb, czero, & + call stdlib${ii}$_cgemm( 'C', 'N', n, bl, n, cone, a, lda, b( 1_${ik}$, i ),ldb, czero, & work, n ) - call stdlib_clacpy( 'G', n, bl, work, n, b( 1, i ), ldb ) + call stdlib${ii}$_clacpy( 'G', n, bl, work, n, b( 1_${ik}$, i ), ldb ) end do else - call stdlib_cgemv( 'C', n, n, cone, a, lda, b, 1, czero, work, 1 ) - call stdlib_ccopy( n, work, 1, b, 1 ) + call stdlib${ii}$_cgemv( 'C', n, n, cone, a, lda, b, 1_${ik}$, czero, work, 1_${ik}$ ) + call stdlib${ii}$_ccopy( n, work, 1_${ik}$, b, 1_${ik}$ ) end if - else if( n>=mnthr .and. lwork>=3*m+m*m+max( m, nrhs, n-2*m ) )then + else if( n>=mnthr .and. lwork>=3_${ik}$*m+m*m+max( m, nrhs, n-2*m ) )then ! underdetermined case, m much less than n ! path 2a - underdetermined, with many more columns than rows ! and sufficient workspace for an efficient algorithm ldwork = m - if( lwork>=3*m+m*lda+max( m, nrhs, n-2*m ) )ldwork = lda - itau = 1 - iwork = m + 1 + if( lwork>=3_${ik}$*m+m*lda+max( m, nrhs, n-2*m ) )ldwork = lda + itau = 1_${ik}$ + iwork = m + 1_${ik}$ ! compute a=l*q ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: none) - call stdlib_cgelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, info ) + call stdlib${ii}$_cgelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, info ) il = iwork ! copy l to work(il), zeroing out above it - call stdlib_clacpy( 'L', m, m, a, lda, work( il ), ldwork ) - call stdlib_claset( 'U', m-1, m-1, czero, czero, work( il+ldwork ),ldwork ) - ie = 1 + call stdlib${ii}$_clacpy( 'L', m, m, a, lda, work( il ), ldwork ) + call stdlib${ii}$_claset( 'U', m-1, m-1, czero, czero, work( il+ldwork ),ldwork ) + ie = 1_${ik}$ itauq = il + ldwork*m itaup = itauq + m iwork = itaup + m ! bidiagonalize l in work(il) ! (cworkspace: need m*m+4*m, prefer m*m+3*m+2*m*nb) ! (rworkspace: need m) - call stdlib_cgebrd( m, m, work( il ), ldwork, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_cgebrd( m, m, work( il ), ldwork, s, rwork( ie ),work( itauq ), work( & itaup ), work( iwork ),lwork-iwork+1, info ) ! multiply b by transpose of left bidiagonalizing vectors of l ! (cworkspace: need m*m+3*m+nrhs, prefer m*m+3*m+nrhs*nb) ! (rworkspace: none) - call stdlib_cunmbr( 'Q', 'L', 'C', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & + call stdlib${ii}$_cunmbr( 'Q', 'L', 'C', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & ldb, work( iwork ),lwork-iwork+1, info ) ! generate right bidiagonalizing vectors of r in work(il) ! (cworkspace: need m*m+4*m-1, prefer m*m+3*m+(m-1)*nb) ! (rworkspace: none) - call stdlib_cungbr( 'P', m, m, m, work( il ), ldwork, work( itaup ),work( iwork ), & + call stdlib${ii}$_cungbr( 'P', m, m, m, work( il ), ldwork, work( itaup ),work( iwork ), & lwork-iwork+1, info ) irwork = ie + m ! perform bidiagonal qr iteration, computing right singular @@ -64709,132 +64711,132 @@ module stdlib_linalg_lapack_c ! left singular vectors ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', m, m, 0, nrhs, s, rwork( ie ), work( il ),ldwork, a, lda, & + call stdlib${ii}$_cbdsqr( 'U', m, m, 0_${ik}$, nrhs, s, rwork( ie ), work( il ),ldwork, a, lda, & b, ldb, rwork( irwork ), info ) if( info/=0 )go to 70 ! multiply b by reciprocals of singular values - thr = max( rcond*s( 1 ), sfmin ) - if( rcondthr ) then - call stdlib_csrscl( nrhs, s( i ), b( i, 1 ), ldb ) - rank = rank + 1 + call stdlib${ii}$_csrscl( nrhs, s( i ), b( i, 1_${ik}$ ), ldb ) + rank = rank + 1_${ik}$ else - call stdlib_claset( 'F', 1, nrhs, czero, czero, b( i, 1 ), ldb ) + call stdlib${ii}$_claset( 'F', 1_${ik}$, nrhs, czero, czero, b( i, 1_${ik}$ ), ldb ) end if end do iwork = il + m*ldwork ! multiply b by right singular vectors of l in work(il) ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nrhs) ! (rworkspace: none) - if( lwork>=ldb*nrhs+iwork-1 .and. nrhs>1 ) then - call stdlib_cgemm( 'C', 'N', m, nrhs, m, cone, work( il ), ldwork,b, ldb, czero, & + if( lwork>=ldb*nrhs+iwork-1 .and. nrhs>1_${ik}$ ) then + call stdlib${ii}$_cgemm( 'C', 'N', m, nrhs, m, cone, work( il ), ldwork,b, ldb, czero, & work( iwork ), ldb ) - call stdlib_clacpy( 'G', m, nrhs, work( iwork ), ldb, b, ldb ) - else if( nrhs>1 ) then + call stdlib${ii}$_clacpy( 'G', m, nrhs, work( iwork ), ldb, b, ldb ) + else if( nrhs>1_${ik}$ ) then chunk = ( lwork-iwork+1 ) / m do i = 1, nrhs, chunk bl = min( nrhs-i+1, chunk ) - call stdlib_cgemm( 'C', 'N', m, bl, m, cone, work( il ), ldwork,b( 1, i ), & + call stdlib${ii}$_cgemm( 'C', 'N', m, bl, m, cone, work( il ), ldwork,b( 1_${ik}$, i ), & ldb, czero, work( iwork ), m ) - call stdlib_clacpy( 'G', m, bl, work( iwork ), m, b( 1, i ),ldb ) + call stdlib${ii}$_clacpy( 'G', m, bl, work( iwork ), m, b( 1_${ik}$, i ),ldb ) end do else - call stdlib_cgemv( 'C', m, m, cone, work( il ), ldwork, b( 1, 1 ),1, czero, work(& - iwork ), 1 ) - call stdlib_ccopy( m, work( iwork ), 1, b( 1, 1 ), 1 ) + call stdlib${ii}$_cgemv( 'C', m, m, cone, work( il ), ldwork, b( 1_${ik}$, 1_${ik}$ ),1_${ik}$, czero, work(& + iwork ), 1_${ik}$ ) + call stdlib${ii}$_ccopy( m, work( iwork ), 1_${ik}$, b( 1_${ik}$, 1_${ik}$ ), 1_${ik}$ ) end if ! zero out below first m rows of b - call stdlib_claset( 'F', n-m, nrhs, czero, czero, b( m+1, 1 ), ldb ) + call stdlib${ii}$_claset( 'F', n-m, nrhs, czero, czero, b( m+1, 1_${ik}$ ), ldb ) iwork = itau + m ! multiply transpose(q) by b ! (cworkspace: need m+nrhs, prefer m+nhrs*nb) ! (rworkspace: none) - call stdlib_cunmlq( 'L', 'C', n, nrhs, m, a, lda, work( itau ), b,ldb, work( iwork )& + call stdlib${ii}$_cunmlq( 'L', 'C', n, nrhs, m, a, lda, work( itau ), b,ldb, work( iwork )& , lwork-iwork+1, info ) else ! path 2 - remaining underdetermined cases - ie = 1 - itauq = 1 + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + m iwork = itaup + m ! bidiagonalize a ! (cworkspace: need 3*m, prefer 2*m+(m+n)*nb) ! (rworkspace: need n) - call stdlib_cgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), work(& + call stdlib${ii}$_cgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), work(& iwork ), lwork-iwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors ! (cworkspace: need 2*m+nrhs, prefer 2*m+nrhs*nb) ! (rworkspace: none) - call stdlib_cunmbr( 'Q', 'L', 'C', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib${ii}$_cunmbr( 'Q', 'L', 'C', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & iwork ), lwork-iwork+1, info ) ! generate right bidiagonalizing vectors in a ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: none) - call stdlib_cungbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-iwork+& - 1, info ) + call stdlib${ii}$_cungbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-iwork+& + 1_${ik}$, info ) irwork = ie + m ! perform bidiagonal qr iteration, ! computing right singular vectors of a in a and ! multiplying b by transpose of left singular vectors ! (cworkspace: none) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'L', m, n, 0, nrhs, s, rwork( ie ), a, lda, dum,1, b, ldb, & + call stdlib${ii}$_cbdsqr( 'L', m, n, 0_${ik}$, nrhs, s, rwork( ie ), a, lda, dum,1_${ik}$, b, ldb, & rwork( irwork ), info ) if( info/=0 )go to 70 ! multiply b by reciprocals of singular values - thr = max( rcond*s( 1 ), sfmin ) - if( rcondthr ) then - call stdlib_csrscl( nrhs, s( i ), b( i, 1 ), ldb ) - rank = rank + 1 + call stdlib${ii}$_csrscl( nrhs, s( i ), b( i, 1_${ik}$ ), ldb ) + rank = rank + 1_${ik}$ else - call stdlib_claset( 'F', 1, nrhs, czero, czero, b( i, 1 ), ldb ) + call stdlib${ii}$_claset( 'F', 1_${ik}$, nrhs, czero, czero, b( i, 1_${ik}$ ), ldb ) end if end do ! multiply b by right singular vectors of a ! (cworkspace: need n, prefer n*nrhs) ! (rworkspace: none) - if( lwork>=ldb*nrhs .and. nrhs>1 ) then - call stdlib_cgemm( 'C', 'N', n, nrhs, m, cone, a, lda, b, ldb,czero, work, ldb ) + if( lwork>=ldb*nrhs .and. nrhs>1_${ik}$ ) then + call stdlib${ii}$_cgemm( 'C', 'N', n, nrhs, m, cone, a, lda, b, ldb,czero, work, ldb ) - call stdlib_clacpy( 'G', n, nrhs, work, ldb, b, ldb ) - else if( nrhs>1 ) then + call stdlib${ii}$_clacpy( 'G', n, nrhs, work, ldb, b, ldb ) + else if( nrhs>1_${ik}$ ) then chunk = lwork / n do i = 1, nrhs, chunk bl = min( nrhs-i+1, chunk ) - call stdlib_cgemm( 'C', 'N', n, bl, m, cone, a, lda, b( 1, i ),ldb, czero, & + call stdlib${ii}$_cgemm( 'C', 'N', n, bl, m, cone, a, lda, b( 1_${ik}$, i ),ldb, czero, & work, n ) - call stdlib_clacpy( 'F', n, bl, work, n, b( 1, i ), ldb ) + call stdlib${ii}$_clacpy( 'F', n, bl, work, n, b( 1_${ik}$, i ), ldb ) end do else - call stdlib_cgemv( 'C', m, n, cone, a, lda, b, 1, czero, work, 1 ) - call stdlib_ccopy( n, work, 1, b, 1 ) + call stdlib${ii}$_cgemv( 'C', m, n, cone, a, lda, b, 1_${ik}$, czero, work, 1_${ik}$ ) + call stdlib${ii}$_ccopy( n, work, 1_${ik}$, b, 1_${ik}$ ) end if end if ! undo scaling - if( iascl==1 ) then - call stdlib_clascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info ) - call stdlib_slascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn,info ) - else if( iascl==2 ) then - call stdlib_clascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info ) - call stdlib_slascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,info ) - end if - if( ibscl==1 ) then - call stdlib_clascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info ) - else if( ibscl==2 ) then - call stdlib_clascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info ) + if( iascl==1_${ik}$ ) then + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, smlnum, n, nrhs, b, ldb, info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, anrm, minmn, 1_${ik}$, s, minmn,info ) + else if( iascl==2_${ik}$ ) then + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, n, nrhs, b, ldb, info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn, 1_${ik}$, s, minmn,info ) + end if + if( ibscl==1_${ik}$ ) then + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, bnrm, n, nrhs, b, ldb, info ) + else if( ibscl==2_${ik}$ ) then + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bignum, bnrm, n, nrhs, b, ldb, info ) end if 70 continue - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_cgelss + end subroutine stdlib${ii}$_cgelss - subroutine stdlib_cgelsy( m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank,work, lwork, rwork, & + subroutine stdlib${ii}$_cgelsy( m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank,work, lwork, rwork, & !! CGELSY computes the minimum-norm solution to a complex linear least !! squares problem: !! minimize || A * X - B || @@ -64872,24 +64874,24 @@ module stdlib_linalg_lapack_c ! -- 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, rank - integer(ilp), intent(in) :: lda, ldb, lwork, m, n, nrhs + integer(${ik}$), intent(out) :: info, rank + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, nrhs real(sp), intent(in) :: rcond ! Array Arguments - integer(ilp), intent(inout) :: jpvt(*) + integer(${ik}$), intent(inout) :: jpvt(*) real(sp), intent(out) :: rwork(*) complex(sp), intent(inout) :: a(lda,*), b(ldb,*) complex(sp), intent(out) :: work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: imax = 1 - integer(ilp), parameter :: imin = 2 + integer(${ik}$), parameter :: imax = 1_${ik}$ + integer(${ik}$), parameter :: imin = 2_${ik}$ ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, iascl, ibscl, ismax, ismin, j, lwkopt, mn, nb, nb1, nb2, nb3, & + integer(${ik}$) :: i, iascl, ibscl, ismax, ismin, j, lwkopt, mn, nb, nb1, nb2, nb3, & nb4 real(sp) :: anrm, bignum, bnrm, smax, smaxpr, smin, sminpr, smlnum, wsize complex(sp) :: c1, c2, s1, s2 @@ -64897,77 +64899,77 @@ module stdlib_linalg_lapack_c intrinsic :: abs,max,min,real,cmplx ! Executable Statements mn = min( m, n ) - ismin = mn + 1 - ismax = 2*mn + 1 + ismin = mn + 1_${ik}$ + ismax = 2_${ik}$*mn + 1_${ik}$ ! test the input arguments. - info = 0 - nb1 = stdlib_ilaenv( 1, 'CGEQRF', ' ', m, n, -1, -1 ) - nb2 = stdlib_ilaenv( 1, 'CGERQF', ' ', m, n, -1, -1 ) - nb3 = stdlib_ilaenv( 1, 'CUNMQR', ' ', m, n, nrhs, -1 ) - nb4 = stdlib_ilaenv( 1, 'CUNMRQ', ' ', m, n, nrhs, -1 ) + info = 0_${ik}$ + nb1 = stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEQRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) + nb2 = stdlib${ii}$_ilaenv( 1_${ik}$, 'CGERQF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) + nb3 = stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMQR', ' ', m, n, nrhs, -1_${ik}$ ) + nb4 = stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMRQ', ' ', m, n, nrhs, -1_${ik}$ ) nb = max( nb1, nb2, nb3, nb4 ) - lwkopt = max( 1, mn+2*n+nb*(n+1), 2*mn+nb*nrhs ) - work( 1 ) = cmplx( lwkopt,KIND=sp) - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( ldazero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_clascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_claset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) - rank = 0 + call stdlib${ii}$_claset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) + rank = 0_${ik}$ go to 70 end if - bnrm = stdlib_clange( 'M', m, nrhs, b, ldb, rwork ) - ibscl = 0 + bnrm = stdlib${ii}$_clange( 'M', m, nrhs, b, ldb, rwork ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_clascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) - ibscl = 2 + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, m, nrhs, b, ldb, info ) + ibscl = 2_${ik}$ end if ! compute qr factorization with column pivoting of a: ! a * p = q * r - call stdlib_cgeqp3( m, n, a, lda, jpvt, work( 1 ), work( mn+1 ),lwork-mn, rwork, info ) + call stdlib${ii}$_cgeqp3( m, n, a, lda, jpvt, work( 1_${ik}$ ), work( mn+1 ),lwork-mn, rwork, info ) wsize = mn + real( work( mn+1 ),KIND=sp) ! complex workspace: mn+nb*(n+1). real workspace 2*n. @@ -64975,21 +64977,21 @@ module stdlib_linalg_lapack_c ! determine rank using incremental condition estimation work( ismin ) = cone work( ismax ) = cone - smax = abs( a( 1, 1 ) ) + smax = abs( a( 1_${ik}$, 1_${ik}$ ) ) smin = smax - if( abs( a( 1, 1 ) )==zero ) then - rank = 0 - call stdlib_claset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) + if( abs( a( 1_${ik}$, 1_${ik}$ ) )==zero ) then + rank = 0_${ik}$ + call stdlib${ii}$_claset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) go to 70 else - rank = 1 + rank = 1_${ik}$ end if 10 continue if( rankk ) .and. ( mn>k ) ) then - if( mod( mn - k, nb - k ) == 0 ) then + if( mod( mn - k, nb - k ) == 0_${ik}$ ) then nblcks = ( mn - k ) / ( nb - k ) else - nblcks = ( mn - k ) / ( nb - k ) + 1 + nblcks = ( mn - k ) / ( nb - k ) + 1_${ik}$ end if else - nblcks = 1 + nblcks = 1_${ik}$ end if - info = 0 + info = 0_${ik}$ 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>mn ) then - info = -5 - else if( ldamn ) then + info = -5_${ik}$ + else if( lda=max( m, n, & k ) ) ) then - call stdlib_cgemlqt( side, trans, m, n, k, mb, a, lda,t( 6 ), mb, c, ldc, work, info & + call stdlib${ii}$_cgemlqt( side, trans, m, n, k, mb, a, lda,t( 6_${ik}$ ), mb, c, ldc, work, info & ) else - call stdlib_clamswlq( side, trans, m, n, k, mb, nb, a, lda, t( 6 ),mb, c, ldc, work, & + call stdlib${ii}$_clamswlq( side, trans, m, n, k, mb, nb, a, lda, t( 6_${ik}$ ),mb, c, ldc, work, & lwork, info ) end if - work( 1 ) = real( lw,KIND=sp) + work( 1_${ik}$ ) = real( lw,KIND=sp) return - end subroutine stdlib_cgemlq + end subroutine stdlib${ii}$_cgemlq - pure subroutine stdlib_cgemqr( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, & + pure subroutine stdlib${ii}$_cgemqr( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, & !! CGEMQR overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -65170,8 +65172,8 @@ module stdlib_linalg_lapack_c ! -- 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) :: lda, m, n, k, tsize, lwork, ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, k, tsize, lwork, ldc ! Array Arguments complex(sp), intent(in) :: a(lda,*), t(*) complex(sp), intent(inout) :: c(ldc,*) @@ -65179,18 +65181,18 @@ module stdlib_linalg_lapack_c ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran, lquery - integer(ilp) :: mb, nb, lw, nblcks, mn + integer(${ik}$) :: mb, nb, lw, nblcks, mn ! Intrinsic Functions intrinsic :: int,max,min,mod ! Executable Statements ! test the input arguments - lquery = lwork==-1 + lquery = lwork==-1_${ik}$ notran = stdlib_lsame( trans, 'N' ) tran = stdlib_lsame( trans, 'C' ) left = stdlib_lsame( side, 'L' ) right = stdlib_lsame( side, 'R' ) - mb = int( t( 2 ),KIND=ilp) - nb = int( t( 3 ),KIND=ilp) + mb = int( t( 2_${ik}$ ),KIND=${ik}$) + nb = int( t( 3_${ik}$ ),KIND=${ik}$) if( left ) then lw = n * nb mn = m @@ -65199,61 +65201,61 @@ module stdlib_linalg_lapack_c mn = n end if if( ( mb>k ) .and. ( mn>k ) ) then - if( mod( mn - k, mb - k )==0 ) then + if( mod( mn - k, mb - k )==0_${ik}$ ) then nblcks = ( mn - k ) / ( mb - k ) else - nblcks = ( mn - k ) / ( mb - k ) + 1 + nblcks = ( mn - k ) / ( mb - k ) + 1_${ik}$ end if else - nblcks = 1 + nblcks = 1_${ik}$ end if - info = 0 + info = 0_${ik}$ 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>mn ) then - info = -5 - else if( ldamn ) then + info = -5_${ik}$ + else if( lda=max( m, n, & k ) ) ) then - call stdlib_cgemqrt( side, trans, m, n, k, nb, a, lda, t( 6 ),nb, c, ldc, work, info & + call stdlib${ii}$_cgemqrt( side, trans, m, n, k, nb, a, lda, t( 6_${ik}$ ),nb, c, ldc, work, info & ) else - call stdlib_clamtsqr( side, trans, m, n, k, mb, nb, a, lda, t( 6 ),nb, c, ldc, work, & + call stdlib${ii}$_clamtsqr( side, trans, m, n, k, mb, nb, a, lda, t( 6_${ik}$ ),nb, c, ldc, work, & lwork, info ) end if - work( 1 ) = lw + work( 1_${ik}$ ) = lw return - end subroutine stdlib_cgemqr + end subroutine stdlib${ii}$_cgemqr - pure subroutine stdlib_cgeqr( m, n, a, lda, t, tsize, work, lwork,info ) + pure subroutine stdlib${ii}$_cgeqr( m, n, a, lda, t, tsize, work, lwork,info ) !! CGEQR computes a QR factorization of a complex M-by-N matrix A: !! A = Q * ( R ), !! ( 0 ) @@ -65265,110 +65267,110 @@ module stdlib_linalg_lapack_c ! -- 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, tsize, lwork + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, tsize, lwork ! Array Arguments complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: t(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, lminws, mint, minw - integer(ilp) :: mb, nb, mintsz, nblcks + integer(${ik}$) :: mb, nb, mintsz, nblcks ! Intrinsic Functions intrinsic :: max,min,mod ! Executable Statements ! test the input arguments - info = 0 - lquery = ( tsize==-1 .or. tsize==-2 .or.lwork==-1 .or. lwork==-2 ) + info = 0_${ik}$ + lquery = ( tsize==-1_${ik}$ .or. tsize==-2_${ik}$ .or.lwork==-1_${ik}$ .or. lwork==-2_${ik}$ ) mint = .false. minw = .false. - if( tsize==-2 .or. lwork==-2 ) then - if( tsize/=-1 ) mint = .true. - if( lwork/=-1 ) minw = .true. + if( tsize==-2_${ik}$ .or. lwork==-2_${ik}$ ) then + if( tsize/=-1_${ik}$ ) mint = .true. + if( lwork/=-1_${ik}$ ) minw = .true. end if ! determine the block size - if( min( m, n )>0 ) then - mb = stdlib_ilaenv( 1, 'CGEQR ', ' ', m, n, 1, -1 ) - nb = stdlib_ilaenv( 1, 'CGEQR ', ' ', m, n, 2, -1 ) + if( min( m, n )>0_${ik}$ ) then + mb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEQR ', ' ', m, n, 1_${ik}$, -1_${ik}$ ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEQR ', ' ', m, n, 2_${ik}$, -1_${ik}$ ) else mb = m - nb = 1 + nb = 1_${ik}$ end if if( mb>m .or. mb<=n ) mb = m - if( nb>min( m, n ) .or. nb<1 ) nb = 1 - mintsz = n + 5 + if( nb>min( m, n ) .or. nb<1_${ik}$ ) nb = 1_${ik}$ + mintsz = n + 5_${ik}$ if( mb>n .and. m>n ) then - if( mod( m - n, mb - n )==0 ) then + if( mod( m - n, mb - n )==0_${ik}$ ) then nblcks = ( m - n ) / ( mb - n ) else - nblcks = ( m - n ) / ( mb - n ) + 1 + nblcks = ( m - n ) / ( mb - n ) + 1_${ik}$ end if else - nblcks = 1 + nblcks = 1_${ik}$ end if ! determine if the workspace size satisfies minimal size lminws = .false. - if( ( tsize=n ) .and. ( & + if( ( tsize=n ) .and. ( & tsize>=mintsz ).and. ( .not.lquery ) ) then - if( tsize=m ) ) then - call stdlib_cgeqrt( m, n, nb, a, lda, t( 6 ), nb, work, info ) + call stdlib${ii}$_cgeqrt( m, n, nb, a, lda, t( 6_${ik}$ ), nb, work, info ) else - call stdlib_clatsqr( m, n, mb, nb, a, lda, t( 6 ), nb, work,lwork, info ) + call stdlib${ii}$_clatsqr( m, n, mb, nb, a, lda, t( 6_${ik}$ ), nb, work,lwork, info ) end if - work( 1 ) = max( 1, nb*n ) + work( 1_${ik}$ ) = max( 1_${ik}$, nb*n ) return - end subroutine stdlib_cgeqr + end subroutine stdlib${ii}$_cgeqr - subroutine stdlib_cgesdd( jobz, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, rwork, iwork, & + subroutine stdlib${ii}$_cgesdd( jobz, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, rwork, iwork, & !! CGESDD computes the singular value decomposition (SVD) of a complex !! M-by-N matrix A, optionally computing the left and/or right singular !! vectors, by using divide-and-conquer method. The SVD is written @@ -65392,10 +65394,10 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldu, ldvt, lwork, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldu, ldvt, lwork, m, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(out) :: rwork(*), s(*) complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: u(ldu,*), vt(ldvt,*), work(*) @@ -65404,49 +65406,49 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: lquery, wntqa, wntqas, wntqn, wntqo, wntqs - integer(ilp) :: blk, chunk, i, ie, ierr, il, ir, iru, irvt, iscl, itau, itaup, itauq, & + integer(${ik}$) :: blk, chunk, i, ie, ierr, il, ir, iru, irvt, iscl, itau, itaup, itauq, & iu, ivt, ldwkvt, ldwrkl, ldwrkr, ldwrku, maxwrk, minmn, minwrk, mnthr1, mnthr2, nrwork,& nwork, wrkbl - integer(ilp) :: lwork_cgebrd_mn, lwork_cgebrd_mm, lwork_cgebrd_nn, lwork_cgelqf_mn, & + integer(${ik}$) :: lwork_cgebrd_mn, lwork_cgebrd_mm, lwork_cgebrd_nn, lwork_cgelqf_mn, & lwork_cgeqrf_mn, lwork_cungbr_p_mn, lwork_cungbr_p_nn, lwork_cungbr_q_mn, & lwork_cungbr_q_mm, lwork_cunglq_mn, lwork_cunglq_nn, lwork_cungqr_mm, lwork_cungqr_mn, & lwork_cunmbr_prc_mm, lwork_cunmbr_qln_mm, lwork_cunmbr_prc_mn, lwork_cunmbr_qln_mn, & lwork_cunmbr_prc_nn, lwork_cunmbr_qln_nn real(sp) :: anrm, bignum, eps, smlnum ! Local Arrays - integer(ilp) :: idum(1) - real(sp) :: dum(1) - complex(sp) :: cdum(1) + integer(${ik}$) :: idum(1_${ik}$) + real(sp) :: dum(1_${ik}$) + complex(sp) :: cdum(1_${ik}$) ! Intrinsic Functions intrinsic :: int,max,min,sqrt ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ minmn = min( m, n ) - mnthr1 = int( minmn*17.0_sp / 9.0_sp,KIND=ilp) - mnthr2 = int( minmn*5.0_sp / 3.0_sp,KIND=ilp) + mnthr1 = int( minmn*17.0_sp / 9.0_sp,KIND=${ik}$) + mnthr2 = int( minmn*5.0_sp / 3.0_sp,KIND=${ik}$) wntqa = stdlib_lsame( jobz, 'A' ) wntqs = stdlib_lsame( jobz, 'S' ) wntqas = wntqa .or. wntqs wntqo = stdlib_lsame( jobz, 'O' ) wntqn = stdlib_lsame( jobz, 'N' ) - lquery = ( lwork==-1 ) - minwrk = 1 - maxwrk = 1 + lquery = ( lwork==-1_${ik}$ ) + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ if( .not.( wntqa .or. wntqs .or. wntqo .or. wntqn ) ) then - info = -1 - else if( m<0 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( lda=n .and. ldvt=n .and. minmn>0 ) then + ! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + if( m>=n .and. minmn>0_${ik}$ ) then ! there is no complex work space needed for bidiagonal svd - ! the realwork space needed for bidiagonal svd (stdlib_sbdsdc,KIND=sp) is + ! the realwork space needed for bidiagonal svd (stdlib${ii}$_sbdsdc,KIND=sp) is ! bdspac = 3*n*n + 4*n for singular values and vectors; ! bdspac = 4*n for singular values only; ! not including e, ru, and rvt matrices. ! compute space preferred for each routine - call stdlib_cgebrd( m, n, cdum(1), m, dum(1), dum(1), cdum(1),cdum(1), cdum(1), -& - 1, ierr ) - lwork_cgebrd_mn = int( cdum(1),KIND=ilp) - call stdlib_cgebrd( n, n, cdum(1), n, dum(1), dum(1), cdum(1),cdum(1), cdum(1), -& - 1, ierr ) - lwork_cgebrd_nn = int( cdum(1),KIND=ilp) - call stdlib_cgeqrf( m, n, cdum(1), m, cdum(1), cdum(1), -1, ierr ) - lwork_cgeqrf_mn = int( cdum(1),KIND=ilp) - call stdlib_cungbr( 'P', n, n, n, cdum(1), n, cdum(1), cdum(1),-1, ierr ) - lwork_cungbr_p_nn = int( cdum(1),KIND=ilp) - call stdlib_cungbr( 'Q', m, m, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) - lwork_cungbr_q_mm = int( cdum(1),KIND=ilp) - call stdlib_cungbr( 'Q', m, n, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) - lwork_cungbr_q_mn = int( cdum(1),KIND=ilp) - call stdlib_cungqr( m, m, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) - lwork_cungqr_mm = int( cdum(1),KIND=ilp) - call stdlib_cungqr( m, n, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) - lwork_cungqr_mn = int( cdum(1),KIND=ilp) - call stdlib_cunmbr( 'P', 'R', 'C', n, n, n, cdum(1), n, cdum(1),cdum(1), n, cdum(& - 1), -1, ierr ) - lwork_cunmbr_prc_nn = int( cdum(1),KIND=ilp) - call stdlib_cunmbr( 'Q', 'L', 'N', m, m, n, cdum(1), m, cdum(1),cdum(1), m, cdum(& - 1), -1, ierr ) - lwork_cunmbr_qln_mm = int( cdum(1),KIND=ilp) - call stdlib_cunmbr( 'Q', 'L', 'N', m, n, n, cdum(1), m, cdum(1),cdum(1), m, cdum(& - 1), -1, ierr ) - lwork_cunmbr_qln_mn = int( cdum(1),KIND=ilp) - call stdlib_cunmbr( 'Q', 'L', 'N', n, n, n, cdum(1), n, cdum(1),cdum(1), n, cdum(& - 1), -1, ierr ) - lwork_cunmbr_qln_nn = int( cdum(1),KIND=ilp) + call stdlib${ii}$_cgebrd( m, n, cdum(1_${ik}$), m, dum(1_${ik}$), dum(1_${ik}$), cdum(1_${ik}$),cdum(1_${ik}$), cdum(1_${ik}$), -& + 1_${ik}$, ierr ) + lwork_cgebrd_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cgebrd( n, n, cdum(1_${ik}$), n, dum(1_${ik}$), dum(1_${ik}$), cdum(1_${ik}$),cdum(1_${ik}$), cdum(1_${ik}$), -& + 1_${ik}$, ierr ) + lwork_cgebrd_nn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cgeqrf( m, n, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_cgeqrf_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cungbr( 'P', n, n, n, cdum(1_${ik}$), n, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_cungbr_p_nn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cungbr( 'Q', m, m, n, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_cungbr_q_mm = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cungbr( 'Q', m, n, n, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_cungbr_q_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cungqr( m, m, n, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_cungqr_mm = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cungqr( m, n, n, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_cungqr_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cunmbr( 'P', 'R', 'C', n, n, n, cdum(1_${ik}$), n, cdum(1_${ik}$),cdum(1_${ik}$), n, cdum(& + 1_${ik}$), -1_${ik}$, ierr ) + lwork_cunmbr_prc_nn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cunmbr( 'Q', 'L', 'N', m, m, n, cdum(1_${ik}$), m, cdum(1_${ik}$),cdum(1_${ik}$), m, cdum(& + 1_${ik}$), -1_${ik}$, ierr ) + lwork_cunmbr_qln_mm = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cunmbr( 'Q', 'L', 'N', m, n, n, cdum(1_${ik}$), m, cdum(1_${ik}$),cdum(1_${ik}$), m, cdum(& + 1_${ik}$), -1_${ik}$, ierr ) + lwork_cunmbr_qln_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cunmbr( 'Q', 'L', 'N', n, n, n, cdum(1_${ik}$), n, cdum(1_${ik}$),cdum(1_${ik}$), n, cdum(& + 1_${ik}$), -1_${ik}$, ierr ) + lwork_cunmbr_qln_nn = int( cdum(1_${ik}$),KIND=${ik}$) if( m>=mnthr1 ) then if( wntqn ) then ! path 1 (m >> n, jobz='n') maxwrk = n + lwork_cgeqrf_mn - maxwrk = max( maxwrk, 2*n + lwork_cgebrd_nn ) - minwrk = 3*n + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_cgebrd_nn ) + minwrk = 3_${ik}$*n else if( wntqo ) then ! path 2 (m >> n, jobz='o') wrkbl = n + lwork_cgeqrf_mn wrkbl = max( wrkbl, n + lwork_cungqr_mn ) - wrkbl = max( wrkbl, 2*n + lwork_cgebrd_nn ) - wrkbl = max( wrkbl, 2*n + lwork_cunmbr_qln_nn ) - wrkbl = max( wrkbl, 2*n + lwork_cunmbr_prc_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_cgebrd_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_cunmbr_qln_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_cunmbr_prc_nn ) maxwrk = m*n + n*n + wrkbl - minwrk = 2*n*n + 3*n + minwrk = 2_${ik}$*n*n + 3_${ik}$*n else if( wntqs ) then ! path 3 (m >> n, jobz='s') wrkbl = n + lwork_cgeqrf_mn wrkbl = max( wrkbl, n + lwork_cungqr_mn ) - wrkbl = max( wrkbl, 2*n + lwork_cgebrd_nn ) - wrkbl = max( wrkbl, 2*n + lwork_cunmbr_qln_nn ) - wrkbl = max( wrkbl, 2*n + lwork_cunmbr_prc_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_cgebrd_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_cunmbr_qln_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_cunmbr_prc_nn ) maxwrk = n*n + wrkbl - minwrk = n*n + 3*n + minwrk = n*n + 3_${ik}$*n else if( wntqa ) then ! path 4 (m >> n, jobz='a') wrkbl = n + lwork_cgeqrf_mn wrkbl = max( wrkbl, n + lwork_cungqr_mm ) - wrkbl = max( wrkbl, 2*n + lwork_cgebrd_nn ) - wrkbl = max( wrkbl, 2*n + lwork_cunmbr_qln_nn ) - wrkbl = max( wrkbl, 2*n + lwork_cunmbr_prc_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_cgebrd_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_cunmbr_qln_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_cunmbr_prc_nn ) maxwrk = n*n + wrkbl - minwrk = n*n + max( 3*n, n + m ) + minwrk = n*n + max( 3_${ik}$*n, n + m ) end if else if( m>=mnthr2 ) then ! path 5 (m >> n, but not as much as mnthr1) - maxwrk = 2*n + lwork_cgebrd_mn - minwrk = 2*n + m + maxwrk = 2_${ik}$*n + lwork_cgebrd_mn + minwrk = 2_${ik}$*n + m if( wntqo ) then ! path 5o (m >> n, jobz='o') - maxwrk = max( maxwrk, 2*n + lwork_cungbr_p_nn ) - maxwrk = max( maxwrk, 2*n + lwork_cungbr_q_mn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_cungbr_p_nn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_cungbr_q_mn ) maxwrk = maxwrk + m*n minwrk = minwrk + n*n else if( wntqs ) then ! path 5s (m >> n, jobz='s') - maxwrk = max( maxwrk, 2*n + lwork_cungbr_p_nn ) - maxwrk = max( maxwrk, 2*n + lwork_cungbr_q_mn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_cungbr_p_nn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_cungbr_q_mn ) else if( wntqa ) then ! path 5a (m >> n, jobz='a') - maxwrk = max( maxwrk, 2*n + lwork_cungbr_p_nn ) - maxwrk = max( maxwrk, 2*n + lwork_cungbr_q_mm ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_cungbr_p_nn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_cungbr_q_mm ) end if else ! path 6 (m >= n, but not much larger) - maxwrk = 2*n + lwork_cgebrd_mn - minwrk = 2*n + m + maxwrk = 2_${ik}$*n + lwork_cgebrd_mn + minwrk = 2_${ik}$*n + m if( wntqo ) then ! path 6o (m >= n, jobz='o') - maxwrk = max( maxwrk, 2*n + lwork_cunmbr_prc_nn ) - maxwrk = max( maxwrk, 2*n + lwork_cunmbr_qln_mn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_cunmbr_prc_nn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_cunmbr_qln_mn ) maxwrk = maxwrk + m*n minwrk = minwrk + n*n else if( wntqs ) then ! path 6s (m >= n, jobz='s') - maxwrk = max( maxwrk, 2*n + lwork_cunmbr_qln_mn ) - maxwrk = max( maxwrk, 2*n + lwork_cunmbr_prc_nn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_cunmbr_qln_mn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_cunmbr_prc_nn ) else if( wntqa ) then ! path 6a (m >= n, jobz='a') - maxwrk = max( maxwrk, 2*n + lwork_cunmbr_qln_mm ) - maxwrk = max( maxwrk, 2*n + lwork_cunmbr_prc_nn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_cunmbr_qln_mm ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_cunmbr_prc_nn ) end if end if - else if( minmn>0 ) then + else if( minmn>0_${ik}$ ) then ! there is no complex work space needed for bidiagonal svd - ! the realwork space needed for bidiagonal svd (stdlib_sbdsdc,KIND=sp) is + ! the realwork space needed for bidiagonal svd (stdlib${ii}$_sbdsdc,KIND=sp) is ! bdspac = 3*m*m + 4*m for singular values and vectors; ! bdspac = 4*m for singular values only; ! not including e, ru, and rvt matrices. ! compute space preferred for each routine - call stdlib_cgebrd( m, n, cdum(1), m, dum(1), dum(1), cdum(1),cdum(1), cdum(1), -& - 1, ierr ) - lwork_cgebrd_mn = int( cdum(1),KIND=ilp) - call stdlib_cgebrd( m, m, cdum(1), m, dum(1), dum(1), cdum(1),cdum(1), cdum(1), -& - 1, ierr ) - lwork_cgebrd_mm = int( cdum(1),KIND=ilp) - call stdlib_cgelqf( m, n, cdum(1), m, cdum(1), cdum(1), -1, ierr ) - lwork_cgelqf_mn = int( cdum(1),KIND=ilp) - call stdlib_cungbr( 'P', m, n, m, cdum(1), m, cdum(1), cdum(1),-1, ierr ) - lwork_cungbr_p_mn = int( cdum(1),KIND=ilp) - call stdlib_cungbr( 'P', n, n, m, cdum(1), n, cdum(1), cdum(1),-1, ierr ) - lwork_cungbr_p_nn = int( cdum(1),KIND=ilp) - call stdlib_cungbr( 'Q', m, m, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) - lwork_cungbr_q_mm = int( cdum(1),KIND=ilp) - call stdlib_cunglq( m, n, m, cdum(1), m, cdum(1), cdum(1),-1, ierr ) - lwork_cunglq_mn = int( cdum(1),KIND=ilp) - call stdlib_cunglq( n, n, m, cdum(1), n, cdum(1), cdum(1),-1, ierr ) - lwork_cunglq_nn = int( cdum(1),KIND=ilp) - call stdlib_cunmbr( 'P', 'R', 'C', m, m, m, cdum(1), m, cdum(1),cdum(1), m, cdum(& - 1), -1, ierr ) - lwork_cunmbr_prc_mm = int( cdum(1),KIND=ilp) - call stdlib_cunmbr( 'P', 'R', 'C', m, n, m, cdum(1), m, cdum(1),cdum(1), m, cdum(& - 1), -1, ierr ) - lwork_cunmbr_prc_mn = int( cdum(1),KIND=ilp) - call stdlib_cunmbr( 'P', 'R', 'C', n, n, m, cdum(1), n, cdum(1),cdum(1), n, cdum(& - 1), -1, ierr ) - lwork_cunmbr_prc_nn = int( cdum(1),KIND=ilp) - call stdlib_cunmbr( 'Q', 'L', 'N', m, m, m, cdum(1), m, cdum(1),cdum(1), m, cdum(& - 1), -1, ierr ) - lwork_cunmbr_qln_mm = int( cdum(1),KIND=ilp) + call stdlib${ii}$_cgebrd( m, n, cdum(1_${ik}$), m, dum(1_${ik}$), dum(1_${ik}$), cdum(1_${ik}$),cdum(1_${ik}$), cdum(1_${ik}$), -& + 1_${ik}$, ierr ) + lwork_cgebrd_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cgebrd( m, m, cdum(1_${ik}$), m, dum(1_${ik}$), dum(1_${ik}$), cdum(1_${ik}$),cdum(1_${ik}$), cdum(1_${ik}$), -& + 1_${ik}$, ierr ) + lwork_cgebrd_mm = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cgelqf( m, n, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_cgelqf_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cungbr( 'P', m, n, m, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_cungbr_p_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cungbr( 'P', n, n, m, cdum(1_${ik}$), n, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_cungbr_p_nn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cungbr( 'Q', m, m, n, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_cungbr_q_mm = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cunglq( m, n, m, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_cunglq_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cunglq( n, n, m, cdum(1_${ik}$), n, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_cunglq_nn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cunmbr( 'P', 'R', 'C', m, m, m, cdum(1_${ik}$), m, cdum(1_${ik}$),cdum(1_${ik}$), m, cdum(& + 1_${ik}$), -1_${ik}$, ierr ) + lwork_cunmbr_prc_mm = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cunmbr( 'P', 'R', 'C', m, n, m, cdum(1_${ik}$), m, cdum(1_${ik}$),cdum(1_${ik}$), m, cdum(& + 1_${ik}$), -1_${ik}$, ierr ) + lwork_cunmbr_prc_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cunmbr( 'P', 'R', 'C', n, n, m, cdum(1_${ik}$), n, cdum(1_${ik}$),cdum(1_${ik}$), n, cdum(& + 1_${ik}$), -1_${ik}$, ierr ) + lwork_cunmbr_prc_nn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cunmbr( 'Q', 'L', 'N', m, m, m, cdum(1_${ik}$), m, cdum(1_${ik}$),cdum(1_${ik}$), m, cdum(& + 1_${ik}$), -1_${ik}$, ierr ) + lwork_cunmbr_qln_mm = int( cdum(1_${ik}$),KIND=${ik}$) if( n>=mnthr1 ) then if( wntqn ) then ! path 1t (n >> m, jobz='n') maxwrk = m + lwork_cgelqf_mn - maxwrk = max( maxwrk, 2*m + lwork_cgebrd_mm ) - minwrk = 3*m + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_cgebrd_mm ) + minwrk = 3_${ik}$*m else if( wntqo ) then ! path 2t (n >> m, jobz='o') wrkbl = m + lwork_cgelqf_mn wrkbl = max( wrkbl, m + lwork_cunglq_mn ) - wrkbl = max( wrkbl, 2*m + lwork_cgebrd_mm ) - wrkbl = max( wrkbl, 2*m + lwork_cunmbr_qln_mm ) - wrkbl = max( wrkbl, 2*m + lwork_cunmbr_prc_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_cgebrd_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_cunmbr_qln_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_cunmbr_prc_mm ) maxwrk = m*n + m*m + wrkbl - minwrk = 2*m*m + 3*m + minwrk = 2_${ik}$*m*m + 3_${ik}$*m else if( wntqs ) then ! path 3t (n >> m, jobz='s') wrkbl = m + lwork_cgelqf_mn wrkbl = max( wrkbl, m + lwork_cunglq_mn ) - wrkbl = max( wrkbl, 2*m + lwork_cgebrd_mm ) - wrkbl = max( wrkbl, 2*m + lwork_cunmbr_qln_mm ) - wrkbl = max( wrkbl, 2*m + lwork_cunmbr_prc_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_cgebrd_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_cunmbr_qln_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_cunmbr_prc_mm ) maxwrk = m*m + wrkbl - minwrk = m*m + 3*m + minwrk = m*m + 3_${ik}$*m else if( wntqa ) then ! path 4t (n >> m, jobz='a') wrkbl = m + lwork_cgelqf_mn wrkbl = max( wrkbl, m + lwork_cunglq_nn ) - wrkbl = max( wrkbl, 2*m + lwork_cgebrd_mm ) - wrkbl = max( wrkbl, 2*m + lwork_cunmbr_qln_mm ) - wrkbl = max( wrkbl, 2*m + lwork_cunmbr_prc_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_cgebrd_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_cunmbr_qln_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_cunmbr_prc_mm ) maxwrk = m*m + wrkbl - minwrk = m*m + max( 3*m, m + n ) + minwrk = m*m + max( 3_${ik}$*m, m + n ) end if else if( n>=mnthr2 ) then ! path 5t (n >> m, but not as much as mnthr1) - maxwrk = 2*m + lwork_cgebrd_mn - minwrk = 2*m + n + maxwrk = 2_${ik}$*m + lwork_cgebrd_mn + minwrk = 2_${ik}$*m + n if( wntqo ) then ! path 5to (n >> m, jobz='o') - maxwrk = max( maxwrk, 2*m + lwork_cungbr_q_mm ) - maxwrk = max( maxwrk, 2*m + lwork_cungbr_p_mn ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_cungbr_q_mm ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_cungbr_p_mn ) maxwrk = maxwrk + m*n minwrk = minwrk + m*m else if( wntqs ) then ! path 5ts (n >> m, jobz='s') - maxwrk = max( maxwrk, 2*m + lwork_cungbr_q_mm ) - maxwrk = max( maxwrk, 2*m + lwork_cungbr_p_mn ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_cungbr_q_mm ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_cungbr_p_mn ) else if( wntqa ) then ! path 5ta (n >> m, jobz='a') - maxwrk = max( maxwrk, 2*m + lwork_cungbr_q_mm ) - maxwrk = max( maxwrk, 2*m + lwork_cungbr_p_nn ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_cungbr_q_mm ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_cungbr_p_nn ) end if else ! path 6t (n > m, but not much larger) - maxwrk = 2*m + lwork_cgebrd_mn - minwrk = 2*m + n + maxwrk = 2_${ik}$*m + lwork_cgebrd_mn + minwrk = 2_${ik}$*m + n if( wntqo ) then ! path 6to (n > m, jobz='o') - maxwrk = max( maxwrk, 2*m + lwork_cunmbr_qln_mm ) - maxwrk = max( maxwrk, 2*m + lwork_cunmbr_prc_mn ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_cunmbr_qln_mm ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_cunmbr_prc_mn ) maxwrk = maxwrk + m*n minwrk = minwrk + m*m else if( wntqs ) then ! path 6ts (n > m, jobz='s') - maxwrk = max( maxwrk, 2*m + lwork_cunmbr_qln_mm ) - maxwrk = max( maxwrk, 2*m + lwork_cunmbr_prc_mn ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_cunmbr_qln_mm ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_cunmbr_prc_mn ) else if( wntqa ) then ! path 6ta (n > m, jobz='a') - maxwrk = max( maxwrk, 2*m + lwork_cunmbr_qln_mm ) - maxwrk = max( maxwrk, 2*m + lwork_cunmbr_prc_nn ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_cunmbr_qln_mm ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_cunmbr_prc_nn ) end if end if end if maxwrk = max( maxwrk, minwrk ) end if - if( info==0 ) then - work( 1 ) = stdlib_sroundup_lwork( maxwrk ) + if( info==0_${ik}$ ) then + work( 1_${ik}$ ) = stdlib${ii}$_sroundup_lwork( maxwrk ) if( lworkzero .and. anrmbignum ) then - iscl = 1 - call stdlib_clascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, ierr ) + iscl = 1_${ik}$ + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, ierr ) end if if( m>=n ) then ! a has at least as many rows as columns. if a has sufficiently @@ -65723,45 +65725,45 @@ module stdlib_linalg_lapack_c if( wntqn ) then ! path 1 (m >> n, jobz='n') ! no singular vectors to be computed - itau = 1 + itau = 1_${ik}$ nwork = itau + n ! compute a=q*r ! cworkspace: need n [tau] + n [work] ! cworkspace: prefer n [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_cgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_cgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) ! zero out below r - if (n>1) call stdlib_claset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) - ie = 1 - itauq = 1 + if (n>1_${ik}$) call stdlib${ii}$_claset( 'L', n-1, n-1, czero, czero, a( 2_${ik}$, 1_${ik}$ ),lda ) + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + n nwork = itaup + n ! bidiagonalize r in a ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + 2*n*nb [work] ! rworkspace: need n [e] - call stdlib_cgebrd( n, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& + call stdlib${ii}$_cgebrd( n, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& work( nwork ), lwork-nwork+1,ierr ) nrwork = ie + n ! perform bidiagonal svd, compute singular values only ! cworkspace: need 0 ! rworkspace: need n [e] + bdspac - call stdlib_sbdsdc( 'U', 'N', n, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& + call stdlib${ii}$_sbdsdc( 'U', 'N', n, s, rwork( ie ), dum,1_${ik}$,dum,1_${ik}$,dum, idum, rwork(& nrwork ), iwork, info ) else if( wntqo ) then ! path 2 (m >> n, jobz='o') ! n left singular vectors to be overwritten on a and ! n right singular vectors to be computed in vt - iu = 1 + iu = 1_${ik}$ ! work(iu) is n by n ldwrku = n ir = iu + ldwrku*n - if( lwork >= m*n + n*n + 3*n ) then + if( lwork >= m*n + n*n + 3_${ik}$*n ) then ! work(ir) is m by n ldwrkr = m else - ldwrkr = ( lwork - n*n - 3*n ) / n + ldwrkr = ( lwork - n*n - 3_${ik}$*n ) / n end if itau = ir + ldwrkr*n nwork = itau + n @@ -65769,18 +65771,18 @@ module stdlib_linalg_lapack_c ! cworkspace: need n*n [u] + n*n [r] + n [tau] + n [work] ! cworkspace: prefer n*n [u] + n*n [r] + n [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_cgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_cgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) ! copy r to work( ir ), zeroing out below it - call stdlib_clacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) - call stdlib_claset( 'L', n-1, n-1, czero, czero, work( ir+1 ),ldwrkr ) + call stdlib${ii}$_clacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) + call stdlib${ii}$_claset( 'L', n-1, n-1, czero, czero, work( ir+1 ),ldwrkr ) ! generate q in a ! cworkspace: need n*n [u] + n*n [r] + n [tau] + n [work] ! cworkspace: prefer n*n [u] + n*n [r] + n [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_cungqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork-nwork+& - 1, ierr ) - ie = 1 + call stdlib${ii}$_cungqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork-nwork+& + 1_${ik}$, ierr ) + ie = 1_${ik}$ itauq = itau itaup = itauq + n nwork = itaup + n @@ -65788,7 +65790,7 @@ module stdlib_linalg_lapack_c ! cworkspace: need n*n [u] + n*n [r] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [u] + n*n [r] + 2*n [tauq, taup] + 2*n*nb [work] ! rworkspace: need n [e] - call stdlib_cgebrd( n, n, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ), & + call stdlib${ii}$_cgebrd( n, n, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ), & work( itaup ), work( nwork ),lwork-nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of r in work(iru) and computing right singular vectors @@ -65798,23 +65800,23 @@ module stdlib_linalg_lapack_c iru = ie + n irvt = iru + n*n nrwork = irvt + n*n - call stdlib_sbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_sbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=sp) to complex matrix work(iu) ! overwrite work(iu) by the left singular vectors of r ! cworkspace: need n*n [u] + n*n [r] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [u] + n*n [r] + 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_clacp2( 'F', n, n, rwork( iru ), n, work( iu ),ldwrku ) - call stdlib_cunmbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_clacp2( 'F', n, n, rwork( iru ), n, work( iu ),ldwrku ) + call stdlib${ii}$_cunmbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & work( iu ), ldwrku,work( nwork ), lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=sp) to complex matrix vt ! overwrite vt by the right singular vectors of r ! cworkspace: need n*n [u] + n*n [r] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [u] + n*n [r] + 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_clacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) - call stdlib_cunmbr( 'P', 'R', 'C', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_clacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) + call stdlib${ii}$_cunmbr( 'P', 'R', 'C', n, n, n, work( ir ), ldwrkr,work( itaup ), & vt, ldvt, work( nwork ),lwork-nwork+1, ierr ) ! multiply q in a by left singular vectors of r in ! work(iu), storing result in work(ir) and copying to a @@ -65823,16 +65825,16 @@ module stdlib_linalg_lapack_c ! rworkspace: need 0 do i = 1, m, ldwrkr chunk = min( m-i+1, ldwrkr ) - call stdlib_cgemm( 'N', 'N', chunk, n, n, cone, a( i, 1 ),lda, work( iu ), & + call stdlib${ii}$_cgemm( 'N', 'N', chunk, n, n, cone, a( i, 1_${ik}$ ),lda, work( iu ), & ldwrku, czero,work( ir ), ldwrkr ) - call stdlib_clacpy( 'F', chunk, n, work( ir ), ldwrkr,a( i, 1 ), lda ) + call stdlib${ii}$_clacpy( 'F', chunk, n, work( ir ), ldwrkr,a( i, 1_${ik}$ ), lda ) end do else if( wntqs ) then ! path 3 (m >> n, jobz='s') ! n left singular vectors to be computed in u and ! n right singular vectors to be computed in vt - ir = 1 + ir = 1_${ik}$ ! work(ir) is n by n ldwrkr = n itau = ir + ldwrkr*n @@ -65841,18 +65843,18 @@ module stdlib_linalg_lapack_c ! cworkspace: need n*n [r] + n [tau] + n [work] ! cworkspace: prefer n*n [r] + n [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_cgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_cgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) ! copy r to work(ir), zeroing out below it - call stdlib_clacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) - call stdlib_claset( 'L', n-1, n-1, czero, czero, work( ir+1 ),ldwrkr ) + call stdlib${ii}$_clacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) + call stdlib${ii}$_claset( 'L', n-1, n-1, czero, czero, work( ir+1 ),ldwrkr ) ! generate q in a ! cworkspace: need n*n [r] + n [tau] + n [work] ! cworkspace: prefer n*n [r] + n [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_cungqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork-nwork+& - 1, ierr ) - ie = 1 + call stdlib${ii}$_cungqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork-nwork+& + 1_${ik}$, ierr ) + ie = 1_${ik}$ itauq = itau itaup = itauq + n nwork = itaup + n @@ -65860,7 +65862,7 @@ module stdlib_linalg_lapack_c ! cworkspace: need n*n [r] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [r] + 2*n [tauq, taup] + 2*n*nb [work] ! rworkspace: need n [e] - call stdlib_cgebrd( n, n, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ), & + call stdlib${ii}$_cgebrd( n, n, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ), & work( itaup ), work( nwork ),lwork-nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -65870,36 +65872,36 @@ module stdlib_linalg_lapack_c iru = ie + n irvt = iru + n*n nrwork = irvt + n*n - call stdlib_sbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_sbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=sp) to complex matrix u ! overwrite u by left singular vectors of r ! cworkspace: need n*n [r] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [r] + 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_clacp2( 'F', n, n, rwork( iru ), n, u, ldu ) - call stdlib_cunmbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_clacp2( 'F', n, n, rwork( iru ), n, u, ldu ) + call stdlib${ii}$_cunmbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & u, ldu, work( nwork ),lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=sp) to complex matrix vt ! overwrite vt by right singular vectors of r ! cworkspace: need n*n [r] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [r] + 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_clacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) - call stdlib_cunmbr( 'P', 'R', 'C', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_clacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) + call stdlib${ii}$_cunmbr( 'P', 'R', 'C', n, n, n, work( ir ), ldwrkr,work( itaup ), & vt, ldvt, work( nwork ),lwork-nwork+1, ierr ) ! multiply q in a by left singular vectors of r in ! work(ir), storing result in u ! cworkspace: need n*n [r] ! rworkspace: need 0 - call stdlib_clacpy( 'F', n, n, u, ldu, work( ir ), ldwrkr ) - call stdlib_cgemm( 'N', 'N', m, n, n, cone, a, lda, work( ir ),ldwrkr, czero, & + call stdlib${ii}$_clacpy( 'F', n, n, u, ldu, work( ir ), ldwrkr ) + call stdlib${ii}$_cgemm( 'N', 'N', m, n, n, cone, a, lda, work( ir ),ldwrkr, czero, & u, ldu ) else if( wntqa ) then ! path 4 (m >> n, jobz='a') ! m left singular vectors to be computed in u and ! n right singular vectors to be computed in vt - iu = 1 + iu = 1_${ik}$ ! work(iu) is n by n ldwrku = n itau = iu + ldwrku*n @@ -65908,18 +65910,18 @@ module stdlib_linalg_lapack_c ! cworkspace: need n*n [u] + n [tau] + n [work] ! cworkspace: prefer n*n [u] + n [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_cgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_cgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) - call stdlib_clacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_clacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! cworkspace: need n*n [u] + n [tau] + m [work] ! cworkspace: prefer n*n [u] + n [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_cungqr( m, m, n, u, ldu, work( itau ),work( nwork ), lwork-nwork+& - 1, ierr ) + call stdlib${ii}$_cungqr( m, m, n, u, ldu, work( itau ),work( nwork ), lwork-nwork+& + 1_${ik}$, ierr ) ! produce r in a, zeroing out below it - if (n>1) call stdlib_claset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) - ie = 1 + if (n>1_${ik}$) call stdlib${ii}$_claset( 'L', n-1, n-1, czero, czero, a( 2_${ik}$, 1_${ik}$ ),lda ) + ie = 1_${ik}$ itauq = itau itaup = itauq + n nwork = itaup + n @@ -65927,7 +65929,7 @@ module stdlib_linalg_lapack_c ! cworkspace: need n*n [u] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [u] + 2*n [tauq, taup] + 2*n*nb [work] ! rworkspace: need n [e] - call stdlib_cgebrd( n, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& + call stdlib${ii}$_cgebrd( n, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& work( nwork ), lwork-nwork+1,ierr ) iru = ie + n irvt = iru + n*n @@ -65937,55 +65939,55 @@ module stdlib_linalg_lapack_c ! singular vectors of bidiagonal matrix in rwork(irvt) ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] + bdspac - call stdlib_sbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_sbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=sp) to complex matrix work(iu) ! overwrite work(iu) by left singular vectors of r ! cworkspace: need n*n [u] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [u] + 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_clacp2( 'F', n, n, rwork( iru ), n, work( iu ),ldwrku ) - call stdlib_cunmbr( 'Q', 'L', 'N', n, n, n, a, lda,work( itauq ), work( iu ), & + call stdlib${ii}$_clacp2( 'F', n, n, rwork( iru ), n, work( iu ),ldwrku ) + call stdlib${ii}$_cunmbr( 'Q', 'L', 'N', n, n, n, a, lda,work( itauq ), work( iu ), & ldwrku,work( nwork ), lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=sp) to complex matrix vt ! overwrite vt by right singular vectors of r ! cworkspace: need n*n [u] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [u] + 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_clacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) - call stdlib_cunmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & + call stdlib${ii}$_clacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) + call stdlib${ii}$_cunmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork-nwork+1, ierr ) ! multiply q in u by left singular vectors of r in ! work(iu), storing result in a ! cworkspace: need n*n [u] ! rworkspace: need 0 - call stdlib_cgemm( 'N', 'N', m, n, n, cone, u, ldu, work( iu ),ldwrku, czero, & + call stdlib${ii}$_cgemm( 'N', 'N', m, n, n, cone, u, ldu, work( iu ),ldwrku, czero, & a, lda ) ! copy left singular vectors of a from a to u - call stdlib_clacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_clacpy( 'F', m, n, a, lda, u, ldu ) end if else if( m>=mnthr2 ) then ! mnthr2 <= m < mnthr1 ! path 5 (m >> n, but not as much as mnthr1) ! reduce to bidiagonal form without qr decomposition, use - ! stdlib_cungbr and matrix multiplication to compute singular vectors - ie = 1 + ! stdlib${ii}$_cungbr and matrix multiplication to compute singular vectors + ie = 1_${ik}$ nrwork = ie + n - itauq = 1 + itauq = 1_${ik}$ itaup = itauq + n nwork = itaup + n ! bidiagonalize a ! cworkspace: need 2*n [tauq, taup] + m [work] ! cworkspace: prefer 2*n [tauq, taup] + (m+n)*nb [work] ! rworkspace: need n [e] - call stdlib_cgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_cgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) if( wntqn ) then ! path 5n (m >> n, jobz='n') ! compute singular values only ! cworkspace: need 0 ! rworkspace: need n [e] + bdspac - call stdlib_sbdsdc( 'U', 'N', n, s, rwork( ie ), dum, 1,dum,1,dum, idum, & + call stdlib${ii}$_sbdsdc( 'U', 'N', n, s, rwork( ie ), dum, 1_${ik}$,dum,1_${ik}$,dum, idum, & rwork( nrwork ), iwork, info ) else if( wntqo ) then iu = nwork @@ -65997,21 +65999,21 @@ module stdlib_linalg_lapack_c ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_clacpy( 'U', n, n, a, lda, vt, ldvt ) - call stdlib_cungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( nwork ), & + call stdlib${ii}$_clacpy( 'U', n, n, a, lda, vt, ldvt ) + call stdlib${ii}$_cungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( nwork ), & lwork-nwork+1, ierr ) ! generate q in a ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_cungbr( 'Q', m, n, n, a, lda, work( itauq ),work( nwork ), lwork-& + call stdlib${ii}$_cungbr( 'Q', m, n, n, a, lda, work( itauq ),work( nwork ), lwork-& nwork+1, ierr ) - if( lwork >= m*n + 3*n ) then + if( lwork >= m*n + 3_${ik}$*n ) then ! work( iu ) is m by n ldwrku = m else ! work(iu) is ldwrku by n - ldwrku = ( lwork - 3*n ) / n + ldwrku = ( lwork - 3_${ik}$*n ) / n end if nwork = iu + ldwrku*n ! perform bidiagonal svd, computing left singular vectors @@ -66019,15 +66021,15 @@ module stdlib_linalg_lapack_c ! singular vectors of bidiagonal matrix in rwork(irvt) ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] + bdspac - call stdlib_sbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_sbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! multiply realmatrix rwork(irvt,KIND=sp) by p**h in vt, ! storing the result in work(iu), copying to vt ! cworkspace: need 2*n [tauq, taup] + n*n [u] ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] + 2*n*n [rwork] - call stdlib_clarcm( n, n, rwork( irvt ), n, vt, ldvt,work( iu ), ldwrku, & + call stdlib${ii}$_clarcm( n, n, rwork( irvt ), n, vt, ldvt,work( iu ), ldwrku, & rwork( nrwork ) ) - call stdlib_clacpy( 'F', n, n, work( iu ), ldwrku, vt, ldvt ) + call stdlib${ii}$_clacpy( 'F', n, n, work( iu ), ldwrku, vt, ldvt ) ! multiply q in a by realmatrix rwork(iru,KIND=sp), storing the ! result in work(iu), copying to a ! cworkspace: need 2*n [tauq, taup] + n*n [u] @@ -66037,9 +66039,9 @@ module stdlib_linalg_lapack_c nrwork = irvt do i = 1, m, ldwrku chunk = min( m-i+1, ldwrku ) - call stdlib_clacrm( chunk, n, a( i, 1 ), lda, rwork( iru ),n, work( iu ), & + call stdlib${ii}$_clacrm( chunk, n, a( i, 1_${ik}$ ), lda, rwork( iru ),n, work( iu ), & ldwrku, rwork( nrwork ) ) - call stdlib_clacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) + call stdlib${ii}$_clacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1_${ik}$ ), lda ) end do else if( wntqs ) then @@ -66048,15 +66050,15 @@ module stdlib_linalg_lapack_c ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_clacpy( 'U', n, n, a, lda, vt, ldvt ) - call stdlib_cungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( nwork ), & + call stdlib${ii}$_clacpy( 'U', n, n, a, lda, vt, ldvt ) + call stdlib${ii}$_cungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( nwork ), & lwork-nwork+1, ierr ) ! copy a to u, generate q ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_clacpy( 'L', m, n, a, lda, u, ldu ) - call stdlib_cungbr( 'Q', m, n, n, u, ldu, work( itauq ),work( nwork ), lwork-& + call stdlib${ii}$_clacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_cungbr( 'Q', m, n, n, u, ldu, work( itauq ),work( nwork ), lwork-& nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -66066,38 +66068,38 @@ module stdlib_linalg_lapack_c iru = nrwork irvt = iru + n*n nrwork = irvt + n*n - call stdlib_sbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_sbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! multiply realmatrix rwork(irvt,KIND=sp) by p**h in vt, ! storing the result in a, copying to vt ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] + 2*n*n [rwork] - call stdlib_clarcm( n, n, rwork( irvt ), n, vt, ldvt, a, lda,rwork( nrwork ) ) + call stdlib${ii}$_clarcm( n, n, rwork( irvt ), n, vt, ldvt, a, lda,rwork( nrwork ) ) - call stdlib_clacpy( 'F', n, n, a, lda, vt, ldvt ) + call stdlib${ii}$_clacpy( 'F', n, n, a, lda, vt, ldvt ) ! multiply q in u by realmatrix rwork(iru,KIND=sp), storing the ! result in a, copying to u ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + 2*m*n [rwork] < n + 5*n*n since m < 2*n here nrwork = irvt - call stdlib_clacrm( m, n, u, ldu, rwork( iru ), n, a, lda,rwork( nrwork ) ) + call stdlib${ii}$_clacrm( m, n, u, ldu, rwork( iru ), n, a, lda,rwork( nrwork ) ) - call stdlib_clacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_clacpy( 'F', m, n, a, lda, u, ldu ) else ! path 5a (m >> n, jobz='a') ! copy a to vt, generate p**h ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_clacpy( 'U', n, n, a, lda, vt, ldvt ) - call stdlib_cungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( nwork ), & + call stdlib${ii}$_clacpy( 'U', n, n, a, lda, vt, ldvt ) + call stdlib${ii}$_cungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( nwork ), & lwork-nwork+1, ierr ) ! copy a to u, generate q ! cworkspace: need 2*n [tauq, taup] + m [work] ! cworkspace: prefer 2*n [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_clacpy( 'L', m, n, a, lda, u, ldu ) - call stdlib_cungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& + call stdlib${ii}$_clacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_cungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -66107,58 +66109,58 @@ module stdlib_linalg_lapack_c iru = nrwork irvt = iru + n*n nrwork = irvt + n*n - call stdlib_sbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_sbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! multiply realmatrix rwork(irvt,KIND=sp) by p**h in vt, ! storing the result in a, copying to vt ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] + 2*n*n [rwork] - call stdlib_clarcm( n, n, rwork( irvt ), n, vt, ldvt, a, lda,rwork( nrwork ) ) + call stdlib${ii}$_clarcm( n, n, rwork( irvt ), n, vt, ldvt, a, lda,rwork( nrwork ) ) - call stdlib_clacpy( 'F', n, n, a, lda, vt, ldvt ) + call stdlib${ii}$_clacpy( 'F', n, n, a, lda, vt, ldvt ) ! multiply q in u by realmatrix rwork(iru,KIND=sp), storing the ! result in a, copying to u ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + 2*m*n [rwork] < n + 5*n*n since m < 2*n here nrwork = irvt - call stdlib_clacrm( m, n, u, ldu, rwork( iru ), n, a, lda,rwork( nrwork ) ) + call stdlib${ii}$_clacrm( m, n, u, ldu, rwork( iru ), n, a, lda,rwork( nrwork ) ) - call stdlib_clacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_clacpy( 'F', m, n, a, lda, u, ldu ) end if else ! m < mnthr2 ! path 6 (m >= n, but not much larger) ! reduce to bidiagonal form without qr decomposition ! use stdlib_cunmbr to compute singular vectors - ie = 1 + ie = 1_${ik}$ nrwork = ie + n - itauq = 1 + itauq = 1_${ik}$ itaup = itauq + n nwork = itaup + n ! bidiagonalize a ! cworkspace: need 2*n [tauq, taup] + m [work] ! cworkspace: prefer 2*n [tauq, taup] + (m+n)*nb [work] ! rworkspace: need n [e] - call stdlib_cgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_cgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) if( wntqn ) then ! path 6n (m >= n, jobz='n') ! compute singular values only ! cworkspace: need 0 ! rworkspace: need n [e] + bdspac - call stdlib_sbdsdc( 'U', 'N', n, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& + call stdlib${ii}$_sbdsdc( 'U', 'N', n, s, rwork( ie ), dum,1_${ik}$,dum,1_${ik}$,dum, idum, rwork(& nrwork ), iwork, info ) else if( wntqo ) then iu = nwork iru = nrwork irvt = iru + n*n nrwork = irvt + n*n - if( lwork >= m*n + 3*n ) then + if( lwork >= m*n + 3_${ik}$*n ) then ! work( iu ) is m by n ldwrku = m else ! work( iu ) is ldwrku by n - ldwrku = ( lwork - 3*n ) / n + ldwrku = ( lwork - 3_${ik}$*n ) / n end if nwork = iu + ldwrku*n ! path 6o (m >= n, jobz='o') @@ -66167,17 +66169,17 @@ module stdlib_linalg_lapack_c ! singular vectors of bidiagonal matrix in rwork(irvt) ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] + bdspac - call stdlib_sbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_sbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(irvt,KIND=sp) to complex matrix vt ! overwrite vt by right singular vectors of a ! cworkspace: need 2*n [tauq, taup] + n*n [u] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*n [u] + n*nb [work] ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] - call stdlib_clacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) - call stdlib_cunmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & + call stdlib${ii}$_clacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) + call stdlib${ii}$_cunmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork-nwork+1, ierr ) - if( lwork >= m*n + 3*n ) then + if( lwork >= m*n + 3_${ik}$*n ) then ! path 6o-fast ! copy realmatrix rwork(iru,KIND=sp) to complex matrix work(iu) ! overwrite work(iu) by left singular vectors of a, copying @@ -66185,18 +66187,18 @@ module stdlib_linalg_lapack_c ! cworkspace: need 2*n [tauq, taup] + m*n [u] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + m*n [u] + n*nb [work] ! rworkspace: need n [e] + n*n [ru] - call stdlib_claset( 'F', m, n, czero, czero, work( iu ),ldwrku ) - call stdlib_clacp2( 'F', n, n, rwork( iru ), n, work( iu ),ldwrku ) - call stdlib_cunmbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), work( iu & + call stdlib${ii}$_claset( 'F', m, n, czero, czero, work( iu ),ldwrku ) + call stdlib${ii}$_clacp2( 'F', n, n, rwork( iru ), n, work( iu ),ldwrku ) + call stdlib${ii}$_cunmbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), work( iu & ), ldwrku,work( nwork ), lwork-nwork+1, ierr ) - call stdlib_clacpy( 'F', m, n, work( iu ), ldwrku, a, lda ) + call stdlib${ii}$_clacpy( 'F', m, n, work( iu ), ldwrku, a, lda ) else ! path 6o-slow ! generate q in a ! cworkspace: need 2*n [tauq, taup] + n*n [u] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*n [u] + n*nb [work] ! rworkspace: need 0 - call stdlib_cungbr( 'Q', m, n, n, a, lda, work( itauq ),work( nwork ), & + call stdlib${ii}$_cungbr( 'Q', m, n, n, a, lda, work( itauq ),work( nwork ), & lwork-nwork+1, ierr ) ! multiply q in a by realmatrix rwork(iru,KIND=sp), storing the ! result in work(iu), copying to a @@ -66207,9 +66209,9 @@ module stdlib_linalg_lapack_c nrwork = irvt do i = 1, m, ldwrku chunk = min( m-i+1, ldwrku ) - call stdlib_clacrm( chunk, n, a( i, 1 ), lda,rwork( iru ), n, work( iu )& + call stdlib${ii}$_clacrm( chunk, n, a( i, 1_${ik}$ ), lda,rwork( iru ), n, work( iu )& , ldwrku,rwork( nrwork ) ) - call stdlib_clacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) + call stdlib${ii}$_clacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1_${ik}$ ), lda ) end do end if @@ -66223,24 +66225,24 @@ module stdlib_linalg_lapack_c iru = nrwork irvt = iru + n*n nrwork = irvt + n*n - call stdlib_sbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_sbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=sp) to complex matrix u ! overwrite u by left singular vectors of a ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] - call stdlib_claset( 'F', m, n, czero, czero, u, ldu ) - call stdlib_clacp2( 'F', n, n, rwork( iru ), n, u, ldu ) - call stdlib_cunmbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), u, ldu, & + call stdlib${ii}$_claset( 'F', m, n, czero, czero, u, ldu ) + call stdlib${ii}$_clacp2( 'F', n, n, rwork( iru ), n, u, ldu ) + call stdlib${ii}$_cunmbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=sp) to complex matrix vt ! overwrite vt by right singular vectors of a ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] - call stdlib_clacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) - call stdlib_cunmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & + call stdlib${ii}$_clacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) + call stdlib${ii}$_cunmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork-nwork+1, ierr ) else ! path 6a (m >= n, jobz='a') @@ -66252,28 +66254,28 @@ module stdlib_linalg_lapack_c iru = nrwork irvt = iru + n*n nrwork = irvt + n*n - call stdlib_sbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_sbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! set the right corner of u to identity matrix - call stdlib_claset( 'F', m, m, czero, czero, u, ldu ) + call stdlib${ii}$_claset( 'F', m, m, czero, czero, u, ldu ) if( m>n ) then - call stdlib_claset( 'F', m-n, m-n, czero, cone,u( n+1, n+1 ), ldu ) + call stdlib${ii}$_claset( 'F', m-n, m-n, czero, cone,u( n+1, n+1 ), ldu ) end if ! copy realmatrix rwork(iru,KIND=sp) to complex matrix u ! overwrite u by left singular vectors of a ! cworkspace: need 2*n [tauq, taup] + m [work] ! cworkspace: prefer 2*n [tauq, taup] + m*nb [work] ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] - call stdlib_clacp2( 'F', n, n, rwork( iru ), n, u, ldu ) - call stdlib_cunmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + call stdlib${ii}$_clacp2( 'F', n, n, rwork( iru ), n, u, ldu ) + call stdlib${ii}$_cunmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=sp) to complex matrix vt ! overwrite vt by right singular vectors of a ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] - call stdlib_clacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) - call stdlib_cunmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & + call stdlib${ii}$_clacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) + call stdlib${ii}$_cunmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork-nwork+1, ierr ) end if end if @@ -66285,48 +66287,48 @@ module stdlib_linalg_lapack_c if( wntqn ) then ! path 1t (n >> m, jobz='n') ! no singular vectors to be computed - itau = 1 + itau = 1_${ik}$ nwork = itau + m ! compute a=l*q ! cworkspace: need m [tau] + m [work] ! cworkspace: prefer m [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_cgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_cgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) ! zero out above l - if (m>1) call stdlib_claset( 'U', m-1, m-1, czero, czero, a( 1, 2 ),lda ) - ie = 1 - itauq = 1 + if (m>1_${ik}$) call stdlib${ii}$_claset( 'U', m-1, m-1, czero, czero, a( 1_${ik}$, 2_${ik}$ ),lda ) + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + m nwork = itaup + m ! bidiagonalize l in a ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + 2*m*nb [work] ! rworkspace: need m [e] - call stdlib_cgebrd( m, m, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& + call stdlib${ii}$_cgebrd( m, m, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& work( nwork ), lwork-nwork+1,ierr ) nrwork = ie + m ! perform bidiagonal svd, compute singular values only ! cworkspace: need 0 ! rworkspace: need m [e] + bdspac - call stdlib_sbdsdc( 'U', 'N', m, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& + call stdlib${ii}$_sbdsdc( 'U', 'N', m, s, rwork( ie ), dum,1_${ik}$,dum,1_${ik}$,dum, idum, rwork(& nrwork ), iwork, info ) else if( wntqo ) then ! path 2t (n >> m, jobz='o') ! m right singular vectors to be overwritten on a and ! m left singular vectors to be computed in u - ivt = 1 + ivt = 1_${ik}$ ldwkvt = m ! work(ivt) is m by m il = ivt + ldwkvt*m - if( lwork >= m*n + m*m + 3*m ) then + if( lwork >= m*n + m*m + 3_${ik}$*m ) then ! work(il) m by n ldwrkl = m chunk = n else ! work(il) is m by chunk ldwrkl = m - chunk = ( lwork - m*m - 3*m ) / m + chunk = ( lwork - m*m - 3_${ik}$*m ) / m end if itau = il + ldwrkl*chunk nwork = itau + m @@ -66334,19 +66336,19 @@ module stdlib_linalg_lapack_c ! cworkspace: need m*m [vt] + m*m [l] + m [tau] + m [work] ! cworkspace: prefer m*m [vt] + m*m [l] + m [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_cgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_cgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) ! copy l to work(il), zeroing about above it - call stdlib_clacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) - call stdlib_claset( 'U', m-1, m-1, czero, czero,work( il+ldwrkl ), ldwrkl ) + call stdlib${ii}$_clacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) + call stdlib${ii}$_claset( 'U', m-1, m-1, czero, czero,work( il+ldwrkl ), ldwrkl ) ! generate q in a ! cworkspace: need m*m [vt] + m*m [l] + m [tau] + m [work] ! cworkspace: prefer m*m [vt] + m*m [l] + m [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_cunglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork-nwork+& - 1, ierr ) - ie = 1 + call stdlib${ii}$_cunglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork-nwork+& + 1_${ik}$, ierr ) + ie = 1_${ik}$ itauq = itau itaup = itauq + m nwork = itaup + m @@ -66354,7 +66356,7 @@ module stdlib_linalg_lapack_c ! cworkspace: need m*m [vt] + m*m [l] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [vt] + m*m [l] + 2*m [tauq, taup] + 2*m*nb [work] ! rworkspace: need m [e] - call stdlib_cgebrd( m, m, work( il ), ldwrkl, s, rwork( ie ),work( itauq ), & + call stdlib${ii}$_cgebrd( m, m, work( il ), ldwrkl, s, rwork( ie ),work( itauq ), & work( itaup ), work( nwork ),lwork-nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -66364,23 +66366,23 @@ module stdlib_linalg_lapack_c iru = ie + m irvt = iru + m*m nrwork = irvt + m*m - call stdlib_sbdsdc( 'U', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_sbdsdc( 'U', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=sp) to complex matrix work(iu) ! overwrite work(iu) by the left singular vectors of l ! cworkspace: need m*m [vt] + m*m [l] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [vt] + m*m [l] + 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_clacp2( 'F', m, m, rwork( iru ), m, u, ldu ) - call stdlib_cunmbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & + call stdlib${ii}$_clacp2( 'F', m, m, rwork( iru ), m, u, ldu ) + call stdlib${ii}$_cunmbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & u, ldu, work( nwork ),lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=sp) to complex matrix work(ivt) ! overwrite work(ivt) by the right singular vectors of l ! cworkspace: need m*m [vt] + m*m [l] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [vt] + m*m [l] + 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_clacp2( 'F', m, m, rwork( irvt ), m, work( ivt ),ldwkvt ) - call stdlib_cunmbr( 'P', 'R', 'C', m, m, m, work( il ), ldwrkl,work( itaup ), & + call stdlib${ii}$_clacp2( 'F', m, m, rwork( irvt ), m, work( ivt ),ldwkvt ) + call stdlib${ii}$_cunmbr( 'P', 'R', 'C', m, m, m, work( il ), ldwrkl,work( itaup ), & work( ivt ), ldwkvt,work( nwork ), lwork-nwork+1, ierr ) ! multiply right singular vectors of l in work(il) by q ! in a, storing result in work(il) and copying to a @@ -66389,16 +66391,16 @@ module stdlib_linalg_lapack_c ! rworkspace: need 0 do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_cgemm( 'N', 'N', m, blk, m, cone, work( ivt ), m,a( 1, i ), & + call stdlib${ii}$_cgemm( 'N', 'N', m, blk, m, cone, work( ivt ), m,a( 1_${ik}$, i ), & lda, czero, work( il ),ldwrkl ) - call stdlib_clacpy( 'F', m, blk, work( il ), ldwrkl,a( 1, i ), lda ) + call stdlib${ii}$_clacpy( 'F', m, blk, work( il ), ldwrkl,a( 1_${ik}$, i ), lda ) end do else if( wntqs ) then ! path 3t (n >> m, jobz='s') ! m right singular vectors to be computed in vt and ! m left singular vectors to be computed in u - il = 1 + il = 1_${ik}$ ! work(il) is m by m ldwrkl = m itau = il + ldwrkl*m @@ -66407,19 +66409,19 @@ module stdlib_linalg_lapack_c ! cworkspace: need m*m [l] + m [tau] + m [work] ! cworkspace: prefer m*m [l] + m [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_cgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_cgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) ! copy l to work(il), zeroing out above it - call stdlib_clacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) - call stdlib_claset( 'U', m-1, m-1, czero, czero,work( il+ldwrkl ), ldwrkl ) + call stdlib${ii}$_clacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) + call stdlib${ii}$_claset( 'U', m-1, m-1, czero, czero,work( il+ldwrkl ), ldwrkl ) ! generate q in a ! cworkspace: need m*m [l] + m [tau] + m [work] ! cworkspace: prefer m*m [l] + m [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_cunglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork-nwork+& - 1, ierr ) - ie = 1 + call stdlib${ii}$_cunglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork-nwork+& + 1_${ik}$, ierr ) + ie = 1_${ik}$ itauq = itau itaup = itauq + m nwork = itaup + m @@ -66427,7 +66429,7 @@ module stdlib_linalg_lapack_c ! cworkspace: need m*m [l] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [l] + 2*m [tauq, taup] + 2*m*nb [work] ! rworkspace: need m [e] - call stdlib_cgebrd( m, m, work( il ), ldwrkl, s, rwork( ie ),work( itauq ), & + call stdlib${ii}$_cgebrd( m, m, work( il ), ldwrkl, s, rwork( ie ),work( itauq ), & work( itaup ), work( nwork ),lwork-nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -66437,36 +66439,36 @@ module stdlib_linalg_lapack_c iru = ie + m irvt = iru + m*m nrwork = irvt + m*m - call stdlib_sbdsdc( 'U', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_sbdsdc( 'U', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=sp) to complex matrix u ! overwrite u by left singular vectors of l ! cworkspace: need m*m [l] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [l] + 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_clacp2( 'F', m, m, rwork( iru ), m, u, ldu ) - call stdlib_cunmbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & + call stdlib${ii}$_clacp2( 'F', m, m, rwork( iru ), m, u, ldu ) + call stdlib${ii}$_cunmbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & u, ldu, work( nwork ),lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=sp) to complex matrix vt ! overwrite vt by left singular vectors of l ! cworkspace: need m*m [l] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [l] + 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_clacp2( 'F', m, m, rwork( irvt ), m, vt, ldvt ) - call stdlib_cunmbr( 'P', 'R', 'C', m, m, m, work( il ), ldwrkl,work( itaup ), & + call stdlib${ii}$_clacp2( 'F', m, m, rwork( irvt ), m, vt, ldvt ) + call stdlib${ii}$_cunmbr( 'P', 'R', 'C', m, m, m, work( il ), ldwrkl,work( itaup ), & vt, ldvt, work( nwork ),lwork-nwork+1, ierr ) ! copy vt to work(il), multiply right singular vectors of l ! in work(il) by q in a, storing result in vt ! cworkspace: need m*m [l] ! rworkspace: need 0 - call stdlib_clacpy( 'F', m, m, vt, ldvt, work( il ), ldwrkl ) - call stdlib_cgemm( 'N', 'N', m, n, m, cone, work( il ), ldwrkl,a, lda, czero, & + call stdlib${ii}$_clacpy( 'F', m, m, vt, ldvt, work( il ), ldwrkl ) + call stdlib${ii}$_cgemm( 'N', 'N', m, n, m, cone, work( il ), ldwrkl,a, lda, czero, & vt, ldvt ) else if( wntqa ) then ! path 4t (n >> m, jobz='a') ! n right singular vectors to be computed in vt and ! m left singular vectors to be computed in u - ivt = 1 + ivt = 1_${ik}$ ! work(ivt) is m by m ldwkvt = m itau = ivt + ldwkvt*m @@ -66475,18 +66477,18 @@ module stdlib_linalg_lapack_c ! cworkspace: need m*m [vt] + m [tau] + m [work] ! cworkspace: prefer m*m [vt] + m [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_cgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_cgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) - call stdlib_clacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_clacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! cworkspace: need m*m [vt] + m [tau] + n [work] ! cworkspace: prefer m*m [vt] + m [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_cunglq( n, n, m, vt, ldvt, work( itau ),work( nwork ), lwork-& + call stdlib${ii}$_cunglq( n, n, m, vt, ldvt, work( itau ),work( nwork ), lwork-& nwork+1, ierr ) ! produce l in a, zeroing out above it - if (m>1) call stdlib_claset( 'U', m-1, m-1, czero, czero, a( 1, 2 ),lda ) - ie = 1 + if (m>1_${ik}$) call stdlib${ii}$_claset( 'U', m-1, m-1, czero, czero, a( 1_${ik}$, 2_${ik}$ ),lda ) + ie = 1_${ik}$ itauq = itau itaup = itauq + m nwork = itaup + m @@ -66494,7 +66496,7 @@ module stdlib_linalg_lapack_c ! cworkspace: need m*m [vt] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [vt] + 2*m [tauq, taup] + 2*m*nb [work] ! rworkspace: need m [e] - call stdlib_cgebrd( m, m, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& + call stdlib${ii}$_cgebrd( m, m, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& work( nwork ), lwork-nwork+1,ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -66504,55 +66506,55 @@ module stdlib_linalg_lapack_c iru = ie + m irvt = iru + m*m nrwork = irvt + m*m - call stdlib_sbdsdc( 'U', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_sbdsdc( 'U', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=sp) to complex matrix u ! overwrite u by left singular vectors of l ! cworkspace: need m*m [vt] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [vt] + 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_clacp2( 'F', m, m, rwork( iru ), m, u, ldu ) - call stdlib_cunmbr( 'Q', 'L', 'N', m, m, m, a, lda,work( itauq ), u, ldu, & + call stdlib${ii}$_clacp2( 'F', m, m, rwork( iru ), m, u, ldu ) + call stdlib${ii}$_cunmbr( 'Q', 'L', 'N', m, m, m, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=sp) to complex matrix work(ivt) ! overwrite work(ivt) by right singular vectors of l ! cworkspace: need m*m [vt] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [vt] + 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_clacp2( 'F', m, m, rwork( irvt ), m, work( ivt ),ldwkvt ) - call stdlib_cunmbr( 'P', 'R', 'C', m, m, m, a, lda,work( itaup ), work( ivt ),& + call stdlib${ii}$_clacp2( 'F', m, m, rwork( irvt ), m, work( ivt ),ldwkvt ) + call stdlib${ii}$_cunmbr( 'P', 'R', 'C', m, m, m, a, lda,work( itaup ), work( ivt ),& ldwkvt,work( nwork ), lwork-nwork+1, ierr ) ! multiply right singular vectors of l in work(ivt) by ! q in vt, storing result in a ! cworkspace: need m*m [vt] ! rworkspace: need 0 - call stdlib_cgemm( 'N', 'N', m, n, m, cone, work( ivt ), ldwkvt,vt, ldvt, & + call stdlib${ii}$_cgemm( 'N', 'N', m, n, m, cone, work( ivt ), ldwkvt,vt, ldvt, & czero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_clacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_clacpy( 'F', m, n, a, lda, vt, ldvt ) end if else if( n>=mnthr2 ) then ! mnthr2 <= n < mnthr1 ! path 5t (n >> m, but not as much as mnthr1) ! reduce to bidiagonal form without qr decomposition, use - ! stdlib_cungbr and matrix multiplication to compute singular vectors - ie = 1 + ! stdlib${ii}$_cungbr and matrix multiplication to compute singular vectors + ie = 1_${ik}$ nrwork = ie + m - itauq = 1 + itauq = 1_${ik}$ itaup = itauq + m nwork = itaup + m ! bidiagonalize a ! cworkspace: need 2*m [tauq, taup] + n [work] ! cworkspace: prefer 2*m [tauq, taup] + (m+n)*nb [work] ! rworkspace: need m [e] - call stdlib_cgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_cgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) if( wntqn ) then ! path 5tn (n >> m, jobz='n') ! compute singular values only ! cworkspace: need 0 ! rworkspace: need m [e] + bdspac - call stdlib_sbdsdc( 'L', 'N', m, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& + call stdlib${ii}$_sbdsdc( 'L', 'N', m, s, rwork( ie ), dum,1_${ik}$,dum,1_${ik}$,dum, idum, rwork(& nrwork ), iwork, info ) else if( wntqo ) then irvt = nrwork @@ -66564,23 +66566,23 @@ module stdlib_linalg_lapack_c ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_clacpy( 'L', m, m, a, lda, u, ldu ) - call stdlib_cungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& + call stdlib${ii}$_clacpy( 'L', m, m, a, lda, u, ldu ) + call stdlib${ii}$_cungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& nwork+1, ierr ) ! generate p**h in a ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_cungbr( 'P', m, n, m, a, lda, work( itaup ),work( nwork ), lwork-& + call stdlib${ii}$_cungbr( 'P', m, n, m, a, lda, work( itaup ),work( nwork ), lwork-& nwork+1, ierr ) ldwkvt = m - if( lwork >= m*n + 3*m ) then + if( lwork >= m*n + 3_${ik}$*m ) then ! work( ivt ) is m by n nwork = ivt + ldwkvt*n chunk = n else ! work( ivt ) is m by chunk - chunk = ( lwork - 3*m ) / m + chunk = ( lwork - 3_${ik}$*m ) / m nwork = ivt + ldwkvt*chunk end if ! perform bidiagonal svd, computing left singular vectors @@ -66588,15 +66590,15 @@ module stdlib_linalg_lapack_c ! singular vectors of bidiagonal matrix in rwork(irvt) ! cworkspace: need 0 ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] + bdspac - call stdlib_sbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_sbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! multiply q in u by realmatrix rwork(irvt,KIND=sp) ! storing the result in work(ivt), copying to u ! cworkspace: need 2*m [tauq, taup] + m*m [vt] ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] + 2*m*m [rwork] - call stdlib_clacrm( m, m, u, ldu, rwork( iru ), m, work( ivt ),ldwkvt, rwork( & + call stdlib${ii}$_clacrm( m, m, u, ldu, rwork( iru ), m, work( ivt ),ldwkvt, rwork( & nrwork ) ) - call stdlib_clacpy( 'F', m, m, work( ivt ), ldwkvt, u, ldu ) + call stdlib${ii}$_clacpy( 'F', m, m, work( ivt ), ldwkvt, u, ldu ) ! multiply rwork(irvt) by p**h in a, storing the ! result in work(ivt), copying to a ! cworkspace: need 2*m [tauq, taup] + m*m [vt] @@ -66606,9 +66608,9 @@ module stdlib_linalg_lapack_c nrwork = iru do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_clarcm( m, blk, rwork( irvt ), m, a( 1, i ), lda,work( ivt ), & + call stdlib${ii}$_clarcm( m, blk, rwork( irvt ), m, a( 1_${ik}$, i ), lda,work( ivt ), & ldwkvt, rwork( nrwork ) ) - call stdlib_clacpy( 'F', m, blk, work( ivt ), ldwkvt,a( 1, i ), lda ) + call stdlib${ii}$_clacpy( 'F', m, blk, work( ivt ), ldwkvt,a( 1_${ik}$, i ), lda ) end do else if( wntqs ) then @@ -66617,15 +66619,15 @@ module stdlib_linalg_lapack_c ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_clacpy( 'L', m, m, a, lda, u, ldu ) - call stdlib_cungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& + call stdlib${ii}$_clacpy( 'L', m, m, a, lda, u, ldu ) + call stdlib${ii}$_cungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& nwork+1, ierr ) ! copy a to vt, generate p**h ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_clacpy( 'U', m, n, a, lda, vt, ldvt ) - call stdlib_cungbr( 'P', m, n, m, vt, ldvt, work( itaup ),work( nwork ), & + call stdlib${ii}$_clacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_cungbr( 'P', m, n, m, vt, ldvt, work( itaup ),work( nwork ), & lwork-nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -66635,38 +66637,38 @@ module stdlib_linalg_lapack_c irvt = nrwork iru = irvt + m*m nrwork = iru + m*m - call stdlib_sbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_sbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! multiply q in u by realmatrix rwork(iru,KIND=sp), storing the ! result in a, copying to u ! cworkspace: need 0 ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] + 2*m*m [rwork] - call stdlib_clacrm( m, m, u, ldu, rwork( iru ), m, a, lda,rwork( nrwork ) ) + call stdlib${ii}$_clacrm( m, m, u, ldu, rwork( iru ), m, a, lda,rwork( nrwork ) ) - call stdlib_clacpy( 'F', m, m, a, lda, u, ldu ) + call stdlib${ii}$_clacpy( 'F', m, m, a, lda, u, ldu ) ! multiply realmatrix rwork(irvt,KIND=sp) by p**h in vt, ! storing the result in a, copying to vt ! cworkspace: need 0 ! rworkspace: need m [e] + m*m [rvt] + 2*m*n [rwork] < m + 5*m*m since n < 2*m here nrwork = iru - call stdlib_clarcm( m, n, rwork( irvt ), m, vt, ldvt, a, lda,rwork( nrwork ) ) + call stdlib${ii}$_clarcm( m, n, rwork( irvt ), m, vt, ldvt, a, lda,rwork( nrwork ) ) - call stdlib_clacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_clacpy( 'F', m, n, a, lda, vt, ldvt ) else ! path 5ta (n >> m, jobz='a') ! copy a to u, generate q ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_clacpy( 'L', m, m, a, lda, u, ldu ) - call stdlib_cungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& + call stdlib${ii}$_clacpy( 'L', m, m, a, lda, u, ldu ) + call stdlib${ii}$_cungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& nwork+1, ierr ) ! copy a to vt, generate p**h ! cworkspace: need 2*m [tauq, taup] + n [work] ! cworkspace: prefer 2*m [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_clacpy( 'U', m, n, a, lda, vt, ldvt ) - call stdlib_cungbr( 'P', n, n, m, vt, ldvt, work( itaup ),work( nwork ), & + call stdlib${ii}$_clacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_cungbr( 'P', n, n, m, vt, ldvt, work( itaup ),work( nwork ), & lwork-nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -66676,58 +66678,58 @@ module stdlib_linalg_lapack_c irvt = nrwork iru = irvt + m*m nrwork = iru + m*m - call stdlib_sbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_sbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! multiply q in u by realmatrix rwork(iru,KIND=sp), storing the ! result in a, copying to u ! cworkspace: need 0 ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] + 2*m*m [rwork] - call stdlib_clacrm( m, m, u, ldu, rwork( iru ), m, a, lda,rwork( nrwork ) ) + call stdlib${ii}$_clacrm( m, m, u, ldu, rwork( iru ), m, a, lda,rwork( nrwork ) ) - call stdlib_clacpy( 'F', m, m, a, lda, u, ldu ) + call stdlib${ii}$_clacpy( 'F', m, m, a, lda, u, ldu ) ! multiply realmatrix rwork(irvt,KIND=sp) by p**h in vt, ! storing the result in a, copying to vt ! cworkspace: need 0 ! rworkspace: need m [e] + m*m [rvt] + 2*m*n [rwork] < m + 5*m*m since n < 2*m here nrwork = iru - call stdlib_clarcm( m, n, rwork( irvt ), m, vt, ldvt, a, lda,rwork( nrwork ) ) + call stdlib${ii}$_clarcm( m, n, rwork( irvt ), m, vt, ldvt, a, lda,rwork( nrwork ) ) - call stdlib_clacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_clacpy( 'F', m, n, a, lda, vt, ldvt ) end if else ! n < mnthr2 ! path 6t (n > m, but not much larger) ! reduce to bidiagonal form without lq decomposition ! use stdlib_cunmbr to compute singular vectors - ie = 1 + ie = 1_${ik}$ nrwork = ie + m - itauq = 1 + itauq = 1_${ik}$ itaup = itauq + m nwork = itaup + m ! bidiagonalize a ! cworkspace: need 2*m [tauq, taup] + n [work] ! cworkspace: prefer 2*m [tauq, taup] + (m+n)*nb [work] ! rworkspace: need m [e] - call stdlib_cgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_cgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) if( wntqn ) then ! path 6tn (n > m, jobz='n') ! compute singular values only ! cworkspace: need 0 ! rworkspace: need m [e] + bdspac - call stdlib_sbdsdc( 'L', 'N', m, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& + call stdlib${ii}$_sbdsdc( 'L', 'N', m, s, rwork( ie ), dum,1_${ik}$,dum,1_${ik}$,dum, idum, rwork(& nrwork ), iwork, info ) else if( wntqo ) then ! path 6to (n > m, jobz='o') ldwkvt = m ivt = nwork - if( lwork >= m*n + 3*m ) then + if( lwork >= m*n + 3_${ik}$*m ) then ! work( ivt ) is m by n - call stdlib_claset( 'F', m, n, czero, czero, work( ivt ),ldwkvt ) + call stdlib${ii}$_claset( 'F', m, n, czero, czero, work( ivt ),ldwkvt ) nwork = ivt + ldwkvt*n else ! work( ivt ) is m by chunk - chunk = ( lwork - 3*m ) / m + chunk = ( lwork - 3_${ik}$*m ) / m nwork = ivt + ldwkvt*chunk end if ! perform bidiagonal svd, computing left singular vectors @@ -66738,17 +66740,17 @@ module stdlib_linalg_lapack_c irvt = nrwork iru = irvt + m*m nrwork = iru + m*m - call stdlib_sbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_sbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=sp) to complex matrix u ! overwrite u by left singular vectors of a ! cworkspace: need 2*m [tauq, taup] + m*m [vt] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*m [vt] + m*nb [work] ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] - call stdlib_clacp2( 'F', m, m, rwork( iru ), m, u, ldu ) - call stdlib_cunmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + call stdlib${ii}$_clacp2( 'F', m, m, rwork( iru ), m, u, ldu ) + call stdlib${ii}$_cunmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork-nwork+1, ierr ) - if( lwork >= m*n + 3*m ) then + if( lwork >= m*n + 3_${ik}$*m ) then ! path 6to-fast ! copy realmatrix rwork(irvt,KIND=sp) to complex matrix work(ivt) ! overwrite work(ivt) by right singular vectors of a, @@ -66756,18 +66758,18 @@ module stdlib_linalg_lapack_c ! cworkspace: need 2*m [tauq, taup] + m*n [vt] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*n [vt] + m*nb [work] ! rworkspace: need m [e] + m*m [rvt] - call stdlib_clacp2( 'F', m, m, rwork( irvt ), m, work( ivt ),ldwkvt ) + call stdlib${ii}$_clacp2( 'F', m, m, rwork( irvt ), m, work( ivt ),ldwkvt ) - call stdlib_cunmbr( 'P', 'R', 'C', m, n, m, a, lda,work( itaup ), work( & + call stdlib${ii}$_cunmbr( 'P', 'R', 'C', m, n, m, a, lda,work( itaup ), work( & ivt ), ldwkvt,work( nwork ), lwork-nwork+1, ierr ) - call stdlib_clacpy( 'F', m, n, work( ivt ), ldwkvt, a, lda ) + call stdlib${ii}$_clacpy( 'F', m, n, work( ivt ), ldwkvt, a, lda ) else ! path 6to-slow ! generate p**h in a ! cworkspace: need 2*m [tauq, taup] + m*m [vt] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*m [vt] + m*nb [work] ! rworkspace: need 0 - call stdlib_cungbr( 'P', m, n, m, a, lda, work( itaup ),work( nwork ), & + call stdlib${ii}$_cungbr( 'P', m, n, m, a, lda, work( itaup ),work( nwork ), & lwork-nwork+1, ierr ) ! multiply q in a by realmatrix rwork(iru,KIND=sp), storing the ! result in work(iu), copying to a @@ -66778,9 +66780,9 @@ module stdlib_linalg_lapack_c nrwork = iru do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_clarcm( m, blk, rwork( irvt ), m, a( 1, i ),lda, work( ivt )& + call stdlib${ii}$_clarcm( m, blk, rwork( irvt ), m, a( 1_${ik}$, i ),lda, work( ivt )& , ldwkvt,rwork( nrwork ) ) - call stdlib_clacpy( 'F', m, blk, work( ivt ), ldwkvt,a( 1, i ), lda ) + call stdlib${ii}$_clacpy( 'F', m, blk, work( ivt ), ldwkvt,a( 1_${ik}$, i ), lda ) end do end if @@ -66794,24 +66796,24 @@ module stdlib_linalg_lapack_c irvt = nrwork iru = irvt + m*m nrwork = iru + m*m - call stdlib_sbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_sbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=sp) to complex matrix u ! overwrite u by left singular vectors of a ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] - call stdlib_clacp2( 'F', m, m, rwork( iru ), m, u, ldu ) - call stdlib_cunmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + call stdlib${ii}$_clacp2( 'F', m, m, rwork( iru ), m, u, ldu ) + call stdlib${ii}$_cunmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=sp) to complex matrix vt ! overwrite vt by right singular vectors of a ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need m [e] + m*m [rvt] - call stdlib_claset( 'F', m, n, czero, czero, vt, ldvt ) - call stdlib_clacp2( 'F', m, m, rwork( irvt ), m, vt, ldvt ) - call stdlib_cunmbr( 'P', 'R', 'C', m, n, m, a, lda,work( itaup ), vt, ldvt, & + call stdlib${ii}$_claset( 'F', m, n, czero, czero, vt, ldvt ) + call stdlib${ii}$_clacp2( 'F', m, m, rwork( irvt ), m, vt, ldvt ) + call stdlib${ii}$_cunmbr( 'P', 'R', 'C', m, n, m, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork-nwork+1, ierr ) else ! path 6ta (n > m, jobz='a') @@ -66823,47 +66825,47 @@ module stdlib_linalg_lapack_c irvt = nrwork iru = irvt + m*m nrwork = iru + m*m - call stdlib_sbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_sbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=sp) to complex matrix u ! overwrite u by left singular vectors of a ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] - call stdlib_clacp2( 'F', m, m, rwork( iru ), m, u, ldu ) - call stdlib_cunmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + call stdlib${ii}$_clacp2( 'F', m, m, rwork( iru ), m, u, ldu ) + call stdlib${ii}$_cunmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork-nwork+1, ierr ) ! set all of vt to identity matrix - call stdlib_claset( 'F', n, n, czero, cone, vt, ldvt ) + call stdlib${ii}$_claset( 'F', n, n, czero, cone, vt, ldvt ) ! copy realmatrix rwork(irvt,KIND=sp) to complex matrix vt ! overwrite vt by right singular vectors of a ! cworkspace: need 2*m [tauq, taup] + n [work] ! cworkspace: prefer 2*m [tauq, taup] + n*nb [work] ! rworkspace: need m [e] + m*m [rvt] - call stdlib_clacp2( 'F', m, m, rwork( irvt ), m, vt, ldvt ) - call stdlib_cunmbr( 'P', 'R', 'C', n, n, m, a, lda,work( itaup ), vt, ldvt, & + call stdlib${ii}$_clacp2( 'F', m, m, rwork( irvt ), m, vt, ldvt ) + call stdlib${ii}$_cunmbr( 'P', 'R', 'C', n, n, m, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork-nwork+1, ierr ) end if end if end if ! undo scaling if necessary - if( iscl==1 ) then - if( anrm>bignum )call stdlib_slascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,& + if( iscl==1_${ik}$ ) then + if( anrm>bignum )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn, 1_${ik}$, s, minmn,& ierr ) - if( info/=0 .and. anrm>bignum )call stdlib_slascl( 'G', 0, 0, bignum, anrm, minmn-1,& - 1,rwork( ie ), minmn, ierr ) - if( anrmbignum )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn-1,& + 1_${ik}$,rwork( ie ), minmn, ierr ) + if( anrm=n .and. minmn>0 ) then - ! space needed for stdlib_zbdsqr is bdspac = 5*n - mnthr = stdlib_ilaenv( 6, 'CGESVD', jobu // jobvt, m, n, 0, 0 ) - ! compute space needed for stdlib_cgeqrf - call stdlib_cgeqrf( m, n, a, lda, cdum(1), cdum(1), -1, ierr ) - lwork_cgeqrf = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_cungqr - call stdlib_cungqr( m, n, n, a, lda, cdum(1), cdum(1), -1, ierr ) - lwork_cungqr_n = int( cdum(1),KIND=ilp) - call stdlib_cungqr( m, m, n, a, lda, cdum(1), cdum(1), -1, ierr ) - lwork_cungqr_m = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_cgebrd - call stdlib_cgebrd( n, n, a, lda, s, dum(1), cdum(1),cdum(1), cdum(1), -1, ierr ) + ! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + if( m>=n .and. minmn>0_${ik}$ ) then + ! space needed for stdlib${ii}$_zbdsqr is bdspac = 5*n + mnthr = stdlib${ii}$_ilaenv( 6_${ik}$, 'CGESVD', jobu // jobvt, m, n, 0_${ik}$, 0_${ik}$ ) + ! compute space needed for stdlib${ii}$_cgeqrf + call stdlib${ii}$_cgeqrf( m, n, a, lda, cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_cgeqrf = int( cdum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_cungqr + call stdlib${ii}$_cungqr( m, n, n, a, lda, cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_cungqr_n = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cungqr( m, m, n, a, lda, cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_cungqr_m = int( cdum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_cgebrd + call stdlib${ii}$_cgebrd( n, n, a, lda, s, dum(1_${ik}$), cdum(1_${ik}$),cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) - lwork_cgebrd = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_cungbr - call stdlib_cungbr( 'P', n, n, n, a, lda, cdum(1),cdum(1), -1, ierr ) - lwork_cungbr_p = int( cdum(1),KIND=ilp) - call stdlib_cungbr( 'Q', n, n, n, a, lda, cdum(1),cdum(1), -1, ierr ) - lwork_cungbr_q = int( cdum(1),KIND=ilp) - mnthr = stdlib_ilaenv( 6, 'CGESVD', jobu // jobvt, m, n, 0, 0 ) + lwork_cgebrd = int( cdum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_cungbr + call stdlib${ii}$_cungbr( 'P', n, n, n, a, lda, cdum(1_${ik}$),cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_cungbr_p = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cungbr( 'Q', n, n, n, a, lda, cdum(1_${ik}$),cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_cungbr_q = int( cdum(1_${ik}$),KIND=${ik}$) + mnthr = stdlib${ii}$_ilaenv( 6_${ik}$, 'CGESVD', jobu // jobvt, m, n, 0_${ik}$, 0_${ik}$ ) if( m>=mnthr ) then if( wntun ) then ! path 1 (m much larger than n, jobu='n') maxwrk = n + lwork_cgeqrf - maxwrk = max( maxwrk, 2*n+lwork_cgebrd ) - if( wntvo .or. wntvas )maxwrk = max( maxwrk, 2*n+lwork_cungbr_p ) - minwrk = 3*n + maxwrk = max( maxwrk, 2_${ik}$*n+lwork_cgebrd ) + if( wntvo .or. wntvas )maxwrk = max( maxwrk, 2_${ik}$*n+lwork_cungbr_p ) + minwrk = 3_${ik}$*n else if( wntuo .and. wntvn ) then ! path 2 (m much larger than n, jobu='o', jobvt='n') wrkbl = n + lwork_cgeqrf wrkbl = max( wrkbl, n+lwork_cungqr_n ) - wrkbl = max( wrkbl, 2*n+lwork_cgebrd ) - wrkbl = max( wrkbl, 2*n+lwork_cungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_cgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_cungbr_q ) maxwrk = max( n*n+wrkbl, n*n+m*n ) - minwrk = 2*n + m + minwrk = 2_${ik}$*n + m else if( wntuo .and. wntvas ) then ! path 3 (m much larger than n, jobu='o', jobvt='s' or ! 'a') wrkbl = n + lwork_cgeqrf wrkbl = max( wrkbl, n+lwork_cungqr_n ) - wrkbl = max( wrkbl, 2*n+lwork_cgebrd ) - wrkbl = max( wrkbl, 2*n+lwork_cungbr_q ) - wrkbl = max( wrkbl, 2*n+lwork_cungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_cgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_cungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_cungbr_p ) maxwrk = max( n*n+wrkbl, n*n+m*n ) - minwrk = 2*n + m + minwrk = 2_${ik}$*n + m else if( wntus .and. wntvn ) then ! path 4 (m much larger than n, jobu='s', jobvt='n') wrkbl = n + lwork_cgeqrf wrkbl = max( wrkbl, n+lwork_cungqr_n ) - wrkbl = max( wrkbl, 2*n+lwork_cgebrd ) - wrkbl = max( wrkbl, 2*n+lwork_cungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_cgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_cungbr_q ) maxwrk = n*n + wrkbl - minwrk = 2*n + m + minwrk = 2_${ik}$*n + m else if( wntus .and. wntvo ) then ! path 5 (m much larger than n, jobu='s', jobvt='o') wrkbl = n + lwork_cgeqrf wrkbl = max( wrkbl, n+lwork_cungqr_n ) - wrkbl = max( wrkbl, 2*n+lwork_cgebrd ) - wrkbl = max( wrkbl, 2*n+lwork_cungbr_q ) - wrkbl = max( wrkbl, 2*n+lwork_cungbr_p ) - maxwrk = 2*n*n + wrkbl - minwrk = 2*n + m + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_cgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_cungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_cungbr_p ) + maxwrk = 2_${ik}$*n*n + wrkbl + minwrk = 2_${ik}$*n + m else if( wntus .and. wntvas ) then ! path 6 (m much larger than n, jobu='s', jobvt='s' or ! 'a') wrkbl = n + lwork_cgeqrf wrkbl = max( wrkbl, n+lwork_cungqr_n ) - wrkbl = max( wrkbl, 2*n+lwork_cgebrd ) - wrkbl = max( wrkbl, 2*n+lwork_cungbr_q ) - wrkbl = max( wrkbl, 2*n+lwork_cungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_cgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_cungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_cungbr_p ) maxwrk = n*n + wrkbl - minwrk = 2*n + m + minwrk = 2_${ik}$*n + m else if( wntua .and. wntvn ) then ! path 7 (m much larger than n, jobu='a', jobvt='n') wrkbl = n + lwork_cgeqrf wrkbl = max( wrkbl, n+lwork_cungqr_m ) - wrkbl = max( wrkbl, 2*n+lwork_cgebrd ) - wrkbl = max( wrkbl, 2*n+lwork_cungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_cgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_cungbr_q ) maxwrk = n*n + wrkbl - minwrk = 2*n + m + minwrk = 2_${ik}$*n + m else if( wntua .and. wntvo ) then ! path 8 (m much larger than n, jobu='a', jobvt='o') wrkbl = n + lwork_cgeqrf wrkbl = max( wrkbl, n+lwork_cungqr_m ) - wrkbl = max( wrkbl, 2*n+lwork_cgebrd ) - wrkbl = max( wrkbl, 2*n+lwork_cungbr_q ) - wrkbl = max( wrkbl, 2*n+lwork_cungbr_p ) - maxwrk = 2*n*n + wrkbl - minwrk = 2*n + m + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_cgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_cungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_cungbr_p ) + maxwrk = 2_${ik}$*n*n + wrkbl + minwrk = 2_${ik}$*n + m else if( wntua .and. wntvas ) then ! path 9 (m much larger than n, jobu='a', jobvt='s' or ! 'a') wrkbl = n + lwork_cgeqrf wrkbl = max( wrkbl, n+lwork_cungqr_m ) - wrkbl = max( wrkbl, 2*n+lwork_cgebrd ) - wrkbl = max( wrkbl, 2*n+lwork_cungbr_q ) - wrkbl = max( wrkbl, 2*n+lwork_cungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_cgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_cungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_cungbr_p ) maxwrk = n*n + wrkbl - minwrk = 2*n + m + minwrk = 2_${ik}$*n + m end if else ! path 10 (m at least n, but not much larger) - call stdlib_cgebrd( m, n, a, lda, s, dum(1), cdum(1),cdum(1), cdum(1), -1, & + call stdlib${ii}$_cgebrd( m, n, a, lda, s, dum(1_${ik}$), cdum(1_${ik}$),cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, & ierr ) - lwork_cgebrd = int( cdum(1),KIND=ilp) - maxwrk = 2*n + lwork_cgebrd + lwork_cgebrd = int( cdum(1_${ik}$),KIND=${ik}$) + maxwrk = 2_${ik}$*n + lwork_cgebrd if( wntus .or. wntuo ) then - call stdlib_cungbr( 'Q', m, n, n, a, lda, cdum(1),cdum(1), -1, ierr ) + call stdlib${ii}$_cungbr( 'Q', m, n, n, a, lda, cdum(1_${ik}$),cdum(1_${ik}$), -1_${ik}$, ierr ) - lwork_cungbr_q = int( cdum(1),KIND=ilp) - maxwrk = max( maxwrk, 2*n+lwork_cungbr_q ) + lwork_cungbr_q = int( cdum(1_${ik}$),KIND=${ik}$) + maxwrk = max( maxwrk, 2_${ik}$*n+lwork_cungbr_q ) end if if( wntua ) then - call stdlib_cungbr( 'Q', m, m, n, a, lda, cdum(1),cdum(1), -1, ierr ) + call stdlib${ii}$_cungbr( 'Q', m, m, n, a, lda, cdum(1_${ik}$),cdum(1_${ik}$), -1_${ik}$, ierr ) - lwork_cungbr_q = int( cdum(1),KIND=ilp) - maxwrk = max( maxwrk, 2*n+lwork_cungbr_q ) + lwork_cungbr_q = int( cdum(1_${ik}$),KIND=${ik}$) + maxwrk = max( maxwrk, 2_${ik}$*n+lwork_cungbr_q ) end if if( .not.wntvn ) then - maxwrk = max( maxwrk, 2*n+lwork_cungbr_p ) - end if - minwrk = 2*n + m - end if - else if( minmn>0 ) then - ! space needed for stdlib_cbdsqr is bdspac = 5*m - mnthr = stdlib_ilaenv( 6, 'CGESVD', jobu // jobvt, m, n, 0, 0 ) - ! compute space needed for stdlib_cgelqf - call stdlib_cgelqf( m, n, a, lda, cdum(1), cdum(1), -1, ierr ) - lwork_cgelqf = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_cunglq - call stdlib_cunglq( n, n, m, cdum(1), n, cdum(1), cdum(1), -1,ierr ) - lwork_cunglq_n = int( cdum(1),KIND=ilp) - call stdlib_cunglq( m, n, m, a, lda, cdum(1), cdum(1), -1, ierr ) - lwork_cunglq_m = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_cgebrd - call stdlib_cgebrd( m, m, a, lda, s, dum(1), cdum(1),cdum(1), cdum(1), -1, ierr ) + maxwrk = max( maxwrk, 2_${ik}$*n+lwork_cungbr_p ) + end if + minwrk = 2_${ik}$*n + m + end if + else if( minmn>0_${ik}$ ) then + ! space needed for stdlib${ii}$_cbdsqr is bdspac = 5*m + mnthr = stdlib${ii}$_ilaenv( 6_${ik}$, 'CGESVD', jobu // jobvt, m, n, 0_${ik}$, 0_${ik}$ ) + ! compute space needed for stdlib${ii}$_cgelqf + call stdlib${ii}$_cgelqf( m, n, a, lda, cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_cgelqf = int( cdum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_cunglq + call stdlib${ii}$_cunglq( n, n, m, cdum(1_${ik}$), n, cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$,ierr ) + lwork_cunglq_n = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_cunglq( m, n, m, a, lda, cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_cunglq_m = int( cdum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_cgebrd + call stdlib${ii}$_cgebrd( m, m, a, lda, s, dum(1_${ik}$), cdum(1_${ik}$),cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) - lwork_cgebrd = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_cungbr p - call stdlib_cungbr( 'P', m, m, m, a, n, cdum(1),cdum(1), -1, ierr ) - lwork_cungbr_p = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_cungbr q - call stdlib_cungbr( 'Q', m, m, m, a, n, cdum(1),cdum(1), -1, ierr ) - lwork_cungbr_q = int( cdum(1),KIND=ilp) + lwork_cgebrd = int( cdum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_cungbr p + call stdlib${ii}$_cungbr( 'P', m, m, m, a, n, cdum(1_${ik}$),cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_cungbr_p = int( cdum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_cungbr q + call stdlib${ii}$_cungbr( 'Q', m, m, m, a, n, cdum(1_${ik}$),cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_cungbr_q = int( cdum(1_${ik}$),KIND=${ik}$) if( n>=mnthr ) then if( wntvn ) then ! path 1t(n much larger than m, jobvt='n') maxwrk = m + lwork_cgelqf - maxwrk = max( maxwrk, 2*m+lwork_cgebrd ) - if( wntuo .or. wntuas )maxwrk = max( maxwrk, 2*m+lwork_cungbr_q ) - minwrk = 3*m + maxwrk = max( maxwrk, 2_${ik}$*m+lwork_cgebrd ) + if( wntuo .or. wntuas )maxwrk = max( maxwrk, 2_${ik}$*m+lwork_cungbr_q ) + minwrk = 3_${ik}$*m else if( wntvo .and. wntun ) then ! path 2t(n much larger than m, jobu='n', jobvt='o') wrkbl = m + lwork_cgelqf wrkbl = max( wrkbl, m+lwork_cunglq_m ) - wrkbl = max( wrkbl, 2*m+lwork_cgebrd ) - wrkbl = max( wrkbl, 2*m+lwork_cungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_cgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_cungbr_p ) maxwrk = max( m*m+wrkbl, m*m+m*n ) - minwrk = 2*m + n + minwrk = 2_${ik}$*m + n else if( wntvo .and. wntuas ) then ! path 3t(n much larger than m, jobu='s' or 'a', ! jobvt='o') wrkbl = m + lwork_cgelqf wrkbl = max( wrkbl, m+lwork_cunglq_m ) - wrkbl = max( wrkbl, 2*m+lwork_cgebrd ) - wrkbl = max( wrkbl, 2*m+lwork_cungbr_p ) - wrkbl = max( wrkbl, 2*m+lwork_cungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_cgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_cungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_cungbr_q ) maxwrk = max( m*m+wrkbl, m*m+m*n ) - minwrk = 2*m + n + minwrk = 2_${ik}$*m + n else if( wntvs .and. wntun ) then ! path 4t(n much larger than m, jobu='n', jobvt='s') wrkbl = m + lwork_cgelqf wrkbl = max( wrkbl, m+lwork_cunglq_m ) - wrkbl = max( wrkbl, 2*m+lwork_cgebrd ) - wrkbl = max( wrkbl, 2*m+lwork_cungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_cgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_cungbr_p ) maxwrk = m*m + wrkbl - minwrk = 2*m + n + minwrk = 2_${ik}$*m + n else if( wntvs .and. wntuo ) then ! path 5t(n much larger than m, jobu='o', jobvt='s') wrkbl = m + lwork_cgelqf wrkbl = max( wrkbl, m+lwork_cunglq_m ) - wrkbl = max( wrkbl, 2*m+lwork_cgebrd ) - wrkbl = max( wrkbl, 2*m+lwork_cungbr_p ) - wrkbl = max( wrkbl, 2*m+lwork_cungbr_q ) - maxwrk = 2*m*m + wrkbl - minwrk = 2*m + n + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_cgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_cungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_cungbr_q ) + maxwrk = 2_${ik}$*m*m + wrkbl + minwrk = 2_${ik}$*m + n else if( wntvs .and. wntuas ) then ! path 6t(n much larger than m, jobu='s' or 'a', ! jobvt='s') wrkbl = m + lwork_cgelqf wrkbl = max( wrkbl, m+lwork_cunglq_m ) - wrkbl = max( wrkbl, 2*m+lwork_cgebrd ) - wrkbl = max( wrkbl, 2*m+lwork_cungbr_p ) - wrkbl = max( wrkbl, 2*m+lwork_cungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_cgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_cungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_cungbr_q ) maxwrk = m*m + wrkbl - minwrk = 2*m + n + minwrk = 2_${ik}$*m + n else if( wntva .and. wntun ) then ! path 7t(n much larger than m, jobu='n', jobvt='a') wrkbl = m + lwork_cgelqf wrkbl = max( wrkbl, m+lwork_cunglq_n ) - wrkbl = max( wrkbl, 2*m+lwork_cgebrd ) - wrkbl = max( wrkbl, 2*m+lwork_cungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_cgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_cungbr_p ) maxwrk = m*m + wrkbl - minwrk = 2*m + n + minwrk = 2_${ik}$*m + n else if( wntva .and. wntuo ) then ! path 8t(n much larger than m, jobu='o', jobvt='a') wrkbl = m + lwork_cgelqf wrkbl = max( wrkbl, m+lwork_cunglq_n ) - wrkbl = max( wrkbl, 2*m+lwork_cgebrd ) - wrkbl = max( wrkbl, 2*m+lwork_cungbr_p ) - wrkbl = max( wrkbl, 2*m+lwork_cungbr_q ) - maxwrk = 2*m*m + wrkbl - minwrk = 2*m + n + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_cgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_cungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_cungbr_q ) + maxwrk = 2_${ik}$*m*m + wrkbl + minwrk = 2_${ik}$*m + n else if( wntva .and. wntuas ) then ! path 9t(n much larger than m, jobu='s' or 'a', ! jobvt='a') wrkbl = m + lwork_cgelqf wrkbl = max( wrkbl, m+lwork_cunglq_n ) - wrkbl = max( wrkbl, 2*m+lwork_cgebrd ) - wrkbl = max( wrkbl, 2*m+lwork_cungbr_p ) - wrkbl = max( wrkbl, 2*m+lwork_cungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_cgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_cungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_cungbr_q ) maxwrk = m*m + wrkbl - minwrk = 2*m + n + minwrk = 2_${ik}$*m + n end if else ! path 10t(n greater than m, but not much larger) - call stdlib_cgebrd( m, n, a, lda, s, dum(1), cdum(1),cdum(1), cdum(1), -1, & + call stdlib${ii}$_cgebrd( m, n, a, lda, s, dum(1_${ik}$), cdum(1_${ik}$),cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, & ierr ) - lwork_cgebrd = int( cdum(1),KIND=ilp) - maxwrk = 2*m + lwork_cgebrd + lwork_cgebrd = int( cdum(1_${ik}$),KIND=${ik}$) + maxwrk = 2_${ik}$*m + lwork_cgebrd if( wntvs .or. wntvo ) then - ! compute space needed for stdlib_cungbr p - call stdlib_cungbr( 'P', m, n, m, a, n, cdum(1),cdum(1), -1, ierr ) - lwork_cungbr_p = int( cdum(1),KIND=ilp) - maxwrk = max( maxwrk, 2*m+lwork_cungbr_p ) + ! compute space needed for stdlib${ii}$_cungbr p + call stdlib${ii}$_cungbr( 'P', m, n, m, a, n, cdum(1_${ik}$),cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_cungbr_p = int( cdum(1_${ik}$),KIND=${ik}$) + maxwrk = max( maxwrk, 2_${ik}$*m+lwork_cungbr_p ) end if if( wntva ) then - call stdlib_cungbr( 'P', n, n, m, a, n, cdum(1),cdum(1), -1, ierr ) - lwork_cungbr_p = int( cdum(1),KIND=ilp) - maxwrk = max( maxwrk, 2*m+lwork_cungbr_p ) + call stdlib${ii}$_cungbr( 'P', n, n, m, a, n, cdum(1_${ik}$),cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_cungbr_p = int( cdum(1_${ik}$),KIND=${ik}$) + maxwrk = max( maxwrk, 2_${ik}$*m+lwork_cungbr_p ) end if if( .not.wntun ) then - maxwrk = max( maxwrk, 2*m+lwork_cungbr_q ) + maxwrk = max( maxwrk, 2_${ik}$*m+lwork_cungbr_q ) end if - minwrk = 2*m + n + minwrk = 2_${ik}$*m + n end if end if maxwrk = max( minwrk, maxwrk ) - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk if( lworkzero .and. anrmbignum ) then - iscl = 1 - call stdlib_clascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, ierr ) + iscl = 1_${ik}$ + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, ierr ) end if if( m>=n ) then ! a has at least as many rows as columns. if a has sufficiently @@ -67280,32 +67282,32 @@ module stdlib_linalg_lapack_c if( wntun ) then ! path 1 (m much larger than n, jobu='n') ! no left singular vectors to be computed - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: need 0) - call stdlib_cgeqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & + call stdlib${ii}$_cgeqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & ierr ) ! zero out below r - if( n > 1 ) then - call stdlib_claset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_claset( 'L', n-1, n-1, czero, czero, a( 2_${ik}$, 1_${ik}$ ),lda ) end if - ie = 1 - itauq = 1 + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + n iwork = itaup + n ! bidiagonalize r in a ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_cgebrd( n, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& + call stdlib${ii}$_cgebrd( n, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& work( iwork ), lwork-iwork+1,ierr ) - ncvt = 0 + ncvt = 0_${ik}$ if( wntvo .or. wntvas ) then ! if right singular vectors desired, generate p'. ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & + call stdlib${ii}$_cungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) ncvt = n end if @@ -67314,17 +67316,17 @@ module stdlib_linalg_lapack_c ! singular vectors of a in a if desired ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', n, ncvt, 0, 0, s, rwork( ie ), a, lda,cdum, 1, cdum, & - 1, rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'U', n, ncvt, 0_${ik}$, 0_${ik}$, s, rwork( ie ), a, lda,cdum, 1_${ik}$, cdum, & + 1_${ik}$, rwork( irwork ), info ) ! if right singular vectors desired in vt, copy them there - if( wntvas )call stdlib_clacpy( 'F', n, n, a, lda, vt, ldvt ) + if( wntvas )call stdlib${ii}$_clacpy( 'F', n, n, a, lda, vt, ldvt ) else if( wntuo .and. wntvn ) then ! path 2 (m much larger than n, jobu='o', jobvt='n') ! n left singular vectors to be overwritten on a and ! no right singular vectors to be computed if( lwork>=n*n+3*n ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=max( wrkbl, lda*n )+lda*n ) then ! work(iu) is lda by n, work(ir) is lda by n ldwrku = lda @@ -67343,38 +67345,38 @@ module stdlib_linalg_lapack_c ! compute a=q*r ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy r to work(ir) and zero out below it - call stdlib_clacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) - call stdlib_claset( 'L', n-1, n-1, czero, czero,work( ir+1 ), ldwrkr ) + call stdlib${ii}$_clacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) + call stdlib${ii}$_claset( 'L', n-1, n-1, czero, czero,work( ir+1 ), ldwrkr ) ! generate q in a ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_cungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_cgebrd( n, n, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ),& + call stdlib${ii}$_cgebrd( n, n, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ),& work( itaup ),work( iwork ), lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing r ! (cworkspace: need n*n+3*n, prefer n*n+2*n+n*nb) ! (rworkspace: need 0) - call stdlib_cungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & + call stdlib${ii}$_cungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) ! (cworkspace: need n*n) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', n, 0, n, 0, s, rwork( ie ), cdum, 1,work( ir ), & - ldwrkr, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'U', n, 0_${ik}$, n, 0_${ik}$, s, rwork( ie ), cdum, 1_${ik}$,work( ir ), & + ldwrkr, cdum, 1_${ik}$,rwork( irwork ), info ) iu = itauq ! multiply q in a by left singular vectors of r in ! work(ir), storing result in work(iu) and copying to a @@ -67382,34 +67384,34 @@ module stdlib_linalg_lapack_c ! (rworkspace: 0) do i = 1, m, ldwrku chunk = min( m-i+1, ldwrku ) - call stdlib_cgemm( 'N', 'N', chunk, n, n, cone, a( i, 1 ),lda, work( ir & + call stdlib${ii}$_cgemm( 'N', 'N', chunk, n, n, cone, a( i, 1_${ik}$ ),lda, work( ir & ), ldwrkr, czero,work( iu ), ldwrku ) - call stdlib_clacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) + call stdlib${ii}$_clacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1_${ik}$ ), lda ) end do else ! insufficient workspace for a fast algorithm - ie = 1 - itauq = 1 + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + n iwork = itaup + n ! bidiagonalize a ! (cworkspace: need 2*n+m, prefer 2*n+(m+n)*nb) ! (rworkspace: n) - call stdlib_cgebrd( m, n, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_cgebrd( m, n, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing a ! (cworkspace: need 3*n, prefer 2*n+n*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), & + call stdlib${ii}$_cungbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in a ! (cworkspace: need 0) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', n, 0, m, 0, s, rwork( ie ), cdum, 1,a, lda, cdum, & - 1, rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'U', n, 0_${ik}$, m, 0_${ik}$, s, rwork( ie ), cdum, 1_${ik}$,a, lda, cdum, & + 1_${ik}$, rwork( irwork ), info ) end if else if( wntuo .and. wntvas ) then ! path 3 (m much larger than n, jobu='o', jobvt='s' or 'a') @@ -67417,7 +67419,7 @@ module stdlib_linalg_lapack_c ! n right singular vectors to be computed in vt if( lwork>=n*n+3*n ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=max( wrkbl, lda*n )+lda*n ) then ! work(iu) is lda by n and work(ir) is lda by n ldwrku = lda @@ -67436,36 +67438,36 @@ module stdlib_linalg_lapack_c ! compute a=q*r ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy r to vt, zeroing out below it - call stdlib_clacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_claset( 'L', n-1, n-1, czero, czero,vt( 2, 1 ), ldvt ) + call stdlib${ii}$_clacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1_${ik}$ )call stdlib${ii}$_claset( 'L', n-1, n-1, czero, czero,vt( 2_${ik}$, 1_${ik}$ ), ldvt ) ! generate q in a ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_cungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in vt, copying result to work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_cgebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_cgebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) - call stdlib_clacpy( 'L', n, n, vt, ldvt, work( ir ), ldwrkr ) + call stdlib${ii}$_clacpy( 'L', n, n, vt, ldvt, work( ir ), ldwrkr ) ! generate left vectors bidiagonalizing r in work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & + call stdlib${ii}$_cungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing r in vt ! (cworkspace: need n*n+3*n-1, prefer n*n+2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib${ii}$_cungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -67473,8 +67475,8 @@ module stdlib_linalg_lapack_c ! singular vectors of r in vt ! (cworkspace: need n*n) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', n, n, n, 0, s, rwork( ie ), vt,ldvt, work( ir ), & - ldwrkr, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'U', n, n, n, 0_${ik}$, s, rwork( ie ), vt,ldvt, work( ir ), & + ldwrkr, cdum, 1_${ik}$,rwork( irwork ), info ) iu = itauq ! multiply q in a by left singular vectors of r in ! work(ir), storing result in work(iu) and copying to a @@ -67482,47 +67484,47 @@ module stdlib_linalg_lapack_c ! (rworkspace: 0) do i = 1, m, ldwrku chunk = min( m-i+1, ldwrku ) - call stdlib_cgemm( 'N', 'N', chunk, n, n, cone, a( i, 1 ),lda, work( ir & + call stdlib${ii}$_cgemm( 'N', 'N', chunk, n, n, cone, a( i, 1_${ik}$ ),lda, work( ir & ), ldwrkr, czero,work( iu ), ldwrku ) - call stdlib_clacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) + call stdlib${ii}$_clacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1_${ik}$ ), lda ) end do else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy r to vt, zeroing out below it - call stdlib_clacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_claset( 'L', n-1, n-1, czero, czero,vt( 2, 1 ), ldvt ) + call stdlib${ii}$_clacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1_${ik}$ )call stdlib${ii}$_claset( 'L', n-1, n-1, czero, czero,vt( 2_${ik}$, 1_${ik}$ ), ldvt ) ! generate q in a ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_cungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in vt ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: n) - call stdlib_cgebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_cgebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in a by left vectors bidiagonalizing r ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_cunmbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), a, lda,& + call stdlib${ii}$_cunmbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), a, lda,& work( iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing r in vt ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib${ii}$_cungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -67530,8 +67532,8 @@ module stdlib_linalg_lapack_c ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', n, n, m, 0, s, rwork( ie ), vt,ldvt, a, lda, cdum,& - 1, rwork( irwork ),info ) + call stdlib${ii}$_cbdsqr( 'U', n, n, m, 0_${ik}$, s, rwork( ie ), vt,ldvt, a, lda, cdum,& + 1_${ik}$, rwork( irwork ),info ) end if else if( wntus ) then if( wntvn ) then @@ -67540,7 +67542,7 @@ module stdlib_linalg_lapack_c ! no right singular vectors to be computed if( lwork>=n*n+3*n ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=wrkbl+lda*n ) then ! work(ir) is lda by n ldwrkr = lda @@ -67553,93 +67555,93 @@ module stdlib_linalg_lapack_c ! compute a=q*r ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(ir), zeroing out below it - call stdlib_clacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) - call stdlib_claset( 'L', n-1, n-1, czero, czero,work( ir+1 ), ldwrkr ) + call stdlib${ii}$_clacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) + call stdlib${ii}$_claset( 'L', n-1, n-1, czero, czero,work( ir+1 ), ldwrkr ) ! generate q in a ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_cungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_cgebrd( n, n, work( ir ), ldwrkr, s,rwork( ie ), work( & + call stdlib${ii}$_cgebrd( n, n, work( ir ), ldwrkr, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing r in work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_cungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) ! (cworkspace: need n*n) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', n, 0, n, 0, s, rwork( ie ), cdum,1, work( ir ),& - ldwrkr, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'U', n, 0_${ik}$, n, 0_${ik}$, s, rwork( ie ), cdum,1_${ik}$, work( ir ),& + ldwrkr, cdum, 1_${ik}$,rwork( irwork ), info ) ! multiply q in a by left singular vectors of r in ! work(ir), storing result in u ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_cgemm( 'N', 'N', m, n, n, cone, a, lda,work( ir ), ldwrkr, & + call stdlib${ii}$_cgemm( 'N', 'N', m, n, n, cone, a, lda,work( ir ), ldwrkr, & czero, u, ldu ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_clacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_clacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_cungqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cungqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! zero out below r in a - if( n > 1 ) then - call stdlib_claset( 'L', n-1, n-1, czero, czero,a( 2, 1 ), lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_claset( 'L', n-1, n-1, czero, czero,a( 2_${ik}$, 1_${ik}$ ), lda ) end if ! bidiagonalize r in a ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_cgebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_cgebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left vectors bidiagonalizing r ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_cunmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib${ii}$_cunmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', n, 0, m, 0, s, rwork( ie ), cdum,1, u, ldu, & - cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_cbdsqr( 'U', n, 0_${ik}$, m, 0_${ik}$, s, rwork( ie ), cdum,1_${ik}$, u, ldu, & + cdum, 1_${ik}$, rwork( irwork ),info ) end if else if( wntvo ) then ! path 5 (m much larger than n, jobu='s', jobvt='o') ! n left singular vectors to be computed in u and ! n right singular vectors to be overwritten on a - if( lwork>=2*n*n+3*n ) then + if( lwork>=2_${ik}$*n*n+3*n ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+2*lda*n ) then ! work(iu) is lda by n and work(ir) is lda by n ldwrku = lda @@ -67661,18 +67663,18 @@ module stdlib_linalg_lapack_c ! compute a=q*r ! (cworkspace: need 2*n*n+2*n, prefer 2*n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_clacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_claset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) + call stdlib${ii}$_clacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_claset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) ! generate q in a ! (cworkspace: need 2*n*n+2*n, prefer 2*n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_cungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n @@ -67681,20 +67683,20 @@ module stdlib_linalg_lapack_c ! (cworkspace: need 2*n*n+3*n, ! prefer 2*n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_cgebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib${ii}$_cgebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_clacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib${ii}$_clacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate left bidiagonalizing vectors in work(iu) ! (cworkspace: need 2*n*n+3*n, prefer 2*n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib${ii}$_cungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in work(ir) ! (cworkspace: need 2*n*n+3*n-1, ! prefer 2*n*n+2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_cungbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -67702,56 +67704,56 @@ module stdlib_linalg_lapack_c ! right singular vectors of r in work(ir) ! (cworkspace: need 2*n*n) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', n, n, n, 0, s, rwork( ie ),work( ir ), ldwrkr, & - work( iu ),ldwrku, cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_cbdsqr( 'U', n, n, n, 0_${ik}$, s, rwork( ie ),work( ir ), ldwrkr, & + work( iu ),ldwrku, cdum, 1_${ik}$, rwork( irwork ),info ) ! multiply q in a by left singular vectors of r in ! work(iu), storing result in u ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_cgemm( 'N', 'N', m, n, n, cone, a, lda,work( iu ), ldwrku, & + call stdlib${ii}$_cgemm( 'N', 'N', m, n, n, cone, a, lda,work( iu ), ldwrku, & czero, u, ldu ) ! copy right singular vectors of r to a ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_clacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) + call stdlib${ii}$_clacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_clacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_clacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_cungqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cungqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! zero out below r in a - if( n > 1 ) then - call stdlib_claset( 'L', n-1, n-1, czero, czero,a( 2, 1 ), lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_claset( 'L', n-1, n-1, czero, czero,a( 2_${ik}$, 1_${ik}$ ), lda ) end if ! bidiagonalize r in a ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_cgebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_cgebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left vectors bidiagonalizing r ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_cunmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib${ii}$_cunmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing r in a ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & + call stdlib${ii}$_cungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -67759,8 +67761,8 @@ module stdlib_linalg_lapack_c ! singular vectors of a in a ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', n, n, m, 0, s, rwork( ie ), a,lda, u, ldu, & - cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_cbdsqr( 'U', n, n, m, 0_${ik}$, s, rwork( ie ), a,lda, u, ldu, & + cdum, 1_${ik}$, rwork( irwork ),info ) end if else if( wntvas ) then ! path 6 (m much larger than n, jobu='s', jobvt='s' @@ -67769,7 +67771,7 @@ module stdlib_linalg_lapack_c ! n right singular vectors to be computed in vt if( lwork>=n*n+3*n ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+lda*n ) then ! work(iu) is lda by n ldwrku = lda @@ -67782,37 +67784,37 @@ module stdlib_linalg_lapack_c ! compute a=q*r ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_clacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_claset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) + call stdlib${ii}$_clacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_claset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) ! generate q in a ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_cungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in work(iu), copying result to vt ! (cworkspace: need n*n+3*n, prefer n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_cgebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib${ii}$_cgebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_clacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) + call stdlib${ii}$_clacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) ! generate left bidiagonalizing vectors in work(iu) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib${ii}$_cungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (cworkspace: need n*n+3*n-1, ! prefer n*n+2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib${ii}$_cungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -67820,52 +67822,52 @@ module stdlib_linalg_lapack_c ! right singular vectors of r in vt ! (cworkspace: need n*n) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', n, n, n, 0, s, rwork( ie ), vt,ldvt, work( iu )& - , ldwrku, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'U', n, n, n, 0_${ik}$, s, rwork( ie ), vt,ldvt, work( iu )& + , ldwrku, cdum, 1_${ik}$,rwork( irwork ), info ) ! multiply q in a by left singular vectors of r in ! work(iu), storing result in u ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_cgemm( 'N', 'N', m, n, n, cone, a, lda,work( iu ), ldwrku, & + call stdlib${ii}$_cgemm( 'N', 'N', m, n, n, cone, a, lda,work( iu ), ldwrku, & czero, u, ldu ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_clacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_clacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_cungqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cungqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to vt, zeroing out below it - call stdlib_clacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_claset( 'L', n-1, n-1, czero, czero,vt( 2, 1 ), & + call stdlib${ii}$_clacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1_${ik}$ )call stdlib${ii}$_claset( 'L', n-1, n-1, czero, czero,vt( 2_${ik}$, 1_${ik}$ ), & ldvt ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in vt ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_cgebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_cgebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in vt ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_cunmbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & + call stdlib${ii}$_cunmbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib${ii}$_cungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -67873,8 +67875,8 @@ module stdlib_linalg_lapack_c ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', n, n, m, 0, s, rwork( ie ), vt,ldvt, u, ldu, & - cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'U', n, n, m, 0_${ik}$, s, rwork( ie ), vt,ldvt, u, ldu, & + cdum, 1_${ik}$,rwork( irwork ), info ) end if end if else if( wntua ) then @@ -67882,9 +67884,9 @@ module stdlib_linalg_lapack_c ! path 7 (m much larger than n, jobu='a', jobvt='n') ! m left singular vectors to be computed in u and ! no right singular vectors to be computed - if( lwork>=n*n+max( n+m, 3*n ) ) then + if( lwork>=n*n+max( n+m, 3_${ik}$*n ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=wrkbl+lda*n ) then ! work(ir) is lda by n ldwrkr = lda @@ -67897,97 +67899,97 @@ module stdlib_linalg_lapack_c ! compute a=q*r, copying result to u ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_clacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_clacpy( 'L', m, n, a, lda, u, ldu ) ! copy r to work(ir), zeroing out below it - call stdlib_clacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) - call stdlib_claset( 'L', n-1, n-1, czero, czero,work( ir+1 ), ldwrkr ) + call stdlib${ii}$_clacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) + call stdlib${ii}$_claset( 'L', n-1, n-1, czero, czero,work( ir+1 ), ldwrkr ) ! generate q in u ! (cworkspace: need n*n+n+m, prefer n*n+n+m*nb) ! (rworkspace: 0) - call stdlib_cungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_cgebrd( n, n, work( ir ), ldwrkr, s,rwork( ie ), work( & + call stdlib${ii}$_cgebrd( n, n, work( ir ), ldwrkr, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_cungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) ! (cworkspace: need n*n) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', n, 0, n, 0, s, rwork( ie ), cdum,1, work( ir ),& - ldwrkr, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'U', n, 0_${ik}$, n, 0_${ik}$, s, rwork( ie ), cdum,1_${ik}$, work( ir ),& + ldwrkr, cdum, 1_${ik}$,rwork( irwork ), info ) ! multiply q in u by left singular vectors of r in ! work(ir), storing result in a ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_cgemm( 'N', 'N', m, n, n, cone, u, ldu,work( ir ), ldwrkr, & + call stdlib${ii}$_cgemm( 'N', 'N', m, n, n, cone, u, ldu,work( ir ), ldwrkr, & czero, a, lda ) ! copy left singular vectors of a from a to u - call stdlib_clacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_clacpy( 'F', m, n, a, lda, u, ldu ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_clacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_clacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need n+m, prefer n+m*nb) ! (rworkspace: 0) - call stdlib_cungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! zero out below r in a - if( n > 1 ) then - call stdlib_claset( 'L', n-1, n-1, czero, czero,a( 2, 1 ), lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_claset( 'L', n-1, n-1, czero, czero,a( 2_${ik}$, 1_${ik}$ ), lda ) end if ! bidiagonalize r in a ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_cgebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_cgebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in a ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_cunmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib${ii}$_cunmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', n, 0, m, 0, s, rwork( ie ), cdum,1, u, ldu, & - cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_cbdsqr( 'U', n, 0_${ik}$, m, 0_${ik}$, s, rwork( ie ), cdum,1_${ik}$, u, ldu, & + cdum, 1_${ik}$, rwork( irwork ),info ) end if else if( wntvo ) then ! path 8 (m much larger than n, jobu='a', jobvt='o') ! m left singular vectors to be computed in u and ! n right singular vectors to be overwritten on a - if( lwork>=2*n*n+max( n+m, 3*n ) ) then + if( lwork>=2_${ik}$*n*n+max( n+m, 3_${ik}$*n ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+2*lda*n ) then ! work(iu) is lda by n and work(ir) is lda by n ldwrku = lda @@ -68009,19 +68011,19 @@ module stdlib_linalg_lapack_c ! compute a=q*r, copying result to u ! (cworkspace: need 2*n*n+2*n, prefer 2*n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_clacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_clacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need 2*n*n+n+m, prefer 2*n*n+n+m*nb) ! (rworkspace: 0) - call stdlib_cungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_clacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_claset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) + call stdlib${ii}$_clacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_claset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n @@ -68030,20 +68032,20 @@ module stdlib_linalg_lapack_c ! (cworkspace: need 2*n*n+3*n, ! prefer 2*n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_cgebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib${ii}$_cgebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_clacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib${ii}$_clacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate left bidiagonalizing vectors in work(iu) ! (cworkspace: need 2*n*n+3*n, prefer 2*n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib${ii}$_cungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in work(ir) ! (cworkspace: need 2*n*n+3*n-1, ! prefer 2*n*n+2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_cungbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -68051,57 +68053,57 @@ module stdlib_linalg_lapack_c ! right singular vectors of r in work(ir) ! (cworkspace: need 2*n*n) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', n, n, n, 0, s, rwork( ie ),work( ir ), ldwrkr, & - work( iu ),ldwrku, cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_cbdsqr( 'U', n, n, n, 0_${ik}$, s, rwork( ie ),work( ir ), ldwrkr, & + work( iu ),ldwrku, cdum, 1_${ik}$, rwork( irwork ),info ) ! multiply q in u by left singular vectors of r in ! work(iu), storing result in a ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_cgemm( 'N', 'N', m, n, n, cone, u, ldu,work( iu ), ldwrku, & + call stdlib${ii}$_cgemm( 'N', 'N', m, n, n, cone, u, ldu,work( iu ), ldwrku, & czero, a, lda ) ! copy left singular vectors of a from a to u - call stdlib_clacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_clacpy( 'F', m, n, a, lda, u, ldu ) ! copy right singular vectors of r from work(ir) to a - call stdlib_clacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) + call stdlib${ii}$_clacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_clacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_clacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need n+m, prefer n+m*nb) ! (rworkspace: 0) - call stdlib_cungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! zero out below r in a - if( n > 1 ) then - call stdlib_claset( 'L', n-1, n-1, czero, czero,a( 2, 1 ), lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_claset( 'L', n-1, n-1, czero, czero,a( 2_${ik}$, 1_${ik}$ ), lda ) end if ! bidiagonalize r in a ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_cgebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_cgebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in a ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_cunmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib${ii}$_cunmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in a ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & + call stdlib${ii}$_cungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -68109,17 +68111,17 @@ module stdlib_linalg_lapack_c ! singular vectors of a in a ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', n, n, m, 0, s, rwork( ie ), a,lda, u, ldu, & - cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_cbdsqr( 'U', n, n, m, 0_${ik}$, s, rwork( ie ), a,lda, u, ldu, & + cdum, 1_${ik}$, rwork( irwork ),info ) end if else if( wntvas ) then ! path 9 (m much larger than n, jobu='a', jobvt='s' ! or 'a') ! m left singular vectors to be computed in u and ! n right singular vectors to be computed in vt - if( lwork>=n*n+max( n+m, 3*n ) ) then + if( lwork>=n*n+max( n+m, 3_${ik}$*n ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+lda*n ) then ! work(iu) is lda by n ldwrku = lda @@ -68132,38 +68134,38 @@ module stdlib_linalg_lapack_c ! compute a=q*r, copying result to u ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_clacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_clacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need n*n+n+m, prefer n*n+n+m*nb) ! (rworkspace: 0) - call stdlib_cungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_clacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_claset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) + call stdlib${ii}$_clacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_claset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in work(iu), copying result to vt ! (cworkspace: need n*n+3*n, prefer n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_cgebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib${ii}$_cgebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_clacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) + call stdlib${ii}$_clacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) ! generate left bidiagonalizing vectors in work(iu) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib${ii}$_cungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (cworkspace: need n*n+3*n-1, ! prefer n*n+2*n+(n-1)*nb) ! (rworkspace: need 0) - call stdlib_cungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib${ii}$_cungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -68171,54 +68173,54 @@ module stdlib_linalg_lapack_c ! right singular vectors of r in vt ! (cworkspace: need n*n) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', n, n, n, 0, s, rwork( ie ), vt,ldvt, work( iu )& - , ldwrku, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'U', n, n, n, 0_${ik}$, s, rwork( ie ), vt,ldvt, work( iu )& + , ldwrku, cdum, 1_${ik}$,rwork( irwork ), info ) ! multiply q in u by left singular vectors of r in ! work(iu), storing result in a ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_cgemm( 'N', 'N', m, n, n, cone, u, ldu,work( iu ), ldwrku, & + call stdlib${ii}$_cgemm( 'N', 'N', m, n, n, cone, u, ldu,work( iu ), ldwrku, & czero, a, lda ) ! copy left singular vectors of a from a to u - call stdlib_clacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_clacpy( 'F', m, n, a, lda, u, ldu ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_clacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_clacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need n+m, prefer n+m*nb) ! (rworkspace: 0) - call stdlib_cungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r from a to vt, zeroing out below it - call stdlib_clacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_claset( 'L', n-1, n-1, czero, czero,vt( 2, 1 ), & + call stdlib${ii}$_clacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1_${ik}$ )call stdlib${ii}$_claset( 'L', n-1, n-1, czero, czero,vt( 2_${ik}$, 1_${ik}$ ), & ldvt ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in vt ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_cgebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_cgebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in vt ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_cunmbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & + call stdlib${ii}$_cunmbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib${ii}$_cungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -68226,8 +68228,8 @@ module stdlib_linalg_lapack_c ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', n, n, m, 0, s, rwork( ie ), vt,ldvt, u, ldu, & - cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'U', n, n, m, 0_${ik}$, s, rwork( ie ), vt,ldvt, u, ldu, & + cdum, 1_${ik}$,rwork( irwork ), info ) end if end if end if @@ -68235,24 +68237,24 @@ module stdlib_linalg_lapack_c ! m < mnthr ! path 10 (m at least n, but not much larger) ! reduce to bidiagonal form without qr decomposition - ie = 1 - itauq = 1 + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + n iwork = itaup + n ! bidiagonalize a ! (cworkspace: need 2*n+m, prefer 2*n+(m+n)*nb) ! (rworkspace: need n) - call stdlib_cgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_cgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,ierr ) if( wntuas ) then ! if left singular vectors desired in u, copy result to u ! and generate left bidiagonalizing vectors in u ! (cworkspace: need 2*n+ncu, prefer 2*n+ncu*nb) ! (rworkspace: 0) - call stdlib_clacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_clacpy( 'L', m, n, a, lda, u, ldu ) if( wntus )ncu = n if( wntua )ncu = m - call stdlib_cungbr( 'Q', m, ncu, n, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_cungbr( 'Q', m, ncu, n, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) end if if( wntvas ) then @@ -68260,8 +68262,8 @@ module stdlib_linalg_lapack_c ! vt and generate right bidiagonalizing vectors in vt ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_clacpy( 'U', n, n, a, lda, vt, ldvt ) - call stdlib_cungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib${ii}$_clacpy( 'U', n, n, a, lda, vt, ldvt ) + call stdlib${ii}$_cungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) end if if( wntuo ) then @@ -68269,7 +68271,7 @@ module stdlib_linalg_lapack_c ! bidiagonalizing vectors in a ! (cworkspace: need 3*n, prefer 2*n+n*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), lwork-& + call stdlib${ii}$_cungbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), lwork-& iwork+1, ierr ) end if if( wntvo ) then @@ -68277,38 +68279,38 @@ module stdlib_linalg_lapack_c ! bidiagonalizing vectors in a ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-& + call stdlib${ii}$_cungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-& iwork+1, ierr ) end if irwork = ie + n if( wntuas .or. wntuo )nru = m - if( wntun )nru = 0 + if( wntun )nru = 0_${ik}$ if( wntvas .or. wntvo )ncvt = n - if( wntvn )ncvt = 0 + if( wntvn )ncvt = 0_${ik}$ if( ( .not.wntuo ) .and. ( .not.wntvo ) ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', n, ncvt, nru, 0, s, rwork( ie ), vt,ldvt, u, ldu, & - cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_cbdsqr( 'U', n, ncvt, nru, 0_${ik}$, s, rwork( ie ), vt,ldvt, u, ldu, & + cdum, 1_${ik}$, rwork( irwork ),info ) else if( ( .not.wntuo ) .and. wntvo ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in a ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', n, ncvt, nru, 0, s, rwork( ie ), a,lda, u, ldu, cdum,& - 1, rwork( irwork ),info ) + call stdlib${ii}$_cbdsqr( 'U', n, ncvt, nru, 0_${ik}$, s, rwork( ie ), a,lda, u, ldu, cdum,& + 1_${ik}$, rwork( irwork ),info ) else ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in a and computing right singular ! vectors in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', n, ncvt, nru, 0, s, rwork( ie ), vt,ldvt, a, lda, & - cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_cbdsqr( 'U', n, ncvt, nru, 0_${ik}$, s, rwork( ie ), vt,ldvt, a, lda, & + cdum, 1_${ik}$, rwork( irwork ),info ) end if end if else @@ -68319,49 +68321,49 @@ module stdlib_linalg_lapack_c if( wntvn ) then ! path 1t(n much larger than m, jobvt='n') ! no right singular vectors to be computed - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_cgelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & + call stdlib${ii}$_cgelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & ierr ) ! zero out above l - if (m>1) call stdlib_claset( 'U', m-1, m-1, czero, czero, a( 1, 2 ),lda ) - ie = 1 - itauq = 1 + if (m>1_${ik}$) call stdlib${ii}$_claset( 'U', m-1, m-1, czero, czero, a( 1_${ik}$, 2_${ik}$ ),lda ) + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + m iwork = itaup + m ! bidiagonalize l in a ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_cgebrd( m, m, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& + call stdlib${ii}$_cgebrd( m, m, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& work( iwork ), lwork-iwork+1,ierr ) if( wntuo .or. wntuas ) then ! if left singular vectors desired, generate q ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & + call stdlib${ii}$_cungbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) end if irwork = ie + m - nru = 0 + nru = 0_${ik}$ if( wntuo .or. wntuas )nru = m ! perform bidiagonal qr iteration, computing left singular ! vectors of a in a if desired ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', m, 0, nru, 0, s, rwork( ie ), cdum, 1,a, lda, cdum, & - 1, rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'U', m, 0_${ik}$, nru, 0_${ik}$, s, rwork( ie ), cdum, 1_${ik}$,a, lda, cdum, & + 1_${ik}$, rwork( irwork ), info ) ! if left singular vectors desired in u, copy them there - if( wntuas )call stdlib_clacpy( 'F', m, m, a, lda, u, ldu ) + if( wntuas )call stdlib${ii}$_clacpy( 'F', m, m, a, lda, u, ldu ) else if( wntvo .and. wntun ) then ! path 2t(n much larger than m, jobu='n', jobvt='o') ! m right singular vectors to be overwritten on a and ! no left singular vectors to be computed if( lwork>=m*m+3*m ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=max( wrkbl, lda*n )+lda*m ) then ! work(iu) is lda by n and work(ir) is lda by m ldwrku = lda @@ -68383,38 +68385,38 @@ module stdlib_linalg_lapack_c ! compute a=l*q ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy l to work(ir) and zero out above it - call stdlib_clacpy( 'L', m, m, a, lda, work( ir ), ldwrkr ) - call stdlib_claset( 'U', m-1, m-1, czero, czero,work( ir+ldwrkr ), ldwrkr ) + call stdlib${ii}$_clacpy( 'L', m, m, a, lda, work( ir ), ldwrkr ) + call stdlib${ii}$_claset( 'U', m-1, m-1, czero, czero,work( ir+ldwrkr ), ldwrkr ) ! generate q in a ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_cunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in work(ir) ! (cworkspace: need m*m+3*m, prefer m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_cgebrd( m, m, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ),& + call stdlib${ii}$_cgebrd( m, m, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ),& work( itaup ),work( iwork ), lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing l ! (cworkspace: need m*m+3*m-1, prefer m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & + call stdlib${ii}$_cungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & iwork ),lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of l in work(ir) ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', m, m, 0, 0, s, rwork( ie ),work( ir ), ldwrkr, & - cdum, 1, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'U', m, m, 0_${ik}$, 0_${ik}$, s, rwork( ie ),work( ir ), ldwrkr, & + cdum, 1_${ik}$, cdum, 1_${ik}$,rwork( irwork ), info ) iu = itauq ! multiply right singular vectors of l in work(ir) by q ! in a, storing result in work(iu) and copying to a @@ -68422,34 +68424,34 @@ module stdlib_linalg_lapack_c ! (rworkspace: 0) do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_cgemm( 'N', 'N', m, blk, m, cone, work( ir ),ldwrkr, a( 1, & + call stdlib${ii}$_cgemm( 'N', 'N', m, blk, m, cone, work( ir ),ldwrkr, a( 1_${ik}$, & i ), lda, czero,work( iu ), ldwrku ) - call stdlib_clacpy( 'F', m, blk, work( iu ), ldwrku,a( 1, i ), lda ) + call stdlib${ii}$_clacpy( 'F', m, blk, work( iu ), ldwrku,a( 1_${ik}$, i ), lda ) end do else ! insufficient workspace for a fast algorithm - ie = 1 - itauq = 1 + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + m iwork = itaup + m ! bidiagonalize a ! (cworkspace: need 2*m+n, prefer 2*m+(m+n)*nb) ! (rworkspace: need m) - call stdlib_cgebrd( m, n, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_cgebrd( m, n, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing a ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), & + call stdlib${ii}$_cungbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of a in a ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'L', m, n, 0, 0, s, rwork( ie ), a, lda,cdum, 1, cdum, & - 1, rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'L', m, n, 0_${ik}$, 0_${ik}$, s, rwork( ie ), a, lda,cdum, 1_${ik}$, cdum, & + 1_${ik}$, rwork( irwork ), info ) end if else if( wntvo .and. wntuas ) then ! path 3t(n much larger than m, jobu='s' or 'a', jobvt='o') @@ -68457,7 +68459,7 @@ module stdlib_linalg_lapack_c ! m left singular vectors to be computed in u if( lwork>=m*m+3*m ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=max( wrkbl, lda*n )+lda*m ) then ! work(iu) is lda by n and work(ir) is lda by m ldwrku = lda @@ -68479,35 +68481,35 @@ module stdlib_linalg_lapack_c ! compute a=l*q ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy l to u, zeroing about above it - call stdlib_clacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_claset( 'U', m-1, m-1, czero, czero, u( 1, 2 ),ldu ) + call stdlib${ii}$_clacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1_${ik}$) call stdlib${ii}$_claset( 'U', m-1, m-1, czero, czero, u( 1_${ik}$, 2_${ik}$ ),ldu ) ! generate q in a ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_cunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in u, copying result to work(ir) ! (cworkspace: need m*m+3*m, prefer m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_cgebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_cgebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) - call stdlib_clacpy( 'U', m, m, u, ldu, work( ir ), ldwrkr ) + call stdlib${ii}$_clacpy( 'U', m, m, u, ldu, work( ir ), ldwrkr ) ! generate right vectors bidiagonalizing l in work(ir) ! (cworkspace: need m*m+3*m-1, prefer m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & + call stdlib${ii}$_cungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & iwork ),lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing l in u ! (cworkspace: need m*m+3*m, prefer m*m+2*m+m*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_cungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -68515,8 +68517,8 @@ module stdlib_linalg_lapack_c ! singular vectors of l in work(ir) ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( ir ), ldwrkr, u, & - ldu, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'U', m, m, m, 0_${ik}$, s, rwork( ie ),work( ir ), ldwrkr, u, & + ldu, cdum, 1_${ik}$,rwork( irwork ), info ) iu = itauq ! multiply right singular vectors of l in work(ir) by q ! in a, storing result in work(iu) and copying to a @@ -68524,46 +68526,46 @@ module stdlib_linalg_lapack_c ! (rworkspace: 0) do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_cgemm( 'N', 'N', m, blk, m, cone, work( ir ),ldwrkr, a( 1, & + call stdlib${ii}$_cgemm( 'N', 'N', m, blk, m, cone, work( ir ),ldwrkr, a( 1_${ik}$, & i ), lda, czero,work( iu ), ldwrku ) - call stdlib_clacpy( 'F', m, blk, work( iu ), ldwrku,a( 1, i ), lda ) + call stdlib${ii}$_clacpy( 'F', m, blk, work( iu ), ldwrku,a( 1_${ik}$, i ), lda ) end do else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy l to u, zeroing out above it - call stdlib_clacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_claset( 'U', m-1, m-1, czero, czero, u( 1, 2 ),ldu ) + call stdlib${ii}$_clacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1_${ik}$) call stdlib${ii}$_claset( 'U', m-1, m-1, czero, czero, u( 1_${ik}$, 2_${ik}$ ),ldu ) ! generate q in a ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_cunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in u ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_cgebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_cgebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right vectors bidiagonalizing l by q in a ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_cunmbr( 'P', 'L', 'C', m, n, m, u, ldu,work( itaup ), a, lda, & + call stdlib${ii}$_cunmbr( 'P', 'L', 'C', m, n, m, u, ldu,work( itaup ), a, lda, & work( iwork ),lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing l in u ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_cungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -68571,8 +68573,8 @@ module stdlib_linalg_lapack_c ! singular vectors of a in a ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', m, n, m, 0, s, rwork( ie ), a, lda,u, ldu, cdum, & - 1, rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'U', m, n, m, 0_${ik}$, s, rwork( ie ), a, lda,u, ldu, cdum, & + 1_${ik}$, rwork( irwork ), info ) end if else if( wntvs ) then if( wntun ) then @@ -68581,7 +68583,7 @@ module stdlib_linalg_lapack_c ! no left singular vectors to be computed if( lwork>=m*m+3*m ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=wrkbl+lda*m ) then ! work(ir) is lda by m ldwrkr = lda @@ -68594,92 +68596,92 @@ module stdlib_linalg_lapack_c ! compute a=l*q ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy l to work(ir), zeroing out above it - call stdlib_clacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) - call stdlib_claset( 'U', m-1, m-1, czero, czero,work( ir+ldwrkr ), & + call stdlib${ii}$_clacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) + call stdlib${ii}$_claset( 'U', m-1, m-1, czero, czero,work( ir+ldwrkr ), & ldwrkr ) ! generate q in a ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_cunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in work(ir) ! (cworkspace: need m*m+3*m, prefer m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_cgebrd( m, m, work( ir ), ldwrkr, s,rwork( ie ), work( & + call stdlib${ii}$_cgebrd( m, m, work( ir ), ldwrkr, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing l in ! work(ir) ! (cworkspace: need m*m+3*m, prefer m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_cungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of l in work(ir) ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', m, m, 0, 0, s, rwork( ie ),work( ir ), ldwrkr, & - cdum, 1, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'U', m, m, 0_${ik}$, 0_${ik}$, s, rwork( ie ),work( ir ), ldwrkr, & + cdum, 1_${ik}$, cdum, 1_${ik}$,rwork( irwork ), info ) ! multiply right singular vectors of l in work(ir) by ! q in a, storing result in vt ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_cgemm( 'N', 'N', m, n, m, cone, work( ir ),ldwrkr, a, lda, & + call stdlib${ii}$_cgemm( 'N', 'N', m, n, m, cone, work( ir ),ldwrkr, a, lda, & czero, vt, ldvt ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy result to vt - call stdlib_clacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_clacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_cunglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_cunglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_claset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda ) + if (m>1_${ik}$) call stdlib${ii}$_claset( 'U', m-1, m-1, czero, czero,a( 1_${ik}$, 2_${ik}$ ), lda ) ! bidiagonalize l in a ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_cgebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_cgebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right vectors bidiagonalizing l by q in vt ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_cunmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & + call stdlib${ii}$_cunmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', m, n, 0, 0, s, rwork( ie ), vt,ldvt, cdum, 1, & - cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'U', m, n, 0_${ik}$, 0_${ik}$, s, rwork( ie ), vt,ldvt, cdum, 1_${ik}$, & + cdum, 1_${ik}$,rwork( irwork ), info ) end if else if( wntuo ) then ! path 5t(n much larger than m, jobu='o', jobvt='s') ! m right singular vectors to be computed in vt and ! m left singular vectors to be overwritten on a - if( lwork>=2*m*m+3*m ) then + if( lwork>=2_${ik}$*m*m+3*m ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+2*lda*m ) then ! work(iu) is lda by m and work(ir) is lda by m ldwrku = lda @@ -68701,18 +68703,18 @@ module stdlib_linalg_lapack_c ! compute a=l*q ! (cworkspace: need 2*m*m+2*m, prefer 2*m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy l to work(iu), zeroing out below it - call stdlib_clacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_claset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & + call stdlib${ii}$_clacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_claset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & ldwrku ) ! generate q in a ! (cworkspace: need 2*m*m+2*m, prefer 2*m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_cunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m @@ -68721,20 +68723,20 @@ module stdlib_linalg_lapack_c ! (cworkspace: need 2*m*m+3*m, ! prefer 2*m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_cgebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib${ii}$_cgebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_clacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib${ii}$_clacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate right bidiagonalizing vectors in work(iu) ! (cworkspace: need 2*m*m+3*m-1, ! prefer 2*m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib${ii}$_cungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in work(ir) ! (cworkspace: need 2*m*m+3*m, prefer 2*m*m+2*m+m*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_cungbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -68742,53 +68744,53 @@ module stdlib_linalg_lapack_c ! right singular vectors of l in work(iu) ! (cworkspace: need 2*m*m) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( iu ), ldwrku, & - work( ir ),ldwrkr, cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_cbdsqr( 'U', m, m, m, 0_${ik}$, s, rwork( ie ),work( iu ), ldwrku, & + work( ir ),ldwrkr, cdum, 1_${ik}$, rwork( irwork ),info ) ! multiply right singular vectors of l in work(iu) by ! q in a, storing result in vt ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_cgemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, a, lda, & + call stdlib${ii}$_cgemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, a, lda, & czero, vt, ldvt ) ! copy left singular vectors of l to a ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_clacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) + call stdlib${ii}$_clacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_clacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_clacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_cunglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_cunglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_claset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda ) + if (m>1_${ik}$) call stdlib${ii}$_claset( 'U', m-1, m-1, czero, czero,a( 1_${ik}$, 2_${ik}$ ), lda ) ! bidiagonalize l in a ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_cgebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_cgebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right vectors bidiagonalizing l by q in vt ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_cunmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & + call stdlib${ii}$_cunmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors of l in a ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & + call stdlib${ii}$_cungbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -68796,8 +68798,8 @@ module stdlib_linalg_lapack_c ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', m, n, m, 0, s, rwork( ie ), vt,ldvt, a, lda, & - cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'U', m, n, m, 0_${ik}$, s, rwork( ie ), vt,ldvt, a, lda, & + cdum, 1_${ik}$,rwork( irwork ), info ) end if else if( wntuas ) then ! path 6t(n much larger than m, jobu='s' or 'a', @@ -68806,7 +68808,7 @@ module stdlib_linalg_lapack_c ! m left singular vectors to be computed in u if( lwork>=m*m+3*m ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+lda*m ) then ! work(iu) is lda by n ldwrku = lda @@ -68819,37 +68821,37 @@ module stdlib_linalg_lapack_c ! compute a=l*q ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy l to work(iu), zeroing out above it - call stdlib_clacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_claset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & + call stdlib${ii}$_clacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_claset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & ldwrku ) ! generate q in a ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_cunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in work(iu), copying result to u ! (cworkspace: need m*m+3*m, prefer m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_cgebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib${ii}$_cgebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_clacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) + call stdlib${ii}$_clacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) ! generate right bidiagonalizing vectors in work(iu) ! (cworkspace: need m*m+3*m-1, ! prefer m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib${ii}$_cungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (cworkspace: need m*m+3*m, prefer m*m+2*m+m*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_cungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -68857,51 +68859,51 @@ module stdlib_linalg_lapack_c ! singular vectors of l in work(iu) ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( iu ), ldwrku, & - u, ldu, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'U', m, m, m, 0_${ik}$, s, rwork( ie ),work( iu ), ldwrku, & + u, ldu, cdum, 1_${ik}$,rwork( irwork ), info ) ! multiply right singular vectors of l in work(iu) by ! q in a, storing result in vt ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_cgemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, a, lda, & + call stdlib${ii}$_cgemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, a, lda, & czero, vt, ldvt ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_clacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_clacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_cunglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_cunglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to u, zeroing out above it - call stdlib_clacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_claset( 'U', m-1, m-1, czero, czero,u( 1, 2 ), ldu ) - ie = 1 + call stdlib${ii}$_clacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1_${ik}$) call stdlib${ii}$_claset( 'U', m-1, m-1, czero, czero,u( 1_${ik}$, 2_${ik}$ ), ldu ) + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in u ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_cgebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_cgebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in u by q ! in vt ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_cunmbr( 'P', 'L', 'C', m, n, m, u, ldu,work( itaup ), vt, & + call stdlib${ii}$_cunmbr( 'P', 'L', 'C', m, n, m, u, ldu,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_cungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -68909,8 +68911,8 @@ module stdlib_linalg_lapack_c ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', m, n, m, 0, s, rwork( ie ), vt,ldvt, u, ldu, & - cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'U', m, n, m, 0_${ik}$, s, rwork( ie ), vt,ldvt, u, ldu, & + cdum, 1_${ik}$,rwork( irwork ), info ) end if end if else if( wntva ) then @@ -68918,9 +68920,9 @@ module stdlib_linalg_lapack_c ! path 7t(n much larger than m, jobu='n', jobvt='a') ! n right singular vectors to be computed in vt and ! no left singular vectors to be computed - if( lwork>=m*m+max( n+m, 3*m ) ) then + if( lwork>=m*m+max( n+m, 3_${ik}$*m ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=wrkbl+lda*m ) then ! work(ir) is lda by m ldwrkr = lda @@ -68933,95 +68935,95 @@ module stdlib_linalg_lapack_c ! compute a=l*q, copying result to vt ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_clacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_clacpy( 'U', m, n, a, lda, vt, ldvt ) ! copy l to work(ir), zeroing out above it - call stdlib_clacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) - call stdlib_claset( 'U', m-1, m-1, czero, czero,work( ir+ldwrkr ), & + call stdlib${ii}$_clacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) + call stdlib${ii}$_claset( 'U', m-1, m-1, czero, czero,work( ir+ldwrkr ), & ldwrkr ) ! generate q in vt ! (cworkspace: need m*m+m+n, prefer m*m+m+n*nb) ! (rworkspace: 0) - call stdlib_cunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_cunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in work(ir) ! (cworkspace: need m*m+3*m, prefer m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_cgebrd( m, m, work( ir ), ldwrkr, s,rwork( ie ), work( & + call stdlib${ii}$_cgebrd( m, m, work( ir ), ldwrkr, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in work(ir) ! (cworkspace: need m*m+3*m-1, ! prefer m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_cungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of l in work(ir) ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', m, m, 0, 0, s, rwork( ie ),work( ir ), ldwrkr, & - cdum, 1, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'U', m, m, 0_${ik}$, 0_${ik}$, s, rwork( ie ),work( ir ), ldwrkr, & + cdum, 1_${ik}$, cdum, 1_${ik}$,rwork( irwork ), info ) ! multiply right singular vectors of l in work(ir) by ! q in vt, storing result in a ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_cgemm( 'N', 'N', m, n, m, cone, work( ir ),ldwrkr, vt, ldvt,& + call stdlib${ii}$_cgemm( 'N', 'N', m, n, m, cone, work( ir ),ldwrkr, vt, ldvt,& czero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_clacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_clacpy( 'F', m, n, a, lda, vt, ldvt ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_clacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_clacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need m+n, prefer m+n*nb) ! (rworkspace: 0) - call stdlib_cunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_cunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_claset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda ) + if (m>1_${ik}$) call stdlib${ii}$_claset( 'U', m-1, m-1, czero, czero,a( 1_${ik}$, 2_${ik}$ ), lda ) ! bidiagonalize l in a ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_cgebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_cgebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in a by q ! in vt ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_cunmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & + call stdlib${ii}$_cunmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', m, n, 0, 0, s, rwork( ie ), vt,ldvt, cdum, 1, & - cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'U', m, n, 0_${ik}$, 0_${ik}$, s, rwork( ie ), vt,ldvt, cdum, 1_${ik}$, & + cdum, 1_${ik}$,rwork( irwork ), info ) end if else if( wntuo ) then ! path 8t(n much larger than m, jobu='o', jobvt='a') ! n right singular vectors to be computed in vt and ! m left singular vectors to be overwritten on a - if( lwork>=2*m*m+max( n+m, 3*m ) ) then + if( lwork>=2_${ik}$*m*m+max( n+m, 3_${ik}$*m ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+2*lda*m ) then ! work(iu) is lda by m and work(ir) is lda by m ldwrku = lda @@ -69043,19 +69045,19 @@ module stdlib_linalg_lapack_c ! compute a=l*q, copying result to vt ! (cworkspace: need 2*m*m+2*m, prefer 2*m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_clacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_clacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need 2*m*m+m+n, prefer 2*m*m+m+n*nb) ! (rworkspace: 0) - call stdlib_cunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_cunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to work(iu), zeroing out above it - call stdlib_clacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_claset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & + call stdlib${ii}$_clacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_claset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & ldwrku ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m @@ -69064,20 +69066,20 @@ module stdlib_linalg_lapack_c ! (cworkspace: need 2*m*m+3*m, ! prefer 2*m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_cgebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib${ii}$_cgebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_clacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib${ii}$_clacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate right bidiagonalizing vectors in work(iu) ! (cworkspace: need 2*m*m+3*m-1, ! prefer 2*m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib${ii}$_cungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in work(ir) ! (cworkspace: need 2*m*m+3*m, prefer 2*m*m+2*m+m*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_cungbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -69085,54 +69087,54 @@ module stdlib_linalg_lapack_c ! right singular vectors of l in work(iu) ! (cworkspace: need 2*m*m) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( iu ), ldwrku, & - work( ir ),ldwrkr, cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_cbdsqr( 'U', m, m, m, 0_${ik}$, s, rwork( ie ),work( iu ), ldwrku, & + work( ir ),ldwrkr, cdum, 1_${ik}$, rwork( irwork ),info ) ! multiply right singular vectors of l in work(iu) by ! q in vt, storing result in a ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_cgemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, vt, ldvt,& + call stdlib${ii}$_cgemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, vt, ldvt,& czero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_clacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_clacpy( 'F', m, n, a, lda, vt, ldvt ) ! copy left singular vectors of a from work(ir) to a - call stdlib_clacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) + call stdlib${ii}$_clacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_clacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_clacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need m+n, prefer m+n*nb) ! (rworkspace: 0) - call stdlib_cunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_cunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_claset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda ) + if (m>1_${ik}$) call stdlib${ii}$_claset( 'U', m-1, m-1, czero, czero,a( 1_${ik}$, 2_${ik}$ ), lda ) ! bidiagonalize l in a ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_cgebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_cgebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in a by q ! in vt ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_cunmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & + call stdlib${ii}$_cunmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in a ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & + call stdlib${ii}$_cungbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -69140,17 +69142,17 @@ module stdlib_linalg_lapack_c ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', m, n, m, 0, s, rwork( ie ), vt,ldvt, a, lda, & - cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'U', m, n, m, 0_${ik}$, s, rwork( ie ), vt,ldvt, a, lda, & + cdum, 1_${ik}$,rwork( irwork ), info ) end if else if( wntuas ) then ! path 9t(n much larger than m, jobu='s' or 'a', ! jobvt='a') ! n right singular vectors to be computed in vt and ! m left singular vectors to be computed in u - if( lwork>=m*m+max( n+m, 3*m ) ) then + if( lwork>=m*m+max( n+m, 3_${ik}$*m ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+lda*m ) then ! work(iu) is lda by m ldwrku = lda @@ -69163,37 +69165,37 @@ module stdlib_linalg_lapack_c ! compute a=l*q, copying result to vt ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_clacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_clacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need m*m+m+n, prefer m*m+m+n*nb) ! (rworkspace: 0) - call stdlib_cunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_cunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to work(iu), zeroing out above it - call stdlib_clacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_claset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & + call stdlib${ii}$_clacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_claset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & ldwrku ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in work(iu), copying result to u ! (cworkspace: need m*m+3*m, prefer m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_cgebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib${ii}$_cgebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_clacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) + call stdlib${ii}$_clacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) ! generate right bidiagonalizing vectors in work(iu) ! (cworkspace: need m*m+3*m, prefer m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib${ii}$_cungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (cworkspace: need m*m+3*m, prefer m*m+2*m+m*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_cungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -69201,53 +69203,53 @@ module stdlib_linalg_lapack_c ! singular vectors of l in work(iu) ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( iu ), ldwrku, & - u, ldu, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'U', m, m, m, 0_${ik}$, s, rwork( ie ),work( iu ), ldwrku, & + u, ldu, cdum, 1_${ik}$,rwork( irwork ), info ) ! multiply right singular vectors of l in work(iu) by ! q in vt, storing result in a ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_cgemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, vt, ldvt,& + call stdlib${ii}$_cgemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, vt, ldvt,& czero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_clacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_clacpy( 'F', m, n, a, lda, vt, ldvt ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_cgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_clacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_clacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need m+n, prefer m+n*nb) ! (rworkspace: 0) - call stdlib_cunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_cunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to u, zeroing out above it - call stdlib_clacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_claset( 'U', m-1, m-1, czero, czero,u( 1, 2 ), ldu ) - ie = 1 + call stdlib${ii}$_clacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1_${ik}$) call stdlib${ii}$_claset( 'U', m-1, m-1, czero, czero,u( 1_${ik}$, 2_${ik}$ ), ldu ) + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in u ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_cgebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_cgebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in u by q ! in vt ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_cunmbr( 'P', 'L', 'C', m, n, m, u, ldu,work( itaup ), vt, & + call stdlib${ii}$_cunmbr( 'P', 'L', 'C', m, n, m, u, ldu,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_cungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -69255,8 +69257,8 @@ module stdlib_linalg_lapack_c ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'U', m, n, m, 0, s, rwork( ie ), vt,ldvt, u, ldu, & - cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_cbdsqr( 'U', m, n, m, 0_${ik}$, s, rwork( ie ), vt,ldvt, u, ldu, & + cdum, 1_${ik}$,rwork( irwork ), info ) end if end if end if @@ -69264,22 +69266,22 @@ module stdlib_linalg_lapack_c ! n < mnthr ! path 10t(n greater than m, but not much larger) ! reduce to bidiagonal form without lq decomposition - ie = 1 - itauq = 1 + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + m iwork = itaup + m ! bidiagonalize a ! (cworkspace: need 2*m+n, prefer 2*m+(m+n)*nb) ! (rworkspace: m) - call stdlib_cgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_cgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,ierr ) if( wntuas ) then ! if left singular vectors desired in u, copy result to u ! and generate left bidiagonalizing vectors in u ! (cworkspace: need 3*m-1, prefer 2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_clacpy( 'L', m, m, a, lda, u, ldu ) - call stdlib_cungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( iwork ), lwork-& + call stdlib${ii}$_clacpy( 'L', m, m, a, lda, u, ldu ) + call stdlib${ii}$_cungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( iwork ), lwork-& iwork+1, ierr ) end if if( wntvas ) then @@ -69287,10 +69289,10 @@ module stdlib_linalg_lapack_c ! vt and generate right bidiagonalizing vectors in vt ! (cworkspace: need 2*m+nrvt, prefer 2*m+nrvt*nb) ! (rworkspace: 0) - call stdlib_clacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_clacpy( 'U', m, n, a, lda, vt, ldvt ) if( wntva )nrvt = n if( wntvs )nrvt = m - call stdlib_cungbr( 'P', nrvt, n, m, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib${ii}$_cungbr( 'P', nrvt, n, m, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) end if if( wntuo ) then @@ -69298,7 +69300,7 @@ module stdlib_linalg_lapack_c ! bidiagonalizing vectors in a ! (cworkspace: need 3*m-1, prefer 2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'Q', m, m, n, a, lda, work( itauq ),work( iwork ), lwork-& + call stdlib${ii}$_cungbr( 'Q', m, m, n, a, lda, work( itauq ),work( iwork ), lwork-& iwork+1, ierr ) end if if( wntvo ) then @@ -69306,59 +69308,59 @@ module stdlib_linalg_lapack_c ! bidiagonalizing vectors in a ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_cungbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-& + call stdlib${ii}$_cungbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-& iwork+1, ierr ) end if irwork = ie + m if( wntuas .or. wntuo )nru = m - if( wntun )nru = 0 + if( wntun )nru = 0_${ik}$ if( wntvas .or. wntvo )ncvt = n - if( wntvn )ncvt = 0 + if( wntvn )ncvt = 0_${ik}$ if( ( .not.wntuo ) .and. ( .not.wntvo ) ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'L', m, ncvt, nru, 0, s, rwork( ie ), vt,ldvt, u, ldu, & - cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_cbdsqr( 'L', m, ncvt, nru, 0_${ik}$, s, rwork( ie ), vt,ldvt, u, ldu, & + cdum, 1_${ik}$, rwork( irwork ),info ) else if( ( .not.wntuo ) .and. wntvo ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in a ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'L', m, ncvt, nru, 0, s, rwork( ie ), a,lda, u, ldu, cdum,& - 1, rwork( irwork ),info ) + call stdlib${ii}$_cbdsqr( 'L', m, ncvt, nru, 0_${ik}$, s, rwork( ie ), a,lda, u, ldu, cdum,& + 1_${ik}$, rwork( irwork ),info ) else ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in a and computing right singular ! vectors in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_cbdsqr( 'L', m, ncvt, nru, 0, s, rwork( ie ), vt,ldvt, a, lda, & - cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_cbdsqr( 'L', m, ncvt, nru, 0_${ik}$, s, rwork( ie ), vt,ldvt, a, lda, & + cdum, 1_${ik}$, rwork( irwork ),info ) end if end if end if ! undo scaling if necessary - if( iscl==1 ) then - if( anrm>bignum )call stdlib_slascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,& + if( iscl==1_${ik}$ ) then + if( anrm>bignum )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn, 1_${ik}$, s, minmn,& ierr ) - if( info/=0 .and. anrm>bignum )call stdlib_slascl( 'G', 0, 0, bignum, anrm, minmn-1,& - 1,rwork( ie ), minmn, ierr ) - if( anrmbignum )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn-1,& + 1_${ik}$,rwork( ie ), minmn, ierr ) + if( anrm= N. The SVD of A is written as !! [++] [xx] [x0] [xx] @@ -69371,20 +69373,20 @@ module stdlib_linalg_lapack_c numrank, iwork, liwork,cwork, lcwork, rwork, lrwork, info ) ! Scalar Arguments character, intent(in) :: joba, jobp, jobr, jobu, jobv - integer(ilp), intent(in) :: m, n, lda, ldu, ldv, liwork, lrwork - integer(ilp), intent(out) :: numrank, info - integer(ilp), intent(inout) :: lcwork + integer(${ik}$), intent(in) :: m, n, lda, ldu, ldv, liwork, lrwork + integer(${ik}$), intent(out) :: numrank, info + integer(${ik}$), intent(inout) :: lcwork ! Array Arguments complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: u(ldu,*), v(ldv,*), cwork(*) real(sp), intent(out) :: s(*), rwork(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: ierr, nr, n1, optratio, p, q - integer(ilp) :: lwcon, lwqp3, lwrk_cgelqf, lwrk_cgesvd, lwrk_cgesvd2, lwrk_cgeqp3, & + integer(${ik}$) :: ierr, nr, n1, optratio, p, q + integer(${ik}$) :: lwcon, lwqp3, lwrk_cgelqf, lwrk_cgesvd, lwrk_cgesvd2, lwrk_cgeqp3, & lwrk_cgeqrf, lwrk_cunmlq, lwrk_cunmqr, lwrk_cunmqr2, lwlqf, lwqrf, lwsvd, lwsvd2, & lwunq, lwunq2, lwunlq, minwrk, minwrk2, optwrk, optwrk2, iminwrk, rminwrk logical(lk) :: accla, acclm, acclh, ascaled, conda, dntwu, dntwv, lquery, lsvc0, lsvec,& @@ -69392,8 +69394,8 @@ module stdlib_linalg_lapack_c real(sp) :: big, epsln, rtmp, sconda, sfmin complex(sp) :: ctmp ! Local Arrays - complex(sp) :: cdummy(1) - real(sp) :: rdummy(1) + complex(sp) :: cdummy(1_${ik}$) + real(sp) :: rdummy(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,conjg,max,min,real,sqrt ! Executable Statements @@ -69416,40 +69418,40 @@ module stdlib_linalg_lapack_c rowprm = stdlib_lsame( jobp, 'P' ) rtrans = stdlib_lsame( jobr, 'T' ) if ( rowprm ) then - iminwrk = max( 1, n + m - 1 ) - rminwrk = max( 2, m, 5*n ) + iminwrk = max( 1_${ik}$, n + m - 1_${ik}$ ) + rminwrk = max( 2_${ik}$, m, 5_${ik}$*n ) else - iminwrk = max( 1, n ) - rminwrk = max( 2, 5*n ) + iminwrk = max( 1_${ik}$, n ) + rminwrk = max( 2_${ik}$, 5_${ik}$*n ) end if - lquery = (liwork == -1 .or. lcwork == -1 .or. lrwork == -1) - info = 0 + lquery = (liwork == -1_${ik}$ .or. lcwork == -1_${ik}$ .or. lrwork == -1_${ik}$) + info = 0_${ik}$ if ( .not. ( accla .or. acclm .or. acclh ) ) then - info = -1 + info = -1_${ik}$ else if ( .not.( rowprm .or. stdlib_lsame( jobp, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if ( .not.( rtrans .or. stdlib_lsame( jobr, 'N' ) ) ) then - info = -3 + info = -3_${ik}$ else if ( .not.( lsvec .or. dntwu ) ) then - info = -4 + info = -4_${ik}$ else if ( wntur .and. wntva ) then - info = -5 + info = -5_${ik}$ else if ( .not.( rsvec .or. dntwv )) then - info = -5 - else if ( m<0 ) then - info = -6 - else if ( ( n<0 ) .or. ( n>m ) ) then - info = -7 - else if ( ldam ) ) then + info = -7_${ik}$ + else if ( lda big / sqrt(real(m,KIND=sp)) ) then + if ( rwork(1_${ik}$) > big / sqrt(real(m,KIND=sp)) ) then ! .. to prevent overflow in the qr factorization, scale the ! matrix by 1/sqrt(m) if too large entry detected - call stdlib_clascl('G',0,0,sqrt(real(m,KIND=sp)),one, m,n, a,lda, ierr) + call stdlib${ii}$_clascl('G',0_${ik}$,0_${ik}$,sqrt(real(m,KIND=sp)),one, m,n, a,lda, ierr) ascaled = .true. end if - call stdlib_claswp( n, a, lda, 1, m-1, iwork(n+1), 1 ) + call stdlib${ii}$_claswp( n, a, lda, 1_${ik}$, m-1, iwork(n+1), 1_${ik}$ ) end if ! .. at this stage, preemptive scaling is done only to avoid column ! norms overflows during the qr factorization. the svd procedure should ! have its own scaling to save the singular values from overflows and ! underflows. that depends on the svd procedure. if ( .not.rowprm ) then - rtmp = stdlib_clange( 'M', m, n, a, lda, rwork ) + rtmp = stdlib${ii}$_clange( 'M', m, n, a, lda, rwork ) if ( ( rtmp /= rtmp ) .or.( (rtmp*zero) /= zero ) ) then - info = - 8 - call stdlib_xerbla( 'CGESVDQ', -info ) + info = - 8_${ik}$ + call stdlib${ii}$_xerbla( 'CGESVDQ', -info ) return end if if ( rtmp > big / sqrt(real(m,KIND=sp)) ) then ! .. to prevent overflow in the qr factorization, scale the ! matrix by 1/sqrt(m) if too large entry detected - call stdlib_clascl('G',0,0, sqrt(real(m,KIND=sp)),one, m,n, a,lda, ierr) + call stdlib${ii}$_clascl('G',0_${ik}$,0_${ik}$, sqrt(real(m,KIND=sp)),one, m,n, a,lda, ierr) ascaled = .true. end if @@ -69736,15 +69738,15 @@ module stdlib_linalg_lapack_c ! [ 0 ] do p = 1, n ! All Columns Are Free Columns - iwork(p) = 0 + iwork(p) = 0_${ik}$ end do - call stdlib_cgeqp3( m, n, a, lda, iwork, cwork, cwork(n+1), lcwork-n,rwork, ierr ) + call stdlib${ii}$_cgeqp3( m, n, a, lda, iwork, cwork, cwork(n+1), lcwork-n,rwork, ierr ) ! if the user requested accuracy level allows truncation in the ! computed upper triangular factor, the matrix r is examined and, ! if possible, replaced with its leading upper trapezoidal part. - epsln = stdlib_slamch('E') - sfmin = stdlib_slamch('S') + epsln = stdlib${ii}$_slamch('E') + sfmin = stdlib${ii}$_slamch('S') ! small = sfmin / epsln nr = n if ( accla ) then @@ -69752,57 +69754,53 @@ module stdlib_linalg_lapack_c ! sigma_i < n*eps*||a||_f are flushed to zero. this is an ! aggressive enforcement of lower numerical rank by introducing a ! backward error of the order of n*eps*||a||_f. - nr = 1 + nr = 1_${ik}$ rtmp = sqrt(real(n,KIND=sp))*epsln - do p = 2, n - if ( abs(a(p,p)) < (rtmp*abs(a(1,1))) ) go to 3002 - nr = nr + 1 - end do - 3002 continue + loop_3002: do p = 2, n + if ( abs(a(p,p)) < (rtmp*abs(a(1,1))) ) exit loop_3002 + nr = nr + 1_${ik}$ + end do loop_3002 elseif ( acclm ) then ! .. similarly as above, only slightly more gentle (less aggressive). ! sudden drop on the diagonal of r is used as the criterion for being - ! close-to-rank-deficient. the threshold is set to epsln=stdlib_slamch('e'). + ! close-to-rank-deficient. the threshold is set to epsln=stdlib${ii}$_slamch('e'). ! [[this can be made more flexible by replacing this hard-coded value ! with a user specified threshold.]] also, the values that underflow ! will be truncated. - nr = 1 - do p = 2, n - if ( ( abs(a(p,p)) < (epsln*abs(a(p-1,p-1))) ) .or.( abs(a(p,p)) < sfmin ) ) go & - to 3402 - nr = nr + 1 - end do - 3402 continue + nr = 1_${ik}$ + loop_3402: do p = 2, n + if ( ( abs(a(p,p)) < (epsln*abs(a(p-1,p-1))) ) .or.( abs(a(p,p)) < sfmin ) ) exit loop_3402 + nr = nr + 1_${ik}$ + end do loop_3402 else ! Rrqr Not Authorized To Determine Numerical Rank Except In The ! obvious case of zero pivots. ! .. inspect r for exact zeros on the diagonal; ! r(i,i)=0 => r(i:n,i:n)=0. - nr = 1 - do p = 2, n - if ( abs(a(p,p)) == zero ) go to 3502 - nr = nr + 1 - end do - 3502 continue + nr = 1_${ik}$ + loop_3502: do p = 2, n + if ( abs(a(p,p)) == zero ) exit loop_3502 + nr = nr + 1_${ik}$ + end do loop_3502 if ( conda ) then ! estimate the scaled condition number of a. use the fact that it is ! the same as the scaled condition number of r. ! V Is Used As Workspace - call stdlib_clacpy( 'U', n, n, a, lda, v, ldv ) + call stdlib${ii}$_clacpy( 'U', n, n, a, lda, v, ldv ) ! only the leading nr x nr submatrix of the triangular factor ! is considered. only if nr=n will this give a reliable error ! bound. however, even for nr < n, this can be used on an ! expert level and obtain useful information in the sense of ! perturbation theory. do p = 1, nr - rtmp = stdlib_scnrm2( p, v(1,p), 1 ) - call stdlib_csscal( p, one/rtmp, v(1,p), 1 ) + rtmp = stdlib${ii}$_scnrm2( p, v(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_csscal( p, one/rtmp, v(1_${ik}$,p), 1_${ik}$ ) end do if ( .not. ( lsvec .or. rsvec ) ) then - call stdlib_cpocon( 'U', nr, v, ldv, one, rtmp,cwork, rwork, ierr ) + call stdlib${ii}$_cpocon( 'U', nr, v, ldv, one, rtmp,cwork, rwork, ierr ) else - call stdlib_cpocon( 'U', nr, v, ldv, one, rtmp,cwork(n+1), rwork, ierr ) + call stdlib${ii}$_cpocon( 'U', nr, v, ldv, one, rtmp,cwork(n+1), rwork, ierr ) end if sconda = one / sqrt(rtmp) @@ -69833,13 +69831,13 @@ module stdlib_linalg_lapack_c if ( q <= nr ) a(p,q) = czero end do end do - call stdlib_cgesvd( 'N', 'N', n, nr, a, lda, s, u, ldu,v, ldv, cwork, lcwork, & + call stdlib${ii}$_cgesvd( 'N', 'N', n, nr, a, lda, s, u, ldu,v, ldv, cwork, lcwork, & rwork, info ) else ! .. compute the singular values of r = [a](1:nr,1:n) - if ( nr > 1 )call stdlib_claset( 'L', nr-1,nr-1, czero,czero, a(2,1), lda ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_claset( 'L', nr-1,nr-1, czero,czero, a(2_${ik}$,1_${ik}$), lda ) - call stdlib_cgesvd( 'N', 'N', nr, n, a, lda, s, u, ldu,v, ldv, cwork, lcwork, & + call stdlib${ii}$_cgesvd( 'N', 'N', nr, n, a, lda, s, u, ldu,v, ldv, cwork, lcwork, & rwork, info ) end if else if ( lsvec .and. ( .not. rsvec) ) then @@ -69847,7 +69845,7 @@ module stdlib_linalg_lapack_c ! The Singular Values And The Left Singular Vectors Requested ! ......................................................................."""""""" if ( rtrans ) then - ! .. apply stdlib_cgesvd to r**h + ! .. apply stdlib${ii}$_cgesvd to r**h ! .. copy r**h into [u] and overwrite [u] with the right singular ! vectors of r do p = 1, nr @@ -69855,12 +69853,12 @@ module stdlib_linalg_lapack_c u(q,p) = conjg(a(p,q)) end do end do - if ( nr > 1 )call stdlib_claset( 'U', nr-1,nr-1, czero,czero, u(1,2), ldu ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_claset( 'U', nr-1,nr-1, czero,czero, u(1_${ik}$,2_${ik}$), ldu ) ! .. the left singular vectors not computed, the nr right singular ! vectors overwrite [u](1:nr,1:nr) as conjugate transposed. these ! will be pre-multiplied by q to build the left singular vectors of a. - call stdlib_cgesvd( 'N', 'O', n, nr, u, ldu, s, u, ldu,u, ldu, cwork(n+1), & + call stdlib${ii}$_cgesvd( 'N', 'O', n, nr, u, ldu, s, u, ldu,u, ldu, cwork(n+1), & lcwork-n, rwork, info ) do p = 1, nr u(p,p) = conjg(u(p,p)) @@ -69873,12 +69871,12 @@ module stdlib_linalg_lapack_c else ! Apply Stdlib_Cgesvd To R ! .. copy r into [u] and overwrite [u] with the left singular vectors - call stdlib_clacpy( 'U', nr, n, a, lda, u, ldu ) - if ( nr > 1 )call stdlib_claset( 'L', nr-1, nr-1, czero, czero, u(2,1), ldu ) + call stdlib${ii}$_clacpy( 'U', nr, n, a, lda, u, ldu ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_claset( 'L', nr-1, nr-1, czero, czero, u(2_${ik}$,1_${ik}$), ldu ) ! .. the right singular vectors not computed, the nr left singular ! vectors overwrite [u](1:nr,1:nr) - call stdlib_cgesvd( 'O', 'N', nr, n, u, ldu, s, u, ldu,v, ldv, cwork(n+1), & + call stdlib${ii}$_cgesvd( 'O', 'N', nr, n, u, ldu, s, u, ldu,v, ldv, cwork(n+1), & lcwork-n, rwork, info ) ! .. now [u](1:nr,1:nr) contains the nr left singular vectors of ! r. these will be pre-multiplied by q to build the left singular @@ -69887,36 +69885,36 @@ module stdlib_linalg_lapack_c ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. ( .not.wntuf ) ) then - call stdlib_claset('A', m-nr, nr, czero, czero, u(nr+1,1), ldu) + call stdlib${ii}$_claset('A', m-nr, nr, czero, czero, u(nr+1,1_${ik}$), ldu) if ( nr < n1 ) then - call stdlib_claset( 'A',nr,n1-nr,czero,czero,u(1,nr+1), ldu ) - call stdlib_claset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_claset( 'A',nr,n1-nr,czero,czero,u(1_${ik}$,nr+1), ldu ) + call stdlib${ii}$_claset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) end if end if ! the q matrix from the first qrf is built into the left singular ! vectors matrix u. - if ( .not.wntuf )call stdlib_cunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, & + if ( .not.wntuf )call stdlib${ii}$_cunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, & cwork(n+1), lcwork-n, ierr ) - if ( rowprm .and. .not.wntuf )call stdlib_claswp( n1, u, ldu, 1, m-1, iwork(n+1), -& - 1 ) + if ( rowprm .and. .not.wntuf )call stdlib${ii}$_claswp( n1, u, ldu, 1_${ik}$, m-1, iwork(n+1), -& + 1_${ik}$ ) else if ( rsvec .and. ( .not. lsvec ) ) then ! ....................................................................... ! The Singular Values And The Right Singular Vectors Requested ! ....................................................................... if ( rtrans ) then - ! .. apply stdlib_cgesvd to r**h + ! .. apply stdlib${ii}$_cgesvd to r**h ! .. copy r**h into v and overwrite v with the left singular vectors do p = 1, nr do q = p, n v(q,p) = conjg(a(p,q)) end do end do - if ( nr > 1 )call stdlib_claset( 'U', nr-1,nr-1, czero,czero, v(1,2), ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_claset( 'U', nr-1,nr-1, czero,czero, v(1_${ik}$,2_${ik}$), ldv ) ! .. the left singular vectors of r**h overwrite v, the right singular ! vectors not computed if ( wntvr .or. ( nr == n ) ) then - call stdlib_cgesvd( 'O', 'N', n, nr, v, ldv, s, u, ldu,u, ldu, cwork(n+1), & + call stdlib${ii}$_cgesvd( 'O', 'N', n, nr, v, ldv, s, u, ldu,u, ldu, cwork(n+1), & lcwork-n, rwork, info ) do p = 1, nr v(p,p) = conjg(v(p,p)) @@ -69933,15 +69931,15 @@ module stdlib_linalg_lapack_c end do end do end if - call stdlib_clapmt( .false., nr, n, v, ldv, iwork ) + call stdlib${ii}$_clapmt( .false., nr, n, v, ldv, iwork ) else ! .. need all n right singular vectors and nr < n ! [!] this is simple implementation that augments [v](1:n,1:nr) ! by padding a zero block. in the case nr << n, a more efficient ! way is to first use the qr factorization. for more details ! how to implement this, see the " full svd " branch. - call stdlib_claset('G', n, n-nr, czero, czero, v(1,nr+1), ldv) - call stdlib_cgesvd( 'O', 'N', n, n, v, ldv, s, u, ldu,u, ldu, cwork(n+1), & + call stdlib${ii}$_claset('G', n, n-nr, czero, czero, v(1_${ik}$,nr+1), ldv) + call stdlib${ii}$_cgesvd( 'O', 'N', n, n, v, ldv, s, u, ldu,u, ldu, cwork(n+1), & lcwork-n, rwork, info ) do p = 1, n v(p,p) = conjg(v(p,p)) @@ -69951,20 +69949,20 @@ module stdlib_linalg_lapack_c v(p,q) = ctmp end do end do - call stdlib_clapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_clapmt( .false., n, n, v, ldv, iwork ) end if else ! Aply Stdlib_Cgesvd To R ! Copy R Into V And Overwrite V With The Right Singular Vectors - call stdlib_clacpy( 'U', nr, n, a, lda, v, ldv ) - if ( nr > 1 )call stdlib_claset( 'L', nr-1, nr-1, czero, czero, v(2,1), ldv ) + call stdlib${ii}$_clacpy( 'U', nr, n, a, lda, v, ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_claset( 'L', nr-1, nr-1, czero, czero, v(2_${ik}$,1_${ik}$), ldv ) ! .. the right singular vectors overwrite v, the nr left singular ! vectors stored in u(1:nr,1:nr) if ( wntvr .or. ( nr == n ) ) then - call stdlib_cgesvd( 'N', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & + call stdlib${ii}$_cgesvd( 'N', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & lcwork-n, rwork, info ) - call stdlib_clapmt( .false., nr, n, v, ldv, iwork ) + call stdlib${ii}$_clapmt( .false., nr, n, v, ldv, iwork ) ! .. now [v](1:nr,1:n) contains v(1:n,1:nr)**h else ! .. need all n right singular vectors and nr < n @@ -69972,10 +69970,10 @@ module stdlib_linalg_lapack_c ! by padding a zero block. in the case nr << n, a more efficient ! way is to first use the lq factorization. for more details ! how to implement this, see the " full svd " branch. - call stdlib_claset('G', n-nr, n, czero,czero, v(nr+1,1), ldv) - call stdlib_cgesvd( 'N', 'O', n, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & + call stdlib${ii}$_claset('G', n-nr, n, czero,czero, v(nr+1,1_${ik}$), ldv) + call stdlib${ii}$_cgesvd( 'N', 'O', n, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & lcwork-n, rwork, info ) - call stdlib_clapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_clapmt( .false., n, n, v, ldv, iwork ) end if ! .. now [v] contains the adjoint of the matrix of the right singular ! vectors of a. @@ -69985,7 +69983,7 @@ module stdlib_linalg_lapack_c ! Full Svd Requested ! ....................................................................... if ( rtrans ) then - ! .. apply stdlib_cgesvd to r**h [[this option is left for r + ! .. apply stdlib${ii}$_cgesvd to r**h [[this option is left for r if ( wntvr .or. ( nr == n ) ) then ! .. copy r**h into [v] and overwrite [v] with the left singular ! vectors of r**h @@ -69994,12 +69992,12 @@ module stdlib_linalg_lapack_c v(q,p) = conjg(a(p,q)) end do end do - if ( nr > 1 )call stdlib_claset( 'U', nr-1,nr-1, czero,czero, v(1,2), ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_claset( 'U', nr-1,nr-1, czero,czero, v(1_${ik}$,2_${ik}$), ldv ) ! .. the left singular vectors of r**h overwrite [v], the nr right ! singular vectors of r**h stored in [u](1:nr,1:nr) as conjugate ! transposed - call stdlib_cgesvd( 'O', 'A', n, nr, v, ldv, s, v, ldv,u, ldu, cwork(n+1), & + call stdlib${ii}$_cgesvd( 'O', 'A', n, nr, v, ldv, s, v, ldv,u, ldu, cwork(n+1), & lcwork-n, rwork, info ) ! Assemble V do p = 1, nr @@ -70017,7 +70015,7 @@ module stdlib_linalg_lapack_c end do end do end if - call stdlib_clapmt( .false., nr, n, v, ldv, iwork ) + call stdlib${ii}$_clapmt( .false., nr, n, v, ldv, iwork ) do p = 1, nr u(p,p) = conjg(u(p,p)) do q = p + 1, nr @@ -70027,10 +70025,10 @@ module stdlib_linalg_lapack_c end do end do if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_claset('A', m-nr,nr, czero,czero, u(nr+1,1), ldu) + call stdlib${ii}$_claset('A', m-nr,nr, czero,czero, u(nr+1,1_${ik}$), ldu) if ( nr < n1 ) then - call stdlib_claset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) - call stdlib_claset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_claset('A',nr,n1-nr,czero,czero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_claset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) end if end if @@ -70041,19 +70039,19 @@ module stdlib_linalg_lapack_c ! [[the optimal ratio n/nr for using qrf instead of padding ! with zeros. here hard coded to 2; it must be at least ! two due to work space constraints.]] - ! optratio = stdlib_ilaenv(6, 'cgesvd', 's' // 'o', nr,n,0,0) + ! optratio = stdlib${ii}$_ilaenv(6, 'cgesvd', 's' // 'o', nr,n,0,0) ! optratio = max( optratio, 2 ) - optratio = 2 + optratio = 2_${ik}$ if ( optratio*nr > n ) then do p = 1, nr do q = p, n v(q,p) = conjg(a(p,q)) end do end do - if ( nr > 1 )call stdlib_claset('U',nr-1,nr-1, czero,czero, v(1,2),ldv) + if ( nr > 1_${ik}$ )call stdlib${ii}$_claset('U',nr-1,nr-1, czero,czero, v(1_${ik}$,2_${ik}$),ldv) - call stdlib_claset('A',n,n-nr,czero,czero,v(1,nr+1),ldv) - call stdlib_cgesvd( 'O', 'A', n, n, v, ldv, s, v, ldv,u, ldu, cwork(n+1), & + call stdlib${ii}$_claset('A',n,n-nr,czero,czero,v(1_${ik}$,nr+1),ldv) + call stdlib${ii}$_cgesvd( 'O', 'A', n, n, v, ldv, s, v, ldv,u, ldu, cwork(n+1), & lcwork-n, rwork, info ) do p = 1, n v(p,p) = conjg(v(p,p)) @@ -70063,7 +70061,7 @@ module stdlib_linalg_lapack_c v(p,q) = ctmp end do end do - call stdlib_clapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_clapmt( .false., n, n, v, ldv, iwork ) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x n1), i.e. (m x n) or (m x m). do p = 1, n @@ -70075,10 +70073,10 @@ module stdlib_linalg_lapack_c end do end do if ( ( n < m ) .and. .not.(wntuf)) then - call stdlib_claset('A',m-n,n,czero,czero,u(n+1,1),ldu) + call stdlib${ii}$_claset('A',m-n,n,czero,czero,u(n+1,1_${ik}$),ldu) if ( n < n1 ) then - call stdlib_claset('A',n,n1-n,czero,czero,u(1,n+1),ldu) - call stdlib_claset('A',m-n,n1-n,czero,cone,u(n+1,n+1), ldu ) + call stdlib${ii}$_claset('A',n,n1-n,czero,czero,u(1_${ik}$,n+1),ldu) + call stdlib${ii}$_claset('A',m-n,n1-n,czero,cone,u(n+1,n+1), ldu ) end if end if else @@ -70089,55 +70087,55 @@ module stdlib_linalg_lapack_c u(q,nr+p) = conjg(a(p,q)) end do end do - if ( nr > 1 )call stdlib_claset('U',nr-1,nr-1,czero,czero,u(1,nr+2),ldu) + if ( nr > 1_${ik}$ )call stdlib${ii}$_claset('U',nr-1,nr-1,czero,czero,u(1_${ik}$,nr+2),ldu) - call stdlib_cgeqrf( n, nr, u(1,nr+1), ldu, cwork(n+1),cwork(n+nr+1), & + call stdlib${ii}$_cgeqrf( n, nr, u(1_${ik}$,nr+1), ldu, cwork(n+1),cwork(n+nr+1), & lcwork-n-nr, ierr ) do p = 1, nr do q = 1, n v(q,p) = conjg(u(p,nr+q)) end do end do - if (nr>1) call stdlib_claset('U',nr-1,nr-1,czero,czero,v(1,2),ldv) - call stdlib_cgesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v,ldv, cwork(n+nr+& - 1),lcwork-n-nr,rwork, info ) - call stdlib_claset('A',n-nr,nr,czero,czero,v(nr+1,1),ldv) - call stdlib_claset('A',nr,n-nr,czero,czero,v(1,nr+1),ldv) - call stdlib_claset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) - call stdlib_cunmqr('R','C', n, n, nr, u(1,nr+1), ldu,cwork(n+1),v,ldv,& + if (nr>1_${ik}$) call stdlib${ii}$_claset('U',nr-1,nr-1,czero,czero,v(1_${ik}$,2_${ik}$),ldv) + call stdlib${ii}$_cgesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v,ldv, cwork(n+nr+& + 1_${ik}$),lcwork-n-nr,rwork, info ) + call stdlib${ii}$_claset('A',n-nr,nr,czero,czero,v(nr+1,1_${ik}$),ldv) + call stdlib${ii}$_claset('A',nr,n-nr,czero,czero,v(1_${ik}$,nr+1),ldv) + call stdlib${ii}$_claset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) + call stdlib${ii}$_cunmqr('R','C', n, n, nr, u(1_${ik}$,nr+1), ldu,cwork(n+1),v,ldv,& cwork(n+nr+1),lcwork-n-nr,ierr) - call stdlib_clapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_clapmt( .false., n, n, v, ldv, iwork ) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_claset('A',m-nr,nr,czero,czero,u(nr+1,1),ldu) + call stdlib${ii}$_claset('A',m-nr,nr,czero,czero,u(nr+1,1_${ik}$),ldu) if ( nr < n1 ) then - call stdlib_claset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) - call stdlib_claset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1),ldu) + call stdlib${ii}$_claset('A',nr,n1-nr,czero,czero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_claset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1),ldu) end if end if end if end if else - ! .. apply stdlib_cgesvd to r [[this is the recommended option]] + ! .. apply stdlib${ii}$_cgesvd to r [[this is the recommended option]] if ( wntvr .or. ( nr == n ) ) then ! .. copy r into [v] and overwrite v with the right singular vectors - call stdlib_clacpy( 'U', nr, n, a, lda, v, ldv ) - if ( nr > 1 )call stdlib_claset( 'L', nr-1,nr-1, czero,czero, v(2,1), ldv ) + call stdlib${ii}$_clacpy( 'U', nr, n, a, lda, v, ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_claset( 'L', nr-1,nr-1, czero,czero, v(2_${ik}$,1_${ik}$), ldv ) ! .. the right singular vectors of r overwrite [v], the nr left ! singular vectors of r stored in [u](1:nr,1:nr) - call stdlib_cgesvd( 'S', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & + call stdlib${ii}$_cgesvd( 'S', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & lcwork-n, rwork, info ) - call stdlib_clapmt( .false., nr, n, v, ldv, iwork ) + call stdlib${ii}$_clapmt( .false., nr, n, v, ldv, iwork ) ! .. now [v](1:nr,1:n) contains v(1:n,1:nr)**h ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_claset('A', m-nr,nr, czero,czero, u(nr+1,1), ldu) + call stdlib${ii}$_claset('A', m-nr,nr, czero,czero, u(nr+1,1_${ik}$), ldu) if ( nr < n1 ) then - call stdlib_claset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) - call stdlib_claset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_claset('A',nr,n1-nr,czero,czero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_claset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) end if end if @@ -70148,55 +70146,55 @@ module stdlib_linalg_lapack_c ! [[the optimal ratio n/nr for using lq instead of padding ! with zeros. here hard coded to 2; it must be at least ! two due to work space constraints.]] - ! optratio = stdlib_ilaenv(6, 'cgesvd', 's' // 'o', nr,n,0,0) + ! optratio = stdlib${ii}$_ilaenv(6, 'cgesvd', 's' // 'o', nr,n,0,0) ! optratio = max( optratio, 2 ) - optratio = 2 + optratio = 2_${ik}$ if ( optratio * nr > n ) then - call stdlib_clacpy( 'U', nr, n, a, lda, v, ldv ) - if ( nr > 1 )call stdlib_claset('L', nr-1,nr-1, czero,czero, v(2,1),ldv) + call stdlib${ii}$_clacpy( 'U', nr, n, a, lda, v, ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_claset('L', nr-1,nr-1, czero,czero, v(2_${ik}$,1_${ik}$),ldv) ! .. the right singular vectors of r overwrite [v], the nr left ! singular vectors of r stored in [u](1:nr,1:nr) - call stdlib_claset('A', n-nr,n, czero,czero, v(nr+1,1),ldv) - call stdlib_cgesvd( 'S', 'O', n, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & + call stdlib${ii}$_claset('A', n-nr,n, czero,czero, v(nr+1,1_${ik}$),ldv) + call stdlib${ii}$_cgesvd( 'S', 'O', n, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & lcwork-n, rwork, info ) - call stdlib_clapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_clapmt( .false., n, n, v, ldv, iwork ) ! .. now [v] contains the adjoint of the matrix of the right ! singular vectors of a. the leading n left singular vectors ! are in [u](1:n,1:n) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x n1), i.e. (m x n) or (m x m). if ( ( n < m ) .and. .not.(wntuf)) then - call stdlib_claset('A',m-n,n,czero,czero,u(n+1,1),ldu) + call stdlib${ii}$_claset('A',m-n,n,czero,czero,u(n+1,1_${ik}$),ldu) if ( n < n1 ) then - call stdlib_claset('A',n,n1-n,czero,czero,u(1,n+1),ldu) - call stdlib_claset( 'A',m-n,n1-n,czero,cone,u(n+1,n+1), ldu ) + call stdlib${ii}$_claset('A',n,n1-n,czero,czero,u(1_${ik}$,n+1),ldu) + call stdlib${ii}$_claset( 'A',m-n,n1-n,czero,cone,u(n+1,n+1), ldu ) end if end if else - call stdlib_clacpy( 'U', nr, n, a, lda, u(nr+1,1), ldu ) - if ( nr > 1 )call stdlib_claset('L',nr-1,nr-1,czero,czero,u(nr+2,1),ldu) + call stdlib${ii}$_clacpy( 'U', nr, n, a, lda, u(nr+1,1_${ik}$), ldu ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_claset('L',nr-1,nr-1,czero,czero,u(nr+2,1_${ik}$),ldu) - call stdlib_cgelqf( nr, n, u(nr+1,1), ldu, cwork(n+1),cwork(n+nr+1), & + call stdlib${ii}$_cgelqf( nr, n, u(nr+1,1_${ik}$), ldu, cwork(n+1),cwork(n+nr+1), & lcwork-n-nr, ierr ) - call stdlib_clacpy('L',nr,nr,u(nr+1,1),ldu,v,ldv) - if ( nr > 1 )call stdlib_claset('U',nr-1,nr-1,czero,czero,v(1,2),ldv) + call stdlib${ii}$_clacpy('L',nr,nr,u(nr+1,1_${ik}$),ldu,v,ldv) + if ( nr > 1_${ik}$ )call stdlib${ii}$_claset('U',nr-1,nr-1,czero,czero,v(1_${ik}$,2_${ik}$),ldv) - call stdlib_cgesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v, ldv, cwork(n+nr+& - 1), lcwork-n-nr, rwork, info ) - call stdlib_claset('A',n-nr,nr,czero,czero,v(nr+1,1),ldv) - call stdlib_claset('A',nr,n-nr,czero,czero,v(1,nr+1),ldv) - call stdlib_claset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) - call stdlib_cunmlq('R','N',n,n,nr,u(nr+1,1),ldu,cwork(n+1),v, ldv, cwork(n+& + call stdlib${ii}$_cgesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v, ldv, cwork(n+nr+& + 1_${ik}$), lcwork-n-nr, rwork, info ) + call stdlib${ii}$_claset('A',n-nr,nr,czero,czero,v(nr+1,1_${ik}$),ldv) + call stdlib${ii}$_claset('A',nr,n-nr,czero,czero,v(1_${ik}$,nr+1),ldv) + call stdlib${ii}$_claset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) + call stdlib${ii}$_cunmlq('R','N',n,n,nr,u(nr+1,1_${ik}$),ldu,cwork(n+1),v, ldv, cwork(n+& nr+1),lcwork-n-nr,ierr) - call stdlib_clapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_clapmt( .false., n, n, v, ldv, iwork ) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_claset('A',m-nr,nr,czero,czero,u(nr+1,1),ldu) + call stdlib${ii}$_claset('A',m-nr,nr,czero,czero,u(nr+1,1_${ik}$),ldu) if ( nr < n1 ) then - call stdlib_claset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) - call stdlib_claset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_claset('A',nr,n1-nr,czero,czero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_claset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) end if end if @@ -70206,10 +70204,10 @@ module stdlib_linalg_lapack_c end if ! the q matrix from the first qrf is built into the left singular ! vectors matrix u. - if ( .not. wntuf )call stdlib_cunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, & + if ( .not. wntuf )call stdlib${ii}$_cunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, & cwork(n+1), lcwork-n, ierr ) - if ( rowprm .and. .not.wntuf )call stdlib_claswp( n1, u, ldu, 1, m-1, iwork(n+1), -& - 1 ) + if ( rowprm .and. .not.wntuf )call stdlib${ii}$_claswp( n1, u, ldu, 1_${ik}$, m-1, iwork(n+1), -& + 1_${ik}$ ) ! ... end of the "full svd" branch end if ! check whether some singular values are returned as zeros, e.g. @@ -70217,27 +70215,27 @@ module stdlib_linalg_lapack_c p = nr do q = p, 1, -1 if ( s(q) > zero ) go to 4002 - nr = nr - 1 + nr = nr - 1_${ik}$ end do 4002 continue ! .. if numerical rank deficiency is detected, the truncated ! singular values are set to zero. - if ( nr < n ) call stdlib_slaset( 'G', n-nr,1, zero,zero, s(nr+1), n ) + if ( nr < n ) call stdlib${ii}$_slaset( 'G', n-nr,1_${ik}$, zero,zero, s(nr+1), n ) ! .. undo scaling; this may cause overflow in the largest singular ! values. - if ( ascaled )call stdlib_slascl( 'G',0,0, one,sqrt(real(m,KIND=sp)), nr,1, s, n, ierr & + if ( ascaled )call stdlib${ii}$_slascl( 'G',0_${ik}$,0_${ik}$, one,sqrt(real(m,KIND=sp)), nr,1_${ik}$, s, n, ierr & ) - if ( conda ) rwork(1) = sconda - rwork(2) = p - nr + if ( conda ) rwork(1_${ik}$) = sconda + rwork(2_${ik}$) = p - nr ! .. p-nr is the number of singular values that are computed as - ! exact zeros in stdlib_cgesvd() applied to the (possibly truncated) + ! exact zeros in stdlib${ii}$_cgesvd() applied to the (possibly truncated) ! full row rank triangular (trapezoidal) factor of a. numrank = nr return - end subroutine stdlib_cgesvdq + end subroutine stdlib${ii}$_cgesvdq - subroutine stdlib_cgesvx( fact, trans, n, nrhs, a, lda, af, ldaf, ipiv,equed, r, c, b, ldb, & + subroutine stdlib${ii}$_cgesvx( fact, trans, n, nrhs, a, lda, af, ldaf, ipiv,equed, r, c, b, ldb, & !! CGESVX uses the LU factorization to compute the solution to a complex !! system of linear equations !! A * X = B, @@ -70251,11 +70249,11 @@ module stdlib_linalg_lapack_c ! Scalar Arguments character, intent(inout) :: equed character, intent(in) :: fact, trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs real(sp), intent(out) :: rcond ! Array Arguments - integer(ilp), intent(inout) :: ipiv(*) + integer(${ik}$), intent(inout) :: ipiv(*) real(sp), intent(out) :: berr(*), ferr(*), rwork(*) real(sp), intent(inout) :: c(*), r(*) complex(sp), intent(inout) :: a(lda,*), af(ldaf,*), b(ldb,*) @@ -70265,12 +70263,12 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: colequ, equil, nofact, notran, rowequ character :: norm - integer(ilp) :: i, infequ, j + integer(${ik}$) :: i, infequ, j real(sp) :: amax, anorm, bignum, colcnd, rcmax, rcmin, rowcnd, rpvgrw, smlnum ! Intrinsic Functions intrinsic :: max,min ! Executable Statements - info = 0 + info = 0_${ik}$ nofact = stdlib_lsame( fact, 'N' ) equil = stdlib_lsame( fact, 'E' ) notran = stdlib_lsame( trans, 'N' ) @@ -70281,26 +70279,26 @@ module stdlib_linalg_lapack_c else rowequ = stdlib_lsame( equed, 'R' ) .or. stdlib_lsame( equed, 'B' ) colequ = stdlib_lsame( equed, 'C' ) .or. stdlib_lsame( equed, 'B' ) - smlnum = stdlib_slamch( 'SAFE MINIMUM' ) + smlnum = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) bignum = one / smlnum end if ! test the input parameters. if( .not.nofact .and. .not.equil .and. .not.stdlib_lsame( fact, 'F' ) )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 - else if( n<0 ) then - info = -3 - else if( nrhs<0 ) then - info = -4 - else if( lda0 ) then + info = -11_${ik}$ + else if( n>0_${ik}$ ) then rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) else rowcnd = one end if end if - if( colequ .and. info==0 ) then + if( colequ .and. info==0_${ik}$ ) then rcmin = bignum rcmax = zero do j = 1, n @@ -70325,31 +70323,31 @@ module stdlib_linalg_lapack_c rcmax = max( rcmax, c( j ) ) end do if( rcmin<=zero ) then - info = -12 - else if( n>0 ) then + info = -12_${ik}$ + else if( n>0_${ik}$ ) then colcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) else colcnd = one end if end if - if( info==0 ) then - if( ldb0 ) then + if( info>0_${ik}$ ) then ! compute the reciprocal pivot growth factor of the ! leading rank-deficient info columns of a. - rpvgrw = stdlib_clantr( 'M', 'U', 'N', info, info, af, ldaf,rwork ) + rpvgrw = stdlib${ii}$_clantr( 'M', 'U', 'N', info, info, af, ldaf,rwork ) if( rpvgrw==zero ) then rpvgrw = one else - rpvgrw = stdlib_clange( 'M', n, info, a, lda, rwork ) /rpvgrw + rpvgrw = stdlib${ii}$_clange( 'M', n, info, a, lda, rwork ) /rpvgrw end if - rwork( 1 ) = rpvgrw + rwork( 1_${ik}$ ) = rpvgrw rcond = zero return end if @@ -70396,21 +70394,21 @@ module stdlib_linalg_lapack_c else norm = 'I' end if - anorm = stdlib_clange( norm, n, n, a, lda, rwork ) - rpvgrw = stdlib_clantr( 'M', 'U', 'N', n, n, af, ldaf, rwork ) + anorm = stdlib${ii}$_clange( norm, n, n, a, lda, rwork ) + rpvgrw = stdlib${ii}$_clantr( 'M', 'U', 'N', n, n, af, ldaf, rwork ) if( rpvgrw==zero ) then rpvgrw = one else - rpvgrw = stdlib_clange( 'M', n, n, a, lda, rwork ) / rpvgrw + rpvgrw = stdlib${ii}$_clange( 'M', n, n, a, lda, rwork ) / rpvgrw end if ! compute the reciprocal of the condition number of a. - call stdlib_cgecon( norm, n, af, ldaf, anorm, rcond, work, rwork, info ) + call stdlib${ii}$_cgecon( norm, n, af, ldaf, anorm, rcond, work, rwork, info ) ! compute the solution matrix x. - call stdlib_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_cgetrs( trans, n, nrhs, af, ldaf, ipiv, x, ldx, info ) + call stdlib${ii}$_clacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_cgetrs( trans, n, nrhs, af, ldaf, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_cgerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & + call stdlib${ii}$_cgerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & work, rwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -70436,13 +70434,13 @@ module stdlib_linalg_lapack_c end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond=n ) then - call stdlib_cgeqr( m, n, a, lda, tq, -1, workq, -1, info2 ) - tszo = int( tq( 1 ),KIND=ilp) - lwo = int( workq( 1 ),KIND=ilp) - call stdlib_cgemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszo, b, ldb, workq, -1, & + call stdlib${ii}$_cgeqr( m, n, a, lda, tq, -1_${ik}$, workq, -1_${ik}$, info2 ) + tszo = int( tq( 1_${ik}$ ),KIND=${ik}$) + lwo = int( workq( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_cgemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszo, b, ldb, workq, -1_${ik}$, & info2 ) - lwo = max( lwo, int( workq( 1 ),KIND=ilp) ) - call stdlib_cgeqr( m, n, a, lda, tq, -2, workq, -2, info2 ) - tszm = int( tq( 1 ),KIND=ilp) - lwm = int( workq( 1 ),KIND=ilp) - call stdlib_cgemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszm, b, ldb, workq, -1, & + lwo = max( lwo, int( workq( 1_${ik}$ ),KIND=${ik}$) ) + call stdlib${ii}$_cgeqr( m, n, a, lda, tq, -2_${ik}$, workq, -2_${ik}$, info2 ) + tszm = int( tq( 1_${ik}$ ),KIND=${ik}$) + lwm = int( workq( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_cgemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszm, b, ldb, workq, -1_${ik}$, & info2 ) - lwm = max( lwm, int( workq( 1 ),KIND=ilp) ) + lwm = max( lwm, int( workq( 1_${ik}$ ),KIND=${ik}$) ) wsizeo = tszo + lwo wsizem = tszm + lwm else - call stdlib_cgelq( m, n, a, lda, tq, -1, workq, -1, info2 ) - tszo = int( tq( 1 ),KIND=ilp) - lwo = int( workq( 1 ),KIND=ilp) - call stdlib_cgemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszo, b, ldb, workq, -1, & + call stdlib${ii}$_cgelq( m, n, a, lda, tq, -1_${ik}$, workq, -1_${ik}$, info2 ) + tszo = int( tq( 1_${ik}$ ),KIND=${ik}$) + lwo = int( workq( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_cgemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszo, b, ldb, workq, -1_${ik}$, & info2 ) - lwo = max( lwo, int( workq( 1 ),KIND=ilp) ) - call stdlib_cgelq( m, n, a, lda, tq, -2, workq, -2, info2 ) - tszm = int( tq( 1 ),KIND=ilp) - lwm = int( workq( 1 ),KIND=ilp) - call stdlib_cgemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszm, b, ldb, workq, -1, & + lwo = max( lwo, int( workq( 1_${ik}$ ),KIND=${ik}$) ) + call stdlib${ii}$_cgelq( m, n, a, lda, tq, -2_${ik}$, workq, -2_${ik}$, info2 ) + tszm = int( tq( 1_${ik}$ ),KIND=${ik}$) + lwm = int( workq( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_cgemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszm, b, ldb, workq, -1_${ik}$, & info2 ) - lwm = max( lwm, int( workq( 1 ),KIND=ilp) ) + lwm = max( lwm, int( workq( 1_${ik}$ ),KIND=${ik}$) ) wsizeo = tszo + lwo wsizem = tszm + lwm end if if( ( lworkzero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_clascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_claset( 'F', maxmn, nrhs, czero, czero, b, ldb ) + call stdlib${ii}$_claset( 'F', maxmn, nrhs, czero, czero, b, ldb ) go to 50 end if brow = m if ( tran ) then brow = n end if - bnrm = stdlib_clange( 'M', brow, nrhs, b, ldb, dum ) - ibscl = 0 + bnrm = stdlib${ii}$_clange( 'M', brow, nrhs, b, ldb, dum ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_clascl( 'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,info ) - ibscl = 2 + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, brow, nrhs, b, ldb,info ) + ibscl = 2_${ik}$ end if if ( m>=n ) then ! compute qr factorization of a - call stdlib_cgeqr( m, n, a, lda, work( lw2+1 ), lw1,work( 1 ), lw2, info ) + call stdlib${ii}$_cgeqr( m, n, a, lda, work( lw2+1 ), lw1,work( 1_${ik}$ ), lw2, info ) if ( .not.tran ) then ! least-squares problem min || a * x - b || ! b(1:m,1:nrhs) := q**t * b(1:m,1:nrhs) - call stdlib_cgemqr( 'L' , 'C', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, work(& - 1 ), lw2,info ) + call stdlib${ii}$_cgemqr( 'L' , 'C', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, work(& + 1_${ik}$ ), lw2,info ) ! b(1:n,1:nrhs) := inv(r) * b(1:n,1:nrhs) - call stdlib_ctrtrs( 'U', 'N', 'N', n, nrhs,a, lda, b, ldb, info ) - if( info>0 ) then + call stdlib${ii}$_ctrtrs( 'U', 'N', 'N', n, nrhs,a, lda, b, ldb, info ) + if( info>0_${ik}$ ) then return end if scllen = n else ! overdetermined system of equations a**t * x = b ! b(1:n,1:nrhs) := inv(r**t) * b(1:n,1:nrhs) - call stdlib_ctrtrs( 'U', 'C', 'N', n, nrhs,a, lda, b, ldb, info ) - if( info>0 ) then + call stdlib${ii}$_ctrtrs( 'U', 'C', 'N', n, nrhs,a, lda, b, ldb, info ) + if( info>0_${ik}$ ) then return end if ! b(n+1:m,1:nrhs) = czero @@ -70622,19 +70620,19 @@ module stdlib_linalg_lapack_c end do end do ! b(1:m,1:nrhs) := q(1:n,:) * b(1:n,1:nrhs) - call stdlib_cgemqr( 'L', 'N', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, & - work( 1 ), lw2,info ) + call stdlib${ii}$_cgemqr( 'L', 'N', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, & + work( 1_${ik}$ ), lw2,info ) scllen = m end if else ! compute lq factorization of a - call stdlib_cgelq( m, n, a, lda, work( lw2+1 ), lw1,work( 1 ), lw2, info ) + call stdlib${ii}$_cgelq( m, n, a, lda, work( lw2+1 ), lw1,work( 1_${ik}$ ), lw2, info ) ! workspace at least m, optimally m*nb. if( .not.tran ) then ! underdetermined system of equations a * x = b ! b(1:m,1:nrhs) := inv(l) * b(1:m,1:nrhs) - call stdlib_ctrtrs( 'L', 'N', 'N', m, nrhs,a, lda, b, ldb, info ) - if( info>0 ) then + call stdlib${ii}$_ctrtrs( 'L', 'N', 'N', m, nrhs,a, lda, b, ldb, info ) + if( info>0_${ik}$ ) then return end if ! b(m+1:n,1:nrhs) = 0 @@ -70644,42 +70642,42 @@ module stdlib_linalg_lapack_c end do end do ! b(1:n,1:nrhs) := q(1:n,:)**t * b(1:m,1:nrhs) - call stdlib_cgemlq( 'L', 'C', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & - work( 1 ), lw2,info ) + call stdlib${ii}$_cgemlq( 'L', 'C', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & + work( 1_${ik}$ ), lw2,info ) ! workspace at least nrhs, optimally nrhs*nb scllen = n else ! overdetermined system min || a**t * x - b || ! b(1:n,1:nrhs) := q * b(1:n,1:nrhs) - call stdlib_cgemlq( 'L', 'N', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & - work( 1 ), lw2,info ) + call stdlib${ii}$_cgemlq( 'L', 'N', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & + work( 1_${ik}$ ), lw2,info ) ! workspace at least nrhs, optimally nrhs*nb ! b(1:m,1:nrhs) := inv(l**t) * b(1:m,1:nrhs) - call stdlib_ctrtrs( 'L', 'C', 'N', m, nrhs,a, lda, b, ldb, info ) - if( info>0 ) then + call stdlib${ii}$_ctrtrs( 'L', 'C', 'N', m, nrhs,a, lda, b, ldb, info ) + if( info>0_${ik}$ ) then return end if scllen = m end if end if ! undo scaling - if( iascl==1 ) then - call stdlib_clascl( 'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,info ) - else if( iascl==2 ) then - call stdlib_clascl( 'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,info ) + if( iascl==1_${ik}$ ) then + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, smlnum, scllen, nrhs, b, ldb,info ) + else if( iascl==2_${ik}$ ) then + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, scllen, nrhs, b, ldb,info ) end if - if( ibscl==1 ) then - call stdlib_clascl( 'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,info ) - else if( ibscl==2 ) then - call stdlib_clascl( 'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,info ) + if( ibscl==1_${ik}$ ) then + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, bnrm, scllen, nrhs, b, ldb,info ) + else if( ibscl==2_${ik}$ ) then + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bignum, bnrm, scllen, nrhs, b, ldb,info ) end if 50 continue - work( 1 ) = real( tszo + lwo,KIND=sp) + work( 1_${ik}$ ) = real( tszo + lwo,KIND=sp) return - end subroutine stdlib_cgetsls + end subroutine stdlib${ii}$_cgetsls - pure subroutine stdlib_cgetsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) + pure subroutine stdlib${ii}$_cgetsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) !! CGETSQRHRT computes a NB2-sized column blocked QR-factorization !! of a complex M-by-N matrix A with M >= N, !! A = Q * R. @@ -70697,8 +70695,8 @@ module stdlib_linalg_lapack_c ! -- 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, nb1, nb2, mb1 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldt, lwork, m, n, nb1, nb2, mb1 ! Array Arguments complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: t(ldt,*), work(*) @@ -70706,41 +70704,41 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, iinfo, j, lw1, lw2, lwt, ldwt, lworkopt, nb1local, nb2local, & + integer(${ik}$) :: i, iinfo, j, lw1, lw2, lwt, ldwt, lworkopt, nb1local, nb2local, & num_all_row_blocks ! Intrinsic Functions intrinsic :: ceiling,real,cmplx,max,min ! Executable Statements ! test the input arguments - info = 0 - lquery = lwork==-1 - if( m<0 ) then - info = -1 - else if( n<0 .or. mzero .and. anrmzero .and. bnrm1 ) then - call stdlib_clacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& + call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vsl, ldvsl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_clacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& , ldvsl ) end if - call stdlib_cungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & + call stdlib${ii}$_cungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vsr - if( ilvsr )call stdlib_claset( 'FULL', n, n, czero, cone, vsr, ldvsr ) + if( ilvsr )call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vsr, ldvsr ) ! reduce to generalized hessenberg form ! (workspace: none needed) - call stdlib_cgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& + call stdlib${ii}$_cgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& ierr ) - sdim = 0 + sdim = 0_${ik}$ ! perform qz algorithm, computing schur vectors if desired ! (complex workspace: need n) ! (real workspace: need n) iwrk = itau - call stdlib_chgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, & + call stdlib${ii}$_chgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, & ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 30 end if @@ -71019,52 +71017,52 @@ module stdlib_linalg_lapack_c ! (workspace: none needed) if( wantst ) then ! undo scaling on eigenvalues before selecting - if( ilascl )call stdlib_clascl( 'G', 0, 0, anrm, anrmto, n, 1, alpha, n, ierr ) + if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, 1_${ik}$, alpha, n, ierr ) - if( ilbscl )call stdlib_clascl( 'G', 0, 0, bnrm, bnrmto, n, 1, beta, n, ierr ) + if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, 1_${ik}$, beta, n, ierr ) ! select eigenvalues do i = 1, n bwork( i ) = selctg( alpha( i ), beta( i ) ) end do - call stdlib_ctgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,beta, vsl, & - ldvsl, vsr, ldvsr, sdim, pvsl, pvsr,dif, work( iwrk ), lwork-iwrk+1, idum, 1, ierr ) + call stdlib${ii}$_ctgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,beta, vsl, & + ldvsl, vsr, ldvsr, sdim, pvsl, pvsr,dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$, ierr ) - if( ierr==1 )info = n + 3 + if( ierr==1_${ik}$ )info = n + 3_${ik}$ end if ! apply back-permutation to vsl and vsr ! (workspace: none needed) - if( ilvsl )call stdlib_cggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), & + if( ilvsl )call stdlib${ii}$_cggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), & n, vsl, ldvsl, ierr ) - if( ilvsr )call stdlib_cggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), & + if( ilvsr )call stdlib${ii}$_cggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), & n, vsr, ldvsr, ierr ) ! undo scaling if( ilascl ) then - call stdlib_clascl( 'U', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) - call stdlib_clascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) + call stdlib${ii}$_clascl( 'U', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr ) end if if( ilbscl ) then - call stdlib_clascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) - call stdlib_clascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + call stdlib${ii}$_clascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) end if if( wantst ) then ! check if reordering is correct lastsl = .true. - sdim = 0 + sdim = 0_${ik}$ do i = 1, n cursl = selctg( alpha( i ), beta( i ) ) - if( cursl )sdim = sdim + 1 - if( cursl .and. .not.lastsl )info = n + 2 + if( cursl )sdim = sdim + 1_${ik}$ + if( cursl .and. .not.lastsl )info = n + 2_${ik}$ lastsl = cursl end do end if 30 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_cgges + end subroutine stdlib${ii}$_cgges - subroutine stdlib_cggesx( jobvsl, jobvsr, sort, selctg, sense, n, a, lda,b, ldb, sdim, alpha,& + subroutine stdlib${ii}$_cggesx( jobvsl, jobvsr, sort, selctg, sense, n, a, lda,b, ldb, sdim, alpha,& !! CGGESX computes for a pair of N-by-N complex nonsymmetric matrices !! (A,B), the generalized eigenvalues, the complex Schur form (S,T), !! and, optionally, the left and/or right matrices of Schur vectors (VSL @@ -71094,12 +71092,12 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvsl, jobvsr, sense, sort - integer(ilp), intent(out) :: info, sdim - integer(ilp), intent(in) :: lda, ldb, ldvsl, ldvsr, liwork, lwork, n + integer(${ik}$), intent(out) :: info, sdim + integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, liwork, lwork, n ! Array Arguments logical(lk), intent(out) :: bwork(*) - integer(ilp), intent(out) :: iwork(*) - real(sp), intent(out) :: rconde(2), rcondv(2), rwork(*) + integer(${ik}$), intent(out) :: iwork(*) + real(sp), intent(out) :: rconde(2_${ik}$), rcondv(2_${ik}$), rwork(*) complex(sp), intent(inout) :: a(lda,*), b(ldb,*) complex(sp), intent(out) :: alpha(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), work(*) @@ -71111,33 +71109,33 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, wantsb, wantse, & wantsn, wantst, wantsv - integer(ilp) :: i, icols, ierr, ihi, ijob, ijobvl, ijobvr, ileft, ilo, iright, irows, & + integer(${ik}$) :: i, icols, ierr, ihi, ijob, ijobvl, ijobvr, ileft, ilo, iright, irows, & irwrk, itau, iwrk, liwmin, lwrk, maxwrk, minwrk real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pl, pr, smlnum ! Local Arrays - real(sp) :: dif(2) + real(sp) :: dif(2_${ik}$) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvsl, 'N' ) ) then - ijobvl = 1 + ijobvl = 1_${ik}$ ilvsl = .false. else if( stdlib_lsame( jobvsl, 'V' ) ) then - ijobvl = 2 + ijobvl = 2_${ik}$ ilvsl = .true. else - ijobvl = -1 + ijobvl = -1_${ik}$ ilvsl = .false. end if if( stdlib_lsame( jobvsr, 'N' ) ) then - ijobvr = 1 + ijobvr = 1_${ik}$ ilvsr = .false. else if( stdlib_lsame( jobvsr, 'V' ) ) then - ijobvr = 2 + ijobvr = 2_${ik}$ ilvsr = .true. else - ijobvr = -1 + ijobvr = -1_${ik}$ ilvsr = .false. end if wantst = stdlib_lsame( sort, 'S' ) @@ -71145,94 +71143,94 @@ module stdlib_linalg_lapack_c wantse = stdlib_lsame( sense, 'E' ) wantsv = stdlib_lsame( sense, 'V' ) wantsb = stdlib_lsame( sense, 'B' ) - lquery = ( lwork==-1 .or. liwork==-1 ) + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) if( wantsn ) then - ijob = 0 + ijob = 0_${ik}$ else if( wantse ) then - ijob = 1 + ijob = 1_${ik}$ else if( wantsv ) then - ijob = 2 + ijob = 2_${ik}$ else if( wantsb ) then - ijob = 4 + ijob = 4_${ik}$ end if ! test the input arguments - info = 0 - if( ijobvl<=0 ) then - info = -1 - else if( ijobvr<=0 ) then - info = -2 + info = 0_${ik}$ + if( ijobvl<=0_${ik}$ ) then + info = -1_${ik}$ + else if( ijobvr<=0_${ik}$ ) then + info = -2_${ik}$ else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then - info = -3 + info = -3_${ik}$ else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. & .not.wantsn ) ) then - info = -5 - else if( n<0 ) then - info = -6 - else if( lda0) then - minwrk = 2*n - maxwrk = n*(1 + stdlib_ilaenv( 1, 'CGEQRF', ' ', n, 1, n, 0 ) ) - maxwrk = max( maxwrk, n*( 1 +stdlib_ilaenv( 1, 'CUNMQR', ' ', n, 1, n, -1 ) ) ) + ! following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + if( n>0_${ik}$) then + minwrk = 2_${ik}$*n + maxwrk = n*(1_${ik}$ + stdlib${ii}$_ilaenv( 1_${ik}$, 'CGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) ) + maxwrk = max( maxwrk, n*( 1_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNMQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) ) ) if( ilvsl ) then - maxwrk = max( maxwrk, n*( 1 +stdlib_ilaenv( 1, 'CUNGQR', ' ', n, 1, n, -1 ) ) & + maxwrk = max( maxwrk, n*( 1_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'CUNGQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) ) & ) end if lwrk = maxwrk - if( ijob>=1 )lwrk = max( lwrk, n*n/2 ) + if( ijob>=1_${ik}$ )lwrk = max( lwrk, n*n/2_${ik}$ ) else - minwrk = 1 - maxwrk = 1 - lwrk = 1 + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + lwrk = 1_${ik}$ end if - work( 1 ) = lwrk - if( wantsn .or. n==0 ) then - liwmin = 1 + work( 1_${ik}$ ) = lwrk + if( wantsn .or. n==0_${ik}$ ) then + liwmin = 1_${ik}$ else - liwmin = n + 2 + liwmin = n + 2_${ik}$ end if - iwork( 1 ) = liwmin + iwork( 1_${ik}$ ) = liwmin if( lworkzero .and. anrmzero .and. bnrm1 ) then - call stdlib_clacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& + call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vsl, ldvsl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_clacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& , ldvsl ) end if - call stdlib_cungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & + call stdlib${ii}$_cungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vsr - if( ilvsr )call stdlib_claset( 'FULL', n, n, czero, cone, vsr, ldvsr ) + if( ilvsr )call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vsr, ldvsr ) ! reduce to generalized hessenberg form ! (workspace: none needed) - call stdlib_cgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& + call stdlib${ii}$_cgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& ierr ) - sdim = 0 + sdim = 0_${ik}$ ! perform qz algorithm, computing schur vectors if desired ! (complex workspace: need n) ! (real workspace: need n) iwrk = itau - call stdlib_chgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, & + call stdlib${ii}$_chgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, & ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 40 end if @@ -71310,9 +71308,9 @@ module stdlib_linalg_lapack_c ! condition number(s) if( wantst ) then ! undo scaling on eigenvalues before selctging - if( ilascl )call stdlib_clascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) + if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr ) - if( ilbscl )call stdlib_clascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) ! select eigenvalues do i = 1, n @@ -71322,59 +71320,59 @@ module stdlib_linalg_lapack_c ! compute reciprocal condition numbers ! (complex workspace: if ijob >= 1, need max(1, 2*sdim*(n-sdim)) ! otherwise, need 1 ) - call stdlib_ctgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alpha, beta, vsl, & + call stdlib${ii}$_ctgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alpha, beta, vsl, & ldvsl, vsr, ldvsr, sdim, pl, pr,dif, work( iwrk ), lwork-iwrk+1, iwork, liwork,ierr & ) - if( ijob>=1 )maxwrk = max( maxwrk, 2*sdim*( n-sdim ) ) - if( ierr==-21 ) then + if( ijob>=1_${ik}$ )maxwrk = max( maxwrk, 2_${ik}$*sdim*( n-sdim ) ) + if( ierr==-21_${ik}$ ) then ! not enough complex workspace - info = -21 + info = -21_${ik}$ else - if( ijob==1 .or. ijob==4 ) then - rconde( 1 ) = pl - rconde( 2 ) = pr + if( ijob==1_${ik}$ .or. ijob==4_${ik}$ ) then + rconde( 1_${ik}$ ) = pl + rconde( 2_${ik}$ ) = pr end if - if( ijob==2 .or. ijob==4 ) then - rcondv( 1 ) = dif( 1 ) - rcondv( 2 ) = dif( 2 ) + if( ijob==2_${ik}$ .or. ijob==4_${ik}$ ) then + rcondv( 1_${ik}$ ) = dif( 1_${ik}$ ) + rcondv( 2_${ik}$ ) = dif( 2_${ik}$ ) end if - if( ierr==1 )info = n + 3 + if( ierr==1_${ik}$ )info = n + 3_${ik}$ end if end if ! apply permutation to vsl and vsr ! (workspace: none needed) - if( ilvsl )call stdlib_cggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), & + if( ilvsl )call stdlib${ii}$_cggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), & n, vsl, ldvsl, ierr ) - if( ilvsr )call stdlib_cggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), & + if( ilvsr )call stdlib${ii}$_cggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), & n, vsr, ldvsr, ierr ) ! undo scaling if( ilascl ) then - call stdlib_clascl( 'U', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) - call stdlib_clascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) + call stdlib${ii}$_clascl( 'U', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr ) end if if( ilbscl ) then - call stdlib_clascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) - call stdlib_clascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + call stdlib${ii}$_clascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) end if if( wantst ) then ! check if reordering is correct lastsl = .true. - sdim = 0 + sdim = 0_${ik}$ do i = 1, n cursl = selctg( alpha( i ), beta( i ) ) - if( cursl )sdim = sdim + 1 - if( cursl .and. .not.lastsl )info = n + 2 + if( cursl )sdim = sdim + 1_${ik}$ + if( cursl .and. .not.lastsl )info = n + 2_${ik}$ lastsl = cursl end do end if 40 continue - work( 1 ) = maxwrk - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = maxwrk + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_cggesx + end subroutine stdlib${ii}$_cggesx - subroutine stdlib_cggev( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, & + subroutine stdlib${ii}$_cggev( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, & !! CGGEV computes for a pair of N-by-N complex nonsymmetric matrices !! (A,B), the generalized eigenvalues, and optionally, the left and/or !! right generalized eigenvectors. @@ -71396,8 +71394,8 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvl, jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n ! Array Arguments real(sp), intent(out) :: rwork(*) complex(sp), intent(inout) :: a(lda,*), b(ldb,*) @@ -71408,12 +71406,12 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery character :: chtemp - integer(ilp) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,& + integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,& itau, iwrk, jc, jr, lwkmin, lwkopt real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp complex(sp) :: x ! Local Arrays - logical(lk) :: ldumma(1) + logical(lk) :: ldumma(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,aimag,max,real,sqrt ! Statement Functions @@ -71423,64 +71421,64 @@ module stdlib_linalg_lapack_c ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvl, 'N' ) ) then - ijobvl = 1 + ijobvl = 1_${ik}$ ilvl = .false. else if( stdlib_lsame( jobvl, 'V' ) ) then - ijobvl = 2 + ijobvl = 2_${ik}$ ilvl = .true. else - ijobvl = -1 + ijobvl = -1_${ik}$ ilvl = .false. end if if( stdlib_lsame( jobvr, 'N' ) ) then - ijobvr = 1 + ijobvr = 1_${ik}$ ilvr = .false. else if( stdlib_lsame( jobvr, 'V' ) ) then - ijobvr = 2 + ijobvr = 2_${ik}$ ilvr = .true. else - ijobvr = -1 + ijobvr = -1_${ik}$ ilvr = .false. end if ilv = ilvl .or. ilvr ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( ijobvl<=0 ) then - info = -1 - else if( ijobvr<=0 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldazero .and. anrmzero .and. bnrm1 ) then - call stdlib_clacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& + call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vl, ldvl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_clacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& ldvl ) end if - call stdlib_cungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & + call stdlib${ii}$_cungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vr - if( ilvr )call stdlib_claset( 'FULL', n, n, czero, cone, vr, ldvr ) + if( ilvr )call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vr, ldvr ) ! reduce to generalized hessenberg form if( ilv ) then ! eigenvectors requested -- work on whole matrix. - call stdlib_cgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib${ii}$_cgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & ierr ) else - call stdlib_cgghrd( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & + call stdlib${ii}$_cgghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & ldb, vl, ldvl, vr, ldvr, ierr ) end if ! perform qz algorithm (compute eigenvalues, and optionally, the @@ -71571,15 +71569,15 @@ module stdlib_linalg_lapack_c else chtemp = 'E' end if - call stdlib_chgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, & + call stdlib${ii}$_chgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, & ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 70 end if @@ -71596,16 +71594,16 @@ module stdlib_linalg_lapack_c else chtemp = 'R' end if - call stdlib_ctgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & + call stdlib${ii}$_ctgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & in, work( iwrk ), rwork( irwrk ),ierr ) - if( ierr/=0 ) then - info = n + 2 + if( ierr/=0_${ik}$ ) then + info = n + 2_${ik}$ go to 70 end if ! undo balancing on vl and vr and normalization ! (workspace: none needed) if( ilvl ) then - call stdlib_cggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,& + call stdlib${ii}$_cggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,& ldvl, ierr ) loop_30: do jc = 1, n temp = zero @@ -71620,7 +71618,7 @@ module stdlib_linalg_lapack_c end do loop_30 end if if( ilvr ) then - call stdlib_cggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,& + call stdlib${ii}$_cggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,& ldvr, ierr ) loop_60: do jc = 1, n temp = zero @@ -71637,14 +71635,14 @@ module stdlib_linalg_lapack_c end if ! undo scaling if necessary 70 continue - if( ilascl )call stdlib_clascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) - if( ilbscl )call stdlib_clascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) - work( 1 ) = lwkopt + if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr ) + if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_cggev + end subroutine stdlib${ii}$_cggev - subroutine stdlib_cggevx( balanc, jobvl, jobvr, sense, n, a, lda, b, ldb,alpha, beta, vl, & + subroutine stdlib${ii}$_cggevx( balanc, jobvl, jobvr, sense, n, a, lda, b, ldb,alpha, beta, vl, & !! CGGEVX computes for a pair of N-by-N complex nonsymmetric matrices !! (A,B) the generalized eigenvalues, and optionally, the left and/or !! right generalized eigenvectors. @@ -71672,12 +71670,12 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: balanc, jobvl, jobvr, sense - integer(ilp), intent(out) :: ihi, ilo, info - integer(ilp), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: ihi, ilo, info + integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n real(sp), intent(out) :: abnrm, bbnrm ! Array Arguments logical(lk), intent(out) :: bwork(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(out) :: lscale(*), rconde(*), rcondv(*), rscale(*), rwork(*) complex(sp), intent(inout) :: a(lda,*), b(ldb,*) complex(sp), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*) @@ -71688,12 +71686,12 @@ module stdlib_linalg_lapack_c logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery, noscl, wantsb, wantse, wantsn, & wantsv character :: chtemp - integer(ilp) :: i, icols, ierr, ijobvl, ijobvr, in, irows, itau, iwrk, iwrk1, j, jc, & + integer(${ik}$) :: i, icols, ierr, ijobvl, ijobvr, in, irows, itau, iwrk, iwrk1, j, jc, & jr, m, maxwrk, minwrk real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp complex(sp) :: x ! Local Arrays - logical(lk) :: ldumma(1) + logical(lk) :: ldumma(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,aimag,max,real,sqrt ! Statement Functions @@ -71703,23 +71701,23 @@ module stdlib_linalg_lapack_c ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvl, 'N' ) ) then - ijobvl = 1 + ijobvl = 1_${ik}$ ilvl = .false. else if( stdlib_lsame( jobvl, 'V' ) ) then - ijobvl = 2 + ijobvl = 2_${ik}$ ilvl = .true. else - ijobvl = -1 + ijobvl = -1_${ik}$ ilvl = .false. end if if( stdlib_lsame( jobvr, 'N' ) ) then - ijobvr = 1 + ijobvr = 1_${ik}$ ilvr = .false. else if( stdlib_lsame( jobvr, 'V' ) ) then - ijobvr = 2 + ijobvr = 2_${ik}$ ilvr = .true. else - ijobvr = -1 + ijobvr = -1_${ik}$ ilvr = .false. end if ilv = ilvl .or. ilvr @@ -71729,63 +71727,63 @@ module stdlib_linalg_lapack_c wantsv = stdlib_lsame( sense, 'V' ) wantsb = stdlib_lsame( sense, 'B' ) ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) if( .not.( noscl .or. stdlib_lsame( balanc,'S' ) .or.stdlib_lsame( balanc, 'B' ) ) ) & then - info = -1 - else if( ijobvl<=0 ) then - info = -2 - else if( ijobvr<=0 ) then - info = -3 + info = -1_${ik}$ + else if( ijobvl<=0_${ik}$ ) then + info = -2_${ik}$ + else if( ijobvr<=0_${ik}$ ) then + info = -3_${ik}$ else if( .not.( wantsn .or. wantse .or. wantsb .or. wantsv ) )then - info = -4 - else if( n<0 ) then - info = -5 - else if( ldazero .and. anrmzero .and. bnrm1 ) then - call stdlib_clacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& + call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vl, ldvl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_clacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& ldvl ) end if - call stdlib_cungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & + call stdlib${ii}$_cungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if - if( ilvr )call stdlib_claset( 'FULL', n, n, czero, cone, vr, ldvr ) + if( ilvr )call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vr, ldvr ) ! reduce to generalized hessenberg form ! (workspace: none needed) if( ilv .or. .not.wantsn ) then ! eigenvectors requested -- work on whole matrix. - call stdlib_cgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib${ii}$_cgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & ierr ) else - call stdlib_cgghrd( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & + call stdlib${ii}$_cgghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & ldb, vl, ldvl, vr, ldvr, ierr ) end if ! perform qz algorithm (compute eigenvalues, and optionally, the @@ -71886,22 +71884,22 @@ module stdlib_linalg_lapack_c else chtemp = 'E' end if - call stdlib_chgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, & + call stdlib${ii}$_chgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, & ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 90 end if ! compute eigenvectors and estimate condition numbers if desired - ! stdlib_ctgevc: (complex workspace: need 2*n ) + ! stdlib${ii}$_ctgevc: (complex workspace: need 2*n ) ! (real workspace: need 2*n ) - ! stdlib_ctgsna: (complex workspace: need 2*n*n if sense='v' or 'b') + ! stdlib${ii}$_ctgsna: (complex workspace: need 2*n*n if sense='v' or 'b') ! (integer workspace: need n+2 ) if( ilv .or. .not.wantsn ) then if( ilv ) then @@ -71914,16 +71912,16 @@ module stdlib_linalg_lapack_c else chtemp = 'R' end if - call stdlib_ctgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,& + call stdlib${ii}$_ctgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,& in, work( iwrk ), rwork,ierr ) - if( ierr/=0 ) then - info = n + 2 + if( ierr/=0_${ik}$ ) then + info = n + 2_${ik}$ go to 90 end if end if if( .not.wantsn ) then - ! compute eigenvectors (stdlib_ctgevc) and estimate condition - ! numbers (stdlib_ctgsna). note that the definition of the condition + ! compute eigenvectors (stdlib${ii}$_ctgevc) and estimate condition + ! numbers (stdlib${ii}$_ctgsna). note that the definition of the condition ! number is not invariant under transformation (u,v) to ! (q*u, z*v), where (u,v) are eigenvectors of the generalized ! schur form (s,t), q and z are orthogonal matrices. in order @@ -71935,18 +71933,18 @@ module stdlib_linalg_lapack_c bwork( j ) = .false. end do bwork( i ) = .true. - iwrk = n + 1 + iwrk = n + 1_${ik}$ iwrk1 = iwrk + n if( wantse .or. wantsb ) then - call stdlib_ctgevc( 'B', 'S', bwork, n, a, lda, b, ldb,work( 1 ), n, work( & - iwrk ), n, 1, m,work( iwrk1 ), rwork, ierr ) - if( ierr/=0 ) then - info = n + 2 + call stdlib${ii}$_ctgevc( 'B', 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( & + iwrk ), n, 1_${ik}$, m,work( iwrk1 ), rwork, ierr ) + if( ierr/=0_${ik}$ ) then + info = n + 2_${ik}$ go to 90 end if end if - call stdlib_ctgsna( sense, 'S', bwork, n, a, lda, b, ldb,work( 1 ), n, work( & - iwrk ), n, rconde( i ),rcondv( i ), 1, m, work( iwrk1 ),lwork-iwrk1+1, iwork, & + call stdlib${ii}$_ctgsna( sense, 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( & + iwrk ), n, rconde( i ),rcondv( i ), 1_${ik}$, m, work( iwrk1 ),lwork-iwrk1+1, iwork, & ierr ) end do end if @@ -71954,7 +71952,7 @@ module stdlib_linalg_lapack_c ! undo balancing on vl and vr and normalization ! (workspace: none needed) if( ilvl ) then - call stdlib_cggbak( balanc, 'L', n, ilo, ihi, lscale, rscale, n, vl,ldvl, ierr ) + call stdlib${ii}$_cggbak( balanc, 'L', n, ilo, ihi, lscale, rscale, n, vl,ldvl, ierr ) loop_50: do jc = 1, n temp = zero @@ -71969,7 +71967,7 @@ module stdlib_linalg_lapack_c end do loop_50 end if if( ilvr ) then - call stdlib_cggbak( balanc, 'R', n, ilo, ihi, lscale, rscale, n, vr,ldvr, ierr ) + call stdlib${ii}$_cggbak( balanc, 'R', n, ilo, ihi, lscale, rscale, n, vr,ldvr, ierr ) loop_80: do jc = 1, n temp = zero @@ -71985,14 +71983,14 @@ module stdlib_linalg_lapack_c end if ! undo scaling if necessary 90 continue - if( ilascl )call stdlib_clascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) - if( ilbscl )call stdlib_clascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) - work( 1 ) = maxwrk + if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr ) + if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_cggevx + end subroutine stdlib${ii}$_cggevx - subroutine stdlib_chbev( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,rwork, info ) + subroutine stdlib${ii}$_chbev( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,rwork, info ) !! CHBEV computes all the eigenvalues and, optionally, eigenvectors of !! a complex Hermitian band matrix A. ! -- lapack driver routine -- @@ -72000,8 +71998,8 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kd, ldab, ldz, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kd, ldab, ldz, n ! Array Arguments real(sp), intent(out) :: rwork(*), w(*) complex(sp), intent(inout) :: ab(ldab,*) @@ -72010,7 +72008,7 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: lower, wantz - integer(ilp) :: iinfo, imax, inde, indrwk, iscale + integer(${ik}$) :: iinfo, imax, inde, indrwk, iscale real(sp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! Intrinsic Functions intrinsic :: sqrt @@ -72018,85 +72016,85 @@ module stdlib_linalg_lapack_c ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) lower = stdlib_lsame( uplo, 'L' ) - info = 0 + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) 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( ldabzero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then - call stdlib_clascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_clascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) else - call stdlib_clascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_clascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) end if end if - ! call stdlib_chbtrd to reduce hermitian band matrix to tridiagonal form. - inde = 1 - call stdlib_chbtrd( jobz, uplo, n, kd, ab, ldab, w, rwork( inde ), z,ldz, work, iinfo ) + ! call stdlib${ii}$_chbtrd to reduce hermitian band matrix to tridiagonal form. + inde = 1_${ik}$ + call stdlib${ii}$_chbtrd( jobz, uplo, n, kd, ab, ldab, w, rwork( inde ), z,ldz, work, iinfo ) - ! for eigenvalues only, call stdlib_ssterf. for eigenvectors, call stdlib_csteqr. + ! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvectors, call stdlib${ii}$_csteqr. if( .not.wantz ) then - call stdlib_ssterf( n, w, rwork( inde ), info ) + call stdlib${ii}$_ssterf( n, w, rwork( inde ), info ) else indrwk = inde + n - call stdlib_csteqr( jobz, n, w, rwork( inde ), z, ldz,rwork( indrwk ), info ) + call stdlib${ii}$_csteqr( jobz, n, w, rwork( inde ), z, ldz,rwork( indrwk ), info ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = n else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_sscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ ) end if return - end subroutine stdlib_chbev + end subroutine stdlib${ii}$_chbev - subroutine stdlib_chbevd( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,lwork, rwork, lrwork, & + subroutine stdlib${ii}$_chbevd( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,lwork, rwork, lrwork, & !! CHBEVD computes all the eigenvalues and, optionally, eigenvectors of !! a complex Hermitian band matrix A. If eigenvectors are desired, it !! uses a divide and conquer algorithm. @@ -72112,10 +72110,10 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kd, ldab, ldz, liwork, lrwork, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kd, ldab, ldz, liwork, lrwork, lwork, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(out) :: rwork(*), w(*) complex(sp), intent(inout) :: ab(ldab,*) complex(sp), intent(out) :: work(*), z(ldz,*) @@ -72124,7 +72122,7 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: lower, lquery, wantz - integer(ilp) :: iinfo, imax, inde, indwk2, indwrk, iscale, liwmin, llrwk, llwk2, & + integer(${ik}$) :: iinfo, imax, inde, indwk2, indwrk, iscale, liwmin, llrwk, llwk2, & lrwmin, lwmin real(sp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! Intrinsic Functions @@ -72133,120 +72131,120 @@ module stdlib_linalg_lapack_c ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) lower = stdlib_lsame( uplo, 'L' ) - lquery = ( lwork==-1 .or. liwork==-1 .or. lrwork==-1 ) - info = 0 - if( n<=1 ) then - lwmin = 1 - lrwmin = 1 - liwmin = 1 + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ .or. lrwork==-1_${ik}$ ) + info = 0_${ik}$ + if( n<=1_${ik}$ ) then + lwmin = 1_${ik}$ + lrwmin = 1_${ik}$ + liwmin = 1_${ik}$ else if( wantz ) then - lwmin = 2*n**2 - lrwmin = 1 + 5*n + 2*n**2 - liwmin = 3 + 5*n + lwmin = 2_${ik}$*n**2_${ik}$ + lrwmin = 1_${ik}$ + 5_${ik}$*n + 2_${ik}$*n**2_${ik}$ + liwmin = 3_${ik}$ + 5_${ik}$*n else lwmin = n lrwmin = n - liwmin = 1 + liwmin = 1_${ik}$ end if end if if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) 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( ldabzero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then - call stdlib_clascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_clascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) else - call stdlib_clascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_clascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) end if end if - ! call stdlib_chbtrd to reduce hermitian band matrix to tridiagonal form. - inde = 1 + ! call stdlib${ii}$_chbtrd to reduce hermitian band matrix to tridiagonal form. + inde = 1_${ik}$ indwrk = inde + n - indwk2 = 1 + n*n - llwk2 = lwork - indwk2 + 1 - llrwk = lrwork - indwrk + 1 - call stdlib_chbtrd( jobz, uplo, n, kd, ab, ldab, w, rwork( inde ), z,ldz, work, iinfo ) + indwk2 = 1_${ik}$ + n*n + llwk2 = lwork - indwk2 + 1_${ik}$ + llrwk = lrwork - indwrk + 1_${ik}$ + call stdlib${ii}$_chbtrd( jobz, uplo, n, kd, ab, ldab, w, rwork( inde ), z,ldz, work, iinfo ) - ! for eigenvalues only, call stdlib_ssterf. for eigenvectors, call stdlib_cstedc. + ! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvectors, call stdlib${ii}$_cstedc. if( .not.wantz ) then - call stdlib_ssterf( n, w, rwork( inde ), info ) + call stdlib${ii}$_ssterf( n, w, rwork( inde ), info ) else - call stdlib_cstedc( 'I', n, w, rwork( inde ), work, n, work( indwk2 ),llwk2, rwork( & + call stdlib${ii}$_cstedc( 'I', n, w, rwork( inde ), work, n, work( indwk2 ),llwk2, rwork( & indwrk ), llrwk, iwork, liwork,info ) - call stdlib_cgemm( 'N', 'N', n, n, n, cone, z, ldz, work, n, czero,work( indwk2 ), & + call stdlib${ii}$_cgemm( 'N', 'N', n, n, n, cone, z, ldz, work, n, czero,work( indwk2 ), & n ) - call stdlib_clacpy( 'A', n, n, work( indwk2 ), n, z, ldz ) + call stdlib${ii}$_clacpy( 'A', n, n, work( indwk2 ), n, z, ldz ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = n else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_sscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ ) end if - work( 1 ) = lwmin - rwork( 1 ) = lrwmin - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = lwmin + rwork( 1_${ik}$ ) = lrwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_chbevd + end subroutine stdlib${ii}$_chbevd - subroutine stdlib_chbevx( jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl,vu, il, iu, abstol, & + subroutine stdlib${ii}$_chbevx( jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl,vu, il, iu, abstol, & !! CHBEVX computes selected eigenvalues and, optionally, eigenvectors !! of a complex Hermitian band matrix A. Eigenvalues and eigenvectors !! can be selected by specifying either a range of values or a range of @@ -72257,11 +72255,11 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range, uplo - integer(ilp), intent(in) :: il, iu, kd, ldab, ldq, ldz, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, iu, kd, ldab, ldq, ldz, n + integer(${ik}$), intent(out) :: info, m real(sp), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: ifail(*), iwork(*) + integer(${ik}$), intent(out) :: ifail(*), iwork(*) real(sp), intent(out) :: rwork(*), w(*) complex(sp), intent(inout) :: ab(ldab,*) complex(sp), intent(out) :: q(ldq,*), work(*), z(ldz,*) @@ -72271,7 +72269,7 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: alleig, indeig, lower, test, valeig, wantz character :: order - integer(ilp) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwk, indrwk, & + integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwk, indrwk, & indwrk, iscale, itmp1, j, jj, nsplit real(sp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, & vuu @@ -72285,68 +72283,68 @@ module stdlib_linalg_lapack_c valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) lower = stdlib_lsame( uplo, 'L' ) - info = 0 + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( kd<0 ) then - info = -5 + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( kd<0_${ik}$ ) then + info = -5_${ik}$ else if( ldab0 .and. vu<=vl )info = -11 + if( n>0_${ik}$ .and. vu<=vl )info = -11_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -12 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -12_${ik}$ else if( iun ) then - info = -13 + info = -13_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz=tmp1 ) )m = 0 + if( .not.( vl=tmp1 ) )m = 0_${ik}$ end if - if( m==1 ) then - w( 1 ) = real( ctmp1,KIND=sp) - if( wantz )z( 1, 1 ) = cone + if( m==1_${ik}$ ) then + w( 1_${ik}$ ) = real( ctmp1,KIND=sp) + if( wantz )z( 1_${ik}$, 1_${ik}$ ) = cone end if return end if ! get machine constants. - safmin = stdlib_slamch( 'SAFE MINIMUM' ) - eps = stdlib_slamch( 'PRECISION' ) + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_slamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) ) ! scale matrix to allowable range, if necessary. - iscale = 0 + iscale = 0_${ik}$ abstll = abstol if ( valeig ) then vll = vl @@ -72355,102 +72353,102 @@ module stdlib_linalg_lapack_c vll = zero vuu = zero endif - anrm = stdlib_clanhb( 'M', uplo, n, kd, ab, ldab, rwork ) + anrm = stdlib${ii}$_clanhb( 'M', uplo, n, kd, ab, ldab, rwork ) if( anrm>zero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then - call stdlib_clascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_clascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) else - call stdlib_clascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_clascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) end if - if( abstol>0 )abstll = abstol*sigma + if( abstol>0_${ik}$ )abstll = abstol*sigma if( valeig ) then vll = vl*sigma vuu = vu*sigma end if end if - ! call stdlib_chbtrd to reduce hermitian band matrix to tridiagonal form. - indd = 1 + ! call stdlib${ii}$_chbtrd to reduce hermitian band matrix to tridiagonal form. + indd = 1_${ik}$ inde = indd + n indrwk = inde + n - indwrk = 1 - call stdlib_chbtrd( jobz, uplo, n, kd, ab, ldab, rwork( indd ),rwork( inde ), q, ldq, & + indwrk = 1_${ik}$ + call stdlib${ii}$_chbtrd( jobz, uplo, n, kd, ab, ldab, rwork( indd ),rwork( inde ), q, ldq, & work( indwrk ), iinfo ) ! if all eigenvalues are desired and abstol is less than or equal - ! to zero, then call stdlib_ssterf or stdlib_csteqr. if this fails for some - ! eigenvalue, then try stdlib_sstebz. + ! to zero, then call stdlib${ii}$_ssterf or stdlib${ii}$_csteqr. if this fails for some + ! eigenvalue, then try stdlib${ii}$_sstebz. test = .false. if (indeig) then - if (il==1 .and. iu==n) then + if (il==1_${ik}$ .and. iu==n) then test = .true. end if end if if ((alleig .or. test) .and. (abstol<=zero)) then - call stdlib_scopy( n, rwork( indd ), 1, w, 1 ) - indee = indrwk + 2*n + call stdlib${ii}$_scopy( n, rwork( indd ), 1_${ik}$, w, 1_${ik}$ ) + indee = indrwk + 2_${ik}$*n if( .not.wantz ) then - call stdlib_scopy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) - call stdlib_ssterf( n, w, rwork( indee ), info ) + call stdlib${ii}$_scopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ ) + call stdlib${ii}$_ssterf( n, w, rwork( indee ), info ) else - call stdlib_clacpy( 'A', n, n, q, ldq, z, ldz ) - call stdlib_scopy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) - call stdlib_csteqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) + call stdlib${ii}$_clacpy( 'A', n, n, q, ldq, z, ldz ) + call stdlib${ii}$_scopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ ) + call stdlib${ii}$_csteqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) - if( info==0 ) then + if( info==0_${ik}$ ) then do i = 1, n - ifail( i ) = 0 + ifail( i ) = 0_${ik}$ end do end if end if - if( info==0 ) then + if( info==0_${ik}$ ) then m = n go to 30 end if - info = 0 + info = 0_${ik}$ end if - ! otherwise, call stdlib_sstebz and, if eigenvectors are desired, stdlib_cstein. + ! otherwise, call stdlib${ii}$_sstebz and, if eigenvectors are desired, stdlib${ii}$_cstein. if( wantz ) then order = 'B' else order = 'E' end if - indibl = 1 + indibl = 1_${ik}$ indisp = indibl + n indiwk = indisp + n - call stdlib_sstebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indd ), rwork( & + call stdlib${ii}$_sstebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indd ), rwork( & inde ), m, nsplit, w,iwork( indibl ), iwork( indisp ), rwork( indrwk ),iwork( indiwk ),& info ) if( wantz ) then - call stdlib_cstein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & + call stdlib${ii}$_cstein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,rwork( indrwk ), iwork( indiwk ), ifail, info ) ! apply unitary matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_cstein. + ! form to eigenvectors returned by stdlib${ii}$_cstein. do j = 1, m - call stdlib_ccopy( n, z( 1, j ), 1, work( 1 ), 1 ) - call stdlib_cgemv( 'N', n, n, cone, q, ldq, work, 1, czero,z( 1, j ), 1 ) + call stdlib${ii}$_ccopy( n, z( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_cgemv( 'N', n, n, cone, q, ldq, work, 1_${ik}$, czero,z( 1_${ik}$, j ), 1_${ik}$ ) end do end if ! if matrix was scaled, then rescale eigenvalues appropriately. 30 continue - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = m else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_sscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. if( wantz ) then do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp1 = w( j ) do jj = j + 1, m if( w( jj )ka ) 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( ldabka ) 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( ldabka ) then - info = -6 + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( ka<0_${ik}$ ) then + info = -5_${ik}$ + else if( kb<0_${ik}$ .or. kb>ka ) then + info = -6_${ik}$ else if( ldab0 .and. vu<=vl )info = -14 + if( n>0_${ik}$ .and. vu<=vl )info = -14_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -15 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -15_${ik}$ else if ( iun ) then - info = -16 + info = -16_${ik}$ end if end if end if - if( info==0) then - if( ldz<1 .or. ( wantz .and. ldzzero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 )call stdlib_clascl( uplo, 0, 0, one, sigma, n, n, a, lda, info ) - ! call stdlib_chetrd to reduce hermitian matrix to tridiagonal form. - inde = 1 - indtau = 1 + if( iscale==1_${ik}$ )call stdlib${ii}$_clascl( uplo, 0_${ik}$, 0_${ik}$, one, sigma, n, n, a, lda, info ) + ! call stdlib${ii}$_chetrd to reduce hermitian matrix to tridiagonal form. + inde = 1_${ik}$ + indtau = 1_${ik}$ indwrk = indtau + n indrwk = inde + n indwk2 = indwrk + n*n - llwork = lwork - indwrk + 1 - llwrk2 = lwork - indwk2 + 1 - llrwk = lrwork - indrwk + 1 - call stdlib_chetrd( uplo, n, a, lda, w, rwork( inde ), work( indtau ),work( indwrk ), & + llwork = lwork - indwrk + 1_${ik}$ + llwrk2 = lwork - indwk2 + 1_${ik}$ + llrwk = lrwork - indrwk + 1_${ik}$ + call stdlib${ii}$_chetrd( uplo, n, a, lda, w, rwork( inde ), work( indtau ),work( indwrk ), & llwork, iinfo ) - ! for eigenvalues only, call stdlib_ssterf. for eigenvectors, first call - ! stdlib_cstedc to generate the eigenvector matrix, work(indwrk), of the - ! tridiagonal matrix, then call stdlib_cunmtr to multiply it to the + ! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvectors, first call + ! stdlib${ii}$_cstedc to generate the eigenvector matrix, work(indwrk), of the + ! tridiagonal matrix, then call stdlib${ii}$_cunmtr to multiply it to the ! householder transformations represented as householder vectors in ! a. if( .not.wantz ) then - call stdlib_ssterf( n, w, rwork( inde ), info ) + call stdlib${ii}$_ssterf( n, w, rwork( inde ), info ) else - call stdlib_cstedc( 'I', n, w, rwork( inde ), work( indwrk ), n,work( indwk2 ), & + call stdlib${ii}$_cstedc( 'I', n, w, rwork( inde ), work( indwrk ), n,work( indwk2 ), & llwrk2, rwork( indrwk ), llrwk,iwork, liwork, info ) - call stdlib_cunmtr( 'L', uplo, 'N', n, n, a, lda, work( indtau ),work( indwrk ), n, & + call stdlib${ii}$_cunmtr( 'L', uplo, 'N', n, n, a, lda, work( indtau ),work( indwrk ), n, & work( indwk2 ), llwrk2, iinfo ) - call stdlib_clacpy( 'A', n, n, work( indwrk ), n, a, lda ) + call stdlib${ii}$_clacpy( 'A', n, n, work( indwrk ), n, a, lda ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = n else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_sscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ ) end if - work( 1 ) = lopt - rwork( 1 ) = lropt - iwork( 1 ) = liopt + work( 1_${ik}$ ) = lopt + rwork( 1_${ik}$ ) = lropt + iwork( 1_${ik}$ ) = liopt return - end subroutine stdlib_cheevd + end subroutine stdlib${ii}$_cheevd - subroutine stdlib_chegvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, rwork, lrwork,& + subroutine stdlib${ii}$_chegvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, rwork, lrwork,& !! CHEGVD computes all the eigenvalues, and optionally, the eigenvectors !! of a complex generalized Hermitian-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and @@ -73044,10 +73042,10 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: itype, lda, ldb, liwork, lrwork, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: itype, lda, ldb, liwork, lrwork, lwork, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(out) :: rwork(*), w(*) complex(sp), intent(inout) :: a(lda,*), b(ldb,*) complex(sp), intent(out) :: work(*) @@ -73056,58 +73054,58 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: lquery, upper, wantz character :: trans - integer(ilp) :: liopt, liwmin, lopt, lropt, lrwmin, lwmin + integer(${ik}$) :: liopt, liwmin, lopt, lropt, lrwmin, lwmin ! Intrinsic Functions intrinsic :: max,real ! Executable Statements ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) upper = stdlib_lsame( uplo, 'U' ) - lquery = ( lwork==-1 .or. lrwork==-1 .or. liwork==-1 ) - info = 0 - if( n<=1 ) then - lwmin = 1 - lrwmin = 1 - liwmin = 1 + lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) + info = 0_${ik}$ + if( n<=1_${ik}$ ) then + lwmin = 1_${ik}$ + lrwmin = 1_${ik}$ + liwmin = 1_${ik}$ else if( wantz ) then - lwmin = 2*n + n*n - lrwmin = 1 + 5*n + 2*n*n - liwmin = 3 + 5*n + lwmin = 2_${ik}$*n + n*n + lrwmin = 1_${ik}$ + 5_${ik}$*n + 2_${ik}$*n*n + liwmin = 3_${ik}$ + 5_${ik}$*n else - lwmin = n + 1 + lwmin = n + 1_${ik}$ lrwmin = n - liwmin = 1 + liwmin = 1_${ik}$ end if lopt = lwmin lropt = lrwmin liopt = liwmin - if( itype<1 .or. itype>3 ) then - info = -1 + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( ldazero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then - call stdlib_csscal( ( n*( n+1 ) ) / 2, sigma, ap, 1 ) + if( iscale==1_${ik}$ ) then + call stdlib${ii}$_csscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ ) end if - ! call stdlib_chptrd to reduce hermitian packed matrix to tridiagonal form. - inde = 1 - indtau = 1 + ! call stdlib${ii}$_chptrd to reduce hermitian packed matrix to tridiagonal form. + inde = 1_${ik}$ + indtau = 1_${ik}$ indrwk = inde + n indwrk = indtau + n - llwrk = lwork - indwrk + 1 - llrwk = lrwork - indrwk + 1 - call stdlib_chptrd( uplo, n, ap, w, rwork( inde ), work( indtau ),iinfo ) - ! for eigenvalues only, call stdlib_ssterf. for eigenvectors, first call - ! stdlib_cupgtr to generate the orthogonal matrix, then call stdlib_cstedc. + llwrk = lwork - indwrk + 1_${ik}$ + llrwk = lrwork - indrwk + 1_${ik}$ + call stdlib${ii}$_chptrd( uplo, n, ap, w, rwork( inde ), work( indtau ),iinfo ) + ! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvectors, first call + ! stdlib${ii}$_cupgtr to generate the orthogonal matrix, then call stdlib${ii}$_cstedc. if( .not.wantz ) then - call stdlib_ssterf( n, w, rwork( inde ), info ) + call stdlib${ii}$_ssterf( n, w, rwork( inde ), info ) else - call stdlib_cstedc( 'I', n, w, rwork( inde ), z, ldz, work( indwrk ),llwrk, rwork( & + call stdlib${ii}$_cstedc( 'I', n, w, rwork( inde ), z, ldz, work( indwrk ),llwrk, rwork( & indrwk ), llrwk, iwork, liwork,info ) - call stdlib_cupmtr( 'L', uplo, 'N', n, n, ap, work( indtau ), z, ldz,work( indwrk ),& + call stdlib${ii}$_cupmtr( 'L', uplo, 'N', n, n, ap, work( indtau ), z, ldz,work( indwrk ),& iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = n else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_sscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ ) end if - work( 1 ) = lwmin - rwork( 1 ) = lrwmin - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = lwmin + rwork( 1_${ik}$ ) = lrwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_chpevd + end subroutine stdlib${ii}$_chpevd - subroutine stdlib_chpgvd( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,lwork, rwork, lrwork,& + subroutine stdlib${ii}$_chpgvd( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,lwork, rwork, lrwork,& !! CHPGVD computes all the eigenvalues and, optionally, the eigenvectors !! of a complex generalized Hermitian-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and @@ -73319,10 +73317,10 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: itype, ldz, liwork, lrwork, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: itype, ldz, liwork, lrwork, lwork, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(out) :: rwork(*), w(*) complex(sp), intent(inout) :: ap(*), bp(*) complex(sp), intent(out) :: work(*), z(ldz,*) @@ -73330,55 +73328,55 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: lquery, upper, wantz character :: trans - integer(ilp) :: j, liwmin, lrwmin, lwmin, neig + integer(${ik}$) :: j, liwmin, lrwmin, lwmin, neig ! Intrinsic Functions intrinsic :: max,real ! Executable Statements ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) upper = stdlib_lsame( uplo, 'U' ) - lquery = ( lwork==-1 .or. lrwork==-1 .or. liwork==-1 ) - info = 0 - if( itype<1 .or. itype>3 ) then - info = -1 + lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( ldz<1 .or. ( wantz .and. ldz0 )neig = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )neig = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y if( upper ) then @@ -73411,9 +73409,9 @@ module stdlib_linalg_lapack_c trans = 'C' end if do j = 1, neig - call stdlib_ctpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_ctpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**h *y if( upper ) then @@ -73422,18 +73420,18 @@ module stdlib_linalg_lapack_c trans = 'N' end if do j = 1, neig - call stdlib_ctpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_ctpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do end if end if - work( 1 ) = lwmin - rwork( 1 ) = lrwmin - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = lwmin + rwork( 1_${ik}$ ) = lrwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_chpgvd + end subroutine stdlib${ii}$_chpgvd - subroutine stdlib_cgees( jobvs, sort, select, n, a, lda, sdim, w, vs,ldvs, work, lwork, & + subroutine stdlib${ii}$_cgees( jobvs, sort, select, n, a, lda, sdim, w, vs,ldvs, work, lwork, & !! CGEES computes for an N-by-N complex nonsymmetric matrix A, the !! eigenvalues, the Schur form T, and, optionally, the matrix of Schur !! vectors Z. This gives the Schur factorization A = Z*T*(Z**H). @@ -73448,8 +73446,8 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvs, sort - integer(ilp), intent(out) :: info, sdim - integer(ilp), intent(in) :: lda, ldvs, lwork, n + integer(${ik}$), intent(out) :: info, sdim + integer(${ik}$), intent(in) :: lda, ldvs, lwork, n ! Array Arguments logical(lk), intent(out) :: bwork(*) real(sp), intent(out) :: rwork(*) @@ -73461,29 +73459,29 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: lquery, scalea, wantst, wantvs - integer(ilp) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, maxwrk, & + integer(${ik}$) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, maxwrk, & minwrk real(sp) :: anrm, bignum, cscale, eps, s, sep, smlnum ! Local Arrays - real(sp) :: dum(1) + real(sp) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) wantvs = stdlib_lsame( jobvs, 'V' ) wantst = stdlib_lsame( sort, 'S' ) if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then - info = -2 - else if( n<0 ) then - info = -4 - else if( ldazero .and. anrm0 )info = ieval + if( ieval>0_${ik}$ )info = ieval ! sort eigenvalues if desired - if( wantst .and. info==0 ) then - if( scalea )call stdlib_clascl( 'G', 0, 0, cscale, anrm, n, 1, w, n, ierr ) + if( wantst .and. info==0_${ik}$ ) then + if( scalea )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, w, n, ierr ) do i = 1, n bwork( i ) = select( w( i ) ) end do ! reorder eigenvalues and transform schur vectors ! (cworkspace: none) ! (rworkspace: none) - call stdlib_ctrsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,s, sep, work( & + call stdlib${ii}$_ctrsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,s, sep, work( & iwrk ), lwork-iwrk+1, icond ) end if if( wantvs ) then ! undo balancing ! (cworkspace: none) ! (rworkspace: need n) - call stdlib_cgebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr ) + call stdlib${ii}$_cgebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr ) end if if( scalea ) then ! undo scaling for the schur form of a - call stdlib_clascl( 'U', 0, 0, cscale, anrm, n, n, a, lda, ierr ) - call stdlib_ccopy( n, a, lda+1, w, 1 ) + call stdlib${ii}$_clascl( 'U', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_ccopy( n, a, lda+1, w, 1_${ik}$ ) end if - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_cgees + end subroutine stdlib${ii}$_cgees - subroutine stdlib_cgeesx( jobvs, sort, select, sense, n, a, lda, sdim, w,vs, ldvs, rconde, & + subroutine stdlib${ii}$_cgeesx( jobvs, sort, select, sense, n, a, lda, sdim, w,vs, ldvs, rconde, & !! CGEESX computes for an N-by-N complex nonsymmetric matrix A, the !! eigenvalues, the Schur form T, and, optionally, the matrix of Schur !! vectors Z. This gives the Schur factorization A = Z*T*(Z**H). @@ -73625,8 +73623,8 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvs, sense, sort - integer(ilp), intent(out) :: info, sdim - integer(ilp), intent(in) :: lda, ldvs, lwork, n + integer(${ik}$), intent(out) :: info, sdim + integer(${ik}$), intent(in) :: lda, ldvs, lwork, n real(sp), intent(out) :: rconde, rcondv ! Array Arguments logical(lk), intent(out) :: bwork(*) @@ -73639,36 +73637,36 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: lquery, scalea, wantsb, wantse, wantsn, wantst, wantsv, wantvs - integer(ilp) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, lwrk, & + integer(${ik}$) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, lwrk, & maxwrk, minwrk real(sp) :: anrm, bignum, cscale, eps, smlnum ! Local Arrays - real(sp) :: dum(1) + real(sp) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ wantvs = stdlib_lsame( jobvs, 'V' ) wantst = stdlib_lsame( sort, 'S' ) wantsn = stdlib_lsame( sense, 'N' ) wantse = stdlib_lsame( sense, 'E' ) wantsv = stdlib_lsame( sense, 'V' ) wantsb = stdlib_lsame( sense, 'B' ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. & .not.wantsn ) ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( ldazero .and. anrm0 )info = ieval + if( ieval>0_${ik}$ )info = ieval ! sort eigenvalues if desired - if( wantst .and. info==0 ) then - if( scalea )call stdlib_clascl( 'G', 0, 0, cscale, anrm, n, 1, w, n, ierr ) + if( wantst .and. info==0_${ik}$ ) then + if( scalea )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, w, n, ierr ) do i = 1, n bwork( i ) = select( w( i ) ) end do @@ -73777,36 +73775,36 @@ module stdlib_linalg_lapack_c ! (cworkspace: if sense is not 'n', need 2*sdim*(n-sdim) ! otherwise, need none ) ! (rworkspace: none) - call stdlib_ctrsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,rconde, & + call stdlib${ii}$_ctrsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,rconde, & rcondv, work( iwrk ), lwork-iwrk+1,icond ) - if( .not.wantsn )maxwrk = max( maxwrk, 2*sdim*( n-sdim ) ) - if( icond==-14 ) then + if( .not.wantsn )maxwrk = max( maxwrk, 2_${ik}$*sdim*( n-sdim ) ) + if( icond==-14_${ik}$ ) then ! not enough complex workspace - info = -15 + info = -15_${ik}$ end if end if if( wantvs ) then ! undo balancing ! (cworkspace: none) ! (rworkspace: need n) - call stdlib_cgebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr ) + call stdlib${ii}$_cgebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr ) end if if( scalea ) then ! undo scaling for the schur form of a - call stdlib_clascl( 'U', 0, 0, cscale, anrm, n, n, a, lda, ierr ) - call stdlib_ccopy( n, a, lda+1, w, 1 ) - if( ( wantsv .or. wantsb ) .and. info==0 ) then - dum( 1 ) = rcondv - call stdlib_slascl( 'G', 0, 0, cscale, anrm, 1, 1, dum, 1, ierr ) - rcondv = dum( 1 ) + call stdlib${ii}$_clascl( 'U', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_ccopy( n, a, lda+1, w, 1_${ik}$ ) + if( ( wantsv .or. wantsb ) .and. info==0_${ik}$ ) then + dum( 1_${ik}$ ) = rcondv + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr ) + rcondv = dum( 1_${ik}$ ) end if end if - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_cgeesx + end subroutine stdlib${ii}$_cgeesx - subroutine stdlib_cgeev( jobvl, jobvr, n, a, lda, w, vl, ldvl, vr, ldvr,work, lwork, rwork, & + subroutine stdlib${ii}$_cgeev( jobvl, jobvr, n, a, lda, w, vl, ldvl, vr, ldvr,work, lwork, rwork, & !! CGEEV computes for an N-by-N complex nonsymmetric matrix A, the !! eigenvalues and, optionally, the left and/or right eigenvectors. !! The right eigenvector v(j) of A satisfies @@ -73823,8 +73821,8 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvl, jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n ! Array Arguments real(sp), intent(out) :: rwork(*) complex(sp), intent(inout) :: a(lda,*) @@ -73834,33 +73832,33 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: lquery, scalea, wantvl, wantvr character :: side - integer(ilp) :: hswork, i, ibal, ierr, ihi, ilo, irwork, itau, iwrk, k, lwork_trevc, & + integer(${ik}$) :: hswork, i, ibal, ierr, ihi, ilo, irwork, itau, iwrk, k, lwork_trevc, & maxwrk, minwrk, nout real(sp) :: anrm, bignum, cscale, eps, scl, smlnum complex(sp) :: tmp ! Local Arrays - logical(lk) :: select(1) - real(sp) :: dum(1) + logical(lk) :: select(1_${ik}$) + real(sp) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: real,cmplx,conjg,aimag,max,sqrt ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) wantvl = stdlib_lsame( jobvl, 'V' ) wantvr = stdlib_lsame( jobvr, 'V' ) if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldazero .and. anrm0 ) then - call stdlib_clascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, w, n, ierr ) + if( info>0_${ik}$ ) then + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, w, n, ierr ) end if end if - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_cgeev + end subroutine stdlib${ii}$_cgeev - subroutine stdlib_cgeevx( balanc, jobvl, jobvr, sense, n, a, lda, w, vl,ldvl, vr, ldvr, ilo, & + subroutine stdlib${ii}$_cgeevx( balanc, jobvl, jobvr, sense, n, a, lda, w, vl,ldvl, vr, ldvr, ilo, & !! CGEEVX computes for an N-by-N complex nonsymmetric matrix A, the !! eigenvalues and, optionally, the left and/or right eigenvectors. !! Optionally also, it computes a balancing transformation to improve @@ -74087,8 +74085,8 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: balanc, jobvl, jobvr, sense - integer(ilp), intent(out) :: ihi, ilo, info - integer(ilp), intent(in) :: lda, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: ihi, ilo, info + integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n real(sp), intent(out) :: abnrm ! Array Arguments real(sp), intent(out) :: rconde(*), rcondv(*), rwork(*), scale(*) @@ -74099,19 +74097,19 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: lquery, scalea, wantvl, wantvr, wntsnb, wntsne, wntsnn, wntsnv character :: job, side - integer(ilp) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, & + integer(${ik}$) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, & nout real(sp) :: anrm, bignum, cscale, eps, scl, smlnum complex(sp) :: tmp ! Local Arrays - logical(lk) :: select(1) - real(sp) :: dum(1) + logical(lk) :: select(1_${ik}$) + real(sp) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: real,cmplx,conjg,aimag,max,sqrt ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) wantvl = stdlib_lsame( jobvl, 'V' ) wantvr = stdlib_lsame( jobvr, 'V' ) wntsnn = stdlib_lsame( sense, 'N' ) @@ -74120,22 +74118,22 @@ module stdlib_linalg_lapack_c wntsnb = stdlib_lsame( sense, 'B' ) if( .not.( stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'S' ) & .or.stdlib_lsame( balanc, 'P' ) .or. stdlib_lsame( balanc, 'B' ) ) ) then - info = -1 + info = -1_${ik}$ else if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then - info = -3 + info = -3_${ik}$ else if( .not.( wntsnn .or. wntsne .or. wntsnb .or. wntsnv ) .or.( ( wntsne .or. & wntsnb ) .and. .not.( wantvl .and.wantvr ) ) ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( ldazero .and. anrm= N. The SVD of [A] is written as !! [A] = [U] * [SIGMA] * [V]^*, @@ -74373,13 +74371,13 @@ module stdlib_linalg_lapack_c ! -- 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, ldu, ldv, lwork, lrwork, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldu, ldv, lwork, lrwork, m, n ! Array Arguments complex(sp), intent(inout) :: a(lda,*) complex(sp), intent(out) :: u(ldu,*), v(ldv,*), cwork(lwork) real(sp), intent(out) :: sva(n), rwork(lrwork) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) character, intent(in) :: joba, jobp, jobr, jobt, jobu, jobv ! =========================================================================== @@ -74388,17 +74386,17 @@ module stdlib_linalg_lapack_c complex(sp) :: ctemp real(sp) :: aapp, aaqq, aatmax, aatmin, big, big1, cond_ok, condr1, condr2, entra, & entrat, epsln, maxprj, scalem, sconda, sfmin, small, temp1, uscal1, uscal2, xsc - integer(ilp) :: ierr, n1, nr, numrank, p, q, warning + integer(${ik}$) :: ierr, n1, nr, numrank, p, q, warning logical(lk) :: almort, defr, errest, goscal, jracc, kill, lquery, lsvec, l2aber, & l2kill, l2pert, l2rank, l2tran, noscal, rowpiv, rsvec, transp - integer(ilp) :: optwrk, minwrk, minrwrk, miniwrk - integer(ilp) :: lwcon, lwlqf, lwqp3, lwqrf, lwunmlq, lwunmqr, lwunmqrm, lwsvdj, & + integer(${ik}$) :: optwrk, minwrk, minrwrk, miniwrk + integer(${ik}$) :: lwcon, lwlqf, lwqp3, lwqrf, lwunmlq, lwunmqr, lwunmqrm, lwsvdj, & lwsvdjv, lrwqp3, lrwcon, lrwsvdj, iwoff - integer(ilp) :: lwrk_cgelqf, lwrk_cgeqp3, lwrk_cgeqp3n, lwrk_cgeqrf, lwrk_cgesvj, & + integer(${ik}$) :: lwrk_cgelqf, lwrk_cgeqp3, lwrk_cgeqp3n, lwrk_cgeqrf, lwrk_cgesvj, & lwrk_cgesvjv, lwrk_cgesvju, lwrk_cunmlq, lwrk_cunmqr, lwrk_cunmqrm ! Local Arrays - complex(sp) :: cdummy(1) - real(sp) :: rdummy(1) + complex(sp) :: cdummy(1_${ik}$) + real(sp) :: rdummy(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,cmplx,conjg,log,max,min,real,nint,sqrt ! test the input arguments @@ -74413,88 +74411,88 @@ module stdlib_linalg_lapack_c l2kill = stdlib_lsame( jobr, 'R' ) defr = stdlib_lsame( jobr, 'N' ) l2pert = stdlib_lsame( jobp, 'P' ) - lquery = ( lwork == -1 ) .or. ( lrwork == -1 ) + lquery = ( lwork == -1_${ik}$ ) .or. ( lrwork == -1_${ik}$ ) if ( .not.(rowpiv .or. l2rank .or. l2aber .or.errest .or. stdlib_lsame( joba, 'C' ) )) & then - info = - 1 + info = - 1_${ik}$ else if ( .not.( lsvec .or. stdlib_lsame( jobu, 'N' ) .or.( stdlib_lsame( jobu, 'W' ) & .and. rsvec .and. l2tran ) ) ) then - info = - 2 + info = - 2_${ik}$ else if ( .not.( rsvec .or. stdlib_lsame( jobv, 'N' ) .or.( stdlib_lsame( jobv, 'W' ) & .and. lsvec .and. l2tran ) ) ) then - info = - 3 + info = - 3_${ik}$ else if ( .not. ( l2kill .or. defr ) ) then - info = - 4 + info = - 4_${ik}$ else if ( .not. ( stdlib_lsame(jobt,'T') .or. stdlib_lsame(jobt,'N') ) ) then - info = - 5 + info = - 5_${ik}$ else if ( .not. ( l2pert .or. stdlib_lsame( jobp, 'N' ) ) ) then - info = - 6 - else if ( m < 0 ) then - info = - 7 - else if ( ( n < 0 ) .or. ( n > m ) ) then - info = - 8 + info = - 6_${ik}$ + else if ( m < 0_${ik}$ ) then + info = - 7_${ik}$ + else if ( ( n < 0_${ik}$ ) .or. ( n > m ) ) then + info = - 8_${ik}$ else if ( lda < m ) then - info = - 10 + info = - 10_${ik}$ else if ( lsvec .and. ( ldu < m ) ) then - info = - 13 + info = - 13_${ik}$ else if ( rsvec .and. ( ldv < n ) ) then - info = - 15 + info = - 15_${ik}$ else ! #:) - info = 0 + info = 0_${ik}$ end if - if ( info == 0 ) then + if ( info == 0_${ik}$ ) then ! Compute The Minimal And The Optimal Workspace Lengths ! [[the expressions for computing the minimal and the optimal ! values of lcwork, lrwork are written with a lot of redundancy and ! can be simplified. however, this verbose form is useful for ! maintenance and modifications of the code.]] - ! .. minimal workspace length for stdlib_cgeqp3 of an m x n matrix, - ! stdlib_cgeqrf of an n x n matrix, stdlib_cgelqf of an n x n matrix, - ! stdlib_cunmlq for computing n x n matrix, stdlib_cunmqr for computing n x n - ! matrix, stdlib_cunmqr for computing m x n matrix, respectively. + ! .. minimal workspace length for stdlib${ii}$_cgeqp3 of an m x n matrix, + ! stdlib${ii}$_cgeqrf of an n x n matrix, stdlib${ii}$_cgelqf of an n x n matrix, + ! stdlib${ii}$_cunmlq for computing n x n matrix, stdlib${ii}$_cunmqr for computing n x n + ! matrix, stdlib${ii}$_cunmqr for computing m x n matrix, respectively. lwqp3 = n+1 - lwqrf = max( 1, n ) - lwlqf = max( 1, n ) - lwunmlq = max( 1, n ) - lwunmqr = max( 1, n ) - lwunmqrm = max( 1, m ) + lwqrf = max( 1_${ik}$, n ) + lwlqf = max( 1_${ik}$, n ) + lwunmlq = max( 1_${ik}$, n ) + lwunmqr = max( 1_${ik}$, n ) + lwunmqrm = max( 1_${ik}$, m ) ! Minimal Workspace Length For Stdlib_Cpocon Of An N X N Matrix - lwcon = 2 * n - ! .. minimal workspace length for stdlib_cgesvj of an n x n matrix, + lwcon = 2_${ik}$ * n + ! .. minimal workspace length for stdlib${ii}$_cgesvj of an n x n matrix, ! without and with explicit accumulation of jacobi rotations - lwsvdj = max( 2 * n, 1 ) - lwsvdjv = max( 2 * n, 1 ) - ! .. minimal real workspace length for stdlib_cgeqp3, stdlib_cpocon, stdlib_cgesvj - lrwqp3 = 2 * n + lwsvdj = max( 2_${ik}$ * n, 1_${ik}$ ) + lwsvdjv = max( 2_${ik}$ * n, 1_${ik}$ ) + ! .. minimal real workspace length for stdlib${ii}$_cgeqp3, stdlib${ii}$_cpocon, stdlib${ii}$_cgesvj + lrwqp3 = 2_${ik}$ * n lrwcon = n lrwsvdj = n if ( lquery ) then - call stdlib_cgeqp3( m, n, a, lda, iwork, cdummy, cdummy, -1,rdummy, ierr ) + call stdlib${ii}$_cgeqp3( m, n, a, lda, iwork, cdummy, cdummy, -1_${ik}$,rdummy, ierr ) - lwrk_cgeqp3 = real( cdummy(1),KIND=sp) - call stdlib_cgeqrf( n, n, a, lda, cdummy, cdummy,-1, ierr ) - lwrk_cgeqrf = real( cdummy(1),KIND=sp) - call stdlib_cgelqf( n, n, a, lda, cdummy, cdummy,-1, ierr ) - lwrk_cgelqf = real( cdummy(1),KIND=sp) + lwrk_cgeqp3 = real( cdummy(1_${ik}$),KIND=sp) + call stdlib${ii}$_cgeqrf( n, n, a, lda, cdummy, cdummy,-1_${ik}$, ierr ) + lwrk_cgeqrf = real( cdummy(1_${ik}$),KIND=sp) + call stdlib${ii}$_cgelqf( n, n, a, lda, cdummy, cdummy,-1_${ik}$, ierr ) + lwrk_cgelqf = real( cdummy(1_${ik}$),KIND=sp) end if - minwrk = 2 - optwrk = 2 + minwrk = 2_${ik}$ + optwrk = 2_${ik}$ miniwrk = n if ( .not. (lsvec .or. rsvec ) ) then ! Minimal And Optimal Sizes Of The Complex Workspace If ! only the singular values are requested if ( errest ) then - minwrk = max( n+lwqp3, n**2+lwcon, n+lwqrf, lwsvdj ) + minwrk = max( n+lwqp3, n**2_${ik}$+lwcon, n+lwqrf, lwsvdj ) else minwrk = max( n+lwqp3, n+lwqrf, lwsvdj ) end if if ( lquery ) then - call stdlib_cgesvj( 'L', 'N', 'N', n, n, a, lda, sva, n, v,ldv, cdummy, -1,& - rdummy, -1, ierr ) - lwrk_cgesvj = real( cdummy(1),KIND=sp) + call stdlib${ii}$_cgesvj( 'L', 'N', 'N', n, n, a, lda, sva, n, v,ldv, cdummy, -1_${ik}$,& + rdummy, -1_${ik}$, ierr ) + lwrk_cgesvj = real( cdummy(1_${ik}$),KIND=sp) if ( errest ) then - optwrk = max( n+lwrk_cgeqp3, n**2+lwcon,n+lwrk_cgeqrf, lwrk_cgesvj ) + optwrk = max( n+lwrk_cgeqp3, n**2_${ik}$+lwcon,n+lwrk_cgeqrf, lwrk_cgesvj ) else optwrk = max( n+lwrk_cgeqp3, n+lwrk_cgeqrf,lwrk_cgesvj ) @@ -74502,15 +74500,15 @@ module stdlib_linalg_lapack_c end if if ( l2tran .or. rowpiv ) then if ( errest ) then - minrwrk = max( 7, 2*m, lrwqp3, lrwcon, lrwsvdj ) + minrwrk = max( 7_${ik}$, 2_${ik}$*m, lrwqp3, lrwcon, lrwsvdj ) else - minrwrk = max( 7, 2*m, lrwqp3, lrwsvdj ) + minrwrk = max( 7_${ik}$, 2_${ik}$*m, lrwqp3, lrwsvdj ) end if else if ( errest ) then - minrwrk = max( 7, lrwqp3, lrwcon, lrwsvdj ) + minrwrk = max( 7_${ik}$, lrwqp3, lrwcon, lrwsvdj ) else - minrwrk = max( 7, lrwqp3, lrwsvdj ) + minrwrk = max( 7_${ik}$, lrwqp3, lrwsvdj ) end if end if if ( rowpiv .or. l2tran ) miniwrk = miniwrk + m @@ -74518,38 +74516,38 @@ module stdlib_linalg_lapack_c ! Minimal And Optimal Sizes Of The Complex Workspace If The ! singular values and the right singular vectors are requested if ( errest ) then - minwrk = max( n+lwqp3, lwcon, lwsvdj, n+lwlqf,2*n+lwqrf, n+lwsvdj, n+& + minwrk = max( n+lwqp3, lwcon, lwsvdj, n+lwlqf,2_${ik}$*n+lwqrf, n+lwsvdj, n+& lwunmlq ) else - minwrk = max( n+lwqp3, lwsvdj, n+lwlqf, 2*n+lwqrf,n+lwsvdj, n+lwunmlq ) + minwrk = max( n+lwqp3, lwsvdj, n+lwlqf, 2_${ik}$*n+lwqrf,n+lwsvdj, n+lwunmlq ) end if if ( lquery ) then - call stdlib_cgesvj( 'L', 'U', 'N', n,n, u, ldu, sva, n, a,lda, cdummy, -1, & - rdummy, -1, ierr ) - lwrk_cgesvj = real( cdummy(1),KIND=sp) - call stdlib_cunmlq( 'L', 'C', n, n, n, a, lda, cdummy,v, ldv, cdummy, -1, & + call stdlib${ii}$_cgesvj( 'L', 'U', 'N', n,n, u, ldu, sva, n, a,lda, cdummy, -1_${ik}$, & + rdummy, -1_${ik}$, ierr ) + lwrk_cgesvj = real( cdummy(1_${ik}$),KIND=sp) + call stdlib${ii}$_cunmlq( 'L', 'C', n, n, n, a, lda, cdummy,v, ldv, cdummy, -1_${ik}$, & ierr ) - lwrk_cunmlq = real( cdummy(1),KIND=sp) + lwrk_cunmlq = real( cdummy(1_${ik}$),KIND=sp) if ( errest ) then - optwrk = max( n+lwrk_cgeqp3, lwcon, lwrk_cgesvj,n+lwrk_cgelqf, 2*n+& + optwrk = max( n+lwrk_cgeqp3, lwcon, lwrk_cgesvj,n+lwrk_cgelqf, 2_${ik}$*n+& lwrk_cgeqrf,n+lwrk_cgesvj, n+lwrk_cunmlq ) else - optwrk = max( n+lwrk_cgeqp3, lwrk_cgesvj,n+lwrk_cgelqf,2*n+lwrk_cgeqrf, n+& + optwrk = max( n+lwrk_cgeqp3, lwrk_cgesvj,n+lwrk_cgelqf,2_${ik}$*n+lwrk_cgeqrf, n+& lwrk_cgesvj,n+lwrk_cunmlq ) end if end if if ( l2tran .or. rowpiv ) then if ( errest ) then - minrwrk = max( 7, 2*m, lrwqp3, lrwsvdj, lrwcon ) + minrwrk = max( 7_${ik}$, 2_${ik}$*m, lrwqp3, lrwsvdj, lrwcon ) else - minrwrk = max( 7, 2*m, lrwqp3, lrwsvdj ) + minrwrk = max( 7_${ik}$, 2_${ik}$*m, lrwqp3, lrwsvdj ) end if else if ( errest ) then - minrwrk = max( 7, lrwqp3, lrwsvdj, lrwcon ) + minrwrk = max( 7_${ik}$, lrwqp3, lrwsvdj, lrwcon ) else - minrwrk = max( 7, lrwqp3, lrwsvdj ) + minrwrk = max( 7_${ik}$, lrwqp3, lrwsvdj ) end if end if if ( rowpiv .or. l2tran ) miniwrk = miniwrk + m @@ -74562,12 +74560,12 @@ module stdlib_linalg_lapack_c minwrk = n + max( lwqp3, n+lwqrf, lwsvdj, lwunmqrm ) end if if ( lquery ) then - call stdlib_cgesvj( 'L', 'U', 'N', n,n, u, ldu, sva, n, a,lda, cdummy, -1, & - rdummy, -1, ierr ) - lwrk_cgesvj = real( cdummy(1),KIND=sp) - call stdlib_cunmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -1, & + call stdlib${ii}$_cgesvj( 'L', 'U', 'N', n,n, u, ldu, sva, n, a,lda, cdummy, -1_${ik}$, & + rdummy, -1_${ik}$, ierr ) + lwrk_cgesvj = real( cdummy(1_${ik}$),KIND=sp) + call stdlib${ii}$_cunmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -1_${ik}$, & ierr ) - lwrk_cunmqrm = real( cdummy(1),KIND=sp) + lwrk_cunmqrm = real( cdummy(1_${ik}$),KIND=sp) if ( errest ) then optwrk = n + max( lwrk_cgeqp3, lwcon, n+lwrk_cgeqrf,lwrk_cgesvj, & lwrk_cunmqrm ) @@ -74578,15 +74576,15 @@ module stdlib_linalg_lapack_c end if if ( l2tran .or. rowpiv ) then if ( errest ) then - minrwrk = max( 7, 2*m, lrwqp3, lrwsvdj, lrwcon ) + minrwrk = max( 7_${ik}$, 2_${ik}$*m, lrwqp3, lrwsvdj, lrwcon ) else - minrwrk = max( 7, 2*m, lrwqp3, lrwsvdj ) + minrwrk = max( 7_${ik}$, 2_${ik}$*m, lrwqp3, lrwsvdj ) end if else if ( errest ) then - minrwrk = max( 7, lrwqp3, lrwsvdj, lrwcon ) + minrwrk = max( 7_${ik}$, lrwqp3, lrwsvdj, lrwcon ) else - minrwrk = max( 7, lrwqp3, lrwsvdj ) + minrwrk = max( 7_${ik}$, lrwqp3, lrwsvdj ) end if end if if ( rowpiv .or. l2tran ) miniwrk = miniwrk + m @@ -74595,108 +74593,108 @@ module stdlib_linalg_lapack_c ! full svd is requested if ( .not. jracc ) then if ( errest ) then - minwrk = max( n+lwqp3, n+lwcon, 2*n+n**2+lwcon,2*n+lwqrf, 2*n+& - lwqp3,2*n+n**2+n+lwlqf, 2*n+n**2+n+n**2+lwcon,2*n+n**2+n+lwsvdj, 2*n+& - n**2+n+lwsvdjv,2*n+n**2+n+lwunmqr,2*n+n**2+n+lwunmlq,n+n**2+lwsvdj, n+& + minwrk = max( n+lwqp3, n+lwcon, 2_${ik}$*n+n**2_${ik}$+lwcon,2_${ik}$*n+lwqrf, 2_${ik}$*n+& + lwqp3,2_${ik}$*n+n**2_${ik}$+n+lwlqf, 2_${ik}$*n+n**2_${ik}$+n+n**2_${ik}$+lwcon,2_${ik}$*n+n**2_${ik}$+n+lwsvdj, 2_${ik}$*n+& + n**2_${ik}$+n+lwsvdjv,2_${ik}$*n+n**2_${ik}$+n+lwunmqr,2_${ik}$*n+n**2_${ik}$+n+lwunmlq,n+n**2_${ik}$+lwsvdj, n+& lwunmqrm ) else - minwrk = max( n+lwqp3, 2*n+n**2+lwcon,2*n+lwqrf, 2*n+& - lwqp3,2*n+n**2+n+lwlqf, 2*n+n**2+n+n**2+lwcon,2*n+n**2+n+lwsvdj, 2*n+& - n**2+n+lwsvdjv,2*n+n**2+n+lwunmqr,2*n+n**2+n+lwunmlq,n+n**2+lwsvdj, & + minwrk = max( n+lwqp3, 2_${ik}$*n+n**2_${ik}$+lwcon,2_${ik}$*n+lwqrf, 2_${ik}$*n+& + lwqp3,2_${ik}$*n+n**2_${ik}$+n+lwlqf, 2_${ik}$*n+n**2_${ik}$+n+n**2_${ik}$+lwcon,2_${ik}$*n+n**2_${ik}$+n+lwsvdj, 2_${ik}$*n+& + n**2_${ik}$+n+lwsvdjv,2_${ik}$*n+n**2_${ik}$+n+lwunmqr,2_${ik}$*n+n**2_${ik}$+n+lwunmlq,n+n**2_${ik}$+lwsvdj, & n+lwunmqrm ) end if miniwrk = miniwrk + n if ( rowpiv .or. l2tran ) miniwrk = miniwrk + m else if ( errest ) then - minwrk = max( n+lwqp3, n+lwcon, 2*n+lwqrf,2*n+n**2+lwsvdjv, 2*n+n**2+n+& + minwrk = max( n+lwqp3, n+lwcon, 2_${ik}$*n+lwqrf,2_${ik}$*n+n**2_${ik}$+lwsvdjv, 2_${ik}$*n+n**2_${ik}$+n+& lwunmqr,n+lwunmqrm ) else - minwrk = max( n+lwqp3, 2*n+lwqrf,2*n+n**2+lwsvdjv, 2*n+n**2+n+lwunmqr,n+& + minwrk = max( n+lwqp3, 2_${ik}$*n+lwqrf,2_${ik}$*n+n**2_${ik}$+lwsvdjv, 2_${ik}$*n+n**2_${ik}$+n+lwunmqr,n+& lwunmqrm ) end if if ( rowpiv .or. l2tran ) miniwrk = miniwrk + m end if if ( lquery ) then - call stdlib_cunmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -1, & + call stdlib${ii}$_cunmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -1_${ik}$, & ierr ) - lwrk_cunmqrm = real( cdummy(1),KIND=sp) - call stdlib_cunmqr( 'L', 'N', n, n, n, a, lda, cdummy, u,ldu, cdummy, -1, & + lwrk_cunmqrm = real( cdummy(1_${ik}$),KIND=sp) + call stdlib${ii}$_cunmqr( 'L', 'N', n, n, n, a, lda, cdummy, u,ldu, cdummy, -1_${ik}$, & ierr ) - lwrk_cunmqr = real( cdummy(1),KIND=sp) + lwrk_cunmqr = real( cdummy(1_${ik}$),KIND=sp) if ( .not. jracc ) then - call stdlib_cgeqp3( n,n, a, lda, iwork, cdummy,cdummy, -1,rdummy, ierr ) + call stdlib${ii}$_cgeqp3( n,n, a, lda, iwork, cdummy,cdummy, -1_${ik}$,rdummy, ierr ) - lwrk_cgeqp3n = real( cdummy(1),KIND=sp) - call stdlib_cgesvj( 'L', 'U', 'N', n, n, u, ldu, sva,n, v, ldv, cdummy, & - -1, rdummy, -1, ierr ) - lwrk_cgesvj = real( cdummy(1),KIND=sp) - call stdlib_cgesvj( 'U', 'U', 'N', n, n, u, ldu, sva,n, v, ldv, cdummy, & - -1, rdummy, -1, ierr ) - lwrk_cgesvju = real( cdummy(1),KIND=sp) - call stdlib_cgesvj( 'L', 'U', 'V', n, n, u, ldu, sva,n, v, ldv, cdummy, & - -1, rdummy, -1, ierr ) - lwrk_cgesvjv = real( cdummy(1),KIND=sp) - call stdlib_cunmlq( 'L', 'C', n, n, n, a, lda, cdummy,v, ldv, cdummy, -& - 1, ierr ) - lwrk_cunmlq = real( cdummy(1),KIND=sp) + lwrk_cgeqp3n = real( cdummy(1_${ik}$),KIND=sp) + call stdlib${ii}$_cgesvj( 'L', 'U', 'N', n, n, u, ldu, sva,n, v, ldv, cdummy, & + -1_${ik}$, rdummy, -1_${ik}$, ierr ) + lwrk_cgesvj = real( cdummy(1_${ik}$),KIND=sp) + call stdlib${ii}$_cgesvj( 'U', 'U', 'N', n, n, u, ldu, sva,n, v, ldv, cdummy, & + -1_${ik}$, rdummy, -1_${ik}$, ierr ) + lwrk_cgesvju = real( cdummy(1_${ik}$),KIND=sp) + call stdlib${ii}$_cgesvj( 'L', 'U', 'V', n, n, u, ldu, sva,n, v, ldv, cdummy, & + -1_${ik}$, rdummy, -1_${ik}$, ierr ) + lwrk_cgesvjv = real( cdummy(1_${ik}$),KIND=sp) + call stdlib${ii}$_cunmlq( 'L', 'C', n, n, n, a, lda, cdummy,v, ldv, cdummy, -& + 1_${ik}$, ierr ) + lwrk_cunmlq = real( cdummy(1_${ik}$),KIND=sp) if ( errest ) then - optwrk = max( n+lwrk_cgeqp3, n+lwcon,2*n+n**2+lwcon, 2*n+lwrk_cgeqrf,& - 2*n+lwrk_cgeqp3n,2*n+n**2+n+lwrk_cgelqf,2*n+n**2+n+n**2+lwcon,2*n+& - n**2+n+lwrk_cgesvj,2*n+n**2+n+lwrk_cgesvjv,2*n+n**2+n+lwrk_cunmqr,2*n+& - n**2+n+lwrk_cunmlq,n+n**2+lwrk_cgesvju,n+lwrk_cunmqrm ) + optwrk = max( n+lwrk_cgeqp3, n+lwcon,2_${ik}$*n+n**2_${ik}$+lwcon, 2_${ik}$*n+lwrk_cgeqrf,& + 2_${ik}$*n+lwrk_cgeqp3n,2_${ik}$*n+n**2_${ik}$+n+lwrk_cgelqf,2_${ik}$*n+n**2_${ik}$+n+n**2_${ik}$+lwcon,2_${ik}$*n+& + n**2_${ik}$+n+lwrk_cgesvj,2_${ik}$*n+n**2_${ik}$+n+lwrk_cgesvjv,2_${ik}$*n+n**2_${ik}$+n+lwrk_cunmqr,2_${ik}$*n+& + n**2_${ik}$+n+lwrk_cunmlq,n+n**2_${ik}$+lwrk_cgesvju,n+lwrk_cunmqrm ) else - optwrk = max( n+lwrk_cgeqp3,2*n+n**2+lwcon, 2*n+lwrk_cgeqrf,2*n+& - lwrk_cgeqp3n,2*n+n**2+n+lwrk_cgelqf,2*n+n**2+n+n**2+lwcon,2*n+n**2+n+& - lwrk_cgesvj,2*n+n**2+n+lwrk_cgesvjv,2*n+n**2+n+lwrk_cunmqr,2*n+n**2+n+& - lwrk_cunmlq,n+n**2+lwrk_cgesvju,n+lwrk_cunmqrm ) + optwrk = max( n+lwrk_cgeqp3,2_${ik}$*n+n**2_${ik}$+lwcon, 2_${ik}$*n+lwrk_cgeqrf,2_${ik}$*n+& + lwrk_cgeqp3n,2_${ik}$*n+n**2_${ik}$+n+lwrk_cgelqf,2_${ik}$*n+n**2_${ik}$+n+n**2_${ik}$+lwcon,2_${ik}$*n+n**2_${ik}$+n+& + lwrk_cgesvj,2_${ik}$*n+n**2_${ik}$+n+lwrk_cgesvjv,2_${ik}$*n+n**2_${ik}$+n+lwrk_cunmqr,2_${ik}$*n+n**2_${ik}$+n+& + lwrk_cunmlq,n+n**2_${ik}$+lwrk_cgesvju,n+lwrk_cunmqrm ) end if else - call stdlib_cgesvj( 'L', 'U', 'V', n, n, u, ldu, sva,n, v, ldv, cdummy, & - -1, rdummy, -1, ierr ) - lwrk_cgesvjv = real( cdummy(1),KIND=sp) - call stdlib_cunmqr( 'L', 'N', n, n, n, cdummy, n, cdummy,v, ldv, cdummy,& - -1, ierr ) - lwrk_cunmqr = real( cdummy(1),KIND=sp) - call stdlib_cunmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -& - 1, ierr ) - lwrk_cunmqrm = real( cdummy(1),KIND=sp) + call stdlib${ii}$_cgesvj( 'L', 'U', 'V', n, n, u, ldu, sva,n, v, ldv, cdummy, & + -1_${ik}$, rdummy, -1_${ik}$, ierr ) + lwrk_cgesvjv = real( cdummy(1_${ik}$),KIND=sp) + call stdlib${ii}$_cunmqr( 'L', 'N', n, n, n, cdummy, n, cdummy,v, ldv, cdummy,& + -1_${ik}$, ierr ) + lwrk_cunmqr = real( cdummy(1_${ik}$),KIND=sp) + call stdlib${ii}$_cunmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -& + 1_${ik}$, ierr ) + lwrk_cunmqrm = real( cdummy(1_${ik}$),KIND=sp) if ( errest ) then - optwrk = max( n+lwrk_cgeqp3, n+lwcon,2*n+lwrk_cgeqrf, 2*n+n**2,2*n+& - n**2+lwrk_cgesvjv,2*n+n**2+n+lwrk_cunmqr,n+lwrk_cunmqrm ) + optwrk = max( n+lwrk_cgeqp3, n+lwcon,2_${ik}$*n+lwrk_cgeqrf, 2_${ik}$*n+n**2_${ik}$,2_${ik}$*n+& + n**2_${ik}$+lwrk_cgesvjv,2_${ik}$*n+n**2_${ik}$+n+lwrk_cunmqr,n+lwrk_cunmqrm ) else - optwrk = max( n+lwrk_cgeqp3, 2*n+lwrk_cgeqrf,2*n+n**2, 2*n+n**2+& - lwrk_cgesvjv,2*n+n**2+n+lwrk_cunmqr,n+lwrk_cunmqrm ) + optwrk = max( n+lwrk_cgeqp3, 2_${ik}$*n+lwrk_cgeqrf,2_${ik}$*n+n**2_${ik}$, 2_${ik}$*n+n**2_${ik}$+& + lwrk_cgesvjv,2_${ik}$*n+n**2_${ik}$+n+lwrk_cunmqr,n+lwrk_cunmqrm ) end if end if end if if ( l2tran .or. rowpiv ) then - minrwrk = max( 7, 2*m, lrwqp3, lrwsvdj, lrwcon ) + minrwrk = max( 7_${ik}$, 2_${ik}$*m, lrwqp3, lrwsvdj, lrwcon ) else - minrwrk = max( 7, lrwqp3, lrwsvdj, lrwcon ) + minrwrk = max( 7_${ik}$, lrwqp3, lrwsvdj, lrwcon ) end if end if - minwrk = max( 2, minwrk ) + minwrk = max( 2_${ik}$, minwrk ) optwrk = max( optwrk, minwrk ) - if ( lwork < minwrk .and. (.not.lquery) ) info = - 17 - if ( lrwork < minrwrk .and. (.not.lquery) ) info = - 19 + if ( lwork < minwrk .and. (.not.lquery) ) info = - 17_${ik}$ + if ( lrwork < minrwrk .and. (.not.lquery) ) info = - 19_${ik}$ end if - if ( info /= 0 ) then + if ( info /= 0_${ik}$ ) then ! #:( - call stdlib_xerbla( 'CGEJSV', - info ) + call stdlib${ii}$_xerbla( 'CGEJSV', - info ) return else if ( lquery ) then - cwork(1) = optwrk - cwork(2) = minwrk - rwork(1) = minrwrk - iwork(1) = max( 4, miniwrk ) + cwork(1_${ik}$) = optwrk + cwork(2_${ik}$) = minwrk + rwork(1_${ik}$) = minrwrk + iwork(1_${ik}$) = max( 4_${ik}$, miniwrk ) return end if ! quick return for void matrix (y3k safe) ! #:) - if ( ( m == 0 ) .or. ( n == 0 ) ) then - iwork(1:4) = 0 - rwork(1:7) = 0 + if ( ( m == 0_${ik}$ ) .or. ( n == 0_${ik}$ ) ) then + iwork(1_${ik}$:4_${ik}$) = 0_${ik}$ + rwork(1_${ik}$:7_${ik}$) = 0_${ik}$ return endif ! determine whether the matrix u should be m x n or m x m @@ -74705,11 +74703,11 @@ module stdlib_linalg_lapack_c if ( stdlib_lsame( jobu, 'F' ) ) n1 = m end if ! set numerical parameters - ! ! note: make sure stdlib_slamch() does not fail on the target architecture. - epsln = stdlib_slamch('EPSILON') - sfmin = stdlib_slamch('SAFEMINIMUM') + ! ! note: make sure stdlib${ii}$_slamch() does not fail on the target architecture. + epsln = stdlib${ii}$_slamch('EPSILON') + sfmin = stdlib${ii}$_slamch('SAFEMINIMUM') small = sfmin / epsln - big = stdlib_slamch('O') + big = stdlib${ii}$_slamch('O') ! big = one / sfmin ! initialize sva(1:n) = diag( ||a e_i||_2 )_1^n ! (!) if necessary, scale sva() to protect the largest norm from @@ -74721,10 +74719,10 @@ module stdlib_linalg_lapack_c do p = 1, n aapp = zero aaqq = one - call stdlib_classq( m, a(1,p), 1, aapp, aaqq ) + call stdlib${ii}$_classq( m, a(1_${ik}$,p), 1_${ik}$, aapp, aaqq ) if ( aapp > big ) then - info = - 9 - call stdlib_xerbla( 'CGEJSV', -info ) + info = - 9_${ik}$ + call stdlib${ii}$_xerbla( 'CGEJSV', -info ) return end if aaqq = sqrt(aaqq) @@ -74735,7 +74733,7 @@ module stdlib_linalg_lapack_c sva(p) = aapp * ( aaqq * scalem ) if ( goscal ) then goscal = .false. - call stdlib_sscal( p-1, scalem, sva, 1 ) + call stdlib${ii}$_sscal( p-1, scalem, sva, 1_${ik}$ ) end if end if end do @@ -74749,78 +74747,78 @@ module stdlib_linalg_lapack_c ! quick return for zero m x n matrix ! #:) if ( aapp == zero ) then - if ( lsvec ) call stdlib_claset( 'G', m, n1, czero, cone, u, ldu ) - if ( rsvec ) call stdlib_claset( 'G', n, n, czero, cone, v, ldv ) - rwork(1) = one - rwork(2) = one - if ( errest ) rwork(3) = one + if ( lsvec ) call stdlib${ii}$_claset( 'G', m, n1, czero, cone, u, ldu ) + if ( rsvec ) call stdlib${ii}$_claset( 'G', n, n, czero, cone, v, ldv ) + rwork(1_${ik}$) = one + rwork(2_${ik}$) = one + if ( errest ) rwork(3_${ik}$) = one if ( lsvec .and. rsvec ) then - rwork(4) = one - rwork(5) = one + rwork(4_${ik}$) = one + rwork(5_${ik}$) = one end if if ( l2tran ) then - rwork(6) = zero - rwork(7) = zero + rwork(6_${ik}$) = zero + rwork(7_${ik}$) = zero end if - iwork(1) = 0 - iwork(2) = 0 - iwork(3) = 0 - iwork(4) = -1 + iwork(1_${ik}$) = 0_${ik}$ + iwork(2_${ik}$) = 0_${ik}$ + iwork(3_${ik}$) = 0_${ik}$ + iwork(4_${ik}$) = -1_${ik}$ return end if ! issue warning if denormalized column norms detected. override the ! high relative accuracy request. issue licence to kill nonzero columns ! (set them to zero) whose norm is less than sigma_max / big (roughly). ! #:( - warning = 0 + warning = 0_${ik}$ if ( aaqq <= sfmin ) then l2rank = .true. l2kill = .true. - warning = 1 + warning = 1_${ik}$ end if ! quick return for one-column matrix ! #:) - if ( n == 1 ) then + if ( n == 1_${ik}$ ) then if ( lsvec ) then - call stdlib_clascl( 'G',0,0,sva(1),scalem, m,1,a(1,1),lda,ierr ) - call stdlib_clacpy( 'A', m, 1, a, lda, u, ldu ) + call stdlib${ii}$_clascl( 'G',0_${ik}$,0_${ik}$,sva(1_${ik}$),scalem, m,1_${ik}$,a(1_${ik}$,1_${ik}$),lda,ierr ) + call stdlib${ii}$_clacpy( 'A', m, 1_${ik}$, a, lda, u, ldu ) ! computing all m left singular vectors of the m x 1 matrix if ( n1 /= n ) then - call stdlib_cgeqrf( m, n, u,ldu, cwork, cwork(n+1),lwork-n,ierr ) - call stdlib_cungqr( m,n1,1, u,ldu,cwork,cwork(n+1),lwork-n,ierr ) - call stdlib_ccopy( m, a(1,1), 1, u(1,1), 1 ) + call stdlib${ii}$_cgeqrf( m, n, u,ldu, cwork, cwork(n+1),lwork-n,ierr ) + call stdlib${ii}$_cungqr( m,n1,1_${ik}$, u,ldu,cwork,cwork(n+1),lwork-n,ierr ) + call stdlib${ii}$_ccopy( m, a(1_${ik}$,1_${ik}$), 1_${ik}$, u(1_${ik}$,1_${ik}$), 1_${ik}$ ) end if end if if ( rsvec ) then - v(1,1) = cone + v(1_${ik}$,1_${ik}$) = cone end if - if ( sva(1) < (big*scalem) ) then - sva(1) = sva(1) / scalem + if ( sva(1_${ik}$) < (big*scalem) ) then + sva(1_${ik}$) = sva(1_${ik}$) / scalem scalem = one end if - rwork(1) = one / scalem - rwork(2) = one - if ( sva(1) /= zero ) then - iwork(1) = 1 - if ( ( sva(1) / scalem) >= sfmin ) then - iwork(2) = 1 + rwork(1_${ik}$) = one / scalem + rwork(2_${ik}$) = one + if ( sva(1_${ik}$) /= zero ) then + iwork(1_${ik}$) = 1_${ik}$ + if ( ( sva(1_${ik}$) / scalem) >= sfmin ) then + iwork(2_${ik}$) = 1_${ik}$ else - iwork(2) = 0 + iwork(2_${ik}$) = 0_${ik}$ end if else - iwork(1) = 0 - iwork(2) = 0 + iwork(1_${ik}$) = 0_${ik}$ + iwork(2_${ik}$) = 0_${ik}$ end if - iwork(3) = 0 - iwork(4) = -1 - if ( errest ) rwork(3) = one + iwork(3_${ik}$) = 0_${ik}$ + iwork(4_${ik}$) = -1_${ik}$ + if ( errest ) rwork(3_${ik}$) = one if ( lsvec .and. rsvec ) then - rwork(4) = one - rwork(5) = one + rwork(4_${ik}$) = one + rwork(5_${ik}$) = one end if if ( l2tran ) then - rwork(6) = zero - rwork(7) = zero + rwork(6_${ik}$) = zero + rwork(7_${ik}$) = zero end if return end if @@ -74836,8 +74834,8 @@ module stdlib_linalg_lapack_c do p = 1, m xsc = zero temp1 = one - call stdlib_classq( n, a(p,1), lda, xsc, temp1 ) - ! stdlib_classq gets both the ell_2 and the ell_infinity norm + call stdlib${ii}$_classq( n, a(p,1_${ik}$), lda, xsc, temp1 ) + ! stdlib${ii}$_classq gets both the ell_2 and the ell_infinity norm ! in one pass through the vector rwork(m+p) = xsc * scalem rwork(p) = xsc * (scalem*sqrt(temp1)) @@ -74846,7 +74844,7 @@ module stdlib_linalg_lapack_c end do else do p = 1, m - rwork(m+p) = scalem*abs( a(p,stdlib_icamax(n,a(p,1),lda)) ) + rwork(m+p) = scalem*abs( a(p,stdlib${ii}$_icamax(n,a(p,1_${ik}$),lda)) ) aatmax = max( aatmax, rwork(m+p) ) aatmin = min( aatmin, rwork(m+p) ) end do @@ -74863,11 +74861,11 @@ module stdlib_linalg_lapack_c if ( l2tran ) then xsc = zero temp1 = one - call stdlib_slassq( n, sva, 1, xsc, temp1 ) + call stdlib${ii}$_slassq( n, sva, 1_${ik}$, xsc, temp1 ) temp1 = one / temp1 entra = zero do p = 1, n - big1 = ( ( sva(p) / xsc )**2 ) * temp1 + big1 = ( ( sva(p) / xsc )**2_${ik}$ ) * temp1 if ( big1 /= zero ) entra = entra + big1 * log(big1) end do entra = - entra / log(real(n,KIND=sp)) @@ -74878,7 +74876,7 @@ module stdlib_linalg_lapack_c ! same trace. entrat = zero do p = 1, m - big1 = ( ( rwork(p) / xsc )**2 ) * temp1 + big1 = ( ( rwork(p) / xsc )**2_${ik}$ ) * temp1 if ( big1 /= zero ) entrat = entrat + big1 * log(big1) end do entrat = - entrat / log(real(m,KIND=sp)) @@ -74922,27 +74920,27 @@ module stdlib_linalg_lapack_c ! scale the matrix so that its maximal singular value remains less ! than sqrt(big) -- the matrix is scaled so that its maximal column ! has euclidean norm equal to sqrt(big/n). the only reason to keep - ! sqrt(big) instead of big is the fact that stdlib_cgejsv uses lapack and + ! sqrt(big) instead of big is the fact that stdlib${ii}$_cgejsv uses lapack and ! blas routines that, in some implementations, are not capable of ! working in the full interval [sfmin,big] and that they may provoke ! overflows in the intermediate results. if the singular values spread - ! from sfmin to big, then stdlib_cgesvj will compute them. so, in that case, - ! one should use stdlib_cgesvj instead of stdlib_cgejsv. + ! from sfmin to big, then stdlib${ii}$_cgesvj will compute them. so, in that case, + ! one should use stdlib_cgesvj instead of stdlib${ii}$_cgejsv. big1 = sqrt( big ) temp1 = sqrt( big / real(n,KIND=sp) ) ! >> for future updates: allow bigger range, i.e. the largest column - ! will be allowed up to big/n and stdlib_cgesvj will do the rest. however, for + ! will be allowed up to big/n and stdlib${ii}$_cgesvj will do the rest. however, for ! this all other (lapack) components must allow such a range. ! temp1 = big/real(n,KIND=sp) ! temp1 = big * epsln this should 'almost' work with current lapack components - call stdlib_slascl( 'G', 0, 0, aapp, temp1, n, 1, sva, n, ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aapp, temp1, n, 1_${ik}$, sva, n, ierr ) if ( aaqq > (aapp * sfmin) ) then aaqq = ( aaqq / aapp ) * temp1 else aaqq = ( aaqq * temp1 ) / aapp end if temp1 = temp1 * scalem - call stdlib_clascl( 'G', 0, 0, aapp, temp1, m, n, a, lda, ierr ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aapp, temp1, m, n, a, lda, ierr ) ! to undo scaling at the end of this procedure, multiply the ! computed singular values with uscal2 / uscal1. uscal1 = temp1 @@ -74956,7 +74954,7 @@ module stdlib_linalg_lapack_c xsc = small ! now, if the condition number of a is too big, ! sigma_max(a) / sigma_min(a) > sqrt(big/n) * epsln / sfmin, - ! as a precaution measure, the full svd is computed using stdlib_cgesvj + ! as a precaution measure, the full svd is computed using stdlib${ii}$_cgesvj ! with accumulated jacobi rotations. this provides numerically ! more robust computation, at the cost of slightly increased run ! time. depending on the concrete implementation of blas and lapack @@ -74969,7 +74967,7 @@ module stdlib_linalg_lapack_c if ( aaqq < xsc ) then do p = 1, n if ( sva(p) < xsc ) then - call stdlib_claset( 'A', m, 1, czero, czero, a(1,p), lda ) + call stdlib${ii}$_claset( 'A', m, 1_${ik}$, czero, czero, a(1_${ik}$,p), lda ) sva(p) = zero end if end do @@ -74982,12 +74980,12 @@ module stdlib_linalg_lapack_c ! has similar effect as powell-reid complete pivoting. ! the ell-infinity norms of a are made nonincreasing. if ( ( lsvec .and. rsvec ) .and. .not.( jracc ) ) then - iwoff = 2*n + iwoff = 2_${ik}$*n else iwoff = n end if do p = 1, m - 1 - q = stdlib_isamax( m-p+1, rwork(m+p), 1 ) + p - 1 + q = stdlib${ii}$_isamax( m-p+1, rwork(m+p), 1_${ik}$ ) + p - 1_${ik}$ iwork(iwoff+p) = q if ( p /= q ) then temp1 = rwork(m+p) @@ -74995,7 +74993,7 @@ module stdlib_linalg_lapack_c rwork(m+q) = temp1 end if end do - call stdlib_claswp( n, a, lda, 1, m-1, iwork(iwoff+1), 1 ) + call stdlib${ii}$_claswp( n, a, lda, 1_${ik}$, m-1, iwork(iwoff+1), 1_${ik}$ ) end if ! end of the preparation phase (scaling, optional sorting and ! transposing, optional flushing of small columns). @@ -75007,47 +75005,45 @@ module stdlib_linalg_lapack_c ! (eg speed by replacing global with restricted window pivoting, such ! as in xgeqpx from toms # 782). good results will be obtained using ! xgeqpx with properly (!) chosen numerical parameters. - ! any improvement of stdlib_cgeqp3 improves overall performance of stdlib_cgejsv. + ! any improvement of stdlib${ii}$_cgeqp3 improves overall performance of stdlib${ii}$_cgejsv. ! a * p1 = q1 * [ r1^* 0]^*: do p = 1, n ! All Columns Are Free Columns - iwork(p) = 0 + iwork(p) = 0_${ik}$ end do - call stdlib_cgeqp3( m, n, a, lda, iwork, cwork, cwork(n+1), lwork-n,rwork, ierr ) + call stdlib${ii}$_cgeqp3( m, n, a, lda, iwork, cwork, cwork(n+1), lwork-n,rwork, ierr ) ! the upper triangular matrix r1 from the first qrf is inspected for ! rank deficiency and possibilities for deflation, or possible ! ill-conditioning. depending on the user specified flag l2rank, ! the procedure explores possibilities to reduce the numerical ! rank by inspecting the computed upper triangular factor. if - ! l2rank or l2aber are up, then stdlib_cgejsv will compute the svd of + ! l2rank or l2aber are up, then stdlib${ii}$_cgejsv will compute the svd of ! a + da, where ||da|| <= f(m,n)*epsln. - nr = 1 + nr = 1_${ik}$ if ( l2aber ) then ! standard absolute error bound suffices. all sigma_i with ! sigma_i < n*epsln*||a|| are flushed to zero. this is an ! aggressive enforcement of lower numerical rank by introducing a ! backward error of the order of n*epsln*||a||. temp1 = sqrt(real(n,KIND=sp))*epsln - do p = 2, n - if ( abs(a(p,p)) >= (temp1*abs(a(1,1))) ) then - nr = nr + 1 + loop_3002: do p = 2, n + if ( abs(a(p,p)) >= (temp1*abs(a(1_${ik}$,1_${ik}$))) ) then + nr = nr + 1_${ik}$ else - go to 3002 + exit loop_3002 end if - end do - 3002 continue + end do loop_3002 else if ( l2rank ) then ! .. similarly as above, only slightly more gentle (less aggressive). ! sudden drop on the diagonal of r1 is used as the criterion for ! close-to-rank-deficient. temp1 = sqrt(sfmin) - do p = 2, n + loop_3402: do p = 2, n if ( ( abs(a(p,p)) < (epsln*abs(a(p-1,p-1))) ) .or.( abs(a(p,p)) < small ) .or.( & - l2kill .and. (abs(a(p,p)) < temp1) ) ) go to 3402 - nr = nr + 1 - end do - 3402 continue + l2kill .and. (abs(a(p,p)) < temp1) ) ) exit loop_3402 + nr = nr + 1_${ik}$ + end do loop_3402 else ! the goal is high relative accuracy. however, if the matrix ! has high scaled condition number the relative accuracy is in @@ -75057,12 +75053,10 @@ module stdlib_linalg_lapack_c ! factor. this prevents the situation in which the code is ! working hard to get the accuracy not warranted by the data. temp1 = sqrt(sfmin) - do p = 2, n - if ( ( abs(a(p,p)) < small ) .or.( l2kill .and. (abs(a(p,p)) < temp1) ) ) go to & - 3302 - nr = nr + 1 - end do - 3302 continue + loop_3302: do p = 2, n + if ( ( abs(a(p,p)) < small ) .or.( l2kill .and. (abs(a(p,p)) < temp1) ) ) exit loop_3302 + nr = nr + 1_${ik}$ + end do loop_3302 end if almort = .false. if ( nr == n ) then @@ -75071,7 +75065,7 @@ module stdlib_linalg_lapack_c temp1 = abs(a(p,p)) / sva(iwork(p)) maxprj = min( maxprj, temp1 ) end do - if ( maxprj**2 >= one - real(n,KIND=sp)*epsln ) almort = .true. + if ( maxprj**2_${ik}$ >= one - real(n,KIND=sp)*epsln ) almort = .true. end if sconda = - one condr1 = - one @@ -75080,41 +75074,41 @@ module stdlib_linalg_lapack_c if ( n == nr ) then if ( rsvec ) then ! V Is Available As Workspace - call stdlib_clacpy( 'U', n, n, a, lda, v, ldv ) + call stdlib${ii}$_clacpy( 'U', n, n, a, lda, v, ldv ) do p = 1, n temp1 = sva(iwork(p)) - call stdlib_csscal( p, one/temp1, v(1,p), 1 ) + call stdlib${ii}$_csscal( p, one/temp1, v(1_${ik}$,p), 1_${ik}$ ) end do if ( lsvec )then - call stdlib_cpocon( 'U', n, v, ldv, one, temp1,cwork(n+1), rwork, ierr ) + call stdlib${ii}$_cpocon( 'U', n, v, ldv, one, temp1,cwork(n+1), rwork, ierr ) else - call stdlib_cpocon( 'U', n, v, ldv, one, temp1,cwork, rwork, ierr ) + call stdlib${ii}$_cpocon( 'U', n, v, ldv, one, temp1,cwork, rwork, ierr ) end if else if ( lsvec ) then ! U Is Available As Workspace - call stdlib_clacpy( 'U', n, n, a, lda, u, ldu ) + call stdlib${ii}$_clacpy( 'U', n, n, a, lda, u, ldu ) do p = 1, n temp1 = sva(iwork(p)) - call stdlib_csscal( p, one/temp1, u(1,p), 1 ) + call stdlib${ii}$_csscal( p, one/temp1, u(1_${ik}$,p), 1_${ik}$ ) end do - call stdlib_cpocon( 'U', n, u, ldu, one, temp1,cwork(n+1), rwork, ierr ) + call stdlib${ii}$_cpocon( 'U', n, u, ldu, one, temp1,cwork(n+1), rwork, ierr ) else - call stdlib_clacpy( 'U', n, n, a, lda, cwork, n ) - ! [] call stdlib_clacpy( 'u', n, n, a, lda, cwork(n+1), n ) + call stdlib${ii}$_clacpy( 'U', n, n, a, lda, cwork, n ) + ! [] call stdlib${ii}$_clacpy( 'u', n, n, a, lda, cwork(n+1), n ) ! change: here index shifted by n to the left, cwork(1:n) ! not needed for sigma only computation do p = 1, n temp1 = sva(iwork(p)) - ! [] call stdlib_csscal( p, one/temp1, cwork(n+(p-1)*n+1), 1 ) - call stdlib_csscal( p, one/temp1, cwork((p-1)*n+1), 1 ) + ! [] call stdlib${ii}$_csscal( p, one/temp1, cwork(n+(p-1)*n+1), 1 ) + call stdlib${ii}$_csscal( p, one/temp1, cwork((p-1)*n+1), 1_${ik}$ ) end do ! The Columns Of R Are Scaled To Have Unit Euclidean Lengths - ! [] call stdlib_cpocon( 'u', n, cwork(n+1), n, one, temp1, + ! [] call stdlib${ii}$_cpocon( 'u', n, cwork(n+1), n, one, temp1, ! [] $ cwork(n+n*n+1), rwork, ierr ) - call stdlib_cpocon( 'U', n, cwork, n, one, temp1,cwork(n*n+1), rwork, ierr ) + call stdlib${ii}$_cpocon( 'U', n, cwork, n, one, temp1,cwork(n*n+1), rwork, ierr ) end if if ( temp1 /= zero ) then @@ -75128,15 +75122,15 @@ module stdlib_linalg_lapack_c sconda = - one end if end if - l2pert = l2pert .and. ( abs( a(1,1)/a(nr,nr) ) > sqrt(big1) ) + l2pert = l2pert .and. ( abs( a(1_${ik}$,1_${ik}$)/a(nr,nr) ) > sqrt(big1) ) ! if there is no violent scaling, artificial perturbation is not needed. ! phase 3: if ( .not. ( rsvec .or. lsvec ) ) then ! singular values only ! .. transpose a(1:nr,1:n) do p = 1, min( n-1, nr ) - call stdlib_ccopy( n-p, a(p,p+1), lda, a(p+1,p), 1 ) - call stdlib_clacgv( n-p+1, a(p,p), 1 ) + call stdlib${ii}$_ccopy( n-p, a(p,p+1), lda, a(p+1,p), 1_${ik}$ ) + call stdlib${ii}$_clacgv( n-p+1, a(p,p), 1_${ik}$ ) end do if ( nr == n ) a(n,n) = conjg(a(n,n)) ! the following two do-loops introduce small relative perturbation @@ -75163,14 +75157,14 @@ module stdlib_linalg_lapack_c end do end do else - if (nr>1) call stdlib_claset( 'U', nr-1,nr-1, czero,czero, a(1,2),lda ) + if (nr>1_${ik}$) call stdlib${ii}$_claset( 'U', nr-1,nr-1, czero,czero, a(1_${ik}$,2_${ik}$),lda ) end if ! Second Preconditioning Using The Qr Factorization - call stdlib_cgeqrf( n,nr, a,lda, cwork, cwork(n+1),lwork-n, ierr ) + call stdlib${ii}$_cgeqrf( n,nr, a,lda, cwork, cwork(n+1),lwork-n, ierr ) ! And Transpose Upper To Lower Triangular do p = 1, nr - 1 - call stdlib_ccopy( nr-p, a(p,p+1), lda, a(p+1,p), 1 ) - call stdlib_clacgv( nr-p+1, a(p,p), 1 ) + call stdlib${ii}$_ccopy( nr-p, a(p,p+1), lda, a(p+1,p), 1_${ik}$ ) + call stdlib${ii}$_clacgv( nr-p+1, a(p,p), 1_${ik}$ ) end do end if ! row-cyclic jacobi svd algorithm with column pivoting @@ -75188,107 +75182,107 @@ module stdlib_linalg_lapack_c end do end do else - if (nr>1) call stdlib_claset( 'U', nr-1, nr-1, czero, czero, a(1,2), lda ) + if (nr>1_${ik}$) call stdlib${ii}$_claset( 'U', nr-1, nr-1, czero, czero, a(1_${ik}$,2_${ik}$), lda ) end if ! .. and one-sided jacobi rotations are started on a lower ! triangular matrix (plus perturbation which is ignored in ! the part which destroys triangular form (confusing?!)) - call stdlib_cgesvj( 'L', 'N', 'N', nr, nr, a, lda, sva,n, v, ldv, cwork, lwork, & + call stdlib${ii}$_cgesvj( 'L', 'N', 'N', nr, nr, a, lda, sva,n, v, ldv, cwork, lwork, & rwork, lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) else if ( ( rsvec .and. ( .not. lsvec ) .and. ( .not. jracc ) ).or.( jracc .and. ( & .not. lsvec ) .and. ( nr /= n ) ) ) then ! -> singular values and right singular vectors <- if ( almort ) then ! In This Case Nr Equals N do p = 1, nr - call stdlib_ccopy( n-p+1, a(p,p), lda, v(p,p), 1 ) - call stdlib_clacgv( n-p+1, v(p,p), 1 ) + call stdlib${ii}$_ccopy( n-p+1, a(p,p), lda, v(p,p), 1_${ik}$ ) + call stdlib${ii}$_clacgv( n-p+1, v(p,p), 1_${ik}$ ) end do - if (nr>1) call stdlib_claset( 'U', nr-1,nr-1, czero, czero, v(1,2), ldv ) - call stdlib_cgesvj( 'L','U','N', n, nr, v, ldv, sva, nr, a, lda,cwork, lwork, & + if (nr>1_${ik}$) call stdlib${ii}$_claset( 'U', nr-1,nr-1, czero, czero, v(1_${ik}$,2_${ik}$), ldv ) + call stdlib${ii}$_cgesvj( 'L','U','N', n, nr, v, ldv, sva, nr, a, lda,cwork, lwork, & rwork, lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) else ! .. two more qr factorizations ( one qrf is not enough, two require ! accumulated product of jacobi rotations, three are perfect ) - if (nr>1) call stdlib_claset( 'L', nr-1,nr-1, czero, czero, a(2,1), lda ) - call stdlib_cgelqf( nr,n, a, lda, cwork, cwork(n+1), lwork-n, ierr) - call stdlib_clacpy( 'L', nr, nr, a, lda, v, ldv ) - if (nr>1) call stdlib_claset( 'U', nr-1,nr-1, czero, czero, v(1,2), ldv ) - call stdlib_cgeqrf( nr, nr, v, ldv, cwork(n+1), cwork(2*n+1),lwork-2*n, ierr ) + if (nr>1_${ik}$) call stdlib${ii}$_claset( 'L', nr-1,nr-1, czero, czero, a(2_${ik}$,1_${ik}$), lda ) + call stdlib${ii}$_cgelqf( nr,n, a, lda, cwork, cwork(n+1), lwork-n, ierr) + call stdlib${ii}$_clacpy( 'L', nr, nr, a, lda, v, ldv ) + if (nr>1_${ik}$) call stdlib${ii}$_claset( 'U', nr-1,nr-1, czero, czero, v(1_${ik}$,2_${ik}$), ldv ) + call stdlib${ii}$_cgeqrf( nr, nr, v, ldv, cwork(n+1), cwork(2_${ik}$*n+1),lwork-2*n, ierr ) do p = 1, nr - call stdlib_ccopy( nr-p+1, v(p,p), ldv, v(p,p), 1 ) - call stdlib_clacgv( nr-p+1, v(p,p), 1 ) + call stdlib${ii}$_ccopy( nr-p+1, v(p,p), ldv, v(p,p), 1_${ik}$ ) + call stdlib${ii}$_clacgv( nr-p+1, v(p,p), 1_${ik}$ ) end do - if (nr>1) call stdlib_claset('U', nr-1, nr-1, czero, czero, v(1,2), ldv) - call stdlib_cgesvj( 'L', 'U','N', nr, nr, v,ldv, sva, nr, u,ldu, cwork(n+1), & + if (nr>1_${ik}$) call stdlib${ii}$_claset('U', nr-1, nr-1, czero, czero, v(1_${ik}$,2_${ik}$), ldv) + call stdlib${ii}$_cgesvj( 'L', 'U','N', nr, nr, v,ldv, sva, nr, u,ldu, cwork(n+1), & lwork-n, rwork, lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) if ( nr < n ) then - call stdlib_claset( 'A',n-nr, nr, czero,czero, v(nr+1,1), ldv ) - call stdlib_claset( 'A',nr, n-nr, czero,czero, v(1,nr+1), ldv ) - call stdlib_claset( 'A',n-nr,n-nr,czero,cone, v(nr+1,nr+1),ldv ) + call stdlib${ii}$_claset( 'A',n-nr, nr, czero,czero, v(nr+1,1_${ik}$), ldv ) + call stdlib${ii}$_claset( 'A',nr, n-nr, czero,czero, v(1_${ik}$,nr+1), ldv ) + call stdlib${ii}$_claset( 'A',n-nr,n-nr,czero,cone, v(nr+1,nr+1),ldv ) end if - call stdlib_cunmlq( 'L', 'C', n, n, nr, a, lda, cwork,v, ldv, cwork(n+1), lwork-n, & + call stdlib${ii}$_cunmlq( 'L', 'C', n, n, nr, a, lda, cwork,v, ldv, cwork(n+1), lwork-n, & ierr ) end if ! Permute The Rows Of V ! do 8991 p = 1, n - ! call stdlib_ccopy( n, v(p,1), ldv, a(iwork(p),1), lda ) + ! call stdlib${ii}$_ccopy( n, v(p,1), ldv, a(iwork(p),1), lda ) 8991 continue - ! call stdlib_clacpy( 'all', n, n, a, lda, v, ldv ) - call stdlib_clapmr( .false., n, n, v, ldv, iwork ) + ! call stdlib${ii}$_clacpy( 'all', n, n, a, lda, v, ldv ) + call stdlib${ii}$_clapmr( .false., n, n, v, ldv, iwork ) if ( transp ) then - call stdlib_clacpy( 'A', n, n, v, ldv, u, ldu ) + call stdlib${ii}$_clacpy( 'A', n, n, v, ldv, u, ldu ) end if else if ( jracc .and. (.not. lsvec) .and. ( nr== n ) ) then - if (n>1) call stdlib_claset( 'L', n-1,n-1, czero, czero, a(2,1), lda ) - call stdlib_cgesvj( 'U','N','V', n, n, a, lda, sva, n, v, ldv,cwork, lwork, rwork, & + if (n>1_${ik}$) call stdlib${ii}$_claset( 'L', n-1,n-1, czero, czero, a(2_${ik}$,1_${ik}$), lda ) + call stdlib${ii}$_cgesvj( 'U','N','V', n, n, a, lda, sva, n, v, ldv,cwork, lwork, rwork, & lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) - call stdlib_clapmr( .false., n, n, v, ldv, iwork ) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) + call stdlib${ii}$_clapmr( .false., n, n, v, ldv, iwork ) else if ( lsvec .and. ( .not. rsvec ) ) then ! Singular Values And Left Singular Vectors ! Second Preconditioning Step To Avoid Need To Accumulate ! jacobi rotations in the jacobi iterations. do p = 1, nr - call stdlib_ccopy( n-p+1, a(p,p), lda, u(p,p), 1 ) - call stdlib_clacgv( n-p+1, u(p,p), 1 ) + call stdlib${ii}$_ccopy( n-p+1, a(p,p), lda, u(p,p), 1_${ik}$ ) + call stdlib${ii}$_clacgv( n-p+1, u(p,p), 1_${ik}$ ) end do - if (nr>1) call stdlib_claset( 'U', nr-1, nr-1, czero, czero, u(1,2), ldu ) - call stdlib_cgeqrf( n, nr, u, ldu, cwork(n+1), cwork(2*n+1),lwork-2*n, ierr ) + if (nr>1_${ik}$) call stdlib${ii}$_claset( 'U', nr-1, nr-1, czero, czero, u(1_${ik}$,2_${ik}$), ldu ) + call stdlib${ii}$_cgeqrf( n, nr, u, ldu, cwork(n+1), cwork(2_${ik}$*n+1),lwork-2*n, ierr ) do p = 1, nr - 1 - call stdlib_ccopy( nr-p, u(p,p+1), ldu, u(p+1,p), 1 ) - call stdlib_clacgv( n-p+1, u(p,p), 1 ) + call stdlib${ii}$_ccopy( nr-p, u(p,p+1), ldu, u(p+1,p), 1_${ik}$ ) + call stdlib${ii}$_clacgv( n-p+1, u(p,p), 1_${ik}$ ) end do - if (nr>1) call stdlib_claset( 'U', nr-1, nr-1, czero, czero, u(1,2), ldu ) - call stdlib_cgesvj( 'L', 'U', 'N', nr,nr, u, ldu, sva, nr, a,lda, cwork(n+1), lwork-& + if (nr>1_${ik}$) call stdlib${ii}$_claset( 'U', nr-1, nr-1, czero, czero, u(1_${ik}$,2_${ik}$), ldu ) + call stdlib${ii}$_cgesvj( 'L', 'U', 'N', nr,nr, u, ldu, sva, nr, a,lda, cwork(n+1), lwork-& n, rwork, lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) if ( nr < m ) then - call stdlib_claset( 'A', m-nr, nr,czero, czero, u(nr+1,1), ldu ) + call stdlib${ii}$_claset( 'A', m-nr, nr,czero, czero, u(nr+1,1_${ik}$), ldu ) if ( nr < n1 ) then - call stdlib_claset( 'A',nr, n1-nr, czero, czero, u(1,nr+1),ldu ) - call stdlib_claset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1),ldu ) + call stdlib${ii}$_claset( 'A',nr, n1-nr, czero, czero, u(1_${ik}$,nr+1),ldu ) + call stdlib${ii}$_claset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1),ldu ) end if end if - call stdlib_cunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-n, & + call stdlib${ii}$_cunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-n, & ierr ) - if ( rowpiv )call stdlib_claswp( n1, u, ldu, 1, m-1, iwork(iwoff+1), -1 ) + if ( rowpiv )call stdlib${ii}$_claswp( n1, u, ldu, 1_${ik}$, m-1, iwork(iwoff+1), -1_${ik}$ ) do p = 1, n1 - xsc = one / stdlib_scnrm2( m, u(1,p), 1 ) - call stdlib_csscal( m, xsc, u(1,p), 1 ) + xsc = one / stdlib${ii}$_scnrm2( m, u(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_csscal( m, xsc, u(1_${ik}$,p), 1_${ik}$ ) end do if ( transp ) then - call stdlib_clacpy( 'A', n, n, u, ldu, v, ldv ) + call stdlib${ii}$_clacpy( 'A', n, n, u, ldu, v, ldv ) end if else ! Full Svd @@ -75299,10 +75293,10 @@ module stdlib_linalg_lapack_c ! equivalent to an lqf call. since in many libraries the qrf ! seems to be better optimized than the lqf, we do explicit ! transpose and use the qrf. this is subject to changes in an - ! optimized implementation of stdlib_cgejsv. + ! optimized implementation of stdlib${ii}$_cgejsv. do p = 1, nr - call stdlib_ccopy( n-p+1, a(p,p), lda, v(p,p), 1 ) - call stdlib_clacgv( n-p+1, v(p,p), 1 ) + call stdlib${ii}$_ccopy( n-p+1, a(p,p), lda, v(p,p), 1_${ik}$ ) + call stdlib${ii}$_clacgv( n-p+1, v(p,p), 1_${ik}$ ) end do ! The Following Two Loops Perturb Small Entries To Avoid ! denormals in the second qr factorization, where they are @@ -75327,17 +75321,17 @@ module stdlib_linalg_lapack_c end do end do else - if (nr>1) call stdlib_claset( 'U', nr-1, nr-1, czero, czero, v(1,2), ldv ) + if (nr>1_${ik}$) call stdlib${ii}$_claset( 'U', nr-1, nr-1, czero, czero, v(1_${ik}$,2_${ik}$), ldv ) end if ! estimate the row scaled condition number of r1 ! (if r1 is rectangular, n > nr, then the condition number ! of the leading nr x nr submatrix is estimated.) - call stdlib_clacpy( 'L', nr, nr, v, ldv, cwork(2*n+1), nr ) + call stdlib${ii}$_clacpy( 'L', nr, nr, v, ldv, cwork(2_${ik}$*n+1), nr ) do p = 1, nr - temp1 = stdlib_scnrm2(nr-p+1,cwork(2*n+(p-1)*nr+p),1) - call stdlib_csscal(nr-p+1,one/temp1,cwork(2*n+(p-1)*nr+p),1) + temp1 = stdlib${ii}$_scnrm2(nr-p+1,cwork(2_${ik}$*n+(p-1)*nr+p),1_${ik}$) + call stdlib${ii}$_csscal(nr-p+1,one/temp1,cwork(2_${ik}$*n+(p-1)*nr+p),1_${ik}$) end do - call stdlib_cpocon('L',nr,cwork(2*n+1),nr,one,temp1,cwork(2*n+nr*nr+1),rwork,& + call stdlib${ii}$_cpocon('L',nr,cwork(2_${ik}$*n+1),nr,one,temp1,cwork(2_${ik}$*n+nr*nr+1),rwork,& ierr) condr1 = one / sqrt(temp1) ! Here Need A Second Opinion On The Condition Number @@ -75351,7 +75345,7 @@ module stdlib_linalg_lapack_c ! implementation, this qrf should be implemented as the qrf ! of a lower triangular matrix. ! r1^* = q2 * r2 - call stdlib_cgeqrf( n, nr, v, ldv, cwork(n+1), cwork(2*n+1),lwork-2*n, ierr ) + call stdlib${ii}$_cgeqrf( n, nr, v, ldv, cwork(n+1), cwork(2_${ik}$*n+1),lwork-2*n, ierr ) if ( l2pert ) then xsc = sqrt(small)/epsln @@ -75363,13 +75357,13 @@ module stdlib_linalg_lapack_c end do end do end if - if ( nr /= n )call stdlib_clacpy( 'A', n, nr, v, ldv, cwork(2*n+1), n ) + if ( nr /= n )call stdlib${ii}$_clacpy( 'A', n, nr, v, ldv, cwork(2_${ik}$*n+1), n ) ! .. save ... ! This Transposed Copy Should Be Better Than Naive do p = 1, nr - 1 - call stdlib_ccopy( nr-p, v(p,p+1), ldv, v(p+1,p), 1 ) - call stdlib_clacgv(nr-p+1, v(p,p), 1 ) + call stdlib${ii}$_ccopy( nr-p, v(p,p+1), ldv, v(p+1,p), 1_${ik}$ ) + call stdlib${ii}$_clacgv(nr-p+1, v(p,p), 1_${ik}$ ) end do v(nr,nr)=conjg(v(nr,nr)) condr2 = condr1 @@ -75377,16 +75371,16 @@ module stdlib_linalg_lapack_c ! .. ill-conditioned case: second qrf with pivoting ! note that windowed pivoting would be equally good ! numerically, and more run-time efficient. so, in - ! an optimal implementation, the next call to stdlib_cgeqp3 + ! an optimal implementation, the next call to stdlib${ii}$_cgeqp3 ! should be replaced with eg. call cgeqpx (acm toms #782) ! with properly (carefully) chosen parameters. ! r1^* * p2 = q2 * r2 do p = 1, nr - iwork(n+p) = 0 + iwork(n+p) = 0_${ik}$ end do - call stdlib_cgeqp3( n, nr, v, ldv, iwork(n+1), cwork(n+1),cwork(2*n+1), lwork-& - 2*n, rwork, ierr ) - ! * call stdlib_cgeqrf( n, nr, v, ldv, cwork(n+1), cwork(2*n+1), + call stdlib${ii}$_cgeqp3( n, nr, v, ldv, iwork(n+1), cwork(n+1),cwork(2_${ik}$*n+1), lwork-& + 2_${ik}$*n, rwork, ierr ) + ! * call stdlib${ii}$_cgeqrf( n, nr, v, ldv, cwork(n+1), cwork(2*n+1), ! * $ lwork-2*n, ierr ) if ( l2pert ) then xsc = sqrt(small) @@ -75398,7 +75392,7 @@ module stdlib_linalg_lapack_c end do end do end if - call stdlib_clacpy( 'A', n, nr, v, ldv, cwork(2*n+1), n ) + call stdlib${ii}$_clacpy( 'A', n, nr, v, ldv, cwork(2_${ik}$*n+1), n ) if ( l2pert ) then xsc = sqrt(small) do p = 2, nr @@ -75409,18 +75403,18 @@ module stdlib_linalg_lapack_c end do end do else - if (nr>1) call stdlib_claset( 'L',nr-1,nr-1,czero,czero,v(2,1),ldv ) + if (nr>1_${ik}$) call stdlib${ii}$_claset( 'L',nr-1,nr-1,czero,czero,v(2_${ik}$,1_${ik}$),ldv ) end if ! now, compute r2 = l3 * q3, the lq factorization. - call stdlib_cgelqf( nr, nr, v, ldv, cwork(2*n+n*nr+1),cwork(2*n+n*nr+nr+1), & + call stdlib${ii}$_cgelqf( nr, nr, v, ldv, cwork(2_${ik}$*n+n*nr+1),cwork(2_${ik}$*n+n*nr+nr+1), & lwork-2*n-n*nr-nr, ierr ) ! And Estimate The Condition Number - call stdlib_clacpy( 'L',nr,nr,v,ldv,cwork(2*n+n*nr+nr+1),nr ) + call stdlib${ii}$_clacpy( 'L',nr,nr,v,ldv,cwork(2_${ik}$*n+n*nr+nr+1),nr ) do p = 1, nr - temp1 = stdlib_scnrm2( p, cwork(2*n+n*nr+nr+p), nr ) - call stdlib_csscal( p, one/temp1, cwork(2*n+n*nr+nr+p), nr ) + temp1 = stdlib${ii}$_scnrm2( p, cwork(2_${ik}$*n+n*nr+nr+p), nr ) + call stdlib${ii}$_csscal( p, one/temp1, cwork(2_${ik}$*n+n*nr+nr+p), nr ) end do - call stdlib_cpocon( 'L',nr,cwork(2*n+n*nr+nr+1),nr,one,temp1,cwork(2*n+n*nr+& + call stdlib${ii}$_cpocon( 'L',nr,cwork(2_${ik}$*n+n*nr+nr+1),nr,one,temp1,cwork(2_${ik}$*n+n*nr+& nr+nr*nr+1),rwork,ierr ) condr2 = one / sqrt(temp1) if ( condr2 >= cond_ok ) then @@ -75428,7 +75422,7 @@ module stdlib_linalg_lapack_c ! (this overwrites the copy of r2, as it will not be ! needed in this branch, but it does not overwritte the ! huseholder vectors of q2.). - call stdlib_clacpy( 'U', nr, nr, v, ldv, cwork(2*n+1), n ) + call stdlib${ii}$_clacpy( 'U', nr, nr, v, ldv, cwork(2_${ik}$*n+1), n ) ! And The Rest Of The Information On Q3 Is In ! work(2*n+n*nr+1:2*n+n*nr+n) end if @@ -75443,71 +75437,71 @@ module stdlib_linalg_lapack_c end do end do else - if (nr>1) call stdlib_claset( 'U', nr-1,nr-1, czero,czero, v(1,2), ldv ) + if (nr>1_${ik}$) call stdlib${ii}$_claset( 'U', nr-1,nr-1, czero,czero, v(1_${ik}$,2_${ik}$), ldv ) end if ! second preconditioning finished; continue with jacobi svd ! the input matrix is lower trinagular. ! recover the right singular vectors as solution of a well ! conditioned triangular matrix equation. if ( condr1 < cond_ok ) then - call stdlib_cgesvj( 'L','U','N',nr,nr,v,ldv,sva,nr,u, ldu,cwork(2*n+n*nr+nr+1)& + call stdlib${ii}$_cgesvj( 'L','U','N',nr,nr,v,ldv,sva,nr,u, ldu,cwork(2_${ik}$*n+n*nr+nr+1)& ,lwork-2*n-n*nr-nr,rwork,lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) do p = 1, nr - call stdlib_ccopy( nr, v(1,p), 1, u(1,p), 1 ) - call stdlib_csscal( nr, sva(p), v(1,p), 1 ) + call stdlib${ii}$_ccopy( nr, v(1_${ik}$,p), 1_${ik}$, u(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_csscal( nr, sva(p), v(1_${ik}$,p), 1_${ik}$ ) end do ! Pick The Right Matrix Equation And Solve It if ( nr == n ) then ! :)) .. best case, r1 is inverted. the solution of this matrix ! equation is q2*v2 = the product of the jacobi rotations - ! used in stdlib_cgesvj, premultiplied with the orthogonal matrix + ! used in stdlib${ii}$_cgesvj, premultiplied with the orthogonal matrix ! from the second qr factorization. - call stdlib_ctrsm('L','U','N','N', nr,nr,cone, a,lda, v,ldv) + call stdlib${ii}$_ctrsm('L','U','N','N', nr,nr,cone, a,lda, v,ldv) else ! .. r1 is well conditioned, but non-square. adjoint of r2 ! is inverted to get the product of the jacobi rotations - ! used in stdlib_cgesvj. the q-factor from the second qr + ! used in stdlib${ii}$_cgesvj. the q-factor from the second qr ! factorization is then built in explicitly. - call stdlib_ctrsm('L','U','C','N',nr,nr,cone,cwork(2*n+1),n,v,ldv) + call stdlib${ii}$_ctrsm('L','U','C','N',nr,nr,cone,cwork(2_${ik}$*n+1),n,v,ldv) if ( nr < n ) then - call stdlib_claset('A',n-nr,nr,czero,czero,v(nr+1,1),ldv) - call stdlib_claset('A',nr,n-nr,czero,czero,v(1,nr+1),ldv) - call stdlib_claset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) + call stdlib${ii}$_claset('A',n-nr,nr,czero,czero,v(nr+1,1_${ik}$),ldv) + call stdlib${ii}$_claset('A',nr,n-nr,czero,czero,v(1_${ik}$,nr+1),ldv) + call stdlib${ii}$_claset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) end if - call stdlib_cunmqr('L','N',n,n,nr,cwork(2*n+1),n,cwork(n+1),v,ldv,cwork(& - 2*n+n*nr+nr+1),lwork-2*n-n*nr-nr,ierr) + call stdlib${ii}$_cunmqr('L','N',n,n,nr,cwork(2_${ik}$*n+1),n,cwork(n+1),v,ldv,cwork(& + 2_${ik}$*n+n*nr+nr+1),lwork-2*n-n*nr-nr,ierr) end if else if ( condr2 < cond_ok ) then ! the matrix r2 is inverted. the solution of the matrix equation ! is q3^* * v3 = the product of the jacobi rotations (appplied to ! the lower triangular l3 from the lq factorization of ! r2=l3*q3), pre-multiplied with the transposed q3. - call stdlib_cgesvj( 'L', 'U', 'N', nr, nr, v, ldv, sva, nr, u,ldu, cwork(2*n+& + call stdlib${ii}$_cgesvj( 'L', 'U', 'N', nr, nr, v, ldv, sva, nr, u,ldu, cwork(2_${ik}$*n+& n*nr+nr+1), lwork-2*n-n*nr-nr,rwork, lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) do p = 1, nr - call stdlib_ccopy( nr, v(1,p), 1, u(1,p), 1 ) - call stdlib_csscal( nr, sva(p), u(1,p), 1 ) + call stdlib${ii}$_ccopy( nr, v(1_${ik}$,p), 1_${ik}$, u(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_csscal( nr, sva(p), u(1_${ik}$,p), 1_${ik}$ ) end do - call stdlib_ctrsm('L','U','N','N',nr,nr,cone,cwork(2*n+1),n,u,ldu) + call stdlib${ii}$_ctrsm('L','U','N','N',nr,nr,cone,cwork(2_${ik}$*n+1),n,u,ldu) ! Apply The Permutation From The Second Qr Factorization do q = 1, nr do p = 1, nr - cwork(2*n+n*nr+nr+iwork(n+p)) = u(p,q) + cwork(2_${ik}$*n+n*nr+nr+iwork(n+p)) = u(p,q) end do do p = 1, nr - u(p,q) = cwork(2*n+n*nr+nr+p) + u(p,q) = cwork(2_${ik}$*n+n*nr+nr+p) end do end do if ( nr < n ) then - call stdlib_claset( 'A',n-nr,nr,czero,czero,v(nr+1,1),ldv ) - call stdlib_claset( 'A',nr,n-nr,czero,czero,v(1,nr+1),ldv ) - call stdlib_claset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) + call stdlib${ii}$_claset( 'A',n-nr,nr,czero,czero,v(nr+1,1_${ik}$),ldv ) + call stdlib${ii}$_claset( 'A',nr,n-nr,czero,czero,v(1_${ik}$,nr+1),ldv ) + call stdlib${ii}$_claset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) end if - call stdlib_cunmqr( 'L','N',n,n,nr,cwork(2*n+1),n,cwork(n+1),v,ldv,cwork(2*n+& + call stdlib${ii}$_cunmqr( 'L','N',n,n,nr,cwork(2_${ik}$*n+1),n,cwork(n+1),v,ldv,cwork(2_${ik}$*n+& n*nr+nr+1),lwork-2*n-n*nr-nr,ierr ) else ! last line of defense. @@ -75518,28 +75512,28 @@ module stdlib_linalg_lapack_c ! is set very close to one (which is unnecessary). normally, ! this branch should never be executed, but in rare cases of ! failure of the rrqr or condition estimator, the last line of - ! defense ensures that stdlib_cgejsv completes the task. - ! compute the full svd of l3 using stdlib_cgesvj with explicit + ! defense ensures that stdlib${ii}$_cgejsv completes the task. + ! compute the full svd of l3 using stdlib${ii}$_cgesvj with explicit ! accumulation of jacobi rotations. - call stdlib_cgesvj( 'L', 'U', 'V', nr, nr, v, ldv, sva, nr, u,ldu, cwork(2*n+& + call stdlib${ii}$_cgesvj( 'L', 'U', 'V', nr, nr, v, ldv, sva, nr, u,ldu, cwork(2_${ik}$*n+& n*nr+nr+1), lwork-2*n-n*nr-nr,rwork, lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) if ( nr < n ) then - call stdlib_claset( 'A',n-nr,nr,czero,czero,v(nr+1,1),ldv ) - call stdlib_claset( 'A',nr,n-nr,czero,czero,v(1,nr+1),ldv ) - call stdlib_claset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) + call stdlib${ii}$_claset( 'A',n-nr,nr,czero,czero,v(nr+1,1_${ik}$),ldv ) + call stdlib${ii}$_claset( 'A',nr,n-nr,czero,czero,v(1_${ik}$,nr+1),ldv ) + call stdlib${ii}$_claset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) end if - call stdlib_cunmqr( 'L','N',n,n,nr,cwork(2*n+1),n,cwork(n+1),v,ldv,cwork(2*n+& + call stdlib${ii}$_cunmqr( 'L','N',n,n,nr,cwork(2_${ik}$*n+1),n,cwork(n+1),v,ldv,cwork(2_${ik}$*n+& n*nr+nr+1),lwork-2*n-n*nr-nr,ierr ) - call stdlib_cunmlq( 'L', 'C', nr, nr, nr, cwork(2*n+1), n,cwork(2*n+n*nr+1), & - u, ldu, cwork(2*n+n*nr+nr+1),lwork-2*n-n*nr-nr, ierr ) + call stdlib${ii}$_cunmlq( 'L', 'C', nr, nr, nr, cwork(2_${ik}$*n+1), n,cwork(2_${ik}$*n+n*nr+1), & + u, ldu, cwork(2_${ik}$*n+n*nr+nr+1),lwork-2*n-n*nr-nr, ierr ) do q = 1, nr do p = 1, nr - cwork(2*n+n*nr+nr+iwork(n+p)) = u(p,q) + cwork(2_${ik}$*n+n*nr+nr+iwork(n+p)) = u(p,q) end do do p = 1, nr - u(p,q) = cwork(2*n+n*nr+nr+p) + u(p,q) = cwork(2_${ik}$*n+n*nr+nr+p) end do end do end if @@ -75549,42 +75543,42 @@ module stdlib_linalg_lapack_c temp1 = sqrt(real(n,KIND=sp)) * epsln do q = 1, n do p = 1, n - cwork(2*n+n*nr+nr+iwork(p)) = v(p,q) + cwork(2_${ik}$*n+n*nr+nr+iwork(p)) = v(p,q) end do do p = 1, n - v(p,q) = cwork(2*n+n*nr+nr+p) + v(p,q) = cwork(2_${ik}$*n+n*nr+nr+p) end do - xsc = one / stdlib_scnrm2( n, v(1,q), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_csscal( n, xsc,& - v(1,q), 1 ) + xsc = one / stdlib${ii}$_scnrm2( n, v(1_${ik}$,q), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_csscal( n, xsc,& + v(1_${ik}$,q), 1_${ik}$ ) end do ! at this moment, v contains the right singular vectors of a. ! next, assemble the left singular vector matrix u (m x n). if ( nr < m ) then - call stdlib_claset('A', m-nr, nr, czero, czero, u(nr+1,1), ldu) + call stdlib${ii}$_claset('A', m-nr, nr, czero, czero, u(nr+1,1_${ik}$), ldu) if ( nr < n1 ) then - call stdlib_claset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) - call stdlib_claset('A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1),ldu) + call stdlib${ii}$_claset('A',nr,n1-nr,czero,czero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_claset('A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1),ldu) end if end if ! the q matrix from the first qrf is built into the left singular ! matrix u. this applies to all cases. - call stdlib_cunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-& + call stdlib${ii}$_cunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-& n, ierr ) ! the columns of u are normalized. the cost is o(m*n) flops. temp1 = sqrt(real(m,KIND=sp)) * epsln do p = 1, nr - xsc = one / stdlib_scnrm2( m, u(1,p), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_csscal( m, xsc,& - u(1,p), 1 ) + xsc = one / stdlib${ii}$_scnrm2( m, u(1_${ik}$,p), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_csscal( m, xsc,& + u(1_${ik}$,p), 1_${ik}$ ) end do ! if the initial qrf is computed with row pivoting, the left ! singular vectors must be adjusted. - if ( rowpiv )call stdlib_claswp( n1, u, ldu, 1, m-1, iwork(iwoff+1), -1 ) + if ( rowpiv )call stdlib${ii}$_claswp( n1, u, ldu, 1_${ik}$, m-1, iwork(iwoff+1), -1_${ik}$ ) else ! The Initial Matrix A Has Almost Orthogonal Columns And ! the second qrf is not needed - call stdlib_clacpy( 'U', n, n, a, lda, cwork(n+1), n ) + call stdlib${ii}$_clacpy( 'U', n, n, a, lda, cwork(n+1), n ) if ( l2pert ) then xsc = sqrt(small) do p = 2, n @@ -75596,43 +75590,43 @@ module stdlib_linalg_lapack_c end do end do else - call stdlib_claset( 'L',n-1,n-1,czero,czero,cwork(n+2),n ) + call stdlib${ii}$_claset( 'L',n-1,n-1,czero,czero,cwork(n+2),n ) end if - call stdlib_cgesvj( 'U', 'U', 'N', n, n, cwork(n+1), n, sva,n, u, ldu, cwork(n+& + call stdlib${ii}$_cgesvj( 'U', 'U', 'N', n, n, cwork(n+1), n, sva,n, u, ldu, cwork(n+& n*n+1), lwork-n-n*n, rwork, lrwork,info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) do p = 1, n - call stdlib_ccopy( n, cwork(n+(p-1)*n+1), 1, u(1,p), 1 ) - call stdlib_csscal( n, sva(p), cwork(n+(p-1)*n+1), 1 ) + call stdlib${ii}$_ccopy( n, cwork(n+(p-1)*n+1), 1_${ik}$, u(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_csscal( n, sva(p), cwork(n+(p-1)*n+1), 1_${ik}$ ) end do - call stdlib_ctrsm( 'L', 'U', 'N', 'N', n, n,cone, a, lda, cwork(n+1), n ) + call stdlib${ii}$_ctrsm( 'L', 'U', 'N', 'N', n, n,cone, a, lda, cwork(n+1), n ) do p = 1, n - call stdlib_ccopy( n, cwork(n+p), n, v(iwork(p),1), ldv ) + call stdlib${ii}$_ccopy( n, cwork(n+p), n, v(iwork(p),1_${ik}$), ldv ) end do temp1 = sqrt(real(n,KIND=sp))*epsln do p = 1, n - xsc = one / stdlib_scnrm2( n, v(1,p), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_csscal( n, xsc,& - v(1,p), 1 ) + xsc = one / stdlib${ii}$_scnrm2( n, v(1_${ik}$,p), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_csscal( n, xsc,& + v(1_${ik}$,p), 1_${ik}$ ) end do ! assemble the left singular vector matrix u (m x n). if ( n < m ) then - call stdlib_claset( 'A', m-n, n, czero, czero, u(n+1,1), ldu ) + call stdlib${ii}$_claset( 'A', m-n, n, czero, czero, u(n+1,1_${ik}$), ldu ) if ( n < n1 ) then - call stdlib_claset('A',n, n1-n, czero, czero, u(1,n+1),ldu) - call stdlib_claset( 'A',m-n,n1-n, czero, cone,u(n+1,n+1),ldu) + call stdlib${ii}$_claset('A',n, n1-n, czero, czero, u(1_${ik}$,n+1),ldu) + call stdlib${ii}$_claset( 'A',m-n,n1-n, czero, cone,u(n+1,n+1),ldu) end if end if - call stdlib_cunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-& + call stdlib${ii}$_cunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-& n, ierr ) temp1 = sqrt(real(m,KIND=sp))*epsln do p = 1, n1 - xsc = one / stdlib_scnrm2( m, u(1,p), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_csscal( m, xsc,& - u(1,p), 1 ) + xsc = one / stdlib${ii}$_scnrm2( m, u(1_${ik}$,p), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_csscal( m, xsc,& + u(1_${ik}$,p), 1_${ik}$ ) end do - if ( rowpiv )call stdlib_claswp( n1, u, ldu, 1, m-1, iwork(iwoff+1), -1 ) + if ( rowpiv )call stdlib${ii}$_claswp( n1, u, ldu, 1_${ik}$, m-1, iwork(iwoff+1), -1_${ik}$ ) end if ! end of the >> almost orthogonal case << in the full svd else @@ -75647,8 +75641,8 @@ module stdlib_linalg_lapack_c ! in presence of extreme values, e.g. when the singular values spread from ! the underflow to the overflow threshold. do p = 1, nr - call stdlib_ccopy( n-p+1, a(p,p), lda, v(p,p), 1 ) - call stdlib_clacgv( n-p+1, v(p,p), 1 ) + call stdlib${ii}$_ccopy( n-p+1, a(p,p), lda, v(p,p), 1_${ik}$ ) + call stdlib${ii}$_clacgv( n-p+1, v(p,p), 1_${ik}$ ) end do if ( l2pert ) then xsc = sqrt(small/epsln) @@ -75662,14 +75656,14 @@ module stdlib_linalg_lapack_c end do end do else - if (nr>1) call stdlib_claset( 'U', nr-1, nr-1, czero, czero, v(1,2), ldv ) + if (nr>1_${ik}$) call stdlib${ii}$_claset( 'U', nr-1, nr-1, czero, czero, v(1_${ik}$,2_${ik}$), ldv ) end if - call stdlib_cgeqrf( n, nr, v, ldv, cwork(n+1), cwork(2*n+1),lwork-2*n, ierr ) + call stdlib${ii}$_cgeqrf( n, nr, v, ldv, cwork(n+1), cwork(2_${ik}$*n+1),lwork-2*n, ierr ) - call stdlib_clacpy( 'L', n, nr, v, ldv, cwork(2*n+1), n ) + call stdlib${ii}$_clacpy( 'L', n, nr, v, ldv, cwork(2_${ik}$*n+1), n ) do p = 1, nr - call stdlib_ccopy( nr-p+1, v(p,p), ldv, u(p,p), 1 ) - call stdlib_clacgv( nr-p+1, u(p,p), 1 ) + call stdlib${ii}$_ccopy( nr-p+1, v(p,p), ldv, u(p,p), 1_${ik}$ ) + call stdlib${ii}$_clacgv( nr-p+1, u(p,p), 1_${ik}$ ) end do if ( l2pert ) then xsc = sqrt(small/epsln) @@ -75681,18 +75675,18 @@ module stdlib_linalg_lapack_c end do end do else - if (nr>1) call stdlib_claset('U', nr-1, nr-1, czero, czero, u(1,2), ldu ) + if (nr>1_${ik}$) call stdlib${ii}$_claset('U', nr-1, nr-1, czero, czero, u(1_${ik}$,2_${ik}$), ldu ) end if - call stdlib_cgesvj( 'L', 'U', 'V', nr, nr, u, ldu, sva,n, v, ldv, cwork(2*n+n*nr+1),& + call stdlib${ii}$_cgesvj( 'L', 'U', 'V', nr, nr, u, ldu, sva,n, v, ldv, cwork(2_${ik}$*n+n*nr+1),& lwork-2*n-n*nr,rwork, lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) if ( nr < n ) then - call stdlib_claset( 'A',n-nr,nr,czero,czero,v(nr+1,1),ldv ) - call stdlib_claset( 'A',nr,n-nr,czero,czero,v(1,nr+1),ldv ) - call stdlib_claset( 'A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv ) + call stdlib${ii}$_claset( 'A',n-nr,nr,czero,czero,v(nr+1,1_${ik}$),ldv ) + call stdlib${ii}$_claset( 'A',nr,n-nr,czero,czero,v(1_${ik}$,nr+1),ldv ) + call stdlib${ii}$_claset( 'A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv ) end if - call stdlib_cunmqr( 'L','N',n,n,nr,cwork(2*n+1),n,cwork(n+1),v,ldv,cwork(2*n+n*nr+& + call stdlib${ii}$_cunmqr( 'L','N',n,n,nr,cwork(2_${ik}$*n+1),n,cwork(n+1),v,ldv,cwork(2_${ik}$*n+n*nr+& nr+1),lwork-2*n-n*nr-nr,ierr ) ! permute the rows of v using the (column) permutation from the ! first qrf. also, scale the columns to make them unit in @@ -75700,39 +75694,39 @@ module stdlib_linalg_lapack_c temp1 = sqrt(real(n,KIND=sp)) * epsln do q = 1, n do p = 1, n - cwork(2*n+n*nr+nr+iwork(p)) = v(p,q) + cwork(2_${ik}$*n+n*nr+nr+iwork(p)) = v(p,q) end do do p = 1, n - v(p,q) = cwork(2*n+n*nr+nr+p) + v(p,q) = cwork(2_${ik}$*n+n*nr+nr+p) end do - xsc = one / stdlib_scnrm2( n, v(1,q), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_csscal( n, xsc,& - v(1,q), 1 ) + xsc = one / stdlib${ii}$_scnrm2( n, v(1_${ik}$,q), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_csscal( n, xsc,& + v(1_${ik}$,q), 1_${ik}$ ) end do ! at this moment, v contains the right singular vectors of a. ! next, assemble the left singular vector matrix u (m x n). if ( nr < m ) then - call stdlib_claset( 'A', m-nr, nr, czero, czero, u(nr+1,1), ldu ) + call stdlib${ii}$_claset( 'A', m-nr, nr, czero, czero, u(nr+1,1_${ik}$), ldu ) if ( nr < n1 ) then - call stdlib_claset('A',nr, n1-nr, czero, czero, u(1,nr+1),ldu) - call stdlib_claset('A',m-nr,n1-nr, czero, cone,u(nr+1,nr+1),ldu) + call stdlib${ii}$_claset('A',nr, n1-nr, czero, czero, u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_claset('A',m-nr,n1-nr, czero, cone,u(nr+1,nr+1),ldu) end if end if - call stdlib_cunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-n, & + call stdlib${ii}$_cunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-n, & ierr ) - if ( rowpiv )call stdlib_claswp( n1, u, ldu, 1, m-1, iwork(iwoff+1), -1 ) + if ( rowpiv )call stdlib${ii}$_claswp( n1, u, ldu, 1_${ik}$, m-1, iwork(iwoff+1), -1_${ik}$ ) end if if ( transp ) then ! .. swap u and v because the procedure worked on a^* do p = 1, n - call stdlib_cswap( n, u(1,p), 1, v(1,p), 1 ) + call stdlib${ii}$_cswap( n, u(1_${ik}$,p), 1_${ik}$, v(1_${ik}$,p), 1_${ik}$ ) end do end if end if ! end of the full svd ! undo scaling, if necessary (and possible) - if ( uscal2 <= (big/sva(1))*uscal1 ) then - call stdlib_slascl( 'G', 0, 0, uscal1, uscal2, nr, 1, sva, n, ierr ) + if ( uscal2 <= (big/sva(1_${ik}$))*uscal1 ) then + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, uscal1, uscal2, nr, 1_${ik}$, sva, n, ierr ) uscal1 = one uscal2 = one end if @@ -75741,30 +75735,30 @@ module stdlib_linalg_lapack_c sva(p) = zero end do end if - rwork(1) = uscal2 * scalem - rwork(2) = uscal1 - if ( errest ) rwork(3) = sconda + rwork(1_${ik}$) = uscal2 * scalem + rwork(2_${ik}$) = uscal1 + if ( errest ) rwork(3_${ik}$) = sconda if ( lsvec .and. rsvec ) then - rwork(4) = condr1 - rwork(5) = condr2 + rwork(4_${ik}$) = condr1 + rwork(5_${ik}$) = condr2 end if if ( l2tran ) then - rwork(6) = entra - rwork(7) = entrat + rwork(6_${ik}$) = entra + rwork(7_${ik}$) = entrat end if - iwork(1) = nr - iwork(2) = numrank - iwork(3) = warning + iwork(1_${ik}$) = nr + iwork(2_${ik}$) = numrank + iwork(3_${ik}$) = warning if ( transp ) then - iwork(4) = 1 + iwork(4_${ik}$) = 1_${ik}$ else - iwork(4) = -1 + iwork(4_${ik}$) = -1_${ik}$ end if return - end subroutine stdlib_cgejsv + end subroutine stdlib${ii}$_cgejsv - pure subroutine stdlib_cgesvj( joba, jobu, jobv, m, n, a, lda, sva, mv, v,ldv, cwork, lwork, & + pure subroutine stdlib${ii}$_cgesvj( joba, jobu, jobv, m, n, a, lda, sva, mv, v,ldv, cwork, lwork, & !! CGESVJ computes the singular value decomposition (SVD) of a complex !! M-by-N matrix A, where M >= N. The SVD of A is written as !! [++] [xx] [x0] [xx] @@ -75779,8 +75773,8 @@ module stdlib_linalg_lapack_c ! -- 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, ldv, lwork, lrwork, m, mv, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldv, lwork, lrwork, m, mv, n character, intent(in) :: joba, jobu, jobv ! Array Arguments complex(sp), intent(inout) :: a(lda,*), v(ldv,*), cwork(lwork) @@ -75788,7 +75782,7 @@ module stdlib_linalg_lapack_c real(sp), intent(out) :: sva(n) ! ===================================================================== ! Local Parameters - integer(ilp), parameter :: nsweep = 30 + integer(${ik}$), parameter :: nsweep = 30_${ik}$ @@ -75797,7 +75791,7 @@ module stdlib_linalg_lapack_c real(sp) :: aapp, aapp0, aapq1, aaqq, apoaq, aqoap, big, bigtheta, cs, ctol, epsln, & mxaapq, mxsinj, rootbig, rooteps, rootsfmin, roottol, skl, sfmin, small, sn, t, temp1, & theta, thsign, tol - integer(ilp) :: blskip, emptsw, i, ibr, ierr, igl, ijblsk, ir1, iswrot, jbc, jgl, kbl, & + integer(${ik}$) :: blskip, emptsw, i, ibr, ierr, igl, ijblsk, ir1, iswrot, jbc, jgl, kbl, & lkahead, mvl, n2, n34, n4, nbl, notrot, p, pskipped, q, rowskip, swband logical(lk) :: applv, goscale, lower, lquery, lsvec, noscale, rotok, rsvec, uctol, & upper @@ -75813,39 +75807,39 @@ module stdlib_linalg_lapack_c applv = stdlib_lsame( jobv, 'A' ) upper = stdlib_lsame( joba, 'U' ) lower = stdlib_lsame( joba, 'L' ) - lquery = ( lwork == -1 ) .or. ( lrwork == -1 ) + lquery = ( lwork == -1_${ik}$ ) .or. ( lrwork == -1_${ik}$ ) if( .not.( upper .or. lower .or. stdlib_lsame( joba, 'G' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( lsvec .or. uctol .or. stdlib_lsame( jobu, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( rsvec .or. applv .or. stdlib_lsame( jobv, 'N' ) ) ) then - info = -3 - else if( m<0 ) then - info = -4 - else if( ( n<0 ) .or. ( n>m ) ) then - info = -5 + info = -3_${ik}$ + else if( m<0_${ik}$ ) then + info = -4_${ik}$ + else if( ( n<0_${ik}$ ) .or. ( n>m ) ) then + info = -5_${ik}$ else if( lda=one ) then - info = -4 - call stdlib_xerbla( 'CGESVJ', -info ) + info = -4_${ik}$ + call stdlib${ii}$_xerbla( 'CGESVJ', -info ) return end if ! initialize the right singular vector matrix. if( rsvec ) then mvl = n - call stdlib_claset( 'A', mvl, n, czero, cone, v, ldv ) + call stdlib${ii}$_claset( 'A', mvl, n, czero, cone, v, ldv ) else if( applv ) then mvl = mv end if @@ -75908,10 +75902,10 @@ module stdlib_linalg_lapack_c do p = 1, n aapp = zero aaqq = one - call stdlib_classq( m-p+1, a( p, p ), 1, aapp, aaqq ) + call stdlib${ii}$_classq( m-p+1, a( p, p ), 1_${ik}$, aapp, aaqq ) if( aapp>big ) then - info = -6 - call stdlib_xerbla( 'CGESVJ', -info ) + info = -6_${ik}$ + call stdlib${ii}$_xerbla( 'CGESVJ', -info ) return end if aaqq = sqrt( aaqq ) @@ -75933,10 +75927,10 @@ module stdlib_linalg_lapack_c do p = 1, n aapp = zero aaqq = one - call stdlib_classq( p, a( 1, p ), 1, aapp, aaqq ) + call stdlib${ii}$_classq( p, a( 1_${ik}$, p ), 1_${ik}$, aapp, aaqq ) if( aapp>big ) then - info = -6 - call stdlib_xerbla( 'CGESVJ', -info ) + info = -6_${ik}$ + call stdlib${ii}$_xerbla( 'CGESVJ', -info ) return end if aaqq = sqrt( aaqq ) @@ -75958,10 +75952,10 @@ module stdlib_linalg_lapack_c do p = 1, n aapp = zero aaqq = one - call stdlib_classq( m, a( 1, p ), 1, aapp, aaqq ) + call stdlib${ii}$_classq( m, a( 1_${ik}$, p ), 1_${ik}$, aapp, aaqq ) if( aapp>big ) then - info = -6 - call stdlib_xerbla( 'CGESVJ', -info ) + info = -6_${ik}$ + call stdlib${ii}$_xerbla( 'CGESVJ', -info ) return end if aaqq = sqrt( aaqq ) @@ -75991,29 +75985,29 @@ module stdlib_linalg_lapack_c end do ! #:) quick return for zero matrix if( aapp==zero ) then - if( lsvec )call stdlib_claset( 'G', m, n, czero, cone, a, lda ) - rwork( 1 ) = one - rwork( 2 ) = zero - rwork( 3 ) = zero - rwork( 4 ) = zero - rwork( 5 ) = zero - rwork( 6 ) = zero + if( lsvec )call stdlib${ii}$_claset( 'G', m, n, czero, cone, a, lda ) + rwork( 1_${ik}$ ) = one + rwork( 2_${ik}$ ) = zero + rwork( 3_${ik}$ ) = zero + rwork( 4_${ik}$ ) = zero + rwork( 5_${ik}$ ) = zero + rwork( 6_${ik}$ ) = zero return end if ! #:) quick return for one-column matrix - if( n==1 ) then - if( lsvec )call stdlib_clascl( 'G', 0, 0, sva( 1 ), skl, m, 1,a( 1, 1 ), lda, ierr ) + if( n==1_${ik}$ ) then + if( lsvec )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, sva( 1_${ik}$ ), skl, m, 1_${ik}$,a( 1_${ik}$, 1_${ik}$ ), lda, ierr ) - rwork( 1 ) = one / skl - if( sva( 1 )>=sfmin ) then - rwork( 2 ) = one + rwork( 1_${ik}$ ) = one / skl + if( sva( 1_${ik}$ )>=sfmin ) then + rwork( 2_${ik}$ ) = one else - rwork( 2 ) = zero + rwork( 2_${ik}$ ) = zero end if - rwork( 3 ) = zero - rwork( 4 ) = zero - rwork( 5 ) = zero - rwork( 6 ) = zero + rwork( 3_${ik}$ ) = zero + rwork( 4_${ik}$ ) = zero + rwork( 5_${ik}$ ) = zero + rwork( 6_${ik}$ ) = zero return end if ! protect small singular values from underflow, and try to @@ -76042,53 +76036,53 @@ module stdlib_linalg_lapack_c end if ! scale, if necessary if( temp1/=one ) then - call stdlib_slascl( 'G', 0, 0, one, temp1, n, 1, sva, n, ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, one, temp1, n, 1_${ik}$, sva, n, ierr ) end if skl = temp1*skl if( skl/=one ) then - call stdlib_clascl( joba, 0, 0, one, skl, m, n, a, lda, ierr ) + call stdlib${ii}$_clascl( joba, 0_${ik}$, 0_${ik}$, one, skl, m, n, a, lda, ierr ) skl = one / skl end if ! row-cyclic jacobi svd algorithm with column pivoting - emptsw = ( n*( n-1 ) ) / 2 - notrot = 0 + emptsw = ( n*( n-1 ) ) / 2_${ik}$ + notrot = 0_${ik}$ do q = 1, n cwork( q ) = cone end do - swband = 3 + swband = 3_${ik}$ ! [tp] swband is a tuning parameter [tp]. it is meaningful and effective - ! if stdlib_cgesvj is used as a computational routine in the preconditioned - ! jacobi svd algorithm stdlib_cgejsv. for sweeps i=1:swband the procedure + ! if stdlib${ii}$_cgesvj is used as a computational routine in the preconditioned + ! jacobi svd algorithm stdlib${ii}$_cgejsv. for sweeps i=1:swband the procedure ! works on pivots inside a band-like region around the diagonal. ! the boundaries are determined dynamically, based on the number of ! pivots above a threshold. - kbl = min( 8, n ) + kbl = min( 8_${ik}$, n ) ! [tp] kbl is a tuning parameter that defines the tile size in the ! tiling of the p-q loops of pivot pairs. in general, an optimal ! value of kbl depends on the matrix dimensions and on the ! parameters of the computer's memory. nbl = n / kbl - if( ( nbl*kbl )/=n )nbl = nbl + 1 - blskip = kbl**2 + if( ( nbl*kbl )/=n )nbl = nbl + 1_${ik}$ + blskip = kbl**2_${ik}$ ! [tp] blkskip is a tuning parameter that depends on swband and kbl. - rowskip = min( 5, kbl ) + rowskip = min( 5_${ik}$, kbl ) ! [tp] rowskip is a tuning parameter. - lkahead = 1 + lkahead = 1_${ik}$ ! [tp] lkahead is a tuning parameter. ! quasi block transformations, using the lower (upper) triangular ! structure of the input matrix. the quasi-block-cycling usually ! invokes cubic convergence. big part of this cycle is done inside ! canonical subspaces of dimensions less than m. - if( ( lower .or. upper ) .and. ( n>max( 64, 4*kbl ) ) ) then + if( ( lower .or. upper ) .and. ( n>max( 64_${ik}$, 4_${ik}$*kbl ) ) ) then ! [tp] the number of partition levels and the actual partition are ! tuning parameters. - n4 = n / 4 - n2 = n / 2 - n34 = 3*n4 + n4 = n / 4_${ik}$ + n2 = n / 2_${ik}$ + n34 = 3_${ik}$*n4 if( applv ) then - q = 0 + q = 0_${ik}$ else - q = 1 + q = 1_${ik}$ end if if( lower ) then ! this works very well on lower triangular matrices, in particular @@ -76098,32 +76092,32 @@ module stdlib_linalg_lapack_c ! [+ + 0 0] [0 0] ! [+ + x 0] actually work on [x 0] [x 0] ! [+ + x x] [x x]. [x x] - call stdlib_cgsvj0( jobv, m-n34, n-n34, a( n34+1, n34+1 ), lda,cwork( n34+1 ), & - sva( n34+1 ), mvl,v( n34*q+1, n34+1 ), ldv, epsln, sfmin, tol,2, cwork( n+1 ), & + call stdlib${ii}$_cgsvj0( jobv, m-n34, n-n34, a( n34+1, n34+1 ), lda,cwork( n34+1 ), & + sva( n34+1 ), mvl,v( n34*q+1, n34+1 ), ldv, epsln, sfmin, tol,2_${ik}$, cwork( n+1 ), & lwork-n, ierr ) - call stdlib_cgsvj0( jobv, m-n2, n34-n2, a( n2+1, n2+1 ), lda,cwork( n2+1 ), sva( & - n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 2,cwork( n+1 ), lwork-n, & + call stdlib${ii}$_cgsvj0( jobv, m-n2, n34-n2, a( n2+1, n2+1 ), lda,cwork( n2+1 ), sva( & + n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 2_${ik}$,cwork( n+1 ), lwork-n, & ierr ) - call stdlib_cgsvj1( jobv, m-n2, n-n2, n4, a( n2+1, n2+1 ), lda,cwork( n2+1 ), & - sva( n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1,cwork( n+1 ), & + call stdlib${ii}$_cgsvj1( jobv, m-n2, n-n2, n4, a( n2+1, n2+1 ), lda,cwork( n2+1 ), & + sva( n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1_${ik}$,cwork( n+1 ), & lwork-n, ierr ) - call stdlib_cgsvj0( jobv, m-n4, n2-n4, a( n4+1, n4+1 ), lda,cwork( n4+1 ), sva( & - n4+1 ), mvl,v( n4*q+1, n4+1 ), ldv, epsln, sfmin, tol, 1,cwork( n+1 ), lwork-n, & + call stdlib${ii}$_cgsvj0( jobv, m-n4, n2-n4, a( n4+1, n4+1 ), lda,cwork( n4+1 ), sva( & + n4+1 ), mvl,v( n4*q+1, n4+1 ), ldv, epsln, sfmin, tol, 1_${ik}$,cwork( n+1 ), lwork-n, & ierr ) - call stdlib_cgsvj0( jobv, m, n4, a, lda, cwork, sva, mvl, v, ldv,epsln, sfmin, & - tol, 1, cwork( n+1 ), lwork-n,ierr ) - call stdlib_cgsvj1( jobv, m, n2, n4, a, lda, cwork, sva, mvl, v,ldv, epsln, & - sfmin, tol, 1, cwork( n+1 ),lwork-n, ierr ) + call stdlib${ii}$_cgsvj0( jobv, m, n4, a, lda, cwork, sva, mvl, v, ldv,epsln, sfmin, & + tol, 1_${ik}$, cwork( n+1 ), lwork-n,ierr ) + call stdlib${ii}$_cgsvj1( jobv, m, n2, n4, a, lda, cwork, sva, mvl, v,ldv, epsln, & + sfmin, tol, 1_${ik}$, cwork( n+1 ),lwork-n, ierr ) else if( upper ) then - call stdlib_cgsvj0( jobv, n4, n4, a, lda, cwork, sva, mvl, v, ldv,epsln, sfmin, & - tol, 2, cwork( n+1 ), lwork-n,ierr ) - call stdlib_cgsvj0( jobv, n2, n4, a( 1, n4+1 ), lda, cwork( n4+1 ),sva( n4+1 ), & - mvl, v( n4*q+1, n4+1 ), ldv,epsln, sfmin, tol, 1, cwork( n+1 ), lwork-n,ierr ) + call stdlib${ii}$_cgsvj0( jobv, n4, n4, a, lda, cwork, sva, mvl, v, ldv,epsln, sfmin, & + tol, 2_${ik}$, cwork( n+1 ), lwork-n,ierr ) + call stdlib${ii}$_cgsvj0( jobv, n2, n4, a( 1_${ik}$, n4+1 ), lda, cwork( n4+1 ),sva( n4+1 ), & + mvl, v( n4*q+1, n4+1 ), ldv,epsln, sfmin, tol, 1_${ik}$, cwork( n+1 ), lwork-n,ierr ) - call stdlib_cgsvj1( jobv, n2, n2, n4, a, lda, cwork, sva, mvl, v,ldv, epsln, & - sfmin, tol, 1, cwork( n+1 ),lwork-n, ierr ) - call stdlib_cgsvj0( jobv, n2+n4, n4, a( 1, n2+1 ), lda,cwork( n2+1 ), sva( n2+1 )& - , mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1,cwork( n+1 ), lwork-n, ierr ) + call stdlib${ii}$_cgsvj1( jobv, n2, n2, n4, a, lda, cwork, sva, mvl, v,ldv, epsln, & + sfmin, tol, 1_${ik}$, cwork( n+1 ),lwork-n, ierr ) + call stdlib${ii}$_cgsvj0( jobv, n2+n4, n4, a( 1_${ik}$, n2+1 ), lda,cwork( n2+1 ), sva( n2+1 )& + , mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1_${ik}$,cwork( n+1 ), lwork-n, ierr ) end if end if @@ -76132,23 +76126,23 @@ module stdlib_linalg_lapack_c ! .. go go go ... mxaapq = zero mxsinj = zero - iswrot = 0 - notrot = 0 - pskipped = 0 + iswrot = 0_${ik}$ + notrot = 0_${ik}$ + pskipped = 0_${ik}$ ! each sweep is unrolled using kbl-by-kbl tiles over the pivot pairs ! 1 <= p < q <= n. this is the first step toward a blocked implementation ! of the rotations. new implementation, based on block transformations, ! is under development. loop_2000: do ibr = 1, nbl - igl = ( ibr-1 )*kbl + 1 + igl = ( ibr-1 )*kbl + 1_${ik}$ loop_1002: do ir1 = 0, min( lkahead, nbl-ibr ) igl = igl + ir1*kbl loop_2001: do p = igl, min( igl+kbl-1, n-1 ) ! .. de rijk's pivoting - q = stdlib_isamax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib${ii}$_isamax( n-p+1, sva( p ), 1_${ik}$ ) + p - 1_${ik}$ if( p/=q ) then - call stdlib_cswap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_cswap( mvl, v( 1, p ), 1,v( 1, q ), 1 ) + call stdlib${ii}$_cswap( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) + if( rsvec )call stdlib${ii}$_cswap( mvl, v( 1_${ik}$, p ), 1_${ik}$,v( 1_${ik}$, q ), 1_${ik}$ ) temp1 = sva( p ) sva( p ) = sva( q ) sva( q ) = temp1 @@ -76156,24 +76150,24 @@ module stdlib_linalg_lapack_c cwork(p) = cwork(q) cwork(q) = aapq end if - if( ir1==0 ) then + if( ir1==0_${ik}$ ) then ! column norms are periodically updated by explicit ! norm computation. ! [!] caveat: - ! unfortunately, some blas implementations compute stdlib_scnrm2(m,a(1,p),1) - ! as sqrt(s=stdlib_cdotc(m,a(1,p),1,a(1,p),1)), which may cause the result to + ! unfortunately, some blas implementations compute stdlib${ii}$_scnrm2(m,a(1,p),1) + ! as sqrt(s=stdlib${ii}$_cdotc(m,a(1,p),1,a(1,p),1)), which may cause the result to ! overflow for ||a(:,p)||_2 > sqrt(overflow_threshold), and to ! underflow for ||a(:,p)||_2 < sqrt(underflow_threshold). - ! hence, stdlib_scnrm2 cannot be trusted, not even in the case when + ! hence, stdlib${ii}$_scnrm2 cannot be trusted, not even in the case when ! the true norm is far from the under(over)flow boundaries. - ! if properly implemented stdlib_scnrm2 is available, the if-then-else-end if - ! below should be replaced with "aapp = stdlib_scnrm2( m, a(1,p), 1 )". + ! if properly implemented stdlib${ii}$_scnrm2 is available, the if-then-else-end if + ! below should be replaced with "aapp = stdlib${ii}$_scnrm2( m, a(1,p), 1 )". if( ( sva( p )rootsfmin ) ) then - sva( p ) = stdlib_scnrm2( m, a( 1, p ), 1 ) + sva( p ) = stdlib${ii}$_scnrm2( m, a( 1_${ik}$, p ), 1_${ik}$ ) else temp1 = zero aapp = one - call stdlib_classq( m, a( 1, p ), 1, temp1, aapp ) + call stdlib${ii}$_classq( m, a( 1_${ik}$, p ), 1_${ik}$, temp1, aapp ) sva( p ) = temp1*sqrt( aapp ) end if aapp = sva( p ) @@ -76181,7 +76175,7 @@ module stdlib_linalg_lapack_c aapp = sva( p ) end if if( aapp>zero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2002: do q = p + 1, min( igl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -76189,25 +76183,25 @@ module stdlib_linalg_lapack_c if( aaqq>=one ) then rotok = ( small*aapp )<=aaqq if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_cdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib${ii}$_cdotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq ) / aapp else - call stdlib_ccopy( m, a( 1, p ), 1,cwork(n+1), 1 ) - call stdlib_clascl( 'G', 0, 0, aapp, one,m, 1, cwork(n+1), & + call stdlib${ii}$_ccopy( m, a( 1_${ik}$, p ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, cwork(n+1), & lda, ierr ) - aapq = stdlib_cdotc( m, cwork(n+1), 1,a( 1, q ), 1 ) / & + aapq = stdlib${ii}$_cdotc( m, cwork(n+1), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq end if else rotok = aapp<=( aaqq / small ) if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_cdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib${ii}$_cdotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aapp ) / aaqq else - call stdlib_ccopy( m, a( 1, q ), 1,cwork(n+1), 1 ) - call stdlib_clascl( 'G', 0, 0, aaqq,one, m, 1,cwork(n+1), & + call stdlib${ii}$_ccopy( m, a( 1_${ik}$, q ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aaqq,one, m, 1_${ik}$,cwork(n+1), & lda, ierr ) - aapq = stdlib_cdotc( m, a(1, p ), 1,cwork(n+1), 1 ) / & + aapq = stdlib${ii}$_cdotc( m, a(1_${ik}$, p ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) / & aapp end if end if @@ -76219,10 +76213,10 @@ module stdlib_linalg_lapack_c ompq = aapq / abs(aapq) ! Rotate ! [rtd] rotated = rotated + one - if( ir1==0 ) then - notrot = 0 - pskipped = 0 - iswrot = iswrot + 1 + if( ir1==0_${ik}$ ) then + notrot = 0_${ik}$ + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ end if if( rotok ) then aqoap = aaqq / aapp @@ -76231,10 +76225,10 @@ module stdlib_linalg_lapack_c if( abs( theta )>bigtheta ) then t = half / theta cs = one - call stdlib_crot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_crot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *t ) if ( rsvec ) then - call stdlib_crot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_crot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*t ) end if sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) @@ -76252,24 +76246,24 @@ module stdlib_linalg_lapack_c sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq1 ) ) - call stdlib_crot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_crot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *sn ) if ( rsvec ) then - call stdlib_crot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_crot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*sn ) end if end if cwork(p) = -cwork(q) * ompq else ! .. have to use modified gram-schmidt like transformation - call stdlib_ccopy( m, a( 1, p ), 1,cwork(n+1), 1 ) - call stdlib_clascl( 'G', 0, 0, aapp, one, m,1, cwork(n+1), & + call stdlib${ii}$_ccopy( m, a( 1_${ik}$, p ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one, m,1_${ik}$, cwork(n+1), & lda,ierr ) - call stdlib_clascl( 'G', 0, 0, aaqq, one, m,1, a( 1, q ), & + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one, m,1_${ik}$, a( 1_${ik}$, q ), & lda, ierr ) - call stdlib_caxpy( m, -aapq, cwork(n+1), 1,a( 1, q ), 1 ) + call stdlib${ii}$_caxpy( m, -aapq, cwork(n+1), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) - call stdlib_clascl( 'G', 0, 0, one, aaqq, m,1, a( 1, q ), & + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq, m,1_${ik}$, a( 1_${ik}$, q ), & lda, ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq1*aapq1 ) ) mxsinj = max( mxsinj, sfmin ) @@ -76277,41 +76271,41 @@ module stdlib_linalg_lapack_c ! end if rotok then ... else ! in the case of cancellation in updating sva(q), sva(p) ! recompute sva(q), sva(p). - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_scnrm2( m, a( 1, q ), 1 ) + sva( q ) = stdlib${ii}$_scnrm2( m, a( 1_${ik}$, q ), 1_${ik}$ ) else t = zero aaqq = one - call stdlib_classq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_classq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq ) end if end if if( ( aapp / aapp0 )<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_scnrm2( m, a( 1, p ), 1 ) + aapp = stdlib${ii}$_scnrm2( m, a( 1_${ik}$, p ), 1_${ik}$ ) else t = zero aapp = one - call stdlib_classq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_classq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp ) end if sva( p ) = aapp end if else ! a(:,p) and a(:,q) already numerically orthogonal - if( ir1==0 )notrot = notrot + 1 + if( ir1==0_${ik}$ )notrot = notrot + 1_${ik}$ ! [rtd] skipped = skipped + 1 - pskipped = pskipped + 1 + pskipped = pskipped + 1_${ik}$ end if else ! a(:,q) is zero column - if( ir1==0 )notrot = notrot + 1 - pskipped = pskipped + 1 + if( ir1==0_${ik}$ )notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then - if( ir1==0 )aapp = -aapp - notrot = 0 + if( ir1==0_${ik}$ )aapp = -aapp + notrot = 0_${ik}$ go to 2103 end if end do loop_2002 @@ -76321,7 +76315,7 @@ module stdlib_linalg_lapack_c sva( p ) = aapp else sva( p ) = aapp - if( ( ir1==0 ) .and. ( aapp==zero ) )notrot = notrot + min( igl+kbl-1, & + if( ( ir1==0_${ik}$ ) .and. ( aapp==zero ) )notrot = notrot + min( igl+kbl-1, & n ) - p end if end do loop_2001 @@ -76330,15 +76324,15 @@ module stdlib_linalg_lapack_c end do loop_1002 ! end of ir1-loop ! ... go to the off diagonal blocks - igl = ( ibr-1 )*kbl + 1 + igl = ( ibr-1 )*kbl + 1_${ik}$ loop_2010: do jbc = ibr + 1, nbl - jgl = ( jbc-1 )*kbl + 1 + jgl = ( jbc-1 )*kbl + 1_${ik}$ ! doing the block at ( ibr, jbc ) - ijblsk = 0 + ijblsk = 0_${ik}$ loop_2100: do p = igl, min( igl+kbl-1, n ) aapp = sva( p ) if( aapp>zero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2200: do q = jgl, min( jgl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -76352,13 +76346,13 @@ module stdlib_linalg_lapack_c rotok = ( small*aaqq )<=aapp end if if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_cdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib${ii}$_cdotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq ) / aapp else - call stdlib_ccopy( m, a( 1, p ), 1,cwork(n+1), 1 ) - call stdlib_clascl( 'G', 0, 0, aapp,one, m, 1,cwork(n+1), & + call stdlib${ii}$_ccopy( m, a( 1_${ik}$, p ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aapp,one, m, 1_${ik}$,cwork(n+1), & lda, ierr ) - aapq = stdlib_cdotc( m, cwork(n+1), 1,a( 1, q ), 1 ) / & + aapq = stdlib${ii}$_cdotc( m, cwork(n+1), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq end if else @@ -76368,13 +76362,13 @@ module stdlib_linalg_lapack_c rotok = aaqq<=( aapp / small ) end if if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_cdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / max(& + aapq = ( stdlib${ii}$_cdotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / max(& aaqq,aapp) )/ min(aaqq,aapp) else - call stdlib_ccopy( m, a( 1, q ), 1,cwork(n+1), 1 ) - call stdlib_clascl( 'G', 0, 0, aaqq,one, m, 1,cwork(n+1), & + call stdlib${ii}$_ccopy( m, a( 1_${ik}$, q ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aaqq,one, m, 1_${ik}$,cwork(n+1), & lda, ierr ) - aapq = stdlib_cdotc( m, a( 1, p ), 1,cwork(n+1), 1 ) / & + aapq = stdlib${ii}$_cdotc( m, a( 1_${ik}$, p ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) / & aapp end if end if @@ -76384,10 +76378,10 @@ module stdlib_linalg_lapack_c ! to rotate or not to rotate, that is the question ... if( abs( aapq1 )>tol ) then ompq = aapq / abs(aapq) - notrot = 0 + notrot = 0_${ik}$ ! [rtd] rotated = rotated + 1 - pskipped = 0 - iswrot = iswrot + 1 + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ if( rotok ) then aqoap = aaqq / aapp apoaq = aapp / aaqq @@ -76396,10 +76390,10 @@ module stdlib_linalg_lapack_c if( abs( theta )>bigtheta ) then t = half / theta cs = one - call stdlib_crot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_crot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *t ) if( rsvec ) then - call stdlib_crot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_crot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*t ) end if sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) @@ -76418,10 +76412,10 @@ module stdlib_linalg_lapack_c sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq1 ) ) - call stdlib_crot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_crot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *sn ) if( rsvec ) then - call stdlib_crot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_crot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*sn ) end if end if @@ -76429,28 +76423,28 @@ module stdlib_linalg_lapack_c else ! .. have to use modified gram-schmidt like transformation if( aapp>aaqq ) then - call stdlib_ccopy( m, a( 1, p ), 1,cwork(n+1), 1 ) + call stdlib${ii}$_ccopy( m, a( 1_${ik}$, p ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) - call stdlib_clascl( 'G', 0, 0, aapp, one,m, 1, cwork(n+1)& + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, cwork(n+1)& ,lda,ierr ) - call stdlib_clascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) - call stdlib_caxpy( m, -aapq, cwork(n+1),1, a( 1, q ), 1 ) + call stdlib${ii}$_caxpy( m, -aapq, cwork(n+1),1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) - call stdlib_clascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq1*aapq1 ) ) mxsinj = max( mxsinj, sfmin ) else - call stdlib_ccopy( m, a( 1, q ), 1,cwork(n+1), 1 ) - call stdlib_clascl( 'G', 0, 0, aaqq, one,m, 1, cwork(n+1)& + call stdlib${ii}$_ccopy( m, a( 1_${ik}$, q ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, cwork(n+1)& ,lda,ierr ) - call stdlib_clascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) - call stdlib_caxpy( m, -conjg(aapq),cwork(n+1), 1, a( 1, & - p ), 1 ) - call stdlib_clascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& + call stdlib${ii}$_caxpy( m, -conjg(aapq),cwork(n+1), 1_${ik}$, a( 1_${ik}$, & + p ), 1_${ik}$ ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, one, aapp,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) sva( p ) = aapp*sqrt( max( zero,one-aapq1*aapq1 ) ) @@ -76460,47 +76454,47 @@ module stdlib_linalg_lapack_c ! end if rotok then ... else ! in the case of cancellation in updating sva(q), sva(p) ! .. recompute sva(q), sva(p) - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_scnrm2( m, a( 1, q ), 1) + sva( q ) = stdlib${ii}$_scnrm2( m, a( 1_${ik}$, q ), 1_${ik}$) else t = zero aaqq = one - call stdlib_classq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_classq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq ) end if end if - if( ( aapp / aapp0 )**2<=rooteps ) then + if( ( aapp / aapp0 )**2_${ik}$<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_scnrm2( m, a( 1, p ), 1 ) + aapp = stdlib${ii}$_scnrm2( m, a( 1_${ik}$, p ), 1_${ik}$ ) else t = zero aapp = one - call stdlib_classq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_classq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp ) end if sva( p ) = aapp end if ! end of ok rotation else - notrot = notrot + 1 + notrot = notrot + 1_${ik}$ ! [rtd] skipped = skipped + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if else - notrot = notrot + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if if( ( i<=swband ) .and. ( ijblsk>=blskip ) )then sva( p ) = aapp - notrot = 0 + notrot = 0_${ik}$ go to 2011 end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then aapp = -aapp - notrot = 0 + notrot = 0_${ik}$ go to 2203 end if end do loop_2200 @@ -76508,8 +76502,8 @@ module stdlib_linalg_lapack_c 2203 continue sva( p ) = aapp else - if( aapp==zero )notrot = notrot +min( jgl+kbl-1, n ) - jgl + 1 - if( aapprootsfmin ) )then - sva( n ) = stdlib_scnrm2( m, a( 1, n ), 1 ) + sva( n ) = stdlib${ii}$_scnrm2( m, a( 1_${ik}$, n ), 1_${ik}$ ) else t = zero aapp = one - call stdlib_classq( m, a( 1, n ), 1, t, aapp ) + call stdlib${ii}$_classq( m, a( 1_${ik}$, n ), 1_${ik}$, t, aapp ) sva( n ) = t*sqrt( aapp ) end if ! additional steering devices @@ -76542,81 +76536,81 @@ module stdlib_linalg_lapack_c end do loop_1993 ! end i=1:nsweep loop ! #:( reaching this point means that the procedure has not converged. - info = nsweep - 1 + info = nsweep - 1_${ik}$ go to 1995 1994 continue ! #:) reaching this point means numerical convergence after the i-th ! sweep. - info = 0 + info = 0_${ik}$ ! #:) info = 0 confirms successful iterations. 1995 continue ! sort the singular values and find how many are above ! the underflow threshold. - n2 = 0 - n4 = 0 + n2 = 0_${ik}$ + n4 = 0_${ik}$ do p = 1, n - 1 - q = stdlib_isamax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib${ii}$_isamax( n-p+1, sva( p ), 1_${ik}$ ) + p - 1_${ik}$ if( p/=q ) then temp1 = sva( p ) sva( p ) = sva( q ) sva( q ) = temp1 - call stdlib_cswap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_cswap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) + call stdlib${ii}$_cswap( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) + if( rsvec )call stdlib${ii}$_cswap( mvl, v( 1_${ik}$, p ), 1_${ik}$, v( 1_${ik}$, q ), 1_${ik}$ ) end if if( sva( p )/=zero ) then - n4 = n4 + 1 - if( sva( p )*skl>sfmin )n2 = n2 + 1 + n4 = n4 + 1_${ik}$ + if( sva( p )*skl>sfmin )n2 = n2 + 1_${ik}$ end if end do if( sva( n )/=zero ) then - n4 = n4 + 1 - if( sva( n )*skl>sfmin )n2 = n2 + 1 + n4 = n4 + 1_${ik}$ + if( sva( n )*skl>sfmin )n2 = n2 + 1_${ik}$ end if ! normalize the left singular vectors. if( lsvec .or. uctol ) then do p = 1, n4 - ! call stdlib_csscal( m, one / sva( p ), a( 1, p ), 1 ) - call stdlib_clascl( 'G',0,0, sva(p), one, m, 1, a(1,p), m, ierr ) + ! call stdlib${ii}$_csscal( m, one / sva( p ), a( 1, p ), 1 ) + call stdlib${ii}$_clascl( 'G',0_${ik}$,0_${ik}$, sva(p), one, m, 1_${ik}$, a(1_${ik}$,p), m, ierr ) end do end if ! scale the product of jacobi rotations. if( rsvec ) then do p = 1, n - temp1 = one / stdlib_scnrm2( mvl, v( 1, p ), 1 ) - call stdlib_csscal( mvl, temp1, v( 1, p ), 1 ) + temp1 = one / stdlib${ii}$_scnrm2( mvl, v( 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_csscal( mvl, temp1, v( 1_${ik}$, p ), 1_${ik}$ ) end do end if ! undo scaling, if necessary (and possible). - if( ( ( skl>one ) .and. ( sva( 1 )<( big / skl ) ) ).or. ( ( skl( sfmin / skl ) ) ) ) then + if( ( ( skl>one ) .and. ( sva( 1_${ik}$ )<( big / skl ) ) ).or. ( ( skl( sfmin / skl ) ) ) ) then do p = 1, n sva( p ) = skl*sva( p ) end do skl = one end if - rwork( 1 ) = skl + rwork( 1_${ik}$ ) = skl ! the singular values of a are skl*sva(1:n). if skl/=one ! then some of the singular values may overflow or underflow and ! the spectrum is given in this factored representation. - rwork( 2 ) = real( n4,KIND=sp) + rwork( 2_${ik}$ ) = real( n4,KIND=sp) ! n4 is the number of computed nonzero singular values of a. - rwork( 3 ) = real( n2,KIND=sp) + rwork( 3_${ik}$ ) = real( n2,KIND=sp) ! n2 is the number of singular values of a greater than sfmin. ! if n2zero .and. anrmzero .and. bnrm1 ) then - call stdlib_clacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& + call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vsl, ldvsl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_clacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& , ldvsl ) end if - call stdlib_cungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & + call stdlib${ii}$_cungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vsr - if( ilvsr )call stdlib_claset( 'FULL', n, n, czero, cone, vsr, ldvsr ) + if( ilvsr )call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vsr, ldvsr ) ! reduce to generalized hessenberg form - call stdlib_cgghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& + call stdlib${ii}$_cgghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& work( iwrk ), lwork+1-iwrk, ierr ) - sdim = 0 + sdim = 0_${ik}$ ! perform qz algorithm, computing schur vectors if desired iwrk = itau - call stdlib_claqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, & - ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), 0, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + call stdlib${ii}$_claqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, & + ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), 0_${ik}$, ierr ) + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 30 end if ! sort eigenvalues alpha/beta if desired if( wantst ) then ! undo scaling on eigenvalues before selecting - if( ilascl )call stdlib_clascl( 'G', 0, 0, anrm, anrmto, n, 1, alpha, n, ierr ) + if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, 1_${ik}$, alpha, n, ierr ) - if( ilbscl )call stdlib_clascl( 'G', 0, 0, bnrm, bnrmto, n, 1, beta, n, ierr ) + if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, 1_${ik}$, beta, n, ierr ) ! select eigenvalues do i = 1, n bwork( i ) = selctg( alpha( i ), beta( i ) ) end do - call stdlib_ctgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,beta, vsl, & - ldvsl, vsr, ldvsr, sdim, pvsl, pvsr,dif, work( iwrk ), lwork-iwrk+1, idum, 1, ierr ) + call stdlib${ii}$_ctgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,beta, vsl, & + ldvsl, vsr, ldvsr, sdim, pvsl, pvsr,dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$, ierr ) - if( ierr==1 )info = n + 3 + if( ierr==1_${ik}$ )info = n + 3_${ik}$ end if ! apply back-permutation to vsl and vsr - if( ilvsl )call stdlib_cggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), & + if( ilvsl )call stdlib${ii}$_cggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), & n, vsl, ldvsl, ierr ) - if( ilvsr )call stdlib_cggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), & + if( ilvsr )call stdlib${ii}$_cggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), & n, vsr, ldvsr, ierr ) ! undo scaling if( ilascl ) then - call stdlib_clascl( 'U', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) - call stdlib_clascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) + call stdlib${ii}$_clascl( 'U', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr ) end if if( ilbscl ) then - call stdlib_clascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) - call stdlib_clascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + call stdlib${ii}$_clascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) end if if( wantst ) then ! check if reordering is correct lastsl = .true. - sdim = 0 + sdim = 0_${ik}$ do i = 1, n cursl = selctg( alpha( i ), beta( i ) ) - if( cursl )sdim = sdim + 1 - if( cursl .and. .not.lastsl )info = n + 2 + if( cursl )sdim = sdim + 1_${ik}$ + if( cursl .and. .not.lastsl )info = n + 2_${ik}$ lastsl = cursl end do end if 30 continue - work( 1 ) = cmplx( lwkopt,KIND=sp) + work( 1_${ik}$ ) = cmplx( lwkopt,KIND=sp) return - end subroutine stdlib_cgges3 + end subroutine stdlib${ii}$_cgges3 - subroutine stdlib_cggev3( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, & + subroutine stdlib${ii}$_cggev3( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, & !! CGGEV3 computes for a pair of N-by-N complex nonsymmetric matrices !! (A,B), the generalized eigenvalues, and optionally, the left and/or !! right generalized eigenvectors. @@ -76889,8 +76883,8 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvl, jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n ! Array Arguments real(sp), intent(out) :: rwork(*) complex(sp), intent(inout) :: a(lda,*), b(ldb,*) @@ -76901,12 +76895,12 @@ module stdlib_linalg_lapack_c ! Local Scalars logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery character :: chtemp - integer(ilp) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,& + integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,& itau, iwrk, jc, jr, lwkopt real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp complex(sp) :: x ! Local Arrays - logical(lk) :: ldumma(1) + logical(lk) :: ldumma(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,aimag,max,real,sqrt ! Statement Functions @@ -76916,75 +76910,75 @@ module stdlib_linalg_lapack_c ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvl, 'N' ) ) then - ijobvl = 1 + ijobvl = 1_${ik}$ ilvl = .false. else if( stdlib_lsame( jobvl, 'V' ) ) then - ijobvl = 2 + ijobvl = 2_${ik}$ ilvl = .true. else - ijobvl = -1 + ijobvl = -1_${ik}$ ilvl = .false. end if if( stdlib_lsame( jobvr, 'N' ) ) then - ijobvr = 1 + ijobvr = 1_${ik}$ ilvr = .false. else if( stdlib_lsame( jobvr, 'V' ) ) then - ijobvr = 2 + ijobvr = 2_${ik}$ ilvr = .true. else - ijobvr = -1 + ijobvr = -1_${ik}$ ilvr = .false. end if ilv = ilvl .or. ilvr ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( ijobvl<=0 ) then - info = -1 - else if( ijobvr<=0 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldazero .and. anrmzero .and. bnrm1 ) then - call stdlib_clacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& + call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vl, ldvl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_clacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& ldvl ) end if - call stdlib_cungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & + call stdlib${ii}$_cungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vr - if( ilvr )call stdlib_claset( 'FULL', n, n, czero, cone, vr, ldvr ) + if( ilvr )call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, vr, ldvr ) ! reduce to generalized hessenberg form if( ilv ) then ! eigenvectors requested -- work on whole matrix. - call stdlib_cgghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib${ii}$_cgghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & work( iwrk ), lwork+1-iwrk,ierr ) else - call stdlib_cgghd3( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & + call stdlib${ii}$_cgghd3( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & ldb, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr ) end if ! perform qz algorithm (compute eigenvalues, and optionally, the @@ -77069,15 +77063,15 @@ module stdlib_linalg_lapack_c else chtemp = 'E' end if - call stdlib_claqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, & - ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), 0, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + call stdlib${ii}$_claqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, & + ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), 0_${ik}$, ierr ) + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 70 end if @@ -77092,15 +77086,15 @@ module stdlib_linalg_lapack_c else chtemp = 'R' end if - call stdlib_ctgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & + call stdlib${ii}$_ctgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & in, work( iwrk ), rwork( irwrk ),ierr ) - if( ierr/=0 ) then - info = n + 2 + if( ierr/=0_${ik}$ ) then + info = n + 2_${ik}$ go to 70 end if ! undo balancing on vl and vr and normalization if( ilvl ) then - call stdlib_cggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,& + call stdlib${ii}$_cggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,& ldvl, ierr ) loop_30: do jc = 1, n temp = zero @@ -77115,7 +77109,7 @@ module stdlib_linalg_lapack_c end do loop_30 end if if( ilvr ) then - call stdlib_cggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,& + call stdlib${ii}$_cggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,& ldvr, ierr ) loop_60: do jc = 1, n temp = zero @@ -77132,14 +77126,14 @@ module stdlib_linalg_lapack_c end if ! undo scaling if necessary 70 continue - if( ilascl )call stdlib_clascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) - if( ilbscl )call stdlib_clascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) - work( 1 ) = cmplx( lwkopt,KIND=sp) + if( ilascl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr ) + if( ilbscl )call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) + work( 1_${ik}$ ) = cmplx( lwkopt,KIND=sp) return - end subroutine stdlib_cggev3 + end subroutine stdlib${ii}$_cggev3 - pure subroutine stdlib_cgsvj0( jobv, m, n, a, lda, d, sva, mv, v, ldv, eps,sfmin, tol, & + pure subroutine stdlib${ii}$_cgsvj0( jobv, m, n, a, lda, d, sva, mv, v, ldv, eps,sfmin, tol, & !! CGSVJ0 is called from CGESVJ as a pre-processor and that is its main !! purpose. It applies Jacobi rotations in the same way as CGESVJ does, but !! it does not check convergence (stopping criterion). Few tuning @@ -77149,8 +77143,8 @@ module stdlib_linalg_lapack_c ! -- 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, ldv, lwork, m, mv, n, nsweep + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldv, lwork, m, mv, n, nsweep real(sp), intent(in) :: eps, sfmin, tol character, intent(in) :: jobv ! Array Arguments @@ -77164,7 +77158,7 @@ module stdlib_linalg_lapack_c complex(sp) :: aapq, ompq real(sp) :: aapp, aapp0, aapq1, aaqq, apoaq, aqoap, big, bigtheta, cs, mxaapq, mxsinj, & rootbig, rooteps, rootsfmin, roottol, small, sn, t, temp1, theta, thsign - integer(ilp) :: blskip, emptsw, i, ibr, ierr, igl, ijblsk, ir1, iswrot, jbc, jgl, kbl, & + integer(${ik}$) :: blskip, emptsw, i, ibr, ierr, igl, ijblsk, ir1, iswrot, jbc, jgl, kbl, & lkahead, mvl, nbl, notrot, p, pskipped, q, rowskip, swband logical(lk) :: applv, rotok, rsvec ! Intrinsic Functions @@ -77175,29 +77169,29 @@ module stdlib_linalg_lapack_c applv = stdlib_lsame( jobv, 'A' ) rsvec = stdlib_lsame( jobv, 'V' ) if( .not.( rsvec .or. applv .or. stdlib_lsame( jobv, 'N' ) ) ) then - info = -1 - else if( m<0 ) then - info = -2 - else if( ( n<0 ) .or. ( n>m ) ) then - info = -3 + info = -1_${ik}$ + else if( m<0_${ik}$ ) then + info = -2_${ik}$ + else if( ( n<0_${ik}$ ) .or. ( n>m ) ) then + info = -3_${ik}$ else if( lda sqrt(overflow_threshold), and to ! underflow for ||a(:,p)||_2 < sqrt(underflow_threshold). - ! hence, stdlib_scnrm2 cannot be trusted, not even in the case when + ! hence, stdlib${ii}$_scnrm2 cannot be trusted, not even in the case when ! the true norm is far from the under(over)flow boundaries. - ! if properly implemented stdlib_scnrm2 is available, the if-then-else-end if - ! below should be replaced with "aapp = stdlib_scnrm2( m, a(1,p), 1 )". + ! if properly implemented stdlib${ii}$_scnrm2 is available, the if-then-else-end if + ! below should be replaced with "aapp = stdlib${ii}$_scnrm2( m, a(1,p), 1 )". if( ( sva( p )rootsfmin ) ) then - sva( p ) = stdlib_scnrm2( m, a( 1, p ), 1 ) + sva( p ) = stdlib${ii}$_scnrm2( m, a( 1_${ik}$, p ), 1_${ik}$ ) else temp1 = zero aapp = one - call stdlib_classq( m, a( 1, p ), 1, temp1, aapp ) + call stdlib${ii}$_classq( m, a( 1_${ik}$, p ), 1_${ik}$, temp1, aapp ) sva( p ) = temp1*sqrt( aapp ) end if aapp = sva( p ) @@ -77295,7 +77289,7 @@ module stdlib_linalg_lapack_c aapp = sva( p ) end if if( aapp>zero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2002: do q = p + 1, min( igl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -77303,25 +77297,25 @@ module stdlib_linalg_lapack_c if( aaqq>=one ) then rotok = ( small*aapp )<=aaqq if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_cdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib${ii}$_cdotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq ) / aapp else - call stdlib_ccopy( m, a( 1, p ), 1,work, 1 ) - call stdlib_clascl( 'G', 0, 0, aapp, one,m, 1, work, lda, & + call stdlib${ii}$_ccopy( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, work, lda, & ierr ) - aapq = stdlib_cdotc( m, work, 1,a( 1, q ), 1 ) / & + aapq = stdlib${ii}$_cdotc( m, work, 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq end if else rotok = aapp<=( aaqq / small ) if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_cdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib${ii}$_cdotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aapp ) / aaqq else - call stdlib_ccopy( m, a( 1, q ), 1,work, 1 ) - call stdlib_clascl( 'G', 0, 0, aaqq,one, m, 1,work, lda, & + call stdlib${ii}$_ccopy( m, a( 1_${ik}$, q ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aaqq,one, m, 1_${ik}$,work, lda, & ierr ) - aapq = stdlib_cdotc( m, a( 1, p ), 1,work, 1 ) / & + aapq = stdlib${ii}$_cdotc( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) / & aapp end if end if @@ -77333,10 +77327,10 @@ module stdlib_linalg_lapack_c ompq = aapq / abs(aapq) ! Rotate ! [rtd] rotated = rotated + one - if( ir1==0 ) then - notrot = 0 - pskipped = 0 - iswrot = iswrot + 1 + if( ir1==0_${ik}$ ) then + notrot = 0_${ik}$ + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ end if if( rotok ) then aqoap = aaqq / aapp @@ -77345,10 +77339,10 @@ module stdlib_linalg_lapack_c if( abs( theta )>bigtheta ) then t = half / theta cs = one - call stdlib_crot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_crot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *t ) if ( rsvec ) then - call stdlib_crot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_crot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*t ) end if sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) @@ -77366,23 +77360,23 @@ module stdlib_linalg_lapack_c sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq1 ) ) - call stdlib_crot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_crot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *sn ) if ( rsvec ) then - call stdlib_crot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_crot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*sn ) end if end if d(p) = -d(q) * ompq else ! .. have to use modified gram-schmidt like transformation - call stdlib_ccopy( m, a( 1, p ), 1,work, 1 ) - call stdlib_clascl( 'G', 0, 0, aapp, one, m,1, work, lda,& + call stdlib${ii}$_ccopy( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one, m,1_${ik}$, work, lda,& ierr ) - call stdlib_clascl( 'G', 0, 0, aaqq, one, m,1, a( 1, q ), & + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one, m,1_${ik}$, a( 1_${ik}$, q ), & lda, ierr ) - call stdlib_caxpy( m, -aapq, work, 1,a( 1, q ), 1 ) - call stdlib_clascl( 'G', 0, 0, one, aaqq, m,1, a( 1, q ), & + call stdlib${ii}$_caxpy( m, -aapq, work, 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq, m,1_${ik}$, a( 1_${ik}$, q ), & lda, ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq1*aapq1 ) ) mxsinj = max( mxsinj, sfmin ) @@ -77390,41 +77384,41 @@ module stdlib_linalg_lapack_c ! end if rotok then ... else ! in the case of cancellation in updating sva(q), sva(p) ! recompute sva(q), sva(p). - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_scnrm2( m, a( 1, q ), 1 ) + sva( q ) = stdlib${ii}$_scnrm2( m, a( 1_${ik}$, q ), 1_${ik}$ ) else t = zero aaqq = one - call stdlib_classq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_classq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq ) end if end if if( ( aapp / aapp0 )<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_scnrm2( m, a( 1, p ), 1 ) + aapp = stdlib${ii}$_scnrm2( m, a( 1_${ik}$, p ), 1_${ik}$ ) else t = zero aapp = one - call stdlib_classq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_classq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp ) end if sva( p ) = aapp end if else ! a(:,p) and a(:,q) already numerically orthogonal - if( ir1==0 )notrot = notrot + 1 + if( ir1==0_${ik}$ )notrot = notrot + 1_${ik}$ ! [rtd] skipped = skipped + 1 - pskipped = pskipped + 1 + pskipped = pskipped + 1_${ik}$ end if else ! a(:,q) is zero column - if( ir1==0 )notrot = notrot + 1 - pskipped = pskipped + 1 + if( ir1==0_${ik}$ )notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then - if( ir1==0 )aapp = -aapp - notrot = 0 + if( ir1==0_${ik}$ )aapp = -aapp + notrot = 0_${ik}$ go to 2103 end if end do loop_2002 @@ -77434,7 +77428,7 @@ module stdlib_linalg_lapack_c sva( p ) = aapp else sva( p ) = aapp - if( ( ir1==0 ) .and. ( aapp==zero ) )notrot = notrot + min( igl+kbl-1, & + if( ( ir1==0_${ik}$ ) .and. ( aapp==zero ) )notrot = notrot + min( igl+kbl-1, & n ) - p end if end do loop_2001 @@ -77443,15 +77437,15 @@ module stdlib_linalg_lapack_c end do loop_1002 ! end of ir1-loop ! ... go to the off diagonal blocks - igl = ( ibr-1 )*kbl + 1 + igl = ( ibr-1 )*kbl + 1_${ik}$ loop_2010: do jbc = ibr + 1, nbl - jgl = ( jbc-1 )*kbl + 1 + jgl = ( jbc-1 )*kbl + 1_${ik}$ ! doing the block at ( ibr, jbc ) - ijblsk = 0 + ijblsk = 0_${ik}$ loop_2100: do p = igl, min( igl+kbl-1, n ) aapp = sva( p ) if( aapp>zero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2200: do q = jgl, min( jgl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -77465,13 +77459,13 @@ module stdlib_linalg_lapack_c rotok = ( small*aaqq )<=aapp end if if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_cdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib${ii}$_cdotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq ) / aapp else - call stdlib_ccopy( m, a( 1, p ), 1,work, 1 ) - call stdlib_clascl( 'G', 0, 0, aapp,one, m, 1,work, lda, & + call stdlib${ii}$_ccopy( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aapp,one, m, 1_${ik}$,work, lda, & ierr ) - aapq = stdlib_cdotc( m, work, 1,a( 1, q ), 1 ) / & + aapq = stdlib${ii}$_cdotc( m, work, 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq end if else @@ -77481,13 +77475,13 @@ module stdlib_linalg_lapack_c rotok = aaqq<=( aapp / small ) end if if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_cdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / max(& + aapq = ( stdlib${ii}$_cdotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / max(& aaqq,aapp) )/ min(aaqq,aapp) else - call stdlib_ccopy( m, a( 1, q ), 1,work, 1 ) - call stdlib_clascl( 'G', 0, 0, aaqq,one, m, 1,work, lda, & + call stdlib${ii}$_ccopy( m, a( 1_${ik}$, q ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aaqq,one, m, 1_${ik}$,work, lda, & ierr ) - aapq = stdlib_cdotc( m, a( 1, p ), 1,work, 1 ) / & + aapq = stdlib${ii}$_cdotc( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) / & aapp end if end if @@ -77497,10 +77491,10 @@ module stdlib_linalg_lapack_c ! to rotate or not to rotate, that is the question ... if( abs( aapq1 )>tol ) then ompq = aapq / abs(aapq) - notrot = 0 + notrot = 0_${ik}$ ! [rtd] rotated = rotated + 1 - pskipped = 0 - iswrot = iswrot + 1 + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ if( rotok ) then aqoap = aaqq / aapp apoaq = aapp / aaqq @@ -77509,10 +77503,10 @@ module stdlib_linalg_lapack_c if( abs( theta )>bigtheta ) then t = half / theta cs = one - call stdlib_crot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_crot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *t ) if( rsvec ) then - call stdlib_crot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_crot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*t ) end if sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) @@ -77531,10 +77525,10 @@ module stdlib_linalg_lapack_c sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq1 ) ) - call stdlib_crot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_crot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *sn ) if( rsvec ) then - call stdlib_crot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_crot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*sn ) end if end if @@ -77542,27 +77536,27 @@ module stdlib_linalg_lapack_c else ! .. have to use modified gram-schmidt like transformation if( aapp>aaqq ) then - call stdlib_ccopy( m, a( 1, p ), 1,work, 1 ) - call stdlib_clascl( 'G', 0, 0, aapp, one,m, 1, work,lda,& + call stdlib${ii}$_ccopy( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, work,lda,& ierr ) - call stdlib_clascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) - call stdlib_caxpy( m, -aapq, work,1, a( 1, q ), 1 ) + call stdlib${ii}$_caxpy( m, -aapq, work,1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) - call stdlib_clascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq1*aapq1 ) ) mxsinj = max( mxsinj, sfmin ) else - call stdlib_ccopy( m, a( 1, q ), 1,work, 1 ) - call stdlib_clascl( 'G', 0, 0, aaqq, one,m, 1, work,lda,& + call stdlib${ii}$_ccopy( m, a( 1_${ik}$, q ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, work,lda,& ierr ) - call stdlib_clascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) - call stdlib_caxpy( m, -conjg(aapq),work, 1, a( 1, p ), 1 & + call stdlib${ii}$_caxpy( m, -conjg(aapq),work, 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ & ) - call stdlib_clascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, one, aapp,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) sva( p ) = aapp*sqrt( max( zero,one-aapq1*aapq1 ) ) @@ -77572,47 +77566,47 @@ module stdlib_linalg_lapack_c ! end if rotok then ... else ! in the case of cancellation in updating sva(q), sva(p) ! .. recompute sva(q), sva(p) - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_scnrm2( m, a( 1, q ), 1) + sva( q ) = stdlib${ii}$_scnrm2( m, a( 1_${ik}$, q ), 1_${ik}$) else t = zero aaqq = one - call stdlib_classq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_classq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq ) end if end if - if( ( aapp / aapp0 )**2<=rooteps ) then + if( ( aapp / aapp0 )**2_${ik}$<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_scnrm2( m, a( 1, p ), 1 ) + aapp = stdlib${ii}$_scnrm2( m, a( 1_${ik}$, p ), 1_${ik}$ ) else t = zero aapp = one - call stdlib_classq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_classq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp ) end if sva( p ) = aapp end if ! end of ok rotation else - notrot = notrot + 1 + notrot = notrot + 1_${ik}$ ! [rtd] skipped = skipped + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if else - notrot = notrot + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if if( ( i<=swband ) .and. ( ijblsk>=blskip ) )then sva( p ) = aapp - notrot = 0 + notrot = 0_${ik}$ go to 2011 end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then aapp = -aapp - notrot = 0 + notrot = 0_${ik}$ go to 2203 end if end do loop_2200 @@ -77620,8 +77614,8 @@ module stdlib_linalg_lapack_c 2203 continue sva( p ) = aapp else - if( aapp==zero )notrot = notrot +min( jgl+kbl-1, n ) - jgl + 1 - if( aapprootsfmin ) )then - sva( n ) = stdlib_scnrm2( m, a( 1, n ), 1 ) + sva( n ) = stdlib${ii}$_scnrm2( m, a( 1_${ik}$, n ), 1_${ik}$ ) else t = zero aapp = one - call stdlib_classq( m, a( 1, n ), 1, t, aapp ) + call stdlib${ii}$_classq( m, a( 1_${ik}$, n ), 1_${ik}$, t, aapp ) sva( n ) = t*sqrt( aapp ) end if ! additional steering devices @@ -77654,17 +77648,17 @@ module stdlib_linalg_lapack_c end do loop_1993 ! end i=1:nsweep loop ! #:( reaching this point means that the procedure has not converged. - info = nsweep - 1 + info = nsweep - 1_${ik}$ go to 1995 1994 continue ! #:) reaching this point means numerical convergence after the i-th ! sweep. - info = 0 + info = 0_${ik}$ ! #:) info = 0 confirms successful iterations. 1995 continue ! sort the vector sva() of column norms. do p = 1, n - 1 - q = stdlib_isamax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib${ii}$_isamax( n-p+1, sva( p ), 1_${ik}$ ) + p - 1_${ik}$ if( p/=q ) then temp1 = sva( p ) sva( p ) = sva( q ) @@ -77672,15 +77666,15 @@ module stdlib_linalg_lapack_c aapq = d( p ) d( p ) = d( q ) d( q ) = aapq - call stdlib_cswap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_cswap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) + call stdlib${ii}$_cswap( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) + if( rsvec )call stdlib${ii}$_cswap( mvl, v( 1_${ik}$, p ), 1_${ik}$, v( 1_${ik}$, q ), 1_${ik}$ ) end if end do return - end subroutine stdlib_cgsvj0 + end subroutine stdlib${ii}$_cgsvj0 - pure subroutine stdlib_cgsvj1( jobv, m, n, n1, a, lda, d, sva, mv, v, ldv,eps, sfmin, tol, & + pure subroutine stdlib${ii}$_cgsvj1( jobv, m, n, n1, a, lda, d, sva, mv, v, ldv,eps, sfmin, tol, & !! CGSVJ1 is called from CGESVJ as a pre-processor and that is its main !! purpose. It applies Jacobi rotations in the same way as CGESVJ does, but !! it targets only particular pivots and it does not check convergence @@ -77711,8 +77705,8 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: eps, sfmin, tol - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldv, lwork, m, mv, n, n1, nsweep + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldv, lwork, m, mv, n, n1, nsweep character, intent(in) :: jobv ! Array Arguments complex(sp), intent(inout) :: a(lda,*), d(n), v(ldv,*) @@ -77724,7 +77718,7 @@ module stdlib_linalg_lapack_c complex(sp) :: aapq, ompq real(sp) :: aapp, aapp0, aapq1, aaqq, apoaq, aqoap, big, bigtheta, cs, mxaapq, mxsinj, & rootbig, rooteps, rootsfmin, roottol, small, sn, t, temp1, theta, thsign - integer(ilp) :: blskip, emptsw, i, ibr, igl, ierr, ijblsk, iswrot, jbc, jgl, kbl, mvl, & + integer(${ik}$) :: blskip, emptsw, i, ibr, igl, ierr, ijblsk, iswrot, jbc, jgl, kbl, mvl, & notrot, nblc, nblr, p, pskipped, q, rowskip, swband logical(lk) :: applv, rotok, rsvec ! Intrinsic Functions @@ -77735,31 +77729,31 @@ module stdlib_linalg_lapack_c applv = stdlib_lsame( jobv, 'A' ) rsvec = stdlib_lsame( jobv, 'V' ) if( .not.( rsvec .or. applv .or. stdlib_lsame( jobv, 'N' ) ) ) then - info = -1 - else if( m<0 ) then - info = -2 - else if( ( n<0 ) .or. ( n>m ) ) then - info = -3 - else if( n1<0 ) then - info = -4 + info = -1_${ik}$ + else if( m<0_${ik}$ ) then + info = -2_${ik}$ + else if( ( n<0_${ik}$ ) .or. ( n>m ) ) then + info = -3_${ik}$ + else if( n1<0_${ik}$ ) then + info = -4_${ik}$ else if( ldazero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2200: do q = jgl, min( jgl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -77838,13 +77832,13 @@ module stdlib_linalg_lapack_c rotok = ( small*aaqq )<=aapp end if if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_cdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib${ii}$_cdotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq ) / aapp else - call stdlib_ccopy( m, a( 1, p ), 1,work, 1 ) - call stdlib_clascl( 'G', 0, 0, aapp,one, m, 1,work, lda, & + call stdlib${ii}$_ccopy( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aapp,one, m, 1_${ik}$,work, lda, & ierr ) - aapq = stdlib_cdotc( m, work, 1,a( 1, q ), 1 ) / & + aapq = stdlib${ii}$_cdotc( m, work, 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq end if else @@ -77854,13 +77848,13 @@ module stdlib_linalg_lapack_c rotok = aaqq<=( aapp / small ) end if if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_cdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / max(& + aapq = ( stdlib${ii}$_cdotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / max(& aaqq,aapp) )/ min(aaqq,aapp) else - call stdlib_ccopy( m, a( 1, q ), 1,work, 1 ) - call stdlib_clascl( 'G', 0, 0, aaqq,one, m, 1,work, lda, & + call stdlib${ii}$_ccopy( m, a( 1_${ik}$, q ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aaqq,one, m, 1_${ik}$,work, lda, & ierr ) - aapq = stdlib_cdotc( m, a( 1, p ), 1,work, 1 ) / & + aapq = stdlib${ii}$_cdotc( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) / & aapp end if end if @@ -77870,10 +77864,10 @@ module stdlib_linalg_lapack_c ! to rotate or not to rotate, that is the question ... if( abs( aapq1 )>tol ) then ompq = aapq / abs(aapq) - notrot = 0 + notrot = 0_${ik}$ ! [rtd] rotated = rotated + 1 - pskipped = 0 - iswrot = iswrot + 1 + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ if( rotok ) then aqoap = aaqq / aapp apoaq = aapp / aaqq @@ -77882,10 +77876,10 @@ module stdlib_linalg_lapack_c if( abs( theta )>bigtheta ) then t = half / theta cs = one - call stdlib_crot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_crot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *t ) if( rsvec ) then - call stdlib_crot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_crot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*t ) end if sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) @@ -77904,10 +77898,10 @@ module stdlib_linalg_lapack_c sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq1 ) ) - call stdlib_crot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_crot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *sn ) if( rsvec ) then - call stdlib_crot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_crot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*sn ) end if end if @@ -77915,27 +77909,27 @@ module stdlib_linalg_lapack_c else ! .. have to use modified gram-schmidt like transformation if( aapp>aaqq ) then - call stdlib_ccopy( m, a( 1, p ), 1,work, 1 ) - call stdlib_clascl( 'G', 0, 0, aapp, one,m, 1, work,lda,& + call stdlib${ii}$_ccopy( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, work,lda,& ierr ) - call stdlib_clascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) - call stdlib_caxpy( m, -aapq, work,1, a( 1, q ), 1 ) + call stdlib${ii}$_caxpy( m, -aapq, work,1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) - call stdlib_clascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq1*aapq1 ) ) mxsinj = max( mxsinj, sfmin ) else - call stdlib_ccopy( m, a( 1, q ), 1,work, 1 ) - call stdlib_clascl( 'G', 0, 0, aaqq, one,m, 1, work,lda,& + call stdlib${ii}$_ccopy( m, a( 1_${ik}$, q ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, work,lda,& ierr ) - call stdlib_clascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) - call stdlib_caxpy( m, -conjg(aapq),work, 1, a( 1, p ), 1 & + call stdlib${ii}$_caxpy( m, -conjg(aapq),work, 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ & ) - call stdlib_clascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& + call stdlib${ii}$_clascl( 'G', 0_${ik}$, 0_${ik}$, one, aapp,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) sva( p ) = aapp*sqrt( max( zero,one-aapq1*aapq1 ) ) @@ -77945,47 +77939,47 @@ module stdlib_linalg_lapack_c ! end if rotok then ... else ! in the case of cancellation in updating sva(q), sva(p) ! .. recompute sva(q), sva(p) - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_scnrm2( m, a( 1, q ), 1) + sva( q ) = stdlib${ii}$_scnrm2( m, a( 1_${ik}$, q ), 1_${ik}$) else t = zero aaqq = one - call stdlib_classq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_classq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq ) end if end if - if( ( aapp / aapp0 )**2<=rooteps ) then + if( ( aapp / aapp0 )**2_${ik}$<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_scnrm2( m, a( 1, p ), 1 ) + aapp = stdlib${ii}$_scnrm2( m, a( 1_${ik}$, p ), 1_${ik}$ ) else t = zero aapp = one - call stdlib_classq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_classq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp ) end if sva( p ) = aapp end if ! end of ok rotation else - notrot = notrot + 1 + notrot = notrot + 1_${ik}$ ! [rtd] skipped = skipped + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if else - notrot = notrot + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if if( ( i<=swband ) .and. ( ijblsk>=blskip ) )then sva( p ) = aapp - notrot = 0 + notrot = 0_${ik}$ go to 2011 end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then aapp = -aapp - notrot = 0 + notrot = 0_${ik}$ go to 2203 end if end do loop_2200 @@ -77993,8 +77987,8 @@ module stdlib_linalg_lapack_c 2203 continue sva( p ) = aapp else - if( aapp==zero )notrot = notrot +min( jgl+kbl-1, n ) - jgl + 1 - if( aapprootsfmin ) )then - sva( n ) = stdlib_scnrm2( m, a( 1, n ), 1 ) + sva( n ) = stdlib${ii}$_scnrm2( m, a( 1_${ik}$, n ), 1_${ik}$ ) else t = zero aapp = one - call stdlib_classq( m, a( 1, n ), 1, t, aapp ) + call stdlib${ii}$_classq( m, a( 1_${ik}$, n ), 1_${ik}$, t, aapp ) sva( n ) = t*sqrt( aapp ) end if ! additional steering devices @@ -78027,17 +78021,17 @@ module stdlib_linalg_lapack_c end do loop_1993 ! end i=1:nsweep loop ! #:( reaching this point means that the procedure has not converged. - info = nsweep - 1 + info = nsweep - 1_${ik}$ go to 1995 1994 continue ! #:) reaching this point means numerical convergence after the i-th ! sweep. - info = 0 + info = 0_${ik}$ ! #:) info = 0 confirms successful iterations. 1995 continue ! sort the vector sva() of column norms. do p = 1, n - 1 - q = stdlib_isamax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib${ii}$_isamax( n-p+1, sva( p ), 1_${ik}$ ) + p - 1_${ik}$ if( p/=q ) then temp1 = sva( p ) sva( p ) = sva( q ) @@ -78045,15 +78039,15 @@ module stdlib_linalg_lapack_c aapq = d( p ) d( p ) = d( q ) d( q ) = aapq - call stdlib_cswap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_cswap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) + call stdlib${ii}$_cswap( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) + if( rsvec )call stdlib${ii}$_cswap( mvl, v( 1_${ik}$, p ), 1_${ik}$, v( 1_${ik}$, q ), 1_${ik}$ ) end if end do return - end subroutine stdlib_cgsvj1 + end subroutine stdlib${ii}$_cgsvj1 - pure subroutine stdlib_chesv_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) + pure subroutine stdlib${ii}$_chesv_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) !! CHESV_AA computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS @@ -78070,62 +78064,62 @@ module stdlib_linalg_lapack_c ! -- 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, lwork, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, lwork, n, nrhs ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(sp), intent(inout) :: a(lda,*), b(ldb,*) complex(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: lwkopt, lwkopt_hetrf, lwkopt_hetrs + integer(${ik}$) :: lwkopt, lwkopt_hetrf, lwkopt_hetrs ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) if( .not.stdlib_lsame( uplo, 'U' ) .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=n )go to 20 ! each step of the main loop @@ -78209,17 +78203,17 @@ module stdlib_linalg_lapack_c ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=1 for the first panel, and ! k1=0 for the rest - j1 = j + 1 + j1 = j + 1_${ik}$ jb = min( n-j1+1, nb ) - k1 = max(1, j)-j + k1 = max(1_${ik}$, j)-j ! panel factorization - call stdlib_clahef_aa( uplo, 2-k1, n-j, jb,a( max(1, j), j+1 ), lda,ipiv( j+1 ), & + call stdlib${ii}$_clahef_aa( uplo, 2_${ik}$-k1, n-j, jb,a( max(1_${ik}$, j), j+1 ), lda,ipiv( j+1 ), & work, n, work( n*nb+1 ) ) ! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot) do j2 = j+2, min(n, j+jb+1) ipiv( j2 ) = ipiv( j2 ) + j - if( (j2/=ipiv(j2)) .and. ((j1-k1)>2) ) then - call stdlib_cswap( j1-k1-2, a( 1, j2 ), 1,a( 1, ipiv(j2) ), 1 ) + if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then + call stdlib${ii}$_cswap( j1-k1-2, a( 1_${ik}$, j2 ), 1_${ik}$,a( 1_${ik}$, ipiv(j2) ), 1_${ik}$ ) end if end do j = j + jb @@ -78228,37 +78222,37 @@ module stdlib_linalg_lapack_c ! work stores the current block of the auxiriarly matrix h if( j1 .or. jb>1 ) then + if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then ! merge rank-1 update with blas-3 update alpha = conjg( a( j, j+1 ) ) a( j, j+1 ) = cone - call stdlib_ccopy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib${ii}$_ccopy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) - call stdlib_cscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib${ii}$_cscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=0 and k2=1 for the first panel, ! and k1=1 and k2=0 for the rest - if( j1>1 ) then + if( j1>1_${ik}$ ) then ! not first panel - k2 = 1 + k2 = 1_${ik}$ else ! first panel - k2 = 0 + k2 = 0_${ik}$ ! first update skips the first column - jb = jb - 1 + jb = jb - 1_${ik}$ end if do j2 = j+1, n, nb nj = min( nb, n-j2+1 ) - ! update (j2, j2) diagonal block with stdlib_cgemv + ! update (j2, j2) diagonal block with stdlib${ii}$_cgemv j3 = j2 do mj = nj-1, 1, -1 - call stdlib_cgemm( 'CONJUGATE TRANSPOSE', 'TRANSPOSE',1, mj, jb+1,-cone,& + call stdlib${ii}$_cgemm( 'CONJUGATE TRANSPOSE', 'TRANSPOSE',1_${ik}$, mj, jb+1,-cone,& a( j1-k2, j3 ), lda,work( (j3-j1+1)+k1*n ), n,cone, a( j3, j3 ), lda ) - j3 = j3 + 1 + j3 = j3 + 1_${ik}$ end do - ! update off-diagonal block of j2-th block row with stdlib_cgemm - call stdlib_cgemm( 'CONJUGATE TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-& + ! update off-diagonal block of j2-th block row with stdlib${ii}$_cgemm + call stdlib${ii}$_cgemm( 'CONJUGATE TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-& cone, a( j1-k2, j2 ), lda,work( (j3-j1+1)+k1*n ), n,cone, a( j2, j3 ), lda & ) end do @@ -78266,7 +78260,7 @@ module stdlib_linalg_lapack_c a( j, j+1 ) = conjg( alpha ) end if ! work(j+1, 1) stores h(j+1, 1) - call stdlib_ccopy( n-j, a( j+1, j+1 ), lda, work( 1 ), 1 ) + call stdlib${ii}$_ccopy( n-j, a( j+1, j+1 ), lda, work( 1_${ik}$ ), 1_${ik}$ ) end if go to 10 else @@ -78275,11 +78269,11 @@ module stdlib_linalg_lapack_c ! ..................................................... ! copy first column a(1:n, 1) into h(1:n, 1) ! (stored in work(1:n)) - call stdlib_ccopy( n, a( 1, 1 ), 1, work( 1 ), 1 ) + call stdlib${ii}$_ccopy( n, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) ! j is the main loop index, increasing from 1 to n in steps of - ! jb, where jb is the number of columns factorized by stdlib_clahef; + ! jb, where jb is the number of columns factorized by stdlib${ii}$_clahef; ! jb is either nb, or n-j+1 for the last block - j = 0 + j = 0_${ik}$ 11 continue if( j>=n )go to 20 ! each step of the main loop @@ -78290,15 +78284,15 @@ module stdlib_linalg_lapack_c ! k1=0 for the rest j1 = j+1 jb = min( n-j1+1, nb ) - k1 = max(1, j)-j + k1 = max(1_${ik}$, j)-j ! panel factorization - call stdlib_clahef_aa( uplo, 2-k1, n-j, jb,a( j+1, max(1, j) ), lda,ipiv( j+1 ), & + call stdlib${ii}$_clahef_aa( uplo, 2_${ik}$-k1, n-j, jb,a( j+1, max(1_${ik}$, j) ), lda,ipiv( j+1 ), & work, n, work( n*nb+1 ) ) ! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot) do j2 = j+2, min(n, j+jb+1) ipiv( j2 ) = ipiv( j2 ) + j - if( (j2/=ipiv(j2)) .and. ((j1-k1)>2) ) then - call stdlib_cswap( j1-k1-2, a( j2, 1 ), lda,a( ipiv(j2), 1 ), lda ) + if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then + call stdlib${ii}$_cswap( j1-k1-2, a( j2, 1_${ik}$ ), lda,a( ipiv(j2), 1_${ik}$ ), lda ) end if end do j = j + jb @@ -78307,36 +78301,36 @@ module stdlib_linalg_lapack_c ! work(j2+1, 1) stores h(j2+1, 1) if( j1 .or. jb>1 ) then + if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then ! merge rank-1 update with blas-3 update alpha = conjg( a( j+1, j ) ) a( j+1, j ) = cone - call stdlib_ccopy( n-j, a( j+1, j-1 ), 1,work( (j+1-j1+1)+jb*n ), 1 ) - call stdlib_cscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib${ii}$_ccopy( n-j, a( j+1, j-1 ), 1_${ik}$,work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) + call stdlib${ii}$_cscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=0 and k2=1 for the first panel, ! and k1=1 and k2=0 for the rest - if( j1>1 ) then + if( j1>1_${ik}$ ) then ! not first panel - k2 = 1 + k2 = 1_${ik}$ else ! first panel - k2 = 0 + k2 = 0_${ik}$ ! first update skips the first column - jb = jb - 1 + jb = jb - 1_${ik}$ end if do j2 = j+1, n, nb nj = min( nb, n-j2+1 ) - ! update (j2, j2) diagonal block with stdlib_cgemv + ! update (j2, j2) diagonal block with stdlib${ii}$_cgemv j3 = j2 do mj = nj-1, 1, -1 - call stdlib_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',mj, 1, jb+1,-& + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',mj, 1_${ik}$, jb+1,-& cone, work( (j3-j1+1)+k1*n ), n,a( j3, j1-k2 ), lda,cone, a( j3, j3 ), & lda ) - j3 = j3 + 1 + j3 = j3 + 1_${ik}$ end do - ! update off-diagonal block of j2-th block column with stdlib_cgemm - call stdlib_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',n-j3+1, nj, jb+1,-& + ! update off-diagonal block of j2-th block column with stdlib${ii}$_cgemm + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',n-j3+1, nj, jb+1,-& cone, work( (j3-j1+1)+k1*n ), n,a( j2, j1-k2 ), lda,cone, a( j3, j2 ), lda & ) end do @@ -78344,17 +78338,17 @@ module stdlib_linalg_lapack_c a( j+1, j ) = conjg( alpha ) end if ! work(j+1, 1) stores h(j+1, 1) - call stdlib_ccopy( n-j, a( j+1, j+1 ), 1, work( 1 ), 1 ) + call stdlib${ii}$_ccopy( n-j, a( j+1, j+1 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) end if go to 11 end if 20 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_chetrf_aa + end subroutine stdlib${ii}$_chetrf_aa - pure subroutine stdlib_chseqr( job, compz, n, ilo, ihi, h, ldh, w, z, ldz,work, lwork, info ) + pure subroutine stdlib${ii}$_chseqr( job, compz, n, ilo, ihi, h, ldh, w, z, ldz,work, lwork, info ) !! CHSEQR computes the eigenvalues of a Hessenberg matrix H !! and, optionally, the matrices T and Z from the Schur decomposition !! H = Z T Z**H, where T is an upper triangular matrix (the @@ -78368,24 +78362,24 @@ module stdlib_linalg_lapack_c ! -- 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, ldh, ldz, lwork, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ilo, ldh, ldz, lwork, n + integer(${ik}$), intent(out) :: info character, intent(in) :: compz, job ! Array Arguments complex(sp), intent(inout) :: h(ldh,*), z(ldz,*) complex(sp), intent(out) :: w(*), work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: ntiny = 15 - integer(ilp), parameter :: nl = 49 + integer(${ik}$), parameter :: ntiny = 15_${ik}$ + integer(${ik}$), parameter :: nl = 49_${ik}$ real(sp), parameter :: rzero = 0.0_sp ! ==== matrices of order ntiny or smaller must be processed by - ! . stdlib_clahqr because of insufficient subdiagonal scratch space. + ! . stdlib${ii}$_clahqr because of insufficient subdiagonal scratch space. ! . (this is a hard limit.) ==== ! ==== nl allocates some local workspace to help small matrices - ! . through a rare stdlib_clahqr failure. nl > ntiny = 15 is - ! . required and nl <= nmin = stdlib_ilaenv(ispec=12,...) is recom- + ! . through a rare stdlib${ii}$_clahqr failure. nl > ntiny = 15 is + ! . required and nl <= nmin = stdlib${ii}$_ilaenv(ispec=12,...) is recom- ! . mended. (the default value of nmin is 75.) using nl = 49 ! . allows up to six simultaneous shifts and a 16-by-16 ! . deflation window. ==== @@ -78395,7 +78389,7 @@ module stdlib_linalg_lapack_c ! Local Arrays complex(sp) :: hl(nl,nl), workl(nl) ! Local Scalars - integer(ilp) :: kbot, nmin + integer(${ik}$) :: kbot, nmin logical(lk) :: initz, lquery, wantt, wantz ! Intrinsic Functions intrinsic :: cmplx,max,min,real @@ -78404,102 +78398,102 @@ module stdlib_linalg_lapack_c wantt = stdlib_lsame( job, 'S' ) initz = stdlib_lsame( compz, 'I' ) wantz = initz .or. stdlib_lsame( compz, 'V' ) - work( 1 ) = cmplx( real( max( 1, n ),KIND=sp), rzero,KIND=sp) - lquery = lwork==-1 - info = 0 + work( 1_${ik}$ ) = cmplx( real( max( 1_${ik}$, n ),KIND=sp), rzero,KIND=sp) + lquery = lwork==-1_${ik}$ + info = 0_${ik}$ if( .not.stdlib_lsame( job, 'E' ) .and. .not.wantt ) then - info = -1 + info = -1_${ik}$ else if( .not.stdlib_lsame( compz, 'N' ) .and. .not.wantz ) 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( ldh1 )call stdlib_ccopy( ilo-1, h, ldh+1, w, 1 ) - if( ihi1_${ik}$ )call stdlib${ii}$_ccopy( ilo-1, h, ldh+1, w, 1_${ik}$ ) + if( ihinmin ) then - call stdlib_claqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,z, ldz, work, & + call stdlib${ii}$_claqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,z, ldz, work, & lwork, info ) else ! ==== small matrix ==== - call stdlib_clahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,z, ldz, info ) + call stdlib${ii}$_clahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,z, ldz, info ) - if( info>0 ) then - ! ==== a rare stdlib_clahqr failure! stdlib_claqr0 sometimes succeeds - ! . when stdlib_clahqr fails. ==== + if( info>0_${ik}$ ) then + ! ==== a rare stdlib${ii}$_clahqr failure! stdlib${ii}$_claqr0 sometimes succeeds + ! . when stdlib${ii}$_clahqr fails. ==== kbot = info if( n>=nl ) then ! ==== larger matrices have enough subdiagonal scratch - ! . space to call stdlib_claqr0 directly. ==== - call stdlib_claqr0( wantt, wantz, n, ilo, kbot, h, ldh, w,ilo, ihi, z, ldz,& + ! . space to call stdlib${ii}$_claqr0 directly. ==== + call stdlib${ii}$_claqr0( wantt, wantz, n, ilo, kbot, h, ldh, w,ilo, ihi, z, ldz,& work, lwork, info ) else ! ==== tiny matrices don't have enough subdiagonal - ! . scratch space to benefit from stdlib_claqr0. hence, + ! . scratch space to benefit from stdlib${ii}$_claqr0. hence, ! . tiny matrices must be copied into a larger - ! . array before calling stdlib_claqr0. ==== - call stdlib_clacpy( 'A', n, n, h, ldh, hl, nl ) + ! . array before calling stdlib${ii}$_claqr0. ==== + call stdlib${ii}$_clacpy( 'A', n, n, h, ldh, hl, nl ) hl( n+1, n ) = czero - call stdlib_claset( 'A', nl, nl-n, czero, czero, hl( 1, n+1 ),nl ) - call stdlib_claqr0( wantt, wantz, nl, ilo, kbot, hl, nl, w,ilo, ihi, z, & + call stdlib${ii}$_claset( 'A', nl, nl-n, czero, czero, hl( 1_${ik}$, n+1 ),nl ) + call stdlib${ii}$_claqr0( wantt, wantz, nl, ilo, kbot, hl, nl, w,ilo, ihi, z, & ldz, workl, nl, info ) - if( wantt .or. info/=0 )call stdlib_clacpy( 'A', n, n, hl, nl, h, ldh ) + if( wantt .or. info/=0_${ik}$ )call stdlib${ii}$_clacpy( 'A', n, n, hl, nl, h, ldh ) end if end if end if ! ==== clear out the trash, if necessary. ==== - if( ( wantt .or. info/=0 ) .and. n>2 )call stdlib_claset( 'L', n-2, n-2, czero, & - czero, h( 3, 1 ), ldh ) + if( ( wantt .or. info/=0_${ik}$ ) .and. n>2_${ik}$ )call stdlib${ii}$_claset( 'L', n-2, n-2, czero, & + czero, h( 3_${ik}$, 1_${ik}$ ), ldh ) ! ==== ensure reported workspace size is backward-compatible with ! . previous lapack versions. ==== - work( 1 ) = cmplx( max( real( max( 1, n ),KIND=sp),real( work( 1 ),KIND=sp) ), & + work( 1_${ik}$ ) = cmplx( max( real( max( 1_${ik}$, n ),KIND=sp),real( work( 1_${ik}$ ),KIND=sp) ), & rzero,KIND=sp) end if - end subroutine stdlib_chseqr + end subroutine stdlib${ii}$_chseqr - pure subroutine stdlib_clahef_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) + pure subroutine stdlib${ii}$_clahef_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) !! CLAHEF_AA factorizes a panel of a complex hermitian matrix A using !! the Aasen's algorithm. The panel consists of a set of NB rows of A !! when UPLO is U, or a set of NB columns when UPLO is L. @@ -78515,23 +78509,23 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: m, nb, j1, lda, ldh + integer(${ik}$), intent(in) :: m, nb, j1, lda, ldh ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(sp), intent(inout) :: a(lda,*), h(ldh,*) complex(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: j, k, k1, i1, i2, mj + integer(${ik}$) :: j, k, k1, i1, i2, mj complex(sp) :: piv, alpha ! Intrinsic Functions intrinsic :: real,conjg,max ! Executable Statements - j = 1 + j = 1_${ik}$ ! k1 is the first column of the panel to be factorized ! i.e., k1 is 2 for the first block column, and 1 for the rest of the blocks - k1 = (2-j1)+1 + k1 = (2_${ik}$-j1)+1_${ik}$ if( stdlib_lsame( uplo, 'U' ) ) then ! ..................................................... ! factorize a as u**t*d*u using the upper triangle of a @@ -78539,100 +78533,100 @@ module stdlib_linalg_lapack_c 10 continue if ( j>min(m, nb) )go to 20 ! k is the column to be factorized - ! when being called from stdlib_chetrf_aa, + ! when being called from stdlib${ii}$_chetrf_aa, ! > for the first block column, j1 is 1, hence j1+j-1 is j, ! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1, k = j1+j-1 if( j==m ) then ! only need to compute t(j, j) - mj = 1 + mj = 1_${ik}$ else mj = m-j+1 end if ! h(j:n, j) := a(j, j:n) - h(j:n, 1:(j-1)) * l(j1:(j-1), j), ! where h(j:n, j) has been initialized to be a(j, j:n) - if( k>2 ) then + if( k>2_${ik}$ ) then ! k is the column to be factorized ! > for the first block column, k is j, skipping the first two ! columns ! > for the rest of the columns, k is j+1, skipping only the ! first column - call stdlib_clacgv( j-k1, a( 1, j ), 1 ) - call stdlib_cgemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( 1, j ), 1,& - cone, h( j, j ), 1 ) - call stdlib_clacgv( j-k1, a( 1, j ), 1 ) + call stdlib${ii}$_clacgv( j-k1, a( 1_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( 1_${ik}$, j ), 1_${ik}$,& + cone, h( j, j ), 1_${ik}$ ) + call stdlib${ii}$_clacgv( j-k1, a( 1_${ik}$, j ), 1_${ik}$ ) end if ! copy h(i:n, i) into work - call stdlib_ccopy( mj, h( j, j ), 1, work( 1 ), 1 ) + call stdlib${ii}$_ccopy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) if( j>k1 ) then ! compute work := work - l(j-1, j:n) * t(j-1,j), ! where a(j-1, j) stores t(j-1, j) and a(j-2, j:n) stores u(j-1, j:n) alpha = -conjg( a( k-1, j ) ) - call stdlib_caxpy( mj, alpha, a( k-2, j ), lda, work( 1 ), 1 ) + call stdlib${ii}$_caxpy( mj, alpha, a( k-2, j ), lda, work( 1_${ik}$ ), 1_${ik}$ ) end if ! set a(j, j) = t(j, j) - a( k, j ) = real( work( 1 ),KIND=sp) + a( k, j ) = real( work( 1_${ik}$ ),KIND=sp) if( j1 ) then + if( k>1_${ik}$ ) then alpha = -a( k, j ) - call stdlib_caxpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2 ), 1 ) + call stdlib${ii}$_caxpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2_${ik}$ ), 1_${ik}$ ) endif ! find max(|work(2:n)|) - i2 = stdlib_icamax( m-j, work( 2 ), 1 ) + 1 + i2 = stdlib${ii}$_icamax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$ piv = work( i2 ) ! apply hermitian pivot - if( (i2/=2) .and. (piv/=0) ) then + if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then ! swap work(i1) and work(i2) - i1 = 2 + i1 = 2_${ik}$ work( i2 ) = work( i1 ) work( i1 ) = piv ! swap a(i1, i1+1:n) with a(i1+1:n, i2) i1 = i1+j-1 i2 = i2+j-1 - call stdlib_cswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1 ) + call stdlib${ii}$_cswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1_${ik}$ ) - call stdlib_clacgv( i2-i1, a( j1+i1-1, i1+1 ), lda ) - call stdlib_clacgv( i2-i1-1, a( j1+i1, i2 ), 1 ) + call stdlib${ii}$_clacgv( i2-i1, a( j1+i1-1, i1+1 ), lda ) + call stdlib${ii}$_clacgv( i2-i1-1, a( j1+i1, i2 ), 1_${ik}$ ) ! swap a(i1, i2+1:n) with a(i2, i2+1:n) - if( i2(k1-1) ) then ! swap l(1:i1-1, i1) with l(1:i1-1, i2), ! skipping the first column - call stdlib_cswap( i1-k1+1, a( 1, i1 ), 1,a( 1, i2 ), 1 ) + call stdlib${ii}$_cswap( i1-k1+1, a( 1_${ik}$, i1 ), 1_${ik}$,a( 1_${ik}$, i2 ), 1_${ik}$ ) end if else ipiv( j+1 ) = j+1 endif ! set a(j, j+1) = t(j, j+1) - a( k, j+1 ) = work( 2 ) + a( k, j+1 ) = work( 2_${ik}$ ) if( jmin( m, nb ) )go to 40 ! k is the column to be factorized - ! when being called from stdlib_chetrf_aa, + ! when being called from stdlib${ii}$_chetrf_aa, ! > for the first block column, j1 is 1, hence j1+j-1 is j, ! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1, k = j1+j-1 if( j==m ) then ! only need to compute t(j, j) - mj = 1 + mj = 1_${ik}$ else mj = m-j+1 end if ! h(j:n, j) := a(j:n, j) - h(j:n, 1:(j-1)) * l(j, j1:(j-1))^t, ! where h(j:n, j) has been initialized to be a(j:n, j) - if( k>2 ) then + if( k>2_${ik}$ ) then ! k is the column to be factorized ! > for the first block column, k is j, skipping the first two ! columns ! > for the rest of the columns, k is j+1, skipping only the ! first column - call stdlib_clacgv( j-k1, a( j, 1 ), lda ) - call stdlib_cgemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( j, 1 ), & - lda,cone, h( j, j ), 1 ) - call stdlib_clacgv( j-k1, a( j, 1 ), lda ) + call stdlib${ii}$_clacgv( j-k1, a( j, 1_${ik}$ ), lda ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( j, 1_${ik}$ ), & + lda,cone, h( j, j ), 1_${ik}$ ) + call stdlib${ii}$_clacgv( j-k1, a( j, 1_${ik}$ ), lda ) end if ! copy h(j:n, j) into work - call stdlib_ccopy( mj, h( j, j ), 1, work( 1 ), 1 ) + call stdlib${ii}$_ccopy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) if( j>k1 ) then ! compute work := work - l(j:n, j-1) * t(j-1,j), ! where a(j-1, j) = t(j-1, j) and a(j, j-2) = l(j, j-1) alpha = -conjg( a( j, k-1 ) ) - call stdlib_caxpy( mj, alpha, a( j, k-2 ), 1, work( 1 ), 1 ) + call stdlib${ii}$_caxpy( mj, alpha, a( j, k-2 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) end if ! set a(j, j) = t(j, j) - a( j, k ) = real( work( 1 ),KIND=sp) + a( j, k ) = real( work( 1_${ik}$ ),KIND=sp) if( j1 ) then + if( k>1_${ik}$ ) then alpha = -a( j, k ) - call stdlib_caxpy( m-j, alpha, a( j+1, k-1 ), 1,work( 2 ), 1 ) + call stdlib${ii}$_caxpy( m-j, alpha, a( j+1, k-1 ), 1_${ik}$,work( 2_${ik}$ ), 1_${ik}$ ) endif ! find max(|work(2:n)|) - i2 = stdlib_icamax( m-j, work( 2 ), 1 ) + 1 + i2 = stdlib${ii}$_icamax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$ piv = work( i2 ) ! apply hermitian pivot - if( (i2/=2) .and. (piv/=0) ) then + if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then ! swap work(i1) and work(i2) - i1 = 2 + i1 = 2_${ik}$ work( i2 ) = work( i1 ) work( i1 ) = piv ! swap a(i1+1:n, i1) with a(i2, i1+1:n) i1 = i1+j-1 i2 = i2+j-1 - call stdlib_cswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1,a( i2, j1+i1 ), lda ) + call stdlib${ii}$_cswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1_${ik}$,a( i2, j1+i1 ), lda ) - call stdlib_clacgv( i2-i1, a( i1+1, j1+i1-1 ), 1 ) - call stdlib_clacgv( i2-i1-1, a( i2, j1+i1 ), lda ) + call stdlib${ii}$_clacgv( i2-i1, a( i1+1, j1+i1-1 ), 1_${ik}$ ) + call stdlib${ii}$_clacgv( i2-i1-1, a( i2, j1+i1 ), lda ) ! swap a(i2+1:n, i1) with a(i2+1:n, i2) - if( i2(k1-1) ) then ! swap l(1:i1-1, i1) with l(1:i1-1, i2), ! skipping the first column - call stdlib_cswap( i1-k1+1, a( i1, 1 ), lda,a( i2, 1 ), lda ) + call stdlib${ii}$_cswap( i1-k1+1, a( i1, 1_${ik}$ ), lda,a( i2, 1_${ik}$ ), lda ) end if else ipiv( j+1 ) = j+1 endif ! set a(j+1, j) = t(j+1, j) - a( j+1, k ) = work( 2 ) + a( j+1, k ) = work( 2_${ik}$ ) if( j ntiny = 15, so there is enough ! . subdiagonal workspace for nwr>=2 as required. ! . (in fact, there is enough subdiagonal space for ! . nwr>=4.) ==== - nwr = stdlib_ilaenv( 13, 'CLAQR0', jbcmpz, n, ilo, ihi, lwork ) - nwr = max( 2, nwr ) - nwr = min( ihi-ilo+1, ( n-1 ) / 3, nwr ) + nwr = stdlib${ii}$_ilaenv( 13_${ik}$, 'CLAQR0', jbcmpz, n, ilo, ihi, lwork ) + nwr = max( 2_${ik}$, nwr ) + nwr = min( ihi-ilo+1, ( n-1 ) / 3_${ik}$, nwr ) ! ==== nsr = recommended number of simultaneous shifts. ! . at this point n > ntiny = 15, so there is at ! . enough subdiagonal workspace for nsr to be even ! . and greater than or equal to two as required. ==== - nsr = stdlib_ilaenv( 15, 'CLAQR0', jbcmpz, n, ilo, ihi, lwork ) - nsr = min( nsr, ( n-3 ) / 6, ihi-ilo ) - nsr = max( 2, nsr-mod( nsr, 2 ) ) + nsr = stdlib${ii}$_ilaenv( 15_${ik}$, 'CLAQR0', jbcmpz, n, ilo, ihi, lwork ) + nsr = min( nsr, ( n-3 ) / 6_${ik}$, ihi-ilo ) + nsr = max( 2_${ik}$, nsr-mod( nsr, 2_${ik}$ ) ) ! ==== estimate optimal workspace ==== - ! ==== workspace query call to stdlib_claqr3 ==== - call stdlib_claqr3( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& - ld, w, h, ldh, n, h, ldh, n, h,ldh, work, -1 ) - ! ==== optimal workspace = max(stdlib_claqr5, stdlib_claqr3) ==== - lwkopt = max( 3*nsr / 2, int( work( 1 ),KIND=ilp) ) + ! ==== workspace query call to stdlib${ii}$_claqr3 ==== + call stdlib${ii}$_claqr3( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& + ld, w, h, ldh, n, h, ldh, n, h,ldh, work, -1_${ik}$ ) + ! ==== optimal workspace = max(stdlib${ii}$_claqr5, stdlib${ii}$_claqr3) ==== + lwkopt = max( 3_${ik}$*nsr / 2_${ik}$, int( work( 1_${ik}$ ),KIND=${ik}$) ) ! ==== quick return in case of workspace query. ==== - if( lwork==-1 ) then - work( 1 ) = cmplx( lwkopt, 0,KIND=sp) + if( lwork==-1_${ik}$ ) then + work( 1_${ik}$ ) = cmplx( lwkopt, 0_${ik}$,KIND=sp) return end if - ! ==== stdlib_clahqr/stdlib_claqr0 crossover point ==== - nmin = stdlib_ilaenv( 12, 'CLAQR0', jbcmpz, n, ilo, ihi, lwork ) + ! ==== stdlib${ii}$_clahqr/stdlib${ii}$_claqr0 crossover point ==== + nmin = stdlib${ii}$_ilaenv( 12_${ik}$, 'CLAQR0', jbcmpz, n, ilo, ihi, lwork ) nmin = max( ntiny, nmin ) ! ==== nibble crossover point ==== - nibble = stdlib_ilaenv( 14, 'CLAQR0', jbcmpz, n, ilo, ihi, lwork ) - nibble = max( 0, nibble ) + nibble = stdlib${ii}$_ilaenv( 14_${ik}$, 'CLAQR0', jbcmpz, n, ilo, ihi, lwork ) + nibble = max( 0_${ik}$, nibble ) ! ==== accumulate reflections during ttswp? use block ! . 2-by-2 structure during matrix-matrix multiply? ==== - kacc22 = stdlib_ilaenv( 16, 'CLAQR0', jbcmpz, n, ilo, ihi, lwork ) - kacc22 = max( 0, kacc22 ) - kacc22 = min( 2, kacc22 ) + kacc22 = stdlib${ii}$_ilaenv( 16_${ik}$, 'CLAQR0', jbcmpz, n, ilo, ihi, lwork ) + kacc22 = max( 0_${ik}$, kacc22 ) + kacc22 = min( 2_${ik}$, kacc22 ) ! ==== nwmax = the largest possible deflation window for ! . which there is sufficient workspace. ==== - nwmax = min( ( n-1 ) / 3, lwork / 2 ) + nwmax = min( ( n-1 ) / 3_${ik}$, lwork / 2_${ik}$ ) nw = nwmax ! ==== nsmax = the largest number of simultaneous shifts ! . for which there is sufficient workspace. ==== - nsmax = min( ( n-3 ) / 6, 2*lwork / 3 ) - nsmax = nsmax - mod( nsmax, 2 ) + nsmax = min( ( n-3 ) / 6_${ik}$, 2_${ik}$*lwork / 3_${ik}$ ) + nsmax = nsmax - mod( nsmax, 2_${ik}$ ) ! ==== ndfl: an iteration count restarted at deflation. ==== - ndfl = 1 + ndfl = 1_${ik}$ ! ==== itmax = iteration limit ==== - itmax = max( 30, 2*kexsh )*max( 10, ( ihi-ilo+1 ) ) + itmax = max( 30_${ik}$, 2_${ik}$*kexsh )*max( 10_${ik}$, ( ihi-ilo+1 ) ) ! ==== last row and column in the active block ==== kbot = ihi ! ==== main loop ==== @@ -78906,27 +78900,27 @@ module stdlib_linalg_lapack_c ! . in general, more powerful than smaller ones, ! . rapidly increase the window to the maximum possible. ! . then, gradually reduce the window size. ==== - nh = kbot - ktop + 1 + nh = kbot - ktop + 1_${ik}$ nwupbd = min( nh, nwmax ) if( ndfl=nh-1 ) then nw = nh else - kwtop = kbot - nw + 1 + kwtop = kbot - nw + 1_${ik}$ if( cabs1( h( kwtop, kwtop-1 ) )>cabs1( h( kwtop-1, kwtop-2 ) ) )nw = nw + & - 1 + 1_${ik}$ end if end if if( ndfl=0 .or. nw>=nwupbd ) then - ndec = ndec + 1 - if( nw-ndec<2 )ndec = 0 + ndec = -1_${ik}$ + else if( ndec>=0_${ik}$ .or. nw>=nwupbd ) then + ndec = ndec + 1_${ik}$ + if( nw-ndec<2_${ik}$ )ndec = 0_${ik}$ nw = nw - ndec end if ! ==== aggressive early deflation: @@ -78939,60 +78933,60 @@ module stdlib_linalg_lapack_c ! . - an at-least-nw-but-more-is-better (nhv-by-nw) ! . vertical work array along the left-hand-edge. ! . ==== - kv = n - nw + 1 - kt = nw + 1 - nho = ( n-nw-1 ) - kt + 1 - kwv = nw + 2 - nve = ( n-nw ) - kwv + 1 + kv = n - nw + 1_${ik}$ + kt = nw + 1_${ik}$ + nho = ( n-nw-1 ) - kt + 1_${ik}$ + kwv = nw + 2_${ik}$ + nve = ( n-nw ) - kwv + 1_${ik}$ ! ==== aggressive early deflation ==== - call stdlib_claqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & - ls, ld, w, h( kv, 1 ), ldh, nho,h( kv, kt ), ldh, nve, h( kwv, 1 ), ldh, work,& + call stdlib${ii}$_claqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & + ls, ld, w, h( kv, 1_${ik}$ ), ldh, nho,h( kv, kt ), ldh, nve, h( kwv, 1_${ik}$ ), ldh, work,& lwork ) ! ==== adjust kbot accounting for new deflations. ==== kbot = kbot - ld ! ==== ks points to the shifts. ==== - ks = kbot - ls + 1 + ks = kbot - ls + 1_${ik}$ ! ==== skip an expensive qr sweep if there is a (partly ! . heuristic) reason to expect that many eigenvalues ! . will deflate without it. here, the qr sweep is ! . skipped if many eigenvalues have just been deflated ! . or if the remaining active block is small. - if( ( ld==0 ) .or. ( ( 100*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& + if( ( ld==0_${ik}$ ) .or. ( ( 100_${ik}$*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& ) ) ) then ! ==== ns = nominal number of simultaneous shifts. - ! . this may be lowered (slightly) if stdlib_claqr3 + ! . this may be lowered (slightly) if stdlib${ii}$_claqr3 ! . did not provide that many shifts. ==== - ns = min( nsmax, nsr, max( 2, kbot-ktop ) ) - ns = ns - mod( ns, 2 ) + ns = min( nsmax, nsr, max( 2_${ik}$, kbot-ktop ) ) + ns = ns - mod( ns, 2_${ik}$ ) ! ==== if there have been no deflations ! . in a multiple of kexsh iterations, ! . then try exceptional shifts. ! . otherwise use shifts provided by - ! . stdlib_claqr3 above or from the eigenvalues + ! . stdlib${ii}$_claqr3 above or from the eigenvalues ! . of a trailing principal submatrix. ==== - if( mod( ndfl, kexsh )==0 ) then - ks = kbot - ns + 1 + if( mod( ndfl, kexsh )==0_${ik}$ ) then + ks = kbot - ns + 1_${ik}$ do i = kbot, ks + 1, -2 w( i ) = h( i, i ) + wilk1*cabs1( h( i, i-1 ) ) w( i-1 ) = w( i ) end do else ! ==== got ns/2 or fewer shifts? use stdlib_claqr4 or - ! . stdlib_clahqr on a trailing principal submatrix to + ! . stdlib${ii}$_clahqr on a trailing principal submatrix to ! . get more. (since ns<=nsmax<=(n-3)/6, ! . there is enough space below the subdiagonal ! . to fit an ns-by-ns scratch array.) ==== - if( kbot-ks+1<=ns / 2 ) then - ks = kbot - ns + 1 - kt = n - ns + 1 - call stdlib_clacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1 ), ldh ) + if( kbot-ks+1<=ns / 2_${ik}$ ) then + ks = kbot - ns + 1_${ik}$ + kt = n - ns + 1_${ik}$ + call stdlib${ii}$_clacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1_${ik}$ ), ldh ) if( ns>nmin ) then - call stdlib_claqr4( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, w( & - ks ), 1, 1,zdum, 1, work, lwork, inf ) + call stdlib${ii}$_claqr4( .false., .false., ns, 1_${ik}$, ns,h( kt, 1_${ik}$ ), ldh, w( & + ks ), 1_${ik}$, 1_${ik}$,zdum, 1_${ik}$, work, lwork, inf ) else - call stdlib_clahqr( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, w( & - ks ), 1, 1,zdum, 1, inf ) + call stdlib${ii}$_clahqr( .false., .false., ns, 1_${ik}$, ns,h( kt, 1_${ik}$ ), ldh, w( & + ks ), 1_${ik}$, 1_${ik}$,zdum, 1_${ik}$, inf ) end if ks = ks + inf ! ==== in case of a rare qr failure use @@ -79013,7 +79007,7 @@ module stdlib_linalg_lapack_c rtdisc = sqrt( -det ) w( kbot-1 ) = ( tr2+rtdisc )*s w( kbot ) = ( tr2-rtdisc )*s - ks = kbot - 1 + ks = kbot - 1_${ik}$ end if end if if( kbot-ks+1>ns ) then @@ -79036,7 +79030,7 @@ module stdlib_linalg_lapack_c end if ! ==== if there are only two shifts, then use ! . only cone. ==== - if( kbot-ks+1==2 ) then + if( kbot-ks+1==2_${ik}$ ) then if( cabs1( w( kbot )-h( kbot, kbot ) )0 ) then - ndfl = 1 + if( ld>0_${ik}$ ) then + ndfl = 1_${ik}$ else - ndfl = ndfl + 1 + ndfl = ndfl + 1_${ik}$ end if ! ==== end of main loop ==== end do loop_70 @@ -79086,11 +79080,11 @@ module stdlib_linalg_lapack_c 80 continue end if ! ==== return the optimal value of lwork. ==== - work( 1 ) = cmplx( lwkopt, 0,KIND=sp) - end subroutine stdlib_claqr0 + work( 1_${ik}$ ) = cmplx( lwkopt, 0_${ik}$,KIND=sp) + end subroutine stdlib${ii}$_claqr0 - pure subroutine stdlib_claqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & + pure subroutine stdlib${ii}$_claqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & !! Aggressive early deflation: !! CLAQR3 accepts as input an upper Hessenberg matrix !! H and performs an unitary similarity transformation @@ -79105,9 +79099,9 @@ module stdlib_linalg_lapack_c ! -- 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) :: ihiz, iloz, kbot, ktop, ldh, ldt, ldv, ldwv, ldz, lwork, n,& + integer(${ik}$), intent(in) :: ihiz, iloz, kbot, ktop, ldh, ldt, ldv, ldwv, ldz, lwork, n,& nh, nv, nw - integer(ilp), intent(out) :: nd, ns + integer(${ik}$), intent(out) :: nd, ns logical(lk), intent(in) :: wantt, wantz ! Array Arguments complex(sp), intent(inout) :: h(ldh,*), z(ldz,*) @@ -79121,7 +79115,7 @@ module stdlib_linalg_lapack_c ! Local Scalars complex(sp) :: beta, cdum, s, tau real(sp) :: foo, safmax, safmin, smlnum, ulp - integer(ilp) :: i, ifst, ilst, info, infqr, j, jw, kcol, kln, knt, krow, kwtop, ltop, & + integer(${ik}$) :: i, ifst, ilst, info, infqr, j, jw, kcol, kln, knt, krow, kwtop, ltop, & lwk1, lwk2, lwk3, lwkopt, nmin ! Intrinsic Functions intrinsic :: abs,aimag,cmplx,conjg,int,max,min,real @@ -79132,45 +79126,45 @@ module stdlib_linalg_lapack_c ! Executable Statements ! ==== estimate optimal workspace. ==== jw = min( nw, kbot-ktop+1 ) - if( jw<=2 ) then - lwkopt = 1 + if( jw<=2_${ik}$ ) then + lwkopt = 1_${ik}$ else - ! ==== workspace query call to stdlib_cgehrd ==== - call stdlib_cgehrd( jw, 1, jw-1, t, ldt, work, work, -1, info ) - lwk1 = int( work( 1 ),KIND=ilp) - ! ==== workspace query call to stdlib_cunmhr ==== - call stdlib_cunmhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv,work, -1, info ) + ! ==== workspace query call to stdlib${ii}$_cgehrd ==== + call stdlib${ii}$_cgehrd( jw, 1_${ik}$, jw-1, t, ldt, work, work, -1_${ik}$, info ) + lwk1 = int( work( 1_${ik}$ ),KIND=${ik}$) + ! ==== workspace query call to stdlib${ii}$_cunmhr ==== + call stdlib${ii}$_cunmhr( 'R', 'N', jw, jw, 1_${ik}$, jw-1, t, ldt, work, v, ldv,work, -1_${ik}$, info ) - lwk2 = int( work( 1 ),KIND=ilp) - ! ==== workspace query call to stdlib_claqr4 ==== - call stdlib_claqr4( .true., .true., jw, 1, jw, t, ldt, sh, 1, jw, v,ldv, work, -1, & + lwk2 = int( work( 1_${ik}$ ),KIND=${ik}$) + ! ==== workspace query call to stdlib${ii}$_claqr4 ==== + call stdlib${ii}$_claqr4( .true., .true., jw, 1_${ik}$, jw, t, ldt, sh, 1_${ik}$, jw, v,ldv, work, -1_${ik}$, & infqr ) - lwk3 = int( work( 1 ),KIND=ilp) + lwk3 = int( work( 1_${ik}$ ),KIND=${ik}$) ! ==== optimal workspace ==== lwkopt = max( jw+max( lwk1, lwk2 ), lwk3 ) end if ! ==== quick return in case of workspace query. ==== - if( lwork==-1 ) then - work( 1 ) = cmplx( lwkopt, 0,KIND=sp) + if( lwork==-1_${ik}$ ) then + work( 1_${ik}$ ) = cmplx( lwkopt, 0_${ik}$,KIND=sp) return end if ! ==== nothing to do ... ! ... for an empty active block ... ==== - ns = 0 - nd = 0 - work( 1 ) = cone + ns = 0_${ik}$ + nd = 0_${ik}$ + work( 1_${ik}$ ) = cone if( ktop>kbot )return ! ... nor for an empty deflation window. ==== if( nw<1 )return ! ==== machine constants ==== - safmin = stdlib_slamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) safmax = rone / safmin - call stdlib_slabad( safmin, safmax ) - ulp = stdlib_slamch( 'PRECISION' ) + call stdlib${ii}$_slabad( safmin, safmax ) + ulp = stdlib${ii}$_slamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=sp) / ulp ) ! ==== setup deflation window ==== jw = min( nw, kbot-ktop+1 ) - kwtop = kbot - jw + 1 + kwtop = kbot - jw + 1_${ik}$ if( kwtop==ktop ) then s = czero else @@ -79179,14 +79173,14 @@ module stdlib_linalg_lapack_c if( kbot==kwtop ) then ! ==== 1-by-1 deflation window: not much to do ==== sh( kwtop ) = h( kwtop, kwtop ) - ns = 1 - nd = 0 + ns = 1_${ik}$ + nd = 0_${ik}$ if( cabs1( s )<=max( smlnum, ulp*cabs1( h( kwtop,kwtop ) ) ) ) then - ns = 0 - nd = 1 + ns = 0_${ik}$ + nd = 1_${ik}$ if( kwtop>ktop )h( kwtop, kwtop-1 ) = czero end if - work( 1 ) = cone + work( 1_${ik}$ ) = cone return end if ! ==== convert to spike-triangular form. (in case of a @@ -79194,37 +79188,37 @@ module stdlib_linalg_lapack_c ! . aggressive early deflation using that part of ! . the deflation window that converged using infqr ! . here and there to keep track.) ==== - call stdlib_clacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) - call stdlib_ccopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 ) - call stdlib_claset( 'A', jw, jw, czero, cone, v, ldv ) - nmin = stdlib_ilaenv( 12, 'CLAQR3', 'SV', jw, 1, jw, lwork ) + call stdlib${ii}$_clacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) + call stdlib${ii}$_ccopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2_${ik}$, 1_${ik}$ ), ldt+1 ) + call stdlib${ii}$_claset( 'A', jw, jw, czero, cone, v, ldv ) + nmin = stdlib${ii}$_ilaenv( 12_${ik}$, 'CLAQR3', 'SV', jw, 1_${ik}$, jw, lwork ) if( jw>nmin ) then - call stdlib_claqr4( .true., .true., jw, 1, jw, t, ldt, sh( kwtop ), 1,jw, v, ldv, & + call stdlib${ii}$_claqr4( .true., .true., jw, 1_${ik}$, jw, t, ldt, sh( kwtop ), 1_${ik}$,jw, v, ldv, & work, lwork, infqr ) else - call stdlib_clahqr( .true., .true., jw, 1, jw, t, ldt, sh( kwtop ), 1,jw, v, ldv, & + call stdlib${ii}$_clahqr( .true., .true., jw, 1_${ik}$, jw, t, ldt, sh( kwtop ), 1_${ik}$,jw, v, ldv, & infqr ) end if ! ==== deflation detection loop ==== ns = jw - ilst = infqr + 1 + ilst = infqr + 1_${ik}$ do knt = infqr + 1, jw ! ==== small spike tip deflation test ==== foo = cabs1( t( ns, ns ) ) if( foo==rzero )foo = cabs1( s ) - if( cabs1( s )*cabs1( v( 1, ns ) )<=max( smlnum, ulp*foo ) )then + if( cabs1( s )*cabs1( v( 1_${ik}$, ns ) )<=max( smlnum, ulp*foo ) )then ! ==== cone more converged eigenvalue ==== - ns = ns - 1 + ns = ns - 1_${ik}$ else ! ==== cone undeflatable eigenvalue. move it up out of the - ! . way. (stdlib_ctrexc can not fail in this case.) ==== + ! . way. (stdlib${ii}$_ctrexc can not fail in this case.) ==== ifst = ns - call stdlib_ctrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) - ilst = ilst + 1 + call stdlib${ii}$_ctrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) + ilst = ilst + 1_${ik}$ end if end do ! ==== return to hessenberg form ==== - if( ns==0 )s = czero + if( ns==0_${ik}$ )s = czero if( nscabs1( t( ifst, ifst ) ) )ifst = j end do ilst = i - if( ifst/=ilst )call stdlib_ctrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) + if( ifst/=ilst )call stdlib${ii}$_ctrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) end do end if @@ -79243,59 +79237,59 @@ module stdlib_linalg_lapack_c sh( kwtop+i-1 ) = t( i, i ) end do if( ns1 .and. s/=czero ) then + if( ns>1_${ik}$ .and. s/=czero ) then ! ==== reflect spike back into lower triangle ==== - call stdlib_ccopy( ns, v, ldv, work, 1 ) + call stdlib${ii}$_ccopy( ns, v, ldv, work, 1_${ik}$ ) do i = 1, ns work( i ) = conjg( work( i ) ) end do - beta = work( 1 ) - call stdlib_clarfg( ns, beta, work( 2 ), 1, tau ) - work( 1 ) = cone - call stdlib_claset( 'L', jw-2, jw-2, czero, czero, t( 3, 1 ), ldt ) - call stdlib_clarf( 'L', ns, jw, work, 1, conjg( tau ), t, ldt,work( jw+1 ) ) + beta = work( 1_${ik}$ ) + call stdlib${ii}$_clarfg( ns, beta, work( 2_${ik}$ ), 1_${ik}$, tau ) + work( 1_${ik}$ ) = cone + call stdlib${ii}$_claset( 'L', jw-2, jw-2, czero, czero, t( 3_${ik}$, 1_${ik}$ ), ldt ) + call stdlib${ii}$_clarf( 'L', ns, jw, work, 1_${ik}$, conjg( tau ), t, ldt,work( jw+1 ) ) - call stdlib_clarf( 'R', ns, ns, work, 1, tau, t, ldt,work( jw+1 ) ) - call stdlib_clarf( 'R', jw, ns, work, 1, tau, v, ldv,work( jw+1 ) ) - call stdlib_cgehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) + call stdlib${ii}$_clarf( 'R', ns, ns, work, 1_${ik}$, tau, t, ldt,work( jw+1 ) ) + call stdlib${ii}$_clarf( 'R', jw, ns, work, 1_${ik}$, tau, v, ldv,work( jw+1 ) ) + call stdlib${ii}$_cgehrd( jw, 1_${ik}$, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) end if ! ==== copy updated reduced window into place ==== - if( kwtop>1 )h( kwtop, kwtop-1 ) = s*conjg( v( 1, 1 ) ) - call stdlib_clacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) - call stdlib_ccopy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) + if( kwtop>1_${ik}$ )h( kwtop, kwtop-1 ) = s*conjg( v( 1_${ik}$, 1_${ik}$ ) ) + call stdlib${ii}$_clacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) + call stdlib${ii}$_ccopy( jw-1, t( 2_${ik}$, 1_${ik}$ ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) ! ==== accumulate orthogonal matrix in order update ! . h and z, if requested. ==== - if( ns>1 .and. s/=czero )call stdlib_cunmhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, & + if( ns>1_${ik}$ .and. s/=czero )call stdlib${ii}$_cunmhr( 'R', 'N', jw, ns, 1_${ik}$, ns, t, ldt, work, & v, ldv,work( jw+1 ), lwork-jw, info ) ! ==== update vertical slab in h ==== if( wantt ) then - ltop = 1 + ltop = 1_${ik}$ else ltop = ktop end if do krow = ltop, kwtop - 1, nv kln = min( nv, kwtop-krow ) - call stdlib_cgemm( 'N', 'N', kln, jw, jw, cone, h( krow, kwtop ),ldh, v, ldv, & + call stdlib${ii}$_cgemm( 'N', 'N', kln, jw, jw, cone, h( krow, kwtop ),ldh, v, ldv, & czero, wv, ldwv ) - call stdlib_clacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) + call stdlib${ii}$_clacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) end do ! ==== update horizontal slab in h ==== if( wantt ) then do kcol = kbot + 1, n, nh kln = min( nh, n-kcol+1 ) - call stdlib_cgemm( 'C', 'N', jw, kln, jw, cone, v, ldv,h( kwtop, kcol ), ldh, & + call stdlib${ii}$_cgemm( 'C', 'N', jw, kln, jw, cone, v, ldv,h( kwtop, kcol ), ldh, & czero, t, ldt ) - call stdlib_clacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) + call stdlib${ii}$_clacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) end do end if ! ==== update vertical slab in z ==== if( wantz ) then do krow = iloz, ihiz, nv kln = min( nv, ihiz-krow+1 ) - call stdlib_cgemm( 'N', 'N', kln, jw, jw, cone, z( krow, kwtop ),ldz, v, ldv, & + call stdlib${ii}$_cgemm( 'N', 'N', kln, jw, jw, cone, z( krow, kwtop ),ldz, v, ldv, & czero, wv, ldwv ) - call stdlib_clacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) + call stdlib${ii}$_clacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) end do end if end if @@ -79308,11 +79302,11 @@ module stdlib_linalg_lapack_c ! . window.) ==== ns = ns - infqr ! ==== return optimal workspace. ==== - work( 1 ) = cmplx( lwkopt, 0,KIND=sp) - end subroutine stdlib_claqr3 + work( 1_${ik}$ ) = cmplx( lwkopt, 0_${ik}$,KIND=sp) + end subroutine stdlib${ii}$_claqr3 - pure subroutine stdlib_claqr4( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, work,& + pure subroutine stdlib${ii}$_claqr4( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, work,& !! CLAQR4 implements one level of recursion for CLAQR0. !! It is a complete implementation of the small bulge multi-shift !! QR algorithm. It may be called by CLAQR0 and, for large enough @@ -79332,20 +79326,20 @@ module stdlib_linalg_lapack_c ! -- 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, ihiz, ilo, iloz, ldh, ldz, lwork, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ihiz, ilo, iloz, ldh, ldz, lwork, n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt, wantz ! Array Arguments complex(sp), intent(inout) :: h(ldh,*), z(ldz,*) complex(sp), intent(out) :: w(*), work(*) ! ================================================================ ! Parameters - integer(ilp), parameter :: ntiny = 15 - integer(ilp), parameter :: kexnw = 5 - integer(ilp), parameter :: kexsh = 6 + integer(${ik}$), parameter :: ntiny = 15_${ik}$ + integer(${ik}$), parameter :: kexnw = 5_${ik}$ + integer(${ik}$), parameter :: kexsh = 6_${ik}$ real(sp), parameter :: wilk1 = 0.75_sp ! ==== matrices of order ntiny or smaller must be processed by - ! . stdlib_clahqr because of insufficient subdiagonal scratch space. + ! . stdlib${ii}$_clahqr because of insufficient subdiagonal scratch space. ! . (this is a hard limit.) ==== ! ==== exceptional deflation windows: try to cure rare @@ -79364,13 +79358,13 @@ module stdlib_linalg_lapack_c ! Local Scalars complex(sp) :: aa, bb, cc, cdum, dd, det, rtdisc, swap, tr2 real(sp) :: s - integer(ilp) :: i, inf, it, itmax, k, kacc22, kbot, kdu, ks, kt, ktop, ku, kv, kwh, & + integer(${ik}$) :: i, inf, it, itmax, k, kacc22, kbot, kdu, ks, kt, ktop, ku, kv, kwh, & kwtop, kwv, ld, ls, lwkopt, ndec, ndfl, nh, nho, nibble, nmin, ns, nsmax, nsr, nve, nw,& nwmax, nwr, nwupbd logical(lk) :: sorted - character :: jbcmpz*2 + character(len=2) :: jbcmpz ! Local Arrays - complex(sp) :: zdum(1,1) + complex(sp) :: zdum(1_${ik}$,1_${ik}$) ! Intrinsic Functions intrinsic :: abs,aimag,cmplx,int,max,min,mod,real,sqrt ! Statement Functions @@ -79378,82 +79372,82 @@ module stdlib_linalg_lapack_c ! Statement Function Definitions cabs1( cdum ) = abs( real( cdum,KIND=sp) ) + abs( aimag( cdum ) ) ! Executable Statements - info = 0 + info = 0_${ik}$ ! ==== quick return for n = 0: nothing to do. ==== - if( n==0 ) then - work( 1 ) = cone + if( n==0_${ik}$ ) then + work( 1_${ik}$ ) = cone return end if if( n<=ntiny ) then ! ==== tiny matrices must use stdlib_clahqr. ==== - lwkopt = 1 - if( lwork/=-1 )call stdlib_clahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, & + lwkopt = 1_${ik}$ + if( lwork/=-1_${ik}$ )call stdlib${ii}$_clahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, & z, ldz, info ) else ! ==== use small bulge multi-shift qr with aggressive early ! . deflation on larger-than-tiny matrices. ==== ! ==== hope for the best. ==== - info = 0 - ! ==== set up job flags for stdlib_ilaenv. ==== + info = 0_${ik}$ + ! ==== set up job flags for stdlib${ii}$_ilaenv. ==== if( wantt ) then - jbcmpz( 1: 1 ) = 'S' + jbcmpz( 1_${ik}$: 1_${ik}$ ) = 'S' else - jbcmpz( 1: 1 ) = 'E' + jbcmpz( 1_${ik}$: 1_${ik}$ ) = 'E' end if if( wantz ) then - jbcmpz( 2: 2 ) = 'V' + jbcmpz( 2_${ik}$: 2_${ik}$ ) = 'V' else - jbcmpz( 2: 2 ) = 'N' + jbcmpz( 2_${ik}$: 2_${ik}$ ) = 'N' end if ! ==== nwr = recommended deflation window size. at this ! . point, n > ntiny = 15, so there is enough ! . subdiagonal workspace for nwr>=2 as required. ! . (in fact, there is enough subdiagonal space for ! . nwr>=4.) ==== - nwr = stdlib_ilaenv( 13, 'CLAQR4', jbcmpz, n, ilo, ihi, lwork ) - nwr = max( 2, nwr ) - nwr = min( ihi-ilo+1, ( n-1 ) / 3, nwr ) + nwr = stdlib${ii}$_ilaenv( 13_${ik}$, 'CLAQR4', jbcmpz, n, ilo, ihi, lwork ) + nwr = max( 2_${ik}$, nwr ) + nwr = min( ihi-ilo+1, ( n-1 ) / 3_${ik}$, nwr ) ! ==== nsr = recommended number of simultaneous shifts. ! . at this point n > ntiny = 15, so there is at ! . enough subdiagonal workspace for nsr to be even ! . and greater than or equal to two as required. ==== - nsr = stdlib_ilaenv( 15, 'CLAQR4', jbcmpz, n, ilo, ihi, lwork ) - nsr = min( nsr, ( n-3 ) / 6, ihi-ilo ) - nsr = max( 2, nsr-mod( nsr, 2 ) ) + nsr = stdlib${ii}$_ilaenv( 15_${ik}$, 'CLAQR4', jbcmpz, n, ilo, ihi, lwork ) + nsr = min( nsr, ( n-3 ) / 6_${ik}$, ihi-ilo ) + nsr = max( 2_${ik}$, nsr-mod( nsr, 2_${ik}$ ) ) ! ==== estimate optimal workspace ==== - ! ==== workspace query call to stdlib_claqr2 ==== - call stdlib_claqr2( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& - ld, w, h, ldh, n, h, ldh, n, h,ldh, work, -1 ) - ! ==== optimal workspace = max(stdlib_claqr5, stdlib_claqr2) ==== - lwkopt = max( 3*nsr / 2, int( work( 1 ),KIND=ilp) ) + ! ==== workspace query call to stdlib${ii}$_claqr2 ==== + call stdlib${ii}$_claqr2( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& + ld, w, h, ldh, n, h, ldh, n, h,ldh, work, -1_${ik}$ ) + ! ==== optimal workspace = max(stdlib${ii}$_claqr5, stdlib${ii}$_claqr2) ==== + lwkopt = max( 3_${ik}$*nsr / 2_${ik}$, int( work( 1_${ik}$ ),KIND=${ik}$) ) ! ==== quick return in case of workspace query. ==== - if( lwork==-1 ) then - work( 1 ) = cmplx( lwkopt, 0,KIND=sp) + if( lwork==-1_${ik}$ ) then + work( 1_${ik}$ ) = cmplx( lwkopt, 0_${ik}$,KIND=sp) return end if - ! ==== stdlib_clahqr/stdlib_claqr0 crossover point ==== - nmin = stdlib_ilaenv( 12, 'CLAQR4', jbcmpz, n, ilo, ihi, lwork ) + ! ==== stdlib${ii}$_clahqr/stdlib${ii}$_claqr0 crossover point ==== + nmin = stdlib${ii}$_ilaenv( 12_${ik}$, 'CLAQR4', jbcmpz, n, ilo, ihi, lwork ) nmin = max( ntiny, nmin ) ! ==== nibble crossover point ==== - nibble = stdlib_ilaenv( 14, 'CLAQR4', jbcmpz, n, ilo, ihi, lwork ) - nibble = max( 0, nibble ) + nibble = stdlib${ii}$_ilaenv( 14_${ik}$, 'CLAQR4', jbcmpz, n, ilo, ihi, lwork ) + nibble = max( 0_${ik}$, nibble ) ! ==== accumulate reflections during ttswp? use block ! . 2-by-2 structure during matrix-matrix multiply? ==== - kacc22 = stdlib_ilaenv( 16, 'CLAQR4', jbcmpz, n, ilo, ihi, lwork ) - kacc22 = max( 0, kacc22 ) - kacc22 = min( 2, kacc22 ) + kacc22 = stdlib${ii}$_ilaenv( 16_${ik}$, 'CLAQR4', jbcmpz, n, ilo, ihi, lwork ) + kacc22 = max( 0_${ik}$, kacc22 ) + kacc22 = min( 2_${ik}$, kacc22 ) ! ==== nwmax = the largest possible deflation window for ! . which there is sufficient workspace. ==== - nwmax = min( ( n-1 ) / 3, lwork / 2 ) + nwmax = min( ( n-1 ) / 3_${ik}$, lwork / 2_${ik}$ ) nw = nwmax ! ==== nsmax = the largest number of simultaneous shifts ! . for which there is sufficient workspace. ==== - nsmax = min( ( n-3 ) / 6, 2*lwork / 3 ) - nsmax = nsmax - mod( nsmax, 2 ) + nsmax = min( ( n-3 ) / 6_${ik}$, 2_${ik}$*lwork / 3_${ik}$ ) + nsmax = nsmax - mod( nsmax, 2_${ik}$ ) ! ==== ndfl: an iteration count restarted at deflation. ==== - ndfl = 1 + ndfl = 1_${ik}$ ! ==== itmax = iteration limit ==== - itmax = max( 30, 2*kexsh )*max( 10, ( ihi-ilo+1 ) ) + itmax = max( 30_${ik}$, 2_${ik}$*kexsh )*max( 10_${ik}$, ( ihi-ilo+1 ) ) ! ==== last row and column in the active block ==== kbot = ihi ! ==== main loop ==== @@ -79481,27 +79475,27 @@ module stdlib_linalg_lapack_c ! . in general, more powerful than smaller ones, ! . rapidly increase the window to the maximum possible. ! . then, gradually reduce the window size. ==== - nh = kbot - ktop + 1 + nh = kbot - ktop + 1_${ik}$ nwupbd = min( nh, nwmax ) if( ndfl=nh-1 ) then nw = nh else - kwtop = kbot - nw + 1 + kwtop = kbot - nw + 1_${ik}$ if( cabs1( h( kwtop, kwtop-1 ) )>cabs1( h( kwtop-1, kwtop-2 ) ) )nw = nw + & - 1 + 1_${ik}$ end if end if if( ndfl=0 .or. nw>=nwupbd ) then - ndec = ndec + 1 - if( nw-ndec<2 )ndec = 0 + ndec = -1_${ik}$ + else if( ndec>=0_${ik}$ .or. nw>=nwupbd ) then + ndec = ndec + 1_${ik}$ + if( nw-ndec<2_${ik}$ )ndec = 0_${ik}$ nw = nw - ndec end if ! ==== aggressive early deflation: @@ -79514,39 +79508,39 @@ module stdlib_linalg_lapack_c ! . - an at-least-nw-but-more-is-better (nhv-by-nw) ! . vertical work array along the left-hand-edge. ! . ==== - kv = n - nw + 1 - kt = nw + 1 - nho = ( n-nw-1 ) - kt + 1 - kwv = nw + 2 - nve = ( n-nw ) - kwv + 1 + kv = n - nw + 1_${ik}$ + kt = nw + 1_${ik}$ + nho = ( n-nw-1 ) - kt + 1_${ik}$ + kwv = nw + 2_${ik}$ + nve = ( n-nw ) - kwv + 1_${ik}$ ! ==== aggressive early deflation ==== - call stdlib_claqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & - ls, ld, w, h( kv, 1 ), ldh, nho,h( kv, kt ), ldh, nve, h( kwv, 1 ), ldh, work,& + call stdlib${ii}$_claqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & + ls, ld, w, h( kv, 1_${ik}$ ), ldh, nho,h( kv, kt ), ldh, nve, h( kwv, 1_${ik}$ ), ldh, work,& lwork ) ! ==== adjust kbot accounting for new deflations. ==== kbot = kbot - ld ! ==== ks points to the shifts. ==== - ks = kbot - ls + 1 + ks = kbot - ls + 1_${ik}$ ! ==== skip an expensive qr sweep if there is a (partly ! . heuristic) reason to expect that many eigenvalues ! . will deflate without it. here, the qr sweep is ! . skipped if many eigenvalues have just been deflated ! . or if the remaining active block is small. - if( ( ld==0 ) .or. ( ( 100*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& + if( ( ld==0_${ik}$ ) .or. ( ( 100_${ik}$*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& ) ) ) then ! ==== ns = nominal number of simultaneous shifts. - ! . this may be lowered (slightly) if stdlib_claqr2 + ! . this may be lowered (slightly) if stdlib${ii}$_claqr2 ! . did not provide that many shifts. ==== - ns = min( nsmax, nsr, max( 2, kbot-ktop ) ) - ns = ns - mod( ns, 2 ) + ns = min( nsmax, nsr, max( 2_${ik}$, kbot-ktop ) ) + ns = ns - mod( ns, 2_${ik}$ ) ! ==== if there have been no deflations ! . in a multiple of kexsh iterations, ! . then try exceptional shifts. ! . otherwise use shifts provided by - ! . stdlib_claqr2 above or from the eigenvalues + ! . stdlib${ii}$_claqr2 above or from the eigenvalues ! . of a trailing principal submatrix. ==== - if( mod( ndfl, kexsh )==0 ) then - ks = kbot - ns + 1 + if( mod( ndfl, kexsh )==0_${ik}$ ) then + ks = kbot - ns + 1_${ik}$ do i = kbot, ks + 1, -2 w( i ) = h( i, i ) + wilk1*cabs1( h( i, i-1 ) ) w( i-1 ) = w( i ) @@ -79557,13 +79551,13 @@ module stdlib_linalg_lapack_c ! . get more. (since ns<=nsmax<=(n-3)/6, ! . there is enough space below the subdiagonal ! . to fit an ns-by-ns scratch array.) ==== - if( kbot-ks+1<=ns / 2 ) then - ks = kbot - ns + 1 - kt = n - ns + 1 - call stdlib_clacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1 ), ldh ) + if( kbot-ks+1<=ns / 2_${ik}$ ) then + ks = kbot - ns + 1_${ik}$ + kt = n - ns + 1_${ik}$ + call stdlib${ii}$_clacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1_${ik}$ ), ldh ) - call stdlib_clahqr( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, w( ks )& - , 1, 1, zdum,1, inf ) + call stdlib${ii}$_clahqr( .false., .false., ns, 1_${ik}$, ns,h( kt, 1_${ik}$ ), ldh, w( ks )& + , 1_${ik}$, 1_${ik}$, zdum,1_${ik}$, inf ) ks = ks + inf ! ==== in case of a rare qr failure use ! . eigenvalues of the trailing 2-by-2 @@ -79583,7 +79577,7 @@ module stdlib_linalg_lapack_c rtdisc = sqrt( -det ) w( kbot-1 ) = ( tr2+rtdisc )*s w( kbot ) = ( tr2-rtdisc )*s - ks = kbot - 1 + ks = kbot - 1_${ik}$ end if end if if( kbot-ks+1>ns ) then @@ -79606,7 +79600,7 @@ module stdlib_linalg_lapack_c end if ! ==== if there are only two shifts, then use ! . only cone. ==== - if( kbot-ks+1==2 ) then + if( kbot-ks+1==2_${ik}$ ) then if( cabs1( w( kbot )-h( kbot, kbot ) )0 ) then - ndfl = 1 + if( ld>0_${ik}$ ) then + ndfl = 1_${ik}$ else - ndfl = ndfl + 1 + ndfl = ndfl + 1_${ik}$ end if ! ==== end of main loop ==== end do loop_70 @@ -79656,11 +79650,11 @@ module stdlib_linalg_lapack_c 80 continue end if ! ==== return the optimal value of lwork. ==== - work( 1 ) = cmplx( lwkopt, 0,KIND=sp) - end subroutine stdlib_claqr4 + work( 1_${ik}$ ) = cmplx( lwkopt, 0_${ik}$,KIND=sp) + end subroutine stdlib${ii}$_claqr4 - recursive subroutine stdlib_claqz0( wants, wantq, wantz, n, ilo, ihi, a,lda, b, ldb, alpha, & + recursive subroutine stdlib${ii}$_claqz0( wants, wantq, wantz, n, ilo, ihi, a,lda, b, ldb, alpha, & !! CLAQZ0 computes the eigenvalues of a matrix pair (H,T), !! where H is an upper Hessenberg matrix and T is upper triangular, !! using the double-shift QZ method. @@ -79704,8 +79698,8 @@ module stdlib_linalg_lapack_c beta, q, ldq, z,ldz, work, lwork, rwork, rec,info ) ! arguments character, intent( in ) :: wants, wantq, wantz - integer(ilp), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,rec - integer(ilp), intent( out ) :: info + integer(${ik}$), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,rec + integer(${ik}$), intent( out ) :: info complex(sp), intent( inout ) :: a( lda, * ), b( ldb, * ), q( ldq, * ),z( ldz, * ), & alpha( * ), beta( * ), work( * ) real(sp), intent( out ) :: rwork( * ) @@ -79714,133 +79708,133 @@ module stdlib_linalg_lapack_c ! local scalars real(sp) :: smlnum, ulp, safmin, safmax, c1, tempr complex(sp) :: eshift, s1, temp - integer(ilp) :: istart, istop, iiter, maxit, istart2, k, ld, nshifts, nblock, nw, nmin,& + integer(${ik}$) :: istart, istop, iiter, maxit, istart2, k, ld, nshifts, nblock, nw, nmin,& nibble, n_undeflated, n_deflated, ns, sweep_info, shiftpos, lworkreq, k2, istartm, & istopm, iwants, iwantq, iwantz, norm_info, aed_info, nwr, nbr, nsr, itemp1, itemp2, & rcost logical(lk) :: ilschur, ilq, ilz - character :: jbcmpz*3 + character(len=3) :: jbcmpz if( stdlib_lsame( wants, 'E' ) ) then ilschur = .false. - iwants = 1 + iwants = 1_${ik}$ else if( stdlib_lsame( wants, 'S' ) ) then ilschur = .true. - iwants = 2 + iwants = 2_${ik}$ else - iwants = 0 + iwants = 0_${ik}$ end if if( stdlib_lsame( wantq, 'N' ) ) then ilq = .false. - iwantq = 1 + iwantq = 1_${ik}$ else if( stdlib_lsame( wantq, 'V' ) ) then ilq = .true. - iwantq = 2 + iwantq = 2_${ik}$ else if( stdlib_lsame( wantq, 'I' ) ) then ilq = .true. - iwantq = 3 + iwantq = 3_${ik}$ else - iwantq = 0 + iwantq = 0_${ik}$ end if if( stdlib_lsame( wantz, 'N' ) ) then ilz = .false. - iwantz = 1 + iwantz = 1_${ik}$ else if( stdlib_lsame( wantz, 'V' ) ) then ilz = .true. - iwantz = 2 + iwantz = 2_${ik}$ else if( stdlib_lsame( wantz, 'I' ) ) then ilz = .true. - iwantz = 3 + iwantz = 3_${ik}$ else - iwantz = 0 + iwantz = 0_${ik}$ end if ! check argument values - info = 0 - if( iwants==0 ) then - info = -1 - else if( iwantq==0 ) then - info = -2 - else if( iwantz==0 ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( ilo<1 ) then - info = -5 + info = 0_${ik}$ + if( iwants==0_${ik}$ ) then + info = -1_${ik}$ + else if( iwantq==0_${ik}$ ) then + info = -2_${ik}$ + else if( iwantz==0_${ik}$ ) then + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( ilo<1_${ik}$ ) then + info = -5_${ik}$ else if( ihi>n .or. ihi= 2 ) then - call stdlib_chgeqz( wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb,alpha, beta, q,& + if( n < nmin .or. rec >= 2_${ik}$ ) then + call stdlib${ii}$_chgeqz( wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb,alpha, beta, q,& ldq, z, ldz, work, lwork, rwork,info ) return end if ! find out required workspace - ! workspace query to stdlib_claqz2 + ! workspace query to stdlib${ii}$_claqz2 nw = max( nwr, nmin ) - call stdlib_claqz2( ilschur, ilq, ilz, n, ilo, ihi, nw, a, lda, b, ldb,q, ldq, z, ldz, & - n_undeflated, n_deflated, alpha,beta, work, nw, work, nw, work, -1, rwork, rec,& + call stdlib${ii}$_claqz2( ilschur, ilq, ilz, n, ilo, ihi, nw, a, lda, b, ldb,q, ldq, z, ldz, & + n_undeflated, n_deflated, alpha,beta, work, nw, work, nw, work, -1_${ik}$, rwork, rec,& aed_info ) - itemp1 = int( work( 1 ),KIND=ilp) - ! workspace query to stdlib_claqz3 - call stdlib_claqz3( ilschur, ilq, ilz, n, ilo, ihi, nsr, nbr, alpha,beta, a, lda, b, & - ldb, q, ldq, z, ldz, work, nbr,work, nbr, work, -1, sweep_info ) - itemp2 = int( work( 1 ),KIND=ilp) - lworkreq = max( itemp1+2*nw**2, itemp2+2*nbr**2 ) - if ( lwork ==-1 ) then - work( 1 ) = real( lworkreq,KIND=sp) + itemp1 = int( work( 1_${ik}$ ),KIND=${ik}$) + ! workspace query to stdlib${ii}$_claqz3 + call stdlib${ii}$_claqz3( ilschur, ilq, ilz, n, ilo, ihi, nsr, nbr, alpha,beta, a, lda, b, & + ldb, q, ldq, z, ldz, work, nbr,work, nbr, work, -1_${ik}$, sweep_info ) + itemp2 = int( work( 1_${ik}$ ),KIND=${ik}$) + lworkreq = max( itemp1+2*nw**2_${ik}$, itemp2+2*nbr**2_${ik}$ ) + if ( lwork ==-1_${ik}$ ) then + work( 1_${ik}$ ) = real( lworkreq,KIND=sp) return else if ( lwork < lworkreq ) then - info = -19 + info = -19_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'CLAQZ0', info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'CLAQZ0', info ) return end if ! initialize q and z - if( iwantq==3 ) call stdlib_claset( 'FULL', n, n, czero, cone, q,ldq ) - if( iwantz==3 ) call stdlib_claset( 'FULL', n, n, czero, cone, z,ldz ) + if( iwantq==3_${ik}$ ) call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, q,ldq ) + if( iwantz==3_${ik}$ ) call stdlib${ii}$_claset( 'FULL', n, n, czero, cone, z,ldz ) ! get machine constants - safmin = stdlib_slamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) safmax = one/safmin - call stdlib_slabad( safmin, safmax ) - ulp = stdlib_slamch( 'PRECISION' ) + call stdlib${ii}$_slabad( safmin, safmax ) + ulp = stdlib${ii}$_slamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=sp)/ulp ) istart = ilo istop = ihi - maxit = 30*( ihi-ilo+1 ) - ld = 0 + maxit = 30_${ik}$*( ihi-ilo+1 ) + ld = 0_${ik}$ do iiter = 1, maxit if( iiter >= maxit ) then info = istop+1 @@ -79855,7 +79849,7 @@ module stdlib_linalg_lapack_c a( istop-1,istop-1 ) ) ) ) ) then a( istop, istop-1 ) = czero istop = istop-1 - ld = 0 + ld = 0_${ik}$ eshift = czero end if ! check deflations at the start @@ -79863,7 +79857,7 @@ module stdlib_linalg_lapack_c abs( a( istart+1,istart+1 ) ) ) ) ) then a( istart+1, istart ) = czero istart = istart+1 - ld = 0 + ld = 0_${ik}$ eshift = czero end if if ( istart+1 >= istop ) then @@ -79881,7 +79875,7 @@ module stdlib_linalg_lapack_c end do ! get range to apply rotations to if ( ilschur ) then - istartm = 1 + istartm = 1_${ik}$ istopm = n else istartm = istart2 @@ -79902,42 +79896,42 @@ module stdlib_linalg_lapack_c ! a diagonal element of b is negligable, move it ! to the top and deflate it do k2 = k, istart2+1, -1 - call stdlib_clartg( b( k2-1, k2 ), b( k2-1, k2-1 ), c1, s1,temp ) + call stdlib${ii}$_clartg( b( k2-1, k2 ), b( k2-1, k2-1 ), c1, s1,temp ) b( k2-1, k2 ) = temp b( k2-1, k2-1 ) = czero - call stdlib_crot( k2-2-istartm+1, b( istartm, k2 ), 1,b( istartm, k2-1 ), & - 1, c1, s1 ) - call stdlib_crot( min( k2+1, istop )-istartm+1, a( istartm,k2 ), 1, a( & - istartm, k2-1 ), 1, c1, s1 ) + call stdlib${ii}$_crot( k2-2-istartm+1, b( istartm, k2 ), 1_${ik}$,b( istartm, k2-1 ), & + 1_${ik}$, c1, s1 ) + call stdlib${ii}$_crot( min( k2+1, istop )-istartm+1, a( istartm,k2 ), 1_${ik}$, a( & + istartm, k2-1 ), 1_${ik}$, c1, s1 ) if ( ilz ) then - call stdlib_crot( n, z( 1, k2 ), 1, z( 1, k2-1 ), 1, c1,s1 ) + call stdlib${ii}$_crot( n, z( 1_${ik}$, k2 ), 1_${ik}$, z( 1_${ik}$, k2-1 ), 1_${ik}$, c1,s1 ) end if if( k2= istop ) then istop = istart2-1 - ld = 0 + ld = 0_${ik}$ eshift = czero cycle end if @@ -79959,7 +79953,7 @@ module stdlib_linalg_lapack_c if ( istop-istart2+1 < nmin ) then ! setting nw to the size of the subblock will make aed deflate ! all the eigenvalues. this is slightly more efficient than just - ! using stdlib_chgeqz because the off diagonal part gets updated via blas. + ! using stdlib${ii}$_chgeqz because the off diagonal part gets updated via blas. if ( istop-istart+1 < nmin ) then nw = istop-istart+1 istart2 = istart @@ -79968,15 +79962,15 @@ module stdlib_linalg_lapack_c end if end if ! time for aed - call stdlib_claqz2( ilschur, ilq, ilz, n, istart2, istop, nw, a, lda,b, ldb, q, ldq,& - z, ldz, n_undeflated, n_deflated,alpha, beta, work, nw, work( nw**2+1 ), nw,work( & - 2*nw**2+1 ), lwork-2*nw**2, rwork, rec,aed_info ) - if ( n_deflated > 0 ) then + call stdlib${ii}$_claqz2( ilschur, ilq, ilz, n, istart2, istop, nw, a, lda,b, ldb, q, ldq,& + z, ldz, n_undeflated, n_deflated,alpha, beta, work, nw, work( nw**2_${ik}$+1 ), nw,work( & + 2_${ik}$*nw**2_${ik}$+1 ), lwork-2*nw**2_${ik}$, rwork, rec,aed_info ) + if ( n_deflated > 0_${ik}$ ) then istop = istop-n_deflated - ld = 0 + ld = 0_${ik}$ eshift = czero end if - if ( 100*n_deflated > nibble*( n_deflated+n_undeflated ) .or.istop-istart2+1 < nmin & + if ( 100_${ik}$*n_deflated > nibble*( n_deflated+n_undeflated ) .or.istop-istart2+1 < nmin & ) then ! aed has uncovered many eigenvalues. skip a qz sweep and run ! aed again. @@ -79986,7 +79980,7 @@ module stdlib_linalg_lapack_c ns = min( nshifts, istop-istart2 ) ns = min( ns, n_undeflated ) shiftpos = istop-n_deflated-n_undeflated+1 - if ( mod( ld, 6 ) == 0 ) then + if ( mod( ld, 6_${ik}$ ) == 0_${ik}$ ) then ! exceptional shift. chosen for no particularly good reason. if( ( real( maxit,KIND=sp)*safmin )*abs( a( istop,istop-1 ) ) ilo ) then a( kwtop, kwtop-1 ) = czero end if end if end if ! store window in case of convergence failure - call stdlib_clacpy( 'ALL', jw, jw, a( kwtop, kwtop ), lda, work, jw ) - call stdlib_clacpy( 'ALL', jw, jw, b( kwtop, kwtop ), ldb, work( jw**2+1 ), jw ) + call stdlib${ii}$_clacpy( 'ALL', jw, jw, a( kwtop, kwtop ), lda, work, jw ) + call stdlib${ii}$_clacpy( 'ALL', jw, jw, b( kwtop, kwtop ), ldb, work( jw**2_${ik}$+1 ), jw ) ! transform window to real schur form - call stdlib_claset( 'FULL', jw, jw, czero, cone, qc, ldqc ) - call stdlib_claset( 'FULL', jw, jw, czero, cone, zc, ldzc ) - call stdlib_claqz0( 'S', 'V', 'V', jw, 1, jw, a( kwtop, kwtop ), lda,b( kwtop, kwtop ),& - ldb, alpha, beta, qc, ldqc, zc,ldzc, work( 2*jw**2+1 ), lwork-2*jw**2, rwork,rec+1, & + call stdlib${ii}$_claset( 'FULL', jw, jw, czero, cone, qc, ldqc ) + call stdlib${ii}$_claset( 'FULL', jw, jw, czero, cone, zc, ldzc ) + call stdlib${ii}$_claqz0( 'S', 'V', 'V', jw, 1_${ik}$, jw, a( kwtop, kwtop ), lda,b( kwtop, kwtop ),& + ldb, alpha, beta, qc, ldqc, zc,ldzc, work( 2_${ik}$*jw**2_${ik}$+1 ), lwork-2*jw**2_${ik}$, rwork,rec+1, & qz_small_info ) - if( qz_small_info /= 0 ) then + if( qz_small_info /= 0_${ik}$ ) then ! convergence failure, restore the window and exit - nd = 0 + nd = 0_${ik}$ ns = jw-qz_small_info - call stdlib_clacpy( 'ALL', jw, jw, work, jw, a( kwtop, kwtop ), lda ) - call stdlib_clacpy( 'ALL', jw, jw, work( jw**2+1 ), jw, b( kwtop,kwtop ), ldb ) + call stdlib${ii}$_clacpy( 'ALL', jw, jw, work, jw, a( kwtop, kwtop ), lda ) + call stdlib${ii}$_clacpy( 'ALL', jw, jw, work( jw**2_${ik}$+1 ), jw, b( kwtop,kwtop ), ldb ) return end if @@ -80104,15 +80098,15 @@ module stdlib_linalg_lapack_c kwbot = kwtop-1 else kwbot = ihi - k = 1 - k2 = 1 + k = 1_${ik}$ + k2 = 1_${ik}$ do while ( k <= jw ) ! try to deflate eigenvalue tempr = abs( a( kwbot, kwbot ) ) if( tempr == zero ) then tempr = abs( s ) end if - if ( ( abs( s*qc( 1, kwbot-kwtop+1 ) ) ) <= max( ulp*tempr, smlnum ) ) & + if ( ( abs( s*qc( 1_${ik}$, kwbot-kwtop+1 ) ) ) <= max( ulp*tempr, smlnum ) ) & then ! deflatable kwbot = kwbot-1 @@ -80120,7 +80114,7 @@ module stdlib_linalg_lapack_c ! not deflatable, move out of the way ifst = kwbot-kwtop+1 ilst = k2 - call stdlib_ctgexc( .true., .true., jw, a( kwtop, kwtop ),lda, b( kwtop, & + call stdlib${ii}$_ctgexc( .true., .true., jw, a( kwtop, kwtop ),lda, b( kwtop, & kwtop ), ldb, qc, ldqc,zc, ldzc, ifst, ilst, ctgexc_info ) k2 = k2+1 end if @@ -80138,16 +80132,16 @@ module stdlib_linalg_lapack_c end do if ( kwtop /= ilo .and. s /= czero ) then ! reflect spike back, this will create optimally packed bulges - a( kwtop:kwbot, kwtop-1 ) = a( kwtop, kwtop-1 ) *conjg( qc( 1,1:jw-nd ) ) + a( kwtop:kwbot, kwtop-1 ) = a( kwtop, kwtop-1 ) *conjg( qc( 1_${ik}$,1_${ik}$:jw-nd ) ) do k = kwbot-1, kwtop, -1 - call stdlib_clartg( a( k, kwtop-1 ), a( k+1, kwtop-1 ), c1, s1,temp ) + call stdlib${ii}$_clartg( a( k, kwtop-1 ), a( k+1, kwtop-1 ), c1, s1,temp ) a( k, kwtop-1 ) = temp a( k+1, kwtop-1 ) = czero k2 = max( kwtop, k-1 ) - call stdlib_crot( ihi-k2+1, a( k, k2 ), lda, a( k+1, k2 ), lda, c1,s1 ) - call stdlib_crot( ihi-( k-1 )+1, b( k, k-1 ), ldb, b( k+1, k-1 ),ldb, c1, s1 ) + call stdlib${ii}$_crot( ihi-k2+1, a( k, k2 ), lda, a( k+1, k2 ), lda, c1,s1 ) + call stdlib${ii}$_crot( ihi-( k-1 )+1_${ik}$, b( k, k-1 ), ldb, b( k+1, k-1 ),ldb, c1, s1 ) - call stdlib_crot( jw, qc( 1, k-kwtop+1 ), 1, qc( 1, k+1-kwtop+1 ),1, c1, conjg( & + call stdlib${ii}$_crot( jw, qc( 1_${ik}$, k-kwtop+1 ), 1_${ik}$, qc( 1_${ik}$, k+1-kwtop+1 ),1_${ik}$, c1, conjg( & s1 ) ) end do ! chase bulges down @@ -80157,7 +80151,7 @@ module stdlib_linalg_lapack_c do while ( k >= kwtop ) ! move bulge down and remove it do k2 = k, kwbot-1 - call stdlib_claqz1( .true., .true., k2, kwtop, kwtop+jw-1,kwbot, a, lda, b, & + call stdlib${ii}$_claqz1( .true., .true., k2, kwtop, kwtop+jw-1,kwbot, a, lda, b, & ldb, jw, kwtop, qc, ldqc,jw, kwtop, zc, ldzc ) end do k = k-1 @@ -80165,44 +80159,44 @@ module stdlib_linalg_lapack_c end if ! apply qc and zc to rest of the matrix if ( ilschur ) then - istartm = 1 + istartm = 1_${ik}$ istopm = n else istartm = ilo istopm = ihi end if - if ( istopm-ihi > 0 ) then - call stdlib_cgemm( 'C', 'N', jw, istopm-ihi, jw, cone, qc, ldqc,a( kwtop, ihi+1 ), & + if ( istopm-ihi > 0_${ik}$ ) then + call stdlib${ii}$_cgemm( 'C', 'N', jw, istopm-ihi, jw, cone, qc, ldqc,a( kwtop, ihi+1 ), & lda, czero, work, jw ) - call stdlib_clacpy( 'ALL', jw, istopm-ihi, work, jw, a( kwtop,ihi+1 ), lda ) - call stdlib_cgemm( 'C', 'N', jw, istopm-ihi, jw, cone, qc, ldqc,b( kwtop, ihi+1 ), & + call stdlib${ii}$_clacpy( 'ALL', jw, istopm-ihi, work, jw, a( kwtop,ihi+1 ), lda ) + call stdlib${ii}$_cgemm( 'C', 'N', jw, istopm-ihi, jw, cone, qc, ldqc,b( kwtop, ihi+1 ), & ldb, czero, work, jw ) - call stdlib_clacpy( 'ALL', jw, istopm-ihi, work, jw, b( kwtop,ihi+1 ), ldb ) + call stdlib${ii}$_clacpy( 'ALL', jw, istopm-ihi, work, jw, b( kwtop,ihi+1 ), ldb ) end if if ( ilq ) then - call stdlib_cgemm( 'N', 'N', n, jw, jw, cone, q( 1, kwtop ), ldq, qc,ldqc, czero, & + call stdlib${ii}$_cgemm( 'N', 'N', n, jw, jw, cone, q( 1_${ik}$, kwtop ), ldq, qc,ldqc, czero, & work, n ) - call stdlib_clacpy( 'ALL', n, jw, work, n, q( 1, kwtop ), ldq ) + call stdlib${ii}$_clacpy( 'ALL', n, jw, work, n, q( 1_${ik}$, kwtop ), ldq ) end if - if ( kwtop-1-istartm+1 > 0 ) then - call stdlib_cgemm( 'N', 'N', kwtop-istartm, jw, jw, cone, a( istartm,kwtop ), lda, & + if ( kwtop-1-istartm+1 > 0_${ik}$ ) then + call stdlib${ii}$_cgemm( 'N', 'N', kwtop-istartm, jw, jw, cone, a( istartm,kwtop ), lda, & zc, ldzc, czero, work,kwtop-istartm ) - call stdlib_clacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,a( istartm, kwtop )& + call stdlib${ii}$_clacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,a( istartm, kwtop )& , lda ) - call stdlib_cgemm( 'N', 'N', kwtop-istartm, jw, jw, cone, b( istartm,kwtop ), ldb, & + call stdlib${ii}$_cgemm( 'N', 'N', kwtop-istartm, jw, jw, cone, b( istartm,kwtop ), ldb, & zc, ldzc, czero, work,kwtop-istartm ) - call stdlib_clacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,b( istartm, kwtop )& + call stdlib${ii}$_clacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,b( istartm, kwtop )& , ldb ) end if if ( ilz ) then - call stdlib_cgemm( 'N', 'N', n, jw, jw, cone, z( 1, kwtop ), ldz, zc,ldzc, czero, & + call stdlib${ii}$_cgemm( 'N', 'N', n, jw, jw, cone, z( 1_${ik}$, kwtop ), ldz, zc,ldzc, czero, & work, n ) - call stdlib_clacpy( 'ALL', n, jw, work, n, z( 1, kwtop ), ldz ) + call stdlib${ii}$_clacpy( 'ALL', n, jw, work, n, z( 1_${ik}$, kwtop ), ldz ) end if - end subroutine stdlib_claqz2 + end subroutine stdlib${ii}$_claqz2 - pure subroutine stdlib_clasyf_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) + pure subroutine stdlib${ii}$_clasyf_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) !! DLATRF_AA factorizes a panel of a complex symmetric matrix A using !! the Aasen's algorithm. The panel consists of a set of NB rows of A !! when UPLO is U, or a set of NB columns when UPLO is L. @@ -80218,23 +80212,23 @@ module stdlib_linalg_lapack_c ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: m, nb, j1, lda, ldh + integer(${ik}$), intent(in) :: m, nb, j1, lda, ldh ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(sp), intent(inout) :: a(lda,*), h(ldh,*) complex(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: j, k, k1, i1, i2, mj + integer(${ik}$) :: j, k, k1, i1, i2, mj complex(sp) :: piv, alpha ! Intrinsic Functions intrinsic :: max ! Executable Statements - j = 1 + j = 1_${ik}$ ! k1 is the first column of the panel to be factorized ! i.e., k1 is 2 for the first block column, and 1 for the rest of the blocks - k1 = (2-j1)+1 + k1 = (2_${ik}$-j1)+1_${ik}$ if( stdlib_lsame( uplo, 'U' ) ) then ! ..................................................... ! factorize a as u**t*d*u using the upper triangle of a @@ -80242,96 +80236,96 @@ module stdlib_linalg_lapack_c 10 continue if ( j>min(m, nb) )go to 20 ! k is the column to be factorized - ! when being called from stdlib_csytrf_aa, + ! when being called from stdlib${ii}$_csytrf_aa, ! > for the first block column, j1 is 1, hence j1+j-1 is j, ! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1, k = j1+j-1 if( j==m ) then ! only need to compute t(j, j) - mj = 1 + mj = 1_${ik}$ else mj = m-j+1 end if ! h(j:m, j) := a(j, j:m) - h(j:m, 1:(j-1)) * l(j1:(j-1), j), ! where h(j:m, j) has been initialized to be a(j, j:m) - if( k>2 ) then + if( k>2_${ik}$ ) then ! k is the column to be factorized ! > for the first block column, k is j, skipping the first two ! columns ! > for the rest of the columns, k is j+1, skipping only the ! first column - call stdlib_cgemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( 1, j ), 1,& - cone, h( j, j ), 1 ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( 1_${ik}$, j ), 1_${ik}$,& + cone, h( j, j ), 1_${ik}$ ) end if ! copy h(i:m, i) into work - call stdlib_ccopy( mj, h( j, j ), 1, work( 1 ), 1 ) + call stdlib${ii}$_ccopy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) if( j>k1 ) then ! compute work := work - l(j-1, j:m) * t(j-1,j), ! where a(j-1, j) stores t(j-1, j) and a(j-2, j:m) stores u(j-1, j:m) alpha = -a( k-1, j ) - call stdlib_caxpy( mj, alpha, a( k-2, j ), lda, work( 1 ), 1 ) + call stdlib${ii}$_caxpy( mj, alpha, a( k-2, j ), lda, work( 1_${ik}$ ), 1_${ik}$ ) end if ! set a(j, j) = t(j, j) - a( k, j ) = work( 1 ) + a( k, j ) = work( 1_${ik}$ ) if( j1 ) then + if( k>1_${ik}$ ) then alpha = -a( k, j ) - call stdlib_caxpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2 ), 1 ) + call stdlib${ii}$_caxpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2_${ik}$ ), 1_${ik}$ ) endif ! find max(|work(2:m)|) - i2 = stdlib_icamax( m-j, work( 2 ), 1 ) + 1 + i2 = stdlib${ii}$_icamax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$ piv = work( i2 ) ! apply symmetric pivot - if( (i2/=2) .and. (piv/=0) ) then + if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then ! swap work(i1) and work(i2) - i1 = 2 + i1 = 2_${ik}$ work( i2 ) = work( i1 ) work( i1 ) = piv ! swap a(i1, i1+1:m) with a(i1+1:m, i2) i1 = i1+j-1 i2 = i2+j-1 - call stdlib_cswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1 ) + call stdlib${ii}$_cswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1_${ik}$ ) ! swap a(i1, i2+1:m) with a(i2, i2+1:m) - if( i2(k1-1) ) then ! swap l(1:i1-1, i1) with l(1:i1-1, i2), ! skipping the first column - call stdlib_cswap( i1-k1+1, a( 1, i1 ), 1,a( 1, i2 ), 1 ) + call stdlib${ii}$_cswap( i1-k1+1, a( 1_${ik}$, i1 ), 1_${ik}$,a( 1_${ik}$, i2 ), 1_${ik}$ ) end if else ipiv( j+1 ) = j+1 endif ! set a(j, j+1) = t(j, j+1) - a( k, j+1 ) = work( 2 ) + a( k, j+1 ) = work( 2_${ik}$ ) if( jmin( m, nb ) )go to 40 ! k is the column to be factorized - ! when being called from stdlib_csytrf_aa, + ! when being called from stdlib${ii}$_csytrf_aa, ! > for the first block column, j1 is 1, hence j1+j-1 is j, ! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1, k = j1+j-1 if( j==m ) then ! only need to compute t(j, j) - mj = 1 + mj = 1_${ik}$ else mj = m-j+1 end if ! h(j:m, j) := a(j:m, j) - h(j:m, 1:(j-1)) * l(j, j1:(j-1))^t, ! where h(j:m, j) has been initialized to be a(j:m, j) - if( k>2 ) then + if( k>2_${ik}$ ) then ! k is the column to be factorized ! > for the first block column, k is j, skipping the first two ! columns ! > for the rest of the columns, k is j+1, skipping only the ! first column - call stdlib_cgemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( j, 1 ), & - lda,cone, h( j, j ), 1 ) + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( j, 1_${ik}$ ), & + lda,cone, h( j, j ), 1_${ik}$ ) end if ! copy h(j:m, j) into work - call stdlib_ccopy( mj, h( j, j ), 1, work( 1 ), 1 ) + call stdlib${ii}$_ccopy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) if( j>k1 ) then ! compute work := work - l(j:m, j-1) * t(j-1,j), ! where a(j-1, j) = t(j-1, j) and a(j, j-2) = l(j, j-1) alpha = -a( j, k-1 ) - call stdlib_caxpy( mj, alpha, a( j, k-2 ), 1, work( 1 ), 1 ) + call stdlib${ii}$_caxpy( mj, alpha, a( j, k-2 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) end if ! set a(j, j) = t(j, j) - a( j, k ) = work( 1 ) + a( j, k ) = work( 1_${ik}$ ) if( j1 ) then + if( k>1_${ik}$ ) then alpha = -a( j, k ) - call stdlib_caxpy( m-j, alpha, a( j+1, k-1 ), 1,work( 2 ), 1 ) + call stdlib${ii}$_caxpy( m-j, alpha, a( j+1, k-1 ), 1_${ik}$,work( 2_${ik}$ ), 1_${ik}$ ) endif ! find max(|work(2:m)|) - i2 = stdlib_icamax( m-j, work( 2 ), 1 ) + 1 + i2 = stdlib${ii}$_icamax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$ piv = work( i2 ) ! apply symmetric pivot - if( (i2/=2) .and. (piv/=0) ) then + if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then ! swap work(i1) and work(i2) - i1 = 2 + i1 = 2_${ik}$ work( i2 ) = work( i1 ) work( i1 ) = piv ! swap a(i1+1:m, i1) with a(i2, i1+1:m) i1 = i1+j-1 i2 = i2+j-1 - call stdlib_cswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1,a( i2, j1+i1 ), lda ) + call stdlib${ii}$_cswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1_${ik}$,a( i2, j1+i1 ), lda ) ! swap a(i2+1:m, i1) with a(i2+1:m, i2) - if( i2(k1-1) ) then ! swap l(1:i1-1, i1) with l(1:i1-1, i2), ! skipping the first column - call stdlib_cswap( i1-k1+1, a( i1, 1 ), lda,a( i2, 1 ), lda ) + call stdlib${ii}$_cswap( i1-k1+1, a( i1, 1_${ik}$ ), lda,a( i2, 1_${ik}$ ), lda ) end if else ipiv( j+1 ) = j+1 endif ! set a(j+1, j) = t(j+1, j) - a( j+1, k ) = work( 2 ) + a( j+1, k ) = work( 2_${ik}$ ) if( j=n )go to 20 ! each step of the main loop @@ -80593,17 +80587,17 @@ module stdlib_linalg_lapack_c ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=1 for the first panel, and ! k1=0 for the rest - j1 = j + 1 + j1 = j + 1_${ik}$ jb = min( n-j1+1, nb ) - k1 = max(1, j)-j + k1 = max(1_${ik}$, j)-j ! panel factorization - call stdlib_clasyf_aa( uplo, 2-k1, n-j, jb,a( max(1, j), j+1 ), lda,ipiv( j+1 ), & + call stdlib${ii}$_clasyf_aa( uplo, 2_${ik}$-k1, n-j, jb,a( max(1_${ik}$, j), j+1 ), lda,ipiv( j+1 ), & work, n, work( n*nb+1 ) ) ! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot) do j2 = j+2, min(n, j+jb+1) ipiv( j2 ) = ipiv( j2 ) + j - if( (j2/=ipiv(j2)) .and. ((j1-k1)>2) ) then - call stdlib_cswap( j1-k1-2, a( 1, j2 ), 1,a( 1, ipiv(j2) ), 1 ) + if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then + call stdlib${ii}$_cswap( j1-k1-2, a( 1_${ik}$, j2 ), 1_${ik}$,a( 1_${ik}$, ipiv(j2) ), 1_${ik}$ ) end if end do j = j + jb @@ -80612,43 +80606,43 @@ module stdlib_linalg_lapack_c ! work stores the current block of the auxiriarly matrix h if( j1 .or. jb>1 ) then + if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then ! merge rank-1 update with blas-3 update alpha = a( j, j+1 ) a( j, j+1 ) = cone - call stdlib_ccopy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib${ii}$_ccopy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) - call stdlib_cscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib${ii}$_cscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=1 and k2= 0 for the first panel, ! while k1=0 and k2=1 for the rest - if( j1>1 ) then + if( j1>1_${ik}$ ) then ! not first panel - k2 = 1 + k2 = 1_${ik}$ else ! first panel - k2 = 0 + k2 = 0_${ik}$ ! first update skips the first column - jb = jb - 1 + jb = jb - 1_${ik}$ end if do j2 = j+1, n, nb nj = min( nb, n-j2+1 ) - ! update (j2, j2) diagonal block with stdlib_cgemv + ! update (j2, j2) diagonal block with stdlib${ii}$_cgemv j3 = j2 do mj = nj-1, 1, -1 - call stdlib_cgemv( 'NO TRANSPOSE', mj, jb+1,-cone, work( j3-j1+1+k1*n ),& - n,a( j1-k2, j3 ), 1,cone, a( j3, j3 ), lda ) - j3 = j3 + 1 + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', mj, jb+1,-cone, work( j3-j1+1+k1*n ),& + n,a( j1-k2, j3 ), 1_${ik}$,cone, a( j3, j3 ), lda ) + j3 = j3 + 1_${ik}$ end do - ! update off-diagonal block of j2-th block row with stdlib_cgemm - call stdlib_cgemm( 'TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-cone, a( j1-& + ! update off-diagonal block of j2-th block row with stdlib${ii}$_cgemm + call stdlib${ii}$_cgemm( 'TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-cone, a( j1-& k2, j2 ), lda,work( j3-j1+1+k1*n ), n,cone, a( j2, j3 ), lda ) end do ! recover t( j, j+1 ) a( j, j+1 ) = alpha end if ! work(j+1, 1) stores h(j+1, 1) - call stdlib_ccopy( n-j, a( j+1, j+1 ), lda, work( 1 ), 1 ) + call stdlib${ii}$_ccopy( n-j, a( j+1, j+1 ), lda, work( 1_${ik}$ ), 1_${ik}$ ) end if go to 10 else @@ -80657,11 +80651,11 @@ module stdlib_linalg_lapack_c ! ..................................................... ! copy first column a(1:n, 1) into h(1:n, 1) ! (stored in work(1:n)) - call stdlib_ccopy( n, a( 1, 1 ), 1, work( 1 ), 1 ) + call stdlib${ii}$_ccopy( n, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) ! j is the main loop index, increasing from 1 to n in steps of - ! jb, where jb is the number of columns factorized by stdlib_clasyf; + ! jb, where jb is the number of columns factorized by stdlib${ii}$_clasyf; ! jb is either nb, or n-j+1 for the last block - j = 0 + j = 0_${ik}$ 11 continue if( j>=n )go to 20 ! each step of the main loop @@ -80672,15 +80666,15 @@ module stdlib_linalg_lapack_c ! k1=0 for the rest j1 = j+1 jb = min( n-j1+1, nb ) - k1 = max(1, j)-j + k1 = max(1_${ik}$, j)-j ! panel factorization - call stdlib_clasyf_aa( uplo, 2-k1, n-j, jb,a( j+1, max(1, j) ), lda,ipiv( j+1 ), & + call stdlib${ii}$_clasyf_aa( uplo, 2_${ik}$-k1, n-j, jb,a( j+1, max(1_${ik}$, j) ), lda,ipiv( j+1 ), & work, n, work( n*nb+1 ) ) ! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot) do j2 = j+2, min(n, j+jb+1) ipiv( j2 ) = ipiv( j2 ) + j - if( (j2/=ipiv(j2)) .and. ((j1-k1)>2) ) then - call stdlib_cswap( j1-k1-2, a( j2, 1 ), lda,a( ipiv(j2), 1 ), lda ) + if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then + call stdlib${ii}$_cswap( j1-k1-2, a( j2, 1_${ik}$ ), lda,a( ipiv(j2), 1_${ik}$ ), lda ) end if end do j = j + jb @@ -80689,35 +80683,35 @@ module stdlib_linalg_lapack_c ! work(j2+1, 1) stores h(j2+1, 1) if( j1 .or. jb>1 ) then + if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then ! merge rank-1 update with blas-3 update alpha = a( j+1, j ) a( j+1, j ) = cone - call stdlib_ccopy( n-j, a( j+1, j-1 ), 1,work( (j+1-j1+1)+jb*n ), 1 ) - call stdlib_cscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib${ii}$_ccopy( n-j, a( j+1, j-1 ), 1_${ik}$,work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) + call stdlib${ii}$_cscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=1 and k2= 0 for the first panel, ! while k1=0 and k2=1 for the rest - if( j1>1 ) then + if( j1>1_${ik}$ ) then ! not first panel - k2 = 1 + k2 = 1_${ik}$ else ! first panel - k2 = 0 + k2 = 0_${ik}$ ! first update skips the first column - jb = jb - 1 + jb = jb - 1_${ik}$ end if do j2 = j+1, n, nb nj = min( nb, n-j2+1 ) - ! update (j2, j2) diagonal block with stdlib_cgemv + ! update (j2, j2) diagonal block with stdlib${ii}$_cgemv j3 = j2 do mj = nj-1, 1, -1 - call stdlib_cgemv( 'NO TRANSPOSE', mj, jb+1,-cone, work( j3-j1+1+k1*n ),& - n,a( j3, j1-k2 ), lda,cone, a( j3, j3 ), 1 ) - j3 = j3 + 1 + call stdlib${ii}$_cgemv( 'NO TRANSPOSE', mj, jb+1,-cone, work( j3-j1+1+k1*n ),& + n,a( j3, j1-k2 ), lda,cone, a( j3, j3 ), 1_${ik}$ ) + j3 = j3 + 1_${ik}$ end do - ! update off-diagonal block in j2-th block column with stdlib_cgemm - call stdlib_cgemm( 'NO TRANSPOSE', 'TRANSPOSE',n-j3+1, nj, jb+1,-cone, & + ! update off-diagonal block in j2-th block column with stdlib${ii}$_cgemm + call stdlib${ii}$_cgemm( 'NO TRANSPOSE', 'TRANSPOSE',n-j3+1, nj, jb+1,-cone, & work( j3-j1+1+k1*n ), n,a( j2, j1-k2 ), lda,cone, a( j3, j2 ), lda ) end do @@ -80725,15 +80719,15 @@ module stdlib_linalg_lapack_c a( j+1, j ) = alpha end if ! work(j+1, 1) stores h(j+1, 1) - call stdlib_ccopy( n-j, a( j+1, j+1 ), 1, work( 1 ), 1 ) + call stdlib${ii}$_ccopy( n-j, a( j+1, j+1 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) end if go to 11 end if 20 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_csytrf_aa - + end subroutine stdlib${ii}$_csytrf_aa + #:endfor end module stdlib_linalg_lapack_c diff --git a/src/stdlib_linalg_lapack_d.fypp b/src/stdlib_linalg_lapack_d.fypp index e06e7dd50..abca063d4 100644 --- a/src/stdlib_linalg_lapack_d.fypp +++ b/src/stdlib_linalg_lapack_d.fypp @@ -9,475 +9,477 @@ module stdlib_linalg_lapack_d private - public :: sp,dp,qp,lk,ilp - public :: stdlib_dbbcsd - public :: stdlib_dbdsdc - public :: stdlib_dbdsqr - public :: stdlib_ddisna - public :: stdlib_dgbbrd - public :: stdlib_dgbcon - public :: stdlib_dgbequ - public :: stdlib_dgbequb - public :: stdlib_dgbrfs - public :: stdlib_dgbsv - public :: stdlib_dgbsvx - public :: stdlib_dgbtf2 - public :: stdlib_dgbtrf - public :: stdlib_dgbtrs - public :: stdlib_dgebak - public :: stdlib_dgebal - public :: stdlib_dgebd2 - public :: stdlib_dgebrd - public :: stdlib_dgecon - public :: stdlib_dgeequ - public :: stdlib_dgeequb - public :: stdlib_dgees - public :: stdlib_dgeesx - public :: stdlib_dgeev - public :: stdlib_dgeevx - public :: stdlib_dgehd2 - public :: stdlib_dgehrd - public :: stdlib_dgejsv - public :: stdlib_dgelq - public :: stdlib_dgelq2 - public :: stdlib_dgelqf - public :: stdlib_dgelqt - public :: stdlib_dgelqt3 - public :: stdlib_dgels - public :: stdlib_dgelsd - public :: stdlib_dgelss - public :: stdlib_dgelsy - public :: stdlib_dgemlq - public :: stdlib_dgemlqt - public :: stdlib_dgemqr - public :: stdlib_dgemqrt - public :: stdlib_dgeql2 - public :: stdlib_dgeqlf - public :: stdlib_dgeqp3 - public :: stdlib_dgeqr - public :: stdlib_dgeqr2 - public :: stdlib_dgeqr2p - public :: stdlib_dgeqrf - public :: stdlib_dgeqrfp - public :: stdlib_dgeqrt - public :: stdlib_dgeqrt2 - public :: stdlib_dgeqrt3 - public :: stdlib_dgerfs - public :: stdlib_dgerq2 - public :: stdlib_dgerqf - public :: stdlib_dgesc2 - public :: stdlib_dgesdd - public :: stdlib_dgesv - public :: stdlib_dgesvd - public :: stdlib_dgesvdq - public :: stdlib_dgesvj - public :: stdlib_dgesvx - public :: stdlib_dgetc2 - public :: stdlib_dgetf2 - public :: stdlib_dgetrf - public :: stdlib_dgetrf2 - public :: stdlib_dgetri - public :: stdlib_dgetrs - public :: stdlib_dgetsls - public :: stdlib_dgetsqrhrt - public :: stdlib_dggbak - public :: stdlib_dggbal - public :: stdlib_dgges - public :: stdlib_dgges3 - public :: stdlib_dggesx - public :: stdlib_dggev - public :: stdlib_dggev3 - public :: stdlib_dggevx - public :: stdlib_dggglm - public :: stdlib_dgghd3 - public :: stdlib_dgghrd - public :: stdlib_dgglse - public :: stdlib_dggqrf - public :: stdlib_dggrqf - public :: stdlib_dgsvj0 - public :: stdlib_dgsvj1 - public :: stdlib_dgtcon - public :: stdlib_dgtrfs - public :: stdlib_dgtsv - public :: stdlib_dgtsvx - public :: stdlib_dgttrf - public :: stdlib_dgttrs - public :: stdlib_dgtts2 - public :: stdlib_dhgeqz - public :: stdlib_dhsein - public :: stdlib_dhseqr - public :: stdlib_disnan - public :: stdlib_dla_gbamv - public :: stdlib_dla_gbrcond - public :: stdlib_dla_gbrpvgrw - public :: stdlib_dla_geamv - public :: stdlib_dla_gercond - public :: stdlib_dla_gerpvgrw - public :: stdlib_dla_lin_berr - public :: stdlib_dla_porcond - public :: stdlib_dla_porpvgrw - public :: stdlib_dla_syamv - public :: stdlib_dla_syrcond - public :: stdlib_dla_syrpvgrw - public :: stdlib_dla_wwaddw - public :: stdlib_dlabad - public :: stdlib_dlabrd - public :: stdlib_dlacn2 - public :: stdlib_dlacon - public :: stdlib_dlacpy - public :: stdlib_dladiv - public :: stdlib_dladiv1 - public :: stdlib_dladiv2 - public :: stdlib_dlae2 - public :: stdlib_dlaebz - public :: stdlib_dlaed0 - public :: stdlib_dlaed1 - public :: stdlib_dlaed2 - public :: stdlib_dlaed3 - public :: stdlib_dlaed4 - public :: stdlib_dlaed5 - public :: stdlib_dlaed6 - public :: stdlib_dlaed7 - public :: stdlib_dlaed8 - public :: stdlib_dlaed9 - public :: stdlib_dlaeda - public :: stdlib_dlaein - public :: stdlib_dlaev2 - public :: stdlib_dlaexc - public :: stdlib_dlag2 - public :: stdlib_dlag2s - public :: stdlib_dlags2 - public :: stdlib_dlagtf - public :: stdlib_dlagtm - public :: stdlib_dlagts - public :: stdlib_dlagv2 - public :: stdlib_dlahqr - public :: stdlib_dlahr2 - public :: stdlib_dlaic1 - public :: stdlib_dlaisnan - public :: stdlib_dlaln2 - public :: stdlib_dlals0 - public :: stdlib_dlalsa - public :: stdlib_dlalsd - public :: stdlib_dlamch - public :: stdlib_dlamc3 - public :: stdlib_dlamrg - public :: stdlib_dlamswlq - public :: stdlib_dlamtsqr - public :: stdlib_dlaneg - public :: stdlib_dlangb - public :: stdlib_dlange - public :: stdlib_dlangt - public :: stdlib_dlanhs - public :: stdlib_dlansb - public :: stdlib_dlansf - public :: stdlib_dlansp - public :: stdlib_dlanst - public :: stdlib_dlansy - public :: stdlib_dlantb - public :: stdlib_dlantp - public :: stdlib_dlantr - public :: stdlib_dlanv2 - public :: stdlib_dlaorhr_col_getrfnp - public :: stdlib_dlaorhr_col_getrfnp2 - public :: stdlib_dlapll - public :: stdlib_dlapmr - public :: stdlib_dlapmt - public :: stdlib_dlapy2 - public :: stdlib_dlapy3 - public :: stdlib_dlaqgb - public :: stdlib_dlaqge - public :: stdlib_dlaqp2 - public :: stdlib_dlaqps - public :: stdlib_dlaqr0 - public :: stdlib_dlaqr1 - public :: stdlib_dlaqr2 - public :: stdlib_dlaqr3 - public :: stdlib_dlaqr4 - public :: stdlib_dlaqr5 - public :: stdlib_dlaqsb - public :: stdlib_dlaqsp - public :: stdlib_dlaqsy - public :: stdlib_dlaqtr - public :: stdlib_dlaqz0 - public :: stdlib_dlaqz1 - public :: stdlib_dlaqz2 - public :: stdlib_dlaqz3 - public :: stdlib_dlaqz4 - public :: stdlib_dlar1v - public :: stdlib_dlar2v - public :: stdlib_dlarf - public :: stdlib_dlarfb - public :: stdlib_dlarfb_gett - public :: stdlib_dlarfg - public :: stdlib_dlarfgp - public :: stdlib_dlarft - public :: stdlib_dlarfx - public :: stdlib_dlarfy - public :: stdlib_dlargv - public :: stdlib_dlarnv - public :: stdlib_dlarra - public :: stdlib_dlarrb - public :: stdlib_dlarrc - public :: stdlib_dlarrd - public :: stdlib_dlarre - public :: stdlib_dlarrf - public :: stdlib_dlarrj - public :: stdlib_dlarrk - public :: stdlib_dlarrr - public :: stdlib_dlarrv - public :: stdlib_dlartg - public :: stdlib_dlartgp - public :: stdlib_dlartgs - public :: stdlib_dlartv - public :: stdlib_dlaruv - public :: stdlib_dlarz - public :: stdlib_dlarzb - public :: stdlib_dlarzt - public :: stdlib_dlas2 - public :: stdlib_dlascl - public :: stdlib_dlasd0 - public :: stdlib_dlasd1 - public :: stdlib_dlasd2 - public :: stdlib_dlasd3 - public :: stdlib_dlasd4 - public :: stdlib_dlasd5 - public :: stdlib_dlasd6 - public :: stdlib_dlasd7 - public :: stdlib_dlasd8 - public :: stdlib_dlasda - public :: stdlib_dlasdq - public :: stdlib_dlasdt - public :: stdlib_dlaset - public :: stdlib_dlasq1 - public :: stdlib_dlasq2 - public :: stdlib_dlasq3 - public :: stdlib_dlasq4 - public :: stdlib_dlasq5 - public :: stdlib_dlasq6 - public :: stdlib_dlasr - public :: stdlib_dlasrt - public :: stdlib_dlassq - public :: stdlib_dlasv2 - public :: stdlib_dlaswlq - public :: stdlib_dlaswp - public :: stdlib_dlasy2 - public :: stdlib_dlasyf - public :: stdlib_dlasyf_aa - public :: stdlib_dlasyf_rk - public :: stdlib_dlasyf_rook - public :: stdlib_dlat2s - public :: stdlib_dlatbs - public :: stdlib_dlatdf - public :: stdlib_dlatps - public :: stdlib_dlatrd - public :: stdlib_dlatrs - public :: stdlib_dlatrz - public :: stdlib_dlatsqr - public :: stdlib_dlauu2 - public :: stdlib_dlauum - public :: stdlib_dopgtr - public :: stdlib_dopmtr - public :: stdlib_dorbdb - public :: stdlib_dorbdb1 - public :: stdlib_dorbdb2 - public :: stdlib_dorbdb3 - public :: stdlib_dorbdb4 - public :: stdlib_dorbdb5 - public :: stdlib_dorbdb6 - public :: stdlib_dorcsd - public :: stdlib_dorcsd2by1 - public :: stdlib_dorg2l - public :: stdlib_dorg2r - public :: stdlib_dorgbr - public :: stdlib_dorghr - public :: stdlib_dorgl2 - public :: stdlib_dorglq - public :: stdlib_dorgql - public :: stdlib_dorgqr - public :: stdlib_dorgr2 - public :: stdlib_dorgrq - public :: stdlib_dorgtr - public :: stdlib_dorgtsqr - public :: stdlib_dorgtsqr_row - public :: stdlib_dorhr_col - public :: stdlib_dorm22 - public :: stdlib_dorm2l - public :: stdlib_dorm2r - public :: stdlib_dormbr - public :: stdlib_dormhr - public :: stdlib_dorml2 - public :: stdlib_dormlq - public :: stdlib_dormql - public :: stdlib_dormqr - public :: stdlib_dormr2 - public :: stdlib_dormr3 - public :: stdlib_dormrq - public :: stdlib_dormrz - public :: stdlib_dormtr - public :: stdlib_dpbcon - public :: stdlib_dpbequ - public :: stdlib_dpbrfs - public :: stdlib_dpbstf - public :: stdlib_dpbsv - public :: stdlib_dpbsvx - public :: stdlib_dpbtf2 - public :: stdlib_dpbtrf - public :: stdlib_dpbtrs - public :: stdlib_dpftrf - public :: stdlib_dpftri - public :: stdlib_dpftrs - public :: stdlib_dpocon - public :: stdlib_dpoequ - public :: stdlib_dpoequb - public :: stdlib_dporfs - public :: stdlib_dposv - public :: stdlib_dposvx - public :: stdlib_dpotf2 - public :: stdlib_dpotrf - public :: stdlib_dpotrf2 - public :: stdlib_dpotri - public :: stdlib_dpotrs - public :: stdlib_dppcon - public :: stdlib_dppequ - public :: stdlib_dpprfs - public :: stdlib_dppsv - public :: stdlib_dppsvx - public :: stdlib_dpptrf - public :: stdlib_dpptri - public :: stdlib_dpptrs - public :: stdlib_dpstf2 - public :: stdlib_dpstrf - public :: stdlib_dptcon - public :: stdlib_dpteqr - public :: stdlib_dptrfs - public :: stdlib_dptsv - public :: stdlib_dptsvx - public :: stdlib_dpttrf - public :: stdlib_dpttrs - public :: stdlib_dptts2 - public :: stdlib_drscl - public :: stdlib_dsb2st_kernels - public :: stdlib_dsbev - public :: stdlib_dsbevd - public :: stdlib_dsbevx - public :: stdlib_dsbgst - public :: stdlib_dsbgv - public :: stdlib_dsbgvd - public :: stdlib_dsbgvx - public :: stdlib_dsbtrd - public :: stdlib_dsfrk - public :: stdlib_dsgesv - public :: stdlib_dspcon - public :: stdlib_dspev - public :: stdlib_dspevd - public :: stdlib_dspevx - public :: stdlib_dspgst - public :: stdlib_dspgv - public :: stdlib_dspgvd - public :: stdlib_dspgvx - public :: stdlib_dsposv - public :: stdlib_dsprfs - public :: stdlib_dspsv - public :: stdlib_dspsvx - public :: stdlib_dsptrd - public :: stdlib_dsptrf - public :: stdlib_dsptri - public :: stdlib_dsptrs - public :: stdlib_dstebz - public :: stdlib_dstedc - public :: stdlib_dstegr - public :: stdlib_dstein - public :: stdlib_dstemr - public :: stdlib_dsteqr - public :: stdlib_dsterf - public :: stdlib_dstev - public :: stdlib_dstevd - public :: stdlib_dstevr - public :: stdlib_dstevx - public :: stdlib_dsycon - public :: stdlib_dsycon_rook - public :: stdlib_dsyconv - public :: stdlib_dsyconvf - public :: stdlib_dsyconvf_rook - public :: stdlib_dsyequb - public :: stdlib_dsyev - public :: stdlib_dsyevd - public :: stdlib_dsyevr - public :: stdlib_dsyevx - public :: stdlib_dsygs2 - public :: stdlib_dsygst - public :: stdlib_dsygv - public :: stdlib_dsygvd - public :: stdlib_dsygvx - public :: stdlib_dsyrfs - public :: stdlib_dsysv - public :: stdlib_dsysv_aa - public :: stdlib_dsysv_rk - public :: stdlib_dsysv_rook - public :: stdlib_dsysvx - public :: stdlib_dsyswapr - public :: stdlib_dsytd2 - public :: stdlib_dsytf2 - public :: stdlib_dsytf2_rk - public :: stdlib_dsytf2_rook - public :: stdlib_dsytrd - public :: stdlib_dsytrd_sb2st - public :: stdlib_dsytrd_sy2sb - public :: stdlib_dsytrf - public :: stdlib_dsytrf_aa - public :: stdlib_dsytrf_rk - public :: stdlib_dsytrf_rook - public :: stdlib_dsytri - public :: stdlib_dsytri_rook - public :: stdlib_dsytrs - public :: stdlib_dsytrs2 - public :: stdlib_dsytrs_3 - public :: stdlib_dsytrs_aa - public :: stdlib_dsytrs_rook - public :: stdlib_dtbcon - public :: stdlib_dtbrfs - public :: stdlib_dtbtrs - public :: stdlib_dtfsm - public :: stdlib_dtftri - public :: stdlib_dtfttp - public :: stdlib_dtfttr - public :: stdlib_dtgevc - public :: stdlib_dtgex2 - public :: stdlib_dtgexc - public :: stdlib_dtgsen - public :: stdlib_dtgsja - public :: stdlib_dtgsna - public :: stdlib_dtgsy2 - public :: stdlib_dtgsyl - public :: stdlib_dtpcon - public :: stdlib_dtplqt - public :: stdlib_dtplqt2 - public :: stdlib_dtpmlqt - public :: stdlib_dtpmqrt - public :: stdlib_dtpqrt - public :: stdlib_dtpqrt2 - public :: stdlib_dtprfb - public :: stdlib_dtprfs - public :: stdlib_dtptri - public :: stdlib_dtptrs - public :: stdlib_dtpttf - public :: stdlib_dtpttr - public :: stdlib_dtrcon - public :: stdlib_dtrevc - public :: stdlib_dtrevc3 - public :: stdlib_dtrexc - public :: stdlib_dtrrfs - public :: stdlib_dtrsen - public :: stdlib_dtrsna - public :: stdlib_dtrsyl - public :: stdlib_dtrti2 - public :: stdlib_dtrtri - public :: stdlib_dtrtrs - public :: stdlib_dtrttf - public :: stdlib_dtrttp - public :: stdlib_dtzrzf - public :: stdlib_dzsum1 + public :: sp,dp,qp,lk,ilp,ilp64 + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + public :: stdlib${ii}$_dbbcsd + public :: stdlib${ii}$_dbdsdc + public :: stdlib${ii}$_dbdsqr + public :: stdlib${ii}$_ddisna + public :: stdlib${ii}$_dgbbrd + public :: stdlib${ii}$_dgbcon + public :: stdlib${ii}$_dgbequ + public :: stdlib${ii}$_dgbequb + public :: stdlib${ii}$_dgbrfs + public :: stdlib${ii}$_dgbsv + public :: stdlib${ii}$_dgbsvx + public :: stdlib${ii}$_dgbtf2 + public :: stdlib${ii}$_dgbtrf + public :: stdlib${ii}$_dgbtrs + public :: stdlib${ii}$_dgebak + public :: stdlib${ii}$_dgebal + public :: stdlib${ii}$_dgebd2 + public :: stdlib${ii}$_dgebrd + public :: stdlib${ii}$_dgecon + public :: stdlib${ii}$_dgeequ + public :: stdlib${ii}$_dgeequb + public :: stdlib${ii}$_dgees + public :: stdlib${ii}$_dgeesx + public :: stdlib${ii}$_dgeev + public :: stdlib${ii}$_dgeevx + public :: stdlib${ii}$_dgehd2 + public :: stdlib${ii}$_dgehrd + public :: stdlib${ii}$_dgejsv + public :: stdlib${ii}$_dgelq + public :: stdlib${ii}$_dgelq2 + public :: stdlib${ii}$_dgelqf + public :: stdlib${ii}$_dgelqt + public :: stdlib${ii}$_dgelqt3 + public :: stdlib${ii}$_dgels + public :: stdlib${ii}$_dgelsd + public :: stdlib${ii}$_dgelss + public :: stdlib${ii}$_dgelsy + public :: stdlib${ii}$_dgemlq + public :: stdlib${ii}$_dgemlqt + public :: stdlib${ii}$_dgemqr + public :: stdlib${ii}$_dgemqrt + public :: stdlib${ii}$_dgeql2 + public :: stdlib${ii}$_dgeqlf + public :: stdlib${ii}$_dgeqp3 + public :: stdlib${ii}$_dgeqr + public :: stdlib${ii}$_dgeqr2 + public :: stdlib${ii}$_dgeqr2p + public :: stdlib${ii}$_dgeqrf + public :: stdlib${ii}$_dgeqrfp + public :: stdlib${ii}$_dgeqrt + public :: stdlib${ii}$_dgeqrt2 + public :: stdlib${ii}$_dgeqrt3 + public :: stdlib${ii}$_dgerfs + public :: stdlib${ii}$_dgerq2 + public :: stdlib${ii}$_dgerqf + public :: stdlib${ii}$_dgesc2 + public :: stdlib${ii}$_dgesdd + public :: stdlib${ii}$_dgesv + public :: stdlib${ii}$_dgesvd + public :: stdlib${ii}$_dgesvdq + public :: stdlib${ii}$_dgesvj + public :: stdlib${ii}$_dgesvx + public :: stdlib${ii}$_dgetc2 + public :: stdlib${ii}$_dgetf2 + public :: stdlib${ii}$_dgetrf + public :: stdlib${ii}$_dgetrf2 + public :: stdlib${ii}$_dgetri + public :: stdlib${ii}$_dgetrs + public :: stdlib${ii}$_dgetsls + public :: stdlib${ii}$_dgetsqrhrt + public :: stdlib${ii}$_dggbak + public :: stdlib${ii}$_dggbal + public :: stdlib${ii}$_dgges + public :: stdlib${ii}$_dgges3 + public :: stdlib${ii}$_dggesx + public :: stdlib${ii}$_dggev + public :: stdlib${ii}$_dggev3 + public :: stdlib${ii}$_dggevx + public :: stdlib${ii}$_dggglm + public :: stdlib${ii}$_dgghd3 + public :: stdlib${ii}$_dgghrd + public :: stdlib${ii}$_dgglse + public :: stdlib${ii}$_dggqrf + public :: stdlib${ii}$_dggrqf + public :: stdlib${ii}$_dgsvj0 + public :: stdlib${ii}$_dgsvj1 + public :: stdlib${ii}$_dgtcon + public :: stdlib${ii}$_dgtrfs + public :: stdlib${ii}$_dgtsv + public :: stdlib${ii}$_dgtsvx + public :: stdlib${ii}$_dgttrf + public :: stdlib${ii}$_dgttrs + public :: stdlib${ii}$_dgtts2 + public :: stdlib${ii}$_dhgeqz + public :: stdlib${ii}$_dhsein + public :: stdlib${ii}$_dhseqr + public :: stdlib${ii}$_disnan + public :: stdlib${ii}$_dla_gbamv + public :: stdlib${ii}$_dla_gbrcond + public :: stdlib${ii}$_dla_gbrpvgrw + public :: stdlib${ii}$_dla_geamv + public :: stdlib${ii}$_dla_gercond + public :: stdlib${ii}$_dla_gerpvgrw + public :: stdlib${ii}$_dla_lin_berr + public :: stdlib${ii}$_dla_porcond + public :: stdlib${ii}$_dla_porpvgrw + public :: stdlib${ii}$_dla_syamv + public :: stdlib${ii}$_dla_syrcond + public :: stdlib${ii}$_dla_syrpvgrw + public :: stdlib${ii}$_dla_wwaddw + public :: stdlib${ii}$_dlabad + public :: stdlib${ii}$_dlabrd + public :: stdlib${ii}$_dlacn2 + public :: stdlib${ii}$_dlacon + public :: stdlib${ii}$_dlacpy + public :: stdlib${ii}$_dladiv + public :: stdlib${ii}$_dladiv1 + public :: stdlib${ii}$_dladiv2 + public :: stdlib${ii}$_dlae2 + public :: stdlib${ii}$_dlaebz + public :: stdlib${ii}$_dlaed0 + public :: stdlib${ii}$_dlaed1 + public :: stdlib${ii}$_dlaed2 + public :: stdlib${ii}$_dlaed3 + public :: stdlib${ii}$_dlaed4 + public :: stdlib${ii}$_dlaed5 + public :: stdlib${ii}$_dlaed6 + public :: stdlib${ii}$_dlaed7 + public :: stdlib${ii}$_dlaed8 + public :: stdlib${ii}$_dlaed9 + public :: stdlib${ii}$_dlaeda + public :: stdlib${ii}$_dlaein + public :: stdlib${ii}$_dlaev2 + public :: stdlib${ii}$_dlaexc + public :: stdlib${ii}$_dlag2 + public :: stdlib${ii}$_dlag2s + public :: stdlib${ii}$_dlags2 + public :: stdlib${ii}$_dlagtf + public :: stdlib${ii}$_dlagtm + public :: stdlib${ii}$_dlagts + public :: stdlib${ii}$_dlagv2 + public :: stdlib${ii}$_dlahqr + public :: stdlib${ii}$_dlahr2 + public :: stdlib${ii}$_dlaic1 + public :: stdlib${ii}$_dlaisnan + public :: stdlib${ii}$_dlaln2 + public :: stdlib${ii}$_dlals0 + public :: stdlib${ii}$_dlalsa + public :: stdlib${ii}$_dlalsd + public :: stdlib${ii}$_dlamch + public :: stdlib${ii}$_dlamc3 + public :: stdlib${ii}$_dlamrg + public :: stdlib${ii}$_dlamswlq + public :: stdlib${ii}$_dlamtsqr + public :: stdlib${ii}$_dlaneg + public :: stdlib${ii}$_dlangb + public :: stdlib${ii}$_dlange + public :: stdlib${ii}$_dlangt + public :: stdlib${ii}$_dlanhs + public :: stdlib${ii}$_dlansb + public :: stdlib${ii}$_dlansf + public :: stdlib${ii}$_dlansp + public :: stdlib${ii}$_dlanst + public :: stdlib${ii}$_dlansy + public :: stdlib${ii}$_dlantb + public :: stdlib${ii}$_dlantp + public :: stdlib${ii}$_dlantr + public :: stdlib${ii}$_dlanv2 + public :: stdlib${ii}$_dlaorhr_col_getrfnp + public :: stdlib${ii}$_dlaorhr_col_getrfnp2 + public :: stdlib${ii}$_dlapll + public :: stdlib${ii}$_dlapmr + public :: stdlib${ii}$_dlapmt + public :: stdlib${ii}$_dlapy2 + public :: stdlib${ii}$_dlapy3 + public :: stdlib${ii}$_dlaqgb + public :: stdlib${ii}$_dlaqge + public :: stdlib${ii}$_dlaqp2 + public :: stdlib${ii}$_dlaqps + public :: stdlib${ii}$_dlaqr0 + public :: stdlib${ii}$_dlaqr1 + public :: stdlib${ii}$_dlaqr2 + public :: stdlib${ii}$_dlaqr3 + public :: stdlib${ii}$_dlaqr4 + public :: stdlib${ii}$_dlaqr5 + public :: stdlib${ii}$_dlaqsb + public :: stdlib${ii}$_dlaqsp + public :: stdlib${ii}$_dlaqsy + public :: stdlib${ii}$_dlaqtr + public :: stdlib${ii}$_dlaqz0 + public :: stdlib${ii}$_dlaqz1 + public :: stdlib${ii}$_dlaqz2 + public :: stdlib${ii}$_dlaqz3 + public :: stdlib${ii}$_dlaqz4 + public :: stdlib${ii}$_dlar1v + public :: stdlib${ii}$_dlar2v + public :: stdlib${ii}$_dlarf + public :: stdlib${ii}$_dlarfb + public :: stdlib${ii}$_dlarfb_gett + public :: stdlib${ii}$_dlarfg + public :: stdlib${ii}$_dlarfgp + public :: stdlib${ii}$_dlarft + public :: stdlib${ii}$_dlarfx + public :: stdlib${ii}$_dlarfy + public :: stdlib${ii}$_dlargv + public :: stdlib${ii}$_dlarnv + public :: stdlib${ii}$_dlarra + public :: stdlib${ii}$_dlarrb + public :: stdlib${ii}$_dlarrc + public :: stdlib${ii}$_dlarrd + public :: stdlib${ii}$_dlarre + public :: stdlib${ii}$_dlarrf + public :: stdlib${ii}$_dlarrj + public :: stdlib${ii}$_dlarrk + public :: stdlib${ii}$_dlarrr + public :: stdlib${ii}$_dlarrv + public :: stdlib${ii}$_dlartg + public :: stdlib${ii}$_dlartgp + public :: stdlib${ii}$_dlartgs + public :: stdlib${ii}$_dlartv + public :: stdlib${ii}$_dlaruv + public :: stdlib${ii}$_dlarz + public :: stdlib${ii}$_dlarzb + public :: stdlib${ii}$_dlarzt + public :: stdlib${ii}$_dlas2 + public :: stdlib${ii}$_dlascl + public :: stdlib${ii}$_dlasd0 + public :: stdlib${ii}$_dlasd1 + public :: stdlib${ii}$_dlasd2 + public :: stdlib${ii}$_dlasd3 + public :: stdlib${ii}$_dlasd4 + public :: stdlib${ii}$_dlasd5 + public :: stdlib${ii}$_dlasd6 + public :: stdlib${ii}$_dlasd7 + public :: stdlib${ii}$_dlasd8 + public :: stdlib${ii}$_dlasda + public :: stdlib${ii}$_dlasdq + public :: stdlib${ii}$_dlasdt + public :: stdlib${ii}$_dlaset + public :: stdlib${ii}$_dlasq1 + public :: stdlib${ii}$_dlasq2 + public :: stdlib${ii}$_dlasq3 + public :: stdlib${ii}$_dlasq4 + public :: stdlib${ii}$_dlasq5 + public :: stdlib${ii}$_dlasq6 + public :: stdlib${ii}$_dlasr + public :: stdlib${ii}$_dlasrt + public :: stdlib${ii}$_dlassq + public :: stdlib${ii}$_dlasv2 + public :: stdlib${ii}$_dlaswlq + public :: stdlib${ii}$_dlaswp + public :: stdlib${ii}$_dlasy2 + public :: stdlib${ii}$_dlasyf + public :: stdlib${ii}$_dlasyf_aa + public :: stdlib${ii}$_dlasyf_rk + public :: stdlib${ii}$_dlasyf_rook + public :: stdlib${ii}$_dlat2s + public :: stdlib${ii}$_dlatbs + public :: stdlib${ii}$_dlatdf + public :: stdlib${ii}$_dlatps + public :: stdlib${ii}$_dlatrd + public :: stdlib${ii}$_dlatrs + public :: stdlib${ii}$_dlatrz + public :: stdlib${ii}$_dlatsqr + public :: stdlib${ii}$_dlauu2 + public :: stdlib${ii}$_dlauum + public :: stdlib${ii}$_dopgtr + public :: stdlib${ii}$_dopmtr + public :: stdlib${ii}$_dorbdb + public :: stdlib${ii}$_dorbdb1 + public :: stdlib${ii}$_dorbdb2 + public :: stdlib${ii}$_dorbdb3 + public :: stdlib${ii}$_dorbdb4 + public :: stdlib${ii}$_dorbdb5 + public :: stdlib${ii}$_dorbdb6 + public :: stdlib${ii}$_dorcsd + public :: stdlib${ii}$_dorcsd2by1 + public :: stdlib${ii}$_dorg2l + public :: stdlib${ii}$_dorg2r + public :: stdlib${ii}$_dorgbr + public :: stdlib${ii}$_dorghr + public :: stdlib${ii}$_dorgl2 + public :: stdlib${ii}$_dorglq + public :: stdlib${ii}$_dorgql + public :: stdlib${ii}$_dorgqr + public :: stdlib${ii}$_dorgr2 + public :: stdlib${ii}$_dorgrq + public :: stdlib${ii}$_dorgtr + public :: stdlib${ii}$_dorgtsqr + public :: stdlib${ii}$_dorgtsqr_row + public :: stdlib${ii}$_dorhr_col + public :: stdlib${ii}$_dorm22 + public :: stdlib${ii}$_dorm2l + public :: stdlib${ii}$_dorm2r + public :: stdlib${ii}$_dormbr + public :: stdlib${ii}$_dormhr + public :: stdlib${ii}$_dorml2 + public :: stdlib${ii}$_dormlq + public :: stdlib${ii}$_dormql + public :: stdlib${ii}$_dormqr + public :: stdlib${ii}$_dormr2 + public :: stdlib${ii}$_dormr3 + public :: stdlib${ii}$_dormrq + public :: stdlib${ii}$_dormrz + public :: stdlib${ii}$_dormtr + public :: stdlib${ii}$_dpbcon + public :: stdlib${ii}$_dpbequ + public :: stdlib${ii}$_dpbrfs + public :: stdlib${ii}$_dpbstf + public :: stdlib${ii}$_dpbsv + public :: stdlib${ii}$_dpbsvx + public :: stdlib${ii}$_dpbtf2 + public :: stdlib${ii}$_dpbtrf + public :: stdlib${ii}$_dpbtrs + public :: stdlib${ii}$_dpftrf + public :: stdlib${ii}$_dpftri + public :: stdlib${ii}$_dpftrs + public :: stdlib${ii}$_dpocon + public :: stdlib${ii}$_dpoequ + public :: stdlib${ii}$_dpoequb + public :: stdlib${ii}$_dporfs + public :: stdlib${ii}$_dposv + public :: stdlib${ii}$_dposvx + public :: stdlib${ii}$_dpotf2 + public :: stdlib${ii}$_dpotrf + public :: stdlib${ii}$_dpotrf2 + public :: stdlib${ii}$_dpotri + public :: stdlib${ii}$_dpotrs + public :: stdlib${ii}$_dppcon + public :: stdlib${ii}$_dppequ + public :: stdlib${ii}$_dpprfs + public :: stdlib${ii}$_dppsv + public :: stdlib${ii}$_dppsvx + public :: stdlib${ii}$_dpptrf + public :: stdlib${ii}$_dpptri + public :: stdlib${ii}$_dpptrs + public :: stdlib${ii}$_dpstf2 + public :: stdlib${ii}$_dpstrf + public :: stdlib${ii}$_dptcon + public :: stdlib${ii}$_dpteqr + public :: stdlib${ii}$_dptrfs + public :: stdlib${ii}$_dptsv + public :: stdlib${ii}$_dptsvx + public :: stdlib${ii}$_dpttrf + public :: stdlib${ii}$_dpttrs + public :: stdlib${ii}$_dptts2 + public :: stdlib${ii}$_drscl + public :: stdlib${ii}$_dsb2st_kernels + public :: stdlib${ii}$_dsbev + public :: stdlib${ii}$_dsbevd + public :: stdlib${ii}$_dsbevx + public :: stdlib${ii}$_dsbgst + public :: stdlib${ii}$_dsbgv + public :: stdlib${ii}$_dsbgvd + public :: stdlib${ii}$_dsbgvx + public :: stdlib${ii}$_dsbtrd + public :: stdlib${ii}$_dsfrk + public :: stdlib${ii}$_dsgesv + public :: stdlib${ii}$_dspcon + public :: stdlib${ii}$_dspev + public :: stdlib${ii}$_dspevd + public :: stdlib${ii}$_dspevx + public :: stdlib${ii}$_dspgst + public :: stdlib${ii}$_dspgv + public :: stdlib${ii}$_dspgvd + public :: stdlib${ii}$_dspgvx + public :: stdlib${ii}$_dsposv + public :: stdlib${ii}$_dsprfs + public :: stdlib${ii}$_dspsv + public :: stdlib${ii}$_dspsvx + public :: stdlib${ii}$_dsptrd + public :: stdlib${ii}$_dsptrf + public :: stdlib${ii}$_dsptri + public :: stdlib${ii}$_dsptrs + public :: stdlib${ii}$_dstebz + public :: stdlib${ii}$_dstedc + public :: stdlib${ii}$_dstegr + public :: stdlib${ii}$_dstein + public :: stdlib${ii}$_dstemr + public :: stdlib${ii}$_dsteqr + public :: stdlib${ii}$_dsterf + public :: stdlib${ii}$_dstev + public :: stdlib${ii}$_dstevd + public :: stdlib${ii}$_dstevr + public :: stdlib${ii}$_dstevx + public :: stdlib${ii}$_dsycon + public :: stdlib${ii}$_dsycon_rook + public :: stdlib${ii}$_dsyconv + public :: stdlib${ii}$_dsyconvf + public :: stdlib${ii}$_dsyconvf_rook + public :: stdlib${ii}$_dsyequb + public :: stdlib${ii}$_dsyev + public :: stdlib${ii}$_dsyevd + public :: stdlib${ii}$_dsyevr + public :: stdlib${ii}$_dsyevx + public :: stdlib${ii}$_dsygs2 + public :: stdlib${ii}$_dsygst + public :: stdlib${ii}$_dsygv + public :: stdlib${ii}$_dsygvd + public :: stdlib${ii}$_dsygvx + public :: stdlib${ii}$_dsyrfs + public :: stdlib${ii}$_dsysv + public :: stdlib${ii}$_dsysv_aa + public :: stdlib${ii}$_dsysv_rk + public :: stdlib${ii}$_dsysv_rook + public :: stdlib${ii}$_dsysvx + public :: stdlib${ii}$_dsyswapr + public :: stdlib${ii}$_dsytd2 + public :: stdlib${ii}$_dsytf2 + public :: stdlib${ii}$_dsytf2_rk + public :: stdlib${ii}$_dsytf2_rook + public :: stdlib${ii}$_dsytrd + public :: stdlib${ii}$_dsytrd_sb2st + public :: stdlib${ii}$_dsytrd_sy2sb + public :: stdlib${ii}$_dsytrf + public :: stdlib${ii}$_dsytrf_aa + public :: stdlib${ii}$_dsytrf_rk + public :: stdlib${ii}$_dsytrf_rook + public :: stdlib${ii}$_dsytri + public :: stdlib${ii}$_dsytri_rook + public :: stdlib${ii}$_dsytrs + public :: stdlib${ii}$_dsytrs2 + public :: stdlib${ii}$_dsytrs_3 + public :: stdlib${ii}$_dsytrs_aa + public :: stdlib${ii}$_dsytrs_rook + public :: stdlib${ii}$_dtbcon + public :: stdlib${ii}$_dtbrfs + public :: stdlib${ii}$_dtbtrs + public :: stdlib${ii}$_dtfsm + public :: stdlib${ii}$_dtftri + public :: stdlib${ii}$_dtfttp + public :: stdlib${ii}$_dtfttr + public :: stdlib${ii}$_dtgevc + public :: stdlib${ii}$_dtgex2 + public :: stdlib${ii}$_dtgexc + public :: stdlib${ii}$_dtgsen + public :: stdlib${ii}$_dtgsja + public :: stdlib${ii}$_dtgsna + public :: stdlib${ii}$_dtgsy2 + public :: stdlib${ii}$_dtgsyl + public :: stdlib${ii}$_dtpcon + public :: stdlib${ii}$_dtplqt + public :: stdlib${ii}$_dtplqt2 + public :: stdlib${ii}$_dtpmlqt + public :: stdlib${ii}$_dtpmqrt + public :: stdlib${ii}$_dtpqrt + public :: stdlib${ii}$_dtpqrt2 + public :: stdlib${ii}$_dtprfb + public :: stdlib${ii}$_dtprfs + public :: stdlib${ii}$_dtptri + public :: stdlib${ii}$_dtptrs + public :: stdlib${ii}$_dtpttf + public :: stdlib${ii}$_dtpttr + public :: stdlib${ii}$_dtrcon + public :: stdlib${ii}$_dtrevc + public :: stdlib${ii}$_dtrevc3 + public :: stdlib${ii}$_dtrexc + public :: stdlib${ii}$_dtrrfs + public :: stdlib${ii}$_dtrsen + public :: stdlib${ii}$_dtrsna + public :: stdlib${ii}$_dtrsyl + public :: stdlib${ii}$_dtrti2 + public :: stdlib${ii}$_dtrtri + public :: stdlib${ii}$_dtrtrs + public :: stdlib${ii}$_dtrttf + public :: stdlib${ii}$_dtrttp + public :: stdlib${ii}$_dtzrzf + public :: stdlib${ii}$_dzsum1 + #:endfor ! 64-bit real constants real(dp), parameter, private :: negone = -1.00_dp @@ -502,7 +504,7 @@ module stdlib_linalg_lapack_d real(dp), parameter, private :: rradix = real(radix(zero),dp) real(dp), parameter, private :: ulp = epsilon(zero) real(dp), parameter, private :: eps = ulp*half - real(dp), parameter, private :: safmin = rradix**max(minexp-1,1-maxexp) + real(dp), parameter, private :: safmin = rradix**max(minexp-1,1_${ik}$-maxexp) real(dp), parameter, private :: safmax = one/safmin real(dp), parameter, private :: smlnum = safmin/ulp real(dp), parameter, private :: bignum = safmax*ulp @@ -512,15 +514,15 @@ module stdlib_linalg_lapack_d ! 64-bit Blue's scaling constants ! ssml>=1/s and sbig==1/S with s,S as defined in https://doi.org/10.1145/355769.355771 real(dp), parameter, private :: tsml = rradix**ceiling((minexp-1)*half) - real(dp), parameter, private :: tbig = rradix**floor((maxexp-digits(zero)+1)*half) + real(dp), parameter, private :: tbig = rradix**floor((maxexp-digits(zero)+1_${ik}$)*half) real(dp), parameter, private :: ssml = rradix**(-floor((minexp-digits(zero))*half)) - real(dp), parameter, private :: sbig = rradix**(-ceiling((maxexp+digits(zero)-1)*half)) + real(dp), parameter, private :: sbig = rradix**(-ceiling((maxexp+digits(zero)-1_${ik}$)*half)) contains - - pure subroutine stdlib_dgbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + pure subroutine stdlib${ii}$_dgbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) !! DGBTF2 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. @@ -528,15 +530,15 @@ module stdlib_linalg_lapack_d ! -- 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(dp), 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 @@ -544,20 +546,20 @@ module stdlib_linalg_lapack_d ! 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}$_dswap( 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_dscal( km, one / ab( kv+1, j ), ab( kv+2, j ), 1 ) + call stdlib${ii}$_dscal( km, one / ab( kv+1, j ), ab( kv+2, j ), 1_${ik}$ ) ! update trailing submatrix within the band. - if( ju>j )call stdlib_dger( km, ju-j, -one, ab( kv+2, j ), 1,ab( kv, j+1 ), & + if( ju>j )call stdlib${ii}$_dger( 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_dgbtf2 + end subroutine stdlib${ii}$_dgbtf2 - pure subroutine stdlib_dgbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info ) + pure subroutine stdlib${ii}$_dgbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info ) !! DGBTRS solves a system of linear equations !! A * X = B or A**T * X = B !! with a general band matrix A using the LU factorization computed @@ -616,47 +618,47 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: ab(ldab,*) real(dp), 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. @@ -668,39 +670,39 @@ module stdlib_linalg_lapack_d do j = 1, n - 1 lm = min( kl, n-j ) l = ipiv( j ) - if( l/=j )call stdlib_dswap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) - call stdlib_dger( lm, nrhs, -one, ab( kd+1, j ), 1, b( j, 1 ),ldb, b( j+1, 1 )& + if( l/=j )call stdlib${ii}$_dswap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb ) + call stdlib${ii}$_dger( 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_dtbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kl+ku,ab, ldab, b( 1, & - i ), 1 ) + call stdlib${ii}$_dtbsv( '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_dtbsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, kl+ku, ab,ldab, b( 1, i )& - , 1 ) + call stdlib${ii}$_dtbsv( '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_dgemv( 'TRANSPOSE', lm, nrhs, -one, b( j+1, 1 ),ldb, ab( kd+1, j )& - , 1, one, b( j, 1 ), ldb ) + call stdlib${ii}$_dgemv( '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_dswap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) + if( l/=j )call stdlib${ii}$_dswap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb ) end do end if end if return - end subroutine stdlib_dgbtrs + end subroutine stdlib${ii}$_dgbtrs - pure subroutine stdlib_dgebak( job, side, n, ilo, ihi, scale, m, v, ldv,info ) + pure subroutine stdlib${ii}$_dgebak( job, side, n, ilo, ihi, scale, m, v, ldv,info ) !! DGEBAK forms the right or left eigenvectors of a real general matrix !! by backward transformation on the computed eigenvectors of the !! balanced matrix output by DGEBAL. @@ -709,8 +711,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: scale(*) real(dp), intent(inout) :: v(ldv,*) @@ -718,7 +720,7 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: leftv, rightv - integer(ilp) :: i, ii, k + integer(${ik}$) :: i, ii, k real(dp) :: s ! Intrinsic Functions intrinsic :: max,min @@ -726,25 +728,25 @@ module stdlib_linalg_lapack_d ! 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 @@ -968,18 +970,18 @@ module stdlib_linalg_lapack_d 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 @@ -990,9 +992,9 @@ module stdlib_linalg_lapack_d 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 @@ -1030,8 +1032,8 @@ module stdlib_linalg_lapack_d 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 ) @@ -1062,23 +1064,23 @@ module stdlib_linalg_lapack_d 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 ) @@ -1086,10 +1088,10 @@ module stdlib_linalg_lapack_d end do end if return - end subroutine stdlib_dgtsv + end subroutine stdlib${ii}$_dgtsv - pure subroutine stdlib_dgttrf( n, dl, d, du, du2, ipiv, info ) + pure subroutine stdlib${ii}$_dgttrf( n, dl, d, du, du2, ipiv, info ) !! DGTTRF computes an LU factorization of a real tridiagonal matrix A !! using elimination with partial pivoting and row interchanges. !! The factorization has the form @@ -1101,24 +1103,24 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: d(*), dl(*), du(*) real(dp), intent(out) :: du2(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i real(dp) :: fact, temp ! Intrinsic Functions intrinsic :: abs ! Executable Statements - info = 0 - if( n<0 ) then - info = -1 - call stdlib_xerbla( 'DGTTRF', -info ) + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -1_${ik}$ + call stdlib${ii}$_xerbla( 'DGTTRF', -info ) return end if ! quick return if possible @@ -1148,11 +1150,11 @@ module stdlib_linalg_lapack_d 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 ) @@ -1166,7 +1168,7 @@ module stdlib_linalg_lapack_d 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. @@ -1178,10 +1180,10 @@ module stdlib_linalg_lapack_d end do 50 continue return - end subroutine stdlib_dgttrf + end subroutine stdlib${ii}$_dgttrf - pure subroutine stdlib_dgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) + pure subroutine stdlib${ii}$_dgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) !! DGTTS2 solves one of the systems of equations !! A*X = B or A**T*X = B, !! with a tridiagonal matrix A using the LU factorization computed @@ -1190,23 +1192,23 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: b(ldb,*) real(dp), intent(in) :: d(*), dl(*), du(*), du2(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ip, j + integer(${ik}$) :: i, ip, j real(dp) :: 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 @@ -1217,13 +1219,13 @@ module stdlib_linalg_lapack_d 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 ) @@ -1249,12 +1251,12 @@ module stdlib_linalg_lapack_d 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 & ) @@ -1267,14 +1269,14 @@ module stdlib_linalg_lapack_d 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 ) @@ -1291,10 +1293,10 @@ module stdlib_linalg_lapack_d end do end if end if - end subroutine stdlib_dgtts2 + end subroutine stdlib${ii}$_dgtts2 - pure real(dp) function stdlib_dla_gbrpvgrw( n, kl, ku, ncols, ab,ldab, afb, ldafb ) + pure real(dp) function stdlib${ii}$_dla_gbrpvgrw( n, kl, ku, ncols, ab,ldab, afb, ldafb ) !! DLA_GBRPVGRW computes the reciprocal pivot growth factor !! norm(A)/norm(U). The "max absolute element" norm is used. If this is !! much less than 1, the stability of the LU factorization of the @@ -1305,18 +1307,18 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: ab(ldab,*), afb(ldafb,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, kd + integer(${ik}$) :: i, j, kd real(dp) :: 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 @@ -1330,11 +1332,11 @@ module stdlib_linalg_lapack_d rpvgrw = min( amax / umax, rpvgrw ) end if end do - stdlib_dla_gbrpvgrw = rpvgrw - end function stdlib_dla_gbrpvgrw + stdlib${ii}$_dla_gbrpvgrw = rpvgrw + end function stdlib${ii}$_dla_gbrpvgrw - pure real(dp) function stdlib_dla_gerpvgrw( n, ncols, a, lda, af,ldaf ) + pure real(dp) function stdlib${ii}$_dla_gerpvgrw( n, ncols, a, lda, af,ldaf ) !! DLA_GERPVGRW computes the reciprocal pivot growth factor !! norm(A)/norm(U). The "max absolute element" norm is used. If this is !! much less than 1, the stability of the LU factorization of the @@ -1345,12 +1347,12 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: a(lda,*), af(ldaf,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: amax, umax, rpvgrw ! Intrinsic Functions intrinsic :: abs,max,min @@ -1369,11 +1371,11 @@ module stdlib_linalg_lapack_d rpvgrw = min( amax / umax, rpvgrw ) end if end do - stdlib_dla_gerpvgrw = rpvgrw - end function stdlib_dla_gerpvgrw + stdlib${ii}$_dla_gerpvgrw = rpvgrw + end function stdlib${ii}$_dla_gerpvgrw - pure subroutine stdlib_dla_wwaddw( n, x, y, w ) + pure subroutine stdlib${ii}$_dla_wwaddw( n, x, y, w ) !! DLA_WWADDW adds a vector W into a doubled-single vector (X, Y). !! This works for all extant IBM's hex and binary floating point !! arithmetic, but not for decimal. @@ -1381,14 +1383,14 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: x(*), y(*) real(dp), intent(in) :: w(*) ! ===================================================================== ! Local Scalars real(dp) :: s - integer(ilp) :: i + integer(${ik}$) :: i ! Executable Statements do 10 i = 1, n s = x(i) + w(i) @@ -1397,10 +1399,10 @@ module stdlib_linalg_lapack_d x(i) = s 10 continue return - end subroutine stdlib_dla_wwaddw + end subroutine stdlib${ii}$_dla_wwaddw - pure subroutine stdlib_dlabad( small, large ) + pure subroutine stdlib${ii}$_dlabad( small, large ) !! DLABAD takes as input the values computed by DLAMCH for underflow and !! overflow, and returns the square root of each of these values if the !! log of LARGE is sufficiently large. This subroutine is intended to @@ -1425,92 +1427,92 @@ module stdlib_linalg_lapack_d large = sqrt( large ) end if return - end subroutine stdlib_dlabad + end subroutine stdlib${ii}$_dlabad - pure subroutine stdlib_dlacn2( n, v, x, isgn, est, kase, isave ) + pure subroutine stdlib${ii}$_dlacn2( n, v, x, isgn, est, kase, isave ) !! DLACN2 estimates the 1-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(dp), 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(dp), intent(out) :: v(*) real(dp), 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(dp) :: altsgn, estold, temp, xs ! Intrinsic Functions intrinsic :: abs,real,nint ! Executable Statements - if( kase==0 ) then + if( kase==0_${ik}$ ) then do i = 1, n x( i ) = one / real( n,KIND=dp) 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) ! 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_dasum( n, x, 1 ) + est = stdlib${ii}$_dasum( 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) ! first iteration. x has been overwritten by transpose(a)*x. 40 continue - isave( 2 ) = stdlib_idamax( n, x, 1 ) - isave( 3 ) = 2 + isave( 2_${ik}$ ) = stdlib${ii}$_idamax( n, x, 1_${ik}$ ) + isave( 3_${ik}$ ) = 2_${ik}$ ! main loop - iterations 2,3,...,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) ! x has been overwritten by a*x. 70 continue - call stdlib_dcopy( n, x, 1, v, 1 ) + call stdlib${ii}$_dcopy( n, x, 1_${ik}$, v, 1_${ik}$ ) estold = est - est = stdlib_dasum( n, v, 1 ) + est = stdlib${ii}$_dasum( 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 @@ -1523,18 +1525,18 @@ module stdlib_linalg_lapack_d 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) ! x has been overwritten by transpose(a)*x. 110 continue - jlast = isave( 2 ) - isave( 2 ) = stdlib_idamax( n, x, 1 ) - if( ( x( jlast )/=abs( x( isave( 2 ) ) ) ) .and.( isave( 3 )est ) then - call stdlib_dcopy( n, x, 1, v, 1 ) + call stdlib${ii}$_dcopy( n, x, 1_${ik}$, v, 1_${ik}$ ) est = temp end if 150 continue - kase = 0 + kase = 0_${ik}$ return - end subroutine stdlib_dlacn2 + end subroutine stdlib${ii}$_dlacn2 - subroutine stdlib_dlacon( n, v, x, isgn, est, kase ) + subroutine stdlib${ii}$_dlacon( n, v, x, isgn, est, kase ) !! DLACON estimates the 1-norm of a square, real matrix A. !! Reverse communication is used for evaluating matrix-vector products. ! -- lapack auxiliary routine -- ! -- 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(dp), intent(inout) :: est ! Array Arguments - integer(ilp), intent(out) :: isgn(*) + integer(${ik}$), intent(out) :: isgn(*) real(dp), intent(out) :: v(*) real(dp), 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(dp) :: altsgn, estold, temp ! Intrinsic Functions intrinsic :: abs,real,nint,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=dp) 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) ! 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_dasum( n, x, 1 ) + est = stdlib${ii}$_dasum( 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) ! first iteration. x has been overwritten by transpose(a)*x. 40 continue - j = stdlib_idamax( n, x, 1 ) - iter = 2 + j = stdlib${ii}$_idamax( n, x, 1_${ik}$ ) + iter = 2_${ik}$ ! main loop - iterations 2,3,...,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) ! x has been overwritten by a*x. 70 continue - call stdlib_dcopy( n, x, 1, v, 1 ) + call stdlib${ii}$_dcopy( n, x, 1_${ik}$, v, 1_${ik}$ ) estold = est - est = stdlib_dasum( n, v, 1 ) + est = stdlib${ii}$_dasum( 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 @@ -1644,18 +1646,18 @@ module stdlib_linalg_lapack_d 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) ! x has been overwritten by transpose(a)*x. 110 continue jlast = j - j = stdlib_idamax( n, x, 1 ) + j = stdlib${ii}$_idamax( n, x, 1_${ik}$ ) if( ( x( jlast )/=abs( x( j ) ) ) .and. ( iterest ) then - call stdlib_dcopy( n, x, 1, v, 1 ) + call stdlib${ii}$_dcopy( n, x, 1_${ik}$, v, 1_${ik}$ ) est = temp end if 150 continue - kase = 0 + kase = 0_${ik}$ return - end subroutine stdlib_dlacon + end subroutine stdlib${ii}$_dlacon - pure subroutine stdlib_dlacpy( uplo, m, n, a, lda, b, ldb ) + pure subroutine stdlib${ii}$_dlacpy( uplo, m, n, a, lda, b, ldb ) !! DLACPY copies all or part of a two-dimensional matrix A to another !! matrix B. ! -- lapack auxiliary routine -- @@ -1690,13 +1692,13 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: a(lda,*) real(dp), intent(out) :: b(ldb,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -1720,10 +1722,10 @@ module stdlib_linalg_lapack_d end do end if return - end subroutine stdlib_dlacpy + end subroutine stdlib${ii}$_dlacpy - pure real(dp) function stdlib_dladiv2( a, b, c, d, r, t ) + pure real(dp) function stdlib${ii}$_dladiv2( 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..-- @@ -1737,18 +1739,18 @@ module stdlib_linalg_lapack_d if( r/=zero ) then br = b * r if( br/=zero ) then - stdlib_dladiv2 = (a + br) * t + stdlib${ii}$_dladiv2 = (a + br) * t else - stdlib_dladiv2 = a * t + (b * t) * r + stdlib${ii}$_dladiv2 = a * t + (b * t) * r end if else - stdlib_dladiv2 = (a + d * (b / c)) * t + stdlib${ii}$_dladiv2 = (a + d * (b / c)) * t end if return - end function stdlib_dladiv2 + end function stdlib${ii}$_dladiv2 - pure subroutine stdlib_dlae2( a, b, c, rt1, rt2 ) + pure subroutine stdlib${ii}$_dlae2( a, b, c, rt1, rt2 ) !! DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix !! [ A B ] !! [ B C ]. @@ -1784,9 +1786,9 @@ module stdlib_linalg_lapack_d 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 + if( ijob<=2_${ik}$ ) then ! ijob=2: 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 @@ -1965,12 +1967,12 @@ module stdlib_linalg_lapack_d ! 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 @@ -1981,56 +1983,56 @@ module stdlib_linalg_lapack_d 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 + if( ijob<=2_${ik}$ ) then ! ijob=2: 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 @@ -2039,51 +2041,51 @@ module stdlib_linalg_lapack_d ! 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_dlaebz + end subroutine stdlib${ii}$_dlaebz - pure subroutine stdlib_dlaed5( i, d, z, delta, rho, dlam ) + pure subroutine stdlib${ii}$_dlaed5( 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 !! diag( D ) + RHO * Z * transpose(Z) . @@ -2095,12 +2097,12 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(out) :: dlam real(dp), intent(in) :: rho ! Array Arguments - real(dp), intent(in) :: d(2), z(2) - real(dp), intent(out) :: delta(2) + real(dp), intent(in) :: d(2_${ik}$), z(2_${ik}$) + real(dp), intent(out) :: delta(2_${ik}$) ! ===================================================================== ! Local Scalars @@ -2108,53 +2110,53 @@ module stdlib_linalg_lapack_d ! 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 + 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_dlaed5 + end subroutine stdlib${ii}$_dlaed5 - pure subroutine stdlib_dlaeda( n, tlvls, curlvl, curpbm, prmptr, perm, givptr,givcol, givnum,& + pure subroutine stdlib${ii}$_dlaeda( n, tlvls, curlvl, curpbm, prmptr, perm, givptr,givcol, givnum,& !! DLAEDA computes the Z vector corresponding to the merge step in the !! CURLVLth step of the merge process with TLVLS steps for the CURPBMth !! problem. @@ -2163,103 +2165,103 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: givnum(2,*), q(*) + integer(${ik}$), intent(in) :: givcol(2_${ik}$,*), givptr(*), perm(*), prmptr(*), qptr(*) + real(dp), intent(in) :: givnum(2_${ik}$,*), q(*) real(dp), 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 :: real,int,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( 'DLAEDA', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DLAEDA', -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=dp) ),KIND=ilp) - bsiz2 = int( half+sqrt( real( qptr( curr+2 )-qptr( curr+1 ),KIND=dp) ),KIND=ilp) + bsiz1 = int( half+sqrt( real( qptr( curr+1 )-qptr( curr ),KIND=dp) ),KIND=${ik}$) + bsiz2 = int( half+sqrt( real( qptr( curr+2 )-qptr( curr+1 ),KIND=dp) ),KIND=${ik}$) do k = 1, mid - bsiz1 - 1 z( k ) = zero end do - call stdlib_dcopy( bsiz1, q( qptr( curr )+bsiz1-1 ), bsiz1,z( mid-bsiz1 ), 1 ) - call stdlib_dcopy( bsiz2, q( qptr( curr+1 ) ), bsiz2, z( mid ), 1 ) + call stdlib${ii}$_dcopy( bsiz1, q( qptr( curr )+bsiz1-1 ), bsiz1,z( mid-bsiz1 ), 1_${ik}$ ) + call stdlib${ii}$_dcopy( 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 ! 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_drot( 1, z( zptr1+givcol( 1, i )-1 ), 1,z( zptr1+givcol( 2, i )-1 ), & - 1, givnum( 1, i ),givnum( 2, i ) ) + call stdlib${ii}$_drot( 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_drot( 1, z( mid-1+givcol( 1, i ) ), 1,z( mid-1+givcol( 2, i ) ), 1, & - givnum( 1, i ),givnum( 2, i ) ) + call stdlib${ii}$_drot( 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=dp) ),KIND=ilp) + bsiz1 = int( half+sqrt( real( qptr( curr+1 )-qptr( curr ),KIND=dp) ),KIND=${ik}$) - bsiz2 = int( half+sqrt( real( qptr( curr+2 )-qptr( curr+1 ),KIND=dp) ),KIND=ilp) + bsiz2 = int( half+sqrt( real( qptr( curr+2 )-qptr( curr+1 ),KIND=dp) ),KIND=${ik}$) - if( bsiz1>0 ) then - call stdlib_dgemv( 'T', bsiz1, bsiz1, one, q( qptr( curr ) ),bsiz1, ztemp( 1 ), & - 1, zero, z( zptr1 ), 1 ) + if( bsiz1>0_${ik}$ ) then + call stdlib${ii}$_dgemv( 'T', bsiz1, bsiz1, one, q( qptr( curr ) ),bsiz1, ztemp( 1_${ik}$ ), & + 1_${ik}$, zero, z( zptr1 ), 1_${ik}$ ) end if - call stdlib_dcopy( psiz1-bsiz1, ztemp( bsiz1+1 ), 1, z( zptr1+bsiz1 ),1 ) - if( bsiz2>0 ) then - call stdlib_dgemv( 'T', bsiz2, bsiz2, one, q( qptr( curr+1 ) ),bsiz2, ztemp( & - psiz1+1 ), 1, zero, z( mid ), 1 ) + call stdlib${ii}$_dcopy( psiz1-bsiz1, ztemp( bsiz1+1 ), 1_${ik}$, z( zptr1+bsiz1 ),1_${ik}$ ) + if( bsiz2>0_${ik}$ ) then + call stdlib${ii}$_dgemv( 'T', bsiz2, bsiz2, one, q( qptr( curr+1 ) ),bsiz2, ztemp( & + psiz1+1 ), 1_${ik}$, zero, z( mid ), 1_${ik}$ ) end if - call stdlib_dcopy( psiz2-bsiz2, ztemp( psiz1+bsiz2+1 ), 1,z( mid+bsiz2 ), 1 ) + call stdlib${ii}$_dcopy( 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_dlaeda + end subroutine stdlib${ii}$_dlaeda - pure subroutine stdlib_dlaev2( a, b, c, rt1, rt2, cs1, sn1 ) + pure subroutine stdlib${ii}$_dlaev2( a, b, c, rt1, rt2, cs1, sn1 ) !! DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix !! [ A B ] !! [ B C ]. @@ -2280,7 +2282,7 @@ module stdlib_linalg_lapack_d ! Local Scalars - integer(ilp) :: sgn1, sgn2 + integer(${ik}$) :: sgn1, sgn2 real(dp) :: ab, acmn, acmx, acs, adf, cs, ct, df, rt, sm, tb, tn ! Intrinsic Functions intrinsic :: abs,sqrt @@ -2299,23 +2301,23 @@ module stdlib_linalg_lapack_d 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. @@ -2324,15 +2326,15 @@ module stdlib_linalg_lapack_d ! includes case rt1 = rt2 = 0 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 @@ -2355,10 +2357,10 @@ module stdlib_linalg_lapack_d sn1 = tn end if return - end subroutine stdlib_dlaev2 + end subroutine stdlib${ii}$_dlaev2 - pure subroutine stdlib_dlag2( a, lda, b, ldb, safmin, scale1, scale2, wr1,wr2, wi ) + pure subroutine stdlib${ii}$_dlag2( a, lda, b, ldb, safmin, scale1, scale2, wr1,wr2, wi ) !! DLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue !! problem A - w B, with scaling as necessary to avoid over-/underflow. !! The scaling factor "s" results in a modified eigenvalue equation @@ -2369,7 +2371,7 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: safmin real(dp), intent(out) :: scale1, scale2, wi, wr1, wr2 ! Array Arguments @@ -2392,17 +2394,17 @@ module stdlib_linalg_lapack_d 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 @@ -2539,10 +2541,10 @@ module stdlib_linalg_lapack_d end if end if return - end subroutine stdlib_dlag2 + end subroutine stdlib${ii}$_dlag2 - pure subroutine stdlib_dlag2s( m, n, a, lda, sa, ldsa, info ) + pure subroutine stdlib${ii}$_dlag2s( m, n, a, lda, sa, ldsa, info ) !! DLAG2S converts a DOUBLE PRECISION matrix, SA, to a SINGLE !! PRECISION matrix, A. !! RMAX is the overflow for the SINGLE PRECISION arithmetic @@ -2553,33 +2555,33 @@ module stdlib_linalg_lapack_d ! -- 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(out) :: sa(ldsa,*) real(dp), intent(in) :: a(lda,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: rmax ! Executable Statements - rmax = stdlib_slamch( 'O' ) + rmax = stdlib${ii}$_slamch( 'O' ) do j = 1, n do i = 1, m if( ( a( i, j )<-rmax ) .or. ( a( i, j )>rmax ) ) then - info = 1 + info = 1_${ik}$ go to 30 end if sa( i, j ) = a( i, j ) end do end do - info = 0 + info = 0_${ik}$ 30 continue return - end subroutine stdlib_dlag2s + end subroutine stdlib${ii}$_dlag2s - pure subroutine stdlib_dlagtm( trans, n, nrhs, alpha, dl, d, du, x, ldx, beta,b, ldb ) + pure subroutine stdlib${ii}$_dlagtm( trans, n, nrhs, alpha, dl, d, du, x, ldx, beta,b, ldb ) !! DLAGTM performs a matrix-vector product of the form !! B := alpha * A * X + beta * B !! where A is a tridiagonal matrix of order N, B and X are N by NRHS @@ -2591,7 +2593,7 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: alpha, beta ! Array Arguments real(dp), intent(inout) :: b(ldb,*) @@ -2599,7 +2601,7 @@ module stdlib_linalg_lapack_d ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Executable Statements if( n==0 )return ! multiply b by beta if beta/=1. @@ -2620,10 +2622,10 @@ module stdlib_linalg_lapack_d 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 & @@ -2634,10 +2636,10 @@ module stdlib_linalg_lapack_d 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 & @@ -2650,10 +2652,10 @@ module stdlib_linalg_lapack_d 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_d 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 & @@ -2678,10 +2680,10 @@ module stdlib_linalg_lapack_d end if end if return - end subroutine stdlib_dlagtm + end subroutine stdlib${ii}$_dlagtm - pure logical(lk) function stdlib_dlaisnan( din1, din2 ) + pure logical(lk) function stdlib${ii}$_dlaisnan( din1, din2 ) !! This routine is not for general use. It exists solely to avoid !! over-optimization in DISNAN. !! DLAISNAN checks for NaNs by comparing its two arguments for @@ -2700,12 +2702,12 @@ module stdlib_linalg_lapack_d real(dp), intent(in) :: din1, din2 ! ===================================================================== ! Executable Statements - stdlib_dlaisnan = (din1/=din2) + stdlib${ii}$_dlaisnan = (din1/=din2) return - end function stdlib_dlaisnan + end function stdlib${ii}$_dlaisnan - pure real(dp) function stdlib_dlamch( cmach ) + pure real(dp) function stdlib${ii}$_dlamch( cmach ) !! DLAMCH determines double precision machine parameters. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- @@ -2756,24 +2758,24 @@ module stdlib_linalg_lapack_d else rmach = zero end if - stdlib_dlamch = rmach + stdlib${ii}$_dlamch = rmach return - end function stdlib_dlamch + end function stdlib${ii}$_dlamch - pure real(dp) function stdlib_dlamc3( a, b ) + pure real(dp) function stdlib${ii}$_dlamc3( a, b ) ! -- lapack auxiliary routine -- ! univ. of tennessee, univ. of california berkeley and nag ltd.. ! Scalar Arguments real(dp), intent(in) :: a, b ! ===================================================================== ! Executable Statements - stdlib_dlamc3 = a + b + stdlib${ii}$_dlamc3 = a + b return - end function stdlib_dlamc3 + end function stdlib${ii}$_dlamc3 - pure subroutine stdlib_dlamrg( n1, n2, a, dtrd1, dtrd2, index ) + pure subroutine stdlib${ii}$_dlamrg( n1, n2, a, dtrd1, dtrd2, index ) !! DLAMRG will create a permutation list which will merge the elements !! of A (which is composed of two independently sorted sets) into a !! single set which is sorted in ascending order. @@ -2781,63 +2783,63 @@ module stdlib_linalg_lapack_d ! -- 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) :: dtrd1, dtrd2, n1, n2 + integer(${ik}$), intent(in) :: dtrd1, dtrd2, n1, n2 ! Array Arguments - integer(ilp), intent(out) :: index(*) + integer(${ik}$), intent(out) :: index(*) real(dp), 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( dtrd1>0 ) then - ind1 = 1 + if( dtrd1>0_${ik}$ ) then + ind1 = 1_${ik}$ else ind1 = n1 end if - if( dtrd2>0 ) then - ind2 = 1 + n1 + if( dtrd2>0_${ik}$ ) then + ind2 = 1_${ik}$ + n1 else ind2 = n1 + n2 end if - i = 1 + i = 1_${ik}$ ! while ( (n1sv > 0) 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 + dtrd1 - n1sv = n1sv - 1 + n1sv = n1sv - 1_${ik}$ else index( i ) = ind2 - i = i + 1 + i = i + 1_${ik}$ ind2 = ind2 + dtrd2 - 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 + dtrd2 end do else ! n2sv == 0 do n2sv = 1, n1sv index( i ) = ind1 - i = i + 1 + i = i + 1_${ik}$ ind1 = ind1 + dtrd1 end do end if return - end subroutine stdlib_dlamrg + end subroutine stdlib${ii}$_dlamrg - pure recursive subroutine stdlib_dlaorhr_col_getrfnp2( m, n, a, lda, d, info ) + pure recursive subroutine stdlib${ii}$_dlaorhr_col_getrfnp2( m, n, a, lda, d, info ) !! DLAORHR_COL_GETRFNP2 computes the modified LU factorization without !! pivoting of a real general M-by-N matrix A. The factorization has !! the form: @@ -2890,8 +2892,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: d(*) @@ -2899,75 +2901,75 @@ module stdlib_linalg_lapack_d ! Local Scalars real(dp) :: 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_dscal( m-1, one / a( 1, 1 ), a( 2, 1 ), 1 ) + if( abs( a( 1_${ik}$, 1_${ik}$ ) ) >= sfmin ) then + call stdlib${ii}$_dscal( 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_dlaorhr_col_getrfnp2( n1, n1, a, lda, d, iinfo ) + call stdlib${ii}$_dlaorhr_col_getrfnp2( n1, n1, a, lda, d, iinfo ) ! solve for b21 - call stdlib_dtrsm( 'R', 'U', 'N', 'N', m-n1, n1, one, a, lda,a( n1+1, 1 ), lda ) + call stdlib${ii}$_dtrsm( 'R', 'U', 'N', 'N', m-n1, n1, one, a, lda,a( n1+1, 1_${ik}$ ), lda ) ! solve for b12 - call stdlib_dtrsm( 'L', 'L', 'N', 'U', n1, n2, one, a, lda,a( 1, n1+1 ), lda ) + call stdlib${ii}$_dtrsm( '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_dgemm( 'N', 'N', m-n1, n2, n1, -one, a( n1+1, 1 ), lda,a( 1, n1+1 ), & + call stdlib${ii}$_dgemm( '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_dlaorhr_col_getrfnp2( m-n1, n2, a( n1+1, n1+1 ), lda,d( n1+1 ), iinfo ) + call stdlib${ii}$_dlaorhr_col_getrfnp2( m-n1, n2, a( n1+1, n1+1 ), lda,d( n1+1 ), iinfo ) end if return - end subroutine stdlib_dlaorhr_col_getrfnp2 + end subroutine stdlib${ii}$_dlaorhr_col_getrfnp2 - pure subroutine stdlib_dlapmr( forwrd, m, n, x, ldx, k ) + pure subroutine stdlib${ii}$_dlapmr( forwrd, m, n, x, ldx, k ) !! DLAPMR rearranges the rows of the M by N matrix X as specified !! by the permutation K(1),K(2),...,K(M) of the integers 1,...,M. !! If FORWRD = .TRUE., forward permutation: @@ -2979,13 +2981,13 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: x(ldx,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, in, j, jj + integer(${ik}$) :: i, in, j, jj real(dp) :: temp ! Executable Statements if( m<=1 )return @@ -3032,10 +3034,10 @@ module stdlib_linalg_lapack_d end do end if return - end subroutine stdlib_dlapmr + end subroutine stdlib${ii}$_dlapmr - pure subroutine stdlib_dlapmt( forwrd, m, n, x, ldx, k ) + pure subroutine stdlib${ii}$_dlapmt( forwrd, m, n, x, ldx, k ) !! DLAPMT rearranges the columns of the M by N matrix X as specified !! by the permutation K(1),K(2),...,K(N) of the integers 1,...,N. !! If FORWRD = .TRUE., forward permutation: @@ -3047,13 +3049,13 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: x(ldx,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ii, in, j + integer(${ik}$) :: i, ii, in, j real(dp) :: temp ! Executable Statements if( n<=1 )return @@ -3100,10 +3102,10 @@ module stdlib_linalg_lapack_d end do end if return - end subroutine stdlib_dlapmt + end subroutine stdlib${ii}$_dlapmt - pure real(dp) function stdlib_dlapy3( x, y, z ) + pure real(dp) function stdlib${ii}$_dlapy3( x, y, z ) !! DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause !! unnecessary overflow and unnecessary underflow. ! -- lapack auxiliary routine -- @@ -3118,7 +3120,7 @@ module stdlib_linalg_lapack_d ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements - hugeval = stdlib_dlamch( 'OVERFLOW' ) + hugeval = stdlib${ii}$_dlamch( 'OVERFLOW' ) xabs = abs( x ) yabs = abs( y ) zabs = abs( z ) @@ -3127,15 +3129,15 @@ module stdlib_linalg_lapack_d ! w can be zero for max(0,nan,0) ! adding all three entries together will make sure ! nan will not disappear. - stdlib_dlapy3 = xabs + yabs + zabs + stdlib${ii}$_dlapy3 = xabs + yabs + zabs else - stdlib_dlapy3 = w*sqrt( ( xabs / w )**2+( yabs / w )**2+( zabs / w )**2 ) + stdlib${ii}$_dlapy3 = w*sqrt( ( xabs / w )**2_${ik}$+( yabs / w )**2_${ik}$+( zabs / w )**2_${ik}$ ) end if return - end function stdlib_dlapy3 + end function stdlib${ii}$_dlapy3 - pure subroutine stdlib_dlaqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) + pure subroutine stdlib${ii}$_dlaqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) !! DLAQGB equilibrates a general M by N band matrix A with KL !! subdiagonals and KU superdiagonals using the row and scaling factors !! in the vectors R and C. @@ -3145,7 +3147,7 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: amax, colcnd, rowcnd ! Array Arguments real(dp), intent(inout) :: ab(ldab,*) @@ -3155,18 +3157,18 @@ module stdlib_linalg_lapack_d real(dp), parameter :: thresh = 0.1e+0_dp ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: 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_dlamch( 'SAFE MINIMUM' ) / stdlib_dlamch( 'PRECISION' ) + small = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' ) large = one / small if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then ! no row scaling @@ -3202,10 +3204,10 @@ module stdlib_linalg_lapack_d equed = 'B' end if return - end subroutine stdlib_dlaqgb + end subroutine stdlib${ii}$_dlaqgb - pure subroutine stdlib_dlaqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed ) + pure subroutine stdlib${ii}$_dlaqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed ) !! DLAQGE equilibrates a general M by N matrix A using the row and !! column scaling factors in the vectors R and C. ! -- lapack auxiliary routine -- @@ -3213,7 +3215,7 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: amax, colcnd, rowcnd ! Array Arguments real(dp), intent(inout) :: a(lda,*) @@ -3223,16 +3225,16 @@ module stdlib_linalg_lapack_d real(dp), parameter :: thresh = 0.1e+0_dp ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: 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_dlamch( 'SAFE MINIMUM' ) / stdlib_dlamch( 'PRECISION' ) + small = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' ) large = one / small if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then ! no row scaling @@ -3268,10 +3270,10 @@ module stdlib_linalg_lapack_d equed = 'B' end if return - end subroutine stdlib_dlaqge + end subroutine stdlib${ii}$_dlaqge - pure subroutine stdlib_dlaqr1( n, h, ldh, sr1, si1, sr2, si2, v ) + pure subroutine stdlib${ii}$_dlaqr1( n, h, ldh, sr1, si1, sr2, si2, v ) !! Given a 2-by-2 or 3-by-3 matrix H, DLAQR1: sets v to a !! scalar multiple of the first column of the product !! (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I) @@ -3287,7 +3289,7 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(dp), intent(in) :: si1, si2, sr1, sr2 - integer(ilp), intent(in) :: ldh, n + integer(${ik}$), intent(in) :: ldh, n ! Array Arguments real(dp), intent(in) :: h(ldh,*) real(dp), intent(out) :: v(*) @@ -3299,39 +3301,39 @@ module stdlib_linalg_lapack_d 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_dlaqr1 + end subroutine stdlib${ii}$_dlaqr1 - pure subroutine stdlib_dlaqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_dlaqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) !! DLAQSB equilibrates a symmetric band matrix A using the scaling !! factors in the vector S. ! -- lapack auxiliary routine -- @@ -3340,7 +3342,7 @@ module stdlib_linalg_lapack_d ! 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(dp), intent(in) :: amax, scond ! Array Arguments real(dp), intent(inout) :: ab(ldab,*) @@ -3350,18 +3352,18 @@ module stdlib_linalg_lapack_d real(dp), parameter :: thresh = 0.1e+0_dp ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: 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_dlamch( 'SAFE MINIMUM' ) / stdlib_dlamch( 'PRECISION' ) + small = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -3381,17 +3383,17 @@ module stdlib_linalg_lapack_d 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_dlaqsb + end subroutine stdlib${ii}$_dlaqsb - pure subroutine stdlib_dlaqsp( uplo, n, ap, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_dlaqsp( uplo, n, ap, s, scond, amax, equed ) !! DLAQSP equilibrates a symmetric matrix A using the scaling factors !! in the vector S. ! -- lapack auxiliary routine -- @@ -3400,7 +3402,7 @@ module stdlib_linalg_lapack_d ! Scalar Arguments character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(dp), intent(in) :: amax, scond ! Array Arguments real(dp), intent(inout) :: ap(*) @@ -3410,16 +3412,16 @@ module stdlib_linalg_lapack_d real(dp), parameter :: thresh = 0.1e+0_dp ! Local Scalars - integer(ilp) :: i, j, jc + integer(${ik}$) :: i, j, jc real(dp) :: 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_dlamch( 'SAFE MINIMUM' ) / stdlib_dlamch( 'PRECISION' ) + small = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -3428,7 +3430,7 @@ module stdlib_linalg_lapack_d ! 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 @@ -3438,22 +3440,22 @@ module stdlib_linalg_lapack_d 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_dlaqsp + end subroutine stdlib${ii}$_dlaqsp - pure subroutine stdlib_dlaqsy( uplo, n, a, lda, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_dlaqsy( uplo, n, a, lda, s, scond, amax, equed ) !! DLAQSY equilibrates a symmetric matrix A using the scaling factors !! in the vector S. ! -- lapack auxiliary routine -- @@ -3462,7 +3464,7 @@ module stdlib_linalg_lapack_d ! Scalar Arguments character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: lda, n + integer(${ik}$), intent(in) :: lda, n real(dp), intent(in) :: amax, scond ! Array Arguments real(dp), intent(inout) :: a(lda,*) @@ -3472,16 +3474,16 @@ module stdlib_linalg_lapack_d real(dp), parameter :: thresh = 0.1e+0_dp ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: 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_dlamch( 'SAFE MINIMUM' ) / stdlib_dlamch( 'PRECISION' ) + small = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -3508,10 +3510,10 @@ module stdlib_linalg_lapack_d equed = 'Y' end if return - end subroutine stdlib_dlaqsy + end subroutine stdlib${ii}$_dlaqsy - pure subroutine stdlib_dlar2v( n, x, y, z, incx, c, s, incc ) + pure subroutine stdlib${ii}$_dlar2v( n, x, y, z, incx, c, s, incc ) !! DLAR2V applies a vector of real plane rotations from both sides to !! a sequence of 2-by-2 real symmetric matrices, defined by the elements !! of the vectors x, y and z. For i = 1,2,...,n @@ -3521,17 +3523,17 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: c(*), s(*) real(dp), intent(inout) :: x(*), y(*), z(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ic, ix + integer(${ik}$) :: i, ic, ix real(dp) :: 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 ) @@ -3551,10 +3553,10 @@ module stdlib_linalg_lapack_d ic = ic + incc end do return - end subroutine stdlib_dlar2v + end subroutine stdlib${ii}$_dlar2v - pure subroutine stdlib_dlarf( side, m, n, v, incv, tau, c, ldc, work ) + pure subroutine stdlib${ii}$_dlarf( side, m, n, v, incv, tau, c, ldc, work ) !! DLARF applies a real elementary reflector H to a real m by n matrix !! C, from either the left or the right. H is represented in the form !! H = I - tau * v * v**T @@ -3565,7 +3567,7 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: tau ! Array Arguments real(dp), intent(inout) :: c(ldc,*) @@ -3575,11 +3577,11 @@ module stdlib_linalg_lapack_d ! 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. @@ -3588,50 +3590,50 @@ module stdlib_linalg_lapack_d 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_iladlc(lastv, n, c, ldc) + lastc = stdlib${ii}$_iladlc(lastv, n, c, ldc) else ! scan for the last non-zero row in c(:,1:lastv). - lastc = stdlib_iladlr(m, lastv, c, ldc) + lastc = stdlib${ii}$_iladlr(m, lastv, c, ldc) end if end if ! note that lastc.eq.0_dp renders the blas operations null; no special ! case is needed at this level. if( applyleft ) then ! form h * c - if( lastv>0 ) then + if( lastv>0_${ik}$ ) then ! w(1:lastc,1) := c(1:lastv,1:lastc)**t * v(1:lastv,1) - call stdlib_dgemv( 'TRANSPOSE', lastv, lastc, one, c, ldc, v, incv,zero, work, 1 & + call stdlib${ii}$_dgemv( '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_dger( lastv, lastc, -tau, v, incv, work, 1, c, ldc ) + call stdlib${ii}$_dger( lastv, lastc, -tau, v, incv, work, 1_${ik}$, c, ldc ) end if else ! form c * h - if( lastv>0 ) then + if( lastv>0_${ik}$ ) then ! w(1:lastc,1) := c(1:lastc,1:lastv) * v(1:lastv,1) - call stdlib_dgemv( 'NO TRANSPOSE', lastc, lastv, one, c, ldc,v, incv, zero, work,& - 1 ) + call stdlib${ii}$_dgemv( 'NO TRANSPOSE', lastc, lastv, one, c, ldc,v, incv, zero, work,& + 1_${ik}$ ) ! c(1:lastc,1:lastv) := c(...) - w(1:lastc,1) * v(1:lastv,1)**t - call stdlib_dger( lastc, lastv, -tau, work, 1, v, incv, c, ldc ) + call stdlib${ii}$_dger( lastc, lastv, -tau, work, 1_${ik}$, v, incv, c, ldc ) end if end if return - end subroutine stdlib_dlarf + end subroutine stdlib${ii}$_dlarf - pure subroutine stdlib_dlarfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, ldc, & + pure subroutine stdlib${ii}$_dlarfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, ldc, & !! DLARFB applies a real block reflector H or its transpose H**T to a !! real m by n matrix C, from either the left or the right. work, ldwork ) @@ -3640,7 +3642,7 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: c(ldc,*) real(dp), intent(in) :: t(ldt,*), v(ldv,*) @@ -3649,7 +3651,7 @@ module stdlib_linalg_lapack_d ! 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 @@ -3669,27 +3671,27 @@ module stdlib_linalg_lapack_d ! w := c**t * v = (c1**t * v1 + c2**t * v2) (stored in work) ! w := c1**t do j = 1, k - call stdlib_dcopy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib${ii}$_dcopy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v1 - call stdlib_dtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, one, v, ldv,& + call stdlib${ii}$_dtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, one, v, ldv,& work, ldwork ) if( m>k ) then ! w := w + c2**t * v2 - call stdlib_dgemm( 'TRANSPOSE', 'NO TRANSPOSE', n, k, m-k,one, c( k+1, 1 ),& - ldc, v( k+1, 1 ), ldv,one, work, ldwork ) + call stdlib${ii}$_dgemm( '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_dtrmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,one, t, ldt, & + call stdlib${ii}$_dtrmm( '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_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', m-k, n, k,-one, v( k+1, 1 )& - , ldv, work, ldwork, one,c( k+1, 1 ), ldc ) + call stdlib${ii}$_dgemm( '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_dtrmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', n, k,one, v, ldv, & + call stdlib${ii}$_dtrmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', n, k,one, v, ldv, & work, ldwork ) ! c1 := c1 - w**t do j = 1, k @@ -3702,27 +3704,27 @@ module stdlib_linalg_lapack_d ! w := c * v = (c1*v1 + c2*v2) (stored in work) ! w := c1 do j = 1, k - call stdlib_dcopy( m, c( 1, j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_dcopy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v1 - call stdlib_dtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, one, v, ldv,& + call stdlib${ii}$_dtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, one, v, ldv,& work, ldwork ) if( n>k ) then ! w := w + c2 * v2 - call stdlib_dgemm( '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}$_dgemm( '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_dtrmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,one, t, ldt, & + call stdlib${ii}$_dtrmm( '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_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, n-k, k,-one, work, & - ldwork, v( k+1, 1 ), ldv, one,c( 1, k+1 ), ldc ) + call stdlib${ii}$_dgemm( '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_dtrmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', m, k,one, v, ldv, & + call stdlib${ii}$_dtrmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', m, k,one, v, ldv, & work, ldwork ) ! c1 := c1 - w do j = 1, k @@ -3741,28 +3743,28 @@ module stdlib_linalg_lapack_d ! w := c**t * v = (c1**t * v1 + c2**t * v2) (stored in work) ! w := c2**t do j = 1, k - call stdlib_dcopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib${ii}$_dcopy( n, c( m-k+j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v2 - call stdlib_dtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, one, v( m-k+& - 1, 1 ), ldv, work, ldwork ) + call stdlib${ii}$_dtrmm( '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_dgemm( 'TRANSPOSE', 'NO TRANSPOSE', n, k, m-k,one, c, ldc, v, & + call stdlib${ii}$_dgemm( '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_dtrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,one, t, ldt, & + call stdlib${ii}$_dtrmm( '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_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', m-k, n, k,-one, v, ldv, & + call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', m-k, n, k,-one, v, ldv, & work, ldwork, one, c, ldc ) end if ! w := w * v2**t - call stdlib_dtrmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', n, k,one, v( m-k+1, & - 1 ), ldv, work, ldwork ) + call stdlib${ii}$_dtrmm( '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 @@ -3774,28 +3776,28 @@ module stdlib_linalg_lapack_d ! w := c * v = (c1*v1 + c2*v2) (stored in work) ! w := c2 do j = 1, k - call stdlib_dcopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_dcopy( m, c( 1_${ik}$, n-k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v2 - call stdlib_dtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, one, v( n-k+& - 1, 1 ), ldv, work, ldwork ) + call stdlib${ii}$_dtrmm( '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_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,one, c, ldc, & + call stdlib${ii}$_dgemm( '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_dtrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,one, t, ldt, & + call stdlib${ii}$_dtrmm( '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_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, n-k, k,-one, work, & + call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, n-k, k,-one, work, & ldwork, v, ldv, one, c, ldc ) end if ! w := w * v2**t - call stdlib_dtrmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', m, k,one, v( n-k+1, & - 1 ), ldv, work, ldwork ) + call stdlib${ii}$_dtrmm( '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 @@ -3814,27 +3816,27 @@ module stdlib_linalg_lapack_d ! 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_dcopy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib${ii}$_dcopy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v1**t - call stdlib_dtrmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', n, k,one, v, ldv, & + call stdlib${ii}$_dtrmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', n, k,one, v, ldv, & work, ldwork ) if( m>k ) then ! w := w + c2**t * v2**t - call stdlib_dgemm( 'TRANSPOSE', 'TRANSPOSE', n, k, m-k, one,c( k+1, 1 ), & - ldc, v( 1, k+1 ), ldv, one,work, ldwork ) + call stdlib${ii}$_dgemm( '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_dtrmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,one, t, ldt, & + call stdlib${ii}$_dtrmm( '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_dgemm( 'TRANSPOSE', 'TRANSPOSE', m-k, n, k, -one,v( 1, k+1 ), & - ldv, work, ldwork, one,c( k+1, 1 ), ldc ) + call stdlib${ii}$_dgemm( '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_dtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, one, v, ldv,& + call stdlib${ii}$_dtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, one, v, ldv,& work, ldwork ) ! c1 := c1 - w**t do j = 1, k @@ -3847,27 +3849,27 @@ module stdlib_linalg_lapack_d ! w := c * v**t = (c1*v1**t + c2*v2**t) (stored in work) ! w := c1 do j = 1, k - call stdlib_dcopy( m, c( 1, j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_dcopy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v1**t - call stdlib_dtrmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', m, k,one, v, ldv, & + call stdlib${ii}$_dtrmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', m, k,one, v, ldv, & work, ldwork ) if( n>k ) then ! w := w + c2 * v2**t - call stdlib_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, n-k,one, c( 1, k+1 ),& - ldc, v( 1, k+1 ), ldv,one, work, ldwork ) + call stdlib${ii}$_dgemm( '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_dtrmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,one, t, ldt, & + call stdlib${ii}$_dtrmm( '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_dgemm( '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}$_dgemm( '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_dtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, one, v, ldv,& + call stdlib${ii}$_dtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, one, v, ldv,& work, ldwork ) ! c1 := c1 - w do j = 1, k @@ -3885,27 +3887,27 @@ module stdlib_linalg_lapack_d ! 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_dcopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib${ii}$_dcopy( n, c( m-k+j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v2**t - call stdlib_dtrmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', n, k,one, v( 1, m-k+& - 1 ), ldv, work, ldwork ) + call stdlib${ii}$_dtrmm( '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_dgemm( 'TRANSPOSE', 'TRANSPOSE', n, k, m-k, one,c, ldc, v, ldv,& + call stdlib${ii}$_dgemm( '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_dtrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,one, t, ldt, & + call stdlib${ii}$_dtrmm( '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_dgemm( 'TRANSPOSE', 'TRANSPOSE', m-k, n, k, -one,v, ldv, work, & + call stdlib${ii}$_dgemm( 'TRANSPOSE', 'TRANSPOSE', m-k, n, k, -one,v, ldv, work, & ldwork, one, c, ldc ) end if ! w := w * v2 - call stdlib_dtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, one, v( 1, & + call stdlib${ii}$_dtrmm( '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 @@ -3918,27 +3920,27 @@ module stdlib_linalg_lapack_d ! w := c * v**t = (c1*v1**t + c2*v2**t) (stored in work) ! w := c2 do j = 1, k - call stdlib_dcopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_dcopy( m, c( 1_${ik}$, n-k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v2**t - call stdlib_dtrmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', m, k,one, v( 1, n-k+& - 1 ), ldv, work, ldwork ) + call stdlib${ii}$_dtrmm( '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_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, n-k,one, c, ldc, v, & + call stdlib${ii}$_dgemm( '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_dtrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,one, t, ldt, & + call stdlib${ii}$_dtrmm( '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_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-one, work, & + call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-one, work, & ldwork, v, ldv, one, c, ldc ) end if ! w := w * v2 - call stdlib_dtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, one, v( 1, & + call stdlib${ii}$_dtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, one, v( 1_${ik}$, & n-k+1 ), ldv, work, ldwork ) ! c1 := c1 - w do j = 1, k @@ -3950,10 +3952,10 @@ module stdlib_linalg_lapack_d end if end if return - end subroutine stdlib_dlarfb + end subroutine stdlib${ii}$_dlarfb - pure subroutine stdlib_dlarfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) + pure subroutine stdlib${ii}$_dlarfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) !! DLARFB_GETT applies a real Householder block reflector H from the !! left to a real (K+M)-by-N "triangular-pentagonal" matrix !! composed of two block matrices: an upper trapezoidal K-by-N matrix A @@ -3967,7 +3969,7 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*), b(ldb,*) real(dp), intent(in) :: t(ldt,*) @@ -3976,7 +3978,7 @@ module stdlib_linalg_lapack_d ! 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 @@ -3990,34 +3992,34 @@ module stdlib_linalg_lapack_d ! col2_(1) compute w2: = a2. therefore, copy a2 = a(1:k, k+1:n) ! into w2=work(1:k, 1:n-k) column-by-column. do j = 1, n-k - call stdlib_dcopy( k, a( 1, k+j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_dcopy( 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, ! v1 is not an identy matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored). - call stdlib_dtrmm( 'L', 'L', 'T', 'U', k, n-k, one, a, lda,work, ldwork ) + call stdlib${ii}$_dtrmm( 'L', 'L', 'T', 'U', k, n-k, one, a, lda,work, ldwork ) end if ! col2_(3) compute w2: = w2 + (v2**t) * b2 = w2 + (b1**t) * b2 ! v2 stored in b1. - if( m>0 ) then - call stdlib_dgemm( 'T', 'N', k, n-k, m, one, b, ldb,b( 1, k+1 ), ldb, one, work, & + if( m>0_${ik}$ ) then + call stdlib${ii}$_dgemm( '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, ! t is upper-triangular. - call stdlib_dtrmm( 'L', 'U', 'N', 'N', k, n-k, one, t, ldt,work, ldwork ) + call stdlib${ii}$_dtrmm( 'L', 'U', 'N', 'N', k, n-k, one, t, ldt,work, ldwork ) ! col2_(5) compute b2: = b2 - v2 * w2 = b2 - b1 * w2, ! v2 stored in b1. - if( m>0 ) then - call stdlib_dgemm( '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}$_dgemm( '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, ! v1 is not an identity matrix, but unit lower-triangular, ! v1 stored in a1 (diagonal ones are not stored). - call stdlib_dtrmm( 'L', 'L', 'N', 'U', k, n-k, one, a, lda,work, ldwork ) + call stdlib${ii}$_dtrmm( '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), @@ -4037,7 +4039,7 @@ module stdlib_linalg_lapack_d ! a1 = a(1:k, 1:k) into the upper-triangular ! w1 = work(1:k, 1:k) column-by-column. do j = 1, k - call stdlib_dcopy( j, a( 1, j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_dcopy( 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 @@ -4050,16 +4052,16 @@ module stdlib_linalg_lapack_d ! 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_dtrmm( 'L', 'L', 'T', 'U', k, k, one, a, lda,work, ldwork ) + call stdlib${ii}$_dtrmm( 'L', 'L', 'T', 'U', k, k, one, a, lda,work, ldwork ) end if ! col1_(3) compute w1: = t * w1, ! t is upper-triangular, ! w1 is upper-triangular with zeroes below the diagonal. - call stdlib_dtrmm( 'L', 'U', 'N', 'N', k, k, one, t, ldt,work, ldwork ) + call stdlib${ii}$_dtrmm( 'L', 'U', 'N', 'N', k, k, one, t, ldt,work, ldwork ) ! col1_(4) compute b1: = - v2 * w1 = - b1 * w1, ! v2 = b1, w1 is upper-triangular with zeroes below the diagonal. - if( m>0 ) then - call stdlib_dtrmm( 'R', 'U', 'N', 'N', m, k, -one, work, ldwork,b, ldb ) + if( m>0_${ik}$ ) then + call stdlib${ii}$_dtrmm( 'R', 'U', 'N', 'N', m, k, -one, work, ldwork,b, ldb ) end if if( lnotident ) then ! col1_(5) compute w1: = v1 * w1 = a1 * w1, @@ -4067,7 +4069,7 @@ module stdlib_linalg_lapack_d ! 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_dtrmm( 'L', 'L', 'N', 'U', k, k, one, a, lda,work, ldwork ) + call stdlib${ii}$_dtrmm( 'L', 'L', 'N', 'U', k, k, one, a, lda,work, ldwork ) ! col1_(6) compute a1: = a1 - w1 = a(1:k, 1:k) - work(1:k, 1:k) ! column-by-column. a1 is upper-triangular on input. ! if ident, a1 is square on output, and w1 is square, @@ -4087,10 +4089,10 @@ module stdlib_linalg_lapack_d end do end do return - end subroutine stdlib_dlarfb_gett + end subroutine stdlib${ii}$_dlarfb_gett - pure subroutine stdlib_dlarft( direct, storev, n, k, v, ldv, tau, t, ldt ) + pure subroutine stdlib${ii}$_dlarft( direct, storev, n, k, v, ldv, tau, t, ldt ) !! DLARFT 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; @@ -4106,14 +4108,14 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(out) :: t(ldt,*) real(dp), 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 @@ -4138,8 +4140,8 @@ module stdlib_linalg_lapack_d 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_dgemv( 'TRANSPOSE', j-i, i-1, -tau( i ),v( i+1, 1 ), ldv, v( i+& - 1, i ), 1, one,t( 1, i ), 1 ) + call stdlib${ii}$_dgemv( '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 @@ -4150,14 +4152,14 @@ module stdlib_linalg_lapack_d 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_dgemv( 'NO TRANSPOSE', i-1, j-i, -tau( i ),v( 1, i+1 ), ldv, v(& - i, i+1 ), ldv, one,t( 1, i ), 1 ) + call stdlib${ii}$_dgemv( '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_dtrmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', i-1, t,ldt, t( 1, i ),& - 1 ) + call stdlib${ii}$_dtrmv( '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 @@ -4165,7 +4167,7 @@ module stdlib_linalg_lapack_d end if end do else - prevlastv = 1 + prevlastv = 1_${ik}$ do i = k, 1, -1 if( tau( i )==zero ) then ! h(i) = i @@ -4185,8 +4187,8 @@ module stdlib_linalg_lapack_d 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_dgemv( '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}$_dgemv( '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 @@ -4197,13 +4199,13 @@ module stdlib_linalg_lapack_d 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_dgemv( '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}$_dgemv( '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_dtrmv( '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}$_dtrmv( '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 @@ -4214,10 +4216,10 @@ module stdlib_linalg_lapack_d end do end if return - end subroutine stdlib_dlarft + end subroutine stdlib${ii}$_dlarft - pure subroutine stdlib_dlarfx( side, m, n, v, tau, c, ldc, work ) + pure subroutine stdlib${ii}$_dlarfx( side, m, n, v, tau, c, ldc, work ) !! DLARFX applies a real elementary reflector H to a real m by n !! matrix C, from either the left or the right. H is represented in the !! form @@ -4230,7 +4232,7 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: tau ! Array Arguments real(dp), intent(inout) :: c(ldc,*) @@ -4239,7 +4241,7 @@ module stdlib_linalg_lapack_d ! ===================================================================== ! Local Scalars - integer(ilp) :: j + integer(${ik}$) :: j real(dp) :: sum, t1, t10, t2, t3, t4, t5, t6, t7, t8, t9, v1, v10, v2, v3, v4, v5, v6, & v7, v8, v9 ! Executable Statements @@ -4248,479 +4250,479 @@ module stdlib_linalg_lapack_d ! 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_dlarf( side, m, n, v, 1, tau, c, ldc, work ) + call stdlib${ii}$_dlarf( 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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_dlarf( side, m, n, v, 1, tau, c, ldc, work ) + call stdlib${ii}$_dlarf( 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 continue return - end subroutine stdlib_dlarfx + end subroutine stdlib${ii}$_dlarfx - pure subroutine stdlib_dlarfy( uplo, n, v, incv, tau, c, ldc, work ) + pure subroutine stdlib${ii}$_dlarfy( uplo, n, v, incv, tau, c, ldc, work ) !! DLARFY applies an elementary reflector, or Householder matrix, H, !! to an n x n symmetric matrix C, from both the left and the right. !! H is represented in the form @@ -4732,7 +4734,7 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: tau ! Array Arguments real(dp), intent(inout) :: c(ldc,*) @@ -4745,16 +4747,16 @@ module stdlib_linalg_lapack_d ! Executable Statements if( tau==zero )return ! form w:= c * v - call stdlib_dsymv( uplo, n, one, c, ldc, v, incv, zero, work, 1 ) - alpha = -half*tau*stdlib_ddot( n, work, 1, v, incv ) - call stdlib_daxpy( n, alpha, v, incv, work, 1 ) + call stdlib${ii}$_dsymv( uplo, n, one, c, ldc, v, incv, zero, work, 1_${ik}$ ) + alpha = -half*tau*stdlib${ii}$_ddot( n, work, 1_${ik}$, v, incv ) + call stdlib${ii}$_daxpy( n, alpha, v, incv, work, 1_${ik}$ ) ! c := c - v * w' - w * v' - call stdlib_dsyr2( uplo, n, -tau, v, incv, work, 1, c, ldc ) + call stdlib${ii}$_dsyr2( uplo, n, -tau, v, incv, work, 1_${ik}$, c, ldc ) return - end subroutine stdlib_dlarfy + end subroutine stdlib${ii}$_dlarfy - pure subroutine stdlib_dlargv( n, x, incx, y, incy, c, incc ) + pure subroutine stdlib${ii}$_dlargv( n, x, incx, y, incy, c, incc ) !! DLARGV generates a vector of real plane rotations, determined by !! elements of the real vectors x and y. For i = 1,2,...,n !! ( c(i) s(i) ) ( x(i) ) = ( a(i) ) @@ -4763,21 +4765,21 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(out) :: c(*) real(dp), intent(inout) :: x(*), y(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ic, ix, iy + integer(${ik}$) :: i, ic, ix, iy real(dp) :: 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 ) @@ -4805,38 +4807,38 @@ module stdlib_linalg_lapack_d ix = ix + incx end do loop_10 return - end subroutine stdlib_dlargv + end subroutine stdlib${ii}$_dlargv - pure subroutine stdlib_dlarra( n, d, e, e2, spltol, tnrm,nsplit, isplit, info ) + pure subroutine stdlib${ii}$_dlarra( n, d, e, e2, spltol, tnrm,nsplit, isplit, info ) !! Compute the splitting points with threshold SPLTOL. !! DLARRA sets any "small" off-diagonal elements to zero. ! -- lapack auxiliary routine -- ! -- 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(dp), intent(in) :: spltol, tnrm ! Array Arguments - integer(ilp), intent(out) :: isplit(*) + integer(${ik}$), intent(out) :: isplit(*) real(dp), intent(in) :: d(*) real(dp), intent(inout) :: e(*), e2(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i real(dp) :: 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_dlamch( 'P' ) - uflow = stdlib_dlamch( 'U' ) + eps = stdlib${ii}$_dlamch( 'P' ) + uflow = stdlib${ii}$_dlamch( 'U' ) ! special case when n=1 ! 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 ! if only scalar is to be done. - nb = stdlib_ilaenv( 1, 'DSTEBZ', ' ', n, -1, -1, -1 ) - if( nb<=1 ) nb = 0 + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSTEBZ', ' ', 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 ) ) @@ -5081,7 +5083,7 @@ module stdlib_linalg_lapack_d gu = gu + fudge*tnorm*eps*n + fudge*two*pivmin ! [jan/28/2009] remove the line below since spdiam variable not use ! spdiam = gu - gl - ! input arguments for stdlib_dlaebz: + ! input arguments for stdlib${ii}$_dlaebz: ! the relative tolerance. an interval (a,b] lies within ! "relative tolerance" if b-a < reltol*max(|a|,|b|), rtoli = reltol @@ -5095,46 +5097,46 @@ module stdlib_linalg_lapack_d 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_dlaebz. - itmax = int( ( log( tnorm+pivmin )-log( pivmin ) ) /log( two ),KIND=ilp) + 2 + ! gerschgorin bounds gl and gu is refined by stdlib${ii}$_dlaebz. + 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_dlaebz( 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}$_dlaebz( 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 @@ -5147,29 +5149,29 @@ module stdlib_linalg_lapack_d ! 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 + if( in==1_${ik}$ ) then ! 1x1 block - if( wl>=d( ibegin )-pivmin )nwl = nwl + 1 - if( wu>=d( ibegin )-pivmin )nwu = nwu + 1 + 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 @@ -5219,13 +5221,13 @@ module stdlib_linalg_lapack_d else ! general case - block of size in >= 2 ! compute local gerschgorin interval and use it as the initial - ! interval for stdlib_dlaebz + ! interval for stdlib${ii}$_dlaebz 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 @@ -5235,7 +5237,7 @@ module stdlib_linalg_lapack_d ! 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 ) @@ -5317,24 +5319,24 @@ module stdlib_linalg_lapack_d 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 ) @@ -5342,44 +5344,44 @@ module stdlib_linalg_lapack_d 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 + 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 ) @@ -5388,7 +5390,7 @@ module stdlib_linalg_lapack_d 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 @@ -5398,9 +5400,9 @@ module stdlib_linalg_lapack_d ! 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 @@ -5504,13 +5506,13 @@ module stdlib_linalg_lapack_d ! 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 @@ -5520,21 +5522,21 @@ module stdlib_linalg_lapack_d ! 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 + 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_dlarrj + end subroutine stdlib${ii}$_dlarrj - pure subroutine stdlib_dlarrk( n, iw, gl, gu,d, e2, pivmin, reltol, w, werr, info) + pure subroutine stdlib${ii}$_dlarrk( n, iw, gl, gu,d, e2, pivmin, reltol, w, werr, info) !! DLARRK computes one eigenvalue of a symmetric tridiagonal !! matrix T to suitable accuracy. This is an auxiliary code to be !! called from DSTEMR. @@ -5622,8 +5624,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: pivmin, reltol, gl, gu real(dp), intent(out) :: w, werr ! Array Arguments @@ -5633,46 +5635,46 @@ module stdlib_linalg_lapack_d real(dp), parameter :: fudge = two ! Local Scalars - integer(ilp) :: i, it, itmax, negcnt + integer(${ik}$) :: i, it, itmax, negcnt real(dp) :: 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_dlamch( 'P' ) + eps = stdlib${ii}$_dlamch( '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 @@ -5685,10 +5687,10 @@ module stdlib_linalg_lapack_d w = half * (left + right) werr = half * abs( right - left ) return - end subroutine stdlib_dlarrk + end subroutine stdlib${ii}$_dlarrk - pure subroutine stdlib_dlarrr( n, d, e, info ) + pure subroutine stdlib${ii}$_dlarrr( 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. @@ -5696,8 +5698,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: d(*) real(dp), intent(inout) :: e(*) @@ -5706,21 +5708,21 @@ module stdlib_linalg_lapack_d real(dp), parameter :: relcond = 0.999_dp ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i logical(lk) :: yesrel real(dp) :: 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_dlamch( 'SAFE MINIMUM' ) - eps = stdlib_dlamch( 'PRECISION' ) + info = 1_${ik}$ + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_dlamch( 'PRECISION' ) smlnum = safmin / eps rmin = sqrt( smlnum ) ! tests for relative accuracy @@ -5739,7 +5741,7 @@ module stdlib_linalg_lapack_d ! instead of the current offdig + offdig2 < 1 yesrel = .true. offdig = zero - tmp = sqrt(abs(d(1))) + tmp = sqrt(abs(d(1_${ik}$))) if (tmp=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 @@ -5928,10 +5930,10 @@ module stdlib_linalg_lapack_d end if end if return - end subroutine stdlib_dlartgp + end subroutine stdlib${ii}$_dlartgp - pure subroutine stdlib_dlartgs( x, y, sigma, cs, sn ) + pure subroutine stdlib${ii}$_dlartgs( x, y, sigma, cs, sn ) !! DLARTGS generates a plane rotation designed to introduce a bulge in !! Golub-Reinsch-style implicit QR iteration for the bidiagonal SVD !! problem. X and Y are the top-row entries, and SIGMA is the shift. @@ -5950,7 +5952,7 @@ module stdlib_linalg_lapack_d ! Local Scalars real(dp) :: r, s, thresh, w, z - thresh = stdlib_dlamch('E') + thresh = stdlib${ii}$_dlamch('E') ! compute the first column of b**t*b - sigma^2*i, up to a scale ! factor. if( (sigma == zero .and. abs(x) < thresh) .or.(abs(x) == sigma .and. y == zero) ) & @@ -5978,16 +5980,16 @@ module stdlib_linalg_lapack_d w = s * y end if ! generate the rotation. - ! call stdlib_dlartgp( z, w, cs, sn, r ) might seem more natural; + ! call stdlib${ii}$_dlartgp( z, w, cs, sn, r ) might seem more natural; ! reordering the arguments ensures that if z = 0 then the rotation ! is by pi/2. - call stdlib_dlartgp( w, z, sn, cs, r ) + call stdlib${ii}$_dlartgp( w, z, sn, cs, r ) return - ! end stdlib_dlartgs - end subroutine stdlib_dlartgs + ! end stdlib${ii}$_dlartgs + end subroutine stdlib${ii}$_dlartgs - pure subroutine stdlib_dlartv( n, x, incx, y, incy, c, s, incc ) + pure subroutine stdlib${ii}$_dlartv( n, x, incx, y, incy, c, s, incc ) !! DLARTV applies a vector of real plane rotations to elements of the !! real vectors x and y. For i = 1,2,...,n !! ( x(i) ) := ( c(i) s(i) ) ( x(i) ) @@ -5996,18 +5998,18 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: c(*), s(*) real(dp), intent(inout) :: x(*), y(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ic, ix, iy + integer(${ik}$) :: i, ic, ix, iy real(dp) :: 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 ) @@ -6018,10 +6020,10 @@ module stdlib_linalg_lapack_d ic = ic + incc end do return - end subroutine stdlib_dlartv + end subroutine stdlib${ii}$_dlartv - pure subroutine stdlib_dlaruv( iseed, n, x ) + pure subroutine stdlib${ii}$_dlaruv( iseed, n, x ) !! DLARUV returns a vector of n random real numbers from a uniform (0,1) !! distribution (n <= 128). !! This is an auxiliary routine called by DLARNV and ZLARNV. @@ -6029,171 +6031,171 @@ module stdlib_linalg_lapack_d ! -- 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(dp), 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(dp), 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 :: real,min,mod ! 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 ) + 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=dp) x( i ) = r*( real( it1,KIND=dp)+r*( real( it2,KIND=dp)+r*( real( it3,KIND=dp)+& @@ -6207,23 +6209,23 @@ module stdlib_linalg_lapack_d ! the statistically correct thing to do in this situation is ! simply to iterate again. ! n.b. the case x( i ) = 0.0_dp 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_dlaruv + end subroutine stdlib${ii}$_dlaruv - pure subroutine stdlib_dlarz( side, m, n, l, v, incv, tau, c, ldc, work ) + pure subroutine stdlib${ii}$_dlarz( side, m, n, l, v, incv, tau, c, ldc, work ) !! DLARZ applies a real elementary reflector H to a real M-by-N !! matrix C, from either the left or the right. H is represented in the !! form @@ -6236,7 +6238,7 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: tau ! Array Arguments real(dp), intent(inout) :: c(ldc,*) @@ -6249,36 +6251,36 @@ module stdlib_linalg_lapack_d ! form h * c if( tau/=zero ) then ! w( 1:n ) = c( 1, 1:n ) - call stdlib_dcopy( n, c, ldc, work, 1 ) + call stdlib${ii}$_dcopy( n, c, ldc, work, 1_${ik}$ ) ! w( 1:n ) = w( 1:n ) + c( m-l+1:m, 1:n )**t * v( 1:l ) - call stdlib_dgemv( 'TRANSPOSE', l, n, one, c( m-l+1, 1 ), ldc, v,incv, one, work,& - 1 ) + call stdlib${ii}$_dgemv( 'TRANSPOSE', l, n, one, c( m-l+1, 1_${ik}$ ), ldc, v,incv, one, work,& + 1_${ik}$ ) ! c( 1, 1:n ) = c( 1, 1:n ) - tau * w( 1:n ) - call stdlib_daxpy( n, -tau, work, 1, c, ldc ) + call stdlib${ii}$_daxpy( n, -tau, work, 1_${ik}$, 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_dger( l, n, -tau, v, incv, work, 1, c( m-l+1, 1 ),ldc ) + call stdlib${ii}$_dger( 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_dcopy( m, c, 1, work, 1 ) + call stdlib${ii}$_dcopy( m, c, 1_${ik}$, work, 1_${ik}$ ) ! w( 1:m ) = w( 1:m ) + c( 1:m, n-l+1:n, 1:n ) * v( 1:l ) - call stdlib_dgemv( 'NO TRANSPOSE', m, l, one, c( 1, n-l+1 ), ldc,v, incv, one, & - work, 1 ) + call stdlib${ii}$_dgemv( 'NO TRANSPOSE', m, l, one, c( 1_${ik}$, n-l+1 ), ldc,v, incv, one, & + work, 1_${ik}$ ) ! c( 1:m, 1 ) = c( 1:m, 1 ) - tau * w( 1:m ) - call stdlib_daxpy( m, -tau, work, 1, c, 1 ) + call stdlib${ii}$_daxpy( m, -tau, work, 1_${ik}$, c, 1_${ik}$ ) ! c( 1:m, n-l+1:n ) = c( 1:m, n-l+1:n ) - ... ! tau * w( 1:m ) * v( 1:l )**t - call stdlib_dger( m, l, -tau, work, 1, v, incv, c( 1, n-l+1 ),ldc ) + call stdlib${ii}$_dger( m, l, -tau, work, 1_${ik}$, v, incv, c( 1_${ik}$, n-l+1 ),ldc ) end if end if return - end subroutine stdlib_dlarz + end subroutine stdlib${ii}$_dlarz - pure subroutine stdlib_dlarzb( side, trans, direct, storev, m, n, k, l, v,ldv, t, ldt, c, & + pure subroutine stdlib${ii}$_dlarzb( side, trans, direct, storev, m, n, k, l, v,ldv, t, ldt, c, & !! DLARZB applies a real block reflector H or its transpose H**T to !! a real distributed M-by-N C from the left or the right. !! Currently, only STOREV = 'R' and DIRECT = 'B' are supported. @@ -6288,7 +6290,7 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: c(ldc,*), t(ldt,*), v(ldv,*) real(dp), intent(out) :: work(ldwork,*) @@ -6296,19 +6298,19 @@ module stdlib_linalg_lapack_d ! 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( 'DLARZB', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DLARZB', -info ) return end if if( stdlib_lsame( trans, 'N' ) ) then @@ -6320,14 +6322,14 @@ module stdlib_linalg_lapack_d ! form h * c or h**t * c ! w( 1:n, 1:k ) = c( 1:k, 1:n )**t do j = 1, k - call stdlib_dcopy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib${ii}$_dcopy( 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_dgemm( 'TRANSPOSE', 'TRANSPOSE', n, k, l, one,c( m-l+1, 1 ), & + if( l>0_${ik}$ )call stdlib${ii}$_dgemm( '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_dtrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k, one, t,ldt, work, & + call stdlib${ii}$_dtrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k, one, t,ldt, work, & ldwork ) ! c( 1:k, 1:n ) = c( 1:k, 1:n ) - w( 1:n, 1:k )**t do j = 1, n @@ -6337,20 +6339,20 @@ module stdlib_linalg_lapack_d 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_dgemm( 'TRANSPOSE', 'TRANSPOSE', l, n, k, -one, v, ldv,work, & - ldwork, one, c( m-l+1, 1 ), ldc ) + if( l>0_${ik}$ )call stdlib${ii}$_dgemm( '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 ) do j = 1, k - call stdlib_dcopy( m, c( 1, j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_dcopy( 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_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, l, one,c( 1, n-l+1 ),& + if( l>0_${ik}$ )call stdlib${ii}$_dgemm( '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_dtrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k, one, t,ldt, work, & + call stdlib${ii}$_dtrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k, one, t,ldt, work, & ldwork ) ! c( 1:m, 1:k ) = c( 1:m, 1:k ) - w( 1:m, 1:k ) do j = 1, k @@ -6360,14 +6362,14 @@ module stdlib_linalg_lapack_d 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_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, l, k, -one,work, & - ldwork, v, ldv, one, c( 1, n-l+1 ), ldc ) + if( l>0_${ik}$ )call stdlib${ii}$_dgemm( '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_dlarzb + end subroutine stdlib${ii}$_dlarzb - pure subroutine stdlib_dlarzt( direct, storev, n, k, v, ldv, tau, t, ldt ) + pure subroutine stdlib${ii}$_dlarzt( direct, storev, n, k, v, ldv, tau, t, ldt ) !! DLARZT forms the triangular factor T of a real block reflector !! H of order > n, which is defined as a product of k elementary !! reflectors. @@ -6385,7 +6387,7 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(out) :: t(ldt,*) real(dp), intent(in) :: tau(*) @@ -6393,17 +6395,17 @@ module stdlib_linalg_lapack_d ! ===================================================================== ! 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( 'DLARZT', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DLARZT', -info ) return end if do i = k, 1, -1 @@ -6416,20 +6418,20 @@ module stdlib_linalg_lapack_d ! general case if( izero ) 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 ) 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 ) + 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 ) = -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 + 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 ) * d( 2 ) if( b>zero ) then tau = -two*c / ( b+sqrt( b*b+four*c ) ) @@ -6549,12 +6551,12 @@ module stdlib_linalg_lapack_d 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 + 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 ) = -z( 1 ) / ( del+tau ) ! delta( 2 ) = -z( 2 ) / tau end if @@ -6563,8 +6565,8 @@ module stdlib_linalg_lapack_d ! 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 + 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 ) * d( 2 ) if( b>zero ) then tau = ( b+sqrt( b*b+four*c ) ) / two @@ -6572,12 +6574,12 @@ module stdlib_linalg_lapack_d 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 + 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 ) = -z( 1 ) / ( del+tau ) ! delta( 2 ) = -z( 2 ) / tau ! temp = sqrt( delta( 1 )*delta( 1 )+delta( 2 )*delta( 2 ) ) @@ -6585,61 +6587,61 @@ module stdlib_linalg_lapack_d ! delta( 2 ) = delta( 2 ) / temp end if return - end subroutine stdlib_dlasd5 + end subroutine stdlib${ii}$_dlasd5 - pure subroutine stdlib_dlasdt( n, lvl, nd, inode, ndiml, ndimr, msub ) + pure subroutine stdlib${ii}$_dlasdt( n, lvl, nd, inode, ndiml, ndimr, msub ) !! DLASDT 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(dp) :: temp ! Intrinsic Functions intrinsic :: real,int,log,max ! Executable Statements ! find the number of levels on the tree. - maxn = max( 1, n ) + maxn = max( 1_${ik}$, n ) temp = log( real( maxn,KIND=dp) / real( msub+1,KIND=dp) ) / 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_dlasdt + end subroutine stdlib${ii}$_dlasdt - pure subroutine stdlib_dlaset( uplo, m, n, alpha, beta, a, lda ) + pure subroutine stdlib${ii}$_dlaset( uplo, m, n, alpha, beta, a, lda ) !! DLASET initializes an m-by-n matrix A to BETA on the diagonal and !! ALPHA on the offdiagonals. ! -- lapack auxiliary routine -- @@ -6647,13 +6649,13 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: alpha, beta ! Array Arguments real(dp), intent(out) :: a(lda,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -6686,10 +6688,10 @@ module stdlib_linalg_lapack_d a( i, i ) = beta end do return - end subroutine stdlib_dlaset + end subroutine stdlib${ii}$_dlaset - pure subroutine stdlib_dlasq4( i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn,dn1, dn2, tau, & + pure subroutine stdlib${ii}$_dlasq4( i0, n0, z, pp, n0in, dmin, dmin1, dmin2, dn,dn1, dn2, tau, & !! DLASQ4 computes an approximation TAU to the smallest eigenvalue !! using values of d from the previous transform. ttype, g ) @@ -6697,8 +6699,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: dmin, dmin1, dmin2, dn, dn1, dn2 real(dp), intent(inout) :: g real(dp), intent(out) :: tau @@ -6715,7 +6717,7 @@ module stdlib_linalg_lapack_d ! Local Scalars - integer(ilp) :: i4, nn, np + integer(${ik}$) :: i4, nn, np real(dp) :: a2, b1, b2, gam, gap1, gap2, s ! Intrinsic Functions intrinsic :: max,min,sqrt @@ -6724,10 +6726,10 @@ module stdlib_linalg_lapack_d ! 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 @@ -6744,32 +6746,32 @@ module stdlib_linalg_lapack_d 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 @@ -6788,17 +6790,17 @@ module stdlib_linalg_lapack_d 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 @@ -6815,21 +6817,21 @@ module stdlib_linalg_lapack_d if( a2z( nn-7 ) )return b1 = z( nn-5 ) / z( nn-7 ) @@ -6844,25 +6846,25 @@ module stdlib_linalg_lapack_d 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. if( dmin2==dn2 .and. two*z( nn-5 )z( nn-7 ) )return b1 = z( nn-5 ) / z( nn-7 ) @@ -6876,7 +6878,7 @@ module stdlib_linalg_lapack_d 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 ) ) @@ -6885,19 +6887,19 @@ module stdlib_linalg_lapack_d 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. s = zero - ttype = -12 + ttype = -12_${ik}$ end if tau = s return - end subroutine stdlib_dlasq4 + end subroutine stdlib${ii}$_dlasq4 - pure subroutine stdlib_dlasq5( i0, n0, z, pp, tau, sigma, dmin, dmin1, dmin2,dn, dnm1, dnm2, & + pure subroutine stdlib${ii}$_dlasq5( i0, n0, z, pp, tau, sigma, dmin, dmin1, dmin2,dn, dnm1, dnm2, & !! DLASQ5 computes one dqds transform in ping-pong form, one !! version for IEEE machines another for non IEEE machines. ieee, eps ) @@ -6906,7 +6908,7 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(out) :: dmin, dmin1, dmin2, dn, dnm1, dnm2 real(dp), intent(inout) :: tau real(dp), intent(in) :: sigma, eps @@ -6915,7 +6917,7 @@ module stdlib_linalg_lapack_d ! ===================================================================== ! Local Scalars - integer(ilp) :: j4, j4p2 + integer(${ik}$) :: j4, j4p2 real(dp) :: d, emin, temp, dthresh ! Intrinsic Functions intrinsic :: min @@ -6924,14 +6926,14 @@ module stdlib_linalg_lapack_d 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 @@ -7578,7 +7580,7 @@ module stdlib_linalg_lapack_d ! choose partition entry as median of 3 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_dlasrt + end subroutine stdlib${ii}$_dlasrt - pure subroutine stdlib_dlassq( n, x, incx, scl, sumsq ) + pure subroutine stdlib${ii}$_dlassq( n, x, incx, scl, sumsq ) !! DLASSQ returns the values scl and smsq such that !! ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, !! where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is @@ -7691,12 +7693,12 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: scl, sumsq ! 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, ymax, ymin ! quick return if possible @@ -7706,7 +7708,7 @@ module stdlib_linalg_lapack_d 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: @@ -7720,17 +7722,17 @@ module stdlib_linalg_lapack_d 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 @@ -7739,12 +7741,12 @@ module stdlib_linalg_lapack_d 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 @@ -7769,7 +7771,7 @@ module stdlib_linalg_lapack_d 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 @@ -7780,10 +7782,10 @@ module stdlib_linalg_lapack_d sumsq = amed end if return - end subroutine stdlib_dlassq + end subroutine stdlib${ii}$_dlassq - pure subroutine stdlib_dlasv2( f, g, h, ssmin, ssmax, snr, csr, snl, csl ) + pure subroutine stdlib${ii}$_dlasv2( f, g, h, ssmin, ssmax, snr, csr, snl, csl ) !! DLASV2 computes the singular value decomposition of a 2-by-2 !! triangular matrix !! [ F G ] @@ -7807,7 +7809,7 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: gasmal, swap - integer(ilp) :: pmax + integer(${ik}$) :: pmax real(dp) :: a, clt, crt, d, fa, ft, ga, gt, ha, ht, l, m, mm, r, s, slt, srt, t, temp, & tsign, tt ! Intrinsic Functions @@ -7821,10 +7823,10 @@ module stdlib_linalg_lapack_d ! 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}$ swap = ( ha>fa ) if( swap ) then - pmax = 3 + pmax = 3_${ik}$ temp = ft ft = ht ht = temp @@ -7846,8 +7848,8 @@ module stdlib_linalg_lapack_d 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 @@ -7977,7 +7979,7 @@ module stdlib_linalg_lapack_d 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 ) @@ -7992,10 +7994,10 @@ module stdlib_linalg_lapack_d end do end if return - end subroutine stdlib_dlaswp + end subroutine stdlib${ii}$_dlaswp - pure subroutine stdlib_dlasy2( ltranl, ltranr, isgn, n1, n2, tl, ldtl, tr,ldtr, b, ldb, & + pure subroutine stdlib${ii}$_dlasy2( ltranl, ltranr, isgn, n1, n2, tl, ldtl, tr,ldtr, b, ldb, & !! DLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in !! op(TL)*X + ISGN*X*op(TR) = SCALE*B, !! where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or @@ -8006,8 +8008,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(out) :: scale, xnorm ! Array Arguments real(dp), intent(in) :: b(ldb,*), tl(ldtl,*), tr(ldtr,*) @@ -8017,89 +8019,89 @@ module stdlib_linalg_lapack_d ! 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(dp) :: 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(dp) :: 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(dp) :: 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_dlamch( 'P' ) - smlnum = stdlib_dlamch( 'S' ) / eps + eps = stdlib${ii}$_dlamch( 'P' ) + smlnum = stdlib${ii}$_dlamch( '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 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: ! 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: ! 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. ! set pivots less than smin to smin. - ipiv = stdlib_idamax( 4, tmp, 1 ) + ipiv = stdlib${ii}$_idamax( 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 ) ) @@ -8108,37 +8110,37 @@ module stdlib_linalg_lapack_d 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: @@ -8147,43 +8149,43 @@ module stdlib_linalg_lapack_d ! solve equivalent 4 by 4 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_dcopy( 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}$_dcopy( 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 @@ -8197,15 +8199,15 @@ module stdlib_linalg_lapack_d end do end do if( ipsv/=i ) then - call stdlib_dswap( 4, t16( ipsv, 1 ), 4, t16( i, 1 ), 4 ) + call stdlib${ii}$_dswap( 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_dswap( 4, t16( 1, jpsv ), 1, t16( 1, i ), 1 ) + if( jpsv/=i )call stdlib${ii}$_dswap( 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 @@ -8240,22 +8242,22 @@ module stdlib_linalg_lapack_d 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_dlasy2 + end subroutine stdlib${ii}$_dlasy2 - pure subroutine stdlib_dlasyf( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) + pure subroutine stdlib${ii}$_dlasyf( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) !! DLASYF computes a partial factorization of a real symmetric matrix A !! using the Bunch-Kaufman diagonal pivoting method. The partial !! factorization has the form: @@ -8273,10 +8275,10 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: w(ldw,*) ! ===================================================================== @@ -8285,12 +8287,12 @@ module stdlib_linalg_lapack_d ! 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(dp) :: 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 @@ -8305,25 +8307,25 @@ module stdlib_linalg_lapack_d ! exit from loop if( ( k<=n-nb+1 .and. nb1 ) then - imax = stdlib_idamax( k-1, w( 1, kw ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_idamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) colmax = abs( w( imax, kw ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k else if( absakk>=alpha*colmax ) then @@ -8331,17 +8333,17 @@ module stdlib_linalg_lapack_d kp = k else ! copy column imax to column kw-1 of w and update it - call stdlib_dcopy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) - call stdlib_dcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_dcopy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) + call stdlib${ii}$_dcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ ) - if( k1 ) then - jmax = stdlib_idamax( imax-1, w( 1, kw-1 ), 1 ) + if( imax>1_${ik}$ ) then + jmax = stdlib${ii}$_idamax( 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 @@ -8352,17 +8354,17 @@ module stdlib_linalg_lapack_d ! pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_dcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_dcopy( 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 ! 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. @@ -8373,16 +8375,16 @@ module stdlib_linalg_lapack_d ! (or k and k-1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = a( kk, kk ) - call stdlib_dcopy( kk-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - if( kp>1 )call stdlib_dcopy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_dcopy( kk-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_dcopy( 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 ! later overwritten). interchange rows kk and kp ! in last kkw to nb columns of w. - if( k2 ) then + if( k>2_${ik}$ ) then ! compose the columns of the inverse of 2-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 @@ -8445,7 +8447,7 @@ module stdlib_linalg_lapack_d 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 @@ -8462,31 +8464,31 @@ module stdlib_linalg_lapack_d jb = min( nb, k-j+1 ) ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_dgemv( '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}$_dgemv( 'NO TRANSPOSE', jj-j+1, n-k, -one,a( j, k+1 ), lda, w( jj, & + kw+1 ), ldw, one,a( j, jj ), 1_${ik}$ ) end do ! update the rectangular superdiagonal block - call stdlib_dgemm( '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}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k, -one,a( 1_${ik}$, k+1 ), & + lda, w( j, kw+1 ), ldw, one,a( 1_${ik}$, j ), lda ) end do ! put u12 in standard form by partially undoing the interchanges ! in columns k+1:n 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_dswap( n-j+1, a( jp, j ), lda, a( jj, j ), & + j = j + 1_${ik}$ + if( jp/=jj .and. j<=n )call stdlib${ii}$_dswap( 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_dcopy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) - call stdlib_dgemv( '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}$_dcopy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ ) + call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1_${ik}$ ), lda,w( k, 1_${ik}$ ), ldw, & + one, w( k, k ), 1_${ik}$ ) + 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 absakk = abs( w( k, k ) ) @@ -8512,14 +8514,14 @@ module stdlib_linalg_lapack_d ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k=alpha*colmax ) then @@ -8527,16 +8529,16 @@ module stdlib_linalg_lapack_d kp = k else ! copy column imax to column k+1 of w and update it - call stdlib_dcopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1 ) - call stdlib_dcopy( n-imax+1, a( imax, imax ), 1, w( imax, k+1 ),1 ) - call stdlib_dgemv( '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}$_dcopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$ ) + call stdlib${ii}$_dcopy( n-imax+1, a( imax, imax ), 1_${ik}$, w( imax, k+1 ),1_${ik}$ ) + call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1_${ik}$ ),lda, w( imax, & + 1_${ik}$ ), ldw, one, w( k, k+1 ), 1_${ik}$ ) ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value - jmax = k - 1 + stdlib_idamax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1_${ik}$ + stdlib${ii}$_idamax( imax-k, w( k, k+1 ), 1_${ik}$ ) rowmax = abs( w( jmax, k+1 ) ) if( imax=alpha*colmax*( colmax / rowmax ) ) then @@ -8547,17 +8549,17 @@ module stdlib_linalg_lapack_d ! pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_dcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_dcopy( 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 ! 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 @@ -8566,17 +8568,17 @@ module stdlib_linalg_lapack_d ! (or k and k+1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = a( kk, kk ) - call stdlib_dcopy( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),lda ) - if( kp1 )call stdlib_dswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_dswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + if( k>1_${ik}$ )call stdlib${ii}$_dswap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) + call stdlib${ii}$_dswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of w now holds ! w(k) = l(k)*d(k), ! where l(k) is the k-th column of l @@ -8586,10 +8588,10 @@ module stdlib_linalg_lapack_d ! 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_dcopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib${ii}$_dcopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ ) if( k=1 )call stdlib_dswap( j, a( jp, 1 ), lda, a( jj, 1 ), lda ) + j = j - 1_${ik}$ + if( jp/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_dswap( 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_dlasyf + end subroutine stdlib${ii}$_dlasyf - pure subroutine stdlib_dlasyf_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info ) + pure subroutine stdlib${ii}$_dlasyf_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info ) !! DLASYF_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: @@ -8710,10 +8712,10 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: e(*), w(ldw,*) ! ===================================================================== @@ -8723,24 +8725,24 @@ module stdlib_linalg_lapack_d ! 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(dp) :: absakk, alpha, colmax, d11, d12, d21, d22, dtemp, 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_dlamch( 'S' ) + sfmin = stdlib${ii}$_dlamch( 'S' ) if( stdlib_lsame( uplo, 'U' ) ) then ! factorize the trailing columns of a using the upper triangle ! of a and working backwards, and compute the matrix w = u12*d ! for use in updating a11 ! initialize the first entry of array e, where superdiagonal ! elements of d are stored - e( 1 ) = zero + e( 1_${ik}$ ) = zero ! k is the main loop index, decreasing from n in steps of 1 or 2 k = n 10 continue @@ -8748,31 +8750,31 @@ module stdlib_linalg_lapack_d kw = nb + k - n ! exit from loop if( ( k<=n-nb+1 .and. nb1 ) then - imax = stdlib_idamax( k-1, w( 1, kw ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_idamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) colmax = abs( w( imax, kw ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k - call stdlib_dcopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) + call stdlib${ii}$_dcopy( 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 @@ -8787,22 +8789,22 @@ module stdlib_linalg_lapack_d 12 continue ! begin pivot search loop body ! copy column imax to column kw-1 of w and update it - call stdlib_dcopy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) - call stdlib_dcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_dcopy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) + call stdlib${ii}$_dcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ ) - if( k1 ) then - itemp = stdlib_idamax( imax-1, w( 1, kw-1 ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_idamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) dtemp = abs( w( itemp, kw-1 ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -8817,7 +8819,7 @@ module stdlib_linalg_lapack_d ! use 1-by-1 pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_dcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_dcopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -8825,7 +8827,7 @@ module stdlib_linalg_lapack_d ! interchange rows and columns k-1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found: set params and repeat @@ -8833,45 +8835,45 @@ module stdlib_linalg_lapack_d colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_dcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_dcopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) end if ! end pivot search loop body if( .not. done ) goto 12 end if ! ============================================================ - kk = k - kstep + 1 + kk = k - kstep + 1_${ik}$ ! kkw is the column of w which corresponds to column kk of a kkw = nb + kk - n - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_dcopy( k-p, a( p+1, k ), 1, a( p, p+1 ), lda ) - call stdlib_dcopy( p, a( 1, k ), 1, a( 1, p ), 1 ) + call stdlib${ii}$_dcopy( k-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ), lda ) + call stdlib${ii}$_dcopy( p, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) ! interchange rows k and p in last n-k+1 columns of a ! and last n-k+2 columns of w - call stdlib_dswap( n-k+1, a( k, k ), lda, a( p, k ), lda ) - call stdlib_dswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw ) + call stdlib${ii}$_dswap( n-k+1, a( k, k ), lda, a( p, k ), lda ) + call stdlib${ii}$_dswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw ) end if ! updated column kp is already stored in column kkw of w if( kp/=kk ) then ! copy non-updated column kk to column kp a( kp, k ) = a( kk, k ) - call stdlib_dcopy( k-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - call stdlib_dcopy( kp, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_dcopy( k-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) + call stdlib${ii}$_dcopy( kp, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) ! interchange rows kk and kp in last n-kk+1 columns ! of a and w - call stdlib_dswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) - call stdlib_dswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) + call stdlib${ii}$_dswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) + call stdlib${ii}$_dswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column kw of w now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u ! store u(k) in column k of a - call stdlib_dcopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) - if( k>1 ) then + call stdlib${ii}$_dcopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) + if( k>1_${ik}$ ) then if( abs( a( k, k ) )>=sfmin ) then r1 = one / a( k, k ) - call stdlib_dscal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_dscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) else if( a( k, k )/=zero ) then do ii = 1, k - 1 a( ii, k ) = a( ii, k ) / a( k, k ) @@ -8886,7 +8888,7 @@ module stdlib_linalg_lapack_d ! ( 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 @@ -8909,7 +8911,7 @@ module stdlib_linalg_lapack_d ! 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 @@ -8926,12 +8928,12 @@ module stdlib_linalg_lapack_d jb = min( nb, k-j+1 ) ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_dgemv( '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}$_dgemv( 'NO TRANSPOSE', jj-j+1, n-k, -one,a( j, k+1 ), lda, w( jj, & + kw+1 ), ldw, one,a( j, jj ), 1_${ik}$ ) end do ! update the rectangular superdiagonal block - if( j>=2 )call stdlib_dgemm( '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}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -one, a( & + 1_${ik}$, k+1 ), lda, w( j, kw+1 ),ldw, one, a( 1_${ik}$, j ), lda ) end do ! set kb to the number of columns factorized kb = n - k @@ -8942,16 +8944,16 @@ module stdlib_linalg_lapack_d ! 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 = 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_dcopy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) - if( k>1 )call stdlib_dgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1 ),lda, w( k, & - 1 ), ldw, one, w( k, k ), 1 ) + call stdlib${ii}$_dcopy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ ) + if( k>1_${ik}$ )call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1_${ik}$ ),lda, w( k, & + 1_${ik}$ ), ldw, one, w( k, k ), 1_${ik}$ ) ! determine rows and columns to be interchanged and whether ! a 1-by-1 or 2-by-2 pivot block will be used absakk = abs( w( k, k ) ) @@ -8959,16 +8961,16 @@ module stdlib_linalg_lapack_d ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k1 )call stdlib_dgemv( '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}$_dcopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$) + call stdlib${ii}$_dcopy( n-imax+1, a( imax, imax ), 1_${ik}$,w( imax, k+1 ), 1_${ik}$ ) + if( k>1_${ik}$ )call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n-k+1, k-1, -one,a( k, 1_${ik}$ ), & + lda, w( imax, 1_${ik}$ ), ldw,one, w( k, k+1 ), 1_${ik}$ ) ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = k - 1 + stdlib_idamax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1_${ik}$ + stdlib${ii}$_idamax( imax-k, w( k, k+1 ), 1_${ik}$ ) rowmax = abs( w( jmax, k+1 ) ) else rowmax = zero end if if( imaxrowmax ) then rowmax = dtemp @@ -9014,7 +9016,7 @@ module stdlib_linalg_lapack_d ! use 1-by-1 pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_dcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_dcopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -9022,7 +9024,7 @@ module stdlib_linalg_lapack_d ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found: set params and repeat @@ -9030,42 +9032,42 @@ module stdlib_linalg_lapack_d colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_dcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_dcopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) end if ! end pivot search loop body if( .not. done ) goto 72 end if ! ============================================================ - kk = k + kstep - 1 - if( ( kstep==2 ) .and. ( p/=k ) ) then + kk = k + kstep - 1_${ik}$ + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_dcopy( p-k, a( k, k ), 1, a( p, k ), lda ) - call stdlib_dcopy( n-p+1, a( p, k ), 1, a( p, p ), 1 ) + call stdlib${ii}$_dcopy( p-k, a( k, k ), 1_${ik}$, a( p, k ), lda ) + call stdlib${ii}$_dcopy( n-p+1, a( p, k ), 1_${ik}$, a( p, p ), 1_${ik}$ ) ! interchange rows k and p in first k columns of a ! and first k+1 columns of w - call stdlib_dswap( k, a( k, 1 ), lda, a( p, 1 ), lda ) - call stdlib_dswap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw ) + call stdlib${ii}$_dswap( k, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda ) + call stdlib${ii}$_dswap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw ) end if ! updated column kp is already stored in column kk of w if( kp/=kk ) then ! copy non-updated column kk to column kp a( kp, k ) = a( kk, k ) - call stdlib_dcopy( kp-k-1, a( k+1, kk ), 1, a( kp, k+1 ), lda ) - call stdlib_dcopy( n-kp+1, a( kp, kk ), 1, a( kp, kp ), 1 ) + call stdlib${ii}$_dcopy( kp-k-1, a( k+1, kk ), 1_${ik}$, a( kp, k+1 ), lda ) + call stdlib${ii}$_dcopy( n-kp+1, a( kp, kk ), 1_${ik}$, a( kp, kp ), 1_${ik}$ ) ! interchange rows kk and kp in first kk columns of a and w - call stdlib_dswap( kk, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_dswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + call stdlib${ii}$_dswap( kk, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) + call stdlib${ii}$_dswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of w now holds ! w(k) = l(k)*d(k) ! where l(k) is the k-th column of l ! store l(k) in column k of a - call stdlib_dcopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib${ii}$_dcopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ ) if( k=sfmin ) then r1 = one / a( k, k ) - call stdlib_dscal( n-k, r1, a( k+1, k ), 1 ) + call stdlib${ii}$_dscal( n-k, r1, a( k+1, k ), 1_${ik}$ ) else if( a( k, k )/=zero ) then do ii = k + 1, n a( ii, k ) = a( ii, k ) / a( k, k ) @@ -9102,7 +9104,7 @@ module stdlib_linalg_lapack_d ! 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 @@ -9119,21 +9121,21 @@ module stdlib_linalg_lapack_d jb = min( nb, n-j+1 ) ! update the lower triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_dgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -one,a( jj, 1 ), lda, w( jj, & - 1 ), ldw, one,a( jj, jj ), 1 ) + call stdlib${ii}$_dgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -one,a( jj, 1_${ik}$ ), lda, w( jj, & + 1_${ik}$ ), ldw, one,a( jj, jj ), 1_${ik}$ ) end do ! update the rectangular subdiagonal block - if( j+jb<=n )call stdlib_dgemm( '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}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& + one, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ),ldw, one, a( j+jb, j ), lda ) end do ! set kb to the number of columns factorized - kb = k - 1 + kb = k - 1_${ik}$ end if return - end subroutine stdlib_dlasyf_rk + end subroutine stdlib${ii}$_dlasyf_rk - pure subroutine stdlib_dlasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) + pure subroutine stdlib${ii}$_dlasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) !! DLASYF_ROOK computes a partial factorization of a real symmetric !! matrix A using the bounded Bunch-Kaufman ("rook") diagonal !! pivoting method. The partial factorization has the form: @@ -9151,10 +9153,10 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: w(ldw,*) ! ===================================================================== @@ -9164,18 +9166,18 @@ module stdlib_linalg_lapack_d ! 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(dp) :: absakk, alpha, colmax, d11, d12, d21, d22, dtemp, 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_dlamch( 'S' ) + sfmin = stdlib${ii}$_dlamch( 'S' ) if( stdlib_lsame( uplo, 'U' ) ) then ! factorize the trailing columns of a using the upper triangle ! of a and working backwards, and compute the matrix w = u12*d @@ -9187,29 +9189,29 @@ module stdlib_linalg_lapack_d kw = nb + k - n ! exit from loop if( ( k<=n-nb+1 .and. nb1 ) then - imax = stdlib_idamax( k-1, w( 1, kw ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_idamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) colmax = abs( w( imax, kw ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k - call stdlib_dcopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) + call stdlib${ii}$_dcopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) else ! ============================================================ ! test for interchange @@ -9224,22 +9226,22 @@ module stdlib_linalg_lapack_d 12 continue ! begin pivot search loop body ! copy column imax to column kw-1 of w and update it - call stdlib_dcopy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) - call stdlib_dcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_dcopy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) + call stdlib${ii}$_dcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ ) - if( k1 ) then - itemp = stdlib_idamax( imax-1, w( 1, kw-1 ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_idamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) dtemp = abs( w( itemp, kw-1 ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -9254,7 +9256,7 @@ module stdlib_linalg_lapack_d ! use 1-by-1 pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_dcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_dcopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -9262,7 +9264,7 @@ module stdlib_linalg_lapack_d ! interchange rows and columns k-1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found: set params and repeat @@ -9270,45 +9272,45 @@ module stdlib_linalg_lapack_d colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_dcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_dcopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) end if ! end pivot search loop body if( .not. done ) goto 12 end if ! ============================================================ - kk = k - kstep + 1 + kk = k - kstep + 1_${ik}$ ! kkw is the column of w which corresponds to column kk of a kkw = nb + kk - n - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_dcopy( k-p, a( p+1, k ), 1, a( p, p+1 ), lda ) - call stdlib_dcopy( p, a( 1, k ), 1, a( 1, p ), 1 ) + call stdlib${ii}$_dcopy( k-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ), lda ) + call stdlib${ii}$_dcopy( p, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) ! interchange rows k and p in last n-k+1 columns of a ! and last n-k+2 columns of w - call stdlib_dswap( n-k+1, a( k, k ), lda, a( p, k ), lda ) - call stdlib_dswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw ) + call stdlib${ii}$_dswap( n-k+1, a( k, k ), lda, a( p, k ), lda ) + call stdlib${ii}$_dswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw ) end if ! updated column kp is already stored in column kkw of w if( kp/=kk ) then ! copy non-updated column kk to column kp a( kp, k ) = a( kk, k ) - call stdlib_dcopy( k-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - call stdlib_dcopy( kp, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_dcopy( k-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) + call stdlib${ii}$_dcopy( kp, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) ! interchange rows kk and kp in last n-kk+1 columns ! of a and w - call stdlib_dswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) - call stdlib_dswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) + call stdlib${ii}$_dswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) + call stdlib${ii}$_dswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column kw of w now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u ! store u(k) in column k of a - call stdlib_dcopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) - if( k>1 ) then + call stdlib${ii}$_dcopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) + if( k>1_${ik}$ ) then if( abs( a( k, k ) )>=sfmin ) then r1 = one / a( k, k ) - call stdlib_dscal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_dscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) else if( a( k, k )/=zero ) then do ii = 1, k - 1 a( ii, k ) = a( ii, k ) / a( k, k ) @@ -9321,7 +9323,7 @@ module stdlib_linalg_lapack_d ! ( 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 @@ -9339,7 +9341,7 @@ module stdlib_linalg_lapack_d 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 @@ -9356,32 +9358,32 @@ module stdlib_linalg_lapack_d jb = min( nb, k-j+1 ) ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_dgemv( '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}$_dgemv( 'NO TRANSPOSE', jj-j+1, n-k, -one,a( j, k+1 ), lda, w( jj, & + kw+1 ), ldw, one,a( j, jj ), 1_${ik}$ ) end do ! update the rectangular superdiagonal block - if( j>=2 )call stdlib_dgemm( '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}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -one, a( & + 1_${ik}$, k+1 ), lda, w( j, kw+1 ), ldw,one, a( 1_${ik}$, j ), lda ) end do ! put u12 in standard form by partially undoing the interchanges ! in columns k+1:n - j = k + 1 + 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_dswap( n-j+1, a( jp2, j ), lda, a( jj, j ), & + j = j + 1_${ik}$ + if( jp2/=jj .and. j<=n )call stdlib${ii}$_dswap( n-j+1, a( jp2, j ), lda, a( jj, j ), & lda ) - jj = j - 1 - if( jp1/=jj .and. kstep==2 )call stdlib_dswap( n-j+1, a( jp1, j ), lda, a( jj, j & + jj = j - 1_${ik}$ + if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_dswap( n-j+1, a( jp1, j ), lda, a( jj, j & ), lda ) if( j<=n )go to 60 ! set kb to the number of columns factorized @@ -9391,16 +9393,16 @@ module stdlib_linalg_lapack_d ! 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 = 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_dcopy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) - if( k>1 )call stdlib_dgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1 ),lda, w( k, & - 1 ), ldw, one, w( k, k ), 1 ) + call stdlib${ii}$_dcopy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ ) + if( k>1_${ik}$ )call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n-k+1, k-1, -one, a( k, 1_${ik}$ ),lda, w( k, & + 1_${ik}$ ), ldw, one, w( k, k ), 1_${ik}$ ) ! determine rows and columns to be interchanged and whether ! a 1-by-1 or 2-by-2 pivot block will be used absakk = abs( w( k, k ) ) @@ -9408,16 +9410,16 @@ module stdlib_linalg_lapack_d ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k1 )call stdlib_dgemv( '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}$_dcopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$) + call stdlib${ii}$_dcopy( n-imax+1, a( imax, imax ), 1_${ik}$,w( imax, k+1 ), 1_${ik}$ ) + if( k>1_${ik}$ )call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n-k+1, k-1, -one,a( k, 1_${ik}$ ), & + lda, w( imax, 1_${ik}$ ), ldw,one, w( k, k+1 ), 1_${ik}$ ) ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = k - 1 + stdlib_idamax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1_${ik}$ + stdlib${ii}$_idamax( imax-k, w( k, k+1 ), 1_${ik}$ ) rowmax = abs( w( jmax, k+1 ) ) else rowmax = zero end if if( imaxrowmax ) then rowmax = dtemp @@ -9461,7 +9463,7 @@ module stdlib_linalg_lapack_d ! use 1-by-1 pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_dcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_dcopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -9469,7 +9471,7 @@ module stdlib_linalg_lapack_d ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found: set params and repeat @@ -9477,42 +9479,42 @@ module stdlib_linalg_lapack_d colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_dcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_dcopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) end if ! end pivot search loop body if( .not. done ) goto 72 end if ! ============================================================ - kk = k + kstep - 1 - if( ( kstep==2 ) .and. ( p/=k ) ) then + kk = k + kstep - 1_${ik}$ + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_dcopy( p-k, a( k, k ), 1, a( p, k ), lda ) - call stdlib_dcopy( n-p+1, a( p, k ), 1, a( p, p ), 1 ) + call stdlib${ii}$_dcopy( p-k, a( k, k ), 1_${ik}$, a( p, k ), lda ) + call stdlib${ii}$_dcopy( n-p+1, a( p, k ), 1_${ik}$, a( p, p ), 1_${ik}$ ) ! interchange rows k and p in first k columns of a ! and first k+1 columns of w - call stdlib_dswap( k, a( k, 1 ), lda, a( p, 1 ), lda ) - call stdlib_dswap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw ) + call stdlib${ii}$_dswap( k, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda ) + call stdlib${ii}$_dswap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw ) end if ! updated column kp is already stored in column kk of w if( kp/=kk ) then ! copy non-updated column kk to column kp a( kp, k ) = a( kk, k ) - call stdlib_dcopy( kp-k-1, a( k+1, kk ), 1, a( kp, k+1 ), lda ) - call stdlib_dcopy( n-kp+1, a( kp, kk ), 1, a( kp, kp ), 1 ) + call stdlib${ii}$_dcopy( kp-k-1, a( k+1, kk ), 1_${ik}$, a( kp, k+1 ), lda ) + call stdlib${ii}$_dcopy( n-kp+1, a( kp, kk ), 1_${ik}$, a( kp, kp ), 1_${ik}$ ) ! interchange rows kk and kp in first kk columns of a and w - call stdlib_dswap( kk, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_dswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + call stdlib${ii}$_dswap( kk, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) + call stdlib${ii}$_dswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of w now holds ! w(k) = l(k)*d(k) ! where l(k) is the k-th column of l ! store l(k) in column k of a - call stdlib_dcopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib${ii}$_dcopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ ) if( k=sfmin ) then r1 = one / a( k, k ) - call stdlib_dscal( n-k, r1, a( k+1, k ), 1 ) + call stdlib${ii}$_dscal( n-k, r1, a( k+1, k ), 1_${ik}$ ) else if( a( k, k )/=zero ) then do ii = k + 1, n a( ii, k ) = a( ii, k ) / a( k, k ) @@ -9542,7 +9544,7 @@ module stdlib_linalg_lapack_d 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 @@ -9559,42 +9561,42 @@ module stdlib_linalg_lapack_d jb = min( nb, n-j+1 ) ! update the lower triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_dgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -one,a( jj, 1 ), lda, w( jj, & - 1 ), ldw, one,a( jj, jj ), 1 ) + call stdlib${ii}$_dgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -one,a( jj, 1_${ik}$ ), lda, w( jj, & + 1_${ik}$ ), ldw, one,a( jj, jj ), 1_${ik}$ ) end do ! update the rectangular subdiagonal block - if( j+jb<=n )call stdlib_dgemm( '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}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& + one, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ), ldw,one, a( j+jb, j ), lda ) end do ! put l21 in standard form by partially undoing the interchanges ! in columns 1:k-1 - j = k - 1 + 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_dswap( j, a( jp2, 1 ), lda, a( jj, 1 ), lda ) + j = j - 1_${ik}$ + if( jp2/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_dswap( j, a( jp2, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda ) - jj = j + 1 - if( jp1/=jj .and. kstep==2 )call stdlib_dswap( j, a( jp1, 1 ), lda, a( jj, 1 ), & + jj = j + 1_${ik}$ + if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_dswap( j, a( jp1, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), & lda ) if( j>=1 )go to 120 ! set kb to the number of columns factorized - kb = k - 1 + kb = k - 1_${ik}$ end if return - end subroutine stdlib_dlasyf_rook + end subroutine stdlib${ii}$_dlasyf_rook - pure subroutine stdlib_dlat2s( uplo, n, a, lda, sa, ldsa, info ) + pure subroutine stdlib${ii}$_dlat2s( uplo, n, a, lda, sa, ldsa, info ) !! DLAT2S converts a DOUBLE PRECISION triangular matrix, SA, to a SINGLE !! PRECISION triangular matrix, A. !! RMAX is the overflow for the SINGLE PRECISION arithmetic @@ -9606,24 +9608,24 @@ module stdlib_linalg_lapack_d ! -- 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, ldsa, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldsa, n ! Array Arguments real(sp), intent(out) :: sa(ldsa,*) real(dp), intent(in) :: a(lda,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: rmax logical(lk) :: upper ! Executable Statements - rmax = stdlib_slamch( 'O' ) + rmax = stdlib${ii}$_slamch( 'O' ) upper = stdlib_lsame( uplo, 'U' ) if( upper ) then do j = 1, n do i = 1, j if( ( a( i, j )<-rmax ) .or. ( a( i, j )>rmax ) )then - info = 1 + info = 1_${ik}$ go to 50 end if sa( i, j ) = a( i, j ) @@ -9633,7 +9635,7 @@ module stdlib_linalg_lapack_d do j = 1, n do i = j, n if( ( a( i, j )<-rmax ) .or. ( a( i, j )>rmax ) )then - info = 1 + info = 1_${ik}$ go to 50 end if sa( i, j ) = a( i, j ) @@ -9642,10 +9644,10 @@ module stdlib_linalg_lapack_d end if 50 continue return - end subroutine stdlib_dlat2s + end subroutine stdlib${ii}$_dlat2s - pure subroutine stdlib_dlatbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm, & + pure subroutine stdlib${ii}$_dlatbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm, & !! DLATBS solves one of the triangular systems !! A *x = s*b or A**T*x = s*b !! with scaling to prevent overflow, where A is an upper or lower @@ -9662,8 +9664,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(out) :: scale ! Array Arguments real(dp), intent(in) :: ab(ldab,*) @@ -9672,42 +9674,42 @@ module stdlib_linalg_lapack_d ! 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(dp) :: 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_dasum( jlen, ab( 2, j ), 1 ) + if( jlen>0_${ik}$ ) then + cnorm( j ) = stdlib${ii}$_dasum( jlen, ab( 2_${ik}$, j ), 1_${ik}$ ) else cnorm( j ) = zero end if @@ -9732,31 +9734,31 @@ module stdlib_linalg_lapack_d end if ! scale the column norms by tscal if the maximum element in cnorm is ! greater than bignum. - imax = stdlib_idamax( n, cnorm, 1 ) + imax = stdlib${ii}$_idamax( n, cnorm, 1_${ik}$ ) tmax = cnorm( imax ) if( tmax<=bignum ) then tscal = one else tscal = one / ( smlnum*tmax ) - call stdlib_dscal( n, tscal, cnorm, 1 ) + call stdlib${ii}$_dscal( n, tscal, cnorm, 1_${ik}$ ) end if ! compute a bound on the computed solution vector to see if the - ! level 2 blas routine stdlib_dtbsv can be used. - j = stdlib_idamax( n, x, 1 ) + ! level 2 blas routine stdlib${ii}$_dtbsv can be used. + j = stdlib${ii}$_idamax( 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 @@ -9798,15 +9800,15 @@ module stdlib_linalg_lapack_d 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 @@ -9846,14 +9848,14 @@ module stdlib_linalg_lapack_d if( ( grow*tscal )>smlnum ) then ! use the level 2 blas solve if the reciprocal of the bound on ! elements of x is not too small. - call stdlib_dtbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1 ) + call stdlib${ii}$_dtbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1_${ik}$ ) else ! use a level 1 blas solve, scaling intermediate results. if( xmax>bignum ) then ! scale x so that its components are less than or equal to ! bignum in absolute value. scale = bignum / xmax - call stdlib_dscal( n, scale, x, 1 ) + call stdlib${ii}$_dscal( n, scale, x, 1_${ik}$ ) xmax = bignum end if if( notran ) then @@ -9874,7 +9876,7 @@ module stdlib_linalg_lapack_d if( xj>tjj*bignum ) then ! scale x by 1/b(j). rec = one / xj - call stdlib_dscal( n, rec, x, 1 ) + call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if @@ -9892,7 +9894,7 @@ module stdlib_linalg_lapack_d ! multiplying x(j) times column j. rec = rec / cnorm( j ) end if - call stdlib_dscal( n, rec, x, 1 ) + call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if @@ -9917,23 +9919,23 @@ module stdlib_linalg_lapack_d if( cnorm( j )>( bignum-xmax )*rec ) then ! scale x by 1/(2*abs(x(j))). rec = rec*half - call stdlib_dscal( n, rec, x, 1 ) + call stdlib${ii}$_dscal( 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_dscal( n, half, x, 1 ) + call stdlib${ii}$_dscal( 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) jlen = min( kd, j-1 ) - call stdlib_daxpy( jlen, -x( j )*tscal,ab( kd+1-jlen, j ), 1, x( j-jlen & - ), 1 ) - i = stdlib_idamax( j-1, x, 1 ) + call stdlib${ii}$_daxpy( jlen, -x( j )*tscal,ab( kd+1-jlen, j ), 1_${ik}$, x( j-jlen & + ), 1_${ik}$ ) + i = stdlib${ii}$_idamax( j-1, x, 1_${ik}$ ) xmax = abs( x( i ) ) end if else if( j0 )call stdlib_daxpy( jlen, -x( j )*tscal, ab( 2, j ), 1,x( j+1 ),& - 1 ) - i = j + stdlib_idamax( n-j, x( j+1 ), 1 ) + if( jlen>0_${ik}$ )call stdlib${ii}$_daxpy( jlen, -x( j )*tscal, ab( 2_${ik}$, j ), 1_${ik}$,x( j+1 ),& + 1_${ik}$ ) + i = j + stdlib${ii}$_idamax( n-j, x( j+1 ), 1_${ik}$ ) xmax = abs( x( i ) ) end if end do loop_110 @@ -9970,7 +9972,7 @@ module stdlib_linalg_lapack_d uscal = uscal / tjjs end if if( rec0 )sumj = stdlib_ddot( jlen, ab( 2, j ), 1, x( j+1 ), 1 ) + if( jlen>0_${ik}$ )sumj = stdlib${ii}$_ddot( jlen, ab( 2_${ik}$, j ), 1_${ik}$, x( j+1 ), 1_${ik}$ ) end if else @@ -10020,7 +10022,7 @@ module stdlib_linalg_lapack_d if( xj>tjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_dscal( n, rec, x, 1 ) + call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if @@ -10031,7 +10033,7 @@ module stdlib_linalg_lapack_d if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_dscal( n, rec, x, 1 ) + call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if @@ -10059,13 +10061,13 @@ module stdlib_linalg_lapack_d end if ! scale the column norms by 1/tscal for return. if( tscal/=one ) then - call stdlib_dscal( n, one / tscal, cnorm, 1 ) + call stdlib${ii}$_dscal( n, one / tscal, cnorm, 1_${ik}$ ) end if return - end subroutine stdlib_dlatbs + end subroutine stdlib${ii}$_dlatbs - pure subroutine stdlib_dlatps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info ) + pure subroutine stdlib${ii}$_dlatps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info ) !! DLATPS solves one of the triangular systems !! A *x = s*b or A**T*x = s*b !! with scaling to prevent overflow, where A is an upper or lower @@ -10082,8 +10084,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(out) :: scale ! Array Arguments real(dp), intent(in) :: ap(*) @@ -10092,84 +10094,84 @@ module stdlib_linalg_lapack_d ! 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(dp) :: 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( 'DLATPS', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DLATPS', -info ) return end if ! quick return if possible if( n==0 )return ! determine machine dependent parameters to control overflow. - smlnum = stdlib_dlamch( 'SAFE MINIMUM' ) / stdlib_dlamch( 'PRECISION' ) + smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' ) bignum = one / smlnum scale = one if( stdlib_lsame( normin, 'N' ) ) then ! compute the 1-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_dasum( j-1, ap( ip ), 1 ) + cnorm( j ) = stdlib${ii}$_dasum( 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_dasum( n-j, ap( ip+1 ), 1 ) - ip = ip + n - j + 1 + cnorm( j ) = stdlib${ii}$_dasum( 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_idamax( n, cnorm, 1 ) + imax = stdlib${ii}$_idamax( n, cnorm, 1_${ik}$ ) tmax = cnorm( imax ) if( tmax<=bignum ) then tscal = one else tscal = one / ( smlnum*tmax ) - call stdlib_dscal( n, tscal, cnorm, 1 ) + call stdlib${ii}$_dscal( n, tscal, cnorm, 1_${ik}$ ) end if ! compute a bound on the computed solution vector to see if the - ! level 2 blas routine stdlib_dtpsv can be used. - j = stdlib_idamax( n, x, 1 ) + ! level 2 blas routine stdlib${ii}$_dtpsv can be used. + j = stdlib${ii}$_idamax( 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 @@ -10181,7 +10183,7 @@ module stdlib_linalg_lapack_d ! initially, g(0) = max{x(i), i=1,...,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. @@ -10197,7 +10199,7 @@ module stdlib_linalg_lapack_d grow = zero end if ip = ip + jinc*jlen - jlen = jlen - 1 + jlen = jlen - 1_${ik}$ end do grow = xbnd else @@ -10215,13 +10217,13 @@ module stdlib_linalg_lapack_d 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 @@ -10233,8 +10235,8 @@ module stdlib_linalg_lapack_d ! initially, m(0) = max{x(i), i=1,...,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 @@ -10244,7 +10246,7 @@ module stdlib_linalg_lapack_d ! m(j) = m(j-1)*( 1 + 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 ) @@ -10265,19 +10267,19 @@ module stdlib_linalg_lapack_d if( ( grow*tscal )>smlnum ) then ! use the level 2 blas solve if the reciprocal of the bound on ! elements of x is not too small. - call stdlib_dtpsv( uplo, trans, diag, n, ap, x, 1 ) + call stdlib${ii}$_dtpsv( uplo, trans, diag, n, ap, x, 1_${ik}$ ) else ! use a level 1 blas solve, scaling intermediate results. if( xmax>bignum ) then ! scale x so that its components are less than or equal to ! bignum in absolute value. scale = bignum / xmax - call stdlib_dscal( n, scale, x, 1 ) + call stdlib${ii}$_dscal( 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_110: do j = jfirst, jlast, jinc ! compute x(j) = b(j) / a(j,j), scaling x if necessary. xj = abs( x( j ) ) @@ -10294,7 +10296,7 @@ module stdlib_linalg_lapack_d if( xj>tjj*bignum ) then ! scale x by 1/b(j). rec = one / xj - call stdlib_dscal( n, rec, x, 1 ) + call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if @@ -10312,7 +10314,7 @@ module stdlib_linalg_lapack_d ! multiplying x(j) times column j. rec = rec / cnorm( j ) end if - call stdlib_dscal( n, rec, x, 1 ) + call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if @@ -10337,20 +10339,20 @@ module stdlib_linalg_lapack_d if( cnorm( j )>( bignum-xmax )*rec ) then ! scale x by 1/(2*abs(x(j))). rec = rec*half - call stdlib_dscal( n, rec, x, 1 ) + call stdlib${ii}$_dscal( 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_dscal( n, half, x, 1 ) + call stdlib${ii}$_dscal( 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_daxpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1, x,1 ) - i = stdlib_idamax( j-1, x, 1 ) + call stdlib${ii}$_daxpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1_${ik}$, x,1_${ik}$ ) + i = stdlib${ii}$_idamax( j-1, x, 1_${ik}$ ) xmax = abs( x( i ) ) end if ip = ip - j @@ -10358,18 +10360,18 @@ module stdlib_linalg_lapack_d if( jj @@ -10391,7 +10393,7 @@ module stdlib_linalg_lapack_d uscal = uscal / tjjs end if if( rectjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_dscal( n, rec, x, 1 ) + call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if @@ -10447,7 +10449,7 @@ module stdlib_linalg_lapack_d if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_dscal( n, rec, x, 1 ) + call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if @@ -10469,7 +10471,7 @@ module stdlib_linalg_lapack_d 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_160 end if @@ -10477,13 +10479,13 @@ module stdlib_linalg_lapack_d end if ! scale the column norms by 1/tscal for return. if( tscal/=one ) then - call stdlib_dscal( n, one / tscal, cnorm, 1 ) + call stdlib${ii}$_dscal( n, one / tscal, cnorm, 1_${ik}$ ) end if return - end subroutine stdlib_dlatps + end subroutine stdlib${ii}$_dlatps - pure subroutine stdlib_dlatrs( uplo, trans, diag, normin, n, a, lda, x, scale,cnorm, info ) + pure subroutine stdlib${ii}$_dlatrs( uplo, trans, diag, normin, n, a, lda, x, scale,cnorm, info ) !! DLATRS 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 @@ -10500,8 +10502,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(out) :: scale ! Array Arguments real(dp), intent(in) :: a(lda,*) @@ -10510,40 +10512,40 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: notran, nounit, upper - integer(ilp) :: i, imax, j, jfirst, jinc, jlast + integer(${ik}$) :: i, imax, j, jfirst, jinc, jlast real(dp) :: 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( ldasmlnum ) then ! use the level 2 blas solve if the reciprocal of the bound on ! elements of x is not too small. - call stdlib_dtrsv( uplo, trans, diag, n, a, lda, x, 1 ) + call stdlib${ii}$_dtrsv( uplo, trans, diag, n, a, lda, x, 1_${ik}$ ) else ! use a level 1 blas solve, scaling intermediate results. if( xmax>bignum ) then ! scale x so that its components are less than or equal to ! bignum in absolute value. scale = bignum / xmax - call stdlib_dscal( n, scale, x, 1 ) + call stdlib${ii}$_dscal( n, scale, x, 1_${ik}$ ) xmax = bignum end if if( notran ) then @@ -10701,7 +10703,7 @@ module stdlib_linalg_lapack_d if( xj>tjj*bignum ) then ! scale x by 1/b(j). rec = one / xj - call stdlib_dscal( n, rec, x, 1 ) + call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if @@ -10719,7 +10721,7 @@ module stdlib_linalg_lapack_d ! multiplying x(j) times column j. rec = rec / cnorm( j ) end if - call stdlib_dscal( n, rec, x, 1 ) + call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if @@ -10744,29 +10746,29 @@ module stdlib_linalg_lapack_d if( cnorm( j )>( bignum-xmax )*rec ) then ! scale x by 1/(2*abs(x(j))). rec = rec*half - call stdlib_dscal( n, rec, x, 1 ) + call stdlib${ii}$_dscal( 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_dscal( n, half, x, 1 ) + call stdlib${ii}$_dscal( 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_daxpy( j-1, -x( j )*tscal, a( 1, j ), 1, x,1 ) - i = stdlib_idamax( j-1, x, 1 ) + call stdlib${ii}$_daxpy( j-1, -x( j )*tscal, a( 1_${ik}$, j ), 1_${ik}$, x,1_${ik}$ ) + i = stdlib${ii}$_idamax( j-1, x, 1_${ik}$ ) xmax = abs( x( i ) ) end if else if( jtjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_dscal( n, rec, x, 1 ) + call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if @@ -10850,7 +10852,7 @@ module stdlib_linalg_lapack_d if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_dscal( n, rec, x, 1 ) + call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if @@ -10878,13 +10880,13 @@ module stdlib_linalg_lapack_d end if ! scale the column norms by 1/tscal for return. if( tscal/=one ) then - call stdlib_dscal( n, one / tscal, cnorm, 1 ) + call stdlib${ii}$_dscal( n, one / tscal, cnorm, 1_${ik}$ ) end if return - end subroutine stdlib_dlatrs + end subroutine stdlib${ii}$_dlatrs - pure subroutine stdlib_dlauu2( uplo, n, a, lda, info ) + pure subroutine stdlib${ii}$_dlauu2( uplo, n, a, lda, info ) !! DLAUU2 computes the product U * U**T or L**T * L, where the triangular !! factor U or L is stored in the upper or lower triangular part of !! the array A. @@ -10898,31 +10900,31 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: i + integer(${ik}$) :: i real(dp) :: 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}$, 'DLAUUM', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code - call stdlib_dlauu2( uplo, n, a, lda, info ) + call stdlib${ii}$_dlauu2( 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_dtrmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',i-1, ib, one, a( & - i, i ), lda, a( 1, i ),lda ) - call stdlib_dlauu2( 'UPPER', ib, a( i, i ), lda, info ) + call stdlib${ii}$_dtrmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',i-1, ib, one, a( & + i, i ), lda, a( 1_${ik}$, i ),lda ) + call stdlib${ii}$_dlauu2( 'UPPER', ib, a( i, i ), lda, info ) if( i+ib<=n ) then - call stdlib_dgemm( '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_dsyrk( 'UPPER', 'NO TRANSPOSE', ib, n-i-ib+1,one, a( i, i+ib ),& + call stdlib${ii}$_dgemm( '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}$_dsyrk( 'UPPER', 'NO TRANSPOSE', ib, n-i-ib+1,one, a( i, i+ib ),& lda, one, a( i, i ),lda ) end if end do @@ -11023,23 +11025,23 @@ module stdlib_linalg_lapack_d ! compute the product l**t * l. do i = 1, n, nb ib = min( nb, n-i+1 ) - call stdlib_dtrmm( 'LEFT', 'LOWER', 'TRANSPOSE', 'NON-UNIT', ib,i-1, one, a( & - i, i ), lda, a( i, 1 ), lda ) - call stdlib_dlauu2( 'LOWER', ib, a( i, i ), lda, info ) + call stdlib${ii}$_dtrmm( 'LEFT', 'LOWER', 'TRANSPOSE', 'NON-UNIT', ib,i-1, one, a( & + i, i ), lda, a( i, 1_${ik}$ ), lda ) + call stdlib${ii}$_dlauu2( 'LOWER', ib, a( i, i ), lda, info ) if( i+ib<=n ) then - call stdlib_dgemm( '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_dsyrk( 'LOWER', 'TRANSPOSE', ib, n-i-ib+1, one,a( i+ib, i ), & + call stdlib${ii}$_dgemm( '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}$_dsyrk( '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_dlauum + end subroutine stdlib${ii}$_dlauum - pure subroutine stdlib_dorbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & + pure subroutine stdlib${ii}$_dorbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & !! DORBDB6 orthogonalizes the column vector !! X = [ X1 ] !! [ X2 ] @@ -11054,8 +11056,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: q1(ldq1,*), q2(ldq2,*) real(dp), intent(out) :: work(*) @@ -11068,60 +11070,60 @@ module stdlib_linalg_lapack_d ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i real(dp) :: 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( 'DORBDB6', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DORBDB6', -info ) return end if ! first, project x onto the orthogonal complement of q's column ! space scl1 = realzero ssq1 = realone - call stdlib_dlassq( m1, x1, incx1, scl1, ssq1 ) + call stdlib${ii}$_dlassq( m1, x1, incx1, scl1, ssq1 ) scl2 = realzero ssq2 = realone - call stdlib_dlassq( m2, x2, incx2, scl2, ssq2 ) - normsq1 = scl1**2*ssq1 + scl2**2*ssq2 - if( m1 == 0 ) then + call stdlib${ii}$_dlassq( 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_dgemv( 'C', m1, n, one, q1, ldq1, x1, incx1, zero, work,1 ) + call stdlib${ii}$_dgemv( 'C', m1, n, one, q1, ldq1, x1, incx1, zero, work,1_${ik}$ ) end if - call stdlib_dgemv( 'C', m2, n, one, q2, ldq2, x2, incx2, one, work, 1 ) - call stdlib_dgemv( 'N', m1, n, negone, q1, ldq1, work, 1, one, x1,incx1 ) - call stdlib_dgemv( 'N', m2, n, negone, q2, ldq2, work, 1, one, x2,incx2 ) + call stdlib${ii}$_dgemv( 'C', m2, n, one, q2, ldq2, x2, incx2, one, work, 1_${ik}$ ) + call stdlib${ii}$_dgemv( 'N', m1, n, negone, q1, ldq1, work, 1_${ik}$, one, x1,incx1 ) + call stdlib${ii}$_dgemv( 'N', m2, n, negone, q2, ldq2, work, 1_${ik}$, one, x2,incx2 ) scl1 = realzero ssq1 = realone - call stdlib_dlassq( m1, x1, incx1, scl1, ssq1 ) + call stdlib${ii}$_dlassq( m1, x1, incx1, scl1, ssq1 ) scl2 = realzero ssq2 = realone - call stdlib_dlassq( m2, x2, incx2, scl2, ssq2 ) - normsq2 = scl1**2*ssq1 + scl2**2*ssq2 + call stdlib${ii}$_dlassq( 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. @@ -11135,23 +11137,23 @@ module stdlib_linalg_lapack_d 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_dgemv( 'C', m1, n, one, q1, ldq1, x1, incx1, zero, work,1 ) + call stdlib${ii}$_dgemv( 'C', m1, n, one, q1, ldq1, x1, incx1, zero, work,1_${ik}$ ) end if - call stdlib_dgemv( 'C', m2, n, one, q2, ldq2, x2, incx2, one, work, 1 ) - call stdlib_dgemv( 'N', m1, n, negone, q1, ldq1, work, 1, one, x1,incx1 ) - call stdlib_dgemv( 'N', m2, n, negone, q2, ldq2, work, 1, one, x2,incx2 ) + call stdlib${ii}$_dgemv( 'C', m2, n, one, q2, ldq2, x2, incx2, one, work, 1_${ik}$ ) + call stdlib${ii}$_dgemv( 'N', m1, n, negone, q1, ldq1, work, 1_${ik}$, one, x1,incx1 ) + call stdlib${ii}$_dgemv( 'N', m2, n, negone, q2, ldq2, work, 1_${ik}$, one, x2,incx2 ) scl1 = realzero ssq1 = realone - call stdlib_dlassq( m1, x1, incx1, scl1, ssq1 ) + call stdlib${ii}$_dlassq( m1, x1, incx1, scl1, ssq1 ) scl2 = realzero ssq2 = realone - call stdlib_dlassq( m1, x1, incx1, scl1, ssq1 ) - normsq2 = scl1**2*ssq1 + scl2**2*ssq2 + call stdlib${ii}$_dlassq( 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. @@ -11164,10 +11166,10 @@ module stdlib_linalg_lapack_d end do end if return - end subroutine stdlib_dorbdb6 + end subroutine stdlib${ii}$_dorbdb6 - pure subroutine stdlib_dorg2l( m, n, k, a, lda, tau, work, info ) + pure subroutine stdlib${ii}$_dorg2l( m, n, k, a, lda, tau, work, info ) !! DORG2L generates an m by n real matrix Q with orthonormal columns, !! which is defined as the last n columns of a product of k elementary !! reflectors of order m @@ -11177,8 +11179,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: tau(*) @@ -11186,23 +11188,23 @@ module stdlib_linalg_lapack_d ! ===================================================================== ! 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_dlarft( 'FORWARD', 'ROWWISE', n-i+1, ib, a( i, i ),lda, tau( i ), & + call stdlib${ii}$_dlarft( '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_dlarfb( '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}$_dlarfb( '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_dorgl2( ib, n-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) + call stdlib${ii}$_dorgl2( ib, n-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) ! set columns 1:i-1 of current block to zero do j = 1, i - 1 do l = i, i + ib - 1 @@ -11476,12 +11478,12 @@ module stdlib_linalg_lapack_d end do end do end if - work( 1 ) = iws + work( 1_${ik}$ ) = iws return - end subroutine stdlib_dorglq + end subroutine stdlib${ii}$_dorglq - pure subroutine stdlib_dorgql( m, n, k, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_dorgql( m, n, k, a, lda, tau, work, lwork, info ) !! DORGQL generates an M-by-N real matrix Q with orthonormal columns, !! which is defined as the last N columns of a product of K elementary !! reflectors of order M @@ -11491,8 +11493,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: tau(*) @@ -11501,50 +11503,50 @@ module stdlib_linalg_lapack_d ! 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}$_dorg2l( 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_dlarft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1, n-k+i ), & + call stdlib${ii}$_dlarft( '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_dlarfb( '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 ) + call stdlib${ii}$_dlarfb( '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_dorg2l( m-k+i+ib-1, ib, ib, a( 1, n-k+i ), lda,tau( i ), work, iinfo & + call stdlib${ii}$_dorg2l( 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 @@ -11597,12 +11599,12 @@ module stdlib_linalg_lapack_d end do end do end if - work( 1 ) = iws + work( 1_${ik}$ ) = iws return - end subroutine stdlib_dorgql + end subroutine stdlib${ii}$_dorgql - pure subroutine stdlib_dorgqr( m, n, k, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_dorgqr( m, n, k, a, lda, tau, work, lwork, info ) !! DORGQR generates an M-by-N real matrix Q with orthonormal columns, !! which is defined as the first N columns of a product of K elementary !! reflectors of order M @@ -11612,8 +11614,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: tau(*) @@ -11622,44 +11624,44 @@ module stdlib_linalg_lapack_d ! 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, 'DORGQR', ' ', 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_dlarft( 'FORWARD', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & + call stdlib${ii}$_dlarft( '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_dlarfb( 'LEFT', 'NO TRANSPOSE', 'FORWARD','COLUMNWISE', m-i+1, n-& + call stdlib${ii}$_dlarfb( '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_dorg2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work,iinfo ) + call stdlib${ii}$_dorg2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work,iinfo ) ! set rows 1:i-1 of current block to zero do j = i, i + ib - 1 do l = 1, i - 1 @@ -11713,12 +11715,12 @@ module stdlib_linalg_lapack_d end do end do end if - work( 1 ) = iws + work( 1_${ik}$ ) = iws return - end subroutine stdlib_dorgqr + end subroutine stdlib${ii}$_dorgqr - pure subroutine stdlib_dorgr2( m, n, k, a, lda, tau, work, info ) + pure subroutine stdlib${ii}$_dorgr2( m, n, k, a, lda, tau, work, info ) !! DORGR2 generates an m by n real matrix Q with orthonormal rows, !! which is defined as the last m rows of a product of k elementary !! reflectors of order n @@ -11728,8 +11730,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: tau(*) @@ -11737,23 +11739,23 @@ module stdlib_linalg_lapack_d ! ===================================================================== ! 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}$_dorgr2( 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_dlarft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( ii, 1 ), lda, & + call stdlib${ii}$_dlarft( '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_dlarfb( 'RIGHT', 'TRANSPOSE', 'BACKWARD', 'ROWWISE',ii-1, n-k+i+& - ib-1, ib, a( ii, 1 ), lda, work,ldwork, a, lda, work( ib+1 ), ldwork ) + call stdlib${ii}$_dlarfb( '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_dorgr2( ib, n-k+i+ib-1, ib, a( ii, 1 ), lda, tau( i ),work, iinfo ) + call stdlib${ii}$_dorgr2( 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 @@ -11900,12 +11902,12 @@ module stdlib_linalg_lapack_d end do end do end if - work( 1 ) = iws + work( 1_${ik}$ ) = iws return - end subroutine stdlib_dorgrq + end subroutine stdlib${ii}$_dorgrq - pure subroutine stdlib_dorgtsqr_row( m, n, mb, nb, a, lda, t, ldt, work,lwork, info ) + pure subroutine stdlib${ii}$_dorgtsqr_row( m, n, mb, nb, a, lda, t, ldt, work,lwork, info ) !! DORGTSQR_ROW generates an M-by-N real matrix Q_out with !! orthonormal columns from the output of DLATSQR. These N orthonormal !! columns are the first N columns of a product of complex unitary @@ -11925,8 +11927,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: t(ldt,*) @@ -11935,55 +11937,55 @@ module stdlib_linalg_lapack_d ! 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(dp) :: dummy(1,1) + real(dp) :: 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 ( mbnq ) 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_dorml2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib${ii}$_dorml2( 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' @@ -12644,28 +12646,28 @@ module stdlib_linalg_lapack_d 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_dlarft( 'FORWARD', 'ROWWISE', nq-i+1, ib, a( i, i ),lda, tau( i ), & + call stdlib${ii}$_dlarft( '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 + mi = m - i + 1_${ik}$ ic = i else ! h or h**t is applied to c(1:m,i:n) - ni = n - i + 1 + ni = n - i + 1_${ik}$ jc = i end if ! apply h or h**t - call stdlib_dlarfb( side, transt, 'FORWARD', 'ROWWISE', mi, ni, ib,a( i, i ), & + call stdlib${ii}$_dlarfb( 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_dormlq + end subroutine stdlib${ii}$_dormlq - pure subroutine stdlib_dormql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) + pure subroutine stdlib${ii}$_dormql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) !! DORMQL overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -12681,97 +12683,97 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*), c(ldc,*) real(dp), intent(in) :: tau(*) real(dp), 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_dorm2l( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib${ii}$_dorm2l( 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 @@ -12783,26 +12785,26 @@ module stdlib_linalg_lapack_d 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_dlarft( 'BACKWARD', 'COLUMNWISE', nq-k+i+ib-1, ib,a( 1, i ), lda, & + call stdlib${ii}$_dlarft( '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 + 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 + ni = n - k + i + ib - 1_${ik}$ end if ! apply h or h**t - call stdlib_dlarfb( side, trans, 'BACKWARD', 'COLUMNWISE', mi, ni,ib, a( 1, i ), & + call stdlib${ii}$_dlarfb( 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_dormql + end subroutine stdlib${ii}$_dormql - pure subroutine stdlib_dormqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) + pure subroutine stdlib${ii}$_dormqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) !! DORMQR overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -12818,128 +12820,128 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*), c(ldc,*) real(dp), intent(in) :: tau(*) real(dp), 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_dorm2r( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib${ii}$_dorm2r( 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_dlarft( 'FORWARD', 'COLUMNWISE', nq-i+1, ib, a( i, i ),lda, tau( i ),& + call stdlib${ii}$_dlarft( '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 + mi = m - i + 1_${ik}$ ic = i else ! h or h**t is applied to c(1:m,i:n) - ni = n - i + 1 + ni = n - i + 1_${ik}$ jc = i end if ! apply h or h**t - call stdlib_dlarfb( side, trans, 'FORWARD', 'COLUMNWISE', mi, ni,ib, a( i, i ), & + call stdlib${ii}$_dlarfb( 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_dormqr + end subroutine stdlib${ii}$_dormqr - pure subroutine stdlib_dormr2( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) + pure subroutine stdlib${ii}$_dormr2( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) !! DORMR2 overwrites the general real m by n matrix C with !! Q * C if SIDE = 'L' and TRANS = 'N', or !! Q**T* C if SIDE = 'L' and TRANS = 'T', or @@ -12955,8 +12957,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*), c(ldc,*) real(dp), intent(in) :: tau(*) @@ -12965,13 +12967,13 @@ module stdlib_linalg_lapack_d ! 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(dp) :: 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 @@ -12981,34 +12983,34 @@ module stdlib_linalg_lapack_d 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_dormr2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib${ii}$_dormr2( 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 @@ -13256,26 +13258,26 @@ module stdlib_linalg_lapack_d 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_dlarft( 'BACKWARD', 'ROWWISE', nq-k+i+ib-1, ib,a( i, 1 ), lda, tau( & + call stdlib${ii}$_dlarft( '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 + 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 + ni = n - k + i + ib - 1_${ik}$ end if ! apply h or h**t - call stdlib_dlarfb( side, transt, 'BACKWARD', 'ROWWISE', mi, ni,ib, a( i, 1 ), & + call stdlib${ii}$_dlarfb( 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_dormrq + end subroutine stdlib${ii}$_dormrq - pure subroutine stdlib_dormrz( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, lwork, & + pure subroutine stdlib${ii}$_dormrz( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, lwork, & !! DORMRZ overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -13291,112 +13293,112 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*), c(ldc,*) real(dp), intent(in) :: tau(*) real(dp), 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_dormr3( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, iinfo ) + call stdlib${ii}$_dormr3( 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' @@ -13407,28 +13409,28 @@ module stdlib_linalg_lapack_d 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_dlarzt( 'BACKWARD', 'ROWWISE', l, ib, a( i, ja ), lda,tau( i ), work(& + call stdlib${ii}$_dlarzt( '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 + mi = m - i + 1_${ik}$ ic = i else ! h or h**t is applied to c(1:m,i:n) - ni = n - i + 1 + ni = n - i + 1_${ik}$ jc = i end if ! apply h or h**t - call stdlib_dlarzb( side, transt, 'BACKWARD', 'ROWWISE', mi, ni,ib, l, a( i, ja )& + call stdlib${ii}$_dlarzb( 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_dormrz + end subroutine stdlib${ii}$_dormrz - pure subroutine stdlib_dpbequ( uplo, n, kd, ab, ldab, s, scond, amax, info ) + pure subroutine stdlib${ii}$_dpbequ( uplo, n, kd, ab, ldab, s, scond, amax, info ) !! DPBEQU 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, @@ -13442,8 +13444,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(out) :: amax, scond ! Array Arguments real(dp), intent(in) :: ab(ldab,*) @@ -13452,42 +13454,42 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: upper - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: 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_dscal( km, one / ajj, ab( kd, j+1 ), kld ) - call stdlib_dsyr( 'UPPER', km, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) + if( km>0_${ik}$ ) then + call stdlib${ii}$_dscal( km, one / ajj, ab( kd, j+1 ), kld ) + call stdlib${ii}$_dsyr( 'UPPER', km, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) end if end do @@ -13599,30 +13601,30 @@ module stdlib_linalg_lapack_d ! factorize a(m+1:n,m+1:n) as l**t*l, and update a(1:m,1:m). do j = n, m + 1, -1 ! compute s(j,j) and test for non-positive-definiteness. - ajj = 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_dscal( km, one / ajj, ab( km+1, j-km ), kld ) - call stdlib_dsyr( 'LOWER', km, -one, ab( km+1, j-km ), kld,ab( 1, j-km ), kld ) + call stdlib${ii}$_dscal( km, one / ajj, ab( km+1, j-km ), kld ) + call stdlib${ii}$_dsyr( '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. 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_dscal( km, one / ajj, ab( 2, j ), 1 ) - call stdlib_dsyr( 'LOWER', km, -one, ab( 2, j ), 1,ab( 1, j+1 ), kld ) + if( km>0_${ik}$ ) then + call stdlib${ii}$_dscal( km, one / ajj, ab( 2_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_dsyr( 'LOWER', km, -one, ab( 2_${ik}$, j ), 1_${ik}$,ab( 1_${ik}$, j+1 ), kld ) end if end do end if @@ -13630,10 +13632,10 @@ module stdlib_linalg_lapack_d 50 continue info = j return - end subroutine stdlib_dpbstf + end subroutine stdlib${ii}$_dpbstf - pure subroutine stdlib_dpbtf2( uplo, n, kd, ab, ldab, info ) + pure subroutine stdlib${ii}$_dpbtf2( uplo, n, kd, ab, ldab, info ) !! DPBTF2 computes the Cholesky factorization of a real symmetric !! positive definite band matrix A. !! The factorization has the form @@ -13647,38 +13649,38 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: ab(ldab,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: j, kld, kn + integer(${ik}$) :: j, kld, kn real(dp) :: 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_dscal( kn, one / ajj, ab( kd, j+1 ), kld ) - call stdlib_dsyr( 'UPPER', kn, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) + if( kn>0_${ik}$ ) then + call stdlib${ii}$_dscal( kn, one / ajj, ab( kd, j+1 ), kld ) + call stdlib${ii}$_dsyr( 'UPPER', kn, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) end if end do @@ -13700,16 +13702,16 @@ module stdlib_linalg_lapack_d ! 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_dscal( kn, one / ajj, ab( 2, j ), 1 ) - call stdlib_dsyr( 'LOWER', kn, -one, ab( 2, j ), 1,ab( 1, j+1 ), kld ) + if( kn>0_${ik}$ ) then + call stdlib${ii}$_dscal( kn, one / ajj, ab( 2_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_dsyr( 'LOWER', kn, -one, ab( 2_${ik}$, j ), 1_${ik}$,ab( 1_${ik}$, j+1 ), kld ) end if end do end if @@ -13717,10 +13719,10 @@ module stdlib_linalg_lapack_d 30 continue info = j return - end subroutine stdlib_dpbtf2 + end subroutine stdlib${ii}$_dpbtf2 - pure subroutine stdlib_dpbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) + pure subroutine stdlib${ii}$_dpbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) !! DPBTRS solves a system of linear equations A*X = B with a symmetric !! positive definite band matrix A using the Cholesky factorization !! A = U**T*U or A = L*L**T computed by DPBTRF. @@ -13729,36 +13731,36 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: ab(ldab,*) real(dp), 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_dtpsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', j-1, ap,ap( jc ), & - 1 ) + if( j>1_${ik}$ )call stdlib${ii}$_dtpsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', j-1, ap,ap( jc ), & + 1_${ik}$ ) ! compute u(j,j) and test for non-positive-definiteness. - ajj = ap( jj ) - stdlib_ddot( j-1, ap( jc ), 1, ap( jc ), 1 ) + ajj = ap( jj ) - stdlib${ii}$_ddot( j-1, ap( jc ), 1_${ik}$, ap( jc ), 1_${ik}$ ) if( ajj<=zero ) then ap( jj ) = ajj go to 30 @@ -14157,7 +14159,7 @@ module stdlib_linalg_lapack_d 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 ) @@ -14170,9 +14172,9 @@ module stdlib_linalg_lapack_d ! 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_dger( n-m, kbt, -one, x( m+1, i ), 1,bb( kb1-kbt, i ), & - 1, x( m+1, i-kbt ), ldx ) + call stdlib${ii}$_dscal( n-m, one / bii, x( m+1, i ), 1_${ik}$ ) + if( kbt>0_${ik}$ )call stdlib${ii}$_dger( 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 ) @@ -14672,21 +14674,21 @@ module stdlib_linalg_lapack_d 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_dlartg( ab( k+1, i-k+ka ), ra1,work( n+i-k+ka-m ), work( i-k+& + call stdlib${ii}$_dlartg( 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 @@ -14698,40 +14700,40 @@ module stdlib_linalg_lapack_d 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 ! have been created outside the band - if( nrt>0 )call stdlib_dlargv( nrt, ab( 1, j2t ), inca, work( j2t-m ), ka1,work( & + if( nrt>0_${ik}$ )call stdlib${ii}$_dlargv( nrt, ab( 1_${ik}$, j2t ), inca, work( j2t-m ), ka1,work( & n+j2t-m ), ka1 ) - if( nr>0 ) then + if( nr>0_${ik}$ ) then ! apply rotations in 1st set from the right do l = 1, ka - 1 - call stdlib_dlartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, work(& + call stdlib${ii}$_dlartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, work(& n+j2-m ),work( j2-m ), ka1 ) end do ! apply rotations in 1st set from both sides to diagonal ! blocks - call stdlib_dlar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & + call stdlib${ii}$_dlar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & work( n+j2-m ),work( j2-m ), ka1 ) end if ! start applying rotations in 1st set from the left do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_dlartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & + if( nrt>0_${ik}$ )call stdlib${ii}$_dlartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & ), inca,work( n+j2-m ), work( j2-m ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 1st set do j = j2, j1, ka1 - call stdlib_drot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,work( n+j-m ), & + call stdlib${ii}$_drot( 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 @@ -14739,14 +14741,14 @@ module stdlib_linalg_lapack_d 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 do l = kb - k, 1, -1 nrt = ( n-j2+ka+l ) / ka1 - if( nrt>0 )call stdlib_dlartv( nrt, ab( l, j2-l+1 ), inca,ab( l+1, j2-l+1 ), & + if( nrt>0_${ik}$ )call stdlib${ii}$_dlartv( 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 @@ -14758,56 +14760,56 @@ module stdlib_linalg_lapack_d 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 + if( nr>0_${ik}$ ) then ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band - call stdlib_dlargv( nr, ab( 1, j2 ), inca, work( j2 ), ka1,work( n+j2 ), ka1 ) + call stdlib${ii}$_dlargv( nr, ab( 1_${ik}$, j2 ), inca, work( j2 ), ka1,work( n+j2 ), ka1 ) ! apply rotations in 2nd set from the right do l = 1, ka - 1 - call stdlib_dlartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, work(& + call stdlib${ii}$_dlartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, work(& n+j2 ),work( j2 ), ka1 ) end do ! apply rotations in 2nd set from both sides to diagonal ! blocks - call stdlib_dlar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & + call stdlib${ii}$_dlar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & work( n+j2 ),work( j2 ), ka1 ) end if ! start applying rotations in 2nd set from the left do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_dlartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & + if( nrt>0_${ik}$ )call stdlib${ii}$_dlartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & ), inca, work( n+j2 ),work( j2 ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 2nd set do j = j2, j1, ka1 - call stdlib_drot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,work( n+j ), work( & + call stdlib${ii}$_drot( 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 + j2 = i - k - 1_${ik}$ + max( 1_${ik}$, k-i0+2 )*ka1 ! finish applying rotations in 1st set from the left do l = kb - k, 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_dlartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & + if( nrt>0_${ik}$ )call stdlib${ii}$_dlartv( 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 ) @@ -14817,7 +14819,7 @@ module stdlib_linalg_lapack_d ! 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 @@ -14827,7 +14829,7 @@ module stdlib_linalg_lapack_d 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 ) @@ -14840,8 +14842,8 @@ module stdlib_linalg_lapack_d end do if( wantx ) then ! post-multiply x by inv(s(i)) - call stdlib_dscal( n-m, one / bii, x( m+1, i ), 1 ) - if( kbt>0 )call stdlib_dger( n-m, kbt, -one, x( m+1, i ), 1,bb( kbt+1, i-kbt )& + call stdlib${ii}$_dscal( n-m, one / bii, x( m+1, i ), 1_${ik}$ ) + if( kbt>0_${ik}$ )call stdlib${ii}$_dger( 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 @@ -14854,9 +14856,9 @@ module stdlib_linalg_lapack_d 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_dlartg( ab( ka1-k, i ), ra1, work( n+i-k+ka-m ),work( i-k+ka-m & + call stdlib${ii}$_dlartg( 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) @@ -14867,7 +14869,7 @@ module stdlib_linalg_lapack_d 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 @@ -14884,35 +14886,35 @@ module stdlib_linalg_lapack_d end do ! generate rotations in 1st set to annihilate elements which ! have been created outside the band - if( nrt>0 )call stdlib_dlargv( nrt, ab( ka1, j2t-ka ), inca, work( j2t-m ),ka1, & + if( nrt>0_${ik}$ )call stdlib${ii}$_dlargv( nrt, ab( ka1, j2t-ka ), inca, work( j2t-m ),ka1, & work( n+j2t-m ), ka1 ) - if( nr>0 ) then + if( nr>0_${ik}$ ) then ! apply rotations in 1st set from the left do l = 1, ka - 1 - call stdlib_dlartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, work( & + call stdlib${ii}$_dlartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, work( & n+j2-m ),work( j2-m ), ka1 ) end do ! apply rotations in 1st set from both sides to diagonal ! blocks - call stdlib_dlar2v( nr, ab( 1, j2 ), ab( 1, j2+1 ), ab( 2, j2 ),inca, work( n+& + call stdlib${ii}$_dlar2v( 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 do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_dlartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& + if( nrt>0_${ik}$ )call stdlib${ii}$_dlartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& inca, work( n+j2-m ),work( j2-m ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 1st set do j = j2, j1, ka1 - call stdlib_drot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,work( n+j-m ), & + call stdlib${ii}$_drot( 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 @@ -14920,14 +14922,14 @@ module stdlib_linalg_lapack_d 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 do l = kb - k, 1, -1 nrt = ( n-j2+ka+l ) / ka1 - if( nrt>0 )call stdlib_dlartv( nrt, ab( ka1-l+1, j2-ka ), inca,ab( ka1-l, j2-& + if( nrt>0_${ik}$ )call stdlib${ii}$_dlartv( 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 @@ -14947,48 +14949,48 @@ module stdlib_linalg_lapack_d 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 + if( nr>0_${ik}$ ) then ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band - call stdlib_dlargv( nr, ab( ka1, j2-ka ), inca, work( j2 ), ka1,work( n+j2 ), & + call stdlib${ii}$_dlargv( nr, ab( ka1, j2-ka ), inca, work( j2 ), ka1,work( n+j2 ), & ka1 ) ! apply rotations in 2nd set from the left do l = 1, ka - 1 - call stdlib_dlartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, work( & + call stdlib${ii}$_dlartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, work( & n+j2 ),work( j2 ), ka1 ) end do ! apply rotations in 2nd set from both sides to diagonal ! blocks - call stdlib_dlar2v( nr, ab( 1, j2 ), ab( 1, j2+1 ), ab( 2, j2 ),inca, work( n+& + call stdlib${ii}$_dlar2v( 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 do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_dlartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& + if( nrt>0_${ik}$ )call stdlib${ii}$_dlartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& inca, work( n+j2 ),work( j2 ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 2nd set do j = j2, j1, ka1 - call stdlib_drot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,work( n+j ), work( & + call stdlib${ii}$_drot( 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 + j2 = i - k - 1_${ik}$ + max( 1_${ik}$, k-i0+2 )*ka1 ! finish applying rotations in 1st set from the right do l = kb - k, 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_dlartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& + if( nrt>0_${ik}$ )call stdlib${ii}$_dlartv( 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 ) @@ -15010,18 +15012,18 @@ module stdlib_linalg_lapack_d ! 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 @@ -15064,9 +15066,9 @@ module stdlib_linalg_lapack_d end do if( wantx ) then ! post-multiply x by inv(s(i)) - call stdlib_dscal( nx, one / bii, x( 1, i ), 1 ) - if( kbt>0 )call stdlib_dger( nx, kbt, -one, x( 1, i ), 1, bb( kb, i+1 ),ldbb-& - 1, x( 1, i+1 ), ldx ) + call stdlib${ii}$_dscal( nx, one / bii, x( 1_${ik}$, i ), 1_${ik}$ ) + if( kbt>0_${ik}$ )call stdlib${ii}$_dger( 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 ) @@ -15077,19 +15079,19 @@ module stdlib_linalg_lapack_d 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_dlargv( nrt, ab( 1, j1+ka ), inca, work( j1 ), ka1,work( & + if( nrt>0_${ik}$ )call stdlib${ii}$_dlargv( nrt, ab( 1_${ik}$, j1+ka ), inca, work( j1 ), ka1,work( & n+j1 ), ka1 ) - if( nr>0 ) then + if( nr>0_${ik}$ ) then ! apply rotations in 1st set from the left do l = 1, ka - 1 - call stdlib_dlartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca, & + call stdlib${ii}$_dlartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca, & work( n+j1 ),work( j1 ), ka1 ) end do ! apply rotations in 1st set from both sides to diagonal ! blocks - call stdlib_dlar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & + call stdlib${ii}$_dlar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & work( n+j1 ),work( j1 ), ka1 ) end if ! start applying rotations in 1st set from the right do l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_dlartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& + if( nrt>0_${ik}$ )call stdlib${ii}$_dlartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& work( n+j1t ),work( j1t ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 1st set do j = j1, j2, ka1 - call stdlib_drot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,work( n+j ), work( j ) ) + call stdlib${ii}$_drot( 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 @@ -15143,15 +15145,15 @@ module stdlib_linalg_lapack_d 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 do l = kb - k, 1, -1 nrt = ( j2+ka+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_dlartv( nrt, ab( l, j1t+ka ), inca,ab( l+1, j1t+ka-1 ),& + if( nrt>0_${ik}$ )call stdlib${ii}$_dlartv( 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 @@ -15163,58 +15165,58 @@ module stdlib_linalg_lapack_d 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 + if( nr>0_${ik}$ ) then ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band - call stdlib_dlargv( nr, ab( 1, j1+ka ), inca, work( m-kb+j1 ),ka1, work( n+m-& + call stdlib${ii}$_dlargv( 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 do l = 1, ka - 1 - call stdlib_dlartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca,& + call stdlib${ii}$_dlartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca,& work( n+m-kb+j1 ), work( m-kb+j1 ), ka1 ) end do ! apply rotations in 2nd set from both sides to diagonal ! blocks - call stdlib_dlar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & + call stdlib${ii}$_dlar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & work( n+m-kb+j1 ),work( m-kb+j1 ), ka1 ) end if ! start applying rotations in 2nd set from the right do l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_dlartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& + if( nrt>0_${ik}$ )call stdlib${ii}$_dlartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& work( n+m-kb+j1t ), work( m-kb+j1t ),ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 2nd set do j = j1, j2, ka1 - call stdlib_drot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,work( n+m-kb+j ), work( & + call stdlib${ii}$_drot( 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 + j2 = i + k + 1_${ik}$ - max( 1_${ik}$, k+i0-m+1 )*ka1 ! finish applying rotations in 1st 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_dlartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& + if( nrt>0_${ik}$ )call stdlib${ii}$_dlartv( 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 ) @@ -15224,7 +15226,7 @@ module stdlib_linalg_lapack_d ! 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 @@ -15234,7 +15236,7 @@ module stdlib_linalg_lapack_d 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 ) @@ -15247,8 +15249,8 @@ module stdlib_linalg_lapack_d end do if( wantx ) then ! post-multiply x by inv(s(i)) - call stdlib_dscal( nx, one / bii, x( 1, i ), 1 ) - if( kbt>0 )call stdlib_dger( nx, kbt, -one, x( 1, i ), 1, bb( 2, i ), 1,x( 1, & + call stdlib${ii}$_dscal( nx, one / bii, x( 1_${ik}$, i ), 1_${ik}$ ) + if( kbt>0_${ik}$ )call stdlib${ii}$_dger( 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 @@ -15260,9 +15262,9 @@ module stdlib_linalg_lapack_d 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_dlargv( nrt, ab( ka1, j1 ), inca, work( j1 ), ka1,work( n+& + if( nrt>0_${ik}$ )call stdlib${ii}$_dlargv( nrt, ab( ka1, j1 ), inca, work( j1 ), ka1,work( n+& j1 ), ka1 ) - if( nr>0 ) then + if( nr>0_${ik}$ ) then ! apply rotations in 1st set from the right do l = 1, ka - 1 - call stdlib_dlartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, work( n+& + call stdlib${ii}$_dlartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, work( n+& j1 ), work( j1 ), ka1 ) end do ! apply rotations in 1st set from both sides to diagonal ! blocks - call stdlib_dlar2v( nr, ab( 1, j1 ), ab( 1, j1-1 ),ab( 2, j1-1 ), inca, work( & + call stdlib${ii}$_dlar2v( 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 do l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_dlartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & + if( nrt>0_${ik}$ )call stdlib${ii}$_dlartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & j1t-ka1+l ), inca,work( n+j1t ), work( j1t ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 1st set do j = j1, j2, ka1 - call stdlib_drot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,work( n+j ), work( j ) ) + call stdlib${ii}$_drot( 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 @@ -15328,15 +15330,15 @@ module stdlib_linalg_lapack_d 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 do l = kb - k, 1, -1 nrt = ( j2+ka+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_dlartv( nrt, ab( ka1-l+1, j1t+l-1 ), inca,ab( ka1-l, & + if( nrt>0_${ik}$ )call stdlib${ii}$_dlartv( 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 @@ -15356,50 +15358,50 @@ module stdlib_linalg_lapack_d 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 + if( nr>0_${ik}$ ) then ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band - call stdlib_dlargv( nr, ab( ka1, j1 ), inca, work( m-kb+j1 ),ka1, work( n+m-& + call stdlib${ii}$_dlargv( nr, ab( ka1, j1 ), inca, work( m-kb+j1 ),ka1, work( n+m-& kb+j1 ), ka1 ) ! apply rotations in 2nd set from the right do l = 1, ka - 1 - call stdlib_dlartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, work( n+& + call stdlib${ii}$_dlartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, work( n+& m-kb+j1 ), work( m-kb+j1 ),ka1 ) end do ! apply rotations in 2nd set from both sides to diagonal ! blocks - call stdlib_dlar2v( nr, ab( 1, j1 ), ab( 1, j1-1 ),ab( 2, j1-1 ), inca, work( & + call stdlib${ii}$_dlar2v( 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 do l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_dlartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & + if( nrt>0_${ik}$ )call stdlib${ii}$_dlartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & j1t-ka1+l ), inca,work( n+m-kb+j1t ), work( m-kb+j1t ),ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 2nd set do j = j1, j2, ka1 - call stdlib_drot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,work( n+m-kb+j ), work( & + call stdlib${ii}$_drot( 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 + j2 = i + k + 1_${ik}$ - max( 1_${ik}$, k+i0-m+1 )*ka1 ! finish applying rotations in 1st 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_dlartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & + if( nrt>0_${ik}$ )call stdlib${ii}$_dlartv( 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 ) @@ -15407,10 +15409,10 @@ module stdlib_linalg_lapack_d end if end if go to 490 - end subroutine stdlib_dsbgst + end subroutine stdlib${ii}$_dsbgst - pure subroutine stdlib_dsbtrd( vect, uplo, n, kd, ab, ldab, d, e, q, ldq,work, info ) + pure subroutine stdlib${ii}$_dsbtrd( vect, uplo, n, kd, ab, ldab, d, e, q, ldq,work, info ) !! DSBTRD reduces a real symmetric band matrix A to symmetric !! tridiagonal form T by an orthogonal similarity transformation: !! Q**T * A * Q = T. @@ -15419,8 +15421,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: ab(ldab,*), q(ldq,*) real(dp), intent(out) :: d(*), e(*), work(*) @@ -15428,7 +15430,7 @@ module stdlib_linalg_lapack_d ! 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(dp) :: temp ! Intrinsic Functions @@ -15438,32 +15440,32 @@ module stdlib_linalg_lapack_d 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_dlargv( nr, ab( 1, j1-1 ), inca, work( j1 ),kd1, d( j1 ), & + call stdlib${ii}$_dlargv( 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_dlartv or stdlib_drot is used - if( nr>=2*kd-1 ) then + ! stdlib${ii}$_dlartv or stdlib${ii}$_drot is used + if( nr>=2_${ik}$*kd-1 ) then do l = 1, kd - 1 - call stdlib_dlartv( nr, ab( l+1, j1-1 ), inca,ab( l, j1 ), inca, & + call stdlib${ii}$_dlartv( 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_drot( kdm1, ab( 2, jinc-1 ), 1,ab( 1, jinc ), 1, d( & + call stdlib${ii}$_drot( 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_dlartg( 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}$_dlartg( 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_drot( k-3, ab( kd-k+4, i+k-2 ), 1,ab( kd-k+3, i+k-1 ), 1,& + call stdlib${ii}$_drot( 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_dlar2v( nr, ab( kd1, j1-1 ), ab( kd1, j1 ),ab( kd, & + if( nr>0_${ik}$ )call stdlib${ii}$_dlar2v( 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_dlartv( nrt, ab( kd-l, j1+l ), inca,ab( kd-& + if( nrt>0_${ik}$ )call stdlib${ii}$_dlartv( 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_drot( kd-1, ab( kd-1, jin+1 ), incx,ab( kd, jin+1 )& + call stdlib${ii}$_drot( 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_drot( lend, ab( kd-1, last+1 ), incx,ab( kd, & + if( lend>0_${ik}$ )call stdlib${ii}$_drot( lend, ab( kd-1, last+1 ), incx,ab( kd, & last+1 ), incx, d( last ),work( last ) ) end if end if @@ -15554,41 +15556,41 @@ module stdlib_linalg_lapack_d ! 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_drot( nq, q( iqb, j-1 ), 1, q( iqb, j ),1, d( j ), & + call stdlib${ii}$_drot( 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_drot( n, q( 1, j-1 ), 1, q( 1, j ), 1,d( j ), work( j & + call stdlib${ii}$_drot( 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 ) @@ -15604,81 +15606,81 @@ module stdlib_linalg_lapack_d 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_dlargv( nr, ab( kd1, j1-kd1 ), inca,work( j1 ), kd1, d( j1 )& + call stdlib${ii}$_dlargv( 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_dlartv or stdlib_drot is used - if( nr>2*kd-1 ) then + ! stdlib${ii}$_dlartv or stdlib${ii}$_drot is used + if( nr>2_${ik}$*kd-1 ) then do l = 1, kd - 1 - call stdlib_dlartv( nr, ab( kd1-l, j1-kd1+l ), inca,ab( kd1-l+1, & + call stdlib${ii}$_dlartv( 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_drot( kdm1, ab( kd, jinc-kd ), incx,ab( kd1, jinc-kd )& + call stdlib${ii}$_drot( 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_dlartg( ab( k-1, i ), ab( k, i ),d( i+k-1 ), work( i+k-1 & + call stdlib${ii}$_dlartg( 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_drot( k-3, ab( k-2, i+1 ), ldab-1,ab( k-1, i+1 ), ldab-1,& + call stdlib${ii}$_drot( 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_dlar2v( nr, ab( 1, j1-1 ), ab( 1, j1 ),ab( 2, j1-1 ),& + if( nr>0_${ik}$ )call stdlib${ii}$_dlar2v( 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_dlartv or stdlib_drot is used - if( nr>0 ) then - if( nr>2*kd-1 ) then + ! stdlib${ii}$_dlartv or stdlib${ii}$_drot 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_dlartv( nrt, ab( l+2, j1-1 ), inca,ab( l+1,& + if( nrt>0_${ik}$ )call stdlib${ii}$_dlartv( 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_drot( kdm1, ab( 3, j1inc-1 ), 1,ab( 2, j1inc ), 1, & + call stdlib${ii}$_drot( 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_drot( lend, ab( 3, last-1 ), 1,ab( 2, last ),& - 1, d( last ),work( last ) ) + if( lend>0_${ik}$ )call stdlib${ii}$_drot( 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 @@ -15687,30 +15689,30 @@ module stdlib_linalg_lapack_d ! 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_drot( nq, q( iqb, j-1 ), 1, q( iqb, j ),1, d( j ), & + call stdlib${ii}$_drot( 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_drot( n, q( 1, j-1 ), 1, q( 1, j ), 1,d( j ), work( j & + call stdlib${ii}$_drot( 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 @@ -15721,10 +15723,10 @@ module stdlib_linalg_lapack_d 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 @@ -15734,14 +15736,14 @@ module stdlib_linalg_lapack_d 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_dsbtrd + end subroutine stdlib${ii}$_dsbtrd - pure subroutine stdlib_dsfrk( transr, uplo, trans, n, k, alpha, a, lda, beta,c ) + pure subroutine stdlib${ii}$_dsfrk( transr, uplo, trans, n, k, alpha, a, lda, beta,c ) !! Level 3 BLAS like routine for C in RFP Format. !! DSFRK performs one of the symmetric rank--k operations !! C := alpha*A*A**T + beta*C, @@ -15755,7 +15757,7 @@ module stdlib_linalg_lapack_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, n + integer(${ik}$), intent(in) :: k, lda, n character, intent(in) :: trans, transr, uplo ! Array Arguments real(dp), intent(in) :: a(lda,*) @@ -15764,12 +15766,12 @@ module stdlib_linalg_lapack_d ! 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' ) @@ -15779,26 +15781,26 @@ module stdlib_linalg_lapack_d 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( 'DSPGST', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DSPGST', -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 + 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_dtpsv( uplo, 'TRANSPOSE', 'NONUNIT', j, bp,ap( j1 ), 1 ) - call stdlib_dspmv( uplo, j-1, -one, ap, bp( j1 ), 1, one,ap( j1 ), 1 ) - call stdlib_dscal( j-1, one / bjj, ap( j1 ), 1 ) - ap( jj ) = ( ap( jj )-stdlib_ddot( j-1, ap( j1 ), 1, bp( j1 ),1 ) ) / & + call stdlib${ii}$_dtpsv( uplo, 'TRANSPOSE', 'NONUNIT', j, bp,ap( j1 ), 1_${ik}$ ) + call stdlib${ii}$_dspmv( uplo, j-1, -one, ap, bp( j1 ), 1_${ik}$, one,ap( j1 ), 1_${ik}$ ) + call stdlib${ii}$_dscal( j-1, one / bjj, ap( j1 ), 1_${ik}$ ) + ap( jj ) = ( ap( jj )-stdlib${ii}$_ddot( 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_idamax( k-1, ap( kc ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_idamax( 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 @@ -16196,7 +16198,7 @@ module stdlib_linalg_lapack_d 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 ) ) @@ -16204,9 +16206,9 @@ module stdlib_linalg_lapack_d end if kx = kx + j end do - kpc = ( imax-1 )*imax / 2 + 1 - if( imax>1 ) then - jmax = stdlib_idamax( imax-1, ap( kpc ), 1 ) + kpc = ( imax-1 )*imax / 2_${ik}$ + 1_${ik}$ + if( imax>1_${ik}$ ) then + jmax = stdlib${ii}$_idamax( imax-1, ap( kpc ), 1_${ik}$ ) rowmax = max( rowmax, abs( ap( kpc+jmax-1 ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then @@ -16220,18 +16222,18 @@ module stdlib_linalg_lapack_d ! interchange rows and columns k-1 and imax, use 2-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_dswap( kp-1, ap( knc ), 1, ap( kpc ), 1 ) - kx = kpc + kp - 1 + call stdlib${ii}$_dswap( 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 @@ -16239,23 +16241,23 @@ module stdlib_linalg_lapack_d 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 + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u ! perform a rank-1 update of a(1:k-1,1:k-1) as ! a := a - u(k)*d(k)*u(k)**t = a - w(k)*1/d(k)*w(k)**t r1 = one / ap( kc+k-1 ) - call stdlib_dspr( uplo, k-1, -r1, ap( kc ), 1, ap ) + call stdlib${ii}$_dspr( uplo, k-1, -r1, ap( kc ), 1_${ik}$, ap ) ! store u(k) in column k - call stdlib_dscal( k-1, r1, ap( kc ), 1 ) + call stdlib${ii}$_dscal( k-1, r1, ap( kc ), 1_${ik}$ ) else ! 2-by-2 pivot block d(k): columns k and k-1 now hold ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k) @@ -16264,29 +16266,29 @@ module stdlib_linalg_lapack_d ! perform a rank-2 update of a(1:k-2,1:k-2) as ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**t ! = a - ( 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 @@ -16300,28 +16302,28 @@ module stdlib_linalg_lapack_d ! 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 = 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 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 @@ -16339,9 +16341,9 @@ module stdlib_linalg_lapack_d 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 @@ -16355,19 +16357,19 @@ module stdlib_linalg_lapack_d ! interchange rows and columns k+1 and imax, use 2-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 = 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. ap( kc+k-1 ) = one / ap( kc+k-1 ) ! compute column k of the inverse. - if( k>1 ) then - call stdlib_dcopy( k-1, ap( kc ), 1, work, 1 ) - call stdlib_dspmv( uplo, k-1, -one, ap, work, 1, zero, ap( kc ),1 ) - ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib_ddot( k-1, work, 1, ap( kc ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_dcopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_dspmv( uplo, k-1, -one, ap, work, 1_${ik}$, zero, ap( kc ),1_${ik}$ ) + ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_ddot( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ ) end if - kstep = 1 + kstep = 1_${ik}$ else ! 2 x 2 diagonal block ! invert the diagonal block. @@ -16530,30 +16532,30 @@ module stdlib_linalg_lapack_d 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_dcopy( k-1, ap( kc ), 1, work, 1 ) - call stdlib_dspmv( uplo, k-1, -one, ap, work, 1, zero, ap( kc ),1 ) - ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib_ddot( k-1, work, 1, ap( kc ), 1 ) - ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib_ddot( k-1, ap( kc ), 1, ap( & - kcnext ),1 ) - call stdlib_dcopy( k-1, ap( kcnext ), 1, work, 1 ) - call stdlib_dspmv( uplo, k-1, -one, ap, work, 1, zero,ap( kcnext ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_dcopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_dspmv( uplo, k-1, -one, ap, work, 1_${ik}$, zero, ap( kc ),1_${ik}$ ) + ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_ddot( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ ) + ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib${ii}$_ddot( k-1, ap( kc ), 1_${ik}$, ap( & + kcnext ),1_${ik}$ ) + call stdlib${ii}$_dcopy( k-1, ap( kcnext ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_dspmv( uplo, k-1, -one, ap, work, 1_${ik}$, zero,ap( kcnext ), 1_${ik}$ ) - ap( kcnext+k ) = ap( kcnext+k ) -stdlib_ddot( k-1, work, 1, ap( kcnext ), 1 ) + ap( kcnext+k ) = ap( kcnext+k ) -stdlib${ii}$_ddot( 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_dswap( kp-1, ap( kc ), 1, ap( kpc ), 1 ) - kx = kpc + kp - 1 + kpc = ( kp-1 )*kp / 2_${ik}$ + 1_${ik}$ + call stdlib${ii}$_dswap( kp-1, ap( kc ), 1_${ik}$, ap( kpc ), 1_${ik}$ ) + kx = kpc + kp - 1_${ik}$ do j = kp + 1, k - 1 - kx = kx + j - 1 + kx = kx + j - 1_${ik}$ temp = ap( kc+j-1 ) ap( kc+j-1 ) = ap( kx ) ap( kx ) = temp @@ -16561,7 +16563,7 @@ module stdlib_linalg_lapack_d 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 @@ -16575,25 +16577,25 @@ module stdlib_linalg_lapack_d ! 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 + 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. ap( kc ) = one / ap( kc ) ! compute column k of the inverse. if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_dger( k-1, nrhs, -one, ap( kc ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb ) + call stdlib${ii}$_dger( k-1, nrhs, -one, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb ) ! multiply by the inverse of the diagonal block. - call stdlib_dscal( nrhs, one / ap( kc+k-1 ), b( k, 1 ), ldb ) - k = k - 1 + call stdlib${ii}$_dscal( nrhs, one / ap( kc+k-1 ), b( k, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( kp/=k-1 )call stdlib_dswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib${ii}$_dswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - call stdlib_dger( k-2, nrhs, -one, ap( kc ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb ) + call stdlib${ii}$_dger( k-2, nrhs, -one, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb ) - call stdlib_dger( k-2, nrhs, -one, ap( kc-( k-1 ) ), 1,b( k-1, 1 ), ldb, b( 1, 1 & + call stdlib${ii}$_dger( k-2, nrhs, -one, ap( kc-( k-1 ) ), 1_${ik}$,b( k-1, 1_${ik}$ ), ldb, b( 1_${ik}$, 1_${ik}$ & ), ldb ) ! multiply by the inverse of the diagonal block. akm1k = ap( kc+k-2 ) @@ -16739,43 +16741,43 @@ module stdlib_linalg_lapack_d 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 = 1_${ik}$ + kc = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(u**t(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, ap( kc ),1, one, b( k, & - 1 ), ldb ) + call stdlib${ii}$_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, ap( kc ),1_${ik}$, one, b( k, & + 1_${ik}$ ), ldb ) ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_dswap( 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 ! 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_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, ap( kc ),1, one, b( k, & - 1 ), ldb ) - call stdlib_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb,ap( kc+k ), 1, one, b( k+& - 1, 1 ), ldb ) + call stdlib${ii}$_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, ap( kc ),1_${ik}$, one, b( k, & + 1_${ik}$ ), ldb ) + call stdlib${ii}$_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb,ap( kc+k ), 1_${ik}$, one, b( k+& + 1_${ik}$, 1_${ik}$ ), ldb ) ! interchange rows k and -ipiv(k). kp = -ipiv( k ) - if( kp/=k )call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - kc = kc + 2*k + 1 - k = k + 2 + if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + kc = kc + 2_${ik}$*k + 1_${ik}$ + k = k + 2_${ik}$ end if go to 40 50 continue @@ -16784,36 +16786,36 @@ module stdlib_linalg_lapack_d ! 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 = 1_${ik}$ + kc = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(l**t(k)), where l(k) is the transformation ! stored in column k of a. - if( k=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( 'DSTEBZ', -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( 'DSTEBZ', -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 ! if only scalar is to be done. - safemn = stdlib_dlamch( 'S' ) - ulp = stdlib_dlamch( 'P' ) + safemn = stdlib${ii}$_dlamch( 'S' ) + ulp = stdlib${ii}$_dlamch( 'P' ) rtoli = ulp*relfac - nb = stdlib_ilaenv( 1, 'DSTEBZ', ' ', n, -1, -1, -1 ) - if( nb<=1 )nb = 0 + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSTEBZ', ' ', n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ )nb = 0_${ik}$ ! 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 @@ -16999,13 +17001,13 @@ module stdlib_linalg_lapack_d 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 ) ) @@ -17019,7 +17021,7 @@ module stdlib_linalg_lapack_d 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 @@ -17031,36 +17033,36 @@ module stdlib_linalg_lapack_d 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_dlaebz( 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}$_dlaebz( 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 @@ -17069,7 +17071,7 @@ module stdlib_linalg_lapack_d else atoli = abstol end if - if( irange==2 ) then + if( irange==2_${ik}$ ) then wl = vl wu = vu else @@ -17080,23 +17082,23 @@ module stdlib_linalg_lapack_d ! 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 + if( in==1_${ik}$ ) 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( 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 @@ -17124,7 +17126,7 @@ module stdlib_linalg_lapack_d 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] @@ -17197,52 +17199,52 @@ module stdlib_linalg_lapack_d ! 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 @@ -17327,7 +17329,7 @@ module stdlib_linalg_lapack_d ! 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 @@ -17352,9 +17354,9 @@ module stdlib_linalg_lapack_d 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 @@ -17379,7 +17381,7 @@ module stdlib_linalg_lapack_d ! 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 @@ -17391,10 +17393,10 @@ module stdlib_linalg_lapack_d 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) @@ -17418,7 +17420,7 @@ module stdlib_linalg_lapack_d 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) @@ -17434,9 +17436,9 @@ module stdlib_linalg_lapack_d ! 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) @@ -17446,7 +17448,7 @@ module stdlib_linalg_lapack_d 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) @@ -17457,9 +17459,9 @@ module stdlib_linalg_lapack_d 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 @@ -17468,10 +17470,10 @@ module stdlib_linalg_lapack_d end if end if return - end subroutine stdlib_dsyconv + end subroutine stdlib${ii}$_dsyconv - pure subroutine stdlib_dsyconvf( uplo, way, n, a, lda, e, ipiv, info ) + pure subroutine stdlib${ii}$_dsyconvf( uplo, way, n, a, lda, e, ipiv, info ) !! If parameter WAY = 'C': !! DSYCONVF converts the factorization output format used in !! DSYTRF provided on entry in parameter A into the factorization @@ -17492,31 +17494,31 @@ module stdlib_linalg_lapack_d ! -- 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(dp), 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 i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(1:i,n-i:n) ip = ipiv( i ) if( i0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(1: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 @@ -17629,40 +17631,40 @@ module stdlib_linalg_lapack_d ! 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 + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(i:n,1:i-1) ip = ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_dswap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_dswap( 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) ip = -ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=(i+1) ) then - call stdlib_dswap( i-1, a( i+1, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_dswap( i-1, a( i+1, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda ) end if end if ! convert ipiv @@ -17670,9 +17672,9 @@ module stdlib_linalg_lapack_d ! 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) @@ -17681,23 +17683,23 @@ module stdlib_linalg_lapack_d ! in reverse factorization order where i decreases from n to 1 i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(i:n,1:i-1) ip = ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_dswap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) + call stdlib${ii}$_dswap( 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 + i = i - 1_${ik}$ ip = -ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=(i+1) ) then - call stdlib_dswap( i-1, a( ip, 1 ), lda,a( i+1, 1 ), lda ) + call stdlib${ii}$_dswap( i-1, a( ip, 1_${ik}$ ), lda,a( i+1, 1_${ik}$ ), lda ) end if end if ! convert ipiv @@ -17706,27 +17708,27 @@ module stdlib_linalg_lapack_d ! 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_dsyconvf + end subroutine stdlib${ii}$_dsyconvf - pure subroutine stdlib_dsyconvf_rook( uplo, way, n, a, lda, e, ipiv, info ) + pure subroutine stdlib${ii}$_dsyconvf_rook( uplo, way, n, a, lda, e, ipiv, info ) !! If parameter WAY = 'C': !! DSYCONVF_ROOK converts the factorization output format used in !! DSYTRF_ROOK provided on entry in parameter A into the factorization @@ -17745,31 +17747,31 @@ module stdlib_linalg_lapack_d ! -- 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(dp), 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 i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(1:i,n-i:n) ip = ipiv( i ) if( i0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(1: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 @@ -17882,31 +17884,31 @@ module stdlib_linalg_lapack_d ! 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 + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(i:n,1:i-1) ip = ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_dswap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_dswap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda ) end if end if else @@ -17915,17 +17917,17 @@ module stdlib_linalg_lapack_d ! in a(i:n,1:i-1) ip = -ipiv( i ) ip2 = -ipiv( i+1 ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_dswap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_dswap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda ) end if if( ip2/=(i+1) ) then - call stdlib_dswap( i-1, a( i+1, 1 ), lda,a( ip2, 1 ), lda ) + call stdlib${ii}$_dswap( 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) @@ -17934,52 +17936,52 @@ module stdlib_linalg_lapack_d ! in reverse factorization order where i decreases from n to 1 i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(i:n,1:i-1) ip = ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_dswap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) + call stdlib${ii}$_dswap( 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+1) and i and ipiv(i) ! in a(i:n,1:i-1) - i = 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_dswap( i-1, a( ip2, 1 ), lda,a( i+1, 1 ), lda ) + call stdlib${ii}$_dswap( i-1, a( ip2, 1_${ik}$ ), lda,a( i+1, 1_${ik}$ ), lda ) end if if( ip/=i ) then - call stdlib_dswap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) + call stdlib${ii}$_dswap( 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_dsyconvf_rook + end subroutine stdlib${ii}$_dsyconvf_rook - pure subroutine stdlib_dsyequb( uplo, n, a, lda, s, scond, amax, work, info ) + pure subroutine stdlib${ii}$_dsyequb( uplo, n, a, lda, s, scond, amax, work, info ) !! DSYEQUB computes row and column scalings intended to equilibrate a !! symmetric matrix A (with respect to the Euclidean norm) and reduce !! its condition number. The scale factors S are computed by the BIN @@ -17991,8 +17993,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(out) :: amax, scond character, intent(in) :: uplo ! Array Arguments @@ -18000,11 +18002,11 @@ module stdlib_linalg_lapack_d real(dp), 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(dp) :: avg, std, tol, c0, c1, c2, t, u, si, d, base, smin, smax, smlnum, bignum, & scale, sumsq logical(lk) :: up @@ -18012,22 +18014,22 @@ module stdlib_linalg_lapack_d 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( 'DSYEQUB', -info ) + if ( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DSYEQUB', -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 @@ -18094,7 +18096,7 @@ module stdlib_linalg_lapack_d do i = n+1, 2*n work( i ) = s( i-n ) * work( i-n ) - avg end do - call stdlib_dlassq( n, work( n+1 ), 1, scale, sumsq ) + call stdlib${ii}$_dlassq( n, work( n+1 ), 1_${ik}$, scale, sumsq ) std = scale * sqrt( sumsq / n ) if ( std < tol * avg ) goto 999 do i = 1, n @@ -18102,13 +18104,13 @@ module stdlib_linalg_lapack_d 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 @@ -18139,23 +18141,23 @@ module stdlib_linalg_lapack_d end do end do 999 continue - smlnum = stdlib_dlamch( 'SAFEMIN' ) + smlnum = stdlib${ii}$_dlamch( 'SAFEMIN' ) bignum = one / smlnum smin = bignum smax = zero t = one / sqrt( avg ) - base = stdlib_dlamch( 'B' ) + base = stdlib${ii}$_dlamch( '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_dsyequb + end subroutine stdlib${ii}$_dsyequb - pure subroutine stdlib_dsygs2( itype, uplo, n, a, lda, b, ldb, info ) + pure subroutine stdlib${ii}$_dsygs2( itype, uplo, n, a, lda, b, ldb, info ) !! DSYGS2 reduces a real symmetric-definite generalized eigenproblem !! to standard form. !! If ITYPE = 1, the problem is A*x = lambda*B*x, @@ -18168,8 +18170,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: b(ldb,*) @@ -18177,46 +18179,46 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: upper - integer(ilp) :: k + integer(${ik}$) :: k real(dp) :: 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}$, 'DSYGST', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code - call stdlib_dsygs2( itype, uplo, n, a, lda, b, ldb, info ) + call stdlib${ii}$_dsygs2( 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_dsygs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib${ii}$_dsygs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) if( k+kb<=n ) then - call stdlib_dtrsm( 'LEFT', uplo, 'TRANSPOSE', 'NON-UNIT',kb, n-k-kb+1, & + call stdlib${ii}$_dtrsm( 'LEFT', uplo, 'TRANSPOSE', 'NON-UNIT',kb, n-k-kb+1, & one, b( k, k ), ldb,a( k, k+kb ), lda ) - call stdlib_dsymm( 'LEFT', uplo, kb, n-k-kb+1, -half,a( k, k ), lda, b( & + call stdlib${ii}$_dsymm( '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_dsyr2k( uplo, 'TRANSPOSE', n-k-kb+1, kb, -one,a( k, k+kb ), & + call stdlib${ii}$_dsyr2k( 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_dsymm( 'LEFT', uplo, kb, n-k-kb+1, -half,a( k, k ), lda, b( & + call stdlib${ii}$_dsymm( '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_dtrsm( '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}$_dtrsm( '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 @@ -18357,18 +18359,18 @@ module stdlib_linalg_lapack_d do k = 1, n, nb kb = min( n-k+1, nb ) ! update the lower triangle of a(k:n,k:n) - call stdlib_dsygs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib${ii}$_dsygs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) if( k+kb<=n ) then - call stdlib_dtrsm( 'RIGHT', uplo, 'TRANSPOSE', 'NON-UNIT',n-k-kb+1, kb, & + call stdlib${ii}$_dtrsm( 'RIGHT', uplo, 'TRANSPOSE', 'NON-UNIT',n-k-kb+1, kb, & one, b( k, k ), ldb,a( k+kb, k ), lda ) - call stdlib_dsymm( 'RIGHT', uplo, n-k-kb+1, kb, -half,a( k, k ), lda, b(& + call stdlib${ii}$_dsymm( '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_dsyr2k( uplo, 'NO TRANSPOSE', n-k-kb+1, kb,-one, a( k+kb, k & + call stdlib${ii}$_dsyr2k( 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_dsymm( 'RIGHT', uplo, n-k-kb+1, kb, -half,a( k, k ), lda, b(& + call stdlib${ii}$_dsymm( '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_dtrsm( 'LEFT', uplo, 'NO TRANSPOSE','NON-UNIT', n-k-kb+1, & + call stdlib${ii}$_dtrsm( '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 @@ -18379,17 +18381,17 @@ module stdlib_linalg_lapack_d 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_dtrmm( 'LEFT', uplo, 'NO TRANSPOSE', 'NON-UNIT',k-1, kb, one, & - b, ldb, a( 1, k ), lda ) - call stdlib_dsymm( 'RIGHT', uplo, k-1, kb, half, a( k, k ),lda, b( 1, k ), & - ldb, one, a( 1, k ), lda ) - call stdlib_dsyr2k( uplo, 'NO TRANSPOSE', k-1, kb, one,a( 1, k ), lda, b( & - 1, k ), ldb, one, a,lda ) - call stdlib_dsymm( 'RIGHT', uplo, k-1, kb, half, a( k, k ),lda, b( 1, k ), & - ldb, one, a( 1, k ), lda ) - call stdlib_dtrmm( 'RIGHT', uplo, 'TRANSPOSE', 'NON-UNIT',k-1, kb, one, b( & - k, k ), ldb, a( 1, k ),lda ) - call stdlib_dsygs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib${ii}$_dtrmm( 'LEFT', uplo, 'NO TRANSPOSE', 'NON-UNIT',k-1, kb, one, & + b, ldb, a( 1_${ik}$, k ), lda ) + call stdlib${ii}$_dsymm( 'RIGHT', uplo, k-1, kb, half, a( k, k ),lda, b( 1_${ik}$, k ), & + ldb, one, a( 1_${ik}$, k ), lda ) + call stdlib${ii}$_dsyr2k( uplo, 'NO TRANSPOSE', k-1, kb, one,a( 1_${ik}$, k ), lda, b( & + 1_${ik}$, k ), ldb, one, a,lda ) + call stdlib${ii}$_dsymm( 'RIGHT', uplo, k-1, kb, half, a( k, k ),lda, b( 1_${ik}$, k ), & + ldb, one, a( 1_${ik}$, k ), lda ) + call stdlib${ii}$_dtrmm( 'RIGHT', uplo, 'TRANSPOSE', 'NON-UNIT',k-1, kb, one, b( & + k, k ), ldb, a( 1_${ik}$, k ),lda ) + call stdlib${ii}$_dsygs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) end do else @@ -18397,27 +18399,27 @@ module stdlib_linalg_lapack_d 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_dtrmm( 'RIGHT', uplo, 'NO TRANSPOSE', 'NON-UNIT',kb, k-1, one, & - b, ldb, a( k, 1 ), lda ) - call stdlib_dsymm( 'LEFT', uplo, kb, k-1, half, a( k, k ),lda, b( k, 1 ), & - ldb, one, a( k, 1 ), lda ) - call stdlib_dsyr2k( uplo, 'TRANSPOSE', k-1, kb, one,a( k, 1 ), lda, b( k, & - 1 ), ldb, one, a,lda ) - call stdlib_dsymm( 'LEFT', uplo, kb, k-1, half, a( k, k ),lda, b( k, 1 ), & - ldb, one, a( k, 1 ), lda ) - call stdlib_dtrmm( 'LEFT', uplo, 'TRANSPOSE', 'NON-UNIT', kb,k-1, one, b( & - k, k ), ldb, a( k, 1 ), lda ) - call stdlib_dsygs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib${ii}$_dtrmm( 'RIGHT', uplo, 'NO TRANSPOSE', 'NON-UNIT',kb, k-1, one, & + b, ldb, a( k, 1_${ik}$ ), lda ) + call stdlib${ii}$_dsymm( 'LEFT', uplo, kb, k-1, half, a( k, k ),lda, b( k, 1_${ik}$ ), & + ldb, one, a( k, 1_${ik}$ ), lda ) + call stdlib${ii}$_dsyr2k( uplo, 'TRANSPOSE', k-1, kb, one,a( k, 1_${ik}$ ), lda, b( k, & + 1_${ik}$ ), ldb, one, a,lda ) + call stdlib${ii}$_dsymm( 'LEFT', uplo, kb, k-1, half, a( k, k ),lda, b( k, 1_${ik}$ ), & + ldb, one, a( k, 1_${ik}$ ), lda ) + call stdlib${ii}$_dtrmm( 'LEFT', uplo, 'TRANSPOSE', 'NON-UNIT', kb,k-1, one, b( & + k, k ), ldb, a( k, 1_${ik}$ ), lda ) + call stdlib${ii}$_dsygs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) end do end if end if end if return - end subroutine stdlib_dsygst + end subroutine stdlib${ii}$_dsygst - pure subroutine stdlib_dsyswapr( uplo, n, a, lda, i1, i2) + pure subroutine stdlib${ii}$_dsyswapr( uplo, n, a, lda, i1, i2) !! DSYSWAPR applies an elementary permutation on the rows and the columns of !! a symmetric matrix. ! -- lapack auxiliary routine -- @@ -18425,13 +18427,13 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,n) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: i + integer(${ik}$) :: i real(dp) :: tmp ! Executable Statements upper = stdlib_lsame( uplo, 'U' ) @@ -18439,7 +18441,7 @@ module stdlib_linalg_lapack_d ! upper ! first swap ! - swap column i1 and i2 from i1 to i1-1 - call stdlib_dswap( i1-1, a(1,i1), 1, a(1,i2), 1 ) + call stdlib${ii}$_dswap( 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 @@ -18462,7 +18464,7 @@ module stdlib_linalg_lapack_d ! lower ! first swap ! - swap row i1 and i2 from i1 to i1-1 - call stdlib_dswap( i1-1, a(i1,1), lda, a(i2,1), lda ) + call stdlib${ii}$_dswap( 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 @@ -18482,10 +18484,10 @@ module stdlib_linalg_lapack_d a(i,i2)=tmp end do endif - end subroutine stdlib_dsyswapr + end subroutine stdlib${ii}$_dsyswapr - pure subroutine stdlib_dsytf2_rk( uplo, n, a, lda, e, ipiv, info ) + pure subroutine stdlib${ii}$_dsytf2_rk( uplo, n, a, lda, e, ipiv, info ) !! DSYTF2_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), @@ -18500,10 +18502,10 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: e(*) ! ===================================================================== @@ -18513,42 +18515,42 @@ module stdlib_linalg_lapack_d ! 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(dp) :: absakk, alpha, colmax, d11, d12, d21, d22, rowmax, dtemp, 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_idamax( k-1, a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_idamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ ) colmax = abs( a( imax, k ) ) else colmax = zero end if if( (max( absakk, colmax )==zero) ) then ! column k is zero or underflow: set info and continue - if( info==0 )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) @@ -18585,13 +18587,13 @@ module stdlib_linalg_lapack_d ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = imax + stdlib_idamax( k-imax, a( imax, imax+1 ),lda ) + jmax = imax + stdlib${ii}$_idamax( k-imax, a( imax, imax+1 ),lda ) rowmax = abs( a( imax, jmax ) ) else rowmax = zero end if - if( imax>1 ) then - itemp = stdlib_idamax( imax-1, a( 1, imax ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_idamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ ) dtemp = abs( a( itemp, imax ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -18611,7 +18613,7 @@ module stdlib_linalg_lapack_d ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found, set variables and repeat @@ -18624,45 +18626,45 @@ module stdlib_linalg_lapack_d end if ! swap two rows and two columns ! first swap - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! interchange rows and column k and p in the leading ! submatrix a(1:k,1:k) if we have a 2-by-2 pivot - if( p>1 )call stdlib_dswap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) - if( p<(k-1) )call stdlib_dswap( k-p-1, a( p+1, k ), 1, a( p, p+1 ),lda ) + if( p>1_${ik}$ )call stdlib${ii}$_dswap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) + if( p<(k-1) )call stdlib${ii}$_dswap( k-p-1, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda ) t = a( k, k ) a( k, k ) = a( p, p ) a( p, p ) = t ! convert upper triangle of a into u form by applying ! the interchanges in columns k+1:n. - if( k1 )call stdlib_dswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) - if( ( kk>1 ) .and. ( kp<(kk-1) ) )call stdlib_dswap( kk-kp-1, a( kp+1, kk ), & - 1, a( kp, kp+1 ),lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_dswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + if( ( kk>1_${ik}$ ) .and. ( kp<(kk-1) ) )call stdlib${ii}$_dswap( kk-kp-1, a( kp+1, kk ), & + 1_${ik}$, a( kp, kp+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t - if( kstep==2 ) 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 + if( k>1_${ik}$ ) then ! perform a rank-1 update of a(1:k-1,1:k-1) and ! store u(k) in column k if( abs( a( k, k ) )>=sfmin ) then @@ -18670,9 +18672,9 @@ module stdlib_linalg_lapack_d ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*1/d(k)*w(k)**t d11 = one / a( k, k ) - call stdlib_dsyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_dsyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) ! store u(k) in column k - call stdlib_dscal( k-1, d11, a( 1, k ), 1 ) + call stdlib${ii}$_dscal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = a( k, k ) @@ -18683,7 +18685,7 @@ module stdlib_linalg_lapack_d ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_dsyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_dsyr( 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 @@ -18697,7 +18699,7 @@ module stdlib_linalg_lapack_d ! 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 @@ -18723,7 +18725,7 @@ module stdlib_linalg_lapack_d ! 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 @@ -18739,11 +18741,11 @@ module stdlib_linalg_lapack_d e( n ) = zero ! k is the main loop index, increasing from 1 to n in steps of ! 1 or 2 - k = 1 + 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 @@ -18752,14 +18754,14 @@ module stdlib_linalg_lapack_d ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( krowmax ) then rowmax = dtemp @@ -18805,7 +18807,7 @@ module stdlib_linalg_lapack_d ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found, set variables and repeat @@ -18818,42 +18820,42 @@ module stdlib_linalg_lapack_d end if ! swap two rows and two columns ! first swap - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! interchange rows and column k and p in the trailing ! submatrix a(k:n,k:n) if we have a 2-by-2 pivot - if( p(k+1) )call stdlib_dswap( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) + if( p(k+1) )call stdlib${ii}$_dswap( p-k-1, a( k+1, k ), 1_${ik}$, a( p, k+1 ), lda ) t = a( k, k ) a( k, k ) = a( p, p ) a( p, p ) = t ! convert lower triangle of a into l form by applying ! the interchanges in columns 1:k-1. - if ( k>1 )call stdlib_dswap( k-1, a( k, 1 ), lda, a( p, 1 ), lda ) + if ( k>1_${ik}$ )call stdlib${ii}$_dswap( 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_dswap( kp-kk-1, a( kk+1, kk ), & - 1, a( kp, kk+1 ),lda ) + if( ( kk(kk+1) ) )call stdlib${ii}$_dswap( kp-kk-1, a( kk+1, kk ), & + 1_${ik}$, a( kp, kk+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t - if( kstep==2 ) 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_dswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) + if ( k>1_${ik}$ )call stdlib${ii}$_dswap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) end if ! update the trailing submatrix - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = l(k)*d(k) ! where l(k) is the k-th column of l @@ -18865,10 +18867,10 @@ module stdlib_linalg_lapack_d ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t d11 = one / a( k, k ) - call stdlib_dsyr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_dsyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda ) ! store l(k) in column k - call stdlib_dscal( n-k, d11, a( k+1, k ), 1 ) + call stdlib${ii}$_dscal( n-k, d11, a( k+1, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = a( k, k ) @@ -18879,7 +18881,7 @@ module stdlib_linalg_lapack_d ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_dsyr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_dsyr( 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 @@ -18922,7 +18924,7 @@ module stdlib_linalg_lapack_d ! 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 @@ -18934,10 +18936,10 @@ module stdlib_linalg_lapack_d 64 continue end if return - end subroutine stdlib_dsytf2_rk + end subroutine stdlib${ii}$_dsytf2_rk - pure subroutine stdlib_dsytf2_rook( uplo, n, a, lda, ipiv, info ) + pure subroutine stdlib${ii}$_dsytf2_rook( uplo, n, a, lda, ipiv, info ) !! DSYTF2_ROOK computes the factorization of a real symmetric matrix A !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method: !! A = U*D*U**T or A = L*D*L**T @@ -18950,10 +18952,10 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*) ! ===================================================================== ! Parameters @@ -18962,30 +18964,30 @@ module stdlib_linalg_lapack_d ! 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(dp) :: absakk, alpha, colmax, d11, d12, d21, d22, rowmax, dtemp, 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_idamax( k-1, a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_idamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ ) colmax = abs( a( imax, k ) ) else colmax = zero end if if( (max( absakk, colmax )==zero) ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k else ! test for interchange @@ -19029,13 +19031,13 @@ module stdlib_linalg_lapack_d ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = imax + stdlib_idamax( k-imax, a( imax, imax+1 ),lda ) + jmax = imax + stdlib${ii}$_idamax( k-imax, a( imax, imax+1 ),lda ) rowmax = abs( a( imax, jmax ) ) else rowmax = zero end if - if( imax>1 ) then - itemp = stdlib_idamax( imax-1, a( 1, imax ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_idamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ ) dtemp = abs( a( itemp, imax ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -19055,7 +19057,7 @@ module stdlib_linalg_lapack_d ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found, set variables and repeat @@ -19068,39 +19070,39 @@ module stdlib_linalg_lapack_d end if ! swap two rows and two columns ! first swap - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! interchange rows and column k and p in the leading ! submatrix a(1:k,1:k) if we have a 2-by-2 pivot - if( p>1 )call stdlib_dswap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) - if( p<(k-1) )call stdlib_dswap( k-p-1, a( p+1, k ), 1, a( p, p+1 ),lda ) + if( p>1_${ik}$ )call stdlib${ii}$_dswap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) + if( p<(k-1) )call stdlib${ii}$_dswap( k-p-1, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda ) t = a( k, k ) a( k, k ) = a( p, p ) a( p, p ) = t end if ! second swap - kk = k - kstep + 1 + 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_dswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) - if( ( kk>1 ) .and. ( kp<(kk-1) ) )call stdlib_dswap( kk-kp-1, a( kp+1, kk ), & - 1, a( kp, kp+1 ),lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_dswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + if( ( kk>1_${ik}$ ) .and. ( kp<(kk-1) ) )call stdlib${ii}$_dswap( kk-kp-1, a( kp+1, kk ), & + 1_${ik}$, a( kp, kp+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t - if( kstep==2 ) 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 + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u - if( k>1 ) then + if( k>1_${ik}$ ) then ! perform a rank-1 update of a(1:k-1,1:k-1) and ! store u(k) in column k if( abs( a( k, k ) )>=sfmin ) then @@ -19108,9 +19110,9 @@ module stdlib_linalg_lapack_d ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*1/d(k)*w(k)**t d11 = one / a( k, k ) - call stdlib_dsyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_dsyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) ! store u(k) in column k - call stdlib_dscal( k-1, d11, a( 1, k ), 1 ) + call stdlib${ii}$_dscal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = a( k, k ) @@ -19121,7 +19123,7 @@ module stdlib_linalg_lapack_d ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_dsyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_dsyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) end if end if else @@ -19133,7 +19135,7 @@ module stdlib_linalg_lapack_d ! 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 @@ -19153,7 +19155,7 @@ module stdlib_linalg_lapack_d 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 @@ -19166,11 +19168,11 @@ module stdlib_linalg_lapack_d ! 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 = 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 @@ -19179,14 +19181,14 @@ module stdlib_linalg_lapack_d ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( krowmax ) then rowmax = dtemp @@ -19230,7 +19232,7 @@ module stdlib_linalg_lapack_d ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found, set variables and repeat @@ -19243,36 +19245,36 @@ module stdlib_linalg_lapack_d end if ! swap two rows and two columns ! first swap - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! interchange rows and column k and p in the trailing ! submatrix a(k:n,k:n) if we have a 2-by-2 pivot - if( p(k+1) )call stdlib_dswap( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) + if( p(k+1) )call stdlib${ii}$_dswap( p-k-1, a( k+1, k ), 1_${ik}$, a( p, k+1 ), lda ) t = a( k, k ) a( k, k ) = a( p, p ) a( p, p ) = t end if ! second swap - kk = k + kstep - 1 + 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_dswap( kp-kk-1, a( kk+1, kk ), & - 1, a( kp, kk+1 ),lda ) + if( ( kk(kk+1) ) )call stdlib${ii}$_dswap( kp-kk-1, a( kk+1, kk ), & + 1_${ik}$, a( kp, kk+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t - if( kstep==2 ) 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 + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = l(k)*d(k) ! where l(k) is the k-th column of l @@ -19284,10 +19286,10 @@ module stdlib_linalg_lapack_d ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t d11 = one / a( k, k ) - call stdlib_dsyr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_dsyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda ) ! store l(k) in column k - call stdlib_dscal( n-k, d11, a( k+1, k ), 1 ) + call stdlib${ii}$_dscal( n-k, d11, a( k+1, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = a( k, k ) @@ -19298,7 +19300,7 @@ module stdlib_linalg_lapack_d ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_dsyr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_dsyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda ) end if end if @@ -19333,7 +19335,7 @@ module stdlib_linalg_lapack_d 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 @@ -19345,10 +19347,10 @@ module stdlib_linalg_lapack_d end if 70 continue return - end subroutine stdlib_dsytf2_rook + end subroutine stdlib${ii}$_dsytf2_rook - pure subroutine stdlib_dsytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) + pure subroutine stdlib${ii}$_dsytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) !! DSYTRF_RK computes the factorization of a real symmetric matrix A !! using the bounded Bunch-Kaufman (rook) diagonal pivoting method: !! A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), @@ -19363,60 +19365,60 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*) real(dp), 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_dlasyf_rk( uplo, k, nb, kb, a, lda, e,ipiv, work, ldwork, iinfo ) + call stdlib${ii}$_dlasyf_rk( uplo, k, nb, kb, a, lda, e,ipiv, work, ldwork, iinfo ) else ! use unblocked code to factorize columns 1:k of a - call stdlib_dsytf2_rk( uplo, k, a, lda, e, ipiv, iinfo ) + call stdlib${ii}$_dsytf2_rk( uplo, k, a, lda, e, ipiv, iinfo ) kb = k end if ! set info on the first occurrence of a zero pivot - if( info==0 .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 ! read ipiv from the last block factored, i.e. @@ -19446,7 +19448,7 @@ module stdlib_linalg_lapack_d do i = k, ( k - kb + 1 ), -1 ip = abs( ipiv( i ) ) if( ip/=i ) then - call stdlib_dswap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda ) + call stdlib${ii}$_dswap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda ) end if end do end if @@ -19459,31 +19461,31 @@ module stdlib_linalg_lapack_d 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_dlasyf_rk; + ! kb, where kb is the number of columns factorized by stdlib${ii}$_dlasyf_rk; ! kb is either nb or nb-1, or n-k+1 for the last block - k = 1 + k = 1_${ik}$ 20 continue ! if k > n, exit from loop if( k>n )go to 35 if( k<=n-nb ) then ! factorize columns k:k+kb-1 of a and use blocked code to ! update columns k+kb:n - call stdlib_dlasyf_rk( uplo, n-k+1, nb, kb, a( k, k ), lda, e( k ),ipiv( k ), & + call stdlib${ii}$_dlasyf_rk( uplo, n-k+1, nb, kb, a( k, k ), lda, e( k ),ipiv( k ), & work, ldwork, iinfo ) else ! use unblocked code to factorize columns k:n of a - call stdlib_dsytf2_rk( uplo, n-k+1, a( k, k ), lda, e( k ),ipiv( k ), iinfo ) + call stdlib${ii}$_dsytf2_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 @@ -19493,11 +19495,11 @@ module stdlib_linalg_lapack_d ! (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 + if( k>1_${ik}$ ) then do i = k, ( k + kb - 1 ), 1 ip = abs( ipiv( i ) ) if( ip/=i ) then - call stdlib_dswap( k-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_dswap( k-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda ) end if end do end if @@ -19509,12 +19511,12 @@ module stdlib_linalg_lapack_d 35 continue ! end lower end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_dsytrf_rk + end subroutine stdlib${ii}$_dsytrf_rk - pure subroutine stdlib_dsytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) + pure subroutine stdlib${ii}$_dsytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) !! DSYTRF_ROOK computes the factorization of a real symmetric matrix A !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. !! The form of the factorization is @@ -19528,60 +19530,60 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*) real(dp), 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_dlasyf_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo ) + call stdlib${ii}$_dlasyf_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo ) else ! use unblocked code to factorize columns 1:k of a - call stdlib_dsytf2_rook( uplo, k, a, lda, ipiv, iinfo ) + call stdlib${ii}$_dsytf2_rook( uplo, k, a, lda, ipiv, iinfo ) kb = k end if ! set info on the first occurrence of a zero pivot - if( info==0 .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 @@ -19606,30 +19608,30 @@ module stdlib_linalg_lapack_d 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_dlasyf_rook; + ! kb, where kb is the number of columns factorized by stdlib${ii}$_dlasyf_rook; ! kb is either nb or nb-1, or n-k+1 for the last block - k = 1 + 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_dlasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, & + call stdlib${ii}$_dlasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, & ldwork, iinfo ) else ! use unblocked code to factorize columns k:n of a - call stdlib_dsytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo ) - kb = n - k + 1 + call stdlib${ii}$_dsytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo ) + kb = n - k + 1_${ik}$ end if ! set info on the first occurrence of a zero pivot - if( info==0 .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 @@ -19637,12 +19639,12 @@ module stdlib_linalg_lapack_d go to 20 end if 40 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_dsytrf_rook + end subroutine stdlib${ii}$_dsytrf_rook - pure subroutine stdlib_dsytri( uplo, n, a, lda, ipiv, work, info ) + pure subroutine stdlib${ii}$_dsytri( uplo, n, a, lda, ipiv, work, info ) !! DSYTRI computes the inverse of a real symmetric indefinite matrix !! A using the factorization A = U*D*U**T or A = L*D*L**T computed by !! DSYTRF. @@ -19651,33 +19653,33 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: k, kp, kstep + integer(${ik}$) :: k, kp, kstep real(dp) :: 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 = 1_${ik}$ 30 continue ! if k > n, exit from loop. if( k>n )go to 40 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = one / a( k, k ) ! compute column k of the inverse. - if( k>1 ) then - call stdlib_dcopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_dsymv( uplo, k-1, -one, a, lda, work, 1, zero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_dcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_dsymv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - stdlib_ddot( k-1, work, 1, a( 1, k ),1 ) + a( k, k ) = a( k, k ) - stdlib${ii}$_ddot( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ ) end if - kstep = 1 + kstep = 1_${ik}$ else ! 2 x 2 diagonal block ! invert the diagonal block. @@ -19727,31 +19729,31 @@ module stdlib_linalg_lapack_d a( k+1, k+1 ) = ak / d a( k, k+1 ) = -akkp1 / d ! compute columns k and k+1 of the inverse. - if( k>1 ) then - call stdlib_dcopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_dsymv( uplo, k-1, -one, a, lda, work, 1, zero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_dcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_dsymv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - stdlib_ddot( k-1, work, 1, a( 1, k ),1 ) - a( k, k+1 ) = a( k, k+1 ) -stdlib_ddot( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) + a( k, k ) = a( k, k ) - stdlib${ii}$_ddot( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ ) + a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_ddot( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) - call stdlib_dcopy( k-1, a( 1, k+1 ), 1, work, 1 ) - call stdlib_dsymv( uplo, k-1, -one, a, lda, work, 1, zero,a( 1, k+1 ), 1 ) + call stdlib${ii}$_dcopy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_dsymv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k+1 ), 1_${ik}$ ) - a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib_ddot( k-1, work, 1, a( 1, k+1 ), 1 ) + a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib${ii}$_ddot( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) end if - kstep = 2 + 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_dswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_dswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + call stdlib${ii}$_dswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + call stdlib${ii}$_dswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp - 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 @@ -19768,18 +19770,18 @@ module stdlib_linalg_lapack_d 50 continue ! if k < 1, exit from loop. if( k<1 )go to 60 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = one / a( k, k ) ! compute column k of the inverse. if( 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 = 1_${ik}$ 30 continue ! if k > n, exit from loop. if( k>n )go to 40 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = one / a( k, k ) ! compute column k of the inverse. - if( k>1 ) then - call stdlib_dcopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_dsymv( uplo, k-1, -one, a, lda, work, 1, zero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_dcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_dsymv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - stdlib_ddot( k-1, work, 1, a( 1, k ),1 ) + a( k, k ) = a( k, k ) - stdlib${ii}$_ddot( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ ) end if - kstep = 1 + kstep = 1_${ik}$ else ! 2 x 2 diagonal block ! invert the diagonal block. @@ -19915,28 +19917,28 @@ module stdlib_linalg_lapack_d a( k+1, k+1 ) = ak / d a( k, k+1 ) = -akkp1 / d ! compute columns k and k+1 of the inverse. - if( k>1 ) then - call stdlib_dcopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_dsymv( uplo, k-1, -one, a, lda, work, 1, zero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_dcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_dsymv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - stdlib_ddot( k-1, work, 1, a( 1, k ),1 ) - a( k, k+1 ) = a( k, k+1 ) -stdlib_ddot( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) + a( k, k ) = a( k, k ) - stdlib${ii}$_ddot( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ ) + a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_ddot( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) - call stdlib_dcopy( k-1, a( 1, k+1 ), 1, work, 1 ) - call stdlib_dsymv( uplo, k-1, -one, a, lda, work, 1, zero,a( 1, k+1 ), 1 ) + call stdlib${ii}$_dcopy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_dsymv( uplo, k-1, -one, a, lda, work, 1_${ik}$, zero,a( 1_${ik}$, k+1 ), 1_${ik}$ ) - a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib_ddot( k-1, work, 1, a( 1, k+1 ), 1 ) + a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib${ii}$_ddot( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) end if - kstep = 2 + 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) kp = ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_dswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_dswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_dswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + call stdlib${ii}$_dswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp @@ -19946,8 +19948,8 @@ module stdlib_linalg_lapack_d ! -ipiv(k+1)in the leading submatrix a(1:k+1,1:k+1) kp = -ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_dswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_dswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_dswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + call stdlib${ii}$_dswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp @@ -19955,17 +19957,17 @@ module stdlib_linalg_lapack_d 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_dswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_dswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_dswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + call stdlib${ii}$_dswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp end if end if - k = k + 1 + k = k + 1_${ik}$ go to 30 40 continue else @@ -19976,18 +19978,18 @@ module stdlib_linalg_lapack_d 50 continue ! if k < 1, exit from loop. if( k<1 )go to 60 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = one / a( k, k ) ! compute column k of the inverse. if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_dger( k-1, nrhs, -one, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb ) + call stdlib${ii}$_dger( k-1, nrhs, -one, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb ) ! multiply by the inverse of the diagonal block. - call stdlib_dscal( nrhs, one / a( k, k ), b( k, 1 ), ldb ) - k = k - 1 + call stdlib${ii}$_dscal( nrhs, one / a( k, k ), b( k, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( kp/=k-1 )call stdlib_dswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib${ii}$_dswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - call stdlib_dger( k-2, nrhs, -one, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb ) + call stdlib${ii}$_dger( k-2, nrhs, -one, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb ) - call stdlib_dger( k-2, nrhs, -one, a( 1, k-1 ), 1, b( k-1, 1 ),ldb, b( 1, 1 ), & + call stdlib${ii}$_dger( k-2, nrhs, -one, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), & ldb ) ! multiply by the inverse of the diagonal block. akm1k = a( k-1, k ) @@ -20144,39 +20146,39 @@ module stdlib_linalg_lapack_d 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 = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(u**t(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, a( 1, k ),1, one, b( k, & - 1 ), ldb ) + call stdlib${ii}$_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, a( 1_${ik}$, k ),1_${ik}$, one, b( k, & + 1_${ik}$ ), ldb ) ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 1 + if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 1_${ik}$ else ! 2 x 2 diagonal block ! multiply by inv(u**t(k+1)), where u(k+1) is the transformation ! stored in columns k and k+1 of a. - call stdlib_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, a( 1, k ),1, one, b( k, & - 1 ), ldb ) - call stdlib_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb,a( 1, k+1 ), 1, one, b( & - k+1, 1 ), ldb ) + call stdlib${ii}$_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb, a( 1_${ik}$, k ),1_${ik}$, one, b( k, & + 1_${ik}$ ), ldb ) + call stdlib${ii}$_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b, ldb,a( 1_${ik}$, k+1 ), 1_${ik}$, one, b( & + k+1, 1_${ik}$ ), ldb ) ! interchange rows k and -ipiv(k). kp = -ipiv( k ) - if( kp/=k )call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 2 + if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 2_${ik}$ end if go to 40 50 continue @@ -20185,34 +20187,34 @@ module stdlib_linalg_lapack_d ! 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 = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(l**t(k)), where l(k) is the transformation ! stored in column k of a. - if( k= 1 ) - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k-1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( kp==-ipiv( k-1 ) )call stdlib_dswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb & + if( kp==-ipiv( k-1 ) )call stdlib${ii}$_dswap( 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_dtrsm('L','U','N','U',n,nrhs,one,a,lda,b,ldb) + call stdlib${ii}$_dtrsm('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_dscal( nrhs, one / a( i, i ), b( i, 1 ), ldb ) - elseif ( i > 1) then + if( ipiv(i) > 0_${ik}$ ) then + call stdlib${ii}$_dscal( 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 @@ -20352,58 +20354,58 @@ module stdlib_linalg_lapack_d 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_dtrsm('L','U','T','U',n,nrhs,one,a,lda,b,ldb) + call stdlib${ii}$_dtrsm('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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k+1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( k < n .and. kp==-ipiv( k+1 ) )call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp,& - 1 ), ldb ) + if( k < n .and. kp==-ipiv( k+1 ) )call stdlib${ii}$_dswap( 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k+1 else ! 2 x 2 diagonal block ! interchange rows k and -ipiv(k+1). kp = -ipiv( k+1 ) - if( kp==-ipiv( k ) )call stdlib_dswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp==-ipiv( k ) )call stdlib${ii}$_dswap( 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_dtrsm('L','L','N','U',n,nrhs,one,a,lda,b,ldb) + call stdlib${ii}$_dtrsm('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_dscal( nrhs, one / a( i, i ), b( i, 1 ), ldb ) + if( ipiv(i) > 0_${ik}$ ) then + call stdlib${ii}$_dscal( nrhs, one / a( i, i ), b( i, 1_${ik}$ ), ldb ) else akm1k = work(i) akm1 = a( i, i ) / akm1k @@ -20415,38 +20417,38 @@ module stdlib_linalg_lapack_d 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_dtrsm('L','L','T','U',n,nrhs,one,a,lda,b,ldb) + call stdlib${ii}$_dtrsm('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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k-1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( k>1 .and. kp==-ipiv( k-1 ) )call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, & - 1 ), ldb ) + if( k>1_${ik}$ .and. kp==-ipiv( k-1 ) )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, & + 1_${ik}$ ), ldb ) k=k-2 endif end do end if ! revert a - call stdlib_dsyconv( uplo, 'R', n, a, lda, ipiv, work, iinfo ) + call stdlib${ii}$_dsyconv( uplo, 'R', n, a, lda, ipiv, work, iinfo ) return - end subroutine stdlib_dsytrs2 + end subroutine stdlib${ii}$_dsytrs2 - pure subroutine stdlib_dsytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) + pure subroutine stdlib${ii}$_dsytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) !! DSYTRS_3 solves a system of linear equations A * X = B with a real !! symmetric matrix A using the factorization computed !! by DSYTRF_RK or DSYTRF_BK: @@ -20461,36 +20463,36 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: a(lda,*), e(*) real(dp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: i, j, k, kp + integer(${ik}$) :: i, j, k, kp real(dp) :: 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_dtrsm( 'L', 'U', 'N', 'U', n, nrhs, one, a, lda, b, ldb ) + call stdlib${ii}$_dtrsm( '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_dscal( nrhs, one / a( i, i ), b( i, 1 ), ldb ) - else if ( i>1 ) then + if( ipiv( i )>0_${ik}$ ) then + call stdlib${ii}$_dscal( 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 @@ -20528,12 +20530,12 @@ module stdlib_linalg_lapack_d 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_dtrsm( 'L', 'U', 'T', 'U', n, nrhs, one, a, lda, b, ldb ) + call stdlib${ii}$_dtrsm( '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. @@ -20543,7 +20545,7 @@ module stdlib_linalg_lapack_d do k = 1, n kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end if end do else @@ -20558,16 +20560,16 @@ module stdlib_linalg_lapack_d do k = 1, n kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib${ii}$_dswap( 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_dtrsm( 'L', 'L', 'N', 'U', n, nrhs, one, a, lda, b, ldb ) + call stdlib${ii}$_dtrsm( '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_dscal( nrhs, one / a( i, i ), b( i, 1 ), ldb ) + if( ipiv( i )>0_${ik}$ ) then + call stdlib${ii}$_dscal( nrhs, one / a( i, i ), b( i, 1_${ik}$ ), ldb ) else if( i b [ l**t \ (d \ (l \p**t * b) ) ] - call stdlib_dtrsm('L', 'L', 'T', 'U', n, nrhs, one, a, lda, b, ldb ) + call stdlib${ii}$_dtrsm('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. @@ -20594,16 +20596,16 @@ module stdlib_linalg_lapack_d do k = n, 1, -1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end if end do ! end lower end if return - end subroutine stdlib_dsytrs_3 + end subroutine stdlib${ii}$_dsytrs_3 - pure subroutine stdlib_dsytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) + pure subroutine stdlib${ii}$_dsytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) !! DSYTRS_AA solves a system of linear equations A*X = B with a real !! symmetric matrix A using the factorization A = U**T*T*U or !! A = L*T*L**T computed by DSYTRF_AA. @@ -20613,42 +20615,42 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: a(lda,*) real(dp), intent(inout) :: b(ldb,*) real(dp), 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 + if( n>1_${ik}$ ) then ! pivot, p**t * b -> b do k = 1, n kp = ipiv( k ) - if( kp/=k )call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end do ! compute u**t \ b -> b [ (u**t \p**t * b) ] - call stdlib_dtrsm('L', 'U', 'T', 'U', n-1, nrhs, one, a( 1, 2 ),lda, b( 2, 1 ), & + call stdlib${ii}$_dtrsm('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 ! compute t \ b -> b [ t \ (u**t \p**t * b) ] - call stdlib_dlacpy( 'F', 1, n, a( 1, 1 ), lda+1, work( n ), 1) - if( n>1 ) then - call stdlib_dlacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 1 ), 1 ) - call stdlib_dlacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 2*n ), 1 ) + call stdlib${ii}$_dlacpy( 'F', 1_${ik}$, n, a( 1_${ik}$, 1_${ik}$ ), lda+1, work( n ), 1_${ik}$) + if( n>1_${ik}$ ) then + call stdlib${ii}$_dlacpy( 'F', 1_${ik}$, n-1, a( 1_${ik}$, 2_${ik}$ ), lda+1, work( 1_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_dlacpy( 'F', 1_${ik}$, n-1, a( 1_${ik}$, 2_${ik}$ ), lda+1, work( 2_${ik}$*n ), 1_${ik}$ ) end if - call stdlib_dgtsv( n, nrhs, work( 1 ), work( n ), work( 2*n ), b, ldb,info ) + call stdlib${ii}$_dgtsv( n, nrhs, work( 1_${ik}$ ), work( n ), work( 2_${ik}$*n ), b, ldb,info ) ! 3) backward substitution with u - if( n>1 ) then + if( n>1_${ik}$ ) then ! compute u \ b -> b [ u \ (t \ (u**t \p**t * b) ) ] - call stdlib_dtrsm( 'L', 'U', 'N', 'U', n-1, nrhs, one, a( 1, 2 ),lda, b( 2, 1 ), & + call stdlib${ii}$_dtrsm( '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) )) ] do k = n, 1, -1 kp = ipiv( k ) - if( kp/=k )call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end do end if else ! solve a*x = b, where a = l*t*l**t. ! 1) forward substitution with l - if( n>1 ) then + if( n>1_${ik}$ ) then ! pivot, p**t * b -> b do k = 1, n kp = ipiv( k ) - if( kp/=k )call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end do ! compute l \ b -> b [ (l \p**t * b) ] - call stdlib_dtrsm( 'L', 'L', 'N', 'U', n-1, nrhs, one, a( 2, 1 ),lda, b( 2, 1 ), & + call stdlib${ii}$_dtrsm( '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 ! compute t \ b -> b [ t \ (l \p**t * b) ] - call stdlib_dlacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1) - if( n>1 ) then - call stdlib_dlacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 1 ), 1 ) - call stdlib_dlacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 2*n ), 1 ) + call stdlib${ii}$_dlacpy( 'F', 1_${ik}$, n, a(1_${ik}$, 1_${ik}$), lda+1, work(n), 1_${ik}$) + if( n>1_${ik}$ ) then + call stdlib${ii}$_dlacpy( 'F', 1_${ik}$, n-1, a( 2_${ik}$, 1_${ik}$ ), lda+1, work( 1_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_dlacpy( 'F', 1_${ik}$, n-1, a( 2_${ik}$, 1_${ik}$ ), lda+1, work( 2_${ik}$*n ), 1_${ik}$ ) end if - call stdlib_dgtsv( n, nrhs, work( 1 ), work(n), work( 2*n ), b, ldb,info) + call stdlib${ii}$_dgtsv( n, nrhs, work( 1_${ik}$ ), work(n), work( 2_${ik}$*n ), b, ldb,info) ! 3) backward substitution with l**t - if( n>1 ) then + if( n>1_${ik}$ ) then ! compute (l**t \ b) -> b [ l**t \ (t \ (l \p**t * b) ) ] - call stdlib_dtrsm( 'L', 'L', 'T', 'U', n-1, nrhs, one, a( 2, 1 ),lda, b( 2, 1 ), & + call stdlib${ii}$_dtrsm( '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) )) ] do k = n, 1, -1 kp = ipiv( k ) - if( kp/=k )call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end do end if end if return - end subroutine stdlib_dsytrs_aa + end subroutine stdlib${ii}$_dsytrs_aa - pure subroutine stdlib_dsytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) + pure subroutine stdlib${ii}$_dsytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) !! DSYTRS_ROOK solves a system of linear equations A*X = B with !! a real symmetric matrix A using the factorization A = U*D*U**T or !! A = L*D*L**T computed by DSYTRF_ROOK. @@ -20731,36 +20733,36 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: a(lda,*) real(dp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: j, k, kp + integer(${ik}$) :: j, k, kp real(dp) :: 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_dger( k-1, nrhs, -one, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb ) + call stdlib${ii}$_dger( k-1, nrhs, -one, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb ) ! multiply by the inverse of the diagonal block. - call stdlib_dscal( nrhs, one / a( k, k ), b( k, 1 ), ldb ) - k = k - 1 + call stdlib${ii}$_dscal( nrhs, one / a( k, k ), b( k, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ else ! 2 x 2 diagonal block ! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1) kp = -ipiv( k ) - if( kp/=k )call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) kp = -ipiv( k-1 ) - if( kp/=k-1 )call stdlib_dswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib${ii}$_dswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - if( k>2 ) then - call stdlib_dger( k-2, nrhs, -one, a( 1, k ), 1, b( k, 1 ),ldb, b( 1, 1 ), & + if( k>2_${ik}$ ) then + call stdlib${ii}$_dger( k-2, nrhs, -one, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), & ldb ) - call stdlib_dger( k-2, nrhs, -one, a( 1, k-1 ), 1, b( k-1, 1 ),ldb, b( 1, 1 ),& + call stdlib${ii}$_dger( k-2, nrhs, -one, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ),& ldb ) end if ! multiply by the inverse of the diagonal block. @@ -20812,43 +20814,43 @@ module stdlib_linalg_lapack_d 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 = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(u**t(k)), where u(k) is the transformation ! stored in column k of a. - if( k>1 )call stdlib_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1, k ), 1, & - one, b( k, 1 ), ldb ) + if( k>1_${ik}$ )call stdlib${ii}$_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, & + one, b( k, 1_${ik}$ ), ldb ) ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 1 + if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 1_${ik}$ else ! 2 x 2 diagonal block ! multiply by inv(u**t(k+1)), where u(k+1) is the transformation ! stored in columns k and k+1 of a. - if( k>1 ) then - call stdlib_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1, k ), 1, one, b( & - k, 1 ), ldb ) - call stdlib_dgemv( '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}$_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, one, b( & + k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_dgemv( 'TRANSPOSE', k-1, nrhs, -one, b,ldb, a( 1_${ik}$, k+1 ), 1_${ik}$, one, & + b( k+1, 1_${ik}$ ), ldb ) end if ! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1). kp = -ipiv( k ) - if( kp/=k )call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) kp = -ipiv( k+1 ) - if( kp/=k+1 )call stdlib_dswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 2 + if( kp/=k+1 )call stdlib${ii}$_dswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 2_${ik}$ end if go to 40 50 continue @@ -20857,36 +20859,36 @@ module stdlib_linalg_lapack_d ! 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 = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_dswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(l**t(k)), where l(k) is the transformation ! stored in column k of a. - if( k 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 + 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 @@ -21850,28 +21852,28 @@ module stdlib_linalg_lapack_d 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 + 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 @@ -21882,38 +21884,38 @@ module stdlib_linalg_lapack_d ! 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 + 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 + 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 @@ -21926,13 +21928,13 @@ module stdlib_linalg_lapack_d ! 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 + 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 @@ -21940,28 +21942,28 @@ module stdlib_linalg_lapack_d 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 + 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 @@ -21972,48 +21974,48 @@ module stdlib_linalg_lapack_d ! 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 + 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 + 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_dtfttp + end subroutine stdlib${ii}$_dtfttp - pure subroutine stdlib_dtfttr( transr, uplo, n, arf, a, lda, info ) + pure subroutine stdlib${ii}$_dtfttr( transr, uplo, n, arf, a, lda, info ) !! DTFTTR copies a triangular matrix A from rectangular full packed !! format (TF) to standard full format (TR). ! -- lapack computational routine -- @@ -22021,60 +22023,60 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(out) :: a(0:lda-1,0:*) - real(dp), intent(in) :: arf(0:*) + real(dp), intent(out) :: a(0_${ik}$:lda-1,0_${ik}$:*) + real(dp), 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}$, 'DTRTRI', uplo // diag, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code - call stdlib_dtrti2( uplo, diag, n, a, lda, info ) + call stdlib${ii}$_dtrti2( uplo, diag, n, a, lda, info ) else ! use blocked code if( upper ) then @@ -23732,35 +23734,35 @@ module stdlib_linalg_lapack_d do j = 1, n, nb jb = min( nb, n-j+1 ) ! compute rows 1:j-1 of current block column - call stdlib_dtrmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, one, a, lda,& - a( 1, j ), lda ) - call stdlib_dtrsm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, -one, a( j,& - j ), lda, a( 1, j ), lda ) + call stdlib${ii}$_dtrmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, one, a, lda,& + a( 1_${ik}$, j ), lda ) + call stdlib${ii}$_dtrsm( '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_dtrti2( 'UPPER', diag, jb, a( j, j ), lda, info ) + call stdlib${ii}$_dtrti2( '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_dtrmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, one,& + call stdlib${ii}$_dtrmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, one,& a( j+jb, j+jb ), lda,a( j+jb, j ), lda ) - call stdlib_dtrsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, -& + call stdlib${ii}$_dtrsm( '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_dtrti2( 'LOWER', diag, jb, a( j, j ), lda, info ) + call stdlib${ii}$_dtrti2( 'LOWER', diag, jb, a( j, j ), lda, info ) end do end if end if return - end subroutine stdlib_dtrtri + end subroutine stdlib${ii}$_dtrtri - pure subroutine stdlib_dtrtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info ) + pure subroutine stdlib${ii}$_dtrtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info ) !! DTRTRS solves a triangular system of the form !! A * X = B or A**T * X = B, !! where A is a triangular matrix of order N, and B is an N-by-NRHS @@ -23770,8 +23772,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: a(lda,*) real(dp), intent(inout) :: b(ldb,*) @@ -23783,26 +23785,26 @@ module stdlib_linalg_lapack_d 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 @@ -24240,22 +24242,22 @@ module stdlib_linalg_lapack_d 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( 'DBBCSD', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DBBCSD', -info ) return else if( lquery ) then return end if ! get machine constants - eps = stdlib_dlamch( 'EPSILON' ) - unfl = stdlib_dlamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_dlamch( 'EPSILON' ) + unfl = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) tolmul = max( ten, min( hundred, eps**meighth ) ) tol = tolmul*eps thresh = max( tol, maxitr*q*q*unfl ) @@ -24280,18 +24282,18 @@ module stdlib_linalg_lapack_d 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 @@ -24311,9 +24313,9 @@ module stdlib_linalg_lapack_d 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 @@ -24337,20 +24339,20 @@ module stdlib_linalg_lapack_d nu = zero else ! compute shifts for b11 and b21 and use the lesser - call stdlib_dlas2( b11d(imax-1), b11e(imax-1), b11d(imax), sigma11,dummy ) + call stdlib${ii}$_dlas2( b11d(imax-1), b11e(imax-1), b11d(imax), sigma11,dummy ) - call stdlib_dlas2( b21d(imax-1), b21e(imax-1), b21d(imax), sigma21,dummy ) + call stdlib${ii}$_dlas2( 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_dp - nu**2 ) + mu = sqrt( 1.0_dp - nu**2_${ik}$ ) if( nu < thresh ) then mu = one nu = zero @@ -24359,10 +24361,10 @@ module stdlib_linalg_lapack_d end if ! rotate to produce bulges in b11 and b21 if( mu <= nu ) then - call stdlib_dlartgs( b11d(imin), b11e(imin), mu,work(iv1tcs+imin-1), work(iv1tsn+& + call stdlib${ii}$_dlartgs( b11d(imin), b11e(imin), mu,work(iv1tcs+imin-1), work(iv1tsn+& imin-1) ) else - call stdlib_dlartgs( b21d(imin), b21e(imin), nu,work(iv1tcs+imin-1), work(iv1tsn+& + call stdlib${ii}$_dlartgs( 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) @@ -24376,27 +24378,27 @@ module stdlib_linalg_lapack_d 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_dlartgp( 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}$_dlartgp( b11bulge, b11d(imin), work(iu1sn+imin-1),work(iu1cs+imin-1),& r ) else if( mu <= nu ) then - call stdlib_dlartgs( b11e( imin ), b11d( imin + 1 ), mu,work(iu1cs+imin-1), work(& + call stdlib${ii}$_dlartgs( b11e( imin ), b11d( imin + 1_${ik}$ ), mu,work(iu1cs+imin-1), work(& iu1sn+imin-1) ) else - call stdlib_dlartgs( b12d( imin ), b12e( imin ), nu,work(iu1cs+imin-1), work(& + call stdlib${ii}$_dlartgs( 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_dlartgp( 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}$_dlartgp( b21bulge, b21d(imin), work(iu2sn+imin-1),work(iu2cs+imin-1),& r ) else if( nu < mu ) then - call stdlib_dlartgs( b21e( imin ), b21d( imin + 1 ), nu,work(iu2cs+imin-1), work(& + call stdlib${ii}$_dlartgs( b21e( imin ), b21d( imin + 1_${ik}$ ), nu,work(iu2cs+imin-1), work(& iu2sn+imin-1) ) else - call stdlib_dlartgs( b22d(imin), b22e(imin), mu,work(iu2cs+imin-1), work(iu2sn+& + call stdlib${ii}$_dlartgs( b22d(imin), b22e(imin), mu,work(iu2cs+imin-1), work(iu2sn+& imin-1) ) end if work(iu2cs+imin-1) = -work(iu2cs+imin-1) @@ -24436,48 +24438,48 @@ module stdlib_linalg_lapack_d 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_dlartgp( x2, x1, work(iv1tsn+i-1), work(iv1tcs+i-1),r ) + call stdlib${ii}$_dlartgp( x2, x1, work(iv1tsn+i-1), work(iv1tcs+i-1),r ) else if( .not. restart11 .and. restart21 ) then - call stdlib_dlartgp( b11bulge, b11e(i-1), work(iv1tsn+i-1),work(iv1tcs+i-1), & + call stdlib${ii}$_dlartgp( b11bulge, b11e(i-1), work(iv1tsn+i-1),work(iv1tcs+i-1), & r ) else if( restart11 .and. .not. restart21 ) then - call stdlib_dlartgp( b21bulge, b21e(i-1), work(iv1tsn+i-1),work(iv1tcs+i-1), & + call stdlib${ii}$_dlartgp( b21bulge, b21e(i-1), work(iv1tsn+i-1),work(iv1tcs+i-1), & r ) else if( mu <= nu ) then - call stdlib_dlartgs( b11d(i), b11e(i), mu, work(iv1tcs+i-1),work(iv1tsn+i-1) ) + call stdlib${ii}$_dlartgs( b11d(i), b11e(i), mu, work(iv1tcs+i-1),work(iv1tsn+i-1) ) else - call stdlib_dlartgs( b21d(i), b21e(i), nu, work(iv1tcs+i-1),work(iv1tsn+i-1) ) + call stdlib${ii}$_dlartgs( 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_dlartgp( y2, y1, work(iv2tsn+i-1-1),work(iv2tcs+i-1-1), r ) + call stdlib${ii}$_dlartgp( y2, y1, work(iv2tsn+i-1-1),work(iv2tcs+i-1-1), r ) else if( .not. restart12 .and. restart22 ) then - call stdlib_dlartgp( b12bulge, b12d(i-1), work(iv2tsn+i-1-1),work(iv2tcs+i-1-& - 1), r ) + call stdlib${ii}$_dlartgp( 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_dlartgp( b22bulge, b22d(i-1), work(iv2tsn+i-1-1),work(iv2tcs+i-1-& - 1), r ) + call stdlib${ii}$_dlartgp( b22bulge, b22d(i-1), work(iv2tsn+i-1-1),work(iv2tcs+i-1-& + 1_${ik}$), r ) else if( nu < mu ) then - call stdlib_dlartgs( b12e(i-1), b12d(i), nu, work(iv2tcs+i-1-1),work(iv2tsn+i-& - 1-1) ) + call stdlib${ii}$_dlartgs( b12e(i-1), b12d(i), nu, work(iv2tcs+i-1-1),work(iv2tsn+i-& + 1_${ik}$-1) ) else - call stdlib_dlartgs( b22e(i-1), b22d(i), mu, work(iv2tcs+i-1-1),work(iv2tsn+i-& - 1-1) ) + call stdlib${ii}$_dlartgs( 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) @@ -24504,44 +24506,44 @@ module stdlib_linalg_lapack_d 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_dlartgp( x2, x1, work(iu1sn+i-1), work(iu1cs+i-1),r ) + call stdlib${ii}$_dlartgp( x2, x1, work(iu1sn+i-1), work(iu1cs+i-1),r ) else if( .not. restart11 .and. restart12 ) then - call stdlib_dlartgp( b11bulge, b11d(i), work(iu1sn+i-1),work(iu1cs+i-1), r ) + call stdlib${ii}$_dlartgp( b11bulge, b11d(i), work(iu1sn+i-1),work(iu1cs+i-1), r ) else if( restart11 .and. .not. restart12 ) then - call stdlib_dlartgp( b12bulge, b12e(i-1), work(iu1sn+i-1),work(iu1cs+i-1), r ) + call stdlib${ii}$_dlartgp( b12bulge, b12e(i-1), work(iu1sn+i-1),work(iu1cs+i-1), r ) else if( mu <= nu ) then - call stdlib_dlartgs( b11e(i), b11d(i+1), mu, work(iu1cs+i-1),work(iu1sn+i-1) ) + call stdlib${ii}$_dlartgs( b11e(i), b11d(i+1), mu, work(iu1cs+i-1),work(iu1sn+i-1) ) else - call stdlib_dlartgs( b12d(i), b12e(i), nu, work(iu1cs+i-1),work(iu1sn+i-1) ) + call stdlib${ii}$_dlartgs( b12d(i), b12e(i), nu, work(iu1cs+i-1),work(iu1sn+i-1) ) end if if( .not. restart21 .and. .not. restart22 ) then - call stdlib_dlartgp( y2, y1, work(iu2sn+i-1), work(iu2cs+i-1),r ) + call stdlib${ii}$_dlartgp( y2, y1, work(iu2sn+i-1), work(iu2cs+i-1),r ) else if( .not. restart21 .and. restart22 ) then - call stdlib_dlartgp( b21bulge, b21d(i), work(iu2sn+i-1),work(iu2cs+i-1), r ) + call stdlib${ii}$_dlartgp( b21bulge, b21d(i), work(iu2sn+i-1),work(iu2cs+i-1), r ) else if( restart21 .and. .not. restart22 ) then - call stdlib_dlartgp( b22bulge, b22e(i-1), work(iu2sn+i-1),work(iu2cs+i-1), r ) + call stdlib${ii}$_dlartgp( b22bulge, b22e(i-1), work(iu2sn+i-1),work(iu2cs+i-1), r ) else if( nu < mu ) then - call stdlib_dlartgs( b21e(i), b21e(i+1), nu, work(iu2cs+i-1),work(iu2sn+i-1) ) + call stdlib${ii}$_dlartgs( b21e(i), b21e(i+1), nu, work(iu2cs+i-1),work(iu2sn+i-1) ) else - call stdlib_dlartgs( b22d(i), b22e(i), mu, work(iu2cs+i-1),work(iu2sn+i-1) ) + call stdlib${ii}$_dlartgs( b22d(i), b22e(i), mu, work(iu2cs+i-1),work(iu2sn+i-1) ) end if work(iu2cs+i-1) = -work(iu2cs+i-1) @@ -24549,14 +24551,14 @@ module stdlib_linalg_lapack_d 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 @@ -24575,24 +24577,24 @@ module stdlib_linalg_lapack_d 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_dlartgp( y2, y1, work(iv2tsn+imax-1-1),work(iv2tcs+imax-1-1), r ) + call stdlib${ii}$_dlartgp( y2, y1, work(iv2tsn+imax-1-1),work(iv2tcs+imax-1-1), r ) else if( .not. restart12 .and. restart22 ) then - call stdlib_dlartgp( b12bulge, b12d(imax-1), work(iv2tsn+imax-1-1),work(iv2tcs+& + call stdlib${ii}$_dlartgp( b12bulge, b12d(imax-1), work(iv2tsn+imax-1-1),work(iv2tcs+& imax-1-1), r ) else if( restart12 .and. .not. restart22 ) then - call stdlib_dlartgp( b22bulge, b22d(imax-1), work(iv2tsn+imax-1-1),work(iv2tcs+& + call stdlib${ii}$_dlartgp( b22bulge, b22d(imax-1), work(iv2tsn+imax-1-1),work(iv2tcs+& imax-1-1), r ) else if( nu < mu ) then - call stdlib_dlartgs( b12e(imax-1), b12d(imax), nu,work(iv2tcs+imax-1-1), work(& + call stdlib${ii}$_dlartgs( b12e(imax-1), b12d(imax), nu,work(iv2tcs+imax-1-1), work(& iv2tsn+imax-1-1) ) else - call stdlib_dlartgs( b22e(imax-1), b22d(imax), mu,work(iv2tcs+imax-1-1), work(& + call stdlib${ii}$_dlartgs( 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) @@ -24606,49 +24608,49 @@ module stdlib_linalg_lapack_d ! update singular vectors if( wantu1 ) then if( colmajor ) then - call stdlib_dlasr( 'R', 'V', 'F', p, imax-imin+1,work(iu1cs+imin-1), work(& - iu1sn+imin-1),u1(1,imin), ldu1 ) + call stdlib${ii}$_dlasr( 'R', 'V', 'F', p, imax-imin+1,work(iu1cs+imin-1), work(& + iu1sn+imin-1),u1(1_${ik}$,imin), ldu1 ) else - call stdlib_dlasr( 'L', 'V', 'F', imax-imin+1, p,work(iu1cs+imin-1), work(& - iu1sn+imin-1),u1(imin,1), ldu1 ) + call stdlib${ii}$_dlasr( '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_dlasr( 'R', 'V', 'F', m-p, imax-imin+1,work(iu2cs+imin-1), work(& - iu2sn+imin-1),u2(1,imin), ldu2 ) + call stdlib${ii}$_dlasr( 'R', 'V', 'F', m-p, imax-imin+1,work(iu2cs+imin-1), work(& + iu2sn+imin-1),u2(1_${ik}$,imin), ldu2 ) else - call stdlib_dlasr( 'L', 'V', 'F', imax-imin+1, m-p,work(iu2cs+imin-1), work(& - iu2sn+imin-1),u2(imin,1), ldu2 ) + call stdlib${ii}$_dlasr( '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_dlasr( 'L', 'V', 'F', imax-imin+1, q,work(iv1tcs+imin-1), work(& - iv1tsn+imin-1),v1t(imin,1), ldv1t ) + call stdlib${ii}$_dlasr( 'L', 'V', 'F', imax-imin+1, q,work(iv1tcs+imin-1), work(& + iv1tsn+imin-1),v1t(imin,1_${ik}$), ldv1t ) else - call stdlib_dlasr( 'R', 'V', 'F', q, imax-imin+1,work(iv1tcs+imin-1), work(& - iv1tsn+imin-1),v1t(1,imin), ldv1t ) + call stdlib${ii}$_dlasr( '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_dlasr( 'L', 'V', 'F', imax-imin+1, m-q,work(iv2tcs+imin-1), work(& - iv2tsn+imin-1),v2t(imin,1), ldv2t ) + call stdlib${ii}$_dlasr( 'L', 'V', 'F', imax-imin+1, m-q,work(iv2tcs+imin-1), work(& + iv2tsn+imin-1),v2t(imin,1_${ik}$), ldv2t ) else - call stdlib_dlasr( 'R', 'V', 'F', m-q, imax-imin+1,work(iv2tcs+imin-1), work(& - iv2tsn+imin-1),v2t(1,imin), ldv2t ) + call stdlib${ii}$_dlasr( '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_dscal( q, negone, v1t(imax,1), ldv1t ) + call stdlib${ii}$_dscal( q, negone, v1t(imax,1_${ik}$), ldv1t ) else - call stdlib_dscal( q, negone, v1t(1,imax), 1 ) + call stdlib${ii}$_dscal( q, negone, v1t(1_${ik}$,imax), 1_${ik}$ ) end if end if end if @@ -24658,33 +24660,33 @@ module stdlib_linalg_lapack_d 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_dscal( p, negone, u1(1,imax), 1 ) + call stdlib${ii}$_dscal( p, negone, u1(1_${ik}$,imax), 1_${ik}$ ) else - call stdlib_dscal( p, negone, u1(imax,1), ldu1 ) + call stdlib${ii}$_dscal( 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_dscal( m-p, negone, u2(1,imax), 1 ) + call stdlib${ii}$_dscal( m-p, negone, u2(1_${ik}$,imax), 1_${ik}$ ) else - call stdlib_dscal( m-p, negone, u2(imax,1), ldu2 ) + call stdlib${ii}$_dscal( 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_dscal( m-q, negone, v2t(imax,1), ldv2t ) + call stdlib${ii}$_dscal( m-q, negone, v2t(imax,1_${ik}$), ldv2t ) else - call stdlib_dscal( m-q, negone, v2t(1,imax), 1 ) + call stdlib${ii}$_dscal( m-q, negone, v2t(1_${ik}$,imax), 1_${ik}$ ) end if end if end if @@ -24704,16 +24706,16 @@ module stdlib_linalg_lapack_d 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 @@ -24733,25 +24735,25 @@ module stdlib_linalg_lapack_d theta(mini) = theta(i) theta(i) = thetamin if( colmajor ) then - if( wantu1 )call stdlib_dswap( p, u1(1,i), 1, u1(1,mini), 1 ) - if( wantu2 )call stdlib_dswap( m-p, u2(1,i), 1, u2(1,mini), 1 ) - if( wantv1t )call stdlib_dswap( q, v1t(i,1), ldv1t, v1t(mini,1), ldv1t ) + if( wantu1 )call stdlib${ii}$_dswap( p, u1(1_${ik}$,i), 1_${ik}$, u1(1_${ik}$,mini), 1_${ik}$ ) + if( wantu2 )call stdlib${ii}$_dswap( m-p, u2(1_${ik}$,i), 1_${ik}$, u2(1_${ik}$,mini), 1_${ik}$ ) + if( wantv1t )call stdlib${ii}$_dswap( q, v1t(i,1_${ik}$), ldv1t, v1t(mini,1_${ik}$), ldv1t ) - if( wantv2t )call stdlib_dswap( m-q, v2t(i,1), ldv2t, v2t(mini,1),ldv2t ) + if( wantv2t )call stdlib${ii}$_dswap( m-q, v2t(i,1_${ik}$), ldv2t, v2t(mini,1_${ik}$),ldv2t ) else - if( wantu1 )call stdlib_dswap( p, u1(i,1), ldu1, u1(mini,1), ldu1 ) - if( wantu2 )call stdlib_dswap( m-p, u2(i,1), ldu2, u2(mini,1), ldu2 ) - if( wantv1t )call stdlib_dswap( q, v1t(1,i), 1, v1t(1,mini), 1 ) - if( wantv2t )call stdlib_dswap( m-q, v2t(1,i), 1, v2t(1,mini), 1 ) + if( wantu1 )call stdlib${ii}$_dswap( p, u1(i,1_${ik}$), ldu1, u1(mini,1_${ik}$), ldu1 ) + if( wantu2 )call stdlib${ii}$_dswap( m-p, u2(i,1_${ik}$), ldu2, u2(mini,1_${ik}$), ldu2 ) + if( wantv1t )call stdlib${ii}$_dswap( q, v1t(1_${ik}$,i), 1_${ik}$, v1t(1_${ik}$,mini), 1_${ik}$ ) + if( wantv2t )call stdlib${ii}$_dswap( m-q, v2t(1_${ik}$,i), 1_${ik}$, v2t(1_${ik}$,mini), 1_${ik}$ ) end if end if end do return - end subroutine stdlib_dbbcsd + end subroutine stdlib${ii}$_dbbcsd - pure subroutine stdlib_ddisna( job, m, n, d, sep, info ) + pure subroutine stdlib${ii}$_ddisna( job, m, n, d, sep, info ) !! DDISNA computes the reciprocal condition numbers for the eigenvectors !! of a real symmetric or complex Hermitian matrix or for the left or !! right singular vectors of a general m-by-n matrix. The reciprocal @@ -24770,8 +24772,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: d(*) real(dp), intent(out) :: sep(*) @@ -24779,13 +24781,13 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: decr, eigen, incr, left, right, sing - integer(ilp) :: i, k + integer(${ik}$) :: i, k real(dp) :: 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' ) @@ -24796,11 +24798,11 @@ module stdlib_linalg_lapack_d 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. @@ -24808,24 +24810,24 @@ module stdlib_linalg_lapack_d 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( 'DDISNA', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DDISNA', -info ) return end if ! quick return if possible if( k==0 )return ! compute reciprocal condition numbers - if( k==1 ) then - sep( 1 ) = stdlib_dlamch( 'O' ) + if( k==1_${ik}$ ) then + sep( 1_${ik}$ ) = stdlib${ii}$_dlamch( '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 ) @@ -24835,15 +24837,15 @@ module stdlib_linalg_lapack_d 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 + if( kl+ku>1_${ik}$ ) then ! reduce to upper bidiagonal form if ku > 0; if ku = 0, 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. @@ -24939,107 +24941,107 @@ module stdlib_linalg_lapack_d 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_dlargv( nr, ab( klu1, j1-klm-1 ), inca,work( j1 ), kb1, & + if( nr>0_${ik}$ )call stdlib${ii}$_dlargv( 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_dlartv( nrt, ab( klu1-l, j1-klm+l-1 ), inca,ab( & + if( nrt>0_${ik}$ )call stdlib${ii}$_dlartv( 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_dlartg( ab( ku+ml-1, i ), ab( ku+ml, i ),work( mn+i+ml-1 ), & + call stdlib${ii}$_dlartg( 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 ) + 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_dlargv( nr, ab( 1, j1+kun-1 ), inca,work( j1+kun ), kb1,& + if( nr>0_${ik}$ )call stdlib${ii}$_dlargv( 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_dlartv( nrt, ab( l+1, j1+kun-1 ), inca,ab( l, j1+& + if( nrt>0_${ik}$ )call stdlib${ii}$_dlartv( 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_dlartg( ab( ku-mu+3, i+mu-2 ),ab( ku-mu+2, i+mu-1 ),work( & + call stdlib${ii}$_dlartg( 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_drot( 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}$_drot( 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_drot( n, pt( j+kun-1, 1 ), ldpt,pt( j+kun, 1 ), ldpt, work( & + call stdlib${ii}$_drot( 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 @@ -25049,31 +25051,31 @@ module stdlib_linalg_lapack_d 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_dlartg( ab( 1, i ), ab( 2, i ), rc, rs, ra ) + call stdlib${ii}$_dlartg( 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_drot( n, pt( i, 1 ), ldpt, pt( m+1, 1 ), ldpt,rc, rs ) + if( wantpt )call stdlib${ii}$_drot( n, pt( i, 1_${ik}$ ), ldpt, pt( m+1, 1_${ik}$ ), ldpt,rc, rs ) end do else @@ -25106,14 +25108,14 @@ module stdlib_linalg_lapack_d 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_dgbbrd + end subroutine stdlib${ii}$_dgbbrd - pure subroutine stdlib_dgbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond,work, iwork, & + pure subroutine stdlib${ii}$_dgbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond,work, iwork, & !! DGBCON estimates the reciprocal of the condition number of a real !! general band matrix A, in either the 1-norm or the infinity-norm, !! using the LU factorization computed by DGBTRF. @@ -25126,13 +25128,13 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: anorm real(dp), 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(dp), intent(in) :: ab(ldab,*) real(dp), intent(out) :: work(*) ! ===================================================================== @@ -25140,56 +25142,56 @@ module stdlib_linalg_lapack_d ! 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(dp) :: 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 + info = 0_${ik}$ onenrm = norm=='1' .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_dlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_dlacn2( 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 @@ -25201,21 +25203,21 @@ module stdlib_linalg_lapack_d work( jp ) = work( j ) work( j ) = t end if - call stdlib_daxpy( lm, -t, ab( kd+1, j ), 1, work( j+1 ), 1 ) + call stdlib${ii}$_daxpy( lm, -t, ab( kd+1, j ), 1_${ik}$, work( j+1 ), 1_${ik}$ ) end do end if ! multiply by inv(u). - call stdlib_dlatbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, & - ldab, work, scale, work( 2*n+1 ),info ) + call stdlib${ii}$_dlatbs( '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_dlatbs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, ldab, & - work, scale, work( 2*n+1 ),info ) + call stdlib${ii}$_dlatbs( '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_ddot( lm, ab( kd+1, j ), 1,work( j+1 ), 1 ) + work( j ) = work( j ) - stdlib${ii}$_ddot( lm, ab( kd+1, j ), 1_${ik}$,work( j+1 ), 1_${ik}$ ) jp = ipiv( j ) if( jp/=j ) then @@ -25229,9 +25231,9 @@ module stdlib_linalg_lapack_d ! divide x by 1/scale if doing so will not cause overflow. normin = 'Y' if( scale/=one ) then - ix = stdlib_idamax( n, work, 1 ) + ix = stdlib${ii}$_idamax( 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. @@ -25487,7 +25489,7 @@ module stdlib_linalg_lapack_d 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. @@ -25514,10 +25516,10 @@ module stdlib_linalg_lapack_d colcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) end if return - end subroutine stdlib_dgbequb + end subroutine stdlib${ii}$_dgbequb - pure subroutine stdlib_dgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb,ipiv, b, ldb, x, & + pure subroutine stdlib${ii}$_dgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb,ipiv, b, ldb, x, & !! DGBRFS 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. @@ -25527,17 +25529,17 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: ab(ldab,*), afb(ldafb,*), b(ldb,*) real(dp), intent(out) :: berr(*), ferr(*), work(*) real(dp), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: itmax = 5 + integer(${ik}$), parameter :: itmax = 5_${ik}$ @@ -25546,42 +25548,42 @@ module stdlib_linalg_lapack_d ! 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(dp) :: 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_dgbtrs( trans, n, kl, ku, 1, afb, ldafb, ipiv,work( n+1 ), n, info ) + call stdlib${ii}$_dgbtrs( trans, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work( n+1 ), n, info ) - call stdlib_daxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) + call stdlib${ii}$_daxpy( 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 @@ -25685,14 +25687,14 @@ module stdlib_linalg_lapack_d work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_dlacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) + call stdlib${ii}$_dlacn2( 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_dgbtrs( transt, n, kl, ku, 1, afb, ldafb, ipiv,work( n+1 ), n, & + call stdlib${ii}$_dgbtrs( 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 ) @@ -25702,7 +25704,7 @@ module stdlib_linalg_lapack_d do i = 1, n work( n+i ) = work( n+i )*work( i ) end do - call stdlib_dgbtrs( trans, n, kl, ku, 1, afb, ldafb, ipiv,work( n+1 ), n, & + call stdlib${ii}$_dgbtrs( trans, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work( n+1 ), n, & info ) end if go to 100 @@ -25715,10 +25717,10 @@ module stdlib_linalg_lapack_d if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_dgbrfs + end subroutine stdlib${ii}$_dgbrfs - pure subroutine stdlib_dgbtrf( m, n, kl, ku, ab, ldab, ipiv, info ) + pure subroutine stdlib${ii}$_dgbtrf( m, n, kl, ku, ab, ldab, ipiv, info ) !! DGBTRF computes an LU factorization of a real m-by-n band matrix A !! using partial pivoting with row interchanges. !! This is the blocked version of the algorithm, calling Level 3 BLAS. @@ -25726,19 +25728,19 @@ module stdlib_linalg_lapack_d ! -- 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(dp), 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(dp) :: temp ! Local Arrays @@ -25750,32 +25752,32 @@ module stdlib_linalg_lapack_d ! 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_dgbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) + call stdlib${ii}$_dgbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) else ! use blocked code ! zero the superdiagonal elements of the work array work13 @@ -25799,7 +25801,7 @@ module stdlib_linalg_lapack_d 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 @@ -25825,57 +25827,57 @@ module stdlib_linalg_lapack_d ! find pivot and test for singularity. km is the number of ! subdiagonal elements in the current column. km = min( kl, m-jj ) - jp = stdlib_idamax( km+1, ab( kv+1, jj ), 1 ) + jp = stdlib${ii}$_idamax( 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_dger( 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}$_dger( 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_dcopy( nw, ab( kv+kl+1-jj+j, jj ), 1,work31( 1, jj-j+1 )& - , 1 ) + if( nw>0_${ik}$ )call stdlib${ii}$_dcopy( 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_dlaswp to apply the row interchanges to a12, a22, and ! a32. - call stdlib_dlaswp( j2, ab( kv+1-jb, j+jb ), ldab-1, 1, jb,ipiv( j ), 1 ) + call stdlib${ii}$_dlaswp( 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 @@ -25888,24 +25890,24 @@ module stdlib_linalg_lapack_d 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_dtrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j2, one, ab(& + call stdlib${ii}$_dtrsm( '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_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j2,jb, -one, ab( & + call stdlib${ii}$_dgemm( '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_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j2,jb, -one, & + call stdlib${ii}$_dgemm( '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 @@ -25914,18 +25916,18 @@ module stdlib_linalg_lapack_d end do end do ! update a13 in the work array - call stdlib_dtrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j3, one, ab(& + call stdlib${ii}$_dtrsm( '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_dgemm( '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}$_dgemm( '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_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j3,jb, -one, & - work31, ldwork, work13,ldwork, one, ab( 1+kl, j+kv ), ldab-1 ) + call stdlib${ii}$_dgemm( '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 @@ -25937,38 +25939,38 @@ module stdlib_linalg_lapack_d 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_dcopy( nw, work31( 1, jj-j+1 ), 1,ab( kv+kl+1-jj+j, jj )& - , 1 ) + if( nw>0_${ik}$ )call stdlib${ii}$_dcopy( 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_dgbtrf + end subroutine stdlib${ii}$_dgbtrf - pure subroutine stdlib_dgecon( norm, n, a, lda, anorm, rcond, work, iwork,info ) + pure subroutine stdlib${ii}$_dgecon( norm, n, a, lda, anorm, rcond, work, iwork,info ) !! DGECON estimates the reciprocal of the condition number of a general !! real matrix A, in either the 1-norm or the infinity-norm, using !! the LU factorization computed by DGETRF. @@ -25980,12 +25982,12 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: anorm real(dp), intent(out) :: rcond ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: work(*) ! ===================================================================== @@ -25993,72 +25995,72 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: onenrm character :: normin - integer(ilp) :: ix, kase, kase1 + integer(${ik}$) :: ix, kase, kase1 real(dp) :: 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 + info = 0_${ik}$ onenrm = norm=='1' .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. @@ -26301,7 +26303,7 @@ module stdlib_linalg_lapack_d 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. @@ -26328,10 +26330,10 @@ module stdlib_linalg_lapack_d colcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) end if return - end subroutine stdlib_dgeequb + end subroutine stdlib${ii}$_dgeequb - pure subroutine stdlib_dgemlqt( side, trans, m, n, k, mb, v, ldv, t, ldt,c, ldc, work, info ) + pure subroutine stdlib${ii}$_dgemlqt( 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 @@ -26347,8 +26349,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: v(ldv,*), t(ldt,*) real(dp), intent(inout) :: c(ldc,*) @@ -26356,44 +26358,44 @@ module stdlib_linalg_lapack_d ! ===================================================================== ! 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_dscal( n, temp, rhs( 1 ), 1 ) + call stdlib${ii}$_dscal( n, temp, rhs( 1_${ik}$ ), 1_${ik}$ ) scale = scale*temp end if do i = n, 1, -1 @@ -26580,12 +26582,12 @@ module stdlib_linalg_lapack_d end do end do ! apply permutations jpiv to the solution (rhs) - call stdlib_dlaswp( 1, rhs, lda, 1, n-1, jpiv, -1 ) + call stdlib${ii}$_dlaswp( 1_${ik}$, rhs, lda, 1_${ik}$, n-1, jpiv, -1_${ik}$ ) return - end subroutine stdlib_dgesc2 + end subroutine stdlib${ii}$_dgesc2 - pure subroutine stdlib_dgetc2( n, a, lda, ipiv, jpiv, info ) + pure subroutine stdlib${ii}$_dgetc2( n, a, lda, ipiv, jpiv, info ) !! DGETC2 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 @@ -26595,34 +26597,34 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ip, ipv, j, jp, jpv + integer(${ik}$) :: i, ip, ipv, j, jp, jpv real(dp) :: 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_dlamch( 'P' ) - smlnum = stdlib_dlamch( 'S' ) / eps + eps = stdlib${ii}$_dlamch( 'P' ) + smlnum = stdlib${ii}$_dlamch( 'S' ) / eps bignum = one / smlnum - call stdlib_dlabad( smlnum, bignum ) + call stdlib${ii}$_dlabad( smlnum, bignum ) ! handle the case n=1 by itself - if( n==1 ) then - ipiv( 1 ) = 1 - jpiv( 1 ) = 1 - if( abs( a( 1, 1 ) )= sfmin ) then - call stdlib_dscal( m-j, one / a( j, j ), a( j+1, j ), 1 ) + call stdlib${ii}$_dscal( 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_dscal( m-1, one / a( 1, 1 ), a( 2, 1 ), 1 ) + if( abs(a( 1_${ik}$, 1_${ik}$ )) >= sfmin ) then + call stdlib${ii}$_dscal( 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_dgetrf2( m, n1, a, lda, ipiv, iinfo ) - if ( info==0 .and. iinfo>0 )info = iinfo + call stdlib${ii}$_dgetrf2( m, n1, a, lda, ipiv, iinfo ) + if ( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo ! [ a12 ] ! apply interchanges to [ --- ] ! [ a22 ] - call stdlib_dlaswp( n2, a( 1, n1+1 ), lda, 1, n1, ipiv, 1 ) + call stdlib${ii}$_dlaswp( n2, a( 1_${ik}$, n1+1 ), lda, 1_${ik}$, n1, ipiv, 1_${ik}$ ) ! solve a12 - call stdlib_dtrsm( 'L', 'L', 'N', 'U', n1, n2, one, a, lda,a( 1, n1+1 ), lda ) + call stdlib${ii}$_dtrsm( 'L', 'L', 'N', 'U', n1, n2, one, a, lda,a( 1_${ik}$, n1+1 ), lda ) ! update a22 - call stdlib_dgemm( 'N', 'N', m-n1, n2, n1, -one, a( n1+1, 1 ), lda,a( 1, n1+1 ), & + call stdlib${ii}$_dgemm( '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_dgetrf2( m-n1, n2, a( n1+1, n1+1 ), lda, ipiv( n1+1 ),iinfo ) + call stdlib${ii}$_dgetrf2( 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_dlaswp( n1, a( 1, 1 ), lda, n1+1, min( m, n), ipiv, 1 ) + call stdlib${ii}$_dlaswp( n1, a( 1_${ik}$, 1_${ik}$ ), lda, n1+1, min( m, n), ipiv, 1_${ik}$ ) end if return - end subroutine stdlib_dgetrf2 + end subroutine stdlib${ii}$_dgetrf2 - pure subroutine stdlib_dgetri( n, a, lda, ipiv, work, lwork, info ) + pure subroutine stdlib${ii}$_dgetri( n, a, lda, ipiv, work, lwork, info ) !! DGETRI computes the inverse of a matrix using the LU factorization !! computed by DGETRF. !! This method inverts U and then computes inv(A) by solving the system @@ -26866,52 +26868,52 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*) real(dp), 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, 'DGETRI', ' ', n, -1, -1, -1 ) + info = 0_${ik}$ + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGETRI', ' ', 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_dtrtri, then u is singular, + ! form inv(u). if info > 0 from stdlib${ii}$_dtrtri, then u is singular, ! and the inverse is not computed. - call stdlib_dtrtri( 'UPPER', 'NON-UNIT', n, a, lda, info ) + call stdlib${ii}$_dtrtri( '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_dgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) + call stdlib${ii}$_dgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) else do j = 1, nrhs, nb jb = min( nrhs-j+1, nb ) - call stdlib_dgtts2( itrans, n, jb, dl, d, du, du2, ipiv, b( 1, j ),ldb ) + call stdlib${ii}$_dgtts2( itrans, n, jb, dl, d, du, du2, ipiv, b( 1_${ik}$, j ),ldb ) end do end if - end subroutine stdlib_dgttrs + end subroutine stdlib${ii}$_dgttrs - pure logical(lk) function stdlib_disnan( din ) + pure logical(lk) function stdlib${ii}$_disnan( din ) !! DISNAN returns .TRUE. if its argument is NaN, and .FALSE. !! otherwise. To be replaced by the Fortran 2003 intrinsic in the !! future. @@ -27527,12 +27529,12 @@ module stdlib_linalg_lapack_d real(dp), intent(in) :: din ! ===================================================================== ! Executable Statements - stdlib_disnan = stdlib_dlaisnan(din,din) + stdlib${ii}$_disnan = stdlib${ii}$_dlaisnan(din,din) return - end function stdlib_disnan + end function stdlib${ii}$_disnan - subroutine stdlib_dla_gbamv( trans, m, n, kl, ku, alpha, ab, ldab, x,incx, beta, y, incy ) + subroutine stdlib${ii}$_dla_gbamv( trans, m, n, kl, ku, alpha, ab, ldab, x,incx, beta, y, incy ) !! DLA_GBAMV performs one of the matrix-vector operations !! y := alpha*abs(A)*abs(x) + beta*abs(y), !! or y := alpha*abs(A)**T*abs(x) + beta*abs(y), @@ -27552,7 +27554,7 @@ module stdlib_linalg_lapack_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, ldab, m, n, kl, ku, trans + integer(${ik}$), intent(in) :: incx, incy, ldab, m, n, kl, ku, trans ! Array Arguments real(dp), intent(in) :: ab(ldab,*), x(*) real(dp), intent(inout) :: y(*) @@ -27561,68 +27563,68 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: symb_zero real(dp) :: 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_dlamch( 'SAFE MINIMUM' ) + safe1 = stdlib${ii}$_dlamch( '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. @@ -27666,7 +27668,7 @@ module stdlib_linalg_lapack_d 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. @@ -27715,10 +27717,10 @@ module stdlib_linalg_lapack_d end if end if return - end subroutine stdlib_dla_gbamv + end subroutine stdlib${ii}$_dla_gbamv - real(dp) function stdlib_dla_gbrcond( trans, n, kl, ku, ab, ldab,afb, ldafb, ipiv, cmode, c,& + real(dp) function stdlib${ii}$_dla_gbrcond( trans, n, kl, ku, ab, ldab,afb, ldafb, ipiv, cmode, c,& !! DLA_GBRCOND Estimates the Skeel condition number of op(A) * op2(C) !! where op2 is determined by CMODE as follows !! CMODE = 1 op2(C) = C @@ -27734,60 +27736,60 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: ab(ldab,*), afb(ldafb,*), c(*) real(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: notrans - integer(ilp) :: kase, i, j, kd, ke + integer(${ik}$) :: kase, i, j, kd, ke real(dp) :: ainvnm, tmp ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements - stdlib_dla_gbrcond = zero - info = 0 + stdlib${ii}$_dla_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_dlamch( 'SAFE MINIMUM' ) + safe1 = stdlib${ii}$_dlamch( '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. @@ -28003,7 +28005,7 @@ module stdlib_linalg_lapack_d 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. @@ -28052,10 +28054,10 @@ module stdlib_linalg_lapack_d end if end if return - end subroutine stdlib_dla_geamv + end subroutine stdlib${ii}$_dla_geamv - real(dp) function stdlib_dla_gercond( trans, n, a, lda, af,ldaf, ipiv, cmode, c,info, work, & + real(dp) function stdlib${ii}$_dla_gercond( trans, n, a, lda, af,ldaf, ipiv, cmode, c,info, work, & !! DLA_GERCOND estimates the Skeel condition number of op(A) * op2(C) !! where op2 is determined by CMODE as follows !! CMODE = 1 op2(C) = C @@ -28071,42 +28073,42 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: a(lda,*), af(ldaf,*), c(*) real(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: notrans - integer(ilp) :: kase, i, j + integer(${ik}$) :: kase, i, j real(dp) :: ainvnm, tmp ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements - stdlib_dla_gercond = zero - info = 0 + stdlib${ii}$_dla_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_dlamch( 'SAFE MINIMUM' ) + safe1 = stdlib${ii}$_dlamch( '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 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. @@ -28530,7 +28532,7 @@ module stdlib_linalg_lapack_d 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. @@ -28591,10 +28593,10 @@ module stdlib_linalg_lapack_d end if end if return - end subroutine stdlib_dla_syamv + end subroutine stdlib${ii}$_dla_syamv - real(dp) function stdlib_dla_syrcond( uplo, n, a, lda, af, ldaf,ipiv, cmode, c, info, work,& + real(dp) function stdlib${ii}$_dla_syrcond( uplo, n, a, lda, af, ldaf,ipiv, cmode, c, info, work,& !! DLA_SYRCOND estimates the Skeel condition number of op(A) * op2(C) !! where op2 is determined by CMODE as follows !! CMODE = 1 op2(C) = C @@ -28610,39 +28612,39 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: a(lda,*), af(ldaf,*), c(*) real(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars character :: normin - integer(ilp) :: kase, i, j + integer(${ik}$) :: kase, i, j real(dp) :: 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_dla_syrcond = zero - info = 0 - if( n<0 ) then - info = -2 - else if( lda0 ) - if ( ipiv( k )>0 ) then + if ( ipiv( k )>0_${ik}$ ) then ! 1x1 pivot kp = ipiv( k ) if ( kp /= k ) then @@ -28837,7 +28839,7 @@ module stdlib_linalg_lapack_d 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 kp = -ipiv( k ) @@ -28849,31 +28851,31 @@ module stdlib_linalg_lapack_d 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 + if ( ipiv( k )>0_${ik}$ ) then ! 1x1 pivot kp = ipiv( k ) if ( kp /= k ) then @@ -28884,7 +28886,7 @@ module stdlib_linalg_lapack_d 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 kp = -ipiv( k ) @@ -28896,25 +28898,25 @@ module stdlib_linalg_lapack_d 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 @@ -28941,11 +28943,11 @@ module stdlib_linalg_lapack_d end if end do end if - stdlib_dla_syrpvgrw = rpvgrw - end function stdlib_dla_syrpvgrw + stdlib${ii}$_dla_syrpvgrw = rpvgrw + end function stdlib${ii}$_dla_syrpvgrw - pure subroutine stdlib_dladiv1( a, b, c, d, p, q ) + pure subroutine stdlib${ii}$_dladiv1( 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..-- @@ -28960,14 +28962,14 @@ module stdlib_linalg_lapack_d ! Executable Statements r = d / c t = one / (c + d * r) - p = stdlib_dladiv2(a, b, c, d, r, t) + p = stdlib${ii}$_dladiv2(a, b, c, d, r, t) a = -a - q = stdlib_dladiv2(b, a, c, d, r, t) + q = stdlib${ii}$_dladiv2(b, a, c, d, r, t) return - end subroutine stdlib_dladiv1 + end subroutine stdlib${ii}$_dladiv1 - pure subroutine stdlib_dlaed6( kniter, orgati, rho, d, z, finit, tau, info ) + pure subroutine stdlib${ii}$_dlaed6( kniter, orgati, rho, d, z, finit, tau, info ) !! DLAED6 computes the positive or negative root (closest to the origin) !! of !! z(1) z(2) z(3) @@ -28984,53 +28986,53 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: finit, rho real(dp), intent(out) :: tau ! Array Arguments - real(dp), intent(in) :: d(3), z(3) + real(dp), intent(in) :: d(3_${ik}$), z(3_${ik}$) ! ===================================================================== ! Parameters - integer(ilp), parameter :: maxit = 40 + integer(${ik}$), parameter :: maxit = 40_${ik}$ ! Local Arrays - real(dp) :: dscale(3), zscale(3) + real(dp) :: dscale(3_${ik}$), zscale(3_${ik}$) ! Local Scalars logical(lk) :: scale - integer(ilp) :: i, iter, niter + integer(${ik}$) :: i, iter, niter real(dp) :: 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 @@ -29044,11 +29046,11 @@ module stdlib_linalg_lapack_d 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 @@ -29061,9 +29063,9 @@ module stdlib_linalg_lapack_d ! 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_dlamch( 'EPSILON' ) - base = stdlib_dlamch( 'BASE' ) - small1 = base**( int( log( stdlib_dlamch( 'SAFMIN' ) ) / log( base ) /three,KIND=ilp) ) + eps = stdlib${ii}$_dlamch( 'EPSILON' ) + base = stdlib${ii}$_dlamch( 'BASE' ) + small1 = base**( int( log( stdlib${ii}$_dlamch( 'SAFMIN' ) ) / log( base ) /three,KIND=${ik}$) ) sminv1 = one / small1 small2 = small1*small1 @@ -29071,9 +29073,9 @@ module stdlib_linalg_lapack_d ! determine if scaling of inputs necessary to avoid overflow ! when computing 1/temp**3 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 @@ -29128,14 +29130,14 @@ module stdlib_linalg_lapack_d ! if finit < 0; ! 2) 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 @@ -29177,23 +29179,22 @@ module stdlib_linalg_lapack_d 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_dlaed6 + end subroutine stdlib${ii}$_dlaed6 - pure subroutine stdlib_dlags2( upper, a1, a2, a3, b1, b2, b3, csu, snu, csv,snv, csq, snq ) + pure subroutine stdlib${ii}$_dlags2( upper, a1, a2, a3, b1, b2, b3, csu, snu, csv,snv, csq, snq ) !! DLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such !! that if ( UPPER ) then !! U**T *A*Q = U**T *( A1 A2 )*Q = ( x 0 ) @@ -29238,7 +29239,7 @@ module stdlib_linalg_lapack_d ! 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_dlasv2( a, b, d, s1, s2, snr, csr, snl, csl ) + call stdlib${ii}$_dlasv2( 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|. @@ -29252,12 +29253,12 @@ module stdlib_linalg_lapack_d if( ( abs( ua11r )+abs( ua12 ) )/=zero ) then if( aua12 / ( abs( ua11r )+abs( ua12 ) )<=avb12 /( abs( vb11r )+abs( vb12 ) ) & ) then - call stdlib_dlartg( -ua11r, ua12, csq, snq, r ) + call stdlib${ii}$_dlartg( -ua11r, ua12, csq, snq, r ) else - call stdlib_dlartg( -vb11r, vb12, csq, snq, r ) + call stdlib${ii}$_dlartg( -vb11r, vb12, csq, snq, r ) end if else - call stdlib_dlartg( -vb11r, vb12, csq, snq, r ) + call stdlib${ii}$_dlartg( -vb11r, vb12, csq, snq, r ) end if csu = csl snu = -snl @@ -29276,12 +29277,12 @@ module stdlib_linalg_lapack_d if( ( abs( ua21 )+abs( ua22 ) )/=zero ) then if( aua22 / ( abs( ua21 )+abs( ua22 ) )<=avb22 /( abs( vb21 )+abs( vb22 ) ) ) & then - call stdlib_dlartg( -ua21, ua22, csq, snq, r ) + call stdlib${ii}$_dlartg( -ua21, ua22, csq, snq, r ) else - call stdlib_dlartg( -vb21, vb22, csq, snq, r ) + call stdlib${ii}$_dlartg( -vb21, vb22, csq, snq, r ) end if else - call stdlib_dlartg( -vb21, vb22, csq, snq, r ) + call stdlib${ii}$_dlartg( -vb21, vb22, csq, snq, r ) end if csu = snl snu = csl @@ -29298,7 +29299,7 @@ module stdlib_linalg_lapack_d ! 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_dlasv2( a, c, d, s1, s2, snr, csr, snl, csl ) + call stdlib${ii}$_dlasv2( 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|. @@ -29312,12 +29313,12 @@ module stdlib_linalg_lapack_d if( ( abs( ua21 )+abs( ua22r ) )/=zero ) then if( aua21 / ( abs( ua21 )+abs( ua22r ) )<=avb21 /( abs( vb21 )+abs( vb22r ) ) & ) then - call stdlib_dlartg( ua22r, ua21, csq, snq, r ) + call stdlib${ii}$_dlartg( ua22r, ua21, csq, snq, r ) else - call stdlib_dlartg( vb22r, vb21, csq, snq, r ) + call stdlib${ii}$_dlartg( vb22r, vb21, csq, snq, r ) end if else - call stdlib_dlartg( vb22r, vb21, csq, snq, r ) + call stdlib${ii}$_dlartg( vb22r, vb21, csq, snq, r ) end if csu = csr snu = -snr @@ -29336,12 +29337,12 @@ module stdlib_linalg_lapack_d if( ( abs( ua11 )+abs( ua12 ) )/=zero ) then if( aua11 / ( abs( ua11 )+abs( ua12 ) )<=avb11 /( abs( vb11 )+abs( vb12 ) ) ) & then - call stdlib_dlartg( ua12, ua11, csq, snq, r ) + call stdlib${ii}$_dlartg( ua12, ua11, csq, snq, r ) else - call stdlib_dlartg( vb12, vb11, csq, snq, r ) + call stdlib${ii}$_dlartg( vb12, vb11, csq, snq, r ) end if else - call stdlib_dlartg( vb12, vb11, csq, snq, r ) + call stdlib${ii}$_dlartg( vb12, vb11, csq, snq, r ) end if csu = snr snu = csr @@ -29350,10 +29351,10 @@ module stdlib_linalg_lapack_d end if end if return - end subroutine stdlib_dlags2 + end subroutine stdlib${ii}$_dlags2 - pure subroutine stdlib_dlagtf( n, a, lambda, b, c, tol, d, in, info ) + pure subroutine stdlib${ii}$_dlagtf( n, a, lambda, b, c, tol, d, in, info ) !! DLAGTF factorizes the matrix (T - lambda*I), where T is an n by n !! tridiagonal matrix and lambda is a scalar, as !! T - lambda*I = PLU, @@ -29370,37 +29371,37 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: lambda, tol ! Array Arguments - integer(ilp), intent(out) :: in(*) + integer(${ik}$), intent(out) :: in(*) real(dp), intent(inout) :: a(*), b(*), c(*) real(dp), intent(out) :: d(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: k + integer(${ik}$) :: k real(dp) :: 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( 'DLAGTF', -info ) + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -1_${ik}$ + call stdlib${ii}$_xerbla( 'DLAGTF', -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_dlamch( 'EPSILON' ) + eps = stdlib${ii}$_dlamch( '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 ) ) @@ -29411,20 +29412,20 @@ module stdlib_linalg_lapack_d 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 ) @@ -29437,14 +29438,14 @@ module stdlib_linalg_lapack_d 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_dlagtf + end subroutine stdlib${ii}$_dlagtf - pure subroutine stdlib_dlagts( job, n, a, b, c, d, in, y, tol, info ) + pure subroutine stdlib${ii}$_dlagts( job, n, a, b, c, d, in, y, tol, info ) !! DLAGTS may be used to solve one of the systems of equations !! (T - lambda*I)*x = y or (T - lambda*I)**T*x = y, !! where T is an n by n tridiagonal matrix, for x, following the @@ -29458,39 +29459,39 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: tol ! Array Arguments - integer(ilp), intent(in) :: in(*) + integer(${ik}$), intent(in) :: in(*) real(dp), intent(in) :: a(*), b(*), c(*), d(*) real(dp), intent(inout) :: y(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: k + integer(${ik}$) :: k real(dp) :: 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( 'DLAGTS', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DLAGTS', -info ) return end if if( n==0 )return - eps = stdlib_dlamch( 'EPSILON' ) - sfmin = stdlib_dlamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_dlamch( 'EPSILON' ) + sfmin = stdlib${ii}$_dlamch( '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 @@ -29498,9 +29499,9 @@ module stdlib_linalg_lapack_d 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 ) @@ -29508,7 +29509,7 @@ module stdlib_linalg_lapack_d 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 ) @@ -29552,7 +29553,7 @@ module stdlib_linalg_lapack_d if( absakabsak )then ak = ak + pert - pert = 2*pert + pert = 2_${ik}$*pert go to 40 else temp = temp*bignum @@ -29560,7 +29561,7 @@ module stdlib_linalg_lapack_d 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 @@ -29569,11 +29570,11 @@ module stdlib_linalg_lapack_d end if else ! come to here if job = 2 or -2 - if( job==2 ) then + 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 ) @@ -29598,9 +29599,9 @@ module stdlib_linalg_lapack_d 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 ) @@ -29613,7 +29614,7 @@ module stdlib_linalg_lapack_d if( absakabsak )then ak = ak + pert - pert = 2*pert + pert = 2_${ik}$*pert go to 70 else temp = temp*bignum @@ -29621,7 +29622,7 @@ module stdlib_linalg_lapack_d 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 @@ -29629,7 +29630,7 @@ module stdlib_linalg_lapack_d 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 ) @@ -29638,10 +29639,10 @@ module stdlib_linalg_lapack_d end if end do end if - end subroutine stdlib_dlagts + end subroutine stdlib${ii}$_dlagts - pure subroutine stdlib_dlaic1( job, j, x, sest, w, gamma, sestpr, s, c ) + pure subroutine stdlib${ii}$_dlaic1( job, j, x, sest, w, gamma, sestpr, s, c ) !! DLAIC1 applies one step of incremental condition estimation in !! its simplest version: !! Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j @@ -29666,7 +29667,7 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(out) :: c, s, sestpr real(dp), intent(in) :: gamma, sest ! Array Arguments @@ -29680,12 +29681,12 @@ module stdlib_linalg_lapack_d ! Intrinsic Functions intrinsic :: abs,max,sign,sqrt ! Executable Statements - eps = stdlib_dlamch( 'EPSILON' ) - alpha = stdlib_ddot( j, x, 1, w, 1 ) + eps = stdlib${ii}$_dlamch( 'EPSILON' ) + alpha = stdlib${ii}$_ddot( 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 @@ -29760,7 +29761,7 @@ module stdlib_linalg_lapack_d 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 @@ -29850,10 +29851,10 @@ module stdlib_linalg_lapack_d end if end if return - end subroutine stdlib_dlaic1 + end subroutine stdlib${ii}$_dlaic1 - pure integer(ilp) function stdlib_dlaneg( n, d, lld, sigma, pivmin, r ) + pure integer(${ik}$) function stdlib${ii}$_dlaneg( n, d, lld, sigma, pivmin, r ) !! DLANEG computes the Sturm count, the number of negative pivots !! encountered while factoring tridiagonal T - sigma I = L D L^T. !! This implementation works directly on the factors without forming @@ -29873,13 +29874,13 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: pivmin, sigma ! Array Arguments real(dp), 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 @@ -29888,37 +29889,37 @@ module stdlib_linalg_lapack_d ! 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(dp) :: 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_dlassq( n-1, dl, 1, scale, sum ) - call stdlib_dlassq( n-1, du, 1, scale, sum ) + call stdlib${ii}$_dlassq( n, d, 1_${ik}$, scale, sum ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_dlassq( n-1, dl, 1_${ik}$, scale, sum ) + call stdlib${ii}$_dlassq( n-1, du, 1_${ik}$, scale, sum ) end if anorm = scale*sqrt( sum ) end if - stdlib_dlangt = anorm + stdlib${ii}$_dlangt = anorm return - end function stdlib_dlangt + end function stdlib${ii}$_dlangt - real(dp) function stdlib_dlanhs( norm, n, a, lda, work ) + real(dp) function stdlib${ii}$_dlanhs( norm, n, a, lda, work ) !! DLANHS returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! Hessenberg matrix A. @@ -30190,19 +30191,19 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: a(lda,*) real(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: 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))). @@ -30210,7 +30211,7 @@ module stdlib_linalg_lapack_d do j = 1, n do i = 1, min( n, j+1 ) sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do end do else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then @@ -30221,7 +30222,7 @@ module stdlib_linalg_lapack_d do i = 1, min( n, j+1 ) sum = sum + abs( a( i, j ) ) end do - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do else if( stdlib_lsame( norm, 'I' ) ) then ! find normi(a). @@ -30236,7 +30237,7 @@ module stdlib_linalg_lapack_d value = zero do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & then @@ -30244,16 +30245,16 @@ module stdlib_linalg_lapack_d scale = zero sum = one do j = 1, n - call stdlib_dlassq( min( n, j+1 ), a( 1, j ), 1, scale, sum ) + call stdlib${ii}$_dlassq( min( n, j+1 ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum ) end do value = scale*sqrt( sum ) end if - stdlib_dlanhs = value + stdlib${ii}$_dlanhs = value return - end function stdlib_dlanhs + end function stdlib${ii}$_dlanhs - real(dp) function stdlib_dlansb( norm, uplo, n, k, ab, ldab,work ) + real(dp) function stdlib${ii}$_dlansb( norm, uplo, n, k, ab, ldab,work ) !! DLANSB returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of an !! n by n symmetric band matrix A, with k super-diagonals. @@ -30262,19 +30263,19 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: ab(ldab,*) real(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, l + integer(${ik}$) :: i, j, l real(dp) :: 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))). @@ -30283,14 +30284,14 @@ module stdlib_linalg_lapack_d do j = 1, n do i = max( k+2-j, 1 ), k + 1 sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( 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_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do end do end if @@ -30301,7 +30302,7 @@ module stdlib_linalg_lapack_d 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 @@ -30311,21 +30312,21 @@ module stdlib_linalg_lapack_d end do do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( 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_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do end if else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & @@ -30333,32 +30334,32 @@ module stdlib_linalg_lapack_d ! 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_dlassq( min( j-1, k ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) + call stdlib${ii}$_dlassq( 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_dlassq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) + call stdlib${ii}$_dlassq( 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_dlassq( n, ab( l, 1 ), ldab, scale, sum ) + call stdlib${ii}$_dlassq( n, ab( l, 1_${ik}$ ), ldab, scale, sum ) value = scale*sqrt( sum ) end if - stdlib_dlansb = value + stdlib${ii}$_dlansb = value return - end function stdlib_dlansb + end function stdlib${ii}$_dlansb - real(dp) function stdlib_dlansf( norm, transr, uplo, n, a, work ) + real(dp) function stdlib${ii}$_dlansf( norm, transr, uplo, n, a, work ) !! DLANSF returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! real symmetric matrix A in RFP format. @@ -30367,60 +30368,60 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: a(0:*) - real(dp), intent(out) :: work(0:*) + real(dp), intent(in) :: a(0_${ik}$:*) + real(dp), 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(dp) :: scale, s, value, aa, temp ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements - if( n==0 ) then - stdlib_dlansf = zero + if( n==0_${ik}$ ) then + stdlib${ii}$_dlansf = zero return - else if( n==1 ) then - stdlib_dlansf = abs( a(0) ) + else if( n==1_${ik}$ ) then + stdlib${ii}$_dlansf = abs( a(0_${ik}$) ) 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 + noe = 1_${ik}$ + if( mod( n, 2_${ik}$ )==0_${ik}$ )noe = 0_${ik}$ ! set ifm = 0 when form='t or 't' and 1 otherwise - ifm = 1 - if( stdlib_lsame( transr, 'T' ) )ifm = 0 + ifm = 1_${ik}$ + if( stdlib_lsame( transr, 'T' ) )ifm = 0_${ik}$ ! set ilu = 0 when uplo='u or 'u' and 1 otherwise - ilu = 1 - if( stdlib_lsame( uplo, 'U' ) )ilu = 0 + ilu = 1_${ik}$ + if( stdlib_lsame( uplo, 'U' ) )ilu = 0_${ik}$ ! 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( ifm==1_${ik}$ ) then + if( noe==1_${ik}$ ) then lda = n else ! noe=0 - lda = n + 1 + lda = n + 1_${ik}$ end if else ! ifm=0 - lda = ( n+1 ) / 2 + 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_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do end do else @@ -30428,18 +30429,18 @@ module stdlib_linalg_lapack_d do j = 0, n - 1 do i = 0, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( 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_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do end do else @@ -30447,7 +30448,7 @@ module stdlib_linalg_lapack_d do j = 0, n do i = 0, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do end do end if @@ -30455,11 +30456,11 @@ module stdlib_linalg_lapack_d else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( & norm=='1' ) ) 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 @@ -30475,13 +30476,13 @@ module stdlib_linalg_lapack_d ! -> 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 @@ -30490,14 +30491,14 @@ module stdlib_linalg_lapack_d 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_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do else ! ilu = 1 - k = k + 1 + k = k + 1_${ik}$ ! k=(n+1)/2 for n odd and ilu=1 do i = k, n - 1 work( i ) = zero @@ -30510,20 +30511,20 @@ module stdlib_linalg_lapack_d 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 @@ -30531,15 +30532,15 @@ module stdlib_linalg_lapack_d 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_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( 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 @@ -30554,13 +30555,13 @@ module stdlib_linalg_lapack_d 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 @@ -30568,10 +30569,10 @@ module stdlib_linalg_lapack_d 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_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do else ! ilu = 1 @@ -30591,13 +30592,13 @@ module stdlib_linalg_lapack_d 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 @@ -30605,22 +30606,22 @@ module stdlib_linalg_lapack_d 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_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do end if end if else ! ifm=0 - k = n / 2 - if( noe==1 ) then + 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 + k = k + 1_${ik}$ ! k is the row size and lda do i = n1, n - 1 work( i ) = zero @@ -30636,7 +30637,7 @@ module stdlib_linalg_lapack_d 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 ) ) @@ -30658,11 +30659,11 @@ module stdlib_linalg_lapack_d ! 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 @@ -30670,14 +30671,14 @@ module stdlib_linalg_lapack_d 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_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do else ! ilu=1 - k = k + 1 + k = k + 1_${ik}$ ! k=(n+1)/2 for n odd and ilu=1 do i = k, n - 1 work( i ) = zero @@ -30696,12 +30697,12 @@ module stdlib_linalg_lapack_d 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 @@ -30734,15 +30735,15 @@ module stdlib_linalg_lapack_d 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_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( 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 @@ -30757,7 +30758,7 @@ module stdlib_linalg_lapack_d 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 @@ -30780,12 +30781,12 @@ module stdlib_linalg_lapack_d ! 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 @@ -30806,10 +30807,10 @@ module stdlib_linalg_lapack_d ! 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_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do else ! ilu=1 @@ -30817,7 +30818,7 @@ module stdlib_linalg_lapack_d work( i ) = zero end do ! j=0 is special :process col a(k:n-1,k) - s = abs( a( 0 ) ) + s = abs( a( 0_${ik}$ ) ) ! a(k,k) do i = 1, k - 1 aa = abs( a( i ) ) @@ -30840,12 +30841,12 @@ module stdlib_linalg_lapack_d 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 @@ -30878,10 +30879,10 @@ module stdlib_linalg_lapack_d 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_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do end if end if @@ -30889,180 +30890,180 @@ module stdlib_linalg_lapack_d 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_dlassq( k-j-2, a( k+j+1+j*lda ), 1, scale, s ) + call stdlib${ii}$_dlassq( k-j-2, a( k+j+1+j*lda ), 1_${ik}$, scale, s ) ! l at a(k,0) end do do j = 0, k - 1 - call stdlib_dlassq( k+j-1, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_dlassq( k+j-1, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! trap u at a(0,0) end do s = s + s ! double s for the off diagonal elements - call stdlib_dlassq( k-1, a( k ), lda+1, scale, s ) + call stdlib${ii}$_dlassq( k-1, a( k ), lda+1, scale, s ) ! tri l at a(k,0) - call stdlib_dlassq( k, a( k-1 ), lda+1, scale, s ) + call stdlib${ii}$_dlassq( k, a( k-1 ), lda+1, scale, s ) ! tri u at a(k-1,0) else ! ilu=1 do j = 0, k - 1 - call stdlib_dlassq( n-j-1, a( j+1+j*lda ), 1, scale, s ) + call stdlib${ii}$_dlassq( n-j-1, a( j+1+j*lda ), 1_${ik}$, scale, s ) ! trap l at a(0,0) end do do j = 0, k - 2 - call stdlib_dlassq( j, a( 0+( 1+j )*lda ), 1, scale, s ) + call stdlib${ii}$_dlassq( j, a( 0_${ik}$+( 1_${ik}$+j )*lda ), 1_${ik}$, scale, s ) ! u at a(0,1) end do s = s + s ! double s for the off diagonal elements - call stdlib_dlassq( k, a( 0 ), lda+1, scale, s ) + call stdlib${ii}$_dlassq( k, a( 0_${ik}$ ), lda+1, scale, s ) ! tri l at a(0,0) - call stdlib_dlassq( k-1, a( 0+lda ), lda+1, scale, s ) + call stdlib${ii}$_dlassq( k-1, a( 0_${ik}$+lda ), lda+1, scale, s ) ! tri u at a(0,1) 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_dlassq( j, a( 0+( k+j )*lda ), 1, scale, s ) + call stdlib${ii}$_dlassq( j, a( 0_${ik}$+( k+j )*lda ), 1_${ik}$, scale, s ) ! u at a(0,k) end do do j = 0, k - 2 - call stdlib_dlassq( k, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_dlassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! k by k-1 rect. at a(0,0) end do do j = 0, k - 2 - call stdlib_dlassq( k-j-1, a( j+1+( j+k-1 )*lda ), 1,scale, s ) + call stdlib${ii}$_dlassq( k-j-1, a( j+1+( j+k-1 )*lda ), 1_${ik}$,scale, s ) ! l at a(0,k-1) end do s = s + s ! double s for the off diagonal elements - call stdlib_dlassq( k-1, a( 0+k*lda ), lda+1, scale, s ) + call stdlib${ii}$_dlassq( k-1, a( 0_${ik}$+k*lda ), lda+1, scale, s ) ! tri u at a(0,k) - call stdlib_dlassq( k, a( 0+( k-1 )*lda ), lda+1, scale, s ) + call stdlib${ii}$_dlassq( k, a( 0_${ik}$+( k-1 )*lda ), lda+1, scale, s ) ! tri l at a(0,k-1) else ! a**t is lower do j = 1, k - 1 - call stdlib_dlassq( j, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_dlassq( j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! u at a(0,0) end do do j = k, n - 1 - call stdlib_dlassq( k, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_dlassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! k by k-1 rect. at a(0,k) end do do j = 0, k - 3 - call stdlib_dlassq( k-j-2, a( j+2+j*lda ), 1, scale, s ) + call stdlib${ii}$_dlassq( k-j-2, a( j+2+j*lda ), 1_${ik}$, scale, s ) ! l at a(1,0) end do s = s + s ! double s for the off diagonal elements - call stdlib_dlassq( k, a( 0 ), lda+1, scale, s ) + call stdlib${ii}$_dlassq( k, a( 0_${ik}$ ), lda+1, scale, s ) ! tri u at a(0,0) - call stdlib_dlassq( k-1, a( 1 ), lda+1, scale, s ) + call stdlib${ii}$_dlassq( k-1, a( 1_${ik}$ ), lda+1, scale, s ) ! tri l at a(1,0) 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_dlassq( k-j-1, a( k+j+2+j*lda ), 1, scale, s ) + call stdlib${ii}$_dlassq( k-j-1, a( k+j+2+j*lda ), 1_${ik}$, scale, s ) ! l at a(k+1,0) end do do j = 0, k - 1 - call stdlib_dlassq( k+j, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_dlassq( k+j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! trap u at a(0,0) end do s = s + s ! double s for the off diagonal elements - call stdlib_dlassq( k, a( k+1 ), lda+1, scale, s ) + call stdlib${ii}$_dlassq( k, a( k+1 ), lda+1, scale, s ) ! tri l at a(k+1,0) - call stdlib_dlassq( k, a( k ), lda+1, scale, s ) + call stdlib${ii}$_dlassq( k, a( k ), lda+1, scale, s ) ! tri u at a(k,0) else ! ilu=1 do j = 0, k - 1 - call stdlib_dlassq( n-j-1, a( j+2+j*lda ), 1, scale, s ) + call stdlib${ii}$_dlassq( n-j-1, a( j+2+j*lda ), 1_${ik}$, scale, s ) ! trap l at a(1,0) end do do j = 1, k - 1 - call stdlib_dlassq( j, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_dlassq( j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! u at a(0,0) end do s = s + s ! double s for the off diagonal elements - call stdlib_dlassq( k, a( 1 ), lda+1, scale, s ) + call stdlib${ii}$_dlassq( k, a( 1_${ik}$ ), lda+1, scale, s ) ! tri l at a(1,0) - call stdlib_dlassq( k, a( 0 ), lda+1, scale, s ) + call stdlib${ii}$_dlassq( k, a( 0_${ik}$ ), lda+1, scale, s ) ! tri u at a(0,0) 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_dlassq( j, a( 0+( k+1+j )*lda ), 1, scale, s ) + call stdlib${ii}$_dlassq( j, a( 0_${ik}$+( k+1+j )*lda ), 1_${ik}$, scale, s ) ! u at a(0,k+1) end do do j = 0, k - 1 - call stdlib_dlassq( k, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_dlassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! k by k rect. at a(0,0) end do do j = 0, k - 2 - call stdlib_dlassq( k-j-1, a( j+1+( j+k )*lda ), 1, scale,s ) + call stdlib${ii}$_dlassq( k-j-1, a( j+1+( j+k )*lda ), 1_${ik}$, scale,s ) ! l at a(0,k) end do s = s + s ! double s for the off diagonal elements - call stdlib_dlassq( k, a( 0+( k+1 )*lda ), lda+1, scale, s ) + call stdlib${ii}$_dlassq( k, a( 0_${ik}$+( k+1 )*lda ), lda+1, scale, s ) ! tri u at a(0,k+1) - call stdlib_dlassq( k, a( 0+k*lda ), lda+1, scale, s ) + call stdlib${ii}$_dlassq( k, a( 0_${ik}$+k*lda ), lda+1, scale, s ) ! tri l at a(0,k) else ! a**t is lower do j = 1, k - 1 - call stdlib_dlassq( j, a( 0+( j+1 )*lda ), 1, scale, s ) + call stdlib${ii}$_dlassq( j, a( 0_${ik}$+( j+1 )*lda ), 1_${ik}$, scale, s ) ! u at a(0,1) end do do j = k + 1, n - call stdlib_dlassq( k, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_dlassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! k by k rect. at a(0,k+1) end do do j = 0, k - 2 - call stdlib_dlassq( k-j-1, a( j+1+j*lda ), 1, scale, s ) + call stdlib${ii}$_dlassq( k-j-1, a( j+1+j*lda ), 1_${ik}$, scale, s ) ! l at a(0,0) end do s = s + s ! double s for the off diagonal elements - call stdlib_dlassq( k, a( lda ), lda+1, scale, s ) + call stdlib${ii}$_dlassq( k, a( lda ), lda+1, scale, s ) ! tri l at a(0,1) - call stdlib_dlassq( k, a( 0 ), lda+1, scale, s ) + call stdlib${ii}$_dlassq( k, a( 0_${ik}$ ), lda+1, scale, s ) ! tri u at a(0,0) end if end if end if value = scale*sqrt( s ) end if - stdlib_dlansf = value + stdlib${ii}$_dlansf = value return - end function stdlib_dlansf + end function stdlib${ii}$_dlansf - real(dp) function stdlib_dlansp( norm, uplo, n, ap, work ) + real(dp) function stdlib${ii}$_dlansp( norm, uplo, n, ap, work ) !! DLANSP returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! real symmetric matrix A, supplied in packed form. @@ -31071,47 +31072,47 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: ap(*) real(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, k + integer(${ik}$) :: i, j, k real(dp) :: 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_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( 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_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( 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 ! 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 @@ -31119,14 +31120,14 @@ module stdlib_linalg_lapack_d 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_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do else do i = 1, n @@ -31134,14 +31135,14 @@ module stdlib_linalg_lapack_d 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_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do end if else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & @@ -31149,44 +31150,44 @@ module stdlib_linalg_lapack_d ! find normf(a). scale = zero sum = one - k = 2 + k = 2_${ik}$ if( stdlib_lsame( uplo, 'U' ) ) then do j = 2, n - call stdlib_dlassq( j-1, ap( k ), 1, scale, sum ) + call stdlib${ii}$_dlassq( j-1, ap( k ), 1_${ik}$, scale, sum ) k = k + j end do else do j = 1, n - 1 - call stdlib_dlassq( n-j, ap( k ), 1, scale, sum ) - k = k + n - j + 1 + call stdlib${ii}$_dlassq( 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_dlassq( n-1, e, 1, scale, sum ) - sum = 2*sum + if( n>1_${ik}$ ) then + call stdlib${ii}$_dlassq( n-1, e, 1_${ik}$, scale, sum ) + sum = 2_${ik}$*sum end if - call stdlib_dlassq( n, d, 1, scale, sum ) + call stdlib${ii}$_dlassq( n, d, 1_${ik}$, scale, sum ) anorm = scale*sqrt( sum ) end if - stdlib_dlanst = anorm + stdlib${ii}$_dlanst = anorm return - end function stdlib_dlanst + end function stdlib${ii}$_dlanst - real(dp) function stdlib_dlansy( norm, uplo, n, a, lda, work ) + real(dp) function stdlib${ii}$_dlansy( norm, uplo, n, a, lda, work ) !! DLANSY returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! real symmetric matrix A. @@ -31257,19 +31258,19 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: a(lda,*) real(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: 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))). @@ -31278,14 +31279,14 @@ module stdlib_linalg_lapack_d do j = 1, n do i = 1, j sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( 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_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do end do end if @@ -31305,7 +31306,7 @@ module stdlib_linalg_lapack_d end do do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do else do i = 1, n @@ -31318,7 +31319,7 @@ module stdlib_linalg_lapack_d sum = sum + absa work( i ) = work( i ) + absa end do - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do end if else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & @@ -31328,23 +31329,23 @@ module stdlib_linalg_lapack_d sum = one if( stdlib_lsame( uplo, 'U' ) ) then do j = 2, n - call stdlib_dlassq( j-1, a( 1, j ), 1, scale, sum ) + call stdlib${ii}$_dlassq( j-1, a( 1_${ik}$, j ), 1_${ik}$, scale, sum ) end do else do j = 1, n - 1 - call stdlib_dlassq( n-j, a( j+1, j ), 1, scale, sum ) + call stdlib${ii}$_dlassq( n-j, a( j+1, j ), 1_${ik}$, scale, sum ) end do end if - sum = 2*sum - call stdlib_dlassq( n, a, lda+1, scale, sum ) + sum = 2_${ik}$*sum + call stdlib${ii}$_dlassq( n, a, lda+1, scale, sum ) value = scale*sqrt( sum ) end if - stdlib_dlansy = value + stdlib${ii}$_dlansy = value return - end function stdlib_dlansy + end function stdlib${ii}$_dlansy - real(dp) function stdlib_dlantb( norm, uplo, diag, n, k, ab,ldab, work ) + real(dp) function stdlib${ii}$_dlantb( norm, uplo, diag, n, k, ab,ldab, work ) !! DLANTB returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of an !! n by n triangular band matrix A, with ( k + 1 ) diagonals. @@ -31353,7 +31354,7 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: ab(ldab,*) real(dp), intent(out) :: work(*) @@ -31361,12 +31362,12 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: udiag - integer(ilp) :: i, j, l + integer(${ik}$) :: i, j, l real(dp) :: 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))). @@ -31376,14 +31377,14 @@ module stdlib_linalg_lapack_d do j = 1, n do i = max( k+2-j, 1 ), k sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( 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_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do end do end if @@ -31393,14 +31394,14 @@ module stdlib_linalg_lapack_d do j = 1, n do i = max( k+2-j, 1 ), k + 1 sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( 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_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do end do end if @@ -31422,7 +31423,7 @@ module stdlib_linalg_lapack_d sum = sum + abs( ab( i, j ) ) end do end if - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do else do j = 1, n @@ -31437,7 +31438,7 @@ module stdlib_linalg_lapack_d sum = sum + abs( ab( i, j ) ) end do end if - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do end if else if( stdlib_lsame( norm, 'I' ) ) then @@ -31449,7 +31450,7 @@ module stdlib_linalg_lapack_d 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 @@ -31459,7 +31460,7 @@ module stdlib_linalg_lapack_d 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 @@ -31471,7 +31472,7 @@ module stdlib_linalg_lapack_d 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 @@ -31481,7 +31482,7 @@ module stdlib_linalg_lapack_d 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 @@ -31490,7 +31491,7 @@ module stdlib_linalg_lapack_d end if do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & then @@ -31499,9 +31500,9 @@ module stdlib_linalg_lapack_d 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_dlassq( min( j-1, k ),ab( max( k+2-j, 1 ), j ), 1, scale,& + call stdlib${ii}$_dlassq( min( j-1, k ),ab( max( k+2-j, 1_${ik}$ ), j ), 1_${ik}$, scale,& sum ) end do end if @@ -31509,7 +31510,7 @@ module stdlib_linalg_lapack_d scale = zero sum = one do j = 1, n - call stdlib_dlassq( min( j, k+1 ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) + call stdlib${ii}$_dlassq( min( j, k+1 ), ab( max( k+2-j, 1_${ik}$ ), j ),1_${ik}$, scale, sum ) end do end if @@ -31517,27 +31518,27 @@ module stdlib_linalg_lapack_d 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_dlassq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) + call stdlib${ii}$_dlassq( 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_dlassq( min( n-j+1, k+1 ), ab( 1, j ), 1, scale,sum ) + call stdlib${ii}$_dlassq( 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_dlantb = value + stdlib${ii}$_dlantb = value return - end function stdlib_dlantb + end function stdlib${ii}$_dlantb - real(dp) function stdlib_dlantp( norm, uplo, diag, n, ap, work ) + real(dp) function stdlib${ii}$_dlantp( norm, uplo, diag, n, ap, work ) !! DLANTP returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! triangular matrix A, supplied in packed form. @@ -31546,7 +31547,7 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: ap(*) real(dp), intent(out) :: work(*) @@ -31554,23 +31555,23 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: udiag - integer(ilp) :: i, j, k + integer(${ik}$) :: i, j, k real(dp) :: 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_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do k = k + j end do @@ -31578,9 +31579,9 @@ module stdlib_linalg_lapack_d do j = 1, n do i = k + 1, k + n - j sum = abs( ap( i ) ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do - k = k + n - j + 1 + k = k + n - j + 1_${ik}$ end do end if else @@ -31589,7 +31590,7 @@ module stdlib_linalg_lapack_d do j = 1, n do i = k, k + j - 1 sum = abs( ap( i ) ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do k = k + j end do @@ -31597,16 +31598,16 @@ module stdlib_linalg_lapack_d do j = 1, n do i = k, k + n - j sum = abs( ap( i ) ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( 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 ! 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 @@ -31622,7 +31623,7 @@ module stdlib_linalg_lapack_d end do end if k = k + j - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do else do j = 1, n @@ -31637,13 +31638,13 @@ module stdlib_linalg_lapack_d sum = sum + abs( ap( i ) ) end do end if - k = k + n - j + 1 - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + k = k + n - j + 1_${ik}$ + if( value < sum .or. stdlib${ii}$_disnan( 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 @@ -31652,9 +31653,9 @@ module stdlib_linalg_lapack_d 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 @@ -31663,7 +31664,7 @@ module stdlib_linalg_lapack_d 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 @@ -31673,10 +31674,10 @@ module stdlib_linalg_lapack_d 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 @@ -31686,7 +31687,7 @@ module stdlib_linalg_lapack_d 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 @@ -31694,7 +31695,7 @@ module stdlib_linalg_lapack_d value = zero do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & then @@ -31703,17 +31704,17 @@ module stdlib_linalg_lapack_d if( stdlib_lsame( diag, 'U' ) ) then scale = one sum = n - k = 2 + k = 2_${ik}$ do j = 2, n - call stdlib_dlassq( j-1, ap( k ), 1, scale, sum ) + call stdlib${ii}$_dlassq( 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_dlassq( j, ap( k ), 1, scale, sum ) + call stdlib${ii}$_dlassq( j, ap( k ), 1_${ik}$, scale, sum ) k = k + j end do end if @@ -31721,29 +31722,29 @@ module stdlib_linalg_lapack_d if( stdlib_lsame( diag, 'U' ) ) then scale = one sum = n - k = 2 + k = 2_${ik}$ do j = 1, n - 1 - call stdlib_dlassq( n-j, ap( k ), 1, scale, sum ) - k = k + n - j + 1 + call stdlib${ii}$_dlassq( 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_dlassq( n-j+1, ap( k ), 1, scale, sum ) - k = k + n - j + 1 + call stdlib${ii}$_dlassq( 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_dlantp = value + stdlib${ii}$_dlantp = value return - end function stdlib_dlantp + end function stdlib${ii}$_dlantp - real(dp) function stdlib_dlantr( norm, uplo, diag, m, n, a, lda,work ) + real(dp) function stdlib${ii}$_dlantr( norm, uplo, diag, m, n, a, lda,work ) !! DLANTR returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! trapezoidal or triangular matrix A. @@ -31752,7 +31753,7 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: a(lda,*) real(dp), intent(out) :: work(*) @@ -31760,12 +31761,12 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: udiag - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: 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))). @@ -31775,14 +31776,14 @@ module stdlib_linalg_lapack_d do j = 1, n do i = 1, min( m, j-1 ) sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( 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_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do end do end if @@ -31792,14 +31793,14 @@ module stdlib_linalg_lapack_d do j = 1, n do i = 1, min( m, j ) sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( 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_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do end do end if @@ -31821,7 +31822,7 @@ module stdlib_linalg_lapack_d sum = sum + abs( a( i, j ) ) end do end if - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do else do j = 1, n @@ -31836,7 +31837,7 @@ module stdlib_linalg_lapack_d sum = sum + abs( a( i, j ) ) end do end if - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do end if else if( stdlib_lsame( norm, 'I' ) ) then @@ -31888,7 +31889,7 @@ module stdlib_linalg_lapack_d value = zero do i = 1, m sum = work( i ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & then @@ -31898,13 +31899,13 @@ module stdlib_linalg_lapack_d scale = one sum = min( m, n ) do j = 2, n - call stdlib_dlassq( min( m, j-1 ), a( 1, j ), 1, scale, sum ) + call stdlib${ii}$_dlassq( 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_dlassq( min( m, j ), a( 1, j ), 1, scale, sum ) + call stdlib${ii}$_dlassq( min( m, j ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum ) end do end if else @@ -31912,24 +31913,24 @@ module stdlib_linalg_lapack_d scale = one sum = min( m, n ) do j = 1, n - call stdlib_dlassq( m-j, a( min( m, j+1 ), j ), 1, scale,sum ) + call stdlib${ii}$_dlassq( 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_dlassq( m-j+1, a( j, j ), 1, scale, sum ) + call stdlib${ii}$_dlassq( m-j+1, a( j, j ), 1_${ik}$, scale, sum ) end do end if end if value = scale*sqrt( sum ) end if - stdlib_dlantr = value + stdlib${ii}$_dlantr = value return - end function stdlib_dlantr + end function stdlib${ii}$_dlantr - pure subroutine stdlib_dlaorhr_col_getrfnp( m, n, a, lda, d, info ) + pure subroutine stdlib${ii}$_dlaorhr_col_getrfnp( m, n, a, lda, d, info ) !! DLAORHR_COL_GETRFNP computes the modified LU factorization without !! pivoting of a real general M-by-N matrix A. The factorization has !! the form: @@ -31967,52 +31968,52 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*) real(dp), 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}$, 'DLAORHR_COL_GETRFNP', ' ', m, n, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=min( m, n ) ) then ! use unblocked code. - call stdlib_dlaorhr_col_getrfnp2( m, n, a, lda, d, info ) + call stdlib${ii}$_dlaorhr_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_dlaorhr_col_getrfnp2( m-j+1, jb, a( j, j ), lda,d( j ), iinfo ) + call stdlib${ii}$_dlaorhr_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_dtrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, one, & + call stdlib${ii}$_dtrsm( '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_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& + call stdlib${ii}$_dgemm( '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 @@ -32020,10 +32021,10 @@ module stdlib_linalg_lapack_d end do end if return - end subroutine stdlib_dlaorhr_col_getrfnp + end subroutine stdlib${ii}$_dlaorhr_col_getrfnp - pure real(dp) function stdlib_dlapy2( x, y ) + pure real(dp) function stdlib${ii}$_dlapy2( x, y ) !! DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary !! overflow and unnecessary underflow. ! -- lapack auxiliary routine -- @@ -32040,27 +32041,27 @@ module stdlib_linalg_lapack_d ! Intrinsic Functions intrinsic :: abs,max,min,sqrt ! Executable Statements - x_is_nan = stdlib_disnan( x ) - y_is_nan = stdlib_disnan( y ) - if ( x_is_nan ) stdlib_dlapy2 = x - if ( y_is_nan ) stdlib_dlapy2 = y - hugeval = stdlib_dlamch( 'OVERFLOW' ) + x_is_nan = stdlib${ii}$_disnan( x ) + y_is_nan = stdlib${ii}$_disnan( y ) + if ( x_is_nan ) stdlib${ii}$_dlapy2 = x + if ( y_is_nan ) stdlib${ii}$_dlapy2 = y + hugeval = stdlib${ii}$_dlamch( '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_dlapy2 = w + stdlib${ii}$_dlapy2 = w else - stdlib_dlapy2 = w*sqrt( one+( z / w )**2 ) + stdlib${ii}$_dlapy2 = w*sqrt( one+( z / w )**2_${ik}$ ) end if end if return - end function stdlib_dlapy2 + end function stdlib${ii}$_dlapy2 - pure subroutine stdlib_dlaqz1( a, lda, b, ldb, sr1, sr2, si, beta1, beta2,v ) + pure subroutine stdlib${ii}$_dlaqz1( a, lda, b, ldb, sr1, sr2, si, beta1, beta2,v ) !! Given a 3-by-3 matrix pencil (A,B), DLAQZ1: 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). @@ -32071,200 +32072,200 @@ module stdlib_linalg_lapack_d !! 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(dp), intent( in ) :: a( lda, * ), b( ldb, * ), sr1,sr2, si, beta1, beta2 real(dp), intent( out ) :: v( * ) ! local scalars - real(dp) :: w(2), safmin, safmax, scale1, scale2 - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) + real(dp) :: w(2_${ik}$), safmin, safmax, scale1, scale2 + safmin = stdlib${ii}$_dlamch( '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_disnan( v( 1 ) ) .or.stdlib_disnan( v( 2 ) ) .or. stdlib_disnan( v( 3 ) ) ) & + if( abs( v( 1_${ik}$ ) )>safmax .or. abs( v( 2_${ik}$ ) ) > safmax .or.abs( v( 3_${ik}$ ) )>safmax .or. & + stdlib${ii}$_disnan( v( 1_${ik}$ ) ) .or.stdlib${ii}$_disnan( v( 2_${ik}$ ) ) .or. stdlib${ii}$_disnan( 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_dlaqz1 + end subroutine stdlib${ii}$_dlaqz1 - pure subroutine stdlib_dlaqz2( ilq, ilz, k, istartm, istopm, ihi, a, lda, b,ldb, nq, qstart, & + pure subroutine stdlib${ii}$_dlaqz2( ilq, ilz, k, istartm, istopm, ihi, a, lda, b,ldb, nq, qstart, & !! DLAQZ2 chases a 2x2 shift bulge in a matrix pencil down a single position q, ldq, nz, zstart, z, ldz ) ! arguments logical(lk), intent( in ) :: ilq, ilz - integer(ilp), intent( in ) :: k, lda, ldb, ldq, ldz, istartm, istopm,nq, nz, qstart, & + integer(${ik}$), intent( in ) :: k, lda, ldb, ldq, ldz, istartm, istopm,nq, nz, qstart, & zstart, ihi real(dp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) ! local variables - real(dp) :: h(2,3), c1, s1, c2, s2, temp + real(dp) :: 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_dlartg( h( 1, 1 ), h( 2, 1 ), c1, s1, temp ) - h( 2, 1 ) = zero - h( 1, 1 ) = temp - call stdlib_drot( 2, h( 1, 2 ), 2, h( 2, 2 ), 2, c1, s1 ) - call stdlib_dlartg( h( 2, 3 ), h( 2, 2 ), c1, s1, temp ) - call stdlib_drot( 1, h( 1, 3 ), 1, h( 1, 2 ), 1, c1, s1 ) - call stdlib_dlartg( h( 1, 2 ), h( 1, 1 ), c2, s2, temp ) - call stdlib_drot( ihi-istartm+1, b( istartm, ihi ), 1, b( istartm,ihi-1 ), 1, c1, & + call stdlib${ii}$_dlartg( 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}$_drot( 2_${ik}$, h( 1_${ik}$, 2_${ik}$ ), 2_${ik}$, h( 2_${ik}$, 2_${ik}$ ), 2_${ik}$, c1, s1 ) + call stdlib${ii}$_dlartg( h( 2_${ik}$, 3_${ik}$ ), h( 2_${ik}$, 2_${ik}$ ), c1, s1, temp ) + call stdlib${ii}$_drot( 1_${ik}$, h( 1_${ik}$, 3_${ik}$ ), 1_${ik}$, h( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, c1, s1 ) + call stdlib${ii}$_dlartg( h( 1_${ik}$, 2_${ik}$ ), h( 1_${ik}$, 1_${ik}$ ), c2, s2, temp ) + call stdlib${ii}$_drot( ihi-istartm+1, b( istartm, ihi ), 1_${ik}$, b( istartm,ihi-1 ), 1_${ik}$, c1, & s1 ) - call stdlib_drot( ihi-istartm+1, b( istartm, ihi-1 ), 1, b( istartm,ihi-2 ), 1, c2, & + call stdlib${ii}$_drot( 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_drot( ihi-istartm+1, a( istartm, ihi ), 1, a( istartm,ihi-1 ), 1, c1, & + call stdlib${ii}$_drot( ihi-istartm+1, a( istartm, ihi ), 1_${ik}$, a( istartm,ihi-1 ), 1_${ik}$, c1, & s1 ) - call stdlib_drot( ihi-istartm+1, a( istartm, ihi-1 ), 1, a( istartm,ihi-2 ), 1, c2, & + call stdlib${ii}$_drot( ihi-istartm+1, a( istartm, ihi-1 ), 1_${ik}$, a( istartm,ihi-2 ), 1_${ik}$, c2, & s2 ) if ( ilz ) then - call stdlib_drot( nz, z( 1, ihi-zstart+1 ), 1, z( 1, ihi-1-zstart+1 ), 1, c1, s1 & + call stdlib${ii}$_drot( nz, z( 1_${ik}$, ihi-zstart+1 ), 1_${ik}$, z( 1_${ik}$, ihi-1-zstart+1 ), 1_${ik}$, c1, s1 & ) - call stdlib_drot( nz, z( 1, ihi-1-zstart+1 ), 1, z( 1,ihi-2-zstart+1 ), 1, c2, & + call stdlib${ii}$_drot( 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_dlartg( a( ihi-1, ihi-2 ), a( ihi, ihi-2 ), c1, s1,temp ) + call stdlib${ii}$_dlartg( 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_drot( istopm-ihi+2, a( ihi-1, ihi-1 ), lda, a( ihi,ihi-1 ), lda, c1, s1 & + call stdlib${ii}$_drot( istopm-ihi+2, a( ihi-1, ihi-1 ), lda, a( ihi,ihi-1 ), lda, c1, s1 & ) - call stdlib_drot( istopm-ihi+2, b( ihi-1, ihi-1 ), ldb, b( ihi,ihi-1 ), ldb, c1, s1 & + call stdlib${ii}$_drot( istopm-ihi+2, b( ihi-1, ihi-1 ), ldb, b( ihi,ihi-1 ), ldb, c1, s1 & ) if ( ilq ) then - call stdlib_drot( nq, q( 1, ihi-1-qstart+1 ), 1, q( 1, ihi-qstart+1 ), 1, c1, s1 & + call stdlib${ii}$_drot( nq, q( 1_${ik}$, ihi-1-qstart+1 ), 1_${ik}$, q( 1_${ik}$, ihi-qstart+1 ), 1_${ik}$, c1, s1 & ) end if - call stdlib_dlartg( b( ihi, ihi ), b( ihi, ihi-1 ), c1, s1, temp ) + call stdlib${ii}$_dlartg( b( ihi, ihi ), b( ihi, ihi-1 ), c1, s1, temp ) b( ihi, ihi ) = temp b( ihi, ihi-1 ) = zero - call stdlib_drot( ihi-istartm, b( istartm, ihi ), 1, b( istartm,ihi-1 ), 1, c1, s1 ) + call stdlib${ii}$_drot( ihi-istartm, b( istartm, ihi ), 1_${ik}$, b( istartm,ihi-1 ), 1_${ik}$, c1, s1 ) - call stdlib_drot( ihi-istartm+1, a( istartm, ihi ), 1, a( istartm,ihi-1 ), 1, c1, & + call stdlib${ii}$_drot( ihi-istartm+1, a( istartm, ihi ), 1_${ik}$, a( istartm,ihi-1 ), 1_${ik}$, c1, & s1 ) if ( ilz ) then - call stdlib_drot( nz, z( 1, ihi-zstart+1 ), 1, z( 1, ihi-1-zstart+1 ), 1, c1, s1 & + call stdlib${ii}$_drot( 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_dlartg( h( 1, 1 ), h( 2, 1 ), c1, s1, temp ) - h( 2, 1 ) = zero - h( 1, 1 ) = temp - call stdlib_drot( 2, h( 1, 2 ), 2, h( 2, 2 ), 2, c1, s1 ) + call stdlib${ii}$_dlartg( 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}$_drot( 2_${ik}$, h( 1_${ik}$, 2_${ik}$ ), 2_${ik}$, h( 2_${ik}$, 2_${ik}$ ), 2_${ik}$, c1, s1 ) ! calculate z1 and z2 - call stdlib_dlartg( h( 2, 3 ), h( 2, 2 ), c1, s1, temp ) - call stdlib_drot( 1, h( 1, 3 ), 1, h( 1, 2 ), 1, c1, s1 ) - call stdlib_dlartg( h( 1, 2 ), h( 1, 1 ), c2, s2, temp ) + call stdlib${ii}$_dlartg( h( 2_${ik}$, 3_${ik}$ ), h( 2_${ik}$, 2_${ik}$ ), c1, s1, temp ) + call stdlib${ii}$_drot( 1_${ik}$, h( 1_${ik}$, 3_${ik}$ ), 1_${ik}$, h( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, c1, s1 ) + call stdlib${ii}$_dlartg( h( 1_${ik}$, 2_${ik}$ ), h( 1_${ik}$, 1_${ik}$ ), c2, s2, temp ) ! apply transformations from the right - call stdlib_drot( k+3-istartm+1, a( istartm, k+2 ), 1, a( istartm,k+1 ), 1, c1, s1 ) + call stdlib${ii}$_drot( k+3-istartm+1, a( istartm, k+2 ), 1_${ik}$, a( istartm,k+1 ), 1_${ik}$, c1, s1 ) - call stdlib_drot( k+3-istartm+1, a( istartm, k+1 ), 1, a( istartm,k ), 1, c2, s2 ) + call stdlib${ii}$_drot( k+3-istartm+1, a( istartm, k+1 ), 1_${ik}$, a( istartm,k ), 1_${ik}$, c2, s2 ) - call stdlib_drot( k+2-istartm+1, b( istartm, k+2 ), 1, b( istartm,k+1 ), 1, c1, s1 ) + call stdlib${ii}$_drot( k+2-istartm+1, b( istartm, k+2 ), 1_${ik}$, b( istartm,k+1 ), 1_${ik}$, c1, s1 ) - call stdlib_drot( k+2-istartm+1, b( istartm, k+1 ), 1, b( istartm,k ), 1, c2, s2 ) + call stdlib${ii}$_drot( k+2-istartm+1, b( istartm, k+1 ), 1_${ik}$, b( istartm,k ), 1_${ik}$, c2, s2 ) if ( ilz ) then - call stdlib_drot( nz, z( 1, k+2-zstart+1 ), 1, z( 1, k+1-zstart+1 ), 1, c1, s1 ) + call stdlib${ii}$_drot( nz, z( 1_${ik}$, k+2-zstart+1 ), 1_${ik}$, z( 1_${ik}$, k+1-zstart+1 ), 1_${ik}$, c1, s1 ) - call stdlib_drot( nz, z( 1, k+1-zstart+1 ), 1, z( 1, k-zstart+1 ),1, c2, s2 ) + call stdlib${ii}$_drot( 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_dlartg( a( k+2, k ), a( k+3, k ), c1, s1, temp ) + call stdlib${ii}$_dlartg( a( k+2, k ), a( k+3, k ), c1, s1, temp ) a( k+2, k ) = temp a( k+3, k ) = zero - call stdlib_dlartg( a( k+1, k ), a( k+2, k ), c2, s2, temp ) + call stdlib${ii}$_dlartg( 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_drot( istopm-k, a( k+2, k+1 ), lda, a( k+3, k+1 ), lda,c1, s1 ) - call stdlib_drot( istopm-k, a( k+1, k+1 ), lda, a( k+2, k+1 ), lda,c2, s2 ) - call stdlib_drot( istopm-k, b( k+2, k+1 ), ldb, b( k+3, k+1 ), ldb,c1, s1 ) - call stdlib_drot( istopm-k, b( k+1, k+1 ), ldb, b( k+2, k+1 ), ldb,c2, s2 ) + call stdlib${ii}$_drot( istopm-k, a( k+2, k+1 ), lda, a( k+3, k+1 ), lda,c1, s1 ) + call stdlib${ii}$_drot( istopm-k, a( k+1, k+1 ), lda, a( k+2, k+1 ), lda,c2, s2 ) + call stdlib${ii}$_drot( istopm-k, b( k+2, k+1 ), ldb, b( k+3, k+1 ), ldb,c1, s1 ) + call stdlib${ii}$_drot( istopm-k, b( k+1, k+1 ), ldb, b( k+2, k+1 ), ldb,c2, s2 ) if ( ilq ) then - call stdlib_drot( nq, q( 1, k+2-qstart+1 ), 1, q( 1, k+3-qstart+1 ), 1, c1, s1 ) + call stdlib${ii}$_drot( nq, q( 1_${ik}$, k+2-qstart+1 ), 1_${ik}$, q( 1_${ik}$, k+3-qstart+1 ), 1_${ik}$, c1, s1 ) - call stdlib_drot( nq, q( 1, k+1-qstart+1 ), 1, q( 1, k+2-qstart+1 ), 1, c2, s2 ) + call stdlib${ii}$_drot( 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_dlaqz2 + end subroutine stdlib${ii}$_dlaqz2 - pure subroutine stdlib_dlaqz4( ilschur, ilq, ilz, n, ilo, ihi, nshifts,nblock_desired, sr, & + pure subroutine stdlib${ii}$_dlaqz4( ilschur, ilq, ilz, n, ilo, ihi, nshifts,nblock_desired, sr, & !! DLAQZ4 Executes a single multishift QZ sweep si, ss, a, lda, b, ldb, q,ldq, z, ldz, qc, ldqc, zc, ldzc, work, lwork,info ) ! function arguments logical(lk), intent( in ) :: ilschur, ilq, ilz - integer(ilp), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,nshifts, & + integer(${ik}$), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,nshifts, & nblock_desired, ldqc, ldzc real(dp), 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(dp) :: temp, v(3), c1, s1, c2, s2, swap - info = 0 + real(dp) :: 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( 'DLAQZ4', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DLAQZ4', -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 @@ -32294,71 +32295,71 @@ module stdlib_linalg_lapack_d ! 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_dlaset( 'FULL', ns+1, ns+1, zero, one, qc, ldqc ) - call stdlib_dlaset( 'FULL', ns, ns, zero, one, zc, ldzc ) + call stdlib${ii}$_dlaset( 'FULL', ns+1, ns+1, zero, one, qc, ldqc ) + call stdlib${ii}$_dlaset( 'FULL', ns, ns, zero, one, zc, ldzc ) do i = 1, ns, 2 ! introduce the shift - call stdlib_dlaqz1( a( ilo, ilo ), lda, b( ilo, ilo ), ldb, sr( i ),sr( i+1 ), si( & + call stdlib${ii}$_dlaqz1( 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_dlartg( temp, v( 3 ), c1, s1, v( 2 ) ) - call stdlib_dlartg( v( 1 ), v( 2 ), c2, s2, temp ) - call stdlib_drot( ns, a( ilo+1, ilo ), lda, a( ilo+2, ilo ), lda, c1,s1 ) - call stdlib_drot( ns, a( ilo, ilo ), lda, a( ilo+1, ilo ), lda, c2,s2 ) - call stdlib_drot( ns, b( ilo+1, ilo ), ldb, b( ilo+2, ilo ), ldb, c1,s1 ) - call stdlib_drot( ns, b( ilo, ilo ), ldb, b( ilo+1, ilo ), ldb, c2,s2 ) - call stdlib_drot( ns+1, qc( 1, 2 ), 1, qc( 1, 3 ), 1, c1, s1 ) - call stdlib_drot( ns+1, qc( 1, 1 ), 1, qc( 1, 2 ), 1, c2, s2 ) + temp = v( 2_${ik}$ ) + call stdlib${ii}$_dlartg( temp, v( 3_${ik}$ ), c1, s1, v( 2_${ik}$ ) ) + call stdlib${ii}$_dlartg( v( 1_${ik}$ ), v( 2_${ik}$ ), c2, s2, temp ) + call stdlib${ii}$_drot( ns, a( ilo+1, ilo ), lda, a( ilo+2, ilo ), lda, c1,s1 ) + call stdlib${ii}$_drot( ns, a( ilo, ilo ), lda, a( ilo+1, ilo ), lda, c2,s2 ) + call stdlib${ii}$_drot( ns, b( ilo+1, ilo ), ldb, b( ilo+2, ilo ), ldb, c1,s1 ) + call stdlib${ii}$_drot( ns, b( ilo, ilo ), ldb, b( ilo+1, ilo ), ldb, c2,s2 ) + call stdlib${ii}$_drot( ns+1, qc( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, qc( 1_${ik}$, 3_${ik}$ ), 1_${ik}$, c1, s1 ) + call stdlib${ii}$_drot( 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_dlaqz2( .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}$_dlaqz2( .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)' sheight = ns+1 - swidth = istopm-( ilo+ns )+1 - if ( swidth > 0 ) then - call stdlib_dgemm( '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}$_dgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,a( ilo, ilo+ns & ), lda, zero, work, sheight ) - call stdlib_dlacpy( 'ALL', sheight, swidth, work, sheight, a( ilo,ilo+ns ), lda ) + call stdlib${ii}$_dlacpy( 'ALL', sheight, swidth, work, sheight, a( ilo,ilo+ns ), lda ) - call stdlib_dgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,b( ilo, ilo+ns & + call stdlib${ii}$_dgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,b( ilo, ilo+ns & ), ldb, zero, work, sheight ) - call stdlib_dlacpy( 'ALL', sheight, swidth, work, sheight, b( ilo,ilo+ns ), ldb ) + call stdlib${ii}$_dlacpy( 'ALL', sheight, swidth, work, sheight, b( ilo,ilo+ns ), ldb ) end if if ( ilq ) then - call stdlib_dgemm( 'N', 'N', n, sheight, sheight, one, q( 1, ilo ),ldq, qc, ldqc, & + call stdlib${ii}$_dgemm( 'N', 'N', n, sheight, sheight, one, q( 1_${ik}$, ilo ),ldq, qc, ldqc, & zero, work, n ) - call stdlib_dlacpy( 'ALL', n, sheight, work, n, q( 1, ilo ), ldq ) + call stdlib${ii}$_dlacpy( '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) sheight = ilo-1-istartm+1 swidth = ns - if ( sheight > 0 ) then - call stdlib_dgemm( 'N', 'N', sheight, swidth, swidth, one, a( istartm,ilo ), lda, & + if ( sheight > 0_${ik}$ ) then + call stdlib${ii}$_dgemm( 'N', 'N', sheight, swidth, swidth, one, a( istartm,ilo ), lda, & zc, ldzc, zero, work, sheight ) - call stdlib_dlacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ilo ), lda ) + call stdlib${ii}$_dlacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ilo ), lda ) - call stdlib_dgemm( 'N', 'N', sheight, swidth, swidth, one, b( istartm,ilo ), ldb, & + call stdlib${ii}$_dgemm( 'N', 'N', sheight, swidth, swidth, one, b( istartm,ilo ), ldb, & zc, ldzc, zero, work, sheight ) - call stdlib_dlacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ilo ), ldb ) + call stdlib${ii}$_dlacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ilo ), ldb ) end if if ( ilz ) then - call stdlib_dgemm( 'N', 'N', n, swidth, swidth, one, z( 1, ilo ), ldz,zc, ldzc, & + call stdlib${ii}$_dgemm( 'N', 'N', n, swidth, swidth, one, z( 1_${ik}$, ilo ), ldz,zc, ldzc, & zero, work, n ) - call stdlib_dlacpy( 'ALL', n, swidth, work, n, z( 1, ilo ), ldz ) + call stdlib${ii}$_dlacpy( '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 @@ -32372,15 +32373,15 @@ module stdlib_linalg_lapack_d istartb = k+1 ! istopb points to the last column we will be updating istopb = k+nblock-1 - call stdlib_dlaset( 'FULL', ns+np, ns+np, zero, one, qc, ldqc ) - call stdlib_dlaset( 'FULL', ns+np, ns+np, zero, one, zc, ldzc ) + call stdlib${ii}$_dlaset( 'FULL', ns+np, ns+np, zero, one, qc, ldqc ) + call stdlib${ii}$_dlaset( '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_dlaqz2( .true., .true., k+i+j-1, istartb, istopb,ihi, a, lda, b, & + call stdlib${ii}$_dlaqz2( .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 @@ -32389,47 +32390,47 @@ module stdlib_linalg_lapack_d ! b(k+1:k+ns+np, k+ns+np:istopm) ! from the left with qc(1:ns+np,1:ns+np)' sheight = ns+np - swidth = istopm-( k+ns+np )+1 - if ( swidth > 0 ) then - call stdlib_dgemm( '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}$_dgemm( 'T', 'N', sheight, swidth, sheight, one, qc,ldqc, a( k+1, k+& ns+np ), lda, zero, work,sheight ) - call stdlib_dlacpy( 'ALL', sheight, swidth, work, sheight, a( k+1,k+ns+np ), lda & + call stdlib${ii}$_dlacpy( 'ALL', sheight, swidth, work, sheight, a( k+1,k+ns+np ), lda & ) - call stdlib_dgemm( 'T', 'N', sheight, swidth, sheight, one, qc,ldqc, b( k+1, k+& + call stdlib${ii}$_dgemm( 'T', 'N', sheight, swidth, sheight, one, qc,ldqc, b( k+1, k+& ns+np ), ldb, zero, work,sheight ) - call stdlib_dlacpy( 'ALL', sheight, swidth, work, sheight, b( k+1,k+ns+np ), ldb & + call stdlib${ii}$_dlacpy( 'ALL', sheight, swidth, work, sheight, b( k+1,k+ns+np ), ldb & ) end if if ( ilq ) then - call stdlib_dgemm( 'N', 'N', n, nblock, nblock, one, q( 1, k+1 ),ldq, qc, ldqc, & + call stdlib${ii}$_dgemm( 'N', 'N', n, nblock, nblock, one, q( 1_${ik}$, k+1 ),ldq, qc, ldqc, & zero, work, n ) - call stdlib_dlacpy( 'ALL', n, nblock, work, n, q( 1, k+1 ), ldq ) + call stdlib${ii}$_dlacpy( '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) sheight = k-istartm+1 swidth = nblock - if ( sheight > 0 ) then - call stdlib_dgemm( 'N', 'N', sheight, swidth, swidth, one,a( istartm, k ), lda, & + if ( sheight > 0_${ik}$ ) then + call stdlib${ii}$_dgemm( 'N', 'N', sheight, swidth, swidth, one,a( istartm, k ), lda, & zc, ldzc, zero, work,sheight ) - call stdlib_dlacpy( 'ALL', sheight, swidth, work, sheight,a( istartm, k ), lda ) + call stdlib${ii}$_dlacpy( 'ALL', sheight, swidth, work, sheight,a( istartm, k ), lda ) - call stdlib_dgemm( 'N', 'N', sheight, swidth, swidth, one,b( istartm, k ), ldb, & + call stdlib${ii}$_dgemm( 'N', 'N', sheight, swidth, swidth, one,b( istartm, k ), ldb, & zc, ldzc, zero, work,sheight ) - call stdlib_dlacpy( 'ALL', sheight, swidth, work, sheight,b( istartm, k ), ldb ) + call stdlib${ii}$_dlacpy( 'ALL', sheight, swidth, work, sheight,b( istartm, k ), ldb ) end if if ( ilz ) then - call stdlib_dgemm( 'N', 'N', n, nblock, nblock, one, z( 1, k ),ldz, zc, ldzc, & + call stdlib${ii}$_dgemm( 'N', 'N', n, nblock, nblock, one, z( 1_${ik}$, k ),ldz, zc, ldzc, & zero, work, n ) - call stdlib_dlacpy( 'ALL', n, nblock, work, n, z( 1, k ), ldz ) + call stdlib${ii}$_dlacpy( '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_dlaset( 'FULL', ns, ns, zero, one, qc, ldqc ) - call stdlib_dlaset( 'FULL', ns+1, ns+1, zero, one, zc, ldzc ) + call stdlib${ii}$_dlaset( 'FULL', ns, ns, zero, one, qc, ldqc ) + call stdlib${ii}$_dlaset( '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 @@ -32437,7 +32438,7 @@ module stdlib_linalg_lapack_d do i = 1, ns, 2 ! chase the shift down to the bottom right corner do ishift = ihi-i-1, ihi-2 - call stdlib_dlaqz2( .true., .true., ishift, istartb, istopb, ihi,a, lda, b, ldb, & + call stdlib${ii}$_dlaqz2( .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 @@ -32445,45 +32446,45 @@ module stdlib_linalg_lapack_d ! update a(ihi-ns+1:ihi, ihi+1:istopm) ! from the left with qc(1:ns,1:ns)' sheight = ns - swidth = istopm-( ihi+1 )+1 - if ( swidth > 0 ) then - call stdlib_dgemm( '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}$_dgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,a( ihi-ns+1, & ihi+1 ), lda, zero, work, sheight ) - call stdlib_dlacpy( 'ALL', sheight, swidth, work, sheight,a( ihi-ns+1, ihi+1 ), lda & + call stdlib${ii}$_dlacpy( 'ALL', sheight, swidth, work, sheight,a( ihi-ns+1, ihi+1 ), lda & ) - call stdlib_dgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,b( ihi-ns+1, & + call stdlib${ii}$_dgemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,b( ihi-ns+1, & ihi+1 ), ldb, zero, work, sheight ) - call stdlib_dlacpy( 'ALL', sheight, swidth, work, sheight,b( ihi-ns+1, ihi+1 ), ldb & + call stdlib${ii}$_dlacpy( 'ALL', sheight, swidth, work, sheight,b( ihi-ns+1, ihi+1 ), ldb & ) end if if ( ilq ) then - call stdlib_dgemm( 'N', 'N', n, ns, ns, one, q( 1, ihi-ns+1 ), ldq,qc, ldqc, zero, & + call stdlib${ii}$_dgemm( 'N', 'N', n, ns, ns, one, q( 1_${ik}$, ihi-ns+1 ), ldq,qc, ldqc, zero, & work, n ) - call stdlib_dlacpy( 'ALL', n, ns, work, n, q( 1, ihi-ns+1 ), ldq ) + call stdlib${ii}$_dlacpy( '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) sheight = ihi-ns-istartm+1 swidth = ns+1 - if ( sheight > 0 ) then - call stdlib_dgemm( 'N', 'N', sheight, swidth, swidth, one, a( istartm,ihi-ns ), lda,& + if ( sheight > 0_${ik}$ ) then + call stdlib${ii}$_dgemm( 'N', 'N', sheight, swidth, swidth, one, a( istartm,ihi-ns ), lda,& zc, ldzc, zero, work, sheight ) - call stdlib_dlacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ihi-ns ), lda & + call stdlib${ii}$_dlacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ihi-ns ), lda & ) - call stdlib_dgemm( 'N', 'N', sheight, swidth, swidth, one, b( istartm,ihi-ns ), ldb,& + call stdlib${ii}$_dgemm( 'N', 'N', sheight, swidth, swidth, one, b( istartm,ihi-ns ), ldb,& zc, ldzc, zero, work, sheight ) - call stdlib_dlacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ihi-ns ), ldb & + call stdlib${ii}$_dlacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ihi-ns ), ldb & ) end if if ( ilz ) then - call stdlib_dgemm( 'N', 'N', n, ns+1, ns+1, one, z( 1, ihi-ns ), ldz,zc, ldzc, zero,& + call stdlib${ii}$_dgemm( 'N', 'N', n, ns+1, ns+1, one, z( 1_${ik}$, ihi-ns ), ldz,zc, ldzc, zero,& work, n ) - call stdlib_dlacpy( 'ALL', n, ns+1, work, n, z( 1, ihi-ns ), ldz ) + call stdlib${ii}$_dlacpy( 'ALL', n, ns+1, work, n, z( 1_${ik}$, ihi-ns ), ldz ) end if - end subroutine stdlib_dlaqz4 + end subroutine stdlib${ii}$_dlaqz4 - pure subroutine stdlib_dlar1v( n, b1, bn, lambda, d, l, ld, lld,pivmin, gaptol, z, wantnc, & + pure subroutine stdlib${ii}$_dlar1v( n, b1, bn, lambda, d, l, ld, lld,pivmin, gaptol, z, wantnc, & !! DLAR1V computes the (scaled) r-th column of the inverse of !! the sumbmatrix in rows B1 through BN of the tridiagonal matrix !! L D L**T - sigma I. When sigma is close to an eigenvalue, the @@ -32505,13 +32506,13 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: gaptol, lambda, pivmin real(dp), intent(out) :: mingma, nrminv, resid, rqcorr, ztz ! Array Arguments - integer(ilp), intent(out) :: isuppz(*) + integer(${ik}$), intent(out) :: isuppz(*) real(dp), intent(in) :: d(*), l(*), ld(*), lld(*) real(dp), intent(out) :: work(*) real(dp), intent(inout) :: z(*) @@ -32519,13 +32520,13 @@ module stdlib_linalg_lapack_d ! 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(dp) :: dminus, dplus, eps, s, tmp ! Intrinsic Functions intrinsic :: abs ! Executable Statements - eps = stdlib_dlamch( 'PRECISION' ) - if( r==0 ) then + eps = stdlib${ii}$_dlamch( 'PRECISION' ) + if( r==0_${ik}$ ) then r1 = b1 r2 = bn else @@ -32533,12 +32534,12 @@ module stdlib_linalg_lapack_d 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 ) @@ -32546,16 +32547,16 @@ module stdlib_linalg_lapack_d ! 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 if( alpha>=zero ) then @@ -32821,27 +32822,27 @@ module stdlib_linalg_lapack_d ! 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_dlapy2( alpha, xnorm ), alpha ) - smlnum = stdlib_dlamch( 'S' ) / stdlib_dlamch( 'E' ) - knt = 0 + beta = sign( stdlib${ii}$_dlapy2( alpha, xnorm ), alpha ) + smlnum = stdlib${ii}$_dlamch( 'S' ) / stdlib${ii}$_dlamch( 'E' ) + knt = 0_${ik}$ if( abs( beta )n)) r = n + if((r<1_${ik}$).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 ) @@ -32986,12 +32987,12 @@ module stdlib_linalg_lapack_d ! 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 ) @@ -33003,7 +33004,7 @@ module stdlib_linalg_lapack_d ! do while( negcnt(left)>i-1 ) back = werr( ii ) 20 continue - negcnt = stdlib_dlaneg( n, d, lld, left, pivmin, r ) + negcnt = stdlib${ii}$_dlaneg( n, d, lld, left, pivmin, r ) if( negcnt>i-1 ) then left = left - back back = two*back @@ -33013,7 +33014,7 @@ module stdlib_linalg_lapack_d ! compute negcount from dstqds facto l+d+l+^t = l d l^t - right back = werr( ii ) 50 continue - negcnt = stdlib_dlaneg( n, d, lld, right, pivmin, r ) + negcnt = stdlib${ii}$_dlaneg( 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 @@ -33043,17 +33044,17 @@ module stdlib_linalg_lapack_d 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 ) @@ -33065,21 +33066,21 @@ module stdlib_linalg_lapack_d 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_dlaneg( n, d, lld, mid, pivmin, r ) + negcnt = stdlib${ii}$_dlaneg( n, d, lld, mid, pivmin, r ) if( negcnt<=i-1 ) then work( k-1 ) = mid else @@ -33087,31 +33088,31 @@ module stdlib_linalg_lapack_d 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 + 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_dlarrb + end subroutine stdlib${ii}$_dlarrb - pure subroutine stdlib_dlarrf( n, d, l, ld, clstrt, clend,w, wgap, werr,spdiam, clgapl, & + pure subroutine stdlib${ii}$_dlarrf( n, d, l, ld, clstrt, clend,w, wgap, werr,spdiam, clgapl, & !! Given the initial representation L D L^T and its cluster of close !! eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ... !! W( CLEND ), DLARRF: finds a new relatively robust representation @@ -33122,8 +33123,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: clgapl, clgapr, pivmin, spdiam real(dp), intent(out) :: sigma ! Array Arguments @@ -33135,27 +33136,27 @@ module stdlib_linalg_lapack_d real(dp), parameter :: quart = 0.25_dp real(dp), parameter :: maxgrowth1 = 8._dp real(dp), parameter :: maxgrowth2 = 8._dp - 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(dp) :: 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=dp) - eps = stdlib_dlamch( 'PRECISION' ) - shift = 0 + fact = real(2_${ik}$**ktrymax,KIND=dp) + eps = stdlib${ii}$_dlamch( '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. @@ -33186,13 +33187,13 @@ module stdlib_linalg_lapack_d ldelta = max(avgap,wgap( clstrt ))/fact rdelta = max(avgap,wgap( clend-1 ))/fact ! initialize the record of the best representation found - s = stdlib_dlamch( 'S' ) + s = stdlib${ii}$_dlamch( 'S' ) smlgrowth = one / s fail = real(n-1,KIND=dp)*mingap/(spdiam*eps) fail2 = real(n-1,KIND=dp)*mingap/(spdiam*sqrt(eps)) bestshift = lsigma ! while (ktry <= ktrymax) - ktry = 0 + ktry = 0_${ik}$ growthbound = maxgrowth1*spdiam 5 continue sawnan1 = .false. @@ -33204,14 +33205,14 @@ module stdlib_linalg_lapack_d ! 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 @@ -33444,13 +33445,13 @@ module stdlib_linalg_lapack_d zusedu = dou+1 endif ! the width of the part of z that is used - zusedw = zusedu - zusedl + 1 - call stdlib_dlaset( 'FULL', n, zusedw, zero, zero,z(1,zusedl), ldz ) - eps = stdlib_dlamch( 'PRECISION' ) + zusedw = zusedu - zusedl + 1_${ik}$ + call stdlib${ii}$_dlaset( 'FULL', n, zusedw, zero, zero,z(1_${ik}$,zusedl), ldz ) + eps = stdlib${ii}$_dlamch( '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 @@ -33464,54 +33465,54 @@ module stdlib_linalg_lapack_d ! 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 + im = wend - wbegin + 1_${ik}$ ! this is for a 1x1 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) @@ -33520,24 +33521,24 @@ module stdlib_linalg_lapack_d ! the eigenvalue approximations will be refined when necessary as ! high relative accuracy is required for the computation of the ! corresponding eigenvectors. - call stdlib_dcopy( im, w( wbegin ), 1,work( wbegin ), 1 ) + call stdlib${ii}$_dcopy( 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 + ndepth = 0_${ik}$ ! parity is either 1 or 0 - parity = 1 + 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 + 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 @@ -33563,37 +33564,37 @@ module stdlib_linalg_lapack_d 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 ! 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_dcopy( in, z( ibegin, j ), 1, d( ibegin ), 1 ) - call stdlib_dcopy( in-1, z( ibegin, j+1 ), 1, l( ibegin ),1 ) + call stdlib${ii}$_dcopy( in, z( ibegin, j ), 1_${ik}$, d( ibegin ), 1_${ik}$ ) + call stdlib${ii}$_dcopy( 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_dlaset( 'FULL', in, 2, zero, zero,z( ibegin, j), ldz ) + call stdlib${ii}$_dlaset( 'FULL', in, 2_${ik}$, zero, zero,z( ibegin, j), ldz ) end if ! compute dl and dll of current rrr do j = ibegin, iend-1 @@ -33601,7 +33602,7 @@ module stdlib_linalg_lapack_d 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 ) @@ -33609,29 +33610,29 @@ module stdlib_linalg_lapack_d ! 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_dlarrb( in, d( ibegin ),work(indlld+ibegin-1),p, q, rtol1, & + call stdlib${ii}$_dlarrb( 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_dlarrb. + ! wbegin-1+oldlst are correctly computed in stdlib${ii}$_dlarrb. ! 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 @@ -33648,7 +33649,7 @@ module stdlib_linalg_lapack_d ! 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 @@ -33659,25 +33660,25 @@ module stdlib_linalg_lapack_d 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. @@ -33688,7 +33689,7 @@ module stdlib_linalg_lapack_d ! 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 ) @@ -33699,13 +33700,13 @@ module stdlib_linalg_lapack_d ! 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_dlarrb( in, d(ibegin),work( indlld+ibegin-1 ),p,p,rqtol, & + offset = indexw( wbegin ) - 1_${ik}$ + call stdlib${ii}$_dlarrb( 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 @@ -33716,18 +33717,18 @@ module stdlib_linalg_lapack_d ! 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_dlarrf needs lwork = 2*n - call stdlib_dlarrf( in, d( ibegin ), l( ibegin ),work(indld+ibegin-1),& + ! stdlib${ii}$_dlarrf needs lwork = 2*n + call stdlib${ii}$_dlarrf( 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_dlarrf + if( iinfo==0_${ik}$ ) then + ! a new rrr for the cluster was found by stdlib${ii}$_dlarrf ! update shift and store it ssigma = sigma + tau z( iend, newftt+1 ) = ssigma @@ -33735,10 +33736,10 @@ module stdlib_linalg_lapack_d ! 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 @@ -33747,24 +33748,24 @@ module stdlib_linalg_lapack_d ! 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=dp)) * 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. @@ -33781,7 +33782,7 @@ module stdlib_linalg_lapack_d ! 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 ) @@ -33803,7 +33804,7 @@ module stdlib_linalg_lapack_d 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. @@ -33812,7 +33813,7 @@ module stdlib_linalg_lapack_d 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 @@ -33836,34 +33837,34 @@ module stdlib_linalg_lapack_d ! take the bisection as new iterate usedbs = .true. itmp1 = iwork( iindr+windex ) - offset = indexw( wbegin ) - 1 - call stdlib_dlarrb( in, d(ibegin),work(indlld+ibegin-1),indeig,& + offset = indexw( wbegin ) - 1_${ik}$ + call stdlib${ii}$_dlarrb( 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_dlar1v( in, 1, in, lambda, d( ibegin ),l( ibegin ), work(& + call stdlib${ii}$_dlar1v( 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 @@ -33983,25 +33984,25 @@ module stdlib_linalg_lapack_d 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_dlarrv + end subroutine stdlib${ii}$_dlarrv - pure subroutine stdlib_dlascl( type, kl, ku, cfrom, cto, m, n, a, lda, info ) + pure subroutine stdlib${ii}$_dlascl( type, kl, ku, cfrom, cto, m, n, a, lda, info ) !! DLASCL 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 @@ -34012,8 +34013,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: cfrom, cto ! Array Arguments real(dp), intent(inout) :: a(lda,*) @@ -34021,61 +34022,61 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: done - integer(ilp) :: i, itype, j, k1, k2, k3, k4 + integer(${ik}$) :: i, itype, j, k1, k2, k3, k4 real(dp) :: 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_disnan(cfrom) ) then - info = -4 - else if( stdlib_disnan(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}$_disnan(cfrom) ) then + info = -4_${ik}$ + else if( stdlib${ii}$_disnan(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. ldazero )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 @@ -34541,14 +34542,14 @@ module stdlib_linalg_lapack_d 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 @@ -34576,11 +34577,11 @@ module stdlib_linalg_lapack_d 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( dpsiabs( 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 @@ -34714,9 +34715,9 @@ module stdlib_linalg_lapack_d 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 ) ) @@ -34754,19 +34755,19 @@ module stdlib_linalg_lapack_d 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( dpsizero .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_dlasd4 + end subroutine stdlib${ii}$_dlasd4 - pure subroutine stdlib_dlasd7( icompq, nl, nr, sqre, k, d, z, zw, vf, vfw, vl,vlw, alpha, & + pure subroutine stdlib${ii}$_dlasd7( icompq, nl, nr, sqre, k, d, z, zw, vf, vfw, vl,vlw, alpha, & !! DLASD7 merges the two sets of singular values together into a single !! sorted set. Then it tries to deflate the size of the problem. There !! are two ways in which deflation can occur: when two or more singular @@ -34913,49 +34914,49 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(in) :: alpha, beta real(dp), 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(dp), intent(inout) :: d(*), vf(*), vl(*) real(dp), 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(dp) :: 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. @@ -35043,34 +35044,34 @@ module stdlib_linalg_lapack_d c = z( j ) ! find sqrt(a**2+b**2) without overflow or ! destructive underflow. - tau = stdlib_dlapy2( c, s ) + tau = stdlib${ii}$_dlapy2( 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_drot( 1, vf( jprev ), 1, vf( j ), 1, c, s ) - call stdlib_drot( 1, vl( jprev ), 1, vl( j ), 1, c, s ) - k2 = k2 - 1 + call stdlib${ii}$_drot( 1_${ik}$, vf( jprev ), 1_${ik}$, vf( j ), 1_${ik}$, c, s ) + call stdlib${ii}$_drot( 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 @@ -35080,7 +35081,7 @@ module stdlib_linalg_lapack_d 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 @@ -35094,51 +35095,51 @@ module stdlib_linalg_lapack_d 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_dcopy( n-k, dsigma( k+1 ), 1, d( k+1 ), 1 ) + call stdlib${ii}$_dcopy( n-k, dsigma( k+1 ), 1_${ik}$, d( k+1 ), 1_${ik}$ ) ! determine dsigma(1), dsigma(2), z(1), vf(1), vl(1), 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_dlapy2( z1, z( m ) ) - if( z( 1 )<=tol ) then + z( 1_${ik}$ ) = stdlib${ii}$_dlapy2( 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_drot( 1, vf( m ), 1, vf( 1 ), 1, c, s ) - call stdlib_drot( 1, vl( m ), 1, vl( 1 ), 1, c, s ) + call stdlib${ii}$_drot( 1_${ik}$, vf( m ), 1_${ik}$, vf( 1_${ik}$ ), 1_${ik}$, c, s ) + call stdlib${ii}$_drot( 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_dcopy( k-1, zw( 2 ), 1, z( 2 ), 1 ) - call stdlib_dcopy( n-1, vfw( 2 ), 1, vf( 2 ), 1 ) - call stdlib_dcopy( n-1, vlw( 2 ), 1, vl( 2 ), 1 ) + call stdlib${ii}$_dcopy( k-1, zw( 2_${ik}$ ), 1_${ik}$, z( 2_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_dcopy( n-1, vfw( 2_${ik}$ ), 1_${ik}$, vf( 2_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_dcopy( n-1, vlw( 2_${ik}$ ), 1_${ik}$, vl( 2_${ik}$ ), 1_${ik}$ ) return - end subroutine stdlib_dlasd7 + end subroutine stdlib${ii}$_dlasd7 - pure subroutine stdlib_dlasd8( icompq, k, d, z, vf, vl, difl, difr, lddifr,dsigma, work, & + pure subroutine stdlib${ii}$_dlasd8( icompq, k, d, z, vf, vl, difl, difr, lddifr,dsigma, work, & !! DLASD8 finds the square roots of the roots of the secular equation, !! as defined by the values in DSIGMA and Z. It makes the appropriate !! calls to DLASD4, and stores, for each element in D, the distance @@ -35151,39 +35152,39 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(out) :: d(*), difl(*), difr(lddifr,*), work(*) real(dp), 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(dp) :: 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 + 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. 30 continue @@ -35342,16 +35342,16 @@ module stdlib_linalg_lapack_d 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_dlasq5( i0, n0, z, pp, tau, sigma, dmin, dmin1, dmin2, dn,dn1, dn2, ieee, & + call stdlib${ii}$_dlasq5( 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 )

0 )info = ierr - call stdlib_dgesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) + call stdlib${ii}$_dgetc2( zdim, z, ldz, ipiv, jpiv, ierr ) + if( ierr>0_${ik}$ )info = ierr + call stdlib${ii}$_dgesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_dscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_dscal( m, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_dscal( m, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do scale = scale*scaloc end if ! unpack solution vector(s) - c( is, js ) = rhs( 1 ) - c( is, jsp1 ) = rhs( 2 ) - f( is, js ) = rhs( 3 ) - f( is, jsp1 ) = rhs( 4 ) + c( is, js ) = rhs( 1_${ik}$ ) + c( is, jsp1 ) = rhs( 2_${ik}$ ) + f( is, js ) = rhs( 3_${ik}$ ) + f( is, jsp1 ) = rhs( 4_${ik}$ ) ! substitute r(i, j) and l(i, j) into remaining ! equation. if( j>p+2 ) then - call stdlib_daxpy( js-1, rhs( 1 ), b( 1, js ), 1,f( is, 1 ), ldf ) + call stdlib${ii}$_daxpy( js-1, rhs( 1_${ik}$ ), b( 1_${ik}$, js ), 1_${ik}$,f( is, 1_${ik}$ ), ldf ) - call stdlib_daxpy( js-1, rhs( 2 ), b( 1, jsp1 ), 1,f( is, 1 ), ldf ) + call stdlib${ii}$_daxpy( js-1, rhs( 2_${ik}$ ), b( 1_${ik}$, jsp1 ), 1_${ik}$,f( is, 1_${ik}$ ), ldf ) - call stdlib_daxpy( js-1, rhs( 3 ), e( 1, js ), 1,f( is, 1 ), ldf ) + call stdlib${ii}$_daxpy( js-1, rhs( 3_${ik}$ ), e( 1_${ik}$, js ), 1_${ik}$,f( is, 1_${ik}$ ), ldf ) - call stdlib_daxpy( js-1, rhs( 4 ), e( 1, jsp1 ), 1,f( is, 1 ), ldf ) + call stdlib${ii}$_daxpy( js-1, rhs( 4_${ik}$ ), e( 1_${ik}$, jsp1 ), 1_${ik}$,f( is, 1_${ik}$ ), ldf ) end if if( i

0 )info = ierr - call stdlib_dgesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) + call stdlib${ii}$_dgetc2( zdim, z, ldz, ipiv, jpiv, ierr ) + if( ierr>0_${ik}$ )info = ierr + call stdlib${ii}$_dgesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_dscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_dscal( m, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_dscal( m, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do scale = scale*scaloc end if ! unpack solution vector(s) - c( is, js ) = rhs( 1 ) - c( isp1, js ) = rhs( 2 ) - f( is, js ) = rhs( 3 ) - f( isp1, js ) = rhs( 4 ) + c( is, js ) = rhs( 1_${ik}$ ) + c( isp1, js ) = rhs( 2_${ik}$ ) + f( is, js ) = rhs( 3_${ik}$ ) + f( isp1, js ) = rhs( 4_${ik}$ ) ! substitute r(i, j) and l(i, j) into remaining ! equation. if( j>p+2 ) then - call stdlib_dger( mb, js-1, one, rhs( 1 ), 1, b( 1, js ),1, f( is, 1 ), & + call stdlib${ii}$_dger( mb, js-1, one, rhs( 1_${ik}$ ), 1_${ik}$, b( 1_${ik}$, js ),1_${ik}$, f( is, 1_${ik}$ ), & ldf ) - call stdlib_dger( mb, js-1, one, rhs( 3 ), 1, e( 1, js ),1, f( is, 1 ), & + call stdlib${ii}$_dger( mb, js-1, one, rhs( 3_${ik}$ ), 1_${ik}$, e( 1_${ik}$, js ),1_${ik}$, f( is, 1_${ik}$ ), & ldf ) end if if( i

0 )info = ierr - call stdlib_dgesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) + call stdlib${ii}$_dgetc2( zdim, z, ldz, ipiv, jpiv, ierr ) + if( ierr>0_${ik}$ )info = ierr + call stdlib${ii}$_dgesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_dscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_dscal( m, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_dscal( m, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do scale = scale*scaloc end if ! unpack solution vector(s) - k = 1 - ii = mb*nb + 1 + k = 1_${ik}$ + ii = mb*nb + 1_${ik}$ do jj = 0, nb - 1 - call stdlib_dcopy( mb, rhs( k ), 1, c( is, js+jj ), 1 ) - call stdlib_dcopy( mb, rhs( ii ), 1, f( is, js+jj ), 1 ) + call stdlib${ii}$_dcopy( mb, rhs( k ), 1_${ik}$, c( is, js+jj ), 1_${ik}$ ) + call stdlib${ii}$_dcopy( mb, rhs( ii ), 1_${ik}$, f( is, js+jj ), 1_${ik}$ ) k = k + mb ii = ii + mb end do ! substitute r(i, j) and l(i, j) into remaining ! equation. if( j>p+2 ) then - call stdlib_dgemm( 'N', 'T', mb, js-1, nb, one,c( is, js ), ldc, b( 1, & - js ), ldb, one,f( is, 1 ), ldf ) - call stdlib_dgemm( 'N', 'T', mb, js-1, nb, one,f( is, js ), ldf, e( 1, & - js ), lde, one,f( is, 1 ), ldf ) + call stdlib${ii}$_dgemm( 'N', 'T', mb, js-1, nb, one,c( is, js ), ldc, b( 1_${ik}$, & + js ), ldb, one,f( is, 1_${ik}$ ), ldf ) + call stdlib${ii}$_dgemm( 'N', 'T', mb, js-1, nb, one,f( is, js ), ldf, e( 1_${ik}$, & + js ), lde, one,f( is, 1_${ik}$ ), ldf ) end if if( i

4 ) ) then - info = -2 - end if - end if - if( info==0 ) then - if( m<=0 ) then - info = -3 - else if( n<=0 ) then - info = -4 - else if( lda4_${ik}$ ) ) then + info = -2_${ik}$ + end if + end if + if( info==0_${ik}$ ) then + if( m<=0_${ik}$ ) then + info = -3_${ik}$ + else if( n<=0_${ik}$ ) then + info = -4_${ik}$ + else if( lda=3 ) then - ifunc = ijob - 2 - call stdlib_dlaset( 'F', m, n, zero, zero, c, ldc ) - call stdlib_dlaset( 'F', m, n, zero, zero, f, ldf ) - else if( ijob>=1 ) then - isolve = 2 + if( ijob>=3_${ik}$ ) then + ifunc = ijob - 2_${ik}$ + call stdlib${ii}$_dlaset( 'F', m, n, zero, zero, c, ldc ) + call stdlib${ii}$_dlaset( 'F', m, n, zero, zero, f, ldf ) + else if( ijob>=1_${ik}$ ) then + isolve = 2_${ik}$ end if end if - if( ( mb<=1 .and. nb<=1 ) .or. ( mb>=m .and. nb>=n ) )then + if( ( mb<=1_${ik}$ .and. nb<=1_${ik}$ ) .or. ( mb>=m .and. nb>=n ) )then loop_30: do iround = 1, isolve ! use unblocked level 2 solver dscale = zero dsum = one - pq = 0 - call stdlib_dtgsy2( trans, ifunc, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f,& + pq = 0_${ik}$ + call stdlib${ii}$_dtgsy2( trans, ifunc, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f,& ldf, scale, dsum, dscale,iwork, pq, info ) if( dscale/=zero ) then - if( ijob==1 .or. ijob==3 ) then - dif = sqrt( real( 2*m*n,KIND=dp) ) / ( dscale*sqrt( dsum ) ) + if( ijob==1_${ik}$ .or. ijob==3_${ik}$ ) then + dif = sqrt( real( 2_${ik}$*m*n,KIND=dp) ) / ( dscale*sqrt( dsum ) ) else dif = sqrt( real( pq,KIND=dp) ) / ( dscale*sqrt( dsum ) ) end if end if - if( isolve==2 .and. iround==1 ) then + if( isolve==2_${ik}$ .and. iround==1_${ik}$ ) then if( notran ) then ifunc = ijob end if scale2 = scale - call stdlib_dlacpy( 'F', m, n, c, ldc, work, m ) - call stdlib_dlacpy( 'F', m, n, f, ldf, work( m*n+1 ), m ) - call stdlib_dlaset( 'F', m, n, zero, zero, c, ldc ) - call stdlib_dlaset( 'F', m, n, zero, zero, f, ldf ) - else if( isolve==2 .and. iround==2 ) then - call stdlib_dlacpy( 'F', m, n, work, m, c, ldc ) - call stdlib_dlacpy( 'F', m, n, work( m*n+1 ), m, f, ldf ) + call stdlib${ii}$_dlacpy( 'F', m, n, c, ldc, work, m ) + call stdlib${ii}$_dlacpy( 'F', m, n, f, ldf, work( m*n+1 ), m ) + call stdlib${ii}$_dlaset( 'F', m, n, zero, zero, c, ldc ) + call stdlib${ii}$_dlaset( 'F', m, n, zero, zero, f, ldf ) + else if( isolve==2_${ik}$ .and. iround==2_${ik}$ ) then + call stdlib${ii}$_dlacpy( 'F', m, n, work, m, c, ldc ) + call stdlib${ii}$_dlacpy( 'F', m, n, work( m*n+1 ), m, f, ldf ) scale = scale2 end if end do loop_30 return end if ! determine block structure of a - p = 0 - i = 1 + p = 0_${ik}$ + i = 1_${ik}$ 40 continue if( i>m )go to 50 - p = p + 1 + p = p + 1_${ik}$ iwork( p ) = i i = i + mb if( i>=m )go to 50 - if( a( i, i-1 )/=zero )i = i + 1 + if( a( i, i-1 )/=zero )i = i + 1_${ik}$ go to 40 50 continue - iwork( p+1 ) = m + 1 - if( iwork( p )==iwork( p+1 ) )p = p - 1 + iwork( p+1 ) = m + 1_${ik}$ + if( iwork( p )==iwork( p+1 ) )p = p - 1_${ik}$ ! determine block structure of b - q = p + 1 - j = 1 + q = p + 1_${ik}$ + j = 1_${ik}$ 60 continue if( j>n )go to 70 - q = q + 1 + q = q + 1_${ik}$ iwork( q ) = j j = j + nb if( j>=n )go to 70 - if( b( j, j-1 )/=zero )j = j + 1 + if( b( j, j-1 )/=zero )j = j + 1_${ik}$ go to 60 70 continue - iwork( q+1 ) = n + 1 - if( iwork( q )==iwork( q+1 ) )q = q - 1 + iwork( q+1 ) = n + 1_${ik}$ + if( iwork( q )==iwork( q+1 ) )q = q - 1_${ik}$ if( notran ) then loop_150: do iround = 1, isolve ! solve (i, j)-subsystem @@ -42747,76 +42747,76 @@ module stdlib_linalg_lapack_d ! for i = p, p - 1,..., 1; j = 1, 2,..., q dscale = zero dsum = one - pq = 0 + pq = 0_${ik}$ scale = one loop_130: do j = p + 2, q js = iwork( j ) - je = iwork( j+1 ) - 1 - nb = je - js + 1 + je = iwork( j+1 ) - 1_${ik}$ + nb = je - js + 1_${ik}$ loop_120: do i = p, 1, -1 is = iwork( i ) - ie = iwork( i+1 ) - 1 - mb = ie - is + 1 - ppqq = 0 - call stdlib_dtgsy2( trans, ifunc, mb, nb, a( is, is ), lda,b( js, js ), & + ie = iwork( i+1 ) - 1_${ik}$ + mb = ie - is + 1_${ik}$ + ppqq = 0_${ik}$ + call stdlib${ii}$_dtgsy2( trans, ifunc, mb, nb, a( is, is ), lda,b( js, js ), & ldb, c( is, js ), ldc,d( is, is ), ldd, e( js, js ), lde,f( is, js ), ldf, & scaloc, dsum, dscale,iwork( q+2 ), ppqq, linfo ) - if( linfo>0 )info = linfo + if( linfo>0_${ik}$ )info = linfo pq = pq + ppqq if( scaloc/=one ) then do k = 1, js - 1 - call stdlib_dscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_dscal( m, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_dscal( m, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do do k = js, je - call stdlib_dscal( is-1, scaloc, c( 1, k ), 1 ) - call stdlib_dscal( is-1, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_dscal( is-1, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_dscal( is-1, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do do k = js, je - call stdlib_dscal( m-ie, scaloc, c( ie+1, k ), 1 ) - call stdlib_dscal( m-ie, scaloc, f( ie+1, k ), 1 ) + call stdlib${ii}$_dscal( m-ie, scaloc, c( ie+1, k ), 1_${ik}$ ) + call stdlib${ii}$_dscal( m-ie, scaloc, f( ie+1, k ), 1_${ik}$ ) end do do k = je + 1, n - call stdlib_dscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_dscal( m, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_dscal( m, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do scale = scale*scaloc end if ! substitute r(i, j) and l(i, j) into remaining ! equation. - if( i>1 ) then - call stdlib_dgemm( 'N', 'N', is-1, nb, mb, -one,a( 1, is ), lda, c( is, & - js ), ldc, one,c( 1, js ), ldc ) - call stdlib_dgemm( 'N', 'N', is-1, nb, mb, -one,d( 1, is ), ldd, c( is, & - js ), ldc, one,f( 1, js ), ldf ) + if( i>1_${ik}$ ) then + call stdlib${ii}$_dgemm( 'N', 'N', is-1, nb, mb, -one,a( 1_${ik}$, is ), lda, c( is, & + js ), ldc, one,c( 1_${ik}$, js ), ldc ) + call stdlib${ii}$_dgemm( 'N', 'N', is-1, nb, mb, -one,d( 1_${ik}$, is ), ldd, c( is, & + js ), ldc, one,f( 1_${ik}$, js ), ldf ) end if if( j0 )info = linfo + if( linfo>0_${ik}$ )info = linfo if( scaloc/=one ) then do k = 1, js - 1 - call stdlib_dscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_dscal( m, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_dscal( m, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do do k = js, je - call stdlib_dscal( is-1, scaloc, c( 1, k ), 1 ) - call stdlib_dscal( is-1, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_dscal( is-1, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_dscal( is-1, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do do k = js, je - call stdlib_dscal( m-ie, scaloc, c( ie+1, k ), 1 ) - call stdlib_dscal( m-ie, scaloc, f( ie+1, k ), 1 ) + call stdlib${ii}$_dscal( m-ie, scaloc, c( ie+1, k ), 1_${ik}$ ) + call stdlib${ii}$_dscal( m-ie, scaloc, f( ie+1, k ), 1_${ik}$ ) end do do k = je + 1, n - call stdlib_dscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_dscal( m, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_dscal( m, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do scale = scale*scaloc end if ! substitute r(i, j) and l(i, j) into remaining equation. if( j>p+2 ) then - call stdlib_dgemm( 'N', 'T', mb, js-1, nb, one, c( is, js ),ldc, b( 1, js )& - , ldb, one, f( is, 1 ),ldf ) - call stdlib_dgemm( 'N', 'T', mb, js-1, nb, one, f( is, js ),ldf, e( 1, js )& - , lde, one, f( is, 1 ),ldf ) + call stdlib${ii}$_dgemm( 'N', 'T', mb, js-1, nb, one, c( is, js ),ldc, b( 1_${ik}$, js )& + , ldb, one, f( is, 1_${ik}$ ),ldf ) + call stdlib${ii}$_dgemm( 'N', 'T', mb, js-1, nb, one, f( is, js ),ldf, e( 1_${ik}$, js )& + , lde, one, f( is, 1_${ik}$ ),ldf ) end if if( i

0. if( anorm>zero ) then ! estimate the norm of the inverse of a. ainvnm = zero normin = 'N' if( onenrm ) then - kase1 = 1 + kase1 = 1_${ik}$ else - kase1 = 2 + kase1 = 2_${ik}$ end if - kase = 0 + kase = 0_${ik}$ 10 continue - call stdlib_dlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_dlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) + if( kase/=0_${ik}$ ) then if( kase==kase1 ) then ! multiply by inv(a). - call stdlib_dlatps( uplo, 'NO TRANSPOSE', diag, normin, n, ap,work, scale, & - work( 2*n+1 ), info ) + call stdlib${ii}$_dlatps( uplo, 'NO TRANSPOSE', diag, normin, n, ap,work, scale, & + work( 2_${ik}$*n+1 ), info ) else ! multiply by inv(a**t). - call stdlib_dlatps( uplo, 'TRANSPOSE', diag, normin, n, ap,work, scale, work( & - 2*n+1 ), info ) + call stdlib${ii}$_dlatps( uplo, 'TRANSPOSE', diag, normin, n, ap,work, scale, work( & + 2_${ik}$*n+1 ), info ) end if normin = 'Y' ! multiply by 1/scale if doing so will not cause overflow. if( scale/=one ) then - ix = stdlib_idamax( n, work, 1 ) + ix = stdlib${ii}$_idamax( n, work, 1_${ik}$ ) xnorm = abs( work( ix ) ) if( scalemin(m,n) ) then - info = -3 - else if( ldamin(m,n) ) then + info = -3_${ik}$ + else if( ldak ) then - info = -6 - else if( mb<1 .or. (mb>k .and. k>0) ) then - info = -7 + info = -2_${ik}$ + else if( m<0_${ik}$ ) then + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( k<0_${ik}$ ) then + info = -5_${ik}$ + else if( l<0_${ik}$ .or. l>k ) then + info = -6_${ik}$ + else if( mb<1_${ik}$ .or. (mb>k .and. k>0_${ik}$) ) then + info = -7_${ik}$ else if( ldv=l ) then - lb = 0 + lb = 0_${ik}$ else - lb = 0 + lb = 0_${ik}$ end if - call stdlib_dtprfb( 'L', 'T', 'F', 'R', nb, n, ib, lb,v( i, 1 ), ldv, t( 1, i ), & - ldt,a( i, 1 ), lda, b, ldb, work, ib ) + call stdlib${ii}$_dtprfb( 'L', 'T', 'F', 'R', nb, n, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), & + ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib ) end do else if( right .and. tran ) then do i = 1, k, mb ib = min( mb, k-i+1 ) nb = min( n-l+i+ib-1, n ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = nb-n+l-i+1 end if - call stdlib_dtprfb( 'R', 'N', 'F', 'R', m, nb, ib, lb,v( i, 1 ), ldv, t( 1, i ), & - ldt,a( 1, i ), lda, b, ldb, work, m ) + call stdlib${ii}$_dtprfb( 'R', 'N', 'F', 'R', m, nb, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), & + ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m ) end do else if( left .and. tran ) then kf = ((k-1)/mb)*mb+1 @@ -43167,12 +43167,12 @@ module stdlib_linalg_lapack_d ib = min( mb, k-i+1 ) nb = min( m-l+i+ib-1, m ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else - lb = 0 + lb = 0_${ik}$ end if - call stdlib_dtprfb( 'L', 'N', 'F', 'R', nb, n, ib, lb,v( i, 1 ), ldv, t( 1, i ), & - ldt,a( i, 1 ), lda, b, ldb, work, ib ) + call stdlib${ii}$_dtprfb( 'L', 'N', 'F', 'R', nb, n, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), & + ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib ) end do else if( right .and. notran ) then kf = ((k-1)/mb)*mb+1 @@ -43180,19 +43180,19 @@ module stdlib_linalg_lapack_d ib = min( mb, k-i+1 ) nb = min( n-l+i+ib-1, n ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = nb-n+l-i+1 end if - call stdlib_dtprfb( 'R', 'T', 'F', 'R', m, nb, ib, lb,v( i, 1 ), ldv, t( 1, i ), & - ldt,a( 1, i ), lda, b, ldb, work, m ) + call stdlib${ii}$_dtprfb( 'R', 'T', 'F', 'R', m, nb, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), & + ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m ) end do end if return - end subroutine stdlib_dtpmlqt + end subroutine stdlib${ii}$_dtpmlqt - pure subroutine stdlib_dtpmqrt( side, trans, m, n, k, l, nb, v, ldv, t, ldt,a, lda, b, ldb, & + pure subroutine stdlib${ii}$_dtpmqrt( side, trans, m, n, k, l, nb, v, ldv, t, ldt,a, lda, b, ldb, & !! DTPMQRT applies a real orthogonal matrix Q obtained from a !! "triangular-pentagonal" real block reflector H to a general !! real matrix C, which consists of two blocks A and B. @@ -43202,8 +43202,8 @@ module stdlib_linalg_lapack_d ! -- 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, lda, ldb, m, n, l, nb, ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k, ldv, lda, ldb, m, n, l, nb, ldt ! Array Arguments real(dp), intent(in) :: v(ldv,*), t(ldt,*) real(dp), intent(inout) :: a(lda,*), b(ldb,*) @@ -43211,48 +43211,48 @@ module stdlib_linalg_lapack_d ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran - integer(ilp) :: i, ib, mb, lb, kf, ldaq, ldvq + integer(${ik}$) :: i, ib, mb, lb, kf, ldaq, ldvq ! 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 - ldvq = max( 1, m ) - ldaq = max( 1, k ) + ldvq = max( 1_${ik}$, m ) + ldaq = max( 1_${ik}$, k ) else if ( right ) then - ldvq = max( 1, n ) - ldaq = max( 1, m ) + ldvq = max( 1_${ik}$, n ) + ldaq = max( 1_${ik}$, m ) 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 ) then - info = -5 - else if( l<0 .or. l>k ) then - info = -6 - else if( nb<1 .or. (nb>k .and. k>0) ) then - info = -7 + info = -2_${ik}$ + else if( m<0_${ik}$ ) then + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( k<0_${ik}$ ) then + info = -5_${ik}$ + else if( l<0_${ik}$ .or. l>k ) then + info = -6_${ik}$ + else if( nb<1_${ik}$ .or. (nb>k .and. k>0_${ik}$) ) then + info = -7_${ik}$ else if( ldv=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-m+l-i+1 end if - call stdlib_dtprfb( 'L', 'T', 'F', 'C', mb, n, ib, lb,v( 1, i ), ldv, t( 1, i ), & - ldt,a( i, 1 ), lda, b, ldb, work, ib ) + call stdlib${ii}$_dtprfb( 'L', 'T', 'F', 'C', mb, n, ib, lb,v( 1_${ik}$, i ), ldv, t( 1_${ik}$, i ), & + ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib ) end do else if( right .and. notran ) then do i = 1, k, nb ib = min( nb, k-i+1 ) mb = min( n-l+i+ib-1, n ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-n+l-i+1 end if - call stdlib_dtprfb( 'R', 'N', 'F', 'C', m, mb, ib, lb,v( 1, i ), ldv, t( 1, i ), & - ldt,a( 1, i ), lda, b, ldb, work, m ) + call stdlib${ii}$_dtprfb( 'R', 'N', 'F', 'C', m, mb, ib, lb,v( 1_${ik}$, i ), ldv, t( 1_${ik}$, i ), & + ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m ) end do else if( left .and. notran ) then kf = ((k-1)/nb)*nb+1 @@ -43287,12 +43287,12 @@ module stdlib_linalg_lapack_d ib = min( nb, k-i+1 ) mb = min( m-l+i+ib-1, m ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-m+l-i+1 end if - call stdlib_dtprfb( 'L', 'N', 'F', 'C', mb, n, ib, lb,v( 1, i ), ldv, t( 1, i ), & - ldt,a( i, 1 ), lda, b, ldb, work, ib ) + call stdlib${ii}$_dtprfb( 'L', 'N', 'F', 'C', mb, n, ib, lb,v( 1_${ik}$, i ), ldv, t( 1_${ik}$, i ), & + ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib ) end do else if( right .and. tran ) then kf = ((k-1)/nb)*nb+1 @@ -43300,19 +43300,19 @@ module stdlib_linalg_lapack_d ib = min( nb, k-i+1 ) mb = min( n-l+i+ib-1, n ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-n+l-i+1 end if - call stdlib_dtprfb( 'R', 'T', 'F', 'C', m, mb, ib, lb,v( 1, i ), ldv, t( 1, i ), & - ldt,a( 1, i ), lda, b, ldb, work, m ) + call stdlib${ii}$_dtprfb( 'R', 'T', 'F', 'C', m, mb, ib, lb,v( 1_${ik}$, i ), ldv, t( 1_${ik}$, i ), & + ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m ) end do end if return - end subroutine stdlib_dtpmqrt + end subroutine stdlib${ii}$_dtpmqrt - pure subroutine stdlib_dtpqrt2( m, n, l, a, lda, b, ldb, t, ldt, info ) + pure subroutine stdlib${ii}$_dtpqrt2( m, n, l, a, lda, b, ldb, t, ldt, info ) !! DTPQRT2 computes a QR factorization of a real "triangular-pentagonal" !! matrix C, which is composed of a triangular block A and pentagonal block B, !! using the compact WY representation for Q. @@ -43320,36 +43320,36 @@ module stdlib_linalg_lapack_d ! -- 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, ldb, ldt, n, m, l + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l ! Array Arguments real(dp), intent(inout) :: a(lda,*), b(ldb,*) real(dp), intent(out) :: t(ldt,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, p, mp, np + integer(${ik}$) :: i, j, p, mp, np real(dp) :: alpha ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( l<0 .or. l>min(m,n) ) then - info = -3 - else if( ldamin(m,n) ) then + info = -3_${ik}$ + else if( lda 0. if( anorm>zero ) then ! estimate the norm of the inverse of a. ainvnm = zero normin = 'N' if( onenrm ) then - kase1 = 1 + kase1 = 1_${ik}$ else - kase1 = 2 + kase1 = 2_${ik}$ end if - kase = 0 + kase = 0_${ik}$ 10 continue - call stdlib_dlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_dlacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) + if( kase/=0_${ik}$ ) then if( kase==kase1 ) then ! multiply by inv(a). - call stdlib_dlatrs( uplo, 'NO TRANSPOSE', diag, normin, n, a,lda, work, scale,& - work( 2*n+1 ), info ) + call stdlib${ii}$_dlatrs( uplo, 'NO TRANSPOSE', diag, normin, n, a,lda, work, scale,& + work( 2_${ik}$*n+1 ), info ) else ! multiply by inv(a**t). - call stdlib_dlatrs( uplo, 'TRANSPOSE', diag, normin, n, a, lda,work, scale, & - work( 2*n+1 ), info ) + call stdlib${ii}$_dlatrs( uplo, 'TRANSPOSE', diag, normin, n, a, lda,work, scale, & + work( 2_${ik}$*n+1 ), info ) end if normin = 'Y' ! multiply by 1/scale if doing so will not cause overflow. if( scale/=one ) then - ix = stdlib_idamax( n, work, 1 ) + ix = stdlib${ii}$_idamax( n, work, 1_${ik}$ ) xnorm = abs( work( ix ) ) if( scale1 .and. nb1_${ik}$ .and. nb1 ) then + call stdlib${ii}$_dlatrz( ib, n-i+1, n-m, a( i, i ), lda, tau( i ),work ) + if( i>1_${ik}$ ) then ! form the triangular factor of the block reflector ! h = h(i+ib-1) . . . h(i+1) h(i) - call stdlib_dlarzt( 'BACKWARD', 'ROWWISE', n-m, ib, a( i, m1 ),lda, tau( i ), & + call stdlib${ii}$_dlarzt( 'BACKWARD', 'ROWWISE', n-m, ib, a( i, m1 ),lda, tau( i ), & work, ldwork ) ! apply h to a(1:i-1,i:n) from the right - call stdlib_dlarzb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', i-1, n-i+1,& - ib, n-m, a( i, m1 ),lda, work, ldwork, a( 1, i ), lda,work( ib+1 ), ldwork ) + call stdlib${ii}$_dlarzb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', i-1, n-i+1,& + ib, n-m, a( i, m1 ),lda, work, ldwork, a( 1_${ik}$, i ), lda,work( ib+1 ), ldwork ) end if end do - mu = i + nb - 1 + mu = i + nb - 1_${ik}$ else mu = m end if ! use unblocked code to factor the last or only block - if( mu>0 )call stdlib_dlatrz( mu, n, n-m, a, lda, tau, work ) - work( 1 ) = lwkopt + if( mu>0_${ik}$ )call stdlib${ii}$_dlatrz( mu, n, n-m, a, lda, tau, work ) + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_dtzrzf + end subroutine stdlib${ii}$_dtzrzf - pure subroutine stdlib_dgbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) + pure subroutine stdlib${ii}$_dgbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) !! DGBSV computes the solution to a real system of linear equations !! A * X = B, where A is a band matrix of order N with KL subdiagonals !! and KU superdiagonals, and X and B are N-by-NRHS matrices. @@ -43633,46 +43633,46 @@ module stdlib_linalg_lapack_d ! -- 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, ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl, ku, ldab, ldb, n, nrhs ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) real(dp), intent(inout) :: ab(ldab,*), b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 - if( n<0 ) then - info = -1 - else if( kl<0 ) then - info = -2 - else if( ku<0 ) then - info = -3 - else if( nrhs<0 ) then - info = -4 - else if( ldab<2*kl+ku+1 ) then - info = -6 - else if( ldb0 ) then + info = -13_${ik}$ + else if( n>0_${ik}$ ) then rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) else rowcnd = one end if end if - if( colequ .and. info==0 ) then + if( colequ .and. info==0_${ik}$ ) then rcmin = bignum rcmax = zero do j = 1, n @@ -43763,32 +43763,32 @@ module stdlib_linalg_lapack_d rcmax = max( rcmax, c( j ) ) end do if( rcmin<=zero ) then - info = -14 - else if( n>0 ) then + info = -14_${ik}$ + else if( n>0_${ik}$ ) then colcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) else colcnd = one end if end if - if( info==0 ) then - if( ldb0 ) then + if( info>0_${ik}$ ) then ! compute the reciprocal pivot growth factor of the ! leading rank-deficient info columns of a. anorm = zero @@ -43829,14 +43829,14 @@ module stdlib_linalg_lapack_d anorm = max( anorm, abs( ab( i, j ) ) ) end do end do - rpvgrw = stdlib_dlantb( 'M', 'U', 'N', info, min( info-1, kl+ku ),afb( max( 1, & - kl+ku+2-info ), 1 ), ldafb,work ) + rpvgrw = stdlib${ii}$_dlantb( 'M', 'U', 'N', info, min( info-1, kl+ku ),afb( max( 1_${ik}$, & + kl+ku+2-info ), 1_${ik}$ ), ldafb,work ) if( rpvgrw==zero ) then rpvgrw = one else rpvgrw = anorm / rpvgrw end if - work( 1 ) = rpvgrw + work( 1_${ik}$ ) = rpvgrw rcond = zero return end if @@ -43848,22 +43848,22 @@ module stdlib_linalg_lapack_d else norm = 'I' end if - anorm = stdlib_dlangb( norm, n, kl, ku, ab, ldab, work ) - rpvgrw = stdlib_dlantb( 'M', 'U', 'N', n, kl+ku, afb, ldafb, work ) + anorm = stdlib${ii}$_dlangb( norm, n, kl, ku, ab, ldab, work ) + rpvgrw = stdlib${ii}$_dlantb( 'M', 'U', 'N', n, kl+ku, afb, ldafb, work ) if( rpvgrw==zero ) then rpvgrw = one else - rpvgrw = stdlib_dlangb( 'M', n, kl, ku, ab, ldab, work ) / rpvgrw + rpvgrw = stdlib${ii}$_dlangb( 'M', n, kl, ku, ab, ldab, work ) / rpvgrw end if ! compute the reciprocal of the condition number of a. - call stdlib_dgbcon( norm, n, kl, ku, afb, ldafb, ipiv, anorm, rcond,work, iwork, info ) + call stdlib${ii}$_dgbcon( norm, n, kl, ku, afb, ldafb, ipiv, anorm, rcond,work, iwork, info ) ! compute the solution matrix x. - call stdlib_dlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_dgbtrs( trans, n, kl, ku, nrhs, afb, ldafb, ipiv, x, ldx,info ) + call stdlib${ii}$_dlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_dgbtrs( trans, n, kl, ku, nrhs, afb, ldafb, ipiv, x, ldx,info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_dgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv,b, ldb, x, ldx, & + call stdlib${ii}$_dgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv,b, ldb, x, ldx, & ferr, berr, work, iwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -43889,13 +43889,13 @@ module stdlib_linalg_lapack_d end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond=g .or. max( f, c, ca )>=sfmax2 .or.min( r, g, ra )<=sfmin2 )go to 170 - if( stdlib_disnan( c+f+ca+r+g+ra ) ) then + if( stdlib${ii}$_disnan( c+f+ca+r+g+ra ) ) then ! exit if nan to avoid infinite loop - info = -3 - call stdlib_xerbla( 'DGEBAL', -info ) + info = -3_${ik}$ + call stdlib${ii}$_xerbla( 'DGEBAL', -info ) return end if f = f*sclfac @@ -44052,18 +44052,18 @@ module stdlib_linalg_lapack_d g = one / f scale( i ) = scale( i )*f noconv = .true. - call stdlib_dscal( n-k+1, g, a( i, k ), lda ) - call stdlib_dscal( l, f, a( 1, i ), 1 ) + call stdlib${ii}$_dscal( n-k+1, g, a( i, k ), lda ) + call stdlib${ii}$_dscal( l, f, a( 1_${ik}$, i ), 1_${ik}$ ) end do loop_200 if( noconv )go to 140 210 continue ilo = k ihi = l return - end subroutine stdlib_dgebal + end subroutine stdlib${ii}$_dgebal - pure subroutine stdlib_dgebd2( m, n, a, lda, d, e, tauq, taup, work, info ) + pure subroutine stdlib${ii}$_dgebd2( m, n, a, lda, d, e, tauq, taup, work, info ) !! DGEBD2 reduces a real general m by n matrix A to upper or lower !! bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. !! If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. @@ -44071,52 +44071,52 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: d(*), e(*), taup(*), tauq(*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i ! 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=n ) then ! reduce to upper bidiagonal form do i = 1, n ! generate elementary reflector h(i) to annihilate a(i+1:m,i) - call stdlib_dlarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,tauq( i ) ) + call stdlib${ii}$_dlarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,tauq( i ) ) d( i ) = a( i, i ) a( i, i ) = one ! apply h(i) to a(i:m,i+1:n) from the left - if( imax( 1, n ) ) then - info = -2 + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -1_${ik}$ + else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then + info = -2_${ik}$ else if( ihin ) then - info = -3 - else if( lda1 .and. nb1_${ik}$ .and. nb1 .and. nb1_${ik}$ .and. nb1 ) 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_dlarft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1, n-k+i ), & + call stdlib${ii}$_dlarft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1_${ik}$, n-k+i ), & lda, tau( i ), work, ldwork ) ! apply h**t to a(1:m-k+i+ib-1,1:n-k+i-1) from the left - call stdlib_dlarfb( 'LEFT', 'TRANSPOSE', 'BACKWARD','COLUMNWISE', m-k+i+ib-1, & - n-k+i-1, ib,a( 1, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork ) + call stdlib${ii}$_dlarfb( 'LEFT', 'TRANSPOSE', 'BACKWARD','COLUMNWISE', m-k+i+ib-1, & + n-k+i-1, ib,a( 1_${ik}$, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork ) end if end do - mu = m - k + i + nb - 1 - nu = n - k + i + nb - 1 + mu = m - k + i + nb - 1_${ik}$ + nu = n - k + i + nb - 1_${ik}$ else mu = m nu = n end if ! use unblocked code to factor the last or only block - if( mu>0 .and. nu>0 )call stdlib_dgeql2( mu, nu, a, lda, tau, work, iinfo ) - work( 1 ) = iws + if( mu>0_${ik}$ .and. nu>0_${ik}$ )call stdlib${ii}$_dgeql2( mu, nu, a, lda, tau, work, iinfo ) + work( 1_${ik}$ ) = iws return - end subroutine stdlib_dgeqlf + end subroutine stdlib${ii}$_dgeqlf - pure subroutine stdlib_dgeqr2( m, n, a, lda, tau, work, info ) + pure subroutine stdlib${ii}$_dgeqr2( m, n, a, lda, tau, work, info ) !! DGEQR2 computes a QR factorization of a real m-by-n matrix A: !! A = Q * ( R ), !! ( 0 ) @@ -44612,50 +44612,50 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, k + integer(${ik}$) :: i, k real(dp) :: aii ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda0 .and. lwork0_${ik}$ .and. lwork1 .and. nb1_${ik}$ .and. nb1 .and. nb1_${ik}$ .and. nb t(i,1) - call stdlib_dlarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,t( i, 1 ) ) + call stdlib${ii}$_dlarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,t( i, 1_${ik}$ ) ) if( ieps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_dgetrs( trans, n, 1, af, ldaf, ipiv, work( n+1 ), n,info ) - call stdlib_daxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) + call stdlib${ii}$_dgetrs( trans, n, 1_${ik}$, af, ldaf, ipiv, work( n+1 ), n,info ) + call stdlib${ii}$_daxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -45226,14 +45226,14 @@ module stdlib_linalg_lapack_d work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_dlacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) + call stdlib${ii}$_dlacn2( 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_dgetrs( transt, n, 1, af, ldaf, ipiv, work( n+1 ),n, info ) + call stdlib${ii}$_dgetrs( transt, n, 1_${ik}$, af, ldaf, ipiv, work( n+1 ),n, info ) do i = 1, n work( n+i ) = work( i )*work( n+i ) @@ -45243,7 +45243,7 @@ module stdlib_linalg_lapack_d do i = 1, n work( n+i ) = work( i )*work( n+i ) end do - call stdlib_dgetrs( trans, n, 1, af, ldaf, ipiv, work( n+1 ), n,info ) + call stdlib${ii}$_dgetrs( trans, n, 1_${ik}$, af, ldaf, ipiv, work( n+1 ), n,info ) end if go to 100 end if @@ -45255,117 +45255,117 @@ module stdlib_linalg_lapack_d if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_dgerfs + end subroutine stdlib${ii}$_dgerfs - pure subroutine stdlib_dgerq2( m, n, a, lda, tau, work, info ) + pure subroutine stdlib${ii}$_dgerq2( m, n, a, lda, tau, work, info ) !! DGERQ2 computes an RQ factorization of a real m by n matrix A: !! A = R * Q. ! -- lapack computational routine -- ! -- 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(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, k + integer(${ik}$) :: i, k real(dp) :: aii ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda0 .and. lwork0_${ik}$ .and. lwork1 .and. nb1_${ik}$ .and. nb1 ) then + if( m-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_dlarft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( m-k+i, 1 ), lda, & + call stdlib${ii}$_dlarft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( m-k+i, 1_${ik}$ ), lda, & tau( i ), work, ldwork ) ! apply h to a(1:m-k+i-1,1:n-k+i+ib-1) from the right - call stdlib_dlarfb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', m-k+i-1, n-& - k+i+ib-1, ib,a( m-k+i, 1 ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork ) + call stdlib${ii}$_dlarfb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', m-k+i-1, n-& + k+i+ib-1, ib,a( m-k+i, 1_${ik}$ ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork ) end if end do - mu = m - k + i + nb - 1 - nu = n - k + i + nb - 1 + mu = m - k + i + nb - 1_${ik}$ + nu = n - k + i + nb - 1_${ik}$ else mu = m nu = n end if ! use unblocked code to factor the last or only block - if( mu>0 .and. nu>0 )call stdlib_dgerq2( mu, nu, a, lda, tau, work, iinfo ) - work( 1 ) = iws + if( mu>0_${ik}$ .and. nu>0_${ik}$ )call stdlib${ii}$_dgerq2( mu, nu, a, lda, tau, work, iinfo ) + work( 1_${ik}$ ) = iws return - end subroutine stdlib_dgerqf + end subroutine stdlib${ii}$_dgerqf - pure subroutine stdlib_dgetrf( m, n, a, lda, ipiv, info ) + pure subroutine stdlib${ii}$_dgetrf( m, n, a, lda, ipiv, info ) !! DGETRF computes an LU factorization of a general M-by-N matrix A !! using partial pivoting with row interchanges. !! The factorization has the form @@ -45426,61 +45426,61 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, iinfo, j, jb, nb + integer(${ik}$) :: i, 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}$, 'DGETRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=min( m, n ) ) then ! use unblocked code. - call stdlib_dgetrf2( m, n, a, lda, ipiv, info ) + call stdlib${ii}$_dgetrf2( m, n, a, lda, ipiv, info ) else ! use blocked code. do j = 1, min( m, n ), nb jb = min( min( m, n )-j+1, nb ) ! factor diagonal and subdiagonal blocks and test for exact ! singularity. - call stdlib_dgetrf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo ) + call stdlib${ii}$_dgetrf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo ) ! adjust info and the pivot indices. - if( info==0 .and. iinfo>0 )info = iinfo + j - 1 + if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + j - 1_${ik}$ do i = j, min( m, j+jb-1 ) - ipiv( i ) = j - 1 + ipiv( i ) + ipiv( i ) = j - 1_${ik}$ + ipiv( i ) end do ! apply interchanges to columns 1:j-1. - call stdlib_dlaswp( j-1, a, lda, j, j+jb-1, ipiv, 1 ) + call stdlib${ii}$_dlaswp( j-1, a, lda, j, j+jb-1, ipiv, 1_${ik}$ ) if( j+jb<=n ) then ! apply interchanges to columns j+jb:n. - call stdlib_dlaswp( n-j-jb+1, a( 1, j+jb ), lda, j, j+jb-1,ipiv, 1 ) + call stdlib${ii}$_dlaswp( n-j-jb+1, a( 1_${ik}$, j+jb ), lda, j, j+jb-1,ipiv, 1_${ik}$ ) ! compute block row of u. - call stdlib_dtrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, one, & + call stdlib${ii}$_dtrsm( '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_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& + call stdlib${ii}$_dgemm( '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 @@ -45488,10 +45488,10 @@ module stdlib_linalg_lapack_d end do end if return - end subroutine stdlib_dgetrf + end subroutine stdlib${ii}$_dgetrf - pure subroutine stdlib_dgghd3( compq, compz, n, ilo, ihi, a, lda, b, ldb, q,ldq, z, ldz, & + pure subroutine stdlib${ii}$_dgghd3( compq, compz, n, ilo, ihi, a, lda, b, ldb, q,ldq, z, ldz, & !! DGGHD3 reduces a pair of real matrices (A,B) to generalized upper !! Hessenberg form using orthogonal transformations, where A is a !! general matrix and B is upper triangular. The form of the @@ -45523,8 +45523,8 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: compq, compz - integer(ilp), intent(in) :: ihi, ilo, lda, ldb, ldq, ldz, n, lwork - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ilo, lda, ldb, ldq, ldz, n, lwork + integer(${ik}$), intent(out) :: info ! Array Arguments real(dp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) real(dp), intent(out) :: work(*) @@ -45533,76 +45533,76 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: blk22, initq, initz, lquery, wantq, wantz character :: compq2, compz2 - integer(ilp) :: cola, i, ierr, j, j0, jcol, jj, jrow, k, kacc22, len, lwkopt, n2nb, nb,& + integer(${ik}$) :: cola, i, ierr, j, j0, jcol, jj, jrow, k, kacc22, len, lwkopt, n2nb, nb,& nblst, nbmin, nh, nnb, nx, ppw, ppwo, pw, top, topq real(dp) :: c, c1, c2, s, s1, s2, temp, temp1, temp2, temp3 ! Intrinsic Functions intrinsic :: real,max ! Executable Statements ! decode and test the input parameters. - info = 0 - nb = stdlib_ilaenv( 1, 'DGGHD3', ' ', n, ilo, ihi, -1 ) - lwkopt = max( 6*n*nb, 1 ) - work( 1 ) = real( lwkopt,KIND=dp) + info = 0_${ik}$ + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGGHD3', ' ', n, ilo, ihi, -1_${ik}$ ) + lwkopt = max( 6_${ik}$*n*nb, 1_${ik}$ ) + work( 1_${ik}$ ) = real( lwkopt,KIND=dp) initq = stdlib_lsame( compq, 'I' ) wantq = initq .or. stdlib_lsame( compq, 'V' ) initz = stdlib_lsame( compz, 'I' ) wantz = initz .or. stdlib_lsame( compz, 'V' ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) if( .not.stdlib_lsame( compq, 'N' ) .and. .not.wantq ) then - info = -1 + info = -1_${ik}$ else if( .not.stdlib_lsame( compz, 'N' ) .and. .not.wantz ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ilo<1 ) then - info = -4 + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( ilo<1_${ik}$ ) then + info = -4_${ik}$ else if( ihi>n .or. ihi1 )call stdlib_dlaset( 'LOWER', n-1, n-1, zero, zero, b(2, 1), ldb ) + if( n>1_${ik}$ )call stdlib${ii}$_dlaset( 'LOWER', n-1, n-1, zero, zero, b(2_${ik}$, 1_${ik}$), ldb ) ! quick return if possible - nh = ihi - ilo + 1 - if( nh<=1 ) then - work( 1 ) = one + nh = ihi - ilo + 1_${ik}$ + if( nh<=1_${ik}$ ) then + work( 1_${ik}$ ) = one return end if ! determine the blocksize. - nbmin = stdlib_ilaenv( 2, 'DGGHD3', ' ', n, ilo, ihi, -1 ) - if( nb>1 .and. nb1_${ik}$ .and. nb=6*n*nbmin ) then - nb = lwork / ( 6*n ) + nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'DGGHD3', ' ', n, ilo, ihi,-1_${ik}$ ) ) + if( lwork>=6_${ik}$*n*nbmin ) then + nb = lwork / ( 6_${ik}$*n ) else - nb = 1 + nb = 1_${ik}$ end if end if end if @@ -45612,8 +45612,8 @@ module stdlib_linalg_lapack_d jcol = ilo else ! use blocked code - kacc22 = stdlib_ilaenv( 16, 'DGGHD3', ' ', n, ilo, ihi, -1 ) - blk22 = kacc22==2 + kacc22 = stdlib${ii}$_ilaenv( 16_${ik}$, 'DGGHD3', ' ', n, ilo, ihi, -1_${ik}$ ) + blk22 = kacc22==2_${ik}$ do jcol = ilo, ihi-2, nb nnb = min( nb, ihi-jcol-1 ) ! initialize small orthogonal factors that will hold the @@ -45621,13 +45621,13 @@ module stdlib_linalg_lapack_d ! n2nb denotes the number of 2*nnb-by-2*nnb factors ! nblst denotes the (possibly smaller) order of the last ! factor. - n2nb = ( ihi-jcol-1 ) / nnb - 1 + n2nb = ( ihi-jcol-1 ) / nnb - 1_${ik}$ nblst = ihi - jcol - n2nb*nnb - call stdlib_dlaset( 'ALL', nblst, nblst, zero, one, work, nblst ) - pw = nblst * nblst + 1 + call stdlib${ii}$_dlaset( 'ALL', nblst, nblst, zero, one, work, nblst ) + pw = nblst * nblst + 1_${ik}$ do i = 1, n2nb - call stdlib_dlaset( 'ALL', 2*nnb, 2*nnb, zero, one,work( pw ), 2*nnb ) - pw = pw + 4*nnb*nnb + call stdlib${ii}$_dlaset( 'ALL', 2_${ik}$*nnb, 2_${ik}$*nnb, zero, one,work( pw ), 2_${ik}$*nnb ) + pw = pw + 4_${ik}$*nnb*nnb end do ! reduce columns jcol:jcol+nnb-1 of a to hessenberg form. do j = jcol, jcol+nnb-1 @@ -45635,14 +45635,14 @@ module stdlib_linalg_lapack_d ! column of a and b, respectively. do i = ihi, j+2, -1 temp = a( i-1, j ) - call stdlib_dlartg( temp, a( i, j ), c, s, a( i-1, j ) ) + call stdlib${ii}$_dlartg( temp, a( i, j ), c, s, a( i-1, j ) ) a( i, j ) = c b( i, j ) = s end do ! accumulate givens rotations into workspace array. - ppw = ( nblst + 1 )*( nblst - 2 ) - j + jcol + 1 - len = 2 + j - jcol - jrow = j + n2nb*nnb + 2 + ppw = ( nblst + 1_${ik}$ )*( nblst - 2_${ik}$ ) - j + jcol + 1_${ik}$ + len = 2_${ik}$ + j - jcol + jrow = j + n2nb*nnb + 2_${ik}$ do i = ihi, jrow, -1 c = a( i, j ) s = b( i, j ) @@ -45651,31 +45651,31 @@ module stdlib_linalg_lapack_d work( jj + nblst ) = c*temp - s*work( jj ) work( jj ) = s*temp + c*work( jj ) end do - len = len + 1 - ppw = ppw - nblst - 1 + len = len + 1_${ik}$ + ppw = ppw - nblst - 1_${ik}$ end do - ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2*nnb + nnb + ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2_${ik}$*nnb + nnb j0 = jrow - nnb do jrow = j0, j+2, -nnb ppw = ppwo - len = 2 + j - jcol + len = 2_${ik}$ + j - jcol do i = jrow+nnb-1, jrow, -1 c = a( i, j ) s = b( i, j ) do jj = ppw, ppw+len-1 - temp = work( jj + 2*nnb ) - work( jj + 2*nnb ) = c*temp - s*work( jj ) + temp = work( jj + 2_${ik}$*nnb ) + work( jj + 2_${ik}$*nnb ) = c*temp - s*work( jj ) work( jj ) = s*temp + c*work( jj ) end do - len = len + 1 - ppw = ppw - 2*nnb - 1 + len = len + 1_${ik}$ + ppw = ppw - 2_${ik}$*nnb - 1_${ik}$ end do - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do ! top denotes the number of top rows in a and b that will ! not be updated during the next steps. - if( jcol<=2 ) then - top = 0 + if( jcol<=2_${ik}$ ) then + top = 0_${ik}$ else top = jcol end if @@ -45693,9 +45693,9 @@ module stdlib_linalg_lapack_d ! annihilate b( jj+1, jj ). if( jj0 ) then + if( jj>0_${ik}$ ) then do i = jj, 1, -1 - call stdlib_drot( ihi-top, a( top+1, j+i+1 ), 1,a( top+1, j+i ), 1, a( & + call stdlib${ii}$_drot( ihi-top, a( top+1, j+i+1 ), 1_${ik}$,a( top+1, j+i ), 1_${ik}$, a( & j+1+i, j ),-b( j+1+i, j ) ) end do end if ! update (j+1)th column of a by transformations from left. - if ( j < jcol + nnb - 1 ) then - len = 1 + j - jcol + if ( j < jcol + nnb - 1_${ik}$ ) then + len = 1_${ik}$ + j - jcol ! multiply with the trailing accumulated orthogonal ! matrix, which takes the form ! [ u11 u12 ] @@ -45744,23 +45744,23 @@ module stdlib_linalg_lapack_d ! [ u21 u22 ] ! where u21 is a len-by-len matrix and u12 is lower ! triangular. - jrow = ihi - nblst + 1 - call stdlib_dgemv( 'TRANSPOSE', nblst, len, one, work,nblst, a( jrow, j+1 )& - , 1, zero,work( pw ), 1 ) + jrow = ihi - nblst + 1_${ik}$ + call stdlib${ii}$_dgemv( 'TRANSPOSE', nblst, len, one, work,nblst, a( jrow, j+1 )& + , 1_${ik}$, zero,work( pw ), 1_${ik}$ ) ppw = pw + len do i = jrow, jrow+nblst-len-1 work( ppw ) = a( i, j+1 ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do - call stdlib_dtrmv( 'LOWER', 'TRANSPOSE', 'NON-UNIT',nblst-len, work( & - len*nblst + 1 ), nblst,work( pw+len ), 1 ) - call stdlib_dgemv( 'TRANSPOSE', len, nblst-len, one,work( (len+1)*nblst - & - len + 1 ), nblst,a( jrow+nblst-len, j+1 ), 1, one,work( pw+len ), 1 ) + call stdlib${ii}$_dtrmv( 'LOWER', 'TRANSPOSE', 'NON-UNIT',nblst-len, work( & + len*nblst + 1_${ik}$ ), nblst,work( pw+len ), 1_${ik}$ ) + call stdlib${ii}$_dgemv( 'TRANSPOSE', len, nblst-len, one,work( (len+1)*nblst - & + len + 1_${ik}$ ), nblst,a( jrow+nblst-len, j+1 ), 1_${ik}$, one,work( pw+len ), 1_${ik}$ ) ppw = pw do i = jrow, jrow+nblst-1 a( i, j+1 ) = work( ppw ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do ! multiply with the other accumulated orthogonal ! matrices, which take the form @@ -45772,44 +45772,44 @@ module stdlib_linalg_lapack_d ! where i denotes the (nnb-len)-by-(nnb-len) identity ! matrix, u21 is a len-by-len upper triangular matrix ! and u12 is an nnb-by-nnb lower triangular matrix. - ppwo = 1 + nblst*nblst + ppwo = 1_${ik}$ + nblst*nblst j0 = jrow - nnb do jrow = j0, jcol+1, -nnb ppw = pw + len do i = jrow, jrow+nnb-1 work( ppw ) = a( i, j+1 ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do ppw = pw do i = jrow+nnb, jrow+nnb+len-1 work( ppw ) = a( i, j+1 ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do - call stdlib_dtrmv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', len,work( ppwo + & - nnb ), 2*nnb, work( pw ),1 ) - call stdlib_dtrmv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', nnb,work( ppwo + & - 2*len*nnb ),2*nnb, work( pw + len ), 1 ) - call stdlib_dgemv( 'TRANSPOSE', nnb, len, one,work( ppwo ), 2*nnb, a( & - jrow, j+1 ), 1,one, work( pw ), 1 ) - call stdlib_dgemv( 'TRANSPOSE', len, nnb, one,work( ppwo + 2*len*nnb + & - nnb ), 2*nnb,a( jrow+nnb, j+1 ), 1, one,work( pw+len ), 1 ) + call stdlib${ii}$_dtrmv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', len,work( ppwo + & + nnb ), 2_${ik}$*nnb, work( pw ),1_${ik}$ ) + call stdlib${ii}$_dtrmv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', nnb,work( ppwo + & + 2_${ik}$*len*nnb ),2_${ik}$*nnb, work( pw + len ), 1_${ik}$ ) + call stdlib${ii}$_dgemv( 'TRANSPOSE', nnb, len, one,work( ppwo ), 2_${ik}$*nnb, a( & + jrow, j+1 ), 1_${ik}$,one, work( pw ), 1_${ik}$ ) + call stdlib${ii}$_dgemv( 'TRANSPOSE', len, nnb, one,work( ppwo + 2_${ik}$*len*nnb + & + nnb ), 2_${ik}$*nnb,a( jrow+nnb, j+1 ), 1_${ik}$, one,work( pw+len ), 1_${ik}$ ) ppw = pw do i = jrow, jrow+len+nnb-1 a( i, j+1 ) = work( ppw ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end if end do ! apply accumulated orthogonal matrices to a. - cola = n - jcol - nnb + 1 - j = ihi - nblst + 1 - call stdlib_dgemm( 'TRANSPOSE', 'NO TRANSPOSE', nblst,cola, nblst, one, work, & + cola = n - jcol - nnb + 1_${ik}$ + j = ihi - nblst + 1_${ik}$ + call stdlib${ii}$_dgemm( 'TRANSPOSE', 'NO TRANSPOSE', nblst,cola, nblst, one, work, & nblst,a( j, jcol+nnb ), lda, zero, work( pw ),nblst ) - call stdlib_dlacpy( 'ALL', nblst, cola, work( pw ), nblst,a( j, jcol+nnb ), lda ) + call stdlib${ii}$_dlacpy( 'ALL', nblst, cola, work( pw ), nblst,a( j, jcol+nnb ), lda ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( blk22 ) then @@ -45819,68 +45819,68 @@ module stdlib_linalg_lapack_d ! [ u21 u22 ], ! where all blocks are nnb-by-nnb, u21 is upper ! triangular and u12 is lower triangular. - call stdlib_dorm22( 'LEFT', 'TRANSPOSE', 2*nnb, cola, nnb,nnb, work( ppwo )& - , 2*nnb,a( j, jcol+nnb ), lda, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_dorm22( 'LEFT', 'TRANSPOSE', 2_${ik}$*nnb, cola, nnb,nnb, work( ppwo )& + , 2_${ik}$*nnb,a( j, jcol+nnb ), lda, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_dgemm( 'TRANSPOSE', 'NO TRANSPOSE', 2*nnb,cola, 2*nnb, one, & - work( ppwo ), 2*nnb,a( j, jcol+nnb ), lda, zero, work( pw ),2*nnb ) - call stdlib_dlacpy( 'ALL', 2*nnb, cola, work( pw ), 2*nnb,a( j, jcol+nnb ),& + call stdlib${ii}$_dgemm( 'TRANSPOSE', 'NO TRANSPOSE', 2_${ik}$*nnb,cola, 2_${ik}$*nnb, one, & + work( ppwo ), 2_${ik}$*nnb,a( j, jcol+nnb ), lda, zero, work( pw ),2_${ik}$*nnb ) + call stdlib${ii}$_dlacpy( 'ALL', 2_${ik}$*nnb, cola, work( pw ), 2_${ik}$*nnb,a( j, jcol+nnb ),& lda ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do ! apply accumulated orthogonal matrices to q. if( wantq ) then - j = ihi - nblst + 1 + j = ihi - nblst + 1_${ik}$ if ( initq ) then - topq = max( 2, j - jcol + 1 ) - nh = ihi - topq + 1 + topq = max( 2_${ik}$, j - jcol + 1_${ik}$ ) + nh = ihi - topq + 1_${ik}$ else - topq = 1 + topq = 1_${ik}$ nh = n end if - call stdlib_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, one, q( & + call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, one, q( & topq, j ), ldq,work, nblst, zero, work( pw ), nh ) - call stdlib_dlacpy( 'ALL', nh, nblst, work( pw ), nh,q( topq, j ), ldq ) + call stdlib${ii}$_dlacpy( 'ALL', nh, nblst, work( pw ), nh,q( topq, j ), ldq ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( initq ) then - topq = max( 2, j - jcol + 1 ) - nh = ihi - topq + 1 + topq = max( 2_${ik}$, j - jcol + 1_${ik}$ ) + nh = ihi - topq + 1_${ik}$ end if if ( blk22 ) then ! exploit the structure of u. - call stdlib_dorm22( 'RIGHT', 'NO TRANSPOSE', nh, 2*nnb,nnb, nnb, work( & - ppwo ), 2*nnb,q( topq, j ), ldq, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_dorm22( 'RIGHT', 'NO TRANSPOSE', nh, 2_${ik}$*nnb,nnb, nnb, work( & + ppwo ), 2_${ik}$*nnb,q( topq, j ), ldq, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2*nnb, 2*nnb, one,& - q( topq, j ), ldq,work( ppwo ), 2*nnb, zero, work( pw ),nh ) - call stdlib_dlacpy( 'ALL', nh, 2*nnb, work( pw ), nh,q( topq, j ), ldq ) + call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2_${ik}$*nnb, 2_${ik}$*nnb, one,& + q( topq, j ), ldq,work( ppwo ), 2_${ik}$*nnb, zero, work( pw ),nh ) + call stdlib${ii}$_dlacpy( 'ALL', nh, 2_${ik}$*nnb, work( pw ), nh,q( topq, j ), ldq ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end if ! accumulate right givens rotations if required. - if ( wantz .or. top>0 ) then + if ( wantz .or. top>0_${ik}$ ) then ! initialize small orthogonal factors that will hold the ! accumulated givens rotations in workspace. - call stdlib_dlaset( 'ALL', nblst, nblst, zero, one, work,nblst ) - pw = nblst * nblst + 1 + call stdlib${ii}$_dlaset( 'ALL', nblst, nblst, zero, one, work,nblst ) + pw = nblst * nblst + 1_${ik}$ do i = 1, n2nb - call stdlib_dlaset( 'ALL', 2*nnb, 2*nnb, zero, one,work( pw ), 2*nnb ) + call stdlib${ii}$_dlaset( 'ALL', 2_${ik}$*nnb, 2_${ik}$*nnb, zero, one,work( pw ), 2_${ik}$*nnb ) - pw = pw + 4*nnb*nnb + pw = pw + 4_${ik}$*nnb*nnb end do ! accumulate givens rotations into workspace array. do j = jcol, jcol+nnb-1 - ppw = ( nblst + 1 )*( nblst - 2 ) - j + jcol + 1 - len = 2 + j - jcol - jrow = j + n2nb*nnb + 2 + ppw = ( nblst + 1_${ik}$ )*( nblst - 2_${ik}$ ) - j + jcol + 1_${ik}$ + len = 2_${ik}$ + j - jcol + jrow = j + n2nb*nnb + 2_${ik}$ do i = ihi, jrow, -1 c = a( i, j ) a( i, j ) = zero @@ -45891,114 +45891,114 @@ module stdlib_linalg_lapack_d work( jj + nblst ) = c*temp - s*work( jj ) work( jj ) = s*temp + c*work( jj ) end do - len = len + 1 - ppw = ppw - nblst - 1 + len = len + 1_${ik}$ + ppw = ppw - nblst - 1_${ik}$ end do - ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2*nnb + nnb + ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2_${ik}$*nnb + nnb j0 = jrow - nnb do jrow = j0, j+2, -nnb ppw = ppwo - len = 2 + j - jcol + len = 2_${ik}$ + j - jcol do i = jrow+nnb-1, jrow, -1 c = a( i, j ) a( i, j ) = zero s = b( i, j ) b( i, j ) = zero do jj = ppw, ppw+len-1 - temp = work( jj + 2*nnb ) - work( jj + 2*nnb ) = c*temp - s*work( jj ) + temp = work( jj + 2_${ik}$*nnb ) + work( jj + 2_${ik}$*nnb ) = c*temp - s*work( jj ) work( jj ) = s*temp + c*work( jj ) end do - len = len + 1 - ppw = ppw - 2*nnb - 1 + len = len + 1_${ik}$ + ppw = ppw - 2_${ik}$*nnb - 1_${ik}$ end do - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end do else - call stdlib_dlaset( 'LOWER', ihi - jcol - 1, nnb, zero, zero,a( jcol + 2, & + call stdlib${ii}$_dlaset( 'LOWER', ihi - jcol - 1_${ik}$, nnb, zero, zero,a( jcol + 2_${ik}$, & jcol ), lda ) - call stdlib_dlaset( 'LOWER', ihi - jcol - 1, nnb, zero, zero,b( jcol + 2, & + call stdlib${ii}$_dlaset( 'LOWER', ihi - jcol - 1_${ik}$, nnb, zero, zero,b( jcol + 2_${ik}$, & jcol ), ldb ) end if ! apply accumulated orthogonal matrices to a and b. - if ( top>0 ) then - j = ihi - nblst + 1 - call stdlib_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, one, a( & - 1, j ), lda,work, nblst, zero, work( pw ), top ) - call stdlib_dlacpy( 'ALL', top, nblst, work( pw ), top,a( 1, j ), lda ) + if ( top>0_${ik}$ ) then + j = ihi - nblst + 1_${ik}$ + call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, one, a( & + 1_${ik}$, j ), lda,work, nblst, zero, work( pw ), top ) + call stdlib${ii}$_dlacpy( 'ALL', top, nblst, work( pw ), top,a( 1_${ik}$, j ), lda ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( blk22 ) then ! exploit the structure of u. - call stdlib_dorm22( 'RIGHT', 'NO TRANSPOSE', top, 2*nnb,nnb, nnb, work( & - ppwo ), 2*nnb,a( 1, j ), lda, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_dorm22( 'RIGHT', 'NO TRANSPOSE', top, 2_${ik}$*nnb,nnb, nnb, work( & + ppwo ), 2_${ik}$*nnb,a( 1_${ik}$, j ), lda, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2*nnb, 2*nnb, & - one, a( 1, j ), lda,work( ppwo ), 2*nnb, zero,work( pw ), top ) - call stdlib_dlacpy( 'ALL', top, 2*nnb, work( pw ), top,a( 1, j ), lda ) + call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2_${ik}$*nnb, 2_${ik}$*nnb, & + one, a( 1_${ik}$, j ), lda,work( ppwo ), 2_${ik}$*nnb, zero,work( pw ), top ) + call stdlib${ii}$_dlacpy( 'ALL', top, 2_${ik}$*nnb, work( pw ), top,a( 1_${ik}$, j ), lda ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do - j = ihi - nblst + 1 - call stdlib_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, one, b( & - 1, j ), ldb,work, nblst, zero, work( pw ), top ) - call stdlib_dlacpy( 'ALL', top, nblst, work( pw ), top,b( 1, j ), ldb ) + j = ihi - nblst + 1_${ik}$ + call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, one, b( & + 1_${ik}$, j ), ldb,work, nblst, zero, work( pw ), top ) + call stdlib${ii}$_dlacpy( 'ALL', top, nblst, work( pw ), top,b( 1_${ik}$, j ), ldb ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( blk22 ) then ! exploit the structure of u. - call stdlib_dorm22( 'RIGHT', 'NO TRANSPOSE', top, 2*nnb,nnb, nnb, work( & - ppwo ), 2*nnb,b( 1, j ), ldb, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_dorm22( 'RIGHT', 'NO TRANSPOSE', top, 2_${ik}$*nnb,nnb, nnb, work( & + ppwo ), 2_${ik}$*nnb,b( 1_${ik}$, j ), ldb, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2*nnb, 2*nnb, & - one, b( 1, j ), ldb,work( ppwo ), 2*nnb, zero,work( pw ), top ) - call stdlib_dlacpy( 'ALL', top, 2*nnb, work( pw ), top,b( 1, j ), ldb ) + call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2_${ik}$*nnb, 2_${ik}$*nnb, & + one, b( 1_${ik}$, j ), ldb,work( ppwo ), 2_${ik}$*nnb, zero,work( pw ), top ) + call stdlib${ii}$_dlacpy( 'ALL', top, 2_${ik}$*nnb, work( pw ), top,b( 1_${ik}$, j ), ldb ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end if ! apply accumulated orthogonal matrices to z. if( wantz ) then - j = ihi - nblst + 1 + j = ihi - nblst + 1_${ik}$ if ( initq ) then - topq = max( 2, j - jcol + 1 ) - nh = ihi - topq + 1 + topq = max( 2_${ik}$, j - jcol + 1_${ik}$ ) + nh = ihi - topq + 1_${ik}$ else - topq = 1 + topq = 1_${ik}$ nh = n end if - call stdlib_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, one, z( & + call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, one, z( & topq, j ), ldz,work, nblst, zero, work( pw ), nh ) - call stdlib_dlacpy( 'ALL', nh, nblst, work( pw ), nh,z( topq, j ), ldz ) + call stdlib${ii}$_dlacpy( 'ALL', nh, nblst, work( pw ), nh,z( topq, j ), ldz ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( initq ) then - topq = max( 2, j - jcol + 1 ) - nh = ihi - topq + 1 + topq = max( 2_${ik}$, j - jcol + 1_${ik}$ ) + nh = ihi - topq + 1_${ik}$ end if if ( blk22 ) then ! exploit the structure of u. - call stdlib_dorm22( 'RIGHT', 'NO TRANSPOSE', nh, 2*nnb,nnb, nnb, work( & - ppwo ), 2*nnb,z( topq, j ), ldz, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_dorm22( 'RIGHT', 'NO TRANSPOSE', nh, 2_${ik}$*nnb,nnb, nnb, work( & + ppwo ), 2_${ik}$*nnb,z( topq, j ), ldz, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2*nnb, 2*nnb, one,& - z( topq, j ), ldz,work( ppwo ), 2*nnb, zero, work( pw ),nh ) - call stdlib_dlacpy( 'ALL', nh, 2*nnb, work( pw ), nh,z( topq, j ), ldz ) + call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2_${ik}$*nnb, 2_${ik}$*nnb, one,& + z( topq, j ), ldz,work( ppwo ), 2_${ik}$*nnb, zero, work( pw ),nh ) + call stdlib${ii}$_dlacpy( 'ALL', nh, 2_${ik}$*nnb, work( pw ), nh,z( topq, j ), ldz ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end if end do @@ -46011,14 +46011,14 @@ module stdlib_linalg_lapack_d if ( wantq )compq2 = 'V' if ( wantz )compz2 = 'V' end if - if ( jcolm ) ) then - info = -3 + info = -1_${ik}$ + else if( m<0_${ik}$ ) then + info = -2_${ik}$ + else if( ( n<0_${ik}$ ) .or. ( n>m ) ) then + info = -3_${ik}$ else if( lda sqrt(overflow_threshold), and ! underflow for ||a(:,p)||_2 < sqrt(underflow_threshold). - ! hence, stdlib_dnrm2 cannot be trusted, not even in the case when + ! hence, stdlib${ii}$_dnrm2 cannot be trusted, not even in the case when ! the true norm is far from the under(over)flow boundaries. - ! if properly implemented stdlib_dnrm2 is available, the if-then-else - ! below should read "aapp = stdlib_dnrm2( m, a(1,p), 1 ) * d(p)". + ! if properly implemented stdlib${ii}$_dnrm2 is available, the if-then-else + ! below should read "aapp = stdlib${ii}$_dnrm2( m, a(1,p), 1 ) * d(p)". if( ( sva( p )rootsfmin ) ) then - sva( p ) = stdlib_dnrm2( m, a( 1, p ), 1 )*d( p ) + sva( p ) = stdlib${ii}$_dnrm2( m, a( 1_${ik}$, p ), 1_${ik}$ )*d( p ) else temp1 = zero aapp = one - call stdlib_dlassq( m, a( 1, p ), 1, temp1, aapp ) + call stdlib${ii}$_dlassq( m, a( 1_${ik}$, p ), 1_${ik}$, temp1, aapp ) sva( p ) = temp1*sqrt( aapp )*d( p ) end if aapp = sva( p ) @@ -46320,7 +46320,7 @@ module stdlib_linalg_lapack_d aapp = sva( p ) end if if( aapp>zero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2002: do q = p + 1, min( igl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -46328,25 +46328,25 @@ module stdlib_linalg_lapack_d if( aaqq>=one ) then rotok = ( small*aapp )<=aaqq if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_ddot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& + aapq = ( stdlib${ii}$_ddot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*d( p )& *d( q ) / aaqq )/ aapp else - call stdlib_dcopy( m, a( 1, p ), 1, work, 1 ) - call stdlib_dlascl( 'G', 0, 0, aapp, d( p ),m, 1, work, lda,& + call stdlib${ii}$_dcopy( m, a( 1_${ik}$, p ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, d( p ),m, 1_${ik}$, work, lda,& ierr ) - aapq = stdlib_ddot( m, work, 1, a( 1, q ),1 )*d( q ) / & + aapq = stdlib${ii}$_ddot( m, work, 1_${ik}$, a( 1_${ik}$, q ),1_${ik}$ )*d( q ) / & aaqq end if else rotok = aapp<=( aaqq / small ) if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_ddot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& + aapq = ( stdlib${ii}$_ddot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*d( p )& *d( q ) / aaqq )/ aapp else - call stdlib_dcopy( m, a( 1, q ), 1, work, 1 ) - call stdlib_dlascl( 'G', 0, 0, aaqq, d( q ),m, 1, work, lda,& + call stdlib${ii}$_dcopy( m, a( 1_${ik}$, q ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, d( q ),m, 1_${ik}$, work, lda,& ierr ) - aapq = stdlib_ddot( m, work, 1, a( 1, p ),1 )*d( p ) / & + aapq = stdlib${ii}$_ddot( m, work, 1_${ik}$, a( 1_${ik}$, p ),1_${ik}$ )*d( p ) / & aapp end if end if @@ -46355,10 +46355,10 @@ module stdlib_linalg_lapack_d if( abs( aapq )>tol ) then ! Rotate ! rotated = rotated + one - if( ir1==0 ) then - notrot = 0 - pskipped = 0 - iswrot = iswrot + 1 + if( ir1==0_${ik}$ ) then + notrot = 0_${ik}$ + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ end if if( rotok ) then aqoap = aaqq / aapp @@ -46366,12 +46366,12 @@ module stdlib_linalg_lapack_d theta = -half*abs( aqoap-apoaq )/aapq if( abs( theta )>bigtheta ) then t = half / theta - fastr( 3 ) = t*d( p ) / d( q ) - fastr( 4 ) = -t*d( q ) / d( p ) - call stdlib_drotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) + fastr( 3_${ik}$ ) = t*d( p ) / d( q ) + fastr( 4_${ik}$ ) = -t*d( q ) / d( p ) + call stdlib${ii}$_drotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$, fastr ) - if( rsvec )call stdlib_drotm( mvl,v( 1, p ), 1,v( 1, q ),& - 1,fastr ) + if( rsvec )call stdlib${ii}$_drotm( mvl,v( 1_${ik}$, p ), 1_${ik}$,v( 1_${ik}$, q ),& + 1_${ik}$,fastr ) sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq ) ) @@ -46391,68 +46391,68 @@ module stdlib_linalg_lapack_d aqoap = d( q ) / d( p ) if( d( p )>=one ) then if( d( q )>=one ) then - fastr( 3 ) = t*apoaq - fastr( 4 ) = -t*aqoap + fastr( 3_${ik}$ ) = t*apoaq + fastr( 4_${ik}$ ) = -t*aqoap d( p ) = d( p )*cs d( q ) = d( q )*cs - call stdlib_drotm( m, a( 1, p ), 1,a( 1, q ), 1,& + call stdlib${ii}$_drotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$,& fastr ) - if( rsvec )call stdlib_drotm( mvl,v( 1, p ), 1, v( & - 1, q ),1, fastr ) + if( rsvec )call stdlib${ii}$_drotm( mvl,v( 1_${ik}$, p ), 1_${ik}$, v( & + 1_${ik}$, q ),1_${ik}$, fastr ) else - call stdlib_daxpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & - p ), 1 ) - call stdlib_daxpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & - 1, q ), 1 ) + call stdlib${ii}$_daxpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( 1_${ik}$, & + p ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( & + 1_${ik}$, q ), 1_${ik}$ ) d( p ) = d( p )*cs d( q ) = d( q ) / cs if( rsvec ) then - call stdlib_daxpy( mvl, -t*aqoap,v( 1, q ), 1,v(& - 1, p ), 1 ) - call stdlib_daxpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& - v( 1, q ), 1 ) + call stdlib${ii}$_daxpy( mvl, -t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,v(& + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ), 1_${ik}$,& + v( 1_${ik}$, q ), 1_${ik}$ ) end if end if else if( d( q )>=one ) then - call stdlib_daxpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & - ), 1 ) - call stdlib_daxpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) + call stdlib${ii}$_daxpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q & + ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( m, -cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) d( p ) = d( p ) / cs d( q ) = d( q )*cs if( rsvec ) then - call stdlib_daxpy( mvl, t*apoaq,v( 1, p ), 1,v( & - 1, q ), 1 ) - call stdlib_daxpy( mvl,-cs*sn*aqoap,v( 1, q ), & - 1,v( 1, p ), 1 ) + call stdlib${ii}$_daxpy( mvl, t*apoaq,v( 1_${ik}$, p ), 1_${ik}$,v( & + 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q ), & + 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if else if( d( p )>=d( q ) ) then - call stdlib_daxpy( m, -t*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) - call stdlib_daxpy( m, cs*sn*apoaq,a( 1, p ), 1,& - a( 1, q ), 1 ) + call stdlib${ii}$_daxpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,& + a( 1_${ik}$, q ), 1_${ik}$ ) d( p ) = d( p )*cs d( q ) = d( q ) / cs if( rsvec ) then - call stdlib_daxpy( mvl,-t*aqoap,v( 1, q ), 1,& - v( 1, p ), 1 ) - call stdlib_daxpy( mvl,cs*sn*apoaq,v( 1, p ),& - 1,v( 1, q ), 1 ) + call stdlib${ii}$_daxpy( mvl,-t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,& + v( 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ),& + 1_${ik}$,v( 1_${ik}$, q ), 1_${ik}$ ) end if else - call stdlib_daxpy( m, t*apoaq,a( 1, p ), 1,a( 1,& - q ), 1 ) - call stdlib_daxpy( m,-cs*sn*aqoap,a( 1, q ), 1,& - a( 1, p ), 1 ) + call stdlib${ii}$_daxpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$,& + q ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( m,-cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,& + a( 1_${ik}$, p ), 1_${ik}$ ) d( p ) = d( p ) / cs d( q ) = d( q )*cs if( rsvec ) then - call stdlib_daxpy( mvl,t*apoaq, v( 1, p ),1, & - v( 1, q ), 1 ) - call stdlib_daxpy( mvl,-cs*sn*aqoap,v( 1, q )& - , 1,v( 1, p ), 1 ) + call stdlib${ii}$_daxpy( mvl,t*apoaq, v( 1_${ik}$, p ),1_${ik}$, & + v( 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q )& + , 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if end if end if @@ -46460,14 +46460,14 @@ module stdlib_linalg_lapack_d end if else ! .. have to use modified gram-schmidt like transformation - call stdlib_dcopy( m, a( 1, p ), 1, work, 1 ) - call stdlib_dlascl( 'G', 0, 0, aapp, one, m,1, work, lda, & + call stdlib${ii}$_dcopy( m, a( 1_${ik}$, p ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one, m,1_${ik}$, work, lda, & ierr ) - call stdlib_dlascl( 'G', 0, 0, aaqq, one, m,1, a( 1, q ), & + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one, m,1_${ik}$, a( 1_${ik}$, q ), & lda, ierr ) temp1 = -aapq*d( p ) / d( q ) - call stdlib_daxpy( m, temp1, work, 1,a( 1, q ), 1 ) - call stdlib_dlascl( 'G', 0, 0, one, aaqq, m,1, a( 1, q ), & + call stdlib${ii}$_daxpy( m, temp1, work, 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq, m,1_${ik}$, a( 1_${ik}$, q ), & lda, ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) @@ -46475,40 +46475,40 @@ module stdlib_linalg_lapack_d ! end if rotok then ... else ! in the case of cancellation in updating sva(q), sva(p) ! recompute sva(q), sva(p). - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_dnrm2( m, a( 1, q ), 1 )*d( q ) + sva( q ) = stdlib${ii}$_dnrm2( m, a( 1_${ik}$, q ), 1_${ik}$ )*d( q ) else t = zero aaqq = one - call stdlib_dlassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_dlassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq )*d( q ) end if end if if( ( aapp / aapp0 )<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_dnrm2( m, a( 1, p ), 1 )*d( p ) + aapp = stdlib${ii}$_dnrm2( m, a( 1_${ik}$, p ), 1_${ik}$ )*d( p ) else t = zero aapp = one - call stdlib_dlassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_dlassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp )*d( p ) end if sva( p ) = aapp end if else ! a(:,p) and a(:,q) already numerically orthogonal - if( ir1==0 )notrot = notrot + 1 - pskipped = pskipped + 1 + if( ir1==0_${ik}$ )notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ end if else ! a(:,q) is zero column - if( ir1==0 )notrot = notrot + 1 - pskipped = pskipped + 1 + if( ir1==0_${ik}$ )notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then - if( ir1==0 )aapp = -aapp - notrot = 0 + if( ir1==0_${ik}$ )aapp = -aapp + notrot = 0_${ik}$ go to 2103 end if end do loop_2002 @@ -46518,7 +46518,7 @@ module stdlib_linalg_lapack_d sva( p ) = aapp else sva( p ) = aapp - if( ( ir1==0 ) .and. ( aapp==zero ) )notrot = notrot + min( igl+kbl-1, & + if( ( ir1==0_${ik}$ ) .and. ( aapp==zero ) )notrot = notrot + min( igl+kbl-1, & n ) - p end if end do loop_2001 @@ -46528,15 +46528,15 @@ module stdlib_linalg_lapack_d ! end of ir1-loop ! ........................................................ ! ... go to the off diagonal blocks - igl = ( ibr-1 )*kbl + 1 + igl = ( ibr-1 )*kbl + 1_${ik}$ loop_2010: do jbc = ibr + 1, nbl - jgl = ( jbc-1 )*kbl + 1 + jgl = ( jbc-1 )*kbl + 1_${ik}$ ! doing the block at ( ibr, jbc ) - ijblsk = 0 + ijblsk = 0_${ik}$ loop_2100: do p = igl, min( igl+kbl-1, n ) aapp = sva( p ) if( aapp>zero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2200: do q = jgl, min( jgl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -46550,13 +46550,13 @@ module stdlib_linalg_lapack_d rotok = ( small*aaqq )<=aapp end if if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_ddot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& + aapq = ( stdlib${ii}$_ddot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*d( p )& *d( q ) / aaqq )/ aapp else - call stdlib_dcopy( m, a( 1, p ), 1, work, 1 ) - call stdlib_dlascl( 'G', 0, 0, aapp, d( p ),m, 1, work, lda,& + call stdlib${ii}$_dcopy( m, a( 1_${ik}$, p ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, d( p ),m, 1_${ik}$, work, lda,& ierr ) - aapq = stdlib_ddot( m, work, 1, a( 1, q ),1 )*d( q ) / & + aapq = stdlib${ii}$_ddot( m, work, 1_${ik}$, a( 1_${ik}$, q ),1_${ik}$ )*d( q ) / & aaqq end if else @@ -46566,23 +46566,23 @@ module stdlib_linalg_lapack_d rotok = aaqq<=( aapp / small ) end if if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_ddot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& + aapq = ( stdlib${ii}$_ddot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*d( p )& *d( q ) / aaqq )/ aapp else - call stdlib_dcopy( m, a( 1, q ), 1, work, 1 ) - call stdlib_dlascl( 'G', 0, 0, aaqq, d( q ),m, 1, work, lda,& + call stdlib${ii}$_dcopy( m, a( 1_${ik}$, q ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, d( q ),m, 1_${ik}$, work, lda,& ierr ) - aapq = stdlib_ddot( m, work, 1, a( 1, p ),1 )*d( p ) / & + aapq = stdlib${ii}$_ddot( m, work, 1_${ik}$, a( 1_${ik}$, p ),1_${ik}$ )*d( p ) / & aapp end if end if mxaapq = max( mxaapq, abs( aapq ) ) ! to rotate or not to rotate, that is the question ... if( abs( aapq )>tol ) then - notrot = 0 + notrot = 0_${ik}$ ! rotated = rotated + 1 - pskipped = 0 - iswrot = iswrot + 1 + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ if( rotok ) then aqoap = aaqq / aapp apoaq = aapp / aaqq @@ -46590,12 +46590,12 @@ module stdlib_linalg_lapack_d if( aaqq>aapp0 )theta = -theta if( abs( theta )>bigtheta ) then t = half / theta - fastr( 3 ) = t*d( p ) / d( q ) - fastr( 4 ) = -t*d( q ) / d( p ) - call stdlib_drotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) + fastr( 3_${ik}$ ) = t*d( p ) / d( q ) + fastr( 4_${ik}$ ) = -t*d( q ) / d( p ) + call stdlib${ii}$_drotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$, fastr ) - if( rsvec )call stdlib_drotm( mvl,v( 1, p ), 1,v( 1, q ),& - 1,fastr ) + if( rsvec )call stdlib${ii}$_drotm( mvl,v( 1_${ik}$, p ), 1_${ik}$,v( 1_${ik}$, q ),& + 1_${ik}$,fastr ) sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq ) ) @@ -46616,68 +46616,68 @@ module stdlib_linalg_lapack_d aqoap = d( q ) / d( p ) if( d( p )>=one ) then if( d( q )>=one ) then - fastr( 3 ) = t*apoaq - fastr( 4 ) = -t*aqoap + fastr( 3_${ik}$ ) = t*apoaq + fastr( 4_${ik}$ ) = -t*aqoap d( p ) = d( p )*cs d( q ) = d( q )*cs - call stdlib_drotm( m, a( 1, p ), 1,a( 1, q ), 1,& + call stdlib${ii}$_drotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$,& fastr ) - if( rsvec )call stdlib_drotm( mvl,v( 1, p ), 1, v( & - 1, q ),1, fastr ) + if( rsvec )call stdlib${ii}$_drotm( mvl,v( 1_${ik}$, p ), 1_${ik}$, v( & + 1_${ik}$, q ),1_${ik}$, fastr ) else - call stdlib_daxpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & - p ), 1 ) - call stdlib_daxpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & - 1, q ), 1 ) + call stdlib${ii}$_daxpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( 1_${ik}$, & + p ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( & + 1_${ik}$, q ), 1_${ik}$ ) if( rsvec ) then - call stdlib_daxpy( mvl, -t*aqoap,v( 1, q ), 1,v(& - 1, p ), 1 ) - call stdlib_daxpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& - v( 1, q ), 1 ) + call stdlib${ii}$_daxpy( mvl, -t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,v(& + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ), 1_${ik}$,& + v( 1_${ik}$, q ), 1_${ik}$ ) end if d( p ) = d( p )*cs d( q ) = d( q ) / cs end if else if( d( q )>=one ) then - call stdlib_daxpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & - ), 1 ) - call stdlib_daxpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) + call stdlib${ii}$_daxpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q & + ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( m, -cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) if( rsvec ) then - call stdlib_daxpy( mvl, t*apoaq,v( 1, p ), 1,v( & - 1, q ), 1 ) - call stdlib_daxpy( mvl,-cs*sn*aqoap,v( 1, q ), & - 1,v( 1, p ), 1 ) + call stdlib${ii}$_daxpy( mvl, t*apoaq,v( 1_${ik}$, p ), 1_${ik}$,v( & + 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q ), & + 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if d( p ) = d( p ) / cs d( q ) = d( q )*cs else if( d( p )>=d( q ) ) then - call stdlib_daxpy( m, -t*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) - call stdlib_daxpy( m, cs*sn*apoaq,a( 1, p ), 1,& - a( 1, q ), 1 ) + call stdlib${ii}$_daxpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,& + a( 1_${ik}$, q ), 1_${ik}$ ) d( p ) = d( p )*cs d( q ) = d( q ) / cs if( rsvec ) then - call stdlib_daxpy( mvl,-t*aqoap,v( 1, q ), 1,& - v( 1, p ), 1 ) - call stdlib_daxpy( mvl,cs*sn*apoaq,v( 1, p ),& - 1,v( 1, q ), 1 ) + call stdlib${ii}$_daxpy( mvl,-t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,& + v( 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ),& + 1_${ik}$,v( 1_${ik}$, q ), 1_${ik}$ ) end if else - call stdlib_daxpy( m, t*apoaq,a( 1, p ), 1,a( 1,& - q ), 1 ) - call stdlib_daxpy( m,-cs*sn*aqoap,a( 1, q ), 1,& - a( 1, p ), 1 ) + call stdlib${ii}$_daxpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$,& + q ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( m,-cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,& + a( 1_${ik}$, p ), 1_${ik}$ ) d( p ) = d( p ) / cs d( q ) = d( q )*cs if( rsvec ) then - call stdlib_daxpy( mvl,t*apoaq, v( 1, p ),1, & - v( 1, q ), 1 ) - call stdlib_daxpy( mvl,-cs*sn*aqoap,v( 1, q )& - , 1,v( 1, p ), 1 ) + call stdlib${ii}$_daxpy( mvl,t*apoaq, v( 1_${ik}$, p ),1_${ik}$, & + v( 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q )& + , 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if end if end if @@ -46685,28 +46685,28 @@ module stdlib_linalg_lapack_d end if else if( aapp>aaqq ) then - call stdlib_dcopy( m, a( 1, p ), 1, work,1 ) - call stdlib_dlascl( 'G', 0, 0, aapp, one,m, 1, work, lda,& + call stdlib${ii}$_dcopy( m, a( 1_${ik}$, p ), 1_${ik}$, work,1_${ik}$ ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, work, lda,& ierr ) - call stdlib_dlascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) temp1 = -aapq*d( p ) / d( q ) - call stdlib_daxpy( m, temp1, work, 1,a( 1, q ), 1 ) + call stdlib${ii}$_daxpy( m, temp1, work, 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) - call stdlib_dlascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) else - call stdlib_dcopy( m, a( 1, q ), 1, work,1 ) - call stdlib_dlascl( 'G', 0, 0, aaqq, one,m, 1, work, lda,& + call stdlib${ii}$_dcopy( m, a( 1_${ik}$, q ), 1_${ik}$, work,1_${ik}$ ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, work, lda,& ierr ) - call stdlib_dlascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) temp1 = -aapq*d( q ) / d( p ) - call stdlib_daxpy( m, temp1, work, 1,a( 1, p ), 1 ) + call stdlib${ii}$_daxpy( m, temp1, work, 1_${ik}$,a( 1_${ik}$, p ), 1_${ik}$ ) - call stdlib_dlascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, one, aapp,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) sva( p ) = aapp*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) @@ -46715,46 +46715,46 @@ module stdlib_linalg_lapack_d ! end if rotok then ... else ! in the case of cancellation in updating sva(q) ! .. recompute sva(q) - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_dnrm2( m, a( 1, q ), 1 )*d( q ) + sva( q ) = stdlib${ii}$_dnrm2( m, a( 1_${ik}$, q ), 1_${ik}$ )*d( q ) else t = zero aaqq = one - call stdlib_dlassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_dlassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq )*d( q ) end if end if - if( ( aapp / aapp0 )**2<=rooteps ) then + if( ( aapp / aapp0 )**2_${ik}$<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_dnrm2( m, a( 1, p ), 1 )*d( p ) + aapp = stdlib${ii}$_dnrm2( m, a( 1_${ik}$, p ), 1_${ik}$ )*d( p ) else t = zero aapp = one - call stdlib_dlassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_dlassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp )*d( p ) end if sva( p ) = aapp end if ! end of ok rotation else - notrot = notrot + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if else - notrot = notrot + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if if( ( i<=swband ) .and. ( ijblsk>=blskip ) )then sva( p ) = aapp - notrot = 0 + notrot = 0_${ik}$ go to 2011 end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then aapp = -aapp - notrot = 0 + notrot = 0_${ik}$ go to 2203 end if end do loop_2200 @@ -46762,8 +46762,8 @@ module stdlib_linalg_lapack_d 2203 continue sva( p ) = aapp else - if( aapp==zero )notrot = notrot +min( jgl+kbl-1, n ) - jgl + 1 - if( aapprootsfmin ) )then - sva( n ) = stdlib_dnrm2( m, a( 1, n ), 1 )*d( n ) + sva( n ) = stdlib${ii}$_dnrm2( m, a( 1_${ik}$, n ), 1_${ik}$ )*d( n ) else t = zero aapp = one - call stdlib_dlassq( m, a( 1, n ), 1, t, aapp ) + call stdlib${ii}$_dlassq( m, a( 1_${ik}$, n ), 1_${ik}$, t, aapp ) sva( n ) = t*sqrt( aapp )*d( n ) end if ! additional steering devices @@ -46796,17 +46796,17 @@ module stdlib_linalg_lapack_d ! end i=1:nsweep loop ! #:) reaching this point means that the procedure has completed the given ! number of iterations. - info = nsweep - 1 + info = nsweep - 1_${ik}$ go to 1995 1994 continue ! #:) reaching this point means that during the i-th sweep all pivots were ! below the given tolerance, causing early exit. - info = 0 + info = 0_${ik}$ ! #:) info = 0 confirms successful iterations. 1995 continue ! sort the vector d. do p = 1, n - 1 - q = stdlib_idamax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib${ii}$_idamax( n-p+1, sva( p ), 1_${ik}$ ) + p - 1_${ik}$ if( p/=q ) then temp1 = sva( p ) sva( p ) = sva( q ) @@ -46814,15 +46814,15 @@ module stdlib_linalg_lapack_d temp1 = d( p ) d( p ) = d( q ) d( q ) = temp1 - call stdlib_dswap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_dswap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) + call stdlib${ii}$_dswap( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) + if( rsvec )call stdlib${ii}$_dswap( mvl, v( 1_${ik}$, p ), 1_${ik}$, v( 1_${ik}$, q ), 1_${ik}$ ) end if end do return - end subroutine stdlib_dgsvj0 + end subroutine stdlib${ii}$_dgsvj0 - pure subroutine stdlib_dgsvj1( jobv, m, n, n1, a, lda, d, sva, mv, v, ldv,eps, sfmin, tol, & + pure subroutine stdlib${ii}$_dgsvj1( jobv, m, n, n1, a, lda, d, sva, mv, v, ldv,eps, sfmin, tol, & !! DGSVJ1 is called from DGESVJ as a pre-processor and that is its main !! purpose. It applies Jacobi rotations in the same way as DGESVJ does, but !! it targets only particular pivots and it does not check convergence @@ -46853,8 +46853,8 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(dp), intent(in) :: eps, sfmin, tol - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldv, lwork, m, mv, n, n1, nsweep + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldv, lwork, m, mv, n, n1, nsweep character, intent(in) :: jobv ! Array Arguments real(dp), intent(inout) :: a(lda,*), d(n), sva(n), v(ldv,*) @@ -46865,11 +46865,11 @@ module stdlib_linalg_lapack_d real(dp) :: aapp, aapp0, aapq, aaqq, apoaq, aqoap, big, bigtheta, cs, large, mxaapq, & mxsinj, rootbig, rooteps, rootsfmin, roottol, small, sn, t, temp1, theta, & thsign - integer(ilp) :: blskip, emptsw, i, ibr, igl, ierr, ijblsk, iswrot, jbc, jgl, kbl, mvl, & + integer(${ik}$) :: blskip, emptsw, i, ibr, igl, ierr, ijblsk, iswrot, jbc, jgl, kbl, mvl, & notrot, nblc, nblr, p, pskipped, q, rowskip, swband logical(lk) :: applv, rotok, rsvec ! Local Arrays - real(dp) :: fastr(5) + real(dp) :: fastr(5_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,real,min,sign,sqrt ! Executable Statements @@ -46877,31 +46877,31 @@ module stdlib_linalg_lapack_d applv = stdlib_lsame( jobv, 'A' ) rsvec = stdlib_lsame( jobv, 'V' ) if( .not.( rsvec .or. applv .or. stdlib_lsame( jobv, 'N' ) ) ) then - info = -1 - else if( m<0 ) then - info = -2 - else if( ( n<0 ) .or. ( n>m ) ) then - info = -3 - else if( n1<0 ) then - info = -4 + info = -1_${ik}$ + else if( m<0_${ik}$ ) then + info = -2_${ik}$ + else if( ( n<0_${ik}$ ) .or. ( n>m ) ) then + info = -3_${ik}$ + else if( n1<0_${ik}$ ) then + info = -4_${ik}$ else if( ldazero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2200: do q = jgl, min( jgl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -46977,13 +46977,13 @@ module stdlib_linalg_lapack_d rotok = ( small*aaqq )<=aapp end if if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_ddot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& + aapq = ( stdlib${ii}$_ddot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*d( p )& *d( q ) / aaqq )/ aapp else - call stdlib_dcopy( m, a( 1, p ), 1, work, 1 ) - call stdlib_dlascl( 'G', 0, 0, aapp, d( p ),m, 1, work, lda,& + call stdlib${ii}$_dcopy( m, a( 1_${ik}$, p ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, d( p ),m, 1_${ik}$, work, lda,& ierr ) - aapq = stdlib_ddot( m, work, 1, a( 1, q ),1 )*d( q ) / & + aapq = stdlib${ii}$_ddot( m, work, 1_${ik}$, a( 1_${ik}$, q ),1_${ik}$ )*d( q ) / & aaqq end if else @@ -46993,23 +46993,23 @@ module stdlib_linalg_lapack_d rotok = aaqq<=( aapp / small ) end if if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_ddot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& + aapq = ( stdlib${ii}$_ddot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*d( p )& *d( q ) / aaqq )/ aapp else - call stdlib_dcopy( m, a( 1, q ), 1, work, 1 ) - call stdlib_dlascl( 'G', 0, 0, aaqq, d( q ),m, 1, work, lda,& + call stdlib${ii}$_dcopy( m, a( 1_${ik}$, q ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, d( q ),m, 1_${ik}$, work, lda,& ierr ) - aapq = stdlib_ddot( m, work, 1, a( 1, p ),1 )*d( p ) / & + aapq = stdlib${ii}$_ddot( m, work, 1_${ik}$, a( 1_${ik}$, p ),1_${ik}$ )*d( p ) / & aapp end if end if mxaapq = max( mxaapq, abs( aapq ) ) ! to rotate or not to rotate, that is the question ... if( abs( aapq )>tol ) then - notrot = 0 + notrot = 0_${ik}$ ! rotated = rotated + 1 - pskipped = 0 - iswrot = iswrot + 1 + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ if( rotok ) then aqoap = aaqq / aapp apoaq = aapp / aaqq @@ -47017,12 +47017,12 @@ module stdlib_linalg_lapack_d if( aaqq>aapp0 )theta = -theta if( abs( theta )>bigtheta ) then t = half / theta - fastr( 3 ) = t*d( p ) / d( q ) - fastr( 4 ) = -t*d( q ) / d( p ) - call stdlib_drotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) + fastr( 3_${ik}$ ) = t*d( p ) / d( q ) + fastr( 4_${ik}$ ) = -t*d( q ) / d( p ) + call stdlib${ii}$_drotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$, fastr ) - if( rsvec )call stdlib_drotm( mvl,v( 1, p ), 1,v( 1, q ),& - 1,fastr ) + if( rsvec )call stdlib${ii}$_drotm( mvl,v( 1_${ik}$, p ), 1_${ik}$,v( 1_${ik}$, q ),& + 1_${ik}$,fastr ) sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq ) ) @@ -47043,68 +47043,68 @@ module stdlib_linalg_lapack_d aqoap = d( q ) / d( p ) if( d( p )>=one ) then if( d( q )>=one ) then - fastr( 3 ) = t*apoaq - fastr( 4 ) = -t*aqoap + fastr( 3_${ik}$ ) = t*apoaq + fastr( 4_${ik}$ ) = -t*aqoap d( p ) = d( p )*cs d( q ) = d( q )*cs - call stdlib_drotm( m, a( 1, p ), 1,a( 1, q ), 1,& + call stdlib${ii}$_drotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$,& fastr ) - if( rsvec )call stdlib_drotm( mvl,v( 1, p ), 1, v( & - 1, q ),1, fastr ) + if( rsvec )call stdlib${ii}$_drotm( mvl,v( 1_${ik}$, p ), 1_${ik}$, v( & + 1_${ik}$, q ),1_${ik}$, fastr ) else - call stdlib_daxpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & - p ), 1 ) - call stdlib_daxpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & - 1, q ), 1 ) + call stdlib${ii}$_daxpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( 1_${ik}$, & + p ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( & + 1_${ik}$, q ), 1_${ik}$ ) if( rsvec ) then - call stdlib_daxpy( mvl, -t*aqoap,v( 1, q ), 1,v(& - 1, p ), 1 ) - call stdlib_daxpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& - v( 1, q ), 1 ) + call stdlib${ii}$_daxpy( mvl, -t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,v(& + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ), 1_${ik}$,& + v( 1_${ik}$, q ), 1_${ik}$ ) end if d( p ) = d( p )*cs d( q ) = d( q ) / cs end if else if( d( q )>=one ) then - call stdlib_daxpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & - ), 1 ) - call stdlib_daxpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) + call stdlib${ii}$_daxpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q & + ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( m, -cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) if( rsvec ) then - call stdlib_daxpy( mvl, t*apoaq,v( 1, p ), 1,v( & - 1, q ), 1 ) - call stdlib_daxpy( mvl,-cs*sn*aqoap,v( 1, q ), & - 1,v( 1, p ), 1 ) + call stdlib${ii}$_daxpy( mvl, t*apoaq,v( 1_${ik}$, p ), 1_${ik}$,v( & + 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q ), & + 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if d( p ) = d( p ) / cs d( q ) = d( q )*cs else if( d( p )>=d( q ) ) then - call stdlib_daxpy( m, -t*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) - call stdlib_daxpy( m, cs*sn*apoaq,a( 1, p ), 1,& - a( 1, q ), 1 ) + call stdlib${ii}$_daxpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,& + a( 1_${ik}$, q ), 1_${ik}$ ) d( p ) = d( p )*cs d( q ) = d( q ) / cs if( rsvec ) then - call stdlib_daxpy( mvl,-t*aqoap,v( 1, q ), 1,& - v( 1, p ), 1 ) - call stdlib_daxpy( mvl,cs*sn*apoaq,v( 1, p ),& - 1,v( 1, q ), 1 ) + call stdlib${ii}$_daxpy( mvl,-t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,& + v( 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ),& + 1_${ik}$,v( 1_${ik}$, q ), 1_${ik}$ ) end if else - call stdlib_daxpy( m, t*apoaq,a( 1, p ), 1,a( 1,& - q ), 1 ) - call stdlib_daxpy( m,-cs*sn*aqoap,a( 1, q ), 1,& - a( 1, p ), 1 ) + call stdlib${ii}$_daxpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$,& + q ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( m,-cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,& + a( 1_${ik}$, p ), 1_${ik}$ ) d( p ) = d( p ) / cs d( q ) = d( q )*cs if( rsvec ) then - call stdlib_daxpy( mvl,t*apoaq, v( 1, p ),1, & - v( 1, q ), 1 ) - call stdlib_daxpy( mvl,-cs*sn*aqoap,v( 1, q )& - , 1,v( 1, p ), 1 ) + call stdlib${ii}$_daxpy( mvl,t*apoaq, v( 1_${ik}$, p ),1_${ik}$, & + v( 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q )& + , 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if end if end if @@ -47112,28 +47112,28 @@ module stdlib_linalg_lapack_d end if else if( aapp>aaqq ) then - call stdlib_dcopy( m, a( 1, p ), 1, work,1 ) - call stdlib_dlascl( 'G', 0, 0, aapp, one,m, 1, work, lda,& + call stdlib${ii}$_dcopy( m, a( 1_${ik}$, p ), 1_${ik}$, work,1_${ik}$ ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, work, lda,& ierr ) - call stdlib_dlascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) temp1 = -aapq*d( p ) / d( q ) - call stdlib_daxpy( m, temp1, work, 1,a( 1, q ), 1 ) + call stdlib${ii}$_daxpy( m, temp1, work, 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) - call stdlib_dlascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) else - call stdlib_dcopy( m, a( 1, q ), 1, work,1 ) - call stdlib_dlascl( 'G', 0, 0, aaqq, one,m, 1, work, lda,& + call stdlib${ii}$_dcopy( m, a( 1_${ik}$, q ), 1_${ik}$, work,1_${ik}$ ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, work, lda,& ierr ) - call stdlib_dlascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) temp1 = -aapq*d( q ) / d( p ) - call stdlib_daxpy( m, temp1, work, 1,a( 1, p ), 1 ) + call stdlib${ii}$_daxpy( m, temp1, work, 1_${ik}$,a( 1_${ik}$, p ), 1_${ik}$ ) - call stdlib_dlascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, one, aapp,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) sva( p ) = aapp*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) @@ -47142,48 +47142,48 @@ module stdlib_linalg_lapack_d ! end if rotok then ... else ! in the case of cancellation in updating sva(q) ! .. recompute sva(q) - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_dnrm2( m, a( 1, q ), 1 )*d( q ) + sva( q ) = stdlib${ii}$_dnrm2( m, a( 1_${ik}$, q ), 1_${ik}$ )*d( q ) else t = zero aaqq = one - call stdlib_dlassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_dlassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq )*d( q ) end if end if - if( ( aapp / aapp0 )**2<=rooteps ) then + if( ( aapp / aapp0 )**2_${ik}$<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_dnrm2( m, a( 1, p ), 1 )*d( p ) + aapp = stdlib${ii}$_dnrm2( m, a( 1_${ik}$, p ), 1_${ik}$ )*d( p ) else t = zero aapp = one - call stdlib_dlassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_dlassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp )*d( p ) end if sva( p ) = aapp end if ! end of ok rotation else - notrot = notrot + 1 + notrot = notrot + 1_${ik}$ ! skipped = skipped + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if else - notrot = notrot + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if ! if ( notrot >= emptsw ) go to 2011 if( ( i<=swband ) .and. ( ijblsk>=blskip ) )then sva( p ) = aapp - notrot = 0 + notrot = 0_${ik}$ go to 2011 end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then aapp = -aapp - notrot = 0 + notrot = 0_${ik}$ go to 2203 end if end do loop_2200 @@ -47191,8 +47191,8 @@ module stdlib_linalg_lapack_d 2203 continue sva( p ) = aapp else - if( aapp==zero )notrot = notrot +min( jgl+kbl-1, n ) - jgl + 1 - if( aapp= emptsw ) go to 2011 end if end do loop_2100 @@ -47209,11 +47209,11 @@ module stdlib_linalg_lapack_d ! 2000 :: end of the ibr-loop ! .. update sva(n) if( ( sva( n )rootsfmin ) )then - sva( n ) = stdlib_dnrm2( m, a( 1, n ), 1 )*d( n ) + sva( n ) = stdlib${ii}$_dnrm2( m, a( 1_${ik}$, n ), 1_${ik}$ )*d( n ) else t = zero aapp = one - call stdlib_dlassq( m, a( 1, n ), 1, t, aapp ) + call stdlib${ii}$_dlassq( m, a( 1_${ik}$, n ), 1_${ik}$, t, aapp ) sva( n ) = t*sqrt( aapp )*d( n ) end if ! additional steering devices @@ -47227,17 +47227,17 @@ module stdlib_linalg_lapack_d ! end i=1:nsweep loop ! #:) reaching this point means that the procedure has completed the given ! number of sweeps. - info = nsweep - 1 + info = nsweep - 1_${ik}$ go to 1995 1994 continue ! #:) reaching this point means that during the i-th sweep all pivots were ! below the given threshold, causing early exit. - info = 0 + info = 0_${ik}$ ! #:) info = 0 confirms successful iterations. 1995 continue ! sort the vector d do p = 1, n - 1 - q = stdlib_idamax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib${ii}$_idamax( n-p+1, sva( p ), 1_${ik}$ ) + p - 1_${ik}$ if( p/=q ) then temp1 = sva( p ) sva( p ) = sva( q ) @@ -47245,15 +47245,15 @@ module stdlib_linalg_lapack_d temp1 = d( p ) d( p ) = d( q ) d( q ) = temp1 - call stdlib_dswap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_dswap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) + call stdlib${ii}$_dswap( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) + if( rsvec )call stdlib${ii}$_dswap( mvl, v( 1_${ik}$, p ), 1_${ik}$, v( 1_${ik}$, q ), 1_${ik}$ ) end if end do return - end subroutine stdlib_dgsvj1 + end subroutine stdlib${ii}$_dgsvj1 - pure subroutine stdlib_dgtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond,work, iwork, info & + pure subroutine stdlib${ii}$_dgtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond,work, iwork, info & !! DGTCON estimates the reciprocal of the condition number of a real !! tridiagonal matrix A using the LU factorization as computed by !! DGTTRF. @@ -47265,41 +47265,41 @@ module stdlib_linalg_lapack_d ! -- 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) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(dp), intent(in) :: anorm real(dp), 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(dp), intent(in) :: d(*), dl(*), du(*), du2(*) real(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: onenrm - integer(ilp) :: i, kase, kase1 + integer(${ik}$) :: i, kase, kase1 real(dp) :: ainvnm ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Executable Statements ! test the input arguments. - info = 0 + info = 0_${ik}$ onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' ) if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then - info = -1 - else if( n<0 ) then - info = -2 + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ else if( anormeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_dgttrs( trans, n, 1, dlf, df, duf, du2, ipiv,work( n+1 ), n, info ) + call stdlib${ii}$_dgttrs( trans, n, 1_${ik}$, dlf, df, duf, du2, ipiv,work( n+1 ), n, info ) - call stdlib_daxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) + call stdlib${ii}$_daxpy( 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 @@ -47505,14 +47505,14 @@ module stdlib_linalg_lapack_d work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1 end if end do - kase = 0 + kase = 0_${ik}$ 70 continue - call stdlib_dlacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) + call stdlib${ii}$_dlacn2( 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_dgttrs( transt, n, 1, dlf, df, duf, du2, ipiv,work( n+1 ), n, & + call stdlib${ii}$_dgttrs( transt, n, 1_${ik}$, dlf, df, duf, du2, ipiv,work( n+1 ), n, & info ) do i = 1, n work( n+i ) = work( i )*work( n+i ) @@ -47522,7 +47522,7 @@ module stdlib_linalg_lapack_d do i = 1, n work( n+i ) = work( i )*work( n+i ) end do - call stdlib_dgttrs( transn, n, 1, dlf, df, duf, du2, ipiv,work( n+1 ), n, & + call stdlib${ii}$_dgttrs( transn, n, 1_${ik}$, dlf, df, duf, du2, ipiv,work( n+1 ), n, & info ) end if go to 70 @@ -47535,10 +47535,10 @@ module stdlib_linalg_lapack_d if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_110 return - end subroutine stdlib_dgtrfs + end subroutine stdlib${ii}$_dgtrfs - pure subroutine stdlib_dgtsvx( fact, trans, n, nrhs, dl, d, du, dlf, df, duf,du2, ipiv, b, & + pure subroutine stdlib${ii}$_dgtsvx( fact, trans, n, nrhs, dl, d, du, dlf, df, duf,du2, ipiv, b, & !! DGTSVX uses the LU factorization to compute the solution to a real !! system of linear equations A * X = B or A**T * X = B, !! where A is a tridiagonal matrix of order N and X and B are N-by-NRHS @@ -47551,12 +47551,12 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: fact, trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs real(dp), intent(out) :: rcond ! Array Arguments - integer(ilp), intent(inout) :: ipiv(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(inout) :: ipiv(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(in) :: b(ldb,*), d(*), dl(*), du(*) real(dp), intent(out) :: berr(*), ferr(*), work(*), x(ldx,*) real(dp), intent(inout) :: df(*), dlf(*), du2(*), duf(*) @@ -47569,37 +47569,37 @@ module stdlib_linalg_lapack_d ! Intrinsic Functions intrinsic :: max ! Executable Statements - info = 0 + info = 0_${ik}$ nofact = stdlib_lsame( fact, 'N' ) notran = stdlib_lsame( trans, 'N' ) if( .not.nofact .and. .not.stdlib_lsame( fact, 'F' ) ) 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 - else if( n<0 ) then - info = -3 - else if( nrhs<0 ) then - info = -4 - else if( ldb1 ) then - call stdlib_dcopy( n-1, dl, 1, dlf, 1 ) - call stdlib_dcopy( n-1, du, 1, duf, 1 ) + call stdlib${ii}$_dcopy( n, d, 1_${ik}$, df, 1_${ik}$ ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_dcopy( n-1, dl, 1_${ik}$, dlf, 1_${ik}$ ) + call stdlib${ii}$_dcopy( n-1, du, 1_${ik}$, duf, 1_${ik}$ ) end if - call stdlib_dgttrf( n, dlf, df, duf, du2, ipiv, info ) + call stdlib${ii}$_dgttrf( n, dlf, df, duf, du2, ipiv, info ) ! return if info is non-zero. - if( info>0 )then + if( info>0_${ik}$ )then rcond = zero return end if @@ -47610,24 +47610,24 @@ module stdlib_linalg_lapack_d else norm = 'I' end if - anorm = stdlib_dlangt( norm, n, dl, d, du ) + anorm = stdlib${ii}$_dlangt( norm, n, dl, d, du ) ! compute the reciprocal of the condition number of a. - call stdlib_dgtcon( norm, n, dlf, df, duf, du2, ipiv, anorm, rcond, work,iwork, info ) + call stdlib${ii}$_dgtcon( norm, n, dlf, df, duf, du2, ipiv, anorm, rcond, work,iwork, info ) ! compute the solution vectors x. - call stdlib_dlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_dgttrs( trans, n, nrhs, dlf, df, duf, du2, ipiv, x, ldx,info ) + call stdlib${ii}$_dlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_dgttrs( trans, n, nrhs, dlf, df, duf, du2, ipiv, x, ldx,info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_dgtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv,b, ldb, x, ldx, & + call stdlib${ii}$_dgtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv,b, ldb, x, ldx, & ferr, berr, work, iwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcondn .or. ihi ilo )temp = temp + abs ( t( j - 1, j ) ) + temp = abs ( t( j, j + 1_${ik}$ ) ) + if ( j > ilo )temp = temp + abs ( t( j - 1_${ik}$, j ) ) if( abs( t( j, j ) )=ilast ) then go to 80 else - ifirst = jch + 1 + ifirst = jch + 1_${ik}$ go to 110 end if end if @@ -47920,24 +47920,24 @@ module stdlib_linalg_lapack_d ! then process as in the case t(ilast,ilast)=0 do jch = j, ilast - 1 temp = t( jch, jch+1 ) - call stdlib_dlartg( temp, t( jch+1, jch+1 ), c, s,t( jch, jch+1 ) ) + call stdlib${ii}$_dlartg( temp, t( jch+1, jch+1 ), c, s,t( jch, jch+1 ) ) t( jch+1, jch+1 ) = zero - if( jch abs( (wr2/s2)*t( & ilast, ilast )- h( ilast, ilast ) ) ) then @@ -48066,12 +48066,12 @@ module stdlib_linalg_lapack_d ! initial q temp = s1*h( istart, istart ) - wr*t( istart, istart ) temp2 = s1*h( istart+1, istart ) - call stdlib_dlartg( temp, temp2, c, s, tempr ) + call stdlib${ii}$_dlartg( temp, temp2, c, s, tempr ) ! sweep loop_190: do j = istart, ilast - 1 if( j>istart ) then temp = h( j, j-1 ) - call stdlib_dlartg( temp, h( j+1, j-1 ), c, s, h( j, j-1 ) ) + call stdlib${ii}$_dlartg( temp, h( j+1, j-1 ), c, s, h( j, j-1 ) ) h( j+1, j-1 ) = zero end if do jc = j, ilastm @@ -48090,7 +48090,7 @@ module stdlib_linalg_lapack_d end do end if temp = t( j+1, j+1 ) - call stdlib_dlartg( temp, t( j+1, j ), c, s, t( j+1, j+1 ) ) + call stdlib${ii}$_dlartg( temp, t( j+1, j ), c, s, t( j+1, j+1 ) ) t( j+1, j ) = zero do jr = ifrstm, min( j+2, ilast ) temp = c*h( jr, j+1 ) + s*h( jr, j ) @@ -48123,7 +48123,7 @@ module stdlib_linalg_lapack_d ! ( b11 0 ) ! b = ( ) with b11 non-negative. ! ( 0 b22 ) - call stdlib_dlasv2( t( ilast-1, ilast-1 ), t( ilast-1, ilast ),t( ilast, ilast ),& + call stdlib${ii}$_dlasv2( t( ilast-1, ilast-1 ), t( ilast-1, ilast ),t( ilast, ilast ),& b22, b11, sr, cr, sl, cl ) if( b11abs( c21 )+abs( c22r )+abs( c22i ) ) & then - t1 = stdlib_dlapy3( c12, c11r, c11i ) + t1 = stdlib${ii}$_dlapy3( c12, c11r, c11i ) cz = c12 / t1 szr = -c11r / t1 szi = -c11i / t1 else - cz = stdlib_dlapy2( c22r, c22i ) + cz = stdlib${ii}$_dlapy2( c22r, c22i ) if( cz<=safmin ) then cz = zero szr = one @@ -48199,7 +48199,7 @@ module stdlib_linalg_lapack_d else tempr = c22r / cz tempi = c22i / cz - t1 = stdlib_dlapy2( cz, c21 ) + t1 = stdlib${ii}$_dlapy2( cz, c21 ) cz = cz / t1 szr = -c21*tempr / t1 szi = c21*tempi / t1 @@ -48221,7 +48221,7 @@ module stdlib_linalg_lapack_d a1i = szi*a12 a2r = cz*a21 + szr*a22 a2i = szi*a22 - cq = stdlib_dlapy2( a1r, a1i ) + cq = stdlib${ii}$_dlapy2( a1r, a1i ) if( cq<=safmin ) then cq = zero sqr = one @@ -48233,7 +48233,7 @@ module stdlib_linalg_lapack_d sqi = tempi*a2r - tempr*a2i end if end if - t1 = stdlib_dlapy3( cq, sqr, sqi ) + t1 = stdlib${ii}$_dlapy3( cq, sqr, sqi ) cq = cq / t1 sqr = sqr / t1 sqi = sqi / t1 @@ -48242,10 +48242,10 @@ module stdlib_linalg_lapack_d tempi = sqr*szi + sqi*szr b1r = cq*cz*b11 + tempr*b22 b1i = tempi*b22 - b1a = stdlib_dlapy2( b1r, b1i ) + b1a = stdlib${ii}$_dlapy2( b1r, b1i ) b2r = cq*cz*b22 + tempr*b11 b2i = -tempi*b11 - b2a = stdlib_dlapy2( b2r, b2i ) + b2a = stdlib${ii}$_dlapy2( b2r, b2i ) ! normalize so beta > 0, and im( alpha1 ) > 0 beta( ilast-1 ) = b1a beta( ilast ) = b2a @@ -48254,10 +48254,10 @@ module stdlib_linalg_lapack_d alphar( ilast ) = ( wr*b2a )*s1inv alphai( ilast ) = -( wi*b2a )*s1inv ! step 3: go to next block -- exit if finished. - ilast = ifirst - 1 + ilast = ifirst - 1_${ik}$ if( ilastistart ) then - v( 1 ) = h( j, j-1 ) - v( 2 ) = h( j+1, j-1 ) - v( 3 ) = h( j+2, j-1 ) - call stdlib_dlarfg( 3, h( j, j-1 ), v( 2 ), 1, tau ) - v( 1 ) = one + v( 1_${ik}$ ) = h( j, j-1 ) + v( 2_${ik}$ ) = h( j+1, j-1 ) + v( 3_${ik}$ ) = h( j+2, j-1 ) + call stdlib${ii}$_dlarfg( 3_${ik}$, h( j, j-1 ), v( 2_${ik}$ ), 1_${ik}$, tau ) + v( 1_${ik}$ ) = one h( j+1, j-1 ) = zero h( j+2, j-1 ) = zero end if do jc = j, ilastm - temp = tau*( h( j, jc )+v( 2 )*h( j+1, jc )+v( 3 )*h( j+2, jc ) ) + temp = tau*( h( j, jc )+v( 2_${ik}$ )*h( j+1, jc )+v( 3_${ik}$ )*h( j+2, jc ) ) h( j, jc ) = h( j, jc ) - temp - h( j+1, jc ) = h( j+1, jc ) - temp*v( 2 ) - h( j+2, jc ) = h( j+2, jc ) - temp*v( 3 ) - temp2 = tau*( t( j, jc )+v( 2 )*t( j+1, jc )+v( 3 )*t( j+2, jc ) ) + h( j+1, jc ) = h( j+1, jc ) - temp*v( 2_${ik}$ ) + h( j+2, jc ) = h( j+2, jc ) - temp*v( 3_${ik}$ ) + temp2 = tau*( t( j, jc )+v( 2_${ik}$ )*t( j+1, jc )+v( 3_${ik}$ )*t( j+2, jc ) ) t( j, jc ) = t( j, jc ) - temp2 - t( j+1, jc ) = t( j+1, jc ) - temp2*v( 2 ) - t( j+2, jc ) = t( j+2, jc ) - temp2*v( 3 ) + t( j+1, jc ) = t( j+1, jc ) - temp2*v( 2_${ik}$ ) + t( j+2, jc ) = t( j+2, jc ) - temp2*v( 3_${ik}$ ) end do if( ilq ) then do jr = 1, n - temp = tau*( q( jr, j )+v( 2 )*q( jr, j+1 )+v( 3 )*q( jr, j+2 ) ) + temp = tau*( q( jr, j )+v( 2_${ik}$ )*q( jr, j+1 )+v( 3_${ik}$ )*q( jr, j+2 ) ) q( jr, j ) = q( jr, j ) - temp - q( jr, j+1 ) = q( jr, j+1 ) - temp*v( 2 ) - q( jr, j+2 ) = q( jr, j+2 ) - temp*v( 3 ) + q( jr, j+1 ) = q( jr, j+1 ) - temp*v( 2_${ik}$ ) + q( jr, j+2 ) = q( jr, j+2 ) - temp*v( 3_${ik}$ ) end do end if ! zero j-th column of b (see dlagbc for details) ! swap rows to pivot - ilpivt = .false. + ${ik}$ivt = .false. temp = max( abs( t( j+1, j+1 ) ), abs( t( j+1, j+2 ) ) ) temp2 = max( abs( t( j+2, j+1 ) ), abs( t( j+2, j+2 ) ) ) if( max( temp, temp2 )abs( w11 ) ) then - ilpivt = .true. + ${ik}$ivt = .true. temp = w12 temp2 = w22 w12 = w11 @@ -48381,38 +48381,38 @@ module stdlib_linalg_lapack_d u2 = ( scale*u2 ) / w22 u1 = ( scale*u1-w12*u2 ) / w11 250 continue - if( ilpivt ) then + if( ${ik}$ivt ) then temp = u2 u2 = u1 u1 = temp end if ! compute householder vector - t1 = sqrt( scale**2+u1**2+u2**2 ) + t1 = sqrt( scale**2_${ik}$+u1**2_${ik}$+u2**2_${ik}$ ) tau = one + scale / t1 vs = -one / ( scale+t1 ) - v( 1 ) = one - v( 2 ) = vs*u1 - v( 3 ) = vs*u2 + v( 1_${ik}$ ) = one + v( 2_${ik}$ ) = vs*u1 + v( 3_${ik}$ ) = vs*u2 ! apply transformations from the right. do jr = ifrstm, min( j+3, ilast ) - temp = tau*( h( jr, j )+v( 2 )*h( jr, j+1 )+v( 3 )*h( jr, j+2 ) ) + temp = tau*( h( jr, j )+v( 2_${ik}$ )*h( jr, j+1 )+v( 3_${ik}$ )*h( jr, j+2 ) ) h( jr, j ) = h( jr, j ) - temp - h( jr, j+1 ) = h( jr, j+1 ) - temp*v( 2 ) - h( jr, j+2 ) = h( jr, j+2 ) - temp*v( 3 ) + h( jr, j+1 ) = h( jr, j+1 ) - temp*v( 2_${ik}$ ) + h( jr, j+2 ) = h( jr, j+2 ) - temp*v( 3_${ik}$ ) end do do jr = ifrstm, j + 2 - temp = tau*( t( jr, j )+v( 2 )*t( jr, j+1 )+v( 3 )*t( jr, j+2 ) ) + temp = tau*( t( jr, j )+v( 2_${ik}$ )*t( jr, j+1 )+v( 3_${ik}$ )*t( jr, j+2 ) ) t( jr, j ) = t( jr, j ) - temp - t( jr, j+1 ) = t( jr, j+1 ) - temp*v( 2 ) - t( jr, j+2 ) = t( jr, j+2 ) - temp*v( 3 ) + t( jr, j+1 ) = t( jr, j+1 ) - temp*v( 2_${ik}$ ) + t( jr, j+2 ) = t( jr, j+2 ) - temp*v( 3_${ik}$ ) end do if( ilz ) then do jr = 1, n - temp = tau*( z( jr, j )+v( 2 )*z( jr, j+1 )+v( 3 )*z( jr, j+2 ) ) + temp = tau*( z( jr, j )+v( 2_${ik}$ )*z( jr, j+1 )+v( 3_${ik}$ )*z( jr, j+2 ) ) z( jr, j ) = z( jr, j ) - temp - z( jr, j+1 ) = z( jr, j+1 ) - temp*v( 2 ) - z( jr, j+2 ) = z( jr, j+2 ) - temp*v( 3 ) + z( jr, j+1 ) = z( jr, j+1 ) - temp*v( 2_${ik}$ ) + z( jr, j+2 ) = z( jr, j+2 ) - temp*v( 3_${ik}$ ) end do end if t( j+1, j ) = zero @@ -48420,9 +48420,9 @@ module stdlib_linalg_lapack_d end do loop_290 ! last elements: use givens rotations ! rotations from the left - j = ilast - 1 + j = ilast - 1_${ik}$ temp = h( j, j-1 ) - call stdlib_dlartg( temp, h( j+1, j-1 ), c, s, h( j, j-1 ) ) + call stdlib${ii}$_dlartg( temp, h( j+1, j-1 ), c, s, h( j, j-1 ) ) h( j+1, j-1 ) = zero do jc = j, ilastm temp = c*h( j, jc ) + s*h( j+1, jc ) @@ -48441,7 +48441,7 @@ module stdlib_linalg_lapack_d end if ! rotations from the right. temp = t( j+1, j+1 ) - call stdlib_dlartg( temp, t( j+1, j ), c, s, t( j+1, j+1 ) ) + call stdlib${ii}$_dlartg( temp, t( j+1, j ), c, s, t( j+1, j+1 ) ) t( j+1, j ) = zero do jr = ifrstm, ilast temp = c*h( jr, j+1 ) + s*h( jr, j ) @@ -48494,15 +48494,15 @@ module stdlib_linalg_lapack_d beta( j ) = t( j, j ) end do ! normal termination - info = 0 + info = 0_${ik}$ ! exit (other than argument error) -- return optimal workspace size 420 continue - work( 1 ) = real( n,KIND=dp) + work( 1_${ik}$ ) = real( n,KIND=dp) return - end subroutine stdlib_dhgeqz + end subroutine stdlib${ii}$_dhgeqz - pure subroutine stdlib_dlabrd( m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y,ldy ) + pure subroutine stdlib${ii}$_dlabrd( m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y,ldy ) !! DLABRD reduces the first NB rows and columns of a real general !! m by n matrix A to upper or lower bidiagonal form by an orthogonal !! transformation Q**T * A * P, and returns the matrices X and Y which @@ -48514,14 +48514,14 @@ module stdlib_linalg_lapack_d ! -- 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, ldx, ldy, m, n, nb + integer(${ik}$), intent(in) :: lda, ldx, ldy, m, n, nb ! Array Arguments real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: d(*), e(*), taup(*), tauq(*), x(ldx,*), y(ldy,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -48531,108 +48531,108 @@ module stdlib_linalg_lapack_d ! reduce to upper bidiagonal form loop_10: do i = 1, nb ! update a(i:m,i) - call stdlib_dgemv( 'NO TRANSPOSE', m-i+1, i-1, -one, a( i, 1 ),lda, y( i, 1 ), & - ldy, one, a( i, i ), 1 ) - call stdlib_dgemv( 'NO TRANSPOSE', m-i+1, i-1, -one, x( i, 1 ),ldx, a( 1, i ), 1,& - one, a( i, i ), 1 ) + call stdlib${ii}$_dgemv( 'NO TRANSPOSE', m-i+1, i-1, -one, a( i, 1_${ik}$ ),lda, y( i, 1_${ik}$ ), & + ldy, one, a( i, i ), 1_${ik}$ ) + call stdlib${ii}$_dgemv( 'NO TRANSPOSE', m-i+1, i-1, -one, x( i, 1_${ik}$ ),ldx, a( 1_${ik}$, i ), 1_${ik}$,& + one, a( i, i ), 1_${ik}$ ) ! generate reflection q(i) to annihilate a(i+1:m,i) - call stdlib_dlarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,tauq( i ) ) + call stdlib${ii}$_dlarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,tauq( i ) ) d( i ) = a( i, i ) if( i= half*ov ) then aa = half * aa @@ -48689,18 +48689,18 @@ module stdlib_linalg_lapack_d s = s * be end if if( abs( d )<=abs( c ) ) then - call stdlib_dladiv1(aa, bb, cc, dd, p, q) + call stdlib${ii}$_dladiv1(aa, bb, cc, dd, p, q) else - call stdlib_dladiv1(bb, aa, dd, cc, p, q) + call stdlib${ii}$_dladiv1(bb, aa, dd, cc, p, q) q = -q end if p = p * s q = q * s return - end subroutine stdlib_dladiv + end subroutine stdlib${ii}$_dladiv - pure subroutine stdlib_dlaed4( n, i, d, z, delta, rho, dlam, info ) + pure subroutine stdlib${ii}$_dlaed4( n, i, d, z, delta, rho, dlam, info ) !! This subroutine computes the I-th updated eigenvalue of a symmetric !! rank-one modification to a diagonal matrix whose elements are !! given in the array d, and that @@ -48715,8 +48715,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(out) :: dlam real(dp), intent(in) :: rho ! Array Arguments @@ -48724,41 +48724,41 @@ module stdlib_linalg_lapack_d real(dp), intent(out) :: delta(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: maxit = 30 + integer(${ik}$), parameter :: maxit = 30_${ik}$ ! Local Scalars logical(lk) :: orgati, swtch, swtch3 - integer(ilp) :: ii, iim1, iip1, ip1, iter, j, niter + integer(${ik}$) :: ii, iim1, iip1, ip1, iter, j, niter real(dp) :: a, b, c, del, dltlb, dltub, dphi, dpsi, dw, eps, erretm, eta, midpt, phi, & prew, psi, rhoinv, tau, temp, temp1, w ! Local Arrays - real(dp) :: zz(3) + real(dp) :: 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 + info = 0_${ik}$ + if( n==1_${ik}$ ) then ! presumably, i=1 upon entry - dlam = d( 1 ) + rho*z( 1 )*z( 1 ) - delta( 1 ) = one + dlam = d( 1_${ik}$ ) + rho*z( 1_${ik}$ )*z( 1_${ik}$ ) + delta( 1_${ik}$ ) = one return end if - if( n==2 ) then - call stdlib_dlaed5( i, d, z, delta, rho, dlam ) + if( n==2_${ik}$ ) then + call stdlib${ii}$_dlaed5( i, d, z, delta, rho, dlam ) return end if ! compute machine epsilon - eps = stdlib_dlamch( 'EPSILON' ) + eps = stdlib${ii}$_dlamch( 'EPSILON' ) rhoinv = one / rho ! 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 midpt = rho / two ! if ||z||_2 is not one, then temp should be set to @@ -48836,7 +48836,7 @@ module stdlib_linalg_lapack_d dltub = min( dltub, tau ) end if ! calculate the new step - niter = niter + 1 + niter = niter + 1_${ik}$ c = w - delta( n-1 )*dpsi - delta( n )*dphi a = ( delta( n-1 )+delta( n ) )*w -delta( n-1 )*delta( n )*( dpsi+dphi ) b = delta( n-1 )*delta( n )*w @@ -48887,7 +48887,7 @@ module stdlib_linalg_lapack_d 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 @@ -48946,14 +48946,14 @@ module stdlib_linalg_lapack_d w = rhoinv + phi + psi end do loop_90 ! return with info = 1, niter = maxit and not converged - info = 1 + info = 1_${ik}$ dlam = d( i ) + tau go to 250 ! 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 del = d( ip1 ) - d( i ) midpt = del / two @@ -49009,10 +49009,10 @@ module stdlib_linalg_lapack_d if( orgati ) then ii = i else - ii = i + 1 + ii = i + 1_${ik}$ end if - iim1 = ii - 1 - iip1 = ii + 1 + iim1 = ii - 1_${ik}$ + iip1 = ii + 1_${ik}$ ! evaluate psi and the derivative dpsi dpsi = zero psi = zero @@ -49042,7 +49042,7 @@ module stdlib_linalg_lapack_d 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 ) / delta( ii ) dw = dpsi + dphi + temp*temp temp = z( ii )*temp @@ -49064,14 +49064,14 @@ module stdlib_linalg_lapack_d dltub = min( dltub, tau ) end if ! calculate the new step - niter = niter + 1 + niter = niter + 1_${ik}$ if( .not.swtch3 ) then if( orgati ) then c = w - delta( ip1 )*dw - ( d( i )-d( ip1 ) )*( z( i ) / delta( i ) )& - **2 + **2_${ik}$ else c = w - delta( i )*dw - ( d( ip1 )-d( i ) )*( z( ip1 ) / delta( ip1 ) )& - **2 + **2_${ik}$ end if a = ( delta( i )+delta( ip1 ) )*w -delta( i )*delta( ip1 )*dw b = delta( i )*delta( ip1 )*w @@ -49096,17 +49096,17 @@ module stdlib_linalg_lapack_d temp1 = z( iim1 ) / delta( iim1 ) temp1 = temp1*temp1 c = temp - delta( iip1 )*( dpsi+dphi ) -( d( iim1 )-d( iip1 ) )*temp1 - zz( 1 ) = z( iim1 )*z( iim1 ) - zz( 3 ) = delta( iip1 )*delta( iip1 )*( ( dpsi-temp1 )+dphi ) + zz( 1_${ik}$ ) = z( iim1 )*z( iim1 ) + zz( 3_${ik}$ ) = delta( iip1 )*delta( iip1 )*( ( dpsi-temp1 )+dphi ) else temp1 = z( iip1 ) / delta( iip1 ) temp1 = temp1*temp1 c = temp - delta( iim1 )*( dpsi+dphi ) -( d( iip1 )-d( iim1 ) )*temp1 - zz( 1 ) = delta( iim1 )*delta( iim1 )*( dpsi+( dphi-temp1 ) ) - zz( 3 ) = z( iip1 )*z( iip1 ) + zz( 1_${ik}$ ) = delta( iim1 )*delta( iim1 )*( dpsi+( dphi-temp1 ) ) + zz( 3_${ik}$ ) = z( iip1 )*z( iip1 ) end if - zz( 2 ) = z( ii )*z( ii ) - call stdlib_dlaed6( niter, orgati, c, delta( iim1 ), zz, w, eta,info ) + zz( 2_${ik}$ ) = z( ii )*z( ii ) + call stdlib${ii}$_dlaed6( niter, orgati, c, delta( iim1 ), zz, w, eta,info ) if( info/=0 )go to 250 end if ! note, eta should be positive if w is negative, and @@ -49161,7 +49161,7 @@ module stdlib_linalg_lapack_d end if tau = tau + eta ! main loop to update the values of the array delta - iter = niter + 1 + iter = niter + 1_${ik}$ loop_240: do niter = iter, maxit ! test for convergence if( abs( w )<=eps*erretm ) then @@ -49182,10 +49182,10 @@ module stdlib_linalg_lapack_d if( .not.swtch ) then if( orgati ) then c = w - delta( ip1 )*dw -( d( i )-d( ip1 ) )*( z( i ) / delta( i ) )& - **2 + **2_${ik}$ else c = w - delta( i )*dw - ( d( ip1 )-d( i ) )*( z( ip1 ) / delta( ip1 ) )& - **2 + **2_${ik}$ end if else temp = z( ii ) / delta( ii ) @@ -49223,26 +49223,26 @@ module stdlib_linalg_lapack_d temp = rhoinv + psi + phi if( swtch ) then c = temp - delta( iim1 )*dpsi - delta( iip1 )*dphi - zz( 1 ) = delta( iim1 )*delta( iim1 )*dpsi - zz( 3 ) = delta( iip1 )*delta( iip1 )*dphi + zz( 1_${ik}$ ) = delta( iim1 )*delta( iim1 )*dpsi + zz( 3_${ik}$ ) = delta( iip1 )*delta( iip1 )*dphi else if( orgati ) then temp1 = z( iim1 ) / delta( iim1 ) temp1 = temp1*temp1 c = temp - delta( iip1 )*( dpsi+dphi ) -( d( iim1 )-d( iip1 ) )& *temp1 - zz( 1 ) = z( iim1 )*z( iim1 ) - zz( 3 ) = delta( iip1 )*delta( iip1 )*( ( dpsi-temp1 )+dphi ) + zz( 1_${ik}$ ) = z( iim1 )*z( iim1 ) + zz( 3_${ik}$ ) = delta( iip1 )*delta( iip1 )*( ( dpsi-temp1 )+dphi ) else temp1 = z( iip1 ) / delta( iip1 ) temp1 = temp1*temp1 c = temp - delta( iim1 )*( dpsi+dphi ) -( d( iip1 )-d( iim1 ) )& *temp1 - zz( 1 ) = delta( iim1 )*delta( iim1 )*( dpsi+( dphi-temp1 ) ) - zz( 3 ) = z( iip1 )*z( iip1 ) + zz( 1_${ik}$ ) = delta( iim1 )*delta( iim1 )*( dpsi+( dphi-temp1 ) ) + zz( 3_${ik}$ ) = z( iip1 )*z( iip1 ) end if end if - call stdlib_dlaed6( niter, orgati, c, delta( iim1 ), zz, w, eta,info ) + call stdlib${ii}$_dlaed6( niter, orgati, c, delta( iim1 ), zz, w, eta,info ) if( info/=0 )go to 250 end if ! note, eta should be positive if w is negative, and @@ -49293,7 +49293,7 @@ module stdlib_linalg_lapack_d if( w*prew>zero .and. abs( w )>abs( prew ) / ten )swtch = .not.swtch end do loop_240 ! return with info = 1, niter = maxit and not converged - info = 1 + info = 1_${ik}$ if( orgati ) then dlam = d( i ) + tau else @@ -49302,10 +49302,10 @@ module stdlib_linalg_lapack_d end if 250 continue return - end subroutine stdlib_dlaed4 + end subroutine stdlib${ii}$_dlaed4 - pure subroutine stdlib_dlaed8( icompq, k, n, qsiz, d, q, ldq, indxq, rho,cutpnt, z, dlamda, & + pure subroutine stdlib${ii}$_dlaed8( icompq, k, n, qsiz, d, q, ldq, indxq, rho,cutpnt, z, dlamda, & !! DLAED8 merges the two sets of eigenvalues 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 @@ -49317,62 +49317,62 @@ module stdlib_linalg_lapack_d ! -- 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) :: cutpnt, icompq, ldq, ldq2, n, qsiz - integer(ilp), intent(out) :: givptr, info, k + integer(${ik}$), intent(in) :: cutpnt, icompq, ldq, ldq2, n, qsiz + integer(${ik}$), intent(out) :: givptr, info, k real(dp), intent(inout) :: rho ! Array Arguments - integer(ilp), intent(out) :: givcol(2,*), indx(*), indxp(*), perm(*) - integer(ilp), intent(inout) :: indxq(*) + integer(${ik}$), intent(out) :: givcol(2_${ik}$,*), indx(*), indxp(*), perm(*) + integer(${ik}$), intent(inout) :: indxq(*) real(dp), intent(inout) :: d(*), q(ldq,*), z(*) - real(dp), intent(out) :: dlamda(*), givnum(2,*), q2(ldq2,*), w(*) + real(dp), intent(out) :: dlamda(*), givnum(2_${ik}$,*), q2(ldq2,*), w(*) ! ===================================================================== ! Parameters real(dp), parameter :: mone = -1.0_dp ! Local Scalars - integer(ilp) :: i, imax, j, jlam, jmax, jp, k2, n1, n1p1, n2 + integer(${ik}$) :: i, imax, j, jlam, jmax, jp, k2, n1, n1p1, n2 real(dp) :: c, eps, s, t, tau, tol ! Intrinsic Functions intrinsic :: abs,max,min,sqrt ! Executable Statements ! test the input parameters. - info = 0 - if( icompq<0 .or. icompq>1 ) then - info = -1 - else if( n<0 ) then - info = -3 - else if( icompq==1 .and. qsizn ) then - info = -10 - else if( ldq21_${ik}$ ) then + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( icompq==1_${ik}$ .and. qsizn ) then + info = -10_${ik}$ + else if( ldq2n )go to 100 if( rho*abs( z( j ) )<=tol ) then ! deflate due to small z component. - k2 = k2 - 1 + k2 = k2 - 1_${ik}$ indxp( k2 ) = j else ! check if eigenvalues are close enough to allow deflation. @@ -49443,7 +49443,7 @@ module stdlib_linalg_lapack_d c = z( j ) ! find sqrt(a**2+b**2) without overflow or ! destructive underflow. - tau = stdlib_dlapy2( c, s ) + tau = stdlib${ii}$_dlapy2( c, s ) t = d( j ) - d( jlam ) c = c / tau s = -s / tau @@ -49452,26 +49452,26 @@ module stdlib_linalg_lapack_d z( j ) = tau z( jlam ) = zero ! record the appropriate givens rotation - givptr = givptr + 1 - givcol( 1, givptr ) = indxq( indx( jlam ) ) - givcol( 2, givptr ) = indxq( indx( j ) ) - givnum( 1, givptr ) = c - givnum( 2, givptr ) = s - if( icompq==1 ) then - call stdlib_drot( qsiz, q( 1, indxq( indx( jlam ) ) ), 1,q( 1, indxq( indx( j & - ) ) ), 1, c, s ) + givptr = givptr + 1_${ik}$ + givcol( 1_${ik}$, givptr ) = indxq( indx( jlam ) ) + givcol( 2_${ik}$, givptr ) = indxq( indx( j ) ) + givnum( 1_${ik}$, givptr ) = c + givnum( 2_${ik}$, givptr ) = s + if( icompq==1_${ik}$ ) then + call stdlib${ii}$_drot( qsiz, q( 1_${ik}$, indxq( indx( jlam ) ) ), 1_${ik}$,q( 1_${ik}$, indxq( indx( j & + ) ) ), 1_${ik}$, c, s ) end if t = d( jlam )*c*c + d( j )*s*s d( j ) = d( jlam )*s*s + d( j )*c*c d( jlam ) = t - k2 = k2 - 1 - i = 1 + k2 = k2 - 1_${ik}$ + i = 1_${ik}$ 90 continue if( k2+i<=n ) then if( d( jlam )max( 1, k ) ) then - info = -2 - else if( max( 1, kstop )max( 1, k ) )then - info = -3 + info = 0_${ik}$ + if( k<0_${ik}$ ) then + info = -1_${ik}$ + else if( kstart<1_${ik}$ .or. kstart>max( 1_${ik}$, k ) ) then + info = -2_${ik}$ + else if( max( 1_${ik}$, kstop )max( 1_${ik}$, k ) )then + info = -3_${ik}$ else if( n=growto*scale )go to 120 ! choose new orthogonal starting vector and try again. temp = eps3 / ( rootn+one ) - vr( 1 ) = eps3 + vr( 1_${ik}$ ) = eps3 do i = 2, n vr( i ) = temp end do vr( n-its+1 ) = vr( n-its+1 ) - eps3*rootn end do ! failure to find eigenvector in n iterations. - info = 1 + info = 1_${ik}$ 120 continue ! normalize eigenvector. - i = stdlib_idamax( n, vr, 1 ) - call stdlib_dscal( n, one / abs( vr( i ) ), vr, 1 ) + i = stdlib${ii}$_idamax( n, vr, 1_${ik}$ ) + call stdlib${ii}$_dscal( n, one / abs( vr( i ) ), vr, 1_${ik}$ ) else ! complex eigenvalue. if( noinit ) then @@ -49779,23 +49779,23 @@ module stdlib_linalg_lapack_d end do else ! scale supplied initial vector. - norm = stdlib_dlapy2( stdlib_dnrm2( n, vr, 1 ), stdlib_dnrm2( n, vi, 1 ) ) + norm = stdlib${ii}$_dlapy2( stdlib${ii}$_dnrm2( n, vr, 1_${ik}$ ), stdlib${ii}$_dnrm2( n, vi, 1_${ik}$ ) ) rec = ( eps3*rootn ) / max( norm, nrmsml ) - call stdlib_dscal( n, rec, vr, 1 ) - call stdlib_dscal( n, rec, vi, 1 ) + call stdlib${ii}$_dscal( n, rec, vr, 1_${ik}$ ) + call stdlib${ii}$_dscal( n, rec, vi, 1_${ik}$ ) end if if( rightv ) then ! lu decomposition with partial pivoting of b, replacing zero ! pivots by eps3. ! the imaginary part of the (i,j)-th element of u is stored in ! b(j+1,i). - b( 2, 1 ) = -wi + b( 2_${ik}$, 1_${ik}$ ) = -wi do i = 2, n - b( i+1, 1 ) = zero + b( i+1, 1_${ik}$ ) = zero end do loop_170: do i = 1, n - 1 - absbii = stdlib_dlapy2( b( i, i ), b( i+1, i ) ) + absbii = stdlib${ii}$_dlapy2( b( i, i ), b( i+1, i ) ) ei = h( i+1, i ) if( absbiivcrit ) then rec = one / vmax - call stdlib_dscal( n, rec, vr, 1 ) - call stdlib_dscal( n, rec, vi, 1 ) + call stdlib${ii}$_dscal( n, rec, vr, 1_${ik}$ ) + call stdlib${ii}$_dscal( n, rec, vi, 1_${ik}$ ) scale = scale*rec vmax = one vcrit = bignum @@ -49927,8 +49927,8 @@ module stdlib_linalg_lapack_d w1 = abs( xr ) + abs( xi ) if( w1>w*bignum ) then rec = one / w1 - call stdlib_dscal( n, rec, vr, 1 ) - call stdlib_dscal( n, rec, vi, 1 ) + call stdlib${ii}$_dscal( n, rec, vr, 1_${ik}$ ) + call stdlib${ii}$_dscal( n, rec, vi, 1_${ik}$ ) xr = vr( i ) xi = vi( i ) scale = scale*rec @@ -49936,7 +49936,7 @@ module stdlib_linalg_lapack_d end if end if ! divide by diagonal element of b. - call stdlib_dladiv( xr, xi, b( i, i ), b( i+1, i ), vr( i ),vi( i ) ) + call stdlib${ii}$_dladiv( xr, xi, b( i, i ), b( i+1, i ), vr( i ),vi( i ) ) vmax = max( abs( vr( i ) )+abs( vi( i ) ), vmax ) vcrit = bignum / vmax @@ -49953,12 +49953,12 @@ module stdlib_linalg_lapack_d end if end do loop_250 ! test for sufficient growth in the norm of (vr,vi). - vnorm = stdlib_dasum( n, vr, 1 ) + stdlib_dasum( n, vi, 1 ) + vnorm = stdlib${ii}$_dasum( n, vr, 1_${ik}$ ) + stdlib${ii}$_dasum( n, vi, 1_${ik}$ ) if( vnorm>=growto*scale )go to 280 ! choose a new orthogonal starting vector and try again. y = eps3 / ( rootn+one ) - vr( 1 ) = eps3 - vi( 1 ) = zero + vr( 1_${ik}$ ) = eps3 + vi( 1_${ik}$ ) = zero do i = 2, n vr( i ) = y vi( i ) = zero @@ -49966,21 +49966,21 @@ module stdlib_linalg_lapack_d vr( n-its+1 ) = vr( n-its+1 ) - eps3*rootn end do loop_270 ! failure to find eigenvector in n iterations - info = 1 + info = 1_${ik}$ 280 continue ! normalize eigenvector. vnorm = zero do i = 1, n vnorm = max( vnorm, abs( vr( i ) )+abs( vi( i ) ) ) end do - call stdlib_dscal( n, one / vnorm, vr, 1 ) - call stdlib_dscal( n, one / vnorm, vi, 1 ) + call stdlib${ii}$_dscal( n, one / vnorm, vr, 1_${ik}$ ) + call stdlib${ii}$_dscal( n, one / vnorm, vi, 1_${ik}$ ) end if return - end subroutine stdlib_dlaein + end subroutine stdlib${ii}$_dlaein - pure subroutine stdlib_dlagv2( a, lda, b, ldb, alphar, alphai, beta, csl, snl,csr, snr ) + pure subroutine stdlib${ii}$_dlagv2( a, lda, b, ldb, alphar, alphai, beta, csl, snl,csr, snr ) !! DLAGV2 computes the Generalized Schur factorization of a real 2-by-2 !! matrix pencil (A,B) where B is upper triangular. This routine !! computes orthogonal (rotation) matrices given by CSL, SNL and CSR, @@ -50003,11 +50003,11 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(out) :: csl, csr, snl, snr ! Array Arguments real(dp), intent(inout) :: a(lda,*), b(ldb,*) - real(dp), intent(out) :: alphai(2), alphar(2), beta(2) + real(dp), intent(out) :: alphai(2_${ik}$), alphar(2_${ik}$), beta(2_${ik}$) ! ===================================================================== ! Local Scalars @@ -50016,135 +50016,135 @@ module stdlib_linalg_lapack_d ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements - safmin = stdlib_dlamch( 'S' ) - ulp = stdlib_dlamch( 'P' ) + safmin = stdlib${ii}$_dlamch( 'S' ) + ulp = stdlib${ii}$_dlamch( 'P' ) ! 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 - a( 1, 1 ) = ascale*a( 1, 1 ) - a( 1, 2 ) = ascale*a( 1, 2 ) - a( 2, 1 ) = ascale*a( 2, 1 ) - a( 2, 2 ) = ascale*a( 2, 2 ) + a( 1_${ik}$, 1_${ik}$ ) = ascale*a( 1_${ik}$, 1_${ik}$ ) + a( 1_${ik}$, 2_${ik}$ ) = ascale*a( 1_${ik}$, 2_${ik}$ ) + a( 2_${ik}$, 1_${ik}$ ) = ascale*a( 2_${ik}$, 1_${ik}$ ) + a( 2_${ik}$, 2_${ik}$ ) = ascale*a( 2_${ik}$, 2_${ik}$ ) ! scale b - bnorm = max( abs( b( 1, 1 ) ), abs( b( 1, 2 ) )+abs( b( 2, 2 ) ),safmin ) + bnorm = max( abs( b( 1_${ik}$, 1_${ik}$ ) ), abs( b( 1_${ik}$, 2_${ik}$ ) )+abs( b( 2_${ik}$, 2_${ik}$ ) ),safmin ) bscale = one / bnorm - b( 1, 1 ) = bscale*b( 1, 1 ) - b( 1, 2 ) = bscale*b( 1, 2 ) - b( 2, 2 ) = bscale*b( 2, 2 ) + b( 1_${ik}$, 1_${ik}$ ) = bscale*b( 1_${ik}$, 1_${ik}$ ) + b( 1_${ik}$, 2_${ik}$ ) = bscale*b( 1_${ik}$, 2_${ik}$ ) + b( 2_${ik}$, 2_${ik}$ ) = bscale*b( 2_${ik}$, 2_${ik}$ ) ! check if a can be deflated - if( abs( a( 2, 1 ) )<=ulp ) then + if( abs( a( 2_${ik}$, 1_${ik}$ ) )<=ulp ) then csl = one snl = zero csr = one snr = zero - a( 2, 1 ) = zero - b( 2, 1 ) = zero + a( 2_${ik}$, 1_${ik}$ ) = zero + b( 2_${ik}$, 1_${ik}$ ) = zero wi = zero ! check if b is singular - else if( abs( b( 1, 1 ) )<=ulp ) then - call stdlib_dlartg( a( 1, 1 ), a( 2, 1 ), csl, snl, r ) + else if( abs( b( 1_${ik}$, 1_${ik}$ ) )<=ulp ) then + call stdlib${ii}$_dlartg( a( 1_${ik}$, 1_${ik}$ ), a( 2_${ik}$, 1_${ik}$ ), csl, snl, r ) csr = one snr = zero - call stdlib_drot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl ) - call stdlib_drot( 2, b( 1, 1 ), ldb, b( 2, 1 ), ldb, csl, snl ) - a( 2, 1 ) = zero - b( 1, 1 ) = zero - b( 2, 1 ) = zero + call stdlib${ii}$_drot( 2_${ik}$, a( 1_${ik}$, 1_${ik}$ ), lda, a( 2_${ik}$, 1_${ik}$ ), lda, csl, snl ) + call stdlib${ii}$_drot( 2_${ik}$, b( 1_${ik}$, 1_${ik}$ ), ldb, b( 2_${ik}$, 1_${ik}$ ), ldb, csl, snl ) + a( 2_${ik}$, 1_${ik}$ ) = zero + b( 1_${ik}$, 1_${ik}$ ) = zero + b( 2_${ik}$, 1_${ik}$ ) = zero wi = zero - else if( abs( b( 2, 2 ) )<=ulp ) then - call stdlib_dlartg( a( 2, 2 ), a( 2, 1 ), csr, snr, t ) + else if( abs( b( 2_${ik}$, 2_${ik}$ ) )<=ulp ) then + call stdlib${ii}$_dlartg( a( 2_${ik}$, 2_${ik}$ ), a( 2_${ik}$, 1_${ik}$ ), csr, snr, t ) snr = -snr - call stdlib_drot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr ) - call stdlib_drot( 2, b( 1, 1 ), 1, b( 1, 2 ), 1, csr, snr ) + call stdlib${ii}$_drot( 2_${ik}$, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, a( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, csr, snr ) + call stdlib${ii}$_drot( 2_${ik}$, b( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, b( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, csr, snr ) csl = one snl = zero - a( 2, 1 ) = zero - b( 2, 1 ) = zero - b( 2, 2 ) = zero + a( 2_${ik}$, 1_${ik}$ ) = zero + b( 2_${ik}$, 1_${ik}$ ) = zero + b( 2_${ik}$, 2_${ik}$ ) = zero wi = zero else ! b is nonsingular, first compute the eigenvalues of (a,b) - call stdlib_dlag2( a, lda, b, ldb, safmin, scale1, scale2, wr1, wr2,wi ) + call stdlib${ii}$_dlag2( a, lda, b, ldb, safmin, scale1, scale2, wr1, wr2,wi ) if( wi==zero ) then ! two real eigenvalues, compute s*a-w*b - h1 = scale1*a( 1, 1 ) - wr1*b( 1, 1 ) - h2 = scale1*a( 1, 2 ) - wr1*b( 1, 2 ) - h3 = scale1*a( 2, 2 ) - wr1*b( 2, 2 ) - rr = stdlib_dlapy2( h1, h2 ) - qq = stdlib_dlapy2( scale1*a( 2, 1 ), h3 ) + h1 = scale1*a( 1_${ik}$, 1_${ik}$ ) - wr1*b( 1_${ik}$, 1_${ik}$ ) + h2 = scale1*a( 1_${ik}$, 2_${ik}$ ) - wr1*b( 1_${ik}$, 2_${ik}$ ) + h3 = scale1*a( 2_${ik}$, 2_${ik}$ ) - wr1*b( 2_${ik}$, 2_${ik}$ ) + rr = stdlib${ii}$_dlapy2( h1, h2 ) + qq = stdlib${ii}$_dlapy2( scale1*a( 2_${ik}$, 1_${ik}$ ), h3 ) if( rr>qq ) then ! find right rotation matrix to zero 1,1 element of ! (sa - wb) - call stdlib_dlartg( h2, h1, csr, snr, t ) + call stdlib${ii}$_dlartg( h2, h1, csr, snr, t ) else ! find right rotation matrix to zero 2,1 element of ! (sa - wb) - call stdlib_dlartg( h3, scale1*a( 2, 1 ), csr, snr, t ) + call stdlib${ii}$_dlartg( h3, scale1*a( 2_${ik}$, 1_${ik}$ ), csr, snr, t ) end if snr = -snr - call stdlib_drot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr ) - call stdlib_drot( 2, b( 1, 1 ), 1, b( 1, 2 ), 1, csr, snr ) + call stdlib${ii}$_drot( 2_${ik}$, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, a( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, csr, snr ) + call stdlib${ii}$_drot( 2_${ik}$, b( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, b( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, csr, snr ) ! compute inf norms of a and b - h1 = max( abs( a( 1, 1 ) )+abs( a( 1, 2 ) ),abs( a( 2, 1 ) )+abs( a( 2, 2 ) ) ) + h1 = max( abs( a( 1_${ik}$, 1_${ik}$ ) )+abs( a( 1_${ik}$, 2_${ik}$ ) ),abs( a( 2_${ik}$, 1_${ik}$ ) )+abs( a( 2_${ik}$, 2_${ik}$ ) ) ) - h2 = max( abs( b( 1, 1 ) )+abs( b( 1, 2 ) ),abs( b( 2, 1 ) )+abs( b( 2, 2 ) ) ) + h2 = max( abs( b( 1_${ik}$, 1_${ik}$ ) )+abs( b( 1_${ik}$, 2_${ik}$ ) ),abs( b( 2_${ik}$, 1_${ik}$ ) )+abs( b( 2_${ik}$, 2_${ik}$ ) ) ) if( ( scale1*h1 )>=abs( wr1 )*h2 ) then ! find left rotation matrix q to zero out b(2,1) - call stdlib_dlartg( b( 1, 1 ), b( 2, 1 ), csl, snl, r ) + call stdlib${ii}$_dlartg( b( 1_${ik}$, 1_${ik}$ ), b( 2_${ik}$, 1_${ik}$ ), csl, snl, r ) else ! find left rotation matrix q to zero out a(2,1) - call stdlib_dlartg( a( 1, 1 ), a( 2, 1 ), csl, snl, r ) + call stdlib${ii}$_dlartg( a( 1_${ik}$, 1_${ik}$ ), a( 2_${ik}$, 1_${ik}$ ), csl, snl, r ) end if - call stdlib_drot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl ) - call stdlib_drot( 2, b( 1, 1 ), ldb, b( 2, 1 ), ldb, csl, snl ) - a( 2, 1 ) = zero - b( 2, 1 ) = zero + call stdlib${ii}$_drot( 2_${ik}$, a( 1_${ik}$, 1_${ik}$ ), lda, a( 2_${ik}$, 1_${ik}$ ), lda, csl, snl ) + call stdlib${ii}$_drot( 2_${ik}$, b( 1_${ik}$, 1_${ik}$ ), ldb, b( 2_${ik}$, 1_${ik}$ ), ldb, csl, snl ) + a( 2_${ik}$, 1_${ik}$ ) = zero + b( 2_${ik}$, 1_${ik}$ ) = zero else ! a pair of complex conjugate eigenvalues ! first compute the svd of the matrix b - call stdlib_dlasv2( b( 1, 1 ), b( 1, 2 ), b( 2, 2 ), r, t, snr,csr, snl, csl ) + call stdlib${ii}$_dlasv2( b( 1_${ik}$, 1_${ik}$ ), b( 1_${ik}$, 2_${ik}$ ), b( 2_${ik}$, 2_${ik}$ ), r, t, snr,csr, snl, csl ) ! form (a,b) := q(a,b)z**t where q is left rotation matrix and - ! z is right rotation matrix computed from stdlib_dlasv2 - call stdlib_drot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl ) - call stdlib_drot( 2, b( 1, 1 ), ldb, b( 2, 1 ), ldb, csl, snl ) - call stdlib_drot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr ) - call stdlib_drot( 2, b( 1, 1 ), 1, b( 1, 2 ), 1, csr, snr ) - b( 2, 1 ) = zero - b( 1, 2 ) = zero + ! z is right rotation matrix computed from stdlib${ii}$_dlasv2 + call stdlib${ii}$_drot( 2_${ik}$, a( 1_${ik}$, 1_${ik}$ ), lda, a( 2_${ik}$, 1_${ik}$ ), lda, csl, snl ) + call stdlib${ii}$_drot( 2_${ik}$, b( 1_${ik}$, 1_${ik}$ ), ldb, b( 2_${ik}$, 1_${ik}$ ), ldb, csl, snl ) + call stdlib${ii}$_drot( 2_${ik}$, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, a( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, csr, snr ) + call stdlib${ii}$_drot( 2_${ik}$, b( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, b( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, csr, snr ) + b( 2_${ik}$, 1_${ik}$ ) = zero + b( 1_${ik}$, 2_${ik}$ ) = zero end if end if ! unscaling - a( 1, 1 ) = anorm*a( 1, 1 ) - a( 2, 1 ) = anorm*a( 2, 1 ) - a( 1, 2 ) = anorm*a( 1, 2 ) - a( 2, 2 ) = anorm*a( 2, 2 ) - b( 1, 1 ) = bnorm*b( 1, 1 ) - b( 2, 1 ) = bnorm*b( 2, 1 ) - b( 1, 2 ) = bnorm*b( 1, 2 ) - b( 2, 2 ) = bnorm*b( 2, 2 ) + a( 1_${ik}$, 1_${ik}$ ) = anorm*a( 1_${ik}$, 1_${ik}$ ) + a( 2_${ik}$, 1_${ik}$ ) = anorm*a( 2_${ik}$, 1_${ik}$ ) + a( 1_${ik}$, 2_${ik}$ ) = anorm*a( 1_${ik}$, 2_${ik}$ ) + a( 2_${ik}$, 2_${ik}$ ) = anorm*a( 2_${ik}$, 2_${ik}$ ) + b( 1_${ik}$, 1_${ik}$ ) = bnorm*b( 1_${ik}$, 1_${ik}$ ) + b( 2_${ik}$, 1_${ik}$ ) = bnorm*b( 2_${ik}$, 1_${ik}$ ) + b( 1_${ik}$, 2_${ik}$ ) = bnorm*b( 1_${ik}$, 2_${ik}$ ) + b( 2_${ik}$, 2_${ik}$ ) = bnorm*b( 2_${ik}$, 2_${ik}$ ) if( wi==zero ) then - alphar( 1 ) = a( 1, 1 ) - alphar( 2 ) = a( 2, 2 ) - alphai( 1 ) = zero - alphai( 2 ) = zero - beta( 1 ) = b( 1, 1 ) - beta( 2 ) = b( 2, 2 ) - else - alphar( 1 ) = anorm*wr1 / scale1 / bnorm - alphai( 1 ) = anorm*wi / scale1 / bnorm - alphar( 2 ) = alphar( 1 ) - alphai( 2 ) = -alphai( 1 ) - beta( 1 ) = one - beta( 2 ) = one + alphar( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ ) + alphar( 2_${ik}$ ) = a( 2_${ik}$, 2_${ik}$ ) + alphai( 1_${ik}$ ) = zero + alphai( 2_${ik}$ ) = zero + beta( 1_${ik}$ ) = b( 1_${ik}$, 1_${ik}$ ) + beta( 2_${ik}$ ) = b( 2_${ik}$, 2_${ik}$ ) + else + alphar( 1_${ik}$ ) = anorm*wr1 / scale1 / bnorm + alphai( 1_${ik}$ ) = anorm*wi / scale1 / bnorm + alphar( 2_${ik}$ ) = alphar( 1_${ik}$ ) + alphai( 2_${ik}$ ) = -alphai( 1_${ik}$ ) + beta( 1_${ik}$ ) = one + beta( 2_${ik}$ ) = one end if return - end subroutine stdlib_dlagv2 + end subroutine stdlib${ii}$_dlagv2 - pure subroutine stdlib_dlahr2( n, k, nb, a, lda, tau, t, ldt, y, ldy ) + pure subroutine stdlib${ii}$_dlahr2( n, k, nb, a, lda, tau, t, ldt, y, ldy ) !! DLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1) !! matrix A so that elements below the k-th subdiagonal are zero. The !! reduction is performed by an orthogonal similarity transformation @@ -50155,14 +50155,14 @@ module stdlib_linalg_lapack_d ! -- 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) :: k, lda, ldt, ldy, n, nb + integer(${ik}$), intent(in) :: k, lda, ldt, ldy, n, nb ! Array Arguments real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: t(ldt,nb), tau(nb), y(ldy,nb) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i real(dp) :: ei ! Intrinsic Functions intrinsic :: min @@ -50170,69 +50170,69 @@ module stdlib_linalg_lapack_d ! quick return if possible if( n<=1 )return loop_10: do i = 1, nb - if( i>1 ) then + if( i>1_${ik}$ ) then ! update a(k+1:n,i) ! update i-th column of a - y * v**t - call stdlib_dgemv( 'NO TRANSPOSE', n-k, i-1, -one, y(k+1,1), ldy,a( k+i-1, 1 ), & - lda, one, a( k+1, i ), 1 ) + call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n-k, i-1, -one, y(k+1,1_${ik}$), ldy,a( k+i-1, 1_${ik}$ ), & + lda, one, a( k+1, i ), 1_${ik}$ ) ! apply i - v * t**t * v**t to this column (call it b) from the ! left, using the last column of t as workspace ! let v = ( v1 ) and b = ( b1 ) (first i-1 rows) ! ( v2 ) ( b2 ) ! where v1 is unit lower triangular ! w := v1**t * b1 - call stdlib_dcopy( i-1, a( k+1, i ), 1, t( 1, nb ), 1 ) - call stdlib_dtrmv( 'LOWER', 'TRANSPOSE', 'UNIT',i-1, a( k+1, 1 ),lda, t( 1, nb ),& - 1 ) + call stdlib${ii}$_dcopy( i-1, a( k+1, i ), 1_${ik}$, t( 1_${ik}$, nb ), 1_${ik}$ ) + call stdlib${ii}$_dtrmv( 'LOWER', 'TRANSPOSE', 'UNIT',i-1, a( k+1, 1_${ik}$ ),lda, t( 1_${ik}$, nb ),& + 1_${ik}$ ) ! w := w + v2**t * b2 - call stdlib_dgemv( 'TRANSPOSE', n-k-i+1, i-1,one, a( k+i, 1 ),lda, a( k+i, i ), & - 1, one, t( 1, nb ), 1 ) + call stdlib${ii}$_dgemv( 'TRANSPOSE', n-k-i+1, i-1,one, a( k+i, 1_${ik}$ ),lda, a( k+i, i ), & + 1_${ik}$, one, t( 1_${ik}$, nb ), 1_${ik}$ ) ! w := t**t * w - call stdlib_dtrmv( 'UPPER', 'TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1, nb ), 1 ) + call stdlib${ii}$_dtrmv( 'UPPER', 'TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1_${ik}$, nb ), 1_${ik}$ ) ! b2 := b2 - v2*w - call stdlib_dgemv( 'NO TRANSPOSE', n-k-i+1, i-1, -one,a( k+i, 1 ),lda, t( 1, nb )& - , 1, one, a( k+i, i ), 1 ) + call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n-k-i+1, i-1, -one,a( k+i, 1_${ik}$ ),lda, t( 1_${ik}$, nb )& + , 1_${ik}$, one, a( k+i, i ), 1_${ik}$ ) ! b1 := b1 - v1*w - call stdlib_dtrmv( 'LOWER', 'NO TRANSPOSE','UNIT', i-1,a( k+1, 1 ), lda, t( 1, & - nb ), 1 ) - call stdlib_daxpy( i-1, -one, t( 1, nb ), 1, a( k+1, i ), 1 ) + call stdlib${ii}$_dtrmv( 'LOWER', 'NO TRANSPOSE','UNIT', i-1,a( k+1, 1_${ik}$ ), lda, t( 1_${ik}$, & + nb ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( i-1, -one, t( 1_${ik}$, nb ), 1_${ik}$, a( k+1, i ), 1_${ik}$ ) a( k+i-1, i-1 ) = ei end if ! generate the elementary reflector h(i) to annihilate ! a(k+i+1:n,i) - call stdlib_dlarfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1,tau( i ) ) + call stdlib${ii}$_dlarfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1_${ik}$,tau( i ) ) ei = a( k+i, i ) a( k+i, i ) = one ! compute y(k+1:n,i) - call stdlib_dgemv( 'NO TRANSPOSE', n-k, n-k-i+1,one, a( k+1, i+1 ),lda, a( k+i, i ),& - 1, zero, y( k+1, i ), 1 ) - call stdlib_dgemv( 'TRANSPOSE', n-k-i+1, i-1,one, a( k+i, 1 ), lda,a( k+i, i ), 1, & - zero, t( 1, i ), 1 ) - call stdlib_dgemv( 'NO TRANSPOSE', n-k, i-1, -one,y( k+1, 1 ), ldy,t( 1, i ), 1, & - one, y( k+1, i ), 1 ) - call stdlib_dscal( n-k, tau( i ), y( k+1, i ), 1 ) + call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n-k, n-k-i+1,one, a( k+1, i+1 ),lda, a( k+i, i ),& + 1_${ik}$, zero, y( k+1, i ), 1_${ik}$ ) + call stdlib${ii}$_dgemv( 'TRANSPOSE', n-k-i+1, i-1,one, a( k+i, 1_${ik}$ ), lda,a( k+i, i ), 1_${ik}$, & + zero, t( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n-k, i-1, -one,y( k+1, 1_${ik}$ ), ldy,t( 1_${ik}$, i ), 1_${ik}$, & + one, y( k+1, i ), 1_${ik}$ ) + call stdlib${ii}$_dscal( n-k, tau( i ), y( k+1, i ), 1_${ik}$ ) ! compute t(1:i,i) - call stdlib_dscal( i-1, -tau( i ), t( 1, i ), 1 ) - call stdlib_dtrmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1, i ), 1 ) + call stdlib${ii}$_dscal( i-1, -tau( i ), t( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_dtrmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1_${ik}$, i ), 1_${ik}$ ) t( i, i ) = tau( i ) end do loop_10 a( k+nb, nb ) = ei ! compute y(1:k,1:nb) - call stdlib_dlacpy( 'ALL', k, nb, a( 1, 2 ), lda, y, ldy ) - call stdlib_dtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE','UNIT', k, nb,one, a( k+1, 1 ), & + call stdlib${ii}$_dlacpy( 'ALL', k, nb, a( 1_${ik}$, 2_${ik}$ ), lda, y, ldy ) + call stdlib${ii}$_dtrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE','UNIT', k, nb,one, a( k+1, 1_${ik}$ ), & lda, y, ldy ) - if( n>k+nb )call stdlib_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,nb, n-k-nb, one,a( 1, & - 2+nb ), lda, a( k+1+nb, 1 ), lda, one, y,ldy ) - call stdlib_dtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE','NON-UNIT', k, nb,one, t, ldt, y, & + if( n>k+nb )call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,nb, n-k-nb, one,a( 1_${ik}$, & + 2_${ik}$+nb ), lda, a( k+1+nb, 1_${ik}$ ), lda, one, y,ldy ) + call stdlib${ii}$_dtrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE','NON-UNIT', k, nb,one, t, ldt, y, & ldy ) return - end subroutine stdlib_dlahr2 + end subroutine stdlib${ii}$_dlahr2 - pure subroutine stdlib_dlaln2( ltrans, na, nw, smin, ca, a, lda, d1, d2, b,ldb, wr, wi, x, & + pure subroutine stdlib${ii}$_dlaln2( ltrans, na, nw, smin, ca, a, lda, d1, d2, b,ldb, wr, wi, x, & !! DLALN2 solves a system of the form (ca A - w D ) X = s B !! or (ca A**T - w D) X = s B with possible scaling ("s") and !! perturbation of A. (A**T means A-transpose.) @@ -50264,8 +50264,8 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: ltrans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldb, ldx, na, nw + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldx, na, nw real(dp), intent(in) :: ca, d1, d2, smin, wi, wr real(dp), intent(out) :: scale, xnorm ! Array Arguments @@ -50275,56 +50275,56 @@ module stdlib_linalg_lapack_d ! Local Scalars - integer(ilp) :: icmax, j + integer(${ik}$) :: icmax, j real(dp) :: bbnd, bi1, bi2, bignum, bnorm, br1, br2, ci21, ci22, cmax, cnorm, cr21, & cr22, csi, csr, li21, lr21, smini, smlnum, temp, u22abs, ui11, ui11r, ui12, ui12s, & ui22, ur11, ur11r, ur12, ur12s, ur22, xi1, xi2, xr1, xr2 ! Local Arrays - logical(lk) :: rswap(4), zswap(4) - integer(ilp) :: ipivot(4,4) - real(dp) :: ci(2,2), civ(4), cr(2,2), crv(4) + logical(lk) :: rswap(4_${ik}$), zswap(4_${ik}$) + integer(${ik}$) :: ipivot(4_${ik}$,4_${ik}$) + real(dp) :: ci(2_${ik}$,2_${ik}$), civ(4_${ik}$), cr(2_${ik}$,2_${ik}$), crv(4_${ik}$) ! Intrinsic Functions intrinsic :: abs,max ! Equivalences - equivalence ( ci( 1, 1 ), civ( 1 ) ),( cr( 1, 1 ), crv( 1 ) ) + equivalence ( ci( 1_${ik}$, 1_${ik}$ ), civ( 1_${ik}$ ) ),( cr( 1_${ik}$, 1_${ik}$ ), crv( 1_${ik}$ ) ) ! Data Statements zswap = [.false.,.false.,.true.,.true.] rswap = [.false.,.true.,.false.,.true.] - ipivot = reshape([1,2,3,4,2,1,4,3,3,4,1,2,4,3,2,1],[4,4]) + ipivot = reshape([1_${ik}$,2_${ik}$,3_${ik}$,4_${ik}$,2_${ik}$,1_${ik}$,4_${ik}$,3_${ik}$,3_${ik}$,4_${ik}$,1_${ik}$,2_${ik}$,4_${ik}$,3_${ik}$,2_${ik}$,1_${ik}$],[4_${ik}$,4_${ik}$]) ! Executable Statements ! compute bignum - smlnum = two*stdlib_dlamch( 'SAFE MINIMUM' ) + smlnum = two*stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) bignum = one / smlnum smini = max( smin, smlnum ) ! don't check for input errors - info = 0 + info = 0_${ik}$ ! standard initializations scale = one - if( na==1 ) then + if( na==1_${ik}$ ) then ! 1 x 1 (i.e., scalar) system c x = b - if( nw==1 ) then + if( nw==1_${ik}$ ) then ! real 1x1 system. ! c = ca a - w d - csr = ca*a( 1, 1 ) - wr*d1 + csr = ca*a( 1_${ik}$, 1_${ik}$ ) - wr*d1 cnorm = abs( csr ) ! if | c | < smini, use c = smini if( cnormone ) then if( bnorm>bignum*cnorm )scale = one / bnorm end if ! compute x - x( 1, 1 ) = ( b( 1, 1 )*scale ) / csr - xnorm = abs( x( 1, 1 ) ) + x( 1_${ik}$, 1_${ik}$ ) = ( b( 1_${ik}$, 1_${ik}$ )*scale ) / csr + xnorm = abs( x( 1_${ik}$, 1_${ik}$ ) ) else ! complex 1x1 system (w is complex) ! c = ca a - w d - csr = ca*a( 1, 1 ) - wr*d1 + csr = ca*a( 1_${ik}$, 1_${ik}$ ) - wr*d1 csi = -wi*d1 cnorm = abs( csr ) + abs( csi ) ! if | c | < smini, use c = smini @@ -50332,35 +50332,35 @@ module stdlib_linalg_lapack_d csr = smini csi = zero cnorm = smini - info = 1 + info = 1_${ik}$ end if ! check scaling for x = b / c - bnorm = abs( b( 1, 1 ) ) + abs( b( 1, 2 ) ) + bnorm = abs( b( 1_${ik}$, 1_${ik}$ ) ) + abs( b( 1_${ik}$, 2_${ik}$ ) ) if( cnormone ) then if( bnorm>bignum*cnorm )scale = one / bnorm end if ! compute x - call stdlib_dladiv( scale*b( 1, 1 ), scale*b( 1, 2 ), csr, csi,x( 1, 1 ), x( 1, & - 2 ) ) - xnorm = abs( x( 1, 1 ) ) + abs( x( 1, 2 ) ) + call stdlib${ii}$_dladiv( scale*b( 1_${ik}$, 1_${ik}$ ), scale*b( 1_${ik}$, 2_${ik}$ ), csr, csi,x( 1_${ik}$, 1_${ik}$ ), x( 1_${ik}$, & + 2_${ik}$ ) ) + xnorm = abs( x( 1_${ik}$, 1_${ik}$ ) ) + abs( x( 1_${ik}$, 2_${ik}$ ) ) end if else ! 2x2 system ! compute the realpart of c = ca a - w d (or ca a**t - w d,KIND=dp) - cr( 1, 1 ) = ca*a( 1, 1 ) - wr*d1 - cr( 2, 2 ) = ca*a( 2, 2 ) - wr*d2 + cr( 1_${ik}$, 1_${ik}$ ) = ca*a( 1_${ik}$, 1_${ik}$ ) - wr*d1 + cr( 2_${ik}$, 2_${ik}$ ) = ca*a( 2_${ik}$, 2_${ik}$ ) - wr*d2 if( ltrans ) then - cr( 1, 2 ) = ca*a( 2, 1 ) - cr( 2, 1 ) = ca*a( 1, 2 ) + cr( 1_${ik}$, 2_${ik}$ ) = ca*a( 2_${ik}$, 1_${ik}$ ) + cr( 2_${ik}$, 1_${ik}$ ) = ca*a( 1_${ik}$, 2_${ik}$ ) else - cr( 2, 1 ) = ca*a( 2, 1 ) - cr( 1, 2 ) = ca*a( 1, 2 ) + cr( 2_${ik}$, 1_${ik}$ ) = ca*a( 2_${ik}$, 1_${ik}$ ) + cr( 1_${ik}$, 2_${ik}$ ) = ca*a( 1_${ik}$, 2_${ik}$ ) end if - if( nw==1 ) then + if( nw==1_${ik}$ ) then ! real2x2 system (w is real,KIND=dp) ! find the largest element in c cmax = zero - icmax = 0 + icmax = 0_${ik}$ do j = 1, 4 if( abs( crv( j ) )>cmax ) then cmax = abs( crv( j ) ) @@ -50369,36 +50369,36 @@ module stdlib_linalg_lapack_d end do ! if norm(c) < smini, use smini*identity. if( cmaxone ) then if( bnorm>bignum*smini )scale = one / bnorm end if temp = scale / smini - x( 1, 1 ) = temp*b( 1, 1 ) - x( 2, 1 ) = temp*b( 2, 1 ) + x( 1_${ik}$, 1_${ik}$ ) = temp*b( 1_${ik}$, 1_${ik}$ ) + x( 2_${ik}$, 1_${ik}$ ) = temp*b( 2_${ik}$, 1_${ik}$ ) xnorm = temp*bnorm - info = 1 + info = 1_${ik}$ return end if ! gaussian elimination with complete pivoting. ur11 = crv( icmax ) - cr21 = crv( ipivot( 2, icmax ) ) - ur12 = crv( ipivot( 3, icmax ) ) - cr22 = crv( ipivot( 4, icmax ) ) + cr21 = crv( ipivot( 2_${ik}$, icmax ) ) + ur12 = crv( ipivot( 3_${ik}$, icmax ) ) + cr22 = crv( ipivot( 4_${ik}$, icmax ) ) ur11r = one / ur11 lr21 = ur11r*cr21 ur22 = cr22 - ur12*lr21 ! if smaller pivot < smini, use smini if( abs( ur22 ) overflow if( xnorm>one .and. cmax>one ) then if( xnorm>bignum / cmax ) then temp = cmax / bignum - x( 1, 1 ) = temp*x( 1, 1 ) - x( 2, 1 ) = temp*x( 2, 1 ) + x( 1_${ik}$, 1_${ik}$ ) = temp*x( 1_${ik}$, 1_${ik}$ ) + x( 2_${ik}$, 1_${ik}$ ) = temp*x( 2_${ik}$, 1_${ik}$ ) xnorm = temp*xnorm scale = temp*scale end if @@ -50428,12 +50428,12 @@ module stdlib_linalg_lapack_d else ! complex 2x2 system (w is complex) ! find the largest element in c - ci( 1, 1 ) = -wi*d1 - ci( 2, 1 ) = zero - ci( 1, 2 ) = zero - ci( 2, 2 ) = -wi*d2 + ci( 1_${ik}$, 1_${ik}$ ) = -wi*d1 + ci( 2_${ik}$, 1_${ik}$ ) = zero + ci( 1_${ik}$, 2_${ik}$ ) = zero + ci( 2_${ik}$, 2_${ik}$ ) = -wi*d2 cmax = zero - icmax = 0 + icmax = 0_${ik}$ do j = 1, 4 if( abs( crv( j ) )+abs( civ( j ) )>cmax ) then cmax = abs( crv( j ) ) + abs( civ( j ) ) @@ -50442,38 +50442,38 @@ module stdlib_linalg_lapack_d end do ! if norm(c) < smini, use smini*identity. if( cmaxone ) then if( bnorm>bignum*smini )scale = one / bnorm end if temp = scale / smini - x( 1, 1 ) = temp*b( 1, 1 ) - x( 2, 1 ) = temp*b( 2, 1 ) - x( 1, 2 ) = temp*b( 1, 2 ) - x( 2, 2 ) = temp*b( 2, 2 ) + x( 1_${ik}$, 1_${ik}$ ) = temp*b( 1_${ik}$, 1_${ik}$ ) + x( 2_${ik}$, 1_${ik}$ ) = temp*b( 2_${ik}$, 1_${ik}$ ) + x( 1_${ik}$, 2_${ik}$ ) = temp*b( 1_${ik}$, 2_${ik}$ ) + x( 2_${ik}$, 2_${ik}$ ) = temp*b( 2_${ik}$, 2_${ik}$ ) xnorm = temp*bnorm - info = 1 + info = 1_${ik}$ return end if ! gaussian elimination with complete pivoting. ur11 = crv( icmax ) ui11 = civ( icmax ) - cr21 = crv( ipivot( 2, icmax ) ) - ci21 = civ( ipivot( 2, icmax ) ) - ur12 = crv( ipivot( 3, icmax ) ) - ui12 = civ( ipivot( 3, icmax ) ) - cr22 = crv( ipivot( 4, icmax ) ) - ci22 = civ( ipivot( 4, icmax ) ) - if( icmax==1 .or. icmax==4 ) then + cr21 = crv( ipivot( 2_${ik}$, icmax ) ) + ci21 = civ( ipivot( 2_${ik}$, icmax ) ) + ur12 = crv( ipivot( 3_${ik}$, icmax ) ) + ui12 = civ( ipivot( 3_${ik}$, icmax ) ) + cr22 = crv( ipivot( 4_${ik}$, icmax ) ) + ci22 = civ( ipivot( 4_${ik}$, icmax ) ) + if( icmax==1_${ik}$ .or. icmax==4_${ik}$ ) then ! code when off-diagonals of pivoted c are real if( abs( ur11 )>abs( ui11 ) ) then temp = ui11 / ur11 - ur11r = one / ( ur11*( one+temp**2 ) ) + ur11r = one / ( ur11*( one+temp**2_${ik}$ ) ) ui11r = -temp*ur11r else temp = ur11 / ui11 - ui11r = -one / ( ui11*( one+temp**2 ) ) + ui11r = -one / ( ui11*( one+temp**2_${ik}$ ) ) ur11r = -temp*ui11r end if lr21 = cr21*ur11r @@ -50498,18 +50498,18 @@ module stdlib_linalg_lapack_d if( u22abs overflow if( xnorm>one .and. cmax>one ) then if( xnorm>bignum / cmax ) then temp = cmax / bignum - x( 1, 1 ) = temp*x( 1, 1 ) - x( 2, 1 ) = temp*x( 2, 1 ) - x( 1, 2 ) = temp*x( 1, 2 ) - x( 2, 2 ) = temp*x( 2, 2 ) + x( 1_${ik}$, 1_${ik}$ ) = temp*x( 1_${ik}$, 1_${ik}$ ) + x( 2_${ik}$, 1_${ik}$ ) = temp*x( 2_${ik}$, 1_${ik}$ ) + x( 1_${ik}$, 2_${ik}$ ) = temp*x( 1_${ik}$, 2_${ik}$ ) + x( 2_${ik}$, 2_${ik}$ ) = temp*x( 2_${ik}$, 2_${ik}$ ) xnorm = temp*xnorm scale = temp*scale end if @@ -50554,10 +50554,10 @@ module stdlib_linalg_lapack_d end if end if return - end subroutine stdlib_dlaln2 + end subroutine stdlib${ii}$_dlaln2 - pure subroutine stdlib_dlals0( icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx,perm, givptr, & + pure subroutine stdlib${ii}$_dlals0( icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx,perm, givptr, & !! DLALS0 applies back the multiplying factors of either the left or the !! right singular vector matrix of a diagonal matrix appended by a row !! to the right hand side matrix B in solving the least squares problem @@ -50583,12 +50583,12 @@ module stdlib_linalg_lapack_d ! -- 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) :: givptr, icompq, k, ldb, ldbx, ldgcol, ldgnum, nl, nr, nrhs,& + integer(${ik}$), intent(in) :: givptr, icompq, k, ldb, ldbx, ldgcol, ldgnum, nl, nr, nrhs,& sqre - integer(ilp), intent(out) :: info + integer(${ik}$), intent(out) :: info real(dp), intent(in) :: c, s ! Array Arguments - integer(ilp), intent(in) :: givcol(ldgcol,*), perm(*) + integer(${ik}$), intent(in) :: givcol(ldgcol,*), perm(*) real(dp), intent(inout) :: b(ldb,*) real(dp), intent(out) :: bx(ldbx,*), work(*) real(dp), intent(in) :: difl(*), difr(ldgnum,*), givnum(ldgnum,*), poles(ldgnum,*), z(& @@ -50596,165 +50596,165 @@ module stdlib_linalg_lapack_d ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, m, n, nlp1 + integer(${ik}$) :: i, j, m, n, nlp1 real(dp) :: diflj, difrj, dj, dsigj, dsigjp, temp ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 - n = nl + nr + 1 - 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 - else if( nrhs<1 ) then - info = -5 + info = 0_${ik}$ + n = nl + nr + 1_${ik}$ + 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( nrhs<1_${ik}$ ) then + info = -5_${ik}$ else if( ldb=max(m,n,k))) then - call stdlib_dgemlqt( side, trans, m, n, k, mb, a, lda,t, ldt, c, ldc, work, info) + call stdlib${ii}$_dgemlqt( side, trans, m, n, k, mb, a, lda,t, ldt, c, ldc, work, info) return end if @@ -50834,85 +50834,85 @@ module stdlib_linalg_lapack_d ! multiply q to the last block of c kk = mod((m-k),(nb-k)) ctr = (m-k)/(nb-k) - if (kk>0) then + if (kk>0_${ik}$) then ii=m-kk+1 - call stdlib_dtpmlqt('L','T',kk , n, k, 0, mb, a(1,ii), lda,t(1,ctr*k+1), ldt, c(& - 1,1), ldc,c(ii,1), ldc, work, info ) + call stdlib${ii}$_dtpmlqt('L','T',kk , n, k, 0_${ik}$, mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1), ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) else ii=m+1 end if do i=ii-(nb-k),nb+1,-(nb-k) ! multiply q to the current block of c (1:m,i:i+nb) - ctr = ctr - 1 - call stdlib_dtpmlqt('L','T',nb-k , n, k, 0,mb, a(1,i), lda,t(1, ctr*k+1),ldt, c(& - 1,1), ldc,c(i,1), ldc, work, info ) + ctr = ctr - 1_${ik}$ + call stdlib${ii}$_dtpmlqt('L','T',nb-k , n, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$, ctr*k+1),ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info ) end do ! multiply q to the first block of c (1:m,1:nb) - call stdlib_dgemlqt('L','T',nb , n, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_dgemlqt('L','T',nb , n, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (left.and.notran) then ! multiply q to the first block of c kk = mod((m-k),(nb-k)) ii=m-kk+1 - ctr = 1 - call stdlib_dgemlqt('L','N',nb , n, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + ctr = 1_${ik}$ + call stdlib${ii}$_dgemlqt('L','N',nb , n, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=nb+1,ii-nb+k,(nb-k) ! multiply q to the current block of c (i:i+nb,1:n) - call stdlib_dtpmlqt('L','N',nb-k , n, k, 0,mb, a(1,i), lda,t(1,ctr*k+1), ldt, c(1,& - 1), ldc,c(i,1), ldc, work, info ) - ctr = ctr + 1 + call stdlib${ii}$_dtpmlqt('L','N',nb-k , n, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$,ctr*k+1), ldt, c(1_${ik}$,& + 1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info ) + ctr = ctr + 1_${ik}$ end do if(ii<=m) then ! multiply q to the last block of c - call stdlib_dtpmlqt('L','N',kk , n, k, 0, mb, a(1,ii), lda,t(1,ctr*k+1), ldt, c(1,& - 1), ldc,c(ii,1), ldc, work, info ) + call stdlib${ii}$_dtpmlqt('L','N',kk , n, k, 0_${ik}$, mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1), ldt, c(1_${ik}$,& + 1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) end if else if(right.and.notran) then ! multiply q to the last block of c kk = mod((n-k),(nb-k)) ctr = (n-k)/(nb-k) - if (kk>0) then + if (kk>0_${ik}$) then ii=n-kk+1 - call stdlib_dtpmlqt('R','N',m , kk, k, 0, mb, a(1, ii), lda,t(1,ctr *k+1), ldt, & - c(1,1), ldc,c(1,ii), ldc, work, info ) + call stdlib${ii}$_dtpmlqt('R','N',m , kk, k, 0_${ik}$, mb, a(1_${ik}$, ii), lda,t(1_${ik}$,ctr *k+1), ldt, & + c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info ) else ii=n+1 end if do i=ii-(nb-k),nb+1,-(nb-k) ! multiply q to the current block of c (1:m,i:i+mb) - ctr = ctr - 1 - call stdlib_dtpmlqt('R','N', m, nb-k, k, 0, mb, a(1, i), lda,t(1,ctr*k+1), ldt, & - c(1,1), ldc,c(1,i), ldc, work, info ) + ctr = ctr - 1_${ik}$ + call stdlib${ii}$_dtpmlqt('R','N', m, nb-k, k, 0_${ik}$, mb, a(1_${ik}$, i), lda,t(1_${ik}$,ctr*k+1), ldt, & + c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info ) end do ! multiply q to the first block of c (1:m,1:mb) - call stdlib_dgemlqt('R','N',m , nb, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_dgemlqt('R','N',m , nb, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (right.and.tran) then ! multiply q to the first block of c kk = mod((n-k),(nb-k)) - ctr = 1 + ctr = 1_${ik}$ ii=n-kk+1 - call stdlib_dgemlqt('R','T',m , nb, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_dgemlqt('R','T',m , nb, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=nb+1,ii-nb+k,(nb-k) ! multiply q to the current block of c (1:m,i:i+mb) - call stdlib_dtpmlqt('R','T',m , nb-k, k, 0,mb, a(1,i), lda,t(1,ctr*k+1), ldt, c(1,& - 1), ldc,c(1,i), ldc, work, info ) - ctr = ctr + 1 + call stdlib${ii}$_dtpmlqt('R','T',m , nb-k, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$,ctr*k+1), ldt, c(1_${ik}$,& + 1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info ) + ctr = ctr + 1_${ik}$ end do if(ii<=n) then ! multiply q to the last block of c - call stdlib_dtpmlqt('R','T',m , kk, k, 0,mb, a(1,ii), lda,t(1,ctr*k+1),ldt, c(1,1),& - ldc,c(1,ii), ldc, work, info ) + call stdlib${ii}$_dtpmlqt('R','T',m , kk, k, 0_${ik}$,mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1),ldt, c(1_${ik}$,1_${ik}$),& + ldc,c(1_${ik}$,ii), ldc, work, info ) end if end if - work(1) = lw + work(1_${ik}$) = lw return - end subroutine stdlib_dlamswlq + end subroutine stdlib${ii}$_dlamswlq - pure subroutine stdlib_dlamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & + pure subroutine stdlib${ii}$_dlamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & !! DLAMTSQR overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -50926,8 +50926,8 @@ module stdlib_linalg_lapack_d ! -- 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) :: lda, m, n, k, mb, nb, ldt, lwork, ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, k, mb, nb, ldt, lwork, ldc ! Array Arguments real(dp), intent(in) :: a(lda,*), t(ldt,*) real(dp), intent(out) :: work(*) @@ -50935,11 +50935,11 @@ module stdlib_linalg_lapack_d ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran, lquery - integer(ilp) :: i, ii, kk, lw, ctr, q + integer(${ik}$) :: i, ii, kk, lw, ctr, q ! External Subroutines ! Executable Statements ! test the input arguments - lquery = lwork<0 + lquery = lwork<0_${ik}$ notran = stdlib_lsame( trans, 'N' ) tran = stdlib_lsame( trans, 'T' ) left = stdlib_lsame( side, 'L' ) @@ -50951,44 +50951,44 @@ module stdlib_linalg_lapack_d lw = mb * nb q = n end if - info = 0 + info = 0_${ik}$ if( .not.left .and. .not.right ) then - info = -1 + info = -1_${ik}$ else if( .not.tran .and. .not.notran ) then - info = -2 + info = -2_${ik}$ else if( m=max(m,n,k))) then - call stdlib_dgemqrt( side, trans, m, n, k, nb, a, lda,t, ldt, c, ldc, work, info) + call stdlib${ii}$_dgemqrt( side, trans, m, n, k, nb, a, lda,t, ldt, c, ldc, work, info) return end if @@ -50996,85 +50996,85 @@ module stdlib_linalg_lapack_d ! multiply q to the last block of c kk = mod((m-k),(mb-k)) ctr = (m-k)/(mb-k) - if (kk>0) then + if (kk>0_${ik}$) then ii=m-kk+1 - call stdlib_dtpmqrt('L','N',kk , n, k, 0, nb, a(ii,1), lda,t(1,ctr*k+1),ldt , c(1,& - 1), ldc,c(ii,1), ldc, work, info ) + call stdlib${ii}$_dtpmqrt('L','N',kk , n, k, 0_${ik}$, nb, a(ii,1_${ik}$), lda,t(1_${ik}$,ctr*k+1),ldt , c(1_${ik}$,& + 1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) else ii=m+1 end if do i=ii-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) - ctr = ctr - 1 - call stdlib_dtpmqrt('L','N',mb-k , n, k, 0,nb, a(i,1), lda,t(1,ctr*k+1),ldt, c(1,& - 1), ldc,c(i,1), ldc, work, info ) + ctr = ctr - 1_${ik}$ + call stdlib${ii}$_dtpmqrt('L','N',mb-k , n, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$,ctr*k+1),ldt, c(1_${ik}$,& + 1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info ) end do ! multiply q to the first block of c (1:mb,1:n) - call stdlib_dgemqrt('L','N',mb , n, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_dgemqrt('L','N',mb , n, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (left.and.tran) then ! multiply q to the first block of c kk = mod((m-k),(mb-k)) ii=m-kk+1 - ctr = 1 - call stdlib_dgemqrt('L','T',mb , n, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + ctr = 1_${ik}$ + call stdlib${ii}$_dgemqrt('L','T',mb , n, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) - call stdlib_dtpmqrt('L','T',mb-k , n, k, 0,nb, a(i,1), lda,t(1,ctr * k + 1),ldt, c(& - 1,1), ldc,c(i,1), ldc, work, info ) - ctr = ctr + 1 + call stdlib${ii}$_dtpmqrt('L','T',mb-k , n, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$,ctr * k + 1_${ik}$),ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info ) + ctr = ctr + 1_${ik}$ end do if(ii<=m) then ! multiply q to the last block of c - call stdlib_dtpmqrt('L','T',kk , n, k, 0,nb, a(ii,1), lda,t(1,ctr * k + 1), ldt, c(& - 1,1), ldc,c(ii,1), ldc, work, info ) + call stdlib${ii}$_dtpmqrt('L','T',kk , n, k, 0_${ik}$,nb, a(ii,1_${ik}$), lda,t(1_${ik}$,ctr * k + 1_${ik}$), ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) end if else if(right.and.tran) then ! multiply q to the last block of c kk = mod((n-k),(mb-k)) ctr = (n-k)/(mb-k) - if (kk>0) then + if (kk>0_${ik}$) then ii=n-kk+1 - call stdlib_dtpmqrt('R','T',m , kk, k, 0, nb, a(ii,1), lda,t(1,ctr*k+1), ldt, c(& - 1,1), ldc,c(1,ii), ldc, work, info ) + call stdlib${ii}$_dtpmqrt('R','T',m , kk, k, 0_${ik}$, nb, a(ii,1_${ik}$), lda,t(1_${ik}$,ctr*k+1), ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info ) else ii=n+1 end if do i=ii-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) - ctr = ctr - 1 - call stdlib_dtpmqrt('R','T',m , mb-k, k, 0,nb, a(i,1), lda,t(1,ctr*k+1), ldt, c(& - 1,1), ldc,c(1,i), ldc, work, info ) + ctr = ctr - 1_${ik}$ + call stdlib${ii}$_dtpmqrt('R','T',m , mb-k, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$,ctr*k+1), ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info ) end do ! multiply q to the first block of c (1:m,1:mb) - call stdlib_dgemqrt('R','T',m , mb, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_dgemqrt('R','T',m , mb, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (right.and.notran) then ! multiply q to the first block of c kk = mod((n-k),(mb-k)) ii=n-kk+1 - ctr = 1 - call stdlib_dgemqrt('R','N', m, mb , k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + ctr = 1_${ik}$ + call stdlib${ii}$_dgemqrt('R','N', m, mb , k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) - call stdlib_dtpmqrt('R','N', m, mb-k, k, 0,nb, a(i,1), lda,t(1, ctr * k + 1),ldt, & - c(1,1), ldc,c(1,i), ldc, work, info ) - ctr = ctr + 1 + call stdlib${ii}$_dtpmqrt('R','N', m, mb-k, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$),ldt, & + c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info ) + ctr = ctr + 1_${ik}$ end do if(ii<=n) then ! multiply q to the last block of c - call stdlib_dtpmqrt('R','N', m, kk , k, 0,nb, a(ii,1), lda,t(1, ctr * k + 1),ldt, & - c(1,1), ldc,c(1,ii), ldc, work, info ) + call stdlib${ii}$_dtpmqrt('R','N', m, kk , k, 0_${ik}$,nb, a(ii,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$),ldt, & + c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info ) end if end if - work(1) = lw + work(1_${ik}$) = lw return - end subroutine stdlib_dlamtsqr + end subroutine stdlib${ii}$_dlamtsqr - pure subroutine stdlib_dlanv2( a, b, c, d, rt1r, rt1i, rt2r, rt2i, cs, sn ) + pure subroutine stdlib${ii}$_dlanv2( a, b, c, d, rt1r, rt1i, rt2r, rt2i, cs, sn ) !! DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric !! matrix in standard form: !! [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ] @@ -51097,14 +51097,14 @@ module stdlib_linalg_lapack_d ! Local Scalars real(dp) :: aa, bb, bcmax, bcmis, cc, cs1, dd, eps, p, sab, sac, scale, sigma, sn1, & tau, temp, z, safmin, safmn2, safmx2 - integer(ilp) :: count + integer(${ik}$) :: count ! Intrinsic Functions intrinsic :: abs,max,min,sign,sqrt ! Executable Statements - safmin = stdlib_dlamch( 'S' ) - eps = stdlib_dlamch( 'P' ) - safmn2 = stdlib_dlamch( 'B' )**int( log( safmin / eps ) /log( stdlib_dlamch( 'B' ) ) / & - two,KIND=ilp) + safmin = stdlib${ii}$_dlamch( 'S' ) + eps = stdlib${ii}$_dlamch( 'P' ) + safmn2 = stdlib${ii}$_dlamch( 'B' )**int( log( safmin / eps ) /log( stdlib${ii}$_dlamch( 'B' ) ) / & + two,KIND=${ik}$) safmx2 = one / safmn2 if( c==zero ) then cs = one @@ -51136,7 +51136,7 @@ module stdlib_linalg_lapack_d a = d + z d = d - ( bcmax / z )*bcmis ! compute b and the rotation matrix - tau = stdlib_dlapy2( c, z ) + tau = stdlib${ii}$_dlapy2( c, z ) cs = z / tau sn = c / tau b = b - c @@ -51144,10 +51144,10 @@ module stdlib_linalg_lapack_d else ! complex eigenvalues, or real(almost,KIND=dp) equal eigenvalues. ! make diagonal elements equal. - count = 0 + count = 0_${ik}$ sigma = b + c 10 continue - count = count + 1 + count = count + 1_${ik}$ scale = max( abs(temp), abs(sigma) ) if( scale>=safmx2 ) then sigma = sigma * safmn2 @@ -51160,7 +51160,7 @@ module stdlib_linalg_lapack_d if (count <= 20)goto 10 end if p = half*temp - tau = stdlib_dlapy2( sigma, temp ) + tau = stdlib${ii}$_dlapy2( sigma, temp ) cs = sqrt( half*( one+abs( sigma ) / tau ) ) sn = -( p / ( tau*cs ) )*sign( one, sigma ) ! compute [ aa bb ] = [ a b ] [ cs -sn ] @@ -51217,10 +51217,10 @@ module stdlib_linalg_lapack_d rt2i = -rt1i end if return - end subroutine stdlib_dlanv2 + end subroutine stdlib${ii}$_dlanv2 - pure subroutine stdlib_dlapll( n, x, incx, y, incy, ssmin ) + pure subroutine stdlib${ii}$_dlapll( n, x, incx, y, incy, ssmin ) !! Given two column vectors X and Y, let !! A = ( X Y ). !! The subroutine first computes the QR factorization of A = Q*R, @@ -51231,7 +51231,7 @@ module stdlib_linalg_lapack_d ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n real(dp), intent(out) :: ssmin ! Array Arguments real(dp), intent(inout) :: x(*), y(*) @@ -51241,26 +51241,26 @@ module stdlib_linalg_lapack_d real(dp) :: a11, a12, a22, c, ssmax, tau ! Executable Statements ! quick return if possible - if( n<=1 ) then + if( n<=1_${ik}$ ) then ssmin = zero return end if ! compute the qr factorization of the n-by-2 matrix ( x y ) - call stdlib_dlarfg( n, x( 1 ), x( 1+incx ), incx, tau ) - a11 = x( 1 ) - x( 1 ) = one - c = -tau*stdlib_ddot( n, x, incx, y, incy ) - call stdlib_daxpy( n, c, x, incx, y, incy ) - call stdlib_dlarfg( n-1, y( 1+incy ), y( 1+2*incy ), incy, tau ) - a12 = y( 1 ) - a22 = y( 1+incy ) + call stdlib${ii}$_dlarfg( n, x( 1_${ik}$ ), x( 1_${ik}$+incx ), incx, tau ) + a11 = x( 1_${ik}$ ) + x( 1_${ik}$ ) = one + c = -tau*stdlib${ii}$_ddot( n, x, incx, y, incy ) + call stdlib${ii}$_daxpy( n, c, x, incx, y, incy ) + call stdlib${ii}$_dlarfg( n-1, y( 1_${ik}$+incy ), y( 1_${ik}$+2*incy ), incy, tau ) + a12 = y( 1_${ik}$ ) + a22 = y( 1_${ik}$+incy ) ! compute the svd of 2-by-2 upper triangular matrix. - call stdlib_dlas2( a11, a12, a22, ssmin, ssmax ) + call stdlib${ii}$_dlas2( a11, a12, a22, ssmin, ssmax ) return - end subroutine stdlib_dlapll + end subroutine stdlib${ii}$_dlapll - pure subroutine stdlib_dlaqp2( m, n, offset, a, lda, jpvt, tau, vn1, vn2,work ) + pure subroutine stdlib${ii}$_dlaqp2( m, n, offset, a, lda, jpvt, tau, vn1, vn2,work ) !! DLAQP2 computes a QR factorization with column pivoting of !! the block A(OFFSET+1:M,1:N). !! The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. @@ -51268,28 +51268,28 @@ module stdlib_linalg_lapack_d ! -- 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, m, n, offset + integer(${ik}$), intent(in) :: lda, m, n, offset ! Array Arguments - integer(ilp), intent(inout) :: jpvt(*) + integer(${ik}$), intent(inout) :: jpvt(*) real(dp), intent(inout) :: a(lda,*), vn1(*), vn2(*) real(dp), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, itemp, j, mn, offpi, pvt + integer(${ik}$) :: i, itemp, j, mn, offpi, pvt real(dp) :: aii, temp, temp2, tol3z ! Intrinsic Functions intrinsic :: abs,max,min,sqrt ! Executable Statements mn = min( m-offset, n ) - tol3z = sqrt(stdlib_dlamch('EPSILON')) + tol3z = sqrt(stdlib${ii}$_dlamch('EPSILON')) ! compute factorization. loop_20: do i = 1, mn offpi = offset + i ! determine ith pivot column and swap if necessary. - pvt = ( i-1 ) + stdlib_idamax( n-i+1, vn1( i ), 1 ) + pvt = ( i-1 ) + stdlib${ii}$_idamax( n-i+1, vn1( i ), 1_${ik}$ ) if( pvt/=i ) then - call stdlib_dswap( m, a( 1, pvt ), 1, a( 1, i ), 1 ) + call stdlib${ii}$_dswap( m, a( 1_${ik}$, pvt ), 1_${ik}$, a( 1_${ik}$, i ), 1_${ik}$ ) itemp = jpvt( pvt ) jpvt( pvt ) = jpvt( i ) jpvt( i ) = itemp @@ -51298,17 +51298,17 @@ module stdlib_linalg_lapack_d end if ! generate elementary reflector h(i). if( offpi1 ) then - call stdlib_dgemv( 'NO TRANSPOSE', m-rk+1, k-1, -one, a( rk, 1 ),lda, f( k, 1 ), & - ldf, one, a( rk, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_dgemv( 'NO TRANSPOSE', m-rk+1, k-1, -one, a( rk, 1_${ik}$ ),lda, f( k, 1_${ik}$ ), & + ldf, one, a( rk, k ), 1_${ik}$ ) end if ! generate elementary reflector h(k). if( rk1 ) then - call stdlib_dgemv( 'TRANSPOSE', m-rk+1, k-1, -tau( k ), a( rk, 1 ),lda, a( rk, k & - ), 1, zero, auxv( 1 ), 1 ) - call stdlib_dgemv( 'NO TRANSPOSE', n, k-1, one, f( 1, 1 ), ldf,auxv( 1 ), 1, one,& - f( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_dgemv( 'TRANSPOSE', m-rk+1, k-1, -tau( k ), a( rk, 1_${ik}$ ),lda, a( rk, k & + ), 1_${ik}$, zero, auxv( 1_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n, k-1, one, f( 1_${ik}$, 1_${ik}$ ), ldf,auxv( 1_${ik}$ ), 1_${ik}$, one,& + f( 1_${ik}$, k ), 1_${ik}$ ) end if ! update the current row of a: ! a(rk,k+1:n) := a(rk,k+1:n) - a(rk,1:k)*f(k+1:n,1:k)**t. if( k0 ) then - itemp = nint( vn2( lsticc ),KIND=ilp) - vn1( lsticc ) = stdlib_dnrm2( m-rk, a( rk+1, lsticc ), 1 ) + if( lsticc>0_${ik}$ ) then + itemp = nint( vn2( lsticc ),KIND=${ik}$) + vn1( lsticc ) = stdlib${ii}$_dnrm2( m-rk, a( rk+1, lsticc ), 1_${ik}$ ) ! note: the computation of vn1( lsticc ) relies on the fact that - ! stdlib_snrm2 does not fail on vectors with norm below the value of - ! sqrt(stdlib_dlamch('s')) + ! stdlib${ii}$_snrm2 does not fail on vectors with norm below the value of + ! sqrt(stdlib${ii}$_dlamch('s')) vn2( lsticc ) = vn1( lsticc ) lsticc = itemp go to 40 end if return - end subroutine stdlib_dlaqps + end subroutine stdlib${ii}$_dlaqps - pure subroutine stdlib_dlaqr5( wantt, wantz, kacc22, n, ktop, kbot, nshfts,sr, si, h, ldh, & + pure subroutine stdlib${ii}$_dlaqr5( wantt, wantz, kacc22, n, ktop, kbot, nshfts,sr, si, h, ldh, & !! DLAQR5 , called by DLAQR0, performs a !! single small-bulge multi-shift QR sweep. iloz, ihiz, z, ldz, v, ldv, u,ldu, nv, wv, ldwv, nh, wh, ldwh ) @@ -51479,7 +51479,7 @@ module stdlib_linalg_lapack_d ! -- 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) :: ihiz, iloz, kacc22, kbot, ktop, ldh, ldu, ldv, ldwh, ldwv, & + integer(${ik}$), intent(in) :: ihiz, iloz, kacc22, kbot, ktop, ldh, ldu, ldv, ldwh, ldwv, & ldz, n, nh, nshfts, nv logical(lk), intent(in) :: wantt, wantz ! Array Arguments @@ -51490,13 +51490,13 @@ module stdlib_linalg_lapack_d ! Local Scalars real(dp) :: alpha, beta, h11, h12, h21, h22, refsum, safmax, safmin, scl, smlnum, swap,& tst1, tst2, ulp - integer(ilp) :: i, i2, i4, incol, j, jbot, jcol, jlen, jrow, jtop, k, k1, kdu, kms, & + integer(${ik}$) :: i, i2, i4, incol, j, jbot, jcol, jlen, jrow, jtop, k, k1, kdu, kms, & krcol, m, m22, mbot, mtop, nbmps, ndcol, ns, nu logical(lk) :: accum, bmp22 ! Intrinsic Functions intrinsic :: abs,real,max,min,mod ! Local Arrays - real(dp) :: vt(3) + real(dp) :: vt(3_${ik}$) ! Executable Statements ! ==== if there are no shifts, then there is nothing to do. ==== if( nshfts<2 )return @@ -51523,34 +51523,34 @@ module stdlib_linalg_lapack_d ! . then simply reduce it by one. the shuffle above ! . ensures that the dropped shift is real and that ! . the remaining shifts are paired. ==== - ns = nshfts - mod( nshfts, 2 ) + ns = nshfts - mod( nshfts, 2_${ik}$ ) ! ==== machine constants for deflation ==== - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) safmax = one / safmin - call stdlib_dlabad( safmin, safmax ) - ulp = stdlib_dlamch( 'PRECISION' ) + call stdlib${ii}$_dlabad( safmin, safmax ) + ulp = stdlib${ii}$_dlamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=dp) / ulp ) ! ==== use accumulated reflections to update far-from-diagonal ! . entries ? ==== - accum = ( kacc22==1 ) .or. ( kacc22==2 ) + accum = ( kacc22==1_${ik}$ ) .or. ( kacc22==2_${ik}$ ) ! ==== clear trash ==== if( ktop+2<=kbot )h( ktop+2, ktop ) = zero ! ==== nbmps = number of 2-shift bulges in the chain ==== - nbmps = ns / 2 + nbmps = ns / 2_${ik}$ ! ==== kdu = width of slab ==== - kdu = 4*nbmps + kdu = 4_${ik}$*nbmps ! ==== create and chase chains of nbmps bulges ==== loop_180: do incol = ktop - 2*nbmps + 1, kbot - 2, 2*nbmps ! jtop = index from which updates from the right start. if( accum ) then jtop = max( ktop, incol ) else if( wantt ) then - jtop = 1 + jtop = 1_${ik}$ else jtop = ktop end if ndcol = incol + kdu - if( accum )call stdlib_dlaset( 'ALL', kdu, kdu, zero, one, u, ldu ) + if( accum )call stdlib${ii}$_dlaset( 'ALL', kdu, kdu, zero, one, u, ldu ) ! ==== near-the-diagonal bulge chase. the following loop ! . performs the near-the-diagonal part of a small bulge ! . multi-shift qr sweep. each 4*nbmps column diagonal @@ -51569,34 +51569,34 @@ module stdlib_linalg_lapack_d ! . (if any) must wait until the active bulges have moved ! . down the diagonal to make room. the phantom matrix ! . paradigm described above helps keep track. ==== - mtop = max( 1, ( ktop-krcol ) / 2+1 ) - mbot = min( nbmps, ( kbot-krcol-1 ) / 2 ) - m22 = mbot + 1 + mtop = max( 1_${ik}$, ( ktop-krcol ) / 2_${ik}$+1 ) + mbot = min( nbmps, ( kbot-krcol-1 ) / 2_${ik}$ ) + m22 = mbot + 1_${ik}$ bmp22 = ( mbotulp*( abs( & + call stdlib${ii}$_dlaqr1( 3_${ik}$, h( k+1, k+1 ), ldh, sr( 2_${ik}$*m-1 ),si( 2_${ik}$*m-1 ), sr( & + 2_${ik}$*m ), si( 2_${ik}$*m ),vt ) + alpha = vt( 1_${ik}$ ) + call stdlib${ii}$_dlarfg( 3_${ik}$, alpha, vt( 2_${ik}$ ), 1_${ik}$, vt( 1_${ik}$ ) ) + refsum = vt( 1_${ik}$ )*( h( k+1, k )+vt( 2_${ik}$ )*h( k+2, k ) ) + if( abs( h( k+2, k )-refsum*vt( 2_${ik}$ ) )+abs( refsum*vt( 3_${ik}$ ) )>ulp*( abs( & h( k, k ) )+abs( h( k+1,k+1 ) )+abs( h( k+2, k+2 ) ) ) ) then ! ==== starting a new bulge here would ! . create non-negligible fill. use @@ -51722,9 +51722,9 @@ module stdlib_linalg_lapack_d h( k+1, k ) = h( k+1, k ) - refsum h( k+2, k ) = zero h( k+3, k ) = zero - v( 1, m ) = vt( 1 ) - v( 2, m ) = vt( 2 ) - v( 3, m ) = vt( 3 ) + v( 1_${ik}$, m ) = vt( 1_${ik}$ ) + v( 2_${ik}$, m ) = vt( 2_${ik}$ ) + v( 3_${ik}$, m ) = vt( 3_${ik}$ ) end if end if end if @@ -51734,19 +51734,19 @@ module stdlib_linalg_lapack_d ! . deflation check. we still delay most of the ! . updates from the left for efficiency. ==== do j = jtop, min( kbot, k+3 ) - refsum = v( 1, m )*( h( j, k+1 )+v( 2, m )*h( j, k+2 )+v( 3, m )*h( j, k+3 & + refsum = v( 1_${ik}$, m )*( h( j, k+1 )+v( 2_${ik}$, m )*h( j, k+2 )+v( 3_${ik}$, m )*h( j, k+3 & ) ) h( j, k+1 ) = h( j, k+1 ) - refsum - h( j, k+2 ) = h( j, k+2 ) - refsum*v( 2, m ) - h( j, k+3 ) = h( j, k+3 ) - refsum*v( 3, m ) + h( j, k+2 ) = h( j, k+2 ) - refsum*v( 2_${ik}$, m ) + h( j, k+3 ) = h( j, k+3 ) - refsum*v( 3_${ik}$, m ) end do ! ==== perform update from left for subsequent ! . column. ==== - refsum = v( 1, m )*( h( k+1, k+1 )+v( 2, m )*h( k+2, k+1 )+v( 3, m )*h( k+3, & + refsum = v( 1_${ik}$, m )*( h( k+1, k+1 )+v( 2_${ik}$, m )*h( k+2, k+1 )+v( 3_${ik}$, m )*h( k+3, & k+1 ) ) h( k+1, k+1 ) = h( k+1, k+1 ) - refsum - h( k+2, k+1 ) = h( k+2, k+1 ) - refsum*v( 2, m ) - h( k+3, k+1 ) = h( k+3, k+1 ) - refsum*v( 3, m ) + h( k+2, k+1 ) = h( k+2, k+1 ) - refsum*v( 2_${ik}$, m ) + h( k+3, k+1 ) = h( k+3, k+1 ) - refsum*v( 3_${ik}$, m ) ! ==== the following convergence test requires that ! . the tradition small-compared-to-nearby-diagonals ! . criterion and the ahues @@ -51789,13 +51789,13 @@ module stdlib_linalg_lapack_d jbot = kbot end if do m = mbot, mtop, -1 - k = krcol + 2*( m-1 ) + k = krcol + 2_${ik}$*( m-1 ) do j = max( ktop, krcol + 2*m ), jbot - refsum = v( 1, m )*( h( k+1, j )+v( 2, m )*h( k+2, j )+v( 3, m )*h( k+3, j & + refsum = v( 1_${ik}$, m )*( h( k+1, j )+v( 2_${ik}$, m )*h( k+2, j )+v( 3_${ik}$, m )*h( k+3, j & ) ) h( k+1, j ) = h( k+1, j ) - refsum - h( k+2, j ) = h( k+2, j ) - refsum*v( 2, m ) - h( k+3, j ) = h( k+3, j ) - refsum*v( 3, m ) + h( k+2, j ) = h( k+2, j ) - refsum*v( 2_${ik}$, m ) + h( k+3, j ) = h( k+3, j ) - refsum*v( 3_${ik}$, m ) end do end do ! ==== accumulate orthogonal transformations. ==== @@ -51804,17 +51804,17 @@ module stdlib_linalg_lapack_d ! . with an efficient matrix-matrix ! . multiply.) ==== do m = mbot, mtop, -1 - k = krcol + 2*( m-1 ) + k = krcol + 2_${ik}$*( m-1 ) kms = k - incol - i2 = max( 1, ktop-incol ) - i2 = max( i2, kms-(krcol-incol)+1 ) - i4 = min( kdu, krcol + 2*( mbot-1 ) - incol + 5 ) + i2 = max( 1_${ik}$, ktop-incol ) + i2 = max( i2, kms-(krcol-incol)+1_${ik}$ ) + i4 = min( kdu, krcol + 2_${ik}$*( mbot-1 ) - incol + 5_${ik}$ ) do j = i2, i4 - refsum = v( 1, m )*( u( j, kms+1 )+v( 2, m )*u( j, kms+2 )+v( 3, m )*u( & + refsum = v( 1_${ik}$, m )*( u( j, kms+1 )+v( 2_${ik}$, m )*u( j, kms+2 )+v( 3_${ik}$, m )*u( & j, kms+3 ) ) u( j, kms+1 ) = u( j, kms+1 ) - refsum - u( j, kms+2 ) = u( j, kms+2 ) - refsum*v( 2, m ) - u( j, kms+3 ) = u( j, kms+3 ) - refsum*v( 3, m ) + u( j, kms+2 ) = u( j, kms+2 ) - refsum*v( 2_${ik}$, m ) + u( j, kms+3 ) = u( j, kms+3 ) - refsum*v( 3_${ik}$, m ) end do end do else if( wantz ) then @@ -51822,13 +51822,13 @@ module stdlib_linalg_lapack_d ! . now by multiplying by reflections ! . from the right. ==== do m = mbot, mtop, -1 - k = krcol + 2*( m-1 ) + k = krcol + 2_${ik}$*( m-1 ) do j = iloz, ihiz - refsum = v( 1, m )*( z( j, k+1 )+v( 2, m )*z( j, k+2 )+v( 3, m )*z( j, & + refsum = v( 1_${ik}$, m )*( z( j, k+1 )+v( 2_${ik}$, m )*z( j, k+2 )+v( 3_${ik}$, m )*z( j, & k+3 ) ) z( j, k+1 ) = z( j, k+1 ) - refsum - z( j, k+2 ) = z( j, k+2 ) - refsum*v( 2, m ) - z( j, k+3 ) = z( j, k+3 ) - refsum*v( 3, m ) + z( j, k+2 ) = z( j, k+2 ) - refsum*v( 2_${ik}$, m ) + z( j, k+3 ) = z( j, k+3 ) - refsum*v( 3_${ik}$, m ) end do end do end if @@ -51839,46 +51839,46 @@ module stdlib_linalg_lapack_d ! . well. ==== if( accum ) then if( wantt ) then - jtop = 1 + jtop = 1_${ik}$ jbot = n else jtop = ktop jbot = kbot end if - k1 = max( 1, ktop-incol ) - nu = ( kdu-max( 0, ndcol-kbot ) ) - k1 + 1 + k1 = max( 1_${ik}$, ktop-incol ) + nu = ( kdu-max( 0_${ik}$, ndcol-kbot ) ) - k1 + 1_${ik}$ ! ==== horizontal multiply ==== do jcol = min( ndcol, kbot ) + 1, jbot, nh jlen = min( nh, jbot-jcol+1 ) - call stdlib_dgemm( 'C', 'N', nu, jlen, nu, one, u( k1, k1 ),ldu, h( incol+k1, & + call stdlib${ii}$_dgemm( 'C', 'N', nu, jlen, nu, one, u( k1, k1 ),ldu, h( incol+k1, & jcol ), ldh, zero, wh,ldwh ) - call stdlib_dlacpy( 'ALL', nu, jlen, wh, ldwh,h( incol+k1, jcol ), ldh ) + call stdlib${ii}$_dlacpy( 'ALL', nu, jlen, wh, ldwh,h( incol+k1, jcol ), ldh ) end do ! ==== vertical multiply ==== do jrow = jtop, max( ktop, incol ) - 1, nv jlen = min( nv, max( ktop, incol )-jrow ) - call stdlib_dgemm( 'N', 'N', jlen, nu, nu, one,h( jrow, incol+k1 ), ldh, u( & + call stdlib${ii}$_dgemm( 'N', 'N', jlen, nu, nu, one,h( jrow, incol+k1 ), ldh, u( & k1, k1 ),ldu, zero, wv, ldwv ) - call stdlib_dlacpy( 'ALL', jlen, nu, wv, ldwv,h( jrow, incol+k1 ), ldh ) + call stdlib${ii}$_dlacpy( 'ALL', jlen, nu, wv, ldwv,h( jrow, incol+k1 ), ldh ) end do ! ==== z multiply (also vertical) ==== if( wantz ) then do jrow = iloz, ihiz, nv jlen = min( nv, ihiz-jrow+1 ) - call stdlib_dgemm( 'N', 'N', jlen, nu, nu, one,z( jrow, incol+k1 ), ldz, u(& + call stdlib${ii}$_dgemm( 'N', 'N', jlen, nu, nu, one,z( jrow, incol+k1 ), ldz, u(& k1, k1 ),ldu, zero, wv, ldwv ) - call stdlib_dlacpy( 'ALL', jlen, nu, wv, ldwv,z( jrow, incol+k1 ), ldz ) + call stdlib${ii}$_dlacpy( 'ALL', jlen, nu, wv, ldwv,z( jrow, incol+k1 ), ldz ) end do end if end if end do loop_180 - end subroutine stdlib_dlaqr5 + end subroutine stdlib${ii}$_dlaqr5 - subroutine stdlib_dlaqtr( ltran, lreal, n, t, ldt, b, w, scale, x, work,info ) + subroutine stdlib${ii}$_dlaqtr( ltran, lreal, n, t, ldt, b, w, scale, x, work,info ) !! DLAQTR solves the real quasi-triangular system !! op(T)*p = scale*c, if LREAL = .TRUE. !! or the complex quasi-triangular systems @@ -51902,8 +51902,8 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: lreal, ltran - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldt, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldt, n real(dp), intent(out) :: scale real(dp), intent(in) :: w ! Array Arguments @@ -51914,47 +51914,47 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: notran - integer(ilp) :: i, ierr, j, j1, j2, jnext, k, n1, n2 + integer(${ik}$) :: i, ierr, j, j1, j2, jnext, k, n1, n2 real(dp) :: bignum, eps, rec, scaloc, si, smin, sminw, smlnum, sr, tjj, tmp, xj, xmax, & xnorm, z ! Local Arrays - real(dp) :: d(2,2), v(2,2) + real(dp) :: d(2_${ik}$,2_${ik}$), v(2_${ik}$,2_${ik}$) ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements ! do not test the input parameters for errors notran = .not.ltran - info = 0 + info = 0_${ik}$ ! quick return if possible if( n==0 )return ! set constants to control overflow - eps = stdlib_dlamch( 'P' ) - smlnum = stdlib_dlamch( 'S' ) / eps + eps = stdlib${ii}$_dlamch( 'P' ) + smlnum = stdlib${ii}$_dlamch( 'S' ) / eps bignum = one / smlnum - xnorm = stdlib_dlange( 'M', n, n, t, ldt, d ) - if( .not.lreal )xnorm = max( xnorm, abs( w ), stdlib_dlange( 'M', n, 1, b, n, d ) ) + xnorm = stdlib${ii}$_dlange( 'M', n, n, t, ldt, d ) + if( .not.lreal )xnorm = max( xnorm, abs( w ), stdlib${ii}$_dlange( 'M', n, 1_${ik}$, b, n, d ) ) smin = max( smlnum, eps*xnorm ) ! compute 1-norm of each column of strictly upper triangular ! part of t to control overflow in triangular solver. - work( 1 ) = zero + work( 1_${ik}$ ) = zero do j = 2, n - work( j ) = stdlib_dasum( j-1, t( 1, j ), 1 ) + work( j ) = stdlib${ii}$_dasum( j-1, t( 1_${ik}$, j ), 1_${ik}$ ) end do if( .not.lreal ) then do i = 2, n work( i ) = work( i ) + abs( b( i ) ) end do end if - n2 = 2*n + n2 = 2_${ik}$*n n1 = n if( .not.lreal )n1 = n2 - k = stdlib_idamax( n1, x, 1 ) + k = stdlib${ii}$_idamax( n1, x, 1_${ik}$ ) xmax = abs( x( k ) ) scale = one if( xmax>bignum ) then scale = bignum / xmax - call stdlib_dscal( n1, scale, x, 1 ) + call stdlib${ii}$_dscal( n1, scale, x, 1_${ik}$ ) xmax = bignum end if if( lreal ) then @@ -51965,11 +51965,11 @@ module stdlib_linalg_lapack_d if( j>jnext )cycle loop_30 j1 = j j2 = j - jnext = j - 1 - if( j>1 ) then + jnext = j - 1_${ik}$ + if( j>1_${ik}$ ) then if( t( j, j-1 )/=zero ) then - j1 = j - 1 - jnext = j - 2 + j1 = j - 1_${ik}$ + jnext = j - 2_${ik}$ end if end if if( j1==j2 ) then @@ -51982,13 +51982,13 @@ module stdlib_linalg_lapack_d if( tjjbignum*tjj ) then rec = one / xj - call stdlib_dscal( n, rec, x, 1 ) + call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if @@ -52000,61 +52000,61 @@ module stdlib_linalg_lapack_d if( xj>one ) then rec = one / xj if( work( j1 )>( bignum-xmax )*rec ) then - call stdlib_dscal( n, rec, x, 1 ) + call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec end if end if - if( j1>1 ) then - call stdlib_daxpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 ) - k = stdlib_idamax( j1-1, x, 1 ) + if( j1>1_${ik}$ ) then + call stdlib${ii}$_daxpy( j1-1, -x( j1 ), t( 1_${ik}$, j1 ), 1_${ik}$, x, 1_${ik}$ ) + k = stdlib${ii}$_idamax( j1-1, x, 1_${ik}$ ) xmax = abs( x( k ) ) end if else ! meet 2 by 2 diagonal block ! call 2 by 2 linear system solve, to take ! care of possible overflow by scaling factor. - d( 1, 1 ) = x( j1 ) - d( 2, 1 ) = x( j2 ) - call stdlib_dlaln2( .false., 2, 1, smin, one, t( j1, j1 ),ldt, one, one, d,& - 2, zero, zero, v, 2,scaloc, xnorm, ierr ) - if( ierr/=0 )info = 2 + d( 1_${ik}$, 1_${ik}$ ) = x( j1 ) + d( 2_${ik}$, 1_${ik}$ ) = x( j2 ) + call stdlib${ii}$_dlaln2( .false., 2_${ik}$, 1_${ik}$, smin, one, t( j1, j1 ),ldt, one, one, d,& + 2_${ik}$, zero, zero, v, 2_${ik}$,scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 2_${ik}$ if( scaloc/=one ) then - call stdlib_dscal( n, scaloc, x, 1 ) + call stdlib${ii}$_dscal( n, scaloc, x, 1_${ik}$ ) scale = scale*scaloc end if - x( j1 ) = v( 1, 1 ) - x( j2 ) = v( 2, 1 ) + x( j1 ) = v( 1_${ik}$, 1_${ik}$ ) + x( j2 ) = v( 2_${ik}$, 1_${ik}$ ) ! scale v(1,1) (= x(j1)) and/or v(2,1) (=x(j2)) ! to avoid overflow in updating right-hand side. - xj = max( abs( v( 1, 1 ) ), abs( v( 2, 1 ) ) ) + xj = max( abs( v( 1_${ik}$, 1_${ik}$ ) ), abs( v( 2_${ik}$, 1_${ik}$ ) ) ) if( xj>one ) then rec = one / xj if( max( work( j1 ), work( j2 ) )>( bignum-xmax )*rec ) then - call stdlib_dscal( n, rec, x, 1 ) + call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec end if end if ! update right-hand side - if( j1>1 ) then - call stdlib_daxpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 ) - call stdlib_daxpy( j1-1, -x( j2 ), t( 1, j2 ), 1, x, 1 ) - k = stdlib_idamax( j1-1, x, 1 ) + if( j1>1_${ik}$ ) then + call stdlib${ii}$_daxpy( j1-1, -x( j1 ), t( 1_${ik}$, j1 ), 1_${ik}$, x, 1_${ik}$ ) + call stdlib${ii}$_daxpy( j1-1, -x( j2 ), t( 1_${ik}$, j2 ), 1_${ik}$, x, 1_${ik}$ ) + k = stdlib${ii}$_idamax( j1-1, x, 1_${ik}$ ) xmax = abs( x( k ) ) end if end if end do loop_30 else ! solve t**t*p = scale*c - jnext = 1 + jnext = 1_${ik}$ loop_40: do j = 1, n if( jone ) then rec = one / xmax if( work( j1 )>( bignum-xj )*rec ) then - call stdlib_dscal( n, rec, x, 1 ) + call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j1 ) = x( j1 ) - stdlib_ddot( j1-1, t( 1, j1 ), 1, x, 1 ) + x( j1 ) = x( j1 ) - stdlib${ii}$_ddot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$, x, 1_${ik}$ ) xj = abs( x( j1 ) ) tjj = abs( t( j1, j1 ) ) tmp = t( j1, j1 ) if( tjjbignum*tjj ) then rec = one / xj - call stdlib_dscal( n, rec, x, 1 ) + call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if @@ -52097,22 +52097,22 @@ module stdlib_linalg_lapack_d if( xmax>one ) then rec = one / xmax if( max( work( j2 ), work( j1 ) )>( bignum-xj )*rec ) then - call stdlib_dscal( n, rec, x, 1 ) + call stdlib${ii}$_dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - d( 1, 1 ) = x( j1 ) - stdlib_ddot( j1-1, t( 1, j1 ), 1, x,1 ) - d( 2, 1 ) = x( j2 ) - stdlib_ddot( j1-1, t( 1, j2 ), 1, x,1 ) - call stdlib_dlaln2( .true., 2, 1, smin, one, t( j1, j1 ),ldt, one, one, d, & - 2, zero, zero, v, 2,scaloc, xnorm, ierr ) - if( ierr/=0 )info = 2 + d( 1_${ik}$, 1_${ik}$ ) = x( j1 ) - stdlib${ii}$_ddot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$, x,1_${ik}$ ) + d( 2_${ik}$, 1_${ik}$ ) = x( j2 ) - stdlib${ii}$_ddot( j1-1, t( 1_${ik}$, j2 ), 1_${ik}$, x,1_${ik}$ ) + call stdlib${ii}$_dlaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, t( j1, j1 ),ldt, one, one, d, & + 2_${ik}$, zero, zero, v, 2_${ik}$,scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 2_${ik}$ if( scaloc/=one ) then - call stdlib_dscal( n, scaloc, x, 1 ) + call stdlib${ii}$_dscal( n, scaloc, x, 1_${ik}$ ) scale = scale*scaloc end if - x( j1 ) = v( 1, 1 ) - x( j2 ) = v( 2, 1 ) + x( j1 ) = v( 1_${ik}$, 1_${ik}$ ) + x( j2 ) = v( 2_${ik}$, 1_${ik}$ ) xmax = max( abs( x( j1 ) ), abs( x( j2 ) ), xmax ) end if end do loop_40 @@ -52126,36 +52126,36 @@ module stdlib_linalg_lapack_d if( j>jnext )cycle loop_70 j1 = j j2 = j - jnext = j - 1 - if( j>1 ) then + jnext = j - 1_${ik}$ + if( j>1_${ik}$ ) then if( t( j, j-1 )/=zero ) then - j1 = j - 1 - jnext = j - 2 + j1 = j - 1_${ik}$ + jnext = j - 2_${ik}$ end if end if if( j1==j2 ) then ! 1 by 1 diagonal block ! scale if necessary to avoid overflow in division z = w - if( j1==1 )z = b( 1 ) + if( j1==1_${ik}$ )z = b( 1_${ik}$ ) xj = abs( x( j1 ) ) + abs( x( n+j1 ) ) tjj = abs( t( j1, j1 ) ) + abs( z ) tmp = t( j1, j1 ) if( tjjbignum*tjj ) then rec = one / xj - call stdlib_dscal( n2, rec, x, 1 ) + call stdlib${ii}$_dscal( n2, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - call stdlib_dladiv( x( j1 ), x( n+j1 ), tmp, z, sr, si ) + call stdlib${ii}$_dladiv( x( j1 ), x( n+j1 ), tmp, z, sr, si ) x( j1 ) = sr x( n+j1 ) = si xj = abs( x( j1 ) ) + abs( x( n+j1 ) ) @@ -52164,14 +52164,14 @@ module stdlib_linalg_lapack_d if( xj>one ) then rec = one / xj if( work( j1 )>( bignum-xmax )*rec ) then - call stdlib_dscal( n2, rec, x, 1 ) + call stdlib${ii}$_dscal( n2, rec, x, 1_${ik}$ ) scale = scale*rec end if end if - if( j1>1 ) then - call stdlib_daxpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 ) - call stdlib_daxpy( j1-1, -x( n+j1 ), t( 1, j1 ), 1,x( n+1 ), 1 ) - x( 1 ) = x( 1 ) + b( j1 )*x( n+j1 ) + if( j1>1_${ik}$ ) then + call stdlib${ii}$_daxpy( j1-1, -x( j1 ), t( 1_${ik}$, j1 ), 1_${ik}$, x, 1_${ik}$ ) + call stdlib${ii}$_daxpy( j1-1, -x( n+j1 ), t( 1_${ik}$, j1 ), 1_${ik}$,x( n+1 ), 1_${ik}$ ) + x( 1_${ik}$ ) = x( 1_${ik}$ ) + b( j1 )*x( n+j1 ) x( n+1 ) = x( n+1 ) - b( j1 )*x( j1 ) xmax = zero do k = 1, j1 - 1 @@ -52180,39 +52180,39 @@ module stdlib_linalg_lapack_d end if else ! meet 2 by 2 diagonal block - d( 1, 1 ) = x( j1 ) - d( 2, 1 ) = x( j2 ) - d( 1, 2 ) = x( n+j1 ) - d( 2, 2 ) = x( n+j2 ) - call stdlib_dlaln2( .false., 2, 2, sminw, one, t( j1, j1 ),ldt, one, one, & - d, 2, zero, -w, v, 2,scaloc, xnorm, ierr ) - if( ierr/=0 )info = 2 + d( 1_${ik}$, 1_${ik}$ ) = x( j1 ) + d( 2_${ik}$, 1_${ik}$ ) = x( j2 ) + d( 1_${ik}$, 2_${ik}$ ) = x( n+j1 ) + d( 2_${ik}$, 2_${ik}$ ) = x( n+j2 ) + call stdlib${ii}$_dlaln2( .false., 2_${ik}$, 2_${ik}$, sminw, one, t( j1, j1 ),ldt, one, one, & + d, 2_${ik}$, zero, -w, v, 2_${ik}$,scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 2_${ik}$ if( scaloc/=one ) then - call stdlib_dscal( 2*n, scaloc, x, 1 ) + call stdlib${ii}$_dscal( 2_${ik}$*n, scaloc, x, 1_${ik}$ ) scale = scaloc*scale end if - x( j1 ) = v( 1, 1 ) - x( j2 ) = v( 2, 1 ) - x( n+j1 ) = v( 1, 2 ) - x( n+j2 ) = v( 2, 2 ) + x( j1 ) = v( 1_${ik}$, 1_${ik}$ ) + x( j2 ) = v( 2_${ik}$, 1_${ik}$ ) + x( n+j1 ) = v( 1_${ik}$, 2_${ik}$ ) + x( n+j2 ) = v( 2_${ik}$, 2_${ik}$ ) ! scale x(j1), .... to avoid overflow in ! updating right hand side. - xj = max( abs( v( 1, 1 ) )+abs( v( 1, 2 ) ),abs( v( 2, 1 ) )+abs( v( 2, 2 )& + xj = max( abs( v( 1_${ik}$, 1_${ik}$ ) )+abs( v( 1_${ik}$, 2_${ik}$ ) ),abs( v( 2_${ik}$, 1_${ik}$ ) )+abs( v( 2_${ik}$, 2_${ik}$ )& ) ) if( xj>one ) then rec = one / xj if( max( work( j1 ), work( j2 ) )>( bignum-xmax )*rec ) then - call stdlib_dscal( n2, rec, x, 1 ) + call stdlib${ii}$_dscal( n2, rec, x, 1_${ik}$ ) scale = scale*rec end if end if ! update the right-hand side. - if( j1>1 ) then - call stdlib_daxpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 ) - call stdlib_daxpy( j1-1, -x( j2 ), t( 1, j2 ), 1, x, 1 ) - call stdlib_daxpy( j1-1, -x( n+j1 ), t( 1, j1 ), 1,x( n+1 ), 1 ) - call stdlib_daxpy( j1-1, -x( n+j2 ), t( 1, j2 ), 1,x( n+1 ), 1 ) - x( 1 ) = x( 1 ) + b( j1 )*x( n+j1 ) +b( j2 )*x( n+j2 ) + if( j1>1_${ik}$ ) then + call stdlib${ii}$_daxpy( j1-1, -x( j1 ), t( 1_${ik}$, j1 ), 1_${ik}$, x, 1_${ik}$ ) + call stdlib${ii}$_daxpy( j1-1, -x( j2 ), t( 1_${ik}$, j2 ), 1_${ik}$, x, 1_${ik}$ ) + call stdlib${ii}$_daxpy( j1-1, -x( n+j1 ), t( 1_${ik}$, j1 ), 1_${ik}$,x( n+1 ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( j1-1, -x( n+j2 ), t( 1_${ik}$, j2 ), 1_${ik}$,x( n+1 ), 1_${ik}$ ) + x( 1_${ik}$ ) = x( 1_${ik}$ ) + b( j1 )*x( n+j1 ) +b( j2 )*x( n+j2 ) x( n+1 ) = x( n+1 ) - b( j1 )*x( j1 ) -b( j2 )*x( j2 ) xmax = zero do k = 1, j1 - 1 @@ -52223,16 +52223,16 @@ module stdlib_linalg_lapack_d end do loop_70 else ! solve (t + ib)**t*(p+iq) = c+id - jnext = 1 + jnext = 1_${ik}$ loop_80: do j = 1, n if( jone ) then rec = one / xmax if( work( j1 )>( bignum-xj )*rec ) then - call stdlib_dscal( n2, rec, x, 1 ) + call stdlib${ii}$_dscal( n2, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j1 ) = x( j1 ) - stdlib_ddot( j1-1, t( 1, j1 ), 1, x, 1 ) - x( n+j1 ) = x( n+j1 ) - stdlib_ddot( j1-1, t( 1, j1 ), 1,x( n+1 ), 1 ) + x( j1 ) = x( j1 ) - stdlib${ii}$_ddot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$, x, 1_${ik}$ ) + x( n+j1 ) = x( n+j1 ) - stdlib${ii}$_ddot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$,x( n+1 ), 1_${ik}$ ) - if( j1>1 ) then + if( j1>1_${ik}$ ) then x( j1 ) = x( j1 ) - b( j1 )*x( n+1 ) - x( n+j1 ) = x( n+j1 ) + b( j1 )*x( 1 ) + x( n+j1 ) = x( n+j1 ) + b( j1 )*x( 1_${ik}$ ) end if xj = abs( x( j1 ) ) + abs( x( j1+n ) ) z = w - if( j1==1 )z = b( 1 ) + if( j1==1_${ik}$ )z = b( 1_${ik}$ ) ! scale if necessary to avoid overflow in ! complex division tjj = abs( t( j1, j1 ) ) + abs( z ) @@ -52265,17 +52265,17 @@ module stdlib_linalg_lapack_d if( tjjbignum*tjj ) then rec = one / xj - call stdlib_dscal( n2, rec, x, 1 ) + call stdlib${ii}$_dscal( n2, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - call stdlib_dladiv( x( j1 ), x( n+j1 ), tmp, -z, sr, si ) + call stdlib${ii}$_dladiv( x( j1 ), x( n+j1 ), tmp, -z, sr, si ) x( j1 ) = sr x( j1+n ) = si xmax = max( abs( x( j1 ) )+abs( x( j1+n ) ), xmax ) @@ -52288,32 +52288,32 @@ module stdlib_linalg_lapack_d if( xmax>one ) then rec = one / xmax if( max( work( j1 ), work( j2 ) )>( bignum-xj ) / xmax ) then - call stdlib_dscal( n2, rec, x, 1 ) + call stdlib${ii}$_dscal( n2, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - d( 1, 1 ) = x( j1 ) - stdlib_ddot( j1-1, t( 1, j1 ), 1, x,1 ) - d( 2, 1 ) = x( j2 ) - stdlib_ddot( j1-1, t( 1, j2 ), 1, x,1 ) - d( 1, 2 ) = x( n+j1 ) - stdlib_ddot( j1-1, t( 1, j1 ), 1,x( n+1 ), 1 ) + d( 1_${ik}$, 1_${ik}$ ) = x( j1 ) - stdlib${ii}$_ddot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$, x,1_${ik}$ ) + d( 2_${ik}$, 1_${ik}$ ) = x( j2 ) - stdlib${ii}$_ddot( j1-1, t( 1_${ik}$, j2 ), 1_${ik}$, x,1_${ik}$ ) + d( 1_${ik}$, 2_${ik}$ ) = x( n+j1 ) - stdlib${ii}$_ddot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$,x( n+1 ), 1_${ik}$ ) - d( 2, 2 ) = x( n+j2 ) - stdlib_ddot( j1-1, t( 1, j2 ), 1,x( n+1 ), 1 ) + d( 2_${ik}$, 2_${ik}$ ) = x( n+j2 ) - stdlib${ii}$_ddot( j1-1, t( 1_${ik}$, j2 ), 1_${ik}$,x( n+1 ), 1_${ik}$ ) - d( 1, 1 ) = d( 1, 1 ) - b( j1 )*x( n+1 ) - d( 2, 1 ) = d( 2, 1 ) - b( j2 )*x( n+1 ) - d( 1, 2 ) = d( 1, 2 ) + b( j1 )*x( 1 ) - d( 2, 2 ) = d( 2, 2 ) + b( j2 )*x( 1 ) - call stdlib_dlaln2( .true., 2, 2, sminw, one, t( j1, j1 ),ldt, one, one, d,& - 2, zero, w, v, 2,scaloc, xnorm, ierr ) - if( ierr/=0 )info = 2 + d( 1_${ik}$, 1_${ik}$ ) = d( 1_${ik}$, 1_${ik}$ ) - b( j1 )*x( n+1 ) + d( 2_${ik}$, 1_${ik}$ ) = d( 2_${ik}$, 1_${ik}$ ) - b( j2 )*x( n+1 ) + d( 1_${ik}$, 2_${ik}$ ) = d( 1_${ik}$, 2_${ik}$ ) + b( j1 )*x( 1_${ik}$ ) + d( 2_${ik}$, 2_${ik}$ ) = d( 2_${ik}$, 2_${ik}$ ) + b( j2 )*x( 1_${ik}$ ) + call stdlib${ii}$_dlaln2( .true., 2_${ik}$, 2_${ik}$, sminw, one, t( j1, j1 ),ldt, one, one, d,& + 2_${ik}$, zero, w, v, 2_${ik}$,scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 2_${ik}$ if( scaloc/=one ) then - call stdlib_dscal( n2, scaloc, x, 1 ) + call stdlib${ii}$_dscal( n2, scaloc, x, 1_${ik}$ ) scale = scaloc*scale end if - x( j1 ) = v( 1, 1 ) - x( j2 ) = v( 2, 1 ) - x( n+j1 ) = v( 1, 2 ) - x( n+j2 ) = v( 2, 2 ) + x( j1 ) = v( 1_${ik}$, 1_${ik}$ ) + x( j2 ) = v( 2_${ik}$, 1_${ik}$ ) + x( n+j1 ) = v( 1_${ik}$, 2_${ik}$ ) + x( n+j2 ) = v( 2_${ik}$, 2_${ik}$ ) xmax = max( abs( x( j1 ) )+abs( x( n+j1 ) ),abs( x( j2 ) )+abs( x( n+j2 ) )& , xmax ) end if @@ -52321,10 +52321,10 @@ module stdlib_linalg_lapack_d end if end if return - end subroutine stdlib_dlaqtr + end subroutine stdlib${ii}$_dlaqtr - pure subroutine stdlib_dlasd3( nl, nr, sqre, k, d, q, ldq, dsigma, u, ldu, u2,ldu2, vt, ldvt,& + pure subroutine stdlib${ii}$_dlasd3( nl, nr, sqre, k, d, q, ldq, dsigma, u, ldu, u2,ldu2, vt, ldvt,& !! DLASD3 finds all the square roots of the roots of the secular !! equation, as defined by the values in D and Z. It makes the !! appropriate calls to DLASD4 and then updates the singular @@ -52341,60 +52341,60 @@ module stdlib_linalg_lapack_d ! -- 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, ldq, ldu, ldu2, ldvt, ldvt2, nl, nr, sqre + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k, ldq, ldu, ldu2, ldvt, ldvt2, nl, nr, sqre ! Array Arguments - integer(ilp), intent(in) :: ctot(*), idxc(*) + integer(${ik}$), intent(in) :: ctot(*), idxc(*) real(dp), intent(out) :: d(*), q(ldq,*), u(ldu,*), vt(ldvt,*) real(dp), intent(inout) :: dsigma(*), vt2(ldvt2,*), z(*) real(dp), intent(in) :: u2(ldu2,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: ctemp, i, j, jc, ktemp, m, n, nlp1, nlp2, nrp1 + integer(${ik}$) :: ctemp, i, j, jc, ktemp, m, n, nlp1, nlp2, nrp1 real(dp) :: rho, temp ! Intrinsic Functions intrinsic :: abs,sign,sqrt ! Executable Statements ! test the input parameters. - info = 0 - if( nl<1 ) then - info = -1 - else if( nr<1 ) then - info = -2 - else if( ( sqre/=1 ) .and. ( sqre/=0 ) ) then - info = -3 - end if - n = nl + nr + 1 + info = 0_${ik}$ + if( nl<1_${ik}$ ) then + info = -1_${ik}$ + else if( nr<1_${ik}$ ) then + info = -2_${ik}$ + else if( ( sqre/=1_${ik}$ ) .and. ( sqre/=0_${ik}$ ) ) then + info = -3_${ik}$ + end if + n = nl + nr + 1_${ik}$ m = n + sqre - nlp1 = nl + 1 - nlp2 = nl + 2 - if( ( k<1 ) .or. ( k>n ) ) then - info = -4 + nlp1 = nl + 1_${ik}$ + nlp2 = nl + 2_${ik}$ + if( ( k<1_${ik}$ ) .or. ( k>n ) ) then + info = -4_${ik}$ else if( ldqzero ) then - call stdlib_dcopy( n, u2( 1, 1 ), 1, u( 1, 1 ), 1 ) + if( k==1_${ik}$ ) then + d( 1_${ik}$ ) = abs( z( 1_${ik}$ ) ) + call stdlib${ii}$_dcopy( m, vt2( 1_${ik}$, 1_${ik}$ ), ldvt2, vt( 1_${ik}$, 1_${ik}$ ), ldvt ) + if( z( 1_${ik}$ )>zero ) then + call stdlib${ii}$_dcopy( n, u2( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, u( 1_${ik}$, 1_${ik}$ ), 1_${ik}$ ) else do i = 1, n - u( i, 1 ) = -u2( i, 1 ) + u( i, 1_${ik}$ ) = -u2( i, 1_${ik}$ ) end do end if return @@ -52416,20 +52416,20 @@ module stdlib_linalg_lapack_d ! 2*dsigma(i) to prevent optimizing compilers from eliminating ! this code. do i = 1, k - dsigma( i ) = stdlib_dlamc3( dsigma( i ), dsigma( i ) ) - dsigma( i ) + dsigma( i ) = stdlib${ii}$_dlamc3( dsigma( i ), dsigma( i ) ) - dsigma( i ) end do ! keep a copy of z. - call stdlib_dcopy( k, z, 1, q, 1 ) + call stdlib${ii}$_dcopy( k, z, 1_${ik}$, q, 1_${ik}$ ) ! normalize z. - rho = stdlib_dnrm2( k, z, 1 ) - call stdlib_dlascl( 'G', 0, 0, rho, one, k, 1, z, k, info ) + rho = stdlib${ii}$_dnrm2( k, z, 1_${ik}$ ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, rho, one, k, 1_${ik}$, z, k, info ) rho = rho*rho ! find the new singular values. do j = 1, k - call stdlib_dlasd4( k, j, dsigma, z, u( 1, j ), rho, d( j ),vt( 1, j ), info ) + call stdlib${ii}$_dlasd4( k, j, dsigma, z, u( 1_${ik}$, j ), rho, d( j ),vt( 1_${ik}$, j ), info ) ! if the zero finder fails, report the convergence failure. - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if end do @@ -52444,89 +52444,89 @@ module stdlib_linalg_lapack_d z( i ) = z( i )*( u( i, j )*vt( i, j ) /( dsigma( i )-dsigma( j+1 ) ) /( dsigma( & i )+dsigma( j+1 ) ) ) end do - z( i ) = sign( sqrt( abs( z( i ) ) ), q( i, 1 ) ) + z( i ) = sign( sqrt( abs( z( i ) ) ), q( i, 1_${ik}$ ) ) end do ! compute left singular vectors of the modified diagonal matrix, ! and store related information for the right singular vectors. do i = 1, k - vt( 1, i ) = z( 1 ) / u( 1, i ) / vt( 1, i ) - u( 1, i ) = negone + vt( 1_${ik}$, i ) = z( 1_${ik}$ ) / u( 1_${ik}$, i ) / vt( 1_${ik}$, i ) + u( 1_${ik}$, i ) = negone do j = 2, k vt( j, i ) = z( j ) / u( j, i ) / vt( j, i ) u( j, i ) = dsigma( j )*vt( j, i ) end do - temp = stdlib_dnrm2( k, u( 1, i ), 1 ) - q( 1, i ) = u( 1, i ) / temp + temp = stdlib${ii}$_dnrm2( k, u( 1_${ik}$, i ), 1_${ik}$ ) + q( 1_${ik}$, i ) = u( 1_${ik}$, i ) / temp do j = 2, k jc = idxc( j ) q( j, i ) = u( jc, i ) / temp end do end do ! update the left singular vector matrix. - if( k==2 ) then - call stdlib_dgemm( 'N', 'N', n, k, k, one, u2, ldu2, q, ldq, zero, u,ldu ) + if( k==2_${ik}$ ) then + call stdlib${ii}$_dgemm( 'N', 'N', n, k, k, one, u2, ldu2, q, ldq, zero, u,ldu ) go to 100 end if - if( ctot( 1 )>0 ) then - call stdlib_dgemm( 'N', 'N', nl, k, ctot( 1 ), one, u2( 1, 2 ), ldu2,q( 2, 1 ), ldq,& - zero, u( 1, 1 ), ldu ) - if( ctot( 3 )>0 ) then - ktemp = 2 + ctot( 1 ) + ctot( 2 ) - call stdlib_dgemm( 'N', 'N', nl, k, ctot( 3 ), one, u2( 1, ktemp ),ldu2, q( & - ktemp, 1 ), ldq, one, u( 1, 1 ), ldu ) - end if - else if( ctot( 3 )>0 ) then - ktemp = 2 + ctot( 1 ) + ctot( 2 ) - call stdlib_dgemm( 'N', 'N', nl, k, ctot( 3 ), one, u2( 1, ktemp ),ldu2, q( ktemp, & - 1 ), ldq, zero, u( 1, 1 ), ldu ) - else - call stdlib_dlacpy( 'F', nl, k, u2, ldu2, u, ldu ) - end if - call stdlib_dcopy( k, q( 1, 1 ), ldq, u( nlp1, 1 ), ldu ) - ktemp = 2 + ctot( 1 ) - ctemp = ctot( 2 ) + ctot( 3 ) - call stdlib_dgemm( 'N', 'N', nr, k, ctemp, one, u2( nlp2, ktemp ), ldu2,q( ktemp, 1 ), & - ldq, zero, u( nlp2, 1 ), ldu ) + if( ctot( 1_${ik}$ )>0_${ik}$ ) then + call stdlib${ii}$_dgemm( 'N', 'N', nl, k, ctot( 1_${ik}$ ), one, u2( 1_${ik}$, 2_${ik}$ ), ldu2,q( 2_${ik}$, 1_${ik}$ ), ldq,& + zero, u( 1_${ik}$, 1_${ik}$ ), ldu ) + if( ctot( 3_${ik}$ )>0_${ik}$ ) then + ktemp = 2_${ik}$ + ctot( 1_${ik}$ ) + ctot( 2_${ik}$ ) + call stdlib${ii}$_dgemm( 'N', 'N', nl, k, ctot( 3_${ik}$ ), one, u2( 1_${ik}$, ktemp ),ldu2, q( & + ktemp, 1_${ik}$ ), ldq, one, u( 1_${ik}$, 1_${ik}$ ), ldu ) + end if + else if( ctot( 3_${ik}$ )>0_${ik}$ ) then + ktemp = 2_${ik}$ + ctot( 1_${ik}$ ) + ctot( 2_${ik}$ ) + call stdlib${ii}$_dgemm( 'N', 'N', nl, k, ctot( 3_${ik}$ ), one, u2( 1_${ik}$, ktemp ),ldu2, q( ktemp, & + 1_${ik}$ ), ldq, zero, u( 1_${ik}$, 1_${ik}$ ), ldu ) + else + call stdlib${ii}$_dlacpy( 'F', nl, k, u2, ldu2, u, ldu ) + end if + call stdlib${ii}$_dcopy( k, q( 1_${ik}$, 1_${ik}$ ), ldq, u( nlp1, 1_${ik}$ ), ldu ) + ktemp = 2_${ik}$ + ctot( 1_${ik}$ ) + ctemp = ctot( 2_${ik}$ ) + ctot( 3_${ik}$ ) + call stdlib${ii}$_dgemm( 'N', 'N', nr, k, ctemp, one, u2( nlp2, ktemp ), ldu2,q( ktemp, 1_${ik}$ ), & + ldq, zero, u( nlp2, 1_${ik}$ ), ldu ) ! generate the right singular vectors. 100 continue do i = 1, k - temp = stdlib_dnrm2( k, vt( 1, i ), 1 ) - q( i, 1 ) = vt( 1, i ) / temp + temp = stdlib${ii}$_dnrm2( k, vt( 1_${ik}$, i ), 1_${ik}$ ) + q( i, 1_${ik}$ ) = vt( 1_${ik}$, i ) / temp do j = 2, k jc = idxc( j ) q( i, j ) = vt( jc, i ) / temp end do end do ! update the right singular vector matrix. - if( k==2 ) then - call stdlib_dgemm( 'N', 'N', k, m, k, one, q, ldq, vt2, ldvt2, zero,vt, ldvt ) + if( k==2_${ik}$ ) then + call stdlib${ii}$_dgemm( 'N', 'N', k, m, k, one, q, ldq, vt2, ldvt2, zero,vt, ldvt ) return end if - ktemp = 1 + ctot( 1 ) - call stdlib_dgemm( 'N', 'N', k, nlp1, ktemp, one, q( 1, 1 ), ldq,vt2( 1, 1 ), ldvt2, & - zero, vt( 1, 1 ), ldvt ) - ktemp = 2 + ctot( 1 ) + ctot( 2 ) - if( ktemp<=ldvt2 )call stdlib_dgemm( 'N', 'N', k, nlp1, ctot( 3 ), one, q( 1, ktemp ),& - ldq, vt2( ktemp, 1 ), ldvt2, one, vt( 1, 1 ),ldvt ) - ktemp = ctot( 1 ) + 1 + ktemp = 1_${ik}$ + ctot( 1_${ik}$ ) + call stdlib${ii}$_dgemm( 'N', 'N', k, nlp1, ktemp, one, q( 1_${ik}$, 1_${ik}$ ), ldq,vt2( 1_${ik}$, 1_${ik}$ ), ldvt2, & + zero, vt( 1_${ik}$, 1_${ik}$ ), ldvt ) + ktemp = 2_${ik}$ + ctot( 1_${ik}$ ) + ctot( 2_${ik}$ ) + if( ktemp<=ldvt2 )call stdlib${ii}$_dgemm( 'N', 'N', k, nlp1, ctot( 3_${ik}$ ), one, q( 1_${ik}$, ktemp ),& + ldq, vt2( ktemp, 1_${ik}$ ), ldvt2, one, vt( 1_${ik}$, 1_${ik}$ ),ldvt ) + ktemp = ctot( 1_${ik}$ ) + 1_${ik}$ nrp1 = nr + sqre - if( ktemp>1 ) then + if( ktemp>1_${ik}$ ) then do i = 1, k - q( i, ktemp ) = q( i, 1 ) + q( i, ktemp ) = q( i, 1_${ik}$ ) end do do i = nlp2, m - vt2( ktemp, i ) = vt2( 1, i ) + vt2( ktemp, i ) = vt2( 1_${ik}$, i ) end do end if - ctemp = 1 + ctot( 2 ) + ctot( 3 ) - call stdlib_dgemm( 'N', 'N', k, nrp1, ctemp, one, q( 1, ktemp ), ldq,vt2( ktemp, nlp2 )& - , ldvt2, zero, vt( 1, nlp2 ), ldvt ) + ctemp = 1_${ik}$ + ctot( 2_${ik}$ ) + ctot( 3_${ik}$ ) + call stdlib${ii}$_dgemm( 'N', 'N', k, nrp1, ctemp, one, q( 1_${ik}$, ktemp ), ldq,vt2( ktemp, nlp2 )& + , ldvt2, zero, vt( 1_${ik}$, nlp2 ), ldvt ) return - end subroutine stdlib_dlasd3 + end subroutine stdlib${ii}$_dlasd3 - pure subroutine stdlib_dlasd6( icompq, nl, nr, sqre, d, vf, vl, alpha, beta,idxq, perm, & + pure subroutine stdlib${ii}$_dlasd6( icompq, nl, nr, sqre, d, vf, vl, alpha, beta,idxq, perm, & !! DLASD6 computes the SVD of an updated upper bidiagonal matrix B !! obtained by merging two smaller ones by appending a row. This !! routine is used only for the problem which requires all singular @@ -52568,53 +52568,53 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: alpha, beta real(dp), intent(out) :: c, s ! Array Arguments - integer(ilp), intent(out) :: givcol(ldgcol,*), iwork(*), perm(*) - integer(ilp), intent(inout) :: idxq(*) + integer(${ik}$), intent(out) :: givcol(ldgcol,*), iwork(*), perm(*) + integer(${ik}$), intent(inout) :: idxq(*) real(dp), intent(inout) :: d(*), vf(*), vl(*) real(dp), intent(out) :: difl(*), difr(*), givnum(ldgnum,*), poles(ldgnum,*), work(*), & z(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, idx, idxc, idxp, isigma, ivfw, ivlw, iw, m, n, n1, n2 + integer(${ik}$) :: i, idx, idxc, idxp, isigma, ivfw, ivlw, iw, m, n, n1, n2 real(dp) :: orgnrm ! 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( ldgcol1 ) then + if( n>1_${ik}$ ) then ! generate q(2:n,2:n) - call stdlib_dorg2r( n-1, n-1, n-1, q( 2, 2 ), ldq, tau, work,iinfo ) + call stdlib${ii}$_dorg2r( n-1, n-1, n-1, q( 2_${ik}$, 2_${ik}$ ), ldq, tau, work,iinfo ) end if end if return - end subroutine stdlib_dopgtr + end subroutine stdlib${ii}$_dopgtr - pure subroutine stdlib_dopmtr( side, uplo, trans, m, n, ap, tau, c, ldc, work,info ) + pure subroutine stdlib${ii}$_dopmtr( side, uplo, trans, m, n, ap, tau, c, ldc, work,info ) !! DOPMTR overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -52757,8 +52757,8 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: side, trans, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldc, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldc, m, n ! Array Arguments real(dp), intent(inout) :: ap(*), c(ldc,*) real(dp), intent(in) :: tau(*) @@ -52767,13 +52767,13 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: forwrd, left, notran, upper - integer(ilp) :: i, i1, i2, i3, ic, ii, jc, mi, ni, nq + integer(${ik}$) :: i, i1, i2, i3, ic, ii, jc, mi, ni, nq real(dp) :: 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' ) upper = stdlib_lsame( uplo, 'U' ) @@ -52784,37 +52784,37 @@ module stdlib_linalg_lapack_d nq = n end if if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -2 + info = -2_${ik}$ else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) ) then - info = -3 - else if( m<0 ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( ldc m-p ) then - info = -2 - else if( q < 0 .or. q < p .or. m-q < p ) then - info = -3 - else if( ldx11 < max( 1, p ) ) then - info = -5 - else if( ldx21 < max( 1, m-p ) ) then - info = -7 + info = 0_${ik}$ + lquery = lwork == -1_${ik}$ + if( m < 0_${ik}$ ) then + info = -1_${ik}$ + else if( p < 0_${ik}$ .or. p > m-p ) then + info = -2_${ik}$ + else if( q < 0_${ik}$ .or. q < p .or. m-q < p ) then + info = -3_${ik}$ + else if( ldx11 < max( 1_${ik}$, p ) ) then + info = -5_${ik}$ + else if( ldx21 < max( 1_${ik}$, m-p ) ) then + info = -7_${ik}$ end if ! compute workspace - if( info == 0 ) then - ilarf = 2 + if( info == 0_${ik}$ ) then + ilarf = 2_${ik}$ llarf = max( p-1, m-p, q-1 ) - iorbdb5 = 2 + iorbdb5 = 2_${ik}$ lorbdb5 = q-1 lworkopt = max( ilarf+llarf-1, iorbdb5+lorbdb5-1 ) lworkmin = lworkopt - work(1) = lworkopt + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not.lquery ) then - info = -14 + info = -14_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'DORBDB2', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DORBDB2', -info ) return else if( lquery ) then return end if ! reduce rows 1, ..., p of x11 and x21 do i = 1, p - if( i > 1 ) then - call stdlib_drot( q-i+1, x11(i,i), ldx11, x21(i-1,i), ldx21, c, s ) + if( i > 1_${ik}$ ) then + call stdlib${ii}$_drot( q-i+1, x11(i,i), ldx11, x21(i-1,i), ldx21, c, s ) end if - call stdlib_dlarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) + call stdlib${ii}$_dlarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) c = x11(i,i) x11(i,i) = one - call stdlib_dlarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & + call stdlib${ii}$_dlarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & work(ilarf) ) - call stdlib_dlarf( 'R', m-p-i+1, q-i+1, x11(i,i), ldx11, tauq1(i),x21(i,i), ldx21, & + call stdlib${ii}$_dlarf( 'R', m-p-i+1, q-i+1, x11(i,i), ldx11, tauq1(i),x21(i,i), ldx21, & work(ilarf) ) - s = sqrt( stdlib_dnrm2( p-i, x11(i+1,i), 1 )**2+ stdlib_dnrm2( m-p-i+1, x21(i,i), 1 & - )**2 ) + s = sqrt( stdlib${ii}$_dnrm2( p-i, x11(i+1,i), 1_${ik}$ )**2_${ik}$+ stdlib${ii}$_dnrm2( m-p-i+1, x21(i,i), 1_${ik}$ & + )**2_${ik}$ ) theta(i) = atan2( s, c ) - call stdlib_dorbdb5( p-i, m-p-i+1, q-i, x11(i+1,i), 1, x21(i,i), 1,x11(i+1,i+1), & + call stdlib${ii}$_dorbdb5( p-i, m-p-i+1, q-i, x11(i+1,i), 1_${ik}$, x21(i,i), 1_${ik}$,x11(i+1,i+1), & ldx11, x21(i,i+1), ldx21,work(iorbdb5), lorbdb5, childinfo ) - call stdlib_dscal( p-i, negone, x11(i+1,i), 1 ) - call stdlib_dlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) ) + call stdlib${ii}$_dscal( p-i, negone, x11(i+1,i), 1_${ik}$ ) + call stdlib${ii}$_dlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1_${ik}$, taup2(i) ) if( i < p ) then - call stdlib_dlarfgp( p-i, x11(i+1,i), x11(i+2,i), 1, taup1(i) ) + call stdlib${ii}$_dlarfgp( p-i, x11(i+1,i), x11(i+2,i), 1_${ik}$, taup1(i) ) phi(i) = atan2( x11(i+1,i), x21(i,i) ) c = cos( phi(i) ) s = sin( phi(i) ) x11(i+1,i) = one - call stdlib_dlarf( 'L', p-i, q-i, x11(i+1,i), 1, taup1(i),x11(i+1,i+1), ldx11, & + call stdlib${ii}$_dlarf( 'L', p-i, q-i, x11(i+1,i), 1_${ik}$, taup1(i),x11(i+1,i+1), ldx11, & work(ilarf) ) end if x21(i,i) = one - call stdlib_dlarf( 'L', m-p-i+1, q-i, x21(i,i), 1, taup2(i),x21(i,i+1), ldx21, work(& + call stdlib${ii}$_dlarf( 'L', m-p-i+1, q-i, x21(i,i), 1_${ik}$, taup2(i),x21(i,i+1), ldx21, work(& ilarf) ) end do ! reduce the bottom-right portion of x21 to the identity matrix do i = p + 1, q - call stdlib_dlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) ) + call stdlib${ii}$_dlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1_${ik}$, taup2(i) ) x21(i,i) = one - call stdlib_dlarf( 'L', m-p-i+1, q-i, x21(i,i), 1, taup2(i),x21(i,i+1), ldx21, work(& + call stdlib${ii}$_dlarf( 'L', m-p-i+1, q-i, x21(i,i), 1_${ik}$, taup2(i),x21(i,i+1), ldx21, work(& ilarf) ) end do return - end subroutine stdlib_dorbdb2 + end subroutine stdlib${ii}$_dorbdb2 - subroutine stdlib_dorbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & + subroutine stdlib${ii}$_dorbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & !! DORBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny !! matrix X with orthonomal columns: !! [ B11 ] @@ -53125,8 +53125,8 @@ module stdlib_linalg_lapack_d ! -- 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) :: lwork, m, p, q, ldx11, ldx21 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork, m, p, q, ldx11, ldx21 ! Array Arguments real(dp), intent(out) :: phi(*), theta(*) real(dp), intent(out) :: taup1(*), taup2(*), tauq1(*), work(*) @@ -53135,88 +53135,88 @@ module stdlib_linalg_lapack_d ! Local Scalars real(dp) :: c, s - integer(ilp) :: childinfo, i, ilarf, iorbdb5, llarf, lorbdb5, lworkmin, & + integer(${ik}$) :: childinfo, i, ilarf, iorbdb5, llarf, lorbdb5, lworkmin, & lworkopt logical(lk) :: lquery ! Intrinsic Function intrinsic :: atan2,cos,max,sin,sqrt ! Executable Statements ! test input arguments - info = 0 - lquery = lwork == -1 - if( m < 0 ) then - info = -1 - else if( 2*p < m .or. p > m ) then - info = -2 + info = 0_${ik}$ + lquery = lwork == -1_${ik}$ + if( m < 0_${ik}$ ) then + info = -1_${ik}$ + else if( 2_${ik}$*p < m .or. p > m ) then + info = -2_${ik}$ else if( q < m-p .or. m-q < m-p ) then - info = -3 - else if( ldx11 < max( 1, p ) ) then - info = -5 - else if( ldx21 < max( 1, m-p ) ) then - info = -7 + info = -3_${ik}$ + else if( ldx11 < max( 1_${ik}$, p ) ) then + info = -5_${ik}$ + else if( ldx21 < max( 1_${ik}$, m-p ) ) then + info = -7_${ik}$ end if ! compute workspace - if( info == 0 ) then - ilarf = 2 + if( info == 0_${ik}$ ) then + ilarf = 2_${ik}$ llarf = max( p, m-p-1, q-1 ) - iorbdb5 = 2 + iorbdb5 = 2_${ik}$ lorbdb5 = q-1 lworkopt = max( ilarf+llarf-1, iorbdb5+lorbdb5-1 ) lworkmin = lworkopt - work(1) = lworkopt + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not.lquery ) then - info = -14 + info = -14_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'DORBDB3', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DORBDB3', -info ) return else if( lquery ) then return end if ! reduce rows 1, ..., m-p of x11 and x21 do i = 1, m-p - if( i > 1 ) then - call stdlib_drot( q-i+1, x11(i-1,i), ldx11, x21(i,i), ldx11, c, s ) + if( i > 1_${ik}$ ) then + call stdlib${ii}$_drot( q-i+1, x11(i-1,i), ldx11, x21(i,i), ldx11, c, s ) end if - call stdlib_dlarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) + call stdlib${ii}$_dlarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) s = x21(i,i) x21(i,i) = one - call stdlib_dlarf( 'R', p-i+1, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i,i), ldx11, & + call stdlib${ii}$_dlarf( 'R', p-i+1, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i,i), ldx11, & work(ilarf) ) - call stdlib_dlarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & + call stdlib${ii}$_dlarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & work(ilarf) ) - c = sqrt( stdlib_dnrm2( p-i+1, x11(i,i), 1 )**2+ stdlib_dnrm2( m-p-i, x21(i+1,i), 1 & - )**2 ) + c = sqrt( stdlib${ii}$_dnrm2( p-i+1, x11(i,i), 1_${ik}$ )**2_${ik}$+ stdlib${ii}$_dnrm2( m-p-i, x21(i+1,i), 1_${ik}$ & + )**2_${ik}$ ) theta(i) = atan2( s, c ) - call stdlib_dorbdb5( p-i+1, m-p-i, q-i, x11(i,i), 1, x21(i+1,i), 1,x11(i,i+1), & + call stdlib${ii}$_dorbdb5( p-i+1, m-p-i, q-i, x11(i,i), 1_${ik}$, x21(i+1,i), 1_${ik}$,x11(i,i+1), & ldx11, x21(i+1,i+1), ldx21,work(iorbdb5), lorbdb5, childinfo ) - call stdlib_dlarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) + call stdlib${ii}$_dlarfgp( p-i+1, x11(i,i), x11(i+1,i), 1_${ik}$, taup1(i) ) if( i < m-p ) then - call stdlib_dlarfgp( m-p-i, x21(i+1,i), x21(i+2,i), 1, taup2(i) ) + call stdlib${ii}$_dlarfgp( m-p-i, x21(i+1,i), x21(i+2,i), 1_${ik}$, taup2(i) ) phi(i) = atan2( x21(i+1,i), x11(i,i) ) c = cos( phi(i) ) s = sin( phi(i) ) x21(i+1,i) = one - call stdlib_dlarf( 'L', m-p-i, q-i, x21(i+1,i), 1, taup2(i),x21(i+1,i+1), ldx21, & + call stdlib${ii}$_dlarf( 'L', m-p-i, q-i, x21(i+1,i), 1_${ik}$, taup2(i),x21(i+1,i+1), ldx21, & work(ilarf) ) end if x11(i,i) = one - call stdlib_dlarf( 'L', p-i+1, q-i, x11(i,i), 1, taup1(i), x11(i,i+1),ldx11, work(& + call stdlib${ii}$_dlarf( 'L', p-i+1, q-i, x11(i,i), 1_${ik}$, taup1(i), x11(i,i+1),ldx11, work(& ilarf) ) end do ! reduce the bottom-right portion of x11 to the identity matrix do i = m-p + 1, q - call stdlib_dlarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) + call stdlib${ii}$_dlarfgp( p-i+1, x11(i,i), x11(i+1,i), 1_${ik}$, taup1(i) ) x11(i,i) = one - call stdlib_dlarf( 'L', p-i+1, q-i, x11(i,i), 1, taup1(i), x11(i,i+1),ldx11, work(& + call stdlib${ii}$_dlarf( 'L', p-i+1, q-i, x11(i,i), 1_${ik}$, taup1(i), x11(i,i+1),ldx11, work(& ilarf) ) end do return - end subroutine stdlib_dorbdb3 + end subroutine stdlib${ii}$_dorbdb3 - subroutine stdlib_dorbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & + subroutine stdlib${ii}$_dorbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & !! DORBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny !! matrix X with orthonomal columns: !! [ B11 ] @@ -53237,8 +53237,8 @@ module stdlib_linalg_lapack_d ! -- 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) :: lwork, m, p, q, ldx11, ldx21 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork, m, p, q, ldx11, ldx21 ! Array Arguments real(dp), intent(out) :: phi(*), theta(*) real(dp), intent(out) :: phantom(*), taup1(*), taup2(*), tauq1(*), work(*) @@ -53247,118 +53247,118 @@ module stdlib_linalg_lapack_d ! Local Scalars real(dp) :: c, s - integer(ilp) :: childinfo, i, ilarf, iorbdb5, j, llarf, lorbdb5, lworkmin, & + integer(${ik}$) :: childinfo, i, ilarf, iorbdb5, j, llarf, lorbdb5, lworkmin, & lworkopt logical(lk) :: lquery ! Intrinsic Function intrinsic :: atan2,cos,max,sin,sqrt ! Executable Statements ! test input arguments - info = 0 - lquery = lwork == -1 - if( m < 0 ) then - info = -1 + info = 0_${ik}$ + lquery = lwork == -1_${ik}$ + if( m < 0_${ik}$ ) then + info = -1_${ik}$ else if( p < m-q .or. m-p < m-q ) then - info = -2 + info = -2_${ik}$ else if( q < m-q .or. q > m ) then - info = -3 - else if( ldx11 < max( 1, p ) ) then - info = -5 - else if( ldx21 < max( 1, m-p ) ) then - info = -7 + info = -3_${ik}$ + else if( ldx11 < max( 1_${ik}$, p ) ) then + info = -5_${ik}$ + else if( ldx21 < max( 1_${ik}$, m-p ) ) then + info = -7_${ik}$ end if ! compute workspace - if( info == 0 ) then - ilarf = 2 + if( info == 0_${ik}$ ) then + ilarf = 2_${ik}$ llarf = max( q-1, p-1, m-p-1 ) - iorbdb5 = 2 + iorbdb5 = 2_${ik}$ lorbdb5 = q - lworkopt = ilarf + llarf - 1 - lworkopt = max( lworkopt, iorbdb5 + lorbdb5 - 1 ) + lworkopt = ilarf + llarf - 1_${ik}$ + lworkopt = max( lworkopt, iorbdb5 + lorbdb5 - 1_${ik}$ ) lworkmin = lworkopt - work(1) = lworkopt + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not.lquery ) then - info = -14 + info = -14_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'DORBDB4', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DORBDB4', -info ) return else if( lquery ) then return end if ! reduce columns 1, ..., m-q of x11 and x21 do i = 1, m-q - if( i == 1 ) then + if( i == 1_${ik}$ ) then do j = 1, m phantom(j) = zero end do - call stdlib_dorbdb5( p, m-p, q, phantom(1), 1, phantom(p+1), 1,x11, ldx11, x21, & + call stdlib${ii}$_dorbdb5( p, m-p, q, phantom(1_${ik}$), 1_${ik}$, phantom(p+1), 1_${ik}$,x11, ldx11, x21, & ldx21, work(iorbdb5),lorbdb5, childinfo ) - call stdlib_dscal( p, negone, phantom(1), 1 ) - call stdlib_dlarfgp( p, phantom(1), phantom(2), 1, taup1(1) ) - call stdlib_dlarfgp( m-p, phantom(p+1), phantom(p+2), 1, taup2(1) ) - theta(i) = atan2( phantom(1), phantom(p+1) ) + call stdlib${ii}$_dscal( p, negone, phantom(1_${ik}$), 1_${ik}$ ) + call stdlib${ii}$_dlarfgp( p, phantom(1_${ik}$), phantom(2_${ik}$), 1_${ik}$, taup1(1_${ik}$) ) + call stdlib${ii}$_dlarfgp( m-p, phantom(p+1), phantom(p+2), 1_${ik}$, taup2(1_${ik}$) ) + theta(i) = atan2( phantom(1_${ik}$), phantom(p+1) ) c = cos( theta(i) ) s = sin( theta(i) ) - phantom(1) = one + phantom(1_${ik}$) = one phantom(p+1) = one - call stdlib_dlarf( 'L', p, q, phantom(1), 1, taup1(1), x11, ldx11,work(ilarf) ) + call stdlib${ii}$_dlarf( 'L', p, q, phantom(1_${ik}$), 1_${ik}$, taup1(1_${ik}$), x11, ldx11,work(ilarf) ) - call stdlib_dlarf( 'L', m-p, q, phantom(p+1), 1, taup2(1), x21,ldx21, work(ilarf)& + call stdlib${ii}$_dlarf( 'L', m-p, q, phantom(p+1), 1_${ik}$, taup2(1_${ik}$), x21,ldx21, work(ilarf)& ) else - call stdlib_dorbdb5( p-i+1, m-p-i+1, q-i+1, x11(i,i-1), 1,x21(i,i-1), 1, x11(i,i)& + call stdlib${ii}$_dorbdb5( p-i+1, m-p-i+1, q-i+1, x11(i,i-1), 1_${ik}$,x21(i,i-1), 1_${ik}$, x11(i,i)& , ldx11, x21(i,i),ldx21, work(iorbdb5), lorbdb5, childinfo ) - call stdlib_dscal( p-i+1, negone, x11(i,i-1), 1 ) - call stdlib_dlarfgp( p-i+1, x11(i,i-1), x11(i+1,i-1), 1, taup1(i) ) - call stdlib_dlarfgp( m-p-i+1, x21(i,i-1), x21(i+1,i-1), 1,taup2(i) ) + call stdlib${ii}$_dscal( p-i+1, negone, x11(i,i-1), 1_${ik}$ ) + call stdlib${ii}$_dlarfgp( p-i+1, x11(i,i-1), x11(i+1,i-1), 1_${ik}$, taup1(i) ) + call stdlib${ii}$_dlarfgp( m-p-i+1, x21(i,i-1), x21(i+1,i-1), 1_${ik}$,taup2(i) ) theta(i) = atan2( x11(i,i-1), x21(i,i-1) ) c = cos( theta(i) ) s = sin( theta(i) ) x11(i,i-1) = one x21(i,i-1) = one - call stdlib_dlarf( 'L', p-i+1, q-i+1, x11(i,i-1), 1, taup1(i),x11(i,i), ldx11, & + call stdlib${ii}$_dlarf( 'L', p-i+1, q-i+1, x11(i,i-1), 1_${ik}$, taup1(i),x11(i,i), ldx11, & work(ilarf) ) - call stdlib_dlarf( 'L', m-p-i+1, q-i+1, x21(i,i-1), 1, taup2(i),x21(i,i), ldx21, & + call stdlib${ii}$_dlarf( 'L', m-p-i+1, q-i+1, x21(i,i-1), 1_${ik}$, taup2(i),x21(i,i), ldx21, & work(ilarf) ) end if - call stdlib_drot( q-i+1, x11(i,i), ldx11, x21(i,i), ldx21, s, -c ) - call stdlib_dlarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) + call stdlib${ii}$_drot( q-i+1, x11(i,i), ldx11, x21(i,i), ldx21, s, -c ) + call stdlib${ii}$_dlarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) c = x21(i,i) x21(i,i) = one - call stdlib_dlarf( 'R', p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i+1,i), ldx11, & + call stdlib${ii}$_dlarf( 'R', p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i+1,i), ldx11, & work(ilarf) ) - call stdlib_dlarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & + call stdlib${ii}$_dlarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & work(ilarf) ) if( i < m-q ) then - s = sqrt( stdlib_dnrm2( p-i, x11(i+1,i), 1 )**2+ stdlib_dnrm2( m-p-i, x21(i+1,i),& - 1 )**2 ) + s = sqrt( stdlib${ii}$_dnrm2( p-i, x11(i+1,i), 1_${ik}$ )**2_${ik}$+ stdlib${ii}$_dnrm2( m-p-i, x21(i+1,i),& + 1_${ik}$ )**2_${ik}$ ) phi(i) = atan2( s, c ) end if end do ! reduce the bottom-right portion of x11 to [ i 0 ] do i = m - q + 1, p - call stdlib_dlarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) + call stdlib${ii}$_dlarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) x11(i,i) = one - call stdlib_dlarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & + call stdlib${ii}$_dlarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & work(ilarf) ) - call stdlib_dlarf( 'R', q-p, q-i+1, x11(i,i), ldx11, tauq1(i),x21(m-q+1,i), ldx21, & + call stdlib${ii}$_dlarf( 'R', q-p, q-i+1, x11(i,i), ldx11, tauq1(i),x21(m-q+1,i), ldx21, & work(ilarf) ) end do ! reduce the bottom-right portion of x21 to [ 0 i ] do i = p + 1, q - call stdlib_dlarfgp( q-i+1, x21(m-q+i-p,i), x21(m-q+i-p,i+1), ldx21,tauq1(i) ) + call stdlib${ii}$_dlarfgp( q-i+1, x21(m-q+i-p,i), x21(m-q+i-p,i+1), ldx21,tauq1(i) ) x21(m-q+i-p,i) = one - call stdlib_dlarf( 'R', q-i, q-i+1, x21(m-q+i-p,i), ldx21, tauq1(i),x21(m-q+i-p+1,i)& + call stdlib${ii}$_dlarf( 'R', q-i, q-i+1, x21(m-q+i-p,i), ldx21, tauq1(i),x21(m-q+i-p+1,i)& , ldx21, work(ilarf) ) end do return - end subroutine stdlib_dorbdb4 + end subroutine stdlib${ii}$_dorbdb4 - subroutine stdlib_dorcsd2by1( jobu1, jobu2, jobv1t, m, p, q, x11, ldx11,x21, ldx21, theta, & + subroutine stdlib${ii}$_dorcsd2by1( jobu1, jobu2, jobv1t, m, p, q, x11, ldx11,x21, ldx21, theta, & !! DORCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with !! orthonormal columns that has been partitioned into a 2-by-1 block !! structure: @@ -53380,48 +53380,48 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobu1, jobu2, jobv1t - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldu1, ldu2, ldv1t, lwork, ldx11, ldx21, m, p, q + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldu1, ldu2, ldv1t, lwork, ldx11, ldx21, m, p, q ! Array Arguments real(dp), intent(out) :: theta(*) real(dp), intent(out) :: u1(ldu1,*), u2(ldu2,*), v1t(ldv1t,*), work(*) real(dp), intent(inout) :: x11(ldx11,*), x21(ldx21,*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: childinfo, i, ib11d, ib11e, ib12d, ib12e, ib21d, ib21e, ib22d, ib22e, & + integer(${ik}$) :: childinfo, i, ib11d, ib11e, ib12d, ib12e, ib21d, ib21e, ib22d, ib22e, & ibbcsd, iorbdb, iorglq, iorgqr, iphi, itaup1, itaup2, itauq1, j, lbbcsd, lorbdb, & lorglq, lorglqmin, lorglqopt, lorgqr, lorgqrmin, lorgqropt, lworkmin, lworkopt, & r logical(lk) :: lquery, wantu1, wantu2, wantv1t ! Local Arrays - real(dp) :: dum1(1), dum2(1,1) + real(dp) :: dum1(1_${ik}$), dum2(1_${ik}$,1_${ik}$) ! Intrinsic Function intrinsic :: int,max,min ! Executable Statements ! test input arguments - info = 0 + info = 0_${ik}$ wantu1 = stdlib_lsame( jobu1, 'Y' ) wantu2 = stdlib_lsame( jobu2, 'Y' ) wantv1t = stdlib_lsame( jobv1t, 'Y' ) - lquery = lwork == -1 - if( m < 0 ) then - info = -4 - else if( p < 0 .or. p > m ) then - info = -5 - else if( q < 0 .or. q > m ) then - info = -6 - else if( ldx11 < max( 1, p ) ) then - info = -8 - else if( ldx21 < max( 1, m-p ) ) then - info = -10 - else if( wantu1 .and. ldu1 < max( 1, p ) ) then - info = -13 - else if( wantu2 .and. ldu2 < max( 1, m - p ) ) then - info = -15 - else if( wantv1t .and. ldv1t < max( 1, q ) ) then - info = -17 + lquery = lwork == -1_${ik}$ + if( m < 0_${ik}$ ) then + info = -4_${ik}$ + else if( p < 0_${ik}$ .or. p > m ) then + info = -5_${ik}$ + else if( q < 0_${ik}$ .or. q > m ) then + info = -6_${ik}$ + else if( ldx11 < max( 1_${ik}$, p ) ) then + info = -8_${ik}$ + else if( ldx21 < max( 1_${ik}$, m-p ) ) then + info = -10_${ik}$ + else if( wantu1 .and. ldu1 < max( 1_${ik}$, p ) ) then + info = -13_${ik}$ + else if( wantu2 .and. ldu2 < max( 1_${ik}$, m - p ) ) then + info = -15_${ik}$ + else if( wantv1t .and. ldv1t < max( 1_${ik}$, q ) ) then + info = -17_${ik}$ end if r = min( p, m-p, q, m-q ) ! compute workspace @@ -53435,143 +53435,143 @@ module stdlib_linalg_lapack_d ! | taup2 (max(1,m-p)) | b11e (r-1) | ! | tauq1 (max(1,q)) | b12d (r) | ! |-----------------------------------------| b12e (r-1) | - ! | stdlib_dorbdb work | stdlib_dorgqr work | stdlib_dorglq work | b21d (r) | + ! | stdlib${ii}$_dorbdb work | stdlib${ii}$_dorgqr work | stdlib${ii}$_dorglq work | b21d (r) | ! | | | | b21e (r-1) | ! | | | | b22d (r) | ! | | | | b22e (r-1) | - ! | | | | stdlib_dbbcsd work | + ! | | | | stdlib${ii}$_dbbcsd work | ! |-------------------------------------------------------| - if( info == 0 ) then - iphi = 2 - ib11d = iphi + max( 1, r-1 ) - ib11e = ib11d + max( 1, r ) - ib12d = ib11e + max( 1, r - 1 ) - ib12e = ib12d + max( 1, r ) - ib21d = ib12e + max( 1, r - 1 ) - ib21e = ib21d + max( 1, r ) - ib22d = ib21e + max( 1, r - 1 ) - ib22e = ib22d + max( 1, r ) - ibbcsd = ib22e + max( 1, r - 1 ) - itaup1 = iphi + max( 1, r-1 ) - itaup2 = itaup1 + max( 1, p ) - itauq1 = itaup2 + max( 1, m-p ) - iorbdb = itauq1 + max( 1, q ) - iorgqr = itauq1 + max( 1, q ) - iorglq = itauq1 + max( 1, q ) - lorgqrmin = 1 - lorgqropt = 1 - lorglqmin = 1 - lorglqopt = 1 + if( info == 0_${ik}$ ) then + iphi = 2_${ik}$ + ib11d = iphi + max( 1_${ik}$, r-1 ) + ib11e = ib11d + max( 1_${ik}$, r ) + ib12d = ib11e + max( 1_${ik}$, r - 1_${ik}$ ) + ib12e = ib12d + max( 1_${ik}$, r ) + ib21d = ib12e + max( 1_${ik}$, r - 1_${ik}$ ) + ib21e = ib21d + max( 1_${ik}$, r ) + ib22d = ib21e + max( 1_${ik}$, r - 1_${ik}$ ) + ib22e = ib22d + max( 1_${ik}$, r ) + ibbcsd = ib22e + max( 1_${ik}$, r - 1_${ik}$ ) + itaup1 = iphi + max( 1_${ik}$, r-1 ) + itaup2 = itaup1 + max( 1_${ik}$, p ) + itauq1 = itaup2 + max( 1_${ik}$, m-p ) + iorbdb = itauq1 + max( 1_${ik}$, q ) + iorgqr = itauq1 + max( 1_${ik}$, q ) + iorglq = itauq1 + max( 1_${ik}$, q ) + lorgqrmin = 1_${ik}$ + lorgqropt = 1_${ik}$ + lorglqmin = 1_${ik}$ + lorglqopt = 1_${ik}$ if( r == q ) then - call stdlib_dorbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,dum1, dum1, dum1, & - dum1, work,-1, childinfo ) - lorbdb = int( work(1),KIND=ilp) - if( wantu1 .and. p > 0 ) then - call stdlib_dorgqr( p, p, q, u1, ldu1, dum1, work(1), -1,childinfo ) + call stdlib${ii}$_dorbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,dum1, dum1, dum1, & + dum1, work,-1_${ik}$, childinfo ) + lorbdb = int( work(1_${ik}$),KIND=${ik}$) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_dorgqr( p, p, q, u1, ldu1, dum1, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) endif - if( wantu2 .and. m-p > 0 ) then - call stdlib_dorgqr( m-p, m-p, q, u2, ldu2, dum1, work(1),-1, childinfo ) + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_dorgqr( m-p, m-p, q, u2, ldu2, dum1, work(1_${ik}$),-1_${ik}$, childinfo ) lorgqrmin = max( lorgqrmin, m-p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_dorglq( q-1, q-1, q-1, v1t, ldv1t,dum1, work(1), -1, childinfo ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_dorglq( q-1, q-1, q-1, v1t, ldv1t,dum1, work(1_${ik}$), -1_${ik}$, childinfo ) lorglqmin = max( lorglqmin, q-1 ) - lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) + lorglqopt = max( lorglqopt, int( work(1_${ik}$),KIND=${ik}$) ) end if - call stdlib_dbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,dum1, u1, & - ldu1, u2, ldu2, v1t, ldv1t,dum2, 1, dum1, dum1, dum1,dum1, dum1, dum1, dum1,dum1,& - work(1), -1, childinfo ) - lbbcsd = int( work(1),KIND=ilp) + call stdlib${ii}$_dbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,dum1, u1, & + ldu1, u2, ldu2, v1t, ldv1t,dum2, 1_${ik}$, dum1, dum1, dum1,dum1, dum1, dum1, dum1,dum1,& + work(1_${ik}$), -1_${ik}$, childinfo ) + lbbcsd = int( work(1_${ik}$),KIND=${ik}$) else if( r == p ) then - call stdlib_dorbdb2( m, p, q, x11, ldx11, x21, ldx21, theta,dum1, dum1, dum1, & - dum1,work(1), -1, childinfo ) - lorbdb = int( work(1),KIND=ilp) - if( wantu1 .and. p > 0 ) then - call stdlib_dorgqr( p-1, p-1, p-1, u1(2,2), ldu1, dum1,work(1), -1, childinfo & + call stdlib${ii}$_dorbdb2( m, p, q, x11, ldx11, x21, ldx21, theta,dum1, dum1, dum1, & + dum1,work(1_${ik}$), -1_${ik}$, childinfo ) + lorbdb = int( work(1_${ik}$),KIND=${ik}$) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_dorgqr( p-1, p-1, p-1, u1(2_${ik}$,2_${ik}$), ldu1, dum1,work(1_${ik}$), -1_${ik}$, childinfo & ) lorgqrmin = max( lorgqrmin, p-1 ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_dorgqr( m-p, m-p, q, u2, ldu2, dum1, work(1),-1, childinfo ) + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_dorgqr( m-p, m-p, q, u2, ldu2, dum1, work(1_${ik}$),-1_${ik}$, childinfo ) lorgqrmin = max( lorgqrmin, m-p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_dorglq( q, q, r, v1t, ldv1t, dum1, work(1), -1,childinfo ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_dorglq( q, q, r, v1t, ldv1t, dum1, work(1_${ik}$), -1_${ik}$,childinfo ) lorglqmin = max( lorglqmin, q ) - lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) + lorglqopt = max( lorglqopt, int( work(1_${ik}$),KIND=${ik}$) ) end if - call stdlib_dbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,dum1, v1t, & - ldv1t, dum2, 1, u1, ldu1,u2, ldu2, dum1, dum1, dum1,dum1, dum1, dum1, dum1,dum1, & - work(1), -1, childinfo ) - lbbcsd = int( work(1),KIND=ilp) + call stdlib${ii}$_dbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,dum1, v1t, & + ldv1t, dum2, 1_${ik}$, u1, ldu1,u2, ldu2, dum1, dum1, dum1,dum1, dum1, dum1, dum1,dum1, & + work(1_${ik}$), -1_${ik}$, childinfo ) + lbbcsd = int( work(1_${ik}$),KIND=${ik}$) else if( r == m-p ) then - call stdlib_dorbdb3( m, p, q, x11, ldx11, x21, ldx21, theta,dum1, dum1, dum1, & - dum1,work(1), -1, childinfo ) - lorbdb = int( work(1),KIND=ilp) - if( wantu1 .and. p > 0 ) then - call stdlib_dorgqr( p, p, q, u1, ldu1, dum1, work(1), -1,childinfo ) + call stdlib${ii}$_dorbdb3( m, p, q, x11, ldx11, x21, ldx21, theta,dum1, dum1, dum1, & + dum1,work(1_${ik}$), -1_${ik}$, childinfo ) + lorbdb = int( work(1_${ik}$),KIND=${ik}$) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_dorgqr( p, p, q, u1, ldu1, dum1, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_dorgqr( m-p-1, m-p-1, m-p-1, u2(2,2), ldu2,dum1, work(1), -1, & + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_dorgqr( m-p-1, m-p-1, m-p-1, u2(2_${ik}$,2_${ik}$), ldu2,dum1, work(1_${ik}$), -1_${ik}$, & childinfo ) lorgqrmin = max( lorgqrmin, m-p-1 ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_dorglq( q, q, r, v1t, ldv1t, dum1, work(1), -1,childinfo ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_dorglq( q, q, r, v1t, ldv1t, dum1, work(1_${ik}$), -1_${ik}$,childinfo ) lorglqmin = max( lorglqmin, q ) - lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) - end if - call stdlib_dbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, dum1, & - dum2, 1, v1t, ldv1t, u2,ldu2, u1, ldu1, dum1, dum1, dum1,dum1, dum1, dum1, dum1,& - dum1, work(1), -1, childinfo ) - lbbcsd = int( work(1),KIND=ilp) - else - call stdlib_dorbdb4( m, p, q, x11, ldx11, x21, ldx21, theta,dum1, dum1, dum1, & - dum1,dum1, work(1), -1, childinfo ) - lorbdb = m + int( work(1),KIND=ilp) - if( wantu1 .and. p > 0 ) then - call stdlib_dorgqr( p, p, m-q, u1, ldu1, dum1, work(1), -1,childinfo ) + lorglqopt = max( lorglqopt, int( work(1_${ik}$),KIND=${ik}$) ) + end if + call stdlib${ii}$_dbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, dum1, & + dum2, 1_${ik}$, v1t, ldv1t, u2,ldu2, u1, ldu1, dum1, dum1, dum1,dum1, dum1, dum1, dum1,& + dum1, work(1_${ik}$), -1_${ik}$, childinfo ) + lbbcsd = int( work(1_${ik}$),KIND=${ik}$) + else + call stdlib${ii}$_dorbdb4( m, p, q, x11, ldx11, x21, ldx21, theta,dum1, dum1, dum1, & + dum1,dum1, work(1_${ik}$), -1_${ik}$, childinfo ) + lorbdb = m + int( work(1_${ik}$),KIND=${ik}$) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_dorgqr( p, p, m-q, u1, ldu1, dum1, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_dorgqr( m-p, m-p, m-q, u2, ldu2, dum1, work(1),-1, childinfo ) + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_dorgqr( m-p, m-p, m-q, u2, ldu2, dum1, work(1_${ik}$),-1_${ik}$, childinfo ) lorgqrmin = max( lorgqrmin, m-p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_dorglq( q, q, q, v1t, ldv1t, dum1, work(1), -1,childinfo ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_dorglq( q, q, q, v1t, ldv1t, dum1, work(1_${ik}$), -1_${ik}$,childinfo ) lorglqmin = max( lorglqmin, q ) - lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) + lorglqopt = max( lorglqopt, int( work(1_${ik}$),KIND=${ik}$) ) end if - call stdlib_dbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, dum1, u2, & - ldu2, u1, ldu1, dum2,1, v1t, ldv1t, dum1, dum1, dum1,dum1, dum1, dum1, dum1,dum1,& - work(1), -1, childinfo ) - lbbcsd = int( work(1),KIND=ilp) + call stdlib${ii}$_dbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, dum1, u2, & + ldu2, u1, ldu1, dum2,1_${ik}$, v1t, ldv1t, dum1, dum1, dum1,dum1, dum1, dum1, dum1,dum1,& + work(1_${ik}$), -1_${ik}$, childinfo ) + lbbcsd = int( work(1_${ik}$),KIND=${ik}$) end if lworkmin = max( iorbdb+lorbdb-1,iorgqr+lorgqrmin-1,iorglq+lorglqmin-1,ibbcsd+lbbcsd-& - 1 ) + 1_${ik}$ ) lworkopt = max( iorbdb+lorbdb-1,iorgqr+lorgqropt-1,iorglq+lorglqopt-1,ibbcsd+lbbcsd-& - 1 ) - work(1) = lworkopt + 1_${ik}$ ) + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not.lquery ) then - info = -19 + info = -19_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'DORCSD2BY1', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DORCSD2BY1', -info ) return else if( lquery ) then return @@ -53583,116 +53583,116 @@ module stdlib_linalg_lapack_d if( r == q ) then ! case 1: r = q ! simultaneously bidiagonalize x11 and x21 - call stdlib_dorbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,work(iphi), work(itaup1)& + call stdlib${ii}$_dorbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,work(iphi), work(itaup1)& , work(itaup2),work(itauq1), work(iorbdb), lorbdb, childinfo ) ! accumulate householder reflectors - if( wantu1 .and. p > 0 ) then - call stdlib_dlacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) - call stdlib_dorgqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_dlacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) + call stdlib${ii}$_dorgqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & childinfo ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_dlacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) - call stdlib_dorgqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_dlacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) + call stdlib${ii}$_dorgqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & childinfo ) end if - if( wantv1t .and. q > 0 ) then - v1t(1,1) = one + if( wantv1t .and. q > 0_${ik}$ ) then + v1t(1_${ik}$,1_${ik}$) = one do j = 2, q - v1t(1,j) = zero - v1t(j,1) = zero + v1t(1_${ik}$,j) = zero + v1t(j,1_${ik}$) = zero end do - call stdlib_dlacpy( 'U', q-1, q-1, x21(1,2), ldx21, v1t(2,2),ldv1t ) - call stdlib_dorglq( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),work(iorglq), & + call stdlib${ii}$_dlacpy( 'U', q-1, q-1, x21(1_${ik}$,2_${ik}$), ldx21, v1t(2_${ik}$,2_${ik}$),ldv1t ) + call stdlib${ii}$_dorglq( q-1, q-1, q-1, v1t(2_${ik}$,2_${ik}$), ldv1t, work(itauq1),work(iorglq), & lorglq, childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_dbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,work(iphi), u1, & - ldu1, u2, ldu2, v1t, ldv1t,dum2, 1, work(ib11d), work(ib11e),work(ib12d), work(& + call stdlib${ii}$_dbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,work(iphi), u1, & + ldu1, u2, ldu2, v1t, ldv1t,dum2, 1_${ik}$, work(ib11d), work(ib11e),work(ib12d), work(& ib12e), work(ib21d),work(ib21e), work(ib22d), work(ib22e),work(ibbcsd), lbbcsd, & childinfo ) ! permute rows and columns to place zero submatrices in ! preferred positions - if( q > 0 .and. wantu2 ) then + if( q > 0_${ik}$ .and. wantu2 ) then do i = 1, q iwork(i) = m - p - q + i end do do i = q + 1, m - p iwork(i) = i - q end do - call stdlib_dlapmt( .false., m-p, m-p, u2, ldu2, iwork ) + call stdlib${ii}$_dlapmt( .false., m-p, m-p, u2, ldu2, iwork ) end if else if( r == p ) then ! case 2: r = p ! simultaneously bidiagonalize x11 and x21 - call stdlib_dorbdb2( m, p, q, x11, ldx11, x21, ldx21, theta,work(iphi), work(itaup1)& + call stdlib${ii}$_dorbdb2( m, p, q, x11, ldx11, x21, ldx21, theta,work(iphi), work(itaup1)& , work(itaup2),work(itauq1), work(iorbdb), lorbdb, childinfo ) ! accumulate householder reflectors - if( wantu1 .and. p > 0 ) then - u1(1,1) = one + if( wantu1 .and. p > 0_${ik}$ ) then + u1(1_${ik}$,1_${ik}$) = one do j = 2, p - u1(1,j) = zero - u1(j,1) = zero + u1(1_${ik}$,j) = zero + u1(j,1_${ik}$) = zero end do - call stdlib_dlacpy( 'L', p-1, p-1, x11(2,1), ldx11, u1(2,2), ldu1 ) - call stdlib_dorgqr( p-1, p-1, p-1, u1(2,2), ldu1, work(itaup1),work(iorgqr), & + call stdlib${ii}$_dlacpy( 'L', p-1, p-1, x11(2_${ik}$,1_${ik}$), ldx11, u1(2_${ik}$,2_${ik}$), ldu1 ) + call stdlib${ii}$_dorgqr( p-1, p-1, p-1, u1(2_${ik}$,2_${ik}$), ldu1, work(itaup1),work(iorgqr), & lorgqr, childinfo ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_dlacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) - call stdlib_dorgqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_dlacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) + call stdlib${ii}$_dorgqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & childinfo ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_dlacpy( 'U', p, q, x11, ldx11, v1t, ldv1t ) - call stdlib_dorglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_dlacpy( 'U', p, q, x11, ldx11, v1t, ldv1t ) + call stdlib${ii}$_dorglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_dbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,work(iphi), v1t, & - ldv1t, dum2, 1, u1, ldu1, u2,ldu2, work(ib11d), work(ib11e), work(ib12d),work(ib12e)& + call stdlib${ii}$_dbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,work(iphi), v1t, & + ldv1t, dum2, 1_${ik}$, u1, ldu1, u2,ldu2, work(ib11d), work(ib11e), work(ib12d),work(ib12e)& , work(ib21d), work(ib21e),work(ib22d), work(ib22e), work(ibbcsd), lbbcsd,childinfo & ) ! permute rows and columns to place identity submatrices in ! preferred positions - if( q > 0 .and. wantu2 ) then + if( q > 0_${ik}$ .and. wantu2 ) then do i = 1, q iwork(i) = m - p - q + i end do do i = q + 1, m - p iwork(i) = i - q end do - call stdlib_dlapmt( .false., m-p, m-p, u2, ldu2, iwork ) + call stdlib${ii}$_dlapmt( .false., m-p, m-p, u2, ldu2, iwork ) end if else if( r == m-p ) then ! case 3: r = m-p ! simultaneously bidiagonalize x11 and x21 - call stdlib_dorbdb3( m, p, q, x11, ldx11, x21, ldx21, theta,work(iphi), work(itaup1)& + call stdlib${ii}$_dorbdb3( m, p, q, x11, ldx11, x21, ldx21, theta,work(iphi), work(itaup1)& , work(itaup2),work(itauq1), work(iorbdb), lorbdb, childinfo ) ! accumulate householder reflectors - if( wantu1 .and. p > 0 ) then - call stdlib_dlacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) - call stdlib_dorgqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_dlacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) + call stdlib${ii}$_dorgqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & childinfo ) end if - if( wantu2 .and. m-p > 0 ) then - u2(1,1) = one + if( wantu2 .and. m-p > 0_${ik}$ ) then + u2(1_${ik}$,1_${ik}$) = one do j = 2, m-p - u2(1,j) = zero - u2(j,1) = zero + u2(1_${ik}$,j) = zero + u2(j,1_${ik}$) = zero end do - call stdlib_dlacpy( 'L', m-p-1, m-p-1, x21(2,1), ldx21, u2(2,2),ldu2 ) - call stdlib_dorgqr( m-p-1, m-p-1, m-p-1, u2(2,2), ldu2,work(itaup2), work(iorgqr)& + call stdlib${ii}$_dlacpy( 'L', m-p-1, m-p-1, x21(2_${ik}$,1_${ik}$), ldx21, u2(2_${ik}$,2_${ik}$),ldu2 ) + call stdlib${ii}$_dorgqr( m-p-1, m-p-1, m-p-1, u2(2_${ik}$,2_${ik}$), ldu2,work(itaup2), work(iorgqr)& , lorgqr, childinfo ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_dlacpy( 'U', m-p, q, x21, ldx21, v1t, ldv1t ) - call stdlib_dorglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_dlacpy( 'U', m-p, q, x21, ldx21, v1t, ldv1t ) + call stdlib${ii}$_dorglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_dbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, work(iphi), & - dum2, 1, v1t, ldv1t, u2,ldu2, u1, ldu1, work(ib11d), work(ib11e),work(ib12d), work(& + call stdlib${ii}$_dbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, work(iphi), & + dum2, 1_${ik}$, v1t, ldv1t, u2,ldu2, u1, ldu1, work(ib11d), work(ib11e),work(ib12d), work(& ib12e), work(ib21d),work(ib21e), work(ib22d), work(ib22e),work(ibbcsd), lbbcsd, & childinfo ) ! permute rows and columns to place identity submatrices in @@ -53705,51 +53705,51 @@ module stdlib_linalg_lapack_d iwork(i) = i - r end do if( wantu1 ) then - call stdlib_dlapmt( .false., p, q, u1, ldu1, iwork ) + call stdlib${ii}$_dlapmt( .false., p, q, u1, ldu1, iwork ) end if if( wantv1t ) then - call stdlib_dlapmr( .false., q, q, v1t, ldv1t, iwork ) + call stdlib${ii}$_dlapmr( .false., q, q, v1t, ldv1t, iwork ) end if end if else ! case 4: r = m-q ! simultaneously bidiagonalize x11 and x21 - call stdlib_dorbdb4( m, p, q, x11, ldx11, x21, ldx21, theta,work(iphi), work(itaup1)& + call stdlib${ii}$_dorbdb4( m, p, q, x11, ldx11, x21, ldx21, theta,work(iphi), work(itaup1)& , work(itaup2),work(itauq1), work(iorbdb), work(iorbdb+m),lorbdb-m, childinfo ) ! accumulate householder reflectors - if( wantu2 .and. m-p > 0 ) then - call stdlib_dcopy( m-p, work(iorbdb+p), 1, u2, 1 ) + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_dcopy( m-p, work(iorbdb+p), 1_${ik}$, u2, 1_${ik}$ ) end if - if( wantu1 .and. p > 0 ) then - call stdlib_dcopy( p, work(iorbdb), 1, u1, 1 ) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_dcopy( p, work(iorbdb), 1_${ik}$, u1, 1_${ik}$ ) do j = 2, p - u1(1,j) = zero + u1(1_${ik}$,j) = zero end do - call stdlib_dlacpy( 'L', p-1, m-q-1, x11(2,1), ldx11, u1(2,2),ldu1 ) - call stdlib_dorgqr( p, p, m-q, u1, ldu1, work(itaup1),work(iorgqr), lorgqr, & + call stdlib${ii}$_dlacpy( 'L', p-1, m-q-1, x11(2_${ik}$,1_${ik}$), ldx11, u1(2_${ik}$,2_${ik}$),ldu1 ) + call stdlib${ii}$_dorgqr( p, p, m-q, u1, ldu1, work(itaup1),work(iorgqr), lorgqr, & childinfo ) end if - if( wantu2 .and. m-p > 0 ) then + if( wantu2 .and. m-p > 0_${ik}$ ) then do j = 2, m-p - u2(1,j) = zero + u2(1_${ik}$,j) = zero end do - call stdlib_dlacpy( 'L', m-p-1, m-q-1, x21(2,1), ldx21, u2(2,2),ldu2 ) - call stdlib_dorgqr( m-p, m-p, m-q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & + call stdlib${ii}$_dlacpy( 'L', m-p-1, m-q-1, x21(2_${ik}$,1_${ik}$), ldx21, u2(2_${ik}$,2_${ik}$),ldu2 ) + call stdlib${ii}$_dorgqr( m-p, m-p, m-q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & childinfo ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_dlacpy( 'U', m-q, q, x21, ldx21, v1t, ldv1t ) - call stdlib_dlacpy( 'U', p-(m-q), q-(m-q), x11(m-q+1,m-q+1), ldx11,v1t(m-q+1,m-q+& - 1), ldv1t ) - call stdlib_dlacpy( 'U', -p+q, q-p, x21(m-q+1,p+1), ldx21,v1t(p+1,p+1), ldv1t ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_dlacpy( 'U', m-q, q, x21, ldx21, v1t, ldv1t ) + call stdlib${ii}$_dlacpy( 'U', p-(m-q), q-(m-q), x11(m-q+1,m-q+1), ldx11,v1t(m-q+1,m-q+& + 1_${ik}$), ldv1t ) + call stdlib${ii}$_dlacpy( 'U', -p+q, q-p, x21(m-q+1,p+1), ldx21,v1t(p+1,p+1), ldv1t ) - call stdlib_dorglq( q, q, q, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & + call stdlib${ii}$_dorglq( q, q, q, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_dbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, work(iphi), & - u2, ldu2, u1, ldu1, dum2,1, v1t, ldv1t, work(ib11d), work(ib11e),work(ib12d), work(& + call stdlib${ii}$_dbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, work(iphi), & + u2, ldu2, u1, ldu1, dum2,1_${ik}$, v1t, ldv1t, work(ib11d), work(ib11e),work(ib12d), work(& ib12e), work(ib21d),work(ib21e), work(ib22d), work(ib22e),work(ibbcsd), lbbcsd, & childinfo ) ! permute rows and columns to place identity submatrices in @@ -53762,18 +53762,18 @@ module stdlib_linalg_lapack_d iwork(i) = i - r end do if( wantu1 ) then - call stdlib_dlapmt( .false., p, p, u1, ldu1, iwork ) + call stdlib${ii}$_dlapmt( .false., p, p, u1, ldu1, iwork ) end if if( wantv1t ) then - call stdlib_dlapmr( .false., p, q, v1t, ldv1t, iwork ) + call stdlib${ii}$_dlapmr( .false., p, q, v1t, ldv1t, iwork ) end if end if end if return - end subroutine stdlib_dorcsd2by1 + end subroutine stdlib${ii}$_dorcsd2by1 - pure subroutine stdlib_dorgtr( uplo, n, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_dorgtr( uplo, n, a, lda, tau, work, lwork, info ) !! DORGTR generates a real orthogonal matrix Q which is defined as the !! product of n-1 elementary reflectors of order N, as returned by !! DSYTRD: @@ -53784,8 +53784,8 @@ module stdlib_linalg_lapack_d ! -- 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 real(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: tau(*) @@ -53794,45 +53794,45 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: lquery, upper - integer(ilp) :: i, iinfo, j, lwkopt, nb + integer(${ik}$) :: i, iinfo, j, lwkopt, nb ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${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 + if( n>1_${ik}$ ) then ! generate q(2:n,2:n) - call stdlib_dorgqr( n-1, n-1, n-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) + call stdlib${ii}$_dorgqr( n-1, n-1, n-1, a( 2_${ik}$, 2_${ik}$ ), lda, tau, work,lwork, iinfo ) end if end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_dorgtr + end subroutine stdlib${ii}$_dorgtr - pure subroutine stdlib_dorgtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) + pure subroutine stdlib${ii}$_dorgtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) !! DORGTSQR generates an M-by-N real matrix Q_out with orthonormal columns, !! which are the first N columns of a product of real orthogonal !! matrices of order M which are returned by DLATSQR @@ -53884,8 +53884,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: t(ldt,*) @@ -53894,85 +53894,85 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: lquery - integer(ilp) :: iinfo, ldc, lworkopt, lc, lw, nblocal, j + integer(${ik}$) :: iinfo, ldc, lworkopt, lc, lw, nblocal, j ! Intrinsic Functions intrinsic :: real,max,min ! Executable Statements ! test the input parameters - lquery = lwork==-1 - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 .or. mkd ) then + if( nb<=1_${ik}$ .or. nb>kd ) then ! use unblocked code - call stdlib_dpbtf2( uplo, n, kd, ab, ldab, info ) + call stdlib${ii}$_dpbtf2( uplo, n, kd, ab, ldab, info ) else ! use blocked code if( stdlib_lsame( uplo, 'U' ) ) then @@ -54159,9 +54159,9 @@ module stdlib_linalg_lapack_d loop_70: do i = 1, n, nb ib = min( nb, n-i+1 ) ! factorize the diagonal block - call stdlib_dpotf2( uplo, ib, ab( kd+1, i ), ldab-1, ii ) - if( ii/=0 ) then - info = i + ii - 1 + call stdlib${ii}$_dpotf2( uplo, ib, ab( kd+1, i ), ldab-1, ii ) + if( ii/=0_${ik}$ ) then + info = i + ii - 1_${ik}$ go to 150 end if if( i+ib<=n ) then @@ -54178,15 +54178,15 @@ module stdlib_linalg_lapack_d ! lies outside the band. i2 = min( kd-ib, n-i-ib+1 ) i3 = min( ib, n-i-kd+1 ) - if( i2>0 ) then + if( i2>0_${ik}$ ) then ! update a12 - call stdlib_dtrsm( 'LEFT', 'UPPER', 'TRANSPOSE','NON-UNIT', ib, i2, one,& + call stdlib${ii}$_dtrsm( 'LEFT', 'UPPER', 'TRANSPOSE','NON-UNIT', ib, i2, one,& ab( kd+1, i ),ldab-1, ab( kd+1-ib, i+ib ), ldab-1 ) ! update a22 - call stdlib_dsyrk( 'UPPER', 'TRANSPOSE', i2, ib, -one,ab( kd+1-ib, i+ib & + call stdlib${ii}$_dsyrk( 'UPPER', 'TRANSPOSE', i2, ib, -one,ab( kd+1-ib, i+ib & ), ldab-1, one,ab( kd+1, i+ib ), ldab-1 ) end if - if( i3>0 ) then + if( i3>0_${ik}$ ) then ! copy the lower triangle of a13 into the work array. do jj = 1, i3 do ii = jj, ib @@ -54194,14 +54194,14 @@ module stdlib_linalg_lapack_d end do end do ! update a13 (in the work array). - call stdlib_dtrsm( 'LEFT', 'UPPER', 'TRANSPOSE','NON-UNIT', ib, i3, one,& + call stdlib${ii}$_dtrsm( 'LEFT', 'UPPER', 'TRANSPOSE','NON-UNIT', ib, i3, one,& ab( kd+1, i ),ldab-1, work, ldwork ) ! update a23 - if( i2>0 )call stdlib_dgemm( 'TRANSPOSE', 'NO TRANSPOSE', i2, i3,ib, -& - one, ab( kd+1-ib, i+ib ),ldab-1, work, ldwork, one,ab( 1+ib, i+kd ), & + if( i2>0_${ik}$ )call stdlib${ii}$_dgemm( 'TRANSPOSE', 'NO TRANSPOSE', i2, i3,ib, -& + one, ab( kd+1-ib, i+ib ),ldab-1, work, ldwork, one,ab( 1_${ik}$+ib, i+kd ), & ldab-1 ) ! update a33 - call stdlib_dsyrk( 'UPPER', 'TRANSPOSE', i3, ib, -one,work, ldwork, one,& + call stdlib${ii}$_dsyrk( 'UPPER', 'TRANSPOSE', i3, ib, -one,work, ldwork, one,& ab( kd+1, i+kd ),ldab-1 ) ! copy the lower triangle of a13 back into place. do jj = 1, i3 @@ -54226,9 +54226,9 @@ module stdlib_linalg_lapack_d loop_140: do i = 1, n, nb ib = min( nb, n-i+1 ) ! factorize the diagonal block - call stdlib_dpotf2( uplo, ib, ab( 1, i ), ldab-1, ii ) - if( ii/=0 ) then - info = i + ii - 1 + call stdlib${ii}$_dpotf2( uplo, ib, ab( 1_${ik}$, i ), ldab-1, ii ) + if( ii/=0_${ik}$ ) then + info = i + ii - 1_${ik}$ go to 150 end if if( i+ib<=n ) then @@ -54245,15 +54245,15 @@ module stdlib_linalg_lapack_d ! lies outside the band. i2 = min( kd-ib, n-i-ib+1 ) i3 = min( ib, n-i-kd+1 ) - if( i2>0 ) then + if( i2>0_${ik}$ ) then ! update a21 - call stdlib_dtrsm( 'RIGHT', 'LOWER', 'TRANSPOSE','NON-UNIT', i2, ib, & - one, ab( 1, i ),ldab-1, ab( 1+ib, i ), ldab-1 ) + call stdlib${ii}$_dtrsm( 'RIGHT', 'LOWER', 'TRANSPOSE','NON-UNIT', i2, ib, & + one, ab( 1_${ik}$, i ),ldab-1, ab( 1_${ik}$+ib, i ), ldab-1 ) ! update a22 - call stdlib_dsyrk( 'LOWER', 'NO TRANSPOSE', i2, ib, -one,ab( 1+ib, i ), & - ldab-1, one,ab( 1, i+ib ), ldab-1 ) + call stdlib${ii}$_dsyrk( 'LOWER', 'NO TRANSPOSE', i2, ib, -one,ab( 1_${ik}$+ib, i ), & + ldab-1, one,ab( 1_${ik}$, i+ib ), ldab-1 ) end if - if( i3>0 ) then + if( i3>0_${ik}$ ) then ! copy the upper triangle of a31 into the work array. do jj = 1, ib do ii = 1, min( jj, i3 ) @@ -54261,15 +54261,15 @@ module stdlib_linalg_lapack_d end do end do ! update a31 (in the work array). - call stdlib_dtrsm( 'RIGHT', 'LOWER', 'TRANSPOSE','NON-UNIT', i3, ib, & - one, ab( 1, i ),ldab-1, work, ldwork ) + call stdlib${ii}$_dtrsm( 'RIGHT', 'LOWER', 'TRANSPOSE','NON-UNIT', i3, ib, & + one, ab( 1_${ik}$, i ),ldab-1, work, ldwork ) ! update a32 - if( i2>0 )call stdlib_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', i3, i2,ib, -& - one, work, ldwork,ab( 1+ib, i ), ldab-1, one,ab( 1+kd-ib, i+ib ), ldab-& - 1 ) + if( i2>0_${ik}$ )call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', i3, i2,ib, -& + one, work, ldwork,ab( 1_${ik}$+ib, i ), ldab-1, one,ab( 1_${ik}$+kd-ib, i+ib ), ldab-& + 1_${ik}$ ) ! update a33 - call stdlib_dsyrk( 'LOWER', 'NO TRANSPOSE', i3, ib, -one,work, ldwork, & - one, ab( 1, i+kd ),ldab-1 ) + call stdlib${ii}$_dsyrk( 'LOWER', 'NO TRANSPOSE', i3, ib, -one,work, ldwork, & + one, ab( 1_${ik}$, i+kd ),ldab-1 ) ! copy the upper triangle of a31 back into place. do jj = 1, ib do ii = 1, min( jj, i3 ) @@ -54284,10 +54284,10 @@ module stdlib_linalg_lapack_d return 150 continue return - end subroutine stdlib_dpbtrf + end subroutine stdlib${ii}$_dpbtrf - pure subroutine stdlib_dpftri( transr, uplo, n, a, info ) + pure subroutine stdlib${ii}$_dpftri( transr, uplo, n, a, info ) !! DPFTRI computes the inverse of a (real) symmetric positive definite !! matrix A using the Cholesky factorization A = U**T*U or A = L*L**T !! computed by DPFTRF. @@ -54296,52 +54296,52 @@ module stdlib_linalg_lapack_d ! -- 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 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n ! Array Arguments - real(dp), intent(inout) :: a(0:*) + real(dp), intent(inout) :: a(0_${ik}$:*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, nisodd, normaltransr - integer(ilp) :: n1, n2, k + integer(${ik}$) :: n1, n2, k ! Intrinsic Functions intrinsic :: 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 + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'DPFTRI', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DPFTRI', -info ) return end if ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. - call stdlib_dtftri( transr, uplo, 'N', n, a, info ) + call stdlib${ii}$_dtftri( transr, uplo, 'N', n, a, info ) if( info>0 )return ! if n is odd, set nisodd = .true. ! if n is even, set k = n/2 and nisodd = .false. - if( mod( n, 2 )==0 ) then - k = n / 2 + if( mod( n, 2_${ik}$ )==0_${ik}$ ) then + k = n / 2_${ik}$ nisodd = .false. else nisodd = .true. end if ! set n1 and n2 depending on lower if( lower ) then - n2 = n / 2 + n2 = n / 2_${ik}$ n1 = n - n2 else - n1 = n / 2 + n1 = n / 2_${ik}$ n2 = n - n1 end if ! start execution of triangular matrix multiply: inv(u)*inv(u)^c or @@ -54354,41 +54354,41 @@ module stdlib_linalg_lapack_d ! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) ) ! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) - call stdlib_dlauum( 'L', n1, a( 0 ), n, info ) - call stdlib_dsyrk( 'L', 'T', n1, n2, one, a( n1 ), n, one,a( 0 ), n ) - call stdlib_dtrmm( 'L', 'U', 'N', 'N', n2, n1, one, a( n ), n,a( n1 ), n ) + call stdlib${ii}$_dlauum( 'L', n1, a( 0_${ik}$ ), n, info ) + call stdlib${ii}$_dsyrk( 'L', 'T', n1, n2, one, a( n1 ), n, one,a( 0_${ik}$ ), n ) + call stdlib${ii}$_dtrmm( 'L', 'U', 'N', 'N', n2, n1, one, a( n ), n,a( n1 ), n ) - call stdlib_dlauum( 'U', n2, a( n ), n, info ) + call stdlib${ii}$_dlauum( 'U', n2, a( n ), n, info ) else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) - call stdlib_dlauum( 'L', n1, a( n2 ), n, info ) - call stdlib_dsyrk( 'L', 'N', n1, n2, one, a( 0 ), n, one,a( n2 ), n ) - call stdlib_dtrmm( 'R', 'U', 'T', 'N', n1, n2, one, a( n1 ), n,a( 0 ), n ) + call stdlib${ii}$_dlauum( 'L', n1, a( n2 ), n, info ) + call stdlib${ii}$_dsyrk( 'L', 'N', n1, n2, one, a( 0_${ik}$ ), n, one,a( n2 ), n ) + call stdlib${ii}$_dtrmm( 'R', 'U', 'T', 'N', n1, n2, one, a( n1 ), n,a( 0_${ik}$ ), n ) - call stdlib_dlauum( 'U', n2, a( n1 ), n, info ) + call stdlib${ii}$_dlauum( 'U', n2, a( n1 ), n, info ) end if else ! n is odd and transr = 't' if( lower ) then ! srpa for lower, transpose, and n is odd ! t1 -> a(0), t2 -> a(1), s -> a(0+n1*n1) - call stdlib_dlauum( 'U', n1, a( 0 ), n1, info ) - call stdlib_dsyrk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0 ), n1 ) + call stdlib${ii}$_dlauum( 'U', n1, a( 0_${ik}$ ), n1, info ) + call stdlib${ii}$_dsyrk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0_${ik}$ ), n1 ) - call stdlib_dtrmm( 'R', 'L', 'N', 'N', n1, n2, one, a( 1 ), n1,a( n1*n1 ), n1 & + call stdlib${ii}$_dtrmm( 'R', 'L', 'N', 'N', n1, n2, one, a( 1_${ik}$ ), n1,a( n1*n1 ), n1 & ) - call stdlib_dlauum( 'L', n2, a( 1 ), n1, info ) + call stdlib${ii}$_dlauum( 'L', n2, a( 1_${ik}$ ), n1, info ) else ! srpa for upper, transpose, and n is odd ! t1 -> a(0+n2*n2), t2 -> a(0+n1*n2), s -> a(0) - call stdlib_dlauum( 'U', n1, a( n2*n2 ), n2, info ) - call stdlib_dsyrk( 'U', 'T', n1, n2, one, a( 0 ), n2, one,a( n2*n2 ), n2 ) + call stdlib${ii}$_dlauum( 'U', n1, a( n2*n2 ), n2, info ) + call stdlib${ii}$_dsyrk( 'U', 'T', n1, n2, one, a( 0_${ik}$ ), n2, one,a( n2*n2 ), n2 ) - call stdlib_dtrmm( 'L', 'L', 'T', 'N', n2, n1, one, a( n1*n2 ),n2, a( 0 ), n2 & + call stdlib${ii}$_dtrmm( 'L', 'L', 'T', 'N', n2, n1, one, a( n1*n2 ),n2, a( 0_${ik}$ ), n2 & ) - call stdlib_dlauum( 'L', n2, a( n1*n2 ), n2, info ) + call stdlib${ii}$_dlauum( 'L', n2, a( n1*n2 ), n2, info ) end if end if else @@ -54399,22 +54399,22 @@ module stdlib_linalg_lapack_d ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) - call stdlib_dlauum( 'L', k, a( 1 ), n+1, info ) - call stdlib_dsyrk( 'L', 'T', k, k, one, a( k+1 ), n+1, one,a( 1 ), n+1 ) + call stdlib${ii}$_dlauum( 'L', k, a( 1_${ik}$ ), n+1, info ) + call stdlib${ii}$_dsyrk( 'L', 'T', k, k, one, a( k+1 ), n+1, one,a( 1_${ik}$ ), n+1 ) - call stdlib_dtrmm( 'L', 'U', 'N', 'N', k, k, one, a( 0 ), n+1,a( k+1 ), n+1 ) + call stdlib${ii}$_dtrmm( 'L', 'U', 'N', 'N', k, k, one, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 ) - call stdlib_dlauum( 'U', k, a( 0 ), n+1, info ) + call stdlib${ii}$_dlauum( 'U', k, a( 0_${ik}$ ), n+1, info ) else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) - call stdlib_dlauum( 'L', k, a( k+1 ), n+1, info ) - call stdlib_dsyrk( 'L', 'N', k, k, one, a( 0 ), n+1, one,a( k+1 ), n+1 ) + call stdlib${ii}$_dlauum( 'L', k, a( k+1 ), n+1, info ) + call stdlib${ii}$_dsyrk( 'L', 'N', k, k, one, a( 0_${ik}$ ), n+1, one,a( k+1 ), n+1 ) - call stdlib_dtrmm( 'R', 'U', 'T', 'N', k, k, one, a( k ), n+1,a( 0 ), n+1 ) + call stdlib${ii}$_dtrmm( 'R', 'U', 'T', 'N', k, k, one, a( k ), n+1,a( 0_${ik}$ ), n+1 ) - call stdlib_dlauum( 'U', k, a( k ), n+1, info ) + call stdlib${ii}$_dlauum( 'U', k, a( k ), n+1, info ) end if else ! n is even and transr = 't' @@ -54422,30 +54422,30 @@ module stdlib_linalg_lapack_d ! srpa for lower, transpose, and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1), ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k - call stdlib_dlauum( 'U', k, a( k ), k, info ) - call stdlib_dsyrk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k ) + call stdlib${ii}$_dlauum( 'U', k, a( k ), k, info ) + call stdlib${ii}$_dsyrk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k ) - call stdlib_dtrmm( 'R', 'L', 'N', 'N', k, k, one, a( 0 ), k,a( k*( k+1 ) ), k & + call stdlib${ii}$_dtrmm( 'R', 'L', 'N', 'N', k, k, one, a( 0_${ik}$ ), k,a( k*( k+1 ) ), k & ) - call stdlib_dlauum( 'L', k, a( 0 ), k, info ) + call stdlib${ii}$_dlauum( 'L', k, a( 0_${ik}$ ), k, info ) else ! srpa for upper, transpose, and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0), ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k - call stdlib_dlauum( 'U', k, a( k*( k+1 ) ), k, info ) - call stdlib_dsyrk( 'U', 'T', k, k, one, a( 0 ), k, one,a( k*( k+1 ) ), k ) + call stdlib${ii}$_dlauum( 'U', k, a( k*( k+1 ) ), k, info ) + call stdlib${ii}$_dsyrk( 'U', 'T', k, k, one, a( 0_${ik}$ ), k, one,a( k*( k+1 ) ), k ) - call stdlib_dtrmm( 'L', 'L', 'T', 'N', k, k, one, a( k*k ), k,a( 0 ), k ) + call stdlib${ii}$_dtrmm( 'L', 'L', 'T', 'N', k, k, one, a( k*k ), k,a( 0_${ik}$ ), k ) - call stdlib_dlauum( 'L', k, a( k*k ), k, info ) + call stdlib${ii}$_dlauum( 'L', k, a( k*k ), k, info ) end if end if end if return - end subroutine stdlib_dpftri + end subroutine stdlib${ii}$_dpftri - pure subroutine stdlib_dpotrf( uplo, n, a, lda, info ) + pure subroutine stdlib${ii}$_dpotrf( uplo, n, a, lda, info ) !! DPOTRF computes the Cholesky factorization of a real symmetric !! positive definite matrix A. !! The factorization has the form @@ -54458,39 +54458,39 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: j, jb, nb + integer(${ik}$) :: j, jb, nb ! Intrinsic Functions intrinsic :: max,min ! 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}$, 'DPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code. - call stdlib_dpotrf2( uplo, n, a, lda, info ) + call stdlib${ii}$_dpotrf2( uplo, n, a, lda, info ) else ! use blocked code. if( upper ) then @@ -54499,15 +54499,15 @@ module stdlib_linalg_lapack_d ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) - call stdlib_dsyrk( 'UPPER', 'TRANSPOSE', jb, j-1, -one,a( 1, j ), lda, one, a(& + call stdlib${ii}$_dsyrk( 'UPPER', 'TRANSPOSE', jb, j-1, -one,a( 1_${ik}$, j ), lda, one, a(& j, j ), lda ) - call stdlib_dpotrf2( 'UPPER', jb, a( j, j ), lda, info ) + call stdlib${ii}$_dpotrf2( 'UPPER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block row. - call stdlib_dgemm( 'TRANSPOSE', 'NO TRANSPOSE', jb, n-j-jb+1,j-1, -one, a( & - 1, j ), lda, a( 1, j+jb ),lda, one, a( j, j+jb ), lda ) - call stdlib_dtrsm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',jb, n-j-jb+1, & + call stdlib${ii}$_dgemm( 'TRANSPOSE', 'NO TRANSPOSE', jb, n-j-jb+1,j-1, -one, a( & + 1_${ik}$, j ), lda, a( 1_${ik}$, j+jb ),lda, one, a( j, j+jb ), lda ) + call stdlib${ii}$_dtrsm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',jb, n-j-jb+1, & one, a( j, j ), lda,a( j, j+jb ), lda ) end if end do @@ -54517,15 +54517,15 @@ module stdlib_linalg_lapack_d ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) - call stdlib_dsyrk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1 ), lda, one,& + call stdlib${ii}$_dsyrk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1_${ik}$ ), lda, one,& a( j, j ), lda ) - call stdlib_dpotrf2( 'LOWER', jb, a( j, j ), lda, info ) + call stdlib${ii}$_dpotrf2( 'LOWER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block column. - call stdlib_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,j-1, -one, a( & - j+jb, 1 ), lda, a( j, 1 ),lda, one, a( j+jb, j ), lda ) - call stdlib_dtrsm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'NON-UNIT',n-j-jb+1, jb, & + call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,j-1, -one, a( & + j+jb, 1_${ik}$ ), lda, a( j, 1_${ik}$ ),lda, one, a( j+jb, j ), lda ) + call stdlib${ii}$_dtrsm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'NON-UNIT',n-j-jb+1, jb, & one, a( j, j ), lda,a( j+jb, j ), lda ) end if end do @@ -54533,13 +54533,13 @@ module stdlib_linalg_lapack_d end if go to 40 30 continue - info = info + j - 1 + info = info + j - 1_${ik}$ 40 continue return - end subroutine stdlib_dpotrf + end subroutine stdlib${ii}$_dpotrf - pure subroutine stdlib_dptrfs( n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr,berr, work, info ) + pure subroutine stdlib${ii}$_dptrfs( n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr,berr, work, info ) !! DPTRFS improves the computed solution to a system of linear !! equations when the coefficient matrix is symmetric positive definite !! and tridiagonal, and provides error bounds and backward error @@ -54549,43 +54549,43 @@ module stdlib_linalg_lapack_d ! -- 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) :: ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs ! Array Arguments real(dp), intent(in) :: b(ldb,*), d(*), df(*), e(*), ef(*) real(dp), intent(out) :: berr(*), ferr(*), work(*) real(dp), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: itmax = 5 + integer(${ik}$), parameter :: itmax = 5_${ik}$ ! Local Scalars - integer(ilp) :: count, i, ix, j, nz + integer(${ik}$) :: count, i, ix, j, nz real(dp) :: bi, cx, dx, eps, ex, lstres, s, safe1, safe2, safmin ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements ! test the input parameters. - info = 0 - if( n<0 ) then - info = -1 - else if( nrhs<0 ) then - info = -2 - else if( ldbeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_dpttrs( n, 1, df, ef, work( n+1 ), n, info ) - call stdlib_daxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) + call stdlib${ii}$_dpttrs( n, 1_${ik}$, df, ef, work( n+1 ), n, info ) + call stdlib${ii}$_daxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -54680,7 +54680,7 @@ module stdlib_linalg_lapack_d work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1 end if end do - ix = stdlib_idamax( n, work, 1 ) + ix = stdlib${ii}$_idamax( n, work, 1_${ik}$ ) ferr( j ) = work( ix ) ! estimate the norm of inv(a). ! solve m(a) * x = e, where m(a) = (m(i,j)) is given by @@ -54688,7 +54688,7 @@ module stdlib_linalg_lapack_d ! m(i,j) = -abs(a(i,j)), i .ne. j, ! and e = [ 1, 1, ..., 1 ]**t. note m(a) = m(l)*d*m(l)**t. ! solve m(l) * x = e. - work( 1 ) = one + work( 1_${ik}$ ) = one do i = 2, n work( i ) = one + work( i-1 )*abs( ef( i-1 ) ) end do @@ -54698,7 +54698,7 @@ module stdlib_linalg_lapack_d work( i ) = work( i ) / df( i ) + work( i+1 )*abs( ef( i ) ) end do ! compute norm(inv(a)) = max(x(i)), 1<=i<=n. - ix = stdlib_idamax( n, work, 1 ) + ix = stdlib${ii}$_idamax( n, work, 1_${ik}$ ) ferr( j ) = ferr( j )*abs( work( ix ) ) ! normalize error. lstres = zero @@ -54708,10 +54708,10 @@ module stdlib_linalg_lapack_d if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_90 return - end subroutine stdlib_dptrfs + end subroutine stdlib${ii}$_dptrfs - pure subroutine stdlib_dptsv( n, nrhs, d, e, b, ldb, info ) + pure subroutine stdlib${ii}$_dptsv( n, nrhs, d, e, b, ldb, info ) !! DPTSV computes the solution to a real system of linear equations !! A*X = B, where A is an N-by-N symmetric positive definite tridiagonal !! matrix, and X and B are N-by-NRHS matrices. @@ -54721,8 +54721,8 @@ module stdlib_linalg_lapack_d ! -- 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) :: ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments real(dp), intent(inout) :: b(ldb,*), d(*), e(*) ! ===================================================================== @@ -54730,29 +54730,29 @@ module stdlib_linalg_lapack_d intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 - if( n<0 ) then - info = -1 - else if( nrhs<0 ) then - info = -2 - else if( ldb1 )call stdlib_dcopy( n-1, e, 1, ef, 1 ) - call stdlib_dpttrf( n, df, ef, info ) + call stdlib${ii}$_dcopy( n, d, 1_${ik}$, df, 1_${ik}$ ) + if( n>1_${ik}$ )call stdlib${ii}$_dcopy( n-1, e, 1_${ik}$, ef, 1_${ik}$ ) + call stdlib${ii}$_dpttrf( n, df, ef, info ) ! return if info is non-zero. - if( info>0 )then + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_dlanst( '1', n, d, e ) + anorm = stdlib${ii}$_dlanst( '1', n, d, e ) ! compute the reciprocal of the condition number of a. - call stdlib_dptcon( n, df, ef, anorm, rcond, work, info ) + call stdlib${ii}$_dptcon( n, df, ef, anorm, rcond, work, info ) ! compute the solution vectors x. - call stdlib_dlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_dpttrs( n, nrhs, df, ef, x, ldx, info ) + call stdlib${ii}$_dlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_dpttrs( n, nrhs, df, ef, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_dptrfs( n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr, berr,work, info ) + call stdlib${ii}$_dptrfs( n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr, berr,work, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcondzero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then - call stdlib_dlascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_dlascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) else - call stdlib_dlascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_dlascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) end if end if - ! call stdlib_dsbtrd to reduce symmetric band matrix to tridiagonal form. - inde = 1 + ! call stdlib${ii}$_dsbtrd to reduce symmetric band matrix to tridiagonal form. + inde = 1_${ik}$ indwrk = inde + n - call stdlib_dsbtrd( jobz, uplo, n, kd, ab, ldab, w, work( inde ), z, ldz,work( indwrk )& + call stdlib${ii}$_dsbtrd( jobz, uplo, n, kd, ab, ldab, w, work( inde ), z, ldz,work( indwrk )& , iinfo ) - ! for eigenvalues only, call stdlib_dsterf. for eigenvectors, call stdlib_ssteqr. + ! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvectors, call stdlib${ii}$_ssteqr. if( .not.wantz ) then - call stdlib_dsterf( n, w, work( inde ), info ) + call stdlib${ii}$_dsterf( n, w, work( inde ), info ) else - call stdlib_dsteqr( jobz, n, w, work( inde ), z, ldz, work( indwrk ),info ) + call stdlib${ii}$_dsteqr( jobz, n, w, work( inde ), z, ldz, work( indwrk ),info ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = n else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_dscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ ) end if return - end subroutine stdlib_dsbev + end subroutine stdlib${ii}$_dsbev - subroutine stdlib_dsbevx( jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl,vu, il, iu, abstol, & + subroutine stdlib${ii}$_dsbevx( jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl,vu, il, iu, abstol, & !! DSBEVX computes selected eigenvalues and, optionally, eigenvectors !! of a real symmetric band matrix A. Eigenvalues and eigenvectors can !! be selected by specifying either a range of values or a range of @@ -54939,11 +54939,11 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range, uplo - integer(ilp), intent(in) :: il, iu, kd, ldab, ldq, ldz, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, iu, kd, ldab, ldq, ldz, n + integer(${ik}$), intent(out) :: info, m real(dp), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: ifail(*), iwork(*) + integer(${ik}$), intent(out) :: ifail(*), iwork(*) real(dp), intent(inout) :: ab(ldab,*) real(dp), intent(out) :: q(ldq,*), w(*), work(*), z(ldz,*) ! ===================================================================== @@ -54951,7 +54951,7 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: alleig, indeig, lower, test, valeig, wantz character :: order - integer(ilp) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwo, indwrk, & + integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwo, indwrk, & iscale, itmp1, j, jj, nsplit real(dp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, & vuu @@ -54964,67 +54964,67 @@ module stdlib_linalg_lapack_d valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) lower = stdlib_lsame( uplo, 'L' ) - info = 0 + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( kd<0 ) then - info = -5 + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( kd<0_${ik}$ ) then + info = -5_${ik}$ else if( ldab0 .and. vu<=vl )info = -11 + if( n>0_${ik}$ .and. vu<=vl )info = -11_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -12 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -12_${ik}$ else if( iun ) then - info = -13 + info = -13_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz=tmp1 ) )m = 0 + if( .not.( vl=tmp1 ) )m = 0_${ik}$ end if - if( m==1 ) then - w( 1 ) = tmp1 - if( wantz )z( 1, 1 ) = one + if( m==1_${ik}$ ) then + w( 1_${ik}$ ) = tmp1 + if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one end if return end if ! get machine constants. - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) - eps = stdlib_dlamch( 'PRECISION' ) + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_dlamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) ) ! scale matrix to allowable range, if necessary. - iscale = 0 + iscale = 0_${ik}$ abstll = abstol if( valeig ) then vll = vl @@ -55033,101 +55033,101 @@ module stdlib_linalg_lapack_d vll = zero vuu = zero end if - anrm = stdlib_dlansb( 'M', uplo, n, kd, ab, ldab, work ) + anrm = stdlib${ii}$_dlansb( 'M', uplo, n, kd, ab, ldab, work ) if( anrm>zero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then - call stdlib_dlascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_dlascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) else - call stdlib_dlascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_dlascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) end if - if( abstol>0 )abstll = abstol*sigma + if( abstol>0_${ik}$ )abstll = abstol*sigma if( valeig ) then vll = vl*sigma vuu = vu*sigma end if end if - ! call stdlib_dsbtrd to reduce symmetric band matrix to tridiagonal form. - indd = 1 + ! call stdlib${ii}$_dsbtrd to reduce symmetric band matrix to tridiagonal form. + indd = 1_${ik}$ inde = indd + n indwrk = inde + n - call stdlib_dsbtrd( jobz, uplo, n, kd, ab, ldab, work( indd ),work( inde ), q, ldq, & + call stdlib${ii}$_dsbtrd( jobz, uplo, n, kd, ab, ldab, work( indd ),work( inde ), q, ldq, & work( indwrk ), iinfo ) ! if all eigenvalues are desired and abstol is less than or equal - ! to zero, then call stdlib_dsterf or stdlib_ssteqr. if this fails for some - ! eigenvalue, then try stdlib_dstebz. + ! to zero, then call stdlib${ii}$_dsterf or stdlib${ii}$_ssteqr. if this fails for some + ! eigenvalue, then try stdlib${ii}$_dstebz. test = .false. if (indeig) then - if (il==1 .and. iu==n) then + if (il==1_${ik}$ .and. iu==n) then test = .true. end if end if if ((alleig .or. test) .and. (abstol<=zero)) then - call stdlib_dcopy( n, work( indd ), 1, w, 1 ) - indee = indwrk + 2*n + call stdlib${ii}$_dcopy( n, work( indd ), 1_${ik}$, w, 1_${ik}$ ) + indee = indwrk + 2_${ik}$*n if( .not.wantz ) then - call stdlib_dcopy( n-1, work( inde ), 1, work( indee ), 1 ) - call stdlib_dsterf( n, w, work( indee ), info ) + call stdlib${ii}$_dcopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ ) + call stdlib${ii}$_dsterf( n, w, work( indee ), info ) else - call stdlib_dlacpy( 'A', n, n, q, ldq, z, ldz ) - call stdlib_dcopy( n-1, work( inde ), 1, work( indee ), 1 ) - call stdlib_dsteqr( jobz, n, w, work( indee ), z, ldz,work( indwrk ), info ) + call stdlib${ii}$_dlacpy( 'A', n, n, q, ldq, z, ldz ) + call stdlib${ii}$_dcopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ ) + call stdlib${ii}$_dsteqr( jobz, n, w, work( indee ), z, ldz,work( indwrk ), info ) - if( info==0 ) then + if( info==0_${ik}$ ) then do i = 1, n - ifail( i ) = 0 + ifail( i ) = 0_${ik}$ end do end if end if - if( info==0 ) then + if( info==0_${ik}$ ) then m = n go to 30 end if - info = 0 + info = 0_${ik}$ end if - ! otherwise, call stdlib_dstebz and, if eigenvectors are desired, stdlib_sstein. + ! otherwise, call stdlib${ii}$_dstebz and, if eigenvectors are desired, stdlib${ii}$_sstein. if( wantz ) then order = 'B' else order = 'E' end if - indibl = 1 + indibl = 1_${ik}$ indisp = indibl + n indiwo = indisp + n - call stdlib_dstebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde & + call stdlib${ii}$_dstebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde & ), m, nsplit, w,iwork( indibl ), iwork( indisp ), work( indwrk ),iwork( indiwo ), info & ) if( wantz ) then - call stdlib_dstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & + call stdlib${ii}$_dstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,work( indwrk ), iwork( indiwo ), ifail, info ) ! apply orthogonal matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_dstein. + ! form to eigenvectors returned by stdlib${ii}$_dstein. do j = 1, m - call stdlib_dcopy( n, z( 1, j ), 1, work( 1 ), 1 ) - call stdlib_dgemv( 'N', n, n, one, q, ldq, work, 1, zero,z( 1, j ), 1 ) + call stdlib${ii}$_dcopy( n, z( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_dgemv( 'N', n, n, one, q, ldq, work, 1_${ik}$, zero,z( 1_${ik}$, j ), 1_${ik}$ ) end do end if ! if matrix was scaled, then rescale eigenvalues appropriately. 30 continue - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = m else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_dscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. if( wantz ) then do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp1 = w( j ) do jj = j + 1, m if( w( jj )ka ) 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( ldabka ) then - info = -6 + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( ka<0_${ik}$ ) then + info = -5_${ik}$ + else if( kb<0_${ik}$ .or. kb>ka ) then + info = -6_${ik}$ else if( ldab0 .and. vu<=vl )info = -14 + if( n>0_${ik}$ .and. vu<=vl )info = -14_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -15 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -15_${ik}$ else if ( iun ) then - info = -16 + info = -16_${ik}$ end if end if end if - if( info==0) then - if( ldz<1 .or. ( wantz .and. ldzxnrm*cte )go to 10 end do ! if we are here, the nrhs normwise backward errors satisfy the ! stopping criterion. we are good to exit. - iter = 0 + iter = 0_${ik}$ return 10 continue loop_30: do iiter = 1, itermax ! convert r (in work) from double precision to single precision ! and store the result in sx. - call stdlib_dlag2s( n, nrhs, work, n, swork( ptsx ), n, info ) - if( info/=0 ) then - iter = -2 + call stdlib${ii}$_dlag2s( n, nrhs, work, n, swork( ptsx ), n, info ) + if( info/=0_${ik}$ ) then + iter = -2_${ik}$ go to 40 end if ! solve the system sa*sx = sr. - call stdlib_sgetrs( 'NO TRANSPOSE', n, nrhs, swork( ptsa ), n, ipiv,swork( ptsx ), & + call stdlib${ii}$_sgetrs( 'NO TRANSPOSE', n, nrhs, swork( ptsa ), n, ipiv,swork( ptsx ), & n, info ) ! convert sx back to double precision and update the current ! iterate. - call stdlib_slag2d( n, nrhs, swork( ptsx ), n, work, n, info ) + call stdlib${ii}$_slag2d( n, nrhs, swork( ptsx ), n, work, n, info ) do i = 1, nrhs - call stdlib_daxpy( n, one, work( 1, i ), 1, x( 1, i ), 1 ) + call stdlib${ii}$_daxpy( n, one, work( 1_${ik}$, i ), 1_${ik}$, x( 1_${ik}$, i ), 1_${ik}$ ) end do ! compute r = b - ax (r is work). - call stdlib_dlacpy( 'ALL', n, nrhs, b, ldb, work, n ) - call stdlib_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n, nrhs, n, negone,a, lda, x, & + call stdlib${ii}$_dlacpy( 'ALL', n, nrhs, b, ldb, work, n ) + call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n, nrhs, n, negone,a, lda, x, & ldx, one, work, n ) ! check whether the nrhs normwise backward errors satisfy the ! stopping criterion. if yes, set iter=iiter>0 and return. do i = 1, nrhs - xnrm = abs( x( stdlib_idamax( n, x( 1, i ), 1 ), i ) ) - rnrm = abs( work( stdlib_idamax( n, work( 1, i ), 1 ), i ) ) + xnrm = abs( x( stdlib${ii}$_idamax( n, x( 1_${ik}$, i ), 1_${ik}$ ), i ) ) + rnrm = abs( work( stdlib${ii}$_idamax( n, work( 1_${ik}$, i ), 1_${ik}$ ), i ) ) if( rnrm>xnrm*cte )go to 20 end do ! if we are here, the nrhs normwise backward errors satisfy the @@ -55585,19 +55585,19 @@ module stdlib_linalg_lapack_d ! performed iter=itermax iterations and never satisfied the ! stopping criterion, set up the iter flag accordingly and follow up ! on double precision routine. - iter = -itermax - 1 + iter = -itermax - 1_${ik}$ 40 continue ! single-precision iterative refinement failed to converge to a ! satisfactory solution, so we resort to double precision. - call stdlib_dgetrf( n, n, a, lda, ipiv, info ) + call stdlib${ii}$_dgetrf( n, n, a, lda, ipiv, info ) if( info/=0 )return - call stdlib_dlacpy( 'ALL', n, nrhs, b, ldb, x, ldx ) - call stdlib_dgetrs( 'NO TRANSPOSE', n, nrhs, a, lda, ipiv, x, ldx,info ) + call stdlib${ii}$_dlacpy( 'ALL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_dgetrs( 'NO TRANSPOSE', n, nrhs, a, lda, ipiv, x, ldx,info ) return - end subroutine stdlib_dsgesv + end subroutine stdlib${ii}$_dsgesv - subroutine stdlib_dspev( jobz, uplo, n, ap, w, z, ldz, work, info ) + subroutine stdlib${ii}$_dspev( jobz, uplo, n, ap, w, z, ldz, work, info ) !! DSPEV computes all the eigenvalues and, optionally, eigenvectors of a !! real symmetric matrix A in packed storage. ! -- lapack driver routine -- @@ -55605,8 +55605,8 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldz, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldz, n ! Array Arguments real(dp), intent(inout) :: ap(*) real(dp), intent(out) :: w(*), work(*), z(ldz,*) @@ -55614,83 +55614,83 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: wantz - integer(ilp) :: iinfo, imax, inde, indtau, indwrk, iscale + integer(${ik}$) :: iinfo, imax, inde, indtau, indwrk, iscale real(dp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! Intrinsic Functions intrinsic :: sqrt ! Executable Statements ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) - info = 0 + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( stdlib_lsame( uplo, 'U' ) .or. stdlib_lsame( uplo, 'L' ) ) )& then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldz<1 .or. ( wantz .and. ldzzero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then - call stdlib_dscal( ( n*( n+1 ) ) / 2, sigma, ap, 1 ) + if( iscale==1_${ik}$ ) then + call stdlib${ii}$_dscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ ) end if - ! call stdlib_dsptrd to reduce symmetric packed matrix to tridiagonal form. - inde = 1 + ! call stdlib${ii}$_dsptrd to reduce symmetric packed matrix to tridiagonal form. + inde = 1_${ik}$ indtau = inde + n - call stdlib_dsptrd( uplo, n, ap, w, work( inde ), work( indtau ), iinfo ) - ! for eigenvalues only, call stdlib_dsterf. for eigenvectors, first call - ! stdlib_dopgtr to generate the orthogonal matrix, then call stdlib_dsteqr. + call stdlib${ii}$_dsptrd( uplo, n, ap, w, work( inde ), work( indtau ), iinfo ) + ! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvectors, first call + ! stdlib${ii}$_dopgtr to generate the orthogonal matrix, then call stdlib${ii}$_dsteqr. if( .not.wantz ) then - call stdlib_dsterf( n, w, work( inde ), info ) + call stdlib${ii}$_dsterf( n, w, work( inde ), info ) else indwrk = indtau + n - call stdlib_dopgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo ) + call stdlib${ii}$_dopgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo ) - call stdlib_dsteqr( jobz, n, w, work( inde ), z, ldz, work( indtau ),info ) + call stdlib${ii}$_dsteqr( jobz, n, w, work( inde ), z, ldz, work( indtau ),info ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = n else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_dscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ ) end if return - end subroutine stdlib_dspev + end subroutine stdlib${ii}$_dspev - subroutine stdlib_dspevx( jobz, range, uplo, n, ap, vl, vu, il, iu,abstol, m, w, z, ldz, & + subroutine stdlib${ii}$_dspevx( jobz, range, uplo, n, ap, vl, vu, il, iu,abstol, m, w, z, ldz, & !! DSPEVX computes selected eigenvalues and, optionally, eigenvectors !! of a real symmetric matrix A in packed storage. Eigenvalues/vectors !! can be selected by specifying either a range of values or a range of @@ -55701,11 +55701,11 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range, uplo - integer(ilp), intent(in) :: il, iu, ldz, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, iu, ldz, n + integer(${ik}$), intent(out) :: info, m real(dp), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: ifail(*), iwork(*) + integer(${ik}$), intent(out) :: ifail(*), iwork(*) real(dp), intent(inout) :: ap(*) real(dp), intent(out) :: w(*), work(*), z(ldz,*) ! ===================================================================== @@ -55713,7 +55713,7 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: alleig, indeig, test, valeig, wantz character :: order - integer(ilp) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwo, indtau, & + integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwo, indtau, & indwrk, iscale, itmp1, j, jj, nsplit real(dp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, & vuu @@ -55725,59 +55725,59 @@ module stdlib_linalg_lapack_d alleig = stdlib_lsame( range, 'A' ) valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) - info = 0 + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( stdlib_lsame( uplo, 'L' ) .or. stdlib_lsame( uplo, 'U' ) ) )& then - info = -3 - else if( n<0 ) then - info = -4 + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ else if( valeig ) then - if( n>0 .and. vu<=vl )info = -7 + if( n>0_${ik}$ .and. vu<=vl )info = -7_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -8 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -8_${ik}$ else if( iun ) then - info = -9 + info = -9_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz=ap( 1 ) ) then - m = 1 - w( 1 ) = ap( 1 ) + if( vl=ap( 1_${ik}$ ) ) then + m = 1_${ik}$ + w( 1_${ik}$ ) = ap( 1_${ik}$ ) end if end if - if( wantz )z( 1, 1 ) = one + if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one return end if ! get machine constants. - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) - eps = stdlib_dlamch( 'PRECISION' ) + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_dlamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) ) ! scale matrix to allowable range, if necessary. - iscale = 0 + iscale = 0_${ik}$ abstll = abstol if( valeig ) then vll = vl @@ -55786,97 +55786,97 @@ module stdlib_linalg_lapack_d vll = zero vuu = zero end if - anrm = stdlib_dlansp( 'M', uplo, n, ap, work ) + anrm = stdlib${ii}$_dlansp( 'M', uplo, n, ap, work ) if( anrm>zero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then - call stdlib_dscal( ( n*( n+1 ) ) / 2, sigma, ap, 1 ) - if( abstol>0 )abstll = abstol*sigma + if( iscale==1_${ik}$ ) then + call stdlib${ii}$_dscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ ) + if( abstol>0_${ik}$ )abstll = abstol*sigma if( valeig ) then vll = vl*sigma vuu = vu*sigma end if end if - ! call stdlib_dsptrd to reduce symmetric packed matrix to tridiagonal form. - indtau = 1 + ! call stdlib${ii}$_dsptrd to reduce symmetric packed matrix to tridiagonal form. + indtau = 1_${ik}$ inde = indtau + n indd = inde + n indwrk = indd + n - call stdlib_dsptrd( uplo, n, ap, work( indd ), work( inde ),work( indtau ), iinfo ) + call stdlib${ii}$_dsptrd( uplo, n, ap, work( indd ), work( inde ),work( indtau ), iinfo ) ! if all eigenvalues are desired and abstol is less than or equal - ! to zero, then call stdlib_dsterf or stdlib_dopgtr and stdlib_ssteqr. if this fails - ! for some eigenvalue, then try stdlib_dstebz. + ! to zero, then call stdlib${ii}$_dsterf or stdlib${ii}$_dopgtr and stdlib${ii}$_ssteqr. if this fails + ! for some eigenvalue, then try stdlib${ii}$_dstebz. test = .false. if (indeig) then - if (il==1 .and. iu==n) then + if (il==1_${ik}$ .and. iu==n) then test = .true. end if end if if ((alleig .or. test) .and. (abstol<=zero)) then - call stdlib_dcopy( n, work( indd ), 1, w, 1 ) - indee = indwrk + 2*n + call stdlib${ii}$_dcopy( n, work( indd ), 1_${ik}$, w, 1_${ik}$ ) + indee = indwrk + 2_${ik}$*n if( .not.wantz ) then - call stdlib_dcopy( n-1, work( inde ), 1, work( indee ), 1 ) - call stdlib_dsterf( n, w, work( indee ), info ) + call stdlib${ii}$_dcopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ ) + call stdlib${ii}$_dsterf( n, w, work( indee ), info ) else - call stdlib_dopgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo ) + call stdlib${ii}$_dopgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo ) - call stdlib_dcopy( n-1, work( inde ), 1, work( indee ), 1 ) - call stdlib_dsteqr( jobz, n, w, work( indee ), z, ldz,work( indwrk ), info ) + call stdlib${ii}$_dcopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ ) + call stdlib${ii}$_dsteqr( jobz, n, w, work( indee ), z, ldz,work( indwrk ), info ) - if( info==0 ) then + if( info==0_${ik}$ ) then do i = 1, n - ifail( i ) = 0 + ifail( i ) = 0_${ik}$ end do end if end if - if( info==0 ) then + if( info==0_${ik}$ ) then m = n go to 20 end if - info = 0 + info = 0_${ik}$ end if - ! otherwise, call stdlib_dstebz and, if eigenvectors are desired, stdlib_sstein. + ! otherwise, call stdlib${ii}$_dstebz and, if eigenvectors are desired, stdlib${ii}$_sstein. if( wantz ) then order = 'B' else order = 'E' end if - indibl = 1 + indibl = 1_${ik}$ indisp = indibl + n indiwo = indisp + n - call stdlib_dstebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde & + call stdlib${ii}$_dstebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde & ), m, nsplit, w,iwork( indibl ), iwork( indisp ), work( indwrk ),iwork( indiwo ), info & ) if( wantz ) then - call stdlib_dstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & + call stdlib${ii}$_dstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,work( indwrk ), iwork( indiwo ), ifail, info ) ! apply orthogonal matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_dstein. - call stdlib_dopmtr( 'L', uplo, 'N', n, m, ap, work( indtau ), z, ldz,work( indwrk ),& + ! form to eigenvectors returned by stdlib${ii}$_dstein. + call stdlib${ii}$_dopmtr( 'L', uplo, 'N', n, m, ap, work( indtau ), z, ldz,work( indwrk ),& iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. 20 continue - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = m else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_dscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. if( wantz ) then do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp1 = w( j ) do jj = j + 1, m if( w( jj )3 ) then - info = -1 + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( ldz<1 .or. ( wantz .and. ldz0 )neig = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )neig = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**t*y or inv(u)*y if( upper ) then @@ -55968,9 +55968,9 @@ module stdlib_linalg_lapack_d trans = 'T' end if do j = 1, neig - call stdlib_dtpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_dtpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**t*y if( upper ) then @@ -55979,15 +55979,15 @@ module stdlib_linalg_lapack_d trans = 'N' end if do j = 1, neig - call stdlib_dtpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_dtpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do end if end if return - end subroutine stdlib_dspgv + end subroutine stdlib${ii}$_dspgv - subroutine stdlib_dspgvx( itype, jobz, range, uplo, n, ap, bp, vl, vu,il, iu, abstol, m, w, & + subroutine stdlib${ii}$_dspgvx( itype, jobz, range, uplo, n, ap, bp, vl, vu,il, iu, abstol, m, w, & !! DSPGVX computes selected eigenvalues, and optionally, eigenvectors !! of a real generalized symmetric-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A @@ -56001,18 +56001,18 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range, uplo - integer(ilp), intent(in) :: il, itype, iu, ldz, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, itype, iu, ldz, n + integer(${ik}$), intent(out) :: info, m real(dp), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: ifail(*), iwork(*) + integer(${ik}$), intent(out) :: ifail(*), iwork(*) real(dp), intent(inout) :: ap(*), bp(*) real(dp), intent(out) :: w(*), work(*), z(ldz,*) ! ===================================================================== ! Local Scalars logical(lk) :: alleig, indeig, upper, valeig, wantz character :: trans - integer(ilp) :: j + integer(${ik}$) :: j ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -56022,56 +56022,56 @@ module stdlib_linalg_lapack_d alleig = stdlib_lsame( range, 'A' ) valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) - info = 0 - if( itype<1 .or. itype>3 ) then - info = -1 + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -3 + info = -3_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -4 - else if( n<0 ) then - info = -5 + info = -4_${ik}$ + else if( n<0_${ik}$ ) then + info = -5_${ik}$ else if( valeig ) then - if( n>0 .and. vu<=vl ) then - info = -9 + if( n>0_${ik}$ .and. vu<=vl ) then + info = -9_${ik}$ end if else if( indeig ) then - if( il<1 ) then - info = -10 + if( il<1_${ik}$ ) then + info = -10_${ik}$ else if( iun ) then - info = -11 + info = -11_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz0 )m = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )m = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**t*y or inv(u)*y if( upper ) then @@ -56080,9 +56080,9 @@ module stdlib_linalg_lapack_d trans = 'T' end if do j = 1, m - call stdlib_dtpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_dtpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**t*y if( upper ) then @@ -56091,15 +56091,15 @@ module stdlib_linalg_lapack_d trans = 'N' end if do j = 1, m - call stdlib_dtpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_dtpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do end if end if return - end subroutine stdlib_dspgvx + end subroutine stdlib${ii}$_dspgvx - subroutine stdlib_dsposv( uplo, n, nrhs, a, lda, b, ldb, x, ldx, work,swork, iter, info ) + subroutine stdlib${ii}$_dsposv( uplo, n, nrhs, a, lda, b, ldb, x, ldx, work,swork, iter, info ) !! DSPOSV computes the solution to a real system of linear equations !! A * X = B, !! where A is an N-by-N symmetric positive definite matrix and X and B @@ -56134,8 +56134,8 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(out) :: info, iter - integer(ilp), intent(in) :: lda, ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info, iter + integer(${ik}$), intent(in) :: lda, ldb, ldx, n, nrhs ! Array Arguments real(sp), intent(out) :: swork(*) real(dp), intent(inout) :: a(lda,*) @@ -56144,36 +56144,36 @@ module stdlib_linalg_lapack_d ! ===================================================================== ! Parameters logical(lk), parameter :: doitref = .true. - integer(ilp), parameter :: itermax = 30 + integer(${ik}$), parameter :: itermax = 30_${ik}$ real(dp), parameter :: bwdmax = 1.0e+00_dp ! Local Scalars - integer(ilp) :: i, iiter, ptsa, ptsx + integer(${ik}$) :: i, iiter, ptsa, ptsx real(dp) :: anrm, cte, eps, rnrm, xnrm ! Intrinsic Functions intrinsic :: abs,real,max,sqrt ! Executable Statements - info = 0 - iter = 0 + info = 0_${ik}$ + iter = 0_${ik}$ ! test the input parameters. if( .not.stdlib_lsame( uplo, 'U' ) .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( ldaxnrm*cte )go to 10 end do ! if we are here, the nrhs normwise backward errors satisfy the ! stopping criterion. we are good to exit. - iter = 0 + iter = 0_${ik}$ return 10 continue loop_30: do iiter = 1, itermax ! convert r (in work) from double precision to single precision ! and store the result in sx. - call stdlib_dlag2s( n, nrhs, work, n, swork( ptsx ), n, info ) - if( info/=0 ) then - iter = -2 + call stdlib${ii}$_dlag2s( n, nrhs, work, n, swork( ptsx ), n, info ) + if( info/=0_${ik}$ ) then + iter = -2_${ik}$ go to 40 end if ! solve the system sa*sx = sr. - call stdlib_spotrs( uplo, n, nrhs, swork( ptsa ), n, swork( ptsx ), n,info ) + call stdlib${ii}$_spotrs( uplo, n, nrhs, swork( ptsa ), n, swork( ptsx ), n,info ) ! convert sx back to double precision and update the current ! iterate. - call stdlib_slag2d( n, nrhs, swork( ptsx ), n, work, n, info ) + call stdlib${ii}$_slag2d( n, nrhs, swork( ptsx ), n, work, n, info ) do i = 1, nrhs - call stdlib_daxpy( n, one, work( 1, i ), 1, x( 1, i ), 1 ) + call stdlib${ii}$_daxpy( n, one, work( 1_${ik}$, i ), 1_${ik}$, x( 1_${ik}$, i ), 1_${ik}$ ) end do ! compute r = b - ax (r is work). - call stdlib_dlacpy( 'ALL', n, nrhs, b, ldb, work, n ) - call stdlib_dsymm( 'L', uplo, n, nrhs, negone, a, lda, x, ldx, one,work, n ) + call stdlib${ii}$_dlacpy( 'ALL', n, nrhs, b, ldb, work, n ) + call stdlib${ii}$_dsymm( 'L', uplo, n, nrhs, negone, a, lda, x, ldx, one,work, n ) ! check whether the nrhs normwise backward errors satisfy the ! stopping criterion. if yes, set iter=iiter>0 and return. do i = 1, nrhs - xnrm = abs( x( stdlib_idamax( n, x( 1, i ), 1 ), i ) ) - rnrm = abs( work( stdlib_idamax( n, work( 1, i ), 1 ), i ) ) + xnrm = abs( x( stdlib${ii}$_idamax( n, x( 1_${ik}$, i ), 1_${ik}$ ), i ) ) + rnrm = abs( work( stdlib${ii}$_idamax( n, work( 1_${ik}$, i ), 1_${ik}$ ), i ) ) if( rnrm>xnrm*cte )go to 20 end do ! if we are here, the nrhs normwise backward errors satisfy the @@ -56266,19 +56266,19 @@ module stdlib_linalg_lapack_d ! performed iter=itermax iterations and never satisfied the ! stopping criterion, set up the iter flag accordingly and follow ! up on double precision routine. - iter = -itermax - 1 + iter = -itermax - 1_${ik}$ 40 continue ! single-precision iterative refinement failed to converge to a ! satisfactory solution, so we resort to double precision. - call stdlib_dpotrf( uplo, n, a, lda, info ) + call stdlib${ii}$_dpotrf( uplo, n, a, lda, info ) if( info/=0 )return - call stdlib_dlacpy( 'ALL', n, nrhs, b, ldb, x, ldx ) - call stdlib_dpotrs( uplo, n, nrhs, a, lda, x, ldx, info ) + call stdlib${ii}$_dlacpy( 'ALL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_dpotrs( uplo, n, nrhs, a, lda, x, ldx, info ) return - end subroutine stdlib_dsposv + end subroutine stdlib${ii}$_dsposv - subroutine stdlib_dsyev( jobz, uplo, n, a, lda, w, work, lwork, info ) + subroutine stdlib${ii}$_dsyev( jobz, uplo, n, a, lda, w, work, lwork, info ) !! DSYEV computes all eigenvalues and, optionally, eigenvectors of a !! real symmetric matrix A. ! -- lapack driver routine -- @@ -56286,8 +56286,8 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, 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 real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: w(*), work(*) @@ -56295,7 +56295,7 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: lower, lquery, wantz - integer(ilp) :: iinfo, imax, inde, indtau, indwrk, iscale, llwork, lwkopt, nb + integer(${ik}$) :: iinfo, imax, inde, indtau, indwrk, iscale, llwork, lwkopt, nb real(dp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! Intrinsic Functions intrinsic :: max,sqrt @@ -56303,89 +56303,89 @@ module stdlib_linalg_lapack_d ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) lower = stdlib_lsame( uplo, 'L' ) - lquery = ( lwork==-1 ) - info = 0 + lquery = ( lwork==-1_${ik}$ ) + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldazero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 )call stdlib_dlascl( uplo, 0, 0, one, sigma, n, n, a, lda, info ) - ! call stdlib_dsytrd to reduce symmetric matrix to tridiagonal form. - inde = 1 + if( iscale==1_${ik}$ )call stdlib${ii}$_dlascl( uplo, 0_${ik}$, 0_${ik}$, one, sigma, n, n, a, lda, info ) + ! call stdlib${ii}$_dsytrd to reduce symmetric matrix to tridiagonal form. + inde = 1_${ik}$ indtau = inde + n indwrk = indtau + n - llwork = lwork - indwrk + 1 - call stdlib_dsytrd( uplo, n, a, lda, w, work( inde ), work( indtau ),work( indwrk ), & + llwork = lwork - indwrk + 1_${ik}$ + call stdlib${ii}$_dsytrd( uplo, n, a, lda, w, work( inde ), work( indtau ),work( indwrk ), & llwork, iinfo ) - ! for eigenvalues only, call stdlib_dsterf. for eigenvectors, first call - ! stdlib_dorgtr to generate the orthogonal matrix, then call stdlib_dsteqr. + ! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvectors, first call + ! stdlib${ii}$_dorgtr to generate the orthogonal matrix, then call stdlib${ii}$_dsteqr. if( .not.wantz ) then - call stdlib_dsterf( n, w, work( inde ), info ) + call stdlib${ii}$_dsterf( n, w, work( inde ), info ) else - call stdlib_dorgtr( uplo, n, a, lda, work( indtau ), work( indwrk ),llwork, iinfo ) + call stdlib${ii}$_dorgtr( uplo, n, a, lda, work( indtau ), work( indwrk ),llwork, iinfo ) - call stdlib_dsteqr( jobz, n, w, work( inde ), a, lda, work( indtau ),info ) + call stdlib${ii}$_dsteqr( jobz, n, w, work( inde ), a, lda, work( indtau ),info ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = n else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_dscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ ) end if ! set work(1) to optimal workspace size. - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_dsyev + end subroutine stdlib${ii}$_dsyev - subroutine stdlib_dsyevx( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, & + subroutine stdlib${ii}$_dsyevx( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, & !! DSYEVX computes selected eigenvalues and, optionally, eigenvectors !! of a real symmetric matrix A. Eigenvalues and eigenvectors can be !! selected by specifying either a range of values or a range of indices @@ -56396,11 +56396,11 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range, uplo - integer(ilp), intent(in) :: il, iu, lda, ldz, lwork, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, iu, lda, ldz, lwork, n + integer(${ik}$), intent(out) :: info, m real(dp), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: ifail(*), iwork(*) + integer(${ik}$), intent(out) :: ifail(*), iwork(*) real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: w(*), work(*), z(ldz,*) ! ===================================================================== @@ -56408,7 +56408,7 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: alleig, indeig, lower, lquery, test, valeig, wantz character :: order - integer(ilp) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwo, indtau, & + integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwo, indtau, & indwkn, indwrk, iscale, itmp1, j, jj, llwork, llwrkn, lwkmin, lwkopt, nb, & nsplit real(dp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, & @@ -56422,188 +56422,188 @@ module stdlib_linalg_lapack_d alleig = stdlib_lsame( range, 'A' ) valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) - lquery = ( lwork==-1 ) - info = 0 + lquery = ( lwork==-1_${ik}$ ) + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( lda0 .and. vu<=vl )info = -8 + if( n>0_${ik}$ .and. vu<=vl )info = -8_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -9 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -9_${ik}$ else if( iun ) then - info = -10 + info = -10_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz=a( 1, 1 ) ) then - m = 1 - w( 1 ) = a( 1, 1 ) + if( vl=a( 1_${ik}$, 1_${ik}$ ) ) then + m = 1_${ik}$ + w( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ ) end if end if - if( wantz )z( 1, 1 ) = one + if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one return end if ! get machine constants. - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) - eps = stdlib_dlamch( 'PRECISION' ) + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_dlamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) ) ! scale matrix to allowable range, if necessary. - iscale = 0 + iscale = 0_${ik}$ abstll = abstol if( valeig ) then vll = vl vuu = vu end if - anrm = stdlib_dlansy( 'M', uplo, n, a, lda, work ) + anrm = stdlib${ii}$_dlansy( 'M', uplo, n, a, lda, work ) if( anrm>zero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then do j = 1, n - call stdlib_dscal( n-j+1, sigma, a( j, j ), 1 ) + call stdlib${ii}$_dscal( n-j+1, sigma, a( j, j ), 1_${ik}$ ) end do else do j = 1, n - call stdlib_dscal( j, sigma, a( 1, j ), 1 ) + call stdlib${ii}$_dscal( j, sigma, a( 1_${ik}$, j ), 1_${ik}$ ) end do end if - if( abstol>0 )abstll = abstol*sigma + if( abstol>0_${ik}$ )abstll = abstol*sigma if( valeig ) then vll = vl*sigma vuu = vu*sigma end if end if - ! call stdlib_dsytrd to reduce symmetric matrix to tridiagonal form. - indtau = 1 + ! call stdlib${ii}$_dsytrd to reduce symmetric matrix to tridiagonal form. + indtau = 1_${ik}$ inde = indtau + n indd = inde + n indwrk = indd + n - llwork = lwork - indwrk + 1 - call stdlib_dsytrd( uplo, n, a, lda, work( indd ), work( inde ),work( indtau ), work( & + llwork = lwork - indwrk + 1_${ik}$ + call stdlib${ii}$_dsytrd( uplo, n, a, lda, work( indd ), work( inde ),work( indtau ), work( & indwrk ), llwork, iinfo ) ! if all eigenvalues are desired and abstol is less than or equal to - ! zero, then call stdlib_dsterf or stdlib_dorgtr and stdlib_ssteqr. if this fails for - ! some eigenvalue, then try stdlib_dstebz. + ! zero, then call stdlib${ii}$_dsterf or stdlib${ii}$_dorgtr and stdlib${ii}$_ssteqr. if this fails for + ! some eigenvalue, then try stdlib${ii}$_dstebz. test = .false. if( indeig ) then - if( il==1 .and. iu==n ) then + if( il==1_${ik}$ .and. iu==n ) then test = .true. end if end if if( ( alleig .or. test ) .and. ( abstol<=zero ) ) then - call stdlib_dcopy( n, work( indd ), 1, w, 1 ) - indee = indwrk + 2*n + call stdlib${ii}$_dcopy( n, work( indd ), 1_${ik}$, w, 1_${ik}$ ) + indee = indwrk + 2_${ik}$*n if( .not.wantz ) then - call stdlib_dcopy( n-1, work( inde ), 1, work( indee ), 1 ) - call stdlib_dsterf( n, w, work( indee ), info ) + call stdlib${ii}$_dcopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ ) + call stdlib${ii}$_dsterf( n, w, work( indee ), info ) else - call stdlib_dlacpy( 'A', n, n, a, lda, z, ldz ) - call stdlib_dorgtr( uplo, n, z, ldz, work( indtau ),work( indwrk ), llwork, & + call stdlib${ii}$_dlacpy( 'A', n, n, a, lda, z, ldz ) + call stdlib${ii}$_dorgtr( uplo, n, z, ldz, work( indtau ),work( indwrk ), llwork, & iinfo ) - call stdlib_dcopy( n-1, work( inde ), 1, work( indee ), 1 ) - call stdlib_dsteqr( jobz, n, w, work( indee ), z, ldz,work( indwrk ), info ) + call stdlib${ii}$_dcopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ ) + call stdlib${ii}$_dsteqr( jobz, n, w, work( indee ), z, ldz,work( indwrk ), info ) - if( info==0 ) then + if( info==0_${ik}$ ) then do i = 1, n - ifail( i ) = 0 + ifail( i ) = 0_${ik}$ end do end if end if - if( info==0 ) then + if( info==0_${ik}$ ) then m = n go to 40 end if - info = 0 + info = 0_${ik}$ end if - ! otherwise, call stdlib_dstebz and, if eigenvectors are desired, stdlib_sstein. + ! otherwise, call stdlib${ii}$_dstebz and, if eigenvectors are desired, stdlib${ii}$_sstein. if( wantz ) then order = 'B' else order = 'E' end if - indibl = 1 + indibl = 1_${ik}$ indisp = indibl + n indiwo = indisp + n - call stdlib_dstebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde & + call stdlib${ii}$_dstebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde & ), m, nsplit, w,iwork( indibl ), iwork( indisp ), work( indwrk ),iwork( indiwo ), info & ) if( wantz ) then - call stdlib_dstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & + call stdlib${ii}$_dstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,work( indwrk ), iwork( indiwo ), ifail, info ) ! apply orthogonal matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_dstein. + ! form to eigenvectors returned by stdlib${ii}$_dstein. indwkn = inde - llwrkn = lwork - indwkn + 1 - call stdlib_dormtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & + llwrkn = lwork - indwkn + 1_${ik}$ + call stdlib${ii}$_dormtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & indwkn ), llwrkn, iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. 40 continue - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = m else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_dscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. if( wantz ) then do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp1 = w( j ) do jj = j + 1, m if( w( jj )3 ) then - info = -1 + lquery = ( lwork==-1_${ik}$ ) + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( lda0 )neig = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )neig = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**t*y or inv(u)*y if( upper ) then @@ -56713,9 +56713,9 @@ module stdlib_linalg_lapack_d else trans = 'T' end if - call stdlib_dtrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, one,b, ldb, a, lda ) + call stdlib${ii}$_dtrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, one,b, ldb, a, lda ) - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**t*y if( upper ) then @@ -56723,16 +56723,16 @@ module stdlib_linalg_lapack_d else trans = 'N' end if - call stdlib_dtrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, one,b, ldb, a, lda ) + call stdlib${ii}$_dtrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, one,b, ldb, a, lda ) end if end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_dsygv + end subroutine stdlib${ii}$_dsygv - subroutine stdlib_dsygvx( itype, jobz, range, uplo, n, a, lda, b, ldb,vl, vu, il, iu, abstol,& + subroutine stdlib${ii}$_dsygvx( itype, jobz, range, uplo, n, a, lda, b, ldb,vl, vu, il, iu, abstol,& !! DSYGVX computes selected eigenvalues, and optionally, eigenvectors !! of a real generalized symmetric-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A @@ -56745,11 +56745,11 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range, uplo - integer(ilp), intent(in) :: il, itype, iu, lda, ldb, ldz, lwork, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, itype, iu, lda, ldb, ldz, lwork, n + integer(${ik}$), intent(out) :: info, m real(dp), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: ifail(*), iwork(*) + integer(${ik}$), intent(out) :: ifail(*), iwork(*) real(dp), intent(inout) :: a(lda,*), b(ldb,*) real(dp), intent(out) :: w(*), work(*), z(ldz,*) ! ===================================================================== @@ -56757,7 +56757,7 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: alleig, indeig, lquery, upper, valeig, wantz character :: trans - integer(ilp) :: lwkmin, lwkopt, nb + integer(${ik}$) :: lwkmin, lwkopt, nb ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -56767,72 +56767,72 @@ module stdlib_linalg_lapack_d alleig = stdlib_lsame( range, 'A' ) valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) - lquery = ( lwork==-1 ) - info = 0 - if( itype<1 .or. itype>3 ) then - info = -1 + lquery = ( lwork==-1_${ik}$ ) + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -3 + info = -3_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( lda0 .and. vu<=vl )info = -11 + if( n>0_${ik}$ .and. vu<=vl )info = -11_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -12 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -12_${ik}$ else if( iun ) then - info = -13 + info = -13_${ik}$ end if end if end if - if (info==0) then - if (ldz<1 .or. (wantz .and. ldz0 )m = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )m = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**t*y or inv(u)*y if( upper ) then @@ -56840,9 +56840,9 @@ module stdlib_linalg_lapack_d else trans = 'T' end if - call stdlib_dtrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, one, b,ldb, z, ldz ) + call stdlib${ii}$_dtrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, one, b,ldb, z, ldz ) - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**t*y if( upper ) then @@ -56850,17 +56850,17 @@ module stdlib_linalg_lapack_d else trans = 'N' end if - call stdlib_dtrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, one, b,ldb, z, ldz ) + call stdlib${ii}$_dtrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, one, b,ldb, z, ldz ) end if end if ! set work(1) to optimal workspace size. - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_dsygvx + end subroutine stdlib${ii}$_dsygvx - pure subroutine stdlib_dsysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) + pure subroutine stdlib${ii}$_dsysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) !! DSYSV computes the solution to a real system of linear equations !! A * X = B, !! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS @@ -56877,68 +56877,68 @@ module stdlib_linalg_lapack_d ! -- 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, lwork, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, lwork, n, nrhs ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) real(dp), intent(inout) :: a(lda,*), b(ldb,*) real(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: lwkopt + integer(${ik}$) :: lwkopt ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) if( .not.stdlib_lsame( uplo, 'U' ) .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 + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_dlansy( 'I', uplo, n, a, lda, work ) + anorm = stdlib${ii}$_dlansy( 'I', uplo, n, a, lda, work ) ! compute the reciprocal of the condition number of a. - call stdlib_dsycon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, iwork,info ) + call stdlib${ii}$_dsycon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, iwork,info ) ! compute the solution vectors x. - call stdlib_dlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_dsytrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info ) + call stdlib${ii}$_dlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_dsytrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_dsyrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & + call stdlib${ii}$_dsyrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & work, iwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond1 )anorm = anorm + abs( s( 2, 1 ) ) - bnorm = abs( p( 1, 1 ) ) - work( 1 ) = zero + anorm = abs( s( 1_${ik}$, 1_${ik}$ ) ) + if( n>1_${ik}$ )anorm = anorm + abs( s( 2_${ik}$, 1_${ik}$ ) ) + bnorm = abs( p( 1_${ik}$, 1_${ik}$ ) ) + work( 1_${ik}$ ) = zero work( n+1 ) = zero do j = 2, n temp = zero temp2 = zero if( s( j, j-1 )==zero ) then - iend = j - 1 + iend = j - 1_${ik}$ else - iend = j - 2 + iend = j - 2_${ik}$ end if do i = 1, iend temp = temp + abs( s( i, j ) ) @@ -57401,7 +57401,7 @@ module stdlib_linalg_lapack_d bscale = one / max( bnorm, safmin ) ! left eigenvectors if( compl ) then - ieig = 0 + ieig = 0_${ik}$ ! main loop over eigenvalues ilcplx = .false. loop_220: do je = 1, n @@ -57413,11 +57413,11 @@ module stdlib_linalg_lapack_d ilcplx = .false. cycle loop_220 end if - nw = 1 + nw = 1_${ik}$ if( jeabs( temp2r )+abs( temp2i ) ) then - work( 2*n+je ) = one - work( 3*n+je ) = zero - work( 2*n+je+1 ) = -temp2r / temp - work( 3*n+je+1 ) = -temp2i / temp + work( 2_${ik}$*n+je ) = one + work( 3_${ik}$*n+je ) = zero + work( 2_${ik}$*n+je+1 ) = -temp2r / temp + work( 3_${ik}$*n+je+1 ) = -temp2i / temp else - work( 2*n+je+1 ) = one - work( 3*n+je+1 ) = zero + work( 2_${ik}$*n+je+1 ) = one + work( 3_${ik}$*n+je+1 ) = zero temp = acoef*s( je, je+1 ) - work( 2*n+je ) = ( bcoefr*p( je+1, je+1 )-acoef*s( je+1, je+1 ) ) / & + work( 2_${ik}$*n+je ) = ( bcoefr*p( je+1, je+1 )-acoef*s( je+1, je+1 ) ) / & temp - work( 3*n+je ) = bcoefi*p( je+1, je+1 ) / temp + work( 3_${ik}$*n+je ) = bcoefi*p( je+1, je+1 ) / temp end if - xmax = max( abs( work( 2*n+je ) )+abs( work( 3*n+je ) ),abs( work( 2*n+je+1 ) & - )+abs( work( 3*n+je+1 ) ) ) + xmax = max( abs( work( 2_${ik}$*n+je ) )+abs( work( 3_${ik}$*n+je ) ),abs( work( 2_${ik}$*n+je+1 ) & + )+abs( work( 3_${ik}$*n+je+1 ) ) ) end if dmin = max( ulp*acoefa*anorm, ulp*bcoefa*bnorm, safmin ) ! t @@ -57542,13 +57542,13 @@ module stdlib_linalg_lapack_d il2by2 = .false. cycle loop_160 end if - na = 1 - bdiag( 1 ) = p( j, j ) + na = 1_${ik}$ + bdiag( 1_${ik}$ ) = p( j, j ) if( j1 ) then + nw = 1_${ik}$ + if( je>1_${ik}$ ) then if( s( je, je-1 )/=zero ) then ilcplx = .true. - nw = 2 + nw = 2_${ik}$ end if end if if( ilall ) then @@ -57686,7 +57686,7 @@ module stdlib_linalg_lapack_d if( .not.ilcplx ) then if( abs( s( je, je ) )<=safmin .and.abs( p( je, je ) )<=safmin ) then ! singular matrix pencil -- unit eigenvector - ieig = ieig - 1 + ieig = ieig - 1_${ik}$ do jr = 1, n vr( jr, ieig ) = zero end do @@ -57736,19 +57736,19 @@ module stdlib_linalg_lapack_d acoefa = abs( acoef ) bcoefa = abs( bcoefr ) ! first component is 1 - work( 2*n+je ) = one + work( 2_${ik}$*n+je ) = one xmax = one ! compute contribution from column je of a and b to sum ! (see "further details", above.) do jr = 1, je - 1 - work( 2*n+jr ) = bcoefr*p( jr, je ) -acoef*s( jr, je ) + work( 2_${ik}$*n+jr ) = bcoefr*p( jr, je ) -acoef*s( jr, je ) end do else ! complex eigenvalue - call stdlib_dlag2( s( je-1, je-1 ), lds, p( je-1, je-1 ), ldp,safmin*safety, & + call stdlib${ii}$_dlag2( s( je-1, je-1 ), lds, p( je-1, je-1 ), ldp,safmin*safety, & acoef, temp, bcoefr, temp2,bcoefi ) if( bcoefi==zero ) then - info = je - 1 + info = je - 1_${ik}$ return end if ! scale to avoid over/underflow @@ -57775,34 +57775,34 @@ module stdlib_linalg_lapack_d temp2r = acoef*s( je, je ) - bcoefr*p( je, je ) temp2i = -bcoefi*p( je, je ) if( abs( temp )>=abs( temp2r )+abs( temp2i ) ) then - work( 2*n+je ) = one - work( 3*n+je ) = zero - work( 2*n+je-1 ) = -temp2r / temp - work( 3*n+je-1 ) = -temp2i / temp + work( 2_${ik}$*n+je ) = one + work( 3_${ik}$*n+je ) = zero + work( 2_${ik}$*n+je-1 ) = -temp2r / temp + work( 3_${ik}$*n+je-1 ) = -temp2i / temp else - work( 2*n+je-1 ) = one - work( 3*n+je-1 ) = zero + work( 2_${ik}$*n+je-1 ) = one + work( 3_${ik}$*n+je-1 ) = zero temp = acoef*s( je-1, je ) - work( 2*n+je ) = ( bcoefr*p( je-1, je-1 )-acoef*s( je-1, je-1 ) ) / & + work( 2_${ik}$*n+je ) = ( bcoefr*p( je-1, je-1 )-acoef*s( je-1, je-1 ) ) / & temp - work( 3*n+je ) = bcoefi*p( je-1, je-1 ) / temp + work( 3_${ik}$*n+je ) = bcoefi*p( je-1, je-1 ) / temp end if - xmax = max( abs( work( 2*n+je ) )+abs( work( 3*n+je ) ),abs( work( 2*n+je-1 ) & - )+abs( work( 3*n+je-1 ) ) ) + xmax = max( abs( work( 2_${ik}$*n+je ) )+abs( work( 3_${ik}$*n+je ) ),abs( work( 2_${ik}$*n+je-1 ) & + )+abs( work( 3_${ik}$*n+je-1 ) ) ) ! compute contribution from columns je and je-1 ! of a and b to the sums. - creala = acoef*work( 2*n+je-1 ) - cimaga = acoef*work( 3*n+je-1 ) - crealb = bcoefr*work( 2*n+je-1 ) -bcoefi*work( 3*n+je-1 ) - cimagb = bcoefi*work( 2*n+je-1 ) +bcoefr*work( 3*n+je-1 ) - cre2a = acoef*work( 2*n+je ) - cim2a = acoef*work( 3*n+je ) - cre2b = bcoefr*work( 2*n+je ) - bcoefi*work( 3*n+je ) - cim2b = bcoefi*work( 2*n+je ) + bcoefr*work( 3*n+je ) + creala = acoef*work( 2_${ik}$*n+je-1 ) + cimaga = acoef*work( 3_${ik}$*n+je-1 ) + crealb = bcoefr*work( 2_${ik}$*n+je-1 ) -bcoefi*work( 3_${ik}$*n+je-1 ) + cimagb = bcoefi*work( 2_${ik}$*n+je-1 ) +bcoefr*work( 3_${ik}$*n+je-1 ) + cre2a = acoef*work( 2_${ik}$*n+je ) + cim2a = acoef*work( 3_${ik}$*n+je ) + cre2b = bcoefr*work( 2_${ik}$*n+je ) - bcoefi*work( 3_${ik}$*n+je ) + cim2b = bcoefi*work( 2_${ik}$*n+je ) + bcoefr*work( 3_${ik}$*n+je ) do jr = 1, je - 2 - work( 2*n+jr ) = -creala*s( jr, je-1 ) +crealb*p( jr, je-1 ) -cre2a*s( jr, & + work( 2_${ik}$*n+jr ) = -creala*s( jr, je-1 ) +crealb*p( jr, je-1 ) -cre2a*s( jr, & je ) + cre2b*p( jr, je ) - work( 3*n+jr ) = -cimaga*s( jr, je-1 ) +cimagb*p( jr, je-1 ) -cim2a*s( jr, & + work( 3_${ik}$*n+jr ) = -cimaga*s( jr, je-1 ) +cimagb*p( jr, je-1 ) -cim2a*s( jr, & je ) + cim2b*p( jr, je ) end do end if @@ -57812,22 +57812,22 @@ module stdlib_linalg_lapack_d loop_370: do j = je - nw, 1, -1 ! if a 2-by-2 block, is in position j-1:j, wait until ! next iteration to process it (when it will be j:j+1) - if( .not.il2by2 .and. j>1 ) then + if( .not.il2by2 .and. j>1_${ik}$ ) then if( s( j, j-1 )/=zero ) then il2by2 = .true. cycle loop_370 end if end if - bdiag( 1 ) = p( j, j ) + bdiag( 1_${ik}$ ) = p( j, j ) if( il2by2 ) then - na = 2 - bdiag( 2 ) = p( j+1, j+1 ) + na = 2_${ik}$ + bdiag( 2_${ik}$ ) = p( j+1, j+1 ) else - na = 1 + na = 1_${ik}$ end if ! compute x(j) (and x(j+1), if 2-by-2 block) - call stdlib_dlaln2( .false., na, nw, dmin, acoef, s( j, j ),lds, bdiag( 1 ), & - bdiag( 2 ), work( 2*n+j ),n, bcoefr, bcoefi, sum, 2, scale, temp,iinfo ) + call stdlib${ii}$_dlaln2( .false., na, nw, dmin, acoef, s( j, j ),lds, bdiag( 1_${ik}$ ), & + bdiag( 2_${ik}$ ), work( 2_${ik}$*n+j ),n, bcoefr, bcoefi, sum, 2_${ik}$, scale, temp,iinfo ) if( scale1 ) then + if( j>1_${ik}$ ) then ! check whether scaling is necessary for sum. xscale = one / max( one, xmax ) temp = acoefa*work( j ) + bcoefa*work( n+j ) @@ -57863,21 +57863,21 @@ module stdlib_linalg_lapack_d ! sums. do ja = 1, na if( ilcplx ) then - creala = acoef*work( 2*n+j+ja-1 ) - cimaga = acoef*work( 3*n+j+ja-1 ) - crealb = bcoefr*work( 2*n+j+ja-1 ) -bcoefi*work( 3*n+j+ja-1 ) - cimagb = bcoefi*work( 2*n+j+ja-1 ) +bcoefr*work( 3*n+j+ja-1 ) + creala = acoef*work( 2_${ik}$*n+j+ja-1 ) + cimaga = acoef*work( 3_${ik}$*n+j+ja-1 ) + crealb = bcoefr*work( 2_${ik}$*n+j+ja-1 ) -bcoefi*work( 3_${ik}$*n+j+ja-1 ) + cimagb = bcoefi*work( 2_${ik}$*n+j+ja-1 ) +bcoefr*work( 3_${ik}$*n+j+ja-1 ) do jr = 1, j - 1 - work( 2*n+jr ) = work( 2*n+jr ) -creala*s( jr, j+ja-1 ) +crealb*p(& + work( 2_${ik}$*n+jr ) = work( 2_${ik}$*n+jr ) -creala*s( jr, j+ja-1 ) +crealb*p(& jr, j+ja-1 ) - work( 3*n+jr ) = work( 3*n+jr ) -cimaga*s( jr, j+ja-1 ) +cimagb*p(& + work( 3_${ik}$*n+jr ) = work( 3_${ik}$*n+jr ) -cimaga*s( jr, j+ja-1 ) +cimagb*p(& jr, j+ja-1 ) end do else - creala = acoef*work( 2*n+j+ja-1 ) - crealb = bcoefr*work( 2*n+j+ja-1 ) + creala = acoef*work( 2_${ik}$*n+j+ja-1 ) + crealb = bcoefr*work( 2_${ik}$*n+j+ja-1 ) do jr = 1, j - 1 - work( 2*n+jr ) = work( 2*n+jr ) -creala*s( jr, j+ja-1 ) +crealb*p(& + work( 2_${ik}$*n+jr ) = work( 2_${ik}$*n+jr ) -creala*s( jr, j+ja-1 ) +crealb*p(& jr, j+ja-1 ) end do end if @@ -57891,7 +57891,7 @@ module stdlib_linalg_lapack_d if( ilback ) then do jw = 0, nw - 1 do jr = 1, n - work( ( jw+4 )*n+jr ) = work( ( jw+2 )*n+1 )*vr( jr, 1 ) + work( ( jw+4 )*n+jr ) = work( ( jw+2 )*n+1 )*vr( jr, 1_${ik}$ ) end do ! a series of compiler directives to defeat ! vectorization for the next loop @@ -57938,10 +57938,10 @@ module stdlib_linalg_lapack_d end do loop_500 end if return - end subroutine stdlib_dtgevc + end subroutine stdlib${ii}$_dtgevc - pure subroutine stdlib_dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, j1, n1, n2, & + pure subroutine stdlib${ii}$_dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, j1, n1, n2, & !! DTGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22) !! of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair !! (A, B) by an orthogonal equivalence transformation. @@ -57958,17 +57958,17 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: wantq, wantz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: j1, lda, ldb, ldq, ldz, lwork, n, n1, n2 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: j1, lda, ldb, ldq, ldz, lwork, n, n1, n2 ! Array Arguments real(dp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) real(dp), intent(out) :: work(*) ! ===================================================================== - ! replaced various illegal calls to stdlib_dcopy by calls to stdlib_dlaset, or by do + ! replaced various illegal calls to stdlib${ii}$_dcopy by calls to stdlib${ii}$_dlaset, or by do ! loops. sven hammarling, 1/5/02. ! Parameters real(dp), parameter :: twenty = 2.0e+01_dp - integer(ilp), parameter :: ldst = 4 + integer(${ik}$), parameter :: ldst = 4_${ik}$ logical(lk), parameter :: wands = .true. @@ -57976,46 +57976,46 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: strong, weak - integer(ilp) :: i, idum, linfo, m + integer(${ik}$) :: i, idum, linfo, m real(dp) :: bqra21, brqa21, ddum, dnorma, dnormb, dscale, dsum, eps, f, g, sa, sb, & scale, smlnum, thresha, threshb ! Local Arrays - integer(ilp) :: iwork(ldst) - real(dp) :: ai(2), ar(2), be(2), ir(ldst,ldst), ircop(ldst,ldst), li(ldst,ldst), licop(& + integer(${ik}$) :: iwork(ldst) + real(dp) :: ai(2_${ik}$), ar(2_${ik}$), be(2_${ik}$), ir(ldst,ldst), ircop(ldst,ldst), li(ldst,ldst), licop(& ldst,ldst), s(ldst,ldst), scpy(ldst,ldst), t(ldst,ldst), taul(ldst), taur(ldst), tcpy(& ldst,ldst) ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements - info = 0 + info = 0_${ik}$ ! quick return if possible if( n<=1 .or. n1<=0 .or. n2<=0 )return if( n1>n .or. ( j1+n1 )>n )return m = n1 + n2 - if( lwork=sb ) then - call stdlib_dlartg( s( 1, 1 ), s( 2, 1 ), li( 1, 1 ), li( 2, 1 ),ddum ) + call stdlib${ii}$_dlartg( s( 1_${ik}$, 1_${ik}$ ), s( 2_${ik}$, 1_${ik}$ ), li( 1_${ik}$, 1_${ik}$ ), li( 2_${ik}$, 1_${ik}$ ),ddum ) else - call stdlib_dlartg( t( 1, 1 ), t( 2, 1 ), li( 1, 1 ), li( 2, 1 ),ddum ) + call stdlib${ii}$_dlartg( t( 1_${ik}$, 1_${ik}$ ), t( 2_${ik}$, 1_${ik}$ ), li( 1_${ik}$, 1_${ik}$ ), li( 2_${ik}$, 1_${ik}$ ),ddum ) end if - call stdlib_drot( 2, s( 1, 1 ), ldst, s( 2, 1 ), ldst, li( 1, 1 ),li( 2, 1 ) ) + call stdlib${ii}$_drot( 2_${ik}$, s( 1_${ik}$, 1_${ik}$ ), ldst, s( 2_${ik}$, 1_${ik}$ ), ldst, li( 1_${ik}$, 1_${ik}$ ),li( 2_${ik}$, 1_${ik}$ ) ) - call stdlib_drot( 2, t( 1, 1 ), ldst, t( 2, 1 ), ldst, li( 1, 1 ),li( 2, 1 ) ) + call stdlib${ii}$_drot( 2_${ik}$, t( 1_${ik}$, 1_${ik}$ ), ldst, t( 2_${ik}$, 1_${ik}$ ), ldst, li( 1_${ik}$, 1_${ik}$ ),li( 2_${ik}$, 1_${ik}$ ) ) - li( 2, 2 ) = li( 1, 1 ) - li( 1, 2 ) = -li( 2, 1 ) + li( 2_${ik}$, 2_${ik}$ ) = li( 1_${ik}$, 1_${ik}$ ) + li( 1_${ik}$, 2_${ik}$ ) = -li( 2_${ik}$, 1_${ik}$ ) ! weak stability test: |s21| <= o(eps f-norm((a))) ! and |t21| <= o(eps f-norm((b))) - weak = abs( s( 2, 1 ) ) <= thresha .and.abs( t( 2, 1 ) ) <= threshb + weak = abs( s( 2_${ik}$, 1_${ik}$ ) ) <= thresha .and.abs( t( 2_${ik}$, 1_${ik}$ ) ) <= threshb if( .not.weak )go to 70 if( wands ) then ! strong stability test: ! f-norm((a-ql**h*s*qr)) <= o(eps*f-norm((a))) ! and ! f-norm((b-ql**h*t*qr)) <= o(eps*f-norm((b))) - call stdlib_dlacpy( 'FULL', m, m, a( j1, j1 ), lda, work( m*m+1 ),m ) - call stdlib_dgemm( 'N', 'N', m, m, m, one, li, ldst, s, ldst, zero,work, m ) + call stdlib${ii}$_dlacpy( 'FULL', m, m, a( j1, j1 ), lda, work( m*m+1 ),m ) + call stdlib${ii}$_dgemm( 'N', 'N', m, m, m, one, li, ldst, s, ldst, zero,work, m ) - call stdlib_dgemm( 'N', 'T', m, m, m, -one, work, m, ir, ldst, one,work( m*m+1 ),& + call stdlib${ii}$_dgemm( 'N', 'T', m, m, m, -one, work, m, ir, ldst, one,work( m*m+1 ),& m ) dscale = zero dsum = one - call stdlib_dlassq( m*m, work( m*m+1 ), 1, dscale, dsum ) + call stdlib${ii}$_dlassq( m*m, work( m*m+1 ), 1_${ik}$, dscale, dsum ) sa = dscale*sqrt( dsum ) - call stdlib_dlacpy( 'FULL', m, m, b( j1, j1 ), ldb, work( m*m+1 ),m ) - call stdlib_dgemm( 'N', 'N', m, m, m, one, li, ldst, t, ldst, zero,work, m ) + call stdlib${ii}$_dlacpy( 'FULL', m, m, b( j1, j1 ), ldb, work( m*m+1 ),m ) + call stdlib${ii}$_dgemm( 'N', 'N', m, m, m, one, li, ldst, t, ldst, zero,work, m ) - call stdlib_dgemm( 'N', 'T', m, m, m, -one, work, m, ir, ldst, one,work( m*m+1 ),& + call stdlib${ii}$_dgemm( 'N', 'T', m, m, m, -one, work, m, ir, ldst, one,work( m*m+1 ),& m ) dscale = zero dsum = one - call stdlib_dlassq( m*m, work( m*m+1 ), 1, dscale, dsum ) + call stdlib${ii}$_dlassq( m*m, work( m*m+1 ), 1_${ik}$, dscale, dsum ) sb = dscale*sqrt( dsum ) strong = sa<=thresha .and. sb<=threshb if( .not.strong )go to 70 end if ! update (a(j1:j1+m-1, m+j1:n), b(j1:j1+m-1, m+j1:n)) and ! (a(1:j1-1, j1:j1+m), b(1:j1-1, j1:j1+m)). - call stdlib_drot( j1+1, a( 1, j1 ), 1, a( 1, j1+1 ), 1, ir( 1, 1 ),ir( 2, 1 ) ) + call stdlib${ii}$_drot( j1+1, a( 1_${ik}$, j1 ), 1_${ik}$, a( 1_${ik}$, j1+1 ), 1_${ik}$, ir( 1_${ik}$, 1_${ik}$ ),ir( 2_${ik}$, 1_${ik}$ ) ) - call stdlib_drot( j1+1, b( 1, j1 ), 1, b( 1, j1+1 ), 1, ir( 1, 1 ),ir( 2, 1 ) ) + call stdlib${ii}$_drot( j1+1, b( 1_${ik}$, j1 ), 1_${ik}$, b( 1_${ik}$, j1+1 ), 1_${ik}$, ir( 1_${ik}$, 1_${ik}$ ),ir( 2_${ik}$, 1_${ik}$ ) ) - call stdlib_drot( n-j1+1, a( j1, j1 ), lda, a( j1+1, j1 ), lda,li( 1, 1 ), li( 2, 1 & + call stdlib${ii}$_drot( n-j1+1, a( j1, j1 ), lda, a( j1+1, j1 ), lda,li( 1_${ik}$, 1_${ik}$ ), li( 2_${ik}$, 1_${ik}$ & ) ) - call stdlib_drot( n-j1+1, b( j1, j1 ), ldb, b( j1+1, j1 ), ldb,li( 1, 1 ), li( 2, 1 & + call stdlib${ii}$_drot( n-j1+1, b( j1, j1 ), ldb, b( j1+1, j1 ), ldb,li( 1_${ik}$, 1_${ik}$ ), li( 2_${ik}$, 1_${ik}$ & ) ) ! set n1-by-n2 (2,1) - blocks to zero. a( j1+1, j1 ) = zero b( j1+1, j1 ) = zero ! accumulate transformations into q and z if requested. - if( wantz )call stdlib_drot( n, z( 1, j1 ), 1, z( 1, j1+1 ), 1, ir( 1, 1 ),ir( 2, 1 & + if( wantz )call stdlib${ii}$_drot( n, z( 1_${ik}$, j1 ), 1_${ik}$, z( 1_${ik}$, j1+1 ), 1_${ik}$, ir( 1_${ik}$, 1_${ik}$ ),ir( 2_${ik}$, 1_${ik}$ & ) ) - if( wantq )call stdlib_drot( n, q( 1, j1 ), 1, q( 1, j1+1 ), 1, li( 1, 1 ),li( 2, 1 & + if( wantq )call stdlib${ii}$_drot( n, q( 1_${ik}$, j1 ), 1_${ik}$, q( 1_${ik}$, j1+1 ), 1_${ik}$, li( 1_${ik}$, 1_${ik}$ ),li( 2_${ik}$, 1_${ik}$ & ) ) ! exit with info = 0 if swap was successfully performed. return @@ -58107,10 +58107,10 @@ module stdlib_linalg_lapack_d ! s11 * r - l * s22 = scale * s12 ! t11 * r - l * t22 = scale * t12 ! for r and l. solutions in li and ir. - call stdlib_dlacpy( 'FULL', n1, n2, t( 1, n1+1 ), ldst, li, ldst ) - call stdlib_dlacpy( 'FULL', n1, n2, s( 1, n1+1 ), ldst,ir( n2+1, n1+1 ), ldst ) + call stdlib${ii}$_dlacpy( 'FULL', n1, n2, t( 1_${ik}$, n1+1 ), ldst, li, ldst ) + call stdlib${ii}$_dlacpy( 'FULL', n1, n2, s( 1_${ik}$, n1+1 ), ldst,ir( n2+1, n1+1 ), ldst ) - call stdlib_dtgsy2( 'N', 0, n1, n2, s, ldst, s( n1+1, n1+1 ), ldst,ir( n2+1, n1+1 ),& + call stdlib${ii}$_dtgsy2( 'N', 0_${ik}$, n1, n2, s, ldst, s( n1+1, n1+1 ), ldst,ir( n2+1, n1+1 ),& ldst, t, ldst, t( n1+1, n1+1 ),ldst, li, ldst, scale, dsum, dscale, iwork, idum,& linfo ) if( linfo/=0 )go to 70 @@ -58121,12 +58121,12 @@ module stdlib_linalg_lapack_d ! li = [ -l ] ! [ scale * identity(n2) ] do i = 1, n2 - call stdlib_dscal( n1, -one, li( 1, i ), 1 ) + call stdlib${ii}$_dscal( n1, -one, li( 1_${ik}$, i ), 1_${ik}$ ) li( n1+i, i ) = scale end do - call stdlib_dgeqr2( m, n2, li, ldst, taul, work, linfo ) + call stdlib${ii}$_dgeqr2( m, n2, li, ldst, taul, work, linfo ) if( linfo/=0 )go to 70 - call stdlib_dorg2r( m, m, n2, li, ldst, taul, work, linfo ) + call stdlib${ii}$_dorg2r( m, m, n2, li, ldst, taul, work, linfo ) if( linfo/=0 )go to 70 ! compute orthogonal matrix rq: ! ir * rq**t = [ 0 tr], @@ -58134,113 +58134,113 @@ module stdlib_linalg_lapack_d do i = 1, n1 ir( n2+i, i ) = scale end do - call stdlib_dgerq2( n1, m, ir( n2+1, 1 ), ldst, taur, work, linfo ) + call stdlib${ii}$_dgerq2( n1, m, ir( n2+1, 1_${ik}$ ), ldst, taur, work, linfo ) if( linfo/=0 )go to 70 - call stdlib_dorgr2( m, m, n1, ir, ldst, taur, work, linfo ) + call stdlib${ii}$_dorgr2( m, m, n1, ir, ldst, taur, work, linfo ) if( linfo/=0 )go to 70 ! perform the swapping tentatively: - call stdlib_dgemm( 'T', 'N', m, m, m, one, li, ldst, s, ldst, zero,work, m ) - call stdlib_dgemm( 'N', 'T', m, m, m, one, work, m, ir, ldst, zero, s,ldst ) - call stdlib_dgemm( 'T', 'N', m, m, m, one, li, ldst, t, ldst, zero,work, m ) - call stdlib_dgemm( 'N', 'T', m, m, m, one, work, m, ir, ldst, zero, t,ldst ) - call stdlib_dlacpy( 'F', m, m, s, ldst, scpy, ldst ) - call stdlib_dlacpy( 'F', m, m, t, ldst, tcpy, ldst ) - call stdlib_dlacpy( 'F', m, m, ir, ldst, ircop, ldst ) - call stdlib_dlacpy( 'F', m, m, li, ldst, licop, ldst ) + call stdlib${ii}$_dgemm( 'T', 'N', m, m, m, one, li, ldst, s, ldst, zero,work, m ) + call stdlib${ii}$_dgemm( 'N', 'T', m, m, m, one, work, m, ir, ldst, zero, s,ldst ) + call stdlib${ii}$_dgemm( 'T', 'N', m, m, m, one, li, ldst, t, ldst, zero,work, m ) + call stdlib${ii}$_dgemm( 'N', 'T', m, m, m, one, work, m, ir, ldst, zero, t,ldst ) + call stdlib${ii}$_dlacpy( 'F', m, m, s, ldst, scpy, ldst ) + call stdlib${ii}$_dlacpy( 'F', m, m, t, ldst, tcpy, ldst ) + call stdlib${ii}$_dlacpy( 'F', m, m, ir, ldst, ircop, ldst ) + call stdlib${ii}$_dlacpy( 'F', m, m, li, ldst, licop, ldst ) ! triangularize the b-part by an rq factorization. ! apply transformation (from left) to a-part, giving s. - call stdlib_dgerq2( m, m, t, ldst, taur, work, linfo ) + call stdlib${ii}$_dgerq2( m, m, t, ldst, taur, work, linfo ) if( linfo/=0 )go to 70 - call stdlib_dormr2( 'R', 'T', m, m, m, t, ldst, taur, s, ldst, work,linfo ) + call stdlib${ii}$_dormr2( 'R', 'T', m, m, m, t, ldst, taur, s, ldst, work,linfo ) if( linfo/=0 )go to 70 - call stdlib_dormr2( 'L', 'N', m, m, m, t, ldst, taur, ir, ldst, work,linfo ) + call stdlib${ii}$_dormr2( 'L', 'N', m, m, m, t, ldst, taur, ir, ldst, work,linfo ) if( linfo/=0 )go to 70 ! compute f-norm(s21) in brqa21. (t21 is 0.) dscale = zero dsum = one do i = 1, n2 - call stdlib_dlassq( n1, s( n2+1, i ), 1, dscale, dsum ) + call stdlib${ii}$_dlassq( n1, s( n2+1, i ), 1_${ik}$, dscale, dsum ) end do brqa21 = dscale*sqrt( dsum ) ! triangularize the b-part by a qr factorization. ! apply transformation (from right) to a-part, giving s. - call stdlib_dgeqr2( m, m, tcpy, ldst, taul, work, linfo ) + call stdlib${ii}$_dgeqr2( m, m, tcpy, ldst, taul, work, linfo ) if( linfo/=0 )go to 70 - call stdlib_dorm2r( 'L', 'T', m, m, m, tcpy, ldst, taul, scpy, ldst,work, info ) + call stdlib${ii}$_dorm2r( 'L', 'T', m, m, m, tcpy, ldst, taul, scpy, ldst,work, info ) - call stdlib_dorm2r( 'R', 'N', m, m, m, tcpy, ldst, taul, licop, ldst,work, info ) + call stdlib${ii}$_dorm2r( 'R', 'N', m, m, m, tcpy, ldst, taul, licop, ldst,work, info ) if( linfo/=0 )go to 70 ! compute f-norm(s21) in bqra21. (t21 is 0.) dscale = zero dsum = one do i = 1, n2 - call stdlib_dlassq( n1, scpy( n2+1, i ), 1, dscale, dsum ) + call stdlib${ii}$_dlassq( n1, scpy( n2+1, i ), 1_${ik}$, dscale, dsum ) end do bqra21 = dscale*sqrt( dsum ) ! decide which method to use. ! weak stability test: ! f-norm(s21) <= o(eps * f-norm((s))) if( bqra21<=brqa21 .and. bqra21<=thresha ) then - call stdlib_dlacpy( 'F', m, m, scpy, ldst, s, ldst ) - call stdlib_dlacpy( 'F', m, m, tcpy, ldst, t, ldst ) - call stdlib_dlacpy( 'F', m, m, ircop, ldst, ir, ldst ) - call stdlib_dlacpy( 'F', m, m, licop, ldst, li, ldst ) + call stdlib${ii}$_dlacpy( 'F', m, m, scpy, ldst, s, ldst ) + call stdlib${ii}$_dlacpy( 'F', m, m, tcpy, ldst, t, ldst ) + call stdlib${ii}$_dlacpy( 'F', m, m, ircop, ldst, ir, ldst ) + call stdlib${ii}$_dlacpy( 'F', m, m, licop, ldst, li, ldst ) else if( brqa21>=thresha ) then go to 70 end if ! set lower triangle of b-part to zero - call stdlib_dlaset( 'LOWER', m-1, m-1, zero, zero, t(2,1), ldst ) + call stdlib${ii}$_dlaset( 'LOWER', m-1, m-1, zero, zero, t(2_${ik}$,1_${ik}$), ldst ) if( wands ) then ! strong stability test: ! f-norm((a-ql**h*s*qr)) <= o(eps*f-norm((a))) ! and ! f-norm((b-ql**h*t*qr)) <= o(eps*f-norm((b))) - call stdlib_dlacpy( 'FULL', m, m, a( j1, j1 ), lda, work( m*m+1 ),m ) - call stdlib_dgemm( 'N', 'N', m, m, m, one, li, ldst, s, ldst, zero,work, m ) + call stdlib${ii}$_dlacpy( 'FULL', m, m, a( j1, j1 ), lda, work( m*m+1 ),m ) + call stdlib${ii}$_dgemm( 'N', 'N', m, m, m, one, li, ldst, s, ldst, zero,work, m ) - call stdlib_dgemm( 'N', 'N', m, m, m, -one, work, m, ir, ldst, one,work( m*m+1 ),& + call stdlib${ii}$_dgemm( 'N', 'N', m, m, m, -one, work, m, ir, ldst, one,work( m*m+1 ),& m ) dscale = zero dsum = one - call stdlib_dlassq( m*m, work( m*m+1 ), 1, dscale, dsum ) + call stdlib${ii}$_dlassq( m*m, work( m*m+1 ), 1_${ik}$, dscale, dsum ) sa = dscale*sqrt( dsum ) - call stdlib_dlacpy( 'FULL', m, m, b( j1, j1 ), ldb, work( m*m+1 ),m ) - call stdlib_dgemm( 'N', 'N', m, m, m, one, li, ldst, t, ldst, zero,work, m ) + call stdlib${ii}$_dlacpy( 'FULL', m, m, b( j1, j1 ), ldb, work( m*m+1 ),m ) + call stdlib${ii}$_dgemm( 'N', 'N', m, m, m, one, li, ldst, t, ldst, zero,work, m ) - call stdlib_dgemm( 'N', 'N', m, m, m, -one, work, m, ir, ldst, one,work( m*m+1 ),& + call stdlib${ii}$_dgemm( 'N', 'N', m, m, m, -one, work, m, ir, ldst, one,work( m*m+1 ),& m ) dscale = zero dsum = one - call stdlib_dlassq( m*m, work( m*m+1 ), 1, dscale, dsum ) + call stdlib${ii}$_dlassq( m*m, work( m*m+1 ), 1_${ik}$, dscale, dsum ) sb = dscale*sqrt( dsum ) strong = sa<=thresha .and. sb<=threshb if( .not.strong )go to 70 end if ! if the swap is accepted ("weakly" and "strongly"), apply the ! transformations and set n1-by-n2 (2,1)-block to zero. - call stdlib_dlaset( 'FULL', n1, n2, zero, zero, s(n2+1,1), ldst ) + call stdlib${ii}$_dlaset( 'FULL', n1, n2, zero, zero, s(n2+1,1_${ik}$), ldst ) ! copy back m-by-m diagonal block starting at index j1 of (a, b) - call stdlib_dlacpy( 'F', m, m, s, ldst, a( j1, j1 ), lda ) - call stdlib_dlacpy( 'F', m, m, t, ldst, b( j1, j1 ), ldb ) - call stdlib_dlaset( 'FULL', ldst, ldst, zero, zero, t, ldst ) + call stdlib${ii}$_dlacpy( 'F', m, m, s, ldst, a( j1, j1 ), lda ) + call stdlib${ii}$_dlacpy( 'F', m, m, t, ldst, b( j1, j1 ), ldb ) + call stdlib${ii}$_dlaset( 'FULL', ldst, ldst, zero, zero, t, ldst ) ! standardize existing 2-by-2 blocks. - call stdlib_dlaset( 'FULL', m, m, zero, zero, work, m ) - work( 1 ) = one - t( 1, 1 ) = one - idum = lwork - m*m - 2 - if( n2>1 ) then - call stdlib_dlagv2( a( j1, j1 ), lda, b( j1, j1 ), ldb, ar, ai, be,work( 1 ), & - work( 2 ), t( 1, 1 ), t( 2, 1 ) ) - work( m+1 ) = -work( 2 ) - work( m+2 ) = work( 1 ) - t( n2, n2 ) = t( 1, 1 ) - t( 1, 2 ) = -t( 2, 1 ) + call stdlib${ii}$_dlaset( 'FULL', m, m, zero, zero, work, m ) + work( 1_${ik}$ ) = one + t( 1_${ik}$, 1_${ik}$ ) = one + idum = lwork - m*m - 2_${ik}$ + if( n2>1_${ik}$ ) then + call stdlib${ii}$_dlagv2( a( j1, j1 ), lda, b( j1, j1 ), ldb, ar, ai, be,work( 1_${ik}$ ), & + work( 2_${ik}$ ), t( 1_${ik}$, 1_${ik}$ ), t( 2_${ik}$, 1_${ik}$ ) ) + work( m+1 ) = -work( 2_${ik}$ ) + work( m+2 ) = work( 1_${ik}$ ) + t( n2, n2 ) = t( 1_${ik}$, 1_${ik}$ ) + t( 1_${ik}$, 2_${ik}$ ) = -t( 2_${ik}$, 1_${ik}$ ) end if work( m*m ) = one t( m, m ) = one - if( n1>1 ) then - call stdlib_dlagv2( a( j1+n2, j1+n2 ), lda, b( j1+n2, j1+n2 ), ldb,taur, taul, & + if( n1>1_${ik}$ ) then + call stdlib${ii}$_dlagv2( a( j1+n2, j1+n2 ), lda, b( j1+n2, j1+n2 ), ldb,taur, taul, & work( m*m+1 ), work( n2*m+n2+1 ),work( n2*m+n2+2 ), t( n2+1, n2+1 ),t( m, m-1 ) ) work( m*m ) = work( n2*m+n2+1 ) @@ -58248,65 +58248,65 @@ module stdlib_linalg_lapack_d t( m, m ) = t( n2+1, n2+1 ) t( m-1, m ) = -t( m, m-1 ) end if - call stdlib_dgemm( 'T', 'N', n2, n1, n2, one, work, m, a( j1, j1+n2 ),lda, zero, & + call stdlib${ii}$_dgemm( 'T', 'N', n2, n1, n2, one, work, m, a( j1, j1+n2 ),lda, zero, & work( m*m+1 ), n2 ) - call stdlib_dlacpy( 'FULL', n2, n1, work( m*m+1 ), n2, a( j1, j1+n2 ),lda ) - call stdlib_dgemm( 'T', 'N', n2, n1, n2, one, work, m, b( j1, j1+n2 ),ldb, zero, & + call stdlib${ii}$_dlacpy( 'FULL', n2, n1, work( m*m+1 ), n2, a( j1, j1+n2 ),lda ) + call stdlib${ii}$_dgemm( 'T', 'N', n2, n1, n2, one, work, m, b( j1, j1+n2 ),ldb, zero, & work( m*m+1 ), n2 ) - call stdlib_dlacpy( 'FULL', n2, n1, work( m*m+1 ), n2, b( j1, j1+n2 ),ldb ) - call stdlib_dgemm( 'N', 'N', m, m, m, one, li, ldst, work, m, zero,work( m*m+1 ), m & + call stdlib${ii}$_dlacpy( 'FULL', n2, n1, work( m*m+1 ), n2, b( j1, j1+n2 ),ldb ) + call stdlib${ii}$_dgemm( 'N', 'N', m, m, m, one, li, ldst, work, m, zero,work( m*m+1 ), m & ) - call stdlib_dlacpy( 'FULL', m, m, work( m*m+1 ), m, li, ldst ) - call stdlib_dgemm( 'N', 'N', n2, n1, n1, one, a( j1, j1+n2 ), lda,t( n2+1, n2+1 ), & + call stdlib${ii}$_dlacpy( 'FULL', m, m, work( m*m+1 ), m, li, ldst ) + call stdlib${ii}$_dgemm( 'N', 'N', n2, n1, n1, one, a( j1, j1+n2 ), lda,t( n2+1, n2+1 ), & ldst, zero, work, n2 ) - call stdlib_dlacpy( 'FULL', n2, n1, work, n2, a( j1, j1+n2 ), lda ) - call stdlib_dgemm( 'N', 'N', n2, n1, n1, one, b( j1, j1+n2 ), ldb,t( n2+1, n2+1 ), & + call stdlib${ii}$_dlacpy( 'FULL', n2, n1, work, n2, a( j1, j1+n2 ), lda ) + call stdlib${ii}$_dgemm( 'N', 'N', n2, n1, n1, one, b( j1, j1+n2 ), ldb,t( n2+1, n2+1 ), & ldst, zero, work, n2 ) - call stdlib_dlacpy( 'FULL', n2, n1, work, n2, b( j1, j1+n2 ), ldb ) - call stdlib_dgemm( 'T', 'N', m, m, m, one, ir, ldst, t, ldst, zero,work, m ) - call stdlib_dlacpy( 'FULL', m, m, work, m, ir, ldst ) + call stdlib${ii}$_dlacpy( 'FULL', n2, n1, work, n2, b( j1, j1+n2 ), ldb ) + call stdlib${ii}$_dgemm( 'T', 'N', m, m, m, one, ir, ldst, t, ldst, zero,work, m ) + call stdlib${ii}$_dlacpy( 'FULL', m, m, work, m, ir, ldst ) ! accumulate transformations into q and z if requested. if( wantq ) then - call stdlib_dgemm( 'N', 'N', n, m, m, one, q( 1, j1 ), ldq, li,ldst, zero, work, & + call stdlib${ii}$_dgemm( 'N', 'N', n, m, m, one, q( 1_${ik}$, j1 ), ldq, li,ldst, zero, work, & n ) - call stdlib_dlacpy( 'FULL', n, m, work, n, q( 1, j1 ), ldq ) + call stdlib${ii}$_dlacpy( 'FULL', n, m, work, n, q( 1_${ik}$, j1 ), ldq ) end if if( wantz ) then - call stdlib_dgemm( 'N', 'N', n, m, m, one, z( 1, j1 ), ldz, ir,ldst, zero, work, & + call stdlib${ii}$_dgemm( 'N', 'N', n, m, m, one, z( 1_${ik}$, j1 ), ldz, ir,ldst, zero, work, & n ) - call stdlib_dlacpy( 'FULL', n, m, work, n, z( 1, j1 ), ldz ) + call stdlib${ii}$_dlacpy( 'FULL', n, m, work, n, z( 1_${ik}$, j1 ), ldz ) end if ! update (a(j1:j1+m-1, m+j1:n), b(j1:j1+m-1, m+j1:n)) and ! (a(1:j1-1, j1:j1+m), b(1:j1-1, j1:j1+m)). i = j1 + m if( i<=n ) then - call stdlib_dgemm( 'T', 'N', m, n-i+1, m, one, li, ldst,a( j1, i ), lda, zero, & + call stdlib${ii}$_dgemm( 'T', 'N', m, n-i+1, m, one, li, ldst,a( j1, i ), lda, zero, & work, m ) - call stdlib_dlacpy( 'FULL', m, n-i+1, work, m, a( j1, i ), lda ) - call stdlib_dgemm( 'T', 'N', m, n-i+1, m, one, li, ldst,b( j1, i ), ldb, zero, & + call stdlib${ii}$_dlacpy( 'FULL', m, n-i+1, work, m, a( j1, i ), lda ) + call stdlib${ii}$_dgemm( 'T', 'N', m, n-i+1, m, one, li, ldst,b( j1, i ), ldb, zero, & work, m ) - call stdlib_dlacpy( 'FULL', m, n-i+1, work, m, b( j1, i ), ldb ) + call stdlib${ii}$_dlacpy( 'FULL', m, n-i+1, work, m, b( j1, i ), ldb ) end if - i = j1 - 1 - if( i>0 ) then - call stdlib_dgemm( 'N', 'N', i, m, m, one, a( 1, j1 ), lda, ir,ldst, zero, work, & + i = j1 - 1_${ik}$ + if( i>0_${ik}$ ) then + call stdlib${ii}$_dgemm( 'N', 'N', i, m, m, one, a( 1_${ik}$, j1 ), lda, ir,ldst, zero, work, & i ) - call stdlib_dlacpy( 'FULL', i, m, work, i, a( 1, j1 ), lda ) - call stdlib_dgemm( 'N', 'N', i, m, m, one, b( 1, j1 ), ldb, ir,ldst, zero, work, & + call stdlib${ii}$_dlacpy( 'FULL', i, m, work, i, a( 1_${ik}$, j1 ), lda ) + call stdlib${ii}$_dgemm( 'N', 'N', i, m, m, one, b( 1_${ik}$, j1 ), ldb, ir,ldst, zero, work, & i ) - call stdlib_dlacpy( 'FULL', i, m, work, i, b( 1, j1 ), ldb ) + call stdlib${ii}$_dlacpy( 'FULL', i, m, work, i, b( 1_${ik}$, j1 ), ldb ) end if ! exit with info = 0 if swap was successfully performed. return end if ! exit with info = 1 if swap was rejected. 70 continue - info = 1 + info = 1_${ik}$ return - end subroutine stdlib_dtgex2 + end subroutine stdlib${ii}$_dtgex2 - pure subroutine stdlib_dtgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, ifst, ilst, & + pure subroutine stdlib${ii}$_dtgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, ifst, ilst, & !! DTGEXC reorders the generalized real Schur decomposition of a real !! matrix pair (A,B) using an orthogonal equivalence transformation !! (A, B) = Q * (A, B) * Z**T, @@ -58325,9 +58325,9 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: wantq, wantz - integer(ilp), intent(inout) :: ifst, ilst - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldb, ldq, ldz, lwork, n + integer(${ik}$), intent(inout) :: ifst, ilst + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldq, ldz, lwork, n ! Array Arguments real(dp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) real(dp), intent(out) :: work(*) @@ -58335,41 +58335,41 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: lquery - integer(ilp) :: here, lwmin, nbf, nbl, nbnext + integer(${ik}$) :: here, lwmin, nbf, nbl, nbnext ! Intrinsic Functions intrinsic :: max ! Executable Statements ! decode and test input arguments. - info = 0 - lquery = ( lwork==-1 ) - if( n<0 ) then - info = -3 - else if( ldan ) then - info = -12 - else if( ilst<1 .or. ilst>n ) then - info = -13 - end if - if( info==0 ) then - if( n<=1 ) then - lwmin = 1 - else - lwmin = 4*n + 16 - end if - work(1) = lwmin + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) + if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( ldan ) then + info = -12_${ik}$ + else if( ilst<1_${ik}$ .or. ilst>n ) then + info = -13_${ik}$ + end if + if( info==0_${ik}$ ) then + if( n<=1_${ik}$ ) then + lwmin = 1_${ik}$ + else + lwmin = 4_${ik}$*n + 16_${ik}$ + end if + work(1_${ik}$) = lwmin if (lwork1 ) then - if( a( ifst, ifst-1 )/=zero )ifst = ifst - 1 + if( ifst>1_${ik}$ ) then + if( a( ifst, ifst-1 )/=zero )ifst = ifst - 1_${ik}$ end if - nbf = 1 + nbf = 1_${ik}$ if( ifst1 ) then - if( a( ilst, ilst-1 )/=zero )ilst = ilst - 1 + if( ilst>1_${ik}$ ) then + if( a( ilst, ilst-1 )/=zero )ilst = ilst - 1_${ik}$ end if - nbl = 1 + nbl = 1_${ik}$ if( ilst=3 ) then - if( a( here-1, here-2 )/=zero )nbnext = 2 + nbnext = 1_${ik}$ + if( here>=3_${ik}$ ) then + if( a( here-1, here-2 )/=zero )nbnext = 2_${ik}$ end if - call stdlib_dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, here-nbnext, & + call stdlib${ii}$_dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, here-nbnext, & nbnext, nbf, work, lwork,info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then ilst = here return end if here = here - nbnext ! test if 2-by-2 block breaks into two 1-by-1 blocks. - if( nbf==2 ) then - if( a( here+1, here )==zero )nbf = 3 + if( nbf==2_${ik}$ ) then + if( a( here+1, here )==zero )nbf = 3_${ik}$ end if else ! current block consists of two 1-by-1 blocks, each of which ! must be swapped individually. - nbnext = 1 - if( here>=3 ) then - if( a( here-1, here-2 )/=zero )nbnext = 2 + nbnext = 1_${ik}$ + if( here>=3_${ik}$ ) then + if( a( here-1, here-2 )/=zero )nbnext = 2_${ik}$ end if - call stdlib_dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, here-nbnext, & - nbnext, 1, work, lwork,info ) - if( info/=0 ) then + call stdlib${ii}$_dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, here-nbnext, & + nbnext, 1_${ik}$, work, lwork,info ) + if( info/=0_${ik}$ ) then ilst = here return end if - if( nbnext==1 ) then + if( nbnext==1_${ik}$ ) then ! swap two 1-by-1 blocks. - call stdlib_dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, here, & - nbnext, 1, work, lwork, info ) - if( info/=0 ) then + call stdlib${ii}$_dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, here, & + nbnext, 1_${ik}$, work, lwork, info ) + if( info/=0_${ik}$ ) then ilst = here return end if - here = here - 1 + here = here - 1_${ik}$ else ! recompute nbnext in case of 2-by-2 split. - if( a( here, here-1 )==zero )nbnext = 1 - if( nbnext==2 ) then + if( a( here, here-1 )==zero )nbnext = 1_${ik}$ + if( nbnext==2_${ik}$ ) then ! 2-by-2 block did not split. - call stdlib_dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz, here-1,& - 2, 1, work, lwork, info ) - if( info/=0 ) then + call stdlib${ii}$_dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz, here-1,& + 2_${ik}$, 1_${ik}$, work, lwork, info ) + if( info/=0_${ik}$ ) then ilst = here return end if - here = here - 2 + here = here - 2_${ik}$ else ! 2-by-2 block did split. - call stdlib_dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz, here, & - 1, 1, work, lwork, info ) - if( info/=0 ) then + call stdlib${ii}$_dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz, here, & + 1_${ik}$, 1_${ik}$, work, lwork, info ) + if( info/=0_${ik}$ ) then ilst = here return end if - here = here - 1 - call stdlib_dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz, here, & - 1, 1, work, lwork, info ) - if( info/=0 ) then + here = here - 1_${ik}$ + call stdlib${ii}$_dtgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz, here, & + 1_${ik}$, 1_${ik}$, work, lwork, info ) + if( info/=0_${ik}$ ) then ilst = here return end if - here = here - 1 + here = here - 1_${ik}$ end if end if end if if( here>ilst )go to 20 end if ilst = here - work( 1 ) = lwmin + work( 1_${ik}$ ) = lwmin return - end subroutine stdlib_dtgexc + end subroutine stdlib${ii}$_dtgexc - pure subroutine stdlib_dtgsen( ijob, wantq, wantz, select, n, a, lda, b, ldb,alphar, alphai, & + pure subroutine stdlib${ii}$_dtgsen( ijob, wantq, wantz, select, n, a, lda, b, ldb,alphar, alphai, & !! DTGSEN reorders the generalized real Schur decomposition of a real !! matrix pair (A, B) (in terms of an orthonormal equivalence trans- !! formation Q**T * (A, B) * Z), so that a selected cluster of eigenvalues @@ -58582,103 +58582,103 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: wantq, wantz - integer(ilp), intent(in) :: ijob, lda, ldb, ldq, ldz, liwork, lwork, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: ijob, lda, ldb, ldq, ldz, liwork, lwork, n + integer(${ik}$), intent(out) :: info, m real(dp), intent(out) :: pl, pr ! Array Arguments logical(lk), intent(in) :: select(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) real(dp), intent(out) :: alphai(*), alphar(*), beta(*), dif(*), work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: idifjb = 3 + integer(${ik}$), parameter :: idifjb = 3_${ik}$ ! Local Scalars logical(lk) :: lquery, pair, swap, wantd, wantd1, wantd2, wantp - integer(ilp) :: i, ierr, ijb, k, kase, kk, ks, liwmin, lwmin, mn2, n1, n2 + integer(${ik}$) :: i, ierr, ijb, k, kase, kk, ks, liwmin, lwmin, mn2, n1, n2 real(dp) :: dscale, dsum, eps, rdscal, smlnum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: max,sign,sqrt ! Executable Statements ! decode and test the input parameters - info = 0 - lquery = ( lwork==-1 .or. liwork==-1 ) - if( ijob<0 .or. ijob>5 ) then - info = -1 - else if( n<0 ) then - info = -5 - else if( lda5_${ik}$ ) then + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -5_${ik}$ + else if( lda=4 - wantd1 = ijob==2 .or. ijob==4 - wantd2 = ijob==3 .or. ijob==5 + eps = stdlib${ii}$_dlamch( 'P' ) + smlnum = stdlib${ii}$_dlamch( 'S' ) / eps + ierr = 0_${ik}$ + wantp = ijob==1_${ik}$ .or. ijob>=4_${ik}$ + wantd1 = ijob==2_${ik}$ .or. ijob==4_${ik}$ + wantd2 = ijob==3_${ik}$ .or. ijob==5_${ik}$ wantd = wantd1 .or. wantd2 ! set m to the dimension of the specified pair of deflating ! subspaces. - m = 0 + m = 0_${ik}$ pair = .false. - if( .not.lquery .or. ijob/=0 ) then + if( .not.lquery .or. ijob/=0_${ik}$ ) then do k = 1, n if( pair ) then pair = .false. else if( k0 ) then + if( ierr>0_${ik}$ ) then ! swap is rejected: exit. - info = 1 + info = 1_${ik}$ if( wantp ) then pl = zero pr = zero end if if( wantd ) then - dif( 1 ) = zero - dif( 2 ) = zero + dif( 1_${ik}$ ) = zero + dif( 2_${ik}$ ) = zero end if go to 60 end if - if( pair )ks = ks + 1 + if( pair )ks = ks + 1_${ik}$ end if end if end do loop_30 @@ -58740,18 +58740,18 @@ module stdlib_linalg_lapack_d ! and compute pl and pr. n1 = m n2 = n - m - i = n1 + 1 - ijb = 0 - call stdlib_dlacpy( 'FULL', n1, n2, a( 1, i ), lda, work, n1 ) - call stdlib_dlacpy( 'FULL', n1, n2, b( 1, i ), ldb, work( n1*n2+1 ),n1 ) - call stdlib_dtgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b( i,& - i ), ldb, work( n1*n2+1 ), n1,dscale, dif( 1 ), work( n1*n2*2+1 ),lwork-2*n1*n2, & + i = n1 + 1_${ik}$ + ijb = 0_${ik}$ + call stdlib${ii}$_dlacpy( 'FULL', n1, n2, a( 1_${ik}$, i ), lda, work, n1 ) + call stdlib${ii}$_dlacpy( 'FULL', n1, n2, b( 1_${ik}$, i ), ldb, work( n1*n2+1 ),n1 ) + call stdlib${ii}$_dtgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b( i,& + i ), ldb, work( n1*n2+1 ), n1,dscale, dif( 1_${ik}$ ), work( n1*n2*2_${ik}$+1 ),lwork-2*n1*n2, & iwork, ierr ) ! estimate the reciprocal of norms of "projections" onto left ! and right eigenspaces. rdscal = zero dsum = one - call stdlib_dlassq( n1*n2, work, 1, rdscal, dsum ) + call stdlib${ii}$_dlassq( n1*n2, work, 1_${ik}$, rdscal, dsum ) pl = rdscal*sqrt( dsum ) if( pl==zero ) then pl = one @@ -58760,7 +58760,7 @@ module stdlib_linalg_lapack_d end if rdscal = zero dsum = one - call stdlib_dlassq( n1*n2, work( n1*n2+1 ), 1, rdscal, dsum ) + call stdlib${ii}$_dlassq( n1*n2, work( n1*n2+1 ), 1_${ik}$, rdscal, dsum ) pr = rdscal*sqrt( dsum ) if( pr==zero ) then pr = one @@ -58773,65 +58773,65 @@ module stdlib_linalg_lapack_d if( wantd1 ) then n1 = m n2 = n - m - i = n1 + 1 + i = n1 + 1_${ik}$ ijb = idifjb ! frobenius norm-based difu-estimate. - call stdlib_dtgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b(& - i, i ), ldb, work( n1*n2+1 ),n1, dscale, dif( 1 ), work( 2*n1*n2+1 ),lwork-& - 2*n1*n2, iwork, ierr ) + call stdlib${ii}$_dtgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b(& + i, i ), ldb, work( n1*n2+1 ),n1, dscale, dif( 1_${ik}$ ), work( 2_${ik}$*n1*n2+1 ),lwork-& + 2_${ik}$*n1*n2, iwork, ierr ) ! frobenius norm-based difl-estimate. - call stdlib_dtgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda, work,n2, b( i, i ),& - ldb, b, ldb, work( n1*n2+1 ),n2, dscale, dif( 2 ), work( 2*n1*n2+1 ),lwork-& - 2*n1*n2, iwork, ierr ) + call stdlib${ii}$_dtgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda, work,n2, b( i, i ),& + ldb, b, ldb, work( n1*n2+1 ),n2, dscale, dif( 2_${ik}$ ), work( 2_${ik}$*n1*n2+1 ),lwork-& + 2_${ik}$*n1*n2, iwork, ierr ) else ! compute 1-norm-based estimates of difu and difl using - ! reversed communication with stdlib_dlacn2. in each step a + ! reversed communication with stdlib${ii}$_dlacn2. in each step a ! generalized sylvester equation or a transposed variant ! is solved. - kase = 0 + kase = 0_${ik}$ n1 = m n2 = n - m - i = n1 + 1 - ijb = 0 - mn2 = 2*n1*n2 + i = n1 + 1_${ik}$ + ijb = 0_${ik}$ + mn2 = 2_${ik}$*n1*n2 ! 1-norm-based estimate of difu. 40 continue - call stdlib_dlacn2( mn2, work( mn2+1 ), work, iwork, dif( 1 ),kase, isave ) + call stdlib${ii}$_dlacn2( mn2, work( mn2+1 ), work, iwork, dif( 1_${ik}$ ),kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! solve generalized sylvester equation. - call stdlib_dtgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & - ldb, b( i, i ), ldb,work( n1*n2+1 ), n1, dscale, dif( 1 ),work( 2*n1*n2+1 )& + call stdlib${ii}$_dtgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & + ldb, b( i, i ), ldb,work( n1*n2+1 ), n1, dscale, dif( 1_${ik}$ ),work( 2_${ik}$*n1*n2+1 )& , lwork-2*n1*n2, iwork,ierr ) else ! solve the transposed variant. - call stdlib_dtgsyl( 'T', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & - ldb, b( i, i ), ldb,work( n1*n2+1 ), n1, dscale, dif( 1 ),work( 2*n1*n2+1 )& + call stdlib${ii}$_dtgsyl( 'T', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & + ldb, b( i, i ), ldb,work( n1*n2+1 ), n1, dscale, dif( 1_${ik}$ ),work( 2_${ik}$*n1*n2+1 )& , lwork-2*n1*n2, iwork,ierr ) end if go to 40 end if - dif( 1 ) = dscale / dif( 1 ) + dif( 1_${ik}$ ) = dscale / dif( 1_${ik}$ ) ! 1-norm-based estimate of difl. 50 continue - call stdlib_dlacn2( mn2, work( mn2+1 ), work, iwork, dif( 2 ),kase, isave ) + call stdlib${ii}$_dlacn2( mn2, work( mn2+1 ), work, iwork, dif( 2_${ik}$ ),kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! solve generalized sylvester equation. - call stdlib_dtgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b( & - i, i ), ldb, b, ldb,work( n1*n2+1 ), n2, dscale, dif( 2 ),work( 2*n1*n2+1 )& + call stdlib${ii}$_dtgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b( & + i, i ), ldb, b, ldb,work( n1*n2+1 ), n2, dscale, dif( 2_${ik}$ ),work( 2_${ik}$*n1*n2+1 )& , lwork-2*n1*n2, iwork,ierr ) else ! solve the transposed variant. - call stdlib_dtgsyl( 'T', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b( & - i, i ), ldb, b, ldb,work( n1*n2+1 ), n2, dscale, dif( 2 ),work( 2*n1*n2+1 )& + call stdlib${ii}$_dtgsyl( 'T', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b( & + i, i ), ldb, b, ldb,work( n1*n2+1 ), n2, dscale, dif( 2_${ik}$ ),work( 2_${ik}$*n1*n2+1 )& , lwork-2*n1*n2, iwork,ierr ) end if go to 50 end if - dif( 2 ) = dscale / dif( 2 ) + dif( 2_${ik}$ ) = dscale / dif( 2_${ik}$ ) end if end if 60 continue @@ -58849,15 +58849,15 @@ module stdlib_linalg_lapack_d end if if( pair ) then ! compute the eigenvalue(s) at position k. - work( 1 ) = a( k, k ) - work( 2 ) = a( k+1, k ) - work( 3 ) = a( k, k+1 ) - work( 4 ) = a( k+1, k+1 ) - work( 5 ) = b( k, k ) - work( 6 ) = b( k+1, k ) - work( 7 ) = b( k, k+1 ) - work( 8 ) = b( k+1, k+1 ) - call stdlib_dlag2( work, 2, work( 5 ), 2, smlnum*eps, beta( k ),beta( k+1 ), & + work( 1_${ik}$ ) = a( k, k ) + work( 2_${ik}$ ) = a( k+1, k ) + work( 3_${ik}$ ) = a( k, k+1 ) + work( 4_${ik}$ ) = a( k+1, k+1 ) + work( 5_${ik}$ ) = b( k, k ) + work( 6_${ik}$ ) = b( k+1, k ) + work( 7_${ik}$ ) = b( k, k+1 ) + work( 8_${ik}$ ) = b( k+1, k+1 ) + call stdlib${ii}$_dlag2( work, 2_${ik}$, work( 5_${ik}$ ), 2_${ik}$, smlnum*eps, beta( k ),beta( k+1 ), & alphar( k ), alphar( k+1 ),alphai( k ) ) alphai( k+1 ) = -alphai( k ) else @@ -58875,13 +58875,13 @@ module stdlib_linalg_lapack_d end if end if end do loop_80 - work( 1 ) = lwmin - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = lwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_dtgsen + end subroutine stdlib${ii}$_dtgsen - pure subroutine stdlib_dtgsja( jobu, jobv, jobq, m, p, n, k, l, a, lda, b,ldb, tola, tolb, & + pure subroutine stdlib${ii}$_dtgsja( jobu, jobv, jobq, m, p, n, k, l, a, lda, b,ldb, tola, tolb, & !! DTGSJA computes the generalized singular value decomposition (GSVD) !! of two real upper triangular (or trapezoidal) matrices A and B. !! On entry, it is assumed that matrices A and B have the following @@ -58949,21 +58949,21 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobq, jobu, jobv - integer(ilp), intent(out) :: info, ncycle - integer(ilp), intent(in) :: k, l, lda, ldb, ldq, ldu, ldv, m, n, p + integer(${ik}$), intent(out) :: info, ncycle + integer(${ik}$), intent(in) :: k, l, lda, ldb, ldq, ldu, ldv, m, n, p real(dp), intent(in) :: tola, tolb ! Array Arguments real(dp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), u(ldu,*), v(ldv,*) real(dp), intent(out) :: alpha(*), beta(*), work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: maxit = 40 + integer(${ik}$), parameter :: maxit = 40_${ik}$ real(dp), parameter :: hugenum = huge(zero) ! Local Scalars logical(lk) :: initq, initu, initv, upper, wantq, wantu, wantv - integer(ilp) :: i, j, kcycle + integer(${ik}$) :: i, j, kcycle real(dp) :: a1, a2, a3, b1, b2, b3, csq, csu, csv, error, gamma, rwk, snq, snu, snv, & ssmin ! Intrinsic Functions @@ -58976,38 +58976,38 @@ module stdlib_linalg_lapack_d wantv = initv .or. stdlib_lsame( jobv, 'V' ) initq = stdlib_lsame( jobq, 'I' ) wantq = initq .or. stdlib_lsame( jobq, 'Q' ) - info = 0 + info = 0_${ik}$ if( .not.( initu .or. wantu .or. stdlib_lsame( jobu, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( initv .or. wantv .or. stdlib_lsame( jobv, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( initq .or. wantq .or. stdlib_lsame( jobq, 'N' ) ) ) then - info = -3 - else if( m<0 ) then - info = -4 - else if( p<0 ) then - info = -5 - else if( n<0 ) then - info = -6 - else if( lda=-hugenum) ) then ! change sign if necessary if( gamma=beta( k+i ) ) then - call stdlib_dscal( l-i+1, one / alpha( k+i ), a( k+i, n-l+i ),lda ) + call stdlib${ii}$_dscal( l-i+1, one / alpha( k+i ), a( k+i, n-l+i ),lda ) else - call stdlib_dscal( l-i+1, one / beta( k+i ), b( i, n-l+i ),ldb ) - call stdlib_dcopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) + call stdlib${ii}$_dscal( l-i+1, one / beta( k+i ), b( i, n-l+i ),ldb ) + call stdlib${ii}$_dcopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) end if else alpha( k+i ) = zero beta( k+i ) = one - call stdlib_dcopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) + call stdlib${ii}$_dcopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) end if end do ! post-assignment @@ -59119,10 +59119,10 @@ module stdlib_linalg_lapack_d 100 continue ncycle = kcycle return - end subroutine stdlib_dtgsja + end subroutine stdlib${ii}$_dtgsja - pure subroutine stdlib_dtgsna( job, howmny, select, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, s, & + pure subroutine stdlib${ii}$_dtgsna( job, howmny, select, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, s, & !! DTGSNA estimates reciprocal condition numbers for specified !! eigenvalues and/or eigenvectors of a matrix pair (A, B) in !! generalized real Schur canonical form (or of any matrix pair @@ -59137,25 +59137,25 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: howmny, job - integer(ilp), intent(out) :: info, m - integer(ilp), intent(in) :: lda, ldb, ldvl, ldvr, lwork, mm, n + integer(${ik}$), intent(out) :: info, m + integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, mm, n ! Array Arguments logical(lk), intent(in) :: select(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(in) :: a(lda,*), b(ldb,*), vl(ldvl,*), vr(ldvr,*) real(dp), intent(out) :: dif(*), s(*), work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: difdri = 3 + integer(${ik}$), parameter :: difdri = 3_${ik}$ ! Local Scalars logical(lk) :: lquery, pair, somcon, wantbh, wantdf, wants - integer(ilp) :: i, ierr, ifst, ilst, iz, k, ks, lwmin, n1, n2 + integer(${ik}$) :: i, ierr, ifst, ilst, iz, k, ks, lwmin, n1, n2 real(dp) :: alphai, alphar, alprqt, beta, c1, c2, cond, eps, lnrm, rnrm, root1, root2, & scale, smlnum, tmpii, tmpir, tmpri, tmprr, uhav, uhavi, uhbv, uhbvi ! Local Arrays - real(dp) :: dummy(1), dummy1(1) + real(dp) :: dummy(1_${ik}$), dummy1(1_${ik}$) ! Intrinsic Functions intrinsic :: max,min,sqrt ! Executable Statements @@ -59164,27 +59164,27 @@ module stdlib_linalg_lapack_d wants = stdlib_lsame( job, 'E' ) .or. wantbh wantdf = stdlib_lsame( job, 'V' ) .or. wantbh somcon = stdlib_lsame( howmny, 'S' ) - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) if( .not.wants .and. .not.wantdf ) then - info = -1 + info = -1_${ik}$ else if( .not.stdlib_lsame( howmny, 'A' ) .and. .not.somcon ) then - info = -2 - else if( n<0 ) then - info = -4 - else if( lda0 ) then + ilst = 1_${ik}$ + call stdlib${ii}$_dtgexc( .false., .false., n, work, n, work( n*n+1 ), n,dummy, 1_${ik}$, & + dummy1, 1_${ik}$, ifst, ilst,work( n*n*2_${ik}$+1 ), lwork-2*n*n, ierr ) + if( ierr>0_${ik}$ ) then ! ill-conditioned problem - swap rejected. dif( ks ) = zero else @@ -59347,15 +59347,15 @@ module stdlib_linalg_lapack_d ! a22 * r - l * a11 = a12 ! b22 * r - l * b11 = b12, ! and compute estimate of difl((a11,b11), (a22, b22)). - n1 = 1 - if( work( 2 )/=zero )n1 = 2 + n1 = 1_${ik}$ + if( work( 2_${ik}$ )/=zero )n1 = 2_${ik}$ n2 = n - n1 - if( n2==0 ) then + if( n2==0_${ik}$ ) then dif( ks ) = cond else - i = n*n + 1 - iz = 2*n*n + 1 - call stdlib_dtgsyl( 'N', difdri, n2, n1, work( n*n1+n1+1 ),n, work, n, & + i = n*n + 1_${ik}$ + iz = 2_${ik}$*n*n + 1_${ik}$ + call stdlib${ii}$_dtgsyl( 'N', difdri, n2, n1, work( n*n1+n1+1 ),n, work, n, & work( n1+1 ), n,work( n*n1+n1+i ), n, work( i ), n,work( n1+i ), n, scale, & dif( ks ),work( iz+1 ), lwork-2*n*n, iwork, ierr ) if( pair )dif( ks ) = min( max( one, alprqt )*dif( ks ),cond ) @@ -59363,14 +59363,14 @@ module stdlib_linalg_lapack_d end if if( pair )dif( ks+1 ) = dif( ks ) end if - if( pair )ks = ks + 1 + if( pair )ks = ks + 1_${ik}$ end do loop_20 - work( 1 ) = lwmin + work( 1_${ik}$ ) = lwmin return - end subroutine stdlib_dtgsna + end subroutine stdlib${ii}$_dtgsna - pure subroutine stdlib_dtplqt( m, n, l, mb, a, lda, b, ldb, t, ldt, work,info ) + pure subroutine stdlib${ii}$_dtplqt( m, n, l, mb, a, lda, b, ldb, t, ldt, work,info ) !! DTPLQT computes a blocked LQ factorization of a real !! "triangular-pentagonal" matrix C, which is composed of a !! triangular block A and pentagonal block B, using the compact @@ -59379,34 +59379,34 @@ module stdlib_linalg_lapack_d ! -- 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, ldb, ldt, n, m, l, mb + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l, mb ! Array Arguments real(dp), intent(inout) :: a(lda,*), b(ldb,*) real(dp), intent(out) :: t(ldt,*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ib, lb, nb, iinfo + integer(${ik}$) :: i, ib, lb, nb, iinfo ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( l<0 .or. (l>min(m,n) .and. min(m,n)>=0)) then - info = -3 - else if( mb<1 .or. (mb>m .and. m>0)) then - info = -4 - else if( ldamin(m,n) .and. min(m,n)>=0_${ik}$)) then + info = -3_${ik}$ + else if( mb<1_${ik}$ .or. (mb>m .and. m>0_${ik}$)) then + info = -4_${ik}$ + else if( lda=l ) then - lb = 0 + lb = 0_${ik}$ else lb = nb-n+l-i+1 end if - call stdlib_dtplqt2( ib, nb, lb, a(i,i), lda, b( i, 1 ), ldb,t(1, i ), ldt, iinfo ) + call stdlib${ii}$_dtplqt2( ib, nb, lb, a(i,i), lda, b( i, 1_${ik}$ ), ldb,t(1_${ik}$, i ), ldt, iinfo ) ! update by applying h**t to b(i+ib:m,:) from the right if( i+ib<=m ) then - call stdlib_dtprfb( 'R', 'N', 'F', 'R', m-i-ib+1, nb, ib, lb,b( i, 1 ), ldb, t( & - 1, i ), ldt,a( i+ib, i ), lda, b( i+ib, 1 ), ldb,work, m-i-ib+1) + call stdlib${ii}$_dtprfb( 'R', 'N', 'F', 'R', m-i-ib+1, nb, ib, lb,b( i, 1_${ik}$ ), ldb, t( & + 1_${ik}$, i ), ldt,a( i+ib, i ), lda, b( i+ib, 1_${ik}$ ), ldb,work, m-i-ib+1) end if end do return - end subroutine stdlib_dtplqt + end subroutine stdlib${ii}$_dtplqt - pure subroutine stdlib_dtpqrt( m, n, l, nb, a, lda, b, ldb, t, ldt, work,info ) + pure subroutine stdlib${ii}$_dtpqrt( m, n, l, nb, a, lda, b, ldb, t, ldt, work,info ) !! DTPQRT computes a blocked QR factorization of a real !! "triangular-pentagonal" matrix C, which is composed of a !! triangular block A and pentagonal block B, using the compact @@ -59441,34 +59441,34 @@ module stdlib_linalg_lapack_d ! -- 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, ldb, ldt, n, m, l, nb + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l, nb ! Array Arguments real(dp), intent(inout) :: a(lda,*), b(ldb,*) real(dp), intent(out) :: t(ldt,*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ib, lb, mb, iinfo + integer(${ik}$) :: i, ib, lb, mb, iinfo ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( l<0 .or. (l>min(m,n) .and. min(m,n)>=0)) then - info = -3 - else if( nb<1 .or. (nb>n .and. n>0)) then - info = -4 - else if( ldamin(m,n) .and. min(m,n)>=0_${ik}$)) then + info = -3_${ik}$ + else if( nb<1_${ik}$ .or. (nb>n .and. n>0_${ik}$)) then + info = -4_${ik}$ + else if( lda=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-m+l-i+1 end if - call stdlib_dtpqrt2( mb, ib, lb, a(i,i), lda, b( 1, i ), ldb,t(1, i ), ldt, iinfo ) + call stdlib${ii}$_dtpqrt2( mb, ib, lb, a(i,i), lda, b( 1_${ik}$, i ), ldb,t(1_${ik}$, i ), ldt, iinfo ) ! update by applying h**t to b(:,i+ib:n) from the left if( i+ib<=n ) then - call stdlib_dtprfb( 'L', 'T', 'F', 'C', mb, n-i-ib+1, ib, lb,b( 1, i ), ldb, t( & - 1, i ), ldt,a( i, i+ib ), lda, b( 1, i+ib ), ldb,work, ib ) + call stdlib${ii}$_dtprfb( 'L', 'T', 'F', 'C', mb, n-i-ib+1, ib, lb,b( 1_${ik}$, i ), ldb, t( & + 1_${ik}$, i ), ldt,a( i, i+ib ), lda, b( 1_${ik}$, i+ib ), ldb,work, ib ) end if end do return - end subroutine stdlib_dtpqrt + end subroutine stdlib${ii}$_dtpqrt - pure subroutine stdlib_dtrevc( side, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, mm, m, & + pure subroutine stdlib${ii}$_dtrevc( side, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, mm, m, & !! DTREVC computes some or all of the right and/or left eigenvectors of !! a real upper quasi-triangular matrix T. !! Matrices of this type are produced by the Schur factorization of @@ -59516,8 +59516,8 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: howmny, side - integer(ilp), intent(out) :: info, m - integer(ilp), intent(in) :: ldt, ldvl, ldvr, mm, n + integer(${ik}$), intent(out) :: info, m + integer(${ik}$), intent(in) :: ldt, ldvl, ldvr, mm, n ! Array Arguments logical(lk), intent(inout) :: select(*) real(dp), intent(in) :: t(ldt,*) @@ -59527,13 +59527,13 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: allv, bothv, leftv, over, pair, rightv, somev - integer(ilp) :: i, ierr, ii, ip, is, j, j1, j2, jnxt, k, ki, n2 + integer(${ik}$) :: i, ierr, ii, ip, is, j, j1, j2, jnxt, k, ki, n2 real(dp) :: beta, bignum, emax, ovfl, rec, remax, scale, smin, smlnum, ulp, unfl, & vcrit, vmax, wi, wr, xnorm ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Local Arrays - real(dp) :: x(2,2) + real(dp) :: x(2_${ik}$,2_${ik}$) ! Executable Statements ! decode and test the input parameters bothv = stdlib_lsame( side, 'B' ) @@ -59542,25 +59542,25 @@ module stdlib_linalg_lapack_d allv = stdlib_lsame( howmny, 'A' ) over = stdlib_lsame( howmny, 'B' ) somev = stdlib_lsame( howmny, 'S' ) - info = 0 + info = 0_${ik}$ if( .not.rightv .and. .not.leftv ) then - info = -1 + info = -1_${ik}$ else if( .not.allv .and. .not.over .and. .not.somev ) then - info = -2 - else if( n<0 ) then - info = -4 - else if( ldtjnxt )cycle loop_60 j1 = j j2 = j - jnxt = j - 1 - if( j>1 ) then + jnxt = j - 1_${ik}$ + if( j>1_${ik}$ ) then if( t( j, j-1 )/=zero ) then - j1 = j - 1 - jnxt = j - 2 + j1 = j - 1_${ik}$ + jnxt = j - 2_${ik}$ end if end if if( j1==j2 ) then ! 1-by-1 diagonal block - call stdlib_dlaln2( .false., 1, 1, smin, one, t( j, j ),ldt, one, one, & - work( j+n ), n, wr,zero, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_dlaln2( .false., 1_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr ) ! scale x(1,1) to avoid overflow when updating ! the right-hand side. if( xnorm>one ) then if( work( j )>bignum / xnorm ) then - x( 1, 1 ) = x( 1, 1 ) / xnorm + x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm scale = scale / xnorm end if end if ! scale if necessary - if( scale/=one )call stdlib_dscal( ki, scale, work( 1+n ), 1 ) - work( j+n ) = x( 1, 1 ) + if( scale/=one )call stdlib${ii}$_dscal( ki, scale, work( 1_${ik}$+n ), 1_${ik}$ ) + work( j+n ) = x( 1_${ik}$, 1_${ik}$ ) ! update right-hand side - call stdlib_daxpy( j-1, -x( 1, 1 ), t( 1, j ), 1,work( 1+n ), 1 ) + call stdlib${ii}$_daxpy( j-1, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ ) else ! 2-by-2 diagonal block - call stdlib_dlaln2( .false., 2, 1, smin, one,t( j-1, j-1 ), ldt, one, & - one,work( j-1+n ), n, wr, zero, x, 2,scale, xnorm, ierr ) + call stdlib${ii}$_dlaln2( .false., 2_${ik}$, 1_${ik}$, smin, one,t( j-1, j-1 ), ldt, one, & + one,work( j-1+n ), n, wr, zero, x, 2_${ik}$,scale, xnorm, ierr ) ! scale x(1,1) and x(2,1) to avoid overflow when ! updating the right-hand side. if( xnorm>one ) then beta = max( work( j-1 ), work( j ) ) if( beta>bignum / xnorm ) then - x( 1, 1 ) = x( 1, 1 ) / xnorm - x( 2, 1 ) = x( 2, 1 ) / xnorm + x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm + x( 2_${ik}$, 1_${ik}$ ) = x( 2_${ik}$, 1_${ik}$ ) / xnorm scale = scale / xnorm end if end if ! scale if necessary - if( scale/=one )call stdlib_dscal( ki, scale, work( 1+n ), 1 ) - work( j-1+n ) = x( 1, 1 ) - work( j+n ) = x( 2, 1 ) + if( scale/=one )call stdlib${ii}$_dscal( ki, scale, work( 1_${ik}$+n ), 1_${ik}$ ) + work( j-1+n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+n ) = x( 2_${ik}$, 1_${ik}$ ) ! update right-hand side - call stdlib_daxpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,work( 1+n ), 1 ) + call stdlib${ii}$_daxpy( j-2, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ ) - call stdlib_daxpy( j-2, -x( 2, 1 ), t( 1, j ), 1,work( 1+n ), 1 ) + call stdlib${ii}$_daxpy( j-2, -x( 2_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ ) end if end do loop_60 ! copy the vector x or q*x to vr and normalize. if( .not.over ) then - call stdlib_dcopy( ki, work( 1+n ), 1, vr( 1, is ), 1 ) - ii = stdlib_idamax( ki, vr( 1, is ), 1 ) + call stdlib${ii}$_dcopy( ki, work( 1_${ik}$+n ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ ) + ii = stdlib${ii}$_idamax( ki, vr( 1_${ik}$, is ), 1_${ik}$ ) remax = one / abs( vr( ii, is ) ) - call stdlib_dscal( ki, remax, vr( 1, is ), 1 ) + call stdlib${ii}$_dscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ ) do k = ki + 1, n vr( k, is ) = zero end do else - if( ki>1 )call stdlib_dgemv( 'N', n, ki-1, one, vr, ldvr,work( 1+n ), 1, & - work( ki+n ),vr( 1, ki ), 1 ) - ii = stdlib_idamax( n, vr( 1, ki ), 1 ) + if( ki>1_${ik}$ )call stdlib${ii}$_dgemv( 'N', n, ki-1, one, vr, ldvr,work( 1_${ik}$+n ), 1_${ik}$, & + work( ki+n ),vr( 1_${ik}$, ki ), 1_${ik}$ ) + ii = stdlib${ii}$_idamax( n, vr( 1_${ik}$, ki ), 1_${ik}$ ) remax = one / abs( vr( ii, ki ) ) - call stdlib_dscal( n, remax, vr( 1, ki ), 1 ) + call stdlib${ii}$_dscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ ) end if else ! complex right eigenvector. @@ -59739,130 +59739,130 @@ module stdlib_linalg_lapack_d end do ! solve upper quasi-triangular system: ! (t(1:ki-2,1:ki-2) - (wr+i*wi))*x = scale*(work+i*work2) - jnxt = ki - 2 + jnxt = ki - 2_${ik}$ loop_90: do j = ki - 2, 1, -1 if( j>jnxt )cycle loop_90 j1 = j j2 = j - jnxt = j - 1 - if( j>1 ) then + jnxt = j - 1_${ik}$ + if( j>1_${ik}$ ) then if( t( j, j-1 )/=zero ) then - j1 = j - 1 - jnxt = j - 2 + j1 = j - 1_${ik}$ + jnxt = j - 2_${ik}$ end if end if if( j1==j2 ) then ! 1-by-1 diagonal block - call stdlib_dlaln2( .false., 1, 2, smin, one, t( j, j ),ldt, one, one, & - work( j+n ), n, wr, wi,x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_dlaln2( .false., 1_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+n ), n, wr, wi,x, 2_${ik}$, scale, xnorm, ierr ) ! scale x(1,1) and x(1,2) to avoid overflow when ! updating the right-hand side. if( xnorm>one ) then if( work( j )>bignum / xnorm ) then - x( 1, 1 ) = x( 1, 1 ) / xnorm - x( 1, 2 ) = x( 1, 2 ) / xnorm + x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm + x( 1_${ik}$, 2_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ ) / xnorm scale = scale / xnorm end if end if ! scale if necessary if( scale/=one ) then - call stdlib_dscal( ki, scale, work( 1+n ), 1 ) - call stdlib_dscal( ki, scale, work( 1+n2 ), 1 ) + call stdlib${ii}$_dscal( ki, scale, work( 1_${ik}$+n ), 1_${ik}$ ) + call stdlib${ii}$_dscal( ki, scale, work( 1_${ik}$+n2 ), 1_${ik}$ ) end if - work( j+n ) = x( 1, 1 ) - work( j+n2 ) = x( 1, 2 ) + work( j+n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+n2 ) = x( 1_${ik}$, 2_${ik}$ ) ! update the right-hand side - call stdlib_daxpy( j-1, -x( 1, 1 ), t( 1, j ), 1,work( 1+n ), 1 ) + call stdlib${ii}$_daxpy( j-1, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ ) - call stdlib_daxpy( j-1, -x( 1, 2 ), t( 1, j ), 1,work( 1+n2 ), 1 ) + call stdlib${ii}$_daxpy( j-1, -x( 1_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n2 ), 1_${ik}$ ) else ! 2-by-2 diagonal block - call stdlib_dlaln2( .false., 2, 2, smin, one,t( j-1, j-1 ), ldt, one, & - one,work( j-1+n ), n, wr, wi, x, 2, scale,xnorm, ierr ) + call stdlib${ii}$_dlaln2( .false., 2_${ik}$, 2_${ik}$, smin, one,t( j-1, j-1 ), ldt, one, & + one,work( j-1+n ), n, wr, wi, x, 2_${ik}$, scale,xnorm, ierr ) ! scale x to avoid overflow when updating ! the right-hand side. if( xnorm>one ) then beta = max( work( j-1 ), work( j ) ) if( beta>bignum / xnorm ) then rec = one / xnorm - x( 1, 1 ) = x( 1, 1 )*rec - x( 1, 2 ) = x( 1, 2 )*rec - x( 2, 1 ) = x( 2, 1 )*rec - x( 2, 2 ) = x( 2, 2 )*rec + x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ )*rec + x( 1_${ik}$, 2_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ )*rec + x( 2_${ik}$, 1_${ik}$ ) = x( 2_${ik}$, 1_${ik}$ )*rec + x( 2_${ik}$, 2_${ik}$ ) = x( 2_${ik}$, 2_${ik}$ )*rec scale = scale*rec end if end if ! scale if necessary if( scale/=one ) then - call stdlib_dscal( ki, scale, work( 1+n ), 1 ) - call stdlib_dscal( ki, scale, work( 1+n2 ), 1 ) + call stdlib${ii}$_dscal( ki, scale, work( 1_${ik}$+n ), 1_${ik}$ ) + call stdlib${ii}$_dscal( ki, scale, work( 1_${ik}$+n2 ), 1_${ik}$ ) end if - work( j-1+n ) = x( 1, 1 ) - work( j+n ) = x( 2, 1 ) - work( j-1+n2 ) = x( 1, 2 ) - work( j+n2 ) = x( 2, 2 ) + work( j-1+n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+n ) = x( 2_${ik}$, 1_${ik}$ ) + work( j-1+n2 ) = x( 1_${ik}$, 2_${ik}$ ) + work( j+n2 ) = x( 2_${ik}$, 2_${ik}$ ) ! update the right-hand side - call stdlib_daxpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,work( 1+n ), 1 ) + call stdlib${ii}$_daxpy( j-2, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ ) - call stdlib_daxpy( j-2, -x( 2, 1 ), t( 1, j ), 1,work( 1+n ), 1 ) + call stdlib${ii}$_daxpy( j-2, -x( 2_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ ) - call stdlib_daxpy( j-2, -x( 1, 2 ), t( 1, j-1 ), 1,work( 1+n2 ), 1 ) + call stdlib${ii}$_daxpy( j-2, -x( 1_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+n2 ), 1_${ik}$ ) - call stdlib_daxpy( j-2, -x( 2, 2 ), t( 1, j ), 1,work( 1+n2 ), 1 ) + call stdlib${ii}$_daxpy( j-2, -x( 2_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n2 ), 1_${ik}$ ) end if end do loop_90 ! copy the vector x or q*x to vr and normalize. if( .not.over ) then - call stdlib_dcopy( ki, work( 1+n ), 1, vr( 1, is-1 ), 1 ) - call stdlib_dcopy( ki, work( 1+n2 ), 1, vr( 1, is ), 1 ) + call stdlib${ii}$_dcopy( ki, work( 1_${ik}$+n ), 1_${ik}$, vr( 1_${ik}$, is-1 ), 1_${ik}$ ) + call stdlib${ii}$_dcopy( ki, work( 1_${ik}$+n2 ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ ) emax = zero do k = 1, ki emax = max( emax, abs( vr( k, is-1 ) )+abs( vr( k, is ) ) ) end do remax = one / emax - call stdlib_dscal( ki, remax, vr( 1, is-1 ), 1 ) - call stdlib_dscal( ki, remax, vr( 1, is ), 1 ) + call stdlib${ii}$_dscal( ki, remax, vr( 1_${ik}$, is-1 ), 1_${ik}$ ) + call stdlib${ii}$_dscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ ) do k = ki + 1, n vr( k, is-1 ) = zero vr( k, is ) = zero end do else - if( ki>2 ) then - call stdlib_dgemv( 'N', n, ki-2, one, vr, ldvr,work( 1+n ), 1, work( ki-& - 1+n ),vr( 1, ki-1 ), 1 ) - call stdlib_dgemv( 'N', n, ki-2, one, vr, ldvr,work( 1+n2 ), 1, work( & - ki+n2 ),vr( 1, ki ), 1 ) + if( ki>2_${ik}$ ) then + call stdlib${ii}$_dgemv( 'N', n, ki-2, one, vr, ldvr,work( 1_${ik}$+n ), 1_${ik}$, work( ki-& + 1_${ik}$+n ),vr( 1_${ik}$, ki-1 ), 1_${ik}$ ) + call stdlib${ii}$_dgemv( 'N', n, ki-2, one, vr, ldvr,work( 1_${ik}$+n2 ), 1_${ik}$, work( & + ki+n2 ),vr( 1_${ik}$, ki ), 1_${ik}$ ) else - call stdlib_dscal( n, work( ki-1+n ), vr( 1, ki-1 ), 1 ) - call stdlib_dscal( n, work( ki+n2 ), vr( 1, ki ), 1 ) + call stdlib${ii}$_dscal( n, work( ki-1+n ), vr( 1_${ik}$, ki-1 ), 1_${ik}$ ) + call stdlib${ii}$_dscal( n, work( ki+n2 ), vr( 1_${ik}$, ki ), 1_${ik}$ ) end if emax = zero do k = 1, n emax = max( emax, abs( vr( k, ki-1 ) )+abs( vr( k, ki ) ) ) end do remax = one / emax - call stdlib_dscal( n, remax, vr( 1, ki-1 ), 1 ) - call stdlib_dscal( n, remax, vr( 1, ki ), 1 ) + call stdlib${ii}$_dscal( n, remax, vr( 1_${ik}$, ki-1 ), 1_${ik}$ ) + call stdlib${ii}$_dscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ ) end if end if - is = is - 1 - if( ip/=0 )is = is - 1 + is = is - 1_${ik}$ + if( ip/=0_${ik}$ )is = is - 1_${ik}$ 130 continue - if( ip==1 )ip = 0 - if( ip==-1 )ip = 1 + if( ip==1_${ik}$ )ip = 0_${ik}$ + if( ip==-1_${ik}$ )ip = 1_${ik}$ end do loop_140 end if if( leftv ) then ! compute left eigenvectors. - ip = 0 - is = 1 + ip = 0_${ik}$ + is = 1_${ik}$ loop_260: do ki = 1, n if( ip==-1 )go to 250 if( ki==n )go to 150 if( t( ki+1, ki )==zero )go to 150 - ip = 1 + ip = 1_${ik}$ 150 continue if( somev ) then if( .not.select( ki ) )go to 250 @@ -59870,9 +59870,9 @@ module stdlib_linalg_lapack_d ! compute the ki-th eigenvalue (wr,wi). wr = t( ki, ki ) wi = zero - if( ip/=0 )wi = sqrt( abs( t( ki, ki+1 ) ) )*sqrt( abs( t( ki+1, ki ) ) ) + if( ip/=0_${ik}$ )wi = sqrt( abs( t( ki, ki+1 ) ) )*sqrt( abs( t( ki+1, ki ) ) ) smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum ) - if( ip==0 ) then + if( ip==0_${ik}$ ) then ! real left eigenvector. work( ki+n ) = one ! form right-hand side @@ -59883,16 +59883,16 @@ module stdlib_linalg_lapack_d ! (t(ki+1:n,ki+1:n) - wr)**t*x = scale*work vmax = one vcrit = bignum - jnxt = ki + 1 + jnxt = ki + 1_${ik}$ loop_170: do j = ki + 1, n if( jvcrit ) then rec = one / vmax - call stdlib_dscal( n-ki+1, rec, work( ki+n ), 1 ) + call stdlib${ii}$_dscal( n-ki+1, rec, work( ki+n ), 1_${ik}$ ) vmax = one vcrit = bignum end if - work( j+n ) = work( j+n ) -stdlib_ddot( j-ki-1, t( ki+1, j ), 1,work( & - ki+1+n ), 1 ) + work( j+n ) = work( j+n ) -stdlib${ii}$_ddot( j-ki-1, t( ki+1, j ), 1_${ik}$,work( & + ki+1+n ), 1_${ik}$ ) ! solve (t(j,j)-wr)**t*x = work - call stdlib_dlaln2( .false., 1, 1, smin, one, t( j, j ),ldt, one, one, & - work( j+n ), n, wr,zero, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_dlaln2( .false., 1_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr ) ! scale if necessary - if( scale/=one )call stdlib_dscal( n-ki+1, scale, work( ki+n ), 1 ) + if( scale/=one )call stdlib${ii}$_dscal( n-ki+1, scale, work( ki+n ), 1_${ik}$ ) - work( j+n ) = x( 1, 1 ) + work( j+n ) = x( 1_${ik}$, 1_${ik}$ ) vmax = max( abs( work( j+n ) ), vmax ) vcrit = bignum / vmax else @@ -59923,43 +59923,43 @@ module stdlib_linalg_lapack_d beta = max( work( j ), work( j+1 ) ) if( beta>vcrit ) then rec = one / vmax - call stdlib_dscal( n-ki+1, rec, work( ki+n ), 1 ) + call stdlib${ii}$_dscal( n-ki+1, rec, work( ki+n ), 1_${ik}$ ) vmax = one vcrit = bignum end if - work( j+n ) = work( j+n ) -stdlib_ddot( j-ki-1, t( ki+1, j ), 1,work( & - ki+1+n ), 1 ) - work( j+1+n ) = work( j+1+n ) -stdlib_ddot( j-ki-1, t( ki+1, j+1 ), 1,& - work( ki+1+n ), 1 ) + work( j+n ) = work( j+n ) -stdlib${ii}$_ddot( j-ki-1, t( ki+1, j ), 1_${ik}$,work( & + ki+1+n ), 1_${ik}$ ) + work( j+1+n ) = work( j+1+n ) -stdlib${ii}$_ddot( j-ki-1, t( ki+1, j+1 ), 1_${ik}$,& + work( ki+1+n ), 1_${ik}$ ) ! solve ! [t(j,j)-wr t(j,j+1) ]**t * x = scale*( work1 ) ! [t(j+1,j) t(j+1,j+1)-wr] ( work2 ) - call stdlib_dlaln2( .true., 2, 1, smin, one, t( j, j ),ldt, one, one, & - work( j+n ), n, wr,zero, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_dlaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr ) ! scale if necessary - if( scale/=one )call stdlib_dscal( n-ki+1, scale, work( ki+n ), 1 ) + if( scale/=one )call stdlib${ii}$_dscal( n-ki+1, scale, work( ki+n ), 1_${ik}$ ) - work( j+n ) = x( 1, 1 ) - work( j+1+n ) = x( 2, 1 ) + work( j+n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+1+n ) = x( 2_${ik}$, 1_${ik}$ ) vmax = max( abs( work( j+n ) ),abs( work( j+1+n ) ), vmax ) vcrit = bignum / vmax end if end do loop_170 ! copy the vector x or q*x to vl and normalize. if( .not.over ) then - call stdlib_dcopy( n-ki+1, work( ki+n ), 1, vl( ki, is ), 1 ) - ii = stdlib_idamax( n-ki+1, vl( ki, is ), 1 ) + ki - 1 + call stdlib${ii}$_dcopy( n-ki+1, work( ki+n ), 1_${ik}$, vl( ki, is ), 1_${ik}$ ) + ii = stdlib${ii}$_idamax( n-ki+1, vl( ki, is ), 1_${ik}$ ) + ki - 1_${ik}$ remax = one / abs( vl( ii, is ) ) - call stdlib_dscal( n-ki+1, remax, vl( ki, is ), 1 ) + call stdlib${ii}$_dscal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ ) do k = 1, ki - 1 vl( k, is ) = zero end do else - if( kivcrit ) then rec = one / vmax - call stdlib_dscal( n-ki+1, rec, work( ki+n ), 1 ) - call stdlib_dscal( n-ki+1, rec, work( ki+n2 ), 1 ) + call stdlib${ii}$_dscal( n-ki+1, rec, work( ki+n ), 1_${ik}$ ) + call stdlib${ii}$_dscal( n-ki+1, rec, work( ki+n2 ), 1_${ik}$ ) vmax = one vcrit = bignum end if - work( j+n ) = work( j+n ) -stdlib_ddot( j-ki-2, t( ki+2, j ), 1,work( & - ki+2+n ), 1 ) - work( j+n2 ) = work( j+n2 ) -stdlib_ddot( j-ki-2, t( ki+2, j ), 1,work( & - ki+2+n2 ), 1 ) + work( j+n ) = work( j+n ) -stdlib${ii}$_ddot( j-ki-2, t( ki+2, j ), 1_${ik}$,work( & + ki+2+n ), 1_${ik}$ ) + work( j+n2 ) = work( j+n2 ) -stdlib${ii}$_ddot( j-ki-2, t( ki+2, j ), 1_${ik}$,work( & + ki+2+n2 ), 1_${ik}$ ) ! solve (t(j,j)-(wr-i*wi))*(x11+i*x12)= wk+i*wk2 - call stdlib_dlaln2( .false., 1, 2, smin, one, t( j, j ),ldt, one, one, & - work( j+n ), n, wr,-wi, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_dlaln2( .false., 1_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+n ), n, wr,-wi, x, 2_${ik}$, scale, xnorm, ierr ) ! scale if necessary if( scale/=one ) then - call stdlib_dscal( n-ki+1, scale, work( ki+n ), 1 ) - call stdlib_dscal( n-ki+1, scale, work( ki+n2 ), 1 ) + call stdlib${ii}$_dscal( n-ki+1, scale, work( ki+n ), 1_${ik}$ ) + call stdlib${ii}$_dscal( n-ki+1, scale, work( ki+n2 ), 1_${ik}$ ) end if - work( j+n ) = x( 1, 1 ) - work( j+n2 ) = x( 1, 2 ) + work( j+n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+n2 ) = x( 1_${ik}$, 2_${ik}$ ) vmax = max( abs( work( j+n ) ),abs( work( j+n2 ) ), vmax ) vcrit = bignum / vmax else @@ -60030,84 +60030,84 @@ module stdlib_linalg_lapack_d beta = max( work( j ), work( j+1 ) ) if( beta>vcrit ) then rec = one / vmax - call stdlib_dscal( n-ki+1, rec, work( ki+n ), 1 ) - call stdlib_dscal( n-ki+1, rec, work( ki+n2 ), 1 ) + call stdlib${ii}$_dscal( n-ki+1, rec, work( ki+n ), 1_${ik}$ ) + call stdlib${ii}$_dscal( n-ki+1, rec, work( ki+n2 ), 1_${ik}$ ) vmax = one vcrit = bignum end if - work( j+n ) = work( j+n ) -stdlib_ddot( j-ki-2, t( ki+2, j ), 1,work( & - ki+2+n ), 1 ) - work( j+n2 ) = work( j+n2 ) -stdlib_ddot( j-ki-2, t( ki+2, j ), 1,work( & - ki+2+n2 ), 1 ) - work( j+1+n ) = work( j+1+n ) -stdlib_ddot( j-ki-2, t( ki+2, j+1 ), 1,& - work( ki+2+n ), 1 ) - work( j+1+n2 ) = work( j+1+n2 ) -stdlib_ddot( j-ki-2, t( ki+2, j+1 ), 1,& - work( ki+2+n2 ), 1 ) + work( j+n ) = work( j+n ) -stdlib${ii}$_ddot( j-ki-2, t( ki+2, j ), 1_${ik}$,work( & + ki+2+n ), 1_${ik}$ ) + work( j+n2 ) = work( j+n2 ) -stdlib${ii}$_ddot( j-ki-2, t( ki+2, j ), 1_${ik}$,work( & + ki+2+n2 ), 1_${ik}$ ) + work( j+1+n ) = work( j+1+n ) -stdlib${ii}$_ddot( j-ki-2, t( ki+2, j+1 ), 1_${ik}$,& + work( ki+2+n ), 1_${ik}$ ) + work( j+1+n2 ) = work( j+1+n2 ) -stdlib${ii}$_ddot( j-ki-2, t( ki+2, j+1 ), 1_${ik}$,& + work( ki+2+n2 ), 1_${ik}$ ) ! solve 2-by-2 complex linear equation ! ([t(j,j) t(j,j+1) ]**t-(wr-i*wi)*i)*x = scale*b ! ([t(j+1,j) t(j+1,j+1)] ) - call stdlib_dlaln2( .true., 2, 2, smin, one, t( j, j ),ldt, one, one, & - work( j+n ), n, wr,-wi, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_dlaln2( .true., 2_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+n ), n, wr,-wi, x, 2_${ik}$, scale, xnorm, ierr ) ! scale if necessary if( scale/=one ) then - call stdlib_dscal( n-ki+1, scale, work( ki+n ), 1 ) - call stdlib_dscal( n-ki+1, scale, work( ki+n2 ), 1 ) + call stdlib${ii}$_dscal( n-ki+1, scale, work( ki+n ), 1_${ik}$ ) + call stdlib${ii}$_dscal( n-ki+1, scale, work( ki+n2 ), 1_${ik}$ ) end if - work( j+n ) = x( 1, 1 ) - work( j+n2 ) = x( 1, 2 ) - work( j+1+n ) = x( 2, 1 ) - work( j+1+n2 ) = x( 2, 2 ) - vmax = max( abs( x( 1, 1 ) ), abs( x( 1, 2 ) ),abs( x( 2, 1 ) ), abs( x(& - 2, 2 ) ), vmax ) + work( j+n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+n2 ) = x( 1_${ik}$, 2_${ik}$ ) + work( j+1+n ) = x( 2_${ik}$, 1_${ik}$ ) + work( j+1+n2 ) = x( 2_${ik}$, 2_${ik}$ ) + vmax = max( abs( x( 1_${ik}$, 1_${ik}$ ) ), abs( x( 1_${ik}$, 2_${ik}$ ) ),abs( x( 2_${ik}$, 1_${ik}$ ) ), abs( x(& + 2_${ik}$, 2_${ik}$ ) ), vmax ) vcrit = bignum / vmax end if end do loop_200 ! copy the vector x or q*x to vl and normalize. if( .not.over ) then - call stdlib_dcopy( n-ki+1, work( ki+n ), 1, vl( ki, is ), 1 ) - call stdlib_dcopy( n-ki+1, work( ki+n2 ), 1, vl( ki, is+1 ),1 ) + call stdlib${ii}$_dcopy( n-ki+1, work( ki+n ), 1_${ik}$, vl( ki, is ), 1_${ik}$ ) + call stdlib${ii}$_dcopy( n-ki+1, work( ki+n2 ), 1_${ik}$, vl( ki, is+1 ),1_${ik}$ ) emax = zero do k = ki, n emax = max( emax, abs( vl( k, is ) )+abs( vl( k, is+1 ) ) ) end do remax = one / emax - call stdlib_dscal( n-ki+1, remax, vl( ki, is ), 1 ) - call stdlib_dscal( n-ki+1, remax, vl( ki, is+1 ), 1 ) + call stdlib${ii}$_dscal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ ) + call stdlib${ii}$_dscal( n-ki+1, remax, vl( ki, is+1 ), 1_${ik}$ ) do k = 1, ki - 1 vl( k, is ) = zero vl( k, is+1 ) = zero end do else if( ki= n + 2*n*nbmin ) then - nb = (lwork - n) / (2*n) + if( over .and. lwork >= n + 2_${ik}$*n*nbmin ) then + nb = (lwork - n) / (2_${ik}$*n) nb = min( nb, nbmax ) - call stdlib_dlaset( 'F', n, 1+2*nb, zero, zero, work, n ) + call stdlib${ii}$_dlaset( 'F', n, 1_${ik}$+2*nb, zero, zero, work, n ) else - nb = 1 + nb = 1_${ik}$ end if ! set the constants to control overflow. - unfl = stdlib_dlamch( 'SAFE MINIMUM' ) + unfl = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) ovfl = one / unfl - call stdlib_dlabad( unfl, ovfl ) - ulp = stdlib_dlamch( 'PRECISION' ) + call stdlib${ii}$_dlabad( unfl, ovfl ) + ulp = stdlib${ii}$_dlamch( 'PRECISION' ) smlnum = unfl*( n / ulp ) bignum = ( one-ulp ) / smlnum ! compute 1-norm of each column of strictly upper triangular ! part of t to control overflow in triangular solver. - work( 1 ) = zero + work( 1_${ik}$ ) = zero do j = 2, n work( j ) = zero do i = 1, j - 1 @@ -60261,30 +60261,30 @@ module stdlib_linalg_lapack_d ! non-blocked version always uses iv=2; ! blocked version starts with iv=nb, goes down to 1 or 2. ! (note the "0-th" column is used for 1-norms computed above.) - iv = 2 - if( nb>2 ) then + iv = 2_${ik}$ + if( nb>2_${ik}$ ) then iv = nb end if - ip = 0 + ip = 0_${ik}$ is = m loop_140: do ki = n, 1, -1 - if( ip==-1 ) then + if( ip==-1_${ik}$ ) then ! previous iteration (ki+1) was second of conjugate pair, ! so this ki is first of conjugate pair; skip to end of loop - ip = 1 + ip = 1_${ik}$ cycle loop_140 - else if( ki==1 ) then + else if( ki==1_${ik}$ ) then ! last column, so this ki must be real eigenvalue - ip = 0 + ip = 0_${ik}$ else if( t( ki, ki-1 )==zero ) then ! zero on sub-diagonal, so this ki is real eigenvalue - ip = 0 + ip = 0_${ik}$ else ! non-zero on sub-diagonal, so this ki is second of conjugate pair - ip = -1 + ip = -1_${ik}$ end if if( somev ) then - if( ip==0 ) then + if( ip==0_${ik}$ ) then if( .not.select( ki ) )cycle loop_140 else if( .not.select( ki-1 ) )cycle loop_140 @@ -60293,9 +60293,9 @@ module stdlib_linalg_lapack_d ! compute the ki-th eigenvalue (wr,wi). wr = t( ki, ki ) wi = zero - if( ip/=0 )wi = sqrt( abs( t( ki, ki-1 ) ) )*sqrt( abs( t( ki-1, ki ) ) ) + if( ip/=0_${ik}$ )wi = sqrt( abs( t( ki, ki-1 ) ) )*sqrt( abs( t( ki-1, ki ) ) ) smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum ) - if( ip==0 ) then + if( ip==0_${ik}$ ) then ! -------------------------------------------------------- ! real right eigenvector work( ki + iv*n ) = one @@ -60305,60 +60305,60 @@ module stdlib_linalg_lapack_d end do ! solve upper quasi-triangular system: ! [ t(1:ki-1,1:ki-1) - wr ]*x = scale*work. - jnxt = ki - 1 + jnxt = ki - 1_${ik}$ loop_60: do j = ki - 1, 1, -1 if( j>jnxt )cycle loop_60 j1 = j j2 = j - jnxt = j - 1 - if( j>1 ) then + jnxt = j - 1_${ik}$ + if( j>1_${ik}$ ) then if( t( j, j-1 )/=zero ) then - j1 = j - 1 - jnxt = j - 2 + j1 = j - 1_${ik}$ + jnxt = j - 2_${ik}$ end if end if if( j1==j2 ) then ! 1-by-1 diagonal block - call stdlib_dlaln2( .false., 1, 1, smin, one, t( j, j ),ldt, one, one, & - work( j+iv*n ), n, wr,zero, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_dlaln2( .false., 1_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+iv*n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr ) ! scale x(1,1) to avoid overflow when updating ! the right-hand side. if( xnorm>one ) then if( work( j )>bignum / xnorm ) then - x( 1, 1 ) = x( 1, 1 ) / xnorm + x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm scale = scale / xnorm end if end if ! scale if necessary - if( scale/=one )call stdlib_dscal( ki, scale, work( 1+iv*n ), 1 ) + if( scale/=one )call stdlib${ii}$_dscal( ki, scale, work( 1_${ik}$+iv*n ), 1_${ik}$ ) - work( j+iv*n ) = x( 1, 1 ) + work( j+iv*n ) = x( 1_${ik}$, 1_${ik}$ ) ! update right-hand side - call stdlib_daxpy( j-1, -x( 1, 1 ), t( 1, j ), 1,work( 1+iv*n ), 1 ) + call stdlib${ii}$_daxpy( j-1, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+iv*n ), 1_${ik}$ ) else ! 2-by-2 diagonal block - call stdlib_dlaln2( .false., 2, 1, smin, one,t( j-1, j-1 ), ldt, one, & - one,work( j-1+iv*n ), n, wr, zero, x, 2,scale, xnorm, ierr ) + call stdlib${ii}$_dlaln2( .false., 2_${ik}$, 1_${ik}$, smin, one,t( j-1, j-1 ), ldt, one, & + one,work( j-1+iv*n ), n, wr, zero, x, 2_${ik}$,scale, xnorm, ierr ) ! scale x(1,1) and x(2,1) to avoid overflow when ! updating the right-hand side. if( xnorm>one ) then beta = max( work( j-1 ), work( j ) ) if( beta>bignum / xnorm ) then - x( 1, 1 ) = x( 1, 1 ) / xnorm - x( 2, 1 ) = x( 2, 1 ) / xnorm + x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm + x( 2_${ik}$, 1_${ik}$ ) = x( 2_${ik}$, 1_${ik}$ ) / xnorm scale = scale / xnorm end if end if ! scale if necessary - if( scale/=one )call stdlib_dscal( ki, scale, work( 1+iv*n ), 1 ) + if( scale/=one )call stdlib${ii}$_dscal( ki, scale, work( 1_${ik}$+iv*n ), 1_${ik}$ ) - work( j-1+iv*n ) = x( 1, 1 ) - work( j +iv*n ) = x( 2, 1 ) + work( j-1+iv*n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j +iv*n ) = x( 2_${ik}$, 1_${ik}$ ) ! update right-hand side - call stdlib_daxpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,work( 1+iv*n ), 1 ) + call stdlib${ii}$_daxpy( j-2, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+iv*n ), 1_${ik}$ ) - call stdlib_daxpy( j-2, -x( 2, 1 ), t( 1, j ), 1,work( 1+iv*n ), 1 ) + call stdlib${ii}$_daxpy( j-2, -x( 2_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+iv*n ), 1_${ik}$ ) end if end do loop_60 @@ -60366,21 +60366,21 @@ module stdlib_linalg_lapack_d if( .not.over ) then ! ------------------------------ ! no back-transform: copy x to vr and normalize. - call stdlib_dcopy( ki, work( 1 + iv*n ), 1, vr( 1, is ), 1 ) - ii = stdlib_idamax( ki, vr( 1, is ), 1 ) + call stdlib${ii}$_dcopy( ki, work( 1_${ik}$ + iv*n ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ ) + ii = stdlib${ii}$_idamax( ki, vr( 1_${ik}$, is ), 1_${ik}$ ) remax = one / abs( vr( ii, is ) ) - call stdlib_dscal( ki, remax, vr( 1, is ), 1 ) + call stdlib${ii}$_dscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ ) do k = ki + 1, n vr( k, is ) = zero end do - else if( nb==1 ) then + else if( nb==1_${ik}$ ) then ! ------------------------------ ! version 1: back-transform each vector with gemv, q*x. - if( ki>1 )call stdlib_dgemv( 'N', n, ki-1, one, vr, ldvr,work( 1 + iv*n ), & - 1, work( ki + iv*n ),vr( 1, ki ), 1 ) - ii = stdlib_idamax( n, vr( 1, ki ), 1 ) + if( ki>1_${ik}$ )call stdlib${ii}$_dgemv( 'N', n, ki-1, one, vr, ldvr,work( 1_${ik}$ + iv*n ), & + 1_${ik}$, work( ki + iv*n ),vr( 1_${ik}$, ki ), 1_${ik}$ ) + ii = stdlib${ii}$_idamax( n, vr( 1_${ik}$, ki ), 1_${ik}$ ) remax = one / abs( vr( ii, ki ) ) - call stdlib_dscal( n, remax, vr( 1, ki ), 1 ) + call stdlib${ii}$_dscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ ) else ! ------------------------------ ! version 2: back-transform block of vectors with gemm @@ -60413,77 +60413,77 @@ module stdlib_linalg_lapack_d end do ! solve upper quasi-triangular system: ! [ t(1:ki-2,1:ki-2) - (wr+i*wi) ]*x = scale*(work+i*work2) - jnxt = ki - 2 + jnxt = ki - 2_${ik}$ loop_90: do j = ki - 2, 1, -1 if( j>jnxt )cycle loop_90 j1 = j j2 = j - jnxt = j - 1 - if( j>1 ) then + jnxt = j - 1_${ik}$ + if( j>1_${ik}$ ) then if( t( j, j-1 )/=zero ) then - j1 = j - 1 - jnxt = j - 2 + j1 = j - 1_${ik}$ + jnxt = j - 2_${ik}$ end if end if if( j1==j2 ) then ! 1-by-1 diagonal block - call stdlib_dlaln2( .false., 1, 2, smin, one, t( j, j ),ldt, one, one, & - work( j+(iv-1)*n ), n,wr, wi, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_dlaln2( .false., 1_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+(iv-1)*n ), n,wr, wi, x, 2_${ik}$, scale, xnorm, ierr ) ! scale x(1,1) and x(1,2) to avoid overflow when ! updating the right-hand side. if( xnorm>one ) then if( work( j )>bignum / xnorm ) then - x( 1, 1 ) = x( 1, 1 ) / xnorm - x( 1, 2 ) = x( 1, 2 ) / xnorm + x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm + x( 1_${ik}$, 2_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ ) / xnorm scale = scale / xnorm end if end if ! scale if necessary if( scale/=one ) then - call stdlib_dscal( ki, scale, work( 1+(iv-1)*n ), 1 ) - call stdlib_dscal( ki, scale, work( 1+(iv )*n ), 1 ) + call stdlib${ii}$_dscal( ki, scale, work( 1_${ik}$+(iv-1)*n ), 1_${ik}$ ) + call stdlib${ii}$_dscal( ki, scale, work( 1_${ik}$+(iv )*n ), 1_${ik}$ ) end if - work( j+(iv-1)*n ) = x( 1, 1 ) - work( j+(iv )*n ) = x( 1, 2 ) + work( j+(iv-1)*n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+(iv )*n ) = x( 1_${ik}$, 2_${ik}$ ) ! update the right-hand side - call stdlib_daxpy( j-1, -x( 1, 1 ), t( 1, j ), 1,work( 1+(iv-1)*n ), 1 ) + call stdlib${ii}$_daxpy( j-1, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+(iv-1)*n ), 1_${ik}$ ) - call stdlib_daxpy( j-1, -x( 1, 2 ), t( 1, j ), 1,work( 1+(iv )*n ), 1 ) + call stdlib${ii}$_daxpy( j-1, -x( 1_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+(iv )*n ), 1_${ik}$ ) else ! 2-by-2 diagonal block - call stdlib_dlaln2( .false., 2, 2, smin, one,t( j-1, j-1 ), ldt, one, & - one,work( j-1+(iv-1)*n ), n, wr, wi, x, 2,scale, xnorm, ierr ) + call stdlib${ii}$_dlaln2( .false., 2_${ik}$, 2_${ik}$, smin, one,t( j-1, j-1 ), ldt, one, & + one,work( j-1+(iv-1)*n ), n, wr, wi, x, 2_${ik}$,scale, xnorm, ierr ) ! scale x to avoid overflow when updating ! the right-hand side. if( xnorm>one ) then beta = max( work( j-1 ), work( j ) ) if( beta>bignum / xnorm ) then rec = one / xnorm - x( 1, 1 ) = x( 1, 1 )*rec - x( 1, 2 ) = x( 1, 2 )*rec - x( 2, 1 ) = x( 2, 1 )*rec - x( 2, 2 ) = x( 2, 2 )*rec + x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ )*rec + x( 1_${ik}$, 2_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ )*rec + x( 2_${ik}$, 1_${ik}$ ) = x( 2_${ik}$, 1_${ik}$ )*rec + x( 2_${ik}$, 2_${ik}$ ) = x( 2_${ik}$, 2_${ik}$ )*rec scale = scale*rec end if end if ! scale if necessary if( scale/=one ) then - call stdlib_dscal( ki, scale, work( 1+(iv-1)*n ), 1 ) - call stdlib_dscal( ki, scale, work( 1+(iv )*n ), 1 ) + call stdlib${ii}$_dscal( ki, scale, work( 1_${ik}$+(iv-1)*n ), 1_${ik}$ ) + call stdlib${ii}$_dscal( ki, scale, work( 1_${ik}$+(iv )*n ), 1_${ik}$ ) end if - work( j-1+(iv-1)*n ) = x( 1, 1 ) - work( j +(iv-1)*n ) = x( 2, 1 ) - work( j-1+(iv )*n ) = x( 1, 2 ) - work( j +(iv )*n ) = x( 2, 2 ) + work( j-1+(iv-1)*n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j +(iv-1)*n ) = x( 2_${ik}$, 1_${ik}$ ) + work( j-1+(iv )*n ) = x( 1_${ik}$, 2_${ik}$ ) + work( j +(iv )*n ) = x( 2_${ik}$, 2_${ik}$ ) ! update the right-hand side - call stdlib_daxpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,work( 1+(iv-1)*n ),& - 1 ) - call stdlib_daxpy( j-2, -x( 2, 1 ), t( 1, j ), 1,work( 1+(iv-1)*n ), & - 1 ) - call stdlib_daxpy( j-2, -x( 1, 2 ), t( 1, j-1 ), 1,work( 1+(iv )*n ), & - 1 ) - call stdlib_daxpy( j-2, -x( 2, 2 ), t( 1, j ), 1,work( 1+(iv )*n ), 1 ) + call stdlib${ii}$_daxpy( j-2, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+(iv-1)*n ),& + 1_${ik}$ ) + call stdlib${ii}$_daxpy( j-2, -x( 2_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+(iv-1)*n ), & + 1_${ik}$ ) + call stdlib${ii}$_daxpy( j-2, -x( 1_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+(iv )*n ), & + 1_${ik}$ ) + call stdlib${ii}$_daxpy( j-2, -x( 2_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+(iv )*n ), 1_${ik}$ ) end if end do loop_90 @@ -60491,38 +60491,38 @@ module stdlib_linalg_lapack_d if( .not.over ) then ! ------------------------------ ! no back-transform: copy x to vr and normalize. - call stdlib_dcopy( ki, work( 1+(iv-1)*n ), 1, vr(1,is-1), 1 ) - call stdlib_dcopy( ki, work( 1+(iv )*n ), 1, vr(1,is ), 1 ) + call stdlib${ii}$_dcopy( ki, work( 1_${ik}$+(iv-1)*n ), 1_${ik}$, vr(1_${ik}$,is-1), 1_${ik}$ ) + call stdlib${ii}$_dcopy( ki, work( 1_${ik}$+(iv )*n ), 1_${ik}$, vr(1_${ik}$,is ), 1_${ik}$ ) emax = zero do k = 1, ki emax = max( emax, abs( vr( k, is-1 ) )+abs( vr( k, is ) ) ) end do remax = one / emax - call stdlib_dscal( ki, remax, vr( 1, is-1 ), 1 ) - call stdlib_dscal( ki, remax, vr( 1, is ), 1 ) + call stdlib${ii}$_dscal( ki, remax, vr( 1_${ik}$, is-1 ), 1_${ik}$ ) + call stdlib${ii}$_dscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ ) do k = ki + 1, n vr( k, is-1 ) = zero vr( k, is ) = zero end do - else if( nb==1 ) then + else if( nb==1_${ik}$ ) then ! ------------------------------ ! version 1: back-transform each vector with gemv, q*x. - if( ki>2 ) then - call stdlib_dgemv( 'N', n, ki-2, one, vr, ldvr,work( 1 + (iv-1)*n ), & - 1,work( ki-1 + (iv-1)*n ), vr(1,ki-1), 1) - call stdlib_dgemv( 'N', n, ki-2, one, vr, ldvr,work( 1 + (iv)*n ), 1,& - work( ki + (iv)*n ), vr( 1, ki ), 1 ) + if( ki>2_${ik}$ ) then + call stdlib${ii}$_dgemv( 'N', n, ki-2, one, vr, ldvr,work( 1_${ik}$ + (iv-1)*n ), & + 1_${ik}$,work( ki-1 + (iv-1)*n ), vr(1_${ik}$,ki-1), 1_${ik}$) + call stdlib${ii}$_dgemv( 'N', n, ki-2, one, vr, ldvr,work( 1_${ik}$ + (iv)*n ), 1_${ik}$,& + work( ki + (iv)*n ), vr( 1_${ik}$, ki ), 1_${ik}$ ) else - call stdlib_dscal( n, work(ki-1+(iv-1)*n), vr(1,ki-1), 1) - call stdlib_dscal( n, work(ki +(iv )*n), vr(1,ki ), 1) + call stdlib${ii}$_dscal( n, work(ki-1+(iv-1)*n), vr(1_${ik}$,ki-1), 1_${ik}$) + call stdlib${ii}$_dscal( n, work(ki +(iv )*n), vr(1_${ik}$,ki ), 1_${ik}$) end if emax = zero do k = 1, n emax = max( emax, abs( vr( k, ki-1 ) )+abs( vr( k, ki ) ) ) end do remax = one / emax - call stdlib_dscal( n, remax, vr( 1, ki-1 ), 1 ) - call stdlib_dscal( n, remax, vr( 1, ki ), 1 ) + call stdlib${ii}$_dscal( n, remax, vr( 1_${ik}$, ki-1 ), 1_${ik}$ ) + call stdlib${ii}$_dscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ ) else ! ------------------------------ ! version 2: back-transform block of vectors with gemm @@ -60533,32 +60533,32 @@ module stdlib_linalg_lapack_d end do iscomplex( iv-1 ) = -ip iscomplex( iv ) = ip - iv = iv - 1 + iv = iv - 1_${ik}$ ! back-transform and normalization is done below end if end if - if( nb>1 ) then + if( nb>1_${ik}$ ) then ! -------------------------------------------------------- ! blocked version of back-transform ! for complex case, ki2 includes both vectors (ki-1 and ki) - if( ip==0 ) then + if( ip==0_${ik}$ ) then ki2 = ki else - ki2 = ki - 1 + ki2 = ki - 1_${ik}$ end if ! columns iv:nb of work are valid vectors. ! when the number of vectors stored reaches nb-1 or nb, ! or if this was last vector, do the gemm - if( (iv<=2) .or. (ki2==1) ) then - call stdlib_dgemm( 'N', 'N', n, nb-iv+1, ki2+nb-iv, one,vr, ldvr,work( 1 + & - (iv)*n ), n,zero,work( 1 + (nb+iv)*n ), n ) + if( (iv<=2_${ik}$) .or. (ki2==1_${ik}$) ) then + call stdlib${ii}$_dgemm( 'N', 'N', n, nb-iv+1, ki2+nb-iv, one,vr, ldvr,work( 1_${ik}$ + & + (iv)*n ), n,zero,work( 1_${ik}$ + (nb+iv)*n ), n ) ! normalize vectors do k = iv, nb - if( iscomplex(k)==0 ) then + if( iscomplex(k)==0_${ik}$ ) then ! real eigenvector - ii = stdlib_idamax( n, work( 1 + (nb+k)*n ), 1 ) + ii = stdlib${ii}$_idamax( n, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ ) remax = one / abs( work( ii + (nb+k)*n ) ) - else if( iscomplex(k)==1 ) then + else if( iscomplex(k)==1_${ik}$ ) then ! first eigenvector of conjugate pair emax = zero do ii = 1, n @@ -60570,17 +60570,17 @@ module stdlib_linalg_lapack_d ! second eigenvector of conjugate pair ! reuse same remax as previous k end if - call stdlib_dscal( n, remax, work( 1 + (nb+k)*n ), 1 ) + call stdlib${ii}$_dscal( n, remax, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ ) end do - call stdlib_dlacpy( 'F', n, nb-iv+1,work( 1 + (nb+iv)*n ), n,vr( 1, ki2 ), & + call stdlib${ii}$_dlacpy( 'F', n, nb-iv+1,work( 1_${ik}$ + (nb+iv)*n ), n,vr( 1_${ik}$, ki2 ), & ldvr ) iv = nb else - iv = iv - 1 + iv = iv - 1_${ik}$ end if end if ! blocked back-transform - is = is - 1 - if( ip/=0 )is = is - 1 + is = is - 1_${ik}$ + if( ip/=0_${ik}$ )is = is - 1_${ik}$ end do loop_140 end if if( leftv ) then @@ -60591,24 +60591,24 @@ module stdlib_linalg_lapack_d ! non-blocked version always uses iv=1; ! blocked version starts with iv=1, goes up to nb-1 or nb. ! (note the "0-th" column is used for 1-norms computed above.) - iv = 1 - ip = 0 - is = 1 + iv = 1_${ik}$ + ip = 0_${ik}$ + is = 1_${ik}$ loop_260: do ki = 1, n - if( ip==1 ) then + if( ip==1_${ik}$ ) then ! previous iteration (ki-1) was first of conjugate pair, ! so this ki is second of conjugate pair; skip to end of loop - ip = -1 + ip = -1_${ik}$ cycle loop_260 else if( ki==n ) then ! last column, so this ki must be real eigenvalue - ip = 0 + ip = 0_${ik}$ else if( t( ki+1, ki )==zero ) then ! zero on sub-diagonal, so this ki is real eigenvalue - ip = 0 + ip = 0_${ik}$ else ! non-zero on sub-diagonal, so this ki is first of conjugate pair - ip = 1 + ip = 1_${ik}$ end if if( somev ) then if( .not.select( ki ) )cycle loop_260 @@ -60616,9 +60616,9 @@ module stdlib_linalg_lapack_d ! compute the ki-th eigenvalue (wr,wi). wr = t( ki, ki ) wi = zero - if( ip/=0 )wi = sqrt( abs( t( ki, ki+1 ) ) )*sqrt( abs( t( ki+1, ki ) ) ) + if( ip/=0_${ik}$ )wi = sqrt( abs( t( ki, ki+1 ) ) )*sqrt( abs( t( ki+1, ki ) ) ) smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum ) - if( ip==0 ) then + if( ip==0_${ik}$ ) then ! -------------------------------------------------------- ! real left eigenvector work( ki + iv*n ) = one @@ -60630,16 +60630,16 @@ module stdlib_linalg_lapack_d ! [ t(ki+1:n,ki+1:n) - wr ]**t * x = scale*work vmax = one vcrit = bignum - jnxt = ki + 1 + jnxt = ki + 1_${ik}$ loop_170: do j = ki + 1, n if( jvcrit ) then rec = one / vmax - call stdlib_dscal( n-ki+1, rec, work( ki+iv*n ), 1 ) + call stdlib${ii}$_dscal( n-ki+1, rec, work( ki+iv*n ), 1_${ik}$ ) vmax = one vcrit = bignum end if - work( j+iv*n ) = work( j+iv*n ) -stdlib_ddot( j-ki-1, t( ki+1, j ), 1,& - work( ki+1+iv*n ), 1 ) + work( j+iv*n ) = work( j+iv*n ) -stdlib${ii}$_ddot( j-ki-1, t( ki+1, j ), 1_${ik}$,& + work( ki+1+iv*n ), 1_${ik}$ ) ! solve [ t(j,j) - wr ]**t * x = work - call stdlib_dlaln2( .false., 1, 1, smin, one, t( j, j ),ldt, one, one, & - work( j+iv*n ), n, wr,zero, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_dlaln2( .false., 1_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+iv*n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr ) ! scale if necessary - if( scale/=one )call stdlib_dscal( n-ki+1, scale, work( ki+iv*n ), 1 ) + if( scale/=one )call stdlib${ii}$_dscal( n-ki+1, scale, work( ki+iv*n ), 1_${ik}$ ) - work( j+iv*n ) = x( 1, 1 ) + work( j+iv*n ) = x( 1_${ik}$, 1_${ik}$ ) vmax = max( abs( work( j+iv*n ) ), vmax ) vcrit = bignum / vmax else @@ -60670,24 +60670,24 @@ module stdlib_linalg_lapack_d beta = max( work( j ), work( j+1 ) ) if( beta>vcrit ) then rec = one / vmax - call stdlib_dscal( n-ki+1, rec, work( ki+iv*n ), 1 ) + call stdlib${ii}$_dscal( n-ki+1, rec, work( ki+iv*n ), 1_${ik}$ ) vmax = one vcrit = bignum end if - work( j+iv*n ) = work( j+iv*n ) -stdlib_ddot( j-ki-1, t( ki+1, j ), 1,& - work( ki+1+iv*n ), 1 ) - work( j+1+iv*n ) = work( j+1+iv*n ) -stdlib_ddot( j-ki-1, t( ki+1, j+1 )& - , 1,work( ki+1+iv*n ), 1 ) + work( j+iv*n ) = work( j+iv*n ) -stdlib${ii}$_ddot( j-ki-1, t( ki+1, j ), 1_${ik}$,& + work( ki+1+iv*n ), 1_${ik}$ ) + work( j+1+iv*n ) = work( j+1+iv*n ) -stdlib${ii}$_ddot( j-ki-1, t( ki+1, j+1 )& + , 1_${ik}$,work( ki+1+iv*n ), 1_${ik}$ ) ! solve ! [ t(j,j)-wr t(j,j+1) ]**t * x = scale*( work1 ) ! [ t(j+1,j) t(j+1,j+1)-wr ] ( work2 ) - call stdlib_dlaln2( .true., 2, 1, smin, one, t( j, j ),ldt, one, one, & - work( j+iv*n ), n, wr,zero, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_dlaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+iv*n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr ) ! scale if necessary - if( scale/=one )call stdlib_dscal( n-ki+1, scale, work( ki+iv*n ), 1 ) + if( scale/=one )call stdlib${ii}$_dscal( n-ki+1, scale, work( ki+iv*n ), 1_${ik}$ ) - work( j +iv*n ) = x( 1, 1 ) - work( j+1+iv*n ) = x( 2, 1 ) + work( j +iv*n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+1+iv*n ) = x( 2_${ik}$, 1_${ik}$ ) vmax = max( abs( work( j +iv*n ) ),abs( work( j+1+iv*n ) ), vmax ) vcrit = bignum / vmax @@ -60697,21 +60697,21 @@ module stdlib_linalg_lapack_d if( .not.over ) then ! ------------------------------ ! no back-transform: copy x to vl and normalize. - call stdlib_dcopy( n-ki+1, work( ki + iv*n ), 1,vl( ki, is ), 1 ) - ii = stdlib_idamax( n-ki+1, vl( ki, is ), 1 ) + ki - 1 + call stdlib${ii}$_dcopy( n-ki+1, work( ki + iv*n ), 1_${ik}$,vl( ki, is ), 1_${ik}$ ) + ii = stdlib${ii}$_idamax( n-ki+1, vl( ki, is ), 1_${ik}$ ) + ki - 1_${ik}$ remax = one / abs( vl( ii, is ) ) - call stdlib_dscal( n-ki+1, remax, vl( ki, is ), 1 ) + call stdlib${ii}$_dscal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ ) do k = 1, ki - 1 vl( k, is ) = zero end do - else if( nb==1 ) then + else if( nb==1_${ik}$ ) then ! ------------------------------ ! version 1: back-transform each vector with gemv, q*x. - if( kivcrit ) then rec = one / vmax - call stdlib_dscal( n-ki+1, rec, work(ki+(iv )*n), 1 ) - call stdlib_dscal( n-ki+1, rec, work(ki+(iv+1)*n), 1 ) + call stdlib${ii}$_dscal( n-ki+1, rec, work(ki+(iv )*n), 1_${ik}$ ) + call stdlib${ii}$_dscal( n-ki+1, rec, work(ki+(iv+1)*n), 1_${ik}$ ) vmax = one vcrit = bignum end if - work( j+(iv )*n ) = work( j+(iv)*n ) -stdlib_ddot( j-ki-2, t( ki+2, j )& - , 1,work( ki+2+(iv)*n ), 1 ) - work( j+(iv+1)*n ) = work( j+(iv+1)*n ) -stdlib_ddot( j-ki-2, t( ki+2, & - j ), 1,work( ki+2+(iv+1)*n ), 1 ) + work( j+(iv )*n ) = work( j+(iv)*n ) -stdlib${ii}$_ddot( j-ki-2, t( ki+2, j )& + , 1_${ik}$,work( ki+2+(iv)*n ), 1_${ik}$ ) + work( j+(iv+1)*n ) = work( j+(iv+1)*n ) -stdlib${ii}$_ddot( j-ki-2, t( ki+2, & + j ), 1_${ik}$,work( ki+2+(iv+1)*n ), 1_${ik}$ ) ! solve [ t(j,j)-(wr-i*wi) ]*(x11+i*x12)= wk+i*wk2 - call stdlib_dlaln2( .false., 1, 2, smin, one, t( j, j ),ldt, one, one, & - work( j+iv*n ), n, wr,-wi, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_dlaln2( .false., 1_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+iv*n ), n, wr,-wi, x, 2_${ik}$, scale, xnorm, ierr ) ! scale if necessary if( scale/=one ) then - call stdlib_dscal( n-ki+1, scale, work(ki+(iv )*n), 1) - call stdlib_dscal( n-ki+1, scale, work(ki+(iv+1)*n), 1) + call stdlib${ii}$_dscal( n-ki+1, scale, work(ki+(iv )*n), 1_${ik}$) + call stdlib${ii}$_dscal( n-ki+1, scale, work(ki+(iv+1)*n), 1_${ik}$) end if - work( j+(iv )*n ) = x( 1, 1 ) - work( j+(iv+1)*n ) = x( 1, 2 ) + work( j+(iv )*n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+(iv+1)*n ) = x( 1_${ik}$, 2_${ik}$ ) vmax = max( abs( work( j+(iv )*n ) ),abs( work( j+(iv+1)*n ) ), vmax ) vcrit = bignum / vmax @@ -60794,35 +60794,35 @@ module stdlib_linalg_lapack_d beta = max( work( j ), work( j+1 ) ) if( beta>vcrit ) then rec = one / vmax - call stdlib_dscal( n-ki+1, rec, work(ki+(iv )*n), 1 ) - call stdlib_dscal( n-ki+1, rec, work(ki+(iv+1)*n), 1 ) + call stdlib${ii}$_dscal( n-ki+1, rec, work(ki+(iv )*n), 1_${ik}$ ) + call stdlib${ii}$_dscal( n-ki+1, rec, work(ki+(iv+1)*n), 1_${ik}$ ) vmax = one vcrit = bignum end if - work( j +(iv )*n ) = work( j+(iv)*n ) -stdlib_ddot( j-ki-2, t( ki+2, & - j ), 1,work( ki+2+(iv)*n ), 1 ) - work( j +(iv+1)*n ) = work( j+(iv+1)*n ) -stdlib_ddot( j-ki-2, t( ki+2,& - j ), 1,work( ki+2+(iv+1)*n ), 1 ) - work( j+1+(iv )*n ) = work( j+1+(iv)*n ) -stdlib_ddot( j-ki-2, t( ki+2,& - j+1 ), 1,work( ki+2+(iv)*n ), 1 ) - work( j+1+(iv+1)*n ) = work( j+1+(iv+1)*n ) -stdlib_ddot( j-ki-2, t( ki+& - 2, j+1 ), 1,work( ki+2+(iv+1)*n ), 1 ) + work( j +(iv )*n ) = work( j+(iv)*n ) -stdlib${ii}$_ddot( j-ki-2, t( ki+2, & + j ), 1_${ik}$,work( ki+2+(iv)*n ), 1_${ik}$ ) + work( j +(iv+1)*n ) = work( j+(iv+1)*n ) -stdlib${ii}$_ddot( j-ki-2, t( ki+2,& + j ), 1_${ik}$,work( ki+2+(iv+1)*n ), 1_${ik}$ ) + work( j+1+(iv )*n ) = work( j+1+(iv)*n ) -stdlib${ii}$_ddot( j-ki-2, t( ki+2,& + j+1 ), 1_${ik}$,work( ki+2+(iv)*n ), 1_${ik}$ ) + work( j+1+(iv+1)*n ) = work( j+1+(iv+1)*n ) -stdlib${ii}$_ddot( j-ki-2, t( ki+& + 2_${ik}$, j+1 ), 1_${ik}$,work( ki+2+(iv+1)*n ), 1_${ik}$ ) ! solve 2-by-2 complex linear equation ! [ (t(j,j) t(j,j+1) )**t - (wr-i*wi)*i ]*x = scale*b ! [ (t(j+1,j) t(j+1,j+1)) ] - call stdlib_dlaln2( .true., 2, 2, smin, one, t( j, j ),ldt, one, one, & - work( j+iv*n ), n, wr,-wi, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_dlaln2( .true., 2_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+iv*n ), n, wr,-wi, x, 2_${ik}$, scale, xnorm, ierr ) ! scale if necessary if( scale/=one ) then - call stdlib_dscal( n-ki+1, scale, work(ki+(iv )*n), 1) - call stdlib_dscal( n-ki+1, scale, work(ki+(iv+1)*n), 1) + call stdlib${ii}$_dscal( n-ki+1, scale, work(ki+(iv )*n), 1_${ik}$) + call stdlib${ii}$_dscal( n-ki+1, scale, work(ki+(iv+1)*n), 1_${ik}$) end if - work( j +(iv )*n ) = x( 1, 1 ) - work( j +(iv+1)*n ) = x( 1, 2 ) - work( j+1+(iv )*n ) = x( 2, 1 ) - work( j+1+(iv+1)*n ) = x( 2, 2 ) - vmax = max( abs( x( 1, 1 ) ), abs( x( 1, 2 ) ),abs( x( 2, 1 ) ), abs( x(& - 2, 2 ) ),vmax ) + work( j +(iv )*n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j +(iv+1)*n ) = x( 1_${ik}$, 2_${ik}$ ) + work( j+1+(iv )*n ) = x( 2_${ik}$, 1_${ik}$ ) + work( j+1+(iv+1)*n ) = x( 2_${ik}$, 2_${ik}$ ) + vmax = max( abs( x( 1_${ik}$, 1_${ik}$ ) ), abs( x( 1_${ik}$, 2_${ik}$ ) ),abs( x( 2_${ik}$, 1_${ik}$ ) ), abs( x(& + 2_${ik}$, 2_${ik}$ ) ),vmax ) vcrit = bignum / vmax end if end do loop_200 @@ -60830,40 +60830,40 @@ module stdlib_linalg_lapack_d if( .not.over ) then ! ------------------------------ ! no back-transform: copy x to vl and normalize. - call stdlib_dcopy( n-ki+1, work( ki + (iv )*n ), 1,vl( ki, is ), 1 ) + call stdlib${ii}$_dcopy( n-ki+1, work( ki + (iv )*n ), 1_${ik}$,vl( ki, is ), 1_${ik}$ ) - call stdlib_dcopy( n-ki+1, work( ki + (iv+1)*n ), 1,vl( ki, is+1 ), 1 ) + call stdlib${ii}$_dcopy( n-ki+1, work( ki + (iv+1)*n ), 1_${ik}$,vl( ki, is+1 ), 1_${ik}$ ) emax = zero do k = ki, n emax = max( emax, abs( vl( k, is ) )+abs( vl( k, is+1 ) ) ) end do remax = one / emax - call stdlib_dscal( n-ki+1, remax, vl( ki, is ), 1 ) - call stdlib_dscal( n-ki+1, remax, vl( ki, is+1 ), 1 ) + call stdlib${ii}$_dscal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ ) + call stdlib${ii}$_dscal( n-ki+1, remax, vl( ki, is+1 ), 1_${ik}$ ) do k = 1, ki - 1 vl( k, is ) = zero vl( k, is+1 ) = zero end do - else if( nb==1 ) then + else if( nb==1_${ik}$ ) then ! ------------------------------ ! version 1: back-transform each vector with gemv, q*x. if( ki1 ) then + if( nb>1_${ik}$ ) then ! -------------------------------------------------------- ! blocked version of back-transform ! for complex case, ki2 includes both vectors (ki and ki+1) - if( ip==0 ) then + if( ip==0_${ik}$ ) then ki2 = ki else - ki2 = ki + 1 + ki2 = ki + 1_${ik}$ end if ! columns 1:iv of work are valid vectors. ! when the number of vectors stored reaches nb-1 or nb, ! or if this was last vector, do the gemm if( (iv>=nb-1) .or. (ki2==n) ) then - call stdlib_dgemm( 'N', 'N', n, iv, n-ki2+iv, one,vl( 1, ki2-iv+1 ), ldvl,& - work( ki2-iv+1 + (1)*n ), n,zero,work( 1 + (nb+1)*n ), n ) + call stdlib${ii}$_dgemm( 'N', 'N', n, iv, n-ki2+iv, one,vl( 1_${ik}$, ki2-iv+1 ), ldvl,& + work( ki2-iv+1 + (1_${ik}$)*n ), n,zero,work( 1_${ik}$ + (nb+1)*n ), n ) ! normalize vectors do k = 1, iv - if( iscomplex(k)==0) then + if( iscomplex(k)==0_${ik}$) then ! real eigenvector - ii = stdlib_idamax( n, work( 1 + (nb+k)*n ), 1 ) + ii = stdlib${ii}$_idamax( n, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ ) remax = one / abs( work( ii + (nb+k)*n ) ) - else if( iscomplex(k)==1) then + else if( iscomplex(k)==1_${ik}$) then ! first eigenvector of conjugate pair emax = zero do ii = 1, n @@ -60912,24 +60912,24 @@ module stdlib_linalg_lapack_d ! second eigenvector of conjugate pair ! reuse same remax as previous k end if - call stdlib_dscal( n, remax, work( 1 + (nb+k)*n ), 1 ) + call stdlib${ii}$_dscal( n, remax, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ ) end do - call stdlib_dlacpy( 'F', n, iv,work( 1 + (nb+1)*n ), n,vl( 1, ki2-iv+1 ), & + call stdlib${ii}$_dlacpy( 'F', n, iv,work( 1_${ik}$ + (nb+1)*n ), n,vl( 1_${ik}$, ki2-iv+1 ), & ldvl ) - iv = 1 + iv = 1_${ik}$ else - iv = iv + 1 + iv = iv + 1_${ik}$ end if end if ! blocked back-transform - is = is + 1 - if( ip/=0 )is = is + 1 + is = is + 1_${ik}$ + if( ip/=0_${ik}$ )is = is + 1_${ik}$ end do loop_260 end if return - end subroutine stdlib_dtrevc3 + end subroutine stdlib${ii}$_dtrevc3 - subroutine stdlib_dtrsyl( trana, tranb, isgn, m, n, a, lda, b, ldb, c,ldc, scale, info ) + subroutine stdlib${ii}$_dtrsyl( trana, tranb, isgn, m, n, a, lda, b, ldb, c,ldc, scale, info ) !! DTRSYL solves the real Sylvester matrix equation: !! op(A)*X + X*op(B) = scale*C or !! op(A)*X - X*op(B) = scale*C, @@ -60947,8 +60947,8 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: trana, tranb - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: isgn, lda, ldb, ldc, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: isgn, lda, ldb, ldc, m, n real(dp), intent(out) :: scale ! Array Arguments real(dp), intent(in) :: a(lda,*), b(ldb,*) @@ -60957,52 +60957,52 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: notrna, notrnb - integer(ilp) :: ierr, j, k, k1, k2, knext, l, l1, l2, lnext + integer(${ik}$) :: ierr, j, k, k1, k2, knext, l, l1, l2, lnext real(dp) :: a11, bignum, da11, db, eps, scaloc, sgn, smin, smlnum, suml, sumr, & xnorm ! Local Arrays - real(dp) :: dum(1), vec(2,2), x(2,2) + real(dp) :: dum(1_${ik}$), vec(2_${ik}$,2_${ik}$), x(2_${ik}$,2_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,max,min ! Executable Statements ! decode and test input parameters notrna = stdlib_lsame( trana, 'N' ) notrnb = stdlib_lsame( tranb, 'N' ) - info = 0 + info = 0_${ik}$ if( .not.notrna .and. .not.stdlib_lsame( trana, 'T' ) .and. .not.stdlib_lsame( trana, & 'C' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.notrnb .and. .not.stdlib_lsame( tranb, 'T' ) .and. .not.stdlib_lsame( & tranb, 'C' ) ) then - info = -2 - else if( isgn/=1 .and. isgn/=-1 ) then - info = -3 - else if( m<0 ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( ldaknext )cycle loop_50 - if( k==1 ) then + if( k==1_${ik}$ ) then k1 = k k2 = k else if( a( k, k-1 )/=zero ) then - k1 = k - 1 + k1 = k - 1_${ik}$ k2 = k - knext = k - 2 + knext = k - 2_${ik}$ else k1 = k k2 = k - knext = k - 1 + knext = k - 1_${ik}$ end if end if if( l1==l2 .and. k1==k2 ) then - suml = stdlib_ddot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & - l1 ), 1 ) - sumr = stdlib_ddot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_ddot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) scaloc = one a11 = a( k1, k1 ) + sgn*b( l1, l1 ) da11 = abs( a11 ) if( da11<=smin ) then a11 = smin da11 = smin - info = 1 + info = 1_${ik}$ end if - db = abs( vec( 1, 1 ) ) + db = abs( vec( 1_${ik}$, 1_${ik}$ ) ) if( da11one ) then if( db>bignum*da11 )scaloc = one / db end if - x( 1, 1 ) = ( vec( 1, 1 )*scaloc ) / a11 + x( 1_${ik}$, 1_${ik}$ ) = ( vec( 1_${ik}$, 1_${ik}$ )*scaloc ) / a11 if( scaloc/=one ) then do j = 1, n - call stdlib_dscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) else if( l1==l2 .and. k1/=k2 ) then - suml = stdlib_ddot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l1 ), 1 ) - sumr = stdlib_ddot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_ddot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l1 ), 1 ) - sumr = stdlib_ddot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - call stdlib_dlaln2( .false., 2, 1, smin, one, a( k1, k1 ),lda, one, one, & - vec, 2, -sgn*b( l1, l1 ),zero, x, 2, scaloc, xnorm, ierr ) - if( ierr/=0 )info = 1 + suml = stdlib${ii}$_ddot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_ddot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr ) + call stdlib${ii}$_dlaln2( .false., 2_${ik}$, 1_${ik}$, smin, one, a( k1, k1 ),lda, one, one, & + vec, 2_${ik}$, -sgn*b( l1, l1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_dscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k2, l1 ) = x( 2, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ ) else if( l1/=l2 .and. k1==k2 ) then - suml = stdlib_ddot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & - l1 ), 1 ) - sumr = stdlib_ddot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) - suml = stdlib_ddot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & - l2 ), 1 ) - sumr = stdlib_ddot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 ) - vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) - call stdlib_dlaln2( .true., 2, 1, smin, one, b( l1, l1 ),ldb, one, one, & - vec, 2, -sgn*a( k1, k1 ),zero, x, 2, scaloc, xnorm, ierr ) - if( ierr/=0 )info = 1 + suml = stdlib${ii}$_ddot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 1_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) + suml = stdlib${ii}$_ddot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & + l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ ) + vec( 2_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) + call stdlib${ii}$_dlaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, b( l1, l1 ),ldb, one, one, & + vec, 2_${ik}$, -sgn*a( k1, k1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_dscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k1, l2 ) = x( 2, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k1, l2 ) = x( 2_${ik}$, 1_${ik}$ ) else if( l1/=l2 .and. k1/=k2 ) then - suml = stdlib_ddot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l1 ), 1 ) - sumr = stdlib_ddot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_ddot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l2 ), 1 ) - sumr = stdlib_ddot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 ) - vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr ) - suml = stdlib_ddot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l1 ), 1 ) - sumr = stdlib_ddot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_ddot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l2 ), 1 ) - sumr = stdlib_ddot( l1-1, c( k2, 1 ), ldc, b( 1, l2 ), 1 ) - vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr ) - call stdlib_dlasy2( .false., .false., isgn, 2, 2,a( k1, k1 ), lda, b( l1, & - l1 ), ldb, vec,2, scaloc, x, 2, xnorm, ierr ) - if( ierr/=0 )info = 1 + suml = stdlib${ii}$_ddot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_ddot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ ) + vec( 1_${ik}$, 2_${ik}$ ) = c( k1, l2 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_ddot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_ddot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ ) + vec( 2_${ik}$, 2_${ik}$ ) = c( k2, l2 ) - ( suml+sgn*sumr ) + call stdlib${ii}$_dlasy2( .false., .false., isgn, 2_${ik}$, 2_${ik}$,a( k1, k1 ), lda, b( l1, & + l1 ), ldb, vec,2_${ik}$, scaloc, x, 2_${ik}$, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_dscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k1, l2 ) = x( 1, 2 ) - c( k2, l1 ) = x( 2, 1 ) - c( k2, l2 ) = x( 2, 2 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k1, l2 ) = x( 1_${ik}$, 2_${ik}$ ) + c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ ) + c( k2, l2 ) = x( 2_${ik}$, 2_${ik}$ ) end if end do loop_50 end do loop_60 @@ -61161,7 +61161,7 @@ module stdlib_linalg_lapack_d ! i=1 j=1 ! start column loop (index = l) ! l1 (l2): column index of the first (last) row of x(k,l) - lnext = 1 + lnext = 1_${ik}$ loop_120: do l = 1, n if( lone ) then if( db>bignum*da11 )scaloc = one / db end if - x( 1, 1 ) = ( vec( 1, 1 )*scaloc ) / a11 + x( 1_${ik}$, 1_${ik}$ ) = ( vec( 1_${ik}$, 1_${ik}$ )*scaloc ) / a11 if( scaloc/=one ) then do j = 1, n - call stdlib_dscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) else if( l1==l2 .and. k1/=k2 ) then - suml = stdlib_ddot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_ddot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_ddot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_ddot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - call stdlib_dlaln2( .true., 2, 1, smin, one, a( k1, k1 ),lda, one, one, & - vec, 2, -sgn*b( l1, l1 ),zero, x, 2, scaloc, xnorm, ierr ) - if( ierr/=0 )info = 1 + suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr ) + call stdlib${ii}$_dlaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, a( k1, k1 ),lda, one, one, & + vec, 2_${ik}$, -sgn*b( l1, l1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_dscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k2, l1 ) = x( 2, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ ) else if( l1/=l2 .and. k1==k2 ) then - suml = stdlib_ddot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_ddot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) - suml = stdlib_ddot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 ) - sumr = stdlib_ddot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 ) - vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) - call stdlib_dlaln2( .true., 2, 1, smin, one, b( l1, l1 ),ldb, one, one, & - vec, 2, -sgn*a( k1, k1 ),zero, x, 2, scaloc, xnorm, ierr ) - if( ierr/=0 )info = 1 + suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 1_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) + suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ ) + vec( 2_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) + call stdlib${ii}$_dlaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, b( l1, l1 ),ldb, one, one, & + vec, 2_${ik}$, -sgn*a( k1, k1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_dscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k1, l2 ) = x( 2, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k1, l2 ) = x( 2_${ik}$, 1_${ik}$ ) else if( l1/=l2 .and. k1/=k2 ) then - suml = stdlib_ddot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_ddot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_ddot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 ) - sumr = stdlib_ddot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 ) - vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr ) - suml = stdlib_ddot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_ddot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_ddot( k1-1, a( 1, k2 ), 1, c( 1, l2 ), 1 ) - sumr = stdlib_ddot( l1-1, c( k2, 1 ), ldc, b( 1, l2 ), 1 ) - vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr ) - call stdlib_dlasy2( .true., .false., isgn, 2, 2, a( k1, k1 ),lda, b( l1, & - l1 ), ldb, vec, 2, scaloc, x,2, xnorm, ierr ) - if( ierr/=0 )info = 1 + suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ ) + vec( 1_${ik}$, 2_${ik}$ ) = c( k1, l2 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ ) + vec( 2_${ik}$, 2_${ik}$ ) = c( k2, l2 ) - ( suml+sgn*sumr ) + call stdlib${ii}$_dlasy2( .true., .false., isgn, 2_${ik}$, 2_${ik}$, a( k1, k1 ),lda, b( l1, & + l1 ), ldb, vec, 2_${ik}$, scaloc, x,2_${ik}$, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_dscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k1, l2 ) = x( 1, 2 ) - c( k2, l1 ) = x( 2, 1 ) - c( k2, l2 ) = x( 2, 2 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k1, l2 ) = x( 1_${ik}$, 2_${ik}$ ) + c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ ) + c( k2, l2 ) = x( 2_${ik}$, 2_${ik}$ ) end if end do loop_110 end do loop_120 @@ -61300,23 +61300,23 @@ module stdlib_linalg_lapack_d lnext = n loop_180: do l = n, 1, -1 if( l>lnext )cycle loop_180 - if( l==1 ) then + if( l==1_${ik}$ ) then l1 = l l2 = l else if( b( l, l-1 )/=zero ) then - l1 = l - 1 + l1 = l - 1_${ik}$ l2 = l - lnext = l - 2 + lnext = l - 2_${ik}$ else l1 = l l2 = l - lnext = l - 1 + lnext = l - 1_${ik}$ end if end if ! start row loop (index = k) ! k1 (k2): row index of the first (last) row of x(k,l) - knext = 1 + knext = 1_${ik}$ loop_170: do k = 1, m if( kone ) then if( db>bignum*da11 )scaloc = one / db end if - x( 1, 1 ) = ( vec( 1, 1 )*scaloc ) / a11 + x( 1_${ik}$, 1_${ik}$ ) = ( vec( 1_${ik}$, 1_${ik}$ )*scaloc ) / a11 if( scaloc/=one ) then do j = 1, n - call stdlib_dscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) else if( l1==l2 .and. k1/=k2 ) then - suml = stdlib_ddot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_ddot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_ddot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - call stdlib_dlaln2( .true., 2, 1, smin, one, a( k1, k1 ),lda, one, one, & - vec, 2, -sgn*b( l1, l1 ),zero, x, 2, scaloc, xnorm, ierr ) - if( ierr/=0 )info = 1 + vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr ) + call stdlib${ii}$_dlaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, a( k1, k1 ),lda, one, one, & + vec, 2_${ik}$, -sgn*b( l1, l1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_dscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k2, l1 ) = x( 2, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ ) else if( l1/=l2 .and. k1==k2 ) then - suml = stdlib_ddot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) - suml = stdlib_ddot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 ) - sumr = stdlib_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & + vec( 1_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) + suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & ) ), ldb ) - vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) - call stdlib_dlaln2( .false., 2, 1, smin, one, b( l1, l1 ),ldb, one, one, & - vec, 2, -sgn*a( k1, k1 ),zero, x, 2, scaloc, xnorm, ierr ) - if( ierr/=0 )info = 1 + vec( 2_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) + call stdlib${ii}$_dlaln2( .false., 2_${ik}$, 1_${ik}$, smin, one, b( l1, l1 ),ldb, one, one, & + vec, 2_${ik}$, -sgn*a( k1, k1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_dscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k1, l2 ) = x( 2, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k1, l2 ) = x( 2_${ik}$, 1_${ik}$ ) else if( l1/=l2 .and. k1/=k2 ) then - suml = stdlib_ddot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_ddot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 ) - sumr = stdlib_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & ) ), ldb ) - vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr ) - suml = stdlib_ddot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_ddot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + vec( 1_${ik}$, 2_${ik}$ ) = c( k1, l2 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_ddot( k1-1, a( 1, k2 ), 1, c( 1, l2 ), 1 ) - sumr = stdlib_ddot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & + vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_ddot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & ) ), ldb ) - vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr ) - call stdlib_dlasy2( .true., .true., isgn, 2, 2, a( k1, k1 ),lda, b( l1, l1 & - ), ldb, vec, 2, scaloc, x,2, xnorm, ierr ) - if( ierr/=0 )info = 1 + vec( 2_${ik}$, 2_${ik}$ ) = c( k2, l2 ) - ( suml+sgn*sumr ) + call stdlib${ii}$_dlasy2( .true., .true., isgn, 2_${ik}$, 2_${ik}$, a( k1, k1 ),lda, b( l1, l1 & + ), ldb, vec, 2_${ik}$, scaloc, x,2_${ik}$, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_dscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k1, l2 ) = x( 1, 2 ) - c( k2, l1 ) = x( 2, 1 ) - c( k2, l2 ) = x( 2, 2 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k1, l2 ) = x( 1_${ik}$, 2_${ik}$ ) + c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ ) + c( k2, l2 ) = x( 2_${ik}$, 2_${ik}$ ) end if end do loop_170 end do loop_180 @@ -61445,18 +61445,18 @@ module stdlib_linalg_lapack_d lnext = n loop_240: do l = n, 1, -1 if( l>lnext )cycle loop_240 - if( l==1 ) then + if( l==1_${ik}$ ) then l1 = l l2 = l else if( b( l, l-1 )/=zero ) then - l1 = l - 1 + l1 = l - 1_${ik}$ l2 = l - lnext = l - 2 + lnext = l - 2_${ik}$ else l1 = l l2 = l - lnext = l - 1 + lnext = l - 1_${ik}$ end if end if ! start row loop (index = k) @@ -61464,133 +61464,133 @@ module stdlib_linalg_lapack_d knext = m loop_230: do k = m, 1, -1 if( k>knext )cycle loop_230 - if( k==1 ) then + if( k==1_${ik}$ ) then k1 = k k2 = k else if( a( k, k-1 )/=zero ) then - k1 = k - 1 + k1 = k - 1_${ik}$ k2 = k - knext = k - 2 + knext = k - 2_${ik}$ else k1 = k k2 = k - knext = k - 1 + knext = k - 1_${ik}$ end if end if if( l1==l2 .and. k1==k2 ) then - suml = stdlib_ddot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & - l1 ), 1 ) - sumr = stdlib_ddot( n-l1, c( k1, min( l1+1, n ) ), ldc,b( l1, min( l1+1, n & + suml = stdlib${ii}$_ddot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( n-l1, c( k1, min( l1+1, n ) ), ldc,b( l1, min( l1+1, n & ) ), ldb ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) scaloc = one a11 = a( k1, k1 ) + sgn*b( l1, l1 ) da11 = abs( a11 ) if( da11<=smin ) then a11 = smin da11 = smin - info = 1 + info = 1_${ik}$ end if - db = abs( vec( 1, 1 ) ) + db = abs( vec( 1_${ik}$, 1_${ik}$ ) ) if( da11one ) then if( db>bignum*da11 )scaloc = one / db end if - x( 1, 1 ) = ( vec( 1, 1 )*scaloc ) / a11 + x( 1_${ik}$, 1_${ik}$ ) = ( vec( 1_${ik}$, 1_${ik}$ )*scaloc ) / a11 if( scaloc/=one ) then do j = 1, n - call stdlib_dscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) else if( l1==l2 .and. k1/=k2 ) then - suml = stdlib_ddot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l1 ), 1 ) - sumr = stdlib_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + suml = stdlib${ii}$_ddot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_ddot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l1 ), 1 ) - sumr = stdlib_ddot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_ddot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - call stdlib_dlaln2( .false., 2, 1, smin, one, a( k1, k1 ),lda, one, one, & - vec, 2, -sgn*b( l1, l1 ),zero, x, 2, scaloc, xnorm, ierr ) - if( ierr/=0 )info = 1 + vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr ) + call stdlib${ii}$_dlaln2( .false., 2_${ik}$, 1_${ik}$, smin, one, a( k1, k1 ),lda, one, one, & + vec, 2_${ik}$, -sgn*b( l1, l1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_dscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k2, l1 ) = x( 2, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ ) else if( l1/=l2 .and. k1==k2 ) then - suml = stdlib_ddot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & - l1 ), 1 ) - sumr = stdlib_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + suml = stdlib${ii}$_ddot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) - suml = stdlib_ddot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & - l2 ), 1 ) - sumr = stdlib_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & + vec( 1_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) + suml = stdlib${ii}$_ddot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & + l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & ) ), ldb ) - vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) - call stdlib_dlaln2( .false., 2, 1, smin, one, b( l1, l1 ),ldb, one, one, & - vec, 2, -sgn*a( k1, k1 ),zero, x, 2, scaloc, xnorm, ierr ) - if( ierr/=0 )info = 1 + vec( 2_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) + call stdlib${ii}$_dlaln2( .false., 2_${ik}$, 1_${ik}$, smin, one, b( l1, l1 ),ldb, one, one, & + vec, 2_${ik}$, -sgn*a( k1, k1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_dscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k1, l2 ) = x( 2, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k1, l2 ) = x( 2_${ik}$, 1_${ik}$ ) else if( l1/=l2 .and. k1/=k2 ) then - suml = stdlib_ddot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l1 ), 1 ) - sumr = stdlib_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + suml = stdlib${ii}$_ddot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_ddot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l2 ), 1 ) - sumr = stdlib_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_ddot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & ) ), ldb ) - vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr ) - suml = stdlib_ddot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l1 ), 1 ) - sumr = stdlib_ddot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + vec( 1_${ik}$, 2_${ik}$ ) = c( k1, l2 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_ddot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_ddot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l2 ), 1 ) - sumr = stdlib_ddot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & + vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_ddot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_ddot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & ) ), ldb ) - vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr ) - call stdlib_dlasy2( .false., .true., isgn, 2, 2, a( k1, k1 ),lda, b( l1, & - l1 ), ldb, vec, 2, scaloc, x,2, xnorm, ierr ) - if( ierr/=0 )info = 1 + vec( 2_${ik}$, 2_${ik}$ ) = c( k2, l2 ) - ( suml+sgn*sumr ) + call stdlib${ii}$_dlasy2( .false., .true., isgn, 2_${ik}$, 2_${ik}$, a( k1, k1 ),lda, b( l1, & + l1 ), ldb, vec, 2_${ik}$, scaloc, x,2_${ik}$, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_dscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k1, l2 ) = x( 1, 2 ) - c( k2, l1 ) = x( 2, 1 ) - c( k2, l2 ) = x( 2, 2 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k1, l2 ) = x( 1_${ik}$, 2_${ik}$ ) + c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ ) + c( k2, l2 ) = x( 2_${ik}$, 2_${ik}$ ) end if end do loop_230 end do loop_240 end if return - end subroutine stdlib_dtrsyl + end subroutine stdlib${ii}$_dtrsyl - pure subroutine stdlib_dgebrd( m, n, a, lda, d, e, tauq, taup, work, lwork,info ) + pure subroutine stdlib${ii}$_dgebrd( m, n, a, lda, d, e, tauq, taup, work, lwork,info ) !! DGEBRD reduces a general real M-by-N matrix A to upper or lower !! bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. !! If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. @@ -61598,8 +61598,8 @@ module stdlib_linalg_lapack_d ! -- 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, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, lwork, m, n ! Array Arguments real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: d(*), e(*), taup(*), tauq(*), work(*) @@ -61607,54 +61607,54 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, iinfo, j, ldwrkx, ldwrky, lwkopt, minmn, nb, nbmin, nx, ws + integer(${ik}$) :: i, iinfo, j, ldwrkx, ldwrky, lwkopt, minmn, nb, nbmin, nx, ws ! Intrinsic Functions intrinsic :: real,max,min ! Executable Statements ! test the input parameters - info = 0 - nb = max( 1, stdlib_ilaenv( 1, 'DGEBRD', ' ', m, n, -1, -1 ) ) + info = 0_${ik}$ + nb = max( 1_${ik}$, stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEBRD', ' ', m, n, -1_${ik}$, -1_${ik}$ ) ) lwkopt = ( m+n )*nb - work( 1 ) = real( lwkopt,KIND=dp) - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda1 .and. nb1_${ik}$ .and. nb=( m+n )*nbmin ) then nb = lwork / ( m+n ) else - nb = 1 + nb = 1_${ik}$ nx = minmn end if end if @@ -61666,13 +61666,13 @@ module stdlib_linalg_lapack_d ! reduce rows and columns i:i+nb-1 to bidiagonal form and return ! the matrices x and y which are needed to update the unreduced ! part of the matrix - call stdlib_dlabrd( m-i+1, n-i+1, nb, a( i, i ), lda, d( i ), e( i ),tauq( i ), & + call stdlib${ii}$_dlabrd( m-i+1, n-i+1, nb, a( i, i ), lda, d( i ), e( i ),tauq( i ), & taup( i ), work, ldwrkx,work( ldwrkx*nb+1 ), ldwrky ) ! update the trailing submatrix a(i+nb:m,i+nb:n), using an update ! of the form a := a - v*y**t - x*u**t - call stdlib_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', m-i-nb+1, n-i-nb+1,nb, -one, a( i+& + call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE', m-i-nb+1, n-i-nb+1,nb, -one, a( i+& nb, i ), lda,work( ldwrkx*nb+nb+1 ), ldwrky, one,a( i+nb, i+nb ), lda ) - call stdlib_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-i-nb+1, n-i-nb+1,nb, -one, & + call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-i-nb+1, n-i-nb+1,nb, -one, & work( nb+1 ), ldwrkx, a( i, i+nb ), lda,one, a( i+nb, i+nb ), lda ) ! copy diagonal and off-diagonal elements of b back into a if( m>=n ) then @@ -61688,61 +61688,61 @@ module stdlib_linalg_lapack_d end if end do ! use unblocked code to reduce the remainder of the matrix - call stdlib_dgebd2( m-i+1, n-i+1, a( i, i ), lda, d( i ), e( i ),tauq( i ), taup( i ), & + call stdlib${ii}$_dgebd2( m-i+1, n-i+1, a( i, i ), lda, d( i ), e( i ),tauq( i ), taup( i ), & work, iinfo ) - work( 1 ) = ws + work( 1_${ik}$ ) = ws return - end subroutine stdlib_dgebrd + end subroutine stdlib${ii}$_dgebrd - pure subroutine stdlib_dgehrd( n, ilo, ihi, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_dgehrd( n, ilo, ihi, a, lda, tau, work, lwork, info ) !! DGEHRD reduces a real general matrix A to upper Hessenberg form H by !! an orthogonal similarity transformation: Q**T * A * Q = H . ! -- lapack computational routine -- ! -- 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, lda, lwork, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ilo, lda, lwork, n + integer(${ik}$), intent(out) :: info ! Array Arguments real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: tau(*), 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) :: lquery - integer(ilp) :: i, ib, iinfo, iwt, j, ldwork, lwkopt, nb, nbmin, nh, nx + integer(${ik}$) :: i, ib, iinfo, iwt, j, ldwork, lwkopt, nb, nbmin, nh, nx real(dp) :: ei ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input parameters - info = 0 - lquery = ( lwork==-1 ) - if( n<0 ) then - info = -1 - else if( ilo<1 .or. ilo>max( 1, n ) ) then - info = -2 + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) + if( n<0_${ik}$ ) then + info = -1_${ik}$ + else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then + info = -2_${ik}$ else if( ihin ) then - info = -3 - else if( lda1 .and. nb1_${ik}$ .and. nb=(n*nbmin + tsize) ) then nb = (lwork-tsize) / n else - nb = 1 + nb = 1_${ik}$ end if end if end if @@ -61788,73 +61788,73 @@ module stdlib_linalg_lapack_d i = ilo else ! use blocked code - iwt = 1 + n*nb + iwt = 1_${ik}$ + n*nb do i = ilo, ihi - 1 - nx, nb ib = min( nb, ihi-i ) ! reduce columns i:i+ib-1 to hessenberg form, returning the ! matrices v and t of the block reflector h = i - v*t*v**t ! which performs the reduction, and also the matrix y = a*v*t - call stdlib_dlahr2( ihi, i, ib, a( 1, i ), lda, tau( i ),work( iwt ), ldt, work, & + call stdlib${ii}$_dlahr2( ihi, i, ib, a( 1_${ik}$, i ), lda, tau( i ),work( iwt ), ldt, work, & ldwork ) ! apply the block reflector h to a(1:ihi,i+ib:ihi) from the ! right, computing a := a - y * v**t. v(i+ib,ib-1) must be set ! to 1 ei = a( i+ib, i+ib-1 ) a( i+ib, i+ib-1 ) = one - call stdlib_dgemm( 'NO TRANSPOSE', 'TRANSPOSE',ihi, ihi-i-ib+1,ib, -one, work, & - ldwork, a( i+ib, i ), lda, one,a( 1, i+ib ), lda ) + call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE',ihi, ihi-i-ib+1,ib, -one, work, & + ldwork, a( i+ib, i ), lda, one,a( 1_${ik}$, i+ib ), lda ) a( i+ib, i+ib-1 ) = ei ! apply the block reflector h to a(1:i,i+1:i+ib-1) from the ! right - call stdlib_dtrmm( 'RIGHT', 'LOWER', 'TRANSPOSE','UNIT', i, ib-1,one, a( i+1, i )& + call stdlib${ii}$_dtrmm( 'RIGHT', 'LOWER', 'TRANSPOSE','UNIT', i, ib-1,one, a( i+1, i )& , lda, work, ldwork ) do j = 0, ib-2 - call stdlib_daxpy( i, -one, work( ldwork*j+1 ), 1,a( 1, i+j+1 ), 1 ) + call stdlib${ii}$_daxpy( i, -one, work( ldwork*j+1 ), 1_${ik}$,a( 1_${ik}$, i+j+1 ), 1_${ik}$ ) end do ! apply the block reflector h to a(i+1:ihi,i+ib:n) from the ! left - call stdlib_dlarfb( 'LEFT', 'TRANSPOSE', 'FORWARD','COLUMNWISE',ihi-i, n-i-ib+1, & + call stdlib${ii}$_dlarfb( 'LEFT', 'TRANSPOSE', 'FORWARD','COLUMNWISE',ihi-i, n-i-ib+1, & ib, a( i+1, i ), lda,work( iwt ), ldt, a( i+1, i+ib ), lda,work, ldwork ) end do end if ! use unblocked code to reduce the rest of the matrix - call stdlib_dgehd2( n, i, ihi, a, lda, tau, work, iinfo ) - work( 1 ) = lwkopt + call stdlib${ii}$_dgehd2( n, i, ihi, a, lda, tau, work, iinfo ) + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_dgehrd + end subroutine stdlib${ii}$_dgehrd - pure subroutine stdlib_dgelqt( m, n, mb, a, lda, t, ldt, work, info ) + pure subroutine stdlib${ii}$_dgelqt( m, n, mb, a, lda, t, ldt, work, info ) !! DGELQT computes a blocked LQ factorization of a real M-by-N matrix A !! using the compact WY representation of Q. ! -- 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, ldt, m, n, mb + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldt, m, n, mb ! Array Arguments real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: t(ldt,*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ib, iinfo, k + integer(${ik}$) :: i, ib, iinfo, k ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( mb<1 .or. ( mb>min(m,n) .and. min(m,n)>0 ) )then - info = -3 - else if( ldamin(m,n) .and. min(m,n)>0_${ik}$ ) )then + info = -3_${ik}$ + else if( lda=n ) then - nb = stdlib_ilaenv( 1, 'DGEQRF', ' ', m, n, -1, -1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) if( tpsd ) then - nb = max( nb, stdlib_ilaenv( 1, 'DORMQR', 'LN', m, nrhs, n,-1 ) ) + nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', 'LN', m, nrhs, n,-1_${ik}$ ) ) else - nb = max( nb, stdlib_ilaenv( 1, 'DORMQR', 'LT', m, nrhs, n,-1 ) ) + nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', 'LT', m, nrhs, n,-1_${ik}$ ) ) end if else - nb = stdlib_ilaenv( 1, 'DGELQF', ' ', m, n, -1, -1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGELQF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) if( tpsd ) then - nb = max( nb, stdlib_ilaenv( 1, 'DORMLQ', 'LT', n, nrhs, m,-1 ) ) + nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMLQ', 'LT', n, nrhs, m,-1_${ik}$ ) ) else - nb = max( nb, stdlib_ilaenv( 1, 'DORMLQ', 'LN', n, nrhs, m,-1 ) ) + nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMLQ', 'LN', n, nrhs, m,-1_${ik}$ ) ) end if end if - wsize = max( 1, mn+max( mn, nrhs )*nb ) - work( 1 ) = real( wsize,KIND=dp) + wsize = max( 1_${ik}$, mn+max( mn, nrhs )*nb ) + work( 1_${ik}$ ) = real( wsize,KIND=dp) end if - if( info/=0 ) then - call stdlib_xerbla( 'DGELS ', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DGELS ', -info ) return else if( lquery ) then return end if ! quick return if possible - if( min( m, n, nrhs )==0 ) then - call stdlib_dlaset( 'FULL', max( m, n ), nrhs, zero, zero, b, ldb ) + if( min( m, n, nrhs )==0_${ik}$ ) then + call stdlib${ii}$_dlaset( 'FULL', max( m, n ), nrhs, zero, zero, b, ldb ) return end if ! get machine parameters - smlnum = stdlib_dlamch( 'S' ) / stdlib_dlamch( 'P' ) + smlnum = stdlib${ii}$_dlamch( 'S' ) / stdlib${ii}$_dlamch( 'P' ) bignum = one / smlnum - call stdlib_dlabad( smlnum, bignum ) + call stdlib${ii}$_dlabad( smlnum, bignum ) ! scale a, b if max element outside range [smlnum,bignum] - anrm = stdlib_dlange( 'M', m, n, a, lda, rwork ) - iascl = 0 + anrm = stdlib${ii}$_dlange( 'M', m, n, a, lda, rwork ) + iascl = 0_${ik}$ if( anrm>zero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_dlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_dlaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) + call stdlib${ii}$_dlaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) go to 50 end if brow = m if( tpsd )brow = n - bnrm = stdlib_dlange( 'M', brow, nrhs, b, ldb, rwork ) - ibscl = 0 + bnrm = stdlib${ii}$_dlange( 'M', brow, nrhs, b, ldb, rwork ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_dlascl( 'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,info ) - ibscl = 2 + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, brow, nrhs, b, ldb,info ) + ibscl = 2_${ik}$ end if if( m>=n ) then ! compute qr factorization of a - call stdlib_dgeqrf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,info ) + call stdlib${ii}$_dgeqrf( m, n, a, lda, work( 1_${ik}$ ), work( mn+1 ), lwork-mn,info ) ! workspace at least n, optimally n*nb if( .not.tpsd ) then ! least-squares problem min || a * x - b || ! b(1:m,1:nrhs) := q**t * b(1:m,1:nrhs) - call stdlib_dormqr( 'LEFT', 'TRANSPOSE', m, nrhs, n, a, lda,work( 1 ), b, ldb, & + call stdlib${ii}$_dormqr( 'LEFT', 'TRANSPOSE', m, nrhs, n, a, lda,work( 1_${ik}$ ), b, ldb, & work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb ! b(1:n,1:nrhs) := inv(r) * b(1:n,1:nrhs) - call stdlib_dtrtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, nrhs,a, lda, b, ldb, & + call stdlib${ii}$_dtrtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, nrhs,a, lda, b, ldb, & info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if scllen = n else ! underdetermined system of equations a**t * x = b ! b(1:n,1:nrhs) := inv(r**t) * b(1:n,1:nrhs) - call stdlib_dtrtrs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,a, lda, b, ldb, & + call stdlib${ii}$_dtrtrs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,a, lda, b, ldb, & info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if ! b(n+1:m,1:nrhs) = zero @@ -62032,21 +62032,21 @@ module stdlib_linalg_lapack_d end do end do ! b(1:m,1:nrhs) := q(1:n,:) * b(1:n,1:nrhs) - call stdlib_dormqr( 'LEFT', 'NO TRANSPOSE', m, nrhs, n, a, lda,work( 1 ), b, ldb,& + call stdlib${ii}$_dormqr( 'LEFT', 'NO TRANSPOSE', m, nrhs, n, a, lda,work( 1_${ik}$ ), b, ldb,& work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb scllen = m end if else ! compute lq factorization of a - call stdlib_dgelqf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,info ) + call stdlib${ii}$_dgelqf( m, n, a, lda, work( 1_${ik}$ ), work( mn+1 ), lwork-mn,info ) ! workspace at least m, optimally m*nb. if( .not.tpsd ) then ! underdetermined system of equations a * x = b ! b(1:m,1:nrhs) := inv(l) * b(1:m,1:nrhs) - call stdlib_dtrtrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & + call stdlib${ii}$_dtrtrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if ! b(m+1:n,1:nrhs) = 0 @@ -62056,43 +62056,43 @@ module stdlib_linalg_lapack_d end do end do ! b(1:n,1:nrhs) := q(1:n,:)**t * b(1:m,1:nrhs) - call stdlib_dormlq( 'LEFT', 'TRANSPOSE', n, nrhs, m, a, lda,work( 1 ), b, ldb, & + call stdlib${ii}$_dormlq( 'LEFT', 'TRANSPOSE', n, nrhs, m, a, lda,work( 1_${ik}$ ), b, ldb, & work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb scllen = n else ! overdetermined system min || a**t * x - b || ! b(1:n,1:nrhs) := q * b(1:n,1:nrhs) - call stdlib_dormlq( 'LEFT', 'NO TRANSPOSE', n, nrhs, m, a, lda,work( 1 ), b, ldb,& + call stdlib${ii}$_dormlq( 'LEFT', 'NO TRANSPOSE', n, nrhs, m, a, lda,work( 1_${ik}$ ), b, ldb,& work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb ! b(1:m,1:nrhs) := inv(l**t) * b(1:m,1:nrhs) - call stdlib_dtrtrs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & + call stdlib${ii}$_dtrtrs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if scllen = m end if end if ! undo scaling - if( iascl==1 ) then - call stdlib_dlascl( 'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,info ) - else if( iascl==2 ) then - call stdlib_dlascl( 'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,info ) + if( iascl==1_${ik}$ ) then + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, smlnum, scllen, nrhs, b, ldb,info ) + else if( iascl==2_${ik}$ ) then + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, scllen, nrhs, b, ldb,info ) end if - if( ibscl==1 ) then - call stdlib_dlascl( 'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,info ) - else if( ibscl==2 ) then - call stdlib_dlascl( 'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,info ) + if( ibscl==1_${ik}$ ) then + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, bnrm, scllen, nrhs, b, ldb,info ) + else if( ibscl==2_${ik}$ ) then + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bignum, bnrm, scllen, nrhs, b, ldb,info ) end if 50 continue - work( 1 ) = real( wsize,KIND=dp) + work( 1_${ik}$ ) = real( wsize,KIND=dp) return - end subroutine stdlib_dgels + end subroutine stdlib${ii}$_dgels - pure subroutine stdlib_dgemlq( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, & + pure subroutine stdlib${ii}$_dgemlq( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, & !! DGEMLQ overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -62106,8 +62106,8 @@ module stdlib_linalg_lapack_d ! -- 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) :: lda, m, n, k, tsize, lwork, ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, k, tsize, lwork, ldc ! Array Arguments real(dp), intent(in) :: a(lda,*), t(*) real(dp), intent(inout) :: c(ldc,*) @@ -62115,18 +62115,18 @@ module stdlib_linalg_lapack_d ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran, lquery - integer(ilp) :: mb, nb, lw, nblcks, mn + integer(${ik}$) :: mb, nb, lw, nblcks, mn ! Intrinsic Functions intrinsic :: int,max,min,mod ! Executable Statements ! test the input arguments - lquery = lwork==-1 + lquery = lwork==-1_${ik}$ notran = stdlib_lsame( trans, 'N' ) tran = stdlib_lsame( trans, 'T' ) left = stdlib_lsame( side, 'L' ) right = stdlib_lsame( side, 'R' ) - mb = int( t( 2 ),KIND=ilp) - nb = int( t( 3 ),KIND=ilp) + mb = int( t( 2_${ik}$ ),KIND=${ik}$) + nb = int( t( 3_${ik}$ ),KIND=${ik}$) if( left ) then lw = n * mb mn = m @@ -62135,61 +62135,61 @@ module stdlib_linalg_lapack_d mn = n end if if( ( nb>k ) .and. ( mn>k ) ) then - if( mod( mn - k, nb - k ) == 0 ) then + if( mod( mn - k, nb - k ) == 0_${ik}$ ) then nblcks = ( mn - k ) / ( nb - k ) else - nblcks = ( mn - k ) / ( nb - k ) + 1 + nblcks = ( mn - k ) / ( nb - k ) + 1_${ik}$ end if else - nblcks = 1 + nblcks = 1_${ik}$ end if - info = 0 + info = 0_${ik}$ 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>mn ) then - info = -5 - else if( ldamn ) then + info = -5_${ik}$ + else if( lda=max( m, n, & k ) ) ) then - call stdlib_dgemlqt( side, trans, m, n, k, mb, a, lda,t( 6 ), mb, c, ldc, work, info & + call stdlib${ii}$_dgemlqt( side, trans, m, n, k, mb, a, lda,t( 6_${ik}$ ), mb, c, ldc, work, info & ) else - call stdlib_dlamswlq( side, trans, m, n, k, mb, nb, a, lda, t( 6 ),mb, c, ldc, work, & + call stdlib${ii}$_dlamswlq( side, trans, m, n, k, mb, nb, a, lda, t( 6_${ik}$ ),mb, c, ldc, work, & lwork, info ) end if - work( 1 ) = lw + work( 1_${ik}$ ) = lw return - end subroutine stdlib_dgemlq + end subroutine stdlib${ii}$_dgemlq - pure subroutine stdlib_dgemqr( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, & + pure subroutine stdlib${ii}$_dgemqr( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, & !! DGEMQR overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -62203,8 +62203,8 @@ module stdlib_linalg_lapack_d ! -- 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) :: lda, m, n, k, tsize, lwork, ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, k, tsize, lwork, ldc ! Array Arguments real(dp), intent(in) :: a(lda,*), t(*) real(dp), intent(inout) :: c(ldc,*) @@ -62212,18 +62212,18 @@ module stdlib_linalg_lapack_d ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran, lquery - integer(ilp) :: mb, nb, lw, nblcks, mn + integer(${ik}$) :: mb, nb, lw, nblcks, mn ! Intrinsic Functions intrinsic :: int,max,min,mod ! Executable Statements ! test the input arguments - lquery = lwork==-1 + lquery = lwork==-1_${ik}$ notran = stdlib_lsame( trans, 'N' ) tran = stdlib_lsame( trans, 'T' ) left = stdlib_lsame( side, 'L' ) right = stdlib_lsame( side, 'R' ) - mb = int( t( 2 ),KIND=ilp) - nb = int( t( 3 ),KIND=ilp) + mb = int( t( 2_${ik}$ ),KIND=${ik}$) + nb = int( t( 3_${ik}$ ),KIND=${ik}$) if( left ) then lw = n * nb mn = m @@ -62232,150 +62232,150 @@ module stdlib_linalg_lapack_d mn = n end if if( ( mb>k ) .and. ( mn>k ) ) then - if( mod( mn - k, mb - k )==0 ) then + if( mod( mn - k, mb - k )==0_${ik}$ ) then nblcks = ( mn - k ) / ( mb - k ) else - nblcks = ( mn - k ) / ( mb - k ) + 1 + nblcks = ( mn - k ) / ( mb - k ) + 1_${ik}$ end if else - nblcks = 1 + nblcks = 1_${ik}$ end if - info = 0 + info = 0_${ik}$ 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>mn ) then - info = -5 - else if( ldamn ) then + info = -5_${ik}$ + else if( lda=max( m, n, & k ) ) ) then - call stdlib_dgemqrt( side, trans, m, n, k, nb, a, lda, t( 6 ),nb, c, ldc, work, info & + call stdlib${ii}$_dgemqrt( side, trans, m, n, k, nb, a, lda, t( 6_${ik}$ ),nb, c, ldc, work, info & ) else - call stdlib_dlamtsqr( side, trans, m, n, k, mb, nb, a, lda, t( 6 ),nb, c, ldc, work, & + call stdlib${ii}$_dlamtsqr( side, trans, m, n, k, mb, nb, a, lda, t( 6_${ik}$ ),nb, c, ldc, work, & lwork, info ) end if - work( 1 ) = lw + work( 1_${ik}$ ) = lw return - end subroutine stdlib_dgemqr + end subroutine stdlib${ii}$_dgemqr - pure subroutine stdlib_dgeqp3( m, n, a, lda, jpvt, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_dgeqp3( m, n, a, lda, jpvt, tau, work, lwork, info ) !! DGEQP3 computes a QR factorization with column pivoting of a !! matrix A: A*P = Q*R using Level 3 BLAS. ! -- lapack computational routine -- ! -- 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, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, lwork, m, n ! Array Arguments - integer(ilp), intent(inout) :: jpvt(*) + integer(${ik}$), intent(inout) :: jpvt(*) real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: tau(*), work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: inb = 1 - integer(ilp), parameter :: inbmin = 2 - integer(ilp), parameter :: ixover = 3 + integer(${ik}$), parameter :: inb = 1_${ik}$ + integer(${ik}$), parameter :: inbmin = 2_${ik}$ + integer(${ik}$), parameter :: ixover = 3_${ik}$ ! Local Scalars logical(lk) :: lquery - integer(ilp) :: fjb, iws, j, jb, lwkopt, minmn, minws, na, nb, nbmin, nfxd, nx, sm, & + integer(${ik}$) :: fjb, iws, j, jb, lwkopt, minmn, minws, na, nb, nbmin, nfxd, nx, sm, & sminmn, sn, topbmn ! Intrinsic Functions intrinsic :: int,max,min ! Executable Statements ! test input arguments ! ==================== - info = 0 - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda0 ) then + if( nfxd>0_${ik}$ ) then na = min( m, nfxd ) - ! cc call stdlib_dgeqr2( m, na, a, lda, tau, work, info ) - call stdlib_dgeqrf( m, na, a, lda, tau, work, lwork, info ) - iws = max( iws, int( work( 1 ),KIND=ilp) ) + ! cc call stdlib${ii}$_dgeqr2( m, na, a, lda, tau, work, info ) + call stdlib${ii}$_dgeqrf( m, na, a, lda, tau, work, lwork, info ) + iws = max( iws, int( work( 1_${ik}$ ),KIND=${ik}$) ) if( na1 ) .and. ( nb1_${ik}$ ) .and. ( nb=nbmin ) .and. ( nbmin(m,n) .and. min(m,n)>0 ) )then - info = -3 - else if( ldamin(m,n) .and. min(m,n)>0_${ik}$ ) )then + info = -3_${ik}$ + else if( lda= N. The SVD of A is written as !! [++] [xx] [x0] [xx] @@ -62558,27 +62558,27 @@ module stdlib_linalg_lapack_d ! -- 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, ldv, lwork, m, mv, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldv, lwork, m, mv, n character, intent(in) :: joba, jobu, jobv ! Array Arguments real(dp), intent(inout) :: a(lda,*), v(ldv,*), work(lwork) real(dp), intent(out) :: sva(n) ! ===================================================================== ! Local Parameters - integer(ilp), parameter :: nsweep = 30 + integer(${ik}$), parameter :: nsweep = 30_${ik}$ ! Local Scalars real(dp) :: aapp, aapp0, aapq, aaqq, apoaq, aqoap, big, bigtheta, cs, ctol, epsln, & large, mxaapq, mxsinj, rootbig, rooteps, rootsfmin, roottol, skl, sfmin, small, sn, t, & temp1, theta, thsign, tol - integer(ilp) :: blskip, emptsw, i, ibr, ierr, igl, ijblsk, ir1, iswrot, jbc, jgl, kbl, & + integer(${ik}$) :: blskip, emptsw, i, ibr, ierr, igl, ijblsk, ir1, iswrot, jbc, jgl, kbl, & lkahead, mvl, n2, n34, n4, nbl, notrot, p, pskipped, q, rowskip, swband logical(lk) :: applv, goscale, lower, lsvec, noscale, rotok, rsvec, uctol, & upper ! Local Arrays - real(dp) :: fastr(5) + real(dp) :: fastr(5_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,min,real,sign,sqrt ! from lapack @@ -62592,31 +62592,31 @@ module stdlib_linalg_lapack_d upper = stdlib_lsame( joba, 'U' ) lower = stdlib_lsame( joba, 'L' ) if( .not.( upper .or. lower .or. stdlib_lsame( joba, 'G' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( lsvec .or. uctol .or. stdlib_lsame( jobu, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( rsvec .or. applv .or. stdlib_lsame( jobv, 'N' ) ) ) then - info = -3 - else if( m<0 ) then - info = -4 - else if( ( n<0 ) .or. ( n>m ) ) then - info = -5 + info = -3_${ik}$ + else if( m<0_${ik}$ ) then + info = -4_${ik}$ + else if( ( n<0_${ik}$ ) .or. ( n>m ) ) then + info = -5_${ik}$ else if( lda=one ) then - info = -4 - call stdlib_xerbla( 'DGESVJ', -info ) + info = -4_${ik}$ + call stdlib${ii}$_xerbla( 'DGESVJ', -info ) return end if ! initialize the right singular vector matrix. if( rsvec ) then mvl = n - call stdlib_dlaset( 'A', mvl, n, zero, one, v, ldv ) + call stdlib${ii}$_dlaset( 'A', mvl, n, zero, one, v, ldv ) else if( applv ) then mvl = mv end if @@ -62679,10 +62679,10 @@ module stdlib_linalg_lapack_d do p = 1, n aapp = zero aaqq = one - call stdlib_dlassq( m-p+1, a( p, p ), 1, aapp, aaqq ) + call stdlib${ii}$_dlassq( m-p+1, a( p, p ), 1_${ik}$, aapp, aaqq ) if( aapp>big ) then - info = -6 - call stdlib_xerbla( 'DGESVJ', -info ) + info = -6_${ik}$ + call stdlib${ii}$_xerbla( 'DGESVJ', -info ) return end if aaqq = sqrt( aaqq ) @@ -62704,10 +62704,10 @@ module stdlib_linalg_lapack_d do p = 1, n aapp = zero aaqq = one - call stdlib_dlassq( p, a( 1, p ), 1, aapp, aaqq ) + call stdlib${ii}$_dlassq( p, a( 1_${ik}$, p ), 1_${ik}$, aapp, aaqq ) if( aapp>big ) then - info = -6 - call stdlib_xerbla( 'DGESVJ', -info ) + info = -6_${ik}$ + call stdlib${ii}$_xerbla( 'DGESVJ', -info ) return end if aaqq = sqrt( aaqq ) @@ -62729,10 +62729,10 @@ module stdlib_linalg_lapack_d do p = 1, n aapp = zero aaqq = one - call stdlib_dlassq( m, a( 1, p ), 1, aapp, aaqq ) + call stdlib${ii}$_dlassq( m, a( 1_${ik}$, p ), 1_${ik}$, aapp, aaqq ) if( aapp>big ) then - info = -6 - call stdlib_xerbla( 'DGESVJ', -info ) + info = -6_${ik}$ + call stdlib${ii}$_xerbla( 'DGESVJ', -info ) return end if aaqq = sqrt( aaqq ) @@ -62762,29 +62762,29 @@ module stdlib_linalg_lapack_d end do ! #:) quick return for zero matrix if( aapp==zero ) then - if( lsvec )call stdlib_dlaset( 'G', m, n, zero, one, a, lda ) - work( 1 ) = one - work( 2 ) = zero - work( 3 ) = zero - work( 4 ) = zero - work( 5 ) = zero - work( 6 ) = zero + if( lsvec )call stdlib${ii}$_dlaset( 'G', m, n, zero, one, a, lda ) + work( 1_${ik}$ ) = one + work( 2_${ik}$ ) = zero + work( 3_${ik}$ ) = zero + work( 4_${ik}$ ) = zero + work( 5_${ik}$ ) = zero + work( 6_${ik}$ ) = zero return end if ! #:) quick return for one-column matrix - if( n==1 ) then - if( lsvec )call stdlib_dlascl( 'G', 0, 0, sva( 1 ), skl, m, 1,a( 1, 1 ), lda, ierr ) + if( n==1_${ik}$ ) then + if( lsvec )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, sva( 1_${ik}$ ), skl, m, 1_${ik}$,a( 1_${ik}$, 1_${ik}$ ), lda, ierr ) - work( 1 ) = one / skl - if( sva( 1 )>=sfmin ) then - work( 2 ) = one + work( 1_${ik}$ ) = one / skl + if( sva( 1_${ik}$ )>=sfmin ) then + work( 2_${ik}$ ) = one else - work( 2 ) = zero + work( 2_${ik}$ ) = zero end if - work( 3 ) = zero - work( 4 ) = zero - work( 5 ) = zero - work( 6 ) = zero + work( 3_${ik}$ ) = zero + work( 4_${ik}$ ) = zero + work( 5_${ik}$ ) = zero + work( 6_${ik}$ ) = zero return end if ! protect small singular values from underflow, and try to @@ -62813,57 +62813,57 @@ module stdlib_linalg_lapack_d end if ! scale, if necessary if( temp1/=one ) then - call stdlib_dlascl( 'G', 0, 0, one, temp1, n, 1, sva, n, ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, one, temp1, n, 1_${ik}$, sva, n, ierr ) end if skl= temp1*skl if( skl/=one ) then - call stdlib_dlascl( joba, 0, 0, one, skl, m, n, a, lda, ierr ) + call stdlib${ii}$_dlascl( joba, 0_${ik}$, 0_${ik}$, one, skl, m, n, a, lda, ierr ) skl= one / skl end if ! row-cyclic jacobi svd algorithm with column pivoting - emptsw = ( n*( n-1 ) ) / 2 - notrot = 0 - fastr( 1 ) = zero + emptsw = ( n*( n-1 ) ) / 2_${ik}$ + notrot = 0_${ik}$ + fastr( 1_${ik}$ ) = zero ! a is represented in factored form a = a * diag(work), where diag(work) ! is initialized to identity. work is updated during fast scaled ! rotations. do q = 1, n work( q ) = one end do - swband = 3 + swband = 3_${ik}$ ! [tp] swband is a tuning parameter [tp]. it is meaningful and effective - ! if stdlib_dgesvj is used as a computational routine in the preconditioned - ! jacobi svd algorithm stdlib_dgesvj. for sweeps i=1:swband the procedure + ! if stdlib${ii}$_dgesvj is used as a computational routine in the preconditioned + ! jacobi svd algorithm stdlib${ii}$_dgesvj. for sweeps i=1:swband the procedure ! works on pivots inside a band-like region around the diagonal. ! the boundaries are determined dynamically, based on the number of ! pivots above a threshold. - kbl = min( 8, n ) + kbl = min( 8_${ik}$, n ) ! [tp] kbl is a tuning parameter that defines the tile size in the ! tiling of the p-q loops of pivot pairs. in general, an optimal ! value of kbl depends on the matrix dimensions and on the ! parameters of the computer's memory. nbl = n / kbl - if( ( nbl*kbl )/=n )nbl = nbl + 1 - blskip = kbl**2 + if( ( nbl*kbl )/=n )nbl = nbl + 1_${ik}$ + blskip = kbl**2_${ik}$ ! [tp] blkskip is a tuning parameter that depends on swband and kbl. - rowskip = min( 5, kbl ) + rowskip = min( 5_${ik}$, kbl ) ! [tp] rowskip is a tuning parameter. - lkahead = 1 + lkahead = 1_${ik}$ ! [tp] lkahead is a tuning parameter. ! quasi block transformations, using the lower (upper) triangular ! structure of the input matrix. the quasi-block-cycling usually ! invokes cubic convergence. big part of this cycle is done inside ! canonical subspaces of dimensions less than m. - if( ( lower .or. upper ) .and. ( n>max( 64, 4*kbl ) ) ) then + if( ( lower .or. upper ) .and. ( n>max( 64_${ik}$, 4_${ik}$*kbl ) ) ) then ! [tp] the number of partition levels and the actual partition are ! tuning parameters. - n4 = n / 4 - n2 = n / 2 - n34 = 3*n4 + n4 = n / 4_${ik}$ + n2 = n / 2_${ik}$ + n34 = 3_${ik}$*n4 if( applv ) then - q = 0 + q = 0_${ik}$ else - q = 1 + q = 1_${ik}$ end if if( lower ) then ! this works very well on lower triangular matrices, in particular @@ -62873,32 +62873,32 @@ module stdlib_linalg_lapack_d ! [+ + 0 0] [0 0] ! [+ + x 0] actually work on [x 0] [x 0] ! [+ + x x] [x x]. [x x] - call stdlib_dgsvj0( jobv, m-n34, n-n34, a( n34+1, n34+1 ), lda,work( n34+1 ), & - sva( n34+1 ), mvl,v( n34*q+1, n34+1 ), ldv, epsln, sfmin, tol,2, work( n+1 ), & + call stdlib${ii}$_dgsvj0( jobv, m-n34, n-n34, a( n34+1, n34+1 ), lda,work( n34+1 ), & + sva( n34+1 ), mvl,v( n34*q+1, n34+1 ), ldv, epsln, sfmin, tol,2_${ik}$, work( n+1 ), & lwork-n, ierr ) - call stdlib_dgsvj0( jobv, m-n2, n34-n2, a( n2+1, n2+1 ), lda,work( n2+1 ), sva( & - n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 2,work( n+1 ), lwork-n, & + call stdlib${ii}$_dgsvj0( jobv, m-n2, n34-n2, a( n2+1, n2+1 ), lda,work( n2+1 ), sva( & + n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 2_${ik}$,work( n+1 ), lwork-n, & ierr ) - call stdlib_dgsvj1( jobv, m-n2, n-n2, n4, a( n2+1, n2+1 ), lda,work( n2+1 ), sva(& - n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1,work( n+1 ), lwork-n, & + call stdlib${ii}$_dgsvj1( jobv, m-n2, n-n2, n4, a( n2+1, n2+1 ), lda,work( n2+1 ), sva(& + n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1_${ik}$,work( n+1 ), lwork-n, & ierr ) - call stdlib_dgsvj0( jobv, m-n4, n2-n4, a( n4+1, n4+1 ), lda,work( n4+1 ), sva( & - n4+1 ), mvl,v( n4*q+1, n4+1 ), ldv, epsln, sfmin, tol, 1,work( n+1 ), lwork-n, & + call stdlib${ii}$_dgsvj0( jobv, m-n4, n2-n4, a( n4+1, n4+1 ), lda,work( n4+1 ), sva( & + n4+1 ), mvl,v( n4*q+1, n4+1 ), ldv, epsln, sfmin, tol, 1_${ik}$,work( n+1 ), lwork-n, & ierr ) - call stdlib_dgsvj0( jobv, m, n4, a, lda, work, sva, mvl, v, ldv,epsln, sfmin, & - tol, 1, work( n+1 ), lwork-n,ierr ) - call stdlib_dgsvj1( jobv, m, n2, n4, a, lda, work, sva, mvl, v,ldv, epsln, sfmin,& - tol, 1, work( n+1 ),lwork-n, ierr ) + call stdlib${ii}$_dgsvj0( jobv, m, n4, a, lda, work, sva, mvl, v, ldv,epsln, sfmin, & + tol, 1_${ik}$, work( n+1 ), lwork-n,ierr ) + call stdlib${ii}$_dgsvj1( jobv, m, n2, n4, a, lda, work, sva, mvl, v,ldv, epsln, sfmin,& + tol, 1_${ik}$, work( n+1 ),lwork-n, ierr ) else if( upper ) then - call stdlib_dgsvj0( jobv, n4, n4, a, lda, work, sva, mvl, v, ldv,epsln, sfmin, & - tol, 2, work( n+1 ), lwork-n,ierr ) - call stdlib_dgsvj0( jobv, n2, n4, a( 1, n4+1 ), lda, work( n4+1 ),sva( n4+1 ), & - mvl, v( n4*q+1, n4+1 ), ldv,epsln, sfmin, tol, 1, work( n+1 ), lwork-n,ierr ) + call stdlib${ii}$_dgsvj0( jobv, n4, n4, a, lda, work, sva, mvl, v, ldv,epsln, sfmin, & + tol, 2_${ik}$, work( n+1 ), lwork-n,ierr ) + call stdlib${ii}$_dgsvj0( jobv, n2, n4, a( 1_${ik}$, n4+1 ), lda, work( n4+1 ),sva( n4+1 ), & + mvl, v( n4*q+1, n4+1 ), ldv,epsln, sfmin, tol, 1_${ik}$, work( n+1 ), lwork-n,ierr ) - call stdlib_dgsvj1( jobv, n2, n2, n4, a, lda, work, sva, mvl, v,ldv, epsln, & - sfmin, tol, 1, work( n+1 ),lwork-n, ierr ) - call stdlib_dgsvj0( jobv, n2+n4, n4, a( 1, n2+1 ), lda,work( n2+1 ), sva( n2+1 ),& - mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1,work( n+1 ), lwork-n, ierr ) + call stdlib${ii}$_dgsvj1( jobv, n2, n2, n4, a, lda, work, sva, mvl, v,ldv, epsln, & + sfmin, tol, 1_${ik}$, work( n+1 ),lwork-n, ierr ) + call stdlib${ii}$_dgsvj0( jobv, n2+n4, n4, a( 1_${ik}$, n2+1 ), lda,work( n2+1 ), sva( n2+1 ),& + mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1_${ik}$,work( n+1 ), lwork-n, ierr ) end if end if @@ -62907,23 +62907,23 @@ module stdlib_linalg_lapack_d ! .. go go go ... mxaapq = zero mxsinj = zero - iswrot = 0 - notrot = 0 - pskipped = 0 + iswrot = 0_${ik}$ + notrot = 0_${ik}$ + pskipped = 0_${ik}$ ! each sweep is unrolled using kbl-by-kbl tiles over the pivot pairs ! 1 <= p < q <= n. this is the first step toward a blocked implementation ! of the rotations. new implementation, based on block transformations, ! is under development. loop_2000: do ibr = 1, nbl - igl = ( ibr-1 )*kbl + 1 + igl = ( ibr-1 )*kbl + 1_${ik}$ loop_1002: do ir1 = 0, min( lkahead, nbl-ibr ) igl = igl + ir1*kbl loop_2001: do p = igl, min( igl+kbl-1, n-1 ) ! .. de rijk's pivoting - q = stdlib_idamax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib${ii}$_idamax( n-p+1, sva( p ), 1_${ik}$ ) + p - 1_${ik}$ if( p/=q ) then - call stdlib_dswap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_dswap( mvl, v( 1, p ), 1,v( 1, q ), 1 ) + call stdlib${ii}$_dswap( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) + if( rsvec )call stdlib${ii}$_dswap( mvl, v( 1_${ik}$, p ), 1_${ik}$,v( 1_${ik}$, q ), 1_${ik}$ ) temp1 = sva( p ) sva( p ) = sva( q ) sva( q ) = temp1 @@ -62931,24 +62931,24 @@ module stdlib_linalg_lapack_d work( p ) = work( q ) work( q ) = temp1 end if - if( ir1==0 ) then + if( ir1==0_${ik}$ ) then ! column norms are periodically updated by explicit ! norm computation. ! caveat: - ! unfortunately, some blas implementations compute stdlib_dnrm2(m,a(1,p),1) - ! as sqrt(stdlib_ddot(m,a(1,p),1,a(1,p),1)), which may cause the result to + ! unfortunately, some blas implementations compute stdlib${ii}$_dnrm2(m,a(1,p),1) + ! as sqrt(stdlib${ii}$_ddot(m,a(1,p),1,a(1,p),1)), which may cause the result to ! overflow for ||a(:,p)||_2 > sqrt(overflow_threshold), and to ! underflow for ||a(:,p)||_2 < sqrt(underflow_threshold). - ! hence, stdlib_dnrm2 cannot be trusted, not even in the case when + ! hence, stdlib${ii}$_dnrm2 cannot be trusted, not even in the case when ! the true norm is far from the under(over)flow boundaries. - ! if properly implemented stdlib_dnrm2 is available, the if-then-else - ! below should read "aapp = stdlib_dnrm2( m, a(1,p), 1 ) * work(p)". + ! if properly implemented stdlib${ii}$_dnrm2 is available, the if-then-else + ! below should read "aapp = stdlib${ii}$_dnrm2( m, a(1,p), 1 ) * work(p)". if( ( sva( p )rootsfmin ) ) then - sva( p ) = stdlib_dnrm2( m, a( 1, p ), 1 )*work( p ) + sva( p ) = stdlib${ii}$_dnrm2( m, a( 1_${ik}$, p ), 1_${ik}$ )*work( p ) else temp1 = zero aapp = one - call stdlib_dlassq( m, a( 1, p ), 1, temp1, aapp ) + call stdlib${ii}$_dlassq( m, a( 1_${ik}$, p ), 1_${ik}$, temp1, aapp ) sva( p ) = temp1*sqrt( aapp )*work( p ) end if aapp = sva( p ) @@ -62956,7 +62956,7 @@ module stdlib_linalg_lapack_d aapp = sva( p ) end if if( aapp>zero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2002: do q = p + 1, min( igl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -62964,25 +62964,25 @@ module stdlib_linalg_lapack_d if( aaqq>=one ) then rotok = ( small*aapp )<=aaqq if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_ddot( m, a( 1, p ), 1, a( 1,q ), 1 )*work( & + aapq = ( stdlib${ii}$_ddot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*work( & p )*work( q ) /aaqq ) / aapp else - call stdlib_dcopy( m, a( 1, p ), 1,work( n+1 ), 1 ) - call stdlib_dlascl( 'G', 0, 0, aapp,work( p ), m, 1,work( n+& - 1 ), lda, ierr ) - aapq = stdlib_ddot( m, work( n+1 ), 1,a( 1, q ), 1 )*work( & + call stdlib${ii}$_dcopy( m, a( 1_${ik}$, p ), 1_${ik}$,work( n+1 ), 1_${ik}$ ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aapp,work( p ), m, 1_${ik}$,work( n+& + 1_${ik}$ ), lda, ierr ) + aapq = stdlib${ii}$_ddot( m, work( n+1 ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ )*work( & q ) / aaqq end if else rotok = aapp<=( aaqq / small ) if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_ddot( m, a( 1, p ), 1, a( 1,q ), 1 )*work( & + aapq = ( stdlib${ii}$_ddot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*work( & p )*work( q ) /aaqq ) / aapp else - call stdlib_dcopy( m, a( 1, q ), 1,work( n+1 ), 1 ) - call stdlib_dlascl( 'G', 0, 0, aaqq,work( q ), m, 1,work( n+& - 1 ), lda, ierr ) - aapq = stdlib_ddot( m, work( n+1 ), 1,a( 1, p ), 1 )*work( & + call stdlib${ii}$_dcopy( m, a( 1_${ik}$, q ), 1_${ik}$,work( n+1 ), 1_${ik}$ ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq,work( q ), m, 1_${ik}$,work( n+& + 1_${ik}$ ), lda, ierr ) + aapq = stdlib${ii}$_ddot( m, work( n+1 ), 1_${ik}$,a( 1_${ik}$, p ), 1_${ik}$ )*work( & p ) / aapp end if end if @@ -62991,10 +62991,10 @@ module stdlib_linalg_lapack_d if( abs( aapq )>tol ) then ! Rotate ! [rtd] rotated = rotated + one - if( ir1==0 ) then - notrot = 0 - pskipped = 0 - iswrot = iswrot + 1 + if( ir1==0_${ik}$ ) then + notrot = 0_${ik}$ + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ end if if( rotok ) then aqoap = aaqq / aapp @@ -63002,12 +63002,12 @@ module stdlib_linalg_lapack_d theta = -half*abs(aqoap-apoaq)/aapq if( abs( theta )>bigtheta ) then t = half / theta - fastr( 3 ) = t*work( p ) / work( q ) - fastr( 4 ) = -t*work( q ) /work( p ) - call stdlib_drotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) + fastr( 3_${ik}$ ) = t*work( p ) / work( q ) + fastr( 4_${ik}$ ) = -t*work( q ) /work( p ) + call stdlib${ii}$_drotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$, fastr ) - if( rsvec )call stdlib_drotm( mvl,v( 1, p ), 1,v( 1, q ),& - 1,fastr ) + if( rsvec )call stdlib${ii}$_drotm( mvl,v( 1_${ik}$, p ), 1_${ik}$,v( 1_${ik}$, q ),& + 1_${ik}$,fastr ) sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq ) ) @@ -63027,68 +63027,68 @@ module stdlib_linalg_lapack_d aqoap = work( q ) / work( p ) if( work( p )>=one ) then if( work( q )>=one ) then - fastr( 3 ) = t*apoaq - fastr( 4 ) = -t*aqoap + fastr( 3_${ik}$ ) = t*apoaq + fastr( 4_${ik}$ ) = -t*aqoap work( p ) = work( p )*cs work( q ) = work( q )*cs - call stdlib_drotm( m, a( 1, p ), 1,a( 1, q ), 1,& + call stdlib${ii}$_drotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$,& fastr ) - if( rsvec )call stdlib_drotm( mvl,v( 1, p ), 1, v( & - 1, q ),1, fastr ) + if( rsvec )call stdlib${ii}$_drotm( mvl,v( 1_${ik}$, p ), 1_${ik}$, v( & + 1_${ik}$, q ),1_${ik}$, fastr ) else - call stdlib_daxpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & - p ), 1 ) - call stdlib_daxpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & - 1, q ), 1 ) + call stdlib${ii}$_daxpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( 1_${ik}$, & + p ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( & + 1_${ik}$, q ), 1_${ik}$ ) work( p ) = work( p )*cs work( q ) = work( q ) / cs if( rsvec ) then - call stdlib_daxpy( mvl, -t*aqoap,v( 1, q ), 1,v(& - 1, p ), 1 ) - call stdlib_daxpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& - v( 1, q ), 1 ) + call stdlib${ii}$_daxpy( mvl, -t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,v(& + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ), 1_${ik}$,& + v( 1_${ik}$, q ), 1_${ik}$ ) end if end if else if( work( q )>=one ) then - call stdlib_daxpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & - ), 1 ) - call stdlib_daxpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) + call stdlib${ii}$_daxpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q & + ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( m, -cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) work( p ) = work( p ) / cs work( q ) = work( q )*cs if( rsvec ) then - call stdlib_daxpy( mvl, t*apoaq,v( 1, p ), 1,v( & - 1, q ), 1 ) - call stdlib_daxpy( mvl,-cs*sn*aqoap,v( 1, q ), & - 1,v( 1, p ), 1 ) + call stdlib${ii}$_daxpy( mvl, t*apoaq,v( 1_${ik}$, p ), 1_${ik}$,v( & + 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q ), & + 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if else if( work( p )>=work( q ) )then - call stdlib_daxpy( m, -t*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) - call stdlib_daxpy( m, cs*sn*apoaq,a( 1, p ), 1,& - a( 1, q ), 1 ) + call stdlib${ii}$_daxpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,& + a( 1_${ik}$, q ), 1_${ik}$ ) work( p ) = work( p )*cs work( q ) = work( q ) / cs if( rsvec ) then - call stdlib_daxpy( mvl,-t*aqoap,v( 1, q ), 1,& - v( 1, p ), 1 ) - call stdlib_daxpy( mvl,cs*sn*apoaq,v( 1, p ),& - 1,v( 1, q ), 1 ) + call stdlib${ii}$_daxpy( mvl,-t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,& + v( 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ),& + 1_${ik}$,v( 1_${ik}$, q ), 1_${ik}$ ) end if else - call stdlib_daxpy( m, t*apoaq,a( 1, p ), 1,a( 1,& - q ), 1 ) - call stdlib_daxpy( m,-cs*sn*aqoap,a( 1, q ), 1,& - a( 1, p ), 1 ) + call stdlib${ii}$_daxpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$,& + q ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( m,-cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,& + a( 1_${ik}$, p ), 1_${ik}$ ) work( p ) = work( p ) / cs work( q ) = work( q )*cs if( rsvec ) then - call stdlib_daxpy( mvl,t*apoaq, v( 1, p ),1, & - v( 1, q ), 1 ) - call stdlib_daxpy( mvl,-cs*sn*aqoap,v( 1, q )& - , 1,v( 1, p ), 1 ) + call stdlib${ii}$_daxpy( mvl,t*apoaq, v( 1_${ik}$, p ),1_${ik}$, & + v( 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q )& + , 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if end if end if @@ -63096,15 +63096,15 @@ module stdlib_linalg_lapack_d end if else ! .. have to use modified gram-schmidt like transformation - call stdlib_dcopy( m, a( 1, p ), 1,work( n+1 ), 1 ) - call stdlib_dlascl( 'G', 0, 0, aapp, one, m,1, work( n+1 ), & + call stdlib${ii}$_dcopy( m, a( 1_${ik}$, p ), 1_${ik}$,work( n+1 ), 1_${ik}$ ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one, m,1_${ik}$, work( n+1 ), & lda,ierr ) - call stdlib_dlascl( 'G', 0, 0, aaqq, one, m,1, a( 1, q ), & + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one, m,1_${ik}$, a( 1_${ik}$, q ), & lda, ierr ) temp1 = -aapq*work( p ) / work( q ) - call stdlib_daxpy( m, temp1, work( n+1 ), 1,a( 1, q ), 1 ) + call stdlib${ii}$_daxpy( m, temp1, work( n+1 ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) - call stdlib_dlascl( 'G', 0, 0, one, aaqq, m,1, a( 1, q ), & + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq, m,1_${ik}$, a( 1_${ik}$, q ), & lda, ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) @@ -63112,42 +63112,42 @@ module stdlib_linalg_lapack_d ! end if rotok then ... else ! in the case of cancellation in updating sva(q), sva(p) ! recompute sva(q), sva(p). - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_dnrm2( m, a( 1, q ), 1 )*work( q ) + sva( q ) = stdlib${ii}$_dnrm2( m, a( 1_${ik}$, q ), 1_${ik}$ )*work( q ) else t = zero aaqq = one - call stdlib_dlassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_dlassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq )*work( q ) end if end if if( ( aapp / aapp0 )<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_dnrm2( m, a( 1, p ), 1 )*work( p ) + aapp = stdlib${ii}$_dnrm2( m, a( 1_${ik}$, p ), 1_${ik}$ )*work( p ) else t = zero aapp = one - call stdlib_dlassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_dlassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp )*work( p ) end if sva( p ) = aapp end if else ! a(:,p) and a(:,q) already numerically orthogonal - if( ir1==0 )notrot = notrot + 1 + if( ir1==0_${ik}$ )notrot = notrot + 1_${ik}$ ! [rtd] skipped = skipped + 1 - pskipped = pskipped + 1 + pskipped = pskipped + 1_${ik}$ end if else ! a(:,q) is zero column - if( ir1==0 )notrot = notrot + 1 - pskipped = pskipped + 1 + if( ir1==0_${ik}$ )notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then - if( ir1==0 )aapp = -aapp - notrot = 0 + if( ir1==0_${ik}$ )aapp = -aapp + notrot = 0_${ik}$ go to 2103 end if end do loop_2002 @@ -63157,7 +63157,7 @@ module stdlib_linalg_lapack_d sva( p ) = aapp else sva( p ) = aapp - if( ( ir1==0 ) .and. ( aapp==zero ) )notrot = notrot + min( igl+kbl-1, & + if( ( ir1==0_${ik}$ ) .and. ( aapp==zero ) )notrot = notrot + min( igl+kbl-1, & n ) - p end if end do loop_2001 @@ -63166,15 +63166,15 @@ module stdlib_linalg_lapack_d end do loop_1002 ! end of ir1-loop ! ... go to the off diagonal blocks - igl = ( ibr-1 )*kbl + 1 + igl = ( ibr-1 )*kbl + 1_${ik}$ loop_2010: do jbc = ibr + 1, nbl - jgl = ( jbc-1 )*kbl + 1 + jgl = ( jbc-1 )*kbl + 1_${ik}$ ! doing the block at ( ibr, jbc ) - ijblsk = 0 + ijblsk = 0_${ik}$ loop_2100: do p = igl, min( igl+kbl-1, n ) aapp = sva( p ) if( aapp>zero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2200: do q = jgl, min( jgl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -63188,13 +63188,13 @@ module stdlib_linalg_lapack_d rotok = ( small*aaqq )<=aapp end if if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_ddot( m, a( 1, p ), 1, a( 1,q ), 1 )*work( & + aapq = ( stdlib${ii}$_ddot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*work( & p )*work( q ) /aaqq ) / aapp else - call stdlib_dcopy( m, a( 1, p ), 1,work( n+1 ), 1 ) - call stdlib_dlascl( 'G', 0, 0, aapp,work( p ), m, 1,work( n+& - 1 ), lda, ierr ) - aapq = stdlib_ddot( m, work( n+1 ), 1,a( 1, q ), 1 )*work( & + call stdlib${ii}$_dcopy( m, a( 1_${ik}$, p ), 1_${ik}$,work( n+1 ), 1_${ik}$ ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aapp,work( p ), m, 1_${ik}$,work( n+& + 1_${ik}$ ), lda, ierr ) + aapq = stdlib${ii}$_ddot( m, work( n+1 ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ )*work( & q ) / aaqq end if else @@ -63204,23 +63204,23 @@ module stdlib_linalg_lapack_d rotok = aaqq<=( aapp / small ) end if if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_ddot( m, a( 1, p ), 1, a( 1,q ), 1 )*work( & + aapq = ( stdlib${ii}$_ddot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*work( & p )*work( q ) /aaqq ) / aapp else - call stdlib_dcopy( m, a( 1, q ), 1,work( n+1 ), 1 ) - call stdlib_dlascl( 'G', 0, 0, aaqq,work( q ), m, 1,work( n+& - 1 ), lda, ierr ) - aapq = stdlib_ddot( m, work( n+1 ), 1,a( 1, p ), 1 )*work( & + call stdlib${ii}$_dcopy( m, a( 1_${ik}$, q ), 1_${ik}$,work( n+1 ), 1_${ik}$ ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq,work( q ), m, 1_${ik}$,work( n+& + 1_${ik}$ ), lda, ierr ) + aapq = stdlib${ii}$_ddot( m, work( n+1 ), 1_${ik}$,a( 1_${ik}$, p ), 1_${ik}$ )*work( & p ) / aapp end if end if mxaapq = max( mxaapq, abs( aapq ) ) ! to rotate or not to rotate, that is the question ... if( abs( aapq )>tol ) then - notrot = 0 + notrot = 0_${ik}$ ! [rtd] rotated = rotated + 1 - pskipped = 0 - iswrot = iswrot + 1 + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ if( rotok ) then aqoap = aaqq / aapp apoaq = aapp / aaqq @@ -63228,12 +63228,12 @@ module stdlib_linalg_lapack_d if( aaqq>aapp0 )theta = -theta if( abs( theta )>bigtheta ) then t = half / theta - fastr( 3 ) = t*work( p ) / work( q ) - fastr( 4 ) = -t*work( q ) /work( p ) - call stdlib_drotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) + fastr( 3_${ik}$ ) = t*work( p ) / work( q ) + fastr( 4_${ik}$ ) = -t*work( q ) /work( p ) + call stdlib${ii}$_drotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$, fastr ) - if( rsvec )call stdlib_drotm( mvl,v( 1, p ), 1,v( 1, q ),& - 1,fastr ) + if( rsvec )call stdlib${ii}$_drotm( mvl,v( 1_${ik}$, p ), 1_${ik}$,v( 1_${ik}$, q ),& + 1_${ik}$,fastr ) sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq ) ) @@ -63254,68 +63254,68 @@ module stdlib_linalg_lapack_d aqoap = work( q ) / work( p ) if( work( p )>=one ) then if( work( q )>=one ) then - fastr( 3 ) = t*apoaq - fastr( 4 ) = -t*aqoap + fastr( 3_${ik}$ ) = t*apoaq + fastr( 4_${ik}$ ) = -t*aqoap work( p ) = work( p )*cs work( q ) = work( q )*cs - call stdlib_drotm( m, a( 1, p ), 1,a( 1, q ), 1,& + call stdlib${ii}$_drotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$,& fastr ) - if( rsvec )call stdlib_drotm( mvl,v( 1, p ), 1, v( & - 1, q ),1, fastr ) + if( rsvec )call stdlib${ii}$_drotm( mvl,v( 1_${ik}$, p ), 1_${ik}$, v( & + 1_${ik}$, q ),1_${ik}$, fastr ) else - call stdlib_daxpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & - p ), 1 ) - call stdlib_daxpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & - 1, q ), 1 ) + call stdlib${ii}$_daxpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( 1_${ik}$, & + p ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( & + 1_${ik}$, q ), 1_${ik}$ ) if( rsvec ) then - call stdlib_daxpy( mvl, -t*aqoap,v( 1, q ), 1,v(& - 1, p ), 1 ) - call stdlib_daxpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& - v( 1, q ), 1 ) + call stdlib${ii}$_daxpy( mvl, -t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,v(& + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ), 1_${ik}$,& + v( 1_${ik}$, q ), 1_${ik}$ ) end if work( p ) = work( p )*cs work( q ) = work( q ) / cs end if else if( work( q )>=one ) then - call stdlib_daxpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & - ), 1 ) - call stdlib_daxpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) + call stdlib${ii}$_daxpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q & + ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( m, -cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) if( rsvec ) then - call stdlib_daxpy( mvl, t*apoaq,v( 1, p ), 1,v( & - 1, q ), 1 ) - call stdlib_daxpy( mvl,-cs*sn*aqoap,v( 1, q ), & - 1,v( 1, p ), 1 ) + call stdlib${ii}$_daxpy( mvl, t*apoaq,v( 1_${ik}$, p ), 1_${ik}$,v( & + 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q ), & + 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if work( p ) = work( p ) / cs work( q ) = work( q )*cs else if( work( p )>=work( q ) )then - call stdlib_daxpy( m, -t*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) - call stdlib_daxpy( m, cs*sn*apoaq,a( 1, p ), 1,& - a( 1, q ), 1 ) + call stdlib${ii}$_daxpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,& + a( 1_${ik}$, q ), 1_${ik}$ ) work( p ) = work( p )*cs work( q ) = work( q ) / cs if( rsvec ) then - call stdlib_daxpy( mvl,-t*aqoap,v( 1, q ), 1,& - v( 1, p ), 1 ) - call stdlib_daxpy( mvl,cs*sn*apoaq,v( 1, p ),& - 1,v( 1, q ), 1 ) + call stdlib${ii}$_daxpy( mvl,-t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,& + v( 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ),& + 1_${ik}$,v( 1_${ik}$, q ), 1_${ik}$ ) end if else - call stdlib_daxpy( m, t*apoaq,a( 1, p ), 1,a( 1,& - q ), 1 ) - call stdlib_daxpy( m,-cs*sn*aqoap,a( 1, q ), 1,& - a( 1, p ), 1 ) + call stdlib${ii}$_daxpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$,& + q ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( m,-cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,& + a( 1_${ik}$, p ), 1_${ik}$ ) work( p ) = work( p ) / cs work( q ) = work( q )*cs if( rsvec ) then - call stdlib_daxpy( mvl,t*apoaq, v( 1, p ),1, & - v( 1, q ), 1 ) - call stdlib_daxpy( mvl,-cs*sn*aqoap,v( 1, q )& - , 1,v( 1, p ), 1 ) + call stdlib${ii}$_daxpy( mvl,t*apoaq, v( 1_${ik}$, p ),1_${ik}$, & + v( 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_daxpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q )& + , 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if end if end if @@ -63323,30 +63323,30 @@ module stdlib_linalg_lapack_d end if else if( aapp>aaqq ) then - call stdlib_dcopy( m, a( 1, p ), 1,work( n+1 ), 1 ) + call stdlib${ii}$_dcopy( m, a( 1_${ik}$, p ), 1_${ik}$,work( n+1 ), 1_${ik}$ ) - call stdlib_dlascl( 'G', 0, 0, aapp, one,m, 1, work( n+1 & + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, work( n+1 & ), lda,ierr ) - call stdlib_dlascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) temp1 = -aapq*work( p ) / work( q ) - call stdlib_daxpy( m, temp1, work( n+1 ),1, a( 1, q ), 1 & + call stdlib${ii}$_daxpy( m, temp1, work( n+1 ),1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ & ) - call stdlib_dlascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) else - call stdlib_dcopy( m, a( 1, q ), 1,work( n+1 ), 1 ) + call stdlib${ii}$_dcopy( m, a( 1_${ik}$, q ), 1_${ik}$,work( n+1 ), 1_${ik}$ ) - call stdlib_dlascl( 'G', 0, 0, aaqq, one,m, 1, work( n+1 & + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, work( n+1 & ), lda,ierr ) - call stdlib_dlascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) temp1 = -aapq*work( q ) / work( p ) - call stdlib_daxpy( m, temp1, work( n+1 ),1, a( 1, p ), 1 & + call stdlib${ii}$_daxpy( m, temp1, work( n+1 ),1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ & ) - call stdlib_dlascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, one, aapp,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) sva( p ) = aapp*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) @@ -63355,48 +63355,48 @@ module stdlib_linalg_lapack_d ! end if rotok then ... else ! in the case of cancellation in updating sva(q) ! .. recompute sva(q) - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_dnrm2( m, a( 1, q ), 1 )*work( q ) + sva( q ) = stdlib${ii}$_dnrm2( m, a( 1_${ik}$, q ), 1_${ik}$ )*work( q ) else t = zero aaqq = one - call stdlib_dlassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_dlassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq )*work( q ) end if end if - if( ( aapp / aapp0 )**2<=rooteps ) then + if( ( aapp / aapp0 )**2_${ik}$<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_dnrm2( m, a( 1, p ), 1 )*work( p ) + aapp = stdlib${ii}$_dnrm2( m, a( 1_${ik}$, p ), 1_${ik}$ )*work( p ) else t = zero aapp = one - call stdlib_dlassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_dlassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp )*work( p ) end if sva( p ) = aapp end if ! end of ok rotation else - notrot = notrot + 1 + notrot = notrot + 1_${ik}$ ! [rtd] skipped = skipped + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if else - notrot = notrot + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if if( ( i<=swband ) .and. ( ijblsk>=blskip ) )then sva( p ) = aapp - notrot = 0 + notrot = 0_${ik}$ go to 2011 end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then aapp = -aapp - notrot = 0 + notrot = 0_${ik}$ go to 2203 end if end do loop_2200 @@ -63404,8 +63404,8 @@ module stdlib_linalg_lapack_d 2203 continue sva( p ) = aapp else - if( aapp==zero )notrot = notrot +min( jgl+kbl-1, n ) - jgl + 1 - if( aapprootsfmin ) )then - sva( n ) = stdlib_dnrm2( m, a( 1, n ), 1 )*work( n ) + sva( n ) = stdlib${ii}$_dnrm2( m, a( 1_${ik}$, n ), 1_${ik}$ )*work( n ) else t = zero aapp = one - call stdlib_dlassq( m, a( 1, n ), 1, t, aapp ) + call stdlib${ii}$_dlassq( m, a( 1_${ik}$, n ), 1_${ik}$, t, aapp ) sva( n ) = t*sqrt( aapp )*work( n ) end if ! additional steering devices @@ -63438,20 +63438,20 @@ module stdlib_linalg_lapack_d end do loop_1993 ! end i=1:nsweep loop ! #:( reaching this point means that the procedure has not converged. - info = nsweep - 1 + info = nsweep - 1_${ik}$ go to 1995 1994 continue ! #:) reaching this point means numerical convergence after the i-th ! sweep. - info = 0 + info = 0_${ik}$ ! #:) info = 0 confirms successful iterations. 1995 continue ! sort the singular values and find how many are above ! the underflow threshold. - n2 = 0 - n4 = 0 + n2 = 0_${ik}$ + n4 = 0_${ik}$ do p = 1, n - 1 - q = stdlib_idamax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib${ii}$_idamax( n-p+1, sva( p ), 1_${ik}$ ) + p - 1_${ik}$ if( p/=q ) then temp1 = sva( p ) sva( p ) = sva( q ) @@ -63459,68 +63459,68 @@ module stdlib_linalg_lapack_d temp1 = work( p ) work( p ) = work( q ) work( q ) = temp1 - call stdlib_dswap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_dswap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) + call stdlib${ii}$_dswap( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) + if( rsvec )call stdlib${ii}$_dswap( mvl, v( 1_${ik}$, p ), 1_${ik}$, v( 1_${ik}$, q ), 1_${ik}$ ) end if if( sva( p )/=zero ) then - n4 = n4 + 1 - if( sva( p )*skl>sfmin )n2 = n2 + 1 + n4 = n4 + 1_${ik}$ + if( sva( p )*skl>sfmin )n2 = n2 + 1_${ik}$ end if end do if( sva( n )/=zero ) then - n4 = n4 + 1 - if( sva( n )*skl>sfmin )n2 = n2 + 1 + n4 = n4 + 1_${ik}$ + if( sva( n )*skl>sfmin )n2 = n2 + 1_${ik}$ end if ! normalize the left singular vectors. if( lsvec .or. uctol ) then do p = 1, n2 - call stdlib_dscal( m, work( p ) / sva( p ), a( 1, p ), 1 ) + call stdlib${ii}$_dscal( m, work( p ) / sva( p ), a( 1_${ik}$, p ), 1_${ik}$ ) end do end if ! scale the product of jacobi rotations (assemble the fast rotations). if( rsvec ) then if( applv ) then do p = 1, n - call stdlib_dscal( mvl, work( p ), v( 1, p ), 1 ) + call stdlib${ii}$_dscal( mvl, work( p ), v( 1_${ik}$, p ), 1_${ik}$ ) end do else do p = 1, n - temp1 = one / stdlib_dnrm2( mvl, v( 1, p ), 1 ) - call stdlib_dscal( mvl, temp1, v( 1, p ), 1 ) + temp1 = one / stdlib${ii}$_dnrm2( mvl, v( 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_dscal( mvl, temp1, v( 1_${ik}$, p ), 1_${ik}$ ) end do end if end if ! undo scaling, if necessary (and possible). - if( ( ( skl>one ) .and. ( sva( 1 )<( big / skl) ) ).or. ( ( skl( sfmin / skl) ) ) ) then + if( ( ( skl>one ) .and. ( sva( 1_${ik}$ )<( big / skl) ) ).or. ( ( skl( sfmin / skl) ) ) ) then do p = 1, n sva( p ) = skl*sva( p ) end do skl= one end if - work( 1 ) = skl + work( 1_${ik}$ ) = skl ! the singular values of a are skl*sva(1:n). if skl/=one ! then some of the singular values may overflow or underflow and ! the spectrum is given in this factored representation. - work( 2 ) = real( n4,KIND=dp) + work( 2_${ik}$ ) = real( n4,KIND=dp) ! n4 is the number of computed nonzero singular values of a. - work( 3 ) = real( n2,KIND=dp) + work( 3_${ik}$ ) = real( n2,KIND=dp) ! n2 is the number of singular values of a greater than sfmin. ! if n20 ) then + info = -11_${ik}$ + else if( n>0_${ik}$ ) then rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) else rowcnd = one end if end if - if( colequ .and. info==0 ) then + if( colequ .and. info==0_${ik}$ ) then rcmin = bignum rcmax = zero do j = 1, n @@ -63607,31 +63607,31 @@ module stdlib_linalg_lapack_d rcmax = max( rcmax, c( j ) ) end do if( rcmin<=zero ) then - info = -12 - else if( n>0 ) then + info = -12_${ik}$ + else if( n>0_${ik}$ ) then colcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) else colcnd = one end if end if - if( info==0 ) then - if( ldb0 ) then + if( info>0_${ik}$ ) then ! compute the reciprocal pivot growth factor of the ! leading rank-deficient info columns of a. - rpvgrw = stdlib_dlantr( 'M', 'U', 'N', info, info, af, ldaf,work ) + rpvgrw = stdlib${ii}$_dlantr( 'M', 'U', 'N', info, info, af, ldaf,work ) if( rpvgrw==zero ) then rpvgrw = one else - rpvgrw = stdlib_dlange( 'M', n, info, a, lda, work ) / rpvgrw + rpvgrw = stdlib${ii}$_dlange( 'M', n, info, a, lda, work ) / rpvgrw end if - work( 1 ) = rpvgrw + work( 1_${ik}$ ) = rpvgrw rcond = zero return end if @@ -63678,21 +63678,21 @@ module stdlib_linalg_lapack_d else norm = 'I' end if - anorm = stdlib_dlange( norm, n, n, a, lda, work ) - rpvgrw = stdlib_dlantr( 'M', 'U', 'N', n, n, af, ldaf, work ) + anorm = stdlib${ii}$_dlange( norm, n, n, a, lda, work ) + rpvgrw = stdlib${ii}$_dlantr( 'M', 'U', 'N', n, n, af, ldaf, work ) if( rpvgrw==zero ) then rpvgrw = one else - rpvgrw = stdlib_dlange( 'M', n, n, a, lda, work ) / rpvgrw + rpvgrw = stdlib${ii}$_dlange( 'M', n, n, a, lda, work ) / rpvgrw end if ! compute the reciprocal of the condition number of a. - call stdlib_dgecon( norm, n, af, ldaf, anorm, rcond, work, iwork, info ) + call stdlib${ii}$_dgecon( norm, n, af, ldaf, anorm, rcond, work, iwork, info ) ! compute the solution matrix x. - call stdlib_dlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_dgetrs( trans, n, nrhs, af, ldaf, ipiv, x, ldx, info ) + call stdlib${ii}$_dlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_dgetrs( trans, n, nrhs, af, ldaf, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_dgerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & + call stdlib${ii}$_dgerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & work, iwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -63717,14 +63717,14 @@ module stdlib_linalg_lapack_d ferr( j ) = ferr( j ) / rowcnd end do end if - work( 1 ) = rpvgrw + work( 1_${ik}$ ) = rpvgrw ! set info = n+1 if the matrix is singular to working precision. - if( rcond0 )then - minwrk = max( 8*n, 6*n + 16 ) - maxwrk = minwrk - n +n*stdlib_ilaenv( 1, 'DGEQRF', ' ', n, 1, n, 0 ) - maxwrk = max( maxwrk, minwrk - n +n*stdlib_ilaenv( 1, 'DORMQR', ' ', n, 1, n, -1 & + ! following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + if( n>0_${ik}$ )then + minwrk = max( 8_${ik}$*n, 6_${ik}$*n + 16_${ik}$ ) + maxwrk = minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) + maxwrk = max( maxwrk, minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', ' ', n, 1_${ik}$, n, -1_${ik}$ & ) ) if( ilvsl ) then - maxwrk = max( maxwrk, minwrk - n +n*stdlib_ilaenv( 1, 'DORGQR', ' ', n, 1, n, & - -1 ) ) + maxwrk = max( maxwrk, minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGQR', ' ', n, 1_${ik}$, n, & + -1_${ik}$ ) ) end if else - minwrk = 1 - maxwrk = 1 + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ end if - work( 1 ) = maxwrk - if( lworkzero .and. anrmzero .and. bnrm1 ) then - call stdlib_dlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& + call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vsl, ldvsl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_dlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& , ldvsl ) end if - call stdlib_dorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & + call stdlib${ii}$_dorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vsr - if( ilvsr )call stdlib_dlaset( 'FULL', n, n, zero, one, vsr, ldvsr ) + if( ilvsr )call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vsr, ldvsr ) ! reduce to generalized hessenberg form ! (workspace: none needed) - call stdlib_dgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& + call stdlib${ii}$_dgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& ierr ) ! perform qz algorithm, computing schur vectors if desired ! (workspace: need n) iwrk = itau - call stdlib_dhgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & + call stdlib${ii}$_dhgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 50 end if ! sort eigenvalues alpha/beta if desired ! (workspace: need 4*n+16 ) - sdim = 0 + sdim = 0_${ik}$ if( wantst ) then ! undo scaling on eigenvalues before selctging if( ilascl ) then - call stdlib_dlascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n,ierr ) - call stdlib_dlascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n,ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n,ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n,ierr ) end if - if( ilbscl )call stdlib_dlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + if( ilbscl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) ! select eigenvalues do i = 1, n bwork( i ) = selctg( alphar( i ), alphai( i ), beta( i ) ) end do - call stdlib_dtgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, & - vsl, ldvsl, vsr, ldvsr, sdim, pvsl,pvsr, dif, work( iwrk ), lwork-iwrk+1, idum, 1,& + call stdlib${ii}$_dtgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, & + vsl, ldvsl, vsr, ldvsr, sdim, pvsl,pvsr, dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$,& ierr ) - if( ierr==1 )info = n + 3 + if( ierr==1_${ik}$ )info = n + 3_${ik}$ end if ! apply back-permutation to vsl and vsr ! (workspace: none needed) - if( ilvsl )call stdlib_dggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, & + if( ilvsl )call stdlib${ii}$_dggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, & vsl, ldvsl, ierr ) - if( ilvsr )call stdlib_dggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, & + if( ilvsr )call stdlib${ii}$_dggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, & vsr, ldvsr, ierr ) ! check if unscaling would cause over/underflow, if so, rescale ! (alphar(i),alphai(i),beta(i)) so beta(i) is on the order of @@ -63971,16 +63971,16 @@ module stdlib_linalg_lapack_d if( alphai( i )/=zero ) then if( ( alphar( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphar( i ) )>( & anrm / anrmto ) ) then - work( 1 ) = abs( a( i, i ) / alphar( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( a( i, i ) / alphar( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) else if( ( alphai( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphai( i )& )>( anrm / anrmto ) )then - work( 1 ) = abs( a( i, i+1 ) / alphai( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( a( i, i+1 ) / alphai( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) end if end if end do @@ -63990,47 +63990,47 @@ module stdlib_linalg_lapack_d if( alphai( i )/=zero ) then if( ( beta( i ) / safmax )>( bnrmto / bnrm ) .or.( safmin / beta( i ) )>( & bnrm / bnrmto ) ) then - work( 1 ) = abs( b( i, i ) / beta( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( b( i, i ) / beta( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) end if end if end do end if ! undo scaling if( ilascl ) then - call stdlib_dlascl( 'H', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) - call stdlib_dlascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr ) - call stdlib_dlascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr ) + call stdlib${ii}$_dlascl( 'H', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr ) end if if( ilbscl ) then - call stdlib_dlascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) - call stdlib_dlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + call stdlib${ii}$_dlascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) end if if( wantst ) then ! check if reordering is correct lastsl = .true. lst2sl = .true. - sdim = 0 - ip = 0 + sdim = 0_${ik}$ + ip = 0_${ik}$ do i = 1, n cursl = selctg( alphar( i ), alphai( i ), beta( i ) ) if( alphai( i )==zero ) then - if( cursl )sdim = sdim + 1 - ip = 0 - if( cursl .and. .not.lastsl )info = n + 2 + if( cursl )sdim = sdim + 1_${ik}$ + ip = 0_${ik}$ + if( cursl .and. .not.lastsl )info = n + 2_${ik}$ else - if( ip==1 ) then + if( ip==1_${ik}$ ) then ! last eigenvalue of conjugate pair cursl = cursl .or. lastsl lastsl = cursl - if( cursl )sdim = sdim + 2 - ip = -1 - if( cursl .and. .not.lst2sl )info = n + 2 + if( cursl )sdim = sdim + 2_${ik}$ + ip = -1_${ik}$ + if( cursl .and. .not.lst2sl )info = n + 2_${ik}$ else ! first eigenvalue of conjugate pair - ip = 1 + ip = 1_${ik}$ end if end if lst2sl = lastsl @@ -64038,12 +64038,12 @@ module stdlib_linalg_lapack_d end do end if 50 continue - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_dgges + end subroutine stdlib${ii}$_dgges - subroutine stdlib_dggesx( jobvsl, jobvsr, sort, selctg, sense, n, a, lda,b, ldb, sdim, & + subroutine stdlib${ii}$_dggesx( jobvsl, jobvsr, sort, selctg, sense, n, a, lda,b, ldb, sdim, & !! DGGESX computes for a pair of N-by-N real nonsymmetric matrices !! (A,B), the generalized eigenvalues, the real Schur form (S,T), and, !! optionally, the left and/or right matrices of Schur vectors (VSL and @@ -64079,13 +64079,13 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvsl, jobvsr, sense, sort - integer(ilp), intent(out) :: info, sdim - integer(ilp), intent(in) :: lda, ldb, ldvsl, ldvsr, liwork, lwork, n + integer(${ik}$), intent(out) :: info, sdim + integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, liwork, lwork, n ! Array Arguments logical(lk), intent(out) :: bwork(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(inout) :: a(lda,*), b(ldb,*) - real(dp), intent(out) :: alphai(*), alphar(*), beta(*), rconde(2), rcondv(2), vsl(& + real(dp), intent(out) :: alphai(*), alphar(*), beta(*), rconde(2_${ik}$), rcondv(2_${ik}$), vsl(& ldvsl,*), vsr(ldvsr,*), work(*) ! Function Arguments procedure(stdlib_selctg_d) :: selctg @@ -64094,34 +64094,34 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, lst2sl, wantsb, & wantse, wantsn, wantst, wantsv - integer(ilp) :: i, icols, ierr, ihi, ijob, ijobvl, ijobvr, ileft, ilo, ip, iright, & + integer(${ik}$) :: i, icols, ierr, ihi, ijob, ijobvl, ijobvr, ileft, ilo, ip, iright, & irows, itau, iwrk, liwmin, lwrk, maxwrk, minwrk real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pl, pr, safmax, safmin, & smlnum ! Local Arrays - real(dp) :: dif(2) + real(dp) :: dif(2_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvsl, 'N' ) ) then - ijobvl = 1 + ijobvl = 1_${ik}$ ilvsl = .false. else if( stdlib_lsame( jobvsl, 'V' ) ) then - ijobvl = 2 + ijobvl = 2_${ik}$ ilvsl = .true. else - ijobvl = -1 + ijobvl = -1_${ik}$ ilvsl = .false. end if if( stdlib_lsame( jobvsr, 'N' ) ) then - ijobvr = 1 + ijobvr = 1_${ik}$ ilvsr = .false. else if( stdlib_lsame( jobvsr, 'V' ) ) then - ijobvr = 2 + ijobvr = 2_${ik}$ ilvsr = .true. else - ijobvr = -1 + ijobvr = -1_${ik}$ ilvsr = .false. end if wantst = stdlib_lsame( sort, 'S' ) @@ -64129,94 +64129,94 @@ module stdlib_linalg_lapack_d wantse = stdlib_lsame( sense, 'E' ) wantsv = stdlib_lsame( sense, 'V' ) wantsb = stdlib_lsame( sense, 'B' ) - lquery = ( lwork==-1 .or. liwork==-1 ) + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) if( wantsn ) then - ijob = 0 + ijob = 0_${ik}$ else if( wantse ) then - ijob = 1 + ijob = 1_${ik}$ else if( wantsv ) then - ijob = 2 + ijob = 2_${ik}$ else if( wantsb ) then - ijob = 4 + ijob = 4_${ik}$ end if ! test the input arguments - info = 0 - if( ijobvl<=0 ) then - info = -1 - else if( ijobvr<=0 ) then - info = -2 + info = 0_${ik}$ + if( ijobvl<=0_${ik}$ ) then + info = -1_${ik}$ + else if( ijobvr<=0_${ik}$ ) then + info = -2_${ik}$ else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then - info = -3 + info = -3_${ik}$ else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. & .not.wantsn ) ) then - info = -5 - else if( n<0 ) then - info = -6 - else if( lda0) then - minwrk = max( 8*n, 6*n + 16 ) - maxwrk = minwrk - n +n*stdlib_ilaenv( 1, 'DGEQRF', ' ', n, 1, n, 0 ) - maxwrk = max( maxwrk, minwrk - n +n*stdlib_ilaenv( 1, 'DORMQR', ' ', n, 1, n, -1 & + ! following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + if( n>0_${ik}$) then + minwrk = max( 8_${ik}$*n, 6_${ik}$*n + 16_${ik}$ ) + maxwrk = minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) + maxwrk = max( maxwrk, minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', ' ', n, 1_${ik}$, n, -1_${ik}$ & ) ) if( ilvsl ) then - maxwrk = max( maxwrk, minwrk - n +n*stdlib_ilaenv( 1, 'DORGQR', ' ', n, 1, n, & - -1 ) ) + maxwrk = max( maxwrk, minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGQR', ' ', n, 1_${ik}$, n, & + -1_${ik}$ ) ) end if lwrk = maxwrk - if( ijob>=1 )lwrk = max( lwrk, n*n/2 ) + if( ijob>=1_${ik}$ )lwrk = max( lwrk, n*n/2_${ik}$ ) else - minwrk = 1 - maxwrk = 1 - lwrk = 1 + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + lwrk = 1_${ik}$ end if - work( 1 ) = lwrk - if( wantsn .or. n==0 ) then - liwmin = 1 + work( 1_${ik}$ ) = lwrk + if( wantsn .or. n==0_${ik}$ ) then + liwmin = 1_${ik}$ else - liwmin = n + 6 + liwmin = n + 6_${ik}$ end if - iwork( 1 ) = liwmin + iwork( 1_${ik}$ ) = liwmin if( lworkzero .and. anrmzero .and. bnrm1 ) then - call stdlib_dlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& + call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vsl, ldvsl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_dlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& , ldvsl ) end if - call stdlib_dorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & + call stdlib${ii}$_dorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vsr - if( ilvsr )call stdlib_dlaset( 'FULL', n, n, zero, one, vsr, ldvsr ) + if( ilvsr )call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vsr, ldvsr ) ! reduce to generalized hessenberg form ! (workspace: none needed) - call stdlib_dgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& + call stdlib${ii}$_dgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& ierr ) - sdim = 0 + sdim = 0_${ik}$ ! perform qz algorithm, computing schur vectors if desired ! (workspace: need n) iwrk = itau - call stdlib_dhgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & + call stdlib${ii}$_dhgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 60 end if @@ -64296,10 +64296,10 @@ module stdlib_linalg_lapack_d if( wantst ) then ! undo scaling on eigenvalues before selctging if( ilascl ) then - call stdlib_dlascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n,ierr ) - call stdlib_dlascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n,ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n,ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n,ierr ) end if - if( ilbscl )call stdlib_dlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + if( ilbscl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) ! select eigenvalues do i = 1, n @@ -64307,30 +64307,30 @@ module stdlib_linalg_lapack_d end do ! reorder eigenvalues, transform generalized schur vectors, and ! compute reciprocal condition numbers - call stdlib_dtgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alphar, alphai, & + call stdlib${ii}$_dtgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alphar, alphai, & beta, vsl, ldvsl, vsr, ldvsr,sdim, pl, pr, dif, work( iwrk ), lwork-iwrk+1,iwork, & liwork, ierr ) - if( ijob>=1 )maxwrk = max( maxwrk, 2*sdim*( n-sdim ) ) - if( ierr==-22 ) then + if( ijob>=1_${ik}$ )maxwrk = max( maxwrk, 2_${ik}$*sdim*( n-sdim ) ) + if( ierr==-22_${ik}$ ) then ! not enough real workspace - info = -22 + info = -22_${ik}$ else - if( ijob==1 .or. ijob==4 ) then - rconde( 1 ) = pl - rconde( 2 ) = pr + if( ijob==1_${ik}$ .or. ijob==4_${ik}$ ) then + rconde( 1_${ik}$ ) = pl + rconde( 2_${ik}$ ) = pr end if - if( ijob==2 .or. ijob==4 ) then - rcondv( 1 ) = dif( 1 ) - rcondv( 2 ) = dif( 2 ) + if( ijob==2_${ik}$ .or. ijob==4_${ik}$ ) then + rcondv( 1_${ik}$ ) = dif( 1_${ik}$ ) + rcondv( 2_${ik}$ ) = dif( 2_${ik}$ ) end if - if( ierr==1 )info = n + 3 + if( ierr==1_${ik}$ )info = n + 3_${ik}$ end if end if ! apply permutation to vsl and vsr ! (workspace: none needed) - if( ilvsl )call stdlib_dggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, & + if( ilvsl )call stdlib${ii}$_dggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, & vsl, ldvsl, ierr ) - if( ilvsr )call stdlib_dggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, & + if( ilvsr )call stdlib${ii}$_dggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, & vsr, ldvsr, ierr ) ! check if unscaling would cause over/underflow, if so, rescale ! (alphar(i),alphai(i),beta(i)) so beta(i) is on the order of @@ -64340,16 +64340,16 @@ module stdlib_linalg_lapack_d if( alphai( i )/=zero ) then if( ( alphar( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphar( i ) )>( & anrm / anrmto ) ) then - work( 1 ) = abs( a( i, i ) / alphar( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( a( i, i ) / alphar( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) else if( ( alphai( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphai( i )& )>( anrm / anrmto ) )then - work( 1 ) = abs( a( i, i+1 ) / alphai( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( a( i, i+1 ) / alphai( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) end if end if end do @@ -64359,47 +64359,47 @@ module stdlib_linalg_lapack_d if( alphai( i )/=zero ) then if( ( beta( i ) / safmax )>( bnrmto / bnrm ) .or.( safmin / beta( i ) )>( & bnrm / bnrmto ) ) then - work( 1 ) = abs( b( i, i ) / beta( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( b( i, i ) / beta( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) end if end if end do end if ! undo scaling if( ilascl ) then - call stdlib_dlascl( 'H', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) - call stdlib_dlascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr ) - call stdlib_dlascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr ) + call stdlib${ii}$_dlascl( 'H', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr ) end if if( ilbscl ) then - call stdlib_dlascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) - call stdlib_dlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + call stdlib${ii}$_dlascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) end if if( wantst ) then ! check if reordering is correct lastsl = .true. lst2sl = .true. - sdim = 0 - ip = 0 + sdim = 0_${ik}$ + ip = 0_${ik}$ do i = 1, n cursl = selctg( alphar( i ), alphai( i ), beta( i ) ) if( alphai( i )==zero ) then - if( cursl )sdim = sdim + 1 - ip = 0 - if( cursl .and. .not.lastsl )info = n + 2 + if( cursl )sdim = sdim + 1_${ik}$ + ip = 0_${ik}$ + if( cursl .and. .not.lastsl )info = n + 2_${ik}$ else - if( ip==1 ) then + if( ip==1_${ik}$ ) then ! last eigenvalue of conjugate pair cursl = cursl .or. lastsl lastsl = cursl - if( cursl )sdim = sdim + 2 - ip = -1 - if( cursl .and. .not.lst2sl )info = n + 2 + if( cursl )sdim = sdim + 2_${ik}$ + ip = -1_${ik}$ + if( cursl .and. .not.lst2sl )info = n + 2_${ik}$ else ! first eigenvalue of conjugate pair - ip = 1 + ip = 1_${ik}$ end if end if lst2sl = lastsl @@ -64407,13 +64407,13 @@ module stdlib_linalg_lapack_d end do end if 60 continue - work( 1 ) = maxwrk - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = maxwrk + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_dggesx + end subroutine stdlib${ii}$_dggesx - subroutine stdlib_dggev( jobvl, jobvr, n, a, lda, b, ldb, alphar, alphai,beta, vl, ldvl, vr, & + subroutine stdlib${ii}$_dggev( jobvl, jobvr, n, a, lda, b, ldb, alphar, alphai,beta, vl, ldvl, vr, & !! DGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B) !! the generalized eigenvalues, and optionally, the left and/or right !! generalized eigenvectors. @@ -64435,8 +64435,8 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvl, jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n ! Array Arguments real(dp), intent(inout) :: a(lda,*), b(ldb,*) real(dp), intent(out) :: alphai(*), alphar(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*) @@ -64446,75 +64446,75 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery character :: chtemp - integer(ilp) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, itau, & + integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, itau, & iwrk, jc, jr, maxwrk, minwrk real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp ! Local Arrays - logical(lk) :: ldumma(1) + logical(lk) :: ldumma(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvl, 'N' ) ) then - ijobvl = 1 + ijobvl = 1_${ik}$ ilvl = .false. else if( stdlib_lsame( jobvl, 'V' ) ) then - ijobvl = 2 + ijobvl = 2_${ik}$ ilvl = .true. else - ijobvl = -1 + ijobvl = -1_${ik}$ ilvl = .false. end if if( stdlib_lsame( jobvr, 'N' ) ) then - ijobvr = 1 + ijobvr = 1_${ik}$ ilvr = .false. else if( stdlib_lsame( jobvr, 'V' ) ) then - ijobvr = 2 + ijobvr = 2_${ik}$ ilvr = .true. else - ijobvr = -1 + ijobvr = -1_${ik}$ ilvr = .false. end if ilv = ilvl .or. ilvr ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( ijobvl<=0 ) then - info = -1 - else if( ijobvr<=0 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldazero .and. anrmzero .and. bnrm1 ) then - call stdlib_dlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& + call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vl, ldvl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_dlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& ldvl ) end if - call stdlib_dorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & + call stdlib${ii}$_dorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vr - if( ilvr )call stdlib_dlaset( 'FULL', n, n, zero, one, vr, ldvr ) + if( ilvr )call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vr, ldvr ) ! reduce to generalized hessenberg form ! (workspace: none needed) if( ilv ) then ! eigenvectors requested -- work on whole matrix. - call stdlib_dgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib${ii}$_dgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & ierr ) else - call stdlib_dgghrd( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & + call stdlib${ii}$_dgghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & ldb, vl, ldvl, vr, ldvr, ierr ) end if ! perform qz algorithm (compute eigenvalues, and optionally, the @@ -64605,15 +64605,15 @@ module stdlib_linalg_lapack_d else chtemp = 'E' end if - call stdlib_dhgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & + call stdlib${ii}$_dhgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & beta, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 110 end if @@ -64629,16 +64629,16 @@ module stdlib_linalg_lapack_d else chtemp = 'R' end if - call stdlib_dtgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & + call stdlib${ii}$_dtgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & in, work( iwrk ), ierr ) - if( ierr/=0 ) then - info = n + 2 + if( ierr/=0_${ik}$ ) then + info = n + 2_${ik}$ go to 110 end if ! undo balancing on vl and vr and normalization ! (workspace: none needed) if( ilvl ) then - call stdlib_dggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, & + call stdlib${ii}$_dggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, & ldvl, ierr ) loop_50: do jc = 1, n if( alphai( jc )zero .and. anrmzero .and. bnrm1 ) then - call stdlib_dlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& + call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vl, ldvl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_dlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& ldvl ) end if - call stdlib_dorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & + call stdlib${ii}$_dorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if - if( ilvr )call stdlib_dlaset( 'FULL', n, n, zero, one, vr, ldvr ) + if( ilvr )call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vr, ldvr ) ! reduce to generalized hessenberg form ! (workspace: none needed) if( ilv .or. .not.wantsn ) then ! eigenvectors requested -- work on whole matrix. - call stdlib_dgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib${ii}$_dgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & ierr ) else - call stdlib_dgghrd( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & + call stdlib${ii}$_dgghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & ldb, vl, ldvl, vr, ldvr, ierr ) end if ! perform qz algorithm (compute eigenvalues, and optionally, the @@ -64950,21 +64950,21 @@ module stdlib_linalg_lapack_d else chtemp = 'E' end if - call stdlib_dhgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & + call stdlib${ii}$_dhgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & beta, vl, ldvl, vr, ldvr, work,lwork, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 130 end if ! compute eigenvectors and estimate condition numbers if desired - ! (workspace: stdlib_dtgevc: need 6*n - ! stdlib_dtgsna: need 2*n*(n+2)+16 if sense = 'v' or 'b', + ! (workspace: stdlib${ii}$_dtgevc: need 6*n + ! stdlib${ii}$_dtgsna: need 2*n*(n+2)+16 if sense = 'v' or 'b', ! need n otherwise ) if( ilv .or. .not.wantsn ) then if( ilv ) then @@ -64977,16 +64977,16 @@ module stdlib_linalg_lapack_d else chtemp = 'R' end if - call stdlib_dtgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,& + call stdlib${ii}$_dtgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,& in, work, ierr ) - if( ierr/=0 ) then - info = n + 2 + if( ierr/=0_${ik}$ ) then + info = n + 2_${ik}$ go to 130 end if end if if( .not.wantsn ) then - ! compute eigenvectors (stdlib_dtgevc) and estimate condition - ! numbers (stdlib_dtgsna). note that the definition of the condition + ! compute eigenvectors (stdlib${ii}$_dtgevc) and estimate condition + ! numbers (stdlib${ii}$_dtgsna). note that the definition of the condition ! number is not invariant under transformation (u,v) to ! (q*u, z*v), where (u,v) are eigenvectors of the generalized ! schur form (s,t), q and z are orthogonal matrices. in order @@ -64998,35 +64998,35 @@ module stdlib_linalg_lapack_d pair = .false. cycle loop_20 end if - mm = 1 + mm = 1_${ik}$ if( in ) then - info = -2 - else if( p<0 .or. pn ) then + info = -2_${ik}$ + else if( p<0_${ik}$ .or. pm ) then - call stdlib_dtrtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', n-m, 1,b( m+1, m+p-n+1 ), & + call stdlib${ii}$_dtrtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', n-m, 1_${ik}$,b( m+1, m+p-n+1 ), & ldb, d( m+1 ), n-m, info ) - if( info>0 ) then - info = 1 + if( info>0_${ik}$ ) then + info = 1_${ik}$ return end if - call stdlib_dcopy( n-m, d( m+1 ), 1, y( m+p-n+1 ), 1 ) + call stdlib${ii}$_dcopy( n-m, d( m+1 ), 1_${ik}$, y( m+p-n+1 ), 1_${ik}$ ) end if ! set y1 = 0 do i = 1, m + p - n y( i ) = zero end do ! update d1 = d1 - t12*y2 - call stdlib_dgemv( 'NO TRANSPOSE', m, n-m, -one, b( 1, m+p-n+1 ), ldb,y( m+p-n+1 ), 1, & - one, d, 1 ) + call stdlib${ii}$_dgemv( 'NO TRANSPOSE', m, n-m, -one, b( 1_${ik}$, m+p-n+1 ), ldb,y( m+p-n+1 ), 1_${ik}$, & + one, d, 1_${ik}$ ) ! solve triangular system: r11*x = d1 - if( m>0 ) then - call stdlib_dtrtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', m, 1, a, lda,d, m, info ) + if( m>0_${ik}$ ) then + call stdlib${ii}$_dtrtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', m, 1_${ik}$, a, lda,d, m, info ) - if( info>0 ) then - info = 2 + if( info>0_${ik}$ ) then + info = 2_${ik}$ return end if ! copy d to x - call stdlib_dcopy( m, d, 1, x, 1 ) + call stdlib${ii}$_dcopy( m, d, 1_${ik}$, x, 1_${ik}$ ) end if ! backward transformation y = z**t *y - call stdlib_dormrq( 'LEFT', 'TRANSPOSE', p, 1, np,b( max( 1, n-p+1 ), 1 ), ldb, work( & - m+1 ), y,max( 1, p ), work( m+np+1 ), lwork-m-np, info ) - work( 1 ) = m + np + max( lopt, int( work( m+np+1 ),KIND=ilp) ) + call stdlib${ii}$_dormrq( 'LEFT', 'TRANSPOSE', p, 1_${ik}$, np,b( max( 1_${ik}$, n-p+1 ), 1_${ik}$ ), ldb, work( & + m+1 ), y,max( 1_${ik}$, p ), work( m+np+1 ), lwork-m-np, info ) + work( 1_${ik}$ ) = m + np + max( lopt, int( work( m+np+1 ),KIND=${ik}$) ) return - end subroutine stdlib_dggglm + end subroutine stdlib${ii}$_dggglm - pure subroutine stdlib_dgglse( m, n, p, a, lda, b, ldb, c, d, x, work, lwork,info ) + pure subroutine stdlib${ii}$_dgglse( m, n, p, a, lda, b, ldb, c, d, x, work, lwork,info ) !! DGGLSE solves the linear equality-constrained least squares (LSE) !! problem: !! minimize || c - A*x ||_2 subject to B*x = d @@ -65259,8 +65259,8 @@ module stdlib_linalg_lapack_d ! -- 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, ldb, lwork, m, n, p + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, p ! Array Arguments real(dp), intent(inout) :: a(lda,*), b(ldb,*), c(*), d(*) real(dp), intent(out) :: work(*), x(*) @@ -65268,46 +65268,46 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: lquery - integer(ilp) :: lopt, lwkmin, lwkopt, mn, nb, nb1, nb2, nb3, nb4, nr + integer(${ik}$) :: lopt, lwkmin, lwkopt, mn, nb, nb1, nb2, nb3, nb4, nr ! Intrinsic Functions intrinsic :: int,max,min ! Executable Statements ! test the input parameters - info = 0 + info = 0_${ik}$ mn = min( m, n ) - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( p<0 .or. p>n .or. pn .or. p0 ) then - call stdlib_dtrtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', p, 1,b( 1, n-p+1 ), ldb, d,& + if( p>0_${ik}$ ) then + call stdlib${ii}$_dtrtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', p, 1_${ik}$,b( 1_${ik}$, n-p+1 ), ldb, d,& p, info ) - if( info>0 ) then - info = 1 + if( info>0_${ik}$ ) then + info = 1_${ik}$ return end if ! put the solution in x - call stdlib_dcopy( p, d, 1, x( n-p+1 ), 1 ) + call stdlib${ii}$_dcopy( p, d, 1_${ik}$, x( n-p+1 ), 1_${ik}$ ) ! update c1 - call stdlib_dgemv( 'NO TRANSPOSE', n-p, p, -one, a( 1, n-p+1 ), lda,d, 1, one, c, 1 & + call stdlib${ii}$_dgemv( 'NO TRANSPOSE', n-p, p, -one, a( 1_${ik}$, n-p+1 ), lda,d, 1_${ik}$, one, c, 1_${ik}$ & ) end if ! solve r11*x1 = c1 for x1 if( n>p ) then - call stdlib_dtrtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n-p, 1,a, lda, c, n-p, & + call stdlib${ii}$_dtrtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n-p, 1_${ik}$,a, lda, c, n-p, & info ) - if( info>0 ) then - info = 2 + if( info>0_${ik}$ ) then + info = 2_${ik}$ return end if ! put the solutions in x - call stdlib_dcopy( n-p, c, 1, x, 1 ) + call stdlib${ii}$_dcopy( n-p, c, 1_${ik}$, x, 1_${ik}$ ) end if ! compute the residual vector: if( m0 )call stdlib_dgemv( 'NO TRANSPOSE', nr, n-m, -one, a( n-p+1, m+1 ),lda, d( & - nr+1 ), 1, one, c( n-p+1 ), 1 ) + if( nr>0_${ik}$ )call stdlib${ii}$_dgemv( 'NO TRANSPOSE', nr, n-m, -one, a( n-p+1, m+1 ),lda, d( & + nr+1 ), 1_${ik}$, one, c( n-p+1 ), 1_${ik}$ ) else nr = p end if - if( nr>0 ) then - call stdlib_dtrmv( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', nr,a( n-p+1, n-p+1 ), lda, & - d, 1 ) - call stdlib_daxpy( nr, -one, d, 1, c( n-p+1 ), 1 ) + if( nr>0_${ik}$ ) then + call stdlib${ii}$_dtrmv( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', nr,a( n-p+1, n-p+1 ), lda, & + d, 1_${ik}$ ) + call stdlib${ii}$_daxpy( nr, -one, d, 1_${ik}$, c( n-p+1 ), 1_${ik}$ ) end if ! backward transformation x = q**t*x - call stdlib_dormrq( 'LEFT', 'TRANSPOSE', n, 1, p, b, ldb, work( 1 ), x,n, work( p+mn+1 & + call stdlib${ii}$_dormrq( 'LEFT', 'TRANSPOSE', n, 1_${ik}$, p, b, ldb, work( 1_${ik}$ ), x,n, work( p+mn+1 & ), lwork-p-mn, info ) - work( 1 ) = p + mn + max( lopt, int( work( p+mn+1 ),KIND=ilp) ) + work( 1_${ik}$ ) = p + mn + max( lopt, int( work( p+mn+1 ),KIND=${ik}$) ) return - end subroutine stdlib_dgglse + end subroutine stdlib${ii}$_dgglse - subroutine stdlib_dhsein( side, eigsrc, initv, select, n, h, ldh, wr, wi,vl, ldvl, vr, ldvr, & + subroutine stdlib${ii}$_dhsein( side, eigsrc, initv, select, n, h, ldh, wr, wi,vl, ldvl, vr, ldvr, & !! DHSEIN uses inverse iteration to find specified right and/or left !! eigenvectors of a real upper Hessenberg matrix H. !! The right eigenvector x and the left eigenvector y of the matrix H @@ -65387,11 +65387,11 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: eigsrc, initv, side - integer(ilp), intent(out) :: info, m - integer(ilp), intent(in) :: ldh, ldvl, ldvr, mm, n + integer(${ik}$), intent(out) :: info, m + integer(${ik}$), intent(in) :: ldh, ldvl, ldvr, mm, n ! Array Arguments logical(lk), intent(inout) :: select(*) - integer(ilp), intent(out) :: ifaill(*), ifailr(*) + integer(${ik}$), intent(out) :: ifaill(*), ifailr(*) real(dp), intent(in) :: h(ldh,*), wi(*) real(dp), intent(inout) :: vl(ldvl,*), vr(ldvr,*), wr(*) real(dp), intent(out) :: work(*) @@ -65399,7 +65399,7 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: bothv, fromqr, leftv, noinit, pair, rightv - integer(ilp) :: i, iinfo, k, kl, kln, kr, ksi, ksr, ldwork + integer(${ik}$) :: i, iinfo, k, kl, kln, kr, ksi, ksr, ldwork real(dp) :: bignum, eps3, hnorm, smlnum, ulp, unfl, wki, wkr ! Intrinsic Functions intrinsic :: abs,max @@ -65412,7 +65412,7 @@ module stdlib_linalg_lapack_d noinit = stdlib_lsame( initv, 'N' ) ! set m to the number of columns required to store the selected ! eigenvectors, and standardize the array select. - m = 0 + m = 0_${ik}$ pair = .false. do k = 1, n if( pair ) then @@ -65420,54 +65420,54 @@ module stdlib_linalg_lapack_d select( k ) = .false. else if( wi( k )==zero ) then - if( select( k ) )m = m + 1 + if( select( k ) )m = m + 1_${ik}$ else pair = .true. if( select( k ) .or. select( k+1 ) ) then select( k ) = .true. - m = m + 2 + m = m + 2_${ik}$ end if end if end if end do - info = 0 + info = 0_${ik}$ if( .not.rightv .and. .not.leftv ) then - info = -1 + info = -1_${ik}$ else if( .not.fromqr .and. .not.stdlib_lsame( eigsrc, 'N' ) ) then - info = -2 + info = -2_${ik}$ else if( .not.noinit .and. .not.stdlib_lsame( initv, 'U' ) ) then - info = -3 - else if( n<0 ) then - info = -5 - else if( ldhzero ) then eps3 = hnorm*ulp @@ -65523,26 +65523,26 @@ module stdlib_linalg_lapack_d wr( k ) = wkr pair = wki/=zero if( pair ) then - ksi = ksr + 1 + ksi = ksr + 1_${ik}$ else ksi = ksr end if if( leftv ) then ! compute left eigenvector. - call stdlib_dlaein( .false., noinit, n-kl+1, h( kl, kl ), ldh,wkr, wki, vl( & + call stdlib${ii}$_dlaein( .false., noinit, n-kl+1, h( kl, kl ), ldh,wkr, wki, vl( & kl, ksr ), vl( kl, ksi ),work, ldwork, work( n*n+n+1 ), eps3, smlnum,bignum, & iinfo ) - if( iinfo>0 ) then + if( iinfo>0_${ik}$ ) then if( pair ) then - info = info + 2 + info = info + 2_${ik}$ else - info = info + 1 + info = info + 1_${ik}$ end if ifaill( ksr ) = k ifaill( ksi ) = k else - ifaill( ksr ) = 0 - ifaill( ksi ) = 0 + ifaill( ksr ) = 0_${ik}$ + ifaill( ksi ) = 0_${ik}$ end if do i = 1, kl - 1 vl( i, ksr ) = zero @@ -65555,19 +65555,19 @@ module stdlib_linalg_lapack_d end if if( rightv ) then ! compute right eigenvector. - call stdlib_dlaein( .true., noinit, kr, h, ldh, wkr, wki,vr( 1, ksr ), vr( 1, & + call stdlib${ii}$_dlaein( .true., noinit, kr, h, ldh, wkr, wki,vr( 1_${ik}$, ksr ), vr( 1_${ik}$, & ksi ), work, ldwork,work( n*n+n+1 ), eps3, smlnum, bignum,iinfo ) - if( iinfo>0 ) then + if( iinfo>0_${ik}$ ) then if( pair ) then - info = info + 2 + info = info + 2_${ik}$ else - info = info + 1 + info = info + 1_${ik}$ end if ifailr( ksr ) = k ifailr( ksi ) = k else - ifailr( ksr ) = 0 - ifailr( ksi ) = 0 + ifailr( ksr ) = 0_${ik}$ + ifailr( ksi ) = 0_${ik}$ end if do i = kr + 1, n vr( i, ksr ) = zero @@ -65579,17 +65579,17 @@ module stdlib_linalg_lapack_d end if end if if( pair ) then - ksr = ksr + 2 + ksr = ksr + 2_${ik}$ else - ksr = ksr + 1 + ksr = ksr + 1_${ik}$ end if end if end do loop_120 return - end subroutine stdlib_dhsein + end subroutine stdlib${ii}$_dhsein - real(dp) function stdlib_dla_porpvgrw( uplo, ncols, a, lda, af,ldaf, work ) + real(dp) function stdlib${ii}$_dla_porpvgrw( uplo, ncols, a, lda, af,ldaf, work ) !! DLA_PORPVGRW computes the reciprocal pivot growth factor !! norm(A)/norm(U). The "max absolute element" norm is used. If this is !! much less than 1, the stability of the LU factorization of the @@ -65601,20 +65601,20 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: ncols, lda, ldaf + integer(${ik}$), intent(in) :: ncols, lda, ldaf ! Array Arguments real(dp), intent(in) :: a(lda,*), af(ldaf,*) real(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: amax, umax, rpvgrw logical(lk) :: upper ! Intrinsic Functions intrinsic :: abs,max,min ! Executable Statements upper = stdlib_lsame( 'UPPER', uplo ) - ! stdlib_dpotrf will have factored only the ncolsxncols leading minor, so + ! stdlib${ii}$_dpotrf will have factored only the ncolsxncols leading minor, so ! we restrict the growth search to that minor and use only the first ! 2*ncols workspace entries. rpvgrw = one @@ -65673,11 +65673,11 @@ module stdlib_linalg_lapack_d end if end do end if - stdlib_dla_porpvgrw = rpvgrw - end function stdlib_dla_porpvgrw + stdlib${ii}$_dla_porpvgrw = rpvgrw + end function stdlib${ii}$_dla_porpvgrw - pure subroutine stdlib_dlaed3( k, n, n1, d, q, ldq, rho, dlamda, q2, indx,ctot, w, s, info ) + pure subroutine stdlib${ii}$_dlaed3( k, n, n1, d, q, ldq, rho, dlamda, q2, indx,ctot, w, s, info ) !! DLAED3 finds the roots of the secular equation, as defined by the !! values in D, W, and RHO, between 1 and K. It makes the !! appropriate calls to DLAED4 and then updates the eigenvectors by @@ -65695,33 +65695,33 @@ module stdlib_linalg_lapack_d ! -- 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, ldq, n, n1 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k, ldq, n, n1 real(dp), intent(in) :: rho ! Array Arguments - integer(ilp), intent(in) :: ctot(*), indx(*) + integer(${ik}$), intent(in) :: ctot(*), indx(*) real(dp), intent(out) :: d(*), q(ldq,*), s(*) real(dp), intent(inout) :: dlamda(*), w(*) real(dp), intent(in) :: q2(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ii, iq2, j, n12, n2, n23 + integer(${ik}$) :: i, ii, iq2, j, n12, n2, n23 real(dp) :: temp ! Intrinsic Functions intrinsic :: max,sign,sqrt ! Executable Statements ! test the input parameters. - info = 0 - if( k<0 ) then - info = -1 + info = 0_${ik}$ + if( k<0_${ik}$ ) then + info = -1_${ik}$ else if( n1 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( icompq==1 .and. qsizcutpnt .or. n1_${ik}$ ) then + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ + else if( icompq==1_${ik}$ .and. qsizcutpnt .or. nn )return - j2 = j1 + 1 - j3 = j1 + 2 - j4 = j1 + 3 - if( n1==1 .and. n2==1 ) then + j2 = j1 + 1_${ik}$ + j3 = j1 + 2_${ik}$ + j4 = j1 + 3_${ik}$ + if( n1==1_${ik}$ .and. n2==1_${ik}$ ) then ! swap two 1-by-1 blocks. t11 = t( j1, j1 ) t22 = t( j2, j2 ) ! determine the transformation to perform the interchange. - call stdlib_dlartg( t( j1, j2 ), t22-t11, cs, sn, temp ) + call stdlib${ii}$_dlartg( t( j1, j2 ), t22-t11, cs, sn, temp ) ! apply transformation to the matrix t. - if( j3<=n )call stdlib_drot( n-j1-1, t( j1, j3 ), ldt, t( j2, j3 ), ldt, cs,sn ) + if( j3<=n )call stdlib${ii}$_drot( n-j1-1, t( j1, j3 ), ldt, t( j2, j3 ), ldt, cs,sn ) - call stdlib_drot( j1-1, t( 1, j1 ), 1, t( 1, j2 ), 1, cs, sn ) + call stdlib${ii}$_drot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$, t( 1_${ik}$, j2 ), 1_${ik}$, cs, sn ) t( j1, j1 ) = t22 t( j2, j2 ) = t11 if( wantq ) then ! accumulate transformation in the matrix q. - call stdlib_drot( n, q( 1, j1 ), 1, q( 1, j2 ), 1, cs, sn ) + call stdlib${ii}$_drot( n, q( 1_${ik}$, j1 ), 1_${ik}$, q( 1_${ik}$, j2 ), 1_${ik}$, cs, sn ) end if else ! swapping involves at least one 2-by-2 block. ! copy the diagonal block of order n1+n2 to the local array d ! and compute its norm. nd = n1 + n2 - call stdlib_dlacpy( 'FULL', nd, nd, t( j1, j1 ), ldt, d, ldd ) - dnorm = stdlib_dlange( 'MAX', nd, nd, d, ldd, work ) + call stdlib${ii}$_dlacpy( 'FULL', nd, nd, t( j1, j1 ), ldt, d, ldd ) + dnorm = stdlib${ii}$_dlange( 'MAX', nd, nd, d, ldd, work ) ! compute machine-dependent threshold for test for accepting ! swap. - eps = stdlib_dlamch( 'P' ) - smlnum = stdlib_dlamch( 'S' ) / eps + eps = stdlib${ii}$_dlamch( 'P' ) + smlnum = stdlib${ii}$_dlamch( 'S' ) / eps thresh = max( ten*eps*dnorm, smlnum ) ! solve t11*x - x*t22 = scale*t12 for x. - call stdlib_dlasy2( .false., .false., -1, n1, n2, d, ldd,d( n1+1, n1+1 ), ldd, d( 1,& + call stdlib${ii}$_dlasy2( .false., .false., -1_${ik}$, n1, n2, d, ldd,d( n1+1, n1+1 ), ldd, d( 1_${ik}$,& n1+1 ), ldd, scale, x,ldx, xnorm, ierr ) ! swap the adjacent diagonal blocks. - k = n1 + n1 + n2 - 3 + k = n1 + n1 + n2 - 3_${ik}$ go to ( 10, 20, 30 )k 10 continue ! n1 = 1, n2 = 2: generate elementary reflector h so that: ! ( scale, x11, x12 ) h = ( 0, 0, * ) - u( 1 ) = scale - u( 2 ) = x( 1, 1 ) - u( 3 ) = x( 1, 2 ) - call stdlib_dlarfg( 3, u( 3 ), u, 1, tau ) - u( 3 ) = one + u( 1_${ik}$ ) = scale + u( 2_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) + u( 3_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ ) + call stdlib${ii}$_dlarfg( 3_${ik}$, u( 3_${ik}$ ), u, 1_${ik}$, tau ) + u( 3_${ik}$ ) = one t11 = t( j1, j1 ) ! perform swap provisionally on diagonal block in d. - call stdlib_dlarfx( 'L', 3, 3, u, tau, d, ldd, work ) - call stdlib_dlarfx( 'R', 3, 3, u, tau, d, ldd, work ) + call stdlib${ii}$_dlarfx( 'L', 3_${ik}$, 3_${ik}$, u, tau, d, ldd, work ) + call stdlib${ii}$_dlarfx( 'R', 3_${ik}$, 3_${ik}$, u, tau, d, ldd, work ) ! test whether to reject swap. - if( max( abs( d( 3, 1 ) ), abs( d( 3, 2 ) ), abs( d( 3,3 )-t11 ) )>thresh )go to & - 50 + if( max( abs( d( 3, 1 ) ), abs( d( 3, 2 ) ), abs( d( 3,3 )-t11 ) )>thresh ) go to 50 ! accept swap: apply transformation to the entire matrix t. - call stdlib_dlarfx( 'L', 3, n-j1+1, u, tau, t( j1, j1 ), ldt, work ) - call stdlib_dlarfx( 'R', j2, 3, u, tau, t( 1, j1 ), ldt, work ) + call stdlib${ii}$_dlarfx( 'L', 3_${ik}$, n-j1+1, u, tau, t( j1, j1 ), ldt, work ) + call stdlib${ii}$_dlarfx( 'R', j2, 3_${ik}$, u, tau, t( 1_${ik}$, j1 ), ldt, work ) t( j3, j1 ) = zero t( j3, j2 ) = zero t( j3, j3 ) = t11 if( wantq ) then ! accumulate transformation in the matrix q. - call stdlib_dlarfx( 'R', n, 3, u, tau, q( 1, j1 ), ldq, work ) + call stdlib${ii}$_dlarfx( 'R', n, 3_${ik}$, u, tau, q( 1_${ik}$, j1 ), ldq, work ) end if go to 40 20 continue @@ -66052,27 +66051,26 @@ module stdlib_linalg_lapack_d ! h ( -x11 ) = ( * ) ! ( -x21 ) = ( 0 ) ! ( scale ) = ( 0 ) - u( 1 ) = -x( 1, 1 ) - u( 2 ) = -x( 2, 1 ) - u( 3 ) = scale - call stdlib_dlarfg( 3, u( 1 ), u( 2 ), 1, tau ) - u( 1 ) = one + u( 1_${ik}$ ) = -x( 1_${ik}$, 1_${ik}$ ) + u( 2_${ik}$ ) = -x( 2_${ik}$, 1_${ik}$ ) + u( 3_${ik}$ ) = scale + call stdlib${ii}$_dlarfg( 3_${ik}$, u( 1_${ik}$ ), u( 2_${ik}$ ), 1_${ik}$, tau ) + u( 1_${ik}$ ) = one t33 = t( j3, j3 ) ! perform swap provisionally on diagonal block in d. - call stdlib_dlarfx( 'L', 3, 3, u, tau, d, ldd, work ) - call stdlib_dlarfx( 'R', 3, 3, u, tau, d, ldd, work ) + call stdlib${ii}$_dlarfx( 'L', 3_${ik}$, 3_${ik}$, u, tau, d, ldd, work ) + call stdlib${ii}$_dlarfx( 'R', 3_${ik}$, 3_${ik}$, u, tau, d, ldd, work ) ! test whether to reject swap. - if( max( abs( d( 2, 1 ) ), abs( d( 3, 1 ) ), abs( d( 1,1 )-t33 ) )>thresh )go to & - 50 + if( max( abs( d( 2, 1 ) ), abs( d( 3, 1 ) ), abs( d( 1,1 )-t33 ) )>thresh ) go to 50 ! accept swap: apply transformation to the entire matrix t. - call stdlib_dlarfx( 'R', j3, 3, u, tau, t( 1, j1 ), ldt, work ) - call stdlib_dlarfx( 'L', 3, n-j1, u, tau, t( j1, j2 ), ldt, work ) + call stdlib${ii}$_dlarfx( 'R', j3, 3_${ik}$, u, tau, t( 1_${ik}$, j1 ), ldt, work ) + call stdlib${ii}$_dlarfx( 'L', 3_${ik}$, n-j1, u, tau, t( j1, j2 ), ldt, work ) t( j1, j1 ) = t33 t( j2, j1 ) = zero t( j3, j1 ) = zero if( wantq ) then ! accumulate transformation in the matrix q. - call stdlib_dlarfx( 'R', n, 3, u, tau, q( 1, j1 ), ldq, work ) + call stdlib${ii}$_dlarfx( 'R', n, 3_${ik}$, u, tau, q( 1_${ik}$, j1 ), ldq, work ) end if go to 40 30 continue @@ -66082,69 +66080,69 @@ module stdlib_linalg_lapack_d ! ( -x21 -x22 ) ( 0 * ) ! ( scale 0 ) ( 0 0 ) ! ( 0 scale ) ( 0 0 ) - u1( 1 ) = -x( 1, 1 ) - u1( 2 ) = -x( 2, 1 ) - u1( 3 ) = scale - call stdlib_dlarfg( 3, u1( 1 ), u1( 2 ), 1, tau1 ) - u1( 1 ) = one - temp = -tau1*( x( 1, 2 )+u1( 2 )*x( 2, 2 ) ) - u2( 1 ) = -temp*u1( 2 ) - x( 2, 2 ) - u2( 2 ) = -temp*u1( 3 ) - u2( 3 ) = scale - call stdlib_dlarfg( 3, u2( 1 ), u2( 2 ), 1, tau2 ) - u2( 1 ) = one + u1( 1_${ik}$ ) = -x( 1_${ik}$, 1_${ik}$ ) + u1( 2_${ik}$ ) = -x( 2_${ik}$, 1_${ik}$ ) + u1( 3_${ik}$ ) = scale + call stdlib${ii}$_dlarfg( 3_${ik}$, u1( 1_${ik}$ ), u1( 2_${ik}$ ), 1_${ik}$, tau1 ) + u1( 1_${ik}$ ) = one + temp = -tau1*( x( 1_${ik}$, 2_${ik}$ )+u1( 2_${ik}$ )*x( 2_${ik}$, 2_${ik}$ ) ) + u2( 1_${ik}$ ) = -temp*u1( 2_${ik}$ ) - x( 2_${ik}$, 2_${ik}$ ) + u2( 2_${ik}$ ) = -temp*u1( 3_${ik}$ ) + u2( 3_${ik}$ ) = scale + call stdlib${ii}$_dlarfg( 3_${ik}$, u2( 1_${ik}$ ), u2( 2_${ik}$ ), 1_${ik}$, tau2 ) + u2( 1_${ik}$ ) = one ! perform swap provisionally on diagonal block in d. - call stdlib_dlarfx( 'L', 3, 4, u1, tau1, d, ldd, work ) - call stdlib_dlarfx( 'R', 4, 3, u1, tau1, d, ldd, work ) - call stdlib_dlarfx( 'L', 3, 4, u2, tau2, d( 2, 1 ), ldd, work ) - call stdlib_dlarfx( 'R', 4, 3, u2, tau2, d( 1, 2 ), ldd, work ) + call stdlib${ii}$_dlarfx( 'L', 3_${ik}$, 4_${ik}$, u1, tau1, d, ldd, work ) + call stdlib${ii}$_dlarfx( 'R', 4_${ik}$, 3_${ik}$, u1, tau1, d, ldd, work ) + call stdlib${ii}$_dlarfx( 'L', 3_${ik}$, 4_${ik}$, u2, tau2, d( 2_${ik}$, 1_${ik}$ ), ldd, work ) + call stdlib${ii}$_dlarfx( 'R', 4_${ik}$, 3_${ik}$, u2, tau2, d( 1_${ik}$, 2_${ik}$ ), ldd, work ) ! test whether to reject swap. - if( max( abs( d( 3, 1 ) ), abs( d( 3, 2 ) ), abs( d( 4, 1 ) ),abs( d( 4, 2 ) ) )& + if( max( abs( d( 3_${ik}$, 1_${ik}$ ) ), abs( d( 3_${ik}$, 2_${ik}$ ) ), abs( d( 4_${ik}$, 1_${ik}$ ) ),abs( d( 4_${ik}$, 2_${ik}$ ) ) )& >thresh )go to 50 ! accept swap: apply transformation to the entire matrix t. - call stdlib_dlarfx( 'L', 3, n-j1+1, u1, tau1, t( j1, j1 ), ldt, work ) - call stdlib_dlarfx( 'R', j4, 3, u1, tau1, t( 1, j1 ), ldt, work ) - call stdlib_dlarfx( 'L', 3, n-j1+1, u2, tau2, t( j2, j1 ), ldt, work ) - call stdlib_dlarfx( 'R', j4, 3, u2, tau2, t( 1, j2 ), ldt, work ) + call stdlib${ii}$_dlarfx( 'L', 3_${ik}$, n-j1+1, u1, tau1, t( j1, j1 ), ldt, work ) + call stdlib${ii}$_dlarfx( 'R', j4, 3_${ik}$, u1, tau1, t( 1_${ik}$, j1 ), ldt, work ) + call stdlib${ii}$_dlarfx( 'L', 3_${ik}$, n-j1+1, u2, tau2, t( j2, j1 ), ldt, work ) + call stdlib${ii}$_dlarfx( 'R', j4, 3_${ik}$, u2, tau2, t( 1_${ik}$, j2 ), ldt, work ) t( j3, j1 ) = zero t( j3, j2 ) = zero t( j4, j1 ) = zero t( j4, j2 ) = zero if( wantq ) then ! accumulate transformation in the matrix q. - call stdlib_dlarfx( 'R', n, 3, u1, tau1, q( 1, j1 ), ldq, work ) - call stdlib_dlarfx( 'R', n, 3, u2, tau2, q( 1, j2 ), ldq, work ) + call stdlib${ii}$_dlarfx( 'R', n, 3_${ik}$, u1, tau1, q( 1_${ik}$, j1 ), ldq, work ) + call stdlib${ii}$_dlarfx( 'R', n, 3_${ik}$, u2, tau2, q( 1_${ik}$, j2 ), ldq, work ) end if 40 continue - if( n2==2 ) then + if( n2==2_${ik}$ ) then ! standardize new 2-by-2 block t11 - call stdlib_dlanv2( t( j1, j1 ), t( j1, j2 ), t( j2, j1 ),t( j2, j2 ), wr1, wi1, & + call stdlib${ii}$_dlanv2( t( j1, j1 ), t( j1, j2 ), t( j2, j1 ),t( j2, j2 ), wr1, wi1, & wr2, wi2, cs, sn ) - call stdlib_drot( n-j1-1, t( j1, j1+2 ), ldt, t( j2, j1+2 ), ldt,cs, sn ) - call stdlib_drot( j1-1, t( 1, j1 ), 1, t( 1, j2 ), 1, cs, sn ) - if( wantq )call stdlib_drot( n, q( 1, j1 ), 1, q( 1, j2 ), 1, cs, sn ) + call stdlib${ii}$_drot( n-j1-1, t( j1, j1+2 ), ldt, t( j2, j1+2 ), ldt,cs, sn ) + call stdlib${ii}$_drot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$, t( 1_${ik}$, j2 ), 1_${ik}$, cs, sn ) + if( wantq )call stdlib${ii}$_drot( n, q( 1_${ik}$, j1 ), 1_${ik}$, q( 1_${ik}$, j2 ), 1_${ik}$, cs, sn ) end if - if( n1==2 ) then + if( n1==2_${ik}$ ) then ! standardize new 2-by-2 block t22 j3 = j1 + n2 - j4 = j3 + 1 - call stdlib_dlanv2( t( j3, j3 ), t( j3, j4 ), t( j4, j3 ),t( j4, j4 ), wr1, wi1, & + j4 = j3 + 1_${ik}$ + call stdlib${ii}$_dlanv2( t( j3, j3 ), t( j3, j4 ), t( j4, j3 ),t( j4, j4 ), wr1, wi1, & wr2, wi2, cs, sn ) - if( j3+2<=n )call stdlib_drot( n-j3-1, t( j3, j3+2 ), ldt, t( j4, j3+2 ),ldt, cs,& + if( j3+2<=n )call stdlib${ii}$_drot( n-j3-1, t( j3, j3+2 ), ldt, t( j4, j3+2 ),ldt, cs,& sn ) - call stdlib_drot( j3-1, t( 1, j3 ), 1, t( 1, j4 ), 1, cs, sn ) - if( wantq )call stdlib_drot( n, q( 1, j3 ), 1, q( 1, j4 ), 1, cs, sn ) + call stdlib${ii}$_drot( j3-1, t( 1_${ik}$, j3 ), 1_${ik}$, t( 1_${ik}$, j4 ), 1_${ik}$, cs, sn ) + if( wantq )call stdlib${ii}$_drot( n, q( 1_${ik}$, j3 ), 1_${ik}$, q( 1_${ik}$, j4 ), 1_${ik}$, cs, sn ) end if end if return ! exit with info = 1 if swap was rejected. 50 continue - info = 1 + info = 1_${ik}$ return - end subroutine stdlib_dlaexc + end subroutine stdlib${ii}$_dlaexc - pure subroutine stdlib_dlahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, & + pure subroutine stdlib${ii}$_dlahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, & !! DLAHQR is an auxiliary routine called by DHSEQR to update the !! eigenvalues and Schur decomposition already computed by DHSEQR, by !! dealing with the Hessenberg submatrix in rows and columns ILO to @@ -66154,8 +66152,8 @@ module stdlib_linalg_lapack_d ! -- 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, ihiz, ilo, iloz, ldh, ldz, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ihiz, ilo, iloz, ldh, ldz, n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt, wantz ! Array Arguments real(dp), intent(inout) :: h(ldh,*), z(ldz,*) @@ -66164,20 +66162,20 @@ module stdlib_linalg_lapack_d ! Parameters real(dp), parameter :: dat1 = 3.0_dp/4.0_dp real(dp), parameter :: dat2 = -0.4375_dp - integer(ilp), parameter :: kexsh = 10 + integer(${ik}$), parameter :: kexsh = 10_${ik}$ ! Local Scalars real(dp) :: aa, ab, ba, bb, cs, det, h11, h12, h21, h21s, h22, rt1i, rt1r, rt2i, rt2r, & rtdisc, s, safmax, safmin, smlnum, sn, sum, t1, t2, t3, tr, tst, ulp, v2, v3 - integer(ilp) :: i, i1, i2, its, itmax, j, k, l, m, nh, nr, nz, kdefl + integer(${ik}$) :: i, i1, i2, its, itmax, j, k, l, m, nh, nr, nz, kdefl ! Local Arrays - real(dp) :: v(3) + real(dp) :: v(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,max,min,sqrt ! Executable Statements - info = 0 + info = 0_${ik}$ ! quick return if possible if( n==0 )return if( ilo==ihi ) then @@ -66191,25 +66189,25 @@ module stdlib_linalg_lapack_d h( j+3, j ) = zero end do if( ilo<=ihi-2 )h( ihi, ihi-2 ) = zero - nh = ihi - ilo + 1 - nz = ihiz - iloz + 1 + nh = ihi - ilo + 1_${ik}$ + nz = ihiz - iloz + 1_${ik}$ ! set machine-dependent constants for the stopping criterion. - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) safmax = one / safmin - call stdlib_dlabad( safmin, safmax ) - ulp = stdlib_dlamch( 'PRECISION' ) + call stdlib${ii}$_dlabad( safmin, safmax ) + ulp = stdlib${ii}$_dlamch( 'PRECISION' ) smlnum = safmin*( real( nh,KIND=dp) / ulp ) ! i1 and i2 are the indices of the first row and last column of h ! to which transformations must be applied. if eigenvalues only are ! being computed, i1 and i2 are set inside the main loop. if( wantt ) then - i1 = 1 + i1 = 1_${ik}$ i2 = n end if ! itmax is the total number of qr iterations allowed. - itmax = 30 * max( 10, nh ) + itmax = 30_${ik}$ * max( 10_${ik}$, nh ) ! kdefl counts the number of iterations since a deflation - kdefl = 0 + kdefl = 0_${ik}$ ! the main loop begins here. i is the loop index and decreases from ! ihi to ilo in steps of 1 or 2. each iteration of the loop works ! with the active submatrix in rows and columns l to i. @@ -66252,7 +66250,7 @@ module stdlib_linalg_lapack_d end if ! exit from loop if a submatrix of order 1 or 2 has split off. if( l>=i-1 )go to 150 - kdefl = kdefl + 1 + kdefl = kdefl + 1_${ik}$ ! now the active submatrix is in rows and columns l to i. if ! eigenvalues only are being computed, only the active submatrix ! need be transformed. @@ -66260,14 +66258,14 @@ module stdlib_linalg_lapack_d i1 = l i2 = i end if - if( mod(kdefl,2*kexsh)==0 ) then + if( mod(kdefl,2_${ik}$*kexsh)==0_${ik}$ ) then ! exceptional shift. s = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) ) h11 = dat1*s + h( i, i ) h12 = dat2*s h21 = s h22 = h11 - else if( mod(kdefl,kexsh)==0 ) then + else if( mod(kdefl,kexsh)==0_${ik}$ ) then ! exceptional shift. s = abs( h( l+1, l ) ) + abs( h( l+2, l+1 ) ) h11 = dat1*s + h( l, l ) @@ -66326,16 +66324,16 @@ module stdlib_linalg_lapack_d h21s = h( m+1, m ) s = abs( h( m, m )-rt2r ) + abs( rt2i ) + abs( h21s ) h21s = h( m+1, m ) / s - v( 1 ) = h21s*h( m, m+1 ) + ( h( m, m )-rt1r )*( ( h( m, m )-rt2r ) / s ) - & + v( 1_${ik}$ ) = h21s*h( m, m+1 ) + ( h( m, m )-rt1r )*( ( h( m, m )-rt2r ) / s ) - & rt1i*( rt2i / s ) - v( 2 ) = h21s*( h( m, m )+h( m+1, m+1 )-rt1r-rt2r ) - v( 3 ) = h21s*h( m+2, m+1 ) - s = abs( v( 1 ) ) + abs( v( 2 ) ) + abs( v( 3 ) ) - v( 1 ) = v( 1 ) / s - v( 2 ) = v( 2 ) / s - v( 3 ) = v( 3 ) / s + v( 2_${ik}$ ) = h21s*( h( m, m )+h( m+1, m+1 )-rt1r-rt2r ) + v( 3_${ik}$ ) = h21s*h( m+2, m+1 ) + s = abs( v( 1_${ik}$ ) ) + abs( v( 2_${ik}$ ) ) + abs( v( 3_${ik}$ ) ) + v( 1_${ik}$ ) = v( 1_${ik}$ ) / s + v( 2_${ik}$ ) = v( 2_${ik}$ ) / s + v( 3_${ik}$ ) = v( 3_${ik}$ ) / s if( m==l )go to 60 - if( abs( h( m, m-1 ) )*( abs( v( 2 ) )+abs( v( 3 ) ) )<=ulp*abs( v( 1 ) )*( abs( & + if( abs( h( m, m-1 ) )*( abs( v( 2_${ik}$ ) )+abs( v( 3_${ik}$ ) ) )<=ulp*abs( v( 1_${ik}$ ) )*( abs( & h( m-1, m-1 ) )+abs( h( m,m ) )+abs( h( m+1, m+1 ) ) ) )go to 60 end do 60 continue @@ -66348,11 +66346,11 @@ module stdlib_linalg_lapack_d ! restore the hessenberg form in the (k-1)th column, and thus ! chases the bulge one step toward the bottom of the active ! submatrix. nr is the order of g. - nr = min( 3, i-k+1 ) - if( k>m )call stdlib_dcopy( nr, h( k, k-1 ), 1, v, 1 ) - call stdlib_dlarfg( nr, v( 1 ), v( 2 ), 1, t1 ) + nr = min( 3_${ik}$, i-k+1 ) + if( k>m )call stdlib${ii}$_dcopy( nr, h( k, k-1 ), 1_${ik}$, v, 1_${ik}$ ) + call stdlib${ii}$_dlarfg( nr, v( 1_${ik}$ ), v( 2_${ik}$ ), 1_${ik}$, t1 ) if( k>m ) then - h( k, k-1 ) = v( 1 ) + h( k, k-1 ) = v( 1_${ik}$ ) h( k+1, k-1 ) = zero if( kl ) then @@ -66362,10 +66360,10 @@ module stdlib_linalg_lapack_d ! . underflow. ==== h( k, k-1 ) = h( k, k-1 )*( one-t1 ) end if - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = t1*v2 - if( nr==3 ) then - v3 = v( 3 ) + if( nr==3_${ik}$ ) then + v3 = v( 3_${ik}$ ) t3 = t1*v3 ! apply g from the left to transform the rows of the matrix ! in columns k to i2. @@ -66392,7 +66390,7 @@ module stdlib_linalg_lapack_d z( j, k+2 ) = z( j, k+2 ) - sum*t3 end do end if - else if( nr==2 ) then + else if( nr==2_${ik}$ ) then ! apply g from the left to transform the rows of the matrix ! in columns k to i2. do j = k, i2 @@ -66430,30 +66428,30 @@ module stdlib_linalg_lapack_d ! h(i-1,i-2) is negligible: a pair of eigenvalues have converged. ! transform the 2-by-2 submatrix to standard schur form, ! and compute and store the eigenvalues. - call stdlib_dlanv2( h( i-1, i-1 ), h( i-1, i ), h( i, i-1 ),h( i, i ), wr( i-1 ), & + call stdlib${ii}$_dlanv2( h( i-1, i-1 ), h( i-1, i ), h( i, i-1 ),h( i, i ), wr( i-1 ), & wi( i-1 ), wr( i ), wi( i ),cs, sn ) if( wantt ) then ! apply the transformation to the rest of h. - if( i2>i )call stdlib_drot( i2-i, h( i-1, i+1 ), ldh, h( i, i+1 ), ldh,cs, sn ) + if( i2>i )call stdlib${ii}$_drot( i2-i, h( i-1, i+1 ), ldh, h( i, i+1 ), ldh,cs, sn ) - call stdlib_drot( i-i1-1, h( i1, i-1 ), 1, h( i1, i ), 1, cs, sn ) + call stdlib${ii}$_drot( i-i1-1, h( i1, i-1 ), 1_${ik}$, h( i1, i ), 1_${ik}$, cs, sn ) end if if( wantz ) then ! apply the transformation to z. - call stdlib_drot( nz, z( iloz, i-1 ), 1, z( iloz, i ), 1, cs, sn ) + call stdlib${ii}$_drot( nz, z( iloz, i-1 ), 1_${ik}$, z( iloz, i ), 1_${ik}$, cs, sn ) end if end if ! reset deflation counter - kdefl = 0 + kdefl = 0_${ik}$ ! return to start of the main loop with new value of i. - i = l - 1 + i = l - 1_${ik}$ go to 20 160 continue return - end subroutine stdlib_dlahqr + end subroutine stdlib${ii}$_dlahqr - pure subroutine stdlib_dlasd2( nl, nr, sqre, k, d, z, alpha, beta, u, ldu, vt,ldvt, dsigma, & + pure subroutine stdlib${ii}$_dlasd2( nl, nr, sqre, k, d, z, alpha, beta, u, ldu, vt,ldvt, dsigma, & !! DLASD2 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 @@ -66466,58 +66464,58 @@ module stdlib_linalg_lapack_d ! -- 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, k - integer(ilp), intent(in) :: ldu, ldu2, ldvt, ldvt2, nl, nr, sqre + integer(${ik}$), intent(out) :: info, k + integer(${ik}$), intent(in) :: ldu, ldu2, ldvt, ldvt2, nl, nr, sqre real(dp), intent(in) :: alpha, beta ! Array Arguments - integer(ilp), intent(out) :: coltyp(*), idx(*), idxc(*), idxp(*) - integer(ilp), intent(inout) :: idxq(*) + integer(${ik}$), intent(out) :: coltyp(*), idx(*), idxc(*), idxp(*) + integer(${ik}$), intent(inout) :: idxq(*) real(dp), intent(inout) :: d(*), u(ldu,*), vt(ldvt,*) real(dp), intent(out) :: dsigma(*), u2(ldu2,*), vt2(ldvt2,*), z(*) ! ===================================================================== ! Local Arrays - integer(ilp) :: ctot(4), psm(4) + integer(${ik}$) :: ctot(4_${ik}$), psm(4_${ik}$) ! Local Scalars - integer(ilp) :: ct, i, idxi, idxj, idxjp, j, jp, jprev, k2, m, n, nlp1, nlp2 + integer(${ik}$) :: ct, i, idxi, idxj, idxjp, j, jp, jprev, k2, m, n, nlp1, nlp2 real(dp) :: c, eps, hlftol, s, tau, tol, z1 ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements ! test the input parameters. - info = 0 - if( nl<1 ) then - info = -1 - else if( nr<1 ) then - info = -2 - else if( ( sqre/=1 ) .and. ( sqre/=0 ) ) then - info = -3 - end if - n = nl + nr + 1 + info = 0_${ik}$ + if( nl<1_${ik}$ ) then + info = -1_${ik}$ + else if( nr<1_${ik}$ ) then + info = -2_${ik}$ + else if( ( sqre/=1_${ik}$ ) .and. ( sqre/=0_${ik}$ ) ) then + info = -3_${ik}$ + end if + n = nl + nr + 1_${ik}$ m = n + sqre if( ldun )go to 110 if( abs( z( j ) )<=tol ) then ! deflate due to small z component. - k2 = k2 - 1 + k2 = k2 - 1_${ik}$ idxp( k2 ) = j - coltyp( j ) = 4 + coltyp( j ) = 4_${ik}$ else ! check if singular values are close enough to allow deflation. if( abs( d( j )-d( jprev ) )<=tol ) then @@ -66599,33 +66597,33 @@ module stdlib_linalg_lapack_d c = z( j ) ! find sqrt(a**2+b**2) without overflow or ! destructive underflow. - tau = stdlib_dlapy2( c, s ) + tau = stdlib${ii}$_dlapy2( c, s ) c = c / tau s = -s / tau z( j ) = tau z( jprev ) = zero ! apply back the givens rotation to the left and right ! singular vector matrices. - idxjp = idxq( idx( jprev )+1 ) - idxj = idxq( idx( j )+1 ) + 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 - call stdlib_drot( n, u( 1, idxjp ), 1, u( 1, idxj ), 1, c, s ) - call stdlib_drot( m, vt( idxjp, 1 ), ldvt, vt( idxj, 1 ), ldvt, c,s ) + call stdlib${ii}$_drot( n, u( 1_${ik}$, idxjp ), 1_${ik}$, u( 1_${ik}$, idxj ), 1_${ik}$, c, s ) + call stdlib${ii}$_drot( m, vt( idxjp, 1_${ik}$ ), ldvt, vt( idxj, 1_${ik}$ ), ldvt, c,s ) if( coltyp( j )/=coltyp( jprev ) ) then - coltyp( j ) = 3 + coltyp( j ) = 3_${ik}$ end if - coltyp( jprev ) = 4 - k2 = k2 - 1 + coltyp( jprev ) = 4_${ik}$ + k2 = k2 - 1_${ik}$ idxp( k2 ) = jprev jprev = j else - k = k + 1 - u2( k, 1 ) = z( jprev ) + k = k + 1_${ik}$ + u2( k, 1_${ik}$ ) = z( jprev ) dsigma( k ) = d( jprev ) idxp( k ) = jprev jprev = j @@ -66634,8 +66632,8 @@ module stdlib_linalg_lapack_d go to 100 110 continue ! record the last singular value. - k = k + 1 - u2( k, 1 ) = z( jprev ) + k = k + 1_${ik}$ + u2( k, 1_${ik}$ ) = z( jprev ) dsigma( k ) = d( jprev ) idxp( k ) = jprev 120 continue @@ -66644,17 +66642,17 @@ module stdlib_linalg_lapack_d ! four groups of uniform structure (although one or more of these ! groups may be empty). do j = 1, 4 - ctot( j ) = 0 + ctot( j ) = 0_${ik}$ end do do j = 2, n ct = coltyp( j ) - ctot( ct ) = ctot( ct ) + 1 + ctot( ct ) = ctot( ct ) + 1_${ik}$ end do ! psm(*) = position in submatrix (of types 1 through 4) - psm( 1 ) = 2 - psm( 2 ) = 2 + ctot( 1 ) - psm( 3 ) = psm( 2 ) + ctot( 2 ) - psm( 4 ) = psm( 3 ) + ctot( 3 ) + psm( 1_${ik}$ ) = 2_${ik}$ + psm( 2_${ik}$ ) = 2_${ik}$ + ctot( 1_${ik}$ ) + psm( 3_${ik}$ ) = psm( 2_${ik}$ ) + ctot( 2_${ik}$ ) + psm( 4_${ik}$ ) = psm( 3_${ik}$ ) + ctot( 3_${ik}$ ) ! fill out the idxc array so that the permutation which it induces ! will place all type-1 columns first, all type-2 columns next, ! then all type-3's, and finally all type-4's, starting from the @@ -66663,7 +66661,7 @@ module stdlib_linalg_lapack_d jp = idxp( j ) ct = coltyp( jp ) idxc( psm( ct ) ) = j - psm( ct ) = psm( ct ) + 1 + psm( ct ) = psm( ct ) + 1_${ik}$ end do ! sort the singular values and corresponding singular vectors into ! dsigma, u2, and vt2 respectively. the singular values/vectors @@ -66674,71 +66672,71 @@ module stdlib_linalg_lapack_d do j = 2, n jp = idxp( j ) dsigma( j ) = d( jp ) - idxj = idxq( idx( idxp( idxc( j ) ) )+1 ) + idxj = idxq( idx( idxp( idxc( j ) ) )+1_${ik}$ ) if( idxj<=nlp1 ) then - idxj = idxj - 1 + idxj = idxj - 1_${ik}$ end if - call stdlib_dcopy( n, u( 1, idxj ), 1, u2( 1, j ), 1 ) - call stdlib_dcopy( m, vt( idxj, 1 ), ldvt, vt2( j, 1 ), ldvt2 ) + call stdlib${ii}$_dcopy( n, u( 1_${ik}$, idxj ), 1_${ik}$, u2( 1_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_dcopy( m, vt( idxj, 1_${ik}$ ), ldvt, vt2( j, 1_${ik}$ ), ldvt2 ) end do ! determine dsigma(1), dsigma(2) and z(1) - 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_dlapy2( z1, z( m ) ) - if( z( 1 )<=tol ) then + z( 1_${ik}$ ) = stdlib${ii}$_dlapy2( 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 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 ! move the rest of the updating row to z. - call stdlib_dcopy( k-1, u2( 2, 1 ), 1, z( 2 ), 1 ) + call stdlib${ii}$_dcopy( k-1, u2( 2_${ik}$, 1_${ik}$ ), 1_${ik}$, z( 2_${ik}$ ), 1_${ik}$ ) ! determine the first column of u2, the first row of vt2 and the ! last row of vt. - call stdlib_dlaset( 'A', n, 1, zero, zero, u2, ldu2 ) - u2( nlp1, 1 ) = one + call stdlib${ii}$_dlaset( 'A', n, 1_${ik}$, zero, zero, u2, ldu2 ) + u2( nlp1, 1_${ik}$ ) = one if( m>n ) then do i = 1, nlp1 vt( m, i ) = -s*vt( nlp1, i ) - vt2( 1, i ) = c*vt( nlp1, i ) + vt2( 1_${ik}$, i ) = c*vt( nlp1, i ) end do do i = nlp2, m - vt2( 1, i ) = s*vt( m, i ) + vt2( 1_${ik}$, i ) = s*vt( m, i ) vt( m, i ) = c*vt( m, i ) end do else - call stdlib_dcopy( m, vt( nlp1, 1 ), ldvt, vt2( 1, 1 ), ldvt2 ) + call stdlib${ii}$_dcopy( m, vt( nlp1, 1_${ik}$ ), ldvt, vt2( 1_${ik}$, 1_${ik}$ ), ldvt2 ) end if if( m>n ) then - call stdlib_dcopy( m, vt( m, 1 ), ldvt, vt2( m, 1 ), ldvt2 ) + call stdlib${ii}$_dcopy( m, vt( m, 1_${ik}$ ), ldvt, vt2( m, 1_${ik}$ ), ldvt2 ) end if ! the deflated singular values and their corresponding vectors go ! into the back of d, u, and v respectively. if( n>k ) then - call stdlib_dcopy( n-k, dsigma( k+1 ), 1, d( k+1 ), 1 ) - call stdlib_dlacpy( 'A', n, n-k, u2( 1, k+1 ), ldu2, u( 1, k+1 ),ldu ) - call stdlib_dlacpy( 'A', n-k, m, vt2( k+1, 1 ), ldvt2, vt( k+1, 1 ),ldvt ) + call stdlib${ii}$_dcopy( n-k, dsigma( k+1 ), 1_${ik}$, d( k+1 ), 1_${ik}$ ) + call stdlib${ii}$_dlacpy( 'A', n, n-k, u2( 1_${ik}$, k+1 ), ldu2, u( 1_${ik}$, k+1 ),ldu ) + call stdlib${ii}$_dlacpy( 'A', n-k, m, vt2( k+1, 1_${ik}$ ), ldvt2, vt( k+1, 1_${ik}$ ),ldvt ) end if - ! copy ctot into coltyp for referencing in stdlib_dlasd3. + ! copy ctot into coltyp for referencing in stdlib${ii}$_dlasd3. do j = 1, 4 coltyp( j ) = ctot( j ) end do return - end subroutine stdlib_dlasd2 + end subroutine stdlib${ii}$_dlasd2 - pure subroutine stdlib_dlaswlq( m, n, mb, nb, a, lda, t, ldt, work, lwork,info) + pure subroutine stdlib${ii}$_dlaswlq( m, n, mb, nb, a, lda, t, ldt, work, lwork,info) !! DLASWLQ computes a blocked Tall-Skinny LQ factorization of !! a real M-by-N matrix A for M <= N: !! A = ( L 0 ) * Q, @@ -66753,76 +66751,76 @@ module stdlib_linalg_lapack_d ! -- 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, mb, nb, lwork, ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, mb, nb, lwork, ldt ! Array Arguments real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: work(*), t(ldt,*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, ii, kk, ctr + integer(${ik}$) :: i, ii, kk, ctr ! External Subroutines intrinsic :: max,min,mod ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 .or. nm .and. m>0 )) then - info = -3 - else if( nb<0 ) then - info = -4 - else if( ldam .and. m>0_${ik}$ )) then + info = -3_${ik}$ + else if( nb<0_${ik}$ ) then + info = -4_${ik}$ + else if( lda=n).or.(nb<=m).or.(nb>=n)) then - call stdlib_dgelqt( m, n, mb, a, lda, t, ldt, work, info) + call stdlib${ii}$_dgelqt( m, n, mb, a, lda, t, ldt, work, info) return end if kk = mod((n-m),(nb-m)) ii=n-kk+1 ! compute the lq factorization of the first block a(1:m,1:nb) - call stdlib_dgelqt( m, nb, mb, a(1,1), lda, t, ldt, work, info) - ctr = 1 + call stdlib${ii}$_dgelqt( m, nb, mb, a(1_${ik}$,1_${ik}$), lda, t, ldt, work, info) + ctr = 1_${ik}$ do i = nb+1, ii-nb+m , (nb-m) ! compute the qr factorization of the current block a(1:m,i:i+nb-m) - call stdlib_dtplqt( m, nb-m, 0, mb, a(1,1), lda, a( 1, i ),lda, t(1, ctr * m + 1),& + call stdlib${ii}$_dtplqt( m, nb-m, 0_${ik}$, mb, a(1_${ik}$,1_${ik}$), lda, a( 1_${ik}$, i ),lda, t(1_${ik}$, ctr * m + 1_${ik}$),& ldt, work, info ) - ctr = ctr + 1 + ctr = ctr + 1_${ik}$ end do ! compute the qr factorization of the last block a(1:m,ii:n) if (ii<=n) then - call stdlib_dtplqt( m, kk, 0, mb, a(1,1), lda, a( 1, ii ),lda, t(1, ctr * m + 1), & + call stdlib${ii}$_dtplqt( m, kk, 0_${ik}$, mb, a(1_${ik}$,1_${ik}$), lda, a( 1_${ik}$, ii ),lda, t(1_${ik}$, ctr * m + 1_${ik}$), & ldt,work, info ) end if - work( 1 ) = m * mb + work( 1_${ik}$ ) = m * mb return - end subroutine stdlib_dlaswlq + end subroutine stdlib${ii}$_dlaswlq - pure subroutine stdlib_dlatsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) + pure subroutine stdlib${ii}$_dlatsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) !! DLATSQR computes a blocked Tall-Skinny QR factorization of !! a real M-by-N matrix A for M >= N: !! A = Q * ( R ), @@ -66838,76 +66836,76 @@ module stdlib_linalg_lapack_d ! -- 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, mb, nb, ldt, lwork + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, mb, nb, ldt, lwork ! Array Arguments real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: work(*), t(ldt,*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, ii, kk, ctr + integer(${ik}$) :: i, ii, kk, ctr ! External Subroutines intrinsic :: max,min,mod ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 .or. mn .and. n>0 )) then - info = -4 - else if( ldan .and. n>0_${ik}$ )) then + info = -4_${ik}$ + else if( lda=m)) then - call stdlib_dgeqrt( m, n, nb, a, lda, t, ldt, work, info) + call stdlib${ii}$_dgeqrt( m, n, nb, a, lda, t, ldt, work, info) return end if kk = mod((m-n),(mb-n)) ii=m-kk+1 ! compute the qr factorization of the first block a(1:mb,1:n) - call stdlib_dgeqrt( mb, n, nb, a(1,1), lda, t, ldt, work, info ) - ctr = 1 + call stdlib${ii}$_dgeqrt( mb, n, nb, a(1_${ik}$,1_${ik}$), lda, t, ldt, work, info ) + ctr = 1_${ik}$ do i = mb+1, ii-mb+n , (mb-n) ! compute the qr factorization of the current block a(i:i+mb-n,1:n) - call stdlib_dtpqrt( mb-n, n, 0, nb, a(1,1), lda, a( i, 1 ), lda,t(1, ctr * n + 1),& + call stdlib${ii}$_dtpqrt( mb-n, n, 0_${ik}$, nb, a(1_${ik}$,1_${ik}$), lda, a( i, 1_${ik}$ ), lda,t(1_${ik}$, ctr * n + 1_${ik}$),& ldt, work, info ) - ctr = ctr + 1 + ctr = ctr + 1_${ik}$ end do ! compute the qr factorization of the last block a(ii:m,1:n) if (ii<=m) then - call stdlib_dtpqrt( kk, n, 0, nb, a(1,1), lda, a( ii, 1 ), lda,t(1, ctr * n + 1), & + call stdlib${ii}$_dtpqrt( kk, n, 0_${ik}$, nb, a(1_${ik}$,1_${ik}$), lda, a( ii, 1_${ik}$ ), lda,t(1_${ik}$, ctr * n + 1_${ik}$), & ldt,work, info ) end if - work( 1 ) = n*nb + work( 1_${ik}$ ) = n*nb return - end subroutine stdlib_dlatsqr + end subroutine stdlib${ii}$_dlatsqr - pure subroutine stdlib_dorgbr( vect, m, n, k, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_dorgbr( vect, m, n, k, a, lda, tau, work, lwork, info ) !! DORGBR generates one of the real orthogonal matrices Q or P**T !! determined by DGEBRD when reducing a real matrix A to bidiagonal !! form: A = Q * B * P**T. Q and P**T are defined as products of @@ -66929,8 +66927,8 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: vect - 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(dp), intent(inout) :: a(lda,*) real(dp), intent(in) :: tau(*) @@ -66939,124 +66937,124 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: lquery, wantq - integer(ilp) :: i, iinfo, j, lwkopt, mn + integer(${ik}$) :: i, iinfo, j, lwkopt, mn ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ wantq = stdlib_lsame( vect, 'Q' ) mn = min( m, n ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) if( .not.wantq .and. .not.stdlib_lsame( vect, 'P' ) ) then - info = -1 - else if( m<0 ) then - info = -2 - else if( n<0 .or. ( wantq .and. ( n>m .or. nm .or. nn .or. m=k ) then - call stdlib_dorgqr( m, n, k, a, lda, tau, work, -1, iinfo ) + call stdlib${ii}$_dorgqr( m, n, k, a, lda, tau, work, -1_${ik}$, iinfo ) else - if( m>1 ) then - call stdlib_dorgqr( m-1, m-1, m-1, a, lda, tau, work, -1,iinfo ) + if( m>1_${ik}$ ) then + call stdlib${ii}$_dorgqr( m-1, m-1, m-1, a, lda, tau, work, -1_${ik}$,iinfo ) end if end if else if( k1 ) then - call stdlib_dorglq( n-1, n-1, n-1, a, lda, tau, work, -1,iinfo ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_dorglq( n-1, n-1, n-1, a, lda, tau, work, -1_${ik}$,iinfo ) end if end if end if - lwkopt = work( 1 ) + lwkopt = work( 1_${ik}$ ) lwkopt = max (lwkopt, mn) end if - if( info/=0 ) then - call stdlib_xerbla( 'DORGBR', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DORGBR', -info ) return else if( lquery ) then - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return end if ! quick return if possible - if( m==0 .or. n==0 ) then - work( 1 ) = 1 + if( m==0_${ik}$ .or. n==0_${ik}$ ) then + work( 1_${ik}$ ) = 1_${ik}$ return end if if( wantq ) then - ! form q, determined by a call to stdlib_dgebrd to reduce an m-by-k + ! form q, determined by a call to stdlib${ii}$_dgebrd to reduce an m-by-k ! matrix if( m>=k ) then ! if m >= k, assume m >= n >= k - call stdlib_dorgqr( m, n, k, a, lda, tau, work, lwork, iinfo ) + call stdlib${ii}$_dorgqr( m, n, k, a, lda, tau, work, lwork, iinfo ) else ! if m < k, assume m = n ! shift the vectors which define the elementary reflectors one ! column to the right, and set the first row and column of q ! to those of the unit matrix do j = m, 2, -1 - a( 1, j ) = zero + a( 1_${ik}$, j ) = zero do i = j + 1, m a( i, j ) = a( i, j-1 ) end do end do - a( 1, 1 ) = one + a( 1_${ik}$, 1_${ik}$ ) = one do i = 2, m - a( i, 1 ) = zero + a( i, 1_${ik}$ ) = zero end do - if( m>1 ) then + if( m>1_${ik}$ ) then ! form q(2:m,2:m) - call stdlib_dorgqr( m-1, m-1, m-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) + call stdlib${ii}$_dorgqr( m-1, m-1, m-1, a( 2_${ik}$, 2_${ik}$ ), lda, tau, work,lwork, iinfo ) end if end if else - ! form p**t, determined by a call to stdlib_dgebrd to reduce a k-by-n + ! form p**t, determined by a call to stdlib${ii}$_dgebrd to reduce a k-by-n ! matrix if( k= n, assume m = n ! shift the vectors which define the elementary reflectors one ! row downward, and set the first row and column of p**t to ! those of the unit matrix - a( 1, 1 ) = one + a( 1_${ik}$, 1_${ik}$ ) = one do i = 2, n - a( i, 1 ) = zero + a( i, 1_${ik}$ ) = zero end do do j = 2, n do i = j - 1, 2, -1 a( i, j ) = a( i-1, j ) end do - a( 1, j ) = zero + a( 1_${ik}$, j ) = zero end do - if( n>1 ) then + if( n>1_${ik}$ ) then ! form p**t(2:n,2:n) - call stdlib_dorglq( n-1, n-1, n-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) + call stdlib${ii}$_dorglq( n-1, n-1, n-1, a( 2_${ik}$, 2_${ik}$ ), lda, tau, work,lwork, iinfo ) end if end if end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_dorgbr + end subroutine stdlib${ii}$_dorgbr - pure subroutine stdlib_dormbr( vect, side, trans, m, n, k, a, lda, tau, c,ldc, work, lwork, & + pure subroutine stdlib${ii}$_dormbr( vect, side, trans, m, n, k, a, lda, tau, c,ldc, work, lwork, & !! If VECT = 'Q', DORMBR: overwrites the general real M-by-N matrix C !! with !! SIDE = 'L' SIDE = 'R' @@ -67085,8 +67083,8 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: side, trans, vect - 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(dp), intent(inout) :: a(lda,*), c(ldc,*) real(dp), intent(in) :: tau(*) @@ -67095,90 +67093,90 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: applyq, left, lquery, notran character :: transt - integer(ilp) :: i1, i2, iinfo, lwkopt, mi, nb, ni, nq, nw + integer(${ik}$) :: i1, i2, iinfo, lwkopt, mi, nb, ni, nq, nw ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ applyq = stdlib_lsame( vect, 'Q' ) left = stdlib_lsame( side, 'L' ) notran = stdlib_lsame( trans, 'N' ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) ! nq is the order of q or p 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.applyq .and. .not.stdlib_lsame( vect, 'P' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then - info = -2 + info = -2_${ik}$ else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) ) then - info = -3 - else if( m<0 ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( k<0 ) then - info = -6 - else if( ( applyq .and. lda=k ) then - ! q was determined by a call to stdlib_dgebrd with nq >= k - call stdlib_dormqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, iinfo & + ! q was determined by a call to stdlib${ii}$_dgebrd with nq >= k + call stdlib${ii}$_dormqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, iinfo & ) - else if( nq>1 ) then - ! q was determined by a call to stdlib_dgebrd with nq < k + else if( nq>1_${ik}$ ) then + ! q was determined by a call to stdlib${ii}$_dgebrd with nq < k if( left ) then - mi = m - 1 + mi = m - 1_${ik}$ ni = n - i1 = 2 - i2 = 1 + i1 = 2_${ik}$ + i2 = 1_${ik}$ else mi = m - ni = n - 1 - i1 = 1 - i2 = 2 + ni = n - 1_${ik}$ + i1 = 1_${ik}$ + i2 = 2_${ik}$ end if - call stdlib_dormqr( side, trans, mi, ni, nq-1, a( 2, 1 ), lda, tau,c( i1, i2 ), & + call stdlib${ii}$_dormqr( side, trans, mi, ni, nq-1, a( 2_${ik}$, 1_${ik}$ ), lda, tau,c( i1, i2 ), & ldc, work, lwork, iinfo ) end if else @@ -67189,32 +67187,32 @@ module stdlib_linalg_lapack_d transt = 'N' end if if( nq>k ) then - ! p was determined by a call to stdlib_dgebrd with nq > k - call stdlib_dormlq( side, transt, m, n, k, a, lda, tau, c, ldc,work, lwork, & + ! p was determined by a call to stdlib${ii}$_dgebrd with nq > k + call stdlib${ii}$_dormlq( side, transt, m, n, k, a, lda, tau, c, ldc,work, lwork, & iinfo ) - else if( nq>1 ) then - ! p was determined by a call to stdlib_dgebrd with nq <= k + else if( nq>1_${ik}$ ) then + ! p was determined by a call to stdlib${ii}$_dgebrd with nq <= k if( left ) then - mi = m - 1 + mi = m - 1_${ik}$ ni = n - i1 = 2 - i2 = 1 + i1 = 2_${ik}$ + i2 = 1_${ik}$ else mi = m - ni = n - 1 - i1 = 1 - i2 = 2 + ni = n - 1_${ik}$ + i1 = 1_${ik}$ + i2 = 2_${ik}$ end if - call stdlib_dormlq( side, transt, mi, ni, nq-1, a( 1, 2 ), lda,tau, c( i1, i2 ), & + call stdlib${ii}$_dormlq( side, transt, mi, ni, nq-1, a( 1_${ik}$, 2_${ik}$ ), lda,tau, c( i1, i2 ), & ldc, work, lwork, iinfo ) end if end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_dormbr + end subroutine stdlib${ii}$_dormbr - pure subroutine stdlib_dpbsv( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) + pure subroutine stdlib${ii}$_dpbsv( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) !! DPBSV computes the solution to a real system of linear equations !! A * X = B, !! where A is an N-by-N symmetric positive definite band matrix and X @@ -67231,8 +67229,8 @@ module stdlib_linalg_lapack_d ! -- 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(dp), intent(inout) :: ab(ldab,*), b(ldb,*) ! ===================================================================== @@ -67240,35 +67238,35 @@ module stdlib_linalg_lapack_d intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .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( ldab0 ) then + info = -11_${ik}$ + else if( n>0_${ik}$ ) then scond = max( smin, smlnum ) / min( smax, bignum ) else scond = one end if end if - if( info==0 ) then - if( ldb0 )then + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_dlansb( '1', uplo, n, kd, ab, ldab, work ) + anorm = stdlib${ii}$_dlansb( '1', uplo, n, kd, ab, ldab, work ) ! compute the reciprocal of the condition number of a. - call stdlib_dpbcon( uplo, n, kd, afb, ldafb, anorm, rcond, work, iwork,info ) + call stdlib${ii}$_dpbcon( uplo, n, kd, afb, ldafb, anorm, rcond, work, iwork,info ) ! compute the solution matrix x. - call stdlib_dlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_dpbtrs( uplo, n, kd, nrhs, afb, ldafb, x, ldx, info ) + call stdlib${ii}$_dlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_dpbtrs( uplo, n, kd, nrhs, afb, ldafb, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_dpbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b, ldb, x,ldx, ferr, berr,& + call stdlib${ii}$_dpbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b, ldb, x,ldx, ferr, berr,& work, iwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -67419,12 +67417,12 @@ module stdlib_linalg_lapack_d end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) - call stdlib_dpotrf( 'L', n1, a( 0 ), n, info ) + call stdlib${ii}$_dpotrf( 'L', n1, a( 0_${ik}$ ), n, info ) if( info>0 )return - call stdlib_dtrsm( 'R', 'L', 'T', 'N', n2, n1, one, a( 0 ), n,a( n1 ), n ) + call stdlib${ii}$_dtrsm( 'R', 'L', 'T', 'N', n2, n1, one, a( 0_${ik}$ ), n,a( n1 ), n ) - call stdlib_dsyrk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n ) - call stdlib_dpotrf( 'U', n2, a( n ), n, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_dsyrk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n ) + call stdlib${ii}$_dpotrf( 'U', n2, a( n ), n, info ) + if( info>0_${ik}$ )info = info + n1 else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) - call stdlib_dpotrf( 'L', n1, a( n2 ), n, info ) + call stdlib${ii}$_dpotrf( 'L', n1, a( n2 ), n, info ) if( info>0 )return - call stdlib_dtrsm( 'L', 'L', 'N', 'N', n1, n2, one, a( n2 ), n,a( 0 ), n ) + call stdlib${ii}$_dtrsm( 'L', 'L', 'N', 'N', n1, n2, one, a( n2 ), n,a( 0_${ik}$ ), n ) - call stdlib_dsyrk( 'U', 'T', n2, n1, -one, a( 0 ), n, one,a( n1 ), n ) - call stdlib_dpotrf( 'U', n2, a( n1 ), n, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_dsyrk( 'U', 'T', n2, n1, -one, a( 0_${ik}$ ), n, one,a( n1 ), n ) + call stdlib${ii}$_dpotrf( 'U', n2, a( n1 ), n, info ) + if( info>0_${ik}$ )info = info + n1 end if else ! n is odd and transr = 't' @@ -67516,26 +67514,26 @@ module stdlib_linalg_lapack_d ! srpa for lower, transpose and n is odd ! t1 -> a(0,0) , t2 -> a(1,0) , s -> a(0,n1) ! t1 -> a(0+0) , t2 -> a(1+0) , s -> a(0+n1*n1); lda=n1 - call stdlib_dpotrf( 'U', n1, a( 0 ), n1, info ) + call stdlib${ii}$_dpotrf( 'U', n1, a( 0_${ik}$ ), n1, info ) if( info>0 )return - call stdlib_dtrsm( 'L', 'U', 'T', 'N', n1, n2, one, a( 0 ), n1,a( n1*n1 ), n1 & + call stdlib${ii}$_dtrsm( 'L', 'U', 'T', 'N', n1, n2, one, a( 0_${ik}$ ), n1,a( n1*n1 ), n1 & ) - call stdlib_dsyrk( 'L', 'T', n2, n1, -one, a( n1*n1 ), n1, one,a( 1 ), n1 ) + call stdlib${ii}$_dsyrk( 'L', 'T', n2, n1, -one, a( n1*n1 ), n1, one,a( 1_${ik}$ ), n1 ) - call stdlib_dpotrf( 'L', n2, a( 1 ), n1, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_dpotrf( 'L', n2, a( 1_${ik}$ ), n1, info ) + if( info>0_${ik}$ )info = info + n1 else ! srpa for upper, transpose and n is odd ! t1 -> a(0,n1+1), t2 -> a(0,n1), s -> a(0,0) ! t1 -> a(n2*n2), t2 -> a(n1*n2), s -> a(0); lda = n2 - call stdlib_dpotrf( 'U', n1, a( n2*n2 ), n2, info ) + call stdlib${ii}$_dpotrf( 'U', n1, a( n2*n2 ), n2, info ) if( info>0 )return - call stdlib_dtrsm( 'R', 'U', 'N', 'N', n2, n1, one, a( n2*n2 ),n2, a( 0 ), n2 & + call stdlib${ii}$_dtrsm( 'R', 'U', 'N', 'N', n2, n1, one, a( n2*n2 ),n2, a( 0_${ik}$ ), n2 & ) - call stdlib_dsyrk( 'L', 'N', n2, n1, -one, a( 0 ), n2, one,a( n1*n2 ), n2 ) + call stdlib${ii}$_dsyrk( 'L', 'N', n2, n1, -one, a( 0_${ik}$ ), n2, one,a( n1*n2 ), n2 ) - call stdlib_dpotrf( 'L', n2, a( n1*n2 ), n2, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_dpotrf( 'L', n2, a( n1*n2 ), n2, info ) + if( info>0_${ik}$ )info = info + n1 end if end if else @@ -67546,26 +67544,26 @@ module stdlib_linalg_lapack_d ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) - call stdlib_dpotrf( 'L', k, a( 1 ), n+1, info ) + call stdlib${ii}$_dpotrf( 'L', k, a( 1_${ik}$ ), n+1, info ) if( info>0 )return - call stdlib_dtrsm( 'R', 'L', 'T', 'N', k, k, one, a( 1 ), n+1,a( k+1 ), n+1 ) + call stdlib${ii}$_dtrsm( 'R', 'L', 'T', 'N', k, k, one, a( 1_${ik}$ ), n+1,a( k+1 ), n+1 ) - call stdlib_dsyrk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0 ), n+1 ) + call stdlib${ii}$_dsyrk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0_${ik}$ ), n+1 ) - call stdlib_dpotrf( 'U', k, a( 0 ), n+1, info ) - if( info>0 )info = info + k + call stdlib${ii}$_dpotrf( 'U', k, a( 0_${ik}$ ), n+1, info ) + if( info>0_${ik}$ )info = info + k else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) - call stdlib_dpotrf( 'L', k, a( k+1 ), n+1, info ) + call stdlib${ii}$_dpotrf( 'L', k, a( k+1 ), n+1, info ) if( info>0 )return - call stdlib_dtrsm( 'L', 'L', 'N', 'N', k, k, one, a( k+1 ),n+1, a( 0 ), n+1 ) + call stdlib${ii}$_dtrsm( 'L', 'L', 'N', 'N', k, k, one, a( k+1 ),n+1, a( 0_${ik}$ ), n+1 ) - call stdlib_dsyrk( 'U', 'T', k, k, -one, a( 0 ), n+1, one,a( k ), n+1 ) + call stdlib${ii}$_dsyrk( 'U', 'T', k, k, -one, a( 0_${ik}$ ), n+1, one,a( k ), n+1 ) - call stdlib_dpotrf( 'U', k, a( k ), n+1, info ) - if( info>0 )info = info + k + call stdlib${ii}$_dpotrf( 'U', k, a( k ), n+1, info ) + if( info>0_${ik}$ )info = info + k end if else ! n is even and transr = 't' @@ -67573,33 +67571,33 @@ module stdlib_linalg_lapack_d ! srpa for lower, transpose and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1) ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k - call stdlib_dpotrf( 'U', k, a( 0+k ), k, info ) + call stdlib${ii}$_dpotrf( 'U', k, a( 0_${ik}$+k ), k, info ) if( info>0 )return - call stdlib_dtrsm( 'L', 'U', 'T', 'N', k, k, one, a( k ), n1,a( k*( k+1 ) ), & + call stdlib${ii}$_dtrsm( 'L', 'U', 'T', 'N', k, k, one, a( k ), n1,a( k*( k+1 ) ), & k ) - call stdlib_dsyrk( 'L', 'T', k, k, -one, a( k*( k+1 ) ), k, one,a( 0 ), k ) + call stdlib${ii}$_dsyrk( 'L', 'T', k, k, -one, a( k*( k+1 ) ), k, one,a( 0_${ik}$ ), k ) - call stdlib_dpotrf( 'L', k, a( 0 ), k, info ) - if( info>0 )info = info + k + call stdlib${ii}$_dpotrf( 'L', k, a( 0_${ik}$ ), k, info ) + if( info>0_${ik}$ )info = info + k else ! srpa for upper, transpose and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0) ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k - call stdlib_dpotrf( 'U', k, a( k*( k+1 ) ), k, info ) + call stdlib${ii}$_dpotrf( 'U', k, a( k*( k+1 ) ), k, info ) if( info>0 )return - call stdlib_dtrsm( 'R', 'U', 'N', 'N', k, k, one,a( k*( k+1 ) ), k, a( 0 ), k & + call stdlib${ii}$_dtrsm( 'R', 'U', 'N', 'N', k, k, one,a( k*( k+1 ) ), k, a( 0_${ik}$ ), k & ) - call stdlib_dsyrk( 'L', 'N', k, k, -one, a( 0 ), k, one,a( k*k ), k ) - call stdlib_dpotrf( 'L', k, a( k*k ), k, info ) - if( info>0 )info = info + k + call stdlib${ii}$_dsyrk( 'L', 'N', k, k, -one, a( 0_${ik}$ ), k, one,a( k*k ), k ) + call stdlib${ii}$_dpotrf( 'L', k, a( k*k ), k, info ) + if( info>0_${ik}$ )info = info + k end if end if end if return - end subroutine stdlib_dpftrf + end subroutine stdlib${ii}$_dpftrf - pure subroutine stdlib_dposv( uplo, n, nrhs, a, lda, b, ldb, info ) + pure subroutine stdlib${ii}$_dposv( uplo, n, nrhs, a, lda, b, ldb, info ) !! DPOSV computes the solution to a real system of linear equations !! A * X = B, !! where A is an N-by-N symmetric positive definite matrix and X and B @@ -67615,8 +67613,8 @@ module stdlib_linalg_lapack_d ! -- 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 real(dp), intent(inout) :: a(lda,*), b(ldb,*) ! ===================================================================== @@ -67624,33 +67622,33 @@ module stdlib_linalg_lapack_d intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .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 + info = -10_${ik}$ + else if( n>0_${ik}$ ) then scond = max( smin, smlnum ) / min( smax, bignum ) else scond = one end if end if - if( info==0 ) then - if( ldb0 )then + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_dlansy( '1', uplo, n, a, lda, work ) + anorm = stdlib${ii}$_dlansy( '1', uplo, n, a, lda, work ) ! compute the reciprocal of the condition number of a. - call stdlib_dpocon( uplo, n, af, ldaf, anorm, rcond, work, iwork, info ) + call stdlib${ii}$_dpocon( uplo, n, af, ldaf, anorm, rcond, work, iwork, info ) ! compute the solution matrix x. - call stdlib_dlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_dpotrs( uplo, n, nrhs, af, ldaf, x, ldx, info ) + call stdlib${ii}$_dlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_dpotrs( uplo, n, nrhs, af, ldaf, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_dporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x, ldx,ferr, berr, work, & + call stdlib${ii}$_dporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x, ldx,ferr, berr, work, & iwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -67788,12 +67786,12 @@ module stdlib_linalg_lapack_d end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcondn ).and.( n>0 )) then - info = -7 - else if(( ilst<1 .or. ilst>n ).and.( n>0 )) then - info = -8 - end if - if( info/=0 ) then - call stdlib_xerbla( 'DTREXC', -info ) + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ + else if( ldtn ).and.( n>0_${ik}$ )) then + info = -7_${ik}$ + else if(( ilst<1_${ik}$ .or. ilst>n ).and.( n>0_${ik}$ )) then + info = -8_${ik}$ + end if + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DTREXC', -info ) return end if ! quick return if possible if( n<=1 )return ! determine the first row of specified block ! and find out it is 1 by 1 or 2 by 2. - if( ifst>1 ) then - if( t( ifst, ifst-1 )/=zero )ifst = ifst - 1 + if( ifst>1_${ik}$ ) then + if( t( ifst, ifst-1 )/=zero )ifst = ifst - 1_${ik}$ end if - nbf = 1 + nbf = 1_${ik}$ if( ifst1 ) then - if( t( ilst, ilst-1 )/=zero )ilst = ilst - 1 + if( ilst>1_${ik}$ ) then + if( t( ilst, ilst-1 )/=zero )ilst = ilst - 1_${ik}$ end if - nbl = 1 + nbl = 1_${ik}$ if( ilst=3 ) then - if( t( here-1, here-2 )/=zero )nbnext = 2 + nbnext = 1_${ik}$ + if( here>=3_${ik}$ ) then + if( t( here-1, here-2 )/=zero )nbnext = 2_${ik}$ end if - call stdlib_dlaexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext,nbf, work, & + call stdlib${ii}$_dlaexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext,nbf, work, & info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then ilst = here return end if here = here - nbnext ! test if 2 by 2 block breaks into two 1 by 1 blocks - if( nbf==2 ) then - if( t( here+1, here )==zero )nbf = 3 + if( nbf==2_${ik}$ ) then + if( t( here+1, here )==zero )nbf = 3_${ik}$ end if else ! current block consists of two 1 by 1 blocks each of which ! must be swapped individually - nbnext = 1 - if( here>=3 ) then - if( t( here-1, here-2 )/=zero )nbnext = 2 + nbnext = 1_${ik}$ + if( here>=3_${ik}$ ) then + if( t( here-1, here-2 )/=zero )nbnext = 2_${ik}$ end if - call stdlib_dlaexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext,1, work, info ) + call stdlib${ii}$_dlaexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext,1_${ik}$, work, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then ilst = here return end if - if( nbnext==1 ) then + if( nbnext==1_${ik}$ ) then ! swap two 1 by 1 blocks, no problems possible - call stdlib_dlaexc( wantq, n, t, ldt, q, ldq, here, nbnext, 1,work, info ) + call stdlib${ii}$_dlaexc( wantq, n, t, ldt, q, ldq, here, nbnext, 1_${ik}$,work, info ) - here = here - 1 + here = here - 1_${ik}$ else ! recompute nbnext in case 2 by 2 split - if( t( here, here-1 )==zero )nbnext = 1 - if( nbnext==2 ) then + if( t( here, here-1 )==zero )nbnext = 1_${ik}$ + if( nbnext==2_${ik}$ ) then ! 2 by 2 block did not split - call stdlib_dlaexc( wantq, n, t, ldt, q, ldq, here-1, 2, 1,work, info ) + call stdlib${ii}$_dlaexc( wantq, n, t, ldt, q, ldq, here-1, 2_${ik}$, 1_${ik}$,work, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then ilst = here return end if - here = here - 2 + here = here - 2_${ik}$ else ! 2 by 2 block did split - call stdlib_dlaexc( wantq, n, t, ldt, q, ldq, here, 1, 1,work, info ) + call stdlib${ii}$_dlaexc( wantq, n, t, ldt, q, ldq, here, 1_${ik}$, 1_${ik}$,work, info ) - call stdlib_dlaexc( wantq, n, t, ldt, q, ldq, here-1, 1, 1,work, info ) + call stdlib${ii}$_dlaexc( wantq, n, t, ldt, q, ldq, here-1, 1_${ik}$, 1_${ik}$,work, info ) - here = here - 2 + here = here - 2_${ik}$ end if end if end if @@ -67994,10 +67992,10 @@ module stdlib_linalg_lapack_d end if ilst = here return - end subroutine stdlib_dtrexc + end subroutine stdlib${ii}$_dtrexc - subroutine stdlib_dtrsen( job, compq, select, n, t, ldt, q, ldq, wr, wi,m, s, sep, work, & + subroutine stdlib${ii}$_dtrsen( job, compq, select, n, t, ldt, q, ldq, wr, wi,m, s, sep, work, & !! DTRSEN reorders the real Schur factorization of a real matrix !! A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in !! the leading diagonal blocks of the upper quasi-triangular matrix T, @@ -68015,22 +68013,22 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: compq, job - integer(ilp), intent(out) :: info, m - integer(ilp), intent(in) :: ldq, ldt, liwork, lwork, n + integer(${ik}$), intent(out) :: info, m + integer(${ik}$), intent(in) :: ldq, ldt, liwork, lwork, n real(dp), intent(out) :: s, sep ! Array Arguments logical(lk), intent(in) :: select(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(inout) :: q(ldq,*), t(ldt,*) real(dp), intent(out) :: wi(*), work(*), wr(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, pair, swap, wantbh, wantq, wants, wantsp - integer(ilp) :: ierr, k, kase, kk, ks, liwmin, lwmin, n1, n2, nn + integer(${ik}$) :: ierr, k, kase, kk, ks, liwmin, lwmin, n1, n2, nn real(dp) :: est, rnorm, scale ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements @@ -68039,22 +68037,22 @@ module stdlib_linalg_lapack_d wants = stdlib_lsame( job, 'E' ) .or. wantbh wantsp = stdlib_lsame( job, 'V' ) .or. wantbh wantq = stdlib_lsame( compq, 'V' ) - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) if( .not.stdlib_lsame( job, 'N' ) .and. .not.wants .and. .not.wantsp )then - info = -1 + info = -1_${ik}$ else if( .not.stdlib_lsame( compq, 'N' ) .and. .not.wantq ) then - info = -2 - else if( n<0 ) then - info = -4 - else if( ldt= N. The SVD of [A] is written as !! [A] = [U] * [SIGMA] * [V]^t, @@ -68455,19 +68453,19 @@ module stdlib_linalg_lapack_d ! -- 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, ldu, ldv, lwork, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldu, ldv, lwork, m, n ! Array Arguments real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: sva(n), u(ldu,*), v(ldv,*), work(lwork) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) character, intent(in) :: joba, jobp, jobr, jobt, jobu, jobv ! =========================================================================== ! Local Scalars real(dp) :: aapp, aaqq, aatmax, aatmin, big, big1, cond_ok, condr1, condr2, entra, & entrat, epsln, maxprj, scalem, sconda, sfmin, small, temp1, uscal1, uscal2, xsc - integer(ilp) :: ierr, n1, nr, numrank, p, q, warning + integer(${ik}$) :: ierr, n1, nr, numrank, p, q, warning logical(lk) :: almort, defr, errest, goscal, jracc, kill, lsvec, l2aber, l2kill, & l2pert, l2rank, l2tran, noscal, rowpiv, rsvec, transp ! Intrinsic Functions @@ -68486,50 +68484,50 @@ module stdlib_linalg_lapack_d l2pert = stdlib_lsame( jobp, 'P' ) if ( .not.(rowpiv .or. l2rank .or. l2aber .or.errest .or. stdlib_lsame( joba, 'C' ) )) & then - info = - 1 + info = - 1_${ik}$ else if ( .not.( lsvec .or. stdlib_lsame( jobu, 'N' ) .or.stdlib_lsame( jobu, 'W' )) )& then - info = - 2 + info = - 2_${ik}$ else if ( .not.( rsvec .or. stdlib_lsame( jobv, 'N' ) .or.stdlib_lsame( jobv, 'W' )) & .or. ( jracc .and. (.not.lsvec) ) ) then - info = - 3 + info = - 3_${ik}$ else if ( .not. ( l2kill .or. defr ) ) then - info = - 4 + info = - 4_${ik}$ else if ( .not. ( l2tran .or. stdlib_lsame( jobt, 'N' ) ) ) then - info = - 5 + info = - 5_${ik}$ else if ( .not. ( l2pert .or. stdlib_lsame( jobp, 'N' ) ) ) then - info = - 6 - else if ( m < 0 ) then - info = - 7 - else if ( ( n < 0 ) .or. ( n > m ) ) then - info = - 8 + info = - 6_${ik}$ + else if ( m < 0_${ik}$ ) then + info = - 7_${ik}$ + else if ( ( n < 0_${ik}$ ) .or. ( n > m ) ) then + info = - 8_${ik}$ else if ( lda < m ) then - info = - 10 + info = - 10_${ik}$ else if ( lsvec .and. ( ldu < m ) ) then - info = - 13 + info = - 13_${ik}$ else if ( rsvec .and. ( ldv < n ) ) then - info = - 15 - else if ( (.not.(lsvec .or. rsvec .or. errest).and.(lwork < max(7,4*n+1,2*m+n))) .or.(& - .not.(lsvec .or. rsvec) .and. errest .and.(lwork < max(7,4*n+n*n,2*m+n))) .or.(lsvec & - .and. (.not.rsvec) .and. (lwork < max(7,2*m+n,4*n+1))).or.(rsvec .and. (.not.lsvec) & - .and. (lwork < max(7,2*m+n,4*n+1))).or.(lsvec .and. rsvec .and. (.not.jracc) .and.(& - lwork big ) then - info = - 9 - call stdlib_xerbla( 'DGEJSV', -info ) + info = - 9_${ik}$ + call stdlib${ii}$_xerbla( 'DGEJSV', -info ) return end if aaqq = sqrt(aaqq) @@ -68568,7 +68566,7 @@ module stdlib_linalg_lapack_d sva(p) = aapp * ( aaqq * scalem ) if ( goscal ) then goscal = .false. - call stdlib_dscal( p-1, scalem, sva, 1 ) + call stdlib${ii}$_dscal( p-1, scalem, sva, 1_${ik}$ ) end if end if end do @@ -68582,76 +68580,76 @@ module stdlib_linalg_lapack_d ! quick return for zero m x n matrix ! #:) if ( aapp == zero ) then - if ( lsvec ) call stdlib_dlaset( 'G', m, n1, zero, one, u, ldu ) - if ( rsvec ) call stdlib_dlaset( 'G', n, n, zero, one, v, ldv ) - work(1) = one - work(2) = one - if ( errest ) work(3) = one + if ( lsvec ) call stdlib${ii}$_dlaset( 'G', m, n1, zero, one, u, ldu ) + if ( rsvec ) call stdlib${ii}$_dlaset( 'G', n, n, zero, one, v, ldv ) + work(1_${ik}$) = one + work(2_${ik}$) = one + if ( errest ) work(3_${ik}$) = one if ( lsvec .and. rsvec ) then - work(4) = one - work(5) = one + work(4_${ik}$) = one + work(5_${ik}$) = one end if if ( l2tran ) then - work(6) = zero - work(7) = zero + work(6_${ik}$) = zero + work(7_${ik}$) = zero end if - iwork(1) = 0 - iwork(2) = 0 - iwork(3) = 0 + iwork(1_${ik}$) = 0_${ik}$ + iwork(2_${ik}$) = 0_${ik}$ + iwork(3_${ik}$) = 0_${ik}$ return end if ! issue warning if denormalized column norms detected. override the ! high relative accuracy request. issue licence to kill columns ! (set them to zero) whose norm is less than sigma_max / big (roughly). ! #:( - warning = 0 + warning = 0_${ik}$ if ( aaqq <= sfmin ) then l2rank = .true. l2kill = .true. - warning = 1 + warning = 1_${ik}$ end if ! quick return for one-column matrix ! #:) - if ( n == 1 ) then + if ( n == 1_${ik}$ ) then if ( lsvec ) then - call stdlib_dlascl( 'G',0,0,sva(1),scalem, m,1,a(1,1),lda,ierr ) - call stdlib_dlacpy( 'A', m, 1, a, lda, u, ldu ) + call stdlib${ii}$_dlascl( 'G',0_${ik}$,0_${ik}$,sva(1_${ik}$),scalem, m,1_${ik}$,a(1_${ik}$,1_${ik}$),lda,ierr ) + call stdlib${ii}$_dlacpy( 'A', m, 1_${ik}$, a, lda, u, ldu ) ! computing all m left singular vectors of the m x 1 matrix if ( n1 /= n ) then - call stdlib_dgeqrf( m, n, u,ldu, work, work(n+1),lwork-n,ierr ) - call stdlib_dorgqr( m,n1,1, u,ldu,work,work(n+1),lwork-n,ierr ) - call stdlib_dcopy( m, a(1,1), 1, u(1,1), 1 ) + call stdlib${ii}$_dgeqrf( m, n, u,ldu, work, work(n+1),lwork-n,ierr ) + call stdlib${ii}$_dorgqr( m,n1,1_${ik}$, u,ldu,work,work(n+1),lwork-n,ierr ) + call stdlib${ii}$_dcopy( m, a(1_${ik}$,1_${ik}$), 1_${ik}$, u(1_${ik}$,1_${ik}$), 1_${ik}$ ) end if end if if ( rsvec ) then - v(1,1) = one + v(1_${ik}$,1_${ik}$) = one end if - if ( sva(1) < (big*scalem) ) then - sva(1) = sva(1) / scalem + if ( sva(1_${ik}$) < (big*scalem) ) then + sva(1_${ik}$) = sva(1_${ik}$) / scalem scalem = one end if - work(1) = one / scalem - work(2) = one - if ( sva(1) /= zero ) then - iwork(1) = 1 - if ( ( sva(1) / scalem) >= sfmin ) then - iwork(2) = 1 + work(1_${ik}$) = one / scalem + work(2_${ik}$) = one + if ( sva(1_${ik}$) /= zero ) then + iwork(1_${ik}$) = 1_${ik}$ + if ( ( sva(1_${ik}$) / scalem) >= sfmin ) then + iwork(2_${ik}$) = 1_${ik}$ else - iwork(2) = 0 + iwork(2_${ik}$) = 0_${ik}$ end if else - iwork(1) = 0 - iwork(2) = 0 + iwork(1_${ik}$) = 0_${ik}$ + iwork(2_${ik}$) = 0_${ik}$ end if - iwork(3) = 0 - if ( errest ) work(3) = one + iwork(3_${ik}$) = 0_${ik}$ + if ( errest ) work(3_${ik}$) = one if ( lsvec .and. rsvec ) then - work(4) = one - work(5) = one + work(4_${ik}$) = one + work(5_${ik}$) = one end if if ( l2tran ) then - work(6) = zero - work(7) = zero + work(6_${ik}$) = zero + work(7_${ik}$) = zero end if return end if @@ -68668,8 +68666,8 @@ module stdlib_linalg_lapack_d do p = 1, m xsc = zero temp1 = one - call stdlib_dlassq( n, a(p,1), lda, xsc, temp1 ) - ! stdlib_dlassq gets both the ell_2 and the ell_infinity norm + call stdlib${ii}$_dlassq( n, a(p,1_${ik}$), lda, xsc, temp1 ) + ! stdlib${ii}$_dlassq gets both the ell_2 and the ell_infinity norm ! in one pass through the vector work(m+n+p) = xsc * scalem work(n+p) = xsc * (scalem*sqrt(temp1)) @@ -68678,7 +68676,7 @@ module stdlib_linalg_lapack_d end do else do p = 1, m - work(m+n+p) = scalem*abs( a(p,stdlib_idamax(n,a(p,1),lda)) ) + work(m+n+p) = scalem*abs( a(p,stdlib${ii}$_idamax(n,a(p,1_${ik}$),lda)) ) aatmax = max( aatmax, work(m+n+p) ) aatmin = min( aatmin, work(m+n+p) ) end do @@ -68695,11 +68693,11 @@ module stdlib_linalg_lapack_d if ( l2tran ) then xsc = zero temp1 = one - call stdlib_dlassq( n, sva, 1, xsc, temp1 ) + call stdlib${ii}$_dlassq( n, sva, 1_${ik}$, xsc, temp1 ) temp1 = one / temp1 entra = zero do p = 1, n - big1 = ( ( sva(p) / xsc )**2 ) * temp1 + big1 = ( ( sva(p) / xsc )**2_${ik}$ ) * temp1 if ( big1 /= zero ) entra = entra + big1 * log(big1) end do entra = - entra / log(real(n,KIND=dp)) @@ -68710,7 +68708,7 @@ module stdlib_linalg_lapack_d ! same trace. entrat = zero do p = n+1, n+m - big1 = ( ( work(p) / xsc )**2 ) * temp1 + big1 = ( ( work(p) / xsc )**2_${ik}$ ) * temp1 if ( big1 /= zero ) entrat = entrat + big1 * log(big1) end do entrat = - entrat / log(real(m,KIND=dp)) @@ -68749,22 +68747,22 @@ module stdlib_linalg_lapack_d ! scale the matrix so that its maximal singular value remains less ! than sqrt(big) -- the matrix is scaled so that its maximal column ! has euclidean norm equal to sqrt(big/n). the only reason to keep - ! sqrt(big) instead of big is the fact that stdlib_dgejsv uses lapack and + ! sqrt(big) instead of big is the fact that stdlib${ii}$_dgejsv uses lapack and ! blas routines that, in some implementations, are not capable of ! working in the full interval [sfmin,big] and that they may provoke ! overflows in the intermediate results. if the singular values spread - ! from sfmin to big, then stdlib_dgesvj will compute them. so, in that case, - ! one should use stdlib_dgesvj instead of stdlib_dgejsv. + ! from sfmin to big, then stdlib${ii}$_dgesvj will compute them. so, in that case, + ! one should use stdlib_dgesvj instead of stdlib${ii}$_dgejsv. big1 = sqrt( big ) temp1 = sqrt( big / real(n,KIND=dp) ) - call stdlib_dlascl( 'G', 0, 0, aapp, temp1, n, 1, sva, n, ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, temp1, n, 1_${ik}$, sva, n, ierr ) if ( aaqq > (aapp * sfmin) ) then aaqq = ( aaqq / aapp ) * temp1 else aaqq = ( aaqq * temp1 ) / aapp end if temp1 = temp1 * scalem - call stdlib_dlascl( 'G', 0, 0, aapp, temp1, m, n, a, lda, ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, temp1, m, n, a, lda, ierr ) ! to undo scaling at the end of this procedure, multiply the ! computed singular values with uscal2 / uscal1. uscal1 = temp1 @@ -68778,7 +68776,7 @@ module stdlib_linalg_lapack_d xsc = small ! now, if the condition number of a is too big, ! sigma_max(a) / sigma_min(a) > sqrt(big/n) * epsln / sfmin, - ! as a precaution measure, the full svd is computed using stdlib_dgesvj + ! as a precaution measure, the full svd is computed using stdlib${ii}$_dgesvj ! with accumulated jacobi rotations. this provides numerically ! more robust computation, at the cost of slightly increased run ! time. depending on the concrete implementation of blas and lapack @@ -68791,7 +68789,7 @@ module stdlib_linalg_lapack_d if ( aaqq < xsc ) then do p = 1, n if ( sva(p) < xsc ) then - call stdlib_dlaset( 'A', m, 1, zero, zero, a(1,p), lda ) + call stdlib${ii}$_dlaset( 'A', m, 1_${ik}$, zero, zero, a(1_${ik}$,p), lda ) sva(p) = zero end if end do @@ -68804,15 +68802,15 @@ module stdlib_linalg_lapack_d ! has similar effect as powell-reid complete pivoting. ! the ell-infinity norms of a are made nonincreasing. do p = 1, m - 1 - q = stdlib_idamax( m-p+1, work(m+n+p), 1 ) + p - 1 - iwork(2*n+p) = q + q = stdlib${ii}$_idamax( m-p+1, work(m+n+p), 1_${ik}$ ) + p - 1_${ik}$ + iwork(2_${ik}$*n+p) = q if ( p /= q ) then temp1 = work(m+n+p) work(m+n+p) = work(m+n+q) work(m+n+q) = temp1 end if end do - call stdlib_dlaswp( n, a, lda, 1, m-1, iwork(2*n+1), 1 ) + call stdlib${ii}$_dlaswp( n, a, lda, 1_${ik}$, m-1, iwork(2_${ik}$*n+1), 1_${ik}$ ) end if ! end of the preparation phase (scaling, optional sorting and ! transposing, optional flushing of small columns). @@ -68824,46 +68822,44 @@ module stdlib_linalg_lapack_d ! (eg speed by replacing global with restricted window pivoting, such ! as in sgeqpx from toms # 782). good results will be obtained using ! sgeqpx with properly (!) chosen numerical parameters. - ! any improvement of stdlib_dgeqp3 improves overall performance of stdlib_dgejsv. + ! any improvement of stdlib${ii}$_dgeqp3 improves overall performance of stdlib${ii}$_dgejsv. ! a * p1 = q1 * [ r1^t 0]^t: do p = 1, n ! All Columns Are Free Columns - iwork(p) = 0 + iwork(p) = 0_${ik}$ end do - call stdlib_dgeqp3( m,n,a,lda, iwork,work, work(n+1),lwork-n, ierr ) + call stdlib${ii}$_dgeqp3( m,n,a,lda, iwork,work, work(n+1),lwork-n, ierr ) ! the upper triangular matrix r1 from the first qrf is inspected for ! rank deficiency and possibilities for deflation, or possible ! ill-conditioning. depending on the user specified flag l2rank, ! the procedure explores possibilities to reduce the numerical ! rank by inspecting the computed upper triangular factor. if - ! l2rank or l2aber are up, then stdlib_dgejsv will compute the svd of + ! l2rank or l2aber are up, then stdlib${ii}$_dgejsv will compute the svd of ! a + da, where ||da|| <= f(m,n)*epsln. - nr = 1 + nr = 1_${ik}$ if ( l2aber ) then ! standard absolute error bound suffices. all sigma_i with ! sigma_i < n*epsln*||a|| are flushed to zero. this is an ! aggressive enforcement of lower numerical rank by introducing a ! backward error of the order of n*epsln*||a||. temp1 = sqrt(real(n,KIND=dp))*epsln - do p = 2, n - if ( abs(a(p,p)) >= (temp1*abs(a(1,1))) ) then - nr = nr + 1 + loop_3002: do p = 2, n + if ( abs(a(p,p)) >= (temp1*abs(a(1_${ik}$,1_${ik}$))) ) then + nr = nr + 1_${ik}$ else - go to 3002 + exit loop_3002 end if - end do - 3002 continue + end do loop_3002 else if ( l2rank ) then ! .. similarly as above, only slightly more gentle (less aggressive). ! sudden drop on the diagonal of r1 is used as the criterion for ! close-to-rank-deficient. temp1 = sqrt(sfmin) - do p = 2, n + loop_3402: do p = 2, n if ( ( abs(a(p,p)) < (epsln*abs(a(p-1,p-1))) ) .or.( abs(a(p,p)) < small ) .or.( & - l2kill .and. (abs(a(p,p)) < temp1) ) ) go to 3402 - nr = nr + 1 - end do - 3402 continue + l2kill .and. (abs(a(p,p)) < temp1) ) ) exit loop_3402 + nr = nr + 1_${ik}$ + end do loop_3402 else ! the goal is high relative accuracy. however, if the matrix ! has high scaled condition number the relative accuracy is in @@ -68873,12 +68869,10 @@ module stdlib_linalg_lapack_d ! factor. this prevents the situation in which the code is ! working hard to get the accuracy not warranted by the data. temp1 = sqrt(sfmin) - do p = 2, n - if ( ( abs(a(p,p)) < small ) .or.( l2kill .and. (abs(a(p,p)) < temp1) ) ) go to & - 3302 - nr = nr + 1 - end do - 3302 continue + loop_3302: do p = 2, n + if ( ( abs(a(p,p)) < small ) .or.( l2kill .and. (abs(a(p,p)) < temp1) ) ) exit loop_3302 + nr = nr + 1_${ik}$ + end do loop_3302 end if almort = .false. if ( nr == n ) then @@ -68887,7 +68881,7 @@ module stdlib_linalg_lapack_d temp1 = abs(a(p,p)) / sva(iwork(p)) maxprj = min( maxprj, temp1 ) end do - if ( maxprj**2 >= one - real(n,KIND=dp)*epsln ) almort = .true. + if ( maxprj**2_${ik}$ >= one - real(n,KIND=dp)*epsln ) almort = .true. end if sconda = - one condr1 = - one @@ -68896,30 +68890,30 @@ module stdlib_linalg_lapack_d if ( n == nr ) then if ( rsvec ) then ! V Is Available As Workspace - call stdlib_dlacpy( 'U', n, n, a, lda, v, ldv ) + call stdlib${ii}$_dlacpy( 'U', n, n, a, lda, v, ldv ) do p = 1, n temp1 = sva(iwork(p)) - call stdlib_dscal( p, one/temp1, v(1,p), 1 ) + call stdlib${ii}$_dscal( p, one/temp1, v(1_${ik}$,p), 1_${ik}$ ) end do - call stdlib_dpocon( 'U', n, v, ldv, one, temp1,work(n+1), iwork(2*n+m+1), & + call stdlib${ii}$_dpocon( 'U', n, v, ldv, one, temp1,work(n+1), iwork(2_${ik}$*n+m+1), & ierr ) else if ( lsvec ) then ! U Is Available As Workspace - call stdlib_dlacpy( 'U', n, n, a, lda, u, ldu ) + call stdlib${ii}$_dlacpy( 'U', n, n, a, lda, u, ldu ) do p = 1, n temp1 = sva(iwork(p)) - call stdlib_dscal( p, one/temp1, u(1,p), 1 ) + call stdlib${ii}$_dscal( p, one/temp1, u(1_${ik}$,p), 1_${ik}$ ) end do - call stdlib_dpocon( 'U', n, u, ldu, one, temp1,work(n+1), iwork(2*n+m+1), & + call stdlib${ii}$_dpocon( 'U', n, u, ldu, one, temp1,work(n+1), iwork(2_${ik}$*n+m+1), & ierr ) else - call stdlib_dlacpy( 'U', n, n, a, lda, work(n+1), n ) + call stdlib${ii}$_dlacpy( 'U', n, n, a, lda, work(n+1), n ) do p = 1, n temp1 = sva(iwork(p)) - call stdlib_dscal( p, one/temp1, work(n+(p-1)*n+1), 1 ) + call stdlib${ii}$_dscal( p, one/temp1, work(n+(p-1)*n+1), 1_${ik}$ ) end do ! The Columns Of R Are Scaled To Have Unit Euclidean Lengths - call stdlib_dpocon( 'U', n, work(n+1), n, one, temp1,work(n+n*n+1), iwork(2*n+& + call stdlib${ii}$_dpocon( 'U', n, work(n+1), n, one, temp1,work(n+n*n+1), iwork(2_${ik}$*n+& m+1), ierr ) end if sconda = one / sqrt(temp1) @@ -68929,14 +68923,14 @@ module stdlib_linalg_lapack_d sconda = - one end if end if - l2pert = l2pert .and. ( abs( a(1,1)/a(nr,nr) ) > sqrt(big1) ) + l2pert = l2pert .and. ( abs( a(1_${ik}$,1_${ik}$)/a(nr,nr) ) > sqrt(big1) ) ! if there is no violent scaling, artificial perturbation is not needed. ! phase 3: if ( .not. ( rsvec .or. lsvec ) ) then ! singular values only ! .. transpose a(1:nr,1:n) do p = 1, min( n-1, nr ) - call stdlib_dcopy( n-p, a(p,p+1), lda, a(p+1,p), 1 ) + call stdlib${ii}$_dcopy( n-p, a(p,p+1), lda, a(p+1,p), 1_${ik}$ ) end do ! the following two do-loops introduce small relative perturbation ! into the strict upper triangle of the lower triangular matrix. @@ -68961,13 +68955,13 @@ module stdlib_linalg_lapack_d end do end do else - call stdlib_dlaset( 'U', nr-1,nr-1, zero,zero, a(1,2),lda ) + call stdlib${ii}$_dlaset( 'U', nr-1,nr-1, zero,zero, a(1_${ik}$,2_${ik}$),lda ) end if ! Second Preconditioning Using The Qr Factorization - call stdlib_dgeqrf( n,nr, a,lda, work, work(n+1),lwork-n, ierr ) + call stdlib${ii}$_dgeqrf( n,nr, a,lda, work, work(n+1),lwork-n, ierr ) ! And Transpose Upper To Lower Triangular do p = 1, nr - 1 - call stdlib_dcopy( nr-p, a(p,p+1), lda, a(p+1,p), 1 ) + call stdlib${ii}$_dcopy( nr-p, a(p,p+1), lda, a(p+1,p), 1_${ik}$ ) end do end if ! row-cyclic jacobi svd algorithm with column pivoting @@ -68984,92 +68978,92 @@ module stdlib_linalg_lapack_d end do end do else - call stdlib_dlaset( 'U', nr-1, nr-1, zero, zero, a(1,2), lda ) + call stdlib${ii}$_dlaset( 'U', nr-1, nr-1, zero, zero, a(1_${ik}$,2_${ik}$), lda ) end if ! .. and one-sided jacobi rotations are started on a lower ! triangular matrix (plus perturbation which is ignored in ! the part which destroys triangular form (confusing?!)) - call stdlib_dgesvj( 'L', 'NOU', 'NOV', nr, nr, a, lda, sva,n, v, ldv, work, & + call stdlib${ii}$_dgesvj( 'L', 'NOU', 'NOV', nr, nr, a, lda, sva,n, v, ldv, work, & lwork, info ) - scalem = work(1) - numrank = nint(work(2),KIND=ilp) + scalem = work(1_${ik}$) + numrank = nint(work(2_${ik}$),KIND=${ik}$) else if ( rsvec .and. ( .not. lsvec ) ) then ! -> singular values and right singular vectors <- if ( almort ) then ! In This Case Nr Equals N do p = 1, nr - call stdlib_dcopy( n-p+1, a(p,p), lda, v(p,p), 1 ) + call stdlib${ii}$_dcopy( n-p+1, a(p,p), lda, v(p,p), 1_${ik}$ ) end do - call stdlib_dlaset( 'UPPER', nr-1, nr-1, zero, zero, v(1,2), ldv ) - call stdlib_dgesvj( 'L','U','N', n, nr, v,ldv, sva, nr, a,lda,work, lwork, info ) + call stdlib${ii}$_dlaset( 'UPPER', nr-1, nr-1, zero, zero, v(1_${ik}$,2_${ik}$), ldv ) + call stdlib${ii}$_dgesvj( 'L','U','N', n, nr, v,ldv, sva, nr, a,lda,work, lwork, info ) - scalem = work(1) - numrank = nint(work(2),KIND=ilp) + scalem = work(1_${ik}$) + numrank = nint(work(2_${ik}$),KIND=${ik}$) else ! .. two more qr factorizations ( one qrf is not enough, two require ! accumulated product of jacobi rotations, three are perfect ) - call stdlib_dlaset( 'LOWER', nr-1, nr-1, zero, zero, a(2,1), lda ) - call stdlib_dgelqf( nr, n, a, lda, work, work(n+1), lwork-n, ierr) - call stdlib_dlacpy( 'LOWER', nr, nr, a, lda, v, ldv ) - call stdlib_dlaset( 'UPPER', nr-1, nr-1, zero, zero, v(1,2), ldv ) - call stdlib_dgeqrf( nr, nr, v, ldv, work(n+1), work(2*n+1),lwork-2*n, ierr ) + call stdlib${ii}$_dlaset( 'LOWER', nr-1, nr-1, zero, zero, a(2_${ik}$,1_${ik}$), lda ) + call stdlib${ii}$_dgelqf( nr, n, a, lda, work, work(n+1), lwork-n, ierr) + call stdlib${ii}$_dlacpy( 'LOWER', nr, nr, a, lda, v, ldv ) + call stdlib${ii}$_dlaset( 'UPPER', nr-1, nr-1, zero, zero, v(1_${ik}$,2_${ik}$), ldv ) + call stdlib${ii}$_dgeqrf( nr, nr, v, ldv, work(n+1), work(2_${ik}$*n+1),lwork-2*n, ierr ) do p = 1, nr - call stdlib_dcopy( nr-p+1, v(p,p), ldv, v(p,p), 1 ) + call stdlib${ii}$_dcopy( nr-p+1, v(p,p), ldv, v(p,p), 1_${ik}$ ) end do - call stdlib_dlaset( 'UPPER', nr-1, nr-1, zero, zero, v(1,2), ldv ) - call stdlib_dgesvj( 'LOWER', 'U','N', nr, nr, v,ldv, sva, nr, u,ldu, work(n+1), & + call stdlib${ii}$_dlaset( 'UPPER', nr-1, nr-1, zero, zero, v(1_${ik}$,2_${ik}$), ldv ) + call stdlib${ii}$_dgesvj( 'LOWER', 'U','N', nr, nr, v,ldv, sva, nr, u,ldu, work(n+1), & lwork, info ) scalem = work(n+1) - numrank = nint(work(n+2),KIND=ilp) + numrank = nint(work(n+2),KIND=${ik}$) if ( nr < n ) then - call stdlib_dlaset( 'A',n-nr, nr, zero,zero, v(nr+1,1), ldv ) - call stdlib_dlaset( 'A',nr, n-nr, zero,zero, v(1,nr+1), ldv ) - call stdlib_dlaset( 'A',n-nr,n-nr,zero,one, v(nr+1,nr+1), ldv ) + call stdlib${ii}$_dlaset( 'A',n-nr, nr, zero,zero, v(nr+1,1_${ik}$), ldv ) + call stdlib${ii}$_dlaset( 'A',nr, n-nr, zero,zero, v(1_${ik}$,nr+1), ldv ) + call stdlib${ii}$_dlaset( 'A',n-nr,n-nr,zero,one, v(nr+1,nr+1), ldv ) end if - call stdlib_dormlq( 'LEFT', 'TRANSPOSE', n, n, nr, a, lda, work,v, ldv, work(n+1), & + call stdlib${ii}$_dormlq( 'LEFT', 'TRANSPOSE', n, n, nr, a, lda, work,v, ldv, work(n+1), & lwork-n, ierr ) end if do p = 1, n - call stdlib_dcopy( n, v(p,1), ldv, a(iwork(p),1), lda ) + call stdlib${ii}$_dcopy( n, v(p,1_${ik}$), ldv, a(iwork(p),1_${ik}$), lda ) end do - call stdlib_dlacpy( 'ALL', n, n, a, lda, v, ldv ) + call stdlib${ii}$_dlacpy( 'ALL', n, n, a, lda, v, ldv ) if ( transp ) then - call stdlib_dlacpy( 'ALL', n, n, v, ldv, u, ldu ) + call stdlib${ii}$_dlacpy( 'ALL', n, n, v, ldv, u, ldu ) end if else if ( lsvec .and. ( .not. rsvec ) ) then ! Singular Values And Left Singular Vectors ! Second Preconditioning Step To Avoid Need To Accumulate ! jacobi rotations in the jacobi iterations. do p = 1, nr - call stdlib_dcopy( n-p+1, a(p,p), lda, u(p,p), 1 ) + call stdlib${ii}$_dcopy( n-p+1, a(p,p), lda, u(p,p), 1_${ik}$ ) end do - call stdlib_dlaset( 'UPPER', nr-1, nr-1, zero, zero, u(1,2), ldu ) - call stdlib_dgeqrf( n, nr, u, ldu, work(n+1), work(2*n+1),lwork-2*n, ierr ) + call stdlib${ii}$_dlaset( 'UPPER', nr-1, nr-1, zero, zero, u(1_${ik}$,2_${ik}$), ldu ) + call stdlib${ii}$_dgeqrf( n, nr, u, ldu, work(n+1), work(2_${ik}$*n+1),lwork-2*n, ierr ) do p = 1, nr - 1 - call stdlib_dcopy( nr-p, u(p,p+1), ldu, u(p+1,p), 1 ) + call stdlib${ii}$_dcopy( nr-p, u(p,p+1), ldu, u(p+1,p), 1_${ik}$ ) end do - call stdlib_dlaset( 'UPPER', nr-1, nr-1, zero, zero, u(1,2), ldu ) - call stdlib_dgesvj( 'LOWER', 'U', 'N', nr,nr, u, ldu, sva, nr, a,lda, work(n+1), & + call stdlib${ii}$_dlaset( 'UPPER', nr-1, nr-1, zero, zero, u(1_${ik}$,2_${ik}$), ldu ) + call stdlib${ii}$_dgesvj( 'LOWER', 'U', 'N', nr,nr, u, ldu, sva, nr, a,lda, work(n+1), & lwork-n, info ) scalem = work(n+1) - numrank = nint(work(n+2),KIND=ilp) + numrank = nint(work(n+2),KIND=${ik}$) if ( nr < m ) then - call stdlib_dlaset( 'A', m-nr, nr,zero, zero, u(nr+1,1), ldu ) + call stdlib${ii}$_dlaset( 'A', m-nr, nr,zero, zero, u(nr+1,1_${ik}$), ldu ) if ( nr < n1 ) then - call stdlib_dlaset( 'A',nr, n1-nr, zero, zero, u(1,nr+1), ldu ) - call stdlib_dlaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_dlaset( 'A',nr, n1-nr, zero, zero, u(1_${ik}$,nr+1), ldu ) + call stdlib${ii}$_dlaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) end if end if - call stdlib_dormqr( 'LEFT', 'NO TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & + call stdlib${ii}$_dormqr( 'LEFT', 'NO TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & lwork-n, ierr ) - if ( rowpiv )call stdlib_dlaswp( n1, u, ldu, 1, m-1, iwork(2*n+1), -1 ) + if ( rowpiv )call stdlib${ii}$_dlaswp( n1, u, ldu, 1_${ik}$, m-1, iwork(2_${ik}$*n+1), -1_${ik}$ ) do p = 1, n1 - xsc = one / stdlib_dnrm2( m, u(1,p), 1 ) - call stdlib_dscal( m, xsc, u(1,p), 1 ) + xsc = one / stdlib${ii}$_dnrm2( m, u(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_dscal( m, xsc, u(1_${ik}$,p), 1_${ik}$ ) end do if ( transp ) then - call stdlib_dlacpy( 'ALL', n, n, u, ldu, v, ldv ) + call stdlib${ii}$_dlacpy( 'ALL', n, n, u, ldu, v, ldv ) end if else ! Full Svd @@ -69080,9 +69074,9 @@ module stdlib_linalg_lapack_d ! equivalent to an lqf call. since in many libraries the qrf ! seems to be better optimized than the lqf, we do explicit ! transpose and use the qrf. this is subject to changes in an - ! optimized implementation of stdlib_dgejsv. + ! optimized implementation of stdlib${ii}$_dgejsv. do p = 1, nr - call stdlib_dcopy( n-p+1, a(p,p), lda, v(p,p), 1 ) + call stdlib${ii}$_dcopy( n-p+1, a(p,p), lda, v(p,p), 1_${ik}$ ) end do ! The Following Two Loops Perturb Small Entries To Avoid ! denormals in the second qr factorization, where they are @@ -69106,18 +69100,18 @@ module stdlib_linalg_lapack_d end do end do else - call stdlib_dlaset( 'U', nr-1, nr-1, zero, zero, v(1,2), ldv ) + call stdlib${ii}$_dlaset( 'U', nr-1, nr-1, zero, zero, v(1_${ik}$,2_${ik}$), ldv ) end if ! estimate the row scaled condition number of r1 ! (if r1 is rectangular, n > nr, then the condition number ! of the leading nr x nr submatrix is estimated.) - call stdlib_dlacpy( 'L', nr, nr, v, ldv, work(2*n+1), nr ) + call stdlib${ii}$_dlacpy( 'L', nr, nr, v, ldv, work(2_${ik}$*n+1), nr ) do p = 1, nr - temp1 = stdlib_dnrm2(nr-p+1,work(2*n+(p-1)*nr+p),1) - call stdlib_dscal(nr-p+1,one/temp1,work(2*n+(p-1)*nr+p),1) + temp1 = stdlib${ii}$_dnrm2(nr-p+1,work(2_${ik}$*n+(p-1)*nr+p),1_${ik}$) + call stdlib${ii}$_dscal(nr-p+1,one/temp1,work(2_${ik}$*n+(p-1)*nr+p),1_${ik}$) end do - call stdlib_dpocon('LOWER',nr,work(2*n+1),nr,one,temp1,work(2*n+nr*nr+1),iwork(m+& - 2*n+1),ierr) + call stdlib${ii}$_dpocon('LOWER',nr,work(2_${ik}$*n+1),nr,one,temp1,work(2_${ik}$*n+nr*nr+1),iwork(m+& + 2_${ik}$*n+1),ierr) condr1 = one / sqrt(temp1) ! Here Need A Second Opinion On The Condition Number ! Then Assume Worst Case Scenario @@ -69130,7 +69124,7 @@ module stdlib_linalg_lapack_d ! implementation, this qrf should be implemented as the qrf ! of a lower triangular matrix. ! r1^t = q2 * r2 - call stdlib_dgeqrf( n, nr, v, ldv, work(n+1), work(2*n+1),lwork-2*n, ierr ) + call stdlib${ii}$_dgeqrf( n, nr, v, ldv, work(n+1), work(2_${ik}$*n+1),lwork-2*n, ierr ) if ( l2pert ) then xsc = sqrt(small)/epsln @@ -69141,27 +69135,27 @@ module stdlib_linalg_lapack_d end do end do end if - if ( nr /= n )call stdlib_dlacpy( 'A', n, nr, v, ldv, work(2*n+1), n ) + if ( nr /= n )call stdlib${ii}$_dlacpy( 'A', n, nr, v, ldv, work(2_${ik}$*n+1), n ) ! .. save ... ! This Transposed Copy Should Be Better Than Naive do p = 1, nr - 1 - call stdlib_dcopy( nr-p, v(p,p+1), ldv, v(p+1,p), 1 ) + call stdlib${ii}$_dcopy( nr-p, v(p,p+1), ldv, v(p+1,p), 1_${ik}$ ) end do condr2 = condr1 else ! .. ill-conditioned case: second qrf with pivoting ! note that windowed pivoting would be equally good ! numerically, and more run-time efficient. so, in - ! an optimal implementation, the next call to stdlib_dgeqp3 + ! an optimal implementation, the next call to stdlib${ii}$_dgeqp3 ! should be replaced with eg. call sgeqpx (acm toms #782) ! with properly (carefully) chosen parameters. ! r1^t * p2 = q2 * r2 do p = 1, nr - iwork(n+p) = 0 + iwork(n+p) = 0_${ik}$ end do - call stdlib_dgeqp3( n, nr, v, ldv, iwork(n+1), work(n+1),work(2*n+1), lwork-& - 2*n, ierr ) - ! * call stdlib_dgeqrf( n, nr, v, ldv, work(n+1), work(2*n+1), + call stdlib${ii}$_dgeqp3( n, nr, v, ldv, iwork(n+1), work(n+1),work(2_${ik}$*n+1), lwork-& + 2_${ik}$*n, ierr ) + ! * call stdlib${ii}$_dgeqrf( n, nr, v, ldv, work(n+1), work(2*n+1), ! * $ lwork-2*n, ierr ) if ( l2pert ) then xsc = sqrt(small) @@ -69172,7 +69166,7 @@ module stdlib_linalg_lapack_d end do end do end if - call stdlib_dlacpy( 'A', n, nr, v, ldv, work(2*n+1), n ) + call stdlib${ii}$_dlacpy( 'A', n, nr, v, ldv, work(2_${ik}$*n+1), n ) if ( l2pert ) then xsc = sqrt(small) do p = 2, nr @@ -69182,18 +69176,18 @@ module stdlib_linalg_lapack_d end do end do else - call stdlib_dlaset( 'L',nr-1,nr-1,zero,zero,v(2,1),ldv ) + call stdlib${ii}$_dlaset( 'L',nr-1,nr-1,zero,zero,v(2_${ik}$,1_${ik}$),ldv ) end if ! now, compute r2 = l3 * q3, the lq factorization. - call stdlib_dgelqf( nr, nr, v, ldv, work(2*n+n*nr+1),work(2*n+n*nr+nr+1), & + call stdlib${ii}$_dgelqf( nr, nr, v, ldv, work(2_${ik}$*n+n*nr+1),work(2_${ik}$*n+n*nr+nr+1), & lwork-2*n-n*nr-nr, ierr ) ! And Estimate The Condition Number - call stdlib_dlacpy( 'L',nr,nr,v,ldv,work(2*n+n*nr+nr+1),nr ) + call stdlib${ii}$_dlacpy( 'L',nr,nr,v,ldv,work(2_${ik}$*n+n*nr+nr+1),nr ) do p = 1, nr - temp1 = stdlib_dnrm2( p, work(2*n+n*nr+nr+p), nr ) - call stdlib_dscal( p, one/temp1, work(2*n+n*nr+nr+p), nr ) + temp1 = stdlib${ii}$_dnrm2( p, work(2_${ik}$*n+n*nr+nr+p), nr ) + call stdlib${ii}$_dscal( p, one/temp1, work(2_${ik}$*n+n*nr+nr+p), nr ) end do - call stdlib_dpocon( 'L',nr,work(2*n+n*nr+nr+1),nr,one,temp1,work(2*n+n*nr+nr+& + call stdlib${ii}$_dpocon( 'L',nr,work(2_${ik}$*n+n*nr+nr+1),nr,one,temp1,work(2_${ik}$*n+n*nr+nr+& nr*nr+1),iwork(m+2*n+1),ierr ) condr2 = one / sqrt(temp1) if ( condr2 >= cond_ok ) then @@ -69201,7 +69195,7 @@ module stdlib_linalg_lapack_d ! (this overwrites the copy of r2, as it will not be ! needed in this branch, but it does not overwritte the ! huseholder vectors of q2.). - call stdlib_dlacpy( 'U', nr, nr, v, ldv, work(2*n+1), n ) + call stdlib${ii}$_dlacpy( 'U', nr, nr, v, ldv, work(2_${ik}$*n+1), n ) ! And The Rest Of The Information On Q3 Is In ! work(2*n+n*nr+1:2*n+n*nr+n) end if @@ -69216,40 +69210,40 @@ module stdlib_linalg_lapack_d end do end do else - call stdlib_dlaset( 'U', nr-1,nr-1, zero,zero, v(1,2), ldv ) + call stdlib${ii}$_dlaset( 'U', nr-1,nr-1, zero,zero, v(1_${ik}$,2_${ik}$), ldv ) end if ! second preconditioning finished; continue with jacobi svd ! the input matrix is lower trinagular. ! recover the right singular vectors as solution of a well ! conditioned triangular matrix equation. if ( condr1 < cond_ok ) then - call stdlib_dgesvj( 'L','U','N',nr,nr,v,ldv,sva,nr,u,ldu,work(2*n+n*nr+nr+1),& + call stdlib${ii}$_dgesvj( 'L','U','N',nr,nr,v,ldv,sva,nr,u,ldu,work(2_${ik}$*n+n*nr+nr+1),& lwork-2*n-n*nr-nr,info ) - scalem = work(2*n+n*nr+nr+1) - numrank = nint(work(2*n+n*nr+nr+2),KIND=ilp) + scalem = work(2_${ik}$*n+n*nr+nr+1) + numrank = nint(work(2_${ik}$*n+n*nr+nr+2),KIND=${ik}$) do p = 1, nr - call stdlib_dcopy( nr, v(1,p), 1, u(1,p), 1 ) - call stdlib_dscal( nr, sva(p), v(1,p), 1 ) + call stdlib${ii}$_dcopy( nr, v(1_${ik}$,p), 1_${ik}$, u(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_dscal( nr, sva(p), v(1_${ik}$,p), 1_${ik}$ ) end do ! Pick The Right Matrix Equation And Solve It if ( nr == n ) then ! :)) .. best case, r1 is inverted. the solution of this matrix ! equation is q2*v2 = the product of the jacobi rotations - ! used in stdlib_dgesvj, premultiplied with the orthogonal matrix + ! used in stdlib${ii}$_dgesvj, premultiplied with the orthogonal matrix ! from the second qr factorization. - call stdlib_dtrsm( 'L','U','N','N', nr,nr,one, a,lda, v,ldv ) + call stdlib${ii}$_dtrsm( 'L','U','N','N', nr,nr,one, a,lda, v,ldv ) else ! .. r1 is well conditioned, but non-square. transpose(r2) ! is inverted to get the product of the jacobi rotations - ! used in stdlib_dgesvj. the q-factor from the second qr + ! used in stdlib${ii}$_dgesvj. the q-factor from the second qr ! factorization is then built in explicitly. - call stdlib_dtrsm('L','U','T','N',nr,nr,one,work(2*n+1),n,v,ldv) + call stdlib${ii}$_dtrsm('L','U','T','N',nr,nr,one,work(2_${ik}$*n+1),n,v,ldv) if ( nr < n ) then - call stdlib_dlaset('A',n-nr,nr,zero,zero,v(nr+1,1),ldv) - call stdlib_dlaset('A',nr,n-nr,zero,zero,v(1,nr+1),ldv) - call stdlib_dlaset('A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv) + call stdlib${ii}$_dlaset('A',n-nr,nr,zero,zero,v(nr+1,1_${ik}$),ldv) + call stdlib${ii}$_dlaset('A',nr,n-nr,zero,zero,v(1_${ik}$,nr+1),ldv) + call stdlib${ii}$_dlaset('A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv) end if - call stdlib_dormqr('L','N',n,n,nr,work(2*n+1),n,work(n+1),v,ldv,work(2*n+& + call stdlib${ii}$_dormqr('L','N',n,n,nr,work(2_${ik}$*n+1),n,work(n+1),v,ldv,work(2_${ik}$*n+& n*nr+nr+1),lwork-2*n-n*nr-nr,ierr) end if else if ( condr2 < cond_ok ) then @@ -69259,30 +69253,30 @@ module stdlib_linalg_lapack_d ! is q3^t*v3 = the product of the jacobi rotations (appplied to ! the lower triangular l3 from the lq factorization of ! r2=l3*q3), pre-multiplied with the transposed q3. - call stdlib_dgesvj( 'L', 'U', 'N', nr, nr, v, ldv, sva, nr, u,ldu, work(2*n+& + call stdlib${ii}$_dgesvj( 'L', 'U', 'N', nr, nr, v, ldv, sva, nr, u,ldu, work(2_${ik}$*n+& n*nr+nr+1), lwork-2*n-n*nr-nr, info ) - scalem = work(2*n+n*nr+nr+1) - numrank = nint(work(2*n+n*nr+nr+2),KIND=ilp) + scalem = work(2_${ik}$*n+n*nr+nr+1) + numrank = nint(work(2_${ik}$*n+n*nr+nr+2),KIND=${ik}$) do p = 1, nr - call stdlib_dcopy( nr, v(1,p), 1, u(1,p), 1 ) - call stdlib_dscal( nr, sva(p), u(1,p), 1 ) + call stdlib${ii}$_dcopy( nr, v(1_${ik}$,p), 1_${ik}$, u(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_dscal( nr, sva(p), u(1_${ik}$,p), 1_${ik}$ ) end do - call stdlib_dtrsm('L','U','N','N',nr,nr,one,work(2*n+1),n,u,ldu) + call stdlib${ii}$_dtrsm('L','U','N','N',nr,nr,one,work(2_${ik}$*n+1),n,u,ldu) ! Apply The Permutation From The Second Qr Factorization do q = 1, nr do p = 1, nr - work(2*n+n*nr+nr+iwork(n+p)) = u(p,q) + work(2_${ik}$*n+n*nr+nr+iwork(n+p)) = u(p,q) end do do p = 1, nr - u(p,q) = work(2*n+n*nr+nr+p) + u(p,q) = work(2_${ik}$*n+n*nr+nr+p) end do end do if ( nr < n ) then - call stdlib_dlaset( 'A',n-nr,nr,zero,zero,v(nr+1,1),ldv ) - call stdlib_dlaset( 'A',nr,n-nr,zero,zero,v(1,nr+1),ldv ) - call stdlib_dlaset( 'A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv ) + call stdlib${ii}$_dlaset( 'A',n-nr,nr,zero,zero,v(nr+1,1_${ik}$),ldv ) + call stdlib${ii}$_dlaset( 'A',nr,n-nr,zero,zero,v(1_${ik}$,nr+1),ldv ) + call stdlib${ii}$_dlaset( 'A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv ) end if - call stdlib_dormqr( 'L','N',n,n,nr,work(2*n+1),n,work(n+1),v,ldv,work(2*n+& + call stdlib${ii}$_dormqr( 'L','N',n,n,nr,work(2_${ik}$*n+1),n,work(n+1),v,ldv,work(2_${ik}$*n+& n*nr+nr+1),lwork-2*n-n*nr-nr,ierr ) else ! last line of defense. @@ -69293,28 +69287,28 @@ module stdlib_linalg_lapack_d ! is set very close to one (which is unnecessary). normally, ! this branch should never be executed, but in rare cases of ! failure of the rrqr or condition estimator, the last line of - ! defense ensures that stdlib_dgejsv completes the task. - ! compute the full svd of l3 using stdlib_dgesvj with explicit + ! defense ensures that stdlib${ii}$_dgejsv completes the task. + ! compute the full svd of l3 using stdlib${ii}$_dgesvj with explicit ! accumulation of jacobi rotations. - call stdlib_dgesvj( 'L', 'U', 'V', nr, nr, v, ldv, sva, nr, u,ldu, work(2*n+& + call stdlib${ii}$_dgesvj( 'L', 'U', 'V', nr, nr, v, ldv, sva, nr, u,ldu, work(2_${ik}$*n+& n*nr+nr+1), lwork-2*n-n*nr-nr, info ) - scalem = work(2*n+n*nr+nr+1) - numrank = nint(work(2*n+n*nr+nr+2),KIND=ilp) + scalem = work(2_${ik}$*n+n*nr+nr+1) + numrank = nint(work(2_${ik}$*n+n*nr+nr+2),KIND=${ik}$) if ( nr < n ) then - call stdlib_dlaset( 'A',n-nr,nr,zero,zero,v(nr+1,1),ldv ) - call stdlib_dlaset( 'A',nr,n-nr,zero,zero,v(1,nr+1),ldv ) - call stdlib_dlaset( 'A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv ) + call stdlib${ii}$_dlaset( 'A',n-nr,nr,zero,zero,v(nr+1,1_${ik}$),ldv ) + call stdlib${ii}$_dlaset( 'A',nr,n-nr,zero,zero,v(1_${ik}$,nr+1),ldv ) + call stdlib${ii}$_dlaset( 'A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv ) end if - call stdlib_dormqr( 'L','N',n,n,nr,work(2*n+1),n,work(n+1),v,ldv,work(2*n+& + call stdlib${ii}$_dormqr( 'L','N',n,n,nr,work(2_${ik}$*n+1),n,work(n+1),v,ldv,work(2_${ik}$*n+& n*nr+nr+1),lwork-2*n-n*nr-nr,ierr ) - call stdlib_dormlq( 'L', 'T', nr, nr, nr, work(2*n+1), n,work(2*n+n*nr+1), u, & - ldu, work(2*n+n*nr+nr+1),lwork-2*n-n*nr-nr, ierr ) + call stdlib${ii}$_dormlq( 'L', 'T', nr, nr, nr, work(2_${ik}$*n+1), n,work(2_${ik}$*n+n*nr+1), u, & + ldu, work(2_${ik}$*n+n*nr+nr+1),lwork-2*n-n*nr-nr, ierr ) do q = 1, nr do p = 1, nr - work(2*n+n*nr+nr+iwork(n+p)) = u(p,q) + work(2_${ik}$*n+n*nr+nr+iwork(n+p)) = u(p,q) end do do p = 1, nr - u(p,q) = work(2*n+n*nr+nr+p) + u(p,q) = work(2_${ik}$*n+n*nr+nr+p) end do end do end if @@ -69324,42 +69318,42 @@ module stdlib_linalg_lapack_d temp1 = sqrt(real(n,KIND=dp)) * epsln do q = 1, n do p = 1, n - work(2*n+n*nr+nr+iwork(p)) = v(p,q) + work(2_${ik}$*n+n*nr+nr+iwork(p)) = v(p,q) end do do p = 1, n - v(p,q) = work(2*n+n*nr+nr+p) + v(p,q) = work(2_${ik}$*n+n*nr+nr+p) end do - xsc = one / stdlib_dnrm2( n, v(1,q), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_dscal( n, xsc, & - v(1,q), 1 ) + xsc = one / stdlib${ii}$_dnrm2( n, v(1_${ik}$,q), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_dscal( n, xsc, & + v(1_${ik}$,q), 1_${ik}$ ) end do ! at this moment, v contains the right singular vectors of a. ! next, assemble the left singular vector matrix u (m x n). if ( nr < m ) then - call stdlib_dlaset( 'A', m-nr, nr, zero, zero, u(nr+1,1), ldu ) + call stdlib${ii}$_dlaset( 'A', m-nr, nr, zero, zero, u(nr+1,1_${ik}$), ldu ) if ( nr < n1 ) then - call stdlib_dlaset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) - call stdlib_dlaset('A',m-nr,n1-nr,zero,one,u(nr+1,nr+1),ldu) + call stdlib${ii}$_dlaset('A',nr,n1-nr,zero,zero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_dlaset('A',m-nr,n1-nr,zero,one,u(nr+1,nr+1),ldu) end if end if ! the q matrix from the first qrf is built into the left singular ! matrix u. this applies to all cases. - call stdlib_dormqr( 'LEFT', 'NO_TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & + call stdlib${ii}$_dormqr( 'LEFT', 'NO_TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & lwork-n, ierr ) ! the columns of u are normalized. the cost is o(m*n) flops. temp1 = sqrt(real(m,KIND=dp)) * epsln do p = 1, nr - xsc = one / stdlib_dnrm2( m, u(1,p), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_dscal( m, xsc, & - u(1,p), 1 ) + xsc = one / stdlib${ii}$_dnrm2( m, u(1_${ik}$,p), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_dscal( m, xsc, & + u(1_${ik}$,p), 1_${ik}$ ) end do ! if the initial qrf is computed with row pivoting, the left ! singular vectors must be adjusted. - if ( rowpiv )call stdlib_dlaswp( n1, u, ldu, 1, m-1, iwork(2*n+1), -1 ) + if ( rowpiv )call stdlib${ii}$_dlaswp( n1, u, ldu, 1_${ik}$, m-1, iwork(2_${ik}$*n+1), -1_${ik}$ ) else ! The Initial Matrix A Has Almost Orthogonal Columns And ! the second qrf is not needed - call stdlib_dlacpy( 'UPPER', n, n, a, lda, work(n+1), n ) + call stdlib${ii}$_dlacpy( 'UPPER', n, n, a, lda, work(n+1), n ) if ( l2pert ) then xsc = sqrt(small) do p = 2, n @@ -69369,44 +69363,44 @@ module stdlib_linalg_lapack_d end do end do else - call stdlib_dlaset( 'LOWER',n-1,n-1,zero,zero,work(n+2),n ) + call stdlib${ii}$_dlaset( 'LOWER',n-1,n-1,zero,zero,work(n+2),n ) end if - call stdlib_dgesvj( 'UPPER', 'U', 'N', n, n, work(n+1), n, sva,n, u, ldu, work(n+& + call stdlib${ii}$_dgesvj( 'UPPER', 'U', 'N', n, n, work(n+1), n, sva,n, u, ldu, work(n+& n*n+1), lwork-n-n*n, info ) scalem = work(n+n*n+1) - numrank = nint(work(n+n*n+2),KIND=ilp) + numrank = nint(work(n+n*n+2),KIND=${ik}$) do p = 1, n - call stdlib_dcopy( n, work(n+(p-1)*n+1), 1, u(1,p), 1 ) - call stdlib_dscal( n, sva(p), work(n+(p-1)*n+1), 1 ) + call stdlib${ii}$_dcopy( n, work(n+(p-1)*n+1), 1_${ik}$, u(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_dscal( n, sva(p), work(n+(p-1)*n+1), 1_${ik}$ ) end do - call stdlib_dtrsm( 'LEFT', 'UPPER', 'NOTRANS', 'NO UD', n, n,one, a, lda, work(n+& - 1), n ) + call stdlib${ii}$_dtrsm( 'LEFT', 'UPPER', 'NOTRANS', 'NO UD', n, n,one, a, lda, work(n+& + 1_${ik}$), n ) do p = 1, n - call stdlib_dcopy( n, work(n+p), n, v(iwork(p),1), ldv ) + call stdlib${ii}$_dcopy( n, work(n+p), n, v(iwork(p),1_${ik}$), ldv ) end do temp1 = sqrt(real(n,KIND=dp))*epsln do p = 1, n - xsc = one / stdlib_dnrm2( n, v(1,p), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_dscal( n, xsc, & - v(1,p), 1 ) + xsc = one / stdlib${ii}$_dnrm2( n, v(1_${ik}$,p), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_dscal( n, xsc, & + v(1_${ik}$,p), 1_${ik}$ ) end do ! assemble the left singular vector matrix u (m x n). if ( n < m ) then - call stdlib_dlaset( 'A', m-n, n, zero, zero, u(n+1,1), ldu ) + call stdlib${ii}$_dlaset( 'A', m-n, n, zero, zero, u(n+1,1_${ik}$), ldu ) if ( n < n1 ) then - call stdlib_dlaset( 'A',n, n1-n, zero, zero, u(1,n+1),ldu ) - call stdlib_dlaset( 'A',m-n,n1-n, zero, one,u(n+1,n+1),ldu ) + call stdlib${ii}$_dlaset( 'A',n, n1-n, zero, zero, u(1_${ik}$,n+1),ldu ) + call stdlib${ii}$_dlaset( 'A',m-n,n1-n, zero, one,u(n+1,n+1),ldu ) end if end if - call stdlib_dormqr( 'LEFT', 'NO TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & + call stdlib${ii}$_dormqr( 'LEFT', 'NO TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & lwork-n, ierr ) temp1 = sqrt(real(m,KIND=dp))*epsln do p = 1, n1 - xsc = one / stdlib_dnrm2( m, u(1,p), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_dscal( m, xsc, & - u(1,p), 1 ) + xsc = one / stdlib${ii}$_dnrm2( m, u(1_${ik}$,p), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_dscal( m, xsc, & + u(1_${ik}$,p), 1_${ik}$ ) end do - if ( rowpiv )call stdlib_dlaswp( n1, u, ldu, 1, m-1, iwork(2*n+1), -1 ) + if ( rowpiv )call stdlib${ii}$_dlaswp( n1, u, ldu, 1_${ik}$, m-1, iwork(2_${ik}$*n+1), -1_${ik}$ ) end if ! end of the >> almost orthogonal case << in the full svd else @@ -69420,7 +69414,7 @@ module stdlib_linalg_lapack_d ! implementation of blas and some lapack procedures, capable of working ! in presence of extreme values. since that is not always the case, ... do p = 1, nr - call stdlib_dcopy( n-p+1, a(p,p), lda, v(p,p), 1 ) + call stdlib${ii}$_dcopy( n-p+1, a(p,p), lda, v(p,p), 1_${ik}$ ) end do if ( l2pert ) then xsc = sqrt(small/epsln) @@ -69433,12 +69427,12 @@ module stdlib_linalg_lapack_d end do end do else - call stdlib_dlaset( 'U', nr-1, nr-1, zero, zero, v(1,2), ldv ) + call stdlib${ii}$_dlaset( 'U', nr-1, nr-1, zero, zero, v(1_${ik}$,2_${ik}$), ldv ) end if - call stdlib_dgeqrf( n, nr, v, ldv, work(n+1), work(2*n+1),lwork-2*n, ierr ) - call stdlib_dlacpy( 'L', n, nr, v, ldv, work(2*n+1), n ) + call stdlib${ii}$_dgeqrf( n, nr, v, ldv, work(n+1), work(2_${ik}$*n+1),lwork-2*n, ierr ) + call stdlib${ii}$_dlacpy( 'L', n, nr, v, ldv, work(2_${ik}$*n+1), n ) do p = 1, nr - call stdlib_dcopy( nr-p+1, v(p,p), ldv, u(p,p), 1 ) + call stdlib${ii}$_dcopy( nr-p+1, v(p,p), ldv, u(p,p), 1_${ik}$ ) end do if ( l2pert ) then xsc = sqrt(small/epsln) @@ -69449,18 +69443,18 @@ module stdlib_linalg_lapack_d end do end do else - call stdlib_dlaset('U', nr-1, nr-1, zero, zero, u(1,2), ldu ) + call stdlib${ii}$_dlaset('U', nr-1, nr-1, zero, zero, u(1_${ik}$,2_${ik}$), ldu ) end if - call stdlib_dgesvj( 'G', 'U', 'V', nr, nr, u, ldu, sva,n, v, ldv, work(2*n+n*nr+1), & + call stdlib${ii}$_dgesvj( 'G', 'U', 'V', nr, nr, u, ldu, sva,n, v, ldv, work(2_${ik}$*n+n*nr+1), & lwork-2*n-n*nr, info ) - scalem = work(2*n+n*nr+1) - numrank = nint(work(2*n+n*nr+2),KIND=ilp) + scalem = work(2_${ik}$*n+n*nr+1) + numrank = nint(work(2_${ik}$*n+n*nr+2),KIND=${ik}$) if ( nr < n ) then - call stdlib_dlaset( 'A',n-nr,nr,zero,zero,v(nr+1,1),ldv ) - call stdlib_dlaset( 'A',nr,n-nr,zero,zero,v(1,nr+1),ldv ) - call stdlib_dlaset( 'A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv ) + call stdlib${ii}$_dlaset( 'A',n-nr,nr,zero,zero,v(nr+1,1_${ik}$),ldv ) + call stdlib${ii}$_dlaset( 'A',nr,n-nr,zero,zero,v(1_${ik}$,nr+1),ldv ) + call stdlib${ii}$_dlaset( 'A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv ) end if - call stdlib_dormqr( 'L','N',n,n,nr,work(2*n+1),n,work(n+1),v,ldv,work(2*n+n*nr+nr+1)& + call stdlib${ii}$_dormqr( 'L','N',n,n,nr,work(2_${ik}$*n+1),n,work(n+1),v,ldv,work(2_${ik}$*n+n*nr+nr+1)& ,lwork-2*n-n*nr-nr,ierr ) ! permute the rows of v using the (column) permutation from the ! first qrf. also, scale the columns to make them unit in @@ -69468,39 +69462,39 @@ module stdlib_linalg_lapack_d temp1 = sqrt(real(n,KIND=dp)) * epsln do q = 1, n do p = 1, n - work(2*n+n*nr+nr+iwork(p)) = v(p,q) + work(2_${ik}$*n+n*nr+nr+iwork(p)) = v(p,q) end do do p = 1, n - v(p,q) = work(2*n+n*nr+nr+p) + v(p,q) = work(2_${ik}$*n+n*nr+nr+p) end do - xsc = one / stdlib_dnrm2( n, v(1,q), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_dscal( n, xsc, & - v(1,q), 1 ) + xsc = one / stdlib${ii}$_dnrm2( n, v(1_${ik}$,q), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_dscal( n, xsc, & + v(1_${ik}$,q), 1_${ik}$ ) end do ! at this moment, v contains the right singular vectors of a. ! next, assemble the left singular vector matrix u (m x n). if ( nr < m ) then - call stdlib_dlaset( 'A', m-nr, nr, zero, zero, u(nr+1,1), ldu ) + call stdlib${ii}$_dlaset( 'A', m-nr, nr, zero, zero, u(nr+1,1_${ik}$), ldu ) if ( nr < n1 ) then - call stdlib_dlaset( 'A',nr, n1-nr, zero, zero, u(1,nr+1),ldu ) - call stdlib_dlaset( 'A',m-nr,n1-nr, zero, one,u(nr+1,nr+1),ldu ) + call stdlib${ii}$_dlaset( 'A',nr, n1-nr, zero, zero, u(1_${ik}$,nr+1),ldu ) + call stdlib${ii}$_dlaset( 'A',m-nr,n1-nr, zero, one,u(nr+1,nr+1),ldu ) end if end if - call stdlib_dormqr( 'LEFT', 'NO TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & + call stdlib${ii}$_dormqr( 'LEFT', 'NO TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & lwork-n, ierr ) - if ( rowpiv )call stdlib_dlaswp( n1, u, ldu, 1, m-1, iwork(2*n+1), -1 ) + if ( rowpiv )call stdlib${ii}$_dlaswp( n1, u, ldu, 1_${ik}$, m-1, iwork(2_${ik}$*n+1), -1_${ik}$ ) end if if ( transp ) then ! .. swap u and v because the procedure worked on a^t do p = 1, n - call stdlib_dswap( n, u(1,p), 1, v(1,p), 1 ) + call stdlib${ii}$_dswap( n, u(1_${ik}$,p), 1_${ik}$, v(1_${ik}$,p), 1_${ik}$ ) end do end if end if ! end of the full svd ! undo scaling, if necessary (and possible) - if ( uscal2 <= (big/sva(1))*uscal1 ) then - call stdlib_dlascl( 'G', 0, 0, uscal1, uscal2, nr, 1, sva, n, ierr ) + if ( uscal2 <= (big/sva(1_${ik}$))*uscal1 ) then + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, uscal1, uscal2, nr, 1_${ik}$, sva, n, ierr ) uscal1 = one uscal2 = one end if @@ -69509,25 +69503,25 @@ module stdlib_linalg_lapack_d sva(p) = zero end do end if - work(1) = uscal2 * scalem - work(2) = uscal1 - if ( errest ) work(3) = sconda + work(1_${ik}$) = uscal2 * scalem + work(2_${ik}$) = uscal1 + if ( errest ) work(3_${ik}$) = sconda if ( lsvec .and. rsvec ) then - work(4) = condr1 - work(5) = condr2 + work(4_${ik}$) = condr1 + work(5_${ik}$) = condr2 end if if ( l2tran ) then - work(6) = entra - work(7) = entrat + work(6_${ik}$) = entra + work(7_${ik}$) = entrat end if - iwork(1) = nr - iwork(2) = numrank - iwork(3) = warning + iwork(1_${ik}$) = nr + iwork(2_${ik}$) = numrank + iwork(3_${ik}$) = warning return - end subroutine stdlib_dgejsv + end subroutine stdlib${ii}$_dgejsv - pure subroutine stdlib_dgelq( m, n, a, lda, t, tsize, work, lwork,info ) + pure subroutine stdlib${ii}$_dgelq( m, n, a, lda, t, tsize, work, lwork,info ) !! DGELQ computes an LQ factorization of a real M-by-N matrix A: !! A = ( L 0 ) * Q !! where: @@ -69538,121 +69532,121 @@ module stdlib_linalg_lapack_d ! -- 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, tsize, lwork + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, tsize, lwork ! Array Arguments real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: t(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, lminws, mint, minw - integer(ilp) :: mb, nb, mintsz, nblcks, lwmin, lwopt, lwreq + integer(${ik}$) :: mb, nb, mintsz, nblcks, lwmin, lwopt, lwreq ! Intrinsic Functions intrinsic :: max,min,mod ! Executable Statements ! test the input arguments - info = 0 - lquery = ( tsize==-1 .or. tsize==-2 .or.lwork==-1 .or. lwork==-2 ) + info = 0_${ik}$ + lquery = ( tsize==-1_${ik}$ .or. tsize==-2_${ik}$ .or.lwork==-1_${ik}$ .or. lwork==-2_${ik}$ ) mint = .false. minw = .false. - if( tsize==-2 .or. lwork==-2 ) then - if( tsize/=-1 ) mint = .true. - if( lwork/=-1 ) minw = .true. + if( tsize==-2_${ik}$ .or. lwork==-2_${ik}$ ) then + if( tsize/=-1_${ik}$ ) mint = .true. + if( lwork/=-1_${ik}$ ) minw = .true. end if ! determine the block size - if( min( m, n )>0 ) then - mb = stdlib_ilaenv( 1, 'DGELQ ', ' ', m, n, 1, -1 ) - nb = stdlib_ilaenv( 1, 'DGELQ ', ' ', m, n, 2, -1 ) + if( min( m, n )>0_${ik}$ ) then + mb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGELQ ', ' ', m, n, 1_${ik}$, -1_${ik}$ ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGELQ ', ' ', m, n, 2_${ik}$, -1_${ik}$ ) else - mb = 1 + mb = 1_${ik}$ nb = n end if - if( mb>min( m, n ) .or. mb<1 ) mb = 1 + if( mb>min( m, n ) .or. mb<1_${ik}$ ) mb = 1_${ik}$ if( nb>n .or. nb<=m ) nb = n - mintsz = m + 5 + mintsz = m + 5_${ik}$ if ( nb>m .and. n>m ) then - if( mod( n - m, nb - m )==0 ) then + if( mod( n - m, nb - m )==0_${ik}$ ) then nblcks = ( n - m ) / ( nb - m ) else - nblcks = ( n - m ) / ( nb - m ) + 1 + nblcks = ( n - m ) / ( nb - m ) + 1_${ik}$ end if else - nblcks = 1 + nblcks = 1_${ik}$ end if ! determine if the workspace size satisfies minimal size if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then - lwmin = max( 1, n ) - lwopt = max( 1, mb*n ) + lwmin = max( 1_${ik}$, n ) + lwopt = max( 1_${ik}$, mb*n ) else - lwmin = max( 1, m ) - lwopt = max( 1, mb*m ) + lwmin = max( 1_${ik}$, m ) + lwopt = max( 1_${ik}$, mb*m ) end if lminws = .false. - if( ( tsize=lwmin ) .and. ( & + if( ( tsize=lwmin ) .and. ( & tsize>=mintsz ).and. ( .not.lquery ) ) then - if( tsize=n ) ) then - lwreq = max( 1, mb*n ) + lwreq = max( 1_${ik}$, mb*n ) else - lwreq = max( 1, mb*m ) + lwreq = max( 1_${ik}$, mb*m ) end if - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda=n ) ) then - call stdlib_dgelqt( m, n, mb, a, lda, t( 6 ), mb, work, info ) + call stdlib${ii}$_dgelqt( m, n, mb, a, lda, t( 6_${ik}$ ), mb, work, info ) else - call stdlib_dlaswlq( m, n, mb, nb, a, lda, t( 6 ), mb, work,lwork, info ) + call stdlib${ii}$_dlaswlq( m, n, mb, nb, a, lda, t( 6_${ik}$ ), mb, work,lwork, info ) end if - work( 1 ) = lwreq + work( 1_${ik}$ ) = lwreq return - end subroutine stdlib_dgelq + end subroutine stdlib${ii}$_dgelq - subroutine stdlib_dgelsy( m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank,work, lwork, info ) + subroutine stdlib${ii}$_dgelsy( m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank,work, lwork, info ) !! DGELSY computes the minimum-norm solution to a real linear least !! squares problem: !! minimize || A * X - B || @@ -69690,22 +69684,22 @@ module stdlib_linalg_lapack_d ! -- 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, rank - integer(ilp), intent(in) :: lda, ldb, lwork, m, n, nrhs + integer(${ik}$), intent(out) :: info, rank + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, nrhs real(dp), intent(in) :: rcond ! Array Arguments - integer(ilp), intent(inout) :: jpvt(*) + integer(${ik}$), intent(inout) :: jpvt(*) real(dp), intent(inout) :: a(lda,*), b(ldb,*) real(dp), intent(out) :: work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: imax = 1 - integer(ilp), parameter :: imin = 2 + integer(${ik}$), parameter :: imax = 1_${ik}$ + integer(${ik}$), parameter :: imin = 2_${ik}$ ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, iascl, ibscl, ismax, ismin, j, lwkmin, lwkopt, mn, nb, nb1, nb2, & + integer(${ik}$) :: i, iascl, ibscl, ismax, ismin, j, lwkmin, lwkopt, mn, nb, nb1, nb2, & nb3, nb4 real(dp) :: anrm, bignum, bnrm, c1, c2, s1, s2, smax, smaxpr, smin, sminpr, smlnum, & wsize @@ -69713,87 +69707,87 @@ module stdlib_linalg_lapack_d intrinsic :: abs,max,min ! Executable Statements mn = min( m, n ) - ismin = mn + 1 - ismax = 2*mn + 1 + ismin = mn + 1_${ik}$ + ismax = 2_${ik}$*mn + 1_${ik}$ ! test the input arguments. - info = 0 - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( ldazero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_dlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_dlaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) - rank = 0 + call stdlib${ii}$_dlaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) + rank = 0_${ik}$ go to 70 end if - bnrm = stdlib_dlange( 'M', m, nrhs, b, ldb, work ) - ibscl = 0 + bnrm = stdlib${ii}$_dlange( 'M', m, nrhs, b, ldb, work ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_dlascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) - ibscl = 2 + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, m, nrhs, b, ldb, info ) + ibscl = 2_${ik}$ end if ! compute qr factorization with column pivoting of a: ! a * p = q * r - call stdlib_dgeqp3( m, n, a, lda, jpvt, work( 1 ), work( mn+1 ),lwork-mn, info ) + call stdlib${ii}$_dgeqp3( m, n, a, lda, jpvt, work( 1_${ik}$ ), work( mn+1 ),lwork-mn, info ) wsize = mn + work( mn+1 ) ! workspace: mn+2*n+nb*(n+1). @@ -69801,21 +69795,21 @@ module stdlib_linalg_lapack_d ! determine rank using incremental condition estimation work( ismin ) = one work( ismax ) = one - smax = abs( a( 1, 1 ) ) + smax = abs( a( 1_${ik}$, 1_${ik}$ ) ) smin = smax - if( abs( a( 1, 1 ) )==zero ) then - rank = 0 - call stdlib_dlaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) + if( abs( a( 1_${ik}$, 1_${ik}$ ) )==zero ) then + rank = 0_${ik}$ + call stdlib${ii}$_dlaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) go to 70 else - rank = 1 + rank = 1_${ik}$ end if 10 continue if( rank0 ) then - mb = stdlib_ilaenv( 1, 'DGEQR ', ' ', m, n, 1, -1 ) - nb = stdlib_ilaenv( 1, 'DGEQR ', ' ', m, n, 2, -1 ) + if( min( m, n )>0_${ik}$ ) then + mb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQR ', ' ', m, n, 1_${ik}$, -1_${ik}$ ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQR ', ' ', m, n, 2_${ik}$, -1_${ik}$ ) else mb = m - nb = 1 + nb = 1_${ik}$ end if if( mb>m .or. mb<=n ) mb = m - if( nb>min( m, n ) .or. nb<1 ) nb = 1 - mintsz = n + 5 + if( nb>min( m, n ) .or. nb<1_${ik}$ ) nb = 1_${ik}$ + mintsz = n + 5_${ik}$ if( mb>n .and. m>n ) then - if( mod( m - n, mb - n )==0 ) then + if( mod( m - n, mb - n )==0_${ik}$ ) then nblcks = ( m - n ) / ( mb - n ) else - nblcks = ( m - n ) / ( mb - n ) + 1 + nblcks = ( m - n ) / ( mb - n ) + 1_${ik}$ end if else - nblcks = 1 + nblcks = 1_${ik}$ end if ! determine if the workspace size satisfies minimal size lminws = .false. - if( ( tsize=n ) .and. ( & + if( ( tsize=n ) .and. ( & tsize>=mintsz ).and. ( .not.lquery ) ) then - if( tsize=m ) ) then - call stdlib_dgeqrt( m, n, nb, a, lda, t( 6 ), nb, work, info ) + call stdlib${ii}$_dgeqrt( m, n, nb, a, lda, t( 6_${ik}$ ), nb, work, info ) else - call stdlib_dlatsqr( m, n, mb, nb, a, lda, t( 6 ), nb, work,lwork, info ) + call stdlib${ii}$_dlatsqr( m, n, mb, nb, a, lda, t( 6_${ik}$ ), nb, work,lwork, info ) end if - work( 1 ) = max( 1, nb*n ) + work( 1_${ik}$ ) = max( 1_${ik}$, nb*n ) return - end subroutine stdlib_dgeqr + end subroutine stdlib${ii}$_dgeqr - subroutine stdlib_dgetsls( trans, m, n, nrhs, a, lda, b, ldb,work, lwork, info ) + subroutine stdlib${ii}$_dgetsls( trans, m, n, nrhs, a, lda, b, ldb,work, lwork, info ) !! DGETSLS solves overdetermined or underdetermined real linear systems !! involving an M-by-N matrix A, using a tall skinny QR or short wide LQ !! factorization of A. It is assumed that A has full rank. @@ -70024,8 +70018,8 @@ module stdlib_linalg_lapack_d ! -- 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) :: lda, ldb, lwork, m, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, nrhs ! Array Arguments real(dp), intent(inout) :: a(lda,*), b(ldb,*) real(dp), intent(out) :: work(*) @@ -70033,74 +70027,74 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: lquery, tran - integer(ilp) :: i, iascl, ibscl, j, maxmn, brow, scllen, tszo, tszm, lwo, lwm, lw1, & + integer(${ik}$) :: i, iascl, ibscl, j, maxmn, brow, scllen, tszo, tszm, lwo, lwm, lw1, & lw2, wsizeo, wsizem, info2 - real(dp) :: anrm, bignum, bnrm, smlnum, tq(5), workq(1) + real(dp) :: anrm, bignum, bnrm, smlnum, tq(5_${ik}$), workq(1_${ik}$) ! Intrinsic Functions intrinsic :: real,max,min,int ! Executable Statements ! test the input arguments. - info = 0 + info = 0_${ik}$ maxmn = max( m, n ) tran = stdlib_lsame( trans, 'T' ) - lquery = ( lwork==-1 .or. lwork==-2 ) + lquery = ( lwork==-1_${ik}$ .or. lwork==-2_${ik}$ ) if( .not.( stdlib_lsame( trans, 'N' ) .or.stdlib_lsame( trans, 'T' ) ) ) then - info = -1 - else if( m<0 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( nrhs<0 ) then - info = -4 - else if( lda=n ) then - call stdlib_dgeqr( m, n, a, lda, tq, -1, workq, -1, info2 ) - tszo = int( tq( 1 ),KIND=ilp) - lwo = int( workq( 1 ),KIND=ilp) - call stdlib_dgemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszo, b, ldb, workq, -1, & + call stdlib${ii}$_dgeqr( m, n, a, lda, tq, -1_${ik}$, workq, -1_${ik}$, info2 ) + tszo = int( tq( 1_${ik}$ ),KIND=${ik}$) + lwo = int( workq( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_dgemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszo, b, ldb, workq, -1_${ik}$, & info2 ) - lwo = max( lwo, int( workq( 1 ),KIND=ilp) ) - call stdlib_dgeqr( m, n, a, lda, tq, -2, workq, -2, info2 ) - tszm = int( tq( 1 ),KIND=ilp) - lwm = int( workq( 1 ),KIND=ilp) - call stdlib_dgemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszm, b, ldb, workq, -1, & + lwo = max( lwo, int( workq( 1_${ik}$ ),KIND=${ik}$) ) + call stdlib${ii}$_dgeqr( m, n, a, lda, tq, -2_${ik}$, workq, -2_${ik}$, info2 ) + tszm = int( tq( 1_${ik}$ ),KIND=${ik}$) + lwm = int( workq( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_dgemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszm, b, ldb, workq, -1_${ik}$, & info2 ) - lwm = max( lwm, int( workq( 1 ),KIND=ilp) ) + lwm = max( lwm, int( workq( 1_${ik}$ ),KIND=${ik}$) ) wsizeo = tszo + lwo wsizem = tszm + lwm else - call stdlib_dgelq( m, n, a, lda, tq, -1, workq, -1, info2 ) - tszo = int( tq( 1 ),KIND=ilp) - lwo = int( workq( 1 ),KIND=ilp) - call stdlib_dgemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszo, b, ldb, workq, -1, & + call stdlib${ii}$_dgelq( m, n, a, lda, tq, -1_${ik}$, workq, -1_${ik}$, info2 ) + tszo = int( tq( 1_${ik}$ ),KIND=${ik}$) + lwo = int( workq( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_dgemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszo, b, ldb, workq, -1_${ik}$, & info2 ) - lwo = max( lwo, int( workq( 1 ),KIND=ilp) ) - call stdlib_dgelq( m, n, a, lda, tq, -2, workq, -2, info2 ) - tszm = int( tq( 1 ),KIND=ilp) - lwm = int( workq( 1 ),KIND=ilp) - call stdlib_dgemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszm, b, ldb, workq, -1, & + lwo = max( lwo, int( workq( 1_${ik}$ ),KIND=${ik}$) ) + call stdlib${ii}$_dgelq( m, n, a, lda, tq, -2_${ik}$, workq, -2_${ik}$, info2 ) + tszm = int( tq( 1_${ik}$ ),KIND=${ik}$) + lwm = int( workq( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_dgemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszm, b, ldb, workq, -1_${ik}$, & info2 ) - lwm = max( lwm, int( workq( 1 ),KIND=ilp) ) + lwm = max( lwm, int( workq( 1_${ik}$ ),KIND=${ik}$) ) wsizeo = tszo + lwo wsizem = tszm + lwm end if if( ( lworkzero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_dlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_dlaset( 'F', maxmn, nrhs, zero, zero, b, ldb ) + call stdlib${ii}$_dlaset( 'F', maxmn, nrhs, zero, zero, b, ldb ) go to 50 end if brow = m if ( tran ) then brow = n end if - bnrm = stdlib_dlange( 'M', brow, nrhs, b, ldb, work ) - ibscl = 0 + bnrm = stdlib${ii}$_dlange( 'M', brow, nrhs, b, ldb, work ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_dlascl( 'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,info ) - ibscl = 2 + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, brow, nrhs, b, ldb,info ) + ibscl = 2_${ik}$ end if if ( m>=n ) then ! compute qr factorization of a - call stdlib_dgeqr( m, n, a, lda, work( lw2+1 ), lw1,work( 1 ), lw2, info ) + call stdlib${ii}$_dgeqr( m, n, a, lda, work( lw2+1 ), lw1,work( 1_${ik}$ ), lw2, info ) if ( .not.tran ) then ! least-squares problem min || a * x - b || ! b(1:m,1:nrhs) := q**t * b(1:m,1:nrhs) - call stdlib_dgemqr( 'L' , 'T', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, work(& - 1 ), lw2,info ) + call stdlib${ii}$_dgemqr( 'L' , 'T', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, work(& + 1_${ik}$ ), lw2,info ) ! b(1:n,1:nrhs) := inv(r) * b(1:n,1:nrhs) - call stdlib_dtrtrs( 'U', 'N', 'N', n, nrhs,a, lda, b, ldb, info ) - if( info>0 ) then + call stdlib${ii}$_dtrtrs( 'U', 'N', 'N', n, nrhs,a, lda, b, ldb, info ) + if( info>0_${ik}$ ) then return end if scllen = n else ! overdetermined system of equations a**t * x = b ! b(1:n,1:nrhs) := inv(r**t) * b(1:n,1:nrhs) - call stdlib_dtrtrs( 'U', 'T', 'N', n, nrhs,a, lda, b, ldb, info ) - if( info>0 ) then + call stdlib${ii}$_dtrtrs( 'U', 'T', 'N', n, nrhs,a, lda, b, ldb, info ) + if( info>0_${ik}$ ) then return end if ! b(n+1:m,1:nrhs) = zero @@ -70178,19 +70172,19 @@ module stdlib_linalg_lapack_d end do end do ! b(1:m,1:nrhs) := q(1:n,:) * b(1:n,1:nrhs) - call stdlib_dgemqr( 'L', 'N', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, & - work( 1 ), lw2,info ) + call stdlib${ii}$_dgemqr( 'L', 'N', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, & + work( 1_${ik}$ ), lw2,info ) scllen = m end if else ! compute lq factorization of a - call stdlib_dgelq( m, n, a, lda, work( lw2+1 ), lw1,work( 1 ), lw2, info ) + call stdlib${ii}$_dgelq( m, n, a, lda, work( lw2+1 ), lw1,work( 1_${ik}$ ), lw2, info ) ! workspace at least m, optimally m*nb. if( .not.tran ) then ! underdetermined system of equations a * x = b ! b(1:m,1:nrhs) := inv(l) * b(1:m,1:nrhs) - call stdlib_dtrtrs( 'L', 'N', 'N', m, nrhs,a, lda, b, ldb, info ) - if( info>0 ) then + call stdlib${ii}$_dtrtrs( 'L', 'N', 'N', m, nrhs,a, lda, b, ldb, info ) + if( info>0_${ik}$ ) then return end if ! b(m+1:n,1:nrhs) = 0 @@ -70200,43 +70194,43 @@ module stdlib_linalg_lapack_d end do end do ! b(1:n,1:nrhs) := q(1:n,:)**t * b(1:m,1:nrhs) - call stdlib_dgemlq( 'L', 'T', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & - work( 1 ), lw2,info ) + call stdlib${ii}$_dgemlq( 'L', 'T', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & + work( 1_${ik}$ ), lw2,info ) ! workspace at least nrhs, optimally nrhs*nb scllen = n else ! overdetermined system min || a**t * x - b || ! b(1:n,1:nrhs) := q * b(1:n,1:nrhs) - call stdlib_dgemlq( 'L', 'N', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & - work( 1 ), lw2,info ) + call stdlib${ii}$_dgemlq( 'L', 'N', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & + work( 1_${ik}$ ), lw2,info ) ! workspace at least nrhs, optimally nrhs*nb ! b(1:m,1:nrhs) := inv(l**t) * b(1:m,1:nrhs) - call stdlib_dtrtrs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & + call stdlib${ii}$_dtrtrs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if scllen = m end if end if ! undo scaling - if( iascl==1 ) then - call stdlib_dlascl( 'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,info ) - else if( iascl==2 ) then - call stdlib_dlascl( 'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,info ) + if( iascl==1_${ik}$ ) then + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, smlnum, scllen, nrhs, b, ldb,info ) + else if( iascl==2_${ik}$ ) then + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, scllen, nrhs, b, ldb,info ) end if - if( ibscl==1 ) then - call stdlib_dlascl( 'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,info ) - else if( ibscl==2 ) then - call stdlib_dlascl( 'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,info ) + if( ibscl==1_${ik}$ ) then + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, bnrm, scllen, nrhs, b, ldb,info ) + else if( ibscl==2_${ik}$ ) then + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bignum, bnrm, scllen, nrhs, b, ldb,info ) end if 50 continue - work( 1 ) = real( tszo + lwo,KIND=dp) + work( 1_${ik}$ ) = real( tszo + lwo,KIND=dp) return - end subroutine stdlib_dgetsls + end subroutine stdlib${ii}$_dgetsls - pure subroutine stdlib_dgetsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) + pure subroutine stdlib${ii}$_dgetsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) !! DGETSQRHRT computes a NB2-sized column blocked QR-factorization !! of a real M-by-N matrix A with M >= N, !! A = Q * R. @@ -70254,8 +70248,8 @@ module stdlib_linalg_lapack_d ! -- 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, nb1, nb2, mb1 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldt, lwork, m, n, nb1, nb2, mb1 ! Array Arguments real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: t(ldt,*), work(*) @@ -70263,41 +70257,41 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, iinfo, j, lw1, lw2, lwt, ldwt, lworkopt, nb1local, nb2local, & + integer(${ik}$) :: i, iinfo, j, lw1, lw2, lwt, ldwt, lworkopt, nb1local, nb2local, & num_all_row_blocks ! Intrinsic Functions intrinsic :: ceiling,real,max,min ! Executable Statements ! test the input arguments - info = 0 - lquery = lwork==-1 - if( m<0 ) then - info = -1 - else if( n<0 .or. mn1 .or. ( n / 2 )n1 .or. ( n / 2_${ik}$ )n )go to 100 if( rho*abs( z( nj ) )<=tol ) then ! deflate due to small z component. - k2 = k2 - 1 - coltyp( nj ) = 4 + k2 = k2 - 1_${ik}$ + coltyp( nj ) = 4_${ik}$ indxp( k2 ) = nj else ! check if eigenvalues are close enough to allow deflation. @@ -70501,7 +70495,7 @@ module stdlib_linalg_lapack_d c = z( nj ) ! find sqrt(a**2+b**2) without overflow or ! destructive underflow. - tau = stdlib_dlapy2( c, s ) + tau = stdlib${ii}$_dlapy2( c, s ) t = d( nj ) - d( pj ) c = c / tau s = -s / tau @@ -70509,20 +70503,20 @@ module stdlib_linalg_lapack_d ! deflation is possible. z( nj ) = tau z( pj ) = zero - if( coltyp( nj )/=coltyp( pj ) )coltyp( nj ) = 2 - coltyp( pj ) = 4 - call stdlib_drot( n, q( 1, pj ), 1, q( 1, nj ), 1, c, s ) - t = d( pj )*c**2 + d( nj )*s**2 - d( nj ) = d( pj )*s**2 + d( nj )*c**2 + if( coltyp( nj )/=coltyp( pj ) )coltyp( nj ) = 2_${ik}$ + coltyp( pj ) = 4_${ik}$ + call stdlib${ii}$_drot( n, q( 1_${ik}$, pj ), 1_${ik}$, q( 1_${ik}$, nj ), 1_${ik}$, c, s ) + t = d( pj )*c**2_${ik}$ + d( nj )*s**2_${ik}$ + d( nj ) = d( pj )*s**2_${ik}$ + d( nj )*c**2_${ik}$ d( pj ) = t - k2 = k2 - 1 - i = 1 + k2 = k2 - 1_${ik}$ + i = 1_${ik}$ 90 continue if( k2+i<=n ) then if( d( pj )kbot )return ! ... nor for an empty deflation window. ==== if( nw<1 )return ! ==== machine constants ==== - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) safmax = one / safmin - call stdlib_dlabad( safmin, safmax ) - ulp = stdlib_dlamch( 'PRECISION' ) + call stdlib${ii}$_dlabad( safmin, safmax ) + ulp = stdlib${ii}$_dlamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=dp) / ulp ) ! ==== setup deflation window ==== jw = min( nw, kbot-ktop+1 ) - kwtop = kbot - jw + 1 + kwtop = kbot - jw + 1_${ik}$ if( kwtop==ktop ) then s = zero else @@ -70707,14 +70701,14 @@ module stdlib_linalg_lapack_d ! ==== 1-by-1 deflation window: not much to do ==== sr( kwtop ) = h( kwtop, kwtop ) si( kwtop ) = zero - ns = 1 - nd = 0 + ns = 1_${ik}$ + nd = 0_${ik}$ if( abs( s )<=max( smlnum, ulp*abs( h( kwtop, kwtop ) ) ) )then - ns = 0 - nd = 1 + ns = 0_${ik}$ + nd = 1_${ik}$ if( kwtop>ktop )h( kwtop, kwtop-1 ) = zero end if - work( 1 ) = one + work( 1_${ik}$ ) = one return end if ! ==== convert to spike-triangular form. (in case of a @@ -70722,23 +70716,23 @@ module stdlib_linalg_lapack_d ! . aggressive early deflation using that part of ! . the deflation window that converged using infqr ! . here and there to keep track.) ==== - call stdlib_dlacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) - call stdlib_dcopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 ) - call stdlib_dlaset( 'A', jw, jw, zero, one, v, ldv ) - call stdlib_dlahqr( .true., .true., jw, 1, jw, t, ldt, sr( kwtop ),si( kwtop ), 1, jw, & + call stdlib${ii}$_dlacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) + call stdlib${ii}$_dcopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2_${ik}$, 1_${ik}$ ), ldt+1 ) + call stdlib${ii}$_dlaset( 'A', jw, jw, zero, one, v, ldv ) + call stdlib${ii}$_dlahqr( .true., .true., jw, 1_${ik}$, jw, t, ldt, sr( kwtop ),si( kwtop ), 1_${ik}$, jw, & v, ldv, infqr ) - ! ==== stdlib_dtrexc needs a clean margin near the diagonal ==== + ! ==== stdlib${ii}$_dtrexc needs a clean margin near the diagonal ==== do j = 1, jw - 3 t( j+2, j ) = zero t( j+3, j ) = zero end do - if( jw>2 )t( jw, jw-2 ) = zero + if( jw>2_${ik}$ )t( jw, jw-2 ) = zero ! ==== deflation detection loop ==== ns = jw - ilst = infqr + 1 + ilst = infqr + 1_${ik}$ 20 continue if( ilst<=ns ) then - if( ns==1 ) then + if( ns==1_${ik}$ ) then bulge = .false. else bulge = t( ns, ns-1 )/=zero @@ -70748,56 +70742,56 @@ module stdlib_linalg_lapack_d ! ==== real eigenvalue ==== foo = abs( t( ns, ns ) ) if( foo==zero )foo = abs( s ) - if( abs( s*v( 1, ns ) )<=max( smlnum, ulp*foo ) ) then + if( abs( s*v( 1_${ik}$, ns ) )<=max( smlnum, ulp*foo ) ) then ! ==== deflatable ==== - ns = ns - 1 + ns = ns - 1_${ik}$ else ! ==== undeflatable. move it up out of the way. - ! . (stdlib_dtrexc can not fail in this case.) ==== + ! . (stdlib${ii}$_dtrexc can not fail in this case.) ==== ifst = ns - call stdlib_dtrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) - ilst = ilst + 1 + call stdlib${ii}$_dtrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) + ilst = ilst + 1_${ik}$ end if else ! ==== complex conjugate pair ==== foo = abs( t( ns, ns ) ) + sqrt( abs( t( ns, ns-1 ) ) )*sqrt( abs( t( ns-1, ns ) & ) ) if( foo==zero )foo = abs( s ) - if( max( abs( s*v( 1, ns ) ), abs( s*v( 1, ns-1 ) ) )<=max( smlnum, ulp*foo ) ) & + if( max( abs( s*v( 1_${ik}$, ns ) ), abs( s*v( 1_${ik}$, ns-1 ) ) )<=max( smlnum, ulp*foo ) ) & then ! ==== deflatable ==== - ns = ns - 2 + ns = ns - 2_${ik}$ else ! ==== undeflatable. move them up out of the way. - ! . fortunately, stdlib_dtrexc does the right thing with + ! . fortunately, stdlib${ii}$_dtrexc does the right thing with ! . ilst in case of a rare exchange failure. ==== ifst = ns - call stdlib_dtrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) - ilst = ilst + 2 + call stdlib${ii}$_dtrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) + ilst = ilst + 2_${ik}$ end if end if ! ==== end deflation detection loop ==== go to 20 end if ! ==== return to hessenberg form ==== - if( ns==0 )s = zero + if( ns==0_${ik}$ )s = zero if( ns1 .and. s/=zero ) then + if( ns>1_${ik}$ .and. s/=zero ) then ! ==== reflect spike back into lower triangle ==== - call stdlib_dcopy( ns, v, ldv, work, 1 ) - beta = work( 1 ) - call stdlib_dlarfg( ns, beta, work( 2 ), 1, tau ) - work( 1 ) = one - call stdlib_dlaset( 'L', jw-2, jw-2, zero, zero, t( 3, 1 ), ldt ) - call stdlib_dlarf( 'L', ns, jw, work, 1, tau, t, ldt,work( jw+1 ) ) - call stdlib_dlarf( 'R', ns, ns, work, 1, tau, t, ldt,work( jw+1 ) ) - call stdlib_dlarf( 'R', jw, ns, work, 1, tau, v, ldv,work( jw+1 ) ) - call stdlib_dgehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) + call stdlib${ii}$_dcopy( ns, v, ldv, work, 1_${ik}$ ) + beta = work( 1_${ik}$ ) + call stdlib${ii}$_dlarfg( ns, beta, work( 2_${ik}$ ), 1_${ik}$, tau ) + work( 1_${ik}$ ) = one + call stdlib${ii}$_dlaset( 'L', jw-2, jw-2, zero, zero, t( 3_${ik}$, 1_${ik}$ ), ldt ) + call stdlib${ii}$_dlarf( 'L', ns, jw, work, 1_${ik}$, tau, t, ldt,work( jw+1 ) ) + call stdlib${ii}$_dlarf( 'R', ns, ns, work, 1_${ik}$, tau, t, ldt,work( jw+1 ) ) + call stdlib${ii}$_dlarf( 'R', jw, ns, work, 1_${ik}$, tau, v, ldv,work( jw+1 ) ) + call stdlib${ii}$_dgehrd( jw, 1_${ik}$, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) end if ! ==== copy updated reduced window into place ==== - if( kwtop>1 )h( kwtop, kwtop-1 ) = s*v( 1, 1 ) - call stdlib_dlacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) - call stdlib_dcopy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) + if( kwtop>1_${ik}$ )h( kwtop, kwtop-1 ) = s*v( 1_${ik}$, 1_${ik}$ ) + call stdlib${ii}$_dlacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) + call stdlib${ii}$_dcopy( jw-1, t( 2_${ik}$, 1_${ik}$ ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) ! ==== accumulate orthogonal matrix in order update ! . h and z, if requested. ==== - if( ns>1 .and. s/=zero )call stdlib_dormhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, & + if( ns>1_${ik}$ .and. s/=zero )call stdlib${ii}$_dormhr( 'R', 'N', jw, ns, 1_${ik}$, ns, t, ldt, work, & v, ldv,work( jw+1 ), lwork-jw, info ) ! ==== update vertical slab in h ==== if( wantt ) then - ltop = 1 + ltop = 1_${ik}$ else ltop = ktop end if do krow = ltop, kwtop - 1, nv kln = min( nv, kwtop-krow ) - call stdlib_dgemm( 'N', 'N', kln, jw, jw, one, h( krow, kwtop ),ldh, v, ldv, & + call stdlib${ii}$_dgemm( 'N', 'N', kln, jw, jw, one, h( krow, kwtop ),ldh, v, ldv, & zero, wv, ldwv ) - call stdlib_dlacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) + call stdlib${ii}$_dlacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) end do ! ==== update horizontal slab in h ==== if( wantt ) then do kcol = kbot + 1, n, nh kln = min( nh, n-kcol+1 ) - call stdlib_dgemm( 'C', 'N', jw, kln, jw, one, v, ldv,h( kwtop, kcol ), ldh, & + call stdlib${ii}$_dgemm( 'C', 'N', jw, kln, jw, one, v, ldv,h( kwtop, kcol ), ldh, & zero, t, ldt ) - call stdlib_dlacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) + call stdlib${ii}$_dlacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) end do end if ! ==== update vertical slab in z ==== if( wantz ) then do krow = iloz, ihiz, nv kln = min( nv, ihiz-krow+1 ) - call stdlib_dgemm( 'N', 'N', kln, jw, jw, one, z( krow, kwtop ),ldz, v, ldv, & + call stdlib${ii}$_dgemm( 'N', 'N', kln, jw, jw, one, z( krow, kwtop ),ldz, v, ldv, & zero, wv, ldwv ) - call stdlib_dlacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) + call stdlib${ii}$_dlacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) end do end if end if @@ -70925,11 +70919,11 @@ module stdlib_linalg_lapack_d ! . window.) ==== ns = ns - infqr ! ==== return optimal workspace. ==== - work( 1 ) = real( lwkopt,KIND=dp) - end subroutine stdlib_dlaqr2 + work( 1_${ik}$ ) = real( lwkopt,KIND=dp) + end subroutine stdlib${ii}$_dlaqr2 - pure subroutine stdlib_dlasd1( nl, nr, sqre, d, alpha, beta, u, ldu, vt, ldvt,idxq, iwork, & + pure subroutine stdlib${ii}$_dlasd1( nl, nr, sqre, d, alpha, beta, u, ldu, vt, ldvt,idxq, iwork, & !! DLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B, !! where N = NL + NR + 1 and M = N + SQRE. DLASD1 is called from DLASD0. !! A related subroutine DLASD7 handles the case in which the singular @@ -70964,49 +70958,49 @@ module stdlib_linalg_lapack_d ! -- 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) :: ldu, ldvt, nl, nr, sqre + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldu, ldvt, nl, nr, sqre real(dp), intent(inout) :: alpha, beta ! Array Arguments - integer(ilp), intent(inout) :: idxq(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(inout) :: idxq(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(inout) :: d(*), u(ldu,*), vt(ldvt,*) real(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: coltyp, i, idx, idxc, idxp, iq, isigma, iu2, ivt2, iz, k, ldq, ldu2, & + integer(${ik}$) :: coltyp, i, idx, idxc, idxp, iq, isigma, iu2, ivt2, iz, k, ldq, ldu2, & ldvt2, m, n, n1, n2 real(dp) :: orgnrm ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements ! test the input parameters. - info = 0 - if( nl<1 ) then - info = -1 - else if( nr<1 ) then - info = -2 - else if( ( sqre<0 ) .or. ( sqre>1 ) ) then - info = -3 + info = 0_${ik}$ + if( nl<1_${ik}$ ) then + info = -1_${ik}$ + else if( nr<1_${ik}$ ) then + info = -2_${ik}$ + else if( ( sqre<0_${ik}$ ) .or. ( sqre>1_${ik}$ ) ) then + info = -3_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'DLASD1', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DLASD1', -info ) return end if - n = nl + nr + 1 + n = nl + nr + 1_${ik}$ m = n + sqre ! the following values are for bookkeeping purposes only. they are ! integer pointers which indicate the portion of the workspace - ! used by a particular array in stdlib_dlasd2 and stdlib_dlasd3. + ! used by a particular array in stdlib${ii}$_dlasd2 and stdlib${ii}$_dlasd3. ldu2 = n ldvt2 = m - iz = 1 + iz = 1_${ik}$ isigma = iz + m iu2 = isigma + n ivt2 = iu2 + ldu2*n iq = ivt2 + ldvt2*m - idx = 1 + idx = 1_${ik}$ idxc = idx + n coltyp = idxc + n idxp = coltyp + n @@ -71018,33 +71012,33 @@ module stdlib_linalg_lapack_d orgnrm = abs( d( i ) ) end if end do - call stdlib_dlascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, n, 1_${ik}$, d, n, info ) alpha = alpha / orgnrm beta = beta / orgnrm ! deflate singular values. - call stdlib_dlasd2( nl, nr, sqre, k, d, work( iz ), alpha, beta, u, ldu,vt, ldvt, work(& + call stdlib${ii}$_dlasd2( nl, nr, sqre, k, d, work( iz ), alpha, beta, u, ldu,vt, ldvt, work(& isigma ), work( iu2 ), ldu2,work( ivt2 ), ldvt2, iwork( idxp ), iwork( idx ),iwork( & idxc ), idxq, iwork( coltyp ), info ) ! solve secular equation and update singular vectors. ldq = k - call stdlib_dlasd3( nl, nr, sqre, k, d, work( iq ), ldq, work( isigma ),u, ldu, work( & + call stdlib${ii}$_dlasd3( nl, nr, sqre, k, d, work( iq ), ldq, work( isigma ),u, ldu, work( & iu2 ), ldu2, vt, ldvt, work( ivt2 ),ldvt2, iwork( idxc ), iwork( coltyp ), work( iz ),& info ) ! report the convergence failure. - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if ! unscale. - call stdlib_dlascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, n, 1_${ik}$, d, n, info ) ! prepare the idxq sorting permutation. n1 = k n2 = n - k - call stdlib_dlamrg( n1, n2, d, 1, -1, idxq ) + call stdlib${ii}$_dlamrg( n1, n2, d, 1_${ik}$, -1_${ik}$, idxq ) return - end subroutine stdlib_dlasd1 + end subroutine stdlib${ii}$_dlasd1 - pure subroutine stdlib_dlaed1( n, d, q, ldq, indxq, rho, cutpnt, work, iwork,info ) + pure subroutine stdlib${ii}$_dlaed1( n, d, q, ldq, indxq, rho, cutpnt, work, iwork,info ) !! DLAED1 computes the updated eigensystem of a diagonal !! matrix after modification by a rank-one symmetric matrix. This !! routine is used only for the eigenproblem which requires all @@ -71075,68 +71069,68 @@ module stdlib_linalg_lapack_d ! -- 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) :: cutpnt, ldq, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: cutpnt, ldq, n + integer(${ik}$), intent(out) :: info real(dp), intent(inout) :: rho ! Array Arguments - integer(ilp), intent(inout) :: indxq(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(inout) :: indxq(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(inout) :: d(*), q(ldq,*) real(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: coltyp, i, idlmda, indx, indxc, indxp, iq2, is, iw, iz, k, n1, n2, & + integer(${ik}$) :: coltyp, i, idlmda, indx, indxc, indxp, iq2, is, iw, iz, k, n1, n2, & zpp1 ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input parameters. - info = 0 - if( n<0 ) then - info = -1 - else if( ldqcutpnt .or. ( n / 2 )cutpnt .or. ( n / 2_${ik}$ )2 ) then - info = -1 - else if( ( icompq==1 ) .and. ( qsiz2_${ik}$ ) then + info = -1_${ik}$ + else if( ( icompq==1_${ik}$ ) .and. ( qsizsmlsiz ) then do j = subpbs, 1, -1 - iwork( 2*j ) = ( iwork( j )+1 ) / 2 - iwork( 2*j-1 ) = iwork( j ) / 2 + iwork( 2_${ik}$*j ) = ( iwork( j )+1_${ik}$ ) / 2_${ik}$ + iwork( 2_${ik}$*j-1 ) = iwork( j ) / 2_${ik}$ end do - tlvls = tlvls + 1 - subpbs = 2*subpbs + tlvls = tlvls + 1_${ik}$ + subpbs = 2_${ik}$*subpbs go to 10 end if do j = 2, subpbs @@ -71211,147 +71205,147 @@ module stdlib_linalg_lapack_d end do ! divide the matrix into subpbs submatrices of size at most smlsiz+1 ! using rank-1 modifications (cuts). - spm1 = subpbs - 1 + spm1 = subpbs - 1_${ik}$ do i = 1, spm1 - submat = iwork( i ) + 1 - smm1 = submat - 1 + submat = iwork( i ) + 1_${ik}$ + smm1 = submat - 1_${ik}$ d( smm1 ) = d( smm1 ) - abs( e( smm1 ) ) d( submat ) = d( submat ) - abs( e( smm1 ) ) end do - indxq = 4*n + 3 - if( icompq/=2 ) then + indxq = 4_${ik}$*n + 3_${ik}$ + if( icompq/=2_${ik}$ ) then ! set up workspaces for eigenvalues only/accumulate new vectors ! routine temp = log( real( n,KIND=dp) ) / log( two ) - lgn = int( temp,KIND=ilp) - if( 2**lgn 1 ) - curlvl = 1 + curlvl = 1_${ik}$ 80 continue - if( subpbs>1 ) then - spm2 = subpbs - 2 + if( subpbs>1_${ik}$ ) then + spm2 = subpbs - 2_${ik}$ loop_90: do i = 0, spm2, 2 - if( i==0 ) then - submat = 1 - matsiz = iwork( 2 ) - msd2 = iwork( 1 ) - curprb = 0 + if( i==0_${ik}$ ) then + submat = 1_${ik}$ + matsiz = iwork( 2_${ik}$ ) + msd2 = iwork( 1_${ik}$ ) + curprb = 0_${ik}$ else - submat = iwork( i ) + 1 + submat = iwork( i ) + 1_${ik}$ matsiz = iwork( i+2 ) - iwork( i ) - msd2 = matsiz / 2 - curprb = curprb + 1 + msd2 = matsiz / 2_${ik}$ + curprb = curprb + 1_${ik}$ end if ! merge lower order eigensystems (of size msd2 and matsiz - msd2) ! into an eigensystem of size matsiz. - ! stdlib_dlaed1 is used only for the full eigensystem of a tridiagonal + ! stdlib${ii}$_dlaed1 is used only for the full eigensystem of a tridiagonal ! matrix. - ! stdlib_dlaed7 handles the cases in which eigenvalues only or eigenvalues + ! stdlib${ii}$_dlaed7 handles the cases in which eigenvalues only or eigenvalues ! and eigenvectors of a full symmetric matrix (which was reduced to ! tridiagonal form) are desired. - if( icompq==2 ) then - call stdlib_dlaed1( matsiz, d( submat ), q( submat, submat ),ldq, iwork( & + if( icompq==2_${ik}$ ) then + call stdlib${ii}$_dlaed1( matsiz, d( submat ), q( submat, submat ),ldq, iwork( & indxq+submat ),e( submat+msd2-1 ), msd2, work,iwork( subpbs+1 ), info ) else - call stdlib_dlaed7( icompq, matsiz, qsiz, tlvls, curlvl, curprb,d( submat ), & - qstore( 1, submat ), ldqs,iwork( indxq+submat ), e( submat+msd2-1 ),msd2, & + call stdlib${ii}$_dlaed7( icompq, matsiz, qsiz, tlvls, curlvl, curprb,d( submat ), & + qstore( 1_${ik}$, submat ), ldqs,iwork( indxq+submat ), e( submat+msd2-1 ),msd2, & work( iq ), iwork( iqptr ),iwork( iprmpt ), iwork( iperm ),iwork( igivpt ), & iwork( igivcl ),work( igivnm ), work( iwrem ),iwork( subpbs+1 ), info ) end if if( info/=0 )go to 130 - iwork( i / 2+1 ) = iwork( i+2 ) + iwork( i / 2_${ik}$+1 ) = iwork( i+2 ) end do loop_90 - subpbs = subpbs / 2 - curlvl = curlvl + 1 + subpbs = subpbs / 2_${ik}$ + curlvl = curlvl + 1_${ik}$ go to 80 end if ! end while ! re-merge the eigenvalues/vectors which were deflated at the final ! merge step. - if( icompq==1 ) then + if( icompq==1_${ik}$ ) then do i = 1, n j = iwork( indxq+i ) work( i ) = d( j ) - call stdlib_dcopy( qsiz, qstore( 1, j ), 1, q( 1, i ), 1 ) + call stdlib${ii}$_dcopy( qsiz, qstore( 1_${ik}$, j ), 1_${ik}$, q( 1_${ik}$, i ), 1_${ik}$ ) end do - call stdlib_dcopy( n, work, 1, d, 1 ) - else if( icompq==2 ) then + call stdlib${ii}$_dcopy( n, work, 1_${ik}$, d, 1_${ik}$ ) + else if( icompq==2_${ik}$ ) then do i = 1, n j = iwork( indxq+i ) work( i ) = d( j ) - call stdlib_dcopy( n, q( 1, j ), 1, work( n*i+1 ), 1 ) + call stdlib${ii}$_dcopy( n, q( 1_${ik}$, j ), 1_${ik}$, work( n*i+1 ), 1_${ik}$ ) end do - call stdlib_dcopy( n, work, 1, d, 1 ) - call stdlib_dlacpy( 'A', n, n, work( n+1 ), n, q, ldq ) + call stdlib${ii}$_dcopy( n, work, 1_${ik}$, d, 1_${ik}$ ) + call stdlib${ii}$_dlacpy( 'A', n, n, work( n+1 ), n, q, ldq ) else do i = 1, n j = iwork( indxq+i ) work( i ) = d( j ) end do - call stdlib_dcopy( n, work, 1, d, 1 ) + call stdlib${ii}$_dcopy( n, work, 1_${ik}$, d, 1_${ik}$ ) end if go to 140 130 continue - info = submat*( n+1 ) + submat + matsiz - 1 + info = submat*( n+1 ) + submat + matsiz - 1_${ik}$ 140 continue return - end subroutine stdlib_dlaed0 + end subroutine stdlib${ii}$_dlaed0 - pure subroutine stdlib_dstedc( compz, n, d, e, z, ldz, work, lwork, iwork,liwork, info ) + pure subroutine stdlib${ii}$_dstedc( compz, n, d, e, z, ldz, work, lwork, iwork,liwork, info ) !! DSTEDC computes all eigenvalues and, optionally, eigenvectors of a !! symmetric tridiagonal matrix using the divide and conquer method. !! The eigenvectors of a full or band real symmetric matrix can also be @@ -71369,115 +71363,115 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: compz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldz, liwork, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldz, liwork, lwork, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(inout) :: d(*), e(*), z(ldz,*) real(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: finish, i, icompz, ii, j, k, lgn, liwmin, lwmin, m, smlsiz, start, & + integer(${ik}$) :: finish, i, icompz, ii, j, k, lgn, liwmin, lwmin, m, smlsiz, start, & storez, strtrw real(dp) :: eps, orgnrm, p, tiny ! Intrinsic Functions intrinsic :: abs,real,int,log,max,mod,sqrt ! Executable Statements ! test the input parameters. - info = 0 - lquery = ( lwork==-1 .or. liwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) if( stdlib_lsame( compz, 'N' ) ) then - icompz = 0 + icompz = 0_${ik}$ else if( stdlib_lsame( compz, 'V' ) ) then - icompz = 1 + icompz = 1_${ik}$ else if( stdlib_lsame( compz, 'I' ) ) then - icompz = 2 + icompz = 2_${ik}$ else - icompz = -1 + icompz = -1_${ik}$ end if - if( icompz<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( ( ldz<1 ) .or.( icompz>0 .and. ldz0_${ik}$ .and. ldztiny ) then - finish = finish + 1 + finish = finish + 1_${ik}$ go to 20 end if end if ! (sub) problem determined. compute its size and solve it. - m = finish - start + 1 - if( m==1 ) then - start = finish + 1 + m = finish - start + 1_${ik}$ + if( m==1_${ik}$ ) then + start = finish + 1_${ik}$ go to 10 end if if( m>smlsiz ) then ! scale. - orgnrm = stdlib_dlanst( 'M', m, d( start ), e( start ) ) - call stdlib_dlascl( 'G', 0, 0, orgnrm, one, m, 1, d( start ), m,info ) - call stdlib_dlascl( 'G', 0, 0, orgnrm, one, m-1, 1, e( start ),m-1, info ) + orgnrm = stdlib${ii}$_dlanst( 'M', m, d( start ), e( start ) ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, m, 1_${ik}$, d( start ), m,info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, m-1, 1_${ik}$, e( start ),m-1, info ) - if( icompz==1 ) then - strtrw = 1 + if( icompz==1_${ik}$ ) then + strtrw = 1_${ik}$ else strtrw = start end if - call stdlib_dlaed0( icompz, n, m, d( start ), e( start ),z( strtrw, start ), & - ldz, work( 1 ), n,work( storez ), iwork, info ) - if( info/=0 ) then + call stdlib${ii}$_dlaed0( icompz, n, m, d( start ), e( start ),z( strtrw, start ), & + ldz, work( 1_${ik}$ ), n,work( storez ), iwork, info ) + if( info/=0_${ik}$ ) then info = ( info / ( m+1 )+start-1 )*( n+1 ) +mod( info, ( m+1 ) ) + start - & - 1 + 1_${ik}$ go to 50 end if ! scale back. - call stdlib_dlascl( 'G', 0, 0, one, orgnrm, m, 1, d( start ), m,info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, m, 1_${ik}$, d( start ), m,info ) else - if( icompz==1 ) then + if( icompz==1_${ik}$ ) then ! since qr won't update a z matrix which is larger than ! the length of d, we must solve the sub-problem in a ! workspace and then multiply back into z. - call stdlib_dsteqr( 'I', m, d( start ), e( start ), work, m,work( m*m+1 ), & + call stdlib${ii}$_dsteqr( 'I', m, d( start ), e( start ), work, m,work( m*m+1 ), & info ) - call stdlib_dlacpy( 'A', n, m, z( 1, start ), ldz,work( storez ), n ) + call stdlib${ii}$_dlacpy( 'A', n, m, z( 1_${ik}$, start ), ldz,work( storez ), n ) - call stdlib_dgemm( 'N', 'N', n, m, m, one,work( storez ), n, work, m, zero,& - z( 1, start ), ldz ) - else if( icompz==2 ) then - call stdlib_dsteqr( 'I', m, d( start ), e( start ),z( start, start ), ldz, & + call stdlib${ii}$_dgemm( 'N', 'N', n, m, m, one,work( storez ), n, work, m, zero,& + z( 1_${ik}$, start ), ldz ) + else if( icompz==2_${ik}$ ) then + call stdlib${ii}$_dsteqr( 'I', m, d( start ), e( start ),z( start, start ), ldz, & work, info ) else - call stdlib_dsterf( m, d( start ), e( start ), info ) + call stdlib${ii}$_dsterf( m, d( start ), e( start ), info ) end if - if( info/=0 ) then + if( info/=0_${ik}$ ) then info = start*( n+1 ) + finish go to 50 end if end if - start = finish + 1 + start = finish + 1_${ik}$ go to 10 end if ! endwhile - if( icompz==0 ) then + if( icompz==0_${ik}$ ) then ! use quick sort - call stdlib_dlasrt( 'I', n, d, info ) + call stdlib${ii}$_dlasrt( 'I', n, d, info ) else ! use selection sort to minimize swaps of eigenvectors do ii = 2, n - i = ii - 1 + i = ii - 1_${ik}$ k = i p = d( i ) do j = ii, n @@ -71565,19 +71559,19 @@ module stdlib_linalg_lapack_d if( k/=i ) then d( k ) = d( i ) d( i ) = p - call stdlib_dswap( n, z( 1, i ), 1, z( 1, k ), 1 ) + call stdlib${ii}$_dswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, k ), 1_${ik}$ ) end if end do end if end if 50 continue - work( 1 ) = lwmin - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = lwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_dstedc + end subroutine stdlib${ii}$_dstedc - pure subroutine stdlib_dstevd( jobz, n, d, e, z, ldz, work, lwork, iwork,liwork, info ) + pure subroutine stdlib${ii}$_dstevd( jobz, n, d, e, z, ldz, work, lwork, iwork,liwork, info ) !! DSTEVD computes all eigenvalues and, optionally, eigenvectors of a !! real symmetric tridiagonal matrix. If eigenvectors are desired, it !! uses a divide and conquer algorithm. @@ -71593,96 +71587,96 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldz, liwork, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldz, liwork, lwork, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(inout) :: d(*), e(*) real(dp), intent(out) :: work(*), z(ldz,*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, wantz - integer(ilp) :: iscale, liwmin, lwmin + integer(${ik}$) :: iscale, liwmin, lwmin real(dp) :: bignum, eps, rmax, rmin, safmin, sigma, smlnum, tnrm ! Intrinsic Functions intrinsic :: sqrt ! Executable Statements ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) - lquery = ( lwork==-1 .or. liwork==-1 ) - info = 0 - liwmin = 1 - lwmin = 1 - if( n>1 .and. wantz ) then - lwmin = 1 + 4*n + n**2 - liwmin = 3 + 5*n + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) + info = 0_${ik}$ + liwmin = 1_${ik}$ + lwmin = 1_${ik}$ + if( n>1_${ik}$ .and. wantz ) then + lwmin = 1_${ik}$ + 4_${ik}$*n + n**2_${ik}$ + liwmin = 3_${ik}$ + 5_${ik}$*n end if if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( ldz<1 .or. ( wantz .and. ldzzero .and. tnrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / tnrm end if - if( iscale==1 ) then - call stdlib_dscal( n, sigma, d, 1 ) - call stdlib_dscal( n-1, sigma, e( 1 ), 1 ) + if( iscale==1_${ik}$ ) then + call stdlib${ii}$_dscal( n, sigma, d, 1_${ik}$ ) + call stdlib${ii}$_dscal( n-1, sigma, e( 1_${ik}$ ), 1_${ik}$ ) end if - ! for eigenvalues only, call stdlib_dsterf. for eigenvalues and - ! eigenvectors, call stdlib_dstedc. + ! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvalues and + ! eigenvectors, call stdlib${ii}$_dstedc. if( .not.wantz ) then - call stdlib_dsterf( n, d, e, info ) + call stdlib${ii}$_dsterf( n, d, e, info ) else - call stdlib_dstedc( 'I', n, d, e, z, ldz, work, lwork, iwork, liwork,info ) + call stdlib${ii}$_dstedc( 'I', n, d, e, z, ldz, work, lwork, iwork, liwork,info ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 )call stdlib_dscal( n, one / sigma, d, 1 ) - work( 1 ) = lwmin - iwork( 1 ) = liwmin + if( iscale==1_${ik}$ )call stdlib${ii}$_dscal( n, one / sigma, d, 1_${ik}$ ) + work( 1_${ik}$ ) = lwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_dstevd + end subroutine stdlib${ii}$_dstevd - subroutine stdlib_dsyevd( jobz, uplo, n, a, lda, w, work, lwork, iwork,liwork, info ) + subroutine stdlib${ii}$_dsyevd( jobz, uplo, n, a, lda, w, work, lwork, iwork,liwork, info ) !! DSYEVD computes all eigenvalues and, optionally, eigenvectors of a !! real symmetric matrix A. If eigenvectors are desired, it uses a !! divide and conquer algorithm. @@ -71699,17 +71693,17 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, liwork, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, liwork, lwork, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: w(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, lquery, wantz - integer(ilp) :: iinfo, inde, indtau, indwk2, indwrk, iscale, liopt, liwmin, llwork, & + integer(${ik}$) :: iinfo, inde, indtau, indwk2, indwrk, iscale, liopt, liwmin, llwork, & llwrk2, lopt, lwmin real(dp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! Intrinsic Functions @@ -71718,105 +71712,105 @@ module stdlib_linalg_lapack_d ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) lower = stdlib_lsame( uplo, 'L' ) - lquery = ( lwork==-1 .or. liwork==-1 ) - info = 0 + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldazero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 )call stdlib_dlascl( uplo, 0, 0, one, sigma, n, n, a, lda, info ) - ! call stdlib_dsytrd to reduce symmetric matrix to tridiagonal form. - inde = 1 + if( iscale==1_${ik}$ )call stdlib${ii}$_dlascl( uplo, 0_${ik}$, 0_${ik}$, one, sigma, n, n, a, lda, info ) + ! call stdlib${ii}$_dsytrd to reduce symmetric matrix to tridiagonal form. + inde = 1_${ik}$ indtau = inde + n indwrk = indtau + n - llwork = lwork - indwrk + 1 + llwork = lwork - indwrk + 1_${ik}$ indwk2 = indwrk + n*n - llwrk2 = lwork - indwk2 + 1 - call stdlib_dsytrd( uplo, n, a, lda, w, work( inde ), work( indtau ),work( indwrk ), & + llwrk2 = lwork - indwk2 + 1_${ik}$ + call stdlib${ii}$_dsytrd( uplo, n, a, lda, w, work( inde ), work( indtau ),work( indwrk ), & llwork, iinfo ) - ! for eigenvalues only, call stdlib_dsterf. for eigenvectors, first call - ! stdlib_dstedc to generate the eigenvector matrix, work(indwrk), of the - ! tridiagonal matrix, then call stdlib_dormtr to multiply it by the + ! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvectors, first call + ! stdlib${ii}$_dstedc to generate the eigenvector matrix, work(indwrk), of the + ! tridiagonal matrix, then call stdlib${ii}$_dormtr to multiply it by the ! householder transformations stored in a. if( .not.wantz ) then - call stdlib_dsterf( n, w, work( inde ), info ) + call stdlib${ii}$_dsterf( n, w, work( inde ), info ) else - call stdlib_dstedc( 'I', n, w, work( inde ), work( indwrk ), n,work( indwk2 ), & + call stdlib${ii}$_dstedc( 'I', n, w, work( inde ), work( indwrk ), n,work( indwk2 ), & llwrk2, iwork, liwork, info ) - call stdlib_dormtr( 'L', uplo, 'N', n, n, a, lda, work( indtau ),work( indwrk ), n, & + call stdlib${ii}$_dormtr( 'L', uplo, 'N', n, n, a, lda, work( indtau ),work( indwrk ), n, & work( indwk2 ), llwrk2, iinfo ) - call stdlib_dlacpy( 'A', n, n, work( indwrk ), n, a, lda ) + call stdlib${ii}$_dlacpy( 'A', n, n, work( indwrk ), n, a, lda ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 )call stdlib_dscal( n, one / sigma, w, 1 ) - work( 1 ) = lopt - iwork( 1 ) = liopt + if( iscale==1_${ik}$ )call stdlib${ii}$_dscal( n, one / sigma, w, 1_${ik}$ ) + work( 1_${ik}$ ) = lopt + iwork( 1_${ik}$ ) = liopt return - end subroutine stdlib_dsyevd + end subroutine stdlib${ii}$_dsyevd - subroutine stdlib_dsygvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, iwork, liwork,& + subroutine stdlib${ii}$_dsygvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, iwork, liwork,& !! DSYGVD computes all the eigenvalues, and optionally, the eigenvectors !! of a real generalized symmetric-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and @@ -71834,10 +71828,10 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: itype, lda, ldb, liwork, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: itype, lda, ldb, liwork, lwork, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(inout) :: a(lda,*), b(ldb,*) real(dp), intent(out) :: w(*), work(*) ! ===================================================================== @@ -71845,51 +71839,51 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: lquery, upper, wantz character :: trans - integer(ilp) :: liopt, liwmin, lopt, lwmin + integer(${ik}$) :: liopt, liwmin, lopt, lwmin ! Intrinsic Functions intrinsic :: real,max ! Executable Statements ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) upper = stdlib_lsame( uplo, 'U' ) - lquery = ( lwork==-1 .or. liwork==-1 ) - info = 0 - if( n<=1 ) then - liwmin = 1 - lwmin = 1 + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) + info = 0_${ik}$ + if( n<=1_${ik}$ ) then + liwmin = 1_${ik}$ + lwmin = 1_${ik}$ else if( wantz ) then - liwmin = 3 + 5*n - lwmin = 1 + 6*n + 2*n**2 + liwmin = 3_${ik}$ + 5_${ik}$*n + lwmin = 1_${ik}$ + 6_${ik}$*n + 2_${ik}$*n**2_${ik}$ else - liwmin = 1 - lwmin = 2*n + 1 + liwmin = 1_${ik}$ + lwmin = 2_${ik}$*n + 1_${ik}$ end if lopt = lwmin liopt = liwmin - if( itype<1 .or. itype>3 ) then - info = -1 + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( ldazero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then - call stdlib_dlascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_dlascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) else - call stdlib_dlascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_dlascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) end if end if - ! call stdlib_dsbtrd to reduce symmetric band matrix to tridiagonal form. - inde = 1 + ! call stdlib${ii}$_dsbtrd to reduce symmetric band matrix to tridiagonal form. + inde = 1_${ik}$ indwrk = inde + n indwk2 = indwrk + n*n - llwrk2 = lwork - indwk2 + 1 - call stdlib_dsbtrd( jobz, uplo, n, kd, ab, ldab, w, work( inde ), z, ldz,work( indwrk )& + llwrk2 = lwork - indwk2 + 1_${ik}$ + call stdlib${ii}$_dsbtrd( jobz, uplo, n, kd, ab, ldab, w, work( inde ), z, ldz,work( indwrk )& , iinfo ) - ! for eigenvalues only, call stdlib_dsterf. for eigenvectors, call stdlib_sstedc. + ! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvectors, call stdlib${ii}$_sstedc. if( .not.wantz ) then - call stdlib_dsterf( n, w, work( inde ), info ) + call stdlib${ii}$_dsterf( n, w, work( inde ), info ) else - call stdlib_dstedc( 'I', n, w, work( inde ), work( indwrk ), n,work( indwk2 ), & + call stdlib${ii}$_dstedc( 'I', n, w, work( inde ), work( indwrk ), n,work( indwk2 ), & llwrk2, iwork, liwork, info ) - call stdlib_dgemm( 'N', 'N', n, n, n, one, z, ldz, work( indwrk ), n,zero, work( & + call stdlib${ii}$_dgemm( 'N', 'N', n, n, n, one, z, ldz, work( indwrk ), n,zero, work( & indwk2 ), n ) - call stdlib_dlacpy( 'A', n, n, work( indwk2 ), n, z, ldz ) + call stdlib${ii}$_dlacpy( 'A', n, n, work( indwk2 ), n, z, ldz ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 )call stdlib_dscal( n, one / sigma, w, 1 ) - work( 1 ) = lwmin - iwork( 1 ) = liwmin + if( iscale==1_${ik}$ )call stdlib${ii}$_dscal( n, one / sigma, w, 1_${ik}$ ) + work( 1_${ik}$ ) = lwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_dsbevd + end subroutine stdlib${ii}$_dsbevd - pure subroutine stdlib_dsbgvd( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w,z, ldz, work, & + pure subroutine stdlib${ii}$_dsbgvd( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w,z, ldz, work, & !! DSBGVD computes all the eigenvalues, and optionally, the eigenvectors !! of a real generalized symmetric-definite banded eigenproblem, of the !! form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and @@ -72087,10 +72081,10 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ka, kb, ldab, ldbb, ldz, liwork, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ka, kb, ldab, ldbb, ldz, liwork, lwork, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(inout) :: ab(ldab,*), bb(ldbb,*) real(dp), intent(out) :: w(*), work(*), z(ldz,*) ! ===================================================================== @@ -72098,51 +72092,51 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: lquery, upper, wantz character :: vect - integer(ilp) :: iinfo, inde, indwk2, indwrk, liwmin, llwrk2, lwmin + integer(${ik}$) :: iinfo, inde, indwk2, indwrk, liwmin, llwrk2, lwmin ! Executable Statements ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) upper = stdlib_lsame( uplo, 'U' ) - lquery = ( lwork==-1 .or. liwork==-1 ) - info = 0 - if( n<=1 ) then - liwmin = 1 - lwmin = 1 + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) + info = 0_${ik}$ + if( n<=1_${ik}$ ) then + liwmin = 1_${ik}$ + lwmin = 1_${ik}$ else if( wantz ) then - liwmin = 3 + 5*n - lwmin = 1 + 5*n + 2*n**2 + liwmin = 3_${ik}$ + 5_${ik}$*n + lwmin = 1_${ik}$ + 5_${ik}$*n + 2_${ik}$*n**2_${ik}$ else - liwmin = 1 - lwmin = 2*n + liwmin = 1_${ik}$ + lwmin = 2_${ik}$*n end if if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ka<0 ) then - info = -4 - else if( kb<0 .or. kb>ka ) 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( ldabzero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then - call stdlib_dscal( ( n*( n+1 ) ) / 2, sigma, ap, 1 ) + if( iscale==1_${ik}$ ) then + call stdlib${ii}$_dscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ ) end if - ! call stdlib_dsptrd to reduce symmetric packed matrix to tridiagonal form. - inde = 1 + ! call stdlib${ii}$_dsptrd to reduce symmetric packed matrix to tridiagonal form. + inde = 1_${ik}$ indtau = inde + n - call stdlib_dsptrd( uplo, n, ap, w, work( inde ), work( indtau ), iinfo ) - ! for eigenvalues only, call stdlib_dsterf. for eigenvectors, first call - ! stdlib_dstedc to generate the eigenvector matrix, work(indwrk), of the - ! tridiagonal matrix, then call stdlib_dopmtr to multiply it by the + call stdlib${ii}$_dsptrd( uplo, n, ap, w, work( inde ), work( indtau ), iinfo ) + ! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvectors, first call + ! stdlib${ii}$_dstedc to generate the eigenvector matrix, work(indwrk), of the + ! tridiagonal matrix, then call stdlib${ii}$_dopmtr to multiply it by the ! householder transformations represented in ap. if( .not.wantz ) then - call stdlib_dsterf( n, w, work( inde ), info ) + call stdlib${ii}$_dsterf( n, w, work( inde ), info ) else indwrk = indtau + n - llwork = lwork - indwrk + 1 - call stdlib_dstedc( 'I', n, w, work( inde ), z, ldz, work( indwrk ),llwork, iwork, & + llwork = lwork - indwrk + 1_${ik}$ + call stdlib${ii}$_dstedc( 'I', n, w, work( inde ), z, ldz, work( indwrk ),llwork, iwork, & liwork, info ) - call stdlib_dopmtr( 'L', uplo, 'N', n, n, ap, work( indtau ), z, ldz,work( indwrk ),& + call stdlib${ii}$_dopmtr( 'L', uplo, 'N', n, n, ap, work( indtau ), z, ldz,work( indwrk ),& iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 )call stdlib_dscal( n, one / sigma, w, 1 ) - work( 1 ) = lwmin - iwork( 1 ) = liwmin + if( iscale==1_${ik}$ )call stdlib${ii}$_dscal( n, one / sigma, w, 1_${ik}$ ) + work( 1_${ik}$ ) = lwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_dspevd + end subroutine stdlib${ii}$_dspevd - subroutine stdlib_dspgvd( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,lwork, iwork, liwork,& + subroutine stdlib${ii}$_dspgvd( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,lwork, iwork, liwork,& !! DSPGVD computes all the eigenvalues, and optionally, the eigenvectors !! of a real generalized symmetric-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and @@ -72330,59 +72324,59 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: itype, ldz, liwork, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: itype, ldz, liwork, lwork, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(inout) :: ap(*), bp(*) real(dp), intent(out) :: w(*), work(*), z(ldz,*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, upper, wantz character :: trans - integer(ilp) :: j, liwmin, lwmin, neig + integer(${ik}$) :: j, liwmin, lwmin, neig ! Intrinsic Functions intrinsic :: real,max ! Executable Statements ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) upper = stdlib_lsame( uplo, 'U' ) - lquery = ( lwork==-1 .or. liwork==-1 ) - info = 0 - if( itype<1 .or. itype>3 ) then - info = -1 + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( ldz<1 .or. ( wantz .and. ldz0 )neig = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )neig = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**t *y or inv(u)*y if( upper ) then @@ -72414,9 +72408,9 @@ module stdlib_linalg_lapack_d trans = 'T' end if do j = 1, neig - call stdlib_dtpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_dtpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**t *y if( upper ) then @@ -72425,17 +72419,17 @@ module stdlib_linalg_lapack_d trans = 'N' end if do j = 1, neig - call stdlib_dtpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_dtpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do end if end if - work( 1 ) = lwmin - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = lwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_dspgvd + end subroutine stdlib${ii}$_dspgvd - pure subroutine stdlib_dbdsdc( uplo, compq, n, d, e, u, ldu, vt, ldvt, q, iq,work, iwork, & + pure subroutine stdlib${ii}$_dbdsdc( uplo, compq, n, d, e, u, ldu, vt, ldvt, q, iq,work, iwork, & !! DBDSDC computes the singular value decomposition (SVD) of a real !! N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT, !! using a divide and conquer method, where S is a diagonal matrix @@ -72458,10 +72452,10 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: compq, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldu, ldvt, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldu, ldvt, n ! Array Arguments - integer(ilp), intent(out) :: iq(*), iwork(*) + integer(${ik}$), intent(out) :: iq(*), iwork(*) real(dp), intent(inout) :: d(*), e(*) real(dp), intent(out) :: q(*), u(ldu,*), vt(ldvt,*), work(*) ! ===================================================================== @@ -72470,7 +72464,7 @@ module stdlib_linalg_lapack_d ! ===================================================================== ! Local Scalars - integer(ilp) :: difl, difr, givcol, givnum, givptr, i, ic, icompq, ierr, ii, is, iu, & + integer(${ik}$) :: difl, difr, givcol, givnum, givptr, i, ic, icompq, ierr, ii, is, iu, & iuplo, ivt, j, k, kk, mlvl, nm1, nsize, perm, poles, qstart, smlsiz, smlszp, sqre, & start, wstart, z real(dp) :: cs, eps, orgnrm, p, r, sn @@ -72478,127 +72472,127 @@ module stdlib_linalg_lapack_d intrinsic :: abs,real,int,log,sign ! Executable Statements ! test the input parameters. - info = 0 - iuplo = 0 - if( stdlib_lsame( uplo, 'U' ) )iuplo = 1 - if( stdlib_lsame( uplo, 'L' ) )iuplo = 2 + info = 0_${ik}$ + iuplo = 0_${ik}$ + if( stdlib_lsame( uplo, 'U' ) )iuplo = 1_${ik}$ + if( stdlib_lsame( uplo, 'L' ) )iuplo = 2_${ik}$ if( stdlib_lsame( compq, 'N' ) ) then - icompq = 0 + icompq = 0_${ik}$ else if( stdlib_lsame( compq, 'P' ) ) then - icompq = 1 + icompq = 1_${ik}$ else if( stdlib_lsame( compq, 'I' ) ) then - icompq = 2 + icompq = 2_${ik}$ else - icompq = -1 + icompq = -1_${ik}$ end if - if( iuplo==0 ) then - info = -1 - else if( icompq<0 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ( ldu<1 ) .or. ( ( icompq==2 ) .and. ( ldu=eps ) then ! a subproblem with e(nm1) not too small but i = nm1. - nsize = n - start + 1 + nsize = n - start + 1_${ik}$ else ! a subproblem with e(nm1) small. this implies an ! 1-by-1 subproblem at d(n). solve this 1-by-1 problem ! first. - nsize = i - start + 1 - if( icompq==2 ) then + nsize = i - start + 1_${ik}$ + if( icompq==2_${ik}$ ) then u( n, n ) = sign( one, d( n ) ) vt( n, n ) = one - else if( icompq==1 ) then + else if( icompq==1_${ik}$ ) then q( n+( qstart-1 )*n ) = sign( one, d( n ) ) q( n+( smlsiz+qstart-1 )*n ) = one end if d( n ) = abs( d( n ) ) end if - if( icompq==2 ) then - call stdlib_dlasd0( nsize, sqre, d( start ), e( start ),u( start, start ), & + if( icompq==2_${ik}$ ) then + call stdlib${ii}$_dlasd0( nsize, sqre, d( start ), e( start ),u( start, start ), & ldu, vt( start, start ),ldvt, smlsiz, iwork, work( wstart ), info ) else - call stdlib_dlasda( icompq, smlsiz, nsize, sqre, d( start ),e( start ), q( & + call stdlib${ii}$_dlasda( icompq, smlsiz, nsize, sqre, d( start ),e( start ), q( & start+( iu+qstart-2 )*n ), n,q( start+( ivt+qstart-2 )*n ),iq( start+k*n ), q(& start+( difl+qstart-2 )*n ), q( start+( difr+qstart-2 )*n ),q( start+( z+& qstart-2 )*n ),q( start+( poles+qstart-2 )*n ),iq( start+givptr*n ), iq( & @@ -72644,18 +72638,18 @@ module stdlib_linalg_lapack_d start+( ic+qstart-2 )*n ),q( start+( is+qstart-2 )*n ),work( wstart ), iwork,& info ) end if - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if - start = i + 1 + start = i + 1_${ik}$ end if end do loop_30 ! unscale - call stdlib_dlascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, n, 1_${ik}$, d, n, ierr ) 40 continue ! use selection sort to minimize swaps of singular vectors do ii = 2, n - i = ii - 1 + i = ii - 1_${ik}$ kk = i p = d( i ) do j = ii, n @@ -72667,33 +72661,33 @@ module stdlib_linalg_lapack_d if( kk/=i ) then d( kk ) = d( i ) d( i ) = p - if( icompq==1 ) then + if( icompq==1_${ik}$ ) then iq( i ) = kk - else if( icompq==2 ) then - call stdlib_dswap( n, u( 1, i ), 1, u( 1, kk ), 1 ) - call stdlib_dswap( n, vt( i, 1 ), ldvt, vt( kk, 1 ), ldvt ) + else if( icompq==2_${ik}$ ) then + call stdlib${ii}$_dswap( n, u( 1_${ik}$, i ), 1_${ik}$, u( 1_${ik}$, kk ), 1_${ik}$ ) + call stdlib${ii}$_dswap( n, vt( i, 1_${ik}$ ), ldvt, vt( kk, 1_${ik}$ ), ldvt ) end if - else if( icompq==1 ) then + else if( icompq==1_${ik}$ ) then iq( i ) = i end if end do ! if icompq = 1, use iq(n,1) as the indicator for uplo - if( icompq==1 ) then - if( iuplo==1 ) then - iq( n ) = 1 + if( icompq==1_${ik}$ ) then + if( iuplo==1_${ik}$ ) then + iq( n ) = 1_${ik}$ else - iq( n ) = 0 + iq( n ) = 0_${ik}$ end if end if ! if b is lower bidiagonal, update u by those givens rotations ! which rotated b to be upper bidiagonal - if( ( iuplo==2 ) .and. ( icompq==2 ) )call stdlib_dlasr( 'L', 'V', 'B', n, n, work( 1 )& + if( ( iuplo==2_${ik}$ ) .and. ( icompq==2_${ik}$ ) )call stdlib${ii}$_dlasr( 'L', 'V', 'B', n, n, work( 1_${ik}$ )& , work( n ), u, ldu ) return - end subroutine stdlib_dbdsdc + end subroutine stdlib${ii}$_dbdsdc - pure subroutine stdlib_dbdsqr( uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u,ldu, c, ldc, work, & + pure subroutine stdlib${ii}$_dbdsqr( uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u,ldu, c, ldc, work, & !! DBDSQR computes the singular values and, optionally, the right and/or !! left singular vectors from the singular value decomposition (SVD) of !! a real N-by-N (upper or lower) bidiagonal matrix B using the implicit @@ -72724,8 +72718,8 @@ module stdlib_linalg_lapack_d ! -- 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) :: ldc, ldu, ldvt, n, ncc, ncvt, nru + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldc, ldu, ldvt, n, ncc, ncvt, nru ! Array Arguments real(dp), intent(inout) :: c(ldc,*), d(*), e(*), u(ldu,*), vt(ldvt,*) real(dp), intent(out) :: work(*) @@ -72734,7 +72728,7 @@ module stdlib_linalg_lapack_d real(dp), parameter :: hndrth = 0.01_dp real(dp), parameter :: hndrd = 100.0_dp real(dp), parameter :: meigth = -0.125_dp - integer(ilp), parameter :: maxitr = 6 + integer(${ik}$), parameter :: maxitr = 6_${ik}$ @@ -72745,7 +72739,7 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: lower, rotate - integer(ilp) :: i, idir, isub, iter, iterdivn, j, ll, lll, m, maxitdivn, nm1, nm12, & + integer(${ik}$) :: i, idir, isub, iter, iterdivn, j, ll, lll, m, maxitdivn, nm1, nm12, & nm13, oldll, oldm real(dp) :: abse, abss, cosl, cosr, cs, eps, f, g, h, mu, oldcs, oldsn, r, shift, & sigmn, sigmx, sinl, sinr, sll, smax, smin, sminl, sminoa, sn, thresh, tol, tolmul, & @@ -72754,52 +72748,52 @@ module stdlib_linalg_lapack_d intrinsic :: abs,real,max,min,sign,sqrt ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ lower = stdlib_lsame( uplo, 'L' ) if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.lower ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( ncvt<0 ) then - info = -3 - else if( nru<0 ) then - info = -4 - else if( ncc<0 ) then - info = -5 - else if( ( ncvt==0 .and. ldvt<1 ) .or.( ncvt>0 .and. ldvt0 .and. ldc0_${ik}$ .and. ldvt0_${ik}$ .and. ldc0 ) .or. ( nru>0 ) .or. ( ncc>0 ) + rotate = ( ncvt>0_${ik}$ ) .or. ( nru>0_${ik}$ ) .or. ( ncc>0_${ik}$ ) ! if no singular vectors desired, use qd algorithm if( .not.rotate ) then - call stdlib_dlasq1( n, d, e, work, info ) + call stdlib${ii}$_dlasq1( n, d, e, work, info ) ! if info equals 2, dqds didn't finish, try to finish if( info /= 2 ) return - info = 0 + info = 0_${ik}$ end if - nm1 = n - 1 + nm1 = n - 1_${ik}$ nm12 = nm1 + nm1 nm13 = nm12 + nm1 - idir = 0 + idir = 0_${ik}$ ! get machine constants - eps = stdlib_dlamch( 'EPSILON' ) - unfl = stdlib_dlamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_dlamch( 'EPSILON' ) + unfl = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) ! if matrix lower bidiagonal, rotate to be upper bidiagonal ! by applying givens rotations on the left if( lower ) then do i = 1, n - 1 - call stdlib_dlartg( d( i ), e( i ), cs, sn, r ) + call stdlib${ii}$_dlartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) @@ -72807,9 +72801,9 @@ module stdlib_linalg_lapack_d work( nm1+i ) = sn end do ! update singular vectors if desired - if( nru>0 )call stdlib_dlasr( 'R', 'V', 'F', nru, n, work( 1 ), work( n ), u,ldu ) + if( nru>0_${ik}$ )call stdlib${ii}$_dlasr( 'R', 'V', 'F', nru, n, work( 1_${ik}$ ), work( n ), u,ldu ) - if( ncc>0 )call stdlib_dlasr( 'L', 'V', 'F', n, ncc, work( 1 ), work( n ), c,ldc ) + if( ncc>0_${ik}$ )call stdlib${ii}$_dlasr( 'L', 'V', 'F', n, ncc, work( 1_${ik}$ ), work( n ), c,ldc ) end if ! compute singular values to relative accuracy tol @@ -72828,7 +72822,7 @@ module stdlib_linalg_lapack_d sminl = zero if( tol>=zero ) then ! relative accuracy desired - sminoa = abs( d( 1 ) ) + sminoa = abs( d( 1_${ik}$ ) ) if( sminoa==zero )go to 50 mu = sminoa do i = 2, n @@ -72847,10 +72841,10 @@ module stdlib_linalg_lapack_d ! (maxit is the maximum number of passes through the inner ! loop permitted before nonconvergence signalled.) maxitdivn = maxitr*n - iterdivn = 0 - iter = -1 - oldll = -1 - oldm = -1 + iterdivn = 0_${ik}$ + iter = -1_${ik}$ + oldll = -1_${ik}$ + oldm = -1_${ik}$ ! m points to last element of unconverged part of matrix m = n ! begin main iteration loop @@ -72859,7 +72853,7 @@ module stdlib_linalg_lapack_d if( m<=1 )go to 160 if( iter>=n ) then iter = iter - n - iterdivn = iterdivn + 1 + iterdivn = iterdivn + 1_${ik}$ if( iterdivn>=maxitdivn )go to 200 end if ! find diagonal block of matrix to work on @@ -72875,33 +72869,33 @@ module stdlib_linalg_lapack_d smin = min( smin, abss ) smax = max( smax, abss, abse ) end do - ll = 0 + ll = 0_${ik}$ go to 90 80 continue e( ll ) = zero ! matrix splits since e(ll) = 0 if( ll==m-1 ) then ! convergence of bottom singular value, return to top of loop - m = m - 1 + m = m - 1_${ik}$ go to 60 end if 90 continue - ll = ll + 1 + ll = ll + 1_${ik}$ ! e(ll) through e(m-1) are nonzero, e(ll-1) is zero if( ll==m-1 ) then ! 2 by 2 block, handle separately - call stdlib_dlasv2( d( m-1 ), e( m-1 ), d( m ), sigmn, sigmx, sinr,cosr, sinl, cosl & + call stdlib${ii}$_dlasv2( d( m-1 ), e( m-1 ), d( m ), sigmn, sigmx, sinr,cosr, sinl, cosl & ) d( m-1 ) = sigmx e( m-1 ) = zero d( m ) = sigmn ! compute singular vectors, if desired - if( ncvt>0 )call stdlib_drot( ncvt, vt( m-1, 1 ), ldvt, vt( m, 1 ), ldvt, cosr,sinr & + if( ncvt>0_${ik}$ )call stdlib${ii}$_drot( ncvt, vt( m-1, 1_${ik}$ ), ldvt, vt( m, 1_${ik}$ ), ldvt, cosr,sinr & ) - if( nru>0 )call stdlib_drot( nru, u( 1, m-1 ), 1, u( 1, m ), 1, cosl, sinl ) - if( ncc>0 )call stdlib_drot( ncc, c( m-1, 1 ), ldc, c( m, 1 ), ldc, cosl,sinl ) + if( nru>0_${ik}$ )call stdlib${ii}$_drot( nru, u( 1_${ik}$, m-1 ), 1_${ik}$, u( 1_${ik}$, m ), 1_${ik}$, cosl, sinl ) + if( ncc>0_${ik}$ )call stdlib${ii}$_drot( ncc, c( m-1, 1_${ik}$ ), ldc, c( m, 1_${ik}$ ), ldc, cosl,sinl ) - m = m - 2 + m = m - 2_${ik}$ go to 60 end if ! if working on new submatrix, choose shift direction @@ -72909,14 +72903,14 @@ module stdlib_linalg_lapack_d if( ll>oldm .or. m=abs( d( m ) ) ) then ! chase bulge from top (big end) to bottom (small end) - idir = 1 + idir = 1_${ik}$ else ! chase bulge from bottom (big end) to top (small end) - idir = 2 + idir = 2_${ik}$ end if end if ! apply convergence tests - if( idir==1 ) then + if( idir==1_${ik}$ ) then ! run convergence test in forward direction ! first apply standard test to bottom of matrix if( abs( e( m-1 ) )<=abs( tol )*abs( d( m ) ) .or.( tolzero ) then - if( ( shift / sll )**2ll )e( i-1 ) = oldsn*r - call stdlib_dlartg( oldcs*r, d( i+1 )*sn, oldcs, oldsn, d( i ) ) + call stdlib${ii}$_dlartg( oldcs*r, d( i+1 )*sn, oldcs, oldsn, d( i ) ) work( i-ll+1 ) = cs work( i-ll+1+nm1 ) = sn work( i-ll+1+nm12 ) = oldcs @@ -73004,12 +72998,12 @@ module stdlib_linalg_lapack_d d( m ) = h*oldcs e( m-1 ) = h*oldsn ! update singular vectors - if( ncvt>0 )call stdlib_dlasr( 'L', 'V', 'F', m-ll+1, ncvt, work( 1 ),work( n ), & - vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_dlasr( 'R', 'V', 'F', nru, m-ll+1, work( nm12+1 ),work( & - nm13+1 ), u( 1, ll ), ldu ) - if( ncc>0 )call stdlib_dlasr( 'L', 'V', 'F', m-ll+1, ncc, work( nm12+1 ),work( & - nm13+1 ), c( ll, 1 ), ldc ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_dlasr( 'L', 'V', 'F', m-ll+1, ncvt, work( 1_${ik}$ ),work( n ), & + vt( ll, 1_${ik}$ ), ldvt ) + if( nru>0_${ik}$ )call stdlib${ii}$_dlasr( 'R', 'V', 'F', nru, m-ll+1, work( nm12+1 ),work( & + nm13+1 ), u( 1_${ik}$, ll ), ldu ) + if( ncc>0_${ik}$ )call stdlib${ii}$_dlasr( 'L', 'V', 'F', m-ll+1, ncc, work( nm12+1 ),work( & + nm13+1 ), c( ll, 1_${ik}$ ), ldc ) ! test convergence if( abs( e( m-1 ) )<=thresh )e( m-1 ) = zero else @@ -73018,9 +73012,9 @@ module stdlib_linalg_lapack_d cs = one oldcs = one do i = m, ll + 1, -1 - call stdlib_dlartg( d( i )*cs, e( i-1 ), cs, sn, r ) + call stdlib${ii}$_dlartg( d( i )*cs, e( i-1 ), cs, sn, r ) if( i0 )call stdlib_dlasr( 'L', 'V', 'B', m-ll+1, ncvt, work( nm12+1 ),work( & - nm13+1 ), vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_dlasr( 'R', 'V', 'B', nru, m-ll+1, work( 1 ),work( n ), u(& - 1, ll ), ldu ) - if( ncc>0 )call stdlib_dlasr( 'L', 'V', 'B', m-ll+1, ncc, work( 1 ),work( n ), c(& - ll, 1 ), ldc ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_dlasr( 'L', 'V', 'B', m-ll+1, ncvt, work( nm12+1 ),work( & + nm13+1 ), vt( ll, 1_${ik}$ ), ldvt ) + if( nru>0_${ik}$ )call stdlib${ii}$_dlasr( 'R', 'V', 'B', nru, m-ll+1, work( 1_${ik}$ ),work( n ), u(& + 1_${ik}$, ll ), ldu ) + if( ncc>0_${ik}$ )call stdlib${ii}$_dlasr( 'L', 'V', 'B', m-ll+1, ncc, work( 1_${ik}$ ),work( n ), c(& + ll, 1_${ik}$ ), ldc ) ! test convergence if( abs( e( ll ) )<=thresh )e( ll ) = zero end if else ! use nonzero shift - if( idir==1 ) then + if( idir==1_${ik}$ ) then ! chase bulge from top to bottom ! save cosines and sines for later singular vector updates f = ( abs( d( ll ) )-shift )*( sign( one, d( ll ) )+shift / d( ll ) ) g = e( ll ) do i = ll, m - 1 - call stdlib_dlartg( f, g, cosr, sinr, r ) + call stdlib${ii}$_dlartg( f, g, cosr, sinr, r ) if( i>ll )e( i-1 ) = r f = cosr*d( i ) + sinr*e( i ) e( i ) = cosr*e( i ) - sinr*d( i ) g = sinr*d( i+1 ) d( i+1 ) = cosr*d( i+1 ) - call stdlib_dlartg( f, g, cosl, sinl, r ) + call stdlib${ii}$_dlartg( f, g, cosl, sinl, r ) d( i ) = r f = cosl*e( i ) + sinl*d( i+1 ) d( i+1 ) = cosl*d( i+1 ) - sinl*e( i ) @@ -73068,12 +73062,12 @@ module stdlib_linalg_lapack_d end do e( m-1 ) = f ! update singular vectors - if( ncvt>0 )call stdlib_dlasr( 'L', 'V', 'F', m-ll+1, ncvt, work( 1 ),work( n ), & - vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_dlasr( 'R', 'V', 'F', nru, m-ll+1, work( nm12+1 ),work( & - nm13+1 ), u( 1, ll ), ldu ) - if( ncc>0 )call stdlib_dlasr( 'L', 'V', 'F', m-ll+1, ncc, work( nm12+1 ),work( & - nm13+1 ), c( ll, 1 ), ldc ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_dlasr( 'L', 'V', 'F', m-ll+1, ncvt, work( 1_${ik}$ ),work( n ), & + vt( ll, 1_${ik}$ ), ldvt ) + if( nru>0_${ik}$ )call stdlib${ii}$_dlasr( 'R', 'V', 'F', nru, m-ll+1, work( nm12+1 ),work( & + nm13+1 ), u( 1_${ik}$, ll ), ldu ) + if( ncc>0_${ik}$ )call stdlib${ii}$_dlasr( 'L', 'V', 'F', m-ll+1, ncc, work( nm12+1 ),work( & + nm13+1 ), c( ll, 1_${ik}$ ), ldc ) ! test convergence if( abs( e( m-1 ) )<=thresh )e( m-1 ) = zero else @@ -73082,13 +73076,13 @@ module stdlib_linalg_lapack_d f = ( abs( d( m ) )-shift )*( sign( one, d( m ) )+shift /d( m ) ) g = e( m-1 ) do i = m, ll + 1, -1 - call stdlib_dlartg( f, g, cosr, sinr, r ) + call stdlib${ii}$_dlartg( f, g, cosr, sinr, r ) if( i0 )call stdlib_dlasr( 'L', 'V', 'B', m-ll+1, ncvt, work( nm12+1 ),work( & - nm13+1 ), vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_dlasr( 'R', 'V', 'B', nru, m-ll+1, work( 1 ),work( n ), u(& - 1, ll ), ldu ) - if( ncc>0 )call stdlib_dlasr( 'L', 'V', 'B', m-ll+1, ncc, work( 1 ),work( n ), c(& - ll, 1 ), ldc ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_dlasr( 'L', 'V', 'B', m-ll+1, ncvt, work( nm12+1 ),work( & + nm13+1 ), vt( ll, 1_${ik}$ ), ldvt ) + if( nru>0_${ik}$ )call stdlib${ii}$_dlasr( 'R', 'V', 'B', nru, m-ll+1, work( 1_${ik}$ ),work( n ), u(& + 1_${ik}$, ll ), ldu ) + if( ncc>0_${ik}$ )call stdlib${ii}$_dlasr( 'L', 'V', 'B', m-ll+1, ncc, work( 1_${ik}$ ),work( n ), c(& + ll, 1_${ik}$ ), ldc ) end if end if ! qr iteration finished, go back and check convergence @@ -73121,15 +73115,15 @@ module stdlib_linalg_lapack_d if( d( i )0 )call stdlib_dscal( ncvt, negone, vt( i, 1 ), ldvt ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_dscal( ncvt, negone, vt( i, 1_${ik}$ ), ldvt ) end if end do ! sort the singular values into decreasing order (insertion sort on ! singular values, but only one transposition per singular vector) do i = 1, n - 1 ! scan for smallest d(i) - isub = 1 - smin = d( 1 ) + isub = 1_${ik}$ + smin = d( 1_${ik}$ ) do j = 2, n + 1 - i if( d( j )<=smin ) then isub = j @@ -73140,26 +73134,26 @@ module stdlib_linalg_lapack_d ! swap singular values and vectors d( isub ) = d( n+1-i ) d( n+1-i ) = smin - if( ncvt>0 )call stdlib_dswap( ncvt, vt( isub, 1 ), ldvt, vt( n+1-i, 1 ),ldvt ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_dswap( ncvt, vt( isub, 1_${ik}$ ), ldvt, vt( n+1-i, 1_${ik}$ ),ldvt ) - if( nru>0 )call stdlib_dswap( nru, u( 1, isub ), 1, u( 1, n+1-i ), 1 ) - if( ncc>0 )call stdlib_dswap( ncc, c( isub, 1 ), ldc, c( n+1-i, 1 ), ldc ) + if( nru>0_${ik}$ )call stdlib${ii}$_dswap( nru, u( 1_${ik}$, isub ), 1_${ik}$, u( 1_${ik}$, n+1-i ), 1_${ik}$ ) + if( ncc>0_${ik}$ )call stdlib${ii}$_dswap( ncc, c( isub, 1_${ik}$ ), ldc, c( n+1-i, 1_${ik}$ ), ldc ) end if end do go to 220 ! maximum number of iterations exceeded, failure to converge 200 continue - info = 0 + info = 0_${ik}$ do i = 1, n - 1 - if( e( i )/=zero )info = info + 1 + if( e( i )/=zero )info = info + 1_${ik}$ end do 220 continue return - end subroutine stdlib_dbdsqr + end subroutine stdlib${ii}$_dbdsqr - subroutine stdlib_dgees( jobvs, sort, select, n, a, lda, sdim, wr, wi,vs, ldvs, work, lwork, & + subroutine stdlib${ii}$_dgees( jobvs, sort, select, n, a, lda, sdim, wr, wi,vs, ldvs, work, lwork, & !! DGEES computes for an N-by-N real nonsymmetric matrix A, the !! eigenvalues, the real Schur form T, and, optionally, the matrix of !! Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). @@ -73179,8 +73173,8 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvs, sort - integer(ilp), intent(out) :: info, sdim - integer(ilp), intent(in) :: lda, ldvs, lwork, n + integer(${ik}$), intent(out) :: info, sdim + integer(${ik}$), intent(in) :: lda, ldvs, lwork, n ! Array Arguments logical(lk), intent(out) :: bwork(*) real(dp), intent(inout) :: a(lda,*) @@ -73191,83 +73185,83 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: cursl, lastsl, lquery, lst2sl, scalea, wantst, wantvs - integer(ilp) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, & + integer(${ik}$) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, & iwrk, maxwrk, minwrk real(dp) :: anrm, bignum, cscale, eps, s, sep, smlnum ! Local Arrays - integer(ilp) :: idum(1) - real(dp) :: dum(1) + integer(${ik}$) :: idum(1_${ik}$) + real(dp) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) wantvs = stdlib_lsame( jobvs, 'V' ) wantst = stdlib_lsame( sort, 'S' ) if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then - info = -2 - else if( n<0 ) then - info = -4 - else if( ldazero .and. anrm0 )info = ieval + if( ieval>0_${ik}$ )info = ieval ! sort eigenvalues if desired - if( wantst .and. info==0 ) then + if( wantst .and. info==0_${ik}$ ) then if( scalea ) then - call stdlib_dlascl( 'G', 0, 0, cscale, anrm, n, 1, wr, n, ierr ) - call stdlib_dlascl( 'G', 0, 0, cscale, anrm, n, 1, wi, n, ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wr, n, ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wi, n, ierr ) end if do i = 1, n bwork( i ) = select( wr( i ), wi( i ) ) end do ! reorder eigenvalues and transform schur vectors ! (workspace: none needed) - call stdlib_dtrsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, s, sep, & - work( iwrk ), lwork-iwrk+1, idum, 1,icond ) - if( icond>0 )info = n + icond + call stdlib${ii}$_dtrsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, s, sep, & + work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$,icond ) + if( icond>0_${ik}$ )info = n + icond end if if( wantvs ) then ! undo balancing ! (workspace: need n) - call stdlib_dgebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr ) + call stdlib${ii}$_dgebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr ) end if if( scalea ) then ! undo scaling for the schur form of a - call stdlib_dlascl( 'H', 0, 0, cscale, anrm, n, n, a, lda, ierr ) - call stdlib_dcopy( n, a, lda+1, wr, 1 ) + call stdlib${ii}$_dlascl( 'H', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_dcopy( n, a, lda+1, wr, 1_${ik}$ ) if( cscale==smlnum ) then ! if scaling back towards underflow, adjust wi if an ! offdiagonal element of a 2-by-2 block in the schur form ! underflows. - if( ieval>0 ) then - i1 = ieval + 1 - i2 = ihi - 1 - call stdlib_dlascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wi,max( ilo-1, 1 ), & + if( ieval>0_${ik}$ ) then + i1 = ieval + 1_${ik}$ + i2 = ihi - 1_${ik}$ + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi,max( ilo-1, 1_${ik}$ ), & ierr ) else if( wantst ) then - i1 = 1 - i2 = n - 1 + i1 = 1_${ik}$ + i2 = n - 1_${ik}$ else i1 = ilo - i2 = ihi - 1 + i2 = ihi - 1_${ik}$ end if - inxt = i1 - 1 + inxt = i1 - 1_${ik}$ loop_20: do i = i1, i2 if( i1 )call stdlib_dswap( i-1, a( 1, i ), 1, a( 1, i+1 ), 1 ) - if( n>i+1 )call stdlib_dswap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), & + if( i>1_${ik}$ )call stdlib${ii}$_dswap( i-1, a( 1_${ik}$, i ), 1_${ik}$, a( 1_${ik}$, i+1 ), 1_${ik}$ ) + if( n>i+1 )call stdlib${ii}$_dswap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), & lda ) if( wantvs ) then - call stdlib_dswap( n, vs( 1, i ), 1, vs( 1, i+1 ), 1 ) + call stdlib${ii}$_dswap( n, vs( 1_${ik}$, i ), 1_${ik}$, vs( 1_${ik}$, i+1 ), 1_${ik}$ ) end if a( i, i+1 ) = a( i+1, i ) a( i+1, i ) = zero end if - inxt = i + 2 + inxt = i + 2_${ik}$ end if end do loop_20 end if ! undo scaling for the imaginary part of the eigenvalues - call stdlib_dlascl( 'G', 0, 0, cscale, anrm, n-ieval, 1,wi( ieval+1 ), max( n-ieval,& - 1 ), ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-ieval, 1_${ik}$,wi( ieval+1 ), max( n-ieval,& + 1_${ik}$ ), ierr ) end if - if( wantst .and. info==0 ) then + if( wantst .and. info==0_${ik}$ ) then ! check if reordering successful lastsl = .true. lst2sl = .true. - sdim = 0 - ip = 0 + sdim = 0_${ik}$ + ip = 0_${ik}$ do i = 1, n cursl = select( wr( i ), wi( i ) ) if( wi( i )==zero ) then - if( cursl )sdim = sdim + 1 - ip = 0 - if( cursl .and. .not.lastsl )info = n + 2 + if( cursl )sdim = sdim + 1_${ik}$ + ip = 0_${ik}$ + if( cursl .and. .not.lastsl )info = n + 2_${ik}$ else - if( ip==1 ) then + if( ip==1_${ik}$ ) then ! last eigenvalue of conjugate pair cursl = cursl .or. lastsl lastsl = cursl - if( cursl )sdim = sdim + 2 - ip = -1 - if( cursl .and. .not.lst2sl )info = n + 2 + if( cursl )sdim = sdim + 2_${ik}$ + ip = -1_${ik}$ + if( cursl .and. .not.lst2sl )info = n + 2_${ik}$ else ! first eigenvalue of conjugate pair - ip = 1 + ip = 1_${ik}$ end if end if lst2sl = lastsl lastsl = cursl end do end if - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_dgees + end subroutine stdlib${ii}$_dgees - subroutine stdlib_dgeesx( jobvs, sort, select, sense, n, a, lda, sdim,wr, wi, vs, ldvs, & + subroutine stdlib${ii}$_dgeesx( jobvs, sort, select, sense, n, a, lda, sdim,wr, wi, vs, ldvs, & !! DGEESX computes for an N-by-N real nonsymmetric matrix A, the !! eigenvalues, the real Schur form T, and, optionally, the matrix of !! Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). @@ -73431,12 +73425,12 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvs, sense, sort - integer(ilp), intent(out) :: info, sdim - integer(ilp), intent(in) :: lda, ldvs, liwork, lwork, n + integer(${ik}$), intent(out) :: info, sdim + integer(${ik}$), intent(in) :: lda, ldvs, liwork, lwork, n real(dp), intent(out) :: rconde, rcondv ! Array Arguments logical(lk), intent(out) :: bwork(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: vs(ldvs,*), wi(*), work(*), wr(*) ! Function Arguments @@ -73446,36 +73440,36 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: cursl, lastsl, lquery, lst2sl, scalea, wantsb, wantse, wantsn, wantst, & wantsv, wantvs - integer(ilp) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, & + integer(${ik}$) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, & iwrk, liwrk, lwrk, maxwrk, minwrk real(dp) :: anrm, bignum, cscale, eps, smlnum ! Local Arrays - real(dp) :: dum(1) + real(dp) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ wantvs = stdlib_lsame( jobvs, 'V' ) wantst = stdlib_lsame( sort, 'S' ) wantsn = stdlib_lsame( sense, 'N' ) wantse = stdlib_lsame( sense, 'E' ) wantsv = stdlib_lsame( sense, 'V' ) wantsb = stdlib_lsame( sense, 'B' ) - lquery = ( lwork==-1 .or. liwork==-1 ) + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. & .not.wantsn ) ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( ldazero .and. anrm0 )info = ieval + if( ieval>0_${ik}$ )info = ieval ! sort eigenvalues if desired - if( wantst .and. info==0 ) then + if( wantst .and. info==0_${ik}$ ) then if( scalea ) then - call stdlib_dlascl( 'G', 0, 0, cscale, anrm, n, 1, wr, n, ierr ) - call stdlib_dlascl( 'G', 0, 0, cscale, anrm, n, 1, wi, n, ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wr, n, ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wi, n, ierr ) end if do i = 1, n bwork( i ) = select( wr( i ), wi( i ) ) @@ -73589,54 +73583,54 @@ module stdlib_linalg_lapack_d ! otherwise, need n ) ! (iworkspace: if sense is 'v' or 'b', need sdim*(n-sdim) ! otherwise, need 0 ) - call stdlib_dtrsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, rconde, & + call stdlib${ii}$_dtrsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, rconde, & rcondv, work( iwrk ), lwork-iwrk+1,iwork, liwork, icond ) if( .not.wantsn )maxwrk = max( maxwrk, n+2*sdim*( n-sdim ) ) - if( icond==-15 ) then + if( icond==-15_${ik}$ ) then ! not enough real workspace - info = -16 - else if( icond==-17 ) then + info = -16_${ik}$ + else if( icond==-17_${ik}$ ) then ! not enough integer workspace - info = -18 - else if( icond>0 ) then - ! stdlib_dtrsen failed to reorder or to restore standard schur form + info = -18_${ik}$ + else if( icond>0_${ik}$ ) then + ! stdlib${ii}$_dtrsen failed to reorder or to restore standard schur form info = icond + n end if end if if( wantvs ) then ! undo balancing ! (rworkspace: need n) - call stdlib_dgebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr ) + call stdlib${ii}$_dgebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr ) end if if( scalea ) then ! undo scaling for the schur form of a - call stdlib_dlascl( 'H', 0, 0, cscale, anrm, n, n, a, lda, ierr ) - call stdlib_dcopy( n, a, lda+1, wr, 1 ) - if( ( wantsv .or. wantsb ) .and. info==0 ) then - dum( 1 ) = rcondv - call stdlib_dlascl( 'G', 0, 0, cscale, anrm, 1, 1, dum, 1, ierr ) - rcondv = dum( 1 ) + call stdlib${ii}$_dlascl( 'H', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_dcopy( n, a, lda+1, wr, 1_${ik}$ ) + if( ( wantsv .or. wantsb ) .and. info==0_${ik}$ ) then + dum( 1_${ik}$ ) = rcondv + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr ) + rcondv = dum( 1_${ik}$ ) end if if( cscale==smlnum ) then ! if scaling back towards underflow, adjust wi if an ! offdiagonal element of a 2-by-2 block in the schur form ! underflows. - if( ieval>0 ) then - i1 = ieval + 1 - i2 = ihi - 1 - call stdlib_dlascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wi, n,ierr ) + if( ieval>0_${ik}$ ) then + i1 = ieval + 1_${ik}$ + i2 = ihi - 1_${ik}$ + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr ) else if( wantst ) then - i1 = 1 - i2 = n - 1 + i1 = 1_${ik}$ + i2 = n - 1_${ik}$ else i1 = ilo - i2 = ihi - 1 + i2 = ihi - 1_${ik}$ end if - inxt = i1 - 1 + inxt = i1 - 1_${ik}$ loop_20: do i = i1, i2 if( i1 )call stdlib_dswap( i-1, a( 1, i ), 1, a( 1, i+1 ), 1 ) - if( n>i+1 )call stdlib_dswap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), & + if( i>1_${ik}$ )call stdlib${ii}$_dswap( i-1, a( 1_${ik}$, i ), 1_${ik}$, a( 1_${ik}$, i+1 ), 1_${ik}$ ) + if( n>i+1 )call stdlib${ii}$_dswap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), & lda ) if( wantvs ) then - call stdlib_dswap( n, vs( 1, i ), 1, vs( 1, i+1 ), 1 ) + call stdlib${ii}$_dswap( n, vs( 1_${ik}$, i ), 1_${ik}$, vs( 1_${ik}$, i+1 ), 1_${ik}$ ) end if a( i, i+1 ) = a( i+1, i ) a( i+1, i ) = zero end if - inxt = i + 2 + inxt = i + 2_${ik}$ end if end do loop_20 end if - call stdlib_dlascl( 'G', 0, 0, cscale, anrm, n-ieval, 1,wi( ieval+1 ), max( n-ieval,& - 1 ), ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-ieval, 1_${ik}$,wi( ieval+1 ), max( n-ieval,& + 1_${ik}$ ), ierr ) end if - if( wantst .and. info==0 ) then + if( wantst .and. info==0_${ik}$ ) then ! check if reordering successful lastsl = .true. lst2sl = .true. - sdim = 0 - ip = 0 + sdim = 0_${ik}$ + ip = 0_${ik}$ do i = 1, n cursl = select( wr( i ), wi( i ) ) if( wi( i )==zero ) then - if( cursl )sdim = sdim + 1 - ip = 0 - if( cursl .and. .not.lastsl )info = n + 2 + if( cursl )sdim = sdim + 1_${ik}$ + ip = 0_${ik}$ + if( cursl .and. .not.lastsl )info = n + 2_${ik}$ else - if( ip==1 ) then + if( ip==1_${ik}$ ) then ! last eigenvalue of conjugate pair cursl = cursl .or. lastsl lastsl = cursl - if( cursl )sdim = sdim + 2 - ip = -1 - if( cursl .and. .not.lst2sl )info = n + 2 + if( cursl )sdim = sdim + 2_${ik}$ + ip = -1_${ik}$ + if( cursl .and. .not.lst2sl )info = n + 2_${ik}$ else ! first eigenvalue of conjugate pair - ip = 1 + ip = 1_${ik}$ end if end if lst2sl = lastsl lastsl = cursl end do end if - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk if( wantsv .or. wantsb ) then - iwork( 1 ) = max( 1, sdim*( n-sdim ) ) + iwork( 1_${ik}$ ) = max( 1_${ik}$, sdim*( n-sdim ) ) else - iwork( 1 ) = 1 + iwork( 1_${ik}$ ) = 1_${ik}$ end if return - end subroutine stdlib_dgeesx + end subroutine stdlib${ii}$_dgeesx - subroutine stdlib_dgeev( jobvl, jobvr, n, a, lda, wr, wi, vl, ldvl, vr,ldvr, work, lwork, & + subroutine stdlib${ii}$_dgeev( jobvl, jobvr, n, a, lda, wr, wi, vl, ldvl, vr,ldvr, work, lwork, & !! DGEEV computes for an N-by-N real nonsymmetric matrix A, the !! eigenvalues and, optionally, the left and/or right eigenvectors. !! The right eigenvector v(j) of A satisfies @@ -73716,8 +73710,8 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvl, jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n ! Array Arguments real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: vl(ldvl,*), vr(ldvr,*), wi(*), work(*), wr(*) @@ -73726,90 +73720,90 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: lquery, scalea, wantvl, wantvr character :: side - integer(ilp) :: hswork, i, ibal, ierr, ihi, ilo, itau, iwrk, k, lwork_trevc, maxwrk, & + integer(${ik}$) :: hswork, i, ibal, ierr, ihi, ilo, itau, iwrk, k, lwork_trevc, maxwrk, & minwrk, nout real(dp) :: anrm, bignum, cs, cscale, eps, r, scl, smlnum, sn ! Local Arrays - logical(lk) :: select(1) - real(dp) :: dum(1) + logical(lk) :: select(1_${ik}$) + real(dp) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) wantvl = stdlib_lsame( jobvl, 'V' ) wantvr = stdlib_lsame( jobvr, 'V' ) if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldazero .and. anrmzero ) then - scl = one / stdlib_dlapy2( stdlib_dnrm2( n, vl( 1, i ), 1 ),stdlib_dnrm2( n, & - vl( 1, i+1 ), 1 ) ) - call stdlib_dscal( n, scl, vl( 1, i ), 1 ) - call stdlib_dscal( n, scl, vl( 1, i+1 ), 1 ) + scl = one / stdlib${ii}$_dlapy2( stdlib${ii}$_dnrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_dnrm2( n, & + vl( 1_${ik}$, i+1 ), 1_${ik}$ ) ) + call stdlib${ii}$_dscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_dscal( n, scl, vl( 1_${ik}$, i+1 ), 1_${ik}$ ) do k = 1, n - work( iwrk+k-1 ) = vl( k, i )**2 + vl( k, i+1 )**2 + work( iwrk+k-1 ) = vl( k, i )**2_${ik}$ + vl( k, i+1 )**2_${ik}$ end do - k = stdlib_idamax( n, work( iwrk ), 1 ) - call stdlib_dlartg( vl( k, i ), vl( k, i+1 ), cs, sn, r ) - call stdlib_drot( n, vl( 1, i ), 1, vl( 1, i+1 ), 1, cs, sn ) + k = stdlib${ii}$_idamax( n, work( iwrk ), 1_${ik}$ ) + call stdlib${ii}$_dlartg( vl( k, i ), vl( k, i+1 ), cs, sn, r ) + call stdlib${ii}$_drot( n, vl( 1_${ik}$, i ), 1_${ik}$, vl( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn ) vl( k, i+1 ) = zero end if end do @@ -73920,23 +73914,23 @@ module stdlib_linalg_lapack_d if( wantvr ) then ! undo balancing of right eigenvectors ! (workspace: need n) - call stdlib_dgebak( 'B', 'R', n, ilo, ihi, work( ibal ), n, vr, ldvr,ierr ) + call stdlib${ii}$_dgebak( 'B', 'R', n, ilo, ihi, work( ibal ), n, vr, ldvr,ierr ) ! normalize right eigenvectors and make largest component real do i = 1, n if( wi( i )==zero ) then - scl = one / stdlib_dnrm2( n, vr( 1, i ), 1 ) - call stdlib_dscal( n, scl, vr( 1, i ), 1 ) + scl = one / stdlib${ii}$_dnrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_dscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ ) else if( wi( i )>zero ) then - scl = one / stdlib_dlapy2( stdlib_dnrm2( n, vr( 1, i ), 1 ),stdlib_dnrm2( n, & - vr( 1, i+1 ), 1 ) ) - call stdlib_dscal( n, scl, vr( 1, i ), 1 ) - call stdlib_dscal( n, scl, vr( 1, i+1 ), 1 ) + scl = one / stdlib${ii}$_dlapy2( stdlib${ii}$_dnrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_dnrm2( n, & + vr( 1_${ik}$, i+1 ), 1_${ik}$ ) ) + call stdlib${ii}$_dscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_dscal( n, scl, vr( 1_${ik}$, i+1 ), 1_${ik}$ ) do k = 1, n - work( iwrk+k-1 ) = vr( k, i )**2 + vr( k, i+1 )**2 + work( iwrk+k-1 ) = vr( k, i )**2_${ik}$ + vr( k, i+1 )**2_${ik}$ end do - k = stdlib_idamax( n, work( iwrk ), 1 ) - call stdlib_dlartg( vr( k, i ), vr( k, i+1 ), cs, sn, r ) - call stdlib_drot( n, vr( 1, i ), 1, vr( 1, i+1 ), 1, cs, sn ) + k = stdlib${ii}$_idamax( n, work( iwrk ), 1_${ik}$ ) + call stdlib${ii}$_dlartg( vr( k, i ), vr( k, i+1 ), cs, sn, r ) + call stdlib${ii}$_drot( n, vr( 1_${ik}$, i ), 1_${ik}$, vr( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn ) vr( k, i+1 ) = zero end if end do @@ -73944,21 +73938,21 @@ module stdlib_linalg_lapack_d ! undo scaling if necessary 50 continue if( scalea ) then - call stdlib_dlascl( 'G', 0, 0, cscale, anrm, n-info, 1, wr( info+1 ),max( n-info, 1 & + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wr( info+1 ),max( n-info, 1_${ik}$ & ), ierr ) - call stdlib_dlascl( 'G', 0, 0, cscale, anrm, n-info, 1, wi( info+1 ),max( n-info, 1 & + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wi( info+1 ),max( n-info, 1_${ik}$ & ), ierr ) - if( info>0 ) then - call stdlib_dlascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wr, n,ierr ) - call stdlib_dlascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wi, n,ierr ) + if( info>0_${ik}$ ) then + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wr, n,ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr ) end if end if - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_dgeev + end subroutine stdlib${ii}$_dgeev - subroutine stdlib_dgeevx( balanc, jobvl, jobvr, sense, n, a, lda, wr, wi,vl, ldvl, vr, ldvr, & + subroutine stdlib${ii}$_dgeevx( balanc, jobvl, jobvr, sense, n, a, lda, wr, wi,vl, ldvl, vr, ldvr, & !! DGEEVX computes for an N-by-N real nonsymmetric matrix A, the !! eigenvalues and, optionally, the left and/or right eigenvectors. !! Optionally also, it computes a balancing transformation to improve @@ -73990,11 +73984,11 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: balanc, jobvl, jobvr, sense - integer(ilp), intent(out) :: ihi, ilo, info - integer(ilp), intent(in) :: lda, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: ihi, ilo, info + integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n real(dp), intent(out) :: abnrm ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: rconde(*), rcondv(*), scale(*), vl(ldvl,*), vr(ldvr,*), wi(*),& work(*), wr(*) @@ -74003,18 +73997,18 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: lquery, scalea, wantvl, wantvr, wntsnb, wntsne, wntsnn, wntsnv character :: job, side - integer(ilp) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, & + integer(${ik}$) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, & nout real(dp) :: anrm, bignum, cs, cscale, eps, r, scl, smlnum, sn ! Local Arrays - logical(lk) :: select(1) - real(dp) :: dum(1) + logical(lk) :: select(1_${ik}$) + real(dp) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) wantvl = stdlib_lsame( jobvl, 'V' ) wantvr = stdlib_lsame( jobvr, 'V' ) wntsnn = stdlib_lsame( sense, 'N' ) @@ -74023,87 +74017,87 @@ module stdlib_linalg_lapack_d wntsnb = stdlib_lsame( sense, 'B' ) if( .not.( stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'S' ).or. & stdlib_lsame( balanc, 'P' ) .or. stdlib_lsame( balanc, 'B' ) ) )then - info = -1 + info = -1_${ik}$ else if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then - info = -3 + info = -3_${ik}$ else if( .not.( wntsnn .or. wntsne .or. wntsnb .or. wntsnv ) .or.( ( wntsne .or. & wntsnb ) .and. .not.( wantvl .and.wantvr ) ) ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( ldazero .and. anrmzero ) then - scl = one / stdlib_dlapy2( stdlib_dnrm2( n, vl( 1, i ), 1 ),stdlib_dnrm2( n, & - vl( 1, i+1 ), 1 ) ) - call stdlib_dscal( n, scl, vl( 1, i ), 1 ) - call stdlib_dscal( n, scl, vl( 1, i+1 ), 1 ) + scl = one / stdlib${ii}$_dlapy2( stdlib${ii}$_dnrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_dnrm2( n, & + vl( 1_${ik}$, i+1 ), 1_${ik}$ ) ) + call stdlib${ii}$_dscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_dscal( n, scl, vl( 1_${ik}$, i+1 ), 1_${ik}$ ) do k = 1, n - work( k ) = vl( k, i )**2 + vl( k, i+1 )**2 + work( k ) = vl( k, i )**2_${ik}$ + vl( k, i+1 )**2_${ik}$ end do - k = stdlib_idamax( n, work, 1 ) - call stdlib_dlartg( vl( k, i ), vl( k, i+1 ), cs, sn, r ) - call stdlib_drot( n, vl( 1, i ), 1, vl( 1, i+1 ), 1, cs, sn ) + k = stdlib${ii}$_idamax( n, work, 1_${ik}$ ) + call stdlib${ii}$_dlartg( vl( k, i ), vl( k, i+1 ), cs, sn, r ) + call stdlib${ii}$_drot( n, vl( 1_${ik}$, i ), 1_${ik}$, vl( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn ) vl( k, i+1 ) = zero end if end do end if if( wantvr ) then ! undo balancing of right eigenvectors - call stdlib_dgebak( balanc, 'R', n, ilo, ihi, scale, n, vr, ldvr,ierr ) + call stdlib${ii}$_dgebak( balanc, 'R', n, ilo, ihi, scale, n, vr, ldvr,ierr ) ! normalize right eigenvectors and make largest component real do i = 1, n if( wi( i )==zero ) then - scl = one / stdlib_dnrm2( n, vr( 1, i ), 1 ) - call stdlib_dscal( n, scl, vr( 1, i ), 1 ) + scl = one / stdlib${ii}$_dnrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_dscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ ) else if( wi( i )>zero ) then - scl = one / stdlib_dlapy2( stdlib_dnrm2( n, vr( 1, i ), 1 ),stdlib_dnrm2( n, & - vr( 1, i+1 ), 1 ) ) - call stdlib_dscal( n, scl, vr( 1, i ), 1 ) - call stdlib_dscal( n, scl, vr( 1, i+1 ), 1 ) + scl = one / stdlib${ii}$_dlapy2( stdlib${ii}$_dnrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_dnrm2( n, & + vr( 1_${ik}$, i+1 ), 1_${ik}$ ) ) + call stdlib${ii}$_dscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_dscal( n, scl, vr( 1_${ik}$, i+1 ), 1_${ik}$ ) do k = 1, n - work( k ) = vr( k, i )**2 + vr( k, i+1 )**2 + work( k ) = vr( k, i )**2_${ik}$ + vr( k, i+1 )**2_${ik}$ end do - k = stdlib_idamax( n, work, 1 ) - call stdlib_dlartg( vr( k, i ), vr( k, i+1 ), cs, sn, r ) - call stdlib_drot( n, vr( 1, i ), 1, vr( 1, i+1 ), 1, cs, sn ) + k = stdlib${ii}$_idamax( n, work, 1_${ik}$ ) + call stdlib${ii}$_dlartg( vr( k, i ), vr( k, i+1 ), cs, sn, r ) + call stdlib${ii}$_drot( n, vr( 1_${ik}$, i ), 1_${ik}$, vr( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn ) vr( k, i+1 ) = zero end if end do @@ -74253,24 +74247,24 @@ module stdlib_linalg_lapack_d ! undo scaling if necessary 50 continue if( scalea ) then - call stdlib_dlascl( 'G', 0, 0, cscale, anrm, n-info, 1, wr( info+1 ),max( n-info, 1 & + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wr( info+1 ),max( n-info, 1_${ik}$ & ), ierr ) - call stdlib_dlascl( 'G', 0, 0, cscale, anrm, n-info, 1, wi( info+1 ),max( n-info, 1 & + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wi( info+1 ),max( n-info, 1_${ik}$ & ), ierr ) - if( info==0 ) then - if( ( wntsnv .or. wntsnb ) .and. icond==0 )call stdlib_dlascl( 'G', 0, 0, cscale,& - anrm, n, 1, rcondv, n,ierr ) + if( info==0_${ik}$ ) then + if( ( wntsnv .or. wntsnb ) .and. icond==0_${ik}$ )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale,& + anrm, n, 1_${ik}$, rcondv, n,ierr ) else - call stdlib_dlascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wr, n,ierr ) - call stdlib_dlascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wi, n,ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wr, n,ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr ) end if end if - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_dgeevx + end subroutine stdlib${ii}$_dgeevx - subroutine stdlib_dgelsd( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, iwork, & + subroutine stdlib${ii}$_dgelsd( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, iwork, & !! DGELSD computes the minimum-norm solution to a real linear least !! squares problem: !! minimize 2-norm(| b - A*x |) @@ -74301,166 +74295,166 @@ module stdlib_linalg_lapack_d ! -- 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, rank - integer(ilp), intent(in) :: lda, ldb, lwork, m, n, nrhs + integer(${ik}$), intent(out) :: info, rank + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, nrhs real(dp), intent(in) :: rcond ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(inout) :: a(lda,*), b(ldb,*) real(dp), intent(out) :: s(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: iascl, ibscl, ie, il, itau, itaup, itauq, ldwork, liwork, maxmn, & + integer(${ik}$) :: iascl, ibscl, ie, il, itau, itaup, itauq, ldwork, liwork, maxmn, & maxwrk, minmn, minwrk, mm, mnthr, nlvl, nwork, smlsiz, wlalsd real(dp) :: anrm, bignum, bnrm, eps, sfmin, smlnum ! Intrinsic Functions intrinsic :: real,int,log,max,min ! Executable Statements ! test the input arguments. - info = 0 + info = 0_${ik}$ minmn = min( m, n ) maxmn = max( m, n ) - mnthr = stdlib_ilaenv( 6, 'DGELSD', ' ', m, n, nrhs, -1 ) - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( lda=n .and. m>=mnthr ) then ! path 1a - overdetermined, with many more rows than columns. mm = n - maxwrk = max( maxwrk, n+n*stdlib_ilaenv( 1, 'DGEQRF', ' ', m, n,-1, -1 ) ) + maxwrk = max( maxwrk, n+n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQRF', ' ', m, n,-1_${ik}$, -1_${ik}$ ) ) - maxwrk = max( maxwrk, n+nrhs*stdlib_ilaenv( 1, 'DORMQR', 'LT', m, nrhs, n, -1 ) ) + maxwrk = max( maxwrk, n+nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', 'LT', m, nrhs, n, -1_${ik}$ ) ) end if if( m>=n ) then ! path 1 - overdetermined or exactly determined. - maxwrk = max( maxwrk, 3*n+( mm+n )*stdlib_ilaenv( 1, 'DGEBRD', ' ', mm, n, -1, -& - 1 ) ) - maxwrk = max( maxwrk, 3*n+nrhs*stdlib_ilaenv( 1, 'DORMBR', 'QLT', mm, nrhs, n, -& - 1 ) ) - maxwrk = max( maxwrk, 3*n+( n-1 )*stdlib_ilaenv( 1, 'DORMBR', 'PLN', n, nrhs, n, & - -1 ) ) - wlalsd = 9*n+2*n*smlsiz+8*n*nlvl+n*nrhs+(smlsiz+1)**2 - maxwrk = max( maxwrk, 3*n+wlalsd ) - minwrk = max( 3*n+mm, 3*n+nrhs, 3*n+wlalsd ) + maxwrk = max( maxwrk, 3_${ik}$*n+( mm+n )*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEBRD', ' ', mm, n, -1_${ik}$, -& + 1_${ik}$ ) ) + maxwrk = max( maxwrk, 3_${ik}$*n+nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMBR', 'QLT', mm, nrhs, n, -& + 1_${ik}$ ) ) + maxwrk = max( maxwrk, 3_${ik}$*n+( n-1 )*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMBR', 'PLN', n, nrhs, n, & + -1_${ik}$ ) ) + wlalsd = 9_${ik}$*n+2*n*smlsiz+8*n*nlvl+n*nrhs+(smlsiz+1)**2_${ik}$ + maxwrk = max( maxwrk, 3_${ik}$*n+wlalsd ) + minwrk = max( 3_${ik}$*n+mm, 3_${ik}$*n+nrhs, 3_${ik}$*n+wlalsd ) end if if( n>m ) then - wlalsd = 9*m+2*m*smlsiz+8*m*nlvl+m*nrhs+(smlsiz+1)**2 + wlalsd = 9_${ik}$*m+2*m*smlsiz+8*m*nlvl+m*nrhs+(smlsiz+1)**2_${ik}$ if( n>=mnthr ) then ! path 2a - underdetermined, with many more columns ! than rows. - maxwrk = m + m*stdlib_ilaenv( 1, 'DGELQF', ' ', m, n, -1, -1 ) - maxwrk = max( maxwrk, m*m+4*m+2*m*stdlib_ilaenv( 1, 'DGEBRD', ' ', m, m, -1, -& - 1 ) ) - maxwrk = max( maxwrk, m*m+4*m+nrhs*stdlib_ilaenv( 1, 'DORMBR', 'QLT', m, nrhs,& - m, -1 ) ) - maxwrk = max( maxwrk, m*m+4*m+( m-1 )*stdlib_ilaenv( 1, 'DORMBR', 'PLN', m, & - nrhs, m, -1 ) ) - if( nrhs>1 ) then + maxwrk = m + m*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGELQF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) + maxwrk = max( maxwrk, m*m+4*m+2*m*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEBRD', ' ', m, m, -1_${ik}$, -& + 1_${ik}$ ) ) + maxwrk = max( maxwrk, m*m+4*m+nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMBR', 'QLT', m, nrhs,& + m, -1_${ik}$ ) ) + maxwrk = max( maxwrk, m*m+4*m+( m-1 )*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMBR', 'PLN', m, & + nrhs, m, -1_${ik}$ ) ) + if( nrhs>1_${ik}$ ) then maxwrk = max( maxwrk, m*m+m+m*nrhs ) else maxwrk = max( maxwrk, m*m+2*m ) end if - maxwrk = max( maxwrk, m+nrhs*stdlib_ilaenv( 1, 'DORMLQ', 'LT', n, nrhs, m, -1 & + maxwrk = max( maxwrk, m+nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMLQ', 'LT', n, nrhs, m, -1_${ik}$ & ) ) maxwrk = max( maxwrk, m*m+4*m+wlalsd ) ! xxx: ensure the path 2a case below is triggered. the workspace ! calculation should use queries for all routines eventually. - maxwrk = max( maxwrk,4*m+m*m+max( m, 2*m-4, nrhs, n-3*m ) ) + maxwrk = max( maxwrk,4_${ik}$*m+m*m+max( m, 2_${ik}$*m-4, nrhs, n-3*m ) ) else ! path 2 - remaining underdetermined cases. - maxwrk = 3*m + ( n+m )*stdlib_ilaenv( 1, 'DGEBRD', ' ', m, n,-1, -1 ) - maxwrk = max( maxwrk, 3*m+nrhs*stdlib_ilaenv( 1, 'DORMBR', 'QLT', m, nrhs, n, & - -1 ) ) - maxwrk = max( maxwrk, 3*m+m*stdlib_ilaenv( 1, 'DORMBR', 'PLN', n, nrhs, m, -1 & + maxwrk = 3_${ik}$*m + ( n+m )*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEBRD', ' ', m, n,-1_${ik}$, -1_${ik}$ ) + maxwrk = max( maxwrk, 3_${ik}$*m+nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMBR', 'QLT', m, nrhs, n, & + -1_${ik}$ ) ) + maxwrk = max( maxwrk, 3_${ik}$*m+m*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMBR', 'PLN', n, nrhs, m, -1_${ik}$ & ) ) - maxwrk = max( maxwrk, 3*m+wlalsd ) + maxwrk = max( maxwrk, 3_${ik}$*m+wlalsd ) end if - minwrk = max( 3*m+nrhs, 3*m+m, 3*m+wlalsd ) + minwrk = max( 3_${ik}$*m+nrhs, 3_${ik}$*m+m, 3_${ik}$*m+wlalsd ) end if minwrk = min( minwrk, maxwrk ) - work( 1 ) = maxwrk - iwork( 1 ) = liwork + work( 1_${ik}$ ) = maxwrk + iwork( 1_${ik}$ ) = liwork if( lworkzero .and. anrmbignum ) then ! scale matrix norm down to bignum. - call stdlib_dlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_dlaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) - call stdlib_dlaset( 'F', minmn, 1, zero, zero, s, 1 ) - rank = 0 + call stdlib${ii}$_dlaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) + call stdlib${ii}$_dlaset( 'F', minmn, 1_${ik}$, zero, zero, s, 1_${ik}$ ) + rank = 0_${ik}$ go to 10 end if ! scale b if max entry outside range [smlnum,bignum]. - bnrm = stdlib_dlange( 'M', m, nrhs, b, ldb, work ) - ibscl = 0 + bnrm = stdlib${ii}$_dlange( 'M', m, nrhs, b, ldb, work ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum. - call stdlib_dlascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) - ibscl = 2 + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, m, nrhs, b, ldb, info ) + ibscl = 2_${ik}$ end if ! if m < n make sure certain entries of b are zero. - if( m=n ) then ! path 1 - overdetermined or exactly determined. @@ -74468,132 +74462,132 @@ module stdlib_linalg_lapack_d if( m>=mnthr ) then ! path 1a - overdetermined, with many more rows than columns. mm = n - itau = 1 + itau = 1_${ik}$ nwork = itau + n ! compute a=q*r. ! (workspace: need 2*n, prefer n+n*nb) - call stdlib_dgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_dgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & info ) ! multiply b by transpose(q). ! (workspace: need n+nrhs, prefer n+nrhs*nb) - call stdlib_dormqr( 'L', 'T', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & + call stdlib${ii}$_dormqr( 'L', 'T', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & nwork ), lwork-nwork+1, info ) ! zero out below r. - if( n>1 ) then - call stdlib_dlaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_dlaset( 'L', n-1, n-1, zero, zero, a( 2_${ik}$, 1_${ik}$ ), lda ) end if end if - ie = 1 + ie = 1_${ik}$ itauq = ie + n itaup = itauq + n nwork = itaup + n ! bidiagonalize r in a. ! (workspace: need 3*n+mm, prefer 3*n+(mm+n)*nb) - call stdlib_dgebrd( mm, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work(& + call stdlib${ii}$_dgebrd( mm, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work(& nwork ), lwork-nwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors of r. ! (workspace: need 3*n+nrhs, prefer 3*n+nrhs*nb) - call stdlib_dormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib${ii}$_dormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & nwork ), lwork-nwork+1, info ) ! solve the bidiagonal least squares problem. - call stdlib_dlalsd( 'U', smlsiz, n, nrhs, s, work( ie ), b, ldb,rcond, rank, work( & + call stdlib${ii}$_dlalsd( 'U', smlsiz, n, nrhs, s, work( ie ), b, ldb,rcond, rank, work( & nwork ), iwork, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then go to 10 end if ! multiply b by right bidiagonalizing vectors of r. - call stdlib_dormbr( 'P', 'L', 'N', n, nrhs, n, a, lda, work( itaup ),b, ldb, work( & + call stdlib${ii}$_dormbr( 'P', 'L', 'N', n, nrhs, n, a, lda, work( itaup ),b, ldb, work( & nwork ), lwork-nwork+1, info ) - else if( n>=mnthr .and. lwork>=4*m+m*m+max( m, 2*m-4, nrhs, n-3*m, wlalsd ) ) & + else if( n>=mnthr .and. lwork>=4_${ik}$*m+m*m+max( m, 2_${ik}$*m-4, nrhs, n-3*m, wlalsd ) ) & then ! path 2a - underdetermined, with many more columns than rows ! and sufficient workspace for an efficient algorithm. ldwork = m - if( lwork>=max( 4*m+m*lda+max( m, 2*m-4, nrhs, n-3*m ),m*lda+m+m*nrhs, 4*m+m*lda+& + if( lwork>=max( 4_${ik}$*m+m*lda+max( m, 2_${ik}$*m-4, nrhs, n-3*m ),m*lda+m+m*nrhs, 4_${ik}$*m+m*lda+& wlalsd ) )ldwork = lda - itau = 1 - nwork = m + 1 + itau = 1_${ik}$ + nwork = m + 1_${ik}$ ! compute a=l*q. ! (workspace: need 2*m, prefer m+m*nb) - call stdlib_dgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, info ) + call stdlib${ii}$_dgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, info ) il = nwork ! copy l to work(il), zeroing out above its diagonal. - call stdlib_dlacpy( 'L', m, m, a, lda, work( il ), ldwork ) - call stdlib_dlaset( 'U', m-1, m-1, zero, zero, work( il+ldwork ),ldwork ) + call stdlib${ii}$_dlacpy( 'L', m, m, a, lda, work( il ), ldwork ) + call stdlib${ii}$_dlaset( 'U', m-1, m-1, zero, zero, work( il+ldwork ),ldwork ) ie = il + ldwork*m itauq = ie + m itaup = itauq + m nwork = itaup + m ! bidiagonalize l in work(il). ! (workspace: need m*m+5*m, prefer m*m+4*m+2*m*nb) - call stdlib_dgebrd( m, m, work( il ), ldwork, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_dgebrd( m, m, work( il ), ldwork, s, work( ie ),work( itauq ), work( & itaup ), work( nwork ),lwork-nwork+1, info ) ! multiply b by transpose of left bidiagonalizing vectors of l. ! (workspace: need m*m+4*m+nrhs, prefer m*m+4*m+nrhs*nb) - call stdlib_dormbr( 'Q', 'L', 'T', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & + call stdlib${ii}$_dormbr( 'Q', 'L', 'T', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & ldb, work( nwork ),lwork-nwork+1, info ) ! solve the bidiagonal least squares problem. - call stdlib_dlalsd( 'U', smlsiz, m, nrhs, s, work( ie ), b, ldb,rcond, rank, work( & + call stdlib${ii}$_dlalsd( 'U', smlsiz, m, nrhs, s, work( ie ), b, ldb,rcond, rank, work( & nwork ), iwork, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then go to 10 end if ! multiply b by right bidiagonalizing vectors of l. - call stdlib_dormbr( 'P', 'L', 'N', m, nrhs, m, work( il ), ldwork,work( itaup ), b, & + call stdlib${ii}$_dormbr( 'P', 'L', 'N', m, nrhs, m, work( il ), ldwork,work( itaup ), b, & ldb, work( nwork ),lwork-nwork+1, info ) ! zero out below first m rows of b. - call stdlib_dlaset( 'F', n-m, nrhs, zero, zero, b( m+1, 1 ), ldb ) + call stdlib${ii}$_dlaset( 'F', n-m, nrhs, zero, zero, b( m+1, 1_${ik}$ ), ldb ) nwork = itau + m ! multiply transpose(q) by b. ! (workspace: need m+nrhs, prefer m+nrhs*nb) - call stdlib_dormlq( 'L', 'T', n, nrhs, m, a, lda, work( itau ), b,ldb, work( nwork )& + call stdlib${ii}$_dormlq( 'L', 'T', n, nrhs, m, a, lda, work( itau ), b,ldb, work( nwork )& , lwork-nwork+1, info ) else ! path 2 - remaining underdetermined cases. - ie = 1 + ie = 1_${ik}$ itauq = ie + m itaup = itauq + m nwork = itaup + m ! bidiagonalize a. ! (workspace: need 3*m+n, prefer 3*m+(m+n)*nb) - call stdlib_dgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work( & + call stdlib${ii}$_dgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work( & nwork ), lwork-nwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors. ! (workspace: need 3*m+nrhs, prefer 3*m+nrhs*nb) - call stdlib_dormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib${ii}$_dormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & nwork ), lwork-nwork+1, info ) ! solve the bidiagonal least squares problem. - call stdlib_dlalsd( 'L', smlsiz, m, nrhs, s, work( ie ), b, ldb,rcond, rank, work( & + call stdlib${ii}$_dlalsd( 'L', smlsiz, m, nrhs, s, work( ie ), b, ldb,rcond, rank, work( & nwork ), iwork, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then go to 10 end if ! multiply b by right bidiagonalizing vectors of a. - call stdlib_dormbr( 'P', 'L', 'N', n, nrhs, m, a, lda, work( itaup ),b, ldb, work( & + call stdlib${ii}$_dormbr( 'P', 'L', 'N', n, nrhs, m, a, lda, work( itaup ),b, ldb, work( & nwork ), lwork-nwork+1, info ) end if ! undo scaling. - if( iascl==1 ) then - call stdlib_dlascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info ) - call stdlib_dlascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn,info ) - else if( iascl==2 ) then - call stdlib_dlascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info ) - call stdlib_dlascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,info ) - end if - if( ibscl==1 ) then - call stdlib_dlascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info ) - else if( ibscl==2 ) then - call stdlib_dlascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info ) + if( iascl==1_${ik}$ ) then + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, smlnum, n, nrhs, b, ldb, info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, anrm, minmn, 1_${ik}$, s, minmn,info ) + else if( iascl==2_${ik}$ ) then + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, n, nrhs, b, ldb, info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn, 1_${ik}$, s, minmn,info ) + end if + if( ibscl==1_${ik}$ ) then + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, bnrm, n, nrhs, b, ldb, info ) + else if( ibscl==2_${ik}$ ) then + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bignum, bnrm, n, nrhs, b, ldb, info ) end if 10 continue - work( 1 ) = maxwrk - iwork( 1 ) = liwork + work( 1_${ik}$ ) = maxwrk + iwork( 1_${ik}$ ) = liwork return - end subroutine stdlib_dgelsd + end subroutine stdlib${ii}$_dgelsd - subroutine stdlib_dgelss( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, info ) + subroutine stdlib${ii}$_dgelss( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, info ) !! DGELSS computes the minimum norm solution to a real linear least !! squares problem: !! Minimize 2-norm(| b - A*x |). @@ -74611,8 +74605,8 @@ module stdlib_linalg_lapack_d ! -- 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, rank - integer(ilp), intent(in) :: lda, ldb, lwork, m, n, nrhs + integer(${ik}$), intent(out) :: info, rank + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, nrhs real(dp), intent(in) :: rcond ! Array Arguments real(dp), intent(inout) :: a(lda,*), b(ldb,*) @@ -74621,190 +74615,190 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: lquery - integer(ilp) :: bdspac, bl, chunk, i, iascl, ibscl, ie, il, itau, itaup, itauq, iwork, & + integer(${ik}$) :: bdspac, bl, chunk, i, iascl, ibscl, ie, il, itau, itaup, itauq, iwork, & ldwork, maxmn, maxwrk, minmn, minwrk, mm, mnthr - integer(ilp) :: lwork_dgeqrf, lwork_dormqr, lwork_dgebrd, lwork_dormbr, lwork_dorgbr, & + integer(${ik}$) :: lwork_dgeqrf, lwork_dormqr, lwork_dgebrd, lwork_dormbr, lwork_dorgbr, & lwork_dormlq, lwork_dgelqf real(dp) :: anrm, bignum, bnrm, eps, sfmin, smlnum, thr ! Local Arrays - real(dp) :: dum(1) + real(dp) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ minmn = min( m, n ) maxmn = max( m, n ) - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( lda0 ) then + ! following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + if( minmn>0_${ik}$ ) then mm = m - mnthr = stdlib_ilaenv( 6, 'DGELSS', ' ', m, n, nrhs, -1 ) + mnthr = stdlib${ii}$_ilaenv( 6_${ik}$, 'DGELSS', ' ', m, n, nrhs, -1_${ik}$ ) if( m>=n .and. m>=mnthr ) then ! path 1a - overdetermined, with many more rows than ! columns - ! compute space needed for stdlib_dgeqrf - call stdlib_dgeqrf( m, n, a, lda, dum(1), dum(1), -1, info ) - lwork_dgeqrf=dum(1) - ! compute space needed for stdlib_dormqr - call stdlib_dormqr( 'L', 'T', m, nrhs, n, a, lda, dum(1), b,ldb, dum(1), -1, & + ! compute space needed for stdlib${ii}$_dgeqrf + call stdlib${ii}$_dgeqrf( m, n, a, lda, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, info ) + lwork_dgeqrf=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_dormqr + call stdlib${ii}$_dormqr( 'L', 'T', m, nrhs, n, a, lda, dum(1_${ik}$), b,ldb, dum(1_${ik}$), -1_${ik}$, & info ) - lwork_dormqr=dum(1) + lwork_dormqr=dum(1_${ik}$) mm = n maxwrk = max( maxwrk, n + lwork_dgeqrf ) maxwrk = max( maxwrk, n + lwork_dormqr ) end if if( m>=n ) then ! path 1 - overdetermined or exactly determined - ! compute workspace needed for stdlib_dbdsqr - bdspac = max( 1, 5*n ) - ! compute space needed for stdlib_dgebrd - call stdlib_dgebrd( mm, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, info & + ! compute workspace needed for stdlib${ii}$_dbdsqr + bdspac = max( 1_${ik}$, 5_${ik}$*n ) + ! compute space needed for stdlib${ii}$_dgebrd + call stdlib${ii}$_dgebrd( mm, n, a, lda, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, info & ) - lwork_dgebrd=dum(1) - ! compute space needed for stdlib_dormbr - call stdlib_dormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, dum(1),b, ldb, dum(1),& - -1, info ) - lwork_dormbr=dum(1) - ! compute space needed for stdlib_dorgbr - call stdlib_dorgbr( 'P', n, n, n, a, lda, dum(1),dum(1), -1, info ) - lwork_dorgbr=dum(1) + lwork_dgebrd=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_dormbr + call stdlib${ii}$_dormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, dum(1_${ik}$),b, ldb, dum(1_${ik}$),& + -1_${ik}$, info ) + lwork_dormbr=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_dorgbr + call stdlib${ii}$_dorgbr( 'P', n, n, n, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, info ) + lwork_dorgbr=dum(1_${ik}$) ! compute total workspace needed - maxwrk = max( maxwrk, 3*n + lwork_dgebrd ) - maxwrk = max( maxwrk, 3*n + lwork_dormbr ) - maxwrk = max( maxwrk, 3*n + lwork_dorgbr ) + maxwrk = max( maxwrk, 3_${ik}$*n + lwork_dgebrd ) + maxwrk = max( maxwrk, 3_${ik}$*n + lwork_dormbr ) + maxwrk = max( maxwrk, 3_${ik}$*n + lwork_dorgbr ) maxwrk = max( maxwrk, bdspac ) maxwrk = max( maxwrk, n*nrhs ) - minwrk = max( 3*n + mm, 3*n + nrhs, bdspac ) + minwrk = max( 3_${ik}$*n + mm, 3_${ik}$*n + nrhs, bdspac ) maxwrk = max( minwrk, maxwrk ) end if if( n>m ) then - ! compute workspace needed for stdlib_dbdsqr - bdspac = max( 1, 5*m ) - minwrk = max( 3*m+nrhs, 3*m+n, bdspac ) + ! compute workspace needed for stdlib${ii}$_dbdsqr + bdspac = max( 1_${ik}$, 5_${ik}$*m ) + minwrk = max( 3_${ik}$*m+nrhs, 3_${ik}$*m+n, bdspac ) if( n>=mnthr ) then ! path 2a - underdetermined, with many more columns ! than rows - ! compute space needed for stdlib_dgelqf - call stdlib_dgelqf( m, n, a, lda, dum(1), dum(1),-1, info ) - lwork_dgelqf=dum(1) - ! compute space needed for stdlib_dgebrd - call stdlib_dgebrd( m, m, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, & + ! compute space needed for stdlib${ii}$_dgelqf + call stdlib${ii}$_dgelqf( m, n, a, lda, dum(1_${ik}$), dum(1_${ik}$),-1_${ik}$, info ) + lwork_dgelqf=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_dgebrd + call stdlib${ii}$_dgebrd( m, m, a, lda, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, & info ) - lwork_dgebrd=dum(1) - ! compute space needed for stdlib_dormbr - call stdlib_dormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda,dum(1), b, ldb, dum(& - 1), -1, info ) - lwork_dormbr=dum(1) - ! compute space needed for stdlib_dorgbr - call stdlib_dorgbr( 'P', m, m, m, a, lda, dum(1),dum(1), -1, info ) - lwork_dorgbr=dum(1) - ! compute space needed for stdlib_dormlq - call stdlib_dormlq( 'L', 'T', n, nrhs, m, a, lda, dum(1),b, ldb, dum(1), -& - 1, info ) - lwork_dormlq=dum(1) + lwork_dgebrd=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_dormbr + call stdlib${ii}$_dormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda,dum(1_${ik}$), b, ldb, dum(& + 1_${ik}$), -1_${ik}$, info ) + lwork_dormbr=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_dorgbr + call stdlib${ii}$_dorgbr( 'P', m, m, m, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, info ) + lwork_dorgbr=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_dormlq + call stdlib${ii}$_dormlq( 'L', 'T', n, nrhs, m, a, lda, dum(1_${ik}$),b, ldb, dum(1_${ik}$), -& + 1_${ik}$, info ) + lwork_dormlq=dum(1_${ik}$) ! compute total workspace needed maxwrk = m + lwork_dgelqf - maxwrk = max( maxwrk, m*m + 4*m + lwork_dgebrd ) - maxwrk = max( maxwrk, m*m + 4*m + lwork_dormbr ) - maxwrk = max( maxwrk, m*m + 4*m + lwork_dorgbr ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + lwork_dgebrd ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + lwork_dormbr ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + lwork_dorgbr ) maxwrk = max( maxwrk, m*m + m + bdspac ) - if( nrhs>1 ) then + if( nrhs>1_${ik}$ ) then maxwrk = max( maxwrk, m*m + m + m*nrhs ) else - maxwrk = max( maxwrk, m*m + 2*m ) + maxwrk = max( maxwrk, m*m + 2_${ik}$*m ) end if maxwrk = max( maxwrk, m + lwork_dormlq ) else ! path 2 - underdetermined - ! compute space needed for stdlib_dgebrd - call stdlib_dgebrd( m, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, & + ! compute space needed for stdlib${ii}$_dgebrd + call stdlib${ii}$_dgebrd( m, n, a, lda, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, & info ) - lwork_dgebrd=dum(1) - ! compute space needed for stdlib_dormbr - call stdlib_dormbr( 'Q', 'L', 'T', m, nrhs, m, a, lda,dum(1), b, ldb, dum(& - 1), -1, info ) - lwork_dormbr=dum(1) - ! compute space needed for stdlib_dorgbr - call stdlib_dorgbr( 'P', m, n, m, a, lda, dum(1),dum(1), -1, info ) - lwork_dorgbr=dum(1) - maxwrk = 3*m + lwork_dgebrd - maxwrk = max( maxwrk, 3*m + lwork_dormbr ) - maxwrk = max( maxwrk, 3*m + lwork_dorgbr ) + lwork_dgebrd=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_dormbr + call stdlib${ii}$_dormbr( 'Q', 'L', 'T', m, nrhs, m, a, lda,dum(1_${ik}$), b, ldb, dum(& + 1_${ik}$), -1_${ik}$, info ) + lwork_dormbr=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_dorgbr + call stdlib${ii}$_dorgbr( 'P', m, n, m, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, info ) + lwork_dorgbr=dum(1_${ik}$) + maxwrk = 3_${ik}$*m + lwork_dgebrd + maxwrk = max( maxwrk, 3_${ik}$*m + lwork_dormbr ) + maxwrk = max( maxwrk, 3_${ik}$*m + lwork_dorgbr ) maxwrk = max( maxwrk, bdspac ) maxwrk = max( maxwrk, n*nrhs ) end if end if maxwrk = max( minwrk, maxwrk ) end if - work( 1 ) = maxwrk - if( lworkzero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_dlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_dlaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) - call stdlib_dlaset( 'F', minmn, 1, zero, zero, s, minmn ) - rank = 0 + call stdlib${ii}$_dlaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) + call stdlib${ii}$_dlaset( 'F', minmn, 1_${ik}$, zero, zero, s, minmn ) + rank = 0_${ik}$ go to 70 end if ! scale b if max element outside range [smlnum,bignum] - bnrm = stdlib_dlange( 'M', m, nrhs, b, ldb, work ) - ibscl = 0 + bnrm = stdlib${ii}$_dlange( 'M', m, nrhs, b, ldb, work ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_dlascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) - ibscl = 2 + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, m, nrhs, b, ldb, info ) + ibscl = 2_${ik}$ end if ! overdetermined case if( m>=n ) then @@ -74813,229 +74807,229 @@ module stdlib_linalg_lapack_d if( m>=mnthr ) then ! path 1a - overdetermined, with many more rows than columns mm = n - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r ! (workspace: need 2*n, prefer n+n*nb) - call stdlib_dgeqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & + call stdlib${ii}$_dgeqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & info ) ! multiply b by transpose(q) ! (workspace: need n+nrhs, prefer n+nrhs*nb) - call stdlib_dormqr( 'L', 'T', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & + call stdlib${ii}$_dormqr( 'L', 'T', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & iwork ), lwork-iwork+1, info ) ! zero out below r - if( n>1 )call stdlib_dlaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) + if( n>1_${ik}$ )call stdlib${ii}$_dlaset( 'L', n-1, n-1, zero, zero, a( 2_${ik}$, 1_${ik}$ ), lda ) end if - ie = 1 + ie = 1_${ik}$ itauq = ie + n itaup = itauq + n iwork = itaup + n ! bidiagonalize r in a ! (workspace: need 3*n+mm, prefer 3*n+(mm+n)*nb) - call stdlib_dgebrd( mm, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work(& + call stdlib${ii}$_dgebrd( mm, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work(& iwork ), lwork-iwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors of r ! (workspace: need 3*n+nrhs, prefer 3*n+nrhs*nb) - call stdlib_dormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib${ii}$_dormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & iwork ), lwork-iwork+1, info ) ! generate right bidiagonalizing vectors of r in a ! (workspace: need 4*n-1, prefer 3*n+(n-1)*nb) - call stdlib_dorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-iwork+& - 1, info ) + call stdlib${ii}$_dorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-iwork+& + 1_${ik}$, info ) iwork = ie + n ! perform bidiagonal qr iteration ! multiply b by transpose of left singular vectors ! compute right singular vectors in a ! (workspace: need bdspac) - call stdlib_dbdsqr( 'U', n, n, 0, nrhs, s, work( ie ), a, lda, dum,1, b, ldb, work( & + call stdlib${ii}$_dbdsqr( 'U', n, n, 0_${ik}$, nrhs, s, work( ie ), a, lda, dum,1_${ik}$, b, ldb, work( & iwork ), info ) if( info/=0 )go to 70 ! multiply b by reciprocals of singular values - thr = max( rcond*s( 1 ), sfmin ) - if( rcondthr ) then - call stdlib_drscl( nrhs, s( i ), b( i, 1 ), ldb ) - rank = rank + 1 + call stdlib${ii}$_drscl( nrhs, s( i ), b( i, 1_${ik}$ ), ldb ) + rank = rank + 1_${ik}$ else - call stdlib_dlaset( 'F', 1, nrhs, zero, zero, b( i, 1 ), ldb ) + call stdlib${ii}$_dlaset( 'F', 1_${ik}$, nrhs, zero, zero, b( i, 1_${ik}$ ), ldb ) end if end do ! multiply b by right singular vectors ! (workspace: need n, prefer n*nrhs) - if( lwork>=ldb*nrhs .and. nrhs>1 ) then - call stdlib_dgemm( 'T', 'N', n, nrhs, n, one, a, lda, b, ldb, zero,work, ldb ) + if( lwork>=ldb*nrhs .and. nrhs>1_${ik}$ ) then + call stdlib${ii}$_dgemm( 'T', 'N', n, nrhs, n, one, a, lda, b, ldb, zero,work, ldb ) - call stdlib_dlacpy( 'G', n, nrhs, work, ldb, b, ldb ) - else if( nrhs>1 ) then + call stdlib${ii}$_dlacpy( 'G', n, nrhs, work, ldb, b, ldb ) + else if( nrhs>1_${ik}$ ) then chunk = lwork / n do i = 1, nrhs, chunk bl = min( nrhs-i+1, chunk ) - call stdlib_dgemm( 'T', 'N', n, bl, n, one, a, lda, b( 1, i ),ldb, zero, work,& + call stdlib${ii}$_dgemm( 'T', 'N', n, bl, n, one, a, lda, b( 1_${ik}$, i ),ldb, zero, work,& n ) - call stdlib_dlacpy( 'G', n, bl, work, n, b( 1, i ), ldb ) + call stdlib${ii}$_dlacpy( 'G', n, bl, work, n, b( 1_${ik}$, i ), ldb ) end do else - call stdlib_dgemv( 'T', n, n, one, a, lda, b, 1, zero, work, 1 ) - call stdlib_dcopy( n, work, 1, b, 1 ) + call stdlib${ii}$_dgemv( 'T', n, n, one, a, lda, b, 1_${ik}$, zero, work, 1_${ik}$ ) + call stdlib${ii}$_dcopy( n, work, 1_${ik}$, b, 1_${ik}$ ) end if - else if( n>=mnthr .and. lwork>=4*m+m*m+max( m, 2*m-4, nrhs, n-3*m ) ) then + else if( n>=mnthr .and. lwork>=4_${ik}$*m+m*m+max( m, 2_${ik}$*m-4, nrhs, n-3*m ) ) then ! path 2a - underdetermined, with many more columns than rows ! and sufficient workspace for an efficient algorithm ldwork = m - if( lwork>=max( 4*m+m*lda+max( m, 2*m-4, nrhs, n-3*m ),m*lda+m+m*nrhs ) )ldwork = & + if( lwork>=max( 4_${ik}$*m+m*lda+max( m, 2_${ik}$*m-4, nrhs, n-3*m ),m*lda+m+m*nrhs ) )ldwork = & lda - itau = 1 - iwork = m + 1 + itau = 1_${ik}$ + iwork = m + 1_${ik}$ ! compute a=l*q ! (workspace: need 2*m, prefer m+m*nb) - call stdlib_dgelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, info ) + call stdlib${ii}$_dgelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, info ) il = iwork ! copy l to work(il), zeroing out above it - call stdlib_dlacpy( 'L', m, m, a, lda, work( il ), ldwork ) - call stdlib_dlaset( 'U', m-1, m-1, zero, zero, work( il+ldwork ),ldwork ) + call stdlib${ii}$_dlacpy( 'L', m, m, a, lda, work( il ), ldwork ) + call stdlib${ii}$_dlaset( 'U', m-1, m-1, zero, zero, work( il+ldwork ),ldwork ) ie = il + ldwork*m itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize l in work(il) ! (workspace: need m*m+5*m, prefer m*m+4*m+2*m*nb) - call stdlib_dgebrd( m, m, work( il ), ldwork, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_dgebrd( m, m, work( il ), ldwork, s, work( ie ),work( itauq ), work( & itaup ), work( iwork ),lwork-iwork+1, info ) ! multiply b by transpose of left bidiagonalizing vectors of l ! (workspace: need m*m+4*m+nrhs, prefer m*m+4*m+nrhs*nb) - call stdlib_dormbr( 'Q', 'L', 'T', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & + call stdlib${ii}$_dormbr( 'Q', 'L', 'T', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & ldb, work( iwork ),lwork-iwork+1, info ) ! generate right bidiagonalizing vectors of r in work(il) ! (workspace: need m*m+5*m-1, prefer m*m+4*m+(m-1)*nb) - call stdlib_dorgbr( 'P', m, m, m, work( il ), ldwork, work( itaup ),work( iwork ), & + call stdlib${ii}$_dorgbr( 'P', m, m, m, work( il ), ldwork, work( itaup ),work( iwork ), & lwork-iwork+1, info ) iwork = ie + m ! perform bidiagonal qr iteration, ! computing right singular vectors of l in work(il) and ! multiplying b by transpose of left singular vectors ! (workspace: need m*m+m+bdspac) - call stdlib_dbdsqr( 'U', m, m, 0, nrhs, s, work( ie ), work( il ),ldwork, a, lda, b,& + call stdlib${ii}$_dbdsqr( 'U', m, m, 0_${ik}$, nrhs, s, work( ie ), work( il ),ldwork, a, lda, b,& ldb, work( iwork ), info ) if( info/=0 )go to 70 ! multiply b by reciprocals of singular values - thr = max( rcond*s( 1 ), sfmin ) - if( rcondthr ) then - call stdlib_drscl( nrhs, s( i ), b( i, 1 ), ldb ) - rank = rank + 1 + call stdlib${ii}$_drscl( nrhs, s( i ), b( i, 1_${ik}$ ), ldb ) + rank = rank + 1_${ik}$ else - call stdlib_dlaset( 'F', 1, nrhs, zero, zero, b( i, 1 ), ldb ) + call stdlib${ii}$_dlaset( 'F', 1_${ik}$, nrhs, zero, zero, b( i, 1_${ik}$ ), ldb ) end if end do iwork = ie ! multiply b by right singular vectors of l in work(il) ! (workspace: need m*m+2*m, prefer m*m+m+m*nrhs) - if( lwork>=ldb*nrhs+iwork-1 .and. nrhs>1 ) then - call stdlib_dgemm( 'T', 'N', m, nrhs, m, one, work( il ), ldwork,b, ldb, zero, & + if( lwork>=ldb*nrhs+iwork-1 .and. nrhs>1_${ik}$ ) then + call stdlib${ii}$_dgemm( 'T', 'N', m, nrhs, m, one, work( il ), ldwork,b, ldb, zero, & work( iwork ), ldb ) - call stdlib_dlacpy( 'G', m, nrhs, work( iwork ), ldb, b, ldb ) - else if( nrhs>1 ) then + call stdlib${ii}$_dlacpy( 'G', m, nrhs, work( iwork ), ldb, b, ldb ) + else if( nrhs>1_${ik}$ ) then chunk = ( lwork-iwork+1 ) / m do i = 1, nrhs, chunk bl = min( nrhs-i+1, chunk ) - call stdlib_dgemm( 'T', 'N', m, bl, m, one, work( il ), ldwork,b( 1, i ), ldb,& + call stdlib${ii}$_dgemm( 'T', 'N', m, bl, m, one, work( il ), ldwork,b( 1_${ik}$, i ), ldb,& zero, work( iwork ), m ) - call stdlib_dlacpy( 'G', m, bl, work( iwork ), m, b( 1, i ),ldb ) + call stdlib${ii}$_dlacpy( 'G', m, bl, work( iwork ), m, b( 1_${ik}$, i ),ldb ) end do else - call stdlib_dgemv( 'T', m, m, one, work( il ), ldwork, b( 1, 1 ),1, zero, work( & - iwork ), 1 ) - call stdlib_dcopy( m, work( iwork ), 1, b( 1, 1 ), 1 ) + call stdlib${ii}$_dgemv( 'T', m, m, one, work( il ), ldwork, b( 1_${ik}$, 1_${ik}$ ),1_${ik}$, zero, work( & + iwork ), 1_${ik}$ ) + call stdlib${ii}$_dcopy( m, work( iwork ), 1_${ik}$, b( 1_${ik}$, 1_${ik}$ ), 1_${ik}$ ) end if ! zero out below first m rows of b - call stdlib_dlaset( 'F', n-m, nrhs, zero, zero, b( m+1, 1 ), ldb ) + call stdlib${ii}$_dlaset( 'F', n-m, nrhs, zero, zero, b( m+1, 1_${ik}$ ), ldb ) iwork = itau + m ! multiply transpose(q) by b ! (workspace: need m+nrhs, prefer m+nrhs*nb) - call stdlib_dormlq( 'L', 'T', n, nrhs, m, a, lda, work( itau ), b,ldb, work( iwork )& + call stdlib${ii}$_dormlq( 'L', 'T', n, nrhs, m, a, lda, work( itau ), b,ldb, work( iwork )& , lwork-iwork+1, info ) else ! path 2 - remaining underdetermined cases - ie = 1 + ie = 1_${ik}$ itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize a ! (workspace: need 3*m+n, prefer 3*m+(m+n)*nb) - call stdlib_dgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work( & + call stdlib${ii}$_dgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work( & iwork ), lwork-iwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors ! (workspace: need 3*m+nrhs, prefer 3*m+nrhs*nb) - call stdlib_dormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib${ii}$_dormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & iwork ), lwork-iwork+1, info ) ! generate right bidiagonalizing vectors in a ! (workspace: need 4*m, prefer 3*m+m*nb) - call stdlib_dorgbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-iwork+& - 1, info ) + call stdlib${ii}$_dorgbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-iwork+& + 1_${ik}$, info ) iwork = ie + m ! perform bidiagonal qr iteration, ! computing right singular vectors of a in a and ! multiplying b by transpose of left singular vectors ! (workspace: need bdspac) - call stdlib_dbdsqr( 'L', m, n, 0, nrhs, s, work( ie ), a, lda, dum,1, b, ldb, work( & + call stdlib${ii}$_dbdsqr( 'L', m, n, 0_${ik}$, nrhs, s, work( ie ), a, lda, dum,1_${ik}$, b, ldb, work( & iwork ), info ) if( info/=0 )go to 70 ! multiply b by reciprocals of singular values - thr = max( rcond*s( 1 ), sfmin ) - if( rcondthr ) then - call stdlib_drscl( nrhs, s( i ), b( i, 1 ), ldb ) - rank = rank + 1 + call stdlib${ii}$_drscl( nrhs, s( i ), b( i, 1_${ik}$ ), ldb ) + rank = rank + 1_${ik}$ else - call stdlib_dlaset( 'F', 1, nrhs, zero, zero, b( i, 1 ), ldb ) + call stdlib${ii}$_dlaset( 'F', 1_${ik}$, nrhs, zero, zero, b( i, 1_${ik}$ ), ldb ) end if end do ! multiply b by right singular vectors of a ! (workspace: need n, prefer n*nrhs) - if( lwork>=ldb*nrhs .and. nrhs>1 ) then - call stdlib_dgemm( 'T', 'N', n, nrhs, m, one, a, lda, b, ldb, zero,work, ldb ) + if( lwork>=ldb*nrhs .and. nrhs>1_${ik}$ ) then + call stdlib${ii}$_dgemm( 'T', 'N', n, nrhs, m, one, a, lda, b, ldb, zero,work, ldb ) - call stdlib_dlacpy( 'F', n, nrhs, work, ldb, b, ldb ) - else if( nrhs>1 ) then + call stdlib${ii}$_dlacpy( 'F', n, nrhs, work, ldb, b, ldb ) + else if( nrhs>1_${ik}$ ) then chunk = lwork / n do i = 1, nrhs, chunk bl = min( nrhs-i+1, chunk ) - call stdlib_dgemm( 'T', 'N', n, bl, m, one, a, lda, b( 1, i ),ldb, zero, work,& + call stdlib${ii}$_dgemm( 'T', 'N', n, bl, m, one, a, lda, b( 1_${ik}$, i ),ldb, zero, work,& n ) - call stdlib_dlacpy( 'F', n, bl, work, n, b( 1, i ), ldb ) + call stdlib${ii}$_dlacpy( 'F', n, bl, work, n, b( 1_${ik}$, i ), ldb ) end do else - call stdlib_dgemv( 'T', m, n, one, a, lda, b, 1, zero, work, 1 ) - call stdlib_dcopy( n, work, 1, b, 1 ) + call stdlib${ii}$_dgemv( 'T', m, n, one, a, lda, b, 1_${ik}$, zero, work, 1_${ik}$ ) + call stdlib${ii}$_dcopy( n, work, 1_${ik}$, b, 1_${ik}$ ) end if end if ! undo scaling - if( iascl==1 ) then - call stdlib_dlascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info ) - call stdlib_dlascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn,info ) - else if( iascl==2 ) then - call stdlib_dlascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info ) - call stdlib_dlascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,info ) - end if - if( ibscl==1 ) then - call stdlib_dlascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info ) - else if( ibscl==2 ) then - call stdlib_dlascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info ) + if( iascl==1_${ik}$ ) then + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, smlnum, n, nrhs, b, ldb, info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, anrm, minmn, 1_${ik}$, s, minmn,info ) + else if( iascl==2_${ik}$ ) then + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, n, nrhs, b, ldb, info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn, 1_${ik}$, s, minmn,info ) + end if + if( ibscl==1_${ik}$ ) then + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, bnrm, n, nrhs, b, ldb, info ) + else if( ibscl==2_${ik}$ ) then + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bignum, bnrm, n, nrhs, b, ldb, info ) end if 70 continue - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_dgelss + end subroutine stdlib${ii}$_dgelss - subroutine stdlib_dgesdd( jobz, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, iwork, info ) + subroutine stdlib${ii}$_dgesdd( jobz, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, iwork, info ) !! DGESDD computes the singular value decomposition (SVD) of a real !! M-by-N matrix A, optionally computing the left and right singular !! vectors. If singular vectors are desired, it uses a @@ -75061,303 +75055,303 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldu, ldvt, lwork, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldu, ldvt, lwork, m, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: s(*), u(ldu,*), vt(ldvt,*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, wntqa, wntqas, wntqn, wntqo, wntqs - integer(ilp) :: bdspac, blk, chunk, i, ie, ierr, il, ir, iscl, itau, itaup, itauq, iu, & + integer(${ik}$) :: bdspac, blk, chunk, i, ie, ierr, il, ir, iscl, itau, itaup, itauq, iu, & ivt, ldwkvt, ldwrkl, ldwrkr, ldwrku, maxwrk, minmn, minwrk, mnthr, nwork, wrkbl - integer(ilp) :: lwork_dgebrd_mn, lwork_dgebrd_mm, lwork_dgebrd_nn, lwork_dgelqf_mn, & + integer(${ik}$) :: lwork_dgebrd_mn, lwork_dgebrd_mm, lwork_dgebrd_nn, lwork_dgelqf_mn, & lwork_dgeqrf_mn, lwork_dorgbr_p_mm, lwork_dorgbr_q_nn, lwork_dorglq_mn, & lwork_dorglq_nn, lwork_dorgqr_mm, lwork_dorgqr_mn, lwork_dormbr_prt_mm, & lwork_dormbr_qln_mm, lwork_dormbr_prt_mn, lwork_dormbr_qln_mn, lwork_dormbr_prt_nn, & lwork_dormbr_qln_nn real(dp) :: anrm, bignum, eps, smlnum ! Local Arrays - integer(ilp) :: idum(1) - real(dp) :: dum(1) + integer(${ik}$) :: idum(1_${ik}$) + real(dp) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: int,max,min,sqrt ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ minmn = min( m, n ) wntqa = stdlib_lsame( jobz, 'A' ) wntqs = stdlib_lsame( jobz, 'S' ) wntqas = wntqa .or. wntqs wntqo = stdlib_lsame( jobz, 'O' ) wntqn = stdlib_lsame( jobz, 'N' ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) if( .not.( wntqa .or. wntqs .or. wntqo .or. wntqn ) ) then - info = -1 - else if( m<0 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( lda=n .and. ldvt=n .and. minmn>0 ) then - ! compute space needed for stdlib_dbdsdc + ! following subroutine, as returned by stdlib${ii}$_ilaenv. + if( info==0_${ik}$ ) then + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + bdspac = 0_${ik}$ + mnthr = int( minmn*11.0_dp / 6.0_dp,KIND=${ik}$) + if( m>=n .and. minmn>0_${ik}$ ) then + ! compute space needed for stdlib${ii}$_dbdsdc if( wntqn ) then - ! stdlib_dbdsdc needs only 4*n (or 6*n for uplo=l for lapack <= 3.6_dp) + ! stdlib${ii}$_dbdsdc needs only 4*n (or 6*n for uplo=l for lapack <= 3.6_dp) ! keep 7*n for backwards compatibility. - bdspac = 7*n + bdspac = 7_${ik}$*n else - bdspac = 3*n*n + 4*n + bdspac = 3_${ik}$*n*n + 4_${ik}$*n end if ! compute space preferred for each routine - call stdlib_dgebrd( m, n, dum(1), m, dum(1), dum(1), dum(1),dum(1), dum(1), -1, & + call stdlib${ii}$_dgebrd( m, n, dum(1_${ik}$), m, dum(1_${ik}$), dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, & ierr ) - lwork_dgebrd_mn = int( dum(1),KIND=ilp) - call stdlib_dgebrd( n, n, dum(1), n, dum(1), dum(1), dum(1),dum(1), dum(1), -1, & + lwork_dgebrd_mn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_dgebrd( n, n, dum(1_${ik}$), n, dum(1_${ik}$), dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, & ierr ) - lwork_dgebrd_nn = int( dum(1),KIND=ilp) - call stdlib_dgeqrf( m, n, dum(1), m, dum(1), dum(1), -1, ierr ) - lwork_dgeqrf_mn = int( dum(1),KIND=ilp) - call stdlib_dorgbr( 'Q', n, n, n, dum(1), n, dum(1), dum(1), -1,ierr ) - lwork_dorgbr_q_nn = int( dum(1),KIND=ilp) - call stdlib_dorgqr( m, m, n, dum(1), m, dum(1), dum(1), -1, ierr ) - lwork_dorgqr_mm = int( dum(1),KIND=ilp) - call stdlib_dorgqr( m, n, n, dum(1), m, dum(1), dum(1), -1, ierr ) - lwork_dorgqr_mn = int( dum(1),KIND=ilp) - call stdlib_dormbr( 'P', 'R', 'T', n, n, n, dum(1), n,dum(1), dum(1), n, dum(1), & - -1, ierr ) - lwork_dormbr_prt_nn = int( dum(1),KIND=ilp) - call stdlib_dormbr( 'Q', 'L', 'N', n, n, n, dum(1), n,dum(1), dum(1), n, dum(1), & - -1, ierr ) - lwork_dormbr_qln_nn = int( dum(1),KIND=ilp) - call stdlib_dormbr( 'Q', 'L', 'N', m, n, n, dum(1), m,dum(1), dum(1), m, dum(1), & - -1, ierr ) - lwork_dormbr_qln_mn = int( dum(1),KIND=ilp) - call stdlib_dormbr( 'Q', 'L', 'N', m, m, n, dum(1), m,dum(1), dum(1), m, dum(1), & - -1, ierr ) - lwork_dormbr_qln_mm = int( dum(1),KIND=ilp) + lwork_dgebrd_nn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_dgeqrf( m, n, dum(1_${ik}$), m, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_dgeqrf_mn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_dorgbr( 'Q', n, n, n, dum(1_${ik}$), n, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$,ierr ) + lwork_dorgbr_q_nn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_dorgqr( m, m, n, dum(1_${ik}$), m, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_dorgqr_mm = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_dorgqr( m, n, n, dum(1_${ik}$), m, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_dorgqr_mn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_dormbr( 'P', 'R', 'T', n, n, n, dum(1_${ik}$), n,dum(1_${ik}$), dum(1_${ik}$), n, dum(1_${ik}$), & + -1_${ik}$, ierr ) + lwork_dormbr_prt_nn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_dormbr( 'Q', 'L', 'N', n, n, n, dum(1_${ik}$), n,dum(1_${ik}$), dum(1_${ik}$), n, dum(1_${ik}$), & + -1_${ik}$, ierr ) + lwork_dormbr_qln_nn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_dormbr( 'Q', 'L', 'N', m, n, n, dum(1_${ik}$), m,dum(1_${ik}$), dum(1_${ik}$), m, dum(1_${ik}$), & + -1_${ik}$, ierr ) + lwork_dormbr_qln_mn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_dormbr( 'Q', 'L', 'N', m, m, n, dum(1_${ik}$), m,dum(1_${ik}$), dum(1_${ik}$), m, dum(1_${ik}$), & + -1_${ik}$, ierr ) + lwork_dormbr_qln_mm = int( dum(1_${ik}$),KIND=${ik}$) if( m>=mnthr ) then if( wntqn ) then ! path 1 (m >> n, jobz='n') wrkbl = n + lwork_dgeqrf_mn - wrkbl = max( wrkbl, 3*n + lwork_dgebrd_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dgebrd_nn ) maxwrk = max( wrkbl, bdspac + n ) minwrk = bdspac + n else if( wntqo ) then ! path 2 (m >> n, jobz='o') wrkbl = n + lwork_dgeqrf_mn wrkbl = max( wrkbl, n + lwork_dorgqr_mn ) - wrkbl = max( wrkbl, 3*n + lwork_dgebrd_nn ) - wrkbl = max( wrkbl, 3*n + lwork_dormbr_qln_nn ) - wrkbl = max( wrkbl, 3*n + lwork_dormbr_prt_nn ) - wrkbl = max( wrkbl, 3*n + bdspac ) - maxwrk = wrkbl + 2*n*n - minwrk = bdspac + 2*n*n + 3*n + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dgebrd_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dormbr_qln_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dormbr_prt_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + bdspac ) + maxwrk = wrkbl + 2_${ik}$*n*n + minwrk = bdspac + 2_${ik}$*n*n + 3_${ik}$*n else if( wntqs ) then ! path 3 (m >> n, jobz='s') wrkbl = n + lwork_dgeqrf_mn wrkbl = max( wrkbl, n + lwork_dorgqr_mn ) - wrkbl = max( wrkbl, 3*n + lwork_dgebrd_nn ) - wrkbl = max( wrkbl, 3*n + lwork_dormbr_qln_nn ) - wrkbl = max( wrkbl, 3*n + lwork_dormbr_prt_nn ) - wrkbl = max( wrkbl, 3*n + bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dgebrd_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dormbr_qln_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dormbr_prt_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + bdspac ) maxwrk = wrkbl + n*n - minwrk = bdspac + n*n + 3*n + minwrk = bdspac + n*n + 3_${ik}$*n else if( wntqa ) then ! path 4 (m >> n, jobz='a') wrkbl = n + lwork_dgeqrf_mn wrkbl = max( wrkbl, n + lwork_dorgqr_mm ) - wrkbl = max( wrkbl, 3*n + lwork_dgebrd_nn ) - wrkbl = max( wrkbl, 3*n + lwork_dormbr_qln_nn ) - wrkbl = max( wrkbl, 3*n + lwork_dormbr_prt_nn ) - wrkbl = max( wrkbl, 3*n + bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dgebrd_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dormbr_qln_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dormbr_prt_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + bdspac ) maxwrk = wrkbl + n*n - minwrk = n*n + max( 3*n + bdspac, n + m ) + minwrk = n*n + max( 3_${ik}$*n + bdspac, n + m ) end if else ! path 5 (m >= n, but not much larger) - wrkbl = 3*n + lwork_dgebrd_mn + wrkbl = 3_${ik}$*n + lwork_dgebrd_mn if( wntqn ) then ! path 5n (m >= n, jobz='n') - maxwrk = max( wrkbl, 3*n + bdspac ) - minwrk = 3*n + max( m, bdspac ) + maxwrk = max( wrkbl, 3_${ik}$*n + bdspac ) + minwrk = 3_${ik}$*n + max( m, bdspac ) else if( wntqo ) then ! path 5o (m >= n, jobz='o') - wrkbl = max( wrkbl, 3*n + lwork_dormbr_prt_nn ) - wrkbl = max( wrkbl, 3*n + lwork_dormbr_qln_mn ) - wrkbl = max( wrkbl, 3*n + bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dormbr_prt_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dormbr_qln_mn ) + wrkbl = max( wrkbl, 3_${ik}$*n + bdspac ) maxwrk = wrkbl + m*n - minwrk = 3*n + max( m, n*n + bdspac ) + minwrk = 3_${ik}$*n + max( m, n*n + bdspac ) else if( wntqs ) then ! path 5s (m >= n, jobz='s') - wrkbl = max( wrkbl, 3*n + lwork_dormbr_qln_mn ) - wrkbl = max( wrkbl, 3*n + lwork_dormbr_prt_nn ) - maxwrk = max( wrkbl, 3*n + bdspac ) - minwrk = 3*n + max( m, bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dormbr_qln_mn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dormbr_prt_nn ) + maxwrk = max( wrkbl, 3_${ik}$*n + bdspac ) + minwrk = 3_${ik}$*n + max( m, bdspac ) else if( wntqa ) then ! path 5a (m >= n, jobz='a') - wrkbl = max( wrkbl, 3*n + lwork_dormbr_qln_mm ) - wrkbl = max( wrkbl, 3*n + lwork_dormbr_prt_nn ) - maxwrk = max( wrkbl, 3*n + bdspac ) - minwrk = 3*n + max( m, bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dormbr_qln_mm ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dormbr_prt_nn ) + maxwrk = max( wrkbl, 3_${ik}$*n + bdspac ) + minwrk = 3_${ik}$*n + max( m, bdspac ) end if end if - else if( minmn>0 ) then - ! compute space needed for stdlib_dbdsdc + else if( minmn>0_${ik}$ ) then + ! compute space needed for stdlib${ii}$_dbdsdc if( wntqn ) then - ! stdlib_dbdsdc needs only 4*n (or 6*n for uplo=l for lapack <= 3.6_dp) + ! stdlib${ii}$_dbdsdc needs only 4*n (or 6*n for uplo=l for lapack <= 3.6_dp) ! keep 7*n for backwards compatibility. - bdspac = 7*m + bdspac = 7_${ik}$*m else - bdspac = 3*m*m + 4*m + bdspac = 3_${ik}$*m*m + 4_${ik}$*m end if ! compute space preferred for each routine - call stdlib_dgebrd( m, n, dum(1), m, dum(1), dum(1), dum(1),dum(1), dum(1), -1, & + call stdlib${ii}$_dgebrd( m, n, dum(1_${ik}$), m, dum(1_${ik}$), dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, & ierr ) - lwork_dgebrd_mn = int( dum(1),KIND=ilp) - call stdlib_dgebrd( m, m, a, m, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) + lwork_dgebrd_mn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_dgebrd( m, m, a, m, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) - lwork_dgebrd_mm = int( dum(1),KIND=ilp) - call stdlib_dgelqf( m, n, a, m, dum(1), dum(1), -1, ierr ) - lwork_dgelqf_mn = int( dum(1),KIND=ilp) - call stdlib_dorglq( n, n, m, dum(1), n, dum(1), dum(1), -1, ierr ) - lwork_dorglq_nn = int( dum(1),KIND=ilp) - call stdlib_dorglq( m, n, m, a, m, dum(1), dum(1), -1, ierr ) - lwork_dorglq_mn = int( dum(1),KIND=ilp) - call stdlib_dorgbr( 'P', m, m, m, a, n, dum(1), dum(1), -1, ierr ) - lwork_dorgbr_p_mm = int( dum(1),KIND=ilp) - call stdlib_dormbr( 'P', 'R', 'T', m, m, m, dum(1), m,dum(1), dum(1), m, dum(1), & - -1, ierr ) - lwork_dormbr_prt_mm = int( dum(1),KIND=ilp) - call stdlib_dormbr( 'P', 'R', 'T', m, n, m, dum(1), m,dum(1), dum(1), m, dum(1), & - -1, ierr ) - lwork_dormbr_prt_mn = int( dum(1),KIND=ilp) - call stdlib_dormbr( 'P', 'R', 'T', n, n, m, dum(1), n,dum(1), dum(1), n, dum(1), & - -1, ierr ) - lwork_dormbr_prt_nn = int( dum(1),KIND=ilp) - call stdlib_dormbr( 'Q', 'L', 'N', m, m, m, dum(1), m,dum(1), dum(1), m, dum(1), & - -1, ierr ) - lwork_dormbr_qln_mm = int( dum(1),KIND=ilp) + lwork_dgebrd_mm = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_dgelqf( m, n, a, m, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_dgelqf_mn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_dorglq( n, n, m, dum(1_${ik}$), n, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_dorglq_nn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_dorglq( m, n, m, a, m, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_dorglq_mn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_dorgbr( 'P', m, m, m, a, n, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_dorgbr_p_mm = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_dormbr( 'P', 'R', 'T', m, m, m, dum(1_${ik}$), m,dum(1_${ik}$), dum(1_${ik}$), m, dum(1_${ik}$), & + -1_${ik}$, ierr ) + lwork_dormbr_prt_mm = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_dormbr( 'P', 'R', 'T', m, n, m, dum(1_${ik}$), m,dum(1_${ik}$), dum(1_${ik}$), m, dum(1_${ik}$), & + -1_${ik}$, ierr ) + lwork_dormbr_prt_mn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_dormbr( 'P', 'R', 'T', n, n, m, dum(1_${ik}$), n,dum(1_${ik}$), dum(1_${ik}$), n, dum(1_${ik}$), & + -1_${ik}$, ierr ) + lwork_dormbr_prt_nn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_dormbr( 'Q', 'L', 'N', m, m, m, dum(1_${ik}$), m,dum(1_${ik}$), dum(1_${ik}$), m, dum(1_${ik}$), & + -1_${ik}$, ierr ) + lwork_dormbr_qln_mm = int( dum(1_${ik}$),KIND=${ik}$) if( n>=mnthr ) then if( wntqn ) then ! path 1t (n >> m, jobz='n') wrkbl = m + lwork_dgelqf_mn - wrkbl = max( wrkbl, 3*m + lwork_dgebrd_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dgebrd_mm ) maxwrk = max( wrkbl, bdspac + m ) minwrk = bdspac + m else if( wntqo ) then ! path 2t (n >> m, jobz='o') wrkbl = m + lwork_dgelqf_mn wrkbl = max( wrkbl, m + lwork_dorglq_mn ) - wrkbl = max( wrkbl, 3*m + lwork_dgebrd_mm ) - wrkbl = max( wrkbl, 3*m + lwork_dormbr_qln_mm ) - wrkbl = max( wrkbl, 3*m + lwork_dormbr_prt_mm ) - wrkbl = max( wrkbl, 3*m + bdspac ) - maxwrk = wrkbl + 2*m*m - minwrk = bdspac + 2*m*m + 3*m + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dgebrd_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dormbr_qln_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dormbr_prt_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + bdspac ) + maxwrk = wrkbl + 2_${ik}$*m*m + minwrk = bdspac + 2_${ik}$*m*m + 3_${ik}$*m else if( wntqs ) then ! path 3t (n >> m, jobz='s') wrkbl = m + lwork_dgelqf_mn wrkbl = max( wrkbl, m + lwork_dorglq_mn ) - wrkbl = max( wrkbl, 3*m + lwork_dgebrd_mm ) - wrkbl = max( wrkbl, 3*m + lwork_dormbr_qln_mm ) - wrkbl = max( wrkbl, 3*m + lwork_dormbr_prt_mm ) - wrkbl = max( wrkbl, 3*m + bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dgebrd_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dormbr_qln_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dormbr_prt_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + bdspac ) maxwrk = wrkbl + m*m - minwrk = bdspac + m*m + 3*m + minwrk = bdspac + m*m + 3_${ik}$*m else if( wntqa ) then ! path 4t (n >> m, jobz='a') wrkbl = m + lwork_dgelqf_mn wrkbl = max( wrkbl, m + lwork_dorglq_nn ) - wrkbl = max( wrkbl, 3*m + lwork_dgebrd_mm ) - wrkbl = max( wrkbl, 3*m + lwork_dormbr_qln_mm ) - wrkbl = max( wrkbl, 3*m + lwork_dormbr_prt_mm ) - wrkbl = max( wrkbl, 3*m + bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dgebrd_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dormbr_qln_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dormbr_prt_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + bdspac ) maxwrk = wrkbl + m*m - minwrk = m*m + max( 3*m + bdspac, m + n ) + minwrk = m*m + max( 3_${ik}$*m + bdspac, m + n ) end if else ! path 5t (n > m, but not much larger) - wrkbl = 3*m + lwork_dgebrd_mn + wrkbl = 3_${ik}$*m + lwork_dgebrd_mn if( wntqn ) then ! path 5tn (n > m, jobz='n') - maxwrk = max( wrkbl, 3*m + bdspac ) - minwrk = 3*m + max( n, bdspac ) + maxwrk = max( wrkbl, 3_${ik}$*m + bdspac ) + minwrk = 3_${ik}$*m + max( n, bdspac ) else if( wntqo ) then ! path 5to (n > m, jobz='o') - wrkbl = max( wrkbl, 3*m + lwork_dormbr_qln_mm ) - wrkbl = max( wrkbl, 3*m + lwork_dormbr_prt_mn ) - wrkbl = max( wrkbl, 3*m + bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dormbr_qln_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dormbr_prt_mn ) + wrkbl = max( wrkbl, 3_${ik}$*m + bdspac ) maxwrk = wrkbl + m*n - minwrk = 3*m + max( n, m*m + bdspac ) + minwrk = 3_${ik}$*m + max( n, m*m + bdspac ) else if( wntqs ) then ! path 5ts (n > m, jobz='s') - wrkbl = max( wrkbl, 3*m + lwork_dormbr_qln_mm ) - wrkbl = max( wrkbl, 3*m + lwork_dormbr_prt_mn ) - maxwrk = max( wrkbl, 3*m + bdspac ) - minwrk = 3*m + max( n, bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dormbr_qln_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dormbr_prt_mn ) + maxwrk = max( wrkbl, 3_${ik}$*m + bdspac ) + minwrk = 3_${ik}$*m + max( n, bdspac ) else if( wntqa ) then ! path 5ta (n > m, jobz='a') - wrkbl = max( wrkbl, 3*m + lwork_dormbr_qln_mm ) - wrkbl = max( wrkbl, 3*m + lwork_dormbr_prt_nn ) - maxwrk = max( wrkbl, 3*m + bdspac ) - minwrk = 3*m + max( n, bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dormbr_qln_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dormbr_prt_nn ) + maxwrk = max( wrkbl, 3_${ik}$*m + bdspac ) + minwrk = 3_${ik}$*m + max( n, bdspac ) end if end if end if maxwrk = max( maxwrk, minwrk ) - work( 1 ) = stdlib_droundup_lwork( maxwrk ) + work( 1_${ik}$ ) = stdlib${ii}$_droundup_lwork( maxwrk ) if( lworkzero .and. anrmbignum ) then - iscl = 1 - call stdlib_dlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, ierr ) + iscl = 1_${ik}$ + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, ierr ) end if if( m>=n ) then ! a has at least as many rows as columns. if a has sufficiently @@ -75367,55 +75361,55 @@ module stdlib_linalg_lapack_d if( wntqn ) then ! path 1 (m >> n, jobz='n') ! no singular vectors to be computed - itau = 1 + itau = 1_${ik}$ nwork = itau + n ! compute a=q*r ! workspace: need n [tau] + n [work] ! workspace: prefer n [tau] + n*nb [work] - call stdlib_dgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & - 1, ierr ) + call stdlib${ii}$_dgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + 1_${ik}$, ierr ) ! zero out below r - if (n>1) call stdlib_dlaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) - ie = 1 + if (n>1_${ik}$) call stdlib${ii}$_dlaset( 'L', n-1, n-1, zero, zero, a( 2_${ik}$, 1_${ik}$ ), lda ) + ie = 1_${ik}$ itauq = ie + n itaup = itauq + n nwork = itaup + n ! bidiagonalize r in a ! workspace: need 3*n [e, tauq, taup] + n [work] ! workspace: prefer 3*n [e, tauq, taup] + 2*n*nb [work] - call stdlib_dgebrd( n, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_dgebrd( n, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) nwork = ie + n ! perform bidiagonal svd, computing singular values only ! workspace: need n [e] + bdspac - call stdlib_dbdsdc( 'U', 'N', n, s, work( ie ), dum, 1, dum, 1,dum, idum, & + call stdlib${ii}$_dbdsdc( 'U', 'N', n, s, work( ie ), dum, 1_${ik}$, dum, 1_${ik}$,dum, idum, & work( nwork ), iwork, info ) else if( wntqo ) then ! path 2 (m >> n, jobz = 'o') ! n left singular vectors to be overwritten on a and ! n right singular vectors to be computed in vt - ir = 1 + ir = 1_${ik}$ ! work(ir) is ldwrkr by n - if( lwork >= lda*n + n*n + 3*n + bdspac ) then + if( lwork >= lda*n + n*n + 3_${ik}$*n + bdspac ) then ldwrkr = lda else - ldwrkr = ( lwork - n*n - 3*n - bdspac ) / n + ldwrkr = ( lwork - n*n - 3_${ik}$*n - bdspac ) / n end if itau = ir + ldwrkr*n nwork = itau + n ! compute a=q*r ! workspace: need n*n [r] + n [tau] + n [work] ! workspace: prefer n*n [r] + n [tau] + n*nb [work] - call stdlib_dgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & - 1, ierr ) + call stdlib${ii}$_dgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + 1_${ik}$, ierr ) ! copy r to work(ir), zeroing out below it - call stdlib_dlacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) - call stdlib_dlaset( 'L', n - 1, n - 1, zero, zero, work(ir+1),ldwrkr ) + call stdlib${ii}$_dlacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) + call stdlib${ii}$_dlaset( 'L', n - 1_${ik}$, n - 1_${ik}$, zero, zero, work(ir+1),ldwrkr ) ! generate q in a ! workspace: need n*n [r] + n [tau] + n [work] ! workspace: prefer n*n [r] + n [tau] + n*nb [work] - call stdlib_dorgqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork - & - nwork + 1, ierr ) + call stdlib${ii}$_dorgqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork - & + nwork + 1_${ik}$, ierr ) ie = itau itauq = ie + n itaup = itauq + n @@ -75423,8 +75417,8 @@ module stdlib_linalg_lapack_d ! bidiagonalize r in work(ir) ! workspace: need n*n [r] + 3*n [e, tauq, taup] + n [work] ! workspace: prefer n*n [r] + 3*n [e, tauq, taup] + 2*n*nb [work] - call stdlib_dgebrd( n, n, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & - work( itaup ), work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_dgebrd( n, n, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & + work( itaup ), work( nwork ),lwork - nwork + 1_${ik}$, ierr ) ! work(iu) is n by n iu = nwork nwork = iu + n*n @@ -75432,32 +75426,32 @@ module stdlib_linalg_lapack_d ! of bidiagonal matrix in work(iu) and computing right ! singular vectors of bidiagonal matrix in vt ! workspace: need n*n [r] + 3*n [e, tauq, taup] + n*n [u] + bdspac - call stdlib_dbdsdc( 'U', 'I', n, s, work( ie ), work( iu ), n,vt, ldvt, dum, & + call stdlib${ii}$_dbdsdc( 'U', 'I', n, s, work( ie ), work( iu ), n,vt, ldvt, dum, & idum, work( nwork ), iwork,info ) ! overwrite work(iu) by left singular vectors of r ! and vt by right singular vectors of r ! workspace: need n*n [r] + 3*n [e, tauq, taup] + n*n [u] + n [work] ! workspace: prefer n*n [r] + 3*n [e, tauq, taup] + n*n [u] + n*nb [work] - call stdlib_dormbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & - work( iu ), n, work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_dormbr( 'P', 'R', 'T', n, n, n, work( ir ), ldwrkr,work( itaup ), & - vt, ldvt, work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_dormbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & + work( iu ), n, work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_dormbr( 'P', 'R', 'T', n, n, n, work( ir ), ldwrkr,work( itaup ), & + vt, ldvt, work( nwork ),lwork - nwork + 1_${ik}$, ierr ) ! multiply q in a by left singular vectors of r in ! work(iu), storing result in work(ir) and copying to a ! workspace: need n*n [r] + 3*n [e, tauq, taup] + n*n [u] ! workspace: prefer m*n [r] + 3*n [e, tauq, taup] + n*n [u] do i = 1, m, ldwrkr - chunk = min( m - i + 1, ldwrkr ) - call stdlib_dgemm( 'N', 'N', chunk, n, n, one, a( i, 1 ),lda, work( iu ), & + chunk = min( m - i + 1_${ik}$, ldwrkr ) + call stdlib${ii}$_dgemm( 'N', 'N', chunk, n, n, one, a( i, 1_${ik}$ ),lda, work( iu ), & n, zero, work( ir ),ldwrkr ) - call stdlib_dlacpy( 'F', chunk, n, work( ir ), ldwrkr,a( i, 1 ), lda ) + call stdlib${ii}$_dlacpy( 'F', chunk, n, work( ir ), ldwrkr,a( i, 1_${ik}$ ), lda ) end do else if( wntqs ) then ! path 3 (m >> n, jobz='s') ! n left singular vectors to be computed in u and ! n right singular vectors to be computed in vt - ir = 1 + ir = 1_${ik}$ ! work(ir) is n by n ldwrkr = n itau = ir + ldwrkr*n @@ -75465,16 +75459,16 @@ module stdlib_linalg_lapack_d ! compute a=q*r ! workspace: need n*n [r] + n [tau] + n [work] ! workspace: prefer n*n [r] + n [tau] + n*nb [work] - call stdlib_dgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & - 1, ierr ) + call stdlib${ii}$_dgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + 1_${ik}$, ierr ) ! copy r to work(ir), zeroing out below it - call stdlib_dlacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) - call stdlib_dlaset( 'L', n - 1, n - 1, zero, zero, work(ir+1),ldwrkr ) + call stdlib${ii}$_dlacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) + call stdlib${ii}$_dlaset( 'L', n - 1_${ik}$, n - 1_${ik}$, zero, zero, work(ir+1),ldwrkr ) ! generate q in a ! workspace: need n*n [r] + n [tau] + n [work] ! workspace: prefer n*n [r] + n [tau] + n*nb [work] - call stdlib_dorgqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork - & - nwork + 1, ierr ) + call stdlib${ii}$_dorgqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork - & + nwork + 1_${ik}$, ierr ) ie = itau itauq = ie + n itaup = itauq + n @@ -75482,33 +75476,33 @@ module stdlib_linalg_lapack_d ! bidiagonalize r in work(ir) ! workspace: need n*n [r] + 3*n [e, tauq, taup] + n [work] ! workspace: prefer n*n [r] + 3*n [e, tauq, taup] + 2*n*nb [work] - call stdlib_dgebrd( n, n, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & - work( itaup ), work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_dgebrd( n, n, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & + work( itaup ), work( nwork ),lwork - nwork + 1_${ik}$, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagoal matrix in u and computing right singular ! vectors of bidiagonal matrix in vt ! workspace: need n*n [r] + 3*n [e, tauq, taup] + bdspac - call stdlib_dbdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & + call stdlib${ii}$_dbdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & work( nwork ), iwork,info ) ! overwrite u by left singular vectors of r and vt ! by right singular vectors of r ! workspace: need n*n [r] + 3*n [e, tauq, taup] + n [work] ! workspace: prefer n*n [r] + 3*n [e, tauq, taup] + n*nb [work] - call stdlib_dormbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & - u, ldu, work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_dormbr( 'P', 'R', 'T', n, n, n, work( ir ), ldwrkr,work( itaup ), & - vt, ldvt, work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_dormbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & + u, ldu, work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_dormbr( 'P', 'R', 'T', n, n, n, work( ir ), ldwrkr,work( itaup ), & + vt, ldvt, work( nwork ),lwork - nwork + 1_${ik}$, ierr ) ! multiply q in a by left singular vectors of r in ! work(ir), storing result in u ! workspace: need n*n [r] - call stdlib_dlacpy( 'F', n, n, u, ldu, work( ir ), ldwrkr ) - call stdlib_dgemm( 'N', 'N', m, n, n, one, a, lda, work( ir ),ldwrkr, zero, u,& + call stdlib${ii}$_dlacpy( 'F', n, n, u, ldu, work( ir ), ldwrkr ) + call stdlib${ii}$_dgemm( 'N', 'N', m, n, n, one, a, lda, work( ir ),ldwrkr, zero, u,& ldu ) else if( wntqa ) then ! path 4 (m >> n, jobz='a') ! m left singular vectors to be computed in u and ! n right singular vectors to be computed in vt - iu = 1 + iu = 1_${ik}$ ! work(iu) is n by n ldwrku = n itau = iu + ldwrku*n @@ -75516,16 +75510,16 @@ module stdlib_linalg_lapack_d ! compute a=q*r, copying result to u ! workspace: need n*n [u] + n [tau] + n [work] ! workspace: prefer n*n [u] + n [tau] + n*nb [work] - call stdlib_dgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & - 1, ierr ) - call stdlib_dlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_dgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + 1_${ik}$, ierr ) + call stdlib${ii}$_dlacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! workspace: need n*n [u] + n [tau] + m [work] ! workspace: prefer n*n [u] + n [tau] + m*nb [work] - call stdlib_dorgqr( m, m, n, u, ldu, work( itau ),work( nwork ), lwork - & - nwork + 1, ierr ) + call stdlib${ii}$_dorgqr( m, m, n, u, ldu, work( itau ),work( nwork ), lwork - & + nwork + 1_${ik}$, ierr ) ! produce r in a, zeroing out other entries - if (n>1) call stdlib_dlaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) + if (n>1_${ik}$) call stdlib${ii}$_dlaset( 'L', n-1, n-1, zero, zero, a( 2_${ik}$, 1_${ik}$ ), lda ) ie = itau itauq = ie + n itaup = itauq + n @@ -75533,105 +75527,105 @@ module stdlib_linalg_lapack_d ! bidiagonalize r in a ! workspace: need n*n [u] + 3*n [e, tauq, taup] + n [work] ! workspace: prefer n*n [u] + 3*n [e, tauq, taup] + 2*n*nb [work] - call stdlib_dgebrd( n, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_dgebrd( n, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in work(iu) and computing right ! singular vectors of bidiagonal matrix in vt ! workspace: need n*n [u] + 3*n [e, tauq, taup] + bdspac - call stdlib_dbdsdc( 'U', 'I', n, s, work( ie ), work( iu ), n,vt, ldvt, dum, & + call stdlib${ii}$_dbdsdc( 'U', 'I', n, s, work( ie ), work( iu ), n,vt, ldvt, dum, & idum, work( nwork ), iwork,info ) ! overwrite work(iu) by left singular vectors of r and vt ! by right singular vectors of r ! workspace: need n*n [u] + 3*n [e, tauq, taup] + n [work] ! workspace: prefer n*n [u] + 3*n [e, tauq, taup] + n*nb [work] - call stdlib_dormbr( 'Q', 'L', 'N', n, n, n, a, lda,work( itauq ), work( iu ), & - ldwrku,work( nwork ), lwork - nwork + 1, ierr ) - call stdlib_dormbr( 'P', 'R', 'T', n, n, n, a, lda,work( itaup ), vt, ldvt, & - work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_dormbr( 'Q', 'L', 'N', n, n, n, a, lda,work( itauq ), work( iu ), & + ldwrku,work( nwork ), lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_dormbr( 'P', 'R', 'T', n, n, n, a, lda,work( itaup ), vt, ldvt, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) ! multiply q in u by left singular vectors of r in ! work(iu), storing result in a ! workspace: need n*n [u] - call stdlib_dgemm( 'N', 'N', m, n, n, one, u, ldu, work( iu ),ldwrku, zero, a,& + call stdlib${ii}$_dgemm( 'N', 'N', m, n, n, one, u, ldu, work( iu ),ldwrku, zero, a,& lda ) ! copy left singular vectors of a from a to u - call stdlib_dlacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_dlacpy( 'F', m, n, a, lda, u, ldu ) end if else ! m < mnthr ! path 5 (m >= n, but not much larger) ! reduce to bidiagonal form without qr decomposition - ie = 1 + ie = 1_${ik}$ itauq = ie + n itaup = itauq + n nwork = itaup + n ! bidiagonalize a ! workspace: need 3*n [e, tauq, taup] + m [work] ! workspace: prefer 3*n [e, tauq, taup] + (m+n)*nb [work] - call stdlib_dgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_dgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) if( wntqn ) then ! path 5n (m >= n, jobz='n') ! perform bidiagonal svd, only computing singular values ! workspace: need 3*n [e, tauq, taup] + bdspac - call stdlib_dbdsdc( 'U', 'N', n, s, work( ie ), dum, 1, dum, 1,dum, idum, & + call stdlib${ii}$_dbdsdc( 'U', 'N', n, s, work( ie ), dum, 1_${ik}$, dum, 1_${ik}$,dum, idum, & work( nwork ), iwork, info ) else if( wntqo ) then ! path 5o (m >= n, jobz='o') iu = nwork - if( lwork >= m*n + 3*n + bdspac ) then + if( lwork >= m*n + 3_${ik}$*n + bdspac ) then ! work( iu ) is m by n ldwrku = m nwork = iu + ldwrku*n - call stdlib_dlaset( 'F', m, n, zero, zero, work( iu ),ldwrku ) + call stdlib${ii}$_dlaset( 'F', m, n, zero, zero, work( iu ),ldwrku ) ! ir is unused; silence compile warnings - ir = -1 + ir = -1_${ik}$ else ! work( iu ) is n by n ldwrku = n nwork = iu + ldwrku*n ! work(ir) is ldwrkr by n ir = nwork - ldwrkr = ( lwork - n*n - 3*n ) / n + ldwrkr = ( lwork - n*n - 3_${ik}$*n ) / n end if nwork = iu + ldwrku*n ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in work(iu) and computing right ! singular vectors of bidiagonal matrix in vt ! workspace: need 3*n [e, tauq, taup] + n*n [u] + bdspac - call stdlib_dbdsdc( 'U', 'I', n, s, work( ie ), work( iu ),ldwrku, vt, ldvt, & + call stdlib${ii}$_dbdsdc( 'U', 'I', n, s, work( ie ), work( iu ),ldwrku, vt, ldvt, & dum, idum, work( nwork ),iwork, info ) ! overwrite vt by right singular vectors of a ! workspace: need 3*n [e, tauq, taup] + n*n [u] + n [work] ! workspace: prefer 3*n [e, tauq, taup] + n*n [u] + n*nb [work] - call stdlib_dormbr( 'P', 'R', 'T', n, n, n, a, lda,work( itaup ), vt, ldvt, & - work( nwork ),lwork - nwork + 1, ierr ) - if( lwork >= m*n + 3*n + bdspac ) then + call stdlib${ii}$_dormbr( 'P', 'R', 'T', n, n, n, a, lda,work( itaup ), vt, ldvt, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + if( lwork >= m*n + 3_${ik}$*n + bdspac ) then ! path 5o-fast ! overwrite work(iu) by left singular vectors of a ! workspace: need 3*n [e, tauq, taup] + m*n [u] + n [work] ! workspace: prefer 3*n [e, tauq, taup] + m*n [u] + n*nb [work] - call stdlib_dormbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), work( iu & - ), ldwrku,work( nwork ), lwork - nwork + 1, ierr ) + call stdlib${ii}$_dormbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), work( iu & + ), ldwrku,work( nwork ), lwork - nwork + 1_${ik}$, ierr ) ! copy left singular vectors of a from work(iu) to a - call stdlib_dlacpy( 'F', m, n, work( iu ), ldwrku, a, lda ) + call stdlib${ii}$_dlacpy( 'F', m, n, work( iu ), ldwrku, a, lda ) else ! path 5o-slow ! generate q in a ! workspace: need 3*n [e, tauq, taup] + n*n [u] + n [work] ! workspace: prefer 3*n [e, tauq, taup] + n*n [u] + n*nb [work] - call stdlib_dorgbr( 'Q', m, n, n, a, lda, work( itauq ),work( nwork ), & - lwork - nwork + 1, ierr ) + call stdlib${ii}$_dorgbr( 'Q', m, n, n, a, lda, work( itauq ),work( nwork ), & + lwork - nwork + 1_${ik}$, ierr ) ! multiply q in a by left singular vectors of ! bidiagonal matrix in work(iu), storing result in ! work(ir) and copying to a ! workspace: need 3*n [e, tauq, taup] + n*n [u] + nb*n [r] ! workspace: prefer 3*n [e, tauq, taup] + n*n [u] + m*n [r] do i = 1, m, ldwrkr - chunk = min( m - i + 1, ldwrkr ) - call stdlib_dgemm( 'N', 'N', chunk, n, n, one, a( i, 1 ),lda, work( iu )& + chunk = min( m - i + 1_${ik}$, ldwrkr ) + call stdlib${ii}$_dgemm( 'N', 'N', chunk, n, n, one, a( i, 1_${ik}$ ),lda, work( iu )& , ldwrku, zero,work( ir ), ldwrkr ) - call stdlib_dlacpy( 'F', chunk, n, work( ir ), ldwrkr,a( i, 1 ), lda ) + call stdlib${ii}$_dlacpy( 'F', chunk, n, work( ir ), ldwrkr,a( i, 1_${ik}$ ), lda ) end do end if @@ -75641,38 +75635,38 @@ module stdlib_linalg_lapack_d ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in vt ! workspace: need 3*n [e, tauq, taup] + bdspac - call stdlib_dlaset( 'F', m, n, zero, zero, u, ldu ) - call stdlib_dbdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & + call stdlib${ii}$_dlaset( 'F', m, n, zero, zero, u, ldu ) + call stdlib${ii}$_dbdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & work( nwork ), iwork,info ) ! overwrite u by left singular vectors of a and vt ! by right singular vectors of a ! workspace: need 3*n [e, tauq, taup] + n [work] ! workspace: prefer 3*n [e, tauq, taup] + n*nb [work] - call stdlib_dormbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), u, ldu, & - work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_dormbr( 'P', 'R', 'T', n, n, n, a, lda,work( itaup ), vt, ldvt, & - work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_dormbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), u, ldu, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_dormbr( 'P', 'R', 'T', n, n, n, a, lda,work( itaup ), vt, ldvt, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) else if( wntqa ) then ! path 5a (m >= n, jobz='a') ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in vt ! workspace: need 3*n [e, tauq, taup] + bdspac - call stdlib_dlaset( 'F', m, m, zero, zero, u, ldu ) - call stdlib_dbdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & + call stdlib${ii}$_dlaset( 'F', m, m, zero, zero, u, ldu ) + call stdlib${ii}$_dbdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & work( nwork ), iwork,info ) ! set the right corner of u to identity matrix if( m>n ) then - call stdlib_dlaset( 'F', m - n, m - n, zero, one, u(n+1,n+1),ldu ) + call stdlib${ii}$_dlaset( 'F', m - n, m - n, zero, one, u(n+1,n+1),ldu ) end if ! overwrite u by left singular vectors of a and vt ! by right singular vectors of a ! workspace: need 3*n [e, tauq, taup] + m [work] ! workspace: prefer 3*n [e, tauq, taup] + m*nb [work] - call stdlib_dormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & - work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_dormbr( 'P', 'R', 'T', n, n, m, a, lda,work( itaup ), vt, ldvt, & - work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_dormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_dormbr( 'P', 'R', 'T', n, n, m, a, lda,work( itaup ), vt, ldvt, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) end if end if else @@ -75683,38 +75677,38 @@ module stdlib_linalg_lapack_d if( wntqn ) then ! path 1t (n >> m, jobz='n') ! no singular vectors to be computed - itau = 1 + itau = 1_${ik}$ nwork = itau + m ! compute a=l*q ! workspace: need m [tau] + m [work] ! workspace: prefer m [tau] + m*nb [work] - call stdlib_dgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & - 1, ierr ) + call stdlib${ii}$_dgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + 1_${ik}$, ierr ) ! zero out above l - if (m>1) call stdlib_dlaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ), lda ) - ie = 1 + if (m>1_${ik}$) call stdlib${ii}$_dlaset( 'U', m-1, m-1, zero, zero, a( 1_${ik}$, 2_${ik}$ ), lda ) + ie = 1_${ik}$ itauq = ie + m itaup = itauq + m nwork = itaup + m ! bidiagonalize l in a ! workspace: need 3*m [e, tauq, taup] + m [work] ! workspace: prefer 3*m [e, tauq, taup] + 2*m*nb [work] - call stdlib_dgebrd( m, m, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_dgebrd( m, m, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) nwork = ie + m ! perform bidiagonal svd, computing singular values only ! workspace: need m [e] + bdspac - call stdlib_dbdsdc( 'U', 'N', m, s, work( ie ), dum, 1, dum, 1,dum, idum, & + call stdlib${ii}$_dbdsdc( 'U', 'N', m, s, work( ie ), dum, 1_${ik}$, dum, 1_${ik}$,dum, idum, & work( nwork ), iwork, info ) else if( wntqo ) then ! path 2t (n >> m, jobz='o') ! m right singular vectors to be overwritten on a and ! m left singular vectors to be computed in u - ivt = 1 + ivt = 1_${ik}$ ! work(ivt) is m by m ! work(il) is m by m; it is later resized to m by chunk for gemm il = ivt + m*m - if( lwork >= m*n + m*m + 3*m + bdspac ) then + if( lwork >= m*n + m*m + 3_${ik}$*m + bdspac ) then ldwrkl = m chunk = n else @@ -75726,17 +75720,17 @@ module stdlib_linalg_lapack_d ! compute a=l*q ! workspace: need m*m [vt] + m*m [l] + m [tau] + m [work] ! workspace: prefer m*m [vt] + m*m [l] + m [tau] + m*nb [work] - call stdlib_dgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & - 1, ierr ) + call stdlib${ii}$_dgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + 1_${ik}$, ierr ) ! copy l to work(il), zeroing about above it - call stdlib_dlacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) - call stdlib_dlaset( 'U', m - 1, m - 1, zero, zero,work( il + ldwrkl ), ldwrkl & + call stdlib${ii}$_dlacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) + call stdlib${ii}$_dlaset( 'U', m - 1_${ik}$, m - 1_${ik}$, zero, zero,work( il + ldwrkl ), ldwrkl & ) ! generate q in a ! workspace: need m*m [vt] + m*m [l] + m [tau] + m [work] ! workspace: prefer m*m [vt] + m*m [l] + m [tau] + m*nb [work] - call stdlib_dorglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork - & - nwork + 1, ierr ) + call stdlib${ii}$_dorglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork - & + nwork + 1_${ik}$, ierr ) ie = itau itauq = ie + m itaup = itauq + m @@ -75744,39 +75738,39 @@ module stdlib_linalg_lapack_d ! bidiagonalize l in work(il) ! workspace: need m*m [vt] + m*m [l] + 3*m [e, tauq, taup] + m [work] ! workspace: prefer m*m [vt] + m*m [l] + 3*m [e, tauq, taup] + 2*m*nb [work] - call stdlib_dgebrd( m, m, work( il ), ldwrkl, s, work( ie ),work( itauq ), & - work( itaup ), work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_dgebrd( m, m, work( il ), ldwrkl, s, work( ie ),work( itauq ), & + work( itaup ), work( nwork ),lwork - nwork + 1_${ik}$, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in u, and computing right singular ! vectors of bidiagonal matrix in work(ivt) ! workspace: need m*m [vt] + m*m [l] + 3*m [e, tauq, taup] + bdspac - call stdlib_dbdsdc( 'U', 'I', m, s, work( ie ), u, ldu,work( ivt ), m, dum, & + call stdlib${ii}$_dbdsdc( 'U', 'I', m, s, work( ie ), u, ldu,work( ivt ), m, dum, & idum, work( nwork ),iwork, info ) ! overwrite u by left singular vectors of l and work(ivt) ! by right singular vectors of l ! workspace: need m*m [vt] + m*m [l] + 3*m [e, tauq, taup] + m [work] ! workspace: prefer m*m [vt] + m*m [l] + 3*m [e, tauq, taup] + m*nb [work] - call stdlib_dormbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & - u, ldu, work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_dormbr( 'P', 'R', 'T', m, m, m, work( il ), ldwrkl,work( itaup ), & - work( ivt ), m,work( nwork ), lwork - nwork + 1, ierr ) + call stdlib${ii}$_dormbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & + u, ldu, work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_dormbr( 'P', 'R', 'T', m, m, m, work( il ), ldwrkl,work( itaup ), & + work( ivt ), m,work( nwork ), lwork - nwork + 1_${ik}$, ierr ) ! multiply right singular vectors of l in work(ivt) by q ! in a, storing result in work(il) and copying to a ! workspace: need m*m [vt] + m*m [l] ! workspace: prefer m*m [vt] + m*n [l] ! at this point, l is resized as m by chunk. do i = 1, n, chunk - blk = min( n - i + 1, chunk ) - call stdlib_dgemm( 'N', 'N', m, blk, m, one, work( ivt ), m,a( 1, i ), lda,& + blk = min( n - i + 1_${ik}$, chunk ) + call stdlib${ii}$_dgemm( 'N', 'N', m, blk, m, one, work( ivt ), m,a( 1_${ik}$, i ), lda,& zero, work( il ), ldwrkl ) - call stdlib_dlacpy( 'F', m, blk, work( il ), ldwrkl,a( 1, i ), lda ) + call stdlib${ii}$_dlacpy( 'F', m, blk, work( il ), ldwrkl,a( 1_${ik}$, i ), lda ) end do else if( wntqs ) then ! path 3t (n >> m, jobz='s') ! m right singular vectors to be computed in vt and ! m left singular vectors to be computed in u - il = 1 + il = 1_${ik}$ ! work(il) is m by m ldwrkl = m itau = il + ldwrkl*m @@ -75784,17 +75778,17 @@ module stdlib_linalg_lapack_d ! compute a=l*q ! workspace: need m*m [l] + m [tau] + m [work] ! workspace: prefer m*m [l] + m [tau] + m*nb [work] - call stdlib_dgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & - 1, ierr ) + call stdlib${ii}$_dgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + 1_${ik}$, ierr ) ! copy l to work(il), zeroing out above it - call stdlib_dlacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) - call stdlib_dlaset( 'U', m - 1, m - 1, zero, zero,work( il + ldwrkl ), ldwrkl & + call stdlib${ii}$_dlacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) + call stdlib${ii}$_dlaset( 'U', m - 1_${ik}$, m - 1_${ik}$, zero, zero,work( il + ldwrkl ), ldwrkl & ) ! generate q in a ! workspace: need m*m [l] + m [tau] + m [work] ! workspace: prefer m*m [l] + m [tau] + m*nb [work] - call stdlib_dorglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork - & - nwork + 1, ierr ) + call stdlib${ii}$_dorglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork - & + nwork + 1_${ik}$, ierr ) ie = itau itauq = ie + m itaup = itauq + m @@ -75802,33 +75796,33 @@ module stdlib_linalg_lapack_d ! bidiagonalize l in work(iu). ! workspace: need m*m [l] + 3*m [e, tauq, taup] + m [work] ! workspace: prefer m*m [l] + 3*m [e, tauq, taup] + 2*m*nb [work] - call stdlib_dgebrd( m, m, work( il ), ldwrkl, s, work( ie ),work( itauq ), & - work( itaup ), work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_dgebrd( m, m, work( il ), ldwrkl, s, work( ie ),work( itauq ), & + work( itaup ), work( nwork ),lwork - nwork + 1_${ik}$, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in vt ! workspace: need m*m [l] + 3*m [e, tauq, taup] + bdspac - call stdlib_dbdsdc( 'U', 'I', m, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & + call stdlib${ii}$_dbdsdc( 'U', 'I', m, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & work( nwork ), iwork,info ) ! overwrite u by left singular vectors of l and vt ! by right singular vectors of l ! workspace: need m*m [l] + 3*m [e, tauq, taup] + m [work] ! workspace: prefer m*m [l] + 3*m [e, tauq, taup] + m*nb [work] - call stdlib_dormbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & - u, ldu, work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_dormbr( 'P', 'R', 'T', m, m, m, work( il ), ldwrkl,work( itaup ), & - vt, ldvt, work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_dormbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & + u, ldu, work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_dormbr( 'P', 'R', 'T', m, m, m, work( il ), ldwrkl,work( itaup ), & + vt, ldvt, work( nwork ),lwork - nwork + 1_${ik}$, ierr ) ! multiply right singular vectors of l in work(il) by ! q in a, storing result in vt ! workspace: need m*m [l] - call stdlib_dlacpy( 'F', m, m, vt, ldvt, work( il ), ldwrkl ) - call stdlib_dgemm( 'N', 'N', m, n, m, one, work( il ), ldwrkl,a, lda, zero, & + call stdlib${ii}$_dlacpy( 'F', m, m, vt, ldvt, work( il ), ldwrkl ) + call stdlib${ii}$_dgemm( 'N', 'N', m, n, m, one, work( il ), ldwrkl,a, lda, zero, & vt, ldvt ) else if( wntqa ) then ! path 4t (n >> m, jobz='a') ! n right singular vectors to be computed in vt and ! m left singular vectors to be computed in u - ivt = 1 + ivt = 1_${ik}$ ! work(ivt) is m by m ldwkvt = m itau = ivt + ldwkvt*m @@ -75836,16 +75830,16 @@ module stdlib_linalg_lapack_d ! compute a=l*q, copying result to vt ! workspace: need m*m [vt] + m [tau] + m [work] ! workspace: prefer m*m [vt] + m [tau] + m*nb [work] - call stdlib_dgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & - 1, ierr ) - call stdlib_dlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_dgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + 1_${ik}$, ierr ) + call stdlib${ii}$_dlacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! workspace: need m*m [vt] + m [tau] + n [work] ! workspace: prefer m*m [vt] + m [tau] + n*nb [work] - call stdlib_dorglq( n, n, m, vt, ldvt, work( itau ),work( nwork ), lwork - & - nwork + 1, ierr ) + call stdlib${ii}$_dorglq( n, n, m, vt, ldvt, work( itau ),work( nwork ), lwork - & + nwork + 1_${ik}$, ierr ) ! produce l in a, zeroing out other entries - if (m>1) call stdlib_dlaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ), lda ) + if (m>1_${ik}$) call stdlib${ii}$_dlaset( 'U', m-1, m-1, zero, zero, a( 1_${ik}$, 2_${ik}$ ), lda ) ie = itau itauq = ie + m itaup = itauq + m @@ -75853,103 +75847,103 @@ module stdlib_linalg_lapack_d ! bidiagonalize l in a ! workspace: need m*m [vt] + 3*m [e, tauq, taup] + m [work] ! workspace: prefer m*m [vt] + 3*m [e, tauq, taup] + 2*m*nb [work] - call stdlib_dgebrd( m, m, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_dgebrd( m, m, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in work(ivt) ! workspace: need m*m [vt] + 3*m [e, tauq, taup] + bdspac - call stdlib_dbdsdc( 'U', 'I', m, s, work( ie ), u, ldu,work( ivt ), ldwkvt, & + call stdlib${ii}$_dbdsdc( 'U', 'I', m, s, work( ie ), u, ldu,work( ivt ), ldwkvt, & dum, idum,work( nwork ), iwork, info ) ! overwrite u by left singular vectors of l and work(ivt) ! by right singular vectors of l ! workspace: need m*m [vt] + 3*m [e, tauq, taup]+ m [work] ! workspace: prefer m*m [vt] + 3*m [e, tauq, taup]+ m*nb [work] - call stdlib_dormbr( 'Q', 'L', 'N', m, m, m, a, lda,work( itauq ), u, ldu, & - work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_dormbr( 'P', 'R', 'T', m, m, m, a, lda,work( itaup ), work( ivt ),& - ldwkvt,work( nwork ), lwork - nwork + 1, ierr ) + call stdlib${ii}$_dormbr( 'Q', 'L', 'N', m, m, m, a, lda,work( itauq ), u, ldu, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_dormbr( 'P', 'R', 'T', m, m, m, a, lda,work( itaup ), work( ivt ),& + ldwkvt,work( nwork ), lwork - nwork + 1_${ik}$, ierr ) ! multiply right singular vectors of l in work(ivt) by ! q in vt, storing result in a ! workspace: need m*m [vt] - call stdlib_dgemm( 'N', 'N', m, n, m, one, work( ivt ), ldwkvt,vt, ldvt, zero,& + call stdlib${ii}$_dgemm( 'N', 'N', m, n, m, one, work( ivt ), ldwkvt,vt, ldvt, zero,& a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_dlacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_dlacpy( 'F', m, n, a, lda, vt, ldvt ) end if else ! n < mnthr ! path 5t (n > m, but not much larger) ! reduce to bidiagonal form without lq decomposition - ie = 1 + ie = 1_${ik}$ itauq = ie + m itaup = itauq + m nwork = itaup + m ! bidiagonalize a ! workspace: need 3*m [e, tauq, taup] + n [work] ! workspace: prefer 3*m [e, tauq, taup] + (m+n)*nb [work] - call stdlib_dgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_dgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) if( wntqn ) then ! path 5tn (n > m, jobz='n') ! perform bidiagonal svd, only computing singular values ! workspace: need 3*m [e, tauq, taup] + bdspac - call stdlib_dbdsdc( 'L', 'N', m, s, work( ie ), dum, 1, dum, 1,dum, idum, & + call stdlib${ii}$_dbdsdc( 'L', 'N', m, s, work( ie ), dum, 1_${ik}$, dum, 1_${ik}$,dum, idum, & work( nwork ), iwork, info ) else if( wntqo ) then ! path 5to (n > m, jobz='o') ldwkvt = m ivt = nwork - if( lwork >= m*n + 3*m + bdspac ) then + if( lwork >= m*n + 3_${ik}$*m + bdspac ) then ! work( ivt ) is m by n - call stdlib_dlaset( 'F', m, n, zero, zero, work( ivt ),ldwkvt ) + call stdlib${ii}$_dlaset( 'F', m, n, zero, zero, work( ivt ),ldwkvt ) nwork = ivt + ldwkvt*n ! il is unused; silence compile warnings - il = -1 + il = -1_${ik}$ else ! work( ivt ) is m by m nwork = ivt + ldwkvt*m il = nwork ! work(il) is m by chunk - chunk = ( lwork - m*m - 3*m ) / m + chunk = ( lwork - m*m - 3_${ik}$*m ) / m end if ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in work(ivt) ! workspace: need 3*m [e, tauq, taup] + m*m [vt] + bdspac - call stdlib_dbdsdc( 'L', 'I', m, s, work( ie ), u, ldu,work( ivt ), ldwkvt, & + call stdlib${ii}$_dbdsdc( 'L', 'I', m, s, work( ie ), u, ldu,work( ivt ), ldwkvt, & dum, idum,work( nwork ), iwork, info ) ! overwrite u by left singular vectors of a ! workspace: need 3*m [e, tauq, taup] + m*m [vt] + m [work] ! workspace: prefer 3*m [e, tauq, taup] + m*m [vt] + m*nb [work] - call stdlib_dormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & - work( nwork ),lwork - nwork + 1, ierr ) - if( lwork >= m*n + 3*m + bdspac ) then + call stdlib${ii}$_dormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + if( lwork >= m*n + 3_${ik}$*m + bdspac ) then ! path 5to-fast ! overwrite work(ivt) by left singular vectors of a ! workspace: need 3*m [e, tauq, taup] + m*n [vt] + m [work] ! workspace: prefer 3*m [e, tauq, taup] + m*n [vt] + m*nb [work] - call stdlib_dormbr( 'P', 'R', 'T', m, n, m, a, lda,work( itaup ), work( & - ivt ), ldwkvt,work( nwork ), lwork - nwork + 1, ierr ) + call stdlib${ii}$_dormbr( 'P', 'R', 'T', m, n, m, a, lda,work( itaup ), work( & + ivt ), ldwkvt,work( nwork ), lwork - nwork + 1_${ik}$, ierr ) ! copy right singular vectors of a from work(ivt) to a - call stdlib_dlacpy( 'F', m, n, work( ivt ), ldwkvt, a, lda ) + call stdlib${ii}$_dlacpy( 'F', m, n, work( ivt ), ldwkvt, a, lda ) else ! path 5to-slow ! generate p**t in a ! workspace: need 3*m [e, tauq, taup] + m*m [vt] + m [work] ! workspace: prefer 3*m [e, tauq, taup] + m*m [vt] + m*nb [work] - call stdlib_dorgbr( 'P', m, n, m, a, lda, work( itaup ),work( nwork ), & - lwork - nwork + 1, ierr ) + call stdlib${ii}$_dorgbr( 'P', m, n, m, a, lda, work( itaup ),work( nwork ), & + lwork - nwork + 1_${ik}$, ierr ) ! multiply q in a by right singular vectors of ! bidiagonal matrix in work(ivt), storing result in ! work(il) and copying to a ! workspace: need 3*m [e, tauq, taup] + m*m [vt] + m*nb [l] ! workspace: prefer 3*m [e, tauq, taup] + m*m [vt] + m*n [l] do i = 1, n, chunk - blk = min( n - i + 1, chunk ) - call stdlib_dgemm( 'N', 'N', m, blk, m, one, work( ivt ),ldwkvt, a( 1, & + blk = min( n - i + 1_${ik}$, chunk ) + call stdlib${ii}$_dgemm( 'N', 'N', m, blk, m, one, work( ivt ),ldwkvt, a( 1_${ik}$, & i ), lda, zero,work( il ), m ) - call stdlib_dlacpy( 'F', m, blk, work( il ), m, a( 1, i ),lda ) + call stdlib${ii}$_dlacpy( 'F', m, blk, work( il ), m, a( 1_${ik}$, i ),lda ) end do end if else if( wntqs ) then @@ -75958,55 +75952,55 @@ module stdlib_linalg_lapack_d ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in vt ! workspace: need 3*m [e, tauq, taup] + bdspac - call stdlib_dlaset( 'F', m, n, zero, zero, vt, ldvt ) - call stdlib_dbdsdc( 'L', 'I', m, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & + call stdlib${ii}$_dlaset( 'F', m, n, zero, zero, vt, ldvt ) + call stdlib${ii}$_dbdsdc( 'L', 'I', m, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & work( nwork ), iwork,info ) ! overwrite u by left singular vectors of a and vt ! by right singular vectors of a ! workspace: need 3*m [e, tauq, taup] + m [work] ! workspace: prefer 3*m [e, tauq, taup] + m*nb [work] - call stdlib_dormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & - work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_dormbr( 'P', 'R', 'T', m, n, m, a, lda,work( itaup ), vt, ldvt, & - work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_dormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_dormbr( 'P', 'R', 'T', m, n, m, a, lda,work( itaup ), vt, ldvt, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) else if( wntqa ) then ! path 5ta (n > m, jobz='a') ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in vt ! workspace: need 3*m [e, tauq, taup] + bdspac - call stdlib_dlaset( 'F', n, n, zero, zero, vt, ldvt ) - call stdlib_dbdsdc( 'L', 'I', m, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & + call stdlib${ii}$_dlaset( 'F', n, n, zero, zero, vt, ldvt ) + call stdlib${ii}$_dbdsdc( 'L', 'I', m, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & work( nwork ), iwork,info ) ! set the right corner of vt to identity matrix if( n>m ) then - call stdlib_dlaset( 'F', n-m, n-m, zero, one, vt(m+1,m+1),ldvt ) + call stdlib${ii}$_dlaset( 'F', n-m, n-m, zero, one, vt(m+1,m+1),ldvt ) end if ! overwrite u by left singular vectors of a and vt ! by right singular vectors of a ! workspace: need 3*m [e, tauq, taup] + n [work] ! workspace: prefer 3*m [e, tauq, taup] + n*nb [work] - call stdlib_dormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & - work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_dormbr( 'P', 'R', 'T', n, n, m, a, lda,work( itaup ), vt, ldvt, & - work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_dormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_dormbr( 'P', 'R', 'T', n, n, m, a, lda,work( itaup ), vt, ldvt, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) end if end if end if ! undo scaling if necessary - if( iscl==1 ) then - if( anrm>bignum )call stdlib_dlascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,& + if( iscl==1_${ik}$ ) then + if( anrm>bignum )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn, 1_${ik}$, s, minmn,& ierr ) - if( anrm=n .and. minmn>0 ) then - ! compute space needed for stdlib_dbdsqr - mnthr = stdlib_ilaenv( 6, 'DGESVD', jobu // jobvt, m, n, 0, 0 ) - bdspac = 5*n - ! compute space needed for stdlib_dgeqrf - call stdlib_dgeqrf( m, n, a, lda, dum(1), dum(1), -1, ierr ) - lwork_dgeqrf = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_dorgqr - call stdlib_dorgqr( m, n, n, a, lda, dum(1), dum(1), -1, ierr ) - lwork_dorgqr_n = int( dum(1),KIND=ilp) - call stdlib_dorgqr( m, m, n, a, lda, dum(1), dum(1), -1, ierr ) - lwork_dorgqr_m = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_dgebrd - call stdlib_dgebrd( n, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) + ! following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + if( m>=n .and. minmn>0_${ik}$ ) then + ! compute space needed for stdlib${ii}$_dbdsqr + mnthr = stdlib${ii}$_ilaenv( 6_${ik}$, 'DGESVD', jobu // jobvt, m, n, 0_${ik}$, 0_${ik}$ ) + bdspac = 5_${ik}$*n + ! compute space needed for stdlib${ii}$_dgeqrf + call stdlib${ii}$_dgeqrf( m, n, a, lda, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_dgeqrf = int( dum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_dorgqr + call stdlib${ii}$_dorgqr( m, n, n, a, lda, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_dorgqr_n = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_dorgqr( m, m, n, a, lda, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_dorgqr_m = int( dum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_dgebrd + call stdlib${ii}$_dgebrd( n, n, a, lda, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) - lwork_dgebrd = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_dorgbr p - call stdlib_dorgbr( 'P', n, n, n, a, lda, dum(1),dum(1), -1, ierr ) - lwork_dorgbr_p = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_dorgbr q - call stdlib_dorgbr( 'Q', n, n, n, a, lda, dum(1),dum(1), -1, ierr ) - lwork_dorgbr_q = int( dum(1),KIND=ilp) + lwork_dgebrd = int( dum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_dorgbr p + call stdlib${ii}$_dorgbr( 'P', n, n, n, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_dorgbr_p = int( dum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_dorgbr q + call stdlib${ii}$_dorgbr( 'Q', n, n, n, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_dorgbr_q = int( dum(1_${ik}$),KIND=${ik}$) if( m>=mnthr ) then if( wntun ) then ! path 1 (m much larger than n, jobu='n') maxwrk = n + lwork_dgeqrf - maxwrk = max( maxwrk, 3*n + lwork_dgebrd ) - if( wntvo .or. wntvas )maxwrk = max( maxwrk, 3*n + lwork_dorgbr_p ) + maxwrk = max( maxwrk, 3_${ik}$*n + lwork_dgebrd ) + if( wntvo .or. wntvas )maxwrk = max( maxwrk, 3_${ik}$*n + lwork_dorgbr_p ) maxwrk = max( maxwrk, bdspac ) - minwrk = max( 4*n, bdspac ) + minwrk = max( 4_${ik}$*n, bdspac ) else if( wntuo .and. wntvn ) then ! path 2 (m much larger than n, jobu='o', jobvt='n') wrkbl = n + lwork_dgeqrf wrkbl = max( wrkbl, n + lwork_dorgqr_n ) - wrkbl = max( wrkbl, 3*n + lwork_dgebrd ) - wrkbl = max( wrkbl, 3*n + lwork_dorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dorgbr_q ) wrkbl = max( wrkbl, bdspac ) maxwrk = max( n*n + wrkbl, n*n + m*n + n ) - minwrk = max( 3*n + m, bdspac ) + minwrk = max( 3_${ik}$*n + m, bdspac ) else if( wntuo .and. wntvas ) then ! path 3 (m much larger than n, jobu='o', jobvt='s' or ! 'a') wrkbl = n + lwork_dgeqrf wrkbl = max( wrkbl, n + lwork_dorgqr_n ) - wrkbl = max( wrkbl, 3*n + lwork_dgebrd ) - wrkbl = max( wrkbl, 3*n + lwork_dorgbr_q ) - wrkbl = max( wrkbl, 3*n + lwork_dorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dorgbr_p ) wrkbl = max( wrkbl, bdspac ) maxwrk = max( n*n + wrkbl, n*n + m*n + n ) - minwrk = max( 3*n + m, bdspac ) + minwrk = max( 3_${ik}$*n + m, bdspac ) else if( wntus .and. wntvn ) then ! path 4 (m much larger than n, jobu='s', jobvt='n') wrkbl = n + lwork_dgeqrf wrkbl = max( wrkbl, n + lwork_dorgqr_n ) - wrkbl = max( wrkbl, 3*n + lwork_dgebrd ) - wrkbl = max( wrkbl, 3*n + lwork_dorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dorgbr_q ) wrkbl = max( wrkbl, bdspac ) maxwrk = n*n + wrkbl - minwrk = max( 3*n + m, bdspac ) + minwrk = max( 3_${ik}$*n + m, bdspac ) else if( wntus .and. wntvo ) then ! path 5 (m much larger than n, jobu='s', jobvt='o') wrkbl = n + lwork_dgeqrf wrkbl = max( wrkbl, n + lwork_dorgqr_n ) - wrkbl = max( wrkbl, 3*n + lwork_dgebrd ) - wrkbl = max( wrkbl, 3*n + lwork_dorgbr_q ) - wrkbl = max( wrkbl, 3*n + lwork_dorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dorgbr_p ) wrkbl = max( wrkbl, bdspac ) - maxwrk = 2*n*n + wrkbl - minwrk = max( 3*n + m, bdspac ) + maxwrk = 2_${ik}$*n*n + wrkbl + minwrk = max( 3_${ik}$*n + m, bdspac ) else if( wntus .and. wntvas ) then ! path 6 (m much larger than n, jobu='s', jobvt='s' or ! 'a') wrkbl = n + lwork_dgeqrf wrkbl = max( wrkbl, n + lwork_dorgqr_n ) - wrkbl = max( wrkbl, 3*n + lwork_dgebrd ) - wrkbl = max( wrkbl, 3*n + lwork_dorgbr_q ) - wrkbl = max( wrkbl, 3*n + lwork_dorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dorgbr_p ) wrkbl = max( wrkbl, bdspac ) maxwrk = n*n + wrkbl - minwrk = max( 3*n + m, bdspac ) + minwrk = max( 3_${ik}$*n + m, bdspac ) else if( wntua .and. wntvn ) then ! path 7 (m much larger than n, jobu='a', jobvt='n') wrkbl = n + lwork_dgeqrf wrkbl = max( wrkbl, n + lwork_dorgqr_m ) - wrkbl = max( wrkbl, 3*n + lwork_dgebrd ) - wrkbl = max( wrkbl, 3*n + lwork_dorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dorgbr_q ) wrkbl = max( wrkbl, bdspac ) maxwrk = n*n + wrkbl - minwrk = max( 3*n + m, bdspac ) + minwrk = max( 3_${ik}$*n + m, bdspac ) else if( wntua .and. wntvo ) then ! path 8 (m much larger than n, jobu='a', jobvt='o') wrkbl = n + lwork_dgeqrf wrkbl = max( wrkbl, n + lwork_dorgqr_m ) - wrkbl = max( wrkbl, 3*n + lwork_dgebrd ) - wrkbl = max( wrkbl, 3*n + lwork_dorgbr_q ) - wrkbl = max( wrkbl, 3*n + lwork_dorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dorgbr_p ) wrkbl = max( wrkbl, bdspac ) - maxwrk = 2*n*n + wrkbl - minwrk = max( 3*n + m, bdspac ) + maxwrk = 2_${ik}$*n*n + wrkbl + minwrk = max( 3_${ik}$*n + m, bdspac ) else if( wntua .and. wntvas ) then ! path 9 (m much larger than n, jobu='a', jobvt='s' or ! 'a') wrkbl = n + lwork_dgeqrf wrkbl = max( wrkbl, n + lwork_dorgqr_m ) - wrkbl = max( wrkbl, 3*n + lwork_dgebrd ) - wrkbl = max( wrkbl, 3*n + lwork_dorgbr_q ) - wrkbl = max( wrkbl, 3*n + lwork_dorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_dorgbr_p ) wrkbl = max( wrkbl, bdspac ) maxwrk = n*n + wrkbl - minwrk = max( 3*n + m, bdspac ) + minwrk = max( 3_${ik}$*n + m, bdspac ) end if else ! path 10 (m at least n, but not much larger) - call stdlib_dgebrd( m, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) + call stdlib${ii}$_dgebrd( m, n, a, lda, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) - lwork_dgebrd = int( dum(1),KIND=ilp) - maxwrk = 3*n + lwork_dgebrd + lwork_dgebrd = int( dum(1_${ik}$),KIND=${ik}$) + maxwrk = 3_${ik}$*n + lwork_dgebrd if( wntus .or. wntuo ) then - call stdlib_dorgbr( 'Q', m, n, n, a, lda, dum(1),dum(1), -1, ierr ) - lwork_dorgbr_q = int( dum(1),KIND=ilp) - maxwrk = max( maxwrk, 3*n + lwork_dorgbr_q ) + call stdlib${ii}$_dorgbr( 'Q', m, n, n, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_dorgbr_q = int( dum(1_${ik}$),KIND=${ik}$) + maxwrk = max( maxwrk, 3_${ik}$*n + lwork_dorgbr_q ) end if if( wntua ) then - call stdlib_dorgbr( 'Q', m, m, n, a, lda, dum(1),dum(1), -1, ierr ) - lwork_dorgbr_q = int( dum(1),KIND=ilp) - maxwrk = max( maxwrk, 3*n + lwork_dorgbr_q ) + call stdlib${ii}$_dorgbr( 'Q', m, m, n, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_dorgbr_q = int( dum(1_${ik}$),KIND=${ik}$) + maxwrk = max( maxwrk, 3_${ik}$*n + lwork_dorgbr_q ) end if if( .not.wntvn ) then - maxwrk = max( maxwrk, 3*n + lwork_dorgbr_p ) + maxwrk = max( maxwrk, 3_${ik}$*n + lwork_dorgbr_p ) end if maxwrk = max( maxwrk, bdspac ) - minwrk = max( 3*n + m, bdspac ) - end if - else if( minmn>0 ) then - ! compute space needed for stdlib_dbdsqr - mnthr = stdlib_ilaenv( 6, 'DGESVD', jobu // jobvt, m, n, 0, 0 ) - bdspac = 5*m - ! compute space needed for stdlib_dgelqf - call stdlib_dgelqf( m, n, a, lda, dum(1), dum(1), -1, ierr ) - lwork_dgelqf = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_dorglq - call stdlib_dorglq( n, n, m, dum(1), n, dum(1), dum(1), -1, ierr ) - lwork_dorglq_n = int( dum(1),KIND=ilp) - call stdlib_dorglq( m, n, m, a, lda, dum(1), dum(1), -1, ierr ) - lwork_dorglq_m = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_dgebrd - call stdlib_dgebrd( m, m, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) + minwrk = max( 3_${ik}$*n + m, bdspac ) + end if + else if( minmn>0_${ik}$ ) then + ! compute space needed for stdlib${ii}$_dbdsqr + mnthr = stdlib${ii}$_ilaenv( 6_${ik}$, 'DGESVD', jobu // jobvt, m, n, 0_${ik}$, 0_${ik}$ ) + bdspac = 5_${ik}$*m + ! compute space needed for stdlib${ii}$_dgelqf + call stdlib${ii}$_dgelqf( m, n, a, lda, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_dgelqf = int( dum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_dorglq + call stdlib${ii}$_dorglq( n, n, m, dum(1_${ik}$), n, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_dorglq_n = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_dorglq( m, n, m, a, lda, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_dorglq_m = int( dum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_dgebrd + call stdlib${ii}$_dgebrd( m, m, a, lda, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) - lwork_dgebrd = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_dorgbr p - call stdlib_dorgbr( 'P', m, m, m, a, n, dum(1),dum(1), -1, ierr ) - lwork_dorgbr_p = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_dorgbr q - call stdlib_dorgbr( 'Q', m, m, m, a, n, dum(1),dum(1), -1, ierr ) - lwork_dorgbr_q = int( dum(1),KIND=ilp) + lwork_dgebrd = int( dum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_dorgbr p + call stdlib${ii}$_dorgbr( 'P', m, m, m, a, n, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_dorgbr_p = int( dum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_dorgbr q + call stdlib${ii}$_dorgbr( 'Q', m, m, m, a, n, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_dorgbr_q = int( dum(1_${ik}$),KIND=${ik}$) if( n>=mnthr ) then if( wntvn ) then ! path 1t(n much larger than m, jobvt='n') maxwrk = m + lwork_dgelqf - maxwrk = max( maxwrk, 3*m + lwork_dgebrd ) - if( wntuo .or. wntuas )maxwrk = max( maxwrk, 3*m + lwork_dorgbr_q ) + maxwrk = max( maxwrk, 3_${ik}$*m + lwork_dgebrd ) + if( wntuo .or. wntuas )maxwrk = max( maxwrk, 3_${ik}$*m + lwork_dorgbr_q ) maxwrk = max( maxwrk, bdspac ) - minwrk = max( 4*m, bdspac ) + minwrk = max( 4_${ik}$*m, bdspac ) else if( wntvo .and. wntun ) then ! path 2t(n much larger than m, jobu='n', jobvt='o') wrkbl = m + lwork_dgelqf wrkbl = max( wrkbl, m + lwork_dorglq_m ) - wrkbl = max( wrkbl, 3*m + lwork_dgebrd ) - wrkbl = max( wrkbl, 3*m + lwork_dorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dorgbr_p ) wrkbl = max( wrkbl, bdspac ) maxwrk = max( m*m + wrkbl, m*m + m*n + m ) - minwrk = max( 3*m + n, bdspac ) + minwrk = max( 3_${ik}$*m + n, bdspac ) else if( wntvo .and. wntuas ) then ! path 3t(n much larger than m, jobu='s' or 'a', ! jobvt='o') wrkbl = m + lwork_dgelqf wrkbl = max( wrkbl, m + lwork_dorglq_m ) - wrkbl = max( wrkbl, 3*m + lwork_dgebrd ) - wrkbl = max( wrkbl, 3*m + lwork_dorgbr_p ) - wrkbl = max( wrkbl, 3*m + lwork_dorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dorgbr_q ) wrkbl = max( wrkbl, bdspac ) maxwrk = max( m*m + wrkbl, m*m + m*n + m ) - minwrk = max( 3*m + n, bdspac ) + minwrk = max( 3_${ik}$*m + n, bdspac ) else if( wntvs .and. wntun ) then ! path 4t(n much larger than m, jobu='n', jobvt='s') wrkbl = m + lwork_dgelqf wrkbl = max( wrkbl, m + lwork_dorglq_m ) - wrkbl = max( wrkbl, 3*m + lwork_dgebrd ) - wrkbl = max( wrkbl, 3*m + lwork_dorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dorgbr_p ) wrkbl = max( wrkbl, bdspac ) maxwrk = m*m + wrkbl - minwrk = max( 3*m + n, bdspac ) + minwrk = max( 3_${ik}$*m + n, bdspac ) else if( wntvs .and. wntuo ) then ! path 5t(n much larger than m, jobu='o', jobvt='s') wrkbl = m + lwork_dgelqf wrkbl = max( wrkbl, m + lwork_dorglq_m ) - wrkbl = max( wrkbl, 3*m + lwork_dgebrd ) - wrkbl = max( wrkbl, 3*m + lwork_dorgbr_p ) - wrkbl = max( wrkbl, 3*m + lwork_dorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dorgbr_q ) wrkbl = max( wrkbl, bdspac ) - maxwrk = 2*m*m + wrkbl - minwrk = max( 3*m + n, bdspac ) + maxwrk = 2_${ik}$*m*m + wrkbl + minwrk = max( 3_${ik}$*m + n, bdspac ) else if( wntvs .and. wntuas ) then ! path 6t(n much larger than m, jobu='s' or 'a', ! jobvt='s') wrkbl = m + lwork_dgelqf wrkbl = max( wrkbl, m + lwork_dorglq_m ) - wrkbl = max( wrkbl, 3*m + lwork_dgebrd ) - wrkbl = max( wrkbl, 3*m + lwork_dorgbr_p ) - wrkbl = max( wrkbl, 3*m + lwork_dorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dorgbr_q ) wrkbl = max( wrkbl, bdspac ) maxwrk = m*m + wrkbl - minwrk = max( 3*m + n, bdspac ) + minwrk = max( 3_${ik}$*m + n, bdspac ) else if( wntva .and. wntun ) then ! path 7t(n much larger than m, jobu='n', jobvt='a') wrkbl = m + lwork_dgelqf wrkbl = max( wrkbl, m + lwork_dorglq_n ) - wrkbl = max( wrkbl, 3*m + lwork_dgebrd ) - wrkbl = max( wrkbl, 3*m + lwork_dorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dorgbr_p ) wrkbl = max( wrkbl, bdspac ) maxwrk = m*m + wrkbl - minwrk = max( 3*m + n, bdspac ) + minwrk = max( 3_${ik}$*m + n, bdspac ) else if( wntva .and. wntuo ) then ! path 8t(n much larger than m, jobu='o', jobvt='a') wrkbl = m + lwork_dgelqf wrkbl = max( wrkbl, m + lwork_dorglq_n ) - wrkbl = max( wrkbl, 3*m + lwork_dgebrd ) - wrkbl = max( wrkbl, 3*m + lwork_dorgbr_p ) - wrkbl = max( wrkbl, 3*m + lwork_dorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dorgbr_q ) wrkbl = max( wrkbl, bdspac ) - maxwrk = 2*m*m + wrkbl - minwrk = max( 3*m + n, bdspac ) + maxwrk = 2_${ik}$*m*m + wrkbl + minwrk = max( 3_${ik}$*m + n, bdspac ) else if( wntva .and. wntuas ) then ! path 9t(n much larger than m, jobu='s' or 'a', ! jobvt='a') wrkbl = m + lwork_dgelqf wrkbl = max( wrkbl, m + lwork_dorglq_n ) - wrkbl = max( wrkbl, 3*m + lwork_dgebrd ) - wrkbl = max( wrkbl, 3*m + lwork_dorgbr_p ) - wrkbl = max( wrkbl, 3*m + lwork_dorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_dorgbr_q ) wrkbl = max( wrkbl, bdspac ) maxwrk = m*m + wrkbl - minwrk = max( 3*m + n, bdspac ) + minwrk = max( 3_${ik}$*m + n, bdspac ) end if else ! path 10t(n greater than m, but not much larger) - call stdlib_dgebrd( m, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) + call stdlib${ii}$_dgebrd( m, n, a, lda, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) - lwork_dgebrd = int( dum(1),KIND=ilp) - maxwrk = 3*m + lwork_dgebrd + lwork_dgebrd = int( dum(1_${ik}$),KIND=${ik}$) + maxwrk = 3_${ik}$*m + lwork_dgebrd if( wntvs .or. wntvo ) then - ! compute space needed for stdlib_dorgbr p - call stdlib_dorgbr( 'P', m, n, m, a, n, dum(1),dum(1), -1, ierr ) - lwork_dorgbr_p = int( dum(1),KIND=ilp) - maxwrk = max( maxwrk, 3*m + lwork_dorgbr_p ) + ! compute space needed for stdlib${ii}$_dorgbr p + call stdlib${ii}$_dorgbr( 'P', m, n, m, a, n, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_dorgbr_p = int( dum(1_${ik}$),KIND=${ik}$) + maxwrk = max( maxwrk, 3_${ik}$*m + lwork_dorgbr_p ) end if if( wntva ) then - call stdlib_dorgbr( 'P', n, n, m, a, n, dum(1),dum(1), -1, ierr ) - lwork_dorgbr_p = int( dum(1),KIND=ilp) - maxwrk = max( maxwrk, 3*m + lwork_dorgbr_p ) + call stdlib${ii}$_dorgbr( 'P', n, n, m, a, n, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_dorgbr_p = int( dum(1_${ik}$),KIND=${ik}$) + maxwrk = max( maxwrk, 3_${ik}$*m + lwork_dorgbr_p ) end if if( .not.wntun ) then - maxwrk = max( maxwrk, 3*m + lwork_dorgbr_q ) + maxwrk = max( maxwrk, 3_${ik}$*m + lwork_dorgbr_q ) end if maxwrk = max( maxwrk, bdspac ) - minwrk = max( 3*m + n, bdspac ) + minwrk = max( 3_${ik}$*m + n, bdspac ) end if end if maxwrk = max( maxwrk, minwrk ) - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk if( lworkzero .and. anrmbignum ) then - iscl = 1 - call stdlib_dlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, ierr ) + iscl = 1_${ik}$ + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, ierr ) end if if( m>=n ) then ! a has at least as many rows as columns. if a has sufficiently @@ -76391,29 +76385,29 @@ module stdlib_linalg_lapack_d if( wntun ) then ! path 1 (m much larger than n, jobu='n') ! no left singular vectors to be computed - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_dgeqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & + call stdlib${ii}$_dgeqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & ierr ) ! zero out below r - if( n > 1 ) then - call stdlib_dlaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ),lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_dlaset( 'L', n-1, n-1, zero, zero, a( 2_${ik}$, 1_${ik}$ ),lda ) end if - ie = 1 + ie = 1_${ik}$ itauq = ie + n itaup = itauq + n iwork = itaup + n ! bidiagonalize r in a ! (workspace: need 4*n, prefer 3*n + 2*n*nb) - call stdlib_dgebrd( n, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_dgebrd( n, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,ierr ) - ncvt = 0 + ncvt = 0_${ik}$ if( wntvo .or. wntvas ) then ! if right singular vectors desired, generate p'. ! (workspace: need 4*n-1, prefer 3*n + (n-1)*nb) - call stdlib_dorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & + call stdlib${ii}$_dorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) ncvt = n end if @@ -76421,17 +76415,17 @@ module stdlib_linalg_lapack_d ! perform bidiagonal qr iteration, computing right ! singular vectors of a in a if desired ! (workspace: need bdspac) - call stdlib_dbdsqr( 'U', n, ncvt, 0, 0, s, work( ie ), a, lda,dum, 1, dum, 1, & + call stdlib${ii}$_dbdsqr( 'U', n, ncvt, 0_${ik}$, 0_${ik}$, s, work( ie ), a, lda,dum, 1_${ik}$, dum, 1_${ik}$, & work( iwork ), info ) ! if right singular vectors desired in vt, copy them there - if( wntvas )call stdlib_dlacpy( 'F', n, n, a, lda, vt, ldvt ) + if( wntvas )call stdlib${ii}$_dlacpy( 'F', n, n, a, lda, vt, ldvt ) else if( wntuo .and. wntvn ) then ! path 2 (m much larger than n, jobu='o', jobvt='n') ! n left singular vectors to be overwritten on a and ! no right singular vectors to be computed - if( lwork>=n*n+max( 4*n, bdspac ) ) then + if( lwork>=n*n+max( 4_${ik}$*n, bdspac ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=max( wrkbl, lda*n + n ) + lda*n ) then ! work(iu) is lda by n, work(ir) is lda by n ldwrku = lda @@ -76449,15 +76443,15 @@ module stdlib_linalg_lapack_d iwork = itau + n ! compute a=q*r ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy r to work(ir) and zero out below it - call stdlib_dlacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) - call stdlib_dlaset( 'L', n-1, n-1, zero, zero, work( ir+1 ),ldwrkr ) + call stdlib${ii}$_dlacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) + call stdlib${ii}$_dlaset( 'L', n-1, n-1, zero, zero, work( ir+1 ),ldwrkr ) ! generate q in a ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_dorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -76465,57 +76459,57 @@ module stdlib_linalg_lapack_d iwork = itaup + n ! bidiagonalize r in work(ir) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + 2*n*nb) - call stdlib_dgebrd( n, n, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & + call stdlib${ii}$_dgebrd( n, n, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & work( itaup ),work( iwork ), lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing r ! (workspace: need n*n + 4*n, prefer n*n + 3*n + n*nb) - call stdlib_dorgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & + call stdlib${ii}$_dorgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) ! (workspace: need n*n + bdspac) - call stdlib_dbdsqr( 'U', n, 0, n, 0, s, work( ie ), dum, 1,work( ir ), & - ldwrkr, dum, 1,work( iwork ), info ) + call stdlib${ii}$_dbdsqr( 'U', n, 0_${ik}$, n, 0_${ik}$, s, work( ie ), dum, 1_${ik}$,work( ir ), & + ldwrkr, dum, 1_${ik}$,work( iwork ), info ) iu = ie + n ! multiply q in a by left singular vectors of r in ! work(ir), storing result in work(iu) and copying to a ! (workspace: need n*n + 2*n, prefer n*n + m*n + n) do i = 1, m, ldwrku chunk = min( m-i+1, ldwrku ) - call stdlib_dgemm( 'N', 'N', chunk, n, n, one, a( i, 1 ),lda, work( ir )& + call stdlib${ii}$_dgemm( 'N', 'N', chunk, n, n, one, a( i, 1_${ik}$ ),lda, work( ir )& , ldwrkr, zero,work( iu ), ldwrku ) - call stdlib_dlacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) + call stdlib${ii}$_dlacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1_${ik}$ ), lda ) end do else ! insufficient workspace for a fast algorithm - ie = 1 + ie = 1_${ik}$ itauq = ie + n itaup = itauq + n iwork = itaup + n ! bidiagonalize a ! (workspace: need 3*n + m, prefer 3*n + (m + n)*nb) - call stdlib_dgebrd( m, n, a, lda, s, work( ie ),work( itauq ), work( itaup & + call stdlib${ii}$_dgebrd( m, n, a, lda, s, work( ie ),work( itauq ), work( itaup & ),work( iwork ), lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing a ! (workspace: need 4*n, prefer 3*n + n*nb) - call stdlib_dorgbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), & + call stdlib${ii}$_dorgbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in a ! (workspace: need bdspac) - call stdlib_dbdsqr( 'U', n, 0, m, 0, s, work( ie ), dum, 1,a, lda, dum, 1, & + call stdlib${ii}$_dbdsqr( 'U', n, 0_${ik}$, m, 0_${ik}$, s, work( ie ), dum, 1_${ik}$,a, lda, dum, 1_${ik}$, & work( iwork ), info ) end if else if( wntuo .and. wntvas ) then ! path 3 (m much larger than n, jobu='o', jobvt='s' or 'a') ! n left singular vectors to be overwritten on a and ! n right singular vectors to be computed in vt - if( lwork>=n*n+max( 4*n, bdspac ) ) then + if( lwork>=n*n+max( 4_${ik}$*n, bdspac ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=max( wrkbl, lda*n + n ) + lda*n ) then ! work(iu) is lda by n and work(ir) is lda by n ldwrku = lda @@ -76533,15 +76527,15 @@ module stdlib_linalg_lapack_d iwork = itau + n ! compute a=q*r ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy r to vt, zeroing out below it - call stdlib_dlacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_dlaset( 'L', n-1, n-1, zero, zero,vt( 2, 1 ), ldvt ) + call stdlib${ii}$_dlacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1_${ik}$ )call stdlib${ii}$_dlaset( 'L', n-1, n-1, zero, zero,vt( 2_${ik}$, 1_${ik}$ ), ldvt ) ! generate q in a ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_dorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -76549,50 +76543,50 @@ module stdlib_linalg_lapack_d iwork = itaup + n ! bidiagonalize r in vt, copying result to work(ir) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + 2*n*nb) - call stdlib_dgebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_dgebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) - call stdlib_dlacpy( 'L', n, n, vt, ldvt, work( ir ), ldwrkr ) + call stdlib${ii}$_dlacpy( 'L', n, n, vt, ldvt, work( ir ), ldwrkr ) ! generate left vectors bidiagonalizing r in work(ir) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + n*nb) - call stdlib_dorgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & + call stdlib${ii}$_dorgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing r in vt ! (workspace: need n*n + 4*n-1, prefer n*n + 3*n + (n-1)*nb) - call stdlib_dorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib${ii}$_dorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) and computing right ! singular vectors of r in vt ! (workspace: need n*n + bdspac) - call stdlib_dbdsqr( 'U', n, n, n, 0, s, work( ie ), vt, ldvt,work( ir ), & - ldwrkr, dum, 1,work( iwork ), info ) + call stdlib${ii}$_dbdsqr( 'U', n, n, n, 0_${ik}$, s, work( ie ), vt, ldvt,work( ir ), & + ldwrkr, dum, 1_${ik}$,work( iwork ), info ) iu = ie + n ! multiply q in a by left singular vectors of r in ! work(ir), storing result in work(iu) and copying to a ! (workspace: need n*n + 2*n, prefer n*n + m*n + n) do i = 1, m, ldwrku chunk = min( m-i+1, ldwrku ) - call stdlib_dgemm( 'N', 'N', chunk, n, n, one, a( i, 1 ),lda, work( ir )& + call stdlib${ii}$_dgemm( 'N', 'N', chunk, n, n, one, a( i, 1_${ik}$ ),lda, work( ir )& , ldwrkr, zero,work( iu ), ldwrku ) - call stdlib_dlacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) + call stdlib${ii}$_dlacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1_${ik}$ ), lda ) end do else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy r to vt, zeroing out below it - call stdlib_dlacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_dlaset( 'L', n-1, n-1, zero, zero,vt( 2, 1 ), ldvt ) + call stdlib${ii}$_dlacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1_${ik}$ )call stdlib${ii}$_dlaset( 'L', n-1, n-1, zero, zero,vt( 2_${ik}$, 1_${ik}$ ), ldvt ) ! generate q in a ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_dorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -76600,32 +76594,32 @@ module stdlib_linalg_lapack_d iwork = itaup + n ! bidiagonalize r in vt ! (workspace: need 4*n, prefer 3*n + 2*n*nb) - call stdlib_dgebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_dgebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in a by left vectors bidiagonalizing r ! (workspace: need 3*n + m, prefer 3*n + m*nb) - call stdlib_dormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), a, lda,& + call stdlib${ii}$_dormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), a, lda,& work( iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing r in vt ! (workspace: need 4*n-1, prefer 3*n + (n-1)*nb) - call stdlib_dorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib${ii}$_dorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in a and computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_dbdsqr( 'U', n, n, m, 0, s, work( ie ), vt, ldvt,a, lda, dum, & - 1, work( iwork ), info ) + call stdlib${ii}$_dbdsqr( 'U', n, n, m, 0_${ik}$, s, work( ie ), vt, ldvt,a, lda, dum, & + 1_${ik}$, work( iwork ), info ) end if else if( wntus ) then if( wntvn ) then ! path 4 (m much larger than n, jobu='s', jobvt='n') ! n left singular vectors to be computed in u and ! no right singular vectors to be computed - if( lwork>=n*n+max( 4*n, bdspac ) ) then + if( lwork>=n*n+max( 4_${ik}$*n, bdspac ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=wrkbl+lda*n ) then ! work(ir) is lda by n ldwrkr = lda @@ -76637,15 +76631,15 @@ module stdlib_linalg_lapack_d iwork = itau + n ! compute a=q*r ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(ir), zeroing out below it - call stdlib_dlacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) - call stdlib_dlaset( 'L', n-1, n-1, zero, zero,work( ir+1 ), ldwrkr ) + call stdlib${ii}$_dlacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) + call stdlib${ii}$_dlaset( 'L', n-1, n-1, zero, zero,work( ir+1 ), ldwrkr ) ! generate q in a ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_dorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -76653,67 +76647,67 @@ module stdlib_linalg_lapack_d iwork = itaup + n ! bidiagonalize r in work(ir) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + 2*n*nb) - call stdlib_dgebrd( n, n, work( ir ), ldwrkr, s,work( ie ), work( itauq & + call stdlib${ii}$_dgebrd( n, n, work( ir ), ldwrkr, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing r in work(ir) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + n*nb) - call stdlib_dorgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_dorgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) ! (workspace: need n*n + bdspac) - call stdlib_dbdsqr( 'U', n, 0, n, 0, s, work( ie ), dum,1, work( ir ), & - ldwrkr, dum, 1,work( iwork ), info ) + call stdlib${ii}$_dbdsqr( 'U', n, 0_${ik}$, n, 0_${ik}$, s, work( ie ), dum,1_${ik}$, work( ir ), & + ldwrkr, dum, 1_${ik}$,work( iwork ), info ) ! multiply q in a by left singular vectors of r in ! work(ir), storing result in u ! (workspace: need n*n) - call stdlib_dgemm( 'N', 'N', m, n, n, one, a, lda,work( ir ), ldwrkr, & + call stdlib${ii}$_dgemm( 'N', 'N', m, n, n, one, a, lda,work( ir ), ldwrkr, & zero, u, ldu ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_dlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_dlacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_dorgqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dorgqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! zero out below r in a - if( n > 1 ) then - call stdlib_dlaset( 'L', n-1, n-1, zero, zero,a( 2, 1 ), lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_dlaset( 'L', n-1, n-1, zero, zero,a( 2_${ik}$, 1_${ik}$ ), lda ) end if ! bidiagonalize r in a ! (workspace: need 4*n, prefer 3*n + 2*n*nb) - call stdlib_dgebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_dgebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left vectors bidiagonalizing r ! (workspace: need 3*n + m, prefer 3*n + m*nb) - call stdlib_dormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib${ii}$_dormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u ! (workspace: need bdspac) - call stdlib_dbdsqr( 'U', n, 0, m, 0, s, work( ie ), dum,1, u, ldu, dum, & - 1, work( iwork ),info ) + call stdlib${ii}$_dbdsqr( 'U', n, 0_${ik}$, m, 0_${ik}$, s, work( ie ), dum,1_${ik}$, u, ldu, dum, & + 1_${ik}$, work( iwork ),info ) end if else if( wntvo ) then ! path 5 (m much larger than n, jobu='s', jobvt='o') ! n left singular vectors to be computed in u and ! n right singular vectors to be overwritten on a - if( lwork>=2*n*n+max( 4*n, bdspac ) ) then + if( lwork>=2_${ik}$*n*n+max( 4_${ik}$*n, bdspac ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+2*lda*n ) then ! work(iu) is lda by n and work(ir) is lda by n ldwrku = lda @@ -76734,15 +76728,15 @@ module stdlib_linalg_lapack_d iwork = itau + n ! compute a=q*r ! (workspace: need 2*n*n + 2*n, prefer 2*n*n + n + n*nb) - call stdlib_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_dlacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_dlaset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) + call stdlib${ii}$_dlacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_dlaset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) ! generate q in a ! (workspace: need 2*n*n + 2*n, prefer 2*n*n + n + n*nb) - call stdlib_dorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -76752,84 +76746,84 @@ module stdlib_linalg_lapack_d ! work(ir) ! (workspace: need 2*n*n + 4*n, ! prefer 2*n*n+3*n+2*n*nb) - call stdlib_dgebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib${ii}$_dgebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_dlacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib${ii}$_dlacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate left bidiagonalizing vectors in work(iu) ! (workspace: need 2*n*n + 4*n, prefer 2*n*n + 3*n + n*nb) - call stdlib_dorgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib${ii}$_dorgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in work(ir) ! (workspace: need 2*n*n + 4*n-1, ! prefer 2*n*n+3*n+(n-1)*nb) - call stdlib_dorgbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_dorgbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(iu) and computing ! right singular vectors of r in work(ir) ! (workspace: need 2*n*n + bdspac) - call stdlib_dbdsqr( 'U', n, n, n, 0, s, work( ie ),work( ir ), ldwrkr, & - work( iu ),ldwrku, dum, 1, work( iwork ), info ) + call stdlib${ii}$_dbdsqr( 'U', n, n, n, 0_${ik}$, s, work( ie ),work( ir ), ldwrkr, & + work( iu ),ldwrku, dum, 1_${ik}$, work( iwork ), info ) ! multiply q in a by left singular vectors of r in ! work(iu), storing result in u ! (workspace: need n*n) - call stdlib_dgemm( 'N', 'N', m, n, n, one, a, lda,work( iu ), ldwrku, & + call stdlib${ii}$_dgemm( 'N', 'N', m, n, n, one, a, lda,work( iu ), ldwrku, & zero, u, ldu ) ! copy right singular vectors of r to a ! (workspace: need n*n) - call stdlib_dlacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) + call stdlib${ii}$_dlacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_dlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_dlacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_dorgqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dorgqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! zero out below r in a - if( n > 1 ) then - call stdlib_dlaset( 'L', n-1, n-1, zero, zero,a( 2, 1 ), lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_dlaset( 'L', n-1, n-1, zero, zero,a( 2_${ik}$, 1_${ik}$ ), lda ) end if ! bidiagonalize r in a ! (workspace: need 4*n, prefer 3*n + 2*n*nb) - call stdlib_dgebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_dgebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left vectors bidiagonalizing r ! (workspace: need 3*n + m, prefer 3*n + m*nb) - call stdlib_dormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib${ii}$_dormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing r in a ! (workspace: need 4*n-1, prefer 3*n + (n-1)*nb) - call stdlib_dorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & + call stdlib${ii}$_dorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in a ! (workspace: need bdspac) - call stdlib_dbdsqr( 'U', n, n, m, 0, s, work( ie ), a,lda, u, ldu, dum, & - 1, work( iwork ),info ) + call stdlib${ii}$_dbdsqr( 'U', n, n, m, 0_${ik}$, s, work( ie ), a,lda, u, ldu, dum, & + 1_${ik}$, work( iwork ),info ) end if else if( wntvas ) then ! path 6 (m much larger than n, jobu='s', jobvt='s' ! or 'a') ! n left singular vectors to be computed in u and ! n right singular vectors to be computed in vt - if( lwork>=n*n+max( 4*n, bdspac ) ) then + if( lwork>=n*n+max( 4_${ik}$*n, bdspac ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+lda*n ) then ! work(iu) is lda by n ldwrku = lda @@ -76841,15 +76835,15 @@ module stdlib_linalg_lapack_d iwork = itau + n ! compute a=q*r ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_dlacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_dlaset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) + call stdlib${ii}$_dlacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_dlaset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) ! generate q in a ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_dorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -76857,46 +76851,46 @@ module stdlib_linalg_lapack_d iwork = itaup + n ! bidiagonalize r in work(iu), copying result to vt ! (workspace: need n*n + 4*n, prefer n*n + 3*n + 2*n*nb) - call stdlib_dgebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib${ii}$_dgebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_dlacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) + call stdlib${ii}$_dlacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) ! generate left bidiagonalizing vectors in work(iu) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + n*nb) - call stdlib_dorgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib${ii}$_dorgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (workspace: need n*n + 4*n-1, ! prefer n*n+3*n+(n-1)*nb) - call stdlib_dorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib${ii}$_dorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(iu) and computing ! right singular vectors of r in vt ! (workspace: need n*n + bdspac) - call stdlib_dbdsqr( 'U', n, n, n, 0, s, work( ie ), vt,ldvt, work( iu ),& - ldwrku, dum, 1,work( iwork ), info ) + call stdlib${ii}$_dbdsqr( 'U', n, n, n, 0_${ik}$, s, work( ie ), vt,ldvt, work( iu ),& + ldwrku, dum, 1_${ik}$,work( iwork ), info ) ! multiply q in a by left singular vectors of r in ! work(iu), storing result in u ! (workspace: need n*n) - call stdlib_dgemm( 'N', 'N', m, n, n, one, a, lda,work( iu ), ldwrku, & + call stdlib${ii}$_dgemm( 'N', 'N', m, n, n, one, a, lda,work( iu ), ldwrku, & zero, u, ldu ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_dlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_dlacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_dorgqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dorgqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to vt, zeroing out below it - call stdlib_dlacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_dlaset( 'L', n-1, n-1, zero, zero,vt( 2, 1 ), ldvt & + call stdlib${ii}$_dlacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1_${ik}$ )call stdlib${ii}$_dlaset( 'L', n-1, n-1, zero, zero,vt( 2_${ik}$, 1_${ik}$ ), ldvt & ) ie = itau itauq = ie + n @@ -76904,24 +76898,24 @@ module stdlib_linalg_lapack_d iwork = itaup + n ! bidiagonalize r in vt ! (workspace: need 4*n, prefer 3*n + 2*n*nb) - call stdlib_dgebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_dgebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in vt ! (workspace: need 3*n + m, prefer 3*n + m*nb) - call stdlib_dormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & + call stdlib${ii}$_dormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (workspace: need 4*n-1, prefer 3*n + (n-1)*nb) - call stdlib_dorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib${ii}$_dorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_dbdsqr( 'U', n, n, m, 0, s, work( ie ), vt,ldvt, u, ldu, & - dum, 1, work( iwork ),info ) + call stdlib${ii}$_dbdsqr( 'U', n, n, m, 0_${ik}$, s, work( ie ), vt,ldvt, u, ldu, & + dum, 1_${ik}$, work( iwork ),info ) end if end if else if( wntua ) then @@ -76929,9 +76923,9 @@ module stdlib_linalg_lapack_d ! path 7 (m much larger than n, jobu='a', jobvt='n') ! m left singular vectors to be computed in u and ! no right singular vectors to be computed - if( lwork>=n*n+max( n+m, 4*n, bdspac ) ) then + if( lwork>=n*n+max( n+m, 4_${ik}$*n, bdspac ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=wrkbl+lda*n ) then ! work(ir) is lda by n ldwrkr = lda @@ -76943,16 +76937,16 @@ module stdlib_linalg_lapack_d iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_dlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_dlacpy( 'L', m, n, a, lda, u, ldu ) ! copy r to work(ir), zeroing out below it - call stdlib_dlacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) - call stdlib_dlaset( 'L', n-1, n-1, zero, zero,work( ir+1 ), ldwrkr ) + call stdlib${ii}$_dlacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) + call stdlib${ii}$_dlaset( 'L', n-1, n-1, zero, zero,work( ir+1 ), ldwrkr ) ! generate q in u ! (workspace: need n*n + n + m, prefer n*n + n + m*nb) - call stdlib_dorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -76960,70 +76954,70 @@ module stdlib_linalg_lapack_d iwork = itaup + n ! bidiagonalize r in work(ir) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + 2*n*nb) - call stdlib_dgebrd( n, n, work( ir ), ldwrkr, s,work( ie ), work( itauq & + call stdlib${ii}$_dgebrd( n, n, work( ir ), ldwrkr, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in work(ir) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + n*nb) - call stdlib_dorgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_dorgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) ! (workspace: need n*n + bdspac) - call stdlib_dbdsqr( 'U', n, 0, n, 0, s, work( ie ), dum,1, work( ir ), & - ldwrkr, dum, 1,work( iwork ), info ) + call stdlib${ii}$_dbdsqr( 'U', n, 0_${ik}$, n, 0_${ik}$, s, work( ie ), dum,1_${ik}$, work( ir ), & + ldwrkr, dum, 1_${ik}$,work( iwork ), info ) ! multiply q in u by left singular vectors of r in ! work(ir), storing result in a ! (workspace: need n*n) - call stdlib_dgemm( 'N', 'N', m, n, n, one, u, ldu,work( ir ), ldwrkr, & + call stdlib${ii}$_dgemm( 'N', 'N', m, n, n, one, u, ldu,work( ir ), ldwrkr, & zero, a, lda ) ! copy left singular vectors of a from a to u - call stdlib_dlacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_dlacpy( 'F', m, n, a, lda, u, ldu ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_dlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_dlacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need n + m, prefer n + m*nb) - call stdlib_dorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! zero out below r in a - if( n > 1 ) then - call stdlib_dlaset( 'L', n-1, n-1, zero, zero,a( 2, 1 ), lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_dlaset( 'L', n-1, n-1, zero, zero,a( 2_${ik}$, 1_${ik}$ ), lda ) end if ! bidiagonalize r in a ! (workspace: need 4*n, prefer 3*n + 2*n*nb) - call stdlib_dgebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_dgebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in a ! (workspace: need 3*n + m, prefer 3*n + m*nb) - call stdlib_dormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib${ii}$_dormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u ! (workspace: need bdspac) - call stdlib_dbdsqr( 'U', n, 0, m, 0, s, work( ie ), dum,1, u, ldu, dum, & - 1, work( iwork ),info ) + call stdlib${ii}$_dbdsqr( 'U', n, 0_${ik}$, m, 0_${ik}$, s, work( ie ), dum,1_${ik}$, u, ldu, dum, & + 1_${ik}$, work( iwork ),info ) end if else if( wntvo ) then ! path 8 (m much larger than n, jobu='a', jobvt='o') ! m left singular vectors to be computed in u and ! n right singular vectors to be overwritten on a - if( lwork>=2*n*n+max( n+m, 4*n, bdspac ) ) then + if( lwork>=2_${ik}$*n*n+max( n+m, 4_${ik}$*n, bdspac ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+2*lda*n ) then ! work(iu) is lda by n and work(ir) is lda by n ldwrku = lda @@ -77044,16 +77038,16 @@ module stdlib_linalg_lapack_d iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n*n + 2*n, prefer 2*n*n + n + n*nb) - call stdlib_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_dlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_dlacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need 2*n*n + n + m, prefer 2*n*n + n + m*nb) - call stdlib_dorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_dlacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_dlaset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) + call stdlib${ii}$_dlacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_dlaset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) ie = itau itauq = ie + n @@ -77063,86 +77057,86 @@ module stdlib_linalg_lapack_d ! work(ir) ! (workspace: need 2*n*n + 4*n, ! prefer 2*n*n+3*n+2*n*nb) - call stdlib_dgebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib${ii}$_dgebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_dlacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib${ii}$_dlacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate left bidiagonalizing vectors in work(iu) ! (workspace: need 2*n*n + 4*n, prefer 2*n*n + 3*n + n*nb) - call stdlib_dorgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib${ii}$_dorgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in work(ir) ! (workspace: need 2*n*n + 4*n-1, ! prefer 2*n*n+3*n+(n-1)*nb) - call stdlib_dorgbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_dorgbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(iu) and computing ! right singular vectors of r in work(ir) ! (workspace: need 2*n*n + bdspac) - call stdlib_dbdsqr( 'U', n, n, n, 0, s, work( ie ),work( ir ), ldwrkr, & - work( iu ),ldwrku, dum, 1, work( iwork ), info ) + call stdlib${ii}$_dbdsqr( 'U', n, n, n, 0_${ik}$, s, work( ie ),work( ir ), ldwrkr, & + work( iu ),ldwrku, dum, 1_${ik}$, work( iwork ), info ) ! multiply q in u by left singular vectors of r in ! work(iu), storing result in a ! (workspace: need n*n) - call stdlib_dgemm( 'N', 'N', m, n, n, one, u, ldu,work( iu ), ldwrku, & + call stdlib${ii}$_dgemm( 'N', 'N', m, n, n, one, u, ldu,work( iu ), ldwrku, & zero, a, lda ) ! copy left singular vectors of a from a to u - call stdlib_dlacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_dlacpy( 'F', m, n, a, lda, u, ldu ) ! copy right singular vectors of r from work(ir) to a - call stdlib_dlacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) + call stdlib${ii}$_dlacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_dlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_dlacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need n + m, prefer n + m*nb) - call stdlib_dorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! zero out below r in a - if( n > 1 ) then - call stdlib_dlaset( 'L', n-1, n-1, zero, zero,a( 2, 1 ), lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_dlaset( 'L', n-1, n-1, zero, zero,a( 2_${ik}$, 1_${ik}$ ), lda ) end if ! bidiagonalize r in a ! (workspace: need 4*n, prefer 3*n + 2*n*nb) - call stdlib_dgebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_dgebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in a ! (workspace: need 3*n + m, prefer 3*n + m*nb) - call stdlib_dormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib${ii}$_dormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in a ! (workspace: need 4*n-1, prefer 3*n + (n-1)*nb) - call stdlib_dorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & + call stdlib${ii}$_dorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in a ! (workspace: need bdspac) - call stdlib_dbdsqr( 'U', n, n, m, 0, s, work( ie ), a,lda, u, ldu, dum, & - 1, work( iwork ),info ) + call stdlib${ii}$_dbdsqr( 'U', n, n, m, 0_${ik}$, s, work( ie ), a,lda, u, ldu, dum, & + 1_${ik}$, work( iwork ),info ) end if else if( wntvas ) then ! path 9 (m much larger than n, jobu='a', jobvt='s' ! or 'a') ! m left singular vectors to be computed in u and ! n right singular vectors to be computed in vt - if( lwork>=n*n+max( n+m, 4*n, bdspac ) ) then + if( lwork>=n*n+max( n+m, 4_${ik}$*n, bdspac ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+lda*n ) then ! work(iu) is lda by n ldwrku = lda @@ -77154,16 +77148,16 @@ module stdlib_linalg_lapack_d iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_dlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_dlacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need n*n + n + m, prefer n*n + n + m*nb) - call stdlib_dorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_dlacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_dlaset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) + call stdlib${ii}$_dlacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_dlaset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) ie = itau itauq = ie + n @@ -77171,48 +77165,48 @@ module stdlib_linalg_lapack_d iwork = itaup + n ! bidiagonalize r in work(iu), copying result to vt ! (workspace: need n*n + 4*n, prefer n*n + 3*n + 2*n*nb) - call stdlib_dgebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib${ii}$_dgebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_dlacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) + call stdlib${ii}$_dlacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) ! generate left bidiagonalizing vectors in work(iu) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + n*nb) - call stdlib_dorgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib${ii}$_dorgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (workspace: need n*n + 4*n-1, ! prefer n*n+3*n+(n-1)*nb) - call stdlib_dorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib${ii}$_dorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(iu) and computing ! right singular vectors of r in vt ! (workspace: need n*n + bdspac) - call stdlib_dbdsqr( 'U', n, n, n, 0, s, work( ie ), vt,ldvt, work( iu ),& - ldwrku, dum, 1,work( iwork ), info ) + call stdlib${ii}$_dbdsqr( 'U', n, n, n, 0_${ik}$, s, work( ie ), vt,ldvt, work( iu ),& + ldwrku, dum, 1_${ik}$,work( iwork ), info ) ! multiply q in u by left singular vectors of r in ! work(iu), storing result in a ! (workspace: need n*n) - call stdlib_dgemm( 'N', 'N', m, n, n, one, u, ldu,work( iu ), ldwrku, & + call stdlib${ii}$_dgemm( 'N', 'N', m, n, n, one, u, ldu,work( iu ), ldwrku, & zero, a, lda ) ! copy left singular vectors of a from a to u - call stdlib_dlacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_dlacpy( 'F', m, n, a, lda, u, ldu ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_dlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_dlacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need n + m, prefer n + m*nb) - call stdlib_dorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r from a to vt, zeroing out below it - call stdlib_dlacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_dlaset( 'L', n-1, n-1, zero, zero,vt( 2, 1 ), ldvt & + call stdlib${ii}$_dlacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1_${ik}$ )call stdlib${ii}$_dlaset( 'L', n-1, n-1, zero, zero,vt( 2_${ik}$, 1_${ik}$ ), ldvt & ) ie = itau itauq = ie + n @@ -77220,24 +77214,24 @@ module stdlib_linalg_lapack_d iwork = itaup + n ! bidiagonalize r in vt ! (workspace: need 4*n, prefer 3*n + 2*n*nb) - call stdlib_dgebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_dgebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in vt ! (workspace: need 3*n + m, prefer 3*n + m*nb) - call stdlib_dormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & + call stdlib${ii}$_dormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (workspace: need 4*n-1, prefer 3*n + (n-1)*nb) - call stdlib_dorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib${ii}$_dorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_dbdsqr( 'U', n, n, m, 0, s, work( ie ), vt,ldvt, u, ldu, & - dum, 1, work( iwork ),info ) + call stdlib${ii}$_dbdsqr( 'U', n, n, m, 0_${ik}$, s, work( ie ), vt,ldvt, u, ldu, & + dum, 1_${ik}$, work( iwork ),info ) end if end if end if @@ -77245,72 +77239,72 @@ module stdlib_linalg_lapack_d ! m < mnthr ! path 10 (m at least n, but not much larger) ! reduce to bidiagonal form without qr decomposition - ie = 1 + ie = 1_${ik}$ itauq = ie + n itaup = itauq + n iwork = itaup + n ! bidiagonalize a ! (workspace: need 3*n + m, prefer 3*n + (m + n)*nb) - call stdlib_dgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_dgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,ierr ) if( wntuas ) then ! if left singular vectors desired in u, copy result to u ! and generate left bidiagonalizing vectors in u ! (workspace: need 3*n + ncu, prefer 3*n + ncu*nb) - call stdlib_dlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_dlacpy( 'L', m, n, a, lda, u, ldu ) if( wntus )ncu = n if( wntua )ncu = m - call stdlib_dorgbr( 'Q', m, ncu, n, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_dorgbr( 'Q', m, ncu, n, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) end if if( wntvas ) then ! if right singular vectors desired in vt, copy result to ! vt and generate right bidiagonalizing vectors in vt ! (workspace: need 4*n-1, prefer 3*n + (n-1)*nb) - call stdlib_dlacpy( 'U', n, n, a, lda, vt, ldvt ) - call stdlib_dorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib${ii}$_dlacpy( 'U', n, n, a, lda, vt, ldvt ) + call stdlib${ii}$_dorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) end if if( wntuo ) then ! if left singular vectors desired in a, generate left ! bidiagonalizing vectors in a ! (workspace: need 4*n, prefer 3*n + n*nb) - call stdlib_dorgbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), lwork-& + call stdlib${ii}$_dorgbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), lwork-& iwork+1, ierr ) end if if( wntvo ) then ! if right singular vectors desired in a, generate right ! bidiagonalizing vectors in a ! (workspace: need 4*n-1, prefer 3*n + (n-1)*nb) - call stdlib_dorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-& + call stdlib${ii}$_dorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-& iwork+1, ierr ) end if iwork = ie + n if( wntuas .or. wntuo )nru = m - if( wntun )nru = 0 + if( wntun )nru = 0_${ik}$ if( wntvas .or. wntvo )ncvt = n - if( wntvn )ncvt = 0 + if( wntvn )ncvt = 0_${ik}$ if( ( .not.wntuo ) .and. ( .not.wntvo ) ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in vt ! (workspace: need bdspac) - call stdlib_dbdsqr( 'U', n, ncvt, nru, 0, s, work( ie ), vt,ldvt, u, ldu, dum,& - 1, work( iwork ), info ) + call stdlib${ii}$_dbdsqr( 'U', n, ncvt, nru, 0_${ik}$, s, work( ie ), vt,ldvt, u, ldu, dum,& + 1_${ik}$, work( iwork ), info ) else if( ( .not.wntuo ) .and. wntvo ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in a ! (workspace: need bdspac) - call stdlib_dbdsqr( 'U', n, ncvt, nru, 0, s, work( ie ), a, lda,u, ldu, dum, & - 1, work( iwork ), info ) + call stdlib${ii}$_dbdsqr( 'U', n, ncvt, nru, 0_${ik}$, s, work( ie ), a, lda,u, ldu, dum, & + 1_${ik}$, work( iwork ), info ) else ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in a and computing right singular ! vectors in vt ! (workspace: need bdspac) - call stdlib_dbdsqr( 'U', n, ncvt, nru, 0, s, work( ie ), vt,ldvt, a, lda, dum,& - 1, work( iwork ), info ) + call stdlib${ii}$_dbdsqr( 'U', n, ncvt, nru, 0_${ik}$, s, work( ie ), vt,ldvt, a, lda, dum,& + 1_${ik}$, work( iwork ), info ) end if end if else @@ -77321,45 +77315,45 @@ module stdlib_linalg_lapack_d if( wntvn ) then ! path 1t(n much larger than m, jobvt='n') ! no right singular vectors to be computed - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_dgelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & + call stdlib${ii}$_dgelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & ierr ) ! zero out above l - if (m>1) call stdlib_dlaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ), lda ) - ie = 1 + if (m>1_${ik}$) call stdlib${ii}$_dlaset( 'U', m-1, m-1, zero, zero, a( 1_${ik}$, 2_${ik}$ ), lda ) + ie = 1_${ik}$ itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize l in a ! (workspace: need 4*m, prefer 3*m + 2*m*nb) - call stdlib_dgebrd( m, m, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_dgebrd( m, m, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,ierr ) if( wntuo .or. wntuas ) then ! if left singular vectors desired, generate q ! (workspace: need 4*m, prefer 3*m + m*nb) - call stdlib_dorgbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & + call stdlib${ii}$_dorgbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) end if iwork = ie + m - nru = 0 + nru = 0_${ik}$ if( wntuo .or. wntuas )nru = m ! perform bidiagonal qr iteration, computing left singular ! vectors of a in a if desired ! (workspace: need bdspac) - call stdlib_dbdsqr( 'U', m, 0, nru, 0, s, work( ie ), dum, 1, a,lda, dum, 1, & + call stdlib${ii}$_dbdsqr( 'U', m, 0_${ik}$, nru, 0_${ik}$, s, work( ie ), dum, 1_${ik}$, a,lda, dum, 1_${ik}$, & work( iwork ), info ) ! if left singular vectors desired in u, copy them there - if( wntuas )call stdlib_dlacpy( 'F', m, m, a, lda, u, ldu ) + if( wntuas )call stdlib${ii}$_dlacpy( 'F', m, m, a, lda, u, ldu ) else if( wntvo .and. wntun ) then ! path 2t(n much larger than m, jobu='n', jobvt='o') ! m right singular vectors to be overwritten on a and ! no left singular vectors to be computed - if( lwork>=m*m+max( 4*m, bdspac ) ) then + if( lwork>=m*m+max( 4_${ik}$*m, bdspac ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=max( wrkbl, lda*n + m ) + lda*m ) then ! work(iu) is lda by n and work(ir) is lda by m ldwrku = lda @@ -77380,15 +77374,15 @@ module stdlib_linalg_lapack_d iwork = itau + m ! compute a=l*q ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy l to work(ir) and zero out above it - call stdlib_dlacpy( 'L', m, m, a, lda, work( ir ), ldwrkr ) - call stdlib_dlaset( 'U', m-1, m-1, zero, zero,work( ir+ldwrkr ), ldwrkr ) + call stdlib${ii}$_dlacpy( 'L', m, m, a, lda, work( ir ), ldwrkr ) + call stdlib${ii}$_dlaset( 'U', m-1, m-1, zero, zero,work( ir+ldwrkr ), ldwrkr ) ! generate q in a ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_dorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + m @@ -77396,57 +77390,57 @@ module stdlib_linalg_lapack_d iwork = itaup + m ! bidiagonalize l in work(ir) ! (workspace: need m*m + 4*m, prefer m*m + 3*m + 2*m*nb) - call stdlib_dgebrd( m, m, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & + call stdlib${ii}$_dgebrd( m, m, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & work( itaup ),work( iwork ), lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing l ! (workspace: need m*m + 4*m-1, prefer m*m + 3*m + (m-1)*nb) - call stdlib_dorgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & + call stdlib${ii}$_dorgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & iwork ),lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of l in work(ir) ! (workspace: need m*m + bdspac) - call stdlib_dbdsqr( 'U', m, m, 0, 0, s, work( ie ),work( ir ), ldwrkr, dum,& - 1, dum, 1,work( iwork ), info ) + call stdlib${ii}$_dbdsqr( 'U', m, m, 0_${ik}$, 0_${ik}$, s, work( ie ),work( ir ), ldwrkr, dum,& + 1_${ik}$, dum, 1_${ik}$,work( iwork ), info ) iu = ie + m ! multiply right singular vectors of l in work(ir) by q ! in a, storing result in work(iu) and copying to a ! (workspace: need m*m + 2*m, prefer m*m + m*n + m) do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_dgemm( 'N', 'N', m, blk, m, one, work( ir ),ldwrkr, a( 1, i & + call stdlib${ii}$_dgemm( 'N', 'N', m, blk, m, one, work( ir ),ldwrkr, a( 1_${ik}$, i & ), lda, zero,work( iu ), ldwrku ) - call stdlib_dlacpy( 'F', m, blk, work( iu ), ldwrku,a( 1, i ), lda ) + call stdlib${ii}$_dlacpy( 'F', m, blk, work( iu ), ldwrku,a( 1_${ik}$, i ), lda ) end do else ! insufficient workspace for a fast algorithm - ie = 1 + ie = 1_${ik}$ itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize a ! (workspace: need 3*m + n, prefer 3*m + (m + n)*nb) - call stdlib_dgebrd( m, n, a, lda, s, work( ie ),work( itauq ), work( itaup & + call stdlib${ii}$_dgebrd( m, n, a, lda, s, work( ie ),work( itauq ), work( itaup & ),work( iwork ), lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing a ! (workspace: need 4*m, prefer 3*m + m*nb) - call stdlib_dorgbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), & + call stdlib${ii}$_dorgbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of a in a ! (workspace: need bdspac) - call stdlib_dbdsqr( 'L', m, n, 0, 0, s, work( ie ), a, lda,dum, 1, dum, 1, & + call stdlib${ii}$_dbdsqr( 'L', m, n, 0_${ik}$, 0_${ik}$, s, work( ie ), a, lda,dum, 1_${ik}$, dum, 1_${ik}$, & work( iwork ), info ) end if else if( wntvo .and. wntuas ) then ! path 3t(n much larger than m, jobu='s' or 'a', jobvt='o') ! m right singular vectors to be overwritten on a and ! m left singular vectors to be computed in u - if( lwork>=m*m+max( 4*m, bdspac ) ) then + if( lwork>=m*m+max( 4_${ik}$*m, bdspac ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=max( wrkbl, lda*n + m ) + lda*m ) then ! work(iu) is lda by n and work(ir) is lda by m ldwrku = lda @@ -77467,14 +77461,14 @@ module stdlib_linalg_lapack_d iwork = itau + m ! compute a=l*q ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy l to u, zeroing about above it - call stdlib_dlacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_dlaset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu ) + call stdlib${ii}$_dlacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1_${ik}$) call stdlib${ii}$_dlaset( 'U', m-1, m-1, zero, zero, u( 1_${ik}$, 2_${ik}$ ),ldu ) ! generate q in a ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_dorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + m @@ -77482,49 +77476,49 @@ module stdlib_linalg_lapack_d iwork = itaup + m ! bidiagonalize l in u, copying result to work(ir) ! (workspace: need m*m + 4*m, prefer m*m + 3*m + 2*m*nb) - call stdlib_dgebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( itaup & + call stdlib${ii}$_dgebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( itaup & ),work( iwork ), lwork-iwork+1, ierr ) - call stdlib_dlacpy( 'U', m, m, u, ldu, work( ir ), ldwrkr ) + call stdlib${ii}$_dlacpy( 'U', m, m, u, ldu, work( ir ), ldwrkr ) ! generate right vectors bidiagonalizing l in work(ir) ! (workspace: need m*m + 4*m-1, prefer m*m + 3*m + (m-1)*nb) - call stdlib_dorgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & + call stdlib${ii}$_dorgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & iwork ),lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing l in u ! (workspace: need m*m + 4*m, prefer m*m + 3*m + m*nb) - call stdlib_dorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_dorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of l in u, and computing right ! singular vectors of l in work(ir) ! (workspace: need m*m + bdspac) - call stdlib_dbdsqr( 'U', m, m, m, 0, s, work( ie ),work( ir ), ldwrkr, u, & - ldu, dum, 1,work( iwork ), info ) + call stdlib${ii}$_dbdsqr( 'U', m, m, m, 0_${ik}$, s, work( ie ),work( ir ), ldwrkr, u, & + ldu, dum, 1_${ik}$,work( iwork ), info ) iu = ie + m ! multiply right singular vectors of l in work(ir) by q ! in a, storing result in work(iu) and copying to a ! (workspace: need m*m + 2*m, prefer m*m + m*n + m)) do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_dgemm( 'N', 'N', m, blk, m, one, work( ir ),ldwrkr, a( 1, i & + call stdlib${ii}$_dgemm( 'N', 'N', m, blk, m, one, work( ir ),ldwrkr, a( 1_${ik}$, i & ), lda, zero,work( iu ), ldwrku ) - call stdlib_dlacpy( 'F', m, blk, work( iu ), ldwrku,a( 1, i ), lda ) + call stdlib${ii}$_dlacpy( 'F', m, blk, work( iu ), ldwrku,a( 1_${ik}$, i ), lda ) end do else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy l to u, zeroing out above it - call stdlib_dlacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_dlaset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu ) + call stdlib${ii}$_dlacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1_${ik}$) call stdlib${ii}$_dlaset( 'U', m-1, m-1, zero, zero, u( 1_${ik}$, 2_${ik}$ ),ldu ) ! generate q in a ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_dorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + m @@ -77532,22 +77526,22 @@ module stdlib_linalg_lapack_d iwork = itaup + m ! bidiagonalize l in u ! (workspace: need 4*m, prefer 3*m + 2*m*nb) - call stdlib_dgebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( itaup & + call stdlib${ii}$_dgebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( itaup & ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right vectors bidiagonalizing l by q in a ! (workspace: need 3*m + n, prefer 3*m + n*nb) - call stdlib_dormbr( 'P', 'L', 'T', m, n, m, u, ldu,work( itaup ), a, lda, & + call stdlib${ii}$_dormbr( 'P', 'L', 'T', m, n, m, u, ldu,work( itaup ), a, lda, & work( iwork ),lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing l in u ! (workspace: need 4*m, prefer 3*m + m*nb) - call stdlib_dorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_dorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in a ! (workspace: need bdspac) - call stdlib_dbdsqr( 'U', m, n, m, 0, s, work( ie ), a, lda,u, ldu, dum, 1, & + call stdlib${ii}$_dbdsqr( 'U', m, n, m, 0_${ik}$, s, work( ie ), a, lda,u, ldu, dum, 1_${ik}$, & work( iwork ), info ) end if else if( wntvs ) then @@ -77555,9 +77549,9 @@ module stdlib_linalg_lapack_d ! path 4t(n much larger than m, jobu='n', jobvt='s') ! m right singular vectors to be computed in vt and ! no left singular vectors to be computed - if( lwork>=m*m+max( 4*m, bdspac ) ) then + if( lwork>=m*m+max( 4_${ik}$*m, bdspac ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=wrkbl+lda*m ) then ! work(ir) is lda by m ldwrkr = lda @@ -77569,15 +77563,15 @@ module stdlib_linalg_lapack_d iwork = itau + m ! compute a=l*q ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy l to work(ir), zeroing out above it - call stdlib_dlacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) - call stdlib_dlaset( 'U', m-1, m-1, zero, zero,work( ir+ldwrkr ), ldwrkr & + call stdlib${ii}$_dlacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) + call stdlib${ii}$_dlaset( 'U', m-1, m-1, zero, zero,work( ir+ldwrkr ), ldwrkr & ) ! generate q in a ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_dorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + m @@ -77585,66 +77579,66 @@ module stdlib_linalg_lapack_d iwork = itaup + m ! bidiagonalize l in work(ir) ! (workspace: need m*m + 4*m, prefer m*m + 3*m + 2*m*nb) - call stdlib_dgebrd( m, m, work( ir ), ldwrkr, s,work( ie ), work( itauq & + call stdlib${ii}$_dgebrd( m, m, work( ir ), ldwrkr, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing l in ! work(ir) ! (workspace: need m*m + 4*m, prefer m*m + 3*m + (m-1)*nb) - call stdlib_dorgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_dorgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of l in work(ir) ! (workspace: need m*m + bdspac) - call stdlib_dbdsqr( 'U', m, m, 0, 0, s, work( ie ),work( ir ), ldwrkr, & - dum, 1, dum, 1,work( iwork ), info ) + call stdlib${ii}$_dbdsqr( 'U', m, m, 0_${ik}$, 0_${ik}$, s, work( ie ),work( ir ), ldwrkr, & + dum, 1_${ik}$, dum, 1_${ik}$,work( iwork ), info ) ! multiply right singular vectors of l in work(ir) by ! q in a, storing result in vt ! (workspace: need m*m) - call stdlib_dgemm( 'N', 'N', m, n, m, one, work( ir ),ldwrkr, a, lda, & + call stdlib${ii}$_dgemm( 'N', 'N', m, n, m, one, work( ir ),ldwrkr, a, lda, & zero, vt, ldvt ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy result to vt - call stdlib_dlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_dlacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_dorglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_dorglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_dlaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda ) + if (m>1_${ik}$) call stdlib${ii}$_dlaset( 'U', m-1, m-1, zero, zero, a( 1_${ik}$, 2_${ik}$ ),lda ) ! bidiagonalize l in a ! (workspace: need 4*m, prefer 3*m + 2*m*nb) - call stdlib_dgebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_dgebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right vectors bidiagonalizing l by q in vt ! (workspace: need 3*m + n, prefer 3*m + n*nb) - call stdlib_dormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & + call stdlib${ii}$_dormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_dbdsqr( 'U', m, n, 0, 0, s, work( ie ), vt,ldvt, dum, 1, & - dum, 1, work( iwork ),info ) + call stdlib${ii}$_dbdsqr( 'U', m, n, 0_${ik}$, 0_${ik}$, s, work( ie ), vt,ldvt, dum, 1_${ik}$, & + dum, 1_${ik}$, work( iwork ),info ) end if else if( wntuo ) then ! path 5t(n much larger than m, jobu='o', jobvt='s') ! m right singular vectors to be computed in vt and ! m left singular vectors to be overwritten on a - if( lwork>=2*m*m+max( 4*m, bdspac ) ) then + if( lwork>=2_${ik}$*m*m+max( 4_${ik}$*m, bdspac ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+2*lda*m ) then ! work(iu) is lda by m and work(ir) is lda by m ldwrku = lda @@ -77665,15 +77659,15 @@ module stdlib_linalg_lapack_d iwork = itau + m ! compute a=l*q ! (workspace: need 2*m*m + 2*m, prefer 2*m*m + m + m*nb) - call stdlib_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy l to work(iu), zeroing out below it - call stdlib_dlacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_dlaset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & + call stdlib${ii}$_dlacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_dlaset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & ) ! generate q in a ! (workspace: need 2*m*m + 2*m, prefer 2*m*m + m + m*nb) - call stdlib_dorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + m @@ -77683,81 +77677,81 @@ module stdlib_linalg_lapack_d ! work(ir) ! (workspace: need 2*m*m + 4*m, ! prefer 2*m*m+3*m+2*m*nb) - call stdlib_dgebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib${ii}$_dgebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_dlacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib${ii}$_dlacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate right bidiagonalizing vectors in work(iu) ! (workspace: need 2*m*m + 4*m-1, ! prefer 2*m*m+3*m+(m-1)*nb) - call stdlib_dorgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib${ii}$_dorgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in work(ir) ! (workspace: need 2*m*m + 4*m, prefer 2*m*m + 3*m + m*nb) - call stdlib_dorgbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_dorgbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of l in work(ir) and computing ! right singular vectors of l in work(iu) ! (workspace: need 2*m*m + bdspac) - call stdlib_dbdsqr( 'U', m, m, m, 0, s, work( ie ),work( iu ), ldwrku, & - work( ir ),ldwrkr, dum, 1, work( iwork ), info ) + call stdlib${ii}$_dbdsqr( 'U', m, m, m, 0_${ik}$, s, work( ie ),work( iu ), ldwrku, & + work( ir ),ldwrkr, dum, 1_${ik}$, work( iwork ), info ) ! multiply right singular vectors of l in work(iu) by ! q in a, storing result in vt ! (workspace: need m*m) - call stdlib_dgemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, a, lda, & + call stdlib${ii}$_dgemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, a, lda, & zero, vt, ldvt ) ! copy left singular vectors of l to a ! (workspace: need m*m) - call stdlib_dlacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) + call stdlib${ii}$_dlacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_dlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_dlacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_dorglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_dorglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_dlaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda ) + if (m>1_${ik}$) call stdlib${ii}$_dlaset( 'U', m-1, m-1, zero, zero, a( 1_${ik}$, 2_${ik}$ ),lda ) ! bidiagonalize l in a ! (workspace: need 4*m, prefer 3*m + 2*m*nb) - call stdlib_dgebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_dgebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right vectors bidiagonalizing l by q in vt ! (workspace: need 3*m + n, prefer 3*m + n*nb) - call stdlib_dormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & + call stdlib${ii}$_dormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors of l in a ! (workspace: need 4*m, prefer 3*m + m*nb) - call stdlib_dorgbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & + call stdlib${ii}$_dorgbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, compute left ! singular vectors of a in a and compute right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_dbdsqr( 'U', m, n, m, 0, s, work( ie ), vt,ldvt, a, lda, & - dum, 1, work( iwork ),info ) + call stdlib${ii}$_dbdsqr( 'U', m, n, m, 0_${ik}$, s, work( ie ), vt,ldvt, a, lda, & + dum, 1_${ik}$, work( iwork ),info ) end if else if( wntuas ) then ! path 6t(n much larger than m, jobu='s' or 'a', ! jobvt='s') ! m right singular vectors to be computed in vt and ! m left singular vectors to be computed in u - if( lwork>=m*m+max( 4*m, bdspac ) ) then + if( lwork>=m*m+max( 4_${ik}$*m, bdspac ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+lda*m ) then ! work(iu) is lda by n ldwrku = lda @@ -77769,15 +77763,15 @@ module stdlib_linalg_lapack_d iwork = itau + m ! compute a=l*q ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy l to work(iu), zeroing out above it - call stdlib_dlacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_dlaset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & + call stdlib${ii}$_dlacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_dlaset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & ) ! generate q in a ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_dorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + m @@ -77785,70 +77779,70 @@ module stdlib_linalg_lapack_d iwork = itaup + m ! bidiagonalize l in work(iu), copying result to u ! (workspace: need m*m + 4*m, prefer m*m + 3*m + 2*m*nb) - call stdlib_dgebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib${ii}$_dgebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_dlacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) + call stdlib${ii}$_dlacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) ! generate right bidiagonalizing vectors in work(iu) ! (workspace: need m*m + 4*m-1, ! prefer m*m+3*m+(m-1)*nb) - call stdlib_dorgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib${ii}$_dorgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (workspace: need m*m + 4*m, prefer m*m + 3*m + m*nb) - call stdlib_dorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_dorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of l in u and computing right ! singular vectors of l in work(iu) ! (workspace: need m*m + bdspac) - call stdlib_dbdsqr( 'U', m, m, m, 0, s, work( ie ),work( iu ), ldwrku, & - u, ldu, dum, 1,work( iwork ), info ) + call stdlib${ii}$_dbdsqr( 'U', m, m, m, 0_${ik}$, s, work( ie ),work( iu ), ldwrku, & + u, ldu, dum, 1_${ik}$,work( iwork ), info ) ! multiply right singular vectors of l in work(iu) by ! q in a, storing result in vt ! (workspace: need m*m) - call stdlib_dgemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, a, lda, & + call stdlib${ii}$_dgemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, a, lda, & zero, vt, ldvt ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_dlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_dlacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_dorglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_dorglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to u, zeroing out above it - call stdlib_dlacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_dlaset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu ) + call stdlib${ii}$_dlacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1_${ik}$) call stdlib${ii}$_dlaset( 'U', m-1, m-1, zero, zero, u( 1_${ik}$, 2_${ik}$ ),ldu ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize l in u ! (workspace: need 4*m, prefer 3*m + 2*m*nb) - call stdlib_dgebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_dgebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in u by q ! in vt ! (workspace: need 3*m + n, prefer 3*m + n*nb) - call stdlib_dormbr( 'P', 'L', 'T', m, n, m, u, ldu,work( itaup ), vt, & + call stdlib${ii}$_dormbr( 'P', 'L', 'T', m, n, m, u, ldu,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (workspace: need 4*m, prefer 3*m + m*nb) - call stdlib_dorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_dorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_dbdsqr( 'U', m, n, m, 0, s, work( ie ), vt,ldvt, u, ldu, & - dum, 1, work( iwork ),info ) + call stdlib${ii}$_dbdsqr( 'U', m, n, m, 0_${ik}$, s, work( ie ), vt,ldvt, u, ldu, & + dum, 1_${ik}$, work( iwork ),info ) end if end if else if( wntva ) then @@ -77856,9 +77850,9 @@ module stdlib_linalg_lapack_d ! path 7t(n much larger than m, jobu='n', jobvt='a') ! n right singular vectors to be computed in vt and ! no left singular vectors to be computed - if( lwork>=m*m+max( n + m, 4*m, bdspac ) ) then + if( lwork>=m*m+max( n + m, 4_${ik}$*m, bdspac ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=wrkbl+lda*m ) then ! work(ir) is lda by m ldwrkr = lda @@ -77870,16 +77864,16 @@ module stdlib_linalg_lapack_d iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_dlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_dlacpy( 'U', m, n, a, lda, vt, ldvt ) ! copy l to work(ir), zeroing out above it - call stdlib_dlacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) - call stdlib_dlaset( 'U', m-1, m-1, zero, zero,work( ir+ldwrkr ), ldwrkr & + call stdlib${ii}$_dlacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) + call stdlib${ii}$_dlaset( 'U', m-1, m-1, zero, zero,work( ir+ldwrkr ), ldwrkr & ) ! generate q in vt ! (workspace: need m*m + m + n, prefer m*m + m + n*nb) - call stdlib_dorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_dorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = itau itauq = ie + m @@ -77887,68 +77881,68 @@ module stdlib_linalg_lapack_d iwork = itaup + m ! bidiagonalize l in work(ir) ! (workspace: need m*m + 4*m, prefer m*m + 3*m + 2*m*nb) - call stdlib_dgebrd( m, m, work( ir ), ldwrkr, s,work( ie ), work( itauq & + call stdlib${ii}$_dgebrd( m, m, work( ir ), ldwrkr, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in work(ir) ! (workspace: need m*m + 4*m-1, ! prefer m*m+3*m+(m-1)*nb) - call stdlib_dorgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_dorgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of l in work(ir) ! (workspace: need m*m + bdspac) - call stdlib_dbdsqr( 'U', m, m, 0, 0, s, work( ie ),work( ir ), ldwrkr, & - dum, 1, dum, 1,work( iwork ), info ) + call stdlib${ii}$_dbdsqr( 'U', m, m, 0_${ik}$, 0_${ik}$, s, work( ie ),work( ir ), ldwrkr, & + dum, 1_${ik}$, dum, 1_${ik}$,work( iwork ), info ) ! multiply right singular vectors of l in work(ir) by ! q in vt, storing result in a ! (workspace: need m*m) - call stdlib_dgemm( 'N', 'N', m, n, m, one, work( ir ),ldwrkr, vt, ldvt, & + call stdlib${ii}$_dgemm( 'N', 'N', m, n, m, one, work( ir ),ldwrkr, vt, ldvt, & zero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_dlacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_dlacpy( 'F', m, n, a, lda, vt, ldvt ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_dlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_dlacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need m + n, prefer m + n*nb) - call stdlib_dorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_dorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_dlaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda ) + if (m>1_${ik}$) call stdlib${ii}$_dlaset( 'U', m-1, m-1, zero, zero, a( 1_${ik}$, 2_${ik}$ ),lda ) ! bidiagonalize l in a ! (workspace: need 4*m, prefer 3*m + 2*m*nb) - call stdlib_dgebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_dgebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in a by q ! in vt ! (workspace: need 3*m + n, prefer 3*m + n*nb) - call stdlib_dormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & + call stdlib${ii}$_dormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_dbdsqr( 'U', m, n, 0, 0, s, work( ie ), vt,ldvt, dum, 1, & - dum, 1, work( iwork ),info ) + call stdlib${ii}$_dbdsqr( 'U', m, n, 0_${ik}$, 0_${ik}$, s, work( ie ), vt,ldvt, dum, 1_${ik}$, & + dum, 1_${ik}$, work( iwork ),info ) end if else if( wntuo ) then ! path 8t(n much larger than m, jobu='o', jobvt='a') ! n right singular vectors to be computed in vt and ! m left singular vectors to be overwritten on a - if( lwork>=2*m*m+max( n + m, 4*m, bdspac ) ) then + if( lwork>=2_${ik}$*m*m+max( n + m, 4_${ik}$*m, bdspac ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+2*lda*m ) then ! work(iu) is lda by m and work(ir) is lda by m ldwrku = lda @@ -77969,16 +77963,16 @@ module stdlib_linalg_lapack_d iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need 2*m*m + 2*m, prefer 2*m*m + m + m*nb) - call stdlib_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_dlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_dlacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need 2*m*m + m + n, prefer 2*m*m + m + n*nb) - call stdlib_dorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_dorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to work(iu), zeroing out above it - call stdlib_dlacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_dlaset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & + call stdlib${ii}$_dlacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_dlaset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & ) ie = itau itauq = ie + m @@ -77988,83 +77982,83 @@ module stdlib_linalg_lapack_d ! work(ir) ! (workspace: need 2*m*m + 4*m, ! prefer 2*m*m+3*m+2*m*nb) - call stdlib_dgebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib${ii}$_dgebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_dlacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib${ii}$_dlacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate right bidiagonalizing vectors in work(iu) ! (workspace: need 2*m*m + 4*m-1, ! prefer 2*m*m+3*m+(m-1)*nb) - call stdlib_dorgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib${ii}$_dorgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in work(ir) ! (workspace: need 2*m*m + 4*m, prefer 2*m*m + 3*m + m*nb) - call stdlib_dorgbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_dorgbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of l in work(ir) and computing ! right singular vectors of l in work(iu) ! (workspace: need 2*m*m + bdspac) - call stdlib_dbdsqr( 'U', m, m, m, 0, s, work( ie ),work( iu ), ldwrku, & - work( ir ),ldwrkr, dum, 1, work( iwork ), info ) + call stdlib${ii}$_dbdsqr( 'U', m, m, m, 0_${ik}$, s, work( ie ),work( iu ), ldwrku, & + work( ir ),ldwrkr, dum, 1_${ik}$, work( iwork ), info ) ! multiply right singular vectors of l in work(iu) by ! q in vt, storing result in a ! (workspace: need m*m) - call stdlib_dgemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, vt, ldvt, & + call stdlib${ii}$_dgemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, vt, ldvt, & zero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_dlacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_dlacpy( 'F', m, n, a, lda, vt, ldvt ) ! copy left singular vectors of a from work(ir) to a - call stdlib_dlacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) + call stdlib${ii}$_dlacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_dlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_dlacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need m + n, prefer m + n*nb) - call stdlib_dorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_dorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_dlaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda ) + if (m>1_${ik}$) call stdlib${ii}$_dlaset( 'U', m-1, m-1, zero, zero, a( 1_${ik}$, 2_${ik}$ ),lda ) ! bidiagonalize l in a ! (workspace: need 4*m, prefer 3*m + 2*m*nb) - call stdlib_dgebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_dgebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in a by q ! in vt ! (workspace: need 3*m + n, prefer 3*m + n*nb) - call stdlib_dormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & + call stdlib${ii}$_dormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in a ! (workspace: need 4*m, prefer 3*m + m*nb) - call stdlib_dorgbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & + call stdlib${ii}$_dorgbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of a in a and computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_dbdsqr( 'U', m, n, m, 0, s, work( ie ), vt,ldvt, a, lda, & - dum, 1, work( iwork ),info ) + call stdlib${ii}$_dbdsqr( 'U', m, n, m, 0_${ik}$, s, work( ie ), vt,ldvt, a, lda, & + dum, 1_${ik}$, work( iwork ),info ) end if else if( wntuas ) then ! path 9t(n much larger than m, jobu='s' or 'a', ! jobvt='a') ! n right singular vectors to be computed in vt and ! m left singular vectors to be computed in u - if( lwork>=m*m+max( n + m, 4*m, bdspac ) ) then + if( lwork>=m*m+max( n + m, 4_${ik}$*m, bdspac ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+lda*m ) then ! work(iu) is lda by m ldwrku = lda @@ -78076,16 +78070,16 @@ module stdlib_linalg_lapack_d iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_dlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_dlacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need m*m + m + n, prefer m*m + m + n*nb) - call stdlib_dorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_dorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to work(iu), zeroing out above it - call stdlib_dlacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_dlaset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & + call stdlib${ii}$_dlacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_dlaset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & ) ie = itau itauq = ie + m @@ -78093,71 +78087,71 @@ module stdlib_linalg_lapack_d iwork = itaup + m ! bidiagonalize l in work(iu), copying result to u ! (workspace: need m*m + 4*m, prefer m*m + 3*m + 2*m*nb) - call stdlib_dgebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib${ii}$_dgebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_dlacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) + call stdlib${ii}$_dlacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) ! generate right bidiagonalizing vectors in work(iu) ! (workspace: need m*m + 4*m, prefer m*m + 3*m + (m-1)*nb) - call stdlib_dorgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib${ii}$_dorgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (workspace: need m*m + 4*m, prefer m*m + 3*m + m*nb) - call stdlib_dorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_dorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of l in u and computing right ! singular vectors of l in work(iu) ! (workspace: need m*m + bdspac) - call stdlib_dbdsqr( 'U', m, m, m, 0, s, work( ie ),work( iu ), ldwrku, & - u, ldu, dum, 1,work( iwork ), info ) + call stdlib${ii}$_dbdsqr( 'U', m, m, m, 0_${ik}$, s, work( ie ),work( iu ), ldwrku, & + u, ldu, dum, 1_${ik}$,work( iwork ), info ) ! multiply right singular vectors of l in work(iu) by ! q in vt, storing result in a ! (workspace: need m*m) - call stdlib_dgemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, vt, ldvt, & + call stdlib${ii}$_dgemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, vt, ldvt, & zero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_dlacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_dlacpy( 'F', m, n, a, lda, vt, ldvt ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_dgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_dlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_dlacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need m + n, prefer m + n*nb) - call stdlib_dorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_dorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to u, zeroing out above it - call stdlib_dlacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_dlaset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu ) + call stdlib${ii}$_dlacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1_${ik}$) call stdlib${ii}$_dlaset( 'U', m-1, m-1, zero, zero, u( 1_${ik}$, 2_${ik}$ ),ldu ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize l in u ! (workspace: need 4*m, prefer 3*m + 2*m*nb) - call stdlib_dgebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_dgebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in u by q ! in vt ! (workspace: need 3*m + n, prefer 3*m + n*nb) - call stdlib_dormbr( 'P', 'L', 'T', m, n, m, u, ldu,work( itaup ), vt, & + call stdlib${ii}$_dormbr( 'P', 'L', 'T', m, n, m, u, ldu,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (workspace: need 4*m, prefer 3*m + m*nb) - call stdlib_dorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_dorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_dbdsqr( 'U', m, n, m, 0, s, work( ie ), vt,ldvt, u, ldu, & - dum, 1, work( iwork ),info ) + call stdlib${ii}$_dbdsqr( 'U', m, n, m, 0_${ik}$, s, work( ie ), vt,ldvt, u, ldu, & + dum, 1_${ik}$, work( iwork ),info ) end if end if end if @@ -78165,107 +78159,107 @@ module stdlib_linalg_lapack_d ! n < mnthr ! path 10t(n greater than m, but not much larger) ! reduce to bidiagonal form without lq decomposition - ie = 1 + ie = 1_${ik}$ itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize a ! (workspace: need 3*m + n, prefer 3*m + (m + n)*nb) - call stdlib_dgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_dgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,ierr ) if( wntuas ) then ! if left singular vectors desired in u, copy result to u ! and generate left bidiagonalizing vectors in u ! (workspace: need 4*m-1, prefer 3*m + (m-1)*nb) - call stdlib_dlacpy( 'L', m, m, a, lda, u, ldu ) - call stdlib_dorgbr( 'Q', m, m, n, u, ldu, work( itauq ),work( iwork ), lwork-& + call stdlib${ii}$_dlacpy( 'L', m, m, a, lda, u, ldu ) + call stdlib${ii}$_dorgbr( 'Q', m, m, n, u, ldu, work( itauq ),work( iwork ), lwork-& iwork+1, ierr ) end if if( wntvas ) then ! if right singular vectors desired in vt, copy result to ! vt and generate right bidiagonalizing vectors in vt ! (workspace: need 3*m + nrvt, prefer 3*m + nrvt*nb) - call stdlib_dlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_dlacpy( 'U', m, n, a, lda, vt, ldvt ) if( wntva )nrvt = n if( wntvs )nrvt = m - call stdlib_dorgbr( 'P', nrvt, n, m, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib${ii}$_dorgbr( 'P', nrvt, n, m, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) end if if( wntuo ) then ! if left singular vectors desired in a, generate left ! bidiagonalizing vectors in a ! (workspace: need 4*m-1, prefer 3*m + (m-1)*nb) - call stdlib_dorgbr( 'Q', m, m, n, a, lda, work( itauq ),work( iwork ), lwork-& + call stdlib${ii}$_dorgbr( 'Q', m, m, n, a, lda, work( itauq ),work( iwork ), lwork-& iwork+1, ierr ) end if if( wntvo ) then ! if right singular vectors desired in a, generate right ! bidiagonalizing vectors in a ! (workspace: need 4*m, prefer 3*m + m*nb) - call stdlib_dorgbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-& + call stdlib${ii}$_dorgbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-& iwork+1, ierr ) end if iwork = ie + m if( wntuas .or. wntuo )nru = m - if( wntun )nru = 0 + if( wntun )nru = 0_${ik}$ if( wntvas .or. wntvo )ncvt = n - if( wntvn )ncvt = 0 + if( wntvn )ncvt = 0_${ik}$ if( ( .not.wntuo ) .and. ( .not.wntvo ) ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in vt ! (workspace: need bdspac) - call stdlib_dbdsqr( 'L', m, ncvt, nru, 0, s, work( ie ), vt,ldvt, u, ldu, dum,& - 1, work( iwork ), info ) + call stdlib${ii}$_dbdsqr( 'L', m, ncvt, nru, 0_${ik}$, s, work( ie ), vt,ldvt, u, ldu, dum,& + 1_${ik}$, work( iwork ), info ) else if( ( .not.wntuo ) .and. wntvo ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in a ! (workspace: need bdspac) - call stdlib_dbdsqr( 'L', m, ncvt, nru, 0, s, work( ie ), a, lda,u, ldu, dum, & - 1, work( iwork ), info ) + call stdlib${ii}$_dbdsqr( 'L', m, ncvt, nru, 0_${ik}$, s, work( ie ), a, lda,u, ldu, dum, & + 1_${ik}$, work( iwork ), info ) else ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in a and computing right singular ! vectors in vt ! (workspace: need bdspac) - call stdlib_dbdsqr( 'L', m, ncvt, nru, 0, s, work( ie ), vt,ldvt, a, lda, dum,& - 1, work( iwork ), info ) + call stdlib${ii}$_dbdsqr( 'L', m, ncvt, nru, 0_${ik}$, s, work( ie ), vt,ldvt, a, lda, dum,& + 1_${ik}$, work( iwork ), info ) end if end if end if - ! if stdlib_dbdsqr failed to converge, copy unconverged superdiagonals + ! if stdlib${ii}$_dbdsqr failed to converge, copy unconverged superdiagonals ! to work( 2:minmn ) - if( info/=0 ) then - if( ie>2 ) then + if( info/=0_${ik}$ ) then + if( ie>2_${ik}$ ) then do i = 1, minmn - 1 work( i+1 ) = work( i+ie-1 ) end do end if - if( ie<2 ) then + if( ie<2_${ik}$ ) then do i = minmn - 1, 1, -1 work( i+1 ) = work( i+ie-1 ) end do end if end if ! undo scaling if necessary - if( iscl==1 ) then - if( anrm>bignum )call stdlib_dlascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,& + if( iscl==1_${ik}$ ) then + if( anrm>bignum )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn, 1_${ik}$, s, minmn,& ierr ) - if( info/=0 .and. anrm>bignum )call stdlib_dlascl( 'G', 0, 0, bignum, anrm, minmn-1,& - 1, work( 2 ),minmn, ierr ) - if( anrmbignum )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn-1,& + 1_${ik}$, work( 2_${ik}$ ),minmn, ierr ) + if( anrm= N. The SVD of A is written as !! [++] [xx] [x0] [xx] @@ -78278,26 +78272,26 @@ module stdlib_linalg_lapack_d numrank, iwork, liwork,work, lwork, rwork, lrwork, info ) ! Scalar Arguments character, intent(in) :: joba, jobp, jobr, jobu, jobv - integer(ilp), intent(in) :: m, n, lda, ldu, ldv, liwork, lrwork - integer(ilp), intent(out) :: numrank, info - integer(ilp), intent(inout) :: lwork + integer(${ik}$), intent(in) :: m, n, lda, ldu, ldv, liwork, lrwork + integer(${ik}$), intent(out) :: numrank, info + integer(${ik}$), intent(inout) :: lwork ! Array Arguments real(dp), intent(inout) :: a(lda,*) real(dp), intent(out) :: u(ldu,*), v(ldv,*), work(*) real(dp), intent(out) :: s(*), rwork(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: ierr, iwoff, nr, n1, optratio, p, q - integer(ilp) :: lwcon, lwqp3, lwrk_dgelqf, lwrk_dgesvd, lwrk_dgesvd2, lwrk_dgeqp3, & + integer(${ik}$) :: ierr, iwoff, nr, n1, optratio, p, q + integer(${ik}$) :: lwcon, lwqp3, lwrk_dgelqf, lwrk_dgesvd, lwrk_dgesvd2, lwrk_dgeqp3, & lwrk_dgeqrf, lwrk_dormlq, lwrk_dormqr, lwrk_dormqr2, lwlqf, lwqrf, lwsvd, lwsvd2, & lworq, lworq2, lworlq, minwrk, minwrk2, optwrk, optwrk2, iminwrk, rminwrk logical(lk) :: accla, acclm, acclh, ascaled, conda, dntwu, dntwv, lquery, lsvc0, lsvec,& rowprm, rsvec, rtrans, wntua, wntuf, wntur, wntus, wntva, wntvr real(dp) :: big, epsln, rtmp, sconda, sfmin ! Local Arrays - real(dp) :: rdummy(1) + real(dp) :: rdummy(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,min,real,sqrt ! test the input arguments @@ -78320,81 +78314,81 @@ module stdlib_linalg_lapack_d rtrans = stdlib_lsame( jobr, 'T' ) if ( rowprm ) then if ( conda ) then - iminwrk = max( 1, n + m - 1 + n ) + iminwrk = max( 1_${ik}$, n + m - 1_${ik}$ + n ) else - iminwrk = max( 1, n + m - 1 ) + iminwrk = max( 1_${ik}$, n + m - 1_${ik}$ ) end if - rminwrk = max( 2, m ) + rminwrk = max( 2_${ik}$, m ) else if ( conda ) then - iminwrk = max( 1, n + n ) + iminwrk = max( 1_${ik}$, n + n ) else - iminwrk = max( 1, n ) + iminwrk = max( 1_${ik}$, n ) end if - rminwrk = 2 + rminwrk = 2_${ik}$ end if - lquery = (liwork == -1 .or. lwork == -1 .or. lrwork == -1) - info = 0 + lquery = (liwork == -1_${ik}$ .or. lwork == -1_${ik}$ .or. lrwork == -1_${ik}$) + info = 0_${ik}$ if ( .not. ( accla .or. acclm .or. acclh ) ) then - info = -1 + info = -1_${ik}$ else if ( .not.( rowprm .or. stdlib_lsame( jobp, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if ( .not.( rtrans .or. stdlib_lsame( jobr, 'N' ) ) ) then - info = -3 + info = -3_${ik}$ else if ( .not.( lsvec .or. dntwu ) ) then - info = -4 + info = -4_${ik}$ else if ( wntur .and. wntva ) then - info = -5 + info = -5_${ik}$ else if ( .not.( rsvec .or. dntwv )) then - info = -5 - else if ( m<0 ) then - info = -6 - else if ( ( n<0 ) .or. ( n>m ) ) then - info = -7 - else if ( ldam ) ) then + info = -7_${ik}$ + else if ( lda big / sqrt(real(m,KIND=dp)) ) then + if ( rwork(1_${ik}$) > big / sqrt(real(m,KIND=dp)) ) then ! .. to prevent overflow in the qr factorization, scale the ! matrix by 1/sqrt(m) if too large entry detected - call stdlib_dlascl('G',0,0,sqrt(real(m,KIND=dp)),one, m,n, a,lda, ierr) + call stdlib${ii}$_dlascl('G',0_${ik}$,0_${ik}$,sqrt(real(m,KIND=dp)),one, m,n, a,lda, ierr) ascaled = .true. end if - call stdlib_dlaswp( n, a, lda, 1, m-1, iwork(n+1), 1 ) + call stdlib${ii}$_dlaswp( n, a, lda, 1_${ik}$, m-1, iwork(n+1), 1_${ik}$ ) end if ! .. at this stage, preemptive scaling is done only to avoid column ! norms overflows during the qr factorization. the svd procedure should ! have its own scaling to save the singular values from overflows and ! underflows. that depends on the svd procedure. if ( .not.rowprm ) then - rtmp = stdlib_dlange( 'M', m, n, a, lda, rdummy ) + rtmp = stdlib${ii}$_dlange( 'M', m, n, a, lda, rdummy ) if ( ( rtmp /= rtmp ) .or.( (rtmp*zero) /= zero ) ) then - info = -8 - call stdlib_xerbla( 'DGESVDQ', -info ) + info = -8_${ik}$ + call stdlib${ii}$_xerbla( 'DGESVDQ', -info ) return end if if ( rtmp > big / sqrt(real(m,KIND=dp)) ) then ! .. to prevent overflow in the qr factorization, scale the ! matrix by 1/sqrt(m) if too large entry detected - call stdlib_dlascl('G',0,0, sqrt(real(m,KIND=dp)),one, m,n, a,lda, ierr) + call stdlib${ii}$_dlascl('G',0_${ik}$,0_${ik}$, sqrt(real(m,KIND=dp)),one, m,n, a,lda, ierr) ascaled = .true. end if @@ -78647,14 +78641,14 @@ module stdlib_linalg_lapack_d ! [ 0 ] do p = 1, n ! All Columns Are Free Columns - iwork(p) = 0 + iwork(p) = 0_${ik}$ end do - call stdlib_dgeqp3( m, n, a, lda, iwork, work, work(n+1), lwork-n,ierr ) + call stdlib${ii}$_dgeqp3( m, n, a, lda, iwork, work, work(n+1), lwork-n,ierr ) ! if the user requested accuracy level allows truncation in the ! computed upper triangular factor, the matrix r is examined and, ! if possible, replaced with its leading upper trapezoidal part. - epsln = stdlib_dlamch('E') - sfmin = stdlib_dlamch('S') + epsln = stdlib${ii}$_dlamch('E') + sfmin = stdlib${ii}$_dlamch('S') ! small = sfmin / epsln nr = n if ( accla ) then @@ -78662,57 +78656,53 @@ module stdlib_linalg_lapack_d ! sigma_i < n*eps*||a||_f are flushed to zero. this is an ! aggressive enforcement of lower numerical rank by introducing a ! backward error of the order of n*eps*||a||_f. - nr = 1 + nr = 1_${ik}$ rtmp = sqrt(real(n,KIND=dp))*epsln - do p = 2, n - if ( abs(a(p,p)) < (rtmp*abs(a(1,1))) ) go to 3002 - nr = nr + 1 - end do - 3002 continue + loop_3002: do p = 2, n + if ( abs(a(p,p)) < (rtmp*abs(a(1,1))) ) exit loop_3002 + nr = nr + 1_${ik}$ + end do loop_3002 elseif ( acclm ) then ! .. similarly as above, only slightly more gentle (less aggressive). ! sudden drop on the diagonal of r is used as the criterion for being - ! close-to-rank-deficient. the threshold is set to epsln=stdlib_dlamch('e'). + ! close-to-rank-deficient. the threshold is set to epsln=stdlib${ii}$_dlamch('e'). ! [[this can be made more flexible by replacing this hard-coded value ! with a user specified threshold.]] also, the values that underflow ! will be truncated. - nr = 1 - do p = 2, n - if ( ( abs(a(p,p)) < (epsln*abs(a(p-1,p-1))) ) .or.( abs(a(p,p)) < sfmin ) ) go & - to 3402 - nr = nr + 1 - end do - 3402 continue + nr = 1_${ik}$ + loop_3402: do p = 2, n + if ( ( abs(a(p,p)) < (epsln*abs(a(p-1,p-1))) ) .or.( abs(a(p,p)) < sfmin ) ) exit loop_3402 + nr = nr + 1_${ik}$ + end do loop_3402 else ! Rrqr Not Authorized To Determine Numerical Rank Except In The ! obvious case of zero pivots. ! .. inspect r for exact zeros on the diagonal; ! r(i,i)=0 => r(i:n,i:n)=0. - nr = 1 - do p = 2, n - if ( abs(a(p,p)) == zero ) go to 3502 - nr = nr + 1 - end do - 3502 continue + nr = 1_${ik}$ + loop_3502: do p = 2, n + if ( abs(a(p,p)) == zero ) exit loop_3502 + nr = nr + 1_${ik}$ + end do loop_3502 if ( conda ) then ! estimate the scaled condition number of a. use the fact that it is ! the same as the scaled condition number of r. ! V Is Used As Workspace - call stdlib_dlacpy( 'U', n, n, a, lda, v, ldv ) + call stdlib${ii}$_dlacpy( 'U', n, n, a, lda, v, ldv ) ! only the leading nr x nr submatrix of the triangular factor ! is considered. only if nr=n will this give a reliable error ! bound. however, even for nr < n, this can be used on an ! expert level and obtain useful information in the sense of ! perturbation theory. do p = 1, nr - rtmp = stdlib_dnrm2( p, v(1,p), 1 ) - call stdlib_dscal( p, one/rtmp, v(1,p), 1 ) + rtmp = stdlib${ii}$_dnrm2( p, v(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_dscal( p, one/rtmp, v(1_${ik}$,p), 1_${ik}$ ) end do if ( .not. ( lsvec .or. rsvec ) ) then - call stdlib_dpocon( 'U', nr, v, ldv, one, rtmp,work, iwork(n+iwoff), ierr & + call stdlib${ii}$_dpocon( 'U', nr, v, ldv, one, rtmp,work, iwork(n+iwoff), ierr & ) else - call stdlib_dpocon( 'U', nr, v, ldv, one, rtmp,work(n+1), iwork(n+iwoff), & + call stdlib${ii}$_dpocon( 'U', nr, v, ldv, one, rtmp,work(n+1), iwork(n+iwoff), & ierr ) end if sconda = one / sqrt(rtmp) @@ -78742,12 +78732,12 @@ module stdlib_linalg_lapack_d if ( q <= nr ) a(p,q) = zero end do end do - call stdlib_dgesvd( 'N', 'N', n, nr, a, lda, s, u, ldu,v, ldv, work, lwork, info & + call stdlib${ii}$_dgesvd( 'N', 'N', n, nr, a, lda, s, u, ldu,v, ldv, work, lwork, info & ) else ! .. compute the singular values of r = [a](1:nr,1:n) - if ( nr > 1 )call stdlib_dlaset( 'L', nr-1,nr-1, zero,zero, a(2,1), lda ) - call stdlib_dgesvd( 'N', 'N', nr, n, a, lda, s, u, ldu,v, ldv, work, lwork, info & + if ( nr > 1_${ik}$ )call stdlib${ii}$_dlaset( 'L', nr-1,nr-1, zero,zero, a(2_${ik}$,1_${ik}$), lda ) + call stdlib${ii}$_dgesvd( 'N', 'N', nr, n, a, lda, s, u, ldu,v, ldv, work, lwork, info & ) end if else if ( lsvec .and. ( .not. rsvec) ) then @@ -78755,7 +78745,7 @@ module stdlib_linalg_lapack_d ! The Singular Values And The Left Singular Vectors Requested ! ......................................................................."""""""" if ( rtrans ) then - ! .. apply stdlib_dgesvd to r**t + ! .. apply stdlib${ii}$_dgesvd to r**t ! .. copy r**t into [u] and overwrite [u] with the right singular ! vectors of r do p = 1, nr @@ -78763,11 +78753,11 @@ module stdlib_linalg_lapack_d u(q,p) = a(p,q) end do end do - if ( nr > 1 )call stdlib_dlaset( 'U', nr-1,nr-1, zero,zero, u(1,2), ldu ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_dlaset( 'U', nr-1,nr-1, zero,zero, u(1_${ik}$,2_${ik}$), ldu ) ! .. the left singular vectors not computed, the nr right singular ! vectors overwrite [u](1:nr,1:nr) as transposed. these ! will be pre-multiplied by q to build the left singular vectors of a. - call stdlib_dgesvd( 'N', 'O', n, nr, u, ldu, s, u, ldu,u, ldu, work(n+1), & + call stdlib${ii}$_dgesvd( 'N', 'O', n, nr, u, ldu, s, u, ldu,u, ldu, work(n+1), & lwork-n, info ) do p = 1, nr do q = p + 1, nr @@ -78779,12 +78769,12 @@ module stdlib_linalg_lapack_d else ! Apply Stdlib_Dgesvd To R ! .. copy r into [u] and overwrite [u] with the left singular vectors - call stdlib_dlacpy( 'U', nr, n, a, lda, u, ldu ) - if ( nr > 1 )call stdlib_dlaset( 'L', nr-1, nr-1, zero, zero, u(2,1), ldu ) + call stdlib${ii}$_dlacpy( 'U', nr, n, a, lda, u, ldu ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_dlaset( 'L', nr-1, nr-1, zero, zero, u(2_${ik}$,1_${ik}$), ldu ) ! .. the right singular vectors not computed, the nr left singular ! vectors overwrite [u](1:nr,1:nr) - call stdlib_dgesvd( 'O', 'N', nr, n, u, ldu, s, u, ldu,v, ldv, work(n+1), & + call stdlib${ii}$_dgesvd( 'O', 'N', nr, n, u, ldu, s, u, ldu,v, ldv, work(n+1), & lwork-n, info ) ! .. now [u](1:nr,1:nr) contains the nr left singular vectors of ! r. these will be pre-multiplied by q to build the left singular @@ -78793,35 +78783,35 @@ module stdlib_linalg_lapack_d ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. ( .not.wntuf ) ) then - call stdlib_dlaset('A', m-nr, nr, zero, zero, u(nr+1,1), ldu) + call stdlib${ii}$_dlaset('A', m-nr, nr, zero, zero, u(nr+1,1_${ik}$), ldu) if ( nr < n1 ) then - call stdlib_dlaset( 'A',nr,n1-nr,zero,zero,u(1,nr+1), ldu ) - call stdlib_dlaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_dlaset( 'A',nr,n1-nr,zero,zero,u(1_${ik}$,nr+1), ldu ) + call stdlib${ii}$_dlaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) end if end if ! the q matrix from the first qrf is built into the left singular ! vectors matrix u. - if ( .not.wntuf )call stdlib_dormqr( 'L', 'N', m, n1, n, a, lda, work, u,ldu, work(& + if ( .not.wntuf )call stdlib${ii}$_dormqr( 'L', 'N', m, n1, n, a, lda, work, u,ldu, work(& n+1), lwork-n, ierr ) - if ( rowprm .and. .not.wntuf )call stdlib_dlaswp( n1, u, ldu, 1, m-1, iwork(n+1), -& - 1 ) + if ( rowprm .and. .not.wntuf )call stdlib${ii}$_dlaswp( n1, u, ldu, 1_${ik}$, m-1, iwork(n+1), -& + 1_${ik}$ ) else if ( rsvec .and. ( .not. lsvec ) ) then ! ....................................................................... ! The Singular Values And The Right Singular Vectors Requested ! ....................................................................... if ( rtrans ) then - ! .. apply stdlib_dgesvd to r**t + ! .. apply stdlib${ii}$_dgesvd to r**t ! .. copy r**t into v and overwrite v with the left singular vectors do p = 1, nr do q = p, n v(q,p) = (a(p,q)) end do end do - if ( nr > 1 )call stdlib_dlaset( 'U', nr-1,nr-1, zero,zero, v(1,2), ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_dlaset( 'U', nr-1,nr-1, zero,zero, v(1_${ik}$,2_${ik}$), ldv ) ! .. the left singular vectors of r**t overwrite v, the right singular ! vectors not computed if ( wntvr .or. ( nr == n ) ) then - call stdlib_dgesvd( 'O', 'N', n, nr, v, ldv, s, u, ldu,u, ldu, work(n+1), & + call stdlib${ii}$_dgesvd( 'O', 'N', n, nr, v, ldv, s, u, ldu,u, ldu, work(n+1), & lwork-n, info ) do p = 1, nr do q = p + 1, nr @@ -78837,15 +78827,15 @@ module stdlib_linalg_lapack_d end do end do end if - call stdlib_dlapmt( .false., nr, n, v, ldv, iwork ) + call stdlib${ii}$_dlapmt( .false., nr, n, v, ldv, iwork ) else ! .. need all n right singular vectors and nr < n ! [!] this is simple implementation that augments [v](1:n,1:nr) ! by padding a zero block. in the case nr << n, a more efficient ! way is to first use the qr factorization. for more details ! how to implement this, see the " full svd " branch. - call stdlib_dlaset('G', n, n-nr, zero, zero, v(1,nr+1), ldv) - call stdlib_dgesvd( 'O', 'N', n, n, v, ldv, s, u, ldu,u, ldu, work(n+1), & + call stdlib${ii}$_dlaset('G', n, n-nr, zero, zero, v(1_${ik}$,nr+1), ldv) + call stdlib${ii}$_dgesvd( 'O', 'N', n, n, v, ldv, s, u, ldu,u, ldu, work(n+1), & lwork-n, info ) do p = 1, n do q = p + 1, n @@ -78854,20 +78844,20 @@ module stdlib_linalg_lapack_d v(p,q) = rtmp end do end do - call stdlib_dlapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_dlapmt( .false., n, n, v, ldv, iwork ) end if else ! Aply Stdlib_Dgesvd To R ! Copy R Into V And Overwrite V With The Right Singular Vectors - call stdlib_dlacpy( 'U', nr, n, a, lda, v, ldv ) - if ( nr > 1 )call stdlib_dlaset( 'L', nr-1, nr-1, zero, zero, v(2,1), ldv ) + call stdlib${ii}$_dlacpy( 'U', nr, n, a, lda, v, ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_dlaset( 'L', nr-1, nr-1, zero, zero, v(2_${ik}$,1_${ik}$), ldv ) ! .. the right singular vectors overwrite v, the nr left singular ! vectors stored in u(1:nr,1:nr) if ( wntvr .or. ( nr == n ) ) then - call stdlib_dgesvd( 'N', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & + call stdlib${ii}$_dgesvd( 'N', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & lwork-n, info ) - call stdlib_dlapmt( .false., nr, n, v, ldv, iwork ) + call stdlib${ii}$_dlapmt( .false., nr, n, v, ldv, iwork ) ! .. now [v](1:nr,1:n) contains v(1:n,1:nr)**t else ! .. need all n right singular vectors and nr < n @@ -78875,10 +78865,10 @@ module stdlib_linalg_lapack_d ! by padding a zero block. in the case nr << n, a more efficient ! way is to first use the lq factorization. for more details ! how to implement this, see the " full svd " branch. - call stdlib_dlaset('G', n-nr, n, zero,zero, v(nr+1,1), ldv) - call stdlib_dgesvd( 'N', 'O', n, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & + call stdlib${ii}$_dlaset('G', n-nr, n, zero,zero, v(nr+1,1_${ik}$), ldv) + call stdlib${ii}$_dgesvd( 'N', 'O', n, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & lwork-n, info ) - call stdlib_dlapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_dlapmt( .false., n, n, v, ldv, iwork ) end if ! .. now [v] contains the transposed matrix of the right singular ! vectors of a. @@ -78888,7 +78878,7 @@ module stdlib_linalg_lapack_d ! Full Svd Requested ! ....................................................................... if ( rtrans ) then - ! .. apply stdlib_dgesvd to r**t [[this option is left for r + ! .. apply stdlib${ii}$_dgesvd to r**t [[this option is left for r if ( wntvr .or. ( nr == n ) ) then ! .. copy r**t into [v] and overwrite [v] with the left singular ! vectors of r**t @@ -78897,10 +78887,10 @@ module stdlib_linalg_lapack_d v(q,p) = a(p,q) end do end do - if ( nr > 1 )call stdlib_dlaset( 'U', nr-1,nr-1, zero,zero, v(1,2), ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_dlaset( 'U', nr-1,nr-1, zero,zero, v(1_${ik}$,2_${ik}$), ldv ) ! .. the left singular vectors of r**t overwrite [v], the nr right ! singular vectors of r**t stored in [u](1:nr,1:nr) as transposed - call stdlib_dgesvd( 'O', 'A', n, nr, v, ldv, s, v, ldv,u, ldu, work(n+1), & + call stdlib${ii}$_dgesvd( 'O', 'A', n, nr, v, ldv, s, v, ldv,u, ldu, work(n+1), & lwork-n, info ) ! Assemble V do p = 1, nr @@ -78917,7 +78907,7 @@ module stdlib_linalg_lapack_d end do end do end if - call stdlib_dlapmt( .false., nr, n, v, ldv, iwork ) + call stdlib${ii}$_dlapmt( .false., nr, n, v, ldv, iwork ) do p = 1, nr do q = p + 1, nr rtmp = u(q,p) @@ -78926,10 +78916,10 @@ module stdlib_linalg_lapack_d end do end do if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_dlaset('A', m-nr,nr, zero,zero, u(nr+1,1), ldu) + call stdlib${ii}$_dlaset('A', m-nr,nr, zero,zero, u(nr+1,1_${ik}$), ldu) if ( nr < n1 ) then - call stdlib_dlaset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) - call stdlib_dlaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_dlaset('A',nr,n1-nr,zero,zero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_dlaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) end if end if else @@ -78939,19 +78929,19 @@ module stdlib_linalg_lapack_d ! [[the optimal ratio n/nr for using qrf instead of padding ! with zeros. here hard coded to 2; it must be at least ! two due to work space constraints.]] - ! optratio = stdlib_ilaenv(6, 'dgesvd', 's' // 'o', nr,n,0,0) + ! optratio = stdlib${ii}$_ilaenv(6, 'dgesvd', 's' // 'o', nr,n,0,0) ! optratio = max( optratio, 2 ) - optratio = 2 + optratio = 2_${ik}$ if ( optratio*nr > n ) then do p = 1, nr do q = p, n v(q,p) = a(p,q) end do end do - if ( nr > 1 )call stdlib_dlaset('U',nr-1,nr-1, zero,zero, v(1,2),ldv) + if ( nr > 1_${ik}$ )call stdlib${ii}$_dlaset('U',nr-1,nr-1, zero,zero, v(1_${ik}$,2_${ik}$),ldv) - call stdlib_dlaset('A',n,n-nr,zero,zero,v(1,nr+1),ldv) - call stdlib_dgesvd( 'O', 'A', n, n, v, ldv, s, v, ldv,u, ldu, work(n+1), & + call stdlib${ii}$_dlaset('A',n,n-nr,zero,zero,v(1_${ik}$,nr+1),ldv) + call stdlib${ii}$_dgesvd( 'O', 'A', n, n, v, ldv, s, v, ldv,u, ldu, work(n+1), & lwork-n, info ) do p = 1, n do q = p + 1, n @@ -78960,7 +78950,7 @@ module stdlib_linalg_lapack_d v(p,q) = rtmp end do end do - call stdlib_dlapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_dlapmt( .false., n, n, v, ldv, iwork ) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x n1), i.e. (m x n) or (m x m). do p = 1, n @@ -78971,10 +78961,10 @@ module stdlib_linalg_lapack_d end do end do if ( ( n < m ) .and. .not.(wntuf)) then - call stdlib_dlaset('A',m-n,n,zero,zero,u(n+1,1),ldu) + call stdlib${ii}$_dlaset('A',m-n,n,zero,zero,u(n+1,1_${ik}$),ldu) if ( n < n1 ) then - call stdlib_dlaset('A',n,n1-n,zero,zero,u(1,n+1),ldu) - call stdlib_dlaset('A',m-n,n1-n,zero,one,u(n+1,n+1), ldu ) + call stdlib${ii}$_dlaset('A',n,n1-n,zero,zero,u(1_${ik}$,n+1),ldu) + call stdlib${ii}$_dlaset('A',m-n,n1-n,zero,one,u(n+1,n+1), ldu ) end if end if else @@ -78985,55 +78975,55 @@ module stdlib_linalg_lapack_d u(q,nr+p) = a(p,q) end do end do - if ( nr > 1 )call stdlib_dlaset('U',nr-1,nr-1,zero,zero,u(1,nr+2),ldu) + if ( nr > 1_${ik}$ )call stdlib${ii}$_dlaset('U',nr-1,nr-1,zero,zero,u(1_${ik}$,nr+2),ldu) - call stdlib_dgeqrf( n, nr, u(1,nr+1), ldu, work(n+1),work(n+nr+1), lwork-& + call stdlib${ii}$_dgeqrf( n, nr, u(1_${ik}$,nr+1), ldu, work(n+1),work(n+nr+1), lwork-& n-nr, ierr ) do p = 1, nr do q = 1, n v(q,p) = u(p,nr+q) end do end do - if (nr>1) call stdlib_dlaset('U',nr-1,nr-1,zero,zero,v(1,2),ldv) - call stdlib_dgesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v,ldv, work(n+nr+1)& + if (nr>1_${ik}$) call stdlib${ii}$_dlaset('U',nr-1,nr-1,zero,zero,v(1_${ik}$,2_${ik}$),ldv) + call stdlib${ii}$_dgesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v,ldv, work(n+nr+1)& ,lwork-n-nr, info ) - call stdlib_dlaset('A',n-nr,nr,zero,zero,v(nr+1,1),ldv) - call stdlib_dlaset('A',nr,n-nr,zero,zero,v(1,nr+1),ldv) - call stdlib_dlaset('A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv) - call stdlib_dormqr('R','C', n, n, nr, u(1,nr+1), ldu,work(n+1),v,ldv,work(& + call stdlib${ii}$_dlaset('A',n-nr,nr,zero,zero,v(nr+1,1_${ik}$),ldv) + call stdlib${ii}$_dlaset('A',nr,n-nr,zero,zero,v(1_${ik}$,nr+1),ldv) + call stdlib${ii}$_dlaset('A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv) + call stdlib${ii}$_dormqr('R','C', n, n, nr, u(1_${ik}$,nr+1), ldu,work(n+1),v,ldv,work(& n+nr+1),lwork-n-nr,ierr) - call stdlib_dlapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_dlapmt( .false., n, n, v, ldv, iwork ) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_dlaset('A',m-nr,nr,zero,zero,u(nr+1,1),ldu) + call stdlib${ii}$_dlaset('A',m-nr,nr,zero,zero,u(nr+1,1_${ik}$),ldu) if ( nr < n1 ) then - call stdlib_dlaset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) - call stdlib_dlaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1),ldu) + call stdlib${ii}$_dlaset('A',nr,n1-nr,zero,zero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_dlaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1),ldu) end if end if end if end if else - ! .. apply stdlib_dgesvd to r [[this is the recommended option]] + ! .. apply stdlib${ii}$_dgesvd to r [[this is the recommended option]] if ( wntvr .or. ( nr == n ) ) then ! .. copy r into [v] and overwrite v with the right singular vectors - call stdlib_dlacpy( 'U', nr, n, a, lda, v, ldv ) - if ( nr > 1 )call stdlib_dlaset( 'L', nr-1,nr-1, zero,zero, v(2,1), ldv ) + call stdlib${ii}$_dlacpy( 'U', nr, n, a, lda, v, ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_dlaset( 'L', nr-1,nr-1, zero,zero, v(2_${ik}$,1_${ik}$), ldv ) ! .. the right singular vectors of r overwrite [v], the nr left ! singular vectors of r stored in [u](1:nr,1:nr) - call stdlib_dgesvd( 'S', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & + call stdlib${ii}$_dgesvd( 'S', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & lwork-n, info ) - call stdlib_dlapmt( .false., nr, n, v, ldv, iwork ) + call stdlib${ii}$_dlapmt( .false., nr, n, v, ldv, iwork ) ! .. now [v](1:nr,1:n) contains v(1:n,1:nr)**t ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_dlaset('A', m-nr,nr, zero,zero, u(nr+1,1), ldu) + call stdlib${ii}$_dlaset('A', m-nr,nr, zero,zero, u(nr+1,1_${ik}$), ldu) if ( nr < n1 ) then - call stdlib_dlaset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) - call stdlib_dlaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_dlaset('A',nr,n1-nr,zero,zero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_dlaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) end if end if else @@ -79043,54 +79033,54 @@ module stdlib_linalg_lapack_d ! [[the optimal ratio n/nr for using lq instead of padding ! with zeros. here hard coded to 2; it must be at least ! two due to work space constraints.]] - ! optratio = stdlib_ilaenv(6, 'dgesvd', 's' // 'o', nr,n,0,0) + ! optratio = stdlib${ii}$_ilaenv(6, 'dgesvd', 's' // 'o', nr,n,0,0) ! optratio = max( optratio, 2 ) - optratio = 2 + optratio = 2_${ik}$ if ( optratio * nr > n ) then - call stdlib_dlacpy( 'U', nr, n, a, lda, v, ldv ) - if ( nr > 1 )call stdlib_dlaset('L', nr-1,nr-1, zero,zero, v(2,1),ldv) + call stdlib${ii}$_dlacpy( 'U', nr, n, a, lda, v, ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_dlaset('L', nr-1,nr-1, zero,zero, v(2_${ik}$,1_${ik}$),ldv) ! .. the right singular vectors of r overwrite [v], the nr left ! singular vectors of r stored in [u](1:nr,1:nr) - call stdlib_dlaset('A', n-nr,n, zero,zero, v(nr+1,1),ldv) - call stdlib_dgesvd( 'S', 'O', n, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & + call stdlib${ii}$_dlaset('A', n-nr,n, zero,zero, v(nr+1,1_${ik}$),ldv) + call stdlib${ii}$_dgesvd( 'S', 'O', n, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & lwork-n, info ) - call stdlib_dlapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_dlapmt( .false., n, n, v, ldv, iwork ) ! .. now [v] contains the transposed matrix of the right ! singular vectors of a. the leading n left singular vectors ! are in [u](1:n,1:n) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x n1), i.e. (m x n) or (m x m). if ( ( n < m ) .and. .not.(wntuf)) then - call stdlib_dlaset('A',m-n,n,zero,zero,u(n+1,1),ldu) + call stdlib${ii}$_dlaset('A',m-n,n,zero,zero,u(n+1,1_${ik}$),ldu) if ( n < n1 ) then - call stdlib_dlaset('A',n,n1-n,zero,zero,u(1,n+1),ldu) - call stdlib_dlaset( 'A',m-n,n1-n,zero,one,u(n+1,n+1), ldu ) + call stdlib${ii}$_dlaset('A',n,n1-n,zero,zero,u(1_${ik}$,n+1),ldu) + call stdlib${ii}$_dlaset( 'A',m-n,n1-n,zero,one,u(n+1,n+1), ldu ) end if end if else - call stdlib_dlacpy( 'U', nr, n, a, lda, u(nr+1,1), ldu ) - if ( nr > 1 )call stdlib_dlaset('L',nr-1,nr-1,zero,zero,u(nr+2,1),ldu) + call stdlib${ii}$_dlacpy( 'U', nr, n, a, lda, u(nr+1,1_${ik}$), ldu ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_dlaset('L',nr-1,nr-1,zero,zero,u(nr+2,1_${ik}$),ldu) - call stdlib_dgelqf( nr, n, u(nr+1,1), ldu, work(n+1),work(n+nr+1), lwork-n-& + call stdlib${ii}$_dgelqf( nr, n, u(nr+1,1_${ik}$), ldu, work(n+1),work(n+nr+1), lwork-n-& nr, ierr ) - call stdlib_dlacpy('L',nr,nr,u(nr+1,1),ldu,v,ldv) - if ( nr > 1 )call stdlib_dlaset('U',nr-1,nr-1,zero,zero,v(1,2),ldv) - call stdlib_dgesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v, ldv, work(n+nr+& - 1), lwork-n-nr, info ) - call stdlib_dlaset('A',n-nr,nr,zero,zero,v(nr+1,1),ldv) - call stdlib_dlaset('A',nr,n-nr,zero,zero,v(1,nr+1),ldv) - call stdlib_dlaset('A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv) - call stdlib_dormlq('R','N',n,n,nr,u(nr+1,1),ldu,work(n+1),v, ldv, work(n+& + call stdlib${ii}$_dlacpy('L',nr,nr,u(nr+1,1_${ik}$),ldu,v,ldv) + if ( nr > 1_${ik}$ )call stdlib${ii}$_dlaset('U',nr-1,nr-1,zero,zero,v(1_${ik}$,2_${ik}$),ldv) + call stdlib${ii}$_dgesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v, ldv, work(n+nr+& + 1_${ik}$), lwork-n-nr, info ) + call stdlib${ii}$_dlaset('A',n-nr,nr,zero,zero,v(nr+1,1_${ik}$),ldv) + call stdlib${ii}$_dlaset('A',nr,n-nr,zero,zero,v(1_${ik}$,nr+1),ldv) + call stdlib${ii}$_dlaset('A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv) + call stdlib${ii}$_dormlq('R','N',n,n,nr,u(nr+1,1_${ik}$),ldu,work(n+1),v, ldv, work(n+& nr+1),lwork-n-nr,ierr) - call stdlib_dlapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_dlapmt( .false., n, n, v, ldv, iwork ) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_dlaset('A',m-nr,nr,zero,zero,u(nr+1,1),ldu) + call stdlib${ii}$_dlaset('A',m-nr,nr,zero,zero,u(nr+1,1_${ik}$),ldu) if ( nr < n1 ) then - call stdlib_dlaset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) - call stdlib_dlaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_dlaset('A',nr,n1-nr,zero,zero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_dlaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) end if end if end if @@ -79099,10 +79089,10 @@ module stdlib_linalg_lapack_d end if ! the q matrix from the first qrf is built into the left singular ! vectors matrix u. - if ( .not. wntuf )call stdlib_dormqr( 'L', 'N', m, n1, n, a, lda, work, u,ldu, work(& + if ( .not. wntuf )call stdlib${ii}$_dormqr( 'L', 'N', m, n1, n, a, lda, work, u,ldu, work(& n+1), lwork-n, ierr ) - if ( rowprm .and. .not.wntuf )call stdlib_dlaswp( n1, u, ldu, 1, m-1, iwork(n+1), -& - 1 ) + if ( rowprm .and. .not.wntuf )call stdlib${ii}$_dlaswp( n1, u, ldu, 1_${ik}$, m-1, iwork(n+1), -& + 1_${ik}$ ) ! ... end of the "full svd" branch end if ! check whether some singular values are returned as zeros, e.g. @@ -79110,27 +79100,27 @@ module stdlib_linalg_lapack_d p = nr do q = p, 1, -1 if ( s(q) > zero ) go to 4002 - nr = nr - 1 + nr = nr - 1_${ik}$ end do 4002 continue ! .. if numerical rank deficiency is detected, the truncated ! singular values are set to zero. - if ( nr < n ) call stdlib_dlaset( 'G', n-nr,1, zero,zero, s(nr+1), n ) + if ( nr < n ) call stdlib${ii}$_dlaset( 'G', n-nr,1_${ik}$, zero,zero, s(nr+1), n ) ! .. undo scaling; this may cause overflow in the largest singular ! values. - if ( ascaled )call stdlib_dlascl( 'G',0,0, one,sqrt(real(m,KIND=dp)), nr,1, s, n, ierr & + if ( ascaled )call stdlib${ii}$_dlascl( 'G',0_${ik}$,0_${ik}$, one,sqrt(real(m,KIND=dp)), nr,1_${ik}$, s, n, ierr & ) - if ( conda ) rwork(1) = sconda - rwork(2) = p - nr + if ( conda ) rwork(1_${ik}$) = sconda + rwork(2_${ik}$) = p - nr ! .. p-nr is the number of singular values that are computed as - ! exact zeros in stdlib_dgesvd() applied to the (possibly truncated) + ! exact zeros in stdlib${ii}$_dgesvd() applied to the (possibly truncated) ! full row rank triangular (trapezoidal) factor of a. numrank = nr return - end subroutine stdlib_dgesvdq + end subroutine stdlib${ii}$_dgesvdq - subroutine stdlib_dgges3( jobvsl, jobvsr, sort, selctg, n, a, lda, b,ldb, sdim, alphar, & + subroutine stdlib${ii}$_dgges3( jobvsl, jobvsr, sort, selctg, n, a, lda, b,ldb, sdim, alphar, & !! DGGES3 computes for a pair of N-by-N real nonsymmetric matrices (A,B), !! the generalized eigenvalues, the generalized real Schur form (S,T), !! optionally, the left and/or right matrices of Schur vectors (VSL and @@ -79163,8 +79153,8 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvsl, jobvsr, sort - integer(ilp), intent(out) :: info, sdim - integer(ilp), intent(in) :: lda, ldb, ldvsl, ldvsr, lwork, n + integer(${ik}$), intent(out) :: info, sdim + integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, lwork, n ! Array Arguments logical(lk), intent(out) :: bwork(*) real(dp), intent(inout) :: a(lda,*), b(ldb,*) @@ -79177,104 +79167,104 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, lst2sl, & wantst - integer(ilp) :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, ip, iright, irows, & + integer(${ik}$) :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, ip, iright, irows, & itau, iwrk, lwkopt real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl, pvsr, safmax, safmin, & smlnum ! Local Arrays - integer(ilp) :: idum(1) - real(dp) :: dif(2) + integer(${ik}$) :: idum(1_${ik}$) + real(dp) :: dif(2_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvsl, 'N' ) ) then - ijobvl = 1 + ijobvl = 1_${ik}$ ilvsl = .false. else if( stdlib_lsame( jobvsl, 'V' ) ) then - ijobvl = 2 + ijobvl = 2_${ik}$ ilvsl = .true. else - ijobvl = -1 + ijobvl = -1_${ik}$ ilvsl = .false. end if if( stdlib_lsame( jobvsr, 'N' ) ) then - ijobvr = 1 + ijobvr = 1_${ik}$ ilvsr = .false. else if( stdlib_lsame( jobvsr, 'V' ) ) then - ijobvr = 2 + ijobvr = 2_${ik}$ ilvsr = .true. else - ijobvr = -1 + ijobvr = -1_${ik}$ ilvsr = .false. end if wantst = stdlib_lsame( sort, 'S' ) ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( ijobvl<=0 ) then - info = -1 - else if( ijobvr<=0 ) then - info = -2 + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) + if( ijobvl<=0_${ik}$ ) then + info = -1_${ik}$ + else if( ijobvr<=0_${ik}$ ) then + info = -2_${ik}$ else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then - info = -3 - else if( n<0 ) then - info = -5 - else if( ldazero .and. anrmzero .and. bnrm1 ) then - call stdlib_dlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& + call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vsl, ldvsl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_dlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& , ldvsl ) end if - call stdlib_dorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & + call stdlib${ii}$_dorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vsr - if( ilvsr )call stdlib_dlaset( 'FULL', n, n, zero, one, vsr, ldvsr ) + if( ilvsr )call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vsr, ldvsr ) ! reduce to generalized hessenberg form - call stdlib_dgghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& + call stdlib${ii}$_dgghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& work( iwrk ), lwork+1-iwrk,ierr ) ! perform qz algorithm, computing schur vectors if desired iwrk = itau - call stdlib_dlaqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & - beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, 0, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + call stdlib${ii}$_dlaqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & + beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, 0_${ik}$, ierr ) + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 50 end if ! sort eigenvalues alpha/beta if desired - sdim = 0 + sdim = 0_${ik}$ if( wantst ) then ! undo scaling on eigenvalues before selctging if( ilascl ) then - call stdlib_dlascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n,ierr ) - call stdlib_dlascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n,ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n,ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n,ierr ) end if - if( ilbscl )call stdlib_dlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + if( ilbscl )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) ! select eigenvalues do i = 1, n bwork( i ) = selctg( alphar( i ), alphai( i ), beta( i ) ) end do - call stdlib_dtgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, & - vsl, ldvsl, vsr, ldvsr, sdim, pvsl,pvsr, dif, work( iwrk ), lwork-iwrk+1, idum, 1,& + call stdlib${ii}$_dtgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, & + vsl, ldvsl, vsr, ldvsr, sdim, pvsl,pvsr, dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$,& ierr ) - if( ierr==1 )info = n + 3 + if( ierr==1_${ik}$ )info = n + 3_${ik}$ end if ! apply back-permutation to vsl and vsr - if( ilvsl )call stdlib_dggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, & + if( ilvsl )call stdlib${ii}$_dggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, & vsl, ldvsl, ierr ) - if( ilvsr )call stdlib_dggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, & + if( ilvsr )call stdlib${ii}$_dggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, & vsr, ldvsr, ierr ) ! check if unscaling would cause over/underflow, if so, rescale ! (alphar(i),alphai(i),beta(i)) so beta(i) is on the order of @@ -79372,16 +79362,16 @@ module stdlib_linalg_lapack_d if( alphai( i )/=zero ) then if( ( alphar( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphar( i ) )>( & anrm / anrmto ) ) then - work( 1 ) = abs( a( i, i ) / alphar( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( a( i, i ) / alphar( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) else if( ( alphai( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphai( i )& )>( anrm / anrmto ) )then - work( 1 ) = abs( a( i, i+1 ) / alphai( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( a( i, i+1 ) / alphai( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) end if end if end do @@ -79391,47 +79381,47 @@ module stdlib_linalg_lapack_d if( alphai( i )/=zero ) then if( ( beta( i ) / safmax )>( bnrmto / bnrm ) .or.( safmin / beta( i ) )>( & bnrm / bnrmto ) ) then - work( 1 ) = abs( b( i, i ) / beta( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( b( i, i ) / beta( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) end if end if end do end if ! undo scaling if( ilascl ) then - call stdlib_dlascl( 'H', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) - call stdlib_dlascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr ) - call stdlib_dlascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr ) + call stdlib${ii}$_dlascl( 'H', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr ) end if if( ilbscl ) then - call stdlib_dlascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) - call stdlib_dlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + call stdlib${ii}$_dlascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) end if if( wantst ) then ! check if reordering is correct lastsl = .true. lst2sl = .true. - sdim = 0 - ip = 0 + sdim = 0_${ik}$ + ip = 0_${ik}$ do i = 1, n cursl = selctg( alphar( i ), alphai( i ), beta( i ) ) if( alphai( i )==zero ) then - if( cursl )sdim = sdim + 1 - ip = 0 - if( cursl .and. .not.lastsl )info = n + 2 + if( cursl )sdim = sdim + 1_${ik}$ + ip = 0_${ik}$ + if( cursl .and. .not.lastsl )info = n + 2_${ik}$ else - if( ip==1 ) then + if( ip==1_${ik}$ ) then ! last eigenvalue of conjugate pair cursl = cursl .or. lastsl lastsl = cursl - if( cursl )sdim = sdim + 2 - ip = -1 - if( cursl .and. .not.lst2sl )info = n + 2 + if( cursl )sdim = sdim + 2_${ik}$ + ip = -1_${ik}$ + if( cursl .and. .not.lst2sl )info = n + 2_${ik}$ else ! first eigenvalue of conjugate pair - ip = 1 + ip = 1_${ik}$ end if end if lst2sl = lastsl @@ -79439,12 +79429,12 @@ module stdlib_linalg_lapack_d end do end if 50 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_dgges3 + end subroutine stdlib${ii}$_dgges3 - subroutine stdlib_dggev3( jobvl, jobvr, n, a, lda, b, ldb, alphar,alphai, beta, vl, ldvl, vr,& + subroutine stdlib${ii}$_dggev3( jobvl, jobvr, n, a, lda, b, ldb, alphar,alphai, beta, vl, ldvl, vr,& !! DGGEV3 computes for a pair of N-by-N real nonsymmetric matrices (A,B) !! the generalized eigenvalues, and optionally, the left and/or right !! generalized eigenvectors. @@ -79466,8 +79456,8 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvl, jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n ! Array Arguments real(dp), intent(inout) :: a(lda,*), b(ldb,*) real(dp), intent(out) :: alphai(*), alphar(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*) @@ -79477,85 +79467,85 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery character :: chtemp - integer(ilp) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, itau, & + integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, itau, & iwrk, jc, jr, lwkopt real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp ! Local Arrays - logical(lk) :: ldumma(1) + logical(lk) :: ldumma(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvl, 'N' ) ) then - ijobvl = 1 + ijobvl = 1_${ik}$ ilvl = .false. else if( stdlib_lsame( jobvl, 'V' ) ) then - ijobvl = 2 + ijobvl = 2_${ik}$ ilvl = .true. else - ijobvl = -1 + ijobvl = -1_${ik}$ ilvl = .false. end if if( stdlib_lsame( jobvr, 'N' ) ) then - ijobvr = 1 + ijobvr = 1_${ik}$ ilvr = .false. else if( stdlib_lsame( jobvr, 'V' ) ) then - ijobvr = 2 + ijobvr = 2_${ik}$ ilvr = .true. else - ijobvr = -1 + ijobvr = -1_${ik}$ ilvr = .false. end if ilv = ilvl .or. ilvr ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( ijobvl<=0 ) then - info = -1 - else if( ijobvr<=0 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldazero .and. anrmzero .and. bnrm1 ) then - call stdlib_dlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& + call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vl, ldvl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_dlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& ldvl ) end if - call stdlib_dorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & + call stdlib${ii}$_dorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vr - if( ilvr )call stdlib_dlaset( 'FULL', n, n, zero, one, vr, ldvr ) + if( ilvr )call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, vr, ldvr ) ! reduce to generalized hessenberg form if( ilv ) then ! eigenvectors requested -- work on whole matrix. - call stdlib_dgghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib${ii}$_dgghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & work( iwrk ), lwork+1-iwrk, ierr ) else - call stdlib_dgghd3( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & + call stdlib${ii}$_dgghd3( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & ldb, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr ) end if ! perform qz algorithm (compute eigenvalues, and optionally, the @@ -79640,15 +79630,15 @@ module stdlib_linalg_lapack_d else chtemp = 'E' end if - call stdlib_dlaqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & - beta, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, 0, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + call stdlib${ii}$_dlaqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & + beta, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, 0_${ik}$, ierr ) + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 110 end if @@ -79663,15 +79653,15 @@ module stdlib_linalg_lapack_d else chtemp = 'R' end if - call stdlib_dtgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & + call stdlib${ii}$_dtgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & in, work( iwrk ), ierr ) - if( ierr/=0 ) then - info = n + 2 + if( ierr/=0_${ik}$ ) then + info = n + 2_${ik}$ go to 110 end if ! undo balancing on vl and vr and normalization if( ilvl ) then - call stdlib_dggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, & + call stdlib${ii}$_dggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, & ldvl, ierr ) loop_50: do jc = 1, n if( alphai( jc ) ntiny = 15 is - ! . required and nl <= nmin = stdlib_ilaenv(ispec=12,...) is recom- + ! . through a rare stdlib${ii}$_dlahqr failure. nl > ntiny = 15 is + ! . required and nl <= nmin = stdlib${ii}$_ilaenv(ispec=12,...) is recom- ! . mended. (the default value of nmin is 75.) using nl = 49 ! . allows up to six simultaneous shifts and a 16-by-16 ! . deflation window. ==== @@ -79783,7 +79773,7 @@ module stdlib_linalg_lapack_d ! Local Arrays real(dp) :: hl(nl,nl), workl(nl) ! Local Scalars - integer(ilp) :: i, kbot, nmin + integer(${ik}$) :: i, kbot, nmin logical(lk) :: initz, lquery, wantt, wantz ! Intrinsic Functions intrinsic :: real,max,min @@ -79792,43 +79782,43 @@ module stdlib_linalg_lapack_d wantt = stdlib_lsame( job, 'S' ) initz = stdlib_lsame( compz, 'I' ) wantz = initz .or. stdlib_lsame( compz, 'V' ) - work( 1 ) = real( max( 1, n ),KIND=dp) - lquery = lwork==-1 - info = 0 + work( 1_${ik}$ ) = real( max( 1_${ik}$, n ),KIND=dp) + lquery = lwork==-1_${ik}$ + info = 0_${ik}$ if( .not.stdlib_lsame( job, 'E' ) .and. .not.wantt ) then - info = -1 + info = -1_${ik}$ else if( .not.stdlib_lsame( compz, 'N' ) .and. .not.wantz ) 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( ldhnmin ) then - call stdlib_dlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, & + call stdlib${ii}$_dlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, & work, lwork, info ) else ! ==== small matrix ==== - call stdlib_dlahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, & + call stdlib${ii}$_dlahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, & info ) - if( info>0 ) then - ! ==== a rare stdlib_dlahqr failure! stdlib_dlaqr0 sometimes succeeds - ! . when stdlib_dlahqr fails. ==== + if( info>0_${ik}$ ) then + ! ==== a rare stdlib${ii}$_dlahqr failure! stdlib${ii}$_dlaqr0 sometimes succeeds + ! . when stdlib${ii}$_dlahqr fails. ==== kbot = info if( n>=nl ) then ! ==== larger matrices have enough subdiagonal scratch - ! . space to call stdlib_dlaqr0 directly. ==== - call stdlib_dlaqr0( wantt, wantz, n, ilo, kbot, h, ldh, wr,wi, ilo, ihi, z,& + ! . space to call stdlib${ii}$_dlaqr0 directly. ==== + call stdlib${ii}$_dlaqr0( wantt, wantz, n, ilo, kbot, h, ldh, wr,wi, ilo, ihi, z,& ldz, work, lwork, info ) else ! ==== tiny matrices don't have enough subdiagonal - ! . scratch space to benefit from stdlib_dlaqr0. hence, + ! . scratch space to benefit from stdlib${ii}$_dlaqr0. hence, ! . tiny matrices must be copied into a larger - ! . array before calling stdlib_dlaqr0. ==== - call stdlib_dlacpy( 'A', n, n, h, ldh, hl, nl ) + ! . array before calling stdlib${ii}$_dlaqr0. ==== + call stdlib${ii}$_dlacpy( 'A', n, n, h, ldh, hl, nl ) hl( n+1, n ) = zero - call stdlib_dlaset( 'A', nl, nl-n, zero, zero, hl( 1, n+1 ),nl ) - call stdlib_dlaqr0( wantt, wantz, nl, ilo, kbot, hl, nl, wr,wi, ilo, ihi, & + call stdlib${ii}$_dlaset( 'A', nl, nl-n, zero, zero, hl( 1_${ik}$, n+1 ),nl ) + call stdlib${ii}$_dlaqr0( wantt, wantz, nl, ilo, kbot, hl, nl, wr,wi, ilo, ihi, & z, ldz, workl, nl, info ) - if( wantt .or. info/=0 )call stdlib_dlacpy( 'A', n, n, hl, nl, h, ldh ) + if( wantt .or. info/=0_${ik}$ )call stdlib${ii}$_dlacpy( 'A', n, n, hl, nl, h, ldh ) end if end if end if ! ==== clear out the trash, if necessary. ==== - if( ( wantt .or. info/=0 ) .and. n>2 )call stdlib_dlaset( 'L', n-2, n-2, zero, zero,& - h( 3, 1 ), ldh ) + if( ( wantt .or. info/=0_${ik}$ ) .and. n>2_${ik}$ )call stdlib${ii}$_dlaset( 'L', n-2, n-2, zero, zero,& + h( 3_${ik}$, 1_${ik}$ ), ldh ) ! ==== ensure reported workspace size is backward-compatible with ! . previous lapack versions. ==== - work( 1 ) = max( real( max( 1, n ),KIND=dp), work( 1 ) ) + work( 1_${ik}$ ) = max( real( max( 1_${ik}$, n ),KIND=dp), work( 1_${ik}$ ) ) end if - end subroutine stdlib_dhseqr + end subroutine stdlib${ii}$_dhseqr - pure subroutine stdlib_dlalsa( icompq, smlsiz, n, nrhs, b, ldb, bx, ldbx, u,ldu, vt, k, difl,& + pure subroutine stdlib${ii}$_dlalsa( icompq, smlsiz, n, nrhs, b, ldb, bx, ldbx, u,ldu, vt, k, difl,& !! DLALSA is an itermediate step in solving the least squares problem !! by computing the SVD of the coefficient matrix in compact form (The !! singular vectors are computed as products of simple orthorgonal @@ -79906,11 +79896,11 @@ module stdlib_linalg_lapack_d ! -- 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, ldb, ldbx, ldgcol, ldu, n, nrhs, smlsiz - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: icompq, ldb, ldbx, ldgcol, ldu, n, nrhs, smlsiz + integer(${ik}$), intent(out) :: info ! Array Arguments - integer(ilp), intent(in) :: givcol(ldgcol,*), givptr(*), k(*), perm(ldgcol,*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(in) :: givcol(ldgcol,*), givptr(*), k(*), perm(ldgcol,*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(inout) :: b(ldb,*) real(dp), intent(out) :: bx(ldbx,*), work(*) real(dp), intent(in) :: c(*), difl(ldu,*), difr(ldu,*), givnum(ldu,*), poles(ldu,*), s(& @@ -79918,95 +79908,95 @@ module stdlib_linalg_lapack_d ! ===================================================================== ! Local Scalars - integer(ilp) :: i, i1, ic, im1, inode, j, lf, ll, lvl, lvl2, nd, ndb1, ndiml, ndimr, & + integer(${ik}$) :: i, i1, ic, im1, inode, j, lf, ll, lvl, lvl2, nd, ndb1, ndiml, ndimr, & nl, nlf, nlp1, nlvl, nr, nrf, nrp1, sqre ! Executable Statements ! test the input parameters. - info = 0 - if( ( icompq<0 ) .or. ( icompq>1 ) ) then - info = -1 - else if( smlsiz<3 ) then - info = -2 + info = 0_${ik}$ + if( ( icompq<0_${ik}$ ) .or. ( icompq>1_${ik}$ ) ) then + info = -1_${ik}$ + else if( smlsiz<3_${ik}$ ) then + info = -2_${ik}$ else if( n=one ) ) then rcnd = eps else rcnd = rcond end if - rank = 0 + rank = 0_${ik}$ ! quick return if possible. - if( n==0 ) then + if( n==0_${ik}$ ) then return - else if( n==1 ) then - if( d( 1 )==zero ) then - call stdlib_dlaset( 'A', 1, nrhs, zero, zero, b, ldb ) + else if( n==1_${ik}$ ) then + if( d( 1_${ik}$ )==zero ) then + call stdlib${ii}$_dlaset( 'A', 1_${ik}$, nrhs, zero, zero, b, ldb ) else - rank = 1 - call stdlib_dlascl( 'G', 0, 0, d( 1 ), one, 1, nrhs, b, ldb, info ) - d( 1 ) = abs( d( 1 ) ) + rank = 1_${ik}$ + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, d( 1_${ik}$ ), one, 1_${ik}$, nrhs, b, ldb, info ) + d( 1_${ik}$ ) = abs( d( 1_${ik}$ ) ) end if return end if ! rotate the matrix if it is lower bidiagonal. if( uplo=='L' ) then do i = 1, n - 1 - call stdlib_dlartg( d( i ), e( i ), cs, sn, r ) + call stdlib${ii}$_dlartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) - if( nrhs==1 ) then - call stdlib_drot( 1, b( i, 1 ), 1, b( i+1, 1 ), 1, cs, sn ) + if( nrhs==1_${ik}$ ) then + call stdlib${ii}$_drot( 1_${ik}$, b( i, 1_${ik}$ ), 1_${ik}$, b( i+1, 1_${ik}$ ), 1_${ik}$, cs, sn ) else - work( i*2-1 ) = cs - work( i*2 ) = sn + work( i*2_${ik}$-1 ) = cs + work( i*2_${ik}$ ) = sn end if end do - if( nrhs>1 ) then + if( nrhs>1_${ik}$ ) then do i = 1, nrhs do j = 1, n - 1 - cs = work( j*2-1 ) - sn = work( j*2 ) - call stdlib_drot( 1, b( j, i ), 1, b( j+1, i ), 1, cs, sn ) + cs = work( j*2_${ik}$-1 ) + sn = work( j*2_${ik}$ ) + call stdlib${ii}$_drot( 1_${ik}$, b( j, i ), 1_${ik}$, b( j+1, i ), 1_${ik}$, cs, sn ) end do end do end if end if ! scale. - nm1 = n - 1 - orgnrm = stdlib_dlanst( 'M', n, d, e ) + nm1 = n - 1_${ik}$ + orgnrm = stdlib${ii}$_dlanst( 'M', n, d, e ) if( orgnrm==zero ) then - call stdlib_dlaset( 'A', n, nrhs, zero, zero, b, ldb ) + call stdlib${ii}$_dlaset( 'A', n, nrhs, zero, zero, b, ldb ) return end if - call stdlib_dlascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info ) - call stdlib_dlascl( 'G', 0, 0, orgnrm, one, nm1, 1, e, nm1, info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, n, 1_${ik}$, d, n, info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, nm1, 1_${ik}$, e, nm1, info ) ! if n is smaller than the minimum divide size smlsiz, then solve ! the problem with another solver. if( n<=smlsiz ) then - nwork = 1 + n*n - call stdlib_dlaset( 'A', n, n, zero, one, work, n ) - call stdlib_dlasdq( 'U', 0, n, n, 0, nrhs, d, e, work, n, work, n, b,ldb, work( & + nwork = 1_${ik}$ + n*n + call stdlib${ii}$_dlaset( 'A', n, n, zero, one, work, n ) + call stdlib${ii}$_dlasdq( 'U', 0_${ik}$, n, n, 0_${ik}$, nrhs, d, e, work, n, work, n, b,ldb, work( & nwork ), info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if - tol = rcnd*abs( d( stdlib_idamax( n, d, 1 ) ) ) + tol = rcnd*abs( d( stdlib${ii}$_idamax( n, d, 1_${ik}$ ) ) ) do i = 1, n if( d( i )<=tol ) then - call stdlib_dlaset( 'A', 1, nrhs, zero, zero, b( i, 1 ), ldb ) + call stdlib${ii}$_dlaset( 'A', 1_${ik}$, nrhs, zero, zero, b( i, 1_${ik}$ ), ldb ) else - call stdlib_dlascl( 'G', 0, 0, d( i ), one, 1, nrhs, b( i, 1 ),ldb, info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, d( i ), one, 1_${ik}$, nrhs, b( i, 1_${ik}$ ),ldb, info ) - rank = rank + 1 + rank = rank + 1_${ik}$ end if end do - call stdlib_dgemm( 'T', 'N', n, nrhs, n, one, work, n, b, ldb, zero,work( nwork ), & + call stdlib${ii}$_dgemm( 'T', 'N', n, nrhs, n, one, work, n, b, ldb, zero,work( nwork ), & n ) - call stdlib_dlacpy( 'A', n, nrhs, work( nwork ), n, b, ldb ) + call stdlib${ii}$_dlacpy( 'A', n, nrhs, work( nwork ), n, b, ldb ) ! unscale. - call stdlib_dlascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) - call stdlib_dlasrt( 'D', n, d, info ) - call stdlib_dlascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, n, 1_${ik}$, d, n, info ) + call stdlib${ii}$_dlasrt( 'D', n, d, info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, n, nrhs, b, ldb, info ) return end if ! book-keeping and setting up some constants. - nlvl = int( log( real( n,KIND=dp) / real( smlsiz+1,KIND=dp) ) / log( two ),KIND=ilp) + & - 1 - smlszp = smlsiz + 1 - u = 1 - vt = 1 + smlsiz*n + nlvl = int( log( real( n,KIND=dp) / real( smlsiz+1,KIND=dp) ) / log( two ),KIND=${ik}$) + & + 1_${ik}$ + smlszp = smlsiz + 1_${ik}$ + u = 1_${ik}$ + vt = 1_${ik}$ + smlsiz*n difl = vt + smlszp*n difr = difl + nlvl*n - z = difr + nlvl*n*2 + z = difr + nlvl*n*2_${ik}$ c = z + nlvl*n s = c + n poles = s + n - givnum = poles + 2*nlvl*n - bx = givnum + 2*nlvl*n + givnum = poles + 2_${ik}$*nlvl*n + bx = givnum + 2_${ik}$*nlvl*n nwork = bx + n*nrhs - sizei = 1 + n + sizei = 1_${ik}$ + n k = sizei + n givptr = k + n perm = givptr + n givcol = perm + nlvl*n - iwk = givcol + nlvl*n*2 - st = 1 - sqre = 0 - icmpq1 = 1 - icmpq2 = 0 - nsub = 0 + iwk = givcol + nlvl*n*2_${ik}$ + st = 1_${ik}$ + sqre = 0_${ik}$ + icmpq1 = 1_${ik}$ + icmpq2 = 0_${ik}$ + nsub = 0_${ik}$ do i = 1, n if( abs( d( i ) )=eps ) then ! a subproblem with e(nm1) not too small but i = nm1. - nsize = n - st + 1 + nsize = n - st + 1_${ik}$ iwork( sizei+nsub-1 ) = nsize else ! a subproblem with e(nm1) small. this implies an ! 1-by-1 subproblem at d(n), which is not solved ! explicitly. - nsize = i - st + 1 + nsize = i - st + 1_${ik}$ iwork( sizei+nsub-1 ) = nsize - nsub = nsub + 1 + nsub = nsub + 1_${ik}$ iwork( nsub ) = n - iwork( sizei+nsub-1 ) = 1 - call stdlib_dcopy( nrhs, b( n, 1 ), ldb, work( bx+nm1 ), n ) + iwork( sizei+nsub-1 ) = 1_${ik}$ + call stdlib${ii}$_dcopy( nrhs, b( n, 1_${ik}$ ), ldb, work( bx+nm1 ), n ) end if - st1 = st - 1 - if( nsize==1 ) then + st1 = st - 1_${ik}$ + if( nsize==1_${ik}$ ) then ! this is a 1-by-1 subproblem and is not solved ! explicitly. - call stdlib_dcopy( nrhs, b( st, 1 ), ldb, work( bx+st1 ), n ) + call stdlib${ii}$_dcopy( nrhs, b( st, 1_${ik}$ ), ldb, work( bx+st1 ), n ) else if( nsize<=smlsiz ) then - ! this is a small subproblem and is solved by stdlib_dlasdq. - call stdlib_dlaset( 'A', nsize, nsize, zero, one,work( vt+st1 ), n ) - call stdlib_dlasdq( 'U', 0, nsize, nsize, 0, nrhs, d( st ),e( st ), work( vt+& - st1 ), n, work( nwork ),n, b( st, 1 ), ldb, work( nwork ), info ) - if( info/=0 ) then + ! this is a small subproblem and is solved by stdlib${ii}$_dlasdq. + call stdlib${ii}$_dlaset( 'A', nsize, nsize, zero, one,work( vt+st1 ), n ) + call stdlib${ii}$_dlasdq( 'U', 0_${ik}$, nsize, nsize, 0_${ik}$, nrhs, d( st ),e( st ), work( vt+& + st1 ), n, work( nwork ),n, b( st, 1_${ik}$ ), ldb, work( nwork ), info ) + if( info/=0_${ik}$ ) then return end if - call stdlib_dlacpy( 'A', nsize, nrhs, b( st, 1 ), ldb,work( bx+st1 ), n ) + call stdlib${ii}$_dlacpy( 'A', nsize, nrhs, b( st, 1_${ik}$ ), ldb,work( bx+st1 ), n ) else ! a large problem. solve it using divide and conquer. - call stdlib_dlasda( icmpq1, smlsiz, nsize, sqre, d( st ),e( st ), work( u+st1 & + call stdlib${ii}$_dlasda( icmpq1, smlsiz, nsize, sqre, d( st ),e( st ), work( u+st1 & ), n, work( vt+st1 ),iwork( k+st1 ), work( difl+st1 ),work( difr+st1 ), work( & z+st1 ),work( poles+st1 ), iwork( givptr+st1 ),iwork( givcol+st1 ), n, iwork( & perm+st1 ),work( givnum+st1 ), work( c+st1 ),work( s+st1 ), work( nwork ), & iwork( iwk ),info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if bxst = bx + st1 - call stdlib_dlalsa( icmpq2, smlsiz, nsize, nrhs, b( st, 1 ),ldb, work( bxst ),& + call stdlib${ii}$_dlalsa( icmpq2, smlsiz, nsize, nrhs, b( st, 1_${ik}$ ),ldb, work( bxst ),& n, work( u+st1 ), n,work( vt+st1 ), iwork( k+st1 ),work( difl+st1 ), work( & difr+st1 ),work( z+st1 ), work( poles+st1 ),iwork( givptr+st1 ), iwork( & givcol+st1 ), n,iwork( perm+st1 ), work( givnum+st1 ),work( c+st1 ), work( s+& st1 ), work( nwork ),iwork( iwk ), info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if end if - st = i + 1 + st = i + 1_${ik}$ end if end do loop_60 ! apply the singular values and treat the tiny ones as zero. - tol = rcnd*abs( d( stdlib_idamax( n, d, 1 ) ) ) + tol = rcnd*abs( d( stdlib${ii}$_idamax( n, d, 1_${ik}$ ) ) ) do i = 1, n ! some of the elements in d can be negative because 1-by-1 ! subproblems were not solved explicitly. if( abs( d( i ) )<=tol ) then - call stdlib_dlaset( 'A', 1, nrhs, zero, zero, work( bx+i-1 ), n ) + call stdlib${ii}$_dlaset( 'A', 1_${ik}$, nrhs, zero, zero, work( bx+i-1 ), n ) else - rank = rank + 1 - call stdlib_dlascl( 'G', 0, 0, d( i ), one, 1, nrhs,work( bx+i-1 ), n, info ) + rank = rank + 1_${ik}$ + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, d( i ), one, 1_${ik}$, nrhs,work( bx+i-1 ), n, info ) end if d( i ) = abs( d( i ) ) end do ! now apply back the right singular vectors. - icmpq2 = 1 + icmpq2 = 1_${ik}$ do i = 1, nsub st = iwork( i ) - st1 = st - 1 + st1 = st - 1_${ik}$ nsize = iwork( sizei+i-1 ) bxst = bx + st1 - if( nsize==1 ) then - call stdlib_dcopy( nrhs, work( bxst ), n, b( st, 1 ), ldb ) + if( nsize==1_${ik}$ ) then + call stdlib${ii}$_dcopy( nrhs, work( bxst ), n, b( st, 1_${ik}$ ), ldb ) else if( nsize<=smlsiz ) then - call stdlib_dgemm( 'T', 'N', nsize, nrhs, nsize, one,work( vt+st1 ), n, work( & - bxst ), n, zero,b( st, 1 ), ldb ) + call stdlib${ii}$_dgemm( 'T', 'N', nsize, nrhs, nsize, one,work( vt+st1 ), n, work( & + bxst ), n, zero,b( st, 1_${ik}$ ), ldb ) else - call stdlib_dlalsa( icmpq2, smlsiz, nsize, nrhs, work( bxst ), n,b( st, 1 ), ldb,& + call stdlib${ii}$_dlalsa( icmpq2, smlsiz, nsize, nrhs, work( bxst ), n,b( st, 1_${ik}$ ), ldb,& work( u+st1 ), n,work( vt+st1 ), iwork( k+st1 ),work( difl+st1 ), work( difr+& st1 ),work( z+st1 ), work( poles+st1 ),iwork( givptr+st1 ), iwork( givcol+st1 ),& n,iwork( perm+st1 ), work( givnum+st1 ),work( c+st1 ), work( s+st1 ), work( & nwork ),iwork( iwk ), info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if end if end do ! unscale and sort the singular values. - call stdlib_dlascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) - call stdlib_dlasrt( 'D', n, d, info ) - call stdlib_dlascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, n, 1_${ik}$, d, n, info ) + call stdlib${ii}$_dlasrt( 'D', n, d, info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, n, nrhs, b, ldb, info ) return - end subroutine stdlib_dlalsd + end subroutine stdlib${ii}$_dlalsd - subroutine stdlib_dlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, work,& + subroutine stdlib${ii}$_dlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, work,& !! DLAQR0 computes the eigenvalues of a Hessenberg matrix H !! and, optionally, the matrices T and Z from the Schur decomposition !! H = Z T Z**T, where T is an upper quasi-triangular matrix (the @@ -80362,21 +80352,21 @@ module stdlib_linalg_lapack_d ! -- 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, ihiz, ilo, iloz, ldh, ldz, lwork, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ihiz, ilo, iloz, ldh, ldz, lwork, n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt, wantz ! Array Arguments real(dp), intent(inout) :: h(ldh,*), z(ldz,*) real(dp), intent(out) :: wi(*), work(*), wr(*) ! ================================================================ ! Parameters - integer(ilp), parameter :: ntiny = 15 - integer(ilp), parameter :: kexnw = 5 - integer(ilp), parameter :: kexsh = 6 + integer(${ik}$), parameter :: ntiny = 15_${ik}$ + integer(${ik}$), parameter :: kexnw = 5_${ik}$ + integer(${ik}$), parameter :: kexsh = 6_${ik}$ real(dp), parameter :: wilk1 = 0.75_dp real(dp), parameter :: wilk2 = -0.4375_dp ! ==== matrices of order ntiny or smaller must be processed by - ! . stdlib_dlahqr because of insufficient subdiagonal scratch space. + ! . stdlib${ii}$_dlahqr because of insufficient subdiagonal scratch space. ! . (this is a hard limit.) ==== ! ==== exceptional deflation windows: try to cure rare @@ -80393,92 +80383,92 @@ module stdlib_linalg_lapack_d ! Local Scalars real(dp) :: aa, bb, cc, cs, dd, sn, ss, swap - integer(ilp) :: i, inf, it, itmax, k, kacc22, kbot, kdu, ks, kt, ktop, ku, kv, kwh, & + integer(${ik}$) :: i, inf, it, itmax, k, kacc22, kbot, kdu, ks, kt, ktop, ku, kv, kwh, & kwtop, kwv, ld, ls, lwkopt, ndec, ndfl, nh, nho, nibble, nmin, ns, nsmax, nsr, nve, nw,& nwmax, nwr, nwupbd logical(lk) :: sorted - character :: jbcmpz*2 + character(len=2_${ik}$) :: jbcmpz ! Local Arrays - real(dp) :: zdum(1,1) + real(dp) :: zdum(1_${ik}$,1_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,int,max,min,mod ! Executable Statements - info = 0 + info = 0_${ik}$ ! ==== quick return for n = 0: nothing to do. ==== - if( n==0 ) then - work( 1 ) = one + if( n==0_${ik}$ ) then + work( 1_${ik}$ ) = one return end if if( n<=ntiny ) then ! ==== tiny matrices must use stdlib_dlahqr. ==== - lwkopt = 1 - if( lwork/=-1 )call stdlib_dlahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, & + lwkopt = 1_${ik}$ + if( lwork/=-1_${ik}$ )call stdlib${ii}$_dlahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, & ihiz, z, ldz, info ) else ! ==== use small bulge multi-shift qr with aggressive early ! . deflation on larger-than-tiny matrices. ==== ! ==== hope for the best. ==== - info = 0 - ! ==== set up job flags for stdlib_ilaenv. ==== + info = 0_${ik}$ + ! ==== set up job flags for stdlib${ii}$_ilaenv. ==== if( wantt ) then - jbcmpz( 1: 1 ) = 'S' + jbcmpz( 1_${ik}$: 1_${ik}$ ) = 'S' else - jbcmpz( 1: 1 ) = 'E' + jbcmpz( 1_${ik}$: 1_${ik}$ ) = 'E' end if if( wantz ) then - jbcmpz( 2: 2 ) = 'V' + jbcmpz( 2_${ik}$: 2_${ik}$ ) = 'V' else - jbcmpz( 2: 2 ) = 'N' + jbcmpz( 2_${ik}$: 2_${ik}$ ) = 'N' end if ! ==== nwr = recommended deflation window size. at this ! . point, n > ntiny = 15, so there is enough ! . subdiagonal workspace for nwr>=2 as required. ! . (in fact, there is enough subdiagonal space for ! . nwr>=4.) ==== - nwr = stdlib_ilaenv( 13, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork ) - nwr = max( 2, nwr ) - nwr = min( ihi-ilo+1, ( n-1 ) / 3, nwr ) + nwr = stdlib${ii}$_ilaenv( 13_${ik}$, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork ) + nwr = max( 2_${ik}$, nwr ) + nwr = min( ihi-ilo+1, ( n-1 ) / 3_${ik}$, nwr ) ! ==== nsr = recommended number of simultaneous shifts. ! . at this point n > ntiny = 15, so there is at ! . enough subdiagonal workspace for nsr to be even ! . and greater than or equal to two as required. ==== - nsr = stdlib_ilaenv( 15, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork ) - nsr = min( nsr, ( n-3 ) / 6, ihi-ilo ) - nsr = max( 2, nsr-mod( nsr, 2 ) ) + nsr = stdlib${ii}$_ilaenv( 15_${ik}$, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork ) + nsr = min( nsr, ( n-3 ) / 6_${ik}$, ihi-ilo ) + nsr = max( 2_${ik}$, nsr-mod( nsr, 2_${ik}$ ) ) ! ==== estimate optimal workspace ==== - ! ==== workspace query call to stdlib_dlaqr3 ==== - call stdlib_dlaqr3( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& - ld, wr, wi, h, ldh, n, h, ldh,n, h, ldh, work, -1 ) - ! ==== optimal workspace = max(stdlib_dlaqr5, stdlib_dlaqr3) ==== - lwkopt = max( 3*nsr / 2, int( work( 1 ),KIND=ilp) ) + ! ==== workspace query call to stdlib${ii}$_dlaqr3 ==== + call stdlib${ii}$_dlaqr3( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& + ld, wr, wi, h, ldh, n, h, ldh,n, h, ldh, work, -1_${ik}$ ) + ! ==== optimal workspace = max(stdlib${ii}$_dlaqr5, stdlib${ii}$_dlaqr3) ==== + lwkopt = max( 3_${ik}$*nsr / 2_${ik}$, int( work( 1_${ik}$ ),KIND=${ik}$) ) ! ==== quick return in case of workspace query. ==== - if( lwork==-1 ) then - work( 1 ) = real( lwkopt,KIND=dp) + if( lwork==-1_${ik}$ ) then + work( 1_${ik}$ ) = real( lwkopt,KIND=dp) return end if - ! ==== stdlib_dlahqr/stdlib_dlaqr0 crossover point ==== - nmin = stdlib_ilaenv( 12, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork ) + ! ==== stdlib${ii}$_dlahqr/stdlib${ii}$_dlaqr0 crossover point ==== + nmin = stdlib${ii}$_ilaenv( 12_${ik}$, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork ) nmin = max( ntiny, nmin ) ! ==== nibble crossover point ==== - nibble = stdlib_ilaenv( 14, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork ) - nibble = max( 0, nibble ) + nibble = stdlib${ii}$_ilaenv( 14_${ik}$, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork ) + nibble = max( 0_${ik}$, nibble ) ! ==== accumulate reflections during ttswp? use block ! . 2-by-2 structure during matrix-matrix multiply? ==== - kacc22 = stdlib_ilaenv( 16, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork ) - kacc22 = max( 0, kacc22 ) - kacc22 = min( 2, kacc22 ) + kacc22 = stdlib${ii}$_ilaenv( 16_${ik}$, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork ) + kacc22 = max( 0_${ik}$, kacc22 ) + kacc22 = min( 2_${ik}$, kacc22 ) ! ==== nwmax = the largest possible deflation window for ! . which there is sufficient workspace. ==== - nwmax = min( ( n-1 ) / 3, lwork / 2 ) + nwmax = min( ( n-1 ) / 3_${ik}$, lwork / 2_${ik}$ ) nw = nwmax ! ==== nsmax = the largest number of simultaneous shifts ! . for which there is sufficient workspace. ==== - nsmax = min( ( n-3 ) / 6, 2*lwork / 3 ) - nsmax = nsmax - mod( nsmax, 2 ) + nsmax = min( ( n-3 ) / 6_${ik}$, 2_${ik}$*lwork / 3_${ik}$ ) + nsmax = nsmax - mod( nsmax, 2_${ik}$ ) ! ==== ndfl: an iteration count restarted at deflation. ==== - ndfl = 1 + ndfl = 1_${ik}$ ! ==== itmax = iteration limit ==== - itmax = max( 30, 2*kexsh )*max( 10, ( ihi-ilo+1 ) ) + itmax = max( 30_${ik}$, 2_${ik}$*kexsh )*max( 10_${ik}$, ( ihi-ilo+1 ) ) ! ==== last row and column in the active block ==== kbot = ihi ! ==== main loop ==== @@ -80506,27 +80496,27 @@ module stdlib_linalg_lapack_d ! . in general, more powerful than smaller ones, ! . rapidly increase the window to the maximum possible. ! . then, gradually reduce the window size. ==== - nh = kbot - ktop + 1 + nh = kbot - ktop + 1_${ik}$ nwupbd = min( nh, nwmax ) if( ndfl=nh-1 ) then nw = nh else - kwtop = kbot - nw + 1 + kwtop = kbot - nw + 1_${ik}$ if( abs( h( kwtop, kwtop-1 ) )>abs( h( kwtop-1, kwtop-2 ) ) )nw = nw + & - 1 + 1_${ik}$ end if end if if( ndfl=0 .or. nw>=nwupbd ) then - ndec = ndec + 1 - if( nw-ndec<2 )ndec = 0 + ndec = -1_${ik}$ + else if( ndec>=0_${ik}$ .or. nw>=nwupbd ) then + ndec = ndec + 1_${ik}$ + if( nw-ndec<2_${ik}$ )ndec = 0_${ik}$ nw = nw - ndec end if ! ==== aggressive early deflation: @@ -80539,46 +80529,46 @@ module stdlib_linalg_lapack_d ! . - an at-least-nw-but-more-is-better (nhv-by-nw) ! . vertical work array along the left-hand-edge. ! . ==== - kv = n - nw + 1 - kt = nw + 1 - nho = ( n-nw-1 ) - kt + 1 - kwv = nw + 2 - nve = ( n-nw ) - kwv + 1 + kv = n - nw + 1_${ik}$ + kt = nw + 1_${ik}$ + nho = ( n-nw-1 ) - kt + 1_${ik}$ + kwv = nw + 2_${ik}$ + nve = ( n-nw ) - kwv + 1_${ik}$ ! ==== aggressive early deflation ==== - call stdlib_dlaqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & - ls, ld, wr, wi, h( kv, 1 ), ldh,nho, h( kv, kt ), ldh, nve, h( kwv, 1 ), ldh,& + call stdlib${ii}$_dlaqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & + ls, ld, wr, wi, h( kv, 1_${ik}$ ), ldh,nho, h( kv, kt ), ldh, nve, h( kwv, 1_${ik}$ ), ldh,& work, lwork ) ! ==== adjust kbot accounting for new deflations. ==== kbot = kbot - ld ! ==== ks points to the shifts. ==== - ks = kbot - ls + 1 + ks = kbot - ls + 1_${ik}$ ! ==== skip an expensive qr sweep if there is a (partly ! . heuristic) reason to expect that many eigenvalues ! . will deflate without it. here, the qr sweep is ! . skipped if many eigenvalues have just been deflated ! . or if the remaining active block is small. - if( ( ld==0 ) .or. ( ( 100*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& + if( ( ld==0_${ik}$ ) .or. ( ( 100_${ik}$*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& ) ) ) then ! ==== ns = nominal number of simultaneous shifts. - ! . this may be lowered (slightly) if stdlib_dlaqr3 + ! . this may be lowered (slightly) if stdlib${ii}$_dlaqr3 ! . did not provide that many shifts. ==== - ns = min( nsmax, nsr, max( 2, kbot-ktop ) ) - ns = ns - mod( ns, 2 ) + ns = min( nsmax, nsr, max( 2_${ik}$, kbot-ktop ) ) + ns = ns - mod( ns, 2_${ik}$ ) ! ==== if there have been no deflations ! . in a multiple of kexsh iterations, ! . then try exceptional shifts. ! . otherwise use shifts provided by - ! . stdlib_dlaqr3 above or from the eigenvalues + ! . stdlib${ii}$_dlaqr3 above or from the eigenvalues ! . of a trailing principal submatrix. ==== - if( mod( ndfl, kexsh )==0 ) then - ks = kbot - ns + 1 + if( mod( ndfl, kexsh )==0_${ik}$ ) then + ks = kbot - ns + 1_${ik}$ do i = kbot, max( ks+1, ktop+2 ), -2 ss = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) ) aa = wilk1*ss + h( i, i ) bb = ss cc = wilk2*ss dd = aa - call stdlib_dlanv2( aa, bb, cc, dd, wr( i-1 ), wi( i-1 ),wr( i ), wi( i & + call stdlib${ii}$_dlanv2( aa, bb, cc, dd, wr( i-1 ), wi( i-1 ),wr( i ), wi( i & ), cs, sn ) end do if( ks==ktop ) then @@ -80589,21 +80579,21 @@ module stdlib_linalg_lapack_d end if else ! ==== got ns/2 or fewer shifts? use stdlib_dlaqr4 or - ! . stdlib_dlahqr on a trailing principal submatrix to + ! . stdlib${ii}$_dlahqr on a trailing principal submatrix to ! . get more. (since ns<=nsmax<=(n-3)/6, ! . there is enough space below the subdiagonal ! . to fit an ns-by-ns scratch array.) ==== - if( kbot-ks+1<=ns / 2 ) then - ks = kbot - ns + 1 - kt = n - ns + 1 - call stdlib_dlacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1 ), ldh ) + if( kbot-ks+1<=ns / 2_${ik}$ ) then + ks = kbot - ns + 1_${ik}$ + kt = n - ns + 1_${ik}$ + call stdlib${ii}$_dlacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1_${ik}$ ), ldh ) if( ns>nmin ) then - call stdlib_dlaqr4( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, wr( & - ks ),wi( ks ), 1, 1, zdum, 1, work,lwork, inf ) + call stdlib${ii}$_dlaqr4( .false., .false., ns, 1_${ik}$, ns,h( kt, 1_${ik}$ ), ldh, wr( & + ks ),wi( ks ), 1_${ik}$, 1_${ik}$, zdum, 1_${ik}$, work,lwork, inf ) else - call stdlib_dlahqr( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, wr( & - ks ),wi( ks ), 1, 1, zdum, 1, inf ) + call stdlib${ii}$_dlahqr( .false., .false., ns, 1_${ik}$, ns,h( kt, 1_${ik}$ ), ldh, wr( & + ks ),wi( ks ), 1_${ik}$, 1_${ik}$, zdum, 1_${ik}$, inf ) end if ks = ks + inf ! ==== in case of a rare qr failure use @@ -80614,9 +80604,9 @@ module stdlib_linalg_lapack_d cc = h( kbot, kbot-1 ) bb = h( kbot-1, kbot ) dd = h( kbot, kbot ) - call stdlib_dlanv2( aa, bb, cc, dd, wr( kbot-1 ),wi( kbot-1 ), wr( & + call stdlib${ii}$_dlanv2( aa, bb, cc, dd, wr( kbot-1 ),wi( kbot-1 ), wr( & kbot ),wi( kbot ), cs, sn ) - ks = kbot - 1 + ks = kbot - 1_${ik}$ end if end if if( kbot-ks+1>ns ) then @@ -80662,7 +80652,7 @@ module stdlib_linalg_lapack_d end if ! ==== if there are only two shifts and both are ! . real, then use only one. ==== - if( kbot-ks+1==2 ) then + if( kbot-ks+1==2_${ik}$ ) then if( wi( kbot )==zero ) then if( abs( wr( kbot )-h( kbot, kbot ) )0 ) then - ndfl = 1 + if( ld>0_${ik}$ ) then + ndfl = 1_${ik}$ else - ndfl = ndfl + 1 + ndfl = ndfl + 1_${ik}$ end if ! ==== end of main loop ==== end do loop_80 @@ -80714,11 +80704,11 @@ module stdlib_linalg_lapack_d 90 continue end if ! ==== return the optimal value of lwork. ==== - work( 1 ) = real( lwkopt,KIND=dp) - end subroutine stdlib_dlaqr0 + work( 1_${ik}$ ) = real( lwkopt,KIND=dp) + end subroutine stdlib${ii}$_dlaqr0 - subroutine stdlib_dlaqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, ns, nd,& + subroutine stdlib${ii}$_dlaqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, ns, nd,& !! Aggressive early deflation: !! DLAQR3 accepts as input an upper Hessenberg matrix !! H and performs an orthogonal similarity transformation @@ -80733,9 +80723,9 @@ module stdlib_linalg_lapack_d ! -- 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) :: ihiz, iloz, kbot, ktop, ldh, ldt, ldv, ldwv, ldz, lwork, n,& + integer(${ik}$), intent(in) :: ihiz, iloz, kbot, ktop, ldh, ldt, ldv, ldwv, ldz, lwork, n,& nh, nv, nw - integer(ilp), intent(out) :: nd, ns + integer(${ik}$), intent(out) :: nd, ns logical(lk), intent(in) :: wantt, wantz ! Array Arguments real(dp), intent(inout) :: h(ldh,*), z(ldz,*) @@ -80745,7 +80735,7 @@ module stdlib_linalg_lapack_d ! Local Scalars real(dp) :: aa, bb, beta, cc, cs, dd, evi, evk, foo, s, safmax, safmin, smlnum, sn, & tau, ulp - integer(ilp) :: i, ifst, ilst, info, infqr, j, jw, k, kcol, kend, kln, krow, kwtop, & + integer(${ik}$) :: i, ifst, ilst, info, infqr, j, jw, k, kcol, kend, kln, krow, kwtop, & ltop, lwk1, lwk2, lwk3, lwkopt, nmin logical(lk) :: bulge, sorted ! Intrinsic Functions @@ -80753,45 +80743,45 @@ module stdlib_linalg_lapack_d ! Executable Statements ! ==== estimate optimal workspace. ==== jw = min( nw, kbot-ktop+1 ) - if( jw<=2 ) then - lwkopt = 1 - else - ! ==== workspace query call to stdlib_dgehrd ==== - call stdlib_dgehrd( jw, 1, jw-1, t, ldt, work, work, -1, info ) - lwk1 = int( work( 1 ),KIND=ilp) - ! ==== workspace query call to stdlib_dormhr ==== - call stdlib_dormhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv,work, -1, info ) + if( jw<=2_${ik}$ ) then + lwkopt = 1_${ik}$ + else + ! ==== workspace query call to stdlib${ii}$_dgehrd ==== + call stdlib${ii}$_dgehrd( jw, 1_${ik}$, jw-1, t, ldt, work, work, -1_${ik}$, info ) + lwk1 = int( work( 1_${ik}$ ),KIND=${ik}$) + ! ==== workspace query call to stdlib${ii}$_dormhr ==== + call stdlib${ii}$_dormhr( 'R', 'N', jw, jw, 1_${ik}$, jw-1, t, ldt, work, v, ldv,work, -1_${ik}$, info ) - lwk2 = int( work( 1 ),KIND=ilp) - ! ==== workspace query call to stdlib_dlaqr4 ==== - call stdlib_dlaqr4( .true., .true., jw, 1, jw, t, ldt, sr, si, 1, jw,v, ldv, work, -& - 1, infqr ) - lwk3 = int( work( 1 ),KIND=ilp) + lwk2 = int( work( 1_${ik}$ ),KIND=${ik}$) + ! ==== workspace query call to stdlib${ii}$_dlaqr4 ==== + call stdlib${ii}$_dlaqr4( .true., .true., jw, 1_${ik}$, jw, t, ldt, sr, si, 1_${ik}$, jw,v, ldv, work, -& + 1_${ik}$, infqr ) + lwk3 = int( work( 1_${ik}$ ),KIND=${ik}$) ! ==== optimal workspace ==== lwkopt = max( jw+max( lwk1, lwk2 ), lwk3 ) end if ! ==== quick return in case of workspace query. ==== - if( lwork==-1 ) then - work( 1 ) = real( lwkopt,KIND=dp) + if( lwork==-1_${ik}$ ) then + work( 1_${ik}$ ) = real( lwkopt,KIND=dp) return end if ! ==== nothing to do ... ! ... for an empty active block ... ==== - ns = 0 - nd = 0 - work( 1 ) = one + ns = 0_${ik}$ + nd = 0_${ik}$ + work( 1_${ik}$ ) = one if( ktop>kbot )return ! ... nor for an empty deflation window. ==== if( nw<1 )return ! ==== machine constants ==== - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) safmax = one / safmin - call stdlib_dlabad( safmin, safmax ) - ulp = stdlib_dlamch( 'PRECISION' ) + call stdlib${ii}$_dlabad( safmin, safmax ) + ulp = stdlib${ii}$_dlamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=dp) / ulp ) ! ==== setup deflation window ==== jw = min( nw, kbot-ktop+1 ) - kwtop = kbot - jw + 1 + kwtop = kbot - jw + 1_${ik}$ if( kwtop==ktop ) then s = zero else @@ -80801,14 +80791,14 @@ module stdlib_linalg_lapack_d ! ==== 1-by-1 deflation window: not much to do ==== sr( kwtop ) = h( kwtop, kwtop ) si( kwtop ) = zero - ns = 1 - nd = 0 + ns = 1_${ik}$ + nd = 0_${ik}$ if( abs( s )<=max( smlnum, ulp*abs( h( kwtop, kwtop ) ) ) )then - ns = 0 - nd = 1 + ns = 0_${ik}$ + nd = 1_${ik}$ if( kwtop>ktop )h( kwtop, kwtop-1 ) = zero end if - work( 1 ) = one + work( 1_${ik}$ ) = one return end if ! ==== convert to spike-triangular form. (in case of a @@ -80816,29 +80806,29 @@ module stdlib_linalg_lapack_d ! . aggressive early deflation using that part of ! . the deflation window that converged using infqr ! . here and there to keep track.) ==== - call stdlib_dlacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) - call stdlib_dcopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 ) - call stdlib_dlaset( 'A', jw, jw, zero, one, v, ldv ) - nmin = stdlib_ilaenv( 12, 'DLAQR3', 'SV', jw, 1, jw, lwork ) + call stdlib${ii}$_dlacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) + call stdlib${ii}$_dcopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2_${ik}$, 1_${ik}$ ), ldt+1 ) + call stdlib${ii}$_dlaset( 'A', jw, jw, zero, one, v, ldv ) + nmin = stdlib${ii}$_ilaenv( 12_${ik}$, 'DLAQR3', 'SV', jw, 1_${ik}$, jw, lwork ) if( jw>nmin ) then - call stdlib_dlaqr4( .true., .true., jw, 1, jw, t, ldt, sr( kwtop ),si( kwtop ), 1, & + call stdlib${ii}$_dlaqr4( .true., .true., jw, 1_${ik}$, jw, t, ldt, sr( kwtop ),si( kwtop ), 1_${ik}$, & jw, v, ldv, work, lwork, infqr ) else - call stdlib_dlahqr( .true., .true., jw, 1, jw, t, ldt, sr( kwtop ),si( kwtop ), 1, & + call stdlib${ii}$_dlahqr( .true., .true., jw, 1_${ik}$, jw, t, ldt, sr( kwtop ),si( kwtop ), 1_${ik}$, & jw, v, ldv, infqr ) end if - ! ==== stdlib_dtrexc needs a clean margin near the diagonal ==== + ! ==== stdlib${ii}$_dtrexc needs a clean margin near the diagonal ==== do j = 1, jw - 3 t( j+2, j ) = zero t( j+3, j ) = zero end do - if( jw>2 )t( jw, jw-2 ) = zero + if( jw>2_${ik}$ )t( jw, jw-2 ) = zero ! ==== deflation detection loop ==== ns = jw - ilst = infqr + 1 + ilst = infqr + 1_${ik}$ 20 continue if( ilst<=ns ) then - if( ns==1 ) then + if( ns==1_${ik}$ ) then bulge = .false. else bulge = t( ns, ns-1 )/=zero @@ -80848,56 +80838,56 @@ module stdlib_linalg_lapack_d ! ==== real eigenvalue ==== foo = abs( t( ns, ns ) ) if( foo==zero )foo = abs( s ) - if( abs( s*v( 1, ns ) )<=max( smlnum, ulp*foo ) ) then + if( abs( s*v( 1_${ik}$, ns ) )<=max( smlnum, ulp*foo ) ) then ! ==== deflatable ==== - ns = ns - 1 + ns = ns - 1_${ik}$ else ! ==== undeflatable. move it up out of the way. - ! . (stdlib_dtrexc can not fail in this case.) ==== + ! . (stdlib${ii}$_dtrexc can not fail in this case.) ==== ifst = ns - call stdlib_dtrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) - ilst = ilst + 1 + call stdlib${ii}$_dtrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) + ilst = ilst + 1_${ik}$ end if else ! ==== complex conjugate pair ==== foo = abs( t( ns, ns ) ) + sqrt( abs( t( ns, ns-1 ) ) )*sqrt( abs( t( ns-1, ns ) & ) ) if( foo==zero )foo = abs( s ) - if( max( abs( s*v( 1, ns ) ), abs( s*v( 1, ns-1 ) ) )<=max( smlnum, ulp*foo ) ) & + if( max( abs( s*v( 1_${ik}$, ns ) ), abs( s*v( 1_${ik}$, ns-1 ) ) )<=max( smlnum, ulp*foo ) ) & then ! ==== deflatable ==== - ns = ns - 2 + ns = ns - 2_${ik}$ else ! ==== undeflatable. move them up out of the way. - ! . fortunately, stdlib_dtrexc does the right thing with + ! . fortunately, stdlib${ii}$_dtrexc does the right thing with ! . ilst in case of a rare exchange failure. ==== ifst = ns - call stdlib_dtrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) - ilst = ilst + 2 + call stdlib${ii}$_dtrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) + ilst = ilst + 2_${ik}$ end if end if ! ==== end deflation detection loop ==== go to 20 end if ! ==== return to hessenberg form ==== - if( ns==0 )s = zero + if( ns==0_${ik}$ )s = zero if( ns1 .and. s/=zero ) then + if( ns>1_${ik}$ .and. s/=zero ) then ! ==== reflect spike back into lower triangle ==== - call stdlib_dcopy( ns, v, ldv, work, 1 ) - beta = work( 1 ) - call stdlib_dlarfg( ns, beta, work( 2 ), 1, tau ) - work( 1 ) = one - call stdlib_dlaset( 'L', jw-2, jw-2, zero, zero, t( 3, 1 ), ldt ) - call stdlib_dlarf( 'L', ns, jw, work, 1, tau, t, ldt,work( jw+1 ) ) - call stdlib_dlarf( 'R', ns, ns, work, 1, tau, t, ldt,work( jw+1 ) ) - call stdlib_dlarf( 'R', jw, ns, work, 1, tau, v, ldv,work( jw+1 ) ) - call stdlib_dgehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) + call stdlib${ii}$_dcopy( ns, v, ldv, work, 1_${ik}$ ) + beta = work( 1_${ik}$ ) + call stdlib${ii}$_dlarfg( ns, beta, work( 2_${ik}$ ), 1_${ik}$, tau ) + work( 1_${ik}$ ) = one + call stdlib${ii}$_dlaset( 'L', jw-2, jw-2, zero, zero, t( 3_${ik}$, 1_${ik}$ ), ldt ) + call stdlib${ii}$_dlarf( 'L', ns, jw, work, 1_${ik}$, tau, t, ldt,work( jw+1 ) ) + call stdlib${ii}$_dlarf( 'R', ns, ns, work, 1_${ik}$, tau, t, ldt,work( jw+1 ) ) + call stdlib${ii}$_dlarf( 'R', jw, ns, work, 1_${ik}$, tau, v, ldv,work( jw+1 ) ) + call stdlib${ii}$_dgehrd( jw, 1_${ik}$, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) end if ! ==== copy updated reduced window into place ==== - if( kwtop>1 )h( kwtop, kwtop-1 ) = s*v( 1, 1 ) - call stdlib_dlacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) - call stdlib_dcopy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) + if( kwtop>1_${ik}$ )h( kwtop, kwtop-1 ) = s*v( 1_${ik}$, 1_${ik}$ ) + call stdlib${ii}$_dlacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) + call stdlib${ii}$_dcopy( jw-1, t( 2_${ik}$, 1_${ik}$ ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) ! ==== accumulate orthogonal matrix in order update ! . h and z, if requested. ==== - if( ns>1 .and. s/=zero )call stdlib_dormhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, & + if( ns>1_${ik}$ .and. s/=zero )call stdlib${ii}$_dormhr( 'R', 'N', jw, ns, 1_${ik}$, ns, t, ldt, work, & v, ldv,work( jw+1 ), lwork-jw, info ) ! ==== update vertical slab in h ==== if( wantt ) then - ltop = 1 + ltop = 1_${ik}$ else ltop = ktop end if do krow = ltop, kwtop - 1, nv kln = min( nv, kwtop-krow ) - call stdlib_dgemm( 'N', 'N', kln, jw, jw, one, h( krow, kwtop ),ldh, v, ldv, & + call stdlib${ii}$_dgemm( 'N', 'N', kln, jw, jw, one, h( krow, kwtop ),ldh, v, ldv, & zero, wv, ldwv ) - call stdlib_dlacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) + call stdlib${ii}$_dlacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) end do ! ==== update horizontal slab in h ==== if( wantt ) then do kcol = kbot + 1, n, nh kln = min( nh, n-kcol+1 ) - call stdlib_dgemm( 'C', 'N', jw, kln, jw, one, v, ldv,h( kwtop, kcol ), ldh, & + call stdlib${ii}$_dgemm( 'C', 'N', jw, kln, jw, one, v, ldv,h( kwtop, kcol ), ldh, & zero, t, ldt ) - call stdlib_dlacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) + call stdlib${ii}$_dlacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) end do end if ! ==== update vertical slab in z ==== if( wantz ) then do krow = iloz, ihiz, nv kln = min( nv, ihiz-krow+1 ) - call stdlib_dgemm( 'N', 'N', kln, jw, jw, one, z( krow, kwtop ),ldz, v, ldv, & + call stdlib${ii}$_dgemm( 'N', 'N', kln, jw, jw, one, z( krow, kwtop ),ldz, v, ldv, & zero, wv, ldwv ) - call stdlib_dlacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) + call stdlib${ii}$_dlacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) end do end if end if @@ -81025,11 +81015,11 @@ module stdlib_linalg_lapack_d ! . window.) ==== ns = ns - infqr ! ==== return optimal workspace. ==== - work( 1 ) = real( lwkopt,KIND=dp) - end subroutine stdlib_dlaqr3 + work( 1_${ik}$ ) = real( lwkopt,KIND=dp) + end subroutine stdlib${ii}$_dlaqr3 - subroutine stdlib_dlaqr4( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, work,& + subroutine stdlib${ii}$_dlaqr4( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, work,& !! DLAQR4 implements one level of recursion for DLAQR0. !! It is a complete implementation of the small bulge multi-shift !! QR algorithm. It may be called by DLAQR0 and, for large enough @@ -81049,21 +81039,21 @@ module stdlib_linalg_lapack_d ! -- 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, ihiz, ilo, iloz, ldh, ldz, lwork, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ihiz, ilo, iloz, ldh, ldz, lwork, n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt, wantz ! Array Arguments real(dp), intent(inout) :: h(ldh,*), z(ldz,*) real(dp), intent(out) :: wi(*), work(*), wr(*) ! ================================================================ ! Parameters - integer(ilp), parameter :: ntiny = 15 - integer(ilp), parameter :: kexnw = 5 - integer(ilp), parameter :: kexsh = 6 + integer(${ik}$), parameter :: ntiny = 15_${ik}$ + integer(${ik}$), parameter :: kexnw = 5_${ik}$ + integer(${ik}$), parameter :: kexsh = 6_${ik}$ real(dp), parameter :: wilk1 = 0.75_dp real(dp), parameter :: wilk2 = -0.4375_dp ! ==== matrices of order ntiny or smaller must be processed by - ! . stdlib_dlahqr because of insufficient subdiagonal scratch space. + ! . stdlib${ii}$_dlahqr because of insufficient subdiagonal scratch space. ! . (this is a hard limit.) ==== ! ==== exceptional deflation windows: try to cure rare @@ -81080,92 +81070,92 @@ module stdlib_linalg_lapack_d ! Local Scalars real(dp) :: aa, bb, cc, cs, dd, sn, ss, swap - integer(ilp) :: i, inf, it, itmax, k, kacc22, kbot, kdu, ks, kt, ktop, ku, kv, kwh, & + integer(${ik}$) :: i, inf, it, itmax, k, kacc22, kbot, kdu, ks, kt, ktop, ku, kv, kwh, & kwtop, kwv, ld, ls, lwkopt, ndec, ndfl, nh, nho, nibble, nmin, ns, nsmax, nsr, nve, nw,& nwmax, nwr, nwupbd logical(lk) :: sorted - character :: jbcmpz*2 + character(len=2_${ik}$) :: jbcmpz ! Local Arrays - real(dp) :: zdum(1,1) + real(dp) :: zdum(1_${ik}$,1_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,int,max,min,mod ! Executable Statements - info = 0 + info = 0_${ik}$ ! ==== quick return for n = 0: nothing to do. ==== - if( n==0 ) then - work( 1 ) = one + if( n==0_${ik}$ ) then + work( 1_${ik}$ ) = one return end if if( n<=ntiny ) then ! ==== tiny matrices must use stdlib_dlahqr. ==== - lwkopt = 1 - if( lwork/=-1 )call stdlib_dlahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, & + lwkopt = 1_${ik}$ + if( lwork/=-1_${ik}$ )call stdlib${ii}$_dlahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, & ihiz, z, ldz, info ) else ! ==== use small bulge multi-shift qr with aggressive early ! . deflation on larger-than-tiny matrices. ==== ! ==== hope for the best. ==== - info = 0 - ! ==== set up job flags for stdlib_ilaenv. ==== + info = 0_${ik}$ + ! ==== set up job flags for stdlib${ii}$_ilaenv. ==== if( wantt ) then - jbcmpz( 1: 1 ) = 'S' + jbcmpz( 1_${ik}$: 1_${ik}$ ) = 'S' else - jbcmpz( 1: 1 ) = 'E' + jbcmpz( 1_${ik}$: 1_${ik}$ ) = 'E' end if if( wantz ) then - jbcmpz( 2: 2 ) = 'V' + jbcmpz( 2_${ik}$: 2_${ik}$ ) = 'V' else - jbcmpz( 2: 2 ) = 'N' + jbcmpz( 2_${ik}$: 2_${ik}$ ) = 'N' end if ! ==== nwr = recommended deflation window size. at this ! . point, n > ntiny = 15, so there is enough ! . subdiagonal workspace for nwr>=2 as required. ! . (in fact, there is enough subdiagonal space for ! . nwr>=4.) ==== - nwr = stdlib_ilaenv( 13, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork ) - nwr = max( 2, nwr ) - nwr = min( ihi-ilo+1, ( n-1 ) / 3, nwr ) + nwr = stdlib${ii}$_ilaenv( 13_${ik}$, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork ) + nwr = max( 2_${ik}$, nwr ) + nwr = min( ihi-ilo+1, ( n-1 ) / 3_${ik}$, nwr ) ! ==== nsr = recommended number of simultaneous shifts. ! . at this point n > ntiny = 15, so there is at ! . enough subdiagonal workspace for nsr to be even ! . and greater than or equal to two as required. ==== - nsr = stdlib_ilaenv( 15, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork ) - nsr = min( nsr, ( n-3 ) / 6, ihi-ilo ) - nsr = max( 2, nsr-mod( nsr, 2 ) ) + nsr = stdlib${ii}$_ilaenv( 15_${ik}$, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork ) + nsr = min( nsr, ( n-3 ) / 6_${ik}$, ihi-ilo ) + nsr = max( 2_${ik}$, nsr-mod( nsr, 2_${ik}$ ) ) ! ==== estimate optimal workspace ==== - ! ==== workspace query call to stdlib_dlaqr2 ==== - call stdlib_dlaqr2( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& - ld, wr, wi, h, ldh, n, h, ldh,n, h, ldh, work, -1 ) - ! ==== optimal workspace = max(stdlib_dlaqr5, stdlib_dlaqr2) ==== - lwkopt = max( 3*nsr / 2, int( work( 1 ),KIND=ilp) ) + ! ==== workspace query call to stdlib${ii}$_dlaqr2 ==== + call stdlib${ii}$_dlaqr2( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& + ld, wr, wi, h, ldh, n, h, ldh,n, h, ldh, work, -1_${ik}$ ) + ! ==== optimal workspace = max(stdlib${ii}$_dlaqr5, stdlib${ii}$_dlaqr2) ==== + lwkopt = max( 3_${ik}$*nsr / 2_${ik}$, int( work( 1_${ik}$ ),KIND=${ik}$) ) ! ==== quick return in case of workspace query. ==== - if( lwork==-1 ) then - work( 1 ) = real( lwkopt,KIND=dp) + if( lwork==-1_${ik}$ ) then + work( 1_${ik}$ ) = real( lwkopt,KIND=dp) return end if - ! ==== stdlib_dlahqr/stdlib_dlaqr0 crossover point ==== - nmin = stdlib_ilaenv( 12, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork ) + ! ==== stdlib${ii}$_dlahqr/stdlib${ii}$_dlaqr0 crossover point ==== + nmin = stdlib${ii}$_ilaenv( 12_${ik}$, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork ) nmin = max( ntiny, nmin ) ! ==== nibble crossover point ==== - nibble = stdlib_ilaenv( 14, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork ) - nibble = max( 0, nibble ) + nibble = stdlib${ii}$_ilaenv( 14_${ik}$, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork ) + nibble = max( 0_${ik}$, nibble ) ! ==== accumulate reflections during ttswp? use block ! . 2-by-2 structure during matrix-matrix multiply? ==== - kacc22 = stdlib_ilaenv( 16, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork ) - kacc22 = max( 0, kacc22 ) - kacc22 = min( 2, kacc22 ) + kacc22 = stdlib${ii}$_ilaenv( 16_${ik}$, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork ) + kacc22 = max( 0_${ik}$, kacc22 ) + kacc22 = min( 2_${ik}$, kacc22 ) ! ==== nwmax = the largest possible deflation window for ! . which there is sufficient workspace. ==== - nwmax = min( ( n-1 ) / 3, lwork / 2 ) + nwmax = min( ( n-1 ) / 3_${ik}$, lwork / 2_${ik}$ ) nw = nwmax ! ==== nsmax = the largest number of simultaneous shifts ! . for which there is sufficient workspace. ==== - nsmax = min( ( n-3 ) / 6, 2*lwork / 3 ) - nsmax = nsmax - mod( nsmax, 2 ) + nsmax = min( ( n-3 ) / 6_${ik}$, 2_${ik}$*lwork / 3_${ik}$ ) + nsmax = nsmax - mod( nsmax, 2_${ik}$ ) ! ==== ndfl: an iteration count restarted at deflation. ==== - ndfl = 1 + ndfl = 1_${ik}$ ! ==== itmax = iteration limit ==== - itmax = max( 30, 2*kexsh )*max( 10, ( ihi-ilo+1 ) ) + itmax = max( 30_${ik}$, 2_${ik}$*kexsh )*max( 10_${ik}$, ( ihi-ilo+1 ) ) ! ==== last row and column in the active block ==== kbot = ihi ! ==== main loop ==== @@ -81193,27 +81183,27 @@ module stdlib_linalg_lapack_d ! . in general, more powerful than smaller ones, ! . rapidly increase the window to the maximum possible. ! . then, gradually reduce the window size. ==== - nh = kbot - ktop + 1 + nh = kbot - ktop + 1_${ik}$ nwupbd = min( nh, nwmax ) if( ndfl=nh-1 ) then nw = nh else - kwtop = kbot - nw + 1 + kwtop = kbot - nw + 1_${ik}$ if( abs( h( kwtop, kwtop-1 ) )>abs( h( kwtop-1, kwtop-2 ) ) )nw = nw + & - 1 + 1_${ik}$ end if end if if( ndfl=0 .or. nw>=nwupbd ) then - ndec = ndec + 1 - if( nw-ndec<2 )ndec = 0 + ndec = -1_${ik}$ + else if( ndec>=0_${ik}$ .or. nw>=nwupbd ) then + ndec = ndec + 1_${ik}$ + if( nw-ndec<2_${ik}$ )ndec = 0_${ik}$ nw = nw - ndec end if ! ==== aggressive early deflation: @@ -81226,46 +81216,46 @@ module stdlib_linalg_lapack_d ! . - an at-least-nw-but-more-is-better (nhv-by-nw) ! . vertical work array along the left-hand-edge. ! . ==== - kv = n - nw + 1 - kt = nw + 1 - nho = ( n-nw-1 ) - kt + 1 - kwv = nw + 2 - nve = ( n-nw ) - kwv + 1 + kv = n - nw + 1_${ik}$ + kt = nw + 1_${ik}$ + nho = ( n-nw-1 ) - kt + 1_${ik}$ + kwv = nw + 2_${ik}$ + nve = ( n-nw ) - kwv + 1_${ik}$ ! ==== aggressive early deflation ==== - call stdlib_dlaqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & - ls, ld, wr, wi, h( kv, 1 ), ldh,nho, h( kv, kt ), ldh, nve, h( kwv, 1 ), ldh,& + call stdlib${ii}$_dlaqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & + ls, ld, wr, wi, h( kv, 1_${ik}$ ), ldh,nho, h( kv, kt ), ldh, nve, h( kwv, 1_${ik}$ ), ldh,& work, lwork ) ! ==== adjust kbot accounting for new deflations. ==== kbot = kbot - ld ! ==== ks points to the shifts. ==== - ks = kbot - ls + 1 + ks = kbot - ls + 1_${ik}$ ! ==== skip an expensive qr sweep if there is a (partly ! . heuristic) reason to expect that many eigenvalues ! . will deflate without it. here, the qr sweep is ! . skipped if many eigenvalues have just been deflated ! . or if the remaining active block is small. - if( ( ld==0 ) .or. ( ( 100*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& + if( ( ld==0_${ik}$ ) .or. ( ( 100_${ik}$*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& ) ) ) then ! ==== ns = nominal number of simultaneous shifts. - ! . this may be lowered (slightly) if stdlib_dlaqr2 + ! . this may be lowered (slightly) if stdlib${ii}$_dlaqr2 ! . did not provide that many shifts. ==== - ns = min( nsmax, nsr, max( 2, kbot-ktop ) ) - ns = ns - mod( ns, 2 ) + ns = min( nsmax, nsr, max( 2_${ik}$, kbot-ktop ) ) + ns = ns - mod( ns, 2_${ik}$ ) ! ==== if there have been no deflations ! . in a multiple of kexsh iterations, ! . then try exceptional shifts. ! . otherwise use shifts provided by - ! . stdlib_dlaqr2 above or from the eigenvalues + ! . stdlib${ii}$_dlaqr2 above or from the eigenvalues ! . of a trailing principal submatrix. ==== - if( mod( ndfl, kexsh )==0 ) then - ks = kbot - ns + 1 + if( mod( ndfl, kexsh )==0_${ik}$ ) then + ks = kbot - ns + 1_${ik}$ do i = kbot, max( ks+1, ktop+2 ), -2 ss = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) ) aa = wilk1*ss + h( i, i ) bb = ss cc = wilk2*ss dd = aa - call stdlib_dlanv2( aa, bb, cc, dd, wr( i-1 ), wi( i-1 ),wr( i ), wi( i & + call stdlib${ii}$_dlanv2( aa, bb, cc, dd, wr( i-1 ), wi( i-1 ),wr( i ), wi( i & ), cs, sn ) end do if( ks==ktop ) then @@ -81280,13 +81270,13 @@ module stdlib_linalg_lapack_d ! . get more. (since ns<=nsmax<=(n-3)/6, ! . there is enough space below the subdiagonal ! . to fit an ns-by-ns scratch array.) ==== - if( kbot-ks+1<=ns / 2 ) then - ks = kbot - ns + 1 - kt = n - ns + 1 - call stdlib_dlacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1 ), ldh ) + if( kbot-ks+1<=ns / 2_${ik}$ ) then + ks = kbot - ns + 1_${ik}$ + kt = n - ns + 1_${ik}$ + call stdlib${ii}$_dlacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1_${ik}$ ), ldh ) - call stdlib_dlahqr( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, wr( ks & - ), wi( ks ),1, 1, zdum, 1, inf ) + call stdlib${ii}$_dlahqr( .false., .false., ns, 1_${ik}$, ns,h( kt, 1_${ik}$ ), ldh, wr( ks & + ), wi( ks ),1_${ik}$, 1_${ik}$, zdum, 1_${ik}$, inf ) ks = ks + inf ! ==== in case of a rare qr failure use ! . eigenvalues of the trailing 2-by-2 @@ -81296,9 +81286,9 @@ module stdlib_linalg_lapack_d cc = h( kbot, kbot-1 ) bb = h( kbot-1, kbot ) dd = h( kbot, kbot ) - call stdlib_dlanv2( aa, bb, cc, dd, wr( kbot-1 ),wi( kbot-1 ), wr( & + call stdlib${ii}$_dlanv2( aa, bb, cc, dd, wr( kbot-1 ),wi( kbot-1 ), wr( & kbot ),wi( kbot ), cs, sn ) - ks = kbot - 1 + ks = kbot - 1_${ik}$ end if end if if( kbot-ks+1>ns ) then @@ -81344,7 +81334,7 @@ module stdlib_linalg_lapack_d end if ! ==== if there are only two shifts and both are ! . real, then use only one. ==== - if( kbot-ks+1==2 ) then + if( kbot-ks+1==2_${ik}$ ) then if( wi( kbot )==zero ) then if( abs( wr( kbot )-h( kbot, kbot ) )0 ) then - ndfl = 1 + if( ld>0_${ik}$ ) then + ndfl = 1_${ik}$ else - ndfl = ndfl + 1 + ndfl = ndfl + 1_${ik}$ end if ! ==== end of main loop ==== end do loop_80 @@ -81396,11 +81386,11 @@ module stdlib_linalg_lapack_d 90 continue end if ! ==== return the optimal value of lwork. ==== - work( 1 ) = real( lwkopt,KIND=dp) - end subroutine stdlib_dlaqr4 + work( 1_${ik}$ ) = real( lwkopt,KIND=dp) + end subroutine stdlib${ii}$_dlaqr4 - recursive subroutine stdlib_dlaqz0( wants, wantq, wantz, n, ilo, ihi, a,lda, b, ldb, alphar, & + recursive subroutine stdlib${ii}$_dlaqz0( wants, wantq, wantz, n, ilo, ihi, a,lda, b, ldb, alphar, & !! DLAQZ0 computes the eigenvalues of a real matrix pair (H,T), !! where H is an upper Hessenberg matrix and T is upper triangular, !! using the double-shift QZ method. @@ -81452,140 +81442,140 @@ module stdlib_linalg_lapack_d alphai, beta,q, ldq, z, ldz, work, lwork, rec,info ) ! arguments character, intent( in ) :: wants, wantq, wantz - integer(ilp), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,rec - integer(ilp), intent( out ) :: info + integer(${ik}$), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,rec + integer(${ik}$), intent( out ) :: info real(dp), intent( inout ) :: a( lda, * ), b( ldb, * ),q( ldq, * ), z( ldz, * ), alphar(& * ),alphai( * ), beta( * ), work( * ) ! local scalars real(dp) :: smlnum, ulp, eshift, safmin, safmax, c1, s1, temp, swap - integer(ilp) :: istart, istop, iiter, maxit, istart2, k, ld, nshifts, nblock, nw, nmin,& + integer(${ik}$) :: istart, istop, iiter, maxit, istart2, k, ld, nshifts, nblock, nw, nmin,& nibble, n_undeflated, n_deflated, ns, sweep_info, shiftpos, lworkreq, k2, istartm, & istopm, iwants, iwantq, iwantz, norm_info, aed_info, nwr, nbr, nsr, itemp1, itemp2, & rcost, i logical(lk) :: ilschur, ilq, ilz - character :: jbcmpz*3 + character(len=3_${ik}$) :: jbcmpz if( stdlib_lsame( wants, 'E' ) ) then ilschur = .false. - iwants = 1 + iwants = 1_${ik}$ else if( stdlib_lsame( wants, 'S' ) ) then ilschur = .true. - iwants = 2 + iwants = 2_${ik}$ else - iwants = 0 + iwants = 0_${ik}$ end if if( stdlib_lsame( wantq, 'N' ) ) then ilq = .false. - iwantq = 1 + iwantq = 1_${ik}$ else if( stdlib_lsame( wantq, 'V' ) ) then ilq = .true. - iwantq = 2 + iwantq = 2_${ik}$ else if( stdlib_lsame( wantq, 'I' ) ) then ilq = .true. - iwantq = 3 + iwantq = 3_${ik}$ else - iwantq = 0 + iwantq = 0_${ik}$ end if if( stdlib_lsame( wantz, 'N' ) ) then ilz = .false. - iwantz = 1 + iwantz = 1_${ik}$ else if( stdlib_lsame( wantz, 'V' ) ) then ilz = .true. - iwantz = 2 + iwantz = 2_${ik}$ else if( stdlib_lsame( wantz, 'I' ) ) then ilz = .true. - iwantz = 3 + iwantz = 3_${ik}$ else - iwantz = 0 + iwantz = 0_${ik}$ end if ! check argument values - info = 0 - if( iwants==0 ) then - info = -1 - else if( iwantq==0 ) then - info = -2 - else if( iwantz==0 ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( ilo<1 ) then - info = -5 + info = 0_${ik}$ + if( iwants==0_${ik}$ ) then + info = -1_${ik}$ + else if( iwantq==0_${ik}$ ) then + info = -2_${ik}$ + else if( iwantz==0_${ik}$ ) then + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( ilo<1_${ik}$ ) then + info = -5_${ik}$ else if( ihi>n .or. ihi= 2 ) then - call stdlib_dhgeqz( wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb,alphar, alphai,& + if( n < nmin .or. rec >= 2_${ik}$ ) then + call stdlib${ii}$_dhgeqz( wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb,alphar, alphai,& beta, q, ldq, z, ldz, work,lwork, info ) return end if ! find out required workspace - ! workspace query to stdlib_dlaqz3 + ! workspace query to stdlib${ii}$_dlaqz3 nw = max( nwr, nmin ) - call stdlib_dlaqz3( ilschur, ilq, ilz, n, ilo, ihi, nw, a, lda, b, ldb,q, ldq, z, ldz, & - n_undeflated, n_deflated, alphar,alphai, beta, work, nw, work, nw, work, -1, rec,& + call stdlib${ii}$_dlaqz3( ilschur, ilq, ilz, n, ilo, ihi, nw, a, lda, b, ldb,q, ldq, z, ldz, & + n_undeflated, n_deflated, alphar,alphai, beta, work, nw, work, nw, work, -1_${ik}$, rec,& aed_info ) - itemp1 = int( work( 1 ),KIND=ilp) - ! workspace query to stdlib_dlaqz4 - call stdlib_dlaqz4( ilschur, ilq, ilz, n, ilo, ihi, nsr, nbr, alphar,alphai, beta, a, & - lda, b, ldb, q, ldq, z, ldz, work,nbr, work, nbr, work, -1, sweep_info ) - itemp2 = int( work( 1 ),KIND=ilp) - lworkreq = max( itemp1+2*nw**2, itemp2+2*nbr**2 ) - if ( lwork ==-1 ) then - work( 1 ) = real( lworkreq,KIND=dp) + itemp1 = int( work( 1_${ik}$ ),KIND=${ik}$) + ! workspace query to stdlib${ii}$_dlaqz4 + call stdlib${ii}$_dlaqz4( ilschur, ilq, ilz, n, ilo, ihi, nsr, nbr, alphar,alphai, beta, a, & + lda, b, ldb, q, ldq, z, ldz, work,nbr, work, nbr, work, -1_${ik}$, sweep_info ) + itemp2 = int( work( 1_${ik}$ ),KIND=${ik}$) + lworkreq = max( itemp1+2*nw**2_${ik}$, itemp2+2*nbr**2_${ik}$ ) + if ( lwork ==-1_${ik}$ ) then + work( 1_${ik}$ ) = real( lworkreq,KIND=dp) return else if ( lwork < lworkreq ) then - info = -19 + info = -19_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'DLAQZ0', info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DLAQZ0', info ) return end if ! initialize q and z - if( iwantq==3 ) call stdlib_dlaset( 'FULL', n, n, zero, one, q, ldq ) - if( iwantz==3 ) call stdlib_dlaset( 'FULL', n, n, zero, one, z, ldz ) + if( iwantq==3_${ik}$ ) call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, q, ldq ) + if( iwantz==3_${ik}$ ) call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, z, ldz ) ! get machine constants - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) safmax = one/safmin - call stdlib_dlabad( safmin, safmax ) - ulp = stdlib_dlamch( 'PRECISION' ) + call stdlib${ii}$_dlabad( safmin, safmax ) + ulp = stdlib${ii}$_dlamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=dp)/ulp ) istart = ilo istop = ihi - maxit = 3*( ihi-ilo+1 ) - ld = 0 + maxit = 3_${ik}$*( ihi-ilo+1 ) + ld = 0_${ik}$ do iiter = 1, maxit if( iiter >= maxit ) then info = istop+1 @@ -81600,13 +81590,13 @@ module stdlib_linalg_lapack_d abs( a( istop-2,istop-2 ) ) ) ) ) then a( istop-1, istop-2 ) = zero istop = istop-2 - ld = 0 + ld = 0_${ik}$ eshift = zero else if ( abs( a( istop, istop-1 ) ) <= max( smlnum,ulp*( abs( a( istop, istop ) )+& abs( a( istop-1,istop-1 ) ) ) ) ) then a( istop, istop-1 ) = zero istop = istop-1 - ld = 0 + ld = 0_${ik}$ eshift = zero end if ! check deflations at the start @@ -81614,13 +81604,13 @@ module stdlib_linalg_lapack_d ) )+abs( a( istart+2,istart+2 ) ) ) ) ) then a( istart+2, istart+1 ) = zero istart = istart+2 - ld = 0 + ld = 0_${ik}$ eshift = zero else if ( abs( a( istart+1, istart ) ) <= max( smlnum,ulp*( abs( a( istart, istart )& )+abs( a( istart+1,istart+1 ) ) ) ) ) then a( istart+1, istart ) = zero istart = istart+1 - ld = 0 + ld = 0_${ik}$ eshift = zero end if if ( istart+1 >= istop ) then @@ -81638,7 +81628,7 @@ module stdlib_linalg_lapack_d end do ! get range to apply rotations to if ( ilschur ) then - istartm = 1 + istartm = 1_${ik}$ istopm = n else istartm = istart2 @@ -81659,41 +81649,41 @@ module stdlib_linalg_lapack_d ! a diagonal element of b is negligable, move it ! to the top and deflate it do k2 = k, istart2+1, -1 - call stdlib_dlartg( b( k2-1, k2 ), b( k2-1, k2-1 ), c1, s1,temp ) + call stdlib${ii}$_dlartg( b( k2-1, k2 ), b( k2-1, k2-1 ), c1, s1,temp ) b( k2-1, k2 ) = temp b( k2-1, k2-1 ) = zero - call stdlib_drot( k2-2-istartm+1, b( istartm, k2 ), 1,b( istartm, k2-1 ), & - 1, c1, s1 ) - call stdlib_drot( min( k2+1, istop )-istartm+1, a( istartm,k2 ), 1, a( & - istartm, k2-1 ), 1, c1, s1 ) + call stdlib${ii}$_drot( k2-2-istartm+1, b( istartm, k2 ), 1_${ik}$,b( istartm, k2-1 ), & + 1_${ik}$, c1, s1 ) + call stdlib${ii}$_drot( min( k2+1, istop )-istartm+1, a( istartm,k2 ), 1_${ik}$, a( & + istartm, k2-1 ), 1_${ik}$, c1, s1 ) if ( ilz ) then - call stdlib_drot( n, z( 1, k2 ), 1, z( 1, k2-1 ), 1, c1,s1 ) + call stdlib${ii}$_drot( n, z( 1_${ik}$, k2 ), 1_${ik}$, z( 1_${ik}$, k2-1 ), 1_${ik}$, c1,s1 ) end if if( k2= istop ) then istop = istart2-1 - ld = 0 + ld = 0_${ik}$ eshift = zero cycle end if @@ -81715,7 +81705,7 @@ module stdlib_linalg_lapack_d if ( istop-istart2+1 < nmin ) then ! setting nw to the size of the subblock will make aed deflate ! all the eigenvalues. this is slightly more efficient than just - ! using stdlib_dhgeqz because the off diagonal part gets updated via blas. + ! using stdlib${ii}$_dhgeqz because the off diagonal part gets updated via blas. if ( istop-istart+1 < nmin ) then nw = istop-istart+1 istart2 = istart @@ -81724,15 +81714,15 @@ module stdlib_linalg_lapack_d end if end if ! time for aed - call stdlib_dlaqz3( ilschur, ilq, ilz, n, istart2, istop, nw, a, lda,b, ldb, q, ldq,& - z, ldz, n_undeflated, n_deflated,alphar, alphai, beta, work, nw, work( nw**2+1 ),& - nw, work( 2*nw**2+1 ), lwork-2*nw**2, rec,aed_info ) - if ( n_deflated > 0 ) then + call stdlib${ii}$_dlaqz3( ilschur, ilq, ilz, n, istart2, istop, nw, a, lda,b, ldb, q, ldq,& + z, ldz, n_undeflated, n_deflated,alphar, alphai, beta, work, nw, work( nw**2_${ik}$+1 ),& + nw, work( 2_${ik}$*nw**2_${ik}$+1 ), lwork-2*nw**2_${ik}$, rec,aed_info ) + if ( n_deflated > 0_${ik}$ ) then istop = istop-n_deflated - ld = 0 + ld = 0_${ik}$ eshift = zero end if - if ( 100*n_deflated > nibble*( n_deflated+n_undeflated ) .or.istop-istart2+1 < nmin & + if ( 100_${ik}$*n_deflated > nibble*( n_deflated+n_undeflated ) .or.istop-istart2+1 < nmin & ) then ! aed has uncovered many eigenvalues. skip a qz sweep and run ! aed again. @@ -81760,7 +81750,7 @@ module stdlib_linalg_lapack_d beta( i+2 ) = swap end if end do - if ( mod( ld, 6 ) == 0 ) then + if ( mod( ld, 6_${ik}$ ) == 0_${ik}$ ) then ! exceptional shift. chosen for no particularly good reason. if( ( real( maxit,KIND=dp)*safmin )*abs( a( istop,istop-1 ) ) ilo ) then a( kwtop, kwtop-1 ) = zero end if end if end if ! store window in case of convergence failure - call stdlib_dlacpy( 'ALL', jw, jw, a( kwtop, kwtop ), lda, work, jw ) - call stdlib_dlacpy( 'ALL', jw, jw, b( kwtop, kwtop ), ldb, work( jw**2+1 ), jw ) + call stdlib${ii}$_dlacpy( 'ALL', jw, jw, a( kwtop, kwtop ), lda, work, jw ) + call stdlib${ii}$_dlacpy( 'ALL', jw, jw, b( kwtop, kwtop ), ldb, work( jw**2_${ik}$+1 ), jw ) ! transform window to real schur form - call stdlib_dlaset( 'FULL', jw, jw, zero, one, qc, ldqc ) - call stdlib_dlaset( 'FULL', jw, jw, zero, one, zc, ldzc ) - call stdlib_dlaqz0( 'S', 'V', 'V', jw, 1, jw, a( kwtop, kwtop ), lda,b( kwtop, kwtop ),& - ldb, alphar, alphai, beta, qc,ldqc, zc, ldzc, work( 2*jw**2+1 ), lwork-2*jw**2,rec+1, & + call stdlib${ii}$_dlaset( 'FULL', jw, jw, zero, one, qc, ldqc ) + call stdlib${ii}$_dlaset( 'FULL', jw, jw, zero, one, zc, ldzc ) + call stdlib${ii}$_dlaqz0( 'S', 'V', 'V', jw, 1_${ik}$, jw, a( kwtop, kwtop ), lda,b( kwtop, kwtop ),& + ldb, alphar, alphai, beta, qc,ldqc, zc, ldzc, work( 2_${ik}$*jw**2_${ik}$+1 ), lwork-2*jw**2_${ik}$,rec+1, & qz_small_info ) - if( qz_small_info /= 0 ) then + if( qz_small_info /= 0_${ik}$ ) then ! convergence failure, restore the window and exit - nd = 0 + nd = 0_${ik}$ ns = jw-qz_small_info - call stdlib_dlacpy( 'ALL', jw, jw, work, jw, a( kwtop, kwtop ), lda ) - call stdlib_dlacpy( 'ALL', jw, jw, work( jw**2+1 ), jw, b( kwtop,kwtop ), ldb ) + call stdlib${ii}$_dlacpy( 'ALL', jw, jw, work, jw, a( kwtop, kwtop ), lda ) + call stdlib${ii}$_dlacpy( 'ALL', jw, jw, work( jw**2_${ik}$+1 ), jw, b( kwtop,kwtop ), ldb ) return end if @@ -81885,11 +81875,11 @@ module stdlib_linalg_lapack_d kwbot = kwtop-1 else kwbot = ihi - k = 1 - k2 = 1 + k = 1_${ik}$ + k2 = 1_${ik}$ do while ( k <= jw ) bulge = .false. - if ( kwbot-kwtop+1 >= 2 ) then + if ( kwbot-kwtop+1 >= 2_${ik}$ ) then bulge = a( kwbot, kwbot-1 ) /= zero end if if ( bulge ) then @@ -81899,7 +81889,7 @@ module stdlib_linalg_lapack_d if( temp == zero )then temp = abs( s ) end if - if ( max( abs( s*qc( 1, kwbot-kwtop ) ), abs( s*qc( 1,kwbot-kwtop+1 ) ) ) <= & + if ( max( abs( s*qc( 1_${ik}$, kwbot-kwtop ) ), abs( s*qc( 1_${ik}$,kwbot-kwtop+1 ) ) ) <= & max( smlnum,ulp*temp ) ) then ! deflatable kwbot = kwbot-2 @@ -81907,7 +81897,7 @@ module stdlib_linalg_lapack_d ! not deflatable, move out of the way ifst = kwbot-kwtop+1 ilst = k2 - call stdlib_dtgexc( .true., .true., jw, a( kwtop, kwtop ),lda, b( kwtop, & + call stdlib${ii}$_dtgexc( .true., .true., jw, a( kwtop, kwtop ),lda, b( kwtop, & kwtop ), ldb, qc, ldqc,zc, ldzc, ifst, ilst, work, lwork,dtgexc_info ) k2 = k2+2 @@ -81919,7 +81909,7 @@ module stdlib_linalg_lapack_d if( temp == zero ) then temp = abs( s ) end if - if ( ( abs( s*qc( 1, kwbot-kwtop+1 ) ) ) <= max( ulp*temp, smlnum ) ) & + if ( ( abs( s*qc( 1_${ik}$, kwbot-kwtop+1 ) ) ) <= max( ulp*temp, smlnum ) ) & then ! deflatable kwbot = kwbot-1 @@ -81927,7 +81917,7 @@ module stdlib_linalg_lapack_d ! not deflatable, move out of the way ifst = kwbot-kwtop+1 ilst = k2 - call stdlib_dtgexc( .true., .true., jw, a( kwtop, kwtop ),lda, b( kwtop, & + call stdlib${ii}$_dtgexc( .true., .true., jw, a( kwtop, kwtop ),lda, b( kwtop, & kwtop ), ldb, qc, ldqc,zc, ldzc, ifst, ilst, work, lwork,dtgexc_info ) k2 = k2+1 @@ -81949,7 +81939,7 @@ module stdlib_linalg_lapack_d end if if ( bulge ) then ! 2x2 eigenvalue block - call stdlib_dlag2( a( k, k ), lda, b( k, k ), ldb, safmin,beta( k ), beta( k+1 ),& + call stdlib${ii}$_dlag2( a( k, k ), lda, b( k, k ), ldb, safmin,beta( k ), beta( k+1 ),& alphar( k ),alphar( k+1 ), alphai( k ) ) alphai( k+1 ) = -alphai( k ) k = k+2 @@ -81963,16 +81953,16 @@ module stdlib_linalg_lapack_d end do if ( kwtop /= ilo .and. s /= zero ) then ! reflect spike back, this will create optimally packed bulges - a( kwtop:kwbot, kwtop-1 ) = a( kwtop, kwtop-1 )*qc( 1,1:jw-nd ) + a( kwtop:kwbot, kwtop-1 ) = a( kwtop, kwtop-1 )*qc( 1_${ik}$,1_${ik}$:jw-nd ) do k = kwbot-1, kwtop, -1 - call stdlib_dlartg( a( k, kwtop-1 ), a( k+1, kwtop-1 ), c1, s1,temp ) + call stdlib${ii}$_dlartg( a( k, kwtop-1 ), a( k+1, kwtop-1 ), c1, s1,temp ) a( k, kwtop-1 ) = temp a( k+1, kwtop-1 ) = zero k2 = max( kwtop, k-1 ) - call stdlib_drot( ihi-k2+1, a( k, k2 ), lda, a( k+1, k2 ), lda, c1,s1 ) - call stdlib_drot( ihi-( k-1 )+1, b( k, k-1 ), ldb, b( k+1, k-1 ),ldb, c1, s1 ) + call stdlib${ii}$_drot( ihi-k2+1, a( k, k2 ), lda, a( k+1, k2 ), lda, c1,s1 ) + call stdlib${ii}$_drot( ihi-( k-1 )+1_${ik}$, b( k, k-1 ), ldb, b( k+1, k-1 ),ldb, c1, s1 ) - call stdlib_drot( jw, qc( 1, k-kwtop+1 ), 1, qc( 1, k+1-kwtop+1 ),1, c1, s1 ) + call stdlib${ii}$_drot( jw, qc( 1_${ik}$, k-kwtop+1 ), 1_${ik}$, qc( 1_${ik}$, k+1-kwtop+1 ),1_${ik}$, c1, s1 ) end do ! chase bulges down @@ -81983,7 +81973,7 @@ module stdlib_linalg_lapack_d if ( ( k >= kwtop+1 ) .and. a( k+1, k-1 ) /= zero ) then ! move double pole block down and remove it do k2 = k-1, kwbot-2 - call stdlib_dlaqz2( .true., .true., k2, kwtop, kwtop+jw-1,kwbot, a, lda, b,& + call stdlib${ii}$_dlaqz2( .true., .true., k2, kwtop, kwtop+jw-1,kwbot, a, lda, b,& ldb, jw, kwtop, qc,ldqc, jw, kwtop, zc, ldzc ) end do k = k-2 @@ -81991,35 +81981,35 @@ module stdlib_linalg_lapack_d ! k points to single shift do k2 = k, kwbot-2 ! move shift down - call stdlib_dlartg( b( k2+1, k2+1 ), b( k2+1, k2 ), c1, s1,temp ) + call stdlib${ii}$_dlartg( b( k2+1, k2+1 ), b( k2+1, k2 ), c1, s1,temp ) b( k2+1, k2+1 ) = temp b( k2+1, k2 ) = zero - call stdlib_drot( k2+2-istartm+1, a( istartm, k2+1 ), 1,a( istartm, k2 ), & - 1, c1, s1 ) - call stdlib_drot( k2-istartm+1, b( istartm, k2+1 ), 1,b( istartm, k2 ), 1, & + call stdlib${ii}$_drot( k2+2-istartm+1, a( istartm, k2+1 ), 1_${ik}$,a( istartm, k2 ), & + 1_${ik}$, c1, s1 ) + call stdlib${ii}$_drot( k2-istartm+1, b( istartm, k2+1 ), 1_${ik}$,b( istartm, k2 ), 1_${ik}$, & c1, s1 ) - call stdlib_drot( jw, zc( 1, k2+1-kwtop+1 ), 1, zc( 1,k2-kwtop+1 ), 1, c1, & + call stdlib${ii}$_drot( jw, zc( 1_${ik}$, k2+1-kwtop+1 ), 1_${ik}$, zc( 1_${ik}$,k2-kwtop+1 ), 1_${ik}$, c1, & s1 ) - call stdlib_dlartg( a( k2+1, k2 ), a( k2+2, k2 ), c1, s1,temp ) + call stdlib${ii}$_dlartg( a( k2+1, k2 ), a( k2+2, k2 ), c1, s1,temp ) a( k2+1, k2 ) = temp a( k2+2, k2 ) = zero - call stdlib_drot( istopm-k2, a( k2+1, k2+1 ), lda, a( k2+2,k2+1 ), lda, c1,& + call stdlib${ii}$_drot( istopm-k2, a( k2+1, k2+1 ), lda, a( k2+2,k2+1 ), lda, c1,& s1 ) - call stdlib_drot( istopm-k2, b( k2+1, k2+1 ), ldb, b( k2+2,k2+1 ), ldb, c1,& + call stdlib${ii}$_drot( istopm-k2, b( k2+1, k2+1 ), ldb, b( k2+2,k2+1 ), ldb, c1,& s1 ) - call stdlib_drot( jw, qc( 1, k2+1-kwtop+1 ), 1, qc( 1,k2+2-kwtop+1 ), 1, & + call stdlib${ii}$_drot( jw, qc( 1_${ik}$, k2+1-kwtop+1 ), 1_${ik}$, qc( 1_${ik}$,k2+2-kwtop+1 ), 1_${ik}$, & c1, s1 ) end do ! remove the shift - call stdlib_dlartg( b( kwbot, kwbot ), b( kwbot, kwbot-1 ), c1,s1, temp ) + call stdlib${ii}$_dlartg( b( kwbot, kwbot ), b( kwbot, kwbot-1 ), c1,s1, temp ) b( kwbot, kwbot ) = temp b( kwbot, kwbot-1 ) = zero - call stdlib_drot( kwbot-istartm, b( istartm, kwbot ), 1,b( istartm, kwbot-1 ),& - 1, c1, s1 ) - call stdlib_drot( kwbot-istartm+1, a( istartm, kwbot ), 1,a( istartm, kwbot-1 & - ), 1, c1, s1 ) - call stdlib_drot( jw, zc( 1, kwbot-kwtop+1 ), 1, zc( 1,kwbot-1-kwtop+1 ), 1, & + call stdlib${ii}$_drot( kwbot-istartm, b( istartm, kwbot ), 1_${ik}$,b( istartm, kwbot-1 ),& + 1_${ik}$, c1, s1 ) + call stdlib${ii}$_drot( kwbot-istartm+1, a( istartm, kwbot ), 1_${ik}$,a( istartm, kwbot-1 & + ), 1_${ik}$, c1, s1 ) + call stdlib${ii}$_drot( jw, zc( 1_${ik}$, kwbot-kwtop+1 ), 1_${ik}$, zc( 1_${ik}$,kwbot-1-kwtop+1 ), 1_${ik}$, & c1, s1 ) k = k-1 end if @@ -82027,44 +82017,44 @@ module stdlib_linalg_lapack_d end if ! apply qc and zc to rest of the matrix if ( ilschur ) then - istartm = 1 + istartm = 1_${ik}$ istopm = n else istartm = ilo istopm = ihi end if - if ( istopm-ihi > 0 ) then - call stdlib_dgemm( 'T', 'N', jw, istopm-ihi, jw, one, qc, ldqc,a( kwtop, ihi+1 ), & + if ( istopm-ihi > 0_${ik}$ ) then + call stdlib${ii}$_dgemm( 'T', 'N', jw, istopm-ihi, jw, one, qc, ldqc,a( kwtop, ihi+1 ), & lda, zero, work, jw ) - call stdlib_dlacpy( 'ALL', jw, istopm-ihi, work, jw, a( kwtop,ihi+1 ), lda ) - call stdlib_dgemm( 'T', 'N', jw, istopm-ihi, jw, one, qc, ldqc,b( kwtop, ihi+1 ), & + call stdlib${ii}$_dlacpy( 'ALL', jw, istopm-ihi, work, jw, a( kwtop,ihi+1 ), lda ) + call stdlib${ii}$_dgemm( 'T', 'N', jw, istopm-ihi, jw, one, qc, ldqc,b( kwtop, ihi+1 ), & ldb, zero, work, jw ) - call stdlib_dlacpy( 'ALL', jw, istopm-ihi, work, jw, b( kwtop,ihi+1 ), ldb ) + call stdlib${ii}$_dlacpy( 'ALL', jw, istopm-ihi, work, jw, b( kwtop,ihi+1 ), ldb ) end if if ( ilq ) then - call stdlib_dgemm( 'N', 'N', n, jw, jw, one, q( 1, kwtop ), ldq, qc,ldqc, zero, & + call stdlib${ii}$_dgemm( 'N', 'N', n, jw, jw, one, q( 1_${ik}$, kwtop ), ldq, qc,ldqc, zero, & work, n ) - call stdlib_dlacpy( 'ALL', n, jw, work, n, q( 1, kwtop ), ldq ) + call stdlib${ii}$_dlacpy( 'ALL', n, jw, work, n, q( 1_${ik}$, kwtop ), ldq ) end if - if ( kwtop-1-istartm+1 > 0 ) then - call stdlib_dgemm( 'N', 'N', kwtop-istartm, jw, jw, one, a( istartm,kwtop ), lda, & + if ( kwtop-1-istartm+1 > 0_${ik}$ ) then + call stdlib${ii}$_dgemm( 'N', 'N', kwtop-istartm, jw, jw, one, a( istartm,kwtop ), lda, & zc, ldzc, zero, work,kwtop-istartm ) - call stdlib_dlacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,a( istartm, kwtop & + call stdlib${ii}$_dlacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,a( istartm, kwtop & ), lda ) - call stdlib_dgemm( 'N', 'N', kwtop-istartm, jw, jw, one, b( istartm,kwtop ), ldb, & + call stdlib${ii}$_dgemm( 'N', 'N', kwtop-istartm, jw, jw, one, b( istartm,kwtop ), ldb, & zc, ldzc, zero, work,kwtop-istartm ) - call stdlib_dlacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,b( istartm, kwtop & + call stdlib${ii}$_dlacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,b( istartm, kwtop & ), ldb ) end if if ( ilz ) then - call stdlib_dgemm( 'N', 'N', n, jw, jw, one, z( 1, kwtop ), ldz, zc,ldzc, zero, & + call stdlib${ii}$_dgemm( 'N', 'N', n, jw, jw, one, z( 1_${ik}$, kwtop ), ldz, zc,ldzc, zero, & work, n ) - call stdlib_dlacpy( 'ALL', n, jw, work, n, z( 1, kwtop ), ldz ) + call stdlib${ii}$_dlacpy( 'ALL', n, jw, work, n, z( 1_${ik}$, kwtop ), ldz ) end if - end subroutine stdlib_dlaqz3 + end subroutine stdlib${ii}$_dlaqz3 - pure subroutine stdlib_dlarre( range, n, vl, vu, il, iu, d, e, e2,rtol1, rtol2, spltol, & + pure subroutine stdlib${ii}$_dlarre( range, n, vl, vu, il, iu, d, e, e2,rtol1, rtol2, spltol, & !! To find the desired eigenvalues of a given real symmetric !! tridiagonal matrix T, DLARRE: sets any "small" off-diagonal !! elements to zero, and for each unreduced block T_i, it finds @@ -82084,13 +82074,13 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: range - integer(ilp), intent(in) :: il, iu, n - integer(ilp), intent(out) :: info, m, nsplit + integer(${ik}$), intent(in) :: il, iu, n + integer(${ik}$), intent(out) :: info, m, nsplit real(dp), intent(out) :: pivmin real(dp), intent(in) :: rtol1, rtol2, spltol real(dp), intent(inout) :: vl, vu ! Array Arguments - integer(ilp), intent(out) :: iblock(*), isplit(*), iwork(*), indexw(*) + integer(${ik}$), intent(out) :: iblock(*), isplit(*), iwork(*), indexw(*) real(dp), intent(inout) :: d(*), e(*), e2(*) real(dp), intent(out) :: gers(*), w(*), werr(*), wgap(*), work(*) ! ===================================================================== @@ -82101,26 +82091,26 @@ module stdlib_linalg_lapack_d real(dp), parameter :: fac = half real(dp), parameter :: maxgrowth = 64.0_dp real(dp), parameter :: fudge = 2.0_dp - integer(ilp), parameter :: maxtry = 6 - integer(ilp), parameter :: allrng = 1 - integer(ilp), parameter :: indrng = 2 - integer(ilp), parameter :: valrng = 3 + integer(${ik}$), parameter :: maxtry = 6_${ik}$ + integer(${ik}$), parameter :: allrng = 1_${ik}$ + integer(${ik}$), parameter :: indrng = 2_${ik}$ + integer(${ik}$), parameter :: valrng = 3_${ik}$ ! Local Scalars logical(lk) :: forceb, norep, usedqd - integer(ilp) :: cnt, cnt1, cnt2, i, ibegin, idum, iend, iinfo, in, indl, indu, irange, & + integer(${ik}$) :: cnt, cnt1, cnt2, i, ibegin, idum, iend, iinfo, in, indl, indu, irange, & j, jblk, mb, mm, wbegin, wend real(dp) :: avgap, bsrtol, clwdth, dmax, dpivot, eabs, emax, eold, eps, gl, gu, isleft,& isrght, rtl, rtol, s1, s2, safmin, sgndef, sigma, spdiam, tau, tmp, tmp1 ! Local Arrays - integer(ilp) :: iseed(4) + integer(${ik}$) :: iseed(4_${ik}$) ! 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 ! decode range @@ -82131,36 +82121,36 @@ module stdlib_linalg_lapack_d else if( stdlib_lsame( range, 'I' ) ) then irange = indrng end if - m = 0 + m = 0_${ik}$ ! get machine constants - safmin = stdlib_dlamch( 'S' ) - eps = stdlib_dlamch( 'P' ) + safmin = stdlib${ii}$_dlamch( 'S' ) + eps = stdlib${ii}$_dlamch( 'P' ) ! set parameters rtl = sqrt(eps) bsrtol = sqrt(eps) ! 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 - wgap(1) = zero - iblock( 1 ) = 1 - indexw( 1 ) = 1 - gers(1) = d( 1 ) - gers(2) = d( 1 ) + werr(1_${ik}$) = zero + wgap(1_${ik}$) = zero + iblock( 1_${ik}$ ) = 1_${ik}$ + indexw( 1_${ik}$ ) = 1_${ik}$ + gers(1_${ik}$) = d( 1_${ik}$ ) + gers(2_${ik}$) = d( 1_${ik}$ ) endif ! store the shift for the initial rrr, which is zero in this case - e(1) = zero + e(1_${ik}$) = zero return end if ! general case: tridiagonal matrix of order > 1 ! init werr, wgap. compute gerschgorin intervals and spectral diameter. ! compute maximum off-diagonal entry and pivmin. - gl = d(1) - gu = d(1) + gl = d(1_${ik}$) + gu = d(1_${ik}$) eold = zero emax = zero e(n) = zero @@ -82172,19 +82162,19 @@ module stdlib_linalg_lapack_d emax = eabs end if tmp1 = eabs + eold - gers( 2*i-1) = d(i) - tmp1 - gl = min( gl, gers( 2*i - 1)) - gers( 2*i ) = d(i) + tmp1 - gu = max( gu, gers(2*i) ) + gers( 2_${ik}$*i-1) = d(i) - tmp1 + gl = min( gl, gers( 2_${ik}$*i - 1_${ik}$)) + gers( 2_${ik}$*i ) = d(i) + tmp1 + gu = max( gu, gers(2_${ik}$*i) ) eold = eabs end do ! the minimum pivot allowed in the sturm sequence for t - pivmin = safmin * max( one, emax**2 ) + pivmin = safmin * max( one, emax**2_${ik}$ ) ! compute spectral diameter. the gerschgorin bounds give an ! estimate that is wrong by at most a factor of sqrt(2) spdiam = gu - gl ! compute splitting points - call stdlib_dlarra( n, d, e, e2, spltol, spdiam,nsplit, isplit, iinfo ) + call stdlib${ii}$_dlarra( n, d, e, e2, spltol, spdiam,nsplit, isplit, iinfo ) ! can force use of bisection instead of faster dqds. ! option left in the code for future multisection work. forceb = .false. @@ -82196,50 +82186,50 @@ module stdlib_linalg_lapack_d vl = gl vu = gu else - ! we call stdlib_dlarrd to find crude approximations to the eigenvalues + ! we call stdlib${ii}$_dlarrd to find crude approximations to the eigenvalues ! in the desired range. in case irange = indrng, we also obtain the ! interval (vl,vu] that contains all the wanted eigenvalues. ! an interval [left,right] has converged if ! right-leftvl ).and.( d( & ibegin )<=vu ) ).or. ( (irange==indrng).and.(iblock(wbegin)==jblk))) 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 wgap(m) = zero iblock( m ) = jblk - indexw( m ) = 1 - wbegin = wbegin + 1 + indexw( m ) = 1_${ik}$ + wbegin = wbegin + 1_${ik}$ endif ! e( iend ) holds the shift for the initial rrr e( iend ) = zero - ibegin = iend + 1 + ibegin = iend + 1_${ik}$ cycle loop_170 end if ! blocks of size larger than 1x1 @@ -82249,13 +82239,13 @@ module stdlib_linalg_lapack_d gl = d(ibegin) gu = d(ibegin) do i = ibegin , 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 if(.not. ((irange==allrng).and.(.not.forceb)) ) then ! count the number of eigenvalues in the current block. - mb = 0 + mb = 0_${ik}$ do i = wbegin,mm if( iblock(i)==jblk ) then mb = mb+1 @@ -82264,16 +82254,16 @@ module stdlib_linalg_lapack_d endif end do 21 continue - if( mb==0) then + if( mb==0_${ik}$) then ! no eigenvalue in the current block lies in the desired range ! e( iend ) holds the shift for the initial rrr e( iend ) = zero - ibegin = iend + 1 + ibegin = iend + 1_${ik}$ cycle loop_170 else ! decide whether dqds or bisection is more efficient usedqd = ( (mb > fac*in) .and. (.not.forceb) ) - wend = wbegin + mb - 1 + wend = wbegin + mb - 1_${ik}$ ! calculate gaps for the current block ! in later stages, when representations for individual ! eigenvalues are different, we use sigma = e( iend ). @@ -82290,17 +82280,17 @@ module stdlib_linalg_lapack_d if(( (irange==allrng) .and. (.not. forceb) ).or.usedqd) then ! case of dqds ! find approximations to the extremal eigenvalues of the block - call stdlib_dlarrk( in, 1, gl, gu, d(ibegin),e2(ibegin), pivmin, rtl, tmp, tmp1, & + call stdlib${ii}$_dlarrk( in, 1_${ik}$, gl, gu, d(ibegin),e2(ibegin), pivmin, rtl, tmp, tmp1, & iinfo ) - if( iinfo/=0 ) then - info = -1 + if( iinfo/=0_${ik}$ ) then + info = -1_${ik}$ return endif isleft = max(gl, tmp - tmp1- hndrd * eps* abs(tmp - tmp1)) - call stdlib_dlarrk( in, in, gl, gu, d(ibegin),e2(ibegin), pivmin, rtl, tmp, tmp1,& + call stdlib${ii}$_dlarrk( in, in, gl, gu, d(ibegin),e2(ibegin), pivmin, rtl, tmp, tmp1,& iinfo ) - if( iinfo/=0 ) then - info = -1 + if( iinfo/=0_${ik}$ ) then + info = -1_${ik}$ return endif isrght = min(gu, tmp + tmp1+ hndrd * eps * abs(tmp + tmp1)) @@ -82325,16 +82315,16 @@ module stdlib_linalg_lapack_d ! if all the eigenvalues have to be computed, we use dqd usedqd = .true. ! indl is the local index of the first eigenvalue to compute - indl = 1 + indl = 1_${ik}$ indu = in ! mb = number of eigenvalues to compute mb = in - wend = wbegin + mb - 1 + wend = wbegin + mb - 1_${ik}$ ! define 1/4 and 3/4 points of the spectrum s1 = isleft + fourth * spdiam s2 = isrght - fourth * spdiam else - ! stdlib_dlarrd has computed iblock and indexw for each eigenvalue + ! stdlib${ii}$_dlarrd has computed iblock and indexw for each eigenvalue ! approximation. ! choose sigma if( usedqd ) then @@ -82347,11 +82337,11 @@ module stdlib_linalg_lapack_d endif endif ! compute the negcount at the 1/4 and 3/4 points - if(mb>1) then - call stdlib_dlarrc( 'T', in, s1, s2, d(ibegin),e(ibegin), pivmin, cnt, cnt1, & + if(mb>1_${ik}$) then + call stdlib${ii}$_dlarrc( 'T', in, s1, s2, d(ibegin),e(ibegin), pivmin, cnt, cnt1, & cnt2, iinfo) endif - if(mb==1) then + if(mb==1_${ik}$) then sigma = gl sgndef = one elseif( cnt1 - indl >= indu - cnt2 ) then @@ -82392,7 +82382,7 @@ module stdlib_linalg_lapack_d tau = spdiam*eps*n + two*pivmin tau = max( tau,two*eps*abs(sigma) ) else - if(mb>1) then + if(mb>1_${ik}$) then clwdth = w(wend) + werr(wend) - w(wbegin) - werr(wbegin) avgap = abs(clwdth / real(wend-wbegin,KIND=dp)) if( sgndef==one ) then @@ -82411,17 +82401,17 @@ module stdlib_linalg_lapack_d ! store d in work(1:in), l in work(in+1:2*in), and reciprocals of ! pivots in work(2*in+1:3*in) dpivot = d( ibegin ) - sigma - work( 1 ) = dpivot - dmax = abs( work(1) ) + work( 1_${ik}$ ) = dpivot + dmax = abs( work(1_${ik}$) ) j = ibegin do i = 1, in - 1 - work( 2*in+i ) = one / work( i ) - tmp = e( j )*work( 2*in+i ) + work( 2_${ik}$*in+i ) = one / work( i ) + tmp = e( j )*work( 2_${ik}$*in+i ) work( in+i ) = tmp dpivot = ( d( j+1 )-sigma ) - tmp*e( j ) work( i+1 ) = dpivot dmax = max( dmax, abs(dpivot) ) - j = j + 1 + j = j + 1_${ik}$ end do ! check for element growth if( dmax > maxgrowth*spdiam ) then @@ -82459,7 +82449,7 @@ module stdlib_linalg_lapack_d end do loop_80 ! if the program reaches this point, no base representation could be ! found in maxtry iterations. - info = 2 + info = 2_${ik}$ return 83 continue ! at this point, we have found an initial base representation @@ -82467,16 +82457,16 @@ module stdlib_linalg_lapack_d ! store the shift. e( iend ) = sigma ! store d and l. - call stdlib_dcopy( in, work, 1, d( ibegin ), 1 ) - call stdlib_dcopy( in-1, work( in+1 ), 1, e( ibegin ), 1 ) - if(mb>1 ) then + call stdlib${ii}$_dcopy( in, work, 1_${ik}$, d( ibegin ), 1_${ik}$ ) + call stdlib${ii}$_dcopy( in-1, work( in+1 ), 1_${ik}$, e( ibegin ), 1_${ik}$ ) + if(mb>1_${ik}$ ) then ! perturb each entry of the base representation by a small ! (but random) relative amount to overcome difficulties with ! glued matrices. do i = 1, 4 - iseed( i ) = 1 + iseed( i ) = 1_${ik}$ end do - call stdlib_dlarnv(2, iseed, 2*in-1, work(1)) + call stdlib${ii}$_dlarnv(2_${ik}$, iseed, 2_${ik}$*in-1, work(1_${ik}$)) do i = 1,in-1 d(ibegin+i-1) = d(ibegin+i-1)*(one+eps*pert*work(i)) e(ibegin+i-1) = e(ibegin+i-1)*(one+eps*pert*work(in+i)) @@ -82484,38 +82474,38 @@ module stdlib_linalg_lapack_d d(iend) = d(iend)*(one+eps*four*work(in)) endif ! don't update the gerschgorin intervals because keeping track - ! of the updates would be too much work in stdlib_dlarrv. + ! of the updates would be too much work in stdlib${ii}$_dlarrv. ! we update w instead and use it to locate the proper gerschgorin ! intervals. ! compute the required eigenvalues of l d l' by bisection or dqds if ( .not.usedqd ) then - ! if stdlib_dlarrd has been used, shift the eigenvalue approximations + ! if stdlib${ii}$_dlarrd has been used, shift the eigenvalue approximations ! according to their representation. this is necessary for - ! a uniform stdlib_dlarrv since dqds computes eigenvalues of the - ! shifted representation. in stdlib_dlarrv, w will always hold the + ! a uniform stdlib${ii}$_dlarrv since dqds computes eigenvalues of the + ! shifted representation. in stdlib${ii}$_dlarrv, w will always hold the ! unshifted eigenvalue approximation. do j=wbegin,wend w(j) = w(j) - sigma werr(j) = werr(j) + abs(w(j)) * eps end do - ! call stdlib_dlarrb to reduce eigenvalue error of the approximations - ! from stdlib_dlarrd + ! call stdlib${ii}$_dlarrb to reduce eigenvalue error of the approximations + ! from stdlib${ii}$_dlarrd do i = ibegin, iend-1 - work( i ) = d( i ) * e( i )**2 + work( i ) = d( i ) * e( i )**2_${ik}$ end do ! use bisection to find ev from indl to indu - call stdlib_dlarrb(in, d(ibegin), work(ibegin),indl, indu, rtol1, rtol2, indl-1,& - w(wbegin), wgap(wbegin), werr(wbegin),work( 2*n+1 ), iwork, pivmin, spdiam,in, & + call stdlib${ii}$_dlarrb(in, d(ibegin), work(ibegin),indl, indu, rtol1, rtol2, indl-1,& + w(wbegin), wgap(wbegin), werr(wbegin),work( 2_${ik}$*n+1 ), iwork, pivmin, spdiam,in, & iinfo ) - if( iinfo /= 0 ) then - info = -4 + if( iinfo /= 0_${ik}$ ) then + info = -4_${ik}$ return end if - ! stdlib_dlarrb computes all gaps correctly except for the last one + ! stdlib${ii}$_dlarrb computes all gaps correctly except for the last one ! record distance to vu/gu wgap( wend ) = max( zero,( vu-sigma ) - ( w( wend ) + werr( wend ) ) ) do i = indl, indu - m = m + 1 + m = m + 1_${ik}$ iblock(m) = jblk indexw(m) = i end do @@ -82527,52 +82517,52 @@ module stdlib_linalg_lapack_d ! might be lost when the shift of the rrr is subtracted to obtain ! the eigenvalues of t. however, t is not guaranteed to define its ! eigenvalues to high relative accuracy anyway. - ! set rtol to the order of the tolerance used in stdlib_dlasq2 + ! set rtol to the order of the tolerance used in stdlib${ii}$_dlasq2 ! this is an estimated error, the worst case bound is 4*n*eps ! which is usually too large and requires unnecessary work to be ! done by bisection when computing the eigenvectors rtol = log(real(in,KIND=dp)) * four * eps j = ibegin do i = 1, in - 1 - work( 2*i-1 ) = abs( d( j ) ) - work( 2*i ) = e( j )*e( j )*work( 2*i-1 ) - j = j + 1 - end do - work( 2*in-1 ) = abs( d( iend ) ) - work( 2*in ) = zero - call stdlib_dlasq2( in, work, iinfo ) - if( iinfo /= 0 ) then + work( 2_${ik}$*i-1 ) = abs( d( j ) ) + work( 2_${ik}$*i ) = e( j )*e( j )*work( 2_${ik}$*i-1 ) + j = j + 1_${ik}$ + end do + work( 2_${ik}$*in-1 ) = abs( d( iend ) ) + work( 2_${ik}$*in ) = zero + call stdlib${ii}$_dlasq2( in, work, iinfo ) + if( iinfo /= 0_${ik}$ ) then ! if iinfo = -5 then an index is part of a tight cluster ! and should be changed. the index is in iwork(1) and the ! gap is in work(n+1) - info = -5 + info = -5_${ik}$ return else ! test that all eigenvalues are positive as expected do i = 1, in if( work( i )zero ) then do i = indl, indu - m = m + 1 + m = m + 1_${ik}$ w( m ) = work( in-i+1 ) iblock( m ) = jblk indexw( m ) = i end do else do i = indl, indu - m = m + 1 + m = m + 1_${ik}$ w( m ) = -work( i ) iblock( m ) = jblk indexw( m ) = i end do end if do i = m - mb + 1, m - ! the value of rtol below should be the tolerance in stdlib_dlasq2 + ! the value of rtol below should be the tolerance in stdlib${ii}$_dlasq2 werr( i ) = rtol * abs( w(i) ) end do do i = m - mb + 1, m - 1 @@ -82582,14 +82572,14 @@ module stdlib_linalg_lapack_d wgap( m ) = max( zero,( vu-sigma ) - ( w( m ) + werr( m ) ) ) end if ! proceed with next block - ibegin = iend + 1 - wbegin = wend + 1 + ibegin = iend + 1_${ik}$ + wbegin = wend + 1_${ik}$ end do loop_170 return - end subroutine stdlib_dlarre + end subroutine stdlib${ii}$_dlarre - pure subroutine stdlib_dlasd0( n, sqre, d, e, u, ldu, vt, ldvt, smlsiz, iwork,work, info ) + pure subroutine stdlib${ii}$_dlasd0( n, sqre, d, e, u, ldu, vt, ldvt, smlsiz, iwork,work, info ) !! Using a divide and conquer approach, DLASD0: computes the singular !! value decomposition (SVD) of a real upper bidiagonal N-by-M !! matrix B with diagonal D and offdiagonal E, where M = N + SQRE. @@ -82602,88 +82592,88 @@ module stdlib_linalg_lapack_d ! -- 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) :: ldu, ldvt, n, smlsiz, sqre + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldu, ldvt, n, smlsiz, sqre ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(inout) :: d(*), e(*) real(dp), intent(out) :: u(ldu,*), vt(ldvt,*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, i1, ic, idxq, idxqc, im1, inode, itemp, iwk, j, lf, ll, lvl, m, ncc,& + integer(${ik}$) :: i, i1, ic, idxq, idxqc, im1, inode, itemp, iwk, j, lf, ll, lvl, m, ncc,& nd, ndb1, ndiml, ndimr, nl, nlf, nlp1, nlvl, nr, nrf, nrp1, sqrei real(dp) :: alpha, beta ! Executable Statements ! test the input parameters. - info = 0 - if( n<0 ) then - info = -1 - else if( ( sqre<0 ) .or. ( sqre>1 ) ) then - info = -2 + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -1_${ik}$ + else if( ( sqre<0_${ik}$ ) .or. ( sqre>1_${ik}$ ) ) then + info = -2_${ik}$ end if m = n + sqre if( ldu1 ) ) then - info = -1 - else if( smlsiz<3 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ( sqre<0 ) .or. ( sqre>1 ) ) then - info = -4 + info = 0_${ik}$ + if( ( icompq<0_${ik}$ ) .or. ( icompq>1_${ik}$ ) ) then + info = -1_${ik}$ + else if( smlsiz<3_${ik}$ ) then + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( ( sqre<0_${ik}$ ) .or. ( sqre>1_${ik}$ ) ) then + info = -4_${ik}$ else if( ldu<( n+sqre ) ) then - info = -8 + info = -8_${ik}$ else if( ldgcol1 ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ncvt<0 ) then - info = -4 - else if( nru<0 ) then - info = -5 - else if( ncc<0 ) then - info = -6 - else if( ( ncvt==0 .and. ldvt<1 ) .or.( ncvt>0 .and. ldvt0 .and. ldc1_${ik}$ ) ) then + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( ncvt<0_${ik}$ ) then + info = -4_${ik}$ + else if( nru<0_${ik}$ ) then + info = -5_${ik}$ + else if( ncc<0_${ik}$ ) then + info = -6_${ik}$ + else if( ( ncvt==0_${ik}$ .and. ldvt<1_${ik}$ ) .or.( ncvt>0_${ik}$ .and. ldvt0_${ik}$ .and. ldc0 ) .or. ( nru>0 ) .or. ( ncc>0 ) - np1 = n + 1 + rotate = ( ncvt>0_${ik}$ ) .or. ( nru>0_${ik}$ ) .or. ( ncc>0_${ik}$ ) + np1 = n + 1_${ik}$ sqre1 = sqre ! if matrix non-square upper bidiagonal, rotate to be lower ! bidiagonal. the rotations are on the right. - if( ( iuplo==1 ) .and. ( sqre1==1 ) ) then + if( ( iuplo==1_${ik}$ ) .and. ( sqre1==1_${ik}$ ) ) then do i = 1, n - 1 - call stdlib_dlartg( d( i ), e( i ), cs, sn, r ) + call stdlib${ii}$_dlartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) @@ -83009,24 +82999,24 @@ module stdlib_linalg_lapack_d work( n+i ) = sn end if end do - call stdlib_dlartg( d( n ), e( n ), cs, sn, r ) + call stdlib${ii}$_dlartg( d( n ), e( n ), cs, sn, r ) d( n ) = r e( n ) = zero if( rotate ) then work( n ) = cs work( n+n ) = sn end if - iuplo = 2 - sqre1 = 0 + iuplo = 2_${ik}$ + sqre1 = 0_${ik}$ ! update singular vectors if desired. - if( ncvt>0 )call stdlib_dlasr( 'L', 'V', 'F', np1, ncvt, work( 1 ),work( np1 ), vt, & + if( ncvt>0_${ik}$ )call stdlib${ii}$_dlasr( 'L', 'V', 'F', np1, ncvt, work( 1_${ik}$ ),work( np1 ), vt, & ldvt ) end if ! if matrix lower bidiagonal, rotate to be upper bidiagonal ! by applying givens rotations on the left. - if( iuplo==2 ) then + if( iuplo==2_${ik}$ ) then do i = 1, n - 1 - call stdlib_dlartg( d( i ), e( i ), cs, sn, r ) + call stdlib${ii}$_dlartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) @@ -83037,8 +83027,8 @@ module stdlib_linalg_lapack_d end do ! if matrix (n+1)-by-n lower bidiagonal, one additional ! rotation is needed. - if( sqre1==1 ) then - call stdlib_dlartg( d( n ), e( n ), cs, sn, r ) + if( sqre1==1_${ik}$ ) then + call stdlib${ii}$_dlartg( d( n ), e( n ), cs, sn, r ) d( n ) = r if( rotate ) then work( n ) = cs @@ -83046,28 +83036,28 @@ module stdlib_linalg_lapack_d end if end if ! update singular vectors if desired. - if( nru>0 ) then - if( sqre1==0 ) then - call stdlib_dlasr( 'R', 'V', 'F', nru, n, work( 1 ),work( np1 ), u, ldu ) + if( nru>0_${ik}$ ) then + if( sqre1==0_${ik}$ ) then + call stdlib${ii}$_dlasr( 'R', 'V', 'F', nru, n, work( 1_${ik}$ ),work( np1 ), u, ldu ) else - call stdlib_dlasr( 'R', 'V', 'F', nru, np1, work( 1 ),work( np1 ), u, ldu ) + call stdlib${ii}$_dlasr( 'R', 'V', 'F', nru, np1, work( 1_${ik}$ ),work( np1 ), u, ldu ) end if end if - if( ncc>0 ) then - if( sqre1==0 ) then - call stdlib_dlasr( 'L', 'V', 'F', n, ncc, work( 1 ),work( np1 ), c, ldc ) + if( ncc>0_${ik}$ ) then + if( sqre1==0_${ik}$ ) then + call stdlib${ii}$_dlasr( 'L', 'V', 'F', n, ncc, work( 1_${ik}$ ),work( np1 ), c, ldc ) else - call stdlib_dlasr( 'L', 'V', 'F', np1, ncc, work( 1 ),work( np1 ), c, ldc ) + call stdlib${ii}$_dlasr( 'L', 'V', 'F', np1, ncc, work( 1_${ik}$ ),work( np1 ), c, ldc ) end if end if end if - ! call stdlib_dbdsqr to compute the svd of the reduced real + ! call stdlib${ii}$_dbdsqr to compute the svd of the reduced real ! n-by-n upper bidiagonal matrix. - call stdlib_dbdsqr( 'U', n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c,ldc, work, info ) + call stdlib${ii}$_dbdsqr( 'U', n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c,ldc, work, info ) ! sort the singular values into ascending order (insertion sort on ! singular values, but only one transposition per singular vector) @@ -83085,17 +83075,17 @@ module stdlib_linalg_lapack_d ! swap singular values and vectors. d( isub ) = d( i ) d( i ) = smin - if( ncvt>0 )call stdlib_dswap( ncvt, vt( isub, 1 ), ldvt, vt( i, 1 ), ldvt ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_dswap( ncvt, vt( isub, 1_${ik}$ ), ldvt, vt( i, 1_${ik}$ ), ldvt ) - if( nru>0 )call stdlib_dswap( nru, u( 1, isub ), 1, u( 1, i ), 1 ) - if( ncc>0 )call stdlib_dswap( ncc, c( isub, 1 ), ldc, c( i, 1 ), ldc ) + if( nru>0_${ik}$ )call stdlib${ii}$_dswap( nru, u( 1_${ik}$, isub ), 1_${ik}$, u( 1_${ik}$, i ), 1_${ik}$ ) + if( ncc>0_${ik}$ )call stdlib${ii}$_dswap( ncc, c( isub, 1_${ik}$ ), ldc, c( i, 1_${ik}$ ), ldc ) end if end do return - end subroutine stdlib_dlasdq + end subroutine stdlib${ii}$_dlasdq - pure subroutine stdlib_dlasq1( n, d, e, work, info ) + pure subroutine stdlib${ii}$_dlasq1( n, d, e, work, info ) !! DLASQ1 computes the singular values of a real N-by-N bidiagonal !! matrix with diagonal D and off-diagonal E. The singular values !! are computed to high relative accuracy, in the absence of @@ -83110,33 +83100,33 @@ module stdlib_linalg_lapack_d ! -- 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 real(dp), intent(inout) :: d(*), e(*) real(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, iinfo + integer(${ik}$) :: i, iinfo real(dp) :: eps, scale, safmin, sigmn, sigmx ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements - info = 0 - if( n<0 ) then - info = -1 - call stdlib_xerbla( 'DLASQ1', -info ) + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -1_${ik}$ + call stdlib${ii}$_xerbla( 'DLASQ1', -info ) return - else if( n==0 ) then + else if( n==0_${ik}$ ) then return - else if( n==1 ) then - d( 1 ) = abs( d( 1 ) ) + else if( n==1_${ik}$ ) then + d( 1_${ik}$ ) = abs( d( 1_${ik}$ ) ) return - else if( n==2 ) then - call stdlib_dlas2( d( 1 ), e( 1 ), d( 2 ), sigmn, sigmx ) - d( 1 ) = sigmx - d( 2 ) = sigmn + else if( n==2_${ik}$ ) then + call stdlib${ii}$_dlas2( d( 1_${ik}$ ), e( 1_${ik}$ ), d( 2_${ik}$ ), sigmn, sigmx ) + d( 1_${ik}$ ) = sigmx + d( 2_${ik}$ ) = sigmn return end if ! estimate the largest singular value. @@ -83148,7 +83138,7 @@ module stdlib_linalg_lapack_d d( n ) = abs( d( n ) ) ! early return if sigmx is zero (matrix is already diagonal). if( sigmx==zero ) then - call stdlib_dlasrt( 'D', n, d, iinfo ) + call stdlib${ii}$_dlasrt( 'D', n, d, iinfo ) return end if do i = 1, n @@ -83156,38 +83146,38 @@ module stdlib_linalg_lapack_d end do ! copy d and e into work (in the z format) and scale (squaring the ! input data makes scaling by a power of the radix pointless). - eps = stdlib_dlamch( 'PRECISION' ) - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_dlamch( 'PRECISION' ) + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) scale = sqrt( eps / safmin ) - call stdlib_dcopy( n, d, 1, work( 1 ), 2 ) - call stdlib_dcopy( n-1, e, 1, work( 2 ), 2 ) - call stdlib_dlascl( 'G', 0, 0, sigmx, scale, 2*n-1, 1, work, 2*n-1,iinfo ) + call stdlib${ii}$_dcopy( n, d, 1_${ik}$, work( 1_${ik}$ ), 2_${ik}$ ) + call stdlib${ii}$_dcopy( n-1, e, 1_${ik}$, work( 2_${ik}$ ), 2_${ik}$ ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, sigmx, scale, 2_${ik}$*n-1, 1_${ik}$, work, 2_${ik}$*n-1,iinfo ) ! compute the q's and e's. do i = 1, 2*n - 1 - work( i ) = work( i )**2 + work( i ) = work( i )**2_${ik}$ end do - work( 2*n ) = zero - call stdlib_dlasq2( n, work, info ) - if( info==0 ) then + work( 2_${ik}$*n ) = zero + call stdlib${ii}$_dlasq2( n, work, info ) + if( info==0_${ik}$ ) then do i = 1, n d( i ) = sqrt( work( i ) ) end do - call stdlib_dlascl( 'G', 0, 0, scale, sigmx, n, 1, d, n, iinfo ) - else if( info==2 ) then + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, scale, sigmx, n, 1_${ik}$, d, n, iinfo ) + else if( info==2_${ik}$ ) then ! maximum number of iterations exceeded. move data from work ! into d and e so the calling subroutine can try to finish do i = 1, n - d( i ) = sqrt( work( 2*i-1 ) ) - e( i ) = sqrt( work( 2*i ) ) + d( i ) = sqrt( work( 2_${ik}$*i-1 ) ) + e( i ) = sqrt( work( 2_${ik}$*i ) ) end do - call stdlib_dlascl( 'G', 0, 0, scale, sigmx, n, 1, d, n, iinfo ) - call stdlib_dlascl( 'G', 0, 0, scale, sigmx, n, 1, e, n, iinfo ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, scale, sigmx, n, 1_${ik}$, d, n, iinfo ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, scale, sigmx, n, 1_${ik}$, e, n, iinfo ) end if return - end subroutine stdlib_dlasq1 + end subroutine stdlib${ii}$_dlasq1 - pure subroutine stdlib_dlasq2( n, z, info ) + pure subroutine stdlib${ii}$_dlasq2( n, z, info ) !! DLASQ2 computes all the eigenvalues of the symmetric positive !! definite tridiagonal matrix associated with the qd array Z to high !! relative accuracy are computed to high relative accuracy, in the @@ -83205,8 +83195,8 @@ module stdlib_linalg_lapack_d ! -- 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 real(dp), intent(inout) :: z(*) ! ===================================================================== @@ -83217,7 +83207,7 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: ieee - integer(ilp) :: i0, i1, i4, iinfo, ipn4, iter, iwhila, iwhilb, k, kmin, n0, n1, nbig, & + integer(${ik}$) :: i0, i1, i4, iinfo, ipn4, iter, iwhila, iwhilb, k, kmin, n0, n1, nbig, & ndiv, nfail, pp, splt, ttype real(dp) :: d, dee, deemin, desig, dmin, dmin1, dmin2, dn, dn1, dn2, e, emax, emin, & eps, g, oldemn, qmax, qmin, s, safmin, sigma, t, tau, temp, tol, tol2, trace, zmax, & @@ -83226,76 +83216,76 @@ module stdlib_linalg_lapack_d intrinsic :: abs,real,max,min,sqrt ! Executable Statements ! test the input arguments. - ! (in case stdlib_dlasq2 is not called by stdlib_dlasq1) - info = 0 - eps = stdlib_dlamch( 'PRECISION' ) - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) + ! (in case stdlib${ii}$_dlasq2 is not called by stdlib${ii}$_dlasq1) + info = 0_${ik}$ + eps = stdlib${ii}$_dlamch( 'PRECISION' ) + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) tol = eps*hundrd - tol2 = tol**2 - if( n<0 ) then - info = -1 - call stdlib_xerbla( 'DLASQ2', 1 ) + tol2 = tol**2_${ik}$ + if( n<0_${ik}$ ) then + info = -1_${ik}$ + call stdlib${ii}$_xerbla( 'DLASQ2', 1_${ik}$ ) return - else if( n==0 ) then + else if( n==0_${ik}$ ) then return - else if( n==1 ) then + else if( n==1_${ik}$ ) then ! 1-by-1 case. - if( z( 1 )z( 1 ) ) then - d = z( 3 ) - z( 3 ) = z( 1 ) - z( 1 ) = d - end if - z( 5 ) = z( 1 ) + z( 2 ) + z( 3 ) - if( z( 2 )>z( 3 )*tol2 ) then - t = half*( ( z( 1 )-z( 3 ) )+z( 2 ) ) - s = z( 3 )*( z( 2 ) / t ) + else if( z( 3_${ik}$ )>z( 1_${ik}$ ) ) then + d = z( 3_${ik}$ ) + z( 3_${ik}$ ) = z( 1_${ik}$ ) + z( 1_${ik}$ ) = d + end if + z( 5_${ik}$ ) = z( 1_${ik}$ ) + z( 2_${ik}$ ) + z( 3_${ik}$ ) + if( z( 2_${ik}$ )>z( 3_${ik}$ )*tol2 ) then + t = half*( ( z( 1_${ik}$ )-z( 3_${ik}$ ) )+z( 2_${ik}$ ) ) + s = z( 3_${ik}$ )*( z( 2_${ik}$ ) / t ) if( s<=t ) then - s = z( 3 )*( z( 2 ) / ( t*( one+sqrt( one+s / t ) ) ) ) + s = z( 3_${ik}$ )*( z( 2_${ik}$ ) / ( t*( one+sqrt( one+s / t ) ) ) ) else - s = z( 3 )*( z( 2 ) / ( t+sqrt( t )*sqrt( t+s ) ) ) + s = z( 3_${ik}$ )*( z( 2_${ik}$ ) / ( t+sqrt( t )*sqrt( t+s ) ) ) end if - t = z( 1 ) + ( s+z( 2 ) ) - z( 3 ) = z( 3 )*( z( 1 ) / t ) - z( 1 ) = t + t = z( 1_${ik}$ ) + ( s+z( 2_${ik}$ ) ) + z( 3_${ik}$ ) = z( 3_${ik}$ )*( z( 1_${ik}$ ) / t ) + z( 1_${ik}$ ) = t end if - z( 2 ) = z( 3 ) - z( 6 ) = z( 2 ) + z( 1 ) + z( 2_${ik}$ ) = z( 3_${ik}$ ) + z( 6_${ik}$ ) = z( 2_${ik}$ ) + z( 1_${ik}$ ) return end if ! check for negative data and compute sums of q's and e's. - z( 2*n ) = zero - emin = z( 2 ) + z( 2_${ik}$*n ) = zero + emin = z( 2_${ik}$ ) qmax = zero zmax = zero d = zero e = zero do k = 1, 2*( n-1 ), 2 if( z( k )i0 ) then - emin = abs( z( 4*n0-5 ) ) + emin = abs( z( 4_${ik}$*n0-5 ) ) else emin = zero end if - qmin = z( 4*n0-3 ) + qmin = z( 4_${ik}$*n0-3 ) qmax = qmin do i4 = 4*n0, 8, -4 if( z( i4-5 )<=zero )go to 100 @@ -83438,24 +83428,24 @@ module stdlib_linalg_lapack_d qmax = max( qmax, z( i4-7 )+z( i4-5 ) ) emin = min( emin, z( i4-5 ) ) end do - i4 = 4 + i4 = 4_${ik}$ 100 continue - i0 = i4 / 4 - pp = 0 - if( n0-i0>1 ) then - dee = z( 4*i0-3 ) + i0 = i4 / 4_${ik}$ + pp = 0_${ik}$ + if( n0-i0>1_${ik}$ ) then + dee = z( 4_${ik}$*i0-3 ) deemin = dee kmin = i0 do i4 = 4*i0+1, 4*n0-3, 4 dee = z( i4 )*( dee /( dee+z( i4-2 ) ) ) if( dee<=deemin ) then deemin = dee - kmin = ( i4+3 )/4 + kmin = ( i4+3 )/4_${ik}$ end if end do - if( (kmin-i0)*2n0 )go to 150 ! while submatrix unfinished take a good dqds step. - call stdlib_dlasq3( i0, n0, z, pp, dmin, sigma, desig, qmax, nfail,iter, ndiv, & + call stdlib${ii}$_dlasq3( i0, n0, z, pp, dmin, sigma, desig, qmax, nfail,iter, ndiv, & ieee, ttype, dmin1, dmin2, dn, dn1,dn2, g, tau ) - pp = 1 - pp + pp = 1_${ik}$ - pp ! when emin is very small check for splits. - if( pp==0 .and. n0-i0>=3 ) then - if( z( 4*n0 )<=tol2*qmax .or.z( 4*n0-1 )<=tol2*sigma ) then - splt = i0 - 1 - qmax = z( 4*i0-3 ) - emin = z( 4*i0-1 ) - oldemn = z( 4*i0 ) + if( pp==0_${ik}$ .and. n0-i0>=3_${ik}$ ) then + if( z( 4_${ik}$*n0 )<=tol2*qmax .or.z( 4_${ik}$*n0-1 )<=tol2*sigma ) then + splt = i0 - 1_${ik}$ + qmax = z( 4_${ik}$*i0-3 ) + emin = z( 4_${ik}$*i0-1 ) + oldemn = z( 4_${ik}$*i0 ) do i4 = 4*i0, 4*( n0-3 ), 4 if( z( i4 )<=tol2*z( i4-3 ) .or.z( i4-1 )<=tol2*sigma ) then z( i4-1 ) = -sigma - splt = i4 / 4 + splt = i4 / 4_${ik}$ qmax = zero emin = z( i4+3 ) oldemn = z( i4+4 ) @@ -83506,76 +83496,76 @@ module stdlib_linalg_lapack_d oldemn = min( oldemn, z( i4 ) ) end if end do - z( 4*n0-1 ) = emin - z( 4*n0 ) = oldemn - i0 = splt + 1 + z( 4_${ik}$*n0-1 ) = emin + z( 4_${ik}$*n0 ) = oldemn + i0 = splt + 1_${ik}$ end if end if end do loop_140 - info = 2 + info = 2_${ik}$ ! maximum number of iterations exceeded, restore the shift ! sigma and place the new d's and e's in a qd array. ! this might need to be done for several blocks i1 = i0 n1 = n0 145 continue - tempq = z( 4*i0-3 ) - z( 4*i0-3 ) = z( 4*i0-3 ) + sigma + tempq = z( 4_${ik}$*i0-3 ) + z( 4_${ik}$*i0-3 ) = z( 4_${ik}$*i0-3 ) + sigma do k = i0+1, n0 - tempe = z( 4*k-5 ) - z( 4*k-5 ) = z( 4*k-5 ) * (tempq / z( 4*k-7 )) - tempq = z( 4*k-3 ) - z( 4*k-3 ) = z( 4*k-3 ) + sigma + tempe - z( 4*k-5 ) + tempe = z( 4_${ik}$*k-5 ) + z( 4_${ik}$*k-5 ) = z( 4_${ik}$*k-5 ) * (tempq / z( 4_${ik}$*k-7 )) + tempq = z( 4_${ik}$*k-3 ) + z( 4_${ik}$*k-3 ) = z( 4_${ik}$*k-3 ) + sigma + tempe - z( 4_${ik}$*k-5 ) end do ! prepare to do this on the previous block if there is one - if( i1>1 ) then + if( i1>1_${ik}$ ) then n1 = i1-1 do while( ( i1>=2 ) .and. ( z(4*i1-5)>=zero ) ) - i1 = i1 - 1 + i1 = i1 - 1_${ik}$ end do - sigma = -z(4*n1-1) + sigma = -z(4_${ik}$*n1-1) go to 145 end if do k = 1, n - z( 2*k-1 ) = z( 4*k-3 ) + z( 2_${ik}$*k-1 ) = z( 4_${ik}$*k-3 ) ! only the block 1..n0 is unfinished. the rest of the e's ! must be essentially zero, although sometimes other data ! has been stored in them. if( kmin(m, nb) )go to 20 ! k is the column to be factorized - ! when being called from stdlib_dsytrf_aa, + ! when being called from stdlib${ii}$_dsytrf_aa, ! > for the first block column, j1 is 1, hence j1+j-1 is j, ! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1, k = j1+j-1 if( j==m ) then ! only need to compute t(j, j) - mj = 1 + mj = 1_${ik}$ else mj = m-j+1 end if ! h(j:m, j) := a(j, j:m) - h(j:m, 1:(j-1)) * l(j1:(j-1), j), ! where h(j:m, j) has been initialized to be a(j, j:m) - if( k>2 ) then + if( k>2_${ik}$ ) then ! k is the column to be factorized ! > for the first block column, k is j, skipping the first two ! columns ! > for the rest of the columns, k is j+1, skipping only the ! first column - call stdlib_dgemv( 'NO TRANSPOSE', mj, j-k1,-one, h( j, k1 ), ldh,a( 1, j ), 1,& - one, h( j, j ), 1 ) + call stdlib${ii}$_dgemv( 'NO TRANSPOSE', mj, j-k1,-one, h( j, k1 ), ldh,a( 1_${ik}$, j ), 1_${ik}$,& + one, h( j, j ), 1_${ik}$ ) end if ! copy h(i:m, i) into work - call stdlib_dcopy( mj, h( j, j ), 1, work( 1 ), 1 ) + call stdlib${ii}$_dcopy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) if( j>k1 ) then ! compute work := work - l(j-1, j:m) * t(j-1,j), ! where a(j-1, j) stores t(j-1, j) and a(j-2, j:m) stores u(j-1, j:m) alpha = -a( k-1, j ) - call stdlib_daxpy( mj, alpha, a( k-2, j ), lda, work( 1 ), 1 ) + call stdlib${ii}$_daxpy( mj, alpha, a( k-2, j ), lda, work( 1_${ik}$ ), 1_${ik}$ ) end if ! set a(j, j) = t(j, j) - a( k, j ) = work( 1 ) + a( k, j ) = work( 1_${ik}$ ) if( j1 ) then + if( k>1_${ik}$ ) then alpha = -a( k, j ) - call stdlib_daxpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2 ), 1 ) + call stdlib${ii}$_daxpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2_${ik}$ ), 1_${ik}$ ) endif ! find max(|work(2:m)|) - i2 = stdlib_idamax( m-j, work( 2 ), 1 ) + 1 + i2 = stdlib${ii}$_idamax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$ piv = work( i2 ) ! apply symmetric pivot - if( (i2/=2) .and. (piv/=0) ) then + if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then ! swap work(i1) and work(i2) - i1 = 2 + i1 = 2_${ik}$ work( i2 ) = work( i1 ) work( i1 ) = piv ! swap a(i1, i1+1:m) with a(i1+1:m, i2) i1 = i1+j-1 i2 = i2+j-1 - call stdlib_dswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1 ) + call stdlib${ii}$_dswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1_${ik}$ ) ! swap a(i1, i2+1:m) with a(i2, i2+1:m) - if( i2(k1-1) ) then ! swap l(1:i1-1, i1) with l(1:i1-1, i2), ! skipping the first column - call stdlib_dswap( i1-k1+1, a( 1, i1 ), 1,a( 1, i2 ), 1 ) + call stdlib${ii}$_dswap( i1-k1+1, a( 1_${ik}$, i1 ), 1_${ik}$,a( 1_${ik}$, i2 ), 1_${ik}$ ) end if else ipiv( j+1 ) = j+1 endif ! set a(j, j+1) = t(j, j+1) - a( k, j+1 ) = work( 2 ) + a( k, j+1 ) = work( 2_${ik}$ ) if( jmin( m, nb ) )go to 40 ! k is the column to be factorized - ! when being called from stdlib_dsytrf_aa, + ! when being called from stdlib${ii}$_dsytrf_aa, ! > for the first block column, j1 is 1, hence j1+j-1 is j, ! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1, k = j1+j-1 if( j==m ) then ! only need to compute t(j, j) - mj = 1 + mj = 1_${ik}$ else mj = m-j+1 end if ! h(j:m, j) := a(j:m, j) - h(j:m, 1:(j-1)) * l(j, j1:(j-1))^t, ! where h(j:m, j) has been initialized to be a(j:m, j) - if( k>2 ) then + if( k>2_${ik}$ ) then ! k is the column to be factorized ! > for the first block column, k is j, skipping the first two ! columns ! > for the rest of the columns, k is j+1, skipping only the ! first column - call stdlib_dgemv( 'NO TRANSPOSE', mj, j-k1,-one, h( j, k1 ), ldh,a( j, 1 ), lda,& - one, h( j, j ), 1 ) + call stdlib${ii}$_dgemv( 'NO TRANSPOSE', mj, j-k1,-one, h( j, k1 ), ldh,a( j, 1_${ik}$ ), lda,& + one, h( j, j ), 1_${ik}$ ) end if ! copy h(j:m, j) into work - call stdlib_dcopy( mj, h( j, j ), 1, work( 1 ), 1 ) + call stdlib${ii}$_dcopy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) if( j>k1 ) then ! compute work := work - l(j:m, j-1) * t(j-1,j), ! where a(j-1, j) = t(j-1, j) and a(j, j-2) = l(j, j-1) alpha = -a( j, k-1 ) - call stdlib_daxpy( mj, alpha, a( j, k-2 ), 1, work( 1 ), 1 ) + call stdlib${ii}$_daxpy( mj, alpha, a( j, k-2 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) end if ! set a(j, j) = t(j, j) - a( j, k ) = work( 1 ) + a( j, k ) = work( 1_${ik}$ ) if( j1 ) then + if( k>1_${ik}$ ) then alpha = -a( j, k ) - call stdlib_daxpy( m-j, alpha, a( j+1, k-1 ), 1,work( 2 ), 1 ) + call stdlib${ii}$_daxpy( m-j, alpha, a( j+1, k-1 ), 1_${ik}$,work( 2_${ik}$ ), 1_${ik}$ ) endif ! find max(|work(2:m)|) - i2 = stdlib_idamax( m-j, work( 2 ), 1 ) + 1 + i2 = stdlib${ii}$_idamax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$ piv = work( i2 ) ! apply symmetric pivot - if( (i2/=2) .and. (piv/=0) ) then + if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then ! swap work(i1) and work(i2) - i1 = 2 + i1 = 2_${ik}$ work( i2 ) = work( i1 ) work( i1 ) = piv ! swap a(i1+1:m, i1) with a(i2, i1+1:m) i1 = i1+j-1 i2 = i2+j-1 - call stdlib_dswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1,a( i2, j1+i1 ), lda ) + call stdlib${ii}$_dswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1_${ik}$,a( i2, j1+i1 ), lda ) ! swap a(i2+1:m, i1) with a(i2+1:m, i2) - if( i2(k1-1) ) then ! swap l(1:i1-1, i1) with l(1:i1-1, i2), ! skipping the first column - call stdlib_dswap( i1-k1+1, a( i1, 1 ), lda,a( i2, 1 ), lda ) + call stdlib${ii}$_dswap( i1-k1+1, a( i1, 1_${ik}$ ), lda,a( i2, 1_${ik}$ ), lda ) end if else ipiv( j+1 ) = j+1 endif ! set a(j+1, j) = t(j+1, j) - a( j+1, k ) = work( 2 ) + a( j+1, k ) = work( 2_${ik}$ ) if( j0 .and. ldz0_${ik}$ .and. ldz0 )z( 1, 1 ) = one + if( n==1_${ik}$ ) then + if( icompz>0_${ik}$ )z( 1_${ik}$, 1_${ik}$ ) = one return end if - if( icompz==2 )call stdlib_dlaset( 'FULL', n, n, zero, one, z, ldz ) - ! call stdlib_dpttrf to factor the matrix. - call stdlib_dpttrf( n, d, e, info ) + if( icompz==2_${ik}$ )call stdlib${ii}$_dlaset( 'FULL', n, n, zero, one, z, ldz ) + ! call stdlib${ii}$_dpttrf to factor the matrix. + call stdlib${ii}$_dpttrf( n, d, e, info ) if( info/=0 )return do i = 1, n d( i ) = sqrt( d( i ) ) @@ -83882,17 +83872,17 @@ module stdlib_linalg_lapack_d do i = 1, n - 1 e( i ) = e( i )*d( i ) end do - ! call stdlib_dbdsqr to compute the singular values/vectors of the + ! call stdlib${ii}$_dbdsqr to compute the singular values/vectors of the ! bidiagonal factor. - if( icompz>0 ) then + if( icompz>0_${ik}$ ) then nru = n else - nru = 0 + nru = 0_${ik}$ end if - call stdlib_dbdsqr( 'LOWER', n, 0, nru, 0, d, e, vt, 1, z, ldz, c, 1,work, info ) + call stdlib${ii}$_dbdsqr( 'LOWER', n, 0_${ik}$, nru, 0_${ik}$, d, e, vt, 1_${ik}$, z, ldz, c, 1_${ik}$,work, info ) ! square the singular values. - if( info==0 ) then + if( info==0_${ik}$ ) then do i = 1, n d( i ) = d( i )*d( i ) end do @@ -83900,10 +83890,10 @@ module stdlib_linalg_lapack_d info = n + info end if return - end subroutine stdlib_dpteqr + end subroutine stdlib${ii}$_dpteqr - pure subroutine stdlib_dstegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, & + pure subroutine stdlib${ii}$_dstegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, & !! DSTEGR computes selected eigenvalues and, optionally, eigenvectors !! of a real symmetric tridiagonal matrix T. Any such unreduced matrix has !! a well defined set of pairwise different real eigenvalues, the corresponding @@ -83926,11 +83916,11 @@ module stdlib_linalg_lapack_d ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range - integer(ilp), intent(in) :: il, iu, ldz, liwork, lwork, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, iu, ldz, liwork, lwork, n + integer(${ik}$), intent(out) :: info, m real(dp), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: isuppz(*), iwork(*) + integer(${ik}$), intent(out) :: isuppz(*), iwork(*) real(dp), intent(inout) :: d(*), e(*) real(dp), intent(out) :: w(*), work(*) real(dp), intent(out) :: z(ldz,*) @@ -83938,14 +83928,14 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: tryrac ! Executable Statements - info = 0 + info = 0_${ik}$ tryrac = .false. - call stdlib_dstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, n, isuppz, & + call stdlib${ii}$_dstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, n, isuppz, & tryrac, work, lwork,iwork, liwork, info ) - end subroutine stdlib_dstegr + end subroutine stdlib${ii}$_dstegr - pure subroutine stdlib_dstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, nzc, & + pure subroutine stdlib${ii}$_dstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, nzc, & !! DSTEMR computes selected eigenvalues and, optionally, eigenvectors !! of a real symmetric tridiagonal matrix T. Any such unreduced matrix has !! a well defined set of pairwise different real eigenvalues, the corresponding @@ -83998,11 +83988,11 @@ module stdlib_linalg_lapack_d ! Scalar Arguments character, intent(in) :: jobz, range logical(lk), intent(inout) :: tryrac - integer(ilp), intent(in) :: il, iu, ldz, nzc, liwork, lwork, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, iu, ldz, nzc, liwork, lwork, n + integer(${ik}$), intent(out) :: info, m real(dp), intent(in) :: vl, vu ! Array Arguments - integer(ilp), intent(out) :: isuppz(*), iwork(*) + integer(${ik}$), intent(out) :: isuppz(*), iwork(*) real(dp), intent(inout) :: d(*), e(*) real(dp), intent(out) :: w(*), work(*) real(dp), intent(out) :: z(ldz,*) @@ -84012,7 +84002,7 @@ module stdlib_linalg_lapack_d ! Local Scalars logical(lk) :: alleig, indeig, lquery, valeig, wantz, zquery - integer(ilp) :: i, ibegin, iend, ifirst, iil, iindbl, iindw, iindwk, iinfo, iinspl, & + integer(${ik}$) :: i, ibegin, iend, ifirst, iil, iindbl, iindw, iindwk, iinfo, iinspl, & iiu, ilast, in, indd, inde2, inderr, indgp, indgrs, indwrk, itmp, itmp2, j, jblk, jj, & liwmin, lwmin, nsplit, nzcmin, offset, wbegin, wend real(dp) :: bignum, cs, eps, pivmin, r1, r2, rmax, rmin, rtol1, rtol2, safmin, scale, & @@ -84025,28 +84015,28 @@ module stdlib_linalg_lapack_d alleig = stdlib_lsame( range, 'A' ) valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) - lquery = ( ( lwork==-1 ).or.( liwork==-1 ) ) - zquery = ( nzc==-1 ) - ! stdlib_dstemr needs work of size 6*n, iwork of size 3*n. - ! in addition, stdlib_dlarre needs work of size 6*n, iwork of size 5*n. - ! furthermore, stdlib_dlarrv needs work of size 12*n, iwork of size 7*n. + lquery = ( ( lwork==-1_${ik}$ ).or.( liwork==-1_${ik}$ ) ) + zquery = ( nzc==-1_${ik}$ ) + ! stdlib${ii}$_dstemr needs work of size 6*n, iwork of size 3*n. + ! in addition, stdlib${ii}$_dlarre needs work of size 6*n, iwork of size 5*n. + ! furthermore, stdlib${ii}$_dlarrv needs work of size 12*n, iwork of size 7*n. if( wantz ) then - lwmin = 18*n - liwmin = 10*n + lwmin = 18_${ik}$*n + liwmin = 10_${ik}$*n else ! need less workspace if only the eigenvalues are wanted - lwmin = 12*n - liwmin = 8*n + lwmin = 12_${ik}$*n + liwmin = 8_${ik}$*n endif wl = zero wu = zero - iil = 0 - iiu = 0 - nsplit = 0 + iil = 0_${ik}$ + iiu = 0_${ik}$ + nsplit = 0_${ik}$ if( valeig ) then ! we do not reference vl, vu in the cases range = 'i','a' ! the interval (wl, wu] contains all the wanted eigenvalues. - ! it is either given by the user or computed in stdlib_dlarre. + ! it is either given by the user or computed in stdlib${ii}$_dlarre. wl = vl wu = vu elseif( indeig ) then @@ -84054,156 +84044,156 @@ module stdlib_linalg_lapack_d iil = il iiu = iu endif - info = 0 + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( valeig .and. n>0 .and. wu<=wl ) then - info = -7 - else if( indeig .and. ( iil<1 .or. iil>n ) ) then - info = -8 + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( valeig .and. n>0_${ik}$ .and. wu<=wl ) then + info = -7_${ik}$ + else if( indeig .and. ( iil<1_${ik}$ .or. iil>n ) ) then + info = -8_${ik}$ else if( indeig .and. ( iiun ) ) then - info = -9 - else if( ldz<1 .or. ( wantz .and. ldz=d( 1 ) ) then - m = 1 - w( 1 ) = d( 1 ) + if( wl=d( 1_${ik}$ ) ) then + m = 1_${ik}$ + w( 1_${ik}$ ) = d( 1_${ik}$ ) end if end if if( wantz.and.(.not.zquery) ) then - z( 1, 1 ) = one - isuppz(1) = 1 - isuppz(2) = 1 + z( 1_${ik}$, 1_${ik}$ ) = one + isuppz(1_${ik}$) = 1_${ik}$ + isuppz(2_${ik}$) = 1_${ik}$ end if return end if - if( n==2 ) then + if( n==2_${ik}$ ) then if( .not.wantz ) then - call stdlib_dlae2( d(1), e(1), d(2), r1, r2 ) + call stdlib${ii}$_dlae2( d(1_${ik}$), e(1_${ik}$), d(2_${ik}$), r1, r2 ) else if( wantz.and.(.not.zquery) ) then - call stdlib_dlaev2( d(1), e(1), d(2), r1, r2, cs, sn ) + call stdlib${ii}$_dlaev2( d(1_${ik}$), e(1_${ik}$), d(2_${ik}$), r1, r2, cs, sn ) end if - if( alleig.or.(valeig.and.(r2>wl).and.(r2<=wu)).or.(indeig.and.(iil==1)) ) & + if( alleig.or.(valeig.and.(r2>wl).and.(r2<=wu)).or.(indeig.and.(iil==1_${ik}$)) ) & then m = m+1 w( m ) = r2 if( wantz.and.(.not.zquery) ) then - z( 1, m ) = -sn - z( 2, m ) = cs + z( 1_${ik}$, m ) = -sn + z( 2_${ik}$, m ) = cs ! note: at most one of sn and cs can be zero. if (sn/=zero) then if (cs/=zero) then - isuppz(2*m-1) = 1 - isuppz(2*m) = 2 + isuppz(2_${ik}$*m-1) = 1_${ik}$ + isuppz(2_${ik}$*m) = 2_${ik}$ else - isuppz(2*m-1) = 1 - isuppz(2*m) = 1 + isuppz(2_${ik}$*m-1) = 1_${ik}$ + isuppz(2_${ik}$*m) = 1_${ik}$ end if else - isuppz(2*m-1) = 2 - isuppz(2*m) = 2 + isuppz(2_${ik}$*m-1) = 2_${ik}$ + isuppz(2_${ik}$*m) = 2_${ik}$ end if endif endif - if( alleig.or.(valeig.and.(r1>wl).and.(r1<=wu)).or.(indeig.and.(iiu==2)) ) & + if( alleig.or.(valeig.and.(r1>wl).and.(r1<=wu)).or.(indeig.and.(iiu==2_${ik}$)) ) & then m = m+1 w( m ) = r1 if( wantz.and.(.not.zquery) ) then - z( 1, m ) = cs - z( 2, m ) = sn + z( 1_${ik}$, m ) = cs + z( 2_${ik}$, m ) = sn ! note: at most one of sn and cs can be zero. if (sn/=zero) then if (cs/=zero) then - isuppz(2*m-1) = 1 - isuppz(2*m) = 2 + isuppz(2_${ik}$*m-1) = 1_${ik}$ + isuppz(2_${ik}$*m) = 2_${ik}$ else - isuppz(2*m-1) = 1 - isuppz(2*m) = 1 + isuppz(2_${ik}$*m-1) = 1_${ik}$ + isuppz(2_${ik}$*m) = 1_${ik}$ end if else - isuppz(2*m-1) = 2 - isuppz(2*m) = 2 + isuppz(2_${ik}$*m-1) = 2_${ik}$ + isuppz(2_${ik}$*m) = 2_${ik}$ end if endif endif else ! continue with general n - indgrs = 1 - inderr = 2*n + 1 - indgp = 3*n + 1 - indd = 4*n + 1 - inde2 = 5*n + 1 - indwrk = 6*n + 1 - iinspl = 1 - iindbl = n + 1 - iindw = 2*n + 1 - iindwk = 3*n + 1 + indgrs = 1_${ik}$ + inderr = 2_${ik}$*n + 1_${ik}$ + indgp = 3_${ik}$*n + 1_${ik}$ + indd = 4_${ik}$*n + 1_${ik}$ + inde2 = 5_${ik}$*n + 1_${ik}$ + indwrk = 6_${ik}$*n + 1_${ik}$ + iinspl = 1_${ik}$ + iindbl = n + 1_${ik}$ + iindw = 2_${ik}$*n + 1_${ik}$ + iindwk = 3_${ik}$*n + 1_${ik}$ ! scale matrix to allowable range, if necessary. ! the allowable range is related to the pivmin parameter; see the - ! comments in stdlib_dlarrd. the preference for scaling small values + ! comments in stdlib${ii}$_dlarrd. the preference for scaling small values ! up is heuristic; we expect users' matrices not to be close to the ! rmax threshold. scale = one - tnrm = stdlib_dlanst( 'M', n, d, e ) + tnrm = stdlib${ii}$_dlanst( 'M', n, d, e ) if( tnrm>zero .and. tnrmrmax ) then scale = rmax / tnrm end if if( scale/=one ) then - call stdlib_dscal( n, scale, d, 1 ) - call stdlib_dscal( n-1, scale, e, 1 ) + call stdlib${ii}$_dscal( n, scale, d, 1_${ik}$ ) + call stdlib${ii}$_dscal( n-1, scale, e, 1_${ik}$ ) tnrm = tnrm*scale if( valeig ) then ! if eigenvalues in interval have to be found, @@ -84215,19 +84205,19 @@ module stdlib_linalg_lapack_d ! compute the desired eigenvalues of the tridiagonal after splitting ! into smaller subblocks if the corresponding off-diagonal elements ! are small - ! thresh is the splitting parameter for stdlib_dlarre + ! thresh is the splitting parameter for stdlib${ii}$_dlarre ! a negative thresh forces the old splitting criterion based on the ! size of the off-diagonal. a positive thresh switches to splitting ! which preserves relative accuracy. if( tryrac ) then ! test whether the matrix warrants the more expensive relative approach. - call stdlib_dlarrr( n, d, e, iinfo ) + call stdlib${ii}$_dlarrr( n, d, e, iinfo ) else ! the user does not care about relative accurately eigenvalues - iinfo = -1 + iinfo = -1_${ik}$ endif ! set the splitting criterion - if (iinfo==0) then + if (iinfo==0_${ik}$) then thresh = eps else thresh = -eps @@ -84236,51 +84226,51 @@ module stdlib_linalg_lapack_d endif if( tryrac ) then ! copy original diagonal, needed to guarantee relative accuracy - call stdlib_dcopy(n,d,1,work(indd),1) + call stdlib${ii}$_dcopy(n,d,1_${ik}$,work(indd),1_${ik}$) endif ! store the squares of the offdiagonal values of t do j = 1, n-1 - work( inde2+j-1 ) = e(j)**2 + work( inde2+j-1 ) = e(j)**2_${ik}$ end do ! set the tolerance parameters for bisection if( .not.wantz ) then - ! stdlib_dlarre computes the eigenvalues to full precision. + ! stdlib${ii}$_dlarre computes the eigenvalues to full precision. rtol1 = four * eps rtol2 = four * eps else - ! stdlib_dlarre computes the eigenvalues to less than full precision. - ! stdlib_dlarrv will refine the eigenvalue approximations, and we can - ! need less accurate initial bisection in stdlib_dlarre. - ! note: these settings do only affect the subset case and stdlib_dlarre + ! stdlib${ii}$_dlarre computes the eigenvalues to less than full precision. + ! stdlib${ii}$_dlarrv will refine the eigenvalue approximations, and we can + ! need less accurate initial bisection in stdlib${ii}$_dlarre. + ! note: these settings do only affect the subset case and stdlib${ii}$_dlarre rtol1 = sqrt(eps) rtol2 = max( sqrt(eps)*5.0e-3_dp, four * eps ) endif - call stdlib_dlarre( range, n, wl, wu, iil, iiu, d, e,work(inde2), rtol1, rtol2, & + call stdlib${ii}$_dlarre( range, n, wl, wu, iil, iiu, d, e,work(inde2), rtol1, rtol2, & thresh, nsplit,iwork( iinspl ), m, w, work( inderr ),work( indgp ), iwork( iindbl ),& iwork( iindw ), work( indgrs ), pivmin,work( indwrk ), iwork( iindwk ), iinfo ) - if( iinfo/=0 ) then - info = 10 + abs( iinfo ) + if( iinfo/=0_${ik}$ ) then + info = 10_${ik}$ + abs( iinfo ) return end if - ! note that if range /= 'v', stdlib_dlarre computes bounds on the desired + ! note that if range /= 'v', stdlib${ii}$_dlarre computes bounds on the desired ! part of the spectrum. all desired eigenvalues are contained in ! (wl,wu] if( wantz ) then ! compute the desired eigenvectors corresponding to the computed ! eigenvalues - call stdlib_dlarrv( n, wl, wu, d, e,pivmin, iwork( iinspl ), m,1, m, minrgp, & + call stdlib${ii}$_dlarrv( n, wl, wu, d, e,pivmin, iwork( iinspl ), m,1_${ik}$, m, minrgp, & rtol1, rtol2,w, work( inderr ), work( indgp ), iwork( iindbl ),iwork( iindw ), & work( indgrs ), z, ldz,isuppz, work( indwrk ), iwork( iindwk ), iinfo ) - if( iinfo/=0 ) then - info = 20 + abs( iinfo ) + if( iinfo/=0_${ik}$ ) then + info = 20_${ik}$ + abs( iinfo ) return end if else - ! stdlib_dlarre computes eigenvalues of the (shifted) root representation - ! stdlib_dlarrv returns the eigenvalues of the unshifted matrix. + ! stdlib${ii}$_dlarre computes eigenvalues of the (shifted) root representation + ! stdlib${ii}$_dlarrv returns the eigenvalues of the unshifted matrix. ! however, if the eigenvectors are not desired by the user, we need - ! to apply the corresponding shifts from stdlib_dlarre to obtain the + ! to apply the corresponding shifts from stdlib${ii}$_dlarre to obtain the ! eigenvalues of the original matrix. do j = 1, m itmp = iwork( iindbl+j-1 ) @@ -84290,52 +84280,52 @@ module stdlib_linalg_lapack_d if ( tryrac ) then ! refine computed eigenvalues so that they are relatively accurate ! with respect to the original matrix t. - ibegin = 1 - wbegin = 1 + ibegin = 1_${ik}$ + wbegin = 1_${ik}$ loop_39: do jblk = 1, iwork( iindbl+m-1 ) iend = iwork( iinspl+jblk-1 ) - in = iend - ibegin + 1 - wend = wbegin - 1 + in = iend - ibegin + 1_${ik}$ + wend = wbegin - 1_${ik}$ ! check if any eigenvalues have to be refined in this block 36 continue if( wend1 .or. n==2 ) then + if( nsplit>1_${ik}$ .or. n==2_${ik}$ ) then if( .not. wantz ) then - call stdlib_dlasrt( 'I', m, w, iinfo ) - if( iinfo/=0 ) then - info = 3 + call stdlib${ii}$_dlasrt( 'I', m, w, iinfo ) + if( iinfo/=0_${ik}$ ) then + info = 3_${ik}$ return end if else do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp = w( j ) do jj = j + 1, m if( w( jj )0 .and. vu<=vl )info = -7 + if( n>0_${ik}$ .and. vu<=vl )info = -7_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -8 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -8_${ik}$ else if( iun ) then - info = -9 + info = -9_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz=d( 1 ) ) then - m = 1 - w( 1 ) = d( 1 ) + if( vl=d( 1_${ik}$ ) ) then + m = 1_${ik}$ + w( 1_${ik}$ ) = d( 1_${ik}$ ) end if end if - if( wantz )z( 1, 1 ) = one + if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one return end if ! get machine constants. - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) - eps = stdlib_dlamch( 'PRECISION' ) + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_dlamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) ) ! scale matrix to allowable range, if necessary. - iscale = 0 + iscale = 0_${ik}$ if( valeig ) then vll = vl vuu = vu end if - tnrm = stdlib_dlanst( 'M', n, d, e ) + tnrm = stdlib${ii}$_dlanst( 'M', n, d, e ) if( tnrm>zero .and. tnrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / tnrm end if - if( iscale==1 ) then - call stdlib_dscal( n, sigma, d, 1 ) - call stdlib_dscal( n-1, sigma, e( 1 ), 1 ) + if( iscale==1_${ik}$ ) then + call stdlib${ii}$_dscal( n, sigma, d, 1_${ik}$ ) + call stdlib${ii}$_dscal( n-1, sigma, e( 1_${ik}$ ), 1_${ik}$ ) if( valeig ) then vll = vl*sigma vuu = vu*sigma end if end if ! initialize indices into workspaces. note: these indices are used only - ! if stdlib_dsterf or stdlib_dstemr fail. - ! iwork(indibl:indibl+m-1) corresponds to iblock in stdlib_dstebz and + ! if stdlib${ii}$_dsterf or stdlib${ii}$_dstemr fail. + ! iwork(indibl:indibl+m-1) corresponds to iblock in stdlib${ii}$_dstebz and ! stores the block indices of each of the m<=n eigenvalues. - indibl = 1 - ! iwork(indisp:indisp+nsplit-1) corresponds to isplit in stdlib_dstebz and + indibl = 1_${ik}$ + ! iwork(indisp:indisp+nsplit-1) corresponds to isplit in stdlib${ii}$_dstebz and ! stores the starting and finishing indices of each block. indisp = indibl + n ! iwork(indifl:indifl+n-1) stores the indices of eigenvectors ! that corresponding to eigenvectors that fail to converge in - ! stdlib_dstein. this information is discarded; if any fail, the driver + ! stdlib${ii}$_dstein. this information is discarded; if any fail, the driver ! returns info > 0. indifl = indisp + n ! indiwo is the offset of the remaining integer workspace. indiwo = indisp + n ! if all eigenvalues are desired, then - ! call stdlib_dsterf or stdlib_dstemr. if this fails for some eigenvalue, then - ! try stdlib_dstebz. + ! call stdlib${ii}$_dsterf or stdlib${ii}$_dstemr. if this fails for some eigenvalue, then + ! try stdlib${ii}$_dstebz. test = .false. if( indeig ) then - if( il==1 .and. iu==n ) then + if( il==1_${ik}$ .and. iu==n ) then test = .true. end if end if - if( ( alleig .or. test ) .and. ieeeok==1 ) then - call stdlib_dcopy( n-1, e( 1 ), 1, work( 1 ), 1 ) + if( ( alleig .or. test ) .and. ieeeok==1_${ik}$ ) then + call stdlib${ii}$_dcopy( n-1, e( 1_${ik}$ ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) if( .not.wantz ) then - call stdlib_dcopy( n, d, 1, w, 1 ) - call stdlib_dsterf( n, w, work, info ) + call stdlib${ii}$_dcopy( n, d, 1_${ik}$, w, 1_${ik}$ ) + call stdlib${ii}$_dsterf( n, w, work, info ) else - call stdlib_dcopy( n, d, 1, work( n+1 ), 1 ) + call stdlib${ii}$_dcopy( n, d, 1_${ik}$, work( n+1 ), 1_${ik}$ ) if (abstol <= two*n*eps) then tryrac = .true. else tryrac = .false. end if - call stdlib_dstemr( jobz, 'A', n, work( n+1 ), work, vl, vu, il,iu, m, w, z, ldz,& - n, isuppz, tryrac,work( 2*n+1 ), lwork-2*n, iwork, liwork, info ) + call stdlib${ii}$_dstemr( jobz, 'A', n, work( n+1 ), work, vl, vu, il,iu, m, w, z, ldz,& + n, isuppz, tryrac,work( 2_${ik}$*n+1 ), lwork-2*n, iwork, liwork, info ) end if - if( info==0 ) then + if( info==0_${ik}$ ) then m = n go to 10 end if - info = 0 + info = 0_${ik}$ end if - ! otherwise, call stdlib_dstebz and, if eigenvectors are desired, stdlib_dstein. + ! otherwise, call stdlib${ii}$_dstebz and, if eigenvectors are desired, stdlib${ii}$_dstein. if( wantz ) then order = 'B' else order = 'E' end if - call stdlib_dstebz( range, order, n, vll, vuu, il, iu, abstol, d, e, m,nsplit, w, & + call stdlib${ii}$_dstebz( range, order, n, vll, vuu, il, iu, abstol, d, e, m,nsplit, w, & iwork( indibl ), iwork( indisp ), work,iwork( indiwo ), info ) if( wantz ) then - call stdlib_dstein( n, d, e, m, w, iwork( indibl ), iwork( indisp ),z, ldz, work, & + call stdlib${ii}$_dstein( n, d, e, m, w, iwork( indibl ), iwork( indisp ),z, ldz, work, & iwork( indiwo ), iwork( indifl ),info ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. 10 continue - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = m else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_dscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. if( wantz ) then do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp1 = w( j ) do jj = j + 1, m if( w( jj )0 .and. vu<=vl )info = -8 + if( n>0_${ik}$ .and. vu<=vl )info = -8_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -9 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -9_${ik}$ else if( iun ) then - info = -10 + info = -10_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz=a( 1, 1 ) ) then - m = 1 - w( 1 ) = a( 1, 1 ) + if( vl=a( 1_${ik}$, 1_${ik}$ ) ) then + m = 1_${ik}$ + w( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ ) end if end if if( wantz ) then - z( 1, 1 ) = one - isuppz( 1 ) = 1 - isuppz( 2 ) = 1 + z( 1_${ik}$, 1_${ik}$ ) = one + isuppz( 1_${ik}$ ) = 1_${ik}$ + isuppz( 2_${ik}$ ) = 1_${ik}$ end if return end if ! get machine constants. - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) - eps = stdlib_dlamch( 'PRECISION' ) + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_dlamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) ) ! scale matrix to allowable range, if necessary. - iscale = 0 + iscale = 0_${ik}$ abstll = abstol if (valeig) then vll = vl vuu = vu end if - anrm = stdlib_dlansy( 'M', uplo, n, a, lda, work ) + anrm = stdlib${ii}$_dlansy( 'M', uplo, n, a, lda, work ) if( anrm>zero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then do j = 1, n - call stdlib_dscal( n-j+1, sigma, a( j, j ), 1 ) + call stdlib${ii}$_dscal( n-j+1, sigma, a( j, j ), 1_${ik}$ ) end do else do j = 1, n - call stdlib_dscal( j, sigma, a( 1, j ), 1 ) + call stdlib${ii}$_dscal( j, sigma, a( 1_${ik}$, j ), 1_${ik}$ ) end do end if - if( abstol>0 )abstll = abstol*sigma + if( abstol>0_${ik}$ )abstll = abstol*sigma if( valeig ) then vll = vl*sigma vuu = vu*sigma end if end if ! initialize indices into workspaces. note: the iwork indices are - ! used only if stdlib_dsterf or stdlib_dstemr fail. + ! used only if stdlib${ii}$_dsterf or stdlib${ii}$_dstemr fail. ! work(indtau:indtau+n-1) stores the scalar factors of the - ! elementary reflectors used in stdlib_dsytrd. - indtau = 1 + ! elementary reflectors used in stdlib${ii}$_dsytrd. + indtau = 1_${ik}$ ! work(indd:indd+n-1) stores the tridiagonal's diagonal entries. indd = indtau + n ! work(inde:inde+n-1) stores the off-diagonal entries of the - ! tridiagonal matrix from stdlib_dsytrd. + ! tridiagonal matrix from stdlib${ii}$_dsytrd. inde = indd + n ! work(inddd:inddd+n-1) is a copy of the diagonal entries over - ! -written by stdlib_dstemr (the stdlib_dsterf path copies the diagonal to w). + ! -written by stdlib${ii}$_dstemr (the stdlib${ii}$_dsterf path copies the diagonal to w). inddd = inde + n ! work(indee:indee+n-1) is a copy of the off-diagonal entries over - ! -written while computing the eigenvalues in stdlib_dsterf and stdlib_dstemr. + ! -written while computing the eigenvalues in stdlib${ii}$_dsterf and stdlib${ii}$_dstemr. indee = inddd + n ! indwk is the starting offset of the left-over workspace, and ! llwork is the remaining workspace size. indwk = indee + n - llwork = lwork - indwk + 1 - ! iwork(indibl:indibl+m-1) corresponds to iblock in stdlib_dstebz and + llwork = lwork - indwk + 1_${ik}$ + ! iwork(indibl:indibl+m-1) corresponds to iblock in stdlib${ii}$_dstebz and ! stores the block indices of each of the m<=n eigenvalues. - indibl = 1 - ! iwork(indisp:indisp+nsplit-1) corresponds to isplit in stdlib_dstebz and + indibl = 1_${ik}$ + ! iwork(indisp:indisp+nsplit-1) corresponds to isplit in stdlib${ii}$_dstebz and ! stores the starting and finishing indices of each block. indisp = indibl + n ! iwork(indifl:indifl+n-1) stores the indices of eigenvectors ! that corresponding to eigenvectors that fail to converge in - ! stdlib_dstein. this information is discarded; if any fail, the driver + ! stdlib${ii}$_dstein. this information is discarded; if any fail, the driver ! returns info > 0. indifl = indisp + n ! indiwo is the offset of the remaining integer workspace. indiwo = indifl + n - ! call stdlib_dsytrd to reduce symmetric matrix to tridiagonal form. - call stdlib_dsytrd( uplo, n, a, lda, work( indd ), work( inde ),work( indtau ), work( & + ! call stdlib${ii}$_dsytrd to reduce symmetric matrix to tridiagonal form. + call stdlib${ii}$_dsytrd( uplo, n, a, lda, work( indd ), work( inde ),work( indtau ), work( & indwk ), llwork, iinfo ) ! if all eigenvalues are desired - ! then call stdlib_dsterf or stdlib_dstemr and stdlib_dormtr. - if( ( alleig .or. ( indeig .and. il==1 .and. iu==n ) ) .and.ieeeok==1 ) then + ! then call stdlib${ii}$_dsterf or stdlib${ii}$_dstemr and stdlib${ii}$_dormtr. + if( ( alleig .or. ( indeig .and. il==1_${ik}$ .and. iu==n ) ) .and.ieeeok==1_${ik}$ ) then if( .not.wantz ) then - call stdlib_dcopy( n, work( indd ), 1, w, 1 ) - call stdlib_dcopy( n-1, work( inde ), 1, work( indee ), 1 ) - call stdlib_dsterf( n, w, work( indee ), info ) + call stdlib${ii}$_dcopy( n, work( indd ), 1_${ik}$, w, 1_${ik}$ ) + call stdlib${ii}$_dcopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ ) + call stdlib${ii}$_dsterf( n, w, work( indee ), info ) else - call stdlib_dcopy( n-1, work( inde ), 1, work( indee ), 1 ) - call stdlib_dcopy( n, work( indd ), 1, work( inddd ), 1 ) + call stdlib${ii}$_dcopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ ) + call stdlib${ii}$_dcopy( n, work( indd ), 1_${ik}$, work( inddd ), 1_${ik}$ ) if (abstol <= two*n*eps) then tryrac = .true. else tryrac = .false. end if - call stdlib_dstemr( jobz, 'A', n, work( inddd ), work( indee ),vl, vu, il, iu, m,& + call stdlib${ii}$_dstemr( jobz, 'A', n, work( inddd ), work( indee ),vl, vu, il, iu, m,& w, z, ldz, n, isuppz,tryrac, work( indwk ), lwork, iwork, liwork,info ) ! apply orthogonal matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_dstemr. - if( wantz .and. info==0 ) then + ! form to eigenvectors returned by stdlib${ii}$_dstemr. + if( wantz .and. info==0_${ik}$ ) then indwkn = inde - llwrkn = lwork - indwkn + 1 - call stdlib_dormtr( 'L', uplo, 'N', n, m, a, lda,work( indtau ), z, ldz, work(& + llwrkn = lwork - indwkn + 1_${ik}$ + call stdlib${ii}$_dormtr( 'L', uplo, 'N', n, m, a, lda,work( indtau ), z, ldz, work(& indwkn ),llwrkn, iinfo ) end if end if - if( info==0 ) then - ! everything worked. skip stdlib_dstebz/stdlib_dstein. iwork(:) are + if( info==0_${ik}$ ) then + ! everything worked. skip stdlib${ii}$_dstebz/stdlib${ii}$_dstein. iwork(:) are ! undefined. m = n go to 30 end if - info = 0 + info = 0_${ik}$ end if - ! otherwise, call stdlib_dstebz and, if eigenvectors are desired, stdlib_dstein. - ! also call stdlib_dstebz and stdlib_dstein if stdlib_dstemr fails. + ! otherwise, call stdlib${ii}$_dstebz and, if eigenvectors are desired, stdlib${ii}$_dstein. + ! also call stdlib${ii}$_dstebz and stdlib${ii}$_dstein if stdlib${ii}$_dstemr fails. if( wantz ) then order = 'B' else order = 'E' end if - call stdlib_dstebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde & + call stdlib${ii}$_dstebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde & ), m, nsplit, w,iwork( indibl ), iwork( indisp ), work( indwk ),iwork( indiwo ), info ) if( wantz ) then - call stdlib_dstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & + call stdlib${ii}$_dstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,work( indwk ), iwork( indiwo ), iwork( indifl ),info ) ! apply orthogonal matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_dstein. + ! form to eigenvectors returned by stdlib${ii}$_dstein. indwkn = inde - llwrkn = lwork - indwkn + 1 - call stdlib_dormtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & + llwrkn = lwork - indwkn + 1_${ik}$ + call stdlib${ii}$_dormtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & indwkn ), llwrkn, iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - ! jump here if stdlib_dstemr/stdlib_dstein succeeded. + ! jump here if stdlib${ii}$_dstemr/stdlib${ii}$_dstein succeeded. 30 continue - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = m else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_dscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. note: we do not sort the ifail portion of iwork. - ! it may not be initialized (if stdlib_dstemr/stdlib_dstein succeeded), and we do + ! it may not be initialized (if stdlib${ii}$_dstemr/stdlib${ii}$_dstein succeeded), and we do ! not return this detailed information to the user. if( wantz ) then do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp1 = w( j ) do jj = j + 1, m if( w( jj )=n )go to 20 ! each step of the main loop @@ -85092,17 +85082,17 @@ module stdlib_linalg_lapack_d ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=1 for the first panel, and ! k1=0 for the rest - j1 = j + 1 + j1 = j + 1_${ik}$ jb = min( n-j1+1, nb ) - k1 = max(1, j)-j + k1 = max(1_${ik}$, j)-j ! panel factorization - call stdlib_dlasyf_aa( uplo, 2-k1, n-j, jb,a( max(1, j), j+1 ), lda,ipiv( j+1 ), & + call stdlib${ii}$_dlasyf_aa( uplo, 2_${ik}$-k1, n-j, jb,a( max(1_${ik}$, j), j+1 ), lda,ipiv( j+1 ), & work, n, work( n*nb+1 ) ) ! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot) do j2 = j+2, min(n, j+jb+1) ipiv( j2 ) = ipiv( j2 ) + j - if( (j2/=ipiv(j2)) .and. ((j1-k1)>2) ) then - call stdlib_dswap( j1-k1-2, a( 1, j2 ), 1,a( 1, ipiv(j2) ), 1 ) + if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then + call stdlib${ii}$_dswap( j1-k1-2, a( 1_${ik}$, j2 ), 1_${ik}$,a( 1_${ik}$, ipiv(j2) ), 1_${ik}$ ) end if end do j = j + jb @@ -85111,43 +85101,43 @@ module stdlib_linalg_lapack_d ! work stores the current block of the auxiriarly matrix h if( j1 .or. jb>1 ) then + if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then ! merge rank-1 update with blas-3 update alpha = a( j, j+1 ) a( j, j+1 ) = one - call stdlib_dcopy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib${ii}$_dcopy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) - call stdlib_dscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib${ii}$_dscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=1 and k2= 0 for the first panel, ! while k1=0 and k2=1 for the rest - if( j1>1 ) then + if( j1>1_${ik}$ ) then ! not first panel - k2 = 1 + k2 = 1_${ik}$ else ! first panel - k2 = 0 + k2 = 0_${ik}$ ! first update skips the first column - jb = jb - 1 + jb = jb - 1_${ik}$ end if do j2 = j+1, n, nb nj = min( nb, n-j2+1 ) - ! update (j2, j2) diagonal block with stdlib_dgemv + ! update (j2, j2) diagonal block with stdlib${ii}$_dgemv j3 = j2 do mj = nj-1, 1, -1 - call stdlib_dgemv( 'NO TRANSPOSE', mj, jb+1,-one, work( j3-j1+1+k1*n ), & - n,a( j1-k2, j3 ), 1,one, a( j3, j3 ), lda ) - j3 = j3 + 1 + call stdlib${ii}$_dgemv( 'NO TRANSPOSE', mj, jb+1,-one, work( j3-j1+1+k1*n ), & + n,a( j1-k2, j3 ), 1_${ik}$,one, a( j3, j3 ), lda ) + j3 = j3 + 1_${ik}$ end do - ! update off-diagonal block of j2-th block row with stdlib_dgemm - call stdlib_dgemm( 'TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-one, a( j1-& + ! update off-diagonal block of j2-th block row with stdlib${ii}$_dgemm + call stdlib${ii}$_dgemm( 'TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-one, a( j1-& k2, j2 ), lda,work( j3-j1+1+k1*n ), n,one, a( j2, j3 ), lda ) end do ! recover t( j, j+1 ) a( j, j+1 ) = alpha end if ! work(j+1, 1) stores h(j+1, 1) - call stdlib_dcopy( n-j, a( j+1, j+1 ), lda, work( 1 ), 1 ) + call stdlib${ii}$_dcopy( n-j, a( j+1, j+1 ), lda, work( 1_${ik}$ ), 1_${ik}$ ) end if go to 10 else @@ -85156,11 +85146,11 @@ module stdlib_linalg_lapack_d ! ..................................................... ! copy first column a(1:n, 1) into h(1:n, 1) ! (stored in work(1:n)) - call stdlib_dcopy( n, a( 1, 1 ), 1, work( 1 ), 1 ) + call stdlib${ii}$_dcopy( n, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) ! j is the main loop index, increasing from 1 to n in steps of - ! jb, where jb is the number of columns factorized by stdlib_dlasyf; + ! jb, where jb is the number of columns factorized by stdlib${ii}$_dlasyf; ! jb is either nb, or n-j+1 for the last block - j = 0 + j = 0_${ik}$ 11 continue if( j>=n )go to 20 ! each step of the main loop @@ -85171,15 +85161,15 @@ module stdlib_linalg_lapack_d ! k1=0 for the rest j1 = j+1 jb = min( n-j1+1, nb ) - k1 = max(1, j)-j + k1 = max(1_${ik}$, j)-j ! panel factorization - call stdlib_dlasyf_aa( uplo, 2-k1, n-j, jb,a( j+1, max(1, j) ), lda,ipiv( j+1 ), & + call stdlib${ii}$_dlasyf_aa( uplo, 2_${ik}$-k1, n-j, jb,a( j+1, max(1_${ik}$, j) ), lda,ipiv( j+1 ), & work, n, work( n*nb+1 ) ) ! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot) do j2 = j+2, min(n, j+jb+1) ipiv( j2 ) = ipiv( j2 ) + j - if( (j2/=ipiv(j2)) .and. ((j1-k1)>2) ) then - call stdlib_dswap( j1-k1-2, a( j2, 1 ), lda,a( ipiv(j2), 1 ), lda ) + if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then + call stdlib${ii}$_dswap( j1-k1-2, a( j2, 1_${ik}$ ), lda,a( ipiv(j2), 1_${ik}$ ), lda ) end if end do j = j + jb @@ -85188,50 +85178,50 @@ module stdlib_linalg_lapack_d ! work(j2+1, 1) stores h(j2+1, 1) if( j1 .or. jb>1 ) then + if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then ! merge rank-1 update with blas-3 update alpha = a( j+1, j ) a( j+1, j ) = one - call stdlib_dcopy( n-j, a( j+1, j-1 ), 1,work( (j+1-j1+1)+jb*n ), 1 ) - call stdlib_dscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib${ii}$_dcopy( n-j, a( j+1, j-1 ), 1_${ik}$,work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) + call stdlib${ii}$_dscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=1 and k2= 0 for the first panel, ! while k1=0 and k2=1 for the rest - if( j1>1 ) then + if( j1>1_${ik}$ ) then ! not first panel - k2 = 1 + k2 = 1_${ik}$ else ! first panel - k2 = 0 + k2 = 0_${ik}$ ! first update skips the first column - jb = jb - 1 + jb = jb - 1_${ik}$ end if do j2 = j+1, n, nb nj = min( nb, n-j2+1 ) - ! update (j2, j2) diagonal block with stdlib_dgemv + ! update (j2, j2) diagonal block with stdlib${ii}$_dgemv j3 = j2 do mj = nj-1, 1, -1 - call stdlib_dgemv( 'NO TRANSPOSE', mj, jb+1,-one, work( j3-j1+1+k1*n ), & - n,a( j3, j1-k2 ), lda,one, a( j3, j3 ), 1 ) - j3 = j3 + 1 + call stdlib${ii}$_dgemv( 'NO TRANSPOSE', mj, jb+1,-one, work( j3-j1+1+k1*n ), & + n,a( j3, j1-k2 ), lda,one, a( j3, j3 ), 1_${ik}$ ) + j3 = j3 + 1_${ik}$ end do - ! update off-diagonal block in j2-th block column with stdlib_dgemm - call stdlib_dgemm( 'NO TRANSPOSE', 'TRANSPOSE',n-j3+1, nj, jb+1,-one, work(& + ! update off-diagonal block in j2-th block column with stdlib${ii}$_dgemm + call stdlib${ii}$_dgemm( 'NO TRANSPOSE', 'TRANSPOSE',n-j3+1, nj, jb+1,-one, work(& j3-j1+1+k1*n ), n,a( j2, j1-k2 ), lda,one, a( j3, j2 ), lda ) end do ! recover t( j+1, j ) a( j+1, j ) = alpha end if ! work(j+1, 1) stores h(j+1, 1) - call stdlib_dcopy( n-j, a( j+1, j+1 ), 1, work( 1 ), 1 ) + call stdlib${ii}$_dcopy( n-j, a( j+1, j+1 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) end if go to 11 end if 20 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_dsytrf_aa - + end subroutine stdlib${ii}$_dsytrf_aa + #:endfor end module stdlib_linalg_lapack_d diff --git a/src/stdlib_linalg_lapack_q.fypp b/src/stdlib_linalg_lapack_q.fypp index 2b820687a..1458c9bb7 100644 --- a/src/stdlib_linalg_lapack_q.fypp +++ b/src/stdlib_linalg_lapack_q.fypp @@ -13,476 +13,478 @@ module stdlib_linalg_lapack_${ri}$ private - public :: sp,dp,${rk}$,lk,ilp - public :: stdlib_${ri}$bbcsd - public :: stdlib_${ri}$bdsdc - public :: stdlib_${ri}$bdsqr - public :: stdlib_${ri}$disna - public :: stdlib_${ri}$gbbrd - public :: stdlib_${ri}$gbcon - public :: stdlib_${ri}$gbequ - public :: stdlib_${ri}$gbequb - public :: stdlib_${ri}$gbrfs - public :: stdlib_${ri}$gbsv - public :: stdlib_${ri}$gbsvx - public :: stdlib_${ri}$gbtf2 - public :: stdlib_${ri}$gbtrf - public :: stdlib_${ri}$gbtrs - public :: stdlib_${ri}$gebak - public :: stdlib_${ri}$gebal - public :: stdlib_${ri}$gebd2 - public :: stdlib_${ri}$gebrd - public :: stdlib_${ri}$gecon - public :: stdlib_${ri}$geequ - public :: stdlib_${ri}$geequb - public :: stdlib_${ri}$gees - public :: stdlib_${ri}$geesx - public :: stdlib_${ri}$geev - public :: stdlib_${ri}$geevx - public :: stdlib_${ri}$gehd2 - public :: stdlib_${ri}$gehrd - public :: stdlib_${ri}$gejsv - public :: stdlib_${ri}$gelq - public :: stdlib_${ri}$gelq2 - public :: stdlib_${ri}$gelqf - public :: stdlib_${ri}$gelqt - public :: stdlib_${ri}$gelqt3 - public :: stdlib_${ri}$gels - public :: stdlib_${ri}$gelsd - public :: stdlib_${ri}$gelss - public :: stdlib_${ri}$gelsy - public :: stdlib_${ri}$gemlq - public :: stdlib_${ri}$gemlqt - public :: stdlib_${ri}$gemqr - public :: stdlib_${ri}$gemqrt - public :: stdlib_${ri}$geql2 - public :: stdlib_${ri}$geqlf - public :: stdlib_${ri}$geqp3 - public :: stdlib_${ri}$geqr - public :: stdlib_${ri}$geqr2 - public :: stdlib_${ri}$geqr2p - public :: stdlib_${ri}$geqrf - public :: stdlib_${ri}$geqrfp - public :: stdlib_${ri}$geqrt - public :: stdlib_${ri}$geqrt2 - public :: stdlib_${ri}$geqrt3 - public :: stdlib_${ri}$gerfs - public :: stdlib_${ri}$gerq2 - public :: stdlib_${ri}$gerqf - public :: stdlib_${ri}$gesc2 - public :: stdlib_${ri}$gesdd - public :: stdlib_${ri}$gesv - public :: stdlib_${ri}$gesvd - public :: stdlib_${ri}$gesvdq - public :: stdlib_${ri}$gesvj - public :: stdlib_${ri}$gesvx - public :: stdlib_${ri}$getc2 - public :: stdlib_${ri}$getf2 - public :: stdlib_${ri}$getrf - public :: stdlib_${ri}$getrf2 - public :: stdlib_${ri}$getri - public :: stdlib_${ri}$getrs - public :: stdlib_${ri}$getsls - public :: stdlib_${ri}$getsqrhrt - public :: stdlib_${ri}$ggbak - public :: stdlib_${ri}$ggbal - public :: stdlib_${ri}$gges - public :: stdlib_${ri}$gges3 - public :: stdlib_${ri}$ggesx - public :: stdlib_${ri}$ggev - public :: stdlib_${ri}$ggev3 - public :: stdlib_${ri}$ggevx - public :: stdlib_${ri}$ggglm - public :: stdlib_${ri}$gghd3 - public :: stdlib_${ri}$gghrd - public :: stdlib_${ri}$gglse - public :: stdlib_${ri}$ggqrf - public :: stdlib_${ri}$ggrqf - public :: stdlib_${ri}$gsvj0 - public :: stdlib_${ri}$gsvj1 - public :: stdlib_${ri}$gtcon - public :: stdlib_${ri}$gtrfs - public :: stdlib_${ri}$gtsv - public :: stdlib_${ri}$gtsvx - public :: stdlib_${ri}$gttrf - public :: stdlib_${ri}$gttrs - public :: stdlib_${ri}$gtts2 - public :: stdlib_${ri}$hgeqz - public :: stdlib_${ri}$hsein - public :: stdlib_${ri}$hseqr - public :: stdlib_${ri}$isnan - public :: stdlib_${ri}$la_gbamv - public :: stdlib_${ri}$la_gbrcond - public :: stdlib_${ri}$la_gbrpvgrw - public :: stdlib_${ri}$la_geamv - public :: stdlib_${ri}$la_gercond - public :: stdlib_${ri}$la_gerpvgrw - public :: stdlib_${ri}$la_lin_berr - public :: stdlib_${ri}$la_porcond - public :: stdlib_${ri}$la_porpvgrw - public :: stdlib_${ri}$la_syamv - public :: stdlib_${ri}$la_syrcond - public :: stdlib_${ri}$la_syrpvgrw - public :: stdlib_${ri}$la_wwaddw - public :: stdlib_${ri}$labad - public :: stdlib_${ri}$labrd - public :: stdlib_${ri}$lacn2 - public :: stdlib_${ri}$lacon - public :: stdlib_${ri}$lacpy - public :: stdlib_${ri}$ladiv - public :: stdlib_${ri}$ladiv1 - public :: stdlib_${ri}$ladiv2 - public :: stdlib_${ri}$lae2 - public :: stdlib_${ri}$laebz - public :: stdlib_${ri}$laed0 - public :: stdlib_${ri}$laed1 - public :: stdlib_${ri}$laed2 - public :: stdlib_${ri}$laed3 - public :: stdlib_${ri}$laed4 - public :: stdlib_${ri}$laed5 - public :: stdlib_${ri}$laed6 - public :: stdlib_${ri}$laed7 - public :: stdlib_${ri}$laed8 - public :: stdlib_${ri}$laed9 - public :: stdlib_${ri}$laeda - public :: stdlib_${ri}$laein - public :: stdlib_${ri}$laev2 - public :: stdlib_${ri}$laexc - public :: stdlib_${ri}$lag2 - public :: stdlib_${ri}$lag2s - public :: stdlib_dlag2${ri}$ - public :: stdlib_${ri}$lags2 - public :: stdlib_${ri}$lagtf - public :: stdlib_${ri}$lagtm - public :: stdlib_${ri}$lagts - public :: stdlib_${ri}$lagv2 - public :: stdlib_${ri}$lahqr - public :: stdlib_${ri}$lahr2 - public :: stdlib_${ri}$laic1 - public :: stdlib_${ri}$laisnan - public :: stdlib_${ri}$laln2 - public :: stdlib_${ri}$lals0 - public :: stdlib_${ri}$lalsa - public :: stdlib_${ri}$lalsd - public :: stdlib_${ri}$lamch - public :: stdlib_${ri}$lamc3 - public :: stdlib_${ri}$lamrg - public :: stdlib_${ri}$lamswlq - public :: stdlib_${ri}$lamtsqr - public :: stdlib_${ri}$laneg - public :: stdlib_${ri}$langb - public :: stdlib_${ri}$lange - public :: stdlib_${ri}$langt - public :: stdlib_${ri}$lanhs - public :: stdlib_${ri}$lansb - public :: stdlib_${ri}$lansf - public :: stdlib_${ri}$lansp - public :: stdlib_${ri}$lanst - public :: stdlib_${ri}$lansy - public :: stdlib_${ri}$lantb - public :: stdlib_${ri}$lantp - public :: stdlib_${ri}$lantr - public :: stdlib_${ri}$lanv2 - public :: stdlib_${ri}$laorhr_col_getrfnp - public :: stdlib_${ri}$laorhr_col_getrfnp2 - public :: stdlib_${ri}$lapll - public :: stdlib_${ri}$lapmr - public :: stdlib_${ri}$lapmt - public :: stdlib_${ri}$lapy2 - public :: stdlib_${ri}$lapy3 - public :: stdlib_${ri}$laqgb - public :: stdlib_${ri}$laqge - public :: stdlib_${ri}$laqp2 - public :: stdlib_${ri}$laqps - public :: stdlib_${ri}$laqr0 - public :: stdlib_${ri}$laqr1 - public :: stdlib_${ri}$laqr2 - public :: stdlib_${ri}$laqr3 - public :: stdlib_${ri}$laqr4 - public :: stdlib_${ri}$laqr5 - public :: stdlib_${ri}$laqsb - public :: stdlib_${ri}$laqsp - public :: stdlib_${ri}$laqsy - public :: stdlib_${ri}$laqtr - public :: stdlib_${ri}$laqz0 - public :: stdlib_${ri}$laqz1 - public :: stdlib_${ri}$laqz2 - public :: stdlib_${ri}$laqz3 - public :: stdlib_${ri}$laqz4 - public :: stdlib_${ri}$lar1v - public :: stdlib_${ri}$lar2v - public :: stdlib_${ri}$larf - public :: stdlib_${ri}$larfb - public :: stdlib_${ri}$larfb_gett - public :: stdlib_${ri}$larfg - public :: stdlib_${ri}$larfgp - public :: stdlib_${ri}$larft - public :: stdlib_${ri}$larfx - public :: stdlib_${ri}$larfy - public :: stdlib_${ri}$largv - public :: stdlib_${ri}$larnv - public :: stdlib_${ri}$larra - public :: stdlib_${ri}$larrb - public :: stdlib_${ri}$larrc - public :: stdlib_${ri}$larrd - public :: stdlib_${ri}$larre - public :: stdlib_${ri}$larrf - public :: stdlib_${ri}$larrj - public :: stdlib_${ri}$larrk - public :: stdlib_${ri}$larrr - public :: stdlib_${ri}$larrv - public :: stdlib_${ri}$lartg - public :: stdlib_${ri}$lartgp - public :: stdlib_${ri}$lartgs - public :: stdlib_${ri}$lartv - public :: stdlib_${ri}$laruv - public :: stdlib_${ri}$larz - public :: stdlib_${ri}$larzb - public :: stdlib_${ri}$larzt - public :: stdlib_${ri}$las2 - public :: stdlib_${ri}$lascl - public :: stdlib_${ri}$lasd0 - public :: stdlib_${ri}$lasd1 - public :: stdlib_${ri}$lasd2 - public :: stdlib_${ri}$lasd3 - public :: stdlib_${ri}$lasd4 - public :: stdlib_${ri}$lasd5 - public :: stdlib_${ri}$lasd6 - public :: stdlib_${ri}$lasd7 - public :: stdlib_${ri}$lasd8 - public :: stdlib_${ri}$lasda - public :: stdlib_${ri}$lasdq - public :: stdlib_${ri}$lasdt - public :: stdlib_${ri}$laset - public :: stdlib_${ri}$lasq1 - public :: stdlib_${ri}$lasq2 - public :: stdlib_${ri}$lasq3 - public :: stdlib_${ri}$lasq4 - public :: stdlib_${ri}$lasq5 - public :: stdlib_${ri}$lasq6 - public :: stdlib_${ri}$lasr - public :: stdlib_${ri}$lasrt - public :: stdlib_${ri}$lassq - public :: stdlib_${ri}$lasv2 - public :: stdlib_${ri}$laswlq - public :: stdlib_${ri}$laswp - public :: stdlib_${ri}$lasy2 - public :: stdlib_${ri}$lasyf - public :: stdlib_${ri}$lasyf_aa - public :: stdlib_${ri}$lasyf_rk - public :: stdlib_${ri}$lasyf_rook - public :: stdlib_${ri}$lat2s - public :: stdlib_${ri}$latbs - public :: stdlib_${ri}$latdf - public :: stdlib_${ri}$latps - public :: stdlib_${ri}$latrd - public :: stdlib_${ri}$latrs - public :: stdlib_${ri}$latrz - public :: stdlib_${ri}$latsqr - public :: stdlib_${ri}$lauu2 - public :: stdlib_${ri}$lauum - public :: stdlib_${ri}$opgtr - public :: stdlib_${ri}$opmtr - public :: stdlib_${ri}$orbdb - public :: stdlib_${ri}$orbdb1 - public :: stdlib_${ri}$orbdb2 - public :: stdlib_${ri}$orbdb3 - public :: stdlib_${ri}$orbdb4 - public :: stdlib_${ri}$orbdb5 - public :: stdlib_${ri}$orbdb6 - public :: stdlib_${ri}$orcsd - public :: stdlib_${ri}$orcsd2by1 - public :: stdlib_${ri}$org2l - public :: stdlib_${ri}$org2r - public :: stdlib_${ri}$orgbr - public :: stdlib_${ri}$orghr - public :: stdlib_${ri}$orgl2 - public :: stdlib_${ri}$orglq - public :: stdlib_${ri}$orgql - public :: stdlib_${ri}$orgqr - public :: stdlib_${ri}$orgr2 - public :: stdlib_${ri}$orgrq - public :: stdlib_${ri}$orgtr - public :: stdlib_${ri}$orgtsqr - public :: stdlib_${ri}$orgtsqr_row - public :: stdlib_${ri}$orhr_col - public :: stdlib_${ri}$orm22 - public :: stdlib_${ri}$orm2l - public :: stdlib_${ri}$orm2r - public :: stdlib_${ri}$ormbr - public :: stdlib_${ri}$ormhr - public :: stdlib_${ri}$orml2 - public :: stdlib_${ri}$ormlq - public :: stdlib_${ri}$ormql - public :: stdlib_${ri}$ormqr - public :: stdlib_${ri}$ormr2 - public :: stdlib_${ri}$ormr3 - public :: stdlib_${ri}$ormrq - public :: stdlib_${ri}$ormrz - public :: stdlib_${ri}$ormtr - public :: stdlib_${ri}$pbcon - public :: stdlib_${ri}$pbequ - public :: stdlib_${ri}$pbrfs - public :: stdlib_${ri}$pbstf - public :: stdlib_${ri}$pbsv - public :: stdlib_${ri}$pbsvx - public :: stdlib_${ri}$pbtf2 - public :: stdlib_${ri}$pbtrf - public :: stdlib_${ri}$pbtrs - public :: stdlib_${ri}$pftrf - public :: stdlib_${ri}$pftri - public :: stdlib_${ri}$pftrs - public :: stdlib_${ri}$pocon - public :: stdlib_${ri}$poequ - public :: stdlib_${ri}$poequb - public :: stdlib_${ri}$porfs - public :: stdlib_${ri}$posv - public :: stdlib_${ri}$posvx - public :: stdlib_${ri}$potf2 - public :: stdlib_${ri}$potrf - public :: stdlib_${ri}$potrf2 - public :: stdlib_${ri}$potri - public :: stdlib_${ri}$potrs - public :: stdlib_${ri}$ppcon - public :: stdlib_${ri}$ppequ - public :: stdlib_${ri}$pprfs - public :: stdlib_${ri}$ppsv - public :: stdlib_${ri}$ppsvx - public :: stdlib_${ri}$pptrf - public :: stdlib_${ri}$pptri - public :: stdlib_${ri}$pptrs - public :: stdlib_${ri}$pstf2 - public :: stdlib_${ri}$pstrf - public :: stdlib_${ri}$ptcon - public :: stdlib_${ri}$pteqr - public :: stdlib_${ri}$ptrfs - public :: stdlib_${ri}$ptsv - public :: stdlib_${ri}$ptsvx - public :: stdlib_${ri}$pttrf - public :: stdlib_${ri}$pttrs - public :: stdlib_${ri}$ptts2 - public :: stdlib_${ri}$rscl - public :: stdlib_${ri}$sb2st_kernels - public :: stdlib_${ri}$sbev - public :: stdlib_${ri}$sbevd - public :: stdlib_${ri}$sbevx - public :: stdlib_${ri}$sbgst - public :: stdlib_${ri}$sbgv - public :: stdlib_${ri}$sbgvd - public :: stdlib_${ri}$sbgvx - public :: stdlib_${ri}$sbtrd - public :: stdlib_${ri}$sfrk - public :: stdlib_${ri}$sgesv - public :: stdlib_${ri}$spcon - public :: stdlib_${ri}$spev - public :: stdlib_${ri}$spevd - public :: stdlib_${ri}$spevx - public :: stdlib_${ri}$spgst - public :: stdlib_${ri}$spgv - public :: stdlib_${ri}$spgvd - public :: stdlib_${ri}$spgvx - public :: stdlib_${ri}$sposv - public :: stdlib_${ri}$sprfs - public :: stdlib_${ri}$spsv - public :: stdlib_${ri}$spsvx - public :: stdlib_${ri}$sptrd - public :: stdlib_${ri}$sptrf - public :: stdlib_${ri}$sptri - public :: stdlib_${ri}$sptrs - public :: stdlib_${ri}$stebz - public :: stdlib_${ri}$stedc - public :: stdlib_${ri}$stegr - public :: stdlib_${ri}$stein - public :: stdlib_${ri}$stemr - public :: stdlib_${ri}$steqr - public :: stdlib_${ri}$sterf - public :: stdlib_${ri}$stev - public :: stdlib_${ri}$stevd - public :: stdlib_${ri}$stevr - public :: stdlib_${ri}$stevx - public :: stdlib_${ri}$sycon - public :: stdlib_${ri}$sycon_rook - public :: stdlib_${ri}$syconv - public :: stdlib_${ri}$syconvf - public :: stdlib_${ri}$syconvf_rook - public :: stdlib_${ri}$syequb - public :: stdlib_${ri}$syev - public :: stdlib_${ri}$syevd - public :: stdlib_${ri}$syevr - public :: stdlib_${ri}$syevx - public :: stdlib_${ri}$sygs2 - public :: stdlib_${ri}$sygst - public :: stdlib_${ri}$sygv - public :: stdlib_${ri}$sygvd - public :: stdlib_${ri}$sygvx - public :: stdlib_${ri}$syrfs - public :: stdlib_${ri}$sysv - public :: stdlib_${ri}$sysv_aa - public :: stdlib_${ri}$sysv_rk - public :: stdlib_${ri}$sysv_rook - public :: stdlib_${ri}$sysvx - public :: stdlib_${ri}$syswapr - public :: stdlib_${ri}$sytd2 - public :: stdlib_${ri}$sytf2 - public :: stdlib_${ri}$sytf2_rk - public :: stdlib_${ri}$sytf2_rook - public :: stdlib_${ri}$sytrd - public :: stdlib_${ri}$sytrd_sb2st - public :: stdlib_${ri}$sytrd_sy2sb - public :: stdlib_${ri}$sytrf - public :: stdlib_${ri}$sytrf_aa - public :: stdlib_${ri}$sytrf_rk - public :: stdlib_${ri}$sytrf_rook - public :: stdlib_${ri}$sytri - public :: stdlib_${ri}$sytri_rook - public :: stdlib_${ri}$sytrs - public :: stdlib_${ri}$sytrs2 - public :: stdlib_${ri}$sytrs_3 - public :: stdlib_${ri}$sytrs_aa - public :: stdlib_${ri}$sytrs_rook - public :: stdlib_${ri}$tbcon - public :: stdlib_${ri}$tbrfs - public :: stdlib_${ri}$tbtrs - public :: stdlib_${ri}$tfsm - public :: stdlib_${ri}$tftri - public :: stdlib_${ri}$tfttp - public :: stdlib_${ri}$tfttr - public :: stdlib_${ri}$tgevc - public :: stdlib_${ri}$tgex2 - public :: stdlib_${ri}$tgexc - public :: stdlib_${ri}$tgsen - public :: stdlib_${ri}$tgsja - public :: stdlib_${ri}$tgsna - public :: stdlib_${ri}$tgsy2 - public :: stdlib_${ri}$tgsyl - public :: stdlib_${ri}$tpcon - public :: stdlib_${ri}$tplqt - public :: stdlib_${ri}$tplqt2 - public :: stdlib_${ri}$tpmlqt - public :: stdlib_${ri}$tpmqrt - public :: stdlib_${ri}$tpqrt - public :: stdlib_${ri}$tpqrt2 - public :: stdlib_${ri}$tprfb - public :: stdlib_${ri}$tprfs - public :: stdlib_${ri}$tptri - public :: stdlib_${ri}$tptrs - public :: stdlib_${ri}$tpttf - public :: stdlib_${ri}$tpttr - public :: stdlib_${ri}$trcon - public :: stdlib_${ri}$trevc - public :: stdlib_${ri}$trevc3 - public :: stdlib_${ri}$trexc - public :: stdlib_${ri}$trrfs - public :: stdlib_${ri}$trsen - public :: stdlib_${ri}$trsna - public :: stdlib_${ri}$trsyl - public :: stdlib_${ri}$trti2 - public :: stdlib_${ri}$trtri - public :: stdlib_${ri}$trtrs - public :: stdlib_${ri}$trttf - public :: stdlib_${ri}$trttp - public :: stdlib_${ri}$tzrzf - public :: stdlib_${ri}$zsum1 + public :: sp,dp,${rk}$,lk,ilp,ilp64 + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + public :: stdlib${ii}$_${ri}$bbcsd + public :: stdlib${ii}$_${ri}$bdsdc + public :: stdlib${ii}$_${ri}$bdsqr + public :: stdlib${ii}$_${ri}$disna + public :: stdlib${ii}$_${ri}$gbbrd + public :: stdlib${ii}$_${ri}$gbcon + public :: stdlib${ii}$_${ri}$gbequ + public :: stdlib${ii}$_${ri}$gbequb + public :: stdlib${ii}$_${ri}$gbrfs + public :: stdlib${ii}$_${ri}$gbsv + public :: stdlib${ii}$_${ri}$gbsvx + public :: stdlib${ii}$_${ri}$gbtf2 + public :: stdlib${ii}$_${ri}$gbtrf + public :: stdlib${ii}$_${ri}$gbtrs + public :: stdlib${ii}$_${ri}$gebak + public :: stdlib${ii}$_${ri}$gebal + public :: stdlib${ii}$_${ri}$gebd2 + public :: stdlib${ii}$_${ri}$gebrd + public :: stdlib${ii}$_${ri}$gecon + public :: stdlib${ii}$_${ri}$geequ + public :: stdlib${ii}$_${ri}$geequb + public :: stdlib${ii}$_${ri}$gees + public :: stdlib${ii}$_${ri}$geesx + public :: stdlib${ii}$_${ri}$geev + public :: stdlib${ii}$_${ri}$geevx + public :: stdlib${ii}$_${ri}$gehd2 + public :: stdlib${ii}$_${ri}$gehrd + public :: stdlib${ii}$_${ri}$gejsv + public :: stdlib${ii}$_${ri}$gelq + public :: stdlib${ii}$_${ri}$gelq2 + public :: stdlib${ii}$_${ri}$gelqf + public :: stdlib${ii}$_${ri}$gelqt + public :: stdlib${ii}$_${ri}$gelqt3 + public :: stdlib${ii}$_${ri}$gels + public :: stdlib${ii}$_${ri}$gelsd + public :: stdlib${ii}$_${ri}$gelss + public :: stdlib${ii}$_${ri}$gelsy + public :: stdlib${ii}$_${ri}$gemlq + public :: stdlib${ii}$_${ri}$gemlqt + public :: stdlib${ii}$_${ri}$gemqr + public :: stdlib${ii}$_${ri}$gemqrt + public :: stdlib${ii}$_${ri}$geql2 + public :: stdlib${ii}$_${ri}$geqlf + public :: stdlib${ii}$_${ri}$geqp3 + public :: stdlib${ii}$_${ri}$geqr + public :: stdlib${ii}$_${ri}$geqr2 + public :: stdlib${ii}$_${ri}$geqr2p + public :: stdlib${ii}$_${ri}$geqrf + public :: stdlib${ii}$_${ri}$geqrfp + public :: stdlib${ii}$_${ri}$geqrt + public :: stdlib${ii}$_${ri}$geqrt2 + public :: stdlib${ii}$_${ri}$geqrt3 + public :: stdlib${ii}$_${ri}$gerfs + public :: stdlib${ii}$_${ri}$gerq2 + public :: stdlib${ii}$_${ri}$gerqf + public :: stdlib${ii}$_${ri}$gesc2 + public :: stdlib${ii}$_${ri}$gesdd + public :: stdlib${ii}$_${ri}$gesv + public :: stdlib${ii}$_${ri}$gesvd + public :: stdlib${ii}$_${ri}$gesvdq + public :: stdlib${ii}$_${ri}$gesvj + public :: stdlib${ii}$_${ri}$gesvx + public :: stdlib${ii}$_${ri}$getc2 + public :: stdlib${ii}$_${ri}$getf2 + public :: stdlib${ii}$_${ri}$getrf + public :: stdlib${ii}$_${ri}$getrf2 + public :: stdlib${ii}$_${ri}$getri + public :: stdlib${ii}$_${ri}$getrs + public :: stdlib${ii}$_${ri}$getsls + public :: stdlib${ii}$_${ri}$getsqrhrt + public :: stdlib${ii}$_${ri}$ggbak + public :: stdlib${ii}$_${ri}$ggbal + public :: stdlib${ii}$_${ri}$gges + public :: stdlib${ii}$_${ri}$gges3 + public :: stdlib${ii}$_${ri}$ggesx + public :: stdlib${ii}$_${ri}$ggev + public :: stdlib${ii}$_${ri}$ggev3 + public :: stdlib${ii}$_${ri}$ggevx + public :: stdlib${ii}$_${ri}$ggglm + public :: stdlib${ii}$_${ri}$gghd3 + public :: stdlib${ii}$_${ri}$gghrd + public :: stdlib${ii}$_${ri}$gglse + public :: stdlib${ii}$_${ri}$ggqrf + public :: stdlib${ii}$_${ri}$ggrqf + public :: stdlib${ii}$_${ri}$gsvj0 + public :: stdlib${ii}$_${ri}$gsvj1 + public :: stdlib${ii}$_${ri}$gtcon + public :: stdlib${ii}$_${ri}$gtrfs + public :: stdlib${ii}$_${ri}$gtsv + public :: stdlib${ii}$_${ri}$gtsvx + public :: stdlib${ii}$_${ri}$gttrf + public :: stdlib${ii}$_${ri}$gttrs + public :: stdlib${ii}$_${ri}$gtts2 + public :: stdlib${ii}$_${ri}$hgeqz + public :: stdlib${ii}$_${ri}$hsein + public :: stdlib${ii}$_${ri}$hseqr + public :: stdlib${ii}$_${ri}$isnan + public :: stdlib${ii}$_${ri}$la_gbamv + public :: stdlib${ii}$_${ri}$la_gbrcond + public :: stdlib${ii}$_${ri}$la_gbrpvgrw + public :: stdlib${ii}$_${ri}$la_geamv + public :: stdlib${ii}$_${ri}$la_gercond + public :: stdlib${ii}$_${ri}$la_gerpvgrw + public :: stdlib${ii}$_${ri}$la_lin_berr + public :: stdlib${ii}$_${ri}$la_porcond + public :: stdlib${ii}$_${ri}$la_porpvgrw + public :: stdlib${ii}$_${ri}$la_syamv + public :: stdlib${ii}$_${ri}$la_syrcond + public :: stdlib${ii}$_${ri}$la_syrpvgrw + public :: stdlib${ii}$_${ri}$la_wwaddw + public :: stdlib${ii}$_${ri}$labad + public :: stdlib${ii}$_${ri}$labrd + public :: stdlib${ii}$_${ri}$lacn2 + public :: stdlib${ii}$_${ri}$lacon + public :: stdlib${ii}$_${ri}$lacpy + public :: stdlib${ii}$_${ri}$ladiv + public :: stdlib${ii}$_${ri}$ladiv1 + public :: stdlib${ii}$_${ri}$ladiv2 + public :: stdlib${ii}$_${ri}$lae2 + public :: stdlib${ii}$_${ri}$laebz + public :: stdlib${ii}$_${ri}$laed0 + public :: stdlib${ii}$_${ri}$laed1 + public :: stdlib${ii}$_${ri}$laed2 + public :: stdlib${ii}$_${ri}$laed3 + public :: stdlib${ii}$_${ri}$laed4 + public :: stdlib${ii}$_${ri}$laed5 + public :: stdlib${ii}$_${ri}$laed6 + public :: stdlib${ii}$_${ri}$laed7 + public :: stdlib${ii}$_${ri}$laed8 + public :: stdlib${ii}$_${ri}$laed9 + public :: stdlib${ii}$_${ri}$laeda + public :: stdlib${ii}$_${ri}$laein + public :: stdlib${ii}$_${ri}$laev2 + public :: stdlib${ii}$_${ri}$laexc + public :: stdlib${ii}$_${ri}$lag2 + public :: stdlib${ii}$_${ri}$lag2s + public :: stdlib${ii}$_dlag2${ri}$ + public :: stdlib${ii}$_${ri}$lags2 + public :: stdlib${ii}$_${ri}$lagtf + public :: stdlib${ii}$_${ri}$lagtm + public :: stdlib${ii}$_${ri}$lagts + public :: stdlib${ii}$_${ri}$lagv2 + public :: stdlib${ii}$_${ri}$lahqr + public :: stdlib${ii}$_${ri}$lahr2 + public :: stdlib${ii}$_${ri}$laic1 + public :: stdlib${ii}$_${ri}$laisnan + public :: stdlib${ii}$_${ri}$laln2 + public :: stdlib${ii}$_${ri}$lals0 + public :: stdlib${ii}$_${ri}$lalsa + public :: stdlib${ii}$_${ri}$lalsd + public :: stdlib${ii}$_${ri}$lamch + public :: stdlib${ii}$_${ri}$lamc3 + public :: stdlib${ii}$_${ri}$lamrg + public :: stdlib${ii}$_${ri}$lamswlq + public :: stdlib${ii}$_${ri}$lamtsqr + public :: stdlib${ii}$_${ri}$laneg + public :: stdlib${ii}$_${ri}$langb + public :: stdlib${ii}$_${ri}$lange + public :: stdlib${ii}$_${ri}$langt + public :: stdlib${ii}$_${ri}$lanhs + public :: stdlib${ii}$_${ri}$lansb + public :: stdlib${ii}$_${ri}$lansf + public :: stdlib${ii}$_${ri}$lansp + public :: stdlib${ii}$_${ri}$lanst + public :: stdlib${ii}$_${ri}$lansy + public :: stdlib${ii}$_${ri}$lantb + public :: stdlib${ii}$_${ri}$lantp + public :: stdlib${ii}$_${ri}$lantr + public :: stdlib${ii}$_${ri}$lanv2 + public :: stdlib${ii}$_${ri}$laorhr_col_getrfnp + public :: stdlib${ii}$_${ri}$laorhr_col_getrfnp2 + public :: stdlib${ii}$_${ri}$lapll + public :: stdlib${ii}$_${ri}$lapmr + public :: stdlib${ii}$_${ri}$lapmt + public :: stdlib${ii}$_${ri}$lapy2 + public :: stdlib${ii}$_${ri}$lapy3 + public :: stdlib${ii}$_${ri}$laqgb + public :: stdlib${ii}$_${ri}$laqge + public :: stdlib${ii}$_${ri}$laqp2 + public :: stdlib${ii}$_${ri}$laqps + public :: stdlib${ii}$_${ri}$laqr0 + public :: stdlib${ii}$_${ri}$laqr1 + public :: stdlib${ii}$_${ri}$laqr2 + public :: stdlib${ii}$_${ri}$laqr3 + public :: stdlib${ii}$_${ri}$laqr4 + public :: stdlib${ii}$_${ri}$laqr5 + public :: stdlib${ii}$_${ri}$laqsb + public :: stdlib${ii}$_${ri}$laqsp + public :: stdlib${ii}$_${ri}$laqsy + public :: stdlib${ii}$_${ri}$laqtr + public :: stdlib${ii}$_${ri}$laqz0 + public :: stdlib${ii}$_${ri}$laqz1 + public :: stdlib${ii}$_${ri}$laqz2 + public :: stdlib${ii}$_${ri}$laqz3 + public :: stdlib${ii}$_${ri}$laqz4 + public :: stdlib${ii}$_${ri}$lar1v + public :: stdlib${ii}$_${ri}$lar2v + public :: stdlib${ii}$_${ri}$larf + public :: stdlib${ii}$_${ri}$larfb + public :: stdlib${ii}$_${ri}$larfb_gett + public :: stdlib${ii}$_${ri}$larfg + public :: stdlib${ii}$_${ri}$larfgp + public :: stdlib${ii}$_${ri}$larft + public :: stdlib${ii}$_${ri}$larfx + public :: stdlib${ii}$_${ri}$larfy + public :: stdlib${ii}$_${ri}$largv + public :: stdlib${ii}$_${ri}$larnv + public :: stdlib${ii}$_${ri}$larra + public :: stdlib${ii}$_${ri}$larrb + public :: stdlib${ii}$_${ri}$larrc + public :: stdlib${ii}$_${ri}$larrd + public :: stdlib${ii}$_${ri}$larre + public :: stdlib${ii}$_${ri}$larrf + public :: stdlib${ii}$_${ri}$larrj + public :: stdlib${ii}$_${ri}$larrk + public :: stdlib${ii}$_${ri}$larrr + public :: stdlib${ii}$_${ri}$larrv + public :: stdlib${ii}$_${ri}$lartg + public :: stdlib${ii}$_${ri}$lartgp + public :: stdlib${ii}$_${ri}$lartgs + public :: stdlib${ii}$_${ri}$lartv + public :: stdlib${ii}$_${ri}$laruv + public :: stdlib${ii}$_${ri}$larz + public :: stdlib${ii}$_${ri}$larzb + public :: stdlib${ii}$_${ri}$larzt + public :: stdlib${ii}$_${ri}$las2 + public :: stdlib${ii}$_${ri}$lascl + public :: stdlib${ii}$_${ri}$lasd0 + public :: stdlib${ii}$_${ri}$lasd1 + public :: stdlib${ii}$_${ri}$lasd2 + public :: stdlib${ii}$_${ri}$lasd3 + public :: stdlib${ii}$_${ri}$lasd4 + public :: stdlib${ii}$_${ri}$lasd5 + public :: stdlib${ii}$_${ri}$lasd6 + public :: stdlib${ii}$_${ri}$lasd7 + public :: stdlib${ii}$_${ri}$lasd8 + public :: stdlib${ii}$_${ri}$lasda + public :: stdlib${ii}$_${ri}$lasdq + public :: stdlib${ii}$_${ri}$lasdt + public :: stdlib${ii}$_${ri}$laset + public :: stdlib${ii}$_${ri}$lasq1 + public :: stdlib${ii}$_${ri}$lasq2 + public :: stdlib${ii}$_${ri}$lasq3 + public :: stdlib${ii}$_${ri}$lasq4 + public :: stdlib${ii}$_${ri}$lasq5 + public :: stdlib${ii}$_${ri}$lasq6 + public :: stdlib${ii}$_${ri}$lasr + public :: stdlib${ii}$_${ri}$lasrt + public :: stdlib${ii}$_${ri}$lassq + public :: stdlib${ii}$_${ri}$lasv2 + public :: stdlib${ii}$_${ri}$laswlq + public :: stdlib${ii}$_${ri}$laswp + public :: stdlib${ii}$_${ri}$lasy2 + public :: stdlib${ii}$_${ri}$lasyf + public :: stdlib${ii}$_${ri}$lasyf_aa + public :: stdlib${ii}$_${ri}$lasyf_rk + public :: stdlib${ii}$_${ri}$lasyf_rook + public :: stdlib${ii}$_${ri}$lat2s + public :: stdlib${ii}$_${ri}$latbs + public :: stdlib${ii}$_${ri}$latdf + public :: stdlib${ii}$_${ri}$latps + public :: stdlib${ii}$_${ri}$latrd + public :: stdlib${ii}$_${ri}$latrs + public :: stdlib${ii}$_${ri}$latrz + public :: stdlib${ii}$_${ri}$latsqr + public :: stdlib${ii}$_${ri}$lauu2 + public :: stdlib${ii}$_${ri}$lauum + public :: stdlib${ii}$_${ri}$opgtr + public :: stdlib${ii}$_${ri}$opmtr + public :: stdlib${ii}$_${ri}$orbdb + public :: stdlib${ii}$_${ri}$orbdb1 + public :: stdlib${ii}$_${ri}$orbdb2 + public :: stdlib${ii}$_${ri}$orbdb3 + public :: stdlib${ii}$_${ri}$orbdb4 + public :: stdlib${ii}$_${ri}$orbdb5 + public :: stdlib${ii}$_${ri}$orbdb6 + public :: stdlib${ii}$_${ri}$orcsd + public :: stdlib${ii}$_${ri}$orcsd2by1 + public :: stdlib${ii}$_${ri}$org2l + public :: stdlib${ii}$_${ri}$org2r + public :: stdlib${ii}$_${ri}$orgbr + public :: stdlib${ii}$_${ri}$orghr + public :: stdlib${ii}$_${ri}$orgl2 + public :: stdlib${ii}$_${ri}$orglq + public :: stdlib${ii}$_${ri}$orgql + public :: stdlib${ii}$_${ri}$orgqr + public :: stdlib${ii}$_${ri}$orgr2 + public :: stdlib${ii}$_${ri}$orgrq + public :: stdlib${ii}$_${ri}$orgtr + public :: stdlib${ii}$_${ri}$orgtsqr + public :: stdlib${ii}$_${ri}$orgtsqr_row + public :: stdlib${ii}$_${ri}$orhr_col + public :: stdlib${ii}$_${ri}$orm22 + public :: stdlib${ii}$_${ri}$orm2l + public :: stdlib${ii}$_${ri}$orm2r + public :: stdlib${ii}$_${ri}$ormbr + public :: stdlib${ii}$_${ri}$ormhr + public :: stdlib${ii}$_${ri}$orml2 + public :: stdlib${ii}$_${ri}$ormlq + public :: stdlib${ii}$_${ri}$ormql + public :: stdlib${ii}$_${ri}$ormqr + public :: stdlib${ii}$_${ri}$ormr2 + public :: stdlib${ii}$_${ri}$ormr3 + public :: stdlib${ii}$_${ri}$ormrq + public :: stdlib${ii}$_${ri}$ormrz + public :: stdlib${ii}$_${ri}$ormtr + public :: stdlib${ii}$_${ri}$pbcon + public :: stdlib${ii}$_${ri}$pbequ + public :: stdlib${ii}$_${ri}$pbrfs + public :: stdlib${ii}$_${ri}$pbstf + public :: stdlib${ii}$_${ri}$pbsv + public :: stdlib${ii}$_${ri}$pbsvx + public :: stdlib${ii}$_${ri}$pbtf2 + public :: stdlib${ii}$_${ri}$pbtrf + public :: stdlib${ii}$_${ri}$pbtrs + public :: stdlib${ii}$_${ri}$pftrf + public :: stdlib${ii}$_${ri}$pftri + public :: stdlib${ii}$_${ri}$pftrs + public :: stdlib${ii}$_${ri}$pocon + public :: stdlib${ii}$_${ri}$poequ + public :: stdlib${ii}$_${ri}$poequb + public :: stdlib${ii}$_${ri}$porfs + public :: stdlib${ii}$_${ri}$posv + public :: stdlib${ii}$_${ri}$posvx + public :: stdlib${ii}$_${ri}$potf2 + public :: stdlib${ii}$_${ri}$potrf + public :: stdlib${ii}$_${ri}$potrf2 + public :: stdlib${ii}$_${ri}$potri + public :: stdlib${ii}$_${ri}$potrs + public :: stdlib${ii}$_${ri}$ppcon + public :: stdlib${ii}$_${ri}$ppequ + public :: stdlib${ii}$_${ri}$pprfs + public :: stdlib${ii}$_${ri}$ppsv + public :: stdlib${ii}$_${ri}$ppsvx + public :: stdlib${ii}$_${ri}$pptrf + public :: stdlib${ii}$_${ri}$pptri + public :: stdlib${ii}$_${ri}$pptrs + public :: stdlib${ii}$_${ri}$pstf2 + public :: stdlib${ii}$_${ri}$pstrf + public :: stdlib${ii}$_${ri}$ptcon + public :: stdlib${ii}$_${ri}$pteqr + public :: stdlib${ii}$_${ri}$ptrfs + public :: stdlib${ii}$_${ri}$ptsv + public :: stdlib${ii}$_${ri}$ptsvx + public :: stdlib${ii}$_${ri}$pttrf + public :: stdlib${ii}$_${ri}$pttrs + public :: stdlib${ii}$_${ri}$ptts2 + public :: stdlib${ii}$_${ri}$rscl + public :: stdlib${ii}$_${ri}$sb2st_kernels + public :: stdlib${ii}$_${ri}$sbev + public :: stdlib${ii}$_${ri}$sbevd + public :: stdlib${ii}$_${ri}$sbevx + public :: stdlib${ii}$_${ri}$sbgst + public :: stdlib${ii}$_${ri}$sbgv + public :: stdlib${ii}$_${ri}$sbgvd + public :: stdlib${ii}$_${ri}$sbgvx + public :: stdlib${ii}$_${ri}$sbtrd + public :: stdlib${ii}$_${ri}$sfrk + public :: stdlib${ii}$_${ri}$sgesv + public :: stdlib${ii}$_${ri}$spcon + public :: stdlib${ii}$_${ri}$spev + public :: stdlib${ii}$_${ri}$spevd + public :: stdlib${ii}$_${ri}$spevx + public :: stdlib${ii}$_${ri}$spgst + public :: stdlib${ii}$_${ri}$spgv + public :: stdlib${ii}$_${ri}$spgvd + public :: stdlib${ii}$_${ri}$spgvx + public :: stdlib${ii}$_${ri}$sposv + public :: stdlib${ii}$_${ri}$sprfs + public :: stdlib${ii}$_${ri}$spsv + public :: stdlib${ii}$_${ri}$spsvx + public :: stdlib${ii}$_${ri}$sptrd + public :: stdlib${ii}$_${ri}$sptrf + public :: stdlib${ii}$_${ri}$sptri + public :: stdlib${ii}$_${ri}$sptrs + public :: stdlib${ii}$_${ri}$stebz + public :: stdlib${ii}$_${ri}$stedc + public :: stdlib${ii}$_${ri}$stegr + public :: stdlib${ii}$_${ri}$stein + public :: stdlib${ii}$_${ri}$stemr + public :: stdlib${ii}$_${ri}$steqr + public :: stdlib${ii}$_${ri}$sterf + public :: stdlib${ii}$_${ri}$stev + public :: stdlib${ii}$_${ri}$stevd + public :: stdlib${ii}$_${ri}$stevr + public :: stdlib${ii}$_${ri}$stevx + public :: stdlib${ii}$_${ri}$sycon + public :: stdlib${ii}$_${ri}$sycon_rook + public :: stdlib${ii}$_${ri}$syconv + public :: stdlib${ii}$_${ri}$syconvf + public :: stdlib${ii}$_${ri}$syconvf_rook + public :: stdlib${ii}$_${ri}$syequb + public :: stdlib${ii}$_${ri}$syev + public :: stdlib${ii}$_${ri}$syevd + public :: stdlib${ii}$_${ri}$syevr + public :: stdlib${ii}$_${ri}$syevx + public :: stdlib${ii}$_${ri}$sygs2 + public :: stdlib${ii}$_${ri}$sygst + public :: stdlib${ii}$_${ri}$sygv + public :: stdlib${ii}$_${ri}$sygvd + public :: stdlib${ii}$_${ri}$sygvx + public :: stdlib${ii}$_${ri}$syrfs + public :: stdlib${ii}$_${ri}$sysv + public :: stdlib${ii}$_${ri}$sysv_aa + public :: stdlib${ii}$_${ri}$sysv_rk + public :: stdlib${ii}$_${ri}$sysv_rook + public :: stdlib${ii}$_${ri}$sysvx + public :: stdlib${ii}$_${ri}$syswapr + public :: stdlib${ii}$_${ri}$sytd2 + public :: stdlib${ii}$_${ri}$sytf2 + public :: stdlib${ii}$_${ri}$sytf2_rk + public :: stdlib${ii}$_${ri}$sytf2_rook + public :: stdlib${ii}$_${ri}$sytrd + public :: stdlib${ii}$_${ri}$sytrd_sb2st + public :: stdlib${ii}$_${ri}$sytrd_sy2sb + public :: stdlib${ii}$_${ri}$sytrf + public :: stdlib${ii}$_${ri}$sytrf_aa + public :: stdlib${ii}$_${ri}$sytrf_rk + public :: stdlib${ii}$_${ri}$sytrf_rook + public :: stdlib${ii}$_${ri}$sytri + public :: stdlib${ii}$_${ri}$sytri_rook + public :: stdlib${ii}$_${ri}$sytrs + public :: stdlib${ii}$_${ri}$sytrs2 + public :: stdlib${ii}$_${ri}$sytrs_3 + public :: stdlib${ii}$_${ri}$sytrs_aa + public :: stdlib${ii}$_${ri}$sytrs_rook + public :: stdlib${ii}$_${ri}$tbcon + public :: stdlib${ii}$_${ri}$tbrfs + public :: stdlib${ii}$_${ri}$tbtrs + public :: stdlib${ii}$_${ri}$tfsm + public :: stdlib${ii}$_${ri}$tftri + public :: stdlib${ii}$_${ri}$tfttp + public :: stdlib${ii}$_${ri}$tfttr + public :: stdlib${ii}$_${ri}$tgevc + public :: stdlib${ii}$_${ri}$tgex2 + public :: stdlib${ii}$_${ri}$tgexc + public :: stdlib${ii}$_${ri}$tgsen + public :: stdlib${ii}$_${ri}$tgsja + public :: stdlib${ii}$_${ri}$tgsna + public :: stdlib${ii}$_${ri}$tgsy2 + public :: stdlib${ii}$_${ri}$tgsyl + public :: stdlib${ii}$_${ri}$tpcon + public :: stdlib${ii}$_${ri}$tplqt + public :: stdlib${ii}$_${ri}$tplqt2 + public :: stdlib${ii}$_${ri}$tpmlqt + public :: stdlib${ii}$_${ri}$tpmqrt + public :: stdlib${ii}$_${ri}$tpqrt + public :: stdlib${ii}$_${ri}$tpqrt2 + public :: stdlib${ii}$_${ri}$tprfb + public :: stdlib${ii}$_${ri}$tprfs + public :: stdlib${ii}$_${ri}$tptri + public :: stdlib${ii}$_${ri}$tptrs + public :: stdlib${ii}$_${ri}$tpttf + public :: stdlib${ii}$_${ri}$tpttr + public :: stdlib${ii}$_${ri}$trcon + public :: stdlib${ii}$_${ri}$trevc + public :: stdlib${ii}$_${ri}$trevc3 + public :: stdlib${ii}$_${ri}$trexc + public :: stdlib${ii}$_${ri}$trrfs + public :: stdlib${ii}$_${ri}$trsen + public :: stdlib${ii}$_${ri}$trsna + public :: stdlib${ii}$_${ri}$trsyl + public :: stdlib${ii}$_${ri}$trti2 + public :: stdlib${ii}$_${ri}$trtri + public :: stdlib${ii}$_${ri}$trtrs + public :: stdlib${ii}$_${ri}$trttf + public :: stdlib${ii}$_${ri}$trttp + public :: stdlib${ii}$_${ri}$tzrzf + public :: stdlib${ii}$_${ri}$zsum1 + #:endfor ! 128-bit real constants real(${rk}$), parameter, private :: negone = -1.00_${rk}$ @@ -507,7 +509,7 @@ module stdlib_linalg_lapack_${ri}$ real(${rk}$), parameter, private :: rradix = real(radix(zero),${rk}$) real(${rk}$), parameter, private :: ulp = epsilon(zero) real(${rk}$), parameter, private :: eps = ulp*half - real(${rk}$), parameter, private :: safmin = rradix**max(minexp-1,1-maxexp) + real(${rk}$), parameter, private :: safmin = rradix**max(minexp-1,1_${ik}$-maxexp) real(${rk}$), parameter, private :: safmax = one/safmin real(${rk}$), parameter, private :: smlnum = safmin/ulp real(${rk}$), parameter, private :: bignum = safmax*ulp @@ -517,15 +519,15 @@ module stdlib_linalg_lapack_${ri}$ ! 128-bit Blue's scaling constants ! ssml>=1/s and sbig==1/S with s,S as defined in https://doi.org/10.1145/355769.355771 real(${rk}$), parameter, private :: tsml = rradix**ceiling((minexp-1)*half) - real(${rk}$), parameter, private :: tbig = rradix**floor((maxexp-digits(zero)+1)*half) + real(${rk}$), parameter, private :: tbig = rradix**floor((maxexp-digits(zero)+1_${ik}$)*half) real(${rk}$), parameter, private :: ssml = rradix**(-floor((minexp-digits(zero))*half)) - real(${rk}$), parameter, private :: sbig = rradix**(-ceiling((maxexp+digits(zero)-1)*half)) + real(${rk}$), parameter, private :: sbig = rradix**(-ceiling((maxexp+digits(zero)-1_${ik}$)*half)) contains - - pure subroutine stdlib_${ri}$bbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, phi, u1, & + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + pure subroutine stdlib${ii}$_${ri}$bbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, phi, u1, & !! DBBCSD: computes the CS decomposition of an orthogonal matrix in !! bidiagonal-block form, !! [ B11 | B12 0 0 ] @@ -554,8 +556,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobu1, jobu2, jobv1t, jobv2t, trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldu1, ldu2, ldv1t, ldv2t, lwork, m, p, q + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldu1, ldu2, ldv1t, ldv2t, lwork, m, p, q ! Array Arguments real(${rk}$), intent(out) :: b11d(*), b11e(*), b12d(*), b12e(*), b21d(*), b21e(*), b22d(*),& b22e(*), work(*) @@ -563,7 +565,7 @@ module stdlib_linalg_lapack_${ri}$ real(${rk}$), intent(inout) :: u1(ldu1,*), u2(ldu2,*), v1t(ldv1t,*), v2t(ldv2t,*) ! =================================================================== ! Parameters - integer(ilp), parameter :: maxitr = 6 + integer(${ik}$), parameter :: maxitr = 6_${ik}$ real(${rk}$), parameter :: hundred = 100.0_${rk}$ real(${rk}$), parameter :: meighth = -0.125_${rk}$ real(${rk}$), parameter :: piover2 = 1.57079632679489661923132169163975144210_${rk}$ @@ -574,7 +576,7 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: colmajor, lquery, restart11, restart12, restart21, restart22, wantu1, & wantu2, wantv1t, wantv2t - integer(ilp) :: i, imin, imax, iter, iu1cs, iu1sn, iu2cs, iu2sn, iv1tcs, iv1tsn, & + integer(${ik}$) :: i, imin, imax, iter, iu1cs, iu1sn, iu2cs, iu2sn, iv1tcs, iv1tsn, & iv2tcs, iv2tsn, j, lworkmin, lworkopt, maxit, mini real(${rk}$) :: b11bulge, b12bulge, b21bulge, b22bulge, dummy, eps, mu, nu, r, sigma11, & sigma21, temp, thetamax, thetamin, thresh, tol, tolmul, unfl, x1, x2, y1, y2 @@ -582,39 +584,39 @@ module stdlib_linalg_lapack_${ri}$ intrinsic :: abs,atan2,cos,max,min,sin,sqrt ! Executable Statements ! test input arguments - info = 0 - lquery = lwork == -1 + info = 0_${ik}$ + lquery = lwork == -1_${ik}$ wantu1 = stdlib_lsame( jobu1, 'Y' ) wantu2 = stdlib_lsame( jobu2, 'Y' ) wantv1t = stdlib_lsame( jobv1t, 'Y' ) wantv2t = stdlib_lsame( jobv2t, 'Y' ) colmajor = .not. stdlib_lsame( trans, 'T' ) - if( m < 0 ) then - info = -6 - else if( p < 0 .or. p > 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 @@ -622,22 +624,22 @@ module stdlib_linalg_lapack_${ri}$ 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( 'DBBCSD', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DBBCSD', -info ) return else if( lquery ) then return end if ! get machine constants - eps = stdlib_${ri}$lamch( 'EPSILON' ) - unfl = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_${ri}$lamch( 'EPSILON' ) + unfl = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) tolmul = max( ten, min( hundred, eps**meighth ) ) tol = tolmul*eps thresh = max( tol, maxitr*q*q*unfl ) @@ -662,18 +664,18 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -693,9 +695,9 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -719,20 +721,20 @@ module stdlib_linalg_lapack_${ri}$ nu = zero else ! compute shifts for b11 and b21 and use the lesser - call stdlib_${ri}$las2( b11d(imax-1), b11e(imax-1), b11d(imax), sigma11,dummy ) + call stdlib${ii}$_${ri}$las2( b11d(imax-1), b11e(imax-1), b11d(imax), sigma11,dummy ) - call stdlib_${ri}$las2( b21d(imax-1), b21e(imax-1), b21d(imax), sigma21,dummy ) + call stdlib${ii}$_${ri}$las2( 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_${rk}$ - nu**2 ) + mu = sqrt( 1.0_${rk}$ - nu**2_${ik}$ ) if( nu < thresh ) then mu = one nu = zero @@ -741,10 +743,10 @@ module stdlib_linalg_lapack_${ri}$ end if ! rotate to produce bulges in b11 and b21 if( mu <= nu ) then - call stdlib_${ri}$lartgs( b11d(imin), b11e(imin), mu,work(iv1tcs+imin-1), work(iv1tsn+& + call stdlib${ii}$_${ri}$lartgs( b11d(imin), b11e(imin), mu,work(iv1tcs+imin-1), work(iv1tsn+& imin-1) ) else - call stdlib_${ri}$lartgs( b21d(imin), b21e(imin), nu,work(iv1tcs+imin-1), work(iv1tsn+& + call stdlib${ii}$_${ri}$lartgs( b21d(imin), b21e(imin), nu,work(iv1tcs+imin-1), work(iv1tsn+& imin-1) ) end if temp = work(iv1tcs+imin-1)*b11d(imin) +work(iv1tsn+imin-1)*b11e(imin) @@ -758,27 +760,27 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$lartgp( 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}$_${ri}$lartgp( b11bulge, b11d(imin), work(iu1sn+imin-1),work(iu1cs+imin-1),& r ) else if( mu <= nu ) then - call stdlib_${ri}$lartgs( b11e( imin ), b11d( imin + 1 ), mu,work(iu1cs+imin-1), work(& + call stdlib${ii}$_${ri}$lartgs( b11e( imin ), b11d( imin + 1_${ik}$ ), mu,work(iu1cs+imin-1), work(& iu1sn+imin-1) ) else - call stdlib_${ri}$lartgs( b12d( imin ), b12e( imin ), nu,work(iu1cs+imin-1), work(& + call stdlib${ii}$_${ri}$lartgs( b12d( imin ), b12e( imin ), nu,work(iu1cs+imin-1), work(& iu1sn+imin-1) ) end if - if( b21d(imin)**2+b21bulge**2 > thresh**2 ) then - call stdlib_${ri}$lartgp( 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}$_${ri}$lartgp( b21bulge, b21d(imin), work(iu2sn+imin-1),work(iu2cs+imin-1),& r ) else if( nu < mu ) then - call stdlib_${ri}$lartgs( b21e( imin ), b21d( imin + 1 ), nu,work(iu2cs+imin-1), work(& + call stdlib${ii}$_${ri}$lartgs( b21e( imin ), b21d( imin + 1_${ik}$ ), nu,work(iu2cs+imin-1), work(& iu2sn+imin-1) ) else - call stdlib_${ri}$lartgs( b22d(imin), b22e(imin), mu,work(iu2cs+imin-1), work(iu2sn+& + call stdlib${ii}$_${ri}$lartgs( b22d(imin), b22e(imin), mu,work(iu2cs+imin-1), work(iu2sn+& imin-1) ) end if work(iu2cs+imin-1) = -work(iu2cs+imin-1) @@ -818,48 +820,48 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$lartgp( x2, x1, work(iv1tsn+i-1), work(iv1tcs+i-1),r ) + call stdlib${ii}$_${ri}$lartgp( x2, x1, work(iv1tsn+i-1), work(iv1tcs+i-1),r ) else if( .not. restart11 .and. restart21 ) then - call stdlib_${ri}$lartgp( b11bulge, b11e(i-1), work(iv1tsn+i-1),work(iv1tcs+i-1), & + call stdlib${ii}$_${ri}$lartgp( b11bulge, b11e(i-1), work(iv1tsn+i-1),work(iv1tcs+i-1), & r ) else if( restart11 .and. .not. restart21 ) then - call stdlib_${ri}$lartgp( b21bulge, b21e(i-1), work(iv1tsn+i-1),work(iv1tcs+i-1), & + call stdlib${ii}$_${ri}$lartgp( b21bulge, b21e(i-1), work(iv1tsn+i-1),work(iv1tcs+i-1), & r ) else if( mu <= nu ) then - call stdlib_${ri}$lartgs( b11d(i), b11e(i), mu, work(iv1tcs+i-1),work(iv1tsn+i-1) ) + call stdlib${ii}$_${ri}$lartgs( b11d(i), b11e(i), mu, work(iv1tcs+i-1),work(iv1tsn+i-1) ) else - call stdlib_${ri}$lartgs( b21d(i), b21e(i), nu, work(iv1tcs+i-1),work(iv1tsn+i-1) ) + call stdlib${ii}$_${ri}$lartgs( b21d(i), b21e(i), nu, work(iv1tcs+i-1),work(iv1tsn+i-1) ) end if work(iv1tcs+i-1) = -work(iv1tcs+i-1) work(iv1tsn+i-1) = -work(iv1tsn+i-1) if( .not. restart12 .and. .not. restart22 ) then - call stdlib_${ri}$lartgp( y2, y1, work(iv2tsn+i-1-1),work(iv2tcs+i-1-1), r ) + call stdlib${ii}$_${ri}$lartgp( y2, y1, work(iv2tsn+i-1-1),work(iv2tcs+i-1-1), r ) else if( .not. restart12 .and. restart22 ) then - call stdlib_${ri}$lartgp( b12bulge, b12d(i-1), work(iv2tsn+i-1-1),work(iv2tcs+i-1-& - 1), r ) + call stdlib${ii}$_${ri}$lartgp( 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_${ri}$lartgp( b22bulge, b22d(i-1), work(iv2tsn+i-1-1),work(iv2tcs+i-1-& - 1), r ) + call stdlib${ii}$_${ri}$lartgp( b22bulge, b22d(i-1), work(iv2tsn+i-1-1),work(iv2tcs+i-1-& + 1_${ik}$), r ) else if( nu < mu ) then - call stdlib_${ri}$lartgs( b12e(i-1), b12d(i), nu, work(iv2tcs+i-1-1),work(iv2tsn+i-& - 1-1) ) + call stdlib${ii}$_${ri}$lartgs( b12e(i-1), b12d(i), nu, work(iv2tcs+i-1-1),work(iv2tsn+i-& + 1_${ik}$-1) ) else - call stdlib_${ri}$lartgs( b22e(i-1), b22d(i), mu, work(iv2tcs+i-1-1),work(iv2tsn+i-& - 1-1) ) + call stdlib${ii}$_${ri}$lartgs( 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) @@ -886,44 +888,44 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$lartgp( x2, x1, work(iu1sn+i-1), work(iu1cs+i-1),r ) + call stdlib${ii}$_${ri}$lartgp( x2, x1, work(iu1sn+i-1), work(iu1cs+i-1),r ) else if( .not. restart11 .and. restart12 ) then - call stdlib_${ri}$lartgp( b11bulge, b11d(i), work(iu1sn+i-1),work(iu1cs+i-1), r ) + call stdlib${ii}$_${ri}$lartgp( b11bulge, b11d(i), work(iu1sn+i-1),work(iu1cs+i-1), r ) else if( restart11 .and. .not. restart12 ) then - call stdlib_${ri}$lartgp( b12bulge, b12e(i-1), work(iu1sn+i-1),work(iu1cs+i-1), r ) + call stdlib${ii}$_${ri}$lartgp( b12bulge, b12e(i-1), work(iu1sn+i-1),work(iu1cs+i-1), r ) else if( mu <= nu ) then - call stdlib_${ri}$lartgs( b11e(i), b11d(i+1), mu, work(iu1cs+i-1),work(iu1sn+i-1) ) + call stdlib${ii}$_${ri}$lartgs( b11e(i), b11d(i+1), mu, work(iu1cs+i-1),work(iu1sn+i-1) ) else - call stdlib_${ri}$lartgs( b12d(i), b12e(i), nu, work(iu1cs+i-1),work(iu1sn+i-1) ) + call stdlib${ii}$_${ri}$lartgs( b12d(i), b12e(i), nu, work(iu1cs+i-1),work(iu1sn+i-1) ) end if if( .not. restart21 .and. .not. restart22 ) then - call stdlib_${ri}$lartgp( y2, y1, work(iu2sn+i-1), work(iu2cs+i-1),r ) + call stdlib${ii}$_${ri}$lartgp( y2, y1, work(iu2sn+i-1), work(iu2cs+i-1),r ) else if( .not. restart21 .and. restart22 ) then - call stdlib_${ri}$lartgp( b21bulge, b21d(i), work(iu2sn+i-1),work(iu2cs+i-1), r ) + call stdlib${ii}$_${ri}$lartgp( b21bulge, b21d(i), work(iu2sn+i-1),work(iu2cs+i-1), r ) else if( restart21 .and. .not. restart22 ) then - call stdlib_${ri}$lartgp( b22bulge, b22e(i-1), work(iu2sn+i-1),work(iu2cs+i-1), r ) + call stdlib${ii}$_${ri}$lartgp( b22bulge, b22e(i-1), work(iu2sn+i-1),work(iu2cs+i-1), r ) else if( nu < mu ) then - call stdlib_${ri}$lartgs( b21e(i), b21e(i+1), nu, work(iu2cs+i-1),work(iu2sn+i-1) ) + call stdlib${ii}$_${ri}$lartgs( b21e(i), b21e(i+1), nu, work(iu2cs+i-1),work(iu2sn+i-1) ) else - call stdlib_${ri}$lartgs( b22d(i), b22e(i), mu, work(iu2cs+i-1),work(iu2sn+i-1) ) + call stdlib${ii}$_${ri}$lartgs( b22d(i), b22e(i), mu, work(iu2cs+i-1),work(iu2sn+i-1) ) end if work(iu2cs+i-1) = -work(iu2cs+i-1) @@ -931,14 +933,14 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -957,24 +959,24 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$lartgp( y2, y1, work(iv2tsn+imax-1-1),work(iv2tcs+imax-1-1), r ) + call stdlib${ii}$_${ri}$lartgp( y2, y1, work(iv2tsn+imax-1-1),work(iv2tcs+imax-1-1), r ) else if( .not. restart12 .and. restart22 ) then - call stdlib_${ri}$lartgp( b12bulge, b12d(imax-1), work(iv2tsn+imax-1-1),work(iv2tcs+& + call stdlib${ii}$_${ri}$lartgp( b12bulge, b12d(imax-1), work(iv2tsn+imax-1-1),work(iv2tcs+& imax-1-1), r ) else if( restart12 .and. .not. restart22 ) then - call stdlib_${ri}$lartgp( b22bulge, b22d(imax-1), work(iv2tsn+imax-1-1),work(iv2tcs+& + call stdlib${ii}$_${ri}$lartgp( b22bulge, b22d(imax-1), work(iv2tsn+imax-1-1),work(iv2tcs+& imax-1-1), r ) else if( nu < mu ) then - call stdlib_${ri}$lartgs( b12e(imax-1), b12d(imax), nu,work(iv2tcs+imax-1-1), work(& + call stdlib${ii}$_${ri}$lartgs( b12e(imax-1), b12d(imax), nu,work(iv2tcs+imax-1-1), work(& iv2tsn+imax-1-1) ) else - call stdlib_${ri}$lartgs( b22e(imax-1), b22d(imax), mu,work(iv2tcs+imax-1-1), work(& + call stdlib${ii}$_${ri}$lartgs( b22e(imax-1), b22d(imax), mu,work(iv2tcs+imax-1-1), work(& iv2tsn+imax-1-1) ) end if temp = work(iv2tcs+imax-1-1)*b12e(imax-1) +work(iv2tsn+imax-1-1)*b12d(imax) @@ -988,49 +990,49 @@ module stdlib_linalg_lapack_${ri}$ ! update singular vectors if( wantu1 ) then if( colmajor ) then - call stdlib_${ri}$lasr( 'R', 'V', 'F', p, imax-imin+1,work(iu1cs+imin-1), work(& - iu1sn+imin-1),u1(1,imin), ldu1 ) + call stdlib${ii}$_${ri}$lasr( 'R', 'V', 'F', p, imax-imin+1,work(iu1cs+imin-1), work(& + iu1sn+imin-1),u1(1_${ik}$,imin), ldu1 ) else - call stdlib_${ri}$lasr( 'L', 'V', 'F', imax-imin+1, p,work(iu1cs+imin-1), work(& - iu1sn+imin-1),u1(imin,1), ldu1 ) + call stdlib${ii}$_${ri}$lasr( '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_${ri}$lasr( 'R', 'V', 'F', m-p, imax-imin+1,work(iu2cs+imin-1), work(& - iu2sn+imin-1),u2(1,imin), ldu2 ) + call stdlib${ii}$_${ri}$lasr( 'R', 'V', 'F', m-p, imax-imin+1,work(iu2cs+imin-1), work(& + iu2sn+imin-1),u2(1_${ik}$,imin), ldu2 ) else - call stdlib_${ri}$lasr( 'L', 'V', 'F', imax-imin+1, m-p,work(iu2cs+imin-1), work(& - iu2sn+imin-1),u2(imin,1), ldu2 ) + call stdlib${ii}$_${ri}$lasr( '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_${ri}$lasr( 'L', 'V', 'F', imax-imin+1, q,work(iv1tcs+imin-1), work(& - iv1tsn+imin-1),v1t(imin,1), ldv1t ) + call stdlib${ii}$_${ri}$lasr( 'L', 'V', 'F', imax-imin+1, q,work(iv1tcs+imin-1), work(& + iv1tsn+imin-1),v1t(imin,1_${ik}$), ldv1t ) else - call stdlib_${ri}$lasr( 'R', 'V', 'F', q, imax-imin+1,work(iv1tcs+imin-1), work(& - iv1tsn+imin-1),v1t(1,imin), ldv1t ) + call stdlib${ii}$_${ri}$lasr( '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_${ri}$lasr( 'L', 'V', 'F', imax-imin+1, m-q,work(iv2tcs+imin-1), work(& - iv2tsn+imin-1),v2t(imin,1), ldv2t ) + call stdlib${ii}$_${ri}$lasr( 'L', 'V', 'F', imax-imin+1, m-q,work(iv2tcs+imin-1), work(& + iv2tsn+imin-1),v2t(imin,1_${ik}$), ldv2t ) else - call stdlib_${ri}$lasr( 'R', 'V', 'F', m-q, imax-imin+1,work(iv2tcs+imin-1), work(& - iv2tsn+imin-1),v2t(1,imin), ldv2t ) + call stdlib${ii}$_${ri}$lasr( '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_${ri}$scal( q, negone, v1t(imax,1), ldv1t ) + call stdlib${ii}$_${ri}$scal( q, negone, v1t(imax,1_${ik}$), ldv1t ) else - call stdlib_${ri}$scal( q, negone, v1t(1,imax), 1 ) + call stdlib${ii}$_${ri}$scal( q, negone, v1t(1_${ik}$,imax), 1_${ik}$ ) end if end if end if @@ -1040,33 +1042,33 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$scal( p, negone, u1(1,imax), 1 ) + call stdlib${ii}$_${ri}$scal( p, negone, u1(1_${ik}$,imax), 1_${ik}$ ) else - call stdlib_${ri}$scal( p, negone, u1(imax,1), ldu1 ) + call stdlib${ii}$_${ri}$scal( 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_${ri}$scal( m-p, negone, u2(1,imax), 1 ) + call stdlib${ii}$_${ri}$scal( m-p, negone, u2(1_${ik}$,imax), 1_${ik}$ ) else - call stdlib_${ri}$scal( m-p, negone, u2(imax,1), ldu2 ) + call stdlib${ii}$_${ri}$scal( 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_${ri}$scal( m-q, negone, v2t(imax,1), ldv2t ) + call stdlib${ii}$_${ri}$scal( m-q, negone, v2t(imax,1_${ik}$), ldv2t ) else - call stdlib_${ri}$scal( m-q, negone, v2t(1,imax), 1 ) + call stdlib${ii}$_${ri}$scal( m-q, negone, v2t(1_${ik}$,imax), 1_${ik}$ ) end if end if end if @@ -1086,16 +1088,16 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -1115,25 +1117,25 @@ module stdlib_linalg_lapack_${ri}$ theta(mini) = theta(i) theta(i) = thetamin if( colmajor ) then - if( wantu1 )call stdlib_${ri}$swap( p, u1(1,i), 1, u1(1,mini), 1 ) - if( wantu2 )call stdlib_${ri}$swap( m-p, u2(1,i), 1, u2(1,mini), 1 ) - if( wantv1t )call stdlib_${ri}$swap( q, v1t(i,1), ldv1t, v1t(mini,1), ldv1t ) + if( wantu1 )call stdlib${ii}$_${ri}$swap( p, u1(1_${ik}$,i), 1_${ik}$, u1(1_${ik}$,mini), 1_${ik}$ ) + if( wantu2 )call stdlib${ii}$_${ri}$swap( m-p, u2(1_${ik}$,i), 1_${ik}$, u2(1_${ik}$,mini), 1_${ik}$ ) + if( wantv1t )call stdlib${ii}$_${ri}$swap( q, v1t(i,1_${ik}$), ldv1t, v1t(mini,1_${ik}$), ldv1t ) - if( wantv2t )call stdlib_${ri}$swap( m-q, v2t(i,1), ldv2t, v2t(mini,1),ldv2t ) + if( wantv2t )call stdlib${ii}$_${ri}$swap( m-q, v2t(i,1_${ik}$), ldv2t, v2t(mini,1_${ik}$),ldv2t ) else - if( wantu1 )call stdlib_${ri}$swap( p, u1(i,1), ldu1, u1(mini,1), ldu1 ) - if( wantu2 )call stdlib_${ri}$swap( m-p, u2(i,1), ldu2, u2(mini,1), ldu2 ) - if( wantv1t )call stdlib_${ri}$swap( q, v1t(1,i), 1, v1t(1,mini), 1 ) - if( wantv2t )call stdlib_${ri}$swap( m-q, v2t(1,i), 1, v2t(1,mini), 1 ) + if( wantu1 )call stdlib${ii}$_${ri}$swap( p, u1(i,1_${ik}$), ldu1, u1(mini,1_${ik}$), ldu1 ) + if( wantu2 )call stdlib${ii}$_${ri}$swap( m-p, u2(i,1_${ik}$), ldu2, u2(mini,1_${ik}$), ldu2 ) + if( wantv1t )call stdlib${ii}$_${ri}$swap( q, v1t(1_${ik}$,i), 1_${ik}$, v1t(1_${ik}$,mini), 1_${ik}$ ) + if( wantv2t )call stdlib${ii}$_${ri}$swap( m-q, v2t(1_${ik}$,i), 1_${ik}$, v2t(1_${ik}$,mini), 1_${ik}$ ) end if end if end do return - end subroutine stdlib_${ri}$bbcsd + end subroutine stdlib${ii}$_${ri}$bbcsd - pure subroutine stdlib_${ri}$bdsdc( uplo, compq, n, d, e, u, ldu, vt, ldvt, q, iq,work, iwork, & + pure subroutine stdlib${ii}$_${ri}$bdsdc( uplo, compq, n, d, e, u, ldu, vt, ldvt, q, iq,work, iwork, & !! DBDSDC: computes the singular value decomposition (SVD) of a real !! N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT, !! using a divide and conquer method, where S is a diagonal matrix @@ -1156,10 +1158,10 @@ module stdlib_linalg_lapack_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: compq, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldu, ldvt, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldu, ldvt, n ! Array Arguments - integer(ilp), intent(out) :: iq(*), iwork(*) + integer(${ik}$), intent(out) :: iq(*), iwork(*) real(${rk}$), intent(inout) :: d(*), e(*) real(${rk}$), intent(out) :: q(*), u(ldu,*), vt(ldvt,*), work(*) ! ===================================================================== @@ -1168,7 +1170,7 @@ module stdlib_linalg_lapack_${ri}$ ! ===================================================================== ! Local Scalars - integer(ilp) :: difl, difr, givcol, givnum, givptr, i, ic, icompq, ierr, ii, is, iu, & + integer(${ik}$) :: difl, difr, givcol, givnum, givptr, i, ic, icompq, ierr, ii, is, iu, & iuplo, ivt, j, k, kk, mlvl, nm1, nsize, perm, poles, qstart, smlsiz, smlszp, sqre, & start, wstart, z real(${rk}$) :: cs, eps, orgnrm, p, r, sn @@ -1176,127 +1178,127 @@ module stdlib_linalg_lapack_${ri}$ intrinsic :: abs,real,int,log,sign ! Executable Statements ! test the input parameters. - info = 0 - iuplo = 0 - if( stdlib_lsame( uplo, 'U' ) )iuplo = 1 - if( stdlib_lsame( uplo, 'L' ) )iuplo = 2 + info = 0_${ik}$ + iuplo = 0_${ik}$ + if( stdlib_lsame( uplo, 'U' ) )iuplo = 1_${ik}$ + if( stdlib_lsame( uplo, 'L' ) )iuplo = 2_${ik}$ if( stdlib_lsame( compq, 'N' ) ) then - icompq = 0 + icompq = 0_${ik}$ else if( stdlib_lsame( compq, 'P' ) ) then - icompq = 1 + icompq = 1_${ik}$ else if( stdlib_lsame( compq, 'I' ) ) then - icompq = 2 + icompq = 2_${ik}$ else - icompq = -1 + icompq = -1_${ik}$ end if - if( iuplo==0 ) then - info = -1 - else if( icompq<0 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ( ldu<1 ) .or. ( ( icompq==2 ) .and. ( ldu=eps ) then ! a subproblem with e(nm1) not too small but i = nm1. - nsize = n - start + 1 + nsize = n - start + 1_${ik}$ else ! a subproblem with e(nm1) small. this implies an ! 1-by-1 subproblem at d(n). solve this 1-by-1 problem ! first. - nsize = i - start + 1 - if( icompq==2 ) then + nsize = i - start + 1_${ik}$ + if( icompq==2_${ik}$ ) then u( n, n ) = sign( one, d( n ) ) vt( n, n ) = one - else if( icompq==1 ) then + else if( icompq==1_${ik}$ ) then q( n+( qstart-1 )*n ) = sign( one, d( n ) ) q( n+( smlsiz+qstart-1 )*n ) = one end if d( n ) = abs( d( n ) ) end if - if( icompq==2 ) then - call stdlib_${ri}$lasd0( nsize, sqre, d( start ), e( start ),u( start, start ), & + if( icompq==2_${ik}$ ) then + call stdlib${ii}$_${ri}$lasd0( nsize, sqre, d( start ), e( start ),u( start, start ), & ldu, vt( start, start ),ldvt, smlsiz, iwork, work( wstart ), info ) else - call stdlib_${ri}$lasda( icompq, smlsiz, nsize, sqre, d( start ),e( start ), q( & + call stdlib${ii}$_${ri}$lasda( icompq, smlsiz, nsize, sqre, d( start ),e( start ), q( & start+( iu+qstart-2 )*n ), n,q( start+( ivt+qstart-2 )*n ),iq( start+k*n ), q(& start+( difl+qstart-2 )*n ), q( start+( difr+qstart-2 )*n ),q( start+( z+& qstart-2 )*n ),q( start+( poles+qstart-2 )*n ),iq( start+givptr*n ), iq( & @@ -1342,18 +1344,18 @@ module stdlib_linalg_lapack_${ri}$ start+( ic+qstart-2 )*n ),q( start+( is+qstart-2 )*n ),work( wstart ), iwork,& info ) end if - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if - start = i + 1 + start = i + 1_${ik}$ end if end do loop_30 ! unscale - call stdlib_${ri}$lascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, n, 1_${ik}$, d, n, ierr ) 40 continue ! use selection sort to minimize swaps of singular vectors do ii = 2, n - i = ii - 1 + i = ii - 1_${ik}$ kk = i p = d( i ) do j = ii, n @@ -1365,33 +1367,33 @@ module stdlib_linalg_lapack_${ri}$ if( kk/=i ) then d( kk ) = d( i ) d( i ) = p - if( icompq==1 ) then + if( icompq==1_${ik}$ ) then iq( i ) = kk - else if( icompq==2 ) then - call stdlib_${ri}$swap( n, u( 1, i ), 1, u( 1, kk ), 1 ) - call stdlib_${ri}$swap( n, vt( i, 1 ), ldvt, vt( kk, 1 ), ldvt ) + else if( icompq==2_${ik}$ ) then + call stdlib${ii}$_${ri}$swap( n, u( 1_${ik}$, i ), 1_${ik}$, u( 1_${ik}$, kk ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$swap( n, vt( i, 1_${ik}$ ), ldvt, vt( kk, 1_${ik}$ ), ldvt ) end if - else if( icompq==1 ) then + else if( icompq==1_${ik}$ ) then iq( i ) = i end if end do ! if icompq = 1, use iq(n,1) as the indicator for uplo - if( icompq==1 ) then - if( iuplo==1 ) then - iq( n ) = 1 + if( icompq==1_${ik}$ ) then + if( iuplo==1_${ik}$ ) then + iq( n ) = 1_${ik}$ else - iq( n ) = 0 + iq( n ) = 0_${ik}$ end if end if ! if b is lower bidiagonal, update u by those givens rotations ! which rotated b to be upper bidiagonal - if( ( iuplo==2 ) .and. ( icompq==2 ) )call stdlib_${ri}$lasr( 'L', 'V', 'B', n, n, work( 1 )& + if( ( iuplo==2_${ik}$ ) .and. ( icompq==2_${ik}$ ) )call stdlib${ii}$_${ri}$lasr( 'L', 'V', 'B', n, n, work( 1_${ik}$ )& , work( n ), u, ldu ) return - end subroutine stdlib_${ri}$bdsdc + end subroutine stdlib${ii}$_${ri}$bdsdc - pure subroutine stdlib_${ri}$bdsqr( uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u,ldu, c, ldc, work, & + pure subroutine stdlib${ii}$_${ri}$bdsqr( uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u,ldu, c, ldc, work, & !! DBDSQR: computes the singular values and, optionally, the right and/or !! left singular vectors from the singular value decomposition (SVD) of !! a real N-by-N (upper or lower) bidiagonal matrix B using the implicit @@ -1422,8 +1424,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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) :: ldc, ldu, ldvt, n, ncc, ncvt, nru + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldc, ldu, ldvt, n, ncc, ncvt, nru ! Array Arguments real(${rk}$), intent(inout) :: c(ldc,*), d(*), e(*), u(ldu,*), vt(ldvt,*) real(${rk}$), intent(out) :: work(*) @@ -1432,7 +1434,7 @@ module stdlib_linalg_lapack_${ri}$ real(${rk}$), parameter :: hndrth = 0.01_${rk}$ real(${rk}$), parameter :: hndrd = 100.0_${rk}$ real(${rk}$), parameter :: meigth = -0.125_${rk}$ - integer(ilp), parameter :: maxitr = 6 + integer(${ik}$), parameter :: maxitr = 6_${ik}$ @@ -1443,7 +1445,7 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: lower, rotate - integer(ilp) :: i, idir, isub, iter, iterdivn, j, ll, lll, m, maxitdivn, nm1, nm12, & + integer(${ik}$) :: i, idir, isub, iter, iterdivn, j, ll, lll, m, maxitdivn, nm1, nm12, & nm13, oldll, oldm real(${rk}$) :: abse, abss, cosl, cosr, cs, eps, f, g, h, mu, oldcs, oldsn, r, shift, & sigmn, sigmx, sinl, sinr, sll, smax, smin, sminl, sminoa, sn, thresh, tol, tolmul, & @@ -1452,52 +1454,52 @@ module stdlib_linalg_lapack_${ri}$ intrinsic :: abs,real,max,min,sign,sqrt ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ lower = stdlib_lsame( uplo, 'L' ) if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.lower ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( ncvt<0 ) then - info = -3 - else if( nru<0 ) then - info = -4 - else if( ncc<0 ) then - info = -5 - else if( ( ncvt==0 .and. ldvt<1 ) .or.( ncvt>0 .and. ldvt0 .and. ldc0_${ik}$ .and. ldvt0_${ik}$ .and. ldc0 ) .or. ( nru>0 ) .or. ( ncc>0 ) + rotate = ( ncvt>0_${ik}$ ) .or. ( nru>0_${ik}$ ) .or. ( ncc>0_${ik}$ ) ! if no singular vectors desired, use qd algorithm if( .not.rotate ) then - call stdlib_${ri}$lasq1( n, d, e, work, info ) + call stdlib${ii}$_${ri}$lasq1( n, d, e, work, info ) ! if info equals 2, dqds didn't finish, try to finish if( info /= 2 ) return - info = 0 + info = 0_${ik}$ end if - nm1 = n - 1 + nm1 = n - 1_${ik}$ nm12 = nm1 + nm1 nm13 = nm12 + nm1 - idir = 0 + idir = 0_${ik}$ ! get machine constants - eps = stdlib_${ri}$lamch( 'EPSILON' ) - unfl = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_${ri}$lamch( 'EPSILON' ) + unfl = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) ! if matrix lower bidiagonal, rotate to be upper bidiagonal ! by applying givens rotations on the left if( lower ) then do i = 1, n - 1 - call stdlib_${ri}$lartg( d( i ), e( i ), cs, sn, r ) + call stdlib${ii}$_${ri}$lartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) @@ -1505,9 +1507,9 @@ module stdlib_linalg_lapack_${ri}$ work( nm1+i ) = sn end do ! update singular vectors if desired - if( nru>0 )call stdlib_${ri}$lasr( 'R', 'V', 'F', nru, n, work( 1 ), work( n ), u,ldu ) + if( nru>0_${ik}$ )call stdlib${ii}$_${ri}$lasr( 'R', 'V', 'F', nru, n, work( 1_${ik}$ ), work( n ), u,ldu ) - if( ncc>0 )call stdlib_${ri}$lasr( 'L', 'V', 'F', n, ncc, work( 1 ), work( n ), c,ldc ) + if( ncc>0_${ik}$ )call stdlib${ii}$_${ri}$lasr( 'L', 'V', 'F', n, ncc, work( 1_${ik}$ ), work( n ), c,ldc ) end if ! compute singular values to relative accuracy tol @@ -1526,7 +1528,7 @@ module stdlib_linalg_lapack_${ri}$ sminl = zero if( tol>=zero ) then ! relative accuracy desired - sminoa = abs( d( 1 ) ) + sminoa = abs( d( 1_${ik}$ ) ) if( sminoa==zero )go to 50 mu = sminoa do i = 2, n @@ -1545,10 +1547,10 @@ module stdlib_linalg_lapack_${ri}$ ! (maxit is the maximum number of passes through the inner ! loop permitted before nonconvergence signalled.) maxitdivn = maxitr*n - iterdivn = 0 - iter = -1 - oldll = -1 - oldm = -1 + iterdivn = 0_${ik}$ + iter = -1_${ik}$ + oldll = -1_${ik}$ + oldm = -1_${ik}$ ! m points to last element of unconverged part of matrix m = n ! begin main iteration loop @@ -1557,7 +1559,7 @@ module stdlib_linalg_lapack_${ri}$ if( m<=1 )go to 160 if( iter>=n ) then iter = iter - n - iterdivn = iterdivn + 1 + iterdivn = iterdivn + 1_${ik}$ if( iterdivn>=maxitdivn )go to 200 end if ! find diagonal block of matrix to work on @@ -1573,33 +1575,33 @@ module stdlib_linalg_lapack_${ri}$ smin = min( smin, abss ) smax = max( smax, abss, abse ) end do - ll = 0 + ll = 0_${ik}$ go to 90 80 continue e( ll ) = zero ! matrix splits since e(ll) = 0 if( ll==m-1 ) then ! convergence of bottom singular value, return to top of loop - m = m - 1 + m = m - 1_${ik}$ go to 60 end if 90 continue - ll = ll + 1 + ll = ll + 1_${ik}$ ! e(ll) through e(m-1) are nonzero, e(ll-1) is zero if( ll==m-1 ) then ! 2 by 2 block, handle separately - call stdlib_${ri}$lasv2( d( m-1 ), e( m-1 ), d( m ), sigmn, sigmx, sinr,cosr, sinl, cosl & + call stdlib${ii}$_${ri}$lasv2( d( m-1 ), e( m-1 ), d( m ), sigmn, sigmx, sinr,cosr, sinl, cosl & ) d( m-1 ) = sigmx e( m-1 ) = zero d( m ) = sigmn ! compute singular vectors, if desired - if( ncvt>0 )call stdlib_${ri}$rot( ncvt, vt( m-1, 1 ), ldvt, vt( m, 1 ), ldvt, cosr,sinr & + if( ncvt>0_${ik}$ )call stdlib${ii}$_${ri}$rot( ncvt, vt( m-1, 1_${ik}$ ), ldvt, vt( m, 1_${ik}$ ), ldvt, cosr,sinr & ) - if( nru>0 )call stdlib_${ri}$rot( nru, u( 1, m-1 ), 1, u( 1, m ), 1, cosl, sinl ) - if( ncc>0 )call stdlib_${ri}$rot( ncc, c( m-1, 1 ), ldc, c( m, 1 ), ldc, cosl,sinl ) + if( nru>0_${ik}$ )call stdlib${ii}$_${ri}$rot( nru, u( 1_${ik}$, m-1 ), 1_${ik}$, u( 1_${ik}$, m ), 1_${ik}$, cosl, sinl ) + if( ncc>0_${ik}$ )call stdlib${ii}$_${ri}$rot( ncc, c( m-1, 1_${ik}$ ), ldc, c( m, 1_${ik}$ ), ldc, cosl,sinl ) - m = m - 2 + m = m - 2_${ik}$ go to 60 end if ! if working on new submatrix, choose shift direction @@ -1607,14 +1609,14 @@ module stdlib_linalg_lapack_${ri}$ if( ll>oldm .or. m=abs( d( m ) ) ) then ! chase bulge from top (big end) to bottom (small end) - idir = 1 + idir = 1_${ik}$ else ! chase bulge from bottom (big end) to top (small end) - idir = 2 + idir = 2_${ik}$ end if end if ! apply convergence tests - if( idir==1 ) then + if( idir==1_${ik}$ ) then ! run convergence test in forward direction ! first apply standard test to bottom of matrix if( abs( e( m-1 ) )<=abs( tol )*abs( d( m ) ) .or.( tolzero ) then - if( ( shift / sll )**2ll )e( i-1 ) = oldsn*r - call stdlib_${ri}$lartg( oldcs*r, d( i+1 )*sn, oldcs, oldsn, d( i ) ) + call stdlib${ii}$_${ri}$lartg( oldcs*r, d( i+1 )*sn, oldcs, oldsn, d( i ) ) work( i-ll+1 ) = cs work( i-ll+1+nm1 ) = sn work( i-ll+1+nm12 ) = oldcs @@ -1702,12 +1704,12 @@ module stdlib_linalg_lapack_${ri}$ d( m ) = h*oldcs e( m-1 ) = h*oldsn ! update singular vectors - if( ncvt>0 )call stdlib_${ri}$lasr( 'L', 'V', 'F', m-ll+1, ncvt, work( 1 ),work( n ), & - vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_${ri}$lasr( 'R', 'V', 'F', nru, m-ll+1, work( nm12+1 ),work( & - nm13+1 ), u( 1, ll ), ldu ) - if( ncc>0 )call stdlib_${ri}$lasr( 'L', 'V', 'F', m-ll+1, ncc, work( nm12+1 ),work( & - nm13+1 ), c( ll, 1 ), ldc ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_${ri}$lasr( 'L', 'V', 'F', m-ll+1, ncvt, work( 1_${ik}$ ),work( n ), & + vt( ll, 1_${ik}$ ), ldvt ) + if( nru>0_${ik}$ )call stdlib${ii}$_${ri}$lasr( 'R', 'V', 'F', nru, m-ll+1, work( nm12+1 ),work( & + nm13+1 ), u( 1_${ik}$, ll ), ldu ) + if( ncc>0_${ik}$ )call stdlib${ii}$_${ri}$lasr( 'L', 'V', 'F', m-ll+1, ncc, work( nm12+1 ),work( & + nm13+1 ), c( ll, 1_${ik}$ ), ldc ) ! test convergence if( abs( e( m-1 ) )<=thresh )e( m-1 ) = zero else @@ -1716,9 +1718,9 @@ module stdlib_linalg_lapack_${ri}$ cs = one oldcs = one do i = m, ll + 1, -1 - call stdlib_${ri}$lartg( d( i )*cs, e( i-1 ), cs, sn, r ) + call stdlib${ii}$_${ri}$lartg( d( i )*cs, e( i-1 ), cs, sn, r ) if( i0 )call stdlib_${ri}$lasr( 'L', 'V', 'B', m-ll+1, ncvt, work( nm12+1 ),work( & - nm13+1 ), vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_${ri}$lasr( 'R', 'V', 'B', nru, m-ll+1, work( 1 ),work( n ), u(& - 1, ll ), ldu ) - if( ncc>0 )call stdlib_${ri}$lasr( 'L', 'V', 'B', m-ll+1, ncc, work( 1 ),work( n ), c(& - ll, 1 ), ldc ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_${ri}$lasr( 'L', 'V', 'B', m-ll+1, ncvt, work( nm12+1 ),work( & + nm13+1 ), vt( ll, 1_${ik}$ ), ldvt ) + if( nru>0_${ik}$ )call stdlib${ii}$_${ri}$lasr( 'R', 'V', 'B', nru, m-ll+1, work( 1_${ik}$ ),work( n ), u(& + 1_${ik}$, ll ), ldu ) + if( ncc>0_${ik}$ )call stdlib${ii}$_${ri}$lasr( 'L', 'V', 'B', m-ll+1, ncc, work( 1_${ik}$ ),work( n ), c(& + ll, 1_${ik}$ ), ldc ) ! test convergence if( abs( e( ll ) )<=thresh )e( ll ) = zero end if else ! use nonzero shift - if( idir==1 ) then + if( idir==1_${ik}$ ) then ! chase bulge from top to bottom ! save cosines and sines for later singular vector updates f = ( abs( d( ll ) )-shift )*( sign( one, d( ll ) )+shift / d( ll ) ) g = e( ll ) do i = ll, m - 1 - call stdlib_${ri}$lartg( f, g, cosr, sinr, r ) + call stdlib${ii}$_${ri}$lartg( f, g, cosr, sinr, r ) if( i>ll )e( i-1 ) = r f = cosr*d( i ) + sinr*e( i ) e( i ) = cosr*e( i ) - sinr*d( i ) g = sinr*d( i+1 ) d( i+1 ) = cosr*d( i+1 ) - call stdlib_${ri}$lartg( f, g, cosl, sinl, r ) + call stdlib${ii}$_${ri}$lartg( f, g, cosl, sinl, r ) d( i ) = r f = cosl*e( i ) + sinl*d( i+1 ) d( i+1 ) = cosl*d( i+1 ) - sinl*e( i ) @@ -1766,12 +1768,12 @@ module stdlib_linalg_lapack_${ri}$ end do e( m-1 ) = f ! update singular vectors - if( ncvt>0 )call stdlib_${ri}$lasr( 'L', 'V', 'F', m-ll+1, ncvt, work( 1 ),work( n ), & - vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_${ri}$lasr( 'R', 'V', 'F', nru, m-ll+1, work( nm12+1 ),work( & - nm13+1 ), u( 1, ll ), ldu ) - if( ncc>0 )call stdlib_${ri}$lasr( 'L', 'V', 'F', m-ll+1, ncc, work( nm12+1 ),work( & - nm13+1 ), c( ll, 1 ), ldc ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_${ri}$lasr( 'L', 'V', 'F', m-ll+1, ncvt, work( 1_${ik}$ ),work( n ), & + vt( ll, 1_${ik}$ ), ldvt ) + if( nru>0_${ik}$ )call stdlib${ii}$_${ri}$lasr( 'R', 'V', 'F', nru, m-ll+1, work( nm12+1 ),work( & + nm13+1 ), u( 1_${ik}$, ll ), ldu ) + if( ncc>0_${ik}$ )call stdlib${ii}$_${ri}$lasr( 'L', 'V', 'F', m-ll+1, ncc, work( nm12+1 ),work( & + nm13+1 ), c( ll, 1_${ik}$ ), ldc ) ! test convergence if( abs( e( m-1 ) )<=thresh )e( m-1 ) = zero else @@ -1780,13 +1782,13 @@ module stdlib_linalg_lapack_${ri}$ f = ( abs( d( m ) )-shift )*( sign( one, d( m ) )+shift /d( m ) ) g = e( m-1 ) do i = m, ll + 1, -1 - call stdlib_${ri}$lartg( f, g, cosr, sinr, r ) + call stdlib${ii}$_${ri}$lartg( f, g, cosr, sinr, r ) if( i0 )call stdlib_${ri}$lasr( 'L', 'V', 'B', m-ll+1, ncvt, work( nm12+1 ),work( & - nm13+1 ), vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_${ri}$lasr( 'R', 'V', 'B', nru, m-ll+1, work( 1 ),work( n ), u(& - 1, ll ), ldu ) - if( ncc>0 )call stdlib_${ri}$lasr( 'L', 'V', 'B', m-ll+1, ncc, work( 1 ),work( n ), c(& - ll, 1 ), ldc ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_${ri}$lasr( 'L', 'V', 'B', m-ll+1, ncvt, work( nm12+1 ),work( & + nm13+1 ), vt( ll, 1_${ik}$ ), ldvt ) + if( nru>0_${ik}$ )call stdlib${ii}$_${ri}$lasr( 'R', 'V', 'B', nru, m-ll+1, work( 1_${ik}$ ),work( n ), u(& + 1_${ik}$, ll ), ldu ) + if( ncc>0_${ik}$ )call stdlib${ii}$_${ri}$lasr( 'L', 'V', 'B', m-ll+1, ncc, work( 1_${ik}$ ),work( n ), c(& + ll, 1_${ik}$ ), ldc ) end if end if ! qr iteration finished, go back and check convergence @@ -1819,15 +1821,15 @@ module stdlib_linalg_lapack_${ri}$ if( d( i )0 )call stdlib_${ri}$scal( ncvt, negone, vt( i, 1 ), ldvt ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_${ri}$scal( ncvt, negone, vt( i, 1_${ik}$ ), ldvt ) end if end do ! sort the singular values into decreasing order (insertion sort on ! singular values, but only one transposition per singular vector) do i = 1, n - 1 ! scan for smallest d(i) - isub = 1 - smin = d( 1 ) + isub = 1_${ik}$ + smin = d( 1_${ik}$ ) do j = 2, n + 1 - i if( d( j )<=smin ) then isub = j @@ -1838,26 +1840,26 @@ module stdlib_linalg_lapack_${ri}$ ! swap singular values and vectors d( isub ) = d( n+1-i ) d( n+1-i ) = smin - if( ncvt>0 )call stdlib_${ri}$swap( ncvt, vt( isub, 1 ), ldvt, vt( n+1-i, 1 ),ldvt ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_${ri}$swap( ncvt, vt( isub, 1_${ik}$ ), ldvt, vt( n+1-i, 1_${ik}$ ),ldvt ) - if( nru>0 )call stdlib_${ri}$swap( nru, u( 1, isub ), 1, u( 1, n+1-i ), 1 ) - if( ncc>0 )call stdlib_${ri}$swap( ncc, c( isub, 1 ), ldc, c( n+1-i, 1 ), ldc ) + if( nru>0_${ik}$ )call stdlib${ii}$_${ri}$swap( nru, u( 1_${ik}$, isub ), 1_${ik}$, u( 1_${ik}$, n+1-i ), 1_${ik}$ ) + if( ncc>0_${ik}$ )call stdlib${ii}$_${ri}$swap( ncc, c( isub, 1_${ik}$ ), ldc, c( n+1-i, 1_${ik}$ ), ldc ) end if end do go to 220 ! maximum number of iterations exceeded, failure to converge 200 continue - info = 0 + info = 0_${ik}$ do i = 1, n - 1 - if( e( i )/=zero )info = info + 1 + if( e( i )/=zero )info = info + 1_${ik}$ end do 220 continue return - end subroutine stdlib_${ri}$bdsqr + end subroutine stdlib${ii}$_${ri}$bdsqr - pure subroutine stdlib_${ri}$disna( job, m, n, d, sep, info ) + pure subroutine stdlib${ii}$_${ri}$disna( job, m, n, d, sep, info ) !! DDISNA: computes the reciprocal condition numbers for the eigenvectors !! of a real symmetric or complex Hermitian matrix or for the left or !! right singular vectors of a general m-by-n matrix. The reciprocal @@ -1876,8 +1878,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: d(*) real(${rk}$), intent(out) :: sep(*) @@ -1885,13 +1887,13 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: decr, eigen, incr, left, right, sing - integer(ilp) :: i, k + integer(${ik}$) :: i, k real(${rk}$) :: 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' ) @@ -1902,11 +1904,11 @@ module stdlib_linalg_lapack_${ri}$ 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. @@ -1914,24 +1916,24 @@ module stdlib_linalg_lapack_${ri}$ 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( 'DDISNA', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DDISNA', -info ) return end if ! quick return if possible if( k==0 )return ! compute reciprocal condition numbers - if( k==1 ) then - sep( 1 ) = stdlib_${ri}$lamch( 'O' ) + if( k==1_${ik}$ ) then + sep( 1_${ik}$ ) = stdlib${ii}$_${ri}$lamch( '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 ) @@ -1941,15 +1943,15 @@ module stdlib_linalg_lapack_${ri}$ 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 + if( kl+ku>1_${ik}$ ) then ! reduce to upper bidiagonal form if ku > 0; if ku = 0, 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. @@ -2045,107 +2047,107 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$largv( nr, ab( klu1, j1-klm-1 ), inca,work( j1 ), kb1, & + if( nr>0_${ik}$ )call stdlib${ii}$_${ri}$largv( nr, ab( klu1, j1-klm-1 ), inca,work( j1 ), kb1, & work( mn+j1 ), kb1 ) ! apply plane rotations from the left do l = 1, kb if( j2-klm+l-1>n ) then - nrt = nr - 1 + nrt = nr - 1_${ik}$ else nrt = nr end if - if( nrt>0 )call stdlib_${ri}$lartv( nrt, ab( klu1-l, j1-klm+l-1 ), inca,ab( & + if( nrt>0_${ik}$ )call stdlib${ii}$_${ri}$lartv( nrt, ab( klu1-l, j1-klm+l-1 ), inca,ab( & klu1-l+1, j1-klm+l-1 ), inca,work( mn+j1 ), work( j1 ), kb1 ) end do if( ml>ml0 ) then if( ml<=m-i+1 ) then ! generate plane rotation to annihilate a(i+ml-1,i) ! within the band, and apply rotation from the left - call stdlib_${ri}$lartg( ab( ku+ml-1, i ), ab( ku+ml, i ),work( mn+i+ml-1 ), & + call stdlib${ii}$_${ri}$lartg( ab( ku+ml-1, i ), ab( ku+ml, i ),work( mn+i+ml-1 ), & work( i+ml-1 ),ra ) ab( ku+ml-1, i ) = ra - if( 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 ) + 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_${ri}$largv( nr, ab( 1, j1+kun-1 ), inca,work( j1+kun ), kb1,& + if( nr>0_${ik}$ )call stdlib${ii}$_${ri}$largv( 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_${ri}$lartv( nrt, ab( l+1, j1+kun-1 ), inca,ab( l, j1+& + if( nrt>0_${ik}$ )call stdlib${ii}$_${ri}$lartv( nrt, ab( l+1, j1+kun-1 ), inca,ab( l, j1+& kun ), inca,work( mn+j1+kun ), work( j1+kun ),kb1 ) end do if( ml==ml0 .and. mu>mu0 ) then if( mu<=n-i+1 ) then ! generate plane rotation to annihilate a(i,i+mu-1) ! within the band, and apply rotation from the right - call stdlib_${ri}$lartg( ab( ku-mu+3, i+mu-2 ),ab( ku-mu+2, i+mu-1 ),work( & + call stdlib${ii}$_${ri}$lartg( ab( ku-mu+3, i+mu-2 ),ab( ku-mu+2, i+mu-1 ),work( & mn+i+mu-1 ), work( i+mu-1 ),ra ) ab( ku-mu+3, i+mu-2 ) = ra - call stdlib_${ri}$rot( min( kl+mu-2, m-i ),ab( ku-mu+4, i+mu-2 ), 1,ab( ku-& - mu+3, i+mu-1 ), 1,work( mn+i+mu-1 ), work( i+mu-1 ) ) + call stdlib${ii}$_${ri}$rot( 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_${ri}$rot( n, pt( j+kun-1, 1 ), ldpt,pt( j+kun, 1 ), ldpt, work( & + call stdlib${ii}$_${ri}$rot( 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 @@ -2155,31 +2157,31 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$lartg( ab( 1, i ), ab( 2, i ), rc, rs, ra ) + call stdlib${ii}$_${ri}$lartg( 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_${ri}$rot( n, pt( i, 1 ), ldpt, pt( m+1, 1 ), ldpt,rc, rs ) + if( wantpt )call stdlib${ii}$_${ri}$rot( n, pt( i, 1_${ik}$ ), ldpt, pt( m+1, 1_${ik}$ ), ldpt,rc, rs ) end do else @@ -2212,14 +2214,14 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$gbbrd + end subroutine stdlib${ii}$_${ri}$gbbrd - pure subroutine stdlib_${ri}$gbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond,work, iwork, & + pure subroutine stdlib${ii}$_${ri}$gbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond,work, iwork, & !! DGBCON: estimates the reciprocal of the condition number of a real !! general band matrix A, in either the 1-norm or the infinity-norm, !! using the LU factorization computed by DGBTRF. @@ -2232,13 +2234,13 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: anorm real(${rk}$), 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(${rk}$), intent(in) :: ab(ldab,*) real(${rk}$), intent(out) :: work(*) ! ===================================================================== @@ -2246,56 +2248,56 @@ module stdlib_linalg_lapack_${ri}$ ! 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(${rk}$) :: 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 + info = 0_${ik}$ onenrm = norm=='1' .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_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_${ri}$lacn2( 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 @@ -2307,21 +2309,21 @@ module stdlib_linalg_lapack_${ri}$ work( jp ) = work( j ) work( j ) = t end if - call stdlib_${ri}$axpy( lm, -t, ab( kd+1, j ), 1, work( j+1 ), 1 ) + call stdlib${ii}$_${ri}$axpy( lm, -t, ab( kd+1, j ), 1_${ik}$, work( j+1 ), 1_${ik}$ ) end do end if ! multiply by inv(u). - call stdlib_${ri}$latbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, & - ldab, work, scale, work( 2*n+1 ),info ) + call stdlib${ii}$_${ri}$latbs( '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_${ri}$latbs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, ldab, & - work, scale, work( 2*n+1 ),info ) + call stdlib${ii}$_${ri}$latbs( '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_${ri}$dot( lm, ab( kd+1, j ), 1,work( j+1 ), 1 ) + work( j ) = work( j ) - stdlib${ii}$_${ri}$dot( lm, ab( kd+1, j ), 1_${ik}$,work( j+1 ), 1_${ik}$ ) jp = ipiv( j ) if( jp/=j ) then @@ -2335,9 +2337,9 @@ module stdlib_linalg_lapack_${ri}$ ! divide x by 1/scale if doing so will not cause overflow. normin = 'Y' if( scale/=one ) then - ix = stdlib_i${ri}$amax( n, work, 1 ) + ix = stdlib${ii}$_i${ri}$amax( 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. @@ -2593,7 +2595,7 @@ module stdlib_linalg_lapack_${ri}$ 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. @@ -2620,10 +2622,10 @@ module stdlib_linalg_lapack_${ri}$ colcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) end if return - end subroutine stdlib_${ri}$gbequb + end subroutine stdlib${ii}$_${ri}$gbequb - pure subroutine stdlib_${ri}$gbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb,ipiv, b, ldb, x, & + pure subroutine stdlib${ii}$_${ri}$gbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb,ipiv, b, ldb, x, & !! DGBRFS: 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. @@ -2633,17 +2635,17 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: ab(ldab,*), afb(ldafb,*), b(ldb,*) real(${rk}$), intent(out) :: berr(*), ferr(*), work(*) real(${rk}$), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: itmax = 5 + integer(${ik}$), parameter :: itmax = 5_${ik}$ @@ -2652,42 +2654,42 @@ module stdlib_linalg_lapack_${ri}$ ! 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(${rk}$) :: 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_${ri}$gbtrs( trans, n, kl, ku, 1, afb, ldafb, ipiv,work( n+1 ), n, info ) + call stdlib${ii}$_${ri}$gbtrs( trans, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work( n+1 ), n, info ) - call stdlib_${ri}$axpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) + call stdlib${ii}$_${ri}$axpy( 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 @@ -2791,14 +2793,14 @@ module stdlib_linalg_lapack_${ri}$ work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_${ri}$lacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) + call stdlib${ii}$_${ri}$lacn2( 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_${ri}$gbtrs( transt, n, kl, ku, 1, afb, ldafb, ipiv,work( n+1 ), n, & + call stdlib${ii}$_${ri}$gbtrs( 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 ) @@ -2808,7 +2810,7 @@ module stdlib_linalg_lapack_${ri}$ do i = 1, n work( n+i ) = work( n+i )*work( i ) end do - call stdlib_${ri}$gbtrs( trans, n, kl, ku, 1, afb, ldafb, ipiv,work( n+1 ), n, & + call stdlib${ii}$_${ri}$gbtrs( trans, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work( n+1 ), n, & info ) end if go to 100 @@ -2821,10 +2823,10 @@ module stdlib_linalg_lapack_${ri}$ if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_${ri}$gbrfs + end subroutine stdlib${ii}$_${ri}$gbrfs - pure subroutine stdlib_${ri}$gbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) + pure subroutine stdlib${ii}$_${ri}$gbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) !! DGBSV: computes the solution to a real system of linear equations !! A * X = B, where A is a band matrix of order N with KL subdiagonals !! and KU superdiagonals, and X and B are N-by-NRHS matrices. @@ -2837,46 +2839,46 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl, ku, ldab, ldb, n, nrhs ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) real(${rk}$), intent(inout) :: ab(ldab,*), b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 - if( n<0 ) then - info = -1 - else if( kl<0 ) then - info = -2 - else if( ku<0 ) then - info = -3 - else if( nrhs<0 ) then - info = -4 - else if( ldab<2*kl+ku+1 ) then - info = -6 - else if( ldb0 ) then + info = -13_${ik}$ + else if( n>0_${ik}$ ) then rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) else rowcnd = one end if end if - if( colequ .and. info==0 ) then + if( colequ .and. info==0_${ik}$ ) then rcmin = bignum rcmax = zero do j = 1, n @@ -2967,32 +2969,32 @@ module stdlib_linalg_lapack_${ri}$ rcmax = max( rcmax, c( j ) ) end do if( rcmin<=zero ) then - info = -14 - else if( n>0 ) then + info = -14_${ik}$ + else if( n>0_${ik}$ ) then colcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) else colcnd = one end if end if - if( info==0 ) then - if( ldb0 ) then + if( info>0_${ik}$ ) then ! compute the reciprocal pivot growth factor of the ! leading rank-deficient info columns of a. anorm = zero @@ -3033,14 +3035,14 @@ module stdlib_linalg_lapack_${ri}$ anorm = max( anorm, abs( ab( i, j ) ) ) end do end do - rpvgrw = stdlib_${ri}$lantb( 'M', 'U', 'N', info, min( info-1, kl+ku ),afb( max( 1, & - kl+ku+2-info ), 1 ), ldafb,work ) + rpvgrw = stdlib${ii}$_${ri}$lantb( 'M', 'U', 'N', info, min( info-1, kl+ku ),afb( max( 1_${ik}$, & + kl+ku+2-info ), 1_${ik}$ ), ldafb,work ) if( rpvgrw==zero ) then rpvgrw = one else rpvgrw = anorm / rpvgrw end if - work( 1 ) = rpvgrw + work( 1_${ik}$ ) = rpvgrw rcond = zero return end if @@ -3052,22 +3054,22 @@ module stdlib_linalg_lapack_${ri}$ else norm = 'I' end if - anorm = stdlib_${ri}$langb( norm, n, kl, ku, ab, ldab, work ) - rpvgrw = stdlib_${ri}$lantb( 'M', 'U', 'N', n, kl+ku, afb, ldafb, work ) + anorm = stdlib${ii}$_${ri}$langb( norm, n, kl, ku, ab, ldab, work ) + rpvgrw = stdlib${ii}$_${ri}$lantb( 'M', 'U', 'N', n, kl+ku, afb, ldafb, work ) if( rpvgrw==zero ) then rpvgrw = one else - rpvgrw = stdlib_${ri}$langb( 'M', n, kl, ku, ab, ldab, work ) / rpvgrw + rpvgrw = stdlib${ii}$_${ri}$langb( 'M', n, kl, ku, ab, ldab, work ) / rpvgrw end if ! compute the reciprocal of the condition number of a. - call stdlib_${ri}$gbcon( norm, n, kl, ku, afb, ldafb, ipiv, anorm, rcond,work, iwork, info ) + call stdlib${ii}$_${ri}$gbcon( norm, n, kl, ku, afb, ldafb, ipiv, anorm, rcond,work, iwork, info ) ! compute the solution matrix x. - call stdlib_${ri}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_${ri}$gbtrs( trans, n, kl, ku, nrhs, afb, ldafb, ipiv, x, ldx,info ) + call stdlib${ii}$_${ri}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_${ri}$gbtrs( trans, n, kl, ku, nrhs, afb, ldafb, ipiv, x, ldx,info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_${ri}$gbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv,b, ldb, x, ldx, & + call stdlib${ii}$_${ri}$gbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv,b, ldb, x, ldx, & ferr, berr, work, iwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -3093,13 +3095,13 @@ module stdlib_linalg_lapack_${ri}$ end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond0 ) then + if( jp/=1_${ik}$ )call stdlib${ii}$_${ri}$swap( 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_${ri}$scal( km, one / ab( kv+1, j ), ab( kv+2, j ), 1 ) + call stdlib${ii}$_${ri}$scal( km, one / ab( kv+1, j ), ab( kv+2, j ), 1_${ik}$ ) ! update trailing submatrix within the band. - if( ju>j )call stdlib_${ri}$ger( km, ju-j, -one, ab( kv+2, j ), 1,ab( kv, j+1 ), & + if( ju>j )call stdlib${ii}$_${ri}$ger( 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_${ri}$gbtf2 + end subroutine stdlib${ii}$_${ri}$gbtf2 - pure subroutine stdlib_${ri}$gbtrf( m, n, kl, ku, ab, ldab, ipiv, info ) + pure subroutine stdlib${ii}$_${ri}$gbtrf( m, n, kl, ku, ab, ldab, ipiv, info ) !! DGBTRF: computes an LU factorization of a real m-by-n band matrix A !! using partial pivoting with row interchanges. !! This is the blocked version of the algorithm, calling Level 3 BLAS. @@ -3193,19 +3195,19 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), 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(${rk}$) :: temp ! Local Arrays @@ -3217,32 +3219,32 @@ module stdlib_linalg_lapack_${ri}$ ! 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_${ri}$gbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) + call stdlib${ii}$_${ri}$gbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) else ! use blocked code ! zero the superdiagonal elements of the work array work13 @@ -3266,7 +3268,7 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -3292,57 +3294,57 @@ module stdlib_linalg_lapack_${ri}$ ! find pivot and test for singularity. km is the number of ! subdiagonal elements in the current column. km = min( kl, m-jj ) - jp = stdlib_i${ri}$amax( km+1, ab( kv+1, jj ), 1 ) + jp = stdlib${ii}$_i${ri}$amax( 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_${ri}$ger( 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}$_${ri}$ger( 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_${ri}$copy( nw, ab( kv+kl+1-jj+j, jj ), 1,work31( 1, jj-j+1 )& - , 1 ) + if( nw>0_${ik}$ )call stdlib${ii}$_${ri}$copy( 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_${ri}$laswp to apply the row interchanges to a12, a22, and ! a32. - call stdlib_${ri}$laswp( j2, ab( kv+1-jb, j+jb ), ldab-1, 1, jb,ipiv( j ), 1 ) + call stdlib${ii}$_${ri}$laswp( 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 @@ -3355,24 +3357,24 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j2, one, ab(& + call stdlib${ii}$_${ri}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j2, one, ab(& kv+1, j ), ldab-1,ab( kv+1-jb, j+jb ), ldab-1 ) - if( i2>0 ) then + if( i2>0_${ik}$ ) then ! update a22 - call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j2,jb, -one, ab( & + call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j2,jb, -one, ab( & kv+1+jb, j ), ldab-1,ab( kv+1-jb, j+jb ), ldab-1, one,ab( kv+1, j+jb ), & ldab-1 ) end if - if( i3>0 ) then + if( i3>0_${ik}$ ) then ! update a32 - call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j2,jb, -one, & + call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j2,jb, -one, & work31, ldwork,ab( kv+1-jb, j+jb ), ldab-1, one,ab( kv+kl+1-jb, j+jb ), & ldab-1 ) end if 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 @@ -3381,18 +3383,18 @@ module stdlib_linalg_lapack_${ri}$ end do end do ! update a13 in the work array - call stdlib_${ri}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j3, one, ab(& + call stdlib${ii}$_${ri}$trsm( '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_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j3,jb, -one, ab( & - kv+1+jb, j ), ldab-1,work13, ldwork, one, ab( 1+jb, j+kv ),ldab-1 ) + call stdlib${ii}$_${ri}$gemm( '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_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j3,jb, -one, & - work31, ldwork, work13,ldwork, one, ab( 1+kl, j+kv ), ldab-1 ) + call stdlib${ii}$_${ri}$gemm( '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 @@ -3404,38 +3406,38 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$copy( nw, work31( 1, jj-j+1 ), 1,ab( kv+kl+1-jj+j, jj )& - , 1 ) + if( nw>0_${ik}$ )call stdlib${ii}$_${ri}$copy( 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_${ri}$gbtrf + end subroutine stdlib${ii}$_${ri}$gbtrf - pure subroutine stdlib_${ri}$gbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info ) + pure subroutine stdlib${ii}$_${ri}$gbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info ) !! DGBTRS: solves a system of linear equations !! A * X = B or A**T * X = B !! with a general band matrix A using the LU factorization computed @@ -3445,47 +3447,47 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: ab(ldab,*) real(${rk}$), 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. @@ -3497,39 +3499,39 @@ module stdlib_linalg_lapack_${ri}$ do j = 1, n - 1 lm = min( kl, n-j ) l = ipiv( j ) - if( l/=j )call stdlib_${ri}$swap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) - call stdlib_${ri}$ger( lm, nrhs, -one, ab( kd+1, j ), 1, b( j, 1 ),ldb, b( j+1, 1 )& + if( l/=j )call stdlib${ii}$_${ri}$swap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ri}$ger( 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_${ri}$tbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kl+ku,ab, ldab, b( 1, & - i ), 1 ) + call stdlib${ii}$_${ri}$tbsv( '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_${ri}$tbsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, kl+ku, ab,ldab, b( 1, i )& - , 1 ) + call stdlib${ii}$_${ri}$tbsv( '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_${ri}$gemv( 'TRANSPOSE', lm, nrhs, -one, b( j+1, 1 ),ldb, ab( kd+1, j )& - , 1, one, b( j, 1 ), ldb ) + call stdlib${ii}$_${ri}$gemv( '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_${ri}$swap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) + if( l/=j )call stdlib${ii}$_${ri}$swap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb ) end do end if end if return - end subroutine stdlib_${ri}$gbtrs + end subroutine stdlib${ii}$_${ri}$gbtrs - pure subroutine stdlib_${ri}$gebak( job, side, n, ilo, ihi, scale, m, v, ldv,info ) + pure subroutine stdlib${ii}$_${ri}$gebak( job, side, n, ilo, ihi, scale, m, v, ldv,info ) !! DGEBAK: forms the right or left eigenvectors of a real general matrix !! by backward transformation on the computed eigenvectors of the !! balanced matrix output by DGEBAL. @@ -3538,8 +3540,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: scale(*) real(${rk}$), intent(inout) :: v(ldv,*) @@ -3547,7 +3549,7 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: leftv, rightv - integer(ilp) :: i, ii, k + integer(${ik}$) :: i, ii, k real(${rk}$) :: s ! Intrinsic Functions intrinsic :: max,min @@ -3555,25 +3557,25 @@ module stdlib_linalg_lapack_${ri}$ ! 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( ldv=g .or. max( f, c, ca )>=sfmax2 .or.min( r, g, ra )<=sfmin2 )go to 170 - if( stdlib_${ri}$isnan( c+f+ca+r+g+ra ) ) then + if( stdlib${ii}$_${ri}$isnan( c+f+ca+r+g+ra ) ) then ! exit if nan to avoid infinite loop - info = -3 - call stdlib_xerbla( 'DGEBAL', -info ) + info = -3_${ik}$ + call stdlib${ii}$_xerbla( 'DGEBAL', -info ) return end if f = f*sclfac @@ -3783,18 +3785,18 @@ module stdlib_linalg_lapack_${ri}$ g = one / f scale( i ) = scale( i )*f noconv = .true. - call stdlib_${ri}$scal( n-k+1, g, a( i, k ), lda ) - call stdlib_${ri}$scal( l, f, a( 1, i ), 1 ) + call stdlib${ii}$_${ri}$scal( n-k+1, g, a( i, k ), lda ) + call stdlib${ii}$_${ri}$scal( l, f, a( 1_${ik}$, i ), 1_${ik}$ ) end do loop_200 if( noconv )go to 140 210 continue ilo = k ihi = l return - end subroutine stdlib_${ri}$gebal + end subroutine stdlib${ii}$_${ri}$gebal - pure subroutine stdlib_${ri}$gebd2( m, n, a, lda, d, e, tauq, taup, work, info ) + pure subroutine stdlib${ii}$_${ri}$gebd2( m, n, a, lda, d, e, tauq, taup, work, info ) !! DGEBD2: reduces a real general m by n matrix A to upper or lower !! bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. !! If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. @@ -3802,52 +3804,52 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: d(*), e(*), taup(*), tauq(*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i ! 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=n ) then ! reduce to upper bidiagonal form do i = 1, n ! generate elementary reflector h(i) to annihilate a(i+1:m,i) - call stdlib_${ri}$larfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,tauq( i ) ) + call stdlib${ii}$_${ri}$larfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,tauq( i ) ) d( i ) = a( i, i ) a( i, i ) = one ! apply h(i) to a(i:m,i+1:n) from the left - if( i= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. @@ -3894,8 +3896,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, lwork, m, n ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: d(*), e(*), taup(*), tauq(*), work(*) @@ -3903,54 +3905,54 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, iinfo, j, ldwrkx, ldwrky, lwkopt, minmn, nb, nbmin, nx, ws + integer(${ik}$) :: i, iinfo, j, ldwrkx, ldwrky, lwkopt, minmn, nb, nbmin, nx, ws ! Intrinsic Functions intrinsic :: real,max,min ! Executable Statements ! test the input parameters - info = 0 - nb = max( 1, stdlib_ilaenv( 1, 'DGEBRD', ' ', m, n, -1, -1 ) ) + info = 0_${ik}$ + nb = max( 1_${ik}$, stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEBRD', ' ', m, n, -1_${ik}$, -1_${ik}$ ) ) lwkopt = ( m+n )*nb - work( 1 ) = real( lwkopt,KIND=${rk}$) - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda1 .and. nb1_${ik}$ .and. nb=( m+n )*nbmin ) then nb = lwork / ( m+n ) else - nb = 1 + nb = 1_${ik}$ nx = minmn end if end if @@ -3962,13 +3964,13 @@ module stdlib_linalg_lapack_${ri}$ ! reduce rows and columns i:i+nb-1 to bidiagonal form and return ! the matrices x and y which are needed to update the unreduced ! part of the matrix - call stdlib_${ri}$labrd( m-i+1, n-i+1, nb, a( i, i ), lda, d( i ), e( i ),tauq( i ), & + call stdlib${ii}$_${ri}$labrd( m-i+1, n-i+1, nb, a( i, i ), lda, d( i ), e( i ),tauq( i ), & taup( i ), work, ldwrkx,work( ldwrkx*nb+1 ), ldwrky ) ! update the trailing submatrix a(i+nb:m,i+nb:n), using an update ! of the form a := a - v*y**t - x*u**t - call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m-i-nb+1, n-i-nb+1,nb, -one, a( i+& + call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m-i-nb+1, n-i-nb+1,nb, -one, a( i+& nb, i ), lda,work( ldwrkx*nb+nb+1 ), ldwrky, one,a( i+nb, i+nb ), lda ) - call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-i-nb+1, n-i-nb+1,nb, -one, & + call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-i-nb+1, n-i-nb+1,nb, -one, & work( nb+1 ), ldwrkx, a( i, i+nb ), lda,one, a( i+nb, i+nb ), lda ) ! copy diagonal and off-diagonal elements of b back into a if( m>=n ) then @@ -3984,14 +3986,14 @@ module stdlib_linalg_lapack_${ri}$ end if end do ! use unblocked code to reduce the remainder of the matrix - call stdlib_${ri}$gebd2( m-i+1, n-i+1, a( i, i ), lda, d( i ), e( i ),tauq( i ), taup( i ), & + call stdlib${ii}$_${ri}$gebd2( m-i+1, n-i+1, a( i, i ), lda, d( i ), e( i ),tauq( i ), taup( i ), & work, iinfo ) - work( 1 ) = ws + work( 1_${ik}$ ) = ws return - end subroutine stdlib_${ri}$gebrd + end subroutine stdlib${ii}$_${ri}$gebrd - pure subroutine stdlib_${ri}$gecon( norm, n, a, lda, anorm, rcond, work, iwork,info ) + pure subroutine stdlib${ii}$_${ri}$gecon( norm, n, a, lda, anorm, rcond, work, iwork,info ) !! DGECON: estimates the reciprocal of the condition number of a general !! real matrix A, in either the 1-norm or the infinity-norm, using !! the LU factorization computed by DGETRF. @@ -4003,12 +4005,12 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: anorm real(${rk}$), intent(out) :: rcond ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: work(*) ! ===================================================================== @@ -4016,72 +4018,72 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: onenrm character :: normin - integer(ilp) :: ix, kase, kase1 + integer(${ik}$) :: ix, kase, kase1 real(${rk}$) :: 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 + info = 0_${ik}$ onenrm = norm=='1' .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. @@ -4324,7 +4326,7 @@ module stdlib_linalg_lapack_${ri}$ 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. @@ -4351,10 +4353,10 @@ module stdlib_linalg_lapack_${ri}$ colcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) end if return - end subroutine stdlib_${ri}$geequb + end subroutine stdlib${ii}$_${ri}$geequb - subroutine stdlib_${ri}$gees( jobvs, sort, select, n, a, lda, sdim, wr, wi,vs, ldvs, work, lwork, & + subroutine stdlib${ii}$_${ri}$gees( jobvs, sort, select, n, a, lda, sdim, wr, wi,vs, ldvs, work, lwork, & !! DGEES: computes for an N-by-N real nonsymmetric matrix A, the !! eigenvalues, the real Schur form T, and, optionally, the matrix of !! Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). @@ -4374,8 +4376,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvs, sort - integer(ilp), intent(out) :: info, sdim - integer(ilp), intent(in) :: lda, ldvs, lwork, n + integer(${ik}$), intent(out) :: info, sdim + integer(${ik}$), intent(in) :: lda, ldvs, lwork, n ! Array Arguments logical(lk), intent(out) :: bwork(*) real(${rk}$), intent(inout) :: a(lda,*) @@ -4386,83 +4388,83 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: cursl, lastsl, lquery, lst2sl, scalea, wantst, wantvs - integer(ilp) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, & + integer(${ik}$) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, & iwrk, maxwrk, minwrk real(${rk}$) :: anrm, bignum, cscale, eps, s, sep, smlnum ! Local Arrays - integer(ilp) :: idum(1) - real(${rk}$) :: dum(1) + integer(${ik}$) :: idum(1_${ik}$) + real(${rk}$) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) wantvs = stdlib_lsame( jobvs, 'V' ) wantst = stdlib_lsame( sort, 'S' ) if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then - info = -2 - else if( n<0 ) then - info = -4 - else if( ldazero .and. anrm0 )info = ieval + if( ieval>0_${ik}$ )info = ieval ! sort eigenvalues if desired - if( wantst .and. info==0 ) then + if( wantst .and. info==0_${ik}$ ) then if( scalea ) then - call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, n, 1, wr, n, ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, n, 1, wi, n, ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wr, n, ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wi, n, ierr ) end if do i = 1, n bwork( i ) = select( wr( i ), wi( i ) ) end do ! reorder eigenvalues and transform schur vectors ! (workspace: none needed) - call stdlib_${ri}$trsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, s, sep, & - work( iwrk ), lwork-iwrk+1, idum, 1,icond ) - if( icond>0 )info = n + icond + call stdlib${ii}$_${ri}$trsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, s, sep, & + work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$,icond ) + if( icond>0_${ik}$ )info = n + icond end if if( wantvs ) then ! undo balancing ! (workspace: need n) - call stdlib_${ri}$gebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr ) + call stdlib${ii}$_${ri}$gebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr ) end if if( scalea ) then ! undo scaling for the schur form of a - call stdlib_${ri}$lascl( 'H', 0, 0, cscale, anrm, n, n, a, lda, ierr ) - call stdlib_${ri}$copy( n, a, lda+1, wr, 1 ) + call stdlib${ii}$_${ri}$lascl( 'H', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_${ri}$copy( n, a, lda+1, wr, 1_${ik}$ ) if( cscale==smlnum ) then ! if scaling back towards underflow, adjust wi if an ! offdiagonal element of a 2-by-2 block in the schur form ! underflows. - if( ieval>0 ) then - i1 = ieval + 1 - i2 = ihi - 1 - call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wi,max( ilo-1, 1 ), & + if( ieval>0_${ik}$ ) then + i1 = ieval + 1_${ik}$ + i2 = ihi - 1_${ik}$ + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi,max( ilo-1, 1_${ik}$ ), & ierr ) else if( wantst ) then - i1 = 1 - i2 = n - 1 + i1 = 1_${ik}$ + i2 = n - 1_${ik}$ else i1 = ilo - i2 = ihi - 1 + i2 = ihi - 1_${ik}$ end if - inxt = i1 - 1 + inxt = i1 - 1_${ik}$ loop_20: do i = i1, i2 if( i1 )call stdlib_${ri}$swap( i-1, a( 1, i ), 1, a( 1, i+1 ), 1 ) - if( n>i+1 )call stdlib_${ri}$swap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), & + if( i>1_${ik}$ )call stdlib${ii}$_${ri}$swap( i-1, a( 1_${ik}$, i ), 1_${ik}$, a( 1_${ik}$, i+1 ), 1_${ik}$ ) + if( n>i+1 )call stdlib${ii}$_${ri}$swap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), & lda ) if( wantvs ) then - call stdlib_${ri}$swap( n, vs( 1, i ), 1, vs( 1, i+1 ), 1 ) + call stdlib${ii}$_${ri}$swap( n, vs( 1_${ik}$, i ), 1_${ik}$, vs( 1_${ik}$, i+1 ), 1_${ik}$ ) end if a( i, i+1 ) = a( i+1, i ) a( i+1, i ) = zero end if - inxt = i + 2 + inxt = i + 2_${ik}$ end if end do loop_20 end if ! undo scaling for the imaginary part of the eigenvalues - call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, n-ieval, 1,wi( ieval+1 ), max( n-ieval,& - 1 ), ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-ieval, 1_${ik}$,wi( ieval+1 ), max( n-ieval,& + 1_${ik}$ ), ierr ) end if - if( wantst .and. info==0 ) then + if( wantst .and. info==0_${ik}$ ) then ! check if reordering successful lastsl = .true. lst2sl = .true. - sdim = 0 - ip = 0 + sdim = 0_${ik}$ + ip = 0_${ik}$ do i = 1, n cursl = select( wr( i ), wi( i ) ) if( wi( i )==zero ) then - if( cursl )sdim = sdim + 1 - ip = 0 - if( cursl .and. .not.lastsl )info = n + 2 + if( cursl )sdim = sdim + 1_${ik}$ + ip = 0_${ik}$ + if( cursl .and. .not.lastsl )info = n + 2_${ik}$ else - if( ip==1 ) then + if( ip==1_${ik}$ ) then ! last eigenvalue of conjugate pair cursl = cursl .or. lastsl lastsl = cursl - if( cursl )sdim = sdim + 2 - ip = -1 - if( cursl .and. .not.lst2sl )info = n + 2 + if( cursl )sdim = sdim + 2_${ik}$ + ip = -1_${ik}$ + if( cursl .and. .not.lst2sl )info = n + 2_${ik}$ else ! first eigenvalue of conjugate pair - ip = 1 + ip = 1_${ik}$ end if end if lst2sl = lastsl lastsl = cursl end do end if - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_${ri}$gees + end subroutine stdlib${ii}$_${ri}$gees - subroutine stdlib_${ri}$geesx( jobvs, sort, select, sense, n, a, lda, sdim,wr, wi, vs, ldvs, & + subroutine stdlib${ii}$_${ri}$geesx( jobvs, sort, select, sense, n, a, lda, sdim,wr, wi, vs, ldvs, & !! DGEESX: computes for an N-by-N real nonsymmetric matrix A, the !! eigenvalues, the real Schur form T, and, optionally, the matrix of !! Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). @@ -4626,12 +4628,12 @@ module stdlib_linalg_lapack_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvs, sense, sort - integer(ilp), intent(out) :: info, sdim - integer(ilp), intent(in) :: lda, ldvs, liwork, lwork, n + integer(${ik}$), intent(out) :: info, sdim + integer(${ik}$), intent(in) :: lda, ldvs, liwork, lwork, n real(${rk}$), intent(out) :: rconde, rcondv ! Array Arguments logical(lk), intent(out) :: bwork(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: vs(ldvs,*), wi(*), work(*), wr(*) ! Function Arguments @@ -4641,36 +4643,36 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: cursl, lastsl, lquery, lst2sl, scalea, wantsb, wantse, wantsn, wantst, & wantsv, wantvs - integer(ilp) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, & + integer(${ik}$) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, & iwrk, liwrk, lwrk, maxwrk, minwrk real(${rk}$) :: anrm, bignum, cscale, eps, smlnum ! Local Arrays - real(${rk}$) :: dum(1) + real(${rk}$) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ wantvs = stdlib_lsame( jobvs, 'V' ) wantst = stdlib_lsame( sort, 'S' ) wantsn = stdlib_lsame( sense, 'N' ) wantse = stdlib_lsame( sense, 'E' ) wantsv = stdlib_lsame( sense, 'V' ) wantsb = stdlib_lsame( sense, 'B' ) - lquery = ( lwork==-1 .or. liwork==-1 ) + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. & .not.wantsn ) ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( ldazero .and. anrm0 )info = ieval + if( ieval>0_${ik}$ )info = ieval ! sort eigenvalues if desired - if( wantst .and. info==0 ) then + if( wantst .and. info==0_${ik}$ ) then if( scalea ) then - call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, n, 1, wr, n, ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, n, 1, wi, n, ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wr, n, ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wi, n, ierr ) end if do i = 1, n bwork( i ) = select( wr( i ), wi( i ) ) @@ -4784,54 +4786,54 @@ module stdlib_linalg_lapack_${ri}$ ! otherwise, need n ) ! (iworkspace: if sense is 'v' or 'b', need sdim*(n-sdim) ! otherwise, need 0 ) - call stdlib_${ri}$trsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, rconde, & + call stdlib${ii}$_${ri}$trsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, rconde, & rcondv, work( iwrk ), lwork-iwrk+1,iwork, liwork, icond ) if( .not.wantsn )maxwrk = max( maxwrk, n+2*sdim*( n-sdim ) ) - if( icond==-15 ) then + if( icond==-15_${ik}$ ) then ! not enough real workspace - info = -16 - else if( icond==-17 ) then + info = -16_${ik}$ + else if( icond==-17_${ik}$ ) then ! not enough integer workspace - info = -18 - else if( icond>0 ) then - ! stdlib_${ri}$trsen failed to reorder or to restore standard schur form + info = -18_${ik}$ + else if( icond>0_${ik}$ ) then + ! stdlib${ii}$_${ri}$trsen failed to reorder or to restore standard schur form info = icond + n end if end if if( wantvs ) then ! undo balancing ! (rworkspace: need n) - call stdlib_${ri}$gebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr ) + call stdlib${ii}$_${ri}$gebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr ) end if if( scalea ) then ! undo scaling for the schur form of a - call stdlib_${ri}$lascl( 'H', 0, 0, cscale, anrm, n, n, a, lda, ierr ) - call stdlib_${ri}$copy( n, a, lda+1, wr, 1 ) - if( ( wantsv .or. wantsb ) .and. info==0 ) then - dum( 1 ) = rcondv - call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, 1, 1, dum, 1, ierr ) - rcondv = dum( 1 ) + call stdlib${ii}$_${ri}$lascl( 'H', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_${ri}$copy( n, a, lda+1, wr, 1_${ik}$ ) + if( ( wantsv .or. wantsb ) .and. info==0_${ik}$ ) then + dum( 1_${ik}$ ) = rcondv + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr ) + rcondv = dum( 1_${ik}$ ) end if if( cscale==smlnum ) then ! if scaling back towards underflow, adjust wi if an ! offdiagonal element of a 2-by-2 block in the schur form ! underflows. - if( ieval>0 ) then - i1 = ieval + 1 - i2 = ihi - 1 - call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wi, n,ierr ) + if( ieval>0_${ik}$ ) then + i1 = ieval + 1_${ik}$ + i2 = ihi - 1_${ik}$ + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr ) else if( wantst ) then - i1 = 1 - i2 = n - 1 + i1 = 1_${ik}$ + i2 = n - 1_${ik}$ else i1 = ilo - i2 = ihi - 1 + i2 = ihi - 1_${ik}$ end if - inxt = i1 - 1 + inxt = i1 - 1_${ik}$ loop_20: do i = i1, i2 if( i1 )call stdlib_${ri}$swap( i-1, a( 1, i ), 1, a( 1, i+1 ), 1 ) - if( n>i+1 )call stdlib_${ri}$swap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), & + if( i>1_${ik}$ )call stdlib${ii}$_${ri}$swap( i-1, a( 1_${ik}$, i ), 1_${ik}$, a( 1_${ik}$, i+1 ), 1_${ik}$ ) + if( n>i+1 )call stdlib${ii}$_${ri}$swap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), & lda ) if( wantvs ) then - call stdlib_${ri}$swap( n, vs( 1, i ), 1, vs( 1, i+1 ), 1 ) + call stdlib${ii}$_${ri}$swap( n, vs( 1_${ik}$, i ), 1_${ik}$, vs( 1_${ik}$, i+1 ), 1_${ik}$ ) end if a( i, i+1 ) = a( i+1, i ) a( i+1, i ) = zero end if - inxt = i + 2 + inxt = i + 2_${ik}$ end if end do loop_20 end if - call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, n-ieval, 1,wi( ieval+1 ), max( n-ieval,& - 1 ), ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-ieval, 1_${ik}$,wi( ieval+1 ), max( n-ieval,& + 1_${ik}$ ), ierr ) end if - if( wantst .and. info==0 ) then + if( wantst .and. info==0_${ik}$ ) then ! check if reordering successful lastsl = .true. lst2sl = .true. - sdim = 0 - ip = 0 + sdim = 0_${ik}$ + ip = 0_${ik}$ do i = 1, n cursl = select( wr( i ), wi( i ) ) if( wi( i )==zero ) then - if( cursl )sdim = sdim + 1 - ip = 0 - if( cursl .and. .not.lastsl )info = n + 2 + if( cursl )sdim = sdim + 1_${ik}$ + ip = 0_${ik}$ + if( cursl .and. .not.lastsl )info = n + 2_${ik}$ else - if( ip==1 ) then + if( ip==1_${ik}$ ) then ! last eigenvalue of conjugate pair cursl = cursl .or. lastsl lastsl = cursl - if( cursl )sdim = sdim + 2 - ip = -1 - if( cursl .and. .not.lst2sl )info = n + 2 + if( cursl )sdim = sdim + 2_${ik}$ + ip = -1_${ik}$ + if( cursl .and. .not.lst2sl )info = n + 2_${ik}$ else ! first eigenvalue of conjugate pair - ip = 1 + ip = 1_${ik}$ end if end if lst2sl = lastsl lastsl = cursl end do end if - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk if( wantsv .or. wantsb ) then - iwork( 1 ) = max( 1, sdim*( n-sdim ) ) + iwork( 1_${ik}$ ) = max( 1_${ik}$, sdim*( n-sdim ) ) else - iwork( 1 ) = 1 + iwork( 1_${ik}$ ) = 1_${ik}$ end if return - end subroutine stdlib_${ri}$geesx + end subroutine stdlib${ii}$_${ri}$geesx - subroutine stdlib_${ri}$geev( jobvl, jobvr, n, a, lda, wr, wi, vl, ldvl, vr,ldvr, work, lwork, & + subroutine stdlib${ii}$_${ri}$geev( jobvl, jobvr, n, a, lda, wr, wi, vl, ldvl, vr,ldvr, work, lwork, & !! DGEEV: computes for an N-by-N real nonsymmetric matrix A, the !! eigenvalues and, optionally, the left and/or right eigenvectors. !! The right eigenvector v(j) of A satisfies @@ -4911,8 +4913,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvl, jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: vl(ldvl,*), vr(ldvr,*), wi(*), work(*), wr(*) @@ -4921,90 +4923,90 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: lquery, scalea, wantvl, wantvr character :: side - integer(ilp) :: hswork, i, ibal, ierr, ihi, ilo, itau, iwrk, k, lwork_trevc, maxwrk, & + integer(${ik}$) :: hswork, i, ibal, ierr, ihi, ilo, itau, iwrk, k, lwork_trevc, maxwrk, & minwrk, nout real(${rk}$) :: anrm, bignum, cs, cscale, eps, r, scl, smlnum, sn ! Local Arrays - logical(lk) :: select(1) - real(${rk}$) :: dum(1) + logical(lk) :: select(1_${ik}$) + real(${rk}$) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) wantvl = stdlib_lsame( jobvl, 'V' ) wantvr = stdlib_lsame( jobvr, 'V' ) if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldazero .and. anrmzero ) then - scl = one / stdlib_${ri}$lapy2( stdlib_${ri}$nrm2( n, vl( 1, i ), 1 ),stdlib_${ri}$nrm2( n, & - vl( 1, i+1 ), 1 ) ) - call stdlib_${ri}$scal( n, scl, vl( 1, i ), 1 ) - call stdlib_${ri}$scal( n, scl, vl( 1, i+1 ), 1 ) + scl = one / stdlib${ii}$_${ri}$lapy2( stdlib${ii}$_${ri}$nrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_${ri}$nrm2( n, & + vl( 1_${ik}$, i+1 ), 1_${ik}$ ) ) + call stdlib${ii}$_${ri}$scal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n, scl, vl( 1_${ik}$, i+1 ), 1_${ik}$ ) do k = 1, n - work( iwrk+k-1 ) = vl( k, i )**2 + vl( k, i+1 )**2 + work( iwrk+k-1 ) = vl( k, i )**2_${ik}$ + vl( k, i+1 )**2_${ik}$ end do - k = stdlib_i${ri}$amax( n, work( iwrk ), 1 ) - call stdlib_${ri}$lartg( vl( k, i ), vl( k, i+1 ), cs, sn, r ) - call stdlib_${ri}$rot( n, vl( 1, i ), 1, vl( 1, i+1 ), 1, cs, sn ) + k = stdlib${ii}$_i${ri}$amax( n, work( iwrk ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$lartg( vl( k, i ), vl( k, i+1 ), cs, sn, r ) + call stdlib${ii}$_${ri}$rot( n, vl( 1_${ik}$, i ), 1_${ik}$, vl( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn ) vl( k, i+1 ) = zero end if end do @@ -5115,23 +5117,23 @@ module stdlib_linalg_lapack_${ri}$ if( wantvr ) then ! undo balancing of right eigenvectors ! (workspace: need n) - call stdlib_${ri}$gebak( 'B', 'R', n, ilo, ihi, work( ibal ), n, vr, ldvr,ierr ) + call stdlib${ii}$_${ri}$gebak( 'B', 'R', n, ilo, ihi, work( ibal ), n, vr, ldvr,ierr ) ! normalize right eigenvectors and make largest component real do i = 1, n if( wi( i )==zero ) then - scl = one / stdlib_${ri}$nrm2( n, vr( 1, i ), 1 ) - call stdlib_${ri}$scal( n, scl, vr( 1, i ), 1 ) + scl = one / stdlib${ii}$_${ri}$nrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ ) else if( wi( i )>zero ) then - scl = one / stdlib_${ri}$lapy2( stdlib_${ri}$nrm2( n, vr( 1, i ), 1 ),stdlib_${ri}$nrm2( n, & - vr( 1, i+1 ), 1 ) ) - call stdlib_${ri}$scal( n, scl, vr( 1, i ), 1 ) - call stdlib_${ri}$scal( n, scl, vr( 1, i+1 ), 1 ) + scl = one / stdlib${ii}$_${ri}$lapy2( stdlib${ii}$_${ri}$nrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_${ri}$nrm2( n, & + vr( 1_${ik}$, i+1 ), 1_${ik}$ ) ) + call stdlib${ii}$_${ri}$scal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n, scl, vr( 1_${ik}$, i+1 ), 1_${ik}$ ) do k = 1, n - work( iwrk+k-1 ) = vr( k, i )**2 + vr( k, i+1 )**2 + work( iwrk+k-1 ) = vr( k, i )**2_${ik}$ + vr( k, i+1 )**2_${ik}$ end do - k = stdlib_i${ri}$amax( n, work( iwrk ), 1 ) - call stdlib_${ri}$lartg( vr( k, i ), vr( k, i+1 ), cs, sn, r ) - call stdlib_${ri}$rot( n, vr( 1, i ), 1, vr( 1, i+1 ), 1, cs, sn ) + k = stdlib${ii}$_i${ri}$amax( n, work( iwrk ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$lartg( vr( k, i ), vr( k, i+1 ), cs, sn, r ) + call stdlib${ii}$_${ri}$rot( n, vr( 1_${ik}$, i ), 1_${ik}$, vr( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn ) vr( k, i+1 ) = zero end if end do @@ -5139,21 +5141,21 @@ module stdlib_linalg_lapack_${ri}$ ! undo scaling if necessary 50 continue if( scalea ) then - call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, n-info, 1, wr( info+1 ),max( n-info, 1 & + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wr( info+1 ),max( n-info, 1_${ik}$ & ), ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, n-info, 1, wi( info+1 ),max( n-info, 1 & + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wi( info+1 ),max( n-info, 1_${ik}$ & ), ierr ) - if( info>0 ) then - call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wr, n,ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wi, n,ierr ) + if( info>0_${ik}$ ) then + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wr, n,ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr ) end if end if - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_${ri}$geev + end subroutine stdlib${ii}$_${ri}$geev - subroutine stdlib_${ri}$geevx( balanc, jobvl, jobvr, sense, n, a, lda, wr, wi,vl, ldvl, vr, ldvr, & + subroutine stdlib${ii}$_${ri}$geevx( balanc, jobvl, jobvr, sense, n, a, lda, wr, wi,vl, ldvl, vr, ldvr, & !! DGEEVX: computes for an N-by-N real nonsymmetric matrix A, the !! eigenvalues and, optionally, the left and/or right eigenvectors. !! Optionally also, it computes a balancing transformation to improve @@ -5185,11 +5187,11 @@ module stdlib_linalg_lapack_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: balanc, jobvl, jobvr, sense - integer(ilp), intent(out) :: ihi, ilo, info - integer(ilp), intent(in) :: lda, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: ihi, ilo, info + integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n real(${rk}$), intent(out) :: abnrm ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: rconde(*), rcondv(*), scale(*), vl(ldvl,*), vr(ldvr,*), wi(*),& work(*), wr(*) @@ -5198,18 +5200,18 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: lquery, scalea, wantvl, wantvr, wntsnb, wntsne, wntsnn, wntsnv character :: job, side - integer(ilp) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, & + integer(${ik}$) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, & nout real(${rk}$) :: anrm, bignum, cs, cscale, eps, r, scl, smlnum, sn ! Local Arrays - logical(lk) :: select(1) - real(${rk}$) :: dum(1) + logical(lk) :: select(1_${ik}$) + real(${rk}$) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) wantvl = stdlib_lsame( jobvl, 'V' ) wantvr = stdlib_lsame( jobvr, 'V' ) wntsnn = stdlib_lsame( sense, 'N' ) @@ -5218,87 +5220,87 @@ module stdlib_linalg_lapack_${ri}$ wntsnb = stdlib_lsame( sense, 'B' ) if( .not.( stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'S' ).or. & stdlib_lsame( balanc, 'P' ) .or. stdlib_lsame( balanc, 'B' ) ) )then - info = -1 + info = -1_${ik}$ else if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then - info = -3 + info = -3_${ik}$ else if( .not.( wntsnn .or. wntsne .or. wntsnb .or. wntsnv ) .or.( ( wntsne .or. & wntsnb ) .and. .not.( wantvl .and.wantvr ) ) ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( ldazero .and. anrmzero ) then - scl = one / stdlib_${ri}$lapy2( stdlib_${ri}$nrm2( n, vl( 1, i ), 1 ),stdlib_${ri}$nrm2( n, & - vl( 1, i+1 ), 1 ) ) - call stdlib_${ri}$scal( n, scl, vl( 1, i ), 1 ) - call stdlib_${ri}$scal( n, scl, vl( 1, i+1 ), 1 ) + scl = one / stdlib${ii}$_${ri}$lapy2( stdlib${ii}$_${ri}$nrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_${ri}$nrm2( n, & + vl( 1_${ik}$, i+1 ), 1_${ik}$ ) ) + call stdlib${ii}$_${ri}$scal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n, scl, vl( 1_${ik}$, i+1 ), 1_${ik}$ ) do k = 1, n - work( k ) = vl( k, i )**2 + vl( k, i+1 )**2 + work( k ) = vl( k, i )**2_${ik}$ + vl( k, i+1 )**2_${ik}$ end do - k = stdlib_i${ri}$amax( n, work, 1 ) - call stdlib_${ri}$lartg( vl( k, i ), vl( k, i+1 ), cs, sn, r ) - call stdlib_${ri}$rot( n, vl( 1, i ), 1, vl( 1, i+1 ), 1, cs, sn ) + k = stdlib${ii}$_i${ri}$amax( n, work, 1_${ik}$ ) + call stdlib${ii}$_${ri}$lartg( vl( k, i ), vl( k, i+1 ), cs, sn, r ) + call stdlib${ii}$_${ri}$rot( n, vl( 1_${ik}$, i ), 1_${ik}$, vl( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn ) vl( k, i+1 ) = zero end if end do end if if( wantvr ) then ! undo balancing of right eigenvectors - call stdlib_${ri}$gebak( balanc, 'R', n, ilo, ihi, scale, n, vr, ldvr,ierr ) + call stdlib${ii}$_${ri}$gebak( balanc, 'R', n, ilo, ihi, scale, n, vr, ldvr,ierr ) ! normalize right eigenvectors and make largest component real do i = 1, n if( wi( i )==zero ) then - scl = one / stdlib_${ri}$nrm2( n, vr( 1, i ), 1 ) - call stdlib_${ri}$scal( n, scl, vr( 1, i ), 1 ) + scl = one / stdlib${ii}$_${ri}$nrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ ) else if( wi( i )>zero ) then - scl = one / stdlib_${ri}$lapy2( stdlib_${ri}$nrm2( n, vr( 1, i ), 1 ),stdlib_${ri}$nrm2( n, & - vr( 1, i+1 ), 1 ) ) - call stdlib_${ri}$scal( n, scl, vr( 1, i ), 1 ) - call stdlib_${ri}$scal( n, scl, vr( 1, i+1 ), 1 ) + scl = one / stdlib${ii}$_${ri}$lapy2( stdlib${ii}$_${ri}$nrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_${ri}$nrm2( n, & + vr( 1_${ik}$, i+1 ), 1_${ik}$ ) ) + call stdlib${ii}$_${ri}$scal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n, scl, vr( 1_${ik}$, i+1 ), 1_${ik}$ ) do k = 1, n - work( k ) = vr( k, i )**2 + vr( k, i+1 )**2 + work( k ) = vr( k, i )**2_${ik}$ + vr( k, i+1 )**2_${ik}$ end do - k = stdlib_i${ri}$amax( n, work, 1 ) - call stdlib_${ri}$lartg( vr( k, i ), vr( k, i+1 ), cs, sn, r ) - call stdlib_${ri}$rot( n, vr( 1, i ), 1, vr( 1, i+1 ), 1, cs, sn ) + k = stdlib${ii}$_i${ri}$amax( n, work, 1_${ik}$ ) + call stdlib${ii}$_${ri}$lartg( vr( k, i ), vr( k, i+1 ), cs, sn, r ) + call stdlib${ii}$_${ri}$rot( n, vr( 1_${ik}$, i ), 1_${ik}$, vr( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn ) vr( k, i+1 ) = zero end if end do @@ -5448,123 +5450,123 @@ module stdlib_linalg_lapack_${ri}$ ! undo scaling if necessary 50 continue if( scalea ) then - call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, n-info, 1, wr( info+1 ),max( n-info, 1 & + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wr( info+1 ),max( n-info, 1_${ik}$ & ), ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, n-info, 1, wi( info+1 ),max( n-info, 1 & + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wi( info+1 ),max( n-info, 1_${ik}$ & ), ierr ) - if( info==0 ) then - if( ( wntsnv .or. wntsnb ) .and. icond==0 )call stdlib_${ri}$lascl( 'G', 0, 0, cscale,& - anrm, n, 1, rcondv, n,ierr ) + if( info==0_${ik}$ ) then + if( ( wntsnv .or. wntsnb ) .and. icond==0_${ik}$ )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale,& + anrm, n, 1_${ik}$, rcondv, n,ierr ) else - call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wr, n,ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wi, n,ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wr, n,ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr ) end if end if - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_${ri}$geevx + end subroutine stdlib${ii}$_${ri}$geevx - pure subroutine stdlib_${ri}$gehd2( n, ilo, ihi, a, lda, tau, work, info ) + pure subroutine stdlib${ii}$_${ri}$gehd2( n, ilo, ihi, a, lda, tau, work, info ) !! DGEHD2: reduces a real general matrix A to upper Hessenberg form H by !! an orthogonal similarity transformation: Q**T * A * Q = H . ! -- lapack computational routine -- ! -- 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, lda, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ilo, lda, n + integer(${ik}$), intent(out) :: info ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i real(${rk}$) :: aii ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input parameters - info = 0 - if( n<0 ) then - info = -1 - else if( ilo<1 .or. ilo>max( 1, n ) ) then - info = -2 + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -1_${ik}$ + else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then + info = -2_${ik}$ else if( ihin ) then - info = -3 - else if( ldamax( 1, n ) ) then - info = -2 + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) + if( n<0_${ik}$ ) then + info = -1_${ik}$ + else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then + info = -2_${ik}$ else if( ihin ) then - info = -3 - else if( lda1 .and. nb1_${ik}$ .and. nb=(n*nbmin + tsize) ) then nb = (lwork-tsize) / n else - nb = 1 + nb = 1_${ik}$ end if end if end if @@ -5610,43 +5612,43 @@ module stdlib_linalg_lapack_${ri}$ i = ilo else ! use blocked code - iwt = 1 + n*nb + iwt = 1_${ik}$ + n*nb do i = ilo, ihi - 1 - nx, nb ib = min( nb, ihi-i ) ! reduce columns i:i+ib-1 to hessenberg form, returning the ! matrices v and t of the block reflector h = i - v*t*v**t ! which performs the reduction, and also the matrix y = a*v*t - call stdlib_${ri}$lahr2( ihi, i, ib, a( 1, i ), lda, tau( i ),work( iwt ), ldt, work, & + call stdlib${ii}$_${ri}$lahr2( ihi, i, ib, a( 1_${ik}$, i ), lda, tau( i ),work( iwt ), ldt, work, & ldwork ) ! apply the block reflector h to a(1:ihi,i+ib:ihi) from the ! right, computing a := a - y * v**t. v(i+ib,ib-1) must be set ! to 1 ei = a( i+ib, i+ib-1 ) a( i+ib, i+ib-1 ) = one - call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE',ihi, ihi-i-ib+1,ib, -one, work, & - ldwork, a( i+ib, i ), lda, one,a( 1, i+ib ), lda ) + call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE',ihi, ihi-i-ib+1,ib, -one, work, & + ldwork, a( i+ib, i ), lda, one,a( 1_${ik}$, i+ib ), lda ) a( i+ib, i+ib-1 ) = ei ! apply the block reflector h to a(1:i,i+1:i+ib-1) from the ! right - call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', 'TRANSPOSE','UNIT', i, ib-1,one, a( i+1, i )& + call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', 'TRANSPOSE','UNIT', i, ib-1,one, a( i+1, i )& , lda, work, ldwork ) do j = 0, ib-2 - call stdlib_${ri}$axpy( i, -one, work( ldwork*j+1 ), 1,a( 1, i+j+1 ), 1 ) + call stdlib${ii}$_${ri}$axpy( i, -one, work( ldwork*j+1 ), 1_${ik}$,a( 1_${ik}$, i+j+1 ), 1_${ik}$ ) end do ! apply the block reflector h to a(i+1:ihi,i+ib:n) from the ! left - call stdlib_${ri}$larfb( 'LEFT', 'TRANSPOSE', 'FORWARD','COLUMNWISE',ihi-i, n-i-ib+1, & + call stdlib${ii}$_${ri}$larfb( 'LEFT', 'TRANSPOSE', 'FORWARD','COLUMNWISE',ihi-i, n-i-ib+1, & ib, a( i+1, i ), lda,work( iwt ), ldt, a( i+1, i+ib ), lda,work, ldwork ) end do end if ! use unblocked code to reduce the rest of the matrix - call stdlib_${ri}$gehd2( n, i, ihi, a, lda, tau, work, iinfo ) - work( 1 ) = lwkopt + call stdlib${ii}$_${ri}$gehd2( n, i, ihi, a, lda, tau, work, iinfo ) + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ri}$gehrd + end subroutine stdlib${ii}$_${ri}$gehrd - pure subroutine stdlib_${ri}$gejsv( joba, jobu, jobv, jobr, jobt, jobp,m, n, a, lda, sva, u, ldu, & + pure subroutine stdlib${ii}$_${ri}$gejsv( joba, jobu, jobv, jobr, jobt, jobp,m, n, a, lda, sva, u, ldu, & !! DGEJSV: computes the singular value decomposition (SVD) of a real M-by-N !! matrix [A], where M >= N. The SVD of [A] is written as !! [A] = [U] * [SIGMA] * [V]^t, @@ -5664,19 +5666,19 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, ldu, ldv, lwork, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldu, ldv, lwork, m, n ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: sva(n), u(ldu,*), v(ldv,*), work(lwork) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) character, intent(in) :: joba, jobp, jobr, jobt, jobu, jobv ! =========================================================================== ! Local Scalars real(${rk}$) :: aapp, aaqq, aatmax, aatmin, big, big1, cond_ok, condr1, condr2, entra, & entrat, epsln, maxprj, scalem, sconda, sfmin, small, temp1, uscal1, uscal2, xsc - integer(ilp) :: ierr, n1, nr, numrank, p, q, warning + integer(${ik}$) :: ierr, n1, nr, numrank, p, q, warning logical(lk) :: almort, defr, errest, goscal, jracc, kill, lsvec, l2aber, l2kill, & l2pert, l2rank, l2tran, noscal, rowpiv, rsvec, transp ! Intrinsic Functions @@ -5695,50 +5697,50 @@ module stdlib_linalg_lapack_${ri}$ l2pert = stdlib_lsame( jobp, 'P' ) if ( .not.(rowpiv .or. l2rank .or. l2aber .or.errest .or. stdlib_lsame( joba, 'C' ) )) & then - info = - 1 + info = - 1_${ik}$ else if ( .not.( lsvec .or. stdlib_lsame( jobu, 'N' ) .or.stdlib_lsame( jobu, 'W' )) )& then - info = - 2 + info = - 2_${ik}$ else if ( .not.( rsvec .or. stdlib_lsame( jobv, 'N' ) .or.stdlib_lsame( jobv, 'W' )) & .or. ( jracc .and. (.not.lsvec) ) ) then - info = - 3 + info = - 3_${ik}$ else if ( .not. ( l2kill .or. defr ) ) then - info = - 4 + info = - 4_${ik}$ else if ( .not. ( l2tran .or. stdlib_lsame( jobt, 'N' ) ) ) then - info = - 5 + info = - 5_${ik}$ else if ( .not. ( l2pert .or. stdlib_lsame( jobp, 'N' ) ) ) then - info = - 6 - else if ( m < 0 ) then - info = - 7 - else if ( ( n < 0 ) .or. ( n > m ) ) then - info = - 8 + info = - 6_${ik}$ + else if ( m < 0_${ik}$ ) then + info = - 7_${ik}$ + else if ( ( n < 0_${ik}$ ) .or. ( n > m ) ) then + info = - 8_${ik}$ else if ( lda < m ) then - info = - 10 + info = - 10_${ik}$ else if ( lsvec .and. ( ldu < m ) ) then - info = - 13 + info = - 13_${ik}$ else if ( rsvec .and. ( ldv < n ) ) then - info = - 15 - else if ( (.not.(lsvec .or. rsvec .or. errest).and.(lwork < max(7,4*n+1,2*m+n))) .or.(& - .not.(lsvec .or. rsvec) .and. errest .and.(lwork < max(7,4*n+n*n,2*m+n))) .or.(lsvec & - .and. (.not.rsvec) .and. (lwork < max(7,2*m+n,4*n+1))).or.(rsvec .and. (.not.lsvec) & - .and. (lwork < max(7,2*m+n,4*n+1))).or.(lsvec .and. rsvec .and. (.not.jracc) .and.(& - lwork big ) then - info = - 9 - call stdlib_xerbla( 'DGEJSV', -info ) + info = - 9_${ik}$ + call stdlib${ii}$_xerbla( 'DGEJSV', -info ) return end if aaqq = sqrt(aaqq) @@ -5777,7 +5779,7 @@ module stdlib_linalg_lapack_${ri}$ sva(p) = aapp * ( aaqq * scalem ) if ( goscal ) then goscal = .false. - call stdlib_${ri}$scal( p-1, scalem, sva, 1 ) + call stdlib${ii}$_${ri}$scal( p-1, scalem, sva, 1_${ik}$ ) end if end if end do @@ -5791,76 +5793,76 @@ module stdlib_linalg_lapack_${ri}$ ! quick return for zero m x n matrix ! #:) if ( aapp == zero ) then - if ( lsvec ) call stdlib_${ri}$laset( 'G', m, n1, zero, one, u, ldu ) - if ( rsvec ) call stdlib_${ri}$laset( 'G', n, n, zero, one, v, ldv ) - work(1) = one - work(2) = one - if ( errest ) work(3) = one + if ( lsvec ) call stdlib${ii}$_${ri}$laset( 'G', m, n1, zero, one, u, ldu ) + if ( rsvec ) call stdlib${ii}$_${ri}$laset( 'G', n, n, zero, one, v, ldv ) + work(1_${ik}$) = one + work(2_${ik}$) = one + if ( errest ) work(3_${ik}$) = one if ( lsvec .and. rsvec ) then - work(4) = one - work(5) = one + work(4_${ik}$) = one + work(5_${ik}$) = one end if if ( l2tran ) then - work(6) = zero - work(7) = zero + work(6_${ik}$) = zero + work(7_${ik}$) = zero end if - iwork(1) = 0 - iwork(2) = 0 - iwork(3) = 0 + iwork(1_${ik}$) = 0_${ik}$ + iwork(2_${ik}$) = 0_${ik}$ + iwork(3_${ik}$) = 0_${ik}$ return end if ! issue warning if denormalized column norms detected. override the ! high relative accuracy request. issue licence to kill columns ! (set them to zero) whose norm is less than sigma_max / big (roughly). ! #:( - warning = 0 + warning = 0_${ik}$ if ( aaqq <= sfmin ) then l2rank = .true. l2kill = .true. - warning = 1 + warning = 1_${ik}$ end if ! quick return for one-column matrix ! #:) - if ( n == 1 ) then + if ( n == 1_${ik}$ ) then if ( lsvec ) then - call stdlib_${ri}$lascl( 'G',0,0,sva(1),scalem, m,1,a(1,1),lda,ierr ) - call stdlib_${ri}$lacpy( 'A', m, 1, a, lda, u, ldu ) + call stdlib${ii}$_${ri}$lascl( 'G',0_${ik}$,0_${ik}$,sva(1_${ik}$),scalem, m,1_${ik}$,a(1_${ik}$,1_${ik}$),lda,ierr ) + call stdlib${ii}$_${ri}$lacpy( 'A', m, 1_${ik}$, a, lda, u, ldu ) ! computing all m left singular vectors of the m x 1 matrix if ( n1 /= n ) then - call stdlib_${ri}$geqrf( m, n, u,ldu, work, work(n+1),lwork-n,ierr ) - call stdlib_${ri}$orgqr( m,n1,1, u,ldu,work,work(n+1),lwork-n,ierr ) - call stdlib_${ri}$copy( m, a(1,1), 1, u(1,1), 1 ) + call stdlib${ii}$_${ri}$geqrf( m, n, u,ldu, work, work(n+1),lwork-n,ierr ) + call stdlib${ii}$_${ri}$orgqr( m,n1,1_${ik}$, u,ldu,work,work(n+1),lwork-n,ierr ) + call stdlib${ii}$_${ri}$copy( m, a(1_${ik}$,1_${ik}$), 1_${ik}$, u(1_${ik}$,1_${ik}$), 1_${ik}$ ) end if end if if ( rsvec ) then - v(1,1) = one + v(1_${ik}$,1_${ik}$) = one end if - if ( sva(1) < (big*scalem) ) then - sva(1) = sva(1) / scalem + if ( sva(1_${ik}$) < (big*scalem) ) then + sva(1_${ik}$) = sva(1_${ik}$) / scalem scalem = one end if - work(1) = one / scalem - work(2) = one - if ( sva(1) /= zero ) then - iwork(1) = 1 - if ( ( sva(1) / scalem) >= sfmin ) then - iwork(2) = 1 + work(1_${ik}$) = one / scalem + work(2_${ik}$) = one + if ( sva(1_${ik}$) /= zero ) then + iwork(1_${ik}$) = 1_${ik}$ + if ( ( sva(1_${ik}$) / scalem) >= sfmin ) then + iwork(2_${ik}$) = 1_${ik}$ else - iwork(2) = 0 + iwork(2_${ik}$) = 0_${ik}$ end if else - iwork(1) = 0 - iwork(2) = 0 + iwork(1_${ik}$) = 0_${ik}$ + iwork(2_${ik}$) = 0_${ik}$ end if - iwork(3) = 0 - if ( errest ) work(3) = one + iwork(3_${ik}$) = 0_${ik}$ + if ( errest ) work(3_${ik}$) = one if ( lsvec .and. rsvec ) then - work(4) = one - work(5) = one + work(4_${ik}$) = one + work(5_${ik}$) = one end if if ( l2tran ) then - work(6) = zero - work(7) = zero + work(6_${ik}$) = zero + work(7_${ik}$) = zero end if return end if @@ -5877,8 +5879,8 @@ module stdlib_linalg_lapack_${ri}$ do p = 1, m xsc = zero temp1 = one - call stdlib_${ri}$lassq( n, a(p,1), lda, xsc, temp1 ) - ! stdlib_${ri}$lassq gets both the ell_2 and the ell_infinity norm + call stdlib${ii}$_${ri}$lassq( n, a(p,1_${ik}$), lda, xsc, temp1 ) + ! stdlib${ii}$_${ri}$lassq gets both the ell_2 and the ell_infinity norm ! in one pass through the vector work(m+n+p) = xsc * scalem work(n+p) = xsc * (scalem*sqrt(temp1)) @@ -5887,7 +5889,7 @@ module stdlib_linalg_lapack_${ri}$ end do else do p = 1, m - work(m+n+p) = scalem*abs( a(p,stdlib_i${ri}$amax(n,a(p,1),lda)) ) + work(m+n+p) = scalem*abs( a(p,stdlib${ii}$_i${ri}$amax(n,a(p,1_${ik}$),lda)) ) aatmax = max( aatmax, work(m+n+p) ) aatmin = min( aatmin, work(m+n+p) ) end do @@ -5904,11 +5906,11 @@ module stdlib_linalg_lapack_${ri}$ if ( l2tran ) then xsc = zero temp1 = one - call stdlib_${ri}$lassq( n, sva, 1, xsc, temp1 ) + call stdlib${ii}$_${ri}$lassq( n, sva, 1_${ik}$, xsc, temp1 ) temp1 = one / temp1 entra = zero do p = 1, n - big1 = ( ( sva(p) / xsc )**2 ) * temp1 + big1 = ( ( sva(p) / xsc )**2_${ik}$ ) * temp1 if ( big1 /= zero ) entra = entra + big1 * log(big1) end do entra = - entra / log(real(n,KIND=${rk}$)) @@ -5919,7 +5921,7 @@ module stdlib_linalg_lapack_${ri}$ ! same trace. entrat = zero do p = n+1, n+m - big1 = ( ( work(p) / xsc )**2 ) * temp1 + big1 = ( ( work(p) / xsc )**2_${ik}$ ) * temp1 if ( big1 /= zero ) entrat = entrat + big1 * log(big1) end do entrat = - entrat / log(real(m,KIND=${rk}$)) @@ -5958,22 +5960,22 @@ module stdlib_linalg_lapack_${ri}$ ! scale the matrix so that its maximal singular value remains less ! than sqrt(big) -- the matrix is scaled so that its maximal column ! has euclidean norm equal to sqrt(big/n). the only reason to keep - ! sqrt(big) instead of big is the fact that stdlib_${ri}$gejsv uses lapack and + ! sqrt(big) instead of big is the fact that stdlib${ii}$_${ri}$gejsv uses lapack and ! blas routines that, in some implementations, are not capable of ! working in the full interval [sfmin,big] and that they may provoke ! overflows in the intermediate results. if the singular values spread - ! from sfmin to big, then stdlib_${ri}$gesvj will compute them. so, in that case, - ! one should use stdlib_${ri}$gesvj instead of stdlib_${ri}$gejsv. + ! from sfmin to big, then stdlib${ii}$_${ri}$gesvj will compute them. so, in that case, + ! one should use stdlib_${ri}$gesvj instead of stdlib${ii}$_${ri}$gejsv. big1 = sqrt( big ) temp1 = sqrt( big / real(n,KIND=${rk}$) ) - call stdlib_${ri}$lascl( 'G', 0, 0, aapp, temp1, n, 1, sva, n, ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, temp1, n, 1_${ik}$, sva, n, ierr ) if ( aaqq > (aapp * sfmin) ) then aaqq = ( aaqq / aapp ) * temp1 else aaqq = ( aaqq * temp1 ) / aapp end if temp1 = temp1 * scalem - call stdlib_${ri}$lascl( 'G', 0, 0, aapp, temp1, m, n, a, lda, ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, temp1, m, n, a, lda, ierr ) ! to undo scaling at the end of this procedure, multiply the ! computed singular values with uscal2 / uscal1. uscal1 = temp1 @@ -5987,7 +5989,7 @@ module stdlib_linalg_lapack_${ri}$ xsc = small ! now, if the condition number of a is too big, ! sigma_max(a) / sigma_min(a) > sqrt(big/n) * epsln / sfmin, - ! as a precaution measure, the full svd is computed using stdlib_${ri}$gesvj + ! as a precaution measure, the full svd is computed using stdlib${ii}$_${ri}$gesvj ! with accumulated jacobi rotations. this provides numerically ! more robust computation, at the cost of slightly increased run ! time. depending on the concrete implementation of blas and lapack @@ -6000,7 +6002,7 @@ module stdlib_linalg_lapack_${ri}$ if ( aaqq < xsc ) then do p = 1, n if ( sva(p) < xsc ) then - call stdlib_${ri}$laset( 'A', m, 1, zero, zero, a(1,p), lda ) + call stdlib${ii}$_${ri}$laset( 'A', m, 1_${ik}$, zero, zero, a(1_${ik}$,p), lda ) sva(p) = zero end if end do @@ -6013,15 +6015,15 @@ module stdlib_linalg_lapack_${ri}$ ! has similar effect as powell-reid complete pivoting. ! the ell-infinity norms of a are made nonincreasing. do p = 1, m - 1 - q = stdlib_i${ri}$amax( m-p+1, work(m+n+p), 1 ) + p - 1 - iwork(2*n+p) = q + q = stdlib${ii}$_i${ri}$amax( m-p+1, work(m+n+p), 1_${ik}$ ) + p - 1_${ik}$ + iwork(2_${ik}$*n+p) = q if ( p /= q ) then temp1 = work(m+n+p) work(m+n+p) = work(m+n+q) work(m+n+q) = temp1 end if end do - call stdlib_${ri}$laswp( n, a, lda, 1, m-1, iwork(2*n+1), 1 ) + call stdlib${ii}$_${ri}$laswp( n, a, lda, 1_${ik}$, m-1, iwork(2_${ik}$*n+1), 1_${ik}$ ) end if ! end of the preparation phase (scaling, optional sorting and ! transposing, optional flushing of small columns). @@ -6033,46 +6035,44 @@ module stdlib_linalg_lapack_${ri}$ ! (eg speed by replacing global with restricted window pivoting, such ! as in sgeqpx from toms # 782). good results will be obtained using ! sgeqpx with properly (!) chosen numerical parameters. - ! any improvement of stdlib_${ri}$geqp3 improves overall performance of stdlib_${ri}$gejsv. + ! any improvement of stdlib${ii}$_${ri}$geqp3 improves overall performance of stdlib${ii}$_${ri}$gejsv. ! a * p1 = q1 * [ r1^t 0]^t: do p = 1, n ! All Columns Are Free Columns - iwork(p) = 0 + iwork(p) = 0_${ik}$ end do - call stdlib_${ri}$geqp3( m,n,a,lda, iwork,work, work(n+1),lwork-n, ierr ) + call stdlib${ii}$_${ri}$geqp3( m,n,a,lda, iwork,work, work(n+1),lwork-n, ierr ) ! the upper triangular matrix r1 from the first qrf is inspected for ! rank deficiency and possibilities for deflation, or possible ! ill-conditioning. depending on the user specified flag l2rank, ! the procedure explores possibilities to reduce the numerical ! rank by inspecting the computed upper triangular factor. if - ! l2rank or l2aber are up, then stdlib_${ri}$gejsv will compute the svd of + ! l2rank or l2aber are up, then stdlib${ii}$_${ri}$gejsv will compute the svd of ! a + da, where ||da|| <= f(m,n)*epsln. - nr = 1 + nr = 1_${ik}$ if ( l2aber ) then ! standard absolute error bound suffices. all sigma_i with ! sigma_i < n*epsln*||a|| are flushed to zero. this is an ! aggressive enforcement of lower numerical rank by introducing a ! backward error of the order of n*epsln*||a||. temp1 = sqrt(real(n,KIND=${rk}$))*epsln - do p = 2, n - if ( abs(a(p,p)) >= (temp1*abs(a(1,1))) ) then - nr = nr + 1 + loop_3002: do p = 2, n + if ( abs(a(p,p)) >= (temp1*abs(a(1_${ik}$,1_${ik}$))) ) then + nr = nr + 1_${ik}$ else - go to 3002 + exit loop_3002 end if - end do - 3002 continue + end do loop_3002 else if ( l2rank ) then ! .. similarly as above, only slightly more gentle (less aggressive). ! sudden drop on the diagonal of r1 is used as the criterion for ! close-to-rank-deficient. temp1 = sqrt(sfmin) - do p = 2, n + loop_3402: do p = 2, n if ( ( abs(a(p,p)) < (epsln*abs(a(p-1,p-1))) ) .or.( abs(a(p,p)) < small ) .or.( & - l2kill .and. (abs(a(p,p)) < temp1) ) ) go to 3402 - nr = nr + 1 - end do - 3402 continue + l2kill .and. (abs(a(p,p)) < temp1) ) ) exit loop_3402 + nr = nr + 1_${ik}$ + end do loop_3402 else ! the goal is high relative accuracy. however, if the matrix ! has high scaled condition number the relative accuracy is in @@ -6082,12 +6082,10 @@ module stdlib_linalg_lapack_${ri}$ ! factor. this prevents the situation in which the code is ! working hard to get the accuracy not warranted by the data. temp1 = sqrt(sfmin) - do p = 2, n - if ( ( abs(a(p,p)) < small ) .or.( l2kill .and. (abs(a(p,p)) < temp1) ) ) go to & - 3302 - nr = nr + 1 - end do - 3302 continue + loop_3302: do p = 2, n + if ( ( abs(a(p,p)) < small ) .or.( l2kill .and. (abs(a(p,p)) < temp1) ) ) exit loop_3302 + nr = nr + 1_${ik}$ + end do loop_3302 end if almort = .false. if ( nr == n ) then @@ -6096,7 +6094,7 @@ module stdlib_linalg_lapack_${ri}$ temp1 = abs(a(p,p)) / sva(iwork(p)) maxprj = min( maxprj, temp1 ) end do - if ( maxprj**2 >= one - real(n,KIND=${rk}$)*epsln ) almort = .true. + if ( maxprj**2_${ik}$ >= one - real(n,KIND=${rk}$)*epsln ) almort = .true. end if sconda = - one condr1 = - one @@ -6105,30 +6103,30 @@ module stdlib_linalg_lapack_${ri}$ if ( n == nr ) then if ( rsvec ) then ! V Is Available As Workspace - call stdlib_${ri}$lacpy( 'U', n, n, a, lda, v, ldv ) + call stdlib${ii}$_${ri}$lacpy( 'U', n, n, a, lda, v, ldv ) do p = 1, n temp1 = sva(iwork(p)) - call stdlib_${ri}$scal( p, one/temp1, v(1,p), 1 ) + call stdlib${ii}$_${ri}$scal( p, one/temp1, v(1_${ik}$,p), 1_${ik}$ ) end do - call stdlib_${ri}$pocon( 'U', n, v, ldv, one, temp1,work(n+1), iwork(2*n+m+1), & + call stdlib${ii}$_${ri}$pocon( 'U', n, v, ldv, one, temp1,work(n+1), iwork(2_${ik}$*n+m+1), & ierr ) else if ( lsvec ) then ! U Is Available As Workspace - call stdlib_${ri}$lacpy( 'U', n, n, a, lda, u, ldu ) + call stdlib${ii}$_${ri}$lacpy( 'U', n, n, a, lda, u, ldu ) do p = 1, n temp1 = sva(iwork(p)) - call stdlib_${ri}$scal( p, one/temp1, u(1,p), 1 ) + call stdlib${ii}$_${ri}$scal( p, one/temp1, u(1_${ik}$,p), 1_${ik}$ ) end do - call stdlib_${ri}$pocon( 'U', n, u, ldu, one, temp1,work(n+1), iwork(2*n+m+1), & + call stdlib${ii}$_${ri}$pocon( 'U', n, u, ldu, one, temp1,work(n+1), iwork(2_${ik}$*n+m+1), & ierr ) else - call stdlib_${ri}$lacpy( 'U', n, n, a, lda, work(n+1), n ) + call stdlib${ii}$_${ri}$lacpy( 'U', n, n, a, lda, work(n+1), n ) do p = 1, n temp1 = sva(iwork(p)) - call stdlib_${ri}$scal( p, one/temp1, work(n+(p-1)*n+1), 1 ) + call stdlib${ii}$_${ri}$scal( p, one/temp1, work(n+(p-1)*n+1), 1_${ik}$ ) end do ! The Columns Of R Are Scaled To Have Unit Euclidean Lengths - call stdlib_${ri}$pocon( 'U', n, work(n+1), n, one, temp1,work(n+n*n+1), iwork(2*n+& + call stdlib${ii}$_${ri}$pocon( 'U', n, work(n+1), n, one, temp1,work(n+n*n+1), iwork(2_${ik}$*n+& m+1), ierr ) end if sconda = one / sqrt(temp1) @@ -6138,14 +6136,14 @@ module stdlib_linalg_lapack_${ri}$ sconda = - one end if end if - l2pert = l2pert .and. ( abs( a(1,1)/a(nr,nr) ) > sqrt(big1) ) + l2pert = l2pert .and. ( abs( a(1_${ik}$,1_${ik}$)/a(nr,nr) ) > sqrt(big1) ) ! if there is no violent scaling, artificial perturbation is not needed. ! phase 3: if ( .not. ( rsvec .or. lsvec ) ) then ! singular values only ! .. transpose a(1:nr,1:n) do p = 1, min( n-1, nr ) - call stdlib_${ri}$copy( n-p, a(p,p+1), lda, a(p+1,p), 1 ) + call stdlib${ii}$_${ri}$copy( n-p, a(p,p+1), lda, a(p+1,p), 1_${ik}$ ) end do ! the following two do-loops introduce small relative perturbation ! into the strict upper triangle of the lower triangular matrix. @@ -6170,13 +6168,13 @@ module stdlib_linalg_lapack_${ri}$ end do end do else - call stdlib_${ri}$laset( 'U', nr-1,nr-1, zero,zero, a(1,2),lda ) + call stdlib${ii}$_${ri}$laset( 'U', nr-1,nr-1, zero,zero, a(1_${ik}$,2_${ik}$),lda ) end if ! Second Preconditioning Using The Qr Factorization - call stdlib_${ri}$geqrf( n,nr, a,lda, work, work(n+1),lwork-n, ierr ) + call stdlib${ii}$_${ri}$geqrf( n,nr, a,lda, work, work(n+1),lwork-n, ierr ) ! And Transpose Upper To Lower Triangular do p = 1, nr - 1 - call stdlib_${ri}$copy( nr-p, a(p,p+1), lda, a(p+1,p), 1 ) + call stdlib${ii}$_${ri}$copy( nr-p, a(p,p+1), lda, a(p+1,p), 1_${ik}$ ) end do end if ! row-cyclic jacobi svd algorithm with column pivoting @@ -6193,92 +6191,92 @@ module stdlib_linalg_lapack_${ri}$ end do end do else - call stdlib_${ri}$laset( 'U', nr-1, nr-1, zero, zero, a(1,2), lda ) + call stdlib${ii}$_${ri}$laset( 'U', nr-1, nr-1, zero, zero, a(1_${ik}$,2_${ik}$), lda ) end if ! .. and one-sided jacobi rotations are started on a lower ! triangular matrix (plus perturbation which is ignored in ! the part which destroys triangular form (confusing?!)) - call stdlib_${ri}$gesvj( 'L', 'NOU', 'NOV', nr, nr, a, lda, sva,n, v, ldv, work, & + call stdlib${ii}$_${ri}$gesvj( 'L', 'NOU', 'NOV', nr, nr, a, lda, sva,n, v, ldv, work, & lwork, info ) - scalem = work(1) - numrank = nint(work(2),KIND=ilp) + scalem = work(1_${ik}$) + numrank = nint(work(2_${ik}$),KIND=${ik}$) else if ( rsvec .and. ( .not. lsvec ) ) then ! -> singular values and right singular vectors <- if ( almort ) then ! In This Case Nr Equals N do p = 1, nr - call stdlib_${ri}$copy( n-p+1, a(p,p), lda, v(p,p), 1 ) + call stdlib${ii}$_${ri}$copy( n-p+1, a(p,p), lda, v(p,p), 1_${ik}$ ) end do - call stdlib_${ri}$laset( 'UPPER', nr-1, nr-1, zero, zero, v(1,2), ldv ) - call stdlib_${ri}$gesvj( 'L','U','N', n, nr, v,ldv, sva, nr, a,lda,work, lwork, info ) + call stdlib${ii}$_${ri}$laset( 'UPPER', nr-1, nr-1, zero, zero, v(1_${ik}$,2_${ik}$), ldv ) + call stdlib${ii}$_${ri}$gesvj( 'L','U','N', n, nr, v,ldv, sva, nr, a,lda,work, lwork, info ) - scalem = work(1) - numrank = nint(work(2),KIND=ilp) + scalem = work(1_${ik}$) + numrank = nint(work(2_${ik}$),KIND=${ik}$) else ! .. two more qr factorizations ( one qrf is not enough, two require ! accumulated product of jacobi rotations, three are perfect ) - call stdlib_${ri}$laset( 'LOWER', nr-1, nr-1, zero, zero, a(2,1), lda ) - call stdlib_${ri}$gelqf( nr, n, a, lda, work, work(n+1), lwork-n, ierr) - call stdlib_${ri}$lacpy( 'LOWER', nr, nr, a, lda, v, ldv ) - call stdlib_${ri}$laset( 'UPPER', nr-1, nr-1, zero, zero, v(1,2), ldv ) - call stdlib_${ri}$geqrf( nr, nr, v, ldv, work(n+1), work(2*n+1),lwork-2*n, ierr ) + call stdlib${ii}$_${ri}$laset( 'LOWER', nr-1, nr-1, zero, zero, a(2_${ik}$,1_${ik}$), lda ) + call stdlib${ii}$_${ri}$gelqf( nr, n, a, lda, work, work(n+1), lwork-n, ierr) + call stdlib${ii}$_${ri}$lacpy( 'LOWER', nr, nr, a, lda, v, ldv ) + call stdlib${ii}$_${ri}$laset( 'UPPER', nr-1, nr-1, zero, zero, v(1_${ik}$,2_${ik}$), ldv ) + call stdlib${ii}$_${ri}$geqrf( nr, nr, v, ldv, work(n+1), work(2_${ik}$*n+1),lwork-2*n, ierr ) do p = 1, nr - call stdlib_${ri}$copy( nr-p+1, v(p,p), ldv, v(p,p), 1 ) + call stdlib${ii}$_${ri}$copy( nr-p+1, v(p,p), ldv, v(p,p), 1_${ik}$ ) end do - call stdlib_${ri}$laset( 'UPPER', nr-1, nr-1, zero, zero, v(1,2), ldv ) - call stdlib_${ri}$gesvj( 'LOWER', 'U','N', nr, nr, v,ldv, sva, nr, u,ldu, work(n+1), & + call stdlib${ii}$_${ri}$laset( 'UPPER', nr-1, nr-1, zero, zero, v(1_${ik}$,2_${ik}$), ldv ) + call stdlib${ii}$_${ri}$gesvj( 'LOWER', 'U','N', nr, nr, v,ldv, sva, nr, u,ldu, work(n+1), & lwork, info ) scalem = work(n+1) - numrank = nint(work(n+2),KIND=ilp) + numrank = nint(work(n+2),KIND=${ik}$) if ( nr < n ) then - call stdlib_${ri}$laset( 'A',n-nr, nr, zero,zero, v(nr+1,1), ldv ) - call stdlib_${ri}$laset( 'A',nr, n-nr, zero,zero, v(1,nr+1), ldv ) - call stdlib_${ri}$laset( 'A',n-nr,n-nr,zero,one, v(nr+1,nr+1), ldv ) + call stdlib${ii}$_${ri}$laset( 'A',n-nr, nr, zero,zero, v(nr+1,1_${ik}$), ldv ) + call stdlib${ii}$_${ri}$laset( 'A',nr, n-nr, zero,zero, v(1_${ik}$,nr+1), ldv ) + call stdlib${ii}$_${ri}$laset( 'A',n-nr,n-nr,zero,one, v(nr+1,nr+1), ldv ) end if - call stdlib_${ri}$ormlq( 'LEFT', 'TRANSPOSE', n, n, nr, a, lda, work,v, ldv, work(n+1), & + call stdlib${ii}$_${ri}$ormlq( 'LEFT', 'TRANSPOSE', n, n, nr, a, lda, work,v, ldv, work(n+1), & lwork-n, ierr ) end if do p = 1, n - call stdlib_${ri}$copy( n, v(p,1), ldv, a(iwork(p),1), lda ) + call stdlib${ii}$_${ri}$copy( n, v(p,1_${ik}$), ldv, a(iwork(p),1_${ik}$), lda ) end do - call stdlib_${ri}$lacpy( 'ALL', n, n, a, lda, v, ldv ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', n, n, a, lda, v, ldv ) if ( transp ) then - call stdlib_${ri}$lacpy( 'ALL', n, n, v, ldv, u, ldu ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', n, n, v, ldv, u, ldu ) end if else if ( lsvec .and. ( .not. rsvec ) ) then ! Singular Values And Left Singular Vectors ! Second Preconditioning Step To Avoid Need To Accumulate ! jacobi rotations in the jacobi iterations. do p = 1, nr - call stdlib_${ri}$copy( n-p+1, a(p,p), lda, u(p,p), 1 ) + call stdlib${ii}$_${ri}$copy( n-p+1, a(p,p), lda, u(p,p), 1_${ik}$ ) end do - call stdlib_${ri}$laset( 'UPPER', nr-1, nr-1, zero, zero, u(1,2), ldu ) - call stdlib_${ri}$geqrf( n, nr, u, ldu, work(n+1), work(2*n+1),lwork-2*n, ierr ) + call stdlib${ii}$_${ri}$laset( 'UPPER', nr-1, nr-1, zero, zero, u(1_${ik}$,2_${ik}$), ldu ) + call stdlib${ii}$_${ri}$geqrf( n, nr, u, ldu, work(n+1), work(2_${ik}$*n+1),lwork-2*n, ierr ) do p = 1, nr - 1 - call stdlib_${ri}$copy( nr-p, u(p,p+1), ldu, u(p+1,p), 1 ) + call stdlib${ii}$_${ri}$copy( nr-p, u(p,p+1), ldu, u(p+1,p), 1_${ik}$ ) end do - call stdlib_${ri}$laset( 'UPPER', nr-1, nr-1, zero, zero, u(1,2), ldu ) - call stdlib_${ri}$gesvj( 'LOWER', 'U', 'N', nr,nr, u, ldu, sva, nr, a,lda, work(n+1), & + call stdlib${ii}$_${ri}$laset( 'UPPER', nr-1, nr-1, zero, zero, u(1_${ik}$,2_${ik}$), ldu ) + call stdlib${ii}$_${ri}$gesvj( 'LOWER', 'U', 'N', nr,nr, u, ldu, sva, nr, a,lda, work(n+1), & lwork-n, info ) scalem = work(n+1) - numrank = nint(work(n+2),KIND=ilp) + numrank = nint(work(n+2),KIND=${ik}$) if ( nr < m ) then - call stdlib_${ri}$laset( 'A', m-nr, nr,zero, zero, u(nr+1,1), ldu ) + call stdlib${ii}$_${ri}$laset( 'A', m-nr, nr,zero, zero, u(nr+1,1_${ik}$), ldu ) if ( nr < n1 ) then - call stdlib_${ri}$laset( 'A',nr, n1-nr, zero, zero, u(1,nr+1), ldu ) - call stdlib_${ri}$laset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_${ri}$laset( 'A',nr, n1-nr, zero, zero, u(1_${ik}$,nr+1), ldu ) + call stdlib${ii}$_${ri}$laset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) end if end if - call stdlib_${ri}$ormqr( 'LEFT', 'NO TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & + call stdlib${ii}$_${ri}$ormqr( 'LEFT', 'NO TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & lwork-n, ierr ) - if ( rowpiv )call stdlib_${ri}$laswp( n1, u, ldu, 1, m-1, iwork(2*n+1), -1 ) + if ( rowpiv )call stdlib${ii}$_${ri}$laswp( n1, u, ldu, 1_${ik}$, m-1, iwork(2_${ik}$*n+1), -1_${ik}$ ) do p = 1, n1 - xsc = one / stdlib_${ri}$nrm2( m, u(1,p), 1 ) - call stdlib_${ri}$scal( m, xsc, u(1,p), 1 ) + xsc = one / stdlib${ii}$_${ri}$nrm2( m, u(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( m, xsc, u(1_${ik}$,p), 1_${ik}$ ) end do if ( transp ) then - call stdlib_${ri}$lacpy( 'ALL', n, n, u, ldu, v, ldv ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', n, n, u, ldu, v, ldv ) end if else ! Full Svd @@ -6289,9 +6287,9 @@ module stdlib_linalg_lapack_${ri}$ ! equivalent to an lqf call. since in many libraries the qrf ! seems to be better optimized than the lqf, we do explicit ! transpose and use the qrf. this is subject to changes in an - ! optimized implementation of stdlib_${ri}$gejsv. + ! optimized implementation of stdlib${ii}$_${ri}$gejsv. do p = 1, nr - call stdlib_${ri}$copy( n-p+1, a(p,p), lda, v(p,p), 1 ) + call stdlib${ii}$_${ri}$copy( n-p+1, a(p,p), lda, v(p,p), 1_${ik}$ ) end do ! The Following Two Loops Perturb Small Entries To Avoid ! denormals in the second qr factorization, where they are @@ -6315,18 +6313,18 @@ module stdlib_linalg_lapack_${ri}$ end do end do else - call stdlib_${ri}$laset( 'U', nr-1, nr-1, zero, zero, v(1,2), ldv ) + call stdlib${ii}$_${ri}$laset( 'U', nr-1, nr-1, zero, zero, v(1_${ik}$,2_${ik}$), ldv ) end if ! estimate the row scaled condition number of r1 ! (if r1 is rectangular, n > nr, then the condition number ! of the leading nr x nr submatrix is estimated.) - call stdlib_${ri}$lacpy( 'L', nr, nr, v, ldv, work(2*n+1), nr ) + call stdlib${ii}$_${ri}$lacpy( 'L', nr, nr, v, ldv, work(2_${ik}$*n+1), nr ) do p = 1, nr - temp1 = stdlib_${ri}$nrm2(nr-p+1,work(2*n+(p-1)*nr+p),1) - call stdlib_${ri}$scal(nr-p+1,one/temp1,work(2*n+(p-1)*nr+p),1) + temp1 = stdlib${ii}$_${ri}$nrm2(nr-p+1,work(2_${ik}$*n+(p-1)*nr+p),1_${ik}$) + call stdlib${ii}$_${ri}$scal(nr-p+1,one/temp1,work(2_${ik}$*n+(p-1)*nr+p),1_${ik}$) end do - call stdlib_${ri}$pocon('LOWER',nr,work(2*n+1),nr,one,temp1,work(2*n+nr*nr+1),iwork(m+& - 2*n+1),ierr) + call stdlib${ii}$_${ri}$pocon('LOWER',nr,work(2_${ik}$*n+1),nr,one,temp1,work(2_${ik}$*n+nr*nr+1),iwork(m+& + 2_${ik}$*n+1),ierr) condr1 = one / sqrt(temp1) ! Here Need A Second Opinion On The Condition Number ! Then Assume Worst Case Scenario @@ -6339,7 +6337,7 @@ module stdlib_linalg_lapack_${ri}$ ! implementation, this qrf should be implemented as the qrf ! of a lower triangular matrix. ! r1^t = q2 * r2 - call stdlib_${ri}$geqrf( n, nr, v, ldv, work(n+1), work(2*n+1),lwork-2*n, ierr ) + call stdlib${ii}$_${ri}$geqrf( n, nr, v, ldv, work(n+1), work(2_${ik}$*n+1),lwork-2*n, ierr ) if ( l2pert ) then xsc = sqrt(small)/epsln @@ -6350,27 +6348,27 @@ module stdlib_linalg_lapack_${ri}$ end do end do end if - if ( nr /= n )call stdlib_${ri}$lacpy( 'A', n, nr, v, ldv, work(2*n+1), n ) + if ( nr /= n )call stdlib${ii}$_${ri}$lacpy( 'A', n, nr, v, ldv, work(2_${ik}$*n+1), n ) ! .. save ... ! This Transposed Copy Should Be Better Than Naive do p = 1, nr - 1 - call stdlib_${ri}$copy( nr-p, v(p,p+1), ldv, v(p+1,p), 1 ) + call stdlib${ii}$_${ri}$copy( nr-p, v(p,p+1), ldv, v(p+1,p), 1_${ik}$ ) end do condr2 = condr1 else ! .. ill-conditioned case: second qrf with pivoting ! note that windowed pivoting would be equally good ! numerically, and more run-time efficient. so, in - ! an optimal implementation, the next call to stdlib_${ri}$geqp3 + ! an optimal implementation, the next call to stdlib${ii}$_${ri}$geqp3 ! should be replaced with eg. call sgeqpx (acm toms #782) ! with properly (carefully) chosen parameters. ! r1^t * p2 = q2 * r2 do p = 1, nr - iwork(n+p) = 0 + iwork(n+p) = 0_${ik}$ end do - call stdlib_${ri}$geqp3( n, nr, v, ldv, iwork(n+1), work(n+1),work(2*n+1), lwork-& - 2*n, ierr ) - ! * call stdlib_${ri}$geqrf( n, nr, v, ldv, work(n+1), work(2*n+1), + call stdlib${ii}$_${ri}$geqp3( n, nr, v, ldv, iwork(n+1), work(n+1),work(2_${ik}$*n+1), lwork-& + 2_${ik}$*n, ierr ) + ! * call stdlib${ii}$_${ri}$geqrf( n, nr, v, ldv, work(n+1), work(2*n+1), ! * $ lwork-2*n, ierr ) if ( l2pert ) then xsc = sqrt(small) @@ -6381,7 +6379,7 @@ module stdlib_linalg_lapack_${ri}$ end do end do end if - call stdlib_${ri}$lacpy( 'A', n, nr, v, ldv, work(2*n+1), n ) + call stdlib${ii}$_${ri}$lacpy( 'A', n, nr, v, ldv, work(2_${ik}$*n+1), n ) if ( l2pert ) then xsc = sqrt(small) do p = 2, nr @@ -6391,18 +6389,18 @@ module stdlib_linalg_lapack_${ri}$ end do end do else - call stdlib_${ri}$laset( 'L',nr-1,nr-1,zero,zero,v(2,1),ldv ) + call stdlib${ii}$_${ri}$laset( 'L',nr-1,nr-1,zero,zero,v(2_${ik}$,1_${ik}$),ldv ) end if ! now, compute r2 = l3 * q3, the lq factorization. - call stdlib_${ri}$gelqf( nr, nr, v, ldv, work(2*n+n*nr+1),work(2*n+n*nr+nr+1), & + call stdlib${ii}$_${ri}$gelqf( nr, nr, v, ldv, work(2_${ik}$*n+n*nr+1),work(2_${ik}$*n+n*nr+nr+1), & lwork-2*n-n*nr-nr, ierr ) ! And Estimate The Condition Number - call stdlib_${ri}$lacpy( 'L',nr,nr,v,ldv,work(2*n+n*nr+nr+1),nr ) + call stdlib${ii}$_${ri}$lacpy( 'L',nr,nr,v,ldv,work(2_${ik}$*n+n*nr+nr+1),nr ) do p = 1, nr - temp1 = stdlib_${ri}$nrm2( p, work(2*n+n*nr+nr+p), nr ) - call stdlib_${ri}$scal( p, one/temp1, work(2*n+n*nr+nr+p), nr ) + temp1 = stdlib${ii}$_${ri}$nrm2( p, work(2_${ik}$*n+n*nr+nr+p), nr ) + call stdlib${ii}$_${ri}$scal( p, one/temp1, work(2_${ik}$*n+n*nr+nr+p), nr ) end do - call stdlib_${ri}$pocon( 'L',nr,work(2*n+n*nr+nr+1),nr,one,temp1,work(2*n+n*nr+nr+& + call stdlib${ii}$_${ri}$pocon( 'L',nr,work(2_${ik}$*n+n*nr+nr+1),nr,one,temp1,work(2_${ik}$*n+n*nr+nr+& nr*nr+1),iwork(m+2*n+1),ierr ) condr2 = one / sqrt(temp1) if ( condr2 >= cond_ok ) then @@ -6410,7 +6408,7 @@ module stdlib_linalg_lapack_${ri}$ ! (this overwrites the copy of r2, as it will not be ! needed in this branch, but it does not overwritte the ! huseholder vectors of q2.). - call stdlib_${ri}$lacpy( 'U', nr, nr, v, ldv, work(2*n+1), n ) + call stdlib${ii}$_${ri}$lacpy( 'U', nr, nr, v, ldv, work(2_${ik}$*n+1), n ) ! And The Rest Of The Information On Q3 Is In ! work(2*n+n*nr+1:2*n+n*nr+n) end if @@ -6425,40 +6423,40 @@ module stdlib_linalg_lapack_${ri}$ end do end do else - call stdlib_${ri}$laset( 'U', nr-1,nr-1, zero,zero, v(1,2), ldv ) + call stdlib${ii}$_${ri}$laset( 'U', nr-1,nr-1, zero,zero, v(1_${ik}$,2_${ik}$), ldv ) end if ! second preconditioning finished; continue with jacobi svd ! the input matrix is lower trinagular. ! recover the right singular vectors as solution of a well ! conditioned triangular matrix equation. if ( condr1 < cond_ok ) then - call stdlib_${ri}$gesvj( 'L','U','N',nr,nr,v,ldv,sva,nr,u,ldu,work(2*n+n*nr+nr+1),& + call stdlib${ii}$_${ri}$gesvj( 'L','U','N',nr,nr,v,ldv,sva,nr,u,ldu,work(2_${ik}$*n+n*nr+nr+1),& lwork-2*n-n*nr-nr,info ) - scalem = work(2*n+n*nr+nr+1) - numrank = nint(work(2*n+n*nr+nr+2),KIND=ilp) + scalem = work(2_${ik}$*n+n*nr+nr+1) + numrank = nint(work(2_${ik}$*n+n*nr+nr+2),KIND=${ik}$) do p = 1, nr - call stdlib_${ri}$copy( nr, v(1,p), 1, u(1,p), 1 ) - call stdlib_${ri}$scal( nr, sva(p), v(1,p), 1 ) + call stdlib${ii}$_${ri}$copy( nr, v(1_${ik}$,p), 1_${ik}$, u(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( nr, sva(p), v(1_${ik}$,p), 1_${ik}$ ) end do ! Pick The Right Matrix Equation And Solve It if ( nr == n ) then ! :)) .. best case, r1 is inverted. the solution of this matrix ! equation is q2*v2 = the product of the jacobi rotations - ! used in stdlib_${ri}$gesvj, premultiplied with the orthogonal matrix + ! used in stdlib${ii}$_${ri}$gesvj, premultiplied with the orthogonal matrix ! from the second qr factorization. - call stdlib_${ri}$trsm( 'L','U','N','N', nr,nr,one, a,lda, v,ldv ) + call stdlib${ii}$_${ri}$trsm( 'L','U','N','N', nr,nr,one, a,lda, v,ldv ) else ! .. r1 is well conditioned, but non-square. transpose(r2) ! is inverted to get the product of the jacobi rotations - ! used in stdlib_${ri}$gesvj. the q-factor from the second qr + ! used in stdlib${ii}$_${ri}$gesvj. the q-factor from the second qr ! factorization is then built in explicitly. - call stdlib_${ri}$trsm('L','U','T','N',nr,nr,one,work(2*n+1),n,v,ldv) + call stdlib${ii}$_${ri}$trsm('L','U','T','N',nr,nr,one,work(2_${ik}$*n+1),n,v,ldv) if ( nr < n ) then - call stdlib_${ri}$laset('A',n-nr,nr,zero,zero,v(nr+1,1),ldv) - call stdlib_${ri}$laset('A',nr,n-nr,zero,zero,v(1,nr+1),ldv) - call stdlib_${ri}$laset('A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv) + call stdlib${ii}$_${ri}$laset('A',n-nr,nr,zero,zero,v(nr+1,1_${ik}$),ldv) + call stdlib${ii}$_${ri}$laset('A',nr,n-nr,zero,zero,v(1_${ik}$,nr+1),ldv) + call stdlib${ii}$_${ri}$laset('A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv) end if - call stdlib_${ri}$ormqr('L','N',n,n,nr,work(2*n+1),n,work(n+1),v,ldv,work(2*n+& + call stdlib${ii}$_${ri}$ormqr('L','N',n,n,nr,work(2_${ik}$*n+1),n,work(n+1),v,ldv,work(2_${ik}$*n+& n*nr+nr+1),lwork-2*n-n*nr-nr,ierr) end if else if ( condr2 < cond_ok ) then @@ -6468,30 +6466,30 @@ module stdlib_linalg_lapack_${ri}$ ! is q3^t*v3 = the product of the jacobi rotations (appplied to ! the lower triangular l3 from the lq factorization of ! r2=l3*q3), pre-multiplied with the transposed q3. - call stdlib_${ri}$gesvj( 'L', 'U', 'N', nr, nr, v, ldv, sva, nr, u,ldu, work(2*n+& + call stdlib${ii}$_${ri}$gesvj( 'L', 'U', 'N', nr, nr, v, ldv, sva, nr, u,ldu, work(2_${ik}$*n+& n*nr+nr+1), lwork-2*n-n*nr-nr, info ) - scalem = work(2*n+n*nr+nr+1) - numrank = nint(work(2*n+n*nr+nr+2),KIND=ilp) + scalem = work(2_${ik}$*n+n*nr+nr+1) + numrank = nint(work(2_${ik}$*n+n*nr+nr+2),KIND=${ik}$) do p = 1, nr - call stdlib_${ri}$copy( nr, v(1,p), 1, u(1,p), 1 ) - call stdlib_${ri}$scal( nr, sva(p), u(1,p), 1 ) + call stdlib${ii}$_${ri}$copy( nr, v(1_${ik}$,p), 1_${ik}$, u(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( nr, sva(p), u(1_${ik}$,p), 1_${ik}$ ) end do - call stdlib_${ri}$trsm('L','U','N','N',nr,nr,one,work(2*n+1),n,u,ldu) + call stdlib${ii}$_${ri}$trsm('L','U','N','N',nr,nr,one,work(2_${ik}$*n+1),n,u,ldu) ! Apply The Permutation From The Second Qr Factorization do q = 1, nr do p = 1, nr - work(2*n+n*nr+nr+iwork(n+p)) = u(p,q) + work(2_${ik}$*n+n*nr+nr+iwork(n+p)) = u(p,q) end do do p = 1, nr - u(p,q) = work(2*n+n*nr+nr+p) + u(p,q) = work(2_${ik}$*n+n*nr+nr+p) end do end do if ( nr < n ) then - call stdlib_${ri}$laset( 'A',n-nr,nr,zero,zero,v(nr+1,1),ldv ) - call stdlib_${ri}$laset( 'A',nr,n-nr,zero,zero,v(1,nr+1),ldv ) - call stdlib_${ri}$laset( 'A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv ) + call stdlib${ii}$_${ri}$laset( 'A',n-nr,nr,zero,zero,v(nr+1,1_${ik}$),ldv ) + call stdlib${ii}$_${ri}$laset( 'A',nr,n-nr,zero,zero,v(1_${ik}$,nr+1),ldv ) + call stdlib${ii}$_${ri}$laset( 'A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv ) end if - call stdlib_${ri}$ormqr( 'L','N',n,n,nr,work(2*n+1),n,work(n+1),v,ldv,work(2*n+& + call stdlib${ii}$_${ri}$ormqr( 'L','N',n,n,nr,work(2_${ik}$*n+1),n,work(n+1),v,ldv,work(2_${ik}$*n+& n*nr+nr+1),lwork-2*n-n*nr-nr,ierr ) else ! last line of defense. @@ -6502,28 +6500,28 @@ module stdlib_linalg_lapack_${ri}$ ! is set very close to one (which is unnecessary). normally, ! this branch should never be executed, but in rare cases of ! failure of the rrqr or condition estimator, the last line of - ! defense ensures that stdlib_${ri}$gejsv completes the task. - ! compute the full svd of l3 using stdlib_${ri}$gesvj with explicit + ! defense ensures that stdlib${ii}$_${ri}$gejsv completes the task. + ! compute the full svd of l3 using stdlib${ii}$_${ri}$gesvj with explicit ! accumulation of jacobi rotations. - call stdlib_${ri}$gesvj( 'L', 'U', 'V', nr, nr, v, ldv, sva, nr, u,ldu, work(2*n+& + call stdlib${ii}$_${ri}$gesvj( 'L', 'U', 'V', nr, nr, v, ldv, sva, nr, u,ldu, work(2_${ik}$*n+& n*nr+nr+1), lwork-2*n-n*nr-nr, info ) - scalem = work(2*n+n*nr+nr+1) - numrank = nint(work(2*n+n*nr+nr+2),KIND=ilp) + scalem = work(2_${ik}$*n+n*nr+nr+1) + numrank = nint(work(2_${ik}$*n+n*nr+nr+2),KIND=${ik}$) if ( nr < n ) then - call stdlib_${ri}$laset( 'A',n-nr,nr,zero,zero,v(nr+1,1),ldv ) - call stdlib_${ri}$laset( 'A',nr,n-nr,zero,zero,v(1,nr+1),ldv ) - call stdlib_${ri}$laset( 'A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv ) + call stdlib${ii}$_${ri}$laset( 'A',n-nr,nr,zero,zero,v(nr+1,1_${ik}$),ldv ) + call stdlib${ii}$_${ri}$laset( 'A',nr,n-nr,zero,zero,v(1_${ik}$,nr+1),ldv ) + call stdlib${ii}$_${ri}$laset( 'A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv ) end if - call stdlib_${ri}$ormqr( 'L','N',n,n,nr,work(2*n+1),n,work(n+1),v,ldv,work(2*n+& + call stdlib${ii}$_${ri}$ormqr( 'L','N',n,n,nr,work(2_${ik}$*n+1),n,work(n+1),v,ldv,work(2_${ik}$*n+& n*nr+nr+1),lwork-2*n-n*nr-nr,ierr ) - call stdlib_${ri}$ormlq( 'L', 'T', nr, nr, nr, work(2*n+1), n,work(2*n+n*nr+1), u, & - ldu, work(2*n+n*nr+nr+1),lwork-2*n-n*nr-nr, ierr ) + call stdlib${ii}$_${ri}$ormlq( 'L', 'T', nr, nr, nr, work(2_${ik}$*n+1), n,work(2_${ik}$*n+n*nr+1), u, & + ldu, work(2_${ik}$*n+n*nr+nr+1),lwork-2*n-n*nr-nr, ierr ) do q = 1, nr do p = 1, nr - work(2*n+n*nr+nr+iwork(n+p)) = u(p,q) + work(2_${ik}$*n+n*nr+nr+iwork(n+p)) = u(p,q) end do do p = 1, nr - u(p,q) = work(2*n+n*nr+nr+p) + u(p,q) = work(2_${ik}$*n+n*nr+nr+p) end do end do end if @@ -6533,42 +6531,42 @@ module stdlib_linalg_lapack_${ri}$ temp1 = sqrt(real(n,KIND=${rk}$)) * epsln do q = 1, n do p = 1, n - work(2*n+n*nr+nr+iwork(p)) = v(p,q) + work(2_${ik}$*n+n*nr+nr+iwork(p)) = v(p,q) end do do p = 1, n - v(p,q) = work(2*n+n*nr+nr+p) + v(p,q) = work(2_${ik}$*n+n*nr+nr+p) end do - xsc = one / stdlib_${ri}$nrm2( n, v(1,q), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_${ri}$scal( n, xsc, & - v(1,q), 1 ) + xsc = one / stdlib${ii}$_${ri}$nrm2( n, v(1_${ik}$,q), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_${ri}$scal( n, xsc, & + v(1_${ik}$,q), 1_${ik}$ ) end do ! at this moment, v contains the right singular vectors of a. ! next, assemble the left singular vector matrix u (m x n). if ( nr < m ) then - call stdlib_${ri}$laset( 'A', m-nr, nr, zero, zero, u(nr+1,1), ldu ) + call stdlib${ii}$_${ri}$laset( 'A', m-nr, nr, zero, zero, u(nr+1,1_${ik}$), ldu ) if ( nr < n1 ) then - call stdlib_${ri}$laset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) - call stdlib_${ri}$laset('A',m-nr,n1-nr,zero,one,u(nr+1,nr+1),ldu) + call stdlib${ii}$_${ri}$laset('A',nr,n1-nr,zero,zero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_${ri}$laset('A',m-nr,n1-nr,zero,one,u(nr+1,nr+1),ldu) end if end if ! the q matrix from the first qrf is built into the left singular ! matrix u. this applies to all cases. - call stdlib_${ri}$ormqr( 'LEFT', 'NO_TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & + call stdlib${ii}$_${ri}$ormqr( 'LEFT', 'NO_TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & lwork-n, ierr ) ! the columns of u are normalized. the cost is o(m*n) flops. temp1 = sqrt(real(m,KIND=${rk}$)) * epsln do p = 1, nr - xsc = one / stdlib_${ri}$nrm2( m, u(1,p), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_${ri}$scal( m, xsc, & - u(1,p), 1 ) + xsc = one / stdlib${ii}$_${ri}$nrm2( m, u(1_${ik}$,p), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_${ri}$scal( m, xsc, & + u(1_${ik}$,p), 1_${ik}$ ) end do ! if the initial qrf is computed with row pivoting, the left ! singular vectors must be adjusted. - if ( rowpiv )call stdlib_${ri}$laswp( n1, u, ldu, 1, m-1, iwork(2*n+1), -1 ) + if ( rowpiv )call stdlib${ii}$_${ri}$laswp( n1, u, ldu, 1_${ik}$, m-1, iwork(2_${ik}$*n+1), -1_${ik}$ ) else ! The Initial Matrix A Has Almost Orthogonal Columns And ! the second qrf is not needed - call stdlib_${ri}$lacpy( 'UPPER', n, n, a, lda, work(n+1), n ) + call stdlib${ii}$_${ri}$lacpy( 'UPPER', n, n, a, lda, work(n+1), n ) if ( l2pert ) then xsc = sqrt(small) do p = 2, n @@ -6578,44 +6576,44 @@ module stdlib_linalg_lapack_${ri}$ end do end do else - call stdlib_${ri}$laset( 'LOWER',n-1,n-1,zero,zero,work(n+2),n ) + call stdlib${ii}$_${ri}$laset( 'LOWER',n-1,n-1,zero,zero,work(n+2),n ) end if - call stdlib_${ri}$gesvj( 'UPPER', 'U', 'N', n, n, work(n+1), n, sva,n, u, ldu, work(n+& + call stdlib${ii}$_${ri}$gesvj( 'UPPER', 'U', 'N', n, n, work(n+1), n, sva,n, u, ldu, work(n+& n*n+1), lwork-n-n*n, info ) scalem = work(n+n*n+1) - numrank = nint(work(n+n*n+2),KIND=ilp) + numrank = nint(work(n+n*n+2),KIND=${ik}$) do p = 1, n - call stdlib_${ri}$copy( n, work(n+(p-1)*n+1), 1, u(1,p), 1 ) - call stdlib_${ri}$scal( n, sva(p), work(n+(p-1)*n+1), 1 ) + call stdlib${ii}$_${ri}$copy( n, work(n+(p-1)*n+1), 1_${ik}$, u(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n, sva(p), work(n+(p-1)*n+1), 1_${ik}$ ) end do - call stdlib_${ri}$trsm( 'LEFT', 'UPPER', 'NOTRANS', 'NO UD', n, n,one, a, lda, work(n+& - 1), n ) + call stdlib${ii}$_${ri}$trsm( 'LEFT', 'UPPER', 'NOTRANS', 'NO UD', n, n,one, a, lda, work(n+& + 1_${ik}$), n ) do p = 1, n - call stdlib_${ri}$copy( n, work(n+p), n, v(iwork(p),1), ldv ) + call stdlib${ii}$_${ri}$copy( n, work(n+p), n, v(iwork(p),1_${ik}$), ldv ) end do temp1 = sqrt(real(n,KIND=${rk}$))*epsln do p = 1, n - xsc = one / stdlib_${ri}$nrm2( n, v(1,p), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_${ri}$scal( n, xsc, & - v(1,p), 1 ) + xsc = one / stdlib${ii}$_${ri}$nrm2( n, v(1_${ik}$,p), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_${ri}$scal( n, xsc, & + v(1_${ik}$,p), 1_${ik}$ ) end do ! assemble the left singular vector matrix u (m x n). if ( n < m ) then - call stdlib_${ri}$laset( 'A', m-n, n, zero, zero, u(n+1,1), ldu ) + call stdlib${ii}$_${ri}$laset( 'A', m-n, n, zero, zero, u(n+1,1_${ik}$), ldu ) if ( n < n1 ) then - call stdlib_${ri}$laset( 'A',n, n1-n, zero, zero, u(1,n+1),ldu ) - call stdlib_${ri}$laset( 'A',m-n,n1-n, zero, one,u(n+1,n+1),ldu ) + call stdlib${ii}$_${ri}$laset( 'A',n, n1-n, zero, zero, u(1_${ik}$,n+1),ldu ) + call stdlib${ii}$_${ri}$laset( 'A',m-n,n1-n, zero, one,u(n+1,n+1),ldu ) end if end if - call stdlib_${ri}$ormqr( 'LEFT', 'NO TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & + call stdlib${ii}$_${ri}$ormqr( 'LEFT', 'NO TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & lwork-n, ierr ) temp1 = sqrt(real(m,KIND=${rk}$))*epsln do p = 1, n1 - xsc = one / stdlib_${ri}$nrm2( m, u(1,p), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_${ri}$scal( m, xsc, & - u(1,p), 1 ) + xsc = one / stdlib${ii}$_${ri}$nrm2( m, u(1_${ik}$,p), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_${ri}$scal( m, xsc, & + u(1_${ik}$,p), 1_${ik}$ ) end do - if ( rowpiv )call stdlib_${ri}$laswp( n1, u, ldu, 1, m-1, iwork(2*n+1), -1 ) + if ( rowpiv )call stdlib${ii}$_${ri}$laswp( n1, u, ldu, 1_${ik}$, m-1, iwork(2_${ik}$*n+1), -1_${ik}$ ) end if ! end of the >> almost orthogonal case << in the full svd else @@ -6629,7 +6627,7 @@ module stdlib_linalg_lapack_${ri}$ ! implementation of blas and some lapack procedures, capable of working ! in presence of extreme values. since that is not always the case, ... do p = 1, nr - call stdlib_${ri}$copy( n-p+1, a(p,p), lda, v(p,p), 1 ) + call stdlib${ii}$_${ri}$copy( n-p+1, a(p,p), lda, v(p,p), 1_${ik}$ ) end do if ( l2pert ) then xsc = sqrt(small/epsln) @@ -6642,12 +6640,12 @@ module stdlib_linalg_lapack_${ri}$ end do end do else - call stdlib_${ri}$laset( 'U', nr-1, nr-1, zero, zero, v(1,2), ldv ) + call stdlib${ii}$_${ri}$laset( 'U', nr-1, nr-1, zero, zero, v(1_${ik}$,2_${ik}$), ldv ) end if - call stdlib_${ri}$geqrf( n, nr, v, ldv, work(n+1), work(2*n+1),lwork-2*n, ierr ) - call stdlib_${ri}$lacpy( 'L', n, nr, v, ldv, work(2*n+1), n ) + call stdlib${ii}$_${ri}$geqrf( n, nr, v, ldv, work(n+1), work(2_${ik}$*n+1),lwork-2*n, ierr ) + call stdlib${ii}$_${ri}$lacpy( 'L', n, nr, v, ldv, work(2_${ik}$*n+1), n ) do p = 1, nr - call stdlib_${ri}$copy( nr-p+1, v(p,p), ldv, u(p,p), 1 ) + call stdlib${ii}$_${ri}$copy( nr-p+1, v(p,p), ldv, u(p,p), 1_${ik}$ ) end do if ( l2pert ) then xsc = sqrt(small/epsln) @@ -6658,18 +6656,18 @@ module stdlib_linalg_lapack_${ri}$ end do end do else - call stdlib_${ri}$laset('U', nr-1, nr-1, zero, zero, u(1,2), ldu ) + call stdlib${ii}$_${ri}$laset('U', nr-1, nr-1, zero, zero, u(1_${ik}$,2_${ik}$), ldu ) end if - call stdlib_${ri}$gesvj( 'G', 'U', 'V', nr, nr, u, ldu, sva,n, v, ldv, work(2*n+n*nr+1), & + call stdlib${ii}$_${ri}$gesvj( 'G', 'U', 'V', nr, nr, u, ldu, sva,n, v, ldv, work(2_${ik}$*n+n*nr+1), & lwork-2*n-n*nr, info ) - scalem = work(2*n+n*nr+1) - numrank = nint(work(2*n+n*nr+2),KIND=ilp) + scalem = work(2_${ik}$*n+n*nr+1) + numrank = nint(work(2_${ik}$*n+n*nr+2),KIND=${ik}$) if ( nr < n ) then - call stdlib_${ri}$laset( 'A',n-nr,nr,zero,zero,v(nr+1,1),ldv ) - call stdlib_${ri}$laset( 'A',nr,n-nr,zero,zero,v(1,nr+1),ldv ) - call stdlib_${ri}$laset( 'A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv ) + call stdlib${ii}$_${ri}$laset( 'A',n-nr,nr,zero,zero,v(nr+1,1_${ik}$),ldv ) + call stdlib${ii}$_${ri}$laset( 'A',nr,n-nr,zero,zero,v(1_${ik}$,nr+1),ldv ) + call stdlib${ii}$_${ri}$laset( 'A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv ) end if - call stdlib_${ri}$ormqr( 'L','N',n,n,nr,work(2*n+1),n,work(n+1),v,ldv,work(2*n+n*nr+nr+1)& + call stdlib${ii}$_${ri}$ormqr( 'L','N',n,n,nr,work(2_${ik}$*n+1),n,work(n+1),v,ldv,work(2_${ik}$*n+n*nr+nr+1)& ,lwork-2*n-n*nr-nr,ierr ) ! permute the rows of v using the (column) permutation from the ! first qrf. also, scale the columns to make them unit in @@ -6677,39 +6675,39 @@ module stdlib_linalg_lapack_${ri}$ temp1 = sqrt(real(n,KIND=${rk}$)) * epsln do q = 1, n do p = 1, n - work(2*n+n*nr+nr+iwork(p)) = v(p,q) + work(2_${ik}$*n+n*nr+nr+iwork(p)) = v(p,q) end do do p = 1, n - v(p,q) = work(2*n+n*nr+nr+p) + v(p,q) = work(2_${ik}$*n+n*nr+nr+p) end do - xsc = one / stdlib_${ri}$nrm2( n, v(1,q), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_${ri}$scal( n, xsc, & - v(1,q), 1 ) + xsc = one / stdlib${ii}$_${ri}$nrm2( n, v(1_${ik}$,q), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_${ri}$scal( n, xsc, & + v(1_${ik}$,q), 1_${ik}$ ) end do ! at this moment, v contains the right singular vectors of a. ! next, assemble the left singular vector matrix u (m x n). if ( nr < m ) then - call stdlib_${ri}$laset( 'A', m-nr, nr, zero, zero, u(nr+1,1), ldu ) + call stdlib${ii}$_${ri}$laset( 'A', m-nr, nr, zero, zero, u(nr+1,1_${ik}$), ldu ) if ( nr < n1 ) then - call stdlib_${ri}$laset( 'A',nr, n1-nr, zero, zero, u(1,nr+1),ldu ) - call stdlib_${ri}$laset( 'A',m-nr,n1-nr, zero, one,u(nr+1,nr+1),ldu ) + call stdlib${ii}$_${ri}$laset( 'A',nr, n1-nr, zero, zero, u(1_${ik}$,nr+1),ldu ) + call stdlib${ii}$_${ri}$laset( 'A',m-nr,n1-nr, zero, one,u(nr+1,nr+1),ldu ) end if end if - call stdlib_${ri}$ormqr( 'LEFT', 'NO TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & + call stdlib${ii}$_${ri}$ormqr( 'LEFT', 'NO TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & lwork-n, ierr ) - if ( rowpiv )call stdlib_${ri}$laswp( n1, u, ldu, 1, m-1, iwork(2*n+1), -1 ) + if ( rowpiv )call stdlib${ii}$_${ri}$laswp( n1, u, ldu, 1_${ik}$, m-1, iwork(2_${ik}$*n+1), -1_${ik}$ ) end if if ( transp ) then ! .. swap u and v because the procedure worked on a^t do p = 1, n - call stdlib_${ri}$swap( n, u(1,p), 1, v(1,p), 1 ) + call stdlib${ii}$_${ri}$swap( n, u(1_${ik}$,p), 1_${ik}$, v(1_${ik}$,p), 1_${ik}$ ) end do end if end if ! end of the full svd ! undo scaling, if necessary (and possible) - if ( uscal2 <= (big/sva(1))*uscal1 ) then - call stdlib_${ri}$lascl( 'G', 0, 0, uscal1, uscal2, nr, 1, sva, n, ierr ) + if ( uscal2 <= (big/sva(1_${ik}$))*uscal1 ) then + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, uscal1, uscal2, nr, 1_${ik}$, sva, n, ierr ) uscal1 = one uscal2 = one end if @@ -6718,25 +6716,25 @@ module stdlib_linalg_lapack_${ri}$ sva(p) = zero end do end if - work(1) = uscal2 * scalem - work(2) = uscal1 - if ( errest ) work(3) = sconda + work(1_${ik}$) = uscal2 * scalem + work(2_${ik}$) = uscal1 + if ( errest ) work(3_${ik}$) = sconda if ( lsvec .and. rsvec ) then - work(4) = condr1 - work(5) = condr2 + work(4_${ik}$) = condr1 + work(5_${ik}$) = condr2 end if if ( l2tran ) then - work(6) = entra - work(7) = entrat + work(6_${ik}$) = entra + work(7_${ik}$) = entrat end if - iwork(1) = nr - iwork(2) = numrank - iwork(3) = warning + iwork(1_${ik}$) = nr + iwork(2_${ik}$) = numrank + iwork(3_${ik}$) = warning return - end subroutine stdlib_${ri}$gejsv + end subroutine stdlib${ii}$_${ri}$gejsv - pure subroutine stdlib_${ri}$gelq( m, n, a, lda, t, tsize, work, lwork,info ) + pure subroutine stdlib${ii}$_${ri}$gelq( m, n, a, lda, t, tsize, work, lwork,info ) !! DGELQ: computes an LQ factorization of a real M-by-N matrix A: !! A = ( L 0 ) * Q !! where: @@ -6747,121 +6745,121 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, tsize, lwork + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, tsize, lwork ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: t(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, lminws, mint, minw - integer(ilp) :: mb, nb, mintsz, nblcks, lwmin, lwopt, lwreq + integer(${ik}$) :: mb, nb, mintsz, nblcks, lwmin, lwopt, lwreq ! Intrinsic Functions intrinsic :: max,min,mod ! Executable Statements ! test the input arguments - info = 0 - lquery = ( tsize==-1 .or. tsize==-2 .or.lwork==-1 .or. lwork==-2 ) + info = 0_${ik}$ + lquery = ( tsize==-1_${ik}$ .or. tsize==-2_${ik}$ .or.lwork==-1_${ik}$ .or. lwork==-2_${ik}$ ) mint = .false. minw = .false. - if( tsize==-2 .or. lwork==-2 ) then - if( tsize/=-1 ) mint = .true. - if( lwork/=-1 ) minw = .true. + if( tsize==-2_${ik}$ .or. lwork==-2_${ik}$ ) then + if( tsize/=-1_${ik}$ ) mint = .true. + if( lwork/=-1_${ik}$ ) minw = .true. end if ! determine the block size - if( min( m, n )>0 ) then - mb = stdlib_ilaenv( 1, 'DGELQ ', ' ', m, n, 1, -1 ) - nb = stdlib_ilaenv( 1, 'DGELQ ', ' ', m, n, 2, -1 ) + if( min( m, n )>0_${ik}$ ) then + mb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGELQ ', ' ', m, n, 1_${ik}$, -1_${ik}$ ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGELQ ', ' ', m, n, 2_${ik}$, -1_${ik}$ ) else - mb = 1 + mb = 1_${ik}$ nb = n end if - if( mb>min( m, n ) .or. mb<1 ) mb = 1 + if( mb>min( m, n ) .or. mb<1_${ik}$ ) mb = 1_${ik}$ if( nb>n .or. nb<=m ) nb = n - mintsz = m + 5 + mintsz = m + 5_${ik}$ if ( nb>m .and. n>m ) then - if( mod( n - m, nb - m )==0 ) then + if( mod( n - m, nb - m )==0_${ik}$ ) then nblcks = ( n - m ) / ( nb - m ) else - nblcks = ( n - m ) / ( nb - m ) + 1 + nblcks = ( n - m ) / ( nb - m ) + 1_${ik}$ end if else - nblcks = 1 + nblcks = 1_${ik}$ end if ! determine if the workspace size satisfies minimal size if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then - lwmin = max( 1, n ) - lwopt = max( 1, mb*n ) + lwmin = max( 1_${ik}$, n ) + lwopt = max( 1_${ik}$, mb*n ) else - lwmin = max( 1, m ) - lwopt = max( 1, mb*m ) + lwmin = max( 1_${ik}$, m ) + lwopt = max( 1_${ik}$, mb*m ) end if lminws = .false. - if( ( tsize=lwmin ) .and. ( & + if( ( tsize=lwmin ) .and. ( & tsize>=mintsz ).and. ( .not.lquery ) ) then - if( tsize=n ) ) then - lwreq = max( 1, mb*n ) + lwreq = max( 1_${ik}$, mb*n ) else - lwreq = max( 1, mb*m ) + lwreq = max( 1_${ik}$, mb*m ) end if - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda=n ) ) then - call stdlib_${ri}$gelqt( m, n, mb, a, lda, t( 6 ), mb, work, info ) + call stdlib${ii}$_${ri}$gelqt( m, n, mb, a, lda, t( 6_${ik}$ ), mb, work, info ) else - call stdlib_${ri}$laswlq( m, n, mb, nb, a, lda, t( 6 ), mb, work,lwork, info ) + call stdlib${ii}$_${ri}$laswlq( m, n, mb, nb, a, lda, t( 6_${ik}$ ), mb, work,lwork, info ) end if - work( 1 ) = lwreq + work( 1_${ik}$ ) = lwreq return - end subroutine stdlib_${ri}$gelq + end subroutine stdlib${ii}$_${ri}$gelq - pure subroutine stdlib_${ri}$gelq2( m, n, a, lda, tau, work, info ) + pure subroutine stdlib${ii}$_${ri}$gelq2( m, n, a, lda, tau, work, info ) !! DGELQ2: computes an LQ factorization of a real m-by-n matrix A: !! A = ( L 0 ) * Q !! where: @@ -6872,50 +6870,50 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, k + integer(${ik}$) :: i, k real(${rk}$) :: aii ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda1 .and. nb1_${ik}$ .and. nbmin(m,n) .and. min(m,n)>0 ) )then - info = -3 - else if( ldamin(m,n) .and. min(m,n)>0_${ik}$ ) )then + info = -3_${ik}$ + else if( lda=n ) then - nb = stdlib_ilaenv( 1, 'DGEQRF', ' ', m, n, -1, -1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) if( tpsd ) then - nb = max( nb, stdlib_ilaenv( 1, 'DORMQR', 'LN', m, nrhs, n,-1 ) ) + nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', 'LN', m, nrhs, n,-1_${ik}$ ) ) else - nb = max( nb, stdlib_ilaenv( 1, 'DORMQR', 'LT', m, nrhs, n,-1 ) ) + nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', 'LT', m, nrhs, n,-1_${ik}$ ) ) end if else - nb = stdlib_ilaenv( 1, 'DGELQF', ' ', m, n, -1, -1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGELQF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) if( tpsd ) then - nb = max( nb, stdlib_ilaenv( 1, 'DORMLQ', 'LT', n, nrhs, m,-1 ) ) + nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMLQ', 'LT', n, nrhs, m,-1_${ik}$ ) ) else - nb = max( nb, stdlib_ilaenv( 1, 'DORMLQ', 'LN', n, nrhs, m,-1 ) ) + nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMLQ', 'LN', n, nrhs, m,-1_${ik}$ ) ) end if end if - wsize = max( 1, mn+max( mn, nrhs )*nb ) - work( 1 ) = real( wsize,KIND=${rk}$) + wsize = max( 1_${ik}$, mn+max( mn, nrhs )*nb ) + work( 1_${ik}$ ) = real( wsize,KIND=${rk}$) end if - if( info/=0 ) then - call stdlib_xerbla( 'DGELS ', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DGELS ', -info ) return else if( lquery ) then return end if ! quick return if possible - if( min( m, n, nrhs )==0 ) then - call stdlib_${ri}$laset( 'FULL', max( m, n ), nrhs, zero, zero, b, ldb ) + if( min( m, n, nrhs )==0_${ik}$ ) then + call stdlib${ii}$_${ri}$laset( 'FULL', max( m, n ), nrhs, zero, zero, b, ldb ) return end if ! get machine parameters - smlnum = stdlib_${ri}$lamch( 'S' ) / stdlib_${ri}$lamch( 'P' ) + smlnum = stdlib${ii}$_${ri}$lamch( 'S' ) / stdlib${ii}$_${ri}$lamch( 'P' ) bignum = one / smlnum - call stdlib_${ri}$labad( smlnum, bignum ) + call stdlib${ii}$_${ri}$labad( smlnum, bignum ) ! scale a, b if max element outside range [smlnum,bignum] - anrm = stdlib_${ri}$lange( 'M', m, n, a, lda, rwork ) - iascl = 0 + anrm = stdlib${ii}$_${ri}$lange( 'M', m, n, a, lda, rwork ) + iascl = 0_${ik}$ if( anrm>zero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_${ri}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_${ri}$laset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) + call stdlib${ii}$_${ri}$laset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) go to 50 end if brow = m if( tpsd )brow = n - bnrm = stdlib_${ri}$lange( 'M', brow, nrhs, b, ldb, rwork ) - ibscl = 0 + bnrm = stdlib${ii}$_${ri}$lange( 'M', brow, nrhs, b, ldb, rwork ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_${ri}$lascl( 'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,info ) - ibscl = 2 + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, brow, nrhs, b, ldb,info ) + ibscl = 2_${ik}$ end if if( m>=n ) then ! compute qr factorization of a - call stdlib_${ri}$geqrf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,info ) + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, work( 1_${ik}$ ), work( mn+1 ), lwork-mn,info ) ! workspace at least n, optimally n*nb if( .not.tpsd ) then ! least-squares problem min || a * x - b || ! b(1:m,1:nrhs) := q**t * b(1:m,1:nrhs) - call stdlib_${ri}$ormqr( 'LEFT', 'TRANSPOSE', m, nrhs, n, a, lda,work( 1 ), b, ldb, & + call stdlib${ii}$_${ri}$ormqr( 'LEFT', 'TRANSPOSE', m, nrhs, n, a, lda,work( 1_${ik}$ ), b, ldb, & work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb ! b(1:n,1:nrhs) := inv(r) * b(1:n,1:nrhs) - call stdlib_${ri}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, nrhs,a, lda, b, ldb, & + call stdlib${ii}$_${ri}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, nrhs,a, lda, b, ldb, & info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if scllen = n else ! underdetermined system of equations a**t * x = b ! b(1:n,1:nrhs) := inv(r**t) * b(1:n,1:nrhs) - call stdlib_${ri}$trtrs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,a, lda, b, ldb, & + call stdlib${ii}$_${ri}$trtrs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,a, lda, b, ldb, & info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if ! b(n+1:m,1:nrhs) = zero @@ -7307,21 +7305,21 @@ module stdlib_linalg_lapack_${ri}$ end do end do ! b(1:m,1:nrhs) := q(1:n,:) * b(1:n,1:nrhs) - call stdlib_${ri}$ormqr( 'LEFT', 'NO TRANSPOSE', m, nrhs, n, a, lda,work( 1 ), b, ldb,& + call stdlib${ii}$_${ri}$ormqr( 'LEFT', 'NO TRANSPOSE', m, nrhs, n, a, lda,work( 1_${ik}$ ), b, ldb,& work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb scllen = m end if else ! compute lq factorization of a - call stdlib_${ri}$gelqf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,info ) + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, work( 1_${ik}$ ), work( mn+1 ), lwork-mn,info ) ! workspace at least m, optimally m*nb. if( .not.tpsd ) then ! underdetermined system of equations a * x = b ! b(1:m,1:nrhs) := inv(l) * b(1:m,1:nrhs) - call stdlib_${ri}$trtrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & + call stdlib${ii}$_${ri}$trtrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if ! b(m+1:n,1:nrhs) = 0 @@ -7331,43 +7329,43 @@ module stdlib_linalg_lapack_${ri}$ end do end do ! b(1:n,1:nrhs) := q(1:n,:)**t * b(1:m,1:nrhs) - call stdlib_${ri}$ormlq( 'LEFT', 'TRANSPOSE', n, nrhs, m, a, lda,work( 1 ), b, ldb, & + call stdlib${ii}$_${ri}$ormlq( 'LEFT', 'TRANSPOSE', n, nrhs, m, a, lda,work( 1_${ik}$ ), b, ldb, & work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb scllen = n else ! overdetermined system min || a**t * x - b || ! b(1:n,1:nrhs) := q * b(1:n,1:nrhs) - call stdlib_${ri}$ormlq( 'LEFT', 'NO TRANSPOSE', n, nrhs, m, a, lda,work( 1 ), b, ldb,& + call stdlib${ii}$_${ri}$ormlq( 'LEFT', 'NO TRANSPOSE', n, nrhs, m, a, lda,work( 1_${ik}$ ), b, ldb,& work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb ! b(1:m,1:nrhs) := inv(l**t) * b(1:m,1:nrhs) - call stdlib_${ri}$trtrs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & + call stdlib${ii}$_${ri}$trtrs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if scllen = m end if end if ! undo scaling - if( iascl==1 ) then - call stdlib_${ri}$lascl( 'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,info ) - else if( iascl==2 ) then - call stdlib_${ri}$lascl( 'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,info ) + if( iascl==1_${ik}$ ) then + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, smlnum, scllen, nrhs, b, ldb,info ) + else if( iascl==2_${ik}$ ) then + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, scllen, nrhs, b, ldb,info ) end if - if( ibscl==1 ) then - call stdlib_${ri}$lascl( 'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,info ) - else if( ibscl==2 ) then - call stdlib_${ri}$lascl( 'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,info ) + if( ibscl==1_${ik}$ ) then + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, bnrm, scllen, nrhs, b, ldb,info ) + else if( ibscl==2_${ik}$ ) then + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bignum, bnrm, scllen, nrhs, b, ldb,info ) end if 50 continue - work( 1 ) = real( wsize,KIND=${rk}$) + work( 1_${ik}$ ) = real( wsize,KIND=${rk}$) return - end subroutine stdlib_${ri}$gels + end subroutine stdlib${ii}$_${ri}$gels - subroutine stdlib_${ri}$gelsd( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, iwork, & + subroutine stdlib${ii}$_${ri}$gelsd( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, iwork, & !! DGELSD: computes the minimum-norm solution to a real linear least !! squares problem: !! minimize 2-norm(| b - A*x |) @@ -7398,166 +7396,166 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, rank - integer(ilp), intent(in) :: lda, ldb, lwork, m, n, nrhs + integer(${ik}$), intent(out) :: info, rank + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, nrhs real(${rk}$), intent(in) :: rcond ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) real(${rk}$), intent(out) :: s(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: iascl, ibscl, ie, il, itau, itaup, itauq, ldwork, liwork, maxmn, & + integer(${ik}$) :: iascl, ibscl, ie, il, itau, itaup, itauq, ldwork, liwork, maxmn, & maxwrk, minmn, minwrk, mm, mnthr, nlvl, nwork, smlsiz, wlalsd real(${rk}$) :: anrm, bignum, bnrm, eps, sfmin, smlnum ! Intrinsic Functions intrinsic :: real,int,log,max,min ! Executable Statements ! test the input arguments. - info = 0 + info = 0_${ik}$ minmn = min( m, n ) maxmn = max( m, n ) - mnthr = stdlib_ilaenv( 6, 'DGELSD', ' ', m, n, nrhs, -1 ) - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( lda=n .and. m>=mnthr ) then ! path 1a - overdetermined, with many more rows than columns. mm = n - maxwrk = max( maxwrk, n+n*stdlib_ilaenv( 1, 'DGEQRF', ' ', m, n,-1, -1 ) ) + maxwrk = max( maxwrk, n+n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQRF', ' ', m, n,-1_${ik}$, -1_${ik}$ ) ) - maxwrk = max( maxwrk, n+nrhs*stdlib_ilaenv( 1, 'DORMQR', 'LT', m, nrhs, n, -1 ) ) + maxwrk = max( maxwrk, n+nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', 'LT', m, nrhs, n, -1_${ik}$ ) ) end if if( m>=n ) then ! path 1 - overdetermined or exactly determined. - maxwrk = max( maxwrk, 3*n+( mm+n )*stdlib_ilaenv( 1, 'DGEBRD', ' ', mm, n, -1, -& - 1 ) ) - maxwrk = max( maxwrk, 3*n+nrhs*stdlib_ilaenv( 1, 'DORMBR', 'QLT', mm, nrhs, n, -& - 1 ) ) - maxwrk = max( maxwrk, 3*n+( n-1 )*stdlib_ilaenv( 1, 'DORMBR', 'PLN', n, nrhs, n, & - -1 ) ) - wlalsd = 9*n+2*n*smlsiz+8*n*nlvl+n*nrhs+(smlsiz+1)**2 - maxwrk = max( maxwrk, 3*n+wlalsd ) - minwrk = max( 3*n+mm, 3*n+nrhs, 3*n+wlalsd ) + maxwrk = max( maxwrk, 3_${ik}$*n+( mm+n )*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEBRD', ' ', mm, n, -1_${ik}$, -& + 1_${ik}$ ) ) + maxwrk = max( maxwrk, 3_${ik}$*n+nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMBR', 'QLT', mm, nrhs, n, -& + 1_${ik}$ ) ) + maxwrk = max( maxwrk, 3_${ik}$*n+( n-1 )*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMBR', 'PLN', n, nrhs, n, & + -1_${ik}$ ) ) + wlalsd = 9_${ik}$*n+2*n*smlsiz+8*n*nlvl+n*nrhs+(smlsiz+1)**2_${ik}$ + maxwrk = max( maxwrk, 3_${ik}$*n+wlalsd ) + minwrk = max( 3_${ik}$*n+mm, 3_${ik}$*n+nrhs, 3_${ik}$*n+wlalsd ) end if if( n>m ) then - wlalsd = 9*m+2*m*smlsiz+8*m*nlvl+m*nrhs+(smlsiz+1)**2 + wlalsd = 9_${ik}$*m+2*m*smlsiz+8*m*nlvl+m*nrhs+(smlsiz+1)**2_${ik}$ if( n>=mnthr ) then ! path 2a - underdetermined, with many more columns ! than rows. - maxwrk = m + m*stdlib_ilaenv( 1, 'DGELQF', ' ', m, n, -1, -1 ) - maxwrk = max( maxwrk, m*m+4*m+2*m*stdlib_ilaenv( 1, 'DGEBRD', ' ', m, m, -1, -& - 1 ) ) - maxwrk = max( maxwrk, m*m+4*m+nrhs*stdlib_ilaenv( 1, 'DORMBR', 'QLT', m, nrhs,& - m, -1 ) ) - maxwrk = max( maxwrk, m*m+4*m+( m-1 )*stdlib_ilaenv( 1, 'DORMBR', 'PLN', m, & - nrhs, m, -1 ) ) - if( nrhs>1 ) then + maxwrk = m + m*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGELQF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) + maxwrk = max( maxwrk, m*m+4*m+2*m*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEBRD', ' ', m, m, -1_${ik}$, -& + 1_${ik}$ ) ) + maxwrk = max( maxwrk, m*m+4*m+nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMBR', 'QLT', m, nrhs,& + m, -1_${ik}$ ) ) + maxwrk = max( maxwrk, m*m+4*m+( m-1 )*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMBR', 'PLN', m, & + nrhs, m, -1_${ik}$ ) ) + if( nrhs>1_${ik}$ ) then maxwrk = max( maxwrk, m*m+m+m*nrhs ) else maxwrk = max( maxwrk, m*m+2*m ) end if - maxwrk = max( maxwrk, m+nrhs*stdlib_ilaenv( 1, 'DORMLQ', 'LT', n, nrhs, m, -1 & + maxwrk = max( maxwrk, m+nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMLQ', 'LT', n, nrhs, m, -1_${ik}$ & ) ) maxwrk = max( maxwrk, m*m+4*m+wlalsd ) ! xxx: ensure the path 2a case below is triggered. the workspace ! calculation should use queries for all routines eventually. - maxwrk = max( maxwrk,4*m+m*m+max( m, 2*m-4, nrhs, n-3*m ) ) + maxwrk = max( maxwrk,4_${ik}$*m+m*m+max( m, 2_${ik}$*m-4, nrhs, n-3*m ) ) else ! path 2 - remaining underdetermined cases. - maxwrk = 3*m + ( n+m )*stdlib_ilaenv( 1, 'DGEBRD', ' ', m, n,-1, -1 ) - maxwrk = max( maxwrk, 3*m+nrhs*stdlib_ilaenv( 1, 'DORMBR', 'QLT', m, nrhs, n, & - -1 ) ) - maxwrk = max( maxwrk, 3*m+m*stdlib_ilaenv( 1, 'DORMBR', 'PLN', n, nrhs, m, -1 & + maxwrk = 3_${ik}$*m + ( n+m )*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEBRD', ' ', m, n,-1_${ik}$, -1_${ik}$ ) + maxwrk = max( maxwrk, 3_${ik}$*m+nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMBR', 'QLT', m, nrhs, n, & + -1_${ik}$ ) ) + maxwrk = max( maxwrk, 3_${ik}$*m+m*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMBR', 'PLN', n, nrhs, m, -1_${ik}$ & ) ) - maxwrk = max( maxwrk, 3*m+wlalsd ) + maxwrk = max( maxwrk, 3_${ik}$*m+wlalsd ) end if - minwrk = max( 3*m+nrhs, 3*m+m, 3*m+wlalsd ) + minwrk = max( 3_${ik}$*m+nrhs, 3_${ik}$*m+m, 3_${ik}$*m+wlalsd ) end if minwrk = min( minwrk, maxwrk ) - work( 1 ) = maxwrk - iwork( 1 ) = liwork + work( 1_${ik}$ ) = maxwrk + iwork( 1_${ik}$ ) = liwork if( lworkzero .and. anrmbignum ) then ! scale matrix norm down to bignum. - call stdlib_${ri}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_${ri}$laset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) - call stdlib_${ri}$laset( 'F', minmn, 1, zero, zero, s, 1 ) - rank = 0 + call stdlib${ii}$_${ri}$laset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) + call stdlib${ii}$_${ri}$laset( 'F', minmn, 1_${ik}$, zero, zero, s, 1_${ik}$ ) + rank = 0_${ik}$ go to 10 end if ! scale b if max entry outside range [smlnum,bignum]. - bnrm = stdlib_${ri}$lange( 'M', m, nrhs, b, ldb, work ) - ibscl = 0 + bnrm = stdlib${ii}$_${ri}$lange( 'M', m, nrhs, b, ldb, work ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum. - call stdlib_${ri}$lascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) - ibscl = 2 + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, m, nrhs, b, ldb, info ) + ibscl = 2_${ik}$ end if ! if m < n make sure certain entries of b are zero. - if( m=n ) then ! path 1 - overdetermined or exactly determined. @@ -7565,132 +7563,132 @@ module stdlib_linalg_lapack_${ri}$ if( m>=mnthr ) then ! path 1a - overdetermined, with many more rows than columns. mm = n - itau = 1 + itau = 1_${ik}$ nwork = itau + n ! compute a=q*r. ! (workspace: need 2*n, prefer n+n*nb) - call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & info ) ! multiply b by transpose(q). ! (workspace: need n+nrhs, prefer n+nrhs*nb) - call stdlib_${ri}$ormqr( 'L', 'T', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & + call stdlib${ii}$_${ri}$ormqr( 'L', 'T', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & nwork ), lwork-nwork+1, info ) ! zero out below r. - if( n>1 ) then - call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_${ri}$laset( 'L', n-1, n-1, zero, zero, a( 2_${ik}$, 1_${ik}$ ), lda ) end if end if - ie = 1 + ie = 1_${ik}$ itauq = ie + n itaup = itauq + n nwork = itaup + n ! bidiagonalize r in a. ! (workspace: need 3*n+mm, prefer 3*n+(mm+n)*nb) - call stdlib_${ri}$gebrd( mm, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work(& + call stdlib${ii}$_${ri}$gebrd( mm, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work(& nwork ), lwork-nwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors of r. ! (workspace: need 3*n+nrhs, prefer 3*n+nrhs*nb) - call stdlib_${ri}$ormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & nwork ), lwork-nwork+1, info ) ! solve the bidiagonal least squares problem. - call stdlib_${ri}$lalsd( 'U', smlsiz, n, nrhs, s, work( ie ), b, ldb,rcond, rank, work( & + call stdlib${ii}$_${ri}$lalsd( 'U', smlsiz, n, nrhs, s, work( ie ), b, ldb,rcond, rank, work( & nwork ), iwork, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then go to 10 end if ! multiply b by right bidiagonalizing vectors of r. - call stdlib_${ri}$ormbr( 'P', 'L', 'N', n, nrhs, n, a, lda, work( itaup ),b, ldb, work( & + call stdlib${ii}$_${ri}$ormbr( 'P', 'L', 'N', n, nrhs, n, a, lda, work( itaup ),b, ldb, work( & nwork ), lwork-nwork+1, info ) - else if( n>=mnthr .and. lwork>=4*m+m*m+max( m, 2*m-4, nrhs, n-3*m, wlalsd ) ) & + else if( n>=mnthr .and. lwork>=4_${ik}$*m+m*m+max( m, 2_${ik}$*m-4, nrhs, n-3*m, wlalsd ) ) & then ! path 2a - underdetermined, with many more columns than rows ! and sufficient workspace for an efficient algorithm. ldwork = m - if( lwork>=max( 4*m+m*lda+max( m, 2*m-4, nrhs, n-3*m ),m*lda+m+m*nrhs, 4*m+m*lda+& + if( lwork>=max( 4_${ik}$*m+m*lda+max( m, 2_${ik}$*m-4, nrhs, n-3*m ),m*lda+m+m*nrhs, 4_${ik}$*m+m*lda+& wlalsd ) )ldwork = lda - itau = 1 - nwork = m + 1 + itau = 1_${ik}$ + nwork = m + 1_${ik}$ ! compute a=l*q. ! (workspace: need 2*m, prefer m+m*nb) - call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, info ) + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, info ) il = nwork ! copy l to work(il), zeroing out above its diagonal. - call stdlib_${ri}$lacpy( 'L', m, m, a, lda, work( il ), ldwork ) - call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, work( il+ldwork ),ldwork ) + call stdlib${ii}$_${ri}$lacpy( 'L', m, m, a, lda, work( il ), ldwork ) + call stdlib${ii}$_${ri}$laset( 'U', m-1, m-1, zero, zero, work( il+ldwork ),ldwork ) ie = il + ldwork*m itauq = ie + m itaup = itauq + m nwork = itaup + m ! bidiagonalize l in work(il). ! (workspace: need m*m+5*m, prefer m*m+4*m+2*m*nb) - call stdlib_${ri}$gebrd( m, m, work( il ), ldwork, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_${ri}$gebrd( m, m, work( il ), ldwork, s, work( ie ),work( itauq ), work( & itaup ), work( nwork ),lwork-nwork+1, info ) ! multiply b by transpose of left bidiagonalizing vectors of l. ! (workspace: need m*m+4*m+nrhs, prefer m*m+4*m+nrhs*nb) - call stdlib_${ri}$ormbr( 'Q', 'L', 'T', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'T', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & ldb, work( nwork ),lwork-nwork+1, info ) ! solve the bidiagonal least squares problem. - call stdlib_${ri}$lalsd( 'U', smlsiz, m, nrhs, s, work( ie ), b, ldb,rcond, rank, work( & + call stdlib${ii}$_${ri}$lalsd( 'U', smlsiz, m, nrhs, s, work( ie ), b, ldb,rcond, rank, work( & nwork ), iwork, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then go to 10 end if ! multiply b by right bidiagonalizing vectors of l. - call stdlib_${ri}$ormbr( 'P', 'L', 'N', m, nrhs, m, work( il ), ldwork,work( itaup ), b, & + call stdlib${ii}$_${ri}$ormbr( 'P', 'L', 'N', m, nrhs, m, work( il ), ldwork,work( itaup ), b, & ldb, work( nwork ),lwork-nwork+1, info ) ! zero out below first m rows of b. - call stdlib_${ri}$laset( 'F', n-m, nrhs, zero, zero, b( m+1, 1 ), ldb ) + call stdlib${ii}$_${ri}$laset( 'F', n-m, nrhs, zero, zero, b( m+1, 1_${ik}$ ), ldb ) nwork = itau + m ! multiply transpose(q) by b. ! (workspace: need m+nrhs, prefer m+nrhs*nb) - call stdlib_${ri}$ormlq( 'L', 'T', n, nrhs, m, a, lda, work( itau ), b,ldb, work( nwork )& + call stdlib${ii}$_${ri}$ormlq( 'L', 'T', n, nrhs, m, a, lda, work( itau ), b,ldb, work( nwork )& , lwork-nwork+1, info ) else ! path 2 - remaining underdetermined cases. - ie = 1 + ie = 1_${ik}$ itauq = ie + m itaup = itauq + m nwork = itaup + m ! bidiagonalize a. ! (workspace: need 3*m+n, prefer 3*m+(m+n)*nb) - call stdlib_${ri}$gebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work( & + call stdlib${ii}$_${ri}$gebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work( & nwork ), lwork-nwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors. ! (workspace: need 3*m+nrhs, prefer 3*m+nrhs*nb) - call stdlib_${ri}$ormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & nwork ), lwork-nwork+1, info ) ! solve the bidiagonal least squares problem. - call stdlib_${ri}$lalsd( 'L', smlsiz, m, nrhs, s, work( ie ), b, ldb,rcond, rank, work( & + call stdlib${ii}$_${ri}$lalsd( 'L', smlsiz, m, nrhs, s, work( ie ), b, ldb,rcond, rank, work( & nwork ), iwork, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then go to 10 end if ! multiply b by right bidiagonalizing vectors of a. - call stdlib_${ri}$ormbr( 'P', 'L', 'N', n, nrhs, m, a, lda, work( itaup ),b, ldb, work( & + call stdlib${ii}$_${ri}$ormbr( 'P', 'L', 'N', n, nrhs, m, a, lda, work( itaup ),b, ldb, work( & nwork ), lwork-nwork+1, info ) end if ! undo scaling. - if( iascl==1 ) then - call stdlib_${ri}$lascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info ) - call stdlib_${ri}$lascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn,info ) - else if( iascl==2 ) then - call stdlib_${ri}$lascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info ) - call stdlib_${ri}$lascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,info ) - end if - if( ibscl==1 ) then - call stdlib_${ri}$lascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info ) - else if( ibscl==2 ) then - call stdlib_${ri}$lascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info ) + if( iascl==1_${ik}$ ) then + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, smlnum, n, nrhs, b, ldb, info ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, anrm, minmn, 1_${ik}$, s, minmn,info ) + else if( iascl==2_${ik}$ ) then + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, n, nrhs, b, ldb, info ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn, 1_${ik}$, s, minmn,info ) + end if + if( ibscl==1_${ik}$ ) then + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, bnrm, n, nrhs, b, ldb, info ) + else if( ibscl==2_${ik}$ ) then + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bignum, bnrm, n, nrhs, b, ldb, info ) end if 10 continue - work( 1 ) = maxwrk - iwork( 1 ) = liwork + work( 1_${ik}$ ) = maxwrk + iwork( 1_${ik}$ ) = liwork return - end subroutine stdlib_${ri}$gelsd + end subroutine stdlib${ii}$_${ri}$gelsd - subroutine stdlib_${ri}$gelss( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, info ) + subroutine stdlib${ii}$_${ri}$gelss( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, info ) !! DGELSS: computes the minimum norm solution to a real linear least !! squares problem: !! Minimize 2-norm(| b - A*x |). @@ -7708,8 +7706,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, rank - integer(ilp), intent(in) :: lda, ldb, lwork, m, n, nrhs + integer(${ik}$), intent(out) :: info, rank + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, nrhs real(${rk}$), intent(in) :: rcond ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) @@ -7718,190 +7716,190 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: lquery - integer(ilp) :: bdspac, bl, chunk, i, iascl, ibscl, ie, il, itau, itaup, itauq, iwork, & + integer(${ik}$) :: bdspac, bl, chunk, i, iascl, ibscl, ie, il, itau, itaup, itauq, iwork, & ldwork, maxmn, maxwrk, minmn, minwrk, mm, mnthr - integer(ilp) :: lwork_qgeqrf, lwork_qormqr, lwork_qgebrd, lwork_qormbr, lwork_qorgbr, & + integer(${ik}$) :: lwork_qgeqrf, lwork_qormqr, lwork_qgebrd, lwork_qormbr, lwork_qorgbr, & lwork_qormlq, lwork_qgelqf real(${rk}$) :: anrm, bignum, bnrm, eps, sfmin, smlnum, thr ! Local Arrays - real(${rk}$) :: dum(1) + real(${rk}$) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ minmn = min( m, n ) maxmn = max( m, n ) - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( lda0 ) then + ! following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + if( minmn>0_${ik}$ ) then mm = m - mnthr = stdlib_ilaenv( 6, 'DGELSS', ' ', m, n, nrhs, -1 ) + mnthr = stdlib${ii}$_ilaenv( 6_${ik}$, 'DGELSS', ' ', m, n, nrhs, -1_${ik}$ ) if( m>=n .and. m>=mnthr ) then ! path 1a - overdetermined, with many more rows than ! columns - ! compute space needed for stdlib_${ri}$geqrf - call stdlib_${ri}$geqrf( m, n, a, lda, dum(1), dum(1), -1, info ) - lwork_qgeqrf=dum(1) - ! compute space needed for stdlib_${ri}$ormqr - call stdlib_${ri}$ormqr( 'L', 'T', m, nrhs, n, a, lda, dum(1), b,ldb, dum(1), -1, & + ! compute space needed for stdlib${ii}$_${ri}$geqrf + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, info ) + lwork_qgeqrf=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_${ri}$ormqr + call stdlib${ii}$_${ri}$ormqr( 'L', 'T', m, nrhs, n, a, lda, dum(1_${ik}$), b,ldb, dum(1_${ik}$), -1_${ik}$, & info ) - lwork_qormqr=dum(1) + lwork_qormqr=dum(1_${ik}$) mm = n maxwrk = max( maxwrk, n + lwork_qgeqrf ) maxwrk = max( maxwrk, n + lwork_qormqr ) end if if( m>=n ) then ! path 1 - overdetermined or exactly determined - ! compute workspace needed for stdlib_${ri}$bdsqr - bdspac = max( 1, 5*n ) - ! compute space needed for stdlib_${ri}$gebrd - call stdlib_${ri}$gebrd( mm, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, info & + ! compute workspace needed for stdlib${ii}$_${ri}$bdsqr + bdspac = max( 1_${ik}$, 5_${ik}$*n ) + ! compute space needed for stdlib${ii}$_${ri}$gebrd + call stdlib${ii}$_${ri}$gebrd( mm, n, a, lda, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, info & ) - lwork_qgebrd=dum(1) - ! compute space needed for stdlib_${ri}$ormbr - call stdlib_${ri}$ormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, dum(1),b, ldb, dum(1),& - -1, info ) - lwork_qormbr=dum(1) - ! compute space needed for stdlib_${ri}$orgbr - call stdlib_${ri}$orgbr( 'P', n, n, n, a, lda, dum(1),dum(1), -1, info ) - lwork_qorgbr=dum(1) + lwork_qgebrd=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_${ri}$ormbr + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, dum(1_${ik}$),b, ldb, dum(1_${ik}$),& + -1_${ik}$, info ) + lwork_qormbr=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_${ri}$orgbr + call stdlib${ii}$_${ri}$orgbr( 'P', n, n, n, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, info ) + lwork_qorgbr=dum(1_${ik}$) ! compute total workspace needed - maxwrk = max( maxwrk, 3*n + lwork_qgebrd ) - maxwrk = max( maxwrk, 3*n + lwork_qormbr ) - maxwrk = max( maxwrk, 3*n + lwork_qorgbr ) + maxwrk = max( maxwrk, 3_${ik}$*n + lwork_qgebrd ) + maxwrk = max( maxwrk, 3_${ik}$*n + lwork_qormbr ) + maxwrk = max( maxwrk, 3_${ik}$*n + lwork_qorgbr ) maxwrk = max( maxwrk, bdspac ) maxwrk = max( maxwrk, n*nrhs ) - minwrk = max( 3*n + mm, 3*n + nrhs, bdspac ) + minwrk = max( 3_${ik}$*n + mm, 3_${ik}$*n + nrhs, bdspac ) maxwrk = max( minwrk, maxwrk ) end if if( n>m ) then - ! compute workspace needed for stdlib_${ri}$bdsqr - bdspac = max( 1, 5*m ) - minwrk = max( 3*m+nrhs, 3*m+n, bdspac ) + ! compute workspace needed for stdlib${ii}$_${ri}$bdsqr + bdspac = max( 1_${ik}$, 5_${ik}$*m ) + minwrk = max( 3_${ik}$*m+nrhs, 3_${ik}$*m+n, bdspac ) if( n>=mnthr ) then ! path 2a - underdetermined, with many more columns ! than rows - ! compute space needed for stdlib_${ri}$gelqf - call stdlib_${ri}$gelqf( m, n, a, lda, dum(1), dum(1),-1, info ) - lwork_qgelqf=dum(1) - ! compute space needed for stdlib_${ri}$gebrd - call stdlib_${ri}$gebrd( m, m, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, & + ! compute space needed for stdlib${ii}$_${ri}$gelqf + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, dum(1_${ik}$), dum(1_${ik}$),-1_${ik}$, info ) + lwork_qgelqf=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_${ri}$gebrd + call stdlib${ii}$_${ri}$gebrd( m, m, a, lda, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, & info ) - lwork_qgebrd=dum(1) - ! compute space needed for stdlib_${ri}$ormbr - call stdlib_${ri}$ormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda,dum(1), b, ldb, dum(& - 1), -1, info ) - lwork_qormbr=dum(1) - ! compute space needed for stdlib_${ri}$orgbr - call stdlib_${ri}$orgbr( 'P', m, m, m, a, lda, dum(1),dum(1), -1, info ) - lwork_qorgbr=dum(1) - ! compute space needed for stdlib_${ri}$ormlq - call stdlib_${ri}$ormlq( 'L', 'T', n, nrhs, m, a, lda, dum(1),b, ldb, dum(1), -& - 1, info ) - lwork_qormlq=dum(1) + lwork_qgebrd=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_${ri}$ormbr + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda,dum(1_${ik}$), b, ldb, dum(& + 1_${ik}$), -1_${ik}$, info ) + lwork_qormbr=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_${ri}$orgbr + call stdlib${ii}$_${ri}$orgbr( 'P', m, m, m, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, info ) + lwork_qorgbr=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_${ri}$ormlq + call stdlib${ii}$_${ri}$ormlq( 'L', 'T', n, nrhs, m, a, lda, dum(1_${ik}$),b, ldb, dum(1_${ik}$), -& + 1_${ik}$, info ) + lwork_qormlq=dum(1_${ik}$) ! compute total workspace needed maxwrk = m + lwork_qgelqf - maxwrk = max( maxwrk, m*m + 4*m + lwork_qgebrd ) - maxwrk = max( maxwrk, m*m + 4*m + lwork_qormbr ) - maxwrk = max( maxwrk, m*m + 4*m + lwork_qorgbr ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + lwork_qgebrd ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + lwork_qormbr ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + lwork_qorgbr ) maxwrk = max( maxwrk, m*m + m + bdspac ) - if( nrhs>1 ) then + if( nrhs>1_${ik}$ ) then maxwrk = max( maxwrk, m*m + m + m*nrhs ) else - maxwrk = max( maxwrk, m*m + 2*m ) + maxwrk = max( maxwrk, m*m + 2_${ik}$*m ) end if maxwrk = max( maxwrk, m + lwork_qormlq ) else ! path 2 - underdetermined - ! compute space needed for stdlib_${ri}$gebrd - call stdlib_${ri}$gebrd( m, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, & + ! compute space needed for stdlib${ii}$_${ri}$gebrd + call stdlib${ii}$_${ri}$gebrd( m, n, a, lda, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, & info ) - lwork_qgebrd=dum(1) - ! compute space needed for stdlib_${ri}$ormbr - call stdlib_${ri}$ormbr( 'Q', 'L', 'T', m, nrhs, m, a, lda,dum(1), b, ldb, dum(& - 1), -1, info ) - lwork_qormbr=dum(1) - ! compute space needed for stdlib_${ri}$orgbr - call stdlib_${ri}$orgbr( 'P', m, n, m, a, lda, dum(1),dum(1), -1, info ) - lwork_qorgbr=dum(1) - maxwrk = 3*m + lwork_qgebrd - maxwrk = max( maxwrk, 3*m + lwork_qormbr ) - maxwrk = max( maxwrk, 3*m + lwork_qorgbr ) + lwork_qgebrd=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_${ri}$ormbr + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'T', m, nrhs, m, a, lda,dum(1_${ik}$), b, ldb, dum(& + 1_${ik}$), -1_${ik}$, info ) + lwork_qormbr=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_${ri}$orgbr + call stdlib${ii}$_${ri}$orgbr( 'P', m, n, m, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, info ) + lwork_qorgbr=dum(1_${ik}$) + maxwrk = 3_${ik}$*m + lwork_qgebrd + maxwrk = max( maxwrk, 3_${ik}$*m + lwork_qormbr ) + maxwrk = max( maxwrk, 3_${ik}$*m + lwork_qorgbr ) maxwrk = max( maxwrk, bdspac ) maxwrk = max( maxwrk, n*nrhs ) end if end if maxwrk = max( minwrk, maxwrk ) end if - work( 1 ) = maxwrk - if( lworkzero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_${ri}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_${ri}$laset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) - call stdlib_${ri}$laset( 'F', minmn, 1, zero, zero, s, minmn ) - rank = 0 + call stdlib${ii}$_${ri}$laset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) + call stdlib${ii}$_${ri}$laset( 'F', minmn, 1_${ik}$, zero, zero, s, minmn ) + rank = 0_${ik}$ go to 70 end if ! scale b if max element outside range [smlnum,bignum] - bnrm = stdlib_${ri}$lange( 'M', m, nrhs, b, ldb, work ) - ibscl = 0 + bnrm = stdlib${ii}$_${ri}$lange( 'M', m, nrhs, b, ldb, work ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_${ri}$lascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) - ibscl = 2 + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, m, nrhs, b, ldb, info ) + ibscl = 2_${ik}$ end if ! overdetermined case if( m>=n ) then @@ -7910,229 +7908,229 @@ module stdlib_linalg_lapack_${ri}$ if( m>=mnthr ) then ! path 1a - overdetermined, with many more rows than columns mm = n - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r ! (workspace: need 2*n, prefer n+n*nb) - call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & info ) ! multiply b by transpose(q) ! (workspace: need n+nrhs, prefer n+nrhs*nb) - call stdlib_${ri}$ormqr( 'L', 'T', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & + call stdlib${ii}$_${ri}$ormqr( 'L', 'T', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & iwork ), lwork-iwork+1, info ) ! zero out below r - if( n>1 )call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) + if( n>1_${ik}$ )call stdlib${ii}$_${ri}$laset( 'L', n-1, n-1, zero, zero, a( 2_${ik}$, 1_${ik}$ ), lda ) end if - ie = 1 + ie = 1_${ik}$ itauq = ie + n itaup = itauq + n iwork = itaup + n ! bidiagonalize r in a ! (workspace: need 3*n+mm, prefer 3*n+(mm+n)*nb) - call stdlib_${ri}$gebrd( mm, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work(& + call stdlib${ii}$_${ri}$gebrd( mm, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work(& iwork ), lwork-iwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors of r ! (workspace: need 3*n+nrhs, prefer 3*n+nrhs*nb) - call stdlib_${ri}$ormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & iwork ), lwork-iwork+1, info ) ! generate right bidiagonalizing vectors of r in a ! (workspace: need 4*n-1, prefer 3*n+(n-1)*nb) - call stdlib_${ri}$orgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-iwork+& - 1, info ) + call stdlib${ii}$_${ri}$orgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-iwork+& + 1_${ik}$, info ) iwork = ie + n ! perform bidiagonal qr iteration ! multiply b by transpose of left singular vectors ! compute right singular vectors in a ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'U', n, n, 0, nrhs, s, work( ie ), a, lda, dum,1, b, ldb, work( & + call stdlib${ii}$_${ri}$bdsqr( 'U', n, n, 0_${ik}$, nrhs, s, work( ie ), a, lda, dum,1_${ik}$, b, ldb, work( & iwork ), info ) if( info/=0 )go to 70 ! multiply b by reciprocals of singular values - thr = max( rcond*s( 1 ), sfmin ) - if( rcondthr ) then - call stdlib_${ri}$rscl( nrhs, s( i ), b( i, 1 ), ldb ) - rank = rank + 1 + call stdlib${ii}$_${ri}$rscl( nrhs, s( i ), b( i, 1_${ik}$ ), ldb ) + rank = rank + 1_${ik}$ else - call stdlib_${ri}$laset( 'F', 1, nrhs, zero, zero, b( i, 1 ), ldb ) + call stdlib${ii}$_${ri}$laset( 'F', 1_${ik}$, nrhs, zero, zero, b( i, 1_${ik}$ ), ldb ) end if end do ! multiply b by right singular vectors ! (workspace: need n, prefer n*nrhs) - if( lwork>=ldb*nrhs .and. nrhs>1 ) then - call stdlib_${ri}$gemm( 'T', 'N', n, nrhs, n, one, a, lda, b, ldb, zero,work, ldb ) + if( lwork>=ldb*nrhs .and. nrhs>1_${ik}$ ) then + call stdlib${ii}$_${ri}$gemm( 'T', 'N', n, nrhs, n, one, a, lda, b, ldb, zero,work, ldb ) - call stdlib_${ri}$lacpy( 'G', n, nrhs, work, ldb, b, ldb ) - else if( nrhs>1 ) then + call stdlib${ii}$_${ri}$lacpy( 'G', n, nrhs, work, ldb, b, ldb ) + else if( nrhs>1_${ik}$ ) then chunk = lwork / n do i = 1, nrhs, chunk bl = min( nrhs-i+1, chunk ) - call stdlib_${ri}$gemm( 'T', 'N', n, bl, n, one, a, lda, b( 1, i ),ldb, zero, work,& + call stdlib${ii}$_${ri}$gemm( 'T', 'N', n, bl, n, one, a, lda, b( 1_${ik}$, i ),ldb, zero, work,& n ) - call stdlib_${ri}$lacpy( 'G', n, bl, work, n, b( 1, i ), ldb ) + call stdlib${ii}$_${ri}$lacpy( 'G', n, bl, work, n, b( 1_${ik}$, i ), ldb ) end do else - call stdlib_${ri}$gemv( 'T', n, n, one, a, lda, b, 1, zero, work, 1 ) - call stdlib_${ri}$copy( n, work, 1, b, 1 ) + call stdlib${ii}$_${ri}$gemv( 'T', n, n, one, a, lda, b, 1_${ik}$, zero, work, 1_${ik}$ ) + call stdlib${ii}$_${ri}$copy( n, work, 1_${ik}$, b, 1_${ik}$ ) end if - else if( n>=mnthr .and. lwork>=4*m+m*m+max( m, 2*m-4, nrhs, n-3*m ) ) then + else if( n>=mnthr .and. lwork>=4_${ik}$*m+m*m+max( m, 2_${ik}$*m-4, nrhs, n-3*m ) ) then ! path 2a - underdetermined, with many more columns than rows ! and sufficient workspace for an efficient algorithm ldwork = m - if( lwork>=max( 4*m+m*lda+max( m, 2*m-4, nrhs, n-3*m ),m*lda+m+m*nrhs ) )ldwork = & + if( lwork>=max( 4_${ik}$*m+m*lda+max( m, 2_${ik}$*m-4, nrhs, n-3*m ),m*lda+m+m*nrhs ) )ldwork = & lda - itau = 1 - iwork = m + 1 + itau = 1_${ik}$ + iwork = m + 1_${ik}$ ! compute a=l*q ! (workspace: need 2*m, prefer m+m*nb) - call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, info ) + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, info ) il = iwork ! copy l to work(il), zeroing out above it - call stdlib_${ri}$lacpy( 'L', m, m, a, lda, work( il ), ldwork ) - call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, work( il+ldwork ),ldwork ) + call stdlib${ii}$_${ri}$lacpy( 'L', m, m, a, lda, work( il ), ldwork ) + call stdlib${ii}$_${ri}$laset( 'U', m-1, m-1, zero, zero, work( il+ldwork ),ldwork ) ie = il + ldwork*m itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize l in work(il) ! (workspace: need m*m+5*m, prefer m*m+4*m+2*m*nb) - call stdlib_${ri}$gebrd( m, m, work( il ), ldwork, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_${ri}$gebrd( m, m, work( il ), ldwork, s, work( ie ),work( itauq ), work( & itaup ), work( iwork ),lwork-iwork+1, info ) ! multiply b by transpose of left bidiagonalizing vectors of l ! (workspace: need m*m+4*m+nrhs, prefer m*m+4*m+nrhs*nb) - call stdlib_${ri}$ormbr( 'Q', 'L', 'T', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'T', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & ldb, work( iwork ),lwork-iwork+1, info ) ! generate right bidiagonalizing vectors of r in work(il) ! (workspace: need m*m+5*m-1, prefer m*m+4*m+(m-1)*nb) - call stdlib_${ri}$orgbr( 'P', m, m, m, work( il ), ldwork, work( itaup ),work( iwork ), & + call stdlib${ii}$_${ri}$orgbr( 'P', m, m, m, work( il ), ldwork, work( itaup ),work( iwork ), & lwork-iwork+1, info ) iwork = ie + m ! perform bidiagonal qr iteration, ! computing right singular vectors of l in work(il) and ! multiplying b by transpose of left singular vectors ! (workspace: need m*m+m+bdspac) - call stdlib_${ri}$bdsqr( 'U', m, m, 0, nrhs, s, work( ie ), work( il ),ldwork, a, lda, b,& + call stdlib${ii}$_${ri}$bdsqr( 'U', m, m, 0_${ik}$, nrhs, s, work( ie ), work( il ),ldwork, a, lda, b,& ldb, work( iwork ), info ) if( info/=0 )go to 70 ! multiply b by reciprocals of singular values - thr = max( rcond*s( 1 ), sfmin ) - if( rcondthr ) then - call stdlib_${ri}$rscl( nrhs, s( i ), b( i, 1 ), ldb ) - rank = rank + 1 + call stdlib${ii}$_${ri}$rscl( nrhs, s( i ), b( i, 1_${ik}$ ), ldb ) + rank = rank + 1_${ik}$ else - call stdlib_${ri}$laset( 'F', 1, nrhs, zero, zero, b( i, 1 ), ldb ) + call stdlib${ii}$_${ri}$laset( 'F', 1_${ik}$, nrhs, zero, zero, b( i, 1_${ik}$ ), ldb ) end if end do iwork = ie ! multiply b by right singular vectors of l in work(il) ! (workspace: need m*m+2*m, prefer m*m+m+m*nrhs) - if( lwork>=ldb*nrhs+iwork-1 .and. nrhs>1 ) then - call stdlib_${ri}$gemm( 'T', 'N', m, nrhs, m, one, work( il ), ldwork,b, ldb, zero, & + if( lwork>=ldb*nrhs+iwork-1 .and. nrhs>1_${ik}$ ) then + call stdlib${ii}$_${ri}$gemm( 'T', 'N', m, nrhs, m, one, work( il ), ldwork,b, ldb, zero, & work( iwork ), ldb ) - call stdlib_${ri}$lacpy( 'G', m, nrhs, work( iwork ), ldb, b, ldb ) - else if( nrhs>1 ) then + call stdlib${ii}$_${ri}$lacpy( 'G', m, nrhs, work( iwork ), ldb, b, ldb ) + else if( nrhs>1_${ik}$ ) then chunk = ( lwork-iwork+1 ) / m do i = 1, nrhs, chunk bl = min( nrhs-i+1, chunk ) - call stdlib_${ri}$gemm( 'T', 'N', m, bl, m, one, work( il ), ldwork,b( 1, i ), ldb,& + call stdlib${ii}$_${ri}$gemm( 'T', 'N', m, bl, m, one, work( il ), ldwork,b( 1_${ik}$, i ), ldb,& zero, work( iwork ), m ) - call stdlib_${ri}$lacpy( 'G', m, bl, work( iwork ), m, b( 1, i ),ldb ) + call stdlib${ii}$_${ri}$lacpy( 'G', m, bl, work( iwork ), m, b( 1_${ik}$, i ),ldb ) end do else - call stdlib_${ri}$gemv( 'T', m, m, one, work( il ), ldwork, b( 1, 1 ),1, zero, work( & - iwork ), 1 ) - call stdlib_${ri}$copy( m, work( iwork ), 1, b( 1, 1 ), 1 ) + call stdlib${ii}$_${ri}$gemv( 'T', m, m, one, work( il ), ldwork, b( 1_${ik}$, 1_${ik}$ ),1_${ik}$, zero, work( & + iwork ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$copy( m, work( iwork ), 1_${ik}$, b( 1_${ik}$, 1_${ik}$ ), 1_${ik}$ ) end if ! zero out below first m rows of b - call stdlib_${ri}$laset( 'F', n-m, nrhs, zero, zero, b( m+1, 1 ), ldb ) + call stdlib${ii}$_${ri}$laset( 'F', n-m, nrhs, zero, zero, b( m+1, 1_${ik}$ ), ldb ) iwork = itau + m ! multiply transpose(q) by b ! (workspace: need m+nrhs, prefer m+nrhs*nb) - call stdlib_${ri}$ormlq( 'L', 'T', n, nrhs, m, a, lda, work( itau ), b,ldb, work( iwork )& + call stdlib${ii}$_${ri}$ormlq( 'L', 'T', n, nrhs, m, a, lda, work( itau ), b,ldb, work( iwork )& , lwork-iwork+1, info ) else ! path 2 - remaining underdetermined cases - ie = 1 + ie = 1_${ik}$ itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize a ! (workspace: need 3*m+n, prefer 3*m+(m+n)*nb) - call stdlib_${ri}$gebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work( & + call stdlib${ii}$_${ri}$gebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work( & iwork ), lwork-iwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors ! (workspace: need 3*m+nrhs, prefer 3*m+nrhs*nb) - call stdlib_${ri}$ormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & iwork ), lwork-iwork+1, info ) ! generate right bidiagonalizing vectors in a ! (workspace: need 4*m, prefer 3*m+m*nb) - call stdlib_${ri}$orgbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-iwork+& - 1, info ) + call stdlib${ii}$_${ri}$orgbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-iwork+& + 1_${ik}$, info ) iwork = ie + m ! perform bidiagonal qr iteration, ! computing right singular vectors of a in a and ! multiplying b by transpose of left singular vectors ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'L', m, n, 0, nrhs, s, work( ie ), a, lda, dum,1, b, ldb, work( & + call stdlib${ii}$_${ri}$bdsqr( 'L', m, n, 0_${ik}$, nrhs, s, work( ie ), a, lda, dum,1_${ik}$, b, ldb, work( & iwork ), info ) if( info/=0 )go to 70 ! multiply b by reciprocals of singular values - thr = max( rcond*s( 1 ), sfmin ) - if( rcondthr ) then - call stdlib_${ri}$rscl( nrhs, s( i ), b( i, 1 ), ldb ) - rank = rank + 1 + call stdlib${ii}$_${ri}$rscl( nrhs, s( i ), b( i, 1_${ik}$ ), ldb ) + rank = rank + 1_${ik}$ else - call stdlib_${ri}$laset( 'F', 1, nrhs, zero, zero, b( i, 1 ), ldb ) + call stdlib${ii}$_${ri}$laset( 'F', 1_${ik}$, nrhs, zero, zero, b( i, 1_${ik}$ ), ldb ) end if end do ! multiply b by right singular vectors of a ! (workspace: need n, prefer n*nrhs) - if( lwork>=ldb*nrhs .and. nrhs>1 ) then - call stdlib_${ri}$gemm( 'T', 'N', n, nrhs, m, one, a, lda, b, ldb, zero,work, ldb ) + if( lwork>=ldb*nrhs .and. nrhs>1_${ik}$ ) then + call stdlib${ii}$_${ri}$gemm( 'T', 'N', n, nrhs, m, one, a, lda, b, ldb, zero,work, ldb ) - call stdlib_${ri}$lacpy( 'F', n, nrhs, work, ldb, b, ldb ) - else if( nrhs>1 ) then + call stdlib${ii}$_${ri}$lacpy( 'F', n, nrhs, work, ldb, b, ldb ) + else if( nrhs>1_${ik}$ ) then chunk = lwork / n do i = 1, nrhs, chunk bl = min( nrhs-i+1, chunk ) - call stdlib_${ri}$gemm( 'T', 'N', n, bl, m, one, a, lda, b( 1, i ),ldb, zero, work,& + call stdlib${ii}$_${ri}$gemm( 'T', 'N', n, bl, m, one, a, lda, b( 1_${ik}$, i ),ldb, zero, work,& n ) - call stdlib_${ri}$lacpy( 'F', n, bl, work, n, b( 1, i ), ldb ) + call stdlib${ii}$_${ri}$lacpy( 'F', n, bl, work, n, b( 1_${ik}$, i ), ldb ) end do else - call stdlib_${ri}$gemv( 'T', m, n, one, a, lda, b, 1, zero, work, 1 ) - call stdlib_${ri}$copy( n, work, 1, b, 1 ) + call stdlib${ii}$_${ri}$gemv( 'T', m, n, one, a, lda, b, 1_${ik}$, zero, work, 1_${ik}$ ) + call stdlib${ii}$_${ri}$copy( n, work, 1_${ik}$, b, 1_${ik}$ ) end if end if ! undo scaling - if( iascl==1 ) then - call stdlib_${ri}$lascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info ) - call stdlib_${ri}$lascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn,info ) - else if( iascl==2 ) then - call stdlib_${ri}$lascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info ) - call stdlib_${ri}$lascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,info ) - end if - if( ibscl==1 ) then - call stdlib_${ri}$lascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info ) - else if( ibscl==2 ) then - call stdlib_${ri}$lascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info ) + if( iascl==1_${ik}$ ) then + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, smlnum, n, nrhs, b, ldb, info ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, anrm, minmn, 1_${ik}$, s, minmn,info ) + else if( iascl==2_${ik}$ ) then + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, n, nrhs, b, ldb, info ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn, 1_${ik}$, s, minmn,info ) + end if + if( ibscl==1_${ik}$ ) then + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, bnrm, n, nrhs, b, ldb, info ) + else if( ibscl==2_${ik}$ ) then + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bignum, bnrm, n, nrhs, b, ldb, info ) end if 70 continue - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_${ri}$gelss + end subroutine stdlib${ii}$_${ri}$gelss - subroutine stdlib_${ri}$gelsy( m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank,work, lwork, info ) + subroutine stdlib${ii}$_${ri}$gelsy( m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank,work, lwork, info ) !! DGELSY: computes the minimum-norm solution to a real linear least !! squares problem: !! minimize || A * X - B || @@ -8170,22 +8168,22 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, rank - integer(ilp), intent(in) :: lda, ldb, lwork, m, n, nrhs + integer(${ik}$), intent(out) :: info, rank + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, nrhs real(${rk}$), intent(in) :: rcond ! Array Arguments - integer(ilp), intent(inout) :: jpvt(*) + integer(${ik}$), intent(inout) :: jpvt(*) real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: imax = 1 - integer(ilp), parameter :: imin = 2 + integer(${ik}$), parameter :: imax = 1_${ik}$ + integer(${ik}$), parameter :: imin = 2_${ik}$ ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, iascl, ibscl, ismax, ismin, j, lwkmin, lwkopt, mn, nb, nb1, nb2, & + integer(${ik}$) :: i, iascl, ibscl, ismax, ismin, j, lwkmin, lwkopt, mn, nb, nb1, nb2, & nb3, nb4 real(${rk}$) :: anrm, bignum, bnrm, c1, c2, s1, s2, smax, smaxpr, smin, sminpr, smlnum, & wsize @@ -8193,87 +8191,87 @@ module stdlib_linalg_lapack_${ri}$ intrinsic :: abs,max,min ! Executable Statements mn = min( m, n ) - ismin = mn + 1 - ismax = 2*mn + 1 + ismin = mn + 1_${ik}$ + ismax = 2_${ik}$*mn + 1_${ik}$ ! test the input arguments. - info = 0 - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( ldazero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_${ri}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_${ri}$laset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) - rank = 0 + call stdlib${ii}$_${ri}$laset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) + rank = 0_${ik}$ go to 70 end if - bnrm = stdlib_${ri}$lange( 'M', m, nrhs, b, ldb, work ) - ibscl = 0 + bnrm = stdlib${ii}$_${ri}$lange( 'M', m, nrhs, b, ldb, work ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_${ri}$lascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) - ibscl = 2 + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, m, nrhs, b, ldb, info ) + ibscl = 2_${ik}$ end if ! compute qr factorization with column pivoting of a: ! a * p = q * r - call stdlib_${ri}$geqp3( m, n, a, lda, jpvt, work( 1 ), work( mn+1 ),lwork-mn, info ) + call stdlib${ii}$_${ri}$geqp3( m, n, a, lda, jpvt, work( 1_${ik}$ ), work( mn+1 ),lwork-mn, info ) wsize = mn + work( mn+1 ) ! workspace: mn+2*n+nb*(n+1). @@ -8281,21 +8279,21 @@ module stdlib_linalg_lapack_${ri}$ ! determine rank using incremental condition estimation work( ismin ) = one work( ismax ) = one - smax = abs( a( 1, 1 ) ) + smax = abs( a( 1_${ik}$, 1_${ik}$ ) ) smin = smax - if( abs( a( 1, 1 ) )==zero ) then - rank = 0 - call stdlib_${ri}$laset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) + if( abs( a( 1_${ik}$, 1_${ik}$ ) )==zero ) then + rank = 0_${ik}$ + call stdlib${ii}$_${ri}$laset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) go to 70 else - rank = 1 + rank = 1_${ik}$ end if 10 continue if( rankk ) .and. ( mn>k ) ) then - if( mod( mn - k, nb - k ) == 0 ) then + if( mod( mn - k, nb - k ) == 0_${ik}$ ) then nblcks = ( mn - k ) / ( nb - k ) else - nblcks = ( mn - k ) / ( nb - k ) + 1 + nblcks = ( mn - k ) / ( nb - k ) + 1_${ik}$ end if else - nblcks = 1 + nblcks = 1_${ik}$ end if - info = 0 + info = 0_${ik}$ 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>mn ) then - info = -5 - else if( ldamn ) then + info = -5_${ik}$ + else if( lda=max( m, n, & k ) ) ) then - call stdlib_${ri}$gemlqt( side, trans, m, n, k, mb, a, lda,t( 6 ), mb, c, ldc, work, info & + call stdlib${ii}$_${ri}$gemlqt( side, trans, m, n, k, mb, a, lda,t( 6_${ik}$ ), mb, c, ldc, work, info & ) else - call stdlib_${ri}$lamswlq( side, trans, m, n, k, mb, nb, a, lda, t( 6 ),mb, c, ldc, work, & + call stdlib${ii}$_${ri}$lamswlq( side, trans, m, n, k, mb, nb, a, lda, t( 6_${ik}$ ),mb, c, ldc, work, & lwork, info ) end if - work( 1 ) = lw + work( 1_${ik}$ ) = lw return - end subroutine stdlib_${ri}$gemlq + end subroutine stdlib${ii}$_${ri}$gemlq - pure subroutine stdlib_${ri}$gemlqt( side, trans, m, n, k, mb, v, ldv, t, ldt,c, ldc, work, info ) + pure subroutine stdlib${ii}$_${ri}$gemlqt( side, trans, m, n, k, mb, v, ldv, t, ldt,c, ldc, work, info ) !! DGEMLQT: overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q C C Q @@ -8478,8 +8476,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: v(ldv,*), t(ldt,*) real(${rk}$), intent(inout) :: c(ldc,*) @@ -8487,44 +8485,44 @@ module stdlib_linalg_lapack_${ri}$ ! ===================================================================== ! 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( ldvk ) .and. ( mn>k ) ) then - if( mod( mn - k, mb - k )==0 ) then + if( mod( mn - k, mb - k )==0_${ik}$ ) then nblcks = ( mn - k ) / ( mb - k ) else - nblcks = ( mn - k ) / ( mb - k ) + 1 + nblcks = ( mn - k ) / ( mb - k ) + 1_${ik}$ end if else - nblcks = 1 + nblcks = 1_${ik}$ end if - info = 0 + info = 0_${ik}$ 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>mn ) then - info = -5 - else if( ldamn ) then + info = -5_${ik}$ + else if( lda=max( m, n, & k ) ) ) then - call stdlib_${ri}$gemqrt( side, trans, m, n, k, nb, a, lda, t( 6 ),nb, c, ldc, work, info & + call stdlib${ii}$_${ri}$gemqrt( side, trans, m, n, k, nb, a, lda, t( 6_${ik}$ ),nb, c, ldc, work, info & ) else - call stdlib_${ri}$lamtsqr( side, trans, m, n, k, mb, nb, a, lda, t( 6 ),nb, c, ldc, work, & + call stdlib${ii}$_${ri}$lamtsqr( side, trans, m, n, k, mb, nb, a, lda, t( 6_${ik}$ ),nb, c, ldc, work, & lwork, info ) end if - work( 1 ) = lw + work( 1_${ik}$ ) = lw return - end subroutine stdlib_${ri}$gemqr + end subroutine stdlib${ii}$_${ri}$gemqr - pure subroutine stdlib_${ri}$gemqrt( side, trans, m, n, k, nb, v, ldv, t, ldt,c, ldc, work, info ) + pure subroutine stdlib${ii}$_${ri}$gemqrt( side, trans, m, n, k, nb, v, ldv, t, ldt,c, ldc, work, info ) !! DGEMQRT: overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q C C Q @@ -8673,8 +8671,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, nb, ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k, ldv, ldc, m, n, nb, ldt ! Array Arguments real(${rk}$), intent(in) :: v(ldv,*), t(ldt,*) real(${rk}$), intent(inout) :: c(ldc,*) @@ -8682,44 +8680,44 @@ module stdlib_linalg_lapack_${ri}$ ! ===================================================================== ! 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( 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( ldv1 .and. nb1_${ik}$ .and. nb1 ) 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_${ri}$larft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1, n-k+i ), & + call stdlib${ii}$_${ri}$larft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1_${ik}$, n-k+i ), & lda, tau( i ), work, ldwork ) ! apply h**t to a(1:m-k+i+ib-1,1:n-k+i-1) from the left - call stdlib_${ri}$larfb( 'LEFT', 'TRANSPOSE', 'BACKWARD','COLUMNWISE', m-k+i+ib-1, & - n-k+i-1, ib,a( 1, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork ) + call stdlib${ii}$_${ri}$larfb( 'LEFT', 'TRANSPOSE', 'BACKWARD','COLUMNWISE', m-k+i+ib-1, & + n-k+i-1, ib,a( 1_${ik}$, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork ) end if end do - mu = m - k + i + nb - 1 - nu = n - k + i + nb - 1 + mu = m - k + i + nb - 1_${ik}$ + nu = n - k + i + nb - 1_${ik}$ else mu = m nu = n end if ! use unblocked code to factor the last or only block - if( mu>0 .and. nu>0 )call stdlib_${ri}$geql2( mu, nu, a, lda, tau, work, iinfo ) - work( 1 ) = iws + if( mu>0_${ik}$ .and. nu>0_${ik}$ )call stdlib${ii}$_${ri}$geql2( mu, nu, a, lda, tau, work, iinfo ) + work( 1_${ik}$ ) = iws return - end subroutine stdlib_${ri}$geqlf + end subroutine stdlib${ii}$_${ri}$geqlf - pure subroutine stdlib_${ri}$geqp3( m, n, a, lda, jpvt, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_${ri}$geqp3( m, n, a, lda, jpvt, tau, work, lwork, info ) !! DGEQP3: computes a QR factorization with column pivoting of a !! matrix A: A*P = Q*R using Level 3 BLAS. ! -- lapack computational routine -- ! -- 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, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, lwork, m, n ! Array Arguments - integer(ilp), intent(inout) :: jpvt(*) + integer(${ik}$), intent(inout) :: jpvt(*) real(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: inb = 1 - integer(ilp), parameter :: inbmin = 2 - integer(ilp), parameter :: ixover = 3 + integer(${ik}$), parameter :: inb = 1_${ik}$ + integer(${ik}$), parameter :: inbmin = 2_${ik}$ + integer(${ik}$), parameter :: ixover = 3_${ik}$ ! Local Scalars logical(lk) :: lquery - integer(ilp) :: fjb, iws, j, jb, lwkopt, minmn, minws, na, nb, nbmin, nfxd, nx, sm, & + integer(${ik}$) :: fjb, iws, j, jb, lwkopt, minmn, minws, na, nb, nbmin, nfxd, nx, sm, & sminmn, sn, topbmn ! Intrinsic Functions intrinsic :: int,max,min ! Executable Statements ! test input arguments ! ==================== - info = 0 - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda0 ) then + if( nfxd>0_${ik}$ ) then na = min( m, nfxd ) - ! cc call stdlib_${ri}$geqr2( m, na, a, lda, tau, work, info ) - call stdlib_${ri}$geqrf( m, na, a, lda, tau, work, lwork, info ) - iws = max( iws, int( work( 1 ),KIND=ilp) ) + ! cc call stdlib${ii}$_${ri}$geqr2( m, na, a, lda, tau, work, info ) + call stdlib${ii}$_${ri}$geqrf( m, na, a, lda, tau, work, lwork, info ) + iws = max( iws, int( work( 1_${ik}$ ),KIND=${ik}$) ) if( na1 ) .and. ( nb1_${ik}$ ) .and. ( nb=nbmin ) .and. ( nb0 ) then - mb = stdlib_ilaenv( 1, 'DGEQR ', ' ', m, n, 1, -1 ) - nb = stdlib_ilaenv( 1, 'DGEQR ', ' ', m, n, 2, -1 ) + if( min( m, n )>0_${ik}$ ) then + mb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQR ', ' ', m, n, 1_${ik}$, -1_${ik}$ ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQR ', ' ', m, n, 2_${ik}$, -1_${ik}$ ) else mb = m - nb = 1 + nb = 1_${ik}$ end if if( mb>m .or. mb<=n ) mb = m - if( nb>min( m, n ) .or. nb<1 ) nb = 1 - mintsz = n + 5 + if( nb>min( m, n ) .or. nb<1_${ik}$ ) nb = 1_${ik}$ + mintsz = n + 5_${ik}$ if( mb>n .and. m>n ) then - if( mod( m - n, mb - n )==0 ) then + if( mod( m - n, mb - n )==0_${ik}$ ) then nblcks = ( m - n ) / ( mb - n ) else - nblcks = ( m - n ) / ( mb - n ) + 1 + nblcks = ( m - n ) / ( mb - n ) + 1_${ik}$ end if else - nblcks = 1 + nblcks = 1_${ik}$ end if ! determine if the workspace size satisfies minimal size lminws = .false. - if( ( tsize=n ) .and. ( & + if( ( tsize=n ) .and. ( & tsize>=mintsz ).and. ( .not.lquery ) ) then - if( tsize=m ) ) then - call stdlib_${ri}$geqrt( m, n, nb, a, lda, t( 6 ), nb, work, info ) + call stdlib${ii}$_${ri}$geqrt( m, n, nb, a, lda, t( 6_${ik}$ ), nb, work, info ) else - call stdlib_${ri}$latsqr( m, n, mb, nb, a, lda, t( 6 ), nb, work,lwork, info ) + call stdlib${ii}$_${ri}$latsqr( m, n, mb, nb, a, lda, t( 6_${ik}$ ), nb, work,lwork, info ) end if - work( 1 ) = max( 1, nb*n ) + work( 1_${ik}$ ) = max( 1_${ik}$, nb*n ) return - end subroutine stdlib_${ri}$geqr + end subroutine stdlib${ii}$_${ri}$geqr - pure subroutine stdlib_${ri}$geqr2( m, n, a, lda, tau, work, info ) + pure subroutine stdlib${ii}$_${ri}$geqr2( m, n, a, lda, tau, work, info ) !! DGEQR2: computes a QR factorization of a real m-by-n matrix A: !! A = Q * ( R ), !! ( 0 ) @@ -9187,50 +9185,50 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, k + integer(${ik}$) :: i, k real(${rk}$) :: aii ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda0 .and. lwork0_${ik}$ .and. lwork1 .and. nb1_${ik}$ .and. nb1 .and. nb1_${ik}$ .and. nbmin(m,n) .and. min(m,n)>0 ) )then - info = -3 - else if( ldamin(m,n) .and. min(m,n)>0_${ik}$ ) )then + info = -3_${ik}$ + else if( lda t(i,1) - call stdlib_${ri}$larfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,t( i, 1 ) ) + call stdlib${ii}$_${ri}$larfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,t( i, 1_${ik}$ ) ) if( ieps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_${ri}$getrs( trans, n, 1, af, ldaf, ipiv, work( n+1 ), n,info ) - call stdlib_${ri}$axpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) + call stdlib${ii}$_${ri}$getrs( trans, n, 1_${ik}$, af, ldaf, ipiv, work( n+1 ), n,info ) + call stdlib${ii}$_${ri}$axpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -9858,14 +9856,14 @@ module stdlib_linalg_lapack_${ri}$ work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_${ri}$lacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) + call stdlib${ii}$_${ri}$lacn2( 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_${ri}$getrs( transt, n, 1, af, ldaf, ipiv, work( n+1 ),n, info ) + call stdlib${ii}$_${ri}$getrs( transt, n, 1_${ik}$, af, ldaf, ipiv, work( n+1 ),n, info ) do i = 1, n work( n+i ) = work( i )*work( n+i ) @@ -9875,7 +9873,7 @@ module stdlib_linalg_lapack_${ri}$ do i = 1, n work( n+i ) = work( i )*work( n+i ) end do - call stdlib_${ri}$getrs( trans, n, 1, af, ldaf, ipiv, work( n+1 ), n,info ) + call stdlib${ii}$_${ri}$getrs( trans, n, 1_${ik}$, af, ldaf, ipiv, work( n+1 ), n,info ) end if go to 100 end if @@ -9887,117 +9885,117 @@ module stdlib_linalg_lapack_${ri}$ if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_${ri}$gerfs + end subroutine stdlib${ii}$_${ri}$gerfs - pure subroutine stdlib_${ri}$gerq2( m, n, a, lda, tau, work, info ) + pure subroutine stdlib${ii}$_${ri}$gerq2( m, n, a, lda, tau, work, info ) !! DGERQ2: computes an RQ factorization of a real m by n matrix A: !! A = R * Q. ! -- lapack computational routine -- ! -- 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(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, k + integer(${ik}$) :: i, k real(${rk}$) :: aii ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda0 .and. lwork0_${ik}$ .and. lwork1 .and. nb1_${ik}$ .and. nb1 ) then + if( m-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_${ri}$larft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( m-k+i, 1 ), lda, & + call stdlib${ii}$_${ri}$larft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( m-k+i, 1_${ik}$ ), lda, & tau( i ), work, ldwork ) ! apply h to a(1:m-k+i-1,1:n-k+i+ib-1) from the right - call stdlib_${ri}$larfb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', m-k+i-1, n-& - k+i+ib-1, ib,a( m-k+i, 1 ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork ) + call stdlib${ii}$_${ri}$larfb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', m-k+i-1, n-& + k+i+ib-1, ib,a( m-k+i, 1_${ik}$ ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork ) end if end do - mu = m - k + i + nb - 1 - nu = n - k + i + nb - 1 + mu = m - k + i + nb - 1_${ik}$ + nu = n - k + i + nb - 1_${ik}$ else mu = m nu = n end if ! use unblocked code to factor the last or only block - if( mu>0 .and. nu>0 )call stdlib_${ri}$gerq2( mu, nu, a, lda, tau, work, iinfo ) - work( 1 ) = iws + if( mu>0_${ik}$ .and. nu>0_${ik}$ )call stdlib${ii}$_${ri}$gerq2( mu, nu, a, lda, tau, work, iinfo ) + work( 1_${ik}$ ) = iws return - end subroutine stdlib_${ri}$gerqf + end subroutine stdlib${ii}$_${ri}$gerqf - pure subroutine stdlib_${ri}$gesc2( n, a, lda, rhs, ipiv, jpiv, scale ) + pure subroutine stdlib${ii}$_${ri}$gesc2( n, a, lda, rhs, ipiv, jpiv, scale ) !! DGESC2: solves a system of linear equations !! A * X = scale* RHS !! with a general N-by-N matrix A using the LU factorization with @@ -10054,27 +10052,27 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, n + integer(${ik}$), intent(in) :: lda, n real(${rk}$), intent(out) :: scale ! Array Arguments - integer(ilp), intent(in) :: ipiv(*), jpiv(*) + integer(${ik}$), intent(in) :: ipiv(*), jpiv(*) real(${rk}$), intent(in) :: a(lda,*) real(${rk}$), intent(inout) :: rhs(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(${rk}$) :: bignum, eps, smlnum, temp ! Intrinsic Functions intrinsic :: abs ! Executable Statements ! set constant to control overflow - eps = stdlib_${ri}$lamch( 'P' ) - smlnum = stdlib_${ri}$lamch( 'S' ) / eps + eps = stdlib${ii}$_${ri}$lamch( 'P' ) + smlnum = stdlib${ii}$_${ri}$lamch( 'S' ) / eps bignum = one / smlnum - call stdlib_${ri}$labad( smlnum, bignum ) + call stdlib${ii}$_${ri}$labad( smlnum, bignum ) ! apply permutations ipiv to rhs - call stdlib_${ri}$laswp( 1, rhs, lda, 1, n-1, ipiv, 1 ) + call stdlib${ii}$_${ri}$laswp( 1_${ik}$, rhs, lda, 1_${ik}$, n-1, ipiv, 1_${ik}$ ) ! solve for l part do i = 1, n - 1 do j = i + 1, n @@ -10084,10 +10082,10 @@ module stdlib_linalg_lapack_${ri}$ ! solve for u part scale = one ! check for scaling - i = stdlib_i${ri}$amax( n, rhs, 1 ) + i = stdlib${ii}$_i${ri}$amax( n, rhs, 1_${ik}$ ) if( two*smlnum*abs( rhs( i ) )>abs( a( n, n ) ) ) then temp = ( one / two ) / abs( rhs( i ) ) - call stdlib_${ri}$scal( n, temp, rhs( 1 ), 1 ) + call stdlib${ii}$_${ri}$scal( n, temp, rhs( 1_${ik}$ ), 1_${ik}$ ) scale = scale*temp end if do i = n, 1, -1 @@ -10098,12 +10096,12 @@ module stdlib_linalg_lapack_${ri}$ end do end do ! apply permutations jpiv to the solution (rhs) - call stdlib_${ri}$laswp( 1, rhs, lda, 1, n-1, jpiv, -1 ) + call stdlib${ii}$_${ri}$laswp( 1_${ik}$, rhs, lda, 1_${ik}$, n-1, jpiv, -1_${ik}$ ) return - end subroutine stdlib_${ri}$gesc2 + end subroutine stdlib${ii}$_${ri}$gesc2 - subroutine stdlib_${ri}$gesdd( jobz, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, iwork, info ) + subroutine stdlib${ii}$_${ri}$gesdd( jobz, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, iwork, info ) !! DGESDD: computes the singular value decomposition (SVD) of a real !! M-by-N matrix A, optionally computing the left and right singular !! vectors. If singular vectors are desired, it uses a @@ -10129,303 +10127,303 @@ module stdlib_linalg_lapack_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldu, ldvt, lwork, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldu, ldvt, lwork, m, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: s(*), u(ldu,*), vt(ldvt,*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, wntqa, wntqas, wntqn, wntqo, wntqs - integer(ilp) :: bdspac, blk, chunk, i, ie, ierr, il, ir, iscl, itau, itaup, itauq, iu, & + integer(${ik}$) :: bdspac, blk, chunk, i, ie, ierr, il, ir, iscl, itau, itaup, itauq, iu, & ivt, ldwkvt, ldwrkl, ldwrkr, ldwrku, maxwrk, minmn, minwrk, mnthr, nwork, wrkbl - integer(ilp) :: lwork_qgebrd_mn, lwork_qgebrd_mm, lwork_qgebrd_nn, lwork_qgelqf_mn, & + integer(${ik}$) :: lwork_qgebrd_mn, lwork_qgebrd_mm, lwork_qgebrd_nn, lwork_qgelqf_mn, & lwork_qgeqrf_mn, lwork_qorgbr_p_mm, lwork_qorgbr_q_nn, lwork_qorglq_mn, & lwork_qorglq_nn, lwork_qorgqr_mm, lwork_qorgqr_mn, lwork_qormbr_prt_mm, & lwork_qormbr_qln_mm, lwork_qormbr_prt_mn, lwork_qormbr_qln_mn, lwork_qormbr_prt_nn, & lwork_qormbr_qln_nn real(${rk}$) :: anrm, bignum, eps, smlnum ! Local Arrays - integer(ilp) :: idum(1) - real(${rk}$) :: dum(1) + integer(${ik}$) :: idum(1_${ik}$) + real(${rk}$) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: int,max,min,sqrt ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ minmn = min( m, n ) wntqa = stdlib_lsame( jobz, 'A' ) wntqs = stdlib_lsame( jobz, 'S' ) wntqas = wntqa .or. wntqs wntqo = stdlib_lsame( jobz, 'O' ) wntqn = stdlib_lsame( jobz, 'N' ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) if( .not.( wntqa .or. wntqs .or. wntqo .or. wntqn ) ) then - info = -1 - else if( m<0 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( lda=n .and. ldvt=n .and. minmn>0 ) then - ! compute space needed for stdlib_${ri}$bdsdc + ! following subroutine, as returned by stdlib${ii}$_ilaenv. + if( info==0_${ik}$ ) then + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + bdspac = 0_${ik}$ + mnthr = int( minmn*11.0_${rk}$ / 6.0_${rk}$,KIND=${ik}$) + if( m>=n .and. minmn>0_${ik}$ ) then + ! compute space needed for stdlib${ii}$_${ri}$bdsdc if( wntqn ) then - ! stdlib_${ri}$bdsdc needs only 4*n (or 6*n for uplo=l for lapack <= 3.6_${rk}$) + ! stdlib${ii}$_${ri}$bdsdc needs only 4*n (or 6*n for uplo=l for lapack <= 3.6_${rk}$) ! keep 7*n for backwards compatibility. - bdspac = 7*n + bdspac = 7_${ik}$*n else - bdspac = 3*n*n + 4*n + bdspac = 3_${ik}$*n*n + 4_${ik}$*n end if ! compute space preferred for each routine - call stdlib_${ri}$gebrd( m, n, dum(1), m, dum(1), dum(1), dum(1),dum(1), dum(1), -1, & + call stdlib${ii}$_${ri}$gebrd( m, n, dum(1_${ik}$), m, dum(1_${ik}$), dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, & ierr ) - lwork_qgebrd_mn = int( dum(1),KIND=ilp) - call stdlib_${ri}$gebrd( n, n, dum(1), n, dum(1), dum(1), dum(1),dum(1), dum(1), -1, & + lwork_qgebrd_mn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ri}$gebrd( n, n, dum(1_${ik}$), n, dum(1_${ik}$), dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, & ierr ) - lwork_qgebrd_nn = int( dum(1),KIND=ilp) - call stdlib_${ri}$geqrf( m, n, dum(1), m, dum(1), dum(1), -1, ierr ) - lwork_qgeqrf_mn = int( dum(1),KIND=ilp) - call stdlib_${ri}$orgbr( 'Q', n, n, n, dum(1), n, dum(1), dum(1), -1,ierr ) - lwork_qorgbr_q_nn = int( dum(1),KIND=ilp) - call stdlib_${ri}$orgqr( m, m, n, dum(1), m, dum(1), dum(1), -1, ierr ) - lwork_qorgqr_mm = int( dum(1),KIND=ilp) - call stdlib_${ri}$orgqr( m, n, n, dum(1), m, dum(1), dum(1), -1, ierr ) - lwork_qorgqr_mn = int( dum(1),KIND=ilp) - call stdlib_${ri}$ormbr( 'P', 'R', 'T', n, n, n, dum(1), n,dum(1), dum(1), n, dum(1), & - -1, ierr ) - lwork_qormbr_prt_nn = int( dum(1),KIND=ilp) - call stdlib_${ri}$ormbr( 'Q', 'L', 'N', n, n, n, dum(1), n,dum(1), dum(1), n, dum(1), & - -1, ierr ) - lwork_qormbr_qln_nn = int( dum(1),KIND=ilp) - call stdlib_${ri}$ormbr( 'Q', 'L', 'N', m, n, n, dum(1), m,dum(1), dum(1), m, dum(1), & - -1, ierr ) - lwork_qormbr_qln_mn = int( dum(1),KIND=ilp) - call stdlib_${ri}$ormbr( 'Q', 'L', 'N', m, m, n, dum(1), m,dum(1), dum(1), m, dum(1), & - -1, ierr ) - lwork_qormbr_qln_mm = int( dum(1),KIND=ilp) + lwork_qgebrd_nn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ri}$geqrf( m, n, dum(1_${ik}$), m, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_qgeqrf_mn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ri}$orgbr( 'Q', n, n, n, dum(1_${ik}$), n, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$,ierr ) + lwork_qorgbr_q_nn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ri}$orgqr( m, m, n, dum(1_${ik}$), m, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_qorgqr_mm = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ri}$orgqr( m, n, n, dum(1_${ik}$), m, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_qorgqr_mn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ri}$ormbr( 'P', 'R', 'T', n, n, n, dum(1_${ik}$), n,dum(1_${ik}$), dum(1_${ik}$), n, dum(1_${ik}$), & + -1_${ik}$, ierr ) + lwork_qormbr_prt_nn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'N', n, n, n, dum(1_${ik}$), n,dum(1_${ik}$), dum(1_${ik}$), n, dum(1_${ik}$), & + -1_${ik}$, ierr ) + lwork_qormbr_qln_nn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'N', m, n, n, dum(1_${ik}$), m,dum(1_${ik}$), dum(1_${ik}$), m, dum(1_${ik}$), & + -1_${ik}$, ierr ) + lwork_qormbr_qln_mn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'N', m, m, n, dum(1_${ik}$), m,dum(1_${ik}$), dum(1_${ik}$), m, dum(1_${ik}$), & + -1_${ik}$, ierr ) + lwork_qormbr_qln_mm = int( dum(1_${ik}$),KIND=${ik}$) if( m>=mnthr ) then if( wntqn ) then ! path 1 (m >> n, jobz='n') wrkbl = n + lwork_qgeqrf_mn - wrkbl = max( wrkbl, 3*n + lwork_qgebrd_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qgebrd_nn ) maxwrk = max( wrkbl, bdspac + n ) minwrk = bdspac + n else if( wntqo ) then ! path 2 (m >> n, jobz='o') wrkbl = n + lwork_qgeqrf_mn wrkbl = max( wrkbl, n + lwork_qorgqr_mn ) - wrkbl = max( wrkbl, 3*n + lwork_qgebrd_nn ) - wrkbl = max( wrkbl, 3*n + lwork_qormbr_qln_nn ) - wrkbl = max( wrkbl, 3*n + lwork_qormbr_prt_nn ) - wrkbl = max( wrkbl, 3*n + bdspac ) - maxwrk = wrkbl + 2*n*n - minwrk = bdspac + 2*n*n + 3*n + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qgebrd_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qormbr_qln_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qormbr_prt_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + bdspac ) + maxwrk = wrkbl + 2_${ik}$*n*n + minwrk = bdspac + 2_${ik}$*n*n + 3_${ik}$*n else if( wntqs ) then ! path 3 (m >> n, jobz='s') wrkbl = n + lwork_qgeqrf_mn wrkbl = max( wrkbl, n + lwork_qorgqr_mn ) - wrkbl = max( wrkbl, 3*n + lwork_qgebrd_nn ) - wrkbl = max( wrkbl, 3*n + lwork_qormbr_qln_nn ) - wrkbl = max( wrkbl, 3*n + lwork_qormbr_prt_nn ) - wrkbl = max( wrkbl, 3*n + bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qgebrd_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qormbr_qln_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qormbr_prt_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + bdspac ) maxwrk = wrkbl + n*n - minwrk = bdspac + n*n + 3*n + minwrk = bdspac + n*n + 3_${ik}$*n else if( wntqa ) then ! path 4 (m >> n, jobz='a') wrkbl = n + lwork_qgeqrf_mn wrkbl = max( wrkbl, n + lwork_qorgqr_mm ) - wrkbl = max( wrkbl, 3*n + lwork_qgebrd_nn ) - wrkbl = max( wrkbl, 3*n + lwork_qormbr_qln_nn ) - wrkbl = max( wrkbl, 3*n + lwork_qormbr_prt_nn ) - wrkbl = max( wrkbl, 3*n + bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qgebrd_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qormbr_qln_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qormbr_prt_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + bdspac ) maxwrk = wrkbl + n*n - minwrk = n*n + max( 3*n + bdspac, n + m ) + minwrk = n*n + max( 3_${ik}$*n + bdspac, n + m ) end if else ! path 5 (m >= n, but not much larger) - wrkbl = 3*n + lwork_qgebrd_mn + wrkbl = 3_${ik}$*n + lwork_qgebrd_mn if( wntqn ) then ! path 5n (m >= n, jobz='n') - maxwrk = max( wrkbl, 3*n + bdspac ) - minwrk = 3*n + max( m, bdspac ) + maxwrk = max( wrkbl, 3_${ik}$*n + bdspac ) + minwrk = 3_${ik}$*n + max( m, bdspac ) else if( wntqo ) then ! path 5o (m >= n, jobz='o') - wrkbl = max( wrkbl, 3*n + lwork_qormbr_prt_nn ) - wrkbl = max( wrkbl, 3*n + lwork_qormbr_qln_mn ) - wrkbl = max( wrkbl, 3*n + bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qormbr_prt_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qormbr_qln_mn ) + wrkbl = max( wrkbl, 3_${ik}$*n + bdspac ) maxwrk = wrkbl + m*n - minwrk = 3*n + max( m, n*n + bdspac ) + minwrk = 3_${ik}$*n + max( m, n*n + bdspac ) else if( wntqs ) then ! path 5s (m >= n, jobz='s') - wrkbl = max( wrkbl, 3*n + lwork_qormbr_qln_mn ) - wrkbl = max( wrkbl, 3*n + lwork_qormbr_prt_nn ) - maxwrk = max( wrkbl, 3*n + bdspac ) - minwrk = 3*n + max( m, bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qormbr_qln_mn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qormbr_prt_nn ) + maxwrk = max( wrkbl, 3_${ik}$*n + bdspac ) + minwrk = 3_${ik}$*n + max( m, bdspac ) else if( wntqa ) then ! path 5a (m >= n, jobz='a') - wrkbl = max( wrkbl, 3*n + lwork_qormbr_qln_mm ) - wrkbl = max( wrkbl, 3*n + lwork_qormbr_prt_nn ) - maxwrk = max( wrkbl, 3*n + bdspac ) - minwrk = 3*n + max( m, bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qormbr_qln_mm ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qormbr_prt_nn ) + maxwrk = max( wrkbl, 3_${ik}$*n + bdspac ) + minwrk = 3_${ik}$*n + max( m, bdspac ) end if end if - else if( minmn>0 ) then - ! compute space needed for stdlib_${ri}$bdsdc + else if( minmn>0_${ik}$ ) then + ! compute space needed for stdlib${ii}$_${ri}$bdsdc if( wntqn ) then - ! stdlib_${ri}$bdsdc needs only 4*n (or 6*n for uplo=l for lapack <= 3.6_${rk}$) + ! stdlib${ii}$_${ri}$bdsdc needs only 4*n (or 6*n for uplo=l for lapack <= 3.6_${rk}$) ! keep 7*n for backwards compatibility. - bdspac = 7*m + bdspac = 7_${ik}$*m else - bdspac = 3*m*m + 4*m + bdspac = 3_${ik}$*m*m + 4_${ik}$*m end if ! compute space preferred for each routine - call stdlib_${ri}$gebrd( m, n, dum(1), m, dum(1), dum(1), dum(1),dum(1), dum(1), -1, & + call stdlib${ii}$_${ri}$gebrd( m, n, dum(1_${ik}$), m, dum(1_${ik}$), dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, & ierr ) - lwork_qgebrd_mn = int( dum(1),KIND=ilp) - call stdlib_${ri}$gebrd( m, m, a, m, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) + lwork_qgebrd_mn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ri}$gebrd( m, m, a, m, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) - lwork_qgebrd_mm = int( dum(1),KIND=ilp) - call stdlib_${ri}$gelqf( m, n, a, m, dum(1), dum(1), -1, ierr ) - lwork_qgelqf_mn = int( dum(1),KIND=ilp) - call stdlib_${ri}$orglq( n, n, m, dum(1), n, dum(1), dum(1), -1, ierr ) - lwork_qorglq_nn = int( dum(1),KIND=ilp) - call stdlib_${ri}$orglq( m, n, m, a, m, dum(1), dum(1), -1, ierr ) - lwork_qorglq_mn = int( dum(1),KIND=ilp) - call stdlib_${ri}$orgbr( 'P', m, m, m, a, n, dum(1), dum(1), -1, ierr ) - lwork_qorgbr_p_mm = int( dum(1),KIND=ilp) - call stdlib_${ri}$ormbr( 'P', 'R', 'T', m, m, m, dum(1), m,dum(1), dum(1), m, dum(1), & - -1, ierr ) - lwork_qormbr_prt_mm = int( dum(1),KIND=ilp) - call stdlib_${ri}$ormbr( 'P', 'R', 'T', m, n, m, dum(1), m,dum(1), dum(1), m, dum(1), & - -1, ierr ) - lwork_qormbr_prt_mn = int( dum(1),KIND=ilp) - call stdlib_${ri}$ormbr( 'P', 'R', 'T', n, n, m, dum(1), n,dum(1), dum(1), n, dum(1), & - -1, ierr ) - lwork_qormbr_prt_nn = int( dum(1),KIND=ilp) - call stdlib_${ri}$ormbr( 'Q', 'L', 'N', m, m, m, dum(1), m,dum(1), dum(1), m, dum(1), & - -1, ierr ) - lwork_qormbr_qln_mm = int( dum(1),KIND=ilp) + lwork_qgebrd_mm = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ri}$gelqf( m, n, a, m, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_qgelqf_mn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ri}$orglq( n, n, m, dum(1_${ik}$), n, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_qorglq_nn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ri}$orglq( m, n, m, a, m, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_qorglq_mn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ri}$orgbr( 'P', m, m, m, a, n, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_qorgbr_p_mm = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ri}$ormbr( 'P', 'R', 'T', m, m, m, dum(1_${ik}$), m,dum(1_${ik}$), dum(1_${ik}$), m, dum(1_${ik}$), & + -1_${ik}$, ierr ) + lwork_qormbr_prt_mm = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ri}$ormbr( 'P', 'R', 'T', m, n, m, dum(1_${ik}$), m,dum(1_${ik}$), dum(1_${ik}$), m, dum(1_${ik}$), & + -1_${ik}$, ierr ) + lwork_qormbr_prt_mn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ri}$ormbr( 'P', 'R', 'T', n, n, m, dum(1_${ik}$), n,dum(1_${ik}$), dum(1_${ik}$), n, dum(1_${ik}$), & + -1_${ik}$, ierr ) + lwork_qormbr_prt_nn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'N', m, m, m, dum(1_${ik}$), m,dum(1_${ik}$), dum(1_${ik}$), m, dum(1_${ik}$), & + -1_${ik}$, ierr ) + lwork_qormbr_qln_mm = int( dum(1_${ik}$),KIND=${ik}$) if( n>=mnthr ) then if( wntqn ) then ! path 1t (n >> m, jobz='n') wrkbl = m + lwork_qgelqf_mn - wrkbl = max( wrkbl, 3*m + lwork_qgebrd_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qgebrd_mm ) maxwrk = max( wrkbl, bdspac + m ) minwrk = bdspac + m else if( wntqo ) then ! path 2t (n >> m, jobz='o') wrkbl = m + lwork_qgelqf_mn wrkbl = max( wrkbl, m + lwork_qorglq_mn ) - wrkbl = max( wrkbl, 3*m + lwork_qgebrd_mm ) - wrkbl = max( wrkbl, 3*m + lwork_qormbr_qln_mm ) - wrkbl = max( wrkbl, 3*m + lwork_qormbr_prt_mm ) - wrkbl = max( wrkbl, 3*m + bdspac ) - maxwrk = wrkbl + 2*m*m - minwrk = bdspac + 2*m*m + 3*m + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qgebrd_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qormbr_qln_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qormbr_prt_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + bdspac ) + maxwrk = wrkbl + 2_${ik}$*m*m + minwrk = bdspac + 2_${ik}$*m*m + 3_${ik}$*m else if( wntqs ) then ! path 3t (n >> m, jobz='s') wrkbl = m + lwork_qgelqf_mn wrkbl = max( wrkbl, m + lwork_qorglq_mn ) - wrkbl = max( wrkbl, 3*m + lwork_qgebrd_mm ) - wrkbl = max( wrkbl, 3*m + lwork_qormbr_qln_mm ) - wrkbl = max( wrkbl, 3*m + lwork_qormbr_prt_mm ) - wrkbl = max( wrkbl, 3*m + bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qgebrd_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qormbr_qln_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qormbr_prt_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + bdspac ) maxwrk = wrkbl + m*m - minwrk = bdspac + m*m + 3*m + minwrk = bdspac + m*m + 3_${ik}$*m else if( wntqa ) then ! path 4t (n >> m, jobz='a') wrkbl = m + lwork_qgelqf_mn wrkbl = max( wrkbl, m + lwork_qorglq_nn ) - wrkbl = max( wrkbl, 3*m + lwork_qgebrd_mm ) - wrkbl = max( wrkbl, 3*m + lwork_qormbr_qln_mm ) - wrkbl = max( wrkbl, 3*m + lwork_qormbr_prt_mm ) - wrkbl = max( wrkbl, 3*m + bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qgebrd_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qormbr_qln_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qormbr_prt_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + bdspac ) maxwrk = wrkbl + m*m - minwrk = m*m + max( 3*m + bdspac, m + n ) + minwrk = m*m + max( 3_${ik}$*m + bdspac, m + n ) end if else ! path 5t (n > m, but not much larger) - wrkbl = 3*m + lwork_qgebrd_mn + wrkbl = 3_${ik}$*m + lwork_qgebrd_mn if( wntqn ) then ! path 5tn (n > m, jobz='n') - maxwrk = max( wrkbl, 3*m + bdspac ) - minwrk = 3*m + max( n, bdspac ) + maxwrk = max( wrkbl, 3_${ik}$*m + bdspac ) + minwrk = 3_${ik}$*m + max( n, bdspac ) else if( wntqo ) then ! path 5to (n > m, jobz='o') - wrkbl = max( wrkbl, 3*m + lwork_qormbr_qln_mm ) - wrkbl = max( wrkbl, 3*m + lwork_qormbr_prt_mn ) - wrkbl = max( wrkbl, 3*m + bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qormbr_qln_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qormbr_prt_mn ) + wrkbl = max( wrkbl, 3_${ik}$*m + bdspac ) maxwrk = wrkbl + m*n - minwrk = 3*m + max( n, m*m + bdspac ) + minwrk = 3_${ik}$*m + max( n, m*m + bdspac ) else if( wntqs ) then ! path 5ts (n > m, jobz='s') - wrkbl = max( wrkbl, 3*m + lwork_qormbr_qln_mm ) - wrkbl = max( wrkbl, 3*m + lwork_qormbr_prt_mn ) - maxwrk = max( wrkbl, 3*m + bdspac ) - minwrk = 3*m + max( n, bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qormbr_qln_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qormbr_prt_mn ) + maxwrk = max( wrkbl, 3_${ik}$*m + bdspac ) + minwrk = 3_${ik}$*m + max( n, bdspac ) else if( wntqa ) then ! path 5ta (n > m, jobz='a') - wrkbl = max( wrkbl, 3*m + lwork_qormbr_qln_mm ) - wrkbl = max( wrkbl, 3*m + lwork_qormbr_prt_nn ) - maxwrk = max( wrkbl, 3*m + bdspac ) - minwrk = 3*m + max( n, bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qormbr_qln_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qormbr_prt_nn ) + maxwrk = max( wrkbl, 3_${ik}$*m + bdspac ) + minwrk = 3_${ik}$*m + max( n, bdspac ) end if end if end if maxwrk = max( maxwrk, minwrk ) - work( 1 ) = stdlib_${ri}$roundup_lwork( maxwrk ) + work( 1_${ik}$ ) = stdlib${ii}$_${ri}$roundup_lwork( maxwrk ) if( lworkzero .and. anrmbignum ) then - iscl = 1 - call stdlib_${ri}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, ierr ) + iscl = 1_${ik}$ + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, ierr ) end if if( m>=n ) then ! a has at least as many rows as columns. if a has sufficiently @@ -10435,55 +10433,55 @@ module stdlib_linalg_lapack_${ri}$ if( wntqn ) then ! path 1 (m >> n, jobz='n') ! no singular vectors to be computed - itau = 1 + itau = 1_${ik}$ nwork = itau + n ! compute a=q*r ! workspace: need n [tau] + n [work] ! workspace: prefer n [tau] + n*nb [work] - call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & - 1, ierr ) + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + 1_${ik}$, ierr ) ! zero out below r - if (n>1) call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) - ie = 1 + if (n>1_${ik}$) call stdlib${ii}$_${ri}$laset( 'L', n-1, n-1, zero, zero, a( 2_${ik}$, 1_${ik}$ ), lda ) + ie = 1_${ik}$ itauq = ie + n itaup = itauq + n nwork = itaup + n ! bidiagonalize r in a ! workspace: need 3*n [e, tauq, taup] + n [work] ! workspace: prefer 3*n [e, tauq, taup] + 2*n*nb [work] - call stdlib_${ri}$gebrd( n, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_${ri}$gebrd( n, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) nwork = ie + n ! perform bidiagonal svd, computing singular values only ! workspace: need n [e] + bdspac - call stdlib_${ri}$bdsdc( 'U', 'N', n, s, work( ie ), dum, 1, dum, 1,dum, idum, & + call stdlib${ii}$_${ri}$bdsdc( 'U', 'N', n, s, work( ie ), dum, 1_${ik}$, dum, 1_${ik}$,dum, idum, & work( nwork ), iwork, info ) else if( wntqo ) then ! path 2 (m >> n, jobz = 'o') ! n left singular vectors to be overwritten on a and ! n right singular vectors to be computed in vt - ir = 1 + ir = 1_${ik}$ ! work(ir) is ldwrkr by n - if( lwork >= lda*n + n*n + 3*n + bdspac ) then + if( lwork >= lda*n + n*n + 3_${ik}$*n + bdspac ) then ldwrkr = lda else - ldwrkr = ( lwork - n*n - 3*n - bdspac ) / n + ldwrkr = ( lwork - n*n - 3_${ik}$*n - bdspac ) / n end if itau = ir + ldwrkr*n nwork = itau + n ! compute a=q*r ! workspace: need n*n [r] + n [tau] + n [work] ! workspace: prefer n*n [r] + n [tau] + n*nb [work] - call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & - 1, ierr ) + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + 1_${ik}$, ierr ) ! copy r to work(ir), zeroing out below it - call stdlib_${ri}$lacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) - call stdlib_${ri}$laset( 'L', n - 1, n - 1, zero, zero, work(ir+1),ldwrkr ) + call stdlib${ii}$_${ri}$lacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) + call stdlib${ii}$_${ri}$laset( 'L', n - 1_${ik}$, n - 1_${ik}$, zero, zero, work(ir+1),ldwrkr ) ! generate q in a ! workspace: need n*n [r] + n [tau] + n [work] ! workspace: prefer n*n [r] + n [tau] + n*nb [work] - call stdlib_${ri}$orgqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork - & - nwork + 1, ierr ) + call stdlib${ii}$_${ri}$orgqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork - & + nwork + 1_${ik}$, ierr ) ie = itau itauq = ie + n itaup = itauq + n @@ -10491,8 +10489,8 @@ module stdlib_linalg_lapack_${ri}$ ! bidiagonalize r in work(ir) ! workspace: need n*n [r] + 3*n [e, tauq, taup] + n [work] ! workspace: prefer n*n [r] + 3*n [e, tauq, taup] + 2*n*nb [work] - call stdlib_${ri}$gebrd( n, n, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & - work( itaup ), work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_${ri}$gebrd( n, n, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & + work( itaup ), work( nwork ),lwork - nwork + 1_${ik}$, ierr ) ! work(iu) is n by n iu = nwork nwork = iu + n*n @@ -10500,32 +10498,32 @@ module stdlib_linalg_lapack_${ri}$ ! of bidiagonal matrix in work(iu) and computing right ! singular vectors of bidiagonal matrix in vt ! workspace: need n*n [r] + 3*n [e, tauq, taup] + n*n [u] + bdspac - call stdlib_${ri}$bdsdc( 'U', 'I', n, s, work( ie ), work( iu ), n,vt, ldvt, dum, & + call stdlib${ii}$_${ri}$bdsdc( 'U', 'I', n, s, work( ie ), work( iu ), n,vt, ldvt, dum, & idum, work( nwork ), iwork,info ) ! overwrite work(iu) by left singular vectors of r ! and vt by right singular vectors of r ! workspace: need n*n [r] + 3*n [e, tauq, taup] + n*n [u] + n [work] ! workspace: prefer n*n [r] + 3*n [e, tauq, taup] + n*n [u] + n*nb [work] - call stdlib_${ri}$ormbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & - work( iu ), n, work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_${ri}$ormbr( 'P', 'R', 'T', n, n, n, work( ir ), ldwrkr,work( itaup ), & - vt, ldvt, work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & + work( iu ), n, work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_${ri}$ormbr( 'P', 'R', 'T', n, n, n, work( ir ), ldwrkr,work( itaup ), & + vt, ldvt, work( nwork ),lwork - nwork + 1_${ik}$, ierr ) ! multiply q in a by left singular vectors of r in ! work(iu), storing result in work(ir) and copying to a ! workspace: need n*n [r] + 3*n [e, tauq, taup] + n*n [u] ! workspace: prefer m*n [r] + 3*n [e, tauq, taup] + n*n [u] do i = 1, m, ldwrkr - chunk = min( m - i + 1, ldwrkr ) - call stdlib_${ri}$gemm( 'N', 'N', chunk, n, n, one, a( i, 1 ),lda, work( iu ), & + chunk = min( m - i + 1_${ik}$, ldwrkr ) + call stdlib${ii}$_${ri}$gemm( 'N', 'N', chunk, n, n, one, a( i, 1_${ik}$ ),lda, work( iu ), & n, zero, work( ir ),ldwrkr ) - call stdlib_${ri}$lacpy( 'F', chunk, n, work( ir ), ldwrkr,a( i, 1 ), lda ) + call stdlib${ii}$_${ri}$lacpy( 'F', chunk, n, work( ir ), ldwrkr,a( i, 1_${ik}$ ), lda ) end do else if( wntqs ) then ! path 3 (m >> n, jobz='s') ! n left singular vectors to be computed in u and ! n right singular vectors to be computed in vt - ir = 1 + ir = 1_${ik}$ ! work(ir) is n by n ldwrkr = n itau = ir + ldwrkr*n @@ -10533,16 +10531,16 @@ module stdlib_linalg_lapack_${ri}$ ! compute a=q*r ! workspace: need n*n [r] + n [tau] + n [work] ! workspace: prefer n*n [r] + n [tau] + n*nb [work] - call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & - 1, ierr ) + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + 1_${ik}$, ierr ) ! copy r to work(ir), zeroing out below it - call stdlib_${ri}$lacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) - call stdlib_${ri}$laset( 'L', n - 1, n - 1, zero, zero, work(ir+1),ldwrkr ) + call stdlib${ii}$_${ri}$lacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) + call stdlib${ii}$_${ri}$laset( 'L', n - 1_${ik}$, n - 1_${ik}$, zero, zero, work(ir+1),ldwrkr ) ! generate q in a ! workspace: need n*n [r] + n [tau] + n [work] ! workspace: prefer n*n [r] + n [tau] + n*nb [work] - call stdlib_${ri}$orgqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork - & - nwork + 1, ierr ) + call stdlib${ii}$_${ri}$orgqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork - & + nwork + 1_${ik}$, ierr ) ie = itau itauq = ie + n itaup = itauq + n @@ -10550,33 +10548,33 @@ module stdlib_linalg_lapack_${ri}$ ! bidiagonalize r in work(ir) ! workspace: need n*n [r] + 3*n [e, tauq, taup] + n [work] ! workspace: prefer n*n [r] + 3*n [e, tauq, taup] + 2*n*nb [work] - call stdlib_${ri}$gebrd( n, n, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & - work( itaup ), work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_${ri}$gebrd( n, n, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & + work( itaup ), work( nwork ),lwork - nwork + 1_${ik}$, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagoal matrix in u and computing right singular ! vectors of bidiagonal matrix in vt ! workspace: need n*n [r] + 3*n [e, tauq, taup] + bdspac - call stdlib_${ri}$bdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & + call stdlib${ii}$_${ri}$bdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & work( nwork ), iwork,info ) ! overwrite u by left singular vectors of r and vt ! by right singular vectors of r ! workspace: need n*n [r] + 3*n [e, tauq, taup] + n [work] ! workspace: prefer n*n [r] + 3*n [e, tauq, taup] + n*nb [work] - call stdlib_${ri}$ormbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & - u, ldu, work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_${ri}$ormbr( 'P', 'R', 'T', n, n, n, work( ir ), ldwrkr,work( itaup ), & - vt, ldvt, work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & + u, ldu, work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_${ri}$ormbr( 'P', 'R', 'T', n, n, n, work( ir ), ldwrkr,work( itaup ), & + vt, ldvt, work( nwork ),lwork - nwork + 1_${ik}$, ierr ) ! multiply q in a by left singular vectors of r in ! work(ir), storing result in u ! workspace: need n*n [r] - call stdlib_${ri}$lacpy( 'F', n, n, u, ldu, work( ir ), ldwrkr ) - call stdlib_${ri}$gemm( 'N', 'N', m, n, n, one, a, lda, work( ir ),ldwrkr, zero, u,& + call stdlib${ii}$_${ri}$lacpy( 'F', n, n, u, ldu, work( ir ), ldwrkr ) + call stdlib${ii}$_${ri}$gemm( 'N', 'N', m, n, n, one, a, lda, work( ir ),ldwrkr, zero, u,& ldu ) else if( wntqa ) then ! path 4 (m >> n, jobz='a') ! m left singular vectors to be computed in u and ! n right singular vectors to be computed in vt - iu = 1 + iu = 1_${ik}$ ! work(iu) is n by n ldwrku = n itau = iu + ldwrku*n @@ -10584,16 +10582,16 @@ module stdlib_linalg_lapack_${ri}$ ! compute a=q*r, copying result to u ! workspace: need n*n [u] + n [tau] + n [work] ! workspace: prefer n*n [u] + n [tau] + n*nb [work] - call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & - 1, ierr ) - call stdlib_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + 1_${ik}$, ierr ) + call stdlib${ii}$_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! workspace: need n*n [u] + n [tau] + m [work] ! workspace: prefer n*n [u] + n [tau] + m*nb [work] - call stdlib_${ri}$orgqr( m, m, n, u, ldu, work( itau ),work( nwork ), lwork - & - nwork + 1, ierr ) + call stdlib${ii}$_${ri}$orgqr( m, m, n, u, ldu, work( itau ),work( nwork ), lwork - & + nwork + 1_${ik}$, ierr ) ! produce r in a, zeroing out other entries - if (n>1) call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) + if (n>1_${ik}$) call stdlib${ii}$_${ri}$laset( 'L', n-1, n-1, zero, zero, a( 2_${ik}$, 1_${ik}$ ), lda ) ie = itau itauq = ie + n itaup = itauq + n @@ -10601,105 +10599,105 @@ module stdlib_linalg_lapack_${ri}$ ! bidiagonalize r in a ! workspace: need n*n [u] + 3*n [e, tauq, taup] + n [work] ! workspace: prefer n*n [u] + 3*n [e, tauq, taup] + 2*n*nb [work] - call stdlib_${ri}$gebrd( n, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_${ri}$gebrd( n, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in work(iu) and computing right ! singular vectors of bidiagonal matrix in vt ! workspace: need n*n [u] + 3*n [e, tauq, taup] + bdspac - call stdlib_${ri}$bdsdc( 'U', 'I', n, s, work( ie ), work( iu ), n,vt, ldvt, dum, & + call stdlib${ii}$_${ri}$bdsdc( 'U', 'I', n, s, work( ie ), work( iu ), n,vt, ldvt, dum, & idum, work( nwork ), iwork,info ) ! overwrite work(iu) by left singular vectors of r and vt ! by right singular vectors of r ! workspace: need n*n [u] + 3*n [e, tauq, taup] + n [work] ! workspace: prefer n*n [u] + 3*n [e, tauq, taup] + n*nb [work] - call stdlib_${ri}$ormbr( 'Q', 'L', 'N', n, n, n, a, lda,work( itauq ), work( iu ), & - ldwrku,work( nwork ), lwork - nwork + 1, ierr ) - call stdlib_${ri}$ormbr( 'P', 'R', 'T', n, n, n, a, lda,work( itaup ), vt, ldvt, & - work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'N', n, n, n, a, lda,work( itauq ), work( iu ), & + ldwrku,work( nwork ), lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_${ri}$ormbr( 'P', 'R', 'T', n, n, n, a, lda,work( itaup ), vt, ldvt, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) ! multiply q in u by left singular vectors of r in ! work(iu), storing result in a ! workspace: need n*n [u] - call stdlib_${ri}$gemm( 'N', 'N', m, n, n, one, u, ldu, work( iu ),ldwrku, zero, a,& + call stdlib${ii}$_${ri}$gemm( 'N', 'N', m, n, n, one, u, ldu, work( iu ),ldwrku, zero, a,& lda ) ! copy left singular vectors of a from a to u - call stdlib_${ri}$lacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ri}$lacpy( 'F', m, n, a, lda, u, ldu ) end if else ! m < mnthr ! path 5 (m >= n, but not much larger) ! reduce to bidiagonal form without qr decomposition - ie = 1 + ie = 1_${ik}$ itauq = ie + n itaup = itauq + n nwork = itaup + n ! bidiagonalize a ! workspace: need 3*n [e, tauq, taup] + m [work] ! workspace: prefer 3*n [e, tauq, taup] + (m+n)*nb [work] - call stdlib_${ri}$gebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_${ri}$gebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) if( wntqn ) then ! path 5n (m >= n, jobz='n') ! perform bidiagonal svd, only computing singular values ! workspace: need 3*n [e, tauq, taup] + bdspac - call stdlib_${ri}$bdsdc( 'U', 'N', n, s, work( ie ), dum, 1, dum, 1,dum, idum, & + call stdlib${ii}$_${ri}$bdsdc( 'U', 'N', n, s, work( ie ), dum, 1_${ik}$, dum, 1_${ik}$,dum, idum, & work( nwork ), iwork, info ) else if( wntqo ) then ! path 5o (m >= n, jobz='o') iu = nwork - if( lwork >= m*n + 3*n + bdspac ) then + if( lwork >= m*n + 3_${ik}$*n + bdspac ) then ! work( iu ) is m by n ldwrku = m nwork = iu + ldwrku*n - call stdlib_${ri}$laset( 'F', m, n, zero, zero, work( iu ),ldwrku ) + call stdlib${ii}$_${ri}$laset( 'F', m, n, zero, zero, work( iu ),ldwrku ) ! ir is unused; silence compile warnings - ir = -1 + ir = -1_${ik}$ else ! work( iu ) is n by n ldwrku = n nwork = iu + ldwrku*n ! work(ir) is ldwrkr by n ir = nwork - ldwrkr = ( lwork - n*n - 3*n ) / n + ldwrkr = ( lwork - n*n - 3_${ik}$*n ) / n end if nwork = iu + ldwrku*n ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in work(iu) and computing right ! singular vectors of bidiagonal matrix in vt ! workspace: need 3*n [e, tauq, taup] + n*n [u] + bdspac - call stdlib_${ri}$bdsdc( 'U', 'I', n, s, work( ie ), work( iu ),ldwrku, vt, ldvt, & + call stdlib${ii}$_${ri}$bdsdc( 'U', 'I', n, s, work( ie ), work( iu ),ldwrku, vt, ldvt, & dum, idum, work( nwork ),iwork, info ) ! overwrite vt by right singular vectors of a ! workspace: need 3*n [e, tauq, taup] + n*n [u] + n [work] ! workspace: prefer 3*n [e, tauq, taup] + n*n [u] + n*nb [work] - call stdlib_${ri}$ormbr( 'P', 'R', 'T', n, n, n, a, lda,work( itaup ), vt, ldvt, & - work( nwork ),lwork - nwork + 1, ierr ) - if( lwork >= m*n + 3*n + bdspac ) then + call stdlib${ii}$_${ri}$ormbr( 'P', 'R', 'T', n, n, n, a, lda,work( itaup ), vt, ldvt, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + if( lwork >= m*n + 3_${ik}$*n + bdspac ) then ! path 5o-fast ! overwrite work(iu) by left singular vectors of a ! workspace: need 3*n [e, tauq, taup] + m*n [u] + n [work] ! workspace: prefer 3*n [e, tauq, taup] + m*n [u] + n*nb [work] - call stdlib_${ri}$ormbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), work( iu & - ), ldwrku,work( nwork ), lwork - nwork + 1, ierr ) + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), work( iu & + ), ldwrku,work( nwork ), lwork - nwork + 1_${ik}$, ierr ) ! copy left singular vectors of a from work(iu) to a - call stdlib_${ri}$lacpy( 'F', m, n, work( iu ), ldwrku, a, lda ) + call stdlib${ii}$_${ri}$lacpy( 'F', m, n, work( iu ), ldwrku, a, lda ) else ! path 5o-slow ! generate q in a ! workspace: need 3*n [e, tauq, taup] + n*n [u] + n [work] ! workspace: prefer 3*n [e, tauq, taup] + n*n [u] + n*nb [work] - call stdlib_${ri}$orgbr( 'Q', m, n, n, a, lda, work( itauq ),work( nwork ), & - lwork - nwork + 1, ierr ) + call stdlib${ii}$_${ri}$orgbr( 'Q', m, n, n, a, lda, work( itauq ),work( nwork ), & + lwork - nwork + 1_${ik}$, ierr ) ! multiply q in a by left singular vectors of ! bidiagonal matrix in work(iu), storing result in ! work(ir) and copying to a ! workspace: need 3*n [e, tauq, taup] + n*n [u] + nb*n [r] ! workspace: prefer 3*n [e, tauq, taup] + n*n [u] + m*n [r] do i = 1, m, ldwrkr - chunk = min( m - i + 1, ldwrkr ) - call stdlib_${ri}$gemm( 'N', 'N', chunk, n, n, one, a( i, 1 ),lda, work( iu )& + chunk = min( m - i + 1_${ik}$, ldwrkr ) + call stdlib${ii}$_${ri}$gemm( 'N', 'N', chunk, n, n, one, a( i, 1_${ik}$ ),lda, work( iu )& , ldwrku, zero,work( ir ), ldwrkr ) - call stdlib_${ri}$lacpy( 'F', chunk, n, work( ir ), ldwrkr,a( i, 1 ), lda ) + call stdlib${ii}$_${ri}$lacpy( 'F', chunk, n, work( ir ), ldwrkr,a( i, 1_${ik}$ ), lda ) end do end if @@ -10709,38 +10707,38 @@ module stdlib_linalg_lapack_${ri}$ ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in vt ! workspace: need 3*n [e, tauq, taup] + bdspac - call stdlib_${ri}$laset( 'F', m, n, zero, zero, u, ldu ) - call stdlib_${ri}$bdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & + call stdlib${ii}$_${ri}$laset( 'F', m, n, zero, zero, u, ldu ) + call stdlib${ii}$_${ri}$bdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & work( nwork ), iwork,info ) ! overwrite u by left singular vectors of a and vt ! by right singular vectors of a ! workspace: need 3*n [e, tauq, taup] + n [work] ! workspace: prefer 3*n [e, tauq, taup] + n*nb [work] - call stdlib_${ri}$ormbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), u, ldu, & - work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_${ri}$ormbr( 'P', 'R', 'T', n, n, n, a, lda,work( itaup ), vt, ldvt, & - work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), u, ldu, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_${ri}$ormbr( 'P', 'R', 'T', n, n, n, a, lda,work( itaup ), vt, ldvt, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) else if( wntqa ) then ! path 5a (m >= n, jobz='a') ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in vt ! workspace: need 3*n [e, tauq, taup] + bdspac - call stdlib_${ri}$laset( 'F', m, m, zero, zero, u, ldu ) - call stdlib_${ri}$bdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & + call stdlib${ii}$_${ri}$laset( 'F', m, m, zero, zero, u, ldu ) + call stdlib${ii}$_${ri}$bdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & work( nwork ), iwork,info ) ! set the right corner of u to identity matrix if( m>n ) then - call stdlib_${ri}$laset( 'F', m - n, m - n, zero, one, u(n+1,n+1),ldu ) + call stdlib${ii}$_${ri}$laset( 'F', m - n, m - n, zero, one, u(n+1,n+1),ldu ) end if ! overwrite u by left singular vectors of a and vt ! by right singular vectors of a ! workspace: need 3*n [e, tauq, taup] + m [work] ! workspace: prefer 3*n [e, tauq, taup] + m*nb [work] - call stdlib_${ri}$ormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & - work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_${ri}$ormbr( 'P', 'R', 'T', n, n, m, a, lda,work( itaup ), vt, ldvt, & - work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_${ri}$ormbr( 'P', 'R', 'T', n, n, m, a, lda,work( itaup ), vt, ldvt, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) end if end if else @@ -10751,38 +10749,38 @@ module stdlib_linalg_lapack_${ri}$ if( wntqn ) then ! path 1t (n >> m, jobz='n') ! no singular vectors to be computed - itau = 1 + itau = 1_${ik}$ nwork = itau + m ! compute a=l*q ! workspace: need m [tau] + m [work] ! workspace: prefer m [tau] + m*nb [work] - call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & - 1, ierr ) + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + 1_${ik}$, ierr ) ! zero out above l - if (m>1) call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, a( 1, 2 ), lda ) - ie = 1 + if (m>1_${ik}$) call stdlib${ii}$_${ri}$laset( 'U', m-1, m-1, zero, zero, a( 1_${ik}$, 2_${ik}$ ), lda ) + ie = 1_${ik}$ itauq = ie + m itaup = itauq + m nwork = itaup + m ! bidiagonalize l in a ! workspace: need 3*m [e, tauq, taup] + m [work] ! workspace: prefer 3*m [e, tauq, taup] + 2*m*nb [work] - call stdlib_${ri}$gebrd( m, m, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_${ri}$gebrd( m, m, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) nwork = ie + m ! perform bidiagonal svd, computing singular values only ! workspace: need m [e] + bdspac - call stdlib_${ri}$bdsdc( 'U', 'N', m, s, work( ie ), dum, 1, dum, 1,dum, idum, & + call stdlib${ii}$_${ri}$bdsdc( 'U', 'N', m, s, work( ie ), dum, 1_${ik}$, dum, 1_${ik}$,dum, idum, & work( nwork ), iwork, info ) else if( wntqo ) then ! path 2t (n >> m, jobz='o') ! m right singular vectors to be overwritten on a and ! m left singular vectors to be computed in u - ivt = 1 + ivt = 1_${ik}$ ! work(ivt) is m by m ! work(il) is m by m; it is later resized to m by chunk for gemm il = ivt + m*m - if( lwork >= m*n + m*m + 3*m + bdspac ) then + if( lwork >= m*n + m*m + 3_${ik}$*m + bdspac ) then ldwrkl = m chunk = n else @@ -10794,17 +10792,17 @@ module stdlib_linalg_lapack_${ri}$ ! compute a=l*q ! workspace: need m*m [vt] + m*m [l] + m [tau] + m [work] ! workspace: prefer m*m [vt] + m*m [l] + m [tau] + m*nb [work] - call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & - 1, ierr ) + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + 1_${ik}$, ierr ) ! copy l to work(il), zeroing about above it - call stdlib_${ri}$lacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) - call stdlib_${ri}$laset( 'U', m - 1, m - 1, zero, zero,work( il + ldwrkl ), ldwrkl & + call stdlib${ii}$_${ri}$lacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) + call stdlib${ii}$_${ri}$laset( 'U', m - 1_${ik}$, m - 1_${ik}$, zero, zero,work( il + ldwrkl ), ldwrkl & ) ! generate q in a ! workspace: need m*m [vt] + m*m [l] + m [tau] + m [work] ! workspace: prefer m*m [vt] + m*m [l] + m [tau] + m*nb [work] - call stdlib_${ri}$orglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork - & - nwork + 1, ierr ) + call stdlib${ii}$_${ri}$orglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork - & + nwork + 1_${ik}$, ierr ) ie = itau itauq = ie + m itaup = itauq + m @@ -10812,39 +10810,39 @@ module stdlib_linalg_lapack_${ri}$ ! bidiagonalize l in work(il) ! workspace: need m*m [vt] + m*m [l] + 3*m [e, tauq, taup] + m [work] ! workspace: prefer m*m [vt] + m*m [l] + 3*m [e, tauq, taup] + 2*m*nb [work] - call stdlib_${ri}$gebrd( m, m, work( il ), ldwrkl, s, work( ie ),work( itauq ), & - work( itaup ), work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_${ri}$gebrd( m, m, work( il ), ldwrkl, s, work( ie ),work( itauq ), & + work( itaup ), work( nwork ),lwork - nwork + 1_${ik}$, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in u, and computing right singular ! vectors of bidiagonal matrix in work(ivt) ! workspace: need m*m [vt] + m*m [l] + 3*m [e, tauq, taup] + bdspac - call stdlib_${ri}$bdsdc( 'U', 'I', m, s, work( ie ), u, ldu,work( ivt ), m, dum, & + call stdlib${ii}$_${ri}$bdsdc( 'U', 'I', m, s, work( ie ), u, ldu,work( ivt ), m, dum, & idum, work( nwork ),iwork, info ) ! overwrite u by left singular vectors of l and work(ivt) ! by right singular vectors of l ! workspace: need m*m [vt] + m*m [l] + 3*m [e, tauq, taup] + m [work] ! workspace: prefer m*m [vt] + m*m [l] + 3*m [e, tauq, taup] + m*nb [work] - call stdlib_${ri}$ormbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & - u, ldu, work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_${ri}$ormbr( 'P', 'R', 'T', m, m, m, work( il ), ldwrkl,work( itaup ), & - work( ivt ), m,work( nwork ), lwork - nwork + 1, ierr ) + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & + u, ldu, work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_${ri}$ormbr( 'P', 'R', 'T', m, m, m, work( il ), ldwrkl,work( itaup ), & + work( ivt ), m,work( nwork ), lwork - nwork + 1_${ik}$, ierr ) ! multiply right singular vectors of l in work(ivt) by q ! in a, storing result in work(il) and copying to a ! workspace: need m*m [vt] + m*m [l] ! workspace: prefer m*m [vt] + m*n [l] ! at this point, l is resized as m by chunk. do i = 1, n, chunk - blk = min( n - i + 1, chunk ) - call stdlib_${ri}$gemm( 'N', 'N', m, blk, m, one, work( ivt ), m,a( 1, i ), lda,& + blk = min( n - i + 1_${ik}$, chunk ) + call stdlib${ii}$_${ri}$gemm( 'N', 'N', m, blk, m, one, work( ivt ), m,a( 1_${ik}$, i ), lda,& zero, work( il ), ldwrkl ) - call stdlib_${ri}$lacpy( 'F', m, blk, work( il ), ldwrkl,a( 1, i ), lda ) + call stdlib${ii}$_${ri}$lacpy( 'F', m, blk, work( il ), ldwrkl,a( 1_${ik}$, i ), lda ) end do else if( wntqs ) then ! path 3t (n >> m, jobz='s') ! m right singular vectors to be computed in vt and ! m left singular vectors to be computed in u - il = 1 + il = 1_${ik}$ ! work(il) is m by m ldwrkl = m itau = il + ldwrkl*m @@ -10852,17 +10850,17 @@ module stdlib_linalg_lapack_${ri}$ ! compute a=l*q ! workspace: need m*m [l] + m [tau] + m [work] ! workspace: prefer m*m [l] + m [tau] + m*nb [work] - call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & - 1, ierr ) + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + 1_${ik}$, ierr ) ! copy l to work(il), zeroing out above it - call stdlib_${ri}$lacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) - call stdlib_${ri}$laset( 'U', m - 1, m - 1, zero, zero,work( il + ldwrkl ), ldwrkl & + call stdlib${ii}$_${ri}$lacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) + call stdlib${ii}$_${ri}$laset( 'U', m - 1_${ik}$, m - 1_${ik}$, zero, zero,work( il + ldwrkl ), ldwrkl & ) ! generate q in a ! workspace: need m*m [l] + m [tau] + m [work] ! workspace: prefer m*m [l] + m [tau] + m*nb [work] - call stdlib_${ri}$orglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork - & - nwork + 1, ierr ) + call stdlib${ii}$_${ri}$orglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork - & + nwork + 1_${ik}$, ierr ) ie = itau itauq = ie + m itaup = itauq + m @@ -10870,33 +10868,33 @@ module stdlib_linalg_lapack_${ri}$ ! bidiagonalize l in work(iu). ! workspace: need m*m [l] + 3*m [e, tauq, taup] + m [work] ! workspace: prefer m*m [l] + 3*m [e, tauq, taup] + 2*m*nb [work] - call stdlib_${ri}$gebrd( m, m, work( il ), ldwrkl, s, work( ie ),work( itauq ), & - work( itaup ), work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_${ri}$gebrd( m, m, work( il ), ldwrkl, s, work( ie ),work( itauq ), & + work( itaup ), work( nwork ),lwork - nwork + 1_${ik}$, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in vt ! workspace: need m*m [l] + 3*m [e, tauq, taup] + bdspac - call stdlib_${ri}$bdsdc( 'U', 'I', m, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & + call stdlib${ii}$_${ri}$bdsdc( 'U', 'I', m, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & work( nwork ), iwork,info ) ! overwrite u by left singular vectors of l and vt ! by right singular vectors of l ! workspace: need m*m [l] + 3*m [e, tauq, taup] + m [work] ! workspace: prefer m*m [l] + 3*m [e, tauq, taup] + m*nb [work] - call stdlib_${ri}$ormbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & - u, ldu, work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_${ri}$ormbr( 'P', 'R', 'T', m, m, m, work( il ), ldwrkl,work( itaup ), & - vt, ldvt, work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & + u, ldu, work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_${ri}$ormbr( 'P', 'R', 'T', m, m, m, work( il ), ldwrkl,work( itaup ), & + vt, ldvt, work( nwork ),lwork - nwork + 1_${ik}$, ierr ) ! multiply right singular vectors of l in work(il) by ! q in a, storing result in vt ! workspace: need m*m [l] - call stdlib_${ri}$lacpy( 'F', m, m, vt, ldvt, work( il ), ldwrkl ) - call stdlib_${ri}$gemm( 'N', 'N', m, n, m, one, work( il ), ldwrkl,a, lda, zero, & + call stdlib${ii}$_${ri}$lacpy( 'F', m, m, vt, ldvt, work( il ), ldwrkl ) + call stdlib${ii}$_${ri}$gemm( 'N', 'N', m, n, m, one, work( il ), ldwrkl,a, lda, zero, & vt, ldvt ) else if( wntqa ) then ! path 4t (n >> m, jobz='a') ! n right singular vectors to be computed in vt and ! m left singular vectors to be computed in u - ivt = 1 + ivt = 1_${ik}$ ! work(ivt) is m by m ldwkvt = m itau = ivt + ldwkvt*m @@ -10904,16 +10902,16 @@ module stdlib_linalg_lapack_${ri}$ ! compute a=l*q, copying result to vt ! workspace: need m*m [vt] + m [tau] + m [work] ! workspace: prefer m*m [vt] + m [tau] + m*nb [work] - call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & - 1, ierr ) - call stdlib_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + 1_${ik}$, ierr ) + call stdlib${ii}$_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! workspace: need m*m [vt] + m [tau] + n [work] ! workspace: prefer m*m [vt] + m [tau] + n*nb [work] - call stdlib_${ri}$orglq( n, n, m, vt, ldvt, work( itau ),work( nwork ), lwork - & - nwork + 1, ierr ) + call stdlib${ii}$_${ri}$orglq( n, n, m, vt, ldvt, work( itau ),work( nwork ), lwork - & + nwork + 1_${ik}$, ierr ) ! produce l in a, zeroing out other entries - if (m>1) call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, a( 1, 2 ), lda ) + if (m>1_${ik}$) call stdlib${ii}$_${ri}$laset( 'U', m-1, m-1, zero, zero, a( 1_${ik}$, 2_${ik}$ ), lda ) ie = itau itauq = ie + m itaup = itauq + m @@ -10921,103 +10919,103 @@ module stdlib_linalg_lapack_${ri}$ ! bidiagonalize l in a ! workspace: need m*m [vt] + 3*m [e, tauq, taup] + m [work] ! workspace: prefer m*m [vt] + 3*m [e, tauq, taup] + 2*m*nb [work] - call stdlib_${ri}$gebrd( m, m, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_${ri}$gebrd( m, m, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in work(ivt) ! workspace: need m*m [vt] + 3*m [e, tauq, taup] + bdspac - call stdlib_${ri}$bdsdc( 'U', 'I', m, s, work( ie ), u, ldu,work( ivt ), ldwkvt, & + call stdlib${ii}$_${ri}$bdsdc( 'U', 'I', m, s, work( ie ), u, ldu,work( ivt ), ldwkvt, & dum, idum,work( nwork ), iwork, info ) ! overwrite u by left singular vectors of l and work(ivt) ! by right singular vectors of l ! workspace: need m*m [vt] + 3*m [e, tauq, taup]+ m [work] ! workspace: prefer m*m [vt] + 3*m [e, tauq, taup]+ m*nb [work] - call stdlib_${ri}$ormbr( 'Q', 'L', 'N', m, m, m, a, lda,work( itauq ), u, ldu, & - work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_${ri}$ormbr( 'P', 'R', 'T', m, m, m, a, lda,work( itaup ), work( ivt ),& - ldwkvt,work( nwork ), lwork - nwork + 1, ierr ) + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'N', m, m, m, a, lda,work( itauq ), u, ldu, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_${ri}$ormbr( 'P', 'R', 'T', m, m, m, a, lda,work( itaup ), work( ivt ),& + ldwkvt,work( nwork ), lwork - nwork + 1_${ik}$, ierr ) ! multiply right singular vectors of l in work(ivt) by ! q in vt, storing result in a ! workspace: need m*m [vt] - call stdlib_${ri}$gemm( 'N', 'N', m, n, m, one, work( ivt ), ldwkvt,vt, ldvt, zero,& + call stdlib${ii}$_${ri}$gemm( 'N', 'N', m, n, m, one, work( ivt ), ldwkvt,vt, ldvt, zero,& a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_${ri}$lacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ri}$lacpy( 'F', m, n, a, lda, vt, ldvt ) end if else ! n < mnthr ! path 5t (n > m, but not much larger) ! reduce to bidiagonal form without lq decomposition - ie = 1 + ie = 1_${ik}$ itauq = ie + m itaup = itauq + m nwork = itaup + m ! bidiagonalize a ! workspace: need 3*m [e, tauq, taup] + n [work] ! workspace: prefer 3*m [e, tauq, taup] + (m+n)*nb [work] - call stdlib_${ri}$gebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_${ri}$gebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) if( wntqn ) then ! path 5tn (n > m, jobz='n') ! perform bidiagonal svd, only computing singular values ! workspace: need 3*m [e, tauq, taup] + bdspac - call stdlib_${ri}$bdsdc( 'L', 'N', m, s, work( ie ), dum, 1, dum, 1,dum, idum, & + call stdlib${ii}$_${ri}$bdsdc( 'L', 'N', m, s, work( ie ), dum, 1_${ik}$, dum, 1_${ik}$,dum, idum, & work( nwork ), iwork, info ) else if( wntqo ) then ! path 5to (n > m, jobz='o') ldwkvt = m ivt = nwork - if( lwork >= m*n + 3*m + bdspac ) then + if( lwork >= m*n + 3_${ik}$*m + bdspac ) then ! work( ivt ) is m by n - call stdlib_${ri}$laset( 'F', m, n, zero, zero, work( ivt ),ldwkvt ) + call stdlib${ii}$_${ri}$laset( 'F', m, n, zero, zero, work( ivt ),ldwkvt ) nwork = ivt + ldwkvt*n ! il is unused; silence compile warnings - il = -1 + il = -1_${ik}$ else ! work( ivt ) is m by m nwork = ivt + ldwkvt*m il = nwork ! work(il) is m by chunk - chunk = ( lwork - m*m - 3*m ) / m + chunk = ( lwork - m*m - 3_${ik}$*m ) / m end if ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in work(ivt) ! workspace: need 3*m [e, tauq, taup] + m*m [vt] + bdspac - call stdlib_${ri}$bdsdc( 'L', 'I', m, s, work( ie ), u, ldu,work( ivt ), ldwkvt, & + call stdlib${ii}$_${ri}$bdsdc( 'L', 'I', m, s, work( ie ), u, ldu,work( ivt ), ldwkvt, & dum, idum,work( nwork ), iwork, info ) ! overwrite u by left singular vectors of a ! workspace: need 3*m [e, tauq, taup] + m*m [vt] + m [work] ! workspace: prefer 3*m [e, tauq, taup] + m*m [vt] + m*nb [work] - call stdlib_${ri}$ormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & - work( nwork ),lwork - nwork + 1, ierr ) - if( lwork >= m*n + 3*m + bdspac ) then + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + if( lwork >= m*n + 3_${ik}$*m + bdspac ) then ! path 5to-fast ! overwrite work(ivt) by left singular vectors of a ! workspace: need 3*m [e, tauq, taup] + m*n [vt] + m [work] ! workspace: prefer 3*m [e, tauq, taup] + m*n [vt] + m*nb [work] - call stdlib_${ri}$ormbr( 'P', 'R', 'T', m, n, m, a, lda,work( itaup ), work( & - ivt ), ldwkvt,work( nwork ), lwork - nwork + 1, ierr ) + call stdlib${ii}$_${ri}$ormbr( 'P', 'R', 'T', m, n, m, a, lda,work( itaup ), work( & + ivt ), ldwkvt,work( nwork ), lwork - nwork + 1_${ik}$, ierr ) ! copy right singular vectors of a from work(ivt) to a - call stdlib_${ri}$lacpy( 'F', m, n, work( ivt ), ldwkvt, a, lda ) + call stdlib${ii}$_${ri}$lacpy( 'F', m, n, work( ivt ), ldwkvt, a, lda ) else ! path 5to-slow ! generate p**t in a ! workspace: need 3*m [e, tauq, taup] + m*m [vt] + m [work] ! workspace: prefer 3*m [e, tauq, taup] + m*m [vt] + m*nb [work] - call stdlib_${ri}$orgbr( 'P', m, n, m, a, lda, work( itaup ),work( nwork ), & - lwork - nwork + 1, ierr ) + call stdlib${ii}$_${ri}$orgbr( 'P', m, n, m, a, lda, work( itaup ),work( nwork ), & + lwork - nwork + 1_${ik}$, ierr ) ! multiply q in a by right singular vectors of ! bidiagonal matrix in work(ivt), storing result in ! work(il) and copying to a ! workspace: need 3*m [e, tauq, taup] + m*m [vt] + m*nb [l] ! workspace: prefer 3*m [e, tauq, taup] + m*m [vt] + m*n [l] do i = 1, n, chunk - blk = min( n - i + 1, chunk ) - call stdlib_${ri}$gemm( 'N', 'N', m, blk, m, one, work( ivt ),ldwkvt, a( 1, & + blk = min( n - i + 1_${ik}$, chunk ) + call stdlib${ii}$_${ri}$gemm( 'N', 'N', m, blk, m, one, work( ivt ),ldwkvt, a( 1_${ik}$, & i ), lda, zero,work( il ), m ) - call stdlib_${ri}$lacpy( 'F', m, blk, work( il ), m, a( 1, i ),lda ) + call stdlib${ii}$_${ri}$lacpy( 'F', m, blk, work( il ), m, a( 1_${ik}$, i ),lda ) end do end if else if( wntqs ) then @@ -11026,55 +11024,55 @@ module stdlib_linalg_lapack_${ri}$ ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in vt ! workspace: need 3*m [e, tauq, taup] + bdspac - call stdlib_${ri}$laset( 'F', m, n, zero, zero, vt, ldvt ) - call stdlib_${ri}$bdsdc( 'L', 'I', m, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & + call stdlib${ii}$_${ri}$laset( 'F', m, n, zero, zero, vt, ldvt ) + call stdlib${ii}$_${ri}$bdsdc( 'L', 'I', m, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & work( nwork ), iwork,info ) ! overwrite u by left singular vectors of a and vt ! by right singular vectors of a ! workspace: need 3*m [e, tauq, taup] + m [work] ! workspace: prefer 3*m [e, tauq, taup] + m*nb [work] - call stdlib_${ri}$ormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & - work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_${ri}$ormbr( 'P', 'R', 'T', m, n, m, a, lda,work( itaup ), vt, ldvt, & - work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_${ri}$ormbr( 'P', 'R', 'T', m, n, m, a, lda,work( itaup ), vt, ldvt, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) else if( wntqa ) then ! path 5ta (n > m, jobz='a') ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in vt ! workspace: need 3*m [e, tauq, taup] + bdspac - call stdlib_${ri}$laset( 'F', n, n, zero, zero, vt, ldvt ) - call stdlib_${ri}$bdsdc( 'L', 'I', m, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & + call stdlib${ii}$_${ri}$laset( 'F', n, n, zero, zero, vt, ldvt ) + call stdlib${ii}$_${ri}$bdsdc( 'L', 'I', m, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & work( nwork ), iwork,info ) ! set the right corner of vt to identity matrix if( n>m ) then - call stdlib_${ri}$laset( 'F', n-m, n-m, zero, one, vt(m+1,m+1),ldvt ) + call stdlib${ii}$_${ri}$laset( 'F', n-m, n-m, zero, one, vt(m+1,m+1),ldvt ) end if ! overwrite u by left singular vectors of a and vt ! by right singular vectors of a ! workspace: need 3*m [e, tauq, taup] + n [work] ! workspace: prefer 3*m [e, tauq, taup] + n*nb [work] - call stdlib_${ri}$ormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & - work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_${ri}$ormbr( 'P', 'R', 'T', n, n, m, a, lda,work( itaup ), vt, ldvt, & - work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_${ri}$ormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_${ri}$ormbr( 'P', 'R', 'T', n, n, m, a, lda,work( itaup ), vt, ldvt, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) end if end if end if ! undo scaling if necessary - if( iscl==1 ) then - if( anrm>bignum )call stdlib_${ri}$lascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,& + if( iscl==1_${ik}$ ) then + if( anrm>bignum )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn, 1_${ik}$, s, minmn,& ierr ) - if( anrm=n .and. minmn>0 ) then - ! compute space needed for stdlib_${ri}$bdsqr - mnthr = stdlib_ilaenv( 6, 'DGESVD', jobu // jobvt, m, n, 0, 0 ) - bdspac = 5*n - ! compute space needed for stdlib_${ri}$geqrf - call stdlib_${ri}$geqrf( m, n, a, lda, dum(1), dum(1), -1, ierr ) - lwork_qgeqrf = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_${ri}$orgqr - call stdlib_${ri}$orgqr( m, n, n, a, lda, dum(1), dum(1), -1, ierr ) - lwork_qorgqr_n = int( dum(1),KIND=ilp) - call stdlib_${ri}$orgqr( m, m, n, a, lda, dum(1), dum(1), -1, ierr ) - lwork_qorgqr_m = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_${ri}$gebrd - call stdlib_${ri}$gebrd( n, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) + ! following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + if( m>=n .and. minmn>0_${ik}$ ) then + ! compute space needed for stdlib${ii}$_${ri}$bdsqr + mnthr = stdlib${ii}$_ilaenv( 6_${ik}$, 'DGESVD', jobu // jobvt, m, n, 0_${ik}$, 0_${ik}$ ) + bdspac = 5_${ik}$*n + ! compute space needed for stdlib${ii}$_${ri}$geqrf + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_qgeqrf = int( dum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_${ri}$orgqr + call stdlib${ii}$_${ri}$orgqr( m, n, n, a, lda, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_qorgqr_n = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ri}$orgqr( m, m, n, a, lda, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_qorgqr_m = int( dum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_${ri}$gebrd + call stdlib${ii}$_${ri}$gebrd( n, n, a, lda, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) - lwork_qgebrd = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_${ri}$orgbr p - call stdlib_${ri}$orgbr( 'P', n, n, n, a, lda, dum(1),dum(1), -1, ierr ) - lwork_qorgbr_p = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_${ri}$orgbr q - call stdlib_${ri}$orgbr( 'Q', n, n, n, a, lda, dum(1),dum(1), -1, ierr ) - lwork_qorgbr_q = int( dum(1),KIND=ilp) + lwork_qgebrd = int( dum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_${ri}$orgbr p + call stdlib${ii}$_${ri}$orgbr( 'P', n, n, n, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_qorgbr_p = int( dum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_${ri}$orgbr q + call stdlib${ii}$_${ri}$orgbr( 'Q', n, n, n, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_qorgbr_q = int( dum(1_${ik}$),KIND=${ik}$) if( m>=mnthr ) then if( wntun ) then ! path 1 (m much larger than n, jobu='n') maxwrk = n + lwork_qgeqrf - maxwrk = max( maxwrk, 3*n + lwork_qgebrd ) - if( wntvo .or. wntvas )maxwrk = max( maxwrk, 3*n + lwork_qorgbr_p ) + maxwrk = max( maxwrk, 3_${ik}$*n + lwork_qgebrd ) + if( wntvo .or. wntvas )maxwrk = max( maxwrk, 3_${ik}$*n + lwork_qorgbr_p ) maxwrk = max( maxwrk, bdspac ) - minwrk = max( 4*n, bdspac ) + minwrk = max( 4_${ik}$*n, bdspac ) else if( wntuo .and. wntvn ) then ! path 2 (m much larger than n, jobu='o', jobvt='n') wrkbl = n + lwork_qgeqrf wrkbl = max( wrkbl, n + lwork_qorgqr_n ) - wrkbl = max( wrkbl, 3*n + lwork_qgebrd ) - wrkbl = max( wrkbl, 3*n + lwork_qorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qorgbr_q ) wrkbl = max( wrkbl, bdspac ) maxwrk = max( n*n + wrkbl, n*n + m*n + n ) - minwrk = max( 3*n + m, bdspac ) + minwrk = max( 3_${ik}$*n + m, bdspac ) else if( wntuo .and. wntvas ) then ! path 3 (m much larger than n, jobu='o', jobvt='s' or ! 'a') wrkbl = n + lwork_qgeqrf wrkbl = max( wrkbl, n + lwork_qorgqr_n ) - wrkbl = max( wrkbl, 3*n + lwork_qgebrd ) - wrkbl = max( wrkbl, 3*n + lwork_qorgbr_q ) - wrkbl = max( wrkbl, 3*n + lwork_qorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qorgbr_p ) wrkbl = max( wrkbl, bdspac ) maxwrk = max( n*n + wrkbl, n*n + m*n + n ) - minwrk = max( 3*n + m, bdspac ) + minwrk = max( 3_${ik}$*n + m, bdspac ) else if( wntus .and. wntvn ) then ! path 4 (m much larger than n, jobu='s', jobvt='n') wrkbl = n + lwork_qgeqrf wrkbl = max( wrkbl, n + lwork_qorgqr_n ) - wrkbl = max( wrkbl, 3*n + lwork_qgebrd ) - wrkbl = max( wrkbl, 3*n + lwork_qorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qorgbr_q ) wrkbl = max( wrkbl, bdspac ) maxwrk = n*n + wrkbl - minwrk = max( 3*n + m, bdspac ) + minwrk = max( 3_${ik}$*n + m, bdspac ) else if( wntus .and. wntvo ) then ! path 5 (m much larger than n, jobu='s', jobvt='o') wrkbl = n + lwork_qgeqrf wrkbl = max( wrkbl, n + lwork_qorgqr_n ) - wrkbl = max( wrkbl, 3*n + lwork_qgebrd ) - wrkbl = max( wrkbl, 3*n + lwork_qorgbr_q ) - wrkbl = max( wrkbl, 3*n + lwork_qorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qorgbr_p ) wrkbl = max( wrkbl, bdspac ) - maxwrk = 2*n*n + wrkbl - minwrk = max( 3*n + m, bdspac ) + maxwrk = 2_${ik}$*n*n + wrkbl + minwrk = max( 3_${ik}$*n + m, bdspac ) else if( wntus .and. wntvas ) then ! path 6 (m much larger than n, jobu='s', jobvt='s' or ! 'a') wrkbl = n + lwork_qgeqrf wrkbl = max( wrkbl, n + lwork_qorgqr_n ) - wrkbl = max( wrkbl, 3*n + lwork_qgebrd ) - wrkbl = max( wrkbl, 3*n + lwork_qorgbr_q ) - wrkbl = max( wrkbl, 3*n + lwork_qorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qorgbr_p ) wrkbl = max( wrkbl, bdspac ) maxwrk = n*n + wrkbl - minwrk = max( 3*n + m, bdspac ) + minwrk = max( 3_${ik}$*n + m, bdspac ) else if( wntua .and. wntvn ) then ! path 7 (m much larger than n, jobu='a', jobvt='n') wrkbl = n + lwork_qgeqrf wrkbl = max( wrkbl, n + lwork_qorgqr_m ) - wrkbl = max( wrkbl, 3*n + lwork_qgebrd ) - wrkbl = max( wrkbl, 3*n + lwork_qorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qorgbr_q ) wrkbl = max( wrkbl, bdspac ) maxwrk = n*n + wrkbl - minwrk = max( 3*n + m, bdspac ) + minwrk = max( 3_${ik}$*n + m, bdspac ) else if( wntua .and. wntvo ) then ! path 8 (m much larger than n, jobu='a', jobvt='o') wrkbl = n + lwork_qgeqrf wrkbl = max( wrkbl, n + lwork_qorgqr_m ) - wrkbl = max( wrkbl, 3*n + lwork_qgebrd ) - wrkbl = max( wrkbl, 3*n + lwork_qorgbr_q ) - wrkbl = max( wrkbl, 3*n + lwork_qorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qorgbr_p ) wrkbl = max( wrkbl, bdspac ) - maxwrk = 2*n*n + wrkbl - minwrk = max( 3*n + m, bdspac ) + maxwrk = 2_${ik}$*n*n + wrkbl + minwrk = max( 3_${ik}$*n + m, bdspac ) else if( wntua .and. wntvas ) then ! path 9 (m much larger than n, jobu='a', jobvt='s' or ! 'a') wrkbl = n + lwork_qgeqrf wrkbl = max( wrkbl, n + lwork_qorgqr_m ) - wrkbl = max( wrkbl, 3*n + lwork_qgebrd ) - wrkbl = max( wrkbl, 3*n + lwork_qorgbr_q ) - wrkbl = max( wrkbl, 3*n + lwork_qorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_qorgbr_p ) wrkbl = max( wrkbl, bdspac ) maxwrk = n*n + wrkbl - minwrk = max( 3*n + m, bdspac ) + minwrk = max( 3_${ik}$*n + m, bdspac ) end if else ! path 10 (m at least n, but not much larger) - call stdlib_${ri}$gebrd( m, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) + call stdlib${ii}$_${ri}$gebrd( m, n, a, lda, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) - lwork_qgebrd = int( dum(1),KIND=ilp) - maxwrk = 3*n + lwork_qgebrd + lwork_qgebrd = int( dum(1_${ik}$),KIND=${ik}$) + maxwrk = 3_${ik}$*n + lwork_qgebrd if( wntus .or. wntuo ) then - call stdlib_${ri}$orgbr( 'Q', m, n, n, a, lda, dum(1),dum(1), -1, ierr ) - lwork_qorgbr_q = int( dum(1),KIND=ilp) - maxwrk = max( maxwrk, 3*n + lwork_qorgbr_q ) + call stdlib${ii}$_${ri}$orgbr( 'Q', m, n, n, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_qorgbr_q = int( dum(1_${ik}$),KIND=${ik}$) + maxwrk = max( maxwrk, 3_${ik}$*n + lwork_qorgbr_q ) end if if( wntua ) then - call stdlib_${ri}$orgbr( 'Q', m, m, n, a, lda, dum(1),dum(1), -1, ierr ) - lwork_qorgbr_q = int( dum(1),KIND=ilp) - maxwrk = max( maxwrk, 3*n + lwork_qorgbr_q ) + call stdlib${ii}$_${ri}$orgbr( 'Q', m, m, n, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_qorgbr_q = int( dum(1_${ik}$),KIND=${ik}$) + maxwrk = max( maxwrk, 3_${ik}$*n + lwork_qorgbr_q ) end if if( .not.wntvn ) then - maxwrk = max( maxwrk, 3*n + lwork_qorgbr_p ) + maxwrk = max( maxwrk, 3_${ik}$*n + lwork_qorgbr_p ) end if maxwrk = max( maxwrk, bdspac ) - minwrk = max( 3*n + m, bdspac ) - end if - else if( minmn>0 ) then - ! compute space needed for stdlib_${ri}$bdsqr - mnthr = stdlib_ilaenv( 6, 'DGESVD', jobu // jobvt, m, n, 0, 0 ) - bdspac = 5*m - ! compute space needed for stdlib_${ri}$gelqf - call stdlib_${ri}$gelqf( m, n, a, lda, dum(1), dum(1), -1, ierr ) - lwork_qgelqf = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_${ri}$orglq - call stdlib_${ri}$orglq( n, n, m, dum(1), n, dum(1), dum(1), -1, ierr ) - lwork_qorglq_n = int( dum(1),KIND=ilp) - call stdlib_${ri}$orglq( m, n, m, a, lda, dum(1), dum(1), -1, ierr ) - lwork_qorglq_m = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_${ri}$gebrd - call stdlib_${ri}$gebrd( m, m, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) + minwrk = max( 3_${ik}$*n + m, bdspac ) + end if + else if( minmn>0_${ik}$ ) then + ! compute space needed for stdlib${ii}$_${ri}$bdsqr + mnthr = stdlib${ii}$_ilaenv( 6_${ik}$, 'DGESVD', jobu // jobvt, m, n, 0_${ik}$, 0_${ik}$ ) + bdspac = 5_${ik}$*m + ! compute space needed for stdlib${ii}$_${ri}$gelqf + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_qgelqf = int( dum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_${ri}$orglq + call stdlib${ii}$_${ri}$orglq( n, n, m, dum(1_${ik}$), n, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_qorglq_n = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ri}$orglq( m, n, m, a, lda, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_qorglq_m = int( dum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_${ri}$gebrd + call stdlib${ii}$_${ri}$gebrd( m, m, a, lda, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) - lwork_qgebrd = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_${ri}$orgbr p - call stdlib_${ri}$orgbr( 'P', m, m, m, a, n, dum(1),dum(1), -1, ierr ) - lwork_qorgbr_p = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_${ri}$orgbr q - call stdlib_${ri}$orgbr( 'Q', m, m, m, a, n, dum(1),dum(1), -1, ierr ) - lwork_qorgbr_q = int( dum(1),KIND=ilp) + lwork_qgebrd = int( dum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_${ri}$orgbr p + call stdlib${ii}$_${ri}$orgbr( 'P', m, m, m, a, n, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_qorgbr_p = int( dum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_${ri}$orgbr q + call stdlib${ii}$_${ri}$orgbr( 'Q', m, m, m, a, n, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_qorgbr_q = int( dum(1_${ik}$),KIND=${ik}$) if( n>=mnthr ) then if( wntvn ) then ! path 1t(n much larger than m, jobvt='n') maxwrk = m + lwork_qgelqf - maxwrk = max( maxwrk, 3*m + lwork_qgebrd ) - if( wntuo .or. wntuas )maxwrk = max( maxwrk, 3*m + lwork_qorgbr_q ) + maxwrk = max( maxwrk, 3_${ik}$*m + lwork_qgebrd ) + if( wntuo .or. wntuas )maxwrk = max( maxwrk, 3_${ik}$*m + lwork_qorgbr_q ) maxwrk = max( maxwrk, bdspac ) - minwrk = max( 4*m, bdspac ) + minwrk = max( 4_${ik}$*m, bdspac ) else if( wntvo .and. wntun ) then ! path 2t(n much larger than m, jobu='n', jobvt='o') wrkbl = m + lwork_qgelqf wrkbl = max( wrkbl, m + lwork_qorglq_m ) - wrkbl = max( wrkbl, 3*m + lwork_qgebrd ) - wrkbl = max( wrkbl, 3*m + lwork_qorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qorgbr_p ) wrkbl = max( wrkbl, bdspac ) maxwrk = max( m*m + wrkbl, m*m + m*n + m ) - minwrk = max( 3*m + n, bdspac ) + minwrk = max( 3_${ik}$*m + n, bdspac ) else if( wntvo .and. wntuas ) then ! path 3t(n much larger than m, jobu='s' or 'a', ! jobvt='o') wrkbl = m + lwork_qgelqf wrkbl = max( wrkbl, m + lwork_qorglq_m ) - wrkbl = max( wrkbl, 3*m + lwork_qgebrd ) - wrkbl = max( wrkbl, 3*m + lwork_qorgbr_p ) - wrkbl = max( wrkbl, 3*m + lwork_qorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qorgbr_q ) wrkbl = max( wrkbl, bdspac ) maxwrk = max( m*m + wrkbl, m*m + m*n + m ) - minwrk = max( 3*m + n, bdspac ) + minwrk = max( 3_${ik}$*m + n, bdspac ) else if( wntvs .and. wntun ) then ! path 4t(n much larger than m, jobu='n', jobvt='s') wrkbl = m + lwork_qgelqf wrkbl = max( wrkbl, m + lwork_qorglq_m ) - wrkbl = max( wrkbl, 3*m + lwork_qgebrd ) - wrkbl = max( wrkbl, 3*m + lwork_qorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qorgbr_p ) wrkbl = max( wrkbl, bdspac ) maxwrk = m*m + wrkbl - minwrk = max( 3*m + n, bdspac ) + minwrk = max( 3_${ik}$*m + n, bdspac ) else if( wntvs .and. wntuo ) then ! path 5t(n much larger than m, jobu='o', jobvt='s') wrkbl = m + lwork_qgelqf wrkbl = max( wrkbl, m + lwork_qorglq_m ) - wrkbl = max( wrkbl, 3*m + lwork_qgebrd ) - wrkbl = max( wrkbl, 3*m + lwork_qorgbr_p ) - wrkbl = max( wrkbl, 3*m + lwork_qorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qorgbr_q ) wrkbl = max( wrkbl, bdspac ) - maxwrk = 2*m*m + wrkbl - minwrk = max( 3*m + n, bdspac ) + maxwrk = 2_${ik}$*m*m + wrkbl + minwrk = max( 3_${ik}$*m + n, bdspac ) else if( wntvs .and. wntuas ) then ! path 6t(n much larger than m, jobu='s' or 'a', ! jobvt='s') wrkbl = m + lwork_qgelqf wrkbl = max( wrkbl, m + lwork_qorglq_m ) - wrkbl = max( wrkbl, 3*m + lwork_qgebrd ) - wrkbl = max( wrkbl, 3*m + lwork_qorgbr_p ) - wrkbl = max( wrkbl, 3*m + lwork_qorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qorgbr_q ) wrkbl = max( wrkbl, bdspac ) maxwrk = m*m + wrkbl - minwrk = max( 3*m + n, bdspac ) + minwrk = max( 3_${ik}$*m + n, bdspac ) else if( wntva .and. wntun ) then ! path 7t(n much larger than m, jobu='n', jobvt='a') wrkbl = m + lwork_qgelqf wrkbl = max( wrkbl, m + lwork_qorglq_n ) - wrkbl = max( wrkbl, 3*m + lwork_qgebrd ) - wrkbl = max( wrkbl, 3*m + lwork_qorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qorgbr_p ) wrkbl = max( wrkbl, bdspac ) maxwrk = m*m + wrkbl - minwrk = max( 3*m + n, bdspac ) + minwrk = max( 3_${ik}$*m + n, bdspac ) else if( wntva .and. wntuo ) then ! path 8t(n much larger than m, jobu='o', jobvt='a') wrkbl = m + lwork_qgelqf wrkbl = max( wrkbl, m + lwork_qorglq_n ) - wrkbl = max( wrkbl, 3*m + lwork_qgebrd ) - wrkbl = max( wrkbl, 3*m + lwork_qorgbr_p ) - wrkbl = max( wrkbl, 3*m + lwork_qorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qorgbr_q ) wrkbl = max( wrkbl, bdspac ) - maxwrk = 2*m*m + wrkbl - minwrk = max( 3*m + n, bdspac ) + maxwrk = 2_${ik}$*m*m + wrkbl + minwrk = max( 3_${ik}$*m + n, bdspac ) else if( wntva .and. wntuas ) then ! path 9t(n much larger than m, jobu='s' or 'a', ! jobvt='a') wrkbl = m + lwork_qgelqf wrkbl = max( wrkbl, m + lwork_qorglq_n ) - wrkbl = max( wrkbl, 3*m + lwork_qgebrd ) - wrkbl = max( wrkbl, 3*m + lwork_qorgbr_p ) - wrkbl = max( wrkbl, 3*m + lwork_qorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_qorgbr_q ) wrkbl = max( wrkbl, bdspac ) maxwrk = m*m + wrkbl - minwrk = max( 3*m + n, bdspac ) + minwrk = max( 3_${ik}$*m + n, bdspac ) end if else ! path 10t(n greater than m, but not much larger) - call stdlib_${ri}$gebrd( m, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) + call stdlib${ii}$_${ri}$gebrd( m, n, a, lda, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) - lwork_qgebrd = int( dum(1),KIND=ilp) - maxwrk = 3*m + lwork_qgebrd + lwork_qgebrd = int( dum(1_${ik}$),KIND=${ik}$) + maxwrk = 3_${ik}$*m + lwork_qgebrd if( wntvs .or. wntvo ) then - ! compute space needed for stdlib_${ri}$orgbr p - call stdlib_${ri}$orgbr( 'P', m, n, m, a, n, dum(1),dum(1), -1, ierr ) - lwork_qorgbr_p = int( dum(1),KIND=ilp) - maxwrk = max( maxwrk, 3*m + lwork_qorgbr_p ) + ! compute space needed for stdlib${ii}$_${ri}$orgbr p + call stdlib${ii}$_${ri}$orgbr( 'P', m, n, m, a, n, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_qorgbr_p = int( dum(1_${ik}$),KIND=${ik}$) + maxwrk = max( maxwrk, 3_${ik}$*m + lwork_qorgbr_p ) end if if( wntva ) then - call stdlib_${ri}$orgbr( 'P', n, n, m, a, n, dum(1),dum(1), -1, ierr ) - lwork_qorgbr_p = int( dum(1),KIND=ilp) - maxwrk = max( maxwrk, 3*m + lwork_qorgbr_p ) + call stdlib${ii}$_${ri}$orgbr( 'P', n, n, m, a, n, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_qorgbr_p = int( dum(1_${ik}$),KIND=${ik}$) + maxwrk = max( maxwrk, 3_${ik}$*m + lwork_qorgbr_p ) end if if( .not.wntun ) then - maxwrk = max( maxwrk, 3*m + lwork_qorgbr_q ) + maxwrk = max( maxwrk, 3_${ik}$*m + lwork_qorgbr_q ) end if maxwrk = max( maxwrk, bdspac ) - minwrk = max( 3*m + n, bdspac ) + minwrk = max( 3_${ik}$*m + n, bdspac ) end if end if maxwrk = max( maxwrk, minwrk ) - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk if( lworkzero .and. anrmbignum ) then - iscl = 1 - call stdlib_${ri}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, ierr ) + iscl = 1_${ik}$ + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, ierr ) end if if( m>=n ) then ! a has at least as many rows as columns. if a has sufficiently @@ -11507,29 +11505,29 @@ module stdlib_linalg_lapack_${ri}$ if( wntun ) then ! path 1 (m much larger than n, jobu='n') ! no left singular vectors to be computed - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & ierr ) ! zero out below r - if( n > 1 ) then - call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero, a( 2, 1 ),lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_${ri}$laset( 'L', n-1, n-1, zero, zero, a( 2_${ik}$, 1_${ik}$ ),lda ) end if - ie = 1 + ie = 1_${ik}$ itauq = ie + n itaup = itauq + n iwork = itaup + n ! bidiagonalize r in a ! (workspace: need 4*n, prefer 3*n + 2*n*nb) - call stdlib_${ri}$gebrd( n, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_${ri}$gebrd( n, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,ierr ) - ncvt = 0 + ncvt = 0_${ik}$ if( wntvo .or. wntvas ) then ! if right singular vectors desired, generate p'. ! (workspace: need 4*n-1, prefer 3*n + (n-1)*nb) - call stdlib_${ri}$orgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & + call stdlib${ii}$_${ri}$orgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) ncvt = n end if @@ -11537,17 +11535,17 @@ module stdlib_linalg_lapack_${ri}$ ! perform bidiagonal qr iteration, computing right ! singular vectors of a in a if desired ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'U', n, ncvt, 0, 0, s, work( ie ), a, lda,dum, 1, dum, 1, & + call stdlib${ii}$_${ri}$bdsqr( 'U', n, ncvt, 0_${ik}$, 0_${ik}$, s, work( ie ), a, lda,dum, 1_${ik}$, dum, 1_${ik}$, & work( iwork ), info ) ! if right singular vectors desired in vt, copy them there - if( wntvas )call stdlib_${ri}$lacpy( 'F', n, n, a, lda, vt, ldvt ) + if( wntvas )call stdlib${ii}$_${ri}$lacpy( 'F', n, n, a, lda, vt, ldvt ) else if( wntuo .and. wntvn ) then ! path 2 (m much larger than n, jobu='o', jobvt='n') ! n left singular vectors to be overwritten on a and ! no right singular vectors to be computed - if( lwork>=n*n+max( 4*n, bdspac ) ) then + if( lwork>=n*n+max( 4_${ik}$*n, bdspac ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=max( wrkbl, lda*n + n ) + lda*n ) then ! work(iu) is lda by n, work(ir) is lda by n ldwrku = lda @@ -11565,15 +11563,15 @@ module stdlib_linalg_lapack_${ri}$ iwork = itau + n ! compute a=q*r ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy r to work(ir) and zero out below it - call stdlib_${ri}$lacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) - call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero, work( ir+1 ),ldwrkr ) + call stdlib${ii}$_${ri}$lacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) + call stdlib${ii}$_${ri}$laset( 'L', n-1, n-1, zero, zero, work( ir+1 ),ldwrkr ) ! generate q in a ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_${ri}$orgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -11581,57 +11579,57 @@ module stdlib_linalg_lapack_${ri}$ iwork = itaup + n ! bidiagonalize r in work(ir) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + 2*n*nb) - call stdlib_${ri}$gebrd( n, n, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & + call stdlib${ii}$_${ri}$gebrd( n, n, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & work( itaup ),work( iwork ), lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing r ! (workspace: need n*n + 4*n, prefer n*n + 3*n + n*nb) - call stdlib_${ri}$orgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & + call stdlib${ii}$_${ri}$orgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) ! (workspace: need n*n + bdspac) - call stdlib_${ri}$bdsqr( 'U', n, 0, n, 0, s, work( ie ), dum, 1,work( ir ), & - ldwrkr, dum, 1,work( iwork ), info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', n, 0_${ik}$, n, 0_${ik}$, s, work( ie ), dum, 1_${ik}$,work( ir ), & + ldwrkr, dum, 1_${ik}$,work( iwork ), info ) iu = ie + n ! multiply q in a by left singular vectors of r in ! work(ir), storing result in work(iu) and copying to a ! (workspace: need n*n + 2*n, prefer n*n + m*n + n) do i = 1, m, ldwrku chunk = min( m-i+1, ldwrku ) - call stdlib_${ri}$gemm( 'N', 'N', chunk, n, n, one, a( i, 1 ),lda, work( ir )& + call stdlib${ii}$_${ri}$gemm( 'N', 'N', chunk, n, n, one, a( i, 1_${ik}$ ),lda, work( ir )& , ldwrkr, zero,work( iu ), ldwrku ) - call stdlib_${ri}$lacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) + call stdlib${ii}$_${ri}$lacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1_${ik}$ ), lda ) end do else ! insufficient workspace for a fast algorithm - ie = 1 + ie = 1_${ik}$ itauq = ie + n itaup = itauq + n iwork = itaup + n ! bidiagonalize a ! (workspace: need 3*n + m, prefer 3*n + (m + n)*nb) - call stdlib_${ri}$gebrd( m, n, a, lda, s, work( ie ),work( itauq ), work( itaup & + call stdlib${ii}$_${ri}$gebrd( m, n, a, lda, s, work( ie ),work( itauq ), work( itaup & ),work( iwork ), lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing a ! (workspace: need 4*n, prefer 3*n + n*nb) - call stdlib_${ri}$orgbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), & + call stdlib${ii}$_${ri}$orgbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in a ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'U', n, 0, m, 0, s, work( ie ), dum, 1,a, lda, dum, 1, & + call stdlib${ii}$_${ri}$bdsqr( 'U', n, 0_${ik}$, m, 0_${ik}$, s, work( ie ), dum, 1_${ik}$,a, lda, dum, 1_${ik}$, & work( iwork ), info ) end if else if( wntuo .and. wntvas ) then ! path 3 (m much larger than n, jobu='o', jobvt='s' or 'a') ! n left singular vectors to be overwritten on a and ! n right singular vectors to be computed in vt - if( lwork>=n*n+max( 4*n, bdspac ) ) then + if( lwork>=n*n+max( 4_${ik}$*n, bdspac ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=max( wrkbl, lda*n + n ) + lda*n ) then ! work(iu) is lda by n and work(ir) is lda by n ldwrku = lda @@ -11649,15 +11647,15 @@ module stdlib_linalg_lapack_${ri}$ iwork = itau + n ! compute a=q*r ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy r to vt, zeroing out below it - call stdlib_${ri}$lacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,vt( 2, 1 ), ldvt ) + call stdlib${ii}$_${ri}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1_${ik}$ )call stdlib${ii}$_${ri}$laset( 'L', n-1, n-1, zero, zero,vt( 2_${ik}$, 1_${ik}$ ), ldvt ) ! generate q in a ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_${ri}$orgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -11665,50 +11663,50 @@ module stdlib_linalg_lapack_${ri}$ iwork = itaup + n ! bidiagonalize r in vt, copying result to work(ir) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + 2*n*nb) - call stdlib_${ri}$gebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_${ri}$gebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'L', n, n, vt, ldvt, work( ir ), ldwrkr ) + call stdlib${ii}$_${ri}$lacpy( 'L', n, n, vt, ldvt, work( ir ), ldwrkr ) ! generate left vectors bidiagonalizing r in work(ir) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + n*nb) - call stdlib_${ri}$orgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & + call stdlib${ii}$_${ri}$orgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing r in vt ! (workspace: need n*n + 4*n-1, prefer n*n + 3*n + (n-1)*nb) - call stdlib_${ri}$orgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib${ii}$_${ri}$orgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) and computing right ! singular vectors of r in vt ! (workspace: need n*n + bdspac) - call stdlib_${ri}$bdsqr( 'U', n, n, n, 0, s, work( ie ), vt, ldvt,work( ir ), & - ldwrkr, dum, 1,work( iwork ), info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', n, n, n, 0_${ik}$, s, work( ie ), vt, ldvt,work( ir ), & + ldwrkr, dum, 1_${ik}$,work( iwork ), info ) iu = ie + n ! multiply q in a by left singular vectors of r in ! work(ir), storing result in work(iu) and copying to a ! (workspace: need n*n + 2*n, prefer n*n + m*n + n) do i = 1, m, ldwrku chunk = min( m-i+1, ldwrku ) - call stdlib_${ri}$gemm( 'N', 'N', chunk, n, n, one, a( i, 1 ),lda, work( ir )& + call stdlib${ii}$_${ri}$gemm( 'N', 'N', chunk, n, n, one, a( i, 1_${ik}$ ),lda, work( ir )& , ldwrkr, zero,work( iu ), ldwrku ) - call stdlib_${ri}$lacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) + call stdlib${ii}$_${ri}$lacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1_${ik}$ ), lda ) end do else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy r to vt, zeroing out below it - call stdlib_${ri}$lacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,vt( 2, 1 ), ldvt ) + call stdlib${ii}$_${ri}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1_${ik}$ )call stdlib${ii}$_${ri}$laset( 'L', n-1, n-1, zero, zero,vt( 2_${ik}$, 1_${ik}$ ), ldvt ) ! generate q in a ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_${ri}$orgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -11716,32 +11714,32 @@ module stdlib_linalg_lapack_${ri}$ iwork = itaup + n ! bidiagonalize r in vt ! (workspace: need 4*n, prefer 3*n + 2*n*nb) - call stdlib_${ri}$gebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_${ri}$gebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in a by left vectors bidiagonalizing r ! (workspace: need 3*n + m, prefer 3*n + m*nb) - call stdlib_${ri}$ormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), a, lda,& + call stdlib${ii}$_${ri}$ormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), a, lda,& work( iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing r in vt ! (workspace: need 4*n-1, prefer 3*n + (n-1)*nb) - call stdlib_${ri}$orgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib${ii}$_${ri}$orgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in a and computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'U', n, n, m, 0, s, work( ie ), vt, ldvt,a, lda, dum, & - 1, work( iwork ), info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', n, n, m, 0_${ik}$, s, work( ie ), vt, ldvt,a, lda, dum, & + 1_${ik}$, work( iwork ), info ) end if else if( wntus ) then if( wntvn ) then ! path 4 (m much larger than n, jobu='s', jobvt='n') ! n left singular vectors to be computed in u and ! no right singular vectors to be computed - if( lwork>=n*n+max( 4*n, bdspac ) ) then + if( lwork>=n*n+max( 4_${ik}$*n, bdspac ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=wrkbl+lda*n ) then ! work(ir) is lda by n ldwrkr = lda @@ -11753,15 +11751,15 @@ module stdlib_linalg_lapack_${ri}$ iwork = itau + n ! compute a=q*r ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(ir), zeroing out below it - call stdlib_${ri}$lacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) - call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,work( ir+1 ), ldwrkr ) + call stdlib${ii}$_${ri}$lacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) + call stdlib${ii}$_${ri}$laset( 'L', n-1, n-1, zero, zero,work( ir+1 ), ldwrkr ) ! generate q in a ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_${ri}$orgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -11769,67 +11767,67 @@ module stdlib_linalg_lapack_${ri}$ iwork = itaup + n ! bidiagonalize r in work(ir) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + 2*n*nb) - call stdlib_${ri}$gebrd( n, n, work( ir ), ldwrkr, s,work( ie ), work( itauq & + call stdlib${ii}$_${ri}$gebrd( n, n, work( ir ), ldwrkr, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing r in work(ir) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + n*nb) - call stdlib_${ri}$orgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_${ri}$orgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) ! (workspace: need n*n + bdspac) - call stdlib_${ri}$bdsqr( 'U', n, 0, n, 0, s, work( ie ), dum,1, work( ir ), & - ldwrkr, dum, 1,work( iwork ), info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', n, 0_${ik}$, n, 0_${ik}$, s, work( ie ), dum,1_${ik}$, work( ir ), & + ldwrkr, dum, 1_${ik}$,work( iwork ), info ) ! multiply q in a by left singular vectors of r in ! work(ir), storing result in u ! (workspace: need n*n) - call stdlib_${ri}$gemm( 'N', 'N', m, n, n, one, a, lda,work( ir ), ldwrkr, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', m, n, n, one, a, lda,work( ir ), ldwrkr, & zero, u, ldu ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_${ri}$orgqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orgqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! zero out below r in a - if( n > 1 ) then - call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,a( 2, 1 ), lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_${ri}$laset( 'L', n-1, n-1, zero, zero,a( 2_${ik}$, 1_${ik}$ ), lda ) end if ! bidiagonalize r in a ! (workspace: need 4*n, prefer 3*n + 2*n*nb) - call stdlib_${ri}$gebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_${ri}$gebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left vectors bidiagonalizing r ! (workspace: need 3*n + m, prefer 3*n + m*nb) - call stdlib_${ri}$ormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib${ii}$_${ri}$ormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'U', n, 0, m, 0, s, work( ie ), dum,1, u, ldu, dum, & - 1, work( iwork ),info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', n, 0_${ik}$, m, 0_${ik}$, s, work( ie ), dum,1_${ik}$, u, ldu, dum, & + 1_${ik}$, work( iwork ),info ) end if else if( wntvo ) then ! path 5 (m much larger than n, jobu='s', jobvt='o') ! n left singular vectors to be computed in u and ! n right singular vectors to be overwritten on a - if( lwork>=2*n*n+max( 4*n, bdspac ) ) then + if( lwork>=2_${ik}$*n*n+max( 4_${ik}$*n, bdspac ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+2*lda*n ) then ! work(iu) is lda by n and work(ir) is lda by n ldwrku = lda @@ -11850,15 +11848,15 @@ module stdlib_linalg_lapack_${ri}$ iwork = itau + n ! compute a=q*r ! (workspace: need 2*n*n + 2*n, prefer 2*n*n + n + n*nb) - call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_${ri}$lacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) + call stdlib${ii}$_${ri}$lacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_${ri}$laset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) ! generate q in a ! (workspace: need 2*n*n + 2*n, prefer 2*n*n + n + n*nb) - call stdlib_${ri}$orgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -11868,84 +11866,84 @@ module stdlib_linalg_lapack_${ri}$ ! work(ir) ! (workspace: need 2*n*n + 4*n, ! prefer 2*n*n+3*n+2*n*nb) - call stdlib_${ri}$gebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib${ii}$_${ri}$gebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib${ii}$_${ri}$lacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate left bidiagonalizing vectors in work(iu) ! (workspace: need 2*n*n + 4*n, prefer 2*n*n + 3*n + n*nb) - call stdlib_${ri}$orgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib${ii}$_${ri}$orgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in work(ir) ! (workspace: need 2*n*n + 4*n-1, ! prefer 2*n*n+3*n+(n-1)*nb) - call stdlib_${ri}$orgbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_${ri}$orgbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(iu) and computing ! right singular vectors of r in work(ir) ! (workspace: need 2*n*n + bdspac) - call stdlib_${ri}$bdsqr( 'U', n, n, n, 0, s, work( ie ),work( ir ), ldwrkr, & - work( iu ),ldwrku, dum, 1, work( iwork ), info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', n, n, n, 0_${ik}$, s, work( ie ),work( ir ), ldwrkr, & + work( iu ),ldwrku, dum, 1_${ik}$, work( iwork ), info ) ! multiply q in a by left singular vectors of r in ! work(iu), storing result in u ! (workspace: need n*n) - call stdlib_${ri}$gemm( 'N', 'N', m, n, n, one, a, lda,work( iu ), ldwrku, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', m, n, n, one, a, lda,work( iu ), ldwrku, & zero, u, ldu ) ! copy right singular vectors of r to a ! (workspace: need n*n) - call stdlib_${ri}$lacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) + call stdlib${ii}$_${ri}$lacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_${ri}$orgqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orgqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! zero out below r in a - if( n > 1 ) then - call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,a( 2, 1 ), lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_${ri}$laset( 'L', n-1, n-1, zero, zero,a( 2_${ik}$, 1_${ik}$ ), lda ) end if ! bidiagonalize r in a ! (workspace: need 4*n, prefer 3*n + 2*n*nb) - call stdlib_${ri}$gebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_${ri}$gebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left vectors bidiagonalizing r ! (workspace: need 3*n + m, prefer 3*n + m*nb) - call stdlib_${ri}$ormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib${ii}$_${ri}$ormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing r in a ! (workspace: need 4*n-1, prefer 3*n + (n-1)*nb) - call stdlib_${ri}$orgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & + call stdlib${ii}$_${ri}$orgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in a ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'U', n, n, m, 0, s, work( ie ), a,lda, u, ldu, dum, & - 1, work( iwork ),info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', n, n, m, 0_${ik}$, s, work( ie ), a,lda, u, ldu, dum, & + 1_${ik}$, work( iwork ),info ) end if else if( wntvas ) then ! path 6 (m much larger than n, jobu='s', jobvt='s' ! or 'a') ! n left singular vectors to be computed in u and ! n right singular vectors to be computed in vt - if( lwork>=n*n+max( 4*n, bdspac ) ) then + if( lwork>=n*n+max( 4_${ik}$*n, bdspac ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+lda*n ) then ! work(iu) is lda by n ldwrku = lda @@ -11957,15 +11955,15 @@ module stdlib_linalg_lapack_${ri}$ iwork = itau + n ! compute a=q*r ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_${ri}$lacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) + call stdlib${ii}$_${ri}$lacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_${ri}$laset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) ! generate q in a ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_${ri}$orgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -11973,46 +11971,46 @@ module stdlib_linalg_lapack_${ri}$ iwork = itaup + n ! bidiagonalize r in work(iu), copying result to vt ! (workspace: need n*n + 4*n, prefer n*n + 3*n + 2*n*nb) - call stdlib_${ri}$gebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib${ii}$_${ri}$gebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) + call stdlib${ii}$_${ri}$lacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) ! generate left bidiagonalizing vectors in work(iu) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + n*nb) - call stdlib_${ri}$orgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib${ii}$_${ri}$orgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (workspace: need n*n + 4*n-1, ! prefer n*n+3*n+(n-1)*nb) - call stdlib_${ri}$orgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib${ii}$_${ri}$orgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(iu) and computing ! right singular vectors of r in vt ! (workspace: need n*n + bdspac) - call stdlib_${ri}$bdsqr( 'U', n, n, n, 0, s, work( ie ), vt,ldvt, work( iu ),& - ldwrku, dum, 1,work( iwork ), info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', n, n, n, 0_${ik}$, s, work( ie ), vt,ldvt, work( iu ),& + ldwrku, dum, 1_${ik}$,work( iwork ), info ) ! multiply q in a by left singular vectors of r in ! work(iu), storing result in u ! (workspace: need n*n) - call stdlib_${ri}$gemm( 'N', 'N', m, n, n, one, a, lda,work( iu ), ldwrku, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', m, n, n, one, a, lda,work( iu ), ldwrku, & zero, u, ldu ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_${ri}$orgqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orgqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to vt, zeroing out below it - call stdlib_${ri}$lacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,vt( 2, 1 ), ldvt & + call stdlib${ii}$_${ri}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1_${ik}$ )call stdlib${ii}$_${ri}$laset( 'L', n-1, n-1, zero, zero,vt( 2_${ik}$, 1_${ik}$ ), ldvt & ) ie = itau itauq = ie + n @@ -12020,24 +12018,24 @@ module stdlib_linalg_lapack_${ri}$ iwork = itaup + n ! bidiagonalize r in vt ! (workspace: need 4*n, prefer 3*n + 2*n*nb) - call stdlib_${ri}$gebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_${ri}$gebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in vt ! (workspace: need 3*n + m, prefer 3*n + m*nb) - call stdlib_${ri}$ormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & + call stdlib${ii}$_${ri}$ormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (workspace: need 4*n-1, prefer 3*n + (n-1)*nb) - call stdlib_${ri}$orgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib${ii}$_${ri}$orgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'U', n, n, m, 0, s, work( ie ), vt,ldvt, u, ldu, & - dum, 1, work( iwork ),info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', n, n, m, 0_${ik}$, s, work( ie ), vt,ldvt, u, ldu, & + dum, 1_${ik}$, work( iwork ),info ) end if end if else if( wntua ) then @@ -12045,9 +12043,9 @@ module stdlib_linalg_lapack_${ri}$ ! path 7 (m much larger than n, jobu='a', jobvt='n') ! m left singular vectors to be computed in u and ! no right singular vectors to be computed - if( lwork>=n*n+max( n+m, 4*n, bdspac ) ) then + if( lwork>=n*n+max( n+m, 4_${ik}$*n, bdspac ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=wrkbl+lda*n ) then ! work(ir) is lda by n ldwrkr = lda @@ -12059,16 +12057,16 @@ module stdlib_linalg_lapack_${ri}$ iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) ! copy r to work(ir), zeroing out below it - call stdlib_${ri}$lacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) - call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,work( ir+1 ), ldwrkr ) + call stdlib${ii}$_${ri}$lacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) + call stdlib${ii}$_${ri}$laset( 'L', n-1, n-1, zero, zero,work( ir+1 ), ldwrkr ) ! generate q in u ! (workspace: need n*n + n + m, prefer n*n + n + m*nb) - call stdlib_${ri}$orgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -12076,70 +12074,70 @@ module stdlib_linalg_lapack_${ri}$ iwork = itaup + n ! bidiagonalize r in work(ir) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + 2*n*nb) - call stdlib_${ri}$gebrd( n, n, work( ir ), ldwrkr, s,work( ie ), work( itauq & + call stdlib${ii}$_${ri}$gebrd( n, n, work( ir ), ldwrkr, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in work(ir) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + n*nb) - call stdlib_${ri}$orgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_${ri}$orgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) ! (workspace: need n*n + bdspac) - call stdlib_${ri}$bdsqr( 'U', n, 0, n, 0, s, work( ie ), dum,1, work( ir ), & - ldwrkr, dum, 1,work( iwork ), info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', n, 0_${ik}$, n, 0_${ik}$, s, work( ie ), dum,1_${ik}$, work( ir ), & + ldwrkr, dum, 1_${ik}$,work( iwork ), info ) ! multiply q in u by left singular vectors of r in ! work(ir), storing result in a ! (workspace: need n*n) - call stdlib_${ri}$gemm( 'N', 'N', m, n, n, one, u, ldu,work( ir ), ldwrkr, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', m, n, n, one, u, ldu,work( ir ), ldwrkr, & zero, a, lda ) ! copy left singular vectors of a from a to u - call stdlib_${ri}$lacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ri}$lacpy( 'F', m, n, a, lda, u, ldu ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need n + m, prefer n + m*nb) - call stdlib_${ri}$orgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! zero out below r in a - if( n > 1 ) then - call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,a( 2, 1 ), lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_${ri}$laset( 'L', n-1, n-1, zero, zero,a( 2_${ik}$, 1_${ik}$ ), lda ) end if ! bidiagonalize r in a ! (workspace: need 4*n, prefer 3*n + 2*n*nb) - call stdlib_${ri}$gebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_${ri}$gebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in a ! (workspace: need 3*n + m, prefer 3*n + m*nb) - call stdlib_${ri}$ormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib${ii}$_${ri}$ormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'U', n, 0, m, 0, s, work( ie ), dum,1, u, ldu, dum, & - 1, work( iwork ),info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', n, 0_${ik}$, m, 0_${ik}$, s, work( ie ), dum,1_${ik}$, u, ldu, dum, & + 1_${ik}$, work( iwork ),info ) end if else if( wntvo ) then ! path 8 (m much larger than n, jobu='a', jobvt='o') ! m left singular vectors to be computed in u and ! n right singular vectors to be overwritten on a - if( lwork>=2*n*n+max( n+m, 4*n, bdspac ) ) then + if( lwork>=2_${ik}$*n*n+max( n+m, 4_${ik}$*n, bdspac ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+2*lda*n ) then ! work(iu) is lda by n and work(ir) is lda by n ldwrku = lda @@ -12160,16 +12158,16 @@ module stdlib_linalg_lapack_${ri}$ iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n*n + 2*n, prefer 2*n*n + n + n*nb) - call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need 2*n*n + n + m, prefer 2*n*n + n + m*nb) - call stdlib_${ri}$orgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_${ri}$lacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) + call stdlib${ii}$_${ri}$lacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_${ri}$laset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) ie = itau itauq = ie + n @@ -12179,86 +12177,86 @@ module stdlib_linalg_lapack_${ri}$ ! work(ir) ! (workspace: need 2*n*n + 4*n, ! prefer 2*n*n+3*n+2*n*nb) - call stdlib_${ri}$gebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib${ii}$_${ri}$gebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib${ii}$_${ri}$lacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate left bidiagonalizing vectors in work(iu) ! (workspace: need 2*n*n + 4*n, prefer 2*n*n + 3*n + n*nb) - call stdlib_${ri}$orgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib${ii}$_${ri}$orgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in work(ir) ! (workspace: need 2*n*n + 4*n-1, ! prefer 2*n*n+3*n+(n-1)*nb) - call stdlib_${ri}$orgbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_${ri}$orgbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(iu) and computing ! right singular vectors of r in work(ir) ! (workspace: need 2*n*n + bdspac) - call stdlib_${ri}$bdsqr( 'U', n, n, n, 0, s, work( ie ),work( ir ), ldwrkr, & - work( iu ),ldwrku, dum, 1, work( iwork ), info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', n, n, n, 0_${ik}$, s, work( ie ),work( ir ), ldwrkr, & + work( iu ),ldwrku, dum, 1_${ik}$, work( iwork ), info ) ! multiply q in u by left singular vectors of r in ! work(iu), storing result in a ! (workspace: need n*n) - call stdlib_${ri}$gemm( 'N', 'N', m, n, n, one, u, ldu,work( iu ), ldwrku, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', m, n, n, one, u, ldu,work( iu ), ldwrku, & zero, a, lda ) ! copy left singular vectors of a from a to u - call stdlib_${ri}$lacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ri}$lacpy( 'F', m, n, a, lda, u, ldu ) ! copy right singular vectors of r from work(ir) to a - call stdlib_${ri}$lacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) + call stdlib${ii}$_${ri}$lacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need n + m, prefer n + m*nb) - call stdlib_${ri}$orgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! zero out below r in a - if( n > 1 ) then - call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,a( 2, 1 ), lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_${ri}$laset( 'L', n-1, n-1, zero, zero,a( 2_${ik}$, 1_${ik}$ ), lda ) end if ! bidiagonalize r in a ! (workspace: need 4*n, prefer 3*n + 2*n*nb) - call stdlib_${ri}$gebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_${ri}$gebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in a ! (workspace: need 3*n + m, prefer 3*n + m*nb) - call stdlib_${ri}$ormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib${ii}$_${ri}$ormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in a ! (workspace: need 4*n-1, prefer 3*n + (n-1)*nb) - call stdlib_${ri}$orgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & + call stdlib${ii}$_${ri}$orgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in a ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'U', n, n, m, 0, s, work( ie ), a,lda, u, ldu, dum, & - 1, work( iwork ),info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', n, n, m, 0_${ik}$, s, work( ie ), a,lda, u, ldu, dum, & + 1_${ik}$, work( iwork ),info ) end if else if( wntvas ) then ! path 9 (m much larger than n, jobu='a', jobvt='s' ! or 'a') ! m left singular vectors to be computed in u and ! n right singular vectors to be computed in vt - if( lwork>=n*n+max( n+m, 4*n, bdspac ) ) then + if( lwork>=n*n+max( n+m, 4_${ik}$*n, bdspac ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+lda*n ) then ! work(iu) is lda by n ldwrku = lda @@ -12270,16 +12268,16 @@ module stdlib_linalg_lapack_${ri}$ iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need n*n + 2*n, prefer n*n + n + n*nb) - call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need n*n + n + m, prefer n*n + n + m*nb) - call stdlib_${ri}$orgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_${ri}$lacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) + call stdlib${ii}$_${ri}$lacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_${ri}$laset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) ie = itau itauq = ie + n @@ -12287,48 +12285,48 @@ module stdlib_linalg_lapack_${ri}$ iwork = itaup + n ! bidiagonalize r in work(iu), copying result to vt ! (workspace: need n*n + 4*n, prefer n*n + 3*n + 2*n*nb) - call stdlib_${ri}$gebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib${ii}$_${ri}$gebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) + call stdlib${ii}$_${ri}$lacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) ! generate left bidiagonalizing vectors in work(iu) ! (workspace: need n*n + 4*n, prefer n*n + 3*n + n*nb) - call stdlib_${ri}$orgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib${ii}$_${ri}$orgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (workspace: need n*n + 4*n-1, ! prefer n*n+3*n+(n-1)*nb) - call stdlib_${ri}$orgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib${ii}$_${ri}$orgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(iu) and computing ! right singular vectors of r in vt ! (workspace: need n*n + bdspac) - call stdlib_${ri}$bdsqr( 'U', n, n, n, 0, s, work( ie ), vt,ldvt, work( iu ),& - ldwrku, dum, 1,work( iwork ), info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', n, n, n, 0_${ik}$, s, work( ie ), vt,ldvt, work( iu ),& + ldwrku, dum, 1_${ik}$,work( iwork ), info ) ! multiply q in u by left singular vectors of r in ! work(iu), storing result in a ! (workspace: need n*n) - call stdlib_${ri}$gemm( 'N', 'N', m, n, n, one, u, ldu,work( iu ), ldwrku, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', m, n, n, one, u, ldu,work( iu ), ldwrku, & zero, a, lda ) ! copy left singular vectors of a from a to u - call stdlib_${ri}$lacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ri}$lacpy( 'F', m, n, a, lda, u, ldu ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n, prefer n + n*nb) - call stdlib_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need n + m, prefer n + m*nb) - call stdlib_${ri}$orgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r from a to vt, zeroing out below it - call stdlib_${ri}$lacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_${ri}$laset( 'L', n-1, n-1, zero, zero,vt( 2, 1 ), ldvt & + call stdlib${ii}$_${ri}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1_${ik}$ )call stdlib${ii}$_${ri}$laset( 'L', n-1, n-1, zero, zero,vt( 2_${ik}$, 1_${ik}$ ), ldvt & ) ie = itau itauq = ie + n @@ -12336,24 +12334,24 @@ module stdlib_linalg_lapack_${ri}$ iwork = itaup + n ! bidiagonalize r in vt ! (workspace: need 4*n, prefer 3*n + 2*n*nb) - call stdlib_${ri}$gebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_${ri}$gebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in vt ! (workspace: need 3*n + m, prefer 3*n + m*nb) - call stdlib_${ri}$ormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & + call stdlib${ii}$_${ri}$ormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (workspace: need 4*n-1, prefer 3*n + (n-1)*nb) - call stdlib_${ri}$orgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib${ii}$_${ri}$orgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'U', n, n, m, 0, s, work( ie ), vt,ldvt, u, ldu, & - dum, 1, work( iwork ),info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', n, n, m, 0_${ik}$, s, work( ie ), vt,ldvt, u, ldu, & + dum, 1_${ik}$, work( iwork ),info ) end if end if end if @@ -12361,72 +12359,72 @@ module stdlib_linalg_lapack_${ri}$ ! m < mnthr ! path 10 (m at least n, but not much larger) ! reduce to bidiagonal form without qr decomposition - ie = 1 + ie = 1_${ik}$ itauq = ie + n itaup = itauq + n iwork = itaup + n ! bidiagonalize a ! (workspace: need 3*n + m, prefer 3*n + (m + n)*nb) - call stdlib_${ri}$gebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_${ri}$gebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,ierr ) if( wntuas ) then ! if left singular vectors desired in u, copy result to u ! and generate left bidiagonalizing vectors in u ! (workspace: need 3*n + ncu, prefer 3*n + ncu*nb) - call stdlib_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ri}$lacpy( 'L', m, n, a, lda, u, ldu ) if( wntus )ncu = n if( wntua )ncu = m - call stdlib_${ri}$orgbr( 'Q', m, ncu, n, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_${ri}$orgbr( 'Q', m, ncu, n, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) end if if( wntvas ) then ! if right singular vectors desired in vt, copy result to ! vt and generate right bidiagonalizing vectors in vt ! (workspace: need 4*n-1, prefer 3*n + (n-1)*nb) - call stdlib_${ri}$lacpy( 'U', n, n, a, lda, vt, ldvt ) - call stdlib_${ri}$orgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib${ii}$_${ri}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ri}$orgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) end if if( wntuo ) then ! if left singular vectors desired in a, generate left ! bidiagonalizing vectors in a ! (workspace: need 4*n, prefer 3*n + n*nb) - call stdlib_${ri}$orgbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orgbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), lwork-& iwork+1, ierr ) end if if( wntvo ) then ! if right singular vectors desired in a, generate right ! bidiagonalizing vectors in a ! (workspace: need 4*n-1, prefer 3*n + (n-1)*nb) - call stdlib_${ri}$orgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-& iwork+1, ierr ) end if iwork = ie + n if( wntuas .or. wntuo )nru = m - if( wntun )nru = 0 + if( wntun )nru = 0_${ik}$ if( wntvas .or. wntvo )ncvt = n - if( wntvn )ncvt = 0 + if( wntvn )ncvt = 0_${ik}$ if( ( .not.wntuo ) .and. ( .not.wntvo ) ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in vt ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'U', n, ncvt, nru, 0, s, work( ie ), vt,ldvt, u, ldu, dum,& - 1, work( iwork ), info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', n, ncvt, nru, 0_${ik}$, s, work( ie ), vt,ldvt, u, ldu, dum,& + 1_${ik}$, work( iwork ), info ) else if( ( .not.wntuo ) .and. wntvo ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in a ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'U', n, ncvt, nru, 0, s, work( ie ), a, lda,u, ldu, dum, & - 1, work( iwork ), info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', n, ncvt, nru, 0_${ik}$, s, work( ie ), a, lda,u, ldu, dum, & + 1_${ik}$, work( iwork ), info ) else ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in a and computing right singular ! vectors in vt ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'U', n, ncvt, nru, 0, s, work( ie ), vt,ldvt, a, lda, dum,& - 1, work( iwork ), info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', n, ncvt, nru, 0_${ik}$, s, work( ie ), vt,ldvt, a, lda, dum,& + 1_${ik}$, work( iwork ), info ) end if end if else @@ -12437,45 +12435,45 @@ module stdlib_linalg_lapack_${ri}$ if( wntvn ) then ! path 1t(n much larger than m, jobvt='n') ! no right singular vectors to be computed - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & ierr ) ! zero out above l - if (m>1) call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, a( 1, 2 ), lda ) - ie = 1 + if (m>1_${ik}$) call stdlib${ii}$_${ri}$laset( 'U', m-1, m-1, zero, zero, a( 1_${ik}$, 2_${ik}$ ), lda ) + ie = 1_${ik}$ itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize l in a ! (workspace: need 4*m, prefer 3*m + 2*m*nb) - call stdlib_${ri}$gebrd( m, m, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_${ri}$gebrd( m, m, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,ierr ) if( wntuo .or. wntuas ) then ! if left singular vectors desired, generate q ! (workspace: need 4*m, prefer 3*m + m*nb) - call stdlib_${ri}$orgbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & + call stdlib${ii}$_${ri}$orgbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) end if iwork = ie + m - nru = 0 + nru = 0_${ik}$ if( wntuo .or. wntuas )nru = m ! perform bidiagonal qr iteration, computing left singular ! vectors of a in a if desired ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'U', m, 0, nru, 0, s, work( ie ), dum, 1, a,lda, dum, 1, & + call stdlib${ii}$_${ri}$bdsqr( 'U', m, 0_${ik}$, nru, 0_${ik}$, s, work( ie ), dum, 1_${ik}$, a,lda, dum, 1_${ik}$, & work( iwork ), info ) ! if left singular vectors desired in u, copy them there - if( wntuas )call stdlib_${ri}$lacpy( 'F', m, m, a, lda, u, ldu ) + if( wntuas )call stdlib${ii}$_${ri}$lacpy( 'F', m, m, a, lda, u, ldu ) else if( wntvo .and. wntun ) then ! path 2t(n much larger than m, jobu='n', jobvt='o') ! m right singular vectors to be overwritten on a and ! no left singular vectors to be computed - if( lwork>=m*m+max( 4*m, bdspac ) ) then + if( lwork>=m*m+max( 4_${ik}$*m, bdspac ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=max( wrkbl, lda*n + m ) + lda*m ) then ! work(iu) is lda by n and work(ir) is lda by m ldwrku = lda @@ -12496,15 +12494,15 @@ module stdlib_linalg_lapack_${ri}$ iwork = itau + m ! compute a=l*q ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy l to work(ir) and zero out above it - call stdlib_${ri}$lacpy( 'L', m, m, a, lda, work( ir ), ldwrkr ) - call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero,work( ir+ldwrkr ), ldwrkr ) + call stdlib${ii}$_${ri}$lacpy( 'L', m, m, a, lda, work( ir ), ldwrkr ) + call stdlib${ii}$_${ri}$laset( 'U', m-1, m-1, zero, zero,work( ir+ldwrkr ), ldwrkr ) ! generate q in a ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_${ri}$orglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + m @@ -12512,57 +12510,57 @@ module stdlib_linalg_lapack_${ri}$ iwork = itaup + m ! bidiagonalize l in work(ir) ! (workspace: need m*m + 4*m, prefer m*m + 3*m + 2*m*nb) - call stdlib_${ri}$gebrd( m, m, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & + call stdlib${ii}$_${ri}$gebrd( m, m, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & work( itaup ),work( iwork ), lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing l ! (workspace: need m*m + 4*m-1, prefer m*m + 3*m + (m-1)*nb) - call stdlib_${ri}$orgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & + call stdlib${ii}$_${ri}$orgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & iwork ),lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of l in work(ir) ! (workspace: need m*m + bdspac) - call stdlib_${ri}$bdsqr( 'U', m, m, 0, 0, s, work( ie ),work( ir ), ldwrkr, dum,& - 1, dum, 1,work( iwork ), info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', m, m, 0_${ik}$, 0_${ik}$, s, work( ie ),work( ir ), ldwrkr, dum,& + 1_${ik}$, dum, 1_${ik}$,work( iwork ), info ) iu = ie + m ! multiply right singular vectors of l in work(ir) by q ! in a, storing result in work(iu) and copying to a ! (workspace: need m*m + 2*m, prefer m*m + m*n + m) do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_${ri}$gemm( 'N', 'N', m, blk, m, one, work( ir ),ldwrkr, a( 1, i & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', m, blk, m, one, work( ir ),ldwrkr, a( 1_${ik}$, i & ), lda, zero,work( iu ), ldwrku ) - call stdlib_${ri}$lacpy( 'F', m, blk, work( iu ), ldwrku,a( 1, i ), lda ) + call stdlib${ii}$_${ri}$lacpy( 'F', m, blk, work( iu ), ldwrku,a( 1_${ik}$, i ), lda ) end do else ! insufficient workspace for a fast algorithm - ie = 1 + ie = 1_${ik}$ itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize a ! (workspace: need 3*m + n, prefer 3*m + (m + n)*nb) - call stdlib_${ri}$gebrd( m, n, a, lda, s, work( ie ),work( itauq ), work( itaup & + call stdlib${ii}$_${ri}$gebrd( m, n, a, lda, s, work( ie ),work( itauq ), work( itaup & ),work( iwork ), lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing a ! (workspace: need 4*m, prefer 3*m + m*nb) - call stdlib_${ri}$orgbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), & + call stdlib${ii}$_${ri}$orgbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of a in a ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'L', m, n, 0, 0, s, work( ie ), a, lda,dum, 1, dum, 1, & + call stdlib${ii}$_${ri}$bdsqr( 'L', m, n, 0_${ik}$, 0_${ik}$, s, work( ie ), a, lda,dum, 1_${ik}$, dum, 1_${ik}$, & work( iwork ), info ) end if else if( wntvo .and. wntuas ) then ! path 3t(n much larger than m, jobu='s' or 'a', jobvt='o') ! m right singular vectors to be overwritten on a and ! m left singular vectors to be computed in u - if( lwork>=m*m+max( 4*m, bdspac ) ) then + if( lwork>=m*m+max( 4_${ik}$*m, bdspac ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=max( wrkbl, lda*n + m ) + lda*m ) then ! work(iu) is lda by n and work(ir) is lda by m ldwrku = lda @@ -12583,14 +12581,14 @@ module stdlib_linalg_lapack_${ri}$ iwork = itau + m ! compute a=l*q ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy l to u, zeroing about above it - call stdlib_${ri}$lacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu ) + call stdlib${ii}$_${ri}$lacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1_${ik}$) call stdlib${ii}$_${ri}$laset( 'U', m-1, m-1, zero, zero, u( 1_${ik}$, 2_${ik}$ ),ldu ) ! generate q in a ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_${ri}$orglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + m @@ -12598,49 +12596,49 @@ module stdlib_linalg_lapack_${ri}$ iwork = itaup + m ! bidiagonalize l in u, copying result to work(ir) ! (workspace: need m*m + 4*m, prefer m*m + 3*m + 2*m*nb) - call stdlib_${ri}$gebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( itaup & + call stdlib${ii}$_${ri}$gebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( itaup & ),work( iwork ), lwork-iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'U', m, m, u, ldu, work( ir ), ldwrkr ) + call stdlib${ii}$_${ri}$lacpy( 'U', m, m, u, ldu, work( ir ), ldwrkr ) ! generate right vectors bidiagonalizing l in work(ir) ! (workspace: need m*m + 4*m-1, prefer m*m + 3*m + (m-1)*nb) - call stdlib_${ri}$orgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & + call stdlib${ii}$_${ri}$orgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & iwork ),lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing l in u ! (workspace: need m*m + 4*m, prefer m*m + 3*m + m*nb) - call stdlib_${ri}$orgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_${ri}$orgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of l in u, and computing right ! singular vectors of l in work(ir) ! (workspace: need m*m + bdspac) - call stdlib_${ri}$bdsqr( 'U', m, m, m, 0, s, work( ie ),work( ir ), ldwrkr, u, & - ldu, dum, 1,work( iwork ), info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', m, m, m, 0_${ik}$, s, work( ie ),work( ir ), ldwrkr, u, & + ldu, dum, 1_${ik}$,work( iwork ), info ) iu = ie + m ! multiply right singular vectors of l in work(ir) by q ! in a, storing result in work(iu) and copying to a ! (workspace: need m*m + 2*m, prefer m*m + m*n + m)) do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_${ri}$gemm( 'N', 'N', m, blk, m, one, work( ir ),ldwrkr, a( 1, i & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', m, blk, m, one, work( ir ),ldwrkr, a( 1_${ik}$, i & ), lda, zero,work( iu ), ldwrku ) - call stdlib_${ri}$lacpy( 'F', m, blk, work( iu ), ldwrku,a( 1, i ), lda ) + call stdlib${ii}$_${ri}$lacpy( 'F', m, blk, work( iu ), ldwrku,a( 1_${ik}$, i ), lda ) end do else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy l to u, zeroing out above it - call stdlib_${ri}$lacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu ) + call stdlib${ii}$_${ri}$lacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1_${ik}$) call stdlib${ii}$_${ri}$laset( 'U', m-1, m-1, zero, zero, u( 1_${ik}$, 2_${ik}$ ),ldu ) ! generate q in a ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_${ri}$orglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + m @@ -12648,22 +12646,22 @@ module stdlib_linalg_lapack_${ri}$ iwork = itaup + m ! bidiagonalize l in u ! (workspace: need 4*m, prefer 3*m + 2*m*nb) - call stdlib_${ri}$gebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( itaup & + call stdlib${ii}$_${ri}$gebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( itaup & ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right vectors bidiagonalizing l by q in a ! (workspace: need 3*m + n, prefer 3*m + n*nb) - call stdlib_${ri}$ormbr( 'P', 'L', 'T', m, n, m, u, ldu,work( itaup ), a, lda, & + call stdlib${ii}$_${ri}$ormbr( 'P', 'L', 'T', m, n, m, u, ldu,work( itaup ), a, lda, & work( iwork ),lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing l in u ! (workspace: need 4*m, prefer 3*m + m*nb) - call stdlib_${ri}$orgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_${ri}$orgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in a ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'U', m, n, m, 0, s, work( ie ), a, lda,u, ldu, dum, 1, & + call stdlib${ii}$_${ri}$bdsqr( 'U', m, n, m, 0_${ik}$, s, work( ie ), a, lda,u, ldu, dum, 1_${ik}$, & work( iwork ), info ) end if else if( wntvs ) then @@ -12671,9 +12669,9 @@ module stdlib_linalg_lapack_${ri}$ ! path 4t(n much larger than m, jobu='n', jobvt='s') ! m right singular vectors to be computed in vt and ! no left singular vectors to be computed - if( lwork>=m*m+max( 4*m, bdspac ) ) then + if( lwork>=m*m+max( 4_${ik}$*m, bdspac ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=wrkbl+lda*m ) then ! work(ir) is lda by m ldwrkr = lda @@ -12685,15 +12683,15 @@ module stdlib_linalg_lapack_${ri}$ iwork = itau + m ! compute a=l*q ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy l to work(ir), zeroing out above it - call stdlib_${ri}$lacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) - call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero,work( ir+ldwrkr ), ldwrkr & + call stdlib${ii}$_${ri}$lacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) + call stdlib${ii}$_${ri}$laset( 'U', m-1, m-1, zero, zero,work( ir+ldwrkr ), ldwrkr & ) ! generate q in a ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_${ri}$orglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + m @@ -12701,66 +12699,66 @@ module stdlib_linalg_lapack_${ri}$ iwork = itaup + m ! bidiagonalize l in work(ir) ! (workspace: need m*m + 4*m, prefer m*m + 3*m + 2*m*nb) - call stdlib_${ri}$gebrd( m, m, work( ir ), ldwrkr, s,work( ie ), work( itauq & + call stdlib${ii}$_${ri}$gebrd( m, m, work( ir ), ldwrkr, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing l in ! work(ir) ! (workspace: need m*m + 4*m, prefer m*m + 3*m + (m-1)*nb) - call stdlib_${ri}$orgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_${ri}$orgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of l in work(ir) ! (workspace: need m*m + bdspac) - call stdlib_${ri}$bdsqr( 'U', m, m, 0, 0, s, work( ie ),work( ir ), ldwrkr, & - dum, 1, dum, 1,work( iwork ), info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', m, m, 0_${ik}$, 0_${ik}$, s, work( ie ),work( ir ), ldwrkr, & + dum, 1_${ik}$, dum, 1_${ik}$,work( iwork ), info ) ! multiply right singular vectors of l in work(ir) by ! q in a, storing result in vt ! (workspace: need m*m) - call stdlib_${ri}$gemm( 'N', 'N', m, n, m, one, work( ir ),ldwrkr, a, lda, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', m, n, m, one, work( ir ),ldwrkr, a, lda, & zero, vt, ldvt ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy result to vt - call stdlib_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_${ri}$orglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_${ri}$orglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda ) + if (m>1_${ik}$) call stdlib${ii}$_${ri}$laset( 'U', m-1, m-1, zero, zero, a( 1_${ik}$, 2_${ik}$ ),lda ) ! bidiagonalize l in a ! (workspace: need 4*m, prefer 3*m + 2*m*nb) - call stdlib_${ri}$gebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_${ri}$gebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right vectors bidiagonalizing l by q in vt ! (workspace: need 3*m + n, prefer 3*m + n*nb) - call stdlib_${ri}$ormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & + call stdlib${ii}$_${ri}$ormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'U', m, n, 0, 0, s, work( ie ), vt,ldvt, dum, 1, & - dum, 1, work( iwork ),info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', m, n, 0_${ik}$, 0_${ik}$, s, work( ie ), vt,ldvt, dum, 1_${ik}$, & + dum, 1_${ik}$, work( iwork ),info ) end if else if( wntuo ) then ! path 5t(n much larger than m, jobu='o', jobvt='s') ! m right singular vectors to be computed in vt and ! m left singular vectors to be overwritten on a - if( lwork>=2*m*m+max( 4*m, bdspac ) ) then + if( lwork>=2_${ik}$*m*m+max( 4_${ik}$*m, bdspac ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+2*lda*m ) then ! work(iu) is lda by m and work(ir) is lda by m ldwrku = lda @@ -12781,15 +12779,15 @@ module stdlib_linalg_lapack_${ri}$ iwork = itau + m ! compute a=l*q ! (workspace: need 2*m*m + 2*m, prefer 2*m*m + m + m*nb) - call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy l to work(iu), zeroing out below it - call stdlib_${ri}$lacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & + call stdlib${ii}$_${ri}$lacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_${ri}$laset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & ) ! generate q in a ! (workspace: need 2*m*m + 2*m, prefer 2*m*m + m + m*nb) - call stdlib_${ri}$orglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + m @@ -12799,81 +12797,81 @@ module stdlib_linalg_lapack_${ri}$ ! work(ir) ! (workspace: need 2*m*m + 4*m, ! prefer 2*m*m+3*m+2*m*nb) - call stdlib_${ri}$gebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib${ii}$_${ri}$gebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib${ii}$_${ri}$lacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate right bidiagonalizing vectors in work(iu) ! (workspace: need 2*m*m + 4*m-1, ! prefer 2*m*m+3*m+(m-1)*nb) - call stdlib_${ri}$orgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib${ii}$_${ri}$orgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in work(ir) ! (workspace: need 2*m*m + 4*m, prefer 2*m*m + 3*m + m*nb) - call stdlib_${ri}$orgbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_${ri}$orgbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of l in work(ir) and computing ! right singular vectors of l in work(iu) ! (workspace: need 2*m*m + bdspac) - call stdlib_${ri}$bdsqr( 'U', m, m, m, 0, s, work( ie ),work( iu ), ldwrku, & - work( ir ),ldwrkr, dum, 1, work( iwork ), info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', m, m, m, 0_${ik}$, s, work( ie ),work( iu ), ldwrku, & + work( ir ),ldwrkr, dum, 1_${ik}$, work( iwork ), info ) ! multiply right singular vectors of l in work(iu) by ! q in a, storing result in vt ! (workspace: need m*m) - call stdlib_${ri}$gemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, a, lda, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, a, lda, & zero, vt, ldvt ) ! copy left singular vectors of l to a ! (workspace: need m*m) - call stdlib_${ri}$lacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) + call stdlib${ii}$_${ri}$lacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_${ri}$orglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_${ri}$orglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda ) + if (m>1_${ik}$) call stdlib${ii}$_${ri}$laset( 'U', m-1, m-1, zero, zero, a( 1_${ik}$, 2_${ik}$ ),lda ) ! bidiagonalize l in a ! (workspace: need 4*m, prefer 3*m + 2*m*nb) - call stdlib_${ri}$gebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_${ri}$gebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right vectors bidiagonalizing l by q in vt ! (workspace: need 3*m + n, prefer 3*m + n*nb) - call stdlib_${ri}$ormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & + call stdlib${ii}$_${ri}$ormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors of l in a ! (workspace: need 4*m, prefer 3*m + m*nb) - call stdlib_${ri}$orgbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & + call stdlib${ii}$_${ri}$orgbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, compute left ! singular vectors of a in a and compute right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'U', m, n, m, 0, s, work( ie ), vt,ldvt, a, lda, & - dum, 1, work( iwork ),info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', m, n, m, 0_${ik}$, s, work( ie ), vt,ldvt, a, lda, & + dum, 1_${ik}$, work( iwork ),info ) end if else if( wntuas ) then ! path 6t(n much larger than m, jobu='s' or 'a', ! jobvt='s') ! m right singular vectors to be computed in vt and ! m left singular vectors to be computed in u - if( lwork>=m*m+max( 4*m, bdspac ) ) then + if( lwork>=m*m+max( 4_${ik}$*m, bdspac ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+lda*m ) then ! work(iu) is lda by n ldwrku = lda @@ -12885,15 +12883,15 @@ module stdlib_linalg_lapack_${ri}$ iwork = itau + m ! compute a=l*q ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy l to work(iu), zeroing out above it - call stdlib_${ri}$lacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & + call stdlib${ii}$_${ri}$lacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_${ri}$laset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & ) ! generate q in a ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_${ri}$orglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + m @@ -12901,70 +12899,70 @@ module stdlib_linalg_lapack_${ri}$ iwork = itaup + m ! bidiagonalize l in work(iu), copying result to u ! (workspace: need m*m + 4*m, prefer m*m + 3*m + 2*m*nb) - call stdlib_${ri}$gebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib${ii}$_${ri}$gebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) + call stdlib${ii}$_${ri}$lacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) ! generate right bidiagonalizing vectors in work(iu) ! (workspace: need m*m + 4*m-1, ! prefer m*m+3*m+(m-1)*nb) - call stdlib_${ri}$orgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib${ii}$_${ri}$orgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (workspace: need m*m + 4*m, prefer m*m + 3*m + m*nb) - call stdlib_${ri}$orgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_${ri}$orgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of l in u and computing right ! singular vectors of l in work(iu) ! (workspace: need m*m + bdspac) - call stdlib_${ri}$bdsqr( 'U', m, m, m, 0, s, work( ie ),work( iu ), ldwrku, & - u, ldu, dum, 1,work( iwork ), info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', m, m, m, 0_${ik}$, s, work( ie ),work( iu ), ldwrku, & + u, ldu, dum, 1_${ik}$,work( iwork ), info ) ! multiply right singular vectors of l in work(iu) by ! q in a, storing result in vt ! (workspace: need m*m) - call stdlib_${ri}$gemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, a, lda, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, a, lda, & zero, vt, ldvt ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_${ri}$orglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_${ri}$orglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to u, zeroing out above it - call stdlib_${ri}$lacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu ) + call stdlib${ii}$_${ri}$lacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1_${ik}$) call stdlib${ii}$_${ri}$laset( 'U', m-1, m-1, zero, zero, u( 1_${ik}$, 2_${ik}$ ),ldu ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize l in u ! (workspace: need 4*m, prefer 3*m + 2*m*nb) - call stdlib_${ri}$gebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_${ri}$gebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in u by q ! in vt ! (workspace: need 3*m + n, prefer 3*m + n*nb) - call stdlib_${ri}$ormbr( 'P', 'L', 'T', m, n, m, u, ldu,work( itaup ), vt, & + call stdlib${ii}$_${ri}$ormbr( 'P', 'L', 'T', m, n, m, u, ldu,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (workspace: need 4*m, prefer 3*m + m*nb) - call stdlib_${ri}$orgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_${ri}$orgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'U', m, n, m, 0, s, work( ie ), vt,ldvt, u, ldu, & - dum, 1, work( iwork ),info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', m, n, m, 0_${ik}$, s, work( ie ), vt,ldvt, u, ldu, & + dum, 1_${ik}$, work( iwork ),info ) end if end if else if( wntva ) then @@ -12972,9 +12970,9 @@ module stdlib_linalg_lapack_${ri}$ ! path 7t(n much larger than m, jobu='n', jobvt='a') ! n right singular vectors to be computed in vt and ! no left singular vectors to be computed - if( lwork>=m*m+max( n + m, 4*m, bdspac ) ) then + if( lwork>=m*m+max( n + m, 4_${ik}$*m, bdspac ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=wrkbl+lda*m ) then ! work(ir) is lda by m ldwrkr = lda @@ -12986,16 +12984,16 @@ module stdlib_linalg_lapack_${ri}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! copy l to work(ir), zeroing out above it - call stdlib_${ri}$lacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) - call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero,work( ir+ldwrkr ), ldwrkr & + call stdlib${ii}$_${ri}$lacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) + call stdlib${ii}$_${ri}$laset( 'U', m-1, m-1, zero, zero,work( ir+ldwrkr ), ldwrkr & ) ! generate q in vt ! (workspace: need m*m + m + n, prefer m*m + m + n*nb) - call stdlib_${ri}$orglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_${ri}$orglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = itau itauq = ie + m @@ -13003,68 +13001,68 @@ module stdlib_linalg_lapack_${ri}$ iwork = itaup + m ! bidiagonalize l in work(ir) ! (workspace: need m*m + 4*m, prefer m*m + 3*m + 2*m*nb) - call stdlib_${ri}$gebrd( m, m, work( ir ), ldwrkr, s,work( ie ), work( itauq & + call stdlib${ii}$_${ri}$gebrd( m, m, work( ir ), ldwrkr, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in work(ir) ! (workspace: need m*m + 4*m-1, ! prefer m*m+3*m+(m-1)*nb) - call stdlib_${ri}$orgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_${ri}$orgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of l in work(ir) ! (workspace: need m*m + bdspac) - call stdlib_${ri}$bdsqr( 'U', m, m, 0, 0, s, work( ie ),work( ir ), ldwrkr, & - dum, 1, dum, 1,work( iwork ), info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', m, m, 0_${ik}$, 0_${ik}$, s, work( ie ),work( ir ), ldwrkr, & + dum, 1_${ik}$, dum, 1_${ik}$,work( iwork ), info ) ! multiply right singular vectors of l in work(ir) by ! q in vt, storing result in a ! (workspace: need m*m) - call stdlib_${ri}$gemm( 'N', 'N', m, n, m, one, work( ir ),ldwrkr, vt, ldvt, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', m, n, m, one, work( ir ),ldwrkr, vt, ldvt, & zero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_${ri}$lacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ri}$lacpy( 'F', m, n, a, lda, vt, ldvt ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need m + n, prefer m + n*nb) - call stdlib_${ri}$orglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_${ri}$orglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda ) + if (m>1_${ik}$) call stdlib${ii}$_${ri}$laset( 'U', m-1, m-1, zero, zero, a( 1_${ik}$, 2_${ik}$ ),lda ) ! bidiagonalize l in a ! (workspace: need 4*m, prefer 3*m + 2*m*nb) - call stdlib_${ri}$gebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_${ri}$gebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in a by q ! in vt ! (workspace: need 3*m + n, prefer 3*m + n*nb) - call stdlib_${ri}$ormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & + call stdlib${ii}$_${ri}$ormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'U', m, n, 0, 0, s, work( ie ), vt,ldvt, dum, 1, & - dum, 1, work( iwork ),info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', m, n, 0_${ik}$, 0_${ik}$, s, work( ie ), vt,ldvt, dum, 1_${ik}$, & + dum, 1_${ik}$, work( iwork ),info ) end if else if( wntuo ) then ! path 8t(n much larger than m, jobu='o', jobvt='a') ! n right singular vectors to be computed in vt and ! m left singular vectors to be overwritten on a - if( lwork>=2*m*m+max( n + m, 4*m, bdspac ) ) then + if( lwork>=2_${ik}$*m*m+max( n + m, 4_${ik}$*m, bdspac ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+2*lda*m ) then ! work(iu) is lda by m and work(ir) is lda by m ldwrku = lda @@ -13085,16 +13083,16 @@ module stdlib_linalg_lapack_${ri}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need 2*m*m + 2*m, prefer 2*m*m + m + m*nb) - call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need 2*m*m + m + n, prefer 2*m*m + m + n*nb) - call stdlib_${ri}$orglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_${ri}$orglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to work(iu), zeroing out above it - call stdlib_${ri}$lacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & + call stdlib${ii}$_${ri}$lacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_${ri}$laset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & ) ie = itau itauq = ie + m @@ -13104,83 +13102,83 @@ module stdlib_linalg_lapack_${ri}$ ! work(ir) ! (workspace: need 2*m*m + 4*m, ! prefer 2*m*m+3*m+2*m*nb) - call stdlib_${ri}$gebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib${ii}$_${ri}$gebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib${ii}$_${ri}$lacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate right bidiagonalizing vectors in work(iu) ! (workspace: need 2*m*m + 4*m-1, ! prefer 2*m*m+3*m+(m-1)*nb) - call stdlib_${ri}$orgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib${ii}$_${ri}$orgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in work(ir) ! (workspace: need 2*m*m + 4*m, prefer 2*m*m + 3*m + m*nb) - call stdlib_${ri}$orgbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_${ri}$orgbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of l in work(ir) and computing ! right singular vectors of l in work(iu) ! (workspace: need 2*m*m + bdspac) - call stdlib_${ri}$bdsqr( 'U', m, m, m, 0, s, work( ie ),work( iu ), ldwrku, & - work( ir ),ldwrkr, dum, 1, work( iwork ), info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', m, m, m, 0_${ik}$, s, work( ie ),work( iu ), ldwrku, & + work( ir ),ldwrkr, dum, 1_${ik}$, work( iwork ), info ) ! multiply right singular vectors of l in work(iu) by ! q in vt, storing result in a ! (workspace: need m*m) - call stdlib_${ri}$gemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, vt, ldvt, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, vt, ldvt, & zero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_${ri}$lacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ri}$lacpy( 'F', m, n, a, lda, vt, ldvt ) ! copy left singular vectors of a from work(ir) to a - call stdlib_${ri}$lacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) + call stdlib${ii}$_${ri}$lacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need m + n, prefer m + n*nb) - call stdlib_${ri}$orglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_${ri}$orglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda ) + if (m>1_${ik}$) call stdlib${ii}$_${ri}$laset( 'U', m-1, m-1, zero, zero, a( 1_${ik}$, 2_${ik}$ ),lda ) ! bidiagonalize l in a ! (workspace: need 4*m, prefer 3*m + 2*m*nb) - call stdlib_${ri}$gebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_${ri}$gebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in a by q ! in vt ! (workspace: need 3*m + n, prefer 3*m + n*nb) - call stdlib_${ri}$ormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & + call stdlib${ii}$_${ri}$ormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in a ! (workspace: need 4*m, prefer 3*m + m*nb) - call stdlib_${ri}$orgbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & + call stdlib${ii}$_${ri}$orgbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of a in a and computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'U', m, n, m, 0, s, work( ie ), vt,ldvt, a, lda, & - dum, 1, work( iwork ),info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', m, n, m, 0_${ik}$, s, work( ie ), vt,ldvt, a, lda, & + dum, 1_${ik}$, work( iwork ),info ) end if else if( wntuas ) then ! path 9t(n much larger than m, jobu='s' or 'a', ! jobvt='a') ! n right singular vectors to be computed in vt and ! m left singular vectors to be computed in u - if( lwork>=m*m+max( n + m, 4*m, bdspac ) ) then + if( lwork>=m*m+max( n + m, 4_${ik}$*m, bdspac ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+lda*m ) then ! work(iu) is lda by m ldwrku = lda @@ -13192,16 +13190,16 @@ module stdlib_linalg_lapack_${ri}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need m*m + 2*m, prefer m*m + m + m*nb) - call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need m*m + m + n, prefer m*m + m + n*nb) - call stdlib_${ri}$orglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_${ri}$orglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to work(iu), zeroing out above it - call stdlib_${ri}$lacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & + call stdlib${ii}$_${ri}$lacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_${ri}$laset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & ) ie = itau itauq = ie + m @@ -13209,71 +13207,71 @@ module stdlib_linalg_lapack_${ri}$ iwork = itaup + m ! bidiagonalize l in work(iu), copying result to u ! (workspace: need m*m + 4*m, prefer m*m + 3*m + 2*m*nb) - call stdlib_${ri}$gebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib${ii}$_${ri}$gebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) + call stdlib${ii}$_${ri}$lacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) ! generate right bidiagonalizing vectors in work(iu) ! (workspace: need m*m + 4*m, prefer m*m + 3*m + (m-1)*nb) - call stdlib_${ri}$orgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib${ii}$_${ri}$orgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (workspace: need m*m + 4*m, prefer m*m + 3*m + m*nb) - call stdlib_${ri}$orgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_${ri}$orgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of l in u and computing right ! singular vectors of l in work(iu) ! (workspace: need m*m + bdspac) - call stdlib_${ri}$bdsqr( 'U', m, m, m, 0, s, work( ie ),work( iu ), ldwrku, & - u, ldu, dum, 1,work( iwork ), info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', m, m, m, 0_${ik}$, s, work( ie ),work( iu ), ldwrku, & + u, ldu, dum, 1_${ik}$,work( iwork ), info ) ! multiply right singular vectors of l in work(iu) by ! q in vt, storing result in a ! (workspace: need m*m) - call stdlib_${ri}$gemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, vt, ldvt, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, vt, ldvt, & zero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_${ri}$lacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ri}$lacpy( 'F', m, n, a, lda, vt, ldvt ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need 2*m, prefer m + m*nb) - call stdlib_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need m + n, prefer m + n*nb) - call stdlib_${ri}$orglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_${ri}$orglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to u, zeroing out above it - call stdlib_${ri}$lacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_${ri}$laset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu ) + call stdlib${ii}$_${ri}$lacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1_${ik}$) call stdlib${ii}$_${ri}$laset( 'U', m-1, m-1, zero, zero, u( 1_${ik}$, 2_${ik}$ ),ldu ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize l in u ! (workspace: need 4*m, prefer 3*m + 2*m*nb) - call stdlib_${ri}$gebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_${ri}$gebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in u by q ! in vt ! (workspace: need 3*m + n, prefer 3*m + n*nb) - call stdlib_${ri}$ormbr( 'P', 'L', 'T', m, n, m, u, ldu,work( itaup ), vt, & + call stdlib${ii}$_${ri}$ormbr( 'P', 'L', 'T', m, n, m, u, ldu,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (workspace: need 4*m, prefer 3*m + m*nb) - call stdlib_${ri}$orgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_${ri}$orgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'U', m, n, m, 0, s, work( ie ), vt,ldvt, u, ldu, & - dum, 1, work( iwork ),info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', m, n, m, 0_${ik}$, s, work( ie ), vt,ldvt, u, ldu, & + dum, 1_${ik}$, work( iwork ),info ) end if end if end if @@ -13281,107 +13279,107 @@ module stdlib_linalg_lapack_${ri}$ ! n < mnthr ! path 10t(n greater than m, but not much larger) ! reduce to bidiagonal form without lq decomposition - ie = 1 + ie = 1_${ik}$ itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize a ! (workspace: need 3*m + n, prefer 3*m + (m + n)*nb) - call stdlib_${ri}$gebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_${ri}$gebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,ierr ) if( wntuas ) then ! if left singular vectors desired in u, copy result to u ! and generate left bidiagonalizing vectors in u ! (workspace: need 4*m-1, prefer 3*m + (m-1)*nb) - call stdlib_${ri}$lacpy( 'L', m, m, a, lda, u, ldu ) - call stdlib_${ri}$orgbr( 'Q', m, m, n, u, ldu, work( itauq ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$lacpy( 'L', m, m, a, lda, u, ldu ) + call stdlib${ii}$_${ri}$orgbr( 'Q', m, m, n, u, ldu, work( itauq ),work( iwork ), lwork-& iwork+1, ierr ) end if if( wntvas ) then ! if right singular vectors desired in vt, copy result to ! vt and generate right bidiagonalizing vectors in vt ! (workspace: need 3*m + nrvt, prefer 3*m + nrvt*nb) - call stdlib_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ri}$lacpy( 'U', m, n, a, lda, vt, ldvt ) if( wntva )nrvt = n if( wntvs )nrvt = m - call stdlib_${ri}$orgbr( 'P', nrvt, n, m, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib${ii}$_${ri}$orgbr( 'P', nrvt, n, m, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) end if if( wntuo ) then ! if left singular vectors desired in a, generate left ! bidiagonalizing vectors in a ! (workspace: need 4*m-1, prefer 3*m + (m-1)*nb) - call stdlib_${ri}$orgbr( 'Q', m, m, n, a, lda, work( itauq ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orgbr( 'Q', m, m, n, a, lda, work( itauq ),work( iwork ), lwork-& iwork+1, ierr ) end if if( wntvo ) then ! if right singular vectors desired in a, generate right ! bidiagonalizing vectors in a ! (workspace: need 4*m, prefer 3*m + m*nb) - call stdlib_${ri}$orgbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-& + call stdlib${ii}$_${ri}$orgbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-& iwork+1, ierr ) end if iwork = ie + m if( wntuas .or. wntuo )nru = m - if( wntun )nru = 0 + if( wntun )nru = 0_${ik}$ if( wntvas .or. wntvo )ncvt = n - if( wntvn )ncvt = 0 + if( wntvn )ncvt = 0_${ik}$ if( ( .not.wntuo ) .and. ( .not.wntvo ) ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in vt ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'L', m, ncvt, nru, 0, s, work( ie ), vt,ldvt, u, ldu, dum,& - 1, work( iwork ), info ) + call stdlib${ii}$_${ri}$bdsqr( 'L', m, ncvt, nru, 0_${ik}$, s, work( ie ), vt,ldvt, u, ldu, dum,& + 1_${ik}$, work( iwork ), info ) else if( ( .not.wntuo ) .and. wntvo ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in a ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'L', m, ncvt, nru, 0, s, work( ie ), a, lda,u, ldu, dum, & - 1, work( iwork ), info ) + call stdlib${ii}$_${ri}$bdsqr( 'L', m, ncvt, nru, 0_${ik}$, s, work( ie ), a, lda,u, ldu, dum, & + 1_${ik}$, work( iwork ), info ) else ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in a and computing right singular ! vectors in vt ! (workspace: need bdspac) - call stdlib_${ri}$bdsqr( 'L', m, ncvt, nru, 0, s, work( ie ), vt,ldvt, a, lda, dum,& - 1, work( iwork ), info ) + call stdlib${ii}$_${ri}$bdsqr( 'L', m, ncvt, nru, 0_${ik}$, s, work( ie ), vt,ldvt, a, lda, dum,& + 1_${ik}$, work( iwork ), info ) end if end if end if - ! if stdlib_${ri}$bdsqr failed to converge, copy unconverged superdiagonals + ! if stdlib${ii}$_${ri}$bdsqr failed to converge, copy unconverged superdiagonals ! to work( 2:minmn ) - if( info/=0 ) then - if( ie>2 ) then + if( info/=0_${ik}$ ) then + if( ie>2_${ik}$ ) then do i = 1, minmn - 1 work( i+1 ) = work( i+ie-1 ) end do end if - if( ie<2 ) then + if( ie<2_${ik}$ ) then do i = minmn - 1, 1, -1 work( i+1 ) = work( i+ie-1 ) end do end if end if ! undo scaling if necessary - if( iscl==1 ) then - if( anrm>bignum )call stdlib_${ri}$lascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,& + if( iscl==1_${ik}$ ) then + if( anrm>bignum )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn, 1_${ik}$, s, minmn,& ierr ) - if( info/=0 .and. anrm>bignum )call stdlib_${ri}$lascl( 'G', 0, 0, bignum, anrm, minmn-1,& - 1, work( 2 ),minmn, ierr ) - if( anrmbignum )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn-1,& + 1_${ik}$, work( 2_${ik}$ ),minmn, ierr ) + if( anrm= N. The SVD of A is written as !! [++] [xx] [x0] [xx] @@ -13394,26 +13392,26 @@ module stdlib_linalg_lapack_${ri}$ numrank, iwork, liwork,work, lwork, rwork, lrwork, info ) ! Scalar Arguments character, intent(in) :: joba, jobp, jobr, jobu, jobv - integer(ilp), intent(in) :: m, n, lda, ldu, ldv, liwork, lrwork - integer(ilp), intent(out) :: numrank, info - integer(ilp), intent(inout) :: lwork + integer(${ik}$), intent(in) :: m, n, lda, ldu, ldv, liwork, lrwork + integer(${ik}$), intent(out) :: numrank, info + integer(${ik}$), intent(inout) :: lwork ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: u(ldu,*), v(ldv,*), work(*) real(${rk}$), intent(out) :: s(*), rwork(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: ierr, iwoff, nr, n1, optratio, p, q - integer(ilp) :: lwcon, lwqp3, lwrk_qgelqf, lwrk_qgesvd, lwrk_qgesvd2, lwrk_qgeqp3, & + integer(${ik}$) :: ierr, iwoff, nr, n1, optratio, p, q + integer(${ik}$) :: lwcon, lwqp3, lwrk_qgelqf, lwrk_qgesvd, lwrk_qgesvd2, lwrk_qgeqp3, & lwrk_qgeqrf, lwrk_qormlq, lwrk_qormqr, lwrk_qormqr2, lwlqf, lwqrf, lwsvd, lwsvd2, & lworq, lworq2, lworlq, minwrk, minwrk2, optwrk, optwrk2, iminwrk, rminwrk logical(lk) :: accla, acclm, acclh, ascaled, conda, dntwu, dntwv, lquery, lsvc0, lsvec,& rowprm, rsvec, rtrans, wntua, wntuf, wntur, wntus, wntva, wntvr real(${rk}$) :: big, epsln, rtmp, sconda, sfmin ! Local Arrays - real(${rk}$) :: rdummy(1) + real(${rk}$) :: rdummy(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,min,real,sqrt ! test the input arguments @@ -13436,81 +13434,81 @@ module stdlib_linalg_lapack_${ri}$ rtrans = stdlib_lsame( jobr, 'T' ) if ( rowprm ) then if ( conda ) then - iminwrk = max( 1, n + m - 1 + n ) + iminwrk = max( 1_${ik}$, n + m - 1_${ik}$ + n ) else - iminwrk = max( 1, n + m - 1 ) + iminwrk = max( 1_${ik}$, n + m - 1_${ik}$ ) end if - rminwrk = max( 2, m ) + rminwrk = max( 2_${ik}$, m ) else if ( conda ) then - iminwrk = max( 1, n + n ) + iminwrk = max( 1_${ik}$, n + n ) else - iminwrk = max( 1, n ) + iminwrk = max( 1_${ik}$, n ) end if - rminwrk = 2 + rminwrk = 2_${ik}$ end if - lquery = (liwork == -1 .or. lwork == -1 .or. lrwork == -1) - info = 0 + lquery = (liwork == -1_${ik}$ .or. lwork == -1_${ik}$ .or. lrwork == -1_${ik}$) + info = 0_${ik}$ if ( .not. ( accla .or. acclm .or. acclh ) ) then - info = -1 + info = -1_${ik}$ else if ( .not.( rowprm .or. stdlib_lsame( jobp, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if ( .not.( rtrans .or. stdlib_lsame( jobr, 'N' ) ) ) then - info = -3 + info = -3_${ik}$ else if ( .not.( lsvec .or. dntwu ) ) then - info = -4 + info = -4_${ik}$ else if ( wntur .and. wntva ) then - info = -5 + info = -5_${ik}$ else if ( .not.( rsvec .or. dntwv )) then - info = -5 - else if ( m<0 ) then - info = -6 - else if ( ( n<0 ) .or. ( n>m ) ) then - info = -7 - else if ( ldam ) ) then + info = -7_${ik}$ + else if ( lda big / sqrt(real(m,KIND=${rk}$)) ) then + if ( rwork(1_${ik}$) > big / sqrt(real(m,KIND=${rk}$)) ) then ! .. to prevent overflow in the qr factorization, scale the ! matrix by 1/sqrt(m) if too large entry detected - call stdlib_${ri}$lascl('G',0,0,sqrt(real(m,KIND=${rk}$)),one, m,n, a,lda, ierr) + call stdlib${ii}$_${ri}$lascl('G',0_${ik}$,0_${ik}$,sqrt(real(m,KIND=${rk}$)),one, m,n, a,lda, ierr) ascaled = .true. end if - call stdlib_${ri}$laswp( n, a, lda, 1, m-1, iwork(n+1), 1 ) + call stdlib${ii}$_${ri}$laswp( n, a, lda, 1_${ik}$, m-1, iwork(n+1), 1_${ik}$ ) end if ! .. at this stage, preemptive scaling is done only to avoid column ! norms overflows during the qr factorization. the svd procedure should ! have its own scaling to save the singular values from overflows and ! underflows. that depends on the svd procedure. if ( .not.rowprm ) then - rtmp = stdlib_${ri}$lange( 'M', m, n, a, lda, rdummy ) + rtmp = stdlib${ii}$_${ri}$lange( 'M', m, n, a, lda, rdummy ) if ( ( rtmp /= rtmp ) .or.( (rtmp*zero) /= zero ) ) then - info = -8 - call stdlib_xerbla( 'DGESVDQ', -info ) + info = -8_${ik}$ + call stdlib${ii}$_xerbla( 'DGESVDQ', -info ) return end if if ( rtmp > big / sqrt(real(m,KIND=${rk}$)) ) then ! .. to prevent overflow in the qr factorization, scale the ! matrix by 1/sqrt(m) if too large entry detected - call stdlib_${ri}$lascl('G',0,0, sqrt(real(m,KIND=${rk}$)),one, m,n, a,lda, ierr) + call stdlib${ii}$_${ri}$lascl('G',0_${ik}$,0_${ik}$, sqrt(real(m,KIND=${rk}$)),one, m,n, a,lda, ierr) ascaled = .true. end if @@ -13763,14 +13761,14 @@ module stdlib_linalg_lapack_${ri}$ ! [ 0 ] do p = 1, n ! All Columns Are Free Columns - iwork(p) = 0 + iwork(p) = 0_${ik}$ end do - call stdlib_${ri}$geqp3( m, n, a, lda, iwork, work, work(n+1), lwork-n,ierr ) + call stdlib${ii}$_${ri}$geqp3( m, n, a, lda, iwork, work, work(n+1), lwork-n,ierr ) ! if the user requested accuracy level allows truncation in the ! computed upper triangular factor, the matrix r is examined and, ! if possible, replaced with its leading upper trapezoidal part. - epsln = stdlib_${ri}$lamch('E') - sfmin = stdlib_${ri}$lamch('S') + epsln = stdlib${ii}$_${ri}$lamch('E') + sfmin = stdlib${ii}$_${ri}$lamch('S') ! small = sfmin / epsln nr = n if ( accla ) then @@ -13778,57 +13776,53 @@ module stdlib_linalg_lapack_${ri}$ ! sigma_i < n*eps*||a||_f are flushed to zero. this is an ! aggressive enforcement of lower numerical rank by introducing a ! backward error of the order of n*eps*||a||_f. - nr = 1 + nr = 1_${ik}$ rtmp = sqrt(real(n,KIND=${rk}$))*epsln - do p = 2, n - if ( abs(a(p,p)) < (rtmp*abs(a(1,1))) ) go to 3002 - nr = nr + 1 - end do - 3002 continue + loop_3002: do p = 2, n + if ( abs(a(p,p)) < (rtmp*abs(a(1,1))) ) exit loop_3002 + nr = nr + 1_${ik}$ + end do loop_3002 elseif ( acclm ) then ! .. similarly as above, only slightly more gentle (less aggressive). ! sudden drop on the diagonal of r is used as the criterion for being - ! close-to-rank-deficient. the threshold is set to epsln=stdlib_${ri}$lamch('e'). + ! close-to-rank-deficient. the threshold is set to epsln=stdlib${ii}$_${ri}$lamch('e'). ! [[this can be made more flexible by replacing this hard-coded value ! with a user specified threshold.]] also, the values that underflow ! will be truncated. - nr = 1 - do p = 2, n - if ( ( abs(a(p,p)) < (epsln*abs(a(p-1,p-1))) ) .or.( abs(a(p,p)) < sfmin ) ) go & - to 3402 - nr = nr + 1 - end do - 3402 continue + nr = 1_${ik}$ + loop_3402: do p = 2, n + if ( ( abs(a(p,p)) < (epsln*abs(a(p-1,p-1))) ) .or.( abs(a(p,p)) < sfmin ) ) exit loop_3402 + nr = nr + 1_${ik}$ + end do loop_3402 else ! Rrqr Not Authorized To Determine Numerical Rank Except In The ! obvious case of zero pivots. ! .. inspect r for exact zeros on the diagonal; ! r(i,i)=0 => r(i:n,i:n)=0. - nr = 1 - do p = 2, n - if ( abs(a(p,p)) == zero ) go to 3502 - nr = nr + 1 - end do - 3502 continue + nr = 1_${ik}$ + loop_3502: do p = 2, n + if ( abs(a(p,p)) == zero ) exit loop_3502 + nr = nr + 1_${ik}$ + end do loop_3502 if ( conda ) then ! estimate the scaled condition number of a. use the fact that it is ! the same as the scaled condition number of r. ! V Is Used As Workspace - call stdlib_${ri}$lacpy( 'U', n, n, a, lda, v, ldv ) + call stdlib${ii}$_${ri}$lacpy( 'U', n, n, a, lda, v, ldv ) ! only the leading nr x nr submatrix of the triangular factor ! is considered. only if nr=n will this give a reliable error ! bound. however, even for nr < n, this can be used on an ! expert level and obtain useful information in the sense of ! perturbation theory. do p = 1, nr - rtmp = stdlib_${ri}$nrm2( p, v(1,p), 1 ) - call stdlib_${ri}$scal( p, one/rtmp, v(1,p), 1 ) + rtmp = stdlib${ii}$_${ri}$nrm2( p, v(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( p, one/rtmp, v(1_${ik}$,p), 1_${ik}$ ) end do if ( .not. ( lsvec .or. rsvec ) ) then - call stdlib_${ri}$pocon( 'U', nr, v, ldv, one, rtmp,work, iwork(n+iwoff), ierr & + call stdlib${ii}$_${ri}$pocon( 'U', nr, v, ldv, one, rtmp,work, iwork(n+iwoff), ierr & ) else - call stdlib_${ri}$pocon( 'U', nr, v, ldv, one, rtmp,work(n+1), iwork(n+iwoff), & + call stdlib${ii}$_${ri}$pocon( 'U', nr, v, ldv, one, rtmp,work(n+1), iwork(n+iwoff), & ierr ) end if sconda = one / sqrt(rtmp) @@ -13858,12 +13852,12 @@ module stdlib_linalg_lapack_${ri}$ if ( q <= nr ) a(p,q) = zero end do end do - call stdlib_${ri}$gesvd( 'N', 'N', n, nr, a, lda, s, u, ldu,v, ldv, work, lwork, info & + call stdlib${ii}$_${ri}$gesvd( 'N', 'N', n, nr, a, lda, s, u, ldu,v, ldv, work, lwork, info & ) else ! .. compute the singular values of r = [a](1:nr,1:n) - if ( nr > 1 )call stdlib_${ri}$laset( 'L', nr-1,nr-1, zero,zero, a(2,1), lda ) - call stdlib_${ri}$gesvd( 'N', 'N', nr, n, a, lda, s, u, ldu,v, ldv, work, lwork, info & + if ( nr > 1_${ik}$ )call stdlib${ii}$_${ri}$laset( 'L', nr-1,nr-1, zero,zero, a(2_${ik}$,1_${ik}$), lda ) + call stdlib${ii}$_${ri}$gesvd( 'N', 'N', nr, n, a, lda, s, u, ldu,v, ldv, work, lwork, info & ) end if else if ( lsvec .and. ( .not. rsvec) ) then @@ -13871,7 +13865,7 @@ module stdlib_linalg_lapack_${ri}$ ! The Singular Values And The Left Singular Vectors Requested ! ......................................................................."""""""" if ( rtrans ) then - ! .. apply stdlib_${ri}$gesvd to r**t + ! .. apply stdlib${ii}$_${ri}$gesvd to r**t ! .. copy r**t into [u] and overwrite [u] with the right singular ! vectors of r do p = 1, nr @@ -13879,11 +13873,11 @@ module stdlib_linalg_lapack_${ri}$ u(q,p) = a(p,q) end do end do - if ( nr > 1 )call stdlib_${ri}$laset( 'U', nr-1,nr-1, zero,zero, u(1,2), ldu ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_${ri}$laset( 'U', nr-1,nr-1, zero,zero, u(1_${ik}$,2_${ik}$), ldu ) ! .. the left singular vectors not computed, the nr right singular ! vectors overwrite [u](1:nr,1:nr) as transposed. these ! will be pre-multiplied by q to build the left singular vectors of a. - call stdlib_${ri}$gesvd( 'N', 'O', n, nr, u, ldu, s, u, ldu,u, ldu, work(n+1), & + call stdlib${ii}$_${ri}$gesvd( 'N', 'O', n, nr, u, ldu, s, u, ldu,u, ldu, work(n+1), & lwork-n, info ) do p = 1, nr do q = p + 1, nr @@ -13895,12 +13889,12 @@ module stdlib_linalg_lapack_${ri}$ else ! Apply Stdlib_Dgesvd To R ! .. copy r into [u] and overwrite [u] with the left singular vectors - call stdlib_${ri}$lacpy( 'U', nr, n, a, lda, u, ldu ) - if ( nr > 1 )call stdlib_${ri}$laset( 'L', nr-1, nr-1, zero, zero, u(2,1), ldu ) + call stdlib${ii}$_${ri}$lacpy( 'U', nr, n, a, lda, u, ldu ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_${ri}$laset( 'L', nr-1, nr-1, zero, zero, u(2_${ik}$,1_${ik}$), ldu ) ! .. the right singular vectors not computed, the nr left singular ! vectors overwrite [u](1:nr,1:nr) - call stdlib_${ri}$gesvd( 'O', 'N', nr, n, u, ldu, s, u, ldu,v, ldv, work(n+1), & + call stdlib${ii}$_${ri}$gesvd( 'O', 'N', nr, n, u, ldu, s, u, ldu,v, ldv, work(n+1), & lwork-n, info ) ! .. now [u](1:nr,1:nr) contains the nr left singular vectors of ! r. these will be pre-multiplied by q to build the left singular @@ -13909,35 +13903,35 @@ module stdlib_linalg_lapack_${ri}$ ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. ( .not.wntuf ) ) then - call stdlib_${ri}$laset('A', m-nr, nr, zero, zero, u(nr+1,1), ldu) + call stdlib${ii}$_${ri}$laset('A', m-nr, nr, zero, zero, u(nr+1,1_${ik}$), ldu) if ( nr < n1 ) then - call stdlib_${ri}$laset( 'A',nr,n1-nr,zero,zero,u(1,nr+1), ldu ) - call stdlib_${ri}$laset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_${ri}$laset( 'A',nr,n1-nr,zero,zero,u(1_${ik}$,nr+1), ldu ) + call stdlib${ii}$_${ri}$laset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) end if end if ! the q matrix from the first qrf is built into the left singular ! vectors matrix u. - if ( .not.wntuf )call stdlib_${ri}$ormqr( 'L', 'N', m, n1, n, a, lda, work, u,ldu, work(& + if ( .not.wntuf )call stdlib${ii}$_${ri}$ormqr( 'L', 'N', m, n1, n, a, lda, work, u,ldu, work(& n+1), lwork-n, ierr ) - if ( rowprm .and. .not.wntuf )call stdlib_${ri}$laswp( n1, u, ldu, 1, m-1, iwork(n+1), -& - 1 ) + if ( rowprm .and. .not.wntuf )call stdlib${ii}$_${ri}$laswp( n1, u, ldu, 1_${ik}$, m-1, iwork(n+1), -& + 1_${ik}$ ) else if ( rsvec .and. ( .not. lsvec ) ) then ! ....................................................................... ! The Singular Values And The Right Singular Vectors Requested ! ....................................................................... if ( rtrans ) then - ! .. apply stdlib_${ri}$gesvd to r**t + ! .. apply stdlib${ii}$_${ri}$gesvd to r**t ! .. copy r**t into v and overwrite v with the left singular vectors do p = 1, nr do q = p, n v(q,p) = (a(p,q)) end do end do - if ( nr > 1 )call stdlib_${ri}$laset( 'U', nr-1,nr-1, zero,zero, v(1,2), ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_${ri}$laset( 'U', nr-1,nr-1, zero,zero, v(1_${ik}$,2_${ik}$), ldv ) ! .. the left singular vectors of r**t overwrite v, the right singular ! vectors not computed if ( wntvr .or. ( nr == n ) ) then - call stdlib_${ri}$gesvd( 'O', 'N', n, nr, v, ldv, s, u, ldu,u, ldu, work(n+1), & + call stdlib${ii}$_${ri}$gesvd( 'O', 'N', n, nr, v, ldv, s, u, ldu,u, ldu, work(n+1), & lwork-n, info ) do p = 1, nr do q = p + 1, nr @@ -13953,15 +13947,15 @@ module stdlib_linalg_lapack_${ri}$ end do end do end if - call stdlib_${ri}$lapmt( .false., nr, n, v, ldv, iwork ) + call stdlib${ii}$_${ri}$lapmt( .false., nr, n, v, ldv, iwork ) else ! .. need all n right singular vectors and nr < n ! [!] this is simple implementation that augments [v](1:n,1:nr) ! by padding a zero block. in the case nr << n, a more efficient ! way is to first use the qr factorization. for more details ! how to implement this, see the " full svd " branch. - call stdlib_${ri}$laset('G', n, n-nr, zero, zero, v(1,nr+1), ldv) - call stdlib_${ri}$gesvd( 'O', 'N', n, n, v, ldv, s, u, ldu,u, ldu, work(n+1), & + call stdlib${ii}$_${ri}$laset('G', n, n-nr, zero, zero, v(1_${ik}$,nr+1), ldv) + call stdlib${ii}$_${ri}$gesvd( 'O', 'N', n, n, v, ldv, s, u, ldu,u, ldu, work(n+1), & lwork-n, info ) do p = 1, n do q = p + 1, n @@ -13970,20 +13964,20 @@ module stdlib_linalg_lapack_${ri}$ v(p,q) = rtmp end do end do - call stdlib_${ri}$lapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_${ri}$lapmt( .false., n, n, v, ldv, iwork ) end if else ! Aply Stdlib_Dgesvd To R ! Copy R Into V And Overwrite V With The Right Singular Vectors - call stdlib_${ri}$lacpy( 'U', nr, n, a, lda, v, ldv ) - if ( nr > 1 )call stdlib_${ri}$laset( 'L', nr-1, nr-1, zero, zero, v(2,1), ldv ) + call stdlib${ii}$_${ri}$lacpy( 'U', nr, n, a, lda, v, ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_${ri}$laset( 'L', nr-1, nr-1, zero, zero, v(2_${ik}$,1_${ik}$), ldv ) ! .. the right singular vectors overwrite v, the nr left singular ! vectors stored in u(1:nr,1:nr) if ( wntvr .or. ( nr == n ) ) then - call stdlib_${ri}$gesvd( 'N', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & + call stdlib${ii}$_${ri}$gesvd( 'N', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & lwork-n, info ) - call stdlib_${ri}$lapmt( .false., nr, n, v, ldv, iwork ) + call stdlib${ii}$_${ri}$lapmt( .false., nr, n, v, ldv, iwork ) ! .. now [v](1:nr,1:n) contains v(1:n,1:nr)**t else ! .. need all n right singular vectors and nr < n @@ -13991,10 +13985,10 @@ module stdlib_linalg_lapack_${ri}$ ! by padding a zero block. in the case nr << n, a more efficient ! way is to first use the lq factorization. for more details ! how to implement this, see the " full svd " branch. - call stdlib_${ri}$laset('G', n-nr, n, zero,zero, v(nr+1,1), ldv) - call stdlib_${ri}$gesvd( 'N', 'O', n, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & + call stdlib${ii}$_${ri}$laset('G', n-nr, n, zero,zero, v(nr+1,1_${ik}$), ldv) + call stdlib${ii}$_${ri}$gesvd( 'N', 'O', n, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & lwork-n, info ) - call stdlib_${ri}$lapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_${ri}$lapmt( .false., n, n, v, ldv, iwork ) end if ! .. now [v] contains the transposed matrix of the right singular ! vectors of a. @@ -14004,7 +13998,7 @@ module stdlib_linalg_lapack_${ri}$ ! Full Svd Requested ! ....................................................................... if ( rtrans ) then - ! .. apply stdlib_${ri}$gesvd to r**t [[this option is left for r + ! .. apply stdlib${ii}$_${ri}$gesvd to r**t [[this option is left for r if ( wntvr .or. ( nr == n ) ) then ! .. copy r**t into [v] and overwrite [v] with the left singular ! vectors of r**t @@ -14013,10 +14007,10 @@ module stdlib_linalg_lapack_${ri}$ v(q,p) = a(p,q) end do end do - if ( nr > 1 )call stdlib_${ri}$laset( 'U', nr-1,nr-1, zero,zero, v(1,2), ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_${ri}$laset( 'U', nr-1,nr-1, zero,zero, v(1_${ik}$,2_${ik}$), ldv ) ! .. the left singular vectors of r**t overwrite [v], the nr right ! singular vectors of r**t stored in [u](1:nr,1:nr) as transposed - call stdlib_${ri}$gesvd( 'O', 'A', n, nr, v, ldv, s, v, ldv,u, ldu, work(n+1), & + call stdlib${ii}$_${ri}$gesvd( 'O', 'A', n, nr, v, ldv, s, v, ldv,u, ldu, work(n+1), & lwork-n, info ) ! Assemble V do p = 1, nr @@ -14033,7 +14027,7 @@ module stdlib_linalg_lapack_${ri}$ end do end do end if - call stdlib_${ri}$lapmt( .false., nr, n, v, ldv, iwork ) + call stdlib${ii}$_${ri}$lapmt( .false., nr, n, v, ldv, iwork ) do p = 1, nr do q = p + 1, nr rtmp = u(q,p) @@ -14042,10 +14036,10 @@ module stdlib_linalg_lapack_${ri}$ end do end do if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_${ri}$laset('A', m-nr,nr, zero,zero, u(nr+1,1), ldu) + call stdlib${ii}$_${ri}$laset('A', m-nr,nr, zero,zero, u(nr+1,1_${ik}$), ldu) if ( nr < n1 ) then - call stdlib_${ri}$laset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) - call stdlib_${ri}$laset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_${ri}$laset('A',nr,n1-nr,zero,zero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_${ri}$laset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) end if end if else @@ -14055,19 +14049,19 @@ module stdlib_linalg_lapack_${ri}$ ! [[the optimal ratio n/nr for using qrf instead of padding ! with zeros. here hard coded to 2; it must be at least ! two due to work space constraints.]] - ! optratio = stdlib_ilaenv(6, 'dgesvd', 's' // 'o', nr,n,0,0) + ! optratio = stdlib${ii}$_ilaenv(6, 'dgesvd', 's' // 'o', nr,n,0,0) ! optratio = max( optratio, 2 ) - optratio = 2 + optratio = 2_${ik}$ if ( optratio*nr > n ) then do p = 1, nr do q = p, n v(q,p) = a(p,q) end do end do - if ( nr > 1 )call stdlib_${ri}$laset('U',nr-1,nr-1, zero,zero, v(1,2),ldv) + if ( nr > 1_${ik}$ )call stdlib${ii}$_${ri}$laset('U',nr-1,nr-1, zero,zero, v(1_${ik}$,2_${ik}$),ldv) - call stdlib_${ri}$laset('A',n,n-nr,zero,zero,v(1,nr+1),ldv) - call stdlib_${ri}$gesvd( 'O', 'A', n, n, v, ldv, s, v, ldv,u, ldu, work(n+1), & + call stdlib${ii}$_${ri}$laset('A',n,n-nr,zero,zero,v(1_${ik}$,nr+1),ldv) + call stdlib${ii}$_${ri}$gesvd( 'O', 'A', n, n, v, ldv, s, v, ldv,u, ldu, work(n+1), & lwork-n, info ) do p = 1, n do q = p + 1, n @@ -14076,7 +14070,7 @@ module stdlib_linalg_lapack_${ri}$ v(p,q) = rtmp end do end do - call stdlib_${ri}$lapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_${ri}$lapmt( .false., n, n, v, ldv, iwork ) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x n1), i.e. (m x n) or (m x m). do p = 1, n @@ -14087,10 +14081,10 @@ module stdlib_linalg_lapack_${ri}$ end do end do if ( ( n < m ) .and. .not.(wntuf)) then - call stdlib_${ri}$laset('A',m-n,n,zero,zero,u(n+1,1),ldu) + call stdlib${ii}$_${ri}$laset('A',m-n,n,zero,zero,u(n+1,1_${ik}$),ldu) if ( n < n1 ) then - call stdlib_${ri}$laset('A',n,n1-n,zero,zero,u(1,n+1),ldu) - call stdlib_${ri}$laset('A',m-n,n1-n,zero,one,u(n+1,n+1), ldu ) + call stdlib${ii}$_${ri}$laset('A',n,n1-n,zero,zero,u(1_${ik}$,n+1),ldu) + call stdlib${ii}$_${ri}$laset('A',m-n,n1-n,zero,one,u(n+1,n+1), ldu ) end if end if else @@ -14101,55 +14095,55 @@ module stdlib_linalg_lapack_${ri}$ u(q,nr+p) = a(p,q) end do end do - if ( nr > 1 )call stdlib_${ri}$laset('U',nr-1,nr-1,zero,zero,u(1,nr+2),ldu) + if ( nr > 1_${ik}$ )call stdlib${ii}$_${ri}$laset('U',nr-1,nr-1,zero,zero,u(1_${ik}$,nr+2),ldu) - call stdlib_${ri}$geqrf( n, nr, u(1,nr+1), ldu, work(n+1),work(n+nr+1), lwork-& + call stdlib${ii}$_${ri}$geqrf( n, nr, u(1_${ik}$,nr+1), ldu, work(n+1),work(n+nr+1), lwork-& n-nr, ierr ) do p = 1, nr do q = 1, n v(q,p) = u(p,nr+q) end do end do - if (nr>1) call stdlib_${ri}$laset('U',nr-1,nr-1,zero,zero,v(1,2),ldv) - call stdlib_${ri}$gesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v,ldv, work(n+nr+1)& + if (nr>1_${ik}$) call stdlib${ii}$_${ri}$laset('U',nr-1,nr-1,zero,zero,v(1_${ik}$,2_${ik}$),ldv) + call stdlib${ii}$_${ri}$gesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v,ldv, work(n+nr+1)& ,lwork-n-nr, info ) - call stdlib_${ri}$laset('A',n-nr,nr,zero,zero,v(nr+1,1),ldv) - call stdlib_${ri}$laset('A',nr,n-nr,zero,zero,v(1,nr+1),ldv) - call stdlib_${ri}$laset('A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv) - call stdlib_${ri}$ormqr('R','C', n, n, nr, u(1,nr+1), ldu,work(n+1),v,ldv,work(& + call stdlib${ii}$_${ri}$laset('A',n-nr,nr,zero,zero,v(nr+1,1_${ik}$),ldv) + call stdlib${ii}$_${ri}$laset('A',nr,n-nr,zero,zero,v(1_${ik}$,nr+1),ldv) + call stdlib${ii}$_${ri}$laset('A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv) + call stdlib${ii}$_${ri}$ormqr('R','C', n, n, nr, u(1_${ik}$,nr+1), ldu,work(n+1),v,ldv,work(& n+nr+1),lwork-n-nr,ierr) - call stdlib_${ri}$lapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_${ri}$lapmt( .false., n, n, v, ldv, iwork ) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_${ri}$laset('A',m-nr,nr,zero,zero,u(nr+1,1),ldu) + call stdlib${ii}$_${ri}$laset('A',m-nr,nr,zero,zero,u(nr+1,1_${ik}$),ldu) if ( nr < n1 ) then - call stdlib_${ri}$laset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) - call stdlib_${ri}$laset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1),ldu) + call stdlib${ii}$_${ri}$laset('A',nr,n1-nr,zero,zero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_${ri}$laset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1),ldu) end if end if end if end if else - ! .. apply stdlib_${ri}$gesvd to r [[this is the recommended option]] + ! .. apply stdlib${ii}$_${ri}$gesvd to r [[this is the recommended option]] if ( wntvr .or. ( nr == n ) ) then ! .. copy r into [v] and overwrite v with the right singular vectors - call stdlib_${ri}$lacpy( 'U', nr, n, a, lda, v, ldv ) - if ( nr > 1 )call stdlib_${ri}$laset( 'L', nr-1,nr-1, zero,zero, v(2,1), ldv ) + call stdlib${ii}$_${ri}$lacpy( 'U', nr, n, a, lda, v, ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_${ri}$laset( 'L', nr-1,nr-1, zero,zero, v(2_${ik}$,1_${ik}$), ldv ) ! .. the right singular vectors of r overwrite [v], the nr left ! singular vectors of r stored in [u](1:nr,1:nr) - call stdlib_${ri}$gesvd( 'S', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & + call stdlib${ii}$_${ri}$gesvd( 'S', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & lwork-n, info ) - call stdlib_${ri}$lapmt( .false., nr, n, v, ldv, iwork ) + call stdlib${ii}$_${ri}$lapmt( .false., nr, n, v, ldv, iwork ) ! .. now [v](1:nr,1:n) contains v(1:n,1:nr)**t ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_${ri}$laset('A', m-nr,nr, zero,zero, u(nr+1,1), ldu) + call stdlib${ii}$_${ri}$laset('A', m-nr,nr, zero,zero, u(nr+1,1_${ik}$), ldu) if ( nr < n1 ) then - call stdlib_${ri}$laset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) - call stdlib_${ri}$laset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_${ri}$laset('A',nr,n1-nr,zero,zero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_${ri}$laset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) end if end if else @@ -14159,54 +14153,54 @@ module stdlib_linalg_lapack_${ri}$ ! [[the optimal ratio n/nr for using lq instead of padding ! with zeros. here hard coded to 2; it must be at least ! two due to work space constraints.]] - ! optratio = stdlib_ilaenv(6, 'dgesvd', 's' // 'o', nr,n,0,0) + ! optratio = stdlib${ii}$_ilaenv(6, 'dgesvd', 's' // 'o', nr,n,0,0) ! optratio = max( optratio, 2 ) - optratio = 2 + optratio = 2_${ik}$ if ( optratio * nr > n ) then - call stdlib_${ri}$lacpy( 'U', nr, n, a, lda, v, ldv ) - if ( nr > 1 )call stdlib_${ri}$laset('L', nr-1,nr-1, zero,zero, v(2,1),ldv) + call stdlib${ii}$_${ri}$lacpy( 'U', nr, n, a, lda, v, ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_${ri}$laset('L', nr-1,nr-1, zero,zero, v(2_${ik}$,1_${ik}$),ldv) ! .. the right singular vectors of r overwrite [v], the nr left ! singular vectors of r stored in [u](1:nr,1:nr) - call stdlib_${ri}$laset('A', n-nr,n, zero,zero, v(nr+1,1),ldv) - call stdlib_${ri}$gesvd( 'S', 'O', n, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & + call stdlib${ii}$_${ri}$laset('A', n-nr,n, zero,zero, v(nr+1,1_${ik}$),ldv) + call stdlib${ii}$_${ri}$gesvd( 'S', 'O', n, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & lwork-n, info ) - call stdlib_${ri}$lapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_${ri}$lapmt( .false., n, n, v, ldv, iwork ) ! .. now [v] contains the transposed matrix of the right ! singular vectors of a. the leading n left singular vectors ! are in [u](1:n,1:n) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x n1), i.e. (m x n) or (m x m). if ( ( n < m ) .and. .not.(wntuf)) then - call stdlib_${ri}$laset('A',m-n,n,zero,zero,u(n+1,1),ldu) + call stdlib${ii}$_${ri}$laset('A',m-n,n,zero,zero,u(n+1,1_${ik}$),ldu) if ( n < n1 ) then - call stdlib_${ri}$laset('A',n,n1-n,zero,zero,u(1,n+1),ldu) - call stdlib_${ri}$laset( 'A',m-n,n1-n,zero,one,u(n+1,n+1), ldu ) + call stdlib${ii}$_${ri}$laset('A',n,n1-n,zero,zero,u(1_${ik}$,n+1),ldu) + call stdlib${ii}$_${ri}$laset( 'A',m-n,n1-n,zero,one,u(n+1,n+1), ldu ) end if end if else - call stdlib_${ri}$lacpy( 'U', nr, n, a, lda, u(nr+1,1), ldu ) - if ( nr > 1 )call stdlib_${ri}$laset('L',nr-1,nr-1,zero,zero,u(nr+2,1),ldu) + call stdlib${ii}$_${ri}$lacpy( 'U', nr, n, a, lda, u(nr+1,1_${ik}$), ldu ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_${ri}$laset('L',nr-1,nr-1,zero,zero,u(nr+2,1_${ik}$),ldu) - call stdlib_${ri}$gelqf( nr, n, u(nr+1,1), ldu, work(n+1),work(n+nr+1), lwork-n-& + call stdlib${ii}$_${ri}$gelqf( nr, n, u(nr+1,1_${ik}$), ldu, work(n+1),work(n+nr+1), lwork-n-& nr, ierr ) - call stdlib_${ri}$lacpy('L',nr,nr,u(nr+1,1),ldu,v,ldv) - if ( nr > 1 )call stdlib_${ri}$laset('U',nr-1,nr-1,zero,zero,v(1,2),ldv) - call stdlib_${ri}$gesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v, ldv, work(n+nr+& - 1), lwork-n-nr, info ) - call stdlib_${ri}$laset('A',n-nr,nr,zero,zero,v(nr+1,1),ldv) - call stdlib_${ri}$laset('A',nr,n-nr,zero,zero,v(1,nr+1),ldv) - call stdlib_${ri}$laset('A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv) - call stdlib_${ri}$ormlq('R','N',n,n,nr,u(nr+1,1),ldu,work(n+1),v, ldv, work(n+& + call stdlib${ii}$_${ri}$lacpy('L',nr,nr,u(nr+1,1_${ik}$),ldu,v,ldv) + if ( nr > 1_${ik}$ )call stdlib${ii}$_${ri}$laset('U',nr-1,nr-1,zero,zero,v(1_${ik}$,2_${ik}$),ldv) + call stdlib${ii}$_${ri}$gesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v, ldv, work(n+nr+& + 1_${ik}$), lwork-n-nr, info ) + call stdlib${ii}$_${ri}$laset('A',n-nr,nr,zero,zero,v(nr+1,1_${ik}$),ldv) + call stdlib${ii}$_${ri}$laset('A',nr,n-nr,zero,zero,v(1_${ik}$,nr+1),ldv) + call stdlib${ii}$_${ri}$laset('A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv) + call stdlib${ii}$_${ri}$ormlq('R','N',n,n,nr,u(nr+1,1_${ik}$),ldu,work(n+1),v, ldv, work(n+& nr+1),lwork-n-nr,ierr) - call stdlib_${ri}$lapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_${ri}$lapmt( .false., n, n, v, ldv, iwork ) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_${ri}$laset('A',m-nr,nr,zero,zero,u(nr+1,1),ldu) + call stdlib${ii}$_${ri}$laset('A',m-nr,nr,zero,zero,u(nr+1,1_${ik}$),ldu) if ( nr < n1 ) then - call stdlib_${ri}$laset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) - call stdlib_${ri}$laset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_${ri}$laset('A',nr,n1-nr,zero,zero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_${ri}$laset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) end if end if end if @@ -14215,10 +14209,10 @@ module stdlib_linalg_lapack_${ri}$ end if ! the q matrix from the first qrf is built into the left singular ! vectors matrix u. - if ( .not. wntuf )call stdlib_${ri}$ormqr( 'L', 'N', m, n1, n, a, lda, work, u,ldu, work(& + if ( .not. wntuf )call stdlib${ii}$_${ri}$ormqr( 'L', 'N', m, n1, n, a, lda, work, u,ldu, work(& n+1), lwork-n, ierr ) - if ( rowprm .and. .not.wntuf )call stdlib_${ri}$laswp( n1, u, ldu, 1, m-1, iwork(n+1), -& - 1 ) + if ( rowprm .and. .not.wntuf )call stdlib${ii}$_${ri}$laswp( n1, u, ldu, 1_${ik}$, m-1, iwork(n+1), -& + 1_${ik}$ ) ! ... end of the "full svd" branch end if ! check whether some singular values are returned as zeros, e.g. @@ -14226,27 +14220,27 @@ module stdlib_linalg_lapack_${ri}$ p = nr do q = p, 1, -1 if ( s(q) > zero ) go to 4002 - nr = nr - 1 + nr = nr - 1_${ik}$ end do 4002 continue ! .. if numerical rank deficiency is detected, the truncated ! singular values are set to zero. - if ( nr < n ) call stdlib_${ri}$laset( 'G', n-nr,1, zero,zero, s(nr+1), n ) + if ( nr < n ) call stdlib${ii}$_${ri}$laset( 'G', n-nr,1_${ik}$, zero,zero, s(nr+1), n ) ! .. undo scaling; this may cause overflow in the largest singular ! values. - if ( ascaled )call stdlib_${ri}$lascl( 'G',0,0, one,sqrt(real(m,KIND=${rk}$)), nr,1, s, n, ierr & + if ( ascaled )call stdlib${ii}$_${ri}$lascl( 'G',0_${ik}$,0_${ik}$, one,sqrt(real(m,KIND=${rk}$)), nr,1_${ik}$, s, n, ierr & ) - if ( conda ) rwork(1) = sconda - rwork(2) = p - nr + if ( conda ) rwork(1_${ik}$) = sconda + rwork(2_${ik}$) = p - nr ! .. p-nr is the number of singular values that are computed as - ! exact zeros in stdlib_${ri}$gesvd() applied to the (possibly truncated) + ! exact zeros in stdlib${ii}$_${ri}$gesvd() applied to the (possibly truncated) ! full row rank triangular (trapezoidal) factor of a. numrank = nr return - end subroutine stdlib_${ri}$gesvdq + end subroutine stdlib${ii}$_${ri}$gesvdq - pure subroutine stdlib_${ri}$gesvj( joba, jobu, jobv, m, n, a, lda, sva, mv, v,ldv, work, lwork, & + pure subroutine stdlib${ii}$_${ri}$gesvj( joba, jobu, jobv, m, n, a, lda, sva, mv, v,ldv, work, lwork, & !! DGESVJ: computes the singular value decomposition (SVD) of a real !! M-by-N matrix A, where M >= N. The SVD of A is written as !! [++] [xx] [x0] [xx] @@ -14263,27 +14257,27 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, ldv, lwork, m, mv, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldv, lwork, m, mv, n character, intent(in) :: joba, jobu, jobv ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*), v(ldv,*), work(lwork) real(${rk}$), intent(out) :: sva(n) ! ===================================================================== ! Local Parameters - integer(ilp), parameter :: nsweep = 30 + integer(${ik}$), parameter :: nsweep = 30_${ik}$ ! Local Scalars real(${rk}$) :: aapp, aapp0, aapq, aaqq, apoaq, aqoap, big, bigtheta, cs, ctol, epsln, & large, mxaapq, mxsinj, rootbig, rooteps, rootsfmin, roottol, skl, sfmin, small, sn, t, & temp1, theta, thsign, tol - integer(ilp) :: blskip, emptsw, i, ibr, ierr, igl, ijblsk, ir1, iswrot, jbc, jgl, kbl, & + integer(${ik}$) :: blskip, emptsw, i, ibr, ierr, igl, ijblsk, ir1, iswrot, jbc, jgl, kbl, & lkahead, mvl, n2, n34, n4, nbl, notrot, p, pskipped, q, rowskip, swband logical(lk) :: applv, goscale, lower, lsvec, noscale, rotok, rsvec, uctol, & upper ! Local Arrays - real(${rk}$) :: fastr(5) + real(${rk}$) :: fastr(5_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,min,real,sign,sqrt ! from lapack @@ -14297,31 +14291,31 @@ module stdlib_linalg_lapack_${ri}$ upper = stdlib_lsame( joba, 'U' ) lower = stdlib_lsame( joba, 'L' ) if( .not.( upper .or. lower .or. stdlib_lsame( joba, 'G' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( lsvec .or. uctol .or. stdlib_lsame( jobu, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( rsvec .or. applv .or. stdlib_lsame( jobv, 'N' ) ) ) then - info = -3 - else if( m<0 ) then - info = -4 - else if( ( n<0 ) .or. ( n>m ) ) then - info = -5 + info = -3_${ik}$ + else if( m<0_${ik}$ ) then + info = -4_${ik}$ + else if( ( n<0_${ik}$ ) .or. ( n>m ) ) then + info = -5_${ik}$ else if( lda=one ) then - info = -4 - call stdlib_xerbla( 'DGESVJ', -info ) + info = -4_${ik}$ + call stdlib${ii}$_xerbla( 'DGESVJ', -info ) return end if ! initialize the right singular vector matrix. if( rsvec ) then mvl = n - call stdlib_${ri}$laset( 'A', mvl, n, zero, one, v, ldv ) + call stdlib${ii}$_${ri}$laset( 'A', mvl, n, zero, one, v, ldv ) else if( applv ) then mvl = mv end if @@ -14384,10 +14378,10 @@ module stdlib_linalg_lapack_${ri}$ do p = 1, n aapp = zero aaqq = one - call stdlib_${ri}$lassq( m-p+1, a( p, p ), 1, aapp, aaqq ) + call stdlib${ii}$_${ri}$lassq( m-p+1, a( p, p ), 1_${ik}$, aapp, aaqq ) if( aapp>big ) then - info = -6 - call stdlib_xerbla( 'DGESVJ', -info ) + info = -6_${ik}$ + call stdlib${ii}$_xerbla( 'DGESVJ', -info ) return end if aaqq = sqrt( aaqq ) @@ -14409,10 +14403,10 @@ module stdlib_linalg_lapack_${ri}$ do p = 1, n aapp = zero aaqq = one - call stdlib_${ri}$lassq( p, a( 1, p ), 1, aapp, aaqq ) + call stdlib${ii}$_${ri}$lassq( p, a( 1_${ik}$, p ), 1_${ik}$, aapp, aaqq ) if( aapp>big ) then - info = -6 - call stdlib_xerbla( 'DGESVJ', -info ) + info = -6_${ik}$ + call stdlib${ii}$_xerbla( 'DGESVJ', -info ) return end if aaqq = sqrt( aaqq ) @@ -14434,10 +14428,10 @@ module stdlib_linalg_lapack_${ri}$ do p = 1, n aapp = zero aaqq = one - call stdlib_${ri}$lassq( m, a( 1, p ), 1, aapp, aaqq ) + call stdlib${ii}$_${ri}$lassq( m, a( 1_${ik}$, p ), 1_${ik}$, aapp, aaqq ) if( aapp>big ) then - info = -6 - call stdlib_xerbla( 'DGESVJ', -info ) + info = -6_${ik}$ + call stdlib${ii}$_xerbla( 'DGESVJ', -info ) return end if aaqq = sqrt( aaqq ) @@ -14467,29 +14461,29 @@ module stdlib_linalg_lapack_${ri}$ end do ! #:) quick return for zero matrix if( aapp==zero ) then - if( lsvec )call stdlib_${ri}$laset( 'G', m, n, zero, one, a, lda ) - work( 1 ) = one - work( 2 ) = zero - work( 3 ) = zero - work( 4 ) = zero - work( 5 ) = zero - work( 6 ) = zero + if( lsvec )call stdlib${ii}$_${ri}$laset( 'G', m, n, zero, one, a, lda ) + work( 1_${ik}$ ) = one + work( 2_${ik}$ ) = zero + work( 3_${ik}$ ) = zero + work( 4_${ik}$ ) = zero + work( 5_${ik}$ ) = zero + work( 6_${ik}$ ) = zero return end if ! #:) quick return for one-column matrix - if( n==1 ) then - if( lsvec )call stdlib_${ri}$lascl( 'G', 0, 0, sva( 1 ), skl, m, 1,a( 1, 1 ), lda, ierr ) + if( n==1_${ik}$ ) then + if( lsvec )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, sva( 1_${ik}$ ), skl, m, 1_${ik}$,a( 1_${ik}$, 1_${ik}$ ), lda, ierr ) - work( 1 ) = one / skl - if( sva( 1 )>=sfmin ) then - work( 2 ) = one + work( 1_${ik}$ ) = one / skl + if( sva( 1_${ik}$ )>=sfmin ) then + work( 2_${ik}$ ) = one else - work( 2 ) = zero + work( 2_${ik}$ ) = zero end if - work( 3 ) = zero - work( 4 ) = zero - work( 5 ) = zero - work( 6 ) = zero + work( 3_${ik}$ ) = zero + work( 4_${ik}$ ) = zero + work( 5_${ik}$ ) = zero + work( 6_${ik}$ ) = zero return end if ! protect small singular values from underflow, and try to @@ -14518,57 +14512,57 @@ module stdlib_linalg_lapack_${ri}$ end if ! scale, if necessary if( temp1/=one ) then - call stdlib_${ri}$lascl( 'G', 0, 0, one, temp1, n, 1, sva, n, ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, temp1, n, 1_${ik}$, sva, n, ierr ) end if skl= temp1*skl if( skl/=one ) then - call stdlib_${ri}$lascl( joba, 0, 0, one, skl, m, n, a, lda, ierr ) + call stdlib${ii}$_${ri}$lascl( joba, 0_${ik}$, 0_${ik}$, one, skl, m, n, a, lda, ierr ) skl= one / skl end if ! row-cyclic jacobi svd algorithm with column pivoting - emptsw = ( n*( n-1 ) ) / 2 - notrot = 0 - fastr( 1 ) = zero + emptsw = ( n*( n-1 ) ) / 2_${ik}$ + notrot = 0_${ik}$ + fastr( 1_${ik}$ ) = zero ! a is represented in factored form a = a * diag(work), where diag(work) ! is initialized to identity. work is updated during fast scaled ! rotations. do q = 1, n work( q ) = one end do - swband = 3 + swband = 3_${ik}$ ! [tp] swband is a tuning parameter [tp]. it is meaningful and effective - ! if stdlib_${ri}$gesvj is used as a computational routine in the preconditioned - ! jacobi svd algorithm stdlib_${ri}$gesvj. for sweeps i=1:swband the procedure + ! if stdlib${ii}$_${ri}$gesvj is used as a computational routine in the preconditioned + ! jacobi svd algorithm stdlib${ii}$_${ri}$gesvj. for sweeps i=1:swband the procedure ! works on pivots inside a band-like region around the diagonal. ! the boundaries are determined dynamically, based on the number of ! pivots above a threshold. - kbl = min( 8, n ) + kbl = min( 8_${ik}$, n ) ! [tp] kbl is a tuning parameter that defines the tile size in the ! tiling of the p-q loops of pivot pairs. in general, an optimal ! value of kbl depends on the matrix dimensions and on the ! parameters of the computer's memory. nbl = n / kbl - if( ( nbl*kbl )/=n )nbl = nbl + 1 - blskip = kbl**2 + if( ( nbl*kbl )/=n )nbl = nbl + 1_${ik}$ + blskip = kbl**2_${ik}$ ! [tp] blkskip is a tuning parameter that depends on swband and kbl. - rowskip = min( 5, kbl ) + rowskip = min( 5_${ik}$, kbl ) ! [tp] rowskip is a tuning parameter. - lkahead = 1 + lkahead = 1_${ik}$ ! [tp] lkahead is a tuning parameter. ! quasi block transformations, using the lower (upper) triangular ! structure of the input matrix. the quasi-block-cycling usually ! invokes cubic convergence. big part of this cycle is done inside ! canonical subspaces of dimensions less than m. - if( ( lower .or. upper ) .and. ( n>max( 64, 4*kbl ) ) ) then + if( ( lower .or. upper ) .and. ( n>max( 64_${ik}$, 4_${ik}$*kbl ) ) ) then ! [tp] the number of partition levels and the actual partition are ! tuning parameters. - n4 = n / 4 - n2 = n / 2 - n34 = 3*n4 + n4 = n / 4_${ik}$ + n2 = n / 2_${ik}$ + n34 = 3_${ik}$*n4 if( applv ) then - q = 0 + q = 0_${ik}$ else - q = 1 + q = 1_${ik}$ end if if( lower ) then ! this works very well on lower triangular matrices, in particular @@ -14578,32 +14572,32 @@ module stdlib_linalg_lapack_${ri}$ ! [+ + 0 0] [0 0] ! [+ + x 0] actually work on [x 0] [x 0] ! [+ + x x] [x x]. [x x] - call stdlib_${ri}$gsvj0( jobv, m-n34, n-n34, a( n34+1, n34+1 ), lda,work( n34+1 ), & - sva( n34+1 ), mvl,v( n34*q+1, n34+1 ), ldv, epsln, sfmin, tol,2, work( n+1 ), & + call stdlib${ii}$_${ri}$gsvj0( jobv, m-n34, n-n34, a( n34+1, n34+1 ), lda,work( n34+1 ), & + sva( n34+1 ), mvl,v( n34*q+1, n34+1 ), ldv, epsln, sfmin, tol,2_${ik}$, work( n+1 ), & lwork-n, ierr ) - call stdlib_${ri}$gsvj0( jobv, m-n2, n34-n2, a( n2+1, n2+1 ), lda,work( n2+1 ), sva( & - n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 2,work( n+1 ), lwork-n, & + call stdlib${ii}$_${ri}$gsvj0( jobv, m-n2, n34-n2, a( n2+1, n2+1 ), lda,work( n2+1 ), sva( & + n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 2_${ik}$,work( n+1 ), lwork-n, & ierr ) - call stdlib_${ri}$gsvj1( jobv, m-n2, n-n2, n4, a( n2+1, n2+1 ), lda,work( n2+1 ), sva(& - n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1,work( n+1 ), lwork-n, & + call stdlib${ii}$_${ri}$gsvj1( jobv, m-n2, n-n2, n4, a( n2+1, n2+1 ), lda,work( n2+1 ), sva(& + n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1_${ik}$,work( n+1 ), lwork-n, & ierr ) - call stdlib_${ri}$gsvj0( jobv, m-n4, n2-n4, a( n4+1, n4+1 ), lda,work( n4+1 ), sva( & - n4+1 ), mvl,v( n4*q+1, n4+1 ), ldv, epsln, sfmin, tol, 1,work( n+1 ), lwork-n, & + call stdlib${ii}$_${ri}$gsvj0( jobv, m-n4, n2-n4, a( n4+1, n4+1 ), lda,work( n4+1 ), sva( & + n4+1 ), mvl,v( n4*q+1, n4+1 ), ldv, epsln, sfmin, tol, 1_${ik}$,work( n+1 ), lwork-n, & ierr ) - call stdlib_${ri}$gsvj0( jobv, m, n4, a, lda, work, sva, mvl, v, ldv,epsln, sfmin, & - tol, 1, work( n+1 ), lwork-n,ierr ) - call stdlib_${ri}$gsvj1( jobv, m, n2, n4, a, lda, work, sva, mvl, v,ldv, epsln, sfmin,& - tol, 1, work( n+1 ),lwork-n, ierr ) + call stdlib${ii}$_${ri}$gsvj0( jobv, m, n4, a, lda, work, sva, mvl, v, ldv,epsln, sfmin, & + tol, 1_${ik}$, work( n+1 ), lwork-n,ierr ) + call stdlib${ii}$_${ri}$gsvj1( jobv, m, n2, n4, a, lda, work, sva, mvl, v,ldv, epsln, sfmin,& + tol, 1_${ik}$, work( n+1 ),lwork-n, ierr ) else if( upper ) then - call stdlib_${ri}$gsvj0( jobv, n4, n4, a, lda, work, sva, mvl, v, ldv,epsln, sfmin, & - tol, 2, work( n+1 ), lwork-n,ierr ) - call stdlib_${ri}$gsvj0( jobv, n2, n4, a( 1, n4+1 ), lda, work( n4+1 ),sva( n4+1 ), & - mvl, v( n4*q+1, n4+1 ), ldv,epsln, sfmin, tol, 1, work( n+1 ), lwork-n,ierr ) + call stdlib${ii}$_${ri}$gsvj0( jobv, n4, n4, a, lda, work, sva, mvl, v, ldv,epsln, sfmin, & + tol, 2_${ik}$, work( n+1 ), lwork-n,ierr ) + call stdlib${ii}$_${ri}$gsvj0( jobv, n2, n4, a( 1_${ik}$, n4+1 ), lda, work( n4+1 ),sva( n4+1 ), & + mvl, v( n4*q+1, n4+1 ), ldv,epsln, sfmin, tol, 1_${ik}$, work( n+1 ), lwork-n,ierr ) - call stdlib_${ri}$gsvj1( jobv, n2, n2, n4, a, lda, work, sva, mvl, v,ldv, epsln, & - sfmin, tol, 1, work( n+1 ),lwork-n, ierr ) - call stdlib_${ri}$gsvj0( jobv, n2+n4, n4, a( 1, n2+1 ), lda,work( n2+1 ), sva( n2+1 ),& - mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1,work( n+1 ), lwork-n, ierr ) + call stdlib${ii}$_${ri}$gsvj1( jobv, n2, n2, n4, a, lda, work, sva, mvl, v,ldv, epsln, & + sfmin, tol, 1_${ik}$, work( n+1 ),lwork-n, ierr ) + call stdlib${ii}$_${ri}$gsvj0( jobv, n2+n4, n4, a( 1_${ik}$, n2+1 ), lda,work( n2+1 ), sva( n2+1 ),& + mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1_${ik}$,work( n+1 ), lwork-n, ierr ) end if end if @@ -14612,23 +14606,23 @@ module stdlib_linalg_lapack_${ri}$ ! .. go go go ... mxaapq = zero mxsinj = zero - iswrot = 0 - notrot = 0 - pskipped = 0 + iswrot = 0_${ik}$ + notrot = 0_${ik}$ + pskipped = 0_${ik}$ ! each sweep is unrolled using kbl-by-kbl tiles over the pivot pairs ! 1 <= p < q <= n. this is the first step toward a blocked implementation ! of the rotations. new implementation, based on block transformations, ! is under development. loop_2000: do ibr = 1, nbl - igl = ( ibr-1 )*kbl + 1 + igl = ( ibr-1 )*kbl + 1_${ik}$ loop_1002: do ir1 = 0, min( lkahead, nbl-ibr ) igl = igl + ir1*kbl loop_2001: do p = igl, min( igl+kbl-1, n-1 ) ! .. de rijk's pivoting - q = stdlib_i${ri}$amax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib${ii}$_i${ri}$amax( n-p+1, sva( p ), 1_${ik}$ ) + p - 1_${ik}$ if( p/=q ) then - call stdlib_${ri}$swap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_${ri}$swap( mvl, v( 1, p ), 1,v( 1, q ), 1 ) + call stdlib${ii}$_${ri}$swap( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) + if( rsvec )call stdlib${ii}$_${ri}$swap( mvl, v( 1_${ik}$, p ), 1_${ik}$,v( 1_${ik}$, q ), 1_${ik}$ ) temp1 = sva( p ) sva( p ) = sva( q ) sva( q ) = temp1 @@ -14636,24 +14630,24 @@ module stdlib_linalg_lapack_${ri}$ work( p ) = work( q ) work( q ) = temp1 end if - if( ir1==0 ) then + if( ir1==0_${ik}$ ) then ! column norms are periodically updated by explicit ! norm computation. ! caveat: - ! unfortunately, some blas implementations compute stdlib_${ri}$nrm2(m,a(1,p),1) - ! as sqrt(stdlib_${ri}$dot(m,a(1,p),1,a(1,p),1)), which may cause the result to + ! unfortunately, some blas implementations compute stdlib${ii}$_${ri}$nrm2(m,a(1,p),1) + ! as sqrt(stdlib${ii}$_${ri}$dot(m,a(1,p),1,a(1,p),1)), which may cause the result to ! overflow for ||a(:,p)||_2 > sqrt(overflow_threshold), and to ! underflow for ||a(:,p)||_2 < sqrt(underflow_threshold). - ! hence, stdlib_${ri}$nrm2 cannot be trusted, not even in the case when + ! hence, stdlib${ii}$_${ri}$nrm2 cannot be trusted, not even in the case when ! the true norm is far from the under(over)flow boundaries. - ! if properly implemented stdlib_${ri}$nrm2 is available, the if-then-else - ! below should read "aapp = stdlib_${ri}$nrm2( m, a(1,p), 1 ) * work(p)". + ! if properly implemented stdlib${ii}$_${ri}$nrm2 is available, the if-then-else + ! below should read "aapp = stdlib${ii}$_${ri}$nrm2( m, a(1,p), 1 ) * work(p)". if( ( sva( p )rootsfmin ) ) then - sva( p ) = stdlib_${ri}$nrm2( m, a( 1, p ), 1 )*work( p ) + sva( p ) = stdlib${ii}$_${ri}$nrm2( m, a( 1_${ik}$, p ), 1_${ik}$ )*work( p ) else temp1 = zero aapp = one - call stdlib_${ri}$lassq( m, a( 1, p ), 1, temp1, aapp ) + call stdlib${ii}$_${ri}$lassq( m, a( 1_${ik}$, p ), 1_${ik}$, temp1, aapp ) sva( p ) = temp1*sqrt( aapp )*work( p ) end if aapp = sva( p ) @@ -14661,7 +14655,7 @@ module stdlib_linalg_lapack_${ri}$ aapp = sva( p ) end if if( aapp>zero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2002: do q = p + 1, min( igl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -14669,25 +14663,25 @@ module stdlib_linalg_lapack_${ri}$ if( aaqq>=one ) then rotok = ( small*aapp )<=aaqq if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_${ri}$dot( m, a( 1, p ), 1, a( 1,q ), 1 )*work( & + aapq = ( stdlib${ii}$_${ri}$dot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*work( & p )*work( q ) /aaqq ) / aapp else - call stdlib_${ri}$copy( m, a( 1, p ), 1,work( n+1 ), 1 ) - call stdlib_${ri}$lascl( 'G', 0, 0, aapp,work( p ), m, 1,work( n+& - 1 ), lda, ierr ) - aapq = stdlib_${ri}$dot( m, work( n+1 ), 1,a( 1, q ), 1 )*work( & + call stdlib${ii}$_${ri}$copy( m, a( 1_${ik}$, p ), 1_${ik}$,work( n+1 ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp,work( p ), m, 1_${ik}$,work( n+& + 1_${ik}$ ), lda, ierr ) + aapq = stdlib${ii}$_${ri}$dot( m, work( n+1 ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ )*work( & q ) / aaqq end if else rotok = aapp<=( aaqq / small ) if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_${ri}$dot( m, a( 1, p ), 1, a( 1,q ), 1 )*work( & + aapq = ( stdlib${ii}$_${ri}$dot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*work( & p )*work( q ) /aaqq ) / aapp else - call stdlib_${ri}$copy( m, a( 1, q ), 1,work( n+1 ), 1 ) - call stdlib_${ri}$lascl( 'G', 0, 0, aaqq,work( q ), m, 1,work( n+& - 1 ), lda, ierr ) - aapq = stdlib_${ri}$dot( m, work( n+1 ), 1,a( 1, p ), 1 )*work( & + call stdlib${ii}$_${ri}$copy( m, a( 1_${ik}$, q ), 1_${ik}$,work( n+1 ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq,work( q ), m, 1_${ik}$,work( n+& + 1_${ik}$ ), lda, ierr ) + aapq = stdlib${ii}$_${ri}$dot( m, work( n+1 ), 1_${ik}$,a( 1_${ik}$, p ), 1_${ik}$ )*work( & p ) / aapp end if end if @@ -14696,10 +14690,10 @@ module stdlib_linalg_lapack_${ri}$ if( abs( aapq )>tol ) then ! Rotate ! [rtd] rotated = rotated + one - if( ir1==0 ) then - notrot = 0 - pskipped = 0 - iswrot = iswrot + 1 + if( ir1==0_${ik}$ ) then + notrot = 0_${ik}$ + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ end if if( rotok ) then aqoap = aaqq / aapp @@ -14707,12 +14701,12 @@ module stdlib_linalg_lapack_${ri}$ theta = -half*abs(aqoap-apoaq)/aapq if( abs( theta )>bigtheta ) then t = half / theta - fastr( 3 ) = t*work( p ) / work( q ) - fastr( 4 ) = -t*work( q ) /work( p ) - call stdlib_${ri}$rotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) + fastr( 3_${ik}$ ) = t*work( p ) / work( q ) + fastr( 4_${ik}$ ) = -t*work( q ) /work( p ) + call stdlib${ii}$_${ri}$rotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$, fastr ) - if( rsvec )call stdlib_${ri}$rotm( mvl,v( 1, p ), 1,v( 1, q ),& - 1,fastr ) + if( rsvec )call stdlib${ii}$_${ri}$rotm( mvl,v( 1_${ik}$, p ), 1_${ik}$,v( 1_${ik}$, q ),& + 1_${ik}$,fastr ) sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq ) ) @@ -14732,68 +14726,68 @@ module stdlib_linalg_lapack_${ri}$ aqoap = work( q ) / work( p ) if( work( p )>=one ) then if( work( q )>=one ) then - fastr( 3 ) = t*apoaq - fastr( 4 ) = -t*aqoap + fastr( 3_${ik}$ ) = t*apoaq + fastr( 4_${ik}$ ) = -t*aqoap work( p ) = work( p )*cs work( q ) = work( q )*cs - call stdlib_${ri}$rotm( m, a( 1, p ), 1,a( 1, q ), 1,& + call stdlib${ii}$_${ri}$rotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$,& fastr ) - if( rsvec )call stdlib_${ri}$rotm( mvl,v( 1, p ), 1, v( & - 1, q ),1, fastr ) + if( rsvec )call stdlib${ii}$_${ri}$rotm( mvl,v( 1_${ik}$, p ), 1_${ik}$, v( & + 1_${ik}$, q ),1_${ik}$, fastr ) else - call stdlib_${ri}$axpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & - p ), 1 ) - call stdlib_${ri}$axpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & - 1, q ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( 1_${ik}$, & + p ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( & + 1_${ik}$, q ), 1_${ik}$ ) work( p ) = work( p )*cs work( q ) = work( q ) / cs if( rsvec ) then - call stdlib_${ri}$axpy( mvl, -t*aqoap,v( 1, q ), 1,v(& - 1, p ), 1 ) - call stdlib_${ri}$axpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& - v( 1, q ), 1 ) + call stdlib${ii}$_${ri}$axpy( mvl, -t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,v(& + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ), 1_${ik}$,& + v( 1_${ik}$, q ), 1_${ik}$ ) end if end if else if( work( q )>=one ) then - call stdlib_${ri}$axpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & - ), 1 ) - call stdlib_${ri}$axpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q & + ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( m, -cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) work( p ) = work( p ) / cs work( q ) = work( q )*cs if( rsvec ) then - call stdlib_${ri}$axpy( mvl, t*apoaq,v( 1, p ), 1,v( & - 1, q ), 1 ) - call stdlib_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1, q ), & - 1,v( 1, p ), 1 ) + call stdlib${ii}$_${ri}$axpy( mvl, t*apoaq,v( 1_${ik}$, p ), 1_${ik}$,v( & + 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q ), & + 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if else if( work( p )>=work( q ) )then - call stdlib_${ri}$axpy( m, -t*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) - call stdlib_${ri}$axpy( m, cs*sn*apoaq,a( 1, p ), 1,& - a( 1, q ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,& + a( 1_${ik}$, q ), 1_${ik}$ ) work( p ) = work( p )*cs work( q ) = work( q ) / cs if( rsvec ) then - call stdlib_${ri}$axpy( mvl,-t*aqoap,v( 1, q ), 1,& - v( 1, p ), 1 ) - call stdlib_${ri}$axpy( mvl,cs*sn*apoaq,v( 1, p ),& - 1,v( 1, q ), 1 ) + call stdlib${ii}$_${ri}$axpy( mvl,-t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,& + v( 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ),& + 1_${ik}$,v( 1_${ik}$, q ), 1_${ik}$ ) end if else - call stdlib_${ri}$axpy( m, t*apoaq,a( 1, p ), 1,a( 1,& - q ), 1 ) - call stdlib_${ri}$axpy( m,-cs*sn*aqoap,a( 1, q ), 1,& - a( 1, p ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$,& + q ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( m,-cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,& + a( 1_${ik}$, p ), 1_${ik}$ ) work( p ) = work( p ) / cs work( q ) = work( q )*cs if( rsvec ) then - call stdlib_${ri}$axpy( mvl,t*apoaq, v( 1, p ),1, & - v( 1, q ), 1 ) - call stdlib_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1, q )& - , 1,v( 1, p ), 1 ) + call stdlib${ii}$_${ri}$axpy( mvl,t*apoaq, v( 1_${ik}$, p ),1_${ik}$, & + v( 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q )& + , 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if end if end if @@ -14801,15 +14795,15 @@ module stdlib_linalg_lapack_${ri}$ end if else ! .. have to use modified gram-schmidt like transformation - call stdlib_${ri}$copy( m, a( 1, p ), 1,work( n+1 ), 1 ) - call stdlib_${ri}$lascl( 'G', 0, 0, aapp, one, m,1, work( n+1 ), & + call stdlib${ii}$_${ri}$copy( m, a( 1_${ik}$, p ), 1_${ik}$,work( n+1 ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one, m,1_${ik}$, work( n+1 ), & lda,ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, aaqq, one, m,1, a( 1, q ), & + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one, m,1_${ik}$, a( 1_${ik}$, q ), & lda, ierr ) temp1 = -aapq*work( p ) / work( q ) - call stdlib_${ri}$axpy( m, temp1, work( n+1 ), 1,a( 1, q ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, temp1, work( n+1 ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) - call stdlib_${ri}$lascl( 'G', 0, 0, one, aaqq, m,1, a( 1, q ), & + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq, m,1_${ik}$, a( 1_${ik}$, q ), & lda, ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) @@ -14817,42 +14811,42 @@ module stdlib_linalg_lapack_${ri}$ ! end if rotok then ... else ! in the case of cancellation in updating sva(q), sva(p) ! recompute sva(q), sva(p). - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_${ri}$nrm2( m, a( 1, q ), 1 )*work( q ) + sva( q ) = stdlib${ii}$_${ri}$nrm2( m, a( 1_${ik}$, q ), 1_${ik}$ )*work( q ) else t = zero aaqq = one - call stdlib_${ri}$lassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_${ri}$lassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq )*work( q ) end if end if if( ( aapp / aapp0 )<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_${ri}$nrm2( m, a( 1, p ), 1 )*work( p ) + aapp = stdlib${ii}$_${ri}$nrm2( m, a( 1_${ik}$, p ), 1_${ik}$ )*work( p ) else t = zero aapp = one - call stdlib_${ri}$lassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_${ri}$lassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp )*work( p ) end if sva( p ) = aapp end if else ! a(:,p) and a(:,q) already numerically orthogonal - if( ir1==0 )notrot = notrot + 1 + if( ir1==0_${ik}$ )notrot = notrot + 1_${ik}$ ! [rtd] skipped = skipped + 1 - pskipped = pskipped + 1 + pskipped = pskipped + 1_${ik}$ end if else ! a(:,q) is zero column - if( ir1==0 )notrot = notrot + 1 - pskipped = pskipped + 1 + if( ir1==0_${ik}$ )notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then - if( ir1==0 )aapp = -aapp - notrot = 0 + if( ir1==0_${ik}$ )aapp = -aapp + notrot = 0_${ik}$ go to 2103 end if end do loop_2002 @@ -14862,7 +14856,7 @@ module stdlib_linalg_lapack_${ri}$ sva( p ) = aapp else sva( p ) = aapp - if( ( ir1==0 ) .and. ( aapp==zero ) )notrot = notrot + min( igl+kbl-1, & + if( ( ir1==0_${ik}$ ) .and. ( aapp==zero ) )notrot = notrot + min( igl+kbl-1, & n ) - p end if end do loop_2001 @@ -14871,15 +14865,15 @@ module stdlib_linalg_lapack_${ri}$ end do loop_1002 ! end of ir1-loop ! ... go to the off diagonal blocks - igl = ( ibr-1 )*kbl + 1 + igl = ( ibr-1 )*kbl + 1_${ik}$ loop_2010: do jbc = ibr + 1, nbl - jgl = ( jbc-1 )*kbl + 1 + jgl = ( jbc-1 )*kbl + 1_${ik}$ ! doing the block at ( ibr, jbc ) - ijblsk = 0 + ijblsk = 0_${ik}$ loop_2100: do p = igl, min( igl+kbl-1, n ) aapp = sva( p ) if( aapp>zero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2200: do q = jgl, min( jgl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -14893,13 +14887,13 @@ module stdlib_linalg_lapack_${ri}$ rotok = ( small*aaqq )<=aapp end if if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_${ri}$dot( m, a( 1, p ), 1, a( 1,q ), 1 )*work( & + aapq = ( stdlib${ii}$_${ri}$dot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*work( & p )*work( q ) /aaqq ) / aapp else - call stdlib_${ri}$copy( m, a( 1, p ), 1,work( n+1 ), 1 ) - call stdlib_${ri}$lascl( 'G', 0, 0, aapp,work( p ), m, 1,work( n+& - 1 ), lda, ierr ) - aapq = stdlib_${ri}$dot( m, work( n+1 ), 1,a( 1, q ), 1 )*work( & + call stdlib${ii}$_${ri}$copy( m, a( 1_${ik}$, p ), 1_${ik}$,work( n+1 ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp,work( p ), m, 1_${ik}$,work( n+& + 1_${ik}$ ), lda, ierr ) + aapq = stdlib${ii}$_${ri}$dot( m, work( n+1 ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ )*work( & q ) / aaqq end if else @@ -14909,23 +14903,23 @@ module stdlib_linalg_lapack_${ri}$ rotok = aaqq<=( aapp / small ) end if if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_${ri}$dot( m, a( 1, p ), 1, a( 1,q ), 1 )*work( & + aapq = ( stdlib${ii}$_${ri}$dot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*work( & p )*work( q ) /aaqq ) / aapp else - call stdlib_${ri}$copy( m, a( 1, q ), 1,work( n+1 ), 1 ) - call stdlib_${ri}$lascl( 'G', 0, 0, aaqq,work( q ), m, 1,work( n+& - 1 ), lda, ierr ) - aapq = stdlib_${ri}$dot( m, work( n+1 ), 1,a( 1, p ), 1 )*work( & + call stdlib${ii}$_${ri}$copy( m, a( 1_${ik}$, q ), 1_${ik}$,work( n+1 ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq,work( q ), m, 1_${ik}$,work( n+& + 1_${ik}$ ), lda, ierr ) + aapq = stdlib${ii}$_${ri}$dot( m, work( n+1 ), 1_${ik}$,a( 1_${ik}$, p ), 1_${ik}$ )*work( & p ) / aapp end if end if mxaapq = max( mxaapq, abs( aapq ) ) ! to rotate or not to rotate, that is the question ... if( abs( aapq )>tol ) then - notrot = 0 + notrot = 0_${ik}$ ! [rtd] rotated = rotated + 1 - pskipped = 0 - iswrot = iswrot + 1 + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ if( rotok ) then aqoap = aaqq / aapp apoaq = aapp / aaqq @@ -14933,12 +14927,12 @@ module stdlib_linalg_lapack_${ri}$ if( aaqq>aapp0 )theta = -theta if( abs( theta )>bigtheta ) then t = half / theta - fastr( 3 ) = t*work( p ) / work( q ) - fastr( 4 ) = -t*work( q ) /work( p ) - call stdlib_${ri}$rotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) + fastr( 3_${ik}$ ) = t*work( p ) / work( q ) + fastr( 4_${ik}$ ) = -t*work( q ) /work( p ) + call stdlib${ii}$_${ri}$rotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$, fastr ) - if( rsvec )call stdlib_${ri}$rotm( mvl,v( 1, p ), 1,v( 1, q ),& - 1,fastr ) + if( rsvec )call stdlib${ii}$_${ri}$rotm( mvl,v( 1_${ik}$, p ), 1_${ik}$,v( 1_${ik}$, q ),& + 1_${ik}$,fastr ) sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq ) ) @@ -14959,68 +14953,68 @@ module stdlib_linalg_lapack_${ri}$ aqoap = work( q ) / work( p ) if( work( p )>=one ) then if( work( q )>=one ) then - fastr( 3 ) = t*apoaq - fastr( 4 ) = -t*aqoap + fastr( 3_${ik}$ ) = t*apoaq + fastr( 4_${ik}$ ) = -t*aqoap work( p ) = work( p )*cs work( q ) = work( q )*cs - call stdlib_${ri}$rotm( m, a( 1, p ), 1,a( 1, q ), 1,& + call stdlib${ii}$_${ri}$rotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$,& fastr ) - if( rsvec )call stdlib_${ri}$rotm( mvl,v( 1, p ), 1, v( & - 1, q ),1, fastr ) + if( rsvec )call stdlib${ii}$_${ri}$rotm( mvl,v( 1_${ik}$, p ), 1_${ik}$, v( & + 1_${ik}$, q ),1_${ik}$, fastr ) else - call stdlib_${ri}$axpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & - p ), 1 ) - call stdlib_${ri}$axpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & - 1, q ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( 1_${ik}$, & + p ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( & + 1_${ik}$, q ), 1_${ik}$ ) if( rsvec ) then - call stdlib_${ri}$axpy( mvl, -t*aqoap,v( 1, q ), 1,v(& - 1, p ), 1 ) - call stdlib_${ri}$axpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& - v( 1, q ), 1 ) + call stdlib${ii}$_${ri}$axpy( mvl, -t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,v(& + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ), 1_${ik}$,& + v( 1_${ik}$, q ), 1_${ik}$ ) end if work( p ) = work( p )*cs work( q ) = work( q ) / cs end if else if( work( q )>=one ) then - call stdlib_${ri}$axpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & - ), 1 ) - call stdlib_${ri}$axpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q & + ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( m, -cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) if( rsvec ) then - call stdlib_${ri}$axpy( mvl, t*apoaq,v( 1, p ), 1,v( & - 1, q ), 1 ) - call stdlib_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1, q ), & - 1,v( 1, p ), 1 ) + call stdlib${ii}$_${ri}$axpy( mvl, t*apoaq,v( 1_${ik}$, p ), 1_${ik}$,v( & + 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q ), & + 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if work( p ) = work( p ) / cs work( q ) = work( q )*cs else if( work( p )>=work( q ) )then - call stdlib_${ri}$axpy( m, -t*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) - call stdlib_${ri}$axpy( m, cs*sn*apoaq,a( 1, p ), 1,& - a( 1, q ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,& + a( 1_${ik}$, q ), 1_${ik}$ ) work( p ) = work( p )*cs work( q ) = work( q ) / cs if( rsvec ) then - call stdlib_${ri}$axpy( mvl,-t*aqoap,v( 1, q ), 1,& - v( 1, p ), 1 ) - call stdlib_${ri}$axpy( mvl,cs*sn*apoaq,v( 1, p ),& - 1,v( 1, q ), 1 ) + call stdlib${ii}$_${ri}$axpy( mvl,-t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,& + v( 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ),& + 1_${ik}$,v( 1_${ik}$, q ), 1_${ik}$ ) end if else - call stdlib_${ri}$axpy( m, t*apoaq,a( 1, p ), 1,a( 1,& - q ), 1 ) - call stdlib_${ri}$axpy( m,-cs*sn*aqoap,a( 1, q ), 1,& - a( 1, p ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$,& + q ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( m,-cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,& + a( 1_${ik}$, p ), 1_${ik}$ ) work( p ) = work( p ) / cs work( q ) = work( q )*cs if( rsvec ) then - call stdlib_${ri}$axpy( mvl,t*apoaq, v( 1, p ),1, & - v( 1, q ), 1 ) - call stdlib_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1, q )& - , 1,v( 1, p ), 1 ) + call stdlib${ii}$_${ri}$axpy( mvl,t*apoaq, v( 1_${ik}$, p ),1_${ik}$, & + v( 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q )& + , 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if end if end if @@ -15028,30 +15022,30 @@ module stdlib_linalg_lapack_${ri}$ end if else if( aapp>aaqq ) then - call stdlib_${ri}$copy( m, a( 1, p ), 1,work( n+1 ), 1 ) + call stdlib${ii}$_${ri}$copy( m, a( 1_${ik}$, p ), 1_${ik}$,work( n+1 ), 1_${ik}$ ) - call stdlib_${ri}$lascl( 'G', 0, 0, aapp, one,m, 1, work( n+1 & + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, work( n+1 & ), lda,ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) temp1 = -aapq*work( p ) / work( q ) - call stdlib_${ri}$axpy( m, temp1, work( n+1 ),1, a( 1, q ), 1 & + call stdlib${ii}$_${ri}$axpy( m, temp1, work( n+1 ),1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ & ) - call stdlib_${ri}$lascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) else - call stdlib_${ri}$copy( m, a( 1, q ), 1,work( n+1 ), 1 ) + call stdlib${ii}$_${ri}$copy( m, a( 1_${ik}$, q ), 1_${ik}$,work( n+1 ), 1_${ik}$ ) - call stdlib_${ri}$lascl( 'G', 0, 0, aaqq, one,m, 1, work( n+1 & + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, work( n+1 & ), lda,ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) temp1 = -aapq*work( q ) / work( p ) - call stdlib_${ri}$axpy( m, temp1, work( n+1 ),1, a( 1, p ), 1 & + call stdlib${ii}$_${ri}$axpy( m, temp1, work( n+1 ),1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ & ) - call stdlib_${ri}$lascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, aapp,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) sva( p ) = aapp*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) @@ -15060,48 +15054,48 @@ module stdlib_linalg_lapack_${ri}$ ! end if rotok then ... else ! in the case of cancellation in updating sva(q) ! .. recompute sva(q) - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_${ri}$nrm2( m, a( 1, q ), 1 )*work( q ) + sva( q ) = stdlib${ii}$_${ri}$nrm2( m, a( 1_${ik}$, q ), 1_${ik}$ )*work( q ) else t = zero aaqq = one - call stdlib_${ri}$lassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_${ri}$lassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq )*work( q ) end if end if - if( ( aapp / aapp0 )**2<=rooteps ) then + if( ( aapp / aapp0 )**2_${ik}$<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_${ri}$nrm2( m, a( 1, p ), 1 )*work( p ) + aapp = stdlib${ii}$_${ri}$nrm2( m, a( 1_${ik}$, p ), 1_${ik}$ )*work( p ) else t = zero aapp = one - call stdlib_${ri}$lassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_${ri}$lassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp )*work( p ) end if sva( p ) = aapp end if ! end of ok rotation else - notrot = notrot + 1 + notrot = notrot + 1_${ik}$ ! [rtd] skipped = skipped + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if else - notrot = notrot + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if if( ( i<=swband ) .and. ( ijblsk>=blskip ) )then sva( p ) = aapp - notrot = 0 + notrot = 0_${ik}$ go to 2011 end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then aapp = -aapp - notrot = 0 + notrot = 0_${ik}$ go to 2203 end if end do loop_2200 @@ -15109,8 +15103,8 @@ module stdlib_linalg_lapack_${ri}$ 2203 continue sva( p ) = aapp else - if( aapp==zero )notrot = notrot +min( jgl+kbl-1, n ) - jgl + 1 - if( aapprootsfmin ) )then - sva( n ) = stdlib_${ri}$nrm2( m, a( 1, n ), 1 )*work( n ) + sva( n ) = stdlib${ii}$_${ri}$nrm2( m, a( 1_${ik}$, n ), 1_${ik}$ )*work( n ) else t = zero aapp = one - call stdlib_${ri}$lassq( m, a( 1, n ), 1, t, aapp ) + call stdlib${ii}$_${ri}$lassq( m, a( 1_${ik}$, n ), 1_${ik}$, t, aapp ) sva( n ) = t*sqrt( aapp )*work( n ) end if ! additional steering devices @@ -15143,20 +15137,20 @@ module stdlib_linalg_lapack_${ri}$ end do loop_1993 ! end i=1:nsweep loop ! #:( reaching this point means that the procedure has not converged. - info = nsweep - 1 + info = nsweep - 1_${ik}$ go to 1995 1994 continue ! #:) reaching this point means numerical convergence after the i-th ! sweep. - info = 0 + info = 0_${ik}$ ! #:) info = 0 confirms successful iterations. 1995 continue ! sort the singular values and find how many are above ! the underflow threshold. - n2 = 0 - n4 = 0 + n2 = 0_${ik}$ + n4 = 0_${ik}$ do p = 1, n - 1 - q = stdlib_i${ri}$amax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib${ii}$_i${ri}$amax( n-p+1, sva( p ), 1_${ik}$ ) + p - 1_${ik}$ if( p/=q ) then temp1 = sva( p ) sva( p ) = sva( q ) @@ -15164,68 +15158,68 @@ module stdlib_linalg_lapack_${ri}$ temp1 = work( p ) work( p ) = work( q ) work( q ) = temp1 - call stdlib_${ri}$swap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_${ri}$swap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) + call stdlib${ii}$_${ri}$swap( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) + if( rsvec )call stdlib${ii}$_${ri}$swap( mvl, v( 1_${ik}$, p ), 1_${ik}$, v( 1_${ik}$, q ), 1_${ik}$ ) end if if( sva( p )/=zero ) then - n4 = n4 + 1 - if( sva( p )*skl>sfmin )n2 = n2 + 1 + n4 = n4 + 1_${ik}$ + if( sva( p )*skl>sfmin )n2 = n2 + 1_${ik}$ end if end do if( sva( n )/=zero ) then - n4 = n4 + 1 - if( sva( n )*skl>sfmin )n2 = n2 + 1 + n4 = n4 + 1_${ik}$ + if( sva( n )*skl>sfmin )n2 = n2 + 1_${ik}$ end if ! normalize the left singular vectors. if( lsvec .or. uctol ) then do p = 1, n2 - call stdlib_${ri}$scal( m, work( p ) / sva( p ), a( 1, p ), 1 ) + call stdlib${ii}$_${ri}$scal( m, work( p ) / sva( p ), a( 1_${ik}$, p ), 1_${ik}$ ) end do end if ! scale the product of jacobi rotations (assemble the fast rotations). if( rsvec ) then if( applv ) then do p = 1, n - call stdlib_${ri}$scal( mvl, work( p ), v( 1, p ), 1 ) + call stdlib${ii}$_${ri}$scal( mvl, work( p ), v( 1_${ik}$, p ), 1_${ik}$ ) end do else do p = 1, n - temp1 = one / stdlib_${ri}$nrm2( mvl, v( 1, p ), 1 ) - call stdlib_${ri}$scal( mvl, temp1, v( 1, p ), 1 ) + temp1 = one / stdlib${ii}$_${ri}$nrm2( mvl, v( 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( mvl, temp1, v( 1_${ik}$, p ), 1_${ik}$ ) end do end if end if ! undo scaling, if necessary (and possible). - if( ( ( skl>one ) .and. ( sva( 1 )<( big / skl) ) ).or. ( ( skl( sfmin / skl) ) ) ) then + if( ( ( skl>one ) .and. ( sva( 1_${ik}$ )<( big / skl) ) ).or. ( ( skl( sfmin / skl) ) ) ) then do p = 1, n sva( p ) = skl*sva( p ) end do skl= one end if - work( 1 ) = skl + work( 1_${ik}$ ) = skl ! the singular values of a are skl*sva(1:n). if skl/=one ! then some of the singular values may overflow or underflow and ! the spectrum is given in this factored representation. - work( 2 ) = real( n4,KIND=${rk}$) + work( 2_${ik}$ ) = real( n4,KIND=${rk}$) ! n4 is the number of computed nonzero singular values of a. - work( 3 ) = real( n2,KIND=${rk}$) + work( 3_${ik}$ ) = real( n2,KIND=${rk}$) ! n2 is the number of singular values of a greater than sfmin. ! if n20 ) then + info = -11_${ik}$ + else if( n>0_${ik}$ ) then rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) else rowcnd = one end if end if - if( colequ .and. info==0 ) then + if( colequ .and. info==0_${ik}$ ) then rcmin = bignum rcmax = zero do j = 1, n @@ -15312,31 +15306,31 @@ module stdlib_linalg_lapack_${ri}$ rcmax = max( rcmax, c( j ) ) end do if( rcmin<=zero ) then - info = -12 - else if( n>0 ) then + info = -12_${ik}$ + else if( n>0_${ik}$ ) then colcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) else colcnd = one end if end if - if( info==0 ) then - if( ldb0 ) then + if( info>0_${ik}$ ) then ! compute the reciprocal pivot growth factor of the ! leading rank-deficient info columns of a. - rpvgrw = stdlib_${ri}$lantr( 'M', 'U', 'N', info, info, af, ldaf,work ) + rpvgrw = stdlib${ii}$_${ri}$lantr( 'M', 'U', 'N', info, info, af, ldaf,work ) if( rpvgrw==zero ) then rpvgrw = one else - rpvgrw = stdlib_${ri}$lange( 'M', n, info, a, lda, work ) / rpvgrw + rpvgrw = stdlib${ii}$_${ri}$lange( 'M', n, info, a, lda, work ) / rpvgrw end if - work( 1 ) = rpvgrw + work( 1_${ik}$ ) = rpvgrw rcond = zero return end if @@ -15383,21 +15377,21 @@ module stdlib_linalg_lapack_${ri}$ else norm = 'I' end if - anorm = stdlib_${ri}$lange( norm, n, n, a, lda, work ) - rpvgrw = stdlib_${ri}$lantr( 'M', 'U', 'N', n, n, af, ldaf, work ) + anorm = stdlib${ii}$_${ri}$lange( norm, n, n, a, lda, work ) + rpvgrw = stdlib${ii}$_${ri}$lantr( 'M', 'U', 'N', n, n, af, ldaf, work ) if( rpvgrw==zero ) then rpvgrw = one else - rpvgrw = stdlib_${ri}$lange( 'M', n, n, a, lda, work ) / rpvgrw + rpvgrw = stdlib${ii}$_${ri}$lange( 'M', n, n, a, lda, work ) / rpvgrw end if ! compute the reciprocal of the condition number of a. - call stdlib_${ri}$gecon( norm, n, af, ldaf, anorm, rcond, work, iwork, info ) + call stdlib${ii}$_${ri}$gecon( norm, n, af, ldaf, anorm, rcond, work, iwork, info ) ! compute the solution matrix x. - call stdlib_${ri}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_${ri}$getrs( trans, n, nrhs, af, ldaf, ipiv, x, ldx, info ) + call stdlib${ii}$_${ri}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_${ri}$getrs( trans, n, nrhs, af, ldaf, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_${ri}$gerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & + call stdlib${ii}$_${ri}$gerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & work, iwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -15422,14 +15416,14 @@ module stdlib_linalg_lapack_${ri}$ ferr( j ) = ferr( j ) / rowcnd end do end if - work( 1 ) = rpvgrw + work( 1_${ik}$ ) = rpvgrw ! set info = n+1 if the matrix is singular to working precision. - if( rcond= sfmin ) then - call stdlib_${ri}$scal( m-j, one / a( j, j ), a( j+1, j ), 1 ) + call stdlib${ii}$_${ri}$scal( 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=min( m, n ) ) then + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGETRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=min( m, n ) ) then ! use unblocked code. - call stdlib_${ri}$getrf2( m, n, a, lda, ipiv, info ) + call stdlib${ii}$_${ri}$getrf2( m, n, a, lda, ipiv, info ) else ! use blocked code. do j = 1, min( m, n ), nb jb = min( min( m, n )-j+1, nb ) ! factor diagonal and subdiagonal blocks and test for exact ! singularity. - call stdlib_${ri}$getrf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo ) + call stdlib${ii}$_${ri}$getrf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo ) ! adjust info and the pivot indices. - if( info==0 .and. iinfo>0 )info = iinfo + j - 1 + if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + j - 1_${ik}$ do i = j, min( m, j+jb-1 ) - ipiv( i ) = j - 1 + ipiv( i ) + ipiv( i ) = j - 1_${ik}$ + ipiv( i ) end do ! apply interchanges to columns 1:j-1. - call stdlib_${ri}$laswp( j-1, a, lda, j, j+jb-1, ipiv, 1 ) + call stdlib${ii}$_${ri}$laswp( j-1, a, lda, j, j+jb-1, ipiv, 1_${ik}$ ) if( j+jb<=n ) then ! apply interchanges to columns j+jb:n. - call stdlib_${ri}$laswp( n-j-jb+1, a( 1, j+jb ), lda, j, j+jb-1,ipiv, 1 ) + call stdlib${ii}$_${ri}$laswp( n-j-jb+1, a( 1_${ik}$, j+jb ), lda, j, j+jb-1,ipiv, 1_${ik}$ ) ! compute block row of u. - call stdlib_${ri}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, one, & + call stdlib${ii}$_${ri}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, one, & a( j, j ), lda, a( j, j+jb ),lda ) if( j+jb<=m ) then ! update trailing submatrix. - call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& + call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& one, a( j+jb, j ), lda,a( j, j+jb ), lda, one, a( j+jb, j+jb ),lda ) end if @@ -15661,10 +15655,10 @@ module stdlib_linalg_lapack_${ri}$ end do end if return - end subroutine stdlib_${ri}$getrf + end subroutine stdlib${ii}$_${ri}$getrf - pure recursive subroutine stdlib_${ri}$getrf2( m, n, a, lda, ipiv, info ) + pure recursive subroutine stdlib${ii}$_${ri}$getrf2( m, n, a, lda, ipiv, info ) !! DGETRF2: computes an LU factorization of a general M-by-N matrix A !! using partial pivoting with row interchanges. !! The factorization has the form @@ -15688,98 +15682,98 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars real(${rk}$) :: sfmin, temp - integer(ilp) :: i, iinfo, n1, n2 + integer(${ik}$) :: i, iinfo, n1, n2 ! 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_${ri}$scal( m-1, one / a( 1, 1 ), a( 2, 1 ), 1 ) + if( abs(a( 1_${ik}$, 1_${ik}$ )) >= sfmin ) then + call stdlib${ii}$_${ri}$scal( 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_${ri}$getrf2( m, n1, a, lda, ipiv, iinfo ) - if ( info==0 .and. iinfo>0 )info = iinfo + call stdlib${ii}$_${ri}$getrf2( m, n1, a, lda, ipiv, iinfo ) + if ( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo ! [ a12 ] ! apply interchanges to [ --- ] ! [ a22 ] - call stdlib_${ri}$laswp( n2, a( 1, n1+1 ), lda, 1, n1, ipiv, 1 ) + call stdlib${ii}$_${ri}$laswp( n2, a( 1_${ik}$, n1+1 ), lda, 1_${ik}$, n1, ipiv, 1_${ik}$ ) ! solve a12 - call stdlib_${ri}$trsm( 'L', 'L', 'N', 'U', n1, n2, one, a, lda,a( 1, n1+1 ), lda ) + call stdlib${ii}$_${ri}$trsm( 'L', 'L', 'N', 'U', n1, n2, one, a, lda,a( 1_${ik}$, n1+1 ), lda ) ! update a22 - call stdlib_${ri}$gemm( 'N', 'N', m-n1, n2, n1, -one, a( n1+1, 1 ), lda,a( 1, n1+1 ), & + call stdlib${ii}$_${ri}$gemm( '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_${ri}$getrf2( m-n1, n2, a( n1+1, n1+1 ), lda, ipiv( n1+1 ),iinfo ) + call stdlib${ii}$_${ri}$getrf2( m-n1, n2, a( n1+1, n1+1 ), lda, ipiv( n1+1 ),iinfo ) ! adjust info and the pivot indices - if ( info==0 .and. iinfo>0 )info = iinfo + n1 + 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_${ri}$laswp( n1, a( 1, 1 ), lda, n1+1, min( m, n), ipiv, 1 ) + call stdlib${ii}$_${ri}$laswp( n1, a( 1_${ik}$, 1_${ik}$ ), lda, n1+1, min( m, n), ipiv, 1_${ik}$ ) end if return - end subroutine stdlib_${ri}$getrf2 + end subroutine stdlib${ii}$_${ri}$getrf2 - pure subroutine stdlib_${ri}$getri( n, a, lda, ipiv, work, lwork, info ) + pure subroutine stdlib${ii}$_${ri}$getri( n, a, lda, ipiv, work, lwork, info ) !! DGETRI: computes the inverse of a matrix using the LU factorization !! computed by DGETRF. !! This method inverts U and then computes inv(A) by solving the system @@ -15788,52 +15782,52 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), 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, 'DGETRI', ' ', n, -1, -1, -1 ) + info = 0_${ik}$ + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGETRI', ' ', 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_${ri}$trtri, then u is singular, + ! form inv(u). if info > 0 from stdlib${ii}$_${ri}$trtri, then u is singular, ! and the inverse is not computed. - call stdlib_${ri}$trtri( 'UPPER', 'NON-UNIT', n, a, lda, info ) + call stdlib${ii}$_${ri}$trtri( '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. nb=n ) then - call stdlib_${ri}$geqr( m, n, a, lda, tq, -1, workq, -1, info2 ) - tszo = int( tq( 1 ),KIND=ilp) - lwo = int( workq( 1 ),KIND=ilp) - call stdlib_${ri}$gemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszo, b, ldb, workq, -1, & + call stdlib${ii}$_${ri}$geqr( m, n, a, lda, tq, -1_${ik}$, workq, -1_${ik}$, info2 ) + tszo = int( tq( 1_${ik}$ ),KIND=${ik}$) + lwo = int( workq( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_${ri}$gemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszo, b, ldb, workq, -1_${ik}$, & info2 ) - lwo = max( lwo, int( workq( 1 ),KIND=ilp) ) - call stdlib_${ri}$geqr( m, n, a, lda, tq, -2, workq, -2, info2 ) - tszm = int( tq( 1 ),KIND=ilp) - lwm = int( workq( 1 ),KIND=ilp) - call stdlib_${ri}$gemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszm, b, ldb, workq, -1, & + lwo = max( lwo, int( workq( 1_${ik}$ ),KIND=${ik}$) ) + call stdlib${ii}$_${ri}$geqr( m, n, a, lda, tq, -2_${ik}$, workq, -2_${ik}$, info2 ) + tszm = int( tq( 1_${ik}$ ),KIND=${ik}$) + lwm = int( workq( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_${ri}$gemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszm, b, ldb, workq, -1_${ik}$, & info2 ) - lwm = max( lwm, int( workq( 1 ),KIND=ilp) ) + lwm = max( lwm, int( workq( 1_${ik}$ ),KIND=${ik}$) ) wsizeo = tszo + lwo wsizem = tszm + lwm else - call stdlib_${ri}$gelq( m, n, a, lda, tq, -1, workq, -1, info2 ) - tszo = int( tq( 1 ),KIND=ilp) - lwo = int( workq( 1 ),KIND=ilp) - call stdlib_${ri}$gemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszo, b, ldb, workq, -1, & + call stdlib${ii}$_${ri}$gelq( m, n, a, lda, tq, -1_${ik}$, workq, -1_${ik}$, info2 ) + tszo = int( tq( 1_${ik}$ ),KIND=${ik}$) + lwo = int( workq( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_${ri}$gemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszo, b, ldb, workq, -1_${ik}$, & info2 ) - lwo = max( lwo, int( workq( 1 ),KIND=ilp) ) - call stdlib_${ri}$gelq( m, n, a, lda, tq, -2, workq, -2, info2 ) - tszm = int( tq( 1 ),KIND=ilp) - lwm = int( workq( 1 ),KIND=ilp) - call stdlib_${ri}$gemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszm, b, ldb, workq, -1, & + lwo = max( lwo, int( workq( 1_${ik}$ ),KIND=${ik}$) ) + call stdlib${ii}$_${ri}$gelq( m, n, a, lda, tq, -2_${ik}$, workq, -2_${ik}$, info2 ) + tszm = int( tq( 1_${ik}$ ),KIND=${ik}$) + lwm = int( workq( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_${ri}$gemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszm, b, ldb, workq, -1_${ik}$, & info2 ) - lwm = max( lwm, int( workq( 1 ),KIND=ilp) ) + lwm = max( lwm, int( workq( 1_${ik}$ ),KIND=${ik}$) ) wsizeo = tszo + lwo wsizem = tszm + lwm end if if( ( lworkzero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_${ri}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_${ri}$laset( 'F', maxmn, nrhs, zero, zero, b, ldb ) + call stdlib${ii}$_${ri}$laset( 'F', maxmn, nrhs, zero, zero, b, ldb ) go to 50 end if brow = m if ( tran ) then brow = n end if - bnrm = stdlib_${ri}$lange( 'M', brow, nrhs, b, ldb, work ) - ibscl = 0 + bnrm = stdlib${ii}$_${ri}$lange( 'M', brow, nrhs, b, ldb, work ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_${ri}$lascl( 'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,info ) - ibscl = 2 + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, brow, nrhs, b, ldb,info ) + ibscl = 2_${ik}$ end if if ( m>=n ) then ! compute qr factorization of a - call stdlib_${ri}$geqr( m, n, a, lda, work( lw2+1 ), lw1,work( 1 ), lw2, info ) + call stdlib${ii}$_${ri}$geqr( m, n, a, lda, work( lw2+1 ), lw1,work( 1_${ik}$ ), lw2, info ) if ( .not.tran ) then ! least-squares problem min || a * x - b || ! b(1:m,1:nrhs) := q**t * b(1:m,1:nrhs) - call stdlib_${ri}$gemqr( 'L' , 'T', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, work(& - 1 ), lw2,info ) + call stdlib${ii}$_${ri}$gemqr( 'L' , 'T', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, work(& + 1_${ik}$ ), lw2,info ) ! b(1:n,1:nrhs) := inv(r) * b(1:n,1:nrhs) - call stdlib_${ri}$trtrs( 'U', 'N', 'N', n, nrhs,a, lda, b, ldb, info ) - if( info>0 ) then + call stdlib${ii}$_${ri}$trtrs( 'U', 'N', 'N', n, nrhs,a, lda, b, ldb, info ) + if( info>0_${ik}$ ) then return end if scllen = n else ! overdetermined system of equations a**t * x = b ! b(1:n,1:nrhs) := inv(r**t) * b(1:n,1:nrhs) - call stdlib_${ri}$trtrs( 'U', 'T', 'N', n, nrhs,a, lda, b, ldb, info ) - if( info>0 ) then + call stdlib${ii}$_${ri}$trtrs( 'U', 'T', 'N', n, nrhs,a, lda, b, ldb, info ) + if( info>0_${ik}$ ) then return end if ! b(n+1:m,1:nrhs) = zero @@ -16128,19 +16122,19 @@ module stdlib_linalg_lapack_${ri}$ end do end do ! b(1:m,1:nrhs) := q(1:n,:) * b(1:n,1:nrhs) - call stdlib_${ri}$gemqr( 'L', 'N', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, & - work( 1 ), lw2,info ) + call stdlib${ii}$_${ri}$gemqr( 'L', 'N', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, & + work( 1_${ik}$ ), lw2,info ) scllen = m end if else ! compute lq factorization of a - call stdlib_${ri}$gelq( m, n, a, lda, work( lw2+1 ), lw1,work( 1 ), lw2, info ) + call stdlib${ii}$_${ri}$gelq( m, n, a, lda, work( lw2+1 ), lw1,work( 1_${ik}$ ), lw2, info ) ! workspace at least m, optimally m*nb. if( .not.tran ) then ! underdetermined system of equations a * x = b ! b(1:m,1:nrhs) := inv(l) * b(1:m,1:nrhs) - call stdlib_${ri}$trtrs( 'L', 'N', 'N', m, nrhs,a, lda, b, ldb, info ) - if( info>0 ) then + call stdlib${ii}$_${ri}$trtrs( 'L', 'N', 'N', m, nrhs,a, lda, b, ldb, info ) + if( info>0_${ik}$ ) then return end if ! b(m+1:n,1:nrhs) = 0 @@ -16150,43 +16144,43 @@ module stdlib_linalg_lapack_${ri}$ end do end do ! b(1:n,1:nrhs) := q(1:n,:)**t * b(1:m,1:nrhs) - call stdlib_${ri}$gemlq( 'L', 'T', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & - work( 1 ), lw2,info ) + call stdlib${ii}$_${ri}$gemlq( 'L', 'T', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & + work( 1_${ik}$ ), lw2,info ) ! workspace at least nrhs, optimally nrhs*nb scllen = n else ! overdetermined system min || a**t * x - b || ! b(1:n,1:nrhs) := q * b(1:n,1:nrhs) - call stdlib_${ri}$gemlq( 'L', 'N', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & - work( 1 ), lw2,info ) + call stdlib${ii}$_${ri}$gemlq( 'L', 'N', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & + work( 1_${ik}$ ), lw2,info ) ! workspace at least nrhs, optimally nrhs*nb ! b(1:m,1:nrhs) := inv(l**t) * b(1:m,1:nrhs) - call stdlib_${ri}$trtrs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & + call stdlib${ii}$_${ri}$trtrs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if scllen = m end if end if ! undo scaling - if( iascl==1 ) then - call stdlib_${ri}$lascl( 'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,info ) - else if( iascl==2 ) then - call stdlib_${ri}$lascl( 'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,info ) + if( iascl==1_${ik}$ ) then + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, smlnum, scllen, nrhs, b, ldb,info ) + else if( iascl==2_${ik}$ ) then + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, scllen, nrhs, b, ldb,info ) end if - if( ibscl==1 ) then - call stdlib_${ri}$lascl( 'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,info ) - else if( ibscl==2 ) then - call stdlib_${ri}$lascl( 'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,info ) + if( ibscl==1_${ik}$ ) then + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, bnrm, scllen, nrhs, b, ldb,info ) + else if( ibscl==2_${ik}$ ) then + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bignum, bnrm, scllen, nrhs, b, ldb,info ) end if 50 continue - work( 1 ) = real( tszo + lwo,KIND=${rk}$) + work( 1_${ik}$ ) = real( tszo + lwo,KIND=${rk}$) return - end subroutine stdlib_${ri}$getsls + end subroutine stdlib${ii}$_${ri}$getsls - pure subroutine stdlib_${ri}$getsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) + pure subroutine stdlib${ii}$_${ri}$getsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) !! DGETSQRHRT: computes a NB2-sized column blocked QR-factorization !! of a real M-by-N matrix A with M >= N, !! A = Q * R. @@ -16204,8 +16198,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, nb1, nb2, mb1 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldt, lwork, m, n, nb1, nb2, mb1 ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: t(ldt,*), work(*) @@ -16213,41 +16207,41 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, iinfo, j, lw1, lw2, lwt, ldwt, lworkopt, nb1local, nb2local, & + integer(${ik}$) :: i, iinfo, j, lw1, lw2, lwt, ldwt, lworkopt, nb1local, nb2local, & num_all_row_blocks ! Intrinsic Functions intrinsic :: ceiling,real,max,min ! Executable Statements ! test the input arguments - info = 0 - lquery = lwork==-1 - if( m<0 ) then - info = -1 - else if( n<0 .or. m0 .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( ldv0 )then - minwrk = max( 8*n, 6*n + 16 ) - maxwrk = minwrk - n +n*stdlib_ilaenv( 1, 'DGEQRF', ' ', n, 1, n, 0 ) - maxwrk = max( maxwrk, minwrk - n +n*stdlib_ilaenv( 1, 'DORMQR', ' ', n, 1, n, -1 & + ! following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + if( n>0_${ik}$ )then + minwrk = max( 8_${ik}$*n, 6_${ik}$*n + 16_${ik}$ ) + maxwrk = minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) + maxwrk = max( maxwrk, minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', ' ', n, 1_${ik}$, n, -1_${ik}$ & ) ) if( ilvsl ) then - maxwrk = max( maxwrk, minwrk - n +n*stdlib_ilaenv( 1, 'DORGQR', ' ', n, 1, n, & - -1 ) ) + maxwrk = max( maxwrk, minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGQR', ' ', n, 1_${ik}$, n, & + -1_${ik}$ ) ) end if else - minwrk = 1 - maxwrk = 1 + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ end if - work( 1 ) = maxwrk - if( lworkzero .and. anrmzero .and. bnrm1 ) then - call stdlib_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& + call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vsl, ldvsl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& , ldvsl ) end if - call stdlib_${ri}$orgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & + call stdlib${ii}$_${ri}$orgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vsr - if( ilvsr )call stdlib_${ri}$laset( 'FULL', n, n, zero, one, vsr, ldvsr ) + if( ilvsr )call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vsr, ldvsr ) ! reduce to generalized hessenberg form ! (workspace: none needed) - call stdlib_${ri}$gghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& + call stdlib${ii}$_${ri}$gghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& ierr ) ! perform qz algorithm, computing schur vectors if desired ! (workspace: need n) iwrk = itau - call stdlib_${ri}$hgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & + call stdlib${ii}$_${ri}$hgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 50 end if ! sort eigenvalues alpha/beta if desired ! (workspace: need 4*n+16 ) - sdim = 0 + sdim = 0_${ik}$ if( wantst ) then ! undo scaling on eigenvalues before selctging if( ilascl ) then - call stdlib_${ri}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n,ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n,ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n,ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n,ierr ) end if - if( ilbscl )call stdlib_${ri}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + if( ilbscl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) ! select eigenvalues do i = 1, n bwork( i ) = selctg( alphar( i ), alphai( i ), beta( i ) ) end do - call stdlib_${ri}$tgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, & - vsl, ldvsl, vsr, ldvsr, sdim, pvsl,pvsr, dif, work( iwrk ), lwork-iwrk+1, idum, 1,& + call stdlib${ii}$_${ri}$tgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, & + vsl, ldvsl, vsr, ldvsr, sdim, pvsl,pvsr, dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$,& ierr ) - if( ierr==1 )info = n + 3 + if( ierr==1_${ik}$ )info = n + 3_${ik}$ end if ! apply back-permutation to vsl and vsr ! (workspace: none needed) - if( ilvsl )call stdlib_${ri}$ggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, & + if( ilvsl )call stdlib${ii}$_${ri}$ggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, & vsl, ldvsl, ierr ) - if( ilvsr )call stdlib_${ri}$ggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, & + if( ilvsr )call stdlib${ii}$_${ri}$ggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, & vsr, ldvsr, ierr ) ! check if unscaling would cause over/underflow, if so, rescale ! (alphar(i),alphai(i),beta(i)) so beta(i) is on the order of @@ -16973,16 +16967,16 @@ module stdlib_linalg_lapack_${ri}$ if( alphai( i )/=zero ) then if( ( alphar( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphar( i ) )>( & anrm / anrmto ) ) then - work( 1 ) = abs( a( i, i ) / alphar( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( a( i, i ) / alphar( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) else if( ( alphai( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphai( i )& )>( anrm / anrmto ) )then - work( 1 ) = abs( a( i, i+1 ) / alphai( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( a( i, i+1 ) / alphai( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) end if end if end do @@ -16992,47 +16986,47 @@ module stdlib_linalg_lapack_${ri}$ if( alphai( i )/=zero ) then if( ( beta( i ) / safmax )>( bnrmto / bnrm ) .or.( safmin / beta( i ) )>( & bnrm / bnrmto ) ) then - work( 1 ) = abs( b( i, i ) / beta( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( b( i, i ) / beta( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) end if end if end do end if ! undo scaling if( ilascl ) then - call stdlib_${ri}$lascl( 'H', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr ) + call stdlib${ii}$_${ri}$lascl( 'H', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr ) end if if( ilbscl ) then - call stdlib_${ri}$lascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + call stdlib${ii}$_${ri}$lascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) end if if( wantst ) then ! check if reordering is correct lastsl = .true. lst2sl = .true. - sdim = 0 - ip = 0 + sdim = 0_${ik}$ + ip = 0_${ik}$ do i = 1, n cursl = selctg( alphar( i ), alphai( i ), beta( i ) ) if( alphai( i )==zero ) then - if( cursl )sdim = sdim + 1 - ip = 0 - if( cursl .and. .not.lastsl )info = n + 2 + if( cursl )sdim = sdim + 1_${ik}$ + ip = 0_${ik}$ + if( cursl .and. .not.lastsl )info = n + 2_${ik}$ else - if( ip==1 ) then + if( ip==1_${ik}$ ) then ! last eigenvalue of conjugate pair cursl = cursl .or. lastsl lastsl = cursl - if( cursl )sdim = sdim + 2 - ip = -1 - if( cursl .and. .not.lst2sl )info = n + 2 + if( cursl )sdim = sdim + 2_${ik}$ + ip = -1_${ik}$ + if( cursl .and. .not.lst2sl )info = n + 2_${ik}$ else ! first eigenvalue of conjugate pair - ip = 1 + ip = 1_${ik}$ end if end if lst2sl = lastsl @@ -17040,12 +17034,12 @@ module stdlib_linalg_lapack_${ri}$ end do end if 50 continue - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_${ri}$gges + end subroutine stdlib${ii}$_${ri}$gges - subroutine stdlib_${ri}$gges3( jobvsl, jobvsr, sort, selctg, n, a, lda, b,ldb, sdim, alphar, & + subroutine stdlib${ii}$_${ri}$gges3( jobvsl, jobvsr, sort, selctg, n, a, lda, b,ldb, sdim, alphar, & !! DGGES3: computes for a pair of N-by-N real nonsymmetric matrices (A,B), !! the generalized eigenvalues, the generalized real Schur form (S,T), !! optionally, the left and/or right matrices of Schur vectors (VSL and @@ -17078,8 +17072,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvsl, jobvsr, sort - integer(ilp), intent(out) :: info, sdim - integer(ilp), intent(in) :: lda, ldb, ldvsl, ldvsr, lwork, n + integer(${ik}$), intent(out) :: info, sdim + integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, lwork, n ! Array Arguments logical(lk), intent(out) :: bwork(*) real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) @@ -17092,104 +17086,104 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, lst2sl, & wantst - integer(ilp) :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, ip, iright, irows, & + integer(${ik}$) :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, ip, iright, irows, & itau, iwrk, lwkopt real(${rk}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl, pvsr, safmax, safmin, & smlnum ! Local Arrays - integer(ilp) :: idum(1) - real(${rk}$) :: dif(2) + integer(${ik}$) :: idum(1_${ik}$) + real(${rk}$) :: dif(2_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvsl, 'N' ) ) then - ijobvl = 1 + ijobvl = 1_${ik}$ ilvsl = .false. else if( stdlib_lsame( jobvsl, 'V' ) ) then - ijobvl = 2 + ijobvl = 2_${ik}$ ilvsl = .true. else - ijobvl = -1 + ijobvl = -1_${ik}$ ilvsl = .false. end if if( stdlib_lsame( jobvsr, 'N' ) ) then - ijobvr = 1 + ijobvr = 1_${ik}$ ilvsr = .false. else if( stdlib_lsame( jobvsr, 'V' ) ) then - ijobvr = 2 + ijobvr = 2_${ik}$ ilvsr = .true. else - ijobvr = -1 + ijobvr = -1_${ik}$ ilvsr = .false. end if wantst = stdlib_lsame( sort, 'S' ) ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( ijobvl<=0 ) then - info = -1 - else if( ijobvr<=0 ) then - info = -2 + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) + if( ijobvl<=0_${ik}$ ) then + info = -1_${ik}$ + else if( ijobvr<=0_${ik}$ ) then + info = -2_${ik}$ else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then - info = -3 - else if( n<0 ) then - info = -5 - else if( ldazero .and. anrmzero .and. bnrm1 ) then - call stdlib_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& + call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vsl, ldvsl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& , ldvsl ) end if - call stdlib_${ri}$orgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & + call stdlib${ii}$_${ri}$orgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vsr - if( ilvsr )call stdlib_${ri}$laset( 'FULL', n, n, zero, one, vsr, ldvsr ) + if( ilvsr )call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vsr, ldvsr ) ! reduce to generalized hessenberg form - call stdlib_${ri}$gghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& + call stdlib${ii}$_${ri}$gghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& work( iwrk ), lwork+1-iwrk,ierr ) ! perform qz algorithm, computing schur vectors if desired iwrk = itau - call stdlib_${ri}$laqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & - beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, 0, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + call stdlib${ii}$_${ri}$laqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & + beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, 0_${ik}$, ierr ) + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 50 end if ! sort eigenvalues alpha/beta if desired - sdim = 0 + sdim = 0_${ik}$ if( wantst ) then ! undo scaling on eigenvalues before selctging if( ilascl ) then - call stdlib_${ri}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n,ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n,ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n,ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n,ierr ) end if - if( ilbscl )call stdlib_${ri}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + if( ilbscl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) ! select eigenvalues do i = 1, n bwork( i ) = selctg( alphar( i ), alphai( i ), beta( i ) ) end do - call stdlib_${ri}$tgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, & - vsl, ldvsl, vsr, ldvsr, sdim, pvsl,pvsr, dif, work( iwrk ), lwork-iwrk+1, idum, 1,& + call stdlib${ii}$_${ri}$tgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, & + vsl, ldvsl, vsr, ldvsr, sdim, pvsl,pvsr, dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$,& ierr ) - if( ierr==1 )info = n + 3 + if( ierr==1_${ik}$ )info = n + 3_${ik}$ end if ! apply back-permutation to vsl and vsr - if( ilvsl )call stdlib_${ri}$ggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, & + if( ilvsl )call stdlib${ii}$_${ri}$ggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, & vsl, ldvsl, ierr ) - if( ilvsr )call stdlib_${ri}$ggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, & + if( ilvsr )call stdlib${ii}$_${ri}$ggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, & vsr, ldvsr, ierr ) ! check if unscaling would cause over/underflow, if so, rescale ! (alphar(i),alphai(i),beta(i)) so beta(i) is on the order of @@ -17287,16 +17281,16 @@ module stdlib_linalg_lapack_${ri}$ if( alphai( i )/=zero ) then if( ( alphar( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphar( i ) )>( & anrm / anrmto ) ) then - work( 1 ) = abs( a( i, i ) / alphar( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( a( i, i ) / alphar( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) else if( ( alphai( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphai( i )& )>( anrm / anrmto ) )then - work( 1 ) = abs( a( i, i+1 ) / alphai( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( a( i, i+1 ) / alphai( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) end if end if end do @@ -17306,47 +17300,47 @@ module stdlib_linalg_lapack_${ri}$ if( alphai( i )/=zero ) then if( ( beta( i ) / safmax )>( bnrmto / bnrm ) .or.( safmin / beta( i ) )>( & bnrm / bnrmto ) ) then - work( 1 ) = abs( b( i, i ) / beta( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( b( i, i ) / beta( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) end if end if end do end if ! undo scaling if( ilascl ) then - call stdlib_${ri}$lascl( 'H', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr ) + call stdlib${ii}$_${ri}$lascl( 'H', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr ) end if if( ilbscl ) then - call stdlib_${ri}$lascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + call stdlib${ii}$_${ri}$lascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) end if if( wantst ) then ! check if reordering is correct lastsl = .true. lst2sl = .true. - sdim = 0 - ip = 0 + sdim = 0_${ik}$ + ip = 0_${ik}$ do i = 1, n cursl = selctg( alphar( i ), alphai( i ), beta( i ) ) if( alphai( i )==zero ) then - if( cursl )sdim = sdim + 1 - ip = 0 - if( cursl .and. .not.lastsl )info = n + 2 + if( cursl )sdim = sdim + 1_${ik}$ + ip = 0_${ik}$ + if( cursl .and. .not.lastsl )info = n + 2_${ik}$ else - if( ip==1 ) then + if( ip==1_${ik}$ ) then ! last eigenvalue of conjugate pair cursl = cursl .or. lastsl lastsl = cursl - if( cursl )sdim = sdim + 2 - ip = -1 - if( cursl .and. .not.lst2sl )info = n + 2 + if( cursl )sdim = sdim + 2_${ik}$ + ip = -1_${ik}$ + if( cursl .and. .not.lst2sl )info = n + 2_${ik}$ else ! first eigenvalue of conjugate pair - ip = 1 + ip = 1_${ik}$ end if end if lst2sl = lastsl @@ -17354,12 +17348,12 @@ module stdlib_linalg_lapack_${ri}$ end do end if 50 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ri}$gges3 + end subroutine stdlib${ii}$_${ri}$gges3 - subroutine stdlib_${ri}$ggesx( jobvsl, jobvsr, sort, selctg, sense, n, a, lda,b, ldb, sdim, & + subroutine stdlib${ii}$_${ri}$ggesx( jobvsl, jobvsr, sort, selctg, sense, n, a, lda,b, ldb, sdim, & !! DGGESX: computes for a pair of N-by-N real nonsymmetric matrices !! (A,B), the generalized eigenvalues, the real Schur form (S,T), and, !! optionally, the left and/or right matrices of Schur vectors (VSL and @@ -17395,13 +17389,13 @@ module stdlib_linalg_lapack_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvsl, jobvsr, sense, sort - integer(ilp), intent(out) :: info, sdim - integer(ilp), intent(in) :: lda, ldb, ldvsl, ldvsr, liwork, lwork, n + integer(${ik}$), intent(out) :: info, sdim + integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, liwork, lwork, n ! Array Arguments logical(lk), intent(out) :: bwork(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) - real(${rk}$), intent(out) :: alphai(*), alphar(*), beta(*), rconde(2), rcondv(2), vsl(& + real(${rk}$), intent(out) :: alphai(*), alphar(*), beta(*), rconde(2_${ik}$), rcondv(2_${ik}$), vsl(& ldvsl,*), vsr(ldvsr,*), work(*) ! Function Arguments procedure(stdlib_selctg_${ri}$) :: selctg @@ -17410,34 +17404,34 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, lst2sl, wantsb, & wantse, wantsn, wantst, wantsv - integer(ilp) :: i, icols, ierr, ihi, ijob, ijobvl, ijobvr, ileft, ilo, ip, iright, & + integer(${ik}$) :: i, icols, ierr, ihi, ijob, ijobvl, ijobvr, ileft, ilo, ip, iright, & irows, itau, iwrk, liwmin, lwrk, maxwrk, minwrk real(${rk}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pl, pr, safmax, safmin, & smlnum ! Local Arrays - real(${rk}$) :: dif(2) + real(${rk}$) :: dif(2_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvsl, 'N' ) ) then - ijobvl = 1 + ijobvl = 1_${ik}$ ilvsl = .false. else if( stdlib_lsame( jobvsl, 'V' ) ) then - ijobvl = 2 + ijobvl = 2_${ik}$ ilvsl = .true. else - ijobvl = -1 + ijobvl = -1_${ik}$ ilvsl = .false. end if if( stdlib_lsame( jobvsr, 'N' ) ) then - ijobvr = 1 + ijobvr = 1_${ik}$ ilvsr = .false. else if( stdlib_lsame( jobvsr, 'V' ) ) then - ijobvr = 2 + ijobvr = 2_${ik}$ ilvsr = .true. else - ijobvr = -1 + ijobvr = -1_${ik}$ ilvsr = .false. end if wantst = stdlib_lsame( sort, 'S' ) @@ -17445,94 +17439,94 @@ module stdlib_linalg_lapack_${ri}$ wantse = stdlib_lsame( sense, 'E' ) wantsv = stdlib_lsame( sense, 'V' ) wantsb = stdlib_lsame( sense, 'B' ) - lquery = ( lwork==-1 .or. liwork==-1 ) + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) if( wantsn ) then - ijob = 0 + ijob = 0_${ik}$ else if( wantse ) then - ijob = 1 + ijob = 1_${ik}$ else if( wantsv ) then - ijob = 2 + ijob = 2_${ik}$ else if( wantsb ) then - ijob = 4 + ijob = 4_${ik}$ end if ! test the input arguments - info = 0 - if( ijobvl<=0 ) then - info = -1 - else if( ijobvr<=0 ) then - info = -2 + info = 0_${ik}$ + if( ijobvl<=0_${ik}$ ) then + info = -1_${ik}$ + else if( ijobvr<=0_${ik}$ ) then + info = -2_${ik}$ else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then - info = -3 + info = -3_${ik}$ else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. & .not.wantsn ) ) then - info = -5 - else if( n<0 ) then - info = -6 - else if( lda0) then - minwrk = max( 8*n, 6*n + 16 ) - maxwrk = minwrk - n +n*stdlib_ilaenv( 1, 'DGEQRF', ' ', n, 1, n, 0 ) - maxwrk = max( maxwrk, minwrk - n +n*stdlib_ilaenv( 1, 'DORMQR', ' ', n, 1, n, -1 & + ! following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + if( n>0_${ik}$) then + minwrk = max( 8_${ik}$*n, 6_${ik}$*n + 16_${ik}$ ) + maxwrk = minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) + maxwrk = max( maxwrk, minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', ' ', n, 1_${ik}$, n, -1_${ik}$ & ) ) if( ilvsl ) then - maxwrk = max( maxwrk, minwrk - n +n*stdlib_ilaenv( 1, 'DORGQR', ' ', n, 1, n, & - -1 ) ) + maxwrk = max( maxwrk, minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'DORGQR', ' ', n, 1_${ik}$, n, & + -1_${ik}$ ) ) end if lwrk = maxwrk - if( ijob>=1 )lwrk = max( lwrk, n*n/2 ) + if( ijob>=1_${ik}$ )lwrk = max( lwrk, n*n/2_${ik}$ ) else - minwrk = 1 - maxwrk = 1 - lwrk = 1 + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + lwrk = 1_${ik}$ end if - work( 1 ) = lwrk - if( wantsn .or. n==0 ) then - liwmin = 1 + work( 1_${ik}$ ) = lwrk + if( wantsn .or. n==0_${ik}$ ) then + liwmin = 1_${ik}$ else - liwmin = n + 6 + liwmin = n + 6_${ik}$ end if - iwork( 1 ) = liwmin + iwork( 1_${ik}$ ) = liwmin if( lworkzero .and. anrmzero .and. bnrm1 ) then - call stdlib_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& + call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vsl, ldvsl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& , ldvsl ) end if - call stdlib_${ri}$orgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & + call stdlib${ii}$_${ri}$orgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vsr - if( ilvsr )call stdlib_${ri}$laset( 'FULL', n, n, zero, one, vsr, ldvsr ) + if( ilvsr )call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vsr, ldvsr ) ! reduce to generalized hessenberg form ! (workspace: none needed) - call stdlib_${ri}$gghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& + call stdlib${ii}$_${ri}$gghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& ierr ) - sdim = 0 + sdim = 0_${ik}$ ! perform qz algorithm, computing schur vectors if desired ! (workspace: need n) iwrk = itau - call stdlib_${ri}$hgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & + call stdlib${ii}$_${ri}$hgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 60 end if @@ -17612,10 +17606,10 @@ module stdlib_linalg_lapack_${ri}$ if( wantst ) then ! undo scaling on eigenvalues before selctging if( ilascl ) then - call stdlib_${ri}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n,ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n,ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n,ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n,ierr ) end if - if( ilbscl )call stdlib_${ri}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + if( ilbscl )call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) ! select eigenvalues do i = 1, n @@ -17623,30 +17617,30 @@ module stdlib_linalg_lapack_${ri}$ end do ! reorder eigenvalues, transform generalized schur vectors, and ! compute reciprocal condition numbers - call stdlib_${ri}$tgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alphar, alphai, & + call stdlib${ii}$_${ri}$tgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alphar, alphai, & beta, vsl, ldvsl, vsr, ldvsr,sdim, pl, pr, dif, work( iwrk ), lwork-iwrk+1,iwork, & liwork, ierr ) - if( ijob>=1 )maxwrk = max( maxwrk, 2*sdim*( n-sdim ) ) - if( ierr==-22 ) then + if( ijob>=1_${ik}$ )maxwrk = max( maxwrk, 2_${ik}$*sdim*( n-sdim ) ) + if( ierr==-22_${ik}$ ) then ! not enough real workspace - info = -22 + info = -22_${ik}$ else - if( ijob==1 .or. ijob==4 ) then - rconde( 1 ) = pl - rconde( 2 ) = pr + if( ijob==1_${ik}$ .or. ijob==4_${ik}$ ) then + rconde( 1_${ik}$ ) = pl + rconde( 2_${ik}$ ) = pr end if - if( ijob==2 .or. ijob==4 ) then - rcondv( 1 ) = dif( 1 ) - rcondv( 2 ) = dif( 2 ) + if( ijob==2_${ik}$ .or. ijob==4_${ik}$ ) then + rcondv( 1_${ik}$ ) = dif( 1_${ik}$ ) + rcondv( 2_${ik}$ ) = dif( 2_${ik}$ ) end if - if( ierr==1 )info = n + 3 + if( ierr==1_${ik}$ )info = n + 3_${ik}$ end if end if ! apply permutation to vsl and vsr ! (workspace: none needed) - if( ilvsl )call stdlib_${ri}$ggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, & + if( ilvsl )call stdlib${ii}$_${ri}$ggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, & vsl, ldvsl, ierr ) - if( ilvsr )call stdlib_${ri}$ggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, & + if( ilvsr )call stdlib${ii}$_${ri}$ggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, & vsr, ldvsr, ierr ) ! check if unscaling would cause over/underflow, if so, rescale ! (alphar(i),alphai(i),beta(i)) so beta(i) is on the order of @@ -17656,16 +17650,16 @@ module stdlib_linalg_lapack_${ri}$ if( alphai( i )/=zero ) then if( ( alphar( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphar( i ) )>( & anrm / anrmto ) ) then - work( 1 ) = abs( a( i, i ) / alphar( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( a( i, i ) / alphar( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) else if( ( alphai( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphai( i )& )>( anrm / anrmto ) )then - work( 1 ) = abs( a( i, i+1 ) / alphai( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( a( i, i+1 ) / alphai( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) end if end if end do @@ -17675,47 +17669,47 @@ module stdlib_linalg_lapack_${ri}$ if( alphai( i )/=zero ) then if( ( beta( i ) / safmax )>( bnrmto / bnrm ) .or.( safmin / beta( i ) )>( & bnrm / bnrmto ) ) then - work( 1 ) = abs( b( i, i ) / beta( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( b( i, i ) / beta( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) end if end if end do end if ! undo scaling if( ilascl ) then - call stdlib_${ri}$lascl( 'H', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr ) + call stdlib${ii}$_${ri}$lascl( 'H', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr ) end if if( ilbscl ) then - call stdlib_${ri}$lascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + call stdlib${ii}$_${ri}$lascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) end if if( wantst ) then ! check if reordering is correct lastsl = .true. lst2sl = .true. - sdim = 0 - ip = 0 + sdim = 0_${ik}$ + ip = 0_${ik}$ do i = 1, n cursl = selctg( alphar( i ), alphai( i ), beta( i ) ) if( alphai( i )==zero ) then - if( cursl )sdim = sdim + 1 - ip = 0 - if( cursl .and. .not.lastsl )info = n + 2 + if( cursl )sdim = sdim + 1_${ik}$ + ip = 0_${ik}$ + if( cursl .and. .not.lastsl )info = n + 2_${ik}$ else - if( ip==1 ) then + if( ip==1_${ik}$ ) then ! last eigenvalue of conjugate pair cursl = cursl .or. lastsl lastsl = cursl - if( cursl )sdim = sdim + 2 - ip = -1 - if( cursl .and. .not.lst2sl )info = n + 2 + if( cursl )sdim = sdim + 2_${ik}$ + ip = -1_${ik}$ + if( cursl .and. .not.lst2sl )info = n + 2_${ik}$ else ! first eigenvalue of conjugate pair - ip = 1 + ip = 1_${ik}$ end if end if lst2sl = lastsl @@ -17723,13 +17717,13 @@ module stdlib_linalg_lapack_${ri}$ end do end if 60 continue - work( 1 ) = maxwrk - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = maxwrk + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_${ri}$ggesx + end subroutine stdlib${ii}$_${ri}$ggesx - subroutine stdlib_${ri}$ggev( jobvl, jobvr, n, a, lda, b, ldb, alphar, alphai,beta, vl, ldvl, vr, & + subroutine stdlib${ii}$_${ri}$ggev( jobvl, jobvr, n, a, lda, b, ldb, alphar, alphai,beta, vl, ldvl, vr, & !! DGGEV: computes for a pair of N-by-N real nonsymmetric matrices (A,B) !! the generalized eigenvalues, and optionally, the left and/or right !! generalized eigenvectors. @@ -17751,8 +17745,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvl, jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) real(${rk}$), intent(out) :: alphai(*), alphar(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*) @@ -17762,75 +17756,75 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery character :: chtemp - integer(ilp) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, itau, & + integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, itau, & iwrk, jc, jr, maxwrk, minwrk real(${rk}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp ! Local Arrays - logical(lk) :: ldumma(1) + logical(lk) :: ldumma(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvl, 'N' ) ) then - ijobvl = 1 + ijobvl = 1_${ik}$ ilvl = .false. else if( stdlib_lsame( jobvl, 'V' ) ) then - ijobvl = 2 + ijobvl = 2_${ik}$ ilvl = .true. else - ijobvl = -1 + ijobvl = -1_${ik}$ ilvl = .false. end if if( stdlib_lsame( jobvr, 'N' ) ) then - ijobvr = 1 + ijobvr = 1_${ik}$ ilvr = .false. else if( stdlib_lsame( jobvr, 'V' ) ) then - ijobvr = 2 + ijobvr = 2_${ik}$ ilvr = .true. else - ijobvr = -1 + ijobvr = -1_${ik}$ ilvr = .false. end if ilv = ilvl .or. ilvr ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( ijobvl<=0 ) then - info = -1 - else if( ijobvr<=0 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldazero .and. anrmzero .and. bnrm1 ) then - call stdlib_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& + call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vl, ldvl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& ldvl ) end if - call stdlib_${ri}$orgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & + call stdlib${ii}$_${ri}$orgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vr - if( ilvr )call stdlib_${ri}$laset( 'FULL', n, n, zero, one, vr, ldvr ) + if( ilvr )call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vr, ldvr ) ! reduce to generalized hessenberg form ! (workspace: none needed) if( ilv ) then ! eigenvectors requested -- work on whole matrix. - call stdlib_${ri}$gghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib${ii}$_${ri}$gghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & ierr ) else - call stdlib_${ri}$gghrd( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & + call stdlib${ii}$_${ri}$gghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & ldb, vl, ldvl, vr, ldvr, ierr ) end if ! perform qz algorithm (compute eigenvalues, and optionally, the @@ -17921,15 +17915,15 @@ module stdlib_linalg_lapack_${ri}$ else chtemp = 'E' end if - call stdlib_${ri}$hgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & + call stdlib${ii}$_${ri}$hgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & beta, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 110 end if @@ -17945,16 +17939,16 @@ module stdlib_linalg_lapack_${ri}$ else chtemp = 'R' end if - call stdlib_${ri}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & + call stdlib${ii}$_${ri}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & in, work( iwrk ), ierr ) - if( ierr/=0 ) then - info = n + 2 + if( ierr/=0_${ik}$ ) then + info = n + 2_${ik}$ go to 110 end if ! undo balancing on vl and vr and normalization ! (workspace: none needed) if( ilvl ) then - call stdlib_${ri}$ggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, & + call stdlib${ii}$_${ri}$ggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, & ldvl, ierr ) loop_50: do jc = 1, n if( alphai( jc )zero .and. anrmzero .and. bnrm1 ) then - call stdlib_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& + call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vl, ldvl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& ldvl ) end if - call stdlib_${ri}$orgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & + call stdlib${ii}$_${ri}$orgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vr - if( ilvr )call stdlib_${ri}$laset( 'FULL', n, n, zero, one, vr, ldvr ) + if( ilvr )call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vr, ldvr ) ! reduce to generalized hessenberg form if( ilv ) then ! eigenvectors requested -- work on whole matrix. - call stdlib_${ri}$gghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib${ii}$_${ri}$gghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & work( iwrk ), lwork+1-iwrk, ierr ) else - call stdlib_${ri}$gghd3( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & + call stdlib${ii}$_${ri}$gghd3( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & ldb, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr ) end if ! perform qz algorithm (compute eigenvalues, and optionally, the @@ -18223,15 +18217,15 @@ module stdlib_linalg_lapack_${ri}$ else chtemp = 'E' end if - call stdlib_${ri}$laqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & - beta, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, 0, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + call stdlib${ii}$_${ri}$laqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & + beta, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, 0_${ik}$, ierr ) + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 110 end if @@ -18246,15 +18240,15 @@ module stdlib_linalg_lapack_${ri}$ else chtemp = 'R' end if - call stdlib_${ri}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & + call stdlib${ii}$_${ri}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & in, work( iwrk ), ierr ) - if( ierr/=0 ) then - info = n + 2 + if( ierr/=0_${ik}$ ) then + info = n + 2_${ik}$ go to 110 end if ! undo balancing on vl and vr and normalization if( ilvl ) then - call stdlib_${ri}$ggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, & + call stdlib${ii}$_${ri}$ggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, & ldvl, ierr ) loop_50: do jc = 1, n if( alphai( jc )zero .and. anrmzero .and. bnrm1 ) then - call stdlib_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& + call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vl, ldvl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_${ri}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& ldvl ) end if - call stdlib_${ri}$orgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & + call stdlib${ii}$_${ri}$orgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if - if( ilvr )call stdlib_${ri}$laset( 'FULL', n, n, zero, one, vr, ldvr ) + if( ilvr )call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, vr, ldvr ) ! reduce to generalized hessenberg form ! (workspace: none needed) if( ilv .or. .not.wantsn ) then ! eigenvectors requested -- work on whole matrix. - call stdlib_${ri}$gghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib${ii}$_${ri}$gghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & ierr ) else - call stdlib_${ri}$gghrd( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & + call stdlib${ii}$_${ri}$gghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & ldb, vl, ldvl, vr, ldvr, ierr ) end if ! perform qz algorithm (compute eigenvalues, and optionally, the @@ -18566,21 +18560,21 @@ module stdlib_linalg_lapack_${ri}$ else chtemp = 'E' end if - call stdlib_${ri}$hgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & + call stdlib${ii}$_${ri}$hgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & beta, vl, ldvl, vr, ldvr, work,lwork, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 130 end if ! compute eigenvectors and estimate condition numbers if desired - ! (workspace: stdlib_${ri}$tgevc: need 6*n - ! stdlib_${ri}$tgsna: need 2*n*(n+2)+16 if sense = 'v' or 'b', + ! (workspace: stdlib${ii}$_${ri}$tgevc: need 6*n + ! stdlib${ii}$_${ri}$tgsna: need 2*n*(n+2)+16 if sense = 'v' or 'b', ! need n otherwise ) if( ilv .or. .not.wantsn ) then if( ilv ) then @@ -18593,16 +18587,16 @@ module stdlib_linalg_lapack_${ri}$ else chtemp = 'R' end if - call stdlib_${ri}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,& + call stdlib${ii}$_${ri}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,& in, work, ierr ) - if( ierr/=0 ) then - info = n + 2 + if( ierr/=0_${ik}$ ) then + info = n + 2_${ik}$ go to 130 end if end if if( .not.wantsn ) then - ! compute eigenvectors (stdlib_${ri}$tgevc) and estimate condition - ! numbers (stdlib_${ri}$tgsna). note that the definition of the condition + ! compute eigenvectors (stdlib${ii}$_${ri}$tgevc) and estimate condition + ! numbers (stdlib${ii}$_${ri}$tgsna). note that the definition of the condition ! number is not invariant under transformation (u,v) to ! (q*u, z*v), where (u,v) are eigenvectors of the generalized ! schur form (s,t), q and z are orthogonal matrices. in order @@ -18614,35 +18608,35 @@ module stdlib_linalg_lapack_${ri}$ pair = .false. cycle loop_20 end if - mm = 1 + mm = 1_${ik}$ if( in ) then - info = -2 - else if( p<0 .or. pn ) then + info = -2_${ik}$ + else if( p<0_${ik}$ .or. pm ) then - call stdlib_${ri}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', n-m, 1,b( m+1, m+p-n+1 ), & + call stdlib${ii}$_${ri}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', n-m, 1_${ik}$,b( m+1, m+p-n+1 ), & ldb, d( m+1 ), n-m, info ) - if( info>0 ) then - info = 1 + if( info>0_${ik}$ ) then + info = 1_${ik}$ return end if - call stdlib_${ri}$copy( n-m, d( m+1 ), 1, y( m+p-n+1 ), 1 ) + call stdlib${ii}$_${ri}$copy( n-m, d( m+1 ), 1_${ik}$, y( m+p-n+1 ), 1_${ik}$ ) end if ! set y1 = 0 do i = 1, m + p - n y( i ) = zero end do ! update d1 = d1 - t12*y2 - call stdlib_${ri}$gemv( 'NO TRANSPOSE', m, n-m, -one, b( 1, m+p-n+1 ), ldb,y( m+p-n+1 ), 1, & - one, d, 1 ) + call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', m, n-m, -one, b( 1_${ik}$, m+p-n+1 ), ldb,y( m+p-n+1 ), 1_${ik}$, & + one, d, 1_${ik}$ ) ! solve triangular system: r11*x = d1 - if( m>0 ) then - call stdlib_${ri}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', m, 1, a, lda,d, m, info ) + if( m>0_${ik}$ ) then + call stdlib${ii}$_${ri}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', m, 1_${ik}$, a, lda,d, m, info ) - if( info>0 ) then - info = 2 + if( info>0_${ik}$ ) then + info = 2_${ik}$ return end if ! copy d to x - call stdlib_${ri}$copy( m, d, 1, x, 1 ) + call stdlib${ii}$_${ri}$copy( m, d, 1_${ik}$, x, 1_${ik}$ ) end if ! backward transformation y = z**t *y - call stdlib_${ri}$ormrq( 'LEFT', 'TRANSPOSE', p, 1, np,b( max( 1, n-p+1 ), 1 ), ldb, work( & - m+1 ), y,max( 1, p ), work( m+np+1 ), lwork-m-np, info ) - work( 1 ) = m + np + max( lopt, int( work( m+np+1 ),KIND=ilp) ) + call stdlib${ii}$_${ri}$ormrq( 'LEFT', 'TRANSPOSE', p, 1_${ik}$, np,b( max( 1_${ik}$, n-p+1 ), 1_${ik}$ ), ldb, work( & + m+1 ), y,max( 1_${ik}$, p ), work( m+np+1 ), lwork-m-np, info ) + work( 1_${ik}$ ) = m + np + max( lopt, int( work( m+np+1 ),KIND=${ik}$) ) return - end subroutine stdlib_${ri}$ggglm + end subroutine stdlib${ii}$_${ri}$ggglm - pure subroutine stdlib_${ri}$gghd3( compq, compz, n, ilo, ihi, a, lda, b, ldb, q,ldq, z, ldz, & + pure subroutine stdlib${ii}$_${ri}$gghd3( compq, compz, n, ilo, ihi, a, lda, b, ldb, q,ldq, z, ldz, & !! DGGHD3: reduces a pair of real matrices (A,B) to generalized upper !! Hessenberg form using orthogonal transformations, where A is a !! general matrix and B is upper triangular. The form of the @@ -18890,8 +18884,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: compq, compz - integer(ilp), intent(in) :: ihi, ilo, lda, ldb, ldq, ldz, n, lwork - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ilo, lda, ldb, ldq, ldz, n, lwork + integer(${ik}$), intent(out) :: info ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) real(${rk}$), intent(out) :: work(*) @@ -18900,76 +18894,76 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: blk22, initq, initz, lquery, wantq, wantz character :: compq2, compz2 - integer(ilp) :: cola, i, ierr, j, j0, jcol, jj, jrow, k, kacc22, len, lwkopt, n2nb, nb,& + integer(${ik}$) :: cola, i, ierr, j, j0, jcol, jj, jrow, k, kacc22, len, lwkopt, n2nb, nb,& nblst, nbmin, nh, nnb, nx, ppw, ppwo, pw, top, topq real(${rk}$) :: c, c1, c2, s, s1, s2, temp, temp1, temp2, temp3 ! Intrinsic Functions intrinsic :: real,max ! Executable Statements ! decode and test the input parameters. - info = 0 - nb = stdlib_ilaenv( 1, 'DGGHD3', ' ', n, ilo, ihi, -1 ) - lwkopt = max( 6*n*nb, 1 ) - work( 1 ) = real( lwkopt,KIND=${rk}$) + info = 0_${ik}$ + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGGHD3', ' ', n, ilo, ihi, -1_${ik}$ ) + lwkopt = max( 6_${ik}$*n*nb, 1_${ik}$ ) + work( 1_${ik}$ ) = real( lwkopt,KIND=${rk}$) initq = stdlib_lsame( compq, 'I' ) wantq = initq .or. stdlib_lsame( compq, 'V' ) initz = stdlib_lsame( compz, 'I' ) wantz = initz .or. stdlib_lsame( compz, 'V' ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) if( .not.stdlib_lsame( compq, 'N' ) .and. .not.wantq ) then - info = -1 + info = -1_${ik}$ else if( .not.stdlib_lsame( compz, 'N' ) .and. .not.wantz ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ilo<1 ) then - info = -4 + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( ilo<1_${ik}$ ) then + info = -4_${ik}$ else if( ihi>n .or. ihi1 )call stdlib_${ri}$laset( 'LOWER', n-1, n-1, zero, zero, b(2, 1), ldb ) + if( n>1_${ik}$ )call stdlib${ii}$_${ri}$laset( 'LOWER', n-1, n-1, zero, zero, b(2_${ik}$, 1_${ik}$), ldb ) ! quick return if possible - nh = ihi - ilo + 1 - if( nh<=1 ) then - work( 1 ) = one + nh = ihi - ilo + 1_${ik}$ + if( nh<=1_${ik}$ ) then + work( 1_${ik}$ ) = one return end if ! determine the blocksize. - nbmin = stdlib_ilaenv( 2, 'DGGHD3', ' ', n, ilo, ihi, -1 ) - if( nb>1 .and. nb1_${ik}$ .and. nb=6*n*nbmin ) then - nb = lwork / ( 6*n ) + nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'DGGHD3', ' ', n, ilo, ihi,-1_${ik}$ ) ) + if( lwork>=6_${ik}$*n*nbmin ) then + nb = lwork / ( 6_${ik}$*n ) else - nb = 1 + nb = 1_${ik}$ end if end if end if @@ -18979,8 +18973,8 @@ module stdlib_linalg_lapack_${ri}$ jcol = ilo else ! use blocked code - kacc22 = stdlib_ilaenv( 16, 'DGGHD3', ' ', n, ilo, ihi, -1 ) - blk22 = kacc22==2 + kacc22 = stdlib${ii}$_ilaenv( 16_${ik}$, 'DGGHD3', ' ', n, ilo, ihi, -1_${ik}$ ) + blk22 = kacc22==2_${ik}$ do jcol = ilo, ihi-2, nb nnb = min( nb, ihi-jcol-1 ) ! initialize small orthogonal factors that will hold the @@ -18988,13 +18982,13 @@ module stdlib_linalg_lapack_${ri}$ ! n2nb denotes the number of 2*nnb-by-2*nnb factors ! nblst denotes the (possibly smaller) order of the last ! factor. - n2nb = ( ihi-jcol-1 ) / nnb - 1 + n2nb = ( ihi-jcol-1 ) / nnb - 1_${ik}$ nblst = ihi - jcol - n2nb*nnb - call stdlib_${ri}$laset( 'ALL', nblst, nblst, zero, one, work, nblst ) - pw = nblst * nblst + 1 + call stdlib${ii}$_${ri}$laset( 'ALL', nblst, nblst, zero, one, work, nblst ) + pw = nblst * nblst + 1_${ik}$ do i = 1, n2nb - call stdlib_${ri}$laset( 'ALL', 2*nnb, 2*nnb, zero, one,work( pw ), 2*nnb ) - pw = pw + 4*nnb*nnb + call stdlib${ii}$_${ri}$laset( 'ALL', 2_${ik}$*nnb, 2_${ik}$*nnb, zero, one,work( pw ), 2_${ik}$*nnb ) + pw = pw + 4_${ik}$*nnb*nnb end do ! reduce columns jcol:jcol+nnb-1 of a to hessenberg form. do j = jcol, jcol+nnb-1 @@ -19002,14 +18996,14 @@ module stdlib_linalg_lapack_${ri}$ ! column of a and b, respectively. do i = ihi, j+2, -1 temp = a( i-1, j ) - call stdlib_${ri}$lartg( temp, a( i, j ), c, s, a( i-1, j ) ) + call stdlib${ii}$_${ri}$lartg( temp, a( i, j ), c, s, a( i-1, j ) ) a( i, j ) = c b( i, j ) = s end do ! accumulate givens rotations into workspace array. - ppw = ( nblst + 1 )*( nblst - 2 ) - j + jcol + 1 - len = 2 + j - jcol - jrow = j + n2nb*nnb + 2 + ppw = ( nblst + 1_${ik}$ )*( nblst - 2_${ik}$ ) - j + jcol + 1_${ik}$ + len = 2_${ik}$ + j - jcol + jrow = j + n2nb*nnb + 2_${ik}$ do i = ihi, jrow, -1 c = a( i, j ) s = b( i, j ) @@ -19018,31 +19012,31 @@ module stdlib_linalg_lapack_${ri}$ work( jj + nblst ) = c*temp - s*work( jj ) work( jj ) = s*temp + c*work( jj ) end do - len = len + 1 - ppw = ppw - nblst - 1 + len = len + 1_${ik}$ + ppw = ppw - nblst - 1_${ik}$ end do - ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2*nnb + nnb + ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2_${ik}$*nnb + nnb j0 = jrow - nnb do jrow = j0, j+2, -nnb ppw = ppwo - len = 2 + j - jcol + len = 2_${ik}$ + j - jcol do i = jrow+nnb-1, jrow, -1 c = a( i, j ) s = b( i, j ) do jj = ppw, ppw+len-1 - temp = work( jj + 2*nnb ) - work( jj + 2*nnb ) = c*temp - s*work( jj ) + temp = work( jj + 2_${ik}$*nnb ) + work( jj + 2_${ik}$*nnb ) = c*temp - s*work( jj ) work( jj ) = s*temp + c*work( jj ) end do - len = len + 1 - ppw = ppw - 2*nnb - 1 + len = len + 1_${ik}$ + ppw = ppw - 2_${ik}$*nnb - 1_${ik}$ end do - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do ! top denotes the number of top rows in a and b that will ! not be updated during the next steps. - if( jcol<=2 ) then - top = 0 + if( jcol<=2_${ik}$ ) then + top = 0_${ik}$ else top = jcol end if @@ -19060,9 +19054,9 @@ module stdlib_linalg_lapack_${ri}$ ! annihilate b( jj+1, jj ). if( jj0 ) then + if( jj>0_${ik}$ ) then do i = jj, 1, -1 - call stdlib_${ri}$rot( ihi-top, a( top+1, j+i+1 ), 1,a( top+1, j+i ), 1, a( & + call stdlib${ii}$_${ri}$rot( ihi-top, a( top+1, j+i+1 ), 1_${ik}$,a( top+1, j+i ), 1_${ik}$, a( & j+1+i, j ),-b( j+1+i, j ) ) end do end if ! update (j+1)th column of a by transformations from left. - if ( j < jcol + nnb - 1 ) then - len = 1 + j - jcol + if ( j < jcol + nnb - 1_${ik}$ ) then + len = 1_${ik}$ + j - jcol ! multiply with the trailing accumulated orthogonal ! matrix, which takes the form ! [ u11 u12 ] @@ -19111,23 +19105,23 @@ module stdlib_linalg_lapack_${ri}$ ! [ u21 u22 ] ! where u21 is a len-by-len matrix and u12 is lower ! triangular. - jrow = ihi - nblst + 1 - call stdlib_${ri}$gemv( 'TRANSPOSE', nblst, len, one, work,nblst, a( jrow, j+1 )& - , 1, zero,work( pw ), 1 ) + jrow = ihi - nblst + 1_${ik}$ + call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', nblst, len, one, work,nblst, a( jrow, j+1 )& + , 1_${ik}$, zero,work( pw ), 1_${ik}$ ) ppw = pw + len do i = jrow, jrow+nblst-len-1 work( ppw ) = a( i, j+1 ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do - call stdlib_${ri}$trmv( 'LOWER', 'TRANSPOSE', 'NON-UNIT',nblst-len, work( & - len*nblst + 1 ), nblst,work( pw+len ), 1 ) - call stdlib_${ri}$gemv( 'TRANSPOSE', len, nblst-len, one,work( (len+1)*nblst - & - len + 1 ), nblst,a( jrow+nblst-len, j+1 ), 1, one,work( pw+len ), 1 ) + call stdlib${ii}$_${ri}$trmv( 'LOWER', 'TRANSPOSE', 'NON-UNIT',nblst-len, work( & + len*nblst + 1_${ik}$ ), nblst,work( pw+len ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', len, nblst-len, one,work( (len+1)*nblst - & + len + 1_${ik}$ ), nblst,a( jrow+nblst-len, j+1 ), 1_${ik}$, one,work( pw+len ), 1_${ik}$ ) ppw = pw do i = jrow, jrow+nblst-1 a( i, j+1 ) = work( ppw ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do ! multiply with the other accumulated orthogonal ! matrices, which take the form @@ -19139,44 +19133,44 @@ module stdlib_linalg_lapack_${ri}$ ! where i denotes the (nnb-len)-by-(nnb-len) identity ! matrix, u21 is a len-by-len upper triangular matrix ! and u12 is an nnb-by-nnb lower triangular matrix. - ppwo = 1 + nblst*nblst + ppwo = 1_${ik}$ + nblst*nblst j0 = jrow - nnb do jrow = j0, jcol+1, -nnb ppw = pw + len do i = jrow, jrow+nnb-1 work( ppw ) = a( i, j+1 ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do ppw = pw do i = jrow+nnb, jrow+nnb+len-1 work( ppw ) = a( i, j+1 ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do - call stdlib_${ri}$trmv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', len,work( ppwo + & - nnb ), 2*nnb, work( pw ),1 ) - call stdlib_${ri}$trmv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', nnb,work( ppwo + & - 2*len*nnb ),2*nnb, work( pw + len ), 1 ) - call stdlib_${ri}$gemv( 'TRANSPOSE', nnb, len, one,work( ppwo ), 2*nnb, a( & - jrow, j+1 ), 1,one, work( pw ), 1 ) - call stdlib_${ri}$gemv( 'TRANSPOSE', len, nnb, one,work( ppwo + 2*len*nnb + & - nnb ), 2*nnb,a( jrow+nnb, j+1 ), 1, one,work( pw+len ), 1 ) + call stdlib${ii}$_${ri}$trmv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', len,work( ppwo + & + nnb ), 2_${ik}$*nnb, work( pw ),1_${ik}$ ) + call stdlib${ii}$_${ri}$trmv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', nnb,work( ppwo + & + 2_${ik}$*len*nnb ),2_${ik}$*nnb, work( pw + len ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', nnb, len, one,work( ppwo ), 2_${ik}$*nnb, a( & + jrow, j+1 ), 1_${ik}$,one, work( pw ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', len, nnb, one,work( ppwo + 2_${ik}$*len*nnb + & + nnb ), 2_${ik}$*nnb,a( jrow+nnb, j+1 ), 1_${ik}$, one,work( pw+len ), 1_${ik}$ ) ppw = pw do i = jrow, jrow+len+nnb-1 a( i, j+1 ) = work( ppw ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end if end do ! apply accumulated orthogonal matrices to a. - cola = n - jcol - nnb + 1 - j = ihi - nblst + 1 - call stdlib_${ri}$gemm( 'TRANSPOSE', 'NO TRANSPOSE', nblst,cola, nblst, one, work, & + cola = n - jcol - nnb + 1_${ik}$ + j = ihi - nblst + 1_${ik}$ + call stdlib${ii}$_${ri}$gemm( 'TRANSPOSE', 'NO TRANSPOSE', nblst,cola, nblst, one, work, & nblst,a( j, jcol+nnb ), lda, zero, work( pw ),nblst ) - call stdlib_${ri}$lacpy( 'ALL', nblst, cola, work( pw ), nblst,a( j, jcol+nnb ), lda ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', nblst, cola, work( pw ), nblst,a( j, jcol+nnb ), lda ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( blk22 ) then @@ -19186,68 +19180,68 @@ module stdlib_linalg_lapack_${ri}$ ! [ u21 u22 ], ! where all blocks are nnb-by-nnb, u21 is upper ! triangular and u12 is lower triangular. - call stdlib_${ri}$orm22( 'LEFT', 'TRANSPOSE', 2*nnb, cola, nnb,nnb, work( ppwo )& - , 2*nnb,a( j, jcol+nnb ), lda, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_${ri}$orm22( 'LEFT', 'TRANSPOSE', 2_${ik}$*nnb, cola, nnb,nnb, work( ppwo )& + , 2_${ik}$*nnb,a( j, jcol+nnb ), lda, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_${ri}$gemm( 'TRANSPOSE', 'NO TRANSPOSE', 2*nnb,cola, 2*nnb, one, & - work( ppwo ), 2*nnb,a( j, jcol+nnb ), lda, zero, work( pw ),2*nnb ) - call stdlib_${ri}$lacpy( 'ALL', 2*nnb, cola, work( pw ), 2*nnb,a( j, jcol+nnb ),& + call stdlib${ii}$_${ri}$gemm( 'TRANSPOSE', 'NO TRANSPOSE', 2_${ik}$*nnb,cola, 2_${ik}$*nnb, one, & + work( ppwo ), 2_${ik}$*nnb,a( j, jcol+nnb ), lda, zero, work( pw ),2_${ik}$*nnb ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', 2_${ik}$*nnb, cola, work( pw ), 2_${ik}$*nnb,a( j, jcol+nnb ),& lda ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do ! apply accumulated orthogonal matrices to q. if( wantq ) then - j = ihi - nblst + 1 + j = ihi - nblst + 1_${ik}$ if ( initq ) then - topq = max( 2, j - jcol + 1 ) - nh = ihi - topq + 1 + topq = max( 2_${ik}$, j - jcol + 1_${ik}$ ) + nh = ihi - topq + 1_${ik}$ else - topq = 1 + topq = 1_${ik}$ nh = n end if - call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, one, q( & + call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, one, q( & topq, j ), ldq,work, nblst, zero, work( pw ), nh ) - call stdlib_${ri}$lacpy( 'ALL', nh, nblst, work( pw ), nh,q( topq, j ), ldq ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', nh, nblst, work( pw ), nh,q( topq, j ), ldq ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( initq ) then - topq = max( 2, j - jcol + 1 ) - nh = ihi - topq + 1 + topq = max( 2_${ik}$, j - jcol + 1_${ik}$ ) + nh = ihi - topq + 1_${ik}$ end if if ( blk22 ) then ! exploit the structure of u. - call stdlib_${ri}$orm22( 'RIGHT', 'NO TRANSPOSE', nh, 2*nnb,nnb, nnb, work( & - ppwo ), 2*nnb,q( topq, j ), ldq, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_${ri}$orm22( 'RIGHT', 'NO TRANSPOSE', nh, 2_${ik}$*nnb,nnb, nnb, work( & + ppwo ), 2_${ik}$*nnb,q( topq, j ), ldq, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2*nnb, 2*nnb, one,& - q( topq, j ), ldq,work( ppwo ), 2*nnb, zero, work( pw ),nh ) - call stdlib_${ri}$lacpy( 'ALL', nh, 2*nnb, work( pw ), nh,q( topq, j ), ldq ) + call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2_${ik}$*nnb, 2_${ik}$*nnb, one,& + q( topq, j ), ldq,work( ppwo ), 2_${ik}$*nnb, zero, work( pw ),nh ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', nh, 2_${ik}$*nnb, work( pw ), nh,q( topq, j ), ldq ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end if ! accumulate right givens rotations if required. - if ( wantz .or. top>0 ) then + if ( wantz .or. top>0_${ik}$ ) then ! initialize small orthogonal factors that will hold the ! accumulated givens rotations in workspace. - call stdlib_${ri}$laset( 'ALL', nblst, nblst, zero, one, work,nblst ) - pw = nblst * nblst + 1 + call stdlib${ii}$_${ri}$laset( 'ALL', nblst, nblst, zero, one, work,nblst ) + pw = nblst * nblst + 1_${ik}$ do i = 1, n2nb - call stdlib_${ri}$laset( 'ALL', 2*nnb, 2*nnb, zero, one,work( pw ), 2*nnb ) + call stdlib${ii}$_${ri}$laset( 'ALL', 2_${ik}$*nnb, 2_${ik}$*nnb, zero, one,work( pw ), 2_${ik}$*nnb ) - pw = pw + 4*nnb*nnb + pw = pw + 4_${ik}$*nnb*nnb end do ! accumulate givens rotations into workspace array. do j = jcol, jcol+nnb-1 - ppw = ( nblst + 1 )*( nblst - 2 ) - j + jcol + 1 - len = 2 + j - jcol - jrow = j + n2nb*nnb + 2 + ppw = ( nblst + 1_${ik}$ )*( nblst - 2_${ik}$ ) - j + jcol + 1_${ik}$ + len = 2_${ik}$ + j - jcol + jrow = j + n2nb*nnb + 2_${ik}$ do i = ihi, jrow, -1 c = a( i, j ) a( i, j ) = zero @@ -19258,114 +19252,114 @@ module stdlib_linalg_lapack_${ri}$ work( jj + nblst ) = c*temp - s*work( jj ) work( jj ) = s*temp + c*work( jj ) end do - len = len + 1 - ppw = ppw - nblst - 1 + len = len + 1_${ik}$ + ppw = ppw - nblst - 1_${ik}$ end do - ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2*nnb + nnb + ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2_${ik}$*nnb + nnb j0 = jrow - nnb do jrow = j0, j+2, -nnb ppw = ppwo - len = 2 + j - jcol + len = 2_${ik}$ + j - jcol do i = jrow+nnb-1, jrow, -1 c = a( i, j ) a( i, j ) = zero s = b( i, j ) b( i, j ) = zero do jj = ppw, ppw+len-1 - temp = work( jj + 2*nnb ) - work( jj + 2*nnb ) = c*temp - s*work( jj ) + temp = work( jj + 2_${ik}$*nnb ) + work( jj + 2_${ik}$*nnb ) = c*temp - s*work( jj ) work( jj ) = s*temp + c*work( jj ) end do - len = len + 1 - ppw = ppw - 2*nnb - 1 + len = len + 1_${ik}$ + ppw = ppw - 2_${ik}$*nnb - 1_${ik}$ end do - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end do else - call stdlib_${ri}$laset( 'LOWER', ihi - jcol - 1, nnb, zero, zero,a( jcol + 2, & + call stdlib${ii}$_${ri}$laset( 'LOWER', ihi - jcol - 1_${ik}$, nnb, zero, zero,a( jcol + 2_${ik}$, & jcol ), lda ) - call stdlib_${ri}$laset( 'LOWER', ihi - jcol - 1, nnb, zero, zero,b( jcol + 2, & + call stdlib${ii}$_${ri}$laset( 'LOWER', ihi - jcol - 1_${ik}$, nnb, zero, zero,b( jcol + 2_${ik}$, & jcol ), ldb ) end if ! apply accumulated orthogonal matrices to a and b. - if ( top>0 ) then - j = ihi - nblst + 1 - call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, one, a( & - 1, j ), lda,work, nblst, zero, work( pw ), top ) - call stdlib_${ri}$lacpy( 'ALL', top, nblst, work( pw ), top,a( 1, j ), lda ) + if ( top>0_${ik}$ ) then + j = ihi - nblst + 1_${ik}$ + call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, one, a( & + 1_${ik}$, j ), lda,work, nblst, zero, work( pw ), top ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', top, nblst, work( pw ), top,a( 1_${ik}$, j ), lda ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( blk22 ) then ! exploit the structure of u. - call stdlib_${ri}$orm22( 'RIGHT', 'NO TRANSPOSE', top, 2*nnb,nnb, nnb, work( & - ppwo ), 2*nnb,a( 1, j ), lda, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_${ri}$orm22( 'RIGHT', 'NO TRANSPOSE', top, 2_${ik}$*nnb,nnb, nnb, work( & + ppwo ), 2_${ik}$*nnb,a( 1_${ik}$, j ), lda, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2*nnb, 2*nnb, & - one, a( 1, j ), lda,work( ppwo ), 2*nnb, zero,work( pw ), top ) - call stdlib_${ri}$lacpy( 'ALL', top, 2*nnb, work( pw ), top,a( 1, j ), lda ) + call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2_${ik}$*nnb, 2_${ik}$*nnb, & + one, a( 1_${ik}$, j ), lda,work( ppwo ), 2_${ik}$*nnb, zero,work( pw ), top ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', top, 2_${ik}$*nnb, work( pw ), top,a( 1_${ik}$, j ), lda ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do - j = ihi - nblst + 1 - call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, one, b( & - 1, j ), ldb,work, nblst, zero, work( pw ), top ) - call stdlib_${ri}$lacpy( 'ALL', top, nblst, work( pw ), top,b( 1, j ), ldb ) + j = ihi - nblst + 1_${ik}$ + call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, one, b( & + 1_${ik}$, j ), ldb,work, nblst, zero, work( pw ), top ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', top, nblst, work( pw ), top,b( 1_${ik}$, j ), ldb ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( blk22 ) then ! exploit the structure of u. - call stdlib_${ri}$orm22( 'RIGHT', 'NO TRANSPOSE', top, 2*nnb,nnb, nnb, work( & - ppwo ), 2*nnb,b( 1, j ), ldb, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_${ri}$orm22( 'RIGHT', 'NO TRANSPOSE', top, 2_${ik}$*nnb,nnb, nnb, work( & + ppwo ), 2_${ik}$*nnb,b( 1_${ik}$, j ), ldb, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2*nnb, 2*nnb, & - one, b( 1, j ), ldb,work( ppwo ), 2*nnb, zero,work( pw ), top ) - call stdlib_${ri}$lacpy( 'ALL', top, 2*nnb, work( pw ), top,b( 1, j ), ldb ) + call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2_${ik}$*nnb, 2_${ik}$*nnb, & + one, b( 1_${ik}$, j ), ldb,work( ppwo ), 2_${ik}$*nnb, zero,work( pw ), top ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', top, 2_${ik}$*nnb, work( pw ), top,b( 1_${ik}$, j ), ldb ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end if ! apply accumulated orthogonal matrices to z. if( wantz ) then - j = ihi - nblst + 1 + j = ihi - nblst + 1_${ik}$ if ( initq ) then - topq = max( 2, j - jcol + 1 ) - nh = ihi - topq + 1 + topq = max( 2_${ik}$, j - jcol + 1_${ik}$ ) + nh = ihi - topq + 1_${ik}$ else - topq = 1 + topq = 1_${ik}$ nh = n end if - call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, one, z( & + call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, one, z( & topq, j ), ldz,work, nblst, zero, work( pw ), nh ) - call stdlib_${ri}$lacpy( 'ALL', nh, nblst, work( pw ), nh,z( topq, j ), ldz ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', nh, nblst, work( pw ), nh,z( topq, j ), ldz ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( initq ) then - topq = max( 2, j - jcol + 1 ) - nh = ihi - topq + 1 + topq = max( 2_${ik}$, j - jcol + 1_${ik}$ ) + nh = ihi - topq + 1_${ik}$ end if if ( blk22 ) then ! exploit the structure of u. - call stdlib_${ri}$orm22( 'RIGHT', 'NO TRANSPOSE', nh, 2*nnb,nnb, nnb, work( & - ppwo ), 2*nnb,z( topq, j ), ldz, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_${ri}$orm22( 'RIGHT', 'NO TRANSPOSE', nh, 2_${ik}$*nnb,nnb, nnb, work( & + ppwo ), 2_${ik}$*nnb,z( topq, j ), ldz, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2*nnb, 2*nnb, one,& - z( topq, j ), ldz,work( ppwo ), 2*nnb, zero, work( pw ),nh ) - call stdlib_${ri}$lacpy( 'ALL', nh, 2*nnb, work( pw ), nh,z( topq, j ), ldz ) + call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2_${ik}$*nnb, 2_${ik}$*nnb, one,& + z( topq, j ), ldz,work( ppwo ), 2_${ik}$*nnb, zero, work( pw ),nh ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', nh, 2_${ik}$*nnb, work( pw ), nh,z( topq, j ), ldz ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end if end do @@ -19378,14 +19372,14 @@ module stdlib_linalg_lapack_${ri}$ if ( wantq )compq2 = 'V' if ( wantz )compz2 = 'V' end if - if ( jcoln .or. ihin .or. pn .or. p0 ) then - call stdlib_${ri}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', p, 1,b( 1, n-p+1 ), ldb, d,& + if( p>0_${ik}$ ) then + call stdlib${ii}$_${ri}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', p, 1_${ik}$,b( 1_${ik}$, n-p+1 ), ldb, d,& p, info ) - if( info>0 ) then - info = 1 + if( info>0_${ik}$ ) then + info = 1_${ik}$ return end if ! put the solution in x - call stdlib_${ri}$copy( p, d, 1, x( n-p+1 ), 1 ) + call stdlib${ii}$_${ri}$copy( p, d, 1_${ik}$, x( n-p+1 ), 1_${ik}$ ) ! update c1 - call stdlib_${ri}$gemv( 'NO TRANSPOSE', n-p, p, -one, a( 1, n-p+1 ), lda,d, 1, one, c, 1 & + call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', n-p, p, -one, a( 1_${ik}$, n-p+1 ), lda,d, 1_${ik}$, one, c, 1_${ik}$ & ) end if ! solve r11*x1 = c1 for x1 if( n>p ) then - call stdlib_${ri}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n-p, 1,a, lda, c, n-p, & + call stdlib${ii}$_${ri}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n-p, 1_${ik}$,a, lda, c, n-p, & info ) - if( info>0 ) then - info = 2 + if( info>0_${ik}$ ) then + info = 2_${ik}$ return end if ! put the solutions in x - call stdlib_${ri}$copy( n-p, c, 1, x, 1 ) + call stdlib${ii}$_${ri}$copy( n-p, c, 1_${ik}$, x, 1_${ik}$ ) end if ! compute the residual vector: if( m0 )call stdlib_${ri}$gemv( 'NO TRANSPOSE', nr, n-m, -one, a( n-p+1, m+1 ),lda, d( & - nr+1 ), 1, one, c( n-p+1 ), 1 ) + if( nr>0_${ik}$ )call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', nr, n-m, -one, a( n-p+1, m+1 ),lda, d( & + nr+1 ), 1_${ik}$, one, c( n-p+1 ), 1_${ik}$ ) else nr = p end if - if( nr>0 ) then - call stdlib_${ri}$trmv( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', nr,a( n-p+1, n-p+1 ), lda, & - d, 1 ) - call stdlib_${ri}$axpy( nr, -one, d, 1, c( n-p+1 ), 1 ) + if( nr>0_${ik}$ ) then + call stdlib${ii}$_${ri}$trmv( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', nr,a( n-p+1, n-p+1 ), lda, & + d, 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( nr, -one, d, 1_${ik}$, c( n-p+1 ), 1_${ik}$ ) end if ! backward transformation x = q**t*x - call stdlib_${ri}$ormrq( 'LEFT', 'TRANSPOSE', n, 1, p, b, ldb, work( 1 ), x,n, work( p+mn+1 & + call stdlib${ii}$_${ri}$ormrq( 'LEFT', 'TRANSPOSE', n, 1_${ik}$, p, b, ldb, work( 1_${ik}$ ), x,n, work( p+mn+1 & ), lwork-p-mn, info ) - work( 1 ) = p + mn + max( lopt, int( work( p+mn+1 ),KIND=ilp) ) + work( 1_${ik}$ ) = p + mn + max( lopt, int( work( p+mn+1 ),KIND=${ik}$) ) return - end subroutine stdlib_${ri}$gglse + end subroutine stdlib${ii}$_${ri}$gglse - pure subroutine stdlib_${ri}$ggqrf( n, m, p, a, lda, taua, b, ldb, taub, work,lwork, info ) + pure subroutine stdlib${ii}$_${ri}$ggqrf( n, m, p, a, lda, taua, b, ldb, taub, work,lwork, info ) !! DGGQRF: computes a generalized QR factorization of an N-by-M matrix A !! and an N-by-P matrix B: !! A = Q*R, B = Q*T*Z, @@ -19671,61 +19665,61 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, ldb, lwork, m, n, p + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, p ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) real(${rk}$), intent(out) :: taua(*), taub(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: lopt, lwkopt, nb, nb1, nb2, nb3 + integer(${ik}$) :: lopt, lwkopt, nb, nb1, nb2, nb3 ! Intrinsic Functions intrinsic :: int,max,min ! Executable Statements ! test the input parameters - info = 0 - nb1 = stdlib_ilaenv( 1, 'DGEQRF', ' ', n, m, -1, -1 ) - nb2 = stdlib_ilaenv( 1, 'DGERQF', ' ', n, p, -1, -1 ) - nb3 = stdlib_ilaenv( 1, 'DORMQR', ' ', n, m, p, -1 ) + info = 0_${ik}$ + nb1 = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGEQRF', ' ', n, m, -1_${ik}$, -1_${ik}$ ) + nb2 = stdlib${ii}$_ilaenv( 1_${ik}$, 'DGERQF', ' ', n, p, -1_${ik}$, -1_${ik}$ ) + nb3 = stdlib${ii}$_ilaenv( 1_${ik}$, 'DORMQR', ' ', n, m, p, -1_${ik}$ ) nb = max( nb1, nb2, nb3 ) lwkopt = max( n, m, p )*nb - work( 1 ) = lwkopt - lquery = ( lwork==-1 ) - if( n<0 ) then - info = -1 - else if( m<0 ) then - info = -2 - else if( p<0 ) then - info = -3 - else if( ldam ) ) then - info = -3 + info = -1_${ik}$ + else if( m<0_${ik}$ ) then + info = -2_${ik}$ + else if( ( n<0_${ik}$ ) .or. ( n>m ) ) then + info = -3_${ik}$ else if( lda sqrt(overflow_threshold), and ! underflow for ||a(:,p)||_2 < sqrt(underflow_threshold). - ! hence, stdlib_${ri}$nrm2 cannot be trusted, not even in the case when + ! hence, stdlib${ii}$_${ri}$nrm2 cannot be trusted, not even in the case when ! the true norm is far from the under(over)flow boundaries. - ! if properly implemented stdlib_${ri}$nrm2 is available, the if-then-else - ! below should read "aapp = stdlib_${ri}$nrm2( m, a(1,p), 1 ) * d(p)". + ! if properly implemented stdlib${ii}$_${ri}$nrm2 is available, the if-then-else + ! below should read "aapp = stdlib${ii}$_${ri}$nrm2( m, a(1,p), 1 ) * d(p)". if( ( sva( p )rootsfmin ) ) then - sva( p ) = stdlib_${ri}$nrm2( m, a( 1, p ), 1 )*d( p ) + sva( p ) = stdlib${ii}$_${ri}$nrm2( m, a( 1_${ik}$, p ), 1_${ik}$ )*d( p ) else temp1 = zero aapp = one - call stdlib_${ri}$lassq( m, a( 1, p ), 1, temp1, aapp ) + call stdlib${ii}$_${ri}$lassq( m, a( 1_${ik}$, p ), 1_${ik}$, temp1, aapp ) sva( p ) = temp1*sqrt( aapp )*d( p ) end if aapp = sva( p ) @@ -19949,7 +19943,7 @@ module stdlib_linalg_lapack_${ri}$ aapp = sva( p ) end if if( aapp>zero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2002: do q = p + 1, min( igl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -19957,25 +19951,25 @@ module stdlib_linalg_lapack_${ri}$ if( aaqq>=one ) then rotok = ( small*aapp )<=aaqq if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_${ri}$dot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& + aapq = ( stdlib${ii}$_${ri}$dot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*d( p )& *d( q ) / aaqq )/ aapp else - call stdlib_${ri}$copy( m, a( 1, p ), 1, work, 1 ) - call stdlib_${ri}$lascl( 'G', 0, 0, aapp, d( p ),m, 1, work, lda,& + call stdlib${ii}$_${ri}$copy( m, a( 1_${ik}$, p ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, d( p ),m, 1_${ik}$, work, lda,& ierr ) - aapq = stdlib_${ri}$dot( m, work, 1, a( 1, q ),1 )*d( q ) / & + aapq = stdlib${ii}$_${ri}$dot( m, work, 1_${ik}$, a( 1_${ik}$, q ),1_${ik}$ )*d( q ) / & aaqq end if else rotok = aapp<=( aaqq / small ) if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_${ri}$dot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& + aapq = ( stdlib${ii}$_${ri}$dot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*d( p )& *d( q ) / aaqq )/ aapp else - call stdlib_${ri}$copy( m, a( 1, q ), 1, work, 1 ) - call stdlib_${ri}$lascl( 'G', 0, 0, aaqq, d( q ),m, 1, work, lda,& + call stdlib${ii}$_${ri}$copy( m, a( 1_${ik}$, q ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, d( q ),m, 1_${ik}$, work, lda,& ierr ) - aapq = stdlib_${ri}$dot( m, work, 1, a( 1, p ),1 )*d( p ) / & + aapq = stdlib${ii}$_${ri}$dot( m, work, 1_${ik}$, a( 1_${ik}$, p ),1_${ik}$ )*d( p ) / & aapp end if end if @@ -19984,10 +19978,10 @@ module stdlib_linalg_lapack_${ri}$ if( abs( aapq )>tol ) then ! Rotate ! rotated = rotated + one - if( ir1==0 ) then - notrot = 0 - pskipped = 0 - iswrot = iswrot + 1 + if( ir1==0_${ik}$ ) then + notrot = 0_${ik}$ + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ end if if( rotok ) then aqoap = aaqq / aapp @@ -19995,12 +19989,12 @@ module stdlib_linalg_lapack_${ri}$ theta = -half*abs( aqoap-apoaq )/aapq if( abs( theta )>bigtheta ) then t = half / theta - fastr( 3 ) = t*d( p ) / d( q ) - fastr( 4 ) = -t*d( q ) / d( p ) - call stdlib_${ri}$rotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) + fastr( 3_${ik}$ ) = t*d( p ) / d( q ) + fastr( 4_${ik}$ ) = -t*d( q ) / d( p ) + call stdlib${ii}$_${ri}$rotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$, fastr ) - if( rsvec )call stdlib_${ri}$rotm( mvl,v( 1, p ), 1,v( 1, q ),& - 1,fastr ) + if( rsvec )call stdlib${ii}$_${ri}$rotm( mvl,v( 1_${ik}$, p ), 1_${ik}$,v( 1_${ik}$, q ),& + 1_${ik}$,fastr ) sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq ) ) @@ -20020,68 +20014,68 @@ module stdlib_linalg_lapack_${ri}$ aqoap = d( q ) / d( p ) if( d( p )>=one ) then if( d( q )>=one ) then - fastr( 3 ) = t*apoaq - fastr( 4 ) = -t*aqoap + fastr( 3_${ik}$ ) = t*apoaq + fastr( 4_${ik}$ ) = -t*aqoap d( p ) = d( p )*cs d( q ) = d( q )*cs - call stdlib_${ri}$rotm( m, a( 1, p ), 1,a( 1, q ), 1,& + call stdlib${ii}$_${ri}$rotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$,& fastr ) - if( rsvec )call stdlib_${ri}$rotm( mvl,v( 1, p ), 1, v( & - 1, q ),1, fastr ) + if( rsvec )call stdlib${ii}$_${ri}$rotm( mvl,v( 1_${ik}$, p ), 1_${ik}$, v( & + 1_${ik}$, q ),1_${ik}$, fastr ) else - call stdlib_${ri}$axpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & - p ), 1 ) - call stdlib_${ri}$axpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & - 1, q ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( 1_${ik}$, & + p ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( & + 1_${ik}$, q ), 1_${ik}$ ) d( p ) = d( p )*cs d( q ) = d( q ) / cs if( rsvec ) then - call stdlib_${ri}$axpy( mvl, -t*aqoap,v( 1, q ), 1,v(& - 1, p ), 1 ) - call stdlib_${ri}$axpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& - v( 1, q ), 1 ) + call stdlib${ii}$_${ri}$axpy( mvl, -t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,v(& + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ), 1_${ik}$,& + v( 1_${ik}$, q ), 1_${ik}$ ) end if end if else if( d( q )>=one ) then - call stdlib_${ri}$axpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & - ), 1 ) - call stdlib_${ri}$axpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q & + ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( m, -cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) d( p ) = d( p ) / cs d( q ) = d( q )*cs if( rsvec ) then - call stdlib_${ri}$axpy( mvl, t*apoaq,v( 1, p ), 1,v( & - 1, q ), 1 ) - call stdlib_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1, q ), & - 1,v( 1, p ), 1 ) + call stdlib${ii}$_${ri}$axpy( mvl, t*apoaq,v( 1_${ik}$, p ), 1_${ik}$,v( & + 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q ), & + 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if else if( d( p )>=d( q ) ) then - call stdlib_${ri}$axpy( m, -t*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) - call stdlib_${ri}$axpy( m, cs*sn*apoaq,a( 1, p ), 1,& - a( 1, q ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,& + a( 1_${ik}$, q ), 1_${ik}$ ) d( p ) = d( p )*cs d( q ) = d( q ) / cs if( rsvec ) then - call stdlib_${ri}$axpy( mvl,-t*aqoap,v( 1, q ), 1,& - v( 1, p ), 1 ) - call stdlib_${ri}$axpy( mvl,cs*sn*apoaq,v( 1, p ),& - 1,v( 1, q ), 1 ) + call stdlib${ii}$_${ri}$axpy( mvl,-t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,& + v( 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ),& + 1_${ik}$,v( 1_${ik}$, q ), 1_${ik}$ ) end if else - call stdlib_${ri}$axpy( m, t*apoaq,a( 1, p ), 1,a( 1,& - q ), 1 ) - call stdlib_${ri}$axpy( m,-cs*sn*aqoap,a( 1, q ), 1,& - a( 1, p ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$,& + q ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( m,-cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,& + a( 1_${ik}$, p ), 1_${ik}$ ) d( p ) = d( p ) / cs d( q ) = d( q )*cs if( rsvec ) then - call stdlib_${ri}$axpy( mvl,t*apoaq, v( 1, p ),1, & - v( 1, q ), 1 ) - call stdlib_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1, q )& - , 1,v( 1, p ), 1 ) + call stdlib${ii}$_${ri}$axpy( mvl,t*apoaq, v( 1_${ik}$, p ),1_${ik}$, & + v( 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q )& + , 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if end if end if @@ -20089,14 +20083,14 @@ module stdlib_linalg_lapack_${ri}$ end if else ! .. have to use modified gram-schmidt like transformation - call stdlib_${ri}$copy( m, a( 1, p ), 1, work, 1 ) - call stdlib_${ri}$lascl( 'G', 0, 0, aapp, one, m,1, work, lda, & + call stdlib${ii}$_${ri}$copy( m, a( 1_${ik}$, p ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one, m,1_${ik}$, work, lda, & ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, aaqq, one, m,1, a( 1, q ), & + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one, m,1_${ik}$, a( 1_${ik}$, q ), & lda, ierr ) temp1 = -aapq*d( p ) / d( q ) - call stdlib_${ri}$axpy( m, temp1, work, 1,a( 1, q ), 1 ) - call stdlib_${ri}$lascl( 'G', 0, 0, one, aaqq, m,1, a( 1, q ), & + call stdlib${ii}$_${ri}$axpy( m, temp1, work, 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq, m,1_${ik}$, a( 1_${ik}$, q ), & lda, ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) @@ -20104,40 +20098,40 @@ module stdlib_linalg_lapack_${ri}$ ! end if rotok then ... else ! in the case of cancellation in updating sva(q), sva(p) ! recompute sva(q), sva(p). - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_${ri}$nrm2( m, a( 1, q ), 1 )*d( q ) + sva( q ) = stdlib${ii}$_${ri}$nrm2( m, a( 1_${ik}$, q ), 1_${ik}$ )*d( q ) else t = zero aaqq = one - call stdlib_${ri}$lassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_${ri}$lassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq )*d( q ) end if end if if( ( aapp / aapp0 )<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_${ri}$nrm2( m, a( 1, p ), 1 )*d( p ) + aapp = stdlib${ii}$_${ri}$nrm2( m, a( 1_${ik}$, p ), 1_${ik}$ )*d( p ) else t = zero aapp = one - call stdlib_${ri}$lassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_${ri}$lassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp )*d( p ) end if sva( p ) = aapp end if else ! a(:,p) and a(:,q) already numerically orthogonal - if( ir1==0 )notrot = notrot + 1 - pskipped = pskipped + 1 + if( ir1==0_${ik}$ )notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ end if else ! a(:,q) is zero column - if( ir1==0 )notrot = notrot + 1 - pskipped = pskipped + 1 + if( ir1==0_${ik}$ )notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then - if( ir1==0 )aapp = -aapp - notrot = 0 + if( ir1==0_${ik}$ )aapp = -aapp + notrot = 0_${ik}$ go to 2103 end if end do loop_2002 @@ -20147,7 +20141,7 @@ module stdlib_linalg_lapack_${ri}$ sva( p ) = aapp else sva( p ) = aapp - if( ( ir1==0 ) .and. ( aapp==zero ) )notrot = notrot + min( igl+kbl-1, & + if( ( ir1==0_${ik}$ ) .and. ( aapp==zero ) )notrot = notrot + min( igl+kbl-1, & n ) - p end if end do loop_2001 @@ -20157,15 +20151,15 @@ module stdlib_linalg_lapack_${ri}$ ! end of ir1-loop ! ........................................................ ! ... go to the off diagonal blocks - igl = ( ibr-1 )*kbl + 1 + igl = ( ibr-1 )*kbl + 1_${ik}$ loop_2010: do jbc = ibr + 1, nbl - jgl = ( jbc-1 )*kbl + 1 + jgl = ( jbc-1 )*kbl + 1_${ik}$ ! doing the block at ( ibr, jbc ) - ijblsk = 0 + ijblsk = 0_${ik}$ loop_2100: do p = igl, min( igl+kbl-1, n ) aapp = sva( p ) if( aapp>zero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2200: do q = jgl, min( jgl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -20179,13 +20173,13 @@ module stdlib_linalg_lapack_${ri}$ rotok = ( small*aaqq )<=aapp end if if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_${ri}$dot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& + aapq = ( stdlib${ii}$_${ri}$dot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*d( p )& *d( q ) / aaqq )/ aapp else - call stdlib_${ri}$copy( m, a( 1, p ), 1, work, 1 ) - call stdlib_${ri}$lascl( 'G', 0, 0, aapp, d( p ),m, 1, work, lda,& + call stdlib${ii}$_${ri}$copy( m, a( 1_${ik}$, p ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, d( p ),m, 1_${ik}$, work, lda,& ierr ) - aapq = stdlib_${ri}$dot( m, work, 1, a( 1, q ),1 )*d( q ) / & + aapq = stdlib${ii}$_${ri}$dot( m, work, 1_${ik}$, a( 1_${ik}$, q ),1_${ik}$ )*d( q ) / & aaqq end if else @@ -20195,23 +20189,23 @@ module stdlib_linalg_lapack_${ri}$ rotok = aaqq<=( aapp / small ) end if if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_${ri}$dot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& + aapq = ( stdlib${ii}$_${ri}$dot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*d( p )& *d( q ) / aaqq )/ aapp else - call stdlib_${ri}$copy( m, a( 1, q ), 1, work, 1 ) - call stdlib_${ri}$lascl( 'G', 0, 0, aaqq, d( q ),m, 1, work, lda,& + call stdlib${ii}$_${ri}$copy( m, a( 1_${ik}$, q ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, d( q ),m, 1_${ik}$, work, lda,& ierr ) - aapq = stdlib_${ri}$dot( m, work, 1, a( 1, p ),1 )*d( p ) / & + aapq = stdlib${ii}$_${ri}$dot( m, work, 1_${ik}$, a( 1_${ik}$, p ),1_${ik}$ )*d( p ) / & aapp end if end if mxaapq = max( mxaapq, abs( aapq ) ) ! to rotate or not to rotate, that is the question ... if( abs( aapq )>tol ) then - notrot = 0 + notrot = 0_${ik}$ ! rotated = rotated + 1 - pskipped = 0 - iswrot = iswrot + 1 + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ if( rotok ) then aqoap = aaqq / aapp apoaq = aapp / aaqq @@ -20219,12 +20213,12 @@ module stdlib_linalg_lapack_${ri}$ if( aaqq>aapp0 )theta = -theta if( abs( theta )>bigtheta ) then t = half / theta - fastr( 3 ) = t*d( p ) / d( q ) - fastr( 4 ) = -t*d( q ) / d( p ) - call stdlib_${ri}$rotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) + fastr( 3_${ik}$ ) = t*d( p ) / d( q ) + fastr( 4_${ik}$ ) = -t*d( q ) / d( p ) + call stdlib${ii}$_${ri}$rotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$, fastr ) - if( rsvec )call stdlib_${ri}$rotm( mvl,v( 1, p ), 1,v( 1, q ),& - 1,fastr ) + if( rsvec )call stdlib${ii}$_${ri}$rotm( mvl,v( 1_${ik}$, p ), 1_${ik}$,v( 1_${ik}$, q ),& + 1_${ik}$,fastr ) sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq ) ) @@ -20245,68 +20239,68 @@ module stdlib_linalg_lapack_${ri}$ aqoap = d( q ) / d( p ) if( d( p )>=one ) then if( d( q )>=one ) then - fastr( 3 ) = t*apoaq - fastr( 4 ) = -t*aqoap + fastr( 3_${ik}$ ) = t*apoaq + fastr( 4_${ik}$ ) = -t*aqoap d( p ) = d( p )*cs d( q ) = d( q )*cs - call stdlib_${ri}$rotm( m, a( 1, p ), 1,a( 1, q ), 1,& + call stdlib${ii}$_${ri}$rotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$,& fastr ) - if( rsvec )call stdlib_${ri}$rotm( mvl,v( 1, p ), 1, v( & - 1, q ),1, fastr ) + if( rsvec )call stdlib${ii}$_${ri}$rotm( mvl,v( 1_${ik}$, p ), 1_${ik}$, v( & + 1_${ik}$, q ),1_${ik}$, fastr ) else - call stdlib_${ri}$axpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & - p ), 1 ) - call stdlib_${ri}$axpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & - 1, q ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( 1_${ik}$, & + p ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( & + 1_${ik}$, q ), 1_${ik}$ ) if( rsvec ) then - call stdlib_${ri}$axpy( mvl, -t*aqoap,v( 1, q ), 1,v(& - 1, p ), 1 ) - call stdlib_${ri}$axpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& - v( 1, q ), 1 ) + call stdlib${ii}$_${ri}$axpy( mvl, -t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,v(& + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ), 1_${ik}$,& + v( 1_${ik}$, q ), 1_${ik}$ ) end if d( p ) = d( p )*cs d( q ) = d( q ) / cs end if else if( d( q )>=one ) then - call stdlib_${ri}$axpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & - ), 1 ) - call stdlib_${ri}$axpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q & + ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( m, -cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) if( rsvec ) then - call stdlib_${ri}$axpy( mvl, t*apoaq,v( 1, p ), 1,v( & - 1, q ), 1 ) - call stdlib_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1, q ), & - 1,v( 1, p ), 1 ) + call stdlib${ii}$_${ri}$axpy( mvl, t*apoaq,v( 1_${ik}$, p ), 1_${ik}$,v( & + 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q ), & + 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if d( p ) = d( p ) / cs d( q ) = d( q )*cs else if( d( p )>=d( q ) ) then - call stdlib_${ri}$axpy( m, -t*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) - call stdlib_${ri}$axpy( m, cs*sn*apoaq,a( 1, p ), 1,& - a( 1, q ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,& + a( 1_${ik}$, q ), 1_${ik}$ ) d( p ) = d( p )*cs d( q ) = d( q ) / cs if( rsvec ) then - call stdlib_${ri}$axpy( mvl,-t*aqoap,v( 1, q ), 1,& - v( 1, p ), 1 ) - call stdlib_${ri}$axpy( mvl,cs*sn*apoaq,v( 1, p ),& - 1,v( 1, q ), 1 ) + call stdlib${ii}$_${ri}$axpy( mvl,-t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,& + v( 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ),& + 1_${ik}$,v( 1_${ik}$, q ), 1_${ik}$ ) end if else - call stdlib_${ri}$axpy( m, t*apoaq,a( 1, p ), 1,a( 1,& - q ), 1 ) - call stdlib_${ri}$axpy( m,-cs*sn*aqoap,a( 1, q ), 1,& - a( 1, p ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$,& + q ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( m,-cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,& + a( 1_${ik}$, p ), 1_${ik}$ ) d( p ) = d( p ) / cs d( q ) = d( q )*cs if( rsvec ) then - call stdlib_${ri}$axpy( mvl,t*apoaq, v( 1, p ),1, & - v( 1, q ), 1 ) - call stdlib_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1, q )& - , 1,v( 1, p ), 1 ) + call stdlib${ii}$_${ri}$axpy( mvl,t*apoaq, v( 1_${ik}$, p ),1_${ik}$, & + v( 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q )& + , 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if end if end if @@ -20314,28 +20308,28 @@ module stdlib_linalg_lapack_${ri}$ end if else if( aapp>aaqq ) then - call stdlib_${ri}$copy( m, a( 1, p ), 1, work,1 ) - call stdlib_${ri}$lascl( 'G', 0, 0, aapp, one,m, 1, work, lda,& + call stdlib${ii}$_${ri}$copy( m, a( 1_${ik}$, p ), 1_${ik}$, work,1_${ik}$ ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, work, lda,& ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) temp1 = -aapq*d( p ) / d( q ) - call stdlib_${ri}$axpy( m, temp1, work, 1,a( 1, q ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, temp1, work, 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) - call stdlib_${ri}$lascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) else - call stdlib_${ri}$copy( m, a( 1, q ), 1, work,1 ) - call stdlib_${ri}$lascl( 'G', 0, 0, aaqq, one,m, 1, work, lda,& + call stdlib${ii}$_${ri}$copy( m, a( 1_${ik}$, q ), 1_${ik}$, work,1_${ik}$ ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, work, lda,& ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) temp1 = -aapq*d( q ) / d( p ) - call stdlib_${ri}$axpy( m, temp1, work, 1,a( 1, p ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, temp1, work, 1_${ik}$,a( 1_${ik}$, p ), 1_${ik}$ ) - call stdlib_${ri}$lascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, aapp,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) sva( p ) = aapp*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) @@ -20344,46 +20338,46 @@ module stdlib_linalg_lapack_${ri}$ ! end if rotok then ... else ! in the case of cancellation in updating sva(q) ! .. recompute sva(q) - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_${ri}$nrm2( m, a( 1, q ), 1 )*d( q ) + sva( q ) = stdlib${ii}$_${ri}$nrm2( m, a( 1_${ik}$, q ), 1_${ik}$ )*d( q ) else t = zero aaqq = one - call stdlib_${ri}$lassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_${ri}$lassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq )*d( q ) end if end if - if( ( aapp / aapp0 )**2<=rooteps ) then + if( ( aapp / aapp0 )**2_${ik}$<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_${ri}$nrm2( m, a( 1, p ), 1 )*d( p ) + aapp = stdlib${ii}$_${ri}$nrm2( m, a( 1_${ik}$, p ), 1_${ik}$ )*d( p ) else t = zero aapp = one - call stdlib_${ri}$lassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_${ri}$lassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp )*d( p ) end if sva( p ) = aapp end if ! end of ok rotation else - notrot = notrot + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if else - notrot = notrot + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if if( ( i<=swband ) .and. ( ijblsk>=blskip ) )then sva( p ) = aapp - notrot = 0 + notrot = 0_${ik}$ go to 2011 end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then aapp = -aapp - notrot = 0 + notrot = 0_${ik}$ go to 2203 end if end do loop_2200 @@ -20391,8 +20385,8 @@ module stdlib_linalg_lapack_${ri}$ 2203 continue sva( p ) = aapp else - if( aapp==zero )notrot = notrot +min( jgl+kbl-1, n ) - jgl + 1 - if( aapprootsfmin ) )then - sva( n ) = stdlib_${ri}$nrm2( m, a( 1, n ), 1 )*d( n ) + sva( n ) = stdlib${ii}$_${ri}$nrm2( m, a( 1_${ik}$, n ), 1_${ik}$ )*d( n ) else t = zero aapp = one - call stdlib_${ri}$lassq( m, a( 1, n ), 1, t, aapp ) + call stdlib${ii}$_${ri}$lassq( m, a( 1_${ik}$, n ), 1_${ik}$, t, aapp ) sva( n ) = t*sqrt( aapp )*d( n ) end if ! additional steering devices @@ -20425,17 +20419,17 @@ module stdlib_linalg_lapack_${ri}$ ! end i=1:nsweep loop ! #:) reaching this point means that the procedure has completed the given ! number of iterations. - info = nsweep - 1 + info = nsweep - 1_${ik}$ go to 1995 1994 continue ! #:) reaching this point means that during the i-th sweep all pivots were ! below the given tolerance, causing early exit. - info = 0 + info = 0_${ik}$ ! #:) info = 0 confirms successful iterations. 1995 continue ! sort the vector d. do p = 1, n - 1 - q = stdlib_i${ri}$amax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib${ii}$_i${ri}$amax( n-p+1, sva( p ), 1_${ik}$ ) + p - 1_${ik}$ if( p/=q ) then temp1 = sva( p ) sva( p ) = sva( q ) @@ -20443,15 +20437,15 @@ module stdlib_linalg_lapack_${ri}$ temp1 = d( p ) d( p ) = d( q ) d( q ) = temp1 - call stdlib_${ri}$swap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_${ri}$swap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) + call stdlib${ii}$_${ri}$swap( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) + if( rsvec )call stdlib${ii}$_${ri}$swap( mvl, v( 1_${ik}$, p ), 1_${ik}$, v( 1_${ik}$, q ), 1_${ik}$ ) end if end do return - end subroutine stdlib_${ri}$gsvj0 + end subroutine stdlib${ii}$_${ri}$gsvj0 - pure subroutine stdlib_${ri}$gsvj1( jobv, m, n, n1, a, lda, d, sva, mv, v, ldv,eps, sfmin, tol, & + pure subroutine stdlib${ii}$_${ri}$gsvj1( jobv, m, n, n1, a, lda, d, sva, mv, v, ldv,eps, sfmin, tol, & !! DGSVJ1: is called from DGESVJ as a pre-processor and that is its main !! purpose. It applies Jacobi rotations in the same way as DGESVJ does, but !! it targets only particular pivots and it does not check convergence @@ -20482,8 +20476,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${rk}$), intent(in) :: eps, sfmin, tol - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldv, lwork, m, mv, n, n1, nsweep + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldv, lwork, m, mv, n, n1, nsweep character, intent(in) :: jobv ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*), d(n), sva(n), v(ldv,*) @@ -20494,11 +20488,11 @@ module stdlib_linalg_lapack_${ri}$ real(${rk}$) :: aapp, aapp0, aapq, aaqq, apoaq, aqoap, big, bigtheta, cs, large, mxaapq, & mxsinj, rootbig, rooteps, rootsfmin, roottol, small, sn, t, temp1, theta, & thsign - integer(ilp) :: blskip, emptsw, i, ibr, igl, ierr, ijblsk, iswrot, jbc, jgl, kbl, mvl, & + integer(${ik}$) :: blskip, emptsw, i, ibr, igl, ierr, ijblsk, iswrot, jbc, jgl, kbl, mvl, & notrot, nblc, nblr, p, pskipped, q, rowskip, swband logical(lk) :: applv, rotok, rsvec ! Local Arrays - real(${rk}$) :: fastr(5) + real(${rk}$) :: fastr(5_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,real,min,sign,sqrt ! Executable Statements @@ -20506,31 +20500,31 @@ module stdlib_linalg_lapack_${ri}$ applv = stdlib_lsame( jobv, 'A' ) rsvec = stdlib_lsame( jobv, 'V' ) if( .not.( rsvec .or. applv .or. stdlib_lsame( jobv, 'N' ) ) ) then - info = -1 - else if( m<0 ) then - info = -2 - else if( ( n<0 ) .or. ( n>m ) ) then - info = -3 - else if( n1<0 ) then - info = -4 + info = -1_${ik}$ + else if( m<0_${ik}$ ) then + info = -2_${ik}$ + else if( ( n<0_${ik}$ ) .or. ( n>m ) ) then + info = -3_${ik}$ + else if( n1<0_${ik}$ ) then + info = -4_${ik}$ else if( ldazero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2200: do q = jgl, min( jgl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -20606,13 +20600,13 @@ module stdlib_linalg_lapack_${ri}$ rotok = ( small*aaqq )<=aapp end if if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_${ri}$dot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& + aapq = ( stdlib${ii}$_${ri}$dot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*d( p )& *d( q ) / aaqq )/ aapp else - call stdlib_${ri}$copy( m, a( 1, p ), 1, work, 1 ) - call stdlib_${ri}$lascl( 'G', 0, 0, aapp, d( p ),m, 1, work, lda,& + call stdlib${ii}$_${ri}$copy( m, a( 1_${ik}$, p ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, d( p ),m, 1_${ik}$, work, lda,& ierr ) - aapq = stdlib_${ri}$dot( m, work, 1, a( 1, q ),1 )*d( q ) / & + aapq = stdlib${ii}$_${ri}$dot( m, work, 1_${ik}$, a( 1_${ik}$, q ),1_${ik}$ )*d( q ) / & aaqq end if else @@ -20622,23 +20616,23 @@ module stdlib_linalg_lapack_${ri}$ rotok = aaqq<=( aapp / small ) end if if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_${ri}$dot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& + aapq = ( stdlib${ii}$_${ri}$dot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*d( p )& *d( q ) / aaqq )/ aapp else - call stdlib_${ri}$copy( m, a( 1, q ), 1, work, 1 ) - call stdlib_${ri}$lascl( 'G', 0, 0, aaqq, d( q ),m, 1, work, lda,& + call stdlib${ii}$_${ri}$copy( m, a( 1_${ik}$, q ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, d( q ),m, 1_${ik}$, work, lda,& ierr ) - aapq = stdlib_${ri}$dot( m, work, 1, a( 1, p ),1 )*d( p ) / & + aapq = stdlib${ii}$_${ri}$dot( m, work, 1_${ik}$, a( 1_${ik}$, p ),1_${ik}$ )*d( p ) / & aapp end if end if mxaapq = max( mxaapq, abs( aapq ) ) ! to rotate or not to rotate, that is the question ... if( abs( aapq )>tol ) then - notrot = 0 + notrot = 0_${ik}$ ! rotated = rotated + 1 - pskipped = 0 - iswrot = iswrot + 1 + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ if( rotok ) then aqoap = aaqq / aapp apoaq = aapp / aaqq @@ -20646,12 +20640,12 @@ module stdlib_linalg_lapack_${ri}$ if( aaqq>aapp0 )theta = -theta if( abs( theta )>bigtheta ) then t = half / theta - fastr( 3 ) = t*d( p ) / d( q ) - fastr( 4 ) = -t*d( q ) / d( p ) - call stdlib_${ri}$rotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) + fastr( 3_${ik}$ ) = t*d( p ) / d( q ) + fastr( 4_${ik}$ ) = -t*d( q ) / d( p ) + call stdlib${ii}$_${ri}$rotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$, fastr ) - if( rsvec )call stdlib_${ri}$rotm( mvl,v( 1, p ), 1,v( 1, q ),& - 1,fastr ) + if( rsvec )call stdlib${ii}$_${ri}$rotm( mvl,v( 1_${ik}$, p ), 1_${ik}$,v( 1_${ik}$, q ),& + 1_${ik}$,fastr ) sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq ) ) @@ -20672,68 +20666,68 @@ module stdlib_linalg_lapack_${ri}$ aqoap = d( q ) / d( p ) if( d( p )>=one ) then if( d( q )>=one ) then - fastr( 3 ) = t*apoaq - fastr( 4 ) = -t*aqoap + fastr( 3_${ik}$ ) = t*apoaq + fastr( 4_${ik}$ ) = -t*aqoap d( p ) = d( p )*cs d( q ) = d( q )*cs - call stdlib_${ri}$rotm( m, a( 1, p ), 1,a( 1, q ), 1,& + call stdlib${ii}$_${ri}$rotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$,& fastr ) - if( rsvec )call stdlib_${ri}$rotm( mvl,v( 1, p ), 1, v( & - 1, q ),1, fastr ) + if( rsvec )call stdlib${ii}$_${ri}$rotm( mvl,v( 1_${ik}$, p ), 1_${ik}$, v( & + 1_${ik}$, q ),1_${ik}$, fastr ) else - call stdlib_${ri}$axpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & - p ), 1 ) - call stdlib_${ri}$axpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & - 1, q ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( 1_${ik}$, & + p ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( & + 1_${ik}$, q ), 1_${ik}$ ) if( rsvec ) then - call stdlib_${ri}$axpy( mvl, -t*aqoap,v( 1, q ), 1,v(& - 1, p ), 1 ) - call stdlib_${ri}$axpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& - v( 1, q ), 1 ) + call stdlib${ii}$_${ri}$axpy( mvl, -t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,v(& + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ), 1_${ik}$,& + v( 1_${ik}$, q ), 1_${ik}$ ) end if d( p ) = d( p )*cs d( q ) = d( q ) / cs end if else if( d( q )>=one ) then - call stdlib_${ri}$axpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & - ), 1 ) - call stdlib_${ri}$axpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q & + ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( m, -cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) if( rsvec ) then - call stdlib_${ri}$axpy( mvl, t*apoaq,v( 1, p ), 1,v( & - 1, q ), 1 ) - call stdlib_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1, q ), & - 1,v( 1, p ), 1 ) + call stdlib${ii}$_${ri}$axpy( mvl, t*apoaq,v( 1_${ik}$, p ), 1_${ik}$,v( & + 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q ), & + 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if d( p ) = d( p ) / cs d( q ) = d( q )*cs else if( d( p )>=d( q ) ) then - call stdlib_${ri}$axpy( m, -t*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) - call stdlib_${ri}$axpy( m, cs*sn*apoaq,a( 1, p ), 1,& - a( 1, q ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,& + a( 1_${ik}$, q ), 1_${ik}$ ) d( p ) = d( p )*cs d( q ) = d( q ) / cs if( rsvec ) then - call stdlib_${ri}$axpy( mvl,-t*aqoap,v( 1, q ), 1,& - v( 1, p ), 1 ) - call stdlib_${ri}$axpy( mvl,cs*sn*apoaq,v( 1, p ),& - 1,v( 1, q ), 1 ) + call stdlib${ii}$_${ri}$axpy( mvl,-t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,& + v( 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ),& + 1_${ik}$,v( 1_${ik}$, q ), 1_${ik}$ ) end if else - call stdlib_${ri}$axpy( m, t*apoaq,a( 1, p ), 1,a( 1,& - q ), 1 ) - call stdlib_${ri}$axpy( m,-cs*sn*aqoap,a( 1, q ), 1,& - a( 1, p ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$,& + q ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( m,-cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,& + a( 1_${ik}$, p ), 1_${ik}$ ) d( p ) = d( p ) / cs d( q ) = d( q )*cs if( rsvec ) then - call stdlib_${ri}$axpy( mvl,t*apoaq, v( 1, p ),1, & - v( 1, q ), 1 ) - call stdlib_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1, q )& - , 1,v( 1, p ), 1 ) + call stdlib${ii}$_${ri}$axpy( mvl,t*apoaq, v( 1_${ik}$, p ),1_${ik}$, & + v( 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q )& + , 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if end if end if @@ -20741,28 +20735,28 @@ module stdlib_linalg_lapack_${ri}$ end if else if( aapp>aaqq ) then - call stdlib_${ri}$copy( m, a( 1, p ), 1, work,1 ) - call stdlib_${ri}$lascl( 'G', 0, 0, aapp, one,m, 1, work, lda,& + call stdlib${ii}$_${ri}$copy( m, a( 1_${ik}$, p ), 1_${ik}$, work,1_${ik}$ ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, work, lda,& ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) temp1 = -aapq*d( p ) / d( q ) - call stdlib_${ri}$axpy( m, temp1, work, 1,a( 1, q ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, temp1, work, 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) - call stdlib_${ri}$lascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) else - call stdlib_${ri}$copy( m, a( 1, q ), 1, work,1 ) - call stdlib_${ri}$lascl( 'G', 0, 0, aaqq, one,m, 1, work, lda,& + call stdlib${ii}$_${ri}$copy( m, a( 1_${ik}$, q ), 1_${ik}$, work,1_${ik}$ ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, work, lda,& ierr ) - call stdlib_${ri}$lascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) temp1 = -aapq*d( q ) / d( p ) - call stdlib_${ri}$axpy( m, temp1, work, 1,a( 1, p ), 1 ) + call stdlib${ii}$_${ri}$axpy( m, temp1, work, 1_${ik}$,a( 1_${ik}$, p ), 1_${ik}$ ) - call stdlib_${ri}$lascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, aapp,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) sva( p ) = aapp*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) @@ -20771,48 +20765,48 @@ module stdlib_linalg_lapack_${ri}$ ! end if rotok then ... else ! in the case of cancellation in updating sva(q) ! .. recompute sva(q) - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_${ri}$nrm2( m, a( 1, q ), 1 )*d( q ) + sva( q ) = stdlib${ii}$_${ri}$nrm2( m, a( 1_${ik}$, q ), 1_${ik}$ )*d( q ) else t = zero aaqq = one - call stdlib_${ri}$lassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_${ri}$lassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq )*d( q ) end if end if - if( ( aapp / aapp0 )**2<=rooteps ) then + if( ( aapp / aapp0 )**2_${ik}$<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_${ri}$nrm2( m, a( 1, p ), 1 )*d( p ) + aapp = stdlib${ii}$_${ri}$nrm2( m, a( 1_${ik}$, p ), 1_${ik}$ )*d( p ) else t = zero aapp = one - call stdlib_${ri}$lassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_${ri}$lassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp )*d( p ) end if sva( p ) = aapp end if ! end of ok rotation else - notrot = notrot + 1 + notrot = notrot + 1_${ik}$ ! skipped = skipped + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if else - notrot = notrot + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if ! if ( notrot >= emptsw ) go to 2011 if( ( i<=swband ) .and. ( ijblsk>=blskip ) )then sva( p ) = aapp - notrot = 0 + notrot = 0_${ik}$ go to 2011 end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then aapp = -aapp - notrot = 0 + notrot = 0_${ik}$ go to 2203 end if end do loop_2200 @@ -20820,8 +20814,8 @@ module stdlib_linalg_lapack_${ri}$ 2203 continue sva( p ) = aapp else - if( aapp==zero )notrot = notrot +min( jgl+kbl-1, n ) - jgl + 1 - if( aapp= emptsw ) go to 2011 end if end do loop_2100 @@ -20838,11 +20832,11 @@ module stdlib_linalg_lapack_${ri}$ ! 2000 :: end of the ibr-loop ! .. update sva(n) if( ( sva( n )rootsfmin ) )then - sva( n ) = stdlib_${ri}$nrm2( m, a( 1, n ), 1 )*d( n ) + sva( n ) = stdlib${ii}$_${ri}$nrm2( m, a( 1_${ik}$, n ), 1_${ik}$ )*d( n ) else t = zero aapp = one - call stdlib_${ri}$lassq( m, a( 1, n ), 1, t, aapp ) + call stdlib${ii}$_${ri}$lassq( m, a( 1_${ik}$, n ), 1_${ik}$, t, aapp ) sva( n ) = t*sqrt( aapp )*d( n ) end if ! additional steering devices @@ -20856,17 +20850,17 @@ module stdlib_linalg_lapack_${ri}$ ! end i=1:nsweep loop ! #:) reaching this point means that the procedure has completed the given ! number of sweeps. - info = nsweep - 1 + info = nsweep - 1_${ik}$ go to 1995 1994 continue ! #:) reaching this point means that during the i-th sweep all pivots were ! below the given threshold, causing early exit. - info = 0 + info = 0_${ik}$ ! #:) info = 0 confirms successful iterations. 1995 continue ! sort the vector d do p = 1, n - 1 - q = stdlib_i${ri}$amax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib${ii}$_i${ri}$amax( n-p+1, sva( p ), 1_${ik}$ ) + p - 1_${ik}$ if( p/=q ) then temp1 = sva( p ) sva( p ) = sva( q ) @@ -20874,15 +20868,15 @@ module stdlib_linalg_lapack_${ri}$ temp1 = d( p ) d( p ) = d( q ) d( q ) = temp1 - call stdlib_${ri}$swap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_${ri}$swap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) + call stdlib${ii}$_${ri}$swap( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) + if( rsvec )call stdlib${ii}$_${ri}$swap( mvl, v( 1_${ik}$, p ), 1_${ik}$, v( 1_${ik}$, q ), 1_${ik}$ ) end if end do return - end subroutine stdlib_${ri}$gsvj1 + end subroutine stdlib${ii}$_${ri}$gsvj1 - pure subroutine stdlib_${ri}$gtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond,work, iwork, info & + pure subroutine stdlib${ii}$_${ri}$gtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond,work, iwork, info & !! DGTCON: estimates the reciprocal of the condition number of a real !! tridiagonal matrix A using the LU factorization as computed by !! DGTTRF. @@ -20894,41 +20888,41 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(${rk}$), intent(in) :: anorm real(${rk}$), 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(${rk}$), intent(in) :: d(*), dl(*), du(*), du2(*) real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: onenrm - integer(ilp) :: i, kase, kase1 + integer(${ik}$) :: i, kase, kase1 real(${rk}$) :: ainvnm ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Executable Statements ! test the input arguments. - info = 0 + info = 0_${ik}$ onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' ) if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then - info = -1 - else if( n<0 ) then - info = -2 + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ else if( anormeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_${ri}$gttrs( trans, n, 1, dlf, df, duf, du2, ipiv,work( n+1 ), n, info ) + call stdlib${ii}$_${ri}$gttrs( trans, n, 1_${ik}$, dlf, df, duf, du2, ipiv,work( n+1 ), n, info ) - call stdlib_${ri}$axpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) + call stdlib${ii}$_${ri}$axpy( 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 @@ -21134,14 +21128,14 @@ module stdlib_linalg_lapack_${ri}$ work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1 end if end do - kase = 0 + kase = 0_${ik}$ 70 continue - call stdlib_${ri}$lacn2( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ),kase, isave ) + call stdlib${ii}$_${ri}$lacn2( 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_${ri}$gttrs( transt, n, 1, dlf, df, duf, du2, ipiv,work( n+1 ), n, & + call stdlib${ii}$_${ri}$gttrs( transt, n, 1_${ik}$, dlf, df, duf, du2, ipiv,work( n+1 ), n, & info ) do i = 1, n work( n+i ) = work( i )*work( n+i ) @@ -21151,7 +21145,7 @@ module stdlib_linalg_lapack_${ri}$ do i = 1, n work( n+i ) = work( i )*work( n+i ) end do - call stdlib_${ri}$gttrs( transn, n, 1, dlf, df, duf, du2, ipiv,work( n+1 ), n, & + call stdlib${ii}$_${ri}$gttrs( transn, n, 1_${ik}$, dlf, df, duf, du2, ipiv,work( n+1 ), n, & info ) end if go to 70 @@ -21164,10 +21158,10 @@ module stdlib_linalg_lapack_${ri}$ if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_110 return - end subroutine stdlib_${ri}$gtrfs + end subroutine stdlib${ii}$_${ri}$gtrfs - pure subroutine stdlib_${ri}$gtsv( n, nrhs, dl, d, du, b, ldb, info ) + pure subroutine stdlib${ii}$_${ri}$gtsv( n, nrhs, dl, d, du, b, ldb, info ) !! DGTSV: solves the equation !! A*X = B, !! where A is an n by n tridiagonal matrix, by Gaussian elimination with @@ -21178,39 +21172,39 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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) :: ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments real(${rk}$), intent(inout) :: b(ldb,*), d(*), dl(*), du(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(${rk}$) :: fact, temp ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements - info = 0 - if( n<0 ) then - info = -1 - else if( nrhs<0 ) then - info = -2 - else if( ldb=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 @@ -21225,18 +21219,18 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -21247,9 +21241,9 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -21287,8 +21281,8 @@ module stdlib_linalg_lapack_${ri}$ 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 ) @@ -21319,23 +21313,23 @@ module stdlib_linalg_lapack_${ri}$ 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 ) @@ -21343,10 +21337,10 @@ module stdlib_linalg_lapack_${ri}$ end do end if return - end subroutine stdlib_${ri}$gtsv + end subroutine stdlib${ii}$_${ri}$gtsv - pure subroutine stdlib_${ri}$gtsvx( fact, trans, n, nrhs, dl, d, du, dlf, df, duf,du2, ipiv, b, & + pure subroutine stdlib${ii}$_${ri}$gtsvx( fact, trans, n, nrhs, dl, d, du, dlf, df, duf,du2, ipiv, b, & !! DGTSVX: uses the LU factorization to compute the solution to a real !! system of linear equations A * X = B or A**T * X = B, !! where A is a tridiagonal matrix of order N and X and B are N-by-NRHS @@ -21359,12 +21353,12 @@ module stdlib_linalg_lapack_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: fact, trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs real(${rk}$), intent(out) :: rcond ! Array Arguments - integer(ilp), intent(inout) :: ipiv(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(inout) :: ipiv(*) + integer(${ik}$), intent(out) :: iwork(*) real(${rk}$), intent(in) :: b(ldb,*), d(*), dl(*), du(*) real(${rk}$), intent(out) :: berr(*), ferr(*), work(*), x(ldx,*) real(${rk}$), intent(inout) :: df(*), dlf(*), du2(*), duf(*) @@ -21377,37 +21371,37 @@ module stdlib_linalg_lapack_${ri}$ ! Intrinsic Functions intrinsic :: max ! Executable Statements - info = 0 + info = 0_${ik}$ nofact = stdlib_lsame( fact, 'N' ) notran = stdlib_lsame( trans, 'N' ) if( .not.nofact .and. .not.stdlib_lsame( fact, 'F' ) ) 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 - else if( n<0 ) then - info = -3 - else if( nrhs<0 ) then - info = -4 - else if( ldb1 ) then - call stdlib_${ri}$copy( n-1, dl, 1, dlf, 1 ) - call stdlib_${ri}$copy( n-1, du, 1, duf, 1 ) + call stdlib${ii}$_${ri}$copy( n, d, 1_${ik}$, df, 1_${ik}$ ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_${ri}$copy( n-1, dl, 1_${ik}$, dlf, 1_${ik}$ ) + call stdlib${ii}$_${ri}$copy( n-1, du, 1_${ik}$, duf, 1_${ik}$ ) end if - call stdlib_${ri}$gttrf( n, dlf, df, duf, du2, ipiv, info ) + call stdlib${ii}$_${ri}$gttrf( n, dlf, df, duf, du2, ipiv, info ) ! return if info is non-zero. - if( info>0 )then + if( info>0_${ik}$ )then rcond = zero return end if @@ -21418,24 +21412,24 @@ module stdlib_linalg_lapack_${ri}$ else norm = 'I' end if - anorm = stdlib_${ri}$langt( norm, n, dl, d, du ) + anorm = stdlib${ii}$_${ri}$langt( norm, n, dl, d, du ) ! compute the reciprocal of the condition number of a. - call stdlib_${ri}$gtcon( norm, n, dlf, df, duf, du2, ipiv, anorm, rcond, work,iwork, info ) + call stdlib${ii}$_${ri}$gtcon( norm, n, dlf, df, duf, du2, ipiv, anorm, rcond, work,iwork, info ) ! compute the solution vectors x. - call stdlib_${ri}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_${ri}$gttrs( trans, n, nrhs, dlf, df, duf, du2, ipiv, x, ldx,info ) + call stdlib${ii}$_${ri}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_${ri}$gttrs( trans, n, nrhs, dlf, df, duf, du2, ipiv, x, ldx,info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_${ri}$gtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv,b, ldb, x, ldx, & + call stdlib${ii}$_${ri}$gtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv,b, ldb, x, ldx, & ferr, berr, work, iwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond1 ) 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 ) @@ -21512,7 +21506,7 @@ module stdlib_linalg_lapack_${ri}$ 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. @@ -21524,10 +21518,10 @@ module stdlib_linalg_lapack_${ri}$ end do 50 continue return - end subroutine stdlib_${ri}$gttrf + end subroutine stdlib${ii}$_${ri}$gttrf - pure subroutine stdlib_${ri}$gttrs( trans, n, nrhs, dl, d, du, du2, ipiv, b, ldb,info ) + pure subroutine stdlib${ii}$_${ri}$gttrs( trans, n, nrhs, dl, d, du, du2, ipiv, b, ldb,info ) !! DGTTRS: 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 @@ -21537,61 +21531,61 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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) :: ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) real(${rk}$), intent(inout) :: b(ldb,*) real(${rk}$), intent(in) :: d(*), dl(*), du(*), du2(*) ! ===================================================================== ! Local Scalars logical(lk) :: notran - integer(ilp) :: itrans, j, jb, nb + integer(${ik}$) :: itrans, j, jb, nb ! Intrinsic Functions intrinsic :: max,min ! Executable Statements - info = 0 + info = 0_${ik}$ notran = ( trans=='N' .or. trans=='N' ) if( .not.notran .and. .not.( trans=='T' .or. trans=='T' ) .and. .not.( trans=='C' .or. & trans=='C' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( ldb=nrhs ) then - call stdlib_${ri}$gtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) + call stdlib${ii}$_${ri}$gtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) else do j = 1, nrhs, nb jb = min( nrhs-j+1, nb ) - call stdlib_${ri}$gtts2( itrans, n, jb, dl, d, du, du2, ipiv, b( 1, j ),ldb ) + call stdlib${ii}$_${ri}$gtts2( itrans, n, jb, dl, d, du, du2, ipiv, b( 1_${ik}$, j ),ldb ) end do end if - end subroutine stdlib_${ri}$gttrs + end subroutine stdlib${ii}$_${ri}$gttrs - pure subroutine stdlib_${ri}$gtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) + pure subroutine stdlib${ii}$_${ri}$gtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) !! DGTTS2: solves one of the systems of equations !! A*X = B or A**T*X = B, !! with a tridiagonal matrix A using the LU factorization computed @@ -21600,23 +21594,23 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(inout) :: b(ldb,*) real(${rk}$), intent(in) :: d(*), dl(*), du(*), du2(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ip, j + integer(${ik}$) :: i, ip, j real(${rk}$) :: 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 @@ -21627,13 +21621,13 @@ module stdlib_linalg_lapack_${ri}$ 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 ) @@ -21659,12 +21653,12 @@ module stdlib_linalg_lapack_${ri}$ 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 & ) @@ -21677,14 +21671,14 @@ module stdlib_linalg_lapack_${ri}$ 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 ) @@ -21701,10 +21695,10 @@ module stdlib_linalg_lapack_${ri}$ end do end if end if - end subroutine stdlib_${ri}$gtts2 + end subroutine stdlib${ii}$_${ri}$gtts2 - subroutine stdlib_${ri}$hgeqz( job, compq, compz, n, ilo, ihi, h, ldh, t, ldt,alphar, alphai, & + subroutine stdlib${ii}$_${ri}$hgeqz( job, compq, compz, n, ilo, ihi, h, ldh, t, ldt,alphar, alphai, & !! DHGEQZ: computes the eigenvalues of a real matrix pair (H,T), !! where H is an upper Hessenberg matrix and T is upper triangular, !! using the double-shift QZ method. @@ -21754,8 +21748,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: compq, compz, job - integer(ilp), intent(in) :: ihi, ilo, ldh, ldq, ldt, ldz, lwork, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ilo, ldh, ldq, ldt, ldz, lwork, n + integer(${ik}$), intent(out) :: info ! Array Arguments real(${rk}$), intent(out) :: alphai(*), alphar(*), beta(*), work(*) real(${rk}$), intent(inout) :: h(ldh,*), q(ldq,*), t(ldt,*), z(ldz,*) @@ -21765,8 +21759,8 @@ module stdlib_linalg_lapack_${ri}$ ! $ safety = one ) ! Local Scalars - logical(lk) :: ilazr2, ilazro, ilpivt, ilq, ilschr, ilz, lquery - integer(ilp) :: icompq, icompz, ifirst, ifrstm, iiter, ilast, ilastm, in, ischur, & + logical(lk) :: ilazr2, ilazro, ${ik}$ivt, ilq, ilschr, ilz, lquery + integer(${ik}$) :: icompq, icompz, ifirst, ifrstm, iiter, ilast, ilastm, in, ischur, & istart, j, jc, jch, jiter, jr, maxit real(${rk}$) :: a11, a12, a1i, a1r, a21, a22, a2i, a2r, ad11, ad11l, ad12, ad12l, ad21, & ad21l, ad22, ad22l, ad32l, an, anorm, ascale, atol, b11, b1a, b1i, b1r, b22, b2a, b2i, & @@ -21775,92 +21769,92 @@ module stdlib_linalg_lapack_${ri}$ temp, temp2, tempi, tempr, u1, u12, u12l, u2, ulp, vs, w11, w12, w21, w22, wabs, wi, & wr, wr2 ! Local Arrays - real(${rk}$) :: v(3) + real(${rk}$) :: v(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,max,min,sqrt ! Executable Statements ! decode job, compq, compz if( stdlib_lsame( job, 'E' ) ) then ilschr = .false. - ischur = 1 + ischur = 1_${ik}$ else if( stdlib_lsame( job, 'S' ) ) then ilschr = .true. - ischur = 2 + ischur = 2_${ik}$ else - ischur = 0 + ischur = 0_${ik}$ end if if( stdlib_lsame( compq, 'N' ) ) then ilq = .false. - icompq = 1 + icompq = 1_${ik}$ else if( stdlib_lsame( compq, 'V' ) ) then ilq = .true. - icompq = 2 + icompq = 2_${ik}$ else if( stdlib_lsame( compq, 'I' ) ) then ilq = .true. - icompq = 3 + icompq = 3_${ik}$ else - icompq = 0 + icompq = 0_${ik}$ end if if( stdlib_lsame( compz, 'N' ) ) then ilz = .false. - icompz = 1 + icompz = 1_${ik}$ else if( stdlib_lsame( compz, 'V' ) ) then ilz = .true. - icompz = 2 + icompz = 2_${ik}$ else if( stdlib_lsame( compz, 'I' ) ) then ilz = .true. - icompz = 3 + icompz = 3_${ik}$ else - icompz = 0 + icompz = 0_${ik}$ end if ! check argument values - info = 0 - work( 1 ) = max( 1, n ) - lquery = ( lwork==-1 ) - if( ischur==0 ) then - info = -1 - else if( icompq==0 ) then - info = -2 - else if( icompz==0 ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( ilo<1 ) then - info = -5 + info = 0_${ik}$ + work( 1_${ik}$ ) = max( 1_${ik}$, n ) + lquery = ( lwork==-1_${ik}$ ) + if( ischur==0_${ik}$ ) then + info = -1_${ik}$ + else if( icompq==0_${ik}$ ) then + info = -2_${ik}$ + else if( icompz==0_${ik}$ ) then + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( ilo<1_${ik}$ ) then + info = -5_${ik}$ else if( ihi>n .or. ihi ilo )temp = temp + abs ( t( j - 1, j ) ) + temp = abs ( t( j, j + 1_${ik}$ ) ) + if ( j > ilo )temp = temp + abs ( t( j - 1_${ik}$, j ) ) if( abs( t( j, j ) )=ilast ) then go to 80 else - ifirst = jch + 1 + ifirst = jch + 1_${ik}$ go to 110 end if end if @@ -21997,24 +21991,24 @@ module stdlib_linalg_lapack_${ri}$ ! then process as in the case t(ilast,ilast)=0 do jch = j, ilast - 1 temp = t( jch, jch+1 ) - call stdlib_${ri}$lartg( temp, t( jch+1, jch+1 ), c, s,t( jch, jch+1 ) ) + call stdlib${ii}$_${ri}$lartg( temp, t( jch+1, jch+1 ), c, s,t( jch, jch+1 ) ) t( jch+1, jch+1 ) = zero - if( jch abs( (wr2/s2)*t( & ilast, ilast )- h( ilast, ilast ) ) ) then @@ -22143,12 +22137,12 @@ module stdlib_linalg_lapack_${ri}$ ! initial q temp = s1*h( istart, istart ) - wr*t( istart, istart ) temp2 = s1*h( istart+1, istart ) - call stdlib_${ri}$lartg( temp, temp2, c, s, tempr ) + call stdlib${ii}$_${ri}$lartg( temp, temp2, c, s, tempr ) ! sweep loop_190: do j = istart, ilast - 1 if( j>istart ) then temp = h( j, j-1 ) - call stdlib_${ri}$lartg( temp, h( j+1, j-1 ), c, s, h( j, j-1 ) ) + call stdlib${ii}$_${ri}$lartg( temp, h( j+1, j-1 ), c, s, h( j, j-1 ) ) h( j+1, j-1 ) = zero end if do jc = j, ilastm @@ -22167,7 +22161,7 @@ module stdlib_linalg_lapack_${ri}$ end do end if temp = t( j+1, j+1 ) - call stdlib_${ri}$lartg( temp, t( j+1, j ), c, s, t( j+1, j+1 ) ) + call stdlib${ii}$_${ri}$lartg( temp, t( j+1, j ), c, s, t( j+1, j+1 ) ) t( j+1, j ) = zero do jr = ifrstm, min( j+2, ilast ) temp = c*h( jr, j+1 ) + s*h( jr, j ) @@ -22200,7 +22194,7 @@ module stdlib_linalg_lapack_${ri}$ ! ( b11 0 ) ! b = ( ) with b11 non-negative. ! ( 0 b22 ) - call stdlib_${ri}$lasv2( t( ilast-1, ilast-1 ), t( ilast-1, ilast ),t( ilast, ilast ),& + call stdlib${ii}$_${ri}$lasv2( t( ilast-1, ilast-1 ), t( ilast-1, ilast ),t( ilast, ilast ),& b22, b11, sr, cr, sl, cl ) if( b11abs( c21 )+abs( c22r )+abs( c22i ) ) & then - t1 = stdlib_${ri}$lapy3( c12, c11r, c11i ) + t1 = stdlib${ii}$_${ri}$lapy3( c12, c11r, c11i ) cz = c12 / t1 szr = -c11r / t1 szi = -c11i / t1 else - cz = stdlib_${ri}$lapy2( c22r, c22i ) + cz = stdlib${ii}$_${ri}$lapy2( c22r, c22i ) if( cz<=safmin ) then cz = zero szr = one @@ -22276,7 +22270,7 @@ module stdlib_linalg_lapack_${ri}$ else tempr = c22r / cz tempi = c22i / cz - t1 = stdlib_${ri}$lapy2( cz, c21 ) + t1 = stdlib${ii}$_${ri}$lapy2( cz, c21 ) cz = cz / t1 szr = -c21*tempr / t1 szi = c21*tempi / t1 @@ -22298,7 +22292,7 @@ module stdlib_linalg_lapack_${ri}$ a1i = szi*a12 a2r = cz*a21 + szr*a22 a2i = szi*a22 - cq = stdlib_${ri}$lapy2( a1r, a1i ) + cq = stdlib${ii}$_${ri}$lapy2( a1r, a1i ) if( cq<=safmin ) then cq = zero sqr = one @@ -22310,7 +22304,7 @@ module stdlib_linalg_lapack_${ri}$ sqi = tempi*a2r - tempr*a2i end if end if - t1 = stdlib_${ri}$lapy3( cq, sqr, sqi ) + t1 = stdlib${ii}$_${ri}$lapy3( cq, sqr, sqi ) cq = cq / t1 sqr = sqr / t1 sqi = sqi / t1 @@ -22319,10 +22313,10 @@ module stdlib_linalg_lapack_${ri}$ tempi = sqr*szi + sqi*szr b1r = cq*cz*b11 + tempr*b22 b1i = tempi*b22 - b1a = stdlib_${ri}$lapy2( b1r, b1i ) + b1a = stdlib${ii}$_${ri}$lapy2( b1r, b1i ) b2r = cq*cz*b22 + tempr*b11 b2i = -tempi*b11 - b2a = stdlib_${ri}$lapy2( b2r, b2i ) + b2a = stdlib${ii}$_${ri}$lapy2( b2r, b2i ) ! normalize so beta > 0, and im( alpha1 ) > 0 beta( ilast-1 ) = b1a beta( ilast ) = b2a @@ -22331,10 +22325,10 @@ module stdlib_linalg_lapack_${ri}$ alphar( ilast ) = ( wr*b2a )*s1inv alphai( ilast ) = -( wi*b2a )*s1inv ! step 3: go to next block -- exit if finished. - ilast = ifirst - 1 + ilast = ifirst - 1_${ik}$ if( ilastistart ) then - v( 1 ) = h( j, j-1 ) - v( 2 ) = h( j+1, j-1 ) - v( 3 ) = h( j+2, j-1 ) - call stdlib_${ri}$larfg( 3, h( j, j-1 ), v( 2 ), 1, tau ) - v( 1 ) = one + v( 1_${ik}$ ) = h( j, j-1 ) + v( 2_${ik}$ ) = h( j+1, j-1 ) + v( 3_${ik}$ ) = h( j+2, j-1 ) + call stdlib${ii}$_${ri}$larfg( 3_${ik}$, h( j, j-1 ), v( 2_${ik}$ ), 1_${ik}$, tau ) + v( 1_${ik}$ ) = one h( j+1, j-1 ) = zero h( j+2, j-1 ) = zero end if do jc = j, ilastm - temp = tau*( h( j, jc )+v( 2 )*h( j+1, jc )+v( 3 )*h( j+2, jc ) ) + temp = tau*( h( j, jc )+v( 2_${ik}$ )*h( j+1, jc )+v( 3_${ik}$ )*h( j+2, jc ) ) h( j, jc ) = h( j, jc ) - temp - h( j+1, jc ) = h( j+1, jc ) - temp*v( 2 ) - h( j+2, jc ) = h( j+2, jc ) - temp*v( 3 ) - temp2 = tau*( t( j, jc )+v( 2 )*t( j+1, jc )+v( 3 )*t( j+2, jc ) ) + h( j+1, jc ) = h( j+1, jc ) - temp*v( 2_${ik}$ ) + h( j+2, jc ) = h( j+2, jc ) - temp*v( 3_${ik}$ ) + temp2 = tau*( t( j, jc )+v( 2_${ik}$ )*t( j+1, jc )+v( 3_${ik}$ )*t( j+2, jc ) ) t( j, jc ) = t( j, jc ) - temp2 - t( j+1, jc ) = t( j+1, jc ) - temp2*v( 2 ) - t( j+2, jc ) = t( j+2, jc ) - temp2*v( 3 ) + t( j+1, jc ) = t( j+1, jc ) - temp2*v( 2_${ik}$ ) + t( j+2, jc ) = t( j+2, jc ) - temp2*v( 3_${ik}$ ) end do if( ilq ) then do jr = 1, n - temp = tau*( q( jr, j )+v( 2 )*q( jr, j+1 )+v( 3 )*q( jr, j+2 ) ) + temp = tau*( q( jr, j )+v( 2_${ik}$ )*q( jr, j+1 )+v( 3_${ik}$ )*q( jr, j+2 ) ) q( jr, j ) = q( jr, j ) - temp - q( jr, j+1 ) = q( jr, j+1 ) - temp*v( 2 ) - q( jr, j+2 ) = q( jr, j+2 ) - temp*v( 3 ) + q( jr, j+1 ) = q( jr, j+1 ) - temp*v( 2_${ik}$ ) + q( jr, j+2 ) = q( jr, j+2 ) - temp*v( 3_${ik}$ ) end do end if ! zero j-th column of b (see dlagbc for details) ! swap rows to pivot - ilpivt = .false. + ${ik}$ivt = .false. temp = max( abs( t( j+1, j+1 ) ), abs( t( j+1, j+2 ) ) ) temp2 = max( abs( t( j+2, j+1 ) ), abs( t( j+2, j+2 ) ) ) if( max( temp, temp2 )abs( w11 ) ) then - ilpivt = .true. + ${ik}$ivt = .true. temp = w12 temp2 = w22 w12 = w11 @@ -22458,38 +22452,38 @@ module stdlib_linalg_lapack_${ri}$ u2 = ( scale*u2 ) / w22 u1 = ( scale*u1-w12*u2 ) / w11 250 continue - if( ilpivt ) then + if( ${ik}$ivt ) then temp = u2 u2 = u1 u1 = temp end if ! compute householder vector - t1 = sqrt( scale**2+u1**2+u2**2 ) + t1 = sqrt( scale**2_${ik}$+u1**2_${ik}$+u2**2_${ik}$ ) tau = one + scale / t1 vs = -one / ( scale+t1 ) - v( 1 ) = one - v( 2 ) = vs*u1 - v( 3 ) = vs*u2 + v( 1_${ik}$ ) = one + v( 2_${ik}$ ) = vs*u1 + v( 3_${ik}$ ) = vs*u2 ! apply transformations from the right. do jr = ifrstm, min( j+3, ilast ) - temp = tau*( h( jr, j )+v( 2 )*h( jr, j+1 )+v( 3 )*h( jr, j+2 ) ) + temp = tau*( h( jr, j )+v( 2_${ik}$ )*h( jr, j+1 )+v( 3_${ik}$ )*h( jr, j+2 ) ) h( jr, j ) = h( jr, j ) - temp - h( jr, j+1 ) = h( jr, j+1 ) - temp*v( 2 ) - h( jr, j+2 ) = h( jr, j+2 ) - temp*v( 3 ) + h( jr, j+1 ) = h( jr, j+1 ) - temp*v( 2_${ik}$ ) + h( jr, j+2 ) = h( jr, j+2 ) - temp*v( 3_${ik}$ ) end do do jr = ifrstm, j + 2 - temp = tau*( t( jr, j )+v( 2 )*t( jr, j+1 )+v( 3 )*t( jr, j+2 ) ) + temp = tau*( t( jr, j )+v( 2_${ik}$ )*t( jr, j+1 )+v( 3_${ik}$ )*t( jr, j+2 ) ) t( jr, j ) = t( jr, j ) - temp - t( jr, j+1 ) = t( jr, j+1 ) - temp*v( 2 ) - t( jr, j+2 ) = t( jr, j+2 ) - temp*v( 3 ) + t( jr, j+1 ) = t( jr, j+1 ) - temp*v( 2_${ik}$ ) + t( jr, j+2 ) = t( jr, j+2 ) - temp*v( 3_${ik}$ ) end do if( ilz ) then do jr = 1, n - temp = tau*( z( jr, j )+v( 2 )*z( jr, j+1 )+v( 3 )*z( jr, j+2 ) ) + temp = tau*( z( jr, j )+v( 2_${ik}$ )*z( jr, j+1 )+v( 3_${ik}$ )*z( jr, j+2 ) ) z( jr, j ) = z( jr, j ) - temp - z( jr, j+1 ) = z( jr, j+1 ) - temp*v( 2 ) - z( jr, j+2 ) = z( jr, j+2 ) - temp*v( 3 ) + z( jr, j+1 ) = z( jr, j+1 ) - temp*v( 2_${ik}$ ) + z( jr, j+2 ) = z( jr, j+2 ) - temp*v( 3_${ik}$ ) end do end if t( j+1, j ) = zero @@ -22497,9 +22491,9 @@ module stdlib_linalg_lapack_${ri}$ end do loop_290 ! last elements: use givens rotations ! rotations from the left - j = ilast - 1 + j = ilast - 1_${ik}$ temp = h( j, j-1 ) - call stdlib_${ri}$lartg( temp, h( j+1, j-1 ), c, s, h( j, j-1 ) ) + call stdlib${ii}$_${ri}$lartg( temp, h( j+1, j-1 ), c, s, h( j, j-1 ) ) h( j+1, j-1 ) = zero do jc = j, ilastm temp = c*h( j, jc ) + s*h( j+1, jc ) @@ -22518,7 +22512,7 @@ module stdlib_linalg_lapack_${ri}$ end if ! rotations from the right. temp = t( j+1, j+1 ) - call stdlib_${ri}$lartg( temp, t( j+1, j ), c, s, t( j+1, j+1 ) ) + call stdlib${ii}$_${ri}$lartg( temp, t( j+1, j ), c, s, t( j+1, j+1 ) ) t( j+1, j ) = zero do jr = ifrstm, ilast temp = c*h( jr, j+1 ) + s*h( jr, j ) @@ -22571,15 +22565,15 @@ module stdlib_linalg_lapack_${ri}$ beta( j ) = t( j, j ) end do ! normal termination - info = 0 + info = 0_${ik}$ ! exit (other than argument error) -- return optimal workspace size 420 continue - work( 1 ) = real( n,KIND=${rk}$) + work( 1_${ik}$ ) = real( n,KIND=${rk}$) return - end subroutine stdlib_${ri}$hgeqz + end subroutine stdlib${ii}$_${ri}$hgeqz - subroutine stdlib_${ri}$hsein( side, eigsrc, initv, select, n, h, ldh, wr, wi,vl, ldvl, vr, ldvr, & + subroutine stdlib${ii}$_${ri}$hsein( side, eigsrc, initv, select, n, h, ldh, wr, wi,vl, ldvl, vr, ldvr, & !! DHSEIN: uses inverse iteration to find specified right and/or left !! eigenvectors of a real upper Hessenberg matrix H. !! The right eigenvector x and the left eigenvector y of the matrix H @@ -22592,11 +22586,11 @@ module stdlib_linalg_lapack_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: eigsrc, initv, side - integer(ilp), intent(out) :: info, m - integer(ilp), intent(in) :: ldh, ldvl, ldvr, mm, n + integer(${ik}$), intent(out) :: info, m + integer(${ik}$), intent(in) :: ldh, ldvl, ldvr, mm, n ! Array Arguments logical(lk), intent(inout) :: select(*) - integer(ilp), intent(out) :: ifaill(*), ifailr(*) + integer(${ik}$), intent(out) :: ifaill(*), ifailr(*) real(${rk}$), intent(in) :: h(ldh,*), wi(*) real(${rk}$), intent(inout) :: vl(ldvl,*), vr(ldvr,*), wr(*) real(${rk}$), intent(out) :: work(*) @@ -22604,7 +22598,7 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: bothv, fromqr, leftv, noinit, pair, rightv - integer(ilp) :: i, iinfo, k, kl, kln, kr, ksi, ksr, ldwork + integer(${ik}$) :: i, iinfo, k, kl, kln, kr, ksi, ksr, ldwork real(${rk}$) :: bignum, eps3, hnorm, smlnum, ulp, unfl, wki, wkr ! Intrinsic Functions intrinsic :: abs,max @@ -22617,7 +22611,7 @@ module stdlib_linalg_lapack_${ri}$ noinit = stdlib_lsame( initv, 'N' ) ! set m to the number of columns required to store the selected ! eigenvectors, and standardize the array select. - m = 0 + m = 0_${ik}$ pair = .false. do k = 1, n if( pair ) then @@ -22625,54 +22619,54 @@ module stdlib_linalg_lapack_${ri}$ select( k ) = .false. else if( wi( k )==zero ) then - if( select( k ) )m = m + 1 + if( select( k ) )m = m + 1_${ik}$ else pair = .true. if( select( k ) .or. select( k+1 ) ) then select( k ) = .true. - m = m + 2 + m = m + 2_${ik}$ end if end if end if end do - info = 0 + info = 0_${ik}$ if( .not.rightv .and. .not.leftv ) then - info = -1 + info = -1_${ik}$ else if( .not.fromqr .and. .not.stdlib_lsame( eigsrc, 'N' ) ) then - info = -2 + info = -2_${ik}$ else if( .not.noinit .and. .not.stdlib_lsame( initv, 'U' ) ) then - info = -3 - else if( n<0 ) then - info = -5 - else if( ldhzero ) then eps3 = hnorm*ulp @@ -22728,26 +22722,26 @@ module stdlib_linalg_lapack_${ri}$ wr( k ) = wkr pair = wki/=zero if( pair ) then - ksi = ksr + 1 + ksi = ksr + 1_${ik}$ else ksi = ksr end if if( leftv ) then ! compute left eigenvector. - call stdlib_${ri}$laein( .false., noinit, n-kl+1, h( kl, kl ), ldh,wkr, wki, vl( & + call stdlib${ii}$_${ri}$laein( .false., noinit, n-kl+1, h( kl, kl ), ldh,wkr, wki, vl( & kl, ksr ), vl( kl, ksi ),work, ldwork, work( n*n+n+1 ), eps3, smlnum,bignum, & iinfo ) - if( iinfo>0 ) then + if( iinfo>0_${ik}$ ) then if( pair ) then - info = info + 2 + info = info + 2_${ik}$ else - info = info + 1 + info = info + 1_${ik}$ end if ifaill( ksr ) = k ifaill( ksi ) = k else - ifaill( ksr ) = 0 - ifaill( ksi ) = 0 + ifaill( ksr ) = 0_${ik}$ + ifaill( ksi ) = 0_${ik}$ end if do i = 1, kl - 1 vl( i, ksr ) = zero @@ -22760,19 +22754,19 @@ module stdlib_linalg_lapack_${ri}$ end if if( rightv ) then ! compute right eigenvector. - call stdlib_${ri}$laein( .true., noinit, kr, h, ldh, wkr, wki,vr( 1, ksr ), vr( 1, & + call stdlib${ii}$_${ri}$laein( .true., noinit, kr, h, ldh, wkr, wki,vr( 1_${ik}$, ksr ), vr( 1_${ik}$, & ksi ), work, ldwork,work( n*n+n+1 ), eps3, smlnum, bignum,iinfo ) - if( iinfo>0 ) then + if( iinfo>0_${ik}$ ) then if( pair ) then - info = info + 2 + info = info + 2_${ik}$ else - info = info + 1 + info = info + 1_${ik}$ end if ifailr( ksr ) = k ifailr( ksi ) = k else - ifailr( ksr ) = 0 - ifailr( ksi ) = 0 + ifailr( ksr ) = 0_${ik}$ + ifailr( ksi ) = 0_${ik}$ end if do i = kr + 1, n vr( i, ksr ) = zero @@ -22784,17 +22778,17 @@ module stdlib_linalg_lapack_${ri}$ end if end if if( pair ) then - ksr = ksr + 2 + ksr = ksr + 2_${ik}$ else - ksr = ksr + 1 + ksr = ksr + 1_${ik}$ end if end if end do loop_120 return - end subroutine stdlib_${ri}$hsein + end subroutine stdlib${ii}$_${ri}$hsein - subroutine stdlib_${ri}$hseqr( job, compz, n, ilo, ihi, h, ldh, wr, wi, z,ldz, work, lwork, info ) + subroutine stdlib${ii}$_${ri}$hseqr( job, compz, n, ilo, ihi, h, ldh, wr, wi, z,ldz, work, lwork, info ) !! DHSEQR: computes the eigenvalues of a Hessenberg matrix H !! and, optionally, the matrices T and Z from the Schur decomposition !! H = Z T Z**T, where T is an upper quasi-triangular matrix (the @@ -22808,23 +22802,23 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, ldh, ldz, lwork, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ilo, ldh, ldz, lwork, n + integer(${ik}$), intent(out) :: info character, intent(in) :: compz, job ! Array Arguments real(${rk}$), intent(inout) :: h(ldh,*), z(ldz,*) real(${rk}$), intent(out) :: wi(*), work(*), wr(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: ntiny = 15 - integer(ilp), parameter :: nl = 49 + integer(${ik}$), parameter :: ntiny = 15_${ik}$ + integer(${ik}$), parameter :: nl = 49_${ik}$ ! ==== matrices of order ntiny or smaller must be processed by - ! . stdlib_${ri}$lahqr because of insufficient subdiagonal scratch space. + ! . stdlib${ii}$_${ri}$lahqr because of insufficient subdiagonal scratch space. ! . (this is a hard limit.) ==== ! ==== nl allocates some local workspace to help small matrices - ! . through a rare stdlib_${ri}$lahqr failure. nl > ntiny = 15 is - ! . required and nl <= nmin = stdlib_ilaenv(ispec=12,...) is recom- + ! . through a rare stdlib${ii}$_${ri}$lahqr failure. nl > ntiny = 15 is + ! . required and nl <= nmin = stdlib${ii}$_ilaenv(ispec=12,...) is recom- ! . mended. (the default value of nmin is 75.) using nl = 49 ! . allows up to six simultaneous shifts and a 16-by-16 ! . deflation window. ==== @@ -22833,7 +22827,7 @@ module stdlib_linalg_lapack_${ri}$ ! Local Arrays real(${rk}$) :: hl(nl,nl), workl(nl) ! Local Scalars - integer(ilp) :: i, kbot, nmin + integer(${ik}$) :: i, kbot, nmin logical(lk) :: initz, lquery, wantt, wantz ! Intrinsic Functions intrinsic :: real,max,min @@ -22842,43 +22836,43 @@ module stdlib_linalg_lapack_${ri}$ wantt = stdlib_lsame( job, 'S' ) initz = stdlib_lsame( compz, 'I' ) wantz = initz .or. stdlib_lsame( compz, 'V' ) - work( 1 ) = real( max( 1, n ),KIND=${rk}$) - lquery = lwork==-1 - info = 0 + work( 1_${ik}$ ) = real( max( 1_${ik}$, n ),KIND=${rk}$) + lquery = lwork==-1_${ik}$ + info = 0_${ik}$ if( .not.stdlib_lsame( job, 'E' ) .and. .not.wantt ) then - info = -1 + info = -1_${ik}$ else if( .not.stdlib_lsame( compz, 'N' ) .and. .not.wantz ) 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( ldhnmin ) then - call stdlib_${ri}$laqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, & + call stdlib${ii}$_${ri}$laqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, & work, lwork, info ) else ! ==== small matrix ==== - call stdlib_${ri}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, & + call stdlib${ii}$_${ri}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, & info ) - if( info>0 ) then - ! ==== a rare stdlib_${ri}$lahqr failure! stdlib_${ri}$laqr0 sometimes succeeds - ! . when stdlib_${ri}$lahqr fails. ==== + if( info>0_${ik}$ ) then + ! ==== a rare stdlib${ii}$_${ri}$lahqr failure! stdlib${ii}$_${ri}$laqr0 sometimes succeeds + ! . when stdlib${ii}$_${ri}$lahqr fails. ==== kbot = info if( n>=nl ) then ! ==== larger matrices have enough subdiagonal scratch - ! . space to call stdlib_${ri}$laqr0 directly. ==== - call stdlib_${ri}$laqr0( wantt, wantz, n, ilo, kbot, h, ldh, wr,wi, ilo, ihi, z,& + ! . space to call stdlib${ii}$_${ri}$laqr0 directly. ==== + call stdlib${ii}$_${ri}$laqr0( wantt, wantz, n, ilo, kbot, h, ldh, wr,wi, ilo, ihi, z,& ldz, work, lwork, info ) else ! ==== tiny matrices don't have enough subdiagonal - ! . scratch space to benefit from stdlib_${ri}$laqr0. hence, + ! . scratch space to benefit from stdlib${ii}$_${ri}$laqr0. hence, ! . tiny matrices must be copied into a larger - ! . array before calling stdlib_${ri}$laqr0. ==== - call stdlib_${ri}$lacpy( 'A', n, n, h, ldh, hl, nl ) + ! . array before calling stdlib${ii}$_${ri}$laqr0. ==== + call stdlib${ii}$_${ri}$lacpy( 'A', n, n, h, ldh, hl, nl ) hl( n+1, n ) = zero - call stdlib_${ri}$laset( 'A', nl, nl-n, zero, zero, hl( 1, n+1 ),nl ) - call stdlib_${ri}$laqr0( wantt, wantz, nl, ilo, kbot, hl, nl, wr,wi, ilo, ihi, & + call stdlib${ii}$_${ri}$laset( 'A', nl, nl-n, zero, zero, hl( 1_${ik}$, n+1 ),nl ) + call stdlib${ii}$_${ri}$laqr0( wantt, wantz, nl, ilo, kbot, hl, nl, wr,wi, ilo, ihi, & z, ldz, workl, nl, info ) - if( wantt .or. info/=0 )call stdlib_${ri}$lacpy( 'A', n, n, hl, nl, h, ldh ) + if( wantt .or. info/=0_${ik}$ )call stdlib${ii}$_${ri}$lacpy( 'A', n, n, hl, nl, h, ldh ) end if end if end if ! ==== clear out the trash, if necessary. ==== - if( ( wantt .or. info/=0 ) .and. n>2 )call stdlib_${ri}$laset( 'L', n-2, n-2, zero, zero,& - h( 3, 1 ), ldh ) + if( ( wantt .or. info/=0_${ik}$ ) .and. n>2_${ik}$ )call stdlib${ii}$_${ri}$laset( 'L', n-2, n-2, zero, zero,& + h( 3_${ik}$, 1_${ik}$ ), ldh ) ! ==== ensure reported workspace size is backward-compatible with ! . previous lapack versions. ==== - work( 1 ) = max( real( max( 1, n ),KIND=${rk}$), work( 1 ) ) + work( 1_${ik}$ ) = max( real( max( 1_${ik}$, n ),KIND=${rk}$), work( 1_${ik}$ ) ) end if - end subroutine stdlib_${ri}$hseqr + end subroutine stdlib${ii}$_${ri}$hseqr - pure logical(lk) function stdlib_${ri}$isnan( din ) + pure logical(lk) function stdlib${ii}$_${ri}$isnan( din ) !! DISNAN: returns .TRUE. if its argument is NaN, and .FALSE. !! otherwise. To be replaced by the Fortran 2003 intrinsic in the !! future. @@ -22952,12 +22946,12 @@ module stdlib_linalg_lapack_${ri}$ real(${rk}$), intent(in) :: din ! ===================================================================== ! Executable Statements - stdlib_${ri}$isnan = stdlib_${ri}$laisnan(din,din) + stdlib${ii}$_${ri}$isnan = stdlib${ii}$_${ri}$laisnan(din,din) return - end function stdlib_${ri}$isnan + end function stdlib${ii}$_${ri}$isnan - subroutine stdlib_${ri}$la_gbamv( trans, m, n, kl, ku, alpha, ab, ldab, x,incx, beta, y, incy ) + subroutine stdlib${ii}$_${ri}$la_gbamv( trans, m, n, kl, ku, alpha, ab, ldab, x,incx, beta, y, incy ) !! DLA_GBAMV: performs one of the matrix-vector operations !! y := alpha*abs(A)*abs(x) + beta*abs(y), !! or y := alpha*abs(A)**T*abs(x) + beta*abs(y), @@ -22977,7 +22971,7 @@ module stdlib_linalg_lapack_${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, ldab, m, n, kl, ku, trans + integer(${ik}$), intent(in) :: incx, incy, ldab, m, n, kl, ku, trans ! Array Arguments real(${rk}$), intent(in) :: ab(ldab,*), x(*) real(${rk}$), intent(inout) :: y(*) @@ -22986,68 +22980,68 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: symb_wero real(${rk}$) :: 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_${ri}$lamch( 'SAFE MINIMUM' ) + safe1 = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) safe1 = (n+1)*safe1 ! form y := alpha*abs(a)*abs(x) + beta*abs(y). ! the o(m*n) symb_wero tests could be replaced by o(n) queries to ! 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_wero = .true. @@ -23091,7 +23085,7 @@ module stdlib_linalg_lapack_${ri}$ 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_wero = .true. @@ -23140,10 +23134,10 @@ module stdlib_linalg_lapack_${ri}$ end if end if return - end subroutine stdlib_${ri}$la_gbamv + end subroutine stdlib${ii}$_${ri}$la_gbamv - real(${rk}$) function stdlib_${ri}$la_gbrcond( trans, n, kl, ku, ab, ldab,afb, ldafb, ipiv, cmode, c,& + real(${rk}$) function stdlib${ii}$_${ri}$la_gbrcond( trans, n, kl, ku, ab, ldab,afb, ldafb, ipiv, cmode, c,& !! DLA_GBRCOND: Estimates the Skeel condition number of op(A) * op2(C) !! where op2 is determined by CMODE as follows !! CMODE = 1 op2(C) = C @@ -23159,60 +23153,60 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: ab(ldab,*), afb(ldafb,*), c(*) real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: notrans - integer(ilp) :: kase, i, j, kd, ke + integer(${ik}$) :: kase, i, j, kd, ke real(${rk}$) :: ainvnm, tmp ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements - stdlib_${ri}$la_gbrcond = zero - info = 0 + stdlib${ii}$_${ri}$la_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_${ri}$lamch( 'SAFE MINIMUM' ) + safe1 = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) safe1 = (n+1)*safe1 ! form y := alpha*abs(a)*abs(x) + beta*abs(y). ! the o(m*n) symb_wero tests could be replaced by o(n) queries to ! 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_wero = .true. @@ -23468,7 +23462,7 @@ module stdlib_linalg_lapack_${ri}$ 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_wero = .true. @@ -23517,10 +23511,10 @@ module stdlib_linalg_lapack_${ri}$ end if end if return - end subroutine stdlib_${ri}$la_geamv + end subroutine stdlib${ii}$_${ri}$la_geamv - real(${rk}$) function stdlib_${ri}$la_gercond( trans, n, a, lda, af,ldaf, ipiv, cmode, c,info, work, & + real(${rk}$) function stdlib${ii}$_${ri}$la_gercond( trans, n, a, lda, af,ldaf, ipiv, cmode, c,info, work, & !! DLA_GERCOND: estimates the Skeel condition number of op(A) * op2(C) !! where op2 is determined by CMODE as follows !! CMODE = 1 op2(C) = C @@ -23536,42 +23530,42 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: a(lda,*), af(ldaf,*), c(*) real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: notrans - integer(ilp) :: kase, i, j + integer(${ik}$) :: kase, i, j real(${rk}$) :: ainvnm, tmp ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements - stdlib_${ri}$la_gercond = zero - info = 0 + stdlib${ii}$_${ri}$la_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_${ri}$lamch( 'SAFE MINIMUM' ) + safe1 = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) safe1 = (n+1)*safe1 ! form y := alpha*abs(a)*abs(x) + beta*abs(y). ! the o(n^2) symb_wero tests could be replaced by o(n) queries to ! 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_wero = .true. @@ -24122,7 +24116,7 @@ module stdlib_linalg_lapack_${ri}$ 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_wero = .true. @@ -24183,10 +24177,10 @@ module stdlib_linalg_lapack_${ri}$ end if end if return - end subroutine stdlib_${ri}$la_syamv + end subroutine stdlib${ii}$_${ri}$la_syamv - real(${rk}$) function stdlib_${ri}$la_syrcond( uplo, n, a, lda, af, ldaf,ipiv, cmode, c, info, work,& + real(${rk}$) function stdlib${ii}$_${ri}$la_syrcond( uplo, n, a, lda, af, ldaf,ipiv, cmode, c, info, work,& !! DLA_SYRCOND: estimates the Skeel condition number of op(A) * op2(C) !! where op2 is determined by CMODE as follows !! CMODE = 1 op2(C) = C @@ -24202,39 +24196,39 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: a(lda,*), af(ldaf,*), c(*) real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars character :: normin - integer(ilp) :: kase, i, j + integer(${ik}$) :: kase, i, j real(${rk}$) :: 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_${ri}$la_syrcond = zero - info = 0 - if( n<0 ) then - info = -2 - else if( lda0 ) - if ( ipiv( k )>0 ) then + if ( ipiv( k )>0_${ik}$ ) then ! 1x1 pivot kp = ipiv( k ) if ( kp /= k ) then @@ -24429,7 +24423,7 @@ module stdlib_linalg_lapack_${ri}$ 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 kp = -ipiv( k ) @@ -24441,31 +24435,31 @@ module stdlib_linalg_lapack_${ri}$ 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 + if ( ipiv( k )>0_${ik}$ ) then ! 1x1 pivot kp = ipiv( k ) if ( kp /= k ) then @@ -24476,7 +24470,7 @@ module stdlib_linalg_lapack_${ri}$ 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 kp = -ipiv( k ) @@ -24488,25 +24482,25 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -24533,11 +24527,11 @@ module stdlib_linalg_lapack_${ri}$ end if end do end if - stdlib_${ri}$la_syrpvgrw = rpvgrw - end function stdlib_${ri}$la_syrpvgrw + stdlib${ii}$_${ri}$la_syrpvgrw = rpvgrw + end function stdlib${ii}$_${ri}$la_syrpvgrw - pure subroutine stdlib_${ri}$la_wwaddw( n, x, y, w ) + pure subroutine stdlib${ii}$_${ri}$la_wwaddw( n, x, y, w ) !! DLA_WWADDW: adds a vector W into a doubled-single vector (X, Y). !! This works for all extant IBM's hex and binary floating point !! arithmetic, but not for decimal. @@ -24545,14 +24539,14 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(inout) :: x(*), y(*) real(${rk}$), intent(in) :: w(*) ! ===================================================================== ! Local Scalars real(${rk}$) :: s - integer(ilp) :: i + integer(${ik}$) :: i ! Executable Statements do 10 i = 1, n s = x(i) + w(i) @@ -24561,10 +24555,10 @@ module stdlib_linalg_lapack_${ri}$ x(i) = s 10 continue return - end subroutine stdlib_${ri}$la_wwaddw + end subroutine stdlib${ii}$_${ri}$la_wwaddw - pure subroutine stdlib_${ri}$labad( small, large ) + pure subroutine stdlib${ii}$_${ri}$labad( small, large ) !! DLABAD: takes as input the values computed by DLAMCH for underflow and !! overflow, and returns the square root of each of these values if the !! log of LARGE is sufficiently large. This subroutine is intended to @@ -24589,10 +24583,10 @@ module stdlib_linalg_lapack_${ri}$ large = sqrt( large ) end if return - end subroutine stdlib_${ri}$labad + end subroutine stdlib${ii}$_${ri}$labad - pure subroutine stdlib_${ri}$labrd( m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y,ldy ) + pure subroutine stdlib${ii}$_${ri}$labrd( m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y,ldy ) !! DLABRD: reduces the first NB rows and columns of a real general !! m by n matrix A to upper or lower bidiagonal form by an orthogonal !! transformation Q**T * A * P, and returns the matrices X and Y which @@ -24604,14 +24598,14 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, ldx, ldy, m, n, nb + integer(${ik}$), intent(in) :: lda, ldx, ldy, m, n, nb ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: d(*), e(*), taup(*), tauq(*), x(ldx,*), y(ldy,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -24621,190 +24615,190 @@ module stdlib_linalg_lapack_${ri}$ ! reduce to upper bidiagonal form loop_10: do i = 1, nb ! update a(i:m,i) - call stdlib_${ri}$gemv( 'NO TRANSPOSE', m-i+1, i-1, -one, a( i, 1 ),lda, y( i, 1 ), & - ldy, one, a( i, i ), 1 ) - call stdlib_${ri}$gemv( 'NO TRANSPOSE', m-i+1, i-1, -one, x( i, 1 ),ldx, a( 1, i ), 1,& - one, a( i, i ), 1 ) + call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', m-i+1, i-1, -one, a( i, 1_${ik}$ ),lda, y( i, 1_${ik}$ ), & + ldy, one, a( i, i ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', m-i+1, i-1, -one, x( i, 1_${ik}$ ),ldx, a( 1_${ik}$, i ), 1_${ik}$,& + one, a( i, i ), 1_${ik}$ ) ! generate reflection q(i) to annihilate a(i+1:m,i) - call stdlib_${ri}$larfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,tauq( i ) ) + call stdlib${ii}$_${ri}$larfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,tauq( i ) ) d( i ) = a( i, i ) if( 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) ! first iteration. x has been overwritten by transpose(a)*x. 40 continue - isave( 2 ) = stdlib_i${ri}$amax( n, x, 1 ) - isave( 3 ) = 2 + isave( 2_${ik}$ ) = stdlib${ii}$_i${ri}$amax( n, x, 1_${ik}$ ) + isave( 3_${ik}$ ) = 2_${ik}$ ! main loop - iterations 2,3,...,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) ! x has been overwritten by a*x. 70 continue - call stdlib_${ri}$copy( n, x, 1, v, 1 ) + call stdlib${ii}$_${ri}$copy( n, x, 1_${ik}$, v, 1_${ik}$ ) estold = est - est = stdlib_${ri}$asum( n, v, 1 ) + est = stdlib${ii}$_${ri}$asum( 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 @@ -24817,18 +24811,18 @@ module stdlib_linalg_lapack_${ri}$ 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) ! x has been overwritten by transpose(a)*x. 110 continue - jlast = isave( 2 ) - isave( 2 ) = stdlib_i${ri}$amax( n, x, 1 ) - if( ( x( jlast )/=abs( x( isave( 2 ) ) ) ) .and.( isave( 3 )est ) then - call stdlib_${ri}$copy( n, x, 1, v, 1 ) + call stdlib${ii}$_${ri}$copy( n, x, 1_${ik}$, v, 1_${ik}$ ) est = temp end if 150 continue - kase = 0 + kase = 0_${ik}$ return - end subroutine stdlib_${ri}$lacn2 + end subroutine stdlib${ii}$_${ri}$lacn2 - subroutine stdlib_${ri}$lacon( n, v, x, isgn, est, kase ) + subroutine stdlib${ii}$_${ri}$lacon( n, v, x, isgn, est, kase ) !! DLACON: estimates the 1-norm of a square, real matrix A. !! Reverse communication is used for evaluating matrix-vector products. ! -- lapack auxiliary routine -- ! -- 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(${rk}$), intent(inout) :: est ! Array Arguments - integer(ilp), intent(out) :: isgn(*) + integer(${ik}$), intent(out) :: isgn(*) real(${rk}$), intent(out) :: v(*) real(${rk}$), 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(${rk}$) :: altsgn, estold, temp ! Intrinsic Functions intrinsic :: abs,real,nint,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=${rk}$) 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) ! 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_${ri}$asum( n, x, 1 ) + est = stdlib${ii}$_${ri}$asum( 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) ! first iteration. x has been overwritten by transpose(a)*x. 40 continue - j = stdlib_i${ri}$amax( n, x, 1 ) - iter = 2 + j = stdlib${ii}$_i${ri}$amax( n, x, 1_${ik}$ ) + iter = 2_${ik}$ ! main loop - iterations 2,3,...,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) ! x has been overwritten by a*x. 70 continue - call stdlib_${ri}$copy( n, x, 1, v, 1 ) + call stdlib${ii}$_${ri}$copy( n, x, 1_${ik}$, v, 1_${ik}$ ) estold = est - est = stdlib_${ri}$asum( n, v, 1 ) + est = stdlib${ii}$_${ri}$asum( 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 @@ -24938,18 +24932,18 @@ module stdlib_linalg_lapack_${ri}$ 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) ! x has been overwritten by transpose(a)*x. 110 continue jlast = j - j = stdlib_i${ri}$amax( n, x, 1 ) + j = stdlib${ii}$_i${ri}$amax( n, x, 1_${ik}$ ) if( ( x( jlast )/=abs( x( j ) ) ) .and. ( iterest ) then - call stdlib_${ri}$copy( n, x, 1, v, 1 ) + call stdlib${ii}$_${ri}$copy( n, x, 1_${ik}$, v, 1_${ik}$ ) est = temp end if 150 continue - kase = 0 + kase = 0_${ik}$ return - end subroutine stdlib_${ri}$lacon + end subroutine stdlib${ii}$_${ri}$lacon - pure subroutine stdlib_${ri}$lacpy( uplo, m, n, a, lda, b, ldb ) + pure subroutine stdlib${ii}$_${ri}$lacpy( uplo, m, n, a, lda, b, ldb ) !! DLACPY: copies all or part of a two-dimensional matrix A to another !! matrix B. ! -- lapack auxiliary routine -- @@ -24984,13 +24978,13 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: a(lda,*) real(${rk}$), intent(out) :: b(ldb,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -25014,10 +25008,10 @@ module stdlib_linalg_lapack_${ri}$ end do end if return - end subroutine stdlib_${ri}$lacpy + end subroutine stdlib${ii}$_${ri}$lacpy - pure subroutine stdlib_${ri}$ladiv( a, b, c, d, p, q ) + pure subroutine stdlib${ii}$_${ri}$ladiv( a, b, c, d, p, q ) !! DLADIV: performs complex division in real arithmetic !! a + i*b !! p + i*q = --------- @@ -25049,9 +25043,9 @@ module stdlib_linalg_lapack_${ri}$ ab = max( abs(a), abs(b) ) cd = max( abs(c), abs(d) ) s = one - ov = stdlib_${ri}$lamch( 'OVERFLOW THRESHOLD' ) - un = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) - eps = stdlib_${ri}$lamch( 'EPSILON' ) + ov = stdlib${ii}$_${ri}$lamch( 'OVERFLOW THRESHOLD' ) + un = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_${ri}$lamch( 'EPSILON' ) be = bs / (eps*eps) if( ab >= half*ov ) then aa = half * aa @@ -25074,18 +25068,18 @@ module stdlib_linalg_lapack_${ri}$ s = s * be end if if( abs( d )<=abs( c ) ) then - call stdlib_${ri}$ladiv1(aa, bb, cc, dd, p, q) + call stdlib${ii}$_${ri}$ladiv1(aa, bb, cc, dd, p, q) else - call stdlib_${ri}$ladiv1(bb, aa, dd, cc, p, q) + call stdlib${ii}$_${ri}$ladiv1(bb, aa, dd, cc, p, q) q = -q end if p = p * s q = q * s return - end subroutine stdlib_${ri}$ladiv + end subroutine stdlib${ii}$_${ri}$ladiv - pure subroutine stdlib_${ri}$ladiv1( a, b, c, d, p, q ) + pure subroutine stdlib${ii}$_${ri}$ladiv1( a, b, c, d, p, q ) ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- @@ -25100,14 +25094,14 @@ module stdlib_linalg_lapack_${ri}$ ! Executable Statements r = d / c t = one / (c + d * r) - p = stdlib_${ri}$ladiv2(a, b, c, d, r, t) + p = stdlib${ii}$_${ri}$ladiv2(a, b, c, d, r, t) a = -a - q = stdlib_${ri}$ladiv2(b, a, c, d, r, t) + q = stdlib${ii}$_${ri}$ladiv2(b, a, c, d, r, t) return - end subroutine stdlib_${ri}$ladiv1 + end subroutine stdlib${ii}$_${ri}$ladiv1 - pure real(${rk}$) function stdlib_${ri}$ladiv2( a, b, c, d, r, t ) + pure real(${rk}$) function stdlib${ii}$_${ri}$ladiv2( a, b, c, d, r, t ) ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- @@ -25121,18 +25115,18 @@ module stdlib_linalg_lapack_${ri}$ if( r/=zero ) then br = b * r if( br/=zero ) then - stdlib_${ri}$ladiv2 = (a + br) * t + stdlib${ii}$_${ri}$ladiv2 = (a + br) * t else - stdlib_${ri}$ladiv2 = a * t + (b * t) * r + stdlib${ii}$_${ri}$ladiv2 = a * t + (b * t) * r end if else - stdlib_${ri}$ladiv2 = (a + d * (b / c)) * t + stdlib${ii}$_${ri}$ladiv2 = (a + d * (b / c)) * t end if return - end function stdlib_${ri}$ladiv2 + end function stdlib${ii}$_${ri}$ladiv2 - pure subroutine stdlib_${ri}$lae2( a, b, c, rt1, rt2 ) + pure subroutine stdlib${ii}$_${ri}$lae2( a, b, c, rt1, rt2 ) !! DLAE2: computes the eigenvalues of a 2-by-2 symmetric matrix !! [ A B ] !! [ B C ]. @@ -25168,9 +25162,9 @@ module stdlib_linalg_lapack_${ri}$ 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 + if( ijob<=2_${ik}$ ) then ! ijob=2: 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 @@ -25349,12 +25343,12 @@ module stdlib_linalg_lapack_${ri}$ ! 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 @@ -25365,56 +25359,56 @@ module stdlib_linalg_lapack_${ri}$ 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 + if( ijob<=2_${ik}$ ) then ! ijob=2: 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 @@ -25423,51 +25417,51 @@ module stdlib_linalg_lapack_${ri}$ ! 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_${ri}$laebz + end subroutine stdlib${ii}$_${ri}$laebz - pure subroutine stdlib_${ri}$laed0( icompq, qsiz, n, d, e, q, ldq, qstore, ldqs,work, iwork, info & + pure subroutine stdlib${ii}$_${ri}$laed0( icompq, qsiz, n, d, e, q, ldq, qstore, ldqs,work, iwork, info & !! DLAED0: computes all eigenvalues and corresponding eigenvectors of a !! symmetric tridiagonal matrix using the divide and conquer method. ) @@ -25475,16 +25469,16 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, ldq, ldqs, n, qsiz - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: icompq, ldq, ldqs, n, qsiz + integer(${ik}$), intent(out) :: info ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(${rk}$), intent(inout) :: d(*), e(*), q(ldq,*) real(${rk}$), intent(out) :: qstore(ldqs,*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: curlvl, curprb, curr, i, igivcl, igivnm, igivpt, indxq, iperm, iprmpt, & + integer(${ik}$) :: curlvl, curprb, curr, i, igivcl, igivnm, igivpt, indxq, iperm, iprmpt, & iq, iqptr, iwrem, j, k, lgn, matsiz, msd2, smlsiz, smm1, spm1, spm2, submat, subpbs, & tlvls real(${rk}$) :: temp @@ -25492,38 +25486,38 @@ module stdlib_linalg_lapack_${ri}$ intrinsic :: abs,real,int,log,max ! Executable Statements ! test the input parameters. - info = 0 - if( icompq<0 .or. icompq>2 ) then - info = -1 - else if( ( icompq==1 ) .and. ( qsiz2_${ik}$ ) then + info = -1_${ik}$ + else if( ( icompq==1_${ik}$ ) .and. ( qsizsmlsiz ) then do j = subpbs, 1, -1 - iwork( 2*j ) = ( iwork( j )+1 ) / 2 - iwork( 2*j-1 ) = iwork( j ) / 2 + iwork( 2_${ik}$*j ) = ( iwork( j )+1_${ik}$ ) / 2_${ik}$ + iwork( 2_${ik}$*j-1 ) = iwork( j ) / 2_${ik}$ end do - tlvls = tlvls + 1 - subpbs = 2*subpbs + tlvls = tlvls + 1_${ik}$ + subpbs = 2_${ik}$*subpbs go to 10 end if do j = 2, subpbs @@ -25531,147 +25525,147 @@ module stdlib_linalg_lapack_${ri}$ end do ! divide the matrix into subpbs submatrices of size at most smlsiz+1 ! using rank-1 modifications (cuts). - spm1 = subpbs - 1 + spm1 = subpbs - 1_${ik}$ do i = 1, spm1 - submat = iwork( i ) + 1 - smm1 = submat - 1 + submat = iwork( i ) + 1_${ik}$ + smm1 = submat - 1_${ik}$ d( smm1 ) = d( smm1 ) - abs( e( smm1 ) ) d( submat ) = d( submat ) - abs( e( smm1 ) ) end do - indxq = 4*n + 3 - if( icompq/=2 ) then + indxq = 4_${ik}$*n + 3_${ik}$ + if( icompq/=2_${ik}$ ) then ! set up workspaces for eigenvalues only/accumulate new vectors ! routine temp = log( real( n,KIND=${rk}$) ) / log( two ) - lgn = int( temp,KIND=ilp) - if( 2**lgn 1 ) - curlvl = 1 + curlvl = 1_${ik}$ 80 continue - if( subpbs>1 ) then - spm2 = subpbs - 2 + if( subpbs>1_${ik}$ ) then + spm2 = subpbs - 2_${ik}$ loop_90: do i = 0, spm2, 2 - if( i==0 ) then - submat = 1 - matsiz = iwork( 2 ) - msd2 = iwork( 1 ) - curprb = 0 + if( i==0_${ik}$ ) then + submat = 1_${ik}$ + matsiz = iwork( 2_${ik}$ ) + msd2 = iwork( 1_${ik}$ ) + curprb = 0_${ik}$ else - submat = iwork( i ) + 1 + submat = iwork( i ) + 1_${ik}$ matsiz = iwork( i+2 ) - iwork( i ) - msd2 = matsiz / 2 - curprb = curprb + 1 + msd2 = matsiz / 2_${ik}$ + curprb = curprb + 1_${ik}$ end if ! merge lower order eigensystems (of size msd2 and matsiz - msd2) ! into an eigensystem of size matsiz. - ! stdlib_${ri}$laed1 is used only for the full eigensystem of a tridiagonal + ! stdlib${ii}$_${ri}$laed1 is used only for the full eigensystem of a tridiagonal ! matrix. - ! stdlib_${ri}$laed7 handles the cases in which eigenvalues only or eigenvalues + ! stdlib${ii}$_${ri}$laed7 handles the cases in which eigenvalues only or eigenvalues ! and eigenvectors of a full symmetric matrix (which was reduced to ! tridiagonal form) are desired. - if( icompq==2 ) then - call stdlib_${ri}$laed1( matsiz, d( submat ), q( submat, submat ),ldq, iwork( & + if( icompq==2_${ik}$ ) then + call stdlib${ii}$_${ri}$laed1( matsiz, d( submat ), q( submat, submat ),ldq, iwork( & indxq+submat ),e( submat+msd2-1 ), msd2, work,iwork( subpbs+1 ), info ) else - call stdlib_${ri}$laed7( icompq, matsiz, qsiz, tlvls, curlvl, curprb,d( submat ), & - qstore( 1, submat ), ldqs,iwork( indxq+submat ), e( submat+msd2-1 ),msd2, & + call stdlib${ii}$_${ri}$laed7( icompq, matsiz, qsiz, tlvls, curlvl, curprb,d( submat ), & + qstore( 1_${ik}$, submat ), ldqs,iwork( indxq+submat ), e( submat+msd2-1 ),msd2, & work( iq ), iwork( iqptr ),iwork( iprmpt ), iwork( iperm ),iwork( igivpt ), & iwork( igivcl ),work( igivnm ), work( iwrem ),iwork( subpbs+1 ), info ) end if if( info/=0 )go to 130 - iwork( i / 2+1 ) = iwork( i+2 ) + iwork( i / 2_${ik}$+1 ) = iwork( i+2 ) end do loop_90 - subpbs = subpbs / 2 - curlvl = curlvl + 1 + subpbs = subpbs / 2_${ik}$ + curlvl = curlvl + 1_${ik}$ go to 80 end if ! end while ! re-merge the eigenvalues/vectors which were deflated at the final ! merge step. - if( icompq==1 ) then + if( icompq==1_${ik}$ ) then do i = 1, n j = iwork( indxq+i ) work( i ) = d( j ) - call stdlib_${ri}$copy( qsiz, qstore( 1, j ), 1, q( 1, i ), 1 ) + call stdlib${ii}$_${ri}$copy( qsiz, qstore( 1_${ik}$, j ), 1_${ik}$, q( 1_${ik}$, i ), 1_${ik}$ ) end do - call stdlib_${ri}$copy( n, work, 1, d, 1 ) - else if( icompq==2 ) then + call stdlib${ii}$_${ri}$copy( n, work, 1_${ik}$, d, 1_${ik}$ ) + else if( icompq==2_${ik}$ ) then do i = 1, n j = iwork( indxq+i ) work( i ) = d( j ) - call stdlib_${ri}$copy( n, q( 1, j ), 1, work( n*i+1 ), 1 ) + call stdlib${ii}$_${ri}$copy( n, q( 1_${ik}$, j ), 1_${ik}$, work( n*i+1 ), 1_${ik}$ ) end do - call stdlib_${ri}$copy( n, work, 1, d, 1 ) - call stdlib_${ri}$lacpy( 'A', n, n, work( n+1 ), n, q, ldq ) + call stdlib${ii}$_${ri}$copy( n, work, 1_${ik}$, d, 1_${ik}$ ) + call stdlib${ii}$_${ri}$lacpy( 'A', n, n, work( n+1 ), n, q, ldq ) else do i = 1, n j = iwork( indxq+i ) work( i ) = d( j ) end do - call stdlib_${ri}$copy( n, work, 1, d, 1 ) + call stdlib${ii}$_${ri}$copy( n, work, 1_${ik}$, d, 1_${ik}$ ) end if go to 140 130 continue - info = submat*( n+1 ) + submat + matsiz - 1 + info = submat*( n+1 ) + submat + matsiz - 1_${ik}$ 140 continue return - end subroutine stdlib_${ri}$laed0 + end subroutine stdlib${ii}$_${ri}$laed0 - pure subroutine stdlib_${ri}$laed1( n, d, q, ldq, indxq, rho, cutpnt, work, iwork,info ) + pure subroutine stdlib${ii}$_${ri}$laed1( n, d, q, ldq, indxq, rho, cutpnt, work, iwork,info ) !! DLAED1: computes the updated eigensystem of a diagonal !! matrix after modification by a rank-one symmetric matrix. This !! routine is used only for the eigenproblem which requires all @@ -25702,68 +25696,68 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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) :: cutpnt, ldq, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: cutpnt, ldq, n + integer(${ik}$), intent(out) :: info real(${rk}$), intent(inout) :: rho ! Array Arguments - integer(ilp), intent(inout) :: indxq(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(inout) :: indxq(*) + integer(${ik}$), intent(out) :: iwork(*) real(${rk}$), intent(inout) :: d(*), q(ldq,*) real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: coltyp, i, idlmda, indx, indxc, indxp, iq2, is, iw, iz, k, n1, n2, & + integer(${ik}$) :: coltyp, i, idlmda, indx, indxc, indxp, iq2, is, iw, iz, k, n1, n2, & zpp1 ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input parameters. - info = 0 - if( n<0 ) then - info = -1 - else if( ldqcutpnt .or. ( n / 2 )cutpnt .or. ( n / 2_${ik}$ )n1 .or. ( n / 2 )n1 .or. ( n / 2_${ik}$ )n )go to 100 if( rho*abs( z( nj ) )<=tol ) then ! deflate due to small z component. - k2 = k2 - 1 - coltyp( nj ) = 4 + k2 = k2 - 1_${ik}$ + coltyp( nj ) = 4_${ik}$ indxp( k2 ) = nj else ! check if eigenvalues are close enough to allow deflation. @@ -25906,7 +25900,7 @@ module stdlib_linalg_lapack_${ri}$ c = z( nj ) ! find sqrt(a**2+b**2) without overflow or ! destructive underflow. - tau = stdlib_${ri}$lapy2( c, s ) + tau = stdlib${ii}$_${ri}$lapy2( c, s ) t = d( nj ) - d( pj ) c = c / tau s = -s / tau @@ -25914,20 +25908,20 @@ module stdlib_linalg_lapack_${ri}$ ! deflation is possible. z( nj ) = tau z( pj ) = zero - if( coltyp( nj )/=coltyp( pj ) )coltyp( nj ) = 2 - coltyp( pj ) = 4 - call stdlib_${ri}$rot( n, q( 1, pj ), 1, q( 1, nj ), 1, c, s ) - t = d( pj )*c**2 + d( nj )*s**2 - d( nj ) = d( pj )*s**2 + d( nj )*c**2 + if( coltyp( nj )/=coltyp( pj ) )coltyp( nj ) = 2_${ik}$ + coltyp( pj ) = 4_${ik}$ + call stdlib${ii}$_${ri}$rot( n, q( 1_${ik}$, pj ), 1_${ik}$, q( 1_${ik}$, nj ), 1_${ik}$, c, s ) + t = d( pj )*c**2_${ik}$ + d( nj )*s**2_${ik}$ + d( nj ) = d( pj )*s**2_${ik}$ + d( nj )*c**2_${ik}$ d( pj ) = t - k2 = k2 - 1 - i = 1 + k2 = k2 - 1_${ik}$ + i = 1_${ik}$ 90 continue if( k2+i<=n ) then if( d( pj )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 ) / delta( ii ) dw = dpsi + dphi + temp*temp temp = z( ii )*temp @@ -26530,14 +26524,14 @@ module stdlib_linalg_lapack_${ri}$ dltub = min( dltub, tau ) end if ! calculate the new step - niter = niter + 1 + niter = niter + 1_${ik}$ if( .not.swtch3 ) then if( orgati ) then c = w - delta( ip1 )*dw - ( d( i )-d( ip1 ) )*( z( i ) / delta( i ) )& - **2 + **2_${ik}$ else c = w - delta( i )*dw - ( d( ip1 )-d( i ) )*( z( ip1 ) / delta( ip1 ) )& - **2 + **2_${ik}$ end if a = ( delta( i )+delta( ip1 ) )*w -delta( i )*delta( ip1 )*dw b = delta( i )*delta( ip1 )*w @@ -26562,17 +26556,17 @@ module stdlib_linalg_lapack_${ri}$ temp1 = z( iim1 ) / delta( iim1 ) temp1 = temp1*temp1 c = temp - delta( iip1 )*( dpsi+dphi ) -( d( iim1 )-d( iip1 ) )*temp1 - zz( 1 ) = z( iim1 )*z( iim1 ) - zz( 3 ) = delta( iip1 )*delta( iip1 )*( ( dpsi-temp1 )+dphi ) + zz( 1_${ik}$ ) = z( iim1 )*z( iim1 ) + zz( 3_${ik}$ ) = delta( iip1 )*delta( iip1 )*( ( dpsi-temp1 )+dphi ) else temp1 = z( iip1 ) / delta( iip1 ) temp1 = temp1*temp1 c = temp - delta( iim1 )*( dpsi+dphi ) -( d( iip1 )-d( iim1 ) )*temp1 - zz( 1 ) = delta( iim1 )*delta( iim1 )*( dpsi+( dphi-temp1 ) ) - zz( 3 ) = z( iip1 )*z( iip1 ) + zz( 1_${ik}$ ) = delta( iim1 )*delta( iim1 )*( dpsi+( dphi-temp1 ) ) + zz( 3_${ik}$ ) = z( iip1 )*z( iip1 ) end if - zz( 2 ) = z( ii )*z( ii ) - call stdlib_${ri}$laed6( niter, orgati, c, delta( iim1 ), zz, w, eta,info ) + zz( 2_${ik}$ ) = z( ii )*z( ii ) + call stdlib${ii}$_${ri}$laed6( niter, orgati, c, delta( iim1 ), zz, w, eta,info ) if( info/=0 )go to 250 end if ! note, eta should be positive if w is negative, and @@ -26627,7 +26621,7 @@ module stdlib_linalg_lapack_${ri}$ end if tau = tau + eta ! main loop to update the values of the array delta - iter = niter + 1 + iter = niter + 1_${ik}$ loop_240: do niter = iter, maxit ! test for convergence if( abs( w )<=eps*erretm ) then @@ -26648,10 +26642,10 @@ module stdlib_linalg_lapack_${ri}$ if( .not.swtch ) then if( orgati ) then c = w - delta( ip1 )*dw -( d( i )-d( ip1 ) )*( z( i ) / delta( i ) )& - **2 + **2_${ik}$ else c = w - delta( i )*dw - ( d( ip1 )-d( i ) )*( z( ip1 ) / delta( ip1 ) )& - **2 + **2_${ik}$ end if else temp = z( ii ) / delta( ii ) @@ -26689,26 +26683,26 @@ module stdlib_linalg_lapack_${ri}$ temp = rhoinv + psi + phi if( swtch ) then c = temp - delta( iim1 )*dpsi - delta( iip1 )*dphi - zz( 1 ) = delta( iim1 )*delta( iim1 )*dpsi - zz( 3 ) = delta( iip1 )*delta( iip1 )*dphi + zz( 1_${ik}$ ) = delta( iim1 )*delta( iim1 )*dpsi + zz( 3_${ik}$ ) = delta( iip1 )*delta( iip1 )*dphi else if( orgati ) then temp1 = z( iim1 ) / delta( iim1 ) temp1 = temp1*temp1 c = temp - delta( iip1 )*( dpsi+dphi ) -( d( iim1 )-d( iip1 ) )& *temp1 - zz( 1 ) = z( iim1 )*z( iim1 ) - zz( 3 ) = delta( iip1 )*delta( iip1 )*( ( dpsi-temp1 )+dphi ) + zz( 1_${ik}$ ) = z( iim1 )*z( iim1 ) + zz( 3_${ik}$ ) = delta( iip1 )*delta( iip1 )*( ( dpsi-temp1 )+dphi ) else temp1 = z( iip1 ) / delta( iip1 ) temp1 = temp1*temp1 c = temp - delta( iim1 )*( dpsi+dphi ) -( d( iip1 )-d( iim1 ) )& *temp1 - zz( 1 ) = delta( iim1 )*delta( iim1 )*( dpsi+( dphi-temp1 ) ) - zz( 3 ) = z( iip1 )*z( iip1 ) + zz( 1_${ik}$ ) = delta( iim1 )*delta( iim1 )*( dpsi+( dphi-temp1 ) ) + zz( 3_${ik}$ ) = z( iip1 )*z( iip1 ) end if end if - call stdlib_${ri}$laed6( niter, orgati, c, delta( iim1 ), zz, w, eta,info ) + call stdlib${ii}$_${ri}$laed6( niter, orgati, c, delta( iim1 ), zz, w, eta,info ) if( info/=0 )go to 250 end if ! note, eta should be positive if w is negative, and @@ -26759,7 +26753,7 @@ module stdlib_linalg_lapack_${ri}$ if( w*prew>zero .and. abs( w )>abs( prew ) / ten )swtch = .not.swtch end do loop_240 ! return with info = 1, niter = maxit and not converged - info = 1 + info = 1_${ik}$ if( orgati ) then dlam = d( i ) + tau else @@ -26768,10 +26762,10 @@ module stdlib_linalg_lapack_${ri}$ end if 250 continue return - end subroutine stdlib_${ri}$laed4 + end subroutine stdlib${ii}$_${ri}$laed4 - pure subroutine stdlib_${ri}$laed5( i, d, z, delta, rho, dlam ) + pure subroutine stdlib${ii}$_${ri}$laed5( 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 !! diag( D ) + RHO * Z * transpose(Z) . @@ -26783,12 +26777,12 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(out) :: dlam real(${rk}$), intent(in) :: rho ! Array Arguments - real(${rk}$), intent(in) :: d(2), z(2) - real(${rk}$), intent(out) :: delta(2) + real(${rk}$), intent(in) :: d(2_${ik}$), z(2_${ik}$) + real(${rk}$), intent(out) :: delta(2_${ik}$) ! ===================================================================== ! Local Scalars @@ -26796,53 +26790,53 @@ module stdlib_linalg_lapack_${ri}$ ! 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 + 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_${ri}$laed5 + end subroutine stdlib${ii}$_${ri}$laed5 - pure subroutine stdlib_${ri}$laed6( kniter, orgati, rho, d, z, finit, tau, info ) + pure subroutine stdlib${ii}$_${ri}$laed6( kniter, orgati, rho, d, z, finit, tau, info ) !! DLAED6: computes the positive or negative root (closest to the origin) !! of !! z(1) z(2) z(3) @@ -26859,53 +26853,53 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: finit, rho real(${rk}$), intent(out) :: tau ! Array Arguments - real(${rk}$), intent(in) :: d(3), z(3) + real(${rk}$), intent(in) :: d(3_${ik}$), z(3_${ik}$) ! ===================================================================== ! Parameters - integer(ilp), parameter :: maxit = 40 + integer(${ik}$), parameter :: maxit = 40_${ik}$ ! Local Arrays - real(${rk}$) :: dscale(3), zscale(3) + real(${rk}$) :: dscale(3_${ik}$), zscale(3_${ik}$) ! Local Scalars logical(lk) :: scale - integer(ilp) :: i, iter, niter + integer(${ik}$) :: i, iter, niter real(${rk}$) :: 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 @@ -26919,11 +26913,11 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -26936,9 +26930,9 @@ module stdlib_linalg_lapack_${ri}$ ! 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_${ri}$lamch( 'EPSILON' ) - base = stdlib_${ri}$lamch( 'BASE' ) - small1 = base**( int( log( stdlib_${ri}$lamch( 'SAFMIN' ) ) / log( base ) /three,KIND=ilp) ) + eps = stdlib${ii}$_${ri}$lamch( 'EPSILON' ) + base = stdlib${ii}$_${ri}$lamch( 'BASE' ) + small1 = base**( int( log( stdlib${ii}$_${ri}$lamch( 'SAFMIN' ) ) / log( base ) /three,KIND=${ik}$) ) sminv1 = one / small1 small2 = small1*small1 @@ -26946,9 +26940,9 @@ module stdlib_linalg_lapack_${ri}$ ! determine if scaling of inputs necessary to avoid overflow ! when computing 1/temp**3 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 @@ -27003,14 +26997,14 @@ module stdlib_linalg_lapack_${ri}$ ! if finit < 0; ! 2) 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 @@ -27052,23 +27046,22 @@ module stdlib_linalg_lapack_${ri}$ 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) ) ) goto 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_${ri}$laed6 + end subroutine stdlib${ii}$_${ri}$laed6 - pure subroutine stdlib_${ri}$laed7( icompq, n, qsiz, tlvls, curlvl, curpbm, d, q,ldq, indxq, rho, & + pure subroutine stdlib${ii}$_${ri}$laed7( icompq, n, qsiz, tlvls, curlvl, curpbm, d, q,ldq, indxq, rho, & !! DLAED7: computes the updated eigensystem of a diagonal !! matrix after modification by a rank-one symmetric matrix. This !! routine is used only for the eigenproblem which requires all @@ -27100,97 +27093,97 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, cutpnt, icompq, ldq, n, qsiz, tlvls - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: curlvl, curpbm, cutpnt, icompq, ldq, n, qsiz, tlvls + integer(${ik}$), intent(out) :: info real(${rk}$), intent(inout) :: rho ! Array Arguments - integer(ilp), intent(inout) :: givcol(2,*), givptr(*), perm(*), prmptr(*), qptr(*) + integer(${ik}$), intent(inout) :: givcol(2_${ik}$,*), givptr(*), perm(*), prmptr(*), qptr(*) - integer(ilp), intent(out) :: indxq(*), iwork(*) - real(${rk}$), intent(inout) :: d(*), givnum(2,*), q(ldq,*), qstore(*) + integer(${ik}$), intent(out) :: indxq(*), iwork(*) + real(${rk}$), intent(inout) :: d(*), givnum(2_${ik}$,*), q(ldq,*), qstore(*) real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: coltyp, curr, i, idlmda, indx, indxc, indxp, iq2, is, iw, iz, k, ldq2, & + integer(${ik}$) :: coltyp, curr, i, idlmda, indx, indxc, indxp, iq2, is, iw, iz, k, ldq2, & n1, n2, ptr ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input parameters. - info = 0 - if( icompq<0 .or. icompq>1 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( icompq==1 .and. qsizcutpnt .or. n1_${ik}$ ) then + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ + else if( icompq==1_${ik}$ .and. qsizcutpnt .or. n1 ) then - info = -1 - else if( n<0 ) then - info = -3 - else if( icompq==1 .and. qsizn ) then - info = -10 - else if( ldq21_${ik}$ ) then + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( icompq==1_${ik}$ .and. qsizn ) then + info = -10_${ik}$ + else if( ldq2n )go to 100 if( rho*abs( z( j ) )<=tol ) then ! deflate due to small z component. - k2 = k2 - 1 + k2 = k2 - 1_${ik}$ indxp( k2 ) = j else ! check if eigenvalues are close enough to allow deflation. @@ -27340,7 +27333,7 @@ module stdlib_linalg_lapack_${ri}$ c = z( j ) ! find sqrt(a**2+b**2) without overflow or ! destructive underflow. - tau = stdlib_${ri}$lapy2( c, s ) + tau = stdlib${ii}$_${ri}$lapy2( c, s ) t = d( j ) - d( jlam ) c = c / tau s = -s / tau @@ -27349,26 +27342,26 @@ module stdlib_linalg_lapack_${ri}$ z( j ) = tau z( jlam ) = zero ! record the appropriate givens rotation - givptr = givptr + 1 - givcol( 1, givptr ) = indxq( indx( jlam ) ) - givcol( 2, givptr ) = indxq( indx( j ) ) - givnum( 1, givptr ) = c - givnum( 2, givptr ) = s - if( icompq==1 ) then - call stdlib_${ri}$rot( qsiz, q( 1, indxq( indx( jlam ) ) ), 1,q( 1, indxq( indx( j & - ) ) ), 1, c, s ) + givptr = givptr + 1_${ik}$ + givcol( 1_${ik}$, givptr ) = indxq( indx( jlam ) ) + givcol( 2_${ik}$, givptr ) = indxq( indx( j ) ) + givnum( 1_${ik}$, givptr ) = c + givnum( 2_${ik}$, givptr ) = s + if( icompq==1_${ik}$ ) then + call stdlib${ii}$_${ri}$rot( qsiz, q( 1_${ik}$, indxq( indx( jlam ) ) ), 1_${ik}$,q( 1_${ik}$, indxq( indx( j & + ) ) ), 1_${ik}$, c, s ) end if t = d( jlam )*c*c + d( j )*s*s d( j ) = d( jlam )*s*s + d( j )*c*c d( jlam ) = t - k2 = k2 - 1 - i = 1 + k2 = k2 - 1_${ik}$ + i = 1_${ik}$ 90 continue if( k2+i<=n ) then if( d( jlam )max( 1, k ) ) then - info = -2 - else if( max( 1, kstop )max( 1, k ) )then - info = -3 + info = 0_${ik}$ + if( k<0_${ik}$ ) then + info = -1_${ik}$ + else if( kstart<1_${ik}$ .or. kstart>max( 1_${ik}$, k ) ) then + info = -2_${ik}$ + else if( max( 1_${ik}$, kstop )max( 1_${ik}$, k ) )then + info = -3_${ik}$ else if( n 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_${ri}$rot( 1, z( zptr1+givcol( 1, i )-1 ), 1,z( zptr1+givcol( 2, i )-1 ), & - 1, givnum( 1, i ),givnum( 2, i ) ) + call stdlib${ii}$_${ri}$rot( 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_${ri}$rot( 1, z( mid-1+givcol( 1, i ) ), 1,z( mid-1+givcol( 2, i ) ), 1, & - givnum( 1, i ),givnum( 2, i ) ) + call stdlib${ii}$_${ri}$rot( 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=${rk}$) ),KIND=ilp) + bsiz1 = int( half+sqrt( real( qptr( curr+1 )-qptr( curr ),KIND=${rk}$) ),KIND=${ik}$) - bsiz2 = int( half+sqrt( real( qptr( curr+2 )-qptr( curr+1 ),KIND=${rk}$) ),KIND=ilp) + bsiz2 = int( half+sqrt( real( qptr( curr+2 )-qptr( curr+1 ),KIND=${rk}$) ),KIND=${ik}$) - if( bsiz1>0 ) then - call stdlib_${ri}$gemv( 'T', bsiz1, bsiz1, one, q( qptr( curr ) ),bsiz1, ztemp( 1 ), & - 1, zero, z( zptr1 ), 1 ) + if( bsiz1>0_${ik}$ ) then + call stdlib${ii}$_${ri}$gemv( 'T', bsiz1, bsiz1, one, q( qptr( curr ) ),bsiz1, ztemp( 1_${ik}$ ), & + 1_${ik}$, zero, z( zptr1 ), 1_${ik}$ ) end if - call stdlib_${ri}$copy( psiz1-bsiz1, ztemp( bsiz1+1 ), 1, z( zptr1+bsiz1 ),1 ) - if( bsiz2>0 ) then - call stdlib_${ri}$gemv( 'T', bsiz2, bsiz2, one, q( qptr( curr+1 ) ),bsiz2, ztemp( & - psiz1+1 ), 1, zero, z( mid ), 1 ) + call stdlib${ii}$_${ri}$copy( psiz1-bsiz1, ztemp( bsiz1+1 ), 1_${ik}$, z( zptr1+bsiz1 ),1_${ik}$ ) + if( bsiz2>0_${ik}$ ) then + call stdlib${ii}$_${ri}$gemv( 'T', bsiz2, bsiz2, one, q( qptr( curr+1 ) ),bsiz2, ztemp( & + psiz1+1 ), 1_${ik}$, zero, z( mid ), 1_${ik}$ ) end if - call stdlib_${ri}$copy( psiz2-bsiz2, ztemp( psiz1+bsiz2+1 ), 1,z( mid+bsiz2 ), 1 ) + call stdlib${ii}$_${ri}$copy( 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_${ri}$laeda + end subroutine stdlib${ii}$_${ri}$laeda - pure subroutine stdlib_${ri}$laein( rightv, noinit, n, h, ldh, wr, wi, vr, vi, b,ldb, work, eps3, & + pure subroutine stdlib${ii}$_${ri}$laein( rightv, noinit, n, h, ldh, wr, wi, vr, vi, b,ldb, work, eps3, & !! DLAEIN: uses inverse iteration to find a right or left eigenvector !! corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg !! matrix H. @@ -27646,8 +27639,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: noinit, rightv - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb, ldh, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, ldh, n real(${rk}$), intent(in) :: bignum, eps3, smlnum, wi, wr ! Array Arguments real(${rk}$), intent(out) :: b(ldb,*), work(*) @@ -27659,13 +27652,13 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars character :: normin, trans - integer(ilp) :: i, i1, i2, i3, ierr, its, j + integer(${ik}$) :: i, i1, i2, i3, ierr, its, j real(${rk}$) :: absbii, absbjj, ei, ej, growto, norm, nrmsml, rec, rootn, scale, temp, & vcrit, vmax, vnorm, w, w1, x, xi, xr, y ! Intrinsic Functions intrinsic :: abs,real,max,sqrt ! Executable Statements - info = 0 + info = 0_${ik}$ ! growto is the threshold used in the acceptance test for an ! eigenvector. rootn = sqrt( real( n,KIND=${rk}$) ) @@ -27688,8 +27681,8 @@ module stdlib_linalg_lapack_${ri}$ end do else ! scale supplied initial vector. - vnorm = stdlib_${ri}$nrm2( n, vr, 1 ) - call stdlib_${ri}$scal( n, ( eps3*rootn ) / max( vnorm, nrmsml ), vr,1 ) + vnorm = stdlib${ii}$_${ri}$nrm2( n, vr, 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n, ( eps3*rootn ) / max( vnorm, nrmsml ), vr,1_${ik}$ ) end if if( rightv ) then ! lu decomposition with partial pivoting of b, replacing zero @@ -27743,7 +27736,7 @@ module stdlib_linalg_lapack_${ri}$ end if end if end do - if( b( 1, 1 )==zero )b( 1, 1 ) = eps3 + if( b( 1_${ik}$, 1_${ik}$ )==zero )b( 1_${ik}$, 1_${ik}$ ) = eps3 trans = 'T' end if normin = 'N' @@ -27751,26 +27744,26 @@ module stdlib_linalg_lapack_${ri}$ ! solve u*x = scale*v for a right eigenvector ! or u**t*x = scale*v for a left eigenvector, ! overwriting x on v. - call stdlib_${ri}$latrs( 'UPPER', trans, 'NONUNIT', normin, n, b, ldb,vr, scale, work,& + call stdlib${ii}$_${ri}$latrs( 'UPPER', trans, 'NONUNIT', normin, n, b, ldb,vr, scale, work,& ierr ) normin = 'Y' ! test for sufficient growth in the norm of v. - vnorm = stdlib_${ri}$asum( n, vr, 1 ) + vnorm = stdlib${ii}$_${ri}$asum( n, vr, 1_${ik}$ ) if( vnorm>=growto*scale )go to 120 ! choose new orthogonal starting vector and try again. temp = eps3 / ( rootn+one ) - vr( 1 ) = eps3 + vr( 1_${ik}$ ) = eps3 do i = 2, n vr( i ) = temp end do vr( n-its+1 ) = vr( n-its+1 ) - eps3*rootn end do ! failure to find eigenvector in n iterations. - info = 1 + info = 1_${ik}$ 120 continue ! normalize eigenvector. - i = stdlib_i${ri}$amax( n, vr, 1 ) - call stdlib_${ri}$scal( n, one / abs( vr( i ) ), vr, 1 ) + i = stdlib${ii}$_i${ri}$amax( n, vr, 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n, one / abs( vr( i ) ), vr, 1_${ik}$ ) else ! complex eigenvalue. if( noinit ) then @@ -27781,23 +27774,23 @@ module stdlib_linalg_lapack_${ri}$ end do else ! scale supplied initial vector. - norm = stdlib_${ri}$lapy2( stdlib_${ri}$nrm2( n, vr, 1 ), stdlib_${ri}$nrm2( n, vi, 1 ) ) + norm = stdlib${ii}$_${ri}$lapy2( stdlib${ii}$_${ri}$nrm2( n, vr, 1_${ik}$ ), stdlib${ii}$_${ri}$nrm2( n, vi, 1_${ik}$ ) ) rec = ( eps3*rootn ) / max( norm, nrmsml ) - call stdlib_${ri}$scal( n, rec, vr, 1 ) - call stdlib_${ri}$scal( n, rec, vi, 1 ) + call stdlib${ii}$_${ri}$scal( n, rec, vr, 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n, rec, vi, 1_${ik}$ ) end if if( rightv ) then ! lu decomposition with partial pivoting of b, replacing zero ! pivots by eps3. ! the imaginary part of the (i,j)-th element of u is stored in ! b(j+1,i). - b( 2, 1 ) = -wi + b( 2_${ik}$, 1_${ik}$ ) = -wi do i = 2, n - b( i+1, 1 ) = zero + b( i+1, 1_${ik}$ ) = zero end do loop_170: do i = 1, n - 1 - absbii = stdlib_${ri}$lapy2( b( i, i ), b( i+1, i ) ) + absbii = stdlib${ii}$_${ri}$lapy2( b( i, i ), b( i+1, i ) ) ei = h( i+1, i ) if( absbiivcrit ) then rec = one / vmax - call stdlib_${ri}$scal( n, rec, vr, 1 ) - call stdlib_${ri}$scal( n, rec, vi, 1 ) + call stdlib${ii}$_${ri}$scal( n, rec, vr, 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n, rec, vi, 1_${ik}$ ) scale = scale*rec vmax = one vcrit = bignum @@ -27929,8 +27922,8 @@ module stdlib_linalg_lapack_${ri}$ w1 = abs( xr ) + abs( xi ) if( w1>w*bignum ) then rec = one / w1 - call stdlib_${ri}$scal( n, rec, vr, 1 ) - call stdlib_${ri}$scal( n, rec, vi, 1 ) + call stdlib${ii}$_${ri}$scal( n, rec, vr, 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n, rec, vi, 1_${ik}$ ) xr = vr( i ) xi = vi( i ) scale = scale*rec @@ -27938,7 +27931,7 @@ module stdlib_linalg_lapack_${ri}$ end if end if ! divide by diagonal element of b. - call stdlib_${ri}$ladiv( xr, xi, b( i, i ), b( i+1, i ), vr( i ),vi( i ) ) + call stdlib${ii}$_${ri}$ladiv( xr, xi, b( i, i ), b( i+1, i ), vr( i ),vi( i ) ) vmax = max( abs( vr( i ) )+abs( vi( i ) ), vmax ) vcrit = bignum / vmax @@ -27955,12 +27948,12 @@ module stdlib_linalg_lapack_${ri}$ end if end do loop_250 ! test for sufficient growth in the norm of (vr,vi). - vnorm = stdlib_${ri}$asum( n, vr, 1 ) + stdlib_${ri}$asum( n, vi, 1 ) + vnorm = stdlib${ii}$_${ri}$asum( n, vr, 1_${ik}$ ) + stdlib${ii}$_${ri}$asum( n, vi, 1_${ik}$ ) if( vnorm>=growto*scale )go to 280 ! choose a new orthogonal starting vector and try again. y = eps3 / ( rootn+one ) - vr( 1 ) = eps3 - vi( 1 ) = zero + vr( 1_${ik}$ ) = eps3 + vi( 1_${ik}$ ) = zero do i = 2, n vr( i ) = y vi( i ) = zero @@ -27968,21 +27961,21 @@ module stdlib_linalg_lapack_${ri}$ vr( n-its+1 ) = vr( n-its+1 ) - eps3*rootn end do loop_270 ! failure to find eigenvector in n iterations - info = 1 + info = 1_${ik}$ 280 continue ! normalize eigenvector. vnorm = zero do i = 1, n vnorm = max( vnorm, abs( vr( i ) )+abs( vi( i ) ) ) end do - call stdlib_${ri}$scal( n, one / vnorm, vr, 1 ) - call stdlib_${ri}$scal( n, one / vnorm, vi, 1 ) + call stdlib${ii}$_${ri}$scal( n, one / vnorm, vr, 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n, one / vnorm, vi, 1_${ik}$ ) end if return - end subroutine stdlib_${ri}$laein + end subroutine stdlib${ii}$_${ri}$laein - pure subroutine stdlib_${ri}$laev2( a, b, c, rt1, rt2, cs1, sn1 ) + pure subroutine stdlib${ii}$_${ri}$laev2( a, b, c, rt1, rt2, cs1, sn1 ) !! DLAEV2: computes the eigendecomposition of a 2-by-2 symmetric matrix !! [ A B ] !! [ B C ]. @@ -28003,7 +27996,7 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars - integer(ilp) :: sgn1, sgn2 + integer(${ik}$) :: sgn1, sgn2 real(${rk}$) :: ab, acmn, acmx, acs, adf, cs, ct, df, rt, sm, tb, tn ! Intrinsic Functions intrinsic :: abs,sqrt @@ -28022,23 +28015,23 @@ module stdlib_linalg_lapack_${ri}$ 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. @@ -28047,15 +28040,15 @@ module stdlib_linalg_lapack_${ri}$ ! includes case rt1 = rt2 = 0 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 @@ -28078,10 +28071,10 @@ module stdlib_linalg_lapack_${ri}$ sn1 = tn end if return - end subroutine stdlib_${ri}$laev2 + end subroutine stdlib${ii}$_${ri}$laev2 - subroutine stdlib_${ri}$laexc( wantq, n, t, ldt, q, ldq, j1, n1, n2, work,info ) + subroutine stdlib${ii}$_${ri}$laexc( wantq, n, t, ldt, q, ldq, j1, n1, n2, work,info ) !! DLAEXC: swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in !! an upper quasi-triangular matrix T by an orthogonal similarity !! transformation. @@ -28094,92 +28087,91 @@ module stdlib_linalg_lapack_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: wantq - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: j1, ldq, ldt, n, n1, n2 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: j1, ldq, ldt, n, n1, n2 ! Array Arguments real(${rk}$), intent(inout) :: q(ldq,*), t(ldt,*) real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: ldd = 4 - integer(ilp), parameter :: ldx = 2 + integer(${ik}$), parameter :: ldd = 4_${ik}$ + integer(${ik}$), parameter :: ldx = 2_${ik}$ ! Local Scalars - integer(ilp) :: ierr, j2, j3, j4, k, nd + integer(${ik}$) :: ierr, j2, j3, j4, k, nd real(${rk}$) :: cs, dnorm, eps, scale, smlnum, sn, t11, t22, t33, tau, tau1, tau2, temp, & thresh, wi1, wi2, wr1, wr2, xnorm ! Local Arrays - real(${rk}$) :: d(ldd,4), u(3), u1(3), u2(3), x(ldx,2) + real(${rk}$) :: d(ldd,4_${ik}$), u(3_${ik}$), u1(3_${ik}$), u2(3_${ik}$), x(ldx,2_${ik}$) ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements - info = 0 + info = 0_${ik}$ ! quick return if possible if( n==0 .or. n1==0 .or. n2==0 )return if( j1+n1>n )return - j2 = j1 + 1 - j3 = j1 + 2 - j4 = j1 + 3 - if( n1==1 .and. n2==1 ) then + j2 = j1 + 1_${ik}$ + j3 = j1 + 2_${ik}$ + j4 = j1 + 3_${ik}$ + if( n1==1_${ik}$ .and. n2==1_${ik}$ ) then ! swap two 1-by-1 blocks. t11 = t( j1, j1 ) t22 = t( j2, j2 ) ! determine the transformation to perform the interchange. - call stdlib_${ri}$lartg( t( j1, j2 ), t22-t11, cs, sn, temp ) + call stdlib${ii}$_${ri}$lartg( t( j1, j2 ), t22-t11, cs, sn, temp ) ! apply transformation to the matrix t. - if( j3<=n )call stdlib_${ri}$rot( n-j1-1, t( j1, j3 ), ldt, t( j2, j3 ), ldt, cs,sn ) + if( j3<=n )call stdlib${ii}$_${ri}$rot( n-j1-1, t( j1, j3 ), ldt, t( j2, j3 ), ldt, cs,sn ) - call stdlib_${ri}$rot( j1-1, t( 1, j1 ), 1, t( 1, j2 ), 1, cs, sn ) + call stdlib${ii}$_${ri}$rot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$, t( 1_${ik}$, j2 ), 1_${ik}$, cs, sn ) t( j1, j1 ) = t22 t( j2, j2 ) = t11 if( wantq ) then ! accumulate transformation in the matrix q. - call stdlib_${ri}$rot( n, q( 1, j1 ), 1, q( 1, j2 ), 1, cs, sn ) + call stdlib${ii}$_${ri}$rot( n, q( 1_${ik}$, j1 ), 1_${ik}$, q( 1_${ik}$, j2 ), 1_${ik}$, cs, sn ) end if else ! swapping involves at least one 2-by-2 block. ! copy the diagonal block of order n1+n2 to the local array d ! and compute its norm. nd = n1 + n2 - call stdlib_${ri}$lacpy( 'FULL', nd, nd, t( j1, j1 ), ldt, d, ldd ) - dnorm = stdlib_${ri}$lange( 'MAX', nd, nd, d, ldd, work ) + call stdlib${ii}$_${ri}$lacpy( 'FULL', nd, nd, t( j1, j1 ), ldt, d, ldd ) + dnorm = stdlib${ii}$_${ri}$lange( 'MAX', nd, nd, d, ldd, work ) ! compute machine-dependent threshold for test for accepting ! swap. - eps = stdlib_${ri}$lamch( 'P' ) - smlnum = stdlib_${ri}$lamch( 'S' ) / eps + eps = stdlib${ii}$_${ri}$lamch( 'P' ) + smlnum = stdlib${ii}$_${ri}$lamch( 'S' ) / eps thresh = max( ten*eps*dnorm, smlnum ) ! solve t11*x - x*t22 = scale*t12 for x. - call stdlib_${ri}$lasy2( .false., .false., -1, n1, n2, d, ldd,d( n1+1, n1+1 ), ldd, d( 1,& + call stdlib${ii}$_${ri}$lasy2( .false., .false., -1_${ik}$, n1, n2, d, ldd,d( n1+1, n1+1 ), ldd, d( 1_${ik}$,& n1+1 ), ldd, scale, x,ldx, xnorm, ierr ) ! swap the adjacent diagonal blocks. - k = n1 + n1 + n2 - 3 + k = n1 + n1 + n2 - 3_${ik}$ go to ( 10, 20, 30 )k 10 continue ! n1 = 1, n2 = 2: generate elementary reflector h so that: ! ( scale, x11, x12 ) h = ( 0, 0, * ) - u( 1 ) = scale - u( 2 ) = x( 1, 1 ) - u( 3 ) = x( 1, 2 ) - call stdlib_${ri}$larfg( 3, u( 3 ), u, 1, tau ) - u( 3 ) = one + u( 1_${ik}$ ) = scale + u( 2_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) + u( 3_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ ) + call stdlib${ii}$_${ri}$larfg( 3_${ik}$, u( 3_${ik}$ ), u, 1_${ik}$, tau ) + u( 3_${ik}$ ) = one t11 = t( j1, j1 ) ! perform swap provisionally on diagonal block in d. - call stdlib_${ri}$larfx( 'L', 3, 3, u, tau, d, ldd, work ) - call stdlib_${ri}$larfx( 'R', 3, 3, u, tau, d, ldd, work ) + call stdlib${ii}$_${ri}$larfx( 'L', 3_${ik}$, 3_${ik}$, u, tau, d, ldd, work ) + call stdlib${ii}$_${ri}$larfx( 'R', 3_${ik}$, 3_${ik}$, u, tau, d, ldd, work ) ! test whether to reject swap. - if( max( abs( d( 3, 1 ) ), abs( d( 3, 2 ) ), abs( d( 3,3 )-t11 ) )>thresh )go to & - 50 + if( max( abs( d( 3, 1 ) ), abs( d( 3, 2 ) ), abs( d( 3,3 )-t11 ) )>thresh ) goto 50 ! accept swap: apply transformation to the entire matrix t. - call stdlib_${ri}$larfx( 'L', 3, n-j1+1, u, tau, t( j1, j1 ), ldt, work ) - call stdlib_${ri}$larfx( 'R', j2, 3, u, tau, t( 1, j1 ), ldt, work ) + call stdlib${ii}$_${ri}$larfx( 'L', 3_${ik}$, n-j1+1, u, tau, t( j1, j1 ), ldt, work ) + call stdlib${ii}$_${ri}$larfx( 'R', j2, 3_${ik}$, u, tau, t( 1_${ik}$, j1 ), ldt, work ) t( j3, j1 ) = zero t( j3, j2 ) = zero t( j3, j3 ) = t11 if( wantq ) then ! accumulate transformation in the matrix q. - call stdlib_${ri}$larfx( 'R', n, 3, u, tau, q( 1, j1 ), ldq, work ) + call stdlib${ii}$_${ri}$larfx( 'R', n, 3_${ik}$, u, tau, q( 1_${ik}$, j1 ), ldq, work ) end if go to 40 20 continue @@ -28187,27 +28179,26 @@ module stdlib_linalg_lapack_${ri}$ ! h ( -x11 ) = ( * ) ! ( -x21 ) = ( 0 ) ! ( scale ) = ( 0 ) - u( 1 ) = -x( 1, 1 ) - u( 2 ) = -x( 2, 1 ) - u( 3 ) = scale - call stdlib_${ri}$larfg( 3, u( 1 ), u( 2 ), 1, tau ) - u( 1 ) = one + u( 1_${ik}$ ) = -x( 1_${ik}$, 1_${ik}$ ) + u( 2_${ik}$ ) = -x( 2_${ik}$, 1_${ik}$ ) + u( 3_${ik}$ ) = scale + call stdlib${ii}$_${ri}$larfg( 3_${ik}$, u( 1_${ik}$ ), u( 2_${ik}$ ), 1_${ik}$, tau ) + u( 1_${ik}$ ) = one t33 = t( j3, j3 ) ! perform swap provisionally on diagonal block in d. - call stdlib_${ri}$larfx( 'L', 3, 3, u, tau, d, ldd, work ) - call stdlib_${ri}$larfx( 'R', 3, 3, u, tau, d, ldd, work ) + call stdlib${ii}$_${ri}$larfx( 'L', 3_${ik}$, 3_${ik}$, u, tau, d, ldd, work ) + call stdlib${ii}$_${ri}$larfx( 'R', 3_${ik}$, 3_${ik}$, u, tau, d, ldd, work ) ! test whether to reject swap. - if( max( abs( d( 2, 1 ) ), abs( d( 3, 1 ) ), abs( d( 1,1 )-t33 ) )>thresh )go to & - 50 + if( max( abs( d( 2, 1 ) ), abs( d( 3, 1 ) ), abs( d( 1,1 )-t33 ) )>thresh ) goto 50 ! accept swap: apply transformation to the entire matrix t. - call stdlib_${ri}$larfx( 'R', j3, 3, u, tau, t( 1, j1 ), ldt, work ) - call stdlib_${ri}$larfx( 'L', 3, n-j1, u, tau, t( j1, j2 ), ldt, work ) + call stdlib${ii}$_${ri}$larfx( 'R', j3, 3_${ik}$, u, tau, t( 1_${ik}$, j1 ), ldt, work ) + call stdlib${ii}$_${ri}$larfx( 'L', 3_${ik}$, n-j1, u, tau, t( j1, j2 ), ldt, work ) t( j1, j1 ) = t33 t( j2, j1 ) = zero t( j3, j1 ) = zero if( wantq ) then ! accumulate transformation in the matrix q. - call stdlib_${ri}$larfx( 'R', n, 3, u, tau, q( 1, j1 ), ldq, work ) + call stdlib${ii}$_${ri}$larfx( 'R', n, 3_${ik}$, u, tau, q( 1_${ik}$, j1 ), ldq, work ) end if go to 40 30 continue @@ -28217,69 +28208,69 @@ module stdlib_linalg_lapack_${ri}$ ! ( -x21 -x22 ) ( 0 * ) ! ( scale 0 ) ( 0 0 ) ! ( 0 scale ) ( 0 0 ) - u1( 1 ) = -x( 1, 1 ) - u1( 2 ) = -x( 2, 1 ) - u1( 3 ) = scale - call stdlib_${ri}$larfg( 3, u1( 1 ), u1( 2 ), 1, tau1 ) - u1( 1 ) = one - temp = -tau1*( x( 1, 2 )+u1( 2 )*x( 2, 2 ) ) - u2( 1 ) = -temp*u1( 2 ) - x( 2, 2 ) - u2( 2 ) = -temp*u1( 3 ) - u2( 3 ) = scale - call stdlib_${ri}$larfg( 3, u2( 1 ), u2( 2 ), 1, tau2 ) - u2( 1 ) = one + u1( 1_${ik}$ ) = -x( 1_${ik}$, 1_${ik}$ ) + u1( 2_${ik}$ ) = -x( 2_${ik}$, 1_${ik}$ ) + u1( 3_${ik}$ ) = scale + call stdlib${ii}$_${ri}$larfg( 3_${ik}$, u1( 1_${ik}$ ), u1( 2_${ik}$ ), 1_${ik}$, tau1 ) + u1( 1_${ik}$ ) = one + temp = -tau1*( x( 1_${ik}$, 2_${ik}$ )+u1( 2_${ik}$ )*x( 2_${ik}$, 2_${ik}$ ) ) + u2( 1_${ik}$ ) = -temp*u1( 2_${ik}$ ) - x( 2_${ik}$, 2_${ik}$ ) + u2( 2_${ik}$ ) = -temp*u1( 3_${ik}$ ) + u2( 3_${ik}$ ) = scale + call stdlib${ii}$_${ri}$larfg( 3_${ik}$, u2( 1_${ik}$ ), u2( 2_${ik}$ ), 1_${ik}$, tau2 ) + u2( 1_${ik}$ ) = one ! perform swap provisionally on diagonal block in d. - call stdlib_${ri}$larfx( 'L', 3, 4, u1, tau1, d, ldd, work ) - call stdlib_${ri}$larfx( 'R', 4, 3, u1, tau1, d, ldd, work ) - call stdlib_${ri}$larfx( 'L', 3, 4, u2, tau2, d( 2, 1 ), ldd, work ) - call stdlib_${ri}$larfx( 'R', 4, 3, u2, tau2, d( 1, 2 ), ldd, work ) + call stdlib${ii}$_${ri}$larfx( 'L', 3_${ik}$, 4_${ik}$, u1, tau1, d, ldd, work ) + call stdlib${ii}$_${ri}$larfx( 'R', 4_${ik}$, 3_${ik}$, u1, tau1, d, ldd, work ) + call stdlib${ii}$_${ri}$larfx( 'L', 3_${ik}$, 4_${ik}$, u2, tau2, d( 2_${ik}$, 1_${ik}$ ), ldd, work ) + call stdlib${ii}$_${ri}$larfx( 'R', 4_${ik}$, 3_${ik}$, u2, tau2, d( 1_${ik}$, 2_${ik}$ ), ldd, work ) ! test whether to reject swap. - if( max( abs( d( 3, 1 ) ), abs( d( 3, 2 ) ), abs( d( 4, 1 ) ),abs( d( 4, 2 ) ) )& + if( max( abs( d( 3_${ik}$, 1_${ik}$ ) ), abs( d( 3_${ik}$, 2_${ik}$ ) ), abs( d( 4_${ik}$, 1_${ik}$ ) ),abs( d( 4_${ik}$, 2_${ik}$ ) ) )& >thresh )go to 50 ! accept swap: apply transformation to the entire matrix t. - call stdlib_${ri}$larfx( 'L', 3, n-j1+1, u1, tau1, t( j1, j1 ), ldt, work ) - call stdlib_${ri}$larfx( 'R', j4, 3, u1, tau1, t( 1, j1 ), ldt, work ) - call stdlib_${ri}$larfx( 'L', 3, n-j1+1, u2, tau2, t( j2, j1 ), ldt, work ) - call stdlib_${ri}$larfx( 'R', j4, 3, u2, tau2, t( 1, j2 ), ldt, work ) + call stdlib${ii}$_${ri}$larfx( 'L', 3_${ik}$, n-j1+1, u1, tau1, t( j1, j1 ), ldt, work ) + call stdlib${ii}$_${ri}$larfx( 'R', j4, 3_${ik}$, u1, tau1, t( 1_${ik}$, j1 ), ldt, work ) + call stdlib${ii}$_${ri}$larfx( 'L', 3_${ik}$, n-j1+1, u2, tau2, t( j2, j1 ), ldt, work ) + call stdlib${ii}$_${ri}$larfx( 'R', j4, 3_${ik}$, u2, tau2, t( 1_${ik}$, j2 ), ldt, work ) t( j3, j1 ) = zero t( j3, j2 ) = zero t( j4, j1 ) = zero t( j4, j2 ) = zero if( wantq ) then ! accumulate transformation in the matrix q. - call stdlib_${ri}$larfx( 'R', n, 3, u1, tau1, q( 1, j1 ), ldq, work ) - call stdlib_${ri}$larfx( 'R', n, 3, u2, tau2, q( 1, j2 ), ldq, work ) + call stdlib${ii}$_${ri}$larfx( 'R', n, 3_${ik}$, u1, tau1, q( 1_${ik}$, j1 ), ldq, work ) + call stdlib${ii}$_${ri}$larfx( 'R', n, 3_${ik}$, u2, tau2, q( 1_${ik}$, j2 ), ldq, work ) end if 40 continue - if( n2==2 ) then + if( n2==2_${ik}$ ) then ! standardize new 2-by-2 block t11 - call stdlib_${ri}$lanv2( t( j1, j1 ), t( j1, j2 ), t( j2, j1 ),t( j2, j2 ), wr1, wi1, & + call stdlib${ii}$_${ri}$lanv2( t( j1, j1 ), t( j1, j2 ), t( j2, j1 ),t( j2, j2 ), wr1, wi1, & wr2, wi2, cs, sn ) - call stdlib_${ri}$rot( n-j1-1, t( j1, j1+2 ), ldt, t( j2, j1+2 ), ldt,cs, sn ) - call stdlib_${ri}$rot( j1-1, t( 1, j1 ), 1, t( 1, j2 ), 1, cs, sn ) - if( wantq )call stdlib_${ri}$rot( n, q( 1, j1 ), 1, q( 1, j2 ), 1, cs, sn ) + call stdlib${ii}$_${ri}$rot( n-j1-1, t( j1, j1+2 ), ldt, t( j2, j1+2 ), ldt,cs, sn ) + call stdlib${ii}$_${ri}$rot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$, t( 1_${ik}$, j2 ), 1_${ik}$, cs, sn ) + if( wantq )call stdlib${ii}$_${ri}$rot( n, q( 1_${ik}$, j1 ), 1_${ik}$, q( 1_${ik}$, j2 ), 1_${ik}$, cs, sn ) end if - if( n1==2 ) then + if( n1==2_${ik}$ ) then ! standardize new 2-by-2 block t22 j3 = j1 + n2 - j4 = j3 + 1 - call stdlib_${ri}$lanv2( t( j3, j3 ), t( j3, j4 ), t( j4, j3 ),t( j4, j4 ), wr1, wi1, & + j4 = j3 + 1_${ik}$ + call stdlib${ii}$_${ri}$lanv2( t( j3, j3 ), t( j3, j4 ), t( j4, j3 ),t( j4, j4 ), wr1, wi1, & wr2, wi2, cs, sn ) - if( j3+2<=n )call stdlib_${ri}$rot( n-j3-1, t( j3, j3+2 ), ldt, t( j4, j3+2 ),ldt, cs,& + if( j3+2<=n )call stdlib${ii}$_${ri}$rot( n-j3-1, t( j3, j3+2 ), ldt, t( j4, j3+2 ),ldt, cs,& sn ) - call stdlib_${ri}$rot( j3-1, t( 1, j3 ), 1, t( 1, j4 ), 1, cs, sn ) - if( wantq )call stdlib_${ri}$rot( n, q( 1, j3 ), 1, q( 1, j4 ), 1, cs, sn ) + call stdlib${ii}$_${ri}$rot( j3-1, t( 1_${ik}$, j3 ), 1_${ik}$, t( 1_${ik}$, j4 ), 1_${ik}$, cs, sn ) + if( wantq )call stdlib${ii}$_${ri}$rot( n, q( 1_${ik}$, j3 ), 1_${ik}$, q( 1_${ik}$, j4 ), 1_${ik}$, cs, sn ) end if end if return ! exit with info = 1 if swap was rejected. 50 continue - info = 1 + info = 1_${ik}$ return - end subroutine stdlib_${ri}$laexc + end subroutine stdlib${ii}$_${ri}$laexc - pure subroutine stdlib_${ri}$lag2( a, lda, b, ldb, safmin, scale1, scale2, wr1,wr2, wi ) + pure subroutine stdlib${ii}$_${ri}$lag2( a, lda, b, ldb, safmin, scale1, scale2, wr1,wr2, wi ) !! DLAG2: computes the eigenvalues of a 2 x 2 generalized eigenvalue !! problem A - w B, with scaling as necessary to avoid over-/underflow. !! The scaling factor "s" results in a modified eigenvalue equation @@ -28290,7 +28281,7 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: safmin real(${rk}$), intent(out) :: scale1, scale2, wi, wr1, wr2 ! Array Arguments @@ -28313,17 +28304,17 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -28460,10 +28451,10 @@ module stdlib_linalg_lapack_${ri}$ end if end if return - end subroutine stdlib_${ri}$lag2 + end subroutine stdlib${ii}$_${ri}$lag2 - pure subroutine stdlib_${ri}$lag2s( m, n, a, lda, sa, ldsa, info ) + pure subroutine stdlib${ii}$_${ri}$lag2s( m, n, a, lda, sa, ldsa, info ) !! DLAG2S: converts a DOUBLE PRECISION matrix, SA, to a SINGLE !! PRECISION matrix, A. !! RMAX is the overflow for the SINGLE PRECISION arithmetic @@ -28474,33 +28465,33 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(dp), intent(out) :: sa(ldsa,*) real(${rk}$), intent(in) :: a(lda,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(${rk}$) :: rmax ! Executable Statements - rmax = stdlib_dlamch( 'O' ) + rmax = stdlib${ii}$_dlamch( 'O' ) do j = 1, n do i = 1, m if( ( a( i, j )<-rmax ) .or. ( a( i, j )>rmax ) ) then - info = 1 + info = 1_${ik}$ go to 30 end if sa( i, j ) = a( i, j ) end do end do - info = 0 + info = 0_${ik}$ 30 continue return - end subroutine stdlib_${ri}$lag2s + end subroutine stdlib${ii}$_${ri}$lag2s - pure subroutine stdlib_${ri}$lags2( upper, a1, a2, a3, b1, b2, b3, csu, snu, csv,snv, csq, snq ) + pure subroutine stdlib${ii}$_${ri}$lags2( upper, a1, a2, a3, b1, b2, b3, csu, snu, csv,snv, csq, snq ) !! DLAGS2: computes 2-by-2 orthogonal matrices U, V and Q, such !! that if ( UPPER ) then !! U**T *A*Q = U**T *( A1 A2 )*Q = ( x 0 ) @@ -28545,7 +28536,7 @@ module stdlib_linalg_lapack_${ri}$ ! 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_${ri}$lasv2( a, b, d, s1, s2, snr, csr, snl, csl ) + call stdlib${ii}$_${ri}$lasv2( a, b, d, s1, s2, snr, csr, snl, csl ) if( abs( csl )>=abs( snl ) .or. abs( csr )>=abs( snr ) )then ! compute the (1,1) and (1,2) elements of u**t *a and v**t *b, ! and (1,2) element of |u|**t *|a| and |v|**t *|b|. @@ -28559,12 +28550,12 @@ module stdlib_linalg_lapack_${ri}$ if( ( abs( ua11r )+abs( ua12 ) )/=zero ) then if( aua12 / ( abs( ua11r )+abs( ua12 ) )<=avb12 /( abs( vb11r )+abs( vb12 ) ) & ) then - call stdlib_${ri}$lartg( -ua11r, ua12, csq, snq, r ) + call stdlib${ii}$_${ri}$lartg( -ua11r, ua12, csq, snq, r ) else - call stdlib_${ri}$lartg( -vb11r, vb12, csq, snq, r ) + call stdlib${ii}$_${ri}$lartg( -vb11r, vb12, csq, snq, r ) end if else - call stdlib_${ri}$lartg( -vb11r, vb12, csq, snq, r ) + call stdlib${ii}$_${ri}$lartg( -vb11r, vb12, csq, snq, r ) end if csu = csl snu = -snl @@ -28583,12 +28574,12 @@ module stdlib_linalg_lapack_${ri}$ if( ( abs( ua21 )+abs( ua22 ) )/=zero ) then if( aua22 / ( abs( ua21 )+abs( ua22 ) )<=avb22 /( abs( vb21 )+abs( vb22 ) ) ) & then - call stdlib_${ri}$lartg( -ua21, ua22, csq, snq, r ) + call stdlib${ii}$_${ri}$lartg( -ua21, ua22, csq, snq, r ) else - call stdlib_${ri}$lartg( -vb21, vb22, csq, snq, r ) + call stdlib${ii}$_${ri}$lartg( -vb21, vb22, csq, snq, r ) end if else - call stdlib_${ri}$lartg( -vb21, vb22, csq, snq, r ) + call stdlib${ii}$_${ri}$lartg( -vb21, vb22, csq, snq, r ) end if csu = snl snu = csl @@ -28605,7 +28596,7 @@ module stdlib_linalg_lapack_${ri}$ ! 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_${ri}$lasv2( a, c, d, s1, s2, snr, csr, snl, csl ) + call stdlib${ii}$_${ri}$lasv2( a, c, d, s1, s2, snr, csr, snl, csl ) if( abs( csr )>=abs( snr ) .or. abs( csl )>=abs( snl ) )then ! compute the (2,1) and (2,2) elements of u**t *a and v**t *b, ! and (2,1) element of |u|**t *|a| and |v|**t *|b|. @@ -28619,12 +28610,12 @@ module stdlib_linalg_lapack_${ri}$ if( ( abs( ua21 )+abs( ua22r ) )/=zero ) then if( aua21 / ( abs( ua21 )+abs( ua22r ) )<=avb21 /( abs( vb21 )+abs( vb22r ) ) & ) then - call stdlib_${ri}$lartg( ua22r, ua21, csq, snq, r ) + call stdlib${ii}$_${ri}$lartg( ua22r, ua21, csq, snq, r ) else - call stdlib_${ri}$lartg( vb22r, vb21, csq, snq, r ) + call stdlib${ii}$_${ri}$lartg( vb22r, vb21, csq, snq, r ) end if else - call stdlib_${ri}$lartg( vb22r, vb21, csq, snq, r ) + call stdlib${ii}$_${ri}$lartg( vb22r, vb21, csq, snq, r ) end if csu = csr snu = -snr @@ -28643,12 +28634,12 @@ module stdlib_linalg_lapack_${ri}$ if( ( abs( ua11 )+abs( ua12 ) )/=zero ) then if( aua11 / ( abs( ua11 )+abs( ua12 ) )<=avb11 /( abs( vb11 )+abs( vb12 ) ) ) & then - call stdlib_${ri}$lartg( ua12, ua11, csq, snq, r ) + call stdlib${ii}$_${ri}$lartg( ua12, ua11, csq, snq, r ) else - call stdlib_${ri}$lartg( vb12, vb11, csq, snq, r ) + call stdlib${ii}$_${ri}$lartg( vb12, vb11, csq, snq, r ) end if else - call stdlib_${ri}$lartg( vb12, vb11, csq, snq, r ) + call stdlib${ii}$_${ri}$lartg( vb12, vb11, csq, snq, r ) end if csu = snr snu = csr @@ -28657,10 +28648,10 @@ module stdlib_linalg_lapack_${ri}$ end if end if return - end subroutine stdlib_${ri}$lags2 + end subroutine stdlib${ii}$_${ri}$lags2 - pure subroutine stdlib_${ri}$lagtf( n, a, lambda, b, c, tol, d, in, info ) + pure subroutine stdlib${ii}$_${ri}$lagtf( n, a, lambda, b, c, tol, d, in, info ) !! DLAGTF: factorizes the matrix (T - lambda*I), where T is an n by n !! tridiagonal matrix and lambda is a scalar, as !! T - lambda*I = PLU, @@ -28677,37 +28668,37 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: lambda, tol ! Array Arguments - integer(ilp), intent(out) :: in(*) + integer(${ik}$), intent(out) :: in(*) real(${rk}$), intent(inout) :: a(*), b(*), c(*) real(${rk}$), intent(out) :: d(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: k + integer(${ik}$) :: k real(${rk}$) :: 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( 'DLAGTF', -info ) + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -1_${ik}$ + call stdlib${ii}$_xerbla( 'DLAGTF', -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_${ri}$lamch( 'EPSILON' ) + eps = stdlib${ii}$_${ri}$lamch( '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 ) ) @@ -28718,20 +28709,20 @@ module stdlib_linalg_lapack_${ri}$ 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 ) @@ -28744,14 +28735,14 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$lagtf + end subroutine stdlib${ii}$_${ri}$lagtf - pure subroutine stdlib_${ri}$lagtm( trans, n, nrhs, alpha, dl, d, du, x, ldx, beta,b, ldb ) + pure subroutine stdlib${ii}$_${ri}$lagtm( trans, n, nrhs, alpha, dl, d, du, x, ldx, beta,b, ldb ) !! DLAGTM: performs a matrix-vector product of the form !! B := alpha * A * X + beta * B !! where A is a tridiagonal matrix of order N, B and X are N by NRHS @@ -28763,7 +28754,7 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: alpha, beta ! Array Arguments real(${rk}$), intent(inout) :: b(ldb,*) @@ -28771,7 +28762,7 @@ module stdlib_linalg_lapack_${ri}$ ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Executable Statements if( n==0 )return ! multiply b by beta if beta/=1. @@ -28792,10 +28783,10 @@ module stdlib_linalg_lapack_${ri}$ 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 & @@ -28806,10 +28797,10 @@ module stdlib_linalg_lapack_${ri}$ 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 & @@ -28822,10 +28813,10 @@ module stdlib_linalg_lapack_${ri}$ 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 & @@ -28836,10 +28827,10 @@ module stdlib_linalg_lapack_${ri}$ 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 & @@ -28850,10 +28841,10 @@ module stdlib_linalg_lapack_${ri}$ end if end if return - end subroutine stdlib_${ri}$lagtm + end subroutine stdlib${ii}$_${ri}$lagtm - pure subroutine stdlib_${ri}$lagts( job, n, a, b, c, d, in, y, tol, info ) + pure subroutine stdlib${ii}$_${ri}$lagts( job, n, a, b, c, d, in, y, tol, info ) !! DLAGTS: may be used to solve one of the systems of equations !! (T - lambda*I)*x = y or (T - lambda*I)**T*x = y, !! where T is an n by n tridiagonal matrix, for x, following the @@ -28867,39 +28858,39 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(inout) :: tol ! Array Arguments - integer(ilp), intent(in) :: in(*) + integer(${ik}$), intent(in) :: in(*) real(${rk}$), intent(in) :: a(*), b(*), c(*), d(*) real(${rk}$), intent(inout) :: y(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: k + integer(${ik}$) :: k real(${rk}$) :: 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( 'DLAGTS', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DLAGTS', -info ) return end if if( n==0 )return - eps = stdlib_${ri}$lamch( 'EPSILON' ) - sfmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_${ri}$lamch( 'EPSILON' ) + sfmin = stdlib${ii}$_${ri}$lamch( '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 @@ -28907,9 +28898,9 @@ module stdlib_linalg_lapack_${ri}$ 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 ) @@ -28917,7 +28908,7 @@ module stdlib_linalg_lapack_${ri}$ 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 ) @@ -28961,7 +28952,7 @@ module stdlib_linalg_lapack_${ri}$ if( absakabsak )then ak = ak + pert - pert = 2*pert + pert = 2_${ik}$*pert go to 40 else temp = temp*bignum @@ -28969,7 +28960,7 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -28978,11 +28969,11 @@ module stdlib_linalg_lapack_${ri}$ end if else ! come to here if job = 2 or -2 - if( job==2 ) then + 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 ) @@ -29007,9 +28998,9 @@ module stdlib_linalg_lapack_${ri}$ 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 ) @@ -29022,7 +29013,7 @@ module stdlib_linalg_lapack_${ri}$ if( absakabsak )then ak = ak + pert - pert = 2*pert + pert = 2_${ik}$*pert go to 70 else temp = temp*bignum @@ -29030,7 +29021,7 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -29038,7 +29029,7 @@ module stdlib_linalg_lapack_${ri}$ 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 ) @@ -29047,10 +29038,10 @@ module stdlib_linalg_lapack_${ri}$ end if end do end if - end subroutine stdlib_${ri}$lagts + end subroutine stdlib${ii}$_${ri}$lagts - pure subroutine stdlib_${ri}$lagv2( a, lda, b, ldb, alphar, alphai, beta, csl, snl,csr, snr ) + pure subroutine stdlib${ii}$_${ri}$lagv2( a, lda, b, ldb, alphar, alphai, beta, csl, snl,csr, snr ) !! DLAGV2: computes the Generalized Schur factorization of a real 2-by-2 !! matrix pencil (A,B) where B is upper triangular. This routine !! computes orthogonal (rotation) matrices given by CSL, SNL and CSR, @@ -29073,11 +29064,11 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(out) :: csl, csr, snl, snr ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) - real(${rk}$), intent(out) :: alphai(2), alphar(2), beta(2) + real(${rk}$), intent(out) :: alphai(2_${ik}$), alphar(2_${ik}$), beta(2_${ik}$) ! ===================================================================== ! Local Scalars @@ -29086,135 +29077,135 @@ module stdlib_linalg_lapack_${ri}$ ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements - safmin = stdlib_${ri}$lamch( 'S' ) - ulp = stdlib_${ri}$lamch( 'P' ) + safmin = stdlib${ii}$_${ri}$lamch( 'S' ) + ulp = stdlib${ii}$_${ri}$lamch( 'P' ) ! 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 - a( 1, 1 ) = ascale*a( 1, 1 ) - a( 1, 2 ) = ascale*a( 1, 2 ) - a( 2, 1 ) = ascale*a( 2, 1 ) - a( 2, 2 ) = ascale*a( 2, 2 ) + a( 1_${ik}$, 1_${ik}$ ) = ascale*a( 1_${ik}$, 1_${ik}$ ) + a( 1_${ik}$, 2_${ik}$ ) = ascale*a( 1_${ik}$, 2_${ik}$ ) + a( 2_${ik}$, 1_${ik}$ ) = ascale*a( 2_${ik}$, 1_${ik}$ ) + a( 2_${ik}$, 2_${ik}$ ) = ascale*a( 2_${ik}$, 2_${ik}$ ) ! scale b - bnorm = max( abs( b( 1, 1 ) ), abs( b( 1, 2 ) )+abs( b( 2, 2 ) ),safmin ) + bnorm = max( abs( b( 1_${ik}$, 1_${ik}$ ) ), abs( b( 1_${ik}$, 2_${ik}$ ) )+abs( b( 2_${ik}$, 2_${ik}$ ) ),safmin ) bscale = one / bnorm - b( 1, 1 ) = bscale*b( 1, 1 ) - b( 1, 2 ) = bscale*b( 1, 2 ) - b( 2, 2 ) = bscale*b( 2, 2 ) + b( 1_${ik}$, 1_${ik}$ ) = bscale*b( 1_${ik}$, 1_${ik}$ ) + b( 1_${ik}$, 2_${ik}$ ) = bscale*b( 1_${ik}$, 2_${ik}$ ) + b( 2_${ik}$, 2_${ik}$ ) = bscale*b( 2_${ik}$, 2_${ik}$ ) ! check if a can be deflated - if( abs( a( 2, 1 ) )<=ulp ) then + if( abs( a( 2_${ik}$, 1_${ik}$ ) )<=ulp ) then csl = one snl = zero csr = one snr = zero - a( 2, 1 ) = zero - b( 2, 1 ) = zero + a( 2_${ik}$, 1_${ik}$ ) = zero + b( 2_${ik}$, 1_${ik}$ ) = zero wi = zero ! check if b is singular - else if( abs( b( 1, 1 ) )<=ulp ) then - call stdlib_${ri}$lartg( a( 1, 1 ), a( 2, 1 ), csl, snl, r ) + else if( abs( b( 1_${ik}$, 1_${ik}$ ) )<=ulp ) then + call stdlib${ii}$_${ri}$lartg( a( 1_${ik}$, 1_${ik}$ ), a( 2_${ik}$, 1_${ik}$ ), csl, snl, r ) csr = one snr = zero - call stdlib_${ri}$rot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl ) - call stdlib_${ri}$rot( 2, b( 1, 1 ), ldb, b( 2, 1 ), ldb, csl, snl ) - a( 2, 1 ) = zero - b( 1, 1 ) = zero - b( 2, 1 ) = zero + call stdlib${ii}$_${ri}$rot( 2_${ik}$, a( 1_${ik}$, 1_${ik}$ ), lda, a( 2_${ik}$, 1_${ik}$ ), lda, csl, snl ) + call stdlib${ii}$_${ri}$rot( 2_${ik}$, b( 1_${ik}$, 1_${ik}$ ), ldb, b( 2_${ik}$, 1_${ik}$ ), ldb, csl, snl ) + a( 2_${ik}$, 1_${ik}$ ) = zero + b( 1_${ik}$, 1_${ik}$ ) = zero + b( 2_${ik}$, 1_${ik}$ ) = zero wi = zero - else if( abs( b( 2, 2 ) )<=ulp ) then - call stdlib_${ri}$lartg( a( 2, 2 ), a( 2, 1 ), csr, snr, t ) + else if( abs( b( 2_${ik}$, 2_${ik}$ ) )<=ulp ) then + call stdlib${ii}$_${ri}$lartg( a( 2_${ik}$, 2_${ik}$ ), a( 2_${ik}$, 1_${ik}$ ), csr, snr, t ) snr = -snr - call stdlib_${ri}$rot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr ) - call stdlib_${ri}$rot( 2, b( 1, 1 ), 1, b( 1, 2 ), 1, csr, snr ) + call stdlib${ii}$_${ri}$rot( 2_${ik}$, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, a( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, csr, snr ) + call stdlib${ii}$_${ri}$rot( 2_${ik}$, b( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, b( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, csr, snr ) csl = one snl = zero - a( 2, 1 ) = zero - b( 2, 1 ) = zero - b( 2, 2 ) = zero + a( 2_${ik}$, 1_${ik}$ ) = zero + b( 2_${ik}$, 1_${ik}$ ) = zero + b( 2_${ik}$, 2_${ik}$ ) = zero wi = zero else ! b is nonsingular, first compute the eigenvalues of (a,b) - call stdlib_${ri}$lag2( a, lda, b, ldb, safmin, scale1, scale2, wr1, wr2,wi ) + call stdlib${ii}$_${ri}$lag2( a, lda, b, ldb, safmin, scale1, scale2, wr1, wr2,wi ) if( wi==zero ) then ! two real eigenvalues, compute s*a-w*b - h1 = scale1*a( 1, 1 ) - wr1*b( 1, 1 ) - h2 = scale1*a( 1, 2 ) - wr1*b( 1, 2 ) - h3 = scale1*a( 2, 2 ) - wr1*b( 2, 2 ) - rr = stdlib_${ri}$lapy2( h1, h2 ) - qq = stdlib_${ri}$lapy2( scale1*a( 2, 1 ), h3 ) + h1 = scale1*a( 1_${ik}$, 1_${ik}$ ) - wr1*b( 1_${ik}$, 1_${ik}$ ) + h2 = scale1*a( 1_${ik}$, 2_${ik}$ ) - wr1*b( 1_${ik}$, 2_${ik}$ ) + h3 = scale1*a( 2_${ik}$, 2_${ik}$ ) - wr1*b( 2_${ik}$, 2_${ik}$ ) + rr = stdlib${ii}$_${ri}$lapy2( h1, h2 ) + qq = stdlib${ii}$_${ri}$lapy2( scale1*a( 2_${ik}$, 1_${ik}$ ), h3 ) if( rr>qq ) then ! find right rotation matrix to zero 1,1 element of ! (sa - wb) - call stdlib_${ri}$lartg( h2, h1, csr, snr, t ) + call stdlib${ii}$_${ri}$lartg( h2, h1, csr, snr, t ) else ! find right rotation matrix to zero 2,1 element of ! (sa - wb) - call stdlib_${ri}$lartg( h3, scale1*a( 2, 1 ), csr, snr, t ) + call stdlib${ii}$_${ri}$lartg( h3, scale1*a( 2_${ik}$, 1_${ik}$ ), csr, snr, t ) end if snr = -snr - call stdlib_${ri}$rot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr ) - call stdlib_${ri}$rot( 2, b( 1, 1 ), 1, b( 1, 2 ), 1, csr, snr ) + call stdlib${ii}$_${ri}$rot( 2_${ik}$, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, a( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, csr, snr ) + call stdlib${ii}$_${ri}$rot( 2_${ik}$, b( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, b( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, csr, snr ) ! compute inf norms of a and b - h1 = max( abs( a( 1, 1 ) )+abs( a( 1, 2 ) ),abs( a( 2, 1 ) )+abs( a( 2, 2 ) ) ) + h1 = max( abs( a( 1_${ik}$, 1_${ik}$ ) )+abs( a( 1_${ik}$, 2_${ik}$ ) ),abs( a( 2_${ik}$, 1_${ik}$ ) )+abs( a( 2_${ik}$, 2_${ik}$ ) ) ) - h2 = max( abs( b( 1, 1 ) )+abs( b( 1, 2 ) ),abs( b( 2, 1 ) )+abs( b( 2, 2 ) ) ) + h2 = max( abs( b( 1_${ik}$, 1_${ik}$ ) )+abs( b( 1_${ik}$, 2_${ik}$ ) ),abs( b( 2_${ik}$, 1_${ik}$ ) )+abs( b( 2_${ik}$, 2_${ik}$ ) ) ) if( ( scale1*h1 )>=abs( wr1 )*h2 ) then ! find left rotation matrix q to zero out b(2,1) - call stdlib_${ri}$lartg( b( 1, 1 ), b( 2, 1 ), csl, snl, r ) + call stdlib${ii}$_${ri}$lartg( b( 1_${ik}$, 1_${ik}$ ), b( 2_${ik}$, 1_${ik}$ ), csl, snl, r ) else ! find left rotation matrix q to zero out a(2,1) - call stdlib_${ri}$lartg( a( 1, 1 ), a( 2, 1 ), csl, snl, r ) + call stdlib${ii}$_${ri}$lartg( a( 1_${ik}$, 1_${ik}$ ), a( 2_${ik}$, 1_${ik}$ ), csl, snl, r ) end if - call stdlib_${ri}$rot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl ) - call stdlib_${ri}$rot( 2, b( 1, 1 ), ldb, b( 2, 1 ), ldb, csl, snl ) - a( 2, 1 ) = zero - b( 2, 1 ) = zero + call stdlib${ii}$_${ri}$rot( 2_${ik}$, a( 1_${ik}$, 1_${ik}$ ), lda, a( 2_${ik}$, 1_${ik}$ ), lda, csl, snl ) + call stdlib${ii}$_${ri}$rot( 2_${ik}$, b( 1_${ik}$, 1_${ik}$ ), ldb, b( 2_${ik}$, 1_${ik}$ ), ldb, csl, snl ) + a( 2_${ik}$, 1_${ik}$ ) = zero + b( 2_${ik}$, 1_${ik}$ ) = zero else ! a pair of complex conjugate eigenvalues ! first compute the svd of the matrix b - call stdlib_${ri}$lasv2( b( 1, 1 ), b( 1, 2 ), b( 2, 2 ), r, t, snr,csr, snl, csl ) + call stdlib${ii}$_${ri}$lasv2( b( 1_${ik}$, 1_${ik}$ ), b( 1_${ik}$, 2_${ik}$ ), b( 2_${ik}$, 2_${ik}$ ), r, t, snr,csr, snl, csl ) ! form (a,b) := q(a,b)z**t where q is left rotation matrix and - ! z is right rotation matrix computed from stdlib_${ri}$lasv2 - call stdlib_${ri}$rot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl ) - call stdlib_${ri}$rot( 2, b( 1, 1 ), ldb, b( 2, 1 ), ldb, csl, snl ) - call stdlib_${ri}$rot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr ) - call stdlib_${ri}$rot( 2, b( 1, 1 ), 1, b( 1, 2 ), 1, csr, snr ) - b( 2, 1 ) = zero - b( 1, 2 ) = zero + ! z is right rotation matrix computed from stdlib${ii}$_${ri}$lasv2 + call stdlib${ii}$_${ri}$rot( 2_${ik}$, a( 1_${ik}$, 1_${ik}$ ), lda, a( 2_${ik}$, 1_${ik}$ ), lda, csl, snl ) + call stdlib${ii}$_${ri}$rot( 2_${ik}$, b( 1_${ik}$, 1_${ik}$ ), ldb, b( 2_${ik}$, 1_${ik}$ ), ldb, csl, snl ) + call stdlib${ii}$_${ri}$rot( 2_${ik}$, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, a( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, csr, snr ) + call stdlib${ii}$_${ri}$rot( 2_${ik}$, b( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, b( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, csr, snr ) + b( 2_${ik}$, 1_${ik}$ ) = zero + b( 1_${ik}$, 2_${ik}$ ) = zero end if end if ! unscaling - a( 1, 1 ) = anorm*a( 1, 1 ) - a( 2, 1 ) = anorm*a( 2, 1 ) - a( 1, 2 ) = anorm*a( 1, 2 ) - a( 2, 2 ) = anorm*a( 2, 2 ) - b( 1, 1 ) = bnorm*b( 1, 1 ) - b( 2, 1 ) = bnorm*b( 2, 1 ) - b( 1, 2 ) = bnorm*b( 1, 2 ) - b( 2, 2 ) = bnorm*b( 2, 2 ) + a( 1_${ik}$, 1_${ik}$ ) = anorm*a( 1_${ik}$, 1_${ik}$ ) + a( 2_${ik}$, 1_${ik}$ ) = anorm*a( 2_${ik}$, 1_${ik}$ ) + a( 1_${ik}$, 2_${ik}$ ) = anorm*a( 1_${ik}$, 2_${ik}$ ) + a( 2_${ik}$, 2_${ik}$ ) = anorm*a( 2_${ik}$, 2_${ik}$ ) + b( 1_${ik}$, 1_${ik}$ ) = bnorm*b( 1_${ik}$, 1_${ik}$ ) + b( 2_${ik}$, 1_${ik}$ ) = bnorm*b( 2_${ik}$, 1_${ik}$ ) + b( 1_${ik}$, 2_${ik}$ ) = bnorm*b( 1_${ik}$, 2_${ik}$ ) + b( 2_${ik}$, 2_${ik}$ ) = bnorm*b( 2_${ik}$, 2_${ik}$ ) if( wi==zero ) then - alphar( 1 ) = a( 1, 1 ) - alphar( 2 ) = a( 2, 2 ) - alphai( 1 ) = zero - alphai( 2 ) = zero - beta( 1 ) = b( 1, 1 ) - beta( 2 ) = b( 2, 2 ) - else - alphar( 1 ) = anorm*wr1 / scale1 / bnorm - alphai( 1 ) = anorm*wi / scale1 / bnorm - alphar( 2 ) = alphar( 1 ) - alphai( 2 ) = -alphai( 1 ) - beta( 1 ) = one - beta( 2 ) = one + alphar( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ ) + alphar( 2_${ik}$ ) = a( 2_${ik}$, 2_${ik}$ ) + alphai( 1_${ik}$ ) = zero + alphai( 2_${ik}$ ) = zero + beta( 1_${ik}$ ) = b( 1_${ik}$, 1_${ik}$ ) + beta( 2_${ik}$ ) = b( 2_${ik}$, 2_${ik}$ ) + else + alphar( 1_${ik}$ ) = anorm*wr1 / scale1 / bnorm + alphai( 1_${ik}$ ) = anorm*wi / scale1 / bnorm + alphar( 2_${ik}$ ) = alphar( 1_${ik}$ ) + alphai( 2_${ik}$ ) = -alphai( 1_${ik}$ ) + beta( 1_${ik}$ ) = one + beta( 2_${ik}$ ) = one end if return - end subroutine stdlib_${ri}$lagv2 + end subroutine stdlib${ii}$_${ri}$lagv2 - pure subroutine stdlib_${ri}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, & + pure subroutine stdlib${ii}$_${ri}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, & !! DLAHQR: is an auxiliary routine called by DHSEQR to update the !! eigenvalues and Schur decomposition already computed by DHSEQR, by !! dealing with the Hessenberg submatrix in rows and columns ILO to @@ -29224,8 +29215,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, ihiz, ilo, iloz, ldh, ldz, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ihiz, ilo, iloz, ldh, ldz, n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt, wantz ! Array Arguments real(${rk}$), intent(inout) :: h(ldh,*), z(ldz,*) @@ -29234,20 +29225,20 @@ module stdlib_linalg_lapack_${ri}$ ! Parameters real(${rk}$), parameter :: dat1 = 3.0_${rk}$/4.0_${rk}$ real(${rk}$), parameter :: dat2 = -0.4375_${rk}$ - integer(ilp), parameter :: kexsh = 10 + integer(${ik}$), parameter :: kexsh = 10_${ik}$ ! Local Scalars real(${rk}$) :: aa, ab, ba, bb, cs, det, h11, h12, h21, h21s, h22, rt1i, rt1r, rt2i, rt2r, & rtdisc, s, safmax, safmin, smlnum, sn, sum, t1, t2, t3, tr, tst, ulp, v2, v3 - integer(ilp) :: i, i1, i2, its, itmax, j, k, l, m, nh, nr, nz, kdefl + integer(${ik}$) :: i, i1, i2, its, itmax, j, k, l, m, nh, nr, nz, kdefl ! Local Arrays - real(${rk}$) :: v(3) + real(${rk}$) :: v(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,max,min,sqrt ! Executable Statements - info = 0 + info = 0_${ik}$ ! quick return if possible if( n==0 )return if( ilo==ihi ) then @@ -29261,25 +29252,25 @@ module stdlib_linalg_lapack_${ri}$ h( j+3, j ) = zero end do if( ilo<=ihi-2 )h( ihi, ihi-2 ) = zero - nh = ihi - ilo + 1 - nz = ihiz - iloz + 1 + nh = ihi - ilo + 1_${ik}$ + nz = ihiz - iloz + 1_${ik}$ ! set machine-dependent constants for the stopping criterion. - safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) safmax = one / safmin - call stdlib_${ri}$labad( safmin, safmax ) - ulp = stdlib_${ri}$lamch( 'PRECISION' ) + call stdlib${ii}$_${ri}$labad( safmin, safmax ) + ulp = stdlib${ii}$_${ri}$lamch( 'PRECISION' ) smlnum = safmin*( real( nh,KIND=${rk}$) / ulp ) ! i1 and i2 are the indices of the first row and last column of h ! to which transformations must be applied. if eigenvalues only are ! being computed, i1 and i2 are set inside the main loop. if( wantt ) then - i1 = 1 + i1 = 1_${ik}$ i2 = n end if ! itmax is the total number of qr iterations allowed. - itmax = 30 * max( 10, nh ) + itmax = 30_${ik}$ * max( 10_${ik}$, nh ) ! kdefl counts the number of iterations since a deflation - kdefl = 0 + kdefl = 0_${ik}$ ! the main loop begins here. i is the loop index and decreases from ! ihi to ilo in steps of 1 or 2. each iteration of the loop works ! with the active submatrix in rows and columns l to i. @@ -29322,7 +29313,7 @@ module stdlib_linalg_lapack_${ri}$ end if ! exit from loop if a submatrix of order 1 or 2 has split off. if( l>=i-1 )go to 150 - kdefl = kdefl + 1 + kdefl = kdefl + 1_${ik}$ ! now the active submatrix is in rows and columns l to i. if ! eigenvalues only are being computed, only the active submatrix ! need be transformed. @@ -29330,14 +29321,14 @@ module stdlib_linalg_lapack_${ri}$ i1 = l i2 = i end if - if( mod(kdefl,2*kexsh)==0 ) then + if( mod(kdefl,2_${ik}$*kexsh)==0_${ik}$ ) then ! exceptional shift. s = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) ) h11 = dat1*s + h( i, i ) h12 = dat2*s h21 = s h22 = h11 - else if( mod(kdefl,kexsh)==0 ) then + else if( mod(kdefl,kexsh)==0_${ik}$ ) then ! exceptional shift. s = abs( h( l+1, l ) ) + abs( h( l+2, l+1 ) ) h11 = dat1*s + h( l, l ) @@ -29396,16 +29387,16 @@ module stdlib_linalg_lapack_${ri}$ h21s = h( m+1, m ) s = abs( h( m, m )-rt2r ) + abs( rt2i ) + abs( h21s ) h21s = h( m+1, m ) / s - v( 1 ) = h21s*h( m, m+1 ) + ( h( m, m )-rt1r )*( ( h( m, m )-rt2r ) / s ) - & + v( 1_${ik}$ ) = h21s*h( m, m+1 ) + ( h( m, m )-rt1r )*( ( h( m, m )-rt2r ) / s ) - & rt1i*( rt2i / s ) - v( 2 ) = h21s*( h( m, m )+h( m+1, m+1 )-rt1r-rt2r ) - v( 3 ) = h21s*h( m+2, m+1 ) - s = abs( v( 1 ) ) + abs( v( 2 ) ) + abs( v( 3 ) ) - v( 1 ) = v( 1 ) / s - v( 2 ) = v( 2 ) / s - v( 3 ) = v( 3 ) / s + v( 2_${ik}$ ) = h21s*( h( m, m )+h( m+1, m+1 )-rt1r-rt2r ) + v( 3_${ik}$ ) = h21s*h( m+2, m+1 ) + s = abs( v( 1_${ik}$ ) ) + abs( v( 2_${ik}$ ) ) + abs( v( 3_${ik}$ ) ) + v( 1_${ik}$ ) = v( 1_${ik}$ ) / s + v( 2_${ik}$ ) = v( 2_${ik}$ ) / s + v( 3_${ik}$ ) = v( 3_${ik}$ ) / s if( m==l )go to 60 - if( abs( h( m, m-1 ) )*( abs( v( 2 ) )+abs( v( 3 ) ) )<=ulp*abs( v( 1 ) )*( abs( & + if( abs( h( m, m-1 ) )*( abs( v( 2_${ik}$ ) )+abs( v( 3_${ik}$ ) ) )<=ulp*abs( v( 1_${ik}$ ) )*( abs( & h( m-1, m-1 ) )+abs( h( m,m ) )+abs( h( m+1, m+1 ) ) ) )go to 60 end do 60 continue @@ -29418,11 +29409,11 @@ module stdlib_linalg_lapack_${ri}$ ! restore the hessenberg form in the (k-1)th column, and thus ! chases the bulge one step toward the bottom of the active ! submatrix. nr is the order of g. - nr = min( 3, i-k+1 ) - if( k>m )call stdlib_${ri}$copy( nr, h( k, k-1 ), 1, v, 1 ) - call stdlib_${ri}$larfg( nr, v( 1 ), v( 2 ), 1, t1 ) + nr = min( 3_${ik}$, i-k+1 ) + if( k>m )call stdlib${ii}$_${ri}$copy( nr, h( k, k-1 ), 1_${ik}$, v, 1_${ik}$ ) + call stdlib${ii}$_${ri}$larfg( nr, v( 1_${ik}$ ), v( 2_${ik}$ ), 1_${ik}$, t1 ) if( k>m ) then - h( k, k-1 ) = v( 1 ) + h( k, k-1 ) = v( 1_${ik}$ ) h( k+1, k-1 ) = zero if( kl ) then @@ -29432,10 +29423,10 @@ module stdlib_linalg_lapack_${ri}$ ! . underflow. ==== h( k, k-1 ) = h( k, k-1 )*( one-t1 ) end if - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = t1*v2 - if( nr==3 ) then - v3 = v( 3 ) + if( nr==3_${ik}$ ) then + v3 = v( 3_${ik}$ ) t3 = t1*v3 ! apply g from the left to transform the rows of the matrix ! in columns k to i2. @@ -29462,7 +29453,7 @@ module stdlib_linalg_lapack_${ri}$ z( j, k+2 ) = z( j, k+2 ) - sum*t3 end do end if - else if( nr==2 ) then + else if( nr==2_${ik}$ ) then ! apply g from the left to transform the rows of the matrix ! in columns k to i2. do j = k, i2 @@ -29500,30 +29491,30 @@ module stdlib_linalg_lapack_${ri}$ ! h(i-1,i-2) is negligible: a pair of eigenvalues have converged. ! transform the 2-by-2 submatrix to standard schur form, ! and compute and store the eigenvalues. - call stdlib_${ri}$lanv2( h( i-1, i-1 ), h( i-1, i ), h( i, i-1 ),h( i, i ), wr( i-1 ), & + call stdlib${ii}$_${ri}$lanv2( h( i-1, i-1 ), h( i-1, i ), h( i, i-1 ),h( i, i ), wr( i-1 ), & wi( i-1 ), wr( i ), wi( i ),cs, sn ) if( wantt ) then ! apply the transformation to the rest of h. - if( i2>i )call stdlib_${ri}$rot( i2-i, h( i-1, i+1 ), ldh, h( i, i+1 ), ldh,cs, sn ) + if( i2>i )call stdlib${ii}$_${ri}$rot( i2-i, h( i-1, i+1 ), ldh, h( i, i+1 ), ldh,cs, sn ) - call stdlib_${ri}$rot( i-i1-1, h( i1, i-1 ), 1, h( i1, i ), 1, cs, sn ) + call stdlib${ii}$_${ri}$rot( i-i1-1, h( i1, i-1 ), 1_${ik}$, h( i1, i ), 1_${ik}$, cs, sn ) end if if( wantz ) then ! apply the transformation to z. - call stdlib_${ri}$rot( nz, z( iloz, i-1 ), 1, z( iloz, i ), 1, cs, sn ) + call stdlib${ii}$_${ri}$rot( nz, z( iloz, i-1 ), 1_${ik}$, z( iloz, i ), 1_${ik}$, cs, sn ) end if end if ! reset deflation counter - kdefl = 0 + kdefl = 0_${ik}$ ! return to start of the main loop with new value of i. - i = l - 1 + i = l - 1_${ik}$ go to 20 160 continue return - end subroutine stdlib_${ri}$lahqr + end subroutine stdlib${ii}$_${ri}$lahqr - pure subroutine stdlib_${ri}$lahr2( n, k, nb, a, lda, tau, t, ldt, y, ldy ) + pure subroutine stdlib${ii}$_${ri}$lahr2( n, k, nb, a, lda, tau, t, ldt, y, ldy ) !! DLAHR2: reduces the first NB columns of A real general n-BY-(n-k+1) !! matrix A so that elements below the k-th subdiagonal are zero. The !! reduction is performed by an orthogonal similarity transformation @@ -29534,14 +29525,14 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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) :: k, lda, ldt, ldy, n, nb + integer(${ik}$), intent(in) :: k, lda, ldt, ldy, n, nb ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: t(ldt,nb), tau(nb), y(ldy,nb) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i real(${rk}$) :: ei ! Intrinsic Functions intrinsic :: min @@ -29549,69 +29540,69 @@ module stdlib_linalg_lapack_${ri}$ ! quick return if possible if( n<=1 )return loop_10: do i = 1, nb - if( i>1 ) then + if( i>1_${ik}$ ) then ! update a(k+1:n,i) ! update i-th column of a - y * v**t - call stdlib_${ri}$gemv( 'NO TRANSPOSE', n-k, i-1, -one, y(k+1,1), ldy,a( k+i-1, 1 ), & - lda, one, a( k+1, i ), 1 ) + call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', n-k, i-1, -one, y(k+1,1_${ik}$), ldy,a( k+i-1, 1_${ik}$ ), & + lda, one, a( k+1, i ), 1_${ik}$ ) ! apply i - v * t**t * v**t to this column (call it b) from the ! left, using the last column of t as workspace ! let v = ( v1 ) and b = ( b1 ) (first i-1 rows) ! ( v2 ) ( b2 ) ! where v1 is unit lower triangular ! w := v1**t * b1 - call stdlib_${ri}$copy( i-1, a( k+1, i ), 1, t( 1, nb ), 1 ) - call stdlib_${ri}$trmv( 'LOWER', 'TRANSPOSE', 'UNIT',i-1, a( k+1, 1 ),lda, t( 1, nb ),& - 1 ) + call stdlib${ii}$_${ri}$copy( i-1, a( k+1, i ), 1_${ik}$, t( 1_${ik}$, nb ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$trmv( 'LOWER', 'TRANSPOSE', 'UNIT',i-1, a( k+1, 1_${ik}$ ),lda, t( 1_${ik}$, nb ),& + 1_${ik}$ ) ! w := w + v2**t * b2 - call stdlib_${ri}$gemv( 'TRANSPOSE', n-k-i+1, i-1,one, a( k+i, 1 ),lda, a( k+i, i ), & - 1, one, t( 1, nb ), 1 ) + call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', n-k-i+1, i-1,one, a( k+i, 1_${ik}$ ),lda, a( k+i, i ), & + 1_${ik}$, one, t( 1_${ik}$, nb ), 1_${ik}$ ) ! w := t**t * w - call stdlib_${ri}$trmv( 'UPPER', 'TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1, nb ), 1 ) + call stdlib${ii}$_${ri}$trmv( 'UPPER', 'TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1_${ik}$, nb ), 1_${ik}$ ) ! b2 := b2 - v2*w - call stdlib_${ri}$gemv( 'NO TRANSPOSE', n-k-i+1, i-1, -one,a( k+i, 1 ),lda, t( 1, nb )& - , 1, one, a( k+i, i ), 1 ) + call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', n-k-i+1, i-1, -one,a( k+i, 1_${ik}$ ),lda, t( 1_${ik}$, nb )& + , 1_${ik}$, one, a( k+i, i ), 1_${ik}$ ) ! b1 := b1 - v1*w - call stdlib_${ri}$trmv( 'LOWER', 'NO TRANSPOSE','UNIT', i-1,a( k+1, 1 ), lda, t( 1, & - nb ), 1 ) - call stdlib_${ri}$axpy( i-1, -one, t( 1, nb ), 1, a( k+1, i ), 1 ) + call stdlib${ii}$_${ri}$trmv( 'LOWER', 'NO TRANSPOSE','UNIT', i-1,a( k+1, 1_${ik}$ ), lda, t( 1_${ik}$, & + nb ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( i-1, -one, t( 1_${ik}$, nb ), 1_${ik}$, a( k+1, i ), 1_${ik}$ ) a( k+i-1, i-1 ) = ei end if ! generate the elementary reflector h(i) to annihilate ! a(k+i+1:n,i) - call stdlib_${ri}$larfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1,tau( i ) ) + call stdlib${ii}$_${ri}$larfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1_${ik}$,tau( i ) ) ei = a( k+i, i ) a( k+i, i ) = one ! compute y(k+1:n,i) - call stdlib_${ri}$gemv( 'NO TRANSPOSE', n-k, n-k-i+1,one, a( k+1, i+1 ),lda, a( k+i, i ),& - 1, zero, y( k+1, i ), 1 ) - call stdlib_${ri}$gemv( 'TRANSPOSE', n-k-i+1, i-1,one, a( k+i, 1 ), lda,a( k+i, i ), 1, & - zero, t( 1, i ), 1 ) - call stdlib_${ri}$gemv( 'NO TRANSPOSE', n-k, i-1, -one,y( k+1, 1 ), ldy,t( 1, i ), 1, & - one, y( k+1, i ), 1 ) - call stdlib_${ri}$scal( n-k, tau( i ), y( k+1, i ), 1 ) + call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', n-k, n-k-i+1,one, a( k+1, i+1 ),lda, a( k+i, i ),& + 1_${ik}$, zero, y( k+1, i ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', n-k-i+1, i-1,one, a( k+i, 1_${ik}$ ), lda,a( k+i, i ), 1_${ik}$, & + zero, t( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', n-k, i-1, -one,y( k+1, 1_${ik}$ ), ldy,t( 1_${ik}$, i ), 1_${ik}$, & + one, y( k+1, i ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n-k, tau( i ), y( k+1, i ), 1_${ik}$ ) ! compute t(1:i,i) - call stdlib_${ri}$scal( i-1, -tau( i ), t( 1, i ), 1 ) - call stdlib_${ri}$trmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1, i ), 1 ) + call stdlib${ii}$_${ri}$scal( i-1, -tau( i ), t( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$trmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1_${ik}$, i ), 1_${ik}$ ) t( i, i ) = tau( i ) end do loop_10 a( k+nb, nb ) = ei ! compute y(1:k,1:nb) - call stdlib_${ri}$lacpy( 'ALL', k, nb, a( 1, 2 ), lda, y, ldy ) - call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE','UNIT', k, nb,one, a( k+1, 1 ), & + call stdlib${ii}$_${ri}$lacpy( 'ALL', k, nb, a( 1_${ik}$, 2_${ik}$ ), lda, y, ldy ) + call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE','UNIT', k, nb,one, a( k+1, 1_${ik}$ ), & lda, y, ldy ) - if( n>k+nb )call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,nb, n-k-nb, one,a( 1, & - 2+nb ), lda, a( k+1+nb, 1 ), lda, one, y,ldy ) - call stdlib_${ri}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE','NON-UNIT', k, nb,one, t, ldt, y, & + if( n>k+nb )call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,nb, n-k-nb, one,a( 1_${ik}$, & + 2_${ik}$+nb ), lda, a( k+1+nb, 1_${ik}$ ), lda, one, y,ldy ) + call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE','NON-UNIT', k, nb,one, t, ldt, y, & ldy ) return - end subroutine stdlib_${ri}$lahr2 + end subroutine stdlib${ii}$_${ri}$lahr2 - pure subroutine stdlib_${ri}$laic1( job, j, x, sest, w, gamma, sestpr, s, c ) + pure subroutine stdlib${ii}$_${ri}$laic1( job, j, x, sest, w, gamma, sestpr, s, c ) !! DLAIC1: applies one step of incremental condition estimation in !! its simplest version: !! Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j @@ -29636,7 +29627,7 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(out) :: c, s, sestpr real(${rk}$), intent(in) :: gamma, sest ! Array Arguments @@ -29650,12 +29641,12 @@ module stdlib_linalg_lapack_${ri}$ ! Intrinsic Functions intrinsic :: abs,max,sign,sqrt ! Executable Statements - eps = stdlib_${ri}$lamch( 'EPSILON' ) - alpha = stdlib_${ri}$dot( j, x, 1, w, 1 ) + eps = stdlib${ii}$_${ri}$lamch( 'EPSILON' ) + alpha = stdlib${ii}$_${ri}$dot( 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 @@ -29730,7 +29721,7 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -29820,10 +29811,10 @@ module stdlib_linalg_lapack_${ri}$ end if end if return - end subroutine stdlib_${ri}$laic1 + end subroutine stdlib${ii}$_${ri}$laic1 - pure logical(lk) function stdlib_${ri}$laisnan( din1, din2 ) + pure logical(lk) function stdlib${ii}$_${ri}$laisnan( din1, din2 ) !! This routine is not for general use. It exists solely to avoid !! over-optimization in DISNAN. !! DLAISNAN: checks for NaNs by comparing its two arguments for @@ -29842,12 +29833,12 @@ module stdlib_linalg_lapack_${ri}$ real(${rk}$), intent(in) :: din1, din2 ! ===================================================================== ! Executable Statements - stdlib_${ri}$laisnan = (din1/=din2) + stdlib${ii}$_${ri}$laisnan = (din1/=din2) return - end function stdlib_${ri}$laisnan + end function stdlib${ii}$_${ri}$laisnan - pure subroutine stdlib_${ri}$laln2( ltrans, na, nw, smin, ca, a, lda, d1, d2, b,ldb, wr, wi, x, & + pure subroutine stdlib${ii}$_${ri}$laln2( ltrans, na, nw, smin, ca, a, lda, d1, d2, b,ldb, wr, wi, x, & !! DLALN2: solves a system of the form (ca A - w D ) X = s B !! or (ca A**T - w D) X = s B with possible scaling ("s") and !! perturbation of A. (A**T means A-transpose.) @@ -29879,8 +29870,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: ltrans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldb, ldx, na, nw + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldx, na, nw real(${rk}$), intent(in) :: ca, d1, d2, smin, wi, wr real(${rk}$), intent(out) :: scale, xnorm ! Array Arguments @@ -29890,56 +29881,56 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars - integer(ilp) :: icmax, j + integer(${ik}$) :: icmax, j real(${rk}$) :: bbnd, bi1, bi2, bignum, bnorm, br1, br2, ci21, ci22, cmax, cnorm, cr21, & cr22, csi, csr, li21, lr21, smini, smlnum, temp, u22abs, ui11, ui11r, ui12, ui12s, & ui22, ur11, ur11r, ur12, ur12s, ur22, xi1, xi2, xr1, xr2 ! Local Arrays - logical(lk) :: rswap(4), zswap(4) - integer(ilp) :: ipivot(4,4) - real(${rk}$) :: ci(2,2), civ(4), cr(2,2), crv(4) + logical(lk) :: rswap(4_${ik}$), zswap(4_${ik}$) + integer(${ik}$) :: ipivot(4_${ik}$,4_${ik}$) + real(${rk}$) :: ci(2_${ik}$,2_${ik}$), civ(4_${ik}$), cr(2_${ik}$,2_${ik}$), crv(4_${ik}$) ! Intrinsic Functions intrinsic :: abs,max ! Equivalences - equivalence ( ci( 1, 1 ), civ( 1 ) ),( cr( 1, 1 ), crv( 1 ) ) + equivalence ( ci( 1_${ik}$, 1_${ik}$ ), civ( 1_${ik}$ ) ),( cr( 1_${ik}$, 1_${ik}$ ), crv( 1_${ik}$ ) ) ! Data Statements zswap = [.false.,.false.,.true.,.true.] rswap = [.false.,.true.,.false.,.true.] - ipivot = reshape([1,2,3,4,2,1,4,3,3,4,1,2,4,3,2,1],[4,4]) + ipivot = reshape([1_${ik}$,2_${ik}$,3_${ik}$,4_${ik}$,2_${ik}$,1_${ik}$,4_${ik}$,3_${ik}$,3_${ik}$,4_${ik}$,1_${ik}$,2_${ik}$,4_${ik}$,3_${ik}$,2_${ik}$,1_${ik}$],[4_${ik}$,4_${ik}$]) ! Executable Statements ! compute bignum - smlnum = two*stdlib_${ri}$lamch( 'SAFE MINIMUM' ) + smlnum = two*stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) bignum = one / smlnum smini = max( smin, smlnum ) ! don't check for input errors - info = 0 + info = 0_${ik}$ ! standard initializations scale = one - if( na==1 ) then + if( na==1_${ik}$ ) then ! 1 x 1 (i.e., scalar) system c x = b - if( nw==1 ) then + if( nw==1_${ik}$ ) then ! real 1x1 system. ! c = ca a - w d - csr = ca*a( 1, 1 ) - wr*d1 + csr = ca*a( 1_${ik}$, 1_${ik}$ ) - wr*d1 cnorm = abs( csr ) ! if | c | < smini, use c = smini if( cnormone ) then if( bnorm>bignum*cnorm )scale = one / bnorm end if ! compute x - x( 1, 1 ) = ( b( 1, 1 )*scale ) / csr - xnorm = abs( x( 1, 1 ) ) + x( 1_${ik}$, 1_${ik}$ ) = ( b( 1_${ik}$, 1_${ik}$ )*scale ) / csr + xnorm = abs( x( 1_${ik}$, 1_${ik}$ ) ) else ! complex 1x1 system (w is complex) ! c = ca a - w d - csr = ca*a( 1, 1 ) - wr*d1 + csr = ca*a( 1_${ik}$, 1_${ik}$ ) - wr*d1 csi = -wi*d1 cnorm = abs( csr ) + abs( csi ) ! if | c | < smini, use c = smini @@ -29947,35 +29938,35 @@ module stdlib_linalg_lapack_${ri}$ csr = smini csi = zero cnorm = smini - info = 1 + info = 1_${ik}$ end if ! check scaling for x = b / c - bnorm = abs( b( 1, 1 ) ) + abs( b( 1, 2 ) ) + bnorm = abs( b( 1_${ik}$, 1_${ik}$ ) ) + abs( b( 1_${ik}$, 2_${ik}$ ) ) if( cnormone ) then if( bnorm>bignum*cnorm )scale = one / bnorm end if ! compute x - call stdlib_${ri}$ladiv( scale*b( 1, 1 ), scale*b( 1, 2 ), csr, csi,x( 1, 1 ), x( 1, & - 2 ) ) - xnorm = abs( x( 1, 1 ) ) + abs( x( 1, 2 ) ) + call stdlib${ii}$_${ri}$ladiv( scale*b( 1_${ik}$, 1_${ik}$ ), scale*b( 1_${ik}$, 2_${ik}$ ), csr, csi,x( 1_${ik}$, 1_${ik}$ ), x( 1_${ik}$, & + 2_${ik}$ ) ) + xnorm = abs( x( 1_${ik}$, 1_${ik}$ ) ) + abs( x( 1_${ik}$, 2_${ik}$ ) ) end if else ! 2x2 system ! compute the realpart of c = ca a - w d (or ca a**t - w d,KIND=${rk}$) - cr( 1, 1 ) = ca*a( 1, 1 ) - wr*d1 - cr( 2, 2 ) = ca*a( 2, 2 ) - wr*d2 + cr( 1_${ik}$, 1_${ik}$ ) = ca*a( 1_${ik}$, 1_${ik}$ ) - wr*d1 + cr( 2_${ik}$, 2_${ik}$ ) = ca*a( 2_${ik}$, 2_${ik}$ ) - wr*d2 if( ltrans ) then - cr( 1, 2 ) = ca*a( 2, 1 ) - cr( 2, 1 ) = ca*a( 1, 2 ) + cr( 1_${ik}$, 2_${ik}$ ) = ca*a( 2_${ik}$, 1_${ik}$ ) + cr( 2_${ik}$, 1_${ik}$ ) = ca*a( 1_${ik}$, 2_${ik}$ ) else - cr( 2, 1 ) = ca*a( 2, 1 ) - cr( 1, 2 ) = ca*a( 1, 2 ) + cr( 2_${ik}$, 1_${ik}$ ) = ca*a( 2_${ik}$, 1_${ik}$ ) + cr( 1_${ik}$, 2_${ik}$ ) = ca*a( 1_${ik}$, 2_${ik}$ ) end if - if( nw==1 ) then + if( nw==1_${ik}$ ) then ! real2x2 system (w is real,KIND=${rk}$) ! find the largest element in c cmax = zero - icmax = 0 + icmax = 0_${ik}$ do j = 1, 4 if( abs( crv( j ) )>cmax ) then cmax = abs( crv( j ) ) @@ -29984,36 +29975,36 @@ module stdlib_linalg_lapack_${ri}$ end do ! if norm(c) < smini, use smini*identity. if( cmaxone ) then if( bnorm>bignum*smini )scale = one / bnorm end if temp = scale / smini - x( 1, 1 ) = temp*b( 1, 1 ) - x( 2, 1 ) = temp*b( 2, 1 ) + x( 1_${ik}$, 1_${ik}$ ) = temp*b( 1_${ik}$, 1_${ik}$ ) + x( 2_${ik}$, 1_${ik}$ ) = temp*b( 2_${ik}$, 1_${ik}$ ) xnorm = temp*bnorm - info = 1 + info = 1_${ik}$ return end if ! gaussian elimination with complete pivoting. ur11 = crv( icmax ) - cr21 = crv( ipivot( 2, icmax ) ) - ur12 = crv( ipivot( 3, icmax ) ) - cr22 = crv( ipivot( 4, icmax ) ) + cr21 = crv( ipivot( 2_${ik}$, icmax ) ) + ur12 = crv( ipivot( 3_${ik}$, icmax ) ) + cr22 = crv( ipivot( 4_${ik}$, icmax ) ) ur11r = one / ur11 lr21 = ur11r*cr21 ur22 = cr22 - ur12*lr21 ! if smaller pivot < smini, use smini if( abs( ur22 ) overflow if( xnorm>one .and. cmax>one ) then if( xnorm>bignum / cmax ) then temp = cmax / bignum - x( 1, 1 ) = temp*x( 1, 1 ) - x( 2, 1 ) = temp*x( 2, 1 ) + x( 1_${ik}$, 1_${ik}$ ) = temp*x( 1_${ik}$, 1_${ik}$ ) + x( 2_${ik}$, 1_${ik}$ ) = temp*x( 2_${ik}$, 1_${ik}$ ) xnorm = temp*xnorm scale = temp*scale end if @@ -30043,12 +30034,12 @@ module stdlib_linalg_lapack_${ri}$ else ! complex 2x2 system (w is complex) ! find the largest element in c - ci( 1, 1 ) = -wi*d1 - ci( 2, 1 ) = zero - ci( 1, 2 ) = zero - ci( 2, 2 ) = -wi*d2 + ci( 1_${ik}$, 1_${ik}$ ) = -wi*d1 + ci( 2_${ik}$, 1_${ik}$ ) = zero + ci( 1_${ik}$, 2_${ik}$ ) = zero + ci( 2_${ik}$, 2_${ik}$ ) = -wi*d2 cmax = zero - icmax = 0 + icmax = 0_${ik}$ do j = 1, 4 if( abs( crv( j ) )+abs( civ( j ) )>cmax ) then cmax = abs( crv( j ) ) + abs( civ( j ) ) @@ -30057,38 +30048,38 @@ module stdlib_linalg_lapack_${ri}$ end do ! if norm(c) < smini, use smini*identity. if( cmaxone ) then if( bnorm>bignum*smini )scale = one / bnorm end if temp = scale / smini - x( 1, 1 ) = temp*b( 1, 1 ) - x( 2, 1 ) = temp*b( 2, 1 ) - x( 1, 2 ) = temp*b( 1, 2 ) - x( 2, 2 ) = temp*b( 2, 2 ) + x( 1_${ik}$, 1_${ik}$ ) = temp*b( 1_${ik}$, 1_${ik}$ ) + x( 2_${ik}$, 1_${ik}$ ) = temp*b( 2_${ik}$, 1_${ik}$ ) + x( 1_${ik}$, 2_${ik}$ ) = temp*b( 1_${ik}$, 2_${ik}$ ) + x( 2_${ik}$, 2_${ik}$ ) = temp*b( 2_${ik}$, 2_${ik}$ ) xnorm = temp*bnorm - info = 1 + info = 1_${ik}$ return end if ! gaussian elimination with complete pivoting. ur11 = crv( icmax ) ui11 = civ( icmax ) - cr21 = crv( ipivot( 2, icmax ) ) - ci21 = civ( ipivot( 2, icmax ) ) - ur12 = crv( ipivot( 3, icmax ) ) - ui12 = civ( ipivot( 3, icmax ) ) - cr22 = crv( ipivot( 4, icmax ) ) - ci22 = civ( ipivot( 4, icmax ) ) - if( icmax==1 .or. icmax==4 ) then + cr21 = crv( ipivot( 2_${ik}$, icmax ) ) + ci21 = civ( ipivot( 2_${ik}$, icmax ) ) + ur12 = crv( ipivot( 3_${ik}$, icmax ) ) + ui12 = civ( ipivot( 3_${ik}$, icmax ) ) + cr22 = crv( ipivot( 4_${ik}$, icmax ) ) + ci22 = civ( ipivot( 4_${ik}$, icmax ) ) + if( icmax==1_${ik}$ .or. icmax==4_${ik}$ ) then ! code when off-diagonals of pivoted c are real if( abs( ur11 )>abs( ui11 ) ) then temp = ui11 / ur11 - ur11r = one / ( ur11*( one+temp**2 ) ) + ur11r = one / ( ur11*( one+temp**2_${ik}$ ) ) ui11r = -temp*ur11r else temp = ur11 / ui11 - ui11r = -one / ( ui11*( one+temp**2 ) ) + ui11r = -one / ( ui11*( one+temp**2_${ik}$ ) ) ur11r = -temp*ui11r end if lr21 = cr21*ur11r @@ -30113,18 +30104,18 @@ module stdlib_linalg_lapack_${ri}$ if( u22abs overflow if( xnorm>one .and. cmax>one ) then if( xnorm>bignum / cmax ) then temp = cmax / bignum - x( 1, 1 ) = temp*x( 1, 1 ) - x( 2, 1 ) = temp*x( 2, 1 ) - x( 1, 2 ) = temp*x( 1, 2 ) - x( 2, 2 ) = temp*x( 2, 2 ) + x( 1_${ik}$, 1_${ik}$ ) = temp*x( 1_${ik}$, 1_${ik}$ ) + x( 2_${ik}$, 1_${ik}$ ) = temp*x( 2_${ik}$, 1_${ik}$ ) + x( 1_${ik}$, 2_${ik}$ ) = temp*x( 1_${ik}$, 2_${ik}$ ) + x( 2_${ik}$, 2_${ik}$ ) = temp*x( 2_${ik}$, 2_${ik}$ ) xnorm = temp*xnorm scale = temp*scale end if @@ -30169,10 +30160,10 @@ module stdlib_linalg_lapack_${ri}$ end if end if return - end subroutine stdlib_${ri}$laln2 + end subroutine stdlib${ii}$_${ri}$laln2 - pure subroutine stdlib_${ri}$lals0( icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx,perm, givptr, & + pure subroutine stdlib${ii}$_${ri}$lals0( icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx,perm, givptr, & !! DLALS0: applies back the multiplying factors of either the left or the !! right singular vector matrix of a diagonal matrix appended by a row !! to the right hand side matrix B in solving the least squares problem @@ -30198,12 +30189,12 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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) :: givptr, icompq, k, ldb, ldbx, ldgcol, ldgnum, nl, nr, nrhs,& + integer(${ik}$), intent(in) :: givptr, icompq, k, ldb, ldbx, ldgcol, ldgnum, nl, nr, nrhs,& sqre - integer(ilp), intent(out) :: info + integer(${ik}$), intent(out) :: info real(${rk}$), intent(in) :: c, s ! Array Arguments - integer(ilp), intent(in) :: givcol(ldgcol,*), perm(*) + integer(${ik}$), intent(in) :: givcol(ldgcol,*), perm(*) real(${rk}$), intent(inout) :: b(ldb,*) real(${rk}$), intent(out) :: bx(ldbx,*), work(*) real(${rk}$), intent(in) :: difl(*), difr(ldgnum,*), givnum(ldgnum,*), poles(ldgnum,*), z(& @@ -30211,165 +30202,165 @@ module stdlib_linalg_lapack_${ri}$ ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, m, n, nlp1 + integer(${ik}$) :: i, j, m, n, nlp1 real(${rk}$) :: diflj, difrj, dj, dsigj, dsigjp, temp ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 - n = nl + nr + 1 - 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 - else if( nrhs<1 ) then - info = -5 + info = 0_${ik}$ + n = nl + nr + 1_${ik}$ + 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( nrhs<1_${ik}$ ) then + info = -5_${ik}$ else if( ldb1 ) ) then - info = -1 - else if( smlsiz<3 ) then - info = -2 + info = 0_${ik}$ + if( ( icompq<0_${ik}$ ) .or. ( icompq>1_${ik}$ ) ) then + info = -1_${ik}$ + else if( smlsiz<3_${ik}$ ) then + info = -2_${ik}$ else if( n=one ) ) then rcnd = eps else rcnd = rcond end if - rank = 0 + rank = 0_${ik}$ ! quick return if possible. - if( n==0 ) then + if( n==0_${ik}$ ) then return - else if( n==1 ) then - if( d( 1 )==zero ) then - call stdlib_${ri}$laset( 'A', 1, nrhs, zero, zero, b, ldb ) + else if( n==1_${ik}$ ) then + if( d( 1_${ik}$ )==zero ) then + call stdlib${ii}$_${ri}$laset( 'A', 1_${ik}$, nrhs, zero, zero, b, ldb ) else - rank = 1 - call stdlib_${ri}$lascl( 'G', 0, 0, d( 1 ), one, 1, nrhs, b, ldb, info ) - d( 1 ) = abs( d( 1 ) ) + rank = 1_${ik}$ + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, d( 1_${ik}$ ), one, 1_${ik}$, nrhs, b, ldb, info ) + d( 1_${ik}$ ) = abs( d( 1_${ik}$ ) ) end if return end if ! rotate the matrix if it is lower bidiagonal. if( uplo=='L' ) then do i = 1, n - 1 - call stdlib_${ri}$lartg( d( i ), e( i ), cs, sn, r ) + call stdlib${ii}$_${ri}$lartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) - if( nrhs==1 ) then - call stdlib_${ri}$rot( 1, b( i, 1 ), 1, b( i+1, 1 ), 1, cs, sn ) + if( nrhs==1_${ik}$ ) then + call stdlib${ii}$_${ri}$rot( 1_${ik}$, b( i, 1_${ik}$ ), 1_${ik}$, b( i+1, 1_${ik}$ ), 1_${ik}$, cs, sn ) else - work( i*2-1 ) = cs - work( i*2 ) = sn + work( i*2_${ik}$-1 ) = cs + work( i*2_${ik}$ ) = sn end if end do - if( nrhs>1 ) then + if( nrhs>1_${ik}$ ) then do i = 1, nrhs do j = 1, n - 1 - cs = work( j*2-1 ) - sn = work( j*2 ) - call stdlib_${ri}$rot( 1, b( j, i ), 1, b( j+1, i ), 1, cs, sn ) + cs = work( j*2_${ik}$-1 ) + sn = work( j*2_${ik}$ ) + call stdlib${ii}$_${ri}$rot( 1_${ik}$, b( j, i ), 1_${ik}$, b( j+1, i ), 1_${ik}$, cs, sn ) end do end do end if end if ! scale. - nm1 = n - 1 - orgnrm = stdlib_${ri}$lanst( 'M', n, d, e ) + nm1 = n - 1_${ik}$ + orgnrm = stdlib${ii}$_${ri}$lanst( 'M', n, d, e ) if( orgnrm==zero ) then - call stdlib_${ri}$laset( 'A', n, nrhs, zero, zero, b, ldb ) + call stdlib${ii}$_${ri}$laset( 'A', n, nrhs, zero, zero, b, ldb ) return end if - call stdlib_${ri}$lascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info ) - call stdlib_${ri}$lascl( 'G', 0, 0, orgnrm, one, nm1, 1, e, nm1, info ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, n, 1_${ik}$, d, n, info ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, nm1, 1_${ik}$, e, nm1, info ) ! if n is smaller than the minimum divide size smlsiz, then solve ! the problem with another solver. if( n<=smlsiz ) then - nwork = 1 + n*n - call stdlib_${ri}$laset( 'A', n, n, zero, one, work, n ) - call stdlib_${ri}$lasdq( 'U', 0, n, n, 0, nrhs, d, e, work, n, work, n, b,ldb, work( & + nwork = 1_${ik}$ + n*n + call stdlib${ii}$_${ri}$laset( 'A', n, n, zero, one, work, n ) + call stdlib${ii}$_${ri}$lasdq( 'U', 0_${ik}$, n, n, 0_${ik}$, nrhs, d, e, work, n, work, n, b,ldb, work( & nwork ), info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if - tol = rcnd*abs( d( stdlib_i${ri}$amax( n, d, 1 ) ) ) + tol = rcnd*abs( d( stdlib${ii}$_i${ri}$amax( n, d, 1_${ik}$ ) ) ) do i = 1, n if( d( i )<=tol ) then - call stdlib_${ri}$laset( 'A', 1, nrhs, zero, zero, b( i, 1 ), ldb ) + call stdlib${ii}$_${ri}$laset( 'A', 1_${ik}$, nrhs, zero, zero, b( i, 1_${ik}$ ), ldb ) else - call stdlib_${ri}$lascl( 'G', 0, 0, d( i ), one, 1, nrhs, b( i, 1 ),ldb, info ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, d( i ), one, 1_${ik}$, nrhs, b( i, 1_${ik}$ ),ldb, info ) - rank = rank + 1 + rank = rank + 1_${ik}$ end if end do - call stdlib_${ri}$gemm( 'T', 'N', n, nrhs, n, one, work, n, b, ldb, zero,work( nwork ), & + call stdlib${ii}$_${ri}$gemm( 'T', 'N', n, nrhs, n, one, work, n, b, ldb, zero,work( nwork ), & n ) - call stdlib_${ri}$lacpy( 'A', n, nrhs, work( nwork ), n, b, ldb ) + call stdlib${ii}$_${ri}$lacpy( 'A', n, nrhs, work( nwork ), n, b, ldb ) ! unscale. - call stdlib_${ri}$lascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) - call stdlib_${ri}$lasrt( 'D', n, d, info ) - call stdlib_${ri}$lascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, n, 1_${ik}$, d, n, info ) + call stdlib${ii}$_${ri}$lasrt( 'D', n, d, info ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, n, nrhs, b, ldb, info ) return end if ! book-keeping and setting up some constants. - nlvl = int( log( real( n,KIND=${rk}$) / real( smlsiz+1,KIND=${rk}$) ) / log( two ),KIND=ilp) + & - 1 - smlszp = smlsiz + 1 - u = 1 - vt = 1 + smlsiz*n + nlvl = int( log( real( n,KIND=${rk}$) / real( smlsiz+1,KIND=${rk}$) ) / log( two ),KIND=${ik}$) + & + 1_${ik}$ + smlszp = smlsiz + 1_${ik}$ + u = 1_${ik}$ + vt = 1_${ik}$ + smlsiz*n difl = vt + smlszp*n difr = difl + nlvl*n - z = difr + nlvl*n*2 + z = difr + nlvl*n*2_${ik}$ c = z + nlvl*n s = c + n poles = s + n - givnum = poles + 2*nlvl*n - bx = givnum + 2*nlvl*n + givnum = poles + 2_${ik}$*nlvl*n + bx = givnum + 2_${ik}$*nlvl*n nwork = bx + n*nrhs - sizei = 1 + n + sizei = 1_${ik}$ + n k = sizei + n givptr = k + n perm = givptr + n givcol = perm + nlvl*n - iwk = givcol + nlvl*n*2 - st = 1 - sqre = 0 - icmpq1 = 1 - icmpq2 = 0 - nsub = 0 + iwk = givcol + nlvl*n*2_${ik}$ + st = 1_${ik}$ + sqre = 0_${ik}$ + icmpq1 = 1_${ik}$ + icmpq2 = 0_${ik}$ + nsub = 0_${ik}$ do i = 1, n if( abs( d( i ) )=eps ) then ! a subproblem with e(nm1) not too small but i = nm1. - nsize = n - st + 1 + nsize = n - st + 1_${ik}$ iwork( sizei+nsub-1 ) = nsize else ! a subproblem with e(nm1) small. this implies an ! 1-by-1 subproblem at d(n), which is not solved ! explicitly. - nsize = i - st + 1 + nsize = i - st + 1_${ik}$ iwork( sizei+nsub-1 ) = nsize - nsub = nsub + 1 + nsub = nsub + 1_${ik}$ iwork( nsub ) = n - iwork( sizei+nsub-1 ) = 1 - call stdlib_${ri}$copy( nrhs, b( n, 1 ), ldb, work( bx+nm1 ), n ) + iwork( sizei+nsub-1 ) = 1_${ik}$ + call stdlib${ii}$_${ri}$copy( nrhs, b( n, 1_${ik}$ ), ldb, work( bx+nm1 ), n ) end if - st1 = st - 1 - if( nsize==1 ) then + st1 = st - 1_${ik}$ + if( nsize==1_${ik}$ ) then ! this is a 1-by-1 subproblem and is not solved ! explicitly. - call stdlib_${ri}$copy( nrhs, b( st, 1 ), ldb, work( bx+st1 ), n ) + call stdlib${ii}$_${ri}$copy( nrhs, b( st, 1_${ik}$ ), ldb, work( bx+st1 ), n ) else if( nsize<=smlsiz ) then - ! this is a small subproblem and is solved by stdlib_${ri}$lasdq. - call stdlib_${ri}$laset( 'A', nsize, nsize, zero, one,work( vt+st1 ), n ) - call stdlib_${ri}$lasdq( 'U', 0, nsize, nsize, 0, nrhs, d( st ),e( st ), work( vt+& - st1 ), n, work( nwork ),n, b( st, 1 ), ldb, work( nwork ), info ) - if( info/=0 ) then + ! this is a small subproblem and is solved by stdlib${ii}$_${ri}$lasdq. + call stdlib${ii}$_${ri}$laset( 'A', nsize, nsize, zero, one,work( vt+st1 ), n ) + call stdlib${ii}$_${ri}$lasdq( 'U', 0_${ik}$, nsize, nsize, 0_${ik}$, nrhs, d( st ),e( st ), work( vt+& + st1 ), n, work( nwork ),n, b( st, 1_${ik}$ ), ldb, work( nwork ), info ) + if( info/=0_${ik}$ ) then return end if - call stdlib_${ri}$lacpy( 'A', nsize, nrhs, b( st, 1 ), ldb,work( bx+st1 ), n ) + call stdlib${ii}$_${ri}$lacpy( 'A', nsize, nrhs, b( st, 1_${ik}$ ), ldb,work( bx+st1 ), n ) else ! a large problem. solve it using divide and conquer. - call stdlib_${ri}$lasda( icmpq1, smlsiz, nsize, sqre, d( st ),e( st ), work( u+st1 & + call stdlib${ii}$_${ri}$lasda( icmpq1, smlsiz, nsize, sqre, d( st ),e( st ), work( u+st1 & ), n, work( vt+st1 ),iwork( k+st1 ), work( difl+st1 ),work( difr+st1 ), work( & z+st1 ),work( poles+st1 ), iwork( givptr+st1 ),iwork( givcol+st1 ), n, iwork( & perm+st1 ),work( givnum+st1 ), work( c+st1 ),work( s+st1 ), work( nwork ), & iwork( iwk ),info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if bxst = bx + st1 - call stdlib_${ri}$lalsa( icmpq2, smlsiz, nsize, nrhs, b( st, 1 ),ldb, work( bxst ),& + call stdlib${ii}$_${ri}$lalsa( icmpq2, smlsiz, nsize, nrhs, b( st, 1_${ik}$ ),ldb, work( bxst ),& n, work( u+st1 ), n,work( vt+st1 ), iwork( k+st1 ),work( difl+st1 ), work( & difr+st1 ),work( z+st1 ), work( poles+st1 ),iwork( givptr+st1 ), iwork( & givcol+st1 ), n,iwork( perm+st1 ), work( givnum+st1 ),work( c+st1 ), work( s+& st1 ), work( nwork ),iwork( iwk ), info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if end if - st = i + 1 + st = i + 1_${ik}$ end if end do loop_60 ! apply the singular values and treat the tiny ones as zero. - tol = rcnd*abs( d( stdlib_i${ri}$amax( n, d, 1 ) ) ) + tol = rcnd*abs( d( stdlib${ii}$_i${ri}$amax( n, d, 1_${ik}$ ) ) ) do i = 1, n ! some of the elements in d can be negative because 1-by-1 ! subproblems were not solved explicitly. if( abs( d( i ) )<=tol ) then - call stdlib_${ri}$laset( 'A', 1, nrhs, zero, zero, work( bx+i-1 ), n ) + call stdlib${ii}$_${ri}$laset( 'A', 1_${ik}$, nrhs, zero, zero, work( bx+i-1 ), n ) else - rank = rank + 1 - call stdlib_${ri}$lascl( 'G', 0, 0, d( i ), one, 1, nrhs,work( bx+i-1 ), n, info ) + rank = rank + 1_${ik}$ + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, d( i ), one, 1_${ik}$, nrhs,work( bx+i-1 ), n, info ) end if d( i ) = abs( d( i ) ) end do ! now apply back the right singular vectors. - icmpq2 = 1 + icmpq2 = 1_${ik}$ do i = 1, nsub st = iwork( i ) - st1 = st - 1 + st1 = st - 1_${ik}$ nsize = iwork( sizei+i-1 ) bxst = bx + st1 - if( nsize==1 ) then - call stdlib_${ri}$copy( nrhs, work( bxst ), n, b( st, 1 ), ldb ) + if( nsize==1_${ik}$ ) then + call stdlib${ii}$_${ri}$copy( nrhs, work( bxst ), n, b( st, 1_${ik}$ ), ldb ) else if( nsize<=smlsiz ) then - call stdlib_${ri}$gemm( 'T', 'N', nsize, nrhs, nsize, one,work( vt+st1 ), n, work( & - bxst ), n, zero,b( st, 1 ), ldb ) + call stdlib${ii}$_${ri}$gemm( 'T', 'N', nsize, nrhs, nsize, one,work( vt+st1 ), n, work( & + bxst ), n, zero,b( st, 1_${ik}$ ), ldb ) else - call stdlib_${ri}$lalsa( icmpq2, smlsiz, nsize, nrhs, work( bxst ), n,b( st, 1 ), ldb,& + call stdlib${ii}$_${ri}$lalsa( icmpq2, smlsiz, nsize, nrhs, work( bxst ), n,b( st, 1_${ik}$ ), ldb,& work( u+st1 ), n,work( vt+st1 ), iwork( k+st1 ),work( difl+st1 ), work( difr+& st1 ),work( z+st1 ), work( poles+st1 ),iwork( givptr+st1 ), iwork( givcol+st1 ),& n,iwork( perm+st1 ), work( givnum+st1 ),work( c+st1 ), work( s+st1 ), work( & nwork ),iwork( iwk ), info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if end if end do ! unscale and sort the singular values. - call stdlib_${ri}$lascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) - call stdlib_${ri}$lasrt( 'D', n, d, info ) - call stdlib_${ri}$lascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, n, 1_${ik}$, d, n, info ) + call stdlib${ii}$_${ri}$lasrt( 'D', n, d, info ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, n, nrhs, b, ldb, info ) return - end subroutine stdlib_${ri}$lalsd + end subroutine stdlib${ii}$_${ri}$lalsd - pure real(${rk}$) function stdlib_${ri}$lamch( cmach ) + pure real(${rk}$) function stdlib${ii}$_${ri}$lamch( cmach ) !! DLAMCH: determines quad precision machine parameters. ! -- lapack auxiliary routine -- ! -- lapack is a software package provided by univ. of tennessee, -- @@ -30877,24 +30868,24 @@ module stdlib_linalg_lapack_${ri}$ else rmach = zero end if - stdlib_${ri}$lamch = rmach + stdlib${ii}$_${ri}$lamch = rmach return - end function stdlib_${ri}$lamch + end function stdlib${ii}$_${ri}$lamch - pure real(${rk}$) function stdlib_${ri}$lamc3( a, b ) + pure real(${rk}$) function stdlib${ii}$_${ri}$lamc3( a, b ) ! -- lapack auxiliary routine -- ! univ. of tennessee, univ. of california berkeley and nag ltd.. ! Scalar Arguments real(${rk}$), intent(in) :: a, b ! ===================================================================== ! Executable Statements - stdlib_${ri}$lamc3 = a + b + stdlib${ii}$_${ri}$lamc3 = a + b return - end function stdlib_${ri}$lamc3 + end function stdlib${ii}$_${ri}$lamc3 - pure subroutine stdlib_${ri}$lamrg( n1, n2, a, dtrd1, dtrd2, index ) + pure subroutine stdlib${ii}$_${ri}$lamrg( n1, n2, a, dtrd1, dtrd2, index ) !! DLAMRG: will create a permutation list which will merge the elements !! of A (which is composed of two independently sorted sets) into a !! single set which is sorted in ascending order. @@ -30902,63 +30893,63 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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) :: dtrd1, dtrd2, n1, n2 + integer(${ik}$), intent(in) :: dtrd1, dtrd2, n1, n2 ! Array Arguments - integer(ilp), intent(out) :: index(*) + integer(${ik}$), intent(out) :: index(*) real(${rk}$), 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( dtrd1>0 ) then - ind1 = 1 + if( dtrd1>0_${ik}$ ) then + ind1 = 1_${ik}$ else ind1 = n1 end if - if( dtrd2>0 ) then - ind2 = 1 + n1 + if( dtrd2>0_${ik}$ ) then + ind2 = 1_${ik}$ + n1 else ind2 = n1 + n2 end if - i = 1 + i = 1_${ik}$ ! while ( (n1sv > 0) 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 + dtrd1 - n1sv = n1sv - 1 + n1sv = n1sv - 1_${ik}$ else index( i ) = ind2 - i = i + 1 + i = i + 1_${ik}$ ind2 = ind2 + dtrd2 - 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 + dtrd2 end do else ! n2sv == 0 do n2sv = 1, n1sv index( i ) = ind1 - i = i + 1 + i = i + 1_${ik}$ ind1 = ind1 + dtrd1 end do end if return - end subroutine stdlib_${ri}$lamrg + end subroutine stdlib${ii}$_${ri}$lamrg - pure subroutine stdlib_${ri}$lamswlq( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & + pure subroutine stdlib${ii}$_${ri}$lamswlq( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & !! DLAMSWLQ: overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -30972,8 +30963,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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) :: lda, m, n, k, mb, nb, ldt, lwork, ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, k, mb, nb, ldt, lwork, ldc ! Array Arguments real(${rk}$), intent(in) :: a(lda,*), t(ldt,*) real(${rk}$), intent(out) :: work(*) @@ -30981,11 +30972,11 @@ module stdlib_linalg_lapack_${ri}$ ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran, lquery - integer(ilp) :: i, ii, kk, ctr, lw + integer(${ik}$) :: i, ii, kk, ctr, lw ! External Subroutines ! Executable Statements ! test the input arguments - lquery = lwork<0 + lquery = lwork<0_${ik}$ notran = stdlib_lsame( trans, 'N' ) tran = stdlib_lsame( trans, 'T' ) left = stdlib_lsame( side, 'L' ) @@ -30995,42 +30986,42 @@ module stdlib_linalg_lapack_${ri}$ else lw = m * mb end if - info = 0 + info = 0_${ik}$ if( .not.left .and. .not.right ) then - info = -1 + info = -1_${ik}$ else if( .not.tran .and. .not.notran ) then - info = -2 - else if( k<0 ) then - info = -5 + info = -2_${ik}$ + else if( k<0_${ik}$ ) then + info = -5_${ik}$ else if( m=max(m,n,k))) then - call stdlib_${ri}$gemlqt( side, trans, m, n, k, mb, a, lda,t, ldt, c, ldc, work, info) + call stdlib${ii}$_${ri}$gemlqt( side, trans, m, n, k, mb, a, lda,t, ldt, c, ldc, work, info) return end if @@ -31038,85 +31029,85 @@ module stdlib_linalg_lapack_${ri}$ ! multiply q to the last block of c kk = mod((m-k),(nb-k)) ctr = (m-k)/(nb-k) - if (kk>0) then + if (kk>0_${ik}$) then ii=m-kk+1 - call stdlib_${ri}$tpmlqt('L','T',kk , n, k, 0, mb, a(1,ii), lda,t(1,ctr*k+1), ldt, c(& - 1,1), ldc,c(ii,1), ldc, work, info ) + call stdlib${ii}$_${ri}$tpmlqt('L','T',kk , n, k, 0_${ik}$, mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1), ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) else ii=m+1 end if do i=ii-(nb-k),nb+1,-(nb-k) ! multiply q to the current block of c (1:m,i:i+nb) - ctr = ctr - 1 - call stdlib_${ri}$tpmlqt('L','T',nb-k , n, k, 0,mb, a(1,i), lda,t(1, ctr*k+1),ldt, c(& - 1,1), ldc,c(i,1), ldc, work, info ) + ctr = ctr - 1_${ik}$ + call stdlib${ii}$_${ri}$tpmlqt('L','T',nb-k , n, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$, ctr*k+1),ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info ) end do ! multiply q to the first block of c (1:m,1:nb) - call stdlib_${ri}$gemlqt('L','T',nb , n, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_${ri}$gemlqt('L','T',nb , n, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (left.and.notran) then ! multiply q to the first block of c kk = mod((m-k),(nb-k)) ii=m-kk+1 - ctr = 1 - call stdlib_${ri}$gemlqt('L','N',nb , n, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + ctr = 1_${ik}$ + call stdlib${ii}$_${ri}$gemlqt('L','N',nb , n, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=nb+1,ii-nb+k,(nb-k) ! multiply q to the current block of c (i:i+nb,1:n) - call stdlib_${ri}$tpmlqt('L','N',nb-k , n, k, 0,mb, a(1,i), lda,t(1,ctr*k+1), ldt, c(1,& - 1), ldc,c(i,1), ldc, work, info ) - ctr = ctr + 1 + call stdlib${ii}$_${ri}$tpmlqt('L','N',nb-k , n, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$,ctr*k+1), ldt, c(1_${ik}$,& + 1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info ) + ctr = ctr + 1_${ik}$ end do if(ii<=m) then ! multiply q to the last block of c - call stdlib_${ri}$tpmlqt('L','N',kk , n, k, 0, mb, a(1,ii), lda,t(1,ctr*k+1), ldt, c(1,& - 1), ldc,c(ii,1), ldc, work, info ) + call stdlib${ii}$_${ri}$tpmlqt('L','N',kk , n, k, 0_${ik}$, mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1), ldt, c(1_${ik}$,& + 1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) end if else if(right.and.notran) then ! multiply q to the last block of c kk = mod((n-k),(nb-k)) ctr = (n-k)/(nb-k) - if (kk>0) then + if (kk>0_${ik}$) then ii=n-kk+1 - call stdlib_${ri}$tpmlqt('R','N',m , kk, k, 0, mb, a(1, ii), lda,t(1,ctr *k+1), ldt, & - c(1,1), ldc,c(1,ii), ldc, work, info ) + call stdlib${ii}$_${ri}$tpmlqt('R','N',m , kk, k, 0_${ik}$, mb, a(1_${ik}$, ii), lda,t(1_${ik}$,ctr *k+1), ldt, & + c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info ) else ii=n+1 end if do i=ii-(nb-k),nb+1,-(nb-k) ! multiply q to the current block of c (1:m,i:i+mb) - ctr = ctr - 1 - call stdlib_${ri}$tpmlqt('R','N', m, nb-k, k, 0, mb, a(1, i), lda,t(1,ctr*k+1), ldt, & - c(1,1), ldc,c(1,i), ldc, work, info ) + ctr = ctr - 1_${ik}$ + call stdlib${ii}$_${ri}$tpmlqt('R','N', m, nb-k, k, 0_${ik}$, mb, a(1_${ik}$, i), lda,t(1_${ik}$,ctr*k+1), ldt, & + c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info ) end do ! multiply q to the first block of c (1:m,1:mb) - call stdlib_${ri}$gemlqt('R','N',m , nb, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_${ri}$gemlqt('R','N',m , nb, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (right.and.tran) then ! multiply q to the first block of c kk = mod((n-k),(nb-k)) - ctr = 1 + ctr = 1_${ik}$ ii=n-kk+1 - call stdlib_${ri}$gemlqt('R','T',m , nb, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_${ri}$gemlqt('R','T',m , nb, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=nb+1,ii-nb+k,(nb-k) ! multiply q to the current block of c (1:m,i:i+mb) - call stdlib_${ri}$tpmlqt('R','T',m , nb-k, k, 0,mb, a(1,i), lda,t(1,ctr*k+1), ldt, c(1,& - 1), ldc,c(1,i), ldc, work, info ) - ctr = ctr + 1 + call stdlib${ii}$_${ri}$tpmlqt('R','T',m , nb-k, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$,ctr*k+1), ldt, c(1_${ik}$,& + 1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info ) + ctr = ctr + 1_${ik}$ end do if(ii<=n) then ! multiply q to the last block of c - call stdlib_${ri}$tpmlqt('R','T',m , kk, k, 0,mb, a(1,ii), lda,t(1,ctr*k+1),ldt, c(1,1),& - ldc,c(1,ii), ldc, work, info ) + call stdlib${ii}$_${ri}$tpmlqt('R','T',m , kk, k, 0_${ik}$,mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1),ldt, c(1_${ik}$,1_${ik}$),& + ldc,c(1_${ik}$,ii), ldc, work, info ) end if end if - work(1) = lw + work(1_${ik}$) = lw return - end subroutine stdlib_${ri}$lamswlq + end subroutine stdlib${ii}$_${ri}$lamswlq - pure subroutine stdlib_${ri}$lamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & + pure subroutine stdlib${ii}$_${ri}$lamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & !! DLAMTSQR: overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -31130,8 +31121,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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) :: lda, m, n, k, mb, nb, ldt, lwork, ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, k, mb, nb, ldt, lwork, ldc ! Array Arguments real(${rk}$), intent(in) :: a(lda,*), t(ldt,*) real(${rk}$), intent(out) :: work(*) @@ -31139,11 +31130,11 @@ module stdlib_linalg_lapack_${ri}$ ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran, lquery - integer(ilp) :: i, ii, kk, lw, ctr, q + integer(${ik}$) :: i, ii, kk, lw, ctr, q ! External Subroutines ! Executable Statements ! test the input arguments - lquery = lwork<0 + lquery = lwork<0_${ik}$ notran = stdlib_lsame( trans, 'N' ) tran = stdlib_lsame( trans, 'T' ) left = stdlib_lsame( side, 'L' ) @@ -31155,44 +31146,44 @@ module stdlib_linalg_lapack_${ri}$ lw = mb * nb q = n end if - info = 0 + info = 0_${ik}$ if( .not.left .and. .not.right ) then - info = -1 + info = -1_${ik}$ else if( .not.tran .and. .not.notran ) then - info = -2 + info = -2_${ik}$ else if( m=max(m,n,k))) then - call stdlib_${ri}$gemqrt( side, trans, m, n, k, nb, a, lda,t, ldt, c, ldc, work, info) + call stdlib${ii}$_${ri}$gemqrt( side, trans, m, n, k, nb, a, lda,t, ldt, c, ldc, work, info) return end if @@ -31200,85 +31191,85 @@ module stdlib_linalg_lapack_${ri}$ ! multiply q to the last block of c kk = mod((m-k),(mb-k)) ctr = (m-k)/(mb-k) - if (kk>0) then + if (kk>0_${ik}$) then ii=m-kk+1 - call stdlib_${ri}$tpmqrt('L','N',kk , n, k, 0, nb, a(ii,1), lda,t(1,ctr*k+1),ldt , c(1,& - 1), ldc,c(ii,1), ldc, work, info ) + call stdlib${ii}$_${ri}$tpmqrt('L','N',kk , n, k, 0_${ik}$, nb, a(ii,1_${ik}$), lda,t(1_${ik}$,ctr*k+1),ldt , c(1_${ik}$,& + 1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) else ii=m+1 end if do i=ii-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) - ctr = ctr - 1 - call stdlib_${ri}$tpmqrt('L','N',mb-k , n, k, 0,nb, a(i,1), lda,t(1,ctr*k+1),ldt, c(1,& - 1), ldc,c(i,1), ldc, work, info ) + ctr = ctr - 1_${ik}$ + call stdlib${ii}$_${ri}$tpmqrt('L','N',mb-k , n, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$,ctr*k+1),ldt, c(1_${ik}$,& + 1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info ) end do ! multiply q to the first block of c (1:mb,1:n) - call stdlib_${ri}$gemqrt('L','N',mb , n, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_${ri}$gemqrt('L','N',mb , n, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (left.and.tran) then ! multiply q to the first block of c kk = mod((m-k),(mb-k)) ii=m-kk+1 - ctr = 1 - call stdlib_${ri}$gemqrt('L','T',mb , n, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + ctr = 1_${ik}$ + call stdlib${ii}$_${ri}$gemqrt('L','T',mb , n, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) - call stdlib_${ri}$tpmqrt('L','T',mb-k , n, k, 0,nb, a(i,1), lda,t(1,ctr * k + 1),ldt, c(& - 1,1), ldc,c(i,1), ldc, work, info ) - ctr = ctr + 1 + call stdlib${ii}$_${ri}$tpmqrt('L','T',mb-k , n, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$,ctr * k + 1_${ik}$),ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info ) + ctr = ctr + 1_${ik}$ end do if(ii<=m) then ! multiply q to the last block of c - call stdlib_${ri}$tpmqrt('L','T',kk , n, k, 0,nb, a(ii,1), lda,t(1,ctr * k + 1), ldt, c(& - 1,1), ldc,c(ii,1), ldc, work, info ) + call stdlib${ii}$_${ri}$tpmqrt('L','T',kk , n, k, 0_${ik}$,nb, a(ii,1_${ik}$), lda,t(1_${ik}$,ctr * k + 1_${ik}$), ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) end if else if(right.and.tran) then ! multiply q to the last block of c kk = mod((n-k),(mb-k)) ctr = (n-k)/(mb-k) - if (kk>0) then + if (kk>0_${ik}$) then ii=n-kk+1 - call stdlib_${ri}$tpmqrt('R','T',m , kk, k, 0, nb, a(ii,1), lda,t(1,ctr*k+1), ldt, c(& - 1,1), ldc,c(1,ii), ldc, work, info ) + call stdlib${ii}$_${ri}$tpmqrt('R','T',m , kk, k, 0_${ik}$, nb, a(ii,1_${ik}$), lda,t(1_${ik}$,ctr*k+1), ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info ) else ii=n+1 end if do i=ii-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) - ctr = ctr - 1 - call stdlib_${ri}$tpmqrt('R','T',m , mb-k, k, 0,nb, a(i,1), lda,t(1,ctr*k+1), ldt, c(& - 1,1), ldc,c(1,i), ldc, work, info ) + ctr = ctr - 1_${ik}$ + call stdlib${ii}$_${ri}$tpmqrt('R','T',m , mb-k, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$,ctr*k+1), ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info ) end do ! multiply q to the first block of c (1:m,1:mb) - call stdlib_${ri}$gemqrt('R','T',m , mb, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_${ri}$gemqrt('R','T',m , mb, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (right.and.notran) then ! multiply q to the first block of c kk = mod((n-k),(mb-k)) ii=n-kk+1 - ctr = 1 - call stdlib_${ri}$gemqrt('R','N', m, mb , k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + ctr = 1_${ik}$ + call stdlib${ii}$_${ri}$gemqrt('R','N', m, mb , k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) - call stdlib_${ri}$tpmqrt('R','N', m, mb-k, k, 0,nb, a(i,1), lda,t(1, ctr * k + 1),ldt, & - c(1,1), ldc,c(1,i), ldc, work, info ) - ctr = ctr + 1 + call stdlib${ii}$_${ri}$tpmqrt('R','N', m, mb-k, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$),ldt, & + c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info ) + ctr = ctr + 1_${ik}$ end do if(ii<=n) then ! multiply q to the last block of c - call stdlib_${ri}$tpmqrt('R','N', m, kk , k, 0,nb, a(ii,1), lda,t(1, ctr * k + 1),ldt, & - c(1,1), ldc,c(1,ii), ldc, work, info ) + call stdlib${ii}$_${ri}$tpmqrt('R','N', m, kk , k, 0_${ik}$,nb, a(ii,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$),ldt, & + c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info ) end if end if - work(1) = lw + work(1_${ik}$) = lw return - end subroutine stdlib_${ri}$lamtsqr + end subroutine stdlib${ii}$_${ri}$lamtsqr - pure integer(ilp) function stdlib_${ri}$laneg( n, d, lld, sigma, pivmin, r ) + pure integer(${ik}$) function stdlib${ii}$_${ri}$laneg( n, d, lld, sigma, pivmin, r ) !! DLANEG: computes the Sturm count, the number of negative pivots !! encountered while factoring tridiagonal T - sigma I = L D L^T. !! This implementation works directly on the factors without forming @@ -31298,13 +31289,13 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: pivmin, sigma ! Array Arguments real(${rk}$), 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 @@ -31313,37 +31304,37 @@ module stdlib_linalg_lapack_${ri}$ ! 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(${rk}$) :: 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_${ri}$lassq( n-1, dl, 1, scale, sum ) - call stdlib_${ri}$lassq( n-1, du, 1, scale, sum ) + call stdlib${ii}$_${ri}$lassq( n, d, 1_${ik}$, scale, sum ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_${ri}$lassq( n-1, dl, 1_${ik}$, scale, sum ) + call stdlib${ii}$_${ri}$lassq( n-1, du, 1_${ik}$, scale, sum ) end if anorm = scale*sqrt( sum ) end if - stdlib_${ri}$langt = anorm + stdlib${ii}$_${ri}$langt = anorm return - end function stdlib_${ri}$langt + end function stdlib${ii}$_${ri}$langt - real(${rk}$) function stdlib_${ri}$lanhs( norm, n, a, lda, work ) + real(${rk}$) function stdlib${ii}$_${ri}$lanhs( norm, n, a, lda, work ) !! DLANHS: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! Hessenberg matrix A. @@ -31615,19 +31606,19 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: a(lda,*) real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(${rk}$) :: 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))). @@ -31635,7 +31626,7 @@ module stdlib_linalg_lapack_${ri}$ do j = 1, n do i = 1, min( n, j+1 ) sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do end do else if( ( stdlib_lsame( norm, 'O' ) ) .or. ( norm=='1' ) ) then @@ -31646,7 +31637,7 @@ module stdlib_linalg_lapack_${ri}$ do i = 1, min( n, j+1 ) sum = sum + abs( a( i, j ) ) end do - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do else if( stdlib_lsame( norm, 'I' ) ) then ! find normi(a). @@ -31661,7 +31652,7 @@ module stdlib_linalg_lapack_${ri}$ value = zero do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & then @@ -31669,16 +31660,16 @@ module stdlib_linalg_lapack_${ri}$ scale = zero sum = one do j = 1, n - call stdlib_${ri}$lassq( min( n, j+1 ), a( 1, j ), 1, scale, sum ) + call stdlib${ii}$_${ri}$lassq( min( n, j+1 ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum ) end do value = scale*sqrt( sum ) end if - stdlib_${ri}$lanhs = value + stdlib${ii}$_${ri}$lanhs = value return - end function stdlib_${ri}$lanhs + end function stdlib${ii}$_${ri}$lanhs - real(${rk}$) function stdlib_${ri}$lansb( norm, uplo, n, k, ab, ldab,work ) + real(${rk}$) function stdlib${ii}$_${ri}$lansb( norm, uplo, n, k, ab, ldab,work ) !! DLANSB: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of an !! n by n symmetric band matrix A, with k super-diagonals. @@ -31687,19 +31678,19 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: ab(ldab,*) real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, l + integer(${ik}$) :: i, j, l real(${rk}$) :: 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))). @@ -31708,14 +31699,14 @@ module stdlib_linalg_lapack_${ri}$ do j = 1, n do i = max( k+2-j, 1 ), k + 1 sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do end do else do j = 1, n do i = 1, min( n+1-j, k+1 ) sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do end do end if @@ -31726,7 +31717,7 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -31736,21 +31727,21 @@ module stdlib_linalg_lapack_${ri}$ end do do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( 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_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do end if else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & @@ -31758,32 +31749,32 @@ module stdlib_linalg_lapack_${ri}$ ! 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_${ri}$lassq( min( j-1, k ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) + call stdlib${ii}$_${ri}$lassq( 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_${ri}$lassq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) + call stdlib${ii}$_${ri}$lassq( 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_${ri}$lassq( n, ab( l, 1 ), ldab, scale, sum ) + call stdlib${ii}$_${ri}$lassq( n, ab( l, 1_${ik}$ ), ldab, scale, sum ) value = scale*sqrt( sum ) end if - stdlib_${ri}$lansb = value + stdlib${ii}$_${ri}$lansb = value return - end function stdlib_${ri}$lansb + end function stdlib${ii}$_${ri}$lansb - real(${rk}$) function stdlib_${ri}$lansf( norm, transr, uplo, n, a, work ) + real(${rk}$) function stdlib${ii}$_${ri}$lansf( norm, transr, uplo, n, a, work ) !! DLANSF: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! real symmetric matrix A in RFP format. @@ -31792,60 +31783,60 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: a(0:*) - real(${rk}$), intent(out) :: work(0:*) + real(${rk}$), intent(in) :: a(0_${ik}$:*) + real(${rk}$), 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(${rk}$) :: scale, s, value, aa, temp ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements - if( n==0 ) then - stdlib_${ri}$lansf = zero + if( n==0_${ik}$ ) then + stdlib${ii}$_${ri}$lansf = zero return - else if( n==1 ) then - stdlib_${ri}$lansf = abs( a(0) ) + else if( n==1_${ik}$ ) then + stdlib${ii}$_${ri}$lansf = abs( a(0_${ik}$) ) 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 + noe = 1_${ik}$ + if( mod( n, 2_${ik}$ )==0_${ik}$ )noe = 0_${ik}$ ! set ifm = 0 when form='t or 't' and 1 otherwise - ifm = 1 - if( stdlib_lsame( transr, 'T' ) )ifm = 0 + ifm = 1_${ik}$ + if( stdlib_lsame( transr, 'T' ) )ifm = 0_${ik}$ ! set ilu = 0 when uplo='u or 'u' and 1 otherwise - ilu = 1 - if( stdlib_lsame( uplo, 'U' ) )ilu = 0 + ilu = 1_${ik}$ + if( stdlib_lsame( uplo, 'U' ) )ilu = 0_${ik}$ ! 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( ifm==1_${ik}$ ) then + if( noe==1_${ik}$ ) then lda = n else ! noe=0 - lda = n + 1 + lda = n + 1_${ik}$ end if else ! ifm=0 - lda = ( n+1 ) / 2 + 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_${ri}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${ri}$isnan( temp ) )value = temp end do end do else @@ -31853,18 +31844,18 @@ module stdlib_linalg_lapack_${ri}$ do j = 0, n - 1 do i = 0, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${ri}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${ri}$isnan( 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_${ri}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${ri}$isnan( temp ) )value = temp end do end do else @@ -31872,7 +31863,7 @@ module stdlib_linalg_lapack_${ri}$ do j = 0, n do i = 0, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${ri}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${ri}$isnan( temp ) )value = temp end do end do end if @@ -31880,11 +31871,11 @@ module stdlib_linalg_lapack_${ri}$ else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( & norm=='1' ) ) 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 @@ -31900,13 +31891,13 @@ module stdlib_linalg_lapack_${ri}$ ! -> 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 @@ -31915,14 +31906,14 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${ri}$isnan( temp ) )value = temp end do else ! ilu = 1 - k = k + 1 + k = k + 1_${ik}$ ! k=(n+1)/2 for n odd and ilu=1 do i = k, n - 1 work( i ) = zero @@ -31935,20 +31926,20 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -31956,15 +31947,15 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${ri}$isnan( 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 @@ -31979,13 +31970,13 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -31993,10 +31984,10 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${ri}$isnan( temp ) )value = temp end do else ! ilu = 1 @@ -32016,13 +32007,13 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -32030,22 +32021,22 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${ri}$isnan( temp ) )value = temp end do end if end if else ! ifm=0 - k = n / 2 - if( noe==1 ) then + 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 + k = k + 1_${ik}$ ! k is the row size and lda do i = n1, n - 1 work( i ) = zero @@ -32061,7 +32052,7 @@ module stdlib_linalg_lapack_${ri}$ 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 ) ) @@ -32083,11 +32074,11 @@ module stdlib_linalg_lapack_${ri}$ ! 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 @@ -32095,14 +32086,14 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${ri}$isnan( temp ) )value = temp end do else ! ilu=1 - k = k + 1 + k = k + 1_${ik}$ ! k=(n+1)/2 for n odd and ilu=1 do i = k, n - 1 work( i ) = zero @@ -32121,12 +32112,12 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -32159,15 +32150,15 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${ri}$isnan( 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 @@ -32182,7 +32173,7 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -32205,12 +32196,12 @@ module stdlib_linalg_lapack_${ri}$ ! 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 @@ -32231,10 +32222,10 @@ module stdlib_linalg_lapack_${ri}$ ! 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_${ri}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${ri}$isnan( temp ) )value = temp end do else ! ilu=1 @@ -32242,7 +32233,7 @@ module stdlib_linalg_lapack_${ri}$ work( i ) = zero end do ! j=0 is special :process col a(k:n-1,k) - s = abs( a( 0 ) ) + s = abs( a( 0_${ik}$ ) ) ! a(k,k) do i = 1, k - 1 aa = abs( a( i ) ) @@ -32265,12 +32256,12 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -32303,10 +32294,10 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${ri}$isnan( temp ) )value = temp end do end if end if @@ -32314,180 +32305,180 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$lassq( k-j-2, a( k+j+1+j*lda ), 1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k-j-2, a( k+j+1+j*lda ), 1_${ik}$, scale, s ) ! l at a(k,0) end do do j = 0, k - 1 - call stdlib_${ri}$lassq( k+j-1, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k+j-1, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! trap u at a(0,0) end do s = s + s ! double s for the off diagonal elements - call stdlib_${ri}$lassq( k-1, a( k ), lda+1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k-1, a( k ), lda+1, scale, s ) ! tri l at a(k,0) - call stdlib_${ri}$lassq( k, a( k-1 ), lda+1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k, a( k-1 ), lda+1, scale, s ) ! tri u at a(k-1,0) else ! ilu=1 do j = 0, k - 1 - call stdlib_${ri}$lassq( n-j-1, a( j+1+j*lda ), 1, scale, s ) + call stdlib${ii}$_${ri}$lassq( n-j-1, a( j+1+j*lda ), 1_${ik}$, scale, s ) ! trap l at a(0,0) end do do j = 0, k - 2 - call stdlib_${ri}$lassq( j, a( 0+( 1+j )*lda ), 1, scale, s ) + call stdlib${ii}$_${ri}$lassq( j, a( 0_${ik}$+( 1_${ik}$+j )*lda ), 1_${ik}$, scale, s ) ! u at a(0,1) end do s = s + s ! double s for the off diagonal elements - call stdlib_${ri}$lassq( k, a( 0 ), lda+1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k, a( 0_${ik}$ ), lda+1, scale, s ) ! tri l at a(0,0) - call stdlib_${ri}$lassq( k-1, a( 0+lda ), lda+1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k-1, a( 0_${ik}$+lda ), lda+1, scale, s ) ! tri u at a(0,1) 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_${ri}$lassq( j, a( 0+( k+j )*lda ), 1, scale, s ) + call stdlib${ii}$_${ri}$lassq( j, a( 0_${ik}$+( k+j )*lda ), 1_${ik}$, scale, s ) ! u at a(0,k) end do do j = 0, k - 2 - call stdlib_${ri}$lassq( k, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! k by k-1 rect. at a(0,0) end do do j = 0, k - 2 - call stdlib_${ri}$lassq( k-j-1, a( j+1+( j+k-1 )*lda ), 1,scale, s ) + call stdlib${ii}$_${ri}$lassq( k-j-1, a( j+1+( j+k-1 )*lda ), 1_${ik}$,scale, s ) ! l at a(0,k-1) end do s = s + s ! double s for the off diagonal elements - call stdlib_${ri}$lassq( k-1, a( 0+k*lda ), lda+1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k-1, a( 0_${ik}$+k*lda ), lda+1, scale, s ) ! tri u at a(0,k) - call stdlib_${ri}$lassq( k, a( 0+( k-1 )*lda ), lda+1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k, a( 0_${ik}$+( k-1 )*lda ), lda+1, scale, s ) ! tri l at a(0,k-1) else ! a**t is lower do j = 1, k - 1 - call stdlib_${ri}$lassq( j, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_${ri}$lassq( j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! u at a(0,0) end do do j = k, n - 1 - call stdlib_${ri}$lassq( k, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! k by k-1 rect. at a(0,k) end do do j = 0, k - 3 - call stdlib_${ri}$lassq( k-j-2, a( j+2+j*lda ), 1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k-j-2, a( j+2+j*lda ), 1_${ik}$, scale, s ) ! l at a(1,0) end do s = s + s ! double s for the off diagonal elements - call stdlib_${ri}$lassq( k, a( 0 ), lda+1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k, a( 0_${ik}$ ), lda+1, scale, s ) ! tri u at a(0,0) - call stdlib_${ri}$lassq( k-1, a( 1 ), lda+1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k-1, a( 1_${ik}$ ), lda+1, scale, s ) ! tri l at a(1,0) 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_${ri}$lassq( k-j-1, a( k+j+2+j*lda ), 1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k-j-1, a( k+j+2+j*lda ), 1_${ik}$, scale, s ) ! l at a(k+1,0) end do do j = 0, k - 1 - call stdlib_${ri}$lassq( k+j, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k+j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! trap u at a(0,0) end do s = s + s ! double s for the off diagonal elements - call stdlib_${ri}$lassq( k, a( k+1 ), lda+1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k, a( k+1 ), lda+1, scale, s ) ! tri l at a(k+1,0) - call stdlib_${ri}$lassq( k, a( k ), lda+1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k, a( k ), lda+1, scale, s ) ! tri u at a(k,0) else ! ilu=1 do j = 0, k - 1 - call stdlib_${ri}$lassq( n-j-1, a( j+2+j*lda ), 1, scale, s ) + call stdlib${ii}$_${ri}$lassq( n-j-1, a( j+2+j*lda ), 1_${ik}$, scale, s ) ! trap l at a(1,0) end do do j = 1, k - 1 - call stdlib_${ri}$lassq( j, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_${ri}$lassq( j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! u at a(0,0) end do s = s + s ! double s for the off diagonal elements - call stdlib_${ri}$lassq( k, a( 1 ), lda+1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k, a( 1_${ik}$ ), lda+1, scale, s ) ! tri l at a(1,0) - call stdlib_${ri}$lassq( k, a( 0 ), lda+1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k, a( 0_${ik}$ ), lda+1, scale, s ) ! tri u at a(0,0) 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_${ri}$lassq( j, a( 0+( k+1+j )*lda ), 1, scale, s ) + call stdlib${ii}$_${ri}$lassq( j, a( 0_${ik}$+( k+1+j )*lda ), 1_${ik}$, scale, s ) ! u at a(0,k+1) end do do j = 0, k - 1 - call stdlib_${ri}$lassq( k, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! k by k rect. at a(0,0) end do do j = 0, k - 2 - call stdlib_${ri}$lassq( k-j-1, a( j+1+( j+k )*lda ), 1, scale,s ) + call stdlib${ii}$_${ri}$lassq( k-j-1, a( j+1+( j+k )*lda ), 1_${ik}$, scale,s ) ! l at a(0,k) end do s = s + s ! double s for the off diagonal elements - call stdlib_${ri}$lassq( k, a( 0+( k+1 )*lda ), lda+1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k, a( 0_${ik}$+( k+1 )*lda ), lda+1, scale, s ) ! tri u at a(0,k+1) - call stdlib_${ri}$lassq( k, a( 0+k*lda ), lda+1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k, a( 0_${ik}$+k*lda ), lda+1, scale, s ) ! tri l at a(0,k) else ! a**t is lower do j = 1, k - 1 - call stdlib_${ri}$lassq( j, a( 0+( j+1 )*lda ), 1, scale, s ) + call stdlib${ii}$_${ri}$lassq( j, a( 0_${ik}$+( j+1 )*lda ), 1_${ik}$, scale, s ) ! u at a(0,1) end do do j = k + 1, n - call stdlib_${ri}$lassq( k, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! k by k rect. at a(0,k+1) end do do j = 0, k - 2 - call stdlib_${ri}$lassq( k-j-1, a( j+1+j*lda ), 1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k-j-1, a( j+1+j*lda ), 1_${ik}$, scale, s ) ! l at a(0,0) end do s = s + s ! double s for the off diagonal elements - call stdlib_${ri}$lassq( k, a( lda ), lda+1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k, a( lda ), lda+1, scale, s ) ! tri l at a(0,1) - call stdlib_${ri}$lassq( k, a( 0 ), lda+1, scale, s ) + call stdlib${ii}$_${ri}$lassq( k, a( 0_${ik}$ ), lda+1, scale, s ) ! tri u at a(0,0) end if end if end if value = scale*sqrt( s ) end if - stdlib_${ri}$lansf = value + stdlib${ii}$_${ri}$lansf = value return - end function stdlib_${ri}$lansf + end function stdlib${ii}$_${ri}$lansf - real(${rk}$) function stdlib_${ri}$lansp( norm, uplo, n, ap, work ) + real(${rk}$) function stdlib${ii}$_${ri}$lansp( norm, uplo, n, ap, work ) !! DLANSP: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! real symmetric matrix A, supplied in packed form. @@ -32496,47 +32487,47 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: ap(*) real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, k + integer(${ik}$) :: i, j, k real(${rk}$) :: 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_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( 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_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( 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 ! 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 @@ -32544,14 +32535,14 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do else do i = 1, n @@ -32559,14 +32550,14 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do end if else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & @@ -32574,44 +32565,44 @@ module stdlib_linalg_lapack_${ri}$ ! find normf(a). scale = zero sum = one - k = 2 + k = 2_${ik}$ if( stdlib_lsame( uplo, 'U' ) ) then do j = 2, n - call stdlib_${ri}$lassq( j-1, ap( k ), 1, scale, sum ) + call stdlib${ii}$_${ri}$lassq( j-1, ap( k ), 1_${ik}$, scale, sum ) k = k + j end do else do j = 1, n - 1 - call stdlib_${ri}$lassq( n-j, ap( k ), 1, scale, sum ) - k = k + n - j + 1 + call stdlib${ii}$_${ri}$lassq( 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_${ri}$lassq( n-1, e, 1, scale, sum ) - sum = 2*sum + if( n>1_${ik}$ ) then + call stdlib${ii}$_${ri}$lassq( n-1, e, 1_${ik}$, scale, sum ) + sum = 2_${ik}$*sum end if - call stdlib_${ri}$lassq( n, d, 1, scale, sum ) + call stdlib${ii}$_${ri}$lassq( n, d, 1_${ik}$, scale, sum ) anorm = scale*sqrt( sum ) end if - stdlib_${ri}$lanst = anorm + stdlib${ii}$_${ri}$lanst = anorm return - end function stdlib_${ri}$lanst + end function stdlib${ii}$_${ri}$lanst - real(${rk}$) function stdlib_${ri}$lansy( norm, uplo, n, a, lda, work ) + real(${rk}$) function stdlib${ii}$_${ri}$lansy( norm, uplo, n, a, lda, work ) !! DLANSY: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! real symmetric matrix A. @@ -32682,19 +32673,19 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: a(lda,*) real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(${rk}$) :: 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))). @@ -32703,14 +32694,14 @@ module stdlib_linalg_lapack_${ri}$ do j = 1, n do i = 1, j sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do end do else do j = 1, n do i = j, n sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do end do end if @@ -32730,7 +32721,7 @@ module stdlib_linalg_lapack_${ri}$ end do do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do else do i = 1, n @@ -32743,7 +32734,7 @@ module stdlib_linalg_lapack_${ri}$ sum = sum + absa work( i ) = work( i ) + absa end do - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do end if else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & @@ -32753,23 +32744,23 @@ module stdlib_linalg_lapack_${ri}$ sum = one if( stdlib_lsame( uplo, 'U' ) ) then do j = 2, n - call stdlib_${ri}$lassq( j-1, a( 1, j ), 1, scale, sum ) + call stdlib${ii}$_${ri}$lassq( j-1, a( 1_${ik}$, j ), 1_${ik}$, scale, sum ) end do else do j = 1, n - 1 - call stdlib_${ri}$lassq( n-j, a( j+1, j ), 1, scale, sum ) + call stdlib${ii}$_${ri}$lassq( n-j, a( j+1, j ), 1_${ik}$, scale, sum ) end do end if - sum = 2*sum - call stdlib_${ri}$lassq( n, a, lda+1, scale, sum ) + sum = 2_${ik}$*sum + call stdlib${ii}$_${ri}$lassq( n, a, lda+1, scale, sum ) value = scale*sqrt( sum ) end if - stdlib_${ri}$lansy = value + stdlib${ii}$_${ri}$lansy = value return - end function stdlib_${ri}$lansy + end function stdlib${ii}$_${ri}$lansy - real(${rk}$) function stdlib_${ri}$lantb( norm, uplo, diag, n, k, ab,ldab, work ) + real(${rk}$) function stdlib${ii}$_${ri}$lantb( norm, uplo, diag, n, k, ab,ldab, work ) !! DLANTB: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of an !! n by n triangular band matrix A, with ( k + 1 ) diagonals. @@ -32778,7 +32769,7 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: ab(ldab,*) real(${rk}$), intent(out) :: work(*) @@ -32786,12 +32777,12 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: udiag - integer(ilp) :: i, j, l + integer(${ik}$) :: i, j, l real(${rk}$) :: 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))). @@ -32801,14 +32792,14 @@ module stdlib_linalg_lapack_${ri}$ do j = 1, n do i = max( k+2-j, 1 ), k sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do end do else do j = 1, n do i = 2, min( n+1-j, k+1 ) sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do end do end if @@ -32818,14 +32809,14 @@ module stdlib_linalg_lapack_${ri}$ do j = 1, n do i = max( k+2-j, 1 ), k + 1 sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do end do else do j = 1, n do i = 1, min( n+1-j, k+1 ) sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do end do end if @@ -32847,7 +32838,7 @@ module stdlib_linalg_lapack_${ri}$ sum = sum + abs( ab( i, j ) ) end do end if - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do else do j = 1, n @@ -32862,7 +32853,7 @@ module stdlib_linalg_lapack_${ri}$ sum = sum + abs( ab( i, j ) ) end do end if - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do end if else if( stdlib_lsame( norm, 'I' ) ) then @@ -32874,7 +32865,7 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -32884,7 +32875,7 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -32896,7 +32887,7 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -32906,7 +32897,7 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -32915,7 +32906,7 @@ module stdlib_linalg_lapack_${ri}$ end if do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & then @@ -32924,9 +32915,9 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$lassq( min( j-1, k ),ab( max( k+2-j, 1 ), j ), 1, scale,& + call stdlib${ii}$_${ri}$lassq( min( j-1, k ),ab( max( k+2-j, 1_${ik}$ ), j ), 1_${ik}$, scale,& sum ) end do end if @@ -32934,7 +32925,7 @@ module stdlib_linalg_lapack_${ri}$ scale = zero sum = one do j = 1, n - call stdlib_${ri}$lassq( min( j, k+1 ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) + call stdlib${ii}$_${ri}$lassq( min( j, k+1 ), ab( max( k+2-j, 1_${ik}$ ), j ),1_${ik}$, scale, sum ) end do end if @@ -32942,27 +32933,27 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$lassq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) + call stdlib${ii}$_${ri}$lassq( 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_${ri}$lassq( min( n-j+1, k+1 ), ab( 1, j ), 1, scale,sum ) + call stdlib${ii}$_${ri}$lassq( 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_${ri}$lantb = value + stdlib${ii}$_${ri}$lantb = value return - end function stdlib_${ri}$lantb + end function stdlib${ii}$_${ri}$lantb - real(${rk}$) function stdlib_${ri}$lantp( norm, uplo, diag, n, ap, work ) + real(${rk}$) function stdlib${ii}$_${ri}$lantp( norm, uplo, diag, n, ap, work ) !! DLANTP: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! triangular matrix A, supplied in packed form. @@ -32971,7 +32962,7 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: ap(*) real(${rk}$), intent(out) :: work(*) @@ -32979,23 +32970,23 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: udiag - integer(ilp) :: i, j, k + integer(${ik}$) :: i, j, k real(${rk}$) :: 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_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do k = k + j end do @@ -33003,9 +32994,9 @@ module stdlib_linalg_lapack_${ri}$ do j = 1, n do i = k + 1, k + n - j sum = abs( ap( i ) ) - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do - k = k + n - j + 1 + k = k + n - j + 1_${ik}$ end do end if else @@ -33014,7 +33005,7 @@ module stdlib_linalg_lapack_${ri}$ do j = 1, n do i = k, k + j - 1 sum = abs( ap( i ) ) - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do k = k + j end do @@ -33022,16 +33013,16 @@ module stdlib_linalg_lapack_${ri}$ do j = 1, n do i = k, k + n - j sum = abs( ap( i ) ) - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( 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 ! 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 @@ -33047,7 +33038,7 @@ module stdlib_linalg_lapack_${ri}$ end do end if k = k + j - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do else do j = 1, n @@ -33062,13 +33053,13 @@ module stdlib_linalg_lapack_${ri}$ sum = sum + abs( ap( i ) ) end do end if - k = k + n - j + 1 - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + k = k + n - j + 1_${ik}$ + if( value < sum .or. stdlib${ii}$_${ri}$isnan( 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 @@ -33077,9 +33068,9 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -33088,7 +33079,7 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -33098,10 +33089,10 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -33111,7 +33102,7 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -33119,7 +33110,7 @@ module stdlib_linalg_lapack_${ri}$ value = zero do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & then @@ -33128,17 +33119,17 @@ module stdlib_linalg_lapack_${ri}$ if( stdlib_lsame( diag, 'U' ) ) then scale = one sum = n - k = 2 + k = 2_${ik}$ do j = 2, n - call stdlib_${ri}$lassq( j-1, ap( k ), 1, scale, sum ) + call stdlib${ii}$_${ri}$lassq( 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_${ri}$lassq( j, ap( k ), 1, scale, sum ) + call stdlib${ii}$_${ri}$lassq( j, ap( k ), 1_${ik}$, scale, sum ) k = k + j end do end if @@ -33146,29 +33137,29 @@ module stdlib_linalg_lapack_${ri}$ if( stdlib_lsame( diag, 'U' ) ) then scale = one sum = n - k = 2 + k = 2_${ik}$ do j = 1, n - 1 - call stdlib_${ri}$lassq( n-j, ap( k ), 1, scale, sum ) - k = k + n - j + 1 + call stdlib${ii}$_${ri}$lassq( 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_${ri}$lassq( n-j+1, ap( k ), 1, scale, sum ) - k = k + n - j + 1 + call stdlib${ii}$_${ri}$lassq( 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_${ri}$lantp = value + stdlib${ii}$_${ri}$lantp = value return - end function stdlib_${ri}$lantp + end function stdlib${ii}$_${ri}$lantp - real(${rk}$) function stdlib_${ri}$lantr( norm, uplo, diag, m, n, a, lda,work ) + real(${rk}$) function stdlib${ii}$_${ri}$lantr( norm, uplo, diag, m, n, a, lda,work ) !! DLANTR: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! trapezoidal or triangular matrix A. @@ -33177,7 +33168,7 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: a(lda,*) real(${rk}$), intent(out) :: work(*) @@ -33185,12 +33176,12 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: udiag - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(${rk}$) :: 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))). @@ -33200,14 +33191,14 @@ module stdlib_linalg_lapack_${ri}$ do j = 1, n do i = 1, min( m, j-1 ) sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do end do else do j = 1, n do i = j + 1, m sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do end do end if @@ -33217,14 +33208,14 @@ module stdlib_linalg_lapack_${ri}$ do j = 1, n do i = 1, min( m, j ) sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do end do else do j = 1, n do i = j, m sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do end do end if @@ -33246,7 +33237,7 @@ module stdlib_linalg_lapack_${ri}$ sum = sum + abs( a( i, j ) ) end do end if - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do else do j = 1, n @@ -33261,7 +33252,7 @@ module stdlib_linalg_lapack_${ri}$ sum = sum + abs( a( i, j ) ) end do end if - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do end if else if( stdlib_lsame( norm, 'I' ) ) then @@ -33313,7 +33304,7 @@ module stdlib_linalg_lapack_${ri}$ value = zero do i = 1, m sum = work( i ) - if( value < sum .or. stdlib_${ri}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${ri}$isnan( sum ) ) value = sum end do else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & then @@ -33323,13 +33314,13 @@ module stdlib_linalg_lapack_${ri}$ scale = one sum = min( m, n ) do j = 2, n - call stdlib_${ri}$lassq( min( m, j-1 ), a( 1, j ), 1, scale, sum ) + call stdlib${ii}$_${ri}$lassq( 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_${ri}$lassq( min( m, j ), a( 1, j ), 1, scale, sum ) + call stdlib${ii}$_${ri}$lassq( min( m, j ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum ) end do end if else @@ -33337,24 +33328,24 @@ module stdlib_linalg_lapack_${ri}$ scale = one sum = min( m, n ) do j = 1, n - call stdlib_${ri}$lassq( m-j, a( min( m, j+1 ), j ), 1, scale,sum ) + call stdlib${ii}$_${ri}$lassq( 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_${ri}$lassq( m-j+1, a( j, j ), 1, scale, sum ) + call stdlib${ii}$_${ri}$lassq( m-j+1, a( j, j ), 1_${ik}$, scale, sum ) end do end if end if value = scale*sqrt( sum ) end if - stdlib_${ri}$lantr = value + stdlib${ii}$_${ri}$lantr = value return - end function stdlib_${ri}$lantr + end function stdlib${ii}$_${ri}$lantr - pure subroutine stdlib_${ri}$lanv2( a, b, c, d, rt1r, rt1i, rt2r, rt2i, cs, sn ) + pure subroutine stdlib${ii}$_${ri}$lanv2( a, b, c, d, rt1r, rt1i, rt2r, rt2i, cs, sn ) !! DLANV2: computes the Schur factorization of a real 2-by-2 nonsymmetric !! matrix in standard form: !! [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ] @@ -33377,14 +33368,14 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars real(${rk}$) :: aa, bb, bcmax, bcmis, cc, cs1, dd, eps, p, sab, sac, scale, sigma, sn1, & tau, temp, z, safmin, safmn2, safmx2 - integer(ilp) :: count + integer(${ik}$) :: count ! Intrinsic Functions intrinsic :: abs,max,min,sign,sqrt ! Executable Statements - safmin = stdlib_${ri}$lamch( 'S' ) - eps = stdlib_${ri}$lamch( 'P' ) - safmn2 = stdlib_${ri}$lamch( 'B' )**int( log( safmin / eps ) /log( stdlib_${ri}$lamch( 'B' ) ) / & - two,KIND=ilp) + safmin = stdlib${ii}$_${ri}$lamch( 'S' ) + eps = stdlib${ii}$_${ri}$lamch( 'P' ) + safmn2 = stdlib${ii}$_${ri}$lamch( 'B' )**int( log( safmin / eps ) /log( stdlib${ii}$_${ri}$lamch( 'B' ) ) / & + two,KIND=${ik}$) safmx2 = one / safmn2 if( c==zero ) then cs = one @@ -33416,7 +33407,7 @@ module stdlib_linalg_lapack_${ri}$ a = d + z d = d - ( bcmax / z )*bcmis ! compute b and the rotation matrix - tau = stdlib_${ri}$lapy2( c, z ) + tau = stdlib${ii}$_${ri}$lapy2( c, z ) cs = z / tau sn = c / tau b = b - c @@ -33424,10 +33415,10 @@ module stdlib_linalg_lapack_${ri}$ else ! complex eigenvalues, or real(almost,KIND=${rk}$) equal eigenvalues. ! make diagonal elements equal. - count = 0 + count = 0_${ik}$ sigma = b + c 10 continue - count = count + 1 + count = count + 1_${ik}$ scale = max( abs(temp), abs(sigma) ) if( scale>=safmx2 ) then sigma = sigma * safmn2 @@ -33440,7 +33431,7 @@ module stdlib_linalg_lapack_${ri}$ if (count <= 20)goto 10 end if p = half*temp - tau = stdlib_${ri}$lapy2( sigma, temp ) + tau = stdlib${ii}$_${ri}$lapy2( sigma, temp ) cs = sqrt( half*( one+abs( sigma ) / tau ) ) sn = -( p / ( tau*cs ) )*sign( one, sigma ) ! compute [ aa bb ] = [ a b ] [ cs -sn ] @@ -33497,10 +33488,10 @@ module stdlib_linalg_lapack_${ri}$ rt2i = -rt1i end if return - end subroutine stdlib_${ri}$lanv2 + end subroutine stdlib${ii}$_${ri}$lanv2 - pure subroutine stdlib_${ri}$laorhr_col_getrfnp( m, n, a, lda, d, info ) + pure subroutine stdlib${ii}$_${ri}$laorhr_col_getrfnp( m, n, a, lda, d, info ) !! DLAORHR_COL_GETRFNP: computes the modified LU factorization without !! pivoting of a real general M-by-N matrix A. The factorization has !! the form: @@ -33538,52 +33529,52 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), 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}$, 'DLAORHR_COL_GETRFNP', ' ', m, n, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=min( m, n ) ) then ! use unblocked code. - call stdlib_${ri}$laorhr_col_getrfnp2( m, n, a, lda, d, info ) + call stdlib${ii}$_${ri}$laorhr_col_getrfnp2( m, n, a, lda, d, info ) else ! use blocked code. do j = 1, min( m, n ), nb jb = min( min( m, n )-j+1, nb ) ! factor diagonal and subdiagonal blocks. - call stdlib_${ri}$laorhr_col_getrfnp2( m-j+1, jb, a( j, j ), lda,d( j ), iinfo ) + call stdlib${ii}$_${ri}$laorhr_col_getrfnp2( m-j+1, jb, a( j, j ), lda,d( j ), iinfo ) if( j+jb<=n ) then ! compute block row of u. - call stdlib_${ri}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, one, & + call stdlib${ii}$_${ri}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, one, & a( j, j ), lda, a( j, j+jb ),lda ) if( j+jb<=m ) then ! update trailing submatrix. - call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& + call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& one, a( j+jb, j ), lda,a( j, j+jb ), lda, one, a( j+jb, j+jb ),lda ) end if @@ -33591,10 +33582,10 @@ module stdlib_linalg_lapack_${ri}$ end do end if return - end subroutine stdlib_${ri}$laorhr_col_getrfnp + end subroutine stdlib${ii}$_${ri}$laorhr_col_getrfnp - pure recursive subroutine stdlib_${ri}$laorhr_col_getrfnp2( m, n, a, lda, d, info ) + pure recursive subroutine stdlib${ii}$_${ri}$laorhr_col_getrfnp2( m, n, a, lda, d, info ) !! DLAORHR_COL_GETRFNP2: computes the modified LU factorization without !! pivoting of a real general M-by-N matrix A. The factorization has !! the form: @@ -33647,8 +33638,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(inout) :: a(lda,*) real(${rk}$), intent(out) :: d(*) @@ -33656,75 +33647,75 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars real(${rk}$) :: 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_${ri}$scal( m-1, one / a( 1, 1 ), a( 2, 1 ), 1 ) + if( abs( a( 1_${ik}$, 1_${ik}$ ) ) >= sfmin ) then + call stdlib${ii}$_${ri}$scal( 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_${ri}$laorhr_col_getrfnp2( n1, n1, a, lda, d, iinfo ) + call stdlib${ii}$_${ri}$laorhr_col_getrfnp2( n1, n1, a, lda, d, iinfo ) ! solve for b21 - call stdlib_${ri}$trsm( 'R', 'U', 'N', 'N', m-n1, n1, one, a, lda,a( n1+1, 1 ), lda ) + call stdlib${ii}$_${ri}$trsm( 'R', 'U', 'N', 'N', m-n1, n1, one, a, lda,a( n1+1, 1_${ik}$ ), lda ) ! solve for b12 - call stdlib_${ri}$trsm( 'L', 'L', 'N', 'U', n1, n2, one, a, lda,a( 1, n1+1 ), lda ) + call stdlib${ii}$_${ri}$trsm( '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_${ri}$gemm( 'N', 'N', m-n1, n2, n1, -one, a( n1+1, 1 ), lda,a( 1, n1+1 ), & + call stdlib${ii}$_${ri}$gemm( '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_${ri}$laorhr_col_getrfnp2( m-n1, n2, a( n1+1, n1+1 ), lda,d( n1+1 ), iinfo ) + call stdlib${ii}$_${ri}$laorhr_col_getrfnp2( m-n1, n2, a( n1+1, n1+1 ), lda,d( n1+1 ), iinfo ) end if return - end subroutine stdlib_${ri}$laorhr_col_getrfnp2 + end subroutine stdlib${ii}$_${ri}$laorhr_col_getrfnp2 - pure subroutine stdlib_${ri}$lapll( n, x, incx, y, incy, ssmin ) + pure subroutine stdlib${ii}$_${ri}$lapll( n, x, incx, y, incy, ssmin ) !! Given two column vectors X and Y, let !! A = ( X Y ). !! The subroutine first computes the QR factorization of A = Q*R, @@ -33735,7 +33726,7 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n real(${rk}$), intent(out) :: ssmin ! Array Arguments real(${rk}$), intent(inout) :: x(*), y(*) @@ -33745,26 +33736,26 @@ module stdlib_linalg_lapack_${ri}$ real(${rk}$) :: a11, a12, a22, c, ssmax, tau ! Executable Statements ! quick return if possible - if( n<=1 ) then + if( n<=1_${ik}$ ) then ssmin = zero return end if ! compute the qr factorization of the n-by-2 matrix ( x y ) - call stdlib_${ri}$larfg( n, x( 1 ), x( 1+incx ), incx, tau ) - a11 = x( 1 ) - x( 1 ) = one - c = -tau*stdlib_${ri}$dot( n, x, incx, y, incy ) - call stdlib_${ri}$axpy( n, c, x, incx, y, incy ) - call stdlib_${ri}$larfg( n-1, y( 1+incy ), y( 1+2*incy ), incy, tau ) - a12 = y( 1 ) - a22 = y( 1+incy ) + call stdlib${ii}$_${ri}$larfg( n, x( 1_${ik}$ ), x( 1_${ik}$+incx ), incx, tau ) + a11 = x( 1_${ik}$ ) + x( 1_${ik}$ ) = one + c = -tau*stdlib${ii}$_${ri}$dot( n, x, incx, y, incy ) + call stdlib${ii}$_${ri}$axpy( n, c, x, incx, y, incy ) + call stdlib${ii}$_${ri}$larfg( n-1, y( 1_${ik}$+incy ), y( 1_${ik}$+2*incy ), incy, tau ) + a12 = y( 1_${ik}$ ) + a22 = y( 1_${ik}$+incy ) ! compute the svd of 2-by-2 upper triangular matrix. - call stdlib_${ri}$las2( a11, a12, a22, ssmin, ssmax ) + call stdlib${ii}$_${ri}$las2( a11, a12, a22, ssmin, ssmax ) return - end subroutine stdlib_${ri}$lapll + end subroutine stdlib${ii}$_${ri}$lapll - pure subroutine stdlib_${ri}$lapmr( forwrd, m, n, x, ldx, k ) + pure subroutine stdlib${ii}$_${ri}$lapmr( forwrd, m, n, x, ldx, k ) !! DLAPMR: rearranges the rows of the M by N matrix X as specified !! by the permutation K(1),K(2),...,K(M) of the integers 1,...,M. !! If FORWRD = .TRUE., forward permutation: @@ -33776,13 +33767,13 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(inout) :: x(ldx,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, in, j, jj + integer(${ik}$) :: i, in, j, jj real(${rk}$) :: temp ! Executable Statements if( m<=1 )return @@ -33829,10 +33820,10 @@ module stdlib_linalg_lapack_${ri}$ end do end if return - end subroutine stdlib_${ri}$lapmr + end subroutine stdlib${ii}$_${ri}$lapmr - pure subroutine stdlib_${ri}$lapmt( forwrd, m, n, x, ldx, k ) + pure subroutine stdlib${ii}$_${ri}$lapmt( forwrd, m, n, x, ldx, k ) !! DLAPMT: rearranges the columns of the M by N matrix X as specified !! by the permutation K(1),K(2),...,K(N) of the integers 1,...,N. !! If FORWRD = .TRUE., forward permutation: @@ -33844,13 +33835,13 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(inout) :: x(ldx,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ii, in, j + integer(${ik}$) :: i, ii, in, j real(${rk}$) :: temp ! Executable Statements if( n<=1 )return @@ -33897,10 +33888,10 @@ module stdlib_linalg_lapack_${ri}$ end do end if return - end subroutine stdlib_${ri}$lapmt + end subroutine stdlib${ii}$_${ri}$lapmt - pure real(${rk}$) function stdlib_${ri}$lapy2( x, y ) + pure real(${rk}$) function stdlib${ii}$_${ri}$lapy2( x, y ) !! DLAPY2: returns sqrt(x**2+y**2), taking care not to cause unnecessary !! overflow and unnecessary underflow. ! -- lapack auxiliary routine -- @@ -33917,27 +33908,27 @@ module stdlib_linalg_lapack_${ri}$ ! Intrinsic Functions intrinsic :: abs,max,min,sqrt ! Executable Statements - x_is_nan = stdlib_${ri}$isnan( x ) - y_is_nan = stdlib_${ri}$isnan( y ) - if ( x_is_nan ) stdlib_${ri}$lapy2 = x - if ( y_is_nan ) stdlib_${ri}$lapy2 = y - hugeval = stdlib_${ri}$lamch( 'OVERFLOW' ) + x_is_nan = stdlib${ii}$_${ri}$isnan( x ) + y_is_nan = stdlib${ii}$_${ri}$isnan( y ) + if ( x_is_nan ) stdlib${ii}$_${ri}$lapy2 = x + if ( y_is_nan ) stdlib${ii}$_${ri}$lapy2 = y + hugeval = stdlib${ii}$_${ri}$lamch( 'OVERFLOW' ) if ( .not.( x_is_nan.or.y_is_nan ) ) then xabs = abs( x ) yabs = abs( y ) w = max( xabs, yabs ) z = min( xabs, yabs ) if( z==zero .or. w>hugeval ) then - stdlib_${ri}$lapy2 = w + stdlib${ii}$_${ri}$lapy2 = w else - stdlib_${ri}$lapy2 = w*sqrt( one+( z / w )**2 ) + stdlib${ii}$_${ri}$lapy2 = w*sqrt( one+( z / w )**2_${ik}$ ) end if end if return - end function stdlib_${ri}$lapy2 + end function stdlib${ii}$_${ri}$lapy2 - pure real(${rk}$) function stdlib_${ri}$lapy3( x, y, z ) + pure real(${rk}$) function stdlib${ii}$_${ri}$lapy3( x, y, z ) !! DLAPY3: returns sqrt(x**2+y**2+z**2), taking care not to cause !! unnecessary overflow and unnecessary underflow. ! -- lapack auxiliary routine -- @@ -33952,7 +33943,7 @@ module stdlib_linalg_lapack_${ri}$ ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements - hugeval = stdlib_${ri}$lamch( 'OVERFLOW' ) + hugeval = stdlib${ii}$_${ri}$lamch( 'OVERFLOW' ) xabs = abs( x ) yabs = abs( y ) zabs = abs( z ) @@ -33961,15 +33952,15 @@ module stdlib_linalg_lapack_${ri}$ ! w can be zero for max(0,nan,0) ! adding all three entries together will make sure ! nan will not disappear. - stdlib_${ri}$lapy3 = xabs + yabs + zabs + stdlib${ii}$_${ri}$lapy3 = xabs + yabs + zabs else - stdlib_${ri}$lapy3 = w*sqrt( ( xabs / w )**2+( yabs / w )**2+( zabs / w )**2 ) + stdlib${ii}$_${ri}$lapy3 = w*sqrt( ( xabs / w )**2_${ik}$+( yabs / w )**2_${ik}$+( zabs / w )**2_${ik}$ ) end if return - end function stdlib_${ri}$lapy3 + end function stdlib${ii}$_${ri}$lapy3 - pure subroutine stdlib_${ri}$laqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) + pure subroutine stdlib${ii}$_${ri}$laqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) !! DLAQGB: equilibrates a general M by N band matrix A with KL !! subdiagonals and KU superdiagonals using the row and scaling factors !! in the vectors R and C. @@ -33979,7 +33970,7 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: amax, colcnd, rowcnd ! Array Arguments real(${rk}$), intent(inout) :: ab(ldab,*) @@ -33989,18 +33980,18 @@ module stdlib_linalg_lapack_${ri}$ real(${rk}$), parameter :: thresh = 0.1e+0_${rk}$ ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(${rk}$) :: 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_${ri}$lamch( 'SAFE MINIMUM' ) / stdlib_${ri}$lamch( 'PRECISION' ) + small = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${ri}$lamch( 'PRECISION' ) large = one / small if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then ! no row scaling @@ -34036,10 +34027,10 @@ module stdlib_linalg_lapack_${ri}$ equed = 'B' end if return - end subroutine stdlib_${ri}$laqgb + end subroutine stdlib${ii}$_${ri}$laqgb - pure subroutine stdlib_${ri}$laqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed ) + pure subroutine stdlib${ii}$_${ri}$laqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed ) !! DLAQGE: equilibrates a general M by N matrix A using the row and !! column scaling factors in the vectors R and C. ! -- lapack auxiliary routine -- @@ -34047,7 +34038,7 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: amax, colcnd, rowcnd ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) @@ -34057,16 +34048,16 @@ module stdlib_linalg_lapack_${ri}$ real(${rk}$), parameter :: thresh = 0.1e+0_${rk}$ ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(${rk}$) :: 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_${ri}$lamch( 'SAFE MINIMUM' ) / stdlib_${ri}$lamch( 'PRECISION' ) + small = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${ri}$lamch( 'PRECISION' ) large = one / small if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then ! no row scaling @@ -34102,10 +34093,10 @@ module stdlib_linalg_lapack_${ri}$ equed = 'B' end if return - end subroutine stdlib_${ri}$laqge + end subroutine stdlib${ii}$_${ri}$laqge - pure subroutine stdlib_${ri}$laqp2( m, n, offset, a, lda, jpvt, tau, vn1, vn2,work ) + pure subroutine stdlib${ii}$_${ri}$laqp2( m, n, offset, a, lda, jpvt, tau, vn1, vn2,work ) !! DLAQP2: computes a QR factorization with column pivoting of !! the block A(OFFSET+1:M,1:N). !! The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. @@ -34113,28 +34104,28 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, m, n, offset + integer(${ik}$), intent(in) :: lda, m, n, offset ! Array Arguments - integer(ilp), intent(inout) :: jpvt(*) + integer(${ik}$), intent(inout) :: jpvt(*) real(${rk}$), intent(inout) :: a(lda,*), vn1(*), vn2(*) real(${rk}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, itemp, j, mn, offpi, pvt + integer(${ik}$) :: i, itemp, j, mn, offpi, pvt real(${rk}$) :: aii, temp, temp2, tol3z ! Intrinsic Functions intrinsic :: abs,max,min,sqrt ! Executable Statements mn = min( m-offset, n ) - tol3z = sqrt(stdlib_${ri}$lamch('EPSILON')) + tol3z = sqrt(stdlib${ii}$_${ri}$lamch('EPSILON')) ! compute factorization. loop_20: do i = 1, mn offpi = offset + i ! determine ith pivot column and swap if necessary. - pvt = ( i-1 ) + stdlib_i${ri}$amax( n-i+1, vn1( i ), 1 ) + pvt = ( i-1 ) + stdlib${ii}$_i${ri}$amax( n-i+1, vn1( i ), 1_${ik}$ ) if( pvt/=i ) then - call stdlib_${ri}$swap( m, a( 1, pvt ), 1, a( 1, i ), 1 ) + call stdlib${ii}$_${ri}$swap( m, a( 1_${ik}$, pvt ), 1_${ik}$, a( 1_${ik}$, i ), 1_${ik}$ ) itemp = jpvt( pvt ) jpvt( pvt ) = jpvt( i ) jpvt( i ) = itemp @@ -34143,17 +34134,17 @@ module stdlib_linalg_lapack_${ri}$ end if ! generate elementary reflector h(i). if( offpi1 ) then - call stdlib_${ri}$gemv( 'NO TRANSPOSE', m-rk+1, k-1, -one, a( rk, 1 ),lda, f( k, 1 ), & - ldf, one, a( rk, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', m-rk+1, k-1, -one, a( rk, 1_${ik}$ ),lda, f( k, 1_${ik}$ ), & + ldf, one, a( rk, k ), 1_${ik}$ ) end if ! generate elementary reflector h(k). if( rk1 ) then - call stdlib_${ri}$gemv( 'TRANSPOSE', m-rk+1, k-1, -tau( k ), a( rk, 1 ),lda, a( rk, k & - ), 1, zero, auxv( 1 ), 1 ) - call stdlib_${ri}$gemv( 'NO TRANSPOSE', n, k-1, one, f( 1, 1 ), ldf,auxv( 1 ), 1, one,& - f( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', m-rk+1, k-1, -tau( k ), a( rk, 1_${ik}$ ),lda, a( rk, k & + ), 1_${ik}$, zero, auxv( 1_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', n, k-1, one, f( 1_${ik}$, 1_${ik}$ ), ldf,auxv( 1_${ik}$ ), 1_${ik}$, one,& + f( 1_${ik}$, k ), 1_${ik}$ ) end if ! update the current row of a: ! a(rk,k+1:n) := a(rk,k+1:n) - a(rk,1:k)*f(k+1:n,1:k)**t. if( k0 ) then - itemp = nint( vn2( lsticc ),KIND=ilp) - vn1( lsticc ) = stdlib_${ri}$nrm2( m-rk, a( rk+1, lsticc ), 1 ) + if( lsticc>0_${ik}$ ) then + itemp = nint( vn2( lsticc ),KIND=${ik}$) + vn1( lsticc ) = stdlib${ii}$_${ri}$nrm2( m-rk, a( rk+1, lsticc ), 1_${ik}$ ) ! note: the computation of vn1( lsticc ) relies on the fact that - ! stdlib_dnrm2 does not fail on vectors with norm below the value of - ! sqrt(stdlib_${ri}$lamch('s')) + ! stdlib${ii}$_dnrm2 does not fail on vectors with norm below the value of + ! sqrt(stdlib${ii}$_${ri}$lamch('s')) vn2( lsticc ) = vn1( lsticc ) lsticc = itemp go to 40 end if return - end subroutine stdlib_${ri}$laqps + end subroutine stdlib${ii}$_${ri}$laqps - subroutine stdlib_${ri}$laqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, work,& + subroutine stdlib${ii}$_${ri}$laqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, work,& !! DLAQR0: computes the eigenvalues of a Hessenberg matrix H !! and, optionally, the matrices T and Z from the Schur decomposition !! H = Z T Z**T, where T is an upper quasi-triangular matrix (the @@ -34330,21 +34321,21 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, ihiz, ilo, iloz, ldh, ldz, lwork, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ihiz, ilo, iloz, ldh, ldz, lwork, n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt, wantz ! Array Arguments real(${rk}$), intent(inout) :: h(ldh,*), z(ldz,*) real(${rk}$), intent(out) :: wi(*), work(*), wr(*) ! ================================================================ ! Parameters - integer(ilp), parameter :: ntiny = 15 - integer(ilp), parameter :: kexnw = 5 - integer(ilp), parameter :: kexsh = 6 + integer(${ik}$), parameter :: ntiny = 15_${ik}$ + integer(${ik}$), parameter :: kexnw = 5_${ik}$ + integer(${ik}$), parameter :: kexsh = 6_${ik}$ real(${rk}$), parameter :: wilk1 = 0.75_${rk}$ real(${rk}$), parameter :: wilk2 = -0.4375_${rk}$ ! ==== matrices of order ntiny or smaller must be processed by - ! . stdlib_${ri}$lahqr because of insufficient subdiagonal scratch space. + ! . stdlib${ii}$_${ri}$lahqr because of insufficient subdiagonal scratch space. ! . (this is a hard limit.) ==== ! ==== exceptional deflation windows: try to cure rare @@ -34361,92 +34352,92 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars real(${rk}$) :: aa, bb, cc, cs, dd, sn, ss, swap - integer(ilp) :: i, inf, it, itmax, k, kacc22, kbot, kdu, ks, kt, ktop, ku, kv, kwh, & + integer(${ik}$) :: i, inf, it, itmax, k, kacc22, kbot, kdu, ks, kt, ktop, ku, kv, kwh, & kwtop, kwv, ld, ls, lwkopt, ndec, ndfl, nh, nho, nibble, nmin, ns, nsmax, nsr, nve, nw,& nwmax, nwr, nwupbd logical(lk) :: sorted - character :: jbcmpz*2 + character(len=2_${ik}$) :: jbcmpz ! Local Arrays - real(${rk}$) :: zdum(1,1) + real(${rk}$) :: zdum(1_${ik}$,1_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,int,max,min,mod ! Executable Statements - info = 0 + info = 0_${ik}$ ! ==== quick return for n = 0: nothing to do. ==== - if( n==0 ) then - work( 1 ) = one + if( n==0_${ik}$ ) then + work( 1_${ik}$ ) = one return end if if( n<=ntiny ) then ! ==== tiny matrices must use stdlib_${ri}$lahqr. ==== - lwkopt = 1 - if( lwork/=-1 )call stdlib_${ri}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, & + lwkopt = 1_${ik}$ + if( lwork/=-1_${ik}$ )call stdlib${ii}$_${ri}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, & ihiz, z, ldz, info ) else ! ==== use small bulge multi-shift qr with aggressive early ! . deflation on larger-than-tiny matrices. ==== ! ==== hope for the best. ==== - info = 0 - ! ==== set up job flags for stdlib_ilaenv. ==== + info = 0_${ik}$ + ! ==== set up job flags for stdlib${ii}$_ilaenv. ==== if( wantt ) then - jbcmpz( 1: 1 ) = 'S' + jbcmpz( 1_${ik}$: 1_${ik}$ ) = 'S' else - jbcmpz( 1: 1 ) = 'E' + jbcmpz( 1_${ik}$: 1_${ik}$ ) = 'E' end if if( wantz ) then - jbcmpz( 2: 2 ) = 'V' + jbcmpz( 2_${ik}$: 2_${ik}$ ) = 'V' else - jbcmpz( 2: 2 ) = 'N' + jbcmpz( 2_${ik}$: 2_${ik}$ ) = 'N' end if ! ==== nwr = recommended deflation window size. at this ! . point, n > ntiny = 15, so there is enough ! . subdiagonal workspace for nwr>=2 as required. ! . (in fact, there is enough subdiagonal space for ! . nwr>=4.) ==== - nwr = stdlib_ilaenv( 13, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork ) - nwr = max( 2, nwr ) - nwr = min( ihi-ilo+1, ( n-1 ) / 3, nwr ) + nwr = stdlib${ii}$_ilaenv( 13_${ik}$, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork ) + nwr = max( 2_${ik}$, nwr ) + nwr = min( ihi-ilo+1, ( n-1 ) / 3_${ik}$, nwr ) ! ==== nsr = recommended number of simultaneous shifts. ! . at this point n > ntiny = 15, so there is at ! . enough subdiagonal workspace for nsr to be even ! . and greater than or equal to two as required. ==== - nsr = stdlib_ilaenv( 15, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork ) - nsr = min( nsr, ( n-3 ) / 6, ihi-ilo ) - nsr = max( 2, nsr-mod( nsr, 2 ) ) + nsr = stdlib${ii}$_ilaenv( 15_${ik}$, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork ) + nsr = min( nsr, ( n-3 ) / 6_${ik}$, ihi-ilo ) + nsr = max( 2_${ik}$, nsr-mod( nsr, 2_${ik}$ ) ) ! ==== estimate optimal workspace ==== - ! ==== workspace query call to stdlib_${ri}$laqr3 ==== - call stdlib_${ri}$laqr3( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& - ld, wr, wi, h, ldh, n, h, ldh,n, h, ldh, work, -1 ) - ! ==== optimal workspace = max(stdlib_${ri}$laqr5, stdlib_${ri}$laqr3) ==== - lwkopt = max( 3*nsr / 2, int( work( 1 ),KIND=ilp) ) + ! ==== workspace query call to stdlib${ii}$_${ri}$laqr3 ==== + call stdlib${ii}$_${ri}$laqr3( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& + ld, wr, wi, h, ldh, n, h, ldh,n, h, ldh, work, -1_${ik}$ ) + ! ==== optimal workspace = max(stdlib${ii}$_${ri}$laqr5, stdlib${ii}$_${ri}$laqr3) ==== + lwkopt = max( 3_${ik}$*nsr / 2_${ik}$, int( work( 1_${ik}$ ),KIND=${ik}$) ) ! ==== quick return in case of workspace query. ==== - if( lwork==-1 ) then - work( 1 ) = real( lwkopt,KIND=${rk}$) + if( lwork==-1_${ik}$ ) then + work( 1_${ik}$ ) = real( lwkopt,KIND=${rk}$) return end if - ! ==== stdlib_${ri}$lahqr/stdlib_${ri}$laqr0 crossover point ==== - nmin = stdlib_ilaenv( 12, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork ) + ! ==== stdlib${ii}$_${ri}$lahqr/stdlib${ii}$_${ri}$laqr0 crossover point ==== + nmin = stdlib${ii}$_ilaenv( 12_${ik}$, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork ) nmin = max( ntiny, nmin ) ! ==== nibble crossover point ==== - nibble = stdlib_ilaenv( 14, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork ) - nibble = max( 0, nibble ) + nibble = stdlib${ii}$_ilaenv( 14_${ik}$, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork ) + nibble = max( 0_${ik}$, nibble ) ! ==== accumulate reflections during ttswp? use block ! . 2-by-2 structure during matrix-matrix multiply? ==== - kacc22 = stdlib_ilaenv( 16, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork ) - kacc22 = max( 0, kacc22 ) - kacc22 = min( 2, kacc22 ) + kacc22 = stdlib${ii}$_ilaenv( 16_${ik}$, 'DLAQR0', jbcmpz, n, ilo, ihi, lwork ) + kacc22 = max( 0_${ik}$, kacc22 ) + kacc22 = min( 2_${ik}$, kacc22 ) ! ==== nwmax = the largest possible deflation window for ! . which there is sufficient workspace. ==== - nwmax = min( ( n-1 ) / 3, lwork / 2 ) + nwmax = min( ( n-1 ) / 3_${ik}$, lwork / 2_${ik}$ ) nw = nwmax ! ==== nsmax = the largest number of simultaneous shifts ! . for which there is sufficient workspace. ==== - nsmax = min( ( n-3 ) / 6, 2*lwork / 3 ) - nsmax = nsmax - mod( nsmax, 2 ) + nsmax = min( ( n-3 ) / 6_${ik}$, 2_${ik}$*lwork / 3_${ik}$ ) + nsmax = nsmax - mod( nsmax, 2_${ik}$ ) ! ==== ndfl: an iteration count restarted at deflation. ==== - ndfl = 1 + ndfl = 1_${ik}$ ! ==== itmax = iteration limit ==== - itmax = max( 30, 2*kexsh )*max( 10, ( ihi-ilo+1 ) ) + itmax = max( 30_${ik}$, 2_${ik}$*kexsh )*max( 10_${ik}$, ( ihi-ilo+1 ) ) ! ==== last row and column in the active block ==== kbot = ihi ! ==== main loop ==== @@ -34474,27 +34465,27 @@ module stdlib_linalg_lapack_${ri}$ ! . in general, more powerful than smaller ones, ! . rapidly increase the window to the maximum possible. ! . then, gradually reduce the window size. ==== - nh = kbot - ktop + 1 + nh = kbot - ktop + 1_${ik}$ nwupbd = min( nh, nwmax ) if( ndfl=nh-1 ) then nw = nh else - kwtop = kbot - nw + 1 + kwtop = kbot - nw + 1_${ik}$ if( abs( h( kwtop, kwtop-1 ) )>abs( h( kwtop-1, kwtop-2 ) ) )nw = nw + & - 1 + 1_${ik}$ end if end if if( ndfl=0 .or. nw>=nwupbd ) then - ndec = ndec + 1 - if( nw-ndec<2 )ndec = 0 + ndec = -1_${ik}$ + else if( ndec>=0_${ik}$ .or. nw>=nwupbd ) then + ndec = ndec + 1_${ik}$ + if( nw-ndec<2_${ik}$ )ndec = 0_${ik}$ nw = nw - ndec end if ! ==== aggressive early deflation: @@ -34507,46 +34498,46 @@ module stdlib_linalg_lapack_${ri}$ ! . - an at-least-nw-but-more-is-better (nhv-by-nw) ! . vertical work array along the left-hand-edge. ! . ==== - kv = n - nw + 1 - kt = nw + 1 - nho = ( n-nw-1 ) - kt + 1 - kwv = nw + 2 - nve = ( n-nw ) - kwv + 1 + kv = n - nw + 1_${ik}$ + kt = nw + 1_${ik}$ + nho = ( n-nw-1 ) - kt + 1_${ik}$ + kwv = nw + 2_${ik}$ + nve = ( n-nw ) - kwv + 1_${ik}$ ! ==== aggressive early deflation ==== - call stdlib_${ri}$laqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & - ls, ld, wr, wi, h( kv, 1 ), ldh,nho, h( kv, kt ), ldh, nve, h( kwv, 1 ), ldh,& + call stdlib${ii}$_${ri}$laqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & + ls, ld, wr, wi, h( kv, 1_${ik}$ ), ldh,nho, h( kv, kt ), ldh, nve, h( kwv, 1_${ik}$ ), ldh,& work, lwork ) ! ==== adjust kbot accounting for new deflations. ==== kbot = kbot - ld ! ==== ks points to the shifts. ==== - ks = kbot - ls + 1 + ks = kbot - ls + 1_${ik}$ ! ==== skip an expensive qr sweep if there is a (partly ! . heuristic) reason to expect that many eigenvalues ! . will deflate without it. here, the qr sweep is ! . skipped if many eigenvalues have just been deflated ! . or if the remaining active block is small. - if( ( ld==0 ) .or. ( ( 100*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& + if( ( ld==0_${ik}$ ) .or. ( ( 100_${ik}$*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& ) ) ) then ! ==== ns = nominal number of simultaneous shifts. - ! . this may be lowered (slightly) if stdlib_${ri}$laqr3 + ! . this may be lowered (slightly) if stdlib${ii}$_${ri}$laqr3 ! . did not provide that many shifts. ==== - ns = min( nsmax, nsr, max( 2, kbot-ktop ) ) - ns = ns - mod( ns, 2 ) + ns = min( nsmax, nsr, max( 2_${ik}$, kbot-ktop ) ) + ns = ns - mod( ns, 2_${ik}$ ) ! ==== if there have been no deflations ! . in a multiple of kexsh iterations, ! . then try exceptional shifts. ! . otherwise use shifts provided by - ! . stdlib_${ri}$laqr3 above or from the eigenvalues + ! . stdlib${ii}$_${ri}$laqr3 above or from the eigenvalues ! . of a trailing principal submatrix. ==== - if( mod( ndfl, kexsh )==0 ) then - ks = kbot - ns + 1 + if( mod( ndfl, kexsh )==0_${ik}$ ) then + ks = kbot - ns + 1_${ik}$ do i = kbot, max( ks+1, ktop+2 ), -2 ss = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) ) aa = wilk1*ss + h( i, i ) bb = ss cc = wilk2*ss dd = aa - call stdlib_${ri}$lanv2( aa, bb, cc, dd, wr( i-1 ), wi( i-1 ),wr( i ), wi( i & + call stdlib${ii}$_${ri}$lanv2( aa, bb, cc, dd, wr( i-1 ), wi( i-1 ),wr( i ), wi( i & ), cs, sn ) end do if( ks==ktop ) then @@ -34557,21 +34548,21 @@ module stdlib_linalg_lapack_${ri}$ end if else ! ==== got ns/2 or fewer shifts? use stdlib_${ri}$laqr4 or - ! . stdlib_${ri}$lahqr on a trailing principal submatrix to + ! . stdlib${ii}$_${ri}$lahqr on a trailing principal submatrix to ! . get more. (since ns<=nsmax<=(n-3)/6, ! . there is enough space below the subdiagonal ! . to fit an ns-by-ns scratch array.) ==== - if( kbot-ks+1<=ns / 2 ) then - ks = kbot - ns + 1 - kt = n - ns + 1 - call stdlib_${ri}$lacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1 ), ldh ) + if( kbot-ks+1<=ns / 2_${ik}$ ) then + ks = kbot - ns + 1_${ik}$ + kt = n - ns + 1_${ik}$ + call stdlib${ii}$_${ri}$lacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1_${ik}$ ), ldh ) if( ns>nmin ) then - call stdlib_${ri}$laqr4( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, wr( & - ks ),wi( ks ), 1, 1, zdum, 1, work,lwork, inf ) + call stdlib${ii}$_${ri}$laqr4( .false., .false., ns, 1_${ik}$, ns,h( kt, 1_${ik}$ ), ldh, wr( & + ks ),wi( ks ), 1_${ik}$, 1_${ik}$, zdum, 1_${ik}$, work,lwork, inf ) else - call stdlib_${ri}$lahqr( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, wr( & - ks ),wi( ks ), 1, 1, zdum, 1, inf ) + call stdlib${ii}$_${ri}$lahqr( .false., .false., ns, 1_${ik}$, ns,h( kt, 1_${ik}$ ), ldh, wr( & + ks ),wi( ks ), 1_${ik}$, 1_${ik}$, zdum, 1_${ik}$, inf ) end if ks = ks + inf ! ==== in case of a rare qr failure use @@ -34582,9 +34573,9 @@ module stdlib_linalg_lapack_${ri}$ cc = h( kbot, kbot-1 ) bb = h( kbot-1, kbot ) dd = h( kbot, kbot ) - call stdlib_${ri}$lanv2( aa, bb, cc, dd, wr( kbot-1 ),wi( kbot-1 ), wr( & + call stdlib${ii}$_${ri}$lanv2( aa, bb, cc, dd, wr( kbot-1 ),wi( kbot-1 ), wr( & kbot ),wi( kbot ), cs, sn ) - ks = kbot - 1 + ks = kbot - 1_${ik}$ end if end if if( kbot-ks+1>ns ) then @@ -34630,7 +34621,7 @@ module stdlib_linalg_lapack_${ri}$ end if ! ==== if there are only two shifts and both are ! . real, then use only one. ==== - if( kbot-ks+1==2 ) then + if( kbot-ks+1==2_${ik}$ ) then if( wi( kbot )==zero ) then if( abs( wr( kbot )-h( kbot, kbot ) )0 ) then - ndfl = 1 + if( ld>0_${ik}$ ) then + ndfl = 1_${ik}$ else - ndfl = ndfl + 1 + ndfl = ndfl + 1_${ik}$ end if ! ==== end of main loop ==== end do loop_80 @@ -34682,11 +34673,11 @@ module stdlib_linalg_lapack_${ri}$ 90 continue end if ! ==== return the optimal value of lwork. ==== - work( 1 ) = real( lwkopt,KIND=${rk}$) - end subroutine stdlib_${ri}$laqr0 + work( 1_${ik}$ ) = real( lwkopt,KIND=${rk}$) + end subroutine stdlib${ii}$_${ri}$laqr0 - pure subroutine stdlib_${ri}$laqr1( n, h, ldh, sr1, si1, sr2, si2, v ) + pure subroutine stdlib${ii}$_${ri}$laqr1( n, h, ldh, sr1, si1, sr2, si2, v ) !! Given a 2-by-2 or 3-by-3 matrix H, DLAQR1: sets v to a !! scalar multiple of the first column of the product !! (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I) @@ -34702,7 +34693,7 @@ module stdlib_linalg_lapack_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${rk}$), intent(in) :: si1, si2, sr1, sr2 - integer(ilp), intent(in) :: ldh, n + integer(${ik}$), intent(in) :: ldh, n ! Array Arguments real(${rk}$), intent(in) :: h(ldh,*) real(${rk}$), intent(out) :: v(*) @@ -34714,39 +34705,39 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$laqr1 + end subroutine stdlib${ii}$_${ri}$laqr1 - subroutine stdlib_${ri}$laqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, ns, nd,& + subroutine stdlib${ii}$_${ri}$laqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, ns, nd,& !! DLAQR2: is identical to DLAQR3 except that it avoids !! recursion by calling DLAHQR instead of DLAQR4. !! Aggressive early deflation: @@ -34763,9 +34754,9 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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) :: ihiz, iloz, kbot, ktop, ldh, ldt, ldv, ldwv, ldz, lwork, n,& + integer(${ik}$), intent(in) :: ihiz, iloz, kbot, ktop, ldh, ldt, ldv, ldwv, ldz, lwork, n,& nh, nv, nw - integer(ilp), intent(out) :: nd, ns + integer(${ik}$), intent(out) :: nd, ns logical(lk), intent(in) :: wantt, wantz ! Array Arguments real(${rk}$), intent(inout) :: h(ldh,*), z(ldz,*) @@ -34775,7 +34766,7 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars real(${rk}$) :: aa, bb, beta, cc, cs, dd, evi, evk, foo, s, safmax, safmin, smlnum, sn, & tau, ulp - integer(ilp) :: i, ifst, ilst, info, infqr, j, jw, k, kcol, kend, kln, krow, kwtop, & + integer(${ik}$) :: i, ifst, ilst, info, infqr, j, jw, k, kcol, kend, kln, krow, kwtop, & ltop, lwk1, lwk2, lwkopt logical(lk) :: bulge, sorted ! Intrinsic Functions @@ -34783,41 +34774,41 @@ module stdlib_linalg_lapack_${ri}$ ! Executable Statements ! ==== estimate optimal workspace. ==== jw = min( nw, kbot-ktop+1 ) - if( jw<=2 ) then - lwkopt = 1 - else - ! ==== workspace query call to stdlib_${ri}$gehrd ==== - call stdlib_${ri}$gehrd( jw, 1, jw-1, t, ldt, work, work, -1, info ) - lwk1 = int( work( 1 ),KIND=ilp) - ! ==== workspace query call to stdlib_${ri}$ormhr ==== - call stdlib_${ri}$ormhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv,work, -1, info ) + if( jw<=2_${ik}$ ) then + lwkopt = 1_${ik}$ + else + ! ==== workspace query call to stdlib${ii}$_${ri}$gehrd ==== + call stdlib${ii}$_${ri}$gehrd( jw, 1_${ik}$, jw-1, t, ldt, work, work, -1_${ik}$, info ) + lwk1 = int( work( 1_${ik}$ ),KIND=${ik}$) + ! ==== workspace query call to stdlib${ii}$_${ri}$ormhr ==== + call stdlib${ii}$_${ri}$ormhr( 'R', 'N', jw, jw, 1_${ik}$, jw-1, t, ldt, work, v, ldv,work, -1_${ik}$, info ) - lwk2 = int( work( 1 ),KIND=ilp) + lwk2 = int( work( 1_${ik}$ ),KIND=${ik}$) ! ==== optimal workspace ==== lwkopt = jw + max( lwk1, lwk2 ) end if ! ==== quick return in case of workspace query. ==== - if( lwork==-1 ) then - work( 1 ) = real( lwkopt,KIND=${rk}$) + if( lwork==-1_${ik}$ ) then + work( 1_${ik}$ ) = real( lwkopt,KIND=${rk}$) return end if ! ==== nothing to do ... ! ... for an empty active block ... ==== - ns = 0 - nd = 0 - work( 1 ) = one + ns = 0_${ik}$ + nd = 0_${ik}$ + work( 1_${ik}$ ) = one if( ktop>kbot )return ! ... nor for an empty deflation window. ==== if( nw<1 )return ! ==== machine constants ==== - safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) safmax = one / safmin - call stdlib_${ri}$labad( safmin, safmax ) - ulp = stdlib_${ri}$lamch( 'PRECISION' ) + call stdlib${ii}$_${ri}$labad( safmin, safmax ) + ulp = stdlib${ii}$_${ri}$lamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=${rk}$) / ulp ) ! ==== setup deflation window ==== jw = min( nw, kbot-ktop+1 ) - kwtop = kbot - jw + 1 + kwtop = kbot - jw + 1_${ik}$ if( kwtop==ktop ) then s = zero else @@ -34827,14 +34818,14 @@ module stdlib_linalg_lapack_${ri}$ ! ==== 1-by-1 deflation window: not much to do ==== sr( kwtop ) = h( kwtop, kwtop ) si( kwtop ) = zero - ns = 1 - nd = 0 + ns = 1_${ik}$ + nd = 0_${ik}$ if( abs( s )<=max( smlnum, ulp*abs( h( kwtop, kwtop ) ) ) )then - ns = 0 - nd = 1 + ns = 0_${ik}$ + nd = 1_${ik}$ if( kwtop>ktop )h( kwtop, kwtop-1 ) = zero end if - work( 1 ) = one + work( 1_${ik}$ ) = one return end if ! ==== convert to spike-triangular form. (in case of a @@ -34842,23 +34833,23 @@ module stdlib_linalg_lapack_${ri}$ ! . aggressive early deflation using that part of ! . the deflation window that converged using infqr ! . here and there to keep track.) ==== - call stdlib_${ri}$lacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) - call stdlib_${ri}$copy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 ) - call stdlib_${ri}$laset( 'A', jw, jw, zero, one, v, ldv ) - call stdlib_${ri}$lahqr( .true., .true., jw, 1, jw, t, ldt, sr( kwtop ),si( kwtop ), 1, jw, & + call stdlib${ii}$_${ri}$lacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) + call stdlib${ii}$_${ri}$copy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2_${ik}$, 1_${ik}$ ), ldt+1 ) + call stdlib${ii}$_${ri}$laset( 'A', jw, jw, zero, one, v, ldv ) + call stdlib${ii}$_${ri}$lahqr( .true., .true., jw, 1_${ik}$, jw, t, ldt, sr( kwtop ),si( kwtop ), 1_${ik}$, jw, & v, ldv, infqr ) - ! ==== stdlib_${ri}$trexc needs a clean margin near the diagonal ==== + ! ==== stdlib${ii}$_${ri}$trexc needs a clean margin near the diagonal ==== do j = 1, jw - 3 t( j+2, j ) = zero t( j+3, j ) = zero end do - if( jw>2 )t( jw, jw-2 ) = zero + if( jw>2_${ik}$ )t( jw, jw-2 ) = zero ! ==== deflation detection loop ==== ns = jw - ilst = infqr + 1 + ilst = infqr + 1_${ik}$ 20 continue if( ilst<=ns ) then - if( ns==1 ) then + if( ns==1_${ik}$ ) then bulge = .false. else bulge = t( ns, ns-1 )/=zero @@ -34868,56 +34859,56 @@ module stdlib_linalg_lapack_${ri}$ ! ==== real eigenvalue ==== foo = abs( t( ns, ns ) ) if( foo==zero )foo = abs( s ) - if( abs( s*v( 1, ns ) )<=max( smlnum, ulp*foo ) ) then + if( abs( s*v( 1_${ik}$, ns ) )<=max( smlnum, ulp*foo ) ) then ! ==== deflatable ==== - ns = ns - 1 + ns = ns - 1_${ik}$ else ! ==== undeflatable. move it up out of the way. - ! . (stdlib_${ri}$trexc can not fail in this case.) ==== + ! . (stdlib${ii}$_${ri}$trexc can not fail in this case.) ==== ifst = ns - call stdlib_${ri}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) - ilst = ilst + 1 + call stdlib${ii}$_${ri}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) + ilst = ilst + 1_${ik}$ end if else ! ==== complex conjugate pair ==== foo = abs( t( ns, ns ) ) + sqrt( abs( t( ns, ns-1 ) ) )*sqrt( abs( t( ns-1, ns ) & ) ) if( foo==zero )foo = abs( s ) - if( max( abs( s*v( 1, ns ) ), abs( s*v( 1, ns-1 ) ) )<=max( smlnum, ulp*foo ) ) & + if( max( abs( s*v( 1_${ik}$, ns ) ), abs( s*v( 1_${ik}$, ns-1 ) ) )<=max( smlnum, ulp*foo ) ) & then ! ==== deflatable ==== - ns = ns - 2 + ns = ns - 2_${ik}$ else ! ==== undeflatable. move them up out of the way. - ! . fortunately, stdlib_${ri}$trexc does the right thing with + ! . fortunately, stdlib${ii}$_${ri}$trexc does the right thing with ! . ilst in case of a rare exchange failure. ==== ifst = ns - call stdlib_${ri}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) - ilst = ilst + 2 + call stdlib${ii}$_${ri}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) + ilst = ilst + 2_${ik}$ end if end if ! ==== end deflation detection loop ==== go to 20 end if ! ==== return to hessenberg form ==== - if( ns==0 )s = zero + if( ns==0_${ik}$ )s = zero if( ns1 .and. s/=zero ) then + if( ns>1_${ik}$ .and. s/=zero ) then ! ==== reflect spike back into lower triangle ==== - call stdlib_${ri}$copy( ns, v, ldv, work, 1 ) - beta = work( 1 ) - call stdlib_${ri}$larfg( ns, beta, work( 2 ), 1, tau ) - work( 1 ) = one - call stdlib_${ri}$laset( 'L', jw-2, jw-2, zero, zero, t( 3, 1 ), ldt ) - call stdlib_${ri}$larf( 'L', ns, jw, work, 1, tau, t, ldt,work( jw+1 ) ) - call stdlib_${ri}$larf( 'R', ns, ns, work, 1, tau, t, ldt,work( jw+1 ) ) - call stdlib_${ri}$larf( 'R', jw, ns, work, 1, tau, v, ldv,work( jw+1 ) ) - call stdlib_${ri}$gehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) + call stdlib${ii}$_${ri}$copy( ns, v, ldv, work, 1_${ik}$ ) + beta = work( 1_${ik}$ ) + call stdlib${ii}$_${ri}$larfg( ns, beta, work( 2_${ik}$ ), 1_${ik}$, tau ) + work( 1_${ik}$ ) = one + call stdlib${ii}$_${ri}$laset( 'L', jw-2, jw-2, zero, zero, t( 3_${ik}$, 1_${ik}$ ), ldt ) + call stdlib${ii}$_${ri}$larf( 'L', ns, jw, work, 1_${ik}$, tau, t, ldt,work( jw+1 ) ) + call stdlib${ii}$_${ri}$larf( 'R', ns, ns, work, 1_${ik}$, tau, t, ldt,work( jw+1 ) ) + call stdlib${ii}$_${ri}$larf( 'R', jw, ns, work, 1_${ik}$, tau, v, ldv,work( jw+1 ) ) + call stdlib${ii}$_${ri}$gehrd( jw, 1_${ik}$, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) end if ! ==== copy updated reduced window into place ==== - if( kwtop>1 )h( kwtop, kwtop-1 ) = s*v( 1, 1 ) - call stdlib_${ri}$lacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) - call stdlib_${ri}$copy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) + if( kwtop>1_${ik}$ )h( kwtop, kwtop-1 ) = s*v( 1_${ik}$, 1_${ik}$ ) + call stdlib${ii}$_${ri}$lacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) + call stdlib${ii}$_${ri}$copy( jw-1, t( 2_${ik}$, 1_${ik}$ ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) ! ==== accumulate orthogonal matrix in order update ! . h and z, if requested. ==== - if( ns>1 .and. s/=zero )call stdlib_${ri}$ormhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, & + if( ns>1_${ik}$ .and. s/=zero )call stdlib${ii}$_${ri}$ormhr( 'R', 'N', jw, ns, 1_${ik}$, ns, t, ldt, work, & v, ldv,work( jw+1 ), lwork-jw, info ) ! ==== update vertical slab in h ==== if( wantt ) then - ltop = 1 + ltop = 1_${ik}$ else ltop = ktop end if do krow = ltop, kwtop - 1, nv kln = min( nv, kwtop-krow ) - call stdlib_${ri}$gemm( 'N', 'N', kln, jw, jw, one, h( krow, kwtop ),ldh, v, ldv, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', kln, jw, jw, one, h( krow, kwtop ),ldh, v, ldv, & zero, wv, ldwv ) - call stdlib_${ri}$lacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) + call stdlib${ii}$_${ri}$lacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) end do ! ==== update horizontal slab in h ==== if( wantt ) then do kcol = kbot + 1, n, nh kln = min( nh, n-kcol+1 ) - call stdlib_${ri}$gemm( 'C', 'N', jw, kln, jw, one, v, ldv,h( kwtop, kcol ), ldh, & + call stdlib${ii}$_${ri}$gemm( 'C', 'N', jw, kln, jw, one, v, ldv,h( kwtop, kcol ), ldh, & zero, t, ldt ) - call stdlib_${ri}$lacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) + call stdlib${ii}$_${ri}$lacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) end do end if ! ==== update vertical slab in z ==== if( wantz ) then do krow = iloz, ihiz, nv kln = min( nv, ihiz-krow+1 ) - call stdlib_${ri}$gemm( 'N', 'N', kln, jw, jw, one, z( krow, kwtop ),ldz, v, ldv, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', kln, jw, jw, one, z( krow, kwtop ),ldz, v, ldv, & zero, wv, ldwv ) - call stdlib_${ri}$lacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) + call stdlib${ii}$_${ri}$lacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) end do end if end if @@ -35045,11 +35036,11 @@ module stdlib_linalg_lapack_${ri}$ ! . window.) ==== ns = ns - infqr ! ==== return optimal workspace. ==== - work( 1 ) = real( lwkopt,KIND=${rk}$) - end subroutine stdlib_${ri}$laqr2 + work( 1_${ik}$ ) = real( lwkopt,KIND=${rk}$) + end subroutine stdlib${ii}$_${ri}$laqr2 - subroutine stdlib_${ri}$laqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, ns, nd,& + subroutine stdlib${ii}$_${ri}$laqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, ns, nd,& !! Aggressive early deflation: !! DLAQR3: accepts as input an upper Hessenberg matrix !! H and performs an orthogonal similarity transformation @@ -35064,9 +35055,9 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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) :: ihiz, iloz, kbot, ktop, ldh, ldt, ldv, ldwv, ldz, lwork, n,& + integer(${ik}$), intent(in) :: ihiz, iloz, kbot, ktop, ldh, ldt, ldv, ldwv, ldz, lwork, n,& nh, nv, nw - integer(ilp), intent(out) :: nd, ns + integer(${ik}$), intent(out) :: nd, ns logical(lk), intent(in) :: wantt, wantz ! Array Arguments real(${rk}$), intent(inout) :: h(ldh,*), z(ldz,*) @@ -35076,7 +35067,7 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars real(${rk}$) :: aa, bb, beta, cc, cs, dd, evi, evk, foo, s, safmax, safmin, smlnum, sn, & tau, ulp - integer(ilp) :: i, ifst, ilst, info, infqr, j, jw, k, kcol, kend, kln, krow, kwtop, & + integer(${ik}$) :: i, ifst, ilst, info, infqr, j, jw, k, kcol, kend, kln, krow, kwtop, & ltop, lwk1, lwk2, lwk3, lwkopt, nmin logical(lk) :: bulge, sorted ! Intrinsic Functions @@ -35084,45 +35075,45 @@ module stdlib_linalg_lapack_${ri}$ ! Executable Statements ! ==== estimate optimal workspace. ==== jw = min( nw, kbot-ktop+1 ) - if( jw<=2 ) then - lwkopt = 1 - else - ! ==== workspace query call to stdlib_${ri}$gehrd ==== - call stdlib_${ri}$gehrd( jw, 1, jw-1, t, ldt, work, work, -1, info ) - lwk1 = int( work( 1 ),KIND=ilp) - ! ==== workspace query call to stdlib_${ri}$ormhr ==== - call stdlib_${ri}$ormhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv,work, -1, info ) + if( jw<=2_${ik}$ ) then + lwkopt = 1_${ik}$ + else + ! ==== workspace query call to stdlib${ii}$_${ri}$gehrd ==== + call stdlib${ii}$_${ri}$gehrd( jw, 1_${ik}$, jw-1, t, ldt, work, work, -1_${ik}$, info ) + lwk1 = int( work( 1_${ik}$ ),KIND=${ik}$) + ! ==== workspace query call to stdlib${ii}$_${ri}$ormhr ==== + call stdlib${ii}$_${ri}$ormhr( 'R', 'N', jw, jw, 1_${ik}$, jw-1, t, ldt, work, v, ldv,work, -1_${ik}$, info ) - lwk2 = int( work( 1 ),KIND=ilp) - ! ==== workspace query call to stdlib_${ri}$laqr4 ==== - call stdlib_${ri}$laqr4( .true., .true., jw, 1, jw, t, ldt, sr, si, 1, jw,v, ldv, work, -& - 1, infqr ) - lwk3 = int( work( 1 ),KIND=ilp) + lwk2 = int( work( 1_${ik}$ ),KIND=${ik}$) + ! ==== workspace query call to stdlib${ii}$_${ri}$laqr4 ==== + call stdlib${ii}$_${ri}$laqr4( .true., .true., jw, 1_${ik}$, jw, t, ldt, sr, si, 1_${ik}$, jw,v, ldv, work, -& + 1_${ik}$, infqr ) + lwk3 = int( work( 1_${ik}$ ),KIND=${ik}$) ! ==== optimal workspace ==== lwkopt = max( jw+max( lwk1, lwk2 ), lwk3 ) end if ! ==== quick return in case of workspace query. ==== - if( lwork==-1 ) then - work( 1 ) = real( lwkopt,KIND=${rk}$) + if( lwork==-1_${ik}$ ) then + work( 1_${ik}$ ) = real( lwkopt,KIND=${rk}$) return end if ! ==== nothing to do ... ! ... for an empty active block ... ==== - ns = 0 - nd = 0 - work( 1 ) = one + ns = 0_${ik}$ + nd = 0_${ik}$ + work( 1_${ik}$ ) = one if( ktop>kbot )return ! ... nor for an empty deflation window. ==== if( nw<1 )return ! ==== machine constants ==== - safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) safmax = one / safmin - call stdlib_${ri}$labad( safmin, safmax ) - ulp = stdlib_${ri}$lamch( 'PRECISION' ) + call stdlib${ii}$_${ri}$labad( safmin, safmax ) + ulp = stdlib${ii}$_${ri}$lamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=${rk}$) / ulp ) ! ==== setup deflation window ==== jw = min( nw, kbot-ktop+1 ) - kwtop = kbot - jw + 1 + kwtop = kbot - jw + 1_${ik}$ if( kwtop==ktop ) then s = zero else @@ -35132,14 +35123,14 @@ module stdlib_linalg_lapack_${ri}$ ! ==== 1-by-1 deflation window: not much to do ==== sr( kwtop ) = h( kwtop, kwtop ) si( kwtop ) = zero - ns = 1 - nd = 0 + ns = 1_${ik}$ + nd = 0_${ik}$ if( abs( s )<=max( smlnum, ulp*abs( h( kwtop, kwtop ) ) ) )then - ns = 0 - nd = 1 + ns = 0_${ik}$ + nd = 1_${ik}$ if( kwtop>ktop )h( kwtop, kwtop-1 ) = zero end if - work( 1 ) = one + work( 1_${ik}$ ) = one return end if ! ==== convert to spike-triangular form. (in case of a @@ -35147,29 +35138,29 @@ module stdlib_linalg_lapack_${ri}$ ! . aggressive early deflation using that part of ! . the deflation window that converged using infqr ! . here and there to keep track.) ==== - call stdlib_${ri}$lacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) - call stdlib_${ri}$copy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 ) - call stdlib_${ri}$laset( 'A', jw, jw, zero, one, v, ldv ) - nmin = stdlib_ilaenv( 12, 'DLAQR3', 'SV', jw, 1, jw, lwork ) + call stdlib${ii}$_${ri}$lacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) + call stdlib${ii}$_${ri}$copy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2_${ik}$, 1_${ik}$ ), ldt+1 ) + call stdlib${ii}$_${ri}$laset( 'A', jw, jw, zero, one, v, ldv ) + nmin = stdlib${ii}$_ilaenv( 12_${ik}$, 'DLAQR3', 'SV', jw, 1_${ik}$, jw, lwork ) if( jw>nmin ) then - call stdlib_${ri}$laqr4( .true., .true., jw, 1, jw, t, ldt, sr( kwtop ),si( kwtop ), 1, & + call stdlib${ii}$_${ri}$laqr4( .true., .true., jw, 1_${ik}$, jw, t, ldt, sr( kwtop ),si( kwtop ), 1_${ik}$, & jw, v, ldv, work, lwork, infqr ) else - call stdlib_${ri}$lahqr( .true., .true., jw, 1, jw, t, ldt, sr( kwtop ),si( kwtop ), 1, & + call stdlib${ii}$_${ri}$lahqr( .true., .true., jw, 1_${ik}$, jw, t, ldt, sr( kwtop ),si( kwtop ), 1_${ik}$, & jw, v, ldv, infqr ) end if - ! ==== stdlib_${ri}$trexc needs a clean margin near the diagonal ==== + ! ==== stdlib${ii}$_${ri}$trexc needs a clean margin near the diagonal ==== do j = 1, jw - 3 t( j+2, j ) = zero t( j+3, j ) = zero end do - if( jw>2 )t( jw, jw-2 ) = zero + if( jw>2_${ik}$ )t( jw, jw-2 ) = zero ! ==== deflation detection loop ==== ns = jw - ilst = infqr + 1 + ilst = infqr + 1_${ik}$ 20 continue if( ilst<=ns ) then - if( ns==1 ) then + if( ns==1_${ik}$ ) then bulge = .false. else bulge = t( ns, ns-1 )/=zero @@ -35179,56 +35170,56 @@ module stdlib_linalg_lapack_${ri}$ ! ==== real eigenvalue ==== foo = abs( t( ns, ns ) ) if( foo==zero )foo = abs( s ) - if( abs( s*v( 1, ns ) )<=max( smlnum, ulp*foo ) ) then + if( abs( s*v( 1_${ik}$, ns ) )<=max( smlnum, ulp*foo ) ) then ! ==== deflatable ==== - ns = ns - 1 + ns = ns - 1_${ik}$ else ! ==== undeflatable. move it up out of the way. - ! . (stdlib_${ri}$trexc can not fail in this case.) ==== + ! . (stdlib${ii}$_${ri}$trexc can not fail in this case.) ==== ifst = ns - call stdlib_${ri}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) - ilst = ilst + 1 + call stdlib${ii}$_${ri}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) + ilst = ilst + 1_${ik}$ end if else ! ==== complex conjugate pair ==== foo = abs( t( ns, ns ) ) + sqrt( abs( t( ns, ns-1 ) ) )*sqrt( abs( t( ns-1, ns ) & ) ) if( foo==zero )foo = abs( s ) - if( max( abs( s*v( 1, ns ) ), abs( s*v( 1, ns-1 ) ) )<=max( smlnum, ulp*foo ) ) & + if( max( abs( s*v( 1_${ik}$, ns ) ), abs( s*v( 1_${ik}$, ns-1 ) ) )<=max( smlnum, ulp*foo ) ) & then ! ==== deflatable ==== - ns = ns - 2 + ns = ns - 2_${ik}$ else ! ==== undeflatable. move them up out of the way. - ! . fortunately, stdlib_${ri}$trexc does the right thing with + ! . fortunately, stdlib${ii}$_${ri}$trexc does the right thing with ! . ilst in case of a rare exchange failure. ==== ifst = ns - call stdlib_${ri}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) - ilst = ilst + 2 + call stdlib${ii}$_${ri}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) + ilst = ilst + 2_${ik}$ end if end if ! ==== end deflation detection loop ==== go to 20 end if ! ==== return to hessenberg form ==== - if( ns==0 )s = zero + if( ns==0_${ik}$ )s = zero if( ns1 .and. s/=zero ) then + if( ns>1_${ik}$ .and. s/=zero ) then ! ==== reflect spike back into lower triangle ==== - call stdlib_${ri}$copy( ns, v, ldv, work, 1 ) - beta = work( 1 ) - call stdlib_${ri}$larfg( ns, beta, work( 2 ), 1, tau ) - work( 1 ) = one - call stdlib_${ri}$laset( 'L', jw-2, jw-2, zero, zero, t( 3, 1 ), ldt ) - call stdlib_${ri}$larf( 'L', ns, jw, work, 1, tau, t, ldt,work( jw+1 ) ) - call stdlib_${ri}$larf( 'R', ns, ns, work, 1, tau, t, ldt,work( jw+1 ) ) - call stdlib_${ri}$larf( 'R', jw, ns, work, 1, tau, v, ldv,work( jw+1 ) ) - call stdlib_${ri}$gehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) + call stdlib${ii}$_${ri}$copy( ns, v, ldv, work, 1_${ik}$ ) + beta = work( 1_${ik}$ ) + call stdlib${ii}$_${ri}$larfg( ns, beta, work( 2_${ik}$ ), 1_${ik}$, tau ) + work( 1_${ik}$ ) = one + call stdlib${ii}$_${ri}$laset( 'L', jw-2, jw-2, zero, zero, t( 3_${ik}$, 1_${ik}$ ), ldt ) + call stdlib${ii}$_${ri}$larf( 'L', ns, jw, work, 1_${ik}$, tau, t, ldt,work( jw+1 ) ) + call stdlib${ii}$_${ri}$larf( 'R', ns, ns, work, 1_${ik}$, tau, t, ldt,work( jw+1 ) ) + call stdlib${ii}$_${ri}$larf( 'R', jw, ns, work, 1_${ik}$, tau, v, ldv,work( jw+1 ) ) + call stdlib${ii}$_${ri}$gehrd( jw, 1_${ik}$, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) end if ! ==== copy updated reduced window into place ==== - if( kwtop>1 )h( kwtop, kwtop-1 ) = s*v( 1, 1 ) - call stdlib_${ri}$lacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) - call stdlib_${ri}$copy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) + if( kwtop>1_${ik}$ )h( kwtop, kwtop-1 ) = s*v( 1_${ik}$, 1_${ik}$ ) + call stdlib${ii}$_${ri}$lacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) + call stdlib${ii}$_${ri}$copy( jw-1, t( 2_${ik}$, 1_${ik}$ ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) ! ==== accumulate orthogonal matrix in order update ! . h and z, if requested. ==== - if( ns>1 .and. s/=zero )call stdlib_${ri}$ormhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, & + if( ns>1_${ik}$ .and. s/=zero )call stdlib${ii}$_${ri}$ormhr( 'R', 'N', jw, ns, 1_${ik}$, ns, t, ldt, work, & v, ldv,work( jw+1 ), lwork-jw, info ) ! ==== update vertical slab in h ==== if( wantt ) then - ltop = 1 + ltop = 1_${ik}$ else ltop = ktop end if do krow = ltop, kwtop - 1, nv kln = min( nv, kwtop-krow ) - call stdlib_${ri}$gemm( 'N', 'N', kln, jw, jw, one, h( krow, kwtop ),ldh, v, ldv, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', kln, jw, jw, one, h( krow, kwtop ),ldh, v, ldv, & zero, wv, ldwv ) - call stdlib_${ri}$lacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) + call stdlib${ii}$_${ri}$lacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) end do ! ==== update horizontal slab in h ==== if( wantt ) then do kcol = kbot + 1, n, nh kln = min( nh, n-kcol+1 ) - call stdlib_${ri}$gemm( 'C', 'N', jw, kln, jw, one, v, ldv,h( kwtop, kcol ), ldh, & + call stdlib${ii}$_${ri}$gemm( 'C', 'N', jw, kln, jw, one, v, ldv,h( kwtop, kcol ), ldh, & zero, t, ldt ) - call stdlib_${ri}$lacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) + call stdlib${ii}$_${ri}$lacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) end do end if ! ==== update vertical slab in z ==== if( wantz ) then do krow = iloz, ihiz, nv kln = min( nv, ihiz-krow+1 ) - call stdlib_${ri}$gemm( 'N', 'N', kln, jw, jw, one, z( krow, kwtop ),ldz, v, ldv, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', kln, jw, jw, one, z( krow, kwtop ),ldz, v, ldv, & zero, wv, ldwv ) - call stdlib_${ri}$lacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) + call stdlib${ii}$_${ri}$lacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) end do end if end if @@ -35356,11 +35347,11 @@ module stdlib_linalg_lapack_${ri}$ ! . window.) ==== ns = ns - infqr ! ==== return optimal workspace. ==== - work( 1 ) = real( lwkopt,KIND=${rk}$) - end subroutine stdlib_${ri}$laqr3 + work( 1_${ik}$ ) = real( lwkopt,KIND=${rk}$) + end subroutine stdlib${ii}$_${ri}$laqr3 - subroutine stdlib_${ri}$laqr4( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, work,& + subroutine stdlib${ii}$_${ri}$laqr4( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, work,& !! DLAQR4: implements one level of recursion for DLAQR0. !! It is a complete implementation of the small bulge multi-shift !! QR algorithm. It may be called by DLAQR0 and, for large enough @@ -35380,21 +35371,21 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, ihiz, ilo, iloz, ldh, ldz, lwork, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ihiz, ilo, iloz, ldh, ldz, lwork, n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt, wantz ! Array Arguments real(${rk}$), intent(inout) :: h(ldh,*), z(ldz,*) real(${rk}$), intent(out) :: wi(*), work(*), wr(*) ! ================================================================ ! Parameters - integer(ilp), parameter :: ntiny = 15 - integer(ilp), parameter :: kexnw = 5 - integer(ilp), parameter :: kexsh = 6 + integer(${ik}$), parameter :: ntiny = 15_${ik}$ + integer(${ik}$), parameter :: kexnw = 5_${ik}$ + integer(${ik}$), parameter :: kexsh = 6_${ik}$ real(${rk}$), parameter :: wilk1 = 0.75_${rk}$ real(${rk}$), parameter :: wilk2 = -0.4375_${rk}$ ! ==== matrices of order ntiny or smaller must be processed by - ! . stdlib_${ri}$lahqr because of insufficient subdiagonal scratch space. + ! . stdlib${ii}$_${ri}$lahqr because of insufficient subdiagonal scratch space. ! . (this is a hard limit.) ==== ! ==== exceptional deflation windows: try to cure rare @@ -35411,92 +35402,92 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars real(${rk}$) :: aa, bb, cc, cs, dd, sn, ss, swap - integer(ilp) :: i, inf, it, itmax, k, kacc22, kbot, kdu, ks, kt, ktop, ku, kv, kwh, & + integer(${ik}$) :: i, inf, it, itmax, k, kacc22, kbot, kdu, ks, kt, ktop, ku, kv, kwh, & kwtop, kwv, ld, ls, lwkopt, ndec, ndfl, nh, nho, nibble, nmin, ns, nsmax, nsr, nve, nw,& nwmax, nwr, nwupbd logical(lk) :: sorted - character :: jbcmpz*2 + character(len=2_${ik}$) :: jbcmpz ! Local Arrays - real(${rk}$) :: zdum(1,1) + real(${rk}$) :: zdum(1_${ik}$,1_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,int,max,min,mod ! Executable Statements - info = 0 + info = 0_${ik}$ ! ==== quick return for n = 0: nothing to do. ==== - if( n==0 ) then - work( 1 ) = one + if( n==0_${ik}$ ) then + work( 1_${ik}$ ) = one return end if if( n<=ntiny ) then ! ==== tiny matrices must use stdlib_${ri}$lahqr. ==== - lwkopt = 1 - if( lwork/=-1 )call stdlib_${ri}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, & + lwkopt = 1_${ik}$ + if( lwork/=-1_${ik}$ )call stdlib${ii}$_${ri}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, & ihiz, z, ldz, info ) else ! ==== use small bulge multi-shift qr with aggressive early ! . deflation on larger-than-tiny matrices. ==== ! ==== hope for the best. ==== - info = 0 - ! ==== set up job flags for stdlib_ilaenv. ==== + info = 0_${ik}$ + ! ==== set up job flags for stdlib${ii}$_ilaenv. ==== if( wantt ) then - jbcmpz( 1: 1 ) = 'S' + jbcmpz( 1_${ik}$: 1_${ik}$ ) = 'S' else - jbcmpz( 1: 1 ) = 'E' + jbcmpz( 1_${ik}$: 1_${ik}$ ) = 'E' end if if( wantz ) then - jbcmpz( 2: 2 ) = 'V' + jbcmpz( 2_${ik}$: 2_${ik}$ ) = 'V' else - jbcmpz( 2: 2 ) = 'N' + jbcmpz( 2_${ik}$: 2_${ik}$ ) = 'N' end if ! ==== nwr = recommended deflation window size. at this ! . point, n > ntiny = 15, so there is enough ! . subdiagonal workspace for nwr>=2 as required. ! . (in fact, there is enough subdiagonal space for ! . nwr>=4.) ==== - nwr = stdlib_ilaenv( 13, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork ) - nwr = max( 2, nwr ) - nwr = min( ihi-ilo+1, ( n-1 ) / 3, nwr ) + nwr = stdlib${ii}$_ilaenv( 13_${ik}$, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork ) + nwr = max( 2_${ik}$, nwr ) + nwr = min( ihi-ilo+1, ( n-1 ) / 3_${ik}$, nwr ) ! ==== nsr = recommended number of simultaneous shifts. ! . at this point n > ntiny = 15, so there is at ! . enough subdiagonal workspace for nsr to be even ! . and greater than or equal to two as required. ==== - nsr = stdlib_ilaenv( 15, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork ) - nsr = min( nsr, ( n-3 ) / 6, ihi-ilo ) - nsr = max( 2, nsr-mod( nsr, 2 ) ) + nsr = stdlib${ii}$_ilaenv( 15_${ik}$, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork ) + nsr = min( nsr, ( n-3 ) / 6_${ik}$, ihi-ilo ) + nsr = max( 2_${ik}$, nsr-mod( nsr, 2_${ik}$ ) ) ! ==== estimate optimal workspace ==== - ! ==== workspace query call to stdlib_${ri}$laqr2 ==== - call stdlib_${ri}$laqr2( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& - ld, wr, wi, h, ldh, n, h, ldh,n, h, ldh, work, -1 ) - ! ==== optimal workspace = max(stdlib_${ri}$laqr5, stdlib_${ri}$laqr2) ==== - lwkopt = max( 3*nsr / 2, int( work( 1 ),KIND=ilp) ) + ! ==== workspace query call to stdlib${ii}$_${ri}$laqr2 ==== + call stdlib${ii}$_${ri}$laqr2( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& + ld, wr, wi, h, ldh, n, h, ldh,n, h, ldh, work, -1_${ik}$ ) + ! ==== optimal workspace = max(stdlib${ii}$_${ri}$laqr5, stdlib${ii}$_${ri}$laqr2) ==== + lwkopt = max( 3_${ik}$*nsr / 2_${ik}$, int( work( 1_${ik}$ ),KIND=${ik}$) ) ! ==== quick return in case of workspace query. ==== - if( lwork==-1 ) then - work( 1 ) = real( lwkopt,KIND=${rk}$) + if( lwork==-1_${ik}$ ) then + work( 1_${ik}$ ) = real( lwkopt,KIND=${rk}$) return end if - ! ==== stdlib_${ri}$lahqr/stdlib_${ri}$laqr0 crossover point ==== - nmin = stdlib_ilaenv( 12, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork ) + ! ==== stdlib${ii}$_${ri}$lahqr/stdlib${ii}$_${ri}$laqr0 crossover point ==== + nmin = stdlib${ii}$_ilaenv( 12_${ik}$, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork ) nmin = max( ntiny, nmin ) ! ==== nibble crossover point ==== - nibble = stdlib_ilaenv( 14, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork ) - nibble = max( 0, nibble ) + nibble = stdlib${ii}$_ilaenv( 14_${ik}$, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork ) + nibble = max( 0_${ik}$, nibble ) ! ==== accumulate reflections during ttswp? use block ! . 2-by-2 structure during matrix-matrix multiply? ==== - kacc22 = stdlib_ilaenv( 16, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork ) - kacc22 = max( 0, kacc22 ) - kacc22 = min( 2, kacc22 ) + kacc22 = stdlib${ii}$_ilaenv( 16_${ik}$, 'DLAQR4', jbcmpz, n, ilo, ihi, lwork ) + kacc22 = max( 0_${ik}$, kacc22 ) + kacc22 = min( 2_${ik}$, kacc22 ) ! ==== nwmax = the largest possible deflation window for ! . which there is sufficient workspace. ==== - nwmax = min( ( n-1 ) / 3, lwork / 2 ) + nwmax = min( ( n-1 ) / 3_${ik}$, lwork / 2_${ik}$ ) nw = nwmax ! ==== nsmax = the largest number of simultaneous shifts ! . for which there is sufficient workspace. ==== - nsmax = min( ( n-3 ) / 6, 2*lwork / 3 ) - nsmax = nsmax - mod( nsmax, 2 ) + nsmax = min( ( n-3 ) / 6_${ik}$, 2_${ik}$*lwork / 3_${ik}$ ) + nsmax = nsmax - mod( nsmax, 2_${ik}$ ) ! ==== ndfl: an iteration count restarted at deflation. ==== - ndfl = 1 + ndfl = 1_${ik}$ ! ==== itmax = iteration limit ==== - itmax = max( 30, 2*kexsh )*max( 10, ( ihi-ilo+1 ) ) + itmax = max( 30_${ik}$, 2_${ik}$*kexsh )*max( 10_${ik}$, ( ihi-ilo+1 ) ) ! ==== last row and column in the active block ==== kbot = ihi ! ==== main loop ==== @@ -35524,27 +35515,27 @@ module stdlib_linalg_lapack_${ri}$ ! . in general, more powerful than smaller ones, ! . rapidly increase the window to the maximum possible. ! . then, gradually reduce the window size. ==== - nh = kbot - ktop + 1 + nh = kbot - ktop + 1_${ik}$ nwupbd = min( nh, nwmax ) if( ndfl=nh-1 ) then nw = nh else - kwtop = kbot - nw + 1 + kwtop = kbot - nw + 1_${ik}$ if( abs( h( kwtop, kwtop-1 ) )>abs( h( kwtop-1, kwtop-2 ) ) )nw = nw + & - 1 + 1_${ik}$ end if end if if( ndfl=0 .or. nw>=nwupbd ) then - ndec = ndec + 1 - if( nw-ndec<2 )ndec = 0 + ndec = -1_${ik}$ + else if( ndec>=0_${ik}$ .or. nw>=nwupbd ) then + ndec = ndec + 1_${ik}$ + if( nw-ndec<2_${ik}$ )ndec = 0_${ik}$ nw = nw - ndec end if ! ==== aggressive early deflation: @@ -35557,46 +35548,46 @@ module stdlib_linalg_lapack_${ri}$ ! . - an at-least-nw-but-more-is-better (nhv-by-nw) ! . vertical work array along the left-hand-edge. ! . ==== - kv = n - nw + 1 - kt = nw + 1 - nho = ( n-nw-1 ) - kt + 1 - kwv = nw + 2 - nve = ( n-nw ) - kwv + 1 + kv = n - nw + 1_${ik}$ + kt = nw + 1_${ik}$ + nho = ( n-nw-1 ) - kt + 1_${ik}$ + kwv = nw + 2_${ik}$ + nve = ( n-nw ) - kwv + 1_${ik}$ ! ==== aggressive early deflation ==== - call stdlib_${ri}$laqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & - ls, ld, wr, wi, h( kv, 1 ), ldh,nho, h( kv, kt ), ldh, nve, h( kwv, 1 ), ldh,& + call stdlib${ii}$_${ri}$laqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & + ls, ld, wr, wi, h( kv, 1_${ik}$ ), ldh,nho, h( kv, kt ), ldh, nve, h( kwv, 1_${ik}$ ), ldh,& work, lwork ) ! ==== adjust kbot accounting for new deflations. ==== kbot = kbot - ld ! ==== ks points to the shifts. ==== - ks = kbot - ls + 1 + ks = kbot - ls + 1_${ik}$ ! ==== skip an expensive qr sweep if there is a (partly ! . heuristic) reason to expect that many eigenvalues ! . will deflate without it. here, the qr sweep is ! . skipped if many eigenvalues have just been deflated ! . or if the remaining active block is small. - if( ( ld==0 ) .or. ( ( 100*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& + if( ( ld==0_${ik}$ ) .or. ( ( 100_${ik}$*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& ) ) ) then ! ==== ns = nominal number of simultaneous shifts. - ! . this may be lowered (slightly) if stdlib_${ri}$laqr2 + ! . this may be lowered (slightly) if stdlib${ii}$_${ri}$laqr2 ! . did not provide that many shifts. ==== - ns = min( nsmax, nsr, max( 2, kbot-ktop ) ) - ns = ns - mod( ns, 2 ) + ns = min( nsmax, nsr, max( 2_${ik}$, kbot-ktop ) ) + ns = ns - mod( ns, 2_${ik}$ ) ! ==== if there have been no deflations ! . in a multiple of kexsh iterations, ! . then try exceptional shifts. ! . otherwise use shifts provided by - ! . stdlib_${ri}$laqr2 above or from the eigenvalues + ! . stdlib${ii}$_${ri}$laqr2 above or from the eigenvalues ! . of a trailing principal submatrix. ==== - if( mod( ndfl, kexsh )==0 ) then - ks = kbot - ns + 1 + if( mod( ndfl, kexsh )==0_${ik}$ ) then + ks = kbot - ns + 1_${ik}$ do i = kbot, max( ks+1, ktop+2 ), -2 ss = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) ) aa = wilk1*ss + h( i, i ) bb = ss cc = wilk2*ss dd = aa - call stdlib_${ri}$lanv2( aa, bb, cc, dd, wr( i-1 ), wi( i-1 ),wr( i ), wi( i & + call stdlib${ii}$_${ri}$lanv2( aa, bb, cc, dd, wr( i-1 ), wi( i-1 ),wr( i ), wi( i & ), cs, sn ) end do if( ks==ktop ) then @@ -35611,13 +35602,13 @@ module stdlib_linalg_lapack_${ri}$ ! . get more. (since ns<=nsmax<=(n-3)/6, ! . there is enough space below the subdiagonal ! . to fit an ns-by-ns scratch array.) ==== - if( kbot-ks+1<=ns / 2 ) then - ks = kbot - ns + 1 - kt = n - ns + 1 - call stdlib_${ri}$lacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1 ), ldh ) + if( kbot-ks+1<=ns / 2_${ik}$ ) then + ks = kbot - ns + 1_${ik}$ + kt = n - ns + 1_${ik}$ + call stdlib${ii}$_${ri}$lacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1_${ik}$ ), ldh ) - call stdlib_${ri}$lahqr( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, wr( ks & - ), wi( ks ),1, 1, zdum, 1, inf ) + call stdlib${ii}$_${ri}$lahqr( .false., .false., ns, 1_${ik}$, ns,h( kt, 1_${ik}$ ), ldh, wr( ks & + ), wi( ks ),1_${ik}$, 1_${ik}$, zdum, 1_${ik}$, inf ) ks = ks + inf ! ==== in case of a rare qr failure use ! . eigenvalues of the trailing 2-by-2 @@ -35627,9 +35618,9 @@ module stdlib_linalg_lapack_${ri}$ cc = h( kbot, kbot-1 ) bb = h( kbot-1, kbot ) dd = h( kbot, kbot ) - call stdlib_${ri}$lanv2( aa, bb, cc, dd, wr( kbot-1 ),wi( kbot-1 ), wr( & + call stdlib${ii}$_${ri}$lanv2( aa, bb, cc, dd, wr( kbot-1 ),wi( kbot-1 ), wr( & kbot ),wi( kbot ), cs, sn ) - ks = kbot - 1 + ks = kbot - 1_${ik}$ end if end if if( kbot-ks+1>ns ) then @@ -35675,7 +35666,7 @@ module stdlib_linalg_lapack_${ri}$ end if ! ==== if there are only two shifts and both are ! . real, then use only one. ==== - if( kbot-ks+1==2 ) then + if( kbot-ks+1==2_${ik}$ ) then if( wi( kbot )==zero ) then if( abs( wr( kbot )-h( kbot, kbot ) )0 ) then - ndfl = 1 + if( ld>0_${ik}$ ) then + ndfl = 1_${ik}$ else - ndfl = ndfl + 1 + ndfl = ndfl + 1_${ik}$ end if ! ==== end of main loop ==== end do loop_80 @@ -35727,11 +35718,11 @@ module stdlib_linalg_lapack_${ri}$ 90 continue end if ! ==== return the optimal value of lwork. ==== - work( 1 ) = real( lwkopt,KIND=${rk}$) - end subroutine stdlib_${ri}$laqr4 + work( 1_${ik}$ ) = real( lwkopt,KIND=${rk}$) + end subroutine stdlib${ii}$_${ri}$laqr4 - pure subroutine stdlib_${ri}$laqr5( wantt, wantz, kacc22, n, ktop, kbot, nshfts,sr, si, h, ldh, & + pure subroutine stdlib${ii}$_${ri}$laqr5( wantt, wantz, kacc22, n, ktop, kbot, nshfts,sr, si, h, ldh, & !! DLAQR5:, called by DLAQR0, performs a !! single small-bulge multi-shift QR sweep. iloz, ihiz, z, ldz, v, ldv, u,ldu, nv, wv, ldwv, nh, wh, ldwh ) @@ -35739,7 +35730,7 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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) :: ihiz, iloz, kacc22, kbot, ktop, ldh, ldu, ldv, ldwh, ldwv, & + integer(${ik}$), intent(in) :: ihiz, iloz, kacc22, kbot, ktop, ldh, ldu, ldv, ldwh, ldwv, & ldz, n, nh, nshfts, nv logical(lk), intent(in) :: wantt, wantz ! Array Arguments @@ -35750,13 +35741,13 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars real(${rk}$) :: alpha, beta, h11, h12, h21, h22, refsum, safmax, safmin, scl, smlnum, swap,& tst1, tst2, ulp - integer(ilp) :: i, i2, i4, incol, j, jbot, jcol, jlen, jrow, jtop, k, k1, kdu, kms, & + integer(${ik}$) :: i, i2, i4, incol, j, jbot, jcol, jlen, jrow, jtop, k, k1, kdu, kms, & krcol, m, m22, mbot, mtop, nbmps, ndcol, ns, nu logical(lk) :: accum, bmp22 ! Intrinsic Functions intrinsic :: abs,real,max,min,mod ! Local Arrays - real(${rk}$) :: vt(3) + real(${rk}$) :: vt(3_${ik}$) ! Executable Statements ! ==== if there are no shifts, then there is nothing to do. ==== if( nshfts<2 )return @@ -35783,34 +35774,34 @@ module stdlib_linalg_lapack_${ri}$ ! . then simply reduce it by one. the shuffle above ! . ensures that the dropped shift is real and that ! . the remaining shifts are paired. ==== - ns = nshfts - mod( nshfts, 2 ) + ns = nshfts - mod( nshfts, 2_${ik}$ ) ! ==== machine constants for deflation ==== - safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) safmax = one / safmin - call stdlib_${ri}$labad( safmin, safmax ) - ulp = stdlib_${ri}$lamch( 'PRECISION' ) + call stdlib${ii}$_${ri}$labad( safmin, safmax ) + ulp = stdlib${ii}$_${ri}$lamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=${rk}$) / ulp ) ! ==== use accumulated reflections to update far-from-diagonal ! . entries ? ==== - accum = ( kacc22==1 ) .or. ( kacc22==2 ) + accum = ( kacc22==1_${ik}$ ) .or. ( kacc22==2_${ik}$ ) ! ==== clear trash ==== if( ktop+2<=kbot )h( ktop+2, ktop ) = zero ! ==== nbmps = number of 2-shift bulges in the chain ==== - nbmps = ns / 2 + nbmps = ns / 2_${ik}$ ! ==== kdu = width of slab ==== - kdu = 4*nbmps + kdu = 4_${ik}$*nbmps ! ==== create and chase chains of nbmps bulges ==== loop_180: do incol = ktop - 2*nbmps + 1, kbot - 2, 2*nbmps ! jtop = index from which updates from the right start. if( accum ) then jtop = max( ktop, incol ) else if( wantt ) then - jtop = 1 + jtop = 1_${ik}$ else jtop = ktop end if ndcol = incol + kdu - if( accum )call stdlib_${ri}$laset( 'ALL', kdu, kdu, zero, one, u, ldu ) + if( accum )call stdlib${ii}$_${ri}$laset( 'ALL', kdu, kdu, zero, one, u, ldu ) ! ==== near-the-diagonal bulge chase. the following loop ! . performs the near-the-diagonal part of a small bulge ! . multi-shift qr sweep. each 4*nbmps column diagonal @@ -35829,34 +35820,34 @@ module stdlib_linalg_lapack_${ri}$ ! . (if any) must wait until the active bulges have moved ! . down the diagonal to make room. the phantom matrix ! . paradigm described above helps keep track. ==== - mtop = max( 1, ( ktop-krcol ) / 2+1 ) - mbot = min( nbmps, ( kbot-krcol-1 ) / 2 ) - m22 = mbot + 1 + mtop = max( 1_${ik}$, ( ktop-krcol ) / 2_${ik}$+1 ) + mbot = min( nbmps, ( kbot-krcol-1 ) / 2_${ik}$ ) + m22 = mbot + 1_${ik}$ bmp22 = ( mbotulp*( abs( & + call stdlib${ii}$_${ri}$laqr1( 3_${ik}$, h( k+1, k+1 ), ldh, sr( 2_${ik}$*m-1 ),si( 2_${ik}$*m-1 ), sr( & + 2_${ik}$*m ), si( 2_${ik}$*m ),vt ) + alpha = vt( 1_${ik}$ ) + call stdlib${ii}$_${ri}$larfg( 3_${ik}$, alpha, vt( 2_${ik}$ ), 1_${ik}$, vt( 1_${ik}$ ) ) + refsum = vt( 1_${ik}$ )*( h( k+1, k )+vt( 2_${ik}$ )*h( k+2, k ) ) + if( abs( h( k+2, k )-refsum*vt( 2_${ik}$ ) )+abs( refsum*vt( 3_${ik}$ ) )>ulp*( abs( & h( k, k ) )+abs( h( k+1,k+1 ) )+abs( h( k+2, k+2 ) ) ) ) then ! ==== starting a new bulge here would ! . create non-negligible fill. use @@ -35982,9 +35973,9 @@ module stdlib_linalg_lapack_${ri}$ h( k+1, k ) = h( k+1, k ) - refsum h( k+2, k ) = zero h( k+3, k ) = zero - v( 1, m ) = vt( 1 ) - v( 2, m ) = vt( 2 ) - v( 3, m ) = vt( 3 ) + v( 1_${ik}$, m ) = vt( 1_${ik}$ ) + v( 2_${ik}$, m ) = vt( 2_${ik}$ ) + v( 3_${ik}$, m ) = vt( 3_${ik}$ ) end if end if end if @@ -35994,19 +35985,19 @@ module stdlib_linalg_lapack_${ri}$ ! . deflation check. we still delay most of the ! . updates from the left for efficiency. ==== do j = jtop, min( kbot, k+3 ) - refsum = v( 1, m )*( h( j, k+1 )+v( 2, m )*h( j, k+2 )+v( 3, m )*h( j, k+3 & + refsum = v( 1_${ik}$, m )*( h( j, k+1 )+v( 2_${ik}$, m )*h( j, k+2 )+v( 3_${ik}$, m )*h( j, k+3 & ) ) h( j, k+1 ) = h( j, k+1 ) - refsum - h( j, k+2 ) = h( j, k+2 ) - refsum*v( 2, m ) - h( j, k+3 ) = h( j, k+3 ) - refsum*v( 3, m ) + h( j, k+2 ) = h( j, k+2 ) - refsum*v( 2_${ik}$, m ) + h( j, k+3 ) = h( j, k+3 ) - refsum*v( 3_${ik}$, m ) end do ! ==== perform update from left for subsequent ! . column. ==== - refsum = v( 1, m )*( h( k+1, k+1 )+v( 2, m )*h( k+2, k+1 )+v( 3, m )*h( k+3, & + refsum = v( 1_${ik}$, m )*( h( k+1, k+1 )+v( 2_${ik}$, m )*h( k+2, k+1 )+v( 3_${ik}$, m )*h( k+3, & k+1 ) ) h( k+1, k+1 ) = h( k+1, k+1 ) - refsum - h( k+2, k+1 ) = h( k+2, k+1 ) - refsum*v( 2, m ) - h( k+3, k+1 ) = h( k+3, k+1 ) - refsum*v( 3, m ) + h( k+2, k+1 ) = h( k+2, k+1 ) - refsum*v( 2_${ik}$, m ) + h( k+3, k+1 ) = h( k+3, k+1 ) - refsum*v( 3_${ik}$, m ) ! ==== the following convergence test requires that ! . the tradition small-compared-to-nearby-diagonals ! . criterion and the ahues @@ -36049,13 +36040,13 @@ module stdlib_linalg_lapack_${ri}$ jbot = kbot end if do m = mbot, mtop, -1 - k = krcol + 2*( m-1 ) + k = krcol + 2_${ik}$*( m-1 ) do j = max( ktop, krcol + 2*m ), jbot - refsum = v( 1, m )*( h( k+1, j )+v( 2, m )*h( k+2, j )+v( 3, m )*h( k+3, j & + refsum = v( 1_${ik}$, m )*( h( k+1, j )+v( 2_${ik}$, m )*h( k+2, j )+v( 3_${ik}$, m )*h( k+3, j & ) ) h( k+1, j ) = h( k+1, j ) - refsum - h( k+2, j ) = h( k+2, j ) - refsum*v( 2, m ) - h( k+3, j ) = h( k+3, j ) - refsum*v( 3, m ) + h( k+2, j ) = h( k+2, j ) - refsum*v( 2_${ik}$, m ) + h( k+3, j ) = h( k+3, j ) - refsum*v( 3_${ik}$, m ) end do end do ! ==== accumulate orthogonal transformations. ==== @@ -36064,17 +36055,17 @@ module stdlib_linalg_lapack_${ri}$ ! . with an efficient matrix-matrix ! . multiply.) ==== do m = mbot, mtop, -1 - k = krcol + 2*( m-1 ) + k = krcol + 2_${ik}$*( m-1 ) kms = k - incol - i2 = max( 1, ktop-incol ) - i2 = max( i2, kms-(krcol-incol)+1 ) - i4 = min( kdu, krcol + 2*( mbot-1 ) - incol + 5 ) + i2 = max( 1_${ik}$, ktop-incol ) + i2 = max( i2, kms-(krcol-incol)+1_${ik}$ ) + i4 = min( kdu, krcol + 2_${ik}$*( mbot-1 ) - incol + 5_${ik}$ ) do j = i2, i4 - refsum = v( 1, m )*( u( j, kms+1 )+v( 2, m )*u( j, kms+2 )+v( 3, m )*u( & + refsum = v( 1_${ik}$, m )*( u( j, kms+1 )+v( 2_${ik}$, m )*u( j, kms+2 )+v( 3_${ik}$, m )*u( & j, kms+3 ) ) u( j, kms+1 ) = u( j, kms+1 ) - refsum - u( j, kms+2 ) = u( j, kms+2 ) - refsum*v( 2, m ) - u( j, kms+3 ) = u( j, kms+3 ) - refsum*v( 3, m ) + u( j, kms+2 ) = u( j, kms+2 ) - refsum*v( 2_${ik}$, m ) + u( j, kms+3 ) = u( j, kms+3 ) - refsum*v( 3_${ik}$, m ) end do end do else if( wantz ) then @@ -36082,13 +36073,13 @@ module stdlib_linalg_lapack_${ri}$ ! . now by multiplying by reflections ! . from the right. ==== do m = mbot, mtop, -1 - k = krcol + 2*( m-1 ) + k = krcol + 2_${ik}$*( m-1 ) do j = iloz, ihiz - refsum = v( 1, m )*( z( j, k+1 )+v( 2, m )*z( j, k+2 )+v( 3, m )*z( j, & + refsum = v( 1_${ik}$, m )*( z( j, k+1 )+v( 2_${ik}$, m )*z( j, k+2 )+v( 3_${ik}$, m )*z( j, & k+3 ) ) z( j, k+1 ) = z( j, k+1 ) - refsum - z( j, k+2 ) = z( j, k+2 ) - refsum*v( 2, m ) - z( j, k+3 ) = z( j, k+3 ) - refsum*v( 3, m ) + z( j, k+2 ) = z( j, k+2 ) - refsum*v( 2_${ik}$, m ) + z( j, k+3 ) = z( j, k+3 ) - refsum*v( 3_${ik}$, m ) end do end do end if @@ -36099,46 +36090,46 @@ module stdlib_linalg_lapack_${ri}$ ! . well. ==== if( accum ) then if( wantt ) then - jtop = 1 + jtop = 1_${ik}$ jbot = n else jtop = ktop jbot = kbot end if - k1 = max( 1, ktop-incol ) - nu = ( kdu-max( 0, ndcol-kbot ) ) - k1 + 1 + k1 = max( 1_${ik}$, ktop-incol ) + nu = ( kdu-max( 0_${ik}$, ndcol-kbot ) ) - k1 + 1_${ik}$ ! ==== horizontal multiply ==== do jcol = min( ndcol, kbot ) + 1, jbot, nh jlen = min( nh, jbot-jcol+1 ) - call stdlib_${ri}$gemm( 'C', 'N', nu, jlen, nu, one, u( k1, k1 ),ldu, h( incol+k1, & + call stdlib${ii}$_${ri}$gemm( 'C', 'N', nu, jlen, nu, one, u( k1, k1 ),ldu, h( incol+k1, & jcol ), ldh, zero, wh,ldwh ) - call stdlib_${ri}$lacpy( 'ALL', nu, jlen, wh, ldwh,h( incol+k1, jcol ), ldh ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', nu, jlen, wh, ldwh,h( incol+k1, jcol ), ldh ) end do ! ==== vertical multiply ==== do jrow = jtop, max( ktop, incol ) - 1, nv jlen = min( nv, max( ktop, incol )-jrow ) - call stdlib_${ri}$gemm( 'N', 'N', jlen, nu, nu, one,h( jrow, incol+k1 ), ldh, u( & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', jlen, nu, nu, one,h( jrow, incol+k1 ), ldh, u( & k1, k1 ),ldu, zero, wv, ldwv ) - call stdlib_${ri}$lacpy( 'ALL', jlen, nu, wv, ldwv,h( jrow, incol+k1 ), ldh ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', jlen, nu, wv, ldwv,h( jrow, incol+k1 ), ldh ) end do ! ==== z multiply (also vertical) ==== if( wantz ) then do jrow = iloz, ihiz, nv jlen = min( nv, ihiz-jrow+1 ) - call stdlib_${ri}$gemm( 'N', 'N', jlen, nu, nu, one,z( jrow, incol+k1 ), ldz, u(& + call stdlib${ii}$_${ri}$gemm( 'N', 'N', jlen, nu, nu, one,z( jrow, incol+k1 ), ldz, u(& k1, k1 ),ldu, zero, wv, ldwv ) - call stdlib_${ri}$lacpy( 'ALL', jlen, nu, wv, ldwv,z( jrow, incol+k1 ), ldz ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', jlen, nu, wv, ldwv,z( jrow, incol+k1 ), ldz ) end do end if end if end do loop_180 - end subroutine stdlib_${ri}$laqr5 + end subroutine stdlib${ii}$_${ri}$laqr5 - pure subroutine stdlib_${ri}$laqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_${ri}$laqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) !! DLAQSB: equilibrates a symmetric band matrix A using the scaling !! factors in the vector S. ! -- lapack auxiliary routine -- @@ -36147,7 +36138,7 @@ module stdlib_linalg_lapack_${ri}$ ! 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(${rk}$), intent(in) :: amax, scond ! Array Arguments real(${rk}$), intent(inout) :: ab(ldab,*) @@ -36157,18 +36148,18 @@ module stdlib_linalg_lapack_${ri}$ real(${rk}$), parameter :: thresh = 0.1e+0_${rk}$ ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(${rk}$) :: 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_${ri}$lamch( 'SAFE MINIMUM' ) / stdlib_${ri}$lamch( 'PRECISION' ) + small = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${ri}$lamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -36188,17 +36179,17 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$laqsb + end subroutine stdlib${ii}$_${ri}$laqsb - pure subroutine stdlib_${ri}$laqsp( uplo, n, ap, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_${ri}$laqsp( uplo, n, ap, s, scond, amax, equed ) !! DLAQSP: equilibrates a symmetric matrix A using the scaling factors !! in the vector S. ! -- lapack auxiliary routine -- @@ -36207,7 +36198,7 @@ module stdlib_linalg_lapack_${ri}$ ! Scalar Arguments character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(${rk}$), intent(in) :: amax, scond ! Array Arguments real(${rk}$), intent(inout) :: ap(*) @@ -36217,16 +36208,16 @@ module stdlib_linalg_lapack_${ri}$ real(${rk}$), parameter :: thresh = 0.1e+0_${rk}$ ! Local Scalars - integer(ilp) :: i, j, jc + integer(${ik}$) :: i, j, jc real(${rk}$) :: 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_${ri}$lamch( 'SAFE MINIMUM' ) / stdlib_${ri}$lamch( 'PRECISION' ) + small = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${ri}$lamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -36235,7 +36226,7 @@ module stdlib_linalg_lapack_${ri}$ ! 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 @@ -36245,22 +36236,22 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$laqsp + end subroutine stdlib${ii}$_${ri}$laqsp - pure subroutine stdlib_${ri}$laqsy( uplo, n, a, lda, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_${ri}$laqsy( uplo, n, a, lda, s, scond, amax, equed ) !! DLAQSY: equilibrates a symmetric matrix A using the scaling factors !! in the vector S. ! -- lapack auxiliary routine -- @@ -36269,7 +36260,7 @@ module stdlib_linalg_lapack_${ri}$ ! Scalar Arguments character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: lda, n + integer(${ik}$), intent(in) :: lda, n real(${rk}$), intent(in) :: amax, scond ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*) @@ -36279,16 +36270,16 @@ module stdlib_linalg_lapack_${ri}$ real(${rk}$), parameter :: thresh = 0.1e+0_${rk}$ ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(${rk}$) :: 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_${ri}$lamch( 'SAFE MINIMUM' ) / stdlib_${ri}$lamch( 'PRECISION' ) + small = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${ri}$lamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -36315,10 +36306,10 @@ module stdlib_linalg_lapack_${ri}$ equed = 'Y' end if return - end subroutine stdlib_${ri}$laqsy + end subroutine stdlib${ii}$_${ri}$laqsy - subroutine stdlib_${ri}$laqtr( ltran, lreal, n, t, ldt, b, w, scale, x, work,info ) + subroutine stdlib${ii}$_${ri}$laqtr( ltran, lreal, n, t, ldt, b, w, scale, x, work,info ) !! DLAQTR: solves the real quasi-triangular system !! op(T)*p = scale*c, if LREAL = .TRUE. !! or the complex quasi-triangular systems @@ -36342,8 +36333,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: lreal, ltran - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldt, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldt, n real(${rk}$), intent(out) :: scale real(${rk}$), intent(in) :: w ! Array Arguments @@ -36354,47 +36345,47 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: notran - integer(ilp) :: i, ierr, j, j1, j2, jnext, k, n1, n2 + integer(${ik}$) :: i, ierr, j, j1, j2, jnext, k, n1, n2 real(${rk}$) :: bignum, eps, rec, scaloc, si, smin, sminw, smlnum, sr, tjj, tmp, xj, xmax, & xnorm, z ! Local Arrays - real(${rk}$) :: d(2,2), v(2,2) + real(${rk}$) :: d(2_${ik}$,2_${ik}$), v(2_${ik}$,2_${ik}$) ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements ! do not test the input parameters for errors notran = .not.ltran - info = 0 + info = 0_${ik}$ ! quick return if possible if( n==0 )return ! set constants to control overflow - eps = stdlib_${ri}$lamch( 'P' ) - smlnum = stdlib_${ri}$lamch( 'S' ) / eps + eps = stdlib${ii}$_${ri}$lamch( 'P' ) + smlnum = stdlib${ii}$_${ri}$lamch( 'S' ) / eps bignum = one / smlnum - xnorm = stdlib_${ri}$lange( 'M', n, n, t, ldt, d ) - if( .not.lreal )xnorm = max( xnorm, abs( w ), stdlib_${ri}$lange( 'M', n, 1, b, n, d ) ) + xnorm = stdlib${ii}$_${ri}$lange( 'M', n, n, t, ldt, d ) + if( .not.lreal )xnorm = max( xnorm, abs( w ), stdlib${ii}$_${ri}$lange( 'M', n, 1_${ik}$, b, n, d ) ) smin = max( smlnum, eps*xnorm ) ! compute 1-norm of each column of strictly upper triangular ! part of t to control overflow in triangular solver. - work( 1 ) = zero + work( 1_${ik}$ ) = zero do j = 2, n - work( j ) = stdlib_${ri}$asum( j-1, t( 1, j ), 1 ) + work( j ) = stdlib${ii}$_${ri}$asum( j-1, t( 1_${ik}$, j ), 1_${ik}$ ) end do if( .not.lreal ) then do i = 2, n work( i ) = work( i ) + abs( b( i ) ) end do end if - n2 = 2*n + n2 = 2_${ik}$*n n1 = n if( .not.lreal )n1 = n2 - k = stdlib_i${ri}$amax( n1, x, 1 ) + k = stdlib${ii}$_i${ri}$amax( n1, x, 1_${ik}$ ) xmax = abs( x( k ) ) scale = one if( xmax>bignum ) then scale = bignum / xmax - call stdlib_${ri}$scal( n1, scale, x, 1 ) + call stdlib${ii}$_${ri}$scal( n1, scale, x, 1_${ik}$ ) xmax = bignum end if if( lreal ) then @@ -36405,11 +36396,11 @@ module stdlib_linalg_lapack_${ri}$ if( j>jnext )cycle loop_30 j1 = j j2 = j - jnext = j - 1 - if( j>1 ) then + jnext = j - 1_${ik}$ + if( j>1_${ik}$ ) then if( t( j, j-1 )/=zero ) then - j1 = j - 1 - jnext = j - 2 + j1 = j - 1_${ik}$ + jnext = j - 2_${ik}$ end if end if if( j1==j2 ) then @@ -36422,13 +36413,13 @@ module stdlib_linalg_lapack_${ri}$ if( tjjbignum*tjj ) then rec = one / xj - call stdlib_${ri}$scal( n, rec, x, 1 ) + call stdlib${ii}$_${ri}$scal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if @@ -36440,61 +36431,61 @@ module stdlib_linalg_lapack_${ri}$ if( xj>one ) then rec = one / xj if( work( j1 )>( bignum-xmax )*rec ) then - call stdlib_${ri}$scal( n, rec, x, 1 ) + call stdlib${ii}$_${ri}$scal( n, rec, x, 1_${ik}$ ) scale = scale*rec end if end if - if( j1>1 ) then - call stdlib_${ri}$axpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 ) - k = stdlib_i${ri}$amax( j1-1, x, 1 ) + if( j1>1_${ik}$ ) then + call stdlib${ii}$_${ri}$axpy( j1-1, -x( j1 ), t( 1_${ik}$, j1 ), 1_${ik}$, x, 1_${ik}$ ) + k = stdlib${ii}$_i${ri}$amax( j1-1, x, 1_${ik}$ ) xmax = abs( x( k ) ) end if else ! meet 2 by 2 diagonal block ! call 2 by 2 linear system solve, to take ! care of possible overflow by scaling factor. - d( 1, 1 ) = x( j1 ) - d( 2, 1 ) = x( j2 ) - call stdlib_${ri}$laln2( .false., 2, 1, smin, one, t( j1, j1 ),ldt, one, one, d,& - 2, zero, zero, v, 2,scaloc, xnorm, ierr ) - if( ierr/=0 )info = 2 + d( 1_${ik}$, 1_${ik}$ ) = x( j1 ) + d( 2_${ik}$, 1_${ik}$ ) = x( j2 ) + call stdlib${ii}$_${ri}$laln2( .false., 2_${ik}$, 1_${ik}$, smin, one, t( j1, j1 ),ldt, one, one, d,& + 2_${ik}$, zero, zero, v, 2_${ik}$,scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 2_${ik}$ if( scaloc/=one ) then - call stdlib_${ri}$scal( n, scaloc, x, 1 ) + call stdlib${ii}$_${ri}$scal( n, scaloc, x, 1_${ik}$ ) scale = scale*scaloc end if - x( j1 ) = v( 1, 1 ) - x( j2 ) = v( 2, 1 ) + x( j1 ) = v( 1_${ik}$, 1_${ik}$ ) + x( j2 ) = v( 2_${ik}$, 1_${ik}$ ) ! scale v(1,1) (= x(j1)) and/or v(2,1) (=x(j2)) ! to avoid overflow in updating right-hand side. - xj = max( abs( v( 1, 1 ) ), abs( v( 2, 1 ) ) ) + xj = max( abs( v( 1_${ik}$, 1_${ik}$ ) ), abs( v( 2_${ik}$, 1_${ik}$ ) ) ) if( xj>one ) then rec = one / xj if( max( work( j1 ), work( j2 ) )>( bignum-xmax )*rec ) then - call stdlib_${ri}$scal( n, rec, x, 1 ) + call stdlib${ii}$_${ri}$scal( n, rec, x, 1_${ik}$ ) scale = scale*rec end if end if ! update right-hand side - if( j1>1 ) then - call stdlib_${ri}$axpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 ) - call stdlib_${ri}$axpy( j1-1, -x( j2 ), t( 1, j2 ), 1, x, 1 ) - k = stdlib_i${ri}$amax( j1-1, x, 1 ) + if( j1>1_${ik}$ ) then + call stdlib${ii}$_${ri}$axpy( j1-1, -x( j1 ), t( 1_${ik}$, j1 ), 1_${ik}$, x, 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( j1-1, -x( j2 ), t( 1_${ik}$, j2 ), 1_${ik}$, x, 1_${ik}$ ) + k = stdlib${ii}$_i${ri}$amax( j1-1, x, 1_${ik}$ ) xmax = abs( x( k ) ) end if end if end do loop_30 else ! solve t**t*p = scale*c - jnext = 1 + jnext = 1_${ik}$ loop_40: do j = 1, n if( jone ) then rec = one / xmax if( work( j1 )>( bignum-xj )*rec ) then - call stdlib_${ri}$scal( n, rec, x, 1 ) + call stdlib${ii}$_${ri}$scal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j1 ) = x( j1 ) - stdlib_${ri}$dot( j1-1, t( 1, j1 ), 1, x, 1 ) + x( j1 ) = x( j1 ) - stdlib${ii}$_${ri}$dot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$, x, 1_${ik}$ ) xj = abs( x( j1 ) ) tjj = abs( t( j1, j1 ) ) tmp = t( j1, j1 ) if( tjjbignum*tjj ) then rec = one / xj - call stdlib_${ri}$scal( n, rec, x, 1 ) + call stdlib${ii}$_${ri}$scal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if @@ -36537,22 +36528,22 @@ module stdlib_linalg_lapack_${ri}$ if( xmax>one ) then rec = one / xmax if( max( work( j2 ), work( j1 ) )>( bignum-xj )*rec ) then - call stdlib_${ri}$scal( n, rec, x, 1 ) + call stdlib${ii}$_${ri}$scal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - d( 1, 1 ) = x( j1 ) - stdlib_${ri}$dot( j1-1, t( 1, j1 ), 1, x,1 ) - d( 2, 1 ) = x( j2 ) - stdlib_${ri}$dot( j1-1, t( 1, j2 ), 1, x,1 ) - call stdlib_${ri}$laln2( .true., 2, 1, smin, one, t( j1, j1 ),ldt, one, one, d, & - 2, zero, zero, v, 2,scaloc, xnorm, ierr ) - if( ierr/=0 )info = 2 + d( 1_${ik}$, 1_${ik}$ ) = x( j1 ) - stdlib${ii}$_${ri}$dot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$, x,1_${ik}$ ) + d( 2_${ik}$, 1_${ik}$ ) = x( j2 ) - stdlib${ii}$_${ri}$dot( j1-1, t( 1_${ik}$, j2 ), 1_${ik}$, x,1_${ik}$ ) + call stdlib${ii}$_${ri}$laln2( .true., 2_${ik}$, 1_${ik}$, smin, one, t( j1, j1 ),ldt, one, one, d, & + 2_${ik}$, zero, zero, v, 2_${ik}$,scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 2_${ik}$ if( scaloc/=one ) then - call stdlib_${ri}$scal( n, scaloc, x, 1 ) + call stdlib${ii}$_${ri}$scal( n, scaloc, x, 1_${ik}$ ) scale = scale*scaloc end if - x( j1 ) = v( 1, 1 ) - x( j2 ) = v( 2, 1 ) + x( j1 ) = v( 1_${ik}$, 1_${ik}$ ) + x( j2 ) = v( 2_${ik}$, 1_${ik}$ ) xmax = max( abs( x( j1 ) ), abs( x( j2 ) ), xmax ) end if end do loop_40 @@ -36566,36 +36557,36 @@ module stdlib_linalg_lapack_${ri}$ if( j>jnext )cycle loop_70 j1 = j j2 = j - jnext = j - 1 - if( j>1 ) then + jnext = j - 1_${ik}$ + if( j>1_${ik}$ ) then if( t( j, j-1 )/=zero ) then - j1 = j - 1 - jnext = j - 2 + j1 = j - 1_${ik}$ + jnext = j - 2_${ik}$ end if end if if( j1==j2 ) then ! 1 by 1 diagonal block ! scale if necessary to avoid overflow in division z = w - if( j1==1 )z = b( 1 ) + if( j1==1_${ik}$ )z = b( 1_${ik}$ ) xj = abs( x( j1 ) ) + abs( x( n+j1 ) ) tjj = abs( t( j1, j1 ) ) + abs( z ) tmp = t( j1, j1 ) if( tjjbignum*tjj ) then rec = one / xj - call stdlib_${ri}$scal( n2, rec, x, 1 ) + call stdlib${ii}$_${ri}$scal( n2, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - call stdlib_${ri}$ladiv( x( j1 ), x( n+j1 ), tmp, z, sr, si ) + call stdlib${ii}$_${ri}$ladiv( x( j1 ), x( n+j1 ), tmp, z, sr, si ) x( j1 ) = sr x( n+j1 ) = si xj = abs( x( j1 ) ) + abs( x( n+j1 ) ) @@ -36604,14 +36595,14 @@ module stdlib_linalg_lapack_${ri}$ if( xj>one ) then rec = one / xj if( work( j1 )>( bignum-xmax )*rec ) then - call stdlib_${ri}$scal( n2, rec, x, 1 ) + call stdlib${ii}$_${ri}$scal( n2, rec, x, 1_${ik}$ ) scale = scale*rec end if end if - if( j1>1 ) then - call stdlib_${ri}$axpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 ) - call stdlib_${ri}$axpy( j1-1, -x( n+j1 ), t( 1, j1 ), 1,x( n+1 ), 1 ) - x( 1 ) = x( 1 ) + b( j1 )*x( n+j1 ) + if( j1>1_${ik}$ ) then + call stdlib${ii}$_${ri}$axpy( j1-1, -x( j1 ), t( 1_${ik}$, j1 ), 1_${ik}$, x, 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( j1-1, -x( n+j1 ), t( 1_${ik}$, j1 ), 1_${ik}$,x( n+1 ), 1_${ik}$ ) + x( 1_${ik}$ ) = x( 1_${ik}$ ) + b( j1 )*x( n+j1 ) x( n+1 ) = x( n+1 ) - b( j1 )*x( j1 ) xmax = zero do k = 1, j1 - 1 @@ -36620,39 +36611,39 @@ module stdlib_linalg_lapack_${ri}$ end if else ! meet 2 by 2 diagonal block - d( 1, 1 ) = x( j1 ) - d( 2, 1 ) = x( j2 ) - d( 1, 2 ) = x( n+j1 ) - d( 2, 2 ) = x( n+j2 ) - call stdlib_${ri}$laln2( .false., 2, 2, sminw, one, t( j1, j1 ),ldt, one, one, & - d, 2, zero, -w, v, 2,scaloc, xnorm, ierr ) - if( ierr/=0 )info = 2 + d( 1_${ik}$, 1_${ik}$ ) = x( j1 ) + d( 2_${ik}$, 1_${ik}$ ) = x( j2 ) + d( 1_${ik}$, 2_${ik}$ ) = x( n+j1 ) + d( 2_${ik}$, 2_${ik}$ ) = x( n+j2 ) + call stdlib${ii}$_${ri}$laln2( .false., 2_${ik}$, 2_${ik}$, sminw, one, t( j1, j1 ),ldt, one, one, & + d, 2_${ik}$, zero, -w, v, 2_${ik}$,scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 2_${ik}$ if( scaloc/=one ) then - call stdlib_${ri}$scal( 2*n, scaloc, x, 1 ) + call stdlib${ii}$_${ri}$scal( 2_${ik}$*n, scaloc, x, 1_${ik}$ ) scale = scaloc*scale end if - x( j1 ) = v( 1, 1 ) - x( j2 ) = v( 2, 1 ) - x( n+j1 ) = v( 1, 2 ) - x( n+j2 ) = v( 2, 2 ) + x( j1 ) = v( 1_${ik}$, 1_${ik}$ ) + x( j2 ) = v( 2_${ik}$, 1_${ik}$ ) + x( n+j1 ) = v( 1_${ik}$, 2_${ik}$ ) + x( n+j2 ) = v( 2_${ik}$, 2_${ik}$ ) ! scale x(j1), .... to avoid overflow in ! updating right hand side. - xj = max( abs( v( 1, 1 ) )+abs( v( 1, 2 ) ),abs( v( 2, 1 ) )+abs( v( 2, 2 )& + xj = max( abs( v( 1_${ik}$, 1_${ik}$ ) )+abs( v( 1_${ik}$, 2_${ik}$ ) ),abs( v( 2_${ik}$, 1_${ik}$ ) )+abs( v( 2_${ik}$, 2_${ik}$ )& ) ) if( xj>one ) then rec = one / xj if( max( work( j1 ), work( j2 ) )>( bignum-xmax )*rec ) then - call stdlib_${ri}$scal( n2, rec, x, 1 ) + call stdlib${ii}$_${ri}$scal( n2, rec, x, 1_${ik}$ ) scale = scale*rec end if end if ! update the right-hand side. - if( j1>1 ) then - call stdlib_${ri}$axpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 ) - call stdlib_${ri}$axpy( j1-1, -x( j2 ), t( 1, j2 ), 1, x, 1 ) - call stdlib_${ri}$axpy( j1-1, -x( n+j1 ), t( 1, j1 ), 1,x( n+1 ), 1 ) - call stdlib_${ri}$axpy( j1-1, -x( n+j2 ), t( 1, j2 ), 1,x( n+1 ), 1 ) - x( 1 ) = x( 1 ) + b( j1 )*x( n+j1 ) +b( j2 )*x( n+j2 ) + if( j1>1_${ik}$ ) then + call stdlib${ii}$_${ri}$axpy( j1-1, -x( j1 ), t( 1_${ik}$, j1 ), 1_${ik}$, x, 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( j1-1, -x( j2 ), t( 1_${ik}$, j2 ), 1_${ik}$, x, 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( j1-1, -x( n+j1 ), t( 1_${ik}$, j1 ), 1_${ik}$,x( n+1 ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( j1-1, -x( n+j2 ), t( 1_${ik}$, j2 ), 1_${ik}$,x( n+1 ), 1_${ik}$ ) + x( 1_${ik}$ ) = x( 1_${ik}$ ) + b( j1 )*x( n+j1 ) +b( j2 )*x( n+j2 ) x( n+1 ) = x( n+1 ) - b( j1 )*x( j1 ) -b( j2 )*x( j2 ) xmax = zero do k = 1, j1 - 1 @@ -36663,16 +36654,16 @@ module stdlib_linalg_lapack_${ri}$ end do loop_70 else ! solve (t + ib)**t*(p+iq) = c+id - jnext = 1 + jnext = 1_${ik}$ loop_80: do j = 1, n if( jone ) then rec = one / xmax if( work( j1 )>( bignum-xj )*rec ) then - call stdlib_${ri}$scal( n2, rec, x, 1 ) + call stdlib${ii}$_${ri}$scal( n2, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j1 ) = x( j1 ) - stdlib_${ri}$dot( j1-1, t( 1, j1 ), 1, x, 1 ) - x( n+j1 ) = x( n+j1 ) - stdlib_${ri}$dot( j1-1, t( 1, j1 ), 1,x( n+1 ), 1 ) + x( j1 ) = x( j1 ) - stdlib${ii}$_${ri}$dot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$, x, 1_${ik}$ ) + x( n+j1 ) = x( n+j1 ) - stdlib${ii}$_${ri}$dot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$,x( n+1 ), 1_${ik}$ ) - if( j1>1 ) then + if( j1>1_${ik}$ ) then x( j1 ) = x( j1 ) - b( j1 )*x( n+1 ) - x( n+j1 ) = x( n+j1 ) + b( j1 )*x( 1 ) + x( n+j1 ) = x( n+j1 ) + b( j1 )*x( 1_${ik}$ ) end if xj = abs( x( j1 ) ) + abs( x( j1+n ) ) z = w - if( j1==1 )z = b( 1 ) + if( j1==1_${ik}$ )z = b( 1_${ik}$ ) ! scale if necessary to avoid overflow in ! complex division tjj = abs( t( j1, j1 ) ) + abs( z ) @@ -36705,17 +36696,17 @@ module stdlib_linalg_lapack_${ri}$ if( tjjbignum*tjj ) then rec = one / xj - call stdlib_${ri}$scal( n2, rec, x, 1 ) + call stdlib${ii}$_${ri}$scal( n2, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - call stdlib_${ri}$ladiv( x( j1 ), x( n+j1 ), tmp, -z, sr, si ) + call stdlib${ii}$_${ri}$ladiv( x( j1 ), x( n+j1 ), tmp, -z, sr, si ) x( j1 ) = sr x( j1+n ) = si xmax = max( abs( x( j1 ) )+abs( x( j1+n ) ), xmax ) @@ -36728,32 +36719,32 @@ module stdlib_linalg_lapack_${ri}$ if( xmax>one ) then rec = one / xmax if( max( work( j1 ), work( j2 ) )>( bignum-xj ) / xmax ) then - call stdlib_${ri}$scal( n2, rec, x, 1 ) + call stdlib${ii}$_${ri}$scal( n2, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - d( 1, 1 ) = x( j1 ) - stdlib_${ri}$dot( j1-1, t( 1, j1 ), 1, x,1 ) - d( 2, 1 ) = x( j2 ) - stdlib_${ri}$dot( j1-1, t( 1, j2 ), 1, x,1 ) - d( 1, 2 ) = x( n+j1 ) - stdlib_${ri}$dot( j1-1, t( 1, j1 ), 1,x( n+1 ), 1 ) + d( 1_${ik}$, 1_${ik}$ ) = x( j1 ) - stdlib${ii}$_${ri}$dot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$, x,1_${ik}$ ) + d( 2_${ik}$, 1_${ik}$ ) = x( j2 ) - stdlib${ii}$_${ri}$dot( j1-1, t( 1_${ik}$, j2 ), 1_${ik}$, x,1_${ik}$ ) + d( 1_${ik}$, 2_${ik}$ ) = x( n+j1 ) - stdlib${ii}$_${ri}$dot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$,x( n+1 ), 1_${ik}$ ) - d( 2, 2 ) = x( n+j2 ) - stdlib_${ri}$dot( j1-1, t( 1, j2 ), 1,x( n+1 ), 1 ) + d( 2_${ik}$, 2_${ik}$ ) = x( n+j2 ) - stdlib${ii}$_${ri}$dot( j1-1, t( 1_${ik}$, j2 ), 1_${ik}$,x( n+1 ), 1_${ik}$ ) - d( 1, 1 ) = d( 1, 1 ) - b( j1 )*x( n+1 ) - d( 2, 1 ) = d( 2, 1 ) - b( j2 )*x( n+1 ) - d( 1, 2 ) = d( 1, 2 ) + b( j1 )*x( 1 ) - d( 2, 2 ) = d( 2, 2 ) + b( j2 )*x( 1 ) - call stdlib_${ri}$laln2( .true., 2, 2, sminw, one, t( j1, j1 ),ldt, one, one, d,& - 2, zero, w, v, 2,scaloc, xnorm, ierr ) - if( ierr/=0 )info = 2 + d( 1_${ik}$, 1_${ik}$ ) = d( 1_${ik}$, 1_${ik}$ ) - b( j1 )*x( n+1 ) + d( 2_${ik}$, 1_${ik}$ ) = d( 2_${ik}$, 1_${ik}$ ) - b( j2 )*x( n+1 ) + d( 1_${ik}$, 2_${ik}$ ) = d( 1_${ik}$, 2_${ik}$ ) + b( j1 )*x( 1_${ik}$ ) + d( 2_${ik}$, 2_${ik}$ ) = d( 2_${ik}$, 2_${ik}$ ) + b( j2 )*x( 1_${ik}$ ) + call stdlib${ii}$_${ri}$laln2( .true., 2_${ik}$, 2_${ik}$, sminw, one, t( j1, j1 ),ldt, one, one, d,& + 2_${ik}$, zero, w, v, 2_${ik}$,scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 2_${ik}$ if( scaloc/=one ) then - call stdlib_${ri}$scal( n2, scaloc, x, 1 ) + call stdlib${ii}$_${ri}$scal( n2, scaloc, x, 1_${ik}$ ) scale = scaloc*scale end if - x( j1 ) = v( 1, 1 ) - x( j2 ) = v( 2, 1 ) - x( n+j1 ) = v( 1, 2 ) - x( n+j2 ) = v( 2, 2 ) + x( j1 ) = v( 1_${ik}$, 1_${ik}$ ) + x( j2 ) = v( 2_${ik}$, 1_${ik}$ ) + x( n+j1 ) = v( 1_${ik}$, 2_${ik}$ ) + x( n+j2 ) = v( 2_${ik}$, 2_${ik}$ ) xmax = max( abs( x( j1 ) )+abs( x( n+j1 ) ),abs( x( j2 ) )+abs( x( n+j2 ) )& , xmax ) end if @@ -36761,10 +36752,10 @@ module stdlib_linalg_lapack_${ri}$ end if end if return - end subroutine stdlib_${ri}$laqtr + end subroutine stdlib${ii}$_${ri}$laqtr - recursive subroutine stdlib_${ri}$laqz0( wants, wantq, wantz, n, ilo, ihi, a,lda, b, ldb, alphar, & + recursive subroutine stdlib${ii}$_${ri}$laqz0( wants, wantq, wantz, n, ilo, ihi, a,lda, b, ldb, alphar, & !! DLAQZ0: computes the eigenvalues of a real matrix pair (H,T), !! where H is an upper Hessenberg matrix and T is upper triangular, !! using the double-shift QZ method. @@ -36816,140 +36807,140 @@ module stdlib_linalg_lapack_${ri}$ alphai, beta,q, ldq, z, ldz, work, lwork, rec,info ) ! arguments character, intent( in ) :: wants, wantq, wantz - integer(ilp), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,rec - integer(ilp), intent( out ) :: info + integer(${ik}$), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,rec + integer(${ik}$), intent( out ) :: info real(${rk}$), intent( inout ) :: a( lda, * ), b( ldb, * ),q( ldq, * ), z( ldz, * ), alphar(& * ),alphai( * ), beta( * ), work( * ) ! local scalars real(${rk}$) :: smlnum, ulp, eshift, safmin, safmax, c1, s1, temp, swap - integer(ilp) :: istart, istop, iiter, maxit, istart2, k, ld, nshifts, nblock, nw, nmin,& + integer(${ik}$) :: istart, istop, iiter, maxit, istart2, k, ld, nshifts, nblock, nw, nmin,& nibble, n_undeflated, n_qeflated, ns, sweep_info, shiftpos, lworkreq, k2, istartm, & istopm, iwants, iwantq, iwantz, norm_info, aed_info, nwr, nbr, nsr, itemp1, itemp2, & rcost, i logical(lk) :: ilschur, ilq, ilz - character :: jbcmpz*3 + character(len=3_${ik}$) :: jbcmpz if( stdlib_lsame( wants, 'E' ) ) then ilschur = .false. - iwants = 1 + iwants = 1_${ik}$ else if( stdlib_lsame( wants, 'S' ) ) then ilschur = .true. - iwants = 2 + iwants = 2_${ik}$ else - iwants = 0 + iwants = 0_${ik}$ end if if( stdlib_lsame( wantq, 'N' ) ) then ilq = .false. - iwantq = 1 + iwantq = 1_${ik}$ else if( stdlib_lsame( wantq, 'V' ) ) then ilq = .true. - iwantq = 2 + iwantq = 2_${ik}$ else if( stdlib_lsame( wantq, 'I' ) ) then ilq = .true. - iwantq = 3 + iwantq = 3_${ik}$ else - iwantq = 0 + iwantq = 0_${ik}$ end if if( stdlib_lsame( wantz, 'N' ) ) then ilz = .false. - iwantz = 1 + iwantz = 1_${ik}$ else if( stdlib_lsame( wantz, 'V' ) ) then ilz = .true. - iwantz = 2 + iwantz = 2_${ik}$ else if( stdlib_lsame( wantz, 'I' ) ) then ilz = .true. - iwantz = 3 + iwantz = 3_${ik}$ else - iwantz = 0 + iwantz = 0_${ik}$ end if ! check argument values - info = 0 - if( iwants==0 ) then - info = -1 - else if( iwantq==0 ) then - info = -2 - else if( iwantz==0 ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( ilo<1 ) then - info = -5 + info = 0_${ik}$ + if( iwants==0_${ik}$ ) then + info = -1_${ik}$ + else if( iwantq==0_${ik}$ ) then + info = -2_${ik}$ + else if( iwantz==0_${ik}$ ) then + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( ilo<1_${ik}$ ) then + info = -5_${ik}$ else if( ihi>n .or. ihi= 2 ) then - call stdlib_${ri}$hgeqz( wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb,alphar, alphai,& + if( n < nmin .or. rec >= 2_${ik}$ ) then + call stdlib${ii}$_${ri}$hgeqz( wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb,alphar, alphai,& beta, q, ldq, z, ldz, work,lwork, info ) return end if ! find out required workspace - ! workspace query to stdlib_${ri}$laqz3 + ! workspace query to stdlib${ii}$_${ri}$laqz3 nw = max( nwr, nmin ) - call stdlib_${ri}$laqz3( ilschur, ilq, ilz, n, ilo, ihi, nw, a, lda, b, ldb,q, ldq, z, ldz, & - n_undeflated, n_qeflated, alphar,alphai, beta, work, nw, work, nw, work, -1, rec,& + call stdlib${ii}$_${ri}$laqz3( ilschur, ilq, ilz, n, ilo, ihi, nw, a, lda, b, ldb,q, ldq, z, ldz, & + n_undeflated, n_qeflated, alphar,alphai, beta, work, nw, work, nw, work, -1_${ik}$, rec,& aed_info ) - itemp1 = int( work( 1 ),KIND=ilp) - ! workspace query to stdlib_${ri}$laqz4 - call stdlib_${ri}$laqz4( ilschur, ilq, ilz, n, ilo, ihi, nsr, nbr, alphar,alphai, beta, a, & - lda, b, ldb, q, ldq, z, ldz, work,nbr, work, nbr, work, -1, sweep_info ) - itemp2 = int( work( 1 ),KIND=ilp) - lworkreq = max( itemp1+2*nw**2, itemp2+2*nbr**2 ) - if ( lwork ==-1 ) then - work( 1 ) = real( lworkreq,KIND=${rk}$) + itemp1 = int( work( 1_${ik}$ ),KIND=${ik}$) + ! workspace query to stdlib${ii}$_${ri}$laqz4 + call stdlib${ii}$_${ri}$laqz4( ilschur, ilq, ilz, n, ilo, ihi, nsr, nbr, alphar,alphai, beta, a, & + lda, b, ldb, q, ldq, z, ldz, work,nbr, work, nbr, work, -1_${ik}$, sweep_info ) + itemp2 = int( work( 1_${ik}$ ),KIND=${ik}$) + lworkreq = max( itemp1+2*nw**2_${ik}$, itemp2+2*nbr**2_${ik}$ ) + if ( lwork ==-1_${ik}$ ) then + work( 1_${ik}$ ) = real( lworkreq,KIND=${rk}$) return else if ( lwork < lworkreq ) then - info = -19 + info = -19_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'DLAQZ0', info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DLAQZ0', info ) return end if ! initialize q and z - if( iwantq==3 ) call stdlib_${ri}$laset( 'FULL', n, n, zero, one, q, ldq ) - if( iwantz==3 ) call stdlib_${ri}$laset( 'FULL', n, n, zero, one, z, ldz ) + if( iwantq==3_${ik}$ ) call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, q, ldq ) + if( iwantz==3_${ik}$ ) call stdlib${ii}$_${ri}$laset( 'FULL', n, n, zero, one, z, ldz ) ! get machine constants - safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) safmax = one/safmin - call stdlib_${ri}$labad( safmin, safmax ) - ulp = stdlib_${ri}$lamch( 'PRECISION' ) + call stdlib${ii}$_${ri}$labad( safmin, safmax ) + ulp = stdlib${ii}$_${ri}$lamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=${rk}$)/ulp ) istart = ilo istop = ihi - maxit = 3*( ihi-ilo+1 ) - ld = 0 + maxit = 3_${ik}$*( ihi-ilo+1 ) + ld = 0_${ik}$ do iiter = 1, maxit if( iiter >= maxit ) then info = istop+1 @@ -36964,13 +36955,13 @@ module stdlib_linalg_lapack_${ri}$ abs( a( istop-2,istop-2 ) ) ) ) ) then a( istop-1, istop-2 ) = zero istop = istop-2 - ld = 0 + ld = 0_${ik}$ eshift = zero else if ( abs( a( istop, istop-1 ) ) <= max( smlnum,ulp*( abs( a( istop, istop ) )+& abs( a( istop-1,istop-1 ) ) ) ) ) then a( istop, istop-1 ) = zero istop = istop-1 - ld = 0 + ld = 0_${ik}$ eshift = zero end if ! check deflations at the start @@ -36978,13 +36969,13 @@ module stdlib_linalg_lapack_${ri}$ ) )+abs( a( istart+2,istart+2 ) ) ) ) ) then a( istart+2, istart+1 ) = zero istart = istart+2 - ld = 0 + ld = 0_${ik}$ eshift = zero else if ( abs( a( istart+1, istart ) ) <= max( smlnum,ulp*( abs( a( istart, istart )& )+abs( a( istart+1,istart+1 ) ) ) ) ) then a( istart+1, istart ) = zero istart = istart+1 - ld = 0 + ld = 0_${ik}$ eshift = zero end if if ( istart+1 >= istop ) then @@ -37002,7 +36993,7 @@ module stdlib_linalg_lapack_${ri}$ end do ! get range to apply rotations to if ( ilschur ) then - istartm = 1 + istartm = 1_${ik}$ istopm = n else istartm = istart2 @@ -37023,41 +37014,41 @@ module stdlib_linalg_lapack_${ri}$ ! a diagonal element of b is negligable, move it ! to the top and deflate it do k2 = k, istart2+1, -1 - call stdlib_${ri}$lartg( b( k2-1, k2 ), b( k2-1, k2-1 ), c1, s1,temp ) + call stdlib${ii}$_${ri}$lartg( b( k2-1, k2 ), b( k2-1, k2-1 ), c1, s1,temp ) b( k2-1, k2 ) = temp b( k2-1, k2-1 ) = zero - call stdlib_${ri}$rot( k2-2-istartm+1, b( istartm, k2 ), 1,b( istartm, k2-1 ), & - 1, c1, s1 ) - call stdlib_${ri}$rot( min( k2+1, istop )-istartm+1, a( istartm,k2 ), 1, a( & - istartm, k2-1 ), 1, c1, s1 ) + call stdlib${ii}$_${ri}$rot( k2-2-istartm+1, b( istartm, k2 ), 1_${ik}$,b( istartm, k2-1 ), & + 1_${ik}$, c1, s1 ) + call stdlib${ii}$_${ri}$rot( min( k2+1, istop )-istartm+1, a( istartm,k2 ), 1_${ik}$, a( & + istartm, k2-1 ), 1_${ik}$, c1, s1 ) if ( ilz ) then - call stdlib_${ri}$rot( n, z( 1, k2 ), 1, z( 1, k2-1 ), 1, c1,s1 ) + call stdlib${ii}$_${ri}$rot( n, z( 1_${ik}$, k2 ), 1_${ik}$, z( 1_${ik}$, k2-1 ), 1_${ik}$, c1,s1 ) end if if( k2= istop ) then istop = istart2-1 - ld = 0 + ld = 0_${ik}$ eshift = zero cycle end if @@ -37079,7 +37070,7 @@ module stdlib_linalg_lapack_${ri}$ if ( istop-istart2+1 < nmin ) then ! setting nw to the size of the subblock will make aed deflate ! all the eigenvalues. this is slightly more efficient than just - ! using stdlib_${ri}$hgeqz because the off diagonal part gets updated via blas. + ! using stdlib${ii}$_${ri}$hgeqz because the off diagonal part gets updated via blas. if ( istop-istart+1 < nmin ) then nw = istop-istart+1 istart2 = istart @@ -37088,15 +37079,15 @@ module stdlib_linalg_lapack_${ri}$ end if end if ! time for aed - call stdlib_${ri}$laqz3( ilschur, ilq, ilz, n, istart2, istop, nw, a, lda,b, ldb, q, ldq,& - z, ldz, n_undeflated, n_qeflated,alphar, alphai, beta, work, nw, work( nw**2+1 ),& - nw, work( 2*nw**2+1 ), lwork-2*nw**2, rec,aed_info ) - if ( n_qeflated > 0 ) then + call stdlib${ii}$_${ri}$laqz3( ilschur, ilq, ilz, n, istart2, istop, nw, a, lda,b, ldb, q, ldq,& + z, ldz, n_undeflated, n_qeflated,alphar, alphai, beta, work, nw, work( nw**2_${ik}$+1 ),& + nw, work( 2_${ik}$*nw**2_${ik}$+1 ), lwork-2*nw**2_${ik}$, rec,aed_info ) + if ( n_qeflated > 0_${ik}$ ) then istop = istop-n_qeflated - ld = 0 + ld = 0_${ik}$ eshift = zero end if - if ( 100*n_qeflated > nibble*( n_qeflated+n_undeflated ) .or.istop-istart2+1 < nmin & + if ( 100_${ik}$*n_qeflated > nibble*( n_qeflated+n_undeflated ) .or.istop-istart2+1 < nmin & ) then ! aed has uncovered many eigenvalues. skip a qz sweep and run ! aed again. @@ -37124,7 +37115,7 @@ module stdlib_linalg_lapack_${ri}$ beta( i+2 ) = swap end if end do - if ( mod( ld, 6 ) == 0 ) then + if ( mod( ld, 6_${ik}$ ) == 0_${ik}$ ) then ! exceptional shift. chosen for no particularly good reason. if( ( real( maxit,KIND=${rk}$)*safmin )*abs( a( istop,istop-1 ) )= 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_${ri}$isnan( v( 1 ) ) .or.stdlib_${ri}$isnan( v( 2 ) ) .or. stdlib_${ri}$isnan( v( 3 ) ) ) & + if( abs( v( 1_${ik}$ ) )>safmax .or. abs( v( 2_${ik}$ ) ) > safmax .or.abs( v( 3_${ik}$ ) )>safmax .or. & + stdlib${ii}$_${ri}$isnan( v( 1_${ik}$ ) ) .or.stdlib${ii}$_${ri}$isnan( v( 2_${ik}$ ) ) .or. stdlib${ii}$_${ri}$isnan( 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_${ri}$laqz1 + end subroutine stdlib${ii}$_${ri}$laqz1 - pure subroutine stdlib_${ri}$laqz2( ilq, ilz, k, istartm, istopm, ihi, a, lda, b,ldb, nq, qstart, & + pure subroutine stdlib${ii}$_${ri}$laqz2( ilq, ilz, k, istartm, istopm, ihi, a, lda, b,ldb, nq, qstart, & !! DLAQZ2: chases a 2x2 shift bulge in a matrix pencil down a single position q, ldq, nz, zstart, z, ldz ) ! arguments logical(lk), intent( in ) :: ilq, ilz - integer(ilp), intent( in ) :: k, lda, ldb, ldq, ldz, istartm, istopm,nq, nz, qstart, & + integer(${ik}$), intent( in ) :: k, lda, ldb, ldq, ldz, istartm, istopm,nq, nz, qstart, & zstart, ihi real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) ! local variables - real(${rk}$) :: h(2,3), c1, s1, c2, s2, temp + real(${rk}$) :: 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_${ri}$lartg( h( 1, 1 ), h( 2, 1 ), c1, s1, temp ) - h( 2, 1 ) = zero - h( 1, 1 ) = temp - call stdlib_${ri}$rot( 2, h( 1, 2 ), 2, h( 2, 2 ), 2, c1, s1 ) - call stdlib_${ri}$lartg( h( 2, 3 ), h( 2, 2 ), c1, s1, temp ) - call stdlib_${ri}$rot( 1, h( 1, 3 ), 1, h( 1, 2 ), 1, c1, s1 ) - call stdlib_${ri}$lartg( h( 1, 2 ), h( 1, 1 ), c2, s2, temp ) - call stdlib_${ri}$rot( ihi-istartm+1, b( istartm, ihi ), 1, b( istartm,ihi-1 ), 1, c1, & + call stdlib${ii}$_${ri}$lartg( 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}$_${ri}$rot( 2_${ik}$, h( 1_${ik}$, 2_${ik}$ ), 2_${ik}$, h( 2_${ik}$, 2_${ik}$ ), 2_${ik}$, c1, s1 ) + call stdlib${ii}$_${ri}$lartg( h( 2_${ik}$, 3_${ik}$ ), h( 2_${ik}$, 2_${ik}$ ), c1, s1, temp ) + call stdlib${ii}$_${ri}$rot( 1_${ik}$, h( 1_${ik}$, 3_${ik}$ ), 1_${ik}$, h( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, c1, s1 ) + call stdlib${ii}$_${ri}$lartg( h( 1_${ik}$, 2_${ik}$ ), h( 1_${ik}$, 1_${ik}$ ), c2, s2, temp ) + call stdlib${ii}$_${ri}$rot( ihi-istartm+1, b( istartm, ihi ), 1_${ik}$, b( istartm,ihi-1 ), 1_${ik}$, c1, & s1 ) - call stdlib_${ri}$rot( ihi-istartm+1, b( istartm, ihi-1 ), 1, b( istartm,ihi-2 ), 1, c2, & + call stdlib${ii}$_${ri}$rot( 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_${ri}$rot( ihi-istartm+1, a( istartm, ihi ), 1, a( istartm,ihi-1 ), 1, c1, & + call stdlib${ii}$_${ri}$rot( ihi-istartm+1, a( istartm, ihi ), 1_${ik}$, a( istartm,ihi-1 ), 1_${ik}$, c1, & s1 ) - call stdlib_${ri}$rot( ihi-istartm+1, a( istartm, ihi-1 ), 1, a( istartm,ihi-2 ), 1, c2, & + call stdlib${ii}$_${ri}$rot( ihi-istartm+1, a( istartm, ihi-1 ), 1_${ik}$, a( istartm,ihi-2 ), 1_${ik}$, c2, & s2 ) if ( ilz ) then - call stdlib_${ri}$rot( nz, z( 1, ihi-zstart+1 ), 1, z( 1, ihi-1-zstart+1 ), 1, c1, s1 & + call stdlib${ii}$_${ri}$rot( nz, z( 1_${ik}$, ihi-zstart+1 ), 1_${ik}$, z( 1_${ik}$, ihi-1-zstart+1 ), 1_${ik}$, c1, s1 & ) - call stdlib_${ri}$rot( nz, z( 1, ihi-1-zstart+1 ), 1, z( 1,ihi-2-zstart+1 ), 1, c2, & + call stdlib${ii}$_${ri}$rot( 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_${ri}$lartg( a( ihi-1, ihi-2 ), a( ihi, ihi-2 ), c1, s1,temp ) + call stdlib${ii}$_${ri}$lartg( a( ihi-1, ihi-2 ), a( ihi, ihi-2 ), c1, s1,temp ) a( ihi-1, ihi-2 ) = temp a( ihi, ihi-2 ) = zero - call stdlib_${ri}$rot( istopm-ihi+2, a( ihi-1, ihi-1 ), lda, a( ihi,ihi-1 ), lda, c1, s1 & + call stdlib${ii}$_${ri}$rot( istopm-ihi+2, a( ihi-1, ihi-1 ), lda, a( ihi,ihi-1 ), lda, c1, s1 & ) - call stdlib_${ri}$rot( istopm-ihi+2, b( ihi-1, ihi-1 ), ldb, b( ihi,ihi-1 ), ldb, c1, s1 & + call stdlib${ii}$_${ri}$rot( istopm-ihi+2, b( ihi-1, ihi-1 ), ldb, b( ihi,ihi-1 ), ldb, c1, s1 & ) if ( ilq ) then - call stdlib_${ri}$rot( nq, q( 1, ihi-1-qstart+1 ), 1, q( 1, ihi-qstart+1 ), 1, c1, s1 & + call stdlib${ii}$_${ri}$rot( nq, q( 1_${ik}$, ihi-1-qstart+1 ), 1_${ik}$, q( 1_${ik}$, ihi-qstart+1 ), 1_${ik}$, c1, s1 & ) end if - call stdlib_${ri}$lartg( b( ihi, ihi ), b( ihi, ihi-1 ), c1, s1, temp ) + call stdlib${ii}$_${ri}$lartg( b( ihi, ihi ), b( ihi, ihi-1 ), c1, s1, temp ) b( ihi, ihi ) = temp b( ihi, ihi-1 ) = zero - call stdlib_${ri}$rot( ihi-istartm, b( istartm, ihi ), 1, b( istartm,ihi-1 ), 1, c1, s1 ) + call stdlib${ii}$_${ri}$rot( ihi-istartm, b( istartm, ihi ), 1_${ik}$, b( istartm,ihi-1 ), 1_${ik}$, c1, s1 ) - call stdlib_${ri}$rot( ihi-istartm+1, a( istartm, ihi ), 1, a( istartm,ihi-1 ), 1, c1, & + call stdlib${ii}$_${ri}$rot( ihi-istartm+1, a( istartm, ihi ), 1_${ik}$, a( istartm,ihi-1 ), 1_${ik}$, c1, & s1 ) if ( ilz ) then - call stdlib_${ri}$rot( nz, z( 1, ihi-zstart+1 ), 1, z( 1, ihi-1-zstart+1 ), 1, c1, s1 & + call stdlib${ii}$_${ri}$rot( 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_${ri}$lartg( h( 1, 1 ), h( 2, 1 ), c1, s1, temp ) - h( 2, 1 ) = zero - h( 1, 1 ) = temp - call stdlib_${ri}$rot( 2, h( 1, 2 ), 2, h( 2, 2 ), 2, c1, s1 ) + call stdlib${ii}$_${ri}$lartg( 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}$_${ri}$rot( 2_${ik}$, h( 1_${ik}$, 2_${ik}$ ), 2_${ik}$, h( 2_${ik}$, 2_${ik}$ ), 2_${ik}$, c1, s1 ) ! calculate z1 and z2 - call stdlib_${ri}$lartg( h( 2, 3 ), h( 2, 2 ), c1, s1, temp ) - call stdlib_${ri}$rot( 1, h( 1, 3 ), 1, h( 1, 2 ), 1, c1, s1 ) - call stdlib_${ri}$lartg( h( 1, 2 ), h( 1, 1 ), c2, s2, temp ) + call stdlib${ii}$_${ri}$lartg( h( 2_${ik}$, 3_${ik}$ ), h( 2_${ik}$, 2_${ik}$ ), c1, s1, temp ) + call stdlib${ii}$_${ri}$rot( 1_${ik}$, h( 1_${ik}$, 3_${ik}$ ), 1_${ik}$, h( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, c1, s1 ) + call stdlib${ii}$_${ri}$lartg( h( 1_${ik}$, 2_${ik}$ ), h( 1_${ik}$, 1_${ik}$ ), c2, s2, temp ) ! apply transformations from the right - call stdlib_${ri}$rot( k+3-istartm+1, a( istartm, k+2 ), 1, a( istartm,k+1 ), 1, c1, s1 ) + call stdlib${ii}$_${ri}$rot( k+3-istartm+1, a( istartm, k+2 ), 1_${ik}$, a( istartm,k+1 ), 1_${ik}$, c1, s1 ) - call stdlib_${ri}$rot( k+3-istartm+1, a( istartm, k+1 ), 1, a( istartm,k ), 1, c2, s2 ) + call stdlib${ii}$_${ri}$rot( k+3-istartm+1, a( istartm, k+1 ), 1_${ik}$, a( istartm,k ), 1_${ik}$, c2, s2 ) - call stdlib_${ri}$rot( k+2-istartm+1, b( istartm, k+2 ), 1, b( istartm,k+1 ), 1, c1, s1 ) + call stdlib${ii}$_${ri}$rot( k+2-istartm+1, b( istartm, k+2 ), 1_${ik}$, b( istartm,k+1 ), 1_${ik}$, c1, s1 ) - call stdlib_${ri}$rot( k+2-istartm+1, b( istartm, k+1 ), 1, b( istartm,k ), 1, c2, s2 ) + call stdlib${ii}$_${ri}$rot( k+2-istartm+1, b( istartm, k+1 ), 1_${ik}$, b( istartm,k ), 1_${ik}$, c2, s2 ) if ( ilz ) then - call stdlib_${ri}$rot( nz, z( 1, k+2-zstart+1 ), 1, z( 1, k+1-zstart+1 ), 1, c1, s1 ) + call stdlib${ii}$_${ri}$rot( nz, z( 1_${ik}$, k+2-zstart+1 ), 1_${ik}$, z( 1_${ik}$, k+1-zstart+1 ), 1_${ik}$, c1, s1 ) - call stdlib_${ri}$rot( nz, z( 1, k+1-zstart+1 ), 1, z( 1, k-zstart+1 ),1, c2, s2 ) + call stdlib${ii}$_${ri}$rot( 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_${ri}$lartg( a( k+2, k ), a( k+3, k ), c1, s1, temp ) + call stdlib${ii}$_${ri}$lartg( a( k+2, k ), a( k+3, k ), c1, s1, temp ) a( k+2, k ) = temp a( k+3, k ) = zero - call stdlib_${ri}$lartg( a( k+1, k ), a( k+2, k ), c2, s2, temp ) + call stdlib${ii}$_${ri}$lartg( a( k+1, k ), a( k+2, k ), c2, s2, temp ) a( k+1, k ) = temp a( k+2, k ) = zero ! apply transformations from the left - call stdlib_${ri}$rot( istopm-k, a( k+2, k+1 ), lda, a( k+3, k+1 ), lda,c1, s1 ) - call stdlib_${ri}$rot( istopm-k, a( k+1, k+1 ), lda, a( k+2, k+1 ), lda,c2, s2 ) - call stdlib_${ri}$rot( istopm-k, b( k+2, k+1 ), ldb, b( k+3, k+1 ), ldb,c1, s1 ) - call stdlib_${ri}$rot( istopm-k, b( k+1, k+1 ), ldb, b( k+2, k+1 ), ldb,c2, s2 ) + call stdlib${ii}$_${ri}$rot( istopm-k, a( k+2, k+1 ), lda, a( k+3, k+1 ), lda,c1, s1 ) + call stdlib${ii}$_${ri}$rot( istopm-k, a( k+1, k+1 ), lda, a( k+2, k+1 ), lda,c2, s2 ) + call stdlib${ii}$_${ri}$rot( istopm-k, b( k+2, k+1 ), ldb, b( k+3, k+1 ), ldb,c1, s1 ) + call stdlib${ii}$_${ri}$rot( istopm-k, b( k+1, k+1 ), ldb, b( k+2, k+1 ), ldb,c2, s2 ) if ( ilq ) then - call stdlib_${ri}$rot( nq, q( 1, k+2-qstart+1 ), 1, q( 1, k+3-qstart+1 ), 1, c1, s1 ) + call stdlib${ii}$_${ri}$rot( nq, q( 1_${ik}$, k+2-qstart+1 ), 1_${ik}$, q( 1_${ik}$, k+3-qstart+1 ), 1_${ik}$, c1, s1 ) - call stdlib_${ri}$rot( nq, q( 1, k+1-qstart+1 ), 1, q( 1, k+2-qstart+1 ), 1, c2, s2 ) + call stdlib${ii}$_${ri}$rot( 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_${ri}$laqz2 + end subroutine stdlib${ii}$_${ri}$laqz2 - recursive subroutine stdlib_${ri}$laqz3( ilschur, ilq, ilz, n, ilo, ihi, nw,a, lda, b, ldb, q, & + recursive subroutine stdlib${ii}$_${ri}$laqz3( ilschur, ilq, ilz, n, ilo, ihi, nw,a, lda, b, ldb, q, & !! DLAQZ3: performs AED ldq, z, ldz, ns,nd, alphar, alphai, beta, qc, ldqc,zc, ldzc, work, lwork, rec, info ) ! arguments logical(lk), intent( in ) :: ilschur, ilq, ilz - integer(ilp), intent( in ) :: n, ilo, ihi, nw, lda, ldb, ldq, ldz,ldqc, ldzc, lwork, & + integer(${ik}$), intent( in ) :: n, ilo, ihi, nw, lda, ldb, ldq, ldz,ldqc, ldzc, lwork, & rec real(${rk}$), intent( inout ) :: a( lda, * ), b( ldb, * ),q( ldq, * ), z( ldz, * ), alphar(& * ),alphai( * ), beta( * ) - integer(ilp), intent( out ) :: ns, nd, info + integer(${ik}$), intent( out ) :: ns, nd, info real(${rk}$), intent(inout) :: qc(ldqc,*), zc(ldzc,*) real(${rk}$), intent(out) :: work(*) ! local scalars logical(lk) :: bulge - integer(ilp) :: jw, kwtop, kwbot, istopm, istartm, k, k2, dtgexc_info, ifst, ilst, & + integer(${ik}$) :: jw, kwtop, kwbot, istopm, istartm, k, k2, dtgexc_info, ifst, ilst, & lworkreq, qz_small_info real(${rk}$) :: s, smlnum, ulp, safmin, safmax, c1, s1, temp - info = 0 + info = 0_${ik}$ ! set up deflation window jw = min( nw, ihi-ilo+1 ) kwtop = ihi-jw+1 @@ -37350,63 +37342,63 @@ module stdlib_linalg_lapack_${ri}$ s = a( kwtop, kwtop-1 ) end if ! determine required workspace - ifst = 1 + ifst = 1_${ik}$ ilst = jw - call stdlib_${ri}$tgexc( .true., .true., jw, a, lda, b, ldb, qc, ldqc, zc,ldzc, ifst, ilst, & - work, -1, dtgexc_info ) - lworkreq = int( work( 1 ),KIND=ilp) - call stdlib_${ri}$laqz0( 'S', 'V', 'V', jw, 1, jw, a( kwtop, kwtop ), lda,b( kwtop, kwtop ),& - ldb, alphar, alphai, beta, qc,ldqc, zc, ldzc, work, -1, rec+1, qz_small_info ) - lworkreq = max( lworkreq, int( work( 1 ),KIND=ilp)+2*jw**2 ) - lworkreq = max( lworkreq, n*nw, 2*nw**2+n ) - if ( lwork ==-1 ) then + call stdlib${ii}$_${ri}$tgexc( .true., .true., jw, a, lda, b, ldb, qc, ldqc, zc,ldzc, ifst, ilst, & + work, -1_${ik}$, dtgexc_info ) + lworkreq = int( work( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_${ri}$laqz0( 'S', 'V', 'V', jw, 1_${ik}$, jw, a( kwtop, kwtop ), lda,b( kwtop, kwtop ),& + ldb, alphar, alphai, beta, qc,ldqc, zc, ldzc, work, -1_${ik}$, rec+1, qz_small_info ) + lworkreq = max( lworkreq, int( work( 1_${ik}$ ),KIND=${ik}$)+2_${ik}$*jw**2_${ik}$ ) + lworkreq = max( lworkreq, n*nw, 2_${ik}$*nw**2_${ik}$+n ) + if ( lwork ==-1_${ik}$ ) then ! workspace query, quick return - work( 1 ) = lworkreq + work( 1_${ik}$ ) = lworkreq return else if ( lwork < lworkreq ) then - info = -26 + info = -26_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'DLAQZ3', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DLAQZ3', -info ) return end if ! get machine constants - safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) safmax = one/safmin - call stdlib_${ri}$labad( safmin, safmax ) - ulp = stdlib_${ri}$lamch( 'PRECISION' ) + call stdlib${ii}$_${ri}$labad( safmin, safmax ) + ulp = stdlib${ii}$_${ri}$lamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=${rk}$)/ulp ) if ( ihi == kwtop ) then ! 1 by 1 deflation window, just try a regular deflation alphar( kwtop ) = a( kwtop, kwtop ) alphai( kwtop ) = zero beta( kwtop ) = b( kwtop, kwtop ) - ns = 1 - nd = 0 + ns = 1_${ik}$ + nd = 0_${ik}$ if ( abs( s ) <= max( smlnum, ulp*abs( a( kwtop,kwtop ) ) ) ) then - ns = 0 - nd = 1 + ns = 0_${ik}$ + nd = 1_${ik}$ if ( kwtop > ilo ) then a( kwtop, kwtop-1 ) = zero end if end if end if ! store window in case of convergence failure - call stdlib_${ri}$lacpy( 'ALL', jw, jw, a( kwtop, kwtop ), lda, work, jw ) - call stdlib_${ri}$lacpy( 'ALL', jw, jw, b( kwtop, kwtop ), ldb, work( jw**2+1 ), jw ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', jw, jw, a( kwtop, kwtop ), lda, work, jw ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', jw, jw, b( kwtop, kwtop ), ldb, work( jw**2_${ik}$+1 ), jw ) ! transform window to real schur form - call stdlib_${ri}$laset( 'FULL', jw, jw, zero, one, qc, ldqc ) - call stdlib_${ri}$laset( 'FULL', jw, jw, zero, one, zc, ldzc ) - call stdlib_${ri}$laqz0( 'S', 'V', 'V', jw, 1, jw, a( kwtop, kwtop ), lda,b( kwtop, kwtop ),& - ldb, alphar, alphai, beta, qc,ldqc, zc, ldzc, work( 2*jw**2+1 ), lwork-2*jw**2,rec+1, & + call stdlib${ii}$_${ri}$laset( 'FULL', jw, jw, zero, one, qc, ldqc ) + call stdlib${ii}$_${ri}$laset( 'FULL', jw, jw, zero, one, zc, ldzc ) + call stdlib${ii}$_${ri}$laqz0( 'S', 'V', 'V', jw, 1_${ik}$, jw, a( kwtop, kwtop ), lda,b( kwtop, kwtop ),& + ldb, alphar, alphai, beta, qc,ldqc, zc, ldzc, work( 2_${ik}$*jw**2_${ik}$+1 ), lwork-2*jw**2_${ik}$,rec+1, & qz_small_info ) - if( qz_small_info /= 0 ) then + if( qz_small_info /= 0_${ik}$ ) then ! convergence failure, restore the window and exit - nd = 0 + nd = 0_${ik}$ ns = jw-qz_small_info - call stdlib_${ri}$lacpy( 'ALL', jw, jw, work, jw, a( kwtop, kwtop ), lda ) - call stdlib_${ri}$lacpy( 'ALL', jw, jw, work( jw**2+1 ), jw, b( kwtop,kwtop ), ldb ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', jw, jw, work, jw, a( kwtop, kwtop ), lda ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', jw, jw, work( jw**2_${ik}$+1 ), jw, b( kwtop,kwtop ), ldb ) return end if @@ -37415,11 +37407,11 @@ module stdlib_linalg_lapack_${ri}$ kwbot = kwtop-1 else kwbot = ihi - k = 1 - k2 = 1 + k = 1_${ik}$ + k2 = 1_${ik}$ do while ( k <= jw ) bulge = .false. - if ( kwbot-kwtop+1 >= 2 ) then + if ( kwbot-kwtop+1 >= 2_${ik}$ ) then bulge = a( kwbot, kwbot-1 ) /= zero end if if ( bulge ) then @@ -37429,7 +37421,7 @@ module stdlib_linalg_lapack_${ri}$ if( temp == zero )then temp = abs( s ) end if - if ( max( abs( s*qc( 1, kwbot-kwtop ) ), abs( s*qc( 1,kwbot-kwtop+1 ) ) ) <= & + if ( max( abs( s*qc( 1_${ik}$, kwbot-kwtop ) ), abs( s*qc( 1_${ik}$,kwbot-kwtop+1 ) ) ) <= & max( smlnum,ulp*temp ) ) then ! deflatable kwbot = kwbot-2 @@ -37437,7 +37429,7 @@ module stdlib_linalg_lapack_${ri}$ ! not deflatable, move out of the way ifst = kwbot-kwtop+1 ilst = k2 - call stdlib_${ri}$tgexc( .true., .true., jw, a( kwtop, kwtop ),lda, b( kwtop, & + call stdlib${ii}$_${ri}$tgexc( .true., .true., jw, a( kwtop, kwtop ),lda, b( kwtop, & kwtop ), ldb, qc, ldqc,zc, ldzc, ifst, ilst, work, lwork,dtgexc_info ) k2 = k2+2 @@ -37449,7 +37441,7 @@ module stdlib_linalg_lapack_${ri}$ if( temp == zero ) then temp = abs( s ) end if - if ( ( abs( s*qc( 1, kwbot-kwtop+1 ) ) ) <= max( ulp*temp, smlnum ) ) & + if ( ( abs( s*qc( 1_${ik}$, kwbot-kwtop+1 ) ) ) <= max( ulp*temp, smlnum ) ) & then ! deflatable kwbot = kwbot-1 @@ -37457,7 +37449,7 @@ module stdlib_linalg_lapack_${ri}$ ! not deflatable, move out of the way ifst = kwbot-kwtop+1 ilst = k2 - call stdlib_${ri}$tgexc( .true., .true., jw, a( kwtop, kwtop ),lda, b( kwtop, & + call stdlib${ii}$_${ri}$tgexc( .true., .true., jw, a( kwtop, kwtop ),lda, b( kwtop, & kwtop ), ldb, qc, ldqc,zc, ldzc, ifst, ilst, work, lwork,dtgexc_info ) k2 = k2+1 @@ -37479,7 +37471,7 @@ module stdlib_linalg_lapack_${ri}$ end if if ( bulge ) then ! 2x2 eigenvalue block - call stdlib_${ri}$lag2( a( k, k ), lda, b( k, k ), ldb, safmin,beta( k ), beta( k+1 ),& + call stdlib${ii}$_${ri}$lag2( a( k, k ), lda, b( k, k ), ldb, safmin,beta( k ), beta( k+1 ),& alphar( k ),alphar( k+1 ), alphai( k ) ) alphai( k+1 ) = -alphai( k ) k = k+2 @@ -37493,16 +37485,16 @@ module stdlib_linalg_lapack_${ri}$ end do if ( kwtop /= ilo .and. s /= zero ) then ! reflect spike back, this will create optimally packed bulges - a( kwtop:kwbot, kwtop-1 ) = a( kwtop, kwtop-1 )*qc( 1,1:jw-nd ) + a( kwtop:kwbot, kwtop-1 ) = a( kwtop, kwtop-1 )*qc( 1_${ik}$,1_${ik}$:jw-nd ) do k = kwbot-1, kwtop, -1 - call stdlib_${ri}$lartg( a( k, kwtop-1 ), a( k+1, kwtop-1 ), c1, s1,temp ) + call stdlib${ii}$_${ri}$lartg( a( k, kwtop-1 ), a( k+1, kwtop-1 ), c1, s1,temp ) a( k, kwtop-1 ) = temp a( k+1, kwtop-1 ) = zero k2 = max( kwtop, k-1 ) - call stdlib_${ri}$rot( ihi-k2+1, a( k, k2 ), lda, a( k+1, k2 ), lda, c1,s1 ) - call stdlib_${ri}$rot( ihi-( k-1 )+1, b( k, k-1 ), ldb, b( k+1, k-1 ),ldb, c1, s1 ) + call stdlib${ii}$_${ri}$rot( ihi-k2+1, a( k, k2 ), lda, a( k+1, k2 ), lda, c1,s1 ) + call stdlib${ii}$_${ri}$rot( ihi-( k-1 )+1_${ik}$, b( k, k-1 ), ldb, b( k+1, k-1 ),ldb, c1, s1 ) - call stdlib_${ri}$rot( jw, qc( 1, k-kwtop+1 ), 1, qc( 1, k+1-kwtop+1 ),1, c1, s1 ) + call stdlib${ii}$_${ri}$rot( jw, qc( 1_${ik}$, k-kwtop+1 ), 1_${ik}$, qc( 1_${ik}$, k+1-kwtop+1 ),1_${ik}$, c1, s1 ) end do ! chase bulges down @@ -37513,7 +37505,7 @@ module stdlib_linalg_lapack_${ri}$ if ( ( k >= kwtop+1 ) .and. a( k+1, k-1 ) /= zero ) then ! move double pole block down and remove it do k2 = k-1, kwbot-2 - call stdlib_${ri}$laqz2( .true., .true., k2, kwtop, kwtop+jw-1,kwbot, a, lda, b,& + call stdlib${ii}$_${ri}$laqz2( .true., .true., k2, kwtop, kwtop+jw-1,kwbot, a, lda, b,& ldb, jw, kwtop, qc,ldqc, jw, kwtop, zc, ldzc ) end do k = k-2 @@ -37521,35 +37513,35 @@ module stdlib_linalg_lapack_${ri}$ ! k points to single shift do k2 = k, kwbot-2 ! move shift down - call stdlib_${ri}$lartg( b( k2+1, k2+1 ), b( k2+1, k2 ), c1, s1,temp ) + call stdlib${ii}$_${ri}$lartg( b( k2+1, k2+1 ), b( k2+1, k2 ), c1, s1,temp ) b( k2+1, k2+1 ) = temp b( k2+1, k2 ) = zero - call stdlib_${ri}$rot( k2+2-istartm+1, a( istartm, k2+1 ), 1,a( istartm, k2 ), & - 1, c1, s1 ) - call stdlib_${ri}$rot( k2-istartm+1, b( istartm, k2+1 ), 1,b( istartm, k2 ), 1, & + call stdlib${ii}$_${ri}$rot( k2+2-istartm+1, a( istartm, k2+1 ), 1_${ik}$,a( istartm, k2 ), & + 1_${ik}$, c1, s1 ) + call stdlib${ii}$_${ri}$rot( k2-istartm+1, b( istartm, k2+1 ), 1_${ik}$,b( istartm, k2 ), 1_${ik}$, & c1, s1 ) - call stdlib_${ri}$rot( jw, zc( 1, k2+1-kwtop+1 ), 1, zc( 1,k2-kwtop+1 ), 1, c1, & + call stdlib${ii}$_${ri}$rot( jw, zc( 1_${ik}$, k2+1-kwtop+1 ), 1_${ik}$, zc( 1_${ik}$,k2-kwtop+1 ), 1_${ik}$, c1, & s1 ) - call stdlib_${ri}$lartg( a( k2+1, k2 ), a( k2+2, k2 ), c1, s1,temp ) + call stdlib${ii}$_${ri}$lartg( a( k2+1, k2 ), a( k2+2, k2 ), c1, s1,temp ) a( k2+1, k2 ) = temp a( k2+2, k2 ) = zero - call stdlib_${ri}$rot( istopm-k2, a( k2+1, k2+1 ), lda, a( k2+2,k2+1 ), lda, c1,& + call stdlib${ii}$_${ri}$rot( istopm-k2, a( k2+1, k2+1 ), lda, a( k2+2,k2+1 ), lda, c1,& s1 ) - call stdlib_${ri}$rot( istopm-k2, b( k2+1, k2+1 ), ldb, b( k2+2,k2+1 ), ldb, c1,& + call stdlib${ii}$_${ri}$rot( istopm-k2, b( k2+1, k2+1 ), ldb, b( k2+2,k2+1 ), ldb, c1,& s1 ) - call stdlib_${ri}$rot( jw, qc( 1, k2+1-kwtop+1 ), 1, qc( 1,k2+2-kwtop+1 ), 1, & + call stdlib${ii}$_${ri}$rot( jw, qc( 1_${ik}$, k2+1-kwtop+1 ), 1_${ik}$, qc( 1_${ik}$,k2+2-kwtop+1 ), 1_${ik}$, & c1, s1 ) end do ! remove the shift - call stdlib_${ri}$lartg( b( kwbot, kwbot ), b( kwbot, kwbot-1 ), c1,s1, temp ) + call stdlib${ii}$_${ri}$lartg( b( kwbot, kwbot ), b( kwbot, kwbot-1 ), c1,s1, temp ) b( kwbot, kwbot ) = temp b( kwbot, kwbot-1 ) = zero - call stdlib_${ri}$rot( kwbot-istartm, b( istartm, kwbot ), 1,b( istartm, kwbot-1 ),& - 1, c1, s1 ) - call stdlib_${ri}$rot( kwbot-istartm+1, a( istartm, kwbot ), 1,a( istartm, kwbot-1 & - ), 1, c1, s1 ) - call stdlib_${ri}$rot( jw, zc( 1, kwbot-kwtop+1 ), 1, zc( 1,kwbot-1-kwtop+1 ), 1, & + call stdlib${ii}$_${ri}$rot( kwbot-istartm, b( istartm, kwbot ), 1_${ik}$,b( istartm, kwbot-1 ),& + 1_${ik}$, c1, s1 ) + call stdlib${ii}$_${ri}$rot( kwbot-istartm+1, a( istartm, kwbot ), 1_${ik}$,a( istartm, kwbot-1 & + ), 1_${ik}$, c1, s1 ) + call stdlib${ii}$_${ri}$rot( jw, zc( 1_${ik}$, kwbot-kwtop+1 ), 1_${ik}$, zc( 1_${ik}$,kwbot-1-kwtop+1 ), 1_${ik}$, & c1, s1 ) k = k-1 end if @@ -37557,82 +37549,82 @@ module stdlib_linalg_lapack_${ri}$ end if ! apply qc and zc to rest of the matrix if ( ilschur ) then - istartm = 1 + istartm = 1_${ik}$ istopm = n else istartm = ilo istopm = ihi end if - if ( istopm-ihi > 0 ) then - call stdlib_${ri}$gemm( 'T', 'N', jw, istopm-ihi, jw, one, qc, ldqc,a( kwtop, ihi+1 ), & + if ( istopm-ihi > 0_${ik}$ ) then + call stdlib${ii}$_${ri}$gemm( 'T', 'N', jw, istopm-ihi, jw, one, qc, ldqc,a( kwtop, ihi+1 ), & lda, zero, work, jw ) - call stdlib_${ri}$lacpy( 'ALL', jw, istopm-ihi, work, jw, a( kwtop,ihi+1 ), lda ) - call stdlib_${ri}$gemm( 'T', 'N', jw, istopm-ihi, jw, one, qc, ldqc,b( kwtop, ihi+1 ), & + call stdlib${ii}$_${ri}$lacpy( 'ALL', jw, istopm-ihi, work, jw, a( kwtop,ihi+1 ), lda ) + call stdlib${ii}$_${ri}$gemm( 'T', 'N', jw, istopm-ihi, jw, one, qc, ldqc,b( kwtop, ihi+1 ), & ldb, zero, work, jw ) - call stdlib_${ri}$lacpy( 'ALL', jw, istopm-ihi, work, jw, b( kwtop,ihi+1 ), ldb ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', jw, istopm-ihi, work, jw, b( kwtop,ihi+1 ), ldb ) end if if ( ilq ) then - call stdlib_${ri}$gemm( 'N', 'N', n, jw, jw, one, q( 1, kwtop ), ldq, qc,ldqc, zero, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', n, jw, jw, one, q( 1_${ik}$, kwtop ), ldq, qc,ldqc, zero, & work, n ) - call stdlib_${ri}$lacpy( 'ALL', n, jw, work, n, q( 1, kwtop ), ldq ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', n, jw, work, n, q( 1_${ik}$, kwtop ), ldq ) end if - if ( kwtop-1-istartm+1 > 0 ) then - call stdlib_${ri}$gemm( 'N', 'N', kwtop-istartm, jw, jw, one, a( istartm,kwtop ), lda, & + if ( kwtop-1-istartm+1 > 0_${ik}$ ) then + call stdlib${ii}$_${ri}$gemm( 'N', 'N', kwtop-istartm, jw, jw, one, a( istartm,kwtop ), lda, & zc, ldzc, zero, work,kwtop-istartm ) - call stdlib_${ri}$lacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,a( istartm, kwtop & + call stdlib${ii}$_${ri}$lacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,a( istartm, kwtop & ), lda ) - call stdlib_${ri}$gemm( 'N', 'N', kwtop-istartm, jw, jw, one, b( istartm,kwtop ), ldb, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', kwtop-istartm, jw, jw, one, b( istartm,kwtop ), ldb, & zc, ldzc, zero, work,kwtop-istartm ) - call stdlib_${ri}$lacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,b( istartm, kwtop & + call stdlib${ii}$_${ri}$lacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,b( istartm, kwtop & ), ldb ) end if if ( ilz ) then - call stdlib_${ri}$gemm( 'N', 'N', n, jw, jw, one, z( 1, kwtop ), ldz, zc,ldzc, zero, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', n, jw, jw, one, z( 1_${ik}$, kwtop ), ldz, zc,ldzc, zero, & work, n ) - call stdlib_${ri}$lacpy( 'ALL', n, jw, work, n, z( 1, kwtop ), ldz ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', n, jw, work, n, z( 1_${ik}$, kwtop ), ldz ) end if - end subroutine stdlib_${ri}$laqz3 + end subroutine stdlib${ii}$_${ri}$laqz3 - pure subroutine stdlib_${ri}$laqz4( ilschur, ilq, ilz, n, ilo, ihi, nshifts,nblock_qesired, sr, & + pure subroutine stdlib${ii}$_${ri}$laqz4( ilschur, ilq, ilz, n, ilo, ihi, nshifts,nblock_qesired, sr, & !! DLAQZ4: Executes a single multishift QZ sweep si, ss, a, lda, b, ldb, q,ldq, z, ldz, qc, ldqc, zc, ldzc, work, lwork,info ) ! function arguments logical(lk), intent( in ) :: ilschur, ilq, ilz - integer(ilp), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,nshifts, & + integer(${ik}$), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,nshifts, & nblock_qesired, ldqc, ldzc real(${rk}$), intent( inout ) :: a( lda, * ), b( ldb, * ),q( ldq, * ), z( ldz, * ), qc( & ldqc, * ),zc( ldzc, * ), work( * ), sr( * ), si( * ),ss( * ) - integer(ilp), intent( out ) :: info + 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(${rk}$) :: temp, v(3), c1, s1, c2, s2, swap - info = 0 + real(${rk}$) :: temp, v(3_${ik}$), c1, s1, c2, s2, swap + info = 0_${ik}$ if ( nblock_qesired < 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_qesired + work( 1_${ik}$ ) = n*nblock_qesired return else if ( lwork < n*nblock_qesired ) then - info = -25 + info = -25_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'DLAQZ4', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DLAQZ4', -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 @@ -37662,71 +37654,71 @@ module stdlib_linalg_lapack_${ri}$ ! 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_qesired-ns, 1 ) + ns = nshifts-mod( nshifts, 2_${ik}$ ) + npos = max( nblock_qesired-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_${ri}$laset( 'FULL', ns+1, ns+1, zero, one, qc, ldqc ) - call stdlib_${ri}$laset( 'FULL', ns, ns, zero, one, zc, ldzc ) + call stdlib${ii}$_${ri}$laset( 'FULL', ns+1, ns+1, zero, one, qc, ldqc ) + call stdlib${ii}$_${ri}$laset( 'FULL', ns, ns, zero, one, zc, ldzc ) do i = 1, ns, 2 ! introduce the shift - call stdlib_${ri}$laqz1( a( ilo, ilo ), lda, b( ilo, ilo ), ldb, sr( i ),sr( i+1 ), si( & + call stdlib${ii}$_${ri}$laqz1( a( ilo, ilo ), lda, b( ilo, ilo ), ldb, sr( i ),sr( i+1 ), si( & i ), ss( i ), ss( i+1 ), v ) - temp = v( 2 ) - call stdlib_${ri}$lartg( temp, v( 3 ), c1, s1, v( 2 ) ) - call stdlib_${ri}$lartg( v( 1 ), v( 2 ), c2, s2, temp ) - call stdlib_${ri}$rot( ns, a( ilo+1, ilo ), lda, a( ilo+2, ilo ), lda, c1,s1 ) - call stdlib_${ri}$rot( ns, a( ilo, ilo ), lda, a( ilo+1, ilo ), lda, c2,s2 ) - call stdlib_${ri}$rot( ns, b( ilo+1, ilo ), ldb, b( ilo+2, ilo ), ldb, c1,s1 ) - call stdlib_${ri}$rot( ns, b( ilo, ilo ), ldb, b( ilo+1, ilo ), ldb, c2,s2 ) - call stdlib_${ri}$rot( ns+1, qc( 1, 2 ), 1, qc( 1, 3 ), 1, c1, s1 ) - call stdlib_${ri}$rot( ns+1, qc( 1, 1 ), 1, qc( 1, 2 ), 1, c2, s2 ) + temp = v( 2_${ik}$ ) + call stdlib${ii}$_${ri}$lartg( temp, v( 3_${ik}$ ), c1, s1, v( 2_${ik}$ ) ) + call stdlib${ii}$_${ri}$lartg( v( 1_${ik}$ ), v( 2_${ik}$ ), c2, s2, temp ) + call stdlib${ii}$_${ri}$rot( ns, a( ilo+1, ilo ), lda, a( ilo+2, ilo ), lda, c1,s1 ) + call stdlib${ii}$_${ri}$rot( ns, a( ilo, ilo ), lda, a( ilo+1, ilo ), lda, c2,s2 ) + call stdlib${ii}$_${ri}$rot( ns, b( ilo+1, ilo ), ldb, b( ilo+2, ilo ), ldb, c1,s1 ) + call stdlib${ii}$_${ri}$rot( ns, b( ilo, ilo ), ldb, b( ilo+1, ilo ), ldb, c2,s2 ) + call stdlib${ii}$_${ri}$rot( ns+1, qc( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, qc( 1_${ik}$, 3_${ik}$ ), 1_${ik}$, c1, s1 ) + call stdlib${ii}$_${ri}$rot( 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_${ri}$laqz2( .true., .true., j, 1, ns, ihi-ilo+1, a( ilo,ilo ), lda, b( & - ilo, ilo ), ldb, ns+1, 1, qc,ldqc, ns, 1, zc, ldzc ) + call stdlib${ii}$_${ri}$laqz2( .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)' sheight = ns+1 - swidth = istopm-( ilo+ns )+1 - if ( swidth > 0 ) then - call stdlib_${ri}$gemm( '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}$_${ri}$gemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,a( ilo, ilo+ns & ), lda, zero, work, sheight ) - call stdlib_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight, a( ilo,ilo+ns ), lda ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight, a( ilo,ilo+ns ), lda ) - call stdlib_${ri}$gemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,b( ilo, ilo+ns & + call stdlib${ii}$_${ri}$gemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,b( ilo, ilo+ns & ), ldb, zero, work, sheight ) - call stdlib_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight, b( ilo,ilo+ns ), ldb ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight, b( ilo,ilo+ns ), ldb ) end if if ( ilq ) then - call stdlib_${ri}$gemm( 'N', 'N', n, sheight, sheight, one, q( 1, ilo ),ldq, qc, ldqc, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', n, sheight, sheight, one, q( 1_${ik}$, ilo ),ldq, qc, ldqc, & zero, work, n ) - call stdlib_${ri}$lacpy( 'ALL', n, sheight, work, n, q( 1, ilo ), ldq ) + call stdlib${ii}$_${ri}$lacpy( '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) sheight = ilo-1-istartm+1 swidth = ns - if ( sheight > 0 ) then - call stdlib_${ri}$gemm( 'N', 'N', sheight, swidth, swidth, one, a( istartm,ilo ), lda, & + if ( sheight > 0_${ik}$ ) then + call stdlib${ii}$_${ri}$gemm( 'N', 'N', sheight, swidth, swidth, one, a( istartm,ilo ), lda, & zc, ldzc, zero, work, sheight ) - call stdlib_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ilo ), lda ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ilo ), lda ) - call stdlib_${ri}$gemm( 'N', 'N', sheight, swidth, swidth, one, b( istartm,ilo ), ldb, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', sheight, swidth, swidth, one, b( istartm,ilo ), ldb, & zc, ldzc, zero, work, sheight ) - call stdlib_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ilo ), ldb ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ilo ), ldb ) end if if ( ilz ) then - call stdlib_${ri}$gemm( 'N', 'N', n, swidth, swidth, one, z( 1, ilo ), ldz,zc, ldzc, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', n, swidth, swidth, one, z( 1_${ik}$, ilo ), ldz,zc, ldzc, & zero, work, n ) - call stdlib_${ri}$lacpy( 'ALL', n, swidth, work, n, z( 1, ilo ), ldz ) + call stdlib${ii}$_${ri}$lacpy( '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 @@ -37740,15 +37732,15 @@ module stdlib_linalg_lapack_${ri}$ istartb = k+1 ! istopb points to the last column we will be updating istopb = k+nblock-1 - call stdlib_${ri}$laset( 'FULL', ns+np, ns+np, zero, one, qc, ldqc ) - call stdlib_${ri}$laset( 'FULL', ns+np, ns+np, zero, one, zc, ldzc ) + call stdlib${ii}$_${ri}$laset( 'FULL', ns+np, ns+np, zero, one, qc, ldqc ) + call stdlib${ii}$_${ri}$laset( 'FULL', ns+np, ns+np, zero, one, zc, ldzc ) ! near the diagonal shift chase do i = ns-1, 0, -2 do j = 0, np-1 ! move down the block with index k+i+j-1, updating ! the (ns+np x ns+np) block: ! (k:k+ns+np,k:k+ns+np-1) - call stdlib_${ri}$laqz2( .true., .true., k+i+j-1, istartb, istopb,ihi, a, lda, b, & + call stdlib${ii}$_${ri}$laqz2( .true., .true., k+i+j-1, istartb, istopb,ihi, a, lda, b, & ldb, nblock, k+1, qc, ldqc,nblock, k, zc, ldzc ) end do end do @@ -37757,47 +37749,47 @@ module stdlib_linalg_lapack_${ri}$ ! b(k+1:k+ns+np, k+ns+np:istopm) ! from the left with qc(1:ns+np,1:ns+np)' sheight = ns+np - swidth = istopm-( k+ns+np )+1 - if ( swidth > 0 ) then - call stdlib_${ri}$gemm( '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}$_${ri}$gemm( 'T', 'N', sheight, swidth, sheight, one, qc,ldqc, a( k+1, k+& ns+np ), lda, zero, work,sheight ) - call stdlib_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight, a( k+1,k+ns+np ), lda & + call stdlib${ii}$_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight, a( k+1,k+ns+np ), lda & ) - call stdlib_${ri}$gemm( 'T', 'N', sheight, swidth, sheight, one, qc,ldqc, b( k+1, k+& + call stdlib${ii}$_${ri}$gemm( 'T', 'N', sheight, swidth, sheight, one, qc,ldqc, b( k+1, k+& ns+np ), ldb, zero, work,sheight ) - call stdlib_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight, b( k+1,k+ns+np ), ldb & + call stdlib${ii}$_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight, b( k+1,k+ns+np ), ldb & ) end if if ( ilq ) then - call stdlib_${ri}$gemm( 'N', 'N', n, nblock, nblock, one, q( 1, k+1 ),ldq, qc, ldqc, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', n, nblock, nblock, one, q( 1_${ik}$, k+1 ),ldq, qc, ldqc, & zero, work, n ) - call stdlib_${ri}$lacpy( 'ALL', n, nblock, work, n, q( 1, k+1 ), ldq ) + call stdlib${ii}$_${ri}$lacpy( '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) sheight = k-istartm+1 swidth = nblock - if ( sheight > 0 ) then - call stdlib_${ri}$gemm( 'N', 'N', sheight, swidth, swidth, one,a( istartm, k ), lda, & + if ( sheight > 0_${ik}$ ) then + call stdlib${ii}$_${ri}$gemm( 'N', 'N', sheight, swidth, swidth, one,a( istartm, k ), lda, & zc, ldzc, zero, work,sheight ) - call stdlib_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight,a( istartm, k ), lda ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight,a( istartm, k ), lda ) - call stdlib_${ri}$gemm( 'N', 'N', sheight, swidth, swidth, one,b( istartm, k ), ldb, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', sheight, swidth, swidth, one,b( istartm, k ), ldb, & zc, ldzc, zero, work,sheight ) - call stdlib_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight,b( istartm, k ), ldb ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight,b( istartm, k ), ldb ) end if if ( ilz ) then - call stdlib_${ri}$gemm( 'N', 'N', n, nblock, nblock, one, z( 1, k ),ldz, zc, ldzc, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', n, nblock, nblock, one, z( 1_${ik}$, k ),ldz, zc, ldzc, & zero, work, n ) - call stdlib_${ri}$lacpy( 'ALL', n, nblock, work, n, z( 1, k ), ldz ) + call stdlib${ii}$_${ri}$lacpy( '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_${ri}$laset( 'FULL', ns, ns, zero, one, qc, ldqc ) - call stdlib_${ri}$laset( 'FULL', ns+1, ns+1, zero, one, zc, ldzc ) + call stdlib${ii}$_${ri}$laset( 'FULL', ns, ns, zero, one, qc, ldqc ) + call stdlib${ii}$_${ri}$laset( 'FULL', ns+1, ns+1, zero, one, zc, ldzc ) ! istartb points to the first row we will be updating istartb = ihi-ns+1 ! istopb points to the last column we will be updating @@ -37805,7 +37797,7 @@ module stdlib_linalg_lapack_${ri}$ do i = 1, ns, 2 ! chase the shift down to the bottom right corner do ishift = ihi-i-1, ihi-2 - call stdlib_${ri}$laqz2( .true., .true., ishift, istartb, istopb, ihi,a, lda, b, ldb, & + call stdlib${ii}$_${ri}$laqz2( .true., .true., ishift, istartb, istopb, ihi,a, lda, b, ldb, & ns, ihi-ns+1, qc, ldqc, ns+1,ihi-ns, zc, ldzc ) end do end do @@ -37813,45 +37805,45 @@ module stdlib_linalg_lapack_${ri}$ ! update a(ihi-ns+1:ihi, ihi+1:istopm) ! from the left with qc(1:ns,1:ns)' sheight = ns - swidth = istopm-( ihi+1 )+1 - if ( swidth > 0 ) then - call stdlib_${ri}$gemm( '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}$_${ri}$gemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,a( ihi-ns+1, & ihi+1 ), lda, zero, work, sheight ) - call stdlib_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight,a( ihi-ns+1, ihi+1 ), lda & + call stdlib${ii}$_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight,a( ihi-ns+1, ihi+1 ), lda & ) - call stdlib_${ri}$gemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,b( ihi-ns+1, & + call stdlib${ii}$_${ri}$gemm( 'T', 'N', sheight, swidth, sheight, one, qc, ldqc,b( ihi-ns+1, & ihi+1 ), ldb, zero, work, sheight ) - call stdlib_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight,b( ihi-ns+1, ihi+1 ), ldb & + call stdlib${ii}$_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight,b( ihi-ns+1, ihi+1 ), ldb & ) end if if ( ilq ) then - call stdlib_${ri}$gemm( 'N', 'N', n, ns, ns, one, q( 1, ihi-ns+1 ), ldq,qc, ldqc, zero, & + call stdlib${ii}$_${ri}$gemm( 'N', 'N', n, ns, ns, one, q( 1_${ik}$, ihi-ns+1 ), ldq,qc, ldqc, zero, & work, n ) - call stdlib_${ri}$lacpy( 'ALL', n, ns, work, n, q( 1, ihi-ns+1 ), ldq ) + call stdlib${ii}$_${ri}$lacpy( '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) sheight = ihi-ns-istartm+1 swidth = ns+1 - if ( sheight > 0 ) then - call stdlib_${ri}$gemm( 'N', 'N', sheight, swidth, swidth, one, a( istartm,ihi-ns ), lda,& + if ( sheight > 0_${ik}$ ) then + call stdlib${ii}$_${ri}$gemm( 'N', 'N', sheight, swidth, swidth, one, a( istartm,ihi-ns ), lda,& zc, ldzc, zero, work, sheight ) - call stdlib_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ihi-ns ), lda & + call stdlib${ii}$_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ihi-ns ), lda & ) - call stdlib_${ri}$gemm( 'N', 'N', sheight, swidth, swidth, one, b( istartm,ihi-ns ), ldb,& + call stdlib${ii}$_${ri}$gemm( 'N', 'N', sheight, swidth, swidth, one, b( istartm,ihi-ns ), ldb,& zc, ldzc, zero, work, sheight ) - call stdlib_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ihi-ns ), ldb & + call stdlib${ii}$_${ri}$lacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ihi-ns ), ldb & ) end if if ( ilz ) then - call stdlib_${ri}$gemm( 'N', 'N', n, ns+1, ns+1, one, z( 1, ihi-ns ), ldz,zc, ldzc, zero,& + call stdlib${ii}$_${ri}$gemm( 'N', 'N', n, ns+1, ns+1, one, z( 1_${ik}$, ihi-ns ), ldz,zc, ldzc, zero,& work, n ) - call stdlib_${ri}$lacpy( 'ALL', n, ns+1, work, n, z( 1, ihi-ns ), ldz ) + call stdlib${ii}$_${ri}$lacpy( 'ALL', n, ns+1, work, n, z( 1_${ik}$, ihi-ns ), ldz ) end if - end subroutine stdlib_${ri}$laqz4 + end subroutine stdlib${ii}$_${ri}$laqz4 - pure subroutine stdlib_${ri}$lar1v( n, b1, bn, lambda, d, l, ld, lld,pivmin, gaptol, z, wantnc, & + pure subroutine stdlib${ii}$_${ri}$lar1v( n, b1, bn, lambda, d, l, ld, lld,pivmin, gaptol, z, wantnc, & !! DLAR1V: computes the (scaled) r-th column of the inverse of !! the sumbmatrix in rows B1 through BN of the tridiagonal matrix !! L D L**T - sigma I. When sigma is close to an eigenvalue, the @@ -37873,13 +37865,13 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: gaptol, lambda, pivmin real(${rk}$), intent(out) :: mingma, nrminv, resid, rqcorr, ztz ! Array Arguments - integer(ilp), intent(out) :: isuppz(*) + integer(${ik}$), intent(out) :: isuppz(*) real(${rk}$), intent(in) :: d(*), l(*), ld(*), lld(*) real(${rk}$), intent(out) :: work(*) real(${rk}$), intent(inout) :: z(*) @@ -37887,13 +37879,13 @@ module stdlib_linalg_lapack_${ri}$ ! 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(${rk}$) :: dminus, dplus, eps, s, tmp ! Intrinsic Functions intrinsic :: abs ! Executable Statements - eps = stdlib_${ri}$lamch( 'PRECISION' ) - if( r==0 ) then + eps = stdlib${ii}$_${ri}$lamch( 'PRECISION' ) + if( r==0_${ik}$ ) then r1 = b1 r2 = bn else @@ -37901,12 +37893,12 @@ module stdlib_linalg_lapack_${ri}$ 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 ) @@ -37914,16 +37906,16 @@ module stdlib_linalg_lapack_${ri}$ ! 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(dplus0 ) 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_ila${ri}$lc(lastv, n, c, ldc) + lastc = stdlib${ii}$_ila${ri}$lc(lastv, n, c, ldc) else ! scan for the last non-zero row in c(:,1:lastv). - lastc = stdlib_ila${ri}$lr(m, lastv, c, ldc) + lastc = stdlib${ii}$_ila${ri}$lr(m, lastv, c, ldc) end if end if ! note that lastc.eq.0_${rk}$ renders the blas operations null; no special ! case is needed at this level. if( applyleft ) then ! form h * c - if( lastv>0 ) then + if( lastv>0_${ik}$ ) then ! w(1:lastc,1) := c(1:lastv,1:lastc)**t * v(1:lastv,1) - call stdlib_${ri}$gemv( 'TRANSPOSE', lastv, lastc, one, c, ldc, v, incv,zero, work, 1 & + call stdlib${ii}$_${ri}$gemv( '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_${ri}$ger( lastv, lastc, -tau, v, incv, work, 1, c, ldc ) + call stdlib${ii}$_${ri}$ger( lastv, lastc, -tau, v, incv, work, 1_${ik}$, c, ldc ) end if else ! form c * h - if( lastv>0 ) then + if( lastv>0_${ik}$ ) then ! w(1:lastc,1) := c(1:lastc,1:lastv) * v(1:lastv,1) - call stdlib_${ri}$gemv( 'NO TRANSPOSE', lastc, lastv, one, c, ldc,v, incv, zero, work,& - 1 ) + call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', lastc, lastv, one, c, ldc,v, incv, zero, work,& + 1_${ik}$ ) ! c(1:lastc,1:lastv) := c(...) - w(1:lastc,1) * v(1:lastv,1)**t - call stdlib_${ri}$ger( lastc, lastv, -tau, work, 1, v, incv, c, ldc ) + call stdlib${ii}$_${ri}$ger( lastc, lastv, -tau, work, 1_${ik}$, v, incv, c, ldc ) end if end if return - end subroutine stdlib_${ri}$larf + end subroutine stdlib${ii}$_${ri}$larf - pure subroutine stdlib_${ri}$larfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, ldc, & + pure subroutine stdlib${ii}$_${ri}$larfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, ldc, & !! DLARFB: applies a real block reflector H or its transpose H**T to a !! real m by n matrix C, from either the left or the right. work, ldwork ) @@ -38202,7 +38194,7 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(inout) :: c(ldc,*) real(${rk}$), intent(in) :: t(ldt,*), v(ldv,*) @@ -38211,7 +38203,7 @@ module stdlib_linalg_lapack_${ri}$ ! 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 @@ -38231,27 +38223,27 @@ module stdlib_linalg_lapack_${ri}$ ! w := c**t * v = (c1**t * v1 + c2**t * v2) (stored in work) ! w := c1**t do j = 1, k - call stdlib_${ri}$copy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib${ii}$_${ri}$copy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v1 - call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, one, v, ldv,& + call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, one, v, ldv,& work, ldwork ) if( m>k ) then ! w := w + c2**t * v2 - call stdlib_${ri}$gemm( 'TRANSPOSE', 'NO TRANSPOSE', n, k, m-k,one, c( k+1, 1 ),& - ldc, v( k+1, 1 ), ldv,one, work, ldwork ) + call stdlib${ii}$_${ri}$gemm( '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_${ri}$trmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,one, t, ldt, & + call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,one, t, ldt, & work, ldwork ) ! c := c - v * w**t if( m>k ) then ! c2 := c2 - v2 * w**t - call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m-k, n, k,-one, v( k+1, 1 )& - , ldv, work, ldwork, one,c( k+1, 1 ), ldc ) + call stdlib${ii}$_${ri}$gemm( '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_${ri}$trmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', n, k,one, v, ldv, & + call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', n, k,one, v, ldv, & work, ldwork ) ! c1 := c1 - w**t do j = 1, k @@ -38264,27 +38256,27 @@ module stdlib_linalg_lapack_${ri}$ ! w := c * v = (c1*v1 + c2*v2) (stored in work) ! w := c1 do j = 1, k - call stdlib_${ri}$copy( m, c( 1, j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_${ri}$copy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v1 - call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, one, v, ldv,& + call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, one, v, ldv,& work, ldwork ) if( n>k ) then ! w := w + c2 * v2 - call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,one, c( 1, k+& - 1 ), ldc, v( k+1, 1 ), ldv,one, work, ldwork ) + call stdlib${ii}$_${ri}$gemm( '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_${ri}$trmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,one, t, ldt, & + call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,one, t, ldt, & work, ldwork ) ! c := c - w * v**t if( n>k ) then ! c2 := c2 - w * v2**t - call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m, n-k, k,-one, work, & - ldwork, v( k+1, 1 ), ldv, one,c( 1, k+1 ), ldc ) + call stdlib${ii}$_${ri}$gemm( '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_${ri}$trmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', m, k,one, v, ldv, & + call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', m, k,one, v, ldv, & work, ldwork ) ! c1 := c1 - w do j = 1, k @@ -38303,28 +38295,28 @@ module stdlib_linalg_lapack_${ri}$ ! w := c**t * v = (c1**t * v1 + c2**t * v2) (stored in work) ! w := c2**t do j = 1, k - call stdlib_${ri}$copy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib${ii}$_${ri}$copy( n, c( m-k+j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v2 - call stdlib_${ri}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, one, v( m-k+& - 1, 1 ), ldv, work, ldwork ) + call stdlib${ii}$_${ri}$trmm( '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_${ri}$gemm( 'TRANSPOSE', 'NO TRANSPOSE', n, k, m-k,one, c, ldc, v, & + call stdlib${ii}$_${ri}$gemm( 'TRANSPOSE', 'NO TRANSPOSE', n, k, m-k,one, c, ldc, v, & ldv, one, work, ldwork ) end if ! w := w * t**t or w * t - call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,one, t, ldt, & + call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,one, t, ldt, & work, ldwork ) ! c := c - v * w**t if( m>k ) then ! c1 := c1 - v1 * w**t - call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m-k, n, k,-one, v, ldv, & + call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m-k, n, k,-one, v, ldv, & work, ldwork, one, c, ldc ) end if ! w := w * v2**t - call stdlib_${ri}$trmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', n, k,one, v( m-k+1, & - 1 ), ldv, work, ldwork ) + call stdlib${ii}$_${ri}$trmm( '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 @@ -38336,28 +38328,28 @@ module stdlib_linalg_lapack_${ri}$ ! w := c * v = (c1*v1 + c2*v2) (stored in work) ! w := c2 do j = 1, k - call stdlib_${ri}$copy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_${ri}$copy( m, c( 1_${ik}$, n-k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v2 - call stdlib_${ri}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, one, v( n-k+& - 1, 1 ), ldv, work, ldwork ) + call stdlib${ii}$_${ri}$trmm( '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_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,one, c, ldc, & + call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,one, c, ldc, & v, ldv, one, work, ldwork ) end if ! w := w * t or w * t**t - call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,one, t, ldt, & + call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,one, t, ldt, & work, ldwork ) ! c := c - w * v**t if( n>k ) then ! c1 := c1 - w * v1**t - call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m, n-k, k,-one, work, & + call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m, n-k, k,-one, work, & ldwork, v, ldv, one, c, ldc ) end if ! w := w * v2**t - call stdlib_${ri}$trmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', m, k,one, v( n-k+1, & - 1 ), ldv, work, ldwork ) + call stdlib${ii}$_${ri}$trmm( '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 @@ -38376,27 +38368,27 @@ module stdlib_linalg_lapack_${ri}$ ! 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_${ri}$copy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib${ii}$_${ri}$copy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v1**t - call stdlib_${ri}$trmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', n, k,one, v, ldv, & + call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', n, k,one, v, ldv, & work, ldwork ) if( m>k ) then ! w := w + c2**t * v2**t - call stdlib_${ri}$gemm( 'TRANSPOSE', 'TRANSPOSE', n, k, m-k, one,c( k+1, 1 ), & - ldc, v( 1, k+1 ), ldv, one,work, ldwork ) + call stdlib${ii}$_${ri}$gemm( '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_${ri}$trmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,one, t, ldt, & + call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,one, t, ldt, & work, ldwork ) ! c := c - v**t * w**t if( m>k ) then ! c2 := c2 - v2**t * w**t - call stdlib_${ri}$gemm( 'TRANSPOSE', 'TRANSPOSE', m-k, n, k, -one,v( 1, k+1 ), & - ldv, work, ldwork, one,c( k+1, 1 ), ldc ) + call stdlib${ii}$_${ri}$gemm( '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_${ri}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, one, v, ldv,& + call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, one, v, ldv,& work, ldwork ) ! c1 := c1 - w**t do j = 1, k @@ -38409,27 +38401,27 @@ module stdlib_linalg_lapack_${ri}$ ! w := c * v**t = (c1*v1**t + c2*v2**t) (stored in work) ! w := c1 do j = 1, k - call stdlib_${ri}$copy( m, c( 1, j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_${ri}$copy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v1**t - call stdlib_${ri}$trmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', m, k,one, v, ldv, & + call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', m, k,one, v, ldv, & work, ldwork ) if( n>k ) then ! w := w + c2 * v2**t - call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, n-k,one, c( 1, k+1 ),& - ldc, v( 1, k+1 ), ldv,one, work, ldwork ) + call stdlib${ii}$_${ri}$gemm( '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_${ri}$trmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,one, t, ldt, & + call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,one, t, ldt, & work, ldwork ) ! c := c - w * v if( n>k ) then ! c2 := c2 - w * v2 - call stdlib_${ri}$gemm( '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}$_${ri}$gemm( '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_${ri}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, one, v, ldv,& + call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, one, v, ldv,& work, ldwork ) ! c1 := c1 - w do j = 1, k @@ -38447,27 +38439,27 @@ module stdlib_linalg_lapack_${ri}$ ! 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_${ri}$copy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib${ii}$_${ri}$copy( n, c( m-k+j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v2**t - call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', n, k,one, v( 1, m-k+& - 1 ), ldv, work, ldwork ) + call stdlib${ii}$_${ri}$trmm( '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_${ri}$gemm( 'TRANSPOSE', 'TRANSPOSE', n, k, m-k, one,c, ldc, v, ldv,& + call stdlib${ii}$_${ri}$gemm( 'TRANSPOSE', 'TRANSPOSE', n, k, m-k, one,c, ldc, v, ldv,& one, work, ldwork ) end if ! w := w * t**t or w * t - call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,one, t, ldt, & + call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,one, t, ldt, & work, ldwork ) ! c := c - v**t * w**t if( m>k ) then ! c1 := c1 - v1**t * w**t - call stdlib_${ri}$gemm( 'TRANSPOSE', 'TRANSPOSE', m-k, n, k, -one,v, ldv, work, & + call stdlib${ii}$_${ri}$gemm( 'TRANSPOSE', 'TRANSPOSE', m-k, n, k, -one,v, ldv, work, & ldwork, one, c, ldc ) end if ! w := w * v2 - call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, one, v( 1, & + call stdlib${ii}$_${ri}$trmm( '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 @@ -38480,27 +38472,27 @@ module stdlib_linalg_lapack_${ri}$ ! w := c * v**t = (c1*v1**t + c2*v2**t) (stored in work) ! w := c2 do j = 1, k - call stdlib_${ri}$copy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_${ri}$copy( m, c( 1_${ik}$, n-k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v2**t - call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', m, k,one, v( 1, n-k+& - 1 ), ldv, work, ldwork ) + call stdlib${ii}$_${ri}$trmm( '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_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, n-k,one, c, ldc, v, & + call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, n-k,one, c, ldc, v, & ldv, one, work, ldwork ) end if ! w := w * t or w * t**t - call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,one, t, ldt, & + call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,one, t, ldt, & work, ldwork ) ! c := c - w * v if( n>k ) then ! c1 := c1 - w * v1 - call stdlib_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-one, work, & + call stdlib${ii}$_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-one, work, & ldwork, v, ldv, one, c, ldc ) end if ! w := w * v2 - call stdlib_${ri}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, one, v( 1, & + call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, one, v( 1_${ik}$, & n-k+1 ), ldv, work, ldwork ) ! c1 := c1 - w do j = 1, k @@ -38512,10 +38504,10 @@ module stdlib_linalg_lapack_${ri}$ end if end if return - end subroutine stdlib_${ri}$larfb + end subroutine stdlib${ii}$_${ri}$larfb - pure subroutine stdlib_${ri}$larfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) + pure subroutine stdlib${ii}$_${ri}$larfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) !! DLARFB_GETT: applies a real Householder block reflector H from the !! left to a real (K+M)-by-N "triangular-pentagonal" matrix !! composed of two block matrices: an upper trapezoidal K-by-N matrix A @@ -38529,7 +38521,7 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) real(${rk}$), intent(in) :: t(ldt,*) @@ -38538,7 +38530,7 @@ module stdlib_linalg_lapack_${ri}$ ! 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 @@ -38552,34 +38544,34 @@ module stdlib_linalg_lapack_${ri}$ ! col2_(1) compute w2: = a2. therefore, copy a2 = a(1:k, k+1:n) ! into w2=work(1:k, 1:n-k) column-by-column. do j = 1, n-k - call stdlib_${ri}$copy( k, a( 1, k+j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_${ri}$copy( 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, ! v1 is not an identy matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored). - call stdlib_${ri}$trmm( 'L', 'L', 'T', 'U', k, n-k, one, a, lda,work, ldwork ) + call stdlib${ii}$_${ri}$trmm( 'L', 'L', 'T', 'U', k, n-k, one, a, lda,work, ldwork ) end if ! col2_(3) compute w2: = w2 + (v2**t) * b2 = w2 + (b1**t) * b2 ! v2 stored in b1. - if( m>0 ) then - call stdlib_${ri}$gemm( 'T', 'N', k, n-k, m, one, b, ldb,b( 1, k+1 ), ldb, one, work, & + if( m>0_${ik}$ ) then + call stdlib${ii}$_${ri}$gemm( '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, ! t is upper-triangular. - call stdlib_${ri}$trmm( 'L', 'U', 'N', 'N', k, n-k, one, t, ldt,work, ldwork ) + call stdlib${ii}$_${ri}$trmm( 'L', 'U', 'N', 'N', k, n-k, one, t, ldt,work, ldwork ) ! col2_(5) compute b2: = b2 - v2 * w2 = b2 - b1 * w2, ! v2 stored in b1. - if( m>0 ) then - call stdlib_${ri}$gemm( '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}$_${ri}$gemm( '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, ! v1 is not an identity matrix, but unit lower-triangular, ! v1 stored in a1 (diagonal ones are not stored). - call stdlib_${ri}$trmm( 'L', 'L', 'N', 'U', k, n-k, one, a, lda,work, ldwork ) + call stdlib${ii}$_${ri}$trmm( 'L', 'L', 'N', 'U', k, n-k, one, a, lda,work, ldwork ) end if ! col2_(7) compute a2: = a2 - w2 = ! = a(1:k, k+1:n-k) - work(1:k, 1:n-k), @@ -38599,7 +38591,7 @@ module stdlib_linalg_lapack_${ri}$ ! a1 = a(1:k, 1:k) into the upper-triangular ! w1 = work(1:k, 1:k) column-by-column. do j = 1, k - call stdlib_${ri}$copy( j, a( 1, j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_${ri}$copy( 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 @@ -38612,16 +38604,16 @@ module stdlib_linalg_lapack_${ri}$ ! 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_${ri}$trmm( 'L', 'L', 'T', 'U', k, k, one, a, lda,work, ldwork ) + call stdlib${ii}$_${ri}$trmm( 'L', 'L', 'T', 'U', k, k, one, a, lda,work, ldwork ) end if ! col1_(3) compute w1: = t * w1, ! t is upper-triangular, ! w1 is upper-triangular with zeroes below the diagonal. - call stdlib_${ri}$trmm( 'L', 'U', 'N', 'N', k, k, one, t, ldt,work, ldwork ) + call stdlib${ii}$_${ri}$trmm( 'L', 'U', 'N', 'N', k, k, one, t, ldt,work, ldwork ) ! col1_(4) compute b1: = - v2 * w1 = - b1 * w1, ! v2 = b1, w1 is upper-triangular with zeroes below the diagonal. - if( m>0 ) then - call stdlib_${ri}$trmm( 'R', 'U', 'N', 'N', m, k, -one, work, ldwork,b, ldb ) + if( m>0_${ik}$ ) then + call stdlib${ii}$_${ri}$trmm( 'R', 'U', 'N', 'N', m, k, -one, work, ldwork,b, ldb ) end if if( lnotident ) then ! col1_(5) compute w1: = v1 * w1 = a1 * w1, @@ -38629,7 +38621,7 @@ module stdlib_linalg_lapack_${ri}$ ! 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_${ri}$trmm( 'L', 'L', 'N', 'U', k, k, one, a, lda,work, ldwork ) + call stdlib${ii}$_${ri}$trmm( 'L', 'L', 'N', 'U', k, k, one, a, lda,work, ldwork ) ! col1_(6) compute a1: = a1 - w1 = a(1:k, 1:k) - work(1:k, 1:k) ! column-by-column. a1 is upper-triangular on input. ! if ident, a1 is square on output, and w1 is square, @@ -38649,10 +38641,10 @@ module stdlib_linalg_lapack_${ri}$ end do end do return - end subroutine stdlib_${ri}$larfb_gett + end subroutine stdlib${ii}$_${ri}$larfb_gett - pure subroutine stdlib_${ri}$larfg( n, alpha, x, incx, tau ) + pure subroutine stdlib${ii}$_${ri}$larfg( n, alpha, x, incx, tau ) !! DLARFG: generates a real elementary reflector H of order n, such !! that !! H * ( alpha ) = ( beta ), H**T * H = I. @@ -38670,7 +38662,7 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(inout) :: alpha real(${rk}$), intent(out) :: tau ! Array Arguments @@ -38678,39 +38670,39 @@ module stdlib_linalg_lapack_${ri}$ ! ===================================================================== ! Local Scalars - integer(ilp) :: j, knt + integer(${ik}$) :: j, knt real(${rk}$) :: beta, rsafmn, safmin, xnorm ! Intrinsic Functions intrinsic :: abs,sign ! Executable Statements - if( n<=1 ) then + if( n<=1_${ik}$ ) then tau = zero return end if - xnorm = stdlib_${ri}$nrm2( n-1, x, incx ) + xnorm = stdlib${ii}$_${ri}$nrm2( n-1, x, incx ) if( xnorm==zero ) then ! h = i tau = zero else ! general case - beta = -sign( stdlib_${ri}$lapy2( alpha, xnorm ), alpha ) - safmin = stdlib_${ri}$lamch( 'S' ) / stdlib_${ri}$lamch( 'E' ) - knt = 0 + beta = -sign( stdlib${ii}$_${ri}$lapy2( alpha, xnorm ), alpha ) + safmin = stdlib${ii}$_${ri}$lamch( 'S' ) / stdlib${ii}$_${ri}$lamch( 'E' ) + knt = 0_${ik}$ if( abs( beta )= 0 if( alpha>=zero ) then @@ -38768,27 +38760,27 @@ module stdlib_linalg_lapack_${ri}$ ! 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_${ri}$lapy2( alpha, xnorm ), alpha ) - smlnum = stdlib_${ri}$lamch( 'S' ) / stdlib_${ri}$lamch( 'E' ) - knt = 0 + beta = sign( stdlib${ii}$_${ri}$lapy2( alpha, xnorm ), alpha ) + smlnum = stdlib${ii}$_${ri}$lamch( 'S' ) / stdlib${ii}$_${ri}$lamch( 'E' ) + knt = 0_${ik}$ if( abs( beta )1 ) then + if( i>1_${ik}$ ) then prevlastv = max( prevlastv, lastv ) else prevlastv = lastv @@ -38904,7 +38896,7 @@ module stdlib_linalg_lapack_${ri}$ end if end do else - prevlastv = 1 + prevlastv = 1_${ik}$ do i = k, 1, -1 if( tau( i )==zero ) then ! h(i) = i @@ -38924,8 +38916,8 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$gemv( 'TRANSPOSE', n-k+i-j, k-i, -tau( i ),v( j, i+1 ), & - ldv, v( j, i ), 1, one,t( i+1, i ), 1 ) + call stdlib${ii}$_${ri}$gemv( '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 @@ -38936,13 +38928,13 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$gemv( 'NO TRANSPOSE', k-i, n-k+i-j,-tau( i ), v( i+1, j ), & - ldv, v( i, j ), ldv,one, t( i+1, i ), 1 ) + call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', k-i, n-k+i-j,-tau( i ), v( i+1, j ), & + ldv, v( i, j ), ldv,one, t( i+1, i ), 1_${ik}$ ) end if ! t(i+1:k,i) := t(i+1:k,i+1:k) * t(i+1:k,i) - call stdlib_${ri}$trmv( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', k-i,t( i+1, i+1 ), & - ldt, t( i+1, i ), 1 ) - if( i>1 ) then + call stdlib${ii}$_${ri}$trmv( '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 @@ -38953,10 +38945,10 @@ module stdlib_linalg_lapack_${ri}$ end do end if return - end subroutine stdlib_${ri}$larft + end subroutine stdlib${ii}$_${ri}$larft - pure subroutine stdlib_${ri}$larfx( side, m, n, v, tau, c, ldc, work ) + pure subroutine stdlib${ii}$_${ri}$larfx( side, m, n, v, tau, c, ldc, work ) !! DLARFX: applies a real elementary reflector H to a real m by n !! matrix C, from either the left or the right. H is represented in the !! form @@ -38969,7 +38961,7 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: tau ! Array Arguments real(${rk}$), intent(inout) :: c(ldc,*) @@ -38978,7 +38970,7 @@ module stdlib_linalg_lapack_${ri}$ ! ===================================================================== ! Local Scalars - integer(ilp) :: j + integer(${ik}$) :: j real(${rk}$) :: sum, t1, t10, t2, t3, t4, t5, t6, t7, t8, t9, v1, v10, v2, v3, v4, v5, v6, & v7, v8, v9 ! Executable Statements @@ -38987,479 +38979,479 @@ module stdlib_linalg_lapack_${ri}$ ! 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_${ri}$larf( side, m, n, v, 1, tau, c, ldc, work ) + call stdlib${ii}$_${ri}$larf( 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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_${ri}$larf( side, m, n, v, 1, tau, c, ldc, work ) + call stdlib${ii}$_${ri}$larf( 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 continue return - end subroutine stdlib_${ri}$larfx + end subroutine stdlib${ii}$_${ri}$larfx - pure subroutine stdlib_${ri}$larfy( uplo, n, v, incv, tau, c, ldc, work ) + pure subroutine stdlib${ii}$_${ri}$larfy( uplo, n, v, incv, tau, c, ldc, work ) !! DLARFY: applies an elementary reflector, or Householder matrix, H, !! to an n x n symmetric matrix C, from both the left and the right. !! H is represented in the form @@ -39471,7 +39463,7 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: tau ! Array Arguments real(${rk}$), intent(inout) :: c(ldc,*) @@ -39484,16 +39476,16 @@ module stdlib_linalg_lapack_${ri}$ ! Executable Statements if( tau==zero )return ! form w:= c * v - call stdlib_${ri}$symv( uplo, n, one, c, ldc, v, incv, zero, work, 1 ) - alpha = -half*tau*stdlib_${ri}$dot( n, work, 1, v, incv ) - call stdlib_${ri}$axpy( n, alpha, v, incv, work, 1 ) + call stdlib${ii}$_${ri}$symv( uplo, n, one, c, ldc, v, incv, zero, work, 1_${ik}$ ) + alpha = -half*tau*stdlib${ii}$_${ri}$dot( n, work, 1_${ik}$, v, incv ) + call stdlib${ii}$_${ri}$axpy( n, alpha, v, incv, work, 1_${ik}$ ) ! c := c - v * w' - w * v' - call stdlib_${ri}$syr2( uplo, n, -tau, v, incv, work, 1, c, ldc ) + call stdlib${ii}$_${ri}$syr2( uplo, n, -tau, v, incv, work, 1_${ik}$, c, ldc ) return - end subroutine stdlib_${ri}$larfy + end subroutine stdlib${ii}$_${ri}$larfy - pure subroutine stdlib_${ri}$largv( n, x, incx, y, incy, c, incc ) + pure subroutine stdlib${ii}$_${ri}$largv( n, x, incx, y, incy, c, incc ) !! DLARGV: generates a vector of real plane rotations, determined by !! elements of the real vectors x and y. For i = 1,2,...,n !! ( c(i) s(i) ) ( x(i) ) = ( a(i) ) @@ -39502,21 +39494,21 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(out) :: c(*) real(${rk}$), intent(inout) :: x(*), y(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ic, ix, iy + integer(${ik}$) :: i, ic, ix, iy real(${rk}$) :: 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 ) @@ -39544,94 +39536,94 @@ module stdlib_linalg_lapack_${ri}$ ix = ix + incx end do loop_10 return - end subroutine stdlib_${ri}$largv + end subroutine stdlib${ii}$_${ri}$largv - pure subroutine stdlib_${ri}$larnv( idist, iseed, n, x ) + pure subroutine stdlib${ii}$_${ri}$larnv( idist, iseed, n, x ) !! DLARNV: 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(${rk}$), intent(out) :: x(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: lv = 128 + integer(${ik}$), parameter :: lv = 128_${ik}$ real(${rk}$), parameter :: twopi = 6.28318530717958647692528676655900576839e+0_${rk}$ ! Local Scalars - integer(ilp) :: i, il, il2, iv + integer(${ik}$) :: i, il, il2, iv ! Local Arrays real(${rk}$) :: 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_${ri}$laruv to generate il2 numbers from a uniform (0,1) + ! call stdlib${ii}$_${ri}$laruv to generate il2 numbers from a uniform (0,1) ! distribution (il2 <= lv) - call stdlib_${ri}$laruv( iseed, il2, u ) - if( idist==1 ) then + call stdlib${ii}$_${ri}$laruv( 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 + else if( idist==2_${ik}$ ) then ! convert generated numbers to uniform (-1,1) distribution do i = 1, il x( iv+i-1 ) = two*u( i ) - one end do - else if( idist==3 ) then + else if( idist==3_${ik}$ ) then ! convert generated numbers to normal (0,1) 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_${ri}$larnv + end subroutine stdlib${ii}$_${ri}$larnv - pure subroutine stdlib_${ri}$larra( n, d, e, e2, spltol, tnrm,nsplit, isplit, info ) + pure subroutine stdlib${ii}$_${ri}$larra( n, d, e, e2, spltol, tnrm,nsplit, isplit, info ) !! Compute the splitting points with threshold SPLTOL. !! DLARRA: sets any "small" off-diagonal elements to zero. ! -- lapack auxiliary routine -- ! -- 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(${rk}$), intent(in) :: spltol, tnrm ! Array Arguments - integer(ilp), intent(out) :: isplit(*) + integer(${ik}$), intent(out) :: isplit(*) real(${rk}$), intent(in) :: d(*) real(${rk}$), intent(inout) :: e(*), e2(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i real(${rk}$) :: 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(spltoln)) r = n + if((r<1_${ik}$).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 ) @@ -39709,12 +39701,12 @@ module stdlib_linalg_lapack_${ri}$ ! 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 ) @@ -39726,7 +39718,7 @@ module stdlib_linalg_lapack_${ri}$ ! do while( negcnt(left)>i-1 ) back = werr( ii ) 20 continue - negcnt = stdlib_${ri}$laneg( n, d, lld, left, pivmin, r ) + negcnt = stdlib${ii}$_${ri}$laneg( n, d, lld, left, pivmin, r ) if( negcnt>i-1 ) then left = left - back back = two*back @@ -39736,7 +39728,7 @@ module stdlib_linalg_lapack_${ri}$ ! compute negcount from dstqds facto l+d+l+^t = l d l^t - right back = werr( ii ) 50 continue - negcnt = stdlib_${ri}$laneg( n, d, lld, right, pivmin, r ) + negcnt = stdlib${ii}$_${ri}$laneg( 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 @@ -39766,17 +39758,17 @@ module stdlib_linalg_lapack_${ri}$ 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 ) @@ -39788,21 +39780,21 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$laneg( n, d, lld, mid, pivmin, r ) + negcnt = stdlib${ii}$_${ri}$laneg( n, d, lld, mid, pivmin, r ) if( negcnt<=i-1 ) then work( k-1 ) = mid else @@ -39810,31 +39802,31 @@ module stdlib_linalg_lapack_${ri}$ 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 + 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_${ri}$larrb + end subroutine stdlib${ii}$_${ri}$larrb - pure subroutine stdlib_${ri}$larrc( jobt, n, vl, vu, d, e, pivmin,eigcnt, lcnt, rcnt, info ) + pure subroutine stdlib${ii}$_${ri}$larrc( jobt, n, vl, vu, d, e, pivmin,eigcnt, lcnt, rcnt, info ) !! Find the number of eigenvalues of the symmetric tridiagonal matrix T !! that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T !! if JOBT = 'L'. @@ -39844,46 +39836,46 @@ module stdlib_linalg_lapack_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobt - integer(ilp), intent(out) :: eigcnt, info, lcnt, rcnt - integer(ilp), intent(in) :: n + integer(${ik}$), intent(out) :: eigcnt, info, lcnt, rcnt + integer(${ik}$), intent(in) :: n real(${rk}$), intent(in) :: pivmin, vl, vu ! Array Arguments real(${rk}$), intent(in) :: d(*), e(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i logical(lk) :: matt real(${rk}$) :: lpivot, rpivot, sl, su, tmp, tmp2 ! Executable Statements - info = 0 + info = 0_${ik}$ ! quick return if possible - if( n<=0 ) then + if( n<=0_${ik}$ ) then return end if - lcnt = 0 - rcnt = 0 - eigcnt = 0 + lcnt = 0_${ik}$ + rcnt = 0_${ik}$ + eigcnt = 0_${ik}$ matt = stdlib_lsame( jobt, 'T' ) if (matt) then ! sturm sequence count on t - lpivot = d( 1 ) - vl - rpivot = d( 1 ) - vu + lpivot = d( 1_${ik}$ ) - vl + rpivot = d( 1_${ik}$ ) - vu if( lpivot<=zero ) then - lcnt = lcnt + 1 + lcnt = lcnt + 1_${ik}$ endif if( rpivot<=zero ) then - rcnt = rcnt + 1 + rcnt = rcnt + 1_${ik}$ endif do i = 1, n-1 - tmp = e(i)**2 + tmp = e(i)**2_${ik}$ lpivot = ( d( i+1 )-vl ) - tmp/lpivot rpivot = ( d( i+1 )-vu ) - tmp/rpivot if( lpivot<=zero ) then - lcnt = lcnt + 1 + lcnt = lcnt + 1_${ik}$ endif if( rpivot<=zero ) then - rcnt = rcnt + 1 + rcnt = rcnt + 1_${ik}$ endif end do else @@ -39894,10 +39886,10 @@ module stdlib_linalg_lapack_${ri}$ lpivot = d( i ) + sl rpivot = d( i ) + su if( lpivot<=zero ) then - lcnt = lcnt + 1 + lcnt = lcnt + 1_${ik}$ endif if( rpivot<=zero ) then - rcnt = rcnt + 1 + rcnt = rcnt + 1_${ik}$ endif tmp = e(i) * d(i) * e(i) tmp2 = tmp / lpivot @@ -39916,18 +39908,18 @@ module stdlib_linalg_lapack_${ri}$ lpivot = d( n ) + sl rpivot = d( n ) + su if( lpivot<=zero ) then - lcnt = lcnt + 1 + lcnt = lcnt + 1_${ik}$ endif if( rpivot<=zero ) then - rcnt = rcnt + 1 + rcnt = rcnt + 1_${ik}$ endif endif eigcnt = rcnt - lcnt return - end subroutine stdlib_${ri}$larrc + end subroutine stdlib${ii}$_${ri}$larrc - pure subroutine stdlib_${ri}$larrd( range, order, n, vl, vu, il, iu, gers,reltol, d, e, e2, & + pure subroutine stdlib${ii}$_${ri}$larrd( range, order, n, vl, vu, il, iu, gers,reltol, d, e, e2, & !! DLARRD: computes the eigenvalues of a symmetric tridiagonal !! matrix T to suitable accuracy. This is an auxiliary code to be !! called from DSTEMR. @@ -39946,37 +39938,37 @@ module stdlib_linalg_lapack_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: order, range - integer(ilp), intent(in) :: il, iu, n, nsplit - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, iu, n, nsplit + integer(${ik}$), intent(out) :: info, m real(${rk}$), intent(in) :: pivmin, reltol, vl, vu real(${rk}$), intent(out) :: wl, wu ! Array Arguments - integer(ilp), intent(out) :: iblock(*), indexw(*), iwork(*) - integer(ilp), intent(in) :: isplit(*) + integer(${ik}$), intent(out) :: iblock(*), indexw(*), iwork(*) + integer(${ik}$), intent(in) :: isplit(*) real(${rk}$), intent(in) :: d(*), e(*), e2(*), gers(*) real(${rk}$), intent(out) :: w(*), werr(*), work(*) ! ===================================================================== ! Parameters real(${rk}$), parameter :: fudge = two - integer(ilp), parameter :: allrng = 1 - integer(ilp), parameter :: valrng = 2 - integer(ilp), parameter :: indrng = 3 + integer(${ik}$), parameter :: allrng = 1_${ik}$ + integer(${ik}$), parameter :: valrng = 2_${ik}$ + integer(${ik}$), parameter :: indrng = 3_${ik}$ ! Local Scalars logical(lk) :: ncnvrg, toofew - integer(ilp) :: i, ib, ibegin, idiscl, idiscu, ie, iend, iinfo, im, in, ioff, iout, & + integer(${ik}$) :: i, ib, ibegin, idiscl, idiscu, ie, iend, iinfo, im, in, ioff, iout, & irange, itmax, itmp1, itmp2, iw, iwoff, j, jblk, jdisc, je, jee, nb, nwl, nwu real(${rk}$) :: atoli, eps, gl, gu, rtoli, tmp1, tmp2, tnorm, uflow, wkill, wlu, & wul ! Local Arrays - integer(ilp) :: idumma(1) + integer(${ik}$) :: idumma(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,int,log,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 ! decode range @@ -39987,61 +39979,61 @@ module stdlib_linalg_lapack_${ri}$ else if( stdlib_lsame( range, 'I' ) ) then irange = indrng else - irange = 0 + irange = 0_${ik}$ end if ! check for errors - if( irange<=0 ) then - info = -1 + if( irange<=0_${ik}$ ) then + info = -1_${ik}$ else if( .not.(stdlib_lsame(order,'B').or.stdlib_lsame(order,'E')) ) then - info = -2 - else if( n<0 ) then - info = -3 + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ else if( irange==valrng ) then - if( vl>=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_${ri}$lamch( 'P' ) - uflow = stdlib_${ri}$lamch( 'U' ) + eps = stdlib${ii}$_${ri}$lamch( 'P' ) + uflow = stdlib${ii}$_${ri}$lamch( 'U' ) ! special case when n=1 ! 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 ! if only scalar is to be done. - nb = stdlib_ilaenv( 1, 'DSTEBZ', ' ', n, -1, -1, -1 ) - if( nb<=1 ) nb = 0 + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DSTEBZ', ' ', 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 ) ) @@ -40049,7 +40041,7 @@ module stdlib_linalg_lapack_${ri}$ gu = gu + fudge*tnorm*eps*n + fudge*two*pivmin ! [jan/28/2009] remove the line below since spdiam variable not use ! spdiam = gu - gl - ! input arguments for stdlib_${ri}$laebz: + ! input arguments for stdlib${ii}$_${ri}$laebz: ! the relative tolerance. an interval (a,b] lies within ! "relative tolerance" if b-a < reltol*max(|a|,|b|), rtoli = reltol @@ -40063,46 +40055,46 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$laebz. - itmax = int( ( log( tnorm+pivmin )-log( pivmin ) ) /log( two ),KIND=ilp) + 2 + ! gerschgorin bounds gl and gu is refined by stdlib${ii}$_${ri}$laebz. + 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_${ri}$laebz( 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}$_${ri}$laebz( 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 @@ -40115,29 +40107,29 @@ module stdlib_linalg_lapack_${ri}$ ! 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 + if( in==1_${ik}$ ) then ! 1x1 block - if( wl>=d( ibegin )-pivmin )nwl = nwl + 1 - if( wu>=d( ibegin )-pivmin )nwu = nwu + 1 + 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 @@ -40187,13 +40179,13 @@ module stdlib_linalg_lapack_${ri}$ else ! general case - block of size in >= 2 ! compute local gerschgorin interval and use it as the initial - ! interval for stdlib_${ri}$laebz + ! interval for stdlib${ii}$_${ri}$laebz 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 @@ -40203,7 +40195,7 @@ module stdlib_linalg_lapack_${ri}$ ! 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 ) @@ -40285,24 +40277,24 @@ module stdlib_linalg_lapack_${ri}$ 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 ) @@ -40310,44 +40302,44 @@ module stdlib_linalg_lapack_${ri}$ 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 + 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 ) @@ -40356,7 +40348,7 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -40366,9 +40358,9 @@ module stdlib_linalg_lapack_${ri}$ ! 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 )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 - wgap(1) = zero - iblock( 1 ) = 1 - indexw( 1 ) = 1 - gers(1) = d( 1 ) - gers(2) = d( 1 ) + werr(1_${ik}$) = zero + wgap(1_${ik}$) = zero + iblock( 1_${ik}$ ) = 1_${ik}$ + indexw( 1_${ik}$ ) = 1_${ik}$ + gers(1_${ik}$) = d( 1_${ik}$ ) + gers(2_${ik}$) = d( 1_${ik}$ ) endif ! store the shift for the initial rrr, which is zero in this case - e(1) = zero + e(1_${ik}$) = zero return end if ! general case: tridiagonal matrix of order > 1 ! init werr, wgap. compute gerschgorin intervals and spectral diameter. ! compute maximum off-diagonal entry and pivmin. - gl = d(1) - gu = d(1) + gl = d(1_${ik}$) + gu = d(1_${ik}$) eold = zero emax = zero e(n) = zero @@ -40506,19 +40498,19 @@ module stdlib_linalg_lapack_${ri}$ emax = eabs end if tmp1 = eabs + eold - gers( 2*i-1) = d(i) - tmp1 - gl = min( gl, gers( 2*i - 1)) - gers( 2*i ) = d(i) + tmp1 - gu = max( gu, gers(2*i) ) + gers( 2_${ik}$*i-1) = d(i) - tmp1 + gl = min( gl, gers( 2_${ik}$*i - 1_${ik}$)) + gers( 2_${ik}$*i ) = d(i) + tmp1 + gu = max( gu, gers(2_${ik}$*i) ) eold = eabs end do ! the minimum pivot allowed in the sturm sequence for t - pivmin = safmin * max( one, emax**2 ) + pivmin = safmin * max( one, emax**2_${ik}$ ) ! compute spectral diameter. the gerschgorin bounds give an ! estimate that is wrong by at most a factor of sqrt(2) spdiam = gu - gl ! compute splitting points - call stdlib_${ri}$larra( n, d, e, e2, spltol, spdiam,nsplit, isplit, iinfo ) + call stdlib${ii}$_${ri}$larra( n, d, e, e2, spltol, spdiam,nsplit, isplit, iinfo ) ! can force use of bisection instead of faster dqds. ! option left in the code for future multisection work. forceb = .false. @@ -40530,50 +40522,50 @@ module stdlib_linalg_lapack_${ri}$ vl = gl vu = gu else - ! we call stdlib_${ri}$larrd to find crude approximations to the eigenvalues + ! we call stdlib${ii}$_${ri}$larrd to find crude approximations to the eigenvalues ! in the desired range. in case irange = indrng, we also obtain the ! interval (vl,vu] that contains all the wanted eigenvalues. ! an interval [left,right] has converged if ! right-leftvl ).and.( d( & ibegin )<=vu ) ).or. ( (irange==indrng).and.(iblock(wbegin)==jblk))) 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 wgap(m) = zero iblock( m ) = jblk - indexw( m ) = 1 - wbegin = wbegin + 1 + indexw( m ) = 1_${ik}$ + wbegin = wbegin + 1_${ik}$ endif ! e( iend ) holds the shift for the initial rrr e( iend ) = zero - ibegin = iend + 1 + ibegin = iend + 1_${ik}$ cycle loop_170 end if ! blocks of size larger than 1x1 @@ -40583,13 +40575,13 @@ module stdlib_linalg_lapack_${ri}$ gl = d(ibegin) gu = d(ibegin) do i = ibegin , 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 if(.not. ((irange==allrng).and.(.not.forceb)) ) then ! count the number of eigenvalues in the current block. - mb = 0 + mb = 0_${ik}$ do i = wbegin,mm if( iblock(i)==jblk ) then mb = mb+1 @@ -40598,16 +40590,16 @@ module stdlib_linalg_lapack_${ri}$ endif end do 21 continue - if( mb==0) then + if( mb==0_${ik}$) then ! no eigenvalue in the current block lies in the desired range ! e( iend ) holds the shift for the initial rrr e( iend ) = zero - ibegin = iend + 1 + ibegin = iend + 1_${ik}$ cycle loop_170 else ! decide whether dqds or bisection is more efficient usedqd = ( (mb > fac*in) .and. (.not.forceb) ) - wend = wbegin + mb - 1 + wend = wbegin + mb - 1_${ik}$ ! calculate gaps for the current block ! in later stages, when representations for individual ! eigenvalues are different, we use sigma = e( iend ). @@ -40624,17 +40616,17 @@ module stdlib_linalg_lapack_${ri}$ if(( (irange==allrng) .and. (.not. forceb) ).or.usedqd) then ! case of dqds ! find approximations to the extremal eigenvalues of the block - call stdlib_${ri}$larrk( in, 1, gl, gu, d(ibegin),e2(ibegin), pivmin, rtl, tmp, tmp1, & + call stdlib${ii}$_${ri}$larrk( in, 1_${ik}$, gl, gu, d(ibegin),e2(ibegin), pivmin, rtl, tmp, tmp1, & iinfo ) - if( iinfo/=0 ) then - info = -1 + if( iinfo/=0_${ik}$ ) then + info = -1_${ik}$ return endif isleft = max(gl, tmp - tmp1- hndrd * eps* abs(tmp - tmp1)) - call stdlib_${ri}$larrk( in, in, gl, gu, d(ibegin),e2(ibegin), pivmin, rtl, tmp, tmp1,& + call stdlib${ii}$_${ri}$larrk( in, in, gl, gu, d(ibegin),e2(ibegin), pivmin, rtl, tmp, tmp1,& iinfo ) - if( iinfo/=0 ) then - info = -1 + if( iinfo/=0_${ik}$ ) then + info = -1_${ik}$ return endif isrght = min(gu, tmp + tmp1+ hndrd * eps * abs(tmp + tmp1)) @@ -40659,16 +40651,16 @@ module stdlib_linalg_lapack_${ri}$ ! if all the eigenvalues have to be computed, we use dqd usedqd = .true. ! indl is the local index of the first eigenvalue to compute - indl = 1 + indl = 1_${ik}$ indu = in ! mb = number of eigenvalues to compute mb = in - wend = wbegin + mb - 1 + wend = wbegin + mb - 1_${ik}$ ! define 1/4 and 3/4 points of the spectrum s1 = isleft + fourth * spdiam s2 = isrght - fourth * spdiam else - ! stdlib_${ri}$larrd has computed iblock and indexw for each eigenvalue + ! stdlib${ii}$_${ri}$larrd has computed iblock and indexw for each eigenvalue ! approximation. ! choose sigma if( usedqd ) then @@ -40681,11 +40673,11 @@ module stdlib_linalg_lapack_${ri}$ endif endif ! compute the negcount at the 1/4 and 3/4 points - if(mb>1) then - call stdlib_${ri}$larrc( 'T', in, s1, s2, d(ibegin),e(ibegin), pivmin, cnt, cnt1, & + if(mb>1_${ik}$) then + call stdlib${ii}$_${ri}$larrc( 'T', in, s1, s2, d(ibegin),e(ibegin), pivmin, cnt, cnt1, & cnt2, iinfo) endif - if(mb==1) then + if(mb==1_${ik}$) then sigma = gl sgndef = one elseif( cnt1 - indl >= indu - cnt2 ) then @@ -40726,7 +40718,7 @@ module stdlib_linalg_lapack_${ri}$ tau = spdiam*eps*n + two*pivmin tau = max( tau,two*eps*abs(sigma) ) else - if(mb>1) then + if(mb>1_${ik}$) then clwdth = w(wend) + werr(wend) - w(wbegin) - werr(wbegin) avgap = abs(clwdth / real(wend-wbegin,KIND=${rk}$)) if( sgndef==one ) then @@ -40745,17 +40737,17 @@ module stdlib_linalg_lapack_${ri}$ ! store d in work(1:in), l in work(in+1:2*in), and reciprocals of ! pivots in work(2*in+1:3*in) dpivot = d( ibegin ) - sigma - work( 1 ) = dpivot - dmax = abs( work(1) ) + work( 1_${ik}$ ) = dpivot + dmax = abs( work(1_${ik}$) ) j = ibegin do i = 1, in - 1 - work( 2*in+i ) = one / work( i ) - tmp = e( j )*work( 2*in+i ) + work( 2_${ik}$*in+i ) = one / work( i ) + tmp = e( j )*work( 2_${ik}$*in+i ) work( in+i ) = tmp dpivot = ( d( j+1 )-sigma ) - tmp*e( j ) work( i+1 ) = dpivot dmax = max( dmax, abs(dpivot) ) - j = j + 1 + j = j + 1_${ik}$ end do ! check for element growth if( dmax > maxgrowth*spdiam ) then @@ -40793,7 +40785,7 @@ module stdlib_linalg_lapack_${ri}$ end do loop_80 ! if the program reaches this point, no base representation could be ! found in maxtry iterations. - info = 2 + info = 2_${ik}$ return 83 continue ! at this point, we have found an initial base representation @@ -40801,16 +40793,16 @@ module stdlib_linalg_lapack_${ri}$ ! store the shift. e( iend ) = sigma ! store d and l. - call stdlib_${ri}$copy( in, work, 1, d( ibegin ), 1 ) - call stdlib_${ri}$copy( in-1, work( in+1 ), 1, e( ibegin ), 1 ) - if(mb>1 ) then + call stdlib${ii}$_${ri}$copy( in, work, 1_${ik}$, d( ibegin ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$copy( in-1, work( in+1 ), 1_${ik}$, e( ibegin ), 1_${ik}$ ) + if(mb>1_${ik}$ ) then ! perturb each entry of the base representation by a small ! (but random) relative amount to overcome difficulties with ! glued matrices. do i = 1, 4 - iseed( i ) = 1 + iseed( i ) = 1_${ik}$ end do - call stdlib_${ri}$larnv(2, iseed, 2*in-1, work(1)) + call stdlib${ii}$_${ri}$larnv(2_${ik}$, iseed, 2_${ik}$*in-1, work(1_${ik}$)) do i = 1,in-1 d(ibegin+i-1) = d(ibegin+i-1)*(one+eps*pert*work(i)) e(ibegin+i-1) = e(ibegin+i-1)*(one+eps*pert*work(in+i)) @@ -40818,38 +40810,38 @@ module stdlib_linalg_lapack_${ri}$ d(iend) = d(iend)*(one+eps*four*work(in)) endif ! don't update the gerschgorin intervals because keeping track - ! of the updates would be too much work in stdlib_${ri}$larrv. + ! of the updates would be too much work in stdlib${ii}$_${ri}$larrv. ! we update w instead and use it to locate the proper gerschgorin ! intervals. ! compute the required eigenvalues of l d l' by bisection or dqds if ( .not.usedqd ) then - ! if stdlib_${ri}$larrd has been used, shift the eigenvalue approximations + ! if stdlib${ii}$_${ri}$larrd has been used, shift the eigenvalue approximations ! according to their representation. this is necessary for - ! a uniform stdlib_${ri}$larrv since dqds computes eigenvalues of the - ! shifted representation. in stdlib_${ri}$larrv, w will always hold the + ! a uniform stdlib${ii}$_${ri}$larrv since dqds computes eigenvalues of the + ! shifted representation. in stdlib${ii}$_${ri}$larrv, w will always hold the ! unshifted eigenvalue approximation. do j=wbegin,wend w(j) = w(j) - sigma werr(j) = werr(j) + abs(w(j)) * eps end do - ! call stdlib_${ri}$larrb to reduce eigenvalue error of the approximations - ! from stdlib_${ri}$larrd + ! call stdlib${ii}$_${ri}$larrb to reduce eigenvalue error of the approximations + ! from stdlib${ii}$_${ri}$larrd do i = ibegin, iend-1 - work( i ) = d( i ) * e( i )**2 + work( i ) = d( i ) * e( i )**2_${ik}$ end do ! use bisection to find ev from indl to indu - call stdlib_${ri}$larrb(in, d(ibegin), work(ibegin),indl, indu, rtol1, rtol2, indl-1,& - w(wbegin), wgap(wbegin), werr(wbegin),work( 2*n+1 ), iwork, pivmin, spdiam,in, & + call stdlib${ii}$_${ri}$larrb(in, d(ibegin), work(ibegin),indl, indu, rtol1, rtol2, indl-1,& + w(wbegin), wgap(wbegin), werr(wbegin),work( 2_${ik}$*n+1 ), iwork, pivmin, spdiam,in, & iinfo ) - if( iinfo /= 0 ) then - info = -4 + if( iinfo /= 0_${ik}$ ) then + info = -4_${ik}$ return end if - ! stdlib_${ri}$larrb computes all gaps correctly except for the last one + ! stdlib${ii}$_${ri}$larrb computes all gaps correctly except for the last one ! record distance to vu/gu wgap( wend ) = max( zero,( vu-sigma ) - ( w( wend ) + werr( wend ) ) ) do i = indl, indu - m = m + 1 + m = m + 1_${ik}$ iblock(m) = jblk indexw(m) = i end do @@ -40861,52 +40853,52 @@ module stdlib_linalg_lapack_${ri}$ ! might be lost when the shift of the rrr is subtracted to obtain ! the eigenvalues of t. however, t is not guaranteed to define its ! eigenvalues to high relative accuracy anyway. - ! set rtol to the order of the tolerance used in stdlib_${ri}$lasq2 + ! set rtol to the order of the tolerance used in stdlib${ii}$_${ri}$lasq2 ! this is an estimated error, the worst case bound is 4*n*eps ! which is usually too large and requires unnecessary work to be ! done by bisection when computing the eigenvectors rtol = log(real(in,KIND=${rk}$)) * four * eps j = ibegin do i = 1, in - 1 - work( 2*i-1 ) = abs( d( j ) ) - work( 2*i ) = e( j )*e( j )*work( 2*i-1 ) - j = j + 1 - end do - work( 2*in-1 ) = abs( d( iend ) ) - work( 2*in ) = zero - call stdlib_${ri}$lasq2( in, work, iinfo ) - if( iinfo /= 0 ) then + work( 2_${ik}$*i-1 ) = abs( d( j ) ) + work( 2_${ik}$*i ) = e( j )*e( j )*work( 2_${ik}$*i-1 ) + j = j + 1_${ik}$ + end do + work( 2_${ik}$*in-1 ) = abs( d( iend ) ) + work( 2_${ik}$*in ) = zero + call stdlib${ii}$_${ri}$lasq2( in, work, iinfo ) + if( iinfo /= 0_${ik}$ ) then ! if iinfo = -5 then an index is part of a tight cluster ! and should be changed. the index is in iwork(1) and the ! gap is in work(n+1) - info = -5 + info = -5_${ik}$ return else ! test that all eigenvalues are positive as expected do i = 1, in if( work( i )zero ) then do i = indl, indu - m = m + 1 + m = m + 1_${ik}$ w( m ) = work( in-i+1 ) iblock( m ) = jblk indexw( m ) = i end do else do i = indl, indu - m = m + 1 + m = m + 1_${ik}$ w( m ) = -work( i ) iblock( m ) = jblk indexw( m ) = i end do end if do i = m - mb + 1, m - ! the value of rtol below should be the tolerance in stdlib_${ri}$lasq2 + ! the value of rtol below should be the tolerance in stdlib${ii}$_${ri}$lasq2 werr( i ) = rtol * abs( w(i) ) end do do i = m - mb + 1, m - 1 @@ -40916,14 +40908,14 @@ module stdlib_linalg_lapack_${ri}$ wgap( m ) = max( zero,( vu-sigma ) - ( w( m ) + werr( m ) ) ) end if ! proceed with next block - ibegin = iend + 1 - wbegin = wend + 1 + ibegin = iend + 1_${ik}$ + wbegin = wend + 1_${ik}$ end do loop_170 return - end subroutine stdlib_${ri}$larre + end subroutine stdlib${ii}$_${ri}$larre - pure subroutine stdlib_${ri}$larrf( n, d, l, ld, clstrt, clend,w, wgap, werr,spdiam, clgapl, & + pure subroutine stdlib${ii}$_${ri}$larrf( n, d, l, ld, clstrt, clend,w, wgap, werr,spdiam, clgapl, & !! Given the initial representation L D L^T and its cluster of close !! eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ... !! W( CLEND ), DLARRF: finds a new relatively robust representation @@ -40934,8 +40926,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: clgapl, clgapr, pivmin, spdiam real(${rk}$), intent(out) :: sigma ! Array Arguments @@ -40947,27 +40939,27 @@ module stdlib_linalg_lapack_${ri}$ real(${rk}$), parameter :: quart = 0.25_${rk}$ real(${rk}$), parameter :: maxgrowth1 = 8._${rk}$ real(${rk}$), parameter :: maxgrowth2 = 8._${rk}$ - integer(ilp), parameter :: ktrymax = 1 - integer(ilp), parameter :: sleft = 1 - integer(ilp), parameter :: sright = 2 + 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(${rk}$) :: avgap, bestshift, clwdth, eps, fact, fail, fail2, growthbound, ldelta, & ldmax, lsigma, max1, max2, mingap, oldp, prod, rdelta, rdmax, rrr1, rrr2, rsigma, s, & smlgrowth, tmp, znm2 ! Intrinsic Functions 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=${rk}$) - eps = stdlib_${ri}$lamch( 'PRECISION' ) - shift = 0 + fact = real(2_${ik}$**ktrymax,KIND=${rk}$) + eps = stdlib${ii}$_${ri}$lamch( '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. @@ -40998,13 +40990,13 @@ module stdlib_linalg_lapack_${ri}$ ldelta = max(avgap,wgap( clstrt ))/fact rdelta = max(avgap,wgap( clend-1 ))/fact ! initialize the record of the best representation found - s = stdlib_${ri}$lamch( 'S' ) + s = stdlib${ii}$_${ri}$lamch( 'S' ) smlgrowth = one / s fail = real(n-1,KIND=${rk}$)*mingap/(spdiam*eps) fail2 = real(n-1,KIND=${rk}$)*mingap/(spdiam*sqrt(eps)) bestshift = lsigma ! while (ktry <= ktrymax) - ktry = 0 + ktry = 0_${ik}$ growthbound = maxgrowth1*spdiam 5 continue sawnan1 = .false. @@ -41016,14 +41008,14 @@ module stdlib_linalg_lapack_${ri}$ ! 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))=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 @@ -41256,13 +41248,13 @@ module stdlib_linalg_lapack_${ri}$ ! 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 @@ -41272,21 +41264,21 @@ module stdlib_linalg_lapack_${ri}$ ! 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 + 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_${ri}$larrj + end subroutine stdlib${ii}$_${ri}$larrj - pure subroutine stdlib_${ri}$larrk( n, iw, gl, gu,d, e2, pivmin, reltol, w, werr, info) + pure subroutine stdlib${ii}$_${ri}$larrk( n, iw, gl, gu,d, e2, pivmin, reltol, w, werr, info) !! DLARRK: computes one eigenvalue of a symmetric tridiagonal !! matrix T to suitable accuracy. This is an auxiliary code to be !! called from DSTEMR. @@ -41374,8 +41366,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: pivmin, reltol, gl, gu real(${rk}$), intent(out) :: w, werr ! Array Arguments @@ -41385,46 +41377,46 @@ module stdlib_linalg_lapack_${ri}$ real(${rk}$), parameter :: fudge = two ! Local Scalars - integer(ilp) :: i, it, itmax, negcnt + integer(${ik}$) :: i, it, itmax, negcnt real(${rk}$) :: 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_${ri}$lamch( 'P' ) + eps = stdlib${ii}$_${ri}$lamch( '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 @@ -41437,10 +41429,10 @@ module stdlib_linalg_lapack_${ri}$ w = half * (left + right) werr = half * abs( right - left ) return - end subroutine stdlib_${ri}$larrk + end subroutine stdlib${ii}$_${ri}$larrk - pure subroutine stdlib_${ri}$larrr( n, d, e, info ) + pure subroutine stdlib${ii}$_${ri}$larrr( 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. @@ -41448,8 +41440,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: d(*) real(${rk}$), intent(inout) :: e(*) @@ -41458,21 +41450,21 @@ module stdlib_linalg_lapack_${ri}$ real(${rk}$), parameter :: relcond = 0.999_${rk}$ ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i logical(lk) :: yesrel real(${rk}$) :: 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_${ri}$lamch( 'SAFE MINIMUM' ) - eps = stdlib_${ri}$lamch( 'PRECISION' ) + info = 1_${ik}$ + safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_${ri}$lamch( 'PRECISION' ) smlnum = safmin / eps rmin = sqrt( smlnum ) ! tests for relative accuracy @@ -41491,7 +41483,7 @@ module stdlib_linalg_lapack_${ri}$ ! instead of the current offdig + offdig2 < 1 yesrel = .true. offdig = zero - tmp = sqrt(abs(d(1))) + tmp = sqrt(abs(d(1_${ik}$))) if (tmp1) then + zusedl = 1_${ik}$ + if(dol>1_${ik}$) then ! set lower bound for use of z zusedl = dol-1 endif @@ -41596,13 +41588,13 @@ module stdlib_linalg_lapack_${ri}$ zusedu = dou+1 endif ! the width of the part of z that is used - zusedw = zusedu - zusedl + 1 - call stdlib_${ri}$laset( 'FULL', n, zusedw, zero, zero,z(1,zusedl), ldz ) - eps = stdlib_${ri}$lamch( 'PRECISION' ) + zusedw = zusedu - zusedl + 1_${ik}$ + call stdlib${ii}$_${ri}$laset( 'FULL', n, zusedw, zero, zero,z(1_${ik}$,zusedl), ldz ) + eps = stdlib${ii}$_${ri}$lamch( '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 @@ -41616,54 +41608,54 @@ module stdlib_linalg_lapack_${ri}$ ! 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 + im = wend - wbegin + 1_${ik}$ ! this is for a 1x1 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) @@ -41672,24 +41664,24 @@ module stdlib_linalg_lapack_${ri}$ ! the eigenvalue approximations will be refined when necessary as ! high relative accuracy is required for the computation of the ! corresponding eigenvectors. - call stdlib_${ri}$copy( im, w( wbegin ), 1,work( wbegin ), 1 ) + call stdlib${ii}$_${ri}$copy( 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 + ndepth = 0_${ik}$ ! parity is either 1 or 0 - parity = 1 + 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 + 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 @@ -41715,37 +41707,37 @@ module stdlib_linalg_lapack_${ri}$ 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 ! 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_${ri}$copy( in, z( ibegin, j ), 1, d( ibegin ), 1 ) - call stdlib_${ri}$copy( in-1, z( ibegin, j+1 ), 1, l( ibegin ),1 ) + call stdlib${ii}$_${ri}$copy( in, z( ibegin, j ), 1_${ik}$, d( ibegin ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$copy( 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_${ri}$laset( 'FULL', in, 2, zero, zero,z( ibegin, j), ldz ) + call stdlib${ii}$_${ri}$laset( 'FULL', in, 2_${ik}$, zero, zero,z( ibegin, j), ldz ) end if ! compute dl and dll of current rrr do j = ibegin, iend-1 @@ -41753,7 +41745,7 @@ module stdlib_linalg_lapack_${ri}$ 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 ) @@ -41761,29 +41753,29 @@ module stdlib_linalg_lapack_${ri}$ ! 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_${ri}$larrb( in, d( ibegin ),work(indlld+ibegin-1),p, q, rtol1, & + call stdlib${ii}$_${ri}$larrb( in, d( ibegin ),work(indlld+ibegin-1),p, q, rtol1, & rtol2, offset,work(wbegin),wgap(wbegin),werr(wbegin),work( indwrk ), iwork(& iindwk ),pivmin, spdiam, in, iinfo ) - if( iinfo/=0 ) then - 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_${ri}$larrb. + ! wbegin-1+oldlst are correctly computed in stdlib${ii}$_${ri}$larrb. ! 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 @@ -41800,7 +41792,7 @@ module stdlib_linalg_lapack_${ri}$ ! 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 @@ -41811,25 +41803,25 @@ module stdlib_linalg_lapack_${ri}$ 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. @@ -41840,7 +41832,7 @@ module stdlib_linalg_lapack_${ri}$ ! 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 ) @@ -41851,13 +41843,13 @@ module stdlib_linalg_lapack_${ri}$ ! 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_${ri}$larrb( in, d(ibegin),work( indlld+ibegin-1 ),p,p,rqtol, & + offset = indexw( wbegin ) - 1_${ik}$ + call stdlib${ii}$_${ri}$larrb( in, d(ibegin),work( indlld+ibegin-1 ),p,p,rqtol, & rqtol, offset,work(wbegin),wgap(wbegin),werr(wbegin),work( indwrk ),& iwork( iindwk ), pivmin, spdiam,in, iinfo ) end do @@ -41868,18 +41860,18 @@ module stdlib_linalg_lapack_${ri}$ ! 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_${ri}$larrf needs lwork = 2*n - call stdlib_${ri}$larrf( in, d( ibegin ), l( ibegin ),work(indld+ibegin-1),& + ! stdlib${ii}$_${ri}$larrf needs lwork = 2*n + call stdlib${ii}$_${ri}$larrf( in, d( ibegin ), l( ibegin ),work(indld+ibegin-1),& newfst, newlst, work(wbegin),wgap(wbegin), werr(wbegin),spdiam, lgap, & rgap, pivmin, tau,z(ibegin, newftt),z(ibegin, newftt+1),work( indwrk ), & iinfo ) - if( iinfo==0 ) then - ! a new rrr for the cluster was found by stdlib_${ri}$larrf + if( iinfo==0_${ik}$ ) then + ! a new rrr for the cluster was found by stdlib${ii}$_${ri}$larrf ! update shift and store it ssigma = sigma + tau z( iend, newftt+1 ) = ssigma @@ -41887,10 +41879,10 @@ module stdlib_linalg_lapack_${ri}$ ! 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 @@ -41899,24 +41891,24 @@ module stdlib_linalg_lapack_${ri}$ ! 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=${rk}$)) * 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. @@ -41933,7 +41925,7 @@ module stdlib_linalg_lapack_${ri}$ ! 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 ) @@ -41955,7 +41947,7 @@ module stdlib_linalg_lapack_${ri}$ 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. @@ -41964,7 +41956,7 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -41988,34 +41980,34 @@ module stdlib_linalg_lapack_${ri}$ ! take the bisection as new iterate usedbs = .true. itmp1 = iwork( iindr+windex ) - offset = indexw( wbegin ) - 1 - call stdlib_${ri}$larrb( in, d(ibegin),work(indlld+ibegin-1),indeig,& + offset = indexw( wbegin ) - 1_${ik}$ + call stdlib${ii}$_${ri}$larrb( in, d(ibegin),work(indlld+ibegin-1),indeig,& indeig,zero, two*eps, offset,work(wbegin),wgap(wbegin),werr(wbegin),& work( indwrk ),iwork( iindwk ), pivmin, spdiam,itmp1, iinfo ) - if( iinfo/=0 ) then - 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_${ri}$lar1v( in, 1, in, lambda, d( ibegin ),l( ibegin ), work(& + call stdlib${ii}$_${ri}$lar1v( 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 @@ -42135,25 +42127,25 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$larrv + end subroutine stdlib${ii}$_${ri}$larrv - pure subroutine stdlib_${ri}$lartg( f, g, c, s, r ) + pure subroutine stdlib${ii}$_${ri}$lartg( f, g, c, s, r ) !! DLARTG: generates a plane rotation so that !! [ C S ] . [ F ] = [ R ] !! [ -S C ] [ G ] [ 0 ] @@ -42217,10 +42209,10 @@ module stdlib_linalg_lapack_${ri}$ r = sign( d, f )*u end if return - end subroutine stdlib_${ri}$lartg + end subroutine stdlib${ii}$_${ri}$lartg - pure subroutine stdlib_${ri}$lartgp( f, g, cs, sn, r ) + pure subroutine stdlib${ii}$_${ri}$lartgp( f, g, cs, sn, r ) !! DLARTGP: generates a plane rotation so that !! [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. !! [ -SN CS ] [ G ] [ 0 ] @@ -42242,7 +42234,7 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars ! logical first - integer(ilp) :: count, i + integer(${ik}$) :: count, i real(${rk}$) :: eps, f1, g1, safmin, safmn2, safmx2, scale ! Intrinsic Functions intrinsic :: abs,int,log,max,sign,sqrt @@ -42252,10 +42244,10 @@ module stdlib_linalg_lapack_${ri}$ ! data first / .true. / ! Executable Statements ! if( first ) then - safmin = stdlib_${ri}$lamch( 'S' ) - eps = stdlib_${ri}$lamch( 'E' ) - safmn2 = stdlib_${ri}$lamch( 'B' )**int( log( safmin / eps ) /log( stdlib_${ri}$lamch( 'B' ) )& - / two,KIND=ilp) + safmin = stdlib${ii}$_${ri}$lamch( 'S' ) + eps = stdlib${ii}$_${ri}$lamch( 'E' ) + safmn2 = stdlib${ii}$_${ri}$lamch( 'B' )**int( log( safmin / eps ) /log( stdlib${ii}$_${ri}$lamch( 'B' ) )& + / two,KIND=${ik}$) safmx2 = one / safmn2 ! first = .false. ! end if @@ -42272,35 +42264,35 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -42311,10 +42303,10 @@ module stdlib_linalg_lapack_${ri}$ end if end if return - end subroutine stdlib_${ri}$lartgp + end subroutine stdlib${ii}$_${ri}$lartgp - pure subroutine stdlib_${ri}$lartgs( x, y, sigma, cs, sn ) + pure subroutine stdlib${ii}$_${ri}$lartgs( x, y, sigma, cs, sn ) !! DLARTGS: generates a plane rotation designed to introduce a bulge in !! Golub-Reinsch-style implicit QR iteration for the bidiagonal SVD !! problem. X and Y are the top-row entries, and SIGMA is the shift. @@ -42333,7 +42325,7 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars real(${rk}$) :: r, s, thresh, w, z - thresh = stdlib_${ri}$lamch('E') + thresh = stdlib${ii}$_${ri}$lamch('E') ! compute the first column of b**t*b - sigma^2*i, up to a scale ! factor. if( (sigma == zero .and. abs(x) < thresh) .or.(abs(x) == sigma .and. y == zero) ) & @@ -42361,16 +42353,16 @@ module stdlib_linalg_lapack_${ri}$ w = s * y end if ! generate the rotation. - ! call stdlib_${ri}$lartgp( z, w, cs, sn, r ) might seem more natural; + ! call stdlib${ii}$_${ri}$lartgp( z, w, cs, sn, r ) might seem more natural; ! reordering the arguments ensures that if z = 0 then the rotation ! is by pi/2. - call stdlib_${ri}$lartgp( w, z, sn, cs, r ) + call stdlib${ii}$_${ri}$lartgp( w, z, sn, cs, r ) return - ! end stdlib_${ri}$lartgs - end subroutine stdlib_${ri}$lartgs + ! end stdlib${ii}$_${ri}$lartgs + end subroutine stdlib${ii}$_${ri}$lartgs - pure subroutine stdlib_${ri}$lartv( n, x, incx, y, incy, c, s, incc ) + pure subroutine stdlib${ii}$_${ri}$lartv( n, x, incx, y, incy, c, s, incc ) !! DLARTV: applies a vector of real plane rotations to elements of the !! real vectors x and y. For i = 1,2,...,n !! ( x(i) ) := ( c(i) s(i) ) ( x(i) ) @@ -42379,18 +42371,18 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: c(*), s(*) real(${rk}$), intent(inout) :: x(*), y(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ic, ix, iy + integer(${ik}$) :: i, ic, ix, iy real(${rk}$) :: 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 ) @@ -42401,10 +42393,10 @@ module stdlib_linalg_lapack_${ri}$ ic = ic + incc end do return - end subroutine stdlib_${ri}$lartv + end subroutine stdlib${ii}$_${ri}$lartv - pure subroutine stdlib_${ri}$laruv( iseed, n, x ) + pure subroutine stdlib${ii}$_${ri}$laruv( iseed, n, x ) !! DLARUV: returns a vector of n random real numbers from a uniform (0,1) !! distribution (n <= 128). !! This is an auxiliary routine called by DLARNV and ZLARNV. @@ -42412,171 +42404,171 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), 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(${rk}$), parameter :: r = one/ipw2 ! Local Scalars - integer(ilp) :: i, i1, i2, i3, i4, it1, it2, it3, it4, j + integer(${ik}$) :: i, i1, i2, i3, i4, it1, it2, it3, it4, j ! Local Arrays - integer(ilp) :: mm(lv,4) + integer(${ik}$) :: mm(lv,4_${ik}$) ! Intrinsic Functions intrinsic :: real,min,mod ! 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 ) + 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=${rk}$) x( i ) = r*( real( it1,KIND=${rk}$)+r*( real( it2,KIND=${rk}$)+r*( real( it3,KIND=${rk}$)+& @@ -42590,23 +42582,23 @@ module stdlib_linalg_lapack_${ri}$ ! the statistically correct thing to do in this situation is ! simply to iterate again. ! n.b. the case x( i ) = 0.0_${rk}$ 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_${ri}$laruv + end subroutine stdlib${ii}$_${ri}$laruv - pure subroutine stdlib_${ri}$larz( side, m, n, l, v, incv, tau, c, ldc, work ) + pure subroutine stdlib${ii}$_${ri}$larz( side, m, n, l, v, incv, tau, c, ldc, work ) !! DLARZ: applies a real elementary reflector H to a real M-by-N !! matrix C, from either the left or the right. H is represented in the !! form @@ -42619,7 +42611,7 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: tau ! Array Arguments real(${rk}$), intent(inout) :: c(ldc,*) @@ -42632,36 +42624,36 @@ module stdlib_linalg_lapack_${ri}$ ! form h * c if( tau/=zero ) then ! w( 1:n ) = c( 1, 1:n ) - call stdlib_${ri}$copy( n, c, ldc, work, 1 ) + call stdlib${ii}$_${ri}$copy( n, c, ldc, work, 1_${ik}$ ) ! w( 1:n ) = w( 1:n ) + c( m-l+1:m, 1:n )**t * v( 1:l ) - call stdlib_${ri}$gemv( 'TRANSPOSE', l, n, one, c( m-l+1, 1 ), ldc, v,incv, one, work,& - 1 ) + call stdlib${ii}$_${ri}$gemv( 'TRANSPOSE', l, n, one, c( m-l+1, 1_${ik}$ ), ldc, v,incv, one, work,& + 1_${ik}$ ) ! c( 1, 1:n ) = c( 1, 1:n ) - tau * w( 1:n ) - call stdlib_${ri}$axpy( n, -tau, work, 1, c, ldc ) + call stdlib${ii}$_${ri}$axpy( n, -tau, work, 1_${ik}$, 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_${ri}$ger( l, n, -tau, v, incv, work, 1, c( m-l+1, 1 ),ldc ) + call stdlib${ii}$_${ri}$ger( 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_${ri}$copy( m, c, 1, work, 1 ) + call stdlib${ii}$_${ri}$copy( m, c, 1_${ik}$, work, 1_${ik}$ ) ! w( 1:m ) = w( 1:m ) + c( 1:m, n-l+1:n, 1:n ) * v( 1:l ) - call stdlib_${ri}$gemv( 'NO TRANSPOSE', m, l, one, c( 1, n-l+1 ), ldc,v, incv, one, & - work, 1 ) + call stdlib${ii}$_${ri}$gemv( 'NO TRANSPOSE', m, l, one, c( 1_${ik}$, n-l+1 ), ldc,v, incv, one, & + work, 1_${ik}$ ) ! c( 1:m, 1 ) = c( 1:m, 1 ) - tau * w( 1:m ) - call stdlib_${ri}$axpy( m, -tau, work, 1, c, 1 ) + call stdlib${ii}$_${ri}$axpy( m, -tau, work, 1_${ik}$, c, 1_${ik}$ ) ! c( 1:m, n-l+1:n ) = c( 1:m, n-l+1:n ) - ... ! tau * w( 1:m ) * v( 1:l )**t - call stdlib_${ri}$ger( m, l, -tau, work, 1, v, incv, c( 1, n-l+1 ),ldc ) + call stdlib${ii}$_${ri}$ger( m, l, -tau, work, 1_${ik}$, v, incv, c( 1_${ik}$, n-l+1 ),ldc ) end if end if return - end subroutine stdlib_${ri}$larz + end subroutine stdlib${ii}$_${ri}$larz - pure subroutine stdlib_${ri}$larzb( side, trans, direct, storev, m, n, k, l, v,ldv, t, ldt, c, & + pure subroutine stdlib${ii}$_${ri}$larzb( side, trans, direct, storev, m, n, k, l, v,ldv, t, ldt, c, & !! DLARZB: applies a real block reflector H or its transpose H**T to !! a real distributed M-by-N C from the left or the right. !! Currently, only STOREV = 'R' and DIRECT = 'B' are supported. @@ -42671,7 +42663,7 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(inout) :: c(ldc,*), t(ldt,*), v(ldv,*) real(${rk}$), intent(out) :: work(ldwork,*) @@ -42679,19 +42671,19 @@ module stdlib_linalg_lapack_${ri}$ ! 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( 'DLARZB', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DLARZB', -info ) return end if if( stdlib_lsame( trans, 'N' ) ) then @@ -42703,14 +42695,14 @@ module stdlib_linalg_lapack_${ri}$ ! form h * c or h**t * c ! w( 1:n, 1:k ) = c( 1:k, 1:n )**t do j = 1, k - call stdlib_${ri}$copy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib${ii}$_${ri}$copy( 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_${ri}$gemm( 'TRANSPOSE', 'TRANSPOSE', n, k, l, one,c( m-l+1, 1 ), & + if( l>0_${ik}$ )call stdlib${ii}$_${ri}$gemm( '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_${ri}$trmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k, one, t,ldt, work, & + call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k, one, t,ldt, work, & ldwork ) ! c( 1:k, 1:n ) = c( 1:k, 1:n ) - w( 1:n, 1:k )**t do j = 1, n @@ -42720,20 +42712,20 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$gemm( 'TRANSPOSE', 'TRANSPOSE', l, n, k, -one, v, ldv,work, & - ldwork, one, c( m-l+1, 1 ), ldc ) + if( l>0_${ik}$ )call stdlib${ii}$_${ri}$gemm( '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 ) do j = 1, k - call stdlib_${ri}$copy( m, c( 1, j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_${ri}$copy( 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_${ri}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, l, one,c( 1, n-l+1 ),& + if( l>0_${ik}$ )call stdlib${ii}$_${ri}$gemm( '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_${ri}$trmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k, one, t,ldt, work, & + call stdlib${ii}$_${ri}$trmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k, one, t,ldt, work, & ldwork ) ! c( 1:m, 1:k ) = c( 1:m, 1:k ) - w( 1:m, 1:k ) do j = 1, k @@ -42743,14 +42735,14 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, l, k, -one,work, & - ldwork, v, ldv, one, c( 1, n-l+1 ), ldc ) + if( l>0_${ik}$ )call stdlib${ii}$_${ri}$gemm( '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_${ri}$larzb + end subroutine stdlib${ii}$_${ri}$larzb - pure subroutine stdlib_${ri}$larzt( direct, storev, n, k, v, ldv, tau, t, ldt ) + pure subroutine stdlib${ii}$_${ri}$larzt( direct, storev, n, k, v, ldv, tau, t, ldt ) !! DLARZT: forms the triangular factor T of a real block reflector !! H of order > n, which is defined as a product of k elementary !! reflectors. @@ -42768,7 +42760,7 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(out) :: t(ldt,*) real(${rk}$), intent(in) :: tau(*) @@ -42776,17 +42768,17 @@ module stdlib_linalg_lapack_${ri}$ ! ===================================================================== ! 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( 'DLARZT', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DLARZT', -info ) return end if do i = k, 1, -1 @@ -42799,20 +42791,20 @@ module stdlib_linalg_lapack_${ri}$ ! general case if( i=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}$_${ri}$isnan(cfrom) ) then + info = -4_${ik}$ + else if( stdlib${ii}$_${ri}$isnan(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. lda1 ) ) then - info = -2 + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -1_${ik}$ + else if( ( sqre<0_${ik}$ ) .or. ( sqre>1_${ik}$ ) ) then + info = -2_${ik}$ end if m = n + sqre if( ldu1 ) ) then - info = -3 + info = 0_${ik}$ + if( nl<1_${ik}$ ) then + info = -1_${ik}$ + else if( nr<1_${ik}$ ) then + info = -2_${ik}$ + else if( ( sqre<0_${ik}$ ) .or. ( sqre>1_${ik}$ ) ) then + info = -3_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'DLASD1', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DLASD1', -info ) return end if - n = nl + nr + 1 + n = nl + nr + 1_${ik}$ m = n + sqre ! the following values are for bookkeeping purposes only. they are ! integer pointers which indicate the portion of the workspace - ! used by a particular array in stdlib_${ri}$lasd2 and stdlib_${ri}$lasd3. + ! used by a particular array in stdlib${ii}$_${ri}$lasd2 and stdlib${ii}$_${ri}$lasd3. ldu2 = n ldvt2 = m - iz = 1 + iz = 1_${ik}$ isigma = iz + m iu2 = isigma + n ivt2 = iu2 + ldu2*n iq = ivt2 + ldvt2*m - idx = 1 + idx = 1_${ik}$ idxc = idx + n coltyp = idxc + n idxp = coltyp + n @@ -43274,33 +43266,33 @@ module stdlib_linalg_lapack_${ri}$ orgnrm = abs( d( i ) ) end if end do - call stdlib_${ri}$lascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, n, 1_${ik}$, d, n, info ) alpha = alpha / orgnrm beta = beta / orgnrm ! deflate singular values. - call stdlib_${ri}$lasd2( nl, nr, sqre, k, d, work( iz ), alpha, beta, u, ldu,vt, ldvt, work(& + call stdlib${ii}$_${ri}$lasd2( nl, nr, sqre, k, d, work( iz ), alpha, beta, u, ldu,vt, ldvt, work(& isigma ), work( iu2 ), ldu2,work( ivt2 ), ldvt2, iwork( idxp ), iwork( idx ),iwork( & idxc ), idxq, iwork( coltyp ), info ) ! solve secular equation and update singular vectors. ldq = k - call stdlib_${ri}$lasd3( nl, nr, sqre, k, d, work( iq ), ldq, work( isigma ),u, ldu, work( & + call stdlib${ii}$_${ri}$lasd3( nl, nr, sqre, k, d, work( iq ), ldq, work( isigma ),u, ldu, work( & iu2 ), ldu2, vt, ldvt, work( ivt2 ),ldvt2, iwork( idxc ), iwork( coltyp ), work( iz ),& info ) ! report the convergence failure. - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if ! unscale. - call stdlib_${ri}$lascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, n, 1_${ik}$, d, n, info ) ! prepare the idxq sorting permutation. n1 = k n2 = n - k - call stdlib_${ri}$lamrg( n1, n2, d, 1, -1, idxq ) + call stdlib${ii}$_${ri}$lamrg( n1, n2, d, 1_${ik}$, -1_${ik}$, idxq ) return - end subroutine stdlib_${ri}$lasd1 + end subroutine stdlib${ii}$_${ri}$lasd1 - pure subroutine stdlib_${ri}$lasd2( nl, nr, sqre, k, d, z, alpha, beta, u, ldu, vt,ldvt, dsigma, & + pure subroutine stdlib${ii}$_${ri}$lasd2( nl, nr, sqre, k, d, z, alpha, beta, u, ldu, vt,ldvt, dsigma, & !! DLASD2: 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 @@ -43313,58 +43305,58 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, k - integer(ilp), intent(in) :: ldu, ldu2, ldvt, ldvt2, nl, nr, sqre + integer(${ik}$), intent(out) :: info, k + integer(${ik}$), intent(in) :: ldu, ldu2, ldvt, ldvt2, nl, nr, sqre real(${rk}$), intent(in) :: alpha, beta ! Array Arguments - integer(ilp), intent(out) :: coltyp(*), idx(*), idxc(*), idxp(*) - integer(ilp), intent(inout) :: idxq(*) + integer(${ik}$), intent(out) :: coltyp(*), idx(*), idxc(*), idxp(*) + integer(${ik}$), intent(inout) :: idxq(*) real(${rk}$), intent(inout) :: d(*), u(ldu,*), vt(ldvt,*) real(${rk}$), intent(out) :: dsigma(*), u2(ldu2,*), vt2(ldvt2,*), z(*) ! ===================================================================== ! Local Arrays - integer(ilp) :: ctot(4), psm(4) + integer(${ik}$) :: ctot(4_${ik}$), psm(4_${ik}$) ! Local Scalars - integer(ilp) :: ct, i, idxi, idxj, idxjp, j, jp, jprev, k2, m, n, nlp1, nlp2 + integer(${ik}$) :: ct, i, idxi, idxj, idxjp, j, jp, jprev, k2, m, n, nlp1, nlp2 real(${rk}$) :: c, eps, hlftol, s, tau, tol, z1 ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements ! test the input parameters. - info = 0 - if( nl<1 ) then - info = -1 - else if( nr<1 ) then - info = -2 - else if( ( sqre/=1 ) .and. ( sqre/=0 ) ) then - info = -3 - end if - n = nl + nr + 1 + info = 0_${ik}$ + if( nl<1_${ik}$ ) then + info = -1_${ik}$ + else if( nr<1_${ik}$ ) then + info = -2_${ik}$ + else if( ( sqre/=1_${ik}$ ) .and. ( sqre/=0_${ik}$ ) ) then + info = -3_${ik}$ + end if + n = nl + nr + 1_${ik}$ m = n + sqre if( ldun )go to 110 if( abs( z( j ) )<=tol ) then ! deflate due to small z component. - k2 = k2 - 1 + k2 = k2 - 1_${ik}$ idxp( k2 ) = j - coltyp( j ) = 4 + coltyp( j ) = 4_${ik}$ else ! check if singular values are close enough to allow deflation. if( abs( d( j )-d( jprev ) )<=tol ) then @@ -43446,33 +43438,33 @@ module stdlib_linalg_lapack_${ri}$ c = z( j ) ! find sqrt(a**2+b**2) without overflow or ! destructive underflow. - tau = stdlib_${ri}$lapy2( c, s ) + tau = stdlib${ii}$_${ri}$lapy2( c, s ) c = c / tau s = -s / tau z( j ) = tau z( jprev ) = zero ! apply back the givens rotation to the left and right ! singular vector matrices. - idxjp = idxq( idx( jprev )+1 ) - idxj = idxq( idx( j )+1 ) + 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 - call stdlib_${ri}$rot( n, u( 1, idxjp ), 1, u( 1, idxj ), 1, c, s ) - call stdlib_${ri}$rot( m, vt( idxjp, 1 ), ldvt, vt( idxj, 1 ), ldvt, c,s ) + call stdlib${ii}$_${ri}$rot( n, u( 1_${ik}$, idxjp ), 1_${ik}$, u( 1_${ik}$, idxj ), 1_${ik}$, c, s ) + call stdlib${ii}$_${ri}$rot( m, vt( idxjp, 1_${ik}$ ), ldvt, vt( idxj, 1_${ik}$ ), ldvt, c,s ) if( coltyp( j )/=coltyp( jprev ) ) then - coltyp( j ) = 3 + coltyp( j ) = 3_${ik}$ end if - coltyp( jprev ) = 4 - k2 = k2 - 1 + coltyp( jprev ) = 4_${ik}$ + k2 = k2 - 1_${ik}$ idxp( k2 ) = jprev jprev = j else - k = k + 1 - u2( k, 1 ) = z( jprev ) + k = k + 1_${ik}$ + u2( k, 1_${ik}$ ) = z( jprev ) dsigma( k ) = d( jprev ) idxp( k ) = jprev jprev = j @@ -43481,8 +43473,8 @@ module stdlib_linalg_lapack_${ri}$ go to 100 110 continue ! record the last singular value. - k = k + 1 - u2( k, 1 ) = z( jprev ) + k = k + 1_${ik}$ + u2( k, 1_${ik}$ ) = z( jprev ) dsigma( k ) = d( jprev ) idxp( k ) = jprev 120 continue @@ -43491,17 +43483,17 @@ module stdlib_linalg_lapack_${ri}$ ! four groups of uniform structure (although one or more of these ! groups may be empty). do j = 1, 4 - ctot( j ) = 0 + ctot( j ) = 0_${ik}$ end do do j = 2, n ct = coltyp( j ) - ctot( ct ) = ctot( ct ) + 1 + ctot( ct ) = ctot( ct ) + 1_${ik}$ end do ! psm(*) = position in submatrix (of types 1 through 4) - psm( 1 ) = 2 - psm( 2 ) = 2 + ctot( 1 ) - psm( 3 ) = psm( 2 ) + ctot( 2 ) - psm( 4 ) = psm( 3 ) + ctot( 3 ) + psm( 1_${ik}$ ) = 2_${ik}$ + psm( 2_${ik}$ ) = 2_${ik}$ + ctot( 1_${ik}$ ) + psm( 3_${ik}$ ) = psm( 2_${ik}$ ) + ctot( 2_${ik}$ ) + psm( 4_${ik}$ ) = psm( 3_${ik}$ ) + ctot( 3_${ik}$ ) ! fill out the idxc array so that the permutation which it induces ! will place all type-1 columns first, all type-2 columns next, ! then all type-3's, and finally all type-4's, starting from the @@ -43510,7 +43502,7 @@ module stdlib_linalg_lapack_${ri}$ jp = idxp( j ) ct = coltyp( jp ) idxc( psm( ct ) ) = j - psm( ct ) = psm( ct ) + 1 + psm( ct ) = psm( ct ) + 1_${ik}$ end do ! sort the singular values and corresponding singular vectors into ! dsigma, u2, and vt2 respectively. the singular values/vectors @@ -43521,71 +43513,71 @@ module stdlib_linalg_lapack_${ri}$ do j = 2, n jp = idxp( j ) dsigma( j ) = d( jp ) - idxj = idxq( idx( idxp( idxc( j ) ) )+1 ) + idxj = idxq( idx( idxp( idxc( j ) ) )+1_${ik}$ ) if( idxj<=nlp1 ) then - idxj = idxj - 1 + idxj = idxj - 1_${ik}$ end if - call stdlib_${ri}$copy( n, u( 1, idxj ), 1, u2( 1, j ), 1 ) - call stdlib_${ri}$copy( m, vt( idxj, 1 ), ldvt, vt2( j, 1 ), ldvt2 ) + call stdlib${ii}$_${ri}$copy( n, u( 1_${ik}$, idxj ), 1_${ik}$, u2( 1_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$copy( m, vt( idxj, 1_${ik}$ ), ldvt, vt2( j, 1_${ik}$ ), ldvt2 ) end do ! determine dsigma(1), dsigma(2) and z(1) - 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_${ri}$lapy2( z1, z( m ) ) - if( z( 1 )<=tol ) then + z( 1_${ik}$ ) = stdlib${ii}$_${ri}$lapy2( 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 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 ! move the rest of the updating row to z. - call stdlib_${ri}$copy( k-1, u2( 2, 1 ), 1, z( 2 ), 1 ) + call stdlib${ii}$_${ri}$copy( k-1, u2( 2_${ik}$, 1_${ik}$ ), 1_${ik}$, z( 2_${ik}$ ), 1_${ik}$ ) ! determine the first column of u2, the first row of vt2 and the ! last row of vt. - call stdlib_${ri}$laset( 'A', n, 1, zero, zero, u2, ldu2 ) - u2( nlp1, 1 ) = one + call stdlib${ii}$_${ri}$laset( 'A', n, 1_${ik}$, zero, zero, u2, ldu2 ) + u2( nlp1, 1_${ik}$ ) = one if( m>n ) then do i = 1, nlp1 vt( m, i ) = -s*vt( nlp1, i ) - vt2( 1, i ) = c*vt( nlp1, i ) + vt2( 1_${ik}$, i ) = c*vt( nlp1, i ) end do do i = nlp2, m - vt2( 1, i ) = s*vt( m, i ) + vt2( 1_${ik}$, i ) = s*vt( m, i ) vt( m, i ) = c*vt( m, i ) end do else - call stdlib_${ri}$copy( m, vt( nlp1, 1 ), ldvt, vt2( 1, 1 ), ldvt2 ) + call stdlib${ii}$_${ri}$copy( m, vt( nlp1, 1_${ik}$ ), ldvt, vt2( 1_${ik}$, 1_${ik}$ ), ldvt2 ) end if if( m>n ) then - call stdlib_${ri}$copy( m, vt( m, 1 ), ldvt, vt2( m, 1 ), ldvt2 ) + call stdlib${ii}$_${ri}$copy( m, vt( m, 1_${ik}$ ), ldvt, vt2( m, 1_${ik}$ ), ldvt2 ) end if ! the deflated singular values and their corresponding vectors go ! into the back of d, u, and v respectively. if( n>k ) then - call stdlib_${ri}$copy( n-k, dsigma( k+1 ), 1, d( k+1 ), 1 ) - call stdlib_${ri}$lacpy( 'A', n, n-k, u2( 1, k+1 ), ldu2, u( 1, k+1 ),ldu ) - call stdlib_${ri}$lacpy( 'A', n-k, m, vt2( k+1, 1 ), ldvt2, vt( k+1, 1 ),ldvt ) + call stdlib${ii}$_${ri}$copy( n-k, dsigma( k+1 ), 1_${ik}$, d( k+1 ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$lacpy( 'A', n, n-k, u2( 1_${ik}$, k+1 ), ldu2, u( 1_${ik}$, k+1 ),ldu ) + call stdlib${ii}$_${ri}$lacpy( 'A', n-k, m, vt2( k+1, 1_${ik}$ ), ldvt2, vt( k+1, 1_${ik}$ ),ldvt ) end if - ! copy ctot into coltyp for referencing in stdlib_${ri}$lasd3. + ! copy ctot into coltyp for referencing in stdlib${ii}$_${ri}$lasd3. do j = 1, 4 coltyp( j ) = ctot( j ) end do return - end subroutine stdlib_${ri}$lasd2 + end subroutine stdlib${ii}$_${ri}$lasd2 - pure subroutine stdlib_${ri}$lasd3( nl, nr, sqre, k, d, q, ldq, dsigma, u, ldu, u2,ldu2, vt, ldvt,& + pure subroutine stdlib${ii}$_${ri}$lasd3( nl, nr, sqre, k, d, q, ldq, dsigma, u, ldu, u2,ldu2, vt, ldvt,& !! DLASD3: finds all the square roots of the roots of the secular !! equation, as defined by the values in D and Z. It makes the !! appropriate calls to DLASD4 and then updates the singular @@ -43602,60 +43594,60 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, ldq, ldu, ldu2, ldvt, ldvt2, nl, nr, sqre + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k, ldq, ldu, ldu2, ldvt, ldvt2, nl, nr, sqre ! Array Arguments - integer(ilp), intent(in) :: ctot(*), idxc(*) + integer(${ik}$), intent(in) :: ctot(*), idxc(*) real(${rk}$), intent(out) :: d(*), q(ldq,*), u(ldu,*), vt(ldvt,*) real(${rk}$), intent(inout) :: dsigma(*), vt2(ldvt2,*), z(*) real(${rk}$), intent(in) :: u2(ldu2,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: ctemp, i, j, jc, ktemp, m, n, nlp1, nlp2, nrp1 + integer(${ik}$) :: ctemp, i, j, jc, ktemp, m, n, nlp1, nlp2, nrp1 real(${rk}$) :: rho, temp ! Intrinsic Functions intrinsic :: abs,sign,sqrt ! Executable Statements ! test the input parameters. - info = 0 - if( nl<1 ) then - info = -1 - else if( nr<1 ) then - info = -2 - else if( ( sqre/=1 ) .and. ( sqre/=0 ) ) then - info = -3 - end if - n = nl + nr + 1 + info = 0_${ik}$ + if( nl<1_${ik}$ ) then + info = -1_${ik}$ + else if( nr<1_${ik}$ ) then + info = -2_${ik}$ + else if( ( sqre/=1_${ik}$ ) .and. ( sqre/=0_${ik}$ ) ) then + info = -3_${ik}$ + end if + n = nl + nr + 1_${ik}$ m = n + sqre - nlp1 = nl + 1 - nlp2 = nl + 2 - if( ( k<1 ) .or. ( k>n ) ) then - info = -4 + nlp1 = nl + 1_${ik}$ + nlp2 = nl + 2_${ik}$ + if( ( k<1_${ik}$ ) .or. ( k>n ) ) then + info = -4_${ik}$ else if( ldqzero ) then - call stdlib_${ri}$copy( n, u2( 1, 1 ), 1, u( 1, 1 ), 1 ) + if( k==1_${ik}$ ) then + d( 1_${ik}$ ) = abs( z( 1_${ik}$ ) ) + call stdlib${ii}$_${ri}$copy( m, vt2( 1_${ik}$, 1_${ik}$ ), ldvt2, vt( 1_${ik}$, 1_${ik}$ ), ldvt ) + if( z( 1_${ik}$ )>zero ) then + call stdlib${ii}$_${ri}$copy( n, u2( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, u( 1_${ik}$, 1_${ik}$ ), 1_${ik}$ ) else do i = 1, n - u( i, 1 ) = -u2( i, 1 ) + u( i, 1_${ik}$ ) = -u2( i, 1_${ik}$ ) end do end if return @@ -43677,20 +43669,20 @@ module stdlib_linalg_lapack_${ri}$ ! 2*dsigma(i) to prevent optimizing compilers from eliminating ! this code. do i = 1, k - dsigma( i ) = stdlib_${ri}$lamc3( dsigma( i ), dsigma( i ) ) - dsigma( i ) + dsigma( i ) = stdlib${ii}$_${ri}$lamc3( dsigma( i ), dsigma( i ) ) - dsigma( i ) end do ! keep a copy of z. - call stdlib_${ri}$copy( k, z, 1, q, 1 ) + call stdlib${ii}$_${ri}$copy( k, z, 1_${ik}$, q, 1_${ik}$ ) ! normalize z. - rho = stdlib_${ri}$nrm2( k, z, 1 ) - call stdlib_${ri}$lascl( 'G', 0, 0, rho, one, k, 1, z, k, info ) + rho = stdlib${ii}$_${ri}$nrm2( k, z, 1_${ik}$ ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, rho, one, k, 1_${ik}$, z, k, info ) rho = rho*rho ! find the new singular values. do j = 1, k - call stdlib_${ri}$lasd4( k, j, dsigma, z, u( 1, j ), rho, d( j ),vt( 1, j ), info ) + call stdlib${ii}$_${ri}$lasd4( k, j, dsigma, z, u( 1_${ik}$, j ), rho, d( j ),vt( 1_${ik}$, j ), info ) ! if the zero finder fails, report the convergence failure. - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if end do @@ -43705,89 +43697,89 @@ module stdlib_linalg_lapack_${ri}$ z( i ) = z( i )*( u( i, j )*vt( i, j ) /( dsigma( i )-dsigma( j+1 ) ) /( dsigma( & i )+dsigma( j+1 ) ) ) end do - z( i ) = sign( sqrt( abs( z( i ) ) ), q( i, 1 ) ) + z( i ) = sign( sqrt( abs( z( i ) ) ), q( i, 1_${ik}$ ) ) end do ! compute left singular vectors of the modified diagonal matrix, ! and store related information for the right singular vectors. do i = 1, k - vt( 1, i ) = z( 1 ) / u( 1, i ) / vt( 1, i ) - u( 1, i ) = negone + vt( 1_${ik}$, i ) = z( 1_${ik}$ ) / u( 1_${ik}$, i ) / vt( 1_${ik}$, i ) + u( 1_${ik}$, i ) = negone do j = 2, k vt( j, i ) = z( j ) / u( j, i ) / vt( j, i ) u( j, i ) = dsigma( j )*vt( j, i ) end do - temp = stdlib_${ri}$nrm2( k, u( 1, i ), 1 ) - q( 1, i ) = u( 1, i ) / temp + temp = stdlib${ii}$_${ri}$nrm2( k, u( 1_${ik}$, i ), 1_${ik}$ ) + q( 1_${ik}$, i ) = u( 1_${ik}$, i ) / temp do j = 2, k jc = idxc( j ) q( j, i ) = u( jc, i ) / temp end do end do ! update the left singular vector matrix. - if( k==2 ) then - call stdlib_${ri}$gemm( 'N', 'N', n, k, k, one, u2, ldu2, q, ldq, zero, u,ldu ) + if( k==2_${ik}$ ) then + call stdlib${ii}$_${ri}$gemm( 'N', 'N', n, k, k, one, u2, ldu2, q, ldq, zero, u,ldu ) go to 100 end if - if( ctot( 1 )>0 ) then - call stdlib_${ri}$gemm( 'N', 'N', nl, k, ctot( 1 ), one, u2( 1, 2 ), ldu2,q( 2, 1 ), ldq,& - zero, u( 1, 1 ), ldu ) - if( ctot( 3 )>0 ) then - ktemp = 2 + ctot( 1 ) + ctot( 2 ) - call stdlib_${ri}$gemm( 'N', 'N', nl, k, ctot( 3 ), one, u2( 1, ktemp ),ldu2, q( & - ktemp, 1 ), ldq, one, u( 1, 1 ), ldu ) - end if - else if( ctot( 3 )>0 ) then - ktemp = 2 + ctot( 1 ) + ctot( 2 ) - call stdlib_${ri}$gemm( 'N', 'N', nl, k, ctot( 3 ), one, u2( 1, ktemp ),ldu2, q( ktemp, & - 1 ), ldq, zero, u( 1, 1 ), ldu ) - else - call stdlib_${ri}$lacpy( 'F', nl, k, u2, ldu2, u, ldu ) - end if - call stdlib_${ri}$copy( k, q( 1, 1 ), ldq, u( nlp1, 1 ), ldu ) - ktemp = 2 + ctot( 1 ) - ctemp = ctot( 2 ) + ctot( 3 ) - call stdlib_${ri}$gemm( 'N', 'N', nr, k, ctemp, one, u2( nlp2, ktemp ), ldu2,q( ktemp, 1 ), & - ldq, zero, u( nlp2, 1 ), ldu ) + if( ctot( 1_${ik}$ )>0_${ik}$ ) then + call stdlib${ii}$_${ri}$gemm( 'N', 'N', nl, k, ctot( 1_${ik}$ ), one, u2( 1_${ik}$, 2_${ik}$ ), ldu2,q( 2_${ik}$, 1_${ik}$ ), ldq,& + zero, u( 1_${ik}$, 1_${ik}$ ), ldu ) + if( ctot( 3_${ik}$ )>0_${ik}$ ) then + ktemp = 2_${ik}$ + ctot( 1_${ik}$ ) + ctot( 2_${ik}$ ) + call stdlib${ii}$_${ri}$gemm( 'N', 'N', nl, k, ctot( 3_${ik}$ ), one, u2( 1_${ik}$, ktemp ),ldu2, q( & + ktemp, 1_${ik}$ ), ldq, one, u( 1_${ik}$, 1_${ik}$ ), ldu ) + end if + else if( ctot( 3_${ik}$ )>0_${ik}$ ) then + ktemp = 2_${ik}$ + ctot( 1_${ik}$ ) + ctot( 2_${ik}$ ) + call stdlib${ii}$_${ri}$gemm( 'N', 'N', nl, k, ctot( 3_${ik}$ ), one, u2( 1_${ik}$, ktemp ),ldu2, q( ktemp, & + 1_${ik}$ ), ldq, zero, u( 1_${ik}$, 1_${ik}$ ), ldu ) + else + call stdlib${ii}$_${ri}$lacpy( 'F', nl, k, u2, ldu2, u, ldu ) + end if + call stdlib${ii}$_${ri}$copy( k, q( 1_${ik}$, 1_${ik}$ ), ldq, u( nlp1, 1_${ik}$ ), ldu ) + ktemp = 2_${ik}$ + ctot( 1_${ik}$ ) + ctemp = ctot( 2_${ik}$ ) + ctot( 3_${ik}$ ) + call stdlib${ii}$_${ri}$gemm( 'N', 'N', nr, k, ctemp, one, u2( nlp2, ktemp ), ldu2,q( ktemp, 1_${ik}$ ), & + ldq, zero, u( nlp2, 1_${ik}$ ), ldu ) ! generate the right singular vectors. 100 continue do i = 1, k - temp = stdlib_${ri}$nrm2( k, vt( 1, i ), 1 ) - q( i, 1 ) = vt( 1, i ) / temp + temp = stdlib${ii}$_${ri}$nrm2( k, vt( 1_${ik}$, i ), 1_${ik}$ ) + q( i, 1_${ik}$ ) = vt( 1_${ik}$, i ) / temp do j = 2, k jc = idxc( j ) q( i, j ) = vt( jc, i ) / temp end do end do ! update the right singular vector matrix. - if( k==2 ) then - call stdlib_${ri}$gemm( 'N', 'N', k, m, k, one, q, ldq, vt2, ldvt2, zero,vt, ldvt ) + if( k==2_${ik}$ ) then + call stdlib${ii}$_${ri}$gemm( 'N', 'N', k, m, k, one, q, ldq, vt2, ldvt2, zero,vt, ldvt ) return end if - ktemp = 1 + ctot( 1 ) - call stdlib_${ri}$gemm( 'N', 'N', k, nlp1, ktemp, one, q( 1, 1 ), ldq,vt2( 1, 1 ), ldvt2, & - zero, vt( 1, 1 ), ldvt ) - ktemp = 2 + ctot( 1 ) + ctot( 2 ) - if( ktemp<=ldvt2 )call stdlib_${ri}$gemm( 'N', 'N', k, nlp1, ctot( 3 ), one, q( 1, ktemp ),& - ldq, vt2( ktemp, 1 ), ldvt2, one, vt( 1, 1 ),ldvt ) - ktemp = ctot( 1 ) + 1 + ktemp = 1_${ik}$ + ctot( 1_${ik}$ ) + call stdlib${ii}$_${ri}$gemm( 'N', 'N', k, nlp1, ktemp, one, q( 1_${ik}$, 1_${ik}$ ), ldq,vt2( 1_${ik}$, 1_${ik}$ ), ldvt2, & + zero, vt( 1_${ik}$, 1_${ik}$ ), ldvt ) + ktemp = 2_${ik}$ + ctot( 1_${ik}$ ) + ctot( 2_${ik}$ ) + if( ktemp<=ldvt2 )call stdlib${ii}$_${ri}$gemm( 'N', 'N', k, nlp1, ctot( 3_${ik}$ ), one, q( 1_${ik}$, ktemp ),& + ldq, vt2( ktemp, 1_${ik}$ ), ldvt2, one, vt( 1_${ik}$, 1_${ik}$ ),ldvt ) + ktemp = ctot( 1_${ik}$ ) + 1_${ik}$ nrp1 = nr + sqre - if( ktemp>1 ) then + if( ktemp>1_${ik}$ ) then do i = 1, k - q( i, ktemp ) = q( i, 1 ) + q( i, ktemp ) = q( i, 1_${ik}$ ) end do do i = nlp2, m - vt2( ktemp, i ) = vt2( 1, i ) + vt2( ktemp, i ) = vt2( 1_${ik}$, i ) end do end if - ctemp = 1 + ctot( 2 ) + ctot( 3 ) - call stdlib_${ri}$gemm( 'N', 'N', k, nrp1, ctemp, one, q( 1, ktemp ), ldq,vt2( ktemp, nlp2 )& - , ldvt2, zero, vt( 1, nlp2 ), ldvt ) + ctemp = 1_${ik}$ + ctot( 2_${ik}$ ) + ctot( 3_${ik}$ ) + call stdlib${ii}$_${ri}$gemm( 'N', 'N', k, nrp1, ctemp, one, q( 1_${ik}$, ktemp ), ldq,vt2( ktemp, nlp2 )& + , ldvt2, zero, vt( 1_${ik}$, nlp2 ), ldvt ) return - end subroutine stdlib_${ri}$lasd3 + end subroutine stdlib${ii}$_${ri}$lasd3 - pure subroutine stdlib_${ri}$lasd4( n, i, d, z, delta, rho, sigma, work, info ) + pure subroutine stdlib${ii}$_${ri}$lasd4( n, i, d, z, delta, rho, sigma, work, info ) !! This subroutine computes the square root of the I-th updated !! eigenvalue of a positive symmetric rank-one modification to !! a positive diagonal matrix whose entries are given as the squares @@ -43803,8 +43795,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: rho real(${rk}$), intent(out) :: sigma ! Array Arguments @@ -43812,44 +43804,44 @@ module stdlib_linalg_lapack_${ri}$ real(${rk}$), 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(${rk}$) :: a, b, c, delsq, delsq2, sq2, dphi, dpsi, dtiim, dtiip, dtipsq, dtisq, & dtnsq, dtnsq1, dw, eps, erretm, eta, phi, prew, psi, rhoinv, sglb, sgub, tau, tau2, & temp, temp1, temp2, w ! Local Arrays - real(${rk}$) :: dd(3), zz(3) + real(${rk}$) :: 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 + info = 0_${ik}$ + if( n==1_${ik}$ ) then ! presumably, i=1 upon entry - sigma = sqrt( d( 1 )*d( 1 )+rho*z( 1 )*z( 1 ) ) - delta( 1 ) = one - work( 1 ) = one + 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_${ri}$lasd5( i, d, z, delta, rho, sigma, work ) + if( n==2_${ik}$ ) then + call stdlib${ii}$_${ri}$lasd5( i, d, z, delta, rho, sigma, work ) return end if ! compute machine epsilon - eps = stdlib_${ri}$lamch( 'EPSILON' ) + eps = stdlib${ii}$_${ri}$lamch( '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 @@ -43932,7 +43924,7 @@ module stdlib_linalg_lapack_${ri}$ go to 240 end if ! calculate the new step - niter = niter + 1 + niter = niter + 1_${ik}$ dtnsq1 = work( n-1 )*delta( n-1 ) dtnsq = work( n )*delta( n ) c = w - dtnsq1*dpsi - dtnsq*dphi @@ -43981,7 +43973,7 @@ module stdlib_linalg_lapack_${ri}$ ! $ + 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 @@ -44034,13 +44026,13 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -44109,8 +44101,8 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -44140,7 +44132,7 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -44157,14 +44149,14 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -44192,11 +44184,11 @@ module stdlib_linalg_lapack_${ri}$ 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( dpsiabs( 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 @@ -44330,9 +44322,9 @@ module stdlib_linalg_lapack_${ri}$ 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 ) ) @@ -44370,19 +44362,19 @@ module stdlib_linalg_lapack_${ri}$ 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( dpsizero .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_${ri}$lasd4 + end subroutine stdlib${ii}$_${ri}$lasd4 - pure subroutine stdlib_${ri}$lasd5( i, d, z, delta, rho, dsigma, work ) + pure subroutine stdlib${ii}$_${ri}$lasd5( i, d, z, delta, rho, dsigma, work ) !! This subroutine computes the square root of the I-th eigenvalue !! of a positive symmetric rank-one modification of a 2-by-2 diagonal !! matrix @@ -44528,12 +44520,12 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(out) :: dsigma real(${rk}$), intent(in) :: rho ! Array Arguments - real(${rk}$), intent(in) :: d(2), z(2) - real(${rk}$), intent(out) :: delta(2), work(2) + real(${rk}$), intent(in) :: d(2_${ik}$), z(2_${ik}$) + real(${rk}$), intent(out) :: delta(2_${ik}$), work(2_${ik}$) ! ===================================================================== ! Local Scalars @@ -44541,29 +44533,29 @@ module stdlib_linalg_lapack_${ri}$ ! 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 ) 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 ) + 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 ) = -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 + 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 ) * d( 2 ) if( b>zero ) then tau = -two*c / ( b+sqrt( b*b+four*c ) ) @@ -44571,12 +44563,12 @@ module stdlib_linalg_lapack_${ri}$ 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 + 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 ) = -z( 1 ) / ( del+tau ) ! delta( 2 ) = -z( 2 ) / tau end if @@ -44585,8 +44577,8 @@ module stdlib_linalg_lapack_${ri}$ ! 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 + 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 ) * d( 2 ) if( b>zero ) then tau = ( b+sqrt( b*b+four*c ) ) / two @@ -44594,12 +44586,12 @@ module stdlib_linalg_lapack_${ri}$ 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 + 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 ) = -z( 1 ) / ( del+tau ) ! delta( 2 ) = -z( 2 ) / tau ! temp = sqrt( delta( 1 )*delta( 1 )+delta( 2 )*delta( 2 ) ) @@ -44607,10 +44599,10 @@ module stdlib_linalg_lapack_${ri}$ ! delta( 2 ) = delta( 2 ) / temp end if return - end subroutine stdlib_${ri}$lasd5 + end subroutine stdlib${ii}$_${ri}$lasd5 - pure subroutine stdlib_${ri}$lasd6( icompq, nl, nr, sqre, d, vf, vl, alpha, beta,idxq, perm, & + pure subroutine stdlib${ii}$_${ri}$lasd6( icompq, nl, nr, sqre, d, vf, vl, alpha, beta,idxq, perm, & !! DLASD6: computes the SVD of an updated upper bidiagonal matrix B !! obtained by merging two smaller ones by appending a row. This !! routine is used only for the problem which requires all singular @@ -44652,53 +44644,53 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(inout) :: alpha, beta real(${rk}$), intent(out) :: c, s ! Array Arguments - integer(ilp), intent(out) :: givcol(ldgcol,*), iwork(*), perm(*) - integer(ilp), intent(inout) :: idxq(*) + integer(${ik}$), intent(out) :: givcol(ldgcol,*), iwork(*), perm(*) + integer(${ik}$), intent(inout) :: idxq(*) real(${rk}$), intent(inout) :: d(*), vf(*), vl(*) real(${rk}$), intent(out) :: difl(*), difr(*), givnum(ldgnum,*), poles(ldgnum,*), work(*), & z(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, idx, idxc, idxp, isigma, ivfw, ivlw, iw, m, n, n1, n2 + integer(${ik}$) :: i, idx, idxc, idxp, isigma, ivfw, ivlw, iw, m, n, n1, n2 real(${rk}$) :: orgnrm ! 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( ldgcol1 ) ) 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. @@ -44882,34 +44874,34 @@ module stdlib_linalg_lapack_${ri}$ c = z( j ) ! find sqrt(a**2+b**2) without overflow or ! destructive underflow. - tau = stdlib_${ri}$lapy2( c, s ) + tau = stdlib${ii}$_${ri}$lapy2( 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_${ri}$rot( 1, vf( jprev ), 1, vf( j ), 1, c, s ) - call stdlib_${ri}$rot( 1, vl( jprev ), 1, vl( j ), 1, c, s ) - k2 = k2 - 1 + call stdlib${ii}$_${ri}$rot( 1_${ik}$, vf( jprev ), 1_${ik}$, vf( j ), 1_${ik}$, c, s ) + call stdlib${ii}$_${ri}$rot( 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 @@ -44919,7 +44911,7 @@ module stdlib_linalg_lapack_${ri}$ 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 @@ -44933,51 +44925,51 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$copy( n-k, dsigma( k+1 ), 1, d( k+1 ), 1 ) + call stdlib${ii}$_${ri}$copy( n-k, dsigma( k+1 ), 1_${ik}$, d( k+1 ), 1_${ik}$ ) ! determine dsigma(1), dsigma(2), z(1), vf(1), vl(1), 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_${ri}$lapy2( z1, z( m ) ) - if( z( 1 )<=tol ) then + z( 1_${ik}$ ) = stdlib${ii}$_${ri}$lapy2( 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_${ri}$rot( 1, vf( m ), 1, vf( 1 ), 1, c, s ) - call stdlib_${ri}$rot( 1, vl( m ), 1, vl( 1 ), 1, c, s ) + call stdlib${ii}$_${ri}$rot( 1_${ik}$, vf( m ), 1_${ik}$, vf( 1_${ik}$ ), 1_${ik}$, c, s ) + call stdlib${ii}$_${ri}$rot( 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_${ri}$copy( k-1, zw( 2 ), 1, z( 2 ), 1 ) - call stdlib_${ri}$copy( n-1, vfw( 2 ), 1, vf( 2 ), 1 ) - call stdlib_${ri}$copy( n-1, vlw( 2 ), 1, vl( 2 ), 1 ) + call stdlib${ii}$_${ri}$copy( k-1, zw( 2_${ik}$ ), 1_${ik}$, z( 2_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$copy( n-1, vfw( 2_${ik}$ ), 1_${ik}$, vf( 2_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$copy( n-1, vlw( 2_${ik}$ ), 1_${ik}$, vl( 2_${ik}$ ), 1_${ik}$ ) return - end subroutine stdlib_${ri}$lasd7 + end subroutine stdlib${ii}$_${ri}$lasd7 - pure subroutine stdlib_${ri}$lasd8( icompq, k, d, z, vf, vl, difl, difr, lddifr,dsigma, work, & + pure subroutine stdlib${ii}$_${ri}$lasd8( icompq, k, d, z, vf, vl, difl, difr, lddifr,dsigma, work, & !! DLASD8: finds the square roots of the roots of the secular equation, !! as defined by the values in DSIGMA and Z. It makes the appropriate !! calls to DLASD4, and stores, for each element in D, the distance @@ -44990,39 +44982,39 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(out) :: d(*), difl(*), difr(lddifr,*), work(*) real(${rk}$), intent(inout) :: dsigma(*), vf(*), vl(*), z(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, iwk1, iwk2, iwk2i, iwk3, iwk3i, j + integer(${ik}$) :: i, iwk1, iwk2, iwk2i, iwk3, iwk3i, j real(${rk}$) :: 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( lddifr1 ) ) then - info = -1 - else if( smlsiz<3 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ( sqre<0 ) .or. ( sqre>1 ) ) then - info = -4 + info = 0_${ik}$ + if( ( icompq<0_${ik}$ ) .or. ( icompq>1_${ik}$ ) ) then + info = -1_${ik}$ + else if( smlsiz<3_${ik}$ ) then + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( ( sqre<0_${ik}$ ) .or. ( sqre>1_${ik}$ ) ) then + info = -4_${ik}$ else if( ldu<( n+sqre ) ) then - info = -8 + info = -8_${ik}$ else if( ldgcol1 ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ncvt<0 ) then - info = -4 - else if( nru<0 ) then - info = -5 - else if( ncc<0 ) then - info = -6 - else if( ( ncvt==0 .and. ldvt<1 ) .or.( ncvt>0 .and. ldvt0 .and. ldc1_${ik}$ ) ) then + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( ncvt<0_${ik}$ ) then + info = -4_${ik}$ + else if( nru<0_${ik}$ ) then + info = -5_${ik}$ + else if( ncc<0_${ik}$ ) then + info = -6_${ik}$ + else if( ( ncvt==0_${ik}$ .and. ldvt<1_${ik}$ ) .or.( ncvt>0_${ik}$ .and. ldvt0_${ik}$ .and. ldc0 ) .or. ( nru>0 ) .or. ( ncc>0 ) - np1 = n + 1 + rotate = ( ncvt>0_${ik}$ ) .or. ( nru>0_${ik}$ ) .or. ( ncc>0_${ik}$ ) + np1 = n + 1_${ik}$ sqre1 = sqre ! if matrix non-square upper bidiagonal, rotate to be lower ! bidiagonal. the rotations are on the right. - if( ( iuplo==1 ) .and. ( sqre1==1 ) ) then + if( ( iuplo==1_${ik}$ ) .and. ( sqre1==1_${ik}$ ) ) then do i = 1, n - 1 - call stdlib_${ri}$lartg( d( i ), e( i ), cs, sn, r ) + call stdlib${ii}$_${ri}$lartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) @@ -45394,24 +45386,24 @@ module stdlib_linalg_lapack_${ri}$ work( n+i ) = sn end if end do - call stdlib_${ri}$lartg( d( n ), e( n ), cs, sn, r ) + call stdlib${ii}$_${ri}$lartg( d( n ), e( n ), cs, sn, r ) d( n ) = r e( n ) = zero if( rotate ) then work( n ) = cs work( n+n ) = sn end if - iuplo = 2 - sqre1 = 0 + iuplo = 2_${ik}$ + sqre1 = 0_${ik}$ ! update singular vectors if desired. - if( ncvt>0 )call stdlib_${ri}$lasr( 'L', 'V', 'F', np1, ncvt, work( 1 ),work( np1 ), vt, & + if( ncvt>0_${ik}$ )call stdlib${ii}$_${ri}$lasr( 'L', 'V', 'F', np1, ncvt, work( 1_${ik}$ ),work( np1 ), vt, & ldvt ) end if ! if matrix lower bidiagonal, rotate to be upper bidiagonal ! by applying givens rotations on the left. - if( iuplo==2 ) then + if( iuplo==2_${ik}$ ) then do i = 1, n - 1 - call stdlib_${ri}$lartg( d( i ), e( i ), cs, sn, r ) + call stdlib${ii}$_${ri}$lartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) @@ -45422,8 +45414,8 @@ module stdlib_linalg_lapack_${ri}$ end do ! if matrix (n+1)-by-n lower bidiagonal, one additional ! rotation is needed. - if( sqre1==1 ) then - call stdlib_${ri}$lartg( d( n ), e( n ), cs, sn, r ) + if( sqre1==1_${ik}$ ) then + call stdlib${ii}$_${ri}$lartg( d( n ), e( n ), cs, sn, r ) d( n ) = r if( rotate ) then work( n ) = cs @@ -45431,28 +45423,28 @@ module stdlib_linalg_lapack_${ri}$ end if end if ! update singular vectors if desired. - if( nru>0 ) then - if( sqre1==0 ) then - call stdlib_${ri}$lasr( 'R', 'V', 'F', nru, n, work( 1 ),work( np1 ), u, ldu ) + if( nru>0_${ik}$ ) then + if( sqre1==0_${ik}$ ) then + call stdlib${ii}$_${ri}$lasr( 'R', 'V', 'F', nru, n, work( 1_${ik}$ ),work( np1 ), u, ldu ) else - call stdlib_${ri}$lasr( 'R', 'V', 'F', nru, np1, work( 1 ),work( np1 ), u, ldu ) + call stdlib${ii}$_${ri}$lasr( 'R', 'V', 'F', nru, np1, work( 1_${ik}$ ),work( np1 ), u, ldu ) end if end if - if( ncc>0 ) then - if( sqre1==0 ) then - call stdlib_${ri}$lasr( 'L', 'V', 'F', n, ncc, work( 1 ),work( np1 ), c, ldc ) + if( ncc>0_${ik}$ ) then + if( sqre1==0_${ik}$ ) then + call stdlib${ii}$_${ri}$lasr( 'L', 'V', 'F', n, ncc, work( 1_${ik}$ ),work( np1 ), c, ldc ) else - call stdlib_${ri}$lasr( 'L', 'V', 'F', np1, ncc, work( 1 ),work( np1 ), c, ldc ) + call stdlib${ii}$_${ri}$lasr( 'L', 'V', 'F', np1, ncc, work( 1_${ik}$ ),work( np1 ), c, ldc ) end if end if end if - ! call stdlib_${ri}$bdsqr to compute the svd of the reduced real + ! call stdlib${ii}$_${ri}$bdsqr to compute the svd of the reduced real ! n-by-n upper bidiagonal matrix. - call stdlib_${ri}$bdsqr( 'U', n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c,ldc, work, info ) + call stdlib${ii}$_${ri}$bdsqr( 'U', n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c,ldc, work, info ) ! sort the singular values into ascending order (insertion sort on ! singular values, but only one transposition per singular vector) @@ -45470,68 +45462,68 @@ module stdlib_linalg_lapack_${ri}$ ! swap singular values and vectors. d( isub ) = d( i ) d( i ) = smin - if( ncvt>0 )call stdlib_${ri}$swap( ncvt, vt( isub, 1 ), ldvt, vt( i, 1 ), ldvt ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_${ri}$swap( ncvt, vt( isub, 1_${ik}$ ), ldvt, vt( i, 1_${ik}$ ), ldvt ) - if( nru>0 )call stdlib_${ri}$swap( nru, u( 1, isub ), 1, u( 1, i ), 1 ) - if( ncc>0 )call stdlib_${ri}$swap( ncc, c( isub, 1 ), ldc, c( i, 1 ), ldc ) + if( nru>0_${ik}$ )call stdlib${ii}$_${ri}$swap( nru, u( 1_${ik}$, isub ), 1_${ik}$, u( 1_${ik}$, i ), 1_${ik}$ ) + if( ncc>0_${ik}$ )call stdlib${ii}$_${ri}$swap( ncc, c( isub, 1_${ik}$ ), ldc, c( i, 1_${ik}$ ), ldc ) end if end do return - end subroutine stdlib_${ri}$lasdq + end subroutine stdlib${ii}$_${ri}$lasdq - pure subroutine stdlib_${ri}$lasdt( n, lvl, nd, inode, ndiml, ndimr, msub ) + pure subroutine stdlib${ii}$_${ri}$lasdt( n, lvl, nd, inode, ndiml, ndimr, msub ) !! DLASDT: 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(${rk}$) :: temp ! Intrinsic Functions intrinsic :: real,int,log,max ! Executable Statements ! find the number of levels on the tree. - maxn = max( 1, n ) + maxn = max( 1_${ik}$, n ) temp = log( real( maxn,KIND=${rk}$) / real( msub+1,KIND=${rk}$) ) / log( two ) - lvl = int( temp,KIND=ilp) + 1 - i = n / 2 - inode( 1 ) = i + 1 - 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_${ri}$lasdt + end subroutine stdlib${ii}$_${ri}$lasdt - pure subroutine stdlib_${ri}$laset( uplo, m, n, alpha, beta, a, lda ) + pure subroutine stdlib${ii}$_${ri}$laset( uplo, m, n, alpha, beta, a, lda ) !! DLASET: initializes an m-by-n matrix A to BETA on the diagonal and !! ALPHA on the offdiagonals. ! -- lapack auxiliary routine -- @@ -45539,13 +45531,13 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: alpha, beta ! Array Arguments real(${rk}$), intent(out) :: a(lda,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -45578,10 +45570,10 @@ module stdlib_linalg_lapack_${ri}$ a( i, i ) = beta end do return - end subroutine stdlib_${ri}$laset + end subroutine stdlib${ii}$_${ri}$laset - pure subroutine stdlib_${ri}$lasq1( n, d, e, work, info ) + pure subroutine stdlib${ii}$_${ri}$lasq1( n, d, e, work, info ) !! DLASQ1: computes the singular values of a real N-by-N bidiagonal !! matrix with diagonal D and off-diagonal E. The singular values !! are computed to high relative accuracy, in the absence of @@ -45596,33 +45588,33 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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 real(${rk}$), intent(inout) :: d(*), e(*) real(${rk}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, iinfo + integer(${ik}$) :: i, iinfo real(${rk}$) :: eps, scale, safmin, sigmn, sigmx ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements - info = 0 - if( n<0 ) then - info = -1 - call stdlib_xerbla( 'DLASQ1', -info ) + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -1_${ik}$ + call stdlib${ii}$_xerbla( 'DLASQ1', -info ) return - else if( n==0 ) then + else if( n==0_${ik}$ ) then return - else if( n==1 ) then - d( 1 ) = abs( d( 1 ) ) + else if( n==1_${ik}$ ) then + d( 1_${ik}$ ) = abs( d( 1_${ik}$ ) ) return - else if( n==2 ) then - call stdlib_${ri}$las2( d( 1 ), e( 1 ), d( 2 ), sigmn, sigmx ) - d( 1 ) = sigmx - d( 2 ) = sigmn + else if( n==2_${ik}$ ) then + call stdlib${ii}$_${ri}$las2( d( 1_${ik}$ ), e( 1_${ik}$ ), d( 2_${ik}$ ), sigmn, sigmx ) + d( 1_${ik}$ ) = sigmx + d( 2_${ik}$ ) = sigmn return end if ! estimate the largest singular value. @@ -45634,7 +45626,7 @@ module stdlib_linalg_lapack_${ri}$ d( n ) = abs( d( n ) ) ! early return if sigmx is zero (matrix is already diagonal). if( sigmx==zero ) then - call stdlib_${ri}$lasrt( 'D', n, d, iinfo ) + call stdlib${ii}$_${ri}$lasrt( 'D', n, d, iinfo ) return end if do i = 1, n @@ -45642,38 +45634,38 @@ module stdlib_linalg_lapack_${ri}$ end do ! copy d and e into work (in the z format) and scale (squaring the ! input data makes scaling by a power of the radix pointless). - eps = stdlib_${ri}$lamch( 'PRECISION' ) - safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_${ri}$lamch( 'PRECISION' ) + safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) scale = sqrt( eps / safmin ) - call stdlib_${ri}$copy( n, d, 1, work( 1 ), 2 ) - call stdlib_${ri}$copy( n-1, e, 1, work( 2 ), 2 ) - call stdlib_${ri}$lascl( 'G', 0, 0, sigmx, scale, 2*n-1, 1, work, 2*n-1,iinfo ) + call stdlib${ii}$_${ri}$copy( n, d, 1_${ik}$, work( 1_${ik}$ ), 2_${ik}$ ) + call stdlib${ii}$_${ri}$copy( n-1, e, 1_${ik}$, work( 2_${ik}$ ), 2_${ik}$ ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, sigmx, scale, 2_${ik}$*n-1, 1_${ik}$, work, 2_${ik}$*n-1,iinfo ) ! compute the q's and e's. do i = 1, 2*n - 1 - work( i ) = work( i )**2 + work( i ) = work( i )**2_${ik}$ end do - work( 2*n ) = zero - call stdlib_${ri}$lasq2( n, work, info ) - if( info==0 ) then + work( 2_${ik}$*n ) = zero + call stdlib${ii}$_${ri}$lasq2( n, work, info ) + if( info==0_${ik}$ ) then do i = 1, n d( i ) = sqrt( work( i ) ) end do - call stdlib_${ri}$lascl( 'G', 0, 0, scale, sigmx, n, 1, d, n, iinfo ) - else if( info==2 ) then + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, scale, sigmx, n, 1_${ik}$, d, n, iinfo ) + else if( info==2_${ik}$ ) then ! maximum number of iterations exceeded. move data from work ! into d and e so the calling subroutine can try to finish do i = 1, n - d( i ) = sqrt( work( 2*i-1 ) ) - e( i ) = sqrt( work( 2*i ) ) + d( i ) = sqrt( work( 2_${ik}$*i-1 ) ) + e( i ) = sqrt( work( 2_${ik}$*i ) ) end do - call stdlib_${ri}$lascl( 'G', 0, 0, scale, sigmx, n, 1, d, n, iinfo ) - call stdlib_${ri}$lascl( 'G', 0, 0, scale, sigmx, n, 1, e, n, iinfo ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, scale, sigmx, n, 1_${ik}$, d, n, iinfo ) + call stdlib${ii}$_${ri}$lascl( 'G', 0_${ik}$, 0_${ik}$, scale, sigmx, n, 1_${ik}$, e, n, iinfo ) end if return - end subroutine stdlib_${ri}$lasq1 + end subroutine stdlib${ii}$_${ri}$lasq1 - pure subroutine stdlib_${ri}$lasq2( n, z, info ) + pure subroutine stdlib${ii}$_${ri}$lasq2( n, z, info ) !! DLASQ2: computes all the eigenvalues of the symmetric positive !! definite tridiagonal matrix associated with the qd array Z to high !! relative accuracy are computed to high relative accuracy, in the @@ -45691,8 +45683,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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 real(${rk}$), intent(inout) :: z(*) ! ===================================================================== @@ -45703,7 +45695,7 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: ieee - integer(ilp) :: i0, i1, i4, iinfo, ipn4, iter, iwhila, iwhilb, k, kmin, n0, n1, nbig, & + integer(${ik}$) :: i0, i1, i4, iinfo, ipn4, iter, iwhila, iwhilb, k, kmin, n0, n1, nbig, & ndiv, nfail, pp, splt, ttype real(${rk}$) :: d, dee, deemin, desig, dmin, dmin1, dmin2, dn, dn1, dn2, e, emax, emin, & eps, g, oldemn, qmax, qmin, s, safmin, sigma, t, tau, temp, tol, tol2, trace, zmax, & @@ -45712,76 +45704,76 @@ module stdlib_linalg_lapack_${ri}$ intrinsic :: abs,real,max,min,sqrt ! Executable Statements ! test the input arguments. - ! (in case stdlib_${ri}$lasq2 is not called by stdlib_${ri}$lasq1) - info = 0 - eps = stdlib_${ri}$lamch( 'PRECISION' ) - safmin = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) + ! (in case stdlib${ii}$_${ri}$lasq2 is not called by stdlib${ii}$_${ri}$lasq1) + info = 0_${ik}$ + eps = stdlib${ii}$_${ri}$lamch( 'PRECISION' ) + safmin = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) tol = eps*hundrd - tol2 = tol**2 - if( n<0 ) then - info = -1 - call stdlib_xerbla( 'DLASQ2', 1 ) + tol2 = tol**2_${ik}$ + if( n<0_${ik}$ ) then + info = -1_${ik}$ + call stdlib${ii}$_xerbla( 'DLASQ2', 1_${ik}$ ) return - else if( n==0 ) then + else if( n==0_${ik}$ ) then return - else if( n==1 ) then + else if( n==1_${ik}$ ) then ! 1-by-1 case. - if( z( 1 )z( 1 ) ) then - d = z( 3 ) - z( 3 ) = z( 1 ) - z( 1 ) = d - end if - z( 5 ) = z( 1 ) + z( 2 ) + z( 3 ) - if( z( 2 )>z( 3 )*tol2 ) then - t = half*( ( z( 1 )-z( 3 ) )+z( 2 ) ) - s = z( 3 )*( z( 2 ) / t ) + else if( z( 3_${ik}$ )>z( 1_${ik}$ ) ) then + d = z( 3_${ik}$ ) + z( 3_${ik}$ ) = z( 1_${ik}$ ) + z( 1_${ik}$ ) = d + end if + z( 5_${ik}$ ) = z( 1_${ik}$ ) + z( 2_${ik}$ ) + z( 3_${ik}$ ) + if( z( 2_${ik}$ )>z( 3_${ik}$ )*tol2 ) then + t = half*( ( z( 1_${ik}$ )-z( 3_${ik}$ ) )+z( 2_${ik}$ ) ) + s = z( 3_${ik}$ )*( z( 2_${ik}$ ) / t ) if( s<=t ) then - s = z( 3 )*( z( 2 ) / ( t*( one+sqrt( one+s / t ) ) ) ) + s = z( 3_${ik}$ )*( z( 2_${ik}$ ) / ( t*( one+sqrt( one+s / t ) ) ) ) else - s = z( 3 )*( z( 2 ) / ( t+sqrt( t )*sqrt( t+s ) ) ) + s = z( 3_${ik}$ )*( z( 2_${ik}$ ) / ( t+sqrt( t )*sqrt( t+s ) ) ) end if - t = z( 1 ) + ( s+z( 2 ) ) - z( 3 ) = z( 3 )*( z( 1 ) / t ) - z( 1 ) = t + t = z( 1_${ik}$ ) + ( s+z( 2_${ik}$ ) ) + z( 3_${ik}$ ) = z( 3_${ik}$ )*( z( 1_${ik}$ ) / t ) + z( 1_${ik}$ ) = t end if - z( 2 ) = z( 3 ) - z( 6 ) = z( 2 ) + z( 1 ) + z( 2_${ik}$ ) = z( 3_${ik}$ ) + z( 6_${ik}$ ) = z( 2_${ik}$ ) + z( 1_${ik}$ ) return end if ! check for negative data and compute sums of q's and e's. - z( 2*n ) = zero - emin = z( 2 ) + z( 2_${ik}$*n ) = zero + emin = z( 2_${ik}$ ) qmax = zero zmax = zero d = zero e = zero do k = 1, 2*( n-1 ), 2 if( z( k )i0 ) then - emin = abs( z( 4*n0-5 ) ) + emin = abs( z( 4_${ik}$*n0-5 ) ) else emin = zero end if - qmin = z( 4*n0-3 ) + qmin = z( 4_${ik}$*n0-3 ) qmax = qmin do i4 = 4*n0, 8, -4 if( z( i4-5 )<=zero )go to 100 @@ -45924,24 +45916,24 @@ module stdlib_linalg_lapack_${ri}$ qmax = max( qmax, z( i4-7 )+z( i4-5 ) ) emin = min( emin, z( i4-5 ) ) end do - i4 = 4 + i4 = 4_${ik}$ 100 continue - i0 = i4 / 4 - pp = 0 - if( n0-i0>1 ) then - dee = z( 4*i0-3 ) + i0 = i4 / 4_${ik}$ + pp = 0_${ik}$ + if( n0-i0>1_${ik}$ ) then + dee = z( 4_${ik}$*i0-3 ) deemin = dee kmin = i0 do i4 = 4*i0+1, 4*n0-3, 4 dee = z( i4 )*( dee /( dee+z( i4-2 ) ) ) if( dee<=deemin ) then deemin = dee - kmin = ( i4+3 )/4 + kmin = ( i4+3 )/4_${ik}$ end if end do - if( (kmin-i0)*2n0 )go to 150 ! while submatrix unfinished take a good dqds step. - call stdlib_${ri}$lasq3( i0, n0, z, pp, dmin, sigma, desig, qmax, nfail,iter, ndiv, & + call stdlib${ii}$_${ri}$lasq3( i0, n0, z, pp, dmin, sigma, desig, qmax, nfail,iter, ndiv, & ieee, ttype, dmin1, dmin2, dn, dn1,dn2, g, tau ) - pp = 1 - pp + pp = 1_${ik}$ - pp ! when emin is very small check for splits. - if( pp==0 .and. n0-i0>=3 ) then - if( z( 4*n0 )<=tol2*qmax .or.z( 4*n0-1 )<=tol2*sigma ) then - splt = i0 - 1 - qmax = z( 4*i0-3 ) - emin = z( 4*i0-1 ) - oldemn = z( 4*i0 ) + if( pp==0_${ik}$ .and. n0-i0>=3_${ik}$ ) then + if( z( 4_${ik}$*n0 )<=tol2*qmax .or.z( 4_${ik}$*n0-1 )<=tol2*sigma ) then + splt = i0 - 1_${ik}$ + qmax = z( 4_${ik}$*i0-3 ) + emin = z( 4_${ik}$*i0-1 ) + oldemn = z( 4_${ik}$*i0 ) do i4 = 4*i0, 4*( n0-3 ), 4 if( z( i4 )<=tol2*z( i4-3 ) .or.z( i4-1 )<=tol2*sigma ) then z( i4-1 ) = -sigma - splt = i4 / 4 + splt = i4 / 4_${ik}$ qmax = zero emin = z( i4+3 ) oldemn = z( i4+4 ) @@ -45992,76 +45984,76 @@ module stdlib_linalg_lapack_${ri}$ oldemn = min( oldemn, z( i4 ) ) end if end do - z( 4*n0-1 ) = emin - z( 4*n0 ) = oldemn - i0 = splt + 1 + z( 4_${ik}$*n0-1 ) = emin + z( 4_${ik}$*n0 ) = oldemn + i0 = splt + 1_${ik}$ end if end if end do loop_140 - info = 2 + info = 2_${ik}$ ! maximum number of iterations exceeded, restore the shift ! sigma and place the new d's and e's in a qd array. ! this might need to be done for several blocks i1 = i0 n1 = n0 145 continue - tempq = z( 4*i0-3 ) - z( 4*i0-3 ) = z( 4*i0-3 ) + sigma + tempq = z( 4_${ik}$*i0-3 ) + z( 4_${ik}$*i0-3 ) = z( 4_${ik}$*i0-3 ) + sigma do k = i0+1, n0 - tempe = z( 4*k-5 ) - z( 4*k-5 ) = z( 4*k-5 ) * (tempq / z( 4*k-7 )) - tempq = z( 4*k-3 ) - z( 4*k-3 ) = z( 4*k-3 ) + sigma + tempe - z( 4*k-5 ) + tempe = z( 4_${ik}$*k-5 ) + z( 4_${ik}$*k-5 ) = z( 4_${ik}$*k-5 ) * (tempq / z( 4_${ik}$*k-7 )) + tempq = z( 4_${ik}$*k-3 ) + z( 4_${ik}$*k-3 ) = z( 4_${ik}$*k-3 ) + sigma + tempe - z( 4_${ik}$*k-5 ) end do ! prepare to do this on the previous block if there is one - if( i1>1 ) then + if( i1>1_${ik}$ ) then n1 = i1-1 do while( ( i1>=2 ) .and. ( z(4*i1-5)>=zero ) ) - i1 = i1 - 1 + i1 = i1 - 1_${ik}$ end do - sigma = -z(4*n1-1) + sigma = -z(4_${ik}$*n1-1) go to 145 end if do k = 1, n - z( 2*k-1 ) = z( 4*k-3 ) + z( 2_${ik}$*k-1 ) = z( 4_${ik}$*k-3 ) ! only the block 1..n0 is unfinished. the rest of the e's ! must be essentially zero, although sometimes other data ! has been stored in them. if( ktol2*( sigma+z( nn-3 ) ) .and.z( nn-2*pp-4 )>tol2*z( nn-7 ) )go to & - 30 + 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. 30 continue @@ -46129,16 +46120,16 @@ module stdlib_linalg_lapack_${ri}$ 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_${ri}$lasq5( i0, n0, z, pp, tau, sigma, dmin, dmin1, dmin2, dn,dn1, dn2, ieee, & + call stdlib${ii}$_${ri}$lasq5( 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 )

0 )info = ierr - call stdlib_${ri}$gesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) + call stdlib${ii}$_${ri}$getc2( zdim, z, ldz, ipiv, jpiv, ierr ) + if( ierr>0_${ik}$ )info = ierr + call stdlib${ii}$_${ri}$gesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_${ri}$scal( m, scaloc, c( 1, k ), 1 ) - call stdlib_${ri}$scal( m, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( m, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do scale = scale*scaloc end if ! unpack solution vector(s) - c( is, js ) = rhs( 1 ) - c( is, jsp1 ) = rhs( 2 ) - f( is, js ) = rhs( 3 ) - f( is, jsp1 ) = rhs( 4 ) + c( is, js ) = rhs( 1_${ik}$ ) + c( is, jsp1 ) = rhs( 2_${ik}$ ) + f( is, js ) = rhs( 3_${ik}$ ) + f( is, jsp1 ) = rhs( 4_${ik}$ ) ! substitute r(i, j) and l(i, j) into remaining ! equation. if( j>p+2 ) then - call stdlib_${ri}$axpy( js-1, rhs( 1 ), b( 1, js ), 1,f( is, 1 ), ldf ) + call stdlib${ii}$_${ri}$axpy( js-1, rhs( 1_${ik}$ ), b( 1_${ik}$, js ), 1_${ik}$,f( is, 1_${ik}$ ), ldf ) - call stdlib_${ri}$axpy( js-1, rhs( 2 ), b( 1, jsp1 ), 1,f( is, 1 ), ldf ) + call stdlib${ii}$_${ri}$axpy( js-1, rhs( 2_${ik}$ ), b( 1_${ik}$, jsp1 ), 1_${ik}$,f( is, 1_${ik}$ ), ldf ) - call stdlib_${ri}$axpy( js-1, rhs( 3 ), e( 1, js ), 1,f( is, 1 ), ldf ) + call stdlib${ii}$_${ri}$axpy( js-1, rhs( 3_${ik}$ ), e( 1_${ik}$, js ), 1_${ik}$,f( is, 1_${ik}$ ), ldf ) - call stdlib_${ri}$axpy( js-1, rhs( 4 ), e( 1, jsp1 ), 1,f( is, 1 ), ldf ) + call stdlib${ii}$_${ri}$axpy( js-1, rhs( 4_${ik}$ ), e( 1_${ik}$, jsp1 ), 1_${ik}$,f( is, 1_${ik}$ ), ldf ) end if if( i

0 )info = ierr - call stdlib_${ri}$gesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) + call stdlib${ii}$_${ri}$getc2( zdim, z, ldz, ipiv, jpiv, ierr ) + if( ierr>0_${ik}$ )info = ierr + call stdlib${ii}$_${ri}$gesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_${ri}$scal( m, scaloc, c( 1, k ), 1 ) - call stdlib_${ri}$scal( m, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( m, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do scale = scale*scaloc end if ! unpack solution vector(s) - c( is, js ) = rhs( 1 ) - c( isp1, js ) = rhs( 2 ) - f( is, js ) = rhs( 3 ) - f( isp1, js ) = rhs( 4 ) + c( is, js ) = rhs( 1_${ik}$ ) + c( isp1, js ) = rhs( 2_${ik}$ ) + f( is, js ) = rhs( 3_${ik}$ ) + f( isp1, js ) = rhs( 4_${ik}$ ) ! substitute r(i, j) and l(i, j) into remaining ! equation. if( j>p+2 ) then - call stdlib_${ri}$ger( mb, js-1, one, rhs( 1 ), 1, b( 1, js ),1, f( is, 1 ), & + call stdlib${ii}$_${ri}$ger( mb, js-1, one, rhs( 1_${ik}$ ), 1_${ik}$, b( 1_${ik}$, js ),1_${ik}$, f( is, 1_${ik}$ ), & ldf ) - call stdlib_${ri}$ger( mb, js-1, one, rhs( 3 ), 1, e( 1, js ),1, f( is, 1 ), & + call stdlib${ii}$_${ri}$ger( mb, js-1, one, rhs( 3_${ik}$ ), 1_${ik}$, e( 1_${ik}$, js ),1_${ik}$, f( is, 1_${ik}$ ), & ldf ) end if if( i

0 )info = ierr - call stdlib_${ri}$gesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) + call stdlib${ii}$_${ri}$getc2( zdim, z, ldz, ipiv, jpiv, ierr ) + if( ierr>0_${ik}$ )info = ierr + call stdlib${ii}$_${ri}$gesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_${ri}$scal( m, scaloc, c( 1, k ), 1 ) - call stdlib_${ri}$scal( m, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( m, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do scale = scale*scaloc end if ! unpack solution vector(s) - k = 1 - ii = mb*nb + 1 + k = 1_${ik}$ + ii = mb*nb + 1_${ik}$ do jj = 0, nb - 1 - call stdlib_${ri}$copy( mb, rhs( k ), 1, c( is, js+jj ), 1 ) - call stdlib_${ri}$copy( mb, rhs( ii ), 1, f( is, js+jj ), 1 ) + call stdlib${ii}$_${ri}$copy( mb, rhs( k ), 1_${ik}$, c( is, js+jj ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$copy( mb, rhs( ii ), 1_${ik}$, f( is, js+jj ), 1_${ik}$ ) k = k + mb ii = ii + mb end do ! substitute r(i, j) and l(i, j) into remaining ! equation. if( j>p+2 ) then - call stdlib_${ri}$gemm( 'N', 'T', mb, js-1, nb, one,c( is, js ), ldc, b( 1, & - js ), ldb, one,f( is, 1 ), ldf ) - call stdlib_${ri}$gemm( 'N', 'T', mb, js-1, nb, one,f( is, js ), ldf, e( 1, & - js ), lde, one,f( is, 1 ), ldf ) + call stdlib${ii}$_${ri}$gemm( 'N', 'T', mb, js-1, nb, one,c( is, js ), ldc, b( 1_${ik}$, & + js ), ldb, one,f( is, 1_${ik}$ ), ldf ) + call stdlib${ii}$_${ri}$gemm( 'N', 'T', mb, js-1, nb, one,f( is, js ), ldf, e( 1_${ik}$, & + js ), lde, one,f( is, 1_${ik}$ ), ldf ) end if if( i

4 ) ) then - info = -2 - end if - end if - if( info==0 ) then - if( m<=0 ) then - info = -3 - else if( n<=0 ) then - info = -4 - else if( lda4_${ik}$ ) ) then + info = -2_${ik}$ + end if + end if + if( info==0_${ik}$ ) then + if( m<=0_${ik}$ ) then + info = -3_${ik}$ + else if( n<=0_${ik}$ ) then + info = -4_${ik}$ + else if( lda=3 ) then - ifunc = ijob - 2 - call stdlib_${ri}$laset( 'F', m, n, zero, zero, c, ldc ) - call stdlib_${ri}$laset( 'F', m, n, zero, zero, f, ldf ) - else if( ijob>=1 ) then - isolve = 2 + if( ijob>=3_${ik}$ ) then + ifunc = ijob - 2_${ik}$ + call stdlib${ii}$_${ri}$laset( 'F', m, n, zero, zero, c, ldc ) + call stdlib${ii}$_${ri}$laset( 'F', m, n, zero, zero, f, ldf ) + else if( ijob>=1_${ik}$ ) then + isolve = 2_${ik}$ end if end if - if( ( mb<=1 .and. nb<=1 ) .or. ( mb>=m .and. nb>=n ) )then + if( ( mb<=1_${ik}$ .and. nb<=1_${ik}$ ) .or. ( mb>=m .and. nb>=n ) )then loop_30: do iround = 1, isolve ! use unblocked level 2 solver dscale = zero dsum = one - pq = 0 - call stdlib_${ri}$tgsy2( trans, ifunc, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f,& + pq = 0_${ik}$ + call stdlib${ii}$_${ri}$tgsy2( trans, ifunc, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f,& ldf, scale, dsum, dscale,iwork, pq, info ) if( dscale/=zero ) then - if( ijob==1 .or. ijob==3 ) then - dif = sqrt( real( 2*m*n,KIND=${rk}$) ) / ( dscale*sqrt( dsum ) ) + if( ijob==1_${ik}$ .or. ijob==3_${ik}$ ) then + dif = sqrt( real( 2_${ik}$*m*n,KIND=${rk}$) ) / ( dscale*sqrt( dsum ) ) else dif = sqrt( real( pq,KIND=${rk}$) ) / ( dscale*sqrt( dsum ) ) end if end if - if( isolve==2 .and. iround==1 ) then + if( isolve==2_${ik}$ .and. iround==1_${ik}$ ) then if( notran ) then ifunc = ijob end if scale2 = scale - call stdlib_${ri}$lacpy( 'F', m, n, c, ldc, work, m ) - call stdlib_${ri}$lacpy( 'F', m, n, f, ldf, work( m*n+1 ), m ) - call stdlib_${ri}$laset( 'F', m, n, zero, zero, c, ldc ) - call stdlib_${ri}$laset( 'F', m, n, zero, zero, f, ldf ) - else if( isolve==2 .and. iround==2 ) then - call stdlib_${ri}$lacpy( 'F', m, n, work, m, c, ldc ) - call stdlib_${ri}$lacpy( 'F', m, n, work( m*n+1 ), m, f, ldf ) + call stdlib${ii}$_${ri}$lacpy( 'F', m, n, c, ldc, work, m ) + call stdlib${ii}$_${ri}$lacpy( 'F', m, n, f, ldf, work( m*n+1 ), m ) + call stdlib${ii}$_${ri}$laset( 'F', m, n, zero, zero, c, ldc ) + call stdlib${ii}$_${ri}$laset( 'F', m, n, zero, zero, f, ldf ) + else if( isolve==2_${ik}$ .and. iround==2_${ik}$ ) then + call stdlib${ii}$_${ri}$lacpy( 'F', m, n, work, m, c, ldc ) + call stdlib${ii}$_${ri}$lacpy( 'F', m, n, work( m*n+1 ), m, f, ldf ) scale = scale2 end if end do loop_30 return end if ! determine block structure of a - p = 0 - i = 1 + p = 0_${ik}$ + i = 1_${ik}$ 40 continue if( i>m )go to 50 - p = p + 1 + p = p + 1_${ik}$ iwork( p ) = i i = i + mb if( i>=m )go to 50 - if( a( i, i-1 )/=zero )i = i + 1 + if( a( i, i-1 )/=zero )i = i + 1_${ik}$ go to 40 50 continue - iwork( p+1 ) = m + 1 - if( iwork( p )==iwork( p+1 ) )p = p - 1 + iwork( p+1 ) = m + 1_${ik}$ + if( iwork( p )==iwork( p+1 ) )p = p - 1_${ik}$ ! determine block structure of b - q = p + 1 - j = 1 + q = p + 1_${ik}$ + j = 1_${ik}$ 60 continue if( j>n )go to 70 - q = q + 1 + q = q + 1_${ik}$ iwork( q ) = j j = j + nb if( j>=n )go to 70 - if( b( j, j-1 )/=zero )j = j + 1 + if( b( j, j-1 )/=zero )j = j + 1_${ik}$ go to 60 70 continue - iwork( q+1 ) = n + 1 - if( iwork( q )==iwork( q+1 ) )q = q - 1 + iwork( q+1 ) = n + 1_${ik}$ + if( iwork( q )==iwork( q+1 ) )q = q - 1_${ik}$ if( notran ) then loop_150: do iround = 1, isolve ! solve (i, j)-subsystem @@ -79600,76 +79591,76 @@ module stdlib_linalg_lapack_${ri}$ ! for i = p, p - 1,..., 1; j = 1, 2,..., q dscale = zero dsum = one - pq = 0 + pq = 0_${ik}$ scale = one loop_130: do j = p + 2, q js = iwork( j ) - je = iwork( j+1 ) - 1 - nb = je - js + 1 + je = iwork( j+1 ) - 1_${ik}$ + nb = je - js + 1_${ik}$ loop_120: do i = p, 1, -1 is = iwork( i ) - ie = iwork( i+1 ) - 1 - mb = ie - is + 1 - ppqq = 0 - call stdlib_${ri}$tgsy2( trans, ifunc, mb, nb, a( is, is ), lda,b( js, js ), & + ie = iwork( i+1 ) - 1_${ik}$ + mb = ie - is + 1_${ik}$ + ppqq = 0_${ik}$ + call stdlib${ii}$_${ri}$tgsy2( trans, ifunc, mb, nb, a( is, is ), lda,b( js, js ), & ldb, c( is, js ), ldc,d( is, is ), ldd, e( js, js ), lde,f( is, js ), ldf, & scaloc, dsum, dscale,iwork( q+2 ), ppqq, linfo ) - if( linfo>0 )info = linfo + if( linfo>0_${ik}$ )info = linfo pq = pq + ppqq if( scaloc/=one ) then do k = 1, js - 1 - call stdlib_${ri}$scal( m, scaloc, c( 1, k ), 1 ) - call stdlib_${ri}$scal( m, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( m, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do do k = js, je - call stdlib_${ri}$scal( is-1, scaloc, c( 1, k ), 1 ) - call stdlib_${ri}$scal( is-1, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_${ri}$scal( is-1, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( is-1, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do do k = js, je - call stdlib_${ri}$scal( m-ie, scaloc, c( ie+1, k ), 1 ) - call stdlib_${ri}$scal( m-ie, scaloc, f( ie+1, k ), 1 ) + call stdlib${ii}$_${ri}$scal( m-ie, scaloc, c( ie+1, k ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( m-ie, scaloc, f( ie+1, k ), 1_${ik}$ ) end do do k = je + 1, n - call stdlib_${ri}$scal( m, scaloc, c( 1, k ), 1 ) - call stdlib_${ri}$scal( m, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( m, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do scale = scale*scaloc end if ! substitute r(i, j) and l(i, j) into remaining ! equation. - if( i>1 ) then - call stdlib_${ri}$gemm( 'N', 'N', is-1, nb, mb, -one,a( 1, is ), lda, c( is, & - js ), ldc, one,c( 1, js ), ldc ) - call stdlib_${ri}$gemm( 'N', 'N', is-1, nb, mb, -one,d( 1, is ), ldd, c( is, & - js ), ldc, one,f( 1, js ), ldf ) + if( i>1_${ik}$ ) then + call stdlib${ii}$_${ri}$gemm( 'N', 'N', is-1, nb, mb, -one,a( 1_${ik}$, is ), lda, c( is, & + js ), ldc, one,c( 1_${ik}$, js ), ldc ) + call stdlib${ii}$_${ri}$gemm( 'N', 'N', is-1, nb, mb, -one,d( 1_${ik}$, is ), ldd, c( is, & + js ), ldc, one,f( 1_${ik}$, js ), ldf ) end if if( j0 )info = linfo + if( linfo>0_${ik}$ )info = linfo if( scaloc/=one ) then do k = 1, js - 1 - call stdlib_${ri}$scal( m, scaloc, c( 1, k ), 1 ) - call stdlib_${ri}$scal( m, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( m, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do do k = js, je - call stdlib_${ri}$scal( is-1, scaloc, c( 1, k ), 1 ) - call stdlib_${ri}$scal( is-1, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_${ri}$scal( is-1, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( is-1, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do do k = js, je - call stdlib_${ri}$scal( m-ie, scaloc, c( ie+1, k ), 1 ) - call stdlib_${ri}$scal( m-ie, scaloc, f( ie+1, k ), 1 ) + call stdlib${ii}$_${ri}$scal( m-ie, scaloc, c( ie+1, k ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( m-ie, scaloc, f( ie+1, k ), 1_${ik}$ ) end do do k = je + 1, n - call stdlib_${ri}$scal( m, scaloc, c( 1, k ), 1 ) - call stdlib_${ri}$scal( m, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( m, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do scale = scale*scaloc end if ! substitute r(i, j) and l(i, j) into remaining equation. if( j>p+2 ) then - call stdlib_${ri}$gemm( 'N', 'T', mb, js-1, nb, one, c( is, js ),ldc, b( 1, js )& - , ldb, one, f( is, 1 ),ldf ) - call stdlib_${ri}$gemm( 'N', 'T', mb, js-1, nb, one, f( is, js ),ldf, e( 1, js )& - , lde, one, f( is, 1 ),ldf ) + call stdlib${ii}$_${ri}$gemm( 'N', 'T', mb, js-1, nb, one, c( is, js ),ldc, b( 1_${ik}$, js )& + , ldb, one, f( is, 1_${ik}$ ),ldf ) + call stdlib${ii}$_${ri}$gemm( 'N', 'T', mb, js-1, nb, one, f( is, js ),ldf, e( 1_${ik}$, js )& + , lde, one, f( is, 1_${ik}$ ),ldf ) end if if( i

0. if( anorm>zero ) then ! estimate the norm of the inverse of a. ainvnm = zero normin = 'N' if( onenrm ) then - kase1 = 1 + kase1 = 1_${ik}$ else - kase1 = 2 + kase1 = 2_${ik}$ end if - kase = 0 + kase = 0_${ik}$ 10 continue - call stdlib_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) + if( kase/=0_${ik}$ ) then if( kase==kase1 ) then ! multiply by inv(a). - call stdlib_${ri}$latps( uplo, 'NO TRANSPOSE', diag, normin, n, ap,work, scale, & - work( 2*n+1 ), info ) + call stdlib${ii}$_${ri}$latps( uplo, 'NO TRANSPOSE', diag, normin, n, ap,work, scale, & + work( 2_${ik}$*n+1 ), info ) else ! multiply by inv(a**t). - call stdlib_${ri}$latps( uplo, 'TRANSPOSE', diag, normin, n, ap,work, scale, work( & - 2*n+1 ), info ) + call stdlib${ii}$_${ri}$latps( uplo, 'TRANSPOSE', diag, normin, n, ap,work, scale, work( & + 2_${ik}$*n+1 ), info ) end if normin = 'Y' ! multiply by 1/scale if doing so will not cause overflow. if( scale/=one ) then - ix = stdlib_i${ri}$amax( n, work, 1 ) + ix = stdlib${ii}$_i${ri}$amax( n, work, 1_${ik}$ ) xnorm = abs( work( ix ) ) if( scalemin(m,n) .and. min(m,n)>=0)) then - info = -3 - else if( mb<1 .or. (mb>m .and. m>0)) then - info = -4 - else if( ldamin(m,n) .and. min(m,n)>=0_${ik}$)) then + info = -3_${ik}$ + else if( mb<1_${ik}$ .or. (mb>m .and. m>0_${ik}$)) then + info = -4_${ik}$ + else if( lda=l ) then - lb = 0 + lb = 0_${ik}$ else lb = nb-n+l-i+1 end if - call stdlib_${ri}$tplqt2( ib, nb, lb, a(i,i), lda, b( i, 1 ), ldb,t(1, i ), ldt, iinfo ) + call stdlib${ii}$_${ri}$tplqt2( ib, nb, lb, a(i,i), lda, b( i, 1_${ik}$ ), ldb,t(1_${ik}$, i ), ldt, iinfo ) ! update by applying h**t to b(i+ib:m,:) from the right if( i+ib<=m ) then - call stdlib_${ri}$tprfb( 'R', 'N', 'F', 'R', m-i-ib+1, nb, ib, lb,b( i, 1 ), ldb, t( & - 1, i ), ldt,a( i+ib, i ), lda, b( i+ib, 1 ), ldb,work, m-i-ib+1) + call stdlib${ii}$_${ri}$tprfb( 'R', 'N', 'F', 'R', m-i-ib+1, nb, ib, lb,b( i, 1_${ik}$ ), ldb, t( & + 1_${ik}$, i ), ldt,a( i+ib, i ), lda, b( i+ib, 1_${ik}$ ), ldb,work, m-i-ib+1) end if end do return - end subroutine stdlib_${ri}$tplqt + end subroutine stdlib${ii}$_${ri}$tplqt - pure subroutine stdlib_${ri}$tplqt2( m, n, l, a, lda, b, ldb, t, ldt, info ) + pure subroutine stdlib${ii}$_${ri}$tplqt2( m, n, l, a, lda, b, ldb, t, ldt, info ) !! DTPLQT2: computes a LQ a factorization of a real "triangular-pentagonal" !! matrix C, which is composed of a triangular block A and pentagonal block B, !! using the compact WY representation for Q. @@ -79900,36 +79891,36 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, ldb, ldt, n, m, l + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) real(${rk}$), intent(out) :: t(ldt,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, p, mp, np + integer(${ik}$) :: i, j, p, mp, np real(${rk}$) :: alpha ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( l<0 .or. l>min(m,n) ) then - info = -3 - else if( ldamin(m,n) ) then + info = -3_${ik}$ + else if( ldak ) then - info = -6 - else if( mb<1 .or. (mb>k .and. k>0) ) then - info = -7 + info = -2_${ik}$ + else if( m<0_${ik}$ ) then + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( k<0_${ik}$ ) then + info = -5_${ik}$ + else if( l<0_${ik}$ .or. l>k ) then + info = -6_${ik}$ + else if( mb<1_${ik}$ .or. (mb>k .and. k>0_${ik}$) ) then + info = -7_${ik}$ else if( ldv=l ) then - lb = 0 + lb = 0_${ik}$ else - lb = 0 + lb = 0_${ik}$ end if - call stdlib_${ri}$tprfb( 'L', 'T', 'F', 'R', nb, n, ib, lb,v( i, 1 ), ldv, t( 1, i ), & - ldt,a( i, 1 ), lda, b, ldb, work, ib ) + call stdlib${ii}$_${ri}$tprfb( 'L', 'T', 'F', 'R', nb, n, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), & + ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib ) end do else if( right .and. tran ) then do i = 1, k, mb ib = min( mb, k-i+1 ) nb = min( n-l+i+ib-1, n ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = nb-n+l-i+1 end if - call stdlib_${ri}$tprfb( 'R', 'N', 'F', 'R', m, nb, ib, lb,v( i, 1 ), ldv, t( 1, i ), & - ldt,a( 1, i ), lda, b, ldb, work, m ) + call stdlib${ii}$_${ri}$tprfb( 'R', 'N', 'F', 'R', m, nb, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), & + ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m ) end do else if( left .and. tran ) then kf = ((k-1)/mb)*mb+1 @@ -80082,12 +80073,12 @@ module stdlib_linalg_lapack_${ri}$ ib = min( mb, k-i+1 ) nb = min( m-l+i+ib-1, m ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else - lb = 0 + lb = 0_${ik}$ end if - call stdlib_${ri}$tprfb( 'L', 'N', 'F', 'R', nb, n, ib, lb,v( i, 1 ), ldv, t( 1, i ), & - ldt,a( i, 1 ), lda, b, ldb, work, ib ) + call stdlib${ii}$_${ri}$tprfb( 'L', 'N', 'F', 'R', nb, n, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), & + ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib ) end do else if( right .and. notran ) then kf = ((k-1)/mb)*mb+1 @@ -80095,19 +80086,19 @@ module stdlib_linalg_lapack_${ri}$ ib = min( mb, k-i+1 ) nb = min( n-l+i+ib-1, n ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = nb-n+l-i+1 end if - call stdlib_${ri}$tprfb( 'R', 'T', 'F', 'R', m, nb, ib, lb,v( i, 1 ), ldv, t( 1, i ), & - ldt,a( 1, i ), lda, b, ldb, work, m ) + call stdlib${ii}$_${ri}$tprfb( 'R', 'T', 'F', 'R', m, nb, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), & + ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m ) end do end if return - end subroutine stdlib_${ri}$tpmlqt + end subroutine stdlib${ii}$_${ri}$tpmlqt - pure subroutine stdlib_${ri}$tpmqrt( side, trans, m, n, k, l, nb, v, ldv, t, ldt,a, lda, b, ldb, & + pure subroutine stdlib${ii}$_${ri}$tpmqrt( side, trans, m, n, k, l, nb, v, ldv, t, ldt,a, lda, b, ldb, & !! DTPMQRT: applies a real orthogonal matrix Q obtained from a !! "triangular-pentagonal" real block reflector H to a general !! real matrix C, which consists of two blocks A and B. @@ -80117,8 +80108,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, lda, ldb, m, n, l, nb, ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k, ldv, lda, ldb, m, n, l, nb, ldt ! Array Arguments real(${rk}$), intent(in) :: v(ldv,*), t(ldt,*) real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) @@ -80126,48 +80117,48 @@ module stdlib_linalg_lapack_${ri}$ ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran - integer(ilp) :: i, ib, mb, lb, kf, ldaq, ldvq + integer(${ik}$) :: i, ib, mb, lb, kf, ldaq, ldvq ! 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 - ldvq = max( 1, m ) - ldaq = max( 1, k ) + ldvq = max( 1_${ik}$, m ) + ldaq = max( 1_${ik}$, k ) else if ( right ) then - ldvq = max( 1, n ) - ldaq = max( 1, m ) + ldvq = max( 1_${ik}$, n ) + ldaq = max( 1_${ik}$, m ) 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 ) then - info = -5 - else if( l<0 .or. l>k ) then - info = -6 - else if( nb<1 .or. (nb>k .and. k>0) ) then - info = -7 + info = -2_${ik}$ + else if( m<0_${ik}$ ) then + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( k<0_${ik}$ ) then + info = -5_${ik}$ + else if( l<0_${ik}$ .or. l>k ) then + info = -6_${ik}$ + else if( nb<1_${ik}$ .or. (nb>k .and. k>0_${ik}$) ) then + info = -7_${ik}$ else if( ldv=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-m+l-i+1 end if - call stdlib_${ri}$tprfb( 'L', 'T', 'F', 'C', mb, n, ib, lb,v( 1, i ), ldv, t( 1, i ), & - ldt,a( i, 1 ), lda, b, ldb, work, ib ) + call stdlib${ii}$_${ri}$tprfb( 'L', 'T', 'F', 'C', mb, n, ib, lb,v( 1_${ik}$, i ), ldv, t( 1_${ik}$, i ), & + ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib ) end do else if( right .and. notran ) then do i = 1, k, nb ib = min( nb, k-i+1 ) mb = min( n-l+i+ib-1, n ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-n+l-i+1 end if - call stdlib_${ri}$tprfb( 'R', 'N', 'F', 'C', m, mb, ib, lb,v( 1, i ), ldv, t( 1, i ), & - ldt,a( 1, i ), lda, b, ldb, work, m ) + call stdlib${ii}$_${ri}$tprfb( 'R', 'N', 'F', 'C', m, mb, ib, lb,v( 1_${ik}$, i ), ldv, t( 1_${ik}$, i ), & + ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m ) end do else if( left .and. notran ) then kf = ((k-1)/nb)*nb+1 @@ -80202,12 +80193,12 @@ module stdlib_linalg_lapack_${ri}$ ib = min( nb, k-i+1 ) mb = min( m-l+i+ib-1, m ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-m+l-i+1 end if - call stdlib_${ri}$tprfb( 'L', 'N', 'F', 'C', mb, n, ib, lb,v( 1, i ), ldv, t( 1, i ), & - ldt,a( i, 1 ), lda, b, ldb, work, ib ) + call stdlib${ii}$_${ri}$tprfb( 'L', 'N', 'F', 'C', mb, n, ib, lb,v( 1_${ik}$, i ), ldv, t( 1_${ik}$, i ), & + ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib ) end do else if( right .and. tran ) then kf = ((k-1)/nb)*nb+1 @@ -80215,19 +80206,19 @@ module stdlib_linalg_lapack_${ri}$ ib = min( nb, k-i+1 ) mb = min( n-l+i+ib-1, n ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-n+l-i+1 end if - call stdlib_${ri}$tprfb( 'R', 'T', 'F', 'C', m, mb, ib, lb,v( 1, i ), ldv, t( 1, i ), & - ldt,a( 1, i ), lda, b, ldb, work, m ) + call stdlib${ii}$_${ri}$tprfb( 'R', 'T', 'F', 'C', m, mb, ib, lb,v( 1_${ik}$, i ), ldv, t( 1_${ik}$, i ), & + ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m ) end do end if return - end subroutine stdlib_${ri}$tpmqrt + end subroutine stdlib${ii}$_${ri}$tpmqrt - pure subroutine stdlib_${ri}$tpqrt( m, n, l, nb, a, lda, b, ldb, t, ldt, work,info ) + pure subroutine stdlib${ii}$_${ri}$tpqrt( m, n, l, nb, a, lda, b, ldb, t, ldt, work,info ) !! DTPQRT: computes a blocked QR factorization of a real !! "triangular-pentagonal" matrix C, which is composed of a !! triangular block A and pentagonal block B, using the compact @@ -80236,34 +80227,34 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, ldb, ldt, n, m, l, nb + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l, nb ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) real(${rk}$), intent(out) :: t(ldt,*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ib, lb, mb, iinfo + integer(${ik}$) :: i, ib, lb, mb, iinfo ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( l<0 .or. (l>min(m,n) .and. min(m,n)>=0)) then - info = -3 - else if( nb<1 .or. (nb>n .and. n>0)) then - info = -4 - else if( ldamin(m,n) .and. min(m,n)>=0_${ik}$)) then + info = -3_${ik}$ + else if( nb<1_${ik}$ .or. (nb>n .and. n>0_${ik}$)) then + info = -4_${ik}$ + else if( lda=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-m+l-i+1 end if - call stdlib_${ri}$tpqrt2( mb, ib, lb, a(i,i), lda, b( 1, i ), ldb,t(1, i ), ldt, iinfo ) + call stdlib${ii}$_${ri}$tpqrt2( mb, ib, lb, a(i,i), lda, b( 1_${ik}$, i ), ldb,t(1_${ik}$, i ), ldt, iinfo ) ! update by applying h**t to b(:,i+ib:n) from the left if( i+ib<=n ) then - call stdlib_${ri}$tprfb( 'L', 'T', 'F', 'C', mb, n-i-ib+1, ib, lb,b( 1, i ), ldb, t( & - 1, i ), ldt,a( i, i+ib ), lda, b( 1, i+ib ), ldb,work, ib ) + call stdlib${ii}$_${ri}$tprfb( 'L', 'T', 'F', 'C', mb, n-i-ib+1, ib, lb,b( 1_${ik}$, i ), ldb, t( & + 1_${ik}$, i ), ldt,a( i, i+ib ), lda, b( 1_${ik}$, i+ib ), ldb,work, ib ) end if end do return - end subroutine stdlib_${ri}$tpqrt + end subroutine stdlib${ii}$_${ri}$tpqrt - pure subroutine stdlib_${ri}$tpqrt2( m, n, l, a, lda, b, ldb, t, ldt, info ) + pure subroutine stdlib${ii}$_${ri}$tpqrt2( m, n, l, a, lda, b, ldb, t, ldt, info ) !! DTPQRT2: computes a QR factorization of a real "triangular-pentagonal" !! matrix C, which is composed of a triangular block A and pentagonal block B, !! using the compact WY representation for Q. @@ -80297,36 +80288,36 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, ldb, ldt, n, m, l + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l ! Array Arguments real(${rk}$), intent(inout) :: a(lda,*), b(ldb,*) real(${rk}$), intent(out) :: t(ldt,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, p, mp, np + integer(${ik}$) :: i, j, p, mp, np real(${rk}$) :: alpha ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( l<0 .or. l>min(m,n) ) then - info = -3 - else if( ldamin(m,n) ) then + info = -3_${ik}$ + else if( lda 0. if( anorm>zero ) then ! estimate the norm of the inverse of a. ainvnm = zero normin = 'N' if( onenrm ) then - kase1 = 1 + kase1 = 1_${ik}$ else - kase1 = 2 + kase1 = 2_${ik}$ end if - kase = 0 + kase = 0_${ik}$ 10 continue - call stdlib_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_${ri}$lacn2( n, work( n+1 ), work, iwork, ainvnm, kase, isave ) + if( kase/=0_${ik}$ ) then if( kase==kase1 ) then ! multiply by inv(a). - call stdlib_${ri}$latrs( uplo, 'NO TRANSPOSE', diag, normin, n, a,lda, work, scale,& - work( 2*n+1 ), info ) + call stdlib${ii}$_${ri}$latrs( uplo, 'NO TRANSPOSE', diag, normin, n, a,lda, work, scale,& + work( 2_${ik}$*n+1 ), info ) else ! multiply by inv(a**t). - call stdlib_${ri}$latrs( uplo, 'TRANSPOSE', diag, normin, n, a, lda,work, scale, & - work( 2*n+1 ), info ) + call stdlib${ii}$_${ri}$latrs( uplo, 'TRANSPOSE', diag, normin, n, a, lda,work, scale, & + work( 2_${ik}$*n+1 ), info ) end if normin = 'Y' ! multiply by 1/scale if doing so will not cause overflow. if( scale/=one ) then - ix = stdlib_i${ri}$amax( n, work, 1 ) + ix = stdlib${ii}$_i${ri}$amax( n, work, 1_${ik}$ ) xnorm = abs( work( ix ) ) if( scalejnxt )cycle loop_60 j1 = j j2 = j - jnxt = j - 1 - if( j>1 ) then + jnxt = j - 1_${ik}$ + if( j>1_${ik}$ ) then if( t( j, j-1 )/=zero ) then - j1 = j - 1 - jnxt = j - 2 + j1 = j - 1_${ik}$ + jnxt = j - 2_${ik}$ end if end if if( j1==j2 ) then ! 1-by-1 diagonal block - call stdlib_${ri}$laln2( .false., 1, 1, smin, one, t( j, j ),ldt, one, one, & - work( j+n ), n, wr,zero, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_${ri}$laln2( .false., 1_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr ) ! scale x(1,1) to avoid overflow when updating ! the right-hand side. if( xnorm>one ) then if( work( j )>bignum / xnorm ) then - x( 1, 1 ) = x( 1, 1 ) / xnorm + x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm scale = scale / xnorm end if end if ! scale if necessary - if( scale/=one )call stdlib_${ri}$scal( ki, scale, work( 1+n ), 1 ) - work( j+n ) = x( 1, 1 ) + if( scale/=one )call stdlib${ii}$_${ri}$scal( ki, scale, work( 1_${ik}$+n ), 1_${ik}$ ) + work( j+n ) = x( 1_${ik}$, 1_${ik}$ ) ! update right-hand side - call stdlib_${ri}$axpy( j-1, -x( 1, 1 ), t( 1, j ), 1,work( 1+n ), 1 ) + call stdlib${ii}$_${ri}$axpy( j-1, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ ) else ! 2-by-2 diagonal block - call stdlib_${ri}$laln2( .false., 2, 1, smin, one,t( j-1, j-1 ), ldt, one, & - one,work( j-1+n ), n, wr, zero, x, 2,scale, xnorm, ierr ) + call stdlib${ii}$_${ri}$laln2( .false., 2_${ik}$, 1_${ik}$, smin, one,t( j-1, j-1 ), ldt, one, & + one,work( j-1+n ), n, wr, zero, x, 2_${ik}$,scale, xnorm, ierr ) ! scale x(1,1) and x(2,1) to avoid overflow when ! updating the right-hand side. if( xnorm>one ) then beta = max( work( j-1 ), work( j ) ) if( beta>bignum / xnorm ) then - x( 1, 1 ) = x( 1, 1 ) / xnorm - x( 2, 1 ) = x( 2, 1 ) / xnorm + x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm + x( 2_${ik}$, 1_${ik}$ ) = x( 2_${ik}$, 1_${ik}$ ) / xnorm scale = scale / xnorm end if end if ! scale if necessary - if( scale/=one )call stdlib_${ri}$scal( ki, scale, work( 1+n ), 1 ) - work( j-1+n ) = x( 1, 1 ) - work( j+n ) = x( 2, 1 ) + if( scale/=one )call stdlib${ii}$_${ri}$scal( ki, scale, work( 1_${ik}$+n ), 1_${ik}$ ) + work( j-1+n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+n ) = x( 2_${ik}$, 1_${ik}$ ) ! update right-hand side - call stdlib_${ri}$axpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,work( 1+n ), 1 ) + call stdlib${ii}$_${ri}$axpy( j-2, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ ) - call stdlib_${ri}$axpy( j-2, -x( 2, 1 ), t( 1, j ), 1,work( 1+n ), 1 ) + call stdlib${ii}$_${ri}$axpy( j-2, -x( 2_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ ) end if end do loop_60 ! copy the vector x or q*x to vr and normalize. if( .not.over ) then - call stdlib_${ri}$copy( ki, work( 1+n ), 1, vr( 1, is ), 1 ) - ii = stdlib_i${ri}$amax( ki, vr( 1, is ), 1 ) + call stdlib${ii}$_${ri}$copy( ki, work( 1_${ik}$+n ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ ) + ii = stdlib${ii}$_i${ri}$amax( ki, vr( 1_${ik}$, is ), 1_${ik}$ ) remax = one / abs( vr( ii, is ) ) - call stdlib_${ri}$scal( ki, remax, vr( 1, is ), 1 ) + call stdlib${ii}$_${ri}$scal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ ) do k = ki + 1, n vr( k, is ) = zero end do else - if( ki>1 )call stdlib_${ri}$gemv( 'N', n, ki-1, one, vr, ldvr,work( 1+n ), 1, & - work( ki+n ),vr( 1, ki ), 1 ) - ii = stdlib_i${ri}$amax( n, vr( 1, ki ), 1 ) + if( ki>1_${ik}$ )call stdlib${ii}$_${ri}$gemv( 'N', n, ki-1, one, vr, ldvr,work( 1_${ik}$+n ), 1_${ik}$, & + work( ki+n ),vr( 1_${ik}$, ki ), 1_${ik}$ ) + ii = stdlib${ii}$_i${ri}$amax( n, vr( 1_${ik}$, ki ), 1_${ik}$ ) remax = one / abs( vr( ii, ki ) ) - call stdlib_${ri}$scal( n, remax, vr( 1, ki ), 1 ) + call stdlib${ii}$_${ri}$scal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ ) end if else ! complex right eigenvector. @@ -81848,130 +81839,130 @@ module stdlib_linalg_lapack_${ri}$ end do ! solve upper quasi-triangular system: ! (t(1:ki-2,1:ki-2) - (wr+i*wi))*x = scale*(work+i*work2) - jnxt = ki - 2 + jnxt = ki - 2_${ik}$ loop_90: do j = ki - 2, 1, -1 if( j>jnxt )cycle loop_90 j1 = j j2 = j - jnxt = j - 1 - if( j>1 ) then + jnxt = j - 1_${ik}$ + if( j>1_${ik}$ ) then if( t( j, j-1 )/=zero ) then - j1 = j - 1 - jnxt = j - 2 + j1 = j - 1_${ik}$ + jnxt = j - 2_${ik}$ end if end if if( j1==j2 ) then ! 1-by-1 diagonal block - call stdlib_${ri}$laln2( .false., 1, 2, smin, one, t( j, j ),ldt, one, one, & - work( j+n ), n, wr, wi,x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_${ri}$laln2( .false., 1_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+n ), n, wr, wi,x, 2_${ik}$, scale, xnorm, ierr ) ! scale x(1,1) and x(1,2) to avoid overflow when ! updating the right-hand side. if( xnorm>one ) then if( work( j )>bignum / xnorm ) then - x( 1, 1 ) = x( 1, 1 ) / xnorm - x( 1, 2 ) = x( 1, 2 ) / xnorm + x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm + x( 1_${ik}$, 2_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ ) / xnorm scale = scale / xnorm end if end if ! scale if necessary if( scale/=one ) then - call stdlib_${ri}$scal( ki, scale, work( 1+n ), 1 ) - call stdlib_${ri}$scal( ki, scale, work( 1+n2 ), 1 ) + call stdlib${ii}$_${ri}$scal( ki, scale, work( 1_${ik}$+n ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( ki, scale, work( 1_${ik}$+n2 ), 1_${ik}$ ) end if - work( j+n ) = x( 1, 1 ) - work( j+n2 ) = x( 1, 2 ) + work( j+n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+n2 ) = x( 1_${ik}$, 2_${ik}$ ) ! update the right-hand side - call stdlib_${ri}$axpy( j-1, -x( 1, 1 ), t( 1, j ), 1,work( 1+n ), 1 ) + call stdlib${ii}$_${ri}$axpy( j-1, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ ) - call stdlib_${ri}$axpy( j-1, -x( 1, 2 ), t( 1, j ), 1,work( 1+n2 ), 1 ) + call stdlib${ii}$_${ri}$axpy( j-1, -x( 1_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n2 ), 1_${ik}$ ) else ! 2-by-2 diagonal block - call stdlib_${ri}$laln2( .false., 2, 2, smin, one,t( j-1, j-1 ), ldt, one, & - one,work( j-1+n ), n, wr, wi, x, 2, scale,xnorm, ierr ) + call stdlib${ii}$_${ri}$laln2( .false., 2_${ik}$, 2_${ik}$, smin, one,t( j-1, j-1 ), ldt, one, & + one,work( j-1+n ), n, wr, wi, x, 2_${ik}$, scale,xnorm, ierr ) ! scale x to avoid overflow when updating ! the right-hand side. if( xnorm>one ) then beta = max( work( j-1 ), work( j ) ) if( beta>bignum / xnorm ) then rec = one / xnorm - x( 1, 1 ) = x( 1, 1 )*rec - x( 1, 2 ) = x( 1, 2 )*rec - x( 2, 1 ) = x( 2, 1 )*rec - x( 2, 2 ) = x( 2, 2 )*rec + x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ )*rec + x( 1_${ik}$, 2_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ )*rec + x( 2_${ik}$, 1_${ik}$ ) = x( 2_${ik}$, 1_${ik}$ )*rec + x( 2_${ik}$, 2_${ik}$ ) = x( 2_${ik}$, 2_${ik}$ )*rec scale = scale*rec end if end if ! scale if necessary if( scale/=one ) then - call stdlib_${ri}$scal( ki, scale, work( 1+n ), 1 ) - call stdlib_${ri}$scal( ki, scale, work( 1+n2 ), 1 ) + call stdlib${ii}$_${ri}$scal( ki, scale, work( 1_${ik}$+n ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( ki, scale, work( 1_${ik}$+n2 ), 1_${ik}$ ) end if - work( j-1+n ) = x( 1, 1 ) - work( j+n ) = x( 2, 1 ) - work( j-1+n2 ) = x( 1, 2 ) - work( j+n2 ) = x( 2, 2 ) + work( j-1+n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+n ) = x( 2_${ik}$, 1_${ik}$ ) + work( j-1+n2 ) = x( 1_${ik}$, 2_${ik}$ ) + work( j+n2 ) = x( 2_${ik}$, 2_${ik}$ ) ! update the right-hand side - call stdlib_${ri}$axpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,work( 1+n ), 1 ) + call stdlib${ii}$_${ri}$axpy( j-2, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ ) - call stdlib_${ri}$axpy( j-2, -x( 2, 1 ), t( 1, j ), 1,work( 1+n ), 1 ) + call stdlib${ii}$_${ri}$axpy( j-2, -x( 2_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ ) - call stdlib_${ri}$axpy( j-2, -x( 1, 2 ), t( 1, j-1 ), 1,work( 1+n2 ), 1 ) + call stdlib${ii}$_${ri}$axpy( j-2, -x( 1_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+n2 ), 1_${ik}$ ) - call stdlib_${ri}$axpy( j-2, -x( 2, 2 ), t( 1, j ), 1,work( 1+n2 ), 1 ) + call stdlib${ii}$_${ri}$axpy( j-2, -x( 2_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n2 ), 1_${ik}$ ) end if end do loop_90 ! copy the vector x or q*x to vr and normalize. if( .not.over ) then - call stdlib_${ri}$copy( ki, work( 1+n ), 1, vr( 1, is-1 ), 1 ) - call stdlib_${ri}$copy( ki, work( 1+n2 ), 1, vr( 1, is ), 1 ) + call stdlib${ii}$_${ri}$copy( ki, work( 1_${ik}$+n ), 1_${ik}$, vr( 1_${ik}$, is-1 ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$copy( ki, work( 1_${ik}$+n2 ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ ) emax = zero do k = 1, ki emax = max( emax, abs( vr( k, is-1 ) )+abs( vr( k, is ) ) ) end do remax = one / emax - call stdlib_${ri}$scal( ki, remax, vr( 1, is-1 ), 1 ) - call stdlib_${ri}$scal( ki, remax, vr( 1, is ), 1 ) + call stdlib${ii}$_${ri}$scal( ki, remax, vr( 1_${ik}$, is-1 ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ ) do k = ki + 1, n vr( k, is-1 ) = zero vr( k, is ) = zero end do else - if( ki>2 ) then - call stdlib_${ri}$gemv( 'N', n, ki-2, one, vr, ldvr,work( 1+n ), 1, work( ki-& - 1+n ),vr( 1, ki-1 ), 1 ) - call stdlib_${ri}$gemv( 'N', n, ki-2, one, vr, ldvr,work( 1+n2 ), 1, work( & - ki+n2 ),vr( 1, ki ), 1 ) + if( ki>2_${ik}$ ) then + call stdlib${ii}$_${ri}$gemv( 'N', n, ki-2, one, vr, ldvr,work( 1_${ik}$+n ), 1_${ik}$, work( ki-& + 1_${ik}$+n ),vr( 1_${ik}$, ki-1 ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$gemv( 'N', n, ki-2, one, vr, ldvr,work( 1_${ik}$+n2 ), 1_${ik}$, work( & + ki+n2 ),vr( 1_${ik}$, ki ), 1_${ik}$ ) else - call stdlib_${ri}$scal( n, work( ki-1+n ), vr( 1, ki-1 ), 1 ) - call stdlib_${ri}$scal( n, work( ki+n2 ), vr( 1, ki ), 1 ) + call stdlib${ii}$_${ri}$scal( n, work( ki-1+n ), vr( 1_${ik}$, ki-1 ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n, work( ki+n2 ), vr( 1_${ik}$, ki ), 1_${ik}$ ) end if emax = zero do k = 1, n emax = max( emax, abs( vr( k, ki-1 ) )+abs( vr( k, ki ) ) ) end do remax = one / emax - call stdlib_${ri}$scal( n, remax, vr( 1, ki-1 ), 1 ) - call stdlib_${ri}$scal( n, remax, vr( 1, ki ), 1 ) + call stdlib${ii}$_${ri}$scal( n, remax, vr( 1_${ik}$, ki-1 ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ ) end if end if - is = is - 1 - if( ip/=0 )is = is - 1 + is = is - 1_${ik}$ + if( ip/=0_${ik}$ )is = is - 1_${ik}$ 130 continue - if( ip==1 )ip = 0 - if( ip==-1 )ip = 1 + if( ip==1_${ik}$ )ip = 0_${ik}$ + if( ip==-1_${ik}$ )ip = 1_${ik}$ end do loop_140 end if if( leftv ) then ! compute left eigenvectors. - ip = 0 - is = 1 + ip = 0_${ik}$ + is = 1_${ik}$ loop_260: do ki = 1, n if( ip==-1 )go to 250 if( ki==n )go to 150 if( t( ki+1, ki )==zero )go to 150 - ip = 1 + ip = 1_${ik}$ 150 continue if( somev ) then if( .not.select( ki ) )go to 250 @@ -81979,9 +81970,9 @@ module stdlib_linalg_lapack_${ri}$ ! compute the ki-th eigenvalue (wr,wi). wr = t( ki, ki ) wi = zero - if( ip/=0 )wi = sqrt( abs( t( ki, ki+1 ) ) )*sqrt( abs( t( ki+1, ki ) ) ) + if( ip/=0_${ik}$ )wi = sqrt( abs( t( ki, ki+1 ) ) )*sqrt( abs( t( ki+1, ki ) ) ) smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum ) - if( ip==0 ) then + if( ip==0_${ik}$ ) then ! real left eigenvector. work( ki+n ) = one ! form right-hand side @@ -81992,16 +81983,16 @@ module stdlib_linalg_lapack_${ri}$ ! (t(ki+1:n,ki+1:n) - wr)**t*x = scale*work vmax = one vcrit = bignum - jnxt = ki + 1 + jnxt = ki + 1_${ik}$ loop_170: do j = ki + 1, n if( jvcrit ) then rec = one / vmax - call stdlib_${ri}$scal( n-ki+1, rec, work( ki+n ), 1 ) + call stdlib${ii}$_${ri}$scal( n-ki+1, rec, work( ki+n ), 1_${ik}$ ) vmax = one vcrit = bignum end if - work( j+n ) = work( j+n ) -stdlib_${ri}$dot( j-ki-1, t( ki+1, j ), 1,work( & - ki+1+n ), 1 ) + work( j+n ) = work( j+n ) -stdlib${ii}$_${ri}$dot( j-ki-1, t( ki+1, j ), 1_${ik}$,work( & + ki+1+n ), 1_${ik}$ ) ! solve (t(j,j)-wr)**t*x = work - call stdlib_${ri}$laln2( .false., 1, 1, smin, one, t( j, j ),ldt, one, one, & - work( j+n ), n, wr,zero, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_${ri}$laln2( .false., 1_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr ) ! scale if necessary - if( scale/=one )call stdlib_${ri}$scal( n-ki+1, scale, work( ki+n ), 1 ) + if( scale/=one )call stdlib${ii}$_${ri}$scal( n-ki+1, scale, work( ki+n ), 1_${ik}$ ) - work( j+n ) = x( 1, 1 ) + work( j+n ) = x( 1_${ik}$, 1_${ik}$ ) vmax = max( abs( work( j+n ) ), vmax ) vcrit = bignum / vmax else @@ -82032,43 +82023,43 @@ module stdlib_linalg_lapack_${ri}$ beta = max( work( j ), work( j+1 ) ) if( beta>vcrit ) then rec = one / vmax - call stdlib_${ri}$scal( n-ki+1, rec, work( ki+n ), 1 ) + call stdlib${ii}$_${ri}$scal( n-ki+1, rec, work( ki+n ), 1_${ik}$ ) vmax = one vcrit = bignum end if - work( j+n ) = work( j+n ) -stdlib_${ri}$dot( j-ki-1, t( ki+1, j ), 1,work( & - ki+1+n ), 1 ) - work( j+1+n ) = work( j+1+n ) -stdlib_${ri}$dot( j-ki-1, t( ki+1, j+1 ), 1,& - work( ki+1+n ), 1 ) + work( j+n ) = work( j+n ) -stdlib${ii}$_${ri}$dot( j-ki-1, t( ki+1, j ), 1_${ik}$,work( & + ki+1+n ), 1_${ik}$ ) + work( j+1+n ) = work( j+1+n ) -stdlib${ii}$_${ri}$dot( j-ki-1, t( ki+1, j+1 ), 1_${ik}$,& + work( ki+1+n ), 1_${ik}$ ) ! solve ! [t(j,j)-wr t(j,j+1) ]**t * x = scale*( work1 ) ! [t(j+1,j) t(j+1,j+1)-wr] ( work2 ) - call stdlib_${ri}$laln2( .true., 2, 1, smin, one, t( j, j ),ldt, one, one, & - work( j+n ), n, wr,zero, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_${ri}$laln2( .true., 2_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr ) ! scale if necessary - if( scale/=one )call stdlib_${ri}$scal( n-ki+1, scale, work( ki+n ), 1 ) + if( scale/=one )call stdlib${ii}$_${ri}$scal( n-ki+1, scale, work( ki+n ), 1_${ik}$ ) - work( j+n ) = x( 1, 1 ) - work( j+1+n ) = x( 2, 1 ) + work( j+n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+1+n ) = x( 2_${ik}$, 1_${ik}$ ) vmax = max( abs( work( j+n ) ),abs( work( j+1+n ) ), vmax ) vcrit = bignum / vmax end if end do loop_170 ! copy the vector x or q*x to vl and normalize. if( .not.over ) then - call stdlib_${ri}$copy( n-ki+1, work( ki+n ), 1, vl( ki, is ), 1 ) - ii = stdlib_i${ri}$amax( n-ki+1, vl( ki, is ), 1 ) + ki - 1 + call stdlib${ii}$_${ri}$copy( n-ki+1, work( ki+n ), 1_${ik}$, vl( ki, is ), 1_${ik}$ ) + ii = stdlib${ii}$_i${ri}$amax( n-ki+1, vl( ki, is ), 1_${ik}$ ) + ki - 1_${ik}$ remax = one / abs( vl( ii, is ) ) - call stdlib_${ri}$scal( n-ki+1, remax, vl( ki, is ), 1 ) + call stdlib${ii}$_${ri}$scal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ ) do k = 1, ki - 1 vl( k, is ) = zero end do else - if( kivcrit ) then rec = one / vmax - call stdlib_${ri}$scal( n-ki+1, rec, work( ki+n ), 1 ) - call stdlib_${ri}$scal( n-ki+1, rec, work( ki+n2 ), 1 ) + call stdlib${ii}$_${ri}$scal( n-ki+1, rec, work( ki+n ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n-ki+1, rec, work( ki+n2 ), 1_${ik}$ ) vmax = one vcrit = bignum end if - work( j+n ) = work( j+n ) -stdlib_${ri}$dot( j-ki-2, t( ki+2, j ), 1,work( & - ki+2+n ), 1 ) - work( j+n2 ) = work( j+n2 ) -stdlib_${ri}$dot( j-ki-2, t( ki+2, j ), 1,work( & - ki+2+n2 ), 1 ) + work( j+n ) = work( j+n ) -stdlib${ii}$_${ri}$dot( j-ki-2, t( ki+2, j ), 1_${ik}$,work( & + ki+2+n ), 1_${ik}$ ) + work( j+n2 ) = work( j+n2 ) -stdlib${ii}$_${ri}$dot( j-ki-2, t( ki+2, j ), 1_${ik}$,work( & + ki+2+n2 ), 1_${ik}$ ) ! solve (t(j,j)-(wr-i*wi))*(x11+i*x12)= wk+i*wk2 - call stdlib_${ri}$laln2( .false., 1, 2, smin, one, t( j, j ),ldt, one, one, & - work( j+n ), n, wr,-wi, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_${ri}$laln2( .false., 1_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+n ), n, wr,-wi, x, 2_${ik}$, scale, xnorm, ierr ) ! scale if necessary if( scale/=one ) then - call stdlib_${ri}$scal( n-ki+1, scale, work( ki+n ), 1 ) - call stdlib_${ri}$scal( n-ki+1, scale, work( ki+n2 ), 1 ) + call stdlib${ii}$_${ri}$scal( n-ki+1, scale, work( ki+n ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n-ki+1, scale, work( ki+n2 ), 1_${ik}$ ) end if - work( j+n ) = x( 1, 1 ) - work( j+n2 ) = x( 1, 2 ) + work( j+n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+n2 ) = x( 1_${ik}$, 2_${ik}$ ) vmax = max( abs( work( j+n ) ),abs( work( j+n2 ) ), vmax ) vcrit = bignum / vmax else @@ -82139,84 +82130,84 @@ module stdlib_linalg_lapack_${ri}$ beta = max( work( j ), work( j+1 ) ) if( beta>vcrit ) then rec = one / vmax - call stdlib_${ri}$scal( n-ki+1, rec, work( ki+n ), 1 ) - call stdlib_${ri}$scal( n-ki+1, rec, work( ki+n2 ), 1 ) + call stdlib${ii}$_${ri}$scal( n-ki+1, rec, work( ki+n ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n-ki+1, rec, work( ki+n2 ), 1_${ik}$ ) vmax = one vcrit = bignum end if - work( j+n ) = work( j+n ) -stdlib_${ri}$dot( j-ki-2, t( ki+2, j ), 1,work( & - ki+2+n ), 1 ) - work( j+n2 ) = work( j+n2 ) -stdlib_${ri}$dot( j-ki-2, t( ki+2, j ), 1,work( & - ki+2+n2 ), 1 ) - work( j+1+n ) = work( j+1+n ) -stdlib_${ri}$dot( j-ki-2, t( ki+2, j+1 ), 1,& - work( ki+2+n ), 1 ) - work( j+1+n2 ) = work( j+1+n2 ) -stdlib_${ri}$dot( j-ki-2, t( ki+2, j+1 ), 1,& - work( ki+2+n2 ), 1 ) + work( j+n ) = work( j+n ) -stdlib${ii}$_${ri}$dot( j-ki-2, t( ki+2, j ), 1_${ik}$,work( & + ki+2+n ), 1_${ik}$ ) + work( j+n2 ) = work( j+n2 ) -stdlib${ii}$_${ri}$dot( j-ki-2, t( ki+2, j ), 1_${ik}$,work( & + ki+2+n2 ), 1_${ik}$ ) + work( j+1+n ) = work( j+1+n ) -stdlib${ii}$_${ri}$dot( j-ki-2, t( ki+2, j+1 ), 1_${ik}$,& + work( ki+2+n ), 1_${ik}$ ) + work( j+1+n2 ) = work( j+1+n2 ) -stdlib${ii}$_${ri}$dot( j-ki-2, t( ki+2, j+1 ), 1_${ik}$,& + work( ki+2+n2 ), 1_${ik}$ ) ! solve 2-by-2 complex linear equation ! ([t(j,j) t(j,j+1) ]**t-(wr-i*wi)*i)*x = scale*b ! ([t(j+1,j) t(j+1,j+1)] ) - call stdlib_${ri}$laln2( .true., 2, 2, smin, one, t( j, j ),ldt, one, one, & - work( j+n ), n, wr,-wi, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_${ri}$laln2( .true., 2_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+n ), n, wr,-wi, x, 2_${ik}$, scale, xnorm, ierr ) ! scale if necessary if( scale/=one ) then - call stdlib_${ri}$scal( n-ki+1, scale, work( ki+n ), 1 ) - call stdlib_${ri}$scal( n-ki+1, scale, work( ki+n2 ), 1 ) + call stdlib${ii}$_${ri}$scal( n-ki+1, scale, work( ki+n ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n-ki+1, scale, work( ki+n2 ), 1_${ik}$ ) end if - work( j+n ) = x( 1, 1 ) - work( j+n2 ) = x( 1, 2 ) - work( j+1+n ) = x( 2, 1 ) - work( j+1+n2 ) = x( 2, 2 ) - vmax = max( abs( x( 1, 1 ) ), abs( x( 1, 2 ) ),abs( x( 2, 1 ) ), abs( x(& - 2, 2 ) ), vmax ) + work( j+n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+n2 ) = x( 1_${ik}$, 2_${ik}$ ) + work( j+1+n ) = x( 2_${ik}$, 1_${ik}$ ) + work( j+1+n2 ) = x( 2_${ik}$, 2_${ik}$ ) + vmax = max( abs( x( 1_${ik}$, 1_${ik}$ ) ), abs( x( 1_${ik}$, 2_${ik}$ ) ),abs( x( 2_${ik}$, 1_${ik}$ ) ), abs( x(& + 2_${ik}$, 2_${ik}$ ) ), vmax ) vcrit = bignum / vmax end if end do loop_200 ! copy the vector x or q*x to vl and normalize. if( .not.over ) then - call stdlib_${ri}$copy( n-ki+1, work( ki+n ), 1, vl( ki, is ), 1 ) - call stdlib_${ri}$copy( n-ki+1, work( ki+n2 ), 1, vl( ki, is+1 ),1 ) + call stdlib${ii}$_${ri}$copy( n-ki+1, work( ki+n ), 1_${ik}$, vl( ki, is ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$copy( n-ki+1, work( ki+n2 ), 1_${ik}$, vl( ki, is+1 ),1_${ik}$ ) emax = zero do k = ki, n emax = max( emax, abs( vl( k, is ) )+abs( vl( k, is+1 ) ) ) end do remax = one / emax - call stdlib_${ri}$scal( n-ki+1, remax, vl( ki, is ), 1 ) - call stdlib_${ri}$scal( n-ki+1, remax, vl( ki, is+1 ), 1 ) + call stdlib${ii}$_${ri}$scal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n-ki+1, remax, vl( ki, is+1 ), 1_${ik}$ ) do k = 1, ki - 1 vl( k, is ) = zero vl( k, is+1 ) = zero end do else if( ki= n + 2*n*nbmin ) then - nb = (lwork - n) / (2*n) + if( over .and. lwork >= n + 2_${ik}$*n*nbmin ) then + nb = (lwork - n) / (2_${ik}$*n) nb = min( nb, nbmax ) - call stdlib_${ri}$laset( 'F', n, 1+2*nb, zero, zero, work, n ) + call stdlib${ii}$_${ri}$laset( 'F', n, 1_${ik}$+2*nb, zero, zero, work, n ) else - nb = 1 + nb = 1_${ik}$ end if ! set the constants to control overflow. - unfl = stdlib_${ri}$lamch( 'SAFE MINIMUM' ) + unfl = stdlib${ii}$_${ri}$lamch( 'SAFE MINIMUM' ) ovfl = one / unfl - call stdlib_${ri}$labad( unfl, ovfl ) - ulp = stdlib_${ri}$lamch( 'PRECISION' ) + call stdlib${ii}$_${ri}$labad( unfl, ovfl ) + ulp = stdlib${ii}$_${ri}$lamch( 'PRECISION' ) smlnum = unfl*( n / ulp ) bignum = ( one-ulp ) / smlnum ! compute 1-norm of each column of strictly upper triangular ! part of t to control overflow in triangular solver. - work( 1 ) = zero + work( 1_${ik}$ ) = zero do j = 2, n work( j ) = zero do i = 1, j - 1 @@ -82370,30 +82361,30 @@ module stdlib_linalg_lapack_${ri}$ ! non-blocked version always uses iv=2; ! blocked version starts with iv=nb, goes down to 1 or 2. ! (note the "0-th" column is used for 1-norms computed above.) - iv = 2 - if( nb>2 ) then + iv = 2_${ik}$ + if( nb>2_${ik}$ ) then iv = nb end if - ip = 0 + ip = 0_${ik}$ is = m loop_140: do ki = n, 1, -1 - if( ip==-1 ) then + if( ip==-1_${ik}$ ) then ! previous iteration (ki+1) was second of conjugate pair, ! so this ki is first of conjugate pair; skip to end of loop - ip = 1 + ip = 1_${ik}$ cycle loop_140 - else if( ki==1 ) then + else if( ki==1_${ik}$ ) then ! last column, so this ki must be real eigenvalue - ip = 0 + ip = 0_${ik}$ else if( t( ki, ki-1 )==zero ) then ! zero on sub-diagonal, so this ki is real eigenvalue - ip = 0 + ip = 0_${ik}$ else ! non-zero on sub-diagonal, so this ki is second of conjugate pair - ip = -1 + ip = -1_${ik}$ end if if( somev ) then - if( ip==0 ) then + if( ip==0_${ik}$ ) then if( .not.select( ki ) )cycle loop_140 else if( .not.select( ki-1 ) )cycle loop_140 @@ -82402,9 +82393,9 @@ module stdlib_linalg_lapack_${ri}$ ! compute the ki-th eigenvalue (wr,wi). wr = t( ki, ki ) wi = zero - if( ip/=0 )wi = sqrt( abs( t( ki, ki-1 ) ) )*sqrt( abs( t( ki-1, ki ) ) ) + if( ip/=0_${ik}$ )wi = sqrt( abs( t( ki, ki-1 ) ) )*sqrt( abs( t( ki-1, ki ) ) ) smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum ) - if( ip==0 ) then + if( ip==0_${ik}$ ) then ! -------------------------------------------------------- ! real right eigenvector work( ki + iv*n ) = one @@ -82414,60 +82405,60 @@ module stdlib_linalg_lapack_${ri}$ end do ! solve upper quasi-triangular system: ! [ t(1:ki-1,1:ki-1) - wr ]*x = scale*work. - jnxt = ki - 1 + jnxt = ki - 1_${ik}$ loop_60: do j = ki - 1, 1, -1 if( j>jnxt )cycle loop_60 j1 = j j2 = j - jnxt = j - 1 - if( j>1 ) then + jnxt = j - 1_${ik}$ + if( j>1_${ik}$ ) then if( t( j, j-1 )/=zero ) then - j1 = j - 1 - jnxt = j - 2 + j1 = j - 1_${ik}$ + jnxt = j - 2_${ik}$ end if end if if( j1==j2 ) then ! 1-by-1 diagonal block - call stdlib_${ri}$laln2( .false., 1, 1, smin, one, t( j, j ),ldt, one, one, & - work( j+iv*n ), n, wr,zero, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_${ri}$laln2( .false., 1_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+iv*n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr ) ! scale x(1,1) to avoid overflow when updating ! the right-hand side. if( xnorm>one ) then if( work( j )>bignum / xnorm ) then - x( 1, 1 ) = x( 1, 1 ) / xnorm + x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm scale = scale / xnorm end if end if ! scale if necessary - if( scale/=one )call stdlib_${ri}$scal( ki, scale, work( 1+iv*n ), 1 ) + if( scale/=one )call stdlib${ii}$_${ri}$scal( ki, scale, work( 1_${ik}$+iv*n ), 1_${ik}$ ) - work( j+iv*n ) = x( 1, 1 ) + work( j+iv*n ) = x( 1_${ik}$, 1_${ik}$ ) ! update right-hand side - call stdlib_${ri}$axpy( j-1, -x( 1, 1 ), t( 1, j ), 1,work( 1+iv*n ), 1 ) + call stdlib${ii}$_${ri}$axpy( j-1, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+iv*n ), 1_${ik}$ ) else ! 2-by-2 diagonal block - call stdlib_${ri}$laln2( .false., 2, 1, smin, one,t( j-1, j-1 ), ldt, one, & - one,work( j-1+iv*n ), n, wr, zero, x, 2,scale, xnorm, ierr ) + call stdlib${ii}$_${ri}$laln2( .false., 2_${ik}$, 1_${ik}$, smin, one,t( j-1, j-1 ), ldt, one, & + one,work( j-1+iv*n ), n, wr, zero, x, 2_${ik}$,scale, xnorm, ierr ) ! scale x(1,1) and x(2,1) to avoid overflow when ! updating the right-hand side. if( xnorm>one ) then beta = max( work( j-1 ), work( j ) ) if( beta>bignum / xnorm ) then - x( 1, 1 ) = x( 1, 1 ) / xnorm - x( 2, 1 ) = x( 2, 1 ) / xnorm + x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm + x( 2_${ik}$, 1_${ik}$ ) = x( 2_${ik}$, 1_${ik}$ ) / xnorm scale = scale / xnorm end if end if ! scale if necessary - if( scale/=one )call stdlib_${ri}$scal( ki, scale, work( 1+iv*n ), 1 ) + if( scale/=one )call stdlib${ii}$_${ri}$scal( ki, scale, work( 1_${ik}$+iv*n ), 1_${ik}$ ) - work( j-1+iv*n ) = x( 1, 1 ) - work( j +iv*n ) = x( 2, 1 ) + work( j-1+iv*n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j +iv*n ) = x( 2_${ik}$, 1_${ik}$ ) ! update right-hand side - call stdlib_${ri}$axpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,work( 1+iv*n ), 1 ) + call stdlib${ii}$_${ri}$axpy( j-2, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+iv*n ), 1_${ik}$ ) - call stdlib_${ri}$axpy( j-2, -x( 2, 1 ), t( 1, j ), 1,work( 1+iv*n ), 1 ) + call stdlib${ii}$_${ri}$axpy( j-2, -x( 2_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+iv*n ), 1_${ik}$ ) end if end do loop_60 @@ -82475,21 +82466,21 @@ module stdlib_linalg_lapack_${ri}$ if( .not.over ) then ! ------------------------------ ! no back-transform: copy x to vr and normalize. - call stdlib_${ri}$copy( ki, work( 1 + iv*n ), 1, vr( 1, is ), 1 ) - ii = stdlib_i${ri}$amax( ki, vr( 1, is ), 1 ) + call stdlib${ii}$_${ri}$copy( ki, work( 1_${ik}$ + iv*n ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ ) + ii = stdlib${ii}$_i${ri}$amax( ki, vr( 1_${ik}$, is ), 1_${ik}$ ) remax = one / abs( vr( ii, is ) ) - call stdlib_${ri}$scal( ki, remax, vr( 1, is ), 1 ) + call stdlib${ii}$_${ri}$scal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ ) do k = ki + 1, n vr( k, is ) = zero end do - else if( nb==1 ) then + else if( nb==1_${ik}$ ) then ! ------------------------------ ! version 1: back-transform each vector with gemv, q*x. - if( ki>1 )call stdlib_${ri}$gemv( 'N', n, ki-1, one, vr, ldvr,work( 1 + iv*n ), & - 1, work( ki + iv*n ),vr( 1, ki ), 1 ) - ii = stdlib_i${ri}$amax( n, vr( 1, ki ), 1 ) + if( ki>1_${ik}$ )call stdlib${ii}$_${ri}$gemv( 'N', n, ki-1, one, vr, ldvr,work( 1_${ik}$ + iv*n ), & + 1_${ik}$, work( ki + iv*n ),vr( 1_${ik}$, ki ), 1_${ik}$ ) + ii = stdlib${ii}$_i${ri}$amax( n, vr( 1_${ik}$, ki ), 1_${ik}$ ) remax = one / abs( vr( ii, ki ) ) - call stdlib_${ri}$scal( n, remax, vr( 1, ki ), 1 ) + call stdlib${ii}$_${ri}$scal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ ) else ! ------------------------------ ! version 2: back-transform block of vectors with gemm @@ -82522,77 +82513,77 @@ module stdlib_linalg_lapack_${ri}$ end do ! solve upper quasi-triangular system: ! [ t(1:ki-2,1:ki-2) - (wr+i*wi) ]*x = scale*(work+i*work2) - jnxt = ki - 2 + jnxt = ki - 2_${ik}$ loop_90: do j = ki - 2, 1, -1 if( j>jnxt )cycle loop_90 j1 = j j2 = j - jnxt = j - 1 - if( j>1 ) then + jnxt = j - 1_${ik}$ + if( j>1_${ik}$ ) then if( t( j, j-1 )/=zero ) then - j1 = j - 1 - jnxt = j - 2 + j1 = j - 1_${ik}$ + jnxt = j - 2_${ik}$ end if end if if( j1==j2 ) then ! 1-by-1 diagonal block - call stdlib_${ri}$laln2( .false., 1, 2, smin, one, t( j, j ),ldt, one, one, & - work( j+(iv-1)*n ), n,wr, wi, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_${ri}$laln2( .false., 1_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+(iv-1)*n ), n,wr, wi, x, 2_${ik}$, scale, xnorm, ierr ) ! scale x(1,1) and x(1,2) to avoid overflow when ! updating the right-hand side. if( xnorm>one ) then if( work( j )>bignum / xnorm ) then - x( 1, 1 ) = x( 1, 1 ) / xnorm - x( 1, 2 ) = x( 1, 2 ) / xnorm + x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm + x( 1_${ik}$, 2_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ ) / xnorm scale = scale / xnorm end if end if ! scale if necessary if( scale/=one ) then - call stdlib_${ri}$scal( ki, scale, work( 1+(iv-1)*n ), 1 ) - call stdlib_${ri}$scal( ki, scale, work( 1+(iv )*n ), 1 ) + call stdlib${ii}$_${ri}$scal( ki, scale, work( 1_${ik}$+(iv-1)*n ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( ki, scale, work( 1_${ik}$+(iv )*n ), 1_${ik}$ ) end if - work( j+(iv-1)*n ) = x( 1, 1 ) - work( j+(iv )*n ) = x( 1, 2 ) + work( j+(iv-1)*n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+(iv )*n ) = x( 1_${ik}$, 2_${ik}$ ) ! update the right-hand side - call stdlib_${ri}$axpy( j-1, -x( 1, 1 ), t( 1, j ), 1,work( 1+(iv-1)*n ), 1 ) + call stdlib${ii}$_${ri}$axpy( j-1, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+(iv-1)*n ), 1_${ik}$ ) - call stdlib_${ri}$axpy( j-1, -x( 1, 2 ), t( 1, j ), 1,work( 1+(iv )*n ), 1 ) + call stdlib${ii}$_${ri}$axpy( j-1, -x( 1_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+(iv )*n ), 1_${ik}$ ) else ! 2-by-2 diagonal block - call stdlib_${ri}$laln2( .false., 2, 2, smin, one,t( j-1, j-1 ), ldt, one, & - one,work( j-1+(iv-1)*n ), n, wr, wi, x, 2,scale, xnorm, ierr ) + call stdlib${ii}$_${ri}$laln2( .false., 2_${ik}$, 2_${ik}$, smin, one,t( j-1, j-1 ), ldt, one, & + one,work( j-1+(iv-1)*n ), n, wr, wi, x, 2_${ik}$,scale, xnorm, ierr ) ! scale x to avoid overflow when updating ! the right-hand side. if( xnorm>one ) then beta = max( work( j-1 ), work( j ) ) if( beta>bignum / xnorm ) then rec = one / xnorm - x( 1, 1 ) = x( 1, 1 )*rec - x( 1, 2 ) = x( 1, 2 )*rec - x( 2, 1 ) = x( 2, 1 )*rec - x( 2, 2 ) = x( 2, 2 )*rec + x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ )*rec + x( 1_${ik}$, 2_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ )*rec + x( 2_${ik}$, 1_${ik}$ ) = x( 2_${ik}$, 1_${ik}$ )*rec + x( 2_${ik}$, 2_${ik}$ ) = x( 2_${ik}$, 2_${ik}$ )*rec scale = scale*rec end if end if ! scale if necessary if( scale/=one ) then - call stdlib_${ri}$scal( ki, scale, work( 1+(iv-1)*n ), 1 ) - call stdlib_${ri}$scal( ki, scale, work( 1+(iv )*n ), 1 ) + call stdlib${ii}$_${ri}$scal( ki, scale, work( 1_${ik}$+(iv-1)*n ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( ki, scale, work( 1_${ik}$+(iv )*n ), 1_${ik}$ ) end if - work( j-1+(iv-1)*n ) = x( 1, 1 ) - work( j +(iv-1)*n ) = x( 2, 1 ) - work( j-1+(iv )*n ) = x( 1, 2 ) - work( j +(iv )*n ) = x( 2, 2 ) + work( j-1+(iv-1)*n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j +(iv-1)*n ) = x( 2_${ik}$, 1_${ik}$ ) + work( j-1+(iv )*n ) = x( 1_${ik}$, 2_${ik}$ ) + work( j +(iv )*n ) = x( 2_${ik}$, 2_${ik}$ ) ! update the right-hand side - call stdlib_${ri}$axpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,work( 1+(iv-1)*n ),& - 1 ) - call stdlib_${ri}$axpy( j-2, -x( 2, 1 ), t( 1, j ), 1,work( 1+(iv-1)*n ), & - 1 ) - call stdlib_${ri}$axpy( j-2, -x( 1, 2 ), t( 1, j-1 ), 1,work( 1+(iv )*n ), & - 1 ) - call stdlib_${ri}$axpy( j-2, -x( 2, 2 ), t( 1, j ), 1,work( 1+(iv )*n ), 1 ) + call stdlib${ii}$_${ri}$axpy( j-2, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+(iv-1)*n ),& + 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( j-2, -x( 2_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+(iv-1)*n ), & + 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( j-2, -x( 1_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+(iv )*n ), & + 1_${ik}$ ) + call stdlib${ii}$_${ri}$axpy( j-2, -x( 2_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+(iv )*n ), 1_${ik}$ ) end if end do loop_90 @@ -82600,38 +82591,38 @@ module stdlib_linalg_lapack_${ri}$ if( .not.over ) then ! ------------------------------ ! no back-transform: copy x to vr and normalize. - call stdlib_${ri}$copy( ki, work( 1+(iv-1)*n ), 1, vr(1,is-1), 1 ) - call stdlib_${ri}$copy( ki, work( 1+(iv )*n ), 1, vr(1,is ), 1 ) + call stdlib${ii}$_${ri}$copy( ki, work( 1_${ik}$+(iv-1)*n ), 1_${ik}$, vr(1_${ik}$,is-1), 1_${ik}$ ) + call stdlib${ii}$_${ri}$copy( ki, work( 1_${ik}$+(iv )*n ), 1_${ik}$, vr(1_${ik}$,is ), 1_${ik}$ ) emax = zero do k = 1, ki emax = max( emax, abs( vr( k, is-1 ) )+abs( vr( k, is ) ) ) end do remax = one / emax - call stdlib_${ri}$scal( ki, remax, vr( 1, is-1 ), 1 ) - call stdlib_${ri}$scal( ki, remax, vr( 1, is ), 1 ) + call stdlib${ii}$_${ri}$scal( ki, remax, vr( 1_${ik}$, is-1 ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ ) do k = ki + 1, n vr( k, is-1 ) = zero vr( k, is ) = zero end do - else if( nb==1 ) then + else if( nb==1_${ik}$ ) then ! ------------------------------ ! version 1: back-transform each vector with gemv, q*x. - if( ki>2 ) then - call stdlib_${ri}$gemv( 'N', n, ki-2, one, vr, ldvr,work( 1 + (iv-1)*n ), & - 1,work( ki-1 + (iv-1)*n ), vr(1,ki-1), 1) - call stdlib_${ri}$gemv( 'N', n, ki-2, one, vr, ldvr,work( 1 + (iv)*n ), 1,& - work( ki + (iv)*n ), vr( 1, ki ), 1 ) + if( ki>2_${ik}$ ) then + call stdlib${ii}$_${ri}$gemv( 'N', n, ki-2, one, vr, ldvr,work( 1_${ik}$ + (iv-1)*n ), & + 1_${ik}$,work( ki-1 + (iv-1)*n ), vr(1_${ik}$,ki-1), 1_${ik}$) + call stdlib${ii}$_${ri}$gemv( 'N', n, ki-2, one, vr, ldvr,work( 1_${ik}$ + (iv)*n ), 1_${ik}$,& + work( ki + (iv)*n ), vr( 1_${ik}$, ki ), 1_${ik}$ ) else - call stdlib_${ri}$scal( n, work(ki-1+(iv-1)*n), vr(1,ki-1), 1) - call stdlib_${ri}$scal( n, work(ki +(iv )*n), vr(1,ki ), 1) + call stdlib${ii}$_${ri}$scal( n, work(ki-1+(iv-1)*n), vr(1_${ik}$,ki-1), 1_${ik}$) + call stdlib${ii}$_${ri}$scal( n, work(ki +(iv )*n), vr(1_${ik}$,ki ), 1_${ik}$) end if emax = zero do k = 1, n emax = max( emax, abs( vr( k, ki-1 ) )+abs( vr( k, ki ) ) ) end do remax = one / emax - call stdlib_${ri}$scal( n, remax, vr( 1, ki-1 ), 1 ) - call stdlib_${ri}$scal( n, remax, vr( 1, ki ), 1 ) + call stdlib${ii}$_${ri}$scal( n, remax, vr( 1_${ik}$, ki-1 ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ ) else ! ------------------------------ ! version 2: back-transform block of vectors with gemm @@ -82642,32 +82633,32 @@ module stdlib_linalg_lapack_${ri}$ end do iscomplex( iv-1 ) = -ip iscomplex( iv ) = ip - iv = iv - 1 + iv = iv - 1_${ik}$ ! back-transform and normalization is done below end if end if - if( nb>1 ) then + if( nb>1_${ik}$ ) then ! -------------------------------------------------------- ! blocked version of back-transform ! for complex case, ki2 includes both vectors (ki-1 and ki) - if( ip==0 ) then + if( ip==0_${ik}$ ) then ki2 = ki else - ki2 = ki - 1 + ki2 = ki - 1_${ik}$ end if ! columns iv:nb of work are valid vectors. ! when the number of vectors stored reaches nb-1 or nb, ! or if this was last vector, do the gemm - if( (iv<=2) .or. (ki2==1) ) then - call stdlib_${ri}$gemm( 'N', 'N', n, nb-iv+1, ki2+nb-iv, one,vr, ldvr,work( 1 + & - (iv)*n ), n,zero,work( 1 + (nb+iv)*n ), n ) + if( (iv<=2_${ik}$) .or. (ki2==1_${ik}$) ) then + call stdlib${ii}$_${ri}$gemm( 'N', 'N', n, nb-iv+1, ki2+nb-iv, one,vr, ldvr,work( 1_${ik}$ + & + (iv)*n ), n,zero,work( 1_${ik}$ + (nb+iv)*n ), n ) ! normalize vectors do k = iv, nb - if( iscomplex(k)==0 ) then + if( iscomplex(k)==0_${ik}$ ) then ! real eigenvector - ii = stdlib_i${ri}$amax( n, work( 1 + (nb+k)*n ), 1 ) + ii = stdlib${ii}$_i${ri}$amax( n, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ ) remax = one / abs( work( ii + (nb+k)*n ) ) - else if( iscomplex(k)==1 ) then + else if( iscomplex(k)==1_${ik}$ ) then ! first eigenvector of conjugate pair emax = zero do ii = 1, n @@ -82679,17 +82670,17 @@ module stdlib_linalg_lapack_${ri}$ ! second eigenvector of conjugate pair ! reuse same remax as previous k end if - call stdlib_${ri}$scal( n, remax, work( 1 + (nb+k)*n ), 1 ) + call stdlib${ii}$_${ri}$scal( n, remax, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ ) end do - call stdlib_${ri}$lacpy( 'F', n, nb-iv+1,work( 1 + (nb+iv)*n ), n,vr( 1, ki2 ), & + call stdlib${ii}$_${ri}$lacpy( 'F', n, nb-iv+1,work( 1_${ik}$ + (nb+iv)*n ), n,vr( 1_${ik}$, ki2 ), & ldvr ) iv = nb else - iv = iv - 1 + iv = iv - 1_${ik}$ end if end if ! blocked back-transform - is = is - 1 - if( ip/=0 )is = is - 1 + is = is - 1_${ik}$ + if( ip/=0_${ik}$ )is = is - 1_${ik}$ end do loop_140 end if if( leftv ) then @@ -82700,24 +82691,24 @@ module stdlib_linalg_lapack_${ri}$ ! non-blocked version always uses iv=1; ! blocked version starts with iv=1, goes up to nb-1 or nb. ! (note the "0-th" column is used for 1-norms computed above.) - iv = 1 - ip = 0 - is = 1 + iv = 1_${ik}$ + ip = 0_${ik}$ + is = 1_${ik}$ loop_260: do ki = 1, n - if( ip==1 ) then + if( ip==1_${ik}$ ) then ! previous iteration (ki-1) was first of conjugate pair, ! so this ki is second of conjugate pair; skip to end of loop - ip = -1 + ip = -1_${ik}$ cycle loop_260 else if( ki==n ) then ! last column, so this ki must be real eigenvalue - ip = 0 + ip = 0_${ik}$ else if( t( ki+1, ki )==zero ) then ! zero on sub-diagonal, so this ki is real eigenvalue - ip = 0 + ip = 0_${ik}$ else ! non-zero on sub-diagonal, so this ki is first of conjugate pair - ip = 1 + ip = 1_${ik}$ end if if( somev ) then if( .not.select( ki ) )cycle loop_260 @@ -82725,9 +82716,9 @@ module stdlib_linalg_lapack_${ri}$ ! compute the ki-th eigenvalue (wr,wi). wr = t( ki, ki ) wi = zero - if( ip/=0 )wi = sqrt( abs( t( ki, ki+1 ) ) )*sqrt( abs( t( ki+1, ki ) ) ) + if( ip/=0_${ik}$ )wi = sqrt( abs( t( ki, ki+1 ) ) )*sqrt( abs( t( ki+1, ki ) ) ) smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum ) - if( ip==0 ) then + if( ip==0_${ik}$ ) then ! -------------------------------------------------------- ! real left eigenvector work( ki + iv*n ) = one @@ -82739,16 +82730,16 @@ module stdlib_linalg_lapack_${ri}$ ! [ t(ki+1:n,ki+1:n) - wr ]**t * x = scale*work vmax = one vcrit = bignum - jnxt = ki + 1 + jnxt = ki + 1_${ik}$ loop_170: do j = ki + 1, n if( jvcrit ) then rec = one / vmax - call stdlib_${ri}$scal( n-ki+1, rec, work( ki+iv*n ), 1 ) + call stdlib${ii}$_${ri}$scal( n-ki+1, rec, work( ki+iv*n ), 1_${ik}$ ) vmax = one vcrit = bignum end if - work( j+iv*n ) = work( j+iv*n ) -stdlib_${ri}$dot( j-ki-1, t( ki+1, j ), 1,& - work( ki+1+iv*n ), 1 ) + work( j+iv*n ) = work( j+iv*n ) -stdlib${ii}$_${ri}$dot( j-ki-1, t( ki+1, j ), 1_${ik}$,& + work( ki+1+iv*n ), 1_${ik}$ ) ! solve [ t(j,j) - wr ]**t * x = work - call stdlib_${ri}$laln2( .false., 1, 1, smin, one, t( j, j ),ldt, one, one, & - work( j+iv*n ), n, wr,zero, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_${ri}$laln2( .false., 1_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+iv*n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr ) ! scale if necessary - if( scale/=one )call stdlib_${ri}$scal( n-ki+1, scale, work( ki+iv*n ), 1 ) + if( scale/=one )call stdlib${ii}$_${ri}$scal( n-ki+1, scale, work( ki+iv*n ), 1_${ik}$ ) - work( j+iv*n ) = x( 1, 1 ) + work( j+iv*n ) = x( 1_${ik}$, 1_${ik}$ ) vmax = max( abs( work( j+iv*n ) ), vmax ) vcrit = bignum / vmax else @@ -82779,24 +82770,24 @@ module stdlib_linalg_lapack_${ri}$ beta = max( work( j ), work( j+1 ) ) if( beta>vcrit ) then rec = one / vmax - call stdlib_${ri}$scal( n-ki+1, rec, work( ki+iv*n ), 1 ) + call stdlib${ii}$_${ri}$scal( n-ki+1, rec, work( ki+iv*n ), 1_${ik}$ ) vmax = one vcrit = bignum end if - work( j+iv*n ) = work( j+iv*n ) -stdlib_${ri}$dot( j-ki-1, t( ki+1, j ), 1,& - work( ki+1+iv*n ), 1 ) - work( j+1+iv*n ) = work( j+1+iv*n ) -stdlib_${ri}$dot( j-ki-1, t( ki+1, j+1 )& - , 1,work( ki+1+iv*n ), 1 ) + work( j+iv*n ) = work( j+iv*n ) -stdlib${ii}$_${ri}$dot( j-ki-1, t( ki+1, j ), 1_${ik}$,& + work( ki+1+iv*n ), 1_${ik}$ ) + work( j+1+iv*n ) = work( j+1+iv*n ) -stdlib${ii}$_${ri}$dot( j-ki-1, t( ki+1, j+1 )& + , 1_${ik}$,work( ki+1+iv*n ), 1_${ik}$ ) ! solve ! [ t(j,j)-wr t(j,j+1) ]**t * x = scale*( work1 ) ! [ t(j+1,j) t(j+1,j+1)-wr ] ( work2 ) - call stdlib_${ri}$laln2( .true., 2, 1, smin, one, t( j, j ),ldt, one, one, & - work( j+iv*n ), n, wr,zero, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_${ri}$laln2( .true., 2_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+iv*n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr ) ! scale if necessary - if( scale/=one )call stdlib_${ri}$scal( n-ki+1, scale, work( ki+iv*n ), 1 ) + if( scale/=one )call stdlib${ii}$_${ri}$scal( n-ki+1, scale, work( ki+iv*n ), 1_${ik}$ ) - work( j +iv*n ) = x( 1, 1 ) - work( j+1+iv*n ) = x( 2, 1 ) + work( j +iv*n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+1+iv*n ) = x( 2_${ik}$, 1_${ik}$ ) vmax = max( abs( work( j +iv*n ) ),abs( work( j+1+iv*n ) ), vmax ) vcrit = bignum / vmax @@ -82806,21 +82797,21 @@ module stdlib_linalg_lapack_${ri}$ if( .not.over ) then ! ------------------------------ ! no back-transform: copy x to vl and normalize. - call stdlib_${ri}$copy( n-ki+1, work( ki + iv*n ), 1,vl( ki, is ), 1 ) - ii = stdlib_i${ri}$amax( n-ki+1, vl( ki, is ), 1 ) + ki - 1 + call stdlib${ii}$_${ri}$copy( n-ki+1, work( ki + iv*n ), 1_${ik}$,vl( ki, is ), 1_${ik}$ ) + ii = stdlib${ii}$_i${ri}$amax( n-ki+1, vl( ki, is ), 1_${ik}$ ) + ki - 1_${ik}$ remax = one / abs( vl( ii, is ) ) - call stdlib_${ri}$scal( n-ki+1, remax, vl( ki, is ), 1 ) + call stdlib${ii}$_${ri}$scal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ ) do k = 1, ki - 1 vl( k, is ) = zero end do - else if( nb==1 ) then + else if( nb==1_${ik}$ ) then ! ------------------------------ ! version 1: back-transform each vector with gemv, q*x. - if( kivcrit ) then rec = one / vmax - call stdlib_${ri}$scal( n-ki+1, rec, work(ki+(iv )*n), 1 ) - call stdlib_${ri}$scal( n-ki+1, rec, work(ki+(iv+1)*n), 1 ) + call stdlib${ii}$_${ri}$scal( n-ki+1, rec, work(ki+(iv )*n), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n-ki+1, rec, work(ki+(iv+1)*n), 1_${ik}$ ) vmax = one vcrit = bignum end if - work( j+(iv )*n ) = work( j+(iv)*n ) -stdlib_${ri}$dot( j-ki-2, t( ki+2, j )& - , 1,work( ki+2+(iv)*n ), 1 ) - work( j+(iv+1)*n ) = work( j+(iv+1)*n ) -stdlib_${ri}$dot( j-ki-2, t( ki+2, & - j ), 1,work( ki+2+(iv+1)*n ), 1 ) + work( j+(iv )*n ) = work( j+(iv)*n ) -stdlib${ii}$_${ri}$dot( j-ki-2, t( ki+2, j )& + , 1_${ik}$,work( ki+2+(iv)*n ), 1_${ik}$ ) + work( j+(iv+1)*n ) = work( j+(iv+1)*n ) -stdlib${ii}$_${ri}$dot( j-ki-2, t( ki+2, & + j ), 1_${ik}$,work( ki+2+(iv+1)*n ), 1_${ik}$ ) ! solve [ t(j,j)-(wr-i*wi) ]*(x11+i*x12)= wk+i*wk2 - call stdlib_${ri}$laln2( .false., 1, 2, smin, one, t( j, j ),ldt, one, one, & - work( j+iv*n ), n, wr,-wi, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_${ri}$laln2( .false., 1_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+iv*n ), n, wr,-wi, x, 2_${ik}$, scale, xnorm, ierr ) ! scale if necessary if( scale/=one ) then - call stdlib_${ri}$scal( n-ki+1, scale, work(ki+(iv )*n), 1) - call stdlib_${ri}$scal( n-ki+1, scale, work(ki+(iv+1)*n), 1) + call stdlib${ii}$_${ri}$scal( n-ki+1, scale, work(ki+(iv )*n), 1_${ik}$) + call stdlib${ii}$_${ri}$scal( n-ki+1, scale, work(ki+(iv+1)*n), 1_${ik}$) end if - work( j+(iv )*n ) = x( 1, 1 ) - work( j+(iv+1)*n ) = x( 1, 2 ) + work( j+(iv )*n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+(iv+1)*n ) = x( 1_${ik}$, 2_${ik}$ ) vmax = max( abs( work( j+(iv )*n ) ),abs( work( j+(iv+1)*n ) ), vmax ) vcrit = bignum / vmax @@ -82903,35 +82894,35 @@ module stdlib_linalg_lapack_${ri}$ beta = max( work( j ), work( j+1 ) ) if( beta>vcrit ) then rec = one / vmax - call stdlib_${ri}$scal( n-ki+1, rec, work(ki+(iv )*n), 1 ) - call stdlib_${ri}$scal( n-ki+1, rec, work(ki+(iv+1)*n), 1 ) + call stdlib${ii}$_${ri}$scal( n-ki+1, rec, work(ki+(iv )*n), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n-ki+1, rec, work(ki+(iv+1)*n), 1_${ik}$ ) vmax = one vcrit = bignum end if - work( j +(iv )*n ) = work( j+(iv)*n ) -stdlib_${ri}$dot( j-ki-2, t( ki+2, & - j ), 1,work( ki+2+(iv)*n ), 1 ) - work( j +(iv+1)*n ) = work( j+(iv+1)*n ) -stdlib_${ri}$dot( j-ki-2, t( ki+2,& - j ), 1,work( ki+2+(iv+1)*n ), 1 ) - work( j+1+(iv )*n ) = work( j+1+(iv)*n ) -stdlib_${ri}$dot( j-ki-2, t( ki+2,& - j+1 ), 1,work( ki+2+(iv)*n ), 1 ) - work( j+1+(iv+1)*n ) = work( j+1+(iv+1)*n ) -stdlib_${ri}$dot( j-ki-2, t( ki+& - 2, j+1 ), 1,work( ki+2+(iv+1)*n ), 1 ) + work( j +(iv )*n ) = work( j+(iv)*n ) -stdlib${ii}$_${ri}$dot( j-ki-2, t( ki+2, & + j ), 1_${ik}$,work( ki+2+(iv)*n ), 1_${ik}$ ) + work( j +(iv+1)*n ) = work( j+(iv+1)*n ) -stdlib${ii}$_${ri}$dot( j-ki-2, t( ki+2,& + j ), 1_${ik}$,work( ki+2+(iv+1)*n ), 1_${ik}$ ) + work( j+1+(iv )*n ) = work( j+1+(iv)*n ) -stdlib${ii}$_${ri}$dot( j-ki-2, t( ki+2,& + j+1 ), 1_${ik}$,work( ki+2+(iv)*n ), 1_${ik}$ ) + work( j+1+(iv+1)*n ) = work( j+1+(iv+1)*n ) -stdlib${ii}$_${ri}$dot( j-ki-2, t( ki+& + 2_${ik}$, j+1 ), 1_${ik}$,work( ki+2+(iv+1)*n ), 1_${ik}$ ) ! solve 2-by-2 complex linear equation ! [ (t(j,j) t(j,j+1) )**t - (wr-i*wi)*i ]*x = scale*b ! [ (t(j+1,j) t(j+1,j+1)) ] - call stdlib_${ri}$laln2( .true., 2, 2, smin, one, t( j, j ),ldt, one, one, & - work( j+iv*n ), n, wr,-wi, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_${ri}$laln2( .true., 2_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+iv*n ), n, wr,-wi, x, 2_${ik}$, scale, xnorm, ierr ) ! scale if necessary if( scale/=one ) then - call stdlib_${ri}$scal( n-ki+1, scale, work(ki+(iv )*n), 1) - call stdlib_${ri}$scal( n-ki+1, scale, work(ki+(iv+1)*n), 1) + call stdlib${ii}$_${ri}$scal( n-ki+1, scale, work(ki+(iv )*n), 1_${ik}$) + call stdlib${ii}$_${ri}$scal( n-ki+1, scale, work(ki+(iv+1)*n), 1_${ik}$) end if - work( j +(iv )*n ) = x( 1, 1 ) - work( j +(iv+1)*n ) = x( 1, 2 ) - work( j+1+(iv )*n ) = x( 2, 1 ) - work( j+1+(iv+1)*n ) = x( 2, 2 ) - vmax = max( abs( x( 1, 1 ) ), abs( x( 1, 2 ) ),abs( x( 2, 1 ) ), abs( x(& - 2, 2 ) ),vmax ) + work( j +(iv )*n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j +(iv+1)*n ) = x( 1_${ik}$, 2_${ik}$ ) + work( j+1+(iv )*n ) = x( 2_${ik}$, 1_${ik}$ ) + work( j+1+(iv+1)*n ) = x( 2_${ik}$, 2_${ik}$ ) + vmax = max( abs( x( 1_${ik}$, 1_${ik}$ ) ), abs( x( 1_${ik}$, 2_${ik}$ ) ),abs( x( 2_${ik}$, 1_${ik}$ ) ), abs( x(& + 2_${ik}$, 2_${ik}$ ) ),vmax ) vcrit = bignum / vmax end if end do loop_200 @@ -82939,40 +82930,40 @@ module stdlib_linalg_lapack_${ri}$ if( .not.over ) then ! ------------------------------ ! no back-transform: copy x to vl and normalize. - call stdlib_${ri}$copy( n-ki+1, work( ki + (iv )*n ), 1,vl( ki, is ), 1 ) + call stdlib${ii}$_${ri}$copy( n-ki+1, work( ki + (iv )*n ), 1_${ik}$,vl( ki, is ), 1_${ik}$ ) - call stdlib_${ri}$copy( n-ki+1, work( ki + (iv+1)*n ), 1,vl( ki, is+1 ), 1 ) + call stdlib${ii}$_${ri}$copy( n-ki+1, work( ki + (iv+1)*n ), 1_${ik}$,vl( ki, is+1 ), 1_${ik}$ ) emax = zero do k = ki, n emax = max( emax, abs( vl( k, is ) )+abs( vl( k, is+1 ) ) ) end do remax = one / emax - call stdlib_${ri}$scal( n-ki+1, remax, vl( ki, is ), 1 ) - call stdlib_${ri}$scal( n-ki+1, remax, vl( ki, is+1 ), 1 ) + call stdlib${ii}$_${ri}$scal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ ) + call stdlib${ii}$_${ri}$scal( n-ki+1, remax, vl( ki, is+1 ), 1_${ik}$ ) do k = 1, ki - 1 vl( k, is ) = zero vl( k, is+1 ) = zero end do - else if( nb==1 ) then + else if( nb==1_${ik}$ ) then ! ------------------------------ ! version 1: back-transform each vector with gemv, q*x. if( ki1 ) then + if( nb>1_${ik}$ ) then ! -------------------------------------------------------- ! blocked version of back-transform ! for complex case, ki2 includes both vectors (ki and ki+1) - if( ip==0 ) then + if( ip==0_${ik}$ ) then ki2 = ki else - ki2 = ki + 1 + ki2 = ki + 1_${ik}$ end if ! columns 1:iv of work are valid vectors. ! when the number of vectors stored reaches nb-1 or nb, ! or if this was last vector, do the gemm if( (iv>=nb-1) .or. (ki2==n) ) then - call stdlib_${ri}$gemm( 'N', 'N', n, iv, n-ki2+iv, one,vl( 1, ki2-iv+1 ), ldvl,& - work( ki2-iv+1 + (1)*n ), n,zero,work( 1 + (nb+1)*n ), n ) + call stdlib${ii}$_${ri}$gemm( 'N', 'N', n, iv, n-ki2+iv, one,vl( 1_${ik}$, ki2-iv+1 ), ldvl,& + work( ki2-iv+1 + (1_${ik}$)*n ), n,zero,work( 1_${ik}$ + (nb+1)*n ), n ) ! normalize vectors do k = 1, iv - if( iscomplex(k)==0) then + if( iscomplex(k)==0_${ik}$) then ! real eigenvector - ii = stdlib_i${ri}$amax( n, work( 1 + (nb+k)*n ), 1 ) + ii = stdlib${ii}$_i${ri}$amax( n, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ ) remax = one / abs( work( ii + (nb+k)*n ) ) - else if( iscomplex(k)==1) then + else if( iscomplex(k)==1_${ik}$) then ! first eigenvector of conjugate pair emax = zero do ii = 1, n @@ -83021,24 +83012,24 @@ module stdlib_linalg_lapack_${ri}$ ! second eigenvector of conjugate pair ! reuse same remax as previous k end if - call stdlib_${ri}$scal( n, remax, work( 1 + (nb+k)*n ), 1 ) + call stdlib${ii}$_${ri}$scal( n, remax, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ ) end do - call stdlib_${ri}$lacpy( 'F', n, iv,work( 1 + (nb+1)*n ), n,vl( 1, ki2-iv+1 ), & + call stdlib${ii}$_${ri}$lacpy( 'F', n, iv,work( 1_${ik}$ + (nb+1)*n ), n,vl( 1_${ik}$, ki2-iv+1 ), & ldvl ) - iv = 1 + iv = 1_${ik}$ else - iv = iv + 1 + iv = iv + 1_${ik}$ end if end if ! blocked back-transform - is = is + 1 - if( ip/=0 )is = is + 1 + is = is + 1_${ik}$ + if( ip/=0_${ik}$ )is = is + 1_${ik}$ end do loop_260 end if return - end subroutine stdlib_${ri}$trevc3 + end subroutine stdlib${ii}$_${ri}$trevc3 - subroutine stdlib_${ri}$trexc( compq, n, t, ldt, q, ldq, ifst, ilst, work,info ) + subroutine stdlib${ii}$_${ri}$trexc( compq, n, t, ldt, q, ldq, ifst, ilst, work,info ) !! DTREXC: reorders the real Schur factorization of a real matrix !! A = Q*T*Q**T, so that the diagonal block of T with row index IFST is !! moved to row ILST. @@ -83054,9 +83045,9 @@ module stdlib_linalg_lapack_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: compq - integer(ilp), intent(inout) :: ifst, ilst - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldq, ldt, n + integer(${ik}$), intent(inout) :: ifst, ilst + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldq, ldt, n ! Array Arguments real(${rk}$), intent(inout) :: q(ldq,*), t(ldt,*) real(${rk}$), intent(out) :: work(*) @@ -83064,112 +83055,112 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: wantq - integer(ilp) :: here, nbf, nbl, nbnext + integer(${ik}$) :: here, nbf, nbl, nbnext ! Intrinsic Functions intrinsic :: max ! Executable Statements ! decode and test the input arguments. - info = 0 + info = 0_${ik}$ wantq = stdlib_lsame( compq, 'V' ) if( .not.wantq .and. .not.stdlib_lsame( compq, 'N' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( ldtn ).and.( n>0 )) then - info = -7 - else if(( ilst<1 .or. ilst>n ).and.( n>0 )) then - info = -8 - end if - if( info/=0 ) then - call stdlib_xerbla( 'DTREXC', -info ) + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ + else if( ldtn ).and.( n>0_${ik}$ )) then + info = -7_${ik}$ + else if(( ilst<1_${ik}$ .or. ilst>n ).and.( n>0_${ik}$ )) then + info = -8_${ik}$ + end if + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'DTREXC', -info ) return end if ! quick return if possible if( n<=1 )return ! determine the first row of specified block ! and find out it is 1 by 1 or 2 by 2. - if( ifst>1 ) then - if( t( ifst, ifst-1 )/=zero )ifst = ifst - 1 + if( ifst>1_${ik}$ ) then + if( t( ifst, ifst-1 )/=zero )ifst = ifst - 1_${ik}$ end if - nbf = 1 + nbf = 1_${ik}$ if( ifst1 ) then - if( t( ilst, ilst-1 )/=zero )ilst = ilst - 1 + if( ilst>1_${ik}$ ) then + if( t( ilst, ilst-1 )/=zero )ilst = ilst - 1_${ik}$ end if - nbl = 1 + nbl = 1_${ik}$ if( ilst=3 ) then - if( t( here-1, here-2 )/=zero )nbnext = 2 + nbnext = 1_${ik}$ + if( here>=3_${ik}$ ) then + if( t( here-1, here-2 )/=zero )nbnext = 2_${ik}$ end if - call stdlib_${ri}$laexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext,nbf, work, & + call stdlib${ii}$_${ri}$laexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext,nbf, work, & info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then ilst = here return end if here = here - nbnext ! test if 2 by 2 block breaks into two 1 by 1 blocks - if( nbf==2 ) then - if( t( here+1, here )==zero )nbf = 3 + if( nbf==2_${ik}$ ) then + if( t( here+1, here )==zero )nbf = 3_${ik}$ end if else ! current block consists of two 1 by 1 blocks each of which ! must be swapped individually - nbnext = 1 - if( here>=3 ) then - if( t( here-1, here-2 )/=zero )nbnext = 2 + nbnext = 1_${ik}$ + if( here>=3_${ik}$ ) then + if( t( here-1, here-2 )/=zero )nbnext = 2_${ik}$ end if - call stdlib_${ri}$laexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext,1, work, info ) + call stdlib${ii}$_${ri}$laexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext,1_${ik}$, work, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then ilst = here return end if - if( nbnext==1 ) then + if( nbnext==1_${ik}$ ) then ! swap two 1 by 1 blocks, no problems possible - call stdlib_${ri}$laexc( wantq, n, t, ldt, q, ldq, here, nbnext, 1,work, info ) + call stdlib${ii}$_${ri}$laexc( wantq, n, t, ldt, q, ldq, here, nbnext, 1_${ik}$,work, info ) - here = here - 1 + here = here - 1_${ik}$ else ! recompute nbnext in case 2 by 2 split - if( t( here, here-1 )==zero )nbnext = 1 - if( nbnext==2 ) then + if( t( here, here-1 )==zero )nbnext = 1_${ik}$ + if( nbnext==2_${ik}$ ) then ! 2 by 2 block did not split - call stdlib_${ri}$laexc( wantq, n, t, ldt, q, ldq, here-1, 2, 1,work, info ) + call stdlib${ii}$_${ri}$laexc( wantq, n, t, ldt, q, ldq, here-1, 2_${ik}$, 1_${ik}$,work, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then ilst = here return end if - here = here - 2 + here = here - 2_${ik}$ else ! 2 by 2 block did split - call stdlib_${ri}$laexc( wantq, n, t, ldt, q, ldq, here, 1, 1,work, info ) + call stdlib${ii}$_${ri}$laexc( wantq, n, t, ldt, q, ldq, here, 1_${ik}$, 1_${ik}$,work, info ) - call stdlib_${ri}$laexc( wantq, n, t, ldt, q, ldq, here-1, 1, 1,work, info ) + call stdlib${ii}$_${ri}$laexc( wantq, n, t, ldt, q, ldq, here-1, 1_${ik}$, 1_${ik}$,work, info ) - here = here - 2 + here = here - 2_${ik}$ end if end if end if @@ -83239,10 +83230,10 @@ module stdlib_linalg_lapack_${ri}$ end if ilst = here return - end subroutine stdlib_${ri}$trexc + end subroutine stdlib${ii}$_${ri}$trexc - pure subroutine stdlib_${ri}$trrfs( uplo, trans, diag, n, nrhs, a, lda, b, ldb, x,ldx, ferr, berr,& + pure subroutine stdlib${ii}$_${ri}$trrfs( uplo, trans, diag, n, nrhs, a, lda, b, ldb, x,ldx, ferr, berr,& !! DTRRFS: provides error bounds and backward error estimates for the !! solution to a system of linear equations with a triangular !! coefficient matrix. @@ -83255,10 +83246,10 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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, ldx, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldx, n, nrhs ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(${rk}$), intent(in) :: a(lda,*), b(ldb,*), x(ldx,*) real(${rk}$), intent(out) :: berr(*), ferr(*), work(*) ! ===================================================================== @@ -83267,42 +83258,42 @@ module stdlib_linalg_lapack_${ri}$ ! Local Scalars logical(lk) :: notran, nounit, upper character :: transt - integer(ilp) :: i, j, k, kase, nz + integer(${ik}$) :: i, j, k, kase, nz real(${rk}$) :: eps, lstres, s, safe1, safe2, safmin, xk ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) notran = stdlib_lsame( trans, 'N' ) nounit = stdlib_lsame( diag, 'N' ) 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 - else if( n<0 ) then - info = -4 - else if( nrhs<0 ) then - info = -5 - else if( ldaknext )cycle loop_50 - if( k==1 ) then + if( k==1_${ik}$ ) then k1 = k k2 = k else if( a( k, k-1 )/=zero ) then - k1 = k - 1 + k1 = k - 1_${ik}$ k2 = k - knext = k - 2 + knext = k - 2_${ik}$ else k1 = k k2 = k - knext = k - 1 + knext = k - 1_${ik}$ end if end if if( l1==l2 .and. k1==k2 ) then - suml = stdlib_${ri}$dot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & - l1 ), 1 ) - sumr = stdlib_${ri}$dot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_${ri}$dot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) scaloc = one a11 = a( k1, k1 ) + sgn*b( l1, l1 ) da11 = abs( a11 ) if( da11<=smin ) then a11 = smin da11 = smin - info = 1 + info = 1_${ik}$ end if - db = abs( vec( 1, 1 ) ) + db = abs( vec( 1_${ik}$, 1_${ik}$ ) ) if( da11one ) then if( db>bignum*da11 )scaloc = one / db end if - x( 1, 1 ) = ( vec( 1, 1 )*scaloc ) / a11 + x( 1_${ik}$, 1_${ik}$ ) = ( vec( 1_${ik}$, 1_${ik}$ )*scaloc ) / a11 if( scaloc/=one ) then do j = 1, n - call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) else if( l1==l2 .and. k1/=k2 ) then - suml = stdlib_${ri}$dot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l1 ), 1 ) - sumr = stdlib_${ri}$dot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_${ri}$dot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l1 ), 1 ) - sumr = stdlib_${ri}$dot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - call stdlib_${ri}$laln2( .false., 2, 1, smin, one, a( k1, k1 ),lda, one, one, & - vec, 2, -sgn*b( l1, l1 ),zero, x, 2, scaloc, xnorm, ierr ) - if( ierr/=0 )info = 1 + suml = stdlib${ii}$_${ri}$dot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_${ri}$dot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr ) + call stdlib${ii}$_${ri}$laln2( .false., 2_${ik}$, 1_${ik}$, smin, one, a( k1, k1 ),lda, one, one, & + vec, 2_${ik}$, -sgn*b( l1, l1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k2, l1 ) = x( 2, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ ) else if( l1/=l2 .and. k1==k2 ) then - suml = stdlib_${ri}$dot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & - l1 ), 1 ) - sumr = stdlib_${ri}$dot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) - suml = stdlib_${ri}$dot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & - l2 ), 1 ) - sumr = stdlib_${ri}$dot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 ) - vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) - call stdlib_${ri}$laln2( .true., 2, 1, smin, one, b( l1, l1 ),ldb, one, one, & - vec, 2, -sgn*a( k1, k1 ),zero, x, 2, scaloc, xnorm, ierr ) - if( ierr/=0 )info = 1 + suml = stdlib${ii}$_${ri}$dot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 1_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) + suml = stdlib${ii}$_${ri}$dot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & + l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ ) + vec( 2_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) + call stdlib${ii}$_${ri}$laln2( .true., 2_${ik}$, 1_${ik}$, smin, one, b( l1, l1 ),ldb, one, one, & + vec, 2_${ik}$, -sgn*a( k1, k1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k1, l2 ) = x( 2, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k1, l2 ) = x( 2_${ik}$, 1_${ik}$ ) else if( l1/=l2 .and. k1/=k2 ) then - suml = stdlib_${ri}$dot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l1 ), 1 ) - sumr = stdlib_${ri}$dot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_${ri}$dot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l2 ), 1 ) - sumr = stdlib_${ri}$dot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 ) - vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr ) - suml = stdlib_${ri}$dot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l1 ), 1 ) - sumr = stdlib_${ri}$dot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_${ri}$dot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l2 ), 1 ) - sumr = stdlib_${ri}$dot( l1-1, c( k2, 1 ), ldc, b( 1, l2 ), 1 ) - vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr ) - call stdlib_${ri}$lasy2( .false., .false., isgn, 2, 2,a( k1, k1 ), lda, b( l1, & - l1 ), ldb, vec,2, scaloc, x, 2, xnorm, ierr ) - if( ierr/=0 )info = 1 + suml = stdlib${ii}$_${ri}$dot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_${ri}$dot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ ) + vec( 1_${ik}$, 2_${ik}$ ) = c( k1, l2 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_${ri}$dot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_${ri}$dot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ ) + vec( 2_${ik}$, 2_${ik}$ ) = c( k2, l2 ) - ( suml+sgn*sumr ) + call stdlib${ii}$_${ri}$lasy2( .false., .false., isgn, 2_${ik}$, 2_${ik}$,a( k1, k1 ), lda, b( l1, & + l1 ), ldb, vec,2_${ik}$, scaloc, x, 2_${ik}$, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k1, l2 ) = x( 1, 2 ) - c( k2, l1 ) = x( 2, 1 ) - c( k2, l2 ) = x( 2, 2 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k1, l2 ) = x( 1_${ik}$, 2_${ik}$ ) + c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ ) + c( k2, l2 ) = x( 2_${ik}$, 2_${ik}$ ) end if end do loop_50 end do loop_60 @@ -84149,7 +84140,7 @@ module stdlib_linalg_lapack_${ri}$ ! i=1 j=1 ! start column loop (index = l) ! l1 (l2): column index of the first (last) row of x(k,l) - lnext = 1 + lnext = 1_${ik}$ loop_120: do l = 1, n if( lone ) then if( db>bignum*da11 )scaloc = one / db end if - x( 1, 1 ) = ( vec( 1, 1 )*scaloc ) / a11 + x( 1_${ik}$, 1_${ik}$ ) = ( vec( 1_${ik}$, 1_${ik}$ )*scaloc ) / a11 if( scaloc/=one ) then do j = 1, n - call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) else if( l1==l2 .and. k1/=k2 ) then - suml = stdlib_${ri}$dot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_${ri}$dot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_${ri}$dot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_${ri}$dot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - call stdlib_${ri}$laln2( .true., 2, 1, smin, one, a( k1, k1 ),lda, one, one, & - vec, 2, -sgn*b( l1, l1 ),zero, x, 2, scaloc, xnorm, ierr ) - if( ierr/=0 )info = 1 + suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr ) + call stdlib${ii}$_${ri}$laln2( .true., 2_${ik}$, 1_${ik}$, smin, one, a( k1, k1 ),lda, one, one, & + vec, 2_${ik}$, -sgn*b( l1, l1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k2, l1 ) = x( 2, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ ) else if( l1/=l2 .and. k1==k2 ) then - suml = stdlib_${ri}$dot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_${ri}$dot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) - suml = stdlib_${ri}$dot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 ) - sumr = stdlib_${ri}$dot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 ) - vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) - call stdlib_${ri}$laln2( .true., 2, 1, smin, one, b( l1, l1 ),ldb, one, one, & - vec, 2, -sgn*a( k1, k1 ),zero, x, 2, scaloc, xnorm, ierr ) - if( ierr/=0 )info = 1 + suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 1_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) + suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ ) + vec( 2_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) + call stdlib${ii}$_${ri}$laln2( .true., 2_${ik}$, 1_${ik}$, smin, one, b( l1, l1 ),ldb, one, one, & + vec, 2_${ik}$, -sgn*a( k1, k1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k1, l2 ) = x( 2, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k1, l2 ) = x( 2_${ik}$, 1_${ik}$ ) else if( l1/=l2 .and. k1/=k2 ) then - suml = stdlib_${ri}$dot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_${ri}$dot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_${ri}$dot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 ) - sumr = stdlib_${ri}$dot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 ) - vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr ) - suml = stdlib_${ri}$dot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_${ri}$dot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_${ri}$dot( k1-1, a( 1, k2 ), 1, c( 1, l2 ), 1 ) - sumr = stdlib_${ri}$dot( l1-1, c( k2, 1 ), ldc, b( 1, l2 ), 1 ) - vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr ) - call stdlib_${ri}$lasy2( .true., .false., isgn, 2, 2, a( k1, k1 ),lda, b( l1, & - l1 ), ldb, vec, 2, scaloc, x,2, xnorm, ierr ) - if( ierr/=0 )info = 1 + suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ ) + vec( 1_${ik}$, 2_${ik}$ ) = c( k1, l2 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ ) + vec( 2_${ik}$, 2_${ik}$ ) = c( k2, l2 ) - ( suml+sgn*sumr ) + call stdlib${ii}$_${ri}$lasy2( .true., .false., isgn, 2_${ik}$, 2_${ik}$, a( k1, k1 ),lda, b( l1, & + l1 ), ldb, vec, 2_${ik}$, scaloc, x,2_${ik}$, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k1, l2 ) = x( 1, 2 ) - c( k2, l1 ) = x( 2, 1 ) - c( k2, l2 ) = x( 2, 2 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k1, l2 ) = x( 1_${ik}$, 2_${ik}$ ) + c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ ) + c( k2, l2 ) = x( 2_${ik}$, 2_${ik}$ ) end if end do loop_110 end do loop_120 @@ -84288,23 +84279,23 @@ module stdlib_linalg_lapack_${ri}$ lnext = n loop_180: do l = n, 1, -1 if( l>lnext )cycle loop_180 - if( l==1 ) then + if( l==1_${ik}$ ) then l1 = l l2 = l else if( b( l, l-1 )/=zero ) then - l1 = l - 1 + l1 = l - 1_${ik}$ l2 = l - lnext = l - 2 + lnext = l - 2_${ik}$ else l1 = l l2 = l - lnext = l - 1 + lnext = l - 1_${ik}$ end if end if ! start row loop (index = k) ! k1 (k2): row index of the first (last) row of x(k,l) - knext = 1 + knext = 1_${ik}$ loop_170: do k = 1, m if( kone ) then if( db>bignum*da11 )scaloc = one / db end if - x( 1, 1 ) = ( vec( 1, 1 )*scaloc ) / a11 + x( 1_${ik}$, 1_${ik}$ ) = ( vec( 1_${ik}$, 1_${ik}$ )*scaloc ) / a11 if( scaloc/=one ) then do j = 1, n - call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) else if( l1==l2 .and. k1/=k2 ) then - suml = stdlib_${ri}$dot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_${ri}$dot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_${ri}$dot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - call stdlib_${ri}$laln2( .true., 2, 1, smin, one, a( k1, k1 ),lda, one, one, & - vec, 2, -sgn*b( l1, l1 ),zero, x, 2, scaloc, xnorm, ierr ) - if( ierr/=0 )info = 1 + vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr ) + call stdlib${ii}$_${ri}$laln2( .true., 2_${ik}$, 1_${ik}$, smin, one, a( k1, k1 ),lda, one, one, & + vec, 2_${ik}$, -sgn*b( l1, l1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k2, l1 ) = x( 2, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ ) else if( l1/=l2 .and. k1==k2 ) then - suml = stdlib_${ri}$dot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) - suml = stdlib_${ri}$dot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 ) - sumr = stdlib_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & + vec( 1_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) + suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & ) ), ldb ) - vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) - call stdlib_${ri}$laln2( .false., 2, 1, smin, one, b( l1, l1 ),ldb, one, one, & - vec, 2, -sgn*a( k1, k1 ),zero, x, 2, scaloc, xnorm, ierr ) - if( ierr/=0 )info = 1 + vec( 2_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) + call stdlib${ii}$_${ri}$laln2( .false., 2_${ik}$, 1_${ik}$, smin, one, b( l1, l1 ),ldb, one, one, & + vec, 2_${ik}$, -sgn*a( k1, k1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k1, l2 ) = x( 2, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k1, l2 ) = x( 2_${ik}$, 1_${ik}$ ) else if( l1/=l2 .and. k1/=k2 ) then - suml = stdlib_${ri}$dot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_${ri}$dot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 ) - sumr = stdlib_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & ) ), ldb ) - vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr ) - suml = stdlib_${ri}$dot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_${ri}$dot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + vec( 1_${ik}$, 2_${ik}$ ) = c( k1, l2 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_${ri}$dot( k1-1, a( 1, k2 ), 1, c( 1, l2 ), 1 ) - sumr = stdlib_${ri}$dot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & + vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_${ri}$dot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & ) ), ldb ) - vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr ) - call stdlib_${ri}$lasy2( .true., .true., isgn, 2, 2, a( k1, k1 ),lda, b( l1, l1 & - ), ldb, vec, 2, scaloc, x,2, xnorm, ierr ) - if( ierr/=0 )info = 1 + vec( 2_${ik}$, 2_${ik}$ ) = c( k2, l2 ) - ( suml+sgn*sumr ) + call stdlib${ii}$_${ri}$lasy2( .true., .true., isgn, 2_${ik}$, 2_${ik}$, a( k1, k1 ),lda, b( l1, l1 & + ), ldb, vec, 2_${ik}$, scaloc, x,2_${ik}$, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k1, l2 ) = x( 1, 2 ) - c( k2, l1 ) = x( 2, 1 ) - c( k2, l2 ) = x( 2, 2 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k1, l2 ) = x( 1_${ik}$, 2_${ik}$ ) + c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ ) + c( k2, l2 ) = x( 2_${ik}$, 2_${ik}$ ) end if end do loop_170 end do loop_180 @@ -84433,18 +84424,18 @@ module stdlib_linalg_lapack_${ri}$ lnext = n loop_240: do l = n, 1, -1 if( l>lnext )cycle loop_240 - if( l==1 ) then + if( l==1_${ik}$ ) then l1 = l l2 = l else if( b( l, l-1 )/=zero ) then - l1 = l - 1 + l1 = l - 1_${ik}$ l2 = l - lnext = l - 2 + lnext = l - 2_${ik}$ else l1 = l l2 = l - lnext = l - 1 + lnext = l - 1_${ik}$ end if end if ! start row loop (index = k) @@ -84452,133 +84443,133 @@ module stdlib_linalg_lapack_${ri}$ knext = m loop_230: do k = m, 1, -1 if( k>knext )cycle loop_230 - if( k==1 ) then + if( k==1_${ik}$ ) then k1 = k k2 = k else if( a( k, k-1 )/=zero ) then - k1 = k - 1 + k1 = k - 1_${ik}$ k2 = k - knext = k - 2 + knext = k - 2_${ik}$ else k1 = k k2 = k - knext = k - 1 + knext = k - 1_${ik}$ end if end if if( l1==l2 .and. k1==k2 ) then - suml = stdlib_${ri}$dot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & - l1 ), 1 ) - sumr = stdlib_${ri}$dot( n-l1, c( k1, min( l1+1, n ) ), ldc,b( l1, min( l1+1, n & + suml = stdlib${ii}$_${ri}$dot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( n-l1, c( k1, min( l1+1, n ) ), ldc,b( l1, min( l1+1, n & ) ), ldb ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) scaloc = one a11 = a( k1, k1 ) + sgn*b( l1, l1 ) da11 = abs( a11 ) if( da11<=smin ) then a11 = smin da11 = smin - info = 1 + info = 1_${ik}$ end if - db = abs( vec( 1, 1 ) ) + db = abs( vec( 1_${ik}$, 1_${ik}$ ) ) if( da11one ) then if( db>bignum*da11 )scaloc = one / db end if - x( 1, 1 ) = ( vec( 1, 1 )*scaloc ) / a11 + x( 1_${ik}$, 1_${ik}$ ) = ( vec( 1_${ik}$, 1_${ik}$ )*scaloc ) / a11 if( scaloc/=one ) then do j = 1, n - call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) else if( l1==l2 .and. k1/=k2 ) then - suml = stdlib_${ri}$dot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l1 ), 1 ) - sumr = stdlib_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + suml = stdlib${ii}$_${ri}$dot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_${ri}$dot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l1 ), 1 ) - sumr = stdlib_${ri}$dot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_${ri}$dot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - call stdlib_${ri}$laln2( .false., 2, 1, smin, one, a( k1, k1 ),lda, one, one, & - vec, 2, -sgn*b( l1, l1 ),zero, x, 2, scaloc, xnorm, ierr ) - if( ierr/=0 )info = 1 + vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr ) + call stdlib${ii}$_${ri}$laln2( .false., 2_${ik}$, 1_${ik}$, smin, one, a( k1, k1 ),lda, one, one, & + vec, 2_${ik}$, -sgn*b( l1, l1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k2, l1 ) = x( 2, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ ) else if( l1/=l2 .and. k1==k2 ) then - suml = stdlib_${ri}$dot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & - l1 ), 1 ) - sumr = stdlib_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + suml = stdlib${ii}$_${ri}$dot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) - suml = stdlib_${ri}$dot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & - l2 ), 1 ) - sumr = stdlib_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & + vec( 1_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) + suml = stdlib${ii}$_${ri}$dot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & + l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & ) ), ldb ) - vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) - call stdlib_${ri}$laln2( .false., 2, 1, smin, one, b( l1, l1 ),ldb, one, one, & - vec, 2, -sgn*a( k1, k1 ),zero, x, 2, scaloc, xnorm, ierr ) - if( ierr/=0 )info = 1 + vec( 2_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) + call stdlib${ii}$_${ri}$laln2( .false., 2_${ik}$, 1_${ik}$, smin, one, b( l1, l1 ),ldb, one, one, & + vec, 2_${ik}$, -sgn*a( k1, k1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k1, l2 ) = x( 2, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k1, l2 ) = x( 2_${ik}$, 1_${ik}$ ) else if( l1/=l2 .and. k1/=k2 ) then - suml = stdlib_${ri}$dot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l1 ), 1 ) - sumr = stdlib_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + suml = stdlib${ii}$_${ri}$dot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_${ri}$dot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l2 ), 1 ) - sumr = stdlib_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_${ri}$dot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & ) ), ldb ) - vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr ) - suml = stdlib_${ri}$dot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l1 ), 1 ) - sumr = stdlib_${ri}$dot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + vec( 1_${ik}$, 2_${ik}$ ) = c( k1, l2 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_${ri}$dot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_${ri}$dot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l2 ), 1 ) - sumr = stdlib_${ri}$dot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & + vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_${ri}$dot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ri}$dot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & ) ), ldb ) - vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr ) - call stdlib_${ri}$lasy2( .false., .true., isgn, 2, 2, a( k1, k1 ),lda, b( l1, & - l1 ), ldb, vec, 2, scaloc, x,2, xnorm, ierr ) - if( ierr/=0 )info = 1 + vec( 2_${ik}$, 2_${ik}$ ) = c( k2, l2 ) - ( suml+sgn*sumr ) + call stdlib${ii}$_${ri}$lasy2( .false., .true., isgn, 2_${ik}$, 2_${ik}$, a( k1, k1 ),lda, b( l1, & + l1 ), ldb, vec, 2_${ik}$, scaloc, x,2_${ik}$, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_${ri}$scal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_${ri}$scal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k1, l2 ) = x( 1, 2 ) - c( k2, l1 ) = x( 2, 1 ) - c( k2, l2 ) = x( 2, 2 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k1, l2 ) = x( 1_${ik}$, 2_${ik}$ ) + c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ ) + c( k2, l2 ) = x( 2_${ik}$, 2_${ik}$ ) end if end do loop_230 end do loop_240 end if return - end subroutine stdlib_${ri}$trsyl + end subroutine stdlib${ii}$_${ri}$trsyl - pure subroutine stdlib_${ri}$trti2( uplo, diag, n, a, lda, info ) + pure subroutine stdlib${ii}$_${ri}$trti2( uplo, diag, n, a, lda, info ) !! DTRTI2: computes the inverse of a real upper or lower triangular !! matrix. !! This is the Level 2 BLAS version of the algorithm. @@ -84587,34 +84578,34 @@ module stdlib_linalg_lapack_${ri}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: diag, 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(${rk}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: nounit, upper - integer(ilp) :: j + integer(${ik}$) :: j real(${rk}$) :: ajj ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) nounit = stdlib_lsame( diag, 'N' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( lda=n ) then + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'DTRTRI', uplo // diag, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code - call stdlib_${ri}$trti2( uplo, diag, n, a, lda, info ) + call stdlib${ii}$_${ri}$trti2( uplo, diag, n, a, lda, info ) else ! use blocked code if( upper ) then @@ -84711,35 +84702,35 @@ module stdlib_linalg_lapack_${ri}$ do j = 1, n, nb jb = min( nb, n-j+1 ) ! compute rows 1:j-1 of current block column - call stdlib_${ri}$trmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, one, a, lda,& - a( 1, j ), lda ) - call stdlib_${ri}$trsm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, -one, a( j,& - j ), lda, a( 1, j ), lda ) + call stdlib${ii}$_${ri}$trmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, one, a, lda,& + a( 1_${ik}$, j ), lda ) + call stdlib${ii}$_${ri}$trsm( '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_${ri}$trti2( 'UPPER', diag, jb, a( j, j ), lda, info ) + call stdlib${ii}$_${ri}$trti2( '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_${ri}$trmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, one,& + call stdlib${ii}$_${ri}$trmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, one,& a( j+jb, j+jb ), lda,a( j+jb, j ), lda ) - call stdlib_${ri}$trsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, -& + call stdlib${ii}$_${ri}$trsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, -& one, a( j, j ), lda,a( j+jb, j ), lda ) end if ! compute inverse of current diagonal block - call stdlib_${ri}$trti2( 'LOWER', diag, jb, a( j, j ), lda, info ) + call stdlib${ii}$_${ri}$trti2( 'LOWER', diag, jb, a( j, j ), lda, info ) end do end if end if return - end subroutine stdlib_${ri}$trtri + end subroutine stdlib${ii}$_${ri}$trtri - pure subroutine stdlib_${ri}$trtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info ) + pure subroutine stdlib${ii}$_${ri}$trtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info ) !! DTRTRS: solves a triangular system of the form !! A * X = B or A**T * X = B, !! where A is a triangular matrix of order N, and B is an N-by-NRHS @@ -84749,8 +84740,8 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: a(lda,*) real(${rk}$), intent(inout) :: b(ldb,*) @@ -84762,26 +84753,26 @@ module stdlib_linalg_lapack_${ri}$ 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( lda1 .and. nb1_${ik}$ .and. nb1 ) then + call stdlib${ii}$_${ri}$latrz( ib, n-i+1, n-m, a( i, i ), lda, tau( i ),work ) + if( i>1_${ik}$ ) then ! form the triangular factor of the block reflector ! h = h(i+ib-1) . . . h(i+1) h(i) - call stdlib_${ri}$larzt( 'BACKWARD', 'ROWWISE', n-m, ib, a( i, m1 ),lda, tau( i ), & + call stdlib${ii}$_${ri}$larzt( 'BACKWARD', 'ROWWISE', n-m, ib, a( i, m1 ),lda, tau( i ), & work, ldwork ) ! apply h to a(1:i-1,i:n) from the right - call stdlib_${ri}$larzb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', i-1, n-i+1,& - ib, n-m, a( i, m1 ),lda, work, ldwork, a( 1, i ), lda,work( ib+1 ), ldwork ) + call stdlib${ii}$_${ri}$larzb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', i-1, n-i+1,& + ib, n-m, a( i, m1 ),lda, work, ldwork, a( 1_${ik}$, i ), lda,work( ib+1 ), ldwork ) end if end do - mu = i + nb - 1 + mu = i + nb - 1_${ik}$ else mu = m end if ! use unblocked code to factor the last or only block - if( mu>0 )call stdlib_${ri}$latrz( mu, n, n-m, a, lda, tau, work ) - work( 1 ) = lwkopt + if( mu>0_${ik}$ )call stdlib${ii}$_${ri}$latrz( mu, n, n-m, a, lda, tau, work ) + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ri}$tzrzf + end subroutine stdlib${ii}$_${ri}$tzrzf - pure real(${rk}$) function stdlib_${ri}$zsum1( n, cx, incx ) + pure real(${rk}$) function stdlib${ii}$_${ri}$zsum1( n, cx, incx ) !! DZSUM1: takes the sum of the absolute values of a complex !! vector and returns a quad precision result. !! Based on DZASUM from the Level 1 BLAS. @@ -85206,17 +85197,17 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(${rk}$), intent(in) :: cx(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, nincx + integer(${ik}$) :: i, nincx real(${rk}$) :: stemp ! Intrinsic Functions intrinsic :: abs ! Executable Statements - stdlib_${ri}$zsum1 = zero + stdlib${ii}$_${ri}$zsum1 = zero stemp = zero if( n<=0 )return if( incx==1 )go to 20 @@ -85226,7 +85217,7 @@ module stdlib_linalg_lapack_${ri}$ ! next line modified. stemp = stemp + abs( cx( i ) ) end do - stdlib_${ri}$zsum1 = stemp + stdlib${ii}$_${ri}$zsum1 = stemp return ! code for increment equal to 1 20 continue @@ -85234,11 +85225,11 @@ module stdlib_linalg_lapack_${ri}$ ! next line modified. stemp = stemp + abs( cx( i ) ) end do - stdlib_${ri}$zsum1 = stemp + stdlib${ii}$_${ri}$zsum1 = stemp return - end function stdlib_${ri}$zsum1 + end function stdlib${ii}$_${ri}$zsum1 - pure subroutine stdlib_dlag2${ri}$( m, n, sa, ldsa, a, lda, info ) + pure subroutine stdlib${ii}$_dlag2${ri}$( m, n, sa, ldsa, a, lda, info ) !! DLAG2Q converts a DOUBLE PRECISION matrix, SA, to an EXTENDED !! PRECISION matrix, A. !! Note that while it is possible to overflow while converting @@ -85249,23 +85240,25 @@ module stdlib_linalg_lapack_${ri}$ ! -- 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(dp), intent(in) :: sa(ldsa,*) real(${rk}$), 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_dlag2${ri}$ + end subroutine stdlib${ii}$_dlag2${ri}$ + + #:endfor end module stdlib_linalg_lapack_${ri}$ diff --git a/src/stdlib_linalg_lapack_s.fypp b/src/stdlib_linalg_lapack_s.fypp index 24d0f1577..fb733556f 100644 --- a/src/stdlib_linalg_lapack_s.fypp +++ b/src/stdlib_linalg_lapack_s.fypp @@ -7,472 +7,474 @@ 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 + 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-bit real constants real(sp), parameter, private :: negone = -1.00_sp @@ -497,7 +499,7 @@ module stdlib_linalg_lapack_s 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 @@ -507,15 +509,15 @@ module stdlib_linalg_lapack_s ! 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 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. @@ -524,17 +526,17 @@ 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 ! 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 @@ -544,7 +546,7 @@ module stdlib_linalg_lapack_s ! next line modified. stemp = stemp + abs( cx( i ) ) end do - stdlib_scsum1 = stemp + stdlib${ii}$_scsum1 = stemp return ! code for increment equal to 1 20 continue @@ -552,12 +554,12 @@ module stdlib_linalg_lapack_s ! 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. @@ -565,15 +567,15 @@ 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) :: 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,47 +655,47 @@ 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. @@ -705,39 +707,39 @@ module stdlib_linalg_lapack_s 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,24 +1140,24 @@ 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 @@ -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,10 +1330,10 @@ 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 @@ -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,11 +1369,11 @@ 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 @@ -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 ) + pure subroutine stdlib${ii}$_slacn2( n, v, x, isgn, est, kase, isave ) !! SLACN2 estimates the 1-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) ! 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) ! first iteration. x has been overwritten by transpose(a)*x. 40 continue - isave( 2 ) = stdlib_isamax( n, x, 1 ) - isave( 3 ) = 2 + isave( 2_${ik}$ ) = stdlib${ii}$_isamax( n, x, 1_${ik}$ ) + isave( 3_${ik}$ ) = 2_${ik}$ ! main loop - iterations 2,3,...,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) ! 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) ! 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 ) + subroutine stdlib${ii}$_slacon( n, v, x, isgn, est, kase ) !! SLACON estimates the 1-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) ! 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) ! first iteration. x has been overwritten by transpose(a)*x. 40 continue - j = stdlib_isamax( n, x, 1 ) - iter = 2 + j = stdlib${ii}$_isamax( n, x, 1_${ik}$ ) + iter = 2_${ik}$ ! main loop - iterations 2,3,...,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) ! 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) ! 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,18 +1776,18 @@ 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 ) + pure subroutine stdlib${ii}$_slae2( a, b, c, rt1, rt2 ) !! SLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix !! [ A B ] !! [ B C ]. @@ -1821,9 +1823,9 @@ 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 + if( ijob<=2_${ik}$ ) then ! ijob=2: 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 @@ -2002,12 +2004,12 @@ module stdlib_linalg_lapack_s ! 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 + if( ijob<=2_${ik}$ ) then ! ijob=2: 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,51 +2078,51 @@ 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 !! diag( D ) + RHO * Z * transpose(Z) . @@ -2132,12 +2134,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) :: 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 + 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,103 +2202,103 @@ 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 ! 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 ) + pure subroutine stdlib${ii}$_slaev2( a, b, c, rt1, rt2, cs1, sn1 ) !! SLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix !! [ A B ] !! [ B C ]. @@ -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,23 +2338,23 @@ 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. @@ -2361,15 +2363,15 @@ module stdlib_linalg_lapack_s ! includes case rt1 = rt2 = 0 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,10 +2394,10 @@ 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 ) + pure subroutine stdlib${ii}$_slag2( a, lda, b, ldb, safmin, scale1, scale2, wr1,wr2, wi ) !! SLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue !! problem A - w B, with scaling as necessary to avoid over-/underflow. !! The scaling factor "s" results in a modified eigenvalue equation @@ -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 @@ -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 @@ -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, -- @@ -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,63 +2813,63 @@ 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 + i = 1_${ik}$ ! while ( (n1sv > 0) 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 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: @@ -2920,8 +2922,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, 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,75 +2931,75 @@ 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. !! If FORWRD = .TRUE., forward permutation: @@ -3009,13 +3011,13 @@ module stdlib_linalg_lapack_s ! -- 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,10 +3064,10 @@ 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. !! If FORWRD = .TRUE., forward permutation: @@ -3077,13 +3079,13 @@ module stdlib_linalg_lapack_s ! -- 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,10 +3132,10 @@ 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 ) + pure real(sp) function stdlib${ii}$_slapy3( x, y, z ) !! SLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause !! unnecessary overflow and unnecessary underflow. ! -- lapack auxiliary routine -- @@ -3148,7 +3150,7 @@ 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 ) @@ -3157,15 +3159,15 @@ module stdlib_linalg_lapack_s ! w can be zero for max(0,nan,0) ! 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,10 +3300,10 @@ 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 ) + pure subroutine stdlib${ii}$_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 !! scalar multiple of the first column of the product !! (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I) @@ -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,10 +3540,10 @@ 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 @@ -3551,17 +3553,17 @@ 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) :: 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,10 +3583,10 @@ 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 @@ -3595,7 +3597,7 @@ module stdlib_linalg_lapack_s ! -- 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) + 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) + 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 + if( lastv>0_${ik}$ ) 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 & + 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 ) + call stdlib${ii}$_sger( lastv, lastc, -tau, v, incv, work, 1_${ik}$, c, ldc ) end if else ! form c * h - if( lastv>0 ) then + if( lastv>0_${ik}$ ) 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 ) + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', lastc, lastv, one, c, ldc,v, incv, zero, work,& + 1_${ik}$ ) ! 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 ) + 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,7 +4008,7 @@ 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 @@ -4020,34 +4022,34 @@ module stdlib_linalg_lapack_s ! col2_(1) compute w2: = a2. therefore, copy a2 = a(1:k, k+1:n) ! into w2=work(1:k, 1:n-k) column-by-column. do j = 1, n-k - call stdlib_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, ! 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 ! 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, ! t is upper-triangular. - call stdlib_strmm( 'L', 'U', 'N', 'N', k, n-k, one, t, ldt,work, ldwork ) + call stdlib${ii}$_strmm( 'L', 'U', 'N', 'N', k, n-k, one, t, ldt,work, ldwork ) ! col2_(5) compute b2: = b2 - v2 * w2 = b2 - b1 * w2, ! v2 stored in b1. - if( m>0 ) then - call stdlib_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, ! 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), @@ -4067,7 +4069,7 @@ module stdlib_linalg_lapack_s ! a1 = a(1:k, 1:k) into the upper-triangular ! w1 = work(1:k, 1:k) column-by-column. do j = 1, k - call stdlib_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 @@ -4080,16 +4082,16 @@ module stdlib_linalg_lapack_s ! 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, ! 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 ) + call stdlib${ii}$_strmm( 'L', 'U', 'N', 'N', k, k, one, t, ldt,work, ldwork ) ! col1_(4) compute b1: = - v2 * w1 = - b1 * w1, ! v2 = b1, w1 is upper-triangular with zeroes below the diagonal. - if( m>0 ) then - call stdlib_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, @@ -4097,7 +4099,7 @@ module stdlib_linalg_lapack_s ! 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 ) + call stdlib${ii}$_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) ! column-by-column. a1 is upper-triangular on input. ! if ident, a1 is square on output, and w1 is square, @@ -4117,10 +4119,10 @@ module stdlib_linalg_lapack_s 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; @@ -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 @@ -4168,8 +4170,8 @@ module stdlib_linalg_lapack_s 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 ) + 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 @@ -4180,14 +4182,14 @@ module stdlib_linalg_lapack_s 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 ) + 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 ) + 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,10 +4246,10 @@ 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 @@ -4260,7 +4262,7 @@ module stdlib_linalg_lapack_s ! -- 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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 ) + 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,16 +4776,16 @@ 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 !! ( c(i) s(i) ) ( x(i) ) = ( a(i) ) @@ -4792,21 +4794,21 @@ 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) :: 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' ) + eps = stdlib${ii}$_slamch( 'P' ) + uflow = stdlib${ii}$_slamch( 'U' ) ! special case when n=1 ! 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 ! 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 ) ) @@ -5110,7 +5112,7 @@ module stdlib_linalg_lapack_s gu = gu + fudge*tnorm*eps*n + fudge*two*pivmin ! [jan/28/2009] 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,29 +5178,29 @@ 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 + if( in==1_${ik}$ ) then ! 1x1 block - if( wl>=d( ibegin )-pivmin )nwl = nwl + 1 - if( wu>=d( ibegin )-pivmin )nwu = nwu + 1 + 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 @@ -5248,13 +5250,13 @@ module stdlib_linalg_lapack_s else ! general case - block of size in >= 2 ! 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 @@ -5264,7 +5266,7 @@ module stdlib_linalg_lapack_s ! 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 + 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 + 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. @@ -5651,8 +5653,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) :: 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,21 +5737,21 @@ 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 @@ -5768,7 +5770,7 @@ module stdlib_linalg_lapack_s ! instead of the current offdig + offdig2 < 1 yesrel = .true. offdig = zero - tmp = sqrt(abs(d(1))) + tmp = sqrt(abs(d(1_${ik}$))) if (tmp=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,10 +5959,10 @@ 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. @@ -5979,7 +5981,7 @@ module stdlib_linalg_lapack_s ! Local Scalars real(sp) :: r, s, thresh, w, z - thresh = stdlib_slamch('E') + thresh = stdlib${ii}$_slamch('E') ! compute the first column of b**t*b - sigma^2*i, up to a scale ! factor. if( (sigma == zero .and. abs(x) < thresh) .or.(abs(x) == sigma .and. y == zero) ) & @@ -6007,16 +6009,16 @@ 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; + ! call stdlib${ii}$_slartgp( z, w, cs, sn, r ) might seem more natural; ! reordering the arguments ensures that if z = 0 then the rotation ! is by pi/2. - call stdlib_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 !! ( x(i) ) := ( c(i) s(i) ) ( x(i) ) @@ -6025,18 +6027,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) :: 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,10 +6049,10 @@ 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 ) + pure subroutine stdlib${ii}$_slaruv( iseed, n, x ) !! SLARUV returns a vector of n random real numbers from a uniform (0,1) !! distribution (n <= 128). !! This is an auxiliary routine called by SLARNV and CLARNV. @@ -6058,171 +6060,171 @@ 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 - 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 ) + 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) x( i ) = r*( real( it1,KIND=sp)+r*( real( it2,KIND=sp)+r*( real( it3,KIND=sp)+& @@ -6237,23 +6239,23 @@ module stdlib_linalg_lapack_s ! 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 @@ -6266,7 +6268,7 @@ module stdlib_linalg_lapack_s ! -- 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,*) @@ -6279,36 +6281,36 @@ module stdlib_linalg_lapack_s ! form h * c if( tau/=zero ) then ! w( 1:n ) = c( 1, 1:n ) - call stdlib_scopy( n, c, ldc, work, 1 ) + call stdlib${ii}$_scopy( n, c, ldc, work, 1_${ik}$ ) ! 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 ) + call stdlib${ii}$_sgemv( 'TRANSPOSE', l, n, one, c( m-l+1, 1_${ik}$ ), ldc, v,incv, one, work,& + 1_${ik}$ ) ! c( 1, 1:n ) = c( 1, 1:n ) - tau * w( 1:n ) - call stdlib_saxpy( n, -tau, work, 1, c, ldc ) + call stdlib${ii}$_saxpy( n, -tau, work, 1_${ik}$, 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 ) + 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 ) + call stdlib${ii}$_scopy( m, c, 1_${ik}$, work, 1_${ik}$ ) ! 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 ) + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', m, l, one, c( 1_${ik}$, n-l+1 ), ldc,v, incv, one, & + work, 1_${ik}$ ) ! c( 1:m, 1 ) = c( 1:m, 1 ) - tau * w( 1:m ) - call stdlib_saxpy( m, -tau, work, 1, c, 1 ) + call stdlib${ii}$_saxpy( m, -tau, work, 1_${ik}$, c, 1_${ik}$ ) ! 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 ) + 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 @@ -6350,14 +6352,14 @@ module stdlib_linalg_lapack_s ! form h * c or h**t * c ! w( 1:n, 1:k ) = c( 1:k, 1: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 ), & + 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, & + 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 do j = 1, n @@ -6367,20 +6369,20 @@ module stdlib_linalg_lapack_s 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 ) + 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 ) 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 ),& + 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, & + 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 ) do j = 1, k @@ -6390,14 +6392,14 @@ module stdlib_linalg_lapack_s 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 ) + 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. @@ -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 @@ -6446,20 +6448,20 @@ module stdlib_linalg_lapack_s ! general case if( izero ) 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 ) 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 ) + 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 ) = -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 + 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 ) * d( 2 ) if( b>zero ) then tau = -two*c / ( b+sqrt( b*b+four*c ) ) @@ -6579,12 +6581,12 @@ module stdlib_linalg_lapack_s 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 + 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 ) = -z( 1 ) / ( del+tau ) ! delta( 2 ) = -z( 2 ) / tau end if @@ -6593,8 +6595,8 @@ module stdlib_linalg_lapack_s ! 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 + 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 ) * d( 2 ) if( b>zero ) then tau = ( b+sqrt( b*b+four*c ) ) / two @@ -6602,12 +6604,12 @@ module stdlib_linalg_lapack_s 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 + 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 ) = -z( 1 ) / ( del+tau ) ! delta( 2 ) = -z( 2 ) / tau ! temp = sqrt( delta( 1 )*delta( 1 )+delta( 2 )*delta( 2 ) ) @@ -6615,61 +6617,61 @@ module stdlib_linalg_lapack_s ! delta( 2 ) = delta( 2 ) / 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,10 +6756,10 @@ 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 @@ -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 @@ -6845,21 +6847,21 @@ module stdlib_linalg_lapack_s 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. 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. 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 @@ -7608,7 +7610,7 @@ module stdlib_linalg_lapack_s ! choose partition entry as median of 3 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 @@ -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,7 +7738,7 @@ 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: @@ -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,10 +7812,10 @@ 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 ) + pure subroutine stdlib${ii}$_slasv2( f, g, h, ssmin, ssmax, snr, csr, snl, csl ) !! SLASV2 computes the singular value decomposition of a 2-by-2 !! triangular matrix !! [ F G ] @@ -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 @@ -7851,10 +7853,10 @@ module stdlib_linalg_lapack_s ! 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}$ 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,10 +8024,10 @@ 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, & + 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 <= N1,N2 <= 2, in !! op(TL)*X + ISGN*X*op(TR) = SCALE*B, !! where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or @@ -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 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: ! 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: ! 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. ! 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,37 +8140,37 @@ 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: @@ -8177,43 +8179,43 @@ module stdlib_linalg_lapack_s ! solve equivalent 4 by 4 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,22 +8272,22 @@ 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: @@ -8303,10 +8305,10 @@ 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, 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,12 +8317,12 @@ 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 @@ -8335,25 +8337,25 @@ 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 @@ -8361,17 +8363,17 @@ module stdlib_linalg_lapack_s 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 @@ -8382,17 +8384,17 @@ module stdlib_linalg_lapack_s ! 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 ! 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. @@ -8403,16 +8405,16 @@ module stdlib_linalg_lapack_s ! (or k and k-1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = a( kk, kk ) - call stdlib_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 ! later overwritten). interchange rows kk and kp ! in last kkw to nb columns of w. - if( k2 ) then + if( k>2_${ik}$ ) then ! compose the columns of the inverse of 2-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 @@ -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 @@ -8492,31 +8494,31 @@ module stdlib_linalg_lapack_s 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 absakk = abs( w( k, k ) ) @@ -8542,14 +8544,14 @@ module stdlib_linalg_lapack_s ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k=alpha*colmax ) then @@ -8557,16 +8559,16 @@ module stdlib_linalg_lapack_s 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 @@ -8577,17 +8579,17 @@ module stdlib_linalg_lapack_s ! 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 ! 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 @@ -8596,17 +8598,17 @@ module stdlib_linalg_lapack_s ! (or k and k+1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = a( kk, kk ) - call stdlib_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 + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of w now holds ! w(k) = l(k)*d(k), ! where l(k) is the k-th column of l @@ -8616,10 +8618,10 @@ module stdlib_linalg_lapack_s ! 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: @@ -8740,10 +8742,10 @@ 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, 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,24 +8755,24 @@ 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 + e( 1_${ik}$ ) = zero ! k is the main loop index, decreasing from n in steps of 1 or 2 k = n 10 continue @@ -8778,31 +8780,31 @@ module stdlib_linalg_lapack_s 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 @@ -8817,22 +8819,22 @@ module stdlib_linalg_lapack_s 12 continue ! begin pivot search loop body ! 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 - 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 @@ -8847,7 +8849,7 @@ module stdlib_linalg_lapack_s ! use 1-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}$ ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -8855,7 +8857,7 @@ module stdlib_linalg_lapack_s ! interchange rows and columns k-1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found: set params and repeat @@ -8863,45 +8865,45 @@ module stdlib_linalg_lapack_s colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth 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}$ ) end if ! end pivot search loop body if( .not. done ) goto 12 end if ! ============================================================ - 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 - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_scopy( k-p, a( p+1, k ), 1, a( p, p+1 ), lda ) - call stdlib_scopy( p, a( 1, k ), 1, a( 1, p ), 1 ) + call stdlib${ii}$_scopy( k-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ), lda ) + call stdlib${ii}$_scopy( p, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) ! interchange rows k and p in last n-k+1 columns of a ! and last n-k+2 columns of w - call stdlib_sswap( n-k+1, a( k, k ), lda, a( p, k ), lda ) - call stdlib_sswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw ) + call stdlib${ii}$_sswap( n-k+1, a( k, k ), lda, a( p, k ), lda ) + call stdlib${ii}$_sswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw ) end if ! updated column kp is already stored in column kkw of w if( kp/=kk ) then ! copy non-updated column kk to column kp a( kp, k ) = a( kk, k ) - call stdlib_scopy( k-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - call stdlib_scopy( kp, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_scopy( k-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) + call stdlib${ii}$_scopy( kp, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) ! interchange rows kk and kp in last n-kk+1 columns ! of a and w - call stdlib_sswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) - call stdlib_sswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) + call stdlib${ii}$_sswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) + call stdlib${ii}$_sswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column kw of w now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u ! store u(k) in column k of a - call stdlib_scopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) - if( k>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 ) @@ -8916,7 +8918,7 @@ module stdlib_linalg_lapack_s ! ( 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 @@ -8956,12 +8958,12 @@ module stdlib_linalg_lapack_s 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 @@ -8972,16 +8974,16 @@ module stdlib_linalg_lapack_s ! 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 = 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 absakk = abs( w( k, k ) ) @@ -8989,16 +8991,16 @@ module stdlib_linalg_lapack_s ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k1 )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 @@ -9044,7 +9046,7 @@ module stdlib_linalg_lapack_s ! use 1-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}$ ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -9052,7 +9054,7 @@ module stdlib_linalg_lapack_s ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found: set params and repeat @@ -9060,42 +9062,42 @@ module stdlib_linalg_lapack_s colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth 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}$ ) end if ! end pivot search loop body if( .not. done ) goto 72 end if ! ============================================================ - kk = k + kstep - 1 - if( ( kstep==2 ) .and. ( p/=k ) ) then + kk = k + kstep - 1_${ik}$ + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_scopy( p-k, a( k, k ), 1, a( p, k ), lda ) - call stdlib_scopy( n-p+1, a( p, k ), 1, a( p, p ), 1 ) + call stdlib${ii}$_scopy( p-k, a( k, k ), 1_${ik}$, a( p, k ), lda ) + call stdlib${ii}$_scopy( n-p+1, a( p, k ), 1_${ik}$, a( p, p ), 1_${ik}$ ) ! interchange rows k and p in first k columns of a ! and first k+1 columns of w - call stdlib_sswap( k, a( k, 1 ), lda, a( p, 1 ), lda ) - call stdlib_sswap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw ) + call stdlib${ii}$_sswap( k, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda ) + call stdlib${ii}$_sswap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw ) end if ! updated column kp is already stored in column kk of w if( kp/=kk ) then ! copy non-updated column kk to column kp a( kp, k ) = a( kk, k ) - call stdlib_scopy( kp-k-1, a( k+1, kk ), 1, a( kp, k+1 ), lda ) - call stdlib_scopy( n-kp+1, a( kp, kk ), 1, a( kp, kp ), 1 ) + call stdlib${ii}$_scopy( kp-k-1, a( k+1, kk ), 1_${ik}$, a( kp, k+1 ), lda ) + call stdlib${ii}$_scopy( n-kp+1, a( kp, kk ), 1_${ik}$, a( kp, kp ), 1_${ik}$ ) ! interchange rows kk and kp in first kk columns of a and w - call stdlib_sswap( kk, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_sswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + call stdlib${ii}$_sswap( kk, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) + call stdlib${ii}$_sswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of w now holds ! w(k) = l(k)*d(k) ! where l(k) is the k-th column of l ! store l(k) in column k of a - call stdlib_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=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 ) @@ -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,21 +9151,21 @@ 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: @@ -9181,10 +9183,10 @@ 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, 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,18 +9196,18 @@ 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 @@ -9217,29 +9219,29 @@ module stdlib_linalg_lapack_s 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 @@ -9254,22 +9256,22 @@ module stdlib_linalg_lapack_s 12 continue ! begin pivot search loop body ! 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 - 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 @@ -9284,7 +9286,7 @@ module stdlib_linalg_lapack_s ! use 1-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}$ ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -9292,7 +9294,7 @@ module stdlib_linalg_lapack_s ! interchange rows and columns k-1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found: set params and repeat @@ -9300,45 +9302,45 @@ module stdlib_linalg_lapack_s colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth 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}$ ) end if ! end pivot search loop body if( .not. done ) goto 12 end if ! ============================================================ - 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 - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_scopy( k-p, a( p+1, k ), 1, a( p, p+1 ), lda ) - call stdlib_scopy( p, a( 1, k ), 1, a( 1, p ), 1 ) + call stdlib${ii}$_scopy( k-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ), lda ) + call stdlib${ii}$_scopy( p, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) ! interchange rows k and p in last n-k+1 columns of a ! and last n-k+2 columns of w - call stdlib_sswap( n-k+1, a( k, k ), lda, a( p, k ), lda ) - call stdlib_sswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw ) + call stdlib${ii}$_sswap( n-k+1, a( k, k ), lda, a( p, k ), lda ) + call stdlib${ii}$_sswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw ) end if ! updated column kp is already stored in column kkw of w if( kp/=kk ) then ! copy non-updated column kk to column kp a( kp, k ) = a( kk, k ) - call stdlib_scopy( k-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - call stdlib_scopy( kp, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_scopy( k-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) + call stdlib${ii}$_scopy( kp, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) ! interchange rows kk and kp in last n-kk+1 columns ! of a and w - call stdlib_sswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) - call stdlib_sswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) + call stdlib${ii}$_sswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) + call stdlib${ii}$_sswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column kw of w now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u ! store u(k) in column k of a - call stdlib_scopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) - if( k>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 ) @@ -9351,7 +9353,7 @@ module stdlib_linalg_lapack_s ! ( 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 @@ -9386,32 +9388,32 @@ module stdlib_linalg_lapack_s 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 @@ -9421,16 +9423,16 @@ module stdlib_linalg_lapack_s ! 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 = 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 absakk = abs( w( k, k ) ) @@ -9438,16 +9440,16 @@ module stdlib_linalg_lapack_s ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k1 )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 @@ -9491,7 +9493,7 @@ module stdlib_linalg_lapack_s ! use 1-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}$ ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -9499,7 +9501,7 @@ module stdlib_linalg_lapack_s ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found: set params and repeat @@ -9507,42 +9509,42 @@ module stdlib_linalg_lapack_s colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth 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}$ ) end if ! end pivot search loop body if( .not. done ) goto 72 end if ! ============================================================ - kk = k + kstep - 1 - if( ( kstep==2 ) .and. ( p/=k ) ) then + kk = k + kstep - 1_${ik}$ + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_scopy( p-k, a( k, k ), 1, a( p, k ), lda ) - call stdlib_scopy( n-p+1, a( p, k ), 1, a( p, p ), 1 ) + call stdlib${ii}$_scopy( p-k, a( k, k ), 1_${ik}$, a( p, k ), lda ) + call stdlib${ii}$_scopy( n-p+1, a( p, k ), 1_${ik}$, a( p, p ), 1_${ik}$ ) ! interchange rows k and p in first k columns of a ! and first k+1 columns of w - call stdlib_sswap( k, a( k, 1 ), lda, a( p, 1 ), lda ) - call stdlib_sswap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw ) + call stdlib${ii}$_sswap( k, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda ) + call stdlib${ii}$_sswap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw ) end if ! updated column kp is already stored in column kk of w if( kp/=kk ) then ! copy non-updated column kk to column kp a( kp, k ) = a( kk, k ) - call stdlib_scopy( kp-k-1, a( k+1, kk ), 1, a( kp, k+1 ), lda ) - call stdlib_scopy( n-kp+1, a( kp, kk ), 1, a( kp, kp ), 1 ) + call stdlib${ii}$_scopy( kp-k-1, a( k+1, kk ), 1_${ik}$, a( kp, k+1 ), lda ) + call stdlib${ii}$_scopy( n-kp+1, a( kp, kk ), 1_${ik}$, a( kp, kp ), 1_${ik}$ ) ! interchange rows kk and kp in first kk columns of a and w - call stdlib_sswap( kk, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_sswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + call stdlib${ii}$_sswap( kk, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) + call stdlib${ii}$_sswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of w now holds ! w(k) = l(k)*d(k) ! where l(k) is the k-th column of l ! store l(k) in column k of a - call stdlib_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=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 ) @@ -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,42 +9591,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 ! put l21 in standard form by partially undoing the interchanges ! in columns 1:k-1 - j = 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 @@ -9641,8 +9643,8 @@ module stdlib_linalg_lapack_s ! -- 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,42 +9653,42 @@ 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 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 @@ -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 @@ -9825,14 +9827,14 @@ module stdlib_linalg_lapack_s if( ( grow*tscal )>smlnum ) then ! use the level 2 blas solve if the reciprocal of the bound on ! elements of x is not too small. - call stdlib_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. 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 @@ -9853,7 +9855,7 @@ module stdlib_linalg_lapack_s if( xj>tjj*bignum ) then ! scale x by 1/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 @@ -9871,7 +9873,7 @@ module stdlib_linalg_lapack_s ! 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 @@ -9896,23 +9898,23 @@ module stdlib_linalg_lapack_s if( cnorm( j )>( bignum-xmax )*rec ) then ! scale x by 1/(2*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 ) + 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) 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 @@ -9949,7 +9951,7 @@ 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 @@ -9999,7 +10001,7 @@ module stdlib_linalg_lapack_s if( xj>tjj*bignum ) then ! scale x by 1/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 @@ -10010,7 +10012,7 @@ module stdlib_linalg_lapack_s if( xj>tjj*bignum ) then ! scale x by (1/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 @@ -10038,13 +10040,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_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 @@ -10061,8 +10063,8 @@ module stdlib_linalg_lapack_s ! -- 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. 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 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 @@ -10160,7 +10162,7 @@ module stdlib_linalg_lapack_s ! initially, g(0) = max{x(i), i=1,...,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. @@ -10176,7 +10178,7 @@ module stdlib_linalg_lapack_s grow = zero end if ip = ip + jinc*jlen - jlen = jlen - 1 + jlen = jlen - 1_${ik}$ end do grow = xbnd else @@ -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 @@ -10212,8 +10214,8 @@ module stdlib_linalg_lapack_s ! initially, m(0) = max{x(i), i=1,...,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 @@ -10223,7 +10225,7 @@ module stdlib_linalg_lapack_s ! m(j) = m(j-1)*( 1 + 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 ) @@ -10244,19 +10246,19 @@ module stdlib_linalg_lapack_s if( ( grow*tscal )>smlnum ) then ! use the level 2 blas solve if the reciprocal of the bound on ! elements of x is not too small. - call stdlib_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. 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 ) ) @@ -10273,7 +10275,7 @@ module stdlib_linalg_lapack_s if( xj>tjj*bignum ) then ! scale x by 1/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 @@ -10291,7 +10293,7 @@ module stdlib_linalg_lapack_s ! 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 @@ -10316,20 +10318,20 @@ module stdlib_linalg_lapack_s if( cnorm( j )>( bignum-xmax )*rec ) then ! scale x by 1/(2*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 ) + 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 ) + 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 @@ -10370,7 +10372,7 @@ module stdlib_linalg_lapack_s uscal = uscal / tjjs end if if( rectjj*bignum ) then ! scale x by 1/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 @@ -10426,7 +10428,7 @@ module stdlib_linalg_lapack_s if( xj>tjj*bignum ) then ! scale x by (1/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 @@ -10448,7 +10450,7 @@ module stdlib_linalg_lapack_s 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,13 +10458,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_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 @@ -10479,8 +10481,8 @@ module stdlib_linalg_lapack_s ! -- 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,40 +10491,40 @@ 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( ldasmlnum ) then ! use the level 2 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. 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 @@ -10680,7 +10682,7 @@ module stdlib_linalg_lapack_s if( xj>tjj*bignum ) then ! scale x by 1/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 @@ -10698,7 +10700,7 @@ module stdlib_linalg_lapack_s ! 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 @@ -10723,29 +10725,29 @@ module stdlib_linalg_lapack_s if( cnorm( j )>( bignum-xmax )*rec ) then ! scale x by 1/(2*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 ) + 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 ) + 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( jtjj*bignum ) then ! scale x by 1/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 @@ -10829,7 +10831,7 @@ module stdlib_linalg_lapack_s if( xj>tjj*bignum ) then ! scale x by (1/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 @@ -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. @@ -10877,31 +10879,31 @@ 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 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,10 +11145,10 @@ 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 @@ -11156,8 +11158,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) :: 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,23 +11167,23 @@ 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 ) + call stdlib${ii}$_sorgl2( ib, n-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) ! set columns 1:i-1 of current block to zero do j = 1, i - 1 do l = i, i + ib - 1 @@ -11455,12 +11457,12 @@ 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 @@ -11470,8 +11472,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) :: 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 ) + 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 & + 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,12 +11578,12 @@ 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 @@ -11591,8 +11593,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) :: 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 ) + call stdlib${ii}$_sorg2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work,iinfo ) ! set rows 1:i-1 of current block to zero do j = i, i + ib - 1 do l = 1, i - 1 @@ -11692,12 +11694,12 @@ 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 @@ -11707,8 +11709,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) :: 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,23 +11718,23 @@ 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 ) + 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 ) + 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,12 +11881,12 @@ 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 @@ -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,55 +11916,55 @@ 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 ( mbnq ) 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,28 +12625,28 @@ 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 + mi = m - i + 1_${ik}$ ic = i else ! h or h**t is applied to c(1:m,i:n) - ni = n - i + 1 + 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 @@ -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,26 +12764,26 @@ 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 + 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 + 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 @@ -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 + mi = m - i + 1_${ik}$ ic = i else ! h or h**t is applied to c(1:m,i:n) - ni = n - i + 1 + 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 @@ -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,26 +13237,26 @@ 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 + 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 + 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 @@ -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,28 +13387,28 @@ 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 + mi = m - i + 1_${ik}$ ic = i else ! h or h**t is applied to c(1:m,i:n) - ni = n - i + 1 + 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, @@ -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 @@ -13577,30 +13579,30 @@ module stdlib_linalg_lapack_s ! factorize a(m+1:n,m+1:n) as l**t*l, and update a(1:m,1:m). do j = n, m + 1, -1 ! compute s(j,j) and test for non-positive-definiteness. - ajj = 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. 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 @@ -13625,38 +13627,38 @@ 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 ! 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 ) + 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 ! 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 + if( nr>0_${ik}$ ) then ! apply rotations in 1st 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 ! 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 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 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 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 + if( nr>0_${ik}$ ) then ! generate rotations in 2nd 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 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 ! 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 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 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 + j2 = i - k - 1_${ik}$ + max( 1_${ik}$, k-i0+2 )*ka1 ! finish applying rotations in 1st set from the left do l = kb - k, 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_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 @@ -14862,35 +14864,35 @@ module stdlib_linalg_lapack_s end do ! generate rotations in 1st 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 + if( nr>0_${ik}$ ) then ! apply rotations in 1st 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 ! 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 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 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 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 + if( nr>0_${ik}$ ) then ! generate rotations in 2nd 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 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 ! 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 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 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 + j2 = i - k - 1_${ik}$ + max( 1_${ik}$, k-i0+2 )*ka1 ! finish applying rotations in 1st set from the right do l = kb - k, 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_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 ) @@ -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 + if( nr>0_${ik}$ ) then ! apply rotations in 1st 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 ! 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 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 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 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 + if( nr>0_${ik}$ ) then ! generate rotations in 2nd 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 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 ! 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 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 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 + j2 = i + k + 1_${ik}$ - max( 1_${ik}$, k+i0-m+1 )*ka1 ! finish applying rotations in 1st 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 + if( nr>0_${ik}$ ) then ! apply rotations in 1st 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 ! 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 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 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 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 + if( nr>0_${ik}$ ) then ! generate rotations in 2nd 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 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 ! 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 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 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 + j2 = i + k + 1_${ik}$ - max( 1_${ik}$, k+i0-m+1 )*ka1 ! finish applying rotations in 1st 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,14 +15714,14 @@ 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 ) + pure subroutine stdlib${ii}$_ssfrk( transr, uplo, trans, n, k, alpha, a, lda, beta,c ) !! Level 3 BLAS like routine for C in RFP Format. !! SSFRK performs one of the symmetric rank--k operations !! C := alpha*A*A**T + beta*C, @@ -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 + 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 @@ -16174,7 +16176,7 @@ module stdlib_linalg_lapack_s 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,9 +16184,9 @@ 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 @@ -16198,18 +16200,18 @@ module stdlib_linalg_lapack_s ! interchange rows and columns k-1 and imax, use 2-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 + 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,23 +16219,23 @@ 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 + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u ! perform a rank-1 update of a(1:k-1,1:k-1) as ! a := a - u(k)*d(k)*u(k)**t = a - w(k)*1/d(k)*w(k)**t r1 = one / ap( kc+k-1 ) - call stdlib_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 ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k) @@ -16242,29 +16244,29 @@ module stdlib_linalg_lapack_s ! perform a rank-2 update of a(1:k-2,1:k-2) as ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**t ! = a - ( 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 @@ -16278,28 +16280,28 @@ module stdlib_linalg_lapack_s ! 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 = 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 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 @@ -16317,9 +16319,9 @@ 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 @@ -16333,19 +16335,19 @@ module stdlib_linalg_lapack_s ! interchange rows and columns k+1 and imax, use 2-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 = 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. ap( kc+k-1 ) = one / ap( kc+k-1 ) ! compute column k of the inverse. - if( k>1 ) 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 ! invert the diagonal block. @@ -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 + 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 @@ -16553,25 +16555,25 @@ module stdlib_linalg_lapack_s ! 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 + 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. ap( kc ) = one / ap( kc ) ! compute column k of the inverse. if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_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 ! 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,43 +16719,43 @@ 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 = 1_${ik}$ + kc = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(u**t(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_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 ! 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 @@ -16762,36 +16764,36 @@ module stdlib_linalg_lapack_s ! 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 = 1_${ik}$ + kc = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(l**t(k)), where l(k) is the transformation ! stored in column k of a. - if( k=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 ! 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 + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SSTEBZ', ' ', n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ )nb = 0_${ik}$ ! 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,23 +17060,23 @@ 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 + if( in==1_${ik}$ ) 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( 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 @@ -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 i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(1:i,n-i:n) ip = ipiv( i ) if( i0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(1: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 + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(i:n,1: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) 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,9 +17650,9 @@ 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) @@ -17659,23 +17661,23 @@ module stdlib_linalg_lapack_s ! in reverse factorization order where i decreases from n to 1 i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(i:n,1: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 + 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 i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(1:i,n-i:n) ip = ipiv( i ) if( i0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(1: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,31 +17862,31 @@ 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 + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(i:n,1: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 @@ -17893,17 +17895,17 @@ module stdlib_linalg_lapack_s ! in a(i:n,1: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) @@ -17912,52 +17914,52 @@ module stdlib_linalg_lapack_s ! in reverse factorization order where i decreases from n to 1 i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(i:n,1: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+1) and i and ipiv(i) ! in a(i:n,1:i-1) - i = 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,23 +18119,23 @@ 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, @@ -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 @@ -18357,17 +18359,17 @@ module stdlib_linalg_lapack_s 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 ) + 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 @@ -18375,27 +18377,27 @@ module stdlib_linalg_lapack_s 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 ) + 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,10 +18462,10 @@ 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), @@ -18478,10 +18480,10 @@ 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(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: e(*) ! ===================================================================== @@ -18491,42 +18493,42 @@ 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) @@ -18563,13 +18565,13 @@ module stdlib_linalg_lapack_s ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = imax + stdlib_isamax( k-imax, a( imax, imax+1 ),lda ) + jmax = imax + stdlib${ii}$_isamax( k-imax, a( imax, imax+1 ),lda ) rowmax = abs( a( imax, jmax ) ) else rowmax = zero end if - if( imax>1 ) 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 @@ -18589,7 +18591,7 @@ module stdlib_linalg_lapack_s ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found, set variables and repeat @@ -18602,45 +18604,45 @@ module stdlib_linalg_lapack_s end if ! swap two rows and two columns ! first swap - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! interchange rows and column k and p in the leading ! submatrix a(1:k,1:k) if we have a 2-by-2 pivot - if( p>1 )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 ) + 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 ) + 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 + if( k>1_${ik}$ ) then ! perform a rank-1 update of a(1:k-1,1:k-1) and ! store u(k) in column k if( abs( a( k, k ) )>=sfmin ) then @@ -18648,9 +18650,9 @@ module stdlib_linalg_lapack_s ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*1/d(k)*w(k)**t d11 = one / a( k, k ) - call stdlib_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 ) @@ -18661,7 +18663,7 @@ module stdlib_linalg_lapack_s ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_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 @@ -18675,7 +18677,7 @@ module stdlib_linalg_lapack_s ! 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 @@ -18717,11 +18719,11 @@ module stdlib_linalg_lapack_s e( n ) = zero ! k is the main loop index, increasing from 1 to n in steps of ! 1 or 2 - k = 1 + 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 @@ -18730,14 +18732,14 @@ module stdlib_linalg_lapack_s ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( krowmax ) then rowmax = stemp @@ -18783,7 +18785,7 @@ module stdlib_linalg_lapack_s ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found, set variables and repeat @@ -18796,42 +18798,42 @@ module stdlib_linalg_lapack_s end if ! swap two rows and two columns ! first swap - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! interchange rows and column k and p in the trailing ! submatrix a(k:n,k:n) if we have a 2-by-2 pivot - if( p(k+1) )call stdlib_sswap( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) + 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 ) + 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 ) + 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 + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = l(k)*d(k) ! where l(k) is the k-th column of l @@ -18843,10 +18845,10 @@ module stdlib_linalg_lapack_s ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t d11 = one / a( k, k ) - call stdlib_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 ) @@ -18857,7 +18859,7 @@ module stdlib_linalg_lapack_s ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_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 @@ -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,10 +18914,10 @@ 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 @@ -18928,10 +18930,10 @@ 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(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) real(sp), intent(inout) :: a(lda,*) ! ===================================================================== ! Parameters @@ -18940,30 +18942,30 @@ 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 @@ -19007,13 +19009,13 @@ module stdlib_linalg_lapack_s ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = imax + stdlib_isamax( k-imax, a( imax, imax+1 ),lda ) + jmax = imax + stdlib${ii}$_isamax( k-imax, a( imax, imax+1 ),lda ) rowmax = abs( a( imax, jmax ) ) else rowmax = zero end if - if( imax>1 ) 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 @@ -19033,7 +19035,7 @@ module stdlib_linalg_lapack_s ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found, set variables and repeat @@ -19046,39 +19048,39 @@ module stdlib_linalg_lapack_s end if ! swap two rows and two columns ! first swap - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! interchange rows and column k and p in the leading ! submatrix a(1:k,1:k) if we have a 2-by-2 pivot - if( p>1 )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 ) + 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 ) + 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 + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u - if( k>1 ) then + if( k>1_${ik}$ ) then ! perform a rank-1 update of a(1:k-1,1:k-1) and ! store u(k) in column k if( abs( a( k, k ) )>=sfmin ) then @@ -19086,9 +19088,9 @@ module stdlib_linalg_lapack_s ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*1/d(k)*w(k)**t d11 = one / a( k, k ) - call stdlib_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 ) @@ -19099,7 +19101,7 @@ module stdlib_linalg_lapack_s ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_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 @@ -19111,7 +19113,7 @@ module stdlib_linalg_lapack_s ! 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 @@ -19144,11 +19146,11 @@ module stdlib_linalg_lapack_s ! 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 = 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 @@ -19157,14 +19159,14 @@ module stdlib_linalg_lapack_s ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( krowmax ) then rowmax = stemp @@ -19208,7 +19210,7 @@ module stdlib_linalg_lapack_s ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found, set variables and repeat @@ -19221,36 +19223,36 @@ module stdlib_linalg_lapack_s end if ! swap two rows and two columns ! first swap - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! interchange rows and column k and p in the trailing ! submatrix a(k:n,k:n) if we have a 2-by-2 pivot - if( p(k+1) )call stdlib_sswap( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) + 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 + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = l(k)*d(k) ! where l(k) is the k-th column of l @@ -19262,10 +19264,10 @@ module stdlib_linalg_lapack_s ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t d11 = one / a( k, k ) - call stdlib_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 ) @@ -19276,7 +19278,7 @@ module stdlib_linalg_lapack_s ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_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 @@ -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,10 +19325,10 @@ 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), @@ -19341,60 +19343,60 @@ 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, 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 ) + 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 ) + 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 ! read ipiv from the last block factored, i.e. @@ -19424,7 +19426,7 @@ module stdlib_linalg_lapack_s do i = k, ( k - kb + 1 ), -1 ip = abs( ipiv( i ) ) if( ip/=i ) then - call stdlib_sswap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda ) + call stdlib${ii}$_sswap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda ) end if end do end if @@ -19437,31 +19439,31 @@ module stdlib_linalg_lapack_s 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_rk; + ! kb, where kb is the number of columns factorized by stdlib${ii}$_slasyf_rk; ! kb is either nb or nb-1, or n-k+1 for the last block - k = 1 + k = 1_${ik}$ 20 continue ! if k > n, exit from loop if( k>n )go to 35 if( k<=n-nb ) then ! factorize columns k:k+kb-1 of a and use blocked code to ! update columns k+kb:n - call stdlib_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 @@ -19471,11 +19473,11 @@ module stdlib_linalg_lapack_s ! (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 + 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 @@ -19487,12 +19489,12 @@ module stdlib_linalg_lapack_s 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 @@ -19506,60 +19508,60 @@ 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, 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 ) + 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 ) + 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 @@ -19584,30 +19586,30 @@ module stdlib_linalg_lapack_s 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; + ! 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 = 1_${ik}$ 30 continue ! if k > n, exit from loop. if( k>n )go to 40 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = one / a( k, k ) ! compute column k of the inverse. - if( k>1 ) 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 ! invert the diagonal block. @@ -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 ) + 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 @@ -19746,18 +19748,18 @@ module stdlib_linalg_lapack_s 50 continue ! if k < 1, exit from loop. if( k<1 )go to 60 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = one / a( k, k ) ! compute column k of the inverse. if( 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 = 1_${ik}$ 30 continue ! if k > n, exit from loop. if( k>n )go to 40 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = one / a( k, k ) ! compute column k of the inverse. - if( k>1 ) 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 ! invert the diagonal block. @@ -19893,28 +19895,28 @@ 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) 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 @@ -19924,8 +19926,8 @@ module stdlib_linalg_lapack_s ! -ipiv(k+1)in the leading submatrix a(1:k+1,1:k+1) kp = -ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_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,17 +19935,17 @@ 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 @@ -19954,18 +19956,18 @@ module stdlib_linalg_lapack_s 50 continue ! if k < 1, exit from loop. if( k<1 )go to 60 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = one / a( k, k ) ! compute column k of the inverse. if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_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 ! 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,39 +20124,39 @@ 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 = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(u**t(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_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 ! 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 @@ -20163,34 +20165,34 @@ module stdlib_linalg_lapack_s ! 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 = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(l**t(k)), where l(k) is the transformation ! stored in column k of a. - if( k= 1 ) - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_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 ! 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_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 ! 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_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 ! 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_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 ! 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: @@ -20439,36 +20441,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,*), 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,12 +20508,12 @@ 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. @@ -20521,7 +20523,7 @@ module stdlib_linalg_lapack_s 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 @@ -20536,16 +20538,16 @@ module stdlib_linalg_lapack_s 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. @@ -20572,16 +20574,16 @@ module stdlib_linalg_lapack_s 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,42 +20593,42 @@ 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 + 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 ! 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) + 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_sgtsv(n, nrhs, work(1), work(n), work(2*n), b, ldb,info) + call stdlib${ii}$_sgtsv(n, nrhs, work(1_${ik}$), work(n), work(2_${ik}$*n), b, ldb,info) ! 3) backward substitution with u - if( n>1 ) then + 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 + 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 ! 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) + 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_sgtsv(n, nrhs, work(1), work(n), work(2*n), b, ldb,info) + call stdlib${ii}$_sgtsv(n, nrhs, work(1_${ik}$), work(n), work(2_${ik}$*n), b, ldb,info) ! 3) backward substitution with l**t - if( n>1 ) then + 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_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 ! 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,43 +20800,43 @@ 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 = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(u**t(k)), where u(k) is the transformation ! stored in column k of a. - if( k>1 )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 ! 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 @@ -20843,36 +20845,36 @@ module stdlib_linalg_lapack_s ! 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 = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(l**t(k)), where l(k) is the transformation ! stored in column k of a. - if( k 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 + 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 + 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 @@ -21868,38 +21870,38 @@ module stdlib_linalg_lapack_s ! 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 + 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 + 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 @@ -21912,13 +21914,13 @@ module stdlib_linalg_lapack_s ! 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 + 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 + 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 @@ -21958,48 +21960,48 @@ module stdlib_linalg_lapack_s ! 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 + 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 + 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 @@ -23718,35 +23720,35 @@ module stdlib_linalg_lapack_s 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 ) + 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 @@ -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 + if( kl+ku>1_${ik}$ ) then ! reduce to upper bidiagonal form if ku > 0; if ku = 0, 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. @@ -24884,107 +24886,107 @@ module stdlib_linalg_lapack_s 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 ) + 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 @@ -24994,31 +24996,31 @@ module stdlib_linalg_lapack_s 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,14 +25053,14 @@ 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, !! using the LU factorization computed by SGBTRF. @@ -25071,13 +25073,13 @@ 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(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 + info = 0_${ik}$ onenrm = norm=='1' .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 @@ -25174,9 +25176,9 @@ module stdlib_linalg_lapack_s ! divide x by 1/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 @@ -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,10 +25662,10 @@ 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. @@ -25671,19 +25673,19 @@ 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) :: 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,38 +25884,38 @@ 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 !! the LU factorization computed by SGETRF. @@ -25925,12 +25927,12 @@ 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(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 + info = 0_${ik}$ onenrm = norm=='1' .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,10 +26275,10 @@ 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 @@ -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,12 +26527,12 @@ 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 @@ -26540,34 +26542,34 @@ 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 ! 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 ) + call stdlib${ii}$_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 ) )= 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( 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 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 !! future. @@ -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,10 +27662,10 @@ 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 @@ -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,10 +27999,10 @@ 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 @@ -28016,42 +28018,42 @@ 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 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,10 +28538,10 @@ 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 @@ -28555,39 +28557,39 @@ 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 + if ( ipiv( k )>0_${ik}$ ) then ! 1x1 pivot kp = ipiv( k ) if ( kp /= k ) then @@ -28782,7 +28784,7 @@ 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 kp = -ipiv( k ) @@ -28794,31 +28796,31 @@ 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 + if ( ipiv( k )>0_${ik}$ ) then ! 1x1 pivot kp = ipiv( k ) if ( kp /= k ) then @@ -28829,7 +28831,7 @@ 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 kp = -ipiv( k ) @@ -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,14 +28907,14 @@ 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) @@ -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,9 +29008,9 @@ 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 @@ -29016,9 +29018,9 @@ module stdlib_linalg_lapack_s ! determine if scaling of inputs necessary to avoid overflow ! when computing 1/temp**3 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 @@ -29073,14 +29075,14 @@ module stdlib_linalg_lapack_s ! if finit < 0; ! 2) 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,23 +29124,23 @@ 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 ) + pure subroutine stdlib${ii}$_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 !! that if ( UPPER ) then !! U**T *A*Q = U**T *( A1 A2 )*Q = ( x 0 ) @@ -29183,7 +29185,7 @@ module stdlib_linalg_lapack_s ! 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 ) + 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|. @@ -29197,12 +29199,12 @@ module stdlib_linalg_lapack_s 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 @@ -29221,12 +29223,12 @@ module stdlib_linalg_lapack_s 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 @@ -29243,7 +29245,7 @@ module stdlib_linalg_lapack_s ! 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 ) + 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|. @@ -29257,12 +29259,12 @@ module stdlib_linalg_lapack_s 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 @@ -29281,12 +29283,12 @@ module stdlib_linalg_lapack_s 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 @@ -29514,11 +29516,11 @@ module stdlib_linalg_lapack_s end if else ! come to here if job = 2 or -2 - if( job==2 ) then + 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,10 +29585,10 @@ 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 @@ -29611,7 +29613,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) :: 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 @@ -29818,13 +29820,13 @@ 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, 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,7 +30157,7 @@ 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 @@ -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,14 +30230,14 @@ 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 @@ -30246,7 +30248,7 @@ module stdlib_linalg_lapack_s 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 + if( n==0_${ik}$ ) then + stdlib${ii}$_slansf = zero return - else if( n==1 ) then - stdlib_slansf = abs( a(0) ) + else if( n==1_${ik}$ ) then + stdlib${ii}$_slansf = abs( a(0_${ik}$) ) 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 + noe = 1_${ik}$ + if( mod( n, 2_${ik}$ )==0_${ik}$ )noe = 0_${ik}$ ! set ifm = 0 when form='t or 't' and 1 otherwise - ifm = 1 - if( stdlib_lsame( transr, 'T' ) )ifm = 0 + ifm = 1_${ik}$ + if( stdlib_lsame( transr, 'T' ) )ifm = 0_${ik}$ ! set ilu = 0 when uplo='u or 'u' and 1 otherwise - ilu = 1 - if( stdlib_lsame( uplo, 'U' ) )ilu = 0 + ilu = 1_${ik}$ + if( stdlib_lsame( uplo, 'U' ) )ilu = 0_${ik}$ ! 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( ifm==1_${ik}$ ) then + if( noe==1_${ik}$ ) then lda = n else ! noe=0 - lda = n + 1 + lda = n + 1_${ik}$ end if else ! ifm=0 - lda = ( n+1 ) / 2 + 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,7 +30394,7 @@ 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 @@ -30400,11 +30402,11 @@ module stdlib_linalg_lapack_s else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( & norm=='1' ) ) 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,14 +30437,14 @@ 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 = k + 1_${ik}$ ! k=(n+1)/2 for n odd and ilu=1 do i = k, n - 1 work( i ) = zero @@ -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,10 +30515,10 @@ 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 @@ -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 + 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 + 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,14 +30617,14 @@ 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 = k + 1_${ik}$ ! k=(n+1)/2 for n odd and ilu=1 do i = k, n - 1 work( i ) = zero @@ -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 @@ -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,10 +30753,10 @@ 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 @@ -30762,7 +30764,7 @@ module stdlib_linalg_lapack_s work( i ) = zero end do ! j=0 is special :process col a(k:n-1,k) - s = abs( a( 0 ) ) + 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 @@ -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 ) + call stdlib${ii}$_slassq( k-j-2, a( k+j+1+j*lda ), 1_${ik}$, scale, s ) ! l at a(k,0) end do do j = 0, k - 1 - call stdlib_slassq( k+j-1, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_slassq( k+j-1, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! trap u at a(0,0) end do s = s + s ! double s for the off diagonal elements - call stdlib_slassq( k-1, a( k ), lda+1, scale, s ) + call stdlib${ii}$_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 ) + call stdlib${ii}$_slassq( k, a( k-1 ), lda+1, scale, s ) ! tri u at a(k-1,0) else ! ilu=1 do j = 0, k - 1 - call stdlib_slassq( n-j-1, a( j+1+j*lda ), 1, scale, s ) + call stdlib${ii}$_slassq( n-j-1, a( j+1+j*lda ), 1_${ik}$, scale, s ) ! trap l at a(0,0) end do do j = 0, k - 2 - call stdlib_slassq( j, a( 0+( 1+j )*lda ), 1, scale, s ) + call stdlib${ii}$_slassq( j, a( 0_${ik}$+( 1_${ik}$+j )*lda ), 1_${ik}$, scale, s ) ! u at a(0,1) end do s = s + s ! double s for the off diagonal elements - call stdlib_slassq( k, a( 0 ), lda+1, scale, s ) + call stdlib${ii}$_slassq( k, a( 0_${ik}$ ), lda+1, scale, s ) ! tri l at a(0,0) - call stdlib_slassq( k-1, a( 0+lda ), lda+1, scale, s ) + call stdlib${ii}$_slassq( k-1, a( 0_${ik}$+lda ), lda+1, scale, s ) ! tri u at a(0,1) 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 ) + call stdlib${ii}$_slassq( j, a( 0_${ik}$+( k+j )*lda ), 1_${ik}$, scale, s ) ! u at a(0,k) end do do j = 0, k - 2 - call stdlib_slassq( k, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_slassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! k by k-1 rect. at a(0,0) end do do j = 0, k - 2 - call stdlib_slassq( k-j-1, a( j+1+( j+k-1 )*lda ), 1,scale, s ) + call stdlib${ii}$_slassq( k-j-1, a( j+1+( j+k-1 )*lda ), 1_${ik}$,scale, s ) ! l at a(0,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 ) + call stdlib${ii}$_slassq( k-1, a( 0_${ik}$+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 ) + call stdlib${ii}$_slassq( k, a( 0_${ik}$+( k-1 )*lda ), lda+1, scale, s ) ! tri l at a(0,k-1) else ! a**t is lower do j = 1, k - 1 - call stdlib_slassq( j, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_slassq( j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! u at a(0,0) end do do j = k, n - 1 - call stdlib_slassq( k, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_slassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! k by k-1 rect. at a(0,k) end do do j = 0, k - 3 - call stdlib_slassq( k-j-2, a( j+2+j*lda ), 1, scale, s ) + call stdlib${ii}$_slassq( k-j-2, a( j+2+j*lda ), 1_${ik}$, scale, s ) ! l at a(1,0) end do s = s + s ! double s for the off diagonal elements - call stdlib_slassq( k, a( 0 ), lda+1, scale, s ) + call stdlib${ii}$_slassq( k, a( 0_${ik}$ ), lda+1, scale, s ) ! tri u at a(0,0) - call stdlib_slassq( k-1, a( 1 ), lda+1, scale, s ) + call stdlib${ii}$_slassq( k-1, a( 1_${ik}$ ), lda+1, scale, s ) ! tri l at a(1,0) 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 ) + call stdlib${ii}$_slassq( k-j-1, a( k+j+2+j*lda ), 1_${ik}$, scale, s ) ! l at a(k+1,0) end do do j = 0, k - 1 - call stdlib_slassq( k+j, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_slassq( k+j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! trap u at a(0,0) end do s = s + s ! double s for the off diagonal elements - call stdlib_slassq( k, a( k+1 ), lda+1, scale, s ) + call stdlib${ii}$_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 ) + call stdlib${ii}$_slassq( k, a( k ), lda+1, scale, s ) ! tri u at a(k,0) else ! ilu=1 do j = 0, k - 1 - call stdlib_slassq( n-j-1, a( j+2+j*lda ), 1, scale, s ) + call stdlib${ii}$_slassq( n-j-1, a( j+2+j*lda ), 1_${ik}$, scale, s ) ! trap l at a(1,0) end do do j = 1, k - 1 - call stdlib_slassq( j, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_slassq( j, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! u at a(0,0) end do s = s + s ! double s for the off diagonal elements - call stdlib_slassq( k, a( 1 ), lda+1, scale, s ) + call stdlib${ii}$_slassq( k, a( 1_${ik}$ ), lda+1, scale, s ) ! tri l at a(1,0) - call stdlib_slassq( k, a( 0 ), lda+1, scale, s ) + call stdlib${ii}$_slassq( k, a( 0_${ik}$ ), lda+1, scale, s ) ! tri u at a(0,0) 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 ) + call stdlib${ii}$_slassq( j, a( 0_${ik}$+( k+1+j )*lda ), 1_${ik}$, scale, s ) ! u at a(0,k+1) end do do j = 0, k - 1 - call stdlib_slassq( k, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_slassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! k by k rect. at a(0,0) end do do j = 0, k - 2 - call stdlib_slassq( k-j-1, a( j+1+( j+k )*lda ), 1, scale,s ) + call stdlib${ii}$_slassq( k-j-1, a( j+1+( j+k )*lda ), 1_${ik}$, scale,s ) ! l at a(0,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 ) + call stdlib${ii}$_slassq( k, a( 0_${ik}$+( 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 ) + call stdlib${ii}$_slassq( k, a( 0_${ik}$+k*lda ), lda+1, scale, s ) ! tri l at a(0,k) else ! a**t is lower do j = 1, k - 1 - call stdlib_slassq( j, a( 0+( j+1 )*lda ), 1, scale, s ) + call stdlib${ii}$_slassq( j, a( 0_${ik}$+( j+1 )*lda ), 1_${ik}$, scale, s ) ! u at a(0,1) end do do j = k + 1, n - call stdlib_slassq( k, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_slassq( k, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! k by k rect. at a(0,k+1) end do do j = 0, k - 2 - call stdlib_slassq( k-j-1, a( j+1+j*lda ), 1, scale, s ) + call stdlib${ii}$_slassq( k-j-1, a( j+1+j*lda ), 1_${ik}$, scale, s ) ! l at a(0,0) end do s = s + s ! double s for the off diagonal elements - call stdlib_slassq( k, a( lda ), lda+1, scale, s ) + call stdlib${ii}$_slassq( k, a( lda ), lda+1, scale, s ) ! tri l at a(0,1) - call stdlib_slassq( k, a( 0 ), lda+1, scale, s ) + call stdlib${ii}$_slassq( k, a( 0_${ik}$ ), lda+1, scale, s ) ! tri u at a(0,0) 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 ! 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,14 +31225,14 @@ 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 @@ -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,23 +31275,23 @@ 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. @@ -31298,7 +31300,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) :: 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,14 +31340,14 @@ 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 @@ -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 ! 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,14 +31739,14 @@ 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 @@ -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,24 +31859,24 @@ 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: @@ -31912,52 +31914,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, 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,10 +31967,10 @@ 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 ) + pure real(sp) function stdlib${ii}$_slapy2( x, y ) !! SLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary !! overflow and unnecessary underflow. ! -- lapack auxiliary routine -- @@ -31985,27 +31987,27 @@ 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 ) + pure subroutine stdlib${ii}$_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 !! 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). @@ -32016,200 +32018,200 @@ module stdlib_linalg_lapack_s !! 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, & + pure subroutine stdlib${ii}$_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 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)' 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) 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,15 +32319,15 @@ 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 @@ -32334,47 +32336,47 @@ module stdlib_linalg_lapack_s ! b(k+1:k+ns+np, k+ns+np:istopm) ! from the left with qc(1:ns+np,1: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) 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,7 +32384,7 @@ 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 @@ -32390,45 +32392,45 @@ module stdlib_linalg_lapack_s ! update a(ihi-ns+1:ihi, ihi+1:istopm) ! from the left with qc(1:ns,1: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) 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. if( alpha>=zero ) then @@ -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 )n)) r = n + if((r<1_${ik}$).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 ) @@ -32931,12 +32933,12 @@ module stdlib_linalg_lapack_s ! 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 + 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. @@ -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 + im = wend - wbegin + 1_${ik}$ ! this is for a 1x1 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 + ndepth = 0_${ik}$ ! parity is either 1 or 0 - parity = 1 + 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 + 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 ! 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*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. ldazero )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( dpsiabs( 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( dpsizero .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. @@ -34988,34 +34990,34 @@ module stdlib_linalg_lapack_s c = z( j ) ! find sqrt(a**2+b**2) 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,7 +35027,7 @@ 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 @@ -35039,51 +35041,51 @@ module stdlib_linalg_lapack_s 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 ) + call stdlib${ii}$_scopy( n-k, dsigma( k+1 ), 1_${ik}$, d( k+1 ), 1_${ik}$ ) ! determine dsigma(1), dsigma(2), z(1), vf(1), vl(1), 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,39 +35098,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(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 + 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. 30 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 )

0 )info = ierr - call stdlib_sgesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) + call stdlib${ii}$_sgetc2( zdim, z, ldz, ipiv, jpiv, ierr ) + if( ierr>0_${ik}$ )info = ierr + call stdlib${ii}$_sgesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_sscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_sscal( m, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_sscal( m, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do scale = scale*scaloc end if ! unpack solution vector(s) - c( is, js ) = rhs( 1 ) - c( is, jsp1 ) = rhs( 2 ) - f( is, js ) = rhs( 3 ) - f( is, jsp1 ) = rhs( 4 ) + c( is, js ) = rhs( 1_${ik}$ ) + c( is, jsp1 ) = rhs( 2_${ik}$ ) + f( is, js ) = rhs( 3_${ik}$ ) + f( is, jsp1 ) = rhs( 4_${ik}$ ) ! substitute r(i, j) and l(i, j) into remaining ! equation. if( j>p+2 ) then - call stdlib_saxpy( js-1, rhs( 1 ), b( 1, js ), 1,f( is, 1 ), ldf ) + call stdlib${ii}$_saxpy( js-1, rhs( 1_${ik}$ ), b( 1_${ik}$, js ), 1_${ik}$,f( is, 1_${ik}$ ), ldf ) - call stdlib_saxpy( js-1, rhs( 2 ), b( 1, jsp1 ), 1,f( is, 1 ), ldf ) + call stdlib${ii}$_saxpy( js-1, rhs( 2_${ik}$ ), b( 1_${ik}$, jsp1 ), 1_${ik}$,f( is, 1_${ik}$ ), ldf ) - call stdlib_saxpy( js-1, rhs( 3 ), e( 1, js ), 1,f( is, 1 ), ldf ) + call stdlib${ii}$_saxpy( js-1, rhs( 3_${ik}$ ), e( 1_${ik}$, js ), 1_${ik}$,f( is, 1_${ik}$ ), ldf ) - call stdlib_saxpy( js-1, rhs( 4 ), e( 1, jsp1 ), 1,f( is, 1 ), ldf ) + call stdlib${ii}$_saxpy( js-1, rhs( 4_${ik}$ ), e( 1_${ik}$, jsp1 ), 1_${ik}$,f( is, 1_${ik}$ ), ldf ) end if if( i

0 )info = ierr - call stdlib_sgesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) + call stdlib${ii}$_sgetc2( zdim, z, ldz, ipiv, jpiv, ierr ) + if( ierr>0_${ik}$ )info = ierr + call stdlib${ii}$_sgesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_sscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_sscal( m, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_sscal( m, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do scale = scale*scaloc end if ! unpack solution vector(s) - c( is, js ) = rhs( 1 ) - c( isp1, js ) = rhs( 2 ) - f( is, js ) = rhs( 3 ) - f( isp1, js ) = rhs( 4 ) + c( is, js ) = rhs( 1_${ik}$ ) + c( isp1, js ) = rhs( 2_${ik}$ ) + f( is, js ) = rhs( 3_${ik}$ ) + f( isp1, js ) = rhs( 4_${ik}$ ) ! substitute r(i, j) and l(i, j) into remaining ! equation. if( j>p+2 ) then - call stdlib_sger( mb, js-1, one, rhs( 1 ), 1, b( 1, js ),1, f( is, 1 ), & + call stdlib${ii}$_sger( mb, js-1, one, rhs( 1_${ik}$ ), 1_${ik}$, b( 1_${ik}$, js ),1_${ik}$, f( is, 1_${ik}$ ), & ldf ) - call stdlib_sger( mb, js-1, one, rhs( 3 ), 1, e( 1, js ),1, f( is, 1 ), & + call stdlib${ii}$_sger( mb, js-1, one, rhs( 3_${ik}$ ), 1_${ik}$, e( 1_${ik}$, js ),1_${ik}$, f( is, 1_${ik}$ ), & ldf ) end if if( i

0 )info = ierr - call stdlib_sgesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) + call stdlib${ii}$_sgetc2( zdim, z, ldz, ipiv, jpiv, ierr ) + if( ierr>0_${ik}$ )info = ierr + call stdlib${ii}$_sgesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_sscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_sscal( m, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_sscal( m, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do scale = scale*scaloc end if ! unpack solution vector(s) - k = 1 - ii = mb*nb + 1 + k = 1_${ik}$ + ii = mb*nb + 1_${ik}$ do jj = 0, nb - 1 - call stdlib_scopy( mb, rhs( k ), 1, c( is, js+jj ), 1 ) - call stdlib_scopy( mb, rhs( ii ), 1, f( is, js+jj ), 1 ) + call stdlib${ii}$_scopy( mb, rhs( k ), 1_${ik}$, c( is, js+jj ), 1_${ik}$ ) + call stdlib${ii}$_scopy( mb, rhs( ii ), 1_${ik}$, f( is, js+jj ), 1_${ik}$ ) k = k + mb ii = ii + mb end do ! substitute r(i, j) and l(i, j) into remaining ! equation. if( j>p+2 ) then - call stdlib_sgemm( 'N', 'T', mb, js-1, nb, one,c( is, js ), ldc, b( 1, & - js ), ldb, one,f( is, 1 ), ldf ) - call stdlib_sgemm( 'N', 'T', mb, js-1, nb, one,f( is, js ), ldf, e( 1, & - js ), lde, one,f( is, 1 ), ldf ) + call stdlib${ii}$_sgemm( 'N', 'T', mb, js-1, nb, one,c( is, js ), ldc, b( 1_${ik}$, & + js ), ldb, one,f( is, 1_${ik}$ ), ldf ) + call stdlib${ii}$_sgemm( 'N', 'T', mb, js-1, nb, one,f( is, js ), ldf, e( 1_${ik}$, & + js ), lde, one,f( is, 1_${ik}$ ), ldf ) end if if( i

4 ) ) then - info = -2 - end if - end if - if( info==0 ) then - if( m<=0 ) then - info = -3 - else if( n<=0 ) then - info = -4 - else if( lda4_${ik}$ ) ) then + info = -2_${ik}$ + end if + end if + if( info==0_${ik}$ ) then + if( m<=0_${ik}$ ) then + info = -3_${ik}$ + else if( n<=0_${ik}$ ) then + info = -4_${ik}$ + else if( lda=3 ) then - ifunc = ijob - 2 - call stdlib_slaset( 'F', m, n, zero, zero, c, ldc ) - call stdlib_slaset( 'F', m, n, zero, zero, f, ldf ) - else if( ijob>=1 .and. notran ) then - isolve = 2 + if( ijob>=3_${ik}$ ) then + ifunc = ijob - 2_${ik}$ + call stdlib${ii}$_slaset( 'F', m, n, zero, zero, c, ldc ) + call stdlib${ii}$_slaset( 'F', m, n, zero, zero, f, ldf ) + else if( ijob>=1_${ik}$ .and. notran ) then + isolve = 2_${ik}$ end if end if - if( ( mb<=1 .and. nb<=1 ) .or. ( mb>=m .and. nb>=n ) )then + if( ( mb<=1_${ik}$ .and. nb<=1_${ik}$ ) .or. ( mb>=m .and. nb>=n ) )then loop_30: do iround = 1, isolve ! use unblocked level 2 solver dscale = zero dsum = one - pq = 0 - call stdlib_stgsy2( trans, ifunc, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f,& + pq = 0_${ik}$ + call stdlib${ii}$_stgsy2( trans, ifunc, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f,& ldf, scale, dsum, dscale,iwork, pq, info ) if( dscale/=zero ) then - if( ijob==1 .or. ijob==3 ) then - dif = sqrt( real( 2*m*n,KIND=sp) ) / ( dscale*sqrt( dsum ) ) + if( ijob==1_${ik}$ .or. ijob==3_${ik}$ ) then + dif = sqrt( real( 2_${ik}$*m*n,KIND=sp) ) / ( dscale*sqrt( dsum ) ) else dif = sqrt( real( pq,KIND=sp) ) / ( dscale*sqrt( dsum ) ) end if end if - if( isolve==2 .and. iround==1 ) then + if( isolve==2_${ik}$ .and. iround==1_${ik}$ ) then if( notran ) then ifunc = ijob end if scale2 = scale - call stdlib_slacpy( 'F', m, n, c, ldc, work, m ) - call stdlib_slacpy( 'F', m, n, f, ldf, work( m*n+1 ), m ) - call stdlib_slaset( 'F', m, n, zero, zero, c, ldc ) - call stdlib_slaset( 'F', m, n, zero, zero, f, ldf ) - else if( isolve==2 .and. iround==2 ) then - call stdlib_slacpy( 'F', m, n, work, m, c, ldc ) - call stdlib_slacpy( 'F', m, n, work( m*n+1 ), m, f, ldf ) + call stdlib${ii}$_slacpy( 'F', m, n, c, ldc, work, m ) + call stdlib${ii}$_slacpy( 'F', m, n, f, ldf, work( m*n+1 ), m ) + call stdlib${ii}$_slaset( 'F', m, n, zero, zero, c, ldc ) + call stdlib${ii}$_slaset( 'F', m, n, zero, zero, f, ldf ) + else if( isolve==2_${ik}$ .and. iround==2_${ik}$ ) then + call stdlib${ii}$_slacpy( 'F', m, n, work, m, c, ldc ) + call stdlib${ii}$_slacpy( 'F', m, n, work( m*n+1 ), m, f, ldf ) scale = scale2 end if end do loop_30 return end if ! determine block structure of a - p = 0 - i = 1 + p = 0_${ik}$ + i = 1_${ik}$ 40 continue if( i>m )go to 50 - p = p + 1 + p = p + 1_${ik}$ iwork( p ) = i i = i + mb if( i>=m )go to 50 - if( a( i, i-1 )/=zero )i = i + 1 + if( a( i, i-1 )/=zero )i = i + 1_${ik}$ go to 40 50 continue - iwork( p+1 ) = m + 1 - if( iwork( p )==iwork( p+1 ) )p = p - 1 + iwork( p+1 ) = m + 1_${ik}$ + if( iwork( p )==iwork( p+1 ) )p = p - 1_${ik}$ ! determine block structure of b - q = p + 1 - j = 1 + q = p + 1_${ik}$ + j = 1_${ik}$ 60 continue if( j>n )go to 70 - q = q + 1 + q = q + 1_${ik}$ iwork( q ) = j j = j + nb if( j>=n )go to 70 - if( b( j, j-1 )/=zero )j = j + 1 + if( b( j, j-1 )/=zero )j = j + 1_${ik}$ go to 60 70 continue - iwork( q+1 ) = n + 1 - if( iwork( q )==iwork( q+1 ) )q = q - 1 + iwork( q+1 ) = n + 1_${ik}$ + if( iwork( q )==iwork( q+1 ) )q = q - 1_${ik}$ if( notran ) then loop_150: do iround = 1, isolve ! solve (i, j)-subsystem @@ -42692,76 +42694,76 @@ module stdlib_linalg_lapack_s ! for i = p, p - 1,..., 1; j = 1, 2,..., q dscale = zero dsum = one - pq = 0 + pq = 0_${ik}$ scale = one loop_130: do j = p + 2, q js = iwork( j ) - je = iwork( j+1 ) - 1 - nb = je - js + 1 + je = iwork( j+1 ) - 1_${ik}$ + nb = je - js + 1_${ik}$ loop_120: do i = p, 1, -1 is = iwork( i ) - ie = iwork( i+1 ) - 1 - mb = ie - is + 1 - ppqq = 0 - call stdlib_stgsy2( trans, ifunc, mb, nb, a( is, is ), lda,b( js, js ), & + ie = iwork( i+1 ) - 1_${ik}$ + mb = ie - is + 1_${ik}$ + ppqq = 0_${ik}$ + call stdlib${ii}$_stgsy2( trans, ifunc, mb, nb, a( is, is ), lda,b( js, js ), & ldb, c( is, js ), ldc,d( is, is ), ldd, e( js, js ), lde,f( is, js ), ldf, & scaloc, dsum, dscale,iwork( q+2 ), ppqq, linfo ) - if( linfo>0 )info = linfo + if( linfo>0_${ik}$ )info = linfo pq = pq + ppqq if( scaloc/=one ) then do k = 1, js - 1 - call stdlib_sscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_sscal( m, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_sscal( m, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do do k = js, je - call stdlib_sscal( is-1, scaloc, c( 1, k ), 1 ) - call stdlib_sscal( is-1, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_sscal( is-1, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_sscal( is-1, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do do k = js, je - call stdlib_sscal( m-ie, scaloc, c( ie+1, k ), 1 ) - call stdlib_sscal( m-ie, scaloc, f( ie+1, k ), 1 ) + call stdlib${ii}$_sscal( m-ie, scaloc, c( ie+1, k ), 1_${ik}$ ) + call stdlib${ii}$_sscal( m-ie, scaloc, f( ie+1, k ), 1_${ik}$ ) end do do k = je + 1, n - call stdlib_sscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_sscal( m, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_sscal( m, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do scale = scale*scaloc end if ! substitute r(i, j) and l(i, j) into remaining ! equation. - if( i>1 ) then - call stdlib_sgemm( 'N', 'N', is-1, nb, mb, -one,a( 1, is ), lda, c( is, & - js ), ldc, one,c( 1, js ), ldc ) - call stdlib_sgemm( 'N', 'N', is-1, nb, mb, -one,d( 1, is ), ldd, c( is, & - js ), ldc, one,f( 1, js ), ldf ) + if( i>1_${ik}$ ) then + call stdlib${ii}$_sgemm( 'N', 'N', is-1, nb, mb, -one,a( 1_${ik}$, is ), lda, c( is, & + js ), ldc, one,c( 1_${ik}$, js ), ldc ) + call stdlib${ii}$_sgemm( 'N', 'N', is-1, nb, mb, -one,d( 1_${ik}$, is ), ldd, c( is, & + js ), ldc, one,f( 1_${ik}$, js ), ldf ) end if if( j0 )info = linfo + if( linfo>0_${ik}$ )info = linfo if( scaloc/=one ) then do k = 1, js - 1 - call stdlib_sscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_sscal( m, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_sscal( m, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do do k = js, je - call stdlib_sscal( is-1, scaloc, c( 1, k ), 1 ) - call stdlib_sscal( is-1, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_sscal( is-1, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_sscal( is-1, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do do k = js, je - call stdlib_sscal( m-ie, scaloc, c( ie+1, k ), 1 ) - call stdlib_sscal( m-ie, scaloc, f( ie+1, k ), 1 ) + call stdlib${ii}$_sscal( m-ie, scaloc, c( ie+1, k ), 1_${ik}$ ) + call stdlib${ii}$_sscal( m-ie, scaloc, f( ie+1, k ), 1_${ik}$ ) end do do k = je + 1, n - call stdlib_sscal( m, scaloc, c( 1, k ), 1 ) - call stdlib_sscal( m, scaloc, f( 1, k ), 1 ) + call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, k ), 1_${ik}$ ) + call stdlib${ii}$_sscal( m, scaloc, f( 1_${ik}$, k ), 1_${ik}$ ) end do scale = scale*scaloc end if ! substitute r(i, j) and l(i, j) into remaining equation. if( j>p+2 ) then - call stdlib_sgemm( 'N', 'T', mb, js-1, nb, one, c( is, js ),ldc, b( 1, js )& - , ldb, one, f( is, 1 ),ldf ) - call stdlib_sgemm( 'N', 'T', mb, js-1, nb, one, f( is, js ),ldf, e( 1, js )& - , lde, one, f( is, 1 ),ldf ) + call stdlib${ii}$_sgemm( 'N', 'T', mb, js-1, nb, one, c( is, js ),ldc, b( 1_${ik}$, js )& + , ldb, one, f( is, 1_${ik}$ ),ldf ) + call stdlib${ii}$_sgemm( 'N', 'T', mb, js-1, nb, one, f( is, js ),ldf, e( 1_${ik}$, js )& + , lde, one, f( is, 1_${ik}$ ),ldf ) end if if( i

0. if( anorm>zero ) then ! estimate the norm of the inverse of a. ainvnm = zero normin = 'N' if( onenrm ) then - kase1 = 1 + kase1 = 1_${ik}$ else - kase1 = 2 + kase1 = 2_${ik}$ end if - kase = 0 + 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(a). - call stdlib_slatps( uplo, 'NO TRANSPOSE', diag, normin, n, ap,work, scale, & - work( 2*n+1 ), info ) + call stdlib${ii}$_slatps( uplo, 'NO TRANSPOSE', diag, normin, n, ap,work, scale, & + work( 2_${ik}$*n+1 ), info ) else ! multiply by inv(a**t). - call stdlib_slatps( uplo, 'TRANSPOSE', diag, normin, n, ap,work, scale, work( & - 2*n+1 ), info ) + call stdlib${ii}$_slatps( uplo, 'TRANSPOSE', diag, normin, n, ap,work, scale, work( & + 2_${ik}$*n+1 ), info ) end if normin = 'Y' ! multiply by 1/scale if doing so will not cause overflow. if( scale/=one ) then - ix = stdlib_isamax( n, work, 1 ) + ix = stdlib${ii}$_isamax( n, work, 1_${ik}$ ) xnorm = abs( work( ix ) ) if( scalemin(m,n) ) then - info = -3 - else if( ldamin(m,n) ) then + info = -3_${ik}$ + else if( ldak ) then - info = -6 - else if( mb<1 .or. (mb>k .and. k>0) ) then - info = -7 + info = -2_${ik}$ + else if( m<0_${ik}$ ) then + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( k<0_${ik}$ ) then + info = -5_${ik}$ + else if( l<0_${ik}$ .or. l>k ) then + info = -6_${ik}$ + else if( mb<1_${ik}$ .or. (mb>k .and. k>0_${ik}$) ) then + info = -7_${ik}$ else if( ldv=l ) then - lb = 0 + lb = 0_${ik}$ else - lb = 0 + lb = 0_${ik}$ end if - call stdlib_stprfb( 'L', 'T', 'F', 'R', nb, n, ib, lb,v( i, 1 ), ldv, t( 1, i ), & - ldt,a( i, 1 ), lda, b, ldb, work, ib ) + call stdlib${ii}$_stprfb( 'L', 'T', 'F', 'R', nb, n, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), & + ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib ) end do else if( right .and. tran ) then do i = 1, k, mb ib = min( mb, k-i+1 ) nb = min( n-l+i+ib-1, n ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = nb-n+l-i+1 end if - call stdlib_stprfb( 'R', 'N', 'F', 'R', m, nb, ib, lb,v( i, 1 ), ldv, t( 1, i ), & - ldt,a( 1, i ), lda, b, ldb, work, m ) + call stdlib${ii}$_stprfb( 'R', 'N', 'F', 'R', m, nb, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), & + ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m ) end do else if( left .and. tran ) then kf = ((k-1)/mb)*mb+1 @@ -43112,12 +43114,12 @@ module stdlib_linalg_lapack_s ib = min( mb, k-i+1 ) nb = min( m-l+i+ib-1, m ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else - lb = 0 + lb = 0_${ik}$ end if - call stdlib_stprfb( 'L', 'N', 'F', 'R', nb, n, ib, lb,v( i, 1 ), ldv, t( 1, i ), & - ldt,a( i, 1 ), lda, b, ldb, work, ib ) + call stdlib${ii}$_stprfb( 'L', 'N', 'F', 'R', nb, n, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), & + ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib ) end do else if( right .and. notran ) then kf = ((k-1)/mb)*mb+1 @@ -43125,19 +43127,19 @@ module stdlib_linalg_lapack_s ib = min( mb, k-i+1 ) nb = min( n-l+i+ib-1, n ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = nb-n+l-i+1 end if - call stdlib_stprfb( 'R', 'T', 'F', 'R', m, nb, ib, lb,v( i, 1 ), ldv, t( 1, i ), & - ldt,a( 1, i ), lda, b, ldb, work, m ) + call stdlib${ii}$_stprfb( 'R', 'T', 'F', 'R', m, nb, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), & + ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m ) end do end if return - end subroutine stdlib_stpmlqt + end subroutine stdlib${ii}$_stpmlqt - pure subroutine stdlib_stpmqrt( side, trans, m, n, k, l, nb, v, ldv, t, ldt,a, lda, b, ldb, & + pure subroutine stdlib${ii}$_stpmqrt( side, trans, m, n, k, l, nb, v, ldv, t, ldt,a, lda, b, ldb, & !! STPMQRT applies a real orthogonal matrix Q obtained from a !! "triangular-pentagonal" real block reflector H to a general !! real matrix C, which consists of two blocks A and B. @@ -43147,8 +43149,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, lda, ldb, m, n, l, nb, ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k, ldv, lda, ldb, m, n, l, nb, ldt ! Array Arguments real(sp), intent(in) :: v(ldv,*), t(ldt,*) real(sp), intent(inout) :: a(lda,*), b(ldb,*) @@ -43156,48 +43158,48 @@ module stdlib_linalg_lapack_s ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran - integer(ilp) :: i, ib, mb, lb, kf, ldaq, ldvq + integer(${ik}$) :: i, ib, mb, lb, kf, ldaq, ldvq ! 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 - ldvq = max( 1, m ) - ldaq = max( 1, k ) + ldvq = max( 1_${ik}$, m ) + ldaq = max( 1_${ik}$, k ) else if ( right ) then - ldvq = max( 1, n ) - ldaq = max( 1, m ) + ldvq = max( 1_${ik}$, n ) + ldaq = max( 1_${ik}$, m ) 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 ) then - info = -5 - else if( l<0 .or. l>k ) then - info = -6 - else if( nb<1 .or. (nb>k .and. k>0) ) then - info = -7 + info = -2_${ik}$ + else if( m<0_${ik}$ ) then + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( k<0_${ik}$ ) then + info = -5_${ik}$ + else if( l<0_${ik}$ .or. l>k ) then + info = -6_${ik}$ + else if( nb<1_${ik}$ .or. (nb>k .and. k>0_${ik}$) ) then + info = -7_${ik}$ else if( ldv=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-m+l-i+1 end if - call stdlib_stprfb( 'L', 'T', 'F', 'C', mb, n, ib, lb,v( 1, i ), ldv, t( 1, i ), & - ldt,a( i, 1 ), lda, b, ldb, work, ib ) + call stdlib${ii}$_stprfb( 'L', 'T', 'F', 'C', mb, n, ib, lb,v( 1_${ik}$, i ), ldv, t( 1_${ik}$, i ), & + ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib ) end do else if( right .and. notran ) then do i = 1, k, nb ib = min( nb, k-i+1 ) mb = min( n-l+i+ib-1, n ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-n+l-i+1 end if - call stdlib_stprfb( 'R', 'N', 'F', 'C', m, mb, ib, lb,v( 1, i ), ldv, t( 1, i ), & - ldt,a( 1, i ), lda, b, ldb, work, m ) + call stdlib${ii}$_stprfb( 'R', 'N', 'F', 'C', m, mb, ib, lb,v( 1_${ik}$, i ), ldv, t( 1_${ik}$, i ), & + ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m ) end do else if( left .and. notran ) then kf = ((k-1)/nb)*nb+1 @@ -43232,12 +43234,12 @@ module stdlib_linalg_lapack_s ib = min( nb, k-i+1 ) mb = min( m-l+i+ib-1, m ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-m+l-i+1 end if - call stdlib_stprfb( 'L', 'N', 'F', 'C', mb, n, ib, lb,v( 1, i ), ldv, t( 1, i ), & - ldt,a( i, 1 ), lda, b, ldb, work, ib ) + call stdlib${ii}$_stprfb( 'L', 'N', 'F', 'C', mb, n, ib, lb,v( 1_${ik}$, i ), ldv, t( 1_${ik}$, i ), & + ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib ) end do else if( right .and. tran ) then kf = ((k-1)/nb)*nb+1 @@ -43245,19 +43247,19 @@ module stdlib_linalg_lapack_s ib = min( nb, k-i+1 ) mb = min( n-l+i+ib-1, n ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-n+l-i+1 end if - call stdlib_stprfb( 'R', 'T', 'F', 'C', m, mb, ib, lb,v( 1, i ), ldv, t( 1, i ), & - ldt,a( 1, i ), lda, b, ldb, work, m ) + call stdlib${ii}$_stprfb( 'R', 'T', 'F', 'C', m, mb, ib, lb,v( 1_${ik}$, i ), ldv, t( 1_${ik}$, i ), & + ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m ) end do end if return - end subroutine stdlib_stpmqrt + end subroutine stdlib${ii}$_stpmqrt - pure subroutine stdlib_stpqrt2( m, n, l, a, lda, b, ldb, t, ldt, info ) + pure subroutine stdlib${ii}$_stpqrt2( m, n, l, a, lda, b, ldb, t, ldt, info ) !! STPQRT2 computes a QR factorization of a real "triangular-pentagonal" !! matrix C, which is composed of a triangular block A and pentagonal block B, !! using the compact WY representation for Q. @@ -43265,36 +43267,36 @@ 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, ldb, ldt, n, m, l + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l ! Array Arguments real(sp), intent(inout) :: a(lda,*), b(ldb,*) real(sp), intent(out) :: t(ldt,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, p, mp, np + integer(${ik}$) :: i, j, p, mp, np real(sp) :: alpha ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( l<0 .or. l>min(m,n) ) then - info = -3 - else if( ldamin(m,n) ) then + info = -3_${ik}$ + else if( lda 0. if( anorm>zero ) then ! estimate the norm of the inverse of a. ainvnm = zero normin = 'N' if( onenrm ) then - kase1 = 1 + kase1 = 1_${ik}$ else - kase1 = 2 + kase1 = 2_${ik}$ end if - kase = 0 + 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(a). - call stdlib_slatrs( uplo, 'NO TRANSPOSE', diag, normin, n, a,lda, work, scale,& - work( 2*n+1 ), info ) + call stdlib${ii}$_slatrs( uplo, 'NO TRANSPOSE', diag, normin, n, a,lda, work, scale,& + work( 2_${ik}$*n+1 ), info ) else ! multiply by inv(a**t). - call stdlib_slatrs( uplo, 'TRANSPOSE', diag, normin, n, a, lda,work, scale, & - work( 2*n+1 ), info ) + call stdlib${ii}$_slatrs( uplo, 'TRANSPOSE', diag, normin, n, a, lda,work, scale, & + work( 2_${ik}$*n+1 ), info ) end if normin = 'Y' ! multiply by 1/scale if doing so will not cause overflow. if( scale/=one ) then - ix = stdlib_isamax( n, work, 1 ) + ix = stdlib${ii}$_isamax( n, work, 1_${ik}$ ) xnorm = abs( work( ix ) ) if( scale1 .and. nb1_${ik}$ .and. nb1 ) then + call stdlib${ii}$_slatrz( ib, n-i+1, n-m, a( i, i ), lda, tau( i ),work ) + if( i>1_${ik}$ ) then ! form the triangular factor of the block reflector ! h = h(i+ib-1) . . . h(i+1) h(i) - call stdlib_slarzt( 'BACKWARD', 'ROWWISE', n-m, ib, a( i, m1 ),lda, tau( i ), & + call stdlib${ii}$_slarzt( 'BACKWARD', 'ROWWISE', n-m, ib, a( i, m1 ),lda, tau( i ), & work, ldwork ) ! apply h to a(1:i-1,i:n) from the right - call stdlib_slarzb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', i-1, n-i+1,& - ib, n-m, a( i, m1 ),lda, work, ldwork, a( 1, i ), lda,work( ib+1 ), ldwork ) + call stdlib${ii}$_slarzb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', i-1, n-i+1,& + ib, n-m, a( i, m1 ),lda, work, ldwork, a( 1_${ik}$, i ), lda,work( ib+1 ), ldwork ) end if end do - mu = i + nb - 1 + mu = i + nb - 1_${ik}$ else mu = m end if ! use unblocked code to factor the last or only block - if( mu>0 )call stdlib_slatrz( mu, n, n-m, a, lda, tau, work ) - work( 1 ) = lwkopt + if( mu>0_${ik}$ )call stdlib${ii}$_slatrz( mu, n, n-m, a, lda, tau, work ) + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_stzrzf + end subroutine stdlib${ii}$_stzrzf - pure subroutine stdlib_sgbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) + pure subroutine stdlib${ii}$_sgbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) !! SGBSV computes the solution to a real system of linear equations !! A * X = B, where A is a band matrix of order N with KL subdiagonals !! and KU superdiagonals, and X and B are N-by-NRHS matrices. @@ -43578,46 +43580,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(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(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) real(sp), intent(inout) :: ab(ldab,*), b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 - if( n<0 ) then - info = -1 - else if( kl<0 ) then - info = -2 - else if( ku<0 ) then - info = -3 - else if( nrhs<0 ) then - info = -4 - else if( ldab<2*kl+ku+1 ) then - info = -6 - else if( ldb0 ) then + info = -13_${ik}$ + else if( n>0_${ik}$ ) then rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) else rowcnd = one end if end if - if( colequ .and. info==0 ) then + if( colequ .and. info==0_${ik}$ ) then rcmin = bignum rcmax = zero do j = 1, n @@ -43711,32 +43713,32 @@ module stdlib_linalg_lapack_s rcmax = max( rcmax, c( j ) ) end do if( rcmin<=zero ) then - info = -14 - else if( n>0 ) then + info = -14_${ik}$ + else if( n>0_${ik}$ ) then colcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) else colcnd = one end if end if - if( info==0 ) then - if( ldb0 ) then + if( info>0_${ik}$ ) then ! compute the reciprocal pivot growth factor of the ! leading rank-deficient info columns of a. anorm = zero @@ -43777,14 +43779,14 @@ module stdlib_linalg_lapack_s anorm = max( anorm, abs( ab( i, j ) ) ) end do end do - rpvgrw = stdlib_slantb( 'M', 'U', 'N', info, min( info-1, kl+ku ),afb( max( 1, & - kl+ku+2-info ), 1 ), ldafb,work ) + rpvgrw = stdlib${ii}$_slantb( 'M', 'U', 'N', info, min( info-1, kl+ku ),afb( max( 1_${ik}$, & + kl+ku+2-info ), 1_${ik}$ ), ldafb,work ) if( rpvgrw==zero ) then rpvgrw = one else rpvgrw = anorm / rpvgrw end if - work( 1 ) = rpvgrw + work( 1_${ik}$ ) = rpvgrw rcond = zero return end if @@ -43796,22 +43798,22 @@ module stdlib_linalg_lapack_s else norm = 'I' end if - anorm = stdlib_slangb( norm, n, kl, ku, ab, ldab, work ) - rpvgrw = stdlib_slantb( 'M', 'U', 'N', n, kl+ku, afb, ldafb, work ) + anorm = stdlib${ii}$_slangb( norm, n, kl, ku, ab, ldab, work ) + rpvgrw = stdlib${ii}$_slantb( 'M', 'U', 'N', n, kl+ku, afb, ldafb, work ) if( rpvgrw==zero ) then rpvgrw = one else - rpvgrw = stdlib_slangb( 'M', n, kl, ku, ab, ldab, work ) / rpvgrw + rpvgrw = stdlib${ii}$_slangb( 'M', n, kl, ku, ab, ldab, work ) / rpvgrw end if ! compute the reciprocal of the condition number of a. - call stdlib_sgbcon( norm, n, kl, ku, afb, ldafb, ipiv, anorm, rcond,work, iwork, info ) + call stdlib${ii}$_sgbcon( norm, n, kl, ku, afb, ldafb, ipiv, anorm, rcond,work, iwork, info ) ! compute the solution matrix x. - call stdlib_slacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_sgbtrs( trans, n, kl, ku, nrhs, afb, ldafb, ipiv, x, ldx,info ) + call stdlib${ii}$_slacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_sgbtrs( trans, n, kl, ku, nrhs, afb, ldafb, ipiv, x, ldx,info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_sgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv,b, ldb, x, ldx, & + call stdlib${ii}$_sgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv,b, ldb, x, ldx, & ferr, berr, work, iwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -43837,13 +43839,13 @@ module stdlib_linalg_lapack_s end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond=sfmax2 .or.min( f, c, g, ca )<=sfmin2 )go to 190 - if( stdlib_sisnan( c+f+ca+r+g+ra ) ) then + if( stdlib${ii}$_sisnan( c+f+ca+r+g+ra ) ) then ! exit if nan to avoid infinite loop - info = -3 - call stdlib_xerbla( 'SGEBAL', -info ) + info = -3_${ik}$ + call stdlib${ii}$_xerbla( 'SGEBAL', -info ) return end if f = f / sclfac @@ -44000,18 +44002,18 @@ module stdlib_linalg_lapack_s g = one / f scale( i ) = scale( i )*f noconv = .true. - call stdlib_sscal( n-k+1, g, a( i, k ), lda ) - call stdlib_sscal( l, f, a( 1, i ), 1 ) + call stdlib${ii}$_sscal( n-k+1, g, a( i, k ), lda ) + call stdlib${ii}$_sscal( l, f, a( 1_${ik}$, i ), 1_${ik}$ ) end do loop_200 if( noconv )go to 140 210 continue ilo = k ihi = l return - end subroutine stdlib_sgebal + end subroutine stdlib${ii}$_sgebal - pure subroutine stdlib_sgebd2( m, n, a, lda, d, e, tauq, taup, work, info ) + pure subroutine stdlib${ii}$_sgebd2( m, n, a, lda, d, e, tauq, taup, work, info ) !! SGEBD2 reduces a real general m by n matrix A to upper or lower !! bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. !! If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. @@ -44019,52 +44021,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, 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(*), e(*), taup(*), tauq(*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i ! 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=n ) then ! reduce to upper bidiagonal form do i = 1, n ! generate elementary reflector h(i) to annihilate a(i+1:m,i) - call stdlib_slarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,tauq( i ) ) + call stdlib${ii}$_slarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,tauq( i ) ) d( i ) = a( i, i ) a( i, i ) = one ! apply h(i) to a(i:m,i+1:n) from the left - if( imax( 1, n ) ) then - info = -2 + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -1_${ik}$ + else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then + info = -2_${ik}$ else if( ihin ) then - info = -3 - else if( lda1 .and. nb1_${ik}$ .and. nb1 .and. nb1_${ik}$ .and. nb1 ) 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**t to a(1:m-k+i+ib-1,1:n-k+i-1) from the left - call stdlib_slarfb( 'LEFT', 'TRANSPOSE', 'BACKWARD','COLUMNWISE', m-k+i+ib-1, & - n-k+i-1, ib,a( 1, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork ) + call stdlib${ii}$_slarfb( 'LEFT', 'TRANSPOSE', 'BACKWARD','COLUMNWISE', m-k+i+ib-1, & + n-k+i-1, ib,a( 1_${ik}$, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork ) end if end do - mu = m - k + i + nb - 1 - nu = n - k + i + nb - 1 + mu = m - k + i + nb - 1_${ik}$ + nu = n - k + i + nb - 1_${ik}$ else mu = m nu = n end if ! use unblocked code to factor the last or only block - if( mu>0 .and. nu>0 )call stdlib_sgeql2( mu, nu, a, lda, tau, work, iinfo ) - work( 1 ) = iws + if( mu>0_${ik}$ .and. nu>0_${ik}$ )call stdlib${ii}$_sgeql2( mu, nu, a, lda, tau, work, iinfo ) + work( 1_${ik}$ ) = iws return - end subroutine stdlib_sgeqlf + end subroutine stdlib${ii}$_sgeqlf - pure subroutine stdlib_sgeqr2( m, n, a, lda, tau, work, info ) + pure subroutine stdlib${ii}$_sgeqr2( m, n, a, lda, tau, work, info ) !! SGEQR2 computes a QR factorization of a real m-by-n matrix A: !! A = Q * ( R ), !! ( 0 ) @@ -44560,50 +44562,50 @@ 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, 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) :: tau(*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, k + integer(${ik}$) :: i, k real(sp) :: aii ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda0 .and. lwork0_${ik}$ .and. lwork1 .and. nb1_${ik}$ .and. nb1 .and. nb1_${ik}$ .and. nb t(i,1) - call stdlib_slarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,t( i, 1 ) ) + call stdlib${ii}$_slarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,t( i, 1_${ik}$ ) ) if( ieps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_sgetrs( trans, n, 1, af, ldaf, ipiv, work( n+1 ), n,info ) - call stdlib_saxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) + call stdlib${ii}$_sgetrs( trans, n, 1_${ik}$, af, ldaf, ipiv, work( n+1 ), n,info ) + call stdlib${ii}$_saxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -45174,14 +45176,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_sgetrs( transt, n, 1, af, ldaf, ipiv, work( n+1 ),n, info ) + call stdlib${ii}$_sgetrs( transt, n, 1_${ik}$, af, ldaf, ipiv, work( n+1 ),n, info ) do i = 1, n work( n+i ) = work( i )*work( n+i ) @@ -45191,7 +45193,7 @@ module stdlib_linalg_lapack_s do i = 1, n work( n+i ) = work( i )*work( n+i ) end do - call stdlib_sgetrs( trans, n, 1, af, ldaf, ipiv, work( n+1 ), n,info ) + call stdlib${ii}$_sgetrs( trans, n, 1_${ik}$, af, ldaf, ipiv, work( n+1 ), n,info ) end if go to 100 end if @@ -45203,117 +45205,117 @@ module stdlib_linalg_lapack_s if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_sgerfs + end subroutine stdlib${ii}$_sgerfs - pure subroutine stdlib_sgerq2( m, n, a, lda, tau, work, info ) + pure subroutine stdlib${ii}$_sgerq2( m, n, a, lda, tau, work, info ) !! SGERQ2 computes an RQ factorization of a real m by n matrix A: !! A = R * Q. ! -- 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) :: tau(*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, k + integer(${ik}$) :: i, k real(sp) :: aii ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda0 .and. lwork0_${ik}$ .and. lwork1 .and. nb1_${ik}$ .and. nb1 ) then + if( m-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', 'ROWWISE', n-k+i+ib-1, ib,a( m-k+i, 1 ), lda, & + call stdlib${ii}$_slarft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( m-k+i, 1_${ik}$ ), lda, & tau( i ), work, ldwork ) ! apply h to a(1:m-k+i-1,1:n-k+i+ib-1) from the right - call stdlib_slarfb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', m-k+i-1, n-& - k+i+ib-1, ib,a( m-k+i, 1 ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork ) + call stdlib${ii}$_slarfb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', m-k+i-1, n-& + k+i+ib-1, ib,a( m-k+i, 1_${ik}$ ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork ) end if end do - mu = m - k + i + nb - 1 - nu = n - k + i + nb - 1 + mu = m - k + i + nb - 1_${ik}$ + nu = n - k + i + nb - 1_${ik}$ else mu = m nu = n end if ! use unblocked code to factor the last or only block - if( mu>0 .and. nu>0 )call stdlib_sgerq2( mu, nu, a, lda, tau, work, iinfo ) - work( 1 ) = iws + if( mu>0_${ik}$ .and. nu>0_${ik}$ )call stdlib${ii}$_sgerq2( mu, nu, a, lda, tau, work, iinfo ) + work( 1_${ik}$ ) = iws return - end subroutine stdlib_sgerqf + end subroutine stdlib${ii}$_sgerqf - pure subroutine stdlib_sgetrf( m, n, a, lda, ipiv, info ) + pure subroutine stdlib${ii}$_sgetrf( m, n, a, lda, ipiv, info ) !! SGETRF computes an LU factorization of a general M-by-N matrix A !! using partial pivoting with row interchanges. !! The factorization has the form @@ -45374,61 +45376,61 @@ 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, 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 - integer(ilp) :: i, iinfo, j, jb, nb + integer(${ik}$) :: i, 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}$, 'SGETRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=min( m, n ) ) then ! use unblocked code. - call stdlib_sgetrf2( m, n, a, lda, ipiv, info ) + call stdlib${ii}$_sgetrf2( m, n, a, lda, ipiv, info ) else ! use blocked code. do j = 1, min( m, n ), nb jb = min( min( m, n )-j+1, nb ) ! factor diagonal and subdiagonal blocks and test for exact ! singularity. - call stdlib_sgetrf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo ) + call stdlib${ii}$_sgetrf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo ) ! adjust info and the pivot indices. - if( info==0 .and. iinfo>0 )info = iinfo + j - 1 + if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + j - 1_${ik}$ do i = j, min( m, j+jb-1 ) - ipiv( i ) = j - 1 + ipiv( i ) + ipiv( i ) = j - 1_${ik}$ + ipiv( i ) end do ! apply interchanges to columns 1:j-1. - call stdlib_slaswp( j-1, a, lda, j, j+jb-1, ipiv, 1 ) + call stdlib${ii}$_slaswp( j-1, a, lda, j, j+jb-1, ipiv, 1_${ik}$ ) if( j+jb<=n ) then ! apply interchanges to columns j+jb:n. - call stdlib_slaswp( n-j-jb+1, a( 1, j+jb ), lda, j, j+jb-1,ipiv, 1 ) + call stdlib${ii}$_slaswp( n-j-jb+1, a( 1_${ik}$, j+jb ), lda, j, j+jb-1,ipiv, 1_${ik}$ ) ! 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 @@ -45436,10 +45438,10 @@ module stdlib_linalg_lapack_s end do end if return - end subroutine stdlib_sgetrf + end subroutine stdlib${ii}$_sgetrf - pure subroutine stdlib_sgghd3( compq, compz, n, ilo, ihi, a, lda, b, ldb, q,ldq, z, ldz, & + pure subroutine stdlib${ii}$_sgghd3( compq, compz, n, ilo, ihi, a, lda, b, ldb, q,ldq, z, ldz, & !! SGGHD3 reduces a pair of real matrices (A,B) to generalized upper !! Hessenberg form using orthogonal transformations, where A is a !! general matrix and B is upper triangular. The form of the @@ -45471,8 +45473,8 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: compq, compz - integer(ilp), intent(in) :: ihi, ilo, lda, ldb, ldq, ldz, n, lwork - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ilo, lda, ldb, ldq, ldz, n, lwork + integer(${ik}$), intent(out) :: info ! Array Arguments real(sp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) real(sp), intent(out) :: work(*) @@ -45481,76 +45483,76 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: blk22, initq, initz, lquery, wantq, wantz character :: compq2, compz2 - integer(ilp) :: cola, i, ierr, j, j0, jcol, jj, jrow, k, kacc22, len, lwkopt, n2nb, nb,& + integer(${ik}$) :: cola, i, ierr, j, j0, jcol, jj, jrow, k, kacc22, len, lwkopt, n2nb, nb,& nblst, nbmin, nh, nnb, nx, ppw, ppwo, pw, top, topq real(sp) :: c, c1, c2, s, s1, s2, temp, temp1, temp2, temp3 ! Intrinsic Functions intrinsic :: real,max ! Executable Statements ! decode and test the input parameters. - info = 0 - nb = stdlib_ilaenv( 1, 'SGGHD3', ' ', n, ilo, ihi, -1 ) - lwkopt = max( 6*n*nb, 1 ) - work( 1 ) = real( lwkopt,KIND=sp) + info = 0_${ik}$ + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SGGHD3', ' ', n, ilo, ihi, -1_${ik}$ ) + lwkopt = max( 6_${ik}$*n*nb, 1_${ik}$ ) + work( 1_${ik}$ ) = real( lwkopt,KIND=sp) initq = stdlib_lsame( compq, 'I' ) wantq = initq .or. stdlib_lsame( compq, 'V' ) initz = stdlib_lsame( compz, 'I' ) wantz = initz .or. stdlib_lsame( compz, 'V' ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) if( .not.stdlib_lsame( compq, 'N' ) .and. .not.wantq ) then - info = -1 + info = -1_${ik}$ else if( .not.stdlib_lsame( compz, 'N' ) .and. .not.wantz ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ilo<1 ) then - info = -4 + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( ilo<1_${ik}$ ) then + info = -4_${ik}$ else if( ihi>n .or. ihi1 )call stdlib_slaset( 'LOWER', n-1, n-1, zero, zero, b(2, 1), ldb ) + if( n>1_${ik}$ )call stdlib${ii}$_slaset( 'LOWER', n-1, n-1, zero, zero, b(2_${ik}$, 1_${ik}$), ldb ) ! quick return if possible - nh = ihi - ilo + 1 - if( nh<=1 ) then - work( 1 ) = one + nh = ihi - ilo + 1_${ik}$ + if( nh<=1_${ik}$ ) then + work( 1_${ik}$ ) = one return end if ! determine the blocksize. - nbmin = stdlib_ilaenv( 2, 'SGGHD3', ' ', n, ilo, ihi, -1 ) - if( nb>1 .and. nb1_${ik}$ .and. nb=6*n*nbmin ) then - nb = lwork / ( 6*n ) + nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'SGGHD3', ' ', n, ilo, ihi,-1_${ik}$ ) ) + if( lwork>=6_${ik}$*n*nbmin ) then + nb = lwork / ( 6_${ik}$*n ) else - nb = 1 + nb = 1_${ik}$ end if end if end if @@ -45560,8 +45562,8 @@ module stdlib_linalg_lapack_s jcol = ilo else ! use blocked code - kacc22 = stdlib_ilaenv( 16, 'SGGHD3', ' ', n, ilo, ihi, -1 ) - blk22 = kacc22==2 + kacc22 = stdlib${ii}$_ilaenv( 16_${ik}$, 'SGGHD3', ' ', n, ilo, ihi, -1_${ik}$ ) + blk22 = kacc22==2_${ik}$ do jcol = ilo, ihi-2, nb nnb = min( nb, ihi-jcol-1 ) ! initialize small orthogonal factors that will hold the @@ -45569,13 +45571,13 @@ module stdlib_linalg_lapack_s ! n2nb denotes the number of 2*nnb-by-2*nnb factors ! nblst denotes the (possibly smaller) order of the last ! factor. - n2nb = ( ihi-jcol-1 ) / nnb - 1 + n2nb = ( ihi-jcol-1 ) / nnb - 1_${ik}$ nblst = ihi - jcol - n2nb*nnb - call stdlib_slaset( 'ALL', nblst, nblst, zero, one, work, nblst ) - pw = nblst * nblst + 1 + call stdlib${ii}$_slaset( 'ALL', nblst, nblst, zero, one, work, nblst ) + pw = nblst * nblst + 1_${ik}$ do i = 1, n2nb - call stdlib_slaset( 'ALL', 2*nnb, 2*nnb, zero, one,work( pw ), 2*nnb ) - pw = pw + 4*nnb*nnb + call stdlib${ii}$_slaset( 'ALL', 2_${ik}$*nnb, 2_${ik}$*nnb, zero, one,work( pw ), 2_${ik}$*nnb ) + pw = pw + 4_${ik}$*nnb*nnb end do ! reduce columns jcol:jcol+nnb-1 of a to hessenberg form. do j = jcol, jcol+nnb-1 @@ -45583,14 +45585,14 @@ module stdlib_linalg_lapack_s ! column of a and b, respectively. do i = ihi, j+2, -1 temp = a( i-1, j ) - call stdlib_slartg( temp, a( i, j ), c, s, a( i-1, j ) ) + call stdlib${ii}$_slartg( temp, a( i, j ), c, s, a( i-1, j ) ) a( i, j ) = c b( i, j ) = s end do ! accumulate givens rotations into workspace array. - ppw = ( nblst + 1 )*( nblst - 2 ) - j + jcol + 1 - len = 2 + j - jcol - jrow = j + n2nb*nnb + 2 + ppw = ( nblst + 1_${ik}$ )*( nblst - 2_${ik}$ ) - j + jcol + 1_${ik}$ + len = 2_${ik}$ + j - jcol + jrow = j + n2nb*nnb + 2_${ik}$ do i = ihi, jrow, -1 c = a( i, j ) s = b( i, j ) @@ -45599,31 +45601,31 @@ module stdlib_linalg_lapack_s work( jj + nblst ) = c*temp - s*work( jj ) work( jj ) = s*temp + c*work( jj ) end do - len = len + 1 - ppw = ppw - nblst - 1 + len = len + 1_${ik}$ + ppw = ppw - nblst - 1_${ik}$ end do - ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2*nnb + nnb + ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2_${ik}$*nnb + nnb j0 = jrow - nnb do jrow = j0, j+2, -nnb ppw = ppwo - len = 2 + j - jcol + len = 2_${ik}$ + j - jcol do i = jrow+nnb-1, jrow, -1 c = a( i, j ) s = b( i, j ) do jj = ppw, ppw+len-1 - temp = work( jj + 2*nnb ) - work( jj + 2*nnb ) = c*temp - s*work( jj ) + temp = work( jj + 2_${ik}$*nnb ) + work( jj + 2_${ik}$*nnb ) = c*temp - s*work( jj ) work( jj ) = s*temp + c*work( jj ) end do - len = len + 1 - ppw = ppw - 2*nnb - 1 + len = len + 1_${ik}$ + ppw = ppw - 2_${ik}$*nnb - 1_${ik}$ end do - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do ! top denotes the number of top rows in a and b that will ! not be updated during the next steps. - if( jcol<=2 ) then - top = 0 + if( jcol<=2_${ik}$ ) then + top = 0_${ik}$ else top = jcol end if @@ -45641,9 +45643,9 @@ module stdlib_linalg_lapack_s ! annihilate b( jj+1, jj ). if( jj0 ) then + if( jj>0_${ik}$ ) then do i = jj, 1, -1 - call stdlib_srot( ihi-top, a( top+1, j+i+1 ), 1,a( top+1, j+i ), 1, a( & + call stdlib${ii}$_srot( ihi-top, a( top+1, j+i+1 ), 1_${ik}$,a( top+1, j+i ), 1_${ik}$, a( & j+1+i, j ),-b( j+1+i, j ) ) end do end if ! update (j+1)th column of a by transformations from left. - if ( j < jcol + nnb - 1 ) then - len = 1 + j - jcol + if ( j < jcol + nnb - 1_${ik}$ ) then + len = 1_${ik}$ + j - jcol ! multiply with the trailing accumulated orthogonal ! matrix, which takes the form ! [ u11 u12 ] @@ -45692,23 +45694,23 @@ module stdlib_linalg_lapack_s ! [ u21 u22 ] ! where u21 is a len-by-len matrix and u12 is lower ! triangular. - jrow = ihi - nblst + 1 - call stdlib_sgemv( 'TRANSPOSE', nblst, len, one, work,nblst, a( jrow, j+1 )& - , 1, zero,work( pw ), 1 ) + jrow = ihi - nblst + 1_${ik}$ + call stdlib${ii}$_sgemv( 'TRANSPOSE', nblst, len, one, work,nblst, a( jrow, j+1 )& + , 1_${ik}$, zero,work( pw ), 1_${ik}$ ) ppw = pw + len do i = jrow, jrow+nblst-len-1 work( ppw ) = a( i, j+1 ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do - call stdlib_strmv( 'LOWER', 'TRANSPOSE', 'NON-UNIT',nblst-len, work( & - len*nblst + 1 ), nblst,work( pw+len ), 1 ) - call stdlib_sgemv( 'TRANSPOSE', len, nblst-len, one,work( (len+1)*nblst - & - len + 1 ), nblst,a( jrow+nblst-len, j+1 ), 1, one,work( pw+len ), 1 ) + call stdlib${ii}$_strmv( 'LOWER', 'TRANSPOSE', 'NON-UNIT',nblst-len, work( & + len*nblst + 1_${ik}$ ), nblst,work( pw+len ), 1_${ik}$ ) + call stdlib${ii}$_sgemv( 'TRANSPOSE', len, nblst-len, one,work( (len+1)*nblst - & + len + 1_${ik}$ ), nblst,a( jrow+nblst-len, j+1 ), 1_${ik}$, one,work( pw+len ), 1_${ik}$ ) ppw = pw do i = jrow, jrow+nblst-1 a( i, j+1 ) = work( ppw ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do ! multiply with the other accumulated orthogonal ! matrices, which take the form @@ -45720,44 +45722,44 @@ module stdlib_linalg_lapack_s ! where i denotes the (nnb-len)-by-(nnb-len) identity ! matrix, u21 is a len-by-len upper triangular matrix ! and u12 is an nnb-by-nnb lower triangular matrix. - ppwo = 1 + nblst*nblst + ppwo = 1_${ik}$ + nblst*nblst j0 = jrow - nnb do jrow = j0, jcol+1, -nnb ppw = pw + len do i = jrow, jrow+nnb-1 work( ppw ) = a( i, j+1 ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do ppw = pw do i = jrow+nnb, jrow+nnb+len-1 work( ppw ) = a( i, j+1 ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do - call stdlib_strmv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', len,work( ppwo + & - nnb ), 2*nnb, work( pw ),1 ) - call stdlib_strmv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', nnb,work( ppwo + & - 2*len*nnb ),2*nnb, work( pw + len ), 1 ) - call stdlib_sgemv( 'TRANSPOSE', nnb, len, one,work( ppwo ), 2*nnb, a( & - jrow, j+1 ), 1,one, work( pw ), 1 ) - call stdlib_sgemv( 'TRANSPOSE', len, nnb, one,work( ppwo + 2*len*nnb + & - nnb ), 2*nnb,a( jrow+nnb, j+1 ), 1, one,work( pw+len ), 1 ) + call stdlib${ii}$_strmv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', len,work( ppwo + & + nnb ), 2_${ik}$*nnb, work( pw ),1_${ik}$ ) + call stdlib${ii}$_strmv( 'LOWER', 'TRANSPOSE', 'NON-UNIT', nnb,work( ppwo + & + 2_${ik}$*len*nnb ),2_${ik}$*nnb, work( pw + len ), 1_${ik}$ ) + call stdlib${ii}$_sgemv( 'TRANSPOSE', nnb, len, one,work( ppwo ), 2_${ik}$*nnb, a( & + jrow, j+1 ), 1_${ik}$,one, work( pw ), 1_${ik}$ ) + call stdlib${ii}$_sgemv( 'TRANSPOSE', len, nnb, one,work( ppwo + 2_${ik}$*len*nnb + & + nnb ), 2_${ik}$*nnb,a( jrow+nnb, j+1 ), 1_${ik}$, one,work( pw+len ), 1_${ik}$ ) ppw = pw do i = jrow, jrow+len+nnb-1 a( i, j+1 ) = work( ppw ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end if end do ! apply accumulated orthogonal matrices to a. - cola = n - jcol - nnb + 1 - j = ihi - nblst + 1 - call stdlib_sgemm( 'TRANSPOSE', 'NO TRANSPOSE', nblst,cola, nblst, one, work, & + cola = n - jcol - nnb + 1_${ik}$ + j = ihi - nblst + 1_${ik}$ + call stdlib${ii}$_sgemm( 'TRANSPOSE', 'NO TRANSPOSE', nblst,cola, nblst, one, work, & nblst,a( j, jcol+nnb ), lda, zero, work( pw ),nblst ) - call stdlib_slacpy( 'ALL', nblst, cola, work( pw ), nblst,a( j, jcol+nnb ), lda ) + call stdlib${ii}$_slacpy( 'ALL', nblst, cola, work( pw ), nblst,a( j, jcol+nnb ), lda ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( blk22 ) then @@ -45767,68 +45769,68 @@ module stdlib_linalg_lapack_s ! [ u21 u22 ], ! where all blocks are nnb-by-nnb, u21 is upper ! triangular and u12 is lower triangular. - call stdlib_sorm22( 'LEFT', 'TRANSPOSE', 2*nnb, cola, nnb,nnb, work( ppwo )& - , 2*nnb,a( j, jcol+nnb ), lda, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_sorm22( 'LEFT', 'TRANSPOSE', 2_${ik}$*nnb, cola, nnb,nnb, work( ppwo )& + , 2_${ik}$*nnb,a( j, jcol+nnb ), lda, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_sgemm( 'TRANSPOSE', 'NO TRANSPOSE', 2*nnb,cola, 2*nnb, one, & - work( ppwo ), 2*nnb,a( j, jcol+nnb ), lda, zero, work( pw ),2*nnb ) - call stdlib_slacpy( 'ALL', 2*nnb, cola, work( pw ), 2*nnb,a( j, jcol+nnb ),& + call stdlib${ii}$_sgemm( 'TRANSPOSE', 'NO TRANSPOSE', 2_${ik}$*nnb,cola, 2_${ik}$*nnb, one, & + work( ppwo ), 2_${ik}$*nnb,a( j, jcol+nnb ), lda, zero, work( pw ),2_${ik}$*nnb ) + call stdlib${ii}$_slacpy( 'ALL', 2_${ik}$*nnb, cola, work( pw ), 2_${ik}$*nnb,a( j, jcol+nnb ),& lda ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do ! apply accumulated orthogonal matrices to q. if( wantq ) then - j = ihi - nblst + 1 + j = ihi - nblst + 1_${ik}$ if ( initq ) then - topq = max( 2, j - jcol + 1 ) - nh = ihi - topq + 1 + topq = max( 2_${ik}$, j - jcol + 1_${ik}$ ) + nh = ihi - topq + 1_${ik}$ else - topq = 1 + topq = 1_${ik}$ nh = n end if - call stdlib_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, one, q( & + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, one, q( & topq, j ), ldq,work, nblst, zero, work( pw ), nh ) - call stdlib_slacpy( 'ALL', nh, nblst, work( pw ), nh,q( topq, j ), ldq ) + call stdlib${ii}$_slacpy( 'ALL', nh, nblst, work( pw ), nh,q( topq, j ), ldq ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( initq ) then - topq = max( 2, j - jcol + 1 ) - nh = ihi - topq + 1 + topq = max( 2_${ik}$, j - jcol + 1_${ik}$ ) + nh = ihi - topq + 1_${ik}$ end if if ( blk22 ) then ! exploit the structure of u. - call stdlib_sorm22( 'RIGHT', 'NO TRANSPOSE', nh, 2*nnb,nnb, nnb, work( & - ppwo ), 2*nnb,q( topq, j ), ldq, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_sorm22( 'RIGHT', 'NO TRANSPOSE', nh, 2_${ik}$*nnb,nnb, nnb, work( & + ppwo ), 2_${ik}$*nnb,q( topq, j ), ldq, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2*nnb, 2*nnb, one,& - q( topq, j ), ldq,work( ppwo ), 2*nnb, zero, work( pw ),nh ) - call stdlib_slacpy( 'ALL', nh, 2*nnb, work( pw ), nh,q( topq, j ), ldq ) + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2_${ik}$*nnb, 2_${ik}$*nnb, one,& + q( topq, j ), ldq,work( ppwo ), 2_${ik}$*nnb, zero, work( pw ),nh ) + call stdlib${ii}$_slacpy( 'ALL', nh, 2_${ik}$*nnb, work( pw ), nh,q( topq, j ), ldq ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end if ! accumulate right givens rotations if required. - if ( wantz .or. top>0 ) then + if ( wantz .or. top>0_${ik}$ ) then ! initialize small orthogonal factors that will hold the ! accumulated givens rotations in workspace. - call stdlib_slaset( 'ALL', nblst, nblst, zero, one, work,nblst ) - pw = nblst * nblst + 1 + call stdlib${ii}$_slaset( 'ALL', nblst, nblst, zero, one, work,nblst ) + pw = nblst * nblst + 1_${ik}$ do i = 1, n2nb - call stdlib_slaset( 'ALL', 2*nnb, 2*nnb, zero, one,work( pw ), 2*nnb ) + call stdlib${ii}$_slaset( 'ALL', 2_${ik}$*nnb, 2_${ik}$*nnb, zero, one,work( pw ), 2_${ik}$*nnb ) - pw = pw + 4*nnb*nnb + pw = pw + 4_${ik}$*nnb*nnb end do ! accumulate givens rotations into workspace array. do j = jcol, jcol+nnb-1 - ppw = ( nblst + 1 )*( nblst - 2 ) - j + jcol + 1 - len = 2 + j - jcol - jrow = j + n2nb*nnb + 2 + ppw = ( nblst + 1_${ik}$ )*( nblst - 2_${ik}$ ) - j + jcol + 1_${ik}$ + len = 2_${ik}$ + j - jcol + jrow = j + n2nb*nnb + 2_${ik}$ do i = ihi, jrow, -1 c = a( i, j ) a( i, j ) = zero @@ -45839,114 +45841,114 @@ module stdlib_linalg_lapack_s work( jj + nblst ) = c*temp - s*work( jj ) work( jj ) = s*temp + c*work( jj ) end do - len = len + 1 - ppw = ppw - nblst - 1 + len = len + 1_${ik}$ + ppw = ppw - nblst - 1_${ik}$ end do - ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2*nnb + nnb + ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2_${ik}$*nnb + nnb j0 = jrow - nnb do jrow = j0, j+2, -nnb ppw = ppwo - len = 2 + j - jcol + len = 2_${ik}$ + j - jcol do i = jrow+nnb-1, jrow, -1 c = a( i, j ) a( i, j ) = zero s = b( i, j ) b( i, j ) = zero do jj = ppw, ppw+len-1 - temp = work( jj + 2*nnb ) - work( jj + 2*nnb ) = c*temp - s*work( jj ) + temp = work( jj + 2_${ik}$*nnb ) + work( jj + 2_${ik}$*nnb ) = c*temp - s*work( jj ) work( jj ) = s*temp + c*work( jj ) end do - len = len + 1 - ppw = ppw - 2*nnb - 1 + len = len + 1_${ik}$ + ppw = ppw - 2_${ik}$*nnb - 1_${ik}$ end do - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end do else - call stdlib_slaset( 'LOWER', ihi - jcol - 1, nnb, zero, zero,a( jcol + 2, & + call stdlib${ii}$_slaset( 'LOWER', ihi - jcol - 1_${ik}$, nnb, zero, zero,a( jcol + 2_${ik}$, & jcol ), lda ) - call stdlib_slaset( 'LOWER', ihi - jcol - 1, nnb, zero, zero,b( jcol + 2, & + call stdlib${ii}$_slaset( 'LOWER', ihi - jcol - 1_${ik}$, nnb, zero, zero,b( jcol + 2_${ik}$, & jcol ), ldb ) end if ! apply accumulated orthogonal matrices to a and b. - if ( top>0 ) then - j = ihi - nblst + 1 - call stdlib_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, one, a( & - 1, j ), lda,work, nblst, zero, work( pw ), top ) - call stdlib_slacpy( 'ALL', top, nblst, work( pw ), top,a( 1, j ), lda ) + if ( top>0_${ik}$ ) then + j = ihi - nblst + 1_${ik}$ + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, one, a( & + 1_${ik}$, j ), lda,work, nblst, zero, work( pw ), top ) + call stdlib${ii}$_slacpy( 'ALL', top, nblst, work( pw ), top,a( 1_${ik}$, j ), lda ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( blk22 ) then ! exploit the structure of u. - call stdlib_sorm22( 'RIGHT', 'NO TRANSPOSE', top, 2*nnb,nnb, nnb, work( & - ppwo ), 2*nnb,a( 1, j ), lda, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_sorm22( 'RIGHT', 'NO TRANSPOSE', top, 2_${ik}$*nnb,nnb, nnb, work( & + ppwo ), 2_${ik}$*nnb,a( 1_${ik}$, j ), lda, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2*nnb, 2*nnb, & - one, a( 1, j ), lda,work( ppwo ), 2*nnb, zero,work( pw ), top ) - call stdlib_slacpy( 'ALL', top, 2*nnb, work( pw ), top,a( 1, j ), lda ) + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2_${ik}$*nnb, 2_${ik}$*nnb, & + one, a( 1_${ik}$, j ), lda,work( ppwo ), 2_${ik}$*nnb, zero,work( pw ), top ) + call stdlib${ii}$_slacpy( 'ALL', top, 2_${ik}$*nnb, work( pw ), top,a( 1_${ik}$, j ), lda ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do - j = ihi - nblst + 1 - call stdlib_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, one, b( & - 1, j ), ldb,work, nblst, zero, work( pw ), top ) - call stdlib_slacpy( 'ALL', top, nblst, work( pw ), top,b( 1, j ), ldb ) + j = ihi - nblst + 1_${ik}$ + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, one, b( & + 1_${ik}$, j ), ldb,work, nblst, zero, work( pw ), top ) + call stdlib${ii}$_slacpy( 'ALL', top, nblst, work( pw ), top,b( 1_${ik}$, j ), ldb ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( blk22 ) then ! exploit the structure of u. - call stdlib_sorm22( 'RIGHT', 'NO TRANSPOSE', top, 2*nnb,nnb, nnb, work( & - ppwo ), 2*nnb,b( 1, j ), ldb, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_sorm22( 'RIGHT', 'NO TRANSPOSE', top, 2_${ik}$*nnb,nnb, nnb, work( & + ppwo ), 2_${ik}$*nnb,b( 1_${ik}$, j ), ldb, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2*nnb, 2*nnb, & - one, b( 1, j ), ldb,work( ppwo ), 2*nnb, zero,work( pw ), top ) - call stdlib_slacpy( 'ALL', top, 2*nnb, work( pw ), top,b( 1, j ), ldb ) + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2_${ik}$*nnb, 2_${ik}$*nnb, & + one, b( 1_${ik}$, j ), ldb,work( ppwo ), 2_${ik}$*nnb, zero,work( pw ), top ) + call stdlib${ii}$_slacpy( 'ALL', top, 2_${ik}$*nnb, work( pw ), top,b( 1_${ik}$, j ), ldb ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end if ! apply accumulated orthogonal matrices to z. if( wantz ) then - j = ihi - nblst + 1 + j = ihi - nblst + 1_${ik}$ if ( initq ) then - topq = max( 2, j - jcol + 1 ) - nh = ihi - topq + 1 + topq = max( 2_${ik}$, j - jcol + 1_${ik}$ ) + nh = ihi - topq + 1_${ik}$ else - topq = 1 + topq = 1_${ik}$ nh = n end if - call stdlib_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, one, z( & + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, one, z( & topq, j ), ldz,work, nblst, zero, work( pw ), nh ) - call stdlib_slacpy( 'ALL', nh, nblst, work( pw ), nh,z( topq, j ), ldz ) + call stdlib${ii}$_slacpy( 'ALL', nh, nblst, work( pw ), nh,z( topq, j ), ldz ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( initq ) then - topq = max( 2, j - jcol + 1 ) - nh = ihi - topq + 1 + topq = max( 2_${ik}$, j - jcol + 1_${ik}$ ) + nh = ihi - topq + 1_${ik}$ end if if ( blk22 ) then ! exploit the structure of u. - call stdlib_sorm22( 'RIGHT', 'NO TRANSPOSE', nh, 2*nnb,nnb, nnb, work( & - ppwo ), 2*nnb,z( topq, j ), ldz, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_sorm22( 'RIGHT', 'NO TRANSPOSE', nh, 2_${ik}$*nnb,nnb, nnb, work( & + ppwo ), 2_${ik}$*nnb,z( topq, j ), ldz, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2*nnb, 2*nnb, one,& - z( topq, j ), ldz,work( ppwo ), 2*nnb, zero, work( pw ),nh ) - call stdlib_slacpy( 'ALL', nh, 2*nnb, work( pw ), nh,z( topq, j ), ldz ) + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2_${ik}$*nnb, 2_${ik}$*nnb, one,& + z( topq, j ), ldz,work( ppwo ), 2_${ik}$*nnb, zero, work( pw ),nh ) + call stdlib${ii}$_slacpy( 'ALL', nh, 2_${ik}$*nnb, work( pw ), nh,z( topq, j ), ldz ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end if end do @@ -45959,14 +45961,14 @@ module stdlib_linalg_lapack_s if ( wantq )compq2 = 'V' if ( wantz )compz2 = 'V' end if - if ( jcoleps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_sgttrs( trans, n, 1, dlf, df, duf, du2, ipiv,work( n+1 ), n, info ) + call stdlib${ii}$_sgttrs( trans, n, 1_${ik}$, dlf, df, duf, du2, 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 @@ -46374,14 +46376,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}$ 70 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_sgttrs( transt, n, 1, dlf, df, duf, du2, ipiv,work( n+1 ), n, & + call stdlib${ii}$_sgttrs( transt, n, 1_${ik}$, dlf, df, duf, du2, ipiv,work( n+1 ), n, & info ) do i = 1, n work( n+i ) = work( i )*work( n+i ) @@ -46391,7 +46393,7 @@ module stdlib_linalg_lapack_s do i = 1, n work( n+i ) = work( i )*work( n+i ) end do - call stdlib_sgttrs( transn, n, 1, dlf, df, duf, du2, ipiv,work( n+1 ), n, & + call stdlib${ii}$_sgttrs( transn, n, 1_${ik}$, dlf, df, duf, du2, ipiv,work( n+1 ), n, & info ) end if go to 70 @@ -46404,10 +46406,10 @@ module stdlib_linalg_lapack_s if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_110 return - end subroutine stdlib_sgtrfs + end subroutine stdlib${ii}$_sgtrfs - pure subroutine stdlib_sgtsvx( fact, trans, n, nrhs, dl, d, du, dlf, df, duf,du2, ipiv, b, & + pure subroutine stdlib${ii}$_sgtsvx( fact, trans, n, nrhs, dl, d, du, dlf, df, duf,du2, ipiv, b, & !! SGTSVX uses the LU factorization to compute the solution to a real !! system of linear equations A * X = B or A**T * X = B, !! where A is a tridiagonal matrix of order N and X and B are N-by-NRHS @@ -46420,12 +46422,12 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: fact, trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs real(sp), intent(out) :: rcond ! Array Arguments - integer(ilp), intent(inout) :: ipiv(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(inout) :: ipiv(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(in) :: b(ldb,*), d(*), dl(*), du(*) real(sp), intent(out) :: berr(*), ferr(*), work(*), x(ldx,*) real(sp), intent(inout) :: df(*), dlf(*), du2(*), duf(*) @@ -46438,37 +46440,37 @@ module stdlib_linalg_lapack_s ! Intrinsic Functions intrinsic :: max ! Executable Statements - info = 0 + info = 0_${ik}$ nofact = stdlib_lsame( fact, 'N' ) notran = stdlib_lsame( trans, 'N' ) if( .not.nofact .and. .not.stdlib_lsame( fact, 'F' ) ) 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 - else if( n<0 ) then - info = -3 - else if( nrhs<0 ) then - info = -4 - else if( ldb1 ) then - call stdlib_scopy( n-1, dl, 1, dlf, 1 ) - call stdlib_scopy( n-1, du, 1, duf, 1 ) + call stdlib${ii}$_scopy( n, d, 1_${ik}$, df, 1_${ik}$ ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_scopy( n-1, dl, 1_${ik}$, dlf, 1_${ik}$ ) + call stdlib${ii}$_scopy( n-1, du, 1_${ik}$, duf, 1_${ik}$ ) end if - call stdlib_sgttrf( n, dlf, df, duf, du2, ipiv, info ) + call stdlib${ii}$_sgttrf( n, dlf, df, duf, du2, ipiv, info ) ! return if info is non-zero. - if( info>0 )then + if( info>0_${ik}$ )then rcond = zero return end if @@ -46479,24 +46481,24 @@ module stdlib_linalg_lapack_s else norm = 'I' end if - anorm = stdlib_slangt( norm, n, dl, d, du ) + anorm = stdlib${ii}$_slangt( norm, n, dl, d, du ) ! compute the reciprocal of the condition number of a. - call stdlib_sgtcon( norm, n, dlf, df, duf, du2, ipiv, anorm, rcond, work,iwork, info ) + call stdlib${ii}$_sgtcon( norm, n, dlf, df, duf, du2, ipiv, anorm, rcond, work,iwork, info ) ! compute the solution vectors x. - call stdlib_slacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_sgttrs( trans, n, nrhs, dlf, df, duf, du2, ipiv, x, ldx,info ) + call stdlib${ii}$_slacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_sgttrs( trans, n, nrhs, dlf, df, duf, du2, ipiv, x, ldx,info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_sgtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv,b, ldb, x, ldx, & + call stdlib${ii}$_sgtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv,b, ldb, x, ldx, & ferr, berr, work, iwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcondn .or. ihi ilo )temp = temp + abs ( t( j - 1, j ) ) + temp = abs ( t( j, j + 1_${ik}$ ) ) + if ( j > ilo )temp = temp + abs ( t( j - 1_${ik}$, j ) ) if( abs( t( j, j ) )=ilast ) then go to 80 else - ifirst = jch + 1 + ifirst = jch + 1_${ik}$ go to 110 end if end if @@ -46789,24 +46791,24 @@ module stdlib_linalg_lapack_s ! then process as in the case t(ilast,ilast)=0 do jch = j, ilast - 1 temp = t( jch, jch+1 ) - call stdlib_slartg( temp, t( jch+1, jch+1 ), c, s,t( jch, jch+1 ) ) + call stdlib${ii}$_slartg( temp, t( jch+1, jch+1 ), c, s,t( jch, jch+1 ) ) t( jch+1, jch+1 ) = zero - if( jch abs( (wr2/s2)*t( & ilast, ilast )- h( ilast, ilast ) ) ) then @@ -46935,12 +46937,12 @@ module stdlib_linalg_lapack_s ! initial q temp = s1*h( istart, istart ) - wr*t( istart, istart ) temp2 = s1*h( istart+1, istart ) - call stdlib_slartg( temp, temp2, c, s, tempr ) + call stdlib${ii}$_slartg( temp, temp2, c, s, tempr ) ! sweep loop_190: do j = istart, ilast - 1 if( j>istart ) then temp = h( j, j-1 ) - call stdlib_slartg( temp, h( j+1, j-1 ), c, s, h( j, j-1 ) ) + call stdlib${ii}$_slartg( temp, h( j+1, j-1 ), c, s, h( j, j-1 ) ) h( j+1, j-1 ) = zero end if do jc = j, ilastm @@ -46959,7 +46961,7 @@ module stdlib_linalg_lapack_s end do end if temp = t( j+1, j+1 ) - call stdlib_slartg( temp, t( j+1, j ), c, s, t( j+1, j+1 ) ) + call stdlib${ii}$_slartg( temp, t( j+1, j ), c, s, t( j+1, j+1 ) ) t( j+1, j ) = zero do jr = ifrstm, min( j+2, ilast ) temp = c*h( jr, j+1 ) + s*h( jr, j ) @@ -46992,7 +46994,7 @@ module stdlib_linalg_lapack_s ! ( b11 0 ) ! b = ( ) with b11 non-negative. ! ( 0 b22 ) - call stdlib_slasv2( t( ilast-1, ilast-1 ), t( ilast-1, ilast ),t( ilast, ilast ),& + call stdlib${ii}$_slasv2( t( ilast-1, ilast-1 ), t( ilast-1, ilast ),t( ilast, ilast ),& b22, b11, sr, cr, sl, cl ) if( b11abs( c21 )+abs( c22r )+abs( c22i ) ) & then - t1 = stdlib_slapy3( c12, c11r, c11i ) + t1 = stdlib${ii}$_slapy3( c12, c11r, c11i ) cz = c12 / t1 szr = -c11r / t1 szi = -c11i / t1 else - cz = stdlib_slapy2( c22r, c22i ) + cz = stdlib${ii}$_slapy2( c22r, c22i ) if( cz<=safmin ) then cz = zero szr = one @@ -47068,7 +47070,7 @@ module stdlib_linalg_lapack_s else tempr = c22r / cz tempi = c22i / cz - t1 = stdlib_slapy2( cz, c21 ) + t1 = stdlib${ii}$_slapy2( cz, c21 ) cz = cz / t1 szr = -c21*tempr / t1 szi = c21*tempi / t1 @@ -47090,7 +47092,7 @@ module stdlib_linalg_lapack_s a1i = szi*a12 a2r = cz*a21 + szr*a22 a2i = szi*a22 - cq = stdlib_slapy2( a1r, a1i ) + cq = stdlib${ii}$_slapy2( a1r, a1i ) if( cq<=safmin ) then cq = zero sqr = one @@ -47102,7 +47104,7 @@ module stdlib_linalg_lapack_s sqi = tempi*a2r - tempr*a2i end if end if - t1 = stdlib_slapy3( cq, sqr, sqi ) + t1 = stdlib${ii}$_slapy3( cq, sqr, sqi ) cq = cq / t1 sqr = sqr / t1 sqi = sqi / t1 @@ -47111,10 +47113,10 @@ module stdlib_linalg_lapack_s tempi = sqr*szi + sqi*szr b1r = cq*cz*b11 + tempr*b22 b1i = tempi*b22 - b1a = stdlib_slapy2( b1r, b1i ) + b1a = stdlib${ii}$_slapy2( b1r, b1i ) b2r = cq*cz*b22 + tempr*b11 b2i = -tempi*b11 - b2a = stdlib_slapy2( b2r, b2i ) + b2a = stdlib${ii}$_slapy2( b2r, b2i ) ! normalize so beta > 0, and im( alpha1 ) > 0 beta( ilast-1 ) = b1a beta( ilast ) = b2a @@ -47123,10 +47125,10 @@ module stdlib_linalg_lapack_s alphar( ilast ) = ( wr*b2a )*s1inv alphai( ilast ) = -( wi*b2a )*s1inv ! step 3: go to next block -- exit if finished. - ilast = ifirst - 1 + ilast = ifirst - 1_${ik}$ if( ilastistart ) then - v( 1 ) = h( j, j-1 ) - v( 2 ) = h( j+1, j-1 ) - v( 3 ) = h( j+2, j-1 ) - call stdlib_slarfg( 3, h( j, j-1 ), v( 2 ), 1, tau ) - v( 1 ) = one + v( 1_${ik}$ ) = h( j, j-1 ) + v( 2_${ik}$ ) = h( j+1, j-1 ) + v( 3_${ik}$ ) = h( j+2, j-1 ) + call stdlib${ii}$_slarfg( 3_${ik}$, h( j, j-1 ), v( 2_${ik}$ ), 1_${ik}$, tau ) + v( 1_${ik}$ ) = one h( j+1, j-1 ) = zero h( j+2, j-1 ) = zero end if do jc = j, ilastm - temp = tau*( h( j, jc )+v( 2 )*h( j+1, jc )+v( 3 )*h( j+2, jc ) ) + temp = tau*( h( j, jc )+v( 2_${ik}$ )*h( j+1, jc )+v( 3_${ik}$ )*h( j+2, jc ) ) h( j, jc ) = h( j, jc ) - temp - h( j+1, jc ) = h( j+1, jc ) - temp*v( 2 ) - h( j+2, jc ) = h( j+2, jc ) - temp*v( 3 ) - temp2 = tau*( t( j, jc )+v( 2 )*t( j+1, jc )+v( 3 )*t( j+2, jc ) ) + h( j+1, jc ) = h( j+1, jc ) - temp*v( 2_${ik}$ ) + h( j+2, jc ) = h( j+2, jc ) - temp*v( 3_${ik}$ ) + temp2 = tau*( t( j, jc )+v( 2_${ik}$ )*t( j+1, jc )+v( 3_${ik}$ )*t( j+2, jc ) ) t( j, jc ) = t( j, jc ) - temp2 - t( j+1, jc ) = t( j+1, jc ) - temp2*v( 2 ) - t( j+2, jc ) = t( j+2, jc ) - temp2*v( 3 ) + t( j+1, jc ) = t( j+1, jc ) - temp2*v( 2_${ik}$ ) + t( j+2, jc ) = t( j+2, jc ) - temp2*v( 3_${ik}$ ) end do if( ilq ) then do jr = 1, n - temp = tau*( q( jr, j )+v( 2 )*q( jr, j+1 )+v( 3 )*q( jr, j+2 ) ) + temp = tau*( q( jr, j )+v( 2_${ik}$ )*q( jr, j+1 )+v( 3_${ik}$ )*q( jr, j+2 ) ) q( jr, j ) = q( jr, j ) - temp - q( jr, j+1 ) = q( jr, j+1 ) - temp*v( 2 ) - q( jr, j+2 ) = q( jr, j+2 ) - temp*v( 3 ) + q( jr, j+1 ) = q( jr, j+1 ) - temp*v( 2_${ik}$ ) + q( jr, j+2 ) = q( jr, j+2 ) - temp*v( 3_${ik}$ ) end do end if ! zero j-th column of b (see slagbc for details) ! swap rows to pivot - ilpivt = .false. + ${ik}$ivt = .false. temp = max( abs( t( j+1, j+1 ) ), abs( t( j+1, j+2 ) ) ) temp2 = max( abs( t( j+2, j+1 ) ), abs( t( j+2, j+2 ) ) ) if( max( temp, temp2 )abs( w11 ) ) then - ilpivt = .true. + ${ik}$ivt = .true. temp = w12 temp2 = w22 w12 = w11 @@ -47250,38 +47252,38 @@ module stdlib_linalg_lapack_s u2 = ( scale*u2 ) / w22 u1 = ( scale*u1-w12*u2 ) / w11 250 continue - if( ilpivt ) then + if( ${ik}$ivt ) then temp = u2 u2 = u1 u1 = temp end if ! compute householder vector - t1 = sqrt( scale**2+u1**2+u2**2 ) + t1 = sqrt( scale**2_${ik}$+u1**2_${ik}$+u2**2_${ik}$ ) tau = one + scale / t1 vs = -one / ( scale+t1 ) - v( 1 ) = one - v( 2 ) = vs*u1 - v( 3 ) = vs*u2 + v( 1_${ik}$ ) = one + v( 2_${ik}$ ) = vs*u1 + v( 3_${ik}$ ) = vs*u2 ! apply transformations from the right. do jr = ifrstm, min( j+3, ilast ) - temp = tau*( h( jr, j )+v( 2 )*h( jr, j+1 )+v( 3 )*h( jr, j+2 ) ) + temp = tau*( h( jr, j )+v( 2_${ik}$ )*h( jr, j+1 )+v( 3_${ik}$ )*h( jr, j+2 ) ) h( jr, j ) = h( jr, j ) - temp - h( jr, j+1 ) = h( jr, j+1 ) - temp*v( 2 ) - h( jr, j+2 ) = h( jr, j+2 ) - temp*v( 3 ) + h( jr, j+1 ) = h( jr, j+1 ) - temp*v( 2_${ik}$ ) + h( jr, j+2 ) = h( jr, j+2 ) - temp*v( 3_${ik}$ ) end do do jr = ifrstm, j + 2 - temp = tau*( t( jr, j )+v( 2 )*t( jr, j+1 )+v( 3 )*t( jr, j+2 ) ) + temp = tau*( t( jr, j )+v( 2_${ik}$ )*t( jr, j+1 )+v( 3_${ik}$ )*t( jr, j+2 ) ) t( jr, j ) = t( jr, j ) - temp - t( jr, j+1 ) = t( jr, j+1 ) - temp*v( 2 ) - t( jr, j+2 ) = t( jr, j+2 ) - temp*v( 3 ) + t( jr, j+1 ) = t( jr, j+1 ) - temp*v( 2_${ik}$ ) + t( jr, j+2 ) = t( jr, j+2 ) - temp*v( 3_${ik}$ ) end do if( ilz ) then do jr = 1, n - temp = tau*( z( jr, j )+v( 2 )*z( jr, j+1 )+v( 3 )*z( jr, j+2 ) ) + temp = tau*( z( jr, j )+v( 2_${ik}$ )*z( jr, j+1 )+v( 3_${ik}$ )*z( jr, j+2 ) ) z( jr, j ) = z( jr, j ) - temp - z( jr, j+1 ) = z( jr, j+1 ) - temp*v( 2 ) - z( jr, j+2 ) = z( jr, j+2 ) - temp*v( 3 ) + z( jr, j+1 ) = z( jr, j+1 ) - temp*v( 2_${ik}$ ) + z( jr, j+2 ) = z( jr, j+2 ) - temp*v( 3_${ik}$ ) end do end if t( j+1, j ) = zero @@ -47289,9 +47291,9 @@ module stdlib_linalg_lapack_s end do loop_290 ! last elements: use givens rotations ! rotations from the left - j = ilast - 1 + j = ilast - 1_${ik}$ temp = h( j, j-1 ) - call stdlib_slartg( temp, h( j+1, j-1 ), c, s, h( j, j-1 ) ) + call stdlib${ii}$_slartg( temp, h( j+1, j-1 ), c, s, h( j, j-1 ) ) h( j+1, j-1 ) = zero do jc = j, ilastm temp = c*h( j, jc ) + s*h( j+1, jc ) @@ -47310,7 +47312,7 @@ module stdlib_linalg_lapack_s end if ! rotations from the right. temp = t( j+1, j+1 ) - call stdlib_slartg( temp, t( j+1, j ), c, s, t( j+1, j+1 ) ) + call stdlib${ii}$_slartg( temp, t( j+1, j ), c, s, t( j+1, j+1 ) ) t( j+1, j ) = zero do jr = ifrstm, ilast temp = c*h( jr, j+1 ) + s*h( jr, j ) @@ -47363,15 +47365,15 @@ module stdlib_linalg_lapack_s beta( j ) = t( j, j ) end do ! normal termination - info = 0 + info = 0_${ik}$ ! exit (other than argument error) -- return optimal workspace size 420 continue - work( 1 ) = real( n,KIND=sp) + work( 1_${ik}$ ) = real( n,KIND=sp) return - end subroutine stdlib_shgeqz + end subroutine stdlib${ii}$_shgeqz - pure subroutine stdlib_slabrd( m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y,ldy ) + pure subroutine stdlib${ii}$_slabrd( m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y,ldy ) !! SLABRD reduces the first NB rows and columns of a real general !! m by n matrix A to upper or lower bidiagonal form by an orthogonal !! transformation Q**T * A * P, and returns the matrices X and Y which @@ -47383,14 +47385,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) :: lda, ldx, ldy, m, n, nb + integer(${ik}$), intent(in) :: lda, ldx, ldy, m, n, nb ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: d(*), e(*), taup(*), tauq(*), x(ldx,*), y(ldy,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -47400,108 +47402,108 @@ module stdlib_linalg_lapack_s ! reduce to upper bidiagonal form loop_10: do i = 1, nb ! update a(i:m,i) - call stdlib_sgemv( 'NO TRANSPOSE', m-i+1, i-1, -one, a( i, 1 ),lda, y( i, 1 ), & - ldy, one, a( i, i ), 1 ) - call stdlib_sgemv( 'NO TRANSPOSE', m-i+1, i-1, -one, x( i, 1 ),ldx, a( 1, i ), 1,& - one, a( i, i ), 1 ) + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', m-i+1, i-1, -one, a( i, 1_${ik}$ ),lda, y( i, 1_${ik}$ ), & + ldy, one, a( i, i ), 1_${ik}$ ) + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', m-i+1, i-1, -one, x( i, 1_${ik}$ ),ldx, a( 1_${ik}$, i ), 1_${ik}$,& + one, a( i, i ), 1_${ik}$ ) ! generate reflection q(i) to annihilate a(i+1:m,i) - call stdlib_slarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,tauq( i ) ) + call stdlib${ii}$_slarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,tauq( i ) ) d( i ) = a( i, i ) if( i= half*ov ) then aa = half * aa @@ -47558,18 +47560,18 @@ module stdlib_linalg_lapack_s s = s * be end if if( abs( d )<=abs( c ) ) then - call stdlib_sladiv1(aa, bb, cc, dd, p, q) + call stdlib${ii}$_sladiv1(aa, bb, cc, dd, p, q) else - call stdlib_sladiv1(bb, aa, dd, cc, p, q) + call stdlib${ii}$_sladiv1(bb, aa, dd, cc, p, q) q = -q end if p = p * s q = q * s return - end subroutine stdlib_sladiv + end subroutine stdlib${ii}$_sladiv - pure subroutine stdlib_slaed4( n, i, d, z, delta, rho, dlam, info ) + pure subroutine stdlib${ii}$_slaed4( n, i, d, z, delta, rho, dlam, info ) !! This subroutine computes the I-th updated eigenvalue of a symmetric !! rank-one modification to a diagonal matrix whose elements are !! given in the array d, and that @@ -47584,8 +47586,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(out) :: dlam real(sp), intent(in) :: rho ! Array Arguments @@ -47593,41 +47595,41 @@ module stdlib_linalg_lapack_s real(sp), intent(out) :: delta(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: maxit = 30 + integer(${ik}$), parameter :: maxit = 30_${ik}$ ! Local Scalars logical(lk) :: orgati, swtch, swtch3 - integer(ilp) :: ii, iim1, iip1, ip1, iter, j, niter + integer(${ik}$) :: ii, iim1, iip1, ip1, iter, j, niter real(sp) :: a, b, c, del, dltlb, dltub, dphi, dpsi, dw, eps, erretm, eta, midpt, phi, & prew, psi, rhoinv, tau, temp, temp1, w ! Local Arrays - real(sp) :: zz(3) + real(sp) :: 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 + info = 0_${ik}$ + if( n==1_${ik}$ ) then ! presumably, i=1 upon entry - dlam = d( 1 ) + rho*z( 1 )*z( 1 ) - delta( 1 ) = one + dlam = d( 1_${ik}$ ) + rho*z( 1_${ik}$ )*z( 1_${ik}$ ) + delta( 1_${ik}$ ) = one return end if - if( n==2 ) then - call stdlib_slaed5( i, d, z, delta, rho, dlam ) + if( n==2_${ik}$ ) then + call stdlib${ii}$_slaed5( i, d, z, delta, rho, dlam ) return end if ! compute machine epsilon - eps = stdlib_slamch( 'EPSILON' ) + eps = stdlib${ii}$_slamch( 'EPSILON' ) rhoinv = one / rho ! 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 midpt = rho / two ! if ||z||_2 is not one, then temp should be set to @@ -47705,7 +47707,7 @@ module stdlib_linalg_lapack_s dltub = min( dltub, tau ) end if ! calculate the new step - niter = niter + 1 + niter = niter + 1_${ik}$ c = w - delta( n-1 )*dpsi - delta( n )*dphi a = ( delta( n-1 )+delta( n ) )*w -delta( n-1 )*delta( n )*( dpsi+dphi ) b = delta( n-1 )*delta( n )*w @@ -47756,7 +47758,7 @@ module stdlib_linalg_lapack_s 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 @@ -47815,14 +47817,14 @@ 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}$ dlam = d( i ) + tau go to 250 ! 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 del = d( ip1 ) - d( i ) midpt = del / two @@ -47878,10 +47880,10 @@ module stdlib_linalg_lapack_s if( orgati ) then ii = i else - ii = i + 1 + ii = i + 1_${ik}$ end if - iim1 = ii - 1 - iip1 = ii + 1 + iim1 = ii - 1_${ik}$ + iip1 = ii + 1_${ik}$ ! evaluate psi and the derivative dpsi dpsi = zero psi = zero @@ -47911,7 +47913,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 ) / delta( ii ) dw = dpsi + dphi + temp*temp temp = z( ii )*temp @@ -47933,14 +47935,14 @@ module stdlib_linalg_lapack_s dltub = min( dltub, tau ) end if ! calculate the new step - niter = niter + 1 + niter = niter + 1_${ik}$ if( .not.swtch3 ) then if( orgati ) then c = w - delta( ip1 )*dw - ( d( i )-d( ip1 ) )*( z( i ) / delta( i ) )& - **2 + **2_${ik}$ else c = w - delta( i )*dw - ( d( ip1 )-d( i ) )*( z( ip1 ) / delta( ip1 ) )& - **2 + **2_${ik}$ end if a = ( delta( i )+delta( ip1 ) )*w -delta( i )*delta( ip1 )*dw b = delta( i )*delta( ip1 )*w @@ -47965,17 +47967,17 @@ module stdlib_linalg_lapack_s temp1 = z( iim1 ) / delta( iim1 ) temp1 = temp1*temp1 c = temp - delta( iip1 )*( dpsi+dphi ) -( d( iim1 )-d( iip1 ) )*temp1 - zz( 1 ) = z( iim1 )*z( iim1 ) - zz( 3 ) = delta( iip1 )*delta( iip1 )*( ( dpsi-temp1 )+dphi ) + zz( 1_${ik}$ ) = z( iim1 )*z( iim1 ) + zz( 3_${ik}$ ) = delta( iip1 )*delta( iip1 )*( ( dpsi-temp1 )+dphi ) else temp1 = z( iip1 ) / delta( iip1 ) temp1 = temp1*temp1 c = temp - delta( iim1 )*( dpsi+dphi ) -( d( iip1 )-d( iim1 ) )*temp1 - zz( 1 ) = delta( iim1 )*delta( iim1 )*( dpsi+( dphi-temp1 ) ) - zz( 3 ) = z( iip1 )*z( iip1 ) + zz( 1_${ik}$ ) = delta( iim1 )*delta( iim1 )*( dpsi+( dphi-temp1 ) ) + zz( 3_${ik}$ ) = z( iip1 )*z( iip1 ) end if - zz( 2 ) = z( ii )*z( ii ) - call stdlib_slaed6( niter, orgati, c, delta( iim1 ), zz, w, eta,info ) + zz( 2_${ik}$ ) = z( ii )*z( ii ) + call stdlib${ii}$_slaed6( niter, orgati, c, delta( iim1 ), zz, w, eta,info ) if( info/=0 )go to 250 end if ! note, eta should be positive if w is negative, and @@ -48030,7 +48032,7 @@ module stdlib_linalg_lapack_s end if tau = tau + eta ! main loop to update the values of the array delta - iter = niter + 1 + iter = niter + 1_${ik}$ loop_240: do niter = iter, maxit ! test for convergence if( abs( w )<=eps*erretm ) then @@ -48051,10 +48053,10 @@ module stdlib_linalg_lapack_s if( .not.swtch ) then if( orgati ) then c = w - delta( ip1 )*dw -( d( i )-d( ip1 ) )*( z( i ) / delta( i ) )& - **2 + **2_${ik}$ else c = w - delta( i )*dw - ( d( ip1 )-d( i ) )*( z( ip1 ) / delta( ip1 ) )& - **2 + **2_${ik}$ end if else temp = z( ii ) / delta( ii ) @@ -48092,26 +48094,26 @@ module stdlib_linalg_lapack_s temp = rhoinv + psi + phi if( swtch ) then c = temp - delta( iim1 )*dpsi - delta( iip1 )*dphi - zz( 1 ) = delta( iim1 )*delta( iim1 )*dpsi - zz( 3 ) = delta( iip1 )*delta( iip1 )*dphi + zz( 1_${ik}$ ) = delta( iim1 )*delta( iim1 )*dpsi + zz( 3_${ik}$ ) = delta( iip1 )*delta( iip1 )*dphi else if( orgati ) then temp1 = z( iim1 ) / delta( iim1 ) temp1 = temp1*temp1 c = temp - delta( iip1 )*( dpsi+dphi ) -( d( iim1 )-d( iip1 ) )& *temp1 - zz( 1 ) = z( iim1 )*z( iim1 ) - zz( 3 ) = delta( iip1 )*delta( iip1 )*( ( dpsi-temp1 )+dphi ) + zz( 1_${ik}$ ) = z( iim1 )*z( iim1 ) + zz( 3_${ik}$ ) = delta( iip1 )*delta( iip1 )*( ( dpsi-temp1 )+dphi ) else temp1 = z( iip1 ) / delta( iip1 ) temp1 = temp1*temp1 c = temp - delta( iim1 )*( dpsi+dphi ) -( d( iip1 )-d( iim1 ) )& *temp1 - zz( 1 ) = delta( iim1 )*delta( iim1 )*( dpsi+( dphi-temp1 ) ) - zz( 3 ) = z( iip1 )*z( iip1 ) + zz( 1_${ik}$ ) = delta( iim1 )*delta( iim1 )*( dpsi+( dphi-temp1 ) ) + zz( 3_${ik}$ ) = z( iip1 )*z( iip1 ) end if end if - call stdlib_slaed6( niter, orgati, c, delta( iim1 ), zz, w, eta,info ) + call stdlib${ii}$_slaed6( niter, orgati, c, delta( iim1 ), zz, w, eta,info ) if( info/=0 )go to 250 end if ! note, eta should be positive if w is negative, and @@ -48162,7 +48164,7 @@ module stdlib_linalg_lapack_s if( w*prew>zero .and. abs( w )>abs( prew ) / ten )swtch = .not.swtch end do loop_240 ! return with info = 1, niter = maxit and not converged - info = 1 + info = 1_${ik}$ if( orgati ) then dlam = d( i ) + tau else @@ -48171,10 +48173,10 @@ module stdlib_linalg_lapack_s end if 250 continue return - end subroutine stdlib_slaed4 + end subroutine stdlib${ii}$_slaed4 - pure subroutine stdlib_slaed8( icompq, k, n, qsiz, d, q, ldq, indxq, rho,cutpnt, z, dlamda, & + pure subroutine stdlib${ii}$_slaed8( icompq, k, n, qsiz, d, q, ldq, indxq, rho,cutpnt, z, dlamda, & !! SLAED8 merges the two sets of eigenvalues 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 @@ -48186,62 +48188,62 @@ 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) :: cutpnt, icompq, ldq, ldq2, n, qsiz - integer(ilp), intent(out) :: givptr, info, k + integer(${ik}$), intent(in) :: cutpnt, icompq, ldq, ldq2, n, qsiz + integer(${ik}$), intent(out) :: givptr, info, k real(sp), intent(inout) :: rho ! Array Arguments - integer(ilp), intent(out) :: givcol(2,*), indx(*), indxp(*), perm(*) - integer(ilp), intent(inout) :: indxq(*) + integer(${ik}$), intent(out) :: givcol(2_${ik}$,*), indx(*), indxp(*), perm(*) + integer(${ik}$), intent(inout) :: indxq(*) real(sp), intent(inout) :: d(*), q(ldq,*), z(*) - real(sp), intent(out) :: dlamda(*), givnum(2,*), q2(ldq2,*), w(*) + real(sp), intent(out) :: dlamda(*), givnum(2_${ik}$,*), q2(ldq2,*), w(*) ! ===================================================================== ! Parameters real(sp), parameter :: mone = -1.0_sp ! Local Scalars - integer(ilp) :: i, imax, j, jlam, jmax, jp, k2, n1, n1p1, n2 + integer(${ik}$) :: i, imax, j, jlam, jmax, jp, k2, n1, n1p1, n2 real(sp) :: c, eps, s, t, tau, tol ! Intrinsic Functions intrinsic :: abs,max,min,sqrt ! Executable Statements ! test the input parameters. - info = 0 - if( icompq<0 .or. icompq>1 ) then - info = -1 - else if( n<0 ) then - info = -3 - else if( icompq==1 .and. qsizn ) then - info = -10 - else if( ldq21_${ik}$ ) then + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( icompq==1_${ik}$ .and. qsizn ) then + info = -10_${ik}$ + else if( ldq2n )go to 100 if( rho*abs( z( j ) )<=tol ) then ! deflate due to small z component. - k2 = k2 - 1 + k2 = k2 - 1_${ik}$ indxp( k2 ) = j else ! check if eigenvalues are close enough to allow deflation. @@ -48312,7 +48314,7 @@ module stdlib_linalg_lapack_s c = z( j ) ! find sqrt(a**2+b**2) without overflow or ! destructive underflow. - tau = stdlib_slapy2( c, s ) + tau = stdlib${ii}$_slapy2( c, s ) t = d( j ) - d( jlam ) c = c / tau s = -s / tau @@ -48321,26 +48323,26 @@ module stdlib_linalg_lapack_s z( j ) = tau z( jlam ) = zero ! record the appropriate givens rotation - givptr = givptr + 1 - givcol( 1, givptr ) = indxq( indx( jlam ) ) - givcol( 2, givptr ) = indxq( indx( j ) ) - givnum( 1, givptr ) = c - givnum( 2, givptr ) = s - if( icompq==1 ) then - call stdlib_srot( qsiz, q( 1, indxq( indx( jlam ) ) ), 1,q( 1, indxq( indx( j & - ) ) ), 1, c, s ) + givptr = givptr + 1_${ik}$ + givcol( 1_${ik}$, givptr ) = indxq( indx( jlam ) ) + givcol( 2_${ik}$, givptr ) = indxq( indx( j ) ) + givnum( 1_${ik}$, givptr ) = c + givnum( 2_${ik}$, givptr ) = s + if( icompq==1_${ik}$ ) then + call stdlib${ii}$_srot( qsiz, q( 1_${ik}$, indxq( indx( jlam ) ) ), 1_${ik}$,q( 1_${ik}$, indxq( indx( j & + ) ) ), 1_${ik}$, c, s ) end if t = d( jlam )*c*c + d( j )*s*s d( j ) = d( jlam )*s*s + d( j )*c*c d( jlam ) = t - k2 = k2 - 1 - i = 1 + k2 = k2 - 1_${ik}$ + i = 1_${ik}$ 90 continue if( k2+i<=n ) then if( d( jlam )max( 1, k ) ) then - info = -2 - else if( max( 1, kstop )max( 1, k ) )then - info = -3 + info = 0_${ik}$ + if( k<0_${ik}$ ) then + info = -1_${ik}$ + else if( kstart<1_${ik}$ .or. kstart>max( 1_${ik}$, k ) ) then + info = -2_${ik}$ + else if( max( 1_${ik}$, kstop )max( 1_${ik}$, k ) )then + info = -3_${ik}$ else if( n=growto*scale )go to 120 ! choose new orthogonal starting vector and try again. temp = eps3 / ( rootn+one ) - vr( 1 ) = eps3 + vr( 1_${ik}$ ) = eps3 do i = 2, n vr( i ) = temp end do vr( n-its+1 ) = vr( n-its+1 ) - eps3*rootn end do ! failure to find eigenvector in n iterations. - info = 1 + info = 1_${ik}$ 120 continue ! normalize eigenvector. - i = stdlib_isamax( n, vr, 1 ) - call stdlib_sscal( n, one / abs( vr( i ) ), vr, 1 ) + i = stdlib${ii}$_isamax( n, vr, 1_${ik}$ ) + call stdlib${ii}$_sscal( n, one / abs( vr( i ) ), vr, 1_${ik}$ ) else ! complex eigenvalue. if( noinit ) then @@ -48648,23 +48650,23 @@ module stdlib_linalg_lapack_s end do else ! scale supplied initial vector. - norm = stdlib_slapy2( stdlib_snrm2( n, vr, 1 ), stdlib_snrm2( n, vi, 1 ) ) + norm = stdlib${ii}$_slapy2( stdlib${ii}$_snrm2( n, vr, 1_${ik}$ ), stdlib${ii}$_snrm2( n, vi, 1_${ik}$ ) ) rec = ( eps3*rootn ) / max( norm, nrmsml ) - call stdlib_sscal( n, rec, vr, 1 ) - call stdlib_sscal( n, rec, vi, 1 ) + call stdlib${ii}$_sscal( n, rec, vr, 1_${ik}$ ) + call stdlib${ii}$_sscal( n, rec, vi, 1_${ik}$ ) end if if( rightv ) then ! lu decomposition with partial pivoting of b, replacing zero ! pivots by eps3. ! the imaginary part of the (i,j)-th element of u is stored in ! b(j+1,i). - b( 2, 1 ) = -wi + b( 2_${ik}$, 1_${ik}$ ) = -wi do i = 2, n - b( i+1, 1 ) = zero + b( i+1, 1_${ik}$ ) = zero end do loop_170: do i = 1, n - 1 - absbii = stdlib_slapy2( b( i, i ), b( i+1, i ) ) + absbii = stdlib${ii}$_slapy2( b( i, i ), b( i+1, i ) ) ei = h( i+1, i ) if( absbiivcrit ) then rec = one / vmax - call stdlib_sscal( n, rec, vr, 1 ) - call stdlib_sscal( n, rec, vi, 1 ) + call stdlib${ii}$_sscal( n, rec, vr, 1_${ik}$ ) + call stdlib${ii}$_sscal( n, rec, vi, 1_${ik}$ ) scale = scale*rec vmax = one vcrit = bignum @@ -48796,8 +48798,8 @@ module stdlib_linalg_lapack_s w1 = abs( xr ) + abs( xi ) if( w1>w*bignum ) then rec = one / w1 - call stdlib_sscal( n, rec, vr, 1 ) - call stdlib_sscal( n, rec, vi, 1 ) + call stdlib${ii}$_sscal( n, rec, vr, 1_${ik}$ ) + call stdlib${ii}$_sscal( n, rec, vi, 1_${ik}$ ) xr = vr( i ) xi = vi( i ) scale = scale*rec @@ -48805,7 +48807,7 @@ module stdlib_linalg_lapack_s end if end if ! divide by diagonal element of b. - call stdlib_sladiv( xr, xi, b( i, i ), b( i+1, i ), vr( i ),vi( i ) ) + call stdlib${ii}$_sladiv( xr, xi, b( i, i ), b( i+1, i ), vr( i ),vi( i ) ) vmax = max( abs( vr( i ) )+abs( vi( i ) ), vmax ) vcrit = bignum / vmax @@ -48822,12 +48824,12 @@ module stdlib_linalg_lapack_s end if end do loop_250 ! test for sufficient growth in the norm of (vr,vi). - vnorm = stdlib_sasum( n, vr, 1 ) + stdlib_sasum( n, vi, 1 ) + vnorm = stdlib${ii}$_sasum( n, vr, 1_${ik}$ ) + stdlib${ii}$_sasum( n, vi, 1_${ik}$ ) if( vnorm>=growto*scale )go to 280 ! choose a new orthogonal starting vector and try again. y = eps3 / ( rootn+one ) - vr( 1 ) = eps3 - vi( 1 ) = zero + vr( 1_${ik}$ ) = eps3 + vi( 1_${ik}$ ) = zero do i = 2, n vr( i ) = y vi( i ) = zero @@ -48835,21 +48837,21 @@ module stdlib_linalg_lapack_s vr( n-its+1 ) = vr( n-its+1 ) - eps3*rootn end do loop_270 ! failure to find eigenvector in n iterations - info = 1 + info = 1_${ik}$ 280 continue ! normalize eigenvector. vnorm = zero do i = 1, n vnorm = max( vnorm, abs( vr( i ) )+abs( vi( i ) ) ) end do - call stdlib_sscal( n, one / vnorm, vr, 1 ) - call stdlib_sscal( n, one / vnorm, vi, 1 ) + call stdlib${ii}$_sscal( n, one / vnorm, vr, 1_${ik}$ ) + call stdlib${ii}$_sscal( n, one / vnorm, vi, 1_${ik}$ ) end if return - end subroutine stdlib_slaein + end subroutine stdlib${ii}$_slaein - pure subroutine stdlib_slagv2( a, lda, b, ldb, alphar, alphai, beta, csl, snl,csr, snr ) + pure subroutine stdlib${ii}$_slagv2( a, lda, b, ldb, alphar, alphai, beta, csl, snl,csr, snr ) !! SLAGV2 computes the Generalized Schur factorization of a real 2-by-2 !! matrix pencil (A,B) where B is upper triangular. This routine !! computes orthogonal (rotation) matrices given by CSL, SNL and CSR, @@ -48872,11 +48874,11 @@ 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(out) :: csl, csr, snl, snr ! Array Arguments real(sp), intent(inout) :: a(lda,*), b(ldb,*) - real(sp), intent(out) :: alphai(2), alphar(2), beta(2) + real(sp), intent(out) :: alphai(2_${ik}$), alphar(2_${ik}$), beta(2_${ik}$) ! ===================================================================== ! Local Scalars @@ -48885,135 +48887,135 @@ module stdlib_linalg_lapack_s ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements - safmin = stdlib_slamch( 'S' ) - ulp = stdlib_slamch( 'P' ) + safmin = stdlib${ii}$_slamch( 'S' ) + ulp = stdlib${ii}$_slamch( 'P' ) ! 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 - a( 1, 1 ) = ascale*a( 1, 1 ) - a( 1, 2 ) = ascale*a( 1, 2 ) - a( 2, 1 ) = ascale*a( 2, 1 ) - a( 2, 2 ) = ascale*a( 2, 2 ) + a( 1_${ik}$, 1_${ik}$ ) = ascale*a( 1_${ik}$, 1_${ik}$ ) + a( 1_${ik}$, 2_${ik}$ ) = ascale*a( 1_${ik}$, 2_${ik}$ ) + a( 2_${ik}$, 1_${ik}$ ) = ascale*a( 2_${ik}$, 1_${ik}$ ) + a( 2_${ik}$, 2_${ik}$ ) = ascale*a( 2_${ik}$, 2_${ik}$ ) ! scale b - bnorm = max( abs( b( 1, 1 ) ), abs( b( 1, 2 ) )+abs( b( 2, 2 ) ),safmin ) + bnorm = max( abs( b( 1_${ik}$, 1_${ik}$ ) ), abs( b( 1_${ik}$, 2_${ik}$ ) )+abs( b( 2_${ik}$, 2_${ik}$ ) ),safmin ) bscale = one / bnorm - b( 1, 1 ) = bscale*b( 1, 1 ) - b( 1, 2 ) = bscale*b( 1, 2 ) - b( 2, 2 ) = bscale*b( 2, 2 ) + b( 1_${ik}$, 1_${ik}$ ) = bscale*b( 1_${ik}$, 1_${ik}$ ) + b( 1_${ik}$, 2_${ik}$ ) = bscale*b( 1_${ik}$, 2_${ik}$ ) + b( 2_${ik}$, 2_${ik}$ ) = bscale*b( 2_${ik}$, 2_${ik}$ ) ! check if a can be deflated - if( abs( a( 2, 1 ) )<=ulp ) then + if( abs( a( 2_${ik}$, 1_${ik}$ ) )<=ulp ) then csl = one snl = zero csr = one snr = zero - a( 2, 1 ) = zero - b( 2, 1 ) = zero + a( 2_${ik}$, 1_${ik}$ ) = zero + b( 2_${ik}$, 1_${ik}$ ) = zero wi = zero ! check if b is singular - else if( abs( b( 1, 1 ) )<=ulp ) then - call stdlib_slartg( a( 1, 1 ), a( 2, 1 ), csl, snl, r ) + else if( abs( b( 1_${ik}$, 1_${ik}$ ) )<=ulp ) then + call stdlib${ii}$_slartg( a( 1_${ik}$, 1_${ik}$ ), a( 2_${ik}$, 1_${ik}$ ), csl, snl, r ) csr = one snr = zero - call stdlib_srot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl ) - call stdlib_srot( 2, b( 1, 1 ), ldb, b( 2, 1 ), ldb, csl, snl ) - a( 2, 1 ) = zero - b( 1, 1 ) = zero - b( 2, 1 ) = zero + call stdlib${ii}$_srot( 2_${ik}$, a( 1_${ik}$, 1_${ik}$ ), lda, a( 2_${ik}$, 1_${ik}$ ), lda, csl, snl ) + call stdlib${ii}$_srot( 2_${ik}$, b( 1_${ik}$, 1_${ik}$ ), ldb, b( 2_${ik}$, 1_${ik}$ ), ldb, csl, snl ) + a( 2_${ik}$, 1_${ik}$ ) = zero + b( 1_${ik}$, 1_${ik}$ ) = zero + b( 2_${ik}$, 1_${ik}$ ) = zero wi = zero - else if( abs( b( 2, 2 ) )<=ulp ) then - call stdlib_slartg( a( 2, 2 ), a( 2, 1 ), csr, snr, t ) + else if( abs( b( 2_${ik}$, 2_${ik}$ ) )<=ulp ) then + call stdlib${ii}$_slartg( a( 2_${ik}$, 2_${ik}$ ), a( 2_${ik}$, 1_${ik}$ ), csr, snr, t ) snr = -snr - call stdlib_srot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr ) - call stdlib_srot( 2, b( 1, 1 ), 1, b( 1, 2 ), 1, csr, snr ) + call stdlib${ii}$_srot( 2_${ik}$, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, a( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, csr, snr ) + call stdlib${ii}$_srot( 2_${ik}$, b( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, b( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, csr, snr ) csl = one snl = zero - a( 2, 1 ) = zero - b( 2, 1 ) = zero - b( 2, 2 ) = zero + a( 2_${ik}$, 1_${ik}$ ) = zero + b( 2_${ik}$, 1_${ik}$ ) = zero + b( 2_${ik}$, 2_${ik}$ ) = zero wi = zero else ! b is nonsingular, first compute the eigenvalues of (a,b) - call stdlib_slag2( a, lda, b, ldb, safmin, scale1, scale2, wr1, wr2,wi ) + call stdlib${ii}$_slag2( a, lda, b, ldb, safmin, scale1, scale2, wr1, wr2,wi ) if( wi==zero ) then ! two real eigenvalues, compute s*a-w*b - h1 = scale1*a( 1, 1 ) - wr1*b( 1, 1 ) - h2 = scale1*a( 1, 2 ) - wr1*b( 1, 2 ) - h3 = scale1*a( 2, 2 ) - wr1*b( 2, 2 ) - rr = stdlib_slapy2( h1, h2 ) - qq = stdlib_slapy2( scale1*a( 2, 1 ), h3 ) + h1 = scale1*a( 1_${ik}$, 1_${ik}$ ) - wr1*b( 1_${ik}$, 1_${ik}$ ) + h2 = scale1*a( 1_${ik}$, 2_${ik}$ ) - wr1*b( 1_${ik}$, 2_${ik}$ ) + h3 = scale1*a( 2_${ik}$, 2_${ik}$ ) - wr1*b( 2_${ik}$, 2_${ik}$ ) + rr = stdlib${ii}$_slapy2( h1, h2 ) + qq = stdlib${ii}$_slapy2( scale1*a( 2_${ik}$, 1_${ik}$ ), h3 ) if( rr>qq ) then ! find right rotation matrix to zero 1,1 element of ! (sa - wb) - call stdlib_slartg( h2, h1, csr, snr, t ) + call stdlib${ii}$_slartg( h2, h1, csr, snr, t ) else ! find right rotation matrix to zero 2,1 element of ! (sa - wb) - call stdlib_slartg( h3, scale1*a( 2, 1 ), csr, snr, t ) + call stdlib${ii}$_slartg( h3, scale1*a( 2_${ik}$, 1_${ik}$ ), csr, snr, t ) end if snr = -snr - call stdlib_srot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr ) - call stdlib_srot( 2, b( 1, 1 ), 1, b( 1, 2 ), 1, csr, snr ) + call stdlib${ii}$_srot( 2_${ik}$, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, a( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, csr, snr ) + call stdlib${ii}$_srot( 2_${ik}$, b( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, b( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, csr, snr ) ! compute inf norms of a and b - h1 = max( abs( a( 1, 1 ) )+abs( a( 1, 2 ) ),abs( a( 2, 1 ) )+abs( a( 2, 2 ) ) ) + h1 = max( abs( a( 1_${ik}$, 1_${ik}$ ) )+abs( a( 1_${ik}$, 2_${ik}$ ) ),abs( a( 2_${ik}$, 1_${ik}$ ) )+abs( a( 2_${ik}$, 2_${ik}$ ) ) ) - h2 = max( abs( b( 1, 1 ) )+abs( b( 1, 2 ) ),abs( b( 2, 1 ) )+abs( b( 2, 2 ) ) ) + h2 = max( abs( b( 1_${ik}$, 1_${ik}$ ) )+abs( b( 1_${ik}$, 2_${ik}$ ) ),abs( b( 2_${ik}$, 1_${ik}$ ) )+abs( b( 2_${ik}$, 2_${ik}$ ) ) ) if( ( scale1*h1 )>=abs( wr1 )*h2 ) then ! find left rotation matrix q to zero out b(2,1) - call stdlib_slartg( b( 1, 1 ), b( 2, 1 ), csl, snl, r ) + call stdlib${ii}$_slartg( b( 1_${ik}$, 1_${ik}$ ), b( 2_${ik}$, 1_${ik}$ ), csl, snl, r ) else ! find left rotation matrix q to zero out a(2,1) - call stdlib_slartg( a( 1, 1 ), a( 2, 1 ), csl, snl, r ) + call stdlib${ii}$_slartg( a( 1_${ik}$, 1_${ik}$ ), a( 2_${ik}$, 1_${ik}$ ), csl, snl, r ) end if - call stdlib_srot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl ) - call stdlib_srot( 2, b( 1, 1 ), ldb, b( 2, 1 ), ldb, csl, snl ) - a( 2, 1 ) = zero - b( 2, 1 ) = zero + call stdlib${ii}$_srot( 2_${ik}$, a( 1_${ik}$, 1_${ik}$ ), lda, a( 2_${ik}$, 1_${ik}$ ), lda, csl, snl ) + call stdlib${ii}$_srot( 2_${ik}$, b( 1_${ik}$, 1_${ik}$ ), ldb, b( 2_${ik}$, 1_${ik}$ ), ldb, csl, snl ) + a( 2_${ik}$, 1_${ik}$ ) = zero + b( 2_${ik}$, 1_${ik}$ ) = zero else ! a pair of complex conjugate eigenvalues ! first compute the svd of the matrix b - call stdlib_slasv2( b( 1, 1 ), b( 1, 2 ), b( 2, 2 ), r, t, snr,csr, snl, csl ) + call stdlib${ii}$_slasv2( b( 1_${ik}$, 1_${ik}$ ), b( 1_${ik}$, 2_${ik}$ ), b( 2_${ik}$, 2_${ik}$ ), r, t, snr,csr, snl, csl ) ! form (a,b) := q(a,b)z**t where q is left rotation matrix and - ! z is right rotation matrix computed from stdlib_slasv2 - call stdlib_srot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl ) - call stdlib_srot( 2, b( 1, 1 ), ldb, b( 2, 1 ), ldb, csl, snl ) - call stdlib_srot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr ) - call stdlib_srot( 2, b( 1, 1 ), 1, b( 1, 2 ), 1, csr, snr ) - b( 2, 1 ) = zero - b( 1, 2 ) = zero + ! z is right rotation matrix computed from stdlib${ii}$_slasv2 + call stdlib${ii}$_srot( 2_${ik}$, a( 1_${ik}$, 1_${ik}$ ), lda, a( 2_${ik}$, 1_${ik}$ ), lda, csl, snl ) + call stdlib${ii}$_srot( 2_${ik}$, b( 1_${ik}$, 1_${ik}$ ), ldb, b( 2_${ik}$, 1_${ik}$ ), ldb, csl, snl ) + call stdlib${ii}$_srot( 2_${ik}$, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, a( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, csr, snr ) + call stdlib${ii}$_srot( 2_${ik}$, b( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, b( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, csr, snr ) + b( 2_${ik}$, 1_${ik}$ ) = zero + b( 1_${ik}$, 2_${ik}$ ) = zero end if end if ! unscaling - a( 1, 1 ) = anorm*a( 1, 1 ) - a( 2, 1 ) = anorm*a( 2, 1 ) - a( 1, 2 ) = anorm*a( 1, 2 ) - a( 2, 2 ) = anorm*a( 2, 2 ) - b( 1, 1 ) = bnorm*b( 1, 1 ) - b( 2, 1 ) = bnorm*b( 2, 1 ) - b( 1, 2 ) = bnorm*b( 1, 2 ) - b( 2, 2 ) = bnorm*b( 2, 2 ) + a( 1_${ik}$, 1_${ik}$ ) = anorm*a( 1_${ik}$, 1_${ik}$ ) + a( 2_${ik}$, 1_${ik}$ ) = anorm*a( 2_${ik}$, 1_${ik}$ ) + a( 1_${ik}$, 2_${ik}$ ) = anorm*a( 1_${ik}$, 2_${ik}$ ) + a( 2_${ik}$, 2_${ik}$ ) = anorm*a( 2_${ik}$, 2_${ik}$ ) + b( 1_${ik}$, 1_${ik}$ ) = bnorm*b( 1_${ik}$, 1_${ik}$ ) + b( 2_${ik}$, 1_${ik}$ ) = bnorm*b( 2_${ik}$, 1_${ik}$ ) + b( 1_${ik}$, 2_${ik}$ ) = bnorm*b( 1_${ik}$, 2_${ik}$ ) + b( 2_${ik}$, 2_${ik}$ ) = bnorm*b( 2_${ik}$, 2_${ik}$ ) if( wi==zero ) then - alphar( 1 ) = a( 1, 1 ) - alphar( 2 ) = a( 2, 2 ) - alphai( 1 ) = zero - alphai( 2 ) = zero - beta( 1 ) = b( 1, 1 ) - beta( 2 ) = b( 2, 2 ) - else - alphar( 1 ) = anorm*wr1 / scale1 / bnorm - alphai( 1 ) = anorm*wi / scale1 / bnorm - alphar( 2 ) = alphar( 1 ) - alphai( 2 ) = -alphai( 1 ) - beta( 1 ) = one - beta( 2 ) = one + alphar( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ ) + alphar( 2_${ik}$ ) = a( 2_${ik}$, 2_${ik}$ ) + alphai( 1_${ik}$ ) = zero + alphai( 2_${ik}$ ) = zero + beta( 1_${ik}$ ) = b( 1_${ik}$, 1_${ik}$ ) + beta( 2_${ik}$ ) = b( 2_${ik}$, 2_${ik}$ ) + else + alphar( 1_${ik}$ ) = anorm*wr1 / scale1 / bnorm + alphai( 1_${ik}$ ) = anorm*wi / scale1 / bnorm + alphar( 2_${ik}$ ) = alphar( 1_${ik}$ ) + alphai( 2_${ik}$ ) = -alphai( 1_${ik}$ ) + beta( 1_${ik}$ ) = one + beta( 2_${ik}$ ) = one end if return - end subroutine stdlib_slagv2 + end subroutine stdlib${ii}$_slagv2 - pure subroutine stdlib_slahr2( n, k, nb, a, lda, tau, t, ldt, y, ldy ) + pure subroutine stdlib${ii}$_slahr2( n, k, nb, a, lda, tau, t, ldt, y, ldy ) !! SLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1) !! matrix A so that elements below the k-th subdiagonal are zero. The !! reduction is performed by an orthogonal similarity transformation @@ -49024,14 +49026,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) :: k, lda, ldt, ldy, n, nb + integer(${ik}$), intent(in) :: k, lda, ldt, ldy, n, nb ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: t(ldt,nb), tau(nb), y(ldy,nb) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i real(sp) :: ei ! Intrinsic Functions intrinsic :: min @@ -49039,69 +49041,69 @@ module stdlib_linalg_lapack_s ! quick return if possible if( n<=1 )return loop_10: do i = 1, nb - if( i>1 ) then + if( i>1_${ik}$ ) then ! update a(k+1:n,i) ! update i-th column of a - y * v**t - call stdlib_sgemv( 'NO TRANSPOSE', n-k, i-1, -one, y(k+1,1), ldy,a( k+i-1, 1 ), & - lda, one, a( k+1, i ), 1 ) + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n-k, i-1, -one, y(k+1,1_${ik}$), ldy,a( k+i-1, 1_${ik}$ ), & + lda, one, a( k+1, i ), 1_${ik}$ ) ! apply i - v * t**t * v**t to this column (call it b) from the ! left, using the last column of t as workspace ! let v = ( v1 ) and b = ( b1 ) (first i-1 rows) ! ( v2 ) ( b2 ) ! where v1 is unit lower triangular ! w := v1**t * b1 - call stdlib_scopy( i-1, a( k+1, i ), 1, t( 1, nb ), 1 ) - call stdlib_strmv( 'LOWER', 'TRANSPOSE', 'UNIT',i-1, a( k+1, 1 ),lda, t( 1, nb ),& - 1 ) + call stdlib${ii}$_scopy( i-1, a( k+1, i ), 1_${ik}$, t( 1_${ik}$, nb ), 1_${ik}$ ) + call stdlib${ii}$_strmv( 'LOWER', 'TRANSPOSE', 'UNIT',i-1, a( k+1, 1_${ik}$ ),lda, t( 1_${ik}$, nb ),& + 1_${ik}$ ) ! w := w + v2**t * b2 - call stdlib_sgemv( 'TRANSPOSE', n-k-i+1, i-1,one, a( k+i, 1 ),lda, a( k+i, i ), & - 1, one, t( 1, nb ), 1 ) + call stdlib${ii}$_sgemv( 'TRANSPOSE', n-k-i+1, i-1,one, a( k+i, 1_${ik}$ ),lda, a( k+i, i ), & + 1_${ik}$, one, t( 1_${ik}$, nb ), 1_${ik}$ ) ! w := t**t * w - call stdlib_strmv( 'UPPER', 'TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1, nb ), 1 ) + call stdlib${ii}$_strmv( 'UPPER', 'TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1_${ik}$, nb ), 1_${ik}$ ) ! b2 := b2 - v2*w - call stdlib_sgemv( 'NO TRANSPOSE', n-k-i+1, i-1, -one,a( k+i, 1 ),lda, t( 1, nb )& - , 1, one, a( k+i, i ), 1 ) + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n-k-i+1, i-1, -one,a( k+i, 1_${ik}$ ),lda, t( 1_${ik}$, nb )& + , 1_${ik}$, one, a( k+i, i ), 1_${ik}$ ) ! b1 := b1 - v1*w - call stdlib_strmv( 'LOWER', 'NO TRANSPOSE','UNIT', i-1,a( k+1, 1 ), lda, t( 1, & - nb ), 1 ) - call stdlib_saxpy( i-1, -one, t( 1, nb ), 1, a( k+1, i ), 1 ) + call stdlib${ii}$_strmv( 'LOWER', 'NO TRANSPOSE','UNIT', i-1,a( k+1, 1_${ik}$ ), lda, t( 1_${ik}$, & + nb ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( i-1, -one, t( 1_${ik}$, nb ), 1_${ik}$, a( k+1, i ), 1_${ik}$ ) a( k+i-1, i-1 ) = ei end if ! generate the elementary reflector h(i) to annihilate ! a(k+i+1:n,i) - call stdlib_slarfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1,tau( i ) ) + call stdlib${ii}$_slarfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1_${ik}$,tau( i ) ) ei = a( k+i, i ) a( k+i, i ) = one ! compute y(k+1:n,i) - call stdlib_sgemv( 'NO TRANSPOSE', n-k, n-k-i+1,one, a( k+1, i+1 ),lda, a( k+i, i ),& - 1, zero, y( k+1, i ), 1 ) - call stdlib_sgemv( 'TRANSPOSE', n-k-i+1, i-1,one, a( k+i, 1 ), lda,a( k+i, i ), 1, & - zero, t( 1, i ), 1 ) - call stdlib_sgemv( 'NO TRANSPOSE', n-k, i-1, -one,y( k+1, 1 ), ldy,t( 1, i ), 1, & - one, y( k+1, i ), 1 ) - call stdlib_sscal( n-k, tau( i ), y( k+1, i ), 1 ) + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n-k, n-k-i+1,one, a( k+1, i+1 ),lda, a( k+i, i ),& + 1_${ik}$, zero, y( k+1, i ), 1_${ik}$ ) + call stdlib${ii}$_sgemv( 'TRANSPOSE', n-k-i+1, i-1,one, a( k+i, 1_${ik}$ ), lda,a( k+i, i ), 1_${ik}$, & + zero, t( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n-k, i-1, -one,y( k+1, 1_${ik}$ ), ldy,t( 1_${ik}$, i ), 1_${ik}$, & + one, y( k+1, i ), 1_${ik}$ ) + call stdlib${ii}$_sscal( n-k, tau( i ), y( k+1, i ), 1_${ik}$ ) ! compute t(1:i,i) - call stdlib_sscal( i-1, -tau( i ), t( 1, i ), 1 ) - call stdlib_strmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1, i ), 1 ) + call stdlib${ii}$_sscal( i-1, -tau( i ), t( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_strmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1_${ik}$, i ), 1_${ik}$ ) t( i, i ) = tau( i ) end do loop_10 a( k+nb, nb ) = ei ! compute y(1:k,1:nb) - call stdlib_slacpy( 'ALL', k, nb, a( 1, 2 ), lda, y, ldy ) - call stdlib_strmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE','UNIT', k, nb,one, a( k+1, 1 ), & + call stdlib${ii}$_slacpy( 'ALL', k, nb, a( 1_${ik}$, 2_${ik}$ ), lda, y, ldy ) + call stdlib${ii}$_strmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE','UNIT', k, nb,one, a( k+1, 1_${ik}$ ), & lda, y, ldy ) - if( n>k+nb )call stdlib_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,nb, n-k-nb, one,a( 1, & - 2+nb ), lda, a( k+1+nb, 1 ), lda, one, y,ldy ) - call stdlib_strmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE','NON-UNIT', k, nb,one, t, ldt, y, & + if( n>k+nb )call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,nb, n-k-nb, one,a( 1_${ik}$, & + 2_${ik}$+nb ), lda, a( k+1+nb, 1_${ik}$ ), lda, one, y,ldy ) + call stdlib${ii}$_strmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE','NON-UNIT', k, nb,one, t, ldt, y, & ldy ) return - end subroutine stdlib_slahr2 + end subroutine stdlib${ii}$_slahr2 - pure subroutine stdlib_slaln2( ltrans, na, nw, smin, ca, a, lda, d1, d2, b,ldb, wr, wi, x, & + pure subroutine stdlib${ii}$_slaln2( ltrans, na, nw, smin, ca, a, lda, d1, d2, b,ldb, wr, wi, x, & !! SLALN2 solves a system of the form (ca A - w D ) X = s B !! or (ca A**T - w D) X = s B with possible scaling ("s") and !! perturbation of A. (A**T means A-transpose.) @@ -49133,8 +49135,8 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: ltrans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldb, ldx, na, nw + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldx, na, nw real(sp), intent(in) :: ca, d1, d2, smin, wi, wr real(sp), intent(out) :: scale, xnorm ! Array Arguments @@ -49144,56 +49146,56 @@ module stdlib_linalg_lapack_s ! Local Scalars - integer(ilp) :: icmax, j + integer(${ik}$) :: icmax, j real(sp) :: bbnd, bi1, bi2, bignum, bnorm, br1, br2, ci21, ci22, cmax, cnorm, cr21, & cr22, csi, csr, li21, lr21, smini, smlnum, temp, u22abs, ui11, ui11r, ui12, ui12s, & ui22, ur11, ur11r, ur12, ur12s, ur22, xi1, xi2, xr1, xr2 ! Local Arrays - logical(lk) :: cswap(4), rswap(4) - integer(ilp) :: ipivot(4,4) - real(sp) :: ci(2,2), civ(4), cr(2,2), crv(4) + logical(lk) :: cswap(4_${ik}$), rswap(4_${ik}$) + integer(${ik}$) :: ipivot(4_${ik}$,4_${ik}$) + real(sp) :: ci(2_${ik}$,2_${ik}$), civ(4_${ik}$), cr(2_${ik}$,2_${ik}$), crv(4_${ik}$) ! Intrinsic Functions intrinsic :: abs,max ! Equivalences - equivalence ( ci( 1, 1 ), civ( 1 ) ),( cr( 1, 1 ), crv( 1 ) ) + equivalence ( ci( 1_${ik}$, 1_${ik}$ ), civ( 1_${ik}$ ) ),( cr( 1_${ik}$, 1_${ik}$ ), crv( 1_${ik}$ ) ) ! Data Statements cswap = [.false.,.false.,.true.,.true.] rswap = [.false.,.true.,.false.,.true.] - ipivot = reshape([1,2,3,4,2,1,4,3,3,4,1,2,4,3,2,1],[4,4]) + ipivot = reshape([1_${ik}$,2_${ik}$,3_${ik}$,4_${ik}$,2_${ik}$,1_${ik}$,4_${ik}$,3_${ik}$,3_${ik}$,4_${ik}$,1_${ik}$,2_${ik}$,4_${ik}$,3_${ik}$,2_${ik}$,1_${ik}$],[4_${ik}$,4_${ik}$]) ! Executable Statements ! compute bignum - smlnum = two*stdlib_slamch( 'SAFE MINIMUM' ) + smlnum = two*stdlib${ii}$_slamch( 'SAFE MINIMUM' ) bignum = one / smlnum smini = max( smin, smlnum ) ! don't check for input errors - info = 0 + info = 0_${ik}$ ! standard initializations scale = one - if( na==1 ) then + if( na==1_${ik}$ ) then ! 1 x 1 (i.e., scalar) system c x = b - if( nw==1 ) then + if( nw==1_${ik}$ ) then ! real 1x1 system. ! c = ca a - w d - csr = ca*a( 1, 1 ) - wr*d1 + csr = ca*a( 1_${ik}$, 1_${ik}$ ) - wr*d1 cnorm = abs( csr ) ! if | c | < smini, use c = smini if( cnormone ) then if( bnorm>bignum*cnorm )scale = one / bnorm end if ! compute x - x( 1, 1 ) = ( b( 1, 1 )*scale ) / csr - xnorm = abs( x( 1, 1 ) ) + x( 1_${ik}$, 1_${ik}$ ) = ( b( 1_${ik}$, 1_${ik}$ )*scale ) / csr + xnorm = abs( x( 1_${ik}$, 1_${ik}$ ) ) else ! complex 1x1 system (w is complex) ! c = ca a - w d - csr = ca*a( 1, 1 ) - wr*d1 + csr = ca*a( 1_${ik}$, 1_${ik}$ ) - wr*d1 csi = -wi*d1 cnorm = abs( csr ) + abs( csi ) ! if | c | < smini, use c = smini @@ -49201,35 +49203,35 @@ module stdlib_linalg_lapack_s csr = smini csi = zero cnorm = smini - info = 1 + info = 1_${ik}$ end if ! check scaling for x = b / c - bnorm = abs( b( 1, 1 ) ) + abs( b( 1, 2 ) ) + bnorm = abs( b( 1_${ik}$, 1_${ik}$ ) ) + abs( b( 1_${ik}$, 2_${ik}$ ) ) if( cnormone ) then if( bnorm>bignum*cnorm )scale = one / bnorm end if ! compute x - call stdlib_sladiv( scale*b( 1, 1 ), scale*b( 1, 2 ), csr, csi,x( 1, 1 ), x( 1, & - 2 ) ) - xnorm = abs( x( 1, 1 ) ) + abs( x( 1, 2 ) ) + call stdlib${ii}$_sladiv( scale*b( 1_${ik}$, 1_${ik}$ ), scale*b( 1_${ik}$, 2_${ik}$ ), csr, csi,x( 1_${ik}$, 1_${ik}$ ), x( 1_${ik}$, & + 2_${ik}$ ) ) + xnorm = abs( x( 1_${ik}$, 1_${ik}$ ) ) + abs( x( 1_${ik}$, 2_${ik}$ ) ) end if else ! 2x2 system ! compute the realpart of c = ca a - w d (or ca a**t - w d,KIND=sp) - cr( 1, 1 ) = ca*a( 1, 1 ) - wr*d1 - cr( 2, 2 ) = ca*a( 2, 2 ) - wr*d2 + cr( 1_${ik}$, 1_${ik}$ ) = ca*a( 1_${ik}$, 1_${ik}$ ) - wr*d1 + cr( 2_${ik}$, 2_${ik}$ ) = ca*a( 2_${ik}$, 2_${ik}$ ) - wr*d2 if( ltrans ) then - cr( 1, 2 ) = ca*a( 2, 1 ) - cr( 2, 1 ) = ca*a( 1, 2 ) + cr( 1_${ik}$, 2_${ik}$ ) = ca*a( 2_${ik}$, 1_${ik}$ ) + cr( 2_${ik}$, 1_${ik}$ ) = ca*a( 1_${ik}$, 2_${ik}$ ) else - cr( 2, 1 ) = ca*a( 2, 1 ) - cr( 1, 2 ) = ca*a( 1, 2 ) + cr( 2_${ik}$, 1_${ik}$ ) = ca*a( 2_${ik}$, 1_${ik}$ ) + cr( 1_${ik}$, 2_${ik}$ ) = ca*a( 1_${ik}$, 2_${ik}$ ) end if - if( nw==1 ) then + if( nw==1_${ik}$ ) then ! real2x2 system (w is real,KIND=sp) ! find the largest element in c cmax = zero - icmax = 0 + icmax = 0_${ik}$ do j = 1, 4 if( abs( crv( j ) )>cmax ) then cmax = abs( crv( j ) ) @@ -49238,36 +49240,36 @@ module stdlib_linalg_lapack_s end do ! if norm(c) < smini, use smini*identity. if( cmaxone ) then if( bnorm>bignum*smini )scale = one / bnorm end if temp = scale / smini - x( 1, 1 ) = temp*b( 1, 1 ) - x( 2, 1 ) = temp*b( 2, 1 ) + x( 1_${ik}$, 1_${ik}$ ) = temp*b( 1_${ik}$, 1_${ik}$ ) + x( 2_${ik}$, 1_${ik}$ ) = temp*b( 2_${ik}$, 1_${ik}$ ) xnorm = temp*bnorm - info = 1 + info = 1_${ik}$ return end if ! gaussian elimination with complete pivoting. ur11 = crv( icmax ) - cr21 = crv( ipivot( 2, icmax ) ) - ur12 = crv( ipivot( 3, icmax ) ) - cr22 = crv( ipivot( 4, icmax ) ) + cr21 = crv( ipivot( 2_${ik}$, icmax ) ) + ur12 = crv( ipivot( 3_${ik}$, icmax ) ) + cr22 = crv( ipivot( 4_${ik}$, icmax ) ) ur11r = one / ur11 lr21 = ur11r*cr21 ur22 = cr22 - ur12*lr21 ! if smaller pivot < smini, use smini if( abs( ur22 ) overflow if( xnorm>one .and. cmax>one ) then if( xnorm>bignum / cmax ) then temp = cmax / bignum - x( 1, 1 ) = temp*x( 1, 1 ) - x( 2, 1 ) = temp*x( 2, 1 ) + x( 1_${ik}$, 1_${ik}$ ) = temp*x( 1_${ik}$, 1_${ik}$ ) + x( 2_${ik}$, 1_${ik}$ ) = temp*x( 2_${ik}$, 1_${ik}$ ) xnorm = temp*xnorm scale = temp*scale end if @@ -49297,12 +49299,12 @@ module stdlib_linalg_lapack_s else ! complex 2x2 system (w is complex) ! find the largest element in c - ci( 1, 1 ) = -wi*d1 - ci( 2, 1 ) = zero - ci( 1, 2 ) = zero - ci( 2, 2 ) = -wi*d2 + ci( 1_${ik}$, 1_${ik}$ ) = -wi*d1 + ci( 2_${ik}$, 1_${ik}$ ) = zero + ci( 1_${ik}$, 2_${ik}$ ) = zero + ci( 2_${ik}$, 2_${ik}$ ) = -wi*d2 cmax = zero - icmax = 0 + icmax = 0_${ik}$ do j = 1, 4 if( abs( crv( j ) )+abs( civ( j ) )>cmax ) then cmax = abs( crv( j ) ) + abs( civ( j ) ) @@ -49311,38 +49313,38 @@ module stdlib_linalg_lapack_s end do ! if norm(c) < smini, use smini*identity. if( cmaxone ) then if( bnorm>bignum*smini )scale = one / bnorm end if temp = scale / smini - x( 1, 1 ) = temp*b( 1, 1 ) - x( 2, 1 ) = temp*b( 2, 1 ) - x( 1, 2 ) = temp*b( 1, 2 ) - x( 2, 2 ) = temp*b( 2, 2 ) + x( 1_${ik}$, 1_${ik}$ ) = temp*b( 1_${ik}$, 1_${ik}$ ) + x( 2_${ik}$, 1_${ik}$ ) = temp*b( 2_${ik}$, 1_${ik}$ ) + x( 1_${ik}$, 2_${ik}$ ) = temp*b( 1_${ik}$, 2_${ik}$ ) + x( 2_${ik}$, 2_${ik}$ ) = temp*b( 2_${ik}$, 2_${ik}$ ) xnorm = temp*bnorm - info = 1 + info = 1_${ik}$ return end if ! gaussian elimination with complete pivoting. ur11 = crv( icmax ) ui11 = civ( icmax ) - cr21 = crv( ipivot( 2, icmax ) ) - ci21 = civ( ipivot( 2, icmax ) ) - ur12 = crv( ipivot( 3, icmax ) ) - ui12 = civ( ipivot( 3, icmax ) ) - cr22 = crv( ipivot( 4, icmax ) ) - ci22 = civ( ipivot( 4, icmax ) ) - if( icmax==1 .or. icmax==4 ) then + cr21 = crv( ipivot( 2_${ik}$, icmax ) ) + ci21 = civ( ipivot( 2_${ik}$, icmax ) ) + ur12 = crv( ipivot( 3_${ik}$, icmax ) ) + ui12 = civ( ipivot( 3_${ik}$, icmax ) ) + cr22 = crv( ipivot( 4_${ik}$, icmax ) ) + ci22 = civ( ipivot( 4_${ik}$, icmax ) ) + if( icmax==1_${ik}$ .or. icmax==4_${ik}$ ) then ! code when off-diagonals of pivoted c are real if( abs( ur11 )>abs( ui11 ) ) then temp = ui11 / ur11 - ur11r = one / ( ur11*( one+temp**2 ) ) + ur11r = one / ( ur11*( one+temp**2_${ik}$ ) ) ui11r = -temp*ur11r else temp = ur11 / ui11 - ui11r = -one / ( ui11*( one+temp**2 ) ) + ui11r = -one / ( ui11*( one+temp**2_${ik}$ ) ) ur11r = -temp*ui11r end if lr21 = cr21*ur11r @@ -49367,18 +49369,18 @@ module stdlib_linalg_lapack_s if( u22abs overflow if( xnorm>one .and. cmax>one ) then if( xnorm>bignum / cmax ) then temp = cmax / bignum - x( 1, 1 ) = temp*x( 1, 1 ) - x( 2, 1 ) = temp*x( 2, 1 ) - x( 1, 2 ) = temp*x( 1, 2 ) - x( 2, 2 ) = temp*x( 2, 2 ) + x( 1_${ik}$, 1_${ik}$ ) = temp*x( 1_${ik}$, 1_${ik}$ ) + x( 2_${ik}$, 1_${ik}$ ) = temp*x( 2_${ik}$, 1_${ik}$ ) + x( 1_${ik}$, 2_${ik}$ ) = temp*x( 1_${ik}$, 2_${ik}$ ) + x( 2_${ik}$, 2_${ik}$ ) = temp*x( 2_${ik}$, 2_${ik}$ ) xnorm = temp*xnorm scale = temp*scale end if @@ -49423,10 +49425,10 @@ module stdlib_linalg_lapack_s end if end if return - end subroutine stdlib_slaln2 + end subroutine stdlib${ii}$_slaln2 - pure subroutine stdlib_slals0( icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx,perm, givptr, & + pure subroutine stdlib${ii}$_slals0( icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx,perm, givptr, & !! SLALS0 applies back the multiplying factors of either the left or the !! right singular vector matrix of a diagonal matrix appended by a row !! to the right hand side matrix B in solving the least squares problem @@ -49452,12 +49454,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) :: givptr, icompq, k, ldb, ldbx, ldgcol, ldgnum, nl, nr, nrhs,& + integer(${ik}$), intent(in) :: givptr, icompq, k, ldb, ldbx, ldgcol, ldgnum, nl, nr, nrhs,& sqre - integer(ilp), intent(out) :: info + integer(${ik}$), intent(out) :: info real(sp), intent(in) :: c, s ! Array Arguments - integer(ilp), intent(in) :: givcol(ldgcol,*), perm(*) + integer(${ik}$), intent(in) :: givcol(ldgcol,*), perm(*) real(sp), intent(inout) :: b(ldb,*) real(sp), intent(out) :: bx(ldbx,*), work(*) real(sp), intent(in) :: difl(*), difr(ldgnum,*), givnum(ldgnum,*), poles(ldgnum,*), z(& @@ -49465,165 +49467,165 @@ module stdlib_linalg_lapack_s ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, m, n, nlp1 + integer(${ik}$) :: i, j, m, n, nlp1 real(sp) :: diflj, difrj, dj, dsigj, dsigjp, temp ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 - n = nl + nr + 1 - 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 - else if( nrhs<1 ) then - info = -5 + info = 0_${ik}$ + n = nl + nr + 1_${ik}$ + 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( nrhs<1_${ik}$ ) then + info = -5_${ik}$ else if( ldb=max(m,n,k))) then - call stdlib_sgemlqt( side, trans, m, n, k, mb, a, lda,t, ldt, c, ldc, work, info) + call stdlib${ii}$_sgemlqt( side, trans, m, n, k, mb, a, lda,t, ldt, c, ldc, work, info) return end if @@ -49703,85 +49705,85 @@ module stdlib_linalg_lapack_s ! multiply q to the last block of c kk = mod((m-k),(nb-k)) ctr = (m-k)/(nb-k) - if (kk>0) then + if (kk>0_${ik}$) then ii=m-kk+1 - call stdlib_stpmlqt('L','T',kk , n, k, 0, mb, a(1,ii), lda,t(1,ctr*k+1), ldt, c(& - 1,1), ldc,c(ii,1), ldc, work, info ) + call stdlib${ii}$_stpmlqt('L','T',kk , n, k, 0_${ik}$, mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1), ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) else ii=m+1 end if do i=ii-(nb-k),nb+1,-(nb-k) ! multiply q to the current block of c (1:m,i:i+nb) - ctr = ctr - 1 - call stdlib_stpmlqt('L','T',nb-k , n, k, 0,mb, a(1,i), lda,t(1,ctr*k+1),ldt, c(1,& - 1), ldc,c(i,1), ldc, work, info ) + ctr = ctr - 1_${ik}$ + call stdlib${ii}$_stpmlqt('L','T',nb-k , n, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$,ctr*k+1),ldt, c(1_${ik}$,& + 1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info ) end do ! multiply q to the first block of c (1:m,1:nb) - call stdlib_sgemlqt('L','T',nb , n, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_sgemlqt('L','T',nb , n, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (left.and.notran) then ! multiply q to the first block of c kk = mod((m-k),(nb-k)) ii=m-kk+1 - ctr = 1 - call stdlib_sgemlqt('L','N',nb , n, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + ctr = 1_${ik}$ + call stdlib${ii}$_sgemlqt('L','N',nb , n, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=nb+1,ii-nb+k,(nb-k) ! multiply q to the current block of c (i:i+nb,1:n) - call stdlib_stpmlqt('L','N',nb-k , n, k, 0,mb, a(1,i), lda,t(1,ctr * k+1), ldt, c(& - 1,1), ldc,c(i,1), ldc, work, info ) - ctr = ctr + 1 + call stdlib${ii}$_stpmlqt('L','N',nb-k , n, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$,ctr * k+1), ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info ) + ctr = ctr + 1_${ik}$ end do if(ii<=m) then ! multiply q to the last block of c - call stdlib_stpmlqt('L','N',kk , n, k, 0, mb, a(1,ii), lda,t(1,ctr*k+1), ldt, c(1,& - 1), ldc,c(ii,1), ldc, work, info ) + call stdlib${ii}$_stpmlqt('L','N',kk , n, k, 0_${ik}$, mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1), ldt, c(1_${ik}$,& + 1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) end if else if(right.and.notran) then ! multiply q to the last block of c kk = mod((n-k),(nb-k)) ctr = (n-k)/(nb-k) - if (kk>0) then + if (kk>0_${ik}$) then ii=n-kk+1 - call stdlib_stpmlqt('R','N',m , kk, k, 0, mb, a(1, ii), lda,t(1,ctr*k+1), ldt, c(& - 1,1), ldc,c(1,ii), ldc, work, info ) + call stdlib${ii}$_stpmlqt('R','N',m , kk, k, 0_${ik}$, mb, a(1_${ik}$, ii), lda,t(1_${ik}$,ctr*k+1), ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info ) else ii=n+1 end if do i=ii-(nb-k),nb+1,-(nb-k) ! multiply q to the current block of c (1:m,i:i+mb) - ctr = ctr - 1 - call stdlib_stpmlqt('R','N', m, nb-k, k, 0, mb, a(1, i), lda,t(1,ctr*k+1), ldt, & - c(1,1), ldc,c(1,i), ldc, work, info ) + ctr = ctr - 1_${ik}$ + call stdlib${ii}$_stpmlqt('R','N', m, nb-k, k, 0_${ik}$, mb, a(1_${ik}$, i), lda,t(1_${ik}$,ctr*k+1), ldt, & + c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info ) end do ! multiply q to the first block of c (1:m,1:mb) - call stdlib_sgemlqt('R','N',m , nb, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_sgemlqt('R','N',m , nb, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (right.and.tran) then ! multiply q to the first block of c kk = mod((n-k),(nb-k)) ii=n-kk+1 - ctr = 1 - call stdlib_sgemlqt('R','T',m , nb, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + ctr = 1_${ik}$ + call stdlib${ii}$_sgemlqt('R','T',m , nb, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=nb+1,ii-nb+k,(nb-k) ! multiply q to the current block of c (1:m,i:i+mb) - call stdlib_stpmlqt('R','T',m , nb-k, k, 0,mb, a(1,i), lda,t(1, ctr*k+1), ldt, c(1,& - 1), ldc,c(1,i), ldc, work, info ) - ctr = ctr + 1 + call stdlib${ii}$_stpmlqt('R','T',m , nb-k, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$, ctr*k+1), ldt, c(1_${ik}$,& + 1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info ) + ctr = ctr + 1_${ik}$ end do if(ii<=n) then ! multiply q to the last block of c - call stdlib_stpmlqt('R','T',m , kk, k, 0,mb, a(1,ii), lda,t(1,ctr*k+1),ldt, c(1,1),& - ldc,c(1,ii), ldc, work, info ) + call stdlib${ii}$_stpmlqt('R','T',m , kk, k, 0_${ik}$,mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1),ldt, c(1_${ik}$,1_${ik}$),& + ldc,c(1_${ik}$,ii), ldc, work, info ) end if end if - work(1) = lw + work(1_${ik}$) = lw return - end subroutine stdlib_slamswlq + end subroutine stdlib${ii}$_slamswlq - pure subroutine stdlib_slamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & + pure subroutine stdlib${ii}$_slamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & !! SLAMTSQR overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -49795,8 +49797,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) :: lda, m, n, k, mb, nb, ldt, lwork, ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, k, mb, nb, ldt, lwork, ldc ! Array Arguments real(sp), intent(in) :: a(lda,*), t(ldt,*) real(sp), intent(out) :: work(*) @@ -49804,11 +49806,11 @@ module stdlib_linalg_lapack_s ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran, lquery - integer(ilp) :: i, ii, kk, lw, ctr, q + integer(${ik}$) :: i, ii, kk, lw, ctr, q ! External Subroutines ! Executable Statements ! test the input arguments - lquery = lwork<0 + lquery = lwork<0_${ik}$ notran = stdlib_lsame( trans, 'N' ) tran = stdlib_lsame( trans, 'T' ) left = stdlib_lsame( side, 'L' ) @@ -49820,44 +49822,44 @@ module stdlib_linalg_lapack_s lw = mb * nb q = n end if - info = 0 + info = 0_${ik}$ if( .not.left .and. .not.right ) then - info = -1 + info = -1_${ik}$ else if( .not.tran .and. .not.notran ) then - info = -2 + info = -2_${ik}$ else if( m=max(m,n,k))) then - call stdlib_sgemqrt( side, trans, m, n, k, nb, a, lda,t, ldt, c, ldc, work, info) + call stdlib${ii}$_sgemqrt( side, trans, m, n, k, nb, a, lda,t, ldt, c, ldc, work, info) return end if @@ -49865,85 +49867,85 @@ module stdlib_linalg_lapack_s ! multiply q to the last block of c kk = mod((m-k),(mb-k)) ctr = (m-k)/(mb-k) - if (kk>0) then + if (kk>0_${ik}$) then ii=m-kk+1 - call stdlib_stpmqrt('L','N',kk , n, k, 0, nb, a(ii,1), lda,t(1,ctr*k+1),ldt , c(1,& - 1), ldc,c(ii,1), ldc, work, info ) + call stdlib${ii}$_stpmqrt('L','N',kk , n, k, 0_${ik}$, nb, a(ii,1_${ik}$), lda,t(1_${ik}$,ctr*k+1),ldt , c(1_${ik}$,& + 1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) else ii=m+1 end if do i=ii-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) - ctr = ctr - 1 - call stdlib_stpmqrt('L','N',mb-k , n, k, 0,nb, a(i,1), lda,t(1, ctr * k + 1), ldt,& - c(1,1), ldc,c(i,1), ldc, work, info ) + ctr = ctr - 1_${ik}$ + call stdlib${ii}$_stpmqrt('L','N',mb-k , n, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$), ldt,& + c(1_${ik}$,1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info ) end do ! multiply q to the first block of c (1:mb,1:n) - call stdlib_sgemqrt('L','N',mb , n, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_sgemqrt('L','N',mb , n, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (left.and.tran) then ! multiply q to the first block of c kk = mod((m-k),(mb-k)) ii=m-kk+1 - ctr = 1 - call stdlib_sgemqrt('L','T',mb , n, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + ctr = 1_${ik}$ + call stdlib${ii}$_sgemqrt('L','T',mb , n, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) - call stdlib_stpmqrt('L','T',mb-k , n, k, 0,nb, a(i,1), lda,t(1,ctr * k + 1),ldt, c(& - 1,1), ldc,c(i,1), ldc, work, info ) - ctr = ctr + 1 + call stdlib${ii}$_stpmqrt('L','T',mb-k , n, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$,ctr * k + 1_${ik}$),ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info ) + ctr = ctr + 1_${ik}$ end do if(ii<=m) then ! multiply q to the last block of c - call stdlib_stpmqrt('L','T',kk , n, k, 0,nb, a(ii,1), lda,t(1, ctr * k + 1), ldt, & - c(1,1), ldc,c(ii,1), ldc, work, info ) + call stdlib${ii}$_stpmqrt('L','T',kk , n, k, 0_${ik}$,nb, a(ii,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$), ldt, & + c(1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) end if else if(right.and.tran) then ! multiply q to the last block of c kk = mod((n-k),(mb-k)) ctr = (n-k)/(mb-k) - if (kk>0) then + if (kk>0_${ik}$) then ii=n-kk+1 - call stdlib_stpmqrt('R','T',m , kk, k, 0, nb, a(ii,1), lda,t(1, ctr * k + 1), & - ldt, c(1,1), ldc,c(1,ii), ldc, work, info ) + call stdlib${ii}$_stpmqrt('R','T',m , kk, k, 0_${ik}$, nb, a(ii,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$), & + ldt, c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info ) else ii=n+1 end if do i=ii-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) - ctr = ctr - 1 - call stdlib_stpmqrt('R','T',m , mb-k, k, 0,nb, a(i,1), lda,t(1, ctr * k + 1), & - ldt, c(1,1), ldc,c(1,i), ldc, work, info ) + ctr = ctr - 1_${ik}$ + call stdlib${ii}$_stpmqrt('R','T',m , mb-k, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$), & + ldt, c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info ) end do ! multiply q to the first block of c (1:m,1:mb) - call stdlib_sgemqrt('R','T',m , mb, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_sgemqrt('R','T',m , mb, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (right.and.notran) then ! multiply q to the first block of c kk = mod((n-k),(mb-k)) ii=n-kk+1 - ctr = 1 - call stdlib_sgemqrt('R','N', m, mb , k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + ctr = 1_${ik}$ + call stdlib${ii}$_sgemqrt('R','N', m, mb , k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) - call stdlib_stpmqrt('R','N', m, mb-k, k, 0,nb, a(i,1), lda,t(1, ctr * k + 1),ldt, & - c(1,1), ldc,c(1,i), ldc, work, info ) - ctr = ctr + 1 + call stdlib${ii}$_stpmqrt('R','N', m, mb-k, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$),ldt, & + c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info ) + ctr = ctr + 1_${ik}$ end do if(ii<=n) then ! multiply q to the last block of c - call stdlib_stpmqrt('R','N', m, kk , k, 0,nb, a(ii,1), lda,t(1, ctr * k + 1),ldt, & - c(1,1), ldc,c(1,ii), ldc, work, info ) + call stdlib${ii}$_stpmqrt('R','N', m, kk , k, 0_${ik}$,nb, a(ii,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$),ldt, & + c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info ) end if end if - work(1) = lw + work(1_${ik}$) = lw return - end subroutine stdlib_slamtsqr + end subroutine stdlib${ii}$_slamtsqr - pure subroutine stdlib_slanv2( a, b, c, d, rt1r, rt1i, rt2r, rt2i, cs, sn ) + pure subroutine stdlib${ii}$_slanv2( a, b, c, d, rt1r, rt1i, rt2r, rt2i, cs, sn ) !! SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric !! matrix in standard form: !! [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ] @@ -49966,14 +49968,14 @@ module stdlib_linalg_lapack_s ! Local Scalars real(sp) :: aa, bb, bcmax, bcmis, cc, cs1, dd, eps, p, sab, sac, scale, sigma, sn1, & tau, temp, z, safmin, safmn2, safmx2 - integer(ilp) :: count + integer(${ik}$) :: count ! Intrinsic Functions intrinsic :: abs,max,min,sign,sqrt ! Executable Statements - safmin = stdlib_slamch( 'S' ) - eps = stdlib_slamch( 'P' ) - safmn2 = stdlib_slamch( 'B' )**int( log( safmin / eps ) /log( stdlib_slamch( 'B' ) ) / & - two,KIND=ilp) + safmin = stdlib${ii}$_slamch( 'S' ) + eps = stdlib${ii}$_slamch( 'P' ) + safmn2 = stdlib${ii}$_slamch( 'B' )**int( log( safmin / eps ) /log( stdlib${ii}$_slamch( 'B' ) ) / & + two,KIND=${ik}$) safmx2 = one / safmn2 if( c==zero ) then cs = one @@ -50005,7 +50007,7 @@ module stdlib_linalg_lapack_s a = d + z d = d - ( bcmax / z )*bcmis ! compute b and the rotation matrix - tau = stdlib_slapy2( c, z ) + tau = stdlib${ii}$_slapy2( c, z ) cs = z / tau sn = c / tau b = b - c @@ -50013,10 +50015,10 @@ module stdlib_linalg_lapack_s else ! complex eigenvalues, or real(almost,KIND=sp) equal eigenvalues. ! make diagonal elements equal. - count = 0 + count = 0_${ik}$ sigma = b + c 10 continue - count = count + 1 + count = count + 1_${ik}$ scale = max( abs(temp), abs(sigma) ) if( scale>=safmx2 ) then sigma = sigma * safmn2 @@ -50029,7 +50031,7 @@ module stdlib_linalg_lapack_s if (count <= 20)goto 10 end if p = half*temp - tau = stdlib_slapy2( sigma, temp ) + tau = stdlib${ii}$_slapy2( sigma, temp ) cs = sqrt( half*( one+abs( sigma ) / tau ) ) sn = -( p / ( tau*cs ) )*sign( one, sigma ) ! compute [ aa bb ] = [ a b ] [ cs -sn ] @@ -50086,10 +50088,10 @@ module stdlib_linalg_lapack_s rt2i = -rt1i end if return - end subroutine stdlib_slanv2 + end subroutine stdlib${ii}$_slanv2 - pure subroutine stdlib_slapll( n, x, incx, y, incy, ssmin ) + pure subroutine stdlib${ii}$_slapll( n, x, incx, y, incy, ssmin ) !! Given two column vectors X and Y, let !! A = ( X Y ). !! The subroutine first computes the QR factorization of A = Q*R, @@ -50100,7 +50102,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) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n real(sp), intent(out) :: ssmin ! Array Arguments real(sp), intent(inout) :: x(*), y(*) @@ -50110,26 +50112,26 @@ module stdlib_linalg_lapack_s real(sp) :: a11, a12, a22, c, ssmax, tau ! Executable Statements ! quick return if possible - if( n<=1 ) then + if( n<=1_${ik}$ ) then ssmin = zero return end if ! compute the qr factorization of the n-by-2 matrix ( x y ) - call stdlib_slarfg( n, x( 1 ), x( 1+incx ), incx, tau ) - a11 = x( 1 ) - x( 1 ) = one - c = -tau*stdlib_sdot( n, x, incx, y, incy ) - call stdlib_saxpy( n, c, x, incx, y, incy ) - call stdlib_slarfg( n-1, y( 1+incy ), y( 1+2*incy ), incy, tau ) - a12 = y( 1 ) - a22 = y( 1+incy ) + call stdlib${ii}$_slarfg( n, x( 1_${ik}$ ), x( 1_${ik}$+incx ), incx, tau ) + a11 = x( 1_${ik}$ ) + x( 1_${ik}$ ) = one + c = -tau*stdlib${ii}$_sdot( n, x, incx, y, incy ) + call stdlib${ii}$_saxpy( n, c, x, incx, y, incy ) + call stdlib${ii}$_slarfg( n-1, y( 1_${ik}$+incy ), y( 1_${ik}$+2*incy ), incy, tau ) + a12 = y( 1_${ik}$ ) + a22 = y( 1_${ik}$+incy ) ! compute the svd of 2-by-2 upper triangular matrix. - call stdlib_slas2( a11, a12, a22, ssmin, ssmax ) + call stdlib${ii}$_slas2( a11, a12, a22, ssmin, ssmax ) return - end subroutine stdlib_slapll + end subroutine stdlib${ii}$_slapll - pure subroutine stdlib_slaqp2( m, n, offset, a, lda, jpvt, tau, vn1, vn2,work ) + pure subroutine stdlib${ii}$_slaqp2( m, n, offset, a, lda, jpvt, tau, vn1, vn2,work ) !! SLAQP2 computes a QR factorization with column pivoting of !! the block A(OFFSET+1:M,1:N). !! The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. @@ -50137,28 +50139,28 @@ 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, m, n, offset + integer(${ik}$), intent(in) :: lda, m, n, offset ! Array Arguments - integer(ilp), intent(inout) :: jpvt(*) + integer(${ik}$), intent(inout) :: jpvt(*) real(sp), intent(inout) :: a(lda,*), vn1(*), vn2(*) real(sp), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, itemp, j, mn, offpi, pvt + integer(${ik}$) :: i, itemp, j, mn, offpi, pvt real(sp) :: aii, temp, temp2, tol3z ! Intrinsic Functions intrinsic :: abs,max,min,sqrt ! Executable Statements mn = min( m-offset, n ) - tol3z = sqrt(stdlib_slamch('EPSILON')) + tol3z = sqrt(stdlib${ii}$_slamch('EPSILON')) ! compute factorization. loop_20: do i = 1, mn offpi = offset + i ! determine ith pivot column and swap if necessary. - pvt = ( i-1 ) + stdlib_isamax( n-i+1, vn1( i ), 1 ) + pvt = ( i-1 ) + stdlib${ii}$_isamax( n-i+1, vn1( i ), 1_${ik}$ ) if( pvt/=i ) then - call stdlib_sswap( m, a( 1, pvt ), 1, a( 1, i ), 1 ) + call stdlib${ii}$_sswap( m, a( 1_${ik}$, pvt ), 1_${ik}$, a( 1_${ik}$, i ), 1_${ik}$ ) itemp = jpvt( pvt ) jpvt( pvt ) = jpvt( i ) jpvt( i ) = itemp @@ -50167,17 +50169,17 @@ module stdlib_linalg_lapack_s end if ! generate elementary reflector h(i). if( offpi1 ) then - call stdlib_sgemv( 'NO TRANSPOSE', m-rk+1, k-1, -one, a( rk, 1 ),lda, f( k, 1 ), & - ldf, one, a( rk, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', m-rk+1, k-1, -one, a( rk, 1_${ik}$ ),lda, f( k, 1_${ik}$ ), & + ldf, one, a( rk, k ), 1_${ik}$ ) end if ! generate elementary reflector h(k). if( rk1 ) then - call stdlib_sgemv( 'TRANSPOSE', m-rk+1, k-1, -tau( k ), a( rk, 1 ),lda, a( rk, k & - ), 1, zero, auxv( 1 ), 1 ) - call stdlib_sgemv( 'NO TRANSPOSE', n, k-1, one, f( 1, 1 ), ldf,auxv( 1 ), 1, one,& - f( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_sgemv( 'TRANSPOSE', m-rk+1, k-1, -tau( k ), a( rk, 1_${ik}$ ),lda, a( rk, k & + ), 1_${ik}$, zero, auxv( 1_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n, k-1, one, f( 1_${ik}$, 1_${ik}$ ), ldf,auxv( 1_${ik}$ ), 1_${ik}$, one,& + f( 1_${ik}$, k ), 1_${ik}$ ) end if ! update the current row of a: ! a(rk,k+1:n) := a(rk,k+1:n) - a(rk,1:k)*f(k+1:n,1:k)**t. if( k0 ) then - itemp = nint( vn2( lsticc ),KIND=ilp) - vn1( lsticc ) = stdlib_snrm2( m-rk, a( rk+1, lsticc ), 1 ) + if( lsticc>0_${ik}$ ) then + itemp = nint( vn2( lsticc ),KIND=${ik}$) + vn1( lsticc ) = stdlib${ii}$_snrm2( m-rk, a( rk+1, lsticc ), 1_${ik}$ ) ! note: the computation of vn1( lsticc ) relies on the fact that - ! stdlib_snrm2 does not fail on vectors with norm below the value of - ! sqrt(stdlib_dlamch('s')) + ! stdlib${ii}$_snrm2 does not fail on vectors with norm below the value of + ! sqrt(stdlib${ii}$_dlamch('s')) vn2( lsticc ) = vn1( lsticc ) lsticc = itemp go to 40 end if return - end subroutine stdlib_slaqps + end subroutine stdlib${ii}$_slaqps - pure subroutine stdlib_slaqr5( wantt, wantz, kacc22, n, ktop, kbot, nshfts,sr, si, h, ldh, & + pure subroutine stdlib${ii}$_slaqr5( wantt, wantz, kacc22, n, ktop, kbot, nshfts,sr, si, h, ldh, & !! SLAQR5 , called by SLAQR0, performs a !! single small-bulge multi-shift QR sweep. iloz, ihiz, z, ldz, v, ldv, u,ldu, nv, wv, ldwv, nh, wh, ldwh ) @@ -50348,7 +50350,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) :: ihiz, iloz, kacc22, kbot, ktop, ldh, ldu, ldv, ldwh, ldwv, & + integer(${ik}$), intent(in) :: ihiz, iloz, kacc22, kbot, ktop, ldh, ldu, ldv, ldwh, ldwv, & ldz, n, nh, nshfts, nv logical(lk), intent(in) :: wantt, wantz ! Array Arguments @@ -50359,13 +50361,13 @@ module stdlib_linalg_lapack_s ! Local Scalars real(sp) :: alpha, beta, h11, h12, h21, h22, refsum, safmax, safmin, scl, smlnum, swap,& tst1, tst2, ulp - integer(ilp) :: i, i2, i4, incol, j, jbot, jcol, jlen, jrow, jtop, k, k1, kdu, kms, & + integer(${ik}$) :: i, i2, i4, incol, j, jbot, jcol, jlen, jrow, jtop, k, k1, kdu, kms, & krcol, m, m22, mbot, mtop, nbmps, ndcol, ns, nu logical(lk) :: accum, bmp22 ! Intrinsic Functions intrinsic :: abs,max,min,mod,real ! Local Arrays - real(sp) :: vt(3) + real(sp) :: vt(3_${ik}$) ! Executable Statements ! ==== if there are no shifts, then there is nothing to do. ==== if( nshfts<2 )return @@ -50392,34 +50394,34 @@ 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 = nshfts - mod( nshfts, 2 ) + ns = nshfts - mod( nshfts, 2_${ik}$ ) ! ==== machine constants for deflation ==== - safmin = stdlib_slamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) safmax = one / safmin - call stdlib_slabad( safmin, safmax ) - ulp = stdlib_slamch( 'PRECISION' ) + call stdlib${ii}$_slabad( safmin, safmax ) + ulp = stdlib${ii}$_slamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=sp) / ulp ) ! ==== use accumulated reflections to update far-from-diagonal ! . entries ? ==== - accum = ( kacc22==1 ) .or. ( kacc22==2 ) + accum = ( kacc22==1_${ik}$ ) .or. ( kacc22==2_${ik}$ ) ! ==== clear trash ==== if( ktop+2<=kbot )h( ktop+2, ktop ) = zero ! ==== nbmps = number of 2-shift bulges in the chain ==== - nbmps = ns / 2 + nbmps = ns / 2_${ik}$ ! ==== kdu = width of slab ==== - kdu = 4*nbmps + kdu = 4_${ik}$*nbmps ! ==== create and chase chains of nbmps bulges ==== loop_180: do incol = ktop - 2*nbmps + 1, kbot - 2, 2*nbmps ! jtop = index from which updates from the right start. if( accum ) then jtop = max( ktop, incol ) else if( wantt ) then - jtop = 1 + jtop = 1_${ik}$ else jtop = ktop end if ndcol = incol + kdu - if( accum )call stdlib_slaset( 'ALL', kdu, kdu, zero, one, u, ldu ) + if( accum )call stdlib${ii}$_slaset( 'ALL', kdu, kdu, zero, one, u, ldu ) ! ==== near-the-diagonal bulge chase. the following loop ! . performs the near-the-diagonal part of a small bulge ! . multi-shift qr sweep. each 4*nbmps column diagonal @@ -50438,34 +50440,34 @@ module stdlib_linalg_lapack_s ! . (if any) must wait until the active bulges have moved ! . down the diagonal to make room. the phantom matrix ! . paradigm described above helps keep track. ==== - mtop = max( 1, ( ktop-krcol ) / 2+1 ) - mbot = min( nbmps, ( kbot-krcol-1 ) / 2 ) - m22 = mbot + 1 + mtop = max( 1_${ik}$, ( ktop-krcol ) / 2_${ik}$+1 ) + mbot = min( nbmps, ( kbot-krcol-1 ) / 2_${ik}$ ) + m22 = mbot + 1_${ik}$ bmp22 = ( mbotulp*( abs( & + call stdlib${ii}$_slaqr1( 3_${ik}$, h( k+1, k+1 ), ldh, sr( 2_${ik}$*m-1 ),si( 2_${ik}$*m-1 ), sr( & + 2_${ik}$*m ), si( 2_${ik}$*m ),vt ) + alpha = vt( 1_${ik}$ ) + call stdlib${ii}$_slarfg( 3_${ik}$, alpha, vt( 2_${ik}$ ), 1_${ik}$, vt( 1_${ik}$ ) ) + refsum = vt( 1_${ik}$ )*( h( k+1, k )+vt( 2_${ik}$ )*h( k+2, k ) ) + if( abs( h( k+2, k )-refsum*vt( 2_${ik}$ ) )+abs( refsum*vt( 3_${ik}$ ) )>ulp*( abs( & h( k, k ) )+abs( h( k+1,k+1 ) )+abs( h( k+2, k+2 ) ) ) ) then ! ==== starting a new bulge here would ! . create non-negligible fill. use @@ -50591,9 +50593,9 @@ module stdlib_linalg_lapack_s h( k+1, k ) = h( k+1, k ) - refsum h( k+2, k ) = zero h( k+3, k ) = zero - v( 1, m ) = vt( 1 ) - v( 2, m ) = vt( 2 ) - v( 3, m ) = vt( 3 ) + v( 1_${ik}$, m ) = vt( 1_${ik}$ ) + v( 2_${ik}$, m ) = vt( 2_${ik}$ ) + v( 3_${ik}$, m ) = vt( 3_${ik}$ ) end if end if end if @@ -50603,19 +50605,19 @@ module stdlib_linalg_lapack_s ! . deflation check. we still delay most of the ! . updates from the left for efficiency. ==== do j = jtop, min( kbot, k+3 ) - refsum = v( 1, m )*( h( j, k+1 )+v( 2, m )*h( j, k+2 )+v( 3, m )*h( j, k+3 & + refsum = v( 1_${ik}$, m )*( h( j, k+1 )+v( 2_${ik}$, m )*h( j, k+2 )+v( 3_${ik}$, m )*h( j, k+3 & ) ) h( j, k+1 ) = h( j, k+1 ) - refsum - h( j, k+2 ) = h( j, k+2 ) - refsum*v( 2, m ) - h( j, k+3 ) = h( j, k+3 ) - refsum*v( 3, m ) + h( j, k+2 ) = h( j, k+2 ) - refsum*v( 2_${ik}$, m ) + h( j, k+3 ) = h( j, k+3 ) - refsum*v( 3_${ik}$, m ) end do ! ==== perform update from left for subsequent ! . column. ==== - refsum = v( 1, m )*( h( k+1, k+1 )+v( 2, m )*h( k+2, k+1 )+v( 3, m )*h( k+3, & + refsum = v( 1_${ik}$, m )*( h( k+1, k+1 )+v( 2_${ik}$, m )*h( k+2, k+1 )+v( 3_${ik}$, m )*h( k+3, & k+1 ) ) h( k+1, k+1 ) = h( k+1, k+1 ) - refsum - h( k+2, k+1 ) = h( k+2, k+1 ) - refsum*v( 2, m ) - h( k+3, k+1 ) = h( k+3, k+1 ) - refsum*v( 3, m ) + h( k+2, k+1 ) = h( k+2, k+1 ) - refsum*v( 2_${ik}$, m ) + h( k+3, k+1 ) = h( k+3, k+1 ) - refsum*v( 3_${ik}$, m ) ! ==== the following convergence test requires that ! . the tradition small-compared-to-nearby-diagonals ! . criterion and the ahues @@ -50658,13 +50660,13 @@ module stdlib_linalg_lapack_s jbot = kbot end if do m = mbot, mtop, -1 - k = krcol + 2*( m-1 ) + k = krcol + 2_${ik}$*( m-1 ) do j = max( ktop, krcol + 2*m ), jbot - refsum = v( 1, m )*( h( k+1, j )+v( 2, m )*h( k+2, j )+v( 3, m )*h( k+3, j & + refsum = v( 1_${ik}$, m )*( h( k+1, j )+v( 2_${ik}$, m )*h( k+2, j )+v( 3_${ik}$, m )*h( k+3, j & ) ) h( k+1, j ) = h( k+1, j ) - refsum - h( k+2, j ) = h( k+2, j ) - refsum*v( 2, m ) - h( k+3, j ) = h( k+3, j ) - refsum*v( 3, m ) + h( k+2, j ) = h( k+2, j ) - refsum*v( 2_${ik}$, m ) + h( k+3, j ) = h( k+3, j ) - refsum*v( 3_${ik}$, m ) end do end do ! ==== accumulate orthogonal transformations. ==== @@ -50673,17 +50675,17 @@ module stdlib_linalg_lapack_s ! . with an efficient matrix-matrix ! . multiply.) ==== do m = mbot, mtop, -1 - k = krcol + 2*( m-1 ) + k = krcol + 2_${ik}$*( m-1 ) kms = k - incol - i2 = max( 1, ktop-incol ) - i2 = max( i2, kms-(krcol-incol)+1 ) - i4 = min( kdu, krcol + 2*( mbot-1 ) - incol + 5 ) + i2 = max( 1_${ik}$, ktop-incol ) + i2 = max( i2, kms-(krcol-incol)+1_${ik}$ ) + i4 = min( kdu, krcol + 2_${ik}$*( mbot-1 ) - incol + 5_${ik}$ ) do j = i2, i4 - refsum = v( 1, m )*( u( j, kms+1 )+v( 2, m )*u( j, kms+2 )+v( 3, m )*u( & + refsum = v( 1_${ik}$, m )*( u( j, kms+1 )+v( 2_${ik}$, m )*u( j, kms+2 )+v( 3_${ik}$, m )*u( & j, kms+3 ) ) u( j, kms+1 ) = u( j, kms+1 ) - refsum - u( j, kms+2 ) = u( j, kms+2 ) - refsum*v( 2, m ) - u( j, kms+3 ) = u( j, kms+3 ) - refsum*v( 3, m ) + u( j, kms+2 ) = u( j, kms+2 ) - refsum*v( 2_${ik}$, m ) + u( j, kms+3 ) = u( j, kms+3 ) - refsum*v( 3_${ik}$, m ) end do end do else if( wantz ) then @@ -50691,13 +50693,13 @@ module stdlib_linalg_lapack_s ! . now by multiplying by reflections ! . from the right. ==== do m = mbot, mtop, -1 - k = krcol + 2*( m-1 ) + k = krcol + 2_${ik}$*( m-1 ) do j = iloz, ihiz - refsum = v( 1, m )*( z( j, k+1 )+v( 2, m )*z( j, k+2 )+v( 3, m )*z( j, & + refsum = v( 1_${ik}$, m )*( z( j, k+1 )+v( 2_${ik}$, m )*z( j, k+2 )+v( 3_${ik}$, m )*z( j, & k+3 ) ) z( j, k+1 ) = z( j, k+1 ) - refsum - z( j, k+2 ) = z( j, k+2 ) - refsum*v( 2, m ) - z( j, k+3 ) = z( j, k+3 ) - refsum*v( 3, m ) + z( j, k+2 ) = z( j, k+2 ) - refsum*v( 2_${ik}$, m ) + z( j, k+3 ) = z( j, k+3 ) - refsum*v( 3_${ik}$, m ) end do end do end if @@ -50708,46 +50710,46 @@ module stdlib_linalg_lapack_s ! . well. ==== if( accum ) then if( wantt ) then - jtop = 1 + jtop = 1_${ik}$ jbot = n else jtop = ktop jbot = kbot end if - k1 = max( 1, ktop-incol ) - nu = ( kdu-max( 0, ndcol-kbot ) ) - k1 + 1 + k1 = max( 1_${ik}$, ktop-incol ) + nu = ( kdu-max( 0_${ik}$, ndcol-kbot ) ) - k1 + 1_${ik}$ ! ==== horizontal multiply ==== do jcol = min( ndcol, kbot ) + 1, jbot, nh jlen = min( nh, jbot-jcol+1 ) - call stdlib_sgemm( 'C', 'N', nu, jlen, nu, one, u( k1, k1 ),ldu, h( incol+k1, & + call stdlib${ii}$_sgemm( 'C', 'N', nu, jlen, nu, one, u( k1, k1 ),ldu, h( incol+k1, & jcol ), ldh, zero, wh,ldwh ) - call stdlib_slacpy( 'ALL', nu, jlen, wh, ldwh,h( incol+k1, jcol ), ldh ) + call stdlib${ii}$_slacpy( 'ALL', nu, jlen, wh, ldwh,h( incol+k1, jcol ), ldh ) end do ! ==== vertical multiply ==== do jrow = jtop, max( ktop, incol ) - 1, nv jlen = min( nv, max( ktop, incol )-jrow ) - call stdlib_sgemm( 'N', 'N', jlen, nu, nu, one,h( jrow, incol+k1 ), ldh, u( & + call stdlib${ii}$_sgemm( 'N', 'N', jlen, nu, nu, one,h( jrow, incol+k1 ), ldh, u( & k1, k1 ),ldu, zero, wv, ldwv ) - call stdlib_slacpy( 'ALL', jlen, nu, wv, ldwv,h( jrow, incol+k1 ), ldh ) + call stdlib${ii}$_slacpy( 'ALL', jlen, nu, wv, ldwv,h( jrow, incol+k1 ), ldh ) end do ! ==== z multiply (also vertical) ==== if( wantz ) then do jrow = iloz, ihiz, nv jlen = min( nv, ihiz-jrow+1 ) - call stdlib_sgemm( 'N', 'N', jlen, nu, nu, one,z( jrow, incol+k1 ), ldz, u(& + call stdlib${ii}$_sgemm( 'N', 'N', jlen, nu, nu, one,z( jrow, incol+k1 ), ldz, u(& k1, k1 ),ldu, zero, wv, ldwv ) - call stdlib_slacpy( 'ALL', jlen, nu, wv, ldwv,z( jrow, incol+k1 ), ldz ) + call stdlib${ii}$_slacpy( 'ALL', jlen, nu, wv, ldwv,z( jrow, incol+k1 ), ldz ) end do end if end if end do loop_180 - end subroutine stdlib_slaqr5 + end subroutine stdlib${ii}$_slaqr5 - subroutine stdlib_slaqtr( ltran, lreal, n, t, ldt, b, w, scale, x, work,info ) + subroutine stdlib${ii}$_slaqtr( ltran, lreal, n, t, ldt, b, w, scale, x, work,info ) !! SLAQTR solves the real quasi-triangular system !! op(T)*p = scale*c, if LREAL = .TRUE. !! or the complex quasi-triangular systems @@ -50771,8 +50773,8 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: lreal, ltran - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldt, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldt, n real(sp), intent(out) :: scale real(sp), intent(in) :: w ! Array Arguments @@ -50783,47 +50785,47 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: notran - integer(ilp) :: i, ierr, j, j1, j2, jnext, k, n1, n2 + integer(${ik}$) :: i, ierr, j, j1, j2, jnext, k, n1, n2 real(sp) :: bignum, eps, rec, scaloc, si, smin, sminw, smlnum, sr, tjj, tmp, xj, xmax, & xnorm, z ! Local Arrays - real(sp) :: d(2,2), v(2,2) + real(sp) :: d(2_${ik}$,2_${ik}$), v(2_${ik}$,2_${ik}$) ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements ! do not test the input parameters for errors notran = .not.ltran - 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 - xnorm = stdlib_slange( 'M', n, n, t, ldt, d ) - if( .not.lreal )xnorm = max( xnorm, abs( w ), stdlib_slange( 'M', n, 1, b, n, d ) ) + xnorm = stdlib${ii}$_slange( 'M', n, n, t, ldt, d ) + if( .not.lreal )xnorm = max( xnorm, abs( w ), stdlib${ii}$_slange( 'M', n, 1_${ik}$, b, n, d ) ) smin = max( smlnum, eps*xnorm ) ! compute 1-norm of each column of strictly upper triangular ! part of t to control overflow in triangular solver. - work( 1 ) = zero + work( 1_${ik}$ ) = zero do j = 2, n - work( j ) = stdlib_sasum( j-1, t( 1, j ), 1 ) + work( j ) = stdlib${ii}$_sasum( j-1, t( 1_${ik}$, j ), 1_${ik}$ ) end do if( .not.lreal ) then do i = 2, n work( i ) = work( i ) + abs( b( i ) ) end do end if - n2 = 2*n + n2 = 2_${ik}$*n n1 = n if( .not.lreal )n1 = n2 - k = stdlib_isamax( n1, x, 1 ) + k = stdlib${ii}$_isamax( n1, x, 1_${ik}$ ) xmax = abs( x( k ) ) scale = one if( xmax>bignum ) then scale = bignum / xmax - call stdlib_sscal( n1, scale, x, 1 ) + call stdlib${ii}$_sscal( n1, scale, x, 1_${ik}$ ) xmax = bignum end if if( lreal ) then @@ -50834,11 +50836,11 @@ module stdlib_linalg_lapack_s if( j>jnext )cycle loop_30 j1 = j j2 = j - jnext = j - 1 - if( j>1 ) then + jnext = j - 1_${ik}$ + if( j>1_${ik}$ ) then if( t( j, j-1 )/=zero ) then - j1 = j - 1 - jnext = j - 2 + j1 = j - 1_${ik}$ + jnext = j - 2_${ik}$ end if end if if( j1==j2 ) then @@ -50851,13 +50853,13 @@ module stdlib_linalg_lapack_s if( tjjbignum*tjj ) then 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 @@ -50869,61 +50871,61 @@ module stdlib_linalg_lapack_s if( xj>one ) then rec = one / xj if( work( j1 )>( bignum-xmax )*rec ) then - call stdlib_sscal( n, rec, x, 1 ) + call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ ) scale = scale*rec end if end if - if( j1>1 ) then - call stdlib_saxpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 ) - k = stdlib_isamax( j1-1, x, 1 ) + if( j1>1_${ik}$ ) then + call stdlib${ii}$_saxpy( j1-1, -x( j1 ), t( 1_${ik}$, j1 ), 1_${ik}$, x, 1_${ik}$ ) + k = stdlib${ii}$_isamax( j1-1, x, 1_${ik}$ ) xmax = abs( x( k ) ) end if else ! meet 2 by 2 diagonal block ! call 2 by 2 linear system solve, to take ! care of possible overflow by scaling factor. - d( 1, 1 ) = x( j1 ) - d( 2, 1 ) = x( j2 ) - call stdlib_slaln2( .false., 2, 1, smin, one, t( j1, j1 ),ldt, one, one, d,& - 2, zero, zero, v, 2,scaloc, xnorm, ierr ) - if( ierr/=0 )info = 2 + d( 1_${ik}$, 1_${ik}$ ) = x( j1 ) + d( 2_${ik}$, 1_${ik}$ ) = x( j2 ) + call stdlib${ii}$_slaln2( .false., 2_${ik}$, 1_${ik}$, smin, one, t( j1, j1 ),ldt, one, one, d,& + 2_${ik}$, zero, zero, v, 2_${ik}$,scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 2_${ik}$ if( scaloc/=one ) then - call stdlib_sscal( n, scaloc, x, 1 ) + call stdlib${ii}$_sscal( n, scaloc, x, 1_${ik}$ ) scale = scale*scaloc end if - x( j1 ) = v( 1, 1 ) - x( j2 ) = v( 2, 1 ) + x( j1 ) = v( 1_${ik}$, 1_${ik}$ ) + x( j2 ) = v( 2_${ik}$, 1_${ik}$ ) ! scale v(1,1) (= x(j1)) and/or v(2,1) (=x(j2)) ! to avoid overflow in updating right-hand side. - xj = max( abs( v( 1, 1 ) ), abs( v( 2, 1 ) ) ) + xj = max( abs( v( 1_${ik}$, 1_${ik}$ ) ), abs( v( 2_${ik}$, 1_${ik}$ ) ) ) if( xj>one ) then rec = one / xj if( max( work( j1 ), work( j2 ) )>( bignum-xmax )*rec ) then - call stdlib_sscal( n, rec, x, 1 ) + call stdlib${ii}$_sscal( n, rec, x, 1_${ik}$ ) scale = scale*rec end if end if ! update right-hand side - if( j1>1 ) then - call stdlib_saxpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 ) - call stdlib_saxpy( j1-1, -x( j2 ), t( 1, j2 ), 1, x, 1 ) - k = stdlib_isamax( j1-1, x, 1 ) + if( j1>1_${ik}$ ) then + call stdlib${ii}$_saxpy( j1-1, -x( j1 ), t( 1_${ik}$, j1 ), 1_${ik}$, x, 1_${ik}$ ) + call stdlib${ii}$_saxpy( j1-1, -x( j2 ), t( 1_${ik}$, j2 ), 1_${ik}$, x, 1_${ik}$ ) + k = stdlib${ii}$_isamax( j1-1, x, 1_${ik}$ ) xmax = abs( x( k ) ) end if end if end do loop_30 else ! solve t**t*p = scale*c - jnext = 1 + jnext = 1_${ik}$ loop_40: do j = 1, n if( jone ) then rec = one / xmax if( work( j1 )>( bignum-xj )*rec ) then - 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( j1 ) = x( j1 ) - stdlib_sdot( j1-1, t( 1, j1 ), 1, x, 1 ) + x( j1 ) = x( j1 ) - stdlib${ii}$_sdot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$, x, 1_${ik}$ ) xj = abs( x( j1 ) ) tjj = abs( t( j1, j1 ) ) tmp = t( j1, j1 ) if( tjjbignum*tjj ) then 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 @@ -50966,22 +50968,22 @@ module stdlib_linalg_lapack_s if( xmax>one ) then rec = one / xmax if( max( work( j2 ), work( j1 ) )>( bignum-xj )*rec ) then - 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 - d( 1, 1 ) = x( j1 ) - stdlib_sdot( j1-1, t( 1, j1 ), 1, x,1 ) - d( 2, 1 ) = x( j2 ) - stdlib_sdot( j1-1, t( 1, j2 ), 1, x,1 ) - call stdlib_slaln2( .true., 2, 1, smin, one, t( j1, j1 ),ldt, one, one, d, & - 2, zero, zero, v, 2,scaloc, xnorm, ierr ) - if( ierr/=0 )info = 2 + d( 1_${ik}$, 1_${ik}$ ) = x( j1 ) - stdlib${ii}$_sdot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$, x,1_${ik}$ ) + d( 2_${ik}$, 1_${ik}$ ) = x( j2 ) - stdlib${ii}$_sdot( j1-1, t( 1_${ik}$, j2 ), 1_${ik}$, x,1_${ik}$ ) + call stdlib${ii}$_slaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, t( j1, j1 ),ldt, one, one, d, & + 2_${ik}$, zero, zero, v, 2_${ik}$,scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 2_${ik}$ if( scaloc/=one ) then - call stdlib_sscal( n, scaloc, x, 1 ) + call stdlib${ii}$_sscal( n, scaloc, x, 1_${ik}$ ) scale = scale*scaloc end if - x( j1 ) = v( 1, 1 ) - x( j2 ) = v( 2, 1 ) + x( j1 ) = v( 1_${ik}$, 1_${ik}$ ) + x( j2 ) = v( 2_${ik}$, 1_${ik}$ ) xmax = max( abs( x( j1 ) ), abs( x( j2 ) ), xmax ) end if end do loop_40 @@ -50995,36 +50997,36 @@ module stdlib_linalg_lapack_s if( j>jnext )cycle loop_70 j1 = j j2 = j - jnext = j - 1 - if( j>1 ) then + jnext = j - 1_${ik}$ + if( j>1_${ik}$ ) then if( t( j, j-1 )/=zero ) then - j1 = j - 1 - jnext = j - 2 + j1 = j - 1_${ik}$ + jnext = j - 2_${ik}$ end if end if if( j1==j2 ) then ! 1 by 1 diagonal block ! scale if necessary to avoid overflow in division z = w - if( j1==1 )z = b( 1 ) + if( j1==1_${ik}$ )z = b( 1_${ik}$ ) xj = abs( x( j1 ) ) + abs( x( n+j1 ) ) tjj = abs( t( j1, j1 ) ) + abs( z ) tmp = t( j1, j1 ) if( tjjbignum*tjj ) then rec = one / xj - call stdlib_sscal( n2, rec, x, 1 ) + call stdlib${ii}$_sscal( n2, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - call stdlib_sladiv( x( j1 ), x( n+j1 ), tmp, z, sr, si ) + call stdlib${ii}$_sladiv( x( j1 ), x( n+j1 ), tmp, z, sr, si ) x( j1 ) = sr x( n+j1 ) = si xj = abs( x( j1 ) ) + abs( x( n+j1 ) ) @@ -51033,14 +51035,14 @@ module stdlib_linalg_lapack_s if( xj>one ) then rec = one / xj if( work( j1 )>( bignum-xmax )*rec ) then - call stdlib_sscal( n2, rec, x, 1 ) + call stdlib${ii}$_sscal( n2, rec, x, 1_${ik}$ ) scale = scale*rec end if end if - if( j1>1 ) then - call stdlib_saxpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 ) - call stdlib_saxpy( j1-1, -x( n+j1 ), t( 1, j1 ), 1,x( n+1 ), 1 ) - x( 1 ) = x( 1 ) + b( j1 )*x( n+j1 ) + if( j1>1_${ik}$ ) then + call stdlib${ii}$_saxpy( j1-1, -x( j1 ), t( 1_${ik}$, j1 ), 1_${ik}$, x, 1_${ik}$ ) + call stdlib${ii}$_saxpy( j1-1, -x( n+j1 ), t( 1_${ik}$, j1 ), 1_${ik}$,x( n+1 ), 1_${ik}$ ) + x( 1_${ik}$ ) = x( 1_${ik}$ ) + b( j1 )*x( n+j1 ) x( n+1 ) = x( n+1 ) - b( j1 )*x( j1 ) xmax = zero do k = 1, j1 - 1 @@ -51049,39 +51051,39 @@ module stdlib_linalg_lapack_s end if else ! meet 2 by 2 diagonal block - d( 1, 1 ) = x( j1 ) - d( 2, 1 ) = x( j2 ) - d( 1, 2 ) = x( n+j1 ) - d( 2, 2 ) = x( n+j2 ) - call stdlib_slaln2( .false., 2, 2, sminw, one, t( j1, j1 ),ldt, one, one, & - d, 2, zero, -w, v, 2,scaloc, xnorm, ierr ) - if( ierr/=0 )info = 2 + d( 1_${ik}$, 1_${ik}$ ) = x( j1 ) + d( 2_${ik}$, 1_${ik}$ ) = x( j2 ) + d( 1_${ik}$, 2_${ik}$ ) = x( n+j1 ) + d( 2_${ik}$, 2_${ik}$ ) = x( n+j2 ) + call stdlib${ii}$_slaln2( .false., 2_${ik}$, 2_${ik}$, sminw, one, t( j1, j1 ),ldt, one, one, & + d, 2_${ik}$, zero, -w, v, 2_${ik}$,scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 2_${ik}$ if( scaloc/=one ) then - call stdlib_sscal( 2*n, scaloc, x, 1 ) + call stdlib${ii}$_sscal( 2_${ik}$*n, scaloc, x, 1_${ik}$ ) scale = scaloc*scale end if - x( j1 ) = v( 1, 1 ) - x( j2 ) = v( 2, 1 ) - x( n+j1 ) = v( 1, 2 ) - x( n+j2 ) = v( 2, 2 ) + x( j1 ) = v( 1_${ik}$, 1_${ik}$ ) + x( j2 ) = v( 2_${ik}$, 1_${ik}$ ) + x( n+j1 ) = v( 1_${ik}$, 2_${ik}$ ) + x( n+j2 ) = v( 2_${ik}$, 2_${ik}$ ) ! scale x(j1), .... to avoid overflow in ! updating right hand side. - xj = max( abs( v( 1, 1 ) )+abs( v( 1, 2 ) ),abs( v( 2, 1 ) )+abs( v( 2, 2 )& + xj = max( abs( v( 1_${ik}$, 1_${ik}$ ) )+abs( v( 1_${ik}$, 2_${ik}$ ) ),abs( v( 2_${ik}$, 1_${ik}$ ) )+abs( v( 2_${ik}$, 2_${ik}$ )& ) ) if( xj>one ) then rec = one / xj if( max( work( j1 ), work( j2 ) )>( bignum-xmax )*rec ) then - call stdlib_sscal( n2, rec, x, 1 ) + call stdlib${ii}$_sscal( n2, rec, x, 1_${ik}$ ) scale = scale*rec end if end if ! update the right-hand side. - if( j1>1 ) then - call stdlib_saxpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 ) - call stdlib_saxpy( j1-1, -x( j2 ), t( 1, j2 ), 1, x, 1 ) - call stdlib_saxpy( j1-1, -x( n+j1 ), t( 1, j1 ), 1,x( n+1 ), 1 ) - call stdlib_saxpy( j1-1, -x( n+j2 ), t( 1, j2 ), 1,x( n+1 ), 1 ) - x( 1 ) = x( 1 ) + b( j1 )*x( n+j1 ) +b( j2 )*x( n+j2 ) + if( j1>1_${ik}$ ) then + call stdlib${ii}$_saxpy( j1-1, -x( j1 ), t( 1_${ik}$, j1 ), 1_${ik}$, x, 1_${ik}$ ) + call stdlib${ii}$_saxpy( j1-1, -x( j2 ), t( 1_${ik}$, j2 ), 1_${ik}$, x, 1_${ik}$ ) + call stdlib${ii}$_saxpy( j1-1, -x( n+j1 ), t( 1_${ik}$, j1 ), 1_${ik}$,x( n+1 ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( j1-1, -x( n+j2 ), t( 1_${ik}$, j2 ), 1_${ik}$,x( n+1 ), 1_${ik}$ ) + x( 1_${ik}$ ) = x( 1_${ik}$ ) + b( j1 )*x( n+j1 ) +b( j2 )*x( n+j2 ) x( n+1 ) = x( n+1 ) - b( j1 )*x( j1 ) -b( j2 )*x( j2 ) xmax = zero do k = 1, j1 - 1 @@ -51092,16 +51094,16 @@ module stdlib_linalg_lapack_s end do loop_70 else ! solve (t + ib)**t*(p+iq) = c+id - jnext = 1 + jnext = 1_${ik}$ loop_80: do j = 1, n if( jone ) then rec = one / xmax if( work( j1 )>( bignum-xj )*rec ) then - call stdlib_sscal( n2, rec, x, 1 ) + call stdlib${ii}$_sscal( n2, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j1 ) = x( j1 ) - stdlib_sdot( j1-1, t( 1, j1 ), 1, x, 1 ) - x( n+j1 ) = x( n+j1 ) - stdlib_sdot( j1-1, t( 1, j1 ), 1,x( n+1 ), 1 ) + x( j1 ) = x( j1 ) - stdlib${ii}$_sdot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$, x, 1_${ik}$ ) + x( n+j1 ) = x( n+j1 ) - stdlib${ii}$_sdot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$,x( n+1 ), 1_${ik}$ ) - if( j1>1 ) then + if( j1>1_${ik}$ ) then x( j1 ) = x( j1 ) - b( j1 )*x( n+1 ) - x( n+j1 ) = x( n+j1 ) + b( j1 )*x( 1 ) + x( n+j1 ) = x( n+j1 ) + b( j1 )*x( 1_${ik}$ ) end if xj = abs( x( j1 ) ) + abs( x( j1+n ) ) z = w - if( j1==1 )z = b( 1 ) + if( j1==1_${ik}$ )z = b( 1_${ik}$ ) ! scale if necessary to avoid overflow in ! complex division tjj = abs( t( j1, j1 ) ) + abs( z ) @@ -51134,17 +51136,17 @@ module stdlib_linalg_lapack_s if( tjjbignum*tjj ) then rec = one / xj - call stdlib_sscal( n2, rec, x, 1 ) + call stdlib${ii}$_sscal( n2, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - call stdlib_sladiv( x( j1 ), x( n+j1 ), tmp, -z, sr, si ) + call stdlib${ii}$_sladiv( x( j1 ), x( n+j1 ), tmp, -z, sr, si ) x( j1 ) = sr x( j1+n ) = si xmax = max( abs( x( j1 ) )+abs( x( j1+n ) ), xmax ) @@ -51157,32 +51159,32 @@ module stdlib_linalg_lapack_s if( xmax>one ) then rec = one / xmax if( max( work( j1 ), work( j2 ) )>( bignum-xj ) / xmax ) then - call stdlib_sscal( n2, rec, x, 1 ) + call stdlib${ii}$_sscal( n2, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - d( 1, 1 ) = x( j1 ) - stdlib_sdot( j1-1, t( 1, j1 ), 1, x,1 ) - d( 2, 1 ) = x( j2 ) - stdlib_sdot( j1-1, t( 1, j2 ), 1, x,1 ) - d( 1, 2 ) = x( n+j1 ) - stdlib_sdot( j1-1, t( 1, j1 ), 1,x( n+1 ), 1 ) + d( 1_${ik}$, 1_${ik}$ ) = x( j1 ) - stdlib${ii}$_sdot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$, x,1_${ik}$ ) + d( 2_${ik}$, 1_${ik}$ ) = x( j2 ) - stdlib${ii}$_sdot( j1-1, t( 1_${ik}$, j2 ), 1_${ik}$, x,1_${ik}$ ) + d( 1_${ik}$, 2_${ik}$ ) = x( n+j1 ) - stdlib${ii}$_sdot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$,x( n+1 ), 1_${ik}$ ) - d( 2, 2 ) = x( n+j2 ) - stdlib_sdot( j1-1, t( 1, j2 ), 1,x( n+1 ), 1 ) + d( 2_${ik}$, 2_${ik}$ ) = x( n+j2 ) - stdlib${ii}$_sdot( j1-1, t( 1_${ik}$, j2 ), 1_${ik}$,x( n+1 ), 1_${ik}$ ) - d( 1, 1 ) = d( 1, 1 ) - b( j1 )*x( n+1 ) - d( 2, 1 ) = d( 2, 1 ) - b( j2 )*x( n+1 ) - d( 1, 2 ) = d( 1, 2 ) + b( j1 )*x( 1 ) - d( 2, 2 ) = d( 2, 2 ) + b( j2 )*x( 1 ) - call stdlib_slaln2( .true., 2, 2, sminw, one, t( j1, j1 ),ldt, one, one, d,& - 2, zero, w, v, 2,scaloc, xnorm, ierr ) - if( ierr/=0 )info = 2 + d( 1_${ik}$, 1_${ik}$ ) = d( 1_${ik}$, 1_${ik}$ ) - b( j1 )*x( n+1 ) + d( 2_${ik}$, 1_${ik}$ ) = d( 2_${ik}$, 1_${ik}$ ) - b( j2 )*x( n+1 ) + d( 1_${ik}$, 2_${ik}$ ) = d( 1_${ik}$, 2_${ik}$ ) + b( j1 )*x( 1_${ik}$ ) + d( 2_${ik}$, 2_${ik}$ ) = d( 2_${ik}$, 2_${ik}$ ) + b( j2 )*x( 1_${ik}$ ) + call stdlib${ii}$_slaln2( .true., 2_${ik}$, 2_${ik}$, sminw, one, t( j1, j1 ),ldt, one, one, d,& + 2_${ik}$, zero, w, v, 2_${ik}$,scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 2_${ik}$ if( scaloc/=one ) then - call stdlib_sscal( n2, scaloc, x, 1 ) + call stdlib${ii}$_sscal( n2, scaloc, x, 1_${ik}$ ) scale = scaloc*scale end if - x( j1 ) = v( 1, 1 ) - x( j2 ) = v( 2, 1 ) - x( n+j1 ) = v( 1, 2 ) - x( n+j2 ) = v( 2, 2 ) + x( j1 ) = v( 1_${ik}$, 1_${ik}$ ) + x( j2 ) = v( 2_${ik}$, 1_${ik}$ ) + x( n+j1 ) = v( 1_${ik}$, 2_${ik}$ ) + x( n+j2 ) = v( 2_${ik}$, 2_${ik}$ ) xmax = max( abs( x( j1 ) )+abs( x( n+j1 ) ),abs( x( j2 ) )+abs( x( n+j2 ) )& , xmax ) end if @@ -51190,10 +51192,10 @@ module stdlib_linalg_lapack_s end if end if return - end subroutine stdlib_slaqtr + end subroutine stdlib${ii}$_slaqtr - pure subroutine stdlib_slasd3( nl, nr, sqre, k, d, q, ldq, dsigma, u, ldu, u2,ldu2, vt, ldvt,& + pure subroutine stdlib${ii}$_slasd3( nl, nr, sqre, k, d, q, ldq, dsigma, u, ldu, u2,ldu2, vt, ldvt,& !! SLASD3 finds all the square roots of the roots of the secular !! equation, as defined by the values in D and Z. It makes the !! appropriate calls to SLASD4 and then updates the singular @@ -51210,60 +51212,60 @@ 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) :: k, ldq, ldu, ldu2, ldvt, ldvt2, nl, nr, sqre + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k, ldq, ldu, ldu2, ldvt, ldvt2, nl, nr, sqre ! Array Arguments - integer(ilp), intent(in) :: ctot(*), idxc(*) + integer(${ik}$), intent(in) :: ctot(*), idxc(*) real(sp), intent(out) :: d(*), q(ldq,*), u(ldu,*), vt(ldvt,*) real(sp), intent(inout) :: dsigma(*), vt2(ldvt2,*), z(*) real(sp), intent(in) :: u2(ldu2,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: ctemp, i, j, jc, ktemp, m, n, nlp1, nlp2, nrp1 + integer(${ik}$) :: ctemp, i, j, jc, ktemp, m, n, nlp1, nlp2, nrp1 real(sp) :: rho, temp ! Intrinsic Functions intrinsic :: abs,sign,sqrt ! Executable Statements ! test the input parameters. - info = 0 - if( nl<1 ) then - info = -1 - else if( nr<1 ) then - info = -2 - else if( ( sqre/=1 ) .and. ( sqre/=0 ) ) then - info = -3 - end if - n = nl + nr + 1 + info = 0_${ik}$ + if( nl<1_${ik}$ ) then + info = -1_${ik}$ + else if( nr<1_${ik}$ ) then + info = -2_${ik}$ + else if( ( sqre/=1_${ik}$ ) .and. ( sqre/=0_${ik}$ ) ) then + info = -3_${ik}$ + end if + n = nl + nr + 1_${ik}$ m = n + sqre - nlp1 = nl + 1 - nlp2 = nl + 2 - if( ( k<1 ) .or. ( k>n ) ) then - info = -4 + nlp1 = nl + 1_${ik}$ + nlp2 = nl + 2_${ik}$ + if( ( k<1_${ik}$ ) .or. ( k>n ) ) then + info = -4_${ik}$ else if( ldqzero ) then - call stdlib_scopy( n, u2( 1, 1 ), 1, u( 1, 1 ), 1 ) + if( k==1_${ik}$ ) then + d( 1_${ik}$ ) = abs( z( 1_${ik}$ ) ) + call stdlib${ii}$_scopy( m, vt2( 1_${ik}$, 1_${ik}$ ), ldvt2, vt( 1_${ik}$, 1_${ik}$ ), ldvt ) + if( z( 1_${ik}$ )>zero ) then + call stdlib${ii}$_scopy( n, u2( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, u( 1_${ik}$, 1_${ik}$ ), 1_${ik}$ ) else do i = 1, n - u( i, 1 ) = -u2( i, 1 ) + u( i, 1_${ik}$ ) = -u2( i, 1_${ik}$ ) end do end if return @@ -51285,20 +51287,20 @@ module stdlib_linalg_lapack_s ! 2*dsigma(i) to prevent optimizing compilers from eliminating ! this code. do i = 1, k - dsigma( i ) = stdlib_slamc3( dsigma( i ), dsigma( i ) ) - dsigma( i ) + dsigma( i ) = stdlib${ii}$_slamc3( dsigma( i ), dsigma( i ) ) - dsigma( i ) end do ! keep a copy of z. - call stdlib_scopy( k, z, 1, q, 1 ) + call stdlib${ii}$_scopy( k, z, 1_${ik}$, q, 1_${ik}$ ) ! normalize z. - rho = stdlib_snrm2( k, z, 1 ) - call stdlib_slascl( 'G', 0, 0, rho, one, k, 1, z, k, info ) + rho = stdlib${ii}$_snrm2( k, z, 1_${ik}$ ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, rho, one, k, 1_${ik}$, z, k, info ) rho = rho*rho ! find the new singular values. do j = 1, k - call stdlib_slasd4( k, j, dsigma, z, u( 1, j ), rho, d( j ),vt( 1, j ), info ) + call stdlib${ii}$_slasd4( k, j, dsigma, z, u( 1_${ik}$, j ), rho, d( j ),vt( 1_${ik}$, j ), info ) ! if the zero finder fails, report the convergence failure. - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if end do @@ -51313,89 +51315,89 @@ module stdlib_linalg_lapack_s z( i ) = z( i )*( u( i, j )*vt( i, j ) /( dsigma( i )-dsigma( j+1 ) ) /( dsigma( & i )+dsigma( j+1 ) ) ) end do - z( i ) = sign( sqrt( abs( z( i ) ) ), q( i, 1 ) ) + z( i ) = sign( sqrt( abs( z( i ) ) ), q( i, 1_${ik}$ ) ) end do ! compute left singular vectors of the modified diagonal matrix, ! and store related information for the right singular vectors. do i = 1, k - vt( 1, i ) = z( 1 ) / u( 1, i ) / vt( 1, i ) - u( 1, i ) = negone + vt( 1_${ik}$, i ) = z( 1_${ik}$ ) / u( 1_${ik}$, i ) / vt( 1_${ik}$, i ) + u( 1_${ik}$, i ) = negone do j = 2, k vt( j, i ) = z( j ) / u( j, i ) / vt( j, i ) u( j, i ) = dsigma( j )*vt( j, i ) end do - temp = stdlib_snrm2( k, u( 1, i ), 1 ) - q( 1, i ) = u( 1, i ) / temp + temp = stdlib${ii}$_snrm2( k, u( 1_${ik}$, i ), 1_${ik}$ ) + q( 1_${ik}$, i ) = u( 1_${ik}$, i ) / temp do j = 2, k jc = idxc( j ) q( j, i ) = u( jc, i ) / temp end do end do ! update the left singular vector matrix. - if( k==2 ) then - call stdlib_sgemm( 'N', 'N', n, k, k, one, u2, ldu2, q, ldq, zero, u,ldu ) + if( k==2_${ik}$ ) then + call stdlib${ii}$_sgemm( 'N', 'N', n, k, k, one, u2, ldu2, q, ldq, zero, u,ldu ) go to 100 end if - if( ctot( 1 )>0 ) then - call stdlib_sgemm( 'N', 'N', nl, k, ctot( 1 ), one, u2( 1, 2 ), ldu2,q( 2, 1 ), ldq,& - zero, u( 1, 1 ), ldu ) - if( ctot( 3 )>0 ) then - ktemp = 2 + ctot( 1 ) + ctot( 2 ) - call stdlib_sgemm( 'N', 'N', nl, k, ctot( 3 ), one, u2( 1, ktemp ),ldu2, q( & - ktemp, 1 ), ldq, one, u( 1, 1 ), ldu ) - end if - else if( ctot( 3 )>0 ) then - ktemp = 2 + ctot( 1 ) + ctot( 2 ) - call stdlib_sgemm( 'N', 'N', nl, k, ctot( 3 ), one, u2( 1, ktemp ),ldu2, q( ktemp, & - 1 ), ldq, zero, u( 1, 1 ), ldu ) - else - call stdlib_slacpy( 'F', nl, k, u2, ldu2, u, ldu ) - end if - call stdlib_scopy( k, q( 1, 1 ), ldq, u( nlp1, 1 ), ldu ) - ktemp = 2 + ctot( 1 ) - ctemp = ctot( 2 ) + ctot( 3 ) - call stdlib_sgemm( 'N', 'N', nr, k, ctemp, one, u2( nlp2, ktemp ), ldu2,q( ktemp, 1 ), & - ldq, zero, u( nlp2, 1 ), ldu ) + if( ctot( 1_${ik}$ )>0_${ik}$ ) then + call stdlib${ii}$_sgemm( 'N', 'N', nl, k, ctot( 1_${ik}$ ), one, u2( 1_${ik}$, 2_${ik}$ ), ldu2,q( 2_${ik}$, 1_${ik}$ ), ldq,& + zero, u( 1_${ik}$, 1_${ik}$ ), ldu ) + if( ctot( 3_${ik}$ )>0_${ik}$ ) then + ktemp = 2_${ik}$ + ctot( 1_${ik}$ ) + ctot( 2_${ik}$ ) + call stdlib${ii}$_sgemm( 'N', 'N', nl, k, ctot( 3_${ik}$ ), one, u2( 1_${ik}$, ktemp ),ldu2, q( & + ktemp, 1_${ik}$ ), ldq, one, u( 1_${ik}$, 1_${ik}$ ), ldu ) + end if + else if( ctot( 3_${ik}$ )>0_${ik}$ ) then + ktemp = 2_${ik}$ + ctot( 1_${ik}$ ) + ctot( 2_${ik}$ ) + call stdlib${ii}$_sgemm( 'N', 'N', nl, k, ctot( 3_${ik}$ ), one, u2( 1_${ik}$, ktemp ),ldu2, q( ktemp, & + 1_${ik}$ ), ldq, zero, u( 1_${ik}$, 1_${ik}$ ), ldu ) + else + call stdlib${ii}$_slacpy( 'F', nl, k, u2, ldu2, u, ldu ) + end if + call stdlib${ii}$_scopy( k, q( 1_${ik}$, 1_${ik}$ ), ldq, u( nlp1, 1_${ik}$ ), ldu ) + ktemp = 2_${ik}$ + ctot( 1_${ik}$ ) + ctemp = ctot( 2_${ik}$ ) + ctot( 3_${ik}$ ) + call stdlib${ii}$_sgemm( 'N', 'N', nr, k, ctemp, one, u2( nlp2, ktemp ), ldu2,q( ktemp, 1_${ik}$ ), & + ldq, zero, u( nlp2, 1_${ik}$ ), ldu ) ! generate the right singular vectors. 100 continue do i = 1, k - temp = stdlib_snrm2( k, vt( 1, i ), 1 ) - q( i, 1 ) = vt( 1, i ) / temp + temp = stdlib${ii}$_snrm2( k, vt( 1_${ik}$, i ), 1_${ik}$ ) + q( i, 1_${ik}$ ) = vt( 1_${ik}$, i ) / temp do j = 2, k jc = idxc( j ) q( i, j ) = vt( jc, i ) / temp end do end do ! update the right singular vector matrix. - if( k==2 ) then - call stdlib_sgemm( 'N', 'N', k, m, k, one, q, ldq, vt2, ldvt2, zero,vt, ldvt ) + if( k==2_${ik}$ ) then + call stdlib${ii}$_sgemm( 'N', 'N', k, m, k, one, q, ldq, vt2, ldvt2, zero,vt, ldvt ) return end if - ktemp = 1 + ctot( 1 ) - call stdlib_sgemm( 'N', 'N', k, nlp1, ktemp, one, q( 1, 1 ), ldq,vt2( 1, 1 ), ldvt2, & - zero, vt( 1, 1 ), ldvt ) - ktemp = 2 + ctot( 1 ) + ctot( 2 ) - if( ktemp<=ldvt2 )call stdlib_sgemm( 'N', 'N', k, nlp1, ctot( 3 ), one, q( 1, ktemp ),& - ldq, vt2( ktemp, 1 ), ldvt2, one, vt( 1, 1 ),ldvt ) - ktemp = ctot( 1 ) + 1 + ktemp = 1_${ik}$ + ctot( 1_${ik}$ ) + call stdlib${ii}$_sgemm( 'N', 'N', k, nlp1, ktemp, one, q( 1_${ik}$, 1_${ik}$ ), ldq,vt2( 1_${ik}$, 1_${ik}$ ), ldvt2, & + zero, vt( 1_${ik}$, 1_${ik}$ ), ldvt ) + ktemp = 2_${ik}$ + ctot( 1_${ik}$ ) + ctot( 2_${ik}$ ) + if( ktemp<=ldvt2 )call stdlib${ii}$_sgemm( 'N', 'N', k, nlp1, ctot( 3_${ik}$ ), one, q( 1_${ik}$, ktemp ),& + ldq, vt2( ktemp, 1_${ik}$ ), ldvt2, one, vt( 1_${ik}$, 1_${ik}$ ),ldvt ) + ktemp = ctot( 1_${ik}$ ) + 1_${ik}$ nrp1 = nr + sqre - if( ktemp>1 ) then + if( ktemp>1_${ik}$ ) then do i = 1, k - q( i, ktemp ) = q( i, 1 ) + q( i, ktemp ) = q( i, 1_${ik}$ ) end do do i = nlp2, m - vt2( ktemp, i ) = vt2( 1, i ) + vt2( ktemp, i ) = vt2( 1_${ik}$, i ) end do end if - ctemp = 1 + ctot( 2 ) + ctot( 3 ) - call stdlib_sgemm( 'N', 'N', k, nrp1, ctemp, one, q( 1, ktemp ), ldq,vt2( ktemp, nlp2 )& - , ldvt2, zero, vt( 1, nlp2 ), ldvt ) + ctemp = 1_${ik}$ + ctot( 2_${ik}$ ) + ctot( 3_${ik}$ ) + call stdlib${ii}$_sgemm( 'N', 'N', k, nrp1, ctemp, one, q( 1_${ik}$, ktemp ), ldq,vt2( ktemp, nlp2 )& + , ldvt2, zero, vt( 1_${ik}$, nlp2 ), ldvt ) return - end subroutine stdlib_slasd3 + end subroutine stdlib${ii}$_slasd3 - pure subroutine stdlib_slasd6( icompq, nl, nr, sqre, d, vf, vl, alpha, beta,idxq, perm, & + pure subroutine stdlib${ii}$_slasd6( icompq, nl, nr, sqre, d, vf, vl, alpha, beta,idxq, perm, & !! SLASD6 computes the SVD of an updated upper bidiagonal matrix B !! obtained by merging two smaller ones by appending a row. This !! routine is used only for the problem which requires all singular @@ -51437,53 +51439,53 @@ 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(inout) :: alpha, beta real(sp), intent(out) :: c, s ! Array Arguments - integer(ilp), intent(out) :: givcol(ldgcol,*), iwork(*), perm(*) - integer(ilp), intent(inout) :: idxq(*) + integer(${ik}$), intent(out) :: givcol(ldgcol,*), iwork(*), perm(*) + integer(${ik}$), intent(inout) :: idxq(*) real(sp), intent(inout) :: d(*), vf(*), vl(*) real(sp), intent(out) :: difl(*), difr(*), givnum(ldgnum,*), poles(ldgnum,*), work(*), & z(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, idx, idxc, idxp, isigma, ivfw, ivlw, iw, m, n, n1, n2 + integer(${ik}$) :: i, idx, idxc, idxp, isigma, ivfw, ivlw, iw, m, n, n1, n2 real(sp) :: orgnrm ! 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( ldgcol1 ) then + if( n>1_${ik}$ ) then ! generate q(2:n,2:n) - call stdlib_sorg2r( n-1, n-1, n-1, q( 2, 2 ), ldq, tau, work,iinfo ) + call stdlib${ii}$_sorg2r( n-1, n-1, n-1, q( 2_${ik}$, 2_${ik}$ ), ldq, tau, work,iinfo ) end if end if return - end subroutine stdlib_sopgtr + end subroutine stdlib${ii}$_sopgtr - pure subroutine stdlib_sopmtr( side, uplo, trans, m, n, ap, tau, c, ldc, work,info ) + pure subroutine stdlib${ii}$_sopmtr( side, uplo, trans, m, n, ap, tau, c, ldc, work,info ) !! SOPMTR overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -51626,8 +51628,8 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: side, trans, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldc, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldc, m, n ! Array Arguments real(sp), intent(inout) :: ap(*), c(ldc,*) real(sp), intent(in) :: tau(*) @@ -51636,13 +51638,13 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: forwrd, left, notran, upper - integer(ilp) :: i, i1, i2, i3, ic, ii, jc, mi, ni, nq + integer(${ik}$) :: i, i1, i2, i3, ic, ii, jc, 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' ) upper = stdlib_lsame( uplo, 'U' ) @@ -51653,37 +51655,37 @@ 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.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -2 + info = -2_${ik}$ else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) ) then - info = -3 - else if( m<0 ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( ldc m-p ) then - info = -2 - else if( q < 0 .or. q < p .or. m-q < p ) then - info = -3 - else if( ldx11 < max( 1, p ) ) then - info = -5 - else if( ldx21 < max( 1, m-p ) ) then - info = -7 + info = 0_${ik}$ + lquery = lwork == -1_${ik}$ + if( m < 0_${ik}$ ) then + info = -1_${ik}$ + else if( p < 0_${ik}$ .or. p > m-p ) then + info = -2_${ik}$ + else if( q < 0_${ik}$ .or. q < p .or. m-q < p ) then + info = -3_${ik}$ + else if( ldx11 < max( 1_${ik}$, p ) ) then + info = -5_${ik}$ + else if( ldx21 < max( 1_${ik}$, m-p ) ) then + info = -7_${ik}$ end if ! compute workspace - if( info == 0 ) then - ilarf = 2 + if( info == 0_${ik}$ ) then + ilarf = 2_${ik}$ llarf = max( p-1, m-p, q-1 ) - iorbdb5 = 2 + iorbdb5 = 2_${ik}$ lorbdb5 = q-1 lworkopt = max( ilarf+llarf-1, iorbdb5+lorbdb5-1 ) lworkmin = lworkopt - work(1) = lworkopt + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not.lquery ) then - info = -14 + info = -14_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'SORBDB2', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'SORBDB2', -info ) return else if( lquery ) then return end if ! reduce rows 1, ..., p of x11 and x21 do i = 1, p - if( i > 1 ) then - call stdlib_srot( q-i+1, x11(i,i), ldx11, x21(i-1,i), ldx21, c, s ) + if( i > 1_${ik}$ ) then + call stdlib${ii}$_srot( q-i+1, x11(i,i), ldx11, x21(i-1,i), ldx21, c, s ) end if - call stdlib_slarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) + call stdlib${ii}$_slarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) c = x11(i,i) x11(i,i) = one - call stdlib_slarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & + call stdlib${ii}$_slarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & work(ilarf) ) - call stdlib_slarf( 'R', m-p-i+1, q-i+1, x11(i,i), ldx11, tauq1(i),x21(i,i), ldx21, & + call stdlib${ii}$_slarf( 'R', m-p-i+1, q-i+1, x11(i,i), ldx11, tauq1(i),x21(i,i), ldx21, & work(ilarf) ) - s = sqrt( stdlib_snrm2( p-i, x11(i+1,i), 1 )**2+ stdlib_snrm2( m-p-i+1, x21(i,i), 1 & - )**2 ) + s = sqrt( stdlib${ii}$_snrm2( p-i, x11(i+1,i), 1_${ik}$ )**2_${ik}$+ stdlib${ii}$_snrm2( m-p-i+1, x21(i,i), 1_${ik}$ & + )**2_${ik}$ ) theta(i) = atan2( s, c ) - call stdlib_sorbdb5( p-i, m-p-i+1, q-i, x11(i+1,i), 1, x21(i,i), 1,x11(i+1,i+1), & + call stdlib${ii}$_sorbdb5( p-i, m-p-i+1, q-i, x11(i+1,i), 1_${ik}$, x21(i,i), 1_${ik}$,x11(i+1,i+1), & ldx11, x21(i,i+1), ldx21,work(iorbdb5), lorbdb5, childinfo ) - call stdlib_sscal( p-i, negone, x11(i+1,i), 1 ) - call stdlib_slarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) ) + call stdlib${ii}$_sscal( p-i, negone, x11(i+1,i), 1_${ik}$ ) + call stdlib${ii}$_slarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1_${ik}$, taup2(i) ) if( i < p ) then - call stdlib_slarfgp( p-i, x11(i+1,i), x11(i+2,i), 1, taup1(i) ) + call stdlib${ii}$_slarfgp( p-i, x11(i+1,i), x11(i+2,i), 1_${ik}$, taup1(i) ) phi(i) = atan2( x11(i+1,i), x21(i,i) ) c = cos( phi(i) ) s = sin( phi(i) ) x11(i+1,i) = one - call stdlib_slarf( 'L', p-i, q-i, x11(i+1,i), 1, taup1(i),x11(i+1,i+1), ldx11, & + call stdlib${ii}$_slarf( 'L', p-i, q-i, x11(i+1,i), 1_${ik}$, taup1(i),x11(i+1,i+1), ldx11, & work(ilarf) ) end if x21(i,i) = one - call stdlib_slarf( 'L', m-p-i+1, q-i, x21(i,i), 1, taup2(i),x21(i,i+1), ldx21, work(& + call stdlib${ii}$_slarf( 'L', m-p-i+1, q-i, x21(i,i), 1_${ik}$, taup2(i),x21(i,i+1), ldx21, work(& ilarf) ) end do ! reduce the bottom-right portion of x21 to the identity matrix do i = p + 1, q - call stdlib_slarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) ) + call stdlib${ii}$_slarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1_${ik}$, taup2(i) ) x21(i,i) = one - call stdlib_slarf( 'L', m-p-i+1, q-i, x21(i,i), 1, taup2(i),x21(i,i+1), ldx21, work(& + call stdlib${ii}$_slarf( 'L', m-p-i+1, q-i, x21(i,i), 1_${ik}$, taup2(i),x21(i,i+1), ldx21, work(& ilarf) ) end do return - end subroutine stdlib_sorbdb2 + end subroutine stdlib${ii}$_sorbdb2 - subroutine stdlib_sorbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & + subroutine stdlib${ii}$_sorbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & !! SORBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny !! matrix X with orthonomal columns: !! [ B11 ] @@ -51994,8 +51996,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) :: lwork, m, p, q, ldx11, ldx21 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork, m, p, q, ldx11, ldx21 ! Array Arguments real(sp), intent(out) :: phi(*), theta(*) real(sp), intent(out) :: taup1(*), taup2(*), tauq1(*), work(*) @@ -52004,88 +52006,88 @@ module stdlib_linalg_lapack_s ! Local Scalars real(sp) :: c, s - integer(ilp) :: childinfo, i, ilarf, iorbdb5, llarf, lorbdb5, lworkmin, & + integer(${ik}$) :: childinfo, i, ilarf, iorbdb5, llarf, lorbdb5, lworkmin, & lworkopt logical(lk) :: lquery ! Intrinsic Function intrinsic :: atan2,cos,max,sin,sqrt ! Executable Statements ! test input arguments - info = 0 - lquery = lwork == -1 - if( m < 0 ) then - info = -1 - else if( 2*p < m .or. p > m ) then - info = -2 + info = 0_${ik}$ + lquery = lwork == -1_${ik}$ + if( m < 0_${ik}$ ) then + info = -1_${ik}$ + else if( 2_${ik}$*p < m .or. p > m ) then + info = -2_${ik}$ else if( q < m-p .or. m-q < m-p ) then - info = -3 - else if( ldx11 < max( 1, p ) ) then - info = -5 - else if( ldx21 < max( 1, m-p ) ) then - info = -7 + info = -3_${ik}$ + else if( ldx11 < max( 1_${ik}$, p ) ) then + info = -5_${ik}$ + else if( ldx21 < max( 1_${ik}$, m-p ) ) then + info = -7_${ik}$ end if ! compute workspace - if( info == 0 ) then - ilarf = 2 + if( info == 0_${ik}$ ) then + ilarf = 2_${ik}$ llarf = max( p, m-p-1, q-1 ) - iorbdb5 = 2 + iorbdb5 = 2_${ik}$ lorbdb5 = q-1 lworkopt = max( ilarf+llarf-1, iorbdb5+lorbdb5-1 ) lworkmin = lworkopt - work(1) = lworkopt + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not.lquery ) then - info = -14 + info = -14_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'SORBDB3', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'SORBDB3', -info ) return else if( lquery ) then return end if ! reduce rows 1, ..., m-p of x11 and x21 do i = 1, m-p - if( i > 1 ) then - call stdlib_srot( q-i+1, x11(i-1,i), ldx11, x21(i,i), ldx11, c, s ) + if( i > 1_${ik}$ ) then + call stdlib${ii}$_srot( q-i+1, x11(i-1,i), ldx11, x21(i,i), ldx11, c, s ) end if - call stdlib_slarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) + call stdlib${ii}$_slarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) s = x21(i,i) x21(i,i) = one - call stdlib_slarf( 'R', p-i+1, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i,i), ldx11, & + call stdlib${ii}$_slarf( 'R', p-i+1, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i,i), ldx11, & work(ilarf) ) - call stdlib_slarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & + call stdlib${ii}$_slarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & work(ilarf) ) - c = sqrt( stdlib_snrm2( p-i+1, x11(i,i), 1 )**2+ stdlib_snrm2( m-p-i, x21(i+1,i), 1 & - )**2 ) + c = sqrt( stdlib${ii}$_snrm2( p-i+1, x11(i,i), 1_${ik}$ )**2_${ik}$+ stdlib${ii}$_snrm2( m-p-i, x21(i+1,i), 1_${ik}$ & + )**2_${ik}$ ) theta(i) = atan2( s, c ) - call stdlib_sorbdb5( p-i+1, m-p-i, q-i, x11(i,i), 1, x21(i+1,i), 1,x11(i,i+1), & + call stdlib${ii}$_sorbdb5( p-i+1, m-p-i, q-i, x11(i,i), 1_${ik}$, x21(i+1,i), 1_${ik}$,x11(i,i+1), & ldx11, x21(i+1,i+1), ldx21,work(iorbdb5), lorbdb5, childinfo ) - call stdlib_slarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) + call stdlib${ii}$_slarfgp( p-i+1, x11(i,i), x11(i+1,i), 1_${ik}$, taup1(i) ) if( i < m-p ) then - call stdlib_slarfgp( m-p-i, x21(i+1,i), x21(i+2,i), 1, taup2(i) ) + call stdlib${ii}$_slarfgp( m-p-i, x21(i+1,i), x21(i+2,i), 1_${ik}$, taup2(i) ) phi(i) = atan2( x21(i+1,i), x11(i,i) ) c = cos( phi(i) ) s = sin( phi(i) ) x21(i+1,i) = one - call stdlib_slarf( 'L', m-p-i, q-i, x21(i+1,i), 1, taup2(i),x21(i+1,i+1), ldx21, & + call stdlib${ii}$_slarf( 'L', m-p-i, q-i, x21(i+1,i), 1_${ik}$, taup2(i),x21(i+1,i+1), ldx21, & work(ilarf) ) end if x11(i,i) = one - call stdlib_slarf( 'L', p-i+1, q-i, x11(i,i), 1, taup1(i), x11(i,i+1),ldx11, work(& + call stdlib${ii}$_slarf( 'L', p-i+1, q-i, x11(i,i), 1_${ik}$, taup1(i), x11(i,i+1),ldx11, work(& ilarf) ) end do ! reduce the bottom-right portion of x11 to the identity matrix do i = m-p + 1, q - call stdlib_slarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) + call stdlib${ii}$_slarfgp( p-i+1, x11(i,i), x11(i+1,i), 1_${ik}$, taup1(i) ) x11(i,i) = one - call stdlib_slarf( 'L', p-i+1, q-i, x11(i,i), 1, taup1(i), x11(i,i+1),ldx11, work(& + call stdlib${ii}$_slarf( 'L', p-i+1, q-i, x11(i,i), 1_${ik}$, taup1(i), x11(i,i+1),ldx11, work(& ilarf) ) end do return - end subroutine stdlib_sorbdb3 + end subroutine stdlib${ii}$_sorbdb3 - subroutine stdlib_sorbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & + subroutine stdlib${ii}$_sorbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & !! SORBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny !! matrix X with orthonomal columns: !! [ B11 ] @@ -52106,8 +52108,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) :: lwork, m, p, q, ldx11, ldx21 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork, m, p, q, ldx11, ldx21 ! Array Arguments real(sp), intent(out) :: phi(*), theta(*) real(sp), intent(out) :: phantom(*), taup1(*), taup2(*), tauq1(*), work(*) @@ -52116,118 +52118,118 @@ module stdlib_linalg_lapack_s ! Local Scalars real(sp) :: c, s - integer(ilp) :: childinfo, i, ilarf, iorbdb5, j, llarf, lorbdb5, lworkmin, & + integer(${ik}$) :: childinfo, i, ilarf, iorbdb5, j, llarf, lorbdb5, lworkmin, & lworkopt logical(lk) :: lquery ! Intrinsic Function intrinsic :: atan2,cos,max,sin,sqrt ! Executable Statements ! test input arguments - info = 0 - lquery = lwork == -1 - if( m < 0 ) then - info = -1 + info = 0_${ik}$ + lquery = lwork == -1_${ik}$ + if( m < 0_${ik}$ ) then + info = -1_${ik}$ else if( p < m-q .or. m-p < m-q ) then - info = -2 + info = -2_${ik}$ else if( q < m-q .or. q > m ) then - info = -3 - else if( ldx11 < max( 1, p ) ) then - info = -5 - else if( ldx21 < max( 1, m-p ) ) then - info = -7 + info = -3_${ik}$ + else if( ldx11 < max( 1_${ik}$, p ) ) then + info = -5_${ik}$ + else if( ldx21 < max( 1_${ik}$, m-p ) ) then + info = -7_${ik}$ end if ! compute workspace - if( info == 0 ) then - ilarf = 2 + if( info == 0_${ik}$ ) then + ilarf = 2_${ik}$ llarf = max( q-1, p-1, m-p-1 ) - iorbdb5 = 2 + iorbdb5 = 2_${ik}$ lorbdb5 = q - lworkopt = ilarf + llarf - 1 - lworkopt = max( lworkopt, iorbdb5 + lorbdb5 - 1 ) + lworkopt = ilarf + llarf - 1_${ik}$ + lworkopt = max( lworkopt, iorbdb5 + lorbdb5 - 1_${ik}$ ) lworkmin = lworkopt - work(1) = lworkopt + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not.lquery ) then - info = -14 + info = -14_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'SORBDB4', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'SORBDB4', -info ) return else if( lquery ) then return end if ! reduce columns 1, ..., m-q of x11 and x21 do i = 1, m-q - if( i == 1 ) then + if( i == 1_${ik}$ ) then do j = 1, m phantom(j) = zero end do - call stdlib_sorbdb5( p, m-p, q, phantom(1), 1, phantom(p+1), 1,x11, ldx11, x21, & + call stdlib${ii}$_sorbdb5( p, m-p, q, phantom(1_${ik}$), 1_${ik}$, phantom(p+1), 1_${ik}$,x11, ldx11, x21, & ldx21, work(iorbdb5),lorbdb5, childinfo ) - call stdlib_sscal( p, negone, phantom(1), 1 ) - call stdlib_slarfgp( p, phantom(1), phantom(2), 1, taup1(1) ) - call stdlib_slarfgp( m-p, phantom(p+1), phantom(p+2), 1, taup2(1) ) - theta(i) = atan2( phantom(1), phantom(p+1) ) + call stdlib${ii}$_sscal( p, negone, phantom(1_${ik}$), 1_${ik}$ ) + call stdlib${ii}$_slarfgp( p, phantom(1_${ik}$), phantom(2_${ik}$), 1_${ik}$, taup1(1_${ik}$) ) + call stdlib${ii}$_slarfgp( m-p, phantom(p+1), phantom(p+2), 1_${ik}$, taup2(1_${ik}$) ) + theta(i) = atan2( phantom(1_${ik}$), phantom(p+1) ) c = cos( theta(i) ) s = sin( theta(i) ) - phantom(1) = one + phantom(1_${ik}$) = one phantom(p+1) = one - call stdlib_slarf( 'L', p, q, phantom(1), 1, taup1(1), x11, ldx11,work(ilarf) ) + call stdlib${ii}$_slarf( 'L', p, q, phantom(1_${ik}$), 1_${ik}$, taup1(1_${ik}$), x11, ldx11,work(ilarf) ) - call stdlib_slarf( 'L', m-p, q, phantom(p+1), 1, taup2(1), x21,ldx21, work(ilarf)& + call stdlib${ii}$_slarf( 'L', m-p, q, phantom(p+1), 1_${ik}$, taup2(1_${ik}$), x21,ldx21, work(ilarf)& ) else - call stdlib_sorbdb5( p-i+1, m-p-i+1, q-i+1, x11(i,i-1), 1,x21(i,i-1), 1, x11(i,i)& + call stdlib${ii}$_sorbdb5( p-i+1, m-p-i+1, q-i+1, x11(i,i-1), 1_${ik}$,x21(i,i-1), 1_${ik}$, x11(i,i)& , ldx11, x21(i,i),ldx21, work(iorbdb5), lorbdb5, childinfo ) - call stdlib_sscal( p-i+1, negone, x11(i,i-1), 1 ) - call stdlib_slarfgp( p-i+1, x11(i,i-1), x11(i+1,i-1), 1, taup1(i) ) - call stdlib_slarfgp( m-p-i+1, x21(i,i-1), x21(i+1,i-1), 1,taup2(i) ) + call stdlib${ii}$_sscal( p-i+1, negone, x11(i,i-1), 1_${ik}$ ) + call stdlib${ii}$_slarfgp( p-i+1, x11(i,i-1), x11(i+1,i-1), 1_${ik}$, taup1(i) ) + call stdlib${ii}$_slarfgp( m-p-i+1, x21(i,i-1), x21(i+1,i-1), 1_${ik}$,taup2(i) ) theta(i) = atan2( x11(i,i-1), x21(i,i-1) ) c = cos( theta(i) ) s = sin( theta(i) ) x11(i,i-1) = one x21(i,i-1) = one - call stdlib_slarf( 'L', p-i+1, q-i+1, x11(i,i-1), 1, taup1(i),x11(i,i), ldx11, & + call stdlib${ii}$_slarf( 'L', p-i+1, q-i+1, x11(i,i-1), 1_${ik}$, taup1(i),x11(i,i), ldx11, & work(ilarf) ) - call stdlib_slarf( 'L', m-p-i+1, q-i+1, x21(i,i-1), 1, taup2(i),x21(i,i), ldx21, & + call stdlib${ii}$_slarf( 'L', m-p-i+1, q-i+1, x21(i,i-1), 1_${ik}$, taup2(i),x21(i,i), ldx21, & work(ilarf) ) end if - call stdlib_srot( q-i+1, x11(i,i), ldx11, x21(i,i), ldx21, s, -c ) - call stdlib_slarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) + call stdlib${ii}$_srot( q-i+1, x11(i,i), ldx11, x21(i,i), ldx21, s, -c ) + call stdlib${ii}$_slarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) c = x21(i,i) x21(i,i) = one - call stdlib_slarf( 'R', p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i+1,i), ldx11, & + call stdlib${ii}$_slarf( 'R', p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i+1,i), ldx11, & work(ilarf) ) - call stdlib_slarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & + call stdlib${ii}$_slarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & work(ilarf) ) if( i < m-q ) then - s = sqrt( stdlib_snrm2( p-i, x11(i+1,i), 1 )**2+ stdlib_snrm2( m-p-i, x21(i+1,i),& - 1 )**2 ) + s = sqrt( stdlib${ii}$_snrm2( p-i, x11(i+1,i), 1_${ik}$ )**2_${ik}$+ stdlib${ii}$_snrm2( m-p-i, x21(i+1,i),& + 1_${ik}$ )**2_${ik}$ ) phi(i) = atan2( s, c ) end if end do ! reduce the bottom-right portion of x11 to [ i 0 ] do i = m - q + 1, p - call stdlib_slarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) + call stdlib${ii}$_slarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) x11(i,i) = one - call stdlib_slarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & + call stdlib${ii}$_slarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & work(ilarf) ) - call stdlib_slarf( 'R', q-p, q-i+1, x11(i,i), ldx11, tauq1(i),x21(m-q+1,i), ldx21, & + call stdlib${ii}$_slarf( 'R', q-p, q-i+1, x11(i,i), ldx11, tauq1(i),x21(m-q+1,i), ldx21, & work(ilarf) ) end do ! reduce the bottom-right portion of x21 to [ 0 i ] do i = p + 1, q - call stdlib_slarfgp( q-i+1, x21(m-q+i-p,i), x21(m-q+i-p,i+1), ldx21,tauq1(i) ) + call stdlib${ii}$_slarfgp( q-i+1, x21(m-q+i-p,i), x21(m-q+i-p,i+1), ldx21,tauq1(i) ) x21(m-q+i-p,i) = one - call stdlib_slarf( 'R', q-i, q-i+1, x21(m-q+i-p,i), ldx21, tauq1(i),x21(m-q+i-p+1,i)& + call stdlib${ii}$_slarf( 'R', q-i, q-i+1, x21(m-q+i-p,i), ldx21, tauq1(i),x21(m-q+i-p+1,i)& , ldx21, work(ilarf) ) end do return - end subroutine stdlib_sorbdb4 + end subroutine stdlib${ii}$_sorbdb4 - subroutine stdlib_sorcsd2by1( jobu1, jobu2, jobv1t, m, p, q, x11, ldx11,x21, ldx21, theta, & + subroutine stdlib${ii}$_sorcsd2by1( jobu1, jobu2, jobv1t, m, p, q, x11, ldx11,x21, ldx21, theta, & !! SORCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with !! orthonormal columns that has been partitioned into a 2-by-1 block !! structure: @@ -52249,48 +52251,48 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobu1, jobu2, jobv1t - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldu1, ldu2, ldv1t, lwork, ldx11, ldx21, m, p, q + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldu1, ldu2, ldv1t, lwork, ldx11, ldx21, m, p, q ! Array Arguments real(sp), intent(out) :: theta(*) real(sp), intent(out) :: u1(ldu1,*), u2(ldu2,*), v1t(ldv1t,*), work(*) real(sp), intent(inout) :: x11(ldx11,*), x21(ldx21,*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: childinfo, i, ib11d, ib11e, ib12d, ib12e, ib21d, ib21e, ib22d, ib22e, & + integer(${ik}$) :: childinfo, i, ib11d, ib11e, ib12d, ib12e, ib21d, ib21e, ib22d, ib22e, & ibbcsd, iorbdb, iorglq, iorgqr, iphi, itaup1, itaup2, itauq1, j, lbbcsd, lorbdb, & lorglq, lorglqmin, lorglqopt, lorgqr, lorgqrmin, lorgqropt, lworkmin, lworkopt, & r logical(lk) :: lquery, wantu1, wantu2, wantv1t ! Local Arrays - real(sp) :: dum1(1), dum2(1,1) + real(sp) :: dum1(1_${ik}$), dum2(1_${ik}$,1_${ik}$) ! Intrinsic Function intrinsic :: int,max,min ! Executable Statements ! test input arguments - info = 0 + info = 0_${ik}$ wantu1 = stdlib_lsame( jobu1, 'Y' ) wantu2 = stdlib_lsame( jobu2, 'Y' ) wantv1t = stdlib_lsame( jobv1t, 'Y' ) - lquery = lwork == -1 - if( m < 0 ) then - info = -4 - else if( p < 0 .or. p > m ) then - info = -5 - else if( q < 0 .or. q > m ) then - info = -6 - else if( ldx11 < max( 1, p ) ) then - info = -8 - else if( ldx21 < max( 1, m-p ) ) then - info = -10 - else if( wantu1 .and. ldu1 < max( 1, p ) ) then - info = -13 - else if( wantu2 .and. ldu2 < max( 1, m - p ) ) then - info = -15 - else if( wantv1t .and. ldv1t < max( 1, q ) ) then - info = -17 + lquery = lwork == -1_${ik}$ + if( m < 0_${ik}$ ) then + info = -4_${ik}$ + else if( p < 0_${ik}$ .or. p > m ) then + info = -5_${ik}$ + else if( q < 0_${ik}$ .or. q > m ) then + info = -6_${ik}$ + else if( ldx11 < max( 1_${ik}$, p ) ) then + info = -8_${ik}$ + else if( ldx21 < max( 1_${ik}$, m-p ) ) then + info = -10_${ik}$ + else if( wantu1 .and. ldu1 < max( 1_${ik}$, p ) ) then + info = -13_${ik}$ + else if( wantu2 .and. ldu2 < max( 1_${ik}$, m - p ) ) then + info = -15_${ik}$ + else if( wantv1t .and. ldv1t < max( 1_${ik}$, q ) ) then + info = -17_${ik}$ end if r = min( p, m-p, q, m-q ) ! compute workspace @@ -52304,143 +52306,143 @@ module stdlib_linalg_lapack_s ! | taup2 (max(1,m-p)) | b11e (r-1) | ! | tauq1 (max(1,q)) | b12d (r) | ! |-----------------------------------------| b12e (r-1) | - ! | stdlib_sorbdb work | stdlib_sorgqr work | stdlib_sorglq work | b21d (r) | + ! | stdlib${ii}$_sorbdb work | stdlib${ii}$_sorgqr work | stdlib${ii}$_sorglq work | b21d (r) | ! | | | | b21e (r-1) | ! | | | | b22d (r) | ! | | | | b22e (r-1) | - ! | | | | stdlib_sbbcsd work | + ! | | | | stdlib${ii}$_sbbcsd work | ! |-------------------------------------------------------| - if( info == 0 ) then - iphi = 2 - ib11d = iphi + max( 1, r-1 ) - ib11e = ib11d + max( 1, r ) - ib12d = ib11e + max( 1, r - 1 ) - ib12e = ib12d + max( 1, r ) - ib21d = ib12e + max( 1, r - 1 ) - ib21e = ib21d + max( 1, r ) - ib22d = ib21e + max( 1, r - 1 ) - ib22e = ib22d + max( 1, r ) - ibbcsd = ib22e + max( 1, r - 1 ) - itaup1 = iphi + max( 1, r-1 ) - itaup2 = itaup1 + max( 1, p ) - itauq1 = itaup2 + max( 1, m-p ) - iorbdb = itauq1 + max( 1, q ) - iorgqr = itauq1 + max( 1, q ) - iorglq = itauq1 + max( 1, q ) - lorgqrmin = 1 - lorgqropt = 1 - lorglqmin = 1 - lorglqopt = 1 + if( info == 0_${ik}$ ) then + iphi = 2_${ik}$ + ib11d = iphi + max( 1_${ik}$, r-1 ) + ib11e = ib11d + max( 1_${ik}$, r ) + ib12d = ib11e + max( 1_${ik}$, r - 1_${ik}$ ) + ib12e = ib12d + max( 1_${ik}$, r ) + ib21d = ib12e + max( 1_${ik}$, r - 1_${ik}$ ) + ib21e = ib21d + max( 1_${ik}$, r ) + ib22d = ib21e + max( 1_${ik}$, r - 1_${ik}$ ) + ib22e = ib22d + max( 1_${ik}$, r ) + ibbcsd = ib22e + max( 1_${ik}$, r - 1_${ik}$ ) + itaup1 = iphi + max( 1_${ik}$, r-1 ) + itaup2 = itaup1 + max( 1_${ik}$, p ) + itauq1 = itaup2 + max( 1_${ik}$, m-p ) + iorbdb = itauq1 + max( 1_${ik}$, q ) + iorgqr = itauq1 + max( 1_${ik}$, q ) + iorglq = itauq1 + max( 1_${ik}$, q ) + lorgqrmin = 1_${ik}$ + lorgqropt = 1_${ik}$ + lorglqmin = 1_${ik}$ + lorglqopt = 1_${ik}$ if( r == q ) then - call stdlib_sorbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,dum1, dum1, dum1, & - dum1, work, -1,childinfo ) - lorbdb = int( work(1),KIND=ilp) - if( wantu1 .and. p > 0 ) then - call stdlib_sorgqr( p, p, q, u1, ldu1, dum1, work(1), -1,childinfo ) + call stdlib${ii}$_sorbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,dum1, dum1, dum1, & + dum1, work, -1_${ik}$,childinfo ) + lorbdb = int( work(1_${ik}$),KIND=${ik}$) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_sorgqr( p, p, q, u1, ldu1, dum1, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) endif - if( wantu2 .and. m-p > 0 ) then - call stdlib_sorgqr( m-p, m-p, q, u2, ldu2, dum1, work(1), -1,childinfo ) + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_sorgqr( m-p, m-p, q, u2, ldu2, dum1, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, m-p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_sorglq( q-1, q-1, q-1, v1t, ldv1t,dum1, work(1), -1, childinfo ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_sorglq( q-1, q-1, q-1, v1t, ldv1t,dum1, work(1_${ik}$), -1_${ik}$, childinfo ) lorglqmin = max( lorglqmin, q-1 ) - lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) + lorglqopt = max( lorglqopt, int( work(1_${ik}$),KIND=${ik}$) ) end if - call stdlib_sbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,dum1, u1, & - ldu1, u2, ldu2, v1t, ldv1t, dum2,1, dum1, dum1, dum1, dum1, dum1,dum1, dum1, & - dum1, work(1), -1, childinfo) - lbbcsd = int( work(1),KIND=ilp) + call stdlib${ii}$_sbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,dum1, u1, & + ldu1, u2, ldu2, v1t, ldv1t, dum2,1_${ik}$, dum1, dum1, dum1, dum1, dum1,dum1, dum1, & + dum1, work(1_${ik}$), -1_${ik}$, childinfo) + lbbcsd = int( work(1_${ik}$),KIND=${ik}$) else if( r == p ) then - call stdlib_sorbdb2( m, p, q, x11, ldx11, x21, ldx21, theta,dum1, dum1, dum1, & - dum1, work(1), -1,childinfo ) - lorbdb = int( work(1),KIND=ilp) - if( wantu1 .and. p > 0 ) then - call stdlib_sorgqr( p-1, p-1, p-1, u1(2,2), ldu1, dum1,work(1), -1, childinfo & + call stdlib${ii}$_sorbdb2( m, p, q, x11, ldx11, x21, ldx21, theta,dum1, dum1, dum1, & + dum1, work(1_${ik}$), -1_${ik}$,childinfo ) + lorbdb = int( work(1_${ik}$),KIND=${ik}$) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_sorgqr( p-1, p-1, p-1, u1(2_${ik}$,2_${ik}$), ldu1, dum1,work(1_${ik}$), -1_${ik}$, childinfo & ) lorgqrmin = max( lorgqrmin, p-1 ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_sorgqr( m-p, m-p, q, u2, ldu2, dum1, work(1), -1,childinfo ) + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_sorgqr( m-p, m-p, q, u2, ldu2, dum1, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, m-p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_sorglq( q, q, r, v1t, ldv1t, dum1, work(1), -1,childinfo ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_sorglq( q, q, r, v1t, ldv1t, dum1, work(1_${ik}$), -1_${ik}$,childinfo ) lorglqmin = max( lorglqmin, q ) - lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) + lorglqopt = max( lorglqopt, int( work(1_${ik}$),KIND=${ik}$) ) end if - call stdlib_sbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,dum1, v1t, & - ldv1t, dum2, 1, u1, ldu1, u2,ldu2, dum1, dum1, dum1, dum1, dum1,dum1, dum1, dum1,& - work(1), -1, childinfo) - lbbcsd = int( work(1),KIND=ilp) + call stdlib${ii}$_sbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,dum1, v1t, & + ldv1t, dum2, 1_${ik}$, u1, ldu1, u2,ldu2, dum1, dum1, dum1, dum1, dum1,dum1, dum1, dum1,& + work(1_${ik}$), -1_${ik}$, childinfo) + lbbcsd = int( work(1_${ik}$),KIND=${ik}$) else if( r == m-p ) then - call stdlib_sorbdb3( m, p, q, x11, ldx11, x21, ldx21, theta,dum1, dum1, dum1, & - dum1, work(1), -1,childinfo ) - lorbdb = int( work(1),KIND=ilp) - if( wantu1 .and. p > 0 ) then - call stdlib_sorgqr( p, p, q, u1, ldu1, dum1, work(1), -1,childinfo ) + call stdlib${ii}$_sorbdb3( m, p, q, x11, ldx11, x21, ldx21, theta,dum1, dum1, dum1, & + dum1, work(1_${ik}$), -1_${ik}$,childinfo ) + lorbdb = int( work(1_${ik}$),KIND=${ik}$) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_sorgqr( p, p, q, u1, ldu1, dum1, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_sorgqr( m-p-1, m-p-1, m-p-1, u2(2,2), ldu2, dum1,work(1), -1, & + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_sorgqr( m-p-1, m-p-1, m-p-1, u2(2_${ik}$,2_${ik}$), ldu2, dum1,work(1_${ik}$), -1_${ik}$, & childinfo ) lorgqrmin = max( lorgqrmin, m-p-1 ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_sorglq( q, q, r, v1t, ldv1t, dum1, work(1), -1,childinfo ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_sorglq( q, q, r, v1t, ldv1t, dum1, work(1_${ik}$), -1_${ik}$,childinfo ) lorglqmin = max( lorglqmin, q ) - lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) - end if - call stdlib_sbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, dum1, & - dum2, 1, v1t, ldv1t, u2, ldu2,u1, ldu1, dum1, dum1, dum1, dum1,dum1, dum1, dum1, & - dum1, work(1), -1,childinfo ) - lbbcsd = int( work(1),KIND=ilp) - else - call stdlib_sorbdb4( m, p, q, x11, ldx11, x21, ldx21, theta,dum1, dum1, dum1, & - dum1, dum1,work(1), -1, childinfo ) - lorbdb = m + int( work(1),KIND=ilp) - if( wantu1 .and. p > 0 ) then - call stdlib_sorgqr( p, p, m-q, u1, ldu1, dum1, work(1), -1,childinfo ) + lorglqopt = max( lorglqopt, int( work(1_${ik}$),KIND=${ik}$) ) + end if + call stdlib${ii}$_sbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, dum1, & + dum2, 1_${ik}$, v1t, ldv1t, u2, ldu2,u1, ldu1, dum1, dum1, dum1, dum1,dum1, dum1, dum1, & + dum1, work(1_${ik}$), -1_${ik}$,childinfo ) + lbbcsd = int( work(1_${ik}$),KIND=${ik}$) + else + call stdlib${ii}$_sorbdb4( m, p, q, x11, ldx11, x21, ldx21, theta,dum1, dum1, dum1, & + dum1, dum1,work(1_${ik}$), -1_${ik}$, childinfo ) + lorbdb = m + int( work(1_${ik}$),KIND=${ik}$) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_sorgqr( p, p, m-q, u1, ldu1, dum1, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_sorgqr( m-p, m-p, m-q, u2, ldu2, dum1, work(1),-1, childinfo ) + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_sorgqr( m-p, m-p, m-q, u2, ldu2, dum1, work(1_${ik}$),-1_${ik}$, childinfo ) lorgqrmin = max( lorgqrmin, m-p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_sorglq( q, q, q, v1t, ldv1t, dum1, work(1), -1,childinfo ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_sorglq( q, q, q, v1t, ldv1t, dum1, work(1_${ik}$), -1_${ik}$,childinfo ) lorglqmin = max( lorglqmin, q ) - lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) + lorglqopt = max( lorglqopt, int( work(1_${ik}$),KIND=${ik}$) ) end if - call stdlib_sbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, dum1, u2, & - ldu2, u1, ldu1, dum2, 1,v1t, ldv1t, dum1, dum1, dum1, dum1,dum1, dum1, dum1, & - dum1, work(1), -1,childinfo ) - lbbcsd = int( work(1),KIND=ilp) + call stdlib${ii}$_sbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, dum1, u2, & + ldu2, u1, ldu1, dum2, 1_${ik}$,v1t, ldv1t, dum1, dum1, dum1, dum1,dum1, dum1, dum1, & + dum1, work(1_${ik}$), -1_${ik}$,childinfo ) + lbbcsd = int( work(1_${ik}$),KIND=${ik}$) end if lworkmin = max( iorbdb+lorbdb-1,iorgqr+lorgqrmin-1,iorglq+lorglqmin-1,ibbcsd+lbbcsd-& - 1 ) + 1_${ik}$ ) lworkopt = max( iorbdb+lorbdb-1,iorgqr+lorgqropt-1,iorglq+lorglqopt-1,ibbcsd+lbbcsd-& - 1 ) - work(1) = lworkopt + 1_${ik}$ ) + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not.lquery ) then - info = -19 + info = -19_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'SORCSD2BY1', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'SORCSD2BY1', -info ) return else if( lquery ) then return @@ -52452,116 +52454,116 @@ module stdlib_linalg_lapack_s if( r == q ) then ! case 1: r = q ! simultaneously bidiagonalize x11 and x21 - call stdlib_sorbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,work(iphi), work(itaup1)& + call stdlib${ii}$_sorbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,work(iphi), work(itaup1)& , work(itaup2),work(itauq1), work(iorbdb), lorbdb, childinfo ) ! accumulate householder reflectors - if( wantu1 .and. p > 0 ) then - call stdlib_slacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) - call stdlib_sorgqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_slacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) + call stdlib${ii}$_sorgqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & childinfo ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_slacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) - call stdlib_sorgqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_slacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) + call stdlib${ii}$_sorgqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & childinfo ) end if - if( wantv1t .and. q > 0 ) then - v1t(1,1) = one + if( wantv1t .and. q > 0_${ik}$ ) then + v1t(1_${ik}$,1_${ik}$) = one do j = 2, q - v1t(1,j) = zero - v1t(j,1) = zero + v1t(1_${ik}$,j) = zero + v1t(j,1_${ik}$) = zero end do - call stdlib_slacpy( 'U', q-1, q-1, x21(1,2), ldx21, v1t(2,2),ldv1t ) - call stdlib_sorglq( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),work(iorglq), & + call stdlib${ii}$_slacpy( 'U', q-1, q-1, x21(1_${ik}$,2_${ik}$), ldx21, v1t(2_${ik}$,2_${ik}$),ldv1t ) + call stdlib${ii}$_sorglq( q-1, q-1, q-1, v1t(2_${ik}$,2_${ik}$), ldv1t, work(itauq1),work(iorglq), & lorglq, childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_sbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,work(iphi), u1, & - ldu1, u2, ldu2, v1t, ldv1t,dum2, 1, work(ib11d), work(ib11e), work(ib12d),work(& + call stdlib${ii}$_sbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,work(iphi), u1, & + ldu1, u2, ldu2, v1t, ldv1t,dum2, 1_${ik}$, work(ib11d), work(ib11e), work(ib12d),work(& ib12e), work(ib21d), work(ib21e),work(ib22d), work(ib22e), work(ibbcsd), lbbcsd,& childinfo ) ! permute rows and columns to place zero submatrices in ! preferred positions - if( q > 0 .and. wantu2 ) then + if( q > 0_${ik}$ .and. wantu2 ) then do i = 1, q iwork(i) = m - p - q + i end do do i = q + 1, m - p iwork(i) = i - q end do - call stdlib_slapmt( .false., m-p, m-p, u2, ldu2, iwork ) + call stdlib${ii}$_slapmt( .false., m-p, m-p, u2, ldu2, iwork ) end if else if( r == p ) then ! case 2: r = p ! simultaneously bidiagonalize x11 and x21 - call stdlib_sorbdb2( m, p, q, x11, ldx11, x21, ldx21, theta,work(iphi), work(itaup1)& + call stdlib${ii}$_sorbdb2( m, p, q, x11, ldx11, x21, ldx21, theta,work(iphi), work(itaup1)& , work(itaup2),work(itauq1), work(iorbdb), lorbdb, childinfo ) ! accumulate householder reflectors - if( wantu1 .and. p > 0 ) then - u1(1,1) = one + if( wantu1 .and. p > 0_${ik}$ ) then + u1(1_${ik}$,1_${ik}$) = one do j = 2, p - u1(1,j) = zero - u1(j,1) = zero + u1(1_${ik}$,j) = zero + u1(j,1_${ik}$) = zero end do - call stdlib_slacpy( 'L', p-1, p-1, x11(2,1), ldx11, u1(2,2), ldu1 ) - call stdlib_sorgqr( p-1, p-1, p-1, u1(2,2), ldu1, work(itaup1),work(iorgqr), & + call stdlib${ii}$_slacpy( 'L', p-1, p-1, x11(2_${ik}$,1_${ik}$), ldx11, u1(2_${ik}$,2_${ik}$), ldu1 ) + call stdlib${ii}$_sorgqr( p-1, p-1, p-1, u1(2_${ik}$,2_${ik}$), ldu1, work(itaup1),work(iorgqr), & lorgqr, childinfo ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_slacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) - call stdlib_sorgqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_slacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) + call stdlib${ii}$_sorgqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & childinfo ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_slacpy( 'U', p, q, x11, ldx11, v1t, ldv1t ) - call stdlib_sorglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_slacpy( 'U', p, q, x11, ldx11, v1t, ldv1t ) + call stdlib${ii}$_sorglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_sbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,work(iphi), v1t, & - ldv1t, dum1, 1, u1, ldu1, u2,ldu2, work(ib11d), work(ib11e), work(ib12d),work(ib12e)& + call stdlib${ii}$_sbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,work(iphi), v1t, & + ldv1t, dum1, 1_${ik}$, u1, ldu1, u2,ldu2, work(ib11d), work(ib11e), work(ib12d),work(ib12e)& , work(ib21d), work(ib21e),work(ib22d), work(ib22e), work(ibbcsd), lbbcsd,childinfo & ) ! permute rows and columns to place identity submatrices in ! preferred positions - if( q > 0 .and. wantu2 ) then + if( q > 0_${ik}$ .and. wantu2 ) then do i = 1, q iwork(i) = m - p - q + i end do do i = q + 1, m - p iwork(i) = i - q end do - call stdlib_slapmt( .false., m-p, m-p, u2, ldu2, iwork ) + call stdlib${ii}$_slapmt( .false., m-p, m-p, u2, ldu2, iwork ) end if else if( r == m-p ) then ! case 3: r = m-p ! simultaneously bidiagonalize x11 and x21 - call stdlib_sorbdb3( m, p, q, x11, ldx11, x21, ldx21, theta,work(iphi), work(itaup1)& + call stdlib${ii}$_sorbdb3( m, p, q, x11, ldx11, x21, ldx21, theta,work(iphi), work(itaup1)& , work(itaup2),work(itauq1), work(iorbdb), lorbdb, childinfo ) ! accumulate householder reflectors - if( wantu1 .and. p > 0 ) then - call stdlib_slacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) - call stdlib_sorgqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_slacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) + call stdlib${ii}$_sorgqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & childinfo ) end if - if( wantu2 .and. m-p > 0 ) then - u2(1,1) = one + if( wantu2 .and. m-p > 0_${ik}$ ) then + u2(1_${ik}$,1_${ik}$) = one do j = 2, m-p - u2(1,j) = zero - u2(j,1) = zero + u2(1_${ik}$,j) = zero + u2(j,1_${ik}$) = zero end do - call stdlib_slacpy( 'L', m-p-1, m-p-1, x21(2,1), ldx21, u2(2,2),ldu2 ) - call stdlib_sorgqr( m-p-1, m-p-1, m-p-1, u2(2,2), ldu2,work(itaup2), work(iorgqr)& + call stdlib${ii}$_slacpy( 'L', m-p-1, m-p-1, x21(2_${ik}$,1_${ik}$), ldx21, u2(2_${ik}$,2_${ik}$),ldu2 ) + call stdlib${ii}$_sorgqr( m-p-1, m-p-1, m-p-1, u2(2_${ik}$,2_${ik}$), ldu2,work(itaup2), work(iorgqr)& , lorgqr, childinfo ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_slacpy( 'U', m-p, q, x21, ldx21, v1t, ldv1t ) - call stdlib_sorglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_slacpy( 'U', m-p, q, x21, ldx21, v1t, ldv1t ) + call stdlib${ii}$_sorglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_sbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, work(iphi), & - dum1, 1, v1t, ldv1t, u2,ldu2, u1, ldu1, work(ib11d), work(ib11e),work(ib12d), work(& + call stdlib${ii}$_sbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, work(iphi), & + dum1, 1_${ik}$, v1t, ldv1t, u2,ldu2, u1, ldu1, work(ib11d), work(ib11e),work(ib12d), work(& ib12e), work(ib21d),work(ib21e), work(ib22d), work(ib22e),work(ibbcsd), lbbcsd, & childinfo ) ! permute rows and columns to place identity submatrices in @@ -52574,51 +52576,51 @@ module stdlib_linalg_lapack_s iwork(i) = i - r end do if( wantu1 ) then - call stdlib_slapmt( .false., p, q, u1, ldu1, iwork ) + call stdlib${ii}$_slapmt( .false., p, q, u1, ldu1, iwork ) end if if( wantv1t ) then - call stdlib_slapmr( .false., q, q, v1t, ldv1t, iwork ) + call stdlib${ii}$_slapmr( .false., q, q, v1t, ldv1t, iwork ) end if end if else ! case 4: r = m-q ! simultaneously bidiagonalize x11 and x21 - call stdlib_sorbdb4( m, p, q, x11, ldx11, x21, ldx21, theta,work(iphi), work(itaup1)& + call stdlib${ii}$_sorbdb4( m, p, q, x11, ldx11, x21, ldx21, theta,work(iphi), work(itaup1)& , work(itaup2),work(itauq1), work(iorbdb), work(iorbdb+m),lorbdb-m, childinfo ) ! accumulate householder reflectors - if( wantu2 .and. m-p > 0 ) then - call stdlib_scopy( m-p, work(iorbdb+p), 1, u2, 1 ) + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_scopy( m-p, work(iorbdb+p), 1_${ik}$, u2, 1_${ik}$ ) end if - if( wantu1 .and. p > 0 ) then - call stdlib_scopy( p, work(iorbdb), 1, u1, 1 ) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_scopy( p, work(iorbdb), 1_${ik}$, u1, 1_${ik}$ ) do j = 2, p - u1(1,j) = zero + u1(1_${ik}$,j) = zero end do - call stdlib_slacpy( 'L', p-1, m-q-1, x11(2,1), ldx11, u1(2,2),ldu1 ) - call stdlib_sorgqr( p, p, m-q, u1, ldu1, work(itaup1),work(iorgqr), lorgqr, & + call stdlib${ii}$_slacpy( 'L', p-1, m-q-1, x11(2_${ik}$,1_${ik}$), ldx11, u1(2_${ik}$,2_${ik}$),ldu1 ) + call stdlib${ii}$_sorgqr( p, p, m-q, u1, ldu1, work(itaup1),work(iorgqr), lorgqr, & childinfo ) end if - if( wantu2 .and. m-p > 0 ) then + if( wantu2 .and. m-p > 0_${ik}$ ) then do j = 2, m-p - u2(1,j) = zero + u2(1_${ik}$,j) = zero end do - call stdlib_slacpy( 'L', m-p-1, m-q-1, x21(2,1), ldx21, u2(2,2),ldu2 ) - call stdlib_sorgqr( m-p, m-p, m-q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & + call stdlib${ii}$_slacpy( 'L', m-p-1, m-q-1, x21(2_${ik}$,1_${ik}$), ldx21, u2(2_${ik}$,2_${ik}$),ldu2 ) + call stdlib${ii}$_sorgqr( m-p, m-p, m-q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & childinfo ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_slacpy( 'U', m-q, q, x21, ldx21, v1t, ldv1t ) - call stdlib_slacpy( 'U', p-(m-q), q-(m-q), x11(m-q+1,m-q+1), ldx11,v1t(m-q+1,m-q+& - 1), ldv1t ) - call stdlib_slacpy( 'U', -p+q, q-p, x21(m-q+1,p+1), ldx21,v1t(p+1,p+1), ldv1t ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_slacpy( 'U', m-q, q, x21, ldx21, v1t, ldv1t ) + call stdlib${ii}$_slacpy( 'U', p-(m-q), q-(m-q), x11(m-q+1,m-q+1), ldx11,v1t(m-q+1,m-q+& + 1_${ik}$), ldv1t ) + call stdlib${ii}$_slacpy( 'U', -p+q, q-p, x21(m-q+1,p+1), ldx21,v1t(p+1,p+1), ldv1t ) - call stdlib_sorglq( q, q, q, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & + call stdlib${ii}$_sorglq( q, q, q, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_sbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, work(iphi), & - u2, ldu2, u1, ldu1, dum1, 1,v1t, ldv1t, work(ib11d), work(ib11e), work(ib12d),work(& + call stdlib${ii}$_sbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, work(iphi), & + u2, ldu2, u1, ldu1, dum1, 1_${ik}$,v1t, ldv1t, work(ib11d), work(ib11e), work(ib12d),work(& ib12e), work(ib21d), work(ib21e),work(ib22d), work(ib22e), work(ibbcsd), lbbcsd,& childinfo ) ! permute rows and columns to place identity submatrices in @@ -52631,18 +52633,18 @@ module stdlib_linalg_lapack_s iwork(i) = i - r end do if( wantu1 ) then - call stdlib_slapmt( .false., p, p, u1, ldu1, iwork ) + call stdlib${ii}$_slapmt( .false., p, p, u1, ldu1, iwork ) end if if( wantv1t ) then - call stdlib_slapmr( .false., p, q, v1t, ldv1t, iwork ) + call stdlib${ii}$_slapmr( .false., p, q, v1t, ldv1t, iwork ) end if end if end if return - end subroutine stdlib_sorcsd2by1 + end subroutine stdlib${ii}$_sorcsd2by1 - pure subroutine stdlib_sorgtr( uplo, n, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_sorgtr( uplo, n, a, lda, tau, work, lwork, info ) !! SORGTR generates a real orthogonal matrix Q which is defined as the !! product of n-1 elementary reflectors of order N, as returned by !! SSYTRD: @@ -52653,8 +52655,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) :: lda, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, lwork, n ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(in) :: tau(*) @@ -52663,45 +52665,45 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: lquery, upper - integer(ilp) :: i, iinfo, j, lwkopt, nb + integer(${ik}$) :: i, iinfo, j, lwkopt, nb ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${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 + if( n>1_${ik}$ ) then ! generate q(2:n,2:n) - call stdlib_sorgqr( n-1, n-1, n-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) + call stdlib${ii}$_sorgqr( n-1, n-1, n-1, a( 2_${ik}$, 2_${ik}$ ), lda, tau, work,lwork, iinfo ) end if end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_sorgtr + end subroutine stdlib${ii}$_sorgtr - pure subroutine stdlib_sorgtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) + pure subroutine stdlib${ii}$_sorgtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) !! SORGTSQR generates an M-by-N real matrix Q_out with orthonormal columns, !! which are the first N columns of a product of real orthogonal !! matrices of order M which are returned by SLATSQR @@ -52753,8 +52755,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,*) @@ -52763,85 +52765,85 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: lquery - integer(ilp) :: iinfo, ldc, lworkopt, lc, lw, nblocal, j + integer(${ik}$) :: iinfo, ldc, lworkopt, lc, lw, nblocal, j ! Intrinsic Functions intrinsic :: real,max,min ! Executable Statements ! test the input parameters - lquery = lwork==-1 - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 .or. mkd ) then + if( nb<=1_${ik}$ .or. nb>kd ) then ! use unblocked code - call stdlib_spbtf2( uplo, n, kd, ab, ldab, info ) + call stdlib${ii}$_spbtf2( uplo, n, kd, ab, ldab, info ) else ! use blocked code if( stdlib_lsame( uplo, 'U' ) ) then @@ -53028,9 +53030,9 @@ module stdlib_linalg_lapack_s loop_70: do i = 1, n, nb ib = min( nb, n-i+1 ) ! factorize the diagonal block - call stdlib_spotf2( uplo, ib, ab( kd+1, i ), ldab-1, ii ) - if( ii/=0 ) then - info = i + ii - 1 + call stdlib${ii}$_spotf2( uplo, ib, ab( kd+1, i ), ldab-1, ii ) + if( ii/=0_${ik}$ ) then + info = i + ii - 1_${ik}$ go to 150 end if if( i+ib<=n ) then @@ -53047,15 +53049,15 @@ module stdlib_linalg_lapack_s ! lies outside the band. i2 = min( kd-ib, n-i-ib+1 ) i3 = min( ib, n-i-kd+1 ) - if( i2>0 ) then + if( i2>0_${ik}$ ) then ! update a12 - call stdlib_strsm( 'LEFT', 'UPPER', 'TRANSPOSE','NON-UNIT', ib, i2, one,& + call stdlib${ii}$_strsm( 'LEFT', 'UPPER', 'TRANSPOSE','NON-UNIT', ib, i2, one,& ab( kd+1, i ),ldab-1, ab( kd+1-ib, i+ib ), ldab-1 ) ! update a22 - call stdlib_ssyrk( 'UPPER', 'TRANSPOSE', i2, ib, -one,ab( kd+1-ib, i+ib & + call stdlib${ii}$_ssyrk( 'UPPER', 'TRANSPOSE', i2, ib, -one,ab( kd+1-ib, i+ib & ), ldab-1, one,ab( kd+1, i+ib ), ldab-1 ) end if - if( i3>0 ) then + if( i3>0_${ik}$ ) then ! copy the lower triangle of a13 into the work array. do jj = 1, i3 do ii = jj, ib @@ -53063,14 +53065,14 @@ module stdlib_linalg_lapack_s end do end do ! update a13 (in the work array). - call stdlib_strsm( 'LEFT', 'UPPER', 'TRANSPOSE','NON-UNIT', ib, i3, one,& + call stdlib${ii}$_strsm( 'LEFT', 'UPPER', 'TRANSPOSE','NON-UNIT', ib, i3, one,& ab( kd+1, i ),ldab-1, work, ldwork ) ! update a23 - if( i2>0 )call stdlib_sgemm( 'TRANSPOSE', 'NO TRANSPOSE', i2, i3,ib, -& - one, ab( kd+1-ib, i+ib ),ldab-1, work, ldwork, one,ab( 1+ib, i+kd ), & + if( i2>0_${ik}$ )call stdlib${ii}$_sgemm( 'TRANSPOSE', 'NO TRANSPOSE', i2, i3,ib, -& + one, ab( kd+1-ib, i+ib ),ldab-1, work, ldwork, one,ab( 1_${ik}$+ib, i+kd ), & ldab-1 ) ! update a33 - call stdlib_ssyrk( 'UPPER', 'TRANSPOSE', i3, ib, -one,work, ldwork, one,& + call stdlib${ii}$_ssyrk( 'UPPER', 'TRANSPOSE', i3, ib, -one,work, ldwork, one,& ab( kd+1, i+kd ),ldab-1 ) ! copy the lower triangle of a13 back into place. do jj = 1, i3 @@ -53095,9 +53097,9 @@ module stdlib_linalg_lapack_s loop_140: do i = 1, n, nb ib = min( nb, n-i+1 ) ! factorize the diagonal block - call stdlib_spotf2( uplo, ib, ab( 1, i ), ldab-1, ii ) - if( ii/=0 ) then - info = i + ii - 1 + call stdlib${ii}$_spotf2( uplo, ib, ab( 1_${ik}$, i ), ldab-1, ii ) + if( ii/=0_${ik}$ ) then + info = i + ii - 1_${ik}$ go to 150 end if if( i+ib<=n ) then @@ -53114,15 +53116,15 @@ module stdlib_linalg_lapack_s ! lies outside the band. i2 = min( kd-ib, n-i-ib+1 ) i3 = min( ib, n-i-kd+1 ) - if( i2>0 ) then + if( i2>0_${ik}$ ) then ! update a21 - call stdlib_strsm( 'RIGHT', 'LOWER', 'TRANSPOSE','NON-UNIT', i2, ib, & - one, ab( 1, i ),ldab-1, ab( 1+ib, i ), ldab-1 ) + call stdlib${ii}$_strsm( 'RIGHT', 'LOWER', 'TRANSPOSE','NON-UNIT', i2, ib, & + one, ab( 1_${ik}$, i ),ldab-1, ab( 1_${ik}$+ib, i ), ldab-1 ) ! update a22 - call stdlib_ssyrk( 'LOWER', 'NO TRANSPOSE', i2, ib, -one,ab( 1+ib, i ), & - ldab-1, one,ab( 1, i+ib ), ldab-1 ) + call stdlib${ii}$_ssyrk( 'LOWER', 'NO TRANSPOSE', i2, ib, -one,ab( 1_${ik}$+ib, i ), & + ldab-1, one,ab( 1_${ik}$, i+ib ), ldab-1 ) end if - if( i3>0 ) then + if( i3>0_${ik}$ ) then ! copy the upper triangle of a31 into the work array. do jj = 1, ib do ii = 1, min( jj, i3 ) @@ -53130,15 +53132,15 @@ module stdlib_linalg_lapack_s end do end do ! update a31 (in the work array). - call stdlib_strsm( 'RIGHT', 'LOWER', 'TRANSPOSE','NON-UNIT', i3, ib, & - one, ab( 1, i ),ldab-1, work, ldwork ) + call stdlib${ii}$_strsm( 'RIGHT', 'LOWER', 'TRANSPOSE','NON-UNIT', i3, ib, & + one, ab( 1_${ik}$, i ),ldab-1, work, ldwork ) ! update a32 - if( i2>0 )call stdlib_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', i3, i2,ib, -& - one, work, ldwork,ab( 1+ib, i ), ldab-1, one,ab( 1+kd-ib, i+ib ), ldab-& - 1 ) + if( i2>0_${ik}$ )call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', i3, i2,ib, -& + one, work, ldwork,ab( 1_${ik}$+ib, i ), ldab-1, one,ab( 1_${ik}$+kd-ib, i+ib ), ldab-& + 1_${ik}$ ) ! update a33 - call stdlib_ssyrk( 'LOWER', 'NO TRANSPOSE', i3, ib, -one,work, ldwork, & - one, ab( 1, i+kd ),ldab-1 ) + call stdlib${ii}$_ssyrk( 'LOWER', 'NO TRANSPOSE', i3, ib, -one,work, ldwork, & + one, ab( 1_${ik}$, i+kd ),ldab-1 ) ! copy the upper triangle of a31 back into place. do jj = 1, ib do ii = 1, min( jj, i3 ) @@ -53153,10 +53155,10 @@ module stdlib_linalg_lapack_s return 150 continue return - end subroutine stdlib_spbtrf + end subroutine stdlib${ii}$_spbtrf - pure subroutine stdlib_spftri( transr, uplo, n, a, info ) + pure subroutine stdlib${ii}$_spftri( transr, uplo, n, a, info ) !! SPFTRI computes the inverse of a real (symmetric) positive definite !! matrix A using the Cholesky factorization A = U**T*U or A = L*L**T !! computed by SPFTRF. @@ -53165,52 +53167,52 @@ 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 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n ! Array Arguments - real(sp), intent(inout) :: a(0:*) + real(sp), intent(inout) :: a(0_${ik}$:*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, nisodd, normaltransr - integer(ilp) :: n1, n2, k + integer(${ik}$) :: n1, n2, k ! Intrinsic Functions intrinsic :: 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 + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'SPFTRI', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'SPFTRI', -info ) return end if ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. - call stdlib_stftri( transr, uplo, 'N', n, a, info ) + call stdlib${ii}$_stftri( transr, uplo, 'N', n, a, info ) if( info>0 )return ! if n is odd, set nisodd = .true. ! if n is even, set k = n/2 and nisodd = .false. - if( mod( n, 2 )==0 ) then - k = n / 2 + if( mod( n, 2_${ik}$ )==0_${ik}$ ) then + k = n / 2_${ik}$ nisodd = .false. else nisodd = .true. end if ! set n1 and n2 depending on lower if( lower ) then - n2 = n / 2 + n2 = n / 2_${ik}$ n1 = n - n2 else - n1 = n / 2 + n1 = n / 2_${ik}$ n2 = n - n1 end if ! start execution of triangular matrix multiply: inv(u)*inv(u)^c or @@ -53223,41 +53225,41 @@ module stdlib_linalg_lapack_s ! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) ) ! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) - call stdlib_slauum( 'L', n1, a( 0 ), n, info ) - call stdlib_ssyrk( 'L', 'T', n1, n2, one, a( n1 ), n, one,a( 0 ), n ) - call stdlib_strmm( 'L', 'U', 'N', 'N', n2, n1, one, a( n ), n,a( n1 ), n ) + call stdlib${ii}$_slauum( 'L', n1, a( 0_${ik}$ ), n, info ) + call stdlib${ii}$_ssyrk( 'L', 'T', n1, n2, one, a( n1 ), n, one,a( 0_${ik}$ ), n ) + call stdlib${ii}$_strmm( 'L', 'U', 'N', 'N', n2, n1, one, a( n ), n,a( n1 ), n ) - call stdlib_slauum( 'U', n2, a( n ), n, info ) + call stdlib${ii}$_slauum( 'U', n2, a( n ), n, info ) else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) - call stdlib_slauum( 'L', n1, a( n2 ), n, info ) - call stdlib_ssyrk( 'L', 'N', n1, n2, one, a( 0 ), n, one,a( n2 ), n ) - call stdlib_strmm( 'R', 'U', 'T', 'N', n1, n2, one, a( n1 ), n,a( 0 ), n ) + call stdlib${ii}$_slauum( 'L', n1, a( n2 ), n, info ) + call stdlib${ii}$_ssyrk( 'L', 'N', n1, n2, one, a( 0_${ik}$ ), n, one,a( n2 ), n ) + call stdlib${ii}$_strmm( 'R', 'U', 'T', 'N', n1, n2, one, a( n1 ), n,a( 0_${ik}$ ), n ) - call stdlib_slauum( 'U', n2, a( n1 ), n, info ) + call stdlib${ii}$_slauum( 'U', n2, a( n1 ), n, info ) end if else ! n is odd and transr = 't' if( lower ) then ! srpa for lower, transpose, and n is odd ! t1 -> a(0), t2 -> a(1), s -> a(0+n1*n1) - call stdlib_slauum( 'U', n1, a( 0 ), n1, info ) - call stdlib_ssyrk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0 ), n1 ) + call stdlib${ii}$_slauum( 'U', n1, a( 0_${ik}$ ), n1, info ) + call stdlib${ii}$_ssyrk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0_${ik}$ ), n1 ) - call stdlib_strmm( 'R', 'L', 'N', 'N', n1, n2, one, a( 1 ), n1,a( n1*n1 ), n1 & + call stdlib${ii}$_strmm( 'R', 'L', 'N', 'N', n1, n2, one, a( 1_${ik}$ ), n1,a( n1*n1 ), n1 & ) - call stdlib_slauum( 'L', n2, a( 1 ), n1, info ) + call stdlib${ii}$_slauum( 'L', n2, a( 1_${ik}$ ), n1, info ) else ! srpa for upper, transpose, and n is odd ! t1 -> a(0+n2*n2), t2 -> a(0+n1*n2), s -> a(0) - call stdlib_slauum( 'U', n1, a( n2*n2 ), n2, info ) - call stdlib_ssyrk( 'U', 'T', n1, n2, one, a( 0 ), n2, one,a( n2*n2 ), n2 ) + call stdlib${ii}$_slauum( 'U', n1, a( n2*n2 ), n2, info ) + call stdlib${ii}$_ssyrk( 'U', 'T', n1, n2, one, a( 0_${ik}$ ), n2, one,a( n2*n2 ), n2 ) - call stdlib_strmm( 'L', 'L', 'T', 'N', n2, n1, one, a( n1*n2 ),n2, a( 0 ), n2 & + call stdlib${ii}$_strmm( 'L', 'L', 'T', 'N', n2, n1, one, a( n1*n2 ),n2, a( 0_${ik}$ ), n2 & ) - call stdlib_slauum( 'L', n2, a( n1*n2 ), n2, info ) + call stdlib${ii}$_slauum( 'L', n2, a( n1*n2 ), n2, info ) end if end if else @@ -53268,22 +53270,22 @@ module stdlib_linalg_lapack_s ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) - call stdlib_slauum( 'L', k, a( 1 ), n+1, info ) - call stdlib_ssyrk( 'L', 'T', k, k, one, a( k+1 ), n+1, one,a( 1 ), n+1 ) + call stdlib${ii}$_slauum( 'L', k, a( 1_${ik}$ ), n+1, info ) + call stdlib${ii}$_ssyrk( 'L', 'T', k, k, one, a( k+1 ), n+1, one,a( 1_${ik}$ ), n+1 ) - call stdlib_strmm( 'L', 'U', 'N', 'N', k, k, one, a( 0 ), n+1,a( k+1 ), n+1 ) + call stdlib${ii}$_strmm( 'L', 'U', 'N', 'N', k, k, one, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 ) - call stdlib_slauum( 'U', k, a( 0 ), n+1, info ) + call stdlib${ii}$_slauum( 'U', k, a( 0_${ik}$ ), n+1, info ) else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) - call stdlib_slauum( 'L', k, a( k+1 ), n+1, info ) - call stdlib_ssyrk( 'L', 'N', k, k, one, a( 0 ), n+1, one,a( k+1 ), n+1 ) + call stdlib${ii}$_slauum( 'L', k, a( k+1 ), n+1, info ) + call stdlib${ii}$_ssyrk( 'L', 'N', k, k, one, a( 0_${ik}$ ), n+1, one,a( k+1 ), n+1 ) - call stdlib_strmm( 'R', 'U', 'T', 'N', k, k, one, a( k ), n+1,a( 0 ), n+1 ) + call stdlib${ii}$_strmm( 'R', 'U', 'T', 'N', k, k, one, a( k ), n+1,a( 0_${ik}$ ), n+1 ) - call stdlib_slauum( 'U', k, a( k ), n+1, info ) + call stdlib${ii}$_slauum( 'U', k, a( k ), n+1, info ) end if else ! n is even and transr = 't' @@ -53291,30 +53293,30 @@ module stdlib_linalg_lapack_s ! srpa for lower, transpose, and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1), ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k - call stdlib_slauum( 'U', k, a( k ), k, info ) - call stdlib_ssyrk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k ) + call stdlib${ii}$_slauum( 'U', k, a( k ), k, info ) + call stdlib${ii}$_ssyrk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k ) - call stdlib_strmm( 'R', 'L', 'N', 'N', k, k, one, a( 0 ), k,a( k*( k+1 ) ), k & + call stdlib${ii}$_strmm( 'R', 'L', 'N', 'N', k, k, one, a( 0_${ik}$ ), k,a( k*( k+1 ) ), k & ) - call stdlib_slauum( 'L', k, a( 0 ), k, info ) + call stdlib${ii}$_slauum( 'L', k, a( 0_${ik}$ ), k, info ) else ! srpa for upper, transpose, and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0), ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k - call stdlib_slauum( 'U', k, a( k*( k+1 ) ), k, info ) - call stdlib_ssyrk( 'U', 'T', k, k, one, a( 0 ), k, one,a( k*( k+1 ) ), k ) + call stdlib${ii}$_slauum( 'U', k, a( k*( k+1 ) ), k, info ) + call stdlib${ii}$_ssyrk( 'U', 'T', k, k, one, a( 0_${ik}$ ), k, one,a( k*( k+1 ) ), k ) - call stdlib_strmm( 'L', 'L', 'T', 'N', k, k, one, a( k*k ), k,a( 0 ), k ) + call stdlib${ii}$_strmm( 'L', 'L', 'T', 'N', k, k, one, a( k*k ), k,a( 0_${ik}$ ), k ) - call stdlib_slauum( 'L', k, a( k*k ), k, info ) + call stdlib${ii}$_slauum( 'L', k, a( k*k ), k, info ) end if end if end if return - end subroutine stdlib_spftri + end subroutine stdlib${ii}$_spftri - pure subroutine stdlib_spotrf( uplo, n, a, lda, info ) + pure subroutine stdlib${ii}$_spotrf( uplo, n, a, lda, info ) !! SPOTRF computes the Cholesky factorization of a real symmetric !! positive definite matrix A. !! The factorization has the form @@ -53327,39 +53329,39 @@ 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 real(sp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: j, jb, nb + integer(${ik}$) :: j, jb, nb ! Intrinsic Functions intrinsic :: max,min ! 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}$, 'SPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code. - call stdlib_spotrf2( uplo, n, a, lda, info ) + call stdlib${ii}$_spotrf2( uplo, n, a, lda, info ) else ! use blocked code. if( upper ) then @@ -53368,15 +53370,15 @@ module stdlib_linalg_lapack_s ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) - call stdlib_ssyrk( 'UPPER', 'TRANSPOSE', jb, j-1, -one,a( 1, j ), lda, one, a(& + call stdlib${ii}$_ssyrk( 'UPPER', 'TRANSPOSE', jb, j-1, -one,a( 1_${ik}$, j ), lda, one, a(& j, j ), lda ) - call stdlib_spotrf2( 'UPPER', jb, a( j, j ), lda, info ) + call stdlib${ii}$_spotrf2( 'UPPER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block row. - call stdlib_sgemm( 'TRANSPOSE', 'NO TRANSPOSE', jb, n-j-jb+1,j-1, -one, a( & - 1, j ), lda, a( 1, j+jb ),lda, one, a( j, j+jb ), lda ) - call stdlib_strsm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',jb, n-j-jb+1, & + call stdlib${ii}$_sgemm( 'TRANSPOSE', 'NO TRANSPOSE', jb, n-j-jb+1,j-1, -one, a( & + 1_${ik}$, j ), lda, a( 1_${ik}$, j+jb ),lda, one, a( j, j+jb ), lda ) + call stdlib${ii}$_strsm( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT',jb, n-j-jb+1, & one, a( j, j ), lda,a( j, j+jb ), lda ) end if end do @@ -53386,15 +53388,15 @@ module stdlib_linalg_lapack_s ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) - call stdlib_ssyrk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1 ), lda, one,& + call stdlib${ii}$_ssyrk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1_${ik}$ ), lda, one,& a( j, j ), lda ) - call stdlib_spotrf2( 'LOWER', jb, a( j, j ), lda, info ) + call stdlib${ii}$_spotrf2( 'LOWER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block column. - call stdlib_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,j-1, -one, a( & - j+jb, 1 ), lda, a( j, 1 ),lda, one, a( j+jb, j ), lda ) - call stdlib_strsm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'NON-UNIT',n-j-jb+1, jb, & + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,j-1, -one, a( & + j+jb, 1_${ik}$ ), lda, a( j, 1_${ik}$ ),lda, one, a( j+jb, j ), lda ) + call stdlib${ii}$_strsm( 'RIGHT', 'LOWER', 'TRANSPOSE', 'NON-UNIT',n-j-jb+1, jb, & one, a( j, j ), lda,a( j+jb, j ), lda ) end if end do @@ -53402,13 +53404,13 @@ module stdlib_linalg_lapack_s end if go to 40 30 continue - info = info + j - 1 + info = info + j - 1_${ik}$ 40 continue return - end subroutine stdlib_spotrf + end subroutine stdlib${ii}$_spotrf - pure subroutine stdlib_sptrfs( n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr,berr, work, info ) + pure subroutine stdlib${ii}$_sptrfs( n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr,berr, work, info ) !! SPTRFS improves the computed solution to a system of linear !! equations when the coefficient matrix is symmetric positive definite !! and tridiagonal, and provides error bounds and backward error @@ -53418,43 +53420,43 @@ 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) :: ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs ! Array Arguments real(sp), intent(in) :: b(ldb,*), d(*), df(*), e(*), ef(*) 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}$ ! Local Scalars - integer(ilp) :: count, i, ix, j, nz + integer(${ik}$) :: count, i, ix, j, nz real(sp) :: bi, cx, dx, eps, ex, lstres, s, safe1, safe2, safmin ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements ! test the input parameters. - info = 0 - if( n<0 ) then - info = -1 - else if( nrhs<0 ) then - info = -2 - else if( ldbeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_spttrs( n, 1, df, ef, work( n+1 ), n, info ) - call stdlib_saxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) + call stdlib${ii}$_spttrs( n, 1_${ik}$, df, ef, work( n+1 ), n, info ) + call stdlib${ii}$_saxpy( n, one, work( n+1 ), 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -53549,7 +53551,7 @@ module stdlib_linalg_lapack_s work( i ) = abs( work( n+i ) ) + nz*eps*work( i ) + safe1 end if end do - ix = stdlib_isamax( n, work, 1 ) + ix = stdlib${ii}$_isamax( n, work, 1_${ik}$ ) ferr( j ) = work( ix ) ! estimate the norm of inv(a). ! solve m(a) * x = e, where m(a) = (m(i,j)) is given by @@ -53557,7 +53559,7 @@ module stdlib_linalg_lapack_s ! m(i,j) = -abs(a(i,j)), i .ne. j, ! and e = [ 1, 1, ..., 1 ]**t. note m(a) = m(l)*d*m(l)**t. ! solve m(l) * x = e. - work( 1 ) = one + work( 1_${ik}$ ) = one do i = 2, n work( i ) = one + work( i-1 )*abs( ef( i-1 ) ) end do @@ -53567,7 +53569,7 @@ module stdlib_linalg_lapack_s work( i ) = work( i ) / df( i ) + work( i+1 )*abs( ef( i ) ) end do ! compute norm(inv(a)) = max(x(i)), 1<=i<=n. - ix = stdlib_isamax( n, work, 1 ) + ix = stdlib${ii}$_isamax( n, work, 1_${ik}$ ) ferr( j ) = ferr( j )*abs( work( ix ) ) ! normalize error. lstres = zero @@ -53577,10 +53579,10 @@ module stdlib_linalg_lapack_s if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_90 return - end subroutine stdlib_sptrfs + end subroutine stdlib${ii}$_sptrfs - pure subroutine stdlib_sptsv( n, nrhs, d, e, b, ldb, info ) + pure subroutine stdlib${ii}$_sptsv( n, nrhs, d, e, b, ldb, info ) !! SPTSV computes the solution to a real system of linear equations !! A*X = B, where A is an N-by-N symmetric positive definite tridiagonal !! matrix, and X and B are N-by-NRHS matrices. @@ -53590,8 +53592,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) :: ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments real(sp), intent(inout) :: b(ldb,*), d(*), e(*) ! ===================================================================== @@ -53599,29 +53601,29 @@ module stdlib_linalg_lapack_s intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 - if( n<0 ) then - info = -1 - else if( nrhs<0 ) then - info = -2 - else if( ldb1 )call stdlib_scopy( n-1, e, 1, ef, 1 ) - call stdlib_spttrf( n, df, ef, info ) + call stdlib${ii}$_scopy( n, d, 1_${ik}$, df, 1_${ik}$ ) + if( n>1_${ik}$ )call stdlib${ii}$_scopy( n-1, e, 1_${ik}$, ef, 1_${ik}$ ) + call stdlib${ii}$_spttrf( n, df, ef, info ) ! return if info is non-zero. - if( info>0 )then + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_slanst( '1', n, d, e ) + anorm = stdlib${ii}$_slanst( '1', n, d, e ) ! compute the reciprocal of the condition number of a. - call stdlib_sptcon( n, df, ef, anorm, rcond, work, info ) + call stdlib${ii}$_sptcon( n, df, ef, anorm, rcond, work, info ) ! compute the solution vectors x. - call stdlib_slacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_spttrs( n, nrhs, df, ef, x, ldx, info ) + call stdlib${ii}$_slacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_spttrs( n, nrhs, df, ef, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_sptrfs( n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr, berr,work, info ) + call stdlib${ii}$_sptrfs( n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr, berr,work, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcondzero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then - call stdlib_slascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_slascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) else - call stdlib_slascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_slascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) end if end if - ! call stdlib_ssbtrd to reduce symmetric band matrix to tridiagonal form. - inde = 1 + ! call stdlib${ii}$_ssbtrd to reduce symmetric band matrix to tridiagonal form. + inde = 1_${ik}$ indwrk = inde + n - call stdlib_ssbtrd( jobz, uplo, n, kd, ab, ldab, w, work( inde ), z, ldz,work( indwrk )& + call stdlib${ii}$_ssbtrd( jobz, uplo, n, kd, ab, ldab, w, work( inde ), z, ldz,work( indwrk )& , iinfo ) - ! for eigenvalues only, call stdlib_ssterf. for eigenvectors, call stdlib_ssteqr. + ! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvectors, call stdlib${ii}$_ssteqr. if( .not.wantz ) then - call stdlib_ssterf( n, w, work( inde ), info ) + call stdlib${ii}$_ssterf( n, w, work( inde ), info ) else - call stdlib_ssteqr( jobz, n, w, work( inde ), z, ldz, work( indwrk ),info ) + call stdlib${ii}$_ssteqr( jobz, n, w, work( inde ), z, ldz, work( indwrk ),info ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = n else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_sscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ ) end if return - end subroutine stdlib_ssbev + end subroutine stdlib${ii}$_ssbev - subroutine stdlib_ssbevx( jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl,vu, il, iu, abstol, & + subroutine stdlib${ii}$_ssbevx( jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl,vu, il, iu, abstol, & !! SSBEVX computes selected eigenvalues and, optionally, eigenvectors !! of a real symmetric band matrix A. Eigenvalues and eigenvectors can !! be selected by specifying either a range of values or a range of @@ -53808,11 +53810,11 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range, uplo - integer(ilp), intent(in) :: il, iu, kd, ldab, ldq, ldz, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, iu, kd, ldab, ldq, ldz, n + integer(${ik}$), intent(out) :: info, m real(sp), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: ifail(*), iwork(*) + integer(${ik}$), intent(out) :: ifail(*), iwork(*) real(sp), intent(inout) :: ab(ldab,*) real(sp), intent(out) :: q(ldq,*), w(*), work(*), z(ldz,*) ! ===================================================================== @@ -53820,7 +53822,7 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: alleig, indeig, lower, test, valeig, wantz character :: order - integer(ilp) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwo, indwrk, & + integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwo, indwrk, & iscale, itmp1, j, jj, nsplit real(sp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, & vuu @@ -53833,67 +53835,67 @@ module stdlib_linalg_lapack_s valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) lower = stdlib_lsame( uplo, 'L' ) - info = 0 + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( kd<0 ) then - info = -5 + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( kd<0_${ik}$ ) then + info = -5_${ik}$ else if( ldab0 .and. vu<=vl )info = -11 + if( n>0_${ik}$ .and. vu<=vl )info = -11_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -12 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -12_${ik}$ else if( iun ) then - info = -13 + info = -13_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz=tmp1 ) )m = 0 + if( .not.( vl=tmp1 ) )m = 0_${ik}$ end if - if( m==1 ) then - w( 1 ) = tmp1 - if( wantz )z( 1, 1 ) = one + if( m==1_${ik}$ ) then + w( 1_${ik}$ ) = tmp1 + if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one end if return end if ! get machine constants. - safmin = stdlib_slamch( 'SAFE MINIMUM' ) - eps = stdlib_slamch( 'PRECISION' ) + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_slamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) ) ! scale matrix to allowable range, if necessary. - iscale = 0 + iscale = 0_${ik}$ abstll = abstol if ( valeig ) then vll = vl @@ -53902,101 +53904,101 @@ module stdlib_linalg_lapack_s vll = zero vuu = zero endif - anrm = stdlib_slansb( 'M', uplo, n, kd, ab, ldab, work ) + anrm = stdlib${ii}$_slansb( 'M', uplo, n, kd, ab, ldab, work ) if( anrm>zero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then - call stdlib_slascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_slascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) else - call stdlib_slascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_slascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) end if - if( abstol>0 )abstll = abstol*sigma + if( abstol>0_${ik}$ )abstll = abstol*sigma if( valeig ) then vll = vl*sigma vuu = vu*sigma end if end if - ! call stdlib_ssbtrd to reduce symmetric band matrix to tridiagonal form. - indd = 1 + ! call stdlib${ii}$_ssbtrd to reduce symmetric band matrix to tridiagonal form. + indd = 1_${ik}$ inde = indd + n indwrk = inde + n - call stdlib_ssbtrd( jobz, uplo, n, kd, ab, ldab, work( indd ),work( inde ), q, ldq, & + call stdlib${ii}$_ssbtrd( jobz, uplo, n, kd, ab, ldab, work( indd ),work( inde ), q, ldq, & work( indwrk ), iinfo ) ! if all eigenvalues are desired and abstol is less than or equal - ! to zero, then call stdlib_ssterf or stdlib_ssteqr. if this fails for some - ! eigenvalue, then try stdlib_sstebz. + ! to zero, then call stdlib${ii}$_ssterf or stdlib${ii}$_ssteqr. if this fails for some + ! eigenvalue, then try stdlib${ii}$_sstebz. test = .false. if (indeig) then - if (il==1 .and. iu==n) then + if (il==1_${ik}$ .and. iu==n) then test = .true. end if end if if ((alleig .or. test) .and. (abstol<=zero)) then - call stdlib_scopy( n, work( indd ), 1, w, 1 ) - indee = indwrk + 2*n + call stdlib${ii}$_scopy( n, work( indd ), 1_${ik}$, w, 1_${ik}$ ) + indee = indwrk + 2_${ik}$*n if( .not.wantz ) then - call stdlib_scopy( n-1, work( inde ), 1, work( indee ), 1 ) - call stdlib_ssterf( n, w, work( indee ), info ) + call stdlib${ii}$_scopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ ) + call stdlib${ii}$_ssterf( n, w, work( indee ), info ) else - call stdlib_slacpy( 'A', n, n, q, ldq, z, ldz ) - call stdlib_scopy( n-1, work( inde ), 1, work( indee ), 1 ) - call stdlib_ssteqr( jobz, n, w, work( indee ), z, ldz,work( indwrk ), info ) + call stdlib${ii}$_slacpy( 'A', n, n, q, ldq, z, ldz ) + call stdlib${ii}$_scopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ ) + call stdlib${ii}$_ssteqr( jobz, n, w, work( indee ), z, ldz,work( indwrk ), info ) - if( info==0 ) then + if( info==0_${ik}$ ) then do i = 1, n - ifail( i ) = 0 + ifail( i ) = 0_${ik}$ end do end if end if - if( info==0 ) then + if( info==0_${ik}$ ) then m = n go to 30 end if - info = 0 + info = 0_${ik}$ end if - ! otherwise, call stdlib_sstebz and, if eigenvectors are desired, stdlib_sstein. + ! otherwise, call stdlib${ii}$_sstebz and, if eigenvectors are desired, stdlib${ii}$_sstein. if( wantz ) then order = 'B' else order = 'E' end if - indibl = 1 + indibl = 1_${ik}$ indisp = indibl + n indiwo = indisp + n - call stdlib_sstebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde & + call stdlib${ii}$_sstebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde & ), m, nsplit, w,iwork( indibl ), iwork( indisp ), work( indwrk ),iwork( indiwo ), info & ) if( wantz ) then - call stdlib_sstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & + call stdlib${ii}$_sstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,work( indwrk ), iwork( indiwo ), ifail, info ) ! apply orthogonal matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_sstein. + ! form to eigenvectors returned by stdlib${ii}$_sstein. do j = 1, m - call stdlib_scopy( n, z( 1, j ), 1, work( 1 ), 1 ) - call stdlib_sgemv( 'N', n, n, one, q, ldq, work, 1, zero,z( 1, j ), 1 ) + call stdlib${ii}$_scopy( n, z( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_sgemv( 'N', n, n, one, q, ldq, work, 1_${ik}$, zero,z( 1_${ik}$, j ), 1_${ik}$ ) end do end if ! if matrix was scaled, then rescale eigenvalues appropriately. 30 continue - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = m else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_sscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. if( wantz ) then do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp1 = w( j ) do jj = j + 1, m if( w( jj )ka ) 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( ldabka ) then - info = -6 + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( ka<0_${ik}$ ) then + info = -5_${ik}$ + else if( kb<0_${ik}$ .or. kb>ka ) then + info = -6_${ik}$ else if( ldab0 .and. vu<=vl )info = -14 + if( n>0_${ik}$ .and. vu<=vl )info = -14_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -15 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -15_${ik}$ else if ( iun ) then - info = -16 + info = -16_${ik}$ end if end if end if - if( info==0) then - if( ldz<1 .or. ( wantz .and. ldzzero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then - call stdlib_sscal( ( n*( n+1 ) ) / 2, sigma, ap, 1 ) + if( iscale==1_${ik}$ ) then + call stdlib${ii}$_sscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ ) end if - ! call stdlib_ssptrd to reduce symmetric packed matrix to tridiagonal form. - inde = 1 + ! call stdlib${ii}$_ssptrd to reduce symmetric packed matrix to tridiagonal form. + inde = 1_${ik}$ indtau = inde + n - call stdlib_ssptrd( uplo, n, ap, w, work( inde ), work( indtau ), iinfo ) - ! for eigenvalues only, call stdlib_ssterf. for eigenvectors, first call - ! stdlib_sopgtr to generate the orthogonal matrix, then call stdlib_ssteqr. + call stdlib${ii}$_ssptrd( uplo, n, ap, w, work( inde ), work( indtau ), iinfo ) + ! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvectors, first call + ! stdlib${ii}$_sopgtr to generate the orthogonal matrix, then call stdlib${ii}$_ssteqr. if( .not.wantz ) then - call stdlib_ssterf( n, w, work( inde ), info ) + call stdlib${ii}$_ssterf( n, w, work( inde ), info ) else indwrk = indtau + n - call stdlib_sopgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo ) + call stdlib${ii}$_sopgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo ) - call stdlib_ssteqr( jobz, n, w, work( inde ), z, ldz, work( indtau ),info ) + call stdlib${ii}$_ssteqr( jobz, n, w, work( inde ), z, ldz, work( indtau ),info ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = n else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_sscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ ) end if return - end subroutine stdlib_sspev + end subroutine stdlib${ii}$_sspev - subroutine stdlib_sspevx( jobz, range, uplo, n, ap, vl, vu, il, iu,abstol, m, w, z, ldz, & + subroutine stdlib${ii}$_sspevx( jobz, range, uplo, n, ap, vl, vu, il, iu,abstol, m, w, z, ldz, & !! SSPEVX computes selected eigenvalues and, optionally, eigenvectors !! of a real symmetric matrix A in packed storage. Eigenvalues/vectors !! can be selected by specifying either a range of values or a range of @@ -54390,11 +54392,11 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range, uplo - integer(ilp), intent(in) :: il, iu, ldz, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, iu, ldz, n + integer(${ik}$), intent(out) :: info, m real(sp), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: ifail(*), iwork(*) + integer(${ik}$), intent(out) :: ifail(*), iwork(*) real(sp), intent(inout) :: ap(*) real(sp), intent(out) :: w(*), work(*), z(ldz,*) ! ===================================================================== @@ -54402,7 +54404,7 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: alleig, indeig, test, valeig, wantz character :: order - integer(ilp) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwo, indtau, & + integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwo, indtau, & indwrk, iscale, itmp1, j, jj, nsplit real(sp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, & vuu @@ -54414,59 +54416,59 @@ module stdlib_linalg_lapack_s alleig = stdlib_lsame( range, 'A' ) valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) - info = 0 + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( stdlib_lsame( uplo, 'L' ) .or. stdlib_lsame( uplo, 'U' ) ) )& then - info = -3 - else if( n<0 ) then - info = -4 + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ else if( valeig ) then - if( n>0 .and. vu<=vl )info = -7 + if( n>0_${ik}$ .and. vu<=vl )info = -7_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -8 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -8_${ik}$ else if( iun ) then - info = -9 + info = -9_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz=ap( 1 ) ) then - m = 1 - w( 1 ) = ap( 1 ) + if( vl=ap( 1_${ik}$ ) ) then + m = 1_${ik}$ + w( 1_${ik}$ ) = ap( 1_${ik}$ ) end if end if - if( wantz )z( 1, 1 ) = one + if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one return end if ! get machine constants. - safmin = stdlib_slamch( 'SAFE MINIMUM' ) - eps = stdlib_slamch( 'PRECISION' ) + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_slamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) ) ! scale matrix to allowable range, if necessary. - iscale = 0 + iscale = 0_${ik}$ abstll = abstol if ( valeig ) then vll = vl @@ -54475,97 +54477,97 @@ module stdlib_linalg_lapack_s vll = zero vuu = zero endif - anrm = stdlib_slansp( 'M', uplo, n, ap, work ) + anrm = stdlib${ii}$_slansp( 'M', uplo, n, ap, work ) if( anrm>zero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then - call stdlib_sscal( ( n*( n+1 ) ) / 2, sigma, ap, 1 ) - if( abstol>0 )abstll = abstol*sigma + if( iscale==1_${ik}$ ) then + call stdlib${ii}$_sscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ ) + if( abstol>0_${ik}$ )abstll = abstol*sigma if( valeig ) then vll = vl*sigma vuu = vu*sigma end if end if - ! call stdlib_ssptrd to reduce symmetric packed matrix to tridiagonal form. - indtau = 1 + ! call stdlib${ii}$_ssptrd to reduce symmetric packed matrix to tridiagonal form. + indtau = 1_${ik}$ inde = indtau + n indd = inde + n indwrk = indd + n - call stdlib_ssptrd( uplo, n, ap, work( indd ), work( inde ),work( indtau ), iinfo ) + call stdlib${ii}$_ssptrd( uplo, n, ap, work( indd ), work( inde ),work( indtau ), iinfo ) ! if all eigenvalues are desired and abstol is less than or equal - ! to zero, then call stdlib_ssterf or stdlib_sopgtr and stdlib_ssteqr. if this fails - ! for some eigenvalue, then try stdlib_sstebz. + ! to zero, then call stdlib${ii}$_ssterf or stdlib${ii}$_sopgtr and stdlib${ii}$_ssteqr. if this fails + ! for some eigenvalue, then try stdlib${ii}$_sstebz. test = .false. if (indeig) then - if (il==1 .and. iu==n) then + if (il==1_${ik}$ .and. iu==n) then test = .true. end if end if if ((alleig .or. test) .and. (abstol<=zero)) then - call stdlib_scopy( n, work( indd ), 1, w, 1 ) - indee = indwrk + 2*n + call stdlib${ii}$_scopy( n, work( indd ), 1_${ik}$, w, 1_${ik}$ ) + indee = indwrk + 2_${ik}$*n if( .not.wantz ) then - call stdlib_scopy( n-1, work( inde ), 1, work( indee ), 1 ) - call stdlib_ssterf( n, w, work( indee ), info ) + call stdlib${ii}$_scopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ ) + call stdlib${ii}$_ssterf( n, w, work( indee ), info ) else - call stdlib_sopgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo ) + call stdlib${ii}$_sopgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo ) - call stdlib_scopy( n-1, work( inde ), 1, work( indee ), 1 ) - call stdlib_ssteqr( jobz, n, w, work( indee ), z, ldz,work( indwrk ), info ) + call stdlib${ii}$_scopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ ) + call stdlib${ii}$_ssteqr( jobz, n, w, work( indee ), z, ldz,work( indwrk ), info ) - if( info==0 ) then + if( info==0_${ik}$ ) then do i = 1, n - ifail( i ) = 0 + ifail( i ) = 0_${ik}$ end do end if end if - if( info==0 ) then + if( info==0_${ik}$ ) then m = n go to 20 end if - info = 0 + info = 0_${ik}$ end if - ! otherwise, call stdlib_sstebz and, if eigenvectors are desired, stdlib_sstein. + ! otherwise, call stdlib${ii}$_sstebz and, if eigenvectors are desired, stdlib${ii}$_sstein. if( wantz ) then order = 'B' else order = 'E' end if - indibl = 1 + indibl = 1_${ik}$ indisp = indibl + n indiwo = indisp + n - call stdlib_sstebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde & + call stdlib${ii}$_sstebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde & ), m, nsplit, w,iwork( indibl ), iwork( indisp ), work( indwrk ),iwork( indiwo ), info & ) if( wantz ) then - call stdlib_sstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & + call stdlib${ii}$_sstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,work( indwrk ), iwork( indiwo ), ifail, info ) ! apply orthogonal matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_sstein. - call stdlib_sopmtr( 'L', uplo, 'N', n, m, ap, work( indtau ), z, ldz,work( indwrk ),& + ! form to eigenvectors returned by stdlib${ii}$_sstein. + call stdlib${ii}$_sopmtr( 'L', uplo, 'N', n, m, ap, work( indtau ), z, ldz,work( indwrk ),& iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. 20 continue - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = m else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_sscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. if( wantz ) then do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp1 = w( j ) do jj = j + 1, m if( w( jj )3 ) then - info = -1 + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( ldz<1 .or. ( wantz .and. ldz0 )neig = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )neig = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**t*y or inv(u)*y if( upper ) then @@ -54657,9 +54659,9 @@ module stdlib_linalg_lapack_s trans = 'T' end if do j = 1, neig - call stdlib_stpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_stpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**t*y if( upper ) then @@ -54668,15 +54670,15 @@ module stdlib_linalg_lapack_s trans = 'N' end if do j = 1, neig - call stdlib_stpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_stpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do end if end if return - end subroutine stdlib_sspgv + end subroutine stdlib${ii}$_sspgv - subroutine stdlib_sspgvx( itype, jobz, range, uplo, n, ap, bp, vl, vu,il, iu, abstol, m, w, & + subroutine stdlib${ii}$_sspgvx( itype, jobz, range, uplo, n, ap, bp, vl, vu,il, iu, abstol, m, w, & !! SSPGVX computes selected eigenvalues, and optionally, eigenvectors !! of a real generalized symmetric-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A @@ -54690,18 +54692,18 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range, uplo - integer(ilp), intent(in) :: il, itype, iu, ldz, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, itype, iu, ldz, n + integer(${ik}$), intent(out) :: info, m real(sp), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: ifail(*), iwork(*) + integer(${ik}$), intent(out) :: ifail(*), iwork(*) real(sp), intent(inout) :: ap(*), bp(*) real(sp), intent(out) :: w(*), work(*), z(ldz,*) ! ===================================================================== ! Local Scalars logical(lk) :: alleig, indeig, upper, valeig, wantz character :: trans - integer(ilp) :: j + integer(${ik}$) :: j ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -54711,56 +54713,56 @@ module stdlib_linalg_lapack_s alleig = stdlib_lsame( range, 'A' ) valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) - info = 0 - if( itype<1 .or. itype>3 ) then - info = -1 + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -3 + info = -3_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -4 - else if( n<0 ) then - info = -5 + info = -4_${ik}$ + else if( n<0_${ik}$ ) then + info = -5_${ik}$ else if( valeig ) then - if( n>0 .and. vu<=vl ) then - info = -9 + if( n>0_${ik}$ .and. vu<=vl ) then + info = -9_${ik}$ end if else if( indeig ) then - if( il<1 ) then - info = -10 + if( il<1_${ik}$ ) then + info = -10_${ik}$ else if( iun ) then - info = -11 + info = -11_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz0 )m = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )m = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**t*y or inv(u)*y if( upper ) then @@ -54769,9 +54771,9 @@ module stdlib_linalg_lapack_s trans = 'T' end if do j = 1, m - call stdlib_stpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_stpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**t*y if( upper ) then @@ -54780,15 +54782,15 @@ module stdlib_linalg_lapack_s trans = 'N' end if do j = 1, m - call stdlib_stpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_stpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do end if end if return - end subroutine stdlib_sspgvx + end subroutine stdlib${ii}$_sspgvx - subroutine stdlib_ssyev( jobz, uplo, n, a, lda, w, work, lwork, info ) + subroutine stdlib${ii}$_ssyev( jobz, uplo, n, a, lda, w, work, lwork, info ) !! SSYEV computes all eigenvalues and, optionally, eigenvectors of a !! real symmetric matrix A. ! -- lapack driver routine -- @@ -54796,8 +54798,8 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, 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 real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: w(*), work(*) @@ -54805,7 +54807,7 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: lower, lquery, wantz - integer(ilp) :: iinfo, imax, inde, indtau, indwrk, iscale, llwork, lwkopt, nb + integer(${ik}$) :: iinfo, imax, inde, indtau, indwrk, iscale, llwork, lwkopt, nb real(sp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! Intrinsic Functions intrinsic :: max,sqrt @@ -54813,89 +54815,89 @@ module stdlib_linalg_lapack_s ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) lower = stdlib_lsame( uplo, 'L' ) - lquery = ( lwork==-1 ) - info = 0 + lquery = ( lwork==-1_${ik}$ ) + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldazero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 )call stdlib_slascl( uplo, 0, 0, one, sigma, n, n, a, lda, info ) - ! call stdlib_ssytrd to reduce symmetric matrix to tridiagonal form. - inde = 1 + if( iscale==1_${ik}$ )call stdlib${ii}$_slascl( uplo, 0_${ik}$, 0_${ik}$, one, sigma, n, n, a, lda, info ) + ! call stdlib${ii}$_ssytrd to reduce symmetric matrix to tridiagonal form. + inde = 1_${ik}$ indtau = inde + n indwrk = indtau + n - llwork = lwork - indwrk + 1 - call stdlib_ssytrd( uplo, n, a, lda, w, work( inde ), work( indtau ),work( indwrk ), & + llwork = lwork - indwrk + 1_${ik}$ + call stdlib${ii}$_ssytrd( uplo, n, a, lda, w, work( inde ), work( indtau ),work( indwrk ), & llwork, iinfo ) - ! for eigenvalues only, call stdlib_ssterf. for eigenvectors, first call - ! stdlib_sorgtr to generate the orthogonal matrix, then call stdlib_ssteqr. + ! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvectors, first call + ! stdlib${ii}$_sorgtr to generate the orthogonal matrix, then call stdlib${ii}$_ssteqr. if( .not.wantz ) then - call stdlib_ssterf( n, w, work( inde ), info ) + call stdlib${ii}$_ssterf( n, w, work( inde ), info ) else - call stdlib_sorgtr( uplo, n, a, lda, work( indtau ), work( indwrk ),llwork, iinfo ) + call stdlib${ii}$_sorgtr( uplo, n, a, lda, work( indtau ), work( indwrk ),llwork, iinfo ) - call stdlib_ssteqr( jobz, n, w, work( inde ), a, lda, work( indtau ),info ) + call stdlib${ii}$_ssteqr( jobz, n, w, work( inde ), a, lda, work( indtau ),info ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = n else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_sscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ ) end if ! set work(1) to optimal workspace size. - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_ssyev + end subroutine stdlib${ii}$_ssyev - subroutine stdlib_ssyevx( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, & + subroutine stdlib${ii}$_ssyevx( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, & !! SSYEVX computes selected eigenvalues and, optionally, eigenvectors !! of a real symmetric matrix A. Eigenvalues and eigenvectors can be !! selected by specifying either a range of values or a range of indices @@ -54906,11 +54908,11 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range, uplo - integer(ilp), intent(in) :: il, iu, lda, ldz, lwork, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, iu, lda, ldz, lwork, n + integer(${ik}$), intent(out) :: info, m real(sp), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: ifail(*), iwork(*) + integer(${ik}$), intent(out) :: ifail(*), iwork(*) real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: w(*), work(*), z(ldz,*) ! ===================================================================== @@ -54918,7 +54920,7 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: alleig, indeig, lower, lquery, test, valeig, wantz character :: order - integer(ilp) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwo, indtau, & + integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwo, indtau, & indwkn, indwrk, iscale, itmp1, j, jj, llwork, llwrkn, lwkmin, lwkopt, nb, & nsplit real(sp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, & @@ -54932,188 +54934,188 @@ module stdlib_linalg_lapack_s alleig = stdlib_lsame( range, 'A' ) valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) - lquery = ( lwork==-1 ) - info = 0 + lquery = ( lwork==-1_${ik}$ ) + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( lda0 .and. vu<=vl )info = -8 + if( n>0_${ik}$ .and. vu<=vl )info = -8_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -9 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -9_${ik}$ else if( iun ) then - info = -10 + info = -10_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz=a( 1, 1 ) ) then - m = 1 - w( 1 ) = a( 1, 1 ) + if( vl=a( 1_${ik}$, 1_${ik}$ ) ) then + m = 1_${ik}$ + w( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ ) end if end if - if( wantz )z( 1, 1 ) = one + if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one return end if ! get machine constants. - safmin = stdlib_slamch( 'SAFE MINIMUM' ) - eps = stdlib_slamch( 'PRECISION' ) + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_slamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) ) ! scale matrix to allowable range, if necessary. - iscale = 0 + iscale = 0_${ik}$ abstll = abstol if( valeig ) then vll = vl vuu = vu end if - anrm = stdlib_slansy( 'M', uplo, n, a, lda, work ) + anrm = stdlib${ii}$_slansy( 'M', uplo, n, a, lda, work ) if( anrm>zero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then do j = 1, n - call stdlib_sscal( n-j+1, sigma, a( j, j ), 1 ) + call stdlib${ii}$_sscal( n-j+1, sigma, a( j, j ), 1_${ik}$ ) end do else do j = 1, n - call stdlib_sscal( j, sigma, a( 1, j ), 1 ) + call stdlib${ii}$_sscal( j, sigma, a( 1_${ik}$, j ), 1_${ik}$ ) end do end if - if( abstol>0 )abstll = abstol*sigma + if( abstol>0_${ik}$ )abstll = abstol*sigma if( valeig ) then vll = vl*sigma vuu = vu*sigma end if end if - ! call stdlib_ssytrd to reduce symmetric matrix to tridiagonal form. - indtau = 1 + ! call stdlib${ii}$_ssytrd to reduce symmetric matrix to tridiagonal form. + indtau = 1_${ik}$ inde = indtau + n indd = inde + n indwrk = indd + n - llwork = lwork - indwrk + 1 - call stdlib_ssytrd( uplo, n, a, lda, work( indd ), work( inde ),work( indtau ), work( & + llwork = lwork - indwrk + 1_${ik}$ + call stdlib${ii}$_ssytrd( uplo, n, a, lda, work( indd ), work( inde ),work( indtau ), work( & indwrk ), llwork, iinfo ) ! if all eigenvalues are desired and abstol is less than or equal to - ! zero, then call stdlib_ssterf or stdlib_sorgtr and stdlib_ssteqr. if this fails for - ! some eigenvalue, then try stdlib_sstebz. + ! zero, then call stdlib${ii}$_ssterf or stdlib${ii}$_sorgtr and stdlib${ii}$_ssteqr. if this fails for + ! some eigenvalue, then try stdlib${ii}$_sstebz. test = .false. if( indeig ) then - if( il==1 .and. iu==n ) then + if( il==1_${ik}$ .and. iu==n ) then test = .true. end if end if if( ( alleig .or. test ) .and. ( abstol<=zero ) ) then - call stdlib_scopy( n, work( indd ), 1, w, 1 ) - indee = indwrk + 2*n + call stdlib${ii}$_scopy( n, work( indd ), 1_${ik}$, w, 1_${ik}$ ) + indee = indwrk + 2_${ik}$*n if( .not.wantz ) then - call stdlib_scopy( n-1, work( inde ), 1, work( indee ), 1 ) - call stdlib_ssterf( n, w, work( indee ), info ) + call stdlib${ii}$_scopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ ) + call stdlib${ii}$_ssterf( n, w, work( indee ), info ) else - call stdlib_slacpy( 'A', n, n, a, lda, z, ldz ) - call stdlib_sorgtr( uplo, n, z, ldz, work( indtau ),work( indwrk ), llwork, & + call stdlib${ii}$_slacpy( 'A', n, n, a, lda, z, ldz ) + call stdlib${ii}$_sorgtr( uplo, n, z, ldz, work( indtau ),work( indwrk ), llwork, & iinfo ) - call stdlib_scopy( n-1, work( inde ), 1, work( indee ), 1 ) - call stdlib_ssteqr( jobz, n, w, work( indee ), z, ldz,work( indwrk ), info ) + call stdlib${ii}$_scopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ ) + call stdlib${ii}$_ssteqr( jobz, n, w, work( indee ), z, ldz,work( indwrk ), info ) - if( info==0 ) then + if( info==0_${ik}$ ) then do i = 1, n - ifail( i ) = 0 + ifail( i ) = 0_${ik}$ end do end if end if - if( info==0 ) then + if( info==0_${ik}$ ) then m = n go to 40 end if - info = 0 + info = 0_${ik}$ end if - ! otherwise, call stdlib_sstebz and, if eigenvectors are desired, stdlib_sstein. + ! otherwise, call stdlib${ii}$_sstebz and, if eigenvectors are desired, stdlib${ii}$_sstein. if( wantz ) then order = 'B' else order = 'E' end if - indibl = 1 + indibl = 1_${ik}$ indisp = indibl + n indiwo = indisp + n - call stdlib_sstebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde & + call stdlib${ii}$_sstebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde & ), m, nsplit, w,iwork( indibl ), iwork( indisp ), work( indwrk ),iwork( indiwo ), info & ) if( wantz ) then - call stdlib_sstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & + call stdlib${ii}$_sstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,work( indwrk ), iwork( indiwo ), ifail, info ) ! apply orthogonal matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_sstein. + ! form to eigenvectors returned by stdlib${ii}$_sstein. indwkn = inde - llwrkn = lwork - indwkn + 1 - call stdlib_sormtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & + llwrkn = lwork - indwkn + 1_${ik}$ + call stdlib${ii}$_sormtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & indwkn ), llwrkn, iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. 40 continue - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = m else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_sscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. if( wantz ) then do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp1 = w( j ) do jj = j + 1, m if( w( jj )3 ) then - info = -1 + lquery = ( lwork==-1_${ik}$ ) + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( lda0 )neig = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )neig = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**t*y or inv(u)*y if( upper ) then @@ -55223,9 +55225,9 @@ module stdlib_linalg_lapack_s else trans = 'T' end if - call stdlib_strsm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, one,b, ldb, a, lda ) + call stdlib${ii}$_strsm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, one,b, ldb, a, lda ) - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**t*y if( upper ) then @@ -55233,16 +55235,16 @@ module stdlib_linalg_lapack_s else trans = 'N' end if - call stdlib_strmm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, one,b, ldb, a, lda ) + call stdlib${ii}$_strmm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, one,b, ldb, a, lda ) end if end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_ssygv + end subroutine stdlib${ii}$_ssygv - subroutine stdlib_ssygvx( itype, jobz, range, uplo, n, a, lda, b, ldb,vl, vu, il, iu, abstol,& + subroutine stdlib${ii}$_ssygvx( itype, jobz, range, uplo, n, a, lda, b, ldb,vl, vu, il, iu, abstol,& !! SSYGVX computes selected eigenvalues, and optionally, eigenvectors !! of a real generalized symmetric-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A @@ -55255,11 +55257,11 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range, uplo - integer(ilp), intent(in) :: il, itype, iu, lda, ldb, ldz, lwork, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, itype, iu, lda, ldb, ldz, lwork, n + integer(${ik}$), intent(out) :: info, m real(sp), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: ifail(*), iwork(*) + integer(${ik}$), intent(out) :: ifail(*), iwork(*) real(sp), intent(inout) :: a(lda,*), b(ldb,*) real(sp), intent(out) :: w(*), work(*), z(ldz,*) ! ===================================================================== @@ -55267,7 +55269,7 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: alleig, indeig, lquery, upper, valeig, wantz character :: trans - integer(ilp) :: lwkmin, lwkopt, nb + integer(${ik}$) :: lwkmin, lwkopt, nb ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -55277,72 +55279,72 @@ module stdlib_linalg_lapack_s alleig = stdlib_lsame( range, 'A' ) valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) - lquery = ( lwork==-1 ) - info = 0 - if( itype<1 .or. itype>3 ) then - info = -1 + lquery = ( lwork==-1_${ik}$ ) + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -3 + info = -3_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( lda0 .and. vu<=vl )info = -11 + if( n>0_${ik}$ .and. vu<=vl )info = -11_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -12 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -12_${ik}$ else if( iun ) then - info = -13 + info = -13_${ik}$ end if end if end if - if (info==0) then - if (ldz<1 .or. (wantz .and. ldz0 )m = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )m = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**t*y or inv(u)*y if( upper ) then @@ -55350,9 +55352,9 @@ module stdlib_linalg_lapack_s else trans = 'T' end if - call stdlib_strsm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, one, b,ldb, z, ldz ) + call stdlib${ii}$_strsm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, one, b,ldb, z, ldz ) - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**t*y if( upper ) then @@ -55360,17 +55362,17 @@ module stdlib_linalg_lapack_s else trans = 'N' end if - call stdlib_strmm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, one, b,ldb, z, ldz ) + call stdlib${ii}$_strmm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, one, b,ldb, z, ldz ) end if end if ! set work(1) to optimal workspace size. - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_ssygvx + end subroutine stdlib${ii}$_ssygvx - pure subroutine stdlib_ssysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) + pure subroutine stdlib${ii}$_ssysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) !! SSYSV computes the solution to a real system of linear equations !! A * X = B, !! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS @@ -55387,68 +55389,68 @@ 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, lwork, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, lwork, n, nrhs ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) real(sp), intent(inout) :: a(lda,*), b(ldb,*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: lwkopt + integer(${ik}$) :: lwkopt ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) if( .not.stdlib_lsame( uplo, 'U' ) .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 + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_slansy( 'I', uplo, n, a, lda, work ) + anorm = stdlib${ii}$_slansy( 'I', uplo, n, a, lda, work ) ! compute the reciprocal of the condition number of a. - call stdlib_ssycon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, iwork,info ) + call stdlib${ii}$_ssycon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, iwork,info ) ! compute the solution vectors x. - call stdlib_slacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_ssytrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info ) + call stdlib${ii}$_slacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_ssytrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_ssyrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & + call stdlib${ii}$_ssyrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & work, iwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond1 )anorm = anorm + abs( s( 2, 1 ) ) - bnorm = abs( p( 1, 1 ) ) - work( 1 ) = zero + anorm = abs( s( 1_${ik}$, 1_${ik}$ ) ) + if( n>1_${ik}$ )anorm = anorm + abs( s( 2_${ik}$, 1_${ik}$ ) ) + bnorm = abs( p( 1_${ik}$, 1_${ik}$ ) ) + work( 1_${ik}$ ) = zero work( n+1 ) = zero do j = 2, n temp = zero temp2 = zero if( s( j, j-1 )==zero ) then - iend = j - 1 + iend = j - 1_${ik}$ else - iend = j - 2 + iend = j - 2_${ik}$ end if do i = 1, iend temp = temp + abs( s( i, j ) ) @@ -55911,7 +55913,7 @@ module stdlib_linalg_lapack_s bscale = one / max( bnorm, safmin ) ! left eigenvectors if( compl ) then - ieig = 0 + ieig = 0_${ik}$ ! main loop over eigenvalues ilcplx = .false. loop_220: do je = 1, n @@ -55923,11 +55925,11 @@ module stdlib_linalg_lapack_s ilcplx = .false. cycle loop_220 end if - nw = 1 + nw = 1_${ik}$ if( jeabs( temp2r )+abs( temp2i ) ) then - work( 2*n+je ) = one - work( 3*n+je ) = zero - work( 2*n+je+1 ) = -temp2r / temp - work( 3*n+je+1 ) = -temp2i / temp + work( 2_${ik}$*n+je ) = one + work( 3_${ik}$*n+je ) = zero + work( 2_${ik}$*n+je+1 ) = -temp2r / temp + work( 3_${ik}$*n+je+1 ) = -temp2i / temp else - work( 2*n+je+1 ) = one - work( 3*n+je+1 ) = zero + work( 2_${ik}$*n+je+1 ) = one + work( 3_${ik}$*n+je+1 ) = zero temp = acoef*s( je, je+1 ) - work( 2*n+je ) = ( bcoefr*p( je+1, je+1 )-acoef*s( je+1, je+1 ) ) / & + work( 2_${ik}$*n+je ) = ( bcoefr*p( je+1, je+1 )-acoef*s( je+1, je+1 ) ) / & temp - work( 3*n+je ) = bcoefi*p( je+1, je+1 ) / temp + work( 3_${ik}$*n+je ) = bcoefi*p( je+1, je+1 ) / temp end if - xmax = max( abs( work( 2*n+je ) )+abs( work( 3*n+je ) ),abs( work( 2*n+je+1 ) & - )+abs( work( 3*n+je+1 ) ) ) + xmax = max( abs( work( 2_${ik}$*n+je ) )+abs( work( 3_${ik}$*n+je ) ),abs( work( 2_${ik}$*n+je+1 ) & + )+abs( work( 3_${ik}$*n+je+1 ) ) ) end if dmin = max( ulp*acoefa*anorm, ulp*bcoefa*bnorm, safmin ) ! t @@ -56052,13 +56054,13 @@ module stdlib_linalg_lapack_s il2by2 = .false. cycle loop_160 end if - na = 1 - bdiag( 1 ) = p( j, j ) + na = 1_${ik}$ + bdiag( 1_${ik}$ ) = p( j, j ) if( j1 ) then + nw = 1_${ik}$ + if( je>1_${ik}$ ) then if( s( je, je-1 )/=zero ) then ilcplx = .true. - nw = 2 + nw = 2_${ik}$ end if end if if( ilall ) then @@ -56196,7 +56198,7 @@ module stdlib_linalg_lapack_s if( .not.ilcplx ) then if( abs( s( je, je ) )<=safmin .and.abs( p( je, je ) )<=safmin ) then ! singular matrix pencil -- unit eigenvector - ieig = ieig - 1 + ieig = ieig - 1_${ik}$ do jr = 1, n vr( jr, ieig ) = zero end do @@ -56246,19 +56248,19 @@ module stdlib_linalg_lapack_s acoefa = abs( acoef ) bcoefa = abs( bcoefr ) ! first component is 1 - work( 2*n+je ) = one + work( 2_${ik}$*n+je ) = one xmax = one ! compute contribution from column je of a and b to sum ! (see "further details", above.) do jr = 1, je - 1 - work( 2*n+jr ) = bcoefr*p( jr, je ) -acoef*s( jr, je ) + work( 2_${ik}$*n+jr ) = bcoefr*p( jr, je ) -acoef*s( jr, je ) end do else ! complex eigenvalue - call stdlib_slag2( s( je-1, je-1 ), lds, p( je-1, je-1 ), ldp,safmin*safety, & + call stdlib${ii}$_slag2( s( je-1, je-1 ), lds, p( je-1, je-1 ), ldp,safmin*safety, & acoef, temp, bcoefr, temp2,bcoefi ) if( bcoefi==zero ) then - info = je - 1 + info = je - 1_${ik}$ return end if ! scale to avoid over/underflow @@ -56285,34 +56287,34 @@ module stdlib_linalg_lapack_s temp2r = acoef*s( je, je ) - bcoefr*p( je, je ) temp2i = -bcoefi*p( je, je ) if( abs( temp )>=abs( temp2r )+abs( temp2i ) ) then - work( 2*n+je ) = one - work( 3*n+je ) = zero - work( 2*n+je-1 ) = -temp2r / temp - work( 3*n+je-1 ) = -temp2i / temp + work( 2_${ik}$*n+je ) = one + work( 3_${ik}$*n+je ) = zero + work( 2_${ik}$*n+je-1 ) = -temp2r / temp + work( 3_${ik}$*n+je-1 ) = -temp2i / temp else - work( 2*n+je-1 ) = one - work( 3*n+je-1 ) = zero + work( 2_${ik}$*n+je-1 ) = one + work( 3_${ik}$*n+je-1 ) = zero temp = acoef*s( je-1, je ) - work( 2*n+je ) = ( bcoefr*p( je-1, je-1 )-acoef*s( je-1, je-1 ) ) / & + work( 2_${ik}$*n+je ) = ( bcoefr*p( je-1, je-1 )-acoef*s( je-1, je-1 ) ) / & temp - work( 3*n+je ) = bcoefi*p( je-1, je-1 ) / temp + work( 3_${ik}$*n+je ) = bcoefi*p( je-1, je-1 ) / temp end if - xmax = max( abs( work( 2*n+je ) )+abs( work( 3*n+je ) ),abs( work( 2*n+je-1 ) & - )+abs( work( 3*n+je-1 ) ) ) + xmax = max( abs( work( 2_${ik}$*n+je ) )+abs( work( 3_${ik}$*n+je ) ),abs( work( 2_${ik}$*n+je-1 ) & + )+abs( work( 3_${ik}$*n+je-1 ) ) ) ! compute contribution from columns je and je-1 ! of a and b to the sums. - creala = acoef*work( 2*n+je-1 ) - cimaga = acoef*work( 3*n+je-1 ) - crealb = bcoefr*work( 2*n+je-1 ) -bcoefi*work( 3*n+je-1 ) - cimagb = bcoefi*work( 2*n+je-1 ) +bcoefr*work( 3*n+je-1 ) - cre2a = acoef*work( 2*n+je ) - cim2a = acoef*work( 3*n+je ) - cre2b = bcoefr*work( 2*n+je ) - bcoefi*work( 3*n+je ) - cim2b = bcoefi*work( 2*n+je ) + bcoefr*work( 3*n+je ) + creala = acoef*work( 2_${ik}$*n+je-1 ) + cimaga = acoef*work( 3_${ik}$*n+je-1 ) + crealb = bcoefr*work( 2_${ik}$*n+je-1 ) -bcoefi*work( 3_${ik}$*n+je-1 ) + cimagb = bcoefi*work( 2_${ik}$*n+je-1 ) +bcoefr*work( 3_${ik}$*n+je-1 ) + cre2a = acoef*work( 2_${ik}$*n+je ) + cim2a = acoef*work( 3_${ik}$*n+je ) + cre2b = bcoefr*work( 2_${ik}$*n+je ) - bcoefi*work( 3_${ik}$*n+je ) + cim2b = bcoefi*work( 2_${ik}$*n+je ) + bcoefr*work( 3_${ik}$*n+je ) do jr = 1, je - 2 - work( 2*n+jr ) = -creala*s( jr, je-1 ) +crealb*p( jr, je-1 ) -cre2a*s( jr, & + work( 2_${ik}$*n+jr ) = -creala*s( jr, je-1 ) +crealb*p( jr, je-1 ) -cre2a*s( jr, & je ) + cre2b*p( jr, je ) - work( 3*n+jr ) = -cimaga*s( jr, je-1 ) +cimagb*p( jr, je-1 ) -cim2a*s( jr, & + work( 3_${ik}$*n+jr ) = -cimaga*s( jr, je-1 ) +cimagb*p( jr, je-1 ) -cim2a*s( jr, & je ) + cim2b*p( jr, je ) end do end if @@ -56322,22 +56324,22 @@ module stdlib_linalg_lapack_s loop_370: do j = je - nw, 1, -1 ! if a 2-by-2 block, is in position j-1:j, wait until ! next iteration to process it (when it will be j:j+1) - if( .not.il2by2 .and. j>1 ) then + if( .not.il2by2 .and. j>1_${ik}$ ) then if( s( j, j-1 )/=zero ) then il2by2 = .true. cycle loop_370 end if end if - bdiag( 1 ) = p( j, j ) + bdiag( 1_${ik}$ ) = p( j, j ) if( il2by2 ) then - na = 2 - bdiag( 2 ) = p( j+1, j+1 ) + na = 2_${ik}$ + bdiag( 2_${ik}$ ) = p( j+1, j+1 ) else - na = 1 + na = 1_${ik}$ end if ! compute x(j) (and x(j+1), if 2-by-2 block) - call stdlib_slaln2( .false., na, nw, dmin, acoef, s( j, j ),lds, bdiag( 1 ), & - bdiag( 2 ), work( 2*n+j ),n, bcoefr, bcoefi, sum, 2, scale, temp,iinfo ) + call stdlib${ii}$_slaln2( .false., na, nw, dmin, acoef, s( j, j ),lds, bdiag( 1_${ik}$ ), & + bdiag( 2_${ik}$ ), work( 2_${ik}$*n+j ),n, bcoefr, bcoefi, sum, 2_${ik}$, scale, temp,iinfo ) if( scale1 ) then + if( j>1_${ik}$ ) then ! check whether scaling is necessary for sum. xscale = one / max( one, xmax ) temp = acoefa*work( j ) + bcoefa*work( n+j ) @@ -56373,21 +56375,21 @@ module stdlib_linalg_lapack_s ! sums. do ja = 1, na if( ilcplx ) then - creala = acoef*work( 2*n+j+ja-1 ) - cimaga = acoef*work( 3*n+j+ja-1 ) - crealb = bcoefr*work( 2*n+j+ja-1 ) -bcoefi*work( 3*n+j+ja-1 ) - cimagb = bcoefi*work( 2*n+j+ja-1 ) +bcoefr*work( 3*n+j+ja-1 ) + creala = acoef*work( 2_${ik}$*n+j+ja-1 ) + cimaga = acoef*work( 3_${ik}$*n+j+ja-1 ) + crealb = bcoefr*work( 2_${ik}$*n+j+ja-1 ) -bcoefi*work( 3_${ik}$*n+j+ja-1 ) + cimagb = bcoefi*work( 2_${ik}$*n+j+ja-1 ) +bcoefr*work( 3_${ik}$*n+j+ja-1 ) do jr = 1, j - 1 - work( 2*n+jr ) = work( 2*n+jr ) -creala*s( jr, j+ja-1 ) +crealb*p(& + work( 2_${ik}$*n+jr ) = work( 2_${ik}$*n+jr ) -creala*s( jr, j+ja-1 ) +crealb*p(& jr, j+ja-1 ) - work( 3*n+jr ) = work( 3*n+jr ) -cimaga*s( jr, j+ja-1 ) +cimagb*p(& + work( 3_${ik}$*n+jr ) = work( 3_${ik}$*n+jr ) -cimaga*s( jr, j+ja-1 ) +cimagb*p(& jr, j+ja-1 ) end do else - creala = acoef*work( 2*n+j+ja-1 ) - crealb = bcoefr*work( 2*n+j+ja-1 ) + creala = acoef*work( 2_${ik}$*n+j+ja-1 ) + crealb = bcoefr*work( 2_${ik}$*n+j+ja-1 ) do jr = 1, j - 1 - work( 2*n+jr ) = work( 2*n+jr ) -creala*s( jr, j+ja-1 ) +crealb*p(& + work( 2_${ik}$*n+jr ) = work( 2_${ik}$*n+jr ) -creala*s( jr, j+ja-1 ) +crealb*p(& jr, j+ja-1 ) end do end if @@ -56401,7 +56403,7 @@ module stdlib_linalg_lapack_s if( ilback ) then do jw = 0, nw - 1 do jr = 1, n - work( ( jw+4 )*n+jr ) = work( ( jw+2 )*n+1 )*vr( jr, 1 ) + work( ( jw+4 )*n+jr ) = work( ( jw+2 )*n+1 )*vr( jr, 1_${ik}$ ) end do ! a series of compiler directives to defeat ! vectorization for the next loop @@ -56448,10 +56450,10 @@ module stdlib_linalg_lapack_s end do loop_500 end if return - end subroutine stdlib_stgevc + end subroutine stdlib${ii}$_stgevc - pure subroutine stdlib_stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, j1, n1, n2, & + pure subroutine stdlib${ii}$_stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, j1, n1, n2, & !! STGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22) !! of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair !! (A, B) by an orthogonal equivalence transformation. @@ -56468,17 +56470,17 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: wantq, wantz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: j1, lda, ldb, ldq, ldz, lwork, n, n1, n2 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: j1, lda, ldb, ldq, ldz, lwork, n, n1, n2 ! Array Arguments real(sp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) real(sp), intent(out) :: work(*) ! ===================================================================== - ! replaced various illegal calls to stdlib_scopy by calls to stdlib_slaset, or by do + ! replaced various illegal calls to stdlib${ii}$_scopy by calls to stdlib${ii}$_slaset, or by do ! loops. sven hammarling, 1/5/02. ! Parameters real(sp), parameter :: twenty = 2.0e+01_sp - integer(ilp), parameter :: ldst = 4 + integer(${ik}$), parameter :: ldst = 4_${ik}$ logical(lk), parameter :: wands = .true. @@ -56486,46 +56488,46 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: strong, weak - integer(ilp) :: i, idum, linfo, m + integer(${ik}$) :: i, idum, linfo, m real(sp) :: bqra21, brqa21, ddum, dnorma, dnormb, dscale, dsum, eps, f, g, sa, sb, & scale, smlnum, thresha, threshb ! Local Arrays - integer(ilp) :: iwork(ldst) - real(sp) :: ai(2), ar(2), be(2), ir(ldst,ldst), ircop(ldst,ldst), li(ldst,ldst), licop(& + integer(${ik}$) :: iwork(ldst) + real(sp) :: ai(2_${ik}$), ar(2_${ik}$), be(2_${ik}$), ir(ldst,ldst), ircop(ldst,ldst), li(ldst,ldst), licop(& ldst,ldst), s(ldst,ldst), scpy(ldst,ldst), t(ldst,ldst), taul(ldst), taur(ldst), tcpy(& ldst,ldst) ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements - info = 0 + info = 0_${ik}$ ! quick return if possible if( n<=1 .or. n1<=0 .or. n2<=0 )return if( n1>n .or. ( j1+n1 )>n )return m = n1 + n2 - if( lwork=sb ) then - call stdlib_slartg( s( 1, 1 ), s( 2, 1 ), li( 1, 1 ), li( 2, 1 ),ddum ) + call stdlib${ii}$_slartg( s( 1_${ik}$, 1_${ik}$ ), s( 2_${ik}$, 1_${ik}$ ), li( 1_${ik}$, 1_${ik}$ ), li( 2_${ik}$, 1_${ik}$ ),ddum ) else - call stdlib_slartg( t( 1, 1 ), t( 2, 1 ), li( 1, 1 ), li( 2, 1 ),ddum ) + call stdlib${ii}$_slartg( t( 1_${ik}$, 1_${ik}$ ), t( 2_${ik}$, 1_${ik}$ ), li( 1_${ik}$, 1_${ik}$ ), li( 2_${ik}$, 1_${ik}$ ),ddum ) end if - call stdlib_srot( 2, s( 1, 1 ), ldst, s( 2, 1 ), ldst, li( 1, 1 ),li( 2, 1 ) ) + call stdlib${ii}$_srot( 2_${ik}$, s( 1_${ik}$, 1_${ik}$ ), ldst, s( 2_${ik}$, 1_${ik}$ ), ldst, li( 1_${ik}$, 1_${ik}$ ),li( 2_${ik}$, 1_${ik}$ ) ) - call stdlib_srot( 2, t( 1, 1 ), ldst, t( 2, 1 ), ldst, li( 1, 1 ),li( 2, 1 ) ) + call stdlib${ii}$_srot( 2_${ik}$, t( 1_${ik}$, 1_${ik}$ ), ldst, t( 2_${ik}$, 1_${ik}$ ), ldst, li( 1_${ik}$, 1_${ik}$ ),li( 2_${ik}$, 1_${ik}$ ) ) - li( 2, 2 ) = li( 1, 1 ) - li( 1, 2 ) = -li( 2, 1 ) + li( 2_${ik}$, 2_${ik}$ ) = li( 1_${ik}$, 1_${ik}$ ) + li( 1_${ik}$, 2_${ik}$ ) = -li( 2_${ik}$, 1_${ik}$ ) ! weak stability test: |s21| <= o(eps f-norm((a))) ! and |t21| <= o(eps f-norm((b))) - weak = abs( s( 2, 1 ) ) <= thresha .and.abs( t( 2, 1 ) ) <= threshb + weak = abs( s( 2_${ik}$, 1_${ik}$ ) ) <= thresha .and.abs( t( 2_${ik}$, 1_${ik}$ ) ) <= threshb if( .not.weak )go to 70 if( wands ) then ! strong stability test: ! f-norm((a-ql**h*s*qr)) <= o(eps*f-norm((a))) ! and ! f-norm((b-ql**h*t*qr)) <= o(eps*f-norm((b))) - call stdlib_slacpy( 'FULL', m, m, a( j1, j1 ), lda, work( m*m+1 ),m ) - call stdlib_sgemm( 'N', 'N', m, m, m, one, li, ldst, s, ldst, zero,work, m ) + call stdlib${ii}$_slacpy( 'FULL', m, m, a( j1, j1 ), lda, work( m*m+1 ),m ) + call stdlib${ii}$_sgemm( 'N', 'N', m, m, m, one, li, ldst, s, ldst, zero,work, m ) - call stdlib_sgemm( 'N', 'T', m, m, m, -one, work, m, ir, ldst, one,work( m*m+1 ),& + call stdlib${ii}$_sgemm( 'N', 'T', m, m, m, -one, work, m, ir, ldst, one,work( m*m+1 ),& m ) dscale = zero dsum = one - call stdlib_slassq( m*m, work( m*m+1 ), 1, dscale, dsum ) + call stdlib${ii}$_slassq( m*m, work( m*m+1 ), 1_${ik}$, dscale, dsum ) sa = dscale*sqrt( dsum ) - call stdlib_slacpy( 'FULL', m, m, b( j1, j1 ), ldb, work( m*m+1 ),m ) - call stdlib_sgemm( 'N', 'N', m, m, m, one, li, ldst, t, ldst, zero,work, m ) + call stdlib${ii}$_slacpy( 'FULL', m, m, b( j1, j1 ), ldb, work( m*m+1 ),m ) + call stdlib${ii}$_sgemm( 'N', 'N', m, m, m, one, li, ldst, t, ldst, zero,work, m ) - call stdlib_sgemm( 'N', 'T', m, m, m, -one, work, m, ir, ldst, one,work( m*m+1 ),& + call stdlib${ii}$_sgemm( 'N', 'T', m, m, m, -one, work, m, ir, ldst, one,work( m*m+1 ),& m ) dscale = zero dsum = one - call stdlib_slassq( m*m, work( m*m+1 ), 1, dscale, dsum ) + call stdlib${ii}$_slassq( m*m, work( m*m+1 ), 1_${ik}$, dscale, dsum ) sb = dscale*sqrt( dsum ) strong = sa<=thresha .and. sb<=threshb if( .not.strong )go to 70 end if ! update (a(j1:j1+m-1, m+j1:n), b(j1:j1+m-1, m+j1:n)) and ! (a(1:j1-1, j1:j1+m), b(1:j1-1, j1:j1+m)). - call stdlib_srot( j1+1, a( 1, j1 ), 1, a( 1, j1+1 ), 1, ir( 1, 1 ),ir( 2, 1 ) ) + call stdlib${ii}$_srot( j1+1, a( 1_${ik}$, j1 ), 1_${ik}$, a( 1_${ik}$, j1+1 ), 1_${ik}$, ir( 1_${ik}$, 1_${ik}$ ),ir( 2_${ik}$, 1_${ik}$ ) ) - call stdlib_srot( j1+1, b( 1, j1 ), 1, b( 1, j1+1 ), 1, ir( 1, 1 ),ir( 2, 1 ) ) + call stdlib${ii}$_srot( j1+1, b( 1_${ik}$, j1 ), 1_${ik}$, b( 1_${ik}$, j1+1 ), 1_${ik}$, ir( 1_${ik}$, 1_${ik}$ ),ir( 2_${ik}$, 1_${ik}$ ) ) - call stdlib_srot( n-j1+1, a( j1, j1 ), lda, a( j1+1, j1 ), lda,li( 1, 1 ), li( 2, 1 & + call stdlib${ii}$_srot( n-j1+1, a( j1, j1 ), lda, a( j1+1, j1 ), lda,li( 1_${ik}$, 1_${ik}$ ), li( 2_${ik}$, 1_${ik}$ & ) ) - call stdlib_srot( n-j1+1, b( j1, j1 ), ldb, b( j1+1, j1 ), ldb,li( 1, 1 ), li( 2, 1 & + call stdlib${ii}$_srot( n-j1+1, b( j1, j1 ), ldb, b( j1+1, j1 ), ldb,li( 1_${ik}$, 1_${ik}$ ), li( 2_${ik}$, 1_${ik}$ & ) ) ! set n1-by-n2 (2,1) - blocks to zero. a( j1+1, j1 ) = zero b( j1+1, j1 ) = zero ! accumulate transformations into q and z if requested. - if( wantz )call stdlib_srot( n, z( 1, j1 ), 1, z( 1, j1+1 ), 1, ir( 1, 1 ),ir( 2, 1 & + if( wantz )call stdlib${ii}$_srot( n, z( 1_${ik}$, j1 ), 1_${ik}$, z( 1_${ik}$, j1+1 ), 1_${ik}$, ir( 1_${ik}$, 1_${ik}$ ),ir( 2_${ik}$, 1_${ik}$ & ) ) - if( wantq )call stdlib_srot( n, q( 1, j1 ), 1, q( 1, j1+1 ), 1, li( 1, 1 ),li( 2, 1 & + if( wantq )call stdlib${ii}$_srot( n, q( 1_${ik}$, j1 ), 1_${ik}$, q( 1_${ik}$, j1+1 ), 1_${ik}$, li( 1_${ik}$, 1_${ik}$ ),li( 2_${ik}$, 1_${ik}$ & ) ) ! exit with info = 0 if swap was successfully performed. return @@ -56617,10 +56619,10 @@ module stdlib_linalg_lapack_s ! s11 * r - l * s22 = scale * s12 ! t11 * r - l * t22 = scale * t12 ! for r and l. solutions in li and ir. - call stdlib_slacpy( 'FULL', n1, n2, t( 1, n1+1 ), ldst, li, ldst ) - call stdlib_slacpy( 'FULL', n1, n2, s( 1, n1+1 ), ldst,ir( n2+1, n1+1 ), ldst ) + call stdlib${ii}$_slacpy( 'FULL', n1, n2, t( 1_${ik}$, n1+1 ), ldst, li, ldst ) + call stdlib${ii}$_slacpy( 'FULL', n1, n2, s( 1_${ik}$, n1+1 ), ldst,ir( n2+1, n1+1 ), ldst ) - call stdlib_stgsy2( 'N', 0, n1, n2, s, ldst, s( n1+1, n1+1 ), ldst,ir( n2+1, n1+1 ),& + call stdlib${ii}$_stgsy2( 'N', 0_${ik}$, n1, n2, s, ldst, s( n1+1, n1+1 ), ldst,ir( n2+1, n1+1 ),& ldst, t, ldst, t( n1+1, n1+1 ),ldst, li, ldst, scale, dsum, dscale, iwork, idum,& linfo ) if( linfo/=0 )go to 70 @@ -56631,12 +56633,12 @@ module stdlib_linalg_lapack_s ! li = [ -l ] ! [ scale * identity(n2) ] do i = 1, n2 - call stdlib_sscal( n1, -one, li( 1, i ), 1 ) + call stdlib${ii}$_sscal( n1, -one, li( 1_${ik}$, i ), 1_${ik}$ ) li( n1+i, i ) = scale end do - call stdlib_sgeqr2( m, n2, li, ldst, taul, work, linfo ) + call stdlib${ii}$_sgeqr2( m, n2, li, ldst, taul, work, linfo ) if( linfo/=0 )go to 70 - call stdlib_sorg2r( m, m, n2, li, ldst, taul, work, linfo ) + call stdlib${ii}$_sorg2r( m, m, n2, li, ldst, taul, work, linfo ) if( linfo/=0 )go to 70 ! compute orthogonal matrix rq: ! ir * rq**t = [ 0 tr], @@ -56644,113 +56646,113 @@ module stdlib_linalg_lapack_s do i = 1, n1 ir( n2+i, i ) = scale end do - call stdlib_sgerq2( n1, m, ir( n2+1, 1 ), ldst, taur, work, linfo ) + call stdlib${ii}$_sgerq2( n1, m, ir( n2+1, 1_${ik}$ ), ldst, taur, work, linfo ) if( linfo/=0 )go to 70 - call stdlib_sorgr2( m, m, n1, ir, ldst, taur, work, linfo ) + call stdlib${ii}$_sorgr2( m, m, n1, ir, ldst, taur, work, linfo ) if( linfo/=0 )go to 70 ! perform the swapping tentatively: - call stdlib_sgemm( 'T', 'N', m, m, m, one, li, ldst, s, ldst, zero,work, m ) - call stdlib_sgemm( 'N', 'T', m, m, m, one, work, m, ir, ldst, zero, s,ldst ) - call stdlib_sgemm( 'T', 'N', m, m, m, one, li, ldst, t, ldst, zero,work, m ) - call stdlib_sgemm( 'N', 'T', m, m, m, one, work, m, ir, ldst, zero, t,ldst ) - call stdlib_slacpy( 'F', m, m, s, ldst, scpy, ldst ) - call stdlib_slacpy( 'F', m, m, t, ldst, tcpy, ldst ) - call stdlib_slacpy( 'F', m, m, ir, ldst, ircop, ldst ) - call stdlib_slacpy( 'F', m, m, li, ldst, licop, ldst ) + call stdlib${ii}$_sgemm( 'T', 'N', m, m, m, one, li, ldst, s, ldst, zero,work, m ) + call stdlib${ii}$_sgemm( 'N', 'T', m, m, m, one, work, m, ir, ldst, zero, s,ldst ) + call stdlib${ii}$_sgemm( 'T', 'N', m, m, m, one, li, ldst, t, ldst, zero,work, m ) + call stdlib${ii}$_sgemm( 'N', 'T', m, m, m, one, work, m, ir, ldst, zero, t,ldst ) + call stdlib${ii}$_slacpy( 'F', m, m, s, ldst, scpy, ldst ) + call stdlib${ii}$_slacpy( 'F', m, m, t, ldst, tcpy, ldst ) + call stdlib${ii}$_slacpy( 'F', m, m, ir, ldst, ircop, ldst ) + call stdlib${ii}$_slacpy( 'F', m, m, li, ldst, licop, ldst ) ! triangularize the b-part by an rq factorization. ! apply transformation (from left) to a-part, giving s. - call stdlib_sgerq2( m, m, t, ldst, taur, work, linfo ) + call stdlib${ii}$_sgerq2( m, m, t, ldst, taur, work, linfo ) if( linfo/=0 )go to 70 - call stdlib_sormr2( 'R', 'T', m, m, m, t, ldst, taur, s, ldst, work,linfo ) + call stdlib${ii}$_sormr2( 'R', 'T', m, m, m, t, ldst, taur, s, ldst, work,linfo ) if( linfo/=0 )go to 70 - call stdlib_sormr2( 'L', 'N', m, m, m, t, ldst, taur, ir, ldst, work,linfo ) + call stdlib${ii}$_sormr2( 'L', 'N', m, m, m, t, ldst, taur, ir, ldst, work,linfo ) if( linfo/=0 )go to 70 ! compute f-norm(s21) in brqa21. (t21 is 0.) dscale = zero dsum = one do i = 1, n2 - call stdlib_slassq( n1, s( n2+1, i ), 1, dscale, dsum ) + call stdlib${ii}$_slassq( n1, s( n2+1, i ), 1_${ik}$, dscale, dsum ) end do brqa21 = dscale*sqrt( dsum ) ! triangularize the b-part by a qr factorization. ! apply transformation (from right) to a-part, giving s. - call stdlib_sgeqr2( m, m, tcpy, ldst, taul, work, linfo ) + call stdlib${ii}$_sgeqr2( m, m, tcpy, ldst, taul, work, linfo ) if( linfo/=0 )go to 70 - call stdlib_sorm2r( 'L', 'T', m, m, m, tcpy, ldst, taul, scpy, ldst,work, info ) + call stdlib${ii}$_sorm2r( 'L', 'T', m, m, m, tcpy, ldst, taul, scpy, ldst,work, info ) - call stdlib_sorm2r( 'R', 'N', m, m, m, tcpy, ldst, taul, licop, ldst,work, info ) + call stdlib${ii}$_sorm2r( 'R', 'N', m, m, m, tcpy, ldst, taul, licop, ldst,work, info ) if( linfo/=0 )go to 70 ! compute f-norm(s21) in bqra21. (t21 is 0.) dscale = zero dsum = one do i = 1, n2 - call stdlib_slassq( n1, scpy( n2+1, i ), 1, dscale, dsum ) + call stdlib${ii}$_slassq( n1, scpy( n2+1, i ), 1_${ik}$, dscale, dsum ) end do bqra21 = dscale*sqrt( dsum ) ! decide which method to use. ! weak stability test: ! f-norm(s21) <= o(eps * f-norm((s))) if( bqra21<=brqa21 .and. bqra21<=thresha ) then - call stdlib_slacpy( 'F', m, m, scpy, ldst, s, ldst ) - call stdlib_slacpy( 'F', m, m, tcpy, ldst, t, ldst ) - call stdlib_slacpy( 'F', m, m, ircop, ldst, ir, ldst ) - call stdlib_slacpy( 'F', m, m, licop, ldst, li, ldst ) + call stdlib${ii}$_slacpy( 'F', m, m, scpy, ldst, s, ldst ) + call stdlib${ii}$_slacpy( 'F', m, m, tcpy, ldst, t, ldst ) + call stdlib${ii}$_slacpy( 'F', m, m, ircop, ldst, ir, ldst ) + call stdlib${ii}$_slacpy( 'F', m, m, licop, ldst, li, ldst ) else if( brqa21>=thresha ) then go to 70 end if ! set lower triangle of b-part to zero - if (m>1) call stdlib_slaset( 'LOWER', m-1, m-1, zero, zero, t(2,1), ldst ) + if (m>1_${ik}$) call stdlib${ii}$_slaset( 'LOWER', m-1, m-1, zero, zero, t(2_${ik}$,1_${ik}$), ldst ) if( wands ) then ! strong stability test: ! f-norm((a-ql**h*s*qr)) <= o(eps*f-norm((a))) ! and ! f-norm((b-ql**h*t*qr)) <= o(eps*f-norm((b))) - call stdlib_slacpy( 'FULL', m, m, a( j1, j1 ), lda, work( m*m+1 ),m ) - call stdlib_sgemm( 'N', 'N', m, m, m, one, li, ldst, s, ldst, zero,work, m ) + call stdlib${ii}$_slacpy( 'FULL', m, m, a( j1, j1 ), lda, work( m*m+1 ),m ) + call stdlib${ii}$_sgemm( 'N', 'N', m, m, m, one, li, ldst, s, ldst, zero,work, m ) - call stdlib_sgemm( 'N', 'N', m, m, m, -one, work, m, ir, ldst, one,work( m*m+1 ),& + call stdlib${ii}$_sgemm( 'N', 'N', m, m, m, -one, work, m, ir, ldst, one,work( m*m+1 ),& m ) dscale = zero dsum = one - call stdlib_slassq( m*m, work( m*m+1 ), 1, dscale, dsum ) + call stdlib${ii}$_slassq( m*m, work( m*m+1 ), 1_${ik}$, dscale, dsum ) sa = dscale*sqrt( dsum ) - call stdlib_slacpy( 'FULL', m, m, b( j1, j1 ), ldb, work( m*m+1 ),m ) - call stdlib_sgemm( 'N', 'N', m, m, m, one, li, ldst, t, ldst, zero,work, m ) + call stdlib${ii}$_slacpy( 'FULL', m, m, b( j1, j1 ), ldb, work( m*m+1 ),m ) + call stdlib${ii}$_sgemm( 'N', 'N', m, m, m, one, li, ldst, t, ldst, zero,work, m ) - call stdlib_sgemm( 'N', 'N', m, m, m, -one, work, m, ir, ldst, one,work( m*m+1 ),& + call stdlib${ii}$_sgemm( 'N', 'N', m, m, m, -one, work, m, ir, ldst, one,work( m*m+1 ),& m ) dscale = zero dsum = one - call stdlib_slassq( m*m, work( m*m+1 ), 1, dscale, dsum ) + call stdlib${ii}$_slassq( m*m, work( m*m+1 ), 1_${ik}$, dscale, dsum ) sb = dscale*sqrt( dsum ) strong = sa<=thresha .and. sb<=threshb if( .not.strong )go to 70 end if ! if the swap is accepted ("weakly" and "strongly"), apply the ! transformations and set n1-by-n2 (2,1)-block to zero. - call stdlib_slaset( 'FULL', n1, n2, zero, zero, s(n2+1,1), ldst ) + call stdlib${ii}$_slaset( 'FULL', n1, n2, zero, zero, s(n2+1,1_${ik}$), ldst ) ! copy back m-by-m diagonal block starting at index j1 of (a, b) - call stdlib_slacpy( 'F', m, m, s, ldst, a( j1, j1 ), lda ) - call stdlib_slacpy( 'F', m, m, t, ldst, b( j1, j1 ), ldb ) - call stdlib_slaset( 'FULL', ldst, ldst, zero, zero, t, ldst ) + call stdlib${ii}$_slacpy( 'F', m, m, s, ldst, a( j1, j1 ), lda ) + call stdlib${ii}$_slacpy( 'F', m, m, t, ldst, b( j1, j1 ), ldb ) + call stdlib${ii}$_slaset( 'FULL', ldst, ldst, zero, zero, t, ldst ) ! standardize existing 2-by-2 blocks. - call stdlib_slaset( 'FULL', m, m, zero, zero, work, m ) - work( 1 ) = one - t( 1, 1 ) = one - idum = lwork - m*m - 2 - if( n2>1 ) then - call stdlib_slagv2( a( j1, j1 ), lda, b( j1, j1 ), ldb, ar, ai, be,work( 1 ), & - work( 2 ), t( 1, 1 ), t( 2, 1 ) ) - work( m+1 ) = -work( 2 ) - work( m+2 ) = work( 1 ) - t( n2, n2 ) = t( 1, 1 ) - t( 1, 2 ) = -t( 2, 1 ) + call stdlib${ii}$_slaset( 'FULL', m, m, zero, zero, work, m ) + work( 1_${ik}$ ) = one + t( 1_${ik}$, 1_${ik}$ ) = one + idum = lwork - m*m - 2_${ik}$ + if( n2>1_${ik}$ ) then + call stdlib${ii}$_slagv2( a( j1, j1 ), lda, b( j1, j1 ), ldb, ar, ai, be,work( 1_${ik}$ ), & + work( 2_${ik}$ ), t( 1_${ik}$, 1_${ik}$ ), t( 2_${ik}$, 1_${ik}$ ) ) + work( m+1 ) = -work( 2_${ik}$ ) + work( m+2 ) = work( 1_${ik}$ ) + t( n2, n2 ) = t( 1_${ik}$, 1_${ik}$ ) + t( 1_${ik}$, 2_${ik}$ ) = -t( 2_${ik}$, 1_${ik}$ ) end if work( m*m ) = one t( m, m ) = one - if( n1>1 ) then - call stdlib_slagv2( a( j1+n2, j1+n2 ), lda, b( j1+n2, j1+n2 ), ldb,taur, taul, & + if( n1>1_${ik}$ ) then + call stdlib${ii}$_slagv2( a( j1+n2, j1+n2 ), lda, b( j1+n2, j1+n2 ), ldb,taur, taul, & work( m*m+1 ), work( n2*m+n2+1 ),work( n2*m+n2+2 ), t( n2+1, n2+1 ),t( m, m-1 ) ) work( m*m ) = work( n2*m+n2+1 ) @@ -56758,65 +56760,65 @@ module stdlib_linalg_lapack_s t( m, m ) = t( n2+1, n2+1 ) t( m-1, m ) = -t( m, m-1 ) end if - call stdlib_sgemm( 'T', 'N', n2, n1, n2, one, work, m, a( j1, j1+n2 ),lda, zero, & + call stdlib${ii}$_sgemm( 'T', 'N', n2, n1, n2, one, work, m, a( j1, j1+n2 ),lda, zero, & work( m*m+1 ), n2 ) - call stdlib_slacpy( 'FULL', n2, n1, work( m*m+1 ), n2, a( j1, j1+n2 ),lda ) - call stdlib_sgemm( 'T', 'N', n2, n1, n2, one, work, m, b( j1, j1+n2 ),ldb, zero, & + call stdlib${ii}$_slacpy( 'FULL', n2, n1, work( m*m+1 ), n2, a( j1, j1+n2 ),lda ) + call stdlib${ii}$_sgemm( 'T', 'N', n2, n1, n2, one, work, m, b( j1, j1+n2 ),ldb, zero, & work( m*m+1 ), n2 ) - call stdlib_slacpy( 'FULL', n2, n1, work( m*m+1 ), n2, b( j1, j1+n2 ),ldb ) - call stdlib_sgemm( 'N', 'N', m, m, m, one, li, ldst, work, m, zero,work( m*m+1 ), m & + call stdlib${ii}$_slacpy( 'FULL', n2, n1, work( m*m+1 ), n2, b( j1, j1+n2 ),ldb ) + call stdlib${ii}$_sgemm( 'N', 'N', m, m, m, one, li, ldst, work, m, zero,work( m*m+1 ), m & ) - call stdlib_slacpy( 'FULL', m, m, work( m*m+1 ), m, li, ldst ) - call stdlib_sgemm( 'N', 'N', n2, n1, n1, one, a( j1, j1+n2 ), lda,t( n2+1, n2+1 ), & + call stdlib${ii}$_slacpy( 'FULL', m, m, work( m*m+1 ), m, li, ldst ) + call stdlib${ii}$_sgemm( 'N', 'N', n2, n1, n1, one, a( j1, j1+n2 ), lda,t( n2+1, n2+1 ), & ldst, zero, work, n2 ) - call stdlib_slacpy( 'FULL', n2, n1, work, n2, a( j1, j1+n2 ), lda ) - call stdlib_sgemm( 'N', 'N', n2, n1, n1, one, b( j1, j1+n2 ), ldb,t( n2+1, n2+1 ), & + call stdlib${ii}$_slacpy( 'FULL', n2, n1, work, n2, a( j1, j1+n2 ), lda ) + call stdlib${ii}$_sgemm( 'N', 'N', n2, n1, n1, one, b( j1, j1+n2 ), ldb,t( n2+1, n2+1 ), & ldst, zero, work, n2 ) - call stdlib_slacpy( 'FULL', n2, n1, work, n2, b( j1, j1+n2 ), ldb ) - call stdlib_sgemm( 'T', 'N', m, m, m, one, ir, ldst, t, ldst, zero,work, m ) - call stdlib_slacpy( 'FULL', m, m, work, m, ir, ldst ) + call stdlib${ii}$_slacpy( 'FULL', n2, n1, work, n2, b( j1, j1+n2 ), ldb ) + call stdlib${ii}$_sgemm( 'T', 'N', m, m, m, one, ir, ldst, t, ldst, zero,work, m ) + call stdlib${ii}$_slacpy( 'FULL', m, m, work, m, ir, ldst ) ! accumulate transformations into q and z if requested. if( wantq ) then - call stdlib_sgemm( 'N', 'N', n, m, m, one, q( 1, j1 ), ldq, li,ldst, zero, work, & + call stdlib${ii}$_sgemm( 'N', 'N', n, m, m, one, q( 1_${ik}$, j1 ), ldq, li,ldst, zero, work, & n ) - call stdlib_slacpy( 'FULL', n, m, work, n, q( 1, j1 ), ldq ) + call stdlib${ii}$_slacpy( 'FULL', n, m, work, n, q( 1_${ik}$, j1 ), ldq ) end if if( wantz ) then - call stdlib_sgemm( 'N', 'N', n, m, m, one, z( 1, j1 ), ldz, ir,ldst, zero, work, & + call stdlib${ii}$_sgemm( 'N', 'N', n, m, m, one, z( 1_${ik}$, j1 ), ldz, ir,ldst, zero, work, & n ) - call stdlib_slacpy( 'FULL', n, m, work, n, z( 1, j1 ), ldz ) + call stdlib${ii}$_slacpy( 'FULL', n, m, work, n, z( 1_${ik}$, j1 ), ldz ) end if ! update (a(j1:j1+m-1, m+j1:n), b(j1:j1+m-1, m+j1:n)) and ! (a(1:j1-1, j1:j1+m), b(1:j1-1, j1:j1+m)). i = j1 + m if( i<=n ) then - call stdlib_sgemm( 'T', 'N', m, n-i+1, m, one, li, ldst,a( j1, i ), lda, zero, & + call stdlib${ii}$_sgemm( 'T', 'N', m, n-i+1, m, one, li, ldst,a( j1, i ), lda, zero, & work, m ) - call stdlib_slacpy( 'FULL', m, n-i+1, work, m, a( j1, i ), lda ) - call stdlib_sgemm( 'T', 'N', m, n-i+1, m, one, li, ldst,b( j1, i ), ldb, zero, & + call stdlib${ii}$_slacpy( 'FULL', m, n-i+1, work, m, a( j1, i ), lda ) + call stdlib${ii}$_sgemm( 'T', 'N', m, n-i+1, m, one, li, ldst,b( j1, i ), ldb, zero, & work, m ) - call stdlib_slacpy( 'FULL', m, n-i+1, work, m, b( j1, i ), ldb ) + call stdlib${ii}$_slacpy( 'FULL', m, n-i+1, work, m, b( j1, i ), ldb ) end if - i = j1 - 1 - if( i>0 ) then - call stdlib_sgemm( 'N', 'N', i, m, m, one, a( 1, j1 ), lda, ir,ldst, zero, work, & + i = j1 - 1_${ik}$ + if( i>0_${ik}$ ) then + call stdlib${ii}$_sgemm( 'N', 'N', i, m, m, one, a( 1_${ik}$, j1 ), lda, ir,ldst, zero, work, & i ) - call stdlib_slacpy( 'FULL', i, m, work, i, a( 1, j1 ), lda ) - call stdlib_sgemm( 'N', 'N', i, m, m, one, b( 1, j1 ), ldb, ir,ldst, zero, work, & + call stdlib${ii}$_slacpy( 'FULL', i, m, work, i, a( 1_${ik}$, j1 ), lda ) + call stdlib${ii}$_sgemm( 'N', 'N', i, m, m, one, b( 1_${ik}$, j1 ), ldb, ir,ldst, zero, work, & i ) - call stdlib_slacpy( 'FULL', i, m, work, i, b( 1, j1 ), ldb ) + call stdlib${ii}$_slacpy( 'FULL', i, m, work, i, b( 1_${ik}$, j1 ), ldb ) end if ! exit with info = 0 if swap was successfully performed. return end if ! exit with info = 1 if swap was rejected. 70 continue - info = 1 + info = 1_${ik}$ return - end subroutine stdlib_stgex2 + end subroutine stdlib${ii}$_stgex2 - pure subroutine stdlib_stgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, ifst, ilst, & + pure subroutine stdlib${ii}$_stgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, ifst, ilst, & !! STGEXC reorders the generalized real Schur decomposition of a real !! matrix pair (A,B) using an orthogonal equivalence transformation !! (A, B) = Q * (A, B) * Z**T, @@ -56835,9 +56837,9 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: wantq, wantz - integer(ilp), intent(inout) :: ifst, ilst - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldb, ldq, ldz, lwork, n + integer(${ik}$), intent(inout) :: ifst, ilst + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldq, ldz, lwork, n ! Array Arguments real(sp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) real(sp), intent(out) :: work(*) @@ -56845,41 +56847,41 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: lquery - integer(ilp) :: here, lwmin, nbf, nbl, nbnext + integer(${ik}$) :: here, lwmin, nbf, nbl, nbnext ! Intrinsic Functions intrinsic :: max ! Executable Statements ! decode and test input arguments. - info = 0 - lquery = ( lwork==-1 ) - if( n<0 ) then - info = -3 - else if( ldan ) then - info = -12 - else if( ilst<1 .or. ilst>n ) then - info = -13 - end if - if( info==0 ) then - if( n<=1 ) then - lwmin = 1 - else - lwmin = 4*n + 16 - end if - work(1) = lwmin + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) + if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( ldan ) then + info = -12_${ik}$ + else if( ilst<1_${ik}$ .or. ilst>n ) then + info = -13_${ik}$ + end if + if( info==0_${ik}$ ) then + if( n<=1_${ik}$ ) then + lwmin = 1_${ik}$ + else + lwmin = 4_${ik}$*n + 16_${ik}$ + end if + work(1_${ik}$) = lwmin if (lwork1 ) then - if( a( ifst, ifst-1 )/=zero )ifst = ifst - 1 + if( ifst>1_${ik}$ ) then + if( a( ifst, ifst-1 )/=zero )ifst = ifst - 1_${ik}$ end if - nbf = 1 + nbf = 1_${ik}$ if( ifst1 ) then - if( a( ilst, ilst-1 )/=zero )ilst = ilst - 1 + if( ilst>1_${ik}$ ) then + if( a( ilst, ilst-1 )/=zero )ilst = ilst - 1_${ik}$ end if - nbl = 1 + nbl = 1_${ik}$ if( ilst=3 ) then - if( a( here-1, here-2 )/=zero )nbnext = 2 + nbnext = 1_${ik}$ + if( here>=3_${ik}$ ) then + if( a( here-1, here-2 )/=zero )nbnext = 2_${ik}$ end if - call stdlib_stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, here-nbnext, & + call stdlib${ii}$_stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, here-nbnext, & nbnext, nbf, work, lwork,info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then ilst = here return end if here = here - nbnext ! test if 2-by-2 block breaks into two 1-by-1 blocks. - if( nbf==2 ) then - if( a( here+1, here )==zero )nbf = 3 + if( nbf==2_${ik}$ ) then + if( a( here+1, here )==zero )nbf = 3_${ik}$ end if else ! current block consists of two 1-by-1 blocks, each of which ! must be swapped individually. - nbnext = 1 - if( here>=3 ) then - if( a( here-1, here-2 )/=zero )nbnext = 2 + nbnext = 1_${ik}$ + if( here>=3_${ik}$ ) then + if( a( here-1, here-2 )/=zero )nbnext = 2_${ik}$ end if - call stdlib_stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, here-nbnext, & - nbnext, 1, work, lwork,info ) - if( info/=0 ) then + call stdlib${ii}$_stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, here-nbnext, & + nbnext, 1_${ik}$, work, lwork,info ) + if( info/=0_${ik}$ ) then ilst = here return end if - if( nbnext==1 ) then + if( nbnext==1_${ik}$ ) then ! swap two 1-by-1 blocks. - call stdlib_stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, here, & - nbnext, 1, work, lwork, info ) - if( info/=0 ) then + call stdlib${ii}$_stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, here, & + nbnext, 1_${ik}$, work, lwork, info ) + if( info/=0_${ik}$ ) then ilst = here return end if - here = here - 1 + here = here - 1_${ik}$ else ! recompute nbnext in case of 2-by-2 split. - if( a( here, here-1 )==zero )nbnext = 1 - if( nbnext==2 ) then + if( a( here, here-1 )==zero )nbnext = 1_${ik}$ + if( nbnext==2_${ik}$ ) then ! 2-by-2 block did not split. - call stdlib_stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz, here-1,& - 2, 1, work, lwork, info ) - if( info/=0 ) then + call stdlib${ii}$_stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz, here-1,& + 2_${ik}$, 1_${ik}$, work, lwork, info ) + if( info/=0_${ik}$ ) then ilst = here return end if - here = here - 2 + here = here - 2_${ik}$ else ! 2-by-2 block did split. - call stdlib_stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz, here, & - 1, 1, work, lwork, info ) - if( info/=0 ) then + call stdlib${ii}$_stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz, here, & + 1_${ik}$, 1_${ik}$, work, lwork, info ) + if( info/=0_${ik}$ ) then ilst = here return end if - here = here - 1 - call stdlib_stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz, here, & - 1, 1, work, lwork, info ) - if( info/=0 ) then + here = here - 1_${ik}$ + call stdlib${ii}$_stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq,z, ldz, here, & + 1_${ik}$, 1_${ik}$, work, lwork, info ) + if( info/=0_${ik}$ ) then ilst = here return end if - here = here - 1 + here = here - 1_${ik}$ end if end if end if if( here>ilst )go to 20 end if ilst = here - work( 1 ) = lwmin + work( 1_${ik}$ ) = lwmin return - end subroutine stdlib_stgexc + end subroutine stdlib${ii}$_stgexc - pure subroutine stdlib_stgsen( ijob, wantq, wantz, select, n, a, lda, b, ldb,alphar, alphai, & + pure subroutine stdlib${ii}$_stgsen( ijob, wantq, wantz, select, n, a, lda, b, ldb,alphar, alphai, & !! STGSEN reorders the generalized real Schur decomposition of a real !! matrix pair (A, B) (in terms of an orthonormal equivalence trans- !! formation Q**T * (A, B) * Z), so that a selected cluster of eigenvalues @@ -57092,103 +57094,103 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: wantq, wantz - integer(ilp), intent(in) :: ijob, lda, ldb, ldq, ldz, liwork, lwork, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: ijob, lda, ldb, ldq, ldz, liwork, lwork, n + integer(${ik}$), intent(out) :: info, m real(sp), intent(out) :: pl, pr ! Array Arguments logical(lk), intent(in) :: select(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) real(sp), intent(out) :: alphai(*), alphar(*), beta(*), dif(*), work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: idifjb = 3 + integer(${ik}$), parameter :: idifjb = 3_${ik}$ ! Local Scalars logical(lk) :: lquery, pair, swap, wantd, wantd1, wantd2, wantp - integer(ilp) :: i, ierr, ijb, k, kase, kk, ks, liwmin, lwmin, mn2, n1, n2 + integer(${ik}$) :: i, ierr, ijb, k, kase, kk, ks, liwmin, lwmin, mn2, n1, n2 real(sp) :: dscale, dsum, eps, rdscal, smlnum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: max,sign,sqrt ! Executable Statements ! decode and test the input parameters - info = 0 - lquery = ( lwork==-1 .or. liwork==-1 ) - if( ijob<0 .or. ijob>5 ) then - info = -1 - else if( n<0 ) then - info = -5 - else if( lda5_${ik}$ ) then + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -5_${ik}$ + else if( lda=4 - wantd1 = ijob==2 .or. ijob==4 - wantd2 = ijob==3 .or. ijob==5 + eps = stdlib${ii}$_slamch( 'P' ) + smlnum = stdlib${ii}$_slamch( 'S' ) / eps + ierr = 0_${ik}$ + wantp = ijob==1_${ik}$ .or. ijob>=4_${ik}$ + wantd1 = ijob==2_${ik}$ .or. ijob==4_${ik}$ + wantd2 = ijob==3_${ik}$ .or. ijob==5_${ik}$ wantd = wantd1 .or. wantd2 ! set m to the dimension of the specified pair of deflating ! subspaces. - m = 0 + m = 0_${ik}$ pair = .false. - if( .not.lquery .or. ijob/=0 ) then + if( .not.lquery .or. ijob/=0_${ik}$ ) then do k = 1, n if( pair ) then pair = .false. else if( k0 ) then + if( ierr>0_${ik}$ ) then ! swap is rejected: exit. - info = 1 + info = 1_${ik}$ if( wantp ) then pl = zero pr = zero end if if( wantd ) then - dif( 1 ) = zero - dif( 2 ) = zero + dif( 1_${ik}$ ) = zero + dif( 2_${ik}$ ) = zero end if go to 60 end if - if( pair )ks = ks + 1 + if( pair )ks = ks + 1_${ik}$ end if end if end do loop_30 @@ -57250,18 +57252,18 @@ module stdlib_linalg_lapack_s ! and compute pl and pr. n1 = m n2 = n - m - i = n1 + 1 - ijb = 0 - call stdlib_slacpy( 'FULL', n1, n2, a( 1, i ), lda, work, n1 ) - call stdlib_slacpy( 'FULL', n1, n2, b( 1, i ), ldb, work( n1*n2+1 ),n1 ) - call stdlib_stgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b( i,& - i ), ldb, work( n1*n2+1 ), n1,dscale, dif( 1 ), work( n1*n2*2+1 ),lwork-2*n1*n2, & + i = n1 + 1_${ik}$ + ijb = 0_${ik}$ + call stdlib${ii}$_slacpy( 'FULL', n1, n2, a( 1_${ik}$, i ), lda, work, n1 ) + call stdlib${ii}$_slacpy( 'FULL', n1, n2, b( 1_${ik}$, i ), ldb, work( n1*n2+1 ),n1 ) + call stdlib${ii}$_stgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b( i,& + i ), ldb, work( n1*n2+1 ), n1,dscale, dif( 1_${ik}$ ), work( n1*n2*2_${ik}$+1 ),lwork-2*n1*n2, & iwork, ierr ) ! estimate the reciprocal of norms of "projections" onto left ! and right eigenspaces. rdscal = zero dsum = one - call stdlib_slassq( n1*n2, work, 1, rdscal, dsum ) + call stdlib${ii}$_slassq( n1*n2, work, 1_${ik}$, rdscal, dsum ) pl = rdscal*sqrt( dsum ) if( pl==zero ) then pl = one @@ -57270,7 +57272,7 @@ module stdlib_linalg_lapack_s end if rdscal = zero dsum = one - call stdlib_slassq( n1*n2, work( n1*n2+1 ), 1, rdscal, dsum ) + call stdlib${ii}$_slassq( n1*n2, work( n1*n2+1 ), 1_${ik}$, rdscal, dsum ) pr = rdscal*sqrt( dsum ) if( pr==zero ) then pr = one @@ -57283,65 +57285,65 @@ module stdlib_linalg_lapack_s if( wantd1 ) then n1 = m n2 = n - m - i = n1 + 1 + i = n1 + 1_${ik}$ ijb = idifjb ! frobenius norm-based difu-estimate. - call stdlib_stgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b(& - i, i ), ldb, work( n1*n2+1 ),n1, dscale, dif( 1 ), work( 2*n1*n2+1 ),lwork-& - 2*n1*n2, iwork, ierr ) + call stdlib${ii}$_stgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b(& + i, i ), ldb, work( n1*n2+1 ),n1, dscale, dif( 1_${ik}$ ), work( 2_${ik}$*n1*n2+1 ),lwork-& + 2_${ik}$*n1*n2, iwork, ierr ) ! frobenius norm-based difl-estimate. - call stdlib_stgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda, work,n2, b( i, i ),& - ldb, b, ldb, work( n1*n2+1 ),n2, dscale, dif( 2 ), work( 2*n1*n2+1 ),lwork-& - 2*n1*n2, iwork, ierr ) + call stdlib${ii}$_stgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda, work,n2, b( i, i ),& + ldb, b, ldb, work( n1*n2+1 ),n2, dscale, dif( 2_${ik}$ ), work( 2_${ik}$*n1*n2+1 ),lwork-& + 2_${ik}$*n1*n2, iwork, ierr ) else ! compute 1-norm-based estimates of difu and difl using - ! reversed communication with stdlib_slacn2. in each step a + ! reversed communication with stdlib${ii}$_slacn2. in each step a ! generalized sylvester equation or a transposed variant ! is solved. - kase = 0 + kase = 0_${ik}$ n1 = m n2 = n - m - i = n1 + 1 - ijb = 0 - mn2 = 2*n1*n2 + i = n1 + 1_${ik}$ + ijb = 0_${ik}$ + mn2 = 2_${ik}$*n1*n2 ! 1-norm-based estimate of difu. 40 continue - call stdlib_slacn2( mn2, work( mn2+1 ), work, iwork, dif( 1 ),kase, isave ) + call stdlib${ii}$_slacn2( mn2, work( mn2+1 ), work, iwork, dif( 1_${ik}$ ),kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! solve generalized sylvester equation. - call stdlib_stgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & - ldb, b( i, i ), ldb,work( n1*n2+1 ), n1, dscale, dif( 1 ),work( 2*n1*n2+1 )& + call stdlib${ii}$_stgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & + ldb, b( i, i ), ldb,work( n1*n2+1 ), n1, dscale, dif( 1_${ik}$ ),work( 2_${ik}$*n1*n2+1 )& , lwork-2*n1*n2, iwork,ierr ) else ! solve the transposed variant. - call stdlib_stgsyl( 'T', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & - ldb, b( i, i ), ldb,work( n1*n2+1 ), n1, dscale, dif( 1 ),work( 2*n1*n2+1 )& + call stdlib${ii}$_stgsyl( 'T', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & + ldb, b( i, i ), ldb,work( n1*n2+1 ), n1, dscale, dif( 1_${ik}$ ),work( 2_${ik}$*n1*n2+1 )& , lwork-2*n1*n2, iwork,ierr ) end if go to 40 end if - dif( 1 ) = dscale / dif( 1 ) + dif( 1_${ik}$ ) = dscale / dif( 1_${ik}$ ) ! 1-norm-based estimate of difl. 50 continue - call stdlib_slacn2( mn2, work( mn2+1 ), work, iwork, dif( 2 ),kase, isave ) + call stdlib${ii}$_slacn2( mn2, work( mn2+1 ), work, iwork, dif( 2_${ik}$ ),kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! solve generalized sylvester equation. - call stdlib_stgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b( & - i, i ), ldb, b, ldb,work( n1*n2+1 ), n2, dscale, dif( 2 ),work( 2*n1*n2+1 )& + call stdlib${ii}$_stgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b( & + i, i ), ldb, b, ldb,work( n1*n2+1 ), n2, dscale, dif( 2_${ik}$ ),work( 2_${ik}$*n1*n2+1 )& , lwork-2*n1*n2, iwork,ierr ) else ! solve the transposed variant. - call stdlib_stgsyl( 'T', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b( & - i, i ), ldb, b, ldb,work( n1*n2+1 ), n2, dscale, dif( 2 ),work( 2*n1*n2+1 )& + call stdlib${ii}$_stgsyl( 'T', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b( & + i, i ), ldb, b, ldb,work( n1*n2+1 ), n2, dscale, dif( 2_${ik}$ ),work( 2_${ik}$*n1*n2+1 )& , lwork-2*n1*n2, iwork,ierr ) end if go to 50 end if - dif( 2 ) = dscale / dif( 2 ) + dif( 2_${ik}$ ) = dscale / dif( 2_${ik}$ ) end if end if 60 continue @@ -57359,15 +57361,15 @@ module stdlib_linalg_lapack_s end if if( pair ) then ! compute the eigenvalue(s) at position k. - work( 1 ) = a( k, k ) - work( 2 ) = a( k+1, k ) - work( 3 ) = a( k, k+1 ) - work( 4 ) = a( k+1, k+1 ) - work( 5 ) = b( k, k ) - work( 6 ) = b( k+1, k ) - work( 7 ) = b( k, k+1 ) - work( 8 ) = b( k+1, k+1 ) - call stdlib_slag2( work, 2, work( 5 ), 2, smlnum*eps, beta( k ),beta( k+1 ), & + work( 1_${ik}$ ) = a( k, k ) + work( 2_${ik}$ ) = a( k+1, k ) + work( 3_${ik}$ ) = a( k, k+1 ) + work( 4_${ik}$ ) = a( k+1, k+1 ) + work( 5_${ik}$ ) = b( k, k ) + work( 6_${ik}$ ) = b( k+1, k ) + work( 7_${ik}$ ) = b( k, k+1 ) + work( 8_${ik}$ ) = b( k+1, k+1 ) + call stdlib${ii}$_slag2( work, 2_${ik}$, work( 5_${ik}$ ), 2_${ik}$, smlnum*eps, beta( k ),beta( k+1 ), & alphar( k ), alphar( k+1 ),alphai( k ) ) alphai( k+1 ) = -alphai( k ) else @@ -57385,13 +57387,13 @@ module stdlib_linalg_lapack_s end if end if end do loop_70 - work( 1 ) = lwmin - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = lwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_stgsen + end subroutine stdlib${ii}$_stgsen - pure subroutine stdlib_stgsja( jobu, jobv, jobq, m, p, n, k, l, a, lda, b,ldb, tola, tolb, & + pure subroutine stdlib${ii}$_stgsja( jobu, jobv, jobq, m, p, n, k, l, a, lda, b,ldb, tola, tolb, & !! STGSJA computes the generalized singular value decomposition (GSVD) !! of two real upper triangular (or trapezoidal) matrices A and B. !! On entry, it is assumed that matrices A and B have the following @@ -57459,21 +57461,21 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobq, jobu, jobv - integer(ilp), intent(out) :: info, ncycle - integer(ilp), intent(in) :: k, l, lda, ldb, ldq, ldu, ldv, m, n, p + integer(${ik}$), intent(out) :: info, ncycle + integer(${ik}$), intent(in) :: k, l, lda, ldb, ldq, ldu, ldv, m, n, p real(sp), intent(in) :: tola, tolb ! Array Arguments real(sp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), u(ldu,*), v(ldv,*) real(sp), intent(out) :: alpha(*), beta(*), work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: maxit = 40 + integer(${ik}$), parameter :: maxit = 40_${ik}$ real(sp), parameter :: hugenum = huge(zero) ! Local Scalars logical(lk) :: initq, initu, initv, upper, wantq, wantu, wantv - integer(ilp) :: i, j, kcycle + integer(${ik}$) :: i, j, kcycle real(sp) :: a1, a2, a3, b1, b2, b3, csq, csu, csv, error, gamma, rwk, snq, snu, snv, & ssmin ! Intrinsic Functions @@ -57486,38 +57488,38 @@ module stdlib_linalg_lapack_s wantv = initv .or. stdlib_lsame( jobv, 'V' ) initq = stdlib_lsame( jobq, 'I' ) wantq = initq .or. stdlib_lsame( jobq, 'Q' ) - info = 0 + info = 0_${ik}$ if( .not.( initu .or. wantu .or. stdlib_lsame( jobu, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( initv .or. wantv .or. stdlib_lsame( jobv, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( initq .or. wantq .or. stdlib_lsame( jobq, 'N' ) ) ) then - info = -3 - else if( m<0 ) then - info = -4 - else if( p<0 ) then - info = -5 - else if( n<0 ) then - info = -6 - else if( lda=-hugenum) ) then ! change sign if necessary if( gamma=beta( k+i ) ) then - call stdlib_sscal( l-i+1, one / alpha( k+i ), a( k+i, n-l+i ),lda ) + call stdlib${ii}$_sscal( l-i+1, one / alpha( k+i ), a( k+i, n-l+i ),lda ) else - call stdlib_sscal( l-i+1, one / beta( k+i ), b( i, n-l+i ),ldb ) - call stdlib_scopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) + call stdlib${ii}$_sscal( l-i+1, one / beta( k+i ), b( i, n-l+i ),ldb ) + call stdlib${ii}$_scopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) end if else alpha( k+i ) = zero beta( k+i ) = one - call stdlib_scopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) + call stdlib${ii}$_scopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) end if end do ! post-assignment @@ -57629,10 +57631,10 @@ module stdlib_linalg_lapack_s 100 continue ncycle = kcycle return - end subroutine stdlib_stgsja + end subroutine stdlib${ii}$_stgsja - pure subroutine stdlib_stgsna( job, howmny, select, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, s, & + pure subroutine stdlib${ii}$_stgsna( job, howmny, select, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, s, & !! STGSNA estimates reciprocal condition numbers for specified !! eigenvalues and/or eigenvectors of a matrix pair (A, B) in !! generalized real Schur canonical form (or of any matrix pair @@ -57647,25 +57649,25 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: howmny, job - integer(ilp), intent(out) :: info, m - integer(ilp), intent(in) :: lda, ldb, ldvl, ldvr, lwork, mm, n + integer(${ik}$), intent(out) :: info, m + integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, mm, n ! Array Arguments logical(lk), intent(in) :: select(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(in) :: a(lda,*), b(ldb,*), vl(ldvl,*), vr(ldvr,*) real(sp), intent(out) :: dif(*), s(*), work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: difdri = 3 + integer(${ik}$), parameter :: difdri = 3_${ik}$ ! Local Scalars logical(lk) :: lquery, pair, somcon, wantbh, wantdf, wants - integer(ilp) :: i, ierr, ifst, ilst, iz, k, ks, lwmin, n1, n2 + integer(${ik}$) :: i, ierr, ifst, ilst, iz, k, ks, lwmin, n1, n2 real(sp) :: alphai, alphar, alprqt, beta, c1, c2, cond, eps, lnrm, rnrm, root1, root2, & scale, smlnum, tmpii, tmpir, tmpri, tmprr, uhav, uhavi, uhbv, uhbvi ! Local Arrays - real(sp) :: dummy(1), dummy1(1) + real(sp) :: dummy(1_${ik}$), dummy1(1_${ik}$) ! Intrinsic Functions intrinsic :: max,min,sqrt ! Executable Statements @@ -57674,27 +57676,27 @@ module stdlib_linalg_lapack_s wants = stdlib_lsame( job, 'E' ) .or. wantbh wantdf = stdlib_lsame( job, 'V' ) .or. wantbh somcon = stdlib_lsame( howmny, 'S' ) - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) if( .not.wants .and. .not.wantdf ) then - info = -1 + info = -1_${ik}$ else if( .not.stdlib_lsame( howmny, 'A' ) .and. .not.somcon ) then - info = -2 - else if( n<0 ) then - info = -4 - else if( lda0 ) then + ilst = 1_${ik}$ + call stdlib${ii}$_stgexc( .false., .false., n, work, n, work( n*n+1 ), n,dummy, 1_${ik}$, & + dummy1, 1_${ik}$, ifst, ilst,work( n*n*2_${ik}$+1 ), lwork-2*n*n, ierr ) + if( ierr>0_${ik}$ ) then ! ill-conditioned problem - swap rejected. dif( ks ) = zero else @@ -57857,15 +57859,15 @@ module stdlib_linalg_lapack_s ! a22 * r - l * a11 = a12 ! b22 * r - l * b11 = b12, ! and compute estimate of difl((a11,b11), (a22, b22)). - n1 = 1 - if( work( 2 )/=zero )n1 = 2 + n1 = 1_${ik}$ + if( work( 2_${ik}$ )/=zero )n1 = 2_${ik}$ n2 = n - n1 - if( n2==0 ) then + if( n2==0_${ik}$ ) then dif( ks ) = cond else - i = n*n + 1 - iz = 2*n*n + 1 - call stdlib_stgsyl( 'N', difdri, n2, n1, work( n*n1+n1+1 ),n, work, n, & + i = n*n + 1_${ik}$ + iz = 2_${ik}$*n*n + 1_${ik}$ + call stdlib${ii}$_stgsyl( 'N', difdri, n2, n1, work( n*n1+n1+1 ),n, work, n, & work( n1+1 ), n,work( n*n1+n1+i ), n, work( i ), n,work( n1+i ), n, scale, & dif( ks ),work( iz+1 ), lwork-2*n*n, iwork, ierr ) if( pair )dif( ks ) = min( max( one, alprqt )*dif( ks ),cond ) @@ -57873,14 +57875,14 @@ module stdlib_linalg_lapack_s end if if( pair )dif( ks+1 ) = dif( ks ) end if - if( pair )ks = ks + 1 + if( pair )ks = ks + 1_${ik}$ end do loop_20 - work( 1 ) = lwmin + work( 1_${ik}$ ) = lwmin return - end subroutine stdlib_stgsna + end subroutine stdlib${ii}$_stgsna - pure subroutine stdlib_stplqt( m, n, l, mb, a, lda, b, ldb, t, ldt, work,info ) + pure subroutine stdlib${ii}$_stplqt( m, n, l, mb, a, lda, b, ldb, t, ldt, work,info ) !! STPLQT computes a blocked LQ factorization of a real !! "triangular-pentagonal" matrix C, which is composed of a !! triangular block A and pentagonal block B, using the compact @@ -57889,34 +57891,34 @@ 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, ldb, ldt, n, m, l, mb + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l, mb ! Array Arguments real(sp), intent(inout) :: a(lda,*), b(ldb,*) real(sp), intent(out) :: t(ldt,*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ib, lb, nb, iinfo + integer(${ik}$) :: i, ib, lb, nb, iinfo ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( l<0 .or. (l>min(m,n) .and. min(m,n)>=0)) then - info = -3 - else if( mb<1 .or. (mb>m .and. m>0)) then - info = -4 - else if( ldamin(m,n) .and. min(m,n)>=0_${ik}$)) then + info = -3_${ik}$ + else if( mb<1_${ik}$ .or. (mb>m .and. m>0_${ik}$)) then + info = -4_${ik}$ + else if( lda=l ) then - lb = 0 + lb = 0_${ik}$ else lb = nb-n+l-i+1 end if - call stdlib_stplqt2( ib, nb, lb, a(i,i), lda, b( i, 1 ), ldb,t(1, i ), ldt, iinfo ) + call stdlib${ii}$_stplqt2( ib, nb, lb, a(i,i), lda, b( i, 1_${ik}$ ), ldb,t(1_${ik}$, i ), ldt, iinfo ) ! update by applying h**t to b(i+ib:m,:) from the right if( i+ib<=m ) then - call stdlib_stprfb( 'R', 'N', 'F', 'R', m-i-ib+1, nb, ib, lb,b( i, 1 ), ldb, t( & - 1, i ), ldt,a( i+ib, i ), lda, b( i+ib, 1 ), ldb,work, m-i-ib+1) + call stdlib${ii}$_stprfb( 'R', 'N', 'F', 'R', m-i-ib+1, nb, ib, lb,b( i, 1_${ik}$ ), ldb, t( & + 1_${ik}$, i ), ldt,a( i+ib, i ), lda, b( i+ib, 1_${ik}$ ), ldb,work, m-i-ib+1) end if end do return - end subroutine stdlib_stplqt + end subroutine stdlib${ii}$_stplqt - pure subroutine stdlib_stpqrt( m, n, l, nb, a, lda, b, ldb, t, ldt, work,info ) + pure subroutine stdlib${ii}$_stpqrt( m, n, l, nb, a, lda, b, ldb, t, ldt, work,info ) !! STPQRT computes a blocked QR factorization of a real !! "triangular-pentagonal" matrix C, which is composed of a !! triangular block A and pentagonal block B, using the compact @@ -57951,34 +57953,34 @@ 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, ldb, ldt, n, m, l, nb + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l, nb ! Array Arguments real(sp), intent(inout) :: a(lda,*), b(ldb,*) real(sp), intent(out) :: t(ldt,*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ib, lb, mb, iinfo + integer(${ik}$) :: i, ib, lb, mb, iinfo ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( l<0 .or. (l>min(m,n) .and. min(m,n)>=0)) then - info = -3 - else if( nb<1 .or. (nb>n .and. n>0)) then - info = -4 - else if( ldamin(m,n) .and. min(m,n)>=0_${ik}$)) then + info = -3_${ik}$ + else if( nb<1_${ik}$ .or. (nb>n .and. n>0_${ik}$)) then + info = -4_${ik}$ + else if( lda=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-m+l-i+1 end if - call stdlib_stpqrt2( mb, ib, lb, a(i,i), lda, b( 1, i ), ldb,t(1, i ), ldt, iinfo ) + call stdlib${ii}$_stpqrt2( mb, ib, lb, a(i,i), lda, b( 1_${ik}$, i ), ldb,t(1_${ik}$, i ), ldt, iinfo ) ! update by applying h^h to b(:,i+ib:n) from the left if( i+ib<=n ) then - call stdlib_stprfb( 'L', 'T', 'F', 'C', mb, n-i-ib+1, ib, lb,b( 1, i ), ldb, t( & - 1, i ), ldt,a( i, i+ib ), lda, b( 1, i+ib ), ldb,work, ib ) + call stdlib${ii}$_stprfb( 'L', 'T', 'F', 'C', mb, n-i-ib+1, ib, lb,b( 1_${ik}$, i ), ldb, t( & + 1_${ik}$, i ), ldt,a( i, i+ib ), lda, b( 1_${ik}$, i+ib ), ldb,work, ib ) end if end do return - end subroutine stdlib_stpqrt + end subroutine stdlib${ii}$_stpqrt - pure subroutine stdlib_strevc( side, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, mm, m, & + pure subroutine stdlib${ii}$_strevc( side, howmny, select, n, t, ldt, vl, ldvl, vr,ldvr, mm, m, & !! STREVC computes some or all of the right and/or left eigenvectors of !! a real upper quasi-triangular matrix T. !! Matrices of this type are produced by the Schur factorization of @@ -58026,8 +58028,8 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: howmny, side - integer(ilp), intent(out) :: info, m - integer(ilp), intent(in) :: ldt, ldvl, ldvr, mm, n + integer(${ik}$), intent(out) :: info, m + integer(${ik}$), intent(in) :: ldt, ldvl, ldvr, mm, n ! Array Arguments logical(lk), intent(inout) :: select(*) real(sp), intent(in) :: t(ldt,*) @@ -58037,13 +58039,13 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: allv, bothv, leftv, over, pair, rightv, somev - integer(ilp) :: i, ierr, ii, ip, is, j, j1, j2, jnxt, k, ki, n2 + integer(${ik}$) :: i, ierr, ii, ip, is, j, j1, j2, jnxt, k, ki, n2 real(sp) :: beta, bignum, emax, ovfl, rec, remax, scale, smin, smlnum, ulp, unfl, & vcrit, vmax, wi, wr, xnorm ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Local Arrays - real(sp) :: x(2,2) + real(sp) :: x(2_${ik}$,2_${ik}$) ! Executable Statements ! decode and test the input parameters bothv = stdlib_lsame( side, 'B' ) @@ -58052,25 +58054,25 @@ module stdlib_linalg_lapack_s allv = stdlib_lsame( howmny, 'A' ) over = stdlib_lsame( howmny, 'B' ) somev = stdlib_lsame( howmny, 'S' ) - info = 0 + info = 0_${ik}$ if( .not.rightv .and. .not.leftv ) then - info = -1 + info = -1_${ik}$ else if( .not.allv .and. .not.over .and. .not.somev ) then - info = -2 - else if( n<0 ) then - info = -4 - else if( ldtjnxt )cycle loop_60 j1 = j j2 = j - jnxt = j - 1 - if( j>1 ) then + jnxt = j - 1_${ik}$ + if( j>1_${ik}$ ) then if( t( j, j-1 )/=zero ) then - j1 = j - 1 - jnxt = j - 2 + j1 = j - 1_${ik}$ + jnxt = j - 2_${ik}$ end if end if if( j1==j2 ) then ! 1-by-1 diagonal block - call stdlib_slaln2( .false., 1, 1, smin, one, t( j, j ),ldt, one, one, & - work( j+n ), n, wr,zero, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_slaln2( .false., 1_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr ) ! scale x(1,1) to avoid overflow when updating ! the right-hand side. if( xnorm>one ) then if( work( j )>bignum / xnorm ) then - x( 1, 1 ) = x( 1, 1 ) / xnorm + x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm scale = scale / xnorm end if end if ! scale if necessary - if( scale/=one )call stdlib_sscal( ki, scale, work( 1+n ), 1 ) - work( j+n ) = x( 1, 1 ) + if( scale/=one )call stdlib${ii}$_sscal( ki, scale, work( 1_${ik}$+n ), 1_${ik}$ ) + work( j+n ) = x( 1_${ik}$, 1_${ik}$ ) ! update right-hand side - call stdlib_saxpy( j-1, -x( 1, 1 ), t( 1, j ), 1,work( 1+n ), 1 ) + call stdlib${ii}$_saxpy( j-1, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ ) else ! 2-by-2 diagonal block - call stdlib_slaln2( .false., 2, 1, smin, one,t( j-1, j-1 ), ldt, one, & - one,work( j-1+n ), n, wr, zero, x, 2,scale, xnorm, ierr ) + call stdlib${ii}$_slaln2( .false., 2_${ik}$, 1_${ik}$, smin, one,t( j-1, j-1 ), ldt, one, & + one,work( j-1+n ), n, wr, zero, x, 2_${ik}$,scale, xnorm, ierr ) ! scale x(1,1) and x(2,1) to avoid overflow when ! updating the right-hand side. if( xnorm>one ) then beta = max( work( j-1 ), work( j ) ) if( beta>bignum / xnorm ) then - x( 1, 1 ) = x( 1, 1 ) / xnorm - x( 2, 1 ) = x( 2, 1 ) / xnorm + x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm + x( 2_${ik}$, 1_${ik}$ ) = x( 2_${ik}$, 1_${ik}$ ) / xnorm scale = scale / xnorm end if end if ! scale if necessary - if( scale/=one )call stdlib_sscal( ki, scale, work( 1+n ), 1 ) - work( j-1+n ) = x( 1, 1 ) - work( j+n ) = x( 2, 1 ) + if( scale/=one )call stdlib${ii}$_sscal( ki, scale, work( 1_${ik}$+n ), 1_${ik}$ ) + work( j-1+n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+n ) = x( 2_${ik}$, 1_${ik}$ ) ! update right-hand side - call stdlib_saxpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,work( 1+n ), 1 ) + call stdlib${ii}$_saxpy( j-2, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ ) - call stdlib_saxpy( j-2, -x( 2, 1 ), t( 1, j ), 1,work( 1+n ), 1 ) + call stdlib${ii}$_saxpy( j-2, -x( 2_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ ) end if end do loop_60 ! copy the vector x or q*x to vr and normalize. if( .not.over ) then - call stdlib_scopy( ki, work( 1+n ), 1, vr( 1, is ), 1 ) - ii = stdlib_isamax( ki, vr( 1, is ), 1 ) + call stdlib${ii}$_scopy( ki, work( 1_${ik}$+n ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ ) + ii = stdlib${ii}$_isamax( ki, vr( 1_${ik}$, is ), 1_${ik}$ ) remax = one / abs( vr( ii, is ) ) - call stdlib_sscal( ki, remax, vr( 1, is ), 1 ) + call stdlib${ii}$_sscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ ) do k = ki + 1, n vr( k, is ) = zero end do else - if( ki>1 )call stdlib_sgemv( 'N', n, ki-1, one, vr, ldvr,work( 1+n ), 1, & - work( ki+n ),vr( 1, ki ), 1 ) - ii = stdlib_isamax( n, vr( 1, ki ), 1 ) + if( ki>1_${ik}$ )call stdlib${ii}$_sgemv( 'N', n, ki-1, one, vr, ldvr,work( 1_${ik}$+n ), 1_${ik}$, & + work( ki+n ),vr( 1_${ik}$, ki ), 1_${ik}$ ) + ii = stdlib${ii}$_isamax( n, vr( 1_${ik}$, ki ), 1_${ik}$ ) remax = one / abs( vr( ii, ki ) ) - call stdlib_sscal( n, remax, vr( 1, ki ), 1 ) + call stdlib${ii}$_sscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ ) end if else ! complex right eigenvector. @@ -58249,130 +58251,130 @@ module stdlib_linalg_lapack_s end do ! solve upper quasi-triangular system: ! (t(1:ki-2,1:ki-2) - (wr+i*wi))*x = scale*(work+i*work2) - jnxt = ki - 2 + jnxt = ki - 2_${ik}$ loop_90: do j = ki - 2, 1, -1 if( j>jnxt )cycle loop_90 j1 = j j2 = j - jnxt = j - 1 - if( j>1 ) then + jnxt = j - 1_${ik}$ + if( j>1_${ik}$ ) then if( t( j, j-1 )/=zero ) then - j1 = j - 1 - jnxt = j - 2 + j1 = j - 1_${ik}$ + jnxt = j - 2_${ik}$ end if end if if( j1==j2 ) then ! 1-by-1 diagonal block - call stdlib_slaln2( .false., 1, 2, smin, one, t( j, j ),ldt, one, one, & - work( j+n ), n, wr, wi,x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_slaln2( .false., 1_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+n ), n, wr, wi,x, 2_${ik}$, scale, xnorm, ierr ) ! scale x(1,1) and x(1,2) to avoid overflow when ! updating the right-hand side. if( xnorm>one ) then if( work( j )>bignum / xnorm ) then - x( 1, 1 ) = x( 1, 1 ) / xnorm - x( 1, 2 ) = x( 1, 2 ) / xnorm + x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm + x( 1_${ik}$, 2_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ ) / xnorm scale = scale / xnorm end if end if ! scale if necessary if( scale/=one ) then - call stdlib_sscal( ki, scale, work( 1+n ), 1 ) - call stdlib_sscal( ki, scale, work( 1+n2 ), 1 ) + call stdlib${ii}$_sscal( ki, scale, work( 1_${ik}$+n ), 1_${ik}$ ) + call stdlib${ii}$_sscal( ki, scale, work( 1_${ik}$+n2 ), 1_${ik}$ ) end if - work( j+n ) = x( 1, 1 ) - work( j+n2 ) = x( 1, 2 ) + work( j+n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+n2 ) = x( 1_${ik}$, 2_${ik}$ ) ! update the right-hand side - call stdlib_saxpy( j-1, -x( 1, 1 ), t( 1, j ), 1,work( 1+n ), 1 ) + call stdlib${ii}$_saxpy( j-1, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ ) - call stdlib_saxpy( j-1, -x( 1, 2 ), t( 1, j ), 1,work( 1+n2 ), 1 ) + call stdlib${ii}$_saxpy( j-1, -x( 1_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n2 ), 1_${ik}$ ) else ! 2-by-2 diagonal block - call stdlib_slaln2( .false., 2, 2, smin, one,t( j-1, j-1 ), ldt, one, & - one,work( j-1+n ), n, wr, wi, x, 2, scale,xnorm, ierr ) + call stdlib${ii}$_slaln2( .false., 2_${ik}$, 2_${ik}$, smin, one,t( j-1, j-1 ), ldt, one, & + one,work( j-1+n ), n, wr, wi, x, 2_${ik}$, scale,xnorm, ierr ) ! scale x to avoid overflow when updating ! the right-hand side. if( xnorm>one ) then beta = max( work( j-1 ), work( j ) ) if( beta>bignum / xnorm ) then rec = one / xnorm - x( 1, 1 ) = x( 1, 1 )*rec - x( 1, 2 ) = x( 1, 2 )*rec - x( 2, 1 ) = x( 2, 1 )*rec - x( 2, 2 ) = x( 2, 2 )*rec + x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ )*rec + x( 1_${ik}$, 2_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ )*rec + x( 2_${ik}$, 1_${ik}$ ) = x( 2_${ik}$, 1_${ik}$ )*rec + x( 2_${ik}$, 2_${ik}$ ) = x( 2_${ik}$, 2_${ik}$ )*rec scale = scale*rec end if end if ! scale if necessary if( scale/=one ) then - call stdlib_sscal( ki, scale, work( 1+n ), 1 ) - call stdlib_sscal( ki, scale, work( 1+n2 ), 1 ) + call stdlib${ii}$_sscal( ki, scale, work( 1_${ik}$+n ), 1_${ik}$ ) + call stdlib${ii}$_sscal( ki, scale, work( 1_${ik}$+n2 ), 1_${ik}$ ) end if - work( j-1+n ) = x( 1, 1 ) - work( j+n ) = x( 2, 1 ) - work( j-1+n2 ) = x( 1, 2 ) - work( j+n2 ) = x( 2, 2 ) + work( j-1+n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+n ) = x( 2_${ik}$, 1_${ik}$ ) + work( j-1+n2 ) = x( 1_${ik}$, 2_${ik}$ ) + work( j+n2 ) = x( 2_${ik}$, 2_${ik}$ ) ! update the right-hand side - call stdlib_saxpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,work( 1+n ), 1 ) + call stdlib${ii}$_saxpy( j-2, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ ) - call stdlib_saxpy( j-2, -x( 2, 1 ), t( 1, j ), 1,work( 1+n ), 1 ) + call stdlib${ii}$_saxpy( j-2, -x( 2_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n ), 1_${ik}$ ) - call stdlib_saxpy( j-2, -x( 1, 2 ), t( 1, j-1 ), 1,work( 1+n2 ), 1 ) + call stdlib${ii}$_saxpy( j-2, -x( 1_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+n2 ), 1_${ik}$ ) - call stdlib_saxpy( j-2, -x( 2, 2 ), t( 1, j ), 1,work( 1+n2 ), 1 ) + call stdlib${ii}$_saxpy( j-2, -x( 2_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+n2 ), 1_${ik}$ ) end if end do loop_90 ! copy the vector x or q*x to vr and normalize. if( .not.over ) then - call stdlib_scopy( ki, work( 1+n ), 1, vr( 1, is-1 ), 1 ) - call stdlib_scopy( ki, work( 1+n2 ), 1, vr( 1, is ), 1 ) + call stdlib${ii}$_scopy( ki, work( 1_${ik}$+n ), 1_${ik}$, vr( 1_${ik}$, is-1 ), 1_${ik}$ ) + call stdlib${ii}$_scopy( ki, work( 1_${ik}$+n2 ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ ) emax = zero do k = 1, ki emax = max( emax, abs( vr( k, is-1 ) )+abs( vr( k, is ) ) ) end do remax = one / emax - call stdlib_sscal( ki, remax, vr( 1, is-1 ), 1 ) - call stdlib_sscal( ki, remax, vr( 1, is ), 1 ) + call stdlib${ii}$_sscal( ki, remax, vr( 1_${ik}$, is-1 ), 1_${ik}$ ) + call stdlib${ii}$_sscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ ) do k = ki + 1, n vr( k, is-1 ) = zero vr( k, is ) = zero end do else - if( ki>2 ) then - call stdlib_sgemv( 'N', n, ki-2, one, vr, ldvr,work( 1+n ), 1, work( ki-& - 1+n ),vr( 1, ki-1 ), 1 ) - call stdlib_sgemv( 'N', n, ki-2, one, vr, ldvr,work( 1+n2 ), 1, work( & - ki+n2 ),vr( 1, ki ), 1 ) + if( ki>2_${ik}$ ) then + call stdlib${ii}$_sgemv( 'N', n, ki-2, one, vr, ldvr,work( 1_${ik}$+n ), 1_${ik}$, work( ki-& + 1_${ik}$+n ),vr( 1_${ik}$, ki-1 ), 1_${ik}$ ) + call stdlib${ii}$_sgemv( 'N', n, ki-2, one, vr, ldvr,work( 1_${ik}$+n2 ), 1_${ik}$, work( & + ki+n2 ),vr( 1_${ik}$, ki ), 1_${ik}$ ) else - call stdlib_sscal( n, work( ki-1+n ), vr( 1, ki-1 ), 1 ) - call stdlib_sscal( n, work( ki+n2 ), vr( 1, ki ), 1 ) + call stdlib${ii}$_sscal( n, work( ki-1+n ), vr( 1_${ik}$, ki-1 ), 1_${ik}$ ) + call stdlib${ii}$_sscal( n, work( ki+n2 ), vr( 1_${ik}$, ki ), 1_${ik}$ ) end if emax = zero do k = 1, n emax = max( emax, abs( vr( k, ki-1 ) )+abs( vr( k, ki ) ) ) end do remax = one / emax - call stdlib_sscal( n, remax, vr( 1, ki-1 ), 1 ) - call stdlib_sscal( n, remax, vr( 1, ki ), 1 ) + call stdlib${ii}$_sscal( n, remax, vr( 1_${ik}$, ki-1 ), 1_${ik}$ ) + call stdlib${ii}$_sscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ ) end if end if - is = is - 1 - if( ip/=0 )is = is - 1 + is = is - 1_${ik}$ + if( ip/=0_${ik}$ )is = is - 1_${ik}$ 130 continue - if( ip==1 )ip = 0 - if( ip==-1 )ip = 1 + if( ip==1_${ik}$ )ip = 0_${ik}$ + if( ip==-1_${ik}$ )ip = 1_${ik}$ end do loop_140 end if if( leftv ) then ! compute left eigenvectors. - ip = 0 - is = 1 + ip = 0_${ik}$ + is = 1_${ik}$ loop_260: do ki = 1, n if( ip==-1 )go to 250 if( ki==n )go to 150 if( t( ki+1, ki )==zero )go to 150 - ip = 1 + ip = 1_${ik}$ 150 continue if( somev ) then if( .not.select( ki ) )go to 250 @@ -58380,9 +58382,9 @@ module stdlib_linalg_lapack_s ! compute the ki-th eigenvalue (wr,wi). wr = t( ki, ki ) wi = zero - if( ip/=0 )wi = sqrt( abs( t( ki, ki+1 ) ) )*sqrt( abs( t( ki+1, ki ) ) ) + if( ip/=0_${ik}$ )wi = sqrt( abs( t( ki, ki+1 ) ) )*sqrt( abs( t( ki+1, ki ) ) ) smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum ) - if( ip==0 ) then + if( ip==0_${ik}$ ) then ! real left eigenvector. work( ki+n ) = one ! form right-hand side @@ -58393,16 +58395,16 @@ module stdlib_linalg_lapack_s ! (t(ki+1:n,ki+1:n) - wr)**t*x = scale*work vmax = one vcrit = bignum - jnxt = ki + 1 + jnxt = ki + 1_${ik}$ loop_170: do j = ki + 1, n if( jvcrit ) then rec = one / vmax - call stdlib_sscal( n-ki+1, rec, work( ki+n ), 1 ) + call stdlib${ii}$_sscal( n-ki+1, rec, work( ki+n ), 1_${ik}$ ) vmax = one vcrit = bignum end if - work( j+n ) = work( j+n ) -stdlib_sdot( j-ki-1, t( ki+1, j ), 1,work( & - ki+1+n ), 1 ) + work( j+n ) = work( j+n ) -stdlib${ii}$_sdot( j-ki-1, t( ki+1, j ), 1_${ik}$,work( & + ki+1+n ), 1_${ik}$ ) ! solve (t(j,j)-wr)**t*x = work - call stdlib_slaln2( .false., 1, 1, smin, one, t( j, j ),ldt, one, one, & - work( j+n ), n, wr,zero, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_slaln2( .false., 1_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr ) ! scale if necessary - if( scale/=one )call stdlib_sscal( n-ki+1, scale, work( ki+n ), 1 ) + if( scale/=one )call stdlib${ii}$_sscal( n-ki+1, scale, work( ki+n ), 1_${ik}$ ) - work( j+n ) = x( 1, 1 ) + work( j+n ) = x( 1_${ik}$, 1_${ik}$ ) vmax = max( abs( work( j+n ) ), vmax ) vcrit = bignum / vmax else @@ -58433,43 +58435,43 @@ module stdlib_linalg_lapack_s beta = max( work( j ), work( j+1 ) ) if( beta>vcrit ) then rec = one / vmax - call stdlib_sscal( n-ki+1, rec, work( ki+n ), 1 ) + call stdlib${ii}$_sscal( n-ki+1, rec, work( ki+n ), 1_${ik}$ ) vmax = one vcrit = bignum end if - work( j+n ) = work( j+n ) -stdlib_sdot( j-ki-1, t( ki+1, j ), 1,work( & - ki+1+n ), 1 ) - work( j+1+n ) = work( j+1+n ) -stdlib_sdot( j-ki-1, t( ki+1, j+1 ), 1,& - work( ki+1+n ), 1 ) + work( j+n ) = work( j+n ) -stdlib${ii}$_sdot( j-ki-1, t( ki+1, j ), 1_${ik}$,work( & + ki+1+n ), 1_${ik}$ ) + work( j+1+n ) = work( j+1+n ) -stdlib${ii}$_sdot( j-ki-1, t( ki+1, j+1 ), 1_${ik}$,& + work( ki+1+n ), 1_${ik}$ ) ! solve ! [t(j,j)-wr t(j,j+1) ]**t* x = scale*( work1 ) ! [t(j+1,j) t(j+1,j+1)-wr] ( work2 ) - call stdlib_slaln2( .true., 2, 1, smin, one, t( j, j ),ldt, one, one, & - work( j+n ), n, wr,zero, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_slaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr ) ! scale if necessary - if( scale/=one )call stdlib_sscal( n-ki+1, scale, work( ki+n ), 1 ) + if( scale/=one )call stdlib${ii}$_sscal( n-ki+1, scale, work( ki+n ), 1_${ik}$ ) - work( j+n ) = x( 1, 1 ) - work( j+1+n ) = x( 2, 1 ) + work( j+n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+1+n ) = x( 2_${ik}$, 1_${ik}$ ) vmax = max( abs( work( j+n ) ),abs( work( j+1+n ) ), vmax ) vcrit = bignum / vmax end if end do loop_170 ! copy the vector x or q*x to vl and normalize. if( .not.over ) then - call stdlib_scopy( n-ki+1, work( ki+n ), 1, vl( ki, is ), 1 ) - ii = stdlib_isamax( n-ki+1, vl( ki, is ), 1 ) + ki - 1 + call stdlib${ii}$_scopy( n-ki+1, work( ki+n ), 1_${ik}$, vl( ki, is ), 1_${ik}$ ) + ii = stdlib${ii}$_isamax( n-ki+1, vl( ki, is ), 1_${ik}$ ) + ki - 1_${ik}$ remax = one / abs( vl( ii, is ) ) - call stdlib_sscal( n-ki+1, remax, vl( ki, is ), 1 ) + call stdlib${ii}$_sscal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ ) do k = 1, ki - 1 vl( k, is ) = zero end do else - if( kivcrit ) then rec = one / vmax - call stdlib_sscal( n-ki+1, rec, work( ki+n ), 1 ) - call stdlib_sscal( n-ki+1, rec, work( ki+n2 ), 1 ) + call stdlib${ii}$_sscal( n-ki+1, rec, work( ki+n ), 1_${ik}$ ) + call stdlib${ii}$_sscal( n-ki+1, rec, work( ki+n2 ), 1_${ik}$ ) vmax = one vcrit = bignum end if - work( j+n ) = work( j+n ) -stdlib_sdot( j-ki-2, t( ki+2, j ), 1,work( & - ki+2+n ), 1 ) - work( j+n2 ) = work( j+n2 ) -stdlib_sdot( j-ki-2, t( ki+2, j ), 1,work( & - ki+2+n2 ), 1 ) + work( j+n ) = work( j+n ) -stdlib${ii}$_sdot( j-ki-2, t( ki+2, j ), 1_${ik}$,work( & + ki+2+n ), 1_${ik}$ ) + work( j+n2 ) = work( j+n2 ) -stdlib${ii}$_sdot( j-ki-2, t( ki+2, j ), 1_${ik}$,work( & + ki+2+n2 ), 1_${ik}$ ) ! solve (t(j,j)-(wr-i*wi))*(x11+i*x12)= wk+i*wk2 - call stdlib_slaln2( .false., 1, 2, smin, one, t( j, j ),ldt, one, one, & - work( j+n ), n, wr,-wi, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_slaln2( .false., 1_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+n ), n, wr,-wi, x, 2_${ik}$, scale, xnorm, ierr ) ! scale if necessary if( scale/=one ) then - call stdlib_sscal( n-ki+1, scale, work( ki+n ), 1 ) - call stdlib_sscal( n-ki+1, scale, work( ki+n2 ), 1 ) + call stdlib${ii}$_sscal( n-ki+1, scale, work( ki+n ), 1_${ik}$ ) + call stdlib${ii}$_sscal( n-ki+1, scale, work( ki+n2 ), 1_${ik}$ ) end if - work( j+n ) = x( 1, 1 ) - work( j+n2 ) = x( 1, 2 ) + work( j+n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+n2 ) = x( 1_${ik}$, 2_${ik}$ ) vmax = max( abs( work( j+n ) ),abs( work( j+n2 ) ), vmax ) vcrit = bignum / vmax else @@ -58540,84 +58542,84 @@ module stdlib_linalg_lapack_s beta = max( work( j ), work( j+1 ) ) if( beta>vcrit ) then rec = one / vmax - call stdlib_sscal( n-ki+1, rec, work( ki+n ), 1 ) - call stdlib_sscal( n-ki+1, rec, work( ki+n2 ), 1 ) + call stdlib${ii}$_sscal( n-ki+1, rec, work( ki+n ), 1_${ik}$ ) + call stdlib${ii}$_sscal( n-ki+1, rec, work( ki+n2 ), 1_${ik}$ ) vmax = one vcrit = bignum end if - work( j+n ) = work( j+n ) -stdlib_sdot( j-ki-2, t( ki+2, j ), 1,work( & - ki+2+n ), 1 ) - work( j+n2 ) = work( j+n2 ) -stdlib_sdot( j-ki-2, t( ki+2, j ), 1,work( & - ki+2+n2 ), 1 ) - work( j+1+n ) = work( j+1+n ) -stdlib_sdot( j-ki-2, t( ki+2, j+1 ), 1,& - work( ki+2+n ), 1 ) - work( j+1+n2 ) = work( j+1+n2 ) -stdlib_sdot( j-ki-2, t( ki+2, j+1 ), 1,& - work( ki+2+n2 ), 1 ) + work( j+n ) = work( j+n ) -stdlib${ii}$_sdot( j-ki-2, t( ki+2, j ), 1_${ik}$,work( & + ki+2+n ), 1_${ik}$ ) + work( j+n2 ) = work( j+n2 ) -stdlib${ii}$_sdot( j-ki-2, t( ki+2, j ), 1_${ik}$,work( & + ki+2+n2 ), 1_${ik}$ ) + work( j+1+n ) = work( j+1+n ) -stdlib${ii}$_sdot( j-ki-2, t( ki+2, j+1 ), 1_${ik}$,& + work( ki+2+n ), 1_${ik}$ ) + work( j+1+n2 ) = work( j+1+n2 ) -stdlib${ii}$_sdot( j-ki-2, t( ki+2, j+1 ), 1_${ik}$,& + work( ki+2+n2 ), 1_${ik}$ ) ! solve 2-by-2 complex linear equation ! ([t(j,j) t(j,j+1) ]**t-(wr-i*wi)*i)*x = scale*b ! ([t(j+1,j) t(j+1,j+1)] ) - call stdlib_slaln2( .true., 2, 2, smin, one, t( j, j ),ldt, one, one, & - work( j+n ), n, wr,-wi, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_slaln2( .true., 2_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+n ), n, wr,-wi, x, 2_${ik}$, scale, xnorm, ierr ) ! scale if necessary if( scale/=one ) then - call stdlib_sscal( n-ki+1, scale, work( ki+n ), 1 ) - call stdlib_sscal( n-ki+1, scale, work( ki+n2 ), 1 ) + call stdlib${ii}$_sscal( n-ki+1, scale, work( ki+n ), 1_${ik}$ ) + call stdlib${ii}$_sscal( n-ki+1, scale, work( ki+n2 ), 1_${ik}$ ) end if - work( j+n ) = x( 1, 1 ) - work( j+n2 ) = x( 1, 2 ) - work( j+1+n ) = x( 2, 1 ) - work( j+1+n2 ) = x( 2, 2 ) - vmax = max( abs( x( 1, 1 ) ), abs( x( 1, 2 ) ),abs( x( 2, 1 ) ), abs( x(& - 2, 2 ) ), vmax ) + work( j+n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+n2 ) = x( 1_${ik}$, 2_${ik}$ ) + work( j+1+n ) = x( 2_${ik}$, 1_${ik}$ ) + work( j+1+n2 ) = x( 2_${ik}$, 2_${ik}$ ) + vmax = max( abs( x( 1_${ik}$, 1_${ik}$ ) ), abs( x( 1_${ik}$, 2_${ik}$ ) ),abs( x( 2_${ik}$, 1_${ik}$ ) ), abs( x(& + 2_${ik}$, 2_${ik}$ ) ), vmax ) vcrit = bignum / vmax end if end do loop_200 ! copy the vector x or q*x to vl and normalize. if( .not.over ) then - call stdlib_scopy( n-ki+1, work( ki+n ), 1, vl( ki, is ), 1 ) - call stdlib_scopy( n-ki+1, work( ki+n2 ), 1, vl( ki, is+1 ),1 ) + call stdlib${ii}$_scopy( n-ki+1, work( ki+n ), 1_${ik}$, vl( ki, is ), 1_${ik}$ ) + call stdlib${ii}$_scopy( n-ki+1, work( ki+n2 ), 1_${ik}$, vl( ki, is+1 ),1_${ik}$ ) emax = zero do k = ki, n emax = max( emax, abs( vl( k, is ) )+abs( vl( k, is+1 ) ) ) end do remax = one / emax - call stdlib_sscal( n-ki+1, remax, vl( ki, is ), 1 ) - call stdlib_sscal( n-ki+1, remax, vl( ki, is+1 ), 1 ) + call stdlib${ii}$_sscal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ ) + call stdlib${ii}$_sscal( n-ki+1, remax, vl( ki, is+1 ), 1_${ik}$ ) do k = 1, ki - 1 vl( k, is ) = zero vl( k, is+1 ) = zero end do else if( ki= n + 2*n*nbmin ) then - nb = (lwork - n) / (2*n) + if( over .and. lwork >= n + 2_${ik}$*n*nbmin ) then + nb = (lwork - n) / (2_${ik}$*n) nb = min( nb, nbmax ) - call stdlib_slaset( 'F', n, 1+2*nb, zero, zero, work, n ) + call stdlib${ii}$_slaset( 'F', n, 1_${ik}$+2*nb, zero, zero, work, n ) else - nb = 1 + nb = 1_${ik}$ end if ! set the constants to control overflow. - unfl = stdlib_slamch( 'SAFE MINIMUM' ) + unfl = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) ovfl = one / unfl - call stdlib_slabad( unfl, ovfl ) - ulp = stdlib_slamch( 'PRECISION' ) + call stdlib${ii}$_slabad( unfl, ovfl ) + ulp = stdlib${ii}$_slamch( 'PRECISION' ) smlnum = unfl*( n / ulp ) bignum = ( one-ulp ) / smlnum ! compute 1-norm of each column of strictly upper triangular ! part of t to control overflow in triangular solver. - work( 1 ) = zero + work( 1_${ik}$ ) = zero do j = 2, n work( j ) = zero do i = 1, j - 1 @@ -58771,30 +58773,30 @@ module stdlib_linalg_lapack_s ! non-blocked version always uses iv=2; ! blocked version starts with iv=nb, goes down to 1 or 2. ! (note the "0-th" column is used for 1-norms computed above.) - iv = 2 - if( nb>2 ) then + iv = 2_${ik}$ + if( nb>2_${ik}$ ) then iv = nb end if - ip = 0 + ip = 0_${ik}$ is = m loop_140: do ki = n, 1, -1 - if( ip==-1 ) then + if( ip==-1_${ik}$ ) then ! previous iteration (ki+1) was second of conjugate pair, ! so this ki is first of conjugate pair; skip to end of loop - ip = 1 + ip = 1_${ik}$ cycle loop_140 - else if( ki==1 ) then + else if( ki==1_${ik}$ ) then ! last column, so this ki must be real eigenvalue - ip = 0 + ip = 0_${ik}$ else if( t( ki, ki-1 )==zero ) then ! zero on sub-diagonal, so this ki is real eigenvalue - ip = 0 + ip = 0_${ik}$ else ! non-zero on sub-diagonal, so this ki is second of conjugate pair - ip = -1 + ip = -1_${ik}$ end if if( somev ) then - if( ip==0 ) then + if( ip==0_${ik}$ ) then if( .not.select( ki ) )cycle loop_140 else if( .not.select( ki-1 ) )cycle loop_140 @@ -58803,9 +58805,9 @@ module stdlib_linalg_lapack_s ! compute the ki-th eigenvalue (wr,wi). wr = t( ki, ki ) wi = zero - if( ip/=0 )wi = sqrt( abs( t( ki, ki-1 ) ) )*sqrt( abs( t( ki-1, ki ) ) ) + if( ip/=0_${ik}$ )wi = sqrt( abs( t( ki, ki-1 ) ) )*sqrt( abs( t( ki-1, ki ) ) ) smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum ) - if( ip==0 ) then + if( ip==0_${ik}$ ) then ! -------------------------------------------------------- ! real right eigenvector work( ki + iv*n ) = one @@ -58815,60 +58817,60 @@ module stdlib_linalg_lapack_s end do ! solve upper quasi-triangular system: ! [ t(1:ki-1,1:ki-1) - wr ]*x = scale*work. - jnxt = ki - 1 + jnxt = ki - 1_${ik}$ loop_60: do j = ki - 1, 1, -1 if( j>jnxt )cycle loop_60 j1 = j j2 = j - jnxt = j - 1 - if( j>1 ) then + jnxt = j - 1_${ik}$ + if( j>1_${ik}$ ) then if( t( j, j-1 )/=zero ) then - j1 = j - 1 - jnxt = j - 2 + j1 = j - 1_${ik}$ + jnxt = j - 2_${ik}$ end if end if if( j1==j2 ) then ! 1-by-1 diagonal block - call stdlib_slaln2( .false., 1, 1, smin, one, t( j, j ),ldt, one, one, & - work( j+iv*n ), n, wr,zero, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_slaln2( .false., 1_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+iv*n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr ) ! scale x(1,1) to avoid overflow when updating ! the right-hand side. if( xnorm>one ) then if( work( j )>bignum / xnorm ) then - x( 1, 1 ) = x( 1, 1 ) / xnorm + x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm scale = scale / xnorm end if end if ! scale if necessary - if( scale/=one )call stdlib_sscal( ki, scale, work( 1+iv*n ), 1 ) + if( scale/=one )call stdlib${ii}$_sscal( ki, scale, work( 1_${ik}$+iv*n ), 1_${ik}$ ) - work( j+iv*n ) = x( 1, 1 ) + work( j+iv*n ) = x( 1_${ik}$, 1_${ik}$ ) ! update right-hand side - call stdlib_saxpy( j-1, -x( 1, 1 ), t( 1, j ), 1,work( 1+iv*n ), 1 ) + call stdlib${ii}$_saxpy( j-1, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+iv*n ), 1_${ik}$ ) else ! 2-by-2 diagonal block - call stdlib_slaln2( .false., 2, 1, smin, one,t( j-1, j-1 ), ldt, one, & - one,work( j-1+iv*n ), n, wr, zero, x, 2,scale, xnorm, ierr ) + call stdlib${ii}$_slaln2( .false., 2_${ik}$, 1_${ik}$, smin, one,t( j-1, j-1 ), ldt, one, & + one,work( j-1+iv*n ), n, wr, zero, x, 2_${ik}$,scale, xnorm, ierr ) ! scale x(1,1) and x(2,1) to avoid overflow when ! updating the right-hand side. if( xnorm>one ) then beta = max( work( j-1 ), work( j ) ) if( beta>bignum / xnorm ) then - x( 1, 1 ) = x( 1, 1 ) / xnorm - x( 2, 1 ) = x( 2, 1 ) / xnorm + x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm + x( 2_${ik}$, 1_${ik}$ ) = x( 2_${ik}$, 1_${ik}$ ) / xnorm scale = scale / xnorm end if end if ! scale if necessary - if( scale/=one )call stdlib_sscal( ki, scale, work( 1+iv*n ), 1 ) + if( scale/=one )call stdlib${ii}$_sscal( ki, scale, work( 1_${ik}$+iv*n ), 1_${ik}$ ) - work( j-1+iv*n ) = x( 1, 1 ) - work( j +iv*n ) = x( 2, 1 ) + work( j-1+iv*n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j +iv*n ) = x( 2_${ik}$, 1_${ik}$ ) ! update right-hand side - call stdlib_saxpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,work( 1+iv*n ), 1 ) + call stdlib${ii}$_saxpy( j-2, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+iv*n ), 1_${ik}$ ) - call stdlib_saxpy( j-2, -x( 2, 1 ), t( 1, j ), 1,work( 1+iv*n ), 1 ) + call stdlib${ii}$_saxpy( j-2, -x( 2_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+iv*n ), 1_${ik}$ ) end if end do loop_60 @@ -58876,21 +58878,21 @@ module stdlib_linalg_lapack_s if( .not.over ) then ! ------------------------------ ! no back-transform: copy x to vr and normalize. - call stdlib_scopy( ki, work( 1 + iv*n ), 1, vr( 1, is ), 1 ) - ii = stdlib_isamax( ki, vr( 1, is ), 1 ) + call stdlib${ii}$_scopy( ki, work( 1_${ik}$ + iv*n ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ ) + ii = stdlib${ii}$_isamax( ki, vr( 1_${ik}$, is ), 1_${ik}$ ) remax = one / abs( vr( ii, is ) ) - call stdlib_sscal( ki, remax, vr( 1, is ), 1 ) + call stdlib${ii}$_sscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ ) do k = ki + 1, n vr( k, is ) = zero end do - else if( nb==1 ) then + else if( nb==1_${ik}$ ) then ! ------------------------------ ! version 1: back-transform each vector with gemv, q*x. - if( ki>1 )call stdlib_sgemv( 'N', n, ki-1, one, vr, ldvr,work( 1 + iv*n ), & - 1, work( ki + iv*n ),vr( 1, ki ), 1 ) - ii = stdlib_isamax( n, vr( 1, ki ), 1 ) + if( ki>1_${ik}$ )call stdlib${ii}$_sgemv( 'N', n, ki-1, one, vr, ldvr,work( 1_${ik}$ + iv*n ), & + 1_${ik}$, work( ki + iv*n ),vr( 1_${ik}$, ki ), 1_${ik}$ ) + ii = stdlib${ii}$_isamax( n, vr( 1_${ik}$, ki ), 1_${ik}$ ) remax = one / abs( vr( ii, ki ) ) - call stdlib_sscal( n, remax, vr( 1, ki ), 1 ) + call stdlib${ii}$_sscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ ) else ! ------------------------------ ! version 2: back-transform block of vectors with gemm @@ -58923,77 +58925,77 @@ module stdlib_linalg_lapack_s end do ! solve upper quasi-triangular system: ! [ t(1:ki-2,1:ki-2) - (wr+i*wi) ]*x = scale*(work+i*work2) - jnxt = ki - 2 + jnxt = ki - 2_${ik}$ loop_90: do j = ki - 2, 1, -1 if( j>jnxt )cycle loop_90 j1 = j j2 = j - jnxt = j - 1 - if( j>1 ) then + jnxt = j - 1_${ik}$ + if( j>1_${ik}$ ) then if( t( j, j-1 )/=zero ) then - j1 = j - 1 - jnxt = j - 2 + j1 = j - 1_${ik}$ + jnxt = j - 2_${ik}$ end if end if if( j1==j2 ) then ! 1-by-1 diagonal block - call stdlib_slaln2( .false., 1, 2, smin, one, t( j, j ),ldt, one, one, & - work( j+(iv-1)*n ), n,wr, wi, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_slaln2( .false., 1_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+(iv-1)*n ), n,wr, wi, x, 2_${ik}$, scale, xnorm, ierr ) ! scale x(1,1) and x(1,2) to avoid overflow when ! updating the right-hand side. if( xnorm>one ) then if( work( j )>bignum / xnorm ) then - x( 1, 1 ) = x( 1, 1 ) / xnorm - x( 1, 2 ) = x( 1, 2 ) / xnorm + x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) / xnorm + x( 1_${ik}$, 2_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ ) / xnorm scale = scale / xnorm end if end if ! scale if necessary if( scale/=one ) then - call stdlib_sscal( ki, scale, work( 1+(iv-1)*n ), 1 ) - call stdlib_sscal( ki, scale, work( 1+(iv )*n ), 1 ) + call stdlib${ii}$_sscal( ki, scale, work( 1_${ik}$+(iv-1)*n ), 1_${ik}$ ) + call stdlib${ii}$_sscal( ki, scale, work( 1_${ik}$+(iv )*n ), 1_${ik}$ ) end if - work( j+(iv-1)*n ) = x( 1, 1 ) - work( j+(iv )*n ) = x( 1, 2 ) + work( j+(iv-1)*n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+(iv )*n ) = x( 1_${ik}$, 2_${ik}$ ) ! update the right-hand side - call stdlib_saxpy( j-1, -x( 1, 1 ), t( 1, j ), 1,work( 1+(iv-1)*n ), 1 ) + call stdlib${ii}$_saxpy( j-1, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+(iv-1)*n ), 1_${ik}$ ) - call stdlib_saxpy( j-1, -x( 1, 2 ), t( 1, j ), 1,work( 1+(iv )*n ), 1 ) + call stdlib${ii}$_saxpy( j-1, -x( 1_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+(iv )*n ), 1_${ik}$ ) else ! 2-by-2 diagonal block - call stdlib_slaln2( .false., 2, 2, smin, one,t( j-1, j-1 ), ldt, one, & - one,work( j-1+(iv-1)*n ), n, wr, wi, x, 2,scale, xnorm, ierr ) + call stdlib${ii}$_slaln2( .false., 2_${ik}$, 2_${ik}$, smin, one,t( j-1, j-1 ), ldt, one, & + one,work( j-1+(iv-1)*n ), n, wr, wi, x, 2_${ik}$,scale, xnorm, ierr ) ! scale x to avoid overflow when updating ! the right-hand side. if( xnorm>one ) then beta = max( work( j-1 ), work( j ) ) if( beta>bignum / xnorm ) then rec = one / xnorm - x( 1, 1 ) = x( 1, 1 )*rec - x( 1, 2 ) = x( 1, 2 )*rec - x( 2, 1 ) = x( 2, 1 )*rec - x( 2, 2 ) = x( 2, 2 )*rec + x( 1_${ik}$, 1_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ )*rec + x( 1_${ik}$, 2_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ )*rec + x( 2_${ik}$, 1_${ik}$ ) = x( 2_${ik}$, 1_${ik}$ )*rec + x( 2_${ik}$, 2_${ik}$ ) = x( 2_${ik}$, 2_${ik}$ )*rec scale = scale*rec end if end if ! scale if necessary if( scale/=one ) then - call stdlib_sscal( ki, scale, work( 1+(iv-1)*n ), 1 ) - call stdlib_sscal( ki, scale, work( 1+(iv )*n ), 1 ) + call stdlib${ii}$_sscal( ki, scale, work( 1_${ik}$+(iv-1)*n ), 1_${ik}$ ) + call stdlib${ii}$_sscal( ki, scale, work( 1_${ik}$+(iv )*n ), 1_${ik}$ ) end if - work( j-1+(iv-1)*n ) = x( 1, 1 ) - work( j +(iv-1)*n ) = x( 2, 1 ) - work( j-1+(iv )*n ) = x( 1, 2 ) - work( j +(iv )*n ) = x( 2, 2 ) + work( j-1+(iv-1)*n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j +(iv-1)*n ) = x( 2_${ik}$, 1_${ik}$ ) + work( j-1+(iv )*n ) = x( 1_${ik}$, 2_${ik}$ ) + work( j +(iv )*n ) = x( 2_${ik}$, 2_${ik}$ ) ! update the right-hand side - call stdlib_saxpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1,work( 1+(iv-1)*n ),& - 1 ) - call stdlib_saxpy( j-2, -x( 2, 1 ), t( 1, j ), 1,work( 1+(iv-1)*n ), & - 1 ) - call stdlib_saxpy( j-2, -x( 1, 2 ), t( 1, j-1 ), 1,work( 1+(iv )*n ), & - 1 ) - call stdlib_saxpy( j-2, -x( 2, 2 ), t( 1, j ), 1,work( 1+(iv )*n ), 1 ) + call stdlib${ii}$_saxpy( j-2, -x( 1_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+(iv-1)*n ),& + 1_${ik}$ ) + call stdlib${ii}$_saxpy( j-2, -x( 2_${ik}$, 1_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+(iv-1)*n ), & + 1_${ik}$ ) + call stdlib${ii}$_saxpy( j-2, -x( 1_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j-1 ), 1_${ik}$,work( 1_${ik}$+(iv )*n ), & + 1_${ik}$ ) + call stdlib${ii}$_saxpy( j-2, -x( 2_${ik}$, 2_${ik}$ ), t( 1_${ik}$, j ), 1_${ik}$,work( 1_${ik}$+(iv )*n ), 1_${ik}$ ) end if end do loop_90 @@ -59001,38 +59003,38 @@ module stdlib_linalg_lapack_s if( .not.over ) then ! ------------------------------ ! no back-transform: copy x to vr and normalize. - call stdlib_scopy( ki, work( 1+(iv-1)*n ), 1, vr(1,is-1), 1 ) - call stdlib_scopy( ki, work( 1+(iv )*n ), 1, vr(1,is ), 1 ) + call stdlib${ii}$_scopy( ki, work( 1_${ik}$+(iv-1)*n ), 1_${ik}$, vr(1_${ik}$,is-1), 1_${ik}$ ) + call stdlib${ii}$_scopy( ki, work( 1_${ik}$+(iv )*n ), 1_${ik}$, vr(1_${ik}$,is ), 1_${ik}$ ) emax = zero do k = 1, ki emax = max( emax, abs( vr( k, is-1 ) )+abs( vr( k, is ) ) ) end do remax = one / emax - call stdlib_sscal( ki, remax, vr( 1, is-1 ), 1 ) - call stdlib_sscal( ki, remax, vr( 1, is ), 1 ) + call stdlib${ii}$_sscal( ki, remax, vr( 1_${ik}$, is-1 ), 1_${ik}$ ) + call stdlib${ii}$_sscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ ) do k = ki + 1, n vr( k, is-1 ) = zero vr( k, is ) = zero end do - else if( nb==1 ) then + else if( nb==1_${ik}$ ) then ! ------------------------------ ! version 1: back-transform each vector with gemv, q*x. - if( ki>2 ) then - call stdlib_sgemv( 'N', n, ki-2, one, vr, ldvr,work( 1 + (iv-1)*n ), & - 1,work( ki-1 + (iv-1)*n ), vr(1,ki-1), 1) - call stdlib_sgemv( 'N', n, ki-2, one, vr, ldvr,work( 1 + (iv)*n ), 1,& - work( ki + (iv)*n ), vr( 1, ki ), 1 ) + if( ki>2_${ik}$ ) then + call stdlib${ii}$_sgemv( 'N', n, ki-2, one, vr, ldvr,work( 1_${ik}$ + (iv-1)*n ), & + 1_${ik}$,work( ki-1 + (iv-1)*n ), vr(1_${ik}$,ki-1), 1_${ik}$) + call stdlib${ii}$_sgemv( 'N', n, ki-2, one, vr, ldvr,work( 1_${ik}$ + (iv)*n ), 1_${ik}$,& + work( ki + (iv)*n ), vr( 1_${ik}$, ki ), 1_${ik}$ ) else - call stdlib_sscal( n, work(ki-1+(iv-1)*n), vr(1,ki-1), 1) - call stdlib_sscal( n, work(ki +(iv )*n), vr(1,ki ), 1) + call stdlib${ii}$_sscal( n, work(ki-1+(iv-1)*n), vr(1_${ik}$,ki-1), 1_${ik}$) + call stdlib${ii}$_sscal( n, work(ki +(iv )*n), vr(1_${ik}$,ki ), 1_${ik}$) end if emax = zero do k = 1, n emax = max( emax, abs( vr( k, ki-1 ) )+abs( vr( k, ki ) ) ) end do remax = one / emax - call stdlib_sscal( n, remax, vr( 1, ki-1 ), 1 ) - call stdlib_sscal( n, remax, vr( 1, ki ), 1 ) + call stdlib${ii}$_sscal( n, remax, vr( 1_${ik}$, ki-1 ), 1_${ik}$ ) + call stdlib${ii}$_sscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ ) else ! ------------------------------ ! version 2: back-transform block of vectors with gemm @@ -59043,32 +59045,32 @@ module stdlib_linalg_lapack_s end do iscomplex( iv-1 ) = -ip iscomplex( iv ) = ip - iv = iv - 1 + iv = iv - 1_${ik}$ ! back-transform and normalization is done below end if end if - if( nb>1 ) then + if( nb>1_${ik}$ ) then ! -------------------------------------------------------- ! blocked version of back-transform ! for complex case, ki2 includes both vectors (ki-1 and ki) - if( ip==0 ) then + if( ip==0_${ik}$ ) then ki2 = ki else - ki2 = ki - 1 + ki2 = ki - 1_${ik}$ end if ! columns iv:nb of work are valid vectors. ! when the number of vectors stored reaches nb-1 or nb, ! or if this was last vector, do the gemm - if( (iv<=2) .or. (ki2==1) ) then - call stdlib_sgemm( 'N', 'N', n, nb-iv+1, ki2+nb-iv, one,vr, ldvr,work( 1 + & - (iv)*n ), n,zero,work( 1 + (nb+iv)*n ), n ) + if( (iv<=2_${ik}$) .or. (ki2==1_${ik}$) ) then + call stdlib${ii}$_sgemm( 'N', 'N', n, nb-iv+1, ki2+nb-iv, one,vr, ldvr,work( 1_${ik}$ + & + (iv)*n ), n,zero,work( 1_${ik}$ + (nb+iv)*n ), n ) ! normalize vectors do k = iv, nb - if( iscomplex(k)==0 ) then + if( iscomplex(k)==0_${ik}$ ) then ! real eigenvector - ii = stdlib_isamax( n, work( 1 + (nb+k)*n ), 1 ) + ii = stdlib${ii}$_isamax( n, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ ) remax = one / abs( work( ii + (nb+k)*n ) ) - else if( iscomplex(k)==1 ) then + else if( iscomplex(k)==1_${ik}$ ) then ! first eigenvector of conjugate pair emax = zero do ii = 1, n @@ -59080,17 +59082,17 @@ module stdlib_linalg_lapack_s ! second eigenvector of conjugate pair ! reuse same remax as previous k end if - call stdlib_sscal( n, remax, work( 1 + (nb+k)*n ), 1 ) + call stdlib${ii}$_sscal( n, remax, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ ) end do - call stdlib_slacpy( 'F', n, nb-iv+1,work( 1 + (nb+iv)*n ), n,vr( 1, ki2 ), & + call stdlib${ii}$_slacpy( 'F', n, nb-iv+1,work( 1_${ik}$ + (nb+iv)*n ), n,vr( 1_${ik}$, ki2 ), & ldvr ) iv = nb else - iv = iv - 1 + iv = iv - 1_${ik}$ end if end if ! blocked back-transform - is = is - 1 - if( ip/=0 )is = is - 1 + is = is - 1_${ik}$ + if( ip/=0_${ik}$ )is = is - 1_${ik}$ end do loop_140 end if if( leftv ) then @@ -59101,24 +59103,24 @@ module stdlib_linalg_lapack_s ! non-blocked version always uses iv=1; ! blocked version starts with iv=1, goes up to nb-1 or nb. ! (note the "0-th" column is used for 1-norms computed above.) - iv = 1 - ip = 0 - is = 1 + iv = 1_${ik}$ + ip = 0_${ik}$ + is = 1_${ik}$ loop_260: do ki = 1, n - if( ip==1 ) then + if( ip==1_${ik}$ ) then ! previous iteration (ki-1) was first of conjugate pair, ! so this ki is second of conjugate pair; skip to end of loop - ip = -1 + ip = -1_${ik}$ cycle loop_260 else if( ki==n ) then ! last column, so this ki must be real eigenvalue - ip = 0 + ip = 0_${ik}$ else if( t( ki+1, ki )==zero ) then ! zero on sub-diagonal, so this ki is real eigenvalue - ip = 0 + ip = 0_${ik}$ else ! non-zero on sub-diagonal, so this ki is first of conjugate pair - ip = 1 + ip = 1_${ik}$ end if if( somev ) then if( .not.select( ki ) )cycle loop_260 @@ -59126,9 +59128,9 @@ module stdlib_linalg_lapack_s ! compute the ki-th eigenvalue (wr,wi). wr = t( ki, ki ) wi = zero - if( ip/=0 )wi = sqrt( abs( t( ki, ki+1 ) ) )*sqrt( abs( t( ki+1, ki ) ) ) + if( ip/=0_${ik}$ )wi = sqrt( abs( t( ki, ki+1 ) ) )*sqrt( abs( t( ki+1, ki ) ) ) smin = max( ulp*( abs( wr )+abs( wi ) ), smlnum ) - if( ip==0 ) then + if( ip==0_${ik}$ ) then ! -------------------------------------------------------- ! real left eigenvector work( ki + iv*n ) = one @@ -59140,16 +59142,16 @@ module stdlib_linalg_lapack_s ! [ t(ki+1:n,ki+1:n) - wr ]**t * x = scale*work vmax = one vcrit = bignum - jnxt = ki + 1 + jnxt = ki + 1_${ik}$ loop_170: do j = ki + 1, n if( jvcrit ) then rec = one / vmax - call stdlib_sscal( n-ki+1, rec, work( ki+iv*n ), 1 ) + call stdlib${ii}$_sscal( n-ki+1, rec, work( ki+iv*n ), 1_${ik}$ ) vmax = one vcrit = bignum end if - work( j+iv*n ) = work( j+iv*n ) -stdlib_sdot( j-ki-1, t( ki+1, j ), 1,& - work( ki+1+iv*n ), 1 ) + work( j+iv*n ) = work( j+iv*n ) -stdlib${ii}$_sdot( j-ki-1, t( ki+1, j ), 1_${ik}$,& + work( ki+1+iv*n ), 1_${ik}$ ) ! solve [ t(j,j) - wr ]**t * x = work - call stdlib_slaln2( .false., 1, 1, smin, one, t( j, j ),ldt, one, one, & - work( j+iv*n ), n, wr,zero, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_slaln2( .false., 1_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+iv*n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr ) ! scale if necessary - if( scale/=one )call stdlib_sscal( n-ki+1, scale, work( ki+iv*n ), 1 ) + if( scale/=one )call stdlib${ii}$_sscal( n-ki+1, scale, work( ki+iv*n ), 1_${ik}$ ) - work( j+iv*n ) = x( 1, 1 ) + work( j+iv*n ) = x( 1_${ik}$, 1_${ik}$ ) vmax = max( abs( work( j+iv*n ) ), vmax ) vcrit = bignum / vmax else @@ -59180,24 +59182,24 @@ module stdlib_linalg_lapack_s beta = max( work( j ), work( j+1 ) ) if( beta>vcrit ) then rec = one / vmax - call stdlib_sscal( n-ki+1, rec, work( ki+iv*n ), 1 ) + call stdlib${ii}$_sscal( n-ki+1, rec, work( ki+iv*n ), 1_${ik}$ ) vmax = one vcrit = bignum end if - work( j+iv*n ) = work( j+iv*n ) -stdlib_sdot( j-ki-1, t( ki+1, j ), 1,& - work( ki+1+iv*n ), 1 ) - work( j+1+iv*n ) = work( j+1+iv*n ) -stdlib_sdot( j-ki-1, t( ki+1, j+1 )& - , 1,work( ki+1+iv*n ), 1 ) + work( j+iv*n ) = work( j+iv*n ) -stdlib${ii}$_sdot( j-ki-1, t( ki+1, j ), 1_${ik}$,& + work( ki+1+iv*n ), 1_${ik}$ ) + work( j+1+iv*n ) = work( j+1+iv*n ) -stdlib${ii}$_sdot( j-ki-1, t( ki+1, j+1 )& + , 1_${ik}$,work( ki+1+iv*n ), 1_${ik}$ ) ! solve ! [ t(j,j)-wr t(j,j+1) ]**t * x = scale*( work1 ) ! [ t(j+1,j) t(j+1,j+1)-wr ] ( work2 ) - call stdlib_slaln2( .true., 2, 1, smin, one, t( j, j ),ldt, one, one, & - work( j+iv*n ), n, wr,zero, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_slaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+iv*n ), n, wr,zero, x, 2_${ik}$, scale, xnorm, ierr ) ! scale if necessary - if( scale/=one )call stdlib_sscal( n-ki+1, scale, work( ki+iv*n ), 1 ) + if( scale/=one )call stdlib${ii}$_sscal( n-ki+1, scale, work( ki+iv*n ), 1_${ik}$ ) - work( j +iv*n ) = x( 1, 1 ) - work( j+1+iv*n ) = x( 2, 1 ) + work( j +iv*n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+1+iv*n ) = x( 2_${ik}$, 1_${ik}$ ) vmax = max( abs( work( j +iv*n ) ),abs( work( j+1+iv*n ) ), vmax ) vcrit = bignum / vmax @@ -59207,21 +59209,21 @@ module stdlib_linalg_lapack_s if( .not.over ) then ! ------------------------------ ! no back-transform: copy x to vl and normalize. - call stdlib_scopy( n-ki+1, work( ki + iv*n ), 1,vl( ki, is ), 1 ) - ii = stdlib_isamax( n-ki+1, vl( ki, is ), 1 ) + ki - 1 + call stdlib${ii}$_scopy( n-ki+1, work( ki + iv*n ), 1_${ik}$,vl( ki, is ), 1_${ik}$ ) + ii = stdlib${ii}$_isamax( n-ki+1, vl( ki, is ), 1_${ik}$ ) + ki - 1_${ik}$ remax = one / abs( vl( ii, is ) ) - call stdlib_sscal( n-ki+1, remax, vl( ki, is ), 1 ) + call stdlib${ii}$_sscal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ ) do k = 1, ki - 1 vl( k, is ) = zero end do - else if( nb==1 ) then + else if( nb==1_${ik}$ ) then ! ------------------------------ ! version 1: back-transform each vector with gemv, q*x. - if( kivcrit ) then rec = one / vmax - call stdlib_sscal( n-ki+1, rec, work(ki+(iv )*n), 1 ) - call stdlib_sscal( n-ki+1, rec, work(ki+(iv+1)*n), 1 ) + call stdlib${ii}$_sscal( n-ki+1, rec, work(ki+(iv )*n), 1_${ik}$ ) + call stdlib${ii}$_sscal( n-ki+1, rec, work(ki+(iv+1)*n), 1_${ik}$ ) vmax = one vcrit = bignum end if - work( j+(iv )*n ) = work( j+(iv)*n ) -stdlib_sdot( j-ki-2, t( ki+2, j )& - , 1,work( ki+2+(iv)*n ), 1 ) - work( j+(iv+1)*n ) = work( j+(iv+1)*n ) -stdlib_sdot( j-ki-2, t( ki+2, & - j ), 1,work( ki+2+(iv+1)*n ), 1 ) + work( j+(iv )*n ) = work( j+(iv)*n ) -stdlib${ii}$_sdot( j-ki-2, t( ki+2, j )& + , 1_${ik}$,work( ki+2+(iv)*n ), 1_${ik}$ ) + work( j+(iv+1)*n ) = work( j+(iv+1)*n ) -stdlib${ii}$_sdot( j-ki-2, t( ki+2, & + j ), 1_${ik}$,work( ki+2+(iv+1)*n ), 1_${ik}$ ) ! solve [ t(j,j)-(wr-i*wi) ]*(x11+i*x12)= wk+i*wk2 - call stdlib_slaln2( .false., 1, 2, smin, one, t( j, j ),ldt, one, one, & - work( j+iv*n ), n, wr,-wi, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_slaln2( .false., 1_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+iv*n ), n, wr,-wi, x, 2_${ik}$, scale, xnorm, ierr ) ! scale if necessary if( scale/=one ) then - call stdlib_sscal( n-ki+1, scale, work(ki+(iv )*n), 1) - call stdlib_sscal( n-ki+1, scale, work(ki+(iv+1)*n), 1) + call stdlib${ii}$_sscal( n-ki+1, scale, work(ki+(iv )*n), 1_${ik}$) + call stdlib${ii}$_sscal( n-ki+1, scale, work(ki+(iv+1)*n), 1_${ik}$) end if - work( j+(iv )*n ) = x( 1, 1 ) - work( j+(iv+1)*n ) = x( 1, 2 ) + work( j+(iv )*n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j+(iv+1)*n ) = x( 1_${ik}$, 2_${ik}$ ) vmax = max( abs( work( j+(iv )*n ) ),abs( work( j+(iv+1)*n ) ), vmax ) vcrit = bignum / vmax @@ -59304,35 +59306,35 @@ module stdlib_linalg_lapack_s beta = max( work( j ), work( j+1 ) ) if( beta>vcrit ) then rec = one / vmax - call stdlib_sscal( n-ki+1, rec, work(ki+(iv )*n), 1 ) - call stdlib_sscal( n-ki+1, rec, work(ki+(iv+1)*n), 1 ) + call stdlib${ii}$_sscal( n-ki+1, rec, work(ki+(iv )*n), 1_${ik}$ ) + call stdlib${ii}$_sscal( n-ki+1, rec, work(ki+(iv+1)*n), 1_${ik}$ ) vmax = one vcrit = bignum end if - work( j +(iv )*n ) = work( j+(iv)*n ) -stdlib_sdot( j-ki-2, t( ki+2, & - j ), 1,work( ki+2+(iv)*n ), 1 ) - work( j +(iv+1)*n ) = work( j+(iv+1)*n ) -stdlib_sdot( j-ki-2, t( ki+2,& - j ), 1,work( ki+2+(iv+1)*n ), 1 ) - work( j+1+(iv )*n ) = work( j+1+(iv)*n ) -stdlib_sdot( j-ki-2, t( ki+2,& - j+1 ), 1,work( ki+2+(iv)*n ), 1 ) - work( j+1+(iv+1)*n ) = work( j+1+(iv+1)*n ) -stdlib_sdot( j-ki-2, t( ki+& - 2, j+1 ), 1,work( ki+2+(iv+1)*n ), 1 ) + work( j +(iv )*n ) = work( j+(iv)*n ) -stdlib${ii}$_sdot( j-ki-2, t( ki+2, & + j ), 1_${ik}$,work( ki+2+(iv)*n ), 1_${ik}$ ) + work( j +(iv+1)*n ) = work( j+(iv+1)*n ) -stdlib${ii}$_sdot( j-ki-2, t( ki+2,& + j ), 1_${ik}$,work( ki+2+(iv+1)*n ), 1_${ik}$ ) + work( j+1+(iv )*n ) = work( j+1+(iv)*n ) -stdlib${ii}$_sdot( j-ki-2, t( ki+2,& + j+1 ), 1_${ik}$,work( ki+2+(iv)*n ), 1_${ik}$ ) + work( j+1+(iv+1)*n ) = work( j+1+(iv+1)*n ) -stdlib${ii}$_sdot( j-ki-2, t( ki+& + 2_${ik}$, j+1 ), 1_${ik}$,work( ki+2+(iv+1)*n ), 1_${ik}$ ) ! solve 2-by-2 complex linear equation ! [ (t(j,j) t(j,j+1) )**t - (wr-i*wi)*i ]*x = scale*b ! [ (t(j+1,j) t(j+1,j+1)) ] - call stdlib_slaln2( .true., 2, 2, smin, one, t( j, j ),ldt, one, one, & - work( j+iv*n ), n, wr,-wi, x, 2, scale, xnorm, ierr ) + call stdlib${ii}$_slaln2( .true., 2_${ik}$, 2_${ik}$, smin, one, t( j, j ),ldt, one, one, & + work( j+iv*n ), n, wr,-wi, x, 2_${ik}$, scale, xnorm, ierr ) ! scale if necessary if( scale/=one ) then - call stdlib_sscal( n-ki+1, scale, work(ki+(iv )*n), 1) - call stdlib_sscal( n-ki+1, scale, work(ki+(iv+1)*n), 1) + call stdlib${ii}$_sscal( n-ki+1, scale, work(ki+(iv )*n), 1_${ik}$) + call stdlib${ii}$_sscal( n-ki+1, scale, work(ki+(iv+1)*n), 1_${ik}$) end if - work( j +(iv )*n ) = x( 1, 1 ) - work( j +(iv+1)*n ) = x( 1, 2 ) - work( j+1+(iv )*n ) = x( 2, 1 ) - work( j+1+(iv+1)*n ) = x( 2, 2 ) - vmax = max( abs( x( 1, 1 ) ), abs( x( 1, 2 ) ),abs( x( 2, 1 ) ), abs( x(& - 2, 2 ) ),vmax ) + work( j +(iv )*n ) = x( 1_${ik}$, 1_${ik}$ ) + work( j +(iv+1)*n ) = x( 1_${ik}$, 2_${ik}$ ) + work( j+1+(iv )*n ) = x( 2_${ik}$, 1_${ik}$ ) + work( j+1+(iv+1)*n ) = x( 2_${ik}$, 2_${ik}$ ) + vmax = max( abs( x( 1_${ik}$, 1_${ik}$ ) ), abs( x( 1_${ik}$, 2_${ik}$ ) ),abs( x( 2_${ik}$, 1_${ik}$ ) ), abs( x(& + 2_${ik}$, 2_${ik}$ ) ),vmax ) vcrit = bignum / vmax end if end do loop_200 @@ -59340,40 +59342,40 @@ module stdlib_linalg_lapack_s if( .not.over ) then ! ------------------------------ ! no back-transform: copy x to vl and normalize. - call stdlib_scopy( n-ki+1, work( ki + (iv )*n ), 1,vl( ki, is ), 1 ) + call stdlib${ii}$_scopy( n-ki+1, work( ki + (iv )*n ), 1_${ik}$,vl( ki, is ), 1_${ik}$ ) - call stdlib_scopy( n-ki+1, work( ki + (iv+1)*n ), 1,vl( ki, is+1 ), 1 ) + call stdlib${ii}$_scopy( n-ki+1, work( ki + (iv+1)*n ), 1_${ik}$,vl( ki, is+1 ), 1_${ik}$ ) emax = zero do k = ki, n emax = max( emax, abs( vl( k, is ) )+abs( vl( k, is+1 ) ) ) end do remax = one / emax - call stdlib_sscal( n-ki+1, remax, vl( ki, is ), 1 ) - call stdlib_sscal( n-ki+1, remax, vl( ki, is+1 ), 1 ) + call stdlib${ii}$_sscal( n-ki+1, remax, vl( ki, is ), 1_${ik}$ ) + call stdlib${ii}$_sscal( n-ki+1, remax, vl( ki, is+1 ), 1_${ik}$ ) do k = 1, ki - 1 vl( k, is ) = zero vl( k, is+1 ) = zero end do - else if( nb==1 ) then + else if( nb==1_${ik}$ ) then ! ------------------------------ ! version 1: back-transform each vector with gemv, q*x. if( ki1 ) then + if( nb>1_${ik}$ ) then ! -------------------------------------------------------- ! blocked version of back-transform ! for complex case, ki2 includes both vectors (ki and ki+1) - if( ip==0 ) then + if( ip==0_${ik}$ ) then ki2 = ki else - ki2 = ki + 1 + ki2 = ki + 1_${ik}$ end if ! columns 1:iv of work are valid vectors. ! when the number of vectors stored reaches nb-1 or nb, ! or if this was last vector, do the gemm if( (iv>=nb-1) .or. (ki2==n) ) then - call stdlib_sgemm( 'N', 'N', n, iv, n-ki2+iv, one,vl( 1, ki2-iv+1 ), ldvl,& - work( ki2-iv+1 + (1)*n ), n,zero,work( 1 + (nb+1)*n ), n ) + call stdlib${ii}$_sgemm( 'N', 'N', n, iv, n-ki2+iv, one,vl( 1_${ik}$, ki2-iv+1 ), ldvl,& + work( ki2-iv+1 + (1_${ik}$)*n ), n,zero,work( 1_${ik}$ + (nb+1)*n ), n ) ! normalize vectors do k = 1, iv - if( iscomplex(k)==0) then + if( iscomplex(k)==0_${ik}$) then ! real eigenvector - ii = stdlib_isamax( n, work( 1 + (nb+k)*n ), 1 ) + ii = stdlib${ii}$_isamax( n, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ ) remax = one / abs( work( ii + (nb+k)*n ) ) - else if( iscomplex(k)==1) then + else if( iscomplex(k)==1_${ik}$) then ! first eigenvector of conjugate pair emax = zero do ii = 1, n @@ -59422,24 +59424,24 @@ module stdlib_linalg_lapack_s ! second eigenvector of conjugate pair ! reuse same remax as previous k end if - call stdlib_sscal( n, remax, work( 1 + (nb+k)*n ), 1 ) + call stdlib${ii}$_sscal( n, remax, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ ) end do - call stdlib_slacpy( 'F', n, iv,work( 1 + (nb+1)*n ), n,vl( 1, ki2-iv+1 ), & + call stdlib${ii}$_slacpy( 'F', n, iv,work( 1_${ik}$ + (nb+1)*n ), n,vl( 1_${ik}$, ki2-iv+1 ), & ldvl ) - iv = 1 + iv = 1_${ik}$ else - iv = iv + 1 + iv = iv + 1_${ik}$ end if end if ! blocked back-transform - is = is + 1 - if( ip/=0 )is = is + 1 + is = is + 1_${ik}$ + if( ip/=0_${ik}$ )is = is + 1_${ik}$ end do loop_260 end if return - end subroutine stdlib_strevc3 + end subroutine stdlib${ii}$_strevc3 - subroutine stdlib_strsyl( trana, tranb, isgn, m, n, a, lda, b, ldb, c,ldc, scale, info ) + subroutine stdlib${ii}$_strsyl( trana, tranb, isgn, m, n, a, lda, b, ldb, c,ldc, scale, info ) !! STRSYL solves the real Sylvester matrix equation: !! op(A)*X + X*op(B) = scale*C or !! op(A)*X - X*op(B) = scale*C, @@ -59457,8 +59459,8 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: trana, tranb - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: isgn, lda, ldb, ldc, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: isgn, lda, ldb, ldc, m, n real(sp), intent(out) :: scale ! Array Arguments real(sp), intent(in) :: a(lda,*), b(ldb,*) @@ -59467,52 +59469,52 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: notrna, notrnb - integer(ilp) :: ierr, j, k, k1, k2, knext, l, l1, l2, lnext + integer(${ik}$) :: ierr, j, k, k1, k2, knext, l, l1, l2, lnext real(sp) :: a11, bignum, da11, db, eps, scaloc, sgn, smin, smlnum, suml, sumr, & xnorm ! Local Arrays - real(sp) :: dum(1), vec(2,2), x(2,2) + real(sp) :: dum(1_${ik}$), vec(2_${ik}$,2_${ik}$), x(2_${ik}$,2_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,min,real ! Executable Statements ! decode and test input parameters notrna = stdlib_lsame( trana, 'N' ) notrnb = stdlib_lsame( tranb, 'N' ) - info = 0 + info = 0_${ik}$ if( .not.notrna .and. .not.stdlib_lsame( trana, 'T' ) .and. .not.stdlib_lsame( trana, & 'C' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.notrnb .and. .not.stdlib_lsame( tranb, 'T' ) .and. .not.stdlib_lsame( & tranb, 'C' ) ) then - info = -2 - else if( isgn/=1 .and. isgn/=-1 ) then - info = -3 - else if( m<0 ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( ldaknext )cycle loop_60 - if( k==1 ) then + if( k==1_${ik}$ ) then k1 = k k2 = k else if( a( k, k-1 )/=zero ) then - k1 = k - 1 + k1 = k - 1_${ik}$ k2 = k - knext = k - 2 + knext = k - 2_${ik}$ else k1 = k k2 = k - knext = k - 1 + knext = k - 1_${ik}$ end if end if if( l1==l2 .and. k1==k2 ) then - suml = stdlib_sdot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & - l1 ), 1 ) - sumr = stdlib_sdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_sdot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) scaloc = one a11 = a( k1, k1 ) + sgn*b( l1, l1 ) da11 = abs( a11 ) if( da11<=smin ) then a11 = smin da11 = smin - info = 1 + info = 1_${ik}$ end if - db = abs( vec( 1, 1 ) ) + db = abs( vec( 1_${ik}$, 1_${ik}$ ) ) if( da11one ) then if( db>bignum*da11 )scaloc = one / db end if - x( 1, 1 ) = ( vec( 1, 1 )*scaloc ) / a11 + x( 1_${ik}$, 1_${ik}$ ) = ( vec( 1_${ik}$, 1_${ik}$ )*scaloc ) / a11 if( scaloc/=one ) then do j = 1, n - call stdlib_sscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) else if( l1==l2 .and. k1/=k2 ) then - suml = stdlib_sdot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l1 ), 1 ) - sumr = stdlib_sdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_sdot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l1 ), 1 ) - sumr = stdlib_sdot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - call stdlib_slaln2( .false., 2, 1, smin, one, a( k1, k1 ),lda, one, one, & - vec, 2, -sgn*b( l1, l1 ),zero, x, 2, scaloc, xnorm, ierr ) - if( ierr/=0 )info = 1 + suml = stdlib${ii}$_sdot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_sdot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr ) + call stdlib${ii}$_slaln2( .false., 2_${ik}$, 1_${ik}$, smin, one, a( k1, k1 ),lda, one, one, & + vec, 2_${ik}$, -sgn*b( l1, l1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_sscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k2, l1 ) = x( 2, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ ) else if( l1/=l2 .and. k1==k2 ) then - suml = stdlib_sdot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & - l1 ), 1 ) - sumr = stdlib_sdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) - suml = stdlib_sdot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & - l2 ), 1 ) - sumr = stdlib_sdot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 ) - vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) - call stdlib_slaln2( .true., 2, 1, smin, one, b( l1, l1 ),ldb, one, one, & - vec, 2, -sgn*a( k1, k1 ),zero, x, 2, scaloc, xnorm, ierr ) - if( ierr/=0 )info = 1 + suml = stdlib${ii}$_sdot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 1_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) + suml = stdlib${ii}$_sdot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & + l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ ) + vec( 2_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) + call stdlib${ii}$_slaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, b( l1, l1 ),ldb, one, one, & + vec, 2_${ik}$, -sgn*a( k1, k1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_sscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k1, l2 ) = x( 2, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k1, l2 ) = x( 2_${ik}$, 1_${ik}$ ) else if( l1/=l2 .and. k1/=k2 ) then - suml = stdlib_sdot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l1 ), 1 ) - sumr = stdlib_sdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_sdot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l2 ), 1 ) - sumr = stdlib_sdot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 ) - vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr ) - suml = stdlib_sdot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l1 ), 1 ) - sumr = stdlib_sdot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_sdot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l2 ), 1 ) - sumr = stdlib_sdot( l1-1, c( k2, 1 ), ldc, b( 1, l2 ), 1 ) - vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr ) - call stdlib_slasy2( .false., .false., isgn, 2, 2,a( k1, k1 ), lda, b( l1, & - l1 ), ldb, vec,2, scaloc, x, 2, xnorm, ierr ) - if( ierr/=0 )info = 1 + suml = stdlib${ii}$_sdot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_sdot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ ) + vec( 1_${ik}$, 2_${ik}$ ) = c( k1, l2 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_sdot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_sdot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ ) + vec( 2_${ik}$, 2_${ik}$ ) = c( k2, l2 ) - ( suml+sgn*sumr ) + call stdlib${ii}$_slasy2( .false., .false., isgn, 2_${ik}$, 2_${ik}$,a( k1, k1 ), lda, b( l1, & + l1 ), ldb, vec,2_${ik}$, scaloc, x, 2_${ik}$, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_sscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k1, l2 ) = x( 1, 2 ) - c( k2, l1 ) = x( 2, 1 ) - c( k2, l2 ) = x( 2, 2 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k1, l2 ) = x( 1_${ik}$, 2_${ik}$ ) + c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ ) + c( k2, l2 ) = x( 2_${ik}$, 2_${ik}$ ) end if end do loop_60 end do loop_70 @@ -59671,7 +59673,7 @@ module stdlib_linalg_lapack_s ! i=1 j=1 ! start column loop (index = l) ! l1 (l2): column index of the first (last) row of x(k,l) - lnext = 1 + lnext = 1_${ik}$ loop_130: do l = 1, n if( lone ) then if( db>bignum*da11 )scaloc = one / db end if - x( 1, 1 ) = ( vec( 1, 1 )*scaloc ) / a11 + x( 1_${ik}$, 1_${ik}$ ) = ( vec( 1_${ik}$, 1_${ik}$ )*scaloc ) / a11 if( scaloc/=one ) then do j = 1, n - call stdlib_sscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) else if( l1==l2 .and. k1/=k2 ) then - suml = stdlib_sdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_sdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_sdot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_sdot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - call stdlib_slaln2( .true., 2, 1, smin, one, a( k1, k1 ),lda, one, one, & - vec, 2, -sgn*b( l1, l1 ),zero, x, 2, scaloc, xnorm, ierr ) - if( ierr/=0 )info = 1 + suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr ) + call stdlib${ii}$_slaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, a( k1, k1 ),lda, one, one, & + vec, 2_${ik}$, -sgn*b( l1, l1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_sscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k2, l1 ) = x( 2, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ ) else if( l1/=l2 .and. k1==k2 ) then - suml = stdlib_sdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_sdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) - suml = stdlib_sdot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 ) - sumr = stdlib_sdot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 ) - vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) - call stdlib_slaln2( .true., 2, 1, smin, one, b( l1, l1 ),ldb, one, one, & - vec, 2, -sgn*a( k1, k1 ),zero, x, 2, scaloc, xnorm, ierr ) - if( ierr/=0 )info = 1 + suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 1_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) + suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ ) + vec( 2_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) + call stdlib${ii}$_slaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, b( l1, l1 ),ldb, one, one, & + vec, 2_${ik}$, -sgn*a( k1, k1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_sscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k1, l2 ) = x( 2, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k1, l2 ) = x( 2_${ik}$, 1_${ik}$ ) else if( l1/=l2 .and. k1/=k2 ) then - suml = stdlib_sdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_sdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_sdot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 ) - sumr = stdlib_sdot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 ) - vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr ) - suml = stdlib_sdot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_sdot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 ) - vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_sdot( k1-1, a( 1, k2 ), 1, c( 1, l2 ), 1 ) - sumr = stdlib_sdot( l1-1, c( k2, 1 ), ldc, b( 1, l2 ), 1 ) - vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr ) - call stdlib_slasy2( .true., .false., isgn, 2, 2, a( k1, k1 ),lda, b( l1, & - l1 ), ldb, vec, 2, scaloc, x,2, xnorm, ierr ) - if( ierr/=0 )info = 1 + suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( l1-1, c( k1, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ ) + vec( 1_${ik}$, 2_${ik}$ ) = c( k1, l2 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l1 ), 1_${ik}$ ) + vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( l1-1, c( k2, 1_${ik}$ ), ldc, b( 1_${ik}$, l2 ), 1_${ik}$ ) + vec( 2_${ik}$, 2_${ik}$ ) = c( k2, l2 ) - ( suml+sgn*sumr ) + call stdlib${ii}$_slasy2( .true., .false., isgn, 2_${ik}$, 2_${ik}$, a( k1, k1 ),lda, b( l1, & + l1 ), ldb, vec, 2_${ik}$, scaloc, x,2_${ik}$, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_sscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k1, l2 ) = x( 1, 2 ) - c( k2, l1 ) = x( 2, 1 ) - c( k2, l2 ) = x( 2, 2 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k1, l2 ) = x( 1_${ik}$, 2_${ik}$ ) + c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ ) + c( k2, l2 ) = x( 2_${ik}$, 2_${ik}$ ) end if end do loop_120 end do loop_130 @@ -59810,23 +59812,23 @@ module stdlib_linalg_lapack_s lnext = n loop_190: do l = n, 1, -1 if( l>lnext )cycle loop_190 - if( l==1 ) then + if( l==1_${ik}$ ) then l1 = l l2 = l else if( b( l, l-1 )/=zero ) then - l1 = l - 1 + l1 = l - 1_${ik}$ l2 = l - lnext = l - 2 + lnext = l - 2_${ik}$ else l1 = l l2 = l - lnext = l - 1 + lnext = l - 1_${ik}$ end if end if ! start row loop (index = k) ! k1 (k2): row index of the first (last) row of x(k,l) - knext = 1 + knext = 1_${ik}$ loop_180: do k = 1, m if( kone ) then if( db>bignum*da11 )scaloc = one / db end if - x( 1, 1 ) = ( vec( 1, 1 )*scaloc ) / a11 + x( 1_${ik}$, 1_${ik}$ ) = ( vec( 1_${ik}$, 1_${ik}$ )*scaloc ) / a11 if( scaloc/=one ) then do j = 1, n - call stdlib_sscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) else if( l1==l2 .and. k1/=k2 ) then - suml = stdlib_sdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_sdot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_sdot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - call stdlib_slaln2( .true., 2, 1, smin, one, a( k1, k1 ),lda, one, one, & - vec, 2, -sgn*b( l1, l1 ),zero, x, 2, scaloc, xnorm, ierr ) - if( ierr/=0 )info = 1 + vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr ) + call stdlib${ii}$_slaln2( .true., 2_${ik}$, 1_${ik}$, smin, one, a( k1, k1 ),lda, one, one, & + vec, 2_${ik}$, -sgn*b( l1, l1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_sscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k2, l1 ) = x( 2, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ ) else if( l1/=l2 .and. k1==k2 ) then - suml = stdlib_sdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) - suml = stdlib_sdot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 ) - sumr = stdlib_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & + vec( 1_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) + suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & ) ), ldb ) - vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) - call stdlib_slaln2( .false., 2, 1, smin, one, b( l1, l1 ),ldb, one, one, & - vec, 2, -sgn*a( k1, k1 ),zero, x, 2, scaloc, xnorm, ierr ) - if( ierr/=0 )info = 1 + vec( 2_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) + call stdlib${ii}$_slaln2( .false., 2_${ik}$, 1_${ik}$, smin, one, b( l1, l1 ),ldb, one, one, & + vec, 2_${ik}$, -sgn*a( k1, k1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_sscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k1, l2 ) = x( 2, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k1, l2 ) = x( 2_${ik}$, 1_${ik}$ ) else if( l1/=l2 .and. k1/=k2 ) then - suml = stdlib_sdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_sdot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 ) - sumr = stdlib_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k1 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & ) ), ldb ) - vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr ) - suml = stdlib_sdot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 ) - sumr = stdlib_sdot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + vec( 1_${ik}$, 2_${ik}$ ) = c( k1, l2 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_sdot( k1-1, a( 1, k2 ), 1, c( 1, l2 ), 1 ) - sumr = stdlib_sdot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l2, min(l2+1, n )& + vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_sdot( k1-1, a( 1_${ik}$, k2 ), 1_${ik}$, c( 1_${ik}$, l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l2, min(l2+1, n )& ), ldb ) - vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr ) - call stdlib_slasy2( .true., .true., isgn, 2, 2, a( k1, k1 ),lda, b( l1, l1 & - ), ldb, vec, 2, scaloc, x,2, xnorm, ierr ) - if( ierr/=0 )info = 1 + vec( 2_${ik}$, 2_${ik}$ ) = c( k2, l2 ) - ( suml+sgn*sumr ) + call stdlib${ii}$_slasy2( .true., .true., isgn, 2_${ik}$, 2_${ik}$, a( k1, k1 ),lda, b( l1, l1 & + ), ldb, vec, 2_${ik}$, scaloc, x,2_${ik}$, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_sscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k1, l2 ) = x( 1, 2 ) - c( k2, l1 ) = x( 2, 1 ) - c( k2, l2 ) = x( 2, 2 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k1, l2 ) = x( 1_${ik}$, 2_${ik}$ ) + c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ ) + c( k2, l2 ) = x( 2_${ik}$, 2_${ik}$ ) end if end do loop_180 end do loop_190 @@ -59955,18 +59957,18 @@ module stdlib_linalg_lapack_s lnext = n loop_250: do l = n, 1, -1 if( l>lnext )cycle loop_250 - if( l==1 ) then + if( l==1_${ik}$ ) then l1 = l l2 = l else if( b( l, l-1 )/=zero ) then - l1 = l - 1 + l1 = l - 1_${ik}$ l2 = l - lnext = l - 2 + lnext = l - 2_${ik}$ else l1 = l l2 = l - lnext = l - 1 + lnext = l - 1_${ik}$ end if end if ! start row loop (index = k) @@ -59974,133 +59976,133 @@ module stdlib_linalg_lapack_s knext = m loop_240: do k = m, 1, -1 if( k>knext )cycle loop_240 - if( k==1 ) then + if( k==1_${ik}$ ) then k1 = k k2 = k else if( a( k, k-1 )/=zero ) then - k1 = k - 1 + k1 = k - 1_${ik}$ k2 = k - knext = k - 2 + knext = k - 2_${ik}$ else k1 = k k2 = k - knext = k - 1 + knext = k - 1_${ik}$ end if end if if( l1==l2 .and. k1==k2 ) then - suml = stdlib_sdot( m-k1, a( k1, min(k1+1, m ) ), lda,c( min( k1+1, m ), & - l1 ), 1 ) - sumr = stdlib_sdot( n-l1, c( k1, min( l1+1, n ) ), ldc,b( l1, min( l1+1, n & + suml = stdlib${ii}$_sdot( m-k1, a( k1, min(k1+1, m ) ), lda,c( min( k1+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( n-l1, c( k1, min( l1+1, n ) ), ldc,b( l1, min( l1+1, n & ) ), ldb ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) scaloc = one a11 = a( k1, k1 ) + sgn*b( l1, l1 ) da11 = abs( a11 ) if( da11<=smin ) then a11 = smin da11 = smin - info = 1 + info = 1_${ik}$ end if - db = abs( vec( 1, 1 ) ) + db = abs( vec( 1_${ik}$, 1_${ik}$ ) ) if( da11one ) then if( db>bignum*da11 )scaloc = one / db end if - x( 1, 1 ) = ( vec( 1, 1 )*scaloc ) / a11 + x( 1_${ik}$, 1_${ik}$ ) = ( vec( 1_${ik}$, 1_${ik}$ )*scaloc ) / a11 if( scaloc/=one ) then do j = 1, n - call stdlib_sscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) else if( l1==l2 .and. k1/=k2 ) then - suml = stdlib_sdot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l1 ), 1 ) - sumr = stdlib_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + suml = stdlib${ii}$_sdot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_sdot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l1 ), 1 ) - sumr = stdlib_sdot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_sdot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - call stdlib_slaln2( .false., 2, 1, smin, one, a( k1, k1 ),lda, one, one, & - vec, 2, -sgn*b( l1, l1 ),zero, x, 2, scaloc, xnorm, ierr ) - if( ierr/=0 )info = 1 + vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr ) + call stdlib${ii}$_slaln2( .false., 2_${ik}$, 1_${ik}$, smin, one, a( k1, k1 ),lda, one, one, & + vec, 2_${ik}$, -sgn*b( l1, l1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_sscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k2, l1 ) = x( 2, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ ) else if( l1/=l2 .and. k1==k2 ) then - suml = stdlib_sdot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & - l1 ), 1 ) - sumr = stdlib_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + suml = stdlib${ii}$_sdot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) - suml = stdlib_sdot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & - l2 ), 1 ) - sumr = stdlib_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & + vec( 1_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) + suml = stdlib${ii}$_sdot( m-k1, a( k1, min( k1+1, m ) ), lda,c( min( k1+1, m ), & + l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & ) ), ldb ) - vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) - call stdlib_slaln2( .false., 2, 1, smin, one, b( l1, l1 ),ldb, one, one, & - vec, 2, -sgn*a( k1, k1 ),zero, x, 2, scaloc, xnorm, ierr ) - if( ierr/=0 )info = 1 + vec( 2_${ik}$, 1_${ik}$ ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) + call stdlib${ii}$_slaln2( .false., 2_${ik}$, 1_${ik}$, smin, one, b( l1, l1 ),ldb, one, one, & + vec, 2_${ik}$, -sgn*a( k1, k1 ),zero, x, 2_${ik}$, scaloc, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_sscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k1, l2 ) = x( 2, 1 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k1, l2 ) = x( 2_${ik}$, 1_${ik}$ ) else if( l1/=l2 .and. k1/=k2 ) then - suml = stdlib_sdot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l1 ), 1 ) - sumr = stdlib_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + suml = stdlib${ii}$_sdot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_sdot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l2 ), 1 ) - sumr = stdlib_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & + vec( 1_${ik}$, 1_${ik}$ ) = c( k1, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_sdot( m-k2, a( k1, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( n-l2, c( k1, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & ) ), ldb ) - vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr ) - suml = stdlib_sdot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l1 ), 1 ) - sumr = stdlib_sdot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & + vec( 1_${ik}$, 2_${ik}$ ) = c( k1, l2 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_sdot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l1 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l1, min( l2+1, n & ) ), ldb ) - vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) - suml = stdlib_sdot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & - l2 ), 1 ) - sumr = stdlib_sdot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & + vec( 2_${ik}$, 1_${ik}$ ) = c( k2, l1 ) - ( suml+sgn*sumr ) + suml = stdlib${ii}$_sdot( m-k2, a( k2, min( k2+1, m ) ), lda,c( min( k2+1, m ), & + l2 ), 1_${ik}$ ) + sumr = stdlib${ii}$_sdot( n-l2, c( k2, min( l2+1, n ) ), ldc,b( l2, min( l2+1, n & ) ), ldb ) - vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr ) - call stdlib_slasy2( .false., .true., isgn, 2, 2, a( k1, k1 ),lda, b( l1, & - l1 ), ldb, vec, 2, scaloc, x,2, xnorm, ierr ) - if( ierr/=0 )info = 1 + vec( 2_${ik}$, 2_${ik}$ ) = c( k2, l2 ) - ( suml+sgn*sumr ) + call stdlib${ii}$_slasy2( .false., .true., isgn, 2_${ik}$, 2_${ik}$, a( k1, k1 ),lda, b( l1, & + l1 ), ldb, vec, 2_${ik}$, scaloc, x,2_${ik}$, xnorm, ierr ) + if( ierr/=0_${ik}$ )info = 1_${ik}$ if( scaloc/=one ) then do j = 1, n - call stdlib_sscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_sscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if - c( k1, l1 ) = x( 1, 1 ) - c( k1, l2 ) = x( 1, 2 ) - c( k2, l1 ) = x( 2, 1 ) - c( k2, l2 ) = x( 2, 2 ) + c( k1, l1 ) = x( 1_${ik}$, 1_${ik}$ ) + c( k1, l2 ) = x( 1_${ik}$, 2_${ik}$ ) + c( k2, l1 ) = x( 2_${ik}$, 1_${ik}$ ) + c( k2, l2 ) = x( 2_${ik}$, 2_${ik}$ ) end if end do loop_240 end do loop_250 end if return - end subroutine stdlib_strsyl + end subroutine stdlib${ii}$_strsyl - pure subroutine stdlib_sgebrd( m, n, a, lda, d, e, tauq, taup, work, lwork,info ) + pure subroutine stdlib${ii}$_sgebrd( m, n, a, lda, d, e, tauq, taup, work, lwork,info ) !! SGEBRD reduces a general real M-by-N matrix A to upper or lower !! bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. !! If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. @@ -60108,8 +60110,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, lwork, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, lwork, m, n ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: d(*), e(*), taup(*), tauq(*), work(*) @@ -60117,54 +60119,54 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, iinfo, j, ldwrkx, ldwrky, lwkopt, minmn, nb, nbmin, nx, ws + integer(${ik}$) :: i, iinfo, j, ldwrkx, ldwrky, lwkopt, minmn, nb, nbmin, nx, ws ! Intrinsic Functions intrinsic :: max,min,real ! Executable Statements ! test the input parameters - info = 0 - nb = max( 1, stdlib_ilaenv( 1, 'SGEBRD', ' ', m, n, -1, -1 ) ) + info = 0_${ik}$ + nb = max( 1_${ik}$, stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEBRD', ' ', m, n, -1_${ik}$, -1_${ik}$ ) ) lwkopt = ( m+n )*nb - work( 1 ) = real( lwkopt,KIND=sp) - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda1 .and. nb1_${ik}$ .and. nb=( m+n )*nbmin ) then nb = lwork / ( m+n ) else - nb = 1 + nb = 1_${ik}$ nx = minmn end if end if @@ -60176,13 +60178,13 @@ module stdlib_linalg_lapack_s ! reduce rows and columns i:i+nb-1 to bidiagonal form and return ! the matrices x and y which are needed to update the unreduced ! part of the matrix - call stdlib_slabrd( m-i+1, n-i+1, nb, a( i, i ), lda, d( i ), e( i ),tauq( i ), & + call stdlib${ii}$_slabrd( m-i+1, n-i+1, nb, a( i, i ), lda, d( i ), e( i ),tauq( i ), & taup( i ), work, ldwrkx,work( ldwrkx*nb+1 ), ldwrky ) ! update the trailing submatrix a(i+nb:m,i+nb:n), using an update ! of the form a := a - v*y**t - x*u**t - call stdlib_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', m-i-nb+1, n-i-nb+1,nb, -one, a( i+& + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE', m-i-nb+1, n-i-nb+1,nb, -one, a( i+& nb, i ), lda,work( ldwrkx*nb+nb+1 ), ldwrky, one,a( i+nb, i+nb ), lda ) - call stdlib_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-i-nb+1, n-i-nb+1,nb, -one, & + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-i-nb+1, n-i-nb+1,nb, -one, & work( nb+1 ), ldwrkx, a( i, i+nb ), lda,one, a( i+nb, i+nb ), lda ) ! copy diagonal and off-diagonal elements of b back into a if( m>=n ) then @@ -60198,61 +60200,61 @@ module stdlib_linalg_lapack_s end if end do ! use unblocked code to reduce the remainder of the matrix - call stdlib_sgebd2( m-i+1, n-i+1, a( i, i ), lda, d( i ), e( i ),tauq( i ), taup( i ), & + call stdlib${ii}$_sgebd2( m-i+1, n-i+1, a( i, i ), lda, d( i ), e( i ),tauq( i ), taup( i ), & work, iinfo ) - work( 1 ) = ws + work( 1_${ik}$ ) = ws return - end subroutine stdlib_sgebrd + end subroutine stdlib${ii}$_sgebrd - pure subroutine stdlib_sgehrd( n, ilo, ihi, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_sgehrd( n, ilo, ihi, a, lda, tau, work, lwork, info ) !! SGEHRD reduces a real general matrix A to upper Hessenberg form H by !! an orthogonal similarity transformation: Q**T * A * Q = H . ! -- 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) :: ihi, ilo, lda, lwork, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ilo, lda, lwork, n + integer(${ik}$), intent(out) :: info ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: tau(*), 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) :: lquery - integer(ilp) :: i, ib, iinfo, iwt, j, ldwork, lwkopt, nb, nbmin, nh, nx + integer(${ik}$) :: i, ib, iinfo, iwt, j, ldwork, lwkopt, nb, nbmin, nh, nx real(sp) :: ei ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input parameters - info = 0 - lquery = ( lwork==-1 ) - if( n<0 ) then - info = -1 - else if( ilo<1 .or. ilo>max( 1, n ) ) then - info = -2 + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) + if( n<0_${ik}$ ) then + info = -1_${ik}$ + else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then + info = -2_${ik}$ else if( ihin ) then - info = -3 - else if( lda1 .and. nb1_${ik}$ .and. nb=(n*nbmin + tsize) ) then nb = (lwork-tsize) / n else - nb = 1 + nb = 1_${ik}$ end if end if end if @@ -60298,73 +60300,73 @@ module stdlib_linalg_lapack_s i = ilo else ! use blocked code - iwt = 1 + n*nb + iwt = 1_${ik}$ + n*nb do i = ilo, ihi - 1 - nx, nb ib = min( nb, ihi-i ) ! reduce columns i:i+ib-1 to hessenberg form, returning the ! matrices v and t of the block reflector h = i - v*t*v**t ! which performs the reduction, and also the matrix y = a*v*t - call stdlib_slahr2( ihi, i, ib, a( 1, i ), lda, tau( i ),work( iwt ), ldt, work, & + call stdlib${ii}$_slahr2( ihi, i, ib, a( 1_${ik}$, i ), lda, tau( i ),work( iwt ), ldt, work, & ldwork ) ! apply the block reflector h to a(1:ihi,i+ib:ihi) from the ! right, computing a := a - y * v**t. v(i+ib,ib-1) must be set ! to 1 ei = a( i+ib, i+ib-1 ) a( i+ib, i+ib-1 ) = one - call stdlib_sgemm( 'NO TRANSPOSE', 'TRANSPOSE',ihi, ihi-i-ib+1,ib, -one, work, & - ldwork, a( i+ib, i ), lda, one,a( 1, i+ib ), lda ) + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE',ihi, ihi-i-ib+1,ib, -one, work, & + ldwork, a( i+ib, i ), lda, one,a( 1_${ik}$, i+ib ), lda ) a( i+ib, i+ib-1 ) = ei ! apply the block reflector h to a(1:i,i+1:i+ib-1) from the ! right - call stdlib_strmm( 'RIGHT', 'LOWER', 'TRANSPOSE','UNIT', i, ib-1,one, a( i+1, i )& + call stdlib${ii}$_strmm( 'RIGHT', 'LOWER', 'TRANSPOSE','UNIT', i, ib-1,one, a( i+1, i )& , lda, work, ldwork ) do j = 0, ib-2 - call stdlib_saxpy( i, -one, work( ldwork*j+1 ), 1,a( 1, i+j+1 ), 1 ) + call stdlib${ii}$_saxpy( i, -one, work( ldwork*j+1 ), 1_${ik}$,a( 1_${ik}$, i+j+1 ), 1_${ik}$ ) end do ! apply the block reflector h to a(i+1:ihi,i+ib:n) from the ! left - call stdlib_slarfb( 'LEFT', 'TRANSPOSE', 'FORWARD','COLUMNWISE',ihi-i, n-i-ib+1, & + call stdlib${ii}$_slarfb( 'LEFT', 'TRANSPOSE', 'FORWARD','COLUMNWISE',ihi-i, n-i-ib+1, & ib, a( i+1, i ), lda,work( iwt ), ldt, a( i+1, i+ib ), lda,work, ldwork ) end do end if ! use unblocked code to reduce the rest of the matrix - call stdlib_sgehd2( n, i, ihi, a, lda, tau, work, iinfo ) - work( 1 ) = lwkopt + call stdlib${ii}$_sgehd2( n, i, ihi, a, lda, tau, work, iinfo ) + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_sgehrd + end subroutine stdlib${ii}$_sgehrd - pure subroutine stdlib_sgelqt( m, n, mb, a, lda, t, ldt, work, info ) + pure subroutine stdlib${ii}$_sgelqt( m, n, mb, a, lda, t, ldt, work, info ) !! DGELQT computes a blocked LQ factorization of a real M-by-N matrix A !! using the compact WY representation of Q. ! -- 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, ldt, m, n, mb + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldt, m, n, mb ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: t(ldt,*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ib, iinfo, k + integer(${ik}$) :: i, ib, iinfo, k ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( mb<1 .or. ( mb>min(m,n) .and. min(m,n)>0 ) )then - info = -3 - else if( ldamin(m,n) .and. min(m,n)>0_${ik}$ ) )then + info = -3_${ik}$ + else if( lda=n ) then - nb = stdlib_ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEQRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) if( tpsd ) then - nb = max( nb, stdlib_ilaenv( 1, 'SORMQR', 'LN', m, nrhs, n,-1 ) ) + nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMQR', 'LN', m, nrhs, n,-1_${ik}$ ) ) else - nb = max( nb, stdlib_ilaenv( 1, 'SORMQR', 'LT', m, nrhs, n,-1 ) ) + nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMQR', 'LT', m, nrhs, n,-1_${ik}$ ) ) end if else - nb = stdlib_ilaenv( 1, 'SGELQF', ' ', m, n, -1, -1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SGELQF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) if( tpsd ) then - nb = max( nb, stdlib_ilaenv( 1, 'SORMLQ', 'LT', n, nrhs, m,-1 ) ) + nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMLQ', 'LT', n, nrhs, m,-1_${ik}$ ) ) else - nb = max( nb, stdlib_ilaenv( 1, 'SORMLQ', 'LN', n, nrhs, m,-1 ) ) + nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMLQ', 'LN', n, nrhs, m,-1_${ik}$ ) ) end if end if - wsize = max( 1, mn + max( mn, nrhs )*nb ) - work( 1 ) = real( wsize,KIND=sp) + wsize = max( 1_${ik}$, mn + max( mn, nrhs )*nb ) + work( 1_${ik}$ ) = real( wsize,KIND=sp) end if - if( info/=0 ) then - call stdlib_xerbla( 'SGELS ', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'SGELS ', -info ) return else if( lquery ) then return end if ! quick return if possible - if( min( m, n, nrhs )==0 ) then - call stdlib_slaset( 'FULL', max( m, n ), nrhs, zero, zero, b, ldb ) + if( min( m, n, nrhs )==0_${ik}$ ) then + call stdlib${ii}$_slaset( 'FULL', max( m, n ), nrhs, zero, zero, b, ldb ) return end if ! get machine parameters - smlnum = stdlib_slamch( 'S' ) / stdlib_slamch( 'P' ) + smlnum = stdlib${ii}$_slamch( 'S' ) / stdlib${ii}$_slamch( 'P' ) bignum = one / smlnum - call stdlib_slabad( smlnum, bignum ) + call stdlib${ii}$_slabad( smlnum, bignum ) ! scale a, b if max element outside range [smlnum,bignum] - anrm = stdlib_slange( 'M', m, n, a, lda, rwork ) - iascl = 0 + anrm = stdlib${ii}$_slange( 'M', m, n, a, lda, rwork ) + iascl = 0_${ik}$ if( anrm>zero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_slascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_slaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) + call stdlib${ii}$_slaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) go to 50 end if brow = m if( tpsd )brow = n - bnrm = stdlib_slange( 'M', brow, nrhs, b, ldb, rwork ) - ibscl = 0 + bnrm = stdlib${ii}$_slange( 'M', brow, nrhs, b, ldb, rwork ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_slascl( 'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,info ) - ibscl = 2 + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, brow, nrhs, b, ldb,info ) + ibscl = 2_${ik}$ end if if( m>=n ) then ! compute qr factorization of a - call stdlib_sgeqrf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,info ) + call stdlib${ii}$_sgeqrf( m, n, a, lda, work( 1_${ik}$ ), work( mn+1 ), lwork-mn,info ) ! workspace at least n, optimally n*nb if( .not.tpsd ) then ! least-squares problem min || a * x - b || ! b(1:m,1:nrhs) := q**t * b(1:m,1:nrhs) - call stdlib_sormqr( 'LEFT', 'TRANSPOSE', m, nrhs, n, a, lda,work( 1 ), b, ldb, & + call stdlib${ii}$_sormqr( 'LEFT', 'TRANSPOSE', m, nrhs, n, a, lda,work( 1_${ik}$ ), b, ldb, & work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb ! b(1:n,1:nrhs) := inv(r) * b(1:n,1:nrhs) - call stdlib_strtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, nrhs,a, lda, b, ldb, & + call stdlib${ii}$_strtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, nrhs,a, lda, b, ldb, & info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if scllen = n else ! underdetermined system of equations a**t * x = b ! b(1:n,1:nrhs) := inv(r**t) * b(1:n,1:nrhs) - call stdlib_strtrs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,a, lda, b, ldb, & + call stdlib${ii}$_strtrs( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, nrhs,a, lda, b, ldb, & info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if ! b(n+1:m,1:nrhs) = zero @@ -60542,21 +60544,21 @@ module stdlib_linalg_lapack_s end do end do ! b(1:m,1:nrhs) := q(1:n,:) * b(1:n,1:nrhs) - call stdlib_sormqr( 'LEFT', 'NO TRANSPOSE', m, nrhs, n, a, lda,work( 1 ), b, ldb,& + call stdlib${ii}$_sormqr( 'LEFT', 'NO TRANSPOSE', m, nrhs, n, a, lda,work( 1_${ik}$ ), b, ldb,& work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb scllen = m end if else ! compute lq factorization of a - call stdlib_sgelqf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,info ) + call stdlib${ii}$_sgelqf( m, n, a, lda, work( 1_${ik}$ ), work( mn+1 ), lwork-mn,info ) ! workspace at least m, optimally m*nb. if( .not.tpsd ) then ! underdetermined system of equations a * x = b ! b(1:m,1:nrhs) := inv(l) * b(1:m,1:nrhs) - call stdlib_strtrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & + call stdlib${ii}$_strtrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if ! b(m+1:n,1:nrhs) = 0 @@ -60566,43 +60568,43 @@ module stdlib_linalg_lapack_s end do end do ! b(1:n,1:nrhs) := q(1:n,:)**t * b(1:m,1:nrhs) - call stdlib_sormlq( 'LEFT', 'TRANSPOSE', n, nrhs, m, a, lda,work( 1 ), b, ldb, & + call stdlib${ii}$_sormlq( 'LEFT', 'TRANSPOSE', n, nrhs, m, a, lda,work( 1_${ik}$ ), b, ldb, & work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb scllen = n else ! overdetermined system min || a**t * x - b || ! b(1:n,1:nrhs) := q * b(1:n,1:nrhs) - call stdlib_sormlq( 'LEFT', 'NO TRANSPOSE', n, nrhs, m, a, lda,work( 1 ), b, ldb,& + call stdlib${ii}$_sormlq( 'LEFT', 'NO TRANSPOSE', n, nrhs, m, a, lda,work( 1_${ik}$ ), b, ldb,& work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb ! b(1:m,1:nrhs) := inv(l**t) * b(1:m,1:nrhs) - call stdlib_strtrs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & + call stdlib${ii}$_strtrs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if scllen = m end if end if ! undo scaling - if( iascl==1 ) then - call stdlib_slascl( 'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,info ) - else if( iascl==2 ) then - call stdlib_slascl( 'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,info ) + if( iascl==1_${ik}$ ) then + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, smlnum, scllen, nrhs, b, ldb,info ) + else if( iascl==2_${ik}$ ) then + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, scllen, nrhs, b, ldb,info ) end if - if( ibscl==1 ) then - call stdlib_slascl( 'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,info ) - else if( ibscl==2 ) then - call stdlib_slascl( 'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,info ) + if( ibscl==1_${ik}$ ) then + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, bnrm, scllen, nrhs, b, ldb,info ) + else if( ibscl==2_${ik}$ ) then + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bignum, bnrm, scllen, nrhs, b, ldb,info ) end if 50 continue - work( 1 ) = real( wsize,KIND=sp) + work( 1_${ik}$ ) = real( wsize,KIND=sp) return - end subroutine stdlib_sgels + end subroutine stdlib${ii}$_sgels - pure subroutine stdlib_sgemlq( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, & + pure subroutine stdlib${ii}$_sgemlq( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, & !! SGEMLQ overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -60616,8 +60618,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) :: lda, m, n, k, tsize, lwork, ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, k, tsize, lwork, ldc ! Array Arguments real(sp), intent(in) :: a(lda,*), t(*) real(sp), intent(inout) :: c(ldc,*) @@ -60625,18 +60627,18 @@ module stdlib_linalg_lapack_s ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran, lquery - integer(ilp) :: mb, nb, lw, nblcks, mn + integer(${ik}$) :: mb, nb, lw, nblcks, mn ! Intrinsic Functions intrinsic :: int,max,min,mod ! Executable Statements ! test the input arguments - lquery = lwork==-1 + lquery = lwork==-1_${ik}$ notran = stdlib_lsame( trans, 'N' ) tran = stdlib_lsame( trans, 'T' ) left = stdlib_lsame( side, 'L' ) right = stdlib_lsame( side, 'R' ) - mb = int( t( 2 ),KIND=ilp) - nb = int( t( 3 ),KIND=ilp) + mb = int( t( 2_${ik}$ ),KIND=${ik}$) + nb = int( t( 3_${ik}$ ),KIND=${ik}$) if( left ) then lw = n * mb mn = m @@ -60645,61 +60647,61 @@ module stdlib_linalg_lapack_s mn = n end if if( ( nb>k ) .and. ( mn>k ) ) then - if( mod( mn - k, nb - k ) == 0 ) then + if( mod( mn - k, nb - k ) == 0_${ik}$ ) then nblcks = ( mn - k ) / ( nb - k ) else - nblcks = ( mn - k ) / ( nb - k ) + 1 + nblcks = ( mn - k ) / ( nb - k ) + 1_${ik}$ end if else - nblcks = 1 + nblcks = 1_${ik}$ end if - info = 0 + info = 0_${ik}$ 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>mn ) then - info = -5 - else if( ldamn ) then + info = -5_${ik}$ + else if( lda=max( m, n, & k ) ) ) then - call stdlib_sgemlqt( side, trans, m, n, k, mb, a, lda,t( 6 ), mb, c, ldc, work, info & + call stdlib${ii}$_sgemlqt( side, trans, m, n, k, mb, a, lda,t( 6_${ik}$ ), mb, c, ldc, work, info & ) else - call stdlib_slamswlq( side, trans, m, n, k, mb, nb, a, lda, t( 6 ),mb, c, ldc, work, & + call stdlib${ii}$_slamswlq( side, trans, m, n, k, mb, nb, a, lda, t( 6_${ik}$ ),mb, c, ldc, work, & lwork, info ) end if - work( 1 ) = real( lw,KIND=sp) + work( 1_${ik}$ ) = real( lw,KIND=sp) return - end subroutine stdlib_sgemlq + end subroutine stdlib${ii}$_sgemlq - pure subroutine stdlib_sgemqr( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, & + pure subroutine stdlib${ii}$_sgemqr( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, & !! SGEMQR overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -60713,8 +60715,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) :: lda, m, n, k, tsize, lwork, ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, k, tsize, lwork, ldc ! Array Arguments real(sp), intent(in) :: a(lda,*), t(*) real(sp), intent(inout) :: c(ldc,*) @@ -60722,18 +60724,18 @@ module stdlib_linalg_lapack_s ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran, lquery - integer(ilp) :: mb, nb, lw, nblcks, mn + integer(${ik}$) :: mb, nb, lw, nblcks, mn ! Intrinsic Functions intrinsic :: int,max,min,mod ! Executable Statements ! test the input arguments - lquery = lwork==-1 + lquery = lwork==-1_${ik}$ notran = stdlib_lsame( trans, 'N' ) tran = stdlib_lsame( trans, 'T' ) left = stdlib_lsame( side, 'L' ) right = stdlib_lsame( side, 'R' ) - mb = int( t( 2 ),KIND=ilp) - nb = int( t( 3 ),KIND=ilp) + mb = int( t( 2_${ik}$ ),KIND=${ik}$) + nb = int( t( 3_${ik}$ ),KIND=${ik}$) if( left ) then lw = n * nb mn = m @@ -60742,149 +60744,149 @@ module stdlib_linalg_lapack_s mn = n end if if( ( mb>k ) .and. ( mn>k ) ) then - if( mod( mn - k, mb - k )==0 ) then + if( mod( mn - k, mb - k )==0_${ik}$ ) then nblcks = ( mn - k ) / ( mb - k ) else - nblcks = ( mn - k ) / ( mb - k ) + 1 + nblcks = ( mn - k ) / ( mb - k ) + 1_${ik}$ end if else - nblcks = 1 + nblcks = 1_${ik}$ end if - info = 0 + info = 0_${ik}$ 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>mn ) then - info = -5 - else if( ldamn ) then + info = -5_${ik}$ + else if( lda=max( m, n, & k ) ) ) then - call stdlib_sgemqrt( side, trans, m, n, k, nb, a, lda, t( 6 ),nb, c, ldc, work, info & + call stdlib${ii}$_sgemqrt( side, trans, m, n, k, nb, a, lda, t( 6_${ik}$ ),nb, c, ldc, work, info & ) else - call stdlib_slamtsqr( side, trans, m, n, k, mb, nb, a, lda, t( 6 ),nb, c, ldc, work, & + call stdlib${ii}$_slamtsqr( side, trans, m, n, k, mb, nb, a, lda, t( 6_${ik}$ ),nb, c, ldc, work, & lwork, info ) end if - work( 1 ) = lw + work( 1_${ik}$ ) = lw return - end subroutine stdlib_sgemqr + end subroutine stdlib${ii}$_sgemqr - pure subroutine stdlib_sgeqp3( m, n, a, lda, jpvt, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_sgeqp3( m, n, a, lda, jpvt, tau, work, lwork, info ) !! SGEQP3 computes a QR factorization with column pivoting of a !! matrix A: A*P = Q*R using Level 3 BLAS. ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, lwork, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, lwork, m, n ! Array Arguments - integer(ilp), intent(inout) :: jpvt(*) + integer(${ik}$), intent(inout) :: jpvt(*) real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: tau(*), work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: inb = 1 - integer(ilp), parameter :: inbmin = 2 - integer(ilp), parameter :: ixover = 3 + integer(${ik}$), parameter :: inb = 1_${ik}$ + integer(${ik}$), parameter :: inbmin = 2_${ik}$ + integer(${ik}$), parameter :: ixover = 3_${ik}$ ! Local Scalars logical(lk) :: lquery - integer(ilp) :: fjb, iws, j, jb, lwkopt, minmn, minws, na, nb, nbmin, nfxd, nx, sm, & + integer(${ik}$) :: fjb, iws, j, jb, lwkopt, minmn, minws, na, nb, nbmin, nfxd, nx, sm, & sminmn, sn, topbmn ! Intrinsic Functions intrinsic :: int,max,min ! test input arguments ! ==================== - info = 0 - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda0 ) then + if( nfxd>0_${ik}$ ) then na = min( m, nfxd ) - ! cc call stdlib_sgeqr2( m, na, a, lda, tau, work, info ) - call stdlib_sgeqrf( m, na, a, lda, tau, work, lwork, info ) - iws = max( iws, int( work( 1 ),KIND=ilp) ) + ! cc call stdlib${ii}$_sgeqr2( m, na, a, lda, tau, work, info ) + call stdlib${ii}$_sgeqrf( m, na, a, lda, tau, work, lwork, info ) + iws = max( iws, int( work( 1_${ik}$ ),KIND=${ik}$) ) if( na1 ) .and. ( nb1_${ik}$ ) .and. ( nb=nbmin ) .and. ( nbmin(m,n) .and. min(m,n)>0 ) )then - info = -3 - else if( ldamin(m,n) .and. min(m,n)>0_${ik}$ ) )then + info = -3_${ik}$ + else if( lda0 ) then + info = -11_${ik}$ + else if( n>0_${ik}$ ) then rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) else rowcnd = one end if end if - if( colequ .and. info==0 ) then + if( colequ .and. info==0_${ik}$ ) then rcmin = bignum rcmax = zero do j = 1, n @@ -61137,31 +61139,31 @@ module stdlib_linalg_lapack_s rcmax = max( rcmax, c( j ) ) end do if( rcmin<=zero ) then - info = -12 - else if( n>0 ) then + info = -12_${ik}$ + else if( n>0_${ik}$ ) then colcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) else colcnd = one end if end if - if( info==0 ) then - if( ldb0 ) then + if( info>0_${ik}$ ) then ! compute the reciprocal pivot growth factor of the ! leading rank-deficient info columns of a. - rpvgrw = stdlib_slantr( 'M', 'U', 'N', info, info, af, ldaf,work ) + rpvgrw = stdlib${ii}$_slantr( 'M', 'U', 'N', info, info, af, ldaf,work ) if( rpvgrw==zero ) then rpvgrw = one else - rpvgrw = stdlib_slange( 'M', n, info, a, lda, work ) / rpvgrw + rpvgrw = stdlib${ii}$_slange( 'M', n, info, a, lda, work ) / rpvgrw end if - work( 1 ) = rpvgrw + work( 1_${ik}$ ) = rpvgrw rcond = zero return end if @@ -61208,21 +61210,21 @@ module stdlib_linalg_lapack_s else norm = 'I' end if - anorm = stdlib_slange( norm, n, n, a, lda, work ) - rpvgrw = stdlib_slantr( 'M', 'U', 'N', n, n, af, ldaf, work ) + anorm = stdlib${ii}$_slange( norm, n, n, a, lda, work ) + rpvgrw = stdlib${ii}$_slantr( 'M', 'U', 'N', n, n, af, ldaf, work ) if( rpvgrw==zero ) then rpvgrw = one else - rpvgrw = stdlib_slange( 'M', n, n, a, lda, work ) / rpvgrw + rpvgrw = stdlib${ii}$_slange( 'M', n, n, a, lda, work ) / rpvgrw end if ! compute the reciprocal of the condition number of a. - call stdlib_sgecon( norm, n, af, ldaf, anorm, rcond, work, iwork, info ) + call stdlib${ii}$_sgecon( norm, n, af, ldaf, anorm, rcond, work, iwork, info ) ! compute the solution matrix x. - call stdlib_slacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_sgetrs( trans, n, nrhs, af, ldaf, ipiv, x, ldx, info ) + call stdlib${ii}$_slacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_sgetrs( trans, n, nrhs, af, ldaf, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_sgerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & + call stdlib${ii}$_sgerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & work, iwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -61248,13 +61250,13 @@ module stdlib_linalg_lapack_s end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond0 )then - minwrk = max( 8*n, 6*n + 16 ) - maxwrk = minwrk - n +n*stdlib_ilaenv( 1, 'SGEQRF', ' ', n, 1, n, 0 ) - maxwrk = max( maxwrk, minwrk - n +n*stdlib_ilaenv( 1, 'SORMQR', ' ', n, 1, n, -1 & + ! following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + if( n>0_${ik}$ )then + minwrk = max( 8_${ik}$*n, 6_${ik}$*n + 16_${ik}$ ) + maxwrk = minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) + maxwrk = max( maxwrk, minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMQR', ' ', n, 1_${ik}$, n, -1_${ik}$ & ) ) if( ilvsl ) then - maxwrk = max( maxwrk, minwrk - n +n*stdlib_ilaenv( 1, 'SORGQR', ' ', n, 1, n, & - -1 ) ) + maxwrk = max( maxwrk, minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SORGQR', ' ', n, 1_${ik}$, n, & + -1_${ik}$ ) ) end if else - minwrk = 1 - maxwrk = 1 + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ end if - work( 1 ) = maxwrk - if( lworkzero .and. anrmzero .and. bnrm1 ) then - call stdlib_slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& + call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vsl, ldvsl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& , ldvsl ) end if - call stdlib_sorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & + call stdlib${ii}$_sorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vsr - if( ilvsr )call stdlib_slaset( 'FULL', n, n, zero, one, vsr, ldvsr ) + if( ilvsr )call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vsr, ldvsr ) ! reduce to generalized hessenberg form ! (workspace: none needed) - call stdlib_sgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& + call stdlib${ii}$_sgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& ierr ) ! perform qz algorithm, computing schur vectors if desired ! (workspace: need n) iwrk = itau - call stdlib_shgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & + call stdlib${ii}$_shgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 40 end if ! sort eigenvalues alpha/beta if desired ! (workspace: need 4*n+16 ) - sdim = 0 + sdim = 0_${ik}$ if( wantst ) then ! undo scaling on eigenvalues before selctging if( ilascl ) then - call stdlib_slascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n,ierr ) - call stdlib_slascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n,ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n,ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n,ierr ) end if - if( ilbscl )call stdlib_slascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + if( ilbscl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) ! select eigenvalues do i = 1, n bwork( i ) = selctg( alphar( i ), alphai( i ), beta( i ) ) end do - call stdlib_stgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, & - vsl, ldvsl, vsr, ldvsr, sdim, pvsl,pvsr, dif, work( iwrk ), lwork-iwrk+1, idum, 1,& + call stdlib${ii}$_stgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, & + vsl, ldvsl, vsr, ldvsr, sdim, pvsl,pvsr, dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$,& ierr ) - if( ierr==1 )info = n + 3 + if( ierr==1_${ik}$ )info = n + 3_${ik}$ end if ! apply back-permutation to vsl and vsr ! (workspace: none needed) - if( ilvsl )call stdlib_sggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, & + if( ilvsl )call stdlib${ii}$_sggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, & vsl, ldvsl, ierr ) - if( ilvsr )call stdlib_sggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, & + if( ilvsr )call stdlib${ii}$_sggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, & vsr, ldvsr, ierr ) ! check if unscaling would cause over/underflow, if so, rescale ! (alphar(i),alphai(i),beta(i)) so beta(i) is on the order of @@ -61501,16 +61503,16 @@ module stdlib_linalg_lapack_s if( alphai( i )/=zero ) then if( ( alphar( i )/safmax )>( anrmto/anrm ) .or.( safmin/alphar( i ) )>( & anrm/anrmto ) ) then - work( 1 ) = abs( a( i, i )/alphar( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( a( i, i )/alphar( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) else if( ( alphai( i )/safmax )>( anrmto/anrm ) .or.( safmin/alphai( i ) )>( & anrm/anrmto ) ) then - work( 1 ) = abs( a( i, i+1 )/alphai( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( a( i, i+1 )/alphai( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) end if end if end do @@ -61520,47 +61522,47 @@ module stdlib_linalg_lapack_s if( alphai( i )/=zero ) then if( ( beta( i )/safmax )>( bnrmto/bnrm ) .or.( safmin/beta( i ) )>( & bnrm/bnrmto ) ) then - work( 1 ) = abs(b( i, i )/beta( i )) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs(b( i, i )/beta( i )) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) end if end if end do end if ! undo scaling if( ilascl ) then - call stdlib_slascl( 'H', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) - call stdlib_slascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr ) - call stdlib_slascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr ) + call stdlib${ii}$_slascl( 'H', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr ) end if if( ilbscl ) then - call stdlib_slascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) - call stdlib_slascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + call stdlib${ii}$_slascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) end if if( wantst ) then ! check if reordering is correct lastsl = .true. lst2sl = .true. - sdim = 0 - ip = 0 + sdim = 0_${ik}$ + ip = 0_${ik}$ do i = 1, n cursl = selctg( alphar( i ), alphai( i ), beta( i ) ) if( alphai( i )==zero ) then - if( cursl )sdim = sdim + 1 - ip = 0 - if( cursl .and. .not.lastsl )info = n + 2 + if( cursl )sdim = sdim + 1_${ik}$ + ip = 0_${ik}$ + if( cursl .and. .not.lastsl )info = n + 2_${ik}$ else - if( ip==1 ) then + if( ip==1_${ik}$ ) then ! last eigenvalue of conjugate pair cursl = cursl .or. lastsl lastsl = cursl - if( cursl )sdim = sdim + 2 - ip = -1 - if( cursl .and. .not.lst2sl )info = n + 2 + if( cursl )sdim = sdim + 2_${ik}$ + ip = -1_${ik}$ + if( cursl .and. .not.lst2sl )info = n + 2_${ik}$ else ! first eigenvalue of conjugate pair - ip = 1 + ip = 1_${ik}$ end if end if lst2sl = lastsl @@ -61568,12 +61570,12 @@ module stdlib_linalg_lapack_s end do end if 40 continue - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_sgges + end subroutine stdlib${ii}$_sgges - subroutine stdlib_sggesx( jobvsl, jobvsr, sort, selctg, sense, n, a, lda,b, ldb, sdim, & + subroutine stdlib${ii}$_sggesx( jobvsl, jobvsr, sort, selctg, sense, n, a, lda,b, ldb, sdim, & !! SGGESX computes for a pair of N-by-N real nonsymmetric matrices !! (A,B), the generalized eigenvalues, the real Schur form (S,T), and, !! optionally, the left and/or right matrices of Schur vectors (VSL and @@ -61609,13 +61611,13 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvsl, jobvsr, sense, sort - integer(ilp), intent(out) :: info, sdim - integer(ilp), intent(in) :: lda, ldb, ldvsl, ldvsr, liwork, lwork, n + integer(${ik}$), intent(out) :: info, sdim + integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, liwork, lwork, n ! Array Arguments logical(lk), intent(out) :: bwork(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(inout) :: a(lda,*), b(ldb,*) - real(sp), intent(out) :: alphai(*), alphar(*), beta(*), rconde(2), rcondv(2), vsl(& + real(sp), intent(out) :: alphai(*), alphar(*), beta(*), rconde(2_${ik}$), rcondv(2_${ik}$), vsl(& ldvsl,*), vsr(ldvsr,*), work(*) ! Function Arguments procedure(stdlib_selctg_s) :: selctg @@ -61624,34 +61626,34 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, lst2sl, wantsb, & wantse, wantsn, wantst, wantsv - integer(ilp) :: i, icols, ierr, ihi, ijob, ijobvl, ijobvr, ileft, ilo, ip, iright, & + integer(${ik}$) :: i, icols, ierr, ihi, ijob, ijobvl, ijobvr, ileft, ilo, ip, iright, & irows, itau, iwrk, liwmin, lwrk, maxwrk, minwrk real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pl, pr, safmax, safmin, & smlnum ! Local Arrays - real(sp) :: dif(2) + real(sp) :: dif(2_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvsl, 'N' ) ) then - ijobvl = 1 + ijobvl = 1_${ik}$ ilvsl = .false. else if( stdlib_lsame( jobvsl, 'V' ) ) then - ijobvl = 2 + ijobvl = 2_${ik}$ ilvsl = .true. else - ijobvl = -1 + ijobvl = -1_${ik}$ ilvsl = .false. end if if( stdlib_lsame( jobvsr, 'N' ) ) then - ijobvr = 1 + ijobvr = 1_${ik}$ ilvsr = .false. else if( stdlib_lsame( jobvsr, 'V' ) ) then - ijobvr = 2 + ijobvr = 2_${ik}$ ilvsr = .true. else - ijobvr = -1 + ijobvr = -1_${ik}$ ilvsr = .false. end if wantst = stdlib_lsame( sort, 'S' ) @@ -61659,94 +61661,94 @@ module stdlib_linalg_lapack_s wantse = stdlib_lsame( sense, 'E' ) wantsv = stdlib_lsame( sense, 'V' ) wantsb = stdlib_lsame( sense, 'B' ) - lquery = ( lwork==-1 .or. liwork==-1 ) + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) if( wantsn ) then - ijob = 0 + ijob = 0_${ik}$ else if( wantse ) then - ijob = 1 + ijob = 1_${ik}$ else if( wantsv ) then - ijob = 2 + ijob = 2_${ik}$ else if( wantsb ) then - ijob = 4 + ijob = 4_${ik}$ end if ! test the input arguments - info = 0 - if( ijobvl<=0 ) then - info = -1 - else if( ijobvr<=0 ) then - info = -2 + info = 0_${ik}$ + if( ijobvl<=0_${ik}$ ) then + info = -1_${ik}$ + else if( ijobvr<=0_${ik}$ ) then + info = -2_${ik}$ else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then - info = -3 + info = -3_${ik}$ else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. & .not.wantsn ) ) then - info = -5 - else if( n<0 ) then - info = -6 - else if( lda0) then - minwrk = max( 8*n, 6*n + 16 ) - maxwrk = minwrk - n +n*stdlib_ilaenv( 1, 'SGEQRF', ' ', n, 1, n, 0 ) - maxwrk = max( maxwrk, minwrk - n +n*stdlib_ilaenv( 1, 'SORMQR', ' ', n, 1, n, -1 & + ! following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + if( n>0_${ik}$) then + minwrk = max( 8_${ik}$*n, 6_${ik}$*n + 16_${ik}$ ) + maxwrk = minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) + maxwrk = max( maxwrk, minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMQR', ' ', n, 1_${ik}$, n, -1_${ik}$ & ) ) if( ilvsl ) then - maxwrk = max( maxwrk, minwrk - n +n*stdlib_ilaenv( 1, 'SORGQR', ' ', n, 1, n, & - -1 ) ) + maxwrk = max( maxwrk, minwrk - n +n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SORGQR', ' ', n, 1_${ik}$, n, & + -1_${ik}$ ) ) end if lwrk = maxwrk - if( ijob>=1 )lwrk = max( lwrk, n*n/2 ) + if( ijob>=1_${ik}$ )lwrk = max( lwrk, n*n/2_${ik}$ ) else - minwrk = 1 - maxwrk = 1 - lwrk = 1 + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + lwrk = 1_${ik}$ end if - work( 1 ) = lwrk - if( wantsn .or. n==0 ) then - liwmin = 1 + work( 1_${ik}$ ) = lwrk + if( wantsn .or. n==0_${ik}$ ) then + liwmin = 1_${ik}$ else - liwmin = n + 6 + liwmin = n + 6_${ik}$ end if - iwork( 1 ) = liwmin + iwork( 1_${ik}$ ) = liwmin if( lworkzero .and. anrmzero .and. bnrm1 ) then - call stdlib_slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& + call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vsl, ldvsl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& , ldvsl ) end if - call stdlib_sorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & + call stdlib${ii}$_sorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vsr - if( ilvsr )call stdlib_slaset( 'FULL', n, n, zero, one, vsr, ldvsr ) + if( ilvsr )call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vsr, ldvsr ) ! reduce to generalized hessenberg form ! (workspace: none needed) - call stdlib_sgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& + call stdlib${ii}$_sgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& ierr ) - sdim = 0 + sdim = 0_${ik}$ ! perform qz algorithm, computing schur vectors if desired ! (workspace: need n) iwrk = itau - call stdlib_shgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & + call stdlib${ii}$_shgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 50 end if @@ -61826,10 +61828,10 @@ module stdlib_linalg_lapack_s if( wantst ) then ! undo scaling on eigenvalues before selctging if( ilascl ) then - call stdlib_slascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n,ierr ) - call stdlib_slascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n,ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n,ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n,ierr ) end if - if( ilbscl )call stdlib_slascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + if( ilbscl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) ! select eigenvalues do i = 1, n @@ -61837,30 +61839,30 @@ module stdlib_linalg_lapack_s end do ! reorder eigenvalues, transform generalized schur vectors, and ! compute reciprocal condition numbers - call stdlib_stgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alphar, alphai, & + call stdlib${ii}$_stgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alphar, alphai, & beta, vsl, ldvsl, vsr, ldvsr,sdim, pl, pr, dif, work( iwrk ), lwork-iwrk+1,iwork, & liwork, ierr ) - if( ijob>=1 )maxwrk = max( maxwrk, 2*sdim*( n-sdim ) ) - if( ierr==-22 ) then + if( ijob>=1_${ik}$ )maxwrk = max( maxwrk, 2_${ik}$*sdim*( n-sdim ) ) + if( ierr==-22_${ik}$ ) then ! not enough real workspace - info = -22 + info = -22_${ik}$ else - if( ijob==1 .or. ijob==4 ) then - rconde( 1 ) = pl - rconde( 2 ) = pr + if( ijob==1_${ik}$ .or. ijob==4_${ik}$ ) then + rconde( 1_${ik}$ ) = pl + rconde( 2_${ik}$ ) = pr end if - if( ijob==2 .or. ijob==4 ) then - rcondv( 1 ) = dif( 1 ) - rcondv( 2 ) = dif( 2 ) + if( ijob==2_${ik}$ .or. ijob==4_${ik}$ ) then + rcondv( 1_${ik}$ ) = dif( 1_${ik}$ ) + rcondv( 2_${ik}$ ) = dif( 2_${ik}$ ) end if - if( ierr==1 )info = n + 3 + if( ierr==1_${ik}$ )info = n + 3_${ik}$ end if end if ! apply permutation to vsl and vsr ! (workspace: none needed) - if( ilvsl )call stdlib_sggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, & + if( ilvsl )call stdlib${ii}$_sggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, & vsl, ldvsl, ierr ) - if( ilvsr )call stdlib_sggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, & + if( ilvsr )call stdlib${ii}$_sggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, & vsr, ldvsr, ierr ) ! check if unscaling would cause over/underflow, if so, rescale ! (alphar(i),alphai(i),beta(i)) so beta(i) is on the order of @@ -61870,16 +61872,16 @@ module stdlib_linalg_lapack_s if( alphai( i )/=zero ) then if( ( alphar( i ) / safmax )>( anrmto / anrm ) .or.( safmin / alphar( i ) )>( & anrm / anrmto ) )then - work( 1 ) = abs( a( i, i ) / alphar( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( a( i, i ) / alphar( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) else if( ( alphai( i ) / safmax )>( anrmto / anrm ).or. ( safmin / alphai( i )& )>( anrm / anrmto ) )then - work( 1 ) = abs( a( i, i+1 ) / alphai( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( a( i, i+1 ) / alphai( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) end if end if end do @@ -61889,47 +61891,47 @@ module stdlib_linalg_lapack_s if( alphai( i )/=zero ) then if( ( beta( i ) / safmax )>( bnrmto / bnrm ) .or.( safmin / beta( i ) )>( & bnrm / bnrmto ) ) then - work( 1 ) = abs( b( i, i ) / beta( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( b( i, i ) / beta( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) end if end if end do end if ! undo scaling if( ilascl ) then - call stdlib_slascl( 'H', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) - call stdlib_slascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr ) - call stdlib_slascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr ) + call stdlib${ii}$_slascl( 'H', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr ) end if if( ilbscl ) then - call stdlib_slascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) - call stdlib_slascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + call stdlib${ii}$_slascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) end if if( wantst ) then ! check if reordering is correct lastsl = .true. lst2sl = .true. - sdim = 0 - ip = 0 + sdim = 0_${ik}$ + ip = 0_${ik}$ do i = 1, n cursl = selctg( alphar( i ), alphai( i ), beta( i ) ) if( alphai( i )==zero ) then - if( cursl )sdim = sdim + 1 - ip = 0 - if( cursl .and. .not.lastsl )info = n + 2 + if( cursl )sdim = sdim + 1_${ik}$ + ip = 0_${ik}$ + if( cursl .and. .not.lastsl )info = n + 2_${ik}$ else - if( ip==1 ) then + if( ip==1_${ik}$ ) then ! last eigenvalue of conjugate pair cursl = cursl .or. lastsl lastsl = cursl - if( cursl )sdim = sdim + 2 - ip = -1 - if( cursl .and. .not.lst2sl )info = n + 2 + if( cursl )sdim = sdim + 2_${ik}$ + ip = -1_${ik}$ + if( cursl .and. .not.lst2sl )info = n + 2_${ik}$ else ! first eigenvalue of conjugate pair - ip = 1 + ip = 1_${ik}$ end if end if lst2sl = lastsl @@ -61937,13 +61939,13 @@ module stdlib_linalg_lapack_s end do end if 50 continue - work( 1 ) = maxwrk - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = maxwrk + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_sggesx + end subroutine stdlib${ii}$_sggesx - subroutine stdlib_sggev( jobvl, jobvr, n, a, lda, b, ldb, alphar, alphai,beta, vl, ldvl, vr, & + subroutine stdlib${ii}$_sggev( jobvl, jobvr, n, a, lda, b, ldb, alphar, alphai,beta, vl, ldvl, vr, & !! SGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B) !! the generalized eigenvalues, and optionally, the left and/or right !! generalized eigenvectors. @@ -61965,8 +61967,8 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvl, jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n ! Array Arguments real(sp), intent(inout) :: a(lda,*), b(ldb,*) real(sp), intent(out) :: alphai(*), alphar(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*) @@ -61976,75 +61978,75 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery character :: chtemp - integer(ilp) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, itau, & + integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, itau, & iwrk, jc, jr, maxwrk, minwrk real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp ! Local Arrays - logical(lk) :: ldumma(1) + logical(lk) :: ldumma(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvl, 'N' ) ) then - ijobvl = 1 + ijobvl = 1_${ik}$ ilvl = .false. else if( stdlib_lsame( jobvl, 'V' ) ) then - ijobvl = 2 + ijobvl = 2_${ik}$ ilvl = .true. else - ijobvl = -1 + ijobvl = -1_${ik}$ ilvl = .false. end if if( stdlib_lsame( jobvr, 'N' ) ) then - ijobvr = 1 + ijobvr = 1_${ik}$ ilvr = .false. else if( stdlib_lsame( jobvr, 'V' ) ) then - ijobvr = 2 + ijobvr = 2_${ik}$ ilvr = .true. else - ijobvr = -1 + ijobvr = -1_${ik}$ ilvr = .false. end if ilv = ilvl .or. ilvr ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( ijobvl<=0 ) then - info = -1 - else if( ijobvr<=0 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldazero .and. anrmzero .and. bnrm1 ) then - call stdlib_slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& + call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vl, ldvl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& ldvl ) end if - call stdlib_sorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & + call stdlib${ii}$_sorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vr - if( ilvr )call stdlib_slaset( 'FULL', n, n, zero, one, vr, ldvr ) + if( ilvr )call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vr, ldvr ) ! reduce to generalized hessenberg form ! (workspace: none needed) if( ilv ) then ! eigenvectors requested -- work on whole matrix. - call stdlib_sgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib${ii}$_sgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & ierr ) else - call stdlib_sgghrd( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & + call stdlib${ii}$_sgghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & ldb, vl, ldvl, vr, ldvr, ierr ) end if ! perform qz algorithm (compute eigenvalues, and optionally, the @@ -62135,15 +62137,15 @@ module stdlib_linalg_lapack_s else chtemp = 'E' end if - call stdlib_shgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & + call stdlib${ii}$_shgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & beta, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 110 end if @@ -62159,16 +62161,16 @@ module stdlib_linalg_lapack_s else chtemp = 'R' end if - call stdlib_stgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & + call stdlib${ii}$_stgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & in, work( iwrk ), ierr ) - if( ierr/=0 ) then - info = n + 2 + if( ierr/=0_${ik}$ ) then + info = n + 2_${ik}$ go to 110 end if ! undo balancing on vl and vr and normalization ! (workspace: none needed) if( ilvl ) then - call stdlib_sggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, & + call stdlib${ii}$_sggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, & ldvl, ierr ) loop_50: do jc = 1, n if( alphai( jc )zero .and. anrmzero .and. bnrm1 ) then - call stdlib_slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& + call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vl, ldvl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& ldvl ) end if - call stdlib_sorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & + call stdlib${ii}$_sorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if - if( ilvr )call stdlib_slaset( 'FULL', n, n, zero, one, vr, ldvr ) + if( ilvr )call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vr, ldvr ) ! reduce to generalized hessenberg form ! (workspace: none needed) if( ilv .or. .not.wantsn ) then ! eigenvectors requested -- work on whole matrix. - call stdlib_sgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib${ii}$_sgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & ierr ) else - call stdlib_sgghrd( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & + call stdlib${ii}$_sgghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & ldb, vl, ldvl, vr, ldvr, ierr ) end if ! perform qz algorithm (compute eigenvalues, and optionally, the @@ -62479,21 +62481,21 @@ module stdlib_linalg_lapack_s else chtemp = 'E' end if - call stdlib_shgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & + call stdlib${ii}$_shgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & beta, vl, ldvl, vr, ldvr, work,lwork, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 130 end if ! compute eigenvectors and estimate condition numbers if desired - ! (workspace: stdlib_stgevc: need 6*n - ! stdlib_stgsna: need 2*n*(n+2)+16 if sense = 'v' or 'b', + ! (workspace: stdlib${ii}$_stgevc: need 6*n + ! stdlib${ii}$_stgsna: need 2*n*(n+2)+16 if sense = 'v' or 'b', ! need n otherwise ) if( ilv .or. .not.wantsn ) then if( ilv ) then @@ -62506,16 +62508,16 @@ module stdlib_linalg_lapack_s else chtemp = 'R' end if - call stdlib_stgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,& + call stdlib${ii}$_stgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,& in, work, ierr ) - if( ierr/=0 ) then - info = n + 2 + if( ierr/=0_${ik}$ ) then + info = n + 2_${ik}$ go to 130 end if end if if( .not.wantsn ) then - ! compute eigenvectors (stdlib_stgevc) and estimate condition - ! numbers (stdlib_stgsna). note that the definition of the condition + ! compute eigenvectors (stdlib${ii}$_stgevc) and estimate condition + ! numbers (stdlib${ii}$_stgsna). note that the definition of the condition ! number is not invariant under transformation (u,v) to ! (q*u, z*v), where (u,v) are eigenvectors of the generalized ! schur form (s,t), q and z are orthogonal matrices. in order @@ -62527,35 +62529,35 @@ module stdlib_linalg_lapack_s pair = .false. cycle loop_20 end if - mm = 1 + mm = 1_${ik}$ if( in ) then - info = -2 - else if( p<0 .or. pn ) then + info = -2_${ik}$ + else if( p<0_${ik}$ .or. pm ) then - call stdlib_strtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', n-m, 1,b( m+1, m+p-n+1 ), & + call stdlib${ii}$_strtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', n-m, 1_${ik}$,b( m+1, m+p-n+1 ), & ldb, d( m+1 ), n-m, info ) - if( info>0 ) then - info = 1 + if( info>0_${ik}$ ) then + info = 1_${ik}$ return end if - call stdlib_scopy( n-m, d( m+1 ), 1, y( m+p-n+1 ), 1 ) + call stdlib${ii}$_scopy( n-m, d( m+1 ), 1_${ik}$, y( m+p-n+1 ), 1_${ik}$ ) end if ! set y1 = 0 do i = 1, m + p - n y( i ) = zero end do ! update d1 = d1 - t12*y2 - call stdlib_sgemv( 'NO TRANSPOSE', m, n-m, -one, b( 1, m+p-n+1 ), ldb,y( m+p-n+1 ), 1, & - one, d, 1 ) + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', m, n-m, -one, b( 1_${ik}$, m+p-n+1 ), ldb,y( m+p-n+1 ), 1_${ik}$, & + one, d, 1_${ik}$ ) ! solve triangular system: r11*x = d1 - if( m>0 ) then - call stdlib_strtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', m, 1, a, lda,d, m, info ) + if( m>0_${ik}$ ) then + call stdlib${ii}$_strtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', m, 1_${ik}$, a, lda,d, m, info ) - if( info>0 ) then - info = 2 + if( info>0_${ik}$ ) then + info = 2_${ik}$ return end if ! copy d to x - call stdlib_scopy( m, d, 1, x, 1 ) + call stdlib${ii}$_scopy( m, d, 1_${ik}$, x, 1_${ik}$ ) end if ! backward transformation y = z**t *y - call stdlib_sormrq( 'LEFT', 'TRANSPOSE', p, 1, np,b( max( 1, n-p+1 ), 1 ), ldb, work( & - m+1 ), y,max( 1, p ), work( m+np+1 ), lwork-m-np, info ) - work( 1 ) = m + np + max( lopt, int( work( m+np+1 ),KIND=ilp) ) + call stdlib${ii}$_sormrq( 'LEFT', 'TRANSPOSE', p, 1_${ik}$, np,b( max( 1_${ik}$, n-p+1 ), 1_${ik}$ ), ldb, work( & + m+1 ), y,max( 1_${ik}$, p ), work( m+np+1 ), lwork-m-np, info ) + work( 1_${ik}$ ) = m + np + max( lopt, int( work( m+np+1 ),KIND=${ik}$) ) return - end subroutine stdlib_sggglm + end subroutine stdlib${ii}$_sggglm - pure subroutine stdlib_sgglse( m, n, p, a, lda, b, ldb, c, d, x, work, lwork,info ) + pure subroutine stdlib${ii}$_sgglse( m, n, p, a, lda, b, ldb, c, d, x, work, lwork,info ) !! SGGLSE solves the linear equality-constrained least squares (LSE) !! problem: !! minimize || c - A*x ||_2 subject to B*x = d @@ -62788,8 +62790,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, ldb, lwork, m, n, p + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, p ! Array Arguments real(sp), intent(inout) :: a(lda,*), b(ldb,*), c(*), d(*) real(sp), intent(out) :: work(*), x(*) @@ -62797,46 +62799,46 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: lquery - integer(ilp) :: lopt, lwkmin, lwkopt, mn, nb, nb1, nb2, nb3, nb4, nr + integer(${ik}$) :: lopt, lwkmin, lwkopt, mn, nb, nb1, nb2, nb3, nb4, nr ! Intrinsic Functions intrinsic :: int,max,min ! Executable Statements ! test the input parameters - info = 0 + info = 0_${ik}$ mn = min( m, n ) - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( p<0 .or. p>n .or. pn .or. p0 ) then - call stdlib_strtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', p, 1,b( 1, n-p+1 ), ldb, d,& + if( p>0_${ik}$ ) then + call stdlib${ii}$_strtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', p, 1_${ik}$,b( 1_${ik}$, n-p+1 ), ldb, d,& p, info ) - if( info>0 ) then - info = 1 + if( info>0_${ik}$ ) then + info = 1_${ik}$ return end if ! put the solution in x - call stdlib_scopy( p, d, 1, x( n-p+1 ), 1 ) + call stdlib${ii}$_scopy( p, d, 1_${ik}$, x( n-p+1 ), 1_${ik}$ ) ! update c1 - call stdlib_sgemv( 'NO TRANSPOSE', n-p, p, -one, a( 1, n-p+1 ), lda,d, 1, one, c, 1 & + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', n-p, p, -one, a( 1_${ik}$, n-p+1 ), lda,d, 1_${ik}$, one, c, 1_${ik}$ & ) end if ! solve r11*x1 = c1 for x1 if( n>p ) then - call stdlib_strtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n-p, 1,a, lda, c, n-p, & + call stdlib${ii}$_strtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n-p, 1_${ik}$,a, lda, c, n-p, & info ) - if( info>0 ) then - info = 2 + if( info>0_${ik}$ ) then + info = 2_${ik}$ return end if ! put the solutions in x - call stdlib_scopy( n-p, c, 1, x, 1 ) + call stdlib${ii}$_scopy( n-p, c, 1_${ik}$, x, 1_${ik}$ ) end if ! compute the residual vector: if( m0 )call stdlib_sgemv( 'NO TRANSPOSE', nr, n-m, -one, a( n-p+1, m+1 ),lda, d( & - nr+1 ), 1, one, c( n-p+1 ), 1 ) + if( nr>0_${ik}$ )call stdlib${ii}$_sgemv( 'NO TRANSPOSE', nr, n-m, -one, a( n-p+1, m+1 ),lda, d( & + nr+1 ), 1_${ik}$, one, c( n-p+1 ), 1_${ik}$ ) else nr = p end if - if( nr>0 ) then - call stdlib_strmv( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', nr,a( n-p+1, n-p+1 ), lda, & - d, 1 ) - call stdlib_saxpy( nr, -one, d, 1, c( n-p+1 ), 1 ) + if( nr>0_${ik}$ ) then + call stdlib${ii}$_strmv( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', nr,a( n-p+1, n-p+1 ), lda, & + d, 1_${ik}$ ) + call stdlib${ii}$_saxpy( nr, -one, d, 1_${ik}$, c( n-p+1 ), 1_${ik}$ ) end if ! backward transformation x = q**t*x - call stdlib_sormrq( 'LEFT', 'TRANSPOSE', n, 1, p, b, ldb, work( 1 ), x,n, work( p+mn+1 & + call stdlib${ii}$_sormrq( 'LEFT', 'TRANSPOSE', n, 1_${ik}$, p, b, ldb, work( 1_${ik}$ ), x,n, work( p+mn+1 & ), lwork-p-mn, info ) - work( 1 ) = p + mn + max( lopt, int( work( p+mn+1 ),KIND=ilp) ) + work( 1_${ik}$ ) = p + mn + max( lopt, int( work( p+mn+1 ),KIND=${ik}$) ) return - end subroutine stdlib_sgglse + end subroutine stdlib${ii}$_sgglse - subroutine stdlib_shsein( side, eigsrc, initv, select, n, h, ldh, wr, wi,vl, ldvl, vr, ldvr, & + subroutine stdlib${ii}$_shsein( side, eigsrc, initv, select, n, h, ldh, wr, wi,vl, ldvl, vr, ldvr, & !! SHSEIN uses inverse iteration to find specified right and/or left !! eigenvectors of a real upper Hessenberg matrix H. !! The right eigenvector x and the left eigenvector y of the matrix H @@ -62916,11 +62918,11 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: eigsrc, initv, side - integer(ilp), intent(out) :: info, m - integer(ilp), intent(in) :: ldh, ldvl, ldvr, mm, n + integer(${ik}$), intent(out) :: info, m + integer(${ik}$), intent(in) :: ldh, ldvl, ldvr, mm, n ! Array Arguments logical(lk), intent(inout) :: select(*) - integer(ilp), intent(out) :: ifaill(*), ifailr(*) + integer(${ik}$), intent(out) :: ifaill(*), ifailr(*) real(sp), intent(in) :: h(ldh,*), wi(*) real(sp), intent(inout) :: vl(ldvl,*), vr(ldvr,*), wr(*) real(sp), intent(out) :: work(*) @@ -62928,7 +62930,7 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: bothv, fromqr, leftv, noinit, pair, rightv - integer(ilp) :: i, iinfo, k, kl, kln, kr, ksi, ksr, ldwork + integer(${ik}$) :: i, iinfo, k, kl, kln, kr, ksi, ksr, ldwork real(sp) :: bignum, eps3, hnorm, smlnum, ulp, unfl, wki, wkr ! Intrinsic Functions intrinsic :: abs,max @@ -62941,7 +62943,7 @@ module stdlib_linalg_lapack_s noinit = stdlib_lsame( initv, 'N' ) ! set m to the number of columns required to store the selected ! eigenvectors, and standardize the array select. - m = 0 + m = 0_${ik}$ pair = .false. do k = 1, n if( pair ) then @@ -62949,54 +62951,54 @@ module stdlib_linalg_lapack_s select( k ) = .false. else if( wi( k )==zero ) then - if( select( k ) )m = m + 1 + if( select( k ) )m = m + 1_${ik}$ else pair = .true. if( select( k ) .or. select( k+1 ) ) then select( k ) = .true. - m = m + 2 + m = m + 2_${ik}$ end if end if end if end do - info = 0 + info = 0_${ik}$ if( .not.rightv .and. .not.leftv ) then - info = -1 + info = -1_${ik}$ else if( .not.fromqr .and. .not.stdlib_lsame( eigsrc, 'N' ) ) then - info = -2 + info = -2_${ik}$ else if( .not.noinit .and. .not.stdlib_lsame( initv, 'U' ) ) then - info = -3 - else if( n<0 ) then - info = -5 - else if( ldhzero ) then eps3 = hnorm*ulp @@ -63052,26 +63054,26 @@ module stdlib_linalg_lapack_s wr( k ) = wkr pair = wki/=zero if( pair ) then - ksi = ksr + 1 + ksi = ksr + 1_${ik}$ else ksi = ksr end if if( leftv ) then ! compute left eigenvector. - call stdlib_slaein( .false., noinit, n-kl+1, h( kl, kl ), ldh,wkr, wki, vl( & + call stdlib${ii}$_slaein( .false., noinit, n-kl+1, h( kl, kl ), ldh,wkr, wki, vl( & kl, ksr ), vl( kl, ksi ),work, ldwork, work( n*n+n+1 ), eps3, smlnum,bignum, & iinfo ) - if( iinfo>0 ) then + if( iinfo>0_${ik}$ ) then if( pair ) then - info = info + 2 + info = info + 2_${ik}$ else - info = info + 1 + info = info + 1_${ik}$ end if ifaill( ksr ) = k ifaill( ksi ) = k else - ifaill( ksr ) = 0 - ifaill( ksi ) = 0 + ifaill( ksr ) = 0_${ik}$ + ifaill( ksi ) = 0_${ik}$ end if do i = 1, kl - 1 vl( i, ksr ) = zero @@ -63084,19 +63086,19 @@ module stdlib_linalg_lapack_s end if if( rightv ) then ! compute right eigenvector. - call stdlib_slaein( .true., noinit, kr, h, ldh, wkr, wki,vr( 1, ksr ), vr( 1, & + call stdlib${ii}$_slaein( .true., noinit, kr, h, ldh, wkr, wki,vr( 1_${ik}$, ksr ), vr( 1_${ik}$, & ksi ), work, ldwork,work( n*n+n+1 ), eps3, smlnum, bignum,iinfo ) - if( iinfo>0 ) then + if( iinfo>0_${ik}$ ) then if( pair ) then - info = info + 2 + info = info + 2_${ik}$ else - info = info + 1 + info = info + 1_${ik}$ end if ifailr( ksr ) = k ifailr( ksi ) = k else - ifailr( ksr ) = 0 - ifailr( ksi ) = 0 + ifailr( ksr ) = 0_${ik}$ + ifailr( ksi ) = 0_${ik}$ end if do i = kr + 1, n vr( i, ksr ) = zero @@ -63108,17 +63110,17 @@ module stdlib_linalg_lapack_s end if end if if( pair ) then - ksr = ksr + 2 + ksr = ksr + 2_${ik}$ else - ksr = ksr + 1 + ksr = ksr + 1_${ik}$ end if end if end do loop_120 return - end subroutine stdlib_shsein + end subroutine stdlib${ii}$_shsein - real(sp) function stdlib_sla_porpvgrw( uplo, ncols, a, lda, af, ldaf, work ) + real(sp) function stdlib${ii}$_sla_porpvgrw( uplo, ncols, a, lda, af, ldaf, work ) !! SLA_PORPVGRW computes the reciprocal pivot growth factor !! norm(A)/norm(U). The "max absolute element" norm is used. If this is !! much less than 1, the stability of the LU factorization of the @@ -63130,20 +63132,20 @@ 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) :: ncols, lda, ldaf + integer(${ik}$), intent(in) :: ncols, lda, ldaf ! Array Arguments real(sp), intent(in) :: a(lda,*), af(ldaf,*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(sp) :: amax, umax, rpvgrw logical(lk) :: upper ! Intrinsic Functions intrinsic :: abs,max,min ! Executable Statements upper = stdlib_lsame( 'UPPER', uplo ) - ! stdlib_spotrf will have factored only the ncolsxncols leading minor, so + ! stdlib${ii}$_spotrf will have factored only the ncolsxncols leading minor, so ! we restrict the growth search to that minor and use only the first ! 2*ncols workspace entries. rpvgrw = one @@ -63202,11 +63204,11 @@ module stdlib_linalg_lapack_s end if end do end if - stdlib_sla_porpvgrw = rpvgrw - end function stdlib_sla_porpvgrw + stdlib${ii}$_sla_porpvgrw = rpvgrw + end function stdlib${ii}$_sla_porpvgrw - pure subroutine stdlib_slaed3( k, n, n1, d, q, ldq, rho, dlamda, q2, indx,ctot, w, s, info ) + pure subroutine stdlib${ii}$_slaed3( k, n, n1, d, q, ldq, rho, dlamda, q2, indx,ctot, w, s, info ) !! SLAED3 finds the roots of the secular equation, as defined by the !! values in D, W, and RHO, between 1 and K. It makes the !! appropriate calls to SLAED4 and then updates the eigenvectors by @@ -63224,33 +63226,33 @@ 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) :: k, ldq, n, n1 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k, ldq, n, n1 real(sp), intent(in) :: rho ! Array Arguments - integer(ilp), intent(in) :: ctot(*), indx(*) + integer(${ik}$), intent(in) :: ctot(*), indx(*) real(sp), intent(out) :: d(*), q(ldq,*), s(*) real(sp), intent(inout) :: dlamda(*), w(*) real(sp), intent(in) :: q2(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ii, iq2, j, n12, n2, n23 + integer(${ik}$) :: i, ii, iq2, j, n12, n2, n23 real(sp) :: temp ! Intrinsic Functions intrinsic :: max,sign,sqrt ! Executable Statements ! test the input parameters. - info = 0 - if( k<0 ) then - info = -1 + info = 0_${ik}$ + if( k<0_${ik}$ ) then + info = -1_${ik}$ else if( n1 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( icompq==1 .and. qsizcutpnt .or. n1_${ik}$ ) then + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ + else if( icompq==1_${ik}$ .and. qsizcutpnt .or. nn )return - j2 = j1 + 1 - j3 = j1 + 2 - j4 = j1 + 3 - if( n1==1 .and. n2==1 ) then + j2 = j1 + 1_${ik}$ + j3 = j1 + 2_${ik}$ + j4 = j1 + 3_${ik}$ + if( n1==1_${ik}$ .and. n2==1_${ik}$ ) then ! swap two 1-by-1 blocks. t11 = t( j1, j1 ) t22 = t( j2, j2 ) ! determine the transformation to perform the interchange. - call stdlib_slartg( t( j1, j2 ), t22-t11, cs, sn, temp ) + call stdlib${ii}$_slartg( t( j1, j2 ), t22-t11, cs, sn, temp ) ! apply transformation to the matrix t. - if( j3<=n )call stdlib_srot( n-j1-1, t( j1, j3 ), ldt, t( j2, j3 ), ldt, cs,sn ) + if( j3<=n )call stdlib${ii}$_srot( n-j1-1, t( j1, j3 ), ldt, t( j2, j3 ), ldt, cs,sn ) - call stdlib_srot( j1-1, t( 1, j1 ), 1, t( 1, j2 ), 1, cs, sn ) + call stdlib${ii}$_srot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$, t( 1_${ik}$, j2 ), 1_${ik}$, cs, sn ) t( j1, j1 ) = t22 t( j2, j2 ) = t11 if( wantq ) then ! accumulate transformation in the matrix q. - call stdlib_srot( n, q( 1, j1 ), 1, q( 1, j2 ), 1, cs, sn ) + call stdlib${ii}$_srot( n, q( 1_${ik}$, j1 ), 1_${ik}$, q( 1_${ik}$, j2 ), 1_${ik}$, cs, sn ) end if else ! swapping involves at least one 2-by-2 block. ! copy the diagonal block of order n1+n2 to the local array d ! and compute its norm. nd = n1 + n2 - call stdlib_slacpy( 'FULL', nd, nd, t( j1, j1 ), ldt, d, ldd ) - dnorm = stdlib_slange( 'MAX', nd, nd, d, ldd, work ) + call stdlib${ii}$_slacpy( 'FULL', nd, nd, t( j1, j1 ), ldt, d, ldd ) + dnorm = stdlib${ii}$_slange( 'MAX', nd, nd, d, ldd, work ) ! compute machine-dependent threshold for test for accepting ! swap. - eps = stdlib_slamch( 'P' ) - smlnum = stdlib_slamch( 'S' ) / eps + eps = stdlib${ii}$_slamch( 'P' ) + smlnum = stdlib${ii}$_slamch( 'S' ) / eps thresh = max( ten*eps*dnorm, smlnum ) ! solve t11*x - x*t22 = scale*t12 for x. - call stdlib_slasy2( .false., .false., -1, n1, n2, d, ldd,d( n1+1, n1+1 ), ldd, d( 1,& + call stdlib${ii}$_slasy2( .false., .false., -1_${ik}$, n1, n2, d, ldd,d( n1+1, n1+1 ), ldd, d( 1_${ik}$,& n1+1 ), ldd, scale, x,ldx, xnorm, ierr ) ! swap the adjacent diagonal blocks. - k = n1 + n1 + n2 - 3 + k = n1 + n1 + n2 - 3_${ik}$ go to ( 10, 20, 30 )k 10 continue ! n1 = 1, n2 = 2: generate elementary reflector h so that: ! ( scale, x11, x12 ) h = ( 0, 0, * ) - u( 1 ) = scale - u( 2 ) = x( 1, 1 ) - u( 3 ) = x( 1, 2 ) - call stdlib_slarfg( 3, u( 3 ), u, 1, tau ) - u( 3 ) = one + u( 1_${ik}$ ) = scale + u( 2_${ik}$ ) = x( 1_${ik}$, 1_${ik}$ ) + u( 3_${ik}$ ) = x( 1_${ik}$, 2_${ik}$ ) + call stdlib${ii}$_slarfg( 3_${ik}$, u( 3_${ik}$ ), u, 1_${ik}$, tau ) + u( 3_${ik}$ ) = one t11 = t( j1, j1 ) ! perform swap provisionally on diagonal block in d. - call stdlib_slarfx( 'L', 3, 3, u, tau, d, ldd, work ) - call stdlib_slarfx( 'R', 3, 3, u, tau, d, ldd, work ) + call stdlib${ii}$_slarfx( 'L', 3_${ik}$, 3_${ik}$, u, tau, d, ldd, work ) + call stdlib${ii}$_slarfx( 'R', 3_${ik}$, 3_${ik}$, u, tau, d, ldd, work ) ! test whether to reject swap. - if( max( abs( d( 3, 1 ) ), abs( d( 3, 2 ) ), abs( d( 3,3 )-t11 ) )>thresh )go to & - 50 + if( max( abs( d( 3, 1 ) ), abs( d( 3, 2 ) ), abs( d( 3,3 )-t11 ) )>thresh )go to 50 + ! accept swap: apply transformation to the entire matrix t. - call stdlib_slarfx( 'L', 3, n-j1+1, u, tau, t( j1, j1 ), ldt, work ) - call stdlib_slarfx( 'R', j2, 3, u, tau, t( 1, j1 ), ldt, work ) + call stdlib${ii}$_slarfx( 'L', 3_${ik}$, n-j1+1, u, tau, t( j1, j1 ), ldt, work ) + call stdlib${ii}$_slarfx( 'R', j2, 3_${ik}$, u, tau, t( 1_${ik}$, j1 ), ldt, work ) t( j3, j1 ) = zero t( j3, j2 ) = zero t( j3, j3 ) = t11 if( wantq ) then ! accumulate transformation in the matrix q. - call stdlib_slarfx( 'R', n, 3, u, tau, q( 1, j1 ), ldq, work ) + call stdlib${ii}$_slarfx( 'R', n, 3_${ik}$, u, tau, q( 1_${ik}$, j1 ), ldq, work ) end if go to 40 20 continue @@ -63581,27 +63583,27 @@ module stdlib_linalg_lapack_s ! h ( -x11 ) = ( * ) ! ( -x21 ) = ( 0 ) ! ( scale ) = ( 0 ) - u( 1 ) = -x( 1, 1 ) - u( 2 ) = -x( 2, 1 ) - u( 3 ) = scale - call stdlib_slarfg( 3, u( 1 ), u( 2 ), 1, tau ) - u( 1 ) = one + u( 1_${ik}$ ) = -x( 1_${ik}$, 1_${ik}$ ) + u( 2_${ik}$ ) = -x( 2_${ik}$, 1_${ik}$ ) + u( 3_${ik}$ ) = scale + call stdlib${ii}$_slarfg( 3_${ik}$, u( 1_${ik}$ ), u( 2_${ik}$ ), 1_${ik}$, tau ) + u( 1_${ik}$ ) = one t33 = t( j3, j3 ) ! perform swap provisionally on diagonal block in d. - call stdlib_slarfx( 'L', 3, 3, u, tau, d, ldd, work ) - call stdlib_slarfx( 'R', 3, 3, u, tau, d, ldd, work ) + call stdlib${ii}$_slarfx( 'L', 3_${ik}$, 3_${ik}$, u, tau, d, ldd, work ) + call stdlib${ii}$_slarfx( 'R', 3_${ik}$, 3_${ik}$, u, tau, d, ldd, work ) ! test whether to reject swap. - if( max( abs( d( 2, 1 ) ), abs( d( 3, 1 ) ), abs( d( 1,1 )-t33 ) )>thresh )go to & - 50 + if( max( abs( d( 2, 1 ) ), abs( d( 3, 1 ) ), abs( d( 1,1 )-t33 ) )>thresh )go to 50 + ! accept swap: apply transformation to the entire matrix t. - call stdlib_slarfx( 'R', j3, 3, u, tau, t( 1, j1 ), ldt, work ) - call stdlib_slarfx( 'L', 3, n-j1, u, tau, t( j1, j2 ), ldt, work ) + call stdlib${ii}$_slarfx( 'R', j3, 3_${ik}$, u, tau, t( 1_${ik}$, j1 ), ldt, work ) + call stdlib${ii}$_slarfx( 'L', 3_${ik}$, n-j1, u, tau, t( j1, j2 ), ldt, work ) t( j1, j1 ) = t33 t( j2, j1 ) = zero t( j3, j1 ) = zero if( wantq ) then ! accumulate transformation in the matrix q. - call stdlib_slarfx( 'R', n, 3, u, tau, q( 1, j1 ), ldq, work ) + call stdlib${ii}$_slarfx( 'R', n, 3_${ik}$, u, tau, q( 1_${ik}$, j1 ), ldq, work ) end if go to 40 30 continue @@ -63611,68 +63613,69 @@ module stdlib_linalg_lapack_s ! ( -x21 -x22 ) ( 0 * ) ! ( scale 0 ) ( 0 0 ) ! ( 0 scale ) ( 0 0 ) - u1( 1 ) = -x( 1, 1 ) - u1( 2 ) = -x( 2, 1 ) - u1( 3 ) = scale - call stdlib_slarfg( 3, u1( 1 ), u1( 2 ), 1, tau1 ) - u1( 1 ) = one - temp = -tau1*( x( 1, 2 )+u1( 2 )*x( 2, 2 ) ) - u2( 1 ) = -temp*u1( 2 ) - x( 2, 2 ) - u2( 2 ) = -temp*u1( 3 ) - u2( 3 ) = scale - call stdlib_slarfg( 3, u2( 1 ), u2( 2 ), 1, tau2 ) - u2( 1 ) = one + u1( 1_${ik}$ ) = -x( 1_${ik}$, 1_${ik}$ ) + u1( 2_${ik}$ ) = -x( 2_${ik}$, 1_${ik}$ ) + u1( 3_${ik}$ ) = scale + call stdlib${ii}$_slarfg( 3_${ik}$, u1( 1_${ik}$ ), u1( 2_${ik}$ ), 1_${ik}$, tau1 ) + u1( 1_${ik}$ ) = one + temp = -tau1*( x( 1_${ik}$, 2_${ik}$ )+u1( 2_${ik}$ )*x( 2_${ik}$, 2_${ik}$ ) ) + u2( 1_${ik}$ ) = -temp*u1( 2_${ik}$ ) - x( 2_${ik}$, 2_${ik}$ ) + u2( 2_${ik}$ ) = -temp*u1( 3_${ik}$ ) + u2( 3_${ik}$ ) = scale + call stdlib${ii}$_slarfg( 3_${ik}$, u2( 1_${ik}$ ), u2( 2_${ik}$ ), 1_${ik}$, tau2 ) + u2( 1_${ik}$ ) = one ! perform swap provisionally on diagonal block in d. - call stdlib_slarfx( 'L', 3, 4, u1, tau1, d, ldd, work ) - call stdlib_slarfx( 'R', 4, 3, u1, tau1, d, ldd, work ) - call stdlib_slarfx( 'L', 3, 4, u2, tau2, d( 2, 1 ), ldd, work ) - call stdlib_slarfx( 'R', 4, 3, u2, tau2, d( 1, 2 ), ldd, work ) + call stdlib${ii}$_slarfx( 'L', 3_${ik}$, 4_${ik}$, u1, tau1, d, ldd, work ) + call stdlib${ii}$_slarfx( 'R', 4_${ik}$, 3_${ik}$, u1, tau1, d, ldd, work ) + call stdlib${ii}$_slarfx( 'L', 3_${ik}$, 4_${ik}$, u2, tau2, d( 2_${ik}$, 1_${ik}$ ), ldd, work ) + call stdlib${ii}$_slarfx( 'R', 4_${ik}$, 3_${ik}$, u2, tau2, d( 1_${ik}$, 2_${ik}$ ), ldd, work ) ! test whether to reject swap. - if( max( abs( d( 3, 1 ) ), abs( d( 3, 2 ) ), abs( d( 4, 1 ) ),abs( d( 4, 2 ) ) )& + if( max( abs( d( 3_${ik}$, 1_${ik}$ ) ), abs( d( 3_${ik}$, 2_${ik}$ ) ), abs( d( 4_${ik}$, 1_${ik}$ ) ),abs( d( 4_${ik}$, 2_${ik}$ ) ) )& >thresh )go to 50 ! accept swap: apply transformation to the entire matrix t. - call stdlib_slarfx( 'L', 3, n-j1+1, u1, tau1, t( j1, j1 ), ldt, work ) - call stdlib_slarfx( 'R', j4, 3, u1, tau1, t( 1, j1 ), ldt, work ) - call stdlib_slarfx( 'L', 3, n-j1+1, u2, tau2, t( j2, j1 ), ldt, work ) - call stdlib_slarfx( 'R', j4, 3, u2, tau2, t( 1, j2 ), ldt, work ) + call stdlib${ii}$_slarfx( 'L', 3_${ik}$, n-j1+1, u1, tau1, t( j1, j1 ), ldt, work ) + call stdlib${ii}$_slarfx( 'R', j4, 3_${ik}$, u1, tau1, t( 1_${ik}$, j1 ), ldt, work ) + call stdlib${ii}$_slarfx( 'L', 3_${ik}$, n-j1+1, u2, tau2, t( j2, j1 ), ldt, work ) + call stdlib${ii}$_slarfx( 'R', j4, 3_${ik}$, u2, tau2, t( 1_${ik}$, j2 ), ldt, work ) t( j3, j1 ) = zero t( j3, j2 ) = zero t( j4, j1 ) = zero t( j4, j2 ) = zero if( wantq ) then ! accumulate transformation in the matrix q. - call stdlib_slarfx( 'R', n, 3, u1, tau1, q( 1, j1 ), ldq, work ) - call stdlib_slarfx( 'R', n, 3, u2, tau2, q( 1, j2 ), ldq, work ) + call stdlib${ii}$_slarfx( 'R', n, 3_${ik}$, u1, tau1, q( 1_${ik}$, j1 ), ldq, work ) + call stdlib${ii}$_slarfx( 'R', n, 3_${ik}$, u2, tau2, q( 1_${ik}$, j2 ), ldq, work ) end if 40 continue - if( n2==2 ) then + if( n2==2_${ik}$ ) then ! standardize new 2-by-2 block t11 - call stdlib_slanv2( t( j1, j1 ), t( j1, j2 ), t( j2, j1 ),t( j2, j2 ), wr1, wi1, & + call stdlib${ii}$_slanv2( t( j1, j1 ), t( j1, j2 ), t( j2, j1 ),t( j2, j2 ), wr1, wi1, & wr2, wi2, cs, sn ) - call stdlib_srot( n-j1-1, t( j1, j1+2 ), ldt, t( j2, j1+2 ), ldt,cs, sn ) - call stdlib_srot( j1-1, t( 1, j1 ), 1, t( 1, j2 ), 1, cs, sn ) - if( wantq )call stdlib_srot( n, q( 1, j1 ), 1, q( 1, j2 ), 1, cs, sn ) + call stdlib${ii}$_srot( n-j1-1, t( j1, j1+2 ), ldt, t( j2, j1+2 ), ldt,cs, sn ) + call stdlib${ii}$_srot( j1-1, t( 1_${ik}$, j1 ), 1_${ik}$, t( 1_${ik}$, j2 ), 1_${ik}$, cs, sn ) + if( wantq )call stdlib${ii}$_srot( n, q( 1_${ik}$, j1 ), 1_${ik}$, q( 1_${ik}$, j2 ), 1_${ik}$, cs, sn ) end if - if( n1==2 ) then + if( n1==2_${ik}$ ) then ! standardize new 2-by-2 block t22 j3 = j1 + n2 - j4 = j3 + 1 - call stdlib_slanv2( t( j3, j3 ), t( j3, j4 ), t( j4, j3 ),t( j4, j4 ), wr1, wi1, & + j4 = j3 + 1_${ik}$ + call stdlib${ii}$_slanv2( t( j3, j3 ), t( j3, j4 ), t( j4, j3 ),t( j4, j4 ), wr1, wi1, & wr2, wi2, cs, sn ) - if( j3+2<=n )call stdlib_srot( n-j3-1, t( j3, j3+2 ), ldt, t( j4, j3+2 ),ldt, cs,& + if( j3+2<=n )call stdlib${ii}$_srot( n-j3-1, t( j3, j3+2 ), ldt, t( j4, j3+2 ),ldt, cs,& sn ) - call stdlib_srot( j3-1, t( 1, j3 ), 1, t( 1, j4 ), 1, cs, sn ) - if( wantq )call stdlib_srot( n, q( 1, j3 ), 1, q( 1, j4 ), 1, cs, sn ) + call stdlib${ii}$_srot( j3-1, t( 1_${ik}$, j3 ), 1_${ik}$, t( 1_${ik}$, j4 ), 1_${ik}$, cs, sn ) + if( wantq )call stdlib${ii}$_srot( n, q( 1_${ik}$, j3 ), 1_${ik}$, q( 1_${ik}$, j4 ), 1_${ik}$, cs, sn ) end if end if return ! exit with info = 1 if swap was rejected. - 50 info = 1 + 50 continue + info = 1_${ik}$ return - end subroutine stdlib_slaexc + end subroutine stdlib${ii}$_slaexc - pure subroutine stdlib_slahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, & + pure subroutine stdlib${ii}$_slahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, & !! SLAHQR is an auxiliary routine called by SHSEQR to update the !! eigenvalues and Schur decomposition already computed by SHSEQR, by !! dealing with the Hessenberg submatrix in rows and columns ILO to @@ -63682,8 +63685,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) :: ihi, ihiz, ilo, iloz, ldh, ldz, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ihiz, ilo, iloz, ldh, ldz, n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt, wantz ! Array Arguments real(sp), intent(inout) :: h(ldh,*), z(ldz,*) @@ -63692,20 +63695,20 @@ module stdlib_linalg_lapack_s ! Parameters real(sp), parameter :: dat1 = 3.0_sp/4.0_sp real(sp), parameter :: dat2 = -0.4375_sp - integer(ilp), parameter :: kexsh = 10 + integer(${ik}$), parameter :: kexsh = 10_${ik}$ ! Local Scalars real(sp) :: aa, ab, ba, bb, cs, det, h11, h12, h21, h21s, h22, rt1i, rt1r, rt2i, rt2r, & rtdisc, s, safmax, safmin, smlnum, sn, sum, t1, t2, t3, tr, tst, ulp, v2, v3 - integer(ilp) :: i, i1, i2, its, itmax, j, k, l, m, nh, nr, nz, kdefl + integer(${ik}$) :: i, i1, i2, its, itmax, j, k, l, m, nh, nr, nz, kdefl ! Local Arrays - real(sp) :: v(3) + real(sp) :: v(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,min,real,sqrt ! Executable Statements - info = 0 + info = 0_${ik}$ ! quick return if possible if( n==0 )return if( ilo==ihi ) then @@ -63719,25 +63722,25 @@ module stdlib_linalg_lapack_s h( j+3, j ) = zero end do if( ilo<=ihi-2 )h( ihi, ihi-2 ) = zero - nh = ihi - ilo + 1 - nz = ihiz - iloz + 1 + nh = ihi - ilo + 1_${ik}$ + nz = ihiz - iloz + 1_${ik}$ ! set machine-dependent constants for the stopping criterion. - safmin = stdlib_slamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) safmax = one / safmin - call stdlib_slabad( safmin, safmax ) - ulp = stdlib_slamch( 'PRECISION' ) + call stdlib${ii}$_slabad( safmin, safmax ) + ulp = stdlib${ii}$_slamch( 'PRECISION' ) smlnum = safmin*( real( nh,KIND=sp) / ulp ) ! i1 and i2 are the indices of the first row and last column of h ! to which transformations must be applied. if eigenvalues only are ! being computed, i1 and i2 are set inside the main loop. if( wantt ) then - i1 = 1 + i1 = 1_${ik}$ i2 = n end if ! itmax is the total number of qr iterations allowed. - itmax = 30 * max( 10, nh ) + itmax = 30_${ik}$ * max( 10_${ik}$, nh ) ! kdefl counts the number of iterations since a deflation - kdefl = 0 + kdefl = 0_${ik}$ ! the main loop begins here. i is the loop index and decreases from ! ihi to ilo in steps of 1 or 2. each iteration of the loop works ! with the active submatrix in rows and columns l to i. @@ -63780,7 +63783,7 @@ module stdlib_linalg_lapack_s end if ! exit from loop if a submatrix of order 1 or 2 has split off. if( l>=i-1 )go to 150 - kdefl = kdefl + 1 + kdefl = kdefl + 1_${ik}$ ! now the active submatrix is in rows and columns l to i. if ! eigenvalues only are being computed, only the active submatrix ! need be transformed. @@ -63788,14 +63791,14 @@ module stdlib_linalg_lapack_s i1 = l i2 = i end if - if( mod(kdefl,2*kexsh)==0 ) then + if( mod(kdefl,2_${ik}$*kexsh)==0_${ik}$ ) then ! exceptional shift. s = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) ) h11 = dat1*s + h( i, i ) h12 = dat2*s h21 = s h22 = h11 - else if( mod(kdefl,kexsh)==0 ) then + else if( mod(kdefl,kexsh)==0_${ik}$ ) then ! exceptional shift. s = abs( h( l+1, l ) ) + abs( h( l+2, l+1 ) ) h11 = dat1*s + h( l, l ) @@ -63854,16 +63857,16 @@ module stdlib_linalg_lapack_s h21s = h( m+1, m ) s = abs( h( m, m )-rt2r ) + abs( rt2i ) + abs( h21s ) h21s = h( m+1, m ) / s - v( 1 ) = h21s*h( m, m+1 ) + ( h( m, m )-rt1r )*( ( h( m, m )-rt2r ) / s ) - & + v( 1_${ik}$ ) = h21s*h( m, m+1 ) + ( h( m, m )-rt1r )*( ( h( m, m )-rt2r ) / s ) - & rt1i*( rt2i / s ) - v( 2 ) = h21s*( h( m, m )+h( m+1, m+1 )-rt1r-rt2r ) - v( 3 ) = h21s*h( m+2, m+1 ) - s = abs( v( 1 ) ) + abs( v( 2 ) ) + abs( v( 3 ) ) - v( 1 ) = v( 1 ) / s - v( 2 ) = v( 2 ) / s - v( 3 ) = v( 3 ) / s + v( 2_${ik}$ ) = h21s*( h( m, m )+h( m+1, m+1 )-rt1r-rt2r ) + v( 3_${ik}$ ) = h21s*h( m+2, m+1 ) + s = abs( v( 1_${ik}$ ) ) + abs( v( 2_${ik}$ ) ) + abs( v( 3_${ik}$ ) ) + v( 1_${ik}$ ) = v( 1_${ik}$ ) / s + v( 2_${ik}$ ) = v( 2_${ik}$ ) / s + v( 3_${ik}$ ) = v( 3_${ik}$ ) / s if( m==l )go to 60 - if( abs( h( m, m-1 ) )*( abs( v( 2 ) )+abs( v( 3 ) ) )<=ulp*abs( v( 1 ) )*( abs( & + if( abs( h( m, m-1 ) )*( abs( v( 2_${ik}$ ) )+abs( v( 3_${ik}$ ) ) )<=ulp*abs( v( 1_${ik}$ ) )*( abs( & h( m-1, m-1 ) )+abs( h( m,m ) )+abs( h( m+1, m+1 ) ) ) )go to 60 end do 60 continue @@ -63876,11 +63879,11 @@ module stdlib_linalg_lapack_s ! restore the hessenberg form in the (k-1)th column, and thus ! chases the bulge one step toward the bottom of the active ! submatrix. nr is the order of g. - nr = min( 3, i-k+1 ) - if( k>m )call stdlib_scopy( nr, h( k, k-1 ), 1, v, 1 ) - call stdlib_slarfg( nr, v( 1 ), v( 2 ), 1, t1 ) + nr = min( 3_${ik}$, i-k+1 ) + if( k>m )call stdlib${ii}$_scopy( nr, h( k, k-1 ), 1_${ik}$, v, 1_${ik}$ ) + call stdlib${ii}$_slarfg( nr, v( 1_${ik}$ ), v( 2_${ik}$ ), 1_${ik}$, t1 ) if( k>m ) then - h( k, k-1 ) = v( 1 ) + h( k, k-1 ) = v( 1_${ik}$ ) h( k+1, k-1 ) = zero if( kl ) then @@ -63890,10 +63893,10 @@ module stdlib_linalg_lapack_s ! . underflow. ==== h( k, k-1 ) = h( k, k-1 )*( one-t1 ) end if - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = t1*v2 - if( nr==3 ) then - v3 = v( 3 ) + if( nr==3_${ik}$ ) then + v3 = v( 3_${ik}$ ) t3 = t1*v3 ! apply g from the left to transform the rows of the matrix ! in columns k to i2. @@ -63920,7 +63923,7 @@ module stdlib_linalg_lapack_s z( j, k+2 ) = z( j, k+2 ) - sum*t3 end do end if - else if( nr==2 ) then + else if( nr==2_${ik}$ ) then ! apply g from the left to transform the rows of the matrix ! in columns k to i2. do j = k, i2 @@ -63958,30 +63961,30 @@ module stdlib_linalg_lapack_s ! h(i-1,i-2) is negligible: a pair of eigenvalues have converged. ! transform the 2-by-2 submatrix to standard schur form, ! and compute and store the eigenvalues. - call stdlib_slanv2( h( i-1, i-1 ), h( i-1, i ), h( i, i-1 ),h( i, i ), wr( i-1 ), & + call stdlib${ii}$_slanv2( h( i-1, i-1 ), h( i-1, i ), h( i, i-1 ),h( i, i ), wr( i-1 ), & wi( i-1 ), wr( i ), wi( i ),cs, sn ) if( wantt ) then ! apply the transformation to the rest of h. - if( i2>i )call stdlib_srot( i2-i, h( i-1, i+1 ), ldh, h( i, i+1 ), ldh,cs, sn ) + if( i2>i )call stdlib${ii}$_srot( i2-i, h( i-1, i+1 ), ldh, h( i, i+1 ), ldh,cs, sn ) - call stdlib_srot( i-i1-1, h( i1, i-1 ), 1, h( i1, i ), 1, cs, sn ) + call stdlib${ii}$_srot( i-i1-1, h( i1, i-1 ), 1_${ik}$, h( i1, i ), 1_${ik}$, cs, sn ) end if if( wantz ) then ! apply the transformation to z. - call stdlib_srot( nz, z( iloz, i-1 ), 1, z( iloz, i ), 1, cs, sn ) + call stdlib${ii}$_srot( nz, z( iloz, i-1 ), 1_${ik}$, z( iloz, i ), 1_${ik}$, cs, sn ) end if end if ! reset deflation counter - kdefl = 0 + kdefl = 0_${ik}$ ! return to start of the main loop with new value of i. - i = l - 1 + i = l - 1_${ik}$ go to 20 160 continue return - end subroutine stdlib_slahqr + end subroutine stdlib${ii}$_slahqr - pure subroutine stdlib_slasd2( nl, nr, sqre, k, d, z, alpha, beta, u, ldu, vt,ldvt, dsigma, & + pure subroutine stdlib${ii}$_slasd2( nl, nr, sqre, k, d, z, alpha, beta, u, ldu, vt,ldvt, dsigma, & !! SLASD2 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 @@ -63994,58 +63997,58 @@ 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, k - integer(ilp), intent(in) :: ldu, ldu2, ldvt, ldvt2, nl, nr, sqre + integer(${ik}$), intent(out) :: info, k + integer(${ik}$), intent(in) :: ldu, ldu2, ldvt, ldvt2, nl, nr, sqre real(sp), intent(in) :: alpha, beta ! Array Arguments - integer(ilp), intent(out) :: coltyp(*), idx(*), idxc(*), idxp(*) - integer(ilp), intent(inout) :: idxq(*) + integer(${ik}$), intent(out) :: coltyp(*), idx(*), idxc(*), idxp(*) + integer(${ik}$), intent(inout) :: idxq(*) real(sp), intent(inout) :: d(*), u(ldu,*), vt(ldvt,*) real(sp), intent(out) :: dsigma(*), u2(ldu2,*), vt2(ldvt2,*), z(*) ! ===================================================================== ! Local Arrays - integer(ilp) :: ctot(4), psm(4) + integer(${ik}$) :: ctot(4_${ik}$), psm(4_${ik}$) ! Local Scalars - integer(ilp) :: ct, i, idxi, idxj, idxjp, j, jp, jprev, k2, m, n, nlp1, nlp2 + integer(${ik}$) :: ct, i, idxi, idxj, idxjp, j, jp, jprev, k2, m, n, nlp1, nlp2 real(sp) :: c, eps, hlftol, s, tau, tol, z1 ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements ! test the input parameters. - info = 0 - if( nl<1 ) then - info = -1 - else if( nr<1 ) then - info = -2 - else if( ( sqre/=1 ) .and. ( sqre/=0 ) ) then - info = -3 - end if - n = nl + nr + 1 + info = 0_${ik}$ + if( nl<1_${ik}$ ) then + info = -1_${ik}$ + else if( nr<1_${ik}$ ) then + info = -2_${ik}$ + else if( ( sqre/=1_${ik}$ ) .and. ( sqre/=0_${ik}$ ) ) then + info = -3_${ik}$ + end if + n = nl + nr + 1_${ik}$ m = n + sqre if( ldun )go to 110 if( abs( z( j ) )<=tol ) then ! deflate due to small z component. - k2 = k2 - 1 + k2 = k2 - 1_${ik}$ idxp( k2 ) = j - coltyp( j ) = 4 + coltyp( j ) = 4_${ik}$ else ! check if singular values are close enough to allow deflation. if( abs( d( j )-d( jprev ) )<=tol ) then @@ -64127,33 +64130,33 @@ module stdlib_linalg_lapack_s c = z( j ) ! find sqrt(a**2+b**2) without overflow or ! destructive underflow. - tau = stdlib_slapy2( c, s ) + tau = stdlib${ii}$_slapy2( c, s ) c = c / tau s = -s / tau z( j ) = tau z( jprev ) = zero ! apply back the givens rotation to the left and right ! singular vector matrices. - idxjp = idxq( idx( jprev )+1 ) - idxj = idxq( idx( j )+1 ) + 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 - call stdlib_srot( n, u( 1, idxjp ), 1, u( 1, idxj ), 1, c, s ) - call stdlib_srot( m, vt( idxjp, 1 ), ldvt, vt( idxj, 1 ), ldvt, c,s ) + call stdlib${ii}$_srot( n, u( 1_${ik}$, idxjp ), 1_${ik}$, u( 1_${ik}$, idxj ), 1_${ik}$, c, s ) + call stdlib${ii}$_srot( m, vt( idxjp, 1_${ik}$ ), ldvt, vt( idxj, 1_${ik}$ ), ldvt, c,s ) if( coltyp( j )/=coltyp( jprev ) ) then - coltyp( j ) = 3 + coltyp( j ) = 3_${ik}$ end if - coltyp( jprev ) = 4 - k2 = k2 - 1 + coltyp( jprev ) = 4_${ik}$ + k2 = k2 - 1_${ik}$ idxp( k2 ) = jprev jprev = j else - k = k + 1 - u2( k, 1 ) = z( jprev ) + k = k + 1_${ik}$ + u2( k, 1_${ik}$ ) = z( jprev ) dsigma( k ) = d( jprev ) idxp( k ) = jprev jprev = j @@ -64162,8 +64165,8 @@ module stdlib_linalg_lapack_s go to 100 110 continue ! record the last singular value. - k = k + 1 - u2( k, 1 ) = z( jprev ) + k = k + 1_${ik}$ + u2( k, 1_${ik}$ ) = z( jprev ) dsigma( k ) = d( jprev ) idxp( k ) = jprev 120 continue @@ -64172,17 +64175,17 @@ module stdlib_linalg_lapack_s ! four groups of uniform structure (although one or more of these ! groups may be empty). do j = 1, 4 - ctot( j ) = 0 + ctot( j ) = 0_${ik}$ end do do j = 2, n ct = coltyp( j ) - ctot( ct ) = ctot( ct ) + 1 + ctot( ct ) = ctot( ct ) + 1_${ik}$ end do ! psm(*) = position in submatrix (of types 1 through 4) - psm( 1 ) = 2 - psm( 2 ) = 2 + ctot( 1 ) - psm( 3 ) = psm( 2 ) + ctot( 2 ) - psm( 4 ) = psm( 3 ) + ctot( 3 ) + psm( 1_${ik}$ ) = 2_${ik}$ + psm( 2_${ik}$ ) = 2_${ik}$ + ctot( 1_${ik}$ ) + psm( 3_${ik}$ ) = psm( 2_${ik}$ ) + ctot( 2_${ik}$ ) + psm( 4_${ik}$ ) = psm( 3_${ik}$ ) + ctot( 3_${ik}$ ) ! fill out the idxc array so that the permutation which it induces ! will place all type-1 columns first, all type-2 columns next, ! then all type-3's, and finally all type-4's, starting from the @@ -64191,7 +64194,7 @@ module stdlib_linalg_lapack_s jp = idxp( j ) ct = coltyp( jp ) idxc( psm( ct ) ) = j - psm( ct ) = psm( ct ) + 1 + psm( ct ) = psm( ct ) + 1_${ik}$ end do ! sort the singular values and corresponding singular vectors into ! dsigma, u2, and vt2 respectively. the singular values/vectors @@ -64202,71 +64205,71 @@ module stdlib_linalg_lapack_s do j = 2, n jp = idxp( j ) dsigma( j ) = d( jp ) - idxj = idxq( idx( idxp( idxc( j ) ) )+1 ) + idxj = idxq( idx( idxp( idxc( j ) ) )+1_${ik}$ ) if( idxj<=nlp1 ) then - idxj = idxj - 1 + idxj = idxj - 1_${ik}$ end if - call stdlib_scopy( n, u( 1, idxj ), 1, u2( 1, j ), 1 ) - call stdlib_scopy( m, vt( idxj, 1 ), ldvt, vt2( j, 1 ), ldvt2 ) + call stdlib${ii}$_scopy( n, u( 1_${ik}$, idxj ), 1_${ik}$, u2( 1_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_scopy( m, vt( idxj, 1_${ik}$ ), ldvt, vt2( j, 1_${ik}$ ), ldvt2 ) end do ! determine dsigma(1), dsigma(2) and z(1) - 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 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 ! move the rest of the updating row to z. - call stdlib_scopy( k-1, u2( 2, 1 ), 1, z( 2 ), 1 ) + call stdlib${ii}$_scopy( k-1, u2( 2_${ik}$, 1_${ik}$ ), 1_${ik}$, z( 2_${ik}$ ), 1_${ik}$ ) ! determine the first column of u2, the first row of vt2 and the ! last row of vt. - call stdlib_slaset( 'A', n, 1, zero, zero, u2, ldu2 ) - u2( nlp1, 1 ) = one + call stdlib${ii}$_slaset( 'A', n, 1_${ik}$, zero, zero, u2, ldu2 ) + u2( nlp1, 1_${ik}$ ) = one if( m>n ) then do i = 1, nlp1 vt( m, i ) = -s*vt( nlp1, i ) - vt2( 1, i ) = c*vt( nlp1, i ) + vt2( 1_${ik}$, i ) = c*vt( nlp1, i ) end do do i = nlp2, m - vt2( 1, i ) = s*vt( m, i ) + vt2( 1_${ik}$, i ) = s*vt( m, i ) vt( m, i ) = c*vt( m, i ) end do else - call stdlib_scopy( m, vt( nlp1, 1 ), ldvt, vt2( 1, 1 ), ldvt2 ) + call stdlib${ii}$_scopy( m, vt( nlp1, 1_${ik}$ ), ldvt, vt2( 1_${ik}$, 1_${ik}$ ), ldvt2 ) end if if( m>n ) then - call stdlib_scopy( m, vt( m, 1 ), ldvt, vt2( m, 1 ), ldvt2 ) + call stdlib${ii}$_scopy( m, vt( m, 1_${ik}$ ), ldvt, vt2( m, 1_${ik}$ ), ldvt2 ) end if ! the deflated singular values and their corresponding vectors go ! into the back of d, u, and v respectively. if( n>k ) then - call stdlib_scopy( n-k, dsigma( k+1 ), 1, d( k+1 ), 1 ) - call stdlib_slacpy( 'A', n, n-k, u2( 1, k+1 ), ldu2, u( 1, k+1 ),ldu ) - call stdlib_slacpy( 'A', n-k, m, vt2( k+1, 1 ), ldvt2, vt( k+1, 1 ),ldvt ) + call stdlib${ii}$_scopy( n-k, dsigma( k+1 ), 1_${ik}$, d( k+1 ), 1_${ik}$ ) + call stdlib${ii}$_slacpy( 'A', n, n-k, u2( 1_${ik}$, k+1 ), ldu2, u( 1_${ik}$, k+1 ),ldu ) + call stdlib${ii}$_slacpy( 'A', n-k, m, vt2( k+1, 1_${ik}$ ), ldvt2, vt( k+1, 1_${ik}$ ),ldvt ) end if - ! copy ctot into coltyp for referencing in stdlib_slasd3. + ! copy ctot into coltyp for referencing in stdlib${ii}$_slasd3. do j = 1, 4 coltyp( j ) = ctot( j ) end do return - end subroutine stdlib_slasd2 + end subroutine stdlib${ii}$_slasd2 - pure subroutine stdlib_slaswlq( m, n, mb, nb, a, lda, t, ldt, work, lwork,info) + pure subroutine stdlib${ii}$_slaswlq( m, n, mb, nb, a, lda, t, ldt, work, lwork,info) !! SLASWLQ computes a blocked Tall-Skinny LQ factorization of !! a real M-by-N matrix A for M <= N: !! A = ( L 0 ) * Q, @@ -64281,76 +64284,76 @@ 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, m, n, mb, nb, lwork, ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, mb, nb, lwork, ldt ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: work(*), t(ldt,*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, ii, kk, ctr + integer(${ik}$) :: i, ii, kk, ctr ! External Subroutines intrinsic :: max,min,mod ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 .or. nm .and. m>0 )) then - info = -3 - else if( nb<=0 ) then - info = -4 - else if( ldam .and. m>0_${ik}$ )) then + info = -3_${ik}$ + else if( nb<=0_${ik}$ ) then + info = -4_${ik}$ + else if( lda=n).or.(nb<=m).or.(nb>=n)) then - call stdlib_sgelqt( m, n, mb, a, lda, t, ldt, work, info) + call stdlib${ii}$_sgelqt( m, n, mb, a, lda, t, ldt, work, info) return end if kk = mod((n-m),(nb-m)) ii=n-kk+1 ! compute the lq factorization of the first block a(1:m,1:nb) - call stdlib_sgelqt( m, nb, mb, a(1,1), lda, t, ldt, work, info) - ctr = 1 + call stdlib${ii}$_sgelqt( m, nb, mb, a(1_${ik}$,1_${ik}$), lda, t, ldt, work, info) + ctr = 1_${ik}$ do i = nb+1, ii-nb+m , (nb-m) ! compute the qr factorization of the current block a(1:m,i:i+nb-m) - call stdlib_stplqt( m, nb-m, 0, mb, a(1,1), lda, a( 1, i ),lda, t(1, ctr * m + 1),& + call stdlib${ii}$_stplqt( m, nb-m, 0_${ik}$, mb, a(1_${ik}$,1_${ik}$), lda, a( 1_${ik}$, i ),lda, t(1_${ik}$, ctr * m + 1_${ik}$),& ldt, work, info ) - ctr = ctr + 1 + ctr = ctr + 1_${ik}$ end do ! compute the qr factorization of the last block a(1:m,ii:n) if (ii<=n) then - call stdlib_stplqt( m, kk, 0, mb, a(1,1), lda, a( 1, ii ),lda, t(1, ctr * m + 1), & + call stdlib${ii}$_stplqt( m, kk, 0_${ik}$, mb, a(1_${ik}$,1_${ik}$), lda, a( 1_${ik}$, ii ),lda, t(1_${ik}$, ctr * m + 1_${ik}$), & ldt,work, info ) end if - work( 1 ) = m * mb + work( 1_${ik}$ ) = m * mb return - end subroutine stdlib_slaswlq + end subroutine stdlib${ii}$_slaswlq - pure subroutine stdlib_slatsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) + pure subroutine stdlib${ii}$_slatsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) !! SLATSQR computes a blocked Tall-Skinny QR factorization of !! a real M-by-N matrix A for M >= N: !! A = Q * ( R ), @@ -64366,76 +64369,76 @@ 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, m, n, mb, nb, ldt, lwork + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, mb, nb, ldt, lwork ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: work(*), t(ldt,*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, ii, kk, ctr + integer(${ik}$) :: i, ii, kk, ctr ! External Subroutines intrinsic :: max,min,mod ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 .or. mn .and. n>0 )) then - info = -4 - else if( ldan .and. n>0_${ik}$ )) then + info = -4_${ik}$ + else if( lda=m)) then - call stdlib_sgeqrt( m, n, nb, a, lda, t, ldt, work, info) + call stdlib${ii}$_sgeqrt( m, n, nb, a, lda, t, ldt, work, info) return end if kk = mod((m-n),(mb-n)) ii=m-kk+1 ! compute the qr factorization of the first block a(1:mb,1:n) - call stdlib_sgeqrt( mb, n, nb, a(1,1), lda, t, ldt, work, info ) - ctr = 1 + call stdlib${ii}$_sgeqrt( mb, n, nb, a(1_${ik}$,1_${ik}$), lda, t, ldt, work, info ) + ctr = 1_${ik}$ do i = mb+1, ii-mb+n , (mb-n) ! compute the qr factorization of the current block a(i:i+mb-n,1:n) - call stdlib_stpqrt( mb-n, n, 0, nb, a(1,1), lda, a( i, 1 ), lda,t(1, ctr * n + 1),& + call stdlib${ii}$_stpqrt( mb-n, n, 0_${ik}$, nb, a(1_${ik}$,1_${ik}$), lda, a( i, 1_${ik}$ ), lda,t(1_${ik}$, ctr * n + 1_${ik}$),& ldt, work, info ) - ctr = ctr + 1 + ctr = ctr + 1_${ik}$ end do ! compute the qr factorization of the last block a(ii:m,1:n) if (ii<=m) then - call stdlib_stpqrt( kk, n, 0, nb, a(1,1), lda, a( ii, 1 ), lda,t(1, ctr * n + 1), & + call stdlib${ii}$_stpqrt( kk, n, 0_${ik}$, nb, a(1_${ik}$,1_${ik}$), lda, a( ii, 1_${ik}$ ), lda,t(1_${ik}$, ctr * n + 1_${ik}$), & ldt,work, info ) end if - work( 1 ) = n*nb + work( 1_${ik}$ ) = n*nb return - end subroutine stdlib_slatsqr + end subroutine stdlib${ii}$_slatsqr - pure subroutine stdlib_sorgbr( vect, m, n, k, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_sorgbr( vect, m, n, k, a, lda, tau, work, lwork, info ) !! SORGBR generates one of the real orthogonal matrices Q or P**T !! determined by SGEBRD when reducing a real matrix A to bidiagonal !! form: A = Q * B * P**T. Q and P**T are defined as products of @@ -64457,8 +64460,8 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: vect - 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(*) @@ -64467,124 +64470,124 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: lquery, wantq - integer(ilp) :: i, iinfo, j, lwkopt, mn + integer(${ik}$) :: i, iinfo, j, lwkopt, mn ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ wantq = stdlib_lsame( vect, 'Q' ) mn = min( m, n ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) if( .not.wantq .and. .not.stdlib_lsame( vect, 'P' ) ) then - info = -1 - else if( m<0 ) then - info = -2 - else if( n<0 .or. ( wantq .and. ( n>m .or. nm .or. nn .or. m=k ) then - call stdlib_sorgqr( m, n, k, a, lda, tau, work, -1, iinfo ) + call stdlib${ii}$_sorgqr( m, n, k, a, lda, tau, work, -1_${ik}$, iinfo ) else - if( m>1 ) then - call stdlib_sorgqr( m-1, m-1, m-1, a, lda, tau, work, -1,iinfo ) + if( m>1_${ik}$ ) then + call stdlib${ii}$_sorgqr( m-1, m-1, m-1, a, lda, tau, work, -1_${ik}$,iinfo ) end if end if else if( k1 ) then - call stdlib_sorglq( n-1, n-1, n-1, a, lda, tau, work, -1,iinfo ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_sorglq( n-1, n-1, n-1, a, lda, tau, work, -1_${ik}$,iinfo ) end if end if end if - lwkopt = work( 1 ) + lwkopt = work( 1_${ik}$ ) lwkopt = max (lwkopt, mn) end if - if( info/=0 ) then - call stdlib_xerbla( 'SORGBR', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'SORGBR', -info ) return else if( lquery ) then - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return end if ! quick return if possible - if( m==0 .or. n==0 ) then - work( 1 ) = 1 + if( m==0_${ik}$ .or. n==0_${ik}$ ) then + work( 1_${ik}$ ) = 1_${ik}$ return end if if( wantq ) then - ! form q, determined by a call to stdlib_sgebrd to reduce an m-by-k + ! form q, determined by a call to stdlib${ii}$_sgebrd to reduce an m-by-k ! matrix if( m>=k ) then ! if m >= k, assume m >= n >= k - call stdlib_sorgqr( m, n, k, a, lda, tau, work, lwork, iinfo ) + call stdlib${ii}$_sorgqr( m, n, k, a, lda, tau, work, lwork, iinfo ) else ! if m < k, assume m = n ! shift the vectors which define the elementary reflectors one ! column to the right, and set the first row and column of q ! to those of the unit matrix do j = m, 2, -1 - a( 1, j ) = zero + a( 1_${ik}$, j ) = zero do i = j + 1, m a( i, j ) = a( i, j-1 ) end do end do - a( 1, 1 ) = one + a( 1_${ik}$, 1_${ik}$ ) = one do i = 2, m - a( i, 1 ) = zero + a( i, 1_${ik}$ ) = zero end do - if( m>1 ) then + if( m>1_${ik}$ ) then ! form q(2:m,2:m) - call stdlib_sorgqr( m-1, m-1, m-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) + call stdlib${ii}$_sorgqr( m-1, m-1, m-1, a( 2_${ik}$, 2_${ik}$ ), lda, tau, work,lwork, iinfo ) end if end if else - ! form p**t, determined by a call to stdlib_sgebrd to reduce a k-by-n + ! form p**t, determined by a call to stdlib${ii}$_sgebrd to reduce a k-by-n ! matrix if( k= n, assume m = n ! shift the vectors which define the elementary reflectors one ! row downward, and set the first row and column of p**t to ! those of the unit matrix - a( 1, 1 ) = one + a( 1_${ik}$, 1_${ik}$ ) = one do i = 2, n - a( i, 1 ) = zero + a( i, 1_${ik}$ ) = zero end do do j = 2, n do i = j - 1, 2, -1 a( i, j ) = a( i-1, j ) end do - a( 1, j ) = zero + a( 1_${ik}$, j ) = zero end do - if( n>1 ) then + if( n>1_${ik}$ ) then ! form p**t(2:n,2:n) - call stdlib_sorglq( n-1, n-1, n-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) + call stdlib${ii}$_sorglq( n-1, n-1, n-1, a( 2_${ik}$, 2_${ik}$ ), lda, tau, work,lwork, iinfo ) end if end if end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_sorgbr + end subroutine stdlib${ii}$_sorgbr - pure subroutine stdlib_sormbr( vect, side, trans, m, n, k, a, lda, tau, c,ldc, work, lwork, & + pure subroutine stdlib${ii}$_sormbr( vect, side, trans, m, n, k, a, lda, tau, c,ldc, work, lwork, & !! If VECT = 'Q', SORMBR: overwrites the general real M-by-N matrix C !! with !! SIDE = 'L' SIDE = 'R' @@ -64613,8 +64616,8 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: side, trans, vect - 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(*) @@ -64623,90 +64626,90 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: applyq, left, lquery, notran character :: transt - integer(ilp) :: i1, i2, iinfo, lwkopt, mi, nb, ni, nq, nw + integer(${ik}$) :: i1, i2, iinfo, lwkopt, mi, nb, ni, nq, nw ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ applyq = stdlib_lsame( vect, 'Q' ) left = stdlib_lsame( side, 'L' ) notran = stdlib_lsame( trans, 'N' ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) ! nq is the order of q or p 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.applyq .and. .not.stdlib_lsame( vect, 'P' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then - info = -2 + info = -2_${ik}$ else if( .not.notran .and. .not.stdlib_lsame( trans, 'T' ) ) then - info = -3 - else if( m<0 ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( k<0 ) then - info = -6 - else if( ( applyq .and. lda=k ) then - ! q was determined by a call to stdlib_sgebrd with nq >= k - call stdlib_sormqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, iinfo & + ! q was determined by a call to stdlib${ii}$_sgebrd with nq >= k + call stdlib${ii}$_sormqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, iinfo & ) - else if( nq>1 ) then - ! q was determined by a call to stdlib_sgebrd with nq < k + else if( nq>1_${ik}$ ) then + ! q was determined by a call to stdlib${ii}$_sgebrd with nq < k if( left ) then - mi = m - 1 + mi = m - 1_${ik}$ ni = n - i1 = 2 - i2 = 1 + i1 = 2_${ik}$ + i2 = 1_${ik}$ else mi = m - ni = n - 1 - i1 = 1 - i2 = 2 + ni = n - 1_${ik}$ + i1 = 1_${ik}$ + i2 = 2_${ik}$ end if - call stdlib_sormqr( side, trans, mi, ni, nq-1, a( 2, 1 ), lda, tau,c( i1, i2 ), & + call stdlib${ii}$_sormqr( side, trans, mi, ni, nq-1, a( 2_${ik}$, 1_${ik}$ ), lda, tau,c( i1, i2 ), & ldc, work, lwork, iinfo ) end if else @@ -64717,32 +64720,32 @@ module stdlib_linalg_lapack_s transt = 'N' end if if( nq>k ) then - ! p was determined by a call to stdlib_sgebrd with nq > k - call stdlib_sormlq( side, transt, m, n, k, a, lda, tau, c, ldc,work, lwork, & + ! p was determined by a call to stdlib${ii}$_sgebrd with nq > k + call stdlib${ii}$_sormlq( side, transt, m, n, k, a, lda, tau, c, ldc,work, lwork, & iinfo ) - else if( nq>1 ) then - ! p was determined by a call to stdlib_sgebrd with nq <= k + else if( nq>1_${ik}$ ) then + ! p was determined by a call to stdlib${ii}$_sgebrd with nq <= k if( left ) then - mi = m - 1 + mi = m - 1_${ik}$ ni = n - i1 = 2 - i2 = 1 + i1 = 2_${ik}$ + i2 = 1_${ik}$ else mi = m - ni = n - 1 - i1 = 1 - i2 = 2 + ni = n - 1_${ik}$ + i1 = 1_${ik}$ + i2 = 2_${ik}$ end if - call stdlib_sormlq( side, transt, mi, ni, nq-1, a( 1, 2 ), lda,tau, c( i1, i2 ), & + call stdlib${ii}$_sormlq( side, transt, mi, ni, nq-1, a( 1_${ik}$, 2_${ik}$ ), lda,tau, c( i1, i2 ), & ldc, work, lwork, iinfo ) end if end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_sormbr + end subroutine stdlib${ii}$_sormbr - pure subroutine stdlib_spbsv( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) + pure subroutine stdlib${ii}$_spbsv( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) !! SPBSV computes the solution to a real system of linear equations !! A * X = B, !! where A is an N-by-N symmetric positive definite band matrix and X @@ -64759,8 +64762,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, ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kd, ldab, ldb, n, nrhs ! Array Arguments real(sp), intent(inout) :: ab(ldab,*), b(ldb,*) ! ===================================================================== @@ -64768,35 +64771,35 @@ module stdlib_linalg_lapack_s intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .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( ldab0 ) then + info = -11_${ik}$ + else if( n>0_${ik}$ ) then scond = max( smin, smlnum ) / min( smax, bignum ) else scond = one end if end if - if( info==0 ) then - if( ldb0 )then + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_slansb( '1', uplo, n, kd, ab, ldab, work ) + anorm = stdlib${ii}$_slansb( '1', uplo, n, kd, ab, ldab, work ) ! compute the reciprocal of the condition number of a. - call stdlib_spbcon( uplo, n, kd, afb, ldafb, anorm, rcond, work, iwork,info ) + call stdlib${ii}$_spbcon( uplo, n, kd, afb, ldafb, anorm, rcond, work, iwork,info ) ! compute the solution matrix x. - call stdlib_slacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_spbtrs( uplo, n, kd, nrhs, afb, ldafb, x, ldx, info ) + call stdlib${ii}$_slacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_spbtrs( uplo, n, kd, nrhs, afb, ldafb, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_spbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b, ldb, x,ldx, ferr, berr,& + call stdlib${ii}$_spbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b, ldb, x,ldx, ferr, berr,& work, iwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -64947,12 +64950,12 @@ module stdlib_linalg_lapack_s end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) - call stdlib_spotrf( 'L', n1, a( 0 ), n, info ) + call stdlib${ii}$_spotrf( 'L', n1, a( 0_${ik}$ ), n, info ) if( info>0 )return - call stdlib_strsm( 'R', 'L', 'T', 'N', n2, n1, one, a( 0 ), n,a( n1 ), n ) + call stdlib${ii}$_strsm( 'R', 'L', 'T', 'N', n2, n1, one, a( 0_${ik}$ ), n,a( n1 ), n ) - call stdlib_ssyrk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n ) - call stdlib_spotrf( 'U', n2, a( n ), n, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_ssyrk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n ) + call stdlib${ii}$_spotrf( 'U', n2, a( n ), n, info ) + if( info>0_${ik}$ )info = info + n1 else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) - call stdlib_spotrf( 'L', n1, a( n2 ), n, info ) + call stdlib${ii}$_spotrf( 'L', n1, a( n2 ), n, info ) if( info>0 )return - call stdlib_strsm( 'L', 'L', 'N', 'N', n1, n2, one, a( n2 ), n,a( 0 ), n ) + call stdlib${ii}$_strsm( 'L', 'L', 'N', 'N', n1, n2, one, a( n2 ), n,a( 0_${ik}$ ), n ) - call stdlib_ssyrk( 'U', 'T', n2, n1, -one, a( 0 ), n, one,a( n1 ), n ) - call stdlib_spotrf( 'U', n2, a( n1 ), n, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_ssyrk( 'U', 'T', n2, n1, -one, a( 0_${ik}$ ), n, one,a( n1 ), n ) + call stdlib${ii}$_spotrf( 'U', n2, a( n1 ), n, info ) + if( info>0_${ik}$ )info = info + n1 end if else ! n is odd and transr = 't' @@ -65044,26 +65047,26 @@ module stdlib_linalg_lapack_s ! srpa for lower, transpose and n is odd ! t1 -> a(0,0) , t2 -> a(1,0) , s -> a(0,n1) ! t1 -> a(0+0) , t2 -> a(1+0) , s -> a(0+n1*n1); lda=n1 - call stdlib_spotrf( 'U', n1, a( 0 ), n1, info ) + call stdlib${ii}$_spotrf( 'U', n1, a( 0_${ik}$ ), n1, info ) if( info>0 )return - call stdlib_strsm( 'L', 'U', 'T', 'N', n1, n2, one, a( 0 ), n1,a( n1*n1 ), n1 & + call stdlib${ii}$_strsm( 'L', 'U', 'T', 'N', n1, n2, one, a( 0_${ik}$ ), n1,a( n1*n1 ), n1 & ) - call stdlib_ssyrk( 'L', 'T', n2, n1, -one, a( n1*n1 ), n1, one,a( 1 ), n1 ) + call stdlib${ii}$_ssyrk( 'L', 'T', n2, n1, -one, a( n1*n1 ), n1, one,a( 1_${ik}$ ), n1 ) - call stdlib_spotrf( 'L', n2, a( 1 ), n1, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_spotrf( 'L', n2, a( 1_${ik}$ ), n1, info ) + if( info>0_${ik}$ )info = info + n1 else ! srpa for upper, transpose and n is odd ! t1 -> a(0,n1+1), t2 -> a(0,n1), s -> a(0,0) ! t1 -> a(n2*n2), t2 -> a(n1*n2), s -> a(0); lda = n2 - call stdlib_spotrf( 'U', n1, a( n2*n2 ), n2, info ) + call stdlib${ii}$_spotrf( 'U', n1, a( n2*n2 ), n2, info ) if( info>0 )return - call stdlib_strsm( 'R', 'U', 'N', 'N', n2, n1, one, a( n2*n2 ),n2, a( 0 ), n2 & + call stdlib${ii}$_strsm( 'R', 'U', 'N', 'N', n2, n1, one, a( n2*n2 ),n2, a( 0_${ik}$ ), n2 & ) - call stdlib_ssyrk( 'L', 'N', n2, n1, -one, a( 0 ), n2, one,a( n1*n2 ), n2 ) + call stdlib${ii}$_ssyrk( 'L', 'N', n2, n1, -one, a( 0_${ik}$ ), n2, one,a( n1*n2 ), n2 ) - call stdlib_spotrf( 'L', n2, a( n1*n2 ), n2, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_spotrf( 'L', n2, a( n1*n2 ), n2, info ) + if( info>0_${ik}$ )info = info + n1 end if end if else @@ -65074,26 +65077,26 @@ module stdlib_linalg_lapack_s ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) - call stdlib_spotrf( 'L', k, a( 1 ), n+1, info ) + call stdlib${ii}$_spotrf( 'L', k, a( 1_${ik}$ ), n+1, info ) if( info>0 )return - call stdlib_strsm( 'R', 'L', 'T', 'N', k, k, one, a( 1 ), n+1,a( k+1 ), n+1 ) + call stdlib${ii}$_strsm( 'R', 'L', 'T', 'N', k, k, one, a( 1_${ik}$ ), n+1,a( k+1 ), n+1 ) - call stdlib_ssyrk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0 ), n+1 ) + call stdlib${ii}$_ssyrk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0_${ik}$ ), n+1 ) - call stdlib_spotrf( 'U', k, a( 0 ), n+1, info ) - if( info>0 )info = info + k + call stdlib${ii}$_spotrf( 'U', k, a( 0_${ik}$ ), n+1, info ) + if( info>0_${ik}$ )info = info + k else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) - call stdlib_spotrf( 'L', k, a( k+1 ), n+1, info ) + call stdlib${ii}$_spotrf( 'L', k, a( k+1 ), n+1, info ) if( info>0 )return - call stdlib_strsm( 'L', 'L', 'N', 'N', k, k, one, a( k+1 ),n+1, a( 0 ), n+1 ) + call stdlib${ii}$_strsm( 'L', 'L', 'N', 'N', k, k, one, a( k+1 ),n+1, a( 0_${ik}$ ), n+1 ) - call stdlib_ssyrk( 'U', 'T', k, k, -one, a( 0 ), n+1, one,a( k ), n+1 ) + call stdlib${ii}$_ssyrk( 'U', 'T', k, k, -one, a( 0_${ik}$ ), n+1, one,a( k ), n+1 ) - call stdlib_spotrf( 'U', k, a( k ), n+1, info ) - if( info>0 )info = info + k + call stdlib${ii}$_spotrf( 'U', k, a( k ), n+1, info ) + if( info>0_${ik}$ )info = info + k end if else ! n is even and transr = 't' @@ -65101,33 +65104,33 @@ module stdlib_linalg_lapack_s ! srpa for lower, transpose and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1) ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k - call stdlib_spotrf( 'U', k, a( 0+k ), k, info ) + call stdlib${ii}$_spotrf( 'U', k, a( 0_${ik}$+k ), k, info ) if( info>0 )return - call stdlib_strsm( 'L', 'U', 'T', 'N', k, k, one, a( k ), n1,a( k*( k+1 ) ), & + call stdlib${ii}$_strsm( 'L', 'U', 'T', 'N', k, k, one, a( k ), n1,a( k*( k+1 ) ), & k ) - call stdlib_ssyrk( 'L', 'T', k, k, -one, a( k*( k+1 ) ), k, one,a( 0 ), k ) + call stdlib${ii}$_ssyrk( 'L', 'T', k, k, -one, a( k*( k+1 ) ), k, one,a( 0_${ik}$ ), k ) - call stdlib_spotrf( 'L', k, a( 0 ), k, info ) - if( info>0 )info = info + k + call stdlib${ii}$_spotrf( 'L', k, a( 0_${ik}$ ), k, info ) + if( info>0_${ik}$ )info = info + k else ! srpa for upper, transpose and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0) ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k - call stdlib_spotrf( 'U', k, a( k*( k+1 ) ), k, info ) + call stdlib${ii}$_spotrf( 'U', k, a( k*( k+1 ) ), k, info ) if( info>0 )return - call stdlib_strsm( 'R', 'U', 'N', 'N', k, k, one,a( k*( k+1 ) ), k, a( 0 ), k & + call stdlib${ii}$_strsm( 'R', 'U', 'N', 'N', k, k, one,a( k*( k+1 ) ), k, a( 0_${ik}$ ), k & ) - call stdlib_ssyrk( 'L', 'N', k, k, -one, a( 0 ), k, one,a( k*k ), k ) - call stdlib_spotrf( 'L', k, a( k*k ), k, info ) - if( info>0 )info = info + k + call stdlib${ii}$_ssyrk( 'L', 'N', k, k, -one, a( 0_${ik}$ ), k, one,a( k*k ), k ) + call stdlib${ii}$_spotrf( 'L', k, a( k*k ), k, info ) + if( info>0_${ik}$ )info = info + k end if end if end if return - end subroutine stdlib_spftrf + end subroutine stdlib${ii}$_spftrf - pure subroutine stdlib_sposv( uplo, n, nrhs, a, lda, b, ldb, info ) + pure subroutine stdlib${ii}$_sposv( uplo, n, nrhs, a, lda, b, ldb, info ) !! SPOSV computes the solution to a real system of linear equations !! A * X = B, !! where A is an N-by-N symmetric positive definite matrix and X and B @@ -65143,8 +65146,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) :: lda, ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, n, nrhs ! Array Arguments real(sp), intent(inout) :: a(lda,*), b(ldb,*) ! ===================================================================== @@ -65152,33 +65155,33 @@ module stdlib_linalg_lapack_s intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .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 + info = -10_${ik}$ + else if( n>0_${ik}$ ) then scond = max( smin, smlnum ) / min( smax, bignum ) else scond = one end if end if - if( info==0 ) then - if( ldb0 )then + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_slansy( '1', uplo, n, a, lda, work ) + anorm = stdlib${ii}$_slansy( '1', uplo, n, a, lda, work ) ! compute the reciprocal of the condition number of a. - call stdlib_spocon( uplo, n, af, ldaf, anorm, rcond, work, iwork, info ) + call stdlib${ii}$_spocon( uplo, n, af, ldaf, anorm, rcond, work, iwork, info ) ! compute the solution matrix x. - call stdlib_slacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_spotrs( uplo, n, nrhs, af, ldaf, x, ldx, info ) + call stdlib${ii}$_slacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_spotrs( uplo, n, nrhs, af, ldaf, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_sporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x, ldx,ferr, berr, work, & + call stdlib${ii}$_sporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x, ldx,ferr, berr, work, & iwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -65316,12 +65319,12 @@ module stdlib_linalg_lapack_s end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcondn ).and.( n>0 )) then - info = -7 - else if(( ilst<1 .or. ilst>n ).and.( n>0 )) then - info = -8 - end if - if( info/=0 ) then - call stdlib_xerbla( 'STREXC', -info ) + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ + else if( ldtn ).and.( n>0_${ik}$ )) then + info = -7_${ik}$ + else if(( ilst<1_${ik}$ .or. ilst>n ).and.( n>0_${ik}$ )) then + info = -8_${ik}$ + end if + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'STREXC', -info ) return end if ! quick return if possible if( n<=1 )return ! determine the first row of specified block ! and find out it is 1 by 1 or 2 by 2. - if( ifst>1 ) then - if( t( ifst, ifst-1 )/=zero )ifst = ifst - 1 + if( ifst>1_${ik}$ ) then + if( t( ifst, ifst-1 )/=zero )ifst = ifst - 1_${ik}$ end if - nbf = 1 + nbf = 1_${ik}$ if( ifst1 ) then - if( t( ilst, ilst-1 )/=zero )ilst = ilst - 1 + if( ilst>1_${ik}$ ) then + if( t( ilst, ilst-1 )/=zero )ilst = ilst - 1_${ik}$ end if - nbl = 1 + nbl = 1_${ik}$ if( ilst=3 ) then - if( t( here-1, here-2 )/=zero )nbnext = 2 + nbnext = 1_${ik}$ + if( here>=3_${ik}$ ) then + if( t( here-1, here-2 )/=zero )nbnext = 2_${ik}$ end if - call stdlib_slaexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext,nbf, work, & + call stdlib${ii}$_slaexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext,nbf, work, & info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then ilst = here return end if here = here - nbnext ! test if 2 by 2 block breaks into two 1 by 1 blocks - if( nbf==2 ) then - if( t( here+1, here )==zero )nbf = 3 + if( nbf==2_${ik}$ ) then + if( t( here+1, here )==zero )nbf = 3_${ik}$ end if else ! current block consists of two 1 by 1 blocks each of which ! must be swapped individually - nbnext = 1 - if( here>=3 ) then - if( t( here-1, here-2 )/=zero )nbnext = 2 + nbnext = 1_${ik}$ + if( here>=3_${ik}$ ) then + if( t( here-1, here-2 )/=zero )nbnext = 2_${ik}$ end if - call stdlib_slaexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext,1, work, info ) + call stdlib${ii}$_slaexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext,1_${ik}$, work, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then ilst = here return end if - if( nbnext==1 ) then + if( nbnext==1_${ik}$ ) then ! swap two 1 by 1 blocks, no problems possible - call stdlib_slaexc( wantq, n, t, ldt, q, ldq, here, nbnext, 1,work, info ) + call stdlib${ii}$_slaexc( wantq, n, t, ldt, q, ldq, here, nbnext, 1_${ik}$,work, info ) - here = here - 1 + here = here - 1_${ik}$ else ! recompute nbnext in case 2 by 2 split - if( t( here, here-1 )==zero )nbnext = 1 - if( nbnext==2 ) then + if( t( here, here-1 )==zero )nbnext = 1_${ik}$ + if( nbnext==2_${ik}$ ) then ! 2 by 2 block did not split - call stdlib_slaexc( wantq, n, t, ldt, q, ldq, here-1, 2, 1,work, info ) + call stdlib${ii}$_slaexc( wantq, n, t, ldt, q, ldq, here-1, 2_${ik}$, 1_${ik}$,work, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then ilst = here return end if - here = here - 2 + here = here - 2_${ik}$ else ! 2 by 2 block did split - call stdlib_slaexc( wantq, n, t, ldt, q, ldq, here, 1, 1,work, info ) + call stdlib${ii}$_slaexc( wantq, n, t, ldt, q, ldq, here, 1_${ik}$, 1_${ik}$,work, info ) - call stdlib_slaexc( wantq, n, t, ldt, q, ldq, here-1, 1, 1,work, info ) + call stdlib${ii}$_slaexc( wantq, n, t, ldt, q, ldq, here-1, 1_${ik}$, 1_${ik}$,work, info ) - here = here - 2 + here = here - 2_${ik}$ end if end if end if @@ -65522,10 +65525,10 @@ module stdlib_linalg_lapack_s end if ilst = here return - end subroutine stdlib_strexc + end subroutine stdlib${ii}$_strexc - subroutine stdlib_strsen( job, compq, select, n, t, ldt, q, ldq, wr, wi,m, s, sep, work, & + subroutine stdlib${ii}$_strsen( job, compq, select, n, t, ldt, q, ldq, wr, wi,m, s, sep, work, & !! STRSEN reorders the real Schur factorization of a real matrix !! A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in !! the leading diagonal blocks of the upper quasi-triangular matrix T, @@ -65543,22 +65546,22 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: compq, job - integer(ilp), intent(out) :: info, m - integer(ilp), intent(in) :: ldq, ldt, liwork, lwork, n + integer(${ik}$), intent(out) :: info, m + integer(${ik}$), intent(in) :: ldq, ldt, liwork, lwork, n real(sp), intent(out) :: s, sep ! Array Arguments logical(lk), intent(in) :: select(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(inout) :: q(ldq,*), t(ldt,*) real(sp), intent(out) :: wi(*), work(*), wr(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, pair, swap, wantbh, wantq, wants, wantsp - integer(ilp) :: ierr, k, kase, kk, ks, liwmin, lwmin, n1, n2, nn + integer(${ik}$) :: ierr, k, kase, kk, ks, liwmin, lwmin, n1, n2, nn real(sp) :: est, rnorm, scale ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements @@ -65567,22 +65570,22 @@ module stdlib_linalg_lapack_s wants = stdlib_lsame( job, 'E' ) .or. wantbh wantsp = stdlib_lsame( job, 'V' ) .or. wantbh wantq = stdlib_lsame( compq, 'V' ) - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) if( .not.stdlib_lsame( job, 'N' ) .and. .not.wants .and. .not.wantsp )then - info = -1 + info = -1_${ik}$ else if( .not.stdlib_lsame( compq, 'N' ) .and. .not.wantq ) then - info = -2 - else if( n<0 ) then - info = -4 - else if( ldt0 ) then - mb = stdlib_ilaenv( 1, 'SGELQ ', ' ', m, n, 1, -1 ) - nb = stdlib_ilaenv( 1, 'SGELQ ', ' ', m, n, 2, -1 ) + if( min( m, n )>0_${ik}$ ) then + mb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SGELQ ', ' ', m, n, 1_${ik}$, -1_${ik}$ ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SGELQ ', ' ', m, n, 2_${ik}$, -1_${ik}$ ) else - mb = 1 + mb = 1_${ik}$ nb = n end if - if( mb>min( m, n ) .or. mb<1 ) mb = 1 + if( mb>min( m, n ) .or. mb<1_${ik}$ ) mb = 1_${ik}$ if( nb>n .or. nb<=m ) nb = n - mintsz = m + 5 + mintsz = m + 5_${ik}$ if ( nb>m .and. n>m ) then - if( mod( n - m, nb - m )==0 ) then + if( mod( n - m, nb - m )==0_${ik}$ ) then nblcks = ( n - m ) / ( nb - m ) else - nblcks = ( n - m ) / ( nb - m ) + 1 + nblcks = ( n - m ) / ( nb - m ) + 1_${ik}$ end if else - nblcks = 1 + nblcks = 1_${ik}$ end if ! determine if the workspace size satisfies minimal size if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then - lwmin = max( 1, n ) - lwopt = max( 1, mb*n ) + lwmin = max( 1_${ik}$, n ) + lwopt = max( 1_${ik}$, mb*n ) else - lwmin = max( 1, m ) - lwopt = max( 1, mb*m ) + lwmin = max( 1_${ik}$, m ) + lwopt = max( 1_${ik}$, mb*m ) end if lminws = .false. - if( ( tsize=lwmin ) .and. ( & + if( ( tsize=lwmin ) .and. ( & tsize>=mintsz ).and. ( .not.lquery ) ) then - if( tsize=n ) ) then - lwreq = max( 1, mb*n ) + lwreq = max( 1_${ik}$, mb*n ) else - lwreq = max( 1, mb*m ) + lwreq = max( 1_${ik}$, mb*m ) end if - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda=n ) ) then - call stdlib_sgelqt( m, n, mb, a, lda, t( 6 ), mb, work, info ) + call stdlib${ii}$_sgelqt( m, n, mb, a, lda, t( 6_${ik}$ ), mb, work, info ) else - call stdlib_slaswlq( m, n, mb, nb, a, lda, t( 6 ), mb, work,lwork, info ) + call stdlib${ii}$_slaswlq( m, n, mb, nb, a, lda, t( 6_${ik}$ ), mb, work,lwork, info ) end if - work( 1 ) = lwreq + work( 1_${ik}$ ) = lwreq return - end subroutine stdlib_sgelq + end subroutine stdlib${ii}$_sgelq - subroutine stdlib_sgelsy( m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank,work, lwork, info ) + subroutine stdlib${ii}$_sgelsy( m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank,work, lwork, info ) !! SGELSY computes the minimum-norm solution to a real linear least !! squares problem: !! minimize || A * X - B || @@ -66128,22 +66131,22 @@ 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, rank - integer(ilp), intent(in) :: lda, ldb, lwork, m, n, nrhs + integer(${ik}$), intent(out) :: info, rank + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, nrhs real(sp), intent(in) :: rcond ! Array Arguments - integer(ilp), intent(inout) :: jpvt(*) + integer(${ik}$), intent(inout) :: jpvt(*) real(sp), intent(inout) :: a(lda,*), b(ldb,*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: imax = 1 - integer(ilp), parameter :: imin = 2 + integer(${ik}$), parameter :: imax = 1_${ik}$ + integer(${ik}$), parameter :: imin = 2_${ik}$ ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, iascl, ibscl, ismax, ismin, j, lwkmin, lwkopt, mn, nb, nb1, nb2, & + integer(${ik}$) :: i, iascl, ibscl, ismax, ismin, j, lwkmin, lwkopt, mn, nb, nb1, nb2, & nb3, nb4 real(sp) :: anrm, bignum, bnrm, c1, c2, s1, s2, smax, smaxpr, smin, sminpr, smlnum, & wsize @@ -66151,87 +66154,87 @@ module stdlib_linalg_lapack_s intrinsic :: abs,max,min ! Executable Statements mn = min( m, n ) - ismin = mn + 1 - ismax = 2*mn + 1 + ismin = mn + 1_${ik}$ + ismax = 2_${ik}$*mn + 1_${ik}$ ! test the input arguments. - info = 0 - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( ldazero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_slascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_slaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) - rank = 0 + call stdlib${ii}$_slaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) + rank = 0_${ik}$ go to 70 end if - bnrm = stdlib_slange( 'M', m, nrhs, b, ldb, work ) - ibscl = 0 + bnrm = stdlib${ii}$_slange( 'M', m, nrhs, b, ldb, work ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_slascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) - ibscl = 2 + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, m, nrhs, b, ldb, info ) + ibscl = 2_${ik}$ end if ! compute qr factorization with column pivoting of a: ! a * p = q * r - call stdlib_sgeqp3( m, n, a, lda, jpvt, work( 1 ), work( mn+1 ),lwork-mn, info ) + call stdlib${ii}$_sgeqp3( m, n, a, lda, jpvt, work( 1_${ik}$ ), work( mn+1 ),lwork-mn, info ) wsize = mn + work( mn+1 ) ! workspace: mn+2*n+nb*(n+1). @@ -66239,21 +66242,21 @@ module stdlib_linalg_lapack_s ! determine rank using incremental condition estimation work( ismin ) = one work( ismax ) = one - smax = abs( a( 1, 1 ) ) + smax = abs( a( 1_${ik}$, 1_${ik}$ ) ) smin = smax - if( abs( a( 1, 1 ) )==zero ) then - rank = 0 - call stdlib_slaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) + if( abs( a( 1_${ik}$, 1_${ik}$ ) )==zero ) then + rank = 0_${ik}$ + call stdlib${ii}$_slaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) go to 70 else - rank = 1 + rank = 1_${ik}$ end if 10 continue if( rank0 ) then - mb = stdlib_ilaenv( 1, 'SGEQR ', ' ', m, n, 1, -1 ) - nb = stdlib_ilaenv( 1, 'SGEQR ', ' ', m, n, 2, -1 ) + if( min( m, n )>0_${ik}$ ) then + mb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEQR ', ' ', m, n, 1_${ik}$, -1_${ik}$ ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEQR ', ' ', m, n, 2_${ik}$, -1_${ik}$ ) else mb = m - nb = 1 + nb = 1_${ik}$ end if if( mb>m .or. mb<=n ) mb = m - if( nb>min( m, n ) .or. nb<1 ) nb = 1 - mintsz = n + 5 + if( nb>min( m, n ) .or. nb<1_${ik}$ ) nb = 1_${ik}$ + mintsz = n + 5_${ik}$ if ( mb>n .and. m>n ) then - if( mod( m - n, mb - n )==0 ) then + if( mod( m - n, mb - n )==0_${ik}$ ) then nblcks = ( m - n ) / ( mb - n ) else - nblcks = ( m - n ) / ( mb - n ) + 1 + nblcks = ( m - n ) / ( mb - n ) + 1_${ik}$ end if else - nblcks = 1 + nblcks = 1_${ik}$ end if ! determine if the workspace size satisfies minimal size lminws = .false. - if( ( tsize=n ) .and. ( & + if( ( tsize=n ) .and. ( & tsize>=mintsz ).and. ( .not.lquery ) ) then - if( tsize=m ) ) then - call stdlib_sgeqrt( m, n, nb, a, lda, t( 6 ), nb, work, info ) + call stdlib${ii}$_sgeqrt( m, n, nb, a, lda, t( 6_${ik}$ ), nb, work, info ) else - call stdlib_slatsqr( m, n, mb, nb, a, lda, t( 6 ), nb, work,lwork, info ) + call stdlib${ii}$_slatsqr( m, n, mb, nb, a, lda, t( 6_${ik}$ ), nb, work,lwork, info ) end if - work( 1 ) = max( 1, nb*n ) + work( 1_${ik}$ ) = max( 1_${ik}$, nb*n ) return - end subroutine stdlib_sgeqr + end subroutine stdlib${ii}$_sgeqr - subroutine stdlib_sgetsls( trans, m, n, nrhs, a, lda, b, ldb,work, lwork, info ) + subroutine stdlib${ii}$_sgetsls( trans, m, n, nrhs, a, lda, b, ldb,work, lwork, info ) !! SGETSLS solves overdetermined or underdetermined real linear systems !! involving an M-by-N matrix A, using a tall skinny QR or short wide LQ !! factorization of A. It is assumed that A has full rank. @@ -66462,8 +66465,8 @@ 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) :: lda, ldb, lwork, m, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, nrhs ! Array Arguments real(sp), intent(inout) :: a(lda,*), b(ldb,*) real(sp), intent(out) :: work(*) @@ -66471,74 +66474,74 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: lquery, tran - integer(ilp) :: i, iascl, ibscl, j, maxmn, brow, scllen, tszo, tszm, lwo, lwm, lw1, & + integer(${ik}$) :: i, iascl, ibscl, j, maxmn, brow, scllen, tszo, tszm, lwo, lwm, lw1, & lw2, wsizeo, wsizem, info2 - real(sp) :: anrm, bignum, bnrm, smlnum, tq(5), workq(1) + real(sp) :: anrm, bignum, bnrm, smlnum, tq(5_${ik}$), workq(1_${ik}$) ! Intrinsic Functions intrinsic :: real,max,min,int ! Executable Statements ! test the input arguments. - info = 0 + info = 0_${ik}$ maxmn = max( m, n ) tran = stdlib_lsame( trans, 'T' ) - lquery = ( lwork==-1 .or. lwork==-2 ) + lquery = ( lwork==-1_${ik}$ .or. lwork==-2_${ik}$ ) if( .not.( stdlib_lsame( trans, 'N' ) .or.stdlib_lsame( trans, 'T' ) ) ) then - info = -1 - else if( m<0 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( nrhs<0 ) then - info = -4 - else if( lda=n ) then - call stdlib_sgeqr( m, n, a, lda, tq, -1, workq, -1, info2 ) - tszo = int( tq( 1 ),KIND=ilp) - lwo = int( workq( 1 ),KIND=ilp) - call stdlib_sgemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszo, b, ldb, workq, -1, & + call stdlib${ii}$_sgeqr( m, n, a, lda, tq, -1_${ik}$, workq, -1_${ik}$, info2 ) + tszo = int( tq( 1_${ik}$ ),KIND=${ik}$) + lwo = int( workq( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_sgemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszo, b, ldb, workq, -1_${ik}$, & info2 ) - lwo = max( lwo, int( workq( 1 ),KIND=ilp) ) - call stdlib_sgeqr( m, n, a, lda, tq, -2, workq, -2, info2 ) - tszm = int( tq( 1 ),KIND=ilp) - lwm = int( workq( 1 ),KIND=ilp) - call stdlib_sgemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszm, b, ldb, workq, -1, & + lwo = max( lwo, int( workq( 1_${ik}$ ),KIND=${ik}$) ) + call stdlib${ii}$_sgeqr( m, n, a, lda, tq, -2_${ik}$, workq, -2_${ik}$, info2 ) + tszm = int( tq( 1_${ik}$ ),KIND=${ik}$) + lwm = int( workq( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_sgemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszm, b, ldb, workq, -1_${ik}$, & info2 ) - lwm = max( lwm, int( workq( 1 ),KIND=ilp) ) + lwm = max( lwm, int( workq( 1_${ik}$ ),KIND=${ik}$) ) wsizeo = tszo + lwo wsizem = tszm + lwm else - call stdlib_sgelq( m, n, a, lda, tq, -1, workq, -1, info2 ) - tszo = int( tq( 1 ),KIND=ilp) - lwo = int( workq( 1 ),KIND=ilp) - call stdlib_sgemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszo, b, ldb, workq, -1, & + call stdlib${ii}$_sgelq( m, n, a, lda, tq, -1_${ik}$, workq, -1_${ik}$, info2 ) + tszo = int( tq( 1_${ik}$ ),KIND=${ik}$) + lwo = int( workq( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_sgemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszo, b, ldb, workq, -1_${ik}$, & info2 ) - lwo = max( lwo, int( workq( 1 ),KIND=ilp) ) - call stdlib_sgelq( m, n, a, lda, tq, -2, workq, -2, info2 ) - tszm = int( tq( 1 ),KIND=ilp) - lwm = int( workq( 1 ),KIND=ilp) - call stdlib_sgemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszm, b, ldb, workq, -1, & + lwo = max( lwo, int( workq( 1_${ik}$ ),KIND=${ik}$) ) + call stdlib${ii}$_sgelq( m, n, a, lda, tq, -2_${ik}$, workq, -2_${ik}$, info2 ) + tszm = int( tq( 1_${ik}$ ),KIND=${ik}$) + lwm = int( workq( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_sgemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszm, b, ldb, workq, -1_${ik}$, & info2 ) - lwm = max( lwm, int( workq( 1 ),KIND=ilp) ) + lwm = max( lwm, int( workq( 1_${ik}$ ),KIND=${ik}$) ) wsizeo = tszo + lwo wsizem = tszm + lwm end if if( ( lworkzero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_slascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_slaset( 'F', maxmn, nrhs, zero, zero, b, ldb ) + call stdlib${ii}$_slaset( 'F', maxmn, nrhs, zero, zero, b, ldb ) go to 50 end if brow = m if ( tran ) then brow = n end if - bnrm = stdlib_slange( 'M', brow, nrhs, b, ldb, work ) - ibscl = 0 + bnrm = stdlib${ii}$_slange( 'M', brow, nrhs, b, ldb, work ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_slascl( 'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,info ) - ibscl = 2 + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, brow, nrhs, b, ldb,info ) + ibscl = 2_${ik}$ end if if ( m>=n ) then ! compute qr factorization of a - call stdlib_sgeqr( m, n, a, lda, work( lw2+1 ), lw1,work( 1 ), lw2, info ) + call stdlib${ii}$_sgeqr( m, n, a, lda, work( lw2+1 ), lw1,work( 1_${ik}$ ), lw2, info ) if ( .not.tran ) then ! least-squares problem min || a * x - b || ! b(1:m,1:nrhs) := q**t * b(1:m,1:nrhs) - call stdlib_sgemqr( 'L' , 'T', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, work(& - 1 ), lw2,info ) + call stdlib${ii}$_sgemqr( 'L' , 'T', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, work(& + 1_${ik}$ ), lw2,info ) ! b(1:n,1:nrhs) := inv(r) * b(1:n,1:nrhs) - call stdlib_strtrs( 'U', 'N', 'N', n, nrhs,a, lda, b, ldb, info ) - if( info>0 ) then + call stdlib${ii}$_strtrs( 'U', 'N', 'N', n, nrhs,a, lda, b, ldb, info ) + if( info>0_${ik}$ ) then return end if scllen = n else ! overdetermined system of equations a**t * x = b ! b(1:n,1:nrhs) := inv(r**t) * b(1:n,1:nrhs) - call stdlib_strtrs( 'U', 'T', 'N', n, nrhs,a, lda, b, ldb, info ) - if( info>0 ) then + call stdlib${ii}$_strtrs( 'U', 'T', 'N', n, nrhs,a, lda, b, ldb, info ) + if( info>0_${ik}$ ) then return end if ! b(n+1:m,1:nrhs) = zero @@ -66616,19 +66619,19 @@ module stdlib_linalg_lapack_s end do end do ! b(1:m,1:nrhs) := q(1:n,:) * b(1:n,1:nrhs) - call stdlib_sgemqr( 'L', 'N', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, & - work( 1 ), lw2,info ) + call stdlib${ii}$_sgemqr( 'L', 'N', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, & + work( 1_${ik}$ ), lw2,info ) scllen = m end if else ! compute lq factorization of a - call stdlib_sgelq( m, n, a, lda, work( lw2+1 ), lw1,work( 1 ), lw2, info ) + call stdlib${ii}$_sgelq( m, n, a, lda, work( lw2+1 ), lw1,work( 1_${ik}$ ), lw2, info ) ! workspace at least m, optimally m*nb. if( .not.tran ) then ! underdetermined system of equations a * x = b ! b(1:m,1:nrhs) := inv(l) * b(1:m,1:nrhs) - call stdlib_strtrs( 'L', 'N', 'N', m, nrhs,a, lda, b, ldb, info ) - if( info>0 ) then + call stdlib${ii}$_strtrs( 'L', 'N', 'N', m, nrhs,a, lda, b, ldb, info ) + if( info>0_${ik}$ ) then return end if ! b(m+1:n,1:nrhs) = 0 @@ -66638,43 +66641,43 @@ module stdlib_linalg_lapack_s end do end do ! b(1:n,1:nrhs) := q(1:n,:)**t * b(1:m,1:nrhs) - call stdlib_sgemlq( 'L', 'T', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & - work( 1 ), lw2,info ) + call stdlib${ii}$_sgemlq( 'L', 'T', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & + work( 1_${ik}$ ), lw2,info ) ! workspace at least nrhs, optimally nrhs*nb scllen = n else ! overdetermined system min || a**t * x - b || ! b(1:n,1:nrhs) := q * b(1:n,1:nrhs) - call stdlib_sgemlq( 'L', 'N', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & - work( 1 ), lw2,info ) + call stdlib${ii}$_sgemlq( 'L', 'N', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & + work( 1_${ik}$ ), lw2,info ) ! workspace at least nrhs, optimally nrhs*nb ! b(1:m,1:nrhs) := inv(l**t) * b(1:m,1:nrhs) - call stdlib_strtrs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & + call stdlib${ii}$_strtrs( 'LOWER', 'TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if scllen = m end if end if ! undo scaling - if( iascl==1 ) then - call stdlib_slascl( 'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,info ) - else if( iascl==2 ) then - call stdlib_slascl( 'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,info ) + if( iascl==1_${ik}$ ) then + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, smlnum, scllen, nrhs, b, ldb,info ) + else if( iascl==2_${ik}$ ) then + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, scllen, nrhs, b, ldb,info ) end if - if( ibscl==1 ) then - call stdlib_slascl( 'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,info ) - else if( ibscl==2 ) then - call stdlib_slascl( 'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,info ) + if( ibscl==1_${ik}$ ) then + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, bnrm, scllen, nrhs, b, ldb,info ) + else if( ibscl==2_${ik}$ ) then + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bignum, bnrm, scllen, nrhs, b, ldb,info ) end if 50 continue - work( 1 ) = real( tszo + lwo,KIND=sp) + work( 1_${ik}$ ) = real( tszo + lwo,KIND=sp) return - end subroutine stdlib_sgetsls + end subroutine stdlib${ii}$_sgetsls - pure subroutine stdlib_sgetsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) + pure subroutine stdlib${ii}$_sgetsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) !! SGETSQRHRT computes a NB2-sized column blocked QR-factorization !! of a complex M-by-N matrix A with M >= N, !! A = Q * R. @@ -66692,8 +66695,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, nb1, nb2, mb1 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldt, lwork, m, n, nb1, nb2, mb1 ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: t(ldt,*), work(*) @@ -66701,41 +66704,41 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, iinfo, j, lw1, lw2, lwt, ldwt, lworkopt, nb1local, nb2local, & + integer(${ik}$) :: i, iinfo, j, lw1, lw2, lwt, ldwt, lworkopt, nb1local, nb2local, & num_all_row_blocks ! Intrinsic Functions intrinsic :: ceiling,max,min ! Executable Statements ! test the input arguments - info = 0 - lquery = lwork==-1 - if( m<0 ) then - info = -1 - else if( n<0 .or. mn1 .or. ( n / 2 )n1 .or. ( n / 2_${ik}$ )n )go to 100 if( rho*abs( z( nj ) )<=tol ) then ! deflate due to small z component. - k2 = k2 - 1 - coltyp( nj ) = 4 + k2 = k2 - 1_${ik}$ + coltyp( nj ) = 4_${ik}$ indxp( k2 ) = nj else ! check if eigenvalues are close enough to allow deflation. @@ -66939,7 +66942,7 @@ module stdlib_linalg_lapack_s c = z( nj ) ! find sqrt(a**2+b**2) without overflow or ! destructive underflow. - tau = stdlib_slapy2( c, s ) + tau = stdlib${ii}$_slapy2( c, s ) t = d( nj ) - d( pj ) c = c / tau s = -s / tau @@ -66947,20 +66950,20 @@ module stdlib_linalg_lapack_s ! deflation is possible. z( nj ) = tau z( pj ) = zero - if( coltyp( nj )/=coltyp( pj ) )coltyp( nj ) = 2 - coltyp( pj ) = 4 - call stdlib_srot( n, q( 1, pj ), 1, q( 1, nj ), 1, c, s ) - t = d( pj )*c**2 + d( nj )*s**2 - d( nj ) = d( pj )*s**2 + d( nj )*c**2 + if( coltyp( nj )/=coltyp( pj ) )coltyp( nj ) = 2_${ik}$ + coltyp( pj ) = 4_${ik}$ + call stdlib${ii}$_srot( n, q( 1_${ik}$, pj ), 1_${ik}$, q( 1_${ik}$, nj ), 1_${ik}$, c, s ) + t = d( pj )*c**2_${ik}$ + d( nj )*s**2_${ik}$ + d( nj ) = d( pj )*s**2_${ik}$ + d( nj )*c**2_${ik}$ d( pj ) = t - k2 = k2 - 1 - i = 1 + k2 = k2 - 1_${ik}$ + i = 1_${ik}$ 90 continue if( k2+i<=n ) then if( d( pj )kbot )return ! ... nor for an empty deflation window. ==== if( nw<1 )return ! ==== machine constants ==== - safmin = stdlib_slamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) safmax = one / safmin - call stdlib_slabad( safmin, safmax ) - ulp = stdlib_slamch( 'PRECISION' ) + call stdlib${ii}$_slabad( safmin, safmax ) + ulp = stdlib${ii}$_slamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=sp) / ulp ) ! ==== setup deflation window ==== jw = min( nw, kbot-ktop+1 ) - kwtop = kbot - jw + 1 + kwtop = kbot - jw + 1_${ik}$ if( kwtop==ktop ) then s = zero else @@ -67145,14 +67148,14 @@ module stdlib_linalg_lapack_s ! ==== 1-by-1 deflation window: not much to do ==== sr( kwtop ) = h( kwtop, kwtop ) si( kwtop ) = zero - ns = 1 - nd = 0 + ns = 1_${ik}$ + nd = 0_${ik}$ if( abs( s )<=max( smlnum, ulp*abs( h( kwtop, kwtop ) ) ) )then - ns = 0 - nd = 1 + ns = 0_${ik}$ + nd = 1_${ik}$ if( kwtop>ktop )h( kwtop, kwtop-1 ) = zero end if - work( 1 ) = one + work( 1_${ik}$ ) = one return end if ! ==== convert to spike-triangular form. (in case of a @@ -67160,23 +67163,23 @@ module stdlib_linalg_lapack_s ! . aggressive early deflation using that part of ! . the deflation window that converged using infqr ! . here and there to keep track.) ==== - call stdlib_slacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) - call stdlib_scopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 ) - call stdlib_slaset( 'A', jw, jw, zero, one, v, ldv ) - call stdlib_slahqr( .true., .true., jw, 1, jw, t, ldt, sr( kwtop ),si( kwtop ), 1, jw, & + call stdlib${ii}$_slacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) + call stdlib${ii}$_scopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2_${ik}$, 1_${ik}$ ), ldt+1 ) + call stdlib${ii}$_slaset( 'A', jw, jw, zero, one, v, ldv ) + call stdlib${ii}$_slahqr( .true., .true., jw, 1_${ik}$, jw, t, ldt, sr( kwtop ),si( kwtop ), 1_${ik}$, jw, & v, ldv, infqr ) - ! ==== stdlib_strexc needs a clean margin near the diagonal ==== + ! ==== stdlib${ii}$_strexc needs a clean margin near the diagonal ==== do j = 1, jw - 3 t( j+2, j ) = zero t( j+3, j ) = zero end do - if( jw>2 )t( jw, jw-2 ) = zero + if( jw>2_${ik}$ )t( jw, jw-2 ) = zero ! ==== deflation detection loop ==== ns = jw - ilst = infqr + 1 + ilst = infqr + 1_${ik}$ 20 continue if( ilst<=ns ) then - if( ns==1 ) then + if( ns==1_${ik}$ ) then bulge = .false. else bulge = t( ns, ns-1 )/=zero @@ -67186,56 +67189,56 @@ module stdlib_linalg_lapack_s ! ==== real eigenvalue ==== foo = abs( t( ns, ns ) ) if( foo==zero )foo = abs( s ) - if( abs( s*v( 1, ns ) )<=max( smlnum, ulp*foo ) ) then + if( abs( s*v( 1_${ik}$, ns ) )<=max( smlnum, ulp*foo ) ) then ! ==== deflatable ==== - ns = ns - 1 + ns = ns - 1_${ik}$ else ! ==== undeflatable. move it up out of the way. - ! . (stdlib_strexc can not fail in this case.) ==== + ! . (stdlib${ii}$_strexc can not fail in this case.) ==== ifst = ns - call stdlib_strexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) - ilst = ilst + 1 + call stdlib${ii}$_strexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) + ilst = ilst + 1_${ik}$ end if else ! ==== complex conjugate pair ==== foo = abs( t( ns, ns ) ) + sqrt( abs( t( ns, ns-1 ) ) )*sqrt( abs( t( ns-1, ns ) & ) ) if( foo==zero )foo = abs( s ) - if( max( abs( s*v( 1, ns ) ), abs( s*v( 1, ns-1 ) ) )<=max( smlnum, ulp*foo ) ) & + if( max( abs( s*v( 1_${ik}$, ns ) ), abs( s*v( 1_${ik}$, ns-1 ) ) )<=max( smlnum, ulp*foo ) ) & then ! ==== deflatable ==== - ns = ns - 2 + ns = ns - 2_${ik}$ else ! ==== undeflatable. move them up out of the way. - ! . fortunately, stdlib_strexc does the right thing with + ! . fortunately, stdlib${ii}$_strexc does the right thing with ! . ilst in case of a rare exchange failure. ==== ifst = ns - call stdlib_strexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) - ilst = ilst + 2 + call stdlib${ii}$_strexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) + ilst = ilst + 2_${ik}$ end if end if ! ==== end deflation detection loop ==== go to 20 end if ! ==== return to hessenberg form ==== - if( ns==0 )s = zero + if( ns==0_${ik}$ )s = zero if( ns1 .and. s/=zero ) then + if( ns>1_${ik}$ .and. s/=zero ) then ! ==== reflect spike back into lower triangle ==== - call stdlib_scopy( ns, v, ldv, work, 1 ) - beta = work( 1 ) - call stdlib_slarfg( ns, beta, work( 2 ), 1, tau ) - work( 1 ) = one - call stdlib_slaset( 'L', jw-2, jw-2, zero, zero, t( 3, 1 ), ldt ) - call stdlib_slarf( 'L', ns, jw, work, 1, tau, t, ldt,work( jw+1 ) ) - call stdlib_slarf( 'R', ns, ns, work, 1, tau, t, ldt,work( jw+1 ) ) - call stdlib_slarf( 'R', jw, ns, work, 1, tau, v, ldv,work( jw+1 ) ) - call stdlib_sgehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) + call stdlib${ii}$_scopy( ns, v, ldv, work, 1_${ik}$ ) + beta = work( 1_${ik}$ ) + call stdlib${ii}$_slarfg( ns, beta, work( 2_${ik}$ ), 1_${ik}$, tau ) + work( 1_${ik}$ ) = one + call stdlib${ii}$_slaset( 'L', jw-2, jw-2, zero, zero, t( 3_${ik}$, 1_${ik}$ ), ldt ) + call stdlib${ii}$_slarf( 'L', ns, jw, work, 1_${ik}$, tau, t, ldt,work( jw+1 ) ) + call stdlib${ii}$_slarf( 'R', ns, ns, work, 1_${ik}$, tau, t, ldt,work( jw+1 ) ) + call stdlib${ii}$_slarf( 'R', jw, ns, work, 1_${ik}$, tau, v, ldv,work( jw+1 ) ) + call stdlib${ii}$_sgehrd( jw, 1_${ik}$, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) end if ! ==== copy updated reduced window into place ==== - if( kwtop>1 )h( kwtop, kwtop-1 ) = s*v( 1, 1 ) - call stdlib_slacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) - call stdlib_scopy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) + if( kwtop>1_${ik}$ )h( kwtop, kwtop-1 ) = s*v( 1_${ik}$, 1_${ik}$ ) + call stdlib${ii}$_slacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) + call stdlib${ii}$_scopy( jw-1, t( 2_${ik}$, 1_${ik}$ ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) ! ==== accumulate orthogonal matrix in order update ! . h and z, if requested. ==== - if( ns>1 .and. s/=zero )call stdlib_sormhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, & + if( ns>1_${ik}$ .and. s/=zero )call stdlib${ii}$_sormhr( 'R', 'N', jw, ns, 1_${ik}$, ns, t, ldt, work, & v, ldv,work( jw+1 ), lwork-jw, info ) ! ==== update vertical slab in h ==== if( wantt ) then - ltop = 1 + ltop = 1_${ik}$ else ltop = ktop end if do krow = ltop, kwtop - 1, nv kln = min( nv, kwtop-krow ) - call stdlib_sgemm( 'N', 'N', kln, jw, jw, one, h( krow, kwtop ),ldh, v, ldv, & + call stdlib${ii}$_sgemm( 'N', 'N', kln, jw, jw, one, h( krow, kwtop ),ldh, v, ldv, & zero, wv, ldwv ) - call stdlib_slacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) + call stdlib${ii}$_slacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) end do ! ==== update horizontal slab in h ==== if( wantt ) then do kcol = kbot + 1, n, nh kln = min( nh, n-kcol+1 ) - call stdlib_sgemm( 'C', 'N', jw, kln, jw, one, v, ldv,h( kwtop, kcol ), ldh, & + call stdlib${ii}$_sgemm( 'C', 'N', jw, kln, jw, one, v, ldv,h( kwtop, kcol ), ldh, & zero, t, ldt ) - call stdlib_slacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) + call stdlib${ii}$_slacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) end do end if ! ==== update vertical slab in z ==== if( wantz ) then do krow = iloz, ihiz, nv kln = min( nv, ihiz-krow+1 ) - call stdlib_sgemm( 'N', 'N', kln, jw, jw, one, z( krow, kwtop ),ldz, v, ldv, & + call stdlib${ii}$_sgemm( 'N', 'N', kln, jw, jw, one, z( krow, kwtop ),ldz, v, ldv, & zero, wv, ldwv ) - call stdlib_slacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) + call stdlib${ii}$_slacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) end do end if end if @@ -67363,11 +67366,11 @@ module stdlib_linalg_lapack_s ! . window.) ==== ns = ns - infqr ! ==== return optimal workspace. ==== - work( 1 ) = real( lwkopt,KIND=sp) - end subroutine stdlib_slaqr2 + work( 1_${ik}$ ) = real( lwkopt,KIND=sp) + end subroutine stdlib${ii}$_slaqr2 - pure subroutine stdlib_slasd1( nl, nr, sqre, d, alpha, beta, u, ldu, vt, ldvt,idxq, iwork, & + pure subroutine stdlib${ii}$_slasd1( nl, nr, sqre, d, alpha, beta, u, ldu, vt, ldvt,idxq, iwork, & !! SLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B, !! where N = NL + NR + 1 and M = N + SQRE. SLASD1 is called from SLASD0. !! A related subroutine SLASD7 handles the case in which the singular @@ -67402,49 +67405,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) :: info - integer(ilp), intent(in) :: ldu, ldvt, nl, nr, sqre + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldu, ldvt, nl, nr, sqre real(sp), intent(inout) :: alpha, beta ! Array Arguments - integer(ilp), intent(inout) :: idxq(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(inout) :: idxq(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(inout) :: d(*), u(ldu,*), vt(ldvt,*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: coltyp, i, idx, idxc, idxp, iq, isigma, iu2, ivt2, iz, k, ldq, ldu2, & + integer(${ik}$) :: coltyp, i, idx, idxc, idxp, iq, isigma, iu2, ivt2, iz, k, ldq, ldu2, & ldvt2, m, n, n1, n2 real(sp) :: orgnrm ! Intrinsic Functions intrinsic :: abs,max ! Executable Statements ! test the input parameters. - info = 0 - if( nl<1 ) then - info = -1 - else if( nr<1 ) then - info = -2 - else if( ( sqre<0 ) .or. ( sqre>1 ) ) then - info = -3 + info = 0_${ik}$ + if( nl<1_${ik}$ ) then + info = -1_${ik}$ + else if( nr<1_${ik}$ ) then + info = -2_${ik}$ + else if( ( sqre<0_${ik}$ ) .or. ( sqre>1_${ik}$ ) ) then + info = -3_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'SLASD1', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'SLASD1', -info ) return end if - n = nl + nr + 1 + n = nl + nr + 1_${ik}$ m = n + sqre ! the following values are for bookkeeping purposes only. they are ! integer pointers which indicate the portion of the workspace - ! used by a particular array in stdlib_slasd2 and stdlib_slasd3. + ! used by a particular array in stdlib${ii}$_slasd2 and stdlib${ii}$_slasd3. ldu2 = n ldvt2 = m - iz = 1 + iz = 1_${ik}$ isigma = iz + m iu2 = isigma + n ivt2 = iu2 + ldu2*n iq = ivt2 + ldvt2*m - idx = 1 + idx = 1_${ik}$ idxc = idx + n coltyp = idxc + n idxp = coltyp + n @@ -67456,33 +67459,33 @@ module stdlib_linalg_lapack_s orgnrm = abs( d( i ) ) end if end do - call stdlib_slascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, n, 1_${ik}$, d, n, info ) alpha = alpha / orgnrm beta = beta / orgnrm ! deflate singular values. - call stdlib_slasd2( nl, nr, sqre, k, d, work( iz ), alpha, beta, u, ldu,vt, ldvt, work(& + call stdlib${ii}$_slasd2( nl, nr, sqre, k, d, work( iz ), alpha, beta, u, ldu,vt, ldvt, work(& isigma ), work( iu2 ), ldu2,work( ivt2 ), ldvt2, iwork( idxp ), iwork( idx ),iwork( & idxc ), idxq, iwork( coltyp ), info ) ! solve secular equation and update singular vectors. ldq = k - call stdlib_slasd3( nl, nr, sqre, k, d, work( iq ), ldq, work( isigma ),u, ldu, work( & + call stdlib${ii}$_slasd3( nl, nr, sqre, k, d, work( iq ), ldq, work( isigma ),u, ldu, work( & iu2 ), ldu2, vt, ldvt, work( ivt2 ),ldvt2, iwork( idxc ), iwork( coltyp ), work( iz ),& info ) ! report the possible convergence failure. - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if ! unscale. - call stdlib_slascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, n, 1_${ik}$, d, n, info ) ! prepare the idxq sorting permutation. n1 = k n2 = n - k - call stdlib_slamrg( n1, n2, d, 1, -1, idxq ) + call stdlib${ii}$_slamrg( n1, n2, d, 1_${ik}$, -1_${ik}$, idxq ) return - end subroutine stdlib_slasd1 + end subroutine stdlib${ii}$_slasd1 - pure subroutine stdlib_slaed1( n, d, q, ldq, indxq, rho, cutpnt, work, iwork,info ) + pure subroutine stdlib${ii}$_slaed1( n, d, q, ldq, indxq, rho, cutpnt, work, iwork,info ) !! SLAED1 computes the updated eigensystem of a diagonal !! matrix after modification by a rank-one symmetric matrix. This !! routine is used only for the eigenproblem which requires all @@ -67513,68 +67516,68 @@ 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) :: cutpnt, ldq, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: cutpnt, ldq, n + integer(${ik}$), intent(out) :: info real(sp), intent(inout) :: rho ! Array Arguments - integer(ilp), intent(inout) :: indxq(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(inout) :: indxq(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(inout) :: d(*), q(ldq,*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: coltyp, cpp1, i, idlmda, indx, indxc, indxp, iq2, is, iw, iz, k, n1, & + integer(${ik}$) :: coltyp, cpp1, i, idlmda, indx, indxc, indxp, iq2, is, iw, iz, k, n1, & n2 ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input parameters. - info = 0 - if( n<0 ) then - info = -1 - else if( ldqcutpnt .or. ( n / 2 )cutpnt .or. ( n / 2_${ik}$ )2 ) then - info = -1 - else if( ( icompq==1 ) .and. ( qsiz2_${ik}$ ) then + info = -1_${ik}$ + else if( ( icompq==1_${ik}$ ) .and. ( qsizsmlsiz ) then do j = subpbs, 1, -1 - iwork( 2*j ) = ( iwork( j )+1 ) / 2 - iwork( 2*j-1 ) = iwork( j ) / 2 + iwork( 2_${ik}$*j ) = ( iwork( j )+1_${ik}$ ) / 2_${ik}$ + iwork( 2_${ik}$*j-1 ) = iwork( j ) / 2_${ik}$ end do - tlvls = tlvls + 1 - subpbs = 2*subpbs + tlvls = tlvls + 1_${ik}$ + subpbs = 2_${ik}$*subpbs go to 10 end if do j = 2, subpbs @@ -67649,147 +67652,147 @@ module stdlib_linalg_lapack_s end do ! divide the matrix into subpbs submatrices of size at most smlsiz+1 ! using rank-1 modifications (cuts). - spm1 = subpbs - 1 + spm1 = subpbs - 1_${ik}$ do i = 1, spm1 - submat = iwork( i ) + 1 - smm1 = submat - 1 + submat = iwork( i ) + 1_${ik}$ + smm1 = submat - 1_${ik}$ d( smm1 ) = d( smm1 ) - abs( e( smm1 ) ) d( submat ) = d( submat ) - abs( e( smm1 ) ) end do - indxq = 4*n + 3 - if( icompq/=2 ) then + indxq = 4_${ik}$*n + 3_${ik}$ + if( icompq/=2_${ik}$ ) then ! set up workspaces for eigenvalues only/accumulate new vectors ! routine temp = log( real( n,KIND=sp) ) / log( two ) - lgn = int( temp,KIND=ilp) - if( 2**lgn 1 ) - curlvl = 1 + curlvl = 1_${ik}$ 80 continue - if( subpbs>1 ) then - spm2 = subpbs - 2 + if( subpbs>1_${ik}$ ) then + spm2 = subpbs - 2_${ik}$ loop_90: do i = 0, spm2, 2 - if( i==0 ) then - submat = 1 - matsiz = iwork( 2 ) - msd2 = iwork( 1 ) - curprb = 0 + if( i==0_${ik}$ ) then + submat = 1_${ik}$ + matsiz = iwork( 2_${ik}$ ) + msd2 = iwork( 1_${ik}$ ) + curprb = 0_${ik}$ else - submat = iwork( i ) + 1 + submat = iwork( i ) + 1_${ik}$ matsiz = iwork( i+2 ) - iwork( i ) - msd2 = matsiz / 2 - curprb = curprb + 1 + msd2 = matsiz / 2_${ik}$ + curprb = curprb + 1_${ik}$ end if ! merge lower order eigensystems (of size msd2 and matsiz - msd2) ! into an eigensystem of size matsiz. - ! stdlib_slaed1 is used only for the full eigensystem of a tridiagonal + ! stdlib${ii}$_slaed1 is used only for the full eigensystem of a tridiagonal ! matrix. - ! stdlib_slaed7 handles the cases in which eigenvalues only or eigenvalues + ! stdlib${ii}$_slaed7 handles the cases in which eigenvalues only or eigenvalues ! and eigenvectors of a full symmetric matrix (which was reduced to ! tridiagonal form) are desired. - if( icompq==2 ) then - call stdlib_slaed1( matsiz, d( submat ), q( submat, submat ),ldq, iwork( & + if( icompq==2_${ik}$ ) then + call stdlib${ii}$_slaed1( matsiz, d( submat ), q( submat, submat ),ldq, iwork( & indxq+submat ),e( submat+msd2-1 ), msd2, work,iwork( subpbs+1 ), info ) else - call stdlib_slaed7( icompq, matsiz, qsiz, tlvls, curlvl, curprb,d( submat ), & - qstore( 1, submat ), ldqs,iwork( indxq+submat ), e( submat+msd2-1 ),msd2, & + call stdlib${ii}$_slaed7( icompq, matsiz, qsiz, tlvls, curlvl, curprb,d( submat ), & + qstore( 1_${ik}$, submat ), ldqs,iwork( indxq+submat ), e( submat+msd2-1 ),msd2, & work( iq ), iwork( iqptr ),iwork( iprmpt ), iwork( iperm ),iwork( igivpt ), & iwork( igivcl ),work( igivnm ), work( iwrem ),iwork( subpbs+1 ), info ) end if if( info/=0 )go to 130 - iwork( i / 2+1 ) = iwork( i+2 ) + iwork( i / 2_${ik}$+1 ) = iwork( i+2 ) end do loop_90 - subpbs = subpbs / 2 - curlvl = curlvl + 1 + subpbs = subpbs / 2_${ik}$ + curlvl = curlvl + 1_${ik}$ go to 80 end if ! end while ! re-merge the eigenvalues/vectors which were deflated at the final ! merge step. - if( icompq==1 ) then + if( icompq==1_${ik}$ ) then do i = 1, n j = iwork( indxq+i ) work( i ) = d( j ) - call stdlib_scopy( qsiz, qstore( 1, j ), 1, q( 1, i ), 1 ) + call stdlib${ii}$_scopy( qsiz, qstore( 1_${ik}$, j ), 1_${ik}$, q( 1_${ik}$, i ), 1_${ik}$ ) end do - call stdlib_scopy( n, work, 1, d, 1 ) - else if( icompq==2 ) then + call stdlib${ii}$_scopy( n, work, 1_${ik}$, d, 1_${ik}$ ) + else if( icompq==2_${ik}$ ) then do i = 1, n j = iwork( indxq+i ) work( i ) = d( j ) - call stdlib_scopy( n, q( 1, j ), 1, work( n*i+1 ), 1 ) + call stdlib${ii}$_scopy( n, q( 1_${ik}$, j ), 1_${ik}$, work( n*i+1 ), 1_${ik}$ ) end do - call stdlib_scopy( n, work, 1, d, 1 ) - call stdlib_slacpy( 'A', n, n, work( n+1 ), n, q, ldq ) + call stdlib${ii}$_scopy( n, work, 1_${ik}$, d, 1_${ik}$ ) + call stdlib${ii}$_slacpy( 'A', n, n, work( n+1 ), n, q, ldq ) else do i = 1, n j = iwork( indxq+i ) work( i ) = d( j ) end do - call stdlib_scopy( n, work, 1, d, 1 ) + call stdlib${ii}$_scopy( n, work, 1_${ik}$, d, 1_${ik}$ ) end if go to 140 130 continue - info = submat*( n+1 ) + submat + matsiz - 1 + info = submat*( n+1 ) + submat + matsiz - 1_${ik}$ 140 continue return - end subroutine stdlib_slaed0 + end subroutine stdlib${ii}$_slaed0 - pure subroutine stdlib_sstedc( compz, n, d, e, z, ldz, work, lwork, iwork,liwork, info ) + pure subroutine stdlib${ii}$_sstedc( compz, n, d, e, z, ldz, work, lwork, iwork,liwork, info ) !! SSTEDC computes all eigenvalues and, optionally, eigenvectors of a !! symmetric tridiagonal matrix using the divide and conquer method. !! The eigenvectors of a full or band real symmetric matrix can also be @@ -67807,115 +67810,115 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: compz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldz, liwork, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldz, liwork, lwork, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(inout) :: d(*), e(*), z(ldz,*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: finish, i, icompz, ii, j, k, lgn, liwmin, lwmin, m, smlsiz, start, & + integer(${ik}$) :: finish, i, icompz, ii, j, k, lgn, liwmin, lwmin, m, smlsiz, start, & storez, strtrw real(sp) :: eps, orgnrm, p, tiny ! Intrinsic Functions intrinsic :: abs,int,log,max,mod,real,sqrt ! Executable Statements ! test the input parameters. - info = 0 - lquery = ( lwork==-1 .or. liwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) if( stdlib_lsame( compz, 'N' ) ) then - icompz = 0 + icompz = 0_${ik}$ else if( stdlib_lsame( compz, 'V' ) ) then - icompz = 1 + icompz = 1_${ik}$ else if( stdlib_lsame( compz, 'I' ) ) then - icompz = 2 + icompz = 2_${ik}$ else - icompz = -1 + icompz = -1_${ik}$ end if - if( icompz<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( ( ldz<1 ) .or.( icompz>0 .and. ldz0_${ik}$ .and. ldztiny ) then - finish = finish + 1 + finish = finish + 1_${ik}$ go to 20 end if end if ! (sub) problem determined. compute its size and solve it. - m = finish - start + 1 - if( m==1 ) then - start = finish + 1 + m = finish - start + 1_${ik}$ + if( m==1_${ik}$ ) then + start = finish + 1_${ik}$ go to 10 end if if( m>smlsiz ) then ! scale. - orgnrm = stdlib_slanst( 'M', m, d( start ), e( start ) ) - call stdlib_slascl( 'G', 0, 0, orgnrm, one, m, 1, d( start ), m,info ) - call stdlib_slascl( 'G', 0, 0, orgnrm, one, m-1, 1, e( start ),m-1, info ) + orgnrm = stdlib${ii}$_slanst( 'M', m, d( start ), e( start ) ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, m, 1_${ik}$, d( start ), m,info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, m-1, 1_${ik}$, e( start ),m-1, info ) - if( icompz==1 ) then - strtrw = 1 + if( icompz==1_${ik}$ ) then + strtrw = 1_${ik}$ else strtrw = start end if - call stdlib_slaed0( icompz, n, m, d( start ), e( start ),z( strtrw, start ), & - ldz, work( 1 ), n,work( storez ), iwork, info ) - if( info/=0 ) then + call stdlib${ii}$_slaed0( icompz, n, m, d( start ), e( start ),z( strtrw, start ), & + ldz, work( 1_${ik}$ ), n,work( storez ), iwork, info ) + if( info/=0_${ik}$ ) then info = ( info / ( m+1 )+start-1 )*( n+1 ) +mod( info, ( m+1 ) ) + start - & - 1 + 1_${ik}$ go to 50 end if ! scale back. - call stdlib_slascl( 'G', 0, 0, one, orgnrm, m, 1, d( start ), m,info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, m, 1_${ik}$, d( start ), m,info ) else - if( icompz==1 ) then + if( icompz==1_${ik}$ ) then ! since qr won't update a z matrix which is larger than ! the length of d, we must solve the sub-problem in a ! workspace and then multiply back into z. - call stdlib_ssteqr( 'I', m, d( start ), e( start ), work, m,work( m*m+1 ), & + call stdlib${ii}$_ssteqr( 'I', m, d( start ), e( start ), work, m,work( m*m+1 ), & info ) - call stdlib_slacpy( 'A', n, m, z( 1, start ), ldz,work( storez ), n ) + call stdlib${ii}$_slacpy( 'A', n, m, z( 1_${ik}$, start ), ldz,work( storez ), n ) - call stdlib_sgemm( 'N', 'N', n, m, m, one,work( storez ), n, work, m, zero,& - z( 1, start ), ldz ) - else if( icompz==2 ) then - call stdlib_ssteqr( 'I', m, d( start ), e( start ),z( start, start ), ldz, & + call stdlib${ii}$_sgemm( 'N', 'N', n, m, m, one,work( storez ), n, work, m, zero,& + z( 1_${ik}$, start ), ldz ) + else if( icompz==2_${ik}$ ) then + call stdlib${ii}$_ssteqr( 'I', m, d( start ), e( start ),z( start, start ), ldz, & work, info ) else - call stdlib_ssterf( m, d( start ), e( start ), info ) + call stdlib${ii}$_ssterf( m, d( start ), e( start ), info ) end if - if( info/=0 ) then + if( info/=0_${ik}$ ) then info = start*( n+1 ) + finish go to 50 end if end if - start = finish + 1 + start = finish + 1_${ik}$ go to 10 end if ! endwhile - if( icompz==0 ) then + if( icompz==0_${ik}$ ) then ! use quick sort - call stdlib_slasrt( 'I', n, d, info ) + call stdlib${ii}$_slasrt( 'I', n, d, info ) else ! use selection sort to minimize swaps of eigenvectors do ii = 2, n - i = ii - 1 + i = ii - 1_${ik}$ k = i p = d( i ) do j = ii, n @@ -68003,19 +68006,19 @@ module stdlib_linalg_lapack_s if( k/=i ) then d( k ) = d( i ) d( i ) = p - call stdlib_sswap( n, z( 1, i ), 1, z( 1, k ), 1 ) + call stdlib${ii}$_sswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, k ), 1_${ik}$ ) end if end do end if end if 50 continue - work( 1 ) = lwmin - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = lwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_sstedc + end subroutine stdlib${ii}$_sstedc - pure subroutine stdlib_sstevd( jobz, n, d, e, z, ldz, work, lwork, iwork,liwork, info ) + pure subroutine stdlib${ii}$_sstevd( jobz, n, d, e, z, ldz, work, lwork, iwork,liwork, info ) !! SSTEVD computes all eigenvalues and, optionally, eigenvectors of a !! real symmetric tridiagonal matrix. If eigenvectors are desired, it !! uses a divide and conquer algorithm. @@ -68031,96 +68034,96 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldz, liwork, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldz, liwork, lwork, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(inout) :: d(*), e(*) real(sp), intent(out) :: work(*), z(ldz,*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, wantz - integer(ilp) :: iscale, liwmin, lwmin + integer(${ik}$) :: iscale, liwmin, lwmin real(sp) :: bignum, eps, rmax, rmin, safmin, sigma, smlnum, tnrm ! Intrinsic Functions intrinsic :: sqrt ! Executable Statements ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) - lquery = ( lwork==-1 .or. liwork==-1 ) - info = 0 - liwmin = 1 - lwmin = 1 - if( n>1 .and. wantz ) then - lwmin = 1 + 4*n + n**2 - liwmin = 3 + 5*n + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) + info = 0_${ik}$ + liwmin = 1_${ik}$ + lwmin = 1_${ik}$ + if( n>1_${ik}$ .and. wantz ) then + lwmin = 1_${ik}$ + 4_${ik}$*n + n**2_${ik}$ + liwmin = 3_${ik}$ + 5_${ik}$*n end if if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( ldz<1 .or. ( wantz .and. ldzzero .and. tnrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / tnrm end if - if( iscale==1 ) then - call stdlib_sscal( n, sigma, d, 1 ) - call stdlib_sscal( n-1, sigma, e( 1 ), 1 ) + if( iscale==1_${ik}$ ) then + call stdlib${ii}$_sscal( n, sigma, d, 1_${ik}$ ) + call stdlib${ii}$_sscal( n-1, sigma, e( 1_${ik}$ ), 1_${ik}$ ) end if - ! for eigenvalues only, call stdlib_ssterf. for eigenvalues and - ! eigenvectors, call stdlib_sstedc. + ! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvalues and + ! eigenvectors, call stdlib${ii}$_sstedc. if( .not.wantz ) then - call stdlib_ssterf( n, d, e, info ) + call stdlib${ii}$_ssterf( n, d, e, info ) else - call stdlib_sstedc( 'I', n, d, e, z, ldz, work, lwork, iwork, liwork,info ) + call stdlib${ii}$_sstedc( 'I', n, d, e, z, ldz, work, lwork, iwork, liwork,info ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 )call stdlib_sscal( n, one / sigma, d, 1 ) - work( 1 ) = lwmin - iwork( 1 ) = liwmin + if( iscale==1_${ik}$ )call stdlib${ii}$_sscal( n, one / sigma, d, 1_${ik}$ ) + work( 1_${ik}$ ) = lwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_sstevd + end subroutine stdlib${ii}$_sstevd - subroutine stdlib_ssyevd( jobz, uplo, n, a, lda, w, work, lwork, iwork,liwork, info ) + subroutine stdlib${ii}$_ssyevd( jobz, uplo, n, a, lda, w, work, lwork, iwork,liwork, info ) !! SSYEVD computes all eigenvalues and, optionally, eigenvectors of a !! real symmetric matrix A. If eigenvectors are desired, it uses a !! divide and conquer algorithm. @@ -68137,17 +68140,17 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, liwork, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, liwork, lwork, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: w(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, lquery, wantz - integer(ilp) :: iinfo, inde, indtau, indwk2, indwrk, iscale, liopt, liwmin, llwork, & + integer(${ik}$) :: iinfo, inde, indtau, indwk2, indwrk, iscale, liopt, liwmin, llwork, & llwrk2, lopt, lwmin real(sp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! Intrinsic Functions @@ -68156,105 +68159,105 @@ module stdlib_linalg_lapack_s ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) lower = stdlib_lsame( uplo, 'L' ) - lquery = ( lwork==-1 .or. liwork==-1 ) - info = 0 + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldazero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 )call stdlib_slascl( uplo, 0, 0, one, sigma, n, n, a, lda, info ) - ! call stdlib_ssytrd to reduce symmetric matrix to tridiagonal form. - inde = 1 + if( iscale==1_${ik}$ )call stdlib${ii}$_slascl( uplo, 0_${ik}$, 0_${ik}$, one, sigma, n, n, a, lda, info ) + ! call stdlib${ii}$_ssytrd to reduce symmetric matrix to tridiagonal form. + inde = 1_${ik}$ indtau = inde + n indwrk = indtau + n - llwork = lwork - indwrk + 1 + llwork = lwork - indwrk + 1_${ik}$ indwk2 = indwrk + n*n - llwrk2 = lwork - indwk2 + 1 - call stdlib_ssytrd( uplo, n, a, lda, w, work( inde ), work( indtau ),work( indwrk ), & + llwrk2 = lwork - indwk2 + 1_${ik}$ + call stdlib${ii}$_ssytrd( uplo, n, a, lda, w, work( inde ), work( indtau ),work( indwrk ), & llwork, iinfo ) - ! for eigenvalues only, call stdlib_ssterf. for eigenvectors, first call - ! stdlib_sstedc to generate the eigenvector matrix, work(indwrk), of the - ! tridiagonal matrix, then call stdlib_sormtr to multiply it by the + ! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvectors, first call + ! stdlib${ii}$_sstedc to generate the eigenvector matrix, work(indwrk), of the + ! tridiagonal matrix, then call stdlib${ii}$_sormtr to multiply it by the ! householder transformations stored in a. if( .not.wantz ) then - call stdlib_ssterf( n, w, work( inde ), info ) + call stdlib${ii}$_ssterf( n, w, work( inde ), info ) else - call stdlib_sstedc( 'I', n, w, work( inde ), work( indwrk ), n,work( indwk2 ), & + call stdlib${ii}$_sstedc( 'I', n, w, work( inde ), work( indwrk ), n,work( indwk2 ), & llwrk2, iwork, liwork, info ) - call stdlib_sormtr( 'L', uplo, 'N', n, n, a, lda, work( indtau ),work( indwrk ), n, & + call stdlib${ii}$_sormtr( 'L', uplo, 'N', n, n, a, lda, work( indtau ),work( indwrk ), n, & work( indwk2 ), llwrk2, iinfo ) - call stdlib_slacpy( 'A', n, n, work( indwrk ), n, a, lda ) + call stdlib${ii}$_slacpy( 'A', n, n, work( indwrk ), n, a, lda ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 )call stdlib_sscal( n, one / sigma, w, 1 ) - work( 1 ) = lopt - iwork( 1 ) = liopt + if( iscale==1_${ik}$ )call stdlib${ii}$_sscal( n, one / sigma, w, 1_${ik}$ ) + work( 1_${ik}$ ) = lopt + iwork( 1_${ik}$ ) = liopt return - end subroutine stdlib_ssyevd + end subroutine stdlib${ii}$_ssyevd - subroutine stdlib_ssygvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, iwork, liwork,& + subroutine stdlib${ii}$_ssygvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, iwork, liwork,& !! SSYGVD computes all the eigenvalues, and optionally, the eigenvectors !! of a real generalized symmetric-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and @@ -68272,10 +68275,10 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: itype, lda, ldb, liwork, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: itype, lda, ldb, liwork, lwork, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(inout) :: a(lda,*), b(ldb,*) real(sp), intent(out) :: w(*), work(*) ! ===================================================================== @@ -68283,51 +68286,51 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: lquery, upper, wantz character :: trans - integer(ilp) :: liopt, liwmin, lopt, lwmin + integer(${ik}$) :: liopt, liwmin, lopt, lwmin ! Intrinsic Functions intrinsic :: max,real ! Executable Statements ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) upper = stdlib_lsame( uplo, 'U' ) - lquery = ( lwork==-1 .or. liwork==-1 ) - info = 0 - if( n<=1 ) then - liwmin = 1 - lwmin = 1 + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) + info = 0_${ik}$ + if( n<=1_${ik}$ ) then + liwmin = 1_${ik}$ + lwmin = 1_${ik}$ else if( wantz ) then - liwmin = 3 + 5*n - lwmin = 1 + 6*n + 2*n**2 + liwmin = 3_${ik}$ + 5_${ik}$*n + lwmin = 1_${ik}$ + 6_${ik}$*n + 2_${ik}$*n**2_${ik}$ else - liwmin = 1 - lwmin = 2*n + 1 + liwmin = 1_${ik}$ + lwmin = 2_${ik}$*n + 1_${ik}$ end if lopt = lwmin liopt = liwmin - if( itype<1 .or. itype>3 ) then - info = -1 + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( ldazero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then - call stdlib_slascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_slascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) else - call stdlib_slascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_slascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) end if end if - ! call stdlib_ssbtrd to reduce symmetric band matrix to tridiagonal form. - inde = 1 + ! call stdlib${ii}$_ssbtrd to reduce symmetric band matrix to tridiagonal form. + inde = 1_${ik}$ indwrk = inde + n indwk2 = indwrk + n*n - llwrk2 = lwork - indwk2 + 1 - call stdlib_ssbtrd( jobz, uplo, n, kd, ab, ldab, w, work( inde ), z, ldz,work( indwrk )& + llwrk2 = lwork - indwk2 + 1_${ik}$ + call stdlib${ii}$_ssbtrd( jobz, uplo, n, kd, ab, ldab, w, work( inde ), z, ldz,work( indwrk )& , iinfo ) - ! for eigenvalues only, call stdlib_ssterf. for eigenvectors, call stdlib_sstedc. + ! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvectors, call stdlib${ii}$_sstedc. if( .not.wantz ) then - call stdlib_ssterf( n, w, work( inde ), info ) + call stdlib${ii}$_ssterf( n, w, work( inde ), info ) else - call stdlib_sstedc( 'I', n, w, work( inde ), work( indwrk ), n,work( indwk2 ), & + call stdlib${ii}$_sstedc( 'I', n, w, work( inde ), work( indwrk ), n,work( indwk2 ), & llwrk2, iwork, liwork, info ) - call stdlib_sgemm( 'N', 'N', n, n, n, one, z, ldz, work( indwrk ), n,zero, work( & + call stdlib${ii}$_sgemm( 'N', 'N', n, n, n, one, z, ldz, work( indwrk ), n,zero, work( & indwk2 ), n ) - call stdlib_slacpy( 'A', n, n, work( indwk2 ), n, z, ldz ) + call stdlib${ii}$_slacpy( 'A', n, n, work( indwk2 ), n, z, ldz ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 )call stdlib_sscal( n, one / sigma, w, 1 ) - work( 1 ) = lwmin - iwork( 1 ) = liwmin + if( iscale==1_${ik}$ )call stdlib${ii}$_sscal( n, one / sigma, w, 1_${ik}$ ) + work( 1_${ik}$ ) = lwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_ssbevd + end subroutine stdlib${ii}$_ssbevd - pure subroutine stdlib_ssbgvd( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w,z, ldz, work, & + pure subroutine stdlib${ii}$_ssbgvd( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w,z, ldz, work, & !! SSBGVD computes all the eigenvalues, and optionally, the eigenvectors !! of a real generalized symmetric-definite banded eigenproblem, of the !! form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and @@ -68525,10 +68528,10 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ka, kb, ldab, ldbb, ldz, liwork, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ka, kb, ldab, ldbb, ldz, liwork, lwork, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(inout) :: ab(ldab,*), bb(ldbb,*) real(sp), intent(out) :: w(*), work(*), z(ldz,*) ! ===================================================================== @@ -68536,51 +68539,51 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: lquery, upper, wantz character :: vect - integer(ilp) :: iinfo, inde, indwk2, indwrk, liwmin, llwrk2, lwmin + integer(${ik}$) :: iinfo, inde, indwk2, indwrk, liwmin, llwrk2, lwmin ! Executable Statements ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) upper = stdlib_lsame( uplo, 'U' ) - lquery = ( lwork==-1 .or. liwork==-1 ) - info = 0 - if( n<=1 ) then - liwmin = 1 - lwmin = 1 + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) + info = 0_${ik}$ + if( n<=1_${ik}$ ) then + liwmin = 1_${ik}$ + lwmin = 1_${ik}$ else if( wantz ) then - liwmin = 3 + 5*n - lwmin = 1 + 5*n + 2*n**2 + liwmin = 3_${ik}$ + 5_${ik}$*n + lwmin = 1_${ik}$ + 5_${ik}$*n + 2_${ik}$*n**2_${ik}$ else - liwmin = 1 - lwmin = 2*n + liwmin = 1_${ik}$ + lwmin = 2_${ik}$*n end if if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ka<0 ) then - info = -4 - else if( kb<0 .or. kb>ka ) 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( ldabzero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then - call stdlib_sscal( ( n*( n+1 ) ) / 2, sigma, ap, 1 ) + if( iscale==1_${ik}$ ) then + call stdlib${ii}$_sscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ ) end if - ! call stdlib_ssptrd to reduce symmetric packed matrix to tridiagonal form. - inde = 1 + ! call stdlib${ii}$_ssptrd to reduce symmetric packed matrix to tridiagonal form. + inde = 1_${ik}$ indtau = inde + n - call stdlib_ssptrd( uplo, n, ap, w, work( inde ), work( indtau ), iinfo ) - ! for eigenvalues only, call stdlib_ssterf. for eigenvectors, first call - ! stdlib_sstedc to generate the eigenvector matrix, work(indwrk), of the - ! tridiagonal matrix, then call stdlib_sopmtr to multiply it by the + call stdlib${ii}$_ssptrd( uplo, n, ap, w, work( inde ), work( indtau ), iinfo ) + ! for eigenvalues only, call stdlib${ii}$_ssterf. for eigenvectors, first call + ! stdlib${ii}$_sstedc to generate the eigenvector matrix, work(indwrk), of the + ! tridiagonal matrix, then call stdlib${ii}$_sopmtr to multiply it by the ! householder transformations represented in ap. if( .not.wantz ) then - call stdlib_ssterf( n, w, work( inde ), info ) + call stdlib${ii}$_ssterf( n, w, work( inde ), info ) else indwrk = indtau + n - llwork = lwork - indwrk + 1 - call stdlib_sstedc( 'I', n, w, work( inde ), z, ldz, work( indwrk ),llwork, iwork, & + llwork = lwork - indwrk + 1_${ik}$ + call stdlib${ii}$_sstedc( 'I', n, w, work( inde ), z, ldz, work( indwrk ),llwork, iwork, & liwork, info ) - call stdlib_sopmtr( 'L', uplo, 'N', n, n, ap, work( indtau ), z, ldz,work( indwrk ),& + call stdlib${ii}$_sopmtr( 'L', uplo, 'N', n, n, ap, work( indtau ), z, ldz,work( indwrk ),& iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 )call stdlib_sscal( n, one / sigma, w, 1 ) - work( 1 ) = lwmin - iwork( 1 ) = liwmin + if( iscale==1_${ik}$ )call stdlib${ii}$_sscal( n, one / sigma, w, 1_${ik}$ ) + work( 1_${ik}$ ) = lwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_sspevd + end subroutine stdlib${ii}$_sspevd - subroutine stdlib_sspgvd( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,lwork, iwork, liwork,& + subroutine stdlib${ii}$_sspgvd( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,lwork, iwork, liwork,& !! SSPGVD computes all the eigenvalues, and optionally, the eigenvectors !! of a real generalized symmetric-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and @@ -68768,59 +68771,59 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: itype, ldz, liwork, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: itype, ldz, liwork, lwork, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(inout) :: ap(*), bp(*) real(sp), intent(out) :: w(*), work(*), z(ldz,*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, upper, wantz character :: trans - integer(ilp) :: j, liwmin, lwmin, neig + integer(${ik}$) :: j, liwmin, lwmin, neig ! Intrinsic Functions intrinsic :: max,real ! Executable Statements ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) upper = stdlib_lsame( uplo, 'U' ) - lquery = ( lwork==-1 .or. liwork==-1 ) - info = 0 - if( itype<1 .or. itype>3 ) then - info = -1 + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( ldz<1 .or. ( wantz .and. ldz0 )neig = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )neig = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**t *y or inv(u)*y if( upper ) then @@ -68852,9 +68855,9 @@ module stdlib_linalg_lapack_s trans = 'T' end if do j = 1, neig - call stdlib_stpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_stpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**t *y if( upper ) then @@ -68863,17 +68866,17 @@ module stdlib_linalg_lapack_s trans = 'N' end if do j = 1, neig - call stdlib_stpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_stpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do end if end if - work( 1 ) = lwmin - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = lwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_sspgvd + end subroutine stdlib${ii}$_sspgvd - pure subroutine stdlib_sbdsdc( uplo, compq, n, d, e, u, ldu, vt, ldvt, q, iq,work, iwork, & + pure subroutine stdlib${ii}$_sbdsdc( uplo, compq, n, d, e, u, ldu, vt, ldvt, q, iq,work, iwork, & !! SBDSDC computes the singular value decomposition (SVD) of a real !! N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT, !! using a divide and conquer method, where S is a diagonal matrix @@ -68896,10 +68899,10 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: compq, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldu, ldvt, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldu, ldvt, n ! Array Arguments - integer(ilp), intent(out) :: iq(*), iwork(*) + integer(${ik}$), intent(out) :: iq(*), iwork(*) real(sp), intent(inout) :: d(*), e(*) real(sp), intent(out) :: q(*), u(ldu,*), vt(ldvt,*), work(*) ! ===================================================================== @@ -68908,7 +68911,7 @@ module stdlib_linalg_lapack_s ! ===================================================================== ! Local Scalars - integer(ilp) :: difl, difr, givcol, givnum, givptr, i, ic, icompq, ierr, ii, is, iu, & + integer(${ik}$) :: difl, difr, givcol, givnum, givptr, i, ic, icompq, ierr, ii, is, iu, & iuplo, ivt, j, k, kk, mlvl, nm1, nsize, perm, poles, qstart, smlsiz, smlszp, sqre, & start, wstart, z real(sp) :: cs, eps, orgnrm, p, r, sn @@ -68916,127 +68919,127 @@ module stdlib_linalg_lapack_s intrinsic :: real,abs,int,log,sign ! Executable Statements ! test the input parameters. - info = 0 - iuplo = 0 - if( stdlib_lsame( uplo, 'U' ) )iuplo = 1 - if( stdlib_lsame( uplo, 'L' ) )iuplo = 2 + info = 0_${ik}$ + iuplo = 0_${ik}$ + if( stdlib_lsame( uplo, 'U' ) )iuplo = 1_${ik}$ + if( stdlib_lsame( uplo, 'L' ) )iuplo = 2_${ik}$ if( stdlib_lsame( compq, 'N' ) ) then - icompq = 0 + icompq = 0_${ik}$ else if( stdlib_lsame( compq, 'P' ) ) then - icompq = 1 + icompq = 1_${ik}$ else if( stdlib_lsame( compq, 'I' ) ) then - icompq = 2 + icompq = 2_${ik}$ else - icompq = -1 + icompq = -1_${ik}$ end if - if( iuplo==0 ) then - info = -1 - else if( icompq<0 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ( ldu<1 ) .or. ( ( icompq==2 ) .and. ( ldu=eps ) then ! a subproblem with e(nm1) not too small but i = nm1. - nsize = n - start + 1 + nsize = n - start + 1_${ik}$ else ! a subproblem with e(nm1) small. this implies an ! 1-by-1 subproblem at d(n). solve this 1-by-1 problem ! first. - nsize = i - start + 1 - if( icompq==2 ) then + nsize = i - start + 1_${ik}$ + if( icompq==2_${ik}$ ) then u( n, n ) = sign( one, d( n ) ) vt( n, n ) = one - else if( icompq==1 ) then + else if( icompq==1_${ik}$ ) then q( n+( qstart-1 )*n ) = sign( one, d( n ) ) q( n+( smlsiz+qstart-1 )*n ) = one end if d( n ) = abs( d( n ) ) end if - if( icompq==2 ) then - call stdlib_slasd0( nsize, sqre, d( start ), e( start ),u( start, start ), & + if( icompq==2_${ik}$ ) then + call stdlib${ii}$_slasd0( nsize, sqre, d( start ), e( start ),u( start, start ), & ldu, vt( start, start ),ldvt, smlsiz, iwork, work( wstart ), info ) else - call stdlib_slasda( icompq, smlsiz, nsize, sqre, d( start ),e( start ), q( & + call stdlib${ii}$_slasda( icompq, smlsiz, nsize, sqre, d( start ),e( start ), q( & start+( iu+qstart-2 )*n ), n,q( start+( ivt+qstart-2 )*n ),iq( start+k*n ), q(& start+( difl+qstart-2 )*n ), q( start+( difr+qstart-2 )*n ),q( start+( z+& qstart-2 )*n ),q( start+( poles+qstart-2 )*n ),iq( start+givptr*n ), iq( & @@ -69082,18 +69085,18 @@ module stdlib_linalg_lapack_s start+( ic+qstart-2 )*n ),q( start+( is+qstart-2 )*n ),work( wstart ), iwork,& info ) end if - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if - start = i + 1 + start = i + 1_${ik}$ end if end do loop_30 ! unscale - call stdlib_slascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, n, 1_${ik}$, d, n, ierr ) 40 continue ! use selection sort to minimize swaps of singular vectors do ii = 2, n - i = ii - 1 + i = ii - 1_${ik}$ kk = i p = d( i ) do j = ii, n @@ -69105,33 +69108,33 @@ module stdlib_linalg_lapack_s if( kk/=i ) then d( kk ) = d( i ) d( i ) = p - if( icompq==1 ) then + if( icompq==1_${ik}$ ) then iq( i ) = kk - else if( icompq==2 ) then - call stdlib_sswap( n, u( 1, i ), 1, u( 1, kk ), 1 ) - call stdlib_sswap( n, vt( i, 1 ), ldvt, vt( kk, 1 ), ldvt ) + else if( icompq==2_${ik}$ ) then + call stdlib${ii}$_sswap( n, u( 1_${ik}$, i ), 1_${ik}$, u( 1_${ik}$, kk ), 1_${ik}$ ) + call stdlib${ii}$_sswap( n, vt( i, 1_${ik}$ ), ldvt, vt( kk, 1_${ik}$ ), ldvt ) end if - else if( icompq==1 ) then + else if( icompq==1_${ik}$ ) then iq( i ) = i end if end do ! if icompq = 1, use iq(n,1) as the indicator for uplo - if( icompq==1 ) then - if( iuplo==1 ) then - iq( n ) = 1 + if( icompq==1_${ik}$ ) then + if( iuplo==1_${ik}$ ) then + iq( n ) = 1_${ik}$ else - iq( n ) = 0 + iq( n ) = 0_${ik}$ end if end if ! if b is lower bidiagonal, update u by those givens rotations ! which rotated b to be upper bidiagonal - if( ( iuplo==2 ) .and. ( icompq==2 ) )call stdlib_slasr( 'L', 'V', 'B', n, n, work( 1 )& + if( ( iuplo==2_${ik}$ ) .and. ( icompq==2_${ik}$ ) )call stdlib${ii}$_slasr( 'L', 'V', 'B', n, n, work( 1_${ik}$ )& , work( n ), u, ldu ) return - end subroutine stdlib_sbdsdc + end subroutine stdlib${ii}$_sbdsdc - pure subroutine stdlib_sbdsqr( uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u,ldu, c, ldc, work, & + pure subroutine stdlib${ii}$_sbdsqr( uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u,ldu, c, ldc, work, & !! SBDSQR computes the singular values and, optionally, the right and/or !! left singular vectors from the singular value decomposition (SVD) of !! a real N-by-N (upper or lower) bidiagonal matrix B using the implicit @@ -69162,8 +69165,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) :: ldc, ldu, ldvt, n, ncc, ncvt, nru + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldc, ldu, ldvt, n, ncc, ncvt, nru ! Array Arguments real(sp), intent(inout) :: c(ldc,*), d(*), e(*), u(ldu,*), vt(ldvt,*) real(sp), intent(out) :: work(*) @@ -69172,7 +69175,7 @@ module stdlib_linalg_lapack_s real(sp), parameter :: hndrth = 0.01_sp real(sp), parameter :: hndrd = 100.0_sp real(sp), parameter :: meigth = -0.125_sp - integer(ilp), parameter :: maxitr = 6 + integer(${ik}$), parameter :: maxitr = 6_${ik}$ @@ -69183,7 +69186,7 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: lower, rotate - integer(ilp) :: i, idir, isub, iter, iterdivn, j, ll, lll, m, maxitdivn, nm1, nm12, & + integer(${ik}$) :: i, idir, isub, iter, iterdivn, j, ll, lll, m, maxitdivn, nm1, nm12, & nm13, oldll, oldm real(sp) :: abse, abss, cosl, cosr, cs, eps, f, g, h, mu, oldcs, oldsn, r, shift, & sigmn, sigmx, sinl, sinr, sll, smax, smin, sminl, sminoa, sn, thresh, tol, tolmul, & @@ -69192,52 +69195,52 @@ module stdlib_linalg_lapack_s intrinsic :: abs,max,min,real,sign,sqrt ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ lower = stdlib_lsame( uplo, 'L' ) if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.lower ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( ncvt<0 ) then - info = -3 - else if( nru<0 ) then - info = -4 - else if( ncc<0 ) then - info = -5 - else if( ( ncvt==0 .and. ldvt<1 ) .or.( ncvt>0 .and. ldvt0 .and. ldc0_${ik}$ .and. ldvt0_${ik}$ .and. ldc0 ) .or. ( nru>0 ) .or. ( ncc>0 ) + rotate = ( ncvt>0_${ik}$ ) .or. ( nru>0_${ik}$ ) .or. ( ncc>0_${ik}$ ) ! if no singular vectors desired, use qd algorithm if( .not.rotate ) then - call stdlib_slasq1( n, d, e, work, info ) + call stdlib${ii}$_slasq1( n, d, e, work, info ) ! if info equals 2, dqds didn't finish, try to finish if( info /= 2 ) return - info = 0 + info = 0_${ik}$ end if - nm1 = n - 1 + nm1 = n - 1_${ik}$ nm12 = nm1 + nm1 nm13 = nm12 + nm1 - idir = 0 + idir = 0_${ik}$ ! get machine constants - eps = stdlib_slamch( 'EPSILON' ) - unfl = stdlib_slamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_slamch( 'EPSILON' ) + unfl = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) ! if matrix lower bidiagonal, rotate to be upper bidiagonal ! by applying givens rotations on the left if( lower ) then do i = 1, n - 1 - call stdlib_slartg( d( i ), e( i ), cs, sn, r ) + call stdlib${ii}$_slartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) @@ -69245,9 +69248,9 @@ module stdlib_linalg_lapack_s work( nm1+i ) = sn end do ! update singular vectors if desired - if( nru>0 )call stdlib_slasr( 'R', 'V', 'F', nru, n, work( 1 ), work( n ), u,ldu ) + if( nru>0_${ik}$ )call stdlib${ii}$_slasr( 'R', 'V', 'F', nru, n, work( 1_${ik}$ ), work( n ), u,ldu ) - if( ncc>0 )call stdlib_slasr( 'L', 'V', 'F', n, ncc, work( 1 ), work( n ), c,ldc ) + if( ncc>0_${ik}$ )call stdlib${ii}$_slasr( 'L', 'V', 'F', n, ncc, work( 1_${ik}$ ), work( n ), c,ldc ) end if ! compute singular values to relative accuracy tol @@ -69266,7 +69269,7 @@ module stdlib_linalg_lapack_s sminl = zero if( tol>=zero ) then ! relative accuracy desired - sminoa = abs( d( 1 ) ) + sminoa = abs( d( 1_${ik}$ ) ) if( sminoa==zero )go to 50 mu = sminoa do i = 2, n @@ -69285,10 +69288,10 @@ module stdlib_linalg_lapack_s ! (maxit is the maximum number of passes through the inner ! loop permitted before nonconvergence signalled.) maxitdivn = maxitr*n - iterdivn = 0 - iter = -1 - oldll = -1 - oldm = -1 + iterdivn = 0_${ik}$ + iter = -1_${ik}$ + oldll = -1_${ik}$ + oldm = -1_${ik}$ ! m points to last element of unconverged part of matrix m = n ! begin main iteration loop @@ -69297,7 +69300,7 @@ module stdlib_linalg_lapack_s if( m<=1 )go to 160 if( iter>=n ) then iter = iter - n - iterdivn = iterdivn + 1 + iterdivn = iterdivn + 1_${ik}$ if( iterdivn>=maxitdivn )go to 200 end if ! find diagonal block of matrix to work on @@ -69313,33 +69316,33 @@ module stdlib_linalg_lapack_s smin = min( smin, abss ) smax = max( smax, abss, abse ) end do - ll = 0 + ll = 0_${ik}$ go to 90 80 continue e( ll ) = zero ! matrix splits since e(ll) = 0 if( ll==m-1 ) then ! convergence of bottom singular value, return to top of loop - m = m - 1 + m = m - 1_${ik}$ go to 60 end if 90 continue - ll = ll + 1 + ll = ll + 1_${ik}$ ! e(ll) through e(m-1) are nonzero, e(ll-1) is zero if( ll==m-1 ) then ! 2 by 2 block, handle separately - call stdlib_slasv2( d( m-1 ), e( m-1 ), d( m ), sigmn, sigmx, sinr,cosr, sinl, cosl & + call stdlib${ii}$_slasv2( d( m-1 ), e( m-1 ), d( m ), sigmn, sigmx, sinr,cosr, sinl, cosl & ) d( m-1 ) = sigmx e( m-1 ) = zero d( m ) = sigmn ! compute singular vectors, if desired - if( ncvt>0 )call stdlib_srot( ncvt, vt( m-1, 1 ), ldvt, vt( m, 1 ), ldvt, cosr,sinr & + if( ncvt>0_${ik}$ )call stdlib${ii}$_srot( ncvt, vt( m-1, 1_${ik}$ ), ldvt, vt( m, 1_${ik}$ ), ldvt, cosr,sinr & ) - if( nru>0 )call stdlib_srot( nru, u( 1, m-1 ), 1, u( 1, m ), 1, cosl, sinl ) - if( ncc>0 )call stdlib_srot( ncc, c( m-1, 1 ), ldc, c( m, 1 ), ldc, cosl,sinl ) + if( nru>0_${ik}$ )call stdlib${ii}$_srot( nru, u( 1_${ik}$, m-1 ), 1_${ik}$, u( 1_${ik}$, m ), 1_${ik}$, cosl, sinl ) + if( ncc>0_${ik}$ )call stdlib${ii}$_srot( ncc, c( m-1, 1_${ik}$ ), ldc, c( m, 1_${ik}$ ), ldc, cosl,sinl ) - m = m - 2 + m = m - 2_${ik}$ go to 60 end if ! if working on new submatrix, choose shift direction @@ -69347,14 +69350,14 @@ module stdlib_linalg_lapack_s if( ll>oldm .or. m=abs( d( m ) ) ) then ! chase bulge from top (big end) to bottom (small end) - idir = 1 + idir = 1_${ik}$ else ! chase bulge from bottom (big end) to top (small end) - idir = 2 + idir = 2_${ik}$ end if end if ! apply convergence tests - if( idir==1 ) then + if( idir==1_${ik}$ ) then ! run convergence test in forward direction ! first apply standard test to bottom of matrix if( abs( e( m-1 ) )<=abs( tol )*abs( d( m ) ) .or.( tolzero ) then - if( ( shift / sll )**2ll )e( i-1 ) = oldsn*r - call stdlib_slartg( oldcs*r, d( i+1 )*sn, oldcs, oldsn, d( i ) ) + call stdlib${ii}$_slartg( oldcs*r, d( i+1 )*sn, oldcs, oldsn, d( i ) ) work( i-ll+1 ) = cs work( i-ll+1+nm1 ) = sn work( i-ll+1+nm12 ) = oldcs @@ -69442,12 +69445,12 @@ module stdlib_linalg_lapack_s d( m ) = h*oldcs e( m-1 ) = h*oldsn ! update singular vectors - if( ncvt>0 )call stdlib_slasr( 'L', 'V', 'F', m-ll+1, ncvt, work( 1 ),work( n ), & - vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_slasr( 'R', 'V', 'F', nru, m-ll+1, work( nm12+1 ),work( & - nm13+1 ), u( 1, ll ), ldu ) - if( ncc>0 )call stdlib_slasr( 'L', 'V', 'F', m-ll+1, ncc, work( nm12+1 ),work( & - nm13+1 ), c( ll, 1 ), ldc ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_slasr( 'L', 'V', 'F', m-ll+1, ncvt, work( 1_${ik}$ ),work( n ), & + vt( ll, 1_${ik}$ ), ldvt ) + if( nru>0_${ik}$ )call stdlib${ii}$_slasr( 'R', 'V', 'F', nru, m-ll+1, work( nm12+1 ),work( & + nm13+1 ), u( 1_${ik}$, ll ), ldu ) + if( ncc>0_${ik}$ )call stdlib${ii}$_slasr( 'L', 'V', 'F', m-ll+1, ncc, work( nm12+1 ),work( & + nm13+1 ), c( ll, 1_${ik}$ ), ldc ) ! test convergence if( abs( e( m-1 ) )<=thresh )e( m-1 ) = zero else @@ -69456,9 +69459,9 @@ module stdlib_linalg_lapack_s cs = one oldcs = one do i = m, ll + 1, -1 - call stdlib_slartg( d( i )*cs, e( i-1 ), cs, sn, r ) + call stdlib${ii}$_slartg( d( i )*cs, e( i-1 ), cs, sn, r ) if( i0 )call stdlib_slasr( 'L', 'V', 'B', m-ll+1, ncvt, work( nm12+1 ),work( & - nm13+1 ), vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_slasr( 'R', 'V', 'B', nru, m-ll+1, work( 1 ),work( n ), u(& - 1, ll ), ldu ) - if( ncc>0 )call stdlib_slasr( 'L', 'V', 'B', m-ll+1, ncc, work( 1 ),work( n ), c(& - ll, 1 ), ldc ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_slasr( 'L', 'V', 'B', m-ll+1, ncvt, work( nm12+1 ),work( & + nm13+1 ), vt( ll, 1_${ik}$ ), ldvt ) + if( nru>0_${ik}$ )call stdlib${ii}$_slasr( 'R', 'V', 'B', nru, m-ll+1, work( 1_${ik}$ ),work( n ), u(& + 1_${ik}$, ll ), ldu ) + if( ncc>0_${ik}$ )call stdlib${ii}$_slasr( 'L', 'V', 'B', m-ll+1, ncc, work( 1_${ik}$ ),work( n ), c(& + ll, 1_${ik}$ ), ldc ) ! test convergence if( abs( e( ll ) )<=thresh )e( ll ) = zero end if else ! use nonzero shift - if( idir==1 ) then + if( idir==1_${ik}$ ) then ! chase bulge from top to bottom ! save cosines and sines for later singular vector updates f = ( abs( d( ll ) )-shift )*( sign( one, d( ll ) )+shift / d( ll ) ) g = e( ll ) do i = ll, m - 1 - call stdlib_slartg( f, g, cosr, sinr, r ) + call stdlib${ii}$_slartg( f, g, cosr, sinr, r ) if( i>ll )e( i-1 ) = r f = cosr*d( i ) + sinr*e( i ) e( i ) = cosr*e( i ) - sinr*d( i ) g = sinr*d( i+1 ) d( i+1 ) = cosr*d( i+1 ) - call stdlib_slartg( f, g, cosl, sinl, r ) + call stdlib${ii}$_slartg( f, g, cosl, sinl, r ) d( i ) = r f = cosl*e( i ) + sinl*d( i+1 ) d( i+1 ) = cosl*d( i+1 ) - sinl*e( i ) @@ -69506,12 +69509,12 @@ module stdlib_linalg_lapack_s end do e( m-1 ) = f ! update singular vectors - if( ncvt>0 )call stdlib_slasr( 'L', 'V', 'F', m-ll+1, ncvt, work( 1 ),work( n ), & - vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_slasr( 'R', 'V', 'F', nru, m-ll+1, work( nm12+1 ),work( & - nm13+1 ), u( 1, ll ), ldu ) - if( ncc>0 )call stdlib_slasr( 'L', 'V', 'F', m-ll+1, ncc, work( nm12+1 ),work( & - nm13+1 ), c( ll, 1 ), ldc ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_slasr( 'L', 'V', 'F', m-ll+1, ncvt, work( 1_${ik}$ ),work( n ), & + vt( ll, 1_${ik}$ ), ldvt ) + if( nru>0_${ik}$ )call stdlib${ii}$_slasr( 'R', 'V', 'F', nru, m-ll+1, work( nm12+1 ),work( & + nm13+1 ), u( 1_${ik}$, ll ), ldu ) + if( ncc>0_${ik}$ )call stdlib${ii}$_slasr( 'L', 'V', 'F', m-ll+1, ncc, work( nm12+1 ),work( & + nm13+1 ), c( ll, 1_${ik}$ ), ldc ) ! test convergence if( abs( e( m-1 ) )<=thresh )e( m-1 ) = zero else @@ -69520,13 +69523,13 @@ module stdlib_linalg_lapack_s f = ( abs( d( m ) )-shift )*( sign( one, d( m ) )+shift /d( m ) ) g = e( m-1 ) do i = m, ll + 1, -1 - call stdlib_slartg( f, g, cosr, sinr, r ) + call stdlib${ii}$_slartg( f, g, cosr, sinr, r ) if( i0 )call stdlib_slasr( 'L', 'V', 'B', m-ll+1, ncvt, work( nm12+1 ),work( & - nm13+1 ), vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_slasr( 'R', 'V', 'B', nru, m-ll+1, work( 1 ),work( n ), u(& - 1, ll ), ldu ) - if( ncc>0 )call stdlib_slasr( 'L', 'V', 'B', m-ll+1, ncc, work( 1 ),work( n ), c(& - ll, 1 ), ldc ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_slasr( 'L', 'V', 'B', m-ll+1, ncvt, work( nm12+1 ),work( & + nm13+1 ), vt( ll, 1_${ik}$ ), ldvt ) + if( nru>0_${ik}$ )call stdlib${ii}$_slasr( 'R', 'V', 'B', nru, m-ll+1, work( 1_${ik}$ ),work( n ), u(& + 1_${ik}$, ll ), ldu ) + if( ncc>0_${ik}$ )call stdlib${ii}$_slasr( 'L', 'V', 'B', m-ll+1, ncc, work( 1_${ik}$ ),work( n ), c(& + ll, 1_${ik}$ ), ldc ) end if end if ! qr iteration finished, go back and check convergence @@ -69559,15 +69562,15 @@ module stdlib_linalg_lapack_s if( d( i )0 )call stdlib_sscal( ncvt, negone, vt( i, 1 ), ldvt ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_sscal( ncvt, negone, vt( i, 1_${ik}$ ), ldvt ) end if end do ! sort the singular values into decreasing order (insertion sort on ! singular values, but only one transposition per singular vector) do i = 1, n - 1 ! scan for smallest d(i) - isub = 1 - smin = d( 1 ) + isub = 1_${ik}$ + smin = d( 1_${ik}$ ) do j = 2, n + 1 - i if( d( j )<=smin ) then isub = j @@ -69578,26 +69581,26 @@ module stdlib_linalg_lapack_s ! swap singular values and vectors d( isub ) = d( n+1-i ) d( n+1-i ) = smin - if( ncvt>0 )call stdlib_sswap( ncvt, vt( isub, 1 ), ldvt, vt( n+1-i, 1 ),ldvt ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_sswap( ncvt, vt( isub, 1_${ik}$ ), ldvt, vt( n+1-i, 1_${ik}$ ),ldvt ) - if( nru>0 )call stdlib_sswap( nru, u( 1, isub ), 1, u( 1, n+1-i ), 1 ) - if( ncc>0 )call stdlib_sswap( ncc, c( isub, 1 ), ldc, c( n+1-i, 1 ), ldc ) + if( nru>0_${ik}$ )call stdlib${ii}$_sswap( nru, u( 1_${ik}$, isub ), 1_${ik}$, u( 1_${ik}$, n+1-i ), 1_${ik}$ ) + if( ncc>0_${ik}$ )call stdlib${ii}$_sswap( ncc, c( isub, 1_${ik}$ ), ldc, c( n+1-i, 1_${ik}$ ), ldc ) end if end do go to 220 ! maximum number of iterations exceeded, failure to converge 200 continue - info = 0 + info = 0_${ik}$ do i = 1, n - 1 - if( e( i )/=zero )info = info + 1 + if( e( i )/=zero )info = info + 1_${ik}$ end do 220 continue return - end subroutine stdlib_sbdsqr + end subroutine stdlib${ii}$_sbdsqr - subroutine stdlib_sgees( jobvs, sort, select, n, a, lda, sdim, wr, wi,vs, ldvs, work, lwork, & + subroutine stdlib${ii}$_sgees( jobvs, sort, select, n, a, lda, sdim, wr, wi,vs, ldvs, work, lwork, & !! SGEES computes for an N-by-N real nonsymmetric matrix A, the !! eigenvalues, the real Schur form T, and, optionally, the matrix of !! Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). @@ -69617,8 +69620,8 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvs, sort - integer(ilp), intent(out) :: info, sdim - integer(ilp), intent(in) :: lda, ldvs, lwork, n + integer(${ik}$), intent(out) :: info, sdim + integer(${ik}$), intent(in) :: lda, ldvs, lwork, n ! Array Arguments logical(lk), intent(out) :: bwork(*) real(sp), intent(inout) :: a(lda,*) @@ -69629,83 +69632,83 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: cursl, lastsl, lquery, lst2sl, scalea, wantst, wantvs - integer(ilp) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, & + integer(${ik}$) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, & iwrk, maxwrk, minwrk real(sp) :: anrm, bignum, cscale, eps, s, sep, smlnum ! Local Arrays - integer(ilp) :: idum(1) - real(sp) :: dum(1) + integer(${ik}$) :: idum(1_${ik}$) + real(sp) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) wantvs = stdlib_lsame( jobvs, 'V' ) wantst = stdlib_lsame( sort, 'S' ) if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then - info = -2 - else if( n<0 ) then - info = -4 - else if( ldazero .and. anrm0 )info = ieval + if( ieval>0_${ik}$ )info = ieval ! sort eigenvalues if desired - if( wantst .and. info==0 ) then + if( wantst .and. info==0_${ik}$ ) then if( scalea ) then - call stdlib_slascl( 'G', 0, 0, cscale, anrm, n, 1, wr, n, ierr ) - call stdlib_slascl( 'G', 0, 0, cscale, anrm, n, 1, wi, n, ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wr, n, ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wi, n, ierr ) end if do i = 1, n bwork( i ) = select( wr( i ), wi( i ) ) end do ! reorder eigenvalues and transform schur vectors ! (workspace: none needed) - call stdlib_strsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, s, sep, & - work( iwrk ), lwork-iwrk+1, idum, 1,icond ) - if( icond>0 )info = n + icond + call stdlib${ii}$_strsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, s, sep, & + work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$,icond ) + if( icond>0_${ik}$ )info = n + icond end if if( wantvs ) then ! undo balancing ! (workspace: need n) - call stdlib_sgebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr ) + call stdlib${ii}$_sgebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr ) end if if( scalea ) then ! undo scaling for the schur form of a - call stdlib_slascl( 'H', 0, 0, cscale, anrm, n, n, a, lda, ierr ) - call stdlib_scopy( n, a, lda+1, wr, 1 ) + call stdlib${ii}$_slascl( 'H', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_scopy( n, a, lda+1, wr, 1_${ik}$ ) if( cscale==smlnum ) then ! if scaling back towards underflow, adjust wi if an ! offdiagonal element of a 2-by-2 block in the schur form ! underflows. - if( ieval>0 ) then - i1 = ieval + 1 - i2 = ihi - 1 - call stdlib_slascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wi,max( ilo-1, 1 ), & + if( ieval>0_${ik}$ ) then + i1 = ieval + 1_${ik}$ + i2 = ihi - 1_${ik}$ + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi,max( ilo-1, 1_${ik}$ ), & ierr ) else if( wantst ) then - i1 = 1 - i2 = n - 1 + i1 = 1_${ik}$ + i2 = n - 1_${ik}$ else i1 = ilo - i2 = ihi - 1 + i2 = ihi - 1_${ik}$ end if - inxt = i1 - 1 + inxt = i1 - 1_${ik}$ loop_20: do i = i1, i2 if( i1 )call stdlib_sswap( i-1, a( 1, i ), 1, a( 1, i+1 ), 1 ) - if( n>i+1 )call stdlib_sswap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), & + if( i>1_${ik}$ )call stdlib${ii}$_sswap( i-1, a( 1_${ik}$, i ), 1_${ik}$, a( 1_${ik}$, i+1 ), 1_${ik}$ ) + if( n>i+1 )call stdlib${ii}$_sswap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), & lda ) if( wantvs ) then - call stdlib_sswap( n, vs( 1, i ), 1, vs( 1, i+1 ), 1 ) + call stdlib${ii}$_sswap( n, vs( 1_${ik}$, i ), 1_${ik}$, vs( 1_${ik}$, i+1 ), 1_${ik}$ ) end if a( i, i+1 ) = a( i+1, i ) a( i+1, i ) = zero end if - inxt = i + 2 + inxt = i + 2_${ik}$ end if end do loop_20 end if ! undo scaling for the imaginary part of the eigenvalues - call stdlib_slascl( 'G', 0, 0, cscale, anrm, n-ieval, 1,wi( ieval+1 ), max( n-ieval,& - 1 ), ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-ieval, 1_${ik}$,wi( ieval+1 ), max( n-ieval,& + 1_${ik}$ ), ierr ) end if - if( wantst .and. info==0 ) then + if( wantst .and. info==0_${ik}$ ) then ! check if reordering successful lastsl = .true. lst2sl = .true. - sdim = 0 - ip = 0 + sdim = 0_${ik}$ + ip = 0_${ik}$ do i = 1, n cursl = select( wr( i ), wi( i ) ) if( wi( i )==zero ) then - if( cursl )sdim = sdim + 1 - ip = 0 - if( cursl .and. .not.lastsl )info = n + 2 + if( cursl )sdim = sdim + 1_${ik}$ + ip = 0_${ik}$ + if( cursl .and. .not.lastsl )info = n + 2_${ik}$ else - if( ip==1 ) then + if( ip==1_${ik}$ ) then ! last eigenvalue of conjugate pair cursl = cursl .or. lastsl lastsl = cursl - if( cursl )sdim = sdim + 2 - ip = -1 - if( cursl .and. .not.lst2sl )info = n + 2 + if( cursl )sdim = sdim + 2_${ik}$ + ip = -1_${ik}$ + if( cursl .and. .not.lst2sl )info = n + 2_${ik}$ else ! first eigenvalue of conjugate pair - ip = 1 + ip = 1_${ik}$ end if end if lst2sl = lastsl lastsl = cursl end do end if - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_sgees + end subroutine stdlib${ii}$_sgees - subroutine stdlib_sgeesx( jobvs, sort, select, sense, n, a, lda, sdim,wr, wi, vs, ldvs, & + subroutine stdlib${ii}$_sgeesx( jobvs, sort, select, sense, n, a, lda, sdim,wr, wi, vs, ldvs, & !! SGEESX computes for an N-by-N real nonsymmetric matrix A, the !! eigenvalues, the real Schur form T, and, optionally, the matrix of !! Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). @@ -69869,12 +69872,12 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvs, sense, sort - integer(ilp), intent(out) :: info, sdim - integer(ilp), intent(in) :: lda, ldvs, liwork, lwork, n + integer(${ik}$), intent(out) :: info, sdim + integer(${ik}$), intent(in) :: lda, ldvs, liwork, lwork, n real(sp), intent(out) :: rconde, rcondv ! Array Arguments logical(lk), intent(out) :: bwork(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: vs(ldvs,*), wi(*), work(*), wr(*) ! Function Arguments @@ -69884,36 +69887,36 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: cursl, lastsl, lquery, lst2sl, scalea, wantsb, wantse, wantsn, wantst, & wantsv, wantvs - integer(ilp) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, & + integer(${ik}$) :: hswork, i, i1, i2, ibal, icond, ierr, ieval, ihi, ilo, inxt, ip, itau, & iwrk, lwrk, liwrk, maxwrk, minwrk real(sp) :: anrm, bignum, cscale, eps, smlnum ! Local Arrays - real(sp) :: dum(1) + real(sp) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ wantvs = stdlib_lsame( jobvs, 'V' ) wantst = stdlib_lsame( sort, 'S' ) wantsn = stdlib_lsame( sense, 'N' ) wantse = stdlib_lsame( sense, 'E' ) wantsv = stdlib_lsame( sense, 'V' ) wantsb = stdlib_lsame( sense, 'B' ) - lquery = ( lwork==-1 .or. liwork==-1 ) + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. & .not.wantsn ) ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( ldazero .and. anrm0 )info = ieval + if( ieval>0_${ik}$ )info = ieval ! sort eigenvalues if desired - if( wantst .and. info==0 ) then + if( wantst .and. info==0_${ik}$ ) then if( scalea ) then - call stdlib_slascl( 'G', 0, 0, cscale, anrm, n, 1, wr, n, ierr ) - call stdlib_slascl( 'G', 0, 0, cscale, anrm, n, 1, wi, n, ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wr, n, ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, wi, n, ierr ) end if do i = 1, n bwork( i ) = select( wr( i ), wi( i ) ) @@ -70027,54 +70030,54 @@ module stdlib_linalg_lapack_s ! otherwise, need n ) ! (iworkspace: if sense is 'v' or 'b', need sdim*(n-sdim) ! otherwise, need 0 ) - call stdlib_strsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, rconde, & + call stdlib${ii}$_strsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, wr, wi,sdim, rconde, & rcondv, work( iwrk ), lwork-iwrk+1,iwork, liwork, icond ) if( .not.wantsn )maxwrk = max( maxwrk, n+2*sdim*( n-sdim ) ) - if( icond==-15 ) then + if( icond==-15_${ik}$ ) then ! not enough real workspace - info = -16 - else if( icond==-17 ) then + info = -16_${ik}$ + else if( icond==-17_${ik}$ ) then ! not enough integer workspace - info = -18 - else if( icond>0 ) then - ! stdlib_strsen failed to reorder or to restore standard schur form + info = -18_${ik}$ + else if( icond>0_${ik}$ ) then + ! stdlib${ii}$_strsen failed to reorder or to restore standard schur form info = icond + n end if end if if( wantvs ) then ! undo balancing ! (rworkspace: need n) - call stdlib_sgebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr ) + call stdlib${ii}$_sgebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs,ierr ) end if if( scalea ) then ! undo scaling for the schur form of a - call stdlib_slascl( 'H', 0, 0, cscale, anrm, n, n, a, lda, ierr ) - call stdlib_scopy( n, a, lda+1, wr, 1 ) - if( ( wantsv .or. wantsb ) .and. info==0 ) then - dum( 1 ) = rcondv - call stdlib_slascl( 'G', 0, 0, cscale, anrm, 1, 1, dum, 1, ierr ) - rcondv = dum( 1 ) + call stdlib${ii}$_slascl( 'H', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_scopy( n, a, lda+1, wr, 1_${ik}$ ) + if( ( wantsv .or. wantsb ) .and. info==0_${ik}$ ) then + dum( 1_${ik}$ ) = rcondv + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr ) + rcondv = dum( 1_${ik}$ ) end if if( cscale==smlnum ) then ! if scaling back towards underflow, adjust wi if an ! offdiagonal element of a 2-by-2 block in the schur form ! underflows. - if( ieval>0 ) then - i1 = ieval + 1 - i2 = ihi - 1 - call stdlib_slascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wi, n,ierr ) + if( ieval>0_${ik}$ ) then + i1 = ieval + 1_${ik}$ + i2 = ihi - 1_${ik}$ + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr ) else if( wantst ) then - i1 = 1 - i2 = n - 1 + i1 = 1_${ik}$ + i2 = n - 1_${ik}$ else i1 = ilo - i2 = ihi - 1 + i2 = ihi - 1_${ik}$ end if - inxt = i1 - 1 + inxt = i1 - 1_${ik}$ loop_20: do i = i1, i2 if( i1 )call stdlib_sswap( i-1, a( 1, i ), 1, a( 1, i+1 ), 1 ) - if( n>i+1 )call stdlib_sswap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), & + if( i>1_${ik}$ )call stdlib${ii}$_sswap( i-1, a( 1_${ik}$, i ), 1_${ik}$, a( 1_${ik}$, i+1 ), 1_${ik}$ ) + if( n>i+1 )call stdlib${ii}$_sswap( n-i-1, a( i, i+2 ), lda,a( i+1, i+2 ), & lda ) if( wantvs ) then - call stdlib_sswap( n, vs( 1, i ), 1, vs( 1, i+1 ), 1 ) + call stdlib${ii}$_sswap( n, vs( 1_${ik}$, i ), 1_${ik}$, vs( 1_${ik}$, i+1 ), 1_${ik}$ ) end if a( i, i+1 ) = a( i+1, i ) a( i+1, i ) = zero end if - inxt = i + 2 + inxt = i + 2_${ik}$ end if end do loop_20 end if - call stdlib_slascl( 'G', 0, 0, cscale, anrm, n-ieval, 1,wi( ieval+1 ), max( n-ieval,& - 1 ), ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-ieval, 1_${ik}$,wi( ieval+1 ), max( n-ieval,& + 1_${ik}$ ), ierr ) end if - if( wantst .and. info==0 ) then + if( wantst .and. info==0_${ik}$ ) then ! check if reordering successful lastsl = .true. lst2sl = .true. - sdim = 0 - ip = 0 + sdim = 0_${ik}$ + ip = 0_${ik}$ do i = 1, n cursl = select( wr( i ), wi( i ) ) if( wi( i )==zero ) then - if( cursl )sdim = sdim + 1 - ip = 0 - if( cursl .and. .not.lastsl )info = n + 2 + if( cursl )sdim = sdim + 1_${ik}$ + ip = 0_${ik}$ + if( cursl .and. .not.lastsl )info = n + 2_${ik}$ else - if( ip==1 ) then + if( ip==1_${ik}$ ) then ! last eigenvalue of conjugate pair cursl = cursl .or. lastsl lastsl = cursl - if( cursl )sdim = sdim + 2 - ip = -1 - if( cursl .and. .not.lst2sl )info = n + 2 + if( cursl )sdim = sdim + 2_${ik}$ + ip = -1_${ik}$ + if( cursl .and. .not.lst2sl )info = n + 2_${ik}$ else ! first eigenvalue of conjugate pair - ip = 1 + ip = 1_${ik}$ end if end if lst2sl = lastsl lastsl = cursl end do end if - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk if( wantsv .or. wantsb ) then - iwork( 1 ) = sdim*(n-sdim) + iwork( 1_${ik}$ ) = sdim*(n-sdim) else - iwork( 1 ) = 1 + iwork( 1_${ik}$ ) = 1_${ik}$ end if return - end subroutine stdlib_sgeesx + end subroutine stdlib${ii}$_sgeesx - subroutine stdlib_sgeev( jobvl, jobvr, n, a, lda, wr, wi, vl, ldvl, vr,ldvr, work, lwork, & + subroutine stdlib${ii}$_sgeev( jobvl, jobvr, n, a, lda, wr, wi, vl, ldvl, vr,ldvr, work, lwork, & !! SGEEV computes for an N-by-N real nonsymmetric matrix A, the !! eigenvalues and, optionally, the left and/or right eigenvectors. !! The right eigenvector v(j) of A satisfies @@ -70154,8 +70157,8 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvl, jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: vl(ldvl,*), vr(ldvr,*), wi(*), work(*), wr(*) @@ -70164,90 +70167,90 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: lquery, scalea, wantvl, wantvr character :: side - integer(ilp) :: hswork, i, ibal, ierr, ihi, ilo, itau, iwrk, k, lwork_trevc, maxwrk, & + integer(${ik}$) :: hswork, i, ibal, ierr, ihi, ilo, itau, iwrk, k, lwork_trevc, maxwrk, & minwrk, nout real(sp) :: anrm, bignum, cs, cscale, eps, r, scl, smlnum, sn ! Local Arrays - logical(lk) :: select(1) - real(sp) :: dum(1) + logical(lk) :: select(1_${ik}$) + real(sp) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) wantvl = stdlib_lsame( jobvl, 'V' ) wantvr = stdlib_lsame( jobvr, 'V' ) if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldazero .and. anrmzero ) then - scl = one / stdlib_slapy2( stdlib_snrm2( n, vl( 1, i ), 1 ),stdlib_snrm2( n, & - vl( 1, i+1 ), 1 ) ) - call stdlib_sscal( n, scl, vl( 1, i ), 1 ) - call stdlib_sscal( n, scl, vl( 1, i+1 ), 1 ) + scl = one / stdlib${ii}$_slapy2( stdlib${ii}$_snrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_snrm2( n, & + vl( 1_${ik}$, i+1 ), 1_${ik}$ ) ) + call stdlib${ii}$_sscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_sscal( n, scl, vl( 1_${ik}$, i+1 ), 1_${ik}$ ) do k = 1, n - work( iwrk+k-1 ) = vl( k, i )**2 + vl( k, i+1 )**2 + work( iwrk+k-1 ) = vl( k, i )**2_${ik}$ + vl( k, i+1 )**2_${ik}$ end do - k = stdlib_isamax( n, work( iwrk ), 1 ) - call stdlib_slartg( vl( k, i ), vl( k, i+1 ), cs, sn, r ) - call stdlib_srot( n, vl( 1, i ), 1, vl( 1, i+1 ), 1, cs, sn ) + k = stdlib${ii}$_isamax( n, work( iwrk ), 1_${ik}$ ) + call stdlib${ii}$_slartg( vl( k, i ), vl( k, i+1 ), cs, sn, r ) + call stdlib${ii}$_srot( n, vl( 1_${ik}$, i ), 1_${ik}$, vl( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn ) vl( k, i+1 ) = zero end if end do @@ -70358,23 +70361,23 @@ module stdlib_linalg_lapack_s if( wantvr ) then ! undo balancing of right eigenvectors ! (workspace: need n) - call stdlib_sgebak( 'B', 'R', n, ilo, ihi, work( ibal ), n, vr, ldvr,ierr ) + call stdlib${ii}$_sgebak( 'B', 'R', n, ilo, ihi, work( ibal ), n, vr, ldvr,ierr ) ! normalize right eigenvectors and make largest component real do i = 1, n if( wi( i )==zero ) then - scl = one / stdlib_snrm2( n, vr( 1, i ), 1 ) - call stdlib_sscal( n, scl, vr( 1, i ), 1 ) + scl = one / stdlib${ii}$_snrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_sscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ ) else if( wi( i )>zero ) then - scl = one / stdlib_slapy2( stdlib_snrm2( n, vr( 1, i ), 1 ),stdlib_snrm2( n, & - vr( 1, i+1 ), 1 ) ) - call stdlib_sscal( n, scl, vr( 1, i ), 1 ) - call stdlib_sscal( n, scl, vr( 1, i+1 ), 1 ) + scl = one / stdlib${ii}$_slapy2( stdlib${ii}$_snrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_snrm2( n, & + vr( 1_${ik}$, i+1 ), 1_${ik}$ ) ) + call stdlib${ii}$_sscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_sscal( n, scl, vr( 1_${ik}$, i+1 ), 1_${ik}$ ) do k = 1, n - work( iwrk+k-1 ) = vr( k, i )**2 + vr( k, i+1 )**2 + work( iwrk+k-1 ) = vr( k, i )**2_${ik}$ + vr( k, i+1 )**2_${ik}$ end do - k = stdlib_isamax( n, work( iwrk ), 1 ) - call stdlib_slartg( vr( k, i ), vr( k, i+1 ), cs, sn, r ) - call stdlib_srot( n, vr( 1, i ), 1, vr( 1, i+1 ), 1, cs, sn ) + k = stdlib${ii}$_isamax( n, work( iwrk ), 1_${ik}$ ) + call stdlib${ii}$_slartg( vr( k, i ), vr( k, i+1 ), cs, sn, r ) + call stdlib${ii}$_srot( n, vr( 1_${ik}$, i ), 1_${ik}$, vr( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn ) vr( k, i+1 ) = zero end if end do @@ -70382,21 +70385,21 @@ module stdlib_linalg_lapack_s ! undo scaling if necessary 50 continue if( scalea ) then - call stdlib_slascl( 'G', 0, 0, cscale, anrm, n-info, 1, wr( info+1 ),max( n-info, 1 & + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wr( info+1 ),max( n-info, 1_${ik}$ & ), ierr ) - call stdlib_slascl( 'G', 0, 0, cscale, anrm, n-info, 1, wi( info+1 ),max( n-info, 1 & + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wi( info+1 ),max( n-info, 1_${ik}$ & ), ierr ) - if( info>0 ) then - call stdlib_slascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wr, n,ierr ) - call stdlib_slascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wi, n,ierr ) + if( info>0_${ik}$ ) then + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wr, n,ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr ) end if end if - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_sgeev + end subroutine stdlib${ii}$_sgeev - subroutine stdlib_sgeevx( balanc, jobvl, jobvr, sense, n, a, lda, wr, wi,vl, ldvl, vr, ldvr, & + subroutine stdlib${ii}$_sgeevx( balanc, jobvl, jobvr, sense, n, a, lda, wr, wi,vl, ldvl, vr, ldvr, & !! SGEEVX computes for an N-by-N real nonsymmetric matrix A, the !! eigenvalues and, optionally, the left and/or right eigenvectors. !! Optionally also, it computes a balancing transformation to improve @@ -70428,11 +70431,11 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: balanc, jobvl, jobvr, sense - integer(ilp), intent(out) :: ihi, ilo, info - integer(ilp), intent(in) :: lda, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: ihi, ilo, info + integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n real(sp), intent(out) :: abnrm ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: rconde(*), rcondv(*), scale(*), vl(ldvl,*), vr(ldvr,*), wi(*),& work(*), wr(*) @@ -70441,18 +70444,18 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: lquery, scalea, wantvl, wantvr, wntsnb, wntsne, wntsnn, wntsnv character :: job, side - integer(ilp) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, & + integer(${ik}$) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, & nout real(sp) :: anrm, bignum, cs, cscale, eps, r, scl, smlnum, sn ! Local Arrays - logical(lk) :: select(1) - real(sp) :: dum(1) + logical(lk) :: select(1_${ik}$) + real(sp) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) wantvl = stdlib_lsame( jobvl, 'V' ) wantvr = stdlib_lsame( jobvr, 'V' ) wntsnn = stdlib_lsame( sense, 'N' ) @@ -70461,87 +70464,87 @@ module stdlib_linalg_lapack_s wntsnb = stdlib_lsame( sense, 'B' ) if( .not.( stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'S' ).or. & stdlib_lsame( balanc, 'P' ) .or. stdlib_lsame( balanc, 'B' ) ) )then - info = -1 + info = -1_${ik}$ else if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then - info = -3 + info = -3_${ik}$ else if( .not.( wntsnn .or. wntsne .or. wntsnb .or. wntsnv ) .or.( ( wntsne .or. & wntsnb ) .and. .not.( wantvl .and.wantvr ) ) ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( ldazero .and. anrmzero ) then - scl = one / stdlib_slapy2( stdlib_snrm2( n, vl( 1, i ), 1 ),stdlib_snrm2( n, & - vl( 1, i+1 ), 1 ) ) - call stdlib_sscal( n, scl, vl( 1, i ), 1 ) - call stdlib_sscal( n, scl, vl( 1, i+1 ), 1 ) + scl = one / stdlib${ii}$_slapy2( stdlib${ii}$_snrm2( n, vl( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_snrm2( n, & + vl( 1_${ik}$, i+1 ), 1_${ik}$ ) ) + call stdlib${ii}$_sscal( n, scl, vl( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_sscal( n, scl, vl( 1_${ik}$, i+1 ), 1_${ik}$ ) do k = 1, n - work( k ) = vl( k, i )**2 + vl( k, i+1 )**2 + work( k ) = vl( k, i )**2_${ik}$ + vl( k, i+1 )**2_${ik}$ end do - k = stdlib_isamax( n, work, 1 ) - call stdlib_slartg( vl( k, i ), vl( k, i+1 ), cs, sn, r ) - call stdlib_srot( n, vl( 1, i ), 1, vl( 1, i+1 ), 1, cs, sn ) + k = stdlib${ii}$_isamax( n, work, 1_${ik}$ ) + call stdlib${ii}$_slartg( vl( k, i ), vl( k, i+1 ), cs, sn, r ) + call stdlib${ii}$_srot( n, vl( 1_${ik}$, i ), 1_${ik}$, vl( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn ) vl( k, i+1 ) = zero end if end do end if if( wantvr ) then ! undo balancing of right eigenvectors - call stdlib_sgebak( balanc, 'R', n, ilo, ihi, scale, n, vr, ldvr,ierr ) + call stdlib${ii}$_sgebak( balanc, 'R', n, ilo, ihi, scale, n, vr, ldvr,ierr ) ! normalize right eigenvectors and make largest component real do i = 1, n if( wi( i )==zero ) then - scl = one / stdlib_snrm2( n, vr( 1, i ), 1 ) - call stdlib_sscal( n, scl, vr( 1, i ), 1 ) + scl = one / stdlib${ii}$_snrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_sscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ ) else if( wi( i )>zero ) then - scl = one / stdlib_slapy2( stdlib_snrm2( n, vr( 1, i ), 1 ),stdlib_snrm2( n, & - vr( 1, i+1 ), 1 ) ) - call stdlib_sscal( n, scl, vr( 1, i ), 1 ) - call stdlib_sscal( n, scl, vr( 1, i+1 ), 1 ) + scl = one / stdlib${ii}$_slapy2( stdlib${ii}$_snrm2( n, vr( 1_${ik}$, i ), 1_${ik}$ ),stdlib${ii}$_snrm2( n, & + vr( 1_${ik}$, i+1 ), 1_${ik}$ ) ) + call stdlib${ii}$_sscal( n, scl, vr( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_sscal( n, scl, vr( 1_${ik}$, i+1 ), 1_${ik}$ ) do k = 1, n - work( k ) = vr( k, i )**2 + vr( k, i+1 )**2 + work( k ) = vr( k, i )**2_${ik}$ + vr( k, i+1 )**2_${ik}$ end do - k = stdlib_isamax( n, work, 1 ) - call stdlib_slartg( vr( k, i ), vr( k, i+1 ), cs, sn, r ) - call stdlib_srot( n, vr( 1, i ), 1, vr( 1, i+1 ), 1, cs, sn ) + k = stdlib${ii}$_isamax( n, work, 1_${ik}$ ) + call stdlib${ii}$_slartg( vr( k, i ), vr( k, i+1 ), cs, sn, r ) + call stdlib${ii}$_srot( n, vr( 1_${ik}$, i ), 1_${ik}$, vr( 1_${ik}$, i+1 ), 1_${ik}$, cs, sn ) vr( k, i+1 ) = zero end if end do @@ -70691,24 +70694,24 @@ module stdlib_linalg_lapack_s ! undo scaling if necessary 50 continue if( scalea ) then - call stdlib_slascl( 'G', 0, 0, cscale, anrm, n-info, 1, wr( info+1 ),max( n-info, 1 & + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wr( info+1 ),max( n-info, 1_${ik}$ & ), ierr ) - call stdlib_slascl( 'G', 0, 0, cscale, anrm, n-info, 1, wi( info+1 ),max( n-info, 1 & + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n-info, 1_${ik}$, wi( info+1 ),max( n-info, 1_${ik}$ & ), ierr ) - if( info==0 ) then - if( ( wntsnv .or. wntsnb ) .and. icond==0 )call stdlib_slascl( 'G', 0, 0, cscale,& - anrm, n, 1, rcondv, n,ierr ) + if( info==0_${ik}$ ) then + if( ( wntsnv .or. wntsnb ) .and. icond==0_${ik}$ )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale,& + anrm, n, 1_${ik}$, rcondv, n,ierr ) else - call stdlib_slascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wr, n,ierr ) - call stdlib_slascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wi, n,ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wr, n,ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, wi, n,ierr ) end if end if - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_sgeevx + end subroutine stdlib${ii}$_sgeevx - pure subroutine stdlib_sgejsv( joba, jobu, jobv, jobr, jobt, jobp,m, n, a, lda, sva, u, ldu, & + pure subroutine stdlib${ii}$_sgejsv( joba, jobu, jobv, jobr, jobt, jobp,m, n, a, lda, sva, u, ldu, & !! SGEJSV computes the singular value decomposition (SVD) of a real M-by-N !! matrix [A], where M >= N. The SVD of [A] is written as !! [A] = [U] * [SIGMA] * [V]^t, @@ -70726,19 +70729,19 @@ 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, ldu, ldv, lwork, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldu, ldv, lwork, m, n ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: sva(n), u(ldu,*), v(ldv,*), work(lwork) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) character, intent(in) :: joba, jobp, jobr, jobt, jobu, jobv ! =========================================================================== ! Local Scalars real(sp) :: aapp, aaqq, aatmax, aatmin, big, big1, cond_ok, condr1, condr2, entra, & entrat, epsln, maxprj, scalem, sconda, sfmin, small, temp1, uscal1, uscal2, xsc - integer(ilp) :: ierr, n1, nr, numrank, p, q, warning + integer(${ik}$) :: ierr, n1, nr, numrank, p, q, warning logical(lk) :: almort, defr, errest, goscal, jracc, kill, lsvec, l2aber, l2kill, & l2pert, l2rank, l2tran, noscal, rowpiv, rsvec, transp ! Intrinsic Functions @@ -70757,50 +70760,50 @@ module stdlib_linalg_lapack_s l2pert = stdlib_lsame( jobp, 'P' ) if ( .not.(rowpiv .or. l2rank .or. l2aber .or.errest .or. stdlib_lsame( joba, 'C' ) )) & then - info = - 1 + info = - 1_${ik}$ else if ( .not.( lsvec .or. stdlib_lsame( jobu, 'N' ) .or.stdlib_lsame( jobu, 'W' )) )& then - info = - 2 + info = - 2_${ik}$ else if ( .not.( rsvec .or. stdlib_lsame( jobv, 'N' ) .or.stdlib_lsame( jobv, 'W' )) & .or. ( jracc .and. (.not.lsvec) ) ) then - info = - 3 + info = - 3_${ik}$ else if ( .not. ( l2kill .or. defr ) ) then - info = - 4 + info = - 4_${ik}$ else if ( .not. ( l2tran .or. stdlib_lsame( jobt, 'N' ) ) ) then - info = - 5 + info = - 5_${ik}$ else if ( .not. ( l2pert .or. stdlib_lsame( jobp, 'N' ) ) ) then - info = - 6 - else if ( m < 0 ) then - info = - 7 - else if ( ( n < 0 ) .or. ( n > m ) ) then - info = - 8 + info = - 6_${ik}$ + else if ( m < 0_${ik}$ ) then + info = - 7_${ik}$ + else if ( ( n < 0_${ik}$ ) .or. ( n > m ) ) then + info = - 8_${ik}$ else if ( lda < m ) then - info = - 10 + info = - 10_${ik}$ else if ( lsvec .and. ( ldu < m ) ) then - info = - 13 + info = - 13_${ik}$ else if ( rsvec .and. ( ldv < n ) ) then - info = - 15 - else if ( (.not.(lsvec .or. rsvec .or. errest).and.(lwork < max(7,4*n+1,2*m+n))) .or.(& - .not.(lsvec .or. rsvec) .and. errest .and.(lwork < max(7,4*n+n*n,2*m+n))) .or.(lsvec & - .and. (.not.rsvec) .and. (lwork < max(7,2*m+n,4*n+1))).or.(rsvec .and. (.not.lsvec) & - .and. (lwork < max(7,2*m+n,4*n+1))).or.(lsvec .and. rsvec .and. (.not.jracc) .and.(& - lwork big ) then - info = - 9 - call stdlib_xerbla( 'SGEJSV', -info ) + info = - 9_${ik}$ + call stdlib${ii}$_xerbla( 'SGEJSV', -info ) return end if aaqq = sqrt(aaqq) @@ -70839,7 +70842,7 @@ module stdlib_linalg_lapack_s sva(p) = aapp * ( aaqq * scalem ) if ( goscal ) then goscal = .false. - call stdlib_sscal( p-1, scalem, sva, 1 ) + call stdlib${ii}$_sscal( p-1, scalem, sva, 1_${ik}$ ) end if end if end do @@ -70853,76 +70856,76 @@ module stdlib_linalg_lapack_s ! quick return for zero m x n matrix ! #:) if ( aapp == zero ) then - if ( lsvec ) call stdlib_slaset( 'G', m, n1, zero, one, u, ldu ) - if ( rsvec ) call stdlib_slaset( 'G', n, n, zero, one, v, ldv ) - work(1) = one - work(2) = one - if ( errest ) work(3) = one + if ( lsvec ) call stdlib${ii}$_slaset( 'G', m, n1, zero, one, u, ldu ) + if ( rsvec ) call stdlib${ii}$_slaset( 'G', n, n, zero, one, v, ldv ) + work(1_${ik}$) = one + work(2_${ik}$) = one + if ( errest ) work(3_${ik}$) = one if ( lsvec .and. rsvec ) then - work(4) = one - work(5) = one + work(4_${ik}$) = one + work(5_${ik}$) = one end if if ( l2tran ) then - work(6) = zero - work(7) = zero + work(6_${ik}$) = zero + work(7_${ik}$) = zero end if - iwork(1) = 0 - iwork(2) = 0 - iwork(3) = 0 + iwork(1_${ik}$) = 0_${ik}$ + iwork(2_${ik}$) = 0_${ik}$ + iwork(3_${ik}$) = 0_${ik}$ return end if ! issue warning if denormalized column norms detected. override the ! high relative accuracy request. issue licence to kill columns ! (set them to zero) whose norm is less than sigma_max / big (roughly). ! #:( - warning = 0 + warning = 0_${ik}$ if ( aaqq <= sfmin ) then l2rank = .true. l2kill = .true. - warning = 1 + warning = 1_${ik}$ end if ! quick return for one-column matrix ! #:) - if ( n == 1 ) then + if ( n == 1_${ik}$ ) then if ( lsvec ) then - call stdlib_slascl( 'G',0,0,sva(1),scalem, m,1,a(1,1),lda,ierr ) - call stdlib_slacpy( 'A', m, 1, a, lda, u, ldu ) + call stdlib${ii}$_slascl( 'G',0_${ik}$,0_${ik}$,sva(1_${ik}$),scalem, m,1_${ik}$,a(1_${ik}$,1_${ik}$),lda,ierr ) + call stdlib${ii}$_slacpy( 'A', m, 1_${ik}$, a, lda, u, ldu ) ! computing all m left singular vectors of the m x 1 matrix if ( n1 /= n ) then - call stdlib_sgeqrf( m, n, u,ldu, work, work(n+1),lwork-n,ierr ) - call stdlib_sorgqr( m,n1,1, u,ldu,work,work(n+1),lwork-n,ierr ) - call stdlib_scopy( m, a(1,1), 1, u(1,1), 1 ) + call stdlib${ii}$_sgeqrf( m, n, u,ldu, work, work(n+1),lwork-n,ierr ) + call stdlib${ii}$_sorgqr( m,n1,1_${ik}$, u,ldu,work,work(n+1),lwork-n,ierr ) + call stdlib${ii}$_scopy( m, a(1_${ik}$,1_${ik}$), 1_${ik}$, u(1_${ik}$,1_${ik}$), 1_${ik}$ ) end if end if if ( rsvec ) then - v(1,1) = one + v(1_${ik}$,1_${ik}$) = one end if - if ( sva(1) < (big*scalem) ) then - sva(1) = sva(1) / scalem + if ( sva(1_${ik}$) < (big*scalem) ) then + sva(1_${ik}$) = sva(1_${ik}$) / scalem scalem = one end if - work(1) = one / scalem - work(2) = one - if ( sva(1) /= zero ) then - iwork(1) = 1 - if ( ( sva(1) / scalem) >= sfmin ) then - iwork(2) = 1 + work(1_${ik}$) = one / scalem + work(2_${ik}$) = one + if ( sva(1_${ik}$) /= zero ) then + iwork(1_${ik}$) = 1_${ik}$ + if ( ( sva(1_${ik}$) / scalem) >= sfmin ) then + iwork(2_${ik}$) = 1_${ik}$ else - iwork(2) = 0 + iwork(2_${ik}$) = 0_${ik}$ end if else - iwork(1) = 0 - iwork(2) = 0 + iwork(1_${ik}$) = 0_${ik}$ + iwork(2_${ik}$) = 0_${ik}$ end if - iwork(3) = 0 - if ( errest ) work(3) = one + iwork(3_${ik}$) = 0_${ik}$ + if ( errest ) work(3_${ik}$) = one if ( lsvec .and. rsvec ) then - work(4) = one - work(5) = one + work(4_${ik}$) = one + work(5_${ik}$) = one end if if ( l2tran ) then - work(6) = zero - work(7) = zero + work(6_${ik}$) = zero + work(7_${ik}$) = zero end if return end if @@ -70939,8 +70942,8 @@ module stdlib_linalg_lapack_s do p = 1, m xsc = zero temp1 = one - call stdlib_slassq( n, a(p,1), lda, xsc, temp1 ) - ! stdlib_slassq gets both the ell_2 and the ell_infinity norm + call stdlib${ii}$_slassq( n, a(p,1_${ik}$), lda, xsc, temp1 ) + ! stdlib${ii}$_slassq gets both the ell_2 and the ell_infinity norm ! in one pass through the vector work(m+n+p) = xsc * scalem work(n+p) = xsc * (scalem*sqrt(temp1)) @@ -70949,7 +70952,7 @@ module stdlib_linalg_lapack_s end do else do p = 1, m - work(m+n+p) = scalem*abs( a(p,stdlib_isamax(n,a(p,1),lda)) ) + work(m+n+p) = scalem*abs( a(p,stdlib${ii}$_isamax(n,a(p,1_${ik}$),lda)) ) aatmax = max( aatmax, work(m+n+p) ) aatmin = min( aatmin, work(m+n+p) ) end do @@ -70966,11 +70969,11 @@ module stdlib_linalg_lapack_s if ( l2tran ) then xsc = zero temp1 = one - call stdlib_slassq( n, sva, 1, xsc, temp1 ) + call stdlib${ii}$_slassq( n, sva, 1_${ik}$, xsc, temp1 ) temp1 = one / temp1 entra = zero do p = 1, n - big1 = ( ( sva(p) / xsc )**2 ) * temp1 + big1 = ( ( sva(p) / xsc )**2_${ik}$ ) * temp1 if ( big1 /= zero ) entra = entra + big1 * log(big1) end do entra = - entra / log(real(n,KIND=sp)) @@ -70981,7 +70984,7 @@ module stdlib_linalg_lapack_s ! same trace. entrat = zero do p = n+1, n+m - big1 = ( ( work(p) / xsc )**2 ) * temp1 + big1 = ( ( work(p) / xsc )**2_${ik}$ ) * temp1 if ( big1 /= zero ) entrat = entrat + big1 * log(big1) end do entrat = - entrat / log(real(m,KIND=sp)) @@ -71020,22 +71023,22 @@ module stdlib_linalg_lapack_s ! scale the matrix so that its maximal singular value remains less ! than sqrt(big) -- the matrix is scaled so that its maximal column ! has euclidean norm equal to sqrt(big/n). the only reason to keep - ! sqrt(big) instead of big is the fact that stdlib_sgejsv uses lapack and + ! sqrt(big) instead of big is the fact that stdlib${ii}$_sgejsv uses lapack and ! blas routines that, in some implementations, are not capable of ! working in the full interval [sfmin,big] and that they may provoke ! overflows in the intermediate results. if the singular values spread - ! from sfmin to big, then stdlib_sgesvj will compute them. so, in that case, - ! one should use stdlib_sgesvj instead of stdlib_sgejsv. + ! from sfmin to big, then stdlib${ii}$_sgesvj will compute them. so, in that case, + ! one should use stdlib_sgesvj instead of stdlib${ii}$_sgejsv. big1 = sqrt( big ) temp1 = sqrt( big / real(n,KIND=sp) ) - call stdlib_slascl( 'G', 0, 0, aapp, temp1, n, 1, sva, n, ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aapp, temp1, n, 1_${ik}$, sva, n, ierr ) if ( aaqq > (aapp * sfmin) ) then aaqq = ( aaqq / aapp ) * temp1 else aaqq = ( aaqq * temp1 ) / aapp end if temp1 = temp1 * scalem - call stdlib_slascl( 'G', 0, 0, aapp, temp1, m, n, a, lda, ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aapp, temp1, m, n, a, lda, ierr ) ! to undo scaling at the end of this procedure, multiply the ! computed singular values with uscal2 / uscal1. uscal1 = temp1 @@ -71049,7 +71052,7 @@ module stdlib_linalg_lapack_s xsc = small ! now, if the condition number of a is too big, ! sigma_max(a) / sigma_min(a) > sqrt(big/n) * epsln / sfmin, - ! as a precaution measure, the full svd is computed using stdlib_sgesvj + ! as a precaution measure, the full svd is computed using stdlib${ii}$_sgesvj ! with accumulated jacobi rotations. this provides numerically ! more robust computation, at the cost of slightly increased run ! time. depending on the concrete implementation of blas and lapack @@ -71062,7 +71065,7 @@ module stdlib_linalg_lapack_s if ( aaqq < xsc ) then do p = 1, n if ( sva(p) < xsc ) then - call stdlib_slaset( 'A', m, 1, zero, zero, a(1,p), lda ) + call stdlib${ii}$_slaset( 'A', m, 1_${ik}$, zero, zero, a(1_${ik}$,p), lda ) sva(p) = zero end if end do @@ -71075,15 +71078,15 @@ module stdlib_linalg_lapack_s ! has similar effect as powell-reid complete pivoting. ! the ell-infinity norms of a are made nonincreasing. do p = 1, m - 1 - q = stdlib_isamax( m-p+1, work(m+n+p), 1 ) + p - 1 - iwork(2*n+p) = q + q = stdlib${ii}$_isamax( m-p+1, work(m+n+p), 1_${ik}$ ) + p - 1_${ik}$ + iwork(2_${ik}$*n+p) = q if ( p /= q ) then temp1 = work(m+n+p) work(m+n+p) = work(m+n+q) work(m+n+q) = temp1 end if end do - call stdlib_slaswp( n, a, lda, 1, m-1, iwork(2*n+1), 1 ) + call stdlib${ii}$_slaswp( n, a, lda, 1_${ik}$, m-1, iwork(2_${ik}$*n+1), 1_${ik}$ ) end if ! end of the preparation phase (scaling, optional sorting and ! transposing, optional flushing of small columns). @@ -71095,21 +71098,21 @@ module stdlib_linalg_lapack_s ! (eg speed by replacing global with restricted window pivoting, such ! as in sgeqpx from toms # 782). good results will be obtained using ! sgeqpx with properly (!) chosen numerical parameters. - ! any improvement of stdlib_sgeqp3 improves overall performance of stdlib_sgejsv. + ! any improvement of stdlib${ii}$_sgeqp3 improves overall performance of stdlib${ii}$_sgejsv. ! a * p1 = q1 * [ r1^t 0]^t: do p = 1, n ! All Columns Are Free Columns - iwork(p) = 0 + iwork(p) = 0_${ik}$ end do - call stdlib_sgeqp3( m,n,a,lda, iwork,work, work(n+1),lwork-n, ierr ) + call stdlib${ii}$_sgeqp3( m,n,a,lda, iwork,work, work(n+1),lwork-n, ierr ) ! the upper triangular matrix r1 from the first qrf is inspected for ! rank deficiency and possibilities for deflation, or possible ! ill-conditioning. depending on the user specified flag l2rank, ! the procedure explores possibilities to reduce the numerical ! rank by inspecting the computed upper triangular factor. if - ! l2rank or l2aber are up, then stdlib_sgejsv will compute the svd of + ! l2rank or l2aber are up, then stdlib${ii}$_sgejsv will compute the svd of ! a + da, where ||da|| <= f(m,n)*epsln. - nr = 1 + nr = 1_${ik}$ if ( l2aber ) then ! standard absolute error bound suffices. all sigma_i with ! sigma_i < n*epsln*||a|| are flushed to zero. this is an @@ -71117,8 +71120,8 @@ module stdlib_linalg_lapack_s ! backward error of the order of n*epsln*||a||. temp1 = sqrt(real(n,KIND=sp))*epsln do p = 2, n - if ( abs(a(p,p)) >= (temp1*abs(a(1,1))) ) then - nr = nr + 1 + if ( abs(a(p,p)) >= (temp1*abs(a(1_${ik}$,1_${ik}$))) ) then + nr = nr + 1_${ik}$ else go to 3002 end if @@ -71132,7 +71135,7 @@ module stdlib_linalg_lapack_s do p = 2, n if ( ( abs(a(p,p)) < (epsln*abs(a(p-1,p-1))) ) .or.( abs(a(p,p)) < small ) .or.( & l2kill .and. (abs(a(p,p)) < temp1) ) ) go to 3402 - nr = nr + 1 + nr = nr + 1_${ik}$ end do 3402 continue else @@ -71145,9 +71148,8 @@ module stdlib_linalg_lapack_s ! working hard to get the accuracy not warranted by the data. temp1 = sqrt(sfmin) do p = 2, n - if ( ( abs(a(p,p)) < small ) .or.( l2kill .and. (abs(a(p,p)) < temp1) ) ) go to & - 3302 - nr = nr + 1 + if ( ( abs(a(p,p)) < small ) .or.( l2kill .and. (abs(a(p,p)) < temp1) ) ) go to 3302 + nr = nr + 1_${ik}$ end do 3302 continue end if @@ -71158,7 +71160,7 @@ module stdlib_linalg_lapack_s temp1 = abs(a(p,p)) / sva(iwork(p)) maxprj = min( maxprj, temp1 ) end do - if ( maxprj**2 >= one - real(n,KIND=sp)*epsln ) almort = .true. + if ( maxprj**2_${ik}$ >= one - real(n,KIND=sp)*epsln ) almort = .true. end if sconda = - one condr1 = - one @@ -71167,30 +71169,30 @@ module stdlib_linalg_lapack_s if ( n == nr ) then if ( rsvec ) then ! V Is Available As Workspace - call stdlib_slacpy( 'U', n, n, a, lda, v, ldv ) + call stdlib${ii}$_slacpy( 'U', n, n, a, lda, v, ldv ) do p = 1, n temp1 = sva(iwork(p)) - call stdlib_sscal( p, one/temp1, v(1,p), 1 ) + call stdlib${ii}$_sscal( p, one/temp1, v(1_${ik}$,p), 1_${ik}$ ) end do - call stdlib_spocon( 'U', n, v, ldv, one, temp1,work(n+1), iwork(2*n+m+1), & + call stdlib${ii}$_spocon( 'U', n, v, ldv, one, temp1,work(n+1), iwork(2_${ik}$*n+m+1), & ierr ) else if ( lsvec ) then ! U Is Available As Workspace - call stdlib_slacpy( 'U', n, n, a, lda, u, ldu ) + call stdlib${ii}$_slacpy( 'U', n, n, a, lda, u, ldu ) do p = 1, n temp1 = sva(iwork(p)) - call stdlib_sscal( p, one/temp1, u(1,p), 1 ) + call stdlib${ii}$_sscal( p, one/temp1, u(1_${ik}$,p), 1_${ik}$ ) end do - call stdlib_spocon( 'U', n, u, ldu, one, temp1,work(n+1), iwork(2*n+m+1), & + call stdlib${ii}$_spocon( 'U', n, u, ldu, one, temp1,work(n+1), iwork(2_${ik}$*n+m+1), & ierr ) else - call stdlib_slacpy( 'U', n, n, a, lda, work(n+1), n ) + call stdlib${ii}$_slacpy( 'U', n, n, a, lda, work(n+1), n ) do p = 1, n temp1 = sva(iwork(p)) - call stdlib_sscal( p, one/temp1, work(n+(p-1)*n+1), 1 ) + call stdlib${ii}$_sscal( p, one/temp1, work(n+(p-1)*n+1), 1_${ik}$ ) end do ! The Columns Of R Are Scaled To Have Unit Euclidean Lengths - call stdlib_spocon( 'U', n, work(n+1), n, one, temp1,work(n+n*n+1), iwork(2*n+& + call stdlib${ii}$_spocon( 'U', n, work(n+1), n, one, temp1,work(n+n*n+1), iwork(2_${ik}$*n+& m+1), ierr ) end if sconda = one / sqrt(temp1) @@ -71200,14 +71202,14 @@ module stdlib_linalg_lapack_s sconda = - one end if end if - l2pert = l2pert .and. ( abs( a(1,1)/a(nr,nr) ) > sqrt(big1) ) + l2pert = l2pert .and. ( abs( a(1_${ik}$,1_${ik}$)/a(nr,nr) ) > sqrt(big1) ) ! if there is no violent scaling, artificial perturbation is not needed. ! phase 3: if ( .not. ( rsvec .or. lsvec ) ) then ! singular values only ! .. transpose a(1:nr,1:n) do p = 1, min( n-1, nr ) - call stdlib_scopy( n-p, a(p,p+1), lda, a(p+1,p), 1 ) + call stdlib${ii}$_scopy( n-p, a(p,p+1), lda, a(p+1,p), 1_${ik}$ ) end do ! the following two do-loops introduce small relative perturbation ! into the strict upper triangle of the lower triangular matrix. @@ -71232,13 +71234,13 @@ module stdlib_linalg_lapack_s end do end do else - if (nr>1) call stdlib_slaset( 'U', nr-1,nr-1, zero,zero, a(1,2),lda ) + if (nr>1_${ik}$) call stdlib${ii}$_slaset( 'U', nr-1,nr-1, zero,zero, a(1_${ik}$,2_${ik}$),lda ) end if ! Second Preconditioning Using The Qr Factorization - call stdlib_sgeqrf( n,nr, a,lda, work, work(n+1),lwork-n, ierr ) + call stdlib${ii}$_sgeqrf( n,nr, a,lda, work, work(n+1),lwork-n, ierr ) ! And Transpose Upper To Lower Triangular do p = 1, nr - 1 - call stdlib_scopy( nr-p, a(p,p+1), lda, a(p+1,p), 1 ) + call stdlib${ii}$_scopy( nr-p, a(p,p+1), lda, a(p+1,p), 1_${ik}$ ) end do end if ! row-cyclic jacobi svd algorithm with column pivoting @@ -71255,92 +71257,92 @@ module stdlib_linalg_lapack_s end do end do else - if (nr>1) call stdlib_slaset( 'U', nr-1, nr-1, zero, zero, a(1,2), lda ) + if (nr>1_${ik}$) call stdlib${ii}$_slaset( 'U', nr-1, nr-1, zero, zero, a(1_${ik}$,2_${ik}$), lda ) end if ! .. and one-sided jacobi rotations are started on a lower ! triangular matrix (plus perturbation which is ignored in ! the part which destroys triangular form (confusing?!)) - call stdlib_sgesvj( 'L', 'NOU', 'NOV', nr, nr, a, lda, sva,n, v, ldv, work, & + call stdlib${ii}$_sgesvj( 'L', 'NOU', 'NOV', nr, nr, a, lda, sva,n, v, ldv, work, & lwork, info ) - scalem = work(1) - numrank = nint(work(2),KIND=ilp) + scalem = work(1_${ik}$) + numrank = nint(work(2_${ik}$),KIND=${ik}$) else if ( rsvec .and. ( .not. lsvec ) ) then ! -> singular values and right singular vectors <- if ( almort ) then ! In This Case Nr Equals N do p = 1, nr - call stdlib_scopy( n-p+1, a(p,p), lda, v(p,p), 1 ) + call stdlib${ii}$_scopy( n-p+1, a(p,p), lda, v(p,p), 1_${ik}$ ) end do - if (nr>1) call stdlib_slaset( 'UPPER', nr-1, nr-1, zero, zero, v(1,2), ldv ) - call stdlib_sgesvj( 'L','U','N', n, nr, v,ldv, sva, nr, a,lda,work, lwork, info ) + if (nr>1_${ik}$) call stdlib${ii}$_slaset( 'UPPER', nr-1, nr-1, zero, zero, v(1_${ik}$,2_${ik}$), ldv ) + call stdlib${ii}$_sgesvj( 'L','U','N', n, nr, v,ldv, sva, nr, a,lda,work, lwork, info ) - scalem = work(1) - numrank = nint(work(2),KIND=ilp) + scalem = work(1_${ik}$) + numrank = nint(work(2_${ik}$),KIND=${ik}$) else ! .. two more qr factorizations ( one qrf is not enough, two require ! accumulated product of jacobi rotations, three are perfect ) - if (nr>1) call stdlib_slaset( 'LOWER', nr-1, nr-1, zero, zero, a(2,1), lda ) - call stdlib_sgelqf( nr, n, a, lda, work, work(n+1), lwork-n, ierr) - call stdlib_slacpy( 'LOWER', nr, nr, a, lda, v, ldv ) - if (nr>1) call stdlib_slaset( 'UPPER', nr-1, nr-1, zero, zero, v(1,2), ldv ) - call stdlib_sgeqrf( nr, nr, v, ldv, work(n+1), work(2*n+1),lwork-2*n, ierr ) + if (nr>1_${ik}$) call stdlib${ii}$_slaset( 'LOWER', nr-1, nr-1, zero, zero, a(2_${ik}$,1_${ik}$), lda ) + call stdlib${ii}$_sgelqf( nr, n, a, lda, work, work(n+1), lwork-n, ierr) + call stdlib${ii}$_slacpy( 'LOWER', nr, nr, a, lda, v, ldv ) + if (nr>1_${ik}$) call stdlib${ii}$_slaset( 'UPPER', nr-1, nr-1, zero, zero, v(1_${ik}$,2_${ik}$), ldv ) + call stdlib${ii}$_sgeqrf( nr, nr, v, ldv, work(n+1), work(2_${ik}$*n+1),lwork-2*n, ierr ) do p = 1, nr - call stdlib_scopy( nr-p+1, v(p,p), ldv, v(p,p), 1 ) + call stdlib${ii}$_scopy( nr-p+1, v(p,p), ldv, v(p,p), 1_${ik}$ ) end do - if (nr>1) call stdlib_slaset( 'UPPER', nr-1, nr-1, zero, zero, v(1,2), ldv ) - call stdlib_sgesvj( 'LOWER', 'U','N', nr, nr, v,ldv, sva, nr, u,ldu, work(n+1), & + if (nr>1_${ik}$) call stdlib${ii}$_slaset( 'UPPER', nr-1, nr-1, zero, zero, v(1_${ik}$,2_${ik}$), ldv ) + call stdlib${ii}$_sgesvj( 'LOWER', 'U','N', nr, nr, v,ldv, sva, nr, u,ldu, work(n+1), & lwork-n, info ) scalem = work(n+1) - numrank = nint(work(n+2),KIND=ilp) + numrank = nint(work(n+2),KIND=${ik}$) if ( nr < n ) then - call stdlib_slaset( 'A',n-nr, nr, zero,zero, v(nr+1,1), ldv ) - call stdlib_slaset( 'A',nr, n-nr, zero,zero, v(1,nr+1), ldv ) - call stdlib_slaset( 'A',n-nr,n-nr,zero,one, v(nr+1,nr+1), ldv ) + call stdlib${ii}$_slaset( 'A',n-nr, nr, zero,zero, v(nr+1,1_${ik}$), ldv ) + call stdlib${ii}$_slaset( 'A',nr, n-nr, zero,zero, v(1_${ik}$,nr+1), ldv ) + call stdlib${ii}$_slaset( 'A',n-nr,n-nr,zero,one, v(nr+1,nr+1), ldv ) end if - call stdlib_sormlq( 'LEFT', 'TRANSPOSE', n, n, nr, a, lda, work,v, ldv, work(n+1), & + call stdlib${ii}$_sormlq( 'LEFT', 'TRANSPOSE', n, n, nr, a, lda, work,v, ldv, work(n+1), & lwork-n, ierr ) end if do p = 1, n - call stdlib_scopy( n, v(p,1), ldv, a(iwork(p),1), lda ) + call stdlib${ii}$_scopy( n, v(p,1_${ik}$), ldv, a(iwork(p),1_${ik}$), lda ) end do - call stdlib_slacpy( 'ALL', n, n, a, lda, v, ldv ) + call stdlib${ii}$_slacpy( 'ALL', n, n, a, lda, v, ldv ) if ( transp ) then - call stdlib_slacpy( 'ALL', n, n, v, ldv, u, ldu ) + call stdlib${ii}$_slacpy( 'ALL', n, n, v, ldv, u, ldu ) end if else if ( lsvec .and. ( .not. rsvec ) ) then ! Singular Values And Left Singular Vectors ! Second Preconditioning Step To Avoid Need To Accumulate ! jacobi rotations in the jacobi iterations. do p = 1, nr - call stdlib_scopy( n-p+1, a(p,p), lda, u(p,p), 1 ) + call stdlib${ii}$_scopy( n-p+1, a(p,p), lda, u(p,p), 1_${ik}$ ) end do - if (nr>1) call stdlib_slaset( 'UPPER', nr-1, nr-1, zero, zero, u(1,2), ldu ) - call stdlib_sgeqrf( n, nr, u, ldu, work(n+1), work(2*n+1),lwork-2*n, ierr ) + if (nr>1_${ik}$) call stdlib${ii}$_slaset( 'UPPER', nr-1, nr-1, zero, zero, u(1_${ik}$,2_${ik}$), ldu ) + call stdlib${ii}$_sgeqrf( n, nr, u, ldu, work(n+1), work(2_${ik}$*n+1),lwork-2*n, ierr ) do p = 1, nr - 1 - call stdlib_scopy( nr-p, u(p,p+1), ldu, u(p+1,p), 1 ) + call stdlib${ii}$_scopy( nr-p, u(p,p+1), ldu, u(p+1,p), 1_${ik}$ ) end do - if (nr>1) call stdlib_slaset( 'UPPER', nr-1, nr-1, zero, zero, u(1,2), ldu ) - call stdlib_sgesvj( 'LOWER', 'U', 'N', nr,nr, u, ldu, sva, nr, a,lda, work(n+1), & + if (nr>1_${ik}$) call stdlib${ii}$_slaset( 'UPPER', nr-1, nr-1, zero, zero, u(1_${ik}$,2_${ik}$), ldu ) + call stdlib${ii}$_sgesvj( 'LOWER', 'U', 'N', nr,nr, u, ldu, sva, nr, a,lda, work(n+1), & lwork-n, info ) scalem = work(n+1) - numrank = nint(work(n+2),KIND=ilp) + numrank = nint(work(n+2),KIND=${ik}$) if ( nr < m ) then - call stdlib_slaset( 'A', m-nr, nr,zero, zero, u(nr+1,1), ldu ) + call stdlib${ii}$_slaset( 'A', m-nr, nr,zero, zero, u(nr+1,1_${ik}$), ldu ) if ( nr < n1 ) then - call stdlib_slaset( 'A',nr, n1-nr, zero, zero, u(1,nr+1), ldu ) - call stdlib_slaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_slaset( 'A',nr, n1-nr, zero, zero, u(1_${ik}$,nr+1), ldu ) + call stdlib${ii}$_slaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) end if end if - call stdlib_sormqr( 'LEFT', 'NO TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & + call stdlib${ii}$_sormqr( 'LEFT', 'NO TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & lwork-n, ierr ) - if ( rowpiv )call stdlib_slaswp( n1, u, ldu, 1, m-1, iwork(2*n+1), -1 ) + if ( rowpiv )call stdlib${ii}$_slaswp( n1, u, ldu, 1_${ik}$, m-1, iwork(2_${ik}$*n+1), -1_${ik}$ ) do p = 1, n1 - xsc = one / stdlib_snrm2( m, u(1,p), 1 ) - call stdlib_sscal( m, xsc, u(1,p), 1 ) + xsc = one / stdlib${ii}$_snrm2( m, u(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_sscal( m, xsc, u(1_${ik}$,p), 1_${ik}$ ) end do if ( transp ) then - call stdlib_slacpy( 'ALL', n, n, u, ldu, v, ldv ) + call stdlib${ii}$_slacpy( 'ALL', n, n, u, ldu, v, ldv ) end if else ! Full Svd @@ -71351,9 +71353,9 @@ module stdlib_linalg_lapack_s ! equivalent to an lqf call. since in many libraries the qrf ! seems to be better optimized than the lqf, we do explicit ! transpose and use the qrf. this is subject to changes in an - ! optimized implementation of stdlib_sgejsv. + ! optimized implementation of stdlib${ii}$_sgejsv. do p = 1, nr - call stdlib_scopy( n-p+1, a(p,p), lda, v(p,p), 1 ) + call stdlib${ii}$_scopy( n-p+1, a(p,p), lda, v(p,p), 1_${ik}$ ) end do ! The Following Two Loops Perturb Small Entries To Avoid ! denormals in the second qr factorization, where they are @@ -71377,18 +71379,18 @@ module stdlib_linalg_lapack_s end do end do else - if (nr>1) call stdlib_slaset( 'U', nr-1, nr-1, zero, zero, v(1,2), ldv ) + if (nr>1_${ik}$) call stdlib${ii}$_slaset( 'U', nr-1, nr-1, zero, zero, v(1_${ik}$,2_${ik}$), ldv ) end if ! estimate the row scaled condition number of r1 ! (if r1 is rectangular, n > nr, then the condition number ! of the leading nr x nr submatrix is estimated.) - call stdlib_slacpy( 'L', nr, nr, v, ldv, work(2*n+1), nr ) + call stdlib${ii}$_slacpy( 'L', nr, nr, v, ldv, work(2_${ik}$*n+1), nr ) do p = 1, nr - temp1 = stdlib_snrm2(nr-p+1,work(2*n+(p-1)*nr+p),1) - call stdlib_sscal(nr-p+1,one/temp1,work(2*n+(p-1)*nr+p),1) + temp1 = stdlib${ii}$_snrm2(nr-p+1,work(2_${ik}$*n+(p-1)*nr+p),1_${ik}$) + call stdlib${ii}$_sscal(nr-p+1,one/temp1,work(2_${ik}$*n+(p-1)*nr+p),1_${ik}$) end do - call stdlib_spocon('LOWER',nr,work(2*n+1),nr,one,temp1,work(2*n+nr*nr+1),iwork(m+& - 2*n+1),ierr) + call stdlib${ii}$_spocon('LOWER',nr,work(2_${ik}$*n+1),nr,one,temp1,work(2_${ik}$*n+nr*nr+1),iwork(m+& + 2_${ik}$*n+1),ierr) condr1 = one / sqrt(temp1) ! Here Need A Second Opinion On The Condition Number ! Then Assume Worst Case Scenario @@ -71401,7 +71403,7 @@ module stdlib_linalg_lapack_s ! implementation, this qrf should be implemented as the qrf ! of a lower triangular matrix. ! r1^t = q2 * r2 - call stdlib_sgeqrf( n, nr, v, ldv, work(n+1), work(2*n+1),lwork-2*n, ierr ) + call stdlib${ii}$_sgeqrf( n, nr, v, ldv, work(n+1), work(2_${ik}$*n+1),lwork-2*n, ierr ) if ( l2pert ) then xsc = sqrt(small)/epsln @@ -71412,27 +71414,27 @@ module stdlib_linalg_lapack_s end do end do end if - if ( nr /= n )call stdlib_slacpy( 'A', n, nr, v, ldv, work(2*n+1), n ) + if ( nr /= n )call stdlib${ii}$_slacpy( 'A', n, nr, v, ldv, work(2_${ik}$*n+1), n ) ! .. save ... ! This Transposed Copy Should Be Better Than Naive do p = 1, nr - 1 - call stdlib_scopy( nr-p, v(p,p+1), ldv, v(p+1,p), 1 ) + call stdlib${ii}$_scopy( nr-p, v(p,p+1), ldv, v(p+1,p), 1_${ik}$ ) end do condr2 = condr1 else ! .. ill-conditioned case: second qrf with pivoting ! note that windowed pivoting would be equally good ! numerically, and more run-time efficient. so, in - ! an optimal implementation, the next call to stdlib_sgeqp3 + ! an optimal implementation, the next call to stdlib${ii}$_sgeqp3 ! should be replaced with eg. call sgeqpx (acm toms #782) ! with properly (carefully) chosen parameters. ! r1^t * p2 = q2 * r2 do p = 1, nr - iwork(n+p) = 0 + iwork(n+p) = 0_${ik}$ end do - call stdlib_sgeqp3( n, nr, v, ldv, iwork(n+1), work(n+1),work(2*n+1), lwork-& - 2*n, ierr ) - ! * call stdlib_sgeqrf( n, nr, v, ldv, work(n+1), work(2*n+1), + call stdlib${ii}$_sgeqp3( n, nr, v, ldv, iwork(n+1), work(n+1),work(2_${ik}$*n+1), lwork-& + 2_${ik}$*n, ierr ) + ! * call stdlib${ii}$_sgeqrf( n, nr, v, ldv, work(n+1), work(2*n+1), ! * $ lwork-2*n, ierr ) if ( l2pert ) then xsc = sqrt(small) @@ -71443,7 +71445,7 @@ module stdlib_linalg_lapack_s end do end do end if - call stdlib_slacpy( 'A', n, nr, v, ldv, work(2*n+1), n ) + call stdlib${ii}$_slacpy( 'A', n, nr, v, ldv, work(2_${ik}$*n+1), n ) if ( l2pert ) then xsc = sqrt(small) do p = 2, nr @@ -71453,18 +71455,18 @@ module stdlib_linalg_lapack_s end do end do else - if (nr>1) call stdlib_slaset( 'L',nr-1,nr-1,zero,zero,v(2,1),ldv ) + if (nr>1_${ik}$) call stdlib${ii}$_slaset( 'L',nr-1,nr-1,zero,zero,v(2_${ik}$,1_${ik}$),ldv ) end if ! now, compute r2 = l3 * q3, the lq factorization. - call stdlib_sgelqf( nr, nr, v, ldv, work(2*n+n*nr+1),work(2*n+n*nr+nr+1), & + call stdlib${ii}$_sgelqf( nr, nr, v, ldv, work(2_${ik}$*n+n*nr+1),work(2_${ik}$*n+n*nr+nr+1), & lwork-2*n-n*nr-nr, ierr ) ! And Estimate The Condition Number - call stdlib_slacpy( 'L',nr,nr,v,ldv,work(2*n+n*nr+nr+1),nr ) + call stdlib${ii}$_slacpy( 'L',nr,nr,v,ldv,work(2_${ik}$*n+n*nr+nr+1),nr ) do p = 1, nr - temp1 = stdlib_snrm2( p, work(2*n+n*nr+nr+p), nr ) - call stdlib_sscal( p, one/temp1, work(2*n+n*nr+nr+p), nr ) + temp1 = stdlib${ii}$_snrm2( p, work(2_${ik}$*n+n*nr+nr+p), nr ) + call stdlib${ii}$_sscal( p, one/temp1, work(2_${ik}$*n+n*nr+nr+p), nr ) end do - call stdlib_spocon( 'L',nr,work(2*n+n*nr+nr+1),nr,one,temp1,work(2*n+n*nr+nr+& + call stdlib${ii}$_spocon( 'L',nr,work(2_${ik}$*n+n*nr+nr+1),nr,one,temp1,work(2_${ik}$*n+n*nr+nr+& nr*nr+1),iwork(m+2*n+1),ierr ) condr2 = one / sqrt(temp1) if ( condr2 >= cond_ok ) then @@ -71472,7 +71474,7 @@ module stdlib_linalg_lapack_s ! (this overwrites the copy of r2, as it will not be ! needed in this branch, but it does not overwritte the ! huseholder vectors of q2.). - call stdlib_slacpy( 'U', nr, nr, v, ldv, work(2*n+1), n ) + call stdlib${ii}$_slacpy( 'U', nr, nr, v, ldv, work(2_${ik}$*n+1), n ) ! And The Rest Of The Information On Q3 Is In ! work(2*n+n*nr+1:2*n+n*nr+n) end if @@ -71487,40 +71489,40 @@ module stdlib_linalg_lapack_s end do end do else - if (nr>1) call stdlib_slaset( 'U', nr-1,nr-1, zero,zero, v(1,2), ldv ) + if (nr>1_${ik}$) call stdlib${ii}$_slaset( 'U', nr-1,nr-1, zero,zero, v(1_${ik}$,2_${ik}$), ldv ) end if ! second preconditioning finished; continue with jacobi svd ! the input matrix is lower trinagular. ! recover the right singular vectors as solution of a well ! conditioned triangular matrix equation. if ( condr1 < cond_ok ) then - call stdlib_sgesvj( 'L','U','N',nr,nr,v,ldv,sva,nr,u,ldu,work(2*n+n*nr+nr+1),& + call stdlib${ii}$_sgesvj( 'L','U','N',nr,nr,v,ldv,sva,nr,u,ldu,work(2_${ik}$*n+n*nr+nr+1),& lwork-2*n-n*nr-nr,info ) - scalem = work(2*n+n*nr+nr+1) - numrank = nint(work(2*n+n*nr+nr+2),KIND=ilp) + scalem = work(2_${ik}$*n+n*nr+nr+1) + numrank = nint(work(2_${ik}$*n+n*nr+nr+2),KIND=${ik}$) do p = 1, nr - call stdlib_scopy( nr, v(1,p), 1, u(1,p), 1 ) - call stdlib_sscal( nr, sva(p), v(1,p), 1 ) + call stdlib${ii}$_scopy( nr, v(1_${ik}$,p), 1_${ik}$, u(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_sscal( nr, sva(p), v(1_${ik}$,p), 1_${ik}$ ) end do ! Pick The Right Matrix Equation And Solve It if ( nr == n ) then ! :)) .. best case, r1 is inverted. the solution of this matrix ! equation is q2*v2 = the product of the jacobi rotations - ! used in stdlib_sgesvj, premultiplied with the orthogonal matrix + ! used in stdlib${ii}$_sgesvj, premultiplied with the orthogonal matrix ! from the second qr factorization. - call stdlib_strsm( 'L','U','N','N', nr,nr,one, a,lda, v,ldv ) + call stdlib${ii}$_strsm( 'L','U','N','N', nr,nr,one, a,lda, v,ldv ) else ! .. r1 is well conditioned, but non-square. transpose(r2) ! is inverted to get the product of the jacobi rotations - ! used in stdlib_sgesvj. the q-factor from the second qr + ! used in stdlib${ii}$_sgesvj. the q-factor from the second qr ! factorization is then built in explicitly. - call stdlib_strsm('L','U','T','N',nr,nr,one,work(2*n+1),n,v,ldv) + call stdlib${ii}$_strsm('L','U','T','N',nr,nr,one,work(2_${ik}$*n+1),n,v,ldv) if ( nr < n ) then - call stdlib_slaset('A',n-nr,nr,zero,zero,v(nr+1,1),ldv) - call stdlib_slaset('A',nr,n-nr,zero,zero,v(1,nr+1),ldv) - call stdlib_slaset('A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv) + call stdlib${ii}$_slaset('A',n-nr,nr,zero,zero,v(nr+1,1_${ik}$),ldv) + call stdlib${ii}$_slaset('A',nr,n-nr,zero,zero,v(1_${ik}$,nr+1),ldv) + call stdlib${ii}$_slaset('A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv) end if - call stdlib_sormqr('L','N',n,n,nr,work(2*n+1),n,work(n+1),v,ldv,work(2*n+& + call stdlib${ii}$_sormqr('L','N',n,n,nr,work(2_${ik}$*n+1),n,work(n+1),v,ldv,work(2_${ik}$*n+& n*nr+nr+1),lwork-2*n-n*nr-nr,ierr) end if else if ( condr2 < cond_ok ) then @@ -71530,30 +71532,30 @@ module stdlib_linalg_lapack_s ! is q3^t*v3 = the product of the jacobi rotations (appplied to ! the lower triangular l3 from the lq factorization of ! r2=l3*q3), pre-multiplied with the transposed q3. - call stdlib_sgesvj( 'L', 'U', 'N', nr, nr, v, ldv, sva, nr, u,ldu, work(2*n+& + call stdlib${ii}$_sgesvj( 'L', 'U', 'N', nr, nr, v, ldv, sva, nr, u,ldu, work(2_${ik}$*n+& n*nr+nr+1), lwork-2*n-n*nr-nr, info ) - scalem = work(2*n+n*nr+nr+1) - numrank = nint(work(2*n+n*nr+nr+2),KIND=ilp) + scalem = work(2_${ik}$*n+n*nr+nr+1) + numrank = nint(work(2_${ik}$*n+n*nr+nr+2),KIND=${ik}$) do p = 1, nr - call stdlib_scopy( nr, v(1,p), 1, u(1,p), 1 ) - call stdlib_sscal( nr, sva(p), u(1,p), 1 ) + call stdlib${ii}$_scopy( nr, v(1_${ik}$,p), 1_${ik}$, u(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_sscal( nr, sva(p), u(1_${ik}$,p), 1_${ik}$ ) end do - call stdlib_strsm('L','U','N','N',nr,nr,one,work(2*n+1),n,u,ldu) + call stdlib${ii}$_strsm('L','U','N','N',nr,nr,one,work(2_${ik}$*n+1),n,u,ldu) ! Apply The Permutation From The Second Qr Factorization do q = 1, nr do p = 1, nr - work(2*n+n*nr+nr+iwork(n+p)) = u(p,q) + work(2_${ik}$*n+n*nr+nr+iwork(n+p)) = u(p,q) end do do p = 1, nr - u(p,q) = work(2*n+n*nr+nr+p) + u(p,q) = work(2_${ik}$*n+n*nr+nr+p) end do end do if ( nr < n ) then - call stdlib_slaset( 'A',n-nr,nr,zero,zero,v(nr+1,1),ldv ) - call stdlib_slaset( 'A',nr,n-nr,zero,zero,v(1,nr+1),ldv ) - call stdlib_slaset( 'A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv ) + call stdlib${ii}$_slaset( 'A',n-nr,nr,zero,zero,v(nr+1,1_${ik}$),ldv ) + call stdlib${ii}$_slaset( 'A',nr,n-nr,zero,zero,v(1_${ik}$,nr+1),ldv ) + call stdlib${ii}$_slaset( 'A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv ) end if - call stdlib_sormqr( 'L','N',n,n,nr,work(2*n+1),n,work(n+1),v,ldv,work(2*n+& + call stdlib${ii}$_sormqr( 'L','N',n,n,nr,work(2_${ik}$*n+1),n,work(n+1),v,ldv,work(2_${ik}$*n+& n*nr+nr+1),lwork-2*n-n*nr-nr,ierr ) else ! last line of defense. @@ -71564,28 +71566,28 @@ module stdlib_linalg_lapack_s ! is set very close to one (which is unnecessary). normally, ! this branch should never be executed, but in rare cases of ! failure of the rrqr or condition estimator, the last line of - ! defense ensures that stdlib_sgejsv completes the task. - ! compute the full svd of l3 using stdlib_sgesvj with explicit + ! defense ensures that stdlib${ii}$_sgejsv completes the task. + ! compute the full svd of l3 using stdlib${ii}$_sgesvj with explicit ! accumulation of jacobi rotations. - call stdlib_sgesvj( 'L', 'U', 'V', nr, nr, v, ldv, sva, nr, u,ldu, work(2*n+& + call stdlib${ii}$_sgesvj( 'L', 'U', 'V', nr, nr, v, ldv, sva, nr, u,ldu, work(2_${ik}$*n+& n*nr+nr+1), lwork-2*n-n*nr-nr, info ) - scalem = work(2*n+n*nr+nr+1) - numrank = nint(work(2*n+n*nr+nr+2),KIND=ilp) + scalem = work(2_${ik}$*n+n*nr+nr+1) + numrank = nint(work(2_${ik}$*n+n*nr+nr+2),KIND=${ik}$) if ( nr < n ) then - call stdlib_slaset( 'A',n-nr,nr,zero,zero,v(nr+1,1),ldv ) - call stdlib_slaset( 'A',nr,n-nr,zero,zero,v(1,nr+1),ldv ) - call stdlib_slaset( 'A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv ) + call stdlib${ii}$_slaset( 'A',n-nr,nr,zero,zero,v(nr+1,1_${ik}$),ldv ) + call stdlib${ii}$_slaset( 'A',nr,n-nr,zero,zero,v(1_${ik}$,nr+1),ldv ) + call stdlib${ii}$_slaset( 'A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv ) end if - call stdlib_sormqr( 'L','N',n,n,nr,work(2*n+1),n,work(n+1),v,ldv,work(2*n+& + call stdlib${ii}$_sormqr( 'L','N',n,n,nr,work(2_${ik}$*n+1),n,work(n+1),v,ldv,work(2_${ik}$*n+& n*nr+nr+1),lwork-2*n-n*nr-nr,ierr ) - call stdlib_sormlq( 'L', 'T', nr, nr, nr, work(2*n+1), n,work(2*n+n*nr+1), u, & - ldu, work(2*n+n*nr+nr+1),lwork-2*n-n*nr-nr, ierr ) + call stdlib${ii}$_sormlq( 'L', 'T', nr, nr, nr, work(2_${ik}$*n+1), n,work(2_${ik}$*n+n*nr+1), u, & + ldu, work(2_${ik}$*n+n*nr+nr+1),lwork-2*n-n*nr-nr, ierr ) do q = 1, nr do p = 1, nr - work(2*n+n*nr+nr+iwork(n+p)) = u(p,q) + work(2_${ik}$*n+n*nr+nr+iwork(n+p)) = u(p,q) end do do p = 1, nr - u(p,q) = work(2*n+n*nr+nr+p) + u(p,q) = work(2_${ik}$*n+n*nr+nr+p) end do end do end if @@ -71595,42 +71597,42 @@ module stdlib_linalg_lapack_s temp1 = sqrt(real(n,KIND=sp)) * epsln do q = 1, n do p = 1, n - work(2*n+n*nr+nr+iwork(p)) = v(p,q) + work(2_${ik}$*n+n*nr+nr+iwork(p)) = v(p,q) end do do p = 1, n - v(p,q) = work(2*n+n*nr+nr+p) + v(p,q) = work(2_${ik}$*n+n*nr+nr+p) end do - xsc = one / stdlib_snrm2( n, v(1,q), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_sscal( n, xsc, & - v(1,q), 1 ) + xsc = one / stdlib${ii}$_snrm2( n, v(1_${ik}$,q), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_sscal( n, xsc, & + v(1_${ik}$,q), 1_${ik}$ ) end do ! at this moment, v contains the right singular vectors of a. ! next, assemble the left singular vector matrix u (m x n). if ( nr < m ) then - call stdlib_slaset( 'A', m-nr, nr, zero, zero, u(nr+1,1), ldu ) + call stdlib${ii}$_slaset( 'A', m-nr, nr, zero, zero, u(nr+1,1_${ik}$), ldu ) if ( nr < n1 ) then - call stdlib_slaset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) - call stdlib_slaset('A',m-nr,n1-nr,zero,one,u(nr+1,nr+1),ldu) + call stdlib${ii}$_slaset('A',nr,n1-nr,zero,zero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_slaset('A',m-nr,n1-nr,zero,one,u(nr+1,nr+1),ldu) end if end if ! the q matrix from the first qrf is built into the left singular ! matrix u. this applies to all cases. - call stdlib_sormqr( 'LEFT', 'NO_TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & + call stdlib${ii}$_sormqr( 'LEFT', 'NO_TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & lwork-n, ierr ) ! the columns of u are normalized. the cost is o(m*n) flops. temp1 = sqrt(real(m,KIND=sp)) * epsln do p = 1, nr - xsc = one / stdlib_snrm2( m, u(1,p), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_sscal( m, xsc, & - u(1,p), 1 ) + xsc = one / stdlib${ii}$_snrm2( m, u(1_${ik}$,p), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_sscal( m, xsc, & + u(1_${ik}$,p), 1_${ik}$ ) end do ! if the initial qrf is computed with row pivoting, the left ! singular vectors must be adjusted. - if ( rowpiv )call stdlib_slaswp( n1, u, ldu, 1, m-1, iwork(2*n+1), -1 ) + if ( rowpiv )call stdlib${ii}$_slaswp( n1, u, ldu, 1_${ik}$, m-1, iwork(2_${ik}$*n+1), -1_${ik}$ ) else ! The Initial Matrix A Has Almost Orthogonal Columns And ! the second qrf is not needed - call stdlib_slacpy( 'UPPER', n, n, a, lda, work(n+1), n ) + call stdlib${ii}$_slacpy( 'UPPER', n, n, a, lda, work(n+1), n ) if ( l2pert ) then xsc = sqrt(small) do p = 2, n @@ -71640,44 +71642,44 @@ module stdlib_linalg_lapack_s end do end do else - call stdlib_slaset( 'LOWER',n-1,n-1,zero,zero,work(n+2),n ) + call stdlib${ii}$_slaset( 'LOWER',n-1,n-1,zero,zero,work(n+2),n ) end if - call stdlib_sgesvj( 'UPPER', 'U', 'N', n, n, work(n+1), n, sva,n, u, ldu, work(n+& + call stdlib${ii}$_sgesvj( 'UPPER', 'U', 'N', n, n, work(n+1), n, sva,n, u, ldu, work(n+& n*n+1), lwork-n-n*n, info ) scalem = work(n+n*n+1) - numrank = nint(work(n+n*n+2),KIND=ilp) + numrank = nint(work(n+n*n+2),KIND=${ik}$) do p = 1, n - call stdlib_scopy( n, work(n+(p-1)*n+1), 1, u(1,p), 1 ) - call stdlib_sscal( n, sva(p), work(n+(p-1)*n+1), 1 ) + call stdlib${ii}$_scopy( n, work(n+(p-1)*n+1), 1_${ik}$, u(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_sscal( n, sva(p), work(n+(p-1)*n+1), 1_${ik}$ ) end do - call stdlib_strsm( 'LEFT', 'UPPER', 'NOTRANS', 'NO UD', n, n,one, a, lda, work(n+& - 1), n ) + call stdlib${ii}$_strsm( 'LEFT', 'UPPER', 'NOTRANS', 'NO UD', n, n,one, a, lda, work(n+& + 1_${ik}$), n ) do p = 1, n - call stdlib_scopy( n, work(n+p), n, v(iwork(p),1), ldv ) + call stdlib${ii}$_scopy( n, work(n+p), n, v(iwork(p),1_${ik}$), ldv ) end do temp1 = sqrt(real(n,KIND=sp))*epsln do p = 1, n - xsc = one / stdlib_snrm2( n, v(1,p), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_sscal( n, xsc, & - v(1,p), 1 ) + xsc = one / stdlib${ii}$_snrm2( n, v(1_${ik}$,p), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_sscal( n, xsc, & + v(1_${ik}$,p), 1_${ik}$ ) end do ! assemble the left singular vector matrix u (m x n). if ( n < m ) then - call stdlib_slaset( 'A', m-n, n, zero, zero, u(n+1,1), ldu ) + call stdlib${ii}$_slaset( 'A', m-n, n, zero, zero, u(n+1,1_${ik}$), ldu ) if ( n < n1 ) then - call stdlib_slaset( 'A',n, n1-n, zero, zero, u(1,n+1),ldu ) - call stdlib_slaset( 'A',m-n,n1-n, zero, one,u(n+1,n+1),ldu ) + call stdlib${ii}$_slaset( 'A',n, n1-n, zero, zero, u(1_${ik}$,n+1),ldu ) + call stdlib${ii}$_slaset( 'A',m-n,n1-n, zero, one,u(n+1,n+1),ldu ) end if end if - call stdlib_sormqr( 'LEFT', 'NO TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & + call stdlib${ii}$_sormqr( 'LEFT', 'NO TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & lwork-n, ierr ) temp1 = sqrt(real(m,KIND=sp))*epsln do p = 1, n1 - xsc = one / stdlib_snrm2( m, u(1,p), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_sscal( m, xsc, & - u(1,p), 1 ) + xsc = one / stdlib${ii}$_snrm2( m, u(1_${ik}$,p), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_sscal( m, xsc, & + u(1_${ik}$,p), 1_${ik}$ ) end do - if ( rowpiv )call stdlib_slaswp( n1, u, ldu, 1, m-1, iwork(2*n+1), -1 ) + if ( rowpiv )call stdlib${ii}$_slaswp( n1, u, ldu, 1_${ik}$, m-1, iwork(2_${ik}$*n+1), -1_${ik}$ ) end if ! end of the >> almost orthogonal case << in the full svd else @@ -71691,7 +71693,7 @@ module stdlib_linalg_lapack_s ! implementation of blas and some lapack procedures, capable of working ! in presence of extreme values. since that is not always the case, ... do p = 1, nr - call stdlib_scopy( n-p+1, a(p,p), lda, v(p,p), 1 ) + call stdlib${ii}$_scopy( n-p+1, a(p,p), lda, v(p,p), 1_${ik}$ ) end do if ( l2pert ) then xsc = sqrt(small/epsln) @@ -71704,12 +71706,12 @@ module stdlib_linalg_lapack_s end do end do else - if (nr>1) call stdlib_slaset( 'U', nr-1, nr-1, zero, zero, v(1,2), ldv ) + if (nr>1_${ik}$) call stdlib${ii}$_slaset( 'U', nr-1, nr-1, zero, zero, v(1_${ik}$,2_${ik}$), ldv ) end if - call stdlib_sgeqrf( n, nr, v, ldv, work(n+1), work(2*n+1),lwork-2*n, ierr ) - call stdlib_slacpy( 'L', n, nr, v, ldv, work(2*n+1), n ) + call stdlib${ii}$_sgeqrf( n, nr, v, ldv, work(n+1), work(2_${ik}$*n+1),lwork-2*n, ierr ) + call stdlib${ii}$_slacpy( 'L', n, nr, v, ldv, work(2_${ik}$*n+1), n ) do p = 1, nr - call stdlib_scopy( nr-p+1, v(p,p), ldv, u(p,p), 1 ) + call stdlib${ii}$_scopy( nr-p+1, v(p,p), ldv, u(p,p), 1_${ik}$ ) end do if ( l2pert ) then xsc = sqrt(small/epsln) @@ -71720,18 +71722,18 @@ module stdlib_linalg_lapack_s end do end do else - if (nr>1) call stdlib_slaset('U', nr-1, nr-1, zero, zero, u(1,2), ldu ) + if (nr>1_${ik}$) call stdlib${ii}$_slaset('U', nr-1, nr-1, zero, zero, u(1_${ik}$,2_${ik}$), ldu ) end if - call stdlib_sgesvj( 'L', 'U', 'V', nr, nr, u, ldu, sva,n, v, ldv, work(2*n+n*nr+1), & + call stdlib${ii}$_sgesvj( 'L', 'U', 'V', nr, nr, u, ldu, sva,n, v, ldv, work(2_${ik}$*n+n*nr+1), & lwork-2*n-n*nr, info ) - scalem = work(2*n+n*nr+1) - numrank = nint(work(2*n+n*nr+2),KIND=ilp) + scalem = work(2_${ik}$*n+n*nr+1) + numrank = nint(work(2_${ik}$*n+n*nr+2),KIND=${ik}$) if ( nr < n ) then - call stdlib_slaset( 'A',n-nr,nr,zero,zero,v(nr+1,1),ldv ) - call stdlib_slaset( 'A',nr,n-nr,zero,zero,v(1,nr+1),ldv ) - call stdlib_slaset( 'A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv ) + call stdlib${ii}$_slaset( 'A',n-nr,nr,zero,zero,v(nr+1,1_${ik}$),ldv ) + call stdlib${ii}$_slaset( 'A',nr,n-nr,zero,zero,v(1_${ik}$,nr+1),ldv ) + call stdlib${ii}$_slaset( 'A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv ) end if - call stdlib_sormqr( 'L','N',n,n,nr,work(2*n+1),n,work(n+1),v,ldv,work(2*n+n*nr+nr+1)& + call stdlib${ii}$_sormqr( 'L','N',n,n,nr,work(2_${ik}$*n+1),n,work(n+1),v,ldv,work(2_${ik}$*n+n*nr+nr+1)& ,lwork-2*n-n*nr-nr,ierr ) ! permute the rows of v using the (column) permutation from the ! first qrf. also, scale the columns to make them unit in @@ -71739,39 +71741,39 @@ module stdlib_linalg_lapack_s temp1 = sqrt(real(n,KIND=sp)) * epsln do q = 1, n do p = 1, n - work(2*n+n*nr+nr+iwork(p)) = v(p,q) + work(2_${ik}$*n+n*nr+nr+iwork(p)) = v(p,q) end do do p = 1, n - v(p,q) = work(2*n+n*nr+nr+p) + v(p,q) = work(2_${ik}$*n+n*nr+nr+p) end do - xsc = one / stdlib_snrm2( n, v(1,q), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_sscal( n, xsc, & - v(1,q), 1 ) + xsc = one / stdlib${ii}$_snrm2( n, v(1_${ik}$,q), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_sscal( n, xsc, & + v(1_${ik}$,q), 1_${ik}$ ) end do ! at this moment, v contains the right singular vectors of a. ! next, assemble the left singular vector matrix u (m x n). if ( nr < m ) then - call stdlib_slaset( 'A', m-nr, nr, zero, zero, u(nr+1,1), ldu ) + call stdlib${ii}$_slaset( 'A', m-nr, nr, zero, zero, u(nr+1,1_${ik}$), ldu ) if ( nr < n1 ) then - call stdlib_slaset( 'A',nr, n1-nr, zero, zero, u(1,nr+1),ldu ) - call stdlib_slaset( 'A',m-nr,n1-nr, zero, one,u(nr+1,nr+1),ldu ) + call stdlib${ii}$_slaset( 'A',nr, n1-nr, zero, zero, u(1_${ik}$,nr+1),ldu ) + call stdlib${ii}$_slaset( 'A',m-nr,n1-nr, zero, one,u(nr+1,nr+1),ldu ) end if end if - call stdlib_sormqr( 'LEFT', 'NO TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & + call stdlib${ii}$_sormqr( 'LEFT', 'NO TR', m, n1, n, a, lda, work, u,ldu, work(n+1), & lwork-n, ierr ) - if ( rowpiv )call stdlib_slaswp( n1, u, ldu, 1, m-1, iwork(2*n+1), -1 ) + if ( rowpiv )call stdlib${ii}$_slaswp( n1, u, ldu, 1_${ik}$, m-1, iwork(2_${ik}$*n+1), -1_${ik}$ ) end if if ( transp ) then ! .. swap u and v because the procedure worked on a^t do p = 1, n - call stdlib_sswap( n, u(1,p), 1, v(1,p), 1 ) + call stdlib${ii}$_sswap( n, u(1_${ik}$,p), 1_${ik}$, v(1_${ik}$,p), 1_${ik}$ ) end do end if end if ! end of the full svd ! undo scaling, if necessary (and possible) - if ( uscal2 <= (big/sva(1))*uscal1 ) then - call stdlib_slascl( 'G', 0, 0, uscal1, uscal2, nr, 1, sva, n, ierr ) + if ( uscal2 <= (big/sva(1_${ik}$))*uscal1 ) then + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, uscal1, uscal2, nr, 1_${ik}$, sva, n, ierr ) uscal1 = one uscal2 = one end if @@ -71780,25 +71782,25 @@ module stdlib_linalg_lapack_s sva(p) = zero end do end if - work(1) = uscal2 * scalem - work(2) = uscal1 - if ( errest ) work(3) = sconda + work(1_${ik}$) = uscal2 * scalem + work(2_${ik}$) = uscal1 + if ( errest ) work(3_${ik}$) = sconda if ( lsvec .and. rsvec ) then - work(4) = condr1 - work(5) = condr2 + work(4_${ik}$) = condr1 + work(5_${ik}$) = condr2 end if if ( l2tran ) then - work(6) = entra - work(7) = entrat + work(6_${ik}$) = entra + work(7_${ik}$) = entrat end if - iwork(1) = nr - iwork(2) = numrank - iwork(3) = warning + iwork(1_${ik}$) = nr + iwork(2_${ik}$) = numrank + iwork(3_${ik}$) = warning return - end subroutine stdlib_sgejsv + end subroutine stdlib${ii}$_sgejsv - subroutine stdlib_sgelsd( m, n, nrhs, a, lda, b, ldb, s, rcond,rank, work, lwork, iwork, & + subroutine stdlib${ii}$_sgelsd( m, n, nrhs, a, lda, b, ldb, s, rcond,rank, work, lwork, iwork, & !! SGELSD computes the minimum-norm solution to a real linear least !! squares problem: !! minimize 2-norm(| b - A*x |) @@ -71829,169 +71831,169 @@ 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, rank - integer(ilp), intent(in) :: lda, ldb, lwork, m, n, nrhs + integer(${ik}$), intent(out) :: info, rank + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, nrhs real(sp), intent(in) :: rcond ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(inout) :: a(lda,*), b(ldb,*) real(sp), intent(out) :: s(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: iascl, ibscl, ie, il, itau, itaup, itauq, ldwork, liwork, maxmn, & + integer(${ik}$) :: iascl, ibscl, ie, il, itau, itaup, itauq, ldwork, liwork, maxmn, & maxwrk, minmn, minwrk, mm, mnthr, nlvl, nwork, smlsiz, wlalsd real(sp) :: anrm, bignum, bnrm, eps, sfmin, smlnum ! Intrinsic Functions intrinsic :: int,log,max,min,real ! Executable Statements ! test the input arguments. - info = 0 + info = 0_${ik}$ minmn = min( m, n ) maxmn = max( m, n ) - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( lda0 ) then - smlsiz = stdlib_ilaenv( 9, 'SGELSD', ' ', 0, 0, 0, 0 ) - mnthr = stdlib_ilaenv( 6, 'SGELSD', ' ', m, n, nrhs, -1 ) - nlvl = max( int( log( real( minmn,KIND=sp) / real( smlsiz + 1,KIND=sp) ) /log( & - two ),KIND=ilp) + 1, 0 ) - liwork = 3*minmn*nlvl + 11*minmn + ! following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + liwork = 1_${ik}$ + if( minmn>0_${ik}$ ) then + smlsiz = stdlib${ii}$_ilaenv( 9_${ik}$, 'SGELSD', ' ', 0_${ik}$, 0_${ik}$, 0_${ik}$, 0_${ik}$ ) + mnthr = stdlib${ii}$_ilaenv( 6_${ik}$, 'SGELSD', ' ', m, n, nrhs, -1_${ik}$ ) + nlvl = max( int( log( real( minmn,KIND=sp) / real( smlsiz + 1_${ik}$,KIND=sp) ) /log( & + two ),KIND=${ik}$) + 1_${ik}$, 0_${ik}$ ) + liwork = 3_${ik}$*minmn*nlvl + 11_${ik}$*minmn mm = m if( m>=n .and. m>=mnthr ) then ! path 1a - overdetermined, with many more rows than ! columns. mm = n - maxwrk = max( maxwrk, n + n*stdlib_ilaenv( 1, 'SGEQRF', ' ', m,n, -1, -1 ) ) + maxwrk = max( maxwrk, n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEQRF', ' ', m,n, -1_${ik}$, -1_${ik}$ ) ) - maxwrk = max( maxwrk, n + nrhs*stdlib_ilaenv( 1, 'SORMQR', 'LT',m, nrhs, n, -& - 1 ) ) + maxwrk = max( maxwrk, n + nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMQR', 'LT',m, nrhs, n, -& + 1_${ik}$ ) ) end if if( m>=n ) then ! path 1 - overdetermined or exactly determined. - maxwrk = max( maxwrk, 3*n + ( mm + n )*stdlib_ilaenv( 1,'SGEBRD', ' ', mm, n, & - -1, -1 ) ) - maxwrk = max( maxwrk, 3*n + nrhs*stdlib_ilaenv( 1, 'SORMBR','QLT', mm, nrhs, & - n, -1 ) ) - maxwrk = max( maxwrk, 3*n + ( n - 1 )*stdlib_ilaenv( 1,'SORMBR', 'PLN', n, & - nrhs, n, -1 ) ) - wlalsd = 9*n + 2*n*smlsiz + 8*n*nlvl + n*nrhs +( smlsiz + 1 )**2 - maxwrk = max( maxwrk, 3*n + wlalsd ) - minwrk = max( 3*n + mm, 3*n + nrhs, 3*n + wlalsd ) + maxwrk = max( maxwrk, 3_${ik}$*n + ( mm + n )*stdlib${ii}$_ilaenv( 1_${ik}$,'SGEBRD', ' ', mm, n, & + -1_${ik}$, -1_${ik}$ ) ) + maxwrk = max( maxwrk, 3_${ik}$*n + nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMBR','QLT', mm, nrhs, & + n, -1_${ik}$ ) ) + maxwrk = max( maxwrk, 3_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'SORMBR', 'PLN', n, & + nrhs, n, -1_${ik}$ ) ) + wlalsd = 9_${ik}$*n + 2_${ik}$*n*smlsiz + 8_${ik}$*n*nlvl + n*nrhs +( smlsiz + 1_${ik}$ )**2_${ik}$ + maxwrk = max( maxwrk, 3_${ik}$*n + wlalsd ) + minwrk = max( 3_${ik}$*n + mm, 3_${ik}$*n + nrhs, 3_${ik}$*n + wlalsd ) end if if( n>m ) then - wlalsd = 9*m + 2*m*smlsiz + 8*m*nlvl + m*nrhs +( smlsiz + 1 )**2 + wlalsd = 9_${ik}$*m + 2_${ik}$*m*smlsiz + 8_${ik}$*m*nlvl + m*nrhs +( smlsiz + 1_${ik}$ )**2_${ik}$ if( n>=mnthr ) then ! path 2a - underdetermined, with many more columns ! than rows. - maxwrk = m + m*stdlib_ilaenv( 1, 'SGELQF', ' ', m, n, -1,-1 ) - maxwrk = max( maxwrk, m*m + 4*m + 2*m*stdlib_ilaenv( 1,'SGEBRD', ' ', m, m,& - -1, -1 ) ) - maxwrk = max( maxwrk, m*m + 4*m + nrhs*stdlib_ilaenv( 1,'SORMBR', 'QLT', m,& - nrhs, m, -1 ) ) - maxwrk = max( maxwrk, m*m + 4*m + ( m - 1 )*stdlib_ilaenv( 1,'SORMBR', & - 'PLN', m, nrhs, m, -1 ) ) - if( nrhs>1 ) then + maxwrk = m + m*stdlib${ii}$_ilaenv( 1_${ik}$, 'SGELQF', ' ', m, n, -1_${ik}$,-1_${ik}$ ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + 2_${ik}$*m*stdlib${ii}$_ilaenv( 1_${ik}$,'SGEBRD', ' ', m, m,& + -1_${ik}$, -1_${ik}$ ) ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + nrhs*stdlib${ii}$_ilaenv( 1_${ik}$,'SORMBR', 'QLT', m,& + nrhs, m, -1_${ik}$ ) ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + ( m - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'SORMBR', & + 'PLN', m, nrhs, m, -1_${ik}$ ) ) + if( nrhs>1_${ik}$ ) then maxwrk = max( maxwrk, m*m + m + m*nrhs ) else - maxwrk = max( maxwrk, m*m + 2*m ) + maxwrk = max( maxwrk, m*m + 2_${ik}$*m ) end if - maxwrk = max( maxwrk, m + nrhs*stdlib_ilaenv( 1, 'SORMLQ','LT', n, nrhs, m,& - -1 ) ) - maxwrk = max( maxwrk, m*m + 4*m + wlalsd ) + maxwrk = max( maxwrk, m + nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMLQ','LT', n, nrhs, m,& + -1_${ik}$ ) ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + wlalsd ) ! xxx: ensure the path 2a case below is triggered. the workspace ! calculation should use queries for all routines eventually. - maxwrk = max( maxwrk,4*m+m*m+max( m, 2*m-4, nrhs, n-3*m ) ) + maxwrk = max( maxwrk,4_${ik}$*m+m*m+max( m, 2_${ik}$*m-4, nrhs, n-3*m ) ) else ! path 2 - remaining underdetermined cases. - maxwrk = 3*m + ( n + m )*stdlib_ilaenv( 1, 'SGEBRD', ' ', m,n, -1, -1 ) + maxwrk = 3_${ik}$*m + ( n + m )*stdlib${ii}$_ilaenv( 1_${ik}$, 'SGEBRD', ' ', m,n, -1_${ik}$, -1_${ik}$ ) - maxwrk = max( maxwrk, 3*m + nrhs*stdlib_ilaenv( 1, 'SORMBR','QLT', m, nrhs,& - n, -1 ) ) - maxwrk = max( maxwrk, 3*m + m*stdlib_ilaenv( 1, 'SORMBR','PLN', n, nrhs, m,& - -1 ) ) - maxwrk = max( maxwrk, 3*m + wlalsd ) + maxwrk = max( maxwrk, 3_${ik}$*m + nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMBR','QLT', m, nrhs,& + n, -1_${ik}$ ) ) + maxwrk = max( maxwrk, 3_${ik}$*m + m*stdlib${ii}$_ilaenv( 1_${ik}$, 'SORMBR','PLN', n, nrhs, m,& + -1_${ik}$ ) ) + maxwrk = max( maxwrk, 3_${ik}$*m + wlalsd ) end if - minwrk = max( 3*m + nrhs, 3*m + m, 3*m + wlalsd ) + minwrk = max( 3_${ik}$*m + nrhs, 3_${ik}$*m + m, 3_${ik}$*m + wlalsd ) end if end if minwrk = min( minwrk, maxwrk ) - work( 1 ) = maxwrk - iwork( 1 ) = liwork + work( 1_${ik}$ ) = maxwrk + iwork( 1_${ik}$ ) = liwork if( lworkzero .and. anrmbignum ) then ! scale matrix norm down to bignum. - call stdlib_slascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_slaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) - call stdlib_slaset( 'F', minmn, 1, zero, zero, s, 1 ) - rank = 0 + call stdlib${ii}$_slaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) + call stdlib${ii}$_slaset( 'F', minmn, 1_${ik}$, zero, zero, s, 1_${ik}$ ) + rank = 0_${ik}$ go to 10 end if ! scale b if max entry outside range [smlnum,bignum]. - bnrm = stdlib_slange( 'M', m, nrhs, b, ldb, work ) - ibscl = 0 + bnrm = stdlib${ii}$_slange( 'M', m, nrhs, b, ldb, work ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum. - call stdlib_slascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) - ibscl = 2 + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, m, nrhs, b, ldb, info ) + ibscl = 2_${ik}$ end if ! if m < n make sure certain entries of b are zero. - if( m=n ) then ! path 1 - overdetermined or exactly determined. @@ -71999,132 +72001,132 @@ module stdlib_linalg_lapack_s if( m>=mnthr ) then ! path 1a - overdetermined, with many more rows than columns. mm = n - itau = 1 + itau = 1_${ik}$ nwork = itau + n ! compute a=q*r. ! (workspace: need 2*n, prefer n+n*nb) - call stdlib_sgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_sgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & info ) ! multiply b by transpose(q). ! (workspace: need n+nrhs, prefer n+nrhs*nb) - call stdlib_sormqr( 'L', 'T', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & + call stdlib${ii}$_sormqr( 'L', 'T', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & nwork ), lwork-nwork+1, info ) ! zero out below r. - if( n>1 ) then - call stdlib_slaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_slaset( 'L', n-1, n-1, zero, zero, a( 2_${ik}$, 1_${ik}$ ), lda ) end if end if - ie = 1 + ie = 1_${ik}$ itauq = ie + n itaup = itauq + n nwork = itaup + n ! bidiagonalize r in a. ! (workspace: need 3*n+mm, prefer 3*n+(mm+n)*nb) - call stdlib_sgebrd( mm, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work(& + call stdlib${ii}$_sgebrd( mm, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work(& nwork ), lwork-nwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors of r. ! (workspace: need 3*n+nrhs, prefer 3*n+nrhs*nb) - call stdlib_sormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib${ii}$_sormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & nwork ), lwork-nwork+1, info ) ! solve the bidiagonal least squares problem. - call stdlib_slalsd( 'U', smlsiz, n, nrhs, s, work( ie ), b, ldb,rcond, rank, work( & + call stdlib${ii}$_slalsd( 'U', smlsiz, n, nrhs, s, work( ie ), b, ldb,rcond, rank, work( & nwork ), iwork, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then go to 10 end if ! multiply b by right bidiagonalizing vectors of r. - call stdlib_sormbr( 'P', 'L', 'N', n, nrhs, n, a, lda, work( itaup ),b, ldb, work( & + call stdlib${ii}$_sormbr( 'P', 'L', 'N', n, nrhs, n, a, lda, work( itaup ),b, ldb, work( & nwork ), lwork-nwork+1, info ) - else if( n>=mnthr .and. lwork>=4*m+m*m+max( m, 2*m-4, nrhs, n-3*m, wlalsd ) ) & + else if( n>=mnthr .and. lwork>=4_${ik}$*m+m*m+max( m, 2_${ik}$*m-4, nrhs, n-3*m, wlalsd ) ) & then ! path 2a - underdetermined, with many more columns than rows ! and sufficient workspace for an efficient algorithm. ldwork = m - if( lwork>=max( 4*m+m*lda+max( m, 2*m-4, nrhs, n-3*m ),m*lda+m+m*nrhs, 4*m+m*lda+& + if( lwork>=max( 4_${ik}$*m+m*lda+max( m, 2_${ik}$*m-4, nrhs, n-3*m ),m*lda+m+m*nrhs, 4_${ik}$*m+m*lda+& wlalsd ) )ldwork = lda - itau = 1 - nwork = m + 1 + itau = 1_${ik}$ + nwork = m + 1_${ik}$ ! compute a=l*q. ! (workspace: need 2*m, prefer m+m*nb) - call stdlib_sgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, info ) + call stdlib${ii}$_sgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, info ) il = nwork ! copy l to work(il), zeroing out above its diagonal. - call stdlib_slacpy( 'L', m, m, a, lda, work( il ), ldwork ) - call stdlib_slaset( 'U', m-1, m-1, zero, zero, work( il+ldwork ),ldwork ) + call stdlib${ii}$_slacpy( 'L', m, m, a, lda, work( il ), ldwork ) + call stdlib${ii}$_slaset( 'U', m-1, m-1, zero, zero, work( il+ldwork ),ldwork ) ie = il + ldwork*m itauq = ie + m itaup = itauq + m nwork = itaup + m ! bidiagonalize l in work(il). ! (workspace: need m*m+5*m, prefer m*m+4*m+2*m*nb) - call stdlib_sgebrd( m, m, work( il ), ldwork, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_sgebrd( m, m, work( il ), ldwork, s, work( ie ),work( itauq ), work( & itaup ), work( nwork ),lwork-nwork+1, info ) ! multiply b by transpose of left bidiagonalizing vectors of l. ! (workspace: need m*m+4*m+nrhs, prefer m*m+4*m+nrhs*nb) - call stdlib_sormbr( 'Q', 'L', 'T', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & + call stdlib${ii}$_sormbr( 'Q', 'L', 'T', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & ldb, work( nwork ),lwork-nwork+1, info ) ! solve the bidiagonal least squares problem. - call stdlib_slalsd( 'U', smlsiz, m, nrhs, s, work( ie ), b, ldb,rcond, rank, work( & + call stdlib${ii}$_slalsd( 'U', smlsiz, m, nrhs, s, work( ie ), b, ldb,rcond, rank, work( & nwork ), iwork, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then go to 10 end if ! multiply b by right bidiagonalizing vectors of l. - call stdlib_sormbr( 'P', 'L', 'N', m, nrhs, m, work( il ), ldwork,work( itaup ), b, & + call stdlib${ii}$_sormbr( 'P', 'L', 'N', m, nrhs, m, work( il ), ldwork,work( itaup ), b, & ldb, work( nwork ),lwork-nwork+1, info ) ! zero out below first m rows of b. - call stdlib_slaset( 'F', n-m, nrhs, zero, zero, b( m+1, 1 ), ldb ) + call stdlib${ii}$_slaset( 'F', n-m, nrhs, zero, zero, b( m+1, 1_${ik}$ ), ldb ) nwork = itau + m ! multiply transpose(q) by b. ! (workspace: need m+nrhs, prefer m+nrhs*nb) - call stdlib_sormlq( 'L', 'T', n, nrhs, m, a, lda, work( itau ), b,ldb, work( nwork )& + call stdlib${ii}$_sormlq( 'L', 'T', n, nrhs, m, a, lda, work( itau ), b,ldb, work( nwork )& , lwork-nwork+1, info ) else ! path 2 - remaining underdetermined cases. - ie = 1 + ie = 1_${ik}$ itauq = ie + m itaup = itauq + m nwork = itaup + m ! bidiagonalize a. ! (workspace: need 3*m+n, prefer 3*m+(m+n)*nb) - call stdlib_sgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work( & + call stdlib${ii}$_sgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work( & nwork ), lwork-nwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors. ! (workspace: need 3*m+nrhs, prefer 3*m+nrhs*nb) - call stdlib_sormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib${ii}$_sormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & nwork ), lwork-nwork+1, info ) ! solve the bidiagonal least squares problem. - call stdlib_slalsd( 'L', smlsiz, m, nrhs, s, work( ie ), b, ldb,rcond, rank, work( & + call stdlib${ii}$_slalsd( 'L', smlsiz, m, nrhs, s, work( ie ), b, ldb,rcond, rank, work( & nwork ), iwork, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then go to 10 end if ! multiply b by right bidiagonalizing vectors of a. - call stdlib_sormbr( 'P', 'L', 'N', n, nrhs, m, a, lda, work( itaup ),b, ldb, work( & + call stdlib${ii}$_sormbr( 'P', 'L', 'N', n, nrhs, m, a, lda, work( itaup ),b, ldb, work( & nwork ), lwork-nwork+1, info ) end if ! undo scaling. - if( iascl==1 ) then - call stdlib_slascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info ) - call stdlib_slascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn,info ) - else if( iascl==2 ) then - call stdlib_slascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info ) - call stdlib_slascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,info ) - end if - if( ibscl==1 ) then - call stdlib_slascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info ) - else if( ibscl==2 ) then - call stdlib_slascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info ) + if( iascl==1_${ik}$ ) then + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, smlnum, n, nrhs, b, ldb, info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, anrm, minmn, 1_${ik}$, s, minmn,info ) + else if( iascl==2_${ik}$ ) then + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, n, nrhs, b, ldb, info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn, 1_${ik}$, s, minmn,info ) + end if + if( ibscl==1_${ik}$ ) then + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, bnrm, n, nrhs, b, ldb, info ) + else if( ibscl==2_${ik}$ ) then + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bignum, bnrm, n, nrhs, b, ldb, info ) end if 10 continue - work( 1 ) = maxwrk - iwork( 1 ) = liwork + work( 1_${ik}$ ) = maxwrk + iwork( 1_${ik}$ ) = liwork return - end subroutine stdlib_sgelsd + end subroutine stdlib${ii}$_sgelsd - subroutine stdlib_sgelss( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, info ) + subroutine stdlib${ii}$_sgelss( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, info ) !! SGELSS computes the minimum norm solution to a real linear least !! squares problem: !! Minimize 2-norm(| b - A*x |). @@ -72142,8 +72144,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, rank - integer(ilp), intent(in) :: lda, ldb, lwork, m, n, nrhs + integer(${ik}$), intent(out) :: info, rank + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, nrhs real(sp), intent(in) :: rcond ! Array Arguments real(sp), intent(inout) :: a(lda,*), b(ldb,*) @@ -72152,187 +72154,187 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: lquery - integer(ilp) :: bdspac, bl, chunk, i, iascl, ibscl, ie, il, itau, itaup, itauq, iwork, & + integer(${ik}$) :: bdspac, bl, chunk, i, iascl, ibscl, ie, il, itau, itaup, itauq, iwork, & ldwork, maxmn, maxwrk, minmn, minwrk, mm, mnthr - integer(ilp) :: lwork_sgeqrf, lwork_sormqr, lwork_sgebrd, lwork_sormbr, lwork_sorgbr, & + integer(${ik}$) :: lwork_sgeqrf, lwork_sormqr, lwork_sgebrd, lwork_sormbr, lwork_sorgbr, & lwork_sormlq real(sp) :: anrm, bignum, bnrm, eps, sfmin, smlnum, thr ! Local Arrays - real(sp) :: dum(1) + real(sp) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ minmn = min( m, n ) maxmn = max( m, n ) - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( lda0 ) then + ! following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + if( minmn>0_${ik}$ ) then mm = m - mnthr = stdlib_ilaenv( 6, 'SGELSS', ' ', m, n, nrhs, -1 ) + mnthr = stdlib${ii}$_ilaenv( 6_${ik}$, 'SGELSS', ' ', m, n, nrhs, -1_${ik}$ ) if( m>=n .and. m>=mnthr ) then ! path 1a - overdetermined, with many more rows than ! columns - ! compute space needed for stdlib_sgeqrf - call stdlib_sgeqrf( m, n, a, lda, dum(1), dum(1), -1, info ) - lwork_sgeqrf=dum(1) - ! compute space needed for stdlib_sormqr - call stdlib_sormqr( 'L', 'T', m, nrhs, n, a, lda, dum(1), b,ldb, dum(1), -1, & + ! compute space needed for stdlib${ii}$_sgeqrf + call stdlib${ii}$_sgeqrf( m, n, a, lda, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, info ) + lwork_sgeqrf=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_sormqr + call stdlib${ii}$_sormqr( 'L', 'T', m, nrhs, n, a, lda, dum(1_${ik}$), b,ldb, dum(1_${ik}$), -1_${ik}$, & info ) - lwork_sormqr=dum(1) + lwork_sormqr=dum(1_${ik}$) mm = n maxwrk = max( maxwrk, n + lwork_sgeqrf ) maxwrk = max( maxwrk, n + lwork_sormqr ) end if if( m>=n ) then ! path 1 - overdetermined or exactly determined - ! compute workspace needed for stdlib_sbdsqr - bdspac = max( 1, 5*n ) - ! compute space needed for stdlib_sgebrd - call stdlib_sgebrd( mm, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, info & + ! compute workspace needed for stdlib${ii}$_sbdsqr + bdspac = max( 1_${ik}$, 5_${ik}$*n ) + ! compute space needed for stdlib${ii}$_sgebrd + call stdlib${ii}$_sgebrd( mm, n, a, lda, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, info & ) - lwork_sgebrd=dum(1) - ! compute space needed for stdlib_sormbr - call stdlib_sormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, dum(1),b, ldb, dum(1),& - -1, info ) - lwork_sormbr=dum(1) - ! compute space needed for stdlib_sorgbr - call stdlib_sorgbr( 'P', n, n, n, a, lda, dum(1),dum(1), -1, info ) - lwork_sorgbr=dum(1) + lwork_sgebrd=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_sormbr + call stdlib${ii}$_sormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, dum(1_${ik}$),b, ldb, dum(1_${ik}$),& + -1_${ik}$, info ) + lwork_sormbr=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_sorgbr + call stdlib${ii}$_sorgbr( 'P', n, n, n, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, info ) + lwork_sorgbr=dum(1_${ik}$) ! compute total workspace needed - maxwrk = max( maxwrk, 3*n + lwork_sgebrd ) - maxwrk = max( maxwrk, 3*n + lwork_sormbr ) - maxwrk = max( maxwrk, 3*n + lwork_sorgbr ) + maxwrk = max( maxwrk, 3_${ik}$*n + lwork_sgebrd ) + maxwrk = max( maxwrk, 3_${ik}$*n + lwork_sormbr ) + maxwrk = max( maxwrk, 3_${ik}$*n + lwork_sorgbr ) maxwrk = max( maxwrk, bdspac ) maxwrk = max( maxwrk, n*nrhs ) - minwrk = max( 3*n + mm, 3*n + nrhs, bdspac ) + minwrk = max( 3_${ik}$*n + mm, 3_${ik}$*n + nrhs, bdspac ) maxwrk = max( minwrk, maxwrk ) end if if( n>m ) then - ! compute workspace needed for stdlib_sbdsqr - bdspac = max( 1, 5*m ) - minwrk = max( 3*m+nrhs, 3*m+n, bdspac ) + ! compute workspace needed for stdlib${ii}$_sbdsqr + bdspac = max( 1_${ik}$, 5_${ik}$*m ) + minwrk = max( 3_${ik}$*m+nrhs, 3_${ik}$*m+n, bdspac ) if( n>=mnthr ) then ! path 2a - underdetermined, with many more columns ! than rows - ! compute space needed for stdlib_sgebrd - call stdlib_sgebrd( m, m, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, & + ! compute space needed for stdlib${ii}$_sgebrd + call stdlib${ii}$_sgebrd( m, m, a, lda, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, & info ) - lwork_sgebrd=dum(1) - ! compute space needed for stdlib_sormbr - call stdlib_sormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda,dum(1), b, ldb, dum(& - 1), -1, info ) - lwork_sormbr=dum(1) - ! compute space needed for stdlib_sorgbr - call stdlib_sorgbr( 'P', m, m, m, a, lda, dum(1),dum(1), -1, info ) - lwork_sorgbr=dum(1) - ! compute space needed for stdlib_sormlq - call stdlib_sormlq( 'L', 'T', n, nrhs, m, a, lda, dum(1),b, ldb, dum(1), -& - 1, info ) - lwork_sormlq=dum(1) + lwork_sgebrd=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_sormbr + call stdlib${ii}$_sormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda,dum(1_${ik}$), b, ldb, dum(& + 1_${ik}$), -1_${ik}$, info ) + lwork_sormbr=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_sorgbr + call stdlib${ii}$_sorgbr( 'P', m, m, m, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, info ) + lwork_sorgbr=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_sormlq + call stdlib${ii}$_sormlq( 'L', 'T', n, nrhs, m, a, lda, dum(1_${ik}$),b, ldb, dum(1_${ik}$), -& + 1_${ik}$, info ) + lwork_sormlq=dum(1_${ik}$) ! compute total workspace needed - maxwrk = m + m*stdlib_ilaenv( 1, 'SGELQF', ' ', m, n, -1,-1 ) - maxwrk = max( maxwrk, m*m + 4*m + lwork_sgebrd ) - maxwrk = max( maxwrk, m*m + 4*m + lwork_sormbr ) - maxwrk = max( maxwrk, m*m + 4*m + lwork_sorgbr ) + maxwrk = m + m*stdlib${ii}$_ilaenv( 1_${ik}$, 'SGELQF', ' ', m, n, -1_${ik}$,-1_${ik}$ ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + lwork_sgebrd ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + lwork_sormbr ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + lwork_sorgbr ) maxwrk = max( maxwrk, m*m + m + bdspac ) - if( nrhs>1 ) then + if( nrhs>1_${ik}$ ) then maxwrk = max( maxwrk, m*m + m + m*nrhs ) else - maxwrk = max( maxwrk, m*m + 2*m ) + maxwrk = max( maxwrk, m*m + 2_${ik}$*m ) end if maxwrk = max( maxwrk, m + lwork_sormlq ) else ! path 2 - underdetermined - ! compute space needed for stdlib_sgebrd - call stdlib_sgebrd( m, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, & + ! compute space needed for stdlib${ii}$_sgebrd + call stdlib${ii}$_sgebrd( m, n, a, lda, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, & info ) - lwork_sgebrd=dum(1) - ! compute space needed for stdlib_sormbr - call stdlib_sormbr( 'Q', 'L', 'T', m, nrhs, m, a, lda,dum(1), b, ldb, dum(& - 1), -1, info ) - lwork_sormbr=dum(1) - ! compute space needed for stdlib_sorgbr - call stdlib_sorgbr( 'P', m, n, m, a, lda, dum(1),dum(1), -1, info ) - lwork_sorgbr=dum(1) - maxwrk = 3*m + lwork_sgebrd - maxwrk = max( maxwrk, 3*m + lwork_sormbr ) - maxwrk = max( maxwrk, 3*m + lwork_sorgbr ) + lwork_sgebrd=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_sormbr + call stdlib${ii}$_sormbr( 'Q', 'L', 'T', m, nrhs, m, a, lda,dum(1_${ik}$), b, ldb, dum(& + 1_${ik}$), -1_${ik}$, info ) + lwork_sormbr=dum(1_${ik}$) + ! compute space needed for stdlib${ii}$_sorgbr + call stdlib${ii}$_sorgbr( 'P', m, n, m, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, info ) + lwork_sorgbr=dum(1_${ik}$) + maxwrk = 3_${ik}$*m + lwork_sgebrd + maxwrk = max( maxwrk, 3_${ik}$*m + lwork_sormbr ) + maxwrk = max( maxwrk, 3_${ik}$*m + lwork_sorgbr ) maxwrk = max( maxwrk, bdspac ) maxwrk = max( maxwrk, n*nrhs ) end if end if maxwrk = max( minwrk, maxwrk ) end if - work( 1 ) = maxwrk - if( lworkzero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_slascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_slaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) - call stdlib_slaset( 'F', minmn, 1, zero, zero, s, minmn ) - rank = 0 + call stdlib${ii}$_slaset( 'F', max( m, n ), nrhs, zero, zero, b, ldb ) + call stdlib${ii}$_slaset( 'F', minmn, 1_${ik}$, zero, zero, s, minmn ) + rank = 0_${ik}$ go to 70 end if ! scale b if max element outside range [smlnum,bignum] - bnrm = stdlib_slange( 'M', m, nrhs, b, ldb, work ) - ibscl = 0 + bnrm = stdlib${ii}$_slange( 'M', m, nrhs, b, ldb, work ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_slascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) - ibscl = 2 + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, m, nrhs, b, ldb, info ) + ibscl = 2_${ik}$ end if ! overdetermined case if( m>=n ) then @@ -72341,229 +72343,229 @@ module stdlib_linalg_lapack_s if( m>=mnthr ) then ! path 1a - overdetermined, with many more rows than columns mm = n - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r ! (workspace: need 2*n, prefer n+n*nb) - call stdlib_sgeqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & + call stdlib${ii}$_sgeqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & info ) ! multiply b by transpose(q) ! (workspace: need n+nrhs, prefer n+nrhs*nb) - call stdlib_sormqr( 'L', 'T', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & + call stdlib${ii}$_sormqr( 'L', 'T', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & iwork ), lwork-iwork+1, info ) ! zero out below r - if( n>1 )call stdlib_slaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) + if( n>1_${ik}$ )call stdlib${ii}$_slaset( 'L', n-1, n-1, zero, zero, a( 2_${ik}$, 1_${ik}$ ), lda ) end if - ie = 1 + ie = 1_${ik}$ itauq = ie + n itaup = itauq + n iwork = itaup + n ! bidiagonalize r in a ! (workspace: need 3*n+mm, prefer 3*n+(mm+n)*nb) - call stdlib_sgebrd( mm, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work(& + call stdlib${ii}$_sgebrd( mm, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work(& iwork ), lwork-iwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors of r ! (workspace: need 3*n+nrhs, prefer 3*n+nrhs*nb) - call stdlib_sormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib${ii}$_sormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & iwork ), lwork-iwork+1, info ) ! generate right bidiagonalizing vectors of r in a ! (workspace: need 4*n-1, prefer 3*n+(n-1)*nb) - call stdlib_sorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-iwork+& - 1, info ) + call stdlib${ii}$_sorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-iwork+& + 1_${ik}$, info ) iwork = ie + n ! perform bidiagonal qr iteration ! multiply b by transpose of left singular vectors ! compute right singular vectors in a ! (workspace: need bdspac) - call stdlib_sbdsqr( 'U', n, n, 0, nrhs, s, work( ie ), a, lda, dum,1, b, ldb, work( & + call stdlib${ii}$_sbdsqr( 'U', n, n, 0_${ik}$, nrhs, s, work( ie ), a, lda, dum,1_${ik}$, b, ldb, work( & iwork ), info ) if( info/=0 )go to 70 ! multiply b by reciprocals of singular values - thr = max( rcond*s( 1 ), sfmin ) - if( rcondthr ) then - call stdlib_srscl( nrhs, s( i ), b( i, 1 ), ldb ) - rank = rank + 1 + call stdlib${ii}$_srscl( nrhs, s( i ), b( i, 1_${ik}$ ), ldb ) + rank = rank + 1_${ik}$ else - call stdlib_slaset( 'F', 1, nrhs, zero, zero, b( i, 1 ), ldb ) + call stdlib${ii}$_slaset( 'F', 1_${ik}$, nrhs, zero, zero, b( i, 1_${ik}$ ), ldb ) end if end do ! multiply b by right singular vectors ! (workspace: need n, prefer n*nrhs) - if( lwork>=ldb*nrhs .and. nrhs>1 ) then - call stdlib_sgemm( 'T', 'N', n, nrhs, n, one, a, lda, b, ldb, zero,work, ldb ) + if( lwork>=ldb*nrhs .and. nrhs>1_${ik}$ ) then + call stdlib${ii}$_sgemm( 'T', 'N', n, nrhs, n, one, a, lda, b, ldb, zero,work, ldb ) - call stdlib_slacpy( 'G', n, nrhs, work, ldb, b, ldb ) - else if( nrhs>1 ) then + call stdlib${ii}$_slacpy( 'G', n, nrhs, work, ldb, b, ldb ) + else if( nrhs>1_${ik}$ ) then chunk = lwork / n do i = 1, nrhs, chunk bl = min( nrhs-i+1, chunk ) - call stdlib_sgemm( 'T', 'N', n, bl, n, one, a, lda, b( 1, i ),ldb, zero, work,& + call stdlib${ii}$_sgemm( 'T', 'N', n, bl, n, one, a, lda, b( 1_${ik}$, i ),ldb, zero, work,& n ) - call stdlib_slacpy( 'G', n, bl, work, n, b( 1, i ), ldb ) + call stdlib${ii}$_slacpy( 'G', n, bl, work, n, b( 1_${ik}$, i ), ldb ) end do else - call stdlib_sgemv( 'T', n, n, one, a, lda, b, 1, zero, work, 1 ) - call stdlib_scopy( n, work, 1, b, 1 ) + call stdlib${ii}$_sgemv( 'T', n, n, one, a, lda, b, 1_${ik}$, zero, work, 1_${ik}$ ) + call stdlib${ii}$_scopy( n, work, 1_${ik}$, b, 1_${ik}$ ) end if - else if( n>=mnthr .and. lwork>=4*m+m*m+max( m, 2*m-4, nrhs, n-3*m ) ) then + else if( n>=mnthr .and. lwork>=4_${ik}$*m+m*m+max( m, 2_${ik}$*m-4, nrhs, n-3*m ) ) then ! path 2a - underdetermined, with many more columns than rows ! and sufficient workspace for an efficient algorithm ldwork = m - if( lwork>=max( 4*m+m*lda+max( m, 2*m-4, nrhs, n-3*m ),m*lda+m+m*nrhs ) )ldwork = & + if( lwork>=max( 4_${ik}$*m+m*lda+max( m, 2_${ik}$*m-4, nrhs, n-3*m ),m*lda+m+m*nrhs ) )ldwork = & lda - itau = 1 - iwork = m + 1 + itau = 1_${ik}$ + iwork = m + 1_${ik}$ ! compute a=l*q ! (workspace: need 2*m, prefer m+m*nb) - call stdlib_sgelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, info ) + call stdlib${ii}$_sgelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, info ) il = iwork ! copy l to work(il), zeroing out above it - call stdlib_slacpy( 'L', m, m, a, lda, work( il ), ldwork ) - call stdlib_slaset( 'U', m-1, m-1, zero, zero, work( il+ldwork ),ldwork ) + call stdlib${ii}$_slacpy( 'L', m, m, a, lda, work( il ), ldwork ) + call stdlib${ii}$_slaset( 'U', m-1, m-1, zero, zero, work( il+ldwork ),ldwork ) ie = il + ldwork*m itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize l in work(il) ! (workspace: need m*m+5*m, prefer m*m+4*m+2*m*nb) - call stdlib_sgebrd( m, m, work( il ), ldwork, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_sgebrd( m, m, work( il ), ldwork, s, work( ie ),work( itauq ), work( & itaup ), work( iwork ),lwork-iwork+1, info ) ! multiply b by transpose of left bidiagonalizing vectors of l ! (workspace: need m*m+4*m+nrhs, prefer m*m+4*m+nrhs*nb) - call stdlib_sormbr( 'Q', 'L', 'T', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & + call stdlib${ii}$_sormbr( 'Q', 'L', 'T', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & ldb, work( iwork ),lwork-iwork+1, info ) ! generate right bidiagonalizing vectors of r in work(il) ! (workspace: need m*m+5*m-1, prefer m*m+4*m+(m-1)*nb) - call stdlib_sorgbr( 'P', m, m, m, work( il ), ldwork, work( itaup ),work( iwork ), & + call stdlib${ii}$_sorgbr( 'P', m, m, m, work( il ), ldwork, work( itaup ),work( iwork ), & lwork-iwork+1, info ) iwork = ie + m ! perform bidiagonal qr iteration, ! computing right singular vectors of l in work(il) and ! multiplying b by transpose of left singular vectors ! (workspace: need m*m+m+bdspac) - call stdlib_sbdsqr( 'U', m, m, 0, nrhs, s, work( ie ), work( il ),ldwork, a, lda, b,& + call stdlib${ii}$_sbdsqr( 'U', m, m, 0_${ik}$, nrhs, s, work( ie ), work( il ),ldwork, a, lda, b,& ldb, work( iwork ), info ) if( info/=0 )go to 70 ! multiply b by reciprocals of singular values - thr = max( rcond*s( 1 ), sfmin ) - if( rcondthr ) then - call stdlib_srscl( nrhs, s( i ), b( i, 1 ), ldb ) - rank = rank + 1 + call stdlib${ii}$_srscl( nrhs, s( i ), b( i, 1_${ik}$ ), ldb ) + rank = rank + 1_${ik}$ else - call stdlib_slaset( 'F', 1, nrhs, zero, zero, b( i, 1 ), ldb ) + call stdlib${ii}$_slaset( 'F', 1_${ik}$, nrhs, zero, zero, b( i, 1_${ik}$ ), ldb ) end if end do iwork = ie ! multiply b by right singular vectors of l in work(il) ! (workspace: need m*m+2*m, prefer m*m+m+m*nrhs) - if( lwork>=ldb*nrhs+iwork-1 .and. nrhs>1 ) then - call stdlib_sgemm( 'T', 'N', m, nrhs, m, one, work( il ), ldwork,b, ldb, zero, & + if( lwork>=ldb*nrhs+iwork-1 .and. nrhs>1_${ik}$ ) then + call stdlib${ii}$_sgemm( 'T', 'N', m, nrhs, m, one, work( il ), ldwork,b, ldb, zero, & work( iwork ), ldb ) - call stdlib_slacpy( 'G', m, nrhs, work( iwork ), ldb, b, ldb ) - else if( nrhs>1 ) then + call stdlib${ii}$_slacpy( 'G', m, nrhs, work( iwork ), ldb, b, ldb ) + else if( nrhs>1_${ik}$ ) then chunk = ( lwork-iwork+1 ) / m do i = 1, nrhs, chunk bl = min( nrhs-i+1, chunk ) - call stdlib_sgemm( 'T', 'N', m, bl, m, one, work( il ), ldwork,b( 1, i ), ldb,& + call stdlib${ii}$_sgemm( 'T', 'N', m, bl, m, one, work( il ), ldwork,b( 1_${ik}$, i ), ldb,& zero, work( iwork ), m ) - call stdlib_slacpy( 'G', m, bl, work( iwork ), m, b( 1, i ),ldb ) + call stdlib${ii}$_slacpy( 'G', m, bl, work( iwork ), m, b( 1_${ik}$, i ),ldb ) end do else - call stdlib_sgemv( 'T', m, m, one, work( il ), ldwork, b( 1, 1 ),1, zero, work( & - iwork ), 1 ) - call stdlib_scopy( m, work( iwork ), 1, b( 1, 1 ), 1 ) + call stdlib${ii}$_sgemv( 'T', m, m, one, work( il ), ldwork, b( 1_${ik}$, 1_${ik}$ ),1_${ik}$, zero, work( & + iwork ), 1_${ik}$ ) + call stdlib${ii}$_scopy( m, work( iwork ), 1_${ik}$, b( 1_${ik}$, 1_${ik}$ ), 1_${ik}$ ) end if ! zero out below first m rows of b - call stdlib_slaset( 'F', n-m, nrhs, zero, zero, b( m+1, 1 ), ldb ) + call stdlib${ii}$_slaset( 'F', n-m, nrhs, zero, zero, b( m+1, 1_${ik}$ ), ldb ) iwork = itau + m ! multiply transpose(q) by b ! (workspace: need m+nrhs, prefer m+nrhs*nb) - call stdlib_sormlq( 'L', 'T', n, nrhs, m, a, lda, work( itau ), b,ldb, work( iwork )& + call stdlib${ii}$_sormlq( 'L', 'T', n, nrhs, m, a, lda, work( itau ), b,ldb, work( iwork )& , lwork-iwork+1, info ) else ! path 2 - remaining underdetermined cases - ie = 1 + ie = 1_${ik}$ itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize a ! (workspace: need 3*m+n, prefer 3*m+(m+n)*nb) - call stdlib_sgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work( & + call stdlib${ii}$_sgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), work( & iwork ), lwork-iwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors ! (workspace: need 3*m+nrhs, prefer 3*m+nrhs*nb) - call stdlib_sormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib${ii}$_sormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & iwork ), lwork-iwork+1, info ) ! generate right bidiagonalizing vectors in a ! (workspace: need 4*m, prefer 3*m+m*nb) - call stdlib_sorgbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-iwork+& - 1, info ) + call stdlib${ii}$_sorgbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-iwork+& + 1_${ik}$, info ) iwork = ie + m ! perform bidiagonal qr iteration, ! computing right singular vectors of a in a and ! multiplying b by transpose of left singular vectors ! (workspace: need bdspac) - call stdlib_sbdsqr( 'L', m, n, 0, nrhs, s, work( ie ), a, lda, dum,1, b, ldb, work( & + call stdlib${ii}$_sbdsqr( 'L', m, n, 0_${ik}$, nrhs, s, work( ie ), a, lda, dum,1_${ik}$, b, ldb, work( & iwork ), info ) if( info/=0 )go to 70 ! multiply b by reciprocals of singular values - thr = max( rcond*s( 1 ), sfmin ) - if( rcondthr ) then - call stdlib_srscl( nrhs, s( i ), b( i, 1 ), ldb ) - rank = rank + 1 + call stdlib${ii}$_srscl( nrhs, s( i ), b( i, 1_${ik}$ ), ldb ) + rank = rank + 1_${ik}$ else - call stdlib_slaset( 'F', 1, nrhs, zero, zero, b( i, 1 ), ldb ) + call stdlib${ii}$_slaset( 'F', 1_${ik}$, nrhs, zero, zero, b( i, 1_${ik}$ ), ldb ) end if end do ! multiply b by right singular vectors of a ! (workspace: need n, prefer n*nrhs) - if( lwork>=ldb*nrhs .and. nrhs>1 ) then - call stdlib_sgemm( 'T', 'N', n, nrhs, m, one, a, lda, b, ldb, zero,work, ldb ) + if( lwork>=ldb*nrhs .and. nrhs>1_${ik}$ ) then + call stdlib${ii}$_sgemm( 'T', 'N', n, nrhs, m, one, a, lda, b, ldb, zero,work, ldb ) - call stdlib_slacpy( 'F', n, nrhs, work, ldb, b, ldb ) - else if( nrhs>1 ) then + call stdlib${ii}$_slacpy( 'F', n, nrhs, work, ldb, b, ldb ) + else if( nrhs>1_${ik}$ ) then chunk = lwork / n do i = 1, nrhs, chunk bl = min( nrhs-i+1, chunk ) - call stdlib_sgemm( 'T', 'N', n, bl, m, one, a, lda, b( 1, i ),ldb, zero, work,& + call stdlib${ii}$_sgemm( 'T', 'N', n, bl, m, one, a, lda, b( 1_${ik}$, i ),ldb, zero, work,& n ) - call stdlib_slacpy( 'F', n, bl, work, n, b( 1, i ), ldb ) + call stdlib${ii}$_slacpy( 'F', n, bl, work, n, b( 1_${ik}$, i ), ldb ) end do else - call stdlib_sgemv( 'T', m, n, one, a, lda, b, 1, zero, work, 1 ) - call stdlib_scopy( n, work, 1, b, 1 ) + call stdlib${ii}$_sgemv( 'T', m, n, one, a, lda, b, 1_${ik}$, zero, work, 1_${ik}$ ) + call stdlib${ii}$_scopy( n, work, 1_${ik}$, b, 1_${ik}$ ) end if end if ! undo scaling - if( iascl==1 ) then - call stdlib_slascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info ) - call stdlib_slascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn,info ) - else if( iascl==2 ) then - call stdlib_slascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info ) - call stdlib_slascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,info ) - end if - if( ibscl==1 ) then - call stdlib_slascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info ) - else if( ibscl==2 ) then - call stdlib_slascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info ) + if( iascl==1_${ik}$ ) then + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, smlnum, n, nrhs, b, ldb, info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, anrm, minmn, 1_${ik}$, s, minmn,info ) + else if( iascl==2_${ik}$ ) then + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, n, nrhs, b, ldb, info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn, 1_${ik}$, s, minmn,info ) + end if + if( ibscl==1_${ik}$ ) then + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, bnrm, n, nrhs, b, ldb, info ) + else if( ibscl==2_${ik}$ ) then + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bignum, bnrm, n, nrhs, b, ldb, info ) end if 70 continue - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_sgelss + end subroutine stdlib${ii}$_sgelss - subroutine stdlib_sgesdd( jobz, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, iwork, info ) + subroutine stdlib${ii}$_sgesdd( jobz, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, iwork, info ) !! SGESDD computes the singular value decomposition (SVD) of a real !! M-by-N matrix A, optionally computing the left and right singular !! vectors. If singular vectors are desired, it uses a @@ -72589,303 +72591,303 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldu, ldvt, lwork, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldu, ldvt, lwork, m, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: s(*), u(ldu,*), vt(ldvt,*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, wntqa, wntqas, wntqn, wntqo, wntqs - integer(ilp) :: bdspac, blk, chunk, i, ie, ierr, il, ir, iscl, itau, itaup, itauq, iu, & + integer(${ik}$) :: bdspac, blk, chunk, i, ie, ierr, il, ir, iscl, itau, itaup, itauq, iu, & ivt, ldwkvt, ldwrkl, ldwrkr, ldwrku, maxwrk, minmn, minwrk, mnthr, nwork, wrkbl - integer(ilp) :: lwork_sgebrd_mn, lwork_sgebrd_mm, lwork_sgebrd_nn, lwork_sgelqf_mn, & + integer(${ik}$) :: lwork_sgebrd_mn, lwork_sgebrd_mm, lwork_sgebrd_nn, lwork_sgelqf_mn, & lwork_sgeqrf_mn, lwork_sorgbr_p_mm, lwork_sorgbr_q_nn, lwork_sorglq_mn, & lwork_sorglq_nn, lwork_sorgqr_mm, lwork_sorgqr_mn, lwork_sormbr_prt_mm, & lwork_sormbr_qln_mm, lwork_sormbr_prt_mn, lwork_sormbr_qln_mn, lwork_sormbr_prt_nn, & lwork_sormbr_qln_nn real(sp) :: anrm, bignum, eps, smlnum ! Local Arrays - integer(ilp) :: idum(1) - real(sp) :: dum(1) + integer(${ik}$) :: idum(1_${ik}$) + real(sp) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: int,max,min,sqrt ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ minmn = min( m, n ) wntqa = stdlib_lsame( jobz, 'A' ) wntqs = stdlib_lsame( jobz, 'S' ) wntqas = wntqa .or. wntqs wntqo = stdlib_lsame( jobz, 'O' ) wntqn = stdlib_lsame( jobz, 'N' ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) if( .not.( wntqa .or. wntqs .or. wntqo .or. wntqn ) ) then - info = -1 - else if( m<0 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( lda=n .and. ldvt=n .and. minmn>0 ) then - ! compute space needed for stdlib_sbdsdc + ! following subroutine, as returned by stdlib${ii}$_ilaenv. + if( info==0_${ik}$ ) then + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + bdspac = 0_${ik}$ + mnthr = int( minmn*11.0_sp / 6.0_sp,KIND=${ik}$) + if( m>=n .and. minmn>0_${ik}$ ) then + ! compute space needed for stdlib${ii}$_sbdsdc if( wntqn ) then - ! stdlib_sbdsdc needs only 4*n (or 6*n for uplo=l for lapack <= 3.6_sp) + ! stdlib${ii}$_sbdsdc needs only 4*n (or 6*n for uplo=l for lapack <= 3.6_sp) ! keep 7*n for backwards compatibility. - bdspac = 7*n + bdspac = 7_${ik}$*n else - bdspac = 3*n*n + 4*n + bdspac = 3_${ik}$*n*n + 4_${ik}$*n end if ! compute space preferred for each routine - call stdlib_sgebrd( m, n, dum(1), m, dum(1), dum(1), dum(1),dum(1), dum(1), -1, & + call stdlib${ii}$_sgebrd( m, n, dum(1_${ik}$), m, dum(1_${ik}$), dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, & ierr ) - lwork_sgebrd_mn = int( dum(1),KIND=ilp) - call stdlib_sgebrd( n, n, dum(1), n, dum(1), dum(1), dum(1),dum(1), dum(1), -1, & + lwork_sgebrd_mn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_sgebrd( n, n, dum(1_${ik}$), n, dum(1_${ik}$), dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, & ierr ) - lwork_sgebrd_nn = int( dum(1),KIND=ilp) - call stdlib_sgeqrf( m, n, dum(1), m, dum(1), dum(1), -1, ierr ) - lwork_sgeqrf_mn = int( dum(1),KIND=ilp) - call stdlib_sorgbr( 'Q', n, n, n, dum(1), n, dum(1), dum(1), -1,ierr ) - lwork_sorgbr_q_nn = int( dum(1),KIND=ilp) - call stdlib_sorgqr( m, m, n, dum(1), m, dum(1), dum(1), -1, ierr ) - lwork_sorgqr_mm = int( dum(1),KIND=ilp) - call stdlib_sorgqr( m, n, n, dum(1), m, dum(1), dum(1), -1, ierr ) - lwork_sorgqr_mn = int( dum(1),KIND=ilp) - call stdlib_sormbr( 'P', 'R', 'T', n, n, n, dum(1), n,dum(1), dum(1), n, dum(1), & - -1, ierr ) - lwork_sormbr_prt_nn = int( dum(1),KIND=ilp) - call stdlib_sormbr( 'Q', 'L', 'N', n, n, n, dum(1), n,dum(1), dum(1), n, dum(1), & - -1, ierr ) - lwork_sormbr_qln_nn = int( dum(1),KIND=ilp) - call stdlib_sormbr( 'Q', 'L', 'N', m, n, n, dum(1), m,dum(1), dum(1), m, dum(1), & - -1, ierr ) - lwork_sormbr_qln_mn = int( dum(1),KIND=ilp) - call stdlib_sormbr( 'Q', 'L', 'N', m, m, n, dum(1), m,dum(1), dum(1), m, dum(1), & - -1, ierr ) - lwork_sormbr_qln_mm = int( dum(1),KIND=ilp) + lwork_sgebrd_nn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_sgeqrf( m, n, dum(1_${ik}$), m, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_sgeqrf_mn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_sorgbr( 'Q', n, n, n, dum(1_${ik}$), n, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$,ierr ) + lwork_sorgbr_q_nn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_sorgqr( m, m, n, dum(1_${ik}$), m, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_sorgqr_mm = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_sorgqr( m, n, n, dum(1_${ik}$), m, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_sorgqr_mn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_sormbr( 'P', 'R', 'T', n, n, n, dum(1_${ik}$), n,dum(1_${ik}$), dum(1_${ik}$), n, dum(1_${ik}$), & + -1_${ik}$, ierr ) + lwork_sormbr_prt_nn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_sormbr( 'Q', 'L', 'N', n, n, n, dum(1_${ik}$), n,dum(1_${ik}$), dum(1_${ik}$), n, dum(1_${ik}$), & + -1_${ik}$, ierr ) + lwork_sormbr_qln_nn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_sormbr( 'Q', 'L', 'N', m, n, n, dum(1_${ik}$), m,dum(1_${ik}$), dum(1_${ik}$), m, dum(1_${ik}$), & + -1_${ik}$, ierr ) + lwork_sormbr_qln_mn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_sormbr( 'Q', 'L', 'N', m, m, n, dum(1_${ik}$), m,dum(1_${ik}$), dum(1_${ik}$), m, dum(1_${ik}$), & + -1_${ik}$, ierr ) + lwork_sormbr_qln_mm = int( dum(1_${ik}$),KIND=${ik}$) if( m>=mnthr ) then if( wntqn ) then ! path 1 (m >> n, jobz='n') wrkbl = n + lwork_sgeqrf_mn - wrkbl = max( wrkbl, 3*n + lwork_sgebrd_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_sgebrd_nn ) maxwrk = max( wrkbl, bdspac + n ) minwrk = bdspac + n else if( wntqo ) then ! path 2 (m >> n, jobz='o') wrkbl = n + lwork_sgeqrf_mn wrkbl = max( wrkbl, n + lwork_sorgqr_mn ) - wrkbl = max( wrkbl, 3*n + lwork_sgebrd_nn ) - wrkbl = max( wrkbl, 3*n + lwork_sormbr_qln_nn ) - wrkbl = max( wrkbl, 3*n + lwork_sormbr_prt_nn ) - wrkbl = max( wrkbl, 3*n + bdspac ) - maxwrk = wrkbl + 2*n*n - minwrk = bdspac + 2*n*n + 3*n + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_sgebrd_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_sormbr_qln_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_sormbr_prt_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + bdspac ) + maxwrk = wrkbl + 2_${ik}$*n*n + minwrk = bdspac + 2_${ik}$*n*n + 3_${ik}$*n else if( wntqs ) then ! path 3 (m >> n, jobz='s') wrkbl = n + lwork_sgeqrf_mn wrkbl = max( wrkbl, n + lwork_sorgqr_mn ) - wrkbl = max( wrkbl, 3*n + lwork_sgebrd_nn ) - wrkbl = max( wrkbl, 3*n + lwork_sormbr_qln_nn ) - wrkbl = max( wrkbl, 3*n + lwork_sormbr_prt_nn ) - wrkbl = max( wrkbl, 3*n + bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_sgebrd_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_sormbr_qln_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_sormbr_prt_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + bdspac ) maxwrk = wrkbl + n*n - minwrk = bdspac + n*n + 3*n + minwrk = bdspac + n*n + 3_${ik}$*n else if( wntqa ) then ! path 4 (m >> n, jobz='a') wrkbl = n + lwork_sgeqrf_mn wrkbl = max( wrkbl, n + lwork_sorgqr_mm ) - wrkbl = max( wrkbl, 3*n + lwork_sgebrd_nn ) - wrkbl = max( wrkbl, 3*n + lwork_sormbr_qln_nn ) - wrkbl = max( wrkbl, 3*n + lwork_sormbr_prt_nn ) - wrkbl = max( wrkbl, 3*n + bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_sgebrd_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_sormbr_qln_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_sormbr_prt_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + bdspac ) maxwrk = wrkbl + n*n - minwrk = n*n + max( 3*n + bdspac, n + m ) + minwrk = n*n + max( 3_${ik}$*n + bdspac, n + m ) end if else ! path 5 (m >= n, but not much larger) - wrkbl = 3*n + lwork_sgebrd_mn + wrkbl = 3_${ik}$*n + lwork_sgebrd_mn if( wntqn ) then ! path 5n (m >= n, jobz='n') - maxwrk = max( wrkbl, 3*n + bdspac ) - minwrk = 3*n + max( m, bdspac ) + maxwrk = max( wrkbl, 3_${ik}$*n + bdspac ) + minwrk = 3_${ik}$*n + max( m, bdspac ) else if( wntqo ) then ! path 5o (m >= n, jobz='o') - wrkbl = max( wrkbl, 3*n + lwork_sormbr_prt_nn ) - wrkbl = max( wrkbl, 3*n + lwork_sormbr_qln_mn ) - wrkbl = max( wrkbl, 3*n + bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_sormbr_prt_nn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_sormbr_qln_mn ) + wrkbl = max( wrkbl, 3_${ik}$*n + bdspac ) maxwrk = wrkbl + m*n - minwrk = 3*n + max( m, n*n + bdspac ) + minwrk = 3_${ik}$*n + max( m, n*n + bdspac ) else if( wntqs ) then ! path 5s (m >= n, jobz='s') - wrkbl = max( wrkbl, 3*n + lwork_sormbr_qln_mn ) - wrkbl = max( wrkbl, 3*n + lwork_sormbr_prt_nn ) - maxwrk = max( wrkbl, 3*n + bdspac ) - minwrk = 3*n + max( m, bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_sormbr_qln_mn ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_sormbr_prt_nn ) + maxwrk = max( wrkbl, 3_${ik}$*n + bdspac ) + minwrk = 3_${ik}$*n + max( m, bdspac ) else if( wntqa ) then ! path 5a (m >= n, jobz='a') - wrkbl = max( wrkbl, 3*n + lwork_sormbr_qln_mm ) - wrkbl = max( wrkbl, 3*n + lwork_sormbr_prt_nn ) - maxwrk = max( wrkbl, 3*n + bdspac ) - minwrk = 3*n + max( m, bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_sormbr_qln_mm ) + wrkbl = max( wrkbl, 3_${ik}$*n + lwork_sormbr_prt_nn ) + maxwrk = max( wrkbl, 3_${ik}$*n + bdspac ) + minwrk = 3_${ik}$*n + max( m, bdspac ) end if end if - else if( minmn>0 ) then - ! compute space needed for stdlib_sbdsdc + else if( minmn>0_${ik}$ ) then + ! compute space needed for stdlib${ii}$_sbdsdc if( wntqn ) then - ! stdlib_sbdsdc needs only 4*n (or 6*n for uplo=l for lapack <= 3.6_sp) + ! stdlib${ii}$_sbdsdc needs only 4*n (or 6*n for uplo=l for lapack <= 3.6_sp) ! keep 7*n for backwards compatibility. - bdspac = 7*m + bdspac = 7_${ik}$*m else - bdspac = 3*m*m + 4*m + bdspac = 3_${ik}$*m*m + 4_${ik}$*m end if ! compute space preferred for each routine - call stdlib_sgebrd( m, n, dum(1), m, dum(1), dum(1), dum(1),dum(1), dum(1), -1, & + call stdlib${ii}$_sgebrd( m, n, dum(1_${ik}$), m, dum(1_${ik}$), dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, & ierr ) - lwork_sgebrd_mn = int( dum(1),KIND=ilp) - call stdlib_sgebrd( m, m, a, m, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) + lwork_sgebrd_mn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_sgebrd( m, m, a, m, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) - lwork_sgebrd_mm = int( dum(1),KIND=ilp) - call stdlib_sgelqf( m, n, a, m, dum(1), dum(1), -1, ierr ) - lwork_sgelqf_mn = int( dum(1),KIND=ilp) - call stdlib_sorglq( n, n, m, dum(1), n, dum(1), dum(1), -1, ierr ) - lwork_sorglq_nn = int( dum(1),KIND=ilp) - call stdlib_sorglq( m, n, m, a, m, dum(1), dum(1), -1, ierr ) - lwork_sorglq_mn = int( dum(1),KIND=ilp) - call stdlib_sorgbr( 'P', m, m, m, a, n, dum(1), dum(1), -1, ierr ) - lwork_sorgbr_p_mm = int( dum(1),KIND=ilp) - call stdlib_sormbr( 'P', 'R', 'T', m, m, m, dum(1), m,dum(1), dum(1), m, dum(1), & - -1, ierr ) - lwork_sormbr_prt_mm = int( dum(1),KIND=ilp) - call stdlib_sormbr( 'P', 'R', 'T', m, n, m, dum(1), m,dum(1), dum(1), m, dum(1), & - -1, ierr ) - lwork_sormbr_prt_mn = int( dum(1),KIND=ilp) - call stdlib_sormbr( 'P', 'R', 'T', n, n, m, dum(1), n,dum(1), dum(1), n, dum(1), & - -1, ierr ) - lwork_sormbr_prt_nn = int( dum(1),KIND=ilp) - call stdlib_sormbr( 'Q', 'L', 'N', m, m, m, dum(1), m,dum(1), dum(1), m, dum(1), & - -1, ierr ) - lwork_sormbr_qln_mm = int( dum(1),KIND=ilp) + lwork_sgebrd_mm = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_sgelqf( m, n, a, m, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_sgelqf_mn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_sorglq( n, n, m, dum(1_${ik}$), n, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_sorglq_nn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_sorglq( m, n, m, a, m, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_sorglq_mn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_sorgbr( 'P', m, m, m, a, n, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_sorgbr_p_mm = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_sormbr( 'P', 'R', 'T', m, m, m, dum(1_${ik}$), m,dum(1_${ik}$), dum(1_${ik}$), m, dum(1_${ik}$), & + -1_${ik}$, ierr ) + lwork_sormbr_prt_mm = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_sormbr( 'P', 'R', 'T', m, n, m, dum(1_${ik}$), m,dum(1_${ik}$), dum(1_${ik}$), m, dum(1_${ik}$), & + -1_${ik}$, ierr ) + lwork_sormbr_prt_mn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_sormbr( 'P', 'R', 'T', n, n, m, dum(1_${ik}$), n,dum(1_${ik}$), dum(1_${ik}$), n, dum(1_${ik}$), & + -1_${ik}$, ierr ) + lwork_sormbr_prt_nn = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_sormbr( 'Q', 'L', 'N', m, m, m, dum(1_${ik}$), m,dum(1_${ik}$), dum(1_${ik}$), m, dum(1_${ik}$), & + -1_${ik}$, ierr ) + lwork_sormbr_qln_mm = int( dum(1_${ik}$),KIND=${ik}$) if( n>=mnthr ) then if( wntqn ) then ! path 1t (n >> m, jobz='n') wrkbl = m + lwork_sgelqf_mn - wrkbl = max( wrkbl, 3*m + lwork_sgebrd_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_sgebrd_mm ) maxwrk = max( wrkbl, bdspac + m ) minwrk = bdspac + m else if( wntqo ) then ! path 2t (n >> m, jobz='o') wrkbl = m + lwork_sgelqf_mn wrkbl = max( wrkbl, m + lwork_sorglq_mn ) - wrkbl = max( wrkbl, 3*m + lwork_sgebrd_mm ) - wrkbl = max( wrkbl, 3*m + lwork_sormbr_qln_mm ) - wrkbl = max( wrkbl, 3*m + lwork_sormbr_prt_mm ) - wrkbl = max( wrkbl, 3*m + bdspac ) - maxwrk = wrkbl + 2*m*m - minwrk = bdspac + 2*m*m + 3*m + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_sgebrd_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_sormbr_qln_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_sormbr_prt_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + bdspac ) + maxwrk = wrkbl + 2_${ik}$*m*m + minwrk = bdspac + 2_${ik}$*m*m + 3_${ik}$*m else if( wntqs ) then ! path 3t (n >> m, jobz='s') wrkbl = m + lwork_sgelqf_mn wrkbl = max( wrkbl, m + lwork_sorglq_mn ) - wrkbl = max( wrkbl, 3*m + lwork_sgebrd_mm ) - wrkbl = max( wrkbl, 3*m + lwork_sormbr_qln_mm ) - wrkbl = max( wrkbl, 3*m + lwork_sormbr_prt_mm ) - wrkbl = max( wrkbl, 3*m + bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_sgebrd_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_sormbr_qln_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_sormbr_prt_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + bdspac ) maxwrk = wrkbl + m*m - minwrk = bdspac + m*m + 3*m + minwrk = bdspac + m*m + 3_${ik}$*m else if( wntqa ) then ! path 4t (n >> m, jobz='a') wrkbl = m + lwork_sgelqf_mn wrkbl = max( wrkbl, m + lwork_sorglq_nn ) - wrkbl = max( wrkbl, 3*m + lwork_sgebrd_mm ) - wrkbl = max( wrkbl, 3*m + lwork_sormbr_qln_mm ) - wrkbl = max( wrkbl, 3*m + lwork_sormbr_prt_mm ) - wrkbl = max( wrkbl, 3*m + bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_sgebrd_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_sormbr_qln_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_sormbr_prt_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + bdspac ) maxwrk = wrkbl + m*m - minwrk = m*m + max( 3*m + bdspac, m + n ) + minwrk = m*m + max( 3_${ik}$*m + bdspac, m + n ) end if else ! path 5t (n > m, but not much larger) - wrkbl = 3*m + lwork_sgebrd_mn + wrkbl = 3_${ik}$*m + lwork_sgebrd_mn if( wntqn ) then ! path 5tn (n > m, jobz='n') - maxwrk = max( wrkbl, 3*m + bdspac ) - minwrk = 3*m + max( n, bdspac ) + maxwrk = max( wrkbl, 3_${ik}$*m + bdspac ) + minwrk = 3_${ik}$*m + max( n, bdspac ) else if( wntqo ) then ! path 5to (n > m, jobz='o') - wrkbl = max( wrkbl, 3*m + lwork_sormbr_qln_mm ) - wrkbl = max( wrkbl, 3*m + lwork_sormbr_prt_mn ) - wrkbl = max( wrkbl, 3*m + bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_sormbr_qln_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_sormbr_prt_mn ) + wrkbl = max( wrkbl, 3_${ik}$*m + bdspac ) maxwrk = wrkbl + m*n - minwrk = 3*m + max( n, m*m + bdspac ) + minwrk = 3_${ik}$*m + max( n, m*m + bdspac ) else if( wntqs ) then ! path 5ts (n > m, jobz='s') - wrkbl = max( wrkbl, 3*m + lwork_sormbr_qln_mm ) - wrkbl = max( wrkbl, 3*m + lwork_sormbr_prt_mn ) - maxwrk = max( wrkbl, 3*m + bdspac ) - minwrk = 3*m + max( n, bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_sormbr_qln_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_sormbr_prt_mn ) + maxwrk = max( wrkbl, 3_${ik}$*m + bdspac ) + minwrk = 3_${ik}$*m + max( n, bdspac ) else if( wntqa ) then ! path 5ta (n > m, jobz='a') - wrkbl = max( wrkbl, 3*m + lwork_sormbr_qln_mm ) - wrkbl = max( wrkbl, 3*m + lwork_sormbr_prt_nn ) - maxwrk = max( wrkbl, 3*m + bdspac ) - minwrk = 3*m + max( n, bdspac ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_sormbr_qln_mm ) + wrkbl = max( wrkbl, 3_${ik}$*m + lwork_sormbr_prt_nn ) + maxwrk = max( wrkbl, 3_${ik}$*m + bdspac ) + minwrk = 3_${ik}$*m + max( n, bdspac ) end if end if end if maxwrk = max( maxwrk, minwrk ) - work( 1 ) = stdlib_sroundup_lwork( maxwrk ) + work( 1_${ik}$ ) = stdlib${ii}$_sroundup_lwork( maxwrk ) if( lworkzero .and. anrmbignum ) then - iscl = 1 - call stdlib_slascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, ierr ) + iscl = 1_${ik}$ + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, ierr ) end if if( m>=n ) then ! a has at least as many rows as columns. if a has sufficiently @@ -72895,55 +72897,55 @@ module stdlib_linalg_lapack_s if( wntqn ) then ! path 1 (m >> n, jobz='n') ! no singular vectors to be computed - itau = 1 + itau = 1_${ik}$ nwork = itau + n ! compute a=q*r ! workspace: need n [tau] + n [work] ! workspace: prefer n [tau] + n*nb [work] - call stdlib_sgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & - 1, ierr ) + call stdlib${ii}$_sgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + 1_${ik}$, ierr ) ! zero out below r - if (n>1) call stdlib_slaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) - ie = 1 + if (n>1_${ik}$) call stdlib${ii}$_slaset( 'L', n-1, n-1, zero, zero, a( 2_${ik}$, 1_${ik}$ ), lda ) + ie = 1_${ik}$ itauq = ie + n itaup = itauq + n nwork = itaup + n ! bidiagonalize r in a ! workspace: need 3*n [e, tauq, taup] + n [work] ! workspace: prefer 3*n [e, tauq, taup] + 2*n*nb [work] - call stdlib_sgebrd( n, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_sgebrd( n, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) nwork = ie + n ! perform bidiagonal svd, computing singular values only ! workspace: need n [e] + bdspac - call stdlib_sbdsdc( 'U', 'N', n, s, work( ie ), dum, 1, dum, 1,dum, idum, & + call stdlib${ii}$_sbdsdc( 'U', 'N', n, s, work( ie ), dum, 1_${ik}$, dum, 1_${ik}$,dum, idum, & work( nwork ), iwork, info ) else if( wntqo ) then ! path 2 (m >> n, jobz = 'o') ! n left singular vectors to be overwritten on a and ! n right singular vectors to be computed in vt - ir = 1 + ir = 1_${ik}$ ! work(ir) is ldwrkr by n - if( lwork >= lda*n + n*n + 3*n + bdspac ) then + if( lwork >= lda*n + n*n + 3_${ik}$*n + bdspac ) then ldwrkr = lda else - ldwrkr = ( lwork - n*n - 3*n - bdspac ) / n + ldwrkr = ( lwork - n*n - 3_${ik}$*n - bdspac ) / n end if itau = ir + ldwrkr*n nwork = itau + n ! compute a=q*r ! workspace: need n*n [r] + n [tau] + n [work] ! workspace: prefer n*n [r] + n [tau] + n*nb [work] - call stdlib_sgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & - 1, ierr ) + call stdlib${ii}$_sgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + 1_${ik}$, ierr ) ! copy r to work(ir), zeroing out below it - call stdlib_slacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) - call stdlib_slaset( 'L', n - 1, n - 1, zero, zero, work(ir+1),ldwrkr ) + call stdlib${ii}$_slacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) + call stdlib${ii}$_slaset( 'L', n - 1_${ik}$, n - 1_${ik}$, zero, zero, work(ir+1),ldwrkr ) ! generate q in a ! workspace: need n*n [r] + n [tau] + n [work] ! workspace: prefer n*n [r] + n [tau] + n*nb [work] - call stdlib_sorgqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork - & - nwork + 1, ierr ) + call stdlib${ii}$_sorgqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork - & + nwork + 1_${ik}$, ierr ) ie = itau itauq = ie + n itaup = itauq + n @@ -72951,8 +72953,8 @@ module stdlib_linalg_lapack_s ! bidiagonalize r in work(ir) ! workspace: need n*n [r] + 3*n [e, tauq, taup] + n [work] ! workspace: prefer n*n [r] + 3*n [e, tauq, taup] + 2*n*nb [work] - call stdlib_sgebrd( n, n, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & - work( itaup ), work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_sgebrd( n, n, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & + work( itaup ), work( nwork ),lwork - nwork + 1_${ik}$, ierr ) ! work(iu) is n by n iu = nwork nwork = iu + n*n @@ -72960,32 +72962,32 @@ module stdlib_linalg_lapack_s ! of bidiagonal matrix in work(iu) and computing right ! singular vectors of bidiagonal matrix in vt ! workspace: need n*n [r] + 3*n [e, tauq, taup] + n*n [u] + bdspac - call stdlib_sbdsdc( 'U', 'I', n, s, work( ie ), work( iu ), n,vt, ldvt, dum, & + call stdlib${ii}$_sbdsdc( 'U', 'I', n, s, work( ie ), work( iu ), n,vt, ldvt, dum, & idum, work( nwork ), iwork,info ) ! overwrite work(iu) by left singular vectors of r ! and vt by right singular vectors of r ! workspace: need n*n [r] + 3*n [e, tauq, taup] + n*n [u] + n [work] ! workspace: prefer n*n [r] + 3*n [e, tauq, taup] + n*n [u] + n*nb [work] - call stdlib_sormbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & - work( iu ), n, work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_sormbr( 'P', 'R', 'T', n, n, n, work( ir ), ldwrkr,work( itaup ), & - vt, ldvt, work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_sormbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & + work( iu ), n, work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_sormbr( 'P', 'R', 'T', n, n, n, work( ir ), ldwrkr,work( itaup ), & + vt, ldvt, work( nwork ),lwork - nwork + 1_${ik}$, ierr ) ! multiply q in a by left singular vectors of r in ! work(iu), storing result in work(ir) and copying to a ! workspace: need n*n [r] + 3*n [e, tauq, taup] + n*n [u] ! workspace: prefer m*n [r] + 3*n [e, tauq, taup] + n*n [u] do i = 1, m, ldwrkr - chunk = min( m - i + 1, ldwrkr ) - call stdlib_sgemm( 'N', 'N', chunk, n, n, one, a( i, 1 ),lda, work( iu ), & + chunk = min( m - i + 1_${ik}$, ldwrkr ) + call stdlib${ii}$_sgemm( 'N', 'N', chunk, n, n, one, a( i, 1_${ik}$ ),lda, work( iu ), & n, zero, work( ir ),ldwrkr ) - call stdlib_slacpy( 'F', chunk, n, work( ir ), ldwrkr,a( i, 1 ), lda ) + call stdlib${ii}$_slacpy( 'F', chunk, n, work( ir ), ldwrkr,a( i, 1_${ik}$ ), lda ) end do else if( wntqs ) then ! path 3 (m >> n, jobz='s') ! n left singular vectors to be computed in u and ! n right singular vectors to be computed in vt - ir = 1 + ir = 1_${ik}$ ! work(ir) is n by n ldwrkr = n itau = ir + ldwrkr*n @@ -72993,16 +72995,16 @@ module stdlib_linalg_lapack_s ! compute a=q*r ! workspace: need n*n [r] + n [tau] + n [work] ! workspace: prefer n*n [r] + n [tau] + n*nb [work] - call stdlib_sgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & - 1, ierr ) + call stdlib${ii}$_sgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + 1_${ik}$, ierr ) ! copy r to work(ir), zeroing out below it - call stdlib_slacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) - call stdlib_slaset( 'L', n - 1, n - 1, zero, zero, work(ir+1),ldwrkr ) + call stdlib${ii}$_slacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) + call stdlib${ii}$_slaset( 'L', n - 1_${ik}$, n - 1_${ik}$, zero, zero, work(ir+1),ldwrkr ) ! generate q in a ! workspace: need n*n [r] + n [tau] + n [work] ! workspace: prefer n*n [r] + n [tau] + n*nb [work] - call stdlib_sorgqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork - & - nwork + 1, ierr ) + call stdlib${ii}$_sorgqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork - & + nwork + 1_${ik}$, ierr ) ie = itau itauq = ie + n itaup = itauq + n @@ -73010,33 +73012,33 @@ module stdlib_linalg_lapack_s ! bidiagonalize r in work(ir) ! workspace: need n*n [r] + 3*n [e, tauq, taup] + n [work] ! workspace: prefer n*n [r] + 3*n [e, tauq, taup] + 2*n*nb [work] - call stdlib_sgebrd( n, n, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & - work( itaup ), work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_sgebrd( n, n, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & + work( itaup ), work( nwork ),lwork - nwork + 1_${ik}$, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagoal matrix in u and computing right singular ! vectors of bidiagonal matrix in vt ! workspace: need n*n [r] + 3*n [e, tauq, taup] + bdspac - call stdlib_sbdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & + call stdlib${ii}$_sbdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & work( nwork ), iwork,info ) ! overwrite u by left singular vectors of r and vt ! by right singular vectors of r ! workspace: need n*n [r] + 3*n [e, tauq, taup] + n [work] ! workspace: prefer n*n [r] + 3*n [e, tauq, taup] + n*nb [work] - call stdlib_sormbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & - u, ldu, work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_sormbr( 'P', 'R', 'T', n, n, n, work( ir ), ldwrkr,work( itaup ), & - vt, ldvt, work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_sormbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & + u, ldu, work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_sormbr( 'P', 'R', 'T', n, n, n, work( ir ), ldwrkr,work( itaup ), & + vt, ldvt, work( nwork ),lwork - nwork + 1_${ik}$, ierr ) ! multiply q in a by left singular vectors of r in ! work(ir), storing result in u ! workspace: need n*n [r] - call stdlib_slacpy( 'F', n, n, u, ldu, work( ir ), ldwrkr ) - call stdlib_sgemm( 'N', 'N', m, n, n, one, a, lda, work( ir ),ldwrkr, zero, u,& + call stdlib${ii}$_slacpy( 'F', n, n, u, ldu, work( ir ), ldwrkr ) + call stdlib${ii}$_sgemm( 'N', 'N', m, n, n, one, a, lda, work( ir ),ldwrkr, zero, u,& ldu ) else if( wntqa ) then ! path 4 (m >> n, jobz='a') ! m left singular vectors to be computed in u and ! n right singular vectors to be computed in vt - iu = 1 + iu = 1_${ik}$ ! work(iu) is n by n ldwrku = n itau = iu + ldwrku*n @@ -73044,16 +73046,16 @@ module stdlib_linalg_lapack_s ! compute a=q*r, copying result to u ! workspace: need n*n [u] + n [tau] + n [work] ! workspace: prefer n*n [u] + n [tau] + n*nb [work] - call stdlib_sgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & - 1, ierr ) - call stdlib_slacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_sgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + 1_${ik}$, ierr ) + call stdlib${ii}$_slacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! workspace: need n*n [u] + n [tau] + m [work] ! workspace: prefer n*n [u] + n [tau] + m*nb [work] - call stdlib_sorgqr( m, m, n, u, ldu, work( itau ),work( nwork ), lwork - & - nwork + 1, ierr ) + call stdlib${ii}$_sorgqr( m, m, n, u, ldu, work( itau ),work( nwork ), lwork - & + nwork + 1_${ik}$, ierr ) ! produce r in a, zeroing out other entries - if (n>1) call stdlib_slaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) + if (n>1_${ik}$) call stdlib${ii}$_slaset( 'L', n-1, n-1, zero, zero, a( 2_${ik}$, 1_${ik}$ ), lda ) ie = itau itauq = ie + n itaup = itauq + n @@ -73061,105 +73063,105 @@ module stdlib_linalg_lapack_s ! bidiagonalize r in a ! workspace: need n*n [u] + 3*n [e, tauq, taup] + n [work] ! workspace: prefer n*n [u] + 3*n [e, tauq, taup] + 2*n*nb [work] - call stdlib_sgebrd( n, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_sgebrd( n, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in work(iu) and computing right ! singular vectors of bidiagonal matrix in vt ! workspace: need n*n [u] + 3*n [e, tauq, taup] + bdspac - call stdlib_sbdsdc( 'U', 'I', n, s, work( ie ), work( iu ), n,vt, ldvt, dum, & + call stdlib${ii}$_sbdsdc( 'U', 'I', n, s, work( ie ), work( iu ), n,vt, ldvt, dum, & idum, work( nwork ), iwork,info ) ! overwrite work(iu) by left singular vectors of r and vt ! by right singular vectors of r ! workspace: need n*n [u] + 3*n [e, tauq, taup] + n [work] ! workspace: prefer n*n [u] + 3*n [e, tauq, taup] + n*nb [work] - call stdlib_sormbr( 'Q', 'L', 'N', n, n, n, a, lda,work( itauq ), work( iu ), & - ldwrku,work( nwork ), lwork - nwork + 1, ierr ) - call stdlib_sormbr( 'P', 'R', 'T', n, n, n, a, lda,work( itaup ), vt, ldvt, & - work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_sormbr( 'Q', 'L', 'N', n, n, n, a, lda,work( itauq ), work( iu ), & + ldwrku,work( nwork ), lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_sormbr( 'P', 'R', 'T', n, n, n, a, lda,work( itaup ), vt, ldvt, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) ! multiply q in u by left singular vectors of r in ! work(iu), storing result in a ! workspace: need n*n [u] - call stdlib_sgemm( 'N', 'N', m, n, n, one, u, ldu, work( iu ),ldwrku, zero, a,& + call stdlib${ii}$_sgemm( 'N', 'N', m, n, n, one, u, ldu, work( iu ),ldwrku, zero, a,& lda ) ! copy left singular vectors of a from a to u - call stdlib_slacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_slacpy( 'F', m, n, a, lda, u, ldu ) end if else ! m < mnthr ! path 5 (m >= n, but not much larger) ! reduce to bidiagonal form without qr decomposition - ie = 1 + ie = 1_${ik}$ itauq = ie + n itaup = itauq + n nwork = itaup + n ! bidiagonalize a ! workspace: need 3*n [e, tauq, taup] + m [work] ! workspace: prefer 3*n [e, tauq, taup] + (m+n)*nb [work] - call stdlib_sgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_sgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) if( wntqn ) then ! path 5n (m >= n, jobz='n') ! perform bidiagonal svd, only computing singular values ! workspace: need 3*n [e, tauq, taup] + bdspac - call stdlib_sbdsdc( 'U', 'N', n, s, work( ie ), dum, 1, dum, 1,dum, idum, & + call stdlib${ii}$_sbdsdc( 'U', 'N', n, s, work( ie ), dum, 1_${ik}$, dum, 1_${ik}$,dum, idum, & work( nwork ), iwork, info ) else if( wntqo ) then ! path 5o (m >= n, jobz='o') iu = nwork - if( lwork >= m*n + 3*n + bdspac ) then + if( lwork >= m*n + 3_${ik}$*n + bdspac ) then ! work( iu ) is m by n ldwrku = m nwork = iu + ldwrku*n - call stdlib_slaset( 'F', m, n, zero, zero, work( iu ),ldwrku ) + call stdlib${ii}$_slaset( 'F', m, n, zero, zero, work( iu ),ldwrku ) ! ir is unused; silence compile warnings - ir = -1 + ir = -1_${ik}$ else ! work( iu ) is n by n ldwrku = n nwork = iu + ldwrku*n ! work(ir) is ldwrkr by n ir = nwork - ldwrkr = ( lwork - n*n - 3*n ) / n + ldwrkr = ( lwork - n*n - 3_${ik}$*n ) / n end if nwork = iu + ldwrku*n ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in work(iu) and computing right ! singular vectors of bidiagonal matrix in vt ! workspace: need 3*n [e, tauq, taup] + n*n [u] + bdspac - call stdlib_sbdsdc( 'U', 'I', n, s, work( ie ), work( iu ),ldwrku, vt, ldvt, & + call stdlib${ii}$_sbdsdc( 'U', 'I', n, s, work( ie ), work( iu ),ldwrku, vt, ldvt, & dum, idum, work( nwork ),iwork, info ) ! overwrite vt by right singular vectors of a ! workspace: need 3*n [e, tauq, taup] + n*n [u] + n [work] ! workspace: prefer 3*n [e, tauq, taup] + n*n [u] + n*nb [work] - call stdlib_sormbr( 'P', 'R', 'T', n, n, n, a, lda,work( itaup ), vt, ldvt, & - work( nwork ),lwork - nwork + 1, ierr ) - if( lwork >= m*n + 3*n + bdspac ) then + call stdlib${ii}$_sormbr( 'P', 'R', 'T', n, n, n, a, lda,work( itaup ), vt, ldvt, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + if( lwork >= m*n + 3_${ik}$*n + bdspac ) then ! path 5o-fast ! overwrite work(iu) by left singular vectors of a ! workspace: need 3*n [e, tauq, taup] + m*n [u] + n [work] ! workspace: prefer 3*n [e, tauq, taup] + m*n [u] + n*nb [work] - call stdlib_sormbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), work( iu & - ), ldwrku,work( nwork ), lwork - nwork + 1, ierr ) + call stdlib${ii}$_sormbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), work( iu & + ), ldwrku,work( nwork ), lwork - nwork + 1_${ik}$, ierr ) ! copy left singular vectors of a from work(iu) to a - call stdlib_slacpy( 'F', m, n, work( iu ), ldwrku, a, lda ) + call stdlib${ii}$_slacpy( 'F', m, n, work( iu ), ldwrku, a, lda ) else ! path 5o-slow ! generate q in a ! workspace: need 3*n [e, tauq, taup] + n*n [u] + n [work] ! workspace: prefer 3*n [e, tauq, taup] + n*n [u] + n*nb [work] - call stdlib_sorgbr( 'Q', m, n, n, a, lda, work( itauq ),work( nwork ), & - lwork - nwork + 1, ierr ) + call stdlib${ii}$_sorgbr( 'Q', m, n, n, a, lda, work( itauq ),work( nwork ), & + lwork - nwork + 1_${ik}$, ierr ) ! multiply q in a by left singular vectors of ! bidiagonal matrix in work(iu), storing result in ! work(ir) and copying to a ! workspace: need 3*n [e, tauq, taup] + n*n [u] + nb*n [r] ! workspace: prefer 3*n [e, tauq, taup] + n*n [u] + m*n [r] do i = 1, m, ldwrkr - chunk = min( m - i + 1, ldwrkr ) - call stdlib_sgemm( 'N', 'N', chunk, n, n, one, a( i, 1 ),lda, work( iu )& + chunk = min( m - i + 1_${ik}$, ldwrkr ) + call stdlib${ii}$_sgemm( 'N', 'N', chunk, n, n, one, a( i, 1_${ik}$ ),lda, work( iu )& , ldwrku, zero,work( ir ), ldwrkr ) - call stdlib_slacpy( 'F', chunk, n, work( ir ), ldwrkr,a( i, 1 ), lda ) + call stdlib${ii}$_slacpy( 'F', chunk, n, work( ir ), ldwrkr,a( i, 1_${ik}$ ), lda ) end do end if @@ -73169,38 +73171,38 @@ module stdlib_linalg_lapack_s ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in vt ! workspace: need 3*n [e, tauq, taup] + bdspac - call stdlib_slaset( 'F', m, n, zero, zero, u, ldu ) - call stdlib_sbdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & + call stdlib${ii}$_slaset( 'F', m, n, zero, zero, u, ldu ) + call stdlib${ii}$_sbdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & work( nwork ), iwork,info ) ! overwrite u by left singular vectors of a and vt ! by right singular vectors of a ! workspace: need 3*n [e, tauq, taup] + n [work] ! workspace: prefer 3*n [e, tauq, taup] + n*nb [work] - call stdlib_sormbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), u, ldu, & - work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_sormbr( 'P', 'R', 'T', n, n, n, a, lda,work( itaup ), vt, ldvt, & - work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_sormbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), u, ldu, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_sormbr( 'P', 'R', 'T', n, n, n, a, lda,work( itaup ), vt, ldvt, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) else if( wntqa ) then ! path 5a (m >= n, jobz='a') ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in vt ! workspace: need 3*n [e, tauq, taup] + bdspac - call stdlib_slaset( 'F', m, m, zero, zero, u, ldu ) - call stdlib_sbdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & + call stdlib${ii}$_slaset( 'F', m, m, zero, zero, u, ldu ) + call stdlib${ii}$_sbdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & work( nwork ), iwork,info ) ! set the right corner of u to identity matrix if( m>n ) then - call stdlib_slaset( 'F', m - n, m - n, zero, one, u(n+1,n+1),ldu ) + call stdlib${ii}$_slaset( 'F', m - n, m - n, zero, one, u(n+1,n+1),ldu ) end if ! overwrite u by left singular vectors of a and vt ! by right singular vectors of a ! workspace: need 3*n [e, tauq, taup] + m [work] ! workspace: prefer 3*n [e, tauq, taup] + m*nb [work] - call stdlib_sormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & - work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_sormbr( 'P', 'R', 'T', n, n, m, a, lda,work( itaup ), vt, ldvt, & - work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_sormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_sormbr( 'P', 'R', 'T', n, n, m, a, lda,work( itaup ), vt, ldvt, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) end if end if else @@ -73211,38 +73213,38 @@ module stdlib_linalg_lapack_s if( wntqn ) then ! path 1t (n >> m, jobz='n') ! no singular vectors to be computed - itau = 1 + itau = 1_${ik}$ nwork = itau + m ! compute a=l*q ! workspace: need m [tau] + m [work] ! workspace: prefer m [tau] + m*nb [work] - call stdlib_sgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & - 1, ierr ) + call stdlib${ii}$_sgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + 1_${ik}$, ierr ) ! zero out above l - if (m>1) call stdlib_slaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ), lda ) - ie = 1 + if (m>1_${ik}$) call stdlib${ii}$_slaset( 'U', m-1, m-1, zero, zero, a( 1_${ik}$, 2_${ik}$ ), lda ) + ie = 1_${ik}$ itauq = ie + m itaup = itauq + m nwork = itaup + m ! bidiagonalize l in a ! workspace: need 3*m [e, tauq, taup] + m [work] ! workspace: prefer 3*m [e, tauq, taup] + 2*m*nb [work] - call stdlib_sgebrd( m, m, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_sgebrd( m, m, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) nwork = ie + m ! perform bidiagonal svd, computing singular values only ! workspace: need m [e] + bdspac - call stdlib_sbdsdc( 'U', 'N', m, s, work( ie ), dum, 1, dum, 1,dum, idum, & + call stdlib${ii}$_sbdsdc( 'U', 'N', m, s, work( ie ), dum, 1_${ik}$, dum, 1_${ik}$,dum, idum, & work( nwork ), iwork, info ) else if( wntqo ) then ! path 2t (n >> m, jobz='o') ! m right singular vectors to be overwritten on a and ! m left singular vectors to be computed in u - ivt = 1 + ivt = 1_${ik}$ ! work(ivt) is m by m ! work(il) is m by m; it is later resized to m by chunk for gemm il = ivt + m*m - if( lwork >= m*n + m*m + 3*m + bdspac ) then + if( lwork >= m*n + m*m + 3_${ik}$*m + bdspac ) then ldwrkl = m chunk = n else @@ -73254,17 +73256,17 @@ module stdlib_linalg_lapack_s ! compute a=l*q ! workspace: need m*m [vt] + m*m [l] + m [tau] + m [work] ! workspace: prefer m*m [vt] + m*m [l] + m [tau] + m*nb [work] - call stdlib_sgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & - 1, ierr ) + call stdlib${ii}$_sgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + 1_${ik}$, ierr ) ! copy l to work(il), zeroing about above it - call stdlib_slacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) - call stdlib_slaset( 'U', m - 1, m - 1, zero, zero,work( il + ldwrkl ), ldwrkl & + call stdlib${ii}$_slacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) + call stdlib${ii}$_slaset( 'U', m - 1_${ik}$, m - 1_${ik}$, zero, zero,work( il + ldwrkl ), ldwrkl & ) ! generate q in a ! workspace: need m*m [vt] + m*m [l] + m [tau] + m [work] ! workspace: prefer m*m [vt] + m*m [l] + m [tau] + m*nb [work] - call stdlib_sorglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork - & - nwork + 1, ierr ) + call stdlib${ii}$_sorglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork - & + nwork + 1_${ik}$, ierr ) ie = itau itauq = ie + m itaup = itauq + m @@ -73272,39 +73274,39 @@ module stdlib_linalg_lapack_s ! bidiagonalize l in work(il) ! workspace: need m*m [vt] + m*m [l] + 3*m [e, tauq, taup] + m [work] ! workspace: prefer m*m [vt] + m*m [l] + 3*m [e, tauq, taup] + 2*m*nb [work] - call stdlib_sgebrd( m, m, work( il ), ldwrkl, s, work( ie ),work( itauq ), & - work( itaup ), work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_sgebrd( m, m, work( il ), ldwrkl, s, work( ie ),work( itauq ), & + work( itaup ), work( nwork ),lwork - nwork + 1_${ik}$, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in u, and computing right singular ! vectors of bidiagonal matrix in work(ivt) ! workspace: need m*m [vt] + m*m [l] + 3*m [e, tauq, taup] + bdspac - call stdlib_sbdsdc( 'U', 'I', m, s, work( ie ), u, ldu,work( ivt ), m, dum, & + call stdlib${ii}$_sbdsdc( 'U', 'I', m, s, work( ie ), u, ldu,work( ivt ), m, dum, & idum, work( nwork ),iwork, info ) ! overwrite u by left singular vectors of l and work(ivt) ! by right singular vectors of l ! workspace: need m*m [vt] + m*m [l] + 3*m [e, tauq, taup] + m [work] ! workspace: prefer m*m [vt] + m*m [l] + 3*m [e, tauq, taup] + m*nb [work] - call stdlib_sormbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & - u, ldu, work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_sormbr( 'P', 'R', 'T', m, m, m, work( il ), ldwrkl,work( itaup ), & - work( ivt ), m,work( nwork ), lwork - nwork + 1, ierr ) + call stdlib${ii}$_sormbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & + u, ldu, work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_sormbr( 'P', 'R', 'T', m, m, m, work( il ), ldwrkl,work( itaup ), & + work( ivt ), m,work( nwork ), lwork - nwork + 1_${ik}$, ierr ) ! multiply right singular vectors of l in work(ivt) by q ! in a, storing result in work(il) and copying to a ! workspace: need m*m [vt] + m*m [l] ! workspace: prefer m*m [vt] + m*n [l] ! at this point, l is resized as m by chunk. do i = 1, n, chunk - blk = min( n - i + 1, chunk ) - call stdlib_sgemm( 'N', 'N', m, blk, m, one, work( ivt ), m,a( 1, i ), lda,& + blk = min( n - i + 1_${ik}$, chunk ) + call stdlib${ii}$_sgemm( 'N', 'N', m, blk, m, one, work( ivt ), m,a( 1_${ik}$, i ), lda,& zero, work( il ), ldwrkl ) - call stdlib_slacpy( 'F', m, blk, work( il ), ldwrkl,a( 1, i ), lda ) + call stdlib${ii}$_slacpy( 'F', m, blk, work( il ), ldwrkl,a( 1_${ik}$, i ), lda ) end do else if( wntqs ) then ! path 3t (n >> m, jobz='s') ! m right singular vectors to be computed in vt and ! m left singular vectors to be computed in u - il = 1 + il = 1_${ik}$ ! work(il) is m by m ldwrkl = m itau = il + ldwrkl*m @@ -73312,17 +73314,17 @@ module stdlib_linalg_lapack_s ! compute a=l*q ! workspace: need m*m [l] + m [tau] + m [work] ! workspace: prefer m*m [l] + m [tau] + m*nb [work] - call stdlib_sgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & - 1, ierr ) + call stdlib${ii}$_sgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + 1_${ik}$, ierr ) ! copy l to work(il), zeroing out above it - call stdlib_slacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) - call stdlib_slaset( 'U', m - 1, m - 1, zero, zero,work( il + ldwrkl ), ldwrkl & + call stdlib${ii}$_slacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) + call stdlib${ii}$_slaset( 'U', m - 1_${ik}$, m - 1_${ik}$, zero, zero,work( il + ldwrkl ), ldwrkl & ) ! generate q in a ! workspace: need m*m [l] + m [tau] + m [work] ! workspace: prefer m*m [l] + m [tau] + m*nb [work] - call stdlib_sorglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork - & - nwork + 1, ierr ) + call stdlib${ii}$_sorglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork - & + nwork + 1_${ik}$, ierr ) ie = itau itauq = ie + m itaup = itauq + m @@ -73330,33 +73332,33 @@ module stdlib_linalg_lapack_s ! bidiagonalize l in work(iu). ! workspace: need m*m [l] + 3*m [e, tauq, taup] + m [work] ! workspace: prefer m*m [l] + 3*m [e, tauq, taup] + 2*m*nb [work] - call stdlib_sgebrd( m, m, work( il ), ldwrkl, s, work( ie ),work( itauq ), & - work( itaup ), work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_sgebrd( m, m, work( il ), ldwrkl, s, work( ie ),work( itauq ), & + work( itaup ), work( nwork ),lwork - nwork + 1_${ik}$, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in vt ! workspace: need m*m [l] + 3*m [e, tauq, taup] + bdspac - call stdlib_sbdsdc( 'U', 'I', m, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & + call stdlib${ii}$_sbdsdc( 'U', 'I', m, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & work( nwork ), iwork,info ) ! overwrite u by left singular vectors of l and vt ! by right singular vectors of l ! workspace: need m*m [l] + 3*m [e, tauq, taup] + m [work] ! workspace: prefer m*m [l] + 3*m [e, tauq, taup] + m*nb [work] - call stdlib_sormbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & - u, ldu, work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_sormbr( 'P', 'R', 'T', m, m, m, work( il ), ldwrkl,work( itaup ), & - vt, ldvt, work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_sormbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & + u, ldu, work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_sormbr( 'P', 'R', 'T', m, m, m, work( il ), ldwrkl,work( itaup ), & + vt, ldvt, work( nwork ),lwork - nwork + 1_${ik}$, ierr ) ! multiply right singular vectors of l in work(il) by ! q in a, storing result in vt ! workspace: need m*m [l] - call stdlib_slacpy( 'F', m, m, vt, ldvt, work( il ), ldwrkl ) - call stdlib_sgemm( 'N', 'N', m, n, m, one, work( il ), ldwrkl,a, lda, zero, & + call stdlib${ii}$_slacpy( 'F', m, m, vt, ldvt, work( il ), ldwrkl ) + call stdlib${ii}$_sgemm( 'N', 'N', m, n, m, one, work( il ), ldwrkl,a, lda, zero, & vt, ldvt ) else if( wntqa ) then ! path 4t (n >> m, jobz='a') ! n right singular vectors to be computed in vt and ! m left singular vectors to be computed in u - ivt = 1 + ivt = 1_${ik}$ ! work(ivt) is m by m ldwkvt = m itau = ivt + ldwkvt*m @@ -73364,16 +73366,16 @@ module stdlib_linalg_lapack_s ! compute a=l*q, copying result to vt ! workspace: need m*m [vt] + m [tau] + m [work] ! workspace: prefer m*m [vt] + m [tau] + m*nb [work] - call stdlib_sgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & - 1, ierr ) - call stdlib_slacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_sgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork - nwork + & + 1_${ik}$, ierr ) + call stdlib${ii}$_slacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! workspace: need m*m [vt] + m [tau] + n [work] ! workspace: prefer m*m [vt] + m [tau] + n*nb [work] - call stdlib_sorglq( n, n, m, vt, ldvt, work( itau ),work( nwork ), lwork - & - nwork + 1, ierr ) + call stdlib${ii}$_sorglq( n, n, m, vt, ldvt, work( itau ),work( nwork ), lwork - & + nwork + 1_${ik}$, ierr ) ! produce l in a, zeroing out other entries - if (m>1) call stdlib_slaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ), lda ) + if (m>1_${ik}$) call stdlib${ii}$_slaset( 'U', m-1, m-1, zero, zero, a( 1_${ik}$, 2_${ik}$ ), lda ) ie = itau itauq = ie + m itaup = itauq + m @@ -73381,103 +73383,103 @@ module stdlib_linalg_lapack_s ! bidiagonalize l in a ! workspace: need m*m [vt] + 3*m [e, tauq, taup] + m [work] ! workspace: prefer m*m [vt] + 3*m [e, tauq, taup] + 2*m*nb [work] - call stdlib_sgebrd( m, m, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_sgebrd( m, m, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in work(ivt) ! workspace: need m*m [vt] + 3*m [e, tauq, taup] + bdspac - call stdlib_sbdsdc( 'U', 'I', m, s, work( ie ), u, ldu,work( ivt ), ldwkvt, & + call stdlib${ii}$_sbdsdc( 'U', 'I', m, s, work( ie ), u, ldu,work( ivt ), ldwkvt, & dum, idum,work( nwork ), iwork, info ) ! overwrite u by left singular vectors of l and work(ivt) ! by right singular vectors of l ! workspace: need m*m [vt] + 3*m [e, tauq, taup]+ m [work] ! workspace: prefer m*m [vt] + 3*m [e, tauq, taup]+ m*nb [work] - call stdlib_sormbr( 'Q', 'L', 'N', m, m, m, a, lda,work( itauq ), u, ldu, & - work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_sormbr( 'P', 'R', 'T', m, m, m, a, lda,work( itaup ), work( ivt ),& - ldwkvt,work( nwork ), lwork - nwork + 1, ierr ) + call stdlib${ii}$_sormbr( 'Q', 'L', 'N', m, m, m, a, lda,work( itauq ), u, ldu, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_sormbr( 'P', 'R', 'T', m, m, m, a, lda,work( itaup ), work( ivt ),& + ldwkvt,work( nwork ), lwork - nwork + 1_${ik}$, ierr ) ! multiply right singular vectors of l in work(ivt) by ! q in vt, storing result in a ! workspace: need m*m [vt] - call stdlib_sgemm( 'N', 'N', m, n, m, one, work( ivt ), ldwkvt,vt, ldvt, zero,& + call stdlib${ii}$_sgemm( 'N', 'N', m, n, m, one, work( ivt ), ldwkvt,vt, ldvt, zero,& a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_slacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_slacpy( 'F', m, n, a, lda, vt, ldvt ) end if else ! n < mnthr ! path 5t (n > m, but not much larger) ! reduce to bidiagonal form without lq decomposition - ie = 1 + ie = 1_${ik}$ itauq = ie + m itaup = itauq + m nwork = itaup + m ! bidiagonalize a ! workspace: need 3*m [e, tauq, taup] + n [work] ! workspace: prefer 3*m [e, tauq, taup] + (m+n)*nb [work] - call stdlib_sgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_sgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) if( wntqn ) then ! path 5tn (n > m, jobz='n') ! perform bidiagonal svd, only computing singular values ! workspace: need 3*m [e, tauq, taup] + bdspac - call stdlib_sbdsdc( 'L', 'N', m, s, work( ie ), dum, 1, dum, 1,dum, idum, & + call stdlib${ii}$_sbdsdc( 'L', 'N', m, s, work( ie ), dum, 1_${ik}$, dum, 1_${ik}$,dum, idum, & work( nwork ), iwork, info ) else if( wntqo ) then ! path 5to (n > m, jobz='o') ldwkvt = m ivt = nwork - if( lwork >= m*n + 3*m + bdspac ) then + if( lwork >= m*n + 3_${ik}$*m + bdspac ) then ! work( ivt ) is m by n - call stdlib_slaset( 'F', m, n, zero, zero, work( ivt ),ldwkvt ) + call stdlib${ii}$_slaset( 'F', m, n, zero, zero, work( ivt ),ldwkvt ) nwork = ivt + ldwkvt*n ! il is unused; silence compile warnings - il = -1 + il = -1_${ik}$ else ! work( ivt ) is m by m nwork = ivt + ldwkvt*m il = nwork ! work(il) is m by chunk - chunk = ( lwork - m*m - 3*m ) / m + chunk = ( lwork - m*m - 3_${ik}$*m ) / m end if ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in work(ivt) ! workspace: need 3*m [e, tauq, taup] + m*m [vt] + bdspac - call stdlib_sbdsdc( 'L', 'I', m, s, work( ie ), u, ldu,work( ivt ), ldwkvt, & + call stdlib${ii}$_sbdsdc( 'L', 'I', m, s, work( ie ), u, ldu,work( ivt ), ldwkvt, & dum, idum,work( nwork ), iwork, info ) ! overwrite u by left singular vectors of a ! workspace: need 3*m [e, tauq, taup] + m*m [vt] + m [work] ! workspace: prefer 3*m [e, tauq, taup] + m*m [vt] + m*nb [work] - call stdlib_sormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & - work( nwork ),lwork - nwork + 1, ierr ) - if( lwork >= m*n + 3*m + bdspac ) then + call stdlib${ii}$_sormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + if( lwork >= m*n + 3_${ik}$*m + bdspac ) then ! path 5to-fast ! overwrite work(ivt) by left singular vectors of a ! workspace: need 3*m [e, tauq, taup] + m*n [vt] + m [work] ! workspace: prefer 3*m [e, tauq, taup] + m*n [vt] + m*nb [work] - call stdlib_sormbr( 'P', 'R', 'T', m, n, m, a, lda,work( itaup ), work( & - ivt ), ldwkvt,work( nwork ), lwork - nwork + 1, ierr ) + call stdlib${ii}$_sormbr( 'P', 'R', 'T', m, n, m, a, lda,work( itaup ), work( & + ivt ), ldwkvt,work( nwork ), lwork - nwork + 1_${ik}$, ierr ) ! copy right singular vectors of a from work(ivt) to a - call stdlib_slacpy( 'F', m, n, work( ivt ), ldwkvt, a, lda ) + call stdlib${ii}$_slacpy( 'F', m, n, work( ivt ), ldwkvt, a, lda ) else ! path 5to-slow ! generate p**t in a ! workspace: need 3*m [e, tauq, taup] + m*m [vt] + m [work] ! workspace: prefer 3*m [e, tauq, taup] + m*m [vt] + m*nb [work] - call stdlib_sorgbr( 'P', m, n, m, a, lda, work( itaup ),work( nwork ), & - lwork - nwork + 1, ierr ) + call stdlib${ii}$_sorgbr( 'P', m, n, m, a, lda, work( itaup ),work( nwork ), & + lwork - nwork + 1_${ik}$, ierr ) ! multiply q in a by right singular vectors of ! bidiagonal matrix in work(ivt), storing result in ! work(il) and copying to a ! workspace: need 3*m [e, tauq, taup] + m*m [vt] + m*nb [l] ! workspace: prefer 3*m [e, tauq, taup] + m*m [vt] + m*n [l] do i = 1, n, chunk - blk = min( n - i + 1, chunk ) - call stdlib_sgemm( 'N', 'N', m, blk, m, one, work( ivt ),ldwkvt, a( 1, & + blk = min( n - i + 1_${ik}$, chunk ) + call stdlib${ii}$_sgemm( 'N', 'N', m, blk, m, one, work( ivt ),ldwkvt, a( 1_${ik}$, & i ), lda, zero,work( il ), m ) - call stdlib_slacpy( 'F', m, blk, work( il ), m, a( 1, i ),lda ) + call stdlib${ii}$_slacpy( 'F', m, blk, work( il ), m, a( 1_${ik}$, i ),lda ) end do end if else if( wntqs ) then @@ -73486,55 +73488,55 @@ module stdlib_linalg_lapack_s ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in vt ! workspace: need 3*m [e, tauq, taup] + bdspac - call stdlib_slaset( 'F', m, n, zero, zero, vt, ldvt ) - call stdlib_sbdsdc( 'L', 'I', m, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & + call stdlib${ii}$_slaset( 'F', m, n, zero, zero, vt, ldvt ) + call stdlib${ii}$_sbdsdc( 'L', 'I', m, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & work( nwork ), iwork,info ) ! overwrite u by left singular vectors of a and vt ! by right singular vectors of a ! workspace: need 3*m [e, tauq, taup] + m [work] ! workspace: prefer 3*m [e, tauq, taup] + m*nb [work] - call stdlib_sormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & - work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_sormbr( 'P', 'R', 'T', m, n, m, a, lda,work( itaup ), vt, ldvt, & - work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_sormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_sormbr( 'P', 'R', 'T', m, n, m, a, lda,work( itaup ), vt, ldvt, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) else if( wntqa ) then ! path 5ta (n > m, jobz='a') ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in u and computing right singular ! vectors of bidiagonal matrix in vt ! workspace: need 3*m [e, tauq, taup] + bdspac - call stdlib_slaset( 'F', n, n, zero, zero, vt, ldvt ) - call stdlib_sbdsdc( 'L', 'I', m, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & + call stdlib${ii}$_slaset( 'F', n, n, zero, zero, vt, ldvt ) + call stdlib${ii}$_sbdsdc( 'L', 'I', m, s, work( ie ), u, ldu, vt,ldvt, dum, idum, & work( nwork ), iwork,info ) ! set the right corner of vt to identity matrix if( n>m ) then - call stdlib_slaset( 'F', n-m, n-m, zero, one, vt(m+1,m+1),ldvt ) + call stdlib${ii}$_slaset( 'F', n-m, n-m, zero, one, vt(m+1,m+1),ldvt ) end if ! overwrite u by left singular vectors of a and vt ! by right singular vectors of a ! workspace: need 3*m [e, tauq, taup] + n [work] ! workspace: prefer 3*m [e, tauq, taup] + n*nb [work] - call stdlib_sormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & - work( nwork ),lwork - nwork + 1, ierr ) - call stdlib_sormbr( 'P', 'R', 'T', n, n, m, a, lda,work( itaup ), vt, ldvt, & - work( nwork ),lwork - nwork + 1, ierr ) + call stdlib${ii}$_sormbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) + call stdlib${ii}$_sormbr( 'P', 'R', 'T', n, n, m, a, lda,work( itaup ), vt, ldvt, & + work( nwork ),lwork - nwork + 1_${ik}$, ierr ) end if end if end if ! undo scaling if necessary - if( iscl==1 ) then - if( anrm>bignum )call stdlib_slascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,& + if( iscl==1_${ik}$ ) then + if( anrm>bignum )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn, 1_${ik}$, s, minmn,& ierr ) - if( anrm=n .and. minmn>0 ) then - ! compute space needed for stdlib_sbdsqr - mnthr = stdlib_ilaenv( 6, 'SGESVD', jobu // jobvt, m, n, 0, 0 ) - bdspac = 5*n - ! compute space needed for stdlib_sgeqrf - call stdlib_sgeqrf( m, n, a, lda, dum(1), dum(1), -1, ierr ) - lwork_sgeqrf = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_sorgqr - call stdlib_sorgqr( m, n, n, a, lda, dum(1), dum(1), -1, ierr ) - lwork_sorgqr_n = int( dum(1),KIND=ilp) - call stdlib_sorgqr( m, m, n, a, lda, dum(1), dum(1), -1, ierr ) - lwork_sorgqr_m = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_sgebrd - call stdlib_sgebrd( n, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) + ! following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + if( m>=n .and. minmn>0_${ik}$ ) then + ! compute space needed for stdlib${ii}$_sbdsqr + mnthr = stdlib${ii}$_ilaenv( 6_${ik}$, 'SGESVD', jobu // jobvt, m, n, 0_${ik}$, 0_${ik}$ ) + bdspac = 5_${ik}$*n + ! compute space needed for stdlib${ii}$_sgeqrf + call stdlib${ii}$_sgeqrf( m, n, a, lda, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_sgeqrf = int( dum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_sorgqr + call stdlib${ii}$_sorgqr( m, n, n, a, lda, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_sorgqr_n = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_sorgqr( m, m, n, a, lda, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_sorgqr_m = int( dum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_sgebrd + call stdlib${ii}$_sgebrd( n, n, a, lda, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) - lwork_sgebrd = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_sorgbr p - call stdlib_sorgbr( 'P', n, n, n, a, lda, dum(1),dum(1), -1, ierr ) - lwork_sorgbr_p = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_sorgbr q - call stdlib_sorgbr( 'Q', n, n, n, a, lda, dum(1),dum(1), -1, ierr ) - lwork_sorgbr_q = int( dum(1),KIND=ilp) + lwork_sgebrd = int( dum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_sorgbr p + call stdlib${ii}$_sorgbr( 'P', n, n, n, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_sorgbr_p = int( dum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_sorgbr q + call stdlib${ii}$_sorgbr( 'Q', n, n, n, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_sorgbr_q = int( dum(1_${ik}$),KIND=${ik}$) if( m>=mnthr ) then if( wntun ) then ! path 1 (m much larger than n, jobu='n') maxwrk = n + lwork_sgeqrf - maxwrk = max( maxwrk, 3*n+lwork_sgebrd ) - if( wntvo .or. wntvas )maxwrk = max( maxwrk, 3*n+lwork_sorgbr_p ) + maxwrk = max( maxwrk, 3_${ik}$*n+lwork_sgebrd ) + if( wntvo .or. wntvas )maxwrk = max( maxwrk, 3_${ik}$*n+lwork_sorgbr_p ) maxwrk = max( maxwrk, bdspac ) - minwrk = max( 4*n, bdspac ) + minwrk = max( 4_${ik}$*n, bdspac ) else if( wntuo .and. wntvn ) then ! path 2 (m much larger than n, jobu='o', jobvt='n') wrkbl = n + lwork_sgeqrf wrkbl = max( wrkbl, n+lwork_sorgqr_n ) - wrkbl = max( wrkbl, 3*n+lwork_sgebrd ) - wrkbl = max( wrkbl, 3*n+lwork_sorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*n+lwork_sgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*n+lwork_sorgbr_q ) wrkbl = max( wrkbl, bdspac ) maxwrk = max( n*n+wrkbl, n*n+m*n+n ) - minwrk = max( 3*n+m, bdspac ) + minwrk = max( 3_${ik}$*n+m, bdspac ) else if( wntuo .and. wntvas ) then ! path 3 (m much larger than n, jobu='o', jobvt='s' or ! 'a') wrkbl = n + lwork_sgeqrf wrkbl = max( wrkbl, n+lwork_sorgqr_n ) - wrkbl = max( wrkbl, 3*n+lwork_sgebrd ) - wrkbl = max( wrkbl, 3*n+lwork_sorgbr_q ) - wrkbl = max( wrkbl, 3*n+lwork_sorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*n+lwork_sgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*n+lwork_sorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*n+lwork_sorgbr_p ) wrkbl = max( wrkbl, bdspac ) maxwrk = max( n*n+wrkbl, n*n+m*n+n ) - minwrk = max( 3*n+m, bdspac ) + minwrk = max( 3_${ik}$*n+m, bdspac ) else if( wntus .and. wntvn ) then ! path 4 (m much larger than n, jobu='s', jobvt='n') wrkbl = n + lwork_sgeqrf wrkbl = max( wrkbl, n+lwork_sorgqr_n ) - wrkbl = max( wrkbl, 3*n+lwork_sgebrd ) - wrkbl = max( wrkbl, 3*n+lwork_sorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*n+lwork_sgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*n+lwork_sorgbr_q ) wrkbl = max( wrkbl, bdspac ) maxwrk = n*n + wrkbl - minwrk = max( 3*n+m, bdspac ) + minwrk = max( 3_${ik}$*n+m, bdspac ) else if( wntus .and. wntvo ) then ! path 5 (m much larger than n, jobu='s', jobvt='o') wrkbl = n + lwork_sgeqrf wrkbl = max( wrkbl, n+lwork_sorgqr_n ) - wrkbl = max( wrkbl, 3*n+lwork_sgebrd ) - wrkbl = max( wrkbl, 3*n+lwork_sorgbr_q ) - wrkbl = max( wrkbl, 3*n+lwork_sorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*n+lwork_sgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*n+lwork_sorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*n+lwork_sorgbr_p ) wrkbl = max( wrkbl, bdspac ) - maxwrk = 2*n*n + wrkbl - minwrk = max( 3*n+m, bdspac ) + maxwrk = 2_${ik}$*n*n + wrkbl + minwrk = max( 3_${ik}$*n+m, bdspac ) else if( wntus .and. wntvas ) then ! path 6 (m much larger than n, jobu='s', jobvt='s' or ! 'a') wrkbl = n + lwork_sgeqrf wrkbl = max( wrkbl, n+lwork_sorgqr_n ) - wrkbl = max( wrkbl, 3*n+lwork_sgebrd ) - wrkbl = max( wrkbl, 3*n+lwork_sorgbr_q ) - wrkbl = max( wrkbl, 3*n+lwork_sorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*n+lwork_sgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*n+lwork_sorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*n+lwork_sorgbr_p ) wrkbl = max( wrkbl, bdspac ) maxwrk = n*n + wrkbl - minwrk = max( 3*n+m, bdspac ) + minwrk = max( 3_${ik}$*n+m, bdspac ) else if( wntua .and. wntvn ) then ! path 7 (m much larger than n, jobu='a', jobvt='n') wrkbl = n + lwork_sgeqrf wrkbl = max( wrkbl, n+lwork_sorgqr_m ) - wrkbl = max( wrkbl, 3*n+lwork_sgebrd ) - wrkbl = max( wrkbl, 3*n+lwork_sorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*n+lwork_sgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*n+lwork_sorgbr_q ) wrkbl = max( wrkbl, bdspac ) maxwrk = n*n + wrkbl - minwrk = max( 3*n+m, bdspac ) + minwrk = max( 3_${ik}$*n+m, bdspac ) else if( wntua .and. wntvo ) then ! path 8 (m much larger than n, jobu='a', jobvt='o') wrkbl = n + lwork_sgeqrf wrkbl = max( wrkbl, n+lwork_sorgqr_m ) - wrkbl = max( wrkbl, 3*n+lwork_sgebrd ) - wrkbl = max( wrkbl, 3*n+lwork_sorgbr_q ) - wrkbl = max( wrkbl, 3*n+lwork_sorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*n+lwork_sgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*n+lwork_sorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*n+lwork_sorgbr_p ) wrkbl = max( wrkbl, bdspac ) - maxwrk = 2*n*n + wrkbl - minwrk = max( 3*n+m, bdspac ) + maxwrk = 2_${ik}$*n*n + wrkbl + minwrk = max( 3_${ik}$*n+m, bdspac ) else if( wntua .and. wntvas ) then ! path 9 (m much larger than n, jobu='a', jobvt='s' or ! 'a') wrkbl = n + lwork_sgeqrf wrkbl = max( wrkbl, n+lwork_sorgqr_m ) - wrkbl = max( wrkbl, 3*n+lwork_sgebrd ) - wrkbl = max( wrkbl, 3*n+lwork_sorgbr_q ) - wrkbl = max( wrkbl, 3*n+lwork_sorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*n+lwork_sgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*n+lwork_sorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*n+lwork_sorgbr_p ) wrkbl = max( wrkbl, bdspac ) maxwrk = n*n + wrkbl - minwrk = max( 3*n+m, bdspac ) + minwrk = max( 3_${ik}$*n+m, bdspac ) end if else ! path 10 (m at least n, but not much larger) - call stdlib_sgebrd( m, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) + call stdlib${ii}$_sgebrd( m, n, a, lda, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) - lwork_sgebrd = int( dum(1),KIND=ilp) - maxwrk = 3*n + lwork_sgebrd + lwork_sgebrd = int( dum(1_${ik}$),KIND=${ik}$) + maxwrk = 3_${ik}$*n + lwork_sgebrd if( wntus .or. wntuo ) then - call stdlib_sorgbr( 'Q', m, n, n, a, lda, dum(1),dum(1), -1, ierr ) - lwork_sorgbr_q = int( dum(1),KIND=ilp) - maxwrk = max( maxwrk, 3*n+lwork_sorgbr_q ) + call stdlib${ii}$_sorgbr( 'Q', m, n, n, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_sorgbr_q = int( dum(1_${ik}$),KIND=${ik}$) + maxwrk = max( maxwrk, 3_${ik}$*n+lwork_sorgbr_q ) end if if( wntua ) then - call stdlib_sorgbr( 'Q', m, m, n, a, lda, dum(1),dum(1), -1, ierr ) - lwork_sorgbr_q = int( dum(1),KIND=ilp) - maxwrk = max( maxwrk, 3*n+lwork_sorgbr_q ) + call stdlib${ii}$_sorgbr( 'Q', m, m, n, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_sorgbr_q = int( dum(1_${ik}$),KIND=${ik}$) + maxwrk = max( maxwrk, 3_${ik}$*n+lwork_sorgbr_q ) end if if( .not.wntvn ) then - maxwrk = max( maxwrk, 3*n+lwork_sorgbr_p ) + maxwrk = max( maxwrk, 3_${ik}$*n+lwork_sorgbr_p ) end if maxwrk = max( maxwrk, bdspac ) - minwrk = max( 3*n+m, bdspac ) - end if - else if( minmn>0 ) then - ! compute space needed for stdlib_sbdsqr - mnthr = stdlib_ilaenv( 6, 'SGESVD', jobu // jobvt, m, n, 0, 0 ) - bdspac = 5*m - ! compute space needed for stdlib_sgelqf - call stdlib_sgelqf( m, n, a, lda, dum(1), dum(1), -1, ierr ) - lwork_sgelqf = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_sorglq - call stdlib_sorglq( n, n, m, dum(1), n, dum(1), dum(1), -1, ierr ) - lwork_sorglq_n = int( dum(1),KIND=ilp) - call stdlib_sorglq( m, n, m, a, lda, dum(1), dum(1), -1, ierr ) - lwork_sorglq_m = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_sgebrd - call stdlib_sgebrd( m, m, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) + minwrk = max( 3_${ik}$*n+m, bdspac ) + end if + else if( minmn>0_${ik}$ ) then + ! compute space needed for stdlib${ii}$_sbdsqr + mnthr = stdlib${ii}$_ilaenv( 6_${ik}$, 'SGESVD', jobu // jobvt, m, n, 0_${ik}$, 0_${ik}$ ) + bdspac = 5_${ik}$*m + ! compute space needed for stdlib${ii}$_sgelqf + call stdlib${ii}$_sgelqf( m, n, a, lda, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_sgelqf = int( dum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_sorglq + call stdlib${ii}$_sorglq( n, n, m, dum(1_${ik}$), n, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_sorglq_n = int( dum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_sorglq( m, n, m, a, lda, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_sorglq_m = int( dum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_sgebrd + call stdlib${ii}$_sgebrd( m, m, a, lda, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) - lwork_sgebrd = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_sorgbr p - call stdlib_sorgbr( 'P', m, m, m, a, n, dum(1),dum(1), -1, ierr ) - lwork_sorgbr_p = int( dum(1),KIND=ilp) - ! compute space needed for stdlib_sorgbr q - call stdlib_sorgbr( 'Q', m, m, m, a, n, dum(1),dum(1), -1, ierr ) - lwork_sorgbr_q = int( dum(1),KIND=ilp) + lwork_sgebrd = int( dum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_sorgbr p + call stdlib${ii}$_sorgbr( 'P', m, m, m, a, n, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_sorgbr_p = int( dum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_sorgbr q + call stdlib${ii}$_sorgbr( 'Q', m, m, m, a, n, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_sorgbr_q = int( dum(1_${ik}$),KIND=${ik}$) if( n>=mnthr ) then if( wntvn ) then ! path 1t(n much larger than m, jobvt='n') maxwrk = m + lwork_sgelqf - maxwrk = max( maxwrk, 3*m+lwork_sgebrd ) - if( wntuo .or. wntuas )maxwrk = max( maxwrk, 3*m+lwork_sorgbr_q ) + maxwrk = max( maxwrk, 3_${ik}$*m+lwork_sgebrd ) + if( wntuo .or. wntuas )maxwrk = max( maxwrk, 3_${ik}$*m+lwork_sorgbr_q ) maxwrk = max( maxwrk, bdspac ) - minwrk = max( 4*m, bdspac ) + minwrk = max( 4_${ik}$*m, bdspac ) else if( wntvo .and. wntun ) then ! path 2t(n much larger than m, jobu='n', jobvt='o') wrkbl = m + lwork_sgelqf wrkbl = max( wrkbl, m+lwork_sorglq_m ) - wrkbl = max( wrkbl, 3*m+lwork_sgebrd ) - wrkbl = max( wrkbl, 3*m+lwork_sorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*m+lwork_sgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*m+lwork_sorgbr_p ) wrkbl = max( wrkbl, bdspac ) maxwrk = max( m*m+wrkbl, m*m+m*n+m ) - minwrk = max( 3*m+n, bdspac ) + minwrk = max( 3_${ik}$*m+n, bdspac ) else if( wntvo .and. wntuas ) then ! path 3t(n much larger than m, jobu='s' or 'a', ! jobvt='o') wrkbl = m + lwork_sgelqf wrkbl = max( wrkbl, m+lwork_sorglq_m ) - wrkbl = max( wrkbl, 3*m+lwork_sgebrd ) - wrkbl = max( wrkbl, 3*m+lwork_sorgbr_p ) - wrkbl = max( wrkbl, 3*m+lwork_sorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*m+lwork_sgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*m+lwork_sorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*m+lwork_sorgbr_q ) wrkbl = max( wrkbl, bdspac ) maxwrk = max( m*m+wrkbl, m*m+m*n+m ) - minwrk = max( 3*m+n, bdspac ) + minwrk = max( 3_${ik}$*m+n, bdspac ) else if( wntvs .and. wntun ) then ! path 4t(n much larger than m, jobu='n', jobvt='s') wrkbl = m + lwork_sgelqf wrkbl = max( wrkbl, m+lwork_sorglq_m ) - wrkbl = max( wrkbl, 3*m+lwork_sgebrd ) - wrkbl = max( wrkbl, 3*m+lwork_sorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*m+lwork_sgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*m+lwork_sorgbr_p ) wrkbl = max( wrkbl, bdspac ) maxwrk = m*m + wrkbl - minwrk = max( 3*m+n, bdspac ) + minwrk = max( 3_${ik}$*m+n, bdspac ) else if( wntvs .and. wntuo ) then ! path 5t(n much larger than m, jobu='o', jobvt='s') wrkbl = m + lwork_sgelqf wrkbl = max( wrkbl, m+lwork_sorglq_m ) - wrkbl = max( wrkbl, 3*m+lwork_sgebrd ) - wrkbl = max( wrkbl, 3*m+lwork_sorgbr_p ) - wrkbl = max( wrkbl, 3*m+lwork_sorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*m+lwork_sgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*m+lwork_sorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*m+lwork_sorgbr_q ) wrkbl = max( wrkbl, bdspac ) - maxwrk = 2*m*m + wrkbl - minwrk = max( 3*m+n, bdspac ) + maxwrk = 2_${ik}$*m*m + wrkbl + minwrk = max( 3_${ik}$*m+n, bdspac ) maxwrk = max( maxwrk, minwrk ) else if( wntvs .and. wntuas ) then ! path 6t(n much larger than m, jobu='s' or 'a', ! jobvt='s') wrkbl = m + lwork_sgelqf wrkbl = max( wrkbl, m+lwork_sorglq_m ) - wrkbl = max( wrkbl, 3*m+lwork_sgebrd ) - wrkbl = max( wrkbl, 3*m+lwork_sorgbr_p ) - wrkbl = max( wrkbl, 3*m+lwork_sorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*m+lwork_sgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*m+lwork_sorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*m+lwork_sorgbr_q ) wrkbl = max( wrkbl, bdspac ) maxwrk = m*m + wrkbl - minwrk = max( 3*m+n, bdspac ) + minwrk = max( 3_${ik}$*m+n, bdspac ) else if( wntva .and. wntun ) then ! path 7t(n much larger than m, jobu='n', jobvt='a') wrkbl = m + lwork_sgelqf wrkbl = max( wrkbl, m+lwork_sorglq_n ) - wrkbl = max( wrkbl, 3*m+lwork_sgebrd ) - wrkbl = max( wrkbl, 3*m+lwork_sorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*m+lwork_sgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*m+lwork_sorgbr_p ) wrkbl = max( wrkbl, bdspac ) maxwrk = m*m + wrkbl - minwrk = max( 3*m+n, bdspac ) + minwrk = max( 3_${ik}$*m+n, bdspac ) else if( wntva .and. wntuo ) then ! path 8t(n much larger than m, jobu='o', jobvt='a') wrkbl = m + lwork_sgelqf wrkbl = max( wrkbl, m+lwork_sorglq_n ) - wrkbl = max( wrkbl, 3*m+lwork_sgebrd ) - wrkbl = max( wrkbl, 3*m+lwork_sorgbr_p ) - wrkbl = max( wrkbl, 3*m+lwork_sorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*m+lwork_sgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*m+lwork_sorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*m+lwork_sorgbr_q ) wrkbl = max( wrkbl, bdspac ) - maxwrk = 2*m*m + wrkbl - minwrk = max( 3*m+n, bdspac ) + maxwrk = 2_${ik}$*m*m + wrkbl + minwrk = max( 3_${ik}$*m+n, bdspac ) else if( wntva .and. wntuas ) then ! path 9t(n much larger than m, jobu='s' or 'a', ! jobvt='a') wrkbl = m + lwork_sgelqf wrkbl = max( wrkbl, m+lwork_sorglq_n ) - wrkbl = max( wrkbl, 3*m+lwork_sgebrd ) - wrkbl = max( wrkbl, 3*m+lwork_sorgbr_p ) - wrkbl = max( wrkbl, 3*m+lwork_sorgbr_q ) + wrkbl = max( wrkbl, 3_${ik}$*m+lwork_sgebrd ) + wrkbl = max( wrkbl, 3_${ik}$*m+lwork_sorgbr_p ) + wrkbl = max( wrkbl, 3_${ik}$*m+lwork_sorgbr_q ) wrkbl = max( wrkbl, bdspac ) maxwrk = m*m + wrkbl - minwrk = max( 3*m+n, bdspac ) + minwrk = max( 3_${ik}$*m+n, bdspac ) end if else ! path 10t(n greater than m, but not much larger) - call stdlib_sgebrd( m, n, a, lda, s, dum(1), dum(1),dum(1), dum(1), -1, ierr ) + call stdlib${ii}$_sgebrd( m, n, a, lda, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, ierr ) - lwork_sgebrd = int( dum(1),KIND=ilp) - maxwrk = 3*m + lwork_sgebrd + lwork_sgebrd = int( dum(1_${ik}$),KIND=${ik}$) + maxwrk = 3_${ik}$*m + lwork_sgebrd if( wntvs .or. wntvo ) then - ! compute space needed for stdlib_sorgbr p - call stdlib_sorgbr( 'P', m, n, m, a, n, dum(1),dum(1), -1, ierr ) - lwork_sorgbr_p = int( dum(1),KIND=ilp) - maxwrk = max( maxwrk, 3*m+lwork_sorgbr_p ) + ! compute space needed for stdlib${ii}$_sorgbr p + call stdlib${ii}$_sorgbr( 'P', m, n, m, a, n, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_sorgbr_p = int( dum(1_${ik}$),KIND=${ik}$) + maxwrk = max( maxwrk, 3_${ik}$*m+lwork_sorgbr_p ) end if if( wntva ) then - call stdlib_sorgbr( 'P', n, n, m, a, n, dum(1),dum(1), -1, ierr ) - lwork_sorgbr_p = int( dum(1),KIND=ilp) - maxwrk = max( maxwrk, 3*m+lwork_sorgbr_p ) + call stdlib${ii}$_sorgbr( 'P', n, n, m, a, n, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, ierr ) + lwork_sorgbr_p = int( dum(1_${ik}$),KIND=${ik}$) + maxwrk = max( maxwrk, 3_${ik}$*m+lwork_sorgbr_p ) end if if( .not.wntun ) then - maxwrk = max( maxwrk, 3*m+lwork_sorgbr_q ) + maxwrk = max( maxwrk, 3_${ik}$*m+lwork_sorgbr_q ) end if maxwrk = max( maxwrk, bdspac ) - minwrk = max( 3*m+n, bdspac ) + minwrk = max( 3_${ik}$*m+n, bdspac ) end if end if maxwrk = max( maxwrk, minwrk ) - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk if( lworkzero .and. anrmbignum ) then - iscl = 1 - call stdlib_slascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, ierr ) + iscl = 1_${ik}$ + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, ierr ) end if if( m>=n ) then ! a has at least as many rows as columns. if a has sufficiently @@ -73920,29 +73922,29 @@ module stdlib_linalg_lapack_s if( wntun ) then ! path 1 (m much larger than n, jobu='n') ! no left singular vectors to be computed - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r ! (workspace: need 2*n, prefer n+n*nb) - call stdlib_sgeqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & + call stdlib${ii}$_sgeqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & ierr ) ! zero out below r - if( n > 1 ) then - call stdlib_slaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ),lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_slaset( 'L', n-1, n-1, zero, zero, a( 2_${ik}$, 1_${ik}$ ),lda ) end if - ie = 1 + ie = 1_${ik}$ itauq = ie + n itaup = itauq + n iwork = itaup + n ! bidiagonalize r in a ! (workspace: need 4*n, prefer 3*n+2*n*nb) - call stdlib_sgebrd( n, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_sgebrd( n, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,ierr ) - ncvt = 0 + ncvt = 0_${ik}$ if( wntvo .or. wntvas ) then ! if right singular vectors desired, generate p'. ! (workspace: need 4*n-1, prefer 3*n+(n-1)*nb) - call stdlib_sorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & + call stdlib${ii}$_sorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) ncvt = n end if @@ -73950,17 +73952,17 @@ module stdlib_linalg_lapack_s ! perform bidiagonal qr iteration, computing right ! singular vectors of a in a if desired ! (workspace: need bdspac) - call stdlib_sbdsqr( 'U', n, ncvt, 0, 0, s, work( ie ), a, lda,dum, 1, dum, 1, & + call stdlib${ii}$_sbdsqr( 'U', n, ncvt, 0_${ik}$, 0_${ik}$, s, work( ie ), a, lda,dum, 1_${ik}$, dum, 1_${ik}$, & work( iwork ), info ) ! if right singular vectors desired in vt, copy them there - if( wntvas )call stdlib_slacpy( 'F', n, n, a, lda, vt, ldvt ) + if( wntvas )call stdlib${ii}$_slacpy( 'F', n, n, a, lda, vt, ldvt ) else if( wntuo .and. wntvn ) then ! path 2 (m much larger than n, jobu='o', jobvt='n') ! n left singular vectors to be overwritten on a and ! no right singular vectors to be computed - if( lwork>=n*n+max( 4*n, bdspac ) ) then + if( lwork>=n*n+max( 4_${ik}$*n, bdspac ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=max( wrkbl, lda*n+n )+lda*n ) then ! work(iu) is lda by n, work(ir) is lda by n ldwrku = lda @@ -73978,15 +73980,15 @@ module stdlib_linalg_lapack_s iwork = itau + n ! compute a=q*r ! (workspace: need n*n+2*n, prefer n*n+n+n*nb) - call stdlib_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy r to work(ir) and zero out below it - call stdlib_slacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) - call stdlib_slaset( 'L', n-1, n-1, zero, zero, work( ir+1 ),ldwrkr ) + call stdlib${ii}$_slacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) + call stdlib${ii}$_slaset( 'L', n-1, n-1, zero, zero, work( ir+1 ),ldwrkr ) ! generate q in a ! (workspace: need n*n+2*n, prefer n*n+n+n*nb) - call stdlib_sorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -73994,57 +73996,57 @@ module stdlib_linalg_lapack_s iwork = itaup + n ! bidiagonalize r in work(ir) ! (workspace: need n*n+4*n, prefer n*n+3*n+2*n*nb) - call stdlib_sgebrd( n, n, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & + call stdlib${ii}$_sgebrd( n, n, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & work( itaup ),work( iwork ), lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing r ! (workspace: need n*n+4*n, prefer n*n+3*n+n*nb) - call stdlib_sorgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & + call stdlib${ii}$_sorgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) ! (workspace: need n*n+bdspac) - call stdlib_sbdsqr( 'U', n, 0, n, 0, s, work( ie ), dum, 1,work( ir ), & - ldwrkr, dum, 1,work( iwork ), info ) + call stdlib${ii}$_sbdsqr( 'U', n, 0_${ik}$, n, 0_${ik}$, s, work( ie ), dum, 1_${ik}$,work( ir ), & + ldwrkr, dum, 1_${ik}$,work( iwork ), info ) iu = ie + n ! multiply q in a by left singular vectors of r in ! work(ir), storing result in work(iu) and copying to a ! (workspace: need n*n+2*n, prefer n*n+m*n+n) do i = 1, m, ldwrku chunk = min( m-i+1, ldwrku ) - call stdlib_sgemm( 'N', 'N', chunk, n, n, one, a( i, 1 ),lda, work( ir )& + call stdlib${ii}$_sgemm( 'N', 'N', chunk, n, n, one, a( i, 1_${ik}$ ),lda, work( ir )& , ldwrkr, zero,work( iu ), ldwrku ) - call stdlib_slacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) + call stdlib${ii}$_slacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1_${ik}$ ), lda ) end do else ! insufficient workspace for a fast algorithm - ie = 1 + ie = 1_${ik}$ itauq = ie + n itaup = itauq + n iwork = itaup + n ! bidiagonalize a ! (workspace: need 3*n+m, prefer 3*n+(m+n)*nb) - call stdlib_sgebrd( m, n, a, lda, s, work( ie ),work( itauq ), work( itaup & + call stdlib${ii}$_sgebrd( m, n, a, lda, s, work( ie ),work( itauq ), work( itaup & ),work( iwork ), lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing a ! (workspace: need 4*n, prefer 3*n+n*nb) - call stdlib_sorgbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), & + call stdlib${ii}$_sorgbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in a ! (workspace: need bdspac) - call stdlib_sbdsqr( 'U', n, 0, m, 0, s, work( ie ), dum, 1,a, lda, dum, 1, & + call stdlib${ii}$_sbdsqr( 'U', n, 0_${ik}$, m, 0_${ik}$, s, work( ie ), dum, 1_${ik}$,a, lda, dum, 1_${ik}$, & work( iwork ), info ) end if else if( wntuo .and. wntvas ) then ! path 3 (m much larger than n, jobu='o', jobvt='s' or 'a') ! n left singular vectors to be overwritten on a and ! n right singular vectors to be computed in vt - if( lwork>=n*n+max( 4*n, bdspac ) ) then + if( lwork>=n*n+max( 4_${ik}$*n, bdspac ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=max( wrkbl, lda*n+n )+lda*n ) then ! work(iu) is lda by n and work(ir) is lda by n ldwrku = lda @@ -74062,15 +74064,15 @@ module stdlib_linalg_lapack_s iwork = itau + n ! compute a=q*r ! (workspace: need n*n+2*n, prefer n*n+n+n*nb) - call stdlib_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy r to vt, zeroing out below it - call stdlib_slacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_slaset( 'L', n-1, n-1, zero, zero,vt( 2, 1 ), ldvt ) + call stdlib${ii}$_slacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1_${ik}$ )call stdlib${ii}$_slaset( 'L', n-1, n-1, zero, zero,vt( 2_${ik}$, 1_${ik}$ ), ldvt ) ! generate q in a ! (workspace: need n*n+2*n, prefer n*n+n+n*nb) - call stdlib_sorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -74078,50 +74080,50 @@ module stdlib_linalg_lapack_s iwork = itaup + n ! bidiagonalize r in vt, copying result to work(ir) ! (workspace: need n*n+4*n, prefer n*n+3*n+2*n*nb) - call stdlib_sgebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_sgebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) - call stdlib_slacpy( 'L', n, n, vt, ldvt, work( ir ), ldwrkr ) + call stdlib${ii}$_slacpy( 'L', n, n, vt, ldvt, work( ir ), ldwrkr ) ! generate left vectors bidiagonalizing r in work(ir) ! (workspace: need n*n+4*n, prefer n*n+3*n+n*nb) - call stdlib_sorgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & + call stdlib${ii}$_sorgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing r in vt ! (workspace: need n*n+4*n-1, prefer n*n+3*n+(n-1)*nb) - call stdlib_sorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib${ii}$_sorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) and computing right ! singular vectors of r in vt ! (workspace: need n*n+bdspac) - call stdlib_sbdsqr( 'U', n, n, n, 0, s, work( ie ), vt, ldvt,work( ir ), & - ldwrkr, dum, 1,work( iwork ), info ) + call stdlib${ii}$_sbdsqr( 'U', n, n, n, 0_${ik}$, s, work( ie ), vt, ldvt,work( ir ), & + ldwrkr, dum, 1_${ik}$,work( iwork ), info ) iu = ie + n ! multiply q in a by left singular vectors of r in ! work(ir), storing result in work(iu) and copying to a ! (workspace: need n*n+2*n, prefer n*n+m*n+n) do i = 1, m, ldwrku chunk = min( m-i+1, ldwrku ) - call stdlib_sgemm( 'N', 'N', chunk, n, n, one, a( i, 1 ),lda, work( ir )& + call stdlib${ii}$_sgemm( 'N', 'N', chunk, n, n, one, a( i, 1_${ik}$ ),lda, work( ir )& , ldwrkr, zero,work( iu ), ldwrku ) - call stdlib_slacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) + call stdlib${ii}$_slacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1_${ik}$ ), lda ) end do else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r ! (workspace: need 2*n, prefer n+n*nb) - call stdlib_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy r to vt, zeroing out below it - call stdlib_slacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_slaset( 'L', n-1, n-1, zero, zero,vt( 2, 1 ), ldvt ) + call stdlib${ii}$_slacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1_${ik}$ )call stdlib${ii}$_slaset( 'L', n-1, n-1, zero, zero,vt( 2_${ik}$, 1_${ik}$ ), ldvt ) ! generate q in a ! (workspace: need 2*n, prefer n+n*nb) - call stdlib_sorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -74129,32 +74131,32 @@ module stdlib_linalg_lapack_s iwork = itaup + n ! bidiagonalize r in vt ! (workspace: need 4*n, prefer 3*n+2*n*nb) - call stdlib_sgebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_sgebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in a by left vectors bidiagonalizing r ! (workspace: need 3*n+m, prefer 3*n+m*nb) - call stdlib_sormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), a, lda,& + call stdlib${ii}$_sormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), a, lda,& work( iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing r in vt ! (workspace: need 4*n-1, prefer 3*n+(n-1)*nb) - call stdlib_sorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib${ii}$_sorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in a and computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_sbdsqr( 'U', n, n, m, 0, s, work( ie ), vt, ldvt,a, lda, dum, & - 1, work( iwork ), info ) + call stdlib${ii}$_sbdsqr( 'U', n, n, m, 0_${ik}$, s, work( ie ), vt, ldvt,a, lda, dum, & + 1_${ik}$, work( iwork ), info ) end if else if( wntus ) then if( wntvn ) then ! path 4 (m much larger than n, jobu='s', jobvt='n') ! n left singular vectors to be computed in u and ! no right singular vectors to be computed - if( lwork>=n*n+max( 4*n, bdspac ) ) then + if( lwork>=n*n+max( 4_${ik}$*n, bdspac ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=wrkbl+lda*n ) then ! work(ir) is lda by n ldwrkr = lda @@ -74166,15 +74168,15 @@ module stdlib_linalg_lapack_s iwork = itau + n ! compute a=q*r ! (workspace: need n*n+2*n, prefer n*n+n+n*nb) - call stdlib_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(ir), zeroing out below it - call stdlib_slacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) - call stdlib_slaset( 'L', n-1, n-1, zero, zero,work( ir+1 ), ldwrkr ) + call stdlib${ii}$_slacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) + call stdlib${ii}$_slaset( 'L', n-1, n-1, zero, zero,work( ir+1 ), ldwrkr ) ! generate q in a ! (workspace: need n*n+2*n, prefer n*n+n+n*nb) - call stdlib_sorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -74182,67 +74184,67 @@ module stdlib_linalg_lapack_s iwork = itaup + n ! bidiagonalize r in work(ir) ! (workspace: need n*n+4*n, prefer n*n+3*n+2*n*nb) - call stdlib_sgebrd( n, n, work( ir ), ldwrkr, s,work( ie ), work( itauq & + call stdlib${ii}$_sgebrd( n, n, work( ir ), ldwrkr, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing r in work(ir) ! (workspace: need n*n+4*n, prefer n*n+3*n+n*nb) - call stdlib_sorgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_sorgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) ! (workspace: need n*n+bdspac) - call stdlib_sbdsqr( 'U', n, 0, n, 0, s, work( ie ), dum,1, work( ir ), & - ldwrkr, dum, 1,work( iwork ), info ) + call stdlib${ii}$_sbdsqr( 'U', n, 0_${ik}$, n, 0_${ik}$, s, work( ie ), dum,1_${ik}$, work( ir ), & + ldwrkr, dum, 1_${ik}$,work( iwork ), info ) ! multiply q in a by left singular vectors of r in ! work(ir), storing result in u ! (workspace: need n*n) - call stdlib_sgemm( 'N', 'N', m, n, n, one, a, lda,work( ir ), ldwrkr, & + call stdlib${ii}$_sgemm( 'N', 'N', m, n, n, one, a, lda,work( ir ), ldwrkr, & zero, u, ldu ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n, prefer n+n*nb) - call stdlib_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_slacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_slacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need 2*n, prefer n+n*nb) - call stdlib_sorgqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sorgqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! zero out below r in a - if( n > 1 ) then - call stdlib_slaset( 'L', n-1, n-1, zero, zero,a( 2, 1 ), lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_slaset( 'L', n-1, n-1, zero, zero,a( 2_${ik}$, 1_${ik}$ ), lda ) end if ! bidiagonalize r in a ! (workspace: need 4*n, prefer 3*n+2*n*nb) - call stdlib_sgebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_sgebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left vectors bidiagonalizing r ! (workspace: need 3*n+m, prefer 3*n+m*nb) - call stdlib_sormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib${ii}$_sormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u ! (workspace: need bdspac) - call stdlib_sbdsqr( 'U', n, 0, m, 0, s, work( ie ), dum,1, u, ldu, dum, & - 1, work( iwork ),info ) + call stdlib${ii}$_sbdsqr( 'U', n, 0_${ik}$, m, 0_${ik}$, s, work( ie ), dum,1_${ik}$, u, ldu, dum, & + 1_${ik}$, work( iwork ),info ) end if else if( wntvo ) then ! path 5 (m much larger than n, jobu='s', jobvt='o') ! n left singular vectors to be computed in u and ! n right singular vectors to be overwritten on a - if( lwork>=2*n*n+max( 4*n, bdspac ) ) then + if( lwork>=2_${ik}$*n*n+max( 4_${ik}$*n, bdspac ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+2*lda*n ) then ! work(iu) is lda by n and work(ir) is lda by n ldwrku = lda @@ -74263,15 +74265,15 @@ module stdlib_linalg_lapack_s iwork = itau + n ! compute a=q*r ! (workspace: need 2*n*n+2*n, prefer 2*n*n+n+n*nb) - call stdlib_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_slacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_slaset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) + call stdlib${ii}$_slacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_slaset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) ! generate q in a ! (workspace: need 2*n*n+2*n, prefer 2*n*n+n+n*nb) - call stdlib_sorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -74281,84 +74283,84 @@ module stdlib_linalg_lapack_s ! work(ir) ! (workspace: need 2*n*n+4*n, ! prefer 2*n*n+3*n+2*n*nb) - call stdlib_sgebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib${ii}$_sgebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_slacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib${ii}$_slacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate left bidiagonalizing vectors in work(iu) ! (workspace: need 2*n*n+4*n, prefer 2*n*n+3*n+n*nb) - call stdlib_sorgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib${ii}$_sorgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in work(ir) ! (workspace: need 2*n*n+4*n-1, ! prefer 2*n*n+3*n+(n-1)*nb) - call stdlib_sorgbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_sorgbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(iu) and computing ! right singular vectors of r in work(ir) ! (workspace: need 2*n*n+bdspac) - call stdlib_sbdsqr( 'U', n, n, n, 0, s, work( ie ),work( ir ), ldwrkr, & - work( iu ),ldwrku, dum, 1, work( iwork ), info ) + call stdlib${ii}$_sbdsqr( 'U', n, n, n, 0_${ik}$, s, work( ie ),work( ir ), ldwrkr, & + work( iu ),ldwrku, dum, 1_${ik}$, work( iwork ), info ) ! multiply q in a by left singular vectors of r in ! work(iu), storing result in u ! (workspace: need n*n) - call stdlib_sgemm( 'N', 'N', m, n, n, one, a, lda,work( iu ), ldwrku, & + call stdlib${ii}$_sgemm( 'N', 'N', m, n, n, one, a, lda,work( iu ), ldwrku, & zero, u, ldu ) ! copy right singular vectors of r to a ! (workspace: need n*n) - call stdlib_slacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) + call stdlib${ii}$_slacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n, prefer n+n*nb) - call stdlib_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_slacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_slacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need 2*n, prefer n+n*nb) - call stdlib_sorgqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sorgqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! zero out below r in a - if( n > 1 ) then - call stdlib_slaset( 'L', n-1, n-1, zero, zero,a( 2, 1 ), lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_slaset( 'L', n-1, n-1, zero, zero,a( 2_${ik}$, 1_${ik}$ ), lda ) end if ! bidiagonalize r in a ! (workspace: need 4*n, prefer 3*n+2*n*nb) - call stdlib_sgebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_sgebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left vectors bidiagonalizing r ! (workspace: need 3*n+m, prefer 3*n+m*nb) - call stdlib_sormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib${ii}$_sormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing r in a ! (workspace: need 4*n-1, prefer 3*n+(n-1)*nb) - call stdlib_sorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & + call stdlib${ii}$_sorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in a ! (workspace: need bdspac) - call stdlib_sbdsqr( 'U', n, n, m, 0, s, work( ie ), a,lda, u, ldu, dum, & - 1, work( iwork ),info ) + call stdlib${ii}$_sbdsqr( 'U', n, n, m, 0_${ik}$, s, work( ie ), a,lda, u, ldu, dum, & + 1_${ik}$, work( iwork ),info ) end if else if( wntvas ) then ! path 6 (m much larger than n, jobu='s', jobvt='s' ! or 'a') ! n left singular vectors to be computed in u and ! n right singular vectors to be computed in vt - if( lwork>=n*n+max( 4*n, bdspac ) ) then + if( lwork>=n*n+max( 4_${ik}$*n, bdspac ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+lda*n ) then ! work(iu) is lda by n ldwrku = lda @@ -74370,15 +74372,15 @@ module stdlib_linalg_lapack_s iwork = itau + n ! compute a=q*r ! (workspace: need n*n+2*n, prefer n*n+n+n*nb) - call stdlib_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_slacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_slaset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) + call stdlib${ii}$_slacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_slaset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) ! generate q in a ! (workspace: need n*n+2*n, prefer n*n+n+n*nb) - call stdlib_sorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sorgqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -74386,46 +74388,46 @@ module stdlib_linalg_lapack_s iwork = itaup + n ! bidiagonalize r in work(iu), copying result to vt ! (workspace: need n*n+4*n, prefer n*n+3*n+2*n*nb) - call stdlib_sgebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib${ii}$_sgebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_slacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) + call stdlib${ii}$_slacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) ! generate left bidiagonalizing vectors in work(iu) ! (workspace: need n*n+4*n, prefer n*n+3*n+n*nb) - call stdlib_sorgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib${ii}$_sorgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (workspace: need n*n+4*n-1, ! prefer n*n+3*n+(n-1)*nb) - call stdlib_sorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib${ii}$_sorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(iu) and computing ! right singular vectors of r in vt ! (workspace: need n*n+bdspac) - call stdlib_sbdsqr( 'U', n, n, n, 0, s, work( ie ), vt,ldvt, work( iu ),& - ldwrku, dum, 1,work( iwork ), info ) + call stdlib${ii}$_sbdsqr( 'U', n, n, n, 0_${ik}$, s, work( ie ), vt,ldvt, work( iu ),& + ldwrku, dum, 1_${ik}$,work( iwork ), info ) ! multiply q in a by left singular vectors of r in ! work(iu), storing result in u ! (workspace: need n*n) - call stdlib_sgemm( 'N', 'N', m, n, n, one, a, lda,work( iu ), ldwrku, & + call stdlib${ii}$_sgemm( 'N', 'N', m, n, n, one, a, lda,work( iu ), ldwrku, & zero, u, ldu ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n, prefer n+n*nb) - call stdlib_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_slacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_slacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need 2*n, prefer n+n*nb) - call stdlib_sorgqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sorgqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to vt, zeroing out below it - call stdlib_slacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_slaset( 'L', n-1, n-1, zero, zero,vt( 2, 1 ), ldvt & + call stdlib${ii}$_slacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1_${ik}$ )call stdlib${ii}$_slaset( 'L', n-1, n-1, zero, zero,vt( 2_${ik}$, 1_${ik}$ ), ldvt & ) ie = itau itauq = ie + n @@ -74433,24 +74435,24 @@ module stdlib_linalg_lapack_s iwork = itaup + n ! bidiagonalize r in vt ! (workspace: need 4*n, prefer 3*n+2*n*nb) - call stdlib_sgebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_sgebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in vt ! (workspace: need 3*n+m, prefer 3*n+m*nb) - call stdlib_sormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & + call stdlib${ii}$_sormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (workspace: need 4*n-1, prefer 3*n+(n-1)*nb) - call stdlib_sorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib${ii}$_sorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_sbdsqr( 'U', n, n, m, 0, s, work( ie ), vt,ldvt, u, ldu, & - dum, 1, work( iwork ),info ) + call stdlib${ii}$_sbdsqr( 'U', n, n, m, 0_${ik}$, s, work( ie ), vt,ldvt, u, ldu, & + dum, 1_${ik}$, work( iwork ),info ) end if end if else if( wntua ) then @@ -74458,9 +74460,9 @@ module stdlib_linalg_lapack_s ! path 7 (m much larger than n, jobu='a', jobvt='n') ! m left singular vectors to be computed in u and ! no right singular vectors to be computed - if( lwork>=n*n+max( n+m, 4*n, bdspac ) ) then + if( lwork>=n*n+max( n+m, 4_${ik}$*n, bdspac ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=wrkbl+lda*n ) then ! work(ir) is lda by n ldwrkr = lda @@ -74472,16 +74474,16 @@ module stdlib_linalg_lapack_s iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need n*n+2*n, prefer n*n+n+n*nb) - call stdlib_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_slacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_slacpy( 'L', m, n, a, lda, u, ldu ) ! copy r to work(ir), zeroing out below it - call stdlib_slacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) - call stdlib_slaset( 'L', n-1, n-1, zero, zero,work( ir+1 ), ldwrkr ) + call stdlib${ii}$_slacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) + call stdlib${ii}$_slaset( 'L', n-1, n-1, zero, zero,work( ir+1 ), ldwrkr ) ! generate q in u ! (workspace: need n*n+n+m, prefer n*n+n+m*nb) - call stdlib_sorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n @@ -74489,70 +74491,70 @@ module stdlib_linalg_lapack_s iwork = itaup + n ! bidiagonalize r in work(ir) ! (workspace: need n*n+4*n, prefer n*n+3*n+2*n*nb) - call stdlib_sgebrd( n, n, work( ir ), ldwrkr, s,work( ie ), work( itauq & + call stdlib${ii}$_sgebrd( n, n, work( ir ), ldwrkr, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in work(ir) ! (workspace: need n*n+4*n, prefer n*n+3*n+n*nb) - call stdlib_sorgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_sorgbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) ! (workspace: need n*n+bdspac) - call stdlib_sbdsqr( 'U', n, 0, n, 0, s, work( ie ), dum,1, work( ir ), & - ldwrkr, dum, 1,work( iwork ), info ) + call stdlib${ii}$_sbdsqr( 'U', n, 0_${ik}$, n, 0_${ik}$, s, work( ie ), dum,1_${ik}$, work( ir ), & + ldwrkr, dum, 1_${ik}$,work( iwork ), info ) ! multiply q in u by left singular vectors of r in ! work(ir), storing result in a ! (workspace: need n*n) - call stdlib_sgemm( 'N', 'N', m, n, n, one, u, ldu,work( ir ), ldwrkr, & + call stdlib${ii}$_sgemm( 'N', 'N', m, n, n, one, u, ldu,work( ir ), ldwrkr, & zero, a, lda ) ! copy left singular vectors of a from a to u - call stdlib_slacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_slacpy( 'F', m, n, a, lda, u, ldu ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n, prefer n+n*nb) - call stdlib_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_slacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_slacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need n+m, prefer n+m*nb) - call stdlib_sorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! zero out below r in a - if( n > 1 ) then - call stdlib_slaset( 'L', n-1, n-1, zero, zero,a( 2, 1 ), lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_slaset( 'L', n-1, n-1, zero, zero,a( 2_${ik}$, 1_${ik}$ ), lda ) end if ! bidiagonalize r in a ! (workspace: need 4*n, prefer 3*n+2*n*nb) - call stdlib_sgebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_sgebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in a ! (workspace: need 3*n+m, prefer 3*n+m*nb) - call stdlib_sormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib${ii}$_sormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u ! (workspace: need bdspac) - call stdlib_sbdsqr( 'U', n, 0, m, 0, s, work( ie ), dum,1, u, ldu, dum, & - 1, work( iwork ),info ) + call stdlib${ii}$_sbdsqr( 'U', n, 0_${ik}$, m, 0_${ik}$, s, work( ie ), dum,1_${ik}$, u, ldu, dum, & + 1_${ik}$, work( iwork ),info ) end if else if( wntvo ) then ! path 8 (m much larger than n, jobu='a', jobvt='o') ! m left singular vectors to be computed in u and ! n right singular vectors to be overwritten on a - if( lwork>=2*n*n+max( n+m, 4*n, bdspac ) ) then + if( lwork>=2_${ik}$*n*n+max( n+m, 4_${ik}$*n, bdspac ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+2*lda*n ) then ! work(iu) is lda by n and work(ir) is lda by n ldwrku = lda @@ -74573,16 +74575,16 @@ module stdlib_linalg_lapack_s iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n*n+2*n, prefer 2*n*n+n+n*nb) - call stdlib_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_slacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_slacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need 2*n*n+n+m, prefer 2*n*n+n+m*nb) - call stdlib_sorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_slacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_slaset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) + call stdlib${ii}$_slacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_slaset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) ie = itau itauq = ie + n @@ -74592,86 +74594,86 @@ module stdlib_linalg_lapack_s ! work(ir) ! (workspace: need 2*n*n+4*n, ! prefer 2*n*n+3*n+2*n*nb) - call stdlib_sgebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib${ii}$_sgebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_slacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib${ii}$_slacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate left bidiagonalizing vectors in work(iu) ! (workspace: need 2*n*n+4*n, prefer 2*n*n+3*n+n*nb) - call stdlib_sorgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib${ii}$_sorgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in work(ir) ! (workspace: need 2*n*n+4*n-1, ! prefer 2*n*n+3*n+(n-1)*nb) - call stdlib_sorgbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_sorgbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(iu) and computing ! right singular vectors of r in work(ir) ! (workspace: need 2*n*n+bdspac) - call stdlib_sbdsqr( 'U', n, n, n, 0, s, work( ie ),work( ir ), ldwrkr, & - work( iu ),ldwrku, dum, 1, work( iwork ), info ) + call stdlib${ii}$_sbdsqr( 'U', n, n, n, 0_${ik}$, s, work( ie ),work( ir ), ldwrkr, & + work( iu ),ldwrku, dum, 1_${ik}$, work( iwork ), info ) ! multiply q in u by left singular vectors of r in ! work(iu), storing result in a ! (workspace: need n*n) - call stdlib_sgemm( 'N', 'N', m, n, n, one, u, ldu,work( iu ), ldwrku, & + call stdlib${ii}$_sgemm( 'N', 'N', m, n, n, one, u, ldu,work( iu ), ldwrku, & zero, a, lda ) ! copy left singular vectors of a from a to u - call stdlib_slacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_slacpy( 'F', m, n, a, lda, u, ldu ) ! copy right singular vectors of r from work(ir) to a - call stdlib_slacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) + call stdlib${ii}$_slacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n, prefer n+n*nb) - call stdlib_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_slacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_slacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need n+m, prefer n+m*nb) - call stdlib_sorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! zero out below r in a - if( n > 1 ) then - call stdlib_slaset( 'L', n-1, n-1, zero, zero,a( 2, 1 ), lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_slaset( 'L', n-1, n-1, zero, zero,a( 2_${ik}$, 1_${ik}$ ), lda ) end if ! bidiagonalize r in a ! (workspace: need 4*n, prefer 3*n+2*n*nb) - call stdlib_sgebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_sgebrd( n, n, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in a ! (workspace: need 3*n+m, prefer 3*n+m*nb) - call stdlib_sormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib${ii}$_sormbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in a ! (workspace: need 4*n-1, prefer 3*n+(n-1)*nb) - call stdlib_sorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & + call stdlib${ii}$_sorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in a ! (workspace: need bdspac) - call stdlib_sbdsqr( 'U', n, n, m, 0, s, work( ie ), a,lda, u, ldu, dum, & - 1, work( iwork ),info ) + call stdlib${ii}$_sbdsqr( 'U', n, n, m, 0_${ik}$, s, work( ie ), a,lda, u, ldu, dum, & + 1_${ik}$, work( iwork ),info ) end if else if( wntvas ) then ! path 9 (m much larger than n, jobu='a', jobvt='s' ! or 'a') ! m left singular vectors to be computed in u and ! n right singular vectors to be computed in vt - if( lwork>=n*n+max( n+m, 4*n, bdspac ) ) then + if( lwork>=n*n+max( n+m, 4_${ik}$*n, bdspac ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+lda*n ) then ! work(iu) is lda by n ldwrku = lda @@ -74683,16 +74685,16 @@ module stdlib_linalg_lapack_s iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need n*n+2*n, prefer n*n+n+n*nb) - call stdlib_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_slacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_slacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need n*n+n+m, prefer n*n+n+m*nb) - call stdlib_sorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_slacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_slaset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) + call stdlib${ii}$_slacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_slaset( 'L', n-1, n-1, zero, zero,work( iu+1 ), ldwrku ) ie = itau itauq = ie + n @@ -74700,48 +74702,48 @@ module stdlib_linalg_lapack_s iwork = itaup + n ! bidiagonalize r in work(iu), copying result to vt ! (workspace: need n*n+4*n, prefer n*n+3*n+2*n*nb) - call stdlib_sgebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib${ii}$_sgebrd( n, n, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_slacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) + call stdlib${ii}$_slacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) ! generate left bidiagonalizing vectors in work(iu) ! (workspace: need n*n+4*n, prefer n*n+3*n+n*nb) - call stdlib_sorgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib${ii}$_sorgbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (workspace: need n*n+4*n-1, ! prefer n*n+3*n+(n-1)*nb) - call stdlib_sorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib${ii}$_sorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(iu) and computing ! right singular vectors of r in vt ! (workspace: need n*n+bdspac) - call stdlib_sbdsqr( 'U', n, n, n, 0, s, work( ie ), vt,ldvt, work( iu ),& - ldwrku, dum, 1,work( iwork ), info ) + call stdlib${ii}$_sbdsqr( 'U', n, n, n, 0_${ik}$, s, work( ie ), vt,ldvt, work( iu ),& + ldwrku, dum, 1_${ik}$,work( iwork ), info ) ! multiply q in u by left singular vectors of r in ! work(iu), storing result in a ! (workspace: need n*n) - call stdlib_sgemm( 'N', 'N', m, n, n, one, u, ldu,work( iu ), ldwrku, & + call stdlib${ii}$_sgemm( 'N', 'N', m, n, n, one, u, ldu,work( iu ), ldwrku, & zero, a, lda ) ! copy left singular vectors of a from a to u - call stdlib_slacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_slacpy( 'F', m, n, a, lda, u, ldu ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (workspace: need 2*n, prefer n+n*nb) - call stdlib_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_slacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_slacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (workspace: need n+m, prefer n+m*nb) - call stdlib_sorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sorgqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r from a to vt, zeroing out below it - call stdlib_slacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_slaset( 'L', n-1, n-1, zero, zero,vt( 2, 1 ), ldvt & + call stdlib${ii}$_slacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1_${ik}$ )call stdlib${ii}$_slaset( 'L', n-1, n-1, zero, zero,vt( 2_${ik}$, 1_${ik}$ ), ldvt & ) ie = itau itauq = ie + n @@ -74749,24 +74751,24 @@ module stdlib_linalg_lapack_s iwork = itaup + n ! bidiagonalize r in vt ! (workspace: need 4*n, prefer 3*n+2*n*nb) - call stdlib_sgebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_sgebrd( n, n, vt, ldvt, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in vt ! (workspace: need 3*n+m, prefer 3*n+m*nb) - call stdlib_sormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & + call stdlib${ii}$_sormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (workspace: need 4*n-1, prefer 3*n+(n-1)*nb) - call stdlib_sorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib${ii}$_sorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) iwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_sbdsqr( 'U', n, n, m, 0, s, work( ie ), vt,ldvt, u, ldu, & - dum, 1, work( iwork ),info ) + call stdlib${ii}$_sbdsqr( 'U', n, n, m, 0_${ik}$, s, work( ie ), vt,ldvt, u, ldu, & + dum, 1_${ik}$, work( iwork ),info ) end if end if end if @@ -74774,72 +74776,72 @@ module stdlib_linalg_lapack_s ! m < mnthr ! path 10 (m at least n, but not much larger) ! reduce to bidiagonal form without qr decomposition - ie = 1 + ie = 1_${ik}$ itauq = ie + n itaup = itauq + n iwork = itaup + n ! bidiagonalize a ! (workspace: need 3*n+m, prefer 3*n+(m+n)*nb) - call stdlib_sgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_sgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,ierr ) if( wntuas ) then ! if left singular vectors desired in u, copy result to u ! and generate left bidiagonalizing vectors in u ! (workspace: need 3*n+ncu, prefer 3*n+ncu*nb) - call stdlib_slacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_slacpy( 'L', m, n, a, lda, u, ldu ) if( wntus )ncu = n if( wntua )ncu = m - call stdlib_sorgbr( 'Q', m, ncu, n, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_sorgbr( 'Q', m, ncu, n, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) end if if( wntvas ) then ! if right singular vectors desired in vt, copy result to ! vt and generate right bidiagonalizing vectors in vt ! (workspace: need 4*n-1, prefer 3*n+(n-1)*nb) - call stdlib_slacpy( 'U', n, n, a, lda, vt, ldvt ) - call stdlib_sorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib${ii}$_slacpy( 'U', n, n, a, lda, vt, ldvt ) + call stdlib${ii}$_sorgbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) end if if( wntuo ) then ! if left singular vectors desired in a, generate left ! bidiagonalizing vectors in a ! (workspace: need 4*n, prefer 3*n+n*nb) - call stdlib_sorgbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), lwork-& + call stdlib${ii}$_sorgbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), lwork-& iwork+1, ierr ) end if if( wntvo ) then ! if right singular vectors desired in a, generate right ! bidiagonalizing vectors in a ! (workspace: need 4*n-1, prefer 3*n+(n-1)*nb) - call stdlib_sorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-& + call stdlib${ii}$_sorgbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-& iwork+1, ierr ) end if iwork = ie + n if( wntuas .or. wntuo )nru = m - if( wntun )nru = 0 + if( wntun )nru = 0_${ik}$ if( wntvas .or. wntvo )ncvt = n - if( wntvn )ncvt = 0 + if( wntvn )ncvt = 0_${ik}$ if( ( .not.wntuo ) .and. ( .not.wntvo ) ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in vt ! (workspace: need bdspac) - call stdlib_sbdsqr( 'U', n, ncvt, nru, 0, s, work( ie ), vt,ldvt, u, ldu, dum,& - 1, work( iwork ), info ) + call stdlib${ii}$_sbdsqr( 'U', n, ncvt, nru, 0_${ik}$, s, work( ie ), vt,ldvt, u, ldu, dum,& + 1_${ik}$, work( iwork ), info ) else if( ( .not.wntuo ) .and. wntvo ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in a ! (workspace: need bdspac) - call stdlib_sbdsqr( 'U', n, ncvt, nru, 0, s, work( ie ), a, lda,u, ldu, dum, & - 1, work( iwork ), info ) + call stdlib${ii}$_sbdsqr( 'U', n, ncvt, nru, 0_${ik}$, s, work( ie ), a, lda,u, ldu, dum, & + 1_${ik}$, work( iwork ), info ) else ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in a and computing right singular ! vectors in vt ! (workspace: need bdspac) - call stdlib_sbdsqr( 'U', n, ncvt, nru, 0, s, work( ie ), vt,ldvt, a, lda, dum,& - 1, work( iwork ), info ) + call stdlib${ii}$_sbdsqr( 'U', n, ncvt, nru, 0_${ik}$, s, work( ie ), vt,ldvt, a, lda, dum,& + 1_${ik}$, work( iwork ), info ) end if end if else @@ -74850,45 +74852,45 @@ module stdlib_linalg_lapack_s if( wntvn ) then ! path 1t(n much larger than m, jobvt='n') ! no right singular vectors to be computed - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q ! (workspace: need 2*m, prefer m+m*nb) - call stdlib_sgelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & + call stdlib${ii}$_sgelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & ierr ) ! zero out above l - if (m>1) call stdlib_slaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ), lda ) - ie = 1 + if (m>1_${ik}$) call stdlib${ii}$_slaset( 'U', m-1, m-1, zero, zero, a( 1_${ik}$, 2_${ik}$ ), lda ) + ie = 1_${ik}$ itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize l in a ! (workspace: need 4*m, prefer 3*m+2*m*nb) - call stdlib_sgebrd( m, m, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_sgebrd( m, m, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,ierr ) if( wntuo .or. wntuas ) then ! if left singular vectors desired, generate q ! (workspace: need 4*m, prefer 3*m+m*nb) - call stdlib_sorgbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & + call stdlib${ii}$_sorgbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) end if iwork = ie + m - nru = 0 + nru = 0_${ik}$ if( wntuo .or. wntuas )nru = m ! perform bidiagonal qr iteration, computing left singular ! vectors of a in a if desired ! (workspace: need bdspac) - call stdlib_sbdsqr( 'U', m, 0, nru, 0, s, work( ie ), dum, 1, a,lda, dum, 1, & + call stdlib${ii}$_sbdsqr( 'U', m, 0_${ik}$, nru, 0_${ik}$, s, work( ie ), dum, 1_${ik}$, a,lda, dum, 1_${ik}$, & work( iwork ), info ) ! if left singular vectors desired in u, copy them there - if( wntuas )call stdlib_slacpy( 'F', m, m, a, lda, u, ldu ) + if( wntuas )call stdlib${ii}$_slacpy( 'F', m, m, a, lda, u, ldu ) else if( wntvo .and. wntun ) then ! path 2t(n much larger than m, jobu='n', jobvt='o') ! m right singular vectors to be overwritten on a and ! no left singular vectors to be computed - if( lwork>=m*m+max( 4*m, bdspac ) ) then + if( lwork>=m*m+max( 4_${ik}$*m, bdspac ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=max( wrkbl, lda*n+m )+lda*m ) then ! work(iu) is lda by n and work(ir) is lda by m ldwrku = lda @@ -74909,15 +74911,15 @@ module stdlib_linalg_lapack_s iwork = itau + m ! compute a=l*q ! (workspace: need m*m+2*m, prefer m*m+m+m*nb) - call stdlib_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy l to work(ir) and zero out above it - call stdlib_slacpy( 'L', m, m, a, lda, work( ir ), ldwrkr ) - call stdlib_slaset( 'U', m-1, m-1, zero, zero,work( ir+ldwrkr ), ldwrkr ) + call stdlib${ii}$_slacpy( 'L', m, m, a, lda, work( ir ), ldwrkr ) + call stdlib${ii}$_slaset( 'U', m-1, m-1, zero, zero,work( ir+ldwrkr ), ldwrkr ) ! generate q in a ! (workspace: need m*m+2*m, prefer m*m+m+m*nb) - call stdlib_sorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + m @@ -74925,57 +74927,57 @@ module stdlib_linalg_lapack_s iwork = itaup + m ! bidiagonalize l in work(ir) ! (workspace: need m*m+4*m, prefer m*m+3*m+2*m*nb) - call stdlib_sgebrd( m, m, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & + call stdlib${ii}$_sgebrd( m, m, work( ir ), ldwrkr, s, work( ie ),work( itauq ), & work( itaup ),work( iwork ), lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing l ! (workspace: need m*m+4*m-1, prefer m*m+3*m+(m-1)*nb) - call stdlib_sorgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & + call stdlib${ii}$_sorgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & iwork ),lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of l in work(ir) ! (workspace: need m*m+bdspac) - call stdlib_sbdsqr( 'U', m, m, 0, 0, s, work( ie ),work( ir ), ldwrkr, dum,& - 1, dum, 1,work( iwork ), info ) + call stdlib${ii}$_sbdsqr( 'U', m, m, 0_${ik}$, 0_${ik}$, s, work( ie ),work( ir ), ldwrkr, dum,& + 1_${ik}$, dum, 1_${ik}$,work( iwork ), info ) iu = ie + m ! multiply right singular vectors of l in work(ir) by q ! in a, storing result in work(iu) and copying to a ! (workspace: need m*m+2*m, prefer m*m+m*n+m) do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_sgemm( 'N', 'N', m, blk, m, one, work( ir ),ldwrkr, a( 1, i & + call stdlib${ii}$_sgemm( 'N', 'N', m, blk, m, one, work( ir ),ldwrkr, a( 1_${ik}$, i & ), lda, zero,work( iu ), ldwrku ) - call stdlib_slacpy( 'F', m, blk, work( iu ), ldwrku,a( 1, i ), lda ) + call stdlib${ii}$_slacpy( 'F', m, blk, work( iu ), ldwrku,a( 1_${ik}$, i ), lda ) end do else ! insufficient workspace for a fast algorithm - ie = 1 + ie = 1_${ik}$ itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize a ! (workspace: need 3*m+n, prefer 3*m+(m+n)*nb) - call stdlib_sgebrd( m, n, a, lda, s, work( ie ),work( itauq ), work( itaup & + call stdlib${ii}$_sgebrd( m, n, a, lda, s, work( ie ),work( itauq ), work( itaup & ),work( iwork ), lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing a ! (workspace: need 4*m, prefer 3*m+m*nb) - call stdlib_sorgbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), & + call stdlib${ii}$_sorgbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of a in a ! (workspace: need bdspac) - call stdlib_sbdsqr( 'L', m, n, 0, 0, s, work( ie ), a, lda,dum, 1, dum, 1, & + call stdlib${ii}$_sbdsqr( 'L', m, n, 0_${ik}$, 0_${ik}$, s, work( ie ), a, lda,dum, 1_${ik}$, dum, 1_${ik}$, & work( iwork ), info ) end if else if( wntvo .and. wntuas ) then ! path 3t(n much larger than m, jobu='s' or 'a', jobvt='o') ! m right singular vectors to be overwritten on a and ! m left singular vectors to be computed in u - if( lwork>=m*m+max( 4*m, bdspac ) ) then + if( lwork>=m*m+max( 4_${ik}$*m, bdspac ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=max( wrkbl, lda*n+m )+lda*m ) then ! work(iu) is lda by n and work(ir) is lda by m ldwrku = lda @@ -74996,14 +74998,14 @@ module stdlib_linalg_lapack_s iwork = itau + m ! compute a=l*q ! (workspace: need m*m+2*m, prefer m*m+m+m*nb) - call stdlib_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy l to u, zeroing about above it - call stdlib_slacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_slaset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu ) + call stdlib${ii}$_slacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1_${ik}$) call stdlib${ii}$_slaset( 'U', m-1, m-1, zero, zero, u( 1_${ik}$, 2_${ik}$ ),ldu ) ! generate q in a ! (workspace: need m*m+2*m, prefer m*m+m+m*nb) - call stdlib_sorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + m @@ -75011,49 +75013,49 @@ module stdlib_linalg_lapack_s iwork = itaup + m ! bidiagonalize l in u, copying result to work(ir) ! (workspace: need m*m+4*m, prefer m*m+3*m+2*m*nb) - call stdlib_sgebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( itaup & + call stdlib${ii}$_sgebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( itaup & ),work( iwork ), lwork-iwork+1, ierr ) - call stdlib_slacpy( 'U', m, m, u, ldu, work( ir ), ldwrkr ) + call stdlib${ii}$_slacpy( 'U', m, m, u, ldu, work( ir ), ldwrkr ) ! generate right vectors bidiagonalizing l in work(ir) ! (workspace: need m*m+4*m-1, prefer m*m+3*m+(m-1)*nb) - call stdlib_sorgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & + call stdlib${ii}$_sorgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & iwork ),lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing l in u ! (workspace: need m*m+4*m, prefer m*m+3*m+m*nb) - call stdlib_sorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_sorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of l in u, and computing right ! singular vectors of l in work(ir) ! (workspace: need m*m+bdspac) - call stdlib_sbdsqr( 'U', m, m, m, 0, s, work( ie ),work( ir ), ldwrkr, u, & - ldu, dum, 1,work( iwork ), info ) + call stdlib${ii}$_sbdsqr( 'U', m, m, m, 0_${ik}$, s, work( ie ),work( ir ), ldwrkr, u, & + ldu, dum, 1_${ik}$,work( iwork ), info ) iu = ie + m ! multiply right singular vectors of l in work(ir) by q ! in a, storing result in work(iu) and copying to a ! (workspace: need m*m+2*m, prefer m*m+m*n+m)) do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_sgemm( 'N', 'N', m, blk, m, one, work( ir ),ldwrkr, a( 1, i & + call stdlib${ii}$_sgemm( 'N', 'N', m, blk, m, one, work( ir ),ldwrkr, a( 1_${ik}$, i & ), lda, zero,work( iu ), ldwrku ) - call stdlib_slacpy( 'F', m, blk, work( iu ), ldwrku,a( 1, i ), lda ) + call stdlib${ii}$_slacpy( 'F', m, blk, work( iu ), ldwrku,a( 1_${ik}$, i ), lda ) end do else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q ! (workspace: need 2*m, prefer m+m*nb) - call stdlib_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy l to u, zeroing out above it - call stdlib_slacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_slaset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu ) + call stdlib${ii}$_slacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1_${ik}$) call stdlib${ii}$_slaset( 'U', m-1, m-1, zero, zero, u( 1_${ik}$, 2_${ik}$ ),ldu ) ! generate q in a ! (workspace: need 2*m, prefer m+m*nb) - call stdlib_sorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + m @@ -75061,22 +75063,22 @@ module stdlib_linalg_lapack_s iwork = itaup + m ! bidiagonalize l in u ! (workspace: need 4*m, prefer 3*m+2*m*nb) - call stdlib_sgebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( itaup & + call stdlib${ii}$_sgebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( itaup & ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right vectors bidiagonalizing l by q in a ! (workspace: need 3*m+n, prefer 3*m+n*nb) - call stdlib_sormbr( 'P', 'L', 'T', m, n, m, u, ldu,work( itaup ), a, lda, & + call stdlib${ii}$_sormbr( 'P', 'L', 'T', m, n, m, u, ldu,work( itaup ), a, lda, & work( iwork ),lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing l in u ! (workspace: need 4*m, prefer 3*m+m*nb) - call stdlib_sorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_sorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in a ! (workspace: need bdspac) - call stdlib_sbdsqr( 'U', m, n, m, 0, s, work( ie ), a, lda,u, ldu, dum, 1, & + call stdlib${ii}$_sbdsqr( 'U', m, n, m, 0_${ik}$, s, work( ie ), a, lda,u, ldu, dum, 1_${ik}$, & work( iwork ), info ) end if else if( wntvs ) then @@ -75084,9 +75086,9 @@ module stdlib_linalg_lapack_s ! path 4t(n much larger than m, jobu='n', jobvt='s') ! m right singular vectors to be computed in vt and ! no left singular vectors to be computed - if( lwork>=m*m+max( 4*m, bdspac ) ) then + if( lwork>=m*m+max( 4_${ik}$*m, bdspac ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=wrkbl+lda*m ) then ! work(ir) is lda by m ldwrkr = lda @@ -75098,15 +75100,15 @@ module stdlib_linalg_lapack_s iwork = itau + m ! compute a=l*q ! (workspace: need m*m+2*m, prefer m*m+m+m*nb) - call stdlib_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy l to work(ir), zeroing out above it - call stdlib_slacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) - call stdlib_slaset( 'U', m-1, m-1, zero, zero,work( ir+ldwrkr ), ldwrkr & + call stdlib${ii}$_slacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) + call stdlib${ii}$_slaset( 'U', m-1, m-1, zero, zero,work( ir+ldwrkr ), ldwrkr & ) ! generate q in a ! (workspace: need m*m+2*m, prefer m*m+m+m*nb) - call stdlib_sorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + m @@ -75114,66 +75116,66 @@ module stdlib_linalg_lapack_s iwork = itaup + m ! bidiagonalize l in work(ir) ! (workspace: need m*m+4*m, prefer m*m+3*m+2*m*nb) - call stdlib_sgebrd( m, m, work( ir ), ldwrkr, s,work( ie ), work( itauq & + call stdlib${ii}$_sgebrd( m, m, work( ir ), ldwrkr, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing l in ! work(ir) ! (workspace: need m*m+4*m, prefer m*m+3*m+(m-1)*nb) - call stdlib_sorgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_sorgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of l in work(ir) ! (workspace: need m*m+bdspac) - call stdlib_sbdsqr( 'U', m, m, 0, 0, s, work( ie ),work( ir ), ldwrkr, & - dum, 1, dum, 1,work( iwork ), info ) + call stdlib${ii}$_sbdsqr( 'U', m, m, 0_${ik}$, 0_${ik}$, s, work( ie ),work( ir ), ldwrkr, & + dum, 1_${ik}$, dum, 1_${ik}$,work( iwork ), info ) ! multiply right singular vectors of l in work(ir) by ! q in a, storing result in vt ! (workspace: need m*m) - call stdlib_sgemm( 'N', 'N', m, n, m, one, work( ir ),ldwrkr, a, lda, & + call stdlib${ii}$_sgemm( 'N', 'N', m, n, m, one, work( ir ),ldwrkr, a, lda, & zero, vt, ldvt ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q ! (workspace: need 2*m, prefer m+m*nb) - call stdlib_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy result to vt - call stdlib_slacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_slacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need 2*m, prefer m+m*nb) - call stdlib_sorglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_sorglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_slaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda ) + if (m>1_${ik}$) call stdlib${ii}$_slaset( 'U', m-1, m-1, zero, zero, a( 1_${ik}$, 2_${ik}$ ),lda ) ! bidiagonalize l in a ! (workspace: need 4*m, prefer 3*m+2*m*nb) - call stdlib_sgebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_sgebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right vectors bidiagonalizing l by q in vt ! (workspace: need 3*m+n, prefer 3*m+n*nb) - call stdlib_sormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & + call stdlib${ii}$_sormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_sbdsqr( 'U', m, n, 0, 0, s, work( ie ), vt,ldvt, dum, 1, & - dum, 1, work( iwork ),info ) + call stdlib${ii}$_sbdsqr( 'U', m, n, 0_${ik}$, 0_${ik}$, s, work( ie ), vt,ldvt, dum, 1_${ik}$, & + dum, 1_${ik}$, work( iwork ),info ) end if else if( wntuo ) then ! path 5t(n much larger than m, jobu='o', jobvt='s') ! m right singular vectors to be computed in vt and ! m left singular vectors to be overwritten on a - if( lwork>=2*m*m+max( 4*m, bdspac ) ) then + if( lwork>=2_${ik}$*m*m+max( 4_${ik}$*m, bdspac ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+2*lda*m ) then ! work(iu) is lda by m and work(ir) is lda by m ldwrku = lda @@ -75194,15 +75196,15 @@ module stdlib_linalg_lapack_s iwork = itau + m ! compute a=l*q ! (workspace: need 2*m*m+2*m, prefer 2*m*m+m+m*nb) - call stdlib_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy l to work(iu), zeroing out below it - call stdlib_slacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_slaset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & + call stdlib${ii}$_slacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_slaset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & ) ! generate q in a ! (workspace: need 2*m*m+2*m, prefer 2*m*m+m+m*nb) - call stdlib_sorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + m @@ -75212,81 +75214,81 @@ module stdlib_linalg_lapack_s ! work(ir) ! (workspace: need 2*m*m+4*m, ! prefer 2*m*m+3*m+2*m*nb) - call stdlib_sgebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib${ii}$_sgebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_slacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib${ii}$_slacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate right bidiagonalizing vectors in work(iu) ! (workspace: need 2*m*m+4*m-1, ! prefer 2*m*m+3*m+(m-1)*nb) - call stdlib_sorgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib${ii}$_sorgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in work(ir) ! (workspace: need 2*m*m+4*m, prefer 2*m*m+3*m+m*nb) - call stdlib_sorgbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_sorgbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of l in work(ir) and computing ! right singular vectors of l in work(iu) ! (workspace: need 2*m*m+bdspac) - call stdlib_sbdsqr( 'U', m, m, m, 0, s, work( ie ),work( iu ), ldwrku, & - work( ir ),ldwrkr, dum, 1, work( iwork ), info ) + call stdlib${ii}$_sbdsqr( 'U', m, m, m, 0_${ik}$, s, work( ie ),work( iu ), ldwrku, & + work( ir ),ldwrkr, dum, 1_${ik}$, work( iwork ), info ) ! multiply right singular vectors of l in work(iu) by ! q in a, storing result in vt ! (workspace: need m*m) - call stdlib_sgemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, a, lda, & + call stdlib${ii}$_sgemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, a, lda, & zero, vt, ldvt ) ! copy left singular vectors of l to a ! (workspace: need m*m) - call stdlib_slacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) + call stdlib${ii}$_slacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need 2*m, prefer m+m*nb) - call stdlib_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_slacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_slacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need 2*m, prefer m+m*nb) - call stdlib_sorglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_sorglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_slaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda ) + if (m>1_${ik}$) call stdlib${ii}$_slaset( 'U', m-1, m-1, zero, zero, a( 1_${ik}$, 2_${ik}$ ),lda ) ! bidiagonalize l in a ! (workspace: need 4*m, prefer 3*m+2*m*nb) - call stdlib_sgebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_sgebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right vectors bidiagonalizing l by q in vt ! (workspace: need 3*m+n, prefer 3*m+n*nb) - call stdlib_sormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & + call stdlib${ii}$_sormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors of l in a ! (workspace: need 4*m, prefer 3*m+m*nb) - call stdlib_sorgbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & + call stdlib${ii}$_sorgbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, compute left ! singular vectors of a in a and compute right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_sbdsqr( 'U', m, n, m, 0, s, work( ie ), vt,ldvt, a, lda, & - dum, 1, work( iwork ),info ) + call stdlib${ii}$_sbdsqr( 'U', m, n, m, 0_${ik}$, s, work( ie ), vt,ldvt, a, lda, & + dum, 1_${ik}$, work( iwork ),info ) end if else if( wntuas ) then ! path 6t(n much larger than m, jobu='s' or 'a', ! jobvt='s') ! m right singular vectors to be computed in vt and ! m left singular vectors to be computed in u - if( lwork>=m*m+max( 4*m, bdspac ) ) then + if( lwork>=m*m+max( 4_${ik}$*m, bdspac ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+lda*m ) then ! work(iu) is lda by n ldwrku = lda @@ -75298,15 +75300,15 @@ module stdlib_linalg_lapack_s iwork = itau + m ! compute a=l*q ! (workspace: need m*m+2*m, prefer m*m+m+m*nb) - call stdlib_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy l to work(iu), zeroing out above it - call stdlib_slacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_slaset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & + call stdlib${ii}$_slacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_slaset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & ) ! generate q in a ! (workspace: need m*m+2*m, prefer m*m+m+m*nb) - call stdlib_sorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sorglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ie = itau itauq = ie + m @@ -75314,70 +75316,70 @@ module stdlib_linalg_lapack_s iwork = itaup + m ! bidiagonalize l in work(iu), copying result to u ! (workspace: need m*m+4*m, prefer m*m+3*m+2*m*nb) - call stdlib_sgebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib${ii}$_sgebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_slacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) + call stdlib${ii}$_slacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) ! generate right bidiagonalizing vectors in work(iu) ! (workspace: need m*m+4*m-1, ! prefer m*m+3*m+(m-1)*nb) - call stdlib_sorgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib${ii}$_sorgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (workspace: need m*m+4*m, prefer m*m+3*m+m*nb) - call stdlib_sorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_sorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of l in u and computing right ! singular vectors of l in work(iu) ! (workspace: need m*m+bdspac) - call stdlib_sbdsqr( 'U', m, m, m, 0, s, work( ie ),work( iu ), ldwrku, & - u, ldu, dum, 1,work( iwork ), info ) + call stdlib${ii}$_sbdsqr( 'U', m, m, m, 0_${ik}$, s, work( ie ),work( iu ), ldwrku, & + u, ldu, dum, 1_${ik}$,work( iwork ), info ) ! multiply right singular vectors of l in work(iu) by ! q in a, storing result in vt ! (workspace: need m*m) - call stdlib_sgemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, a, lda, & + call stdlib${ii}$_sgemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, a, lda, & zero, vt, ldvt ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need 2*m, prefer m+m*nb) - call stdlib_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_slacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_slacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need 2*m, prefer m+m*nb) - call stdlib_sorglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_sorglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to u, zeroing out above it - call stdlib_slacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_slaset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu ) + call stdlib${ii}$_slacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1_${ik}$) call stdlib${ii}$_slaset( 'U', m-1, m-1, zero, zero, u( 1_${ik}$, 2_${ik}$ ),ldu ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize l in u ! (workspace: need 4*m, prefer 3*m+2*m*nb) - call stdlib_sgebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_sgebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in u by q ! in vt ! (workspace: need 3*m+n, prefer 3*m+n*nb) - call stdlib_sormbr( 'P', 'L', 'T', m, n, m, u, ldu,work( itaup ), vt, & + call stdlib${ii}$_sormbr( 'P', 'L', 'T', m, n, m, u, ldu,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (workspace: need 4*m, prefer 3*m+m*nb) - call stdlib_sorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_sorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_sbdsqr( 'U', m, n, m, 0, s, work( ie ), vt,ldvt, u, ldu, & - dum, 1, work( iwork ),info ) + call stdlib${ii}$_sbdsqr( 'U', m, n, m, 0_${ik}$, s, work( ie ), vt,ldvt, u, ldu, & + dum, 1_${ik}$, work( iwork ),info ) end if end if else if( wntva ) then @@ -75385,9 +75387,9 @@ module stdlib_linalg_lapack_s ! path 7t(n much larger than m, jobu='n', jobvt='a') ! n right singular vectors to be computed in vt and ! no left singular vectors to be computed - if( lwork>=m*m+max( n+m, 4*m, bdspac ) ) then + if( lwork>=m*m+max( n+m, 4_${ik}$*m, bdspac ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=wrkbl+lda*m ) then ! work(ir) is lda by m ldwrkr = lda @@ -75399,16 +75401,16 @@ module stdlib_linalg_lapack_s iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need m*m+2*m, prefer m*m+m+m*nb) - call stdlib_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_slacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_slacpy( 'U', m, n, a, lda, vt, ldvt ) ! copy l to work(ir), zeroing out above it - call stdlib_slacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) - call stdlib_slaset( 'U', m-1, m-1, zero, zero,work( ir+ldwrkr ), ldwrkr & + call stdlib${ii}$_slacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) + call stdlib${ii}$_slaset( 'U', m-1, m-1, zero, zero,work( ir+ldwrkr ), ldwrkr & ) ! generate q in vt ! (workspace: need m*m+m+n, prefer m*m+m+n*nb) - call stdlib_sorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_sorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = itau itauq = ie + m @@ -75416,68 +75418,68 @@ module stdlib_linalg_lapack_s iwork = itaup + m ! bidiagonalize l in work(ir) ! (workspace: need m*m+4*m, prefer m*m+3*m+2*m*nb) - call stdlib_sgebrd( m, m, work( ir ), ldwrkr, s,work( ie ), work( itauq & + call stdlib${ii}$_sgebrd( m, m, work( ir ), ldwrkr, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in work(ir) ! (workspace: need m*m+4*m-1, ! prefer m*m+3*m+(m-1)*nb) - call stdlib_sorgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_sorgbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of l in work(ir) ! (workspace: need m*m+bdspac) - call stdlib_sbdsqr( 'U', m, m, 0, 0, s, work( ie ),work( ir ), ldwrkr, & - dum, 1, dum, 1,work( iwork ), info ) + call stdlib${ii}$_sbdsqr( 'U', m, m, 0_${ik}$, 0_${ik}$, s, work( ie ),work( ir ), ldwrkr, & + dum, 1_${ik}$, dum, 1_${ik}$,work( iwork ), info ) ! multiply right singular vectors of l in work(ir) by ! q in vt, storing result in a ! (workspace: need m*m) - call stdlib_sgemm( 'N', 'N', m, n, m, one, work( ir ),ldwrkr, vt, ldvt, & + call stdlib${ii}$_sgemm( 'N', 'N', m, n, m, one, work( ir ),ldwrkr, vt, ldvt, & zero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_slacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_slacpy( 'F', m, n, a, lda, vt, ldvt ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need 2*m, prefer m+m*nb) - call stdlib_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_slacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_slacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need m+n, prefer m+n*nb) - call stdlib_sorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_sorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_slaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda ) + if (m>1_${ik}$) call stdlib${ii}$_slaset( 'U', m-1, m-1, zero, zero, a( 1_${ik}$, 2_${ik}$ ),lda ) ! bidiagonalize l in a ! (workspace: need 4*m, prefer 3*m+2*m*nb) - call stdlib_sgebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_sgebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in a by q ! in vt ! (workspace: need 3*m+n, prefer 3*m+n*nb) - call stdlib_sormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & + call stdlib${ii}$_sormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_sbdsqr( 'U', m, n, 0, 0, s, work( ie ), vt,ldvt, dum, 1, & - dum, 1, work( iwork ),info ) + call stdlib${ii}$_sbdsqr( 'U', m, n, 0_${ik}$, 0_${ik}$, s, work( ie ), vt,ldvt, dum, 1_${ik}$, & + dum, 1_${ik}$, work( iwork ),info ) end if else if( wntuo ) then ! path 8t(n much larger than m, jobu='o', jobvt='a') ! n right singular vectors to be computed in vt and ! m left singular vectors to be overwritten on a - if( lwork>=2*m*m+max( n+m, 4*m, bdspac ) ) then + if( lwork>=2_${ik}$*m*m+max( n+m, 4_${ik}$*m, bdspac ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+2*lda*m ) then ! work(iu) is lda by m and work(ir) is lda by m ldwrku = lda @@ -75498,16 +75500,16 @@ module stdlib_linalg_lapack_s iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need 2*m*m+2*m, prefer 2*m*m+m+m*nb) - call stdlib_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_slacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_slacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need 2*m*m+m+n, prefer 2*m*m+m+n*nb) - call stdlib_sorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_sorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to work(iu), zeroing out above it - call stdlib_slacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_slaset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & + call stdlib${ii}$_slacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_slaset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & ) ie = itau itauq = ie + m @@ -75517,83 +75519,83 @@ module stdlib_linalg_lapack_s ! work(ir) ! (workspace: need 2*m*m+4*m, ! prefer 2*m*m+3*m+2*m*nb) - call stdlib_sgebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib${ii}$_sgebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_slacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib${ii}$_slacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate right bidiagonalizing vectors in work(iu) ! (workspace: need 2*m*m+4*m-1, ! prefer 2*m*m+3*m+(m-1)*nb) - call stdlib_sorgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib${ii}$_sorgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in work(ir) ! (workspace: need 2*m*m+4*m, prefer 2*m*m+3*m+m*nb) - call stdlib_sorgbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_sorgbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of l in work(ir) and computing ! right singular vectors of l in work(iu) ! (workspace: need 2*m*m+bdspac) - call stdlib_sbdsqr( 'U', m, m, m, 0, s, work( ie ),work( iu ), ldwrku, & - work( ir ),ldwrkr, dum, 1, work( iwork ), info ) + call stdlib${ii}$_sbdsqr( 'U', m, m, m, 0_${ik}$, s, work( ie ),work( iu ), ldwrku, & + work( ir ),ldwrkr, dum, 1_${ik}$, work( iwork ), info ) ! multiply right singular vectors of l in work(iu) by ! q in vt, storing result in a ! (workspace: need m*m) - call stdlib_sgemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, vt, ldvt, & + call stdlib${ii}$_sgemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, vt, ldvt, & zero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_slacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_slacpy( 'F', m, n, a, lda, vt, ldvt ) ! copy left singular vectors of a from work(ir) to a - call stdlib_slacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) + call stdlib${ii}$_slacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need 2*m, prefer m+m*nb) - call stdlib_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_slacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_slacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need m+n, prefer m+n*nb) - call stdlib_sorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_sorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_slaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ),lda ) + if (m>1_${ik}$) call stdlib${ii}$_slaset( 'U', m-1, m-1, zero, zero, a( 1_${ik}$, 2_${ik}$ ),lda ) ! bidiagonalize l in a ! (workspace: need 4*m, prefer 3*m+2*m*nb) - call stdlib_sgebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_sgebrd( m, m, a, lda, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in a by q ! in vt ! (workspace: need 3*m+n, prefer 3*m+n*nb) - call stdlib_sormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & + call stdlib${ii}$_sormbr( 'P', 'L', 'T', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in a ! (workspace: need 4*m, prefer 3*m+m*nb) - call stdlib_sorgbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & + call stdlib${ii}$_sorgbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of a in a and computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_sbdsqr( 'U', m, n, m, 0, s, work( ie ), vt,ldvt, a, lda, & - dum, 1, work( iwork ),info ) + call stdlib${ii}$_sbdsqr( 'U', m, n, m, 0_${ik}$, s, work( ie ), vt,ldvt, a, lda, & + dum, 1_${ik}$, work( iwork ),info ) end if else if( wntuas ) then ! path 9t(n much larger than m, jobu='s' or 'a', ! jobvt='a') ! n right singular vectors to be computed in vt and ! m left singular vectors to be computed in u - if( lwork>=m*m+max( n+m, 4*m, bdspac ) ) then + if( lwork>=m*m+max( n+m, 4_${ik}$*m, bdspac ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+lda*m ) then ! work(iu) is lda by m ldwrku = lda @@ -75605,16 +75607,16 @@ module stdlib_linalg_lapack_s iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need m*m+2*m, prefer m*m+m+m*nb) - call stdlib_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_slacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_slacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need m*m+m+n, prefer m*m+m+n*nb) - call stdlib_sorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_sorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to work(iu), zeroing out above it - call stdlib_slacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_slaset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & + call stdlib${ii}$_slacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_slaset( 'U', m-1, m-1, zero, zero,work( iu+ldwrku ), ldwrku & ) ie = itau itauq = ie + m @@ -75622,71 +75624,71 @@ module stdlib_linalg_lapack_s iwork = itaup + m ! bidiagonalize l in work(iu), copying result to u ! (workspace: need m*m+4*m, prefer m*m+3*m+2*m*nb) - call stdlib_sgebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & + call stdlib${ii}$_sgebrd( m, m, work( iu ), ldwrku, s,work( ie ), work( itauq & ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_slacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) + call stdlib${ii}$_slacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) ! generate right bidiagonalizing vectors in work(iu) ! (workspace: need m*m+4*m, prefer m*m+3*m+(m-1)*nb) - call stdlib_sorgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib${ii}$_sorgbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (workspace: need m*m+4*m, prefer m*m+3*m+m*nb) - call stdlib_sorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_sorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of l in u and computing right ! singular vectors of l in work(iu) ! (workspace: need m*m+bdspac) - call stdlib_sbdsqr( 'U', m, m, m, 0, s, work( ie ),work( iu ), ldwrku, & - u, ldu, dum, 1,work( iwork ), info ) + call stdlib${ii}$_sbdsqr( 'U', m, m, m, 0_${ik}$, s, work( ie ),work( iu ), ldwrku, & + u, ldu, dum, 1_${ik}$,work( iwork ), info ) ! multiply right singular vectors of l in work(iu) by ! q in vt, storing result in a ! (workspace: need m*m) - call stdlib_sgemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, vt, ldvt, & + call stdlib${ii}$_sgemm( 'N', 'N', m, n, m, one, work( iu ),ldwrku, vt, ldvt, & zero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_slacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_slacpy( 'F', m, n, a, lda, vt, ldvt ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (workspace: need 2*m, prefer m+m*nb) - call stdlib_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_sgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_slacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_slacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (workspace: need m+n, prefer m+n*nb) - call stdlib_sorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_sorglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to u, zeroing out above it - call stdlib_slacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_slaset( 'U', m-1, m-1, zero, zero, u( 1, 2 ),ldu ) + call stdlib${ii}$_slacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1_${ik}$) call stdlib${ii}$_slaset( 'U', m-1, m-1, zero, zero, u( 1_${ik}$, 2_${ik}$ ),ldu ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize l in u ! (workspace: need 4*m, prefer 3*m+2*m*nb) - call stdlib_sgebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( & + call stdlib${ii}$_sgebrd( m, m, u, ldu, s, work( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in u by q ! in vt ! (workspace: need 3*m+n, prefer 3*m+n*nb) - call stdlib_sormbr( 'P', 'L', 'T', m, n, m, u, ldu,work( itaup ), vt, & + call stdlib${ii}$_sormbr( 'P', 'L', 'T', m, n, m, u, ldu,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (workspace: need 4*m, prefer 3*m+m*nb) - call stdlib_sorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_sorgbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) iwork = ie + m ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u and computing right ! singular vectors of a in vt ! (workspace: need bdspac) - call stdlib_sbdsqr( 'U', m, n, m, 0, s, work( ie ), vt,ldvt, u, ldu, & - dum, 1, work( iwork ),info ) + call stdlib${ii}$_sbdsqr( 'U', m, n, m, 0_${ik}$, s, work( ie ), vt,ldvt, u, ldu, & + dum, 1_${ik}$, work( iwork ),info ) end if end if end if @@ -75694,107 +75696,107 @@ module stdlib_linalg_lapack_s ! n < mnthr ! path 10t(n greater than m, but not much larger) ! reduce to bidiagonal form without lq decomposition - ie = 1 + ie = 1_${ik}$ itauq = ie + m itaup = itauq + m iwork = itaup + m ! bidiagonalize a ! (workspace: need 3*m+n, prefer 3*m+(m+n)*nb) - call stdlib_sgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_sgebrd( m, n, a, lda, s, work( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,ierr ) if( wntuas ) then ! if left singular vectors desired in u, copy result to u ! and generate left bidiagonalizing vectors in u ! (workspace: need 4*m-1, prefer 3*m+(m-1)*nb) - call stdlib_slacpy( 'L', m, m, a, lda, u, ldu ) - call stdlib_sorgbr( 'Q', m, m, n, u, ldu, work( itauq ),work( iwork ), lwork-& + call stdlib${ii}$_slacpy( 'L', m, m, a, lda, u, ldu ) + call stdlib${ii}$_sorgbr( 'Q', m, m, n, u, ldu, work( itauq ),work( iwork ), lwork-& iwork+1, ierr ) end if if( wntvas ) then ! if right singular vectors desired in vt, copy result to ! vt and generate right bidiagonalizing vectors in vt ! (workspace: need 3*m+nrvt, prefer 3*m+nrvt*nb) - call stdlib_slacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_slacpy( 'U', m, n, a, lda, vt, ldvt ) if( wntva )nrvt = n if( wntvs )nrvt = m - call stdlib_sorgbr( 'P', nrvt, n, m, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib${ii}$_sorgbr( 'P', nrvt, n, m, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) end if if( wntuo ) then ! if left singular vectors desired in a, generate left ! bidiagonalizing vectors in a ! (workspace: need 4*m-1, prefer 3*m+(m-1)*nb) - call stdlib_sorgbr( 'Q', m, m, n, a, lda, work( itauq ),work( iwork ), lwork-& + call stdlib${ii}$_sorgbr( 'Q', m, m, n, a, lda, work( itauq ),work( iwork ), lwork-& iwork+1, ierr ) end if if( wntvo ) then ! if right singular vectors desired in a, generate right ! bidiagonalizing vectors in a ! (workspace: need 4*m, prefer 3*m+m*nb) - call stdlib_sorgbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-& + call stdlib${ii}$_sorgbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-& iwork+1, ierr ) end if iwork = ie + m if( wntuas .or. wntuo )nru = m - if( wntun )nru = 0 + if( wntun )nru = 0_${ik}$ if( wntvas .or. wntvo )ncvt = n - if( wntvn )ncvt = 0 + if( wntvn )ncvt = 0_${ik}$ if( ( .not.wntuo ) .and. ( .not.wntvo ) ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in vt ! (workspace: need bdspac) - call stdlib_sbdsqr( 'L', m, ncvt, nru, 0, s, work( ie ), vt,ldvt, u, ldu, dum,& - 1, work( iwork ), info ) + call stdlib${ii}$_sbdsqr( 'L', m, ncvt, nru, 0_${ik}$, s, work( ie ), vt,ldvt, u, ldu, dum,& + 1_${ik}$, work( iwork ), info ) else if( ( .not.wntuo ) .and. wntvo ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in a ! (workspace: need bdspac) - call stdlib_sbdsqr( 'L', m, ncvt, nru, 0, s, work( ie ), a, lda,u, ldu, dum, & - 1, work( iwork ), info ) + call stdlib${ii}$_sbdsqr( 'L', m, ncvt, nru, 0_${ik}$, s, work( ie ), a, lda,u, ldu, dum, & + 1_${ik}$, work( iwork ), info ) else ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in a and computing right singular ! vectors in vt ! (workspace: need bdspac) - call stdlib_sbdsqr( 'L', m, ncvt, nru, 0, s, work( ie ), vt,ldvt, a, lda, dum,& - 1, work( iwork ), info ) + call stdlib${ii}$_sbdsqr( 'L', m, ncvt, nru, 0_${ik}$, s, work( ie ), vt,ldvt, a, lda, dum,& + 1_${ik}$, work( iwork ), info ) end if end if end if - ! if stdlib_sbdsqr failed to converge, copy unconverged superdiagonals + ! if stdlib${ii}$_sbdsqr failed to converge, copy unconverged superdiagonals ! to work( 2:minmn ) - if( info/=0 ) then - if( ie>2 ) then + if( info/=0_${ik}$ ) then + if( ie>2_${ik}$ ) then do i = 1, minmn - 1 work( i+1 ) = work( i+ie-1 ) end do end if - if( ie<2 ) then + if( ie<2_${ik}$ ) then do i = minmn - 1, 1, -1 work( i+1 ) = work( i+ie-1 ) end do end if end if ! undo scaling if necessary - if( iscl==1 ) then - if( anrm>bignum )call stdlib_slascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,& + if( iscl==1_${ik}$ ) then + if( anrm>bignum )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn, 1_${ik}$, s, minmn,& ierr ) - if( info/=0 .and. anrm>bignum )call stdlib_slascl( 'G', 0, 0, bignum, anrm, minmn-1,& - 1, work( 2 ),minmn, ierr ) - if( anrmbignum )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn-1,& + 1_${ik}$, work( 2_${ik}$ ),minmn, ierr ) + if( anrm= N. The SVD of A is written as !! [++] [xx] [x0] [xx] @@ -75807,26 +75809,26 @@ module stdlib_linalg_lapack_s numrank, iwork, liwork,work, lwork, rwork, lrwork, info ) ! Scalar Arguments character, intent(in) :: joba, jobp, jobr, jobu, jobv - integer(ilp), intent(in) :: m, n, lda, ldu, ldv, liwork, lrwork - integer(ilp), intent(out) :: numrank, info - integer(ilp), intent(inout) :: lwork + integer(${ik}$), intent(in) :: m, n, lda, ldu, ldv, liwork, lrwork + integer(${ik}$), intent(out) :: numrank, info + integer(${ik}$), intent(inout) :: lwork ! Array Arguments real(sp), intent(inout) :: a(lda,*) real(sp), intent(out) :: u(ldu,*), v(ldv,*), work(*) real(sp), intent(out) :: s(*), rwork(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: ierr, iwoff, nr, n1, optratio, p, q - integer(ilp) :: lwcon, lwqp3, lwrk_sgelqf, lwrk_sgesvd, lwrk_sgesvd2, lwrk_sgeqp3, & + integer(${ik}$) :: ierr, iwoff, nr, n1, optratio, p, q + integer(${ik}$) :: lwcon, lwqp3, lwrk_sgelqf, lwrk_sgesvd, lwrk_sgesvd2, lwrk_sgeqp3, & lwrk_sgeqrf, lwrk_sormlq, lwrk_sormqr, lwrk_sormqr2, lwlqf, lwqrf, lwsvd, lwsvd2, & lworq, lworq2, lwunlq, minwrk, minwrk2, optwrk, optwrk2, iminwrk, rminwrk logical(lk) :: accla, acclm, acclh, ascaled, conda, dntwu, dntwv, lquery, lsvc0, lsvec,& rowprm, rsvec, rtrans, wntua, wntuf, wntur, wntus, wntva, wntvr real(sp) :: big, epsln, rtmp, sconda, sfmin ! Local Arrays - real(sp) :: rdummy(1) + real(sp) :: rdummy(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,min,real,sqrt ! Executable Statements @@ -75850,81 +75852,81 @@ module stdlib_linalg_lapack_s rtrans = stdlib_lsame( jobr, 'T' ) if ( rowprm ) then if ( conda ) then - iminwrk = max( 1, n + m - 1 + n ) + iminwrk = max( 1_${ik}$, n + m - 1_${ik}$ + n ) else - iminwrk = max( 1, n + m - 1 ) + iminwrk = max( 1_${ik}$, n + m - 1_${ik}$ ) end if - rminwrk = max( 2, m ) + rminwrk = max( 2_${ik}$, m ) else if ( conda ) then - iminwrk = max( 1, n + n ) + iminwrk = max( 1_${ik}$, n + n ) else - iminwrk = max( 1, n ) + iminwrk = max( 1_${ik}$, n ) end if - rminwrk = 2 + rminwrk = 2_${ik}$ end if - lquery = (liwork == -1 .or. lwork == -1 .or. lrwork == -1) - info = 0 + lquery = (liwork == -1_${ik}$ .or. lwork == -1_${ik}$ .or. lrwork == -1_${ik}$) + info = 0_${ik}$ if ( .not. ( accla .or. acclm .or. acclh ) ) then - info = -1 + info = -1_${ik}$ else if ( .not.( rowprm .or. stdlib_lsame( jobp, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if ( .not.( rtrans .or. stdlib_lsame( jobr, 'N' ) ) ) then - info = -3 + info = -3_${ik}$ else if ( .not.( lsvec .or. dntwu ) ) then - info = -4 + info = -4_${ik}$ else if ( wntur .and. wntva ) then - info = -5 + info = -5_${ik}$ else if ( .not.( rsvec .or. dntwv )) then - info = -5 - else if ( m<0 ) then - info = -6 - else if ( ( n<0 ) .or. ( n>m ) ) then - info = -7 - else if ( ldam ) ) then + info = -7_${ik}$ + else if ( lda big / sqrt(real(m,KIND=sp)) ) then + if ( rwork(1_${ik}$) > big / sqrt(real(m,KIND=sp)) ) then ! .. to prevent overflow in the qr factorization, scale the ! matrix by 1/sqrt(m) if too large entry detected - call stdlib_slascl('G',0,0,sqrt(real(m,KIND=sp)),one, m,n, a,lda, ierr) + call stdlib${ii}$_slascl('G',0_${ik}$,0_${ik}$,sqrt(real(m,KIND=sp)),one, m,n, a,lda, ierr) ascaled = .true. end if - call stdlib_slaswp( n, a, lda, 1, m-1, iwork(n+1), 1 ) + call stdlib${ii}$_slaswp( n, a, lda, 1_${ik}$, m-1, iwork(n+1), 1_${ik}$ ) end if ! .. at this stage, preemptive scaling is done only to avoid column ! norms overflows during the qr factorization. the svd procedure should ! have its own scaling to save the singular values from overflows and ! underflows. that depends on the svd procedure. if ( .not.rowprm ) then - rtmp = stdlib_slange( 'M', m, n, a, lda, rdummy ) + rtmp = stdlib${ii}$_slange( 'M', m, n, a, lda, rdummy ) if ( ( rtmp /= rtmp ) .or.( (rtmp*zero) /= zero ) ) then - info = -8 - call stdlib_xerbla( 'SGESVDQ', -info ) + info = -8_${ik}$ + call stdlib${ii}$_xerbla( 'SGESVDQ', -info ) return end if if ( rtmp > big / sqrt(real(m,KIND=sp)) ) then ! .. to prevent overflow in the qr factorization, scale the ! matrix by 1/sqrt(m) if too large entry detected - call stdlib_slascl('G',0,0, sqrt(real(m,KIND=sp)),one, m,n, a,lda, ierr) + call stdlib${ii}$_slascl('G',0_${ik}$,0_${ik}$, sqrt(real(m,KIND=sp)),one, m,n, a,lda, ierr) ascaled = .true. end if @@ -76177,14 +76179,14 @@ module stdlib_linalg_lapack_s ! [ 0 ] do p = 1, n ! All Columns Are Free Columns - iwork(p) = 0 + iwork(p) = 0_${ik}$ end do - call stdlib_sgeqp3( m, n, a, lda, iwork, work, work(n+1), lwork-n,ierr ) + call stdlib${ii}$_sgeqp3( m, n, a, lda, iwork, work, work(n+1), lwork-n,ierr ) ! if the user requested accuracy level allows truncation in the ! computed upper triangular factor, the matrix r is examined and, ! if possible, replaced with its leading upper trapezoidal part. - epsln = stdlib_slamch('E') - sfmin = stdlib_slamch('S') + epsln = stdlib${ii}$_slamch('E') + sfmin = stdlib${ii}$_slamch('S') ! small = sfmin / epsln nr = n if ( accla ) then @@ -76192,25 +76194,24 @@ module stdlib_linalg_lapack_s ! sigma_i < n*eps*||a||_f are flushed to zero. this is an ! aggressive enforcement of lower numerical rank by introducing a ! backward error of the order of n*eps*||a||_f. - nr = 1 + nr = 1_${ik}$ rtmp = sqrt(real(n,KIND=sp))*epsln do p = 2, n if ( abs(a(p,p)) < (rtmp*abs(a(1,1))) ) go to 3002 - nr = nr + 1 + nr = nr + 1_${ik}$ end do 3002 continue elseif ( acclm ) then ! .. similarly as above, only slightly more gentle (less aggressive). ! sudden drop on the diagonal of r is used as the criterion for being - ! close-to-rank-deficient. the threshold is set to epsln=stdlib_slamch('e'). + ! close-to-rank-deficient. the threshold is set to epsln=stdlib${ii}$_slamch('e'). ! [[this can be made more flexible by replacing this hard-coded value ! with a user specified threshold.]] also, the values that underflow ! will be truncated. - nr = 1 + nr = 1_${ik}$ do p = 2, n - if ( ( abs(a(p,p)) < (epsln*abs(a(p-1,p-1))) ) .or.( abs(a(p,p)) < sfmin ) ) go & - to 3402 - nr = nr + 1 + if ( ( abs(a(p,p)) < (epsln*abs(a(p-1,p-1))) ) .or.( abs(a(p,p)) < sfmin ) ) go to 3402 + nr = nr + 1_${ik}$ end do 3402 continue else @@ -76218,31 +76219,31 @@ module stdlib_linalg_lapack_s ! obvious case of zero pivots. ! .. inspect r for exact zeros on the diagonal; ! r(i,i)=0 => r(i:n,i:n)=0. - nr = 1 + nr = 1_${ik}$ do p = 2, n if ( abs(a(p,p)) == zero ) go to 3502 - nr = nr + 1 + nr = nr + 1_${ik}$ end do 3502 continue if ( conda ) then ! estimate the scaled condition number of a. use the fact that it is ! the same as the scaled condition number of r. ! V Is Used As Workspace - call stdlib_slacpy( 'U', n, n, a, lda, v, ldv ) + call stdlib${ii}$_slacpy( 'U', n, n, a, lda, v, ldv ) ! only the leading nr x nr submatrix of the triangular factor ! is considered. only if nr=n will this give a reliable error ! bound. however, even for nr < n, this can be used on an ! expert level and obtain useful information in the sense of ! perturbation theory. do p = 1, nr - rtmp = stdlib_snrm2( p, v(1,p), 1 ) - call stdlib_sscal( p, one/rtmp, v(1,p), 1 ) + rtmp = stdlib${ii}$_snrm2( p, v(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_sscal( p, one/rtmp, v(1_${ik}$,p), 1_${ik}$ ) end do if ( .not. ( lsvec .or. rsvec ) ) then - call stdlib_spocon( 'U', nr, v, ldv, one, rtmp,work, iwork(n+iwoff), ierr & + call stdlib${ii}$_spocon( 'U', nr, v, ldv, one, rtmp,work, iwork(n+iwoff), ierr & ) else - call stdlib_spocon( 'U', nr, v, ldv, one, rtmp,work(n+1), iwork(n+iwoff), & + call stdlib${ii}$_spocon( 'U', nr, v, ldv, one, rtmp,work(n+1), iwork(n+iwoff), & ierr ) end if sconda = one / sqrt(rtmp) @@ -76272,12 +76273,12 @@ module stdlib_linalg_lapack_s if ( q <= nr ) a(p,q) = zero end do end do - call stdlib_sgesvd( 'N', 'N', n, nr, a, lda, s, u, ldu,v, ldv, work, lwork, info & + call stdlib${ii}$_sgesvd( 'N', 'N', n, nr, a, lda, s, u, ldu,v, ldv, work, lwork, info & ) else ! .. compute the singular values of r = [a](1:nr,1:n) - if ( nr > 1 )call stdlib_slaset( 'L', nr-1,nr-1, zero,zero, a(2,1), lda ) - call stdlib_sgesvd( 'N', 'N', nr, n, a, lda, s, u, ldu,v, ldv, work, lwork, info & + if ( nr > 1_${ik}$ )call stdlib${ii}$_slaset( 'L', nr-1,nr-1, zero,zero, a(2_${ik}$,1_${ik}$), lda ) + call stdlib${ii}$_sgesvd( 'N', 'N', nr, n, a, lda, s, u, ldu,v, ldv, work, lwork, info & ) end if else if ( lsvec .and. ( .not. rsvec) ) then @@ -76285,7 +76286,7 @@ module stdlib_linalg_lapack_s ! The Singular Values And The Left Singular Vectors Requested ! ......................................................................."""""""" if ( rtrans ) then - ! .. apply stdlib_sgesvd to r**t + ! .. apply stdlib${ii}$_sgesvd to r**t ! .. copy r**t into [u] and overwrite [u] with the right singular ! vectors of r do p = 1, nr @@ -76293,11 +76294,11 @@ module stdlib_linalg_lapack_s u(q,p) = a(p,q) end do end do - if ( nr > 1 )call stdlib_slaset( 'U', nr-1,nr-1, zero,zero, u(1,2), ldu ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_slaset( 'U', nr-1,nr-1, zero,zero, u(1_${ik}$,2_${ik}$), ldu ) ! .. the left singular vectors not computed, the nr right singular ! vectors overwrite [u](1:nr,1:nr) as transposed. these ! will be pre-multiplied by q to build the left singular vectors of a. - call stdlib_sgesvd( 'N', 'O', n, nr, u, ldu, s, u, ldu,u, ldu, work(n+1), & + call stdlib${ii}$_sgesvd( 'N', 'O', n, nr, u, ldu, s, u, ldu,u, ldu, work(n+1), & lwork-n, info ) do p = 1, nr do q = p + 1, nr @@ -76309,12 +76310,12 @@ module stdlib_linalg_lapack_s else ! Apply Stdlib_Sgesvd To R ! .. copy r into [u] and overwrite [u] with the left singular vectors - call stdlib_slacpy( 'U', nr, n, a, lda, u, ldu ) - if ( nr > 1 )call stdlib_slaset( 'L', nr-1, nr-1, zero, zero, u(2,1), ldu ) + call stdlib${ii}$_slacpy( 'U', nr, n, a, lda, u, ldu ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_slaset( 'L', nr-1, nr-1, zero, zero, u(2_${ik}$,1_${ik}$), ldu ) ! .. the right singular vectors not computed, the nr left singular ! vectors overwrite [u](1:nr,1:nr) - call stdlib_sgesvd( 'O', 'N', nr, n, u, ldu, s, u, ldu,v, ldv, work(n+1), & + call stdlib${ii}$_sgesvd( 'O', 'N', nr, n, u, ldu, s, u, ldu,v, ldv, work(n+1), & lwork-n, info ) ! .. now [u](1:nr,1:nr) contains the nr left singular vectors of ! r. these will be pre-multiplied by q to build the left singular @@ -76323,35 +76324,35 @@ module stdlib_linalg_lapack_s ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. ( .not.wntuf ) ) then - call stdlib_slaset('A', m-nr, nr, zero, zero, u(nr+1,1), ldu) + call stdlib${ii}$_slaset('A', m-nr, nr, zero, zero, u(nr+1,1_${ik}$), ldu) if ( nr < n1 ) then - call stdlib_slaset( 'A',nr,n1-nr,zero,zero,u(1,nr+1), ldu ) - call stdlib_slaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_slaset( 'A',nr,n1-nr,zero,zero,u(1_${ik}$,nr+1), ldu ) + call stdlib${ii}$_slaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) end if end if ! the q matrix from the first qrf is built into the left singular ! vectors matrix u. - if ( .not.wntuf )call stdlib_sormqr( 'L', 'N', m, n1, n, a, lda, work, u,ldu, work(& + if ( .not.wntuf )call stdlib${ii}$_sormqr( 'L', 'N', m, n1, n, a, lda, work, u,ldu, work(& n+1), lwork-n, ierr ) - if ( rowprm .and. .not.wntuf )call stdlib_slaswp( n1, u, ldu, 1, m-1, iwork(n+1), -& - 1 ) + if ( rowprm .and. .not.wntuf )call stdlib${ii}$_slaswp( n1, u, ldu, 1_${ik}$, m-1, iwork(n+1), -& + 1_${ik}$ ) else if ( rsvec .and. ( .not. lsvec ) ) then ! ....................................................................... ! The Singular Values And The Right Singular Vectors Requested ! ....................................................................... if ( rtrans ) then - ! .. apply stdlib_sgesvd to r**t + ! .. apply stdlib${ii}$_sgesvd to r**t ! .. copy r**t into v and overwrite v with the left singular vectors do p = 1, nr do q = p, n v(q,p) = (a(p,q)) end do end do - if ( nr > 1 )call stdlib_slaset( 'U', nr-1,nr-1, zero,zero, v(1,2), ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_slaset( 'U', nr-1,nr-1, zero,zero, v(1_${ik}$,2_${ik}$), ldv ) ! .. the left singular vectors of r**t overwrite v, the right singular ! vectors not computed if ( wntvr .or. ( nr == n ) ) then - call stdlib_sgesvd( 'O', 'N', n, nr, v, ldv, s, u, ldu,u, ldu, work(n+1), & + call stdlib${ii}$_sgesvd( 'O', 'N', n, nr, v, ldv, s, u, ldu,u, ldu, work(n+1), & lwork-n, info ) do p = 1, nr do q = p + 1, nr @@ -76367,15 +76368,15 @@ module stdlib_linalg_lapack_s end do end do end if - call stdlib_slapmt( .false., nr, n, v, ldv, iwork ) + call stdlib${ii}$_slapmt( .false., nr, n, v, ldv, iwork ) else ! .. need all n right singular vectors and nr < n ! [!] this is simple implementation that augments [v](1:n,1:nr) ! by padding a zero block. in the case nr << n, a more efficient ! way is to first use the qr factorization. for more details ! how to implement this, see the " full svd " branch. - call stdlib_slaset('G', n, n-nr, zero, zero, v(1,nr+1), ldv) - call stdlib_sgesvd( 'O', 'N', n, n, v, ldv, s, u, ldu,u, ldu, work(n+1), & + call stdlib${ii}$_slaset('G', n, n-nr, zero, zero, v(1_${ik}$,nr+1), ldv) + call stdlib${ii}$_sgesvd( 'O', 'N', n, n, v, ldv, s, u, ldu,u, ldu, work(n+1), & lwork-n, info ) do p = 1, n do q = p + 1, n @@ -76384,20 +76385,20 @@ module stdlib_linalg_lapack_s v(p,q) = rtmp end do end do - call stdlib_slapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_slapmt( .false., n, n, v, ldv, iwork ) end if else ! Aply Stdlib_Sgesvd To R ! Copy R Into V And Overwrite V With The Right Singular Vectors - call stdlib_slacpy( 'U', nr, n, a, lda, v, ldv ) - if ( nr > 1 )call stdlib_slaset( 'L', nr-1, nr-1, zero, zero, v(2,1), ldv ) + call stdlib${ii}$_slacpy( 'U', nr, n, a, lda, v, ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_slaset( 'L', nr-1, nr-1, zero, zero, v(2_${ik}$,1_${ik}$), ldv ) ! .. the right singular vectors overwrite v, the nr left singular ! vectors stored in u(1:nr,1:nr) if ( wntvr .or. ( nr == n ) ) then - call stdlib_sgesvd( 'N', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & + call stdlib${ii}$_sgesvd( 'N', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & lwork-n, info ) - call stdlib_slapmt( .false., nr, n, v, ldv, iwork ) + call stdlib${ii}$_slapmt( .false., nr, n, v, ldv, iwork ) ! .. now [v](1:nr,1:n) contains v(1:n,1:nr)**t else ! .. need all n right singular vectors and nr < n @@ -76405,10 +76406,10 @@ module stdlib_linalg_lapack_s ! by padding a zero block. in the case nr << n, a more efficient ! way is to first use the lq factorization. for more details ! how to implement this, see the " full svd " branch. - call stdlib_slaset('G', n-nr, n, zero,zero, v(nr+1,1), ldv) - call stdlib_sgesvd( 'N', 'O', n, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & + call stdlib${ii}$_slaset('G', n-nr, n, zero,zero, v(nr+1,1_${ik}$), ldv) + call stdlib${ii}$_sgesvd( 'N', 'O', n, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & lwork-n, info ) - call stdlib_slapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_slapmt( .false., n, n, v, ldv, iwork ) end if ! .. now [v] contains the transposed matrix of the right singular ! vectors of a. @@ -76418,7 +76419,7 @@ module stdlib_linalg_lapack_s ! Full Svd Requested ! ....................................................................... if ( rtrans ) then - ! .. apply stdlib_sgesvd to r**t [[this option is left for r + ! .. apply stdlib${ii}$_sgesvd to r**t [[this option is left for r if ( wntvr .or. ( nr == n ) ) then ! .. copy r**t into [v] and overwrite [v] with the left singular ! vectors of r**t @@ -76427,10 +76428,10 @@ module stdlib_linalg_lapack_s v(q,p) = a(p,q) end do end do - if ( nr > 1 )call stdlib_slaset( 'U', nr-1,nr-1, zero,zero, v(1,2), ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_slaset( 'U', nr-1,nr-1, zero,zero, v(1_${ik}$,2_${ik}$), ldv ) ! .. the left singular vectors of r**t overwrite [v], the nr right ! singular vectors of r**t stored in [u](1:nr,1:nr) as transposed - call stdlib_sgesvd( 'O', 'A', n, nr, v, ldv, s, v, ldv,u, ldu, work(n+1), & + call stdlib${ii}$_sgesvd( 'O', 'A', n, nr, v, ldv, s, v, ldv,u, ldu, work(n+1), & lwork-n, info ) ! Assemble V do p = 1, nr @@ -76447,7 +76448,7 @@ module stdlib_linalg_lapack_s end do end do end if - call stdlib_slapmt( .false., nr, n, v, ldv, iwork ) + call stdlib${ii}$_slapmt( .false., nr, n, v, ldv, iwork ) do p = 1, nr do q = p + 1, nr rtmp = u(q,p) @@ -76456,10 +76457,10 @@ module stdlib_linalg_lapack_s end do end do if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_slaset('A', m-nr,nr, zero,zero, u(nr+1,1), ldu) + call stdlib${ii}$_slaset('A', m-nr,nr, zero,zero, u(nr+1,1_${ik}$), ldu) if ( nr < n1 ) then - call stdlib_slaset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) - call stdlib_slaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_slaset('A',nr,n1-nr,zero,zero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_slaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) end if end if else @@ -76469,19 +76470,19 @@ module stdlib_linalg_lapack_s ! [[the optimal ratio n/nr for using qrf instead of padding ! with zeros. here hard coded to 2; it must be at least ! two due to work space constraints.]] - ! optratio = stdlib_ilaenv(6, 'sgesvd', 's' // 'o', nr,n,0,0) + ! optratio = stdlib${ii}$_ilaenv(6, 'sgesvd', 's' // 'o', nr,n,0,0) ! optratio = max( optratio, 2 ) - optratio = 2 + optratio = 2_${ik}$ if ( optratio*nr > n ) then do p = 1, nr do q = p, n v(q,p) = a(p,q) end do end do - if ( nr > 1 )call stdlib_slaset('U',nr-1,nr-1, zero,zero, v(1,2),ldv) + if ( nr > 1_${ik}$ )call stdlib${ii}$_slaset('U',nr-1,nr-1, zero,zero, v(1_${ik}$,2_${ik}$),ldv) - call stdlib_slaset('A',n,n-nr,zero,zero,v(1,nr+1),ldv) - call stdlib_sgesvd( 'O', 'A', n, n, v, ldv, s, v, ldv,u, ldu, work(n+1), & + call stdlib${ii}$_slaset('A',n,n-nr,zero,zero,v(1_${ik}$,nr+1),ldv) + call stdlib${ii}$_sgesvd( 'O', 'A', n, n, v, ldv, s, v, ldv,u, ldu, work(n+1), & lwork-n, info ) do p = 1, n do q = p + 1, n @@ -76490,7 +76491,7 @@ module stdlib_linalg_lapack_s v(p,q) = rtmp end do end do - call stdlib_slapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_slapmt( .false., n, n, v, ldv, iwork ) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x n1), i.e. (m x n) or (m x m). do p = 1, n @@ -76501,10 +76502,10 @@ module stdlib_linalg_lapack_s end do end do if ( ( n < m ) .and. .not.(wntuf)) then - call stdlib_slaset('A',m-n,n,zero,zero,u(n+1,1),ldu) + call stdlib${ii}$_slaset('A',m-n,n,zero,zero,u(n+1,1_${ik}$),ldu) if ( n < n1 ) then - call stdlib_slaset('A',n,n1-n,zero,zero,u(1,n+1),ldu) - call stdlib_slaset('A',m-n,n1-n,zero,one,u(n+1,n+1), ldu ) + call stdlib${ii}$_slaset('A',n,n1-n,zero,zero,u(1_${ik}$,n+1),ldu) + call stdlib${ii}$_slaset('A',m-n,n1-n,zero,one,u(n+1,n+1), ldu ) end if end if else @@ -76515,55 +76516,55 @@ module stdlib_linalg_lapack_s u(q,nr+p) = a(p,q) end do end do - if ( nr > 1 )call stdlib_slaset('U',nr-1,nr-1,zero,zero,u(1,nr+2),ldu) + if ( nr > 1_${ik}$ )call stdlib${ii}$_slaset('U',nr-1,nr-1,zero,zero,u(1_${ik}$,nr+2),ldu) - call stdlib_sgeqrf( n, nr, u(1,nr+1), ldu, work(n+1),work(n+nr+1), lwork-& + call stdlib${ii}$_sgeqrf( n, nr, u(1_${ik}$,nr+1), ldu, work(n+1),work(n+nr+1), lwork-& n-nr, ierr ) do p = 1, nr do q = 1, n v(q,p) = u(p,nr+q) end do end do - call stdlib_slaset('U',nr-1,nr-1,zero,zero,v(1,2),ldv) - call stdlib_sgesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v,ldv, work(n+nr+1)& + call stdlib${ii}$_slaset('U',nr-1,nr-1,zero,zero,v(1_${ik}$,2_${ik}$),ldv) + call stdlib${ii}$_sgesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v,ldv, work(n+nr+1)& ,lwork-n-nr, info ) - call stdlib_slaset('A',n-nr,nr,zero,zero,v(nr+1,1),ldv) - call stdlib_slaset('A',nr,n-nr,zero,zero,v(1,nr+1),ldv) - call stdlib_slaset('A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv) - call stdlib_sormqr('R','C', n, n, nr, u(1,nr+1), ldu,work(n+1),v,ldv,work(& + call stdlib${ii}$_slaset('A',n-nr,nr,zero,zero,v(nr+1,1_${ik}$),ldv) + call stdlib${ii}$_slaset('A',nr,n-nr,zero,zero,v(1_${ik}$,nr+1),ldv) + call stdlib${ii}$_slaset('A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv) + call stdlib${ii}$_sormqr('R','C', n, n, nr, u(1_${ik}$,nr+1), ldu,work(n+1),v,ldv,work(& n+nr+1),lwork-n-nr,ierr) - call stdlib_slapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_slapmt( .false., n, n, v, ldv, iwork ) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_slaset('A',m-nr,nr,zero,zero,u(nr+1,1),ldu) + call stdlib${ii}$_slaset('A',m-nr,nr,zero,zero,u(nr+1,1_${ik}$),ldu) if ( nr < n1 ) then - call stdlib_slaset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) - call stdlib_slaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1),ldu) + call stdlib${ii}$_slaset('A',nr,n1-nr,zero,zero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_slaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1),ldu) end if end if end if end if else - ! .. apply stdlib_sgesvd to r [[this is the recommended option]] + ! .. apply stdlib${ii}$_sgesvd to r [[this is the recommended option]] if ( wntvr .or. ( nr == n ) ) then ! .. copy r into [v] and overwrite v with the right singular vectors - call stdlib_slacpy( 'U', nr, n, a, lda, v, ldv ) - if ( nr > 1 )call stdlib_slaset( 'L', nr-1,nr-1, zero,zero, v(2,1), ldv ) + call stdlib${ii}$_slacpy( 'U', nr, n, a, lda, v, ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_slaset( 'L', nr-1,nr-1, zero,zero, v(2_${ik}$,1_${ik}$), ldv ) ! .. the right singular vectors of r overwrite [v], the nr left ! singular vectors of r stored in [u](1:nr,1:nr) - call stdlib_sgesvd( 'S', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & + call stdlib${ii}$_sgesvd( 'S', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & lwork-n, info ) - call stdlib_slapmt( .false., nr, n, v, ldv, iwork ) + call stdlib${ii}$_slapmt( .false., nr, n, v, ldv, iwork ) ! .. now [v](1:nr,1:n) contains v(1:n,1:nr)**t ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_slaset('A', m-nr,nr, zero,zero, u(nr+1,1), ldu) + call stdlib${ii}$_slaset('A', m-nr,nr, zero,zero, u(nr+1,1_${ik}$), ldu) if ( nr < n1 ) then - call stdlib_slaset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) - call stdlib_slaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_slaset('A',nr,n1-nr,zero,zero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_slaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) end if end if else @@ -76573,54 +76574,54 @@ module stdlib_linalg_lapack_s ! [[the optimal ratio n/nr for using lq instead of padding ! with zeros. here hard coded to 2; it must be at least ! two due to work space constraints.]] - ! optratio = stdlib_ilaenv(6, 'sgesvd', 's' // 'o', nr,n,0,0) + ! optratio = stdlib${ii}$_ilaenv(6, 'sgesvd', 's' // 'o', nr,n,0,0) ! optratio = max( optratio, 2 ) - optratio = 2 + optratio = 2_${ik}$ if ( optratio * nr > n ) then - call stdlib_slacpy( 'U', nr, n, a, lda, v, ldv ) - if ( nr > 1 )call stdlib_slaset('L', nr-1,nr-1, zero,zero, v(2,1),ldv) + call stdlib${ii}$_slacpy( 'U', nr, n, a, lda, v, ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_slaset('L', nr-1,nr-1, zero,zero, v(2_${ik}$,1_${ik}$),ldv) ! .. the right singular vectors of r overwrite [v], the nr left ! singular vectors of r stored in [u](1:nr,1:nr) - call stdlib_slaset('A', n-nr,n, zero,zero, v(nr+1,1),ldv) - call stdlib_sgesvd( 'S', 'O', n, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & + call stdlib${ii}$_slaset('A', n-nr,n, zero,zero, v(nr+1,1_${ik}$),ldv) + call stdlib${ii}$_sgesvd( 'S', 'O', n, n, v, ldv, s, u, ldu,v, ldv, work(n+1), & lwork-n, info ) - call stdlib_slapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_slapmt( .false., n, n, v, ldv, iwork ) ! .. now [v] contains the transposed matrix of the right ! singular vectors of a. the leading n left singular vectors ! are in [u](1:n,1:n) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x n1), i.e. (m x n) or (m x m). if ( ( n < m ) .and. .not.(wntuf)) then - call stdlib_slaset('A',m-n,n,zero,zero,u(n+1,1),ldu) + call stdlib${ii}$_slaset('A',m-n,n,zero,zero,u(n+1,1_${ik}$),ldu) if ( n < n1 ) then - call stdlib_slaset('A',n,n1-n,zero,zero,u(1,n+1),ldu) - call stdlib_slaset( 'A',m-n,n1-n,zero,one,u(n+1,n+1), ldu ) + call stdlib${ii}$_slaset('A',n,n1-n,zero,zero,u(1_${ik}$,n+1),ldu) + call stdlib${ii}$_slaset( 'A',m-n,n1-n,zero,one,u(n+1,n+1), ldu ) end if end if else - call stdlib_slacpy( 'U', nr, n, a, lda, u(nr+1,1), ldu ) - if ( nr > 1 )call stdlib_slaset('L',nr-1,nr-1,zero,zero,u(nr+2,1),ldu) + call stdlib${ii}$_slacpy( 'U', nr, n, a, lda, u(nr+1,1_${ik}$), ldu ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_slaset('L',nr-1,nr-1,zero,zero,u(nr+2,1_${ik}$),ldu) - call stdlib_sgelqf( nr, n, u(nr+1,1), ldu, work(n+1),work(n+nr+1), lwork-n-& + call stdlib${ii}$_sgelqf( nr, n, u(nr+1,1_${ik}$), ldu, work(n+1),work(n+nr+1), lwork-n-& nr, ierr ) - call stdlib_slacpy('L',nr,nr,u(nr+1,1),ldu,v,ldv) - if ( nr > 1 )call stdlib_slaset('U',nr-1,nr-1,zero,zero,v(1,2),ldv) - call stdlib_sgesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v, ldv, work(n+nr+& - 1), lwork-n-nr, info ) - call stdlib_slaset('A',n-nr,nr,zero,zero,v(nr+1,1),ldv) - call stdlib_slaset('A',nr,n-nr,zero,zero,v(1,nr+1),ldv) - call stdlib_slaset('A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv) - call stdlib_sormlq('R','N',n,n,nr,u(nr+1,1),ldu,work(n+1),v, ldv, work(n+& + call stdlib${ii}$_slacpy('L',nr,nr,u(nr+1,1_${ik}$),ldu,v,ldv) + if ( nr > 1_${ik}$ )call stdlib${ii}$_slaset('U',nr-1,nr-1,zero,zero,v(1_${ik}$,2_${ik}$),ldv) + call stdlib${ii}$_sgesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v, ldv, work(n+nr+& + 1_${ik}$), lwork-n-nr, info ) + call stdlib${ii}$_slaset('A',n-nr,nr,zero,zero,v(nr+1,1_${ik}$),ldv) + call stdlib${ii}$_slaset('A',nr,n-nr,zero,zero,v(1_${ik}$,nr+1),ldv) + call stdlib${ii}$_slaset('A',n-nr,n-nr,zero,one,v(nr+1,nr+1),ldv) + call stdlib${ii}$_sormlq('R','N',n,n,nr,u(nr+1,1_${ik}$),ldu,work(n+1),v, ldv, work(n+& nr+1),lwork-n-nr,ierr) - call stdlib_slapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_slapmt( .false., n, n, v, ldv, iwork ) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_slaset('A',m-nr,nr,zero,zero,u(nr+1,1),ldu) + call stdlib${ii}$_slaset('A',m-nr,nr,zero,zero,u(nr+1,1_${ik}$),ldu) if ( nr < n1 ) then - call stdlib_slaset('A',nr,n1-nr,zero,zero,u(1,nr+1),ldu) - call stdlib_slaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_slaset('A',nr,n1-nr,zero,zero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_slaset( 'A',m-nr,n1-nr,zero,one,u(nr+1,nr+1), ldu ) end if end if end if @@ -76629,10 +76630,10 @@ module stdlib_linalg_lapack_s end if ! the q matrix from the first qrf is built into the left singular ! vectors matrix u. - if ( .not. wntuf )call stdlib_sormqr( 'L', 'N', m, n1, n, a, lda, work, u,ldu, work(& + if ( .not. wntuf )call stdlib${ii}$_sormqr( 'L', 'N', m, n1, n, a, lda, work, u,ldu, work(& n+1), lwork-n, ierr ) - if ( rowprm .and. .not.wntuf )call stdlib_slaswp( n1, u, ldu, 1, m-1, iwork(n+1), -& - 1 ) + if ( rowprm .and. .not.wntuf )call stdlib${ii}$_slaswp( n1, u, ldu, 1_${ik}$, m-1, iwork(n+1), -& + 1_${ik}$ ) ! ... end of the "full svd" branch end if ! check whether some singular values are returned as zeros, e.g. @@ -76640,27 +76641,27 @@ module stdlib_linalg_lapack_s p = nr do q = p, 1, -1 if ( s(q) > zero ) go to 4002 - nr = nr - 1 + nr = nr - 1_${ik}$ end do 4002 continue ! .. if numerical rank deficiency is detected, the truncated ! singular values are set to zero. - if ( nr < n ) call stdlib_slaset( 'G', n-nr,1, zero,zero, s(nr+1), n ) + if ( nr < n ) call stdlib${ii}$_slaset( 'G', n-nr,1_${ik}$, zero,zero, s(nr+1), n ) ! .. undo scaling; this may cause overflow in the largest singular ! values. - if ( ascaled )call stdlib_slascl( 'G',0,0, one,sqrt(real(m,KIND=sp)), nr,1, s, n, ierr & + if ( ascaled )call stdlib${ii}$_slascl( 'G',0_${ik}$,0_${ik}$, one,sqrt(real(m,KIND=sp)), nr,1_${ik}$, s, n, ierr & ) - if ( conda ) rwork(1) = sconda - rwork(2) = p - nr + if ( conda ) rwork(1_${ik}$) = sconda + rwork(2_${ik}$) = p - nr ! .. p-nr is the number of singular values that are computed as - ! exact zeros in stdlib_sgesvd() applied to the (possibly truncated) + ! exact zeros in stdlib${ii}$_sgesvd() applied to the (possibly truncated) ! full row rank triangular (trapezoidal) factor of a. numrank = nr return - end subroutine stdlib_sgesvdq + end subroutine stdlib${ii}$_sgesvdq - pure subroutine stdlib_sgesvj( joba, jobu, jobv, m, n, a, lda, sva, mv, v,ldv, work, lwork, & + pure subroutine stdlib${ii}$_sgesvj( joba, jobu, jobv, m, n, a, lda, sva, mv, v,ldv, work, lwork, & !! SGESVJ computes the singular value decomposition (SVD) of a real !! M-by-N matrix A, where M >= N. The SVD of A is written as !! [++] [xx] [x0] [xx] @@ -76677,27 +76678,27 @@ 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, ldv, lwork, m, mv, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldv, lwork, m, mv, n character, intent(in) :: joba, jobu, jobv ! Array Arguments real(sp), intent(inout) :: a(lda,*), v(ldv,*), work(lwork) real(sp), intent(out) :: sva(n) ! ===================================================================== ! Local Parameters - integer(ilp), parameter :: nsweep = 30 + integer(${ik}$), parameter :: nsweep = 30_${ik}$ ! Local Scalars real(sp) :: aapp, aapp0, aapq, aaqq, apoaq, aqoap, big, bigtheta, cs, ctol, epsln, & large, mxaapq, mxsinj, rootbig, rooteps, rootsfmin, roottol, skl, sfmin, small, sn, t, & temp1, theta, thsign, tol - integer(ilp) :: blskip, emptsw, i, ibr, ierr, igl, ijblsk, ir1, iswrot, jbc, jgl, kbl, & + integer(${ik}$) :: blskip, emptsw, i, ibr, ierr, igl, ijblsk, ir1, iswrot, jbc, jgl, kbl, & lkahead, mvl, n2, n34, n4, nbl, notrot, p, pskipped, q, rowskip, swband logical(lk) :: applv, goscale, lower, lsvec, noscale, rotok, rsvec, uctol, & upper ! Local Arrays - real(sp) :: fastr(5) + real(sp) :: fastr(5_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,min,float,sign,sqrt ! from lapack @@ -76711,31 +76712,31 @@ module stdlib_linalg_lapack_s upper = stdlib_lsame( joba, 'U' ) lower = stdlib_lsame( joba, 'L' ) if( .not.( upper .or. lower .or. stdlib_lsame( joba, 'G' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( lsvec .or. uctol .or. stdlib_lsame( jobu, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( rsvec .or. applv .or. stdlib_lsame( jobv, 'N' ) ) ) then - info = -3 - else if( m<0 ) then - info = -4 - else if( ( n<0 ) .or. ( n>m ) ) then - info = -5 + info = -3_${ik}$ + else if( m<0_${ik}$ ) then + info = -4_${ik}$ + else if( ( n<0_${ik}$ ) .or. ( n>m ) ) then + info = -5_${ik}$ else if( lda=one ) then - info = -4 - call stdlib_xerbla( 'SGESVJ', -info ) + info = -4_${ik}$ + call stdlib${ii}$_xerbla( 'SGESVJ', -info ) return end if ! initialize the right singular vector matrix. if( rsvec ) then mvl = n - call stdlib_slaset( 'A', mvl, n, zero, one, v, ldv ) + call stdlib${ii}$_slaset( 'A', mvl, n, zero, one, v, ldv ) else if( applv ) then mvl = mv end if @@ -76798,10 +76799,10 @@ module stdlib_linalg_lapack_s do p = 1, n aapp = zero aaqq = one - call stdlib_slassq( m-p+1, a( p, p ), 1, aapp, aaqq ) + call stdlib${ii}$_slassq( m-p+1, a( p, p ), 1_${ik}$, aapp, aaqq ) if( aapp>big ) then - info = -6 - call stdlib_xerbla( 'SGESVJ', -info ) + info = -6_${ik}$ + call stdlib${ii}$_xerbla( 'SGESVJ', -info ) return end if aaqq = sqrt( aaqq ) @@ -76823,10 +76824,10 @@ module stdlib_linalg_lapack_s do p = 1, n aapp = zero aaqq = one - call stdlib_slassq( p, a( 1, p ), 1, aapp, aaqq ) + call stdlib${ii}$_slassq( p, a( 1_${ik}$, p ), 1_${ik}$, aapp, aaqq ) if( aapp>big ) then - info = -6 - call stdlib_xerbla( 'SGESVJ', -info ) + info = -6_${ik}$ + call stdlib${ii}$_xerbla( 'SGESVJ', -info ) return end if aaqq = sqrt( aaqq ) @@ -76848,10 +76849,10 @@ module stdlib_linalg_lapack_s do p = 1, n aapp = zero aaqq = one - call stdlib_slassq( m, a( 1, p ), 1, aapp, aaqq ) + call stdlib${ii}$_slassq( m, a( 1_${ik}$, p ), 1_${ik}$, aapp, aaqq ) if( aapp>big ) then - info = -6 - call stdlib_xerbla( 'SGESVJ', -info ) + info = -6_${ik}$ + call stdlib${ii}$_xerbla( 'SGESVJ', -info ) return end if aaqq = sqrt( aaqq ) @@ -76881,29 +76882,29 @@ module stdlib_linalg_lapack_s end do ! #:) quick return for zero matrix if( aapp==zero ) then - if( lsvec )call stdlib_slaset( 'G', m, n, zero, one, a, lda ) - work( 1 ) = one - work( 2 ) = zero - work( 3 ) = zero - work( 4 ) = zero - work( 5 ) = zero - work( 6 ) = zero + if( lsvec )call stdlib${ii}$_slaset( 'G', m, n, zero, one, a, lda ) + work( 1_${ik}$ ) = one + work( 2_${ik}$ ) = zero + work( 3_${ik}$ ) = zero + work( 4_${ik}$ ) = zero + work( 5_${ik}$ ) = zero + work( 6_${ik}$ ) = zero return end if ! #:) quick return for one-column matrix - if( n==1 ) then - if( lsvec )call stdlib_slascl( 'G', 0, 0, sva( 1 ), skl, m, 1,a( 1, 1 ), lda, ierr ) + if( n==1_${ik}$ ) then + if( lsvec )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, sva( 1_${ik}$ ), skl, m, 1_${ik}$,a( 1_${ik}$, 1_${ik}$ ), lda, ierr ) - work( 1 ) = one / skl - if( sva( 1 )>=sfmin ) then - work( 2 ) = one + work( 1_${ik}$ ) = one / skl + if( sva( 1_${ik}$ )>=sfmin ) then + work( 2_${ik}$ ) = one else - work( 2 ) = zero + work( 2_${ik}$ ) = zero end if - work( 3 ) = zero - work( 4 ) = zero - work( 5 ) = zero - work( 6 ) = zero + work( 3_${ik}$ ) = zero + work( 4_${ik}$ ) = zero + work( 5_${ik}$ ) = zero + work( 6_${ik}$ ) = zero return end if ! protect small singular values from underflow, and try to @@ -76932,57 +76933,57 @@ module stdlib_linalg_lapack_s end if ! scale, if necessary if( temp1/=one ) then - call stdlib_slascl( 'G', 0, 0, one, temp1, n, 1, sva, n, ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, one, temp1, n, 1_${ik}$, sva, n, ierr ) end if skl = temp1*skl if( skl/=one ) then - call stdlib_slascl( joba, 0, 0, one, skl, m, n, a, lda, ierr ) + call stdlib${ii}$_slascl( joba, 0_${ik}$, 0_${ik}$, one, skl, m, n, a, lda, ierr ) skl = one / skl end if ! row-cyclic jacobi svd algorithm with column pivoting - emptsw = ( n*( n-1 ) ) / 2 - notrot = 0 - fastr( 1 ) = zero + emptsw = ( n*( n-1 ) ) / 2_${ik}$ + notrot = 0_${ik}$ + fastr( 1_${ik}$ ) = zero ! a is represented in factored form a = a * diag(work), where diag(work) ! is initialized to identity. work is updated during fast scaled ! rotations. do q = 1, n work( q ) = one end do - swband = 3 + swband = 3_${ik}$ ! [tp] swband is a tuning parameter [tp]. it is meaningful and effective - ! if stdlib_sgesvj is used as a computational routine in the preconditioned - ! jacobi svd algorithm stdlib_sgesvj. for sweeps i=1:swband the procedure + ! if stdlib${ii}$_sgesvj is used as a computational routine in the preconditioned + ! jacobi svd algorithm stdlib${ii}$_sgesvj. for sweeps i=1:swband the procedure ! works on pivots inside a band-like region around the diagonal. ! the boundaries are determined dynamically, based on the number of ! pivots above a threshold. - kbl = min( 8, n ) + kbl = min( 8_${ik}$, n ) ! [tp] kbl is a tuning parameter that defines the tile size in the ! tiling of the p-q loops of pivot pairs. in general, an optimal ! value of kbl depends on the matrix dimensions and on the ! parameters of the computer's memory. nbl = n / kbl - if( ( nbl*kbl )/=n )nbl = nbl + 1 - blskip = kbl**2 + if( ( nbl*kbl )/=n )nbl = nbl + 1_${ik}$ + blskip = kbl**2_${ik}$ ! [tp] blkskip is a tuning parameter that depends on swband and kbl. - rowskip = min( 5, kbl ) + rowskip = min( 5_${ik}$, kbl ) ! [tp] rowskip is a tuning parameter. - lkahead = 1 + lkahead = 1_${ik}$ ! [tp] lkahead is a tuning parameter. ! quasi block transformations, using the lower (upper) triangular ! structure of the input matrix. the quasi-block-cycling usually ! invokes cubic convergence. big part of this cycle is done inside ! canonical subspaces of dimensions less than m. - if( ( lower .or. upper ) .and. ( n>max( 64, 4*kbl ) ) ) then + if( ( lower .or. upper ) .and. ( n>max( 64_${ik}$, 4_${ik}$*kbl ) ) ) then ! [tp] the number of partition levels and the actual partition are ! tuning parameters. - n4 = n / 4 - n2 = n / 2 - n34 = 3*n4 + n4 = n / 4_${ik}$ + n2 = n / 2_${ik}$ + n34 = 3_${ik}$*n4 if( applv ) then - q = 0 + q = 0_${ik}$ else - q = 1 + q = 1_${ik}$ end if if( lower ) then ! this works very well on lower triangular matrices, in particular @@ -76992,32 +76993,32 @@ module stdlib_linalg_lapack_s ! [+ + 0 0] [0 0] ! [+ + x 0] actually work on [x 0] [x 0] ! [+ + x x] [x x]. [x x] - call stdlib_sgsvj0( jobv, m-n34, n-n34, a( n34+1, n34+1 ), lda,work( n34+1 ), & - sva( n34+1 ), mvl,v( n34*q+1, n34+1 ), ldv, epsln, sfmin, tol,2, work( n+1 ), & + call stdlib${ii}$_sgsvj0( jobv, m-n34, n-n34, a( n34+1, n34+1 ), lda,work( n34+1 ), & + sva( n34+1 ), mvl,v( n34*q+1, n34+1 ), ldv, epsln, sfmin, tol,2_${ik}$, work( n+1 ), & lwork-n, ierr ) - call stdlib_sgsvj0( jobv, m-n2, n34-n2, a( n2+1, n2+1 ), lda,work( n2+1 ), sva( & - n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 2,work( n+1 ), lwork-n, & + call stdlib${ii}$_sgsvj0( jobv, m-n2, n34-n2, a( n2+1, n2+1 ), lda,work( n2+1 ), sva( & + n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 2_${ik}$,work( n+1 ), lwork-n, & ierr ) - call stdlib_sgsvj1( jobv, m-n2, n-n2, n4, a( n2+1, n2+1 ), lda,work( n2+1 ), sva(& - n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1,work( n+1 ), lwork-n, & + call stdlib${ii}$_sgsvj1( jobv, m-n2, n-n2, n4, a( n2+1, n2+1 ), lda,work( n2+1 ), sva(& + n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1_${ik}$,work( n+1 ), lwork-n, & ierr ) - call stdlib_sgsvj0( jobv, m-n4, n2-n4, a( n4+1, n4+1 ), lda,work( n4+1 ), sva( & - n4+1 ), mvl,v( n4*q+1, n4+1 ), ldv, epsln, sfmin, tol, 1,work( n+1 ), lwork-n, & + call stdlib${ii}$_sgsvj0( jobv, m-n4, n2-n4, a( n4+1, n4+1 ), lda,work( n4+1 ), sva( & + n4+1 ), mvl,v( n4*q+1, n4+1 ), ldv, epsln, sfmin, tol, 1_${ik}$,work( n+1 ), lwork-n, & ierr ) - call stdlib_sgsvj0( jobv, m, n4, a, lda, work, sva, mvl, v, ldv,epsln, sfmin, & - tol, 1, work( n+1 ), lwork-n,ierr ) - call stdlib_sgsvj1( jobv, m, n2, n4, a, lda, work, sva, mvl, v,ldv, epsln, sfmin,& - tol, 1, work( n+1 ),lwork-n, ierr ) + call stdlib${ii}$_sgsvj0( jobv, m, n4, a, lda, work, sva, mvl, v, ldv,epsln, sfmin, & + tol, 1_${ik}$, work( n+1 ), lwork-n,ierr ) + call stdlib${ii}$_sgsvj1( jobv, m, n2, n4, a, lda, work, sva, mvl, v,ldv, epsln, sfmin,& + tol, 1_${ik}$, work( n+1 ),lwork-n, ierr ) else if( upper ) then - call stdlib_sgsvj0( jobv, n4, n4, a, lda, work, sva, mvl, v, ldv,epsln, sfmin, & - tol, 2, work( n+1 ), lwork-n,ierr ) - call stdlib_sgsvj0( jobv, n2, n4, a( 1, n4+1 ), lda, work( n4+1 ),sva( n4+1 ), & - mvl, v( n4*q+1, n4+1 ), ldv,epsln, sfmin, tol, 1, work( n+1 ), lwork-n,ierr ) + call stdlib${ii}$_sgsvj0( jobv, n4, n4, a, lda, work, sva, mvl, v, ldv,epsln, sfmin, & + tol, 2_${ik}$, work( n+1 ), lwork-n,ierr ) + call stdlib${ii}$_sgsvj0( jobv, n2, n4, a( 1_${ik}$, n4+1 ), lda, work( n4+1 ),sva( n4+1 ), & + mvl, v( n4*q+1, n4+1 ), ldv,epsln, sfmin, tol, 1_${ik}$, work( n+1 ), lwork-n,ierr ) - call stdlib_sgsvj1( jobv, n2, n2, n4, a, lda, work, sva, mvl, v,ldv, epsln, & - sfmin, tol, 1, work( n+1 ),lwork-n, ierr ) - call stdlib_sgsvj0( jobv, n2+n4, n4, a( 1, n2+1 ), lda,work( n2+1 ), sva( n2+1 ),& - mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1,work( n+1 ), lwork-n, ierr ) + call stdlib${ii}$_sgsvj1( jobv, n2, n2, n4, a, lda, work, sva, mvl, v,ldv, epsln, & + sfmin, tol, 1_${ik}$, work( n+1 ),lwork-n, ierr ) + call stdlib${ii}$_sgsvj0( jobv, n2+n4, n4, a( 1_${ik}$, n2+1 ), lda,work( n2+1 ), sva( n2+1 ),& + mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1_${ik}$,work( n+1 ), lwork-n, ierr ) end if end if @@ -77026,23 +77027,23 @@ module stdlib_linalg_lapack_s ! .. go go go ... mxaapq = zero mxsinj = zero - iswrot = 0 - notrot = 0 - pskipped = 0 + iswrot = 0_${ik}$ + notrot = 0_${ik}$ + pskipped = 0_${ik}$ ! each sweep is unrolled using kbl-by-kbl tiles over the pivot pairs ! 1 <= p < q <= n. this is the first step toward a blocked implementation ! of the rotations. new implementation, based on block transformations, ! is under development. loop_2000: do ibr = 1, nbl - igl = ( ibr-1 )*kbl + 1 + igl = ( ibr-1 )*kbl + 1_${ik}$ loop_1002: do ir1 = 0, min( lkahead, nbl-ibr ) igl = igl + ir1*kbl loop_2001: do p = igl, min( igl+kbl-1, n-1 ) ! .. de rijk's pivoting - q = stdlib_isamax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib${ii}$_isamax( n-p+1, sva( p ), 1_${ik}$ ) + p - 1_${ik}$ if( p/=q ) then - call stdlib_sswap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_sswap( mvl, v( 1, p ), 1,v( 1, q ), 1 ) + call stdlib${ii}$_sswap( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) + if( rsvec )call stdlib${ii}$_sswap( mvl, v( 1_${ik}$, p ), 1_${ik}$,v( 1_${ik}$, q ), 1_${ik}$ ) temp1 = sva( p ) sva( p ) = sva( q ) sva( q ) = temp1 @@ -77050,24 +77051,24 @@ module stdlib_linalg_lapack_s work( p ) = work( q ) work( q ) = temp1 end if - if( ir1==0 ) then + if( ir1==0_${ik}$ ) then ! column norms are periodically updated by explicit ! norm computation. ! caveat: - ! unfortunately, some blas implementations compute stdlib_snrm2(m,a(1,p),1) - ! as sqrt(stdlib_sdot(m,a(1,p),1,a(1,p),1)), which may cause the result to + ! unfortunately, some blas implementations compute stdlib${ii}$_snrm2(m,a(1,p),1) + ! as sqrt(stdlib${ii}$_sdot(m,a(1,p),1,a(1,p),1)), which may cause the result to ! overflow for ||a(:,p)||_2 > sqrt(overflow_threshold), and to ! underflow for ||a(:,p)||_2 < sqrt(underflow_threshold). - ! hence, stdlib_snrm2 cannot be trusted, not even in the case when + ! hence, stdlib${ii}$_snrm2 cannot be trusted, not even in the case when ! the true norm is far from the under(over)flow boundaries. - ! if properly implemented stdlib_snrm2 is available, the if-then-else - ! below should read "aapp = stdlib_snrm2( m, a(1,p), 1 ) * work(p)". + ! if properly implemented stdlib${ii}$_snrm2 is available, the if-then-else + ! below should read "aapp = stdlib${ii}$_snrm2( m, a(1,p), 1 ) * work(p)". if( ( sva( p )rootsfmin ) ) then - sva( p ) = stdlib_snrm2( m, a( 1, p ), 1 )*work( p ) + sva( p ) = stdlib${ii}$_snrm2( m, a( 1_${ik}$, p ), 1_${ik}$ )*work( p ) else temp1 = zero aapp = one - call stdlib_slassq( m, a( 1, p ), 1, temp1, aapp ) + call stdlib${ii}$_slassq( m, a( 1_${ik}$, p ), 1_${ik}$, temp1, aapp ) sva( p ) = temp1*sqrt( aapp )*work( p ) end if aapp = sva( p ) @@ -77075,7 +77076,7 @@ module stdlib_linalg_lapack_s aapp = sva( p ) end if if( aapp>zero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2002: do q = p + 1, min( igl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -77083,25 +77084,25 @@ module stdlib_linalg_lapack_s if( aaqq>=one ) then rotok = ( small*aapp )<=aaqq if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_sdot( m, a( 1, p ), 1, a( 1,q ), 1 )*work( & + aapq = ( stdlib${ii}$_sdot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*work( & p )*work( q ) /aaqq ) / aapp else - call stdlib_scopy( m, a( 1, p ), 1,work( n+1 ), 1 ) - call stdlib_slascl( 'G', 0, 0, aapp,work( p ), m, 1,work( n+& - 1 ), lda, ierr ) - aapq = stdlib_sdot( m, work( n+1 ), 1,a( 1, q ), 1 )*work( & + call stdlib${ii}$_scopy( m, a( 1_${ik}$, p ), 1_${ik}$,work( n+1 ), 1_${ik}$ ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aapp,work( p ), m, 1_${ik}$,work( n+& + 1_${ik}$ ), lda, ierr ) + aapq = stdlib${ii}$_sdot( m, work( n+1 ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ )*work( & q ) / aaqq end if else rotok = aapp<=( aaqq / small ) if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_sdot( m, a( 1, p ), 1, a( 1,q ), 1 )*work( & + aapq = ( stdlib${ii}$_sdot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*work( & p )*work( q ) /aaqq ) / aapp else - call stdlib_scopy( m, a( 1, q ), 1,work( n+1 ), 1 ) - call stdlib_slascl( 'G', 0, 0, aaqq,work( q ), m, 1,work( n+& - 1 ), lda, ierr ) - aapq = stdlib_sdot( m, work( n+1 ), 1,a( 1, p ), 1 )*work( & + call stdlib${ii}$_scopy( m, a( 1_${ik}$, q ), 1_${ik}$,work( n+1 ), 1_${ik}$ ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aaqq,work( q ), m, 1_${ik}$,work( n+& + 1_${ik}$ ), lda, ierr ) + aapq = stdlib${ii}$_sdot( m, work( n+1 ), 1_${ik}$,a( 1_${ik}$, p ), 1_${ik}$ )*work( & p ) / aapp end if end if @@ -77110,10 +77111,10 @@ module stdlib_linalg_lapack_s if( abs( aapq )>tol ) then ! Rotate ! [rtd] rotated = rotated + one - if( ir1==0 ) then - notrot = 0 - pskipped = 0 - iswrot = iswrot + 1 + if( ir1==0_${ik}$ ) then + notrot = 0_${ik}$ + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ end if if( rotok ) then aqoap = aaqq / aapp @@ -77121,12 +77122,12 @@ module stdlib_linalg_lapack_s theta = -half*abs( aqoap-apoaq ) / aapq if( abs( theta )>bigtheta ) then t = half / theta - fastr( 3 ) = t*work( p ) / work( q ) - fastr( 4 ) = -t*work( q ) /work( p ) - call stdlib_srotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) + fastr( 3_${ik}$ ) = t*work( p ) / work( q ) + fastr( 4_${ik}$ ) = -t*work( q ) /work( p ) + call stdlib${ii}$_srotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$, fastr ) - if( rsvec )call stdlib_srotm( mvl,v( 1, p ), 1,v( 1, q ),& - 1,fastr ) + if( rsvec )call stdlib${ii}$_srotm( mvl,v( 1_${ik}$, p ), 1_${ik}$,v( 1_${ik}$, q ),& + 1_${ik}$,fastr ) sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq ) ) @@ -77146,68 +77147,68 @@ module stdlib_linalg_lapack_s aqoap = work( q ) / work( p ) if( work( p )>=one ) then if( work( q )>=one ) then - fastr( 3 ) = t*apoaq - fastr( 4 ) = -t*aqoap + fastr( 3_${ik}$ ) = t*apoaq + fastr( 4_${ik}$ ) = -t*aqoap work( p ) = work( p )*cs work( q ) = work( q )*cs - call stdlib_srotm( m, a( 1, p ), 1,a( 1, q ), 1,& + call stdlib${ii}$_srotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$,& fastr ) - if( rsvec )call stdlib_srotm( mvl,v( 1, p ), 1, v( & - 1, q ),1, fastr ) + if( rsvec )call stdlib${ii}$_srotm( mvl,v( 1_${ik}$, p ), 1_${ik}$, v( & + 1_${ik}$, q ),1_${ik}$, fastr ) else - call stdlib_saxpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & - p ), 1 ) - call stdlib_saxpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & - 1, q ), 1 ) + call stdlib${ii}$_saxpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( 1_${ik}$, & + p ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( & + 1_${ik}$, q ), 1_${ik}$ ) work( p ) = work( p )*cs work( q ) = work( q ) / cs if( rsvec ) then - call stdlib_saxpy( mvl, -t*aqoap,v( 1, q ), 1,v(& - 1, p ), 1 ) - call stdlib_saxpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& - v( 1, q ), 1 ) + call stdlib${ii}$_saxpy( mvl, -t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,v(& + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ), 1_${ik}$,& + v( 1_${ik}$, q ), 1_${ik}$ ) end if end if else if( work( q )>=one ) then - call stdlib_saxpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & - ), 1 ) - call stdlib_saxpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) + call stdlib${ii}$_saxpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q & + ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( m, -cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) work( p ) = work( p ) / cs work( q ) = work( q )*cs if( rsvec ) then - call stdlib_saxpy( mvl, t*apoaq,v( 1, p ), 1,v( & - 1, q ), 1 ) - call stdlib_saxpy( mvl,-cs*sn*aqoap,v( 1, q ), & - 1,v( 1, p ), 1 ) + call stdlib${ii}$_saxpy( mvl, t*apoaq,v( 1_${ik}$, p ), 1_${ik}$,v( & + 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q ), & + 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if else if( work( p )>=work( q ) )then - call stdlib_saxpy( m, -t*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) - call stdlib_saxpy( m, cs*sn*apoaq,a( 1, p ), 1,& - a( 1, q ), 1 ) + call stdlib${ii}$_saxpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,& + a( 1_${ik}$, q ), 1_${ik}$ ) work( p ) = work( p )*cs work( q ) = work( q ) / cs if( rsvec ) then - call stdlib_saxpy( mvl,-t*aqoap,v( 1, q ), 1,& - v( 1, p ), 1 ) - call stdlib_saxpy( mvl,cs*sn*apoaq,v( 1, p ),& - 1,v( 1, q ), 1 ) + call stdlib${ii}$_saxpy( mvl,-t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,& + v( 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ),& + 1_${ik}$,v( 1_${ik}$, q ), 1_${ik}$ ) end if else - call stdlib_saxpy( m, t*apoaq,a( 1, p ), 1,a( 1,& - q ), 1 ) - call stdlib_saxpy( m,-cs*sn*aqoap,a( 1, q ), 1,& - a( 1, p ), 1 ) + call stdlib${ii}$_saxpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$,& + q ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( m,-cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,& + a( 1_${ik}$, p ), 1_${ik}$ ) work( p ) = work( p ) / cs work( q ) = work( q )*cs if( rsvec ) then - call stdlib_saxpy( mvl,t*apoaq, v( 1, p ),1, & - v( 1, q ), 1 ) - call stdlib_saxpy( mvl,-cs*sn*aqoap,v( 1, q )& - , 1,v( 1, p ), 1 ) + call stdlib${ii}$_saxpy( mvl,t*apoaq, v( 1_${ik}$, p ),1_${ik}$, & + v( 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q )& + , 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if end if end if @@ -77215,15 +77216,15 @@ module stdlib_linalg_lapack_s end if else ! .. have to use modified gram-schmidt like transformation - call stdlib_scopy( m, a( 1, p ), 1,work( n+1 ), 1 ) - call stdlib_slascl( 'G', 0, 0, aapp, one, m,1, work( n+1 ), & + call stdlib${ii}$_scopy( m, a( 1_${ik}$, p ), 1_${ik}$,work( n+1 ), 1_${ik}$ ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one, m,1_${ik}$, work( n+1 ), & lda,ierr ) - call stdlib_slascl( 'G', 0, 0, aaqq, one, m,1, a( 1, q ), & + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one, m,1_${ik}$, a( 1_${ik}$, q ), & lda, ierr ) temp1 = -aapq*work( p ) / work( q ) - call stdlib_saxpy( m, temp1, work( n+1 ), 1,a( 1, q ), 1 ) + call stdlib${ii}$_saxpy( m, temp1, work( n+1 ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) - call stdlib_slascl( 'G', 0, 0, one, aaqq, m,1, a( 1, q ), & + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq, m,1_${ik}$, a( 1_${ik}$, q ), & lda, ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) @@ -77231,42 +77232,42 @@ module stdlib_linalg_lapack_s ! end if rotok then ... else ! in the case of cancellation in updating sva(q), sva(p) ! recompute sva(q), sva(p). - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_snrm2( m, a( 1, q ), 1 )*work( q ) + sva( q ) = stdlib${ii}$_snrm2( m, a( 1_${ik}$, q ), 1_${ik}$ )*work( q ) else t = zero aaqq = one - call stdlib_slassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_slassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq )*work( q ) end if end if if( ( aapp / aapp0 )<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_snrm2( m, a( 1, p ), 1 )*work( p ) + aapp = stdlib${ii}$_snrm2( m, a( 1_${ik}$, p ), 1_${ik}$ )*work( p ) else t = zero aapp = one - call stdlib_slassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_slassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp )*work( p ) end if sva( p ) = aapp end if else ! a(:,p) and a(:,q) already numerically orthogonal - if( ir1==0 )notrot = notrot + 1 + if( ir1==0_${ik}$ )notrot = notrot + 1_${ik}$ ! [rtd] skipped = skipped + 1 - pskipped = pskipped + 1 + pskipped = pskipped + 1_${ik}$ end if else ! a(:,q) is zero column - if( ir1==0 )notrot = notrot + 1 - pskipped = pskipped + 1 + if( ir1==0_${ik}$ )notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then - if( ir1==0 )aapp = -aapp - notrot = 0 + if( ir1==0_${ik}$ )aapp = -aapp + notrot = 0_${ik}$ go to 2103 end if end do loop_2002 @@ -77276,7 +77277,7 @@ module stdlib_linalg_lapack_s sva( p ) = aapp else sva( p ) = aapp - if( ( ir1==0 ) .and. ( aapp==zero ) )notrot = notrot + min( igl+kbl-1, & + if( ( ir1==0_${ik}$ ) .and. ( aapp==zero ) )notrot = notrot + min( igl+kbl-1, & n ) - p end if end do loop_2001 @@ -77285,15 +77286,15 @@ module stdlib_linalg_lapack_s end do loop_1002 ! end of ir1-loop ! ... go to the off diagonal blocks - igl = ( ibr-1 )*kbl + 1 + igl = ( ibr-1 )*kbl + 1_${ik}$ loop_2010: do jbc = ibr + 1, nbl - jgl = ( jbc-1 )*kbl + 1 + jgl = ( jbc-1 )*kbl + 1_${ik}$ ! doing the block at ( ibr, jbc ) - ijblsk = 0 + ijblsk = 0_${ik}$ loop_2100: do p = igl, min( igl+kbl-1, n ) aapp = sva( p ) if( aapp>zero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2200: do q = jgl, min( jgl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -77307,13 +77308,13 @@ module stdlib_linalg_lapack_s rotok = ( small*aaqq )<=aapp end if if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_sdot( m, a( 1, p ), 1, a( 1,q ), 1 )*work( & + aapq = ( stdlib${ii}$_sdot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*work( & p )*work( q ) /aaqq ) / aapp else - call stdlib_scopy( m, a( 1, p ), 1,work( n+1 ), 1 ) - call stdlib_slascl( 'G', 0, 0, aapp,work( p ), m, 1,work( n+& - 1 ), lda, ierr ) - aapq = stdlib_sdot( m, work( n+1 ), 1,a( 1, q ), 1 )*work( & + call stdlib${ii}$_scopy( m, a( 1_${ik}$, p ), 1_${ik}$,work( n+1 ), 1_${ik}$ ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aapp,work( p ), m, 1_${ik}$,work( n+& + 1_${ik}$ ), lda, ierr ) + aapq = stdlib${ii}$_sdot( m, work( n+1 ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ )*work( & q ) / aaqq end if else @@ -77323,23 +77324,23 @@ module stdlib_linalg_lapack_s rotok = aaqq<=( aapp / small ) end if if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_sdot( m, a( 1, p ), 1, a( 1,q ), 1 )*work( & + aapq = ( stdlib${ii}$_sdot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*work( & p )*work( q ) /aaqq ) / aapp else - call stdlib_scopy( m, a( 1, q ), 1,work( n+1 ), 1 ) - call stdlib_slascl( 'G', 0, 0, aaqq,work( q ), m, 1,work( n+& - 1 ), lda, ierr ) - aapq = stdlib_sdot( m, work( n+1 ), 1,a( 1, p ), 1 )*work( & + call stdlib${ii}$_scopy( m, a( 1_${ik}$, q ), 1_${ik}$,work( n+1 ), 1_${ik}$ ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aaqq,work( q ), m, 1_${ik}$,work( n+& + 1_${ik}$ ), lda, ierr ) + aapq = stdlib${ii}$_sdot( m, work( n+1 ), 1_${ik}$,a( 1_${ik}$, p ), 1_${ik}$ )*work( & p ) / aapp end if end if mxaapq = max( mxaapq, abs( aapq ) ) ! to rotate or not to rotate, that is the question ... if( abs( aapq )>tol ) then - notrot = 0 + notrot = 0_${ik}$ ! [rtd] rotated = rotated + 1 - pskipped = 0 - iswrot = iswrot + 1 + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ if( rotok ) then aqoap = aaqq / aapp apoaq = aapp / aaqq @@ -77347,12 +77348,12 @@ module stdlib_linalg_lapack_s if( aaqq>aapp0 )theta = -theta if( abs( theta )>bigtheta ) then t = half / theta - fastr( 3 ) = t*work( p ) / work( q ) - fastr( 4 ) = -t*work( q ) /work( p ) - call stdlib_srotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) + fastr( 3_${ik}$ ) = t*work( p ) / work( q ) + fastr( 4_${ik}$ ) = -t*work( q ) /work( p ) + call stdlib${ii}$_srotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$, fastr ) - if( rsvec )call stdlib_srotm( mvl,v( 1, p ), 1,v( 1, q ),& - 1,fastr ) + if( rsvec )call stdlib${ii}$_srotm( mvl,v( 1_${ik}$, p ), 1_${ik}$,v( 1_${ik}$, q ),& + 1_${ik}$,fastr ) sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq ) ) @@ -77373,68 +77374,68 @@ module stdlib_linalg_lapack_s aqoap = work( q ) / work( p ) if( work( p )>=one ) then if( work( q )>=one ) then - fastr( 3 ) = t*apoaq - fastr( 4 ) = -t*aqoap + fastr( 3_${ik}$ ) = t*apoaq + fastr( 4_${ik}$ ) = -t*aqoap work( p ) = work( p )*cs work( q ) = work( q )*cs - call stdlib_srotm( m, a( 1, p ), 1,a( 1, q ), 1,& + call stdlib${ii}$_srotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$,& fastr ) - if( rsvec )call stdlib_srotm( mvl,v( 1, p ), 1, v( & - 1, q ),1, fastr ) + if( rsvec )call stdlib${ii}$_srotm( mvl,v( 1_${ik}$, p ), 1_${ik}$, v( & + 1_${ik}$, q ),1_${ik}$, fastr ) else - call stdlib_saxpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & - p ), 1 ) - call stdlib_saxpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & - 1, q ), 1 ) + call stdlib${ii}$_saxpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( 1_${ik}$, & + p ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( & + 1_${ik}$, q ), 1_${ik}$ ) if( rsvec ) then - call stdlib_saxpy( mvl, -t*aqoap,v( 1, q ), 1,v(& - 1, p ), 1 ) - call stdlib_saxpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& - v( 1, q ), 1 ) + call stdlib${ii}$_saxpy( mvl, -t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,v(& + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ), 1_${ik}$,& + v( 1_${ik}$, q ), 1_${ik}$ ) end if work( p ) = work( p )*cs work( q ) = work( q ) / cs end if else if( work( q )>=one ) then - call stdlib_saxpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & - ), 1 ) - call stdlib_saxpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) + call stdlib${ii}$_saxpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q & + ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( m, -cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) if( rsvec ) then - call stdlib_saxpy( mvl, t*apoaq,v( 1, p ), 1,v( & - 1, q ), 1 ) - call stdlib_saxpy( mvl,-cs*sn*aqoap,v( 1, q ), & - 1,v( 1, p ), 1 ) + call stdlib${ii}$_saxpy( mvl, t*apoaq,v( 1_${ik}$, p ), 1_${ik}$,v( & + 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q ), & + 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if work( p ) = work( p ) / cs work( q ) = work( q )*cs else if( work( p )>=work( q ) )then - call stdlib_saxpy( m, -t*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) - call stdlib_saxpy( m, cs*sn*apoaq,a( 1, p ), 1,& - a( 1, q ), 1 ) + call stdlib${ii}$_saxpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,& + a( 1_${ik}$, q ), 1_${ik}$ ) work( p ) = work( p )*cs work( q ) = work( q ) / cs if( rsvec ) then - call stdlib_saxpy( mvl,-t*aqoap,v( 1, q ), 1,& - v( 1, p ), 1 ) - call stdlib_saxpy( mvl,cs*sn*apoaq,v( 1, p ),& - 1,v( 1, q ), 1 ) + call stdlib${ii}$_saxpy( mvl,-t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,& + v( 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ),& + 1_${ik}$,v( 1_${ik}$, q ), 1_${ik}$ ) end if else - call stdlib_saxpy( m, t*apoaq,a( 1, p ), 1,a( 1,& - q ), 1 ) - call stdlib_saxpy( m,-cs*sn*aqoap,a( 1, q ), 1,& - a( 1, p ), 1 ) + call stdlib${ii}$_saxpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$,& + q ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( m,-cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,& + a( 1_${ik}$, p ), 1_${ik}$ ) work( p ) = work( p ) / cs work( q ) = work( q )*cs if( rsvec ) then - call stdlib_saxpy( mvl,t*apoaq, v( 1, p ),1, & - v( 1, q ), 1 ) - call stdlib_saxpy( mvl,-cs*sn*aqoap,v( 1, q )& - , 1,v( 1, p ), 1 ) + call stdlib${ii}$_saxpy( mvl,t*apoaq, v( 1_${ik}$, p ),1_${ik}$, & + v( 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q )& + , 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if end if end if @@ -77442,30 +77443,30 @@ module stdlib_linalg_lapack_s end if else if( aapp>aaqq ) then - call stdlib_scopy( m, a( 1, p ), 1,work( n+1 ), 1 ) + call stdlib${ii}$_scopy( m, a( 1_${ik}$, p ), 1_${ik}$,work( n+1 ), 1_${ik}$ ) - call stdlib_slascl( 'G', 0, 0, aapp, one,m, 1, work( n+1 & + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, work( n+1 & ), lda,ierr ) - call stdlib_slascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) temp1 = -aapq*work( p ) / work( q ) - call stdlib_saxpy( m, temp1, work( n+1 ),1, a( 1, q ), 1 & + call stdlib${ii}$_saxpy( m, temp1, work( n+1 ),1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ & ) - call stdlib_slascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) else - call stdlib_scopy( m, a( 1, q ), 1,work( n+1 ), 1 ) + call stdlib${ii}$_scopy( m, a( 1_${ik}$, q ), 1_${ik}$,work( n+1 ), 1_${ik}$ ) - call stdlib_slascl( 'G', 0, 0, aaqq, one,m, 1, work( n+1 & + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, work( n+1 & ), lda,ierr ) - call stdlib_slascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) temp1 = -aapq*work( q ) / work( p ) - call stdlib_saxpy( m, temp1, work( n+1 ),1, a( 1, p ), 1 & + call stdlib${ii}$_saxpy( m, temp1, work( n+1 ),1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ & ) - call stdlib_slascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, one, aapp,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) sva( p ) = aapp*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) @@ -77474,48 +77475,48 @@ module stdlib_linalg_lapack_s ! end if rotok then ... else ! in the case of cancellation in updating sva(q) ! .. recompute sva(q) - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_snrm2( m, a( 1, q ), 1 )*work( q ) + sva( q ) = stdlib${ii}$_snrm2( m, a( 1_${ik}$, q ), 1_${ik}$ )*work( q ) else t = zero aaqq = one - call stdlib_slassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_slassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq )*work( q ) end if end if - if( ( aapp / aapp0 )**2<=rooteps ) then + if( ( aapp / aapp0 )**2_${ik}$<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_snrm2( m, a( 1, p ), 1 )*work( p ) + aapp = stdlib${ii}$_snrm2( m, a( 1_${ik}$, p ), 1_${ik}$ )*work( p ) else t = zero aapp = one - call stdlib_slassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_slassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp )*work( p ) end if sva( p ) = aapp end if ! end of ok rotation else - notrot = notrot + 1 + notrot = notrot + 1_${ik}$ ! [rtd] skipped = skipped + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if else - notrot = notrot + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if if( ( i<=swband ) .and. ( ijblsk>=blskip ) )then sva( p ) = aapp - notrot = 0 + notrot = 0_${ik}$ go to 2011 end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then aapp = -aapp - notrot = 0 + notrot = 0_${ik}$ go to 2203 end if end do loop_2200 @@ -77523,8 +77524,8 @@ module stdlib_linalg_lapack_s 2203 continue sva( p ) = aapp else - if( aapp==zero )notrot = notrot +min( jgl+kbl-1, n ) - jgl + 1 - if( aapprootsfmin ) )then - sva( n ) = stdlib_snrm2( m, a( 1, n ), 1 )*work( n ) + sva( n ) = stdlib${ii}$_snrm2( m, a( 1_${ik}$, n ), 1_${ik}$ )*work( n ) else t = zero aapp = one - call stdlib_slassq( m, a( 1, n ), 1, t, aapp ) + call stdlib${ii}$_slassq( m, a( 1_${ik}$, n ), 1_${ik}$, t, aapp ) sva( n ) = t*sqrt( aapp )*work( n ) end if ! additional steering devices @@ -77557,20 +77558,20 @@ module stdlib_linalg_lapack_s end do loop_1993 ! end i=1:nsweep loop ! #:( reaching this point means that the procedure has not converged. - info = nsweep - 1 + info = nsweep - 1_${ik}$ go to 1995 1994 continue ! #:) reaching this point means numerical convergence after the i-th ! sweep. - info = 0 + info = 0_${ik}$ ! #:) info = 0 confirms successful iterations. 1995 continue ! sort the singular values and find how many are above ! the underflow threshold. - n2 = 0 - n4 = 0 + n2 = 0_${ik}$ + n4 = 0_${ik}$ do p = 1, n - 1 - q = stdlib_isamax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib${ii}$_isamax( n-p+1, sva( p ), 1_${ik}$ ) + p - 1_${ik}$ if( p/=q ) then temp1 = sva( p ) sva( p ) = sva( q ) @@ -77578,68 +77579,68 @@ module stdlib_linalg_lapack_s temp1 = work( p ) work( p ) = work( q ) work( q ) = temp1 - call stdlib_sswap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_sswap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) + call stdlib${ii}$_sswap( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) + if( rsvec )call stdlib${ii}$_sswap( mvl, v( 1_${ik}$, p ), 1_${ik}$, v( 1_${ik}$, q ), 1_${ik}$ ) end if if( sva( p )/=zero ) then - n4 = n4 + 1 - if( sva( p )*skl>sfmin )n2 = n2 + 1 + n4 = n4 + 1_${ik}$ + if( sva( p )*skl>sfmin )n2 = n2 + 1_${ik}$ end if end do if( sva( n )/=zero ) then - n4 = n4 + 1 - if( sva( n )*skl>sfmin )n2 = n2 + 1 + n4 = n4 + 1_${ik}$ + if( sva( n )*skl>sfmin )n2 = n2 + 1_${ik}$ end if ! normalize the left singular vectors. if( lsvec .or. uctol ) then do p = 1, n2 - call stdlib_sscal( m, work( p ) / sva( p ), a( 1, p ), 1 ) + call stdlib${ii}$_sscal( m, work( p ) / sva( p ), a( 1_${ik}$, p ), 1_${ik}$ ) end do end if ! scale the product of jacobi rotations (assemble the fast rotations). if( rsvec ) then if( applv ) then do p = 1, n - call stdlib_sscal( mvl, work( p ), v( 1, p ), 1 ) + call stdlib${ii}$_sscal( mvl, work( p ), v( 1_${ik}$, p ), 1_${ik}$ ) end do else do p = 1, n - temp1 = one / stdlib_snrm2( mvl, v( 1, p ), 1 ) - call stdlib_sscal( mvl, temp1, v( 1, p ), 1 ) + temp1 = one / stdlib${ii}$_snrm2( mvl, v( 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_sscal( mvl, temp1, v( 1_${ik}$, p ), 1_${ik}$ ) end do end if end if ! undo scaling, if necessary (and possible). - if( ( ( skl>one ) .and. ( sva( 1 )<( big / skl ) ) ).or. ( ( skl( sfmin / skl ) ) ) ) then + if( ( ( skl>one ) .and. ( sva( 1_${ik}$ )<( big / skl ) ) ).or. ( ( skl( sfmin / skl ) ) ) ) then do p = 1, n sva( p ) = skl*sva( p ) end do skl = one end if - work( 1 ) = skl + work( 1_${ik}$ ) = skl ! the singular values of a are skl*sva(1:n). if skl/=one ! then some of the singular values may overflow or underflow and ! the spectrum is given in this factored representation. - work( 2 ) = real( n4,KIND=sp) + work( 2_${ik}$ ) = real( n4,KIND=sp) ! n4 is the number of computed nonzero singular values of a. - work( 3 ) = real( n2,KIND=sp) + work( 3_${ik}$ ) = real( n2,KIND=sp) ! n2 is the number of singular values of a greater than sfmin. ! if n2zero .and. anrmzero .and. bnrm1 ) then - call stdlib_slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& + call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vsl, ldvsl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& , ldvsl ) end if - call stdlib_sorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & + call stdlib${ii}$_sorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vsr - if( ilvsr )call stdlib_slaset( 'FULL', n, n, zero, one, vsr, ldvsr ) + if( ilvsr )call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vsr, ldvsr ) ! reduce to generalized hessenberg form - call stdlib_sgghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& + call stdlib${ii}$_sgghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& work( iwrk ), lwork+1-iwrk, ierr ) ! perform qz algorithm, computing schur vectors if desired iwrk = itau - call stdlib_slaqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & - beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, 0, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + call stdlib${ii}$_slaqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & + beta, vsl, ldvsl, vsr, ldvsr,work( iwrk ), lwork+1-iwrk, 0_${ik}$, ierr ) + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 40 end if ! sort eigenvalues alpha/beta if desired - sdim = 0 + sdim = 0_${ik}$ if( wantst ) then ! undo scaling on eigenvalues before selctging if( ilascl ) then - call stdlib_slascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n,ierr ) - call stdlib_slascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n,ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n,ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n,ierr ) end if - if( ilbscl )call stdlib_slascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + if( ilbscl )call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) ! select eigenvalues do i = 1, n bwork( i ) = selctg( alphar( i ), alphai( i ), beta( i ) ) end do - call stdlib_stgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, & - vsl, ldvsl, vsr, ldvsr, sdim, pvsl,pvsr, dif, work( iwrk ), lwork-iwrk+1, idum, 1,& + call stdlib${ii}$_stgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar,alphai, beta, & + vsl, ldvsl, vsr, ldvsr, sdim, pvsl,pvsr, dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$,& ierr ) - if( ierr==1 )info = n + 3 + if( ierr==1_${ik}$ )info = n + 3_${ik}$ end if ! apply back-permutation to vsl and vsr - if( ilvsl )call stdlib_sggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, & + if( ilvsl )call stdlib${ii}$_sggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, & vsl, ldvsl, ierr ) - if( ilvsr )call stdlib_sggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, & + if( ilvsr )call stdlib${ii}$_sggbak( 'P', 'R', n, ilo, ihi, work( ileft ),work( iright ), n, & vsr, ldvsr, ierr ) ! check if unscaling would cause over/underflow, if so, rescale ! (alphar(i),alphai(i),beta(i)) so beta(i) is on the order of @@ -77881,16 +77882,16 @@ module stdlib_linalg_lapack_s if( alphai( i )/=zero ) then if( ( alphar( i )/safmax )>( anrmto/anrm ) .or.( safmin/alphar( i ) )>( & anrm/anrmto ) ) then - work( 1 ) = abs( a( i, i )/alphar( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( a( i, i )/alphar( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) else if( ( alphai( i )/safmax )>( anrmto/anrm ) .or.( safmin/alphai( i ) )>( & anrm/anrmto ) ) then - work( 1 ) = abs( a( i, i+1 )/alphai( i ) ) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs( a( i, i+1 )/alphai( i ) ) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) end if end if end do @@ -77900,47 +77901,47 @@ module stdlib_linalg_lapack_s if( alphai( i )/=zero ) then if( ( beta( i )/safmax )>( bnrmto/bnrm ) .or.( safmin/beta( i ) )>( & bnrm/bnrmto ) ) then - work( 1 ) = abs(b( i, i )/beta( i )) - beta( i ) = beta( i )*work( 1 ) - alphar( i ) = alphar( i )*work( 1 ) - alphai( i ) = alphai( i )*work( 1 ) + work( 1_${ik}$ ) = abs(b( i, i )/beta( i )) + beta( i ) = beta( i )*work( 1_${ik}$ ) + alphar( i ) = alphar( i )*work( 1_${ik}$ ) + alphai( i ) = alphai( i )*work( 1_${ik}$ ) end if end if end do end if ! undo scaling if( ilascl ) then - call stdlib_slascl( 'H', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) - call stdlib_slascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr ) - call stdlib_slascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr ) + call stdlib${ii}$_slascl( 'H', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphar, n, ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alphai, n, ierr ) end if if( ilbscl ) then - call stdlib_slascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) - call stdlib_slascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + call stdlib${ii}$_slascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) end if if( wantst ) then ! check if reordering is correct lastsl = .true. lst2sl = .true. - sdim = 0 - ip = 0 + sdim = 0_${ik}$ + ip = 0_${ik}$ do i = 1, n cursl = selctg( alphar( i ), alphai( i ), beta( i ) ) if( alphai( i )==zero ) then - if( cursl )sdim = sdim + 1 - ip = 0 - if( cursl .and. .not.lastsl )info = n + 2 + if( cursl )sdim = sdim + 1_${ik}$ + ip = 0_${ik}$ + if( cursl .and. .not.lastsl )info = n + 2_${ik}$ else - if( ip==1 ) then + if( ip==1_${ik}$ ) then ! last eigenvalue of conjugate pair cursl = cursl .or. lastsl lastsl = cursl - if( cursl )sdim = sdim + 2 - ip = -1 - if( cursl .and. .not.lst2sl )info = n + 2 + if( cursl )sdim = sdim + 2_${ik}$ + ip = -1_${ik}$ + if( cursl .and. .not.lst2sl )info = n + 2_${ik}$ else ! first eigenvalue of conjugate pair - ip = 1 + ip = 1_${ik}$ end if end if lst2sl = lastsl @@ -77948,12 +77949,12 @@ module stdlib_linalg_lapack_s end do end if 40 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_sgges3 + end subroutine stdlib${ii}$_sgges3 - subroutine stdlib_sggev3( jobvl, jobvr, n, a, lda, b, ldb, alphar,alphai, beta, vl, ldvl, vr,& + subroutine stdlib${ii}$_sggev3( jobvl, jobvr, n, a, lda, b, ldb, alphar,alphai, beta, vl, ldvl, vr,& !! SGGEV3 computes for a pair of N-by-N real nonsymmetric matrices (A,B) !! the generalized eigenvalues, and optionally, the left and/or right !! generalized eigenvectors. @@ -77975,8 +77976,8 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvl, jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n ! Array Arguments real(sp), intent(inout) :: a(lda,*), b(ldb,*) real(sp), intent(out) :: alphai(*), alphar(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*) @@ -77986,80 +77987,80 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery character :: chtemp - integer(ilp) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, itau, & + integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, itau, & iwrk, jc, jr, lwkopt real(sp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp ! Local Arrays - logical(lk) :: ldumma(1) + logical(lk) :: ldumma(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvl, 'N' ) ) then - ijobvl = 1 + ijobvl = 1_${ik}$ ilvl = .false. else if( stdlib_lsame( jobvl, 'V' ) ) then - ijobvl = 2 + ijobvl = 2_${ik}$ ilvl = .true. else - ijobvl = -1 + ijobvl = -1_${ik}$ ilvl = .false. end if if( stdlib_lsame( jobvr, 'N' ) ) then - ijobvr = 1 + ijobvr = 1_${ik}$ ilvr = .false. else if( stdlib_lsame( jobvr, 'V' ) ) then - ijobvr = 2 + ijobvr = 2_${ik}$ ilvr = .true. else - ijobvr = -1 + ijobvr = -1_${ik}$ ilvr = .false. end if ilv = ilvl .or. ilvr ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( ijobvl<=0 ) then - info = -1 - else if( ijobvr<=0 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldazero .and. anrmzero .and. bnrm1 ) then - call stdlib_slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& + call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vl, ldvl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& ldvl ) end if - call stdlib_sorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & + call stdlib${ii}$_sorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vr - if( ilvr )call stdlib_slaset( 'FULL', n, n, zero, one, vr, ldvr ) + if( ilvr )call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, vr, ldvr ) ! reduce to generalized hessenberg form if( ilv ) then ! eigenvectors requested -- work on whole matrix. - call stdlib_sgghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib${ii}$_sgghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & work( iwrk ), lwork+1-iwrk, ierr ) else - call stdlib_sgghd3( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & + call stdlib${ii}$_sgghd3( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & ldb, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr ) end if ! perform qz algorithm (compute eigenvalues, and optionally, the @@ -78144,15 +78145,15 @@ module stdlib_linalg_lapack_s else chtemp = 'E' end if - call stdlib_slaqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & - beta, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, 0, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + call stdlib${ii}$_slaqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alphar, alphai, & + beta, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, 0_${ik}$, ierr ) + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 110 end if @@ -78167,15 +78168,15 @@ module stdlib_linalg_lapack_s else chtemp = 'R' end if - call stdlib_stgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & + call stdlib${ii}$_stgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & in, work( iwrk ), ierr ) - if( ierr/=0 ) then - info = n + 2 + if( ierr/=0_${ik}$ ) then + info = n + 2_${ik}$ go to 110 end if ! undo balancing on vl and vr and normalization if( ilvl ) then - call stdlib_sggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, & + call stdlib${ii}$_sggbak( 'P', 'L', n, ilo, ihi, work( ileft ),work( iright ), n, vl, & ldvl, ierr ) loop_50: do jc = 1, n if( alphai( jc )m ) ) then - info = -3 + info = -1_${ik}$ + else if( m<0_${ik}$ ) then + info = -2_${ik}$ + else if( ( n<0_${ik}$ ) .or. ( n>m ) ) then + info = -3_${ik}$ else if( lda sqrt(overflow_threshold), and ! underflow for ||a(:,p)||_2 < sqrt(underflow_threshold). - ! hence, stdlib_snrm2 cannot be trusted, not even in the case when + ! hence, stdlib${ii}$_snrm2 cannot be trusted, not even in the case when ! the true norm is far from the under(over)flow boundaries. - ! if properly implemented stdlib_snrm2 is available, the if-then-else - ! below should read "aapp = stdlib_snrm2( m, a(1,p), 1 ) * d(p)". + ! if properly implemented stdlib${ii}$_snrm2 is available, the if-then-else + ! below should read "aapp = stdlib${ii}$_snrm2( m, a(1,p), 1 ) * d(p)". if( ( sva( p )rootsfmin ) ) then - sva( p ) = stdlib_snrm2( m, a( 1, p ), 1 )*d( p ) + sva( p ) = stdlib${ii}$_snrm2( m, a( 1_${ik}$, p ), 1_${ik}$ )*d( p ) else temp1 = zero aapp = one - call stdlib_slassq( m, a( 1, p ), 1, temp1, aapp ) + call stdlib${ii}$_slassq( m, a( 1_${ik}$, p ), 1_${ik}$, temp1, aapp ) sva( p ) = temp1*sqrt( aapp )*d( p ) end if aapp = sva( p ) @@ -78394,7 +78395,7 @@ module stdlib_linalg_lapack_s aapp = sva( p ) end if if( aapp>zero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2002: do q = p + 1, min( igl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -78402,25 +78403,25 @@ module stdlib_linalg_lapack_s if( aaqq>=one ) then rotok = ( small*aapp )<=aaqq if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_sdot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& + aapq = ( stdlib${ii}$_sdot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*d( p )& *d( q ) / aaqq )/ aapp else - call stdlib_scopy( m, a( 1, p ), 1, work, 1 ) - call stdlib_slascl( 'G', 0, 0, aapp, d( p ),m, 1, work, lda,& + call stdlib${ii}$_scopy( m, a( 1_${ik}$, p ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aapp, d( p ),m, 1_${ik}$, work, lda,& ierr ) - aapq = stdlib_sdot( m, work, 1, a( 1, q ),1 )*d( q ) / & + aapq = stdlib${ii}$_sdot( m, work, 1_${ik}$, a( 1_${ik}$, q ),1_${ik}$ )*d( q ) / & aaqq end if else rotok = aapp<=( aaqq / small ) if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_sdot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& + aapq = ( stdlib${ii}$_sdot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*d( p )& *d( q ) / aaqq )/ aapp else - call stdlib_scopy( m, a( 1, q ), 1, work, 1 ) - call stdlib_slascl( 'G', 0, 0, aaqq, d( q ),m, 1, work, lda,& + call stdlib${ii}$_scopy( m, a( 1_${ik}$, q ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, d( q ),m, 1_${ik}$, work, lda,& ierr ) - aapq = stdlib_sdot( m, work, 1, a( 1, p ),1 )*d( p ) / & + aapq = stdlib${ii}$_sdot( m, work, 1_${ik}$, a( 1_${ik}$, p ),1_${ik}$ )*d( p ) / & aapp end if end if @@ -78429,10 +78430,10 @@ module stdlib_linalg_lapack_s if( abs( aapq )>tol ) then ! Rotate ! rotated = rotated + one - if( ir1==0 ) then - notrot = 0 - pskipped = 0 - iswrot = iswrot + 1 + if( ir1==0_${ik}$ ) then + notrot = 0_${ik}$ + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ end if if( rotok ) then aqoap = aaqq / aapp @@ -78440,12 +78441,12 @@ module stdlib_linalg_lapack_s theta = -half*abs( aqoap-apoaq ) / aapq if( abs( theta )>bigtheta ) then t = half / theta - fastr( 3 ) = t*d( p ) / d( q ) - fastr( 4 ) = -t*d( q ) / d( p ) - call stdlib_srotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) + fastr( 3_${ik}$ ) = t*d( p ) / d( q ) + fastr( 4_${ik}$ ) = -t*d( q ) / d( p ) + call stdlib${ii}$_srotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$, fastr ) - if( rsvec )call stdlib_srotm( mvl,v( 1, p ), 1,v( 1, q ),& - 1,fastr ) + if( rsvec )call stdlib${ii}$_srotm( mvl,v( 1_${ik}$, p ), 1_${ik}$,v( 1_${ik}$, q ),& + 1_${ik}$,fastr ) sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq ) ) @@ -78465,68 +78466,68 @@ module stdlib_linalg_lapack_s aqoap = d( q ) / d( p ) if( d( p )>=one ) then if( d( q )>=one ) then - fastr( 3 ) = t*apoaq - fastr( 4 ) = -t*aqoap + fastr( 3_${ik}$ ) = t*apoaq + fastr( 4_${ik}$ ) = -t*aqoap d( p ) = d( p )*cs d( q ) = d( q )*cs - call stdlib_srotm( m, a( 1, p ), 1,a( 1, q ), 1,& + call stdlib${ii}$_srotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$,& fastr ) - if( rsvec )call stdlib_srotm( mvl,v( 1, p ), 1, v( & - 1, q ),1, fastr ) + if( rsvec )call stdlib${ii}$_srotm( mvl,v( 1_${ik}$, p ), 1_${ik}$, v( & + 1_${ik}$, q ),1_${ik}$, fastr ) else - call stdlib_saxpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & - p ), 1 ) - call stdlib_saxpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & - 1, q ), 1 ) + call stdlib${ii}$_saxpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( 1_${ik}$, & + p ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( & + 1_${ik}$, q ), 1_${ik}$ ) d( p ) = d( p )*cs d( q ) = d( q ) / cs if( rsvec ) then - call stdlib_saxpy( mvl, -t*aqoap,v( 1, q ), 1,v(& - 1, p ), 1 ) - call stdlib_saxpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& - v( 1, q ), 1 ) + call stdlib${ii}$_saxpy( mvl, -t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,v(& + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ), 1_${ik}$,& + v( 1_${ik}$, q ), 1_${ik}$ ) end if end if else if( d( q )>=one ) then - call stdlib_saxpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & - ), 1 ) - call stdlib_saxpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) + call stdlib${ii}$_saxpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q & + ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( m, -cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) d( p ) = d( p ) / cs d( q ) = d( q )*cs if( rsvec ) then - call stdlib_saxpy( mvl, t*apoaq,v( 1, p ), 1,v( & - 1, q ), 1 ) - call stdlib_saxpy( mvl,-cs*sn*aqoap,v( 1, q ), & - 1,v( 1, p ), 1 ) + call stdlib${ii}$_saxpy( mvl, t*apoaq,v( 1_${ik}$, p ), 1_${ik}$,v( & + 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q ), & + 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if else if( d( p )>=d( q ) ) then - call stdlib_saxpy( m, -t*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) - call stdlib_saxpy( m, cs*sn*apoaq,a( 1, p ), 1,& - a( 1, q ), 1 ) + call stdlib${ii}$_saxpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,& + a( 1_${ik}$, q ), 1_${ik}$ ) d( p ) = d( p )*cs d( q ) = d( q ) / cs if( rsvec ) then - call stdlib_saxpy( mvl,-t*aqoap,v( 1, q ), 1,& - v( 1, p ), 1 ) - call stdlib_saxpy( mvl,cs*sn*apoaq,v( 1, p ),& - 1,v( 1, q ), 1 ) + call stdlib${ii}$_saxpy( mvl,-t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,& + v( 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ),& + 1_${ik}$,v( 1_${ik}$, q ), 1_${ik}$ ) end if else - call stdlib_saxpy( m, t*apoaq,a( 1, p ), 1,a( 1,& - q ), 1 ) - call stdlib_saxpy( m,-cs*sn*aqoap,a( 1, q ), 1,& - a( 1, p ), 1 ) + call stdlib${ii}$_saxpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$,& + q ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( m,-cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,& + a( 1_${ik}$, p ), 1_${ik}$ ) d( p ) = d( p ) / cs d( q ) = d( q )*cs if( rsvec ) then - call stdlib_saxpy( mvl,t*apoaq, v( 1, p ),1, & - v( 1, q ), 1 ) - call stdlib_saxpy( mvl,-cs*sn*aqoap,v( 1, q )& - , 1,v( 1, p ), 1 ) + call stdlib${ii}$_saxpy( mvl,t*apoaq, v( 1_${ik}$, p ),1_${ik}$, & + v( 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q )& + , 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if end if end if @@ -78534,14 +78535,14 @@ module stdlib_linalg_lapack_s end if else ! .. have to use modified gram-schmidt like transformation - call stdlib_scopy( m, a( 1, p ), 1, work, 1 ) - call stdlib_slascl( 'G', 0, 0, aapp, one, m,1, work, lda, & + call stdlib${ii}$_scopy( m, a( 1_${ik}$, p ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one, m,1_${ik}$, work, lda, & ierr ) - call stdlib_slascl( 'G', 0, 0, aaqq, one, m,1, a( 1, q ), & + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one, m,1_${ik}$, a( 1_${ik}$, q ), & lda, ierr ) temp1 = -aapq*d( p ) / d( q ) - call stdlib_saxpy( m, temp1, work, 1,a( 1, q ), 1 ) - call stdlib_slascl( 'G', 0, 0, one, aaqq, m,1, a( 1, q ), & + call stdlib${ii}$_saxpy( m, temp1, work, 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq, m,1_${ik}$, a( 1_${ik}$, q ), & lda, ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) @@ -78549,40 +78550,40 @@ module stdlib_linalg_lapack_s ! end if rotok then ... else ! in the case of cancellation in updating sva(q), sva(p) ! recompute sva(q), sva(p). - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_snrm2( m, a( 1, q ), 1 )*d( q ) + sva( q ) = stdlib${ii}$_snrm2( m, a( 1_${ik}$, q ), 1_${ik}$ )*d( q ) else t = zero aaqq = one - call stdlib_slassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_slassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq )*d( q ) end if end if if( ( aapp / aapp0 )<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_snrm2( m, a( 1, p ), 1 )*d( p ) + aapp = stdlib${ii}$_snrm2( m, a( 1_${ik}$, p ), 1_${ik}$ )*d( p ) else t = zero aapp = one - call stdlib_slassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_slassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp )*d( p ) end if sva( p ) = aapp end if else ! a(:,p) and a(:,q) already numerically orthogonal - if( ir1==0 )notrot = notrot + 1 - pskipped = pskipped + 1 + if( ir1==0_${ik}$ )notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ end if else ! a(:,q) is zero column - if( ir1==0 )notrot = notrot + 1 - pskipped = pskipped + 1 + if( ir1==0_${ik}$ )notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then - if( ir1==0 )aapp = -aapp - notrot = 0 + if( ir1==0_${ik}$ )aapp = -aapp + notrot = 0_${ik}$ go to 2103 end if end do loop_2002 @@ -78592,7 +78593,7 @@ module stdlib_linalg_lapack_s sva( p ) = aapp else sva( p ) = aapp - if( ( ir1==0 ) .and. ( aapp==zero ) )notrot = notrot + min( igl+kbl-1, & + if( ( ir1==0_${ik}$ ) .and. ( aapp==zero ) )notrot = notrot + min( igl+kbl-1, & n ) - p end if end do loop_2001 @@ -78602,15 +78603,15 @@ module stdlib_linalg_lapack_s ! end of ir1-loop ! ........................................................ ! ... go to the off diagonal blocks - igl = ( ibr-1 )*kbl + 1 + igl = ( ibr-1 )*kbl + 1_${ik}$ loop_2010: do jbc = ibr + 1, nbl - jgl = ( jbc-1 )*kbl + 1 + jgl = ( jbc-1 )*kbl + 1_${ik}$ ! doing the block at ( ibr, jbc ) - ijblsk = 0 + ijblsk = 0_${ik}$ loop_2100: do p = igl, min( igl+kbl-1, n ) aapp = sva( p ) if( aapp>zero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2200: do q = jgl, min( jgl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -78624,13 +78625,13 @@ module stdlib_linalg_lapack_s rotok = ( small*aaqq )<=aapp end if if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_sdot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& + aapq = ( stdlib${ii}$_sdot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*d( p )& *d( q ) / aaqq )/ aapp else - call stdlib_scopy( m, a( 1, p ), 1, work, 1 ) - call stdlib_slascl( 'G', 0, 0, aapp, d( p ),m, 1, work, lda,& + call stdlib${ii}$_scopy( m, a( 1_${ik}$, p ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aapp, d( p ),m, 1_${ik}$, work, lda,& ierr ) - aapq = stdlib_sdot( m, work, 1, a( 1, q ),1 )*d( q ) / & + aapq = stdlib${ii}$_sdot( m, work, 1_${ik}$, a( 1_${ik}$, q ),1_${ik}$ )*d( q ) / & aaqq end if else @@ -78640,23 +78641,23 @@ module stdlib_linalg_lapack_s rotok = aaqq<=( aapp / small ) end if if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_sdot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& + aapq = ( stdlib${ii}$_sdot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*d( p )& *d( q ) / aaqq )/ aapp else - call stdlib_scopy( m, a( 1, q ), 1, work, 1 ) - call stdlib_slascl( 'G', 0, 0, aaqq, d( q ),m, 1, work, lda,& + call stdlib${ii}$_scopy( m, a( 1_${ik}$, q ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, d( q ),m, 1_${ik}$, work, lda,& ierr ) - aapq = stdlib_sdot( m, work, 1, a( 1, p ),1 )*d( p ) / & + aapq = stdlib${ii}$_sdot( m, work, 1_${ik}$, a( 1_${ik}$, p ),1_${ik}$ )*d( p ) / & aapp end if end if mxaapq = max( mxaapq, abs( aapq ) ) ! to rotate or not to rotate, that is the question ... if( abs( aapq )>tol ) then - notrot = 0 + notrot = 0_${ik}$ ! rotated = rotated + 1 - pskipped = 0 - iswrot = iswrot + 1 + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ if( rotok ) then aqoap = aaqq / aapp apoaq = aapp / aaqq @@ -78664,12 +78665,12 @@ module stdlib_linalg_lapack_s if( aaqq>aapp0 )theta = -theta if( abs( theta )>bigtheta ) then t = half / theta - fastr( 3 ) = t*d( p ) / d( q ) - fastr( 4 ) = -t*d( q ) / d( p ) - call stdlib_srotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) + fastr( 3_${ik}$ ) = t*d( p ) / d( q ) + fastr( 4_${ik}$ ) = -t*d( q ) / d( p ) + call stdlib${ii}$_srotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$, fastr ) - if( rsvec )call stdlib_srotm( mvl,v( 1, p ), 1,v( 1, q ),& - 1,fastr ) + if( rsvec )call stdlib${ii}$_srotm( mvl,v( 1_${ik}$, p ), 1_${ik}$,v( 1_${ik}$, q ),& + 1_${ik}$,fastr ) sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq ) ) @@ -78690,68 +78691,68 @@ module stdlib_linalg_lapack_s aqoap = d( q ) / d( p ) if( d( p )>=one ) then if( d( q )>=one ) then - fastr( 3 ) = t*apoaq - fastr( 4 ) = -t*aqoap + fastr( 3_${ik}$ ) = t*apoaq + fastr( 4_${ik}$ ) = -t*aqoap d( p ) = d( p )*cs d( q ) = d( q )*cs - call stdlib_srotm( m, a( 1, p ), 1,a( 1, q ), 1,& + call stdlib${ii}$_srotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$,& fastr ) - if( rsvec )call stdlib_srotm( mvl,v( 1, p ), 1, v( & - 1, q ),1, fastr ) + if( rsvec )call stdlib${ii}$_srotm( mvl,v( 1_${ik}$, p ), 1_${ik}$, v( & + 1_${ik}$, q ),1_${ik}$, fastr ) else - call stdlib_saxpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & - p ), 1 ) - call stdlib_saxpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & - 1, q ), 1 ) + call stdlib${ii}$_saxpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( 1_${ik}$, & + p ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( & + 1_${ik}$, q ), 1_${ik}$ ) if( rsvec ) then - call stdlib_saxpy( mvl, -t*aqoap,v( 1, q ), 1,v(& - 1, p ), 1 ) - call stdlib_saxpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& - v( 1, q ), 1 ) + call stdlib${ii}$_saxpy( mvl, -t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,v(& + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ), 1_${ik}$,& + v( 1_${ik}$, q ), 1_${ik}$ ) end if d( p ) = d( p )*cs d( q ) = d( q ) / cs end if else if( d( q )>=one ) then - call stdlib_saxpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & - ), 1 ) - call stdlib_saxpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) + call stdlib${ii}$_saxpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q & + ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( m, -cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) if( rsvec ) then - call stdlib_saxpy( mvl, t*apoaq,v( 1, p ), 1,v( & - 1, q ), 1 ) - call stdlib_saxpy( mvl,-cs*sn*aqoap,v( 1, q ), & - 1,v( 1, p ), 1 ) + call stdlib${ii}$_saxpy( mvl, t*apoaq,v( 1_${ik}$, p ), 1_${ik}$,v( & + 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q ), & + 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if d( p ) = d( p ) / cs d( q ) = d( q )*cs else if( d( p )>=d( q ) ) then - call stdlib_saxpy( m, -t*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) - call stdlib_saxpy( m, cs*sn*apoaq,a( 1, p ), 1,& - a( 1, q ), 1 ) + call stdlib${ii}$_saxpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,& + a( 1_${ik}$, q ), 1_${ik}$ ) d( p ) = d( p )*cs d( q ) = d( q ) / cs if( rsvec ) then - call stdlib_saxpy( mvl,-t*aqoap,v( 1, q ), 1,& - v( 1, p ), 1 ) - call stdlib_saxpy( mvl,cs*sn*apoaq,v( 1, p ),& - 1,v( 1, q ), 1 ) + call stdlib${ii}$_saxpy( mvl,-t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,& + v( 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ),& + 1_${ik}$,v( 1_${ik}$, q ), 1_${ik}$ ) end if else - call stdlib_saxpy( m, t*apoaq,a( 1, p ), 1,a( 1,& - q ), 1 ) - call stdlib_saxpy( m,-cs*sn*aqoap,a( 1, q ), 1,& - a( 1, p ), 1 ) + call stdlib${ii}$_saxpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$,& + q ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( m,-cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,& + a( 1_${ik}$, p ), 1_${ik}$ ) d( p ) = d( p ) / cs d( q ) = d( q )*cs if( rsvec ) then - call stdlib_saxpy( mvl,t*apoaq, v( 1, p ),1, & - v( 1, q ), 1 ) - call stdlib_saxpy( mvl,-cs*sn*aqoap,v( 1, q )& - , 1,v( 1, p ), 1 ) + call stdlib${ii}$_saxpy( mvl,t*apoaq, v( 1_${ik}$, p ),1_${ik}$, & + v( 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q )& + , 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if end if end if @@ -78759,28 +78760,28 @@ module stdlib_linalg_lapack_s end if else if( aapp>aaqq ) then - call stdlib_scopy( m, a( 1, p ), 1, work,1 ) - call stdlib_slascl( 'G', 0, 0, aapp, one,m, 1, work, lda,& + call stdlib${ii}$_scopy( m, a( 1_${ik}$, p ), 1_${ik}$, work,1_${ik}$ ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, work, lda,& ierr ) - call stdlib_slascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) temp1 = -aapq*d( p ) / d( q ) - call stdlib_saxpy( m, temp1, work, 1,a( 1, q ), 1 ) + call stdlib${ii}$_saxpy( m, temp1, work, 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) - call stdlib_slascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) else - call stdlib_scopy( m, a( 1, q ), 1, work,1 ) - call stdlib_slascl( 'G', 0, 0, aaqq, one,m, 1, work, lda,& + call stdlib${ii}$_scopy( m, a( 1_${ik}$, q ), 1_${ik}$, work,1_${ik}$ ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, work, lda,& ierr ) - call stdlib_slascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) temp1 = -aapq*d( q ) / d( p ) - call stdlib_saxpy( m, temp1, work, 1,a( 1, p ), 1 ) + call stdlib${ii}$_saxpy( m, temp1, work, 1_${ik}$,a( 1_${ik}$, p ), 1_${ik}$ ) - call stdlib_slascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, one, aapp,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) sva( p ) = aapp*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) @@ -78789,46 +78790,46 @@ module stdlib_linalg_lapack_s ! end if rotok then ... else ! in the case of cancellation in updating sva(q) ! .. recompute sva(q) - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_snrm2( m, a( 1, q ), 1 )*d( q ) + sva( q ) = stdlib${ii}$_snrm2( m, a( 1_${ik}$, q ), 1_${ik}$ )*d( q ) else t = zero aaqq = one - call stdlib_slassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_slassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq )*d( q ) end if end if - if( ( aapp / aapp0 )**2<=rooteps ) then + if( ( aapp / aapp0 )**2_${ik}$<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_snrm2( m, a( 1, p ), 1 )*d( p ) + aapp = stdlib${ii}$_snrm2( m, a( 1_${ik}$, p ), 1_${ik}$ )*d( p ) else t = zero aapp = one - call stdlib_slassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_slassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp )*d( p ) end if sva( p ) = aapp end if ! end of ok rotation else - notrot = notrot + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if else - notrot = notrot + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if if( ( i<=swband ) .and. ( ijblsk>=blskip ) )then sva( p ) = aapp - notrot = 0 + notrot = 0_${ik}$ go to 2011 end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then aapp = -aapp - notrot = 0 + notrot = 0_${ik}$ go to 2203 end if end do loop_2200 @@ -78836,8 +78837,8 @@ module stdlib_linalg_lapack_s 2203 continue sva( p ) = aapp else - if( aapp==zero )notrot = notrot +min( jgl+kbl-1, n ) - jgl + 1 - if( aapprootsfmin ) )then - sva( n ) = stdlib_snrm2( m, a( 1, n ), 1 )*d( n ) + sva( n ) = stdlib${ii}$_snrm2( m, a( 1_${ik}$, n ), 1_${ik}$ )*d( n ) else t = zero aapp = one - call stdlib_slassq( m, a( 1, n ), 1, t, aapp ) + call stdlib${ii}$_slassq( m, a( 1_${ik}$, n ), 1_${ik}$, t, aapp ) sva( n ) = t*sqrt( aapp )*d( n ) end if ! additional steering devices @@ -78870,17 +78871,17 @@ module stdlib_linalg_lapack_s ! end i=1:nsweep loop ! #:) reaching this point means that the procedure has completed the given ! number of iterations. - info = nsweep - 1 + info = nsweep - 1_${ik}$ go to 1995 1994 continue ! #:) reaching this point means that during the i-th sweep all pivots were ! below the given tolerance, causing early exit. - info = 0 + info = 0_${ik}$ ! #:) info = 0 confirms successful iterations. 1995 continue ! sort the vector d. do p = 1, n - 1 - q = stdlib_isamax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib${ii}$_isamax( n-p+1, sva( p ), 1_${ik}$ ) + p - 1_${ik}$ if( p/=q ) then temp1 = sva( p ) sva( p ) = sva( q ) @@ -78888,15 +78889,15 @@ module stdlib_linalg_lapack_s temp1 = d( p ) d( p ) = d( q ) d( q ) = temp1 - call stdlib_sswap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_sswap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) + call stdlib${ii}$_sswap( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) + if( rsvec )call stdlib${ii}$_sswap( mvl, v( 1_${ik}$, p ), 1_${ik}$, v( 1_${ik}$, q ), 1_${ik}$ ) end if end do return - end subroutine stdlib_sgsvj0 + end subroutine stdlib${ii}$_sgsvj0 - pure subroutine stdlib_sgsvj1( jobv, m, n, n1, a, lda, d, sva, mv, v, ldv,eps, sfmin, tol, & + pure subroutine stdlib${ii}$_sgsvj1( jobv, m, n, n1, a, lda, d, sva, mv, v, ldv,eps, sfmin, tol, & !! SGSVJ1 is called from SGESVJ as a pre-processor and that is its main !! purpose. It applies Jacobi rotations in the same way as SGESVJ does, but !! it targets only particular pivots and it does not check convergence @@ -78927,8 +78928,8 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(sp), intent(in) :: eps, sfmin, tol - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldv, lwork, m, mv, n, n1, nsweep + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldv, lwork, m, mv, n, n1, nsweep character, intent(in) :: jobv ! Array Arguments real(sp), intent(inout) :: a(lda,*), d(n), sva(n), v(ldv,*) @@ -78939,11 +78940,11 @@ module stdlib_linalg_lapack_s real(sp) :: aapp, aapp0, aapq, aaqq, apoaq, aqoap, big, bigtheta, cs, large, mxaapq, & mxsinj, rootbig, rooteps, rootsfmin, roottol, small, sn, t, temp1, theta, & thsign - integer(ilp) :: blskip, emptsw, i, ibr, igl, ierr, ijblsk, iswrot, jbc, jgl, kbl, mvl, & + integer(${ik}$) :: blskip, emptsw, i, ibr, igl, ierr, ijblsk, iswrot, jbc, jgl, kbl, mvl, & notrot, nblc, nblr, p, pskipped, q, rowskip, swband logical(lk) :: applv, rotok, rsvec ! Local Arrays - real(sp) :: fastr(5) + real(sp) :: fastr(5_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,float,min,sign,sqrt ! Executable Statements @@ -78951,31 +78952,31 @@ module stdlib_linalg_lapack_s applv = stdlib_lsame( jobv, 'A' ) rsvec = stdlib_lsame( jobv, 'V' ) if( .not.( rsvec .or. applv .or. stdlib_lsame( jobv, 'N' ) ) ) then - info = -1 - else if( m<0 ) then - info = -2 - else if( ( n<0 ) .or. ( n>m ) ) then - info = -3 - else if( n1<0 ) then - info = -4 + info = -1_${ik}$ + else if( m<0_${ik}$ ) then + info = -2_${ik}$ + else if( ( n<0_${ik}$ ) .or. ( n>m ) ) then + info = -3_${ik}$ + else if( n1<0_${ik}$ ) then + info = -4_${ik}$ else if( ldazero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2200: do q = jgl, min( jgl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -79051,13 +79052,13 @@ module stdlib_linalg_lapack_s rotok = ( small*aaqq )<=aapp end if if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_sdot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& + aapq = ( stdlib${ii}$_sdot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*d( p )& *d( q ) / aaqq )/ aapp else - call stdlib_scopy( m, a( 1, p ), 1, work, 1 ) - call stdlib_slascl( 'G', 0, 0, aapp, d( p ),m, 1, work, lda,& + call stdlib${ii}$_scopy( m, a( 1_${ik}$, p ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aapp, d( p ),m, 1_${ik}$, work, lda,& ierr ) - aapq = stdlib_sdot( m, work, 1, a( 1, q ),1 )*d( q ) / & + aapq = stdlib${ii}$_sdot( m, work, 1_${ik}$, a( 1_${ik}$, q ),1_${ik}$ )*d( q ) / & aaqq end if else @@ -79067,23 +79068,23 @@ module stdlib_linalg_lapack_s rotok = aaqq<=( aapp / small ) end if if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_sdot( m, a( 1, p ), 1, a( 1,q ), 1 )*d( p )& + aapq = ( stdlib${ii}$_sdot( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$,q ), 1_${ik}$ )*d( p )& *d( q ) / aaqq )/ aapp else - call stdlib_scopy( m, a( 1, q ), 1, work, 1 ) - call stdlib_slascl( 'G', 0, 0, aaqq, d( q ),m, 1, work, lda,& + call stdlib${ii}$_scopy( m, a( 1_${ik}$, q ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, d( q ),m, 1_${ik}$, work, lda,& ierr ) - aapq = stdlib_sdot( m, work, 1, a( 1, p ),1 )*d( p ) / & + aapq = stdlib${ii}$_sdot( m, work, 1_${ik}$, a( 1_${ik}$, p ),1_${ik}$ )*d( p ) / & aapp end if end if mxaapq = max( mxaapq, abs( aapq ) ) ! to rotate or not to rotate, that is the question ... if( abs( aapq )>tol ) then - notrot = 0 + notrot = 0_${ik}$ ! rotated = rotated + 1 - pskipped = 0 - iswrot = iswrot + 1 + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ if( rotok ) then aqoap = aaqq / aapp apoaq = aapp / aaqq @@ -79091,12 +79092,12 @@ module stdlib_linalg_lapack_s if( aaqq>aapp0 )theta = -theta if( abs( theta )>bigtheta ) then t = half / theta - fastr( 3 ) = t*d( p ) / d( q ) - fastr( 4 ) = -t*d( q ) / d( p ) - call stdlib_srotm( m, a( 1, p ), 1,a( 1, q ), 1, fastr ) + fastr( 3_${ik}$ ) = t*d( p ) / d( q ) + fastr( 4_${ik}$ ) = -t*d( q ) / d( p ) + call stdlib${ii}$_srotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$, fastr ) - if( rsvec )call stdlib_srotm( mvl,v( 1, p ), 1,v( 1, q ),& - 1,fastr ) + if( rsvec )call stdlib${ii}$_srotm( mvl,v( 1_${ik}$, p ), 1_${ik}$,v( 1_${ik}$, q ),& + 1_${ik}$,fastr ) sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq ) ) @@ -79117,68 +79118,68 @@ module stdlib_linalg_lapack_s aqoap = d( q ) / d( p ) if( d( p )>=one ) then if( d( q )>=one ) then - fastr( 3 ) = t*apoaq - fastr( 4 ) = -t*aqoap + fastr( 3_${ik}$ ) = t*apoaq + fastr( 4_${ik}$ ) = -t*aqoap d( p ) = d( p )*cs d( q ) = d( q )*cs - call stdlib_srotm( m, a( 1, p ), 1,a( 1, q ), 1,& + call stdlib${ii}$_srotm( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$,& fastr ) - if( rsvec )call stdlib_srotm( mvl,v( 1, p ), 1, v( & - 1, q ),1, fastr ) + if( rsvec )call stdlib${ii}$_srotm( mvl,v( 1_${ik}$, p ), 1_${ik}$, v( & + 1_${ik}$, q ),1_${ik}$, fastr ) else - call stdlib_saxpy( m, -t*aqoap,a( 1, q ), 1,a( 1, & - p ), 1 ) - call stdlib_saxpy( m, cs*sn*apoaq,a( 1, p ), 1,a( & - 1, q ), 1 ) + call stdlib${ii}$_saxpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( 1_${ik}$, & + p ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( & + 1_${ik}$, q ), 1_${ik}$ ) if( rsvec ) then - call stdlib_saxpy( mvl, -t*aqoap,v( 1, q ), 1,v(& - 1, p ), 1 ) - call stdlib_saxpy( mvl,cs*sn*apoaq,v( 1, p ), 1,& - v( 1, q ), 1 ) + call stdlib${ii}$_saxpy( mvl, -t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,v(& + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ), 1_${ik}$,& + v( 1_${ik}$, q ), 1_${ik}$ ) end if d( p ) = d( p )*cs d( q ) = d( q ) / cs end if else if( d( q )>=one ) then - call stdlib_saxpy( m, t*apoaq,a( 1, p ), 1,a( 1, q & - ), 1 ) - call stdlib_saxpy( m, -cs*sn*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) + call stdlib${ii}$_saxpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q & + ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( m, -cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) if( rsvec ) then - call stdlib_saxpy( mvl, t*apoaq,v( 1, p ), 1,v( & - 1, q ), 1 ) - call stdlib_saxpy( mvl,-cs*sn*aqoap,v( 1, q ), & - 1,v( 1, p ), 1 ) + call stdlib${ii}$_saxpy( mvl, t*apoaq,v( 1_${ik}$, p ), 1_${ik}$,v( & + 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q ), & + 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if d( p ) = d( p ) / cs d( q ) = d( q )*cs else if( d( p )>=d( q ) ) then - call stdlib_saxpy( m, -t*aqoap,a( 1, q ), 1,a( & - 1, p ), 1 ) - call stdlib_saxpy( m, cs*sn*apoaq,a( 1, p ), 1,& - a( 1, q ), 1 ) + call stdlib${ii}$_saxpy( m, -t*aqoap,a( 1_${ik}$, q ), 1_${ik}$,a( & + 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( m, cs*sn*apoaq,a( 1_${ik}$, p ), 1_${ik}$,& + a( 1_${ik}$, q ), 1_${ik}$ ) d( p ) = d( p )*cs d( q ) = d( q ) / cs if( rsvec ) then - call stdlib_saxpy( mvl,-t*aqoap,v( 1, q ), 1,& - v( 1, p ), 1 ) - call stdlib_saxpy( mvl,cs*sn*apoaq,v( 1, p ),& - 1,v( 1, q ), 1 ) + call stdlib${ii}$_saxpy( mvl,-t*aqoap,v( 1_${ik}$, q ), 1_${ik}$,& + v( 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( mvl,cs*sn*apoaq,v( 1_${ik}$, p ),& + 1_${ik}$,v( 1_${ik}$, q ), 1_${ik}$ ) end if else - call stdlib_saxpy( m, t*apoaq,a( 1, p ), 1,a( 1,& - q ), 1 ) - call stdlib_saxpy( m,-cs*sn*aqoap,a( 1, q ), 1,& - a( 1, p ), 1 ) + call stdlib${ii}$_saxpy( m, t*apoaq,a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$,& + q ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( m,-cs*sn*aqoap,a( 1_${ik}$, q ), 1_${ik}$,& + a( 1_${ik}$, p ), 1_${ik}$ ) d( p ) = d( p ) / cs d( q ) = d( q )*cs if( rsvec ) then - call stdlib_saxpy( mvl,t*apoaq, v( 1, p ),1, & - v( 1, q ), 1 ) - call stdlib_saxpy( mvl,-cs*sn*aqoap,v( 1, q )& - , 1,v( 1, p ), 1 ) + call stdlib${ii}$_saxpy( mvl,t*apoaq, v( 1_${ik}$, p ),1_${ik}$, & + v( 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_saxpy( mvl,-cs*sn*aqoap,v( 1_${ik}$, q )& + , 1_${ik}$,v( 1_${ik}$, p ), 1_${ik}$ ) end if end if end if @@ -79186,28 +79187,28 @@ module stdlib_linalg_lapack_s end if else if( aapp>aaqq ) then - call stdlib_scopy( m, a( 1, p ), 1, work,1 ) - call stdlib_slascl( 'G', 0, 0, aapp, one,m, 1, work, lda,& + call stdlib${ii}$_scopy( m, a( 1_${ik}$, p ), 1_${ik}$, work,1_${ik}$ ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, work, lda,& ierr ) - call stdlib_slascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) temp1 = -aapq*d( p ) / d( q ) - call stdlib_saxpy( m, temp1, work, 1,a( 1, q ), 1 ) + call stdlib${ii}$_saxpy( m, temp1, work, 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) - call stdlib_slascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) else - call stdlib_scopy( m, a( 1, q ), 1, work,1 ) - call stdlib_slascl( 'G', 0, 0, aaqq, one,m, 1, work, lda,& + call stdlib${ii}$_scopy( m, a( 1_${ik}$, q ), 1_${ik}$, work,1_${ik}$ ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, work, lda,& ierr ) - call stdlib_slascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) temp1 = -aapq*d( q ) / d( p ) - call stdlib_saxpy( m, temp1, work, 1,a( 1, p ), 1 ) + call stdlib${ii}$_saxpy( m, temp1, work, 1_${ik}$,a( 1_${ik}$, p ), 1_${ik}$ ) - call stdlib_slascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, one, aapp,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) sva( p ) = aapp*sqrt( max( zero,one-aapq*aapq ) ) mxsinj = max( mxsinj, sfmin ) @@ -79216,48 +79217,48 @@ module stdlib_linalg_lapack_s ! end if rotok then ... else ! in the case of cancellation in updating sva(q) ! .. recompute sva(q) - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_snrm2( m, a( 1, q ), 1 )*d( q ) + sva( q ) = stdlib${ii}$_snrm2( m, a( 1_${ik}$, q ), 1_${ik}$ )*d( q ) else t = zero aaqq = one - call stdlib_slassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_slassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq )*d( q ) end if end if - if( ( aapp / aapp0 )**2<=rooteps ) then + if( ( aapp / aapp0 )**2_${ik}$<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_snrm2( m, a( 1, p ), 1 )*d( p ) + aapp = stdlib${ii}$_snrm2( m, a( 1_${ik}$, p ), 1_${ik}$ )*d( p ) else t = zero aapp = one - call stdlib_slassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_slassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp )*d( p ) end if sva( p ) = aapp end if ! end of ok rotation else - notrot = notrot + 1 + notrot = notrot + 1_${ik}$ ! skipped = skipped + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if else - notrot = notrot + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if ! if ( notrot >= emptsw ) go to 2011 if( ( i<=swband ) .and. ( ijblsk>=blskip ) )then sva( p ) = aapp - notrot = 0 + notrot = 0_${ik}$ go to 2011 end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then aapp = -aapp - notrot = 0 + notrot = 0_${ik}$ go to 2203 end if end do loop_2200 @@ -79265,8 +79266,8 @@ module stdlib_linalg_lapack_s 2203 continue sva( p ) = aapp else - if( aapp==zero )notrot = notrot +min( jgl+kbl-1, n ) - jgl + 1 - if( aapp= emptsw ) go to 2011 end if end do loop_2100 @@ -79283,11 +79284,11 @@ module stdlib_linalg_lapack_s ! 2000 :: end of the ibr-loop ! .. update sva(n) if( ( sva( n )rootsfmin ) )then - sva( n ) = stdlib_snrm2( m, a( 1, n ), 1 )*d( n ) + sva( n ) = stdlib${ii}$_snrm2( m, a( 1_${ik}$, n ), 1_${ik}$ )*d( n ) else t = zero aapp = one - call stdlib_slassq( m, a( 1, n ), 1, t, aapp ) + call stdlib${ii}$_slassq( m, a( 1_${ik}$, n ), 1_${ik}$, t, aapp ) sva( n ) = t*sqrt( aapp )*d( n ) end if ! additional steering devices @@ -79301,17 +79302,17 @@ module stdlib_linalg_lapack_s ! end i=1:nsweep loop ! #:) reaching this point means that the procedure has completed the given ! number of sweeps. - info = nsweep - 1 + info = nsweep - 1_${ik}$ go to 1995 1994 continue ! #:) reaching this point means that during the i-th sweep all pivots were ! below the given threshold, causing early exit. - info = 0 + info = 0_${ik}$ ! #:) info = 0 confirms successful iterations. 1995 continue ! sort the vector d do p = 1, n - 1 - q = stdlib_isamax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib${ii}$_isamax( n-p+1, sva( p ), 1_${ik}$ ) + p - 1_${ik}$ if( p/=q ) then temp1 = sva( p ) sva( p ) = sva( q ) @@ -79319,15 +79320,15 @@ module stdlib_linalg_lapack_s temp1 = d( p ) d( p ) = d( q ) d( q ) = temp1 - call stdlib_sswap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_sswap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) + call stdlib${ii}$_sswap( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) + if( rsvec )call stdlib${ii}$_sswap( mvl, v( 1_${ik}$, p ), 1_${ik}$, v( 1_${ik}$, q ), 1_${ik}$ ) end if end do return - end subroutine stdlib_sgsvj1 + end subroutine stdlib${ii}$_sgsvj1 - subroutine stdlib_shseqr( job, compz, n, ilo, ihi, h, ldh, wr, wi, z,ldz, work, lwork, info ) + subroutine stdlib${ii}$_shseqr( job, compz, n, ilo, ihi, h, ldh, wr, wi, z,ldz, work, lwork, info ) !! SHSEQR computes the eigenvalues of a Hessenberg matrix H !! and, optionally, the matrices T and Z from the Schur decomposition !! H = Z T Z**T, where T is an upper quasi-triangular matrix (the @@ -79341,23 +79342,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) :: ihi, ilo, ldh, ldz, lwork, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ilo, ldh, ldz, lwork, n + integer(${ik}$), intent(out) :: info character, intent(in) :: compz, job ! Array Arguments real(sp), intent(inout) :: h(ldh,*), z(ldz,*) real(sp), intent(out) :: wi(*), work(*), wr(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: ntiny = 15 - integer(ilp), parameter :: nl = 49 + integer(${ik}$), parameter :: ntiny = 15_${ik}$ + integer(${ik}$), parameter :: nl = 49_${ik}$ ! ==== matrices of order ntiny or smaller must be processed by - ! . stdlib_slahqr because of insufficient subdiagonal scratch space. + ! . stdlib${ii}$_slahqr because of insufficient subdiagonal scratch space. ! . (this is a hard limit.) ==== ! ==== nl allocates some local workspace to help small matrices - ! . through a rare stdlib_slahqr failure. nl > ntiny = 15 is - ! . required and nl <= nmin = stdlib_ilaenv(ispec=12,...) is recom- + ! . through a rare stdlib${ii}$_slahqr failure. nl > ntiny = 15 is + ! . required and nl <= nmin = stdlib${ii}$_ilaenv(ispec=12,...) is recom- ! . mended. (the default value of nmin is 75.) using nl = 49 ! . allows up to six simultaneous shifts and a 16-by-16 ! . deflation window. ==== @@ -79366,7 +79367,7 @@ module stdlib_linalg_lapack_s ! Local Arrays real(sp) :: hl(nl,nl), workl(nl) ! Local Scalars - integer(ilp) :: i, kbot, nmin + integer(${ik}$) :: i, kbot, nmin logical(lk) :: initz, lquery, wantt, wantz ! Intrinsic Functions intrinsic :: max,min,real @@ -79375,43 +79376,43 @@ module stdlib_linalg_lapack_s wantt = stdlib_lsame( job, 'S' ) initz = stdlib_lsame( compz, 'I' ) wantz = initz .or. stdlib_lsame( compz, 'V' ) - work( 1 ) = real( max( 1, n ),KIND=sp) - lquery = lwork==-1 - info = 0 + work( 1_${ik}$ ) = real( max( 1_${ik}$, n ),KIND=sp) + lquery = lwork==-1_${ik}$ + info = 0_${ik}$ if( .not.stdlib_lsame( job, 'E' ) .and. .not.wantt ) then - info = -1 + info = -1_${ik}$ else if( .not.stdlib_lsame( compz, 'N' ) .and. .not.wantz ) 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( ldhnmin ) then - call stdlib_slaqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, & + call stdlib${ii}$_slaqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, & work, lwork, info ) else ! ==== small matrix ==== - call stdlib_slahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, & + call stdlib${ii}$_slahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo,ihi, z, ldz, & info ) - if( info>0 ) then - ! ==== a rare stdlib_slahqr failure! stdlib_slaqr0 sometimes succeeds - ! . when stdlib_slahqr fails. ==== + if( info>0_${ik}$ ) then + ! ==== a rare stdlib${ii}$_slahqr failure! stdlib${ii}$_slaqr0 sometimes succeeds + ! . when stdlib${ii}$_slahqr fails. ==== kbot = info if( n>=nl ) then ! ==== larger matrices have enough subdiagonal scratch - ! . space to call stdlib_slaqr0 directly. ==== - call stdlib_slaqr0( wantt, wantz, n, ilo, kbot, h, ldh, wr,wi, ilo, ihi, z,& + ! . space to call stdlib${ii}$_slaqr0 directly. ==== + call stdlib${ii}$_slaqr0( wantt, wantz, n, ilo, kbot, h, ldh, wr,wi, ilo, ihi, z,& ldz, work, lwork, info ) else ! ==== tiny matrices don't have enough subdiagonal - ! . scratch space to benefit from stdlib_slaqr0. hence, + ! . scratch space to benefit from stdlib${ii}$_slaqr0. hence, ! . tiny matrices must be copied into a larger - ! . array before calling stdlib_slaqr0. ==== - call stdlib_slacpy( 'A', n, n, h, ldh, hl, nl ) + ! . array before calling stdlib${ii}$_slaqr0. ==== + call stdlib${ii}$_slacpy( 'A', n, n, h, ldh, hl, nl ) hl( n+1, n ) = zero - call stdlib_slaset( 'A', nl, nl-n, zero, zero, hl( 1, n+1 ),nl ) - call stdlib_slaqr0( wantt, wantz, nl, ilo, kbot, hl, nl, wr,wi, ilo, ihi, & + call stdlib${ii}$_slaset( 'A', nl, nl-n, zero, zero, hl( 1_${ik}$, n+1 ),nl ) + call stdlib${ii}$_slaqr0( wantt, wantz, nl, ilo, kbot, hl, nl, wr,wi, ilo, ihi, & z, ldz, workl, nl, info ) - if( wantt .or. info/=0 )call stdlib_slacpy( 'A', n, n, hl, nl, h, ldh ) + if( wantt .or. info/=0_${ik}$ )call stdlib${ii}$_slacpy( 'A', n, n, hl, nl, h, ldh ) end if end if end if ! ==== clear out the trash, if necessary. ==== - if( ( wantt .or. info/=0 ) .and. n>2 )call stdlib_slaset( 'L', n-2, n-2, zero, zero,& - h( 3, 1 ), ldh ) + if( ( wantt .or. info/=0_${ik}$ ) .and. n>2_${ik}$ )call stdlib${ii}$_slaset( 'L', n-2, n-2, zero, zero,& + h( 3_${ik}$, 1_${ik}$ ), ldh ) ! ==== ensure reported workspace size is backward-compatible with ! . previous lapack versions. ==== - work( 1 ) = max( real( max( 1, n ),KIND=sp), work( 1 ) ) + work( 1_${ik}$ ) = max( real( max( 1_${ik}$, n ),KIND=sp), work( 1_${ik}$ ) ) end if - end subroutine stdlib_shseqr + end subroutine stdlib${ii}$_shseqr - pure subroutine stdlib_slalsa( icompq, smlsiz, n, nrhs, b, ldb, bx, ldbx, u,ldu, vt, k, difl,& + pure subroutine stdlib${ii}$_slalsa( icompq, smlsiz, n, nrhs, b, ldb, bx, ldbx, u,ldu, vt, k, difl,& !! SLALSA is an itermediate step in solving the least squares problem !! by computing the SVD of the coefficient matrix in compact form (The !! singular vectors are computed as products of simple orthorgonal @@ -79489,11 +79490,11 @@ 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, ldb, ldbx, ldgcol, ldu, n, nrhs, smlsiz - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: icompq, ldb, ldbx, ldgcol, ldu, n, nrhs, smlsiz + integer(${ik}$), intent(out) :: info ! Array Arguments - integer(ilp), intent(in) :: givcol(ldgcol,*), givptr(*), k(*), perm(ldgcol,*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(in) :: givcol(ldgcol,*), givptr(*), k(*), perm(ldgcol,*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(inout) :: b(ldb,*) real(sp), intent(out) :: bx(ldbx,*), work(*) real(sp), intent(in) :: c(*), difl(ldu,*), difr(ldu,*), givnum(ldu,*), poles(ldu,*), s(& @@ -79501,95 +79502,95 @@ module stdlib_linalg_lapack_s ! ===================================================================== ! Local Scalars - integer(ilp) :: i, i1, ic, im1, inode, j, lf, ll, lvl, lvl2, nd, ndb1, ndiml, ndimr, & + integer(${ik}$) :: i, i1, ic, im1, inode, j, lf, ll, lvl, lvl2, nd, ndb1, ndiml, ndimr, & nl, nlf, nlp1, nlvl, nr, nrf, nrp1, sqre ! Executable Statements ! test the input parameters. - info = 0 - if( ( icompq<0 ) .or. ( icompq>1 ) ) then - info = -1 - else if( smlsiz<3 ) then - info = -2 + info = 0_${ik}$ + if( ( icompq<0_${ik}$ ) .or. ( icompq>1_${ik}$ ) ) then + info = -1_${ik}$ + else if( smlsiz<3_${ik}$ ) then + info = -2_${ik}$ else if( n=one ) ) then rcnd = eps else rcnd = rcond end if - rank = 0 + rank = 0_${ik}$ ! quick return if possible. - if( n==0 ) then + if( n==0_${ik}$ ) then return - else if( n==1 ) then - if( d( 1 )==zero ) then - call stdlib_slaset( 'A', 1, nrhs, zero, zero, b, ldb ) + else if( n==1_${ik}$ ) then + if( d( 1_${ik}$ )==zero ) then + call stdlib${ii}$_slaset( 'A', 1_${ik}$, nrhs, zero, zero, b, ldb ) else - rank = 1 - call stdlib_slascl( 'G', 0, 0, d( 1 ), one, 1, nrhs, b, ldb, info ) - d( 1 ) = abs( d( 1 ) ) + rank = 1_${ik}$ + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, d( 1_${ik}$ ), one, 1_${ik}$, nrhs, b, ldb, info ) + d( 1_${ik}$ ) = abs( d( 1_${ik}$ ) ) end if return end if ! rotate the matrix if it is lower bidiagonal. if( uplo=='L' ) then do i = 1, n - 1 - call stdlib_slartg( d( i ), e( i ), cs, sn, r ) + call stdlib${ii}$_slartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) - if( nrhs==1 ) then - call stdlib_srot( 1, b( i, 1 ), 1, b( i+1, 1 ), 1, cs, sn ) + if( nrhs==1_${ik}$ ) then + call stdlib${ii}$_srot( 1_${ik}$, b( i, 1_${ik}$ ), 1_${ik}$, b( i+1, 1_${ik}$ ), 1_${ik}$, cs, sn ) else - work( i*2-1 ) = cs - work( i*2 ) = sn + work( i*2_${ik}$-1 ) = cs + work( i*2_${ik}$ ) = sn end if end do - if( nrhs>1 ) then + if( nrhs>1_${ik}$ ) then do i = 1, nrhs do j = 1, n - 1 - cs = work( j*2-1 ) - sn = work( j*2 ) - call stdlib_srot( 1, b( j, i ), 1, b( j+1, i ), 1, cs, sn ) + cs = work( j*2_${ik}$-1 ) + sn = work( j*2_${ik}$ ) + call stdlib${ii}$_srot( 1_${ik}$, b( j, i ), 1_${ik}$, b( j+1, i ), 1_${ik}$, cs, sn ) end do end do end if end if ! scale. - nm1 = n - 1 - orgnrm = stdlib_slanst( 'M', n, d, e ) + nm1 = n - 1_${ik}$ + orgnrm = stdlib${ii}$_slanst( 'M', n, d, e ) if( orgnrm==zero ) then - call stdlib_slaset( 'A', n, nrhs, zero, zero, b, ldb ) + call stdlib${ii}$_slaset( 'A', n, nrhs, zero, zero, b, ldb ) return end if - call stdlib_slascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info ) - call stdlib_slascl( 'G', 0, 0, orgnrm, one, nm1, 1, e, nm1, info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, n, 1_${ik}$, d, n, info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, nm1, 1_${ik}$, e, nm1, info ) ! if n is smaller than the minimum divide size smlsiz, then solve ! the problem with another solver. if( n<=smlsiz ) then - nwork = 1 + n*n - call stdlib_slaset( 'A', n, n, zero, one, work, n ) - call stdlib_slasdq( 'U', 0, n, n, 0, nrhs, d, e, work, n, work, n, b,ldb, work( & + nwork = 1_${ik}$ + n*n + call stdlib${ii}$_slaset( 'A', n, n, zero, one, work, n ) + call stdlib${ii}$_slasdq( 'U', 0_${ik}$, n, n, 0_${ik}$, nrhs, d, e, work, n, work, n, b,ldb, work( & nwork ), info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if - tol = rcnd*abs( d( stdlib_isamax( n, d, 1 ) ) ) + tol = rcnd*abs( d( stdlib${ii}$_isamax( n, d, 1_${ik}$ ) ) ) do i = 1, n if( d( i )<=tol ) then - call stdlib_slaset( 'A', 1, nrhs, zero, zero, b( i, 1 ), ldb ) + call stdlib${ii}$_slaset( 'A', 1_${ik}$, nrhs, zero, zero, b( i, 1_${ik}$ ), ldb ) else - call stdlib_slascl( 'G', 0, 0, d( i ), one, 1, nrhs, b( i, 1 ),ldb, info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, d( i ), one, 1_${ik}$, nrhs, b( i, 1_${ik}$ ),ldb, info ) - rank = rank + 1 + rank = rank + 1_${ik}$ end if end do - call stdlib_sgemm( 'T', 'N', n, nrhs, n, one, work, n, b, ldb, zero,work( nwork ), & + call stdlib${ii}$_sgemm( 'T', 'N', n, nrhs, n, one, work, n, b, ldb, zero,work( nwork ), & n ) - call stdlib_slacpy( 'A', n, nrhs, work( nwork ), n, b, ldb ) + call stdlib${ii}$_slacpy( 'A', n, nrhs, work( nwork ), n, b, ldb ) ! unscale. - call stdlib_slascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) - call stdlib_slasrt( 'D', n, d, info ) - call stdlib_slascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, n, 1_${ik}$, d, n, info ) + call stdlib${ii}$_slasrt( 'D', n, d, info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, n, nrhs, b, ldb, info ) return end if ! book-keeping and setting up some constants. - nlvl = int( log( real( n,KIND=sp) / real( smlsiz+1,KIND=sp) ) / log( two ),KIND=ilp) + & - 1 - smlszp = smlsiz + 1 - u = 1 - vt = 1 + smlsiz*n + nlvl = int( log( real( n,KIND=sp) / real( smlsiz+1,KIND=sp) ) / log( two ),KIND=${ik}$) + & + 1_${ik}$ + smlszp = smlsiz + 1_${ik}$ + u = 1_${ik}$ + vt = 1_${ik}$ + smlsiz*n difl = vt + smlszp*n difr = difl + nlvl*n - z = difr + nlvl*n*2 + z = difr + nlvl*n*2_${ik}$ c = z + nlvl*n s = c + n poles = s + n - givnum = poles + 2*nlvl*n - bx = givnum + 2*nlvl*n + givnum = poles + 2_${ik}$*nlvl*n + bx = givnum + 2_${ik}$*nlvl*n nwork = bx + n*nrhs - sizei = 1 + n + sizei = 1_${ik}$ + n k = sizei + n givptr = k + n perm = givptr + n givcol = perm + nlvl*n - iwk = givcol + nlvl*n*2 - st = 1 - sqre = 0 - icmpq1 = 1 - icmpq2 = 0 - nsub = 0 + iwk = givcol + nlvl*n*2_${ik}$ + st = 1_${ik}$ + sqre = 0_${ik}$ + icmpq1 = 1_${ik}$ + icmpq2 = 0_${ik}$ + nsub = 0_${ik}$ do i = 1, n if( abs( d( i ) )=eps ) then ! a subproblem with e(nm1) not too small but i = nm1. - nsize = n - st + 1 + nsize = n - st + 1_${ik}$ iwork( sizei+nsub-1 ) = nsize else ! a subproblem with e(nm1) small. this implies an ! 1-by-1 subproblem at d(n), which is not solved ! explicitly. - nsize = i - st + 1 + nsize = i - st + 1_${ik}$ iwork( sizei+nsub-1 ) = nsize - nsub = nsub + 1 + nsub = nsub + 1_${ik}$ iwork( nsub ) = n - iwork( sizei+nsub-1 ) = 1 - call stdlib_scopy( nrhs, b( n, 1 ), ldb, work( bx+nm1 ), n ) + iwork( sizei+nsub-1 ) = 1_${ik}$ + call stdlib${ii}$_scopy( nrhs, b( n, 1_${ik}$ ), ldb, work( bx+nm1 ), n ) end if - st1 = st - 1 - if( nsize==1 ) then + st1 = st - 1_${ik}$ + if( nsize==1_${ik}$ ) then ! this is a 1-by-1 subproblem and is not solved ! explicitly. - call stdlib_scopy( nrhs, b( st, 1 ), ldb, work( bx+st1 ), n ) + call stdlib${ii}$_scopy( nrhs, b( st, 1_${ik}$ ), ldb, work( bx+st1 ), n ) else if( nsize<=smlsiz ) then - ! this is a small subproblem and is solved by stdlib_slasdq. - call stdlib_slaset( 'A', nsize, nsize, zero, one,work( vt+st1 ), n ) - call stdlib_slasdq( 'U', 0, nsize, nsize, 0, nrhs, d( st ),e( st ), work( vt+& - st1 ), n, work( nwork ),n, b( st, 1 ), ldb, work( nwork ), info ) - if( info/=0 ) then + ! this is a small subproblem and is solved by stdlib${ii}$_slasdq. + call stdlib${ii}$_slaset( 'A', nsize, nsize, zero, one,work( vt+st1 ), n ) + call stdlib${ii}$_slasdq( 'U', 0_${ik}$, nsize, nsize, 0_${ik}$, nrhs, d( st ),e( st ), work( vt+& + st1 ), n, work( nwork ),n, b( st, 1_${ik}$ ), ldb, work( nwork ), info ) + if( info/=0_${ik}$ ) then return end if - call stdlib_slacpy( 'A', nsize, nrhs, b( st, 1 ), ldb,work( bx+st1 ), n ) + call stdlib${ii}$_slacpy( 'A', nsize, nrhs, b( st, 1_${ik}$ ), ldb,work( bx+st1 ), n ) else ! a large problem. solve it using divide and conquer. - call stdlib_slasda( icmpq1, smlsiz, nsize, sqre, d( st ),e( st ), work( u+st1 & + call stdlib${ii}$_slasda( icmpq1, smlsiz, nsize, sqre, d( st ),e( st ), work( u+st1 & ), n, work( vt+st1 ),iwork( k+st1 ), work( difl+st1 ),work( difr+st1 ), work( & z+st1 ),work( poles+st1 ), iwork( givptr+st1 ),iwork( givcol+st1 ), n, iwork( & perm+st1 ),work( givnum+st1 ), work( c+st1 ),work( s+st1 ), work( nwork ), & iwork( iwk ),info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if bxst = bx + st1 - call stdlib_slalsa( icmpq2, smlsiz, nsize, nrhs, b( st, 1 ),ldb, work( bxst ),& + call stdlib${ii}$_slalsa( icmpq2, smlsiz, nsize, nrhs, b( st, 1_${ik}$ ),ldb, work( bxst ),& n, work( u+st1 ), n,work( vt+st1 ), iwork( k+st1 ),work( difl+st1 ), work( & difr+st1 ),work( z+st1 ), work( poles+st1 ),iwork( givptr+st1 ), iwork( & givcol+st1 ), n,iwork( perm+st1 ), work( givnum+st1 ),work( c+st1 ), work( s+& st1 ), work( nwork ),iwork( iwk ), info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if end if - st = i + 1 + st = i + 1_${ik}$ end if end do loop_60 ! apply the singular values and treat the tiny ones as zero. - tol = rcnd*abs( d( stdlib_isamax( n, d, 1 ) ) ) + tol = rcnd*abs( d( stdlib${ii}$_isamax( n, d, 1_${ik}$ ) ) ) do i = 1, n ! some of the elements in d can be negative because 1-by-1 ! subproblems were not solved explicitly. if( abs( d( i ) )<=tol ) then - call stdlib_slaset( 'A', 1, nrhs, zero, zero, work( bx+i-1 ), n ) + call stdlib${ii}$_slaset( 'A', 1_${ik}$, nrhs, zero, zero, work( bx+i-1 ), n ) else - rank = rank + 1 - call stdlib_slascl( 'G', 0, 0, d( i ), one, 1, nrhs,work( bx+i-1 ), n, info ) + rank = rank + 1_${ik}$ + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, d( i ), one, 1_${ik}$, nrhs,work( bx+i-1 ), n, info ) end if d( i ) = abs( d( i ) ) end do ! now apply back the right singular vectors. - icmpq2 = 1 + icmpq2 = 1_${ik}$ do i = 1, nsub st = iwork( i ) - st1 = st - 1 + st1 = st - 1_${ik}$ nsize = iwork( sizei+i-1 ) bxst = bx + st1 - if( nsize==1 ) then - call stdlib_scopy( nrhs, work( bxst ), n, b( st, 1 ), ldb ) + if( nsize==1_${ik}$ ) then + call stdlib${ii}$_scopy( nrhs, work( bxst ), n, b( st, 1_${ik}$ ), ldb ) else if( nsize<=smlsiz ) then - call stdlib_sgemm( 'T', 'N', nsize, nrhs, nsize, one,work( vt+st1 ), n, work( & - bxst ), n, zero,b( st, 1 ), ldb ) + call stdlib${ii}$_sgemm( 'T', 'N', nsize, nrhs, nsize, one,work( vt+st1 ), n, work( & + bxst ), n, zero,b( st, 1_${ik}$ ), ldb ) else - call stdlib_slalsa( icmpq2, smlsiz, nsize, nrhs, work( bxst ), n,b( st, 1 ), ldb,& + call stdlib${ii}$_slalsa( icmpq2, smlsiz, nsize, nrhs, work( bxst ), n,b( st, 1_${ik}$ ), ldb,& work( u+st1 ), n,work( vt+st1 ), iwork( k+st1 ),work( difl+st1 ), work( difr+& st1 ),work( z+st1 ), work( poles+st1 ),iwork( givptr+st1 ), iwork( givcol+st1 ),& n,iwork( perm+st1 ), work( givnum+st1 ),work( c+st1 ), work( s+st1 ), work( & nwork ),iwork( iwk ), info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if end if end do ! unscale and sort the singular values. - call stdlib_slascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) - call stdlib_slasrt( 'D', n, d, info ) - call stdlib_slascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, n, 1_${ik}$, d, n, info ) + call stdlib${ii}$_slasrt( 'D', n, d, info ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, n, nrhs, b, ldb, info ) return - end subroutine stdlib_slalsd + end subroutine stdlib${ii}$_slalsd - subroutine stdlib_slaqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, work,& + subroutine stdlib${ii}$_slaqr0( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, work,& !! SLAQR0 computes the eigenvalues of a Hessenberg matrix H !! and, optionally, the matrices T and Z from the Schur decomposition !! H = Z T Z**T, where T is an upper quasi-triangular matrix (the @@ -79945,21 +79946,21 @@ 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) :: ihi, ihiz, ilo, iloz, ldh, ldz, lwork, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ihiz, ilo, iloz, ldh, ldz, lwork, n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt, wantz ! Array Arguments real(sp), intent(inout) :: h(ldh,*), z(ldz,*) real(sp), intent(out) :: wi(*), work(*), wr(*) ! ================================================================ ! Parameters - integer(ilp), parameter :: ntiny = 15 - integer(ilp), parameter :: kexnw = 5 - integer(ilp), parameter :: kexsh = 6 + integer(${ik}$), parameter :: ntiny = 15_${ik}$ + integer(${ik}$), parameter :: kexnw = 5_${ik}$ + integer(${ik}$), parameter :: kexsh = 6_${ik}$ real(sp), parameter :: wilk1 = 0.75_sp real(sp), parameter :: wilk2 = -0.4375_sp ! ==== matrices of order ntiny or smaller must be processed by - ! . stdlib_slahqr because of insufficient subdiagonal scratch space. + ! . stdlib${ii}$_slahqr because of insufficient subdiagonal scratch space. ! . (this is a hard limit.) ==== ! ==== exceptional deflation windows: try to cure rare @@ -79976,92 +79977,92 @@ module stdlib_linalg_lapack_s ! Local Scalars real(sp) :: aa, bb, cc, cs, dd, sn, ss, swap - integer(ilp) :: i, inf, it, itmax, k, kacc22, kbot, kdu, ks, kt, ktop, ku, kv, kwh, & + integer(${ik}$) :: i, inf, it, itmax, k, kacc22, kbot, kdu, ks, kt, ktop, ku, kv, kwh, & kwtop, kwv, ld, ls, lwkopt, ndec, ndfl, nh, nho, nibble, nmin, ns, nsmax, nsr, nve, nw,& nwmax, nwr, nwupbd logical(lk) :: sorted - character :: jbcmpz*2 + character(len=2_${ik}$) :: jbcmpz ! Local Arrays - real(sp) :: zdum(1,1) + real(sp) :: zdum(1_${ik}$,1_${ik}$) ! Intrinsic Functions intrinsic :: abs,int,max,min,mod,real ! Executable Statements - info = 0 + info = 0_${ik}$ ! ==== quick return for n = 0: nothing to do. ==== - if( n==0 ) then - work( 1 ) = one + if( n==0_${ik}$ ) then + work( 1_${ik}$ ) = one return end if if( n<=ntiny ) then ! ==== tiny matrices must use stdlib_slahqr. ==== - lwkopt = 1 - if( lwork/=-1 )call stdlib_slahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, & + lwkopt = 1_${ik}$ + if( lwork/=-1_${ik}$ )call stdlib${ii}$_slahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, & ihiz, z, ldz, info ) else ! ==== use small bulge multi-shift qr with aggressive early ! . deflation on larger-than-tiny matrices. ==== ! ==== hope for the best. ==== - info = 0 - ! ==== set up job flags for stdlib_ilaenv. ==== + info = 0_${ik}$ + ! ==== set up job flags for stdlib${ii}$_ilaenv. ==== if( wantt ) then - jbcmpz( 1: 1 ) = 'S' + jbcmpz( 1_${ik}$: 1_${ik}$ ) = 'S' else - jbcmpz( 1: 1 ) = 'E' + jbcmpz( 1_${ik}$: 1_${ik}$ ) = 'E' end if if( wantz ) then - jbcmpz( 2: 2 ) = 'V' + jbcmpz( 2_${ik}$: 2_${ik}$ ) = 'V' else - jbcmpz( 2: 2 ) = 'N' + jbcmpz( 2_${ik}$: 2_${ik}$ ) = 'N' end if ! ==== nwr = recommended deflation window size. at this ! . point, n > ntiny = 15, so there is enough ! . subdiagonal workspace for nwr>=2 as required. ! . (in fact, there is enough subdiagonal space for ! . nwr>=4.) ==== - nwr = stdlib_ilaenv( 13, 'SLAQR0', jbcmpz, n, ilo, ihi, lwork ) - nwr = max( 2, nwr ) - nwr = min( ihi-ilo+1, ( n-1 ) / 3, nwr ) + nwr = stdlib${ii}$_ilaenv( 13_${ik}$, 'SLAQR0', jbcmpz, n, ilo, ihi, lwork ) + nwr = max( 2_${ik}$, nwr ) + nwr = min( ihi-ilo+1, ( n-1 ) / 3_${ik}$, nwr ) ! ==== nsr = recommended number of simultaneous shifts. ! . at this point n > ntiny = 15, so there is at ! . enough subdiagonal workspace for nsr to be even ! . and greater than or equal to two as required. ==== - nsr = stdlib_ilaenv( 15, 'SLAQR0', jbcmpz, n, ilo, ihi, lwork ) - nsr = min( nsr, ( n-3 ) / 6, ihi-ilo ) - nsr = max( 2, nsr-mod( nsr, 2 ) ) + nsr = stdlib${ii}$_ilaenv( 15_${ik}$, 'SLAQR0', jbcmpz, n, ilo, ihi, lwork ) + nsr = min( nsr, ( n-3 ) / 6_${ik}$, ihi-ilo ) + nsr = max( 2_${ik}$, nsr-mod( nsr, 2_${ik}$ ) ) ! ==== estimate optimal workspace ==== - ! ==== workspace query call to stdlib_slaqr3 ==== - call stdlib_slaqr3( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& - ld, wr, wi, h, ldh, n, h, ldh,n, h, ldh, work, -1 ) - ! ==== optimal workspace = max(stdlib_slaqr5, stdlib_slaqr3) ==== - lwkopt = max( 3*nsr / 2, int( work( 1 ),KIND=ilp) ) + ! ==== workspace query call to stdlib${ii}$_slaqr3 ==== + call stdlib${ii}$_slaqr3( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& + ld, wr, wi, h, ldh, n, h, ldh,n, h, ldh, work, -1_${ik}$ ) + ! ==== optimal workspace = max(stdlib${ii}$_slaqr5, stdlib${ii}$_slaqr3) ==== + lwkopt = max( 3_${ik}$*nsr / 2_${ik}$, int( work( 1_${ik}$ ),KIND=${ik}$) ) ! ==== quick return in case of workspace query. ==== - if( lwork==-1 ) then - work( 1 ) = real( lwkopt,KIND=sp) + if( lwork==-1_${ik}$ ) then + work( 1_${ik}$ ) = real( lwkopt,KIND=sp) return end if - ! ==== stdlib_slahqr/stdlib_slaqr0 crossover point ==== - nmin = stdlib_ilaenv( 12, 'SLAQR0', jbcmpz, n, ilo, ihi, lwork ) + ! ==== stdlib${ii}$_slahqr/stdlib${ii}$_slaqr0 crossover point ==== + nmin = stdlib${ii}$_ilaenv( 12_${ik}$, 'SLAQR0', jbcmpz, n, ilo, ihi, lwork ) nmin = max( ntiny, nmin ) ! ==== nibble crossover point ==== - nibble = stdlib_ilaenv( 14, 'SLAQR0', jbcmpz, n, ilo, ihi, lwork ) - nibble = max( 0, nibble ) + nibble = stdlib${ii}$_ilaenv( 14_${ik}$, 'SLAQR0', jbcmpz, n, ilo, ihi, lwork ) + nibble = max( 0_${ik}$, nibble ) ! ==== accumulate reflections during ttswp? use block ! . 2-by-2 structure during matrix-matrix multiply? ==== - kacc22 = stdlib_ilaenv( 16, 'SLAQR0', jbcmpz, n, ilo, ihi, lwork ) - kacc22 = max( 0, kacc22 ) - kacc22 = min( 2, kacc22 ) + kacc22 = stdlib${ii}$_ilaenv( 16_${ik}$, 'SLAQR0', jbcmpz, n, ilo, ihi, lwork ) + kacc22 = max( 0_${ik}$, kacc22 ) + kacc22 = min( 2_${ik}$, kacc22 ) ! ==== nwmax = the largest possible deflation window for ! . which there is sufficient workspace. ==== - nwmax = min( ( n-1 ) / 3, lwork / 2 ) + nwmax = min( ( n-1 ) / 3_${ik}$, lwork / 2_${ik}$ ) nw = nwmax ! ==== nsmax = the largest number of simultaneous shifts ! . for which there is sufficient workspace. ==== - nsmax = min( ( n-3 ) / 6, 2*lwork / 3 ) - nsmax = nsmax - mod( nsmax, 2 ) + nsmax = min( ( n-3 ) / 6_${ik}$, 2_${ik}$*lwork / 3_${ik}$ ) + nsmax = nsmax - mod( nsmax, 2_${ik}$ ) ! ==== ndfl: an iteration count restarted at deflation. ==== - ndfl = 1 + ndfl = 1_${ik}$ ! ==== itmax = iteration limit ==== - itmax = max( 30, 2*kexsh )*max( 10, ( ihi-ilo+1 ) ) + itmax = max( 30_${ik}$, 2_${ik}$*kexsh )*max( 10_${ik}$, ( ihi-ilo+1 ) ) ! ==== last row and column in the active block ==== kbot = ihi ! ==== main loop ==== @@ -80089,27 +80090,27 @@ module stdlib_linalg_lapack_s ! . in general, more powerful than smaller ones, ! . rapidly increase the window to the maximum possible. ! . then, gradually reduce the window size. ==== - nh = kbot - ktop + 1 + nh = kbot - ktop + 1_${ik}$ nwupbd = min( nh, nwmax ) if( ndfl=nh-1 ) then nw = nh else - kwtop = kbot - nw + 1 + kwtop = kbot - nw + 1_${ik}$ if( abs( h( kwtop, kwtop-1 ) )>abs( h( kwtop-1, kwtop-2 ) ) )nw = nw + & - 1 + 1_${ik}$ end if end if if( ndfl=0 .or. nw>=nwupbd ) then - ndec = ndec + 1 - if( nw-ndec<2 )ndec = 0 + ndec = -1_${ik}$ + else if( ndec>=0_${ik}$ .or. nw>=nwupbd ) then + ndec = ndec + 1_${ik}$ + if( nw-ndec<2_${ik}$ )ndec = 0_${ik}$ nw = nw - ndec end if ! ==== aggressive early deflation: @@ -80122,46 +80123,46 @@ module stdlib_linalg_lapack_s ! . - an at-least-nw-but-more-is-better (nhv-by-nw) ! . vertical work array along the left-hand-edge. ! . ==== - kv = n - nw + 1 - kt = nw + 1 - nho = ( n-nw-1 ) - kt + 1 - kwv = nw + 2 - nve = ( n-nw ) - kwv + 1 + kv = n - nw + 1_${ik}$ + kt = nw + 1_${ik}$ + nho = ( n-nw-1 ) - kt + 1_${ik}$ + kwv = nw + 2_${ik}$ + nve = ( n-nw ) - kwv + 1_${ik}$ ! ==== aggressive early deflation ==== - call stdlib_slaqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & - ls, ld, wr, wi, h( kv, 1 ), ldh,nho, h( kv, kt ), ldh, nve, h( kwv, 1 ), ldh,& + call stdlib${ii}$_slaqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & + ls, ld, wr, wi, h( kv, 1_${ik}$ ), ldh,nho, h( kv, kt ), ldh, nve, h( kwv, 1_${ik}$ ), ldh,& work, lwork ) ! ==== adjust kbot accounting for new deflations. ==== kbot = kbot - ld ! ==== ks points to the shifts. ==== - ks = kbot - ls + 1 + ks = kbot - ls + 1_${ik}$ ! ==== skip an expensive qr sweep if there is a (partly ! . heuristic) reason to expect that many eigenvalues ! . will deflate without it. here, the qr sweep is ! . skipped if many eigenvalues have just been deflated ! . or if the remaining active block is small. - if( ( ld==0 ) .or. ( ( 100*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& + if( ( ld==0_${ik}$ ) .or. ( ( 100_${ik}$*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& ) ) ) then ! ==== ns = nominal number of simultaneous shifts. - ! . this may be lowered (slightly) if stdlib_slaqr3 + ! . this may be lowered (slightly) if stdlib${ii}$_slaqr3 ! . did not provide that many shifts. ==== - ns = min( nsmax, nsr, max( 2, kbot-ktop ) ) - ns = ns - mod( ns, 2 ) + ns = min( nsmax, nsr, max( 2_${ik}$, kbot-ktop ) ) + ns = ns - mod( ns, 2_${ik}$ ) ! ==== if there have been no deflations ! . in a multiple of kexsh iterations, ! . then try exceptional shifts. ! . otherwise use shifts provided by - ! . stdlib_slaqr3 above or from the eigenvalues + ! . stdlib${ii}$_slaqr3 above or from the eigenvalues ! . of a trailing principal submatrix. ==== - if( mod( ndfl, kexsh )==0 ) then - ks = kbot - ns + 1 + if( mod( ndfl, kexsh )==0_${ik}$ ) then + ks = kbot - ns + 1_${ik}$ do i = kbot, max( ks+1, ktop+2 ), -2 ss = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) ) aa = wilk1*ss + h( i, i ) bb = ss cc = wilk2*ss dd = aa - call stdlib_slanv2( aa, bb, cc, dd, wr( i-1 ), wi( i-1 ),wr( i ), wi( i & + call stdlib${ii}$_slanv2( aa, bb, cc, dd, wr( i-1 ), wi( i-1 ),wr( i ), wi( i & ), cs, sn ) end do if( ks==ktop ) then @@ -80172,21 +80173,21 @@ module stdlib_linalg_lapack_s end if else ! ==== got ns/2 or fewer shifts? use stdlib_slaqr4 or - ! . stdlib_slahqr on a trailing principal submatrix to + ! . stdlib${ii}$_slahqr on a trailing principal submatrix to ! . get more. (since ns<=nsmax<=(n-3)/6, ! . there is enough space below the subdiagonal ! . to fit an ns-by-ns scratch array.) ==== - if( kbot-ks+1<=ns / 2 ) then - ks = kbot - ns + 1 - kt = n - ns + 1 - call stdlib_slacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1 ), ldh ) + if( kbot-ks+1<=ns / 2_${ik}$ ) then + ks = kbot - ns + 1_${ik}$ + kt = n - ns + 1_${ik}$ + call stdlib${ii}$_slacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1_${ik}$ ), ldh ) if( ns>nmin ) then - call stdlib_slaqr4( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, wr( & - ks ),wi( ks ), 1, 1, zdum, 1, work,lwork, inf ) + call stdlib${ii}$_slaqr4( .false., .false., ns, 1_${ik}$, ns,h( kt, 1_${ik}$ ), ldh, wr( & + ks ),wi( ks ), 1_${ik}$, 1_${ik}$, zdum, 1_${ik}$, work,lwork, inf ) else - call stdlib_slahqr( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, wr( & - ks ),wi( ks ), 1, 1, zdum, 1, inf ) + call stdlib${ii}$_slahqr( .false., .false., ns, 1_${ik}$, ns,h( kt, 1_${ik}$ ), ldh, wr( & + ks ),wi( ks ), 1_${ik}$, 1_${ik}$, zdum, 1_${ik}$, inf ) end if ks = ks + inf ! ==== in case of a rare qr failure use @@ -80197,9 +80198,9 @@ module stdlib_linalg_lapack_s cc = h( kbot, kbot-1 ) bb = h( kbot-1, kbot ) dd = h( kbot, kbot ) - call stdlib_slanv2( aa, bb, cc, dd, wr( kbot-1 ),wi( kbot-1 ), wr( & + call stdlib${ii}$_slanv2( aa, bb, cc, dd, wr( kbot-1 ),wi( kbot-1 ), wr( & kbot ),wi( kbot ), cs, sn ) - ks = kbot - 1 + ks = kbot - 1_${ik}$ end if end if if( kbot-ks+1>ns ) then @@ -80245,7 +80246,7 @@ module stdlib_linalg_lapack_s end if ! ==== if there are only two shifts and both are ! . real, then use only one. ==== - if( kbot-ks+1==2 ) then + if( kbot-ks+1==2_${ik}$ ) then if( wi( kbot )==zero ) then if( abs( wr( kbot )-h( kbot, kbot ) )0 ) then - ndfl = 1 + if( ld>0_${ik}$ ) then + ndfl = 1_${ik}$ else - ndfl = ndfl + 1 + ndfl = ndfl + 1_${ik}$ end if ! ==== end of main loop ==== end do loop_80 @@ -80297,11 +80298,11 @@ module stdlib_linalg_lapack_s 90 continue end if ! ==== return the optimal value of lwork. ==== - work( 1 ) = real( lwkopt,KIND=sp) - end subroutine stdlib_slaqr0 + work( 1_${ik}$ ) = real( lwkopt,KIND=sp) + end subroutine stdlib${ii}$_slaqr0 - subroutine stdlib_slaqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, ns, nd,& + subroutine stdlib${ii}$_slaqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, ns, nd,& !! Aggressive early deflation: !! SLAQR3 accepts as input an upper Hessenberg matrix !! H and performs an orthogonal similarity transformation @@ -80316,9 +80317,9 @@ 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) :: ihiz, iloz, kbot, ktop, ldh, ldt, ldv, ldwv, ldz, lwork, n,& + integer(${ik}$), intent(in) :: ihiz, iloz, kbot, ktop, ldh, ldt, ldv, ldwv, ldz, lwork, n,& nh, nv, nw - integer(ilp), intent(out) :: nd, ns + integer(${ik}$), intent(out) :: nd, ns logical(lk), intent(in) :: wantt, wantz ! Array Arguments real(sp), intent(inout) :: h(ldh,*), z(ldz,*) @@ -80328,7 +80329,7 @@ module stdlib_linalg_lapack_s ! Local Scalars real(sp) :: aa, bb, beta, cc, cs, dd, evi, evk, foo, s, safmax, safmin, smlnum, sn, & tau, ulp - integer(ilp) :: i, ifst, ilst, info, infqr, j, jw, k, kcol, kend, kln, krow, kwtop, & + integer(${ik}$) :: i, ifst, ilst, info, infqr, j, jw, k, kcol, kend, kln, krow, kwtop, & ltop, lwk1, lwk2, lwk3, lwkopt, nmin logical(lk) :: bulge, sorted ! Intrinsic Functions @@ -80336,45 +80337,45 @@ module stdlib_linalg_lapack_s ! Executable Statements ! ==== estimate optimal workspace. ==== jw = min( nw, kbot-ktop+1 ) - if( jw<=2 ) then - lwkopt = 1 - else - ! ==== workspace query call to stdlib_sgehrd ==== - call stdlib_sgehrd( jw, 1, jw-1, t, ldt, work, work, -1, info ) - lwk1 = int( work( 1 ),KIND=ilp) - ! ==== workspace query call to stdlib_sormhr ==== - call stdlib_sormhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv,work, -1, info ) + if( jw<=2_${ik}$ ) then + lwkopt = 1_${ik}$ + else + ! ==== workspace query call to stdlib${ii}$_sgehrd ==== + call stdlib${ii}$_sgehrd( jw, 1_${ik}$, jw-1, t, ldt, work, work, -1_${ik}$, info ) + lwk1 = int( work( 1_${ik}$ ),KIND=${ik}$) + ! ==== workspace query call to stdlib${ii}$_sormhr ==== + call stdlib${ii}$_sormhr( 'R', 'N', jw, jw, 1_${ik}$, jw-1, t, ldt, work, v, ldv,work, -1_${ik}$, info ) - lwk2 = int( work( 1 ),KIND=ilp) - ! ==== workspace query call to stdlib_slaqr4 ==== - call stdlib_slaqr4( .true., .true., jw, 1, jw, t, ldt, sr, si, 1, jw,v, ldv, work, -& - 1, infqr ) - lwk3 = int( work( 1 ),KIND=ilp) + lwk2 = int( work( 1_${ik}$ ),KIND=${ik}$) + ! ==== workspace query call to stdlib${ii}$_slaqr4 ==== + call stdlib${ii}$_slaqr4( .true., .true., jw, 1_${ik}$, jw, t, ldt, sr, si, 1_${ik}$, jw,v, ldv, work, -& + 1_${ik}$, infqr ) + lwk3 = int( work( 1_${ik}$ ),KIND=${ik}$) ! ==== optimal workspace ==== lwkopt = max( jw+max( lwk1, lwk2 ), lwk3 ) end if ! ==== quick return in case of workspace query. ==== - if( lwork==-1 ) then - work( 1 ) = real( lwkopt,KIND=sp) + if( lwork==-1_${ik}$ ) then + work( 1_${ik}$ ) = real( lwkopt,KIND=sp) return end if ! ==== nothing to do ... ! ... for an empty active block ... ==== - ns = 0 - nd = 0 - work( 1 ) = one + ns = 0_${ik}$ + nd = 0_${ik}$ + work( 1_${ik}$ ) = one if( ktop>kbot )return ! ... nor for an empty deflation window. ==== if( nw<1 )return ! ==== machine constants ==== - safmin = stdlib_slamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) safmax = one / safmin - call stdlib_slabad( safmin, safmax ) - ulp = stdlib_slamch( 'PRECISION' ) + call stdlib${ii}$_slabad( safmin, safmax ) + ulp = stdlib${ii}$_slamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=sp) / ulp ) ! ==== setup deflation window ==== jw = min( nw, kbot-ktop+1 ) - kwtop = kbot - jw + 1 + kwtop = kbot - jw + 1_${ik}$ if( kwtop==ktop ) then s = zero else @@ -80384,14 +80385,14 @@ module stdlib_linalg_lapack_s ! ==== 1-by-1 deflation window: not much to do ==== sr( kwtop ) = h( kwtop, kwtop ) si( kwtop ) = zero - ns = 1 - nd = 0 + ns = 1_${ik}$ + nd = 0_${ik}$ if( abs( s )<=max( smlnum, ulp*abs( h( kwtop, kwtop ) ) ) )then - ns = 0 - nd = 1 + ns = 0_${ik}$ + nd = 1_${ik}$ if( kwtop>ktop )h( kwtop, kwtop-1 ) = zero end if - work( 1 ) = one + work( 1_${ik}$ ) = one return end if ! ==== convert to spike-triangular form. (in case of a @@ -80399,29 +80400,29 @@ module stdlib_linalg_lapack_s ! . aggressive early deflation using that part of ! . the deflation window that converged using infqr ! . here and there to keep track.) ==== - call stdlib_slacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) - call stdlib_scopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 ) - call stdlib_slaset( 'A', jw, jw, zero, one, v, ldv ) - nmin = stdlib_ilaenv( 12, 'SLAQR3', 'SV', jw, 1, jw, lwork ) + call stdlib${ii}$_slacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) + call stdlib${ii}$_scopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2_${ik}$, 1_${ik}$ ), ldt+1 ) + call stdlib${ii}$_slaset( 'A', jw, jw, zero, one, v, ldv ) + nmin = stdlib${ii}$_ilaenv( 12_${ik}$, 'SLAQR3', 'SV', jw, 1_${ik}$, jw, lwork ) if( jw>nmin ) then - call stdlib_slaqr4( .true., .true., jw, 1, jw, t, ldt, sr( kwtop ),si( kwtop ), 1, & + call stdlib${ii}$_slaqr4( .true., .true., jw, 1_${ik}$, jw, t, ldt, sr( kwtop ),si( kwtop ), 1_${ik}$, & jw, v, ldv, work, lwork, infqr ) else - call stdlib_slahqr( .true., .true., jw, 1, jw, t, ldt, sr( kwtop ),si( kwtop ), 1, & + call stdlib${ii}$_slahqr( .true., .true., jw, 1_${ik}$, jw, t, ldt, sr( kwtop ),si( kwtop ), 1_${ik}$, & jw, v, ldv, infqr ) end if - ! ==== stdlib_strexc needs a clean margin near the diagonal ==== + ! ==== stdlib${ii}$_strexc needs a clean margin near the diagonal ==== do j = 1, jw - 3 t( j+2, j ) = zero t( j+3, j ) = zero end do - if( jw>2 )t( jw, jw-2 ) = zero + if( jw>2_${ik}$ )t( jw, jw-2 ) = zero ! ==== deflation detection loop ==== ns = jw - ilst = infqr + 1 + ilst = infqr + 1_${ik}$ 20 continue if( ilst<=ns ) then - if( ns==1 ) then + if( ns==1_${ik}$ ) then bulge = .false. else bulge = t( ns, ns-1 )/=zero @@ -80431,56 +80432,56 @@ module stdlib_linalg_lapack_s ! ==== real eigenvalue ==== foo = abs( t( ns, ns ) ) if( foo==zero )foo = abs( s ) - if( abs( s*v( 1, ns ) )<=max( smlnum, ulp*foo ) ) then + if( abs( s*v( 1_${ik}$, ns ) )<=max( smlnum, ulp*foo ) ) then ! ==== deflatable ==== - ns = ns - 1 + ns = ns - 1_${ik}$ else ! ==== undeflatable. move it up out of the way. - ! . (stdlib_strexc can not fail in this case.) ==== + ! . (stdlib${ii}$_strexc can not fail in this case.) ==== ifst = ns - call stdlib_strexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) - ilst = ilst + 1 + call stdlib${ii}$_strexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) + ilst = ilst + 1_${ik}$ end if else ! ==== complex conjugate pair ==== foo = abs( t( ns, ns ) ) + sqrt( abs( t( ns, ns-1 ) ) )*sqrt( abs( t( ns-1, ns ) & ) ) if( foo==zero )foo = abs( s ) - if( max( abs( s*v( 1, ns ) ), abs( s*v( 1, ns-1 ) ) )<=max( smlnum, ulp*foo ) ) & + if( max( abs( s*v( 1_${ik}$, ns ) ), abs( s*v( 1_${ik}$, ns-1 ) ) )<=max( smlnum, ulp*foo ) ) & then ! ==== deflatable ==== - ns = ns - 2 + ns = ns - 2_${ik}$ else ! ==== undeflatable. move them up out of the way. - ! . fortunately, stdlib_strexc does the right thing with + ! . fortunately, stdlib${ii}$_strexc does the right thing with ! . ilst in case of a rare exchange failure. ==== ifst = ns - call stdlib_strexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) - ilst = ilst + 2 + call stdlib${ii}$_strexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, work,info ) + ilst = ilst + 2_${ik}$ end if end if ! ==== end deflation detection loop ==== go to 20 end if ! ==== return to hessenberg form ==== - if( ns==0 )s = zero + if( ns==0_${ik}$ )s = zero if( ns1 .and. s/=zero ) then + if( ns>1_${ik}$ .and. s/=zero ) then ! ==== reflect spike back into lower triangle ==== - call stdlib_scopy( ns, v, ldv, work, 1 ) - beta = work( 1 ) - call stdlib_slarfg( ns, beta, work( 2 ), 1, tau ) - work( 1 ) = one - call stdlib_slaset( 'L', jw-2, jw-2, zero, zero, t( 3, 1 ), ldt ) - call stdlib_slarf( 'L', ns, jw, work, 1, tau, t, ldt,work( jw+1 ) ) - call stdlib_slarf( 'R', ns, ns, work, 1, tau, t, ldt,work( jw+1 ) ) - call stdlib_slarf( 'R', jw, ns, work, 1, tau, v, ldv,work( jw+1 ) ) - call stdlib_sgehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) + call stdlib${ii}$_scopy( ns, v, ldv, work, 1_${ik}$ ) + beta = work( 1_${ik}$ ) + call stdlib${ii}$_slarfg( ns, beta, work( 2_${ik}$ ), 1_${ik}$, tau ) + work( 1_${ik}$ ) = one + call stdlib${ii}$_slaset( 'L', jw-2, jw-2, zero, zero, t( 3_${ik}$, 1_${ik}$ ), ldt ) + call stdlib${ii}$_slarf( 'L', ns, jw, work, 1_${ik}$, tau, t, ldt,work( jw+1 ) ) + call stdlib${ii}$_slarf( 'R', ns, ns, work, 1_${ik}$, tau, t, ldt,work( jw+1 ) ) + call stdlib${ii}$_slarf( 'R', jw, ns, work, 1_${ik}$, tau, v, ldv,work( jw+1 ) ) + call stdlib${ii}$_sgehrd( jw, 1_${ik}$, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) end if ! ==== copy updated reduced window into place ==== - if( kwtop>1 )h( kwtop, kwtop-1 ) = s*v( 1, 1 ) - call stdlib_slacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) - call stdlib_scopy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) + if( kwtop>1_${ik}$ )h( kwtop, kwtop-1 ) = s*v( 1_${ik}$, 1_${ik}$ ) + call stdlib${ii}$_slacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) + call stdlib${ii}$_scopy( jw-1, t( 2_${ik}$, 1_${ik}$ ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) ! ==== accumulate orthogonal matrix in order update ! . h and z, if requested. ==== - if( ns>1 .and. s/=zero )call stdlib_sormhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, & + if( ns>1_${ik}$ .and. s/=zero )call stdlib${ii}$_sormhr( 'R', 'N', jw, ns, 1_${ik}$, ns, t, ldt, work, & v, ldv,work( jw+1 ), lwork-jw, info ) ! ==== update vertical slab in h ==== if( wantt ) then - ltop = 1 + ltop = 1_${ik}$ else ltop = ktop end if do krow = ltop, kwtop - 1, nv kln = min( nv, kwtop-krow ) - call stdlib_sgemm( 'N', 'N', kln, jw, jw, one, h( krow, kwtop ),ldh, v, ldv, & + call stdlib${ii}$_sgemm( 'N', 'N', kln, jw, jw, one, h( krow, kwtop ),ldh, v, ldv, & zero, wv, ldwv ) - call stdlib_slacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) + call stdlib${ii}$_slacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) end do ! ==== update horizontal slab in h ==== if( wantt ) then do kcol = kbot + 1, n, nh kln = min( nh, n-kcol+1 ) - call stdlib_sgemm( 'C', 'N', jw, kln, jw, one, v, ldv,h( kwtop, kcol ), ldh, & + call stdlib${ii}$_sgemm( 'C', 'N', jw, kln, jw, one, v, ldv,h( kwtop, kcol ), ldh, & zero, t, ldt ) - call stdlib_slacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) + call stdlib${ii}$_slacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) end do end if ! ==== update vertical slab in z ==== if( wantz ) then do krow = iloz, ihiz, nv kln = min( nv, ihiz-krow+1 ) - call stdlib_sgemm( 'N', 'N', kln, jw, jw, one, z( krow, kwtop ),ldz, v, ldv, & + call stdlib${ii}$_sgemm( 'N', 'N', kln, jw, jw, one, z( krow, kwtop ),ldz, v, ldv, & zero, wv, ldwv ) - call stdlib_slacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) + call stdlib${ii}$_slacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) end do end if end if @@ -80608,11 +80609,11 @@ module stdlib_linalg_lapack_s ! . window.) ==== ns = ns - infqr ! ==== return optimal workspace. ==== - work( 1 ) = real( lwkopt,KIND=sp) - end subroutine stdlib_slaqr3 + work( 1_${ik}$ ) = real( lwkopt,KIND=sp) + end subroutine stdlib${ii}$_slaqr3 - subroutine stdlib_slaqr4( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, work,& + subroutine stdlib${ii}$_slaqr4( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, ihiz, z, ldz, work,& !! SLAQR4 implements one level of recursion for SLAQR0. !! It is a complete implementation of the small bulge multi-shift !! QR algorithm. It may be called by SLAQR0 and, for large enough @@ -80632,21 +80633,21 @@ 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) :: ihi, ihiz, ilo, iloz, ldh, ldz, lwork, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ihiz, ilo, iloz, ldh, ldz, lwork, n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt, wantz ! Array Arguments real(sp), intent(inout) :: h(ldh,*), z(ldz,*) real(sp), intent(out) :: wi(*), work(*), wr(*) ! ================================================================ ! Parameters - integer(ilp), parameter :: ntiny = 15 - integer(ilp), parameter :: kexnw = 5 - integer(ilp), parameter :: kexsh = 6 + integer(${ik}$), parameter :: ntiny = 15_${ik}$ + integer(${ik}$), parameter :: kexnw = 5_${ik}$ + integer(${ik}$), parameter :: kexsh = 6_${ik}$ real(sp), parameter :: wilk1 = 0.75_sp real(sp), parameter :: wilk2 = -0.4375_sp ! ==== matrices of order ntiny or smaller must be processed by - ! . stdlib_slahqr because of insufficient subdiagonal scratch space. + ! . stdlib${ii}$_slahqr because of insufficient subdiagonal scratch space. ! . (this is a hard limit.) ==== ! ==== exceptional deflation windows: try to cure rare @@ -80663,92 +80664,92 @@ module stdlib_linalg_lapack_s ! Local Scalars real(sp) :: aa, bb, cc, cs, dd, sn, ss, swap - integer(ilp) :: i, inf, it, itmax, k, kacc22, kbot, kdu, ks, kt, ktop, ku, kv, kwh, & + integer(${ik}$) :: i, inf, it, itmax, k, kacc22, kbot, kdu, ks, kt, ktop, ku, kv, kwh, & kwtop, kwv, ld, ls, lwkopt, ndec, ndfl, nh, nho, nibble, nmin, ns, nsmax, nsr, nve, nw,& nwmax, nwr, nwupbd logical(lk) :: sorted - character :: jbcmpz*2 + character(len=2_${ik}$) :: jbcmpz ! Local Arrays - real(sp) :: zdum(1,1) + real(sp) :: zdum(1_${ik}$,1_${ik}$) ! Intrinsic Functions intrinsic :: abs,int,max,min,mod,real ! Executable Statements - info = 0 + info = 0_${ik}$ ! ==== quick return for n = 0: nothing to do. ==== - if( n==0 ) then - work( 1 ) = one + if( n==0_${ik}$ ) then + work( 1_${ik}$ ) = one return end if if( n<=ntiny ) then ! ==== tiny matrices must use stdlib_slahqr. ==== - lwkopt = 1 - if( lwork/=-1 )call stdlib_slahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, & + lwkopt = 1_${ik}$ + if( lwork/=-1_${ik}$ )call stdlib${ii}$_slahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi,iloz, & ihiz, z, ldz, info ) else ! ==== use small bulge multi-shift qr with aggressive early ! . deflation on larger-than-tiny matrices. ==== ! ==== hope for the best. ==== - info = 0 - ! ==== set up job flags for stdlib_ilaenv. ==== + info = 0_${ik}$ + ! ==== set up job flags for stdlib${ii}$_ilaenv. ==== if( wantt ) then - jbcmpz( 1: 1 ) = 'S' + jbcmpz( 1_${ik}$: 1_${ik}$ ) = 'S' else - jbcmpz( 1: 1 ) = 'E' + jbcmpz( 1_${ik}$: 1_${ik}$ ) = 'E' end if if( wantz ) then - jbcmpz( 2: 2 ) = 'V' + jbcmpz( 2_${ik}$: 2_${ik}$ ) = 'V' else - jbcmpz( 2: 2 ) = 'N' + jbcmpz( 2_${ik}$: 2_${ik}$ ) = 'N' end if ! ==== nwr = recommended deflation window size. at this ! . point, n > ntiny = 15, so there is enough ! . subdiagonal workspace for nwr>=2 as required. ! . (in fact, there is enough subdiagonal space for ! . nwr>=4.) ==== - nwr = stdlib_ilaenv( 13, 'SLAQR4', jbcmpz, n, ilo, ihi, lwork ) - nwr = max( 2, nwr ) - nwr = min( ihi-ilo+1, ( n-1 ) / 3, nwr ) + nwr = stdlib${ii}$_ilaenv( 13_${ik}$, 'SLAQR4', jbcmpz, n, ilo, ihi, lwork ) + nwr = max( 2_${ik}$, nwr ) + nwr = min( ihi-ilo+1, ( n-1 ) / 3_${ik}$, nwr ) ! ==== nsr = recommended number of simultaneous shifts. ! . at this point n > ntiny = 15, so there is at ! . enough subdiagonal workspace for nsr to be even ! . and greater than or equal to two as required. ==== - nsr = stdlib_ilaenv( 15, 'SLAQR4', jbcmpz, n, ilo, ihi, lwork ) - nsr = min( nsr, ( n-3 ) / 6, ihi-ilo ) - nsr = max( 2, nsr-mod( nsr, 2 ) ) + nsr = stdlib${ii}$_ilaenv( 15_${ik}$, 'SLAQR4', jbcmpz, n, ilo, ihi, lwork ) + nsr = min( nsr, ( n-3 ) / 6_${ik}$, ihi-ilo ) + nsr = max( 2_${ik}$, nsr-mod( nsr, 2_${ik}$ ) ) ! ==== estimate optimal workspace ==== - ! ==== workspace query call to stdlib_slaqr2 ==== - call stdlib_slaqr2( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& - ld, wr, wi, h, ldh, n, h, ldh,n, h, ldh, work, -1 ) - ! ==== optimal workspace = max(stdlib_slaqr5, stdlib_slaqr2) ==== - lwkopt = max( 3*nsr / 2, int( work( 1 ),KIND=ilp) ) + ! ==== workspace query call to stdlib${ii}$_slaqr2 ==== + call stdlib${ii}$_slaqr2( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& + ld, wr, wi, h, ldh, n, h, ldh,n, h, ldh, work, -1_${ik}$ ) + ! ==== optimal workspace = max(stdlib${ii}$_slaqr5, stdlib${ii}$_slaqr2) ==== + lwkopt = max( 3_${ik}$*nsr / 2_${ik}$, int( work( 1_${ik}$ ),KIND=${ik}$) ) ! ==== quick return in case of workspace query. ==== - if( lwork==-1 ) then - work( 1 ) = real( lwkopt,KIND=sp) + if( lwork==-1_${ik}$ ) then + work( 1_${ik}$ ) = real( lwkopt,KIND=sp) return end if - ! ==== stdlib_slahqr/stdlib_slaqr0 crossover point ==== - nmin = stdlib_ilaenv( 12, 'SLAQR4', jbcmpz, n, ilo, ihi, lwork ) + ! ==== stdlib${ii}$_slahqr/stdlib${ii}$_slaqr0 crossover point ==== + nmin = stdlib${ii}$_ilaenv( 12_${ik}$, 'SLAQR4', jbcmpz, n, ilo, ihi, lwork ) nmin = max( ntiny, nmin ) ! ==== nibble crossover point ==== - nibble = stdlib_ilaenv( 14, 'SLAQR4', jbcmpz, n, ilo, ihi, lwork ) - nibble = max( 0, nibble ) + nibble = stdlib${ii}$_ilaenv( 14_${ik}$, 'SLAQR4', jbcmpz, n, ilo, ihi, lwork ) + nibble = max( 0_${ik}$, nibble ) ! ==== accumulate reflections during ttswp? use block ! . 2-by-2 structure during matrix-matrix multiply? ==== - kacc22 = stdlib_ilaenv( 16, 'SLAQR4', jbcmpz, n, ilo, ihi, lwork ) - kacc22 = max( 0, kacc22 ) - kacc22 = min( 2, kacc22 ) + kacc22 = stdlib${ii}$_ilaenv( 16_${ik}$, 'SLAQR4', jbcmpz, n, ilo, ihi, lwork ) + kacc22 = max( 0_${ik}$, kacc22 ) + kacc22 = min( 2_${ik}$, kacc22 ) ! ==== nwmax = the largest possible deflation window for ! . which there is sufficient workspace. ==== - nwmax = min( ( n-1 ) / 3, lwork / 2 ) + nwmax = min( ( n-1 ) / 3_${ik}$, lwork / 2_${ik}$ ) nw = nwmax ! ==== nsmax = the largest number of simultaneous shifts ! . for which there is sufficient workspace. ==== - nsmax = min( ( n-3 ) / 6, 2*lwork / 3 ) - nsmax = nsmax - mod( nsmax, 2 ) + nsmax = min( ( n-3 ) / 6_${ik}$, 2_${ik}$*lwork / 3_${ik}$ ) + nsmax = nsmax - mod( nsmax, 2_${ik}$ ) ! ==== ndfl: an iteration count restarted at deflation. ==== - ndfl = 1 + ndfl = 1_${ik}$ ! ==== itmax = iteration limit ==== - itmax = max( 30, 2*kexsh )*max( 10, ( ihi-ilo+1 ) ) + itmax = max( 30_${ik}$, 2_${ik}$*kexsh )*max( 10_${ik}$, ( ihi-ilo+1 ) ) ! ==== last row and column in the active block ==== kbot = ihi ! ==== main loop ==== @@ -80776,27 +80777,27 @@ module stdlib_linalg_lapack_s ! . in general, more powerful than smaller ones, ! . rapidly increase the window to the maximum possible. ! . then, gradually reduce the window size. ==== - nh = kbot - ktop + 1 + nh = kbot - ktop + 1_${ik}$ nwupbd = min( nh, nwmax ) if( ndfl=nh-1 ) then nw = nh else - kwtop = kbot - nw + 1 + kwtop = kbot - nw + 1_${ik}$ if( abs( h( kwtop, kwtop-1 ) )>abs( h( kwtop-1, kwtop-2 ) ) )nw = nw + & - 1 + 1_${ik}$ end if end if if( ndfl=0 .or. nw>=nwupbd ) then - ndec = ndec + 1 - if( nw-ndec<2 )ndec = 0 + ndec = -1_${ik}$ + else if( ndec>=0_${ik}$ .or. nw>=nwupbd ) then + ndec = ndec + 1_${ik}$ + if( nw-ndec<2_${ik}$ )ndec = 0_${ik}$ nw = nw - ndec end if ! ==== aggressive early deflation: @@ -80809,46 +80810,46 @@ module stdlib_linalg_lapack_s ! . - an at-least-nw-but-more-is-better (nhv-by-nw) ! . vertical work array along the left-hand-edge. ! . ==== - kv = n - nw + 1 - kt = nw + 1 - nho = ( n-nw-1 ) - kt + 1 - kwv = nw + 2 - nve = ( n-nw ) - kwv + 1 + kv = n - nw + 1_${ik}$ + kt = nw + 1_${ik}$ + nho = ( n-nw-1 ) - kt + 1_${ik}$ + kwv = nw + 2_${ik}$ + nve = ( n-nw ) - kwv + 1_${ik}$ ! ==== aggressive early deflation ==== - call stdlib_slaqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & - ls, ld, wr, wi, h( kv, 1 ), ldh,nho, h( kv, kt ), ldh, nve, h( kwv, 1 ), ldh,& + call stdlib${ii}$_slaqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & + ls, ld, wr, wi, h( kv, 1_${ik}$ ), ldh,nho, h( kv, kt ), ldh, nve, h( kwv, 1_${ik}$ ), ldh,& work, lwork ) ! ==== adjust kbot accounting for new deflations. ==== kbot = kbot - ld ! ==== ks points to the shifts. ==== - ks = kbot - ls + 1 + ks = kbot - ls + 1_${ik}$ ! ==== skip an expensive qr sweep if there is a (partly ! . heuristic) reason to expect that many eigenvalues ! . will deflate without it. here, the qr sweep is ! . skipped if many eigenvalues have just been deflated ! . or if the remaining active block is small. - if( ( ld==0 ) .or. ( ( 100*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& + if( ( ld==0_${ik}$ ) .or. ( ( 100_${ik}$*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& ) ) ) then ! ==== ns = nominal number of simultaneous shifts. - ! . this may be lowered (slightly) if stdlib_slaqr2 + ! . this may be lowered (slightly) if stdlib${ii}$_slaqr2 ! . did not provide that many shifts. ==== - ns = min( nsmax, nsr, max( 2, kbot-ktop ) ) - ns = ns - mod( ns, 2 ) + ns = min( nsmax, nsr, max( 2_${ik}$, kbot-ktop ) ) + ns = ns - mod( ns, 2_${ik}$ ) ! ==== if there have been no deflations ! . in a multiple of kexsh iterations, ! . then try exceptional shifts. ! . otherwise use shifts provided by - ! . stdlib_slaqr2 above or from the eigenvalues + ! . stdlib${ii}$_slaqr2 above or from the eigenvalues ! . of a trailing principal submatrix. ==== - if( mod( ndfl, kexsh )==0 ) then - ks = kbot - ns + 1 + if( mod( ndfl, kexsh )==0_${ik}$ ) then + ks = kbot - ns + 1_${ik}$ do i = kbot, max( ks+1, ktop+2 ), -2 ss = abs( h( i, i-1 ) ) + abs( h( i-1, i-2 ) ) aa = wilk1*ss + h( i, i ) bb = ss cc = wilk2*ss dd = aa - call stdlib_slanv2( aa, bb, cc, dd, wr( i-1 ), wi( i-1 ),wr( i ), wi( i & + call stdlib${ii}$_slanv2( aa, bb, cc, dd, wr( i-1 ), wi( i-1 ),wr( i ), wi( i & ), cs, sn ) end do if( ks==ktop ) then @@ -80863,13 +80864,13 @@ module stdlib_linalg_lapack_s ! . get more. (since ns<=nsmax<=(n-3)/6, ! . there is enough space below the subdiagonal ! . to fit an ns-by-ns scratch array.) ==== - if( kbot-ks+1<=ns / 2 ) then - ks = kbot - ns + 1 - kt = n - ns + 1 - call stdlib_slacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1 ), ldh ) + if( kbot-ks+1<=ns / 2_${ik}$ ) then + ks = kbot - ns + 1_${ik}$ + kt = n - ns + 1_${ik}$ + call stdlib${ii}$_slacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1_${ik}$ ), ldh ) - call stdlib_slahqr( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, wr( ks & - ), wi( ks ),1, 1, zdum, 1, inf ) + call stdlib${ii}$_slahqr( .false., .false., ns, 1_${ik}$, ns,h( kt, 1_${ik}$ ), ldh, wr( ks & + ), wi( ks ),1_${ik}$, 1_${ik}$, zdum, 1_${ik}$, inf ) ks = ks + inf ! ==== in case of a rare qr failure use ! . eigenvalues of the trailing 2-by-2 @@ -80879,9 +80880,9 @@ module stdlib_linalg_lapack_s cc = h( kbot, kbot-1 ) bb = h( kbot-1, kbot ) dd = h( kbot, kbot ) - call stdlib_slanv2( aa, bb, cc, dd, wr( kbot-1 ),wi( kbot-1 ), wr( & + call stdlib${ii}$_slanv2( aa, bb, cc, dd, wr( kbot-1 ),wi( kbot-1 ), wr( & kbot ),wi( kbot ), cs, sn ) - ks = kbot - 1 + ks = kbot - 1_${ik}$ end if end if if( kbot-ks+1>ns ) then @@ -80927,7 +80928,7 @@ module stdlib_linalg_lapack_s end if ! ==== if there are only two shifts and both are ! . real, then use only one. ==== - if( kbot-ks+1==2 ) then + if( kbot-ks+1==2_${ik}$ ) then if( wi( kbot )==zero ) then if( abs( wr( kbot )-h( kbot, kbot ) )0 ) then - ndfl = 1 + if( ld>0_${ik}$ ) then + ndfl = 1_${ik}$ else - ndfl = ndfl + 1 + ndfl = ndfl + 1_${ik}$ end if ! ==== end of main loop ==== end do loop_80 @@ -80979,11 +80980,11 @@ module stdlib_linalg_lapack_s 90 continue end if ! ==== return the optimal value of lwork. ==== - work( 1 ) = real( lwkopt,KIND=sp) - end subroutine stdlib_slaqr4 + work( 1_${ik}$ ) = real( lwkopt,KIND=sp) + end subroutine stdlib${ii}$_slaqr4 - recursive subroutine stdlib_slaqz0( wants, wantq, wantz, n, ilo, ihi, a,lda, b, ldb, alphar, & + recursive subroutine stdlib${ii}$_slaqz0( wants, wantq, wantz, n, ilo, ihi, a,lda, b, ldb, alphar, & !! SLAQZ0 computes the eigenvalues of a real matrix pair (H,T), !! where H is an upper Hessenberg matrix and T is upper triangular, !! using the double-shift QZ method. @@ -81035,140 +81036,140 @@ module stdlib_linalg_lapack_s alphai, beta,q, ldq, z, ldz, work, lwork, rec,info ) ! arguments character, intent( in ) :: wants, wantq, wantz - integer(ilp), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,rec - integer(ilp), intent( out ) :: info + integer(${ik}$), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,rec + integer(${ik}$), intent( out ) :: info real(sp), intent( inout ) :: a( lda, * ), b( ldb, * ), q( ldq, * ),z( ldz, * ), alphar(& * ), alphai( * ), beta( * ), work( * ) ! local scalars real(sp) :: smlnum, ulp, eshift, safmin, safmax, c1, s1, temp, swap - integer(ilp) :: istart, istop, iiter, maxit, istart2, k, ld, nshifts, nblock, nw, nmin,& + integer(${ik}$) :: istart, istop, iiter, maxit, istart2, k, ld, nshifts, nblock, nw, nmin,& nibble, n_undeflated, n_deflated, ns, sweep_info, shiftpos, lworkreq, k2, istartm, & istopm, iwants, iwantq, iwantz, norm_info, aed_info, nwr, nbr, nsr, itemp1, itemp2, & rcost, i logical(lk) :: ilschur, ilq, ilz - character :: jbcmpz*3 + character(len=3_${ik}$) :: jbcmpz if( stdlib_lsame( wants, 'E' ) ) then ilschur = .false. - iwants = 1 + iwants = 1_${ik}$ else if( stdlib_lsame( wants, 'S' ) ) then ilschur = .true. - iwants = 2 + iwants = 2_${ik}$ else - iwants = 0 + iwants = 0_${ik}$ end if if( stdlib_lsame( wantq, 'N' ) ) then ilq = .false. - iwantq = 1 + iwantq = 1_${ik}$ else if( stdlib_lsame( wantq, 'V' ) ) then ilq = .true. - iwantq = 2 + iwantq = 2_${ik}$ else if( stdlib_lsame( wantq, 'I' ) ) then ilq = .true. - iwantq = 3 + iwantq = 3_${ik}$ else - iwantq = 0 + iwantq = 0_${ik}$ end if if( stdlib_lsame( wantz, 'N' ) ) then ilz = .false. - iwantz = 1 + iwantz = 1_${ik}$ else if( stdlib_lsame( wantz, 'V' ) ) then ilz = .true. - iwantz = 2 + iwantz = 2_${ik}$ else if( stdlib_lsame( wantz, 'I' ) ) then ilz = .true. - iwantz = 3 + iwantz = 3_${ik}$ else - iwantz = 0 + iwantz = 0_${ik}$ end if ! check argument values - info = 0 - if( iwants==0 ) then - info = -1 - else if( iwantq==0 ) then - info = -2 - else if( iwantz==0 ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( ilo<1 ) then - info = -5 + info = 0_${ik}$ + if( iwants==0_${ik}$ ) then + info = -1_${ik}$ + else if( iwantq==0_${ik}$ ) then + info = -2_${ik}$ + else if( iwantz==0_${ik}$ ) then + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( ilo<1_${ik}$ ) then + info = -5_${ik}$ else if( ihi>n .or. ihi= 2 ) then - call stdlib_shgeqz( wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb,alphar, alphai,& + if( n < nmin .or. rec >= 2_${ik}$ ) then + call stdlib${ii}$_shgeqz( wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb,alphar, alphai,& beta, q, ldq, z, ldz, work,lwork, info ) return end if ! find out required workspace - ! workspace query to stdlib_slaqz3 + ! workspace query to stdlib${ii}$_slaqz3 nw = max( nwr, nmin ) - call stdlib_slaqz3( ilschur, ilq, ilz, n, ilo, ihi, nw, a, lda, b, ldb,q, ldq, z, ldz, & - n_undeflated, n_deflated, alphar,alphai, beta, work, nw, work, nw, work, -1, rec,& + call stdlib${ii}$_slaqz3( ilschur, ilq, ilz, n, ilo, ihi, nw, a, lda, b, ldb,q, ldq, z, ldz, & + n_undeflated, n_deflated, alphar,alphai, beta, work, nw, work, nw, work, -1_${ik}$, rec,& aed_info ) - itemp1 = int( work( 1 ),KIND=ilp) - ! workspace query to stdlib_slaqz4 - call stdlib_slaqz4( ilschur, ilq, ilz, n, ilo, ihi, nsr, nbr, alphar,alphai, beta, a, & - lda, b, ldb, q, ldq, z, ldz, work,nbr, work, nbr, work, -1, sweep_info ) - itemp2 = int( work( 1 ),KIND=ilp) - lworkreq = max( itemp1+2*nw**2, itemp2+2*nbr**2 ) - if ( lwork ==-1 ) then - work( 1 ) = real( lworkreq,KIND=sp) + itemp1 = int( work( 1_${ik}$ ),KIND=${ik}$) + ! workspace query to stdlib${ii}$_slaqz4 + call stdlib${ii}$_slaqz4( ilschur, ilq, ilz, n, ilo, ihi, nsr, nbr, alphar,alphai, beta, a, & + lda, b, ldb, q, ldq, z, ldz, work,nbr, work, nbr, work, -1_${ik}$, sweep_info ) + itemp2 = int( work( 1_${ik}$ ),KIND=${ik}$) + lworkreq = max( itemp1+2*nw**2_${ik}$, itemp2+2*nbr**2_${ik}$ ) + if ( lwork ==-1_${ik}$ ) then + work( 1_${ik}$ ) = real( lworkreq,KIND=sp) return else if ( lwork < lworkreq ) then - info = -19 + info = -19_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'SLAQZ0', info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'SLAQZ0', info ) return end if ! initialize q and z - if( iwantq==3 ) call stdlib_slaset( 'FULL', n, n, zero, one, q, ldq ) - if( iwantz==3 ) call stdlib_slaset( 'FULL', n, n, zero, one, z, ldz ) + if( iwantq==3_${ik}$ ) call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, q, ldq ) + if( iwantz==3_${ik}$ ) call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, z, ldz ) ! get machine constants - safmin = stdlib_slamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) safmax = one/safmin - call stdlib_slabad( safmin, safmax ) - ulp = stdlib_slamch( 'PRECISION' ) + call stdlib${ii}$_slabad( safmin, safmax ) + ulp = stdlib${ii}$_slamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=sp)/ulp ) istart = ilo istop = ihi - maxit = 3*( ihi-ilo+1 ) - ld = 0 + maxit = 3_${ik}$*( ihi-ilo+1 ) + ld = 0_${ik}$ do iiter = 1, maxit if( iiter >= maxit ) then info = istop+1 @@ -81183,13 +81184,13 @@ module stdlib_linalg_lapack_s abs( a( istop-2,istop-2 ) ) ) ) ) then a( istop-1, istop-2 ) = zero istop = istop-2 - ld = 0 + ld = 0_${ik}$ eshift = zero else if ( abs( a( istop, istop-1 ) ) <= max( smlnum,ulp*( abs( a( istop, istop ) )+& abs( a( istop-1,istop-1 ) ) ) ) ) then a( istop, istop-1 ) = zero istop = istop-1 - ld = 0 + ld = 0_${ik}$ eshift = zero end if ! check deflations at the start @@ -81197,13 +81198,13 @@ module stdlib_linalg_lapack_s ) )+abs( a( istart+2,istart+2 ) ) ) ) ) then a( istart+2, istart+1 ) = zero istart = istart+2 - ld = 0 + ld = 0_${ik}$ eshift = zero else if ( abs( a( istart+1, istart ) ) <= max( smlnum,ulp*( abs( a( istart, istart )& )+abs( a( istart+1,istart+1 ) ) ) ) ) then a( istart+1, istart ) = zero istart = istart+1 - ld = 0 + ld = 0_${ik}$ eshift = zero end if if ( istart+1 >= istop ) then @@ -81221,7 +81222,7 @@ module stdlib_linalg_lapack_s end do ! get range to apply rotations to if ( ilschur ) then - istartm = 1 + istartm = 1_${ik}$ istopm = n else istartm = istart2 @@ -81242,41 +81243,41 @@ module stdlib_linalg_lapack_s ! a diagonal element of b is negligable, move it ! to the top and deflate it do k2 = k, istart2+1, -1 - call stdlib_slartg( b( k2-1, k2 ), b( k2-1, k2-1 ), c1, s1,temp ) + call stdlib${ii}$_slartg( b( k2-1, k2 ), b( k2-1, k2-1 ), c1, s1,temp ) b( k2-1, k2 ) = temp b( k2-1, k2-1 ) = zero - call stdlib_srot( k2-2-istartm+1, b( istartm, k2 ), 1,b( istartm, k2-1 ), & - 1, c1, s1 ) - call stdlib_srot( min( k2+1, istop )-istartm+1, a( istartm,k2 ), 1, a( & - istartm, k2-1 ), 1, c1, s1 ) + call stdlib${ii}$_srot( k2-2-istartm+1, b( istartm, k2 ), 1_${ik}$,b( istartm, k2-1 ), & + 1_${ik}$, c1, s1 ) + call stdlib${ii}$_srot( min( k2+1, istop )-istartm+1, a( istartm,k2 ), 1_${ik}$, a( & + istartm, k2-1 ), 1_${ik}$, c1, s1 ) if ( ilz ) then - call stdlib_srot( n, z( 1, k2 ), 1, z( 1, k2-1 ), 1, c1,s1 ) + call stdlib${ii}$_srot( n, z( 1_${ik}$, k2 ), 1_${ik}$, z( 1_${ik}$, k2-1 ), 1_${ik}$, c1,s1 ) end if if( k2= istop ) then istop = istart2-1 - ld = 0 + ld = 0_${ik}$ eshift = zero cycle end if @@ -81307,15 +81308,15 @@ module stdlib_linalg_lapack_s end if end if ! time for aed - call stdlib_slaqz3( ilschur, ilq, ilz, n, istart2, istop, nw, a, lda,b, ldb, q, ldq,& - z, ldz, n_undeflated, n_deflated,alphar, alphai, beta, work, nw, work( nw**2+1 ),& - nw, work( 2*nw**2+1 ), lwork-2*nw**2, rec,aed_info ) - if ( n_deflated > 0 ) then + call stdlib${ii}$_slaqz3( ilschur, ilq, ilz, n, istart2, istop, nw, a, lda,b, ldb, q, ldq,& + z, ldz, n_undeflated, n_deflated,alphar, alphai, beta, work, nw, work( nw**2_${ik}$+1 ),& + nw, work( 2_${ik}$*nw**2_${ik}$+1 ), lwork-2*nw**2_${ik}$, rec,aed_info ) + if ( n_deflated > 0_${ik}$ ) then istop = istop-n_deflated - ld = 0 + ld = 0_${ik}$ eshift = zero end if - if ( 100*n_deflated > nibble*( n_deflated+n_undeflated ) .or.istop-istart2+1 < nmin & + if ( 100_${ik}$*n_deflated > nibble*( n_deflated+n_undeflated ) .or.istop-istart2+1 < nmin & ) then ! aed has uncovered many eigenvalues. skip a qz sweep and run ! aed again. @@ -81343,7 +81344,7 @@ module stdlib_linalg_lapack_s beta( i+2 ) = swap end if end do - if ( mod( ld, 6 ) == 0 ) then + if ( mod( ld, 6_${ik}$ ) == 0_${ik}$ ) then ! exceptional shift. chosen for no particularly good reason. if( ( real( maxit,KIND=sp)*safmin )*abs( a( istop,istop-1 ) ) ilo ) then a( kwtop, kwtop-1 ) = zero end if end if end if ! store window in case of convergence failure - call stdlib_slacpy( 'ALL', jw, jw, a( kwtop, kwtop ), lda, work, jw ) - call stdlib_slacpy( 'ALL', jw, jw, b( kwtop, kwtop ), ldb, work( jw**2+1 ), jw ) + call stdlib${ii}$_slacpy( 'ALL', jw, jw, a( kwtop, kwtop ), lda, work, jw ) + call stdlib${ii}$_slacpy( 'ALL', jw, jw, b( kwtop, kwtop ), ldb, work( jw**2_${ik}$+1 ), jw ) ! transform window to real schur form - call stdlib_slaset( 'FULL', jw, jw, zero, one, qc, ldqc ) - call stdlib_slaset( 'FULL', jw, jw, zero, one, zc, ldzc ) - call stdlib_slaqz0( 'S', 'V', 'V', jw, 1, jw, a( kwtop, kwtop ), lda,b( kwtop, kwtop ),& - ldb, alphar, alphai, beta, qc,ldqc, zc, ldzc, work( 2*jw**2+1 ), lwork-2*jw**2,rec+1, & + call stdlib${ii}$_slaset( 'FULL', jw, jw, zero, one, qc, ldqc ) + call stdlib${ii}$_slaset( 'FULL', jw, jw, zero, one, zc, ldzc ) + call stdlib${ii}$_slaqz0( 'S', 'V', 'V', jw, 1_${ik}$, jw, a( kwtop, kwtop ), lda,b( kwtop, kwtop ),& + ldb, alphar, alphai, beta, qc,ldqc, zc, ldzc, work( 2_${ik}$*jw**2_${ik}$+1 ), lwork-2*jw**2_${ik}$,rec+1, & qz_small_info ) - if( qz_small_info /= 0 ) then + if( qz_small_info /= 0_${ik}$ ) then ! convergence failure, restore the window and exit - nd = 0 + nd = 0_${ik}$ ns = jw-qz_small_info - call stdlib_slacpy( 'ALL', jw, jw, work, jw, a( kwtop, kwtop ), lda ) - call stdlib_slacpy( 'ALL', jw, jw, work( jw**2+1 ), jw, b( kwtop,kwtop ), ldb ) + call stdlib${ii}$_slacpy( 'ALL', jw, jw, work, jw, a( kwtop, kwtop ), lda ) + call stdlib${ii}$_slacpy( 'ALL', jw, jw, work( jw**2_${ik}$+1 ), jw, b( kwtop,kwtop ), ldb ) return end if @@ -81468,11 +81470,11 @@ module stdlib_linalg_lapack_s kwbot = kwtop-1 else kwbot = ihi - k = 1 - k2 = 1 + k = 1_${ik}$ + k2 = 1_${ik}$ do while ( k <= jw ) bulge = .false. - if ( kwbot-kwtop+1 >= 2 ) then + if ( kwbot-kwtop+1 >= 2_${ik}$ ) then bulge = a( kwbot, kwbot-1 ) /= zero end if if ( bulge ) then @@ -81482,7 +81484,7 @@ module stdlib_linalg_lapack_s if( temp == zero )then temp = abs( s ) end if - if ( max( abs( s*qc( 1, kwbot-kwtop ) ), abs( s*qc( 1,kwbot-kwtop+1 ) ) ) <= & + if ( max( abs( s*qc( 1_${ik}$, kwbot-kwtop ) ), abs( s*qc( 1_${ik}$,kwbot-kwtop+1 ) ) ) <= & max( smlnum,ulp*temp ) ) then ! deflatable kwbot = kwbot-2 @@ -81490,7 +81492,7 @@ module stdlib_linalg_lapack_s ! not deflatable, move out of the way ifst = kwbot-kwtop+1 ilst = k2 - call stdlib_stgexc( .true., .true., jw, a( kwtop, kwtop ),lda, b( kwtop, & + call stdlib${ii}$_stgexc( .true., .true., jw, a( kwtop, kwtop ),lda, b( kwtop, & kwtop ), ldb, qc, ldqc,zc, ldzc, ifst, ilst, work, lwork,stgexc_info ) k2 = k2+2 @@ -81502,7 +81504,7 @@ module stdlib_linalg_lapack_s if( temp == zero ) then temp = abs( s ) end if - if ( ( abs( s*qc( 1, kwbot-kwtop+1 ) ) ) <= max( ulp*temp, smlnum ) ) & + if ( ( abs( s*qc( 1_${ik}$, kwbot-kwtop+1 ) ) ) <= max( ulp*temp, smlnum ) ) & then ! deflatable kwbot = kwbot-1 @@ -81510,7 +81512,7 @@ module stdlib_linalg_lapack_s ! not deflatable, move out of the way ifst = kwbot-kwtop+1 ilst = k2 - call stdlib_stgexc( .true., .true., jw, a( kwtop, kwtop ),lda, b( kwtop, & + call stdlib${ii}$_stgexc( .true., .true., jw, a( kwtop, kwtop ),lda, b( kwtop, & kwtop ), ldb, qc, ldqc,zc, ldzc, ifst, ilst, work, lwork,stgexc_info ) k2 = k2+1 @@ -81532,7 +81534,7 @@ module stdlib_linalg_lapack_s end if if ( bulge ) then ! 2x2 eigenvalue block - call stdlib_slag2( a( k, k ), lda, b( k, k ), ldb, safmin,beta( k ), beta( k+1 ),& + call stdlib${ii}$_slag2( a( k, k ), lda, b( k, k ), ldb, safmin,beta( k ), beta( k+1 ),& alphar( k ),alphar( k+1 ), alphai( k ) ) alphai( k+1 ) = -alphai( k ) k = k+2 @@ -81546,16 +81548,16 @@ module stdlib_linalg_lapack_s end do if ( kwtop /= ilo .and. s /= zero ) then ! reflect spike back, this will create optimally packed bulges - a( kwtop:kwbot, kwtop-1 ) = a( kwtop, kwtop-1 )*qc( 1,1:jw-nd ) + a( kwtop:kwbot, kwtop-1 ) = a( kwtop, kwtop-1 )*qc( 1_${ik}$,1_${ik}$:jw-nd ) do k = kwbot-1, kwtop, -1 - call stdlib_slartg( a( k, kwtop-1 ), a( k+1, kwtop-1 ), c1, s1,temp ) + call stdlib${ii}$_slartg( a( k, kwtop-1 ), a( k+1, kwtop-1 ), c1, s1,temp ) a( k, kwtop-1 ) = temp a( k+1, kwtop-1 ) = zero k2 = max( kwtop, k-1 ) - call stdlib_srot( ihi-k2+1, a( k, k2 ), lda, a( k+1, k2 ), lda, c1,s1 ) - call stdlib_srot( ihi-( k-1 )+1, b( k, k-1 ), ldb, b( k+1, k-1 ),ldb, c1, s1 ) + call stdlib${ii}$_srot( ihi-k2+1, a( k, k2 ), lda, a( k+1, k2 ), lda, c1,s1 ) + call stdlib${ii}$_srot( ihi-( k-1 )+1_${ik}$, b( k, k-1 ), ldb, b( k+1, k-1 ),ldb, c1, s1 ) - call stdlib_srot( jw, qc( 1, k-kwtop+1 ), 1, qc( 1, k+1-kwtop+1 ),1, c1, s1 ) + call stdlib${ii}$_srot( jw, qc( 1_${ik}$, k-kwtop+1 ), 1_${ik}$, qc( 1_${ik}$, k+1-kwtop+1 ),1_${ik}$, c1, s1 ) end do ! chase bulges down @@ -81566,7 +81568,7 @@ module stdlib_linalg_lapack_s if ( ( k >= kwtop+1 ) .and. a( k+1, k-1 ) /= zero ) then ! move double pole block down and remove it do k2 = k-1, kwbot-2 - call stdlib_slaqz2( .true., .true., k2, kwtop, kwtop+jw-1,kwbot, a, lda, b,& + call stdlib${ii}$_slaqz2( .true., .true., k2, kwtop, kwtop+jw-1,kwbot, a, lda, b,& ldb, jw, kwtop, qc,ldqc, jw, kwtop, zc, ldzc ) end do k = k-2 @@ -81574,35 +81576,35 @@ module stdlib_linalg_lapack_s ! k points to single shift do k2 = k, kwbot-2 ! move shift down - call stdlib_slartg( b( k2+1, k2+1 ), b( k2+1, k2 ), c1, s1,temp ) + call stdlib${ii}$_slartg( b( k2+1, k2+1 ), b( k2+1, k2 ), c1, s1,temp ) b( k2+1, k2+1 ) = temp b( k2+1, k2 ) = zero - call stdlib_srot( k2+2-istartm+1, a( istartm, k2+1 ), 1,a( istartm, k2 ), & - 1, c1, s1 ) - call stdlib_srot( k2-istartm+1, b( istartm, k2+1 ), 1,b( istartm, k2 ), 1, & + call stdlib${ii}$_srot( k2+2-istartm+1, a( istartm, k2+1 ), 1_${ik}$,a( istartm, k2 ), & + 1_${ik}$, c1, s1 ) + call stdlib${ii}$_srot( k2-istartm+1, b( istartm, k2+1 ), 1_${ik}$,b( istartm, k2 ), 1_${ik}$, & c1, s1 ) - call stdlib_srot( jw, zc( 1, k2+1-kwtop+1 ), 1, zc( 1,k2-kwtop+1 ), 1, c1, & + call stdlib${ii}$_srot( jw, zc( 1_${ik}$, k2+1-kwtop+1 ), 1_${ik}$, zc( 1_${ik}$,k2-kwtop+1 ), 1_${ik}$, c1, & s1 ) - call stdlib_slartg( a( k2+1, k2 ), a( k2+2, k2 ), c1, s1,temp ) + call stdlib${ii}$_slartg( a( k2+1, k2 ), a( k2+2, k2 ), c1, s1,temp ) a( k2+1, k2 ) = temp a( k2+2, k2 ) = zero - call stdlib_srot( istopm-k2, a( k2+1, k2+1 ), lda, a( k2+2,k2+1 ), lda, c1,& + call stdlib${ii}$_srot( istopm-k2, a( k2+1, k2+1 ), lda, a( k2+2,k2+1 ), lda, c1,& s1 ) - call stdlib_srot( istopm-k2, b( k2+1, k2+1 ), ldb, b( k2+2,k2+1 ), ldb, c1,& + call stdlib${ii}$_srot( istopm-k2, b( k2+1, k2+1 ), ldb, b( k2+2,k2+1 ), ldb, c1,& s1 ) - call stdlib_srot( jw, qc( 1, k2+1-kwtop+1 ), 1, qc( 1,k2+2-kwtop+1 ), 1, & + call stdlib${ii}$_srot( jw, qc( 1_${ik}$, k2+1-kwtop+1 ), 1_${ik}$, qc( 1_${ik}$,k2+2-kwtop+1 ), 1_${ik}$, & c1, s1 ) end do ! remove the shift - call stdlib_slartg( b( kwbot, kwbot ), b( kwbot, kwbot-1 ), c1,s1, temp ) + call stdlib${ii}$_slartg( b( kwbot, kwbot ), b( kwbot, kwbot-1 ), c1,s1, temp ) b( kwbot, kwbot ) = temp b( kwbot, kwbot-1 ) = zero - call stdlib_srot( kwbot-istartm, b( istartm, kwbot ), 1,b( istartm, kwbot-1 ),& - 1, c1, s1 ) - call stdlib_srot( kwbot-istartm+1, a( istartm, kwbot ), 1,a( istartm, kwbot-1 & - ), 1, c1, s1 ) - call stdlib_srot( jw, zc( 1, kwbot-kwtop+1 ), 1, zc( 1,kwbot-1-kwtop+1 ), 1, & + call stdlib${ii}$_srot( kwbot-istartm, b( istartm, kwbot ), 1_${ik}$,b( istartm, kwbot-1 ),& + 1_${ik}$, c1, s1 ) + call stdlib${ii}$_srot( kwbot-istartm+1, a( istartm, kwbot ), 1_${ik}$,a( istartm, kwbot-1 & + ), 1_${ik}$, c1, s1 ) + call stdlib${ii}$_srot( jw, zc( 1_${ik}$, kwbot-kwtop+1 ), 1_${ik}$, zc( 1_${ik}$,kwbot-1-kwtop+1 ), 1_${ik}$, & c1, s1 ) k = k-1 end if @@ -81610,44 +81612,44 @@ module stdlib_linalg_lapack_s end if ! apply qc and zc to rest of the matrix if ( ilschur ) then - istartm = 1 + istartm = 1_${ik}$ istopm = n else istartm = ilo istopm = ihi end if - if ( istopm-ihi > 0 ) then - call stdlib_sgemm( 'T', 'N', jw, istopm-ihi, jw, one, qc, ldqc,a( kwtop, ihi+1 ), & + if ( istopm-ihi > 0_${ik}$ ) then + call stdlib${ii}$_sgemm( 'T', 'N', jw, istopm-ihi, jw, one, qc, ldqc,a( kwtop, ihi+1 ), & lda, zero, work, jw ) - call stdlib_slacpy( 'ALL', jw, istopm-ihi, work, jw, a( kwtop,ihi+1 ), lda ) - call stdlib_sgemm( 'T', 'N', jw, istopm-ihi, jw, one, qc, ldqc,b( kwtop, ihi+1 ), & + call stdlib${ii}$_slacpy( 'ALL', jw, istopm-ihi, work, jw, a( kwtop,ihi+1 ), lda ) + call stdlib${ii}$_sgemm( 'T', 'N', jw, istopm-ihi, jw, one, qc, ldqc,b( kwtop, ihi+1 ), & ldb, zero, work, jw ) - call stdlib_slacpy( 'ALL', jw, istopm-ihi, work, jw, b( kwtop,ihi+1 ), ldb ) + call stdlib${ii}$_slacpy( 'ALL', jw, istopm-ihi, work, jw, b( kwtop,ihi+1 ), ldb ) end if if ( ilq ) then - call stdlib_sgemm( 'N', 'N', n, jw, jw, one, q( 1, kwtop ), ldq, qc,ldqc, zero, & + call stdlib${ii}$_sgemm( 'N', 'N', n, jw, jw, one, q( 1_${ik}$, kwtop ), ldq, qc,ldqc, zero, & work, n ) - call stdlib_slacpy( 'ALL', n, jw, work, n, q( 1, kwtop ), ldq ) + call stdlib${ii}$_slacpy( 'ALL', n, jw, work, n, q( 1_${ik}$, kwtop ), ldq ) end if - if ( kwtop-1-istartm+1 > 0 ) then - call stdlib_sgemm( 'N', 'N', kwtop-istartm, jw, jw, one, a( istartm,kwtop ), lda, & + if ( kwtop-1-istartm+1 > 0_${ik}$ ) then + call stdlib${ii}$_sgemm( 'N', 'N', kwtop-istartm, jw, jw, one, a( istartm,kwtop ), lda, & zc, ldzc, zero, work,kwtop-istartm ) - call stdlib_slacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,a( istartm, kwtop & + call stdlib${ii}$_slacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,a( istartm, kwtop & ), lda ) - call stdlib_sgemm( 'N', 'N', kwtop-istartm, jw, jw, one, b( istartm,kwtop ), ldb, & + call stdlib${ii}$_sgemm( 'N', 'N', kwtop-istartm, jw, jw, one, b( istartm,kwtop ), ldb, & zc, ldzc, zero, work,kwtop-istartm ) - call stdlib_slacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,b( istartm, kwtop & + call stdlib${ii}$_slacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,b( istartm, kwtop & ), ldb ) end if if ( ilz ) then - call stdlib_sgemm( 'N', 'N', n, jw, jw, one, z( 1, kwtop ), ldz, zc,ldzc, zero, & + call stdlib${ii}$_sgemm( 'N', 'N', n, jw, jw, one, z( 1_${ik}$, kwtop ), ldz, zc,ldzc, zero, & work, n ) - call stdlib_slacpy( 'ALL', n, jw, work, n, z( 1, kwtop ), ldz ) + call stdlib${ii}$_slacpy( 'ALL', n, jw, work, n, z( 1_${ik}$, kwtop ), ldz ) end if - end subroutine stdlib_slaqz3 + end subroutine stdlib${ii}$_slaqz3 - pure subroutine stdlib_slarre( range, n, vl, vu, il, iu, d, e, e2,rtol1, rtol2, spltol, & + pure subroutine stdlib${ii}$_slarre( range, n, vl, vu, il, iu, d, e, e2,rtol1, rtol2, spltol, & !! To find the desired eigenvalues of a given real symmetric !! tridiagonal matrix T, SLARRE: sets any "small" off-diagonal !! elements to zero, and for each unreduced block T_i, it finds @@ -81667,13 +81669,13 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: range - integer(ilp), intent(in) :: il, iu, n - integer(ilp), intent(out) :: info, m, nsplit + integer(${ik}$), intent(in) :: il, iu, n + integer(${ik}$), intent(out) :: info, m, nsplit real(sp), intent(out) :: pivmin real(sp), intent(in) :: rtol1, rtol2, spltol real(sp), intent(inout) :: vl, vu ! Array Arguments - integer(ilp), intent(out) :: iblock(*), isplit(*), iwork(*), indexw(*) + integer(${ik}$), intent(out) :: iblock(*), isplit(*), iwork(*), indexw(*) real(sp), intent(inout) :: d(*), e(*), e2(*) real(sp), intent(out) :: gers(*), w(*), werr(*), wgap(*), work(*) ! ===================================================================== @@ -81684,26 +81686,26 @@ module stdlib_linalg_lapack_s real(sp), parameter :: fac = half real(sp), parameter :: maxgrowth = 64.0_sp real(sp), parameter :: fudge = 2.0_sp - integer(ilp), parameter :: maxtry = 6 - integer(ilp), parameter :: allrng = 1 - integer(ilp), parameter :: indrng = 2 - integer(ilp), parameter :: valrng = 3 + integer(${ik}$), parameter :: maxtry = 6_${ik}$ + integer(${ik}$), parameter :: allrng = 1_${ik}$ + integer(${ik}$), parameter :: indrng = 2_${ik}$ + integer(${ik}$), parameter :: valrng = 3_${ik}$ ! Local Scalars logical(lk) :: forceb, norep, usedqd - integer(ilp) :: cnt, cnt1, cnt2, i, ibegin, idum, iend, iinfo, in, indl, indu, irange, & + integer(${ik}$) :: cnt, cnt1, cnt2, i, ibegin, idum, iend, iinfo, in, indl, indu, irange, & j, jblk, mb, mm, wbegin, wend real(sp) :: avgap, bsrtol, clwdth, dmax, dpivot, eabs, emax, eold, eps, gl, gu, isleft,& isrght, rtl, rtol, s1, s2, safmin, sgndef, sigma, spdiam, tau, tmp, tmp1 ! Local Arrays - integer(ilp) :: iseed(4) + integer(${ik}$) :: iseed(4_${ik}$) ! 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 ! decode range @@ -81714,10 +81716,10 @@ module stdlib_linalg_lapack_s else if( stdlib_lsame( range, 'I' ) ) then irange = indrng end if - m = 0 + m = 0_${ik}$ ! get machine constants - safmin = stdlib_slamch( 'S' ) - eps = stdlib_slamch( 'P' ) + safmin = stdlib${ii}$_slamch( 'S' ) + eps = stdlib${ii}$_slamch( 'P' ) ! set parameters rtl = hndrd*eps ! if one were ever to ask for less initial precision in bsrtol, @@ -81726,28 +81728,28 @@ module stdlib_linalg_lapack_s ! (eigenvalues in the middle need not as much accuracy) bsrtol = sqrt(eps)*(0.5e-3_sp) ! 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 - wgap(1) = zero - iblock( 1 ) = 1 - indexw( 1 ) = 1 - gers(1) = d( 1 ) - gers(2) = d( 1 ) + werr(1_${ik}$) = zero + wgap(1_${ik}$) = zero + iblock( 1_${ik}$ ) = 1_${ik}$ + indexw( 1_${ik}$ ) = 1_${ik}$ + gers(1_${ik}$) = d( 1_${ik}$ ) + gers(2_${ik}$) = d( 1_${ik}$ ) endif ! store the shift for the initial rrr, which is zero in this case - e(1) = zero + e(1_${ik}$) = zero return end if ! general case: tridiagonal matrix of order > 1 ! init werr, wgap. compute gerschgorin intervals and spectral diameter. ! compute maximum off-diagonal entry and pivmin. - gl = d(1) - gu = d(1) + gl = d(1_${ik}$) + gu = d(1_${ik}$) eold = zero emax = zero e(n) = zero @@ -81759,19 +81761,19 @@ module stdlib_linalg_lapack_s emax = eabs end if tmp1 = eabs + eold - gers( 2*i-1) = d(i) - tmp1 - gl = min( gl, gers( 2*i - 1)) - gers( 2*i ) = d(i) + tmp1 - gu = max( gu, gers(2*i) ) + gers( 2_${ik}$*i-1) = d(i) - tmp1 + gl = min( gl, gers( 2_${ik}$*i - 1_${ik}$)) + gers( 2_${ik}$*i ) = d(i) + tmp1 + gu = max( gu, gers(2_${ik}$*i) ) eold = eabs end do ! the minimum pivot allowed in the sturm sequence for t - pivmin = safmin * max( one, emax**2 ) + pivmin = safmin * max( one, emax**2_${ik}$ ) ! compute spectral diameter. the gerschgorin bounds give an ! estimate that is wrong by at most a factor of sqrt(2) spdiam = gu - gl ! compute splitting points - call stdlib_slarra( n, d, e, e2, spltol, spdiam,nsplit, isplit, iinfo ) + call stdlib${ii}$_slarra( n, d, e, e2, spltol, spdiam,nsplit, isplit, iinfo ) ! can force use of bisection instead of faster dqds. ! option left in the code for future multisection work. forceb = .false. @@ -81783,50 +81785,50 @@ module stdlib_linalg_lapack_s vl = gl vu = gu else - ! we call stdlib_slarrd to find crude approximations to the eigenvalues + ! we call stdlib${ii}$_slarrd to find crude approximations to the eigenvalues ! in the desired range. in case irange = indrng, we also obtain the ! interval (vl,vu] that contains all the wanted eigenvalues. ! an interval [left,right] has converged if ! right-leftvl ).and.( d( & ibegin )<=vu ) ).or. ( (irange==indrng).and.(iblock(wbegin)==jblk))) 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 wgap(m) = zero iblock( m ) = jblk - indexw( m ) = 1 - wbegin = wbegin + 1 + indexw( m ) = 1_${ik}$ + wbegin = wbegin + 1_${ik}$ endif ! e( iend ) holds the shift for the initial rrr e( iend ) = zero - ibegin = iend + 1 + ibegin = iend + 1_${ik}$ cycle loop_170 end if ! blocks of size larger than 1x1 @@ -81836,13 +81838,13 @@ module stdlib_linalg_lapack_s gl = d(ibegin) gu = d(ibegin) do i = ibegin , 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 if(.not. ((irange==allrng).and.(.not.forceb)) ) then ! count the number of eigenvalues in the current block. - mb = 0 + mb = 0_${ik}$ do i = wbegin,mm if( iblock(i)==jblk ) then mb = mb+1 @@ -81851,16 +81853,16 @@ module stdlib_linalg_lapack_s endif end do 21 continue - if( mb==0) then + if( mb==0_${ik}$) then ! no eigenvalue in the current block lies in the desired range ! e( iend ) holds the shift for the initial rrr e( iend ) = zero - ibegin = iend + 1 + ibegin = iend + 1_${ik}$ cycle loop_170 else ! decide whether dqds or bisection is more efficient usedqd = ( (mb > fac*in) .and. (.not.forceb) ) - wend = wbegin + mb - 1 + wend = wbegin + mb - 1_${ik}$ ! calculate gaps for the current block ! in later stages, when representations for individual ! eigenvalues are different, we use sigma = e( iend ). @@ -81877,17 +81879,17 @@ module stdlib_linalg_lapack_s if(( (irange==allrng) .and. (.not. forceb) ).or.usedqd) then ! case of dqds ! find approximations to the extremal eigenvalues of the block - call stdlib_slarrk( in, 1, gl, gu, d(ibegin),e2(ibegin), pivmin, rtl, tmp, tmp1, & + call stdlib${ii}$_slarrk( in, 1_${ik}$, gl, gu, d(ibegin),e2(ibegin), pivmin, rtl, tmp, tmp1, & iinfo ) - if( iinfo/=0 ) then - info = -1 + if( iinfo/=0_${ik}$ ) then + info = -1_${ik}$ return endif isleft = max(gl, tmp - tmp1- hndrd * eps* abs(tmp - tmp1)) - call stdlib_slarrk( in, in, gl, gu, d(ibegin),e2(ibegin), pivmin, rtl, tmp, tmp1,& + call stdlib${ii}$_slarrk( in, in, gl, gu, d(ibegin),e2(ibegin), pivmin, rtl, tmp, tmp1,& iinfo ) - if( iinfo/=0 ) then - info = -1 + if( iinfo/=0_${ik}$ ) then + info = -1_${ik}$ return endif isrght = min(gu, tmp + tmp1+ hndrd * eps * abs(tmp + tmp1)) @@ -81912,16 +81914,16 @@ module stdlib_linalg_lapack_s ! if all the eigenvalues have to be computed, we use dqd usedqd = .true. ! indl is the local index of the first eigenvalue to compute - indl = 1 + indl = 1_${ik}$ indu = in ! mb = number of eigenvalues to compute mb = in - wend = wbegin + mb - 1 + wend = wbegin + mb - 1_${ik}$ ! define 1/4 and 3/4 points of the spectrum s1 = isleft + fourth * spdiam s2 = isrght - fourth * spdiam else - ! stdlib_slarrd has computed iblock and indexw for each eigenvalue + ! stdlib${ii}$_slarrd has computed iblock and indexw for each eigenvalue ! approximation. ! choose sigma if( usedqd ) then @@ -81934,11 +81936,11 @@ module stdlib_linalg_lapack_s endif endif ! compute the negcount at the 1/4 and 3/4 points - if(mb>1) then - call stdlib_slarrc( 'T', in, s1, s2, d(ibegin),e(ibegin), pivmin, cnt, cnt1, & + if(mb>1_${ik}$) then + call stdlib${ii}$_slarrc( 'T', in, s1, s2, d(ibegin),e(ibegin), pivmin, cnt, cnt1, & cnt2, iinfo) endif - if(mb==1) then + if(mb==1_${ik}$) then sigma = gl sgndef = one elseif( cnt1 - indl >= indu - cnt2 ) then @@ -81979,7 +81981,7 @@ module stdlib_linalg_lapack_s tau = spdiam*eps*n + two*pivmin tau = max( tau,two*eps*abs(sigma) ) else - if(mb>1) then + if(mb>1_${ik}$) then clwdth = w(wend) + werr(wend) - w(wbegin) - werr(wbegin) avgap = abs(clwdth / real(wend-wbegin,KIND=sp)) if( sgndef==one ) then @@ -81998,17 +82000,17 @@ module stdlib_linalg_lapack_s ! store d in work(1:in), l in work(in+1:2*in), and reciprocals of ! pivots in work(2*in+1:3*in) dpivot = d( ibegin ) - sigma - work( 1 ) = dpivot - dmax = abs( work(1) ) + work( 1_${ik}$ ) = dpivot + dmax = abs( work(1_${ik}$) ) j = ibegin do i = 1, in - 1 - work( 2*in+i ) = one / work( i ) - tmp = e( j )*work( 2*in+i ) + work( 2_${ik}$*in+i ) = one / work( i ) + tmp = e( j )*work( 2_${ik}$*in+i ) work( in+i ) = tmp dpivot = ( d( j+1 )-sigma ) - tmp*e( j ) work( i+1 ) = dpivot dmax = max( dmax, abs(dpivot) ) - j = j + 1 + j = j + 1_${ik}$ end do ! check for element growth if( dmax > maxgrowth*spdiam ) then @@ -82046,7 +82048,7 @@ module stdlib_linalg_lapack_s end do loop_80 ! if the program reaches this point, no base representation could be ! found in maxtry iterations. - info = 2 + info = 2_${ik}$ return 83 continue ! at this point, we have found an initial base representation @@ -82054,16 +82056,16 @@ module stdlib_linalg_lapack_s ! store the shift. e( iend ) = sigma ! store d and l. - call stdlib_scopy( in, work, 1, d( ibegin ), 1 ) - call stdlib_scopy( in-1, work( in+1 ), 1, e( ibegin ), 1 ) - if(mb>1 ) then + call stdlib${ii}$_scopy( in, work, 1_${ik}$, d( ibegin ), 1_${ik}$ ) + call stdlib${ii}$_scopy( in-1, work( in+1 ), 1_${ik}$, e( ibegin ), 1_${ik}$ ) + if(mb>1_${ik}$ ) then ! perturb each entry of the base representation by a small ! (but random) relative amount to overcome difficulties with ! glued matrices. do i = 1, 4 - iseed( i ) = 1 + iseed( i ) = 1_${ik}$ end do - call stdlib_slarnv(2, iseed, 2*in-1, work(1)) + call stdlib${ii}$_slarnv(2_${ik}$, iseed, 2_${ik}$*in-1, work(1_${ik}$)) do i = 1,in-1 d(ibegin+i-1) = d(ibegin+i-1)*(one+eps*pert*work(i)) e(ibegin+i-1) = e(ibegin+i-1)*(one+eps*pert*work(in+i)) @@ -82071,38 +82073,38 @@ module stdlib_linalg_lapack_s d(iend) = d(iend)*(one+eps*four*work(in)) endif ! don't update the gerschgorin intervals because keeping track - ! of the updates would be too much work in stdlib_slarrv. + ! of the updates would be too much work in stdlib${ii}$_slarrv. ! we update w instead and use it to locate the proper gerschgorin ! intervals. ! compute the required eigenvalues of l d l' by bisection or dqds if ( .not.usedqd ) then - ! if stdlib_slarrd has been used, shift the eigenvalue approximations + ! if stdlib${ii}$_slarrd has been used, shift the eigenvalue approximations ! according to their representation. this is necessary for - ! a uniform stdlib_slarrv since dqds computes eigenvalues of the - ! shifted representation. in stdlib_slarrv, w will always hold the + ! a uniform stdlib${ii}$_slarrv since dqds computes eigenvalues of the + ! shifted representation. in stdlib${ii}$_slarrv, w will always hold the ! unshifted eigenvalue approximation. do j=wbegin,wend w(j) = w(j) - sigma werr(j) = werr(j) + abs(w(j)) * eps end do - ! call stdlib_slarrb to reduce eigenvalue error of the approximations - ! from stdlib_slarrd + ! call stdlib${ii}$_slarrb to reduce eigenvalue error of the approximations + ! from stdlib${ii}$_slarrd do i = ibegin, iend-1 - work( i ) = d( i ) * e( i )**2 + work( i ) = d( i ) * e( i )**2_${ik}$ end do ! use bisection to find ev from indl to indu - call stdlib_slarrb(in, d(ibegin), work(ibegin),indl, indu, rtol1, rtol2, indl-1,& - w(wbegin), wgap(wbegin), werr(wbegin),work( 2*n+1 ), iwork, pivmin, spdiam,in, & + call stdlib${ii}$_slarrb(in, d(ibegin), work(ibegin),indl, indu, rtol1, rtol2, indl-1,& + w(wbegin), wgap(wbegin), werr(wbegin),work( 2_${ik}$*n+1 ), iwork, pivmin, spdiam,in, & iinfo ) - if( iinfo /= 0 ) then - info = -4 + if( iinfo /= 0_${ik}$ ) then + info = -4_${ik}$ return end if - ! stdlib_slarrb computes all gaps correctly except for the last one + ! stdlib${ii}$_slarrb computes all gaps correctly except for the last one ! record distance to vu/gu wgap( wend ) = max( zero,( vu-sigma ) - ( w( wend ) + werr( wend ) ) ) do i = indl, indu - m = m + 1 + m = m + 1_${ik}$ iblock(m) = jblk indexw(m) = i end do @@ -82114,52 +82116,52 @@ module stdlib_linalg_lapack_s ! might be lost when the shift of the rrr is subtracted to obtain ! the eigenvalues of t. however, t is not guaranteed to define its ! eigenvalues to high relative accuracy anyway. - ! set rtol to the order of the tolerance used in stdlib_slasq2 + ! set rtol to the order of the tolerance used in stdlib${ii}$_slasq2 ! this is an estimated error, the worst case bound is 4*n*eps ! which is usually too large and requires unnecessary work to be ! done by bisection when computing the eigenvectors rtol = log(real(in,KIND=sp)) * four * eps j = ibegin do i = 1, in - 1 - work( 2*i-1 ) = abs( d( j ) ) - work( 2*i ) = e( j )*e( j )*work( 2*i-1 ) - j = j + 1 - end do - work( 2*in-1 ) = abs( d( iend ) ) - work( 2*in ) = zero - call stdlib_slasq2( in, work, iinfo ) - if( iinfo /= 0 ) then + work( 2_${ik}$*i-1 ) = abs( d( j ) ) + work( 2_${ik}$*i ) = e( j )*e( j )*work( 2_${ik}$*i-1 ) + j = j + 1_${ik}$ + end do + work( 2_${ik}$*in-1 ) = abs( d( iend ) ) + work( 2_${ik}$*in ) = zero + call stdlib${ii}$_slasq2( in, work, iinfo ) + if( iinfo /= 0_${ik}$ ) then ! if iinfo = -5 then an index is part of a tight cluster ! and should be changed. the index is in iwork(1) and the ! gap is in work(n+1) - info = -5 + info = -5_${ik}$ return else ! test that all eigenvalues are positive as expected do i = 1, in if( work( i )zero ) then do i = indl, indu - m = m + 1 + m = m + 1_${ik}$ w( m ) = work( in-i+1 ) iblock( m ) = jblk indexw( m ) = i end do else do i = indl, indu - m = m + 1 + m = m + 1_${ik}$ w( m ) = -work( i ) iblock( m ) = jblk indexw( m ) = i end do end if do i = m - mb + 1, m - ! the value of rtol below should be the tolerance in stdlib_slasq2 + ! the value of rtol below should be the tolerance in stdlib${ii}$_slasq2 werr( i ) = rtol * abs( w(i) ) end do do i = m - mb + 1, m - 1 @@ -82169,14 +82171,14 @@ module stdlib_linalg_lapack_s wgap( m ) = max( zero,( vu-sigma ) - ( w( m ) + werr( m ) ) ) end if ! proceed with next block - ibegin = iend + 1 - wbegin = wend + 1 + ibegin = iend + 1_${ik}$ + wbegin = wend + 1_${ik}$ end do loop_170 return - end subroutine stdlib_slarre + end subroutine stdlib${ii}$_slarre - pure subroutine stdlib_slasd0( n, sqre, d, e, u, ldu, vt, ldvt, smlsiz, iwork,work, info ) + pure subroutine stdlib${ii}$_slasd0( n, sqre, d, e, u, ldu, vt, ldvt, smlsiz, iwork,work, info ) !! Using a divide and conquer approach, SLASD0: computes the singular !! value decomposition (SVD) of a real upper bidiagonal N-by-M !! matrix B with diagonal D and offdiagonal E, where M = N + SQRE. @@ -82189,88 +82191,88 @@ 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) :: ldu, ldvt, n, smlsiz, sqre + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldu, ldvt, n, smlsiz, sqre ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(sp), intent(inout) :: d(*), e(*) real(sp), intent(out) :: u(ldu,*), vt(ldvt,*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, i1, ic, idxq, idxqc, im1, inode, itemp, iwk, j, lf, ll, lvl, m, ncc,& + integer(${ik}$) :: i, i1, ic, idxq, idxqc, im1, inode, itemp, iwk, j, lf, ll, lvl, m, ncc,& nd, ndb1, ndiml, ndimr, nl, nlf, nlp1, nlvl, nr, nrf, nrp1, sqrei real(sp) :: alpha, beta ! Executable Statements ! test the input parameters. - info = 0 - if( n<0 ) then - info = -1 - else if( ( sqre<0 ) .or. ( sqre>1 ) ) then - info = -2 + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -1_${ik}$ + else if( ( sqre<0_${ik}$ ) .or. ( sqre>1_${ik}$ ) ) then + info = -2_${ik}$ end if m = n + sqre if( ldu1 ) ) then - info = -1 - else if( smlsiz<3 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ( sqre<0 ) .or. ( sqre>1 ) ) then - info = -4 + info = 0_${ik}$ + if( ( icompq<0_${ik}$ ) .or. ( icompq>1_${ik}$ ) ) then + info = -1_${ik}$ + else if( smlsiz<3_${ik}$ ) then + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( ( sqre<0_${ik}$ ) .or. ( sqre>1_${ik}$ ) ) then + info = -4_${ik}$ else if( ldu<( n+sqre ) ) then - info = -8 + info = -8_${ik}$ else if( ldgcol1 ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ncvt<0 ) then - info = -4 - else if( nru<0 ) then - info = -5 - else if( ncc<0 ) then - info = -6 - else if( ( ncvt==0 .and. ldvt<1 ) .or.( ncvt>0 .and. ldvt0 .and. ldc1_${ik}$ ) ) then + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( ncvt<0_${ik}$ ) then + info = -4_${ik}$ + else if( nru<0_${ik}$ ) then + info = -5_${ik}$ + else if( ncc<0_${ik}$ ) then + info = -6_${ik}$ + else if( ( ncvt==0_${ik}$ .and. ldvt<1_${ik}$ ) .or.( ncvt>0_${ik}$ .and. ldvt0_${ik}$ .and. ldc0 ) .or. ( nru>0 ) .or. ( ncc>0 ) - np1 = n + 1 + rotate = ( ncvt>0_${ik}$ ) .or. ( nru>0_${ik}$ ) .or. ( ncc>0_${ik}$ ) + np1 = n + 1_${ik}$ sqre1 = sqre ! if matrix non-square upper bidiagonal, rotate to be lower ! bidiagonal. the rotations are on the right. - if( ( iuplo==1 ) .and. ( sqre1==1 ) ) then + if( ( iuplo==1_${ik}$ ) .and. ( sqre1==1_${ik}$ ) ) then do i = 1, n - 1 - call stdlib_slartg( d( i ), e( i ), cs, sn, r ) + call stdlib${ii}$_slartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) @@ -82596,24 +82598,24 @@ module stdlib_linalg_lapack_s work( n+i ) = sn end if end do - call stdlib_slartg( d( n ), e( n ), cs, sn, r ) + call stdlib${ii}$_slartg( d( n ), e( n ), cs, sn, r ) d( n ) = r e( n ) = zero if( rotate ) then work( n ) = cs work( n+n ) = sn end if - iuplo = 2 - sqre1 = 0 + iuplo = 2_${ik}$ + sqre1 = 0_${ik}$ ! update singular vectors if desired. - if( ncvt>0 )call stdlib_slasr( 'L', 'V', 'F', np1, ncvt, work( 1 ),work( np1 ), vt, & + if( ncvt>0_${ik}$ )call stdlib${ii}$_slasr( 'L', 'V', 'F', np1, ncvt, work( 1_${ik}$ ),work( np1 ), vt, & ldvt ) end if ! if matrix lower bidiagonal, rotate to be upper bidiagonal ! by applying givens rotations on the left. - if( iuplo==2 ) then + if( iuplo==2_${ik}$ ) then do i = 1, n - 1 - call stdlib_slartg( d( i ), e( i ), cs, sn, r ) + call stdlib${ii}$_slartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) @@ -82624,8 +82626,8 @@ module stdlib_linalg_lapack_s end do ! if matrix (n+1)-by-n lower bidiagonal, one additional ! rotation is needed. - if( sqre1==1 ) then - call stdlib_slartg( d( n ), e( n ), cs, sn, r ) + if( sqre1==1_${ik}$ ) then + call stdlib${ii}$_slartg( d( n ), e( n ), cs, sn, r ) d( n ) = r if( rotate ) then work( n ) = cs @@ -82633,28 +82635,28 @@ module stdlib_linalg_lapack_s end if end if ! update singular vectors if desired. - if( nru>0 ) then - if( sqre1==0 ) then - call stdlib_slasr( 'R', 'V', 'F', nru, n, work( 1 ),work( np1 ), u, ldu ) + if( nru>0_${ik}$ ) then + if( sqre1==0_${ik}$ ) then + call stdlib${ii}$_slasr( 'R', 'V', 'F', nru, n, work( 1_${ik}$ ),work( np1 ), u, ldu ) else - call stdlib_slasr( 'R', 'V', 'F', nru, np1, work( 1 ),work( np1 ), u, ldu ) + call stdlib${ii}$_slasr( 'R', 'V', 'F', nru, np1, work( 1_${ik}$ ),work( np1 ), u, ldu ) end if end if - if( ncc>0 ) then - if( sqre1==0 ) then - call stdlib_slasr( 'L', 'V', 'F', n, ncc, work( 1 ),work( np1 ), c, ldc ) + if( ncc>0_${ik}$ ) then + if( sqre1==0_${ik}$ ) then + call stdlib${ii}$_slasr( 'L', 'V', 'F', n, ncc, work( 1_${ik}$ ),work( np1 ), c, ldc ) else - call stdlib_slasr( 'L', 'V', 'F', np1, ncc, work( 1 ),work( np1 ), c, ldc ) + call stdlib${ii}$_slasr( 'L', 'V', 'F', np1, ncc, work( 1_${ik}$ ),work( np1 ), c, ldc ) end if end if end if - ! call stdlib_sbdsqr to compute the svd of the reduced real + ! call stdlib${ii}$_sbdsqr to compute the svd of the reduced real ! n-by-n upper bidiagonal matrix. - call stdlib_sbdsqr( 'U', n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c,ldc, work, info ) + call stdlib${ii}$_sbdsqr( 'U', n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c,ldc, work, info ) ! sort the singular values into ascending order (insertion sort on ! singular values, but only one transposition per singular vector) @@ -82672,17 +82674,17 @@ module stdlib_linalg_lapack_s ! swap singular values and vectors. d( isub ) = d( i ) d( i ) = smin - if( ncvt>0 )call stdlib_sswap( ncvt, vt( isub, 1 ), ldvt, vt( i, 1 ), ldvt ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_sswap( ncvt, vt( isub, 1_${ik}$ ), ldvt, vt( i, 1_${ik}$ ), ldvt ) - if( nru>0 )call stdlib_sswap( nru, u( 1, isub ), 1, u( 1, i ), 1 ) - if( ncc>0 )call stdlib_sswap( ncc, c( isub, 1 ), ldc, c( i, 1 ), ldc ) + if( nru>0_${ik}$ )call stdlib${ii}$_sswap( nru, u( 1_${ik}$, isub ), 1_${ik}$, u( 1_${ik}$, i ), 1_${ik}$ ) + if( ncc>0_${ik}$ )call stdlib${ii}$_sswap( ncc, c( isub, 1_${ik}$ ), ldc, c( i, 1_${ik}$ ), ldc ) end if end do return - end subroutine stdlib_slasdq + end subroutine stdlib${ii}$_slasdq - pure subroutine stdlib_slasq1( n, d, e, work, info ) + pure subroutine stdlib${ii}$_slasq1( n, d, e, work, info ) !! SLASQ1 computes the singular values of a real N-by-N bidiagonal !! matrix with diagonal D and off-diagonal E. The singular values !! are computed to high relative accuracy, in the absence of @@ -82697,33 +82699,33 @@ 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 real(sp), intent(inout) :: d(*), e(*) real(sp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, iinfo + integer(${ik}$) :: i, iinfo real(sp) :: eps, scale, safmin, sigmn, sigmx ! Intrinsic Functions intrinsic :: abs,max,sqrt ! Executable Statements - info = 0 - if( n<0 ) then - info = -1 - call stdlib_xerbla( 'SLASQ1', -info ) + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -1_${ik}$ + call stdlib${ii}$_xerbla( 'SLASQ1', -info ) return - else if( n==0 ) then + else if( n==0_${ik}$ ) then return - else if( n==1 ) then - d( 1 ) = abs( d( 1 ) ) + else if( n==1_${ik}$ ) then + d( 1_${ik}$ ) = abs( d( 1_${ik}$ ) ) return - else if( n==2 ) then - call stdlib_slas2( d( 1 ), e( 1 ), d( 2 ), sigmn, sigmx ) - d( 1 ) = sigmx - d( 2 ) = sigmn + else if( n==2_${ik}$ ) then + call stdlib${ii}$_slas2( d( 1_${ik}$ ), e( 1_${ik}$ ), d( 2_${ik}$ ), sigmn, sigmx ) + d( 1_${ik}$ ) = sigmx + d( 2_${ik}$ ) = sigmn return end if ! estimate the largest singular value. @@ -82735,7 +82737,7 @@ module stdlib_linalg_lapack_s d( n ) = abs( d( n ) ) ! early return if sigmx is zero (matrix is already diagonal). if( sigmx==zero ) then - call stdlib_slasrt( 'D', n, d, iinfo ) + call stdlib${ii}$_slasrt( 'D', n, d, iinfo ) return end if do i = 1, n @@ -82743,38 +82745,38 @@ module stdlib_linalg_lapack_s end do ! copy d and e into work (in the z format) and scale (squaring the ! input data makes scaling by a power of the radix pointless). - eps = stdlib_slamch( 'PRECISION' ) - safmin = stdlib_slamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_slamch( 'PRECISION' ) + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) scale = sqrt( eps / safmin ) - call stdlib_scopy( n, d, 1, work( 1 ), 2 ) - call stdlib_scopy( n-1, e, 1, work( 2 ), 2 ) - call stdlib_slascl( 'G', 0, 0, sigmx, scale, 2*n-1, 1, work, 2*n-1,iinfo ) + call stdlib${ii}$_scopy( n, d, 1_${ik}$, work( 1_${ik}$ ), 2_${ik}$ ) + call stdlib${ii}$_scopy( n-1, e, 1_${ik}$, work( 2_${ik}$ ), 2_${ik}$ ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, sigmx, scale, 2_${ik}$*n-1, 1_${ik}$, work, 2_${ik}$*n-1,iinfo ) ! compute the q's and e's. do i = 1, 2*n - 1 - work( i ) = work( i )**2 + work( i ) = work( i )**2_${ik}$ end do - work( 2*n ) = zero - call stdlib_slasq2( n, work, info ) - if( info==0 ) then + work( 2_${ik}$*n ) = zero + call stdlib${ii}$_slasq2( n, work, info ) + if( info==0_${ik}$ ) then do i = 1, n d( i ) = sqrt( work( i ) ) end do - call stdlib_slascl( 'G', 0, 0, scale, sigmx, n, 1, d, n, iinfo ) - else if( info==2 ) then + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, scale, sigmx, n, 1_${ik}$, d, n, iinfo ) + else if( info==2_${ik}$ ) then ! maximum number of iterations exceeded. move data from work ! into d and e so the calling subroutine can try to finish do i = 1, n - d( i ) = sqrt( work( 2*i-1 ) ) - e( i ) = sqrt( work( 2*i ) ) + d( i ) = sqrt( work( 2_${ik}$*i-1 ) ) + e( i ) = sqrt( work( 2_${ik}$*i ) ) end do - call stdlib_slascl( 'G', 0, 0, scale, sigmx, n, 1, d, n, iinfo ) - call stdlib_slascl( 'G', 0, 0, scale, sigmx, n, 1, e, n, iinfo ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, scale, sigmx, n, 1_${ik}$, d, n, iinfo ) + call stdlib${ii}$_slascl( 'G', 0_${ik}$, 0_${ik}$, scale, sigmx, n, 1_${ik}$, e, n, iinfo ) end if return - end subroutine stdlib_slasq1 + end subroutine stdlib${ii}$_slasq1 - pure subroutine stdlib_slasq2( n, z, info ) + pure subroutine stdlib${ii}$_slasq2( n, z, info ) !! SLASQ2 computes all the eigenvalues of the symmetric positive !! definite tridiagonal matrix associated with the qd array Z to high !! relative accuracy are computed to high relative accuracy, in the @@ -82792,8 +82794,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) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n ! Array Arguments real(sp), intent(inout) :: z(*) ! ===================================================================== @@ -82804,7 +82806,7 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: ieee - integer(ilp) :: i0, i4, iinfo, ipn4, iter, iwhila, iwhilb, k, kmin, n0, nbig, ndiv, & + integer(${ik}$) :: i0, i4, iinfo, ipn4, iter, iwhila, iwhilb, k, kmin, n0, nbig, ndiv, & nfail, pp, splt, ttype, i1, n1 real(sp) :: d, dee, deemin, desig, dmin, dmin1, dmin2, dn, dn1, dn2, e, emax, emin, & eps, g, oldemn, qmax, qmin, s, safmin, sigma, t, tau, temp, tol, tol2, trace, zmax, & @@ -82813,76 +82815,76 @@ module stdlib_linalg_lapack_s intrinsic :: abs,max,min,real,sqrt ! Executable Statements ! test the input arguments. - ! (in case stdlib_slasq2 is not called by stdlib_slasq1) - info = 0 - eps = stdlib_slamch( 'PRECISION' ) - safmin = stdlib_slamch( 'SAFE MINIMUM' ) + ! (in case stdlib${ii}$_slasq2 is not called by stdlib${ii}$_slasq1) + info = 0_${ik}$ + eps = stdlib${ii}$_slamch( 'PRECISION' ) + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) tol = eps*hundrd - tol2 = tol**2 - if( n<0 ) then - info = -1 - call stdlib_xerbla( 'SLASQ2', 1 ) + tol2 = tol**2_${ik}$ + if( n<0_${ik}$ ) then + info = -1_${ik}$ + call stdlib${ii}$_xerbla( 'SLASQ2', 1_${ik}$ ) return - else if( n==0 ) then + else if( n==0_${ik}$ ) then return - else if( n==1 ) then + else if( n==1_${ik}$ ) then ! 1-by-1 case. - if( z( 1 )z( 1 ) ) then - d = z( 3 ) - z( 3 ) = z( 1 ) - z( 1 ) = d - end if - z( 5 ) = z( 1 ) + z( 2 ) + z( 3 ) - if( z( 2 )>z( 3 )*tol2 ) then - t = half*( ( z( 1 )-z( 3 ) )+z( 2 ) ) - s = z( 3 )*( z( 2 ) / t ) + else if( z( 3_${ik}$ )>z( 1_${ik}$ ) ) then + d = z( 3_${ik}$ ) + z( 3_${ik}$ ) = z( 1_${ik}$ ) + z( 1_${ik}$ ) = d + end if + z( 5_${ik}$ ) = z( 1_${ik}$ ) + z( 2_${ik}$ ) + z( 3_${ik}$ ) + if( z( 2_${ik}$ )>z( 3_${ik}$ )*tol2 ) then + t = half*( ( z( 1_${ik}$ )-z( 3_${ik}$ ) )+z( 2_${ik}$ ) ) + s = z( 3_${ik}$ )*( z( 2_${ik}$ ) / t ) if( s<=t ) then - s = z( 3 )*( z( 2 ) / ( t*( one+sqrt( one+s / t ) ) ) ) + s = z( 3_${ik}$ )*( z( 2_${ik}$ ) / ( t*( one+sqrt( one+s / t ) ) ) ) else - s = z( 3 )*( z( 2 ) / ( t+sqrt( t )*sqrt( t+s ) ) ) + s = z( 3_${ik}$ )*( z( 2_${ik}$ ) / ( t+sqrt( t )*sqrt( t+s ) ) ) end if - t = z( 1 ) + ( s+z( 2 ) ) - z( 3 ) = z( 3 )*( z( 1 ) / t ) - z( 1 ) = t + t = z( 1_${ik}$ ) + ( s+z( 2_${ik}$ ) ) + z( 3_${ik}$ ) = z( 3_${ik}$ )*( z( 1_${ik}$ ) / t ) + z( 1_${ik}$ ) = t end if - z( 2 ) = z( 3 ) - z( 6 ) = z( 2 ) + z( 1 ) + z( 2_${ik}$ ) = z( 3_${ik}$ ) + z( 6_${ik}$ ) = z( 2_${ik}$ ) + z( 1_${ik}$ ) return end if ! check for negative data and compute sums of q's and e's. - z( 2*n ) = zero - emin = z( 2 ) + z( 2_${ik}$*n ) = zero + emin = z( 2_${ik}$ ) qmax = zero zmax = zero d = zero e = zero do k = 1, 2*( n-1 ), 2 if( z( k )i0 ) then - emin = abs( z( 4*n0-5 ) ) + emin = abs( z( 4_${ik}$*n0-5 ) ) else emin = zero end if - qmin = z( 4*n0-3 ) + qmin = z( 4_${ik}$*n0-3 ) qmax = qmin do i4 = 4*n0, 8, -4 if( z( i4-5 )<=zero )go to 100 @@ -83028,24 +83030,24 @@ module stdlib_linalg_lapack_s qmax = max( qmax, z( i4-7 )+z( i4-5 ) ) emin = min( emin, z( i4-5 ) ) end do - i4 = 4 + i4 = 4_${ik}$ 100 continue - i0 = i4 / 4 - pp = 0 - if( n0-i0>1 ) then - dee = z( 4*i0-3 ) + i0 = i4 / 4_${ik}$ + pp = 0_${ik}$ + if( n0-i0>1_${ik}$ ) then + dee = z( 4_${ik}$*i0-3 ) deemin = dee kmin = i0 do i4 = 4*i0+1, 4*n0-3, 4 dee = z( i4 )*( dee /( dee+z( i4-2 ) ) ) if( dee<=deemin ) then deemin = dee - kmin = ( i4+3 )/4 + kmin = ( i4+3 )/4_${ik}$ end if end do - if( (kmin-i0)*2n0 )go to 150 ! while submatrix unfinished take a good dqds step. - call stdlib_slasq3( i0, n0, z, pp, dmin, sigma, desig, qmax, nfail,iter, ndiv, & + call stdlib${ii}$_slasq3( i0, n0, z, pp, dmin, sigma, desig, qmax, nfail,iter, ndiv, & ieee, ttype, dmin1, dmin2, dn, dn1,dn2, g, tau ) - pp = 1 - pp + pp = 1_${ik}$ - pp ! when emin is very small check for splits. - if( pp==0 .and. n0-i0>=3 ) then - if( z( 4*n0 )<=tol2*qmax .or.z( 4*n0-1 )<=tol2*sigma ) then - splt = i0 - 1 - qmax = z( 4*i0-3 ) - emin = z( 4*i0-1 ) - oldemn = z( 4*i0 ) + if( pp==0_${ik}$ .and. n0-i0>=3_${ik}$ ) then + if( z( 4_${ik}$*n0 )<=tol2*qmax .or.z( 4_${ik}$*n0-1 )<=tol2*sigma ) then + splt = i0 - 1_${ik}$ + qmax = z( 4_${ik}$*i0-3 ) + emin = z( 4_${ik}$*i0-1 ) + oldemn = z( 4_${ik}$*i0 ) do i4 = 4*i0, 4*( n0-3 ), 4 if( z( i4 )<=tol2*z( i4-3 ) .or.z( i4-1 )<=tol2*sigma ) then z( i4-1 ) = -sigma - splt = i4 / 4 + splt = i4 / 4_${ik}$ qmax = zero emin = z( i4+3 ) oldemn = z( i4+4 ) @@ -83096,78 +83098,78 @@ module stdlib_linalg_lapack_s oldemn = min( oldemn, z( i4 ) ) end if end do - z( 4*n0-1 ) = emin - z( 4*n0 ) = oldemn - i0 = splt + 1 + z( 4_${ik}$*n0-1 ) = emin + z( 4_${ik}$*n0 ) = oldemn + i0 = splt + 1_${ik}$ end if end if end do loop_140 - info = 2 + info = 2_${ik}$ ! maximum number of iterations exceeded, restore the shift ! sigma and place the new d's and e's in a qd array. ! this might need to be done for several blocks i1 = i0 n1 = n0 145 continue - tempq = z( 4*i0-3 ) - z( 4*i0-3 ) = z( 4*i0-3 ) + sigma + tempq = z( 4_${ik}$*i0-3 ) + z( 4_${ik}$*i0-3 ) = z( 4_${ik}$*i0-3 ) + sigma do k = i0+1, n0 - tempe = z( 4*k-5 ) - z( 4*k-5 ) = z( 4*k-5 ) * (tempq / z( 4*k-7 )) - tempq = z( 4*k-3 ) - z( 4*k-3 ) = z( 4*k-3 ) + sigma + tempe - z( 4*k-5 ) + tempe = z( 4_${ik}$*k-5 ) + z( 4_${ik}$*k-5 ) = z( 4_${ik}$*k-5 ) * (tempq / z( 4_${ik}$*k-7 )) + tempq = z( 4_${ik}$*k-3 ) + z( 4_${ik}$*k-3 ) = z( 4_${ik}$*k-3 ) + sigma + tempe - z( 4_${ik}$*k-5 ) end do ! prepare to do this on the previous block if there is one - if( i1>1 ) then + if( i1>1_${ik}$ ) then n1 = i1-1 do while( ( i1>=2 ) .and. ( z(4*i1-5)>=zero ) ) - i1 = i1 - 1 + i1 = i1 - 1_${ik}$ end do - if( i1>=1 ) then - sigma = -z(4*n1-1) + if( i1>=1_${ik}$ ) then + sigma = -z(4_${ik}$*n1-1) go to 145 end if end if do k = 1, n - z( 2*k-1 ) = z( 4*k-3 ) + z( 2_${ik}$*k-1 ) = z( 4_${ik}$*k-3 ) ! only the block 1..n0 is unfinished. the rest of the e's ! must be essentially zero, although sometimes other data ! has been stored in them. if( kmin(m, nb) )go to 20 ! k is the column to be factorized - ! when being called from stdlib_ssytrf_aa, + ! when being called from stdlib${ii}$_ssytrf_aa, ! > for the first block column, j1 is 1, hence j1+j-1 is j, ! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1, k = j1+j-1 if( j==m ) then ! only need to compute t(j, j) - mj = 1 + mj = 1_${ik}$ else mj = m-j+1 end if ! h(j:m, j) := a(j, j:m) - h(j:m, 1:(j-1)) * l(j1:(j-1), j), ! where h(j:m, j) has been initialized to be a(j, j:m) - if( k>2 ) then + if( k>2_${ik}$ ) then ! k is the column to be factorized ! > for the first block column, k is j, skipping the first two ! columns ! > for the rest of the columns, k is j+1, skipping only the ! first column - call stdlib_sgemv( 'NO TRANSPOSE', mj, j-k1,-one, h( j, k1 ), ldh,a( 1, j ), 1,& - one, h( j, j ), 1 ) + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', mj, j-k1,-one, h( j, k1 ), ldh,a( 1_${ik}$, j ), 1_${ik}$,& + one, h( j, j ), 1_${ik}$ ) end if ! copy h(i:m, i) into work - call stdlib_scopy( mj, h( j, j ), 1, work( 1 ), 1 ) + call stdlib${ii}$_scopy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) if( j>k1 ) then ! compute work := work - l(j-1, j:m) * t(j-1,j), ! where a(j-1, j) stores t(j-1, j) and a(j-2, j:m) stores u(j-1, j:m) alpha = -a( k-1, j ) - call stdlib_saxpy( mj, alpha, a( k-2, j ), lda, work( 1 ), 1 ) + call stdlib${ii}$_saxpy( mj, alpha, a( k-2, j ), lda, work( 1_${ik}$ ), 1_${ik}$ ) end if ! set a(j, j) = t(j, j) - a( k, j ) = work( 1 ) + a( k, j ) = work( 1_${ik}$ ) if( j1 ) then + if( k>1_${ik}$ ) then alpha = -a( k, j ) - call stdlib_saxpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2 ), 1 ) + call stdlib${ii}$_saxpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2_${ik}$ ), 1_${ik}$ ) endif ! find max(|work(2:m)|) - i2 = stdlib_isamax( m-j, work( 2 ), 1 ) + 1 + i2 = stdlib${ii}$_isamax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$ piv = work( i2 ) ! apply symmetric pivot - if( (i2/=2) .and. (piv/=0) ) then + if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then ! swap work(i1) and work(i2) - i1 = 2 + i1 = 2_${ik}$ work( i2 ) = work( i1 ) work( i1 ) = piv ! swap a(i1, i1+1:m) with a(i1+1:m, i2) i1 = i1+j-1 i2 = i2+j-1 - call stdlib_sswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1 ) + call stdlib${ii}$_sswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1_${ik}$ ) ! swap a(i1, i2+1:m) with a(i2, i2+1:m) - if( i2(k1-1) ) then ! swap l(1:i1-1, i1) with l(1:i1-1, i2), ! skipping the first column - call stdlib_sswap( i1-k1+1, a( 1, i1 ), 1,a( 1, i2 ), 1 ) + call stdlib${ii}$_sswap( i1-k1+1, a( 1_${ik}$, i1 ), 1_${ik}$,a( 1_${ik}$, i2 ), 1_${ik}$ ) end if else ipiv( j+1 ) = j+1 endif ! set a(j, j+1) = t(j, j+1) - a( k, j+1 ) = work( 2 ) + a( k, j+1 ) = work( 2_${ik}$ ) if( jmin( m, nb ) )go to 40 ! k is the column to be factorized - ! when being called from stdlib_ssytrf_aa, + ! when being called from stdlib${ii}$_ssytrf_aa, ! > for the first block column, j1 is 1, hence j1+j-1 is j, ! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1, k = j1+j-1 if( j==m ) then ! only need to compute t(j, j) - mj = 1 + mj = 1_${ik}$ else mj = m-j+1 end if ! h(j:m, j) := a(j:m, j) - h(j:m, 1:(j-1)) * l(j, j1:(j-1))^t, ! where h(j:m, j) has been initialized to be a(j:m, j) - if( k>2 ) then + if( k>2_${ik}$ ) then ! k is the column to be factorized ! > for the first block column, k is j, skipping the first two ! columns ! > for the rest of the columns, k is j+1, skipping only the ! first column - call stdlib_sgemv( 'NO TRANSPOSE', mj, j-k1,-one, h( j, k1 ), ldh,a( j, 1 ), lda,& - one, h( j, j ), 1 ) + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', mj, j-k1,-one, h( j, k1 ), ldh,a( j, 1_${ik}$ ), lda,& + one, h( j, j ), 1_${ik}$ ) end if ! copy h(j:m, j) into work - call stdlib_scopy( mj, h( j, j ), 1, work( 1 ), 1 ) + call stdlib${ii}$_scopy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) if( j>k1 ) then ! compute work := work - l(j:m, j-1) * t(j-1,j), ! where a(j-1, j) = t(j-1, j) and a(j, j-2) = l(j, j-1) alpha = -a( j, k-1 ) - call stdlib_saxpy( mj, alpha, a( j, k-2 ), 1, work( 1 ), 1 ) + call stdlib${ii}$_saxpy( mj, alpha, a( j, k-2 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) end if ! set a(j, j) = t(j, j) - a( j, k ) = work( 1 ) + a( j, k ) = work( 1_${ik}$ ) if( j1 ) then + if( k>1_${ik}$ ) then alpha = -a( j, k ) - call stdlib_saxpy( m-j, alpha, a( j+1, k-1 ), 1,work( 2 ), 1 ) + call stdlib${ii}$_saxpy( m-j, alpha, a( j+1, k-1 ), 1_${ik}$,work( 2_${ik}$ ), 1_${ik}$ ) endif ! find max(|work(2:m)|) - i2 = stdlib_isamax( m-j, work( 2 ), 1 ) + 1 + i2 = stdlib${ii}$_isamax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$ piv = work( i2 ) ! apply symmetric pivot - if( (i2/=2) .and. (piv/=0) ) then + if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then ! swap work(i1) and work(i2) - i1 = 2 + i1 = 2_${ik}$ work( i2 ) = work( i1 ) work( i1 ) = piv ! swap a(i1+1:m, i1) with a(i2, i1+1:m) i1 = i1+j-1 i2 = i2+j-1 - call stdlib_sswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1,a( i2, j1+i1 ), lda ) + call stdlib${ii}$_sswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1_${ik}$,a( i2, j1+i1 ), lda ) ! swap a(i2+1:m, i1) with a(i2+1:m, i2) - if( i2(k1-1) ) then ! swap l(1:i1-1, i1) with l(1:i1-1, i2), ! skipping the first column - call stdlib_sswap( i1-k1+1, a( i1, 1 ), lda,a( i2, 1 ), lda ) + call stdlib${ii}$_sswap( i1-k1+1, a( i1, 1_${ik}$ ), lda,a( i2, 1_${ik}$ ), lda ) end if else ipiv( j+1 ) = j+1 endif ! set a(j+1, j) = t(j+1, j) - a( j+1, k ) = work( 2 ) + a( j+1, k ) = work( 2_${ik}$ ) if( j0 .and. ldz0_${ik}$ .and. ldz0 )z( 1, 1 ) = one + if( n==1_${ik}$ ) then + if( icompz>0_${ik}$ )z( 1_${ik}$, 1_${ik}$ ) = one return end if - if( icompz==2 )call stdlib_slaset( 'FULL', n, n, zero, one, z, ldz ) - ! call stdlib_spttrf to factor the matrix. - call stdlib_spttrf( n, d, e, info ) + if( icompz==2_${ik}$ )call stdlib${ii}$_slaset( 'FULL', n, n, zero, one, z, ldz ) + ! call stdlib${ii}$_spttrf to factor the matrix. + call stdlib${ii}$_spttrf( n, d, e, info ) if( info/=0 )return do i = 1, n d( i ) = sqrt( d( i ) ) @@ -83474,17 +83476,17 @@ module stdlib_linalg_lapack_s do i = 1, n - 1 e( i ) = e( i )*d( i ) end do - ! call stdlib_sbdsqr to compute the singular values/vectors of the + ! call stdlib${ii}$_sbdsqr to compute the singular values/vectors of the ! bidiagonal factor. - if( icompz>0 ) then + if( icompz>0_${ik}$ ) then nru = n else - nru = 0 + nru = 0_${ik}$ end if - call stdlib_sbdsqr( 'LOWER', n, 0, nru, 0, d, e, vt, 1, z, ldz, c, 1,work, info ) + call stdlib${ii}$_sbdsqr( 'LOWER', n, 0_${ik}$, nru, 0_${ik}$, d, e, vt, 1_${ik}$, z, ldz, c, 1_${ik}$,work, info ) ! square the singular values. - if( info==0 ) then + if( info==0_${ik}$ ) then do i = 1, n d( i ) = d( i )*d( i ) end do @@ -83492,10 +83494,10 @@ module stdlib_linalg_lapack_s info = n + info end if return - end subroutine stdlib_spteqr + end subroutine stdlib${ii}$_spteqr - pure subroutine stdlib_sstegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, & + pure subroutine stdlib${ii}$_sstegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, & !! SSTEGR computes selected eigenvalues and, optionally, eigenvectors !! of a real symmetric tridiagonal matrix T. Any such unreduced matrix has !! a well defined set of pairwise different real eigenvalues, the corresponding @@ -83518,11 +83520,11 @@ module stdlib_linalg_lapack_s ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range - integer(ilp), intent(in) :: il, iu, ldz, liwork, lwork, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, iu, ldz, liwork, lwork, n + integer(${ik}$), intent(out) :: info, m real(sp), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: isuppz(*), iwork(*) + integer(${ik}$), intent(out) :: isuppz(*), iwork(*) real(sp), intent(inout) :: d(*), e(*) real(sp), intent(out) :: w(*), work(*) real(sp), intent(out) :: z(ldz,*) @@ -83530,14 +83532,14 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: tryrac ! Executable Statements - info = 0 + info = 0_${ik}$ tryrac = .false. - call stdlib_sstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, n, isuppz, & + call stdlib${ii}$_sstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, n, isuppz, & tryrac, work, lwork,iwork, liwork, info ) - end subroutine stdlib_sstegr + end subroutine stdlib${ii}$_sstegr - pure subroutine stdlib_sstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, nzc, & + pure subroutine stdlib${ii}$_sstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, nzc, & !! SSTEMR computes selected eigenvalues and, optionally, eigenvectors !! of a real symmetric tridiagonal matrix T. Any such unreduced matrix has !! a well defined set of pairwise different real eigenvalues, the corresponding @@ -83590,11 +83592,11 @@ module stdlib_linalg_lapack_s ! Scalar Arguments character, intent(in) :: jobz, range logical(lk), intent(inout) :: tryrac - integer(ilp), intent(in) :: il, iu, ldz, nzc, liwork, lwork, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, iu, ldz, nzc, liwork, lwork, n + integer(${ik}$), intent(out) :: info, m real(sp), intent(in) :: vl, vu ! Array Arguments - integer(ilp), intent(out) :: isuppz(*), iwork(*) + integer(${ik}$), intent(out) :: isuppz(*), iwork(*) real(sp), intent(inout) :: d(*), e(*) real(sp), intent(out) :: w(*), work(*) real(sp), intent(out) :: z(ldz,*) @@ -83604,7 +83606,7 @@ module stdlib_linalg_lapack_s ! Local Scalars logical(lk) :: alleig, indeig, lquery, valeig, wantz, zquery - integer(ilp) :: i, ibegin, iend, ifirst, iil, iindbl, iindw, iindwk, iinfo, iinspl, & + integer(${ik}$) :: i, ibegin, iend, ifirst, iil, iindbl, iindw, iindwk, iinfo, iinspl, & iiu, ilast, in, indd, inde2, inderr, indgp, indgrs, indwrk, itmp, itmp2, j, jblk, jj, & liwmin, lwmin, nsplit, nzcmin, offset, wbegin, wend real(sp) :: bignum, cs, eps, pivmin, r1, r2, rmax, rmin, rtol1, rtol2, safmin, scale, & @@ -83617,28 +83619,28 @@ module stdlib_linalg_lapack_s alleig = stdlib_lsame( range, 'A' ) valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) - lquery = ( ( lwork==-1 ).or.( liwork==-1 ) ) - zquery = ( nzc==-1 ) - ! stdlib_sstemr needs work of size 6*n, iwork of size 3*n. - ! in addition, stdlib_slarre needs work of size 6*n, iwork of size 5*n. - ! furthermore, stdlib_slarrv needs work of size 12*n, iwork of size 7*n. + lquery = ( ( lwork==-1_${ik}$ ).or.( liwork==-1_${ik}$ ) ) + zquery = ( nzc==-1_${ik}$ ) + ! stdlib${ii}$_sstemr needs work of size 6*n, iwork of size 3*n. + ! in addition, stdlib${ii}$_slarre needs work of size 6*n, iwork of size 5*n. + ! furthermore, stdlib${ii}$_slarrv needs work of size 12*n, iwork of size 7*n. if( wantz ) then - lwmin = 18*n - liwmin = 10*n + lwmin = 18_${ik}$*n + liwmin = 10_${ik}$*n else ! need less workspace if only the eigenvalues are wanted - lwmin = 12*n - liwmin = 8*n + lwmin = 12_${ik}$*n + liwmin = 8_${ik}$*n endif wl = zero wu = zero - iil = 0 - iiu = 0 - nsplit = 0 + iil = 0_${ik}$ + iiu = 0_${ik}$ + nsplit = 0_${ik}$ if( valeig ) then ! we do not reference vl, vu in the cases range = 'i','a' ! the interval (wl, wu] contains all the wanted eigenvalues. - ! it is either given by the user or computed in stdlib_slarre. + ! it is either given by the user or computed in stdlib${ii}$_slarre. wl = vl wu = vu elseif( indeig ) then @@ -83646,156 +83648,156 @@ module stdlib_linalg_lapack_s iil = il iiu = iu endif - info = 0 + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( valeig .and. n>0 .and. wu<=wl ) then - info = -7 - else if( indeig .and. ( iil<1 .or. iil>n ) ) then - info = -8 + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( valeig .and. n>0_${ik}$ .and. wu<=wl ) then + info = -7_${ik}$ + else if( indeig .and. ( iil<1_${ik}$ .or. iil>n ) ) then + info = -8_${ik}$ else if( indeig .and. ( iiun ) ) then - info = -9 - else if( ldz<1 .or. ( wantz .and. ldz=d( 1 ) ) then - m = 1 - w( 1 ) = d( 1 ) + if( wl=d( 1_${ik}$ ) ) then + m = 1_${ik}$ + w( 1_${ik}$ ) = d( 1_${ik}$ ) end if end if if( wantz.and.(.not.zquery) ) then - z( 1, 1 ) = one - isuppz(1) = 1 - isuppz(2) = 1 + z( 1_${ik}$, 1_${ik}$ ) = one + isuppz(1_${ik}$) = 1_${ik}$ + isuppz(2_${ik}$) = 1_${ik}$ end if return end if - if( n==2 ) then + if( n==2_${ik}$ ) then if( .not.wantz ) then - call stdlib_slae2( d(1), e(1), d(2), r1, r2 ) + call stdlib${ii}$_slae2( d(1_${ik}$), e(1_${ik}$), d(2_${ik}$), r1, r2 ) else if( wantz.and.(.not.zquery) ) then - call stdlib_slaev2( d(1), e(1), d(2), r1, r2, cs, sn ) + call stdlib${ii}$_slaev2( d(1_${ik}$), e(1_${ik}$), d(2_${ik}$), r1, r2, cs, sn ) end if - if( alleig.or.(valeig.and.(r2>wl).and.(r2<=wu)).or.(indeig.and.(iil==1)) ) & + if( alleig.or.(valeig.and.(r2>wl).and.(r2<=wu)).or.(indeig.and.(iil==1_${ik}$)) ) & then m = m+1 w( m ) = r2 if( wantz.and.(.not.zquery) ) then - z( 1, m ) = -sn - z( 2, m ) = cs + z( 1_${ik}$, m ) = -sn + z( 2_${ik}$, m ) = cs ! note: at most one of sn and cs can be zero. if (sn/=zero) then if (cs/=zero) then - isuppz(2*m-1) = 1 - isuppz(2*m) = 2 + isuppz(2_${ik}$*m-1) = 1_${ik}$ + isuppz(2_${ik}$*m) = 2_${ik}$ else - isuppz(2*m-1) = 1 - isuppz(2*m) = 1 + isuppz(2_${ik}$*m-1) = 1_${ik}$ + isuppz(2_${ik}$*m) = 1_${ik}$ end if else - isuppz(2*m-1) = 2 - isuppz(2*m) = 2 + isuppz(2_${ik}$*m-1) = 2_${ik}$ + isuppz(2_${ik}$*m) = 2_${ik}$ end if endif endif - if( alleig.or.(valeig.and.(r1>wl).and.(r1<=wu)).or.(indeig.and.(iiu==2)) ) & + if( alleig.or.(valeig.and.(r1>wl).and.(r1<=wu)).or.(indeig.and.(iiu==2_${ik}$)) ) & then m = m+1 w( m ) = r1 if( wantz.and.(.not.zquery) ) then - z( 1, m ) = cs - z( 2, m ) = sn + z( 1_${ik}$, m ) = cs + z( 2_${ik}$, m ) = sn ! note: at most one of sn and cs can be zero. if (sn/=zero) then if (cs/=zero) then - isuppz(2*m-1) = 1 - isuppz(2*m) = 2 + isuppz(2_${ik}$*m-1) = 1_${ik}$ + isuppz(2_${ik}$*m) = 2_${ik}$ else - isuppz(2*m-1) = 1 - isuppz(2*m) = 1 + isuppz(2_${ik}$*m-1) = 1_${ik}$ + isuppz(2_${ik}$*m) = 1_${ik}$ end if else - isuppz(2*m-1) = 2 - isuppz(2*m) = 2 + isuppz(2_${ik}$*m-1) = 2_${ik}$ + isuppz(2_${ik}$*m) = 2_${ik}$ end if endif endif else ! continue with general n - indgrs = 1 - inderr = 2*n + 1 - indgp = 3*n + 1 - indd = 4*n + 1 - inde2 = 5*n + 1 - indwrk = 6*n + 1 - iinspl = 1 - iindbl = n + 1 - iindw = 2*n + 1 - iindwk = 3*n + 1 + indgrs = 1_${ik}$ + inderr = 2_${ik}$*n + 1_${ik}$ + indgp = 3_${ik}$*n + 1_${ik}$ + indd = 4_${ik}$*n + 1_${ik}$ + inde2 = 5_${ik}$*n + 1_${ik}$ + indwrk = 6_${ik}$*n + 1_${ik}$ + iinspl = 1_${ik}$ + iindbl = n + 1_${ik}$ + iindw = 2_${ik}$*n + 1_${ik}$ + iindwk = 3_${ik}$*n + 1_${ik}$ ! scale matrix to allowable range, if necessary. ! the allowable range is related to the pivmin parameter; see the - ! comments in stdlib_slarrd. the preference for scaling small values + ! comments in stdlib${ii}$_slarrd. the preference for scaling small values ! up is heuristic; we expect users' matrices not to be close to the ! rmax threshold. scale = one - tnrm = stdlib_slanst( 'M', n, d, e ) + tnrm = stdlib${ii}$_slanst( 'M', n, d, e ) if( tnrm>zero .and. tnrmrmax ) then scale = rmax / tnrm end if if( scale/=one ) then - call stdlib_sscal( n, scale, d, 1 ) - call stdlib_sscal( n-1, scale, e, 1 ) + call stdlib${ii}$_sscal( n, scale, d, 1_${ik}$ ) + call stdlib${ii}$_sscal( n-1, scale, e, 1_${ik}$ ) tnrm = tnrm*scale if( valeig ) then ! if eigenvalues in interval have to be found, @@ -83807,19 +83809,19 @@ module stdlib_linalg_lapack_s ! compute the desired eigenvalues of the tridiagonal after splitting ! into smaller subblocks if the corresponding off-diagonal elements ! are small - ! thresh is the splitting parameter for stdlib_slarre + ! thresh is the splitting parameter for stdlib${ii}$_slarre ! a negative thresh forces the old splitting criterion based on the ! size of the off-diagonal. a positive thresh switches to splitting ! which preserves relative accuracy. if( tryrac ) then ! test whether the matrix warrants the more expensive relative approach. - call stdlib_slarrr( n, d, e, iinfo ) + call stdlib${ii}$_slarrr( n, d, e, iinfo ) else ! the user does not care about relative accurately eigenvalues - iinfo = -1 + iinfo = -1_${ik}$ endif ! set the splitting criterion - if (iinfo==0) then + if (iinfo==0_${ik}$) then thresh = eps else thresh = -eps @@ -83828,51 +83830,51 @@ module stdlib_linalg_lapack_s endif if( tryrac ) then ! copy original diagonal, needed to guarantee relative accuracy - call stdlib_scopy(n,d,1,work(indd),1) + call stdlib${ii}$_scopy(n,d,1_${ik}$,work(indd),1_${ik}$) endif ! store the squares of the offdiagonal values of t do j = 1, n-1 - work( inde2+j-1 ) = e(j)**2 + work( inde2+j-1 ) = e(j)**2_${ik}$ end do ! set the tolerance parameters for bisection if( .not.wantz ) then - ! stdlib_slarre computes the eigenvalues to full precision. + ! stdlib${ii}$_slarre computes the eigenvalues to full precision. rtol1 = four * eps rtol2 = four * eps else - ! stdlib_slarre computes the eigenvalues to less than full precision. - ! stdlib_slarrv will refine the eigenvalue approximations, and we can - ! need less accurate initial bisection in stdlib_slarre. - ! note: these settings do only affect the subset case and stdlib_slarre + ! stdlib${ii}$_slarre computes the eigenvalues to less than full precision. + ! stdlib${ii}$_slarrv will refine the eigenvalue approximations, and we can + ! need less accurate initial bisection in stdlib${ii}$_slarre. + ! note: these settings do only affect the subset case and stdlib${ii}$_slarre rtol1 = max( sqrt(eps)*5.0e-2_sp, four * eps ) rtol2 = max( sqrt(eps)*5.0e-3_sp, four * eps ) endif - call stdlib_slarre( range, n, wl, wu, iil, iiu, d, e,work(inde2), rtol1, rtol2, & + call stdlib${ii}$_slarre( range, n, wl, wu, iil, iiu, d, e,work(inde2), rtol1, rtol2, & thresh, nsplit,iwork( iinspl ), m, w, work( inderr ),work( indgp ), iwork( iindbl ),& iwork( iindw ), work( indgrs ), pivmin,work( indwrk ), iwork( iindwk ), iinfo ) - if( iinfo/=0 ) then - info = 10 + abs( iinfo ) + if( iinfo/=0_${ik}$ ) then + info = 10_${ik}$ + abs( iinfo ) return end if - ! note that if range /= 'v', stdlib_slarre computes bounds on the desired + ! note that if range /= 'v', stdlib${ii}$_slarre computes bounds on the desired ! part of the spectrum. all desired eigenvalues are contained in ! (wl,wu] if( wantz ) then ! compute the desired eigenvectors corresponding to the computed ! eigenvalues - call stdlib_slarrv( n, wl, wu, d, e,pivmin, iwork( iinspl ), m,1, m, minrgp, & + call stdlib${ii}$_slarrv( n, wl, wu, d, e,pivmin, iwork( iinspl ), m,1_${ik}$, m, minrgp, & rtol1, rtol2,w, work( inderr ), work( indgp ), iwork( iindbl ),iwork( iindw ), & work( indgrs ), z, ldz,isuppz, work( indwrk ), iwork( iindwk ), iinfo ) - if( iinfo/=0 ) then - info = 20 + abs( iinfo ) + if( iinfo/=0_${ik}$ ) then + info = 20_${ik}$ + abs( iinfo ) return end if else - ! stdlib_slarre computes eigenvalues of the (shifted) root representation - ! stdlib_slarrv returns the eigenvalues of the unshifted matrix. + ! stdlib${ii}$_slarre computes eigenvalues of the (shifted) root representation + ! stdlib${ii}$_slarrv returns the eigenvalues of the unshifted matrix. ! however, if the eigenvectors are not desired by the user, we need - ! to apply the corresponding shifts from stdlib_slarre to obtain the + ! to apply the corresponding shifts from stdlib${ii}$_slarre to obtain the ! eigenvalues of the original matrix. do j = 1, m itmp = iwork( iindbl+j-1 ) @@ -83882,52 +83884,52 @@ module stdlib_linalg_lapack_s if ( tryrac ) then ! refine computed eigenvalues so that they are relatively accurate ! with respect to the original matrix t. - ibegin = 1 - wbegin = 1 + ibegin = 1_${ik}$ + wbegin = 1_${ik}$ loop_39: do jblk = 1, iwork( iindbl+m-1 ) iend = iwork( iinspl+jblk-1 ) - in = iend - ibegin + 1 - wend = wbegin - 1 + in = iend - ibegin + 1_${ik}$ + wend = wbegin - 1_${ik}$ ! check if any eigenvalues have to be refined in this block 36 continue if( wend1 .or. n==2 ) then + if( nsplit>1_${ik}$ .or. n==2_${ik}$ ) then if( .not. wantz ) then - call stdlib_slasrt( 'I', m, w, iinfo ) - if( iinfo/=0 ) then - info = 3 + call stdlib${ii}$_slasrt( 'I', m, w, iinfo ) + if( iinfo/=0_${ik}$ ) then + info = 3_${ik}$ return end if else do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp = w( j ) do jj = j + 1, m if( w( jj )0 .and. vu<=vl )info = -7 + if( n>0_${ik}$ .and. vu<=vl )info = -7_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -8 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -8_${ik}$ else if( iun ) then - info = -9 + info = -9_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz=d( 1 ) ) then - m = 1 - w( 1 ) = d( 1 ) + if( vl=d( 1_${ik}$ ) ) then + m = 1_${ik}$ + w( 1_${ik}$ ) = d( 1_${ik}$ ) end if end if - if( wantz )z( 1, 1 ) = one + if( wantz )z( 1_${ik}$, 1_${ik}$ ) = one return end if ! get machine constants. - safmin = stdlib_slamch( 'SAFE MINIMUM' ) - eps = stdlib_slamch( 'PRECISION' ) + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_slamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) ) ! scale matrix to allowable range, if necessary. - iscale = 0 + iscale = 0_${ik}$ if( valeig ) then vll = vl vuu = vu end if - tnrm = stdlib_slanst( 'M', n, d, e ) + tnrm = stdlib${ii}$_slanst( 'M', n, d, e ) if( tnrm>zero .and. tnrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / tnrm end if - if( iscale==1 ) then - call stdlib_sscal( n, sigma, d, 1 ) - call stdlib_sscal( n-1, sigma, e( 1 ), 1 ) + if( iscale==1_${ik}$ ) then + call stdlib${ii}$_sscal( n, sigma, d, 1_${ik}$ ) + call stdlib${ii}$_sscal( n-1, sigma, e( 1_${ik}$ ), 1_${ik}$ ) if( valeig ) then vll = vl*sigma vuu = vu*sigma end if end if ! initialize indices into workspaces. note: these indices are used only - ! if stdlib_ssterf or stdlib_sstemr fail. - ! iwork(indibl:indibl+m-1) corresponds to iblock in stdlib_sstebz and + ! if stdlib${ii}$_ssterf or stdlib${ii}$_sstemr fail. + ! iwork(indibl:indibl+m-1) corresponds to iblock in stdlib${ii}$_sstebz and ! stores the block indices of each of the m<=n eigenvalues. - indibl = 1 - ! iwork(indisp:indisp+nsplit-1) corresponds to isplit in stdlib_sstebz and + indibl = 1_${ik}$ + ! iwork(indisp:indisp+nsplit-1) corresponds to isplit in stdlib${ii}$_sstebz and ! stores the starting and finishing indices of each block. indisp = indibl + n ! iwork(indifl:indifl+n-1) stores the indices of eigenvectors ! that corresponding to eigenvectors that fail to converge in - ! stdlib_sstein. this information is discarded; if any fail, the driver + ! stdlib${ii}$_sstein. this information is discarded; if any fail, the driver ! returns info > 0. indifl = indisp + n ! indiwo is the offset of the remaining integer workspace. indiwo = indisp + n ! if all eigenvalues are desired, then - ! call stdlib_ssterf or stdlib_sstemr. if this fails for some eigenvalue, then - ! try stdlib_sstebz. + ! call stdlib${ii}$_ssterf or stdlib${ii}$_sstemr. if this fails for some eigenvalue, then + ! try stdlib${ii}$_sstebz. test = .false. if( indeig ) then - if( il==1 .and. iu==n ) then + if( il==1_${ik}$ .and. iu==n ) then test = .true. end if end if - if( ( alleig .or. test ) .and. ieeeok==1 ) then - call stdlib_scopy( n-1, e( 1 ), 1, work( 1 ), 1 ) + if( ( alleig .or. test ) .and. ieeeok==1_${ik}$ ) then + call stdlib${ii}$_scopy( n-1, e( 1_${ik}$ ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) if( .not.wantz ) then - call stdlib_scopy( n, d, 1, w, 1 ) - call stdlib_ssterf( n, w, work, info ) + call stdlib${ii}$_scopy( n, d, 1_${ik}$, w, 1_${ik}$ ) + call stdlib${ii}$_ssterf( n, w, work, info ) else - call stdlib_scopy( n, d, 1, work( n+1 ), 1 ) + call stdlib${ii}$_scopy( n, d, 1_${ik}$, work( n+1 ), 1_${ik}$ ) if (abstol <= two*n*eps) then tryrac = .true. else tryrac = .false. end if - call stdlib_sstemr( jobz, 'A', n, work( n+1 ), work, vl, vu, il,iu, m, w, z, ldz,& - n, isuppz, tryrac,work( 2*n+1 ), lwork-2*n, iwork, liwork, info ) + call stdlib${ii}$_sstemr( jobz, 'A', n, work( n+1 ), work, vl, vu, il,iu, m, w, z, ldz,& + n, isuppz, tryrac,work( 2_${ik}$*n+1 ), lwork-2*n, iwork, liwork, info ) end if - if( info==0 ) then + if( info==0_${ik}$ ) then m = n go to 10 end if - info = 0 + info = 0_${ik}$ end if - ! otherwise, call stdlib_sstebz and, if eigenvectors are desired, stdlib_sstein. + ! otherwise, call stdlib${ii}$_sstebz and, if eigenvectors are desired, stdlib${ii}$_sstein. if( wantz ) then order = 'B' else order = 'E' end if - call stdlib_sstebz( range, order, n, vll, vuu, il, iu, abstol, d, e, m,nsplit, w, & + call stdlib${ii}$_sstebz( range, order, n, vll, vuu, il, iu, abstol, d, e, m,nsplit, w, & iwork( indibl ), iwork( indisp ), work,iwork( indiwo ), info ) if( wantz ) then - call stdlib_sstein( n, d, e, m, w, iwork( indibl ), iwork( indisp ),z, ldz, work, & + call stdlib${ii}$_sstein( n, d, e, m, w, iwork( indibl ), iwork( indisp ),z, ldz, work, & iwork( indiwo ), iwork( indifl ),info ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. 10 continue - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = m else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_sscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. if( wantz ) then do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp1 = w( j ) do jj = j + 1, m if( w( jj )0 .and. vu<=vl )info = -8 + if( n>0_${ik}$ .and. vu<=vl )info = -8_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -9 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -9_${ik}$ else if( iun ) then - info = -10 + info = -10_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz=a( 1, 1 ) ) then - m = 1 - w( 1 ) = a( 1, 1 ) + if( vl=a( 1_${ik}$, 1_${ik}$ ) ) then + m = 1_${ik}$ + w( 1_${ik}$ ) = a( 1_${ik}$, 1_${ik}$ ) end if end if if( wantz ) then - z( 1, 1 ) = one - isuppz( 1 ) = 1 - isuppz( 2 ) = 1 + z( 1_${ik}$, 1_${ik}$ ) = one + isuppz( 1_${ik}$ ) = 1_${ik}$ + isuppz( 2_${ik}$ ) = 1_${ik}$ end if return end if ! get machine constants. - safmin = stdlib_slamch( 'SAFE MINIMUM' ) - eps = stdlib_slamch( 'PRECISION' ) + safmin = stdlib${ii}$_slamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_slamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) ) ! scale matrix to allowable range, if necessary. - iscale = 0 + iscale = 0_${ik}$ abstll = abstol if (valeig) then vll = vl vuu = vu end if - anrm = stdlib_slansy( 'M', uplo, n, a, lda, work ) + anrm = stdlib${ii}$_slansy( 'M', uplo, n, a, lda, work ) if( anrm>zero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then do j = 1, n - call stdlib_sscal( n-j+1, sigma, a( j, j ), 1 ) + call stdlib${ii}$_sscal( n-j+1, sigma, a( j, j ), 1_${ik}$ ) end do else do j = 1, n - call stdlib_sscal( j, sigma, a( 1, j ), 1 ) + call stdlib${ii}$_sscal( j, sigma, a( 1_${ik}$, j ), 1_${ik}$ ) end do end if - if( abstol>0 )abstll = abstol*sigma + if( abstol>0_${ik}$ )abstll = abstol*sigma if( valeig ) then vll = vl*sigma vuu = vu*sigma end if end if ! initialize indices into workspaces. note: the iwork indices are - ! used only if stdlib_ssterf or stdlib_sstemr fail. + ! used only if stdlib${ii}$_ssterf or stdlib${ii}$_sstemr fail. ! work(indtau:indtau+n-1) stores the scalar factors of the - ! elementary reflectors used in stdlib_ssytrd. - indtau = 1 + ! elementary reflectors used in stdlib${ii}$_ssytrd. + indtau = 1_${ik}$ ! work(indd:indd+n-1) stores the tridiagonal's diagonal entries. indd = indtau + n ! work(inde:inde+n-1) stores the off-diagonal entries of the - ! tridiagonal matrix from stdlib_ssytrd. + ! tridiagonal matrix from stdlib${ii}$_ssytrd. inde = indd + n ! work(inddd:inddd+n-1) is a copy of the diagonal entries over - ! -written by stdlib_sstemr (the stdlib_ssterf path copies the diagonal to w). + ! -written by stdlib${ii}$_sstemr (the stdlib${ii}$_ssterf path copies the diagonal to w). inddd = inde + n ! work(indee:indee+n-1) is a copy of the off-diagonal entries over - ! -written while computing the eigenvalues in stdlib_ssterf and stdlib_sstemr. + ! -written while computing the eigenvalues in stdlib${ii}$_ssterf and stdlib${ii}$_sstemr. indee = inddd + n ! indwk is the starting offset of the left-over workspace, and ! llwork is the remaining workspace size. indwk = indee + n - llwork = lwork - indwk + 1 - ! iwork(indibl:indibl+m-1) corresponds to iblock in stdlib_sstebz and + llwork = lwork - indwk + 1_${ik}$ + ! iwork(indibl:indibl+m-1) corresponds to iblock in stdlib${ii}$_sstebz and ! stores the block indices of each of the m<=n eigenvalues. - indibl = 1 - ! iwork(indisp:indisp+nsplit-1) corresponds to isplit in stdlib_sstebz and + indibl = 1_${ik}$ + ! iwork(indisp:indisp+nsplit-1) corresponds to isplit in stdlib${ii}$_sstebz and ! stores the starting and finishing indices of each block. indisp = indibl + n ! iwork(indifl:indifl+n-1) stores the indices of eigenvectors ! that corresponding to eigenvectors that fail to converge in - ! stdlib_sstein. this information is discarded; if any fail, the driver + ! stdlib${ii}$_sstein. this information is discarded; if any fail, the driver ! returns info > 0. indifl = indisp + n ! indiwo is the offset of the remaining integer workspace. indiwo = indifl + n - ! call stdlib_ssytrd to reduce symmetric matrix to tridiagonal form. - call stdlib_ssytrd( uplo, n, a, lda, work( indd ), work( inde ),work( indtau ), work( & + ! call stdlib${ii}$_ssytrd to reduce symmetric matrix to tridiagonal form. + call stdlib${ii}$_ssytrd( uplo, n, a, lda, work( indd ), work( inde ),work( indtau ), work( & indwk ), llwork, iinfo ) ! if all eigenvalues are desired - ! then call stdlib_ssterf or stdlib_sstemr and stdlib_sormtr. + ! then call stdlib${ii}$_ssterf or stdlib${ii}$_sstemr and stdlib${ii}$_sormtr. test = .false. if( indeig ) then - if( il==1 .and. iu==n ) then + if( il==1_${ik}$ .and. iu==n ) then test = .true. end if end if - if( ( alleig.or.test ) .and. ( ieeeok==1 ) ) then + if( ( alleig.or.test ) .and. ( ieeeok==1_${ik}$ ) ) then if( .not.wantz ) then - call stdlib_scopy( n, work( indd ), 1, w, 1 ) - call stdlib_scopy( n-1, work( inde ), 1, work( indee ), 1 ) - call stdlib_ssterf( n, w, work( indee ), info ) + call stdlib${ii}$_scopy( n, work( indd ), 1_${ik}$, w, 1_${ik}$ ) + call stdlib${ii}$_scopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ ) + call stdlib${ii}$_ssterf( n, w, work( indee ), info ) else - call stdlib_scopy( n-1, work( inde ), 1, work( indee ), 1 ) - call stdlib_scopy( n, work( indd ), 1, work( inddd ), 1 ) + call stdlib${ii}$_scopy( n-1, work( inde ), 1_${ik}$, work( indee ), 1_${ik}$ ) + call stdlib${ii}$_scopy( n, work( indd ), 1_${ik}$, work( inddd ), 1_${ik}$ ) if (abstol <= two*n*eps) then tryrac = .true. else tryrac = .false. end if - call stdlib_sstemr( jobz, 'A', n, work( inddd ), work( indee ),vl, vu, il, iu, m,& + call stdlib${ii}$_sstemr( jobz, 'A', n, work( inddd ), work( indee ),vl, vu, il, iu, m,& w, z, ldz, n, isuppz,tryrac, work( indwk ), lwork, iwork, liwork,info ) ! apply orthogonal matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_sstemr. - if( wantz .and. info==0 ) then + ! form to eigenvectors returned by stdlib${ii}$_sstemr. + if( wantz .and. info==0_${ik}$ ) then indwkn = inde - llwrkn = lwork - indwkn + 1 - call stdlib_sormtr( 'L', uplo, 'N', n, m, a, lda,work( indtau ), z, ldz, work(& + llwrkn = lwork - indwkn + 1_${ik}$ + call stdlib${ii}$_sormtr( 'L', uplo, 'N', n, m, a, lda,work( indtau ), z, ldz, work(& indwkn ),llwrkn, iinfo ) end if end if - if( info==0 ) then - ! everything worked. skip stdlib_sstebz/stdlib_sstein. iwork(:) are + if( info==0_${ik}$ ) then + ! everything worked. skip stdlib${ii}$_sstebz/stdlib${ii}$_sstein. iwork(:) are ! undefined. m = n go to 30 end if - info = 0 + info = 0_${ik}$ end if - ! otherwise, call stdlib_sstebz and, if eigenvectors are desired, stdlib_sstein. - ! also call stdlib_sstebz and stdlib_sstein if stdlib_sstemr fails. + ! otherwise, call stdlib${ii}$_sstebz and, if eigenvectors are desired, stdlib${ii}$_sstein. + ! also call stdlib${ii}$_sstebz and stdlib${ii}$_sstein if stdlib${ii}$_sstemr fails. if( wantz ) then order = 'B' else order = 'E' end if - call stdlib_sstebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde & + call stdlib${ii}$_sstebz( range, order, n, vll, vuu, il, iu, abstll,work( indd ), work( inde & ), m, nsplit, w,iwork( indibl ), iwork( indisp ), work( indwk ),iwork( indiwo ), info ) if( wantz ) then - call stdlib_sstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & + call stdlib${ii}$_sstein( n, work( indd ), work( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,work( indwk ), iwork( indiwo ), iwork( indifl ),info ) ! apply orthogonal matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_sstein. + ! form to eigenvectors returned by stdlib${ii}$_sstein. indwkn = inde - llwrkn = lwork - indwkn + 1 - call stdlib_sormtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & + llwrkn = lwork - indwkn + 1_${ik}$ + call stdlib${ii}$_sormtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & indwkn ), llwrkn, iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - ! jump here if stdlib_sstemr/stdlib_sstein succeeded. + ! jump here if stdlib${ii}$_sstemr/stdlib${ii}$_sstein succeeded. 30 continue - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = m else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_sscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_sscal( imax, one / sigma, w, 1_${ik}$ ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. note: we do not sort the ifail portion of iwork. - ! it may not be initialized (if stdlib_sstemr/stdlib_sstein succeeded), and we do + ! it may not be initialized (if stdlib${ii}$_sstemr/stdlib${ii}$_sstein succeeded), and we do ! not return this detailed information to the user. if( wantz ) then do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp1 = w( j ) do jj = j + 1, m if( w( jj )=n )go to 20 ! each step of the main loop @@ -84688,17 +84690,17 @@ module stdlib_linalg_lapack_s ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=1 for the first panel, and ! k1=0 for the rest - j1 = j + 1 + j1 = j + 1_${ik}$ jb = min( n-j1+1, nb ) - k1 = max(1, j)-j + k1 = max(1_${ik}$, j)-j ! panel factorization - call stdlib_slasyf_aa( uplo, 2-k1, n-j, jb,a( max(1, j), j+1 ), lda,ipiv( j+1 ), & + call stdlib${ii}$_slasyf_aa( uplo, 2_${ik}$-k1, n-j, jb,a( max(1_${ik}$, j), j+1 ), lda,ipiv( j+1 ), & work, n, work( n*nb+1 ) ) ! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot) do j2 = j+2, min(n, j+jb+1) ipiv( j2 ) = ipiv( j2 ) + j - if( (j2/=ipiv(j2)) .and. ((j1-k1)>2) ) then - call stdlib_sswap( j1-k1-2, a( 1, j2 ), 1,a( 1, ipiv(j2) ), 1 ) + if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then + call stdlib${ii}$_sswap( j1-k1-2, a( 1_${ik}$, j2 ), 1_${ik}$,a( 1_${ik}$, ipiv(j2) ), 1_${ik}$ ) end if end do j = j + jb @@ -84707,43 +84709,43 @@ module stdlib_linalg_lapack_s ! work stores the current block of the auxiriarly matrix h if( j1 .or. jb>1 ) then + if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then ! merge rank-1 update with blas-3 update alpha = a( j, j+1 ) a( j, j+1 ) = one - call stdlib_scopy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib${ii}$_scopy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) - call stdlib_sscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib${ii}$_sscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=1 and k2= 0 for the first panel, ! while k1=0 and k2=1 for the rest - if( j1>1 ) then + if( j1>1_${ik}$ ) then ! not first panel - k2 = 1 + k2 = 1_${ik}$ else ! first panel - k2 = 0 + k2 = 0_${ik}$ ! first update skips the first column - jb = jb - 1 + jb = jb - 1_${ik}$ end if do j2 = j+1, n, nb nj = min( nb, n-j2+1 ) - ! update (j2, j2) diagonal block with stdlib_sgemv + ! update (j2, j2) diagonal block with stdlib${ii}$_sgemv j3 = j2 do mj = nj-1, 1, -1 - call stdlib_sgemv( 'NO TRANSPOSE', mj, jb+1,-one, work( j3-j1+1+k1*n ), & - n,a( j1-k2, j3 ), 1,one, a( j3, j3 ), lda ) - j3 = j3 + 1 + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', mj, jb+1,-one, work( j3-j1+1+k1*n ), & + n,a( j1-k2, j3 ), 1_${ik}$,one, a( j3, j3 ), lda ) + j3 = j3 + 1_${ik}$ end do - ! update off-diagonal block of j2-th block row with stdlib_sgemm - call stdlib_sgemm( 'TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-one, a( j1-& + ! update off-diagonal block of j2-th block row with stdlib${ii}$_sgemm + call stdlib${ii}$_sgemm( 'TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-one, a( j1-& k2, j2 ), lda,work( j3-j1+1+k1*n ), n,one, a( j2, j3 ), lda ) end do ! recover t( j, j+1 ) a( j, j+1 ) = alpha end if ! work(j+1, 1) stores h(j+1, 1) - call stdlib_scopy( n-j, a( j+1, j+1 ), lda, work( 1 ), 1 ) + call stdlib${ii}$_scopy( n-j, a( j+1, j+1 ), lda, work( 1_${ik}$ ), 1_${ik}$ ) end if go to 10 else @@ -84752,11 +84754,11 @@ module stdlib_linalg_lapack_s ! ..................................................... ! copy first column a(1:n, 1) into h(1:n, 1) ! (stored in work(1:n)) - call stdlib_scopy( n, a( 1, 1 ), 1, work( 1 ), 1 ) + call stdlib${ii}$_scopy( n, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) ! j is the main loop index, increasing from 1 to n in steps of - ! jb, where jb is the number of columns factorized by stdlib_slasyf; + ! jb, where jb is the number of columns factorized by stdlib${ii}$_slasyf; ! jb is either nb, or n-j+1 for the last block - j = 0 + j = 0_${ik}$ 11 continue if( j>=n )go to 20 ! each step of the main loop @@ -84767,15 +84769,15 @@ module stdlib_linalg_lapack_s ! k1=0 for the rest j1 = j+1 jb = min( n-j1+1, nb ) - k1 = max(1, j)-j + k1 = max(1_${ik}$, j)-j ! panel factorization - call stdlib_slasyf_aa( uplo, 2-k1, n-j, jb,a( j+1, max(1, j) ), lda,ipiv( j+1 ), & + call stdlib${ii}$_slasyf_aa( uplo, 2_${ik}$-k1, n-j, jb,a( j+1, max(1_${ik}$, j) ), lda,ipiv( j+1 ), & work, n, work( n*nb+1 ) ) ! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot) do j2 = j+2, min(n, j+jb+1) ipiv( j2 ) = ipiv( j2 ) + j - if( (j2/=ipiv(j2)) .and. ((j1-k1)>2) ) then - call stdlib_sswap( j1-k1-2, a( j2, 1 ), lda,a( ipiv(j2), 1 ), lda ) + if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then + call stdlib${ii}$_sswap( j1-k1-2, a( j2, 1_${ik}$ ), lda,a( ipiv(j2), 1_${ik}$ ), lda ) end if end do j = j + jb @@ -84784,50 +84786,50 @@ module stdlib_linalg_lapack_s ! work(j2+1, 1) stores h(j2+1, 1) if( j1 .or. jb>1 ) then + if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then ! merge rank-1 update with blas-3 update alpha = a( j+1, j ) a( j+1, j ) = one - call stdlib_scopy( n-j, a( j+1, j-1 ), 1,work( (j+1-j1+1)+jb*n ), 1 ) - call stdlib_sscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib${ii}$_scopy( n-j, a( j+1, j-1 ), 1_${ik}$,work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) + call stdlib${ii}$_sscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=1 and k2= 0 for the first panel, ! while k1=0 and k2=1 for the rest - if( j1>1 ) then + if( j1>1_${ik}$ ) then ! not first panel - k2 = 1 + k2 = 1_${ik}$ else ! first panel - k2 = 0 + k2 = 0_${ik}$ ! first update skips the first column - jb = jb - 1 + jb = jb - 1_${ik}$ end if do j2 = j+1, n, nb nj = min( nb, n-j2+1 ) - ! update (j2, j2) diagonal block with stdlib_sgemv + ! update (j2, j2) diagonal block with stdlib${ii}$_sgemv j3 = j2 do mj = nj-1, 1, -1 - call stdlib_sgemv( 'NO TRANSPOSE', mj, jb+1,-one, work( j3-j1+1+k1*n ), & - n,a( j3, j1-k2 ), lda,one, a( j3, j3 ), 1 ) - j3 = j3 + 1 + call stdlib${ii}$_sgemv( 'NO TRANSPOSE', mj, jb+1,-one, work( j3-j1+1+k1*n ), & + n,a( j3, j1-k2 ), lda,one, a( j3, j3 ), 1_${ik}$ ) + j3 = j3 + 1_${ik}$ end do - ! update off-diagonal block in j2-th block column with stdlib_sgemm - call stdlib_sgemm( 'NO TRANSPOSE', 'TRANSPOSE',n-j3+1, nj, jb+1,-one, work(& + ! update off-diagonal block in j2-th block column with stdlib${ii}$_sgemm + call stdlib${ii}$_sgemm( 'NO TRANSPOSE', 'TRANSPOSE',n-j3+1, nj, jb+1,-one, work(& j3-j1+1+k1*n ), n,a( j2, j1-k2 ), lda,one, a( j3, j2 ), lda ) end do ! recover t( j+1, j ) a( j+1, j ) = alpha end if ! work(j+1, 1) stores h(j+1, 1) - call stdlib_scopy( n-j, a( j+1, j+1 ), 1, work( 1 ), 1 ) + call stdlib${ii}$_scopy( n-j, a( j+1, j+1 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) end if go to 11 end if 20 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_ssytrf_aa - + end subroutine stdlib${ii}$_ssytrf_aa + #:endfor end module stdlib_linalg_lapack_s diff --git a/src/stdlib_linalg_lapack_w.fypp b/src/stdlib_linalg_lapack_w.fypp index 306279071..abfd667b5 100644 --- a/src/stdlib_linalg_lapack_w.fypp +++ b/src/stdlib_linalg_lapack_w.fypp @@ -14,459 +14,460 @@ module stdlib_linalg_lapack_${ci}$ implicit none(type,external) private - - public :: sp,dp,${ck}$,lk,ilp - public :: stdlib_${ci}$lag2w - public :: stdlib_${ci}$bbcsd - public :: stdlib_${ci}$bdsqr - public :: stdlib_${ci}$cgesv - public :: stdlib_${ci}$cposv - public :: stdlib_${ci}$drscl - public :: stdlib_${ci}$gbbrd - public :: stdlib_${ci}$gbcon - public :: stdlib_${ci}$gbequ - public :: stdlib_${ci}$gbequb - public :: stdlib_${ci}$gbrfs - public :: stdlib_${ci}$gbsv - public :: stdlib_${ci}$gbsvx - public :: stdlib_${ci}$gbtf2 - public :: stdlib_${ci}$gbtrf - public :: stdlib_${ci}$gbtrs - public :: stdlib_${ci}$gebak - public :: stdlib_${ci}$gebal - public :: stdlib_${ci}$gebd2 - public :: stdlib_${ci}$gebrd - public :: stdlib_${ci}$gecon - public :: stdlib_${ci}$geequ - public :: stdlib_${ci}$geequb - public :: stdlib_${ci}$gees - public :: stdlib_${ci}$geesx - public :: stdlib_${ci}$geev - public :: stdlib_${ci}$geevx - public :: stdlib_${ci}$gehd2 - public :: stdlib_${ci}$gehrd - public :: stdlib_${ci}$gejsv - public :: stdlib_${ci}$gelq - public :: stdlib_${ci}$gelq2 - public :: stdlib_${ci}$gelqf - public :: stdlib_${ci}$gelqt - public :: stdlib_${ci}$gelqt3 - public :: stdlib_${ci}$gels - public :: stdlib_${ci}$gelsd - public :: stdlib_${ci}$gelss - public :: stdlib_${ci}$gelsy - public :: stdlib_${ci}$gemlq - public :: stdlib_${ci}$gemlqt - public :: stdlib_${ci}$gemqr - public :: stdlib_${ci}$gemqrt - public :: stdlib_${ci}$geql2 - public :: stdlib_${ci}$geqlf - public :: stdlib_${ci}$geqp3 - public :: stdlib_${ci}$geqr - public :: stdlib_${ci}$geqr2 - public :: stdlib_${ci}$geqr2p - public :: stdlib_${ci}$geqrf - public :: stdlib_${ci}$geqrfp - public :: stdlib_${ci}$geqrt - public :: stdlib_${ci}$geqrt2 - public :: stdlib_${ci}$geqrt3 - public :: stdlib_${ci}$gerfs - public :: stdlib_${ci}$gerq2 - public :: stdlib_${ci}$gerqf - public :: stdlib_${ci}$gesc2 - public :: stdlib_${ci}$gesdd - public :: stdlib_${ci}$gesv - public :: stdlib_${ci}$gesvd - public :: stdlib_${ci}$gesvdq - public :: stdlib_${ci}$gesvj - public :: stdlib_${ci}$gesvx - public :: stdlib_${ci}$getc2 - public :: stdlib_${ci}$getf2 - public :: stdlib_${ci}$getrf - public :: stdlib_${ci}$getrf2 - public :: stdlib_${ci}$getri - public :: stdlib_${ci}$getrs - public :: stdlib_${ci}$getsls - public :: stdlib_${ci}$getsqrhrt - public :: stdlib_${ci}$ggbak - public :: stdlib_${ci}$ggbal - public :: stdlib_${ci}$gges - public :: stdlib_${ci}$gges3 - public :: stdlib_${ci}$ggesx - public :: stdlib_${ci}$ggev - public :: stdlib_${ci}$ggev3 - public :: stdlib_${ci}$ggevx - public :: stdlib_${ci}$ggglm - public :: stdlib_${ci}$gghd3 - public :: stdlib_${ci}$gghrd - public :: stdlib_${ci}$gglse - public :: stdlib_${ci}$ggqrf - public :: stdlib_${ci}$ggrqf - public :: stdlib_${ci}$gsvj0 - public :: stdlib_${ci}$gsvj1 - public :: stdlib_${ci}$gtcon - public :: stdlib_${ci}$gtrfs - public :: stdlib_${ci}$gtsv - public :: stdlib_${ci}$gtsvx - public :: stdlib_${ci}$gttrf - public :: stdlib_${ci}$gttrs - public :: stdlib_${ci}$gtts2 - public :: stdlib_${ci}$hb2st_kernels - public :: stdlib_${ci}$hbev - public :: stdlib_${ci}$hbevd - public :: stdlib_${ci}$hbevx - public :: stdlib_${ci}$hbgst - public :: stdlib_${ci}$hbgv - public :: stdlib_${ci}$hbgvd - public :: stdlib_${ci}$hbgvx - public :: stdlib_${ci}$hbtrd - public :: stdlib_${ci}$hecon - public :: stdlib_${ci}$hecon_rook - public :: stdlib_${ci}$heequb - public :: stdlib_${ci}$heev - public :: stdlib_${ci}$heevd - public :: stdlib_${ci}$heevr - public :: stdlib_${ci}$heevx - public :: stdlib_${ci}$hegs2 - public :: stdlib_${ci}$hegst - public :: stdlib_${ci}$hegv - public :: stdlib_${ci}$hegvd - public :: stdlib_${ci}$hegvx - public :: stdlib_${ci}$herfs - public :: stdlib_${ci}$hesv - public :: stdlib_${ci}$hesv_aa - public :: stdlib_${ci}$hesv_rk - public :: stdlib_${ci}$hesv_rook - public :: stdlib_${ci}$hesvx - public :: stdlib_${ci}$heswapr - public :: stdlib_${ci}$hetd2 - public :: stdlib_${ci}$hetf2 - public :: stdlib_${ci}$hetf2_rk - public :: stdlib_${ci}$hetf2_rook - public :: stdlib_${ci}$hetrd - public :: stdlib_${ci}$hetrd_hb2st - public :: stdlib_${ci}$hetrd_he2hb - public :: stdlib_${ci}$hetrf - public :: stdlib_${ci}$hetrf_aa - public :: stdlib_${ci}$hetrf_rk - public :: stdlib_${ci}$hetrf_rook - public :: stdlib_${ci}$hetri - public :: stdlib_${ci}$hetri_rook - public :: stdlib_${ci}$hetrs - public :: stdlib_${ci}$hetrs2 - public :: stdlib_${ci}$hetrs_3 - public :: stdlib_${ci}$hetrs_aa - public :: stdlib_${ci}$hetrs_rook - public :: stdlib_${ci}$hfrk - public :: stdlib_${ci}$hgeqz - public :: stdlib_${ci}$hpcon - public :: stdlib_${ci}$hpev - public :: stdlib_${ci}$hpevd - public :: stdlib_${ci}$hpevx - public :: stdlib_${ci}$hpgst - public :: stdlib_${ci}$hpgv - public :: stdlib_${ci}$hpgvd - public :: stdlib_${ci}$hpgvx - public :: stdlib_${ci}$hprfs - public :: stdlib_${ci}$hpsv - public :: stdlib_${ci}$hpsvx - public :: stdlib_${ci}$hptrd - public :: stdlib_${ci}$hptrf - public :: stdlib_${ci}$hptri - public :: stdlib_${ci}$hptrs - public :: stdlib_${ci}$hsein - public :: stdlib_${ci}$hseqr - public :: stdlib_${ci}$la_gbamv - public :: stdlib_${ci}$la_gbrcond_c - public :: stdlib_${ci}$la_gbrpvgrw - public :: stdlib_${ci}$la_geamv - public :: stdlib_${ci}$la_gercond_c - public :: stdlib_${ci}$la_gerpvgrw - public :: stdlib_${ci}$la_heamv - public :: stdlib_${ci}$la_hercond_c - public :: stdlib_${ci}$la_herpvgrw - public :: stdlib_${ci}$la_lin_berr - public :: stdlib_${ci}$la_porcond_c - public :: stdlib_${ci}$la_porpvgrw - public :: stdlib_${ci}$la_syamv - public :: stdlib_${ci}$la_syrcond_c - public :: stdlib_${ci}$la_syrpvgrw - public :: stdlib_${ci}$la_wwaddw - public :: stdlib_${ci}$labrd - public :: stdlib_${ci}$lacgv - public :: stdlib_${ci}$lacn2 - public :: stdlib_${ci}$lacon - public :: stdlib_${ci}$lacp2 - public :: stdlib_${ci}$lacpy - public :: stdlib_${ci}$lacrm - public :: stdlib_${ci}$lacrt - public :: stdlib_${ci}$ladiv - public :: stdlib_${ci}$laed0 - public :: stdlib_${ci}$laed7 - public :: stdlib_${ci}$laed8 - public :: stdlib_${ci}$laein - public :: stdlib_${ci}$laesy - public :: stdlib_${ci}$laev2 - public :: stdlib_${ci}$lag2c - public :: stdlib_${ci}$lags2 - public :: stdlib_${ci}$lagtm - public :: stdlib_${ci}$lahef - public :: stdlib_${ci}$lahef_aa - public :: stdlib_${ci}$lahef_rk - public :: stdlib_${ci}$lahef_rook - public :: stdlib_${ci}$lahqr - public :: stdlib_${ci}$lahr2 - public :: stdlib_${ci}$laic1 - public :: stdlib_${ci}$lals0 - public :: stdlib_${ci}$lalsa - public :: stdlib_${ci}$lalsd - public :: stdlib_${ci}$lamswlq - public :: stdlib_${ci}$lamtsqr - public :: stdlib_${ci}$langb - public :: stdlib_${ci}$lange - public :: stdlib_${ci}$langt - public :: stdlib_${ci}$lanhb - public :: stdlib_${ci}$lanhe - public :: stdlib_${ci}$lanhf - public :: stdlib_${ci}$lanhp - public :: stdlib_${ci}$lanhs - public :: stdlib_${ci}$lanht - public :: stdlib_${ci}$lansb - public :: stdlib_${ci}$lansp - public :: stdlib_${ci}$lansy - public :: stdlib_${ci}$lantb - public :: stdlib_${ci}$lantp - public :: stdlib_${ci}$lantr - public :: stdlib_${ci}$lapll - public :: stdlib_${ci}$lapmr - public :: stdlib_${ci}$lapmt - public :: stdlib_${ci}$laqgb - public :: stdlib_${ci}$laqge - public :: stdlib_${ci}$laqhb - public :: stdlib_${ci}$laqhe - public :: stdlib_${ci}$laqhp - public :: stdlib_${ci}$laqp2 - public :: stdlib_${ci}$laqps - public :: stdlib_${ci}$laqr0 - public :: stdlib_${ci}$laqr1 - public :: stdlib_${ci}$laqr2 - public :: stdlib_${ci}$laqr3 - public :: stdlib_${ci}$laqr4 - public :: stdlib_${ci}$laqr5 - public :: stdlib_${ci}$laqsb - public :: stdlib_${ci}$laqsp - public :: stdlib_${ci}$laqsy - public :: stdlib_${ci}$laqz0 - public :: stdlib_${ci}$laqz1 - public :: stdlib_${ci}$laqz2 - public :: stdlib_${ci}$laqz3 - public :: stdlib_${ci}$lar1v - public :: stdlib_${ci}$lar2v - public :: stdlib_${ci}$larcm - public :: stdlib_${ci}$larf - public :: stdlib_${ci}$larfb - public :: stdlib_${ci}$larfb_gett - public :: stdlib_${ci}$larfg - public :: stdlib_${ci}$larfgp - public :: stdlib_${ci}$larft - public :: stdlib_${ci}$larfx - public :: stdlib_${ci}$larfy - public :: stdlib_${ci}$largv - public :: stdlib_${ci}$larnv - public :: stdlib_${ci}$larrv - public :: stdlib_${ci}$lartg - public :: stdlib_${ci}$lartv - public :: stdlib_${ci}$larz - public :: stdlib_${ci}$larzb - public :: stdlib_${ci}$larzt - public :: stdlib_${ci}$lascl - public :: stdlib_${ci}$laset - public :: stdlib_${ci}$lasr - public :: stdlib_${ci}$lassq - public :: stdlib_${ci}$laswlq - public :: stdlib_${ci}$laswp - public :: stdlib_${ci}$lasyf - public :: stdlib_${ci}$lasyf_aa - public :: stdlib_${ci}$lasyf_rk - public :: stdlib_${ci}$lasyf_rook - public :: stdlib_${ci}$lat2c - public :: stdlib_${ci}$latbs - public :: stdlib_${ci}$latdf - public :: stdlib_${ci}$latps - public :: stdlib_${ci}$latrd - public :: stdlib_${ci}$latrs - public :: stdlib_${ci}$latrz - public :: stdlib_${ci}$latsqr - public :: stdlib_${ci}$launhr_col_getrfnp - public :: stdlib_${ci}$launhr_col_getrfnp2 - public :: stdlib_${ci}$lauu2 - public :: stdlib_${ci}$lauum - public :: stdlib_${ci}$pbcon - public :: stdlib_${ci}$pbequ - public :: stdlib_${ci}$pbrfs - public :: stdlib_${ci}$pbstf - public :: stdlib_${ci}$pbsv - public :: stdlib_${ci}$pbsvx - public :: stdlib_${ci}$pbtf2 - public :: stdlib_${ci}$pbtrf - public :: stdlib_${ci}$pbtrs - public :: stdlib_${ci}$pftrf - public :: stdlib_${ci}$pftri - public :: stdlib_${ci}$pftrs - public :: stdlib_${ci}$pocon - public :: stdlib_${ci}$poequ - public :: stdlib_${ci}$poequb - public :: stdlib_${ci}$porfs - public :: stdlib_${ci}$posv - public :: stdlib_${ci}$posvx - public :: stdlib_${ci}$potf2 - public :: stdlib_${ci}$potrf - public :: stdlib_${ci}$potrf2 - public :: stdlib_${ci}$potri - public :: stdlib_${ci}$potrs - public :: stdlib_${ci}$ppcon - public :: stdlib_${ci}$ppequ - public :: stdlib_${ci}$pprfs - public :: stdlib_${ci}$ppsv - public :: stdlib_${ci}$ppsvx - public :: stdlib_${ci}$pptrf - public :: stdlib_${ci}$pptri - public :: stdlib_${ci}$pptrs - public :: stdlib_${ci}$pstf2 - public :: stdlib_${ci}$pstrf - public :: stdlib_${ci}$ptcon - public :: stdlib_${ci}$pteqr - public :: stdlib_${ci}$ptrfs - public :: stdlib_${ci}$ptsv - public :: stdlib_${ci}$ptsvx - public :: stdlib_${ci}$pttrf - public :: stdlib_${ci}$pttrs - public :: stdlib_${ci}$ptts2 - public :: stdlib_${ci}$rot - public :: stdlib_${ci}$spcon - public :: stdlib_${ci}$spmv - public :: stdlib_${ci}$spr - public :: stdlib_${ci}$sprfs - public :: stdlib_${ci}$spsv - public :: stdlib_${ci}$spsvx - public :: stdlib_${ci}$sptrf - public :: stdlib_${ci}$sptri - public :: stdlib_${ci}$sptrs - public :: stdlib_${ci}$stedc - public :: stdlib_${ci}$stegr - public :: stdlib_${ci}$stein - public :: stdlib_${ci}$stemr - public :: stdlib_${ci}$steqr - public :: stdlib_${ci}$sycon - public :: stdlib_${ci}$sycon_rook - public :: stdlib_${ci}$syconv - public :: stdlib_${ci}$syconvf - public :: stdlib_${ci}$syconvf_rook - public :: stdlib_${ci}$syequb - public :: stdlib_${ci}$symv - public :: stdlib_${ci}$syr - public :: stdlib_${ci}$syrfs - public :: stdlib_${ci}$sysv - public :: stdlib_${ci}$sysv_aa - public :: stdlib_${ci}$sysv_rk - public :: stdlib_${ci}$sysv_rook - public :: stdlib_${ci}$sysvx - public :: stdlib_${ci}$syswapr - public :: stdlib_${ci}$sytf2 - public :: stdlib_${ci}$sytf2_rk - public :: stdlib_${ci}$sytf2_rook - public :: stdlib_${ci}$sytrf - public :: stdlib_${ci}$sytrf_aa - public :: stdlib_${ci}$sytrf_rk - public :: stdlib_${ci}$sytrf_rook - public :: stdlib_${ci}$sytri - public :: stdlib_${ci}$sytri_rook - public :: stdlib_${ci}$sytrs - public :: stdlib_${ci}$sytrs2 - public :: stdlib_${ci}$sytrs_3 - public :: stdlib_${ci}$sytrs_aa - public :: stdlib_${ci}$sytrs_rook - public :: stdlib_${ci}$tbcon - public :: stdlib_${ci}$tbrfs - public :: stdlib_${ci}$tbtrs - public :: stdlib_${ci}$tfsm - public :: stdlib_${ci}$tftri - public :: stdlib_${ci}$tfttp - public :: stdlib_${ci}$tfttr - public :: stdlib_${ci}$tgevc - public :: stdlib_${ci}$tgex2 - public :: stdlib_${ci}$tgexc - public :: stdlib_${ci}$tgsen - public :: stdlib_${ci}$tgsja - public :: stdlib_${ci}$tgsna - public :: stdlib_${ci}$tgsy2 - public :: stdlib_${ci}$tgsyl - public :: stdlib_${ci}$tpcon - public :: stdlib_${ci}$tplqt - public :: stdlib_${ci}$tplqt2 - public :: stdlib_${ci}$tpmlqt - public :: stdlib_${ci}$tpmqrt - public :: stdlib_${ci}$tpqrt - public :: stdlib_${ci}$tpqrt2 - public :: stdlib_${ci}$tprfb - public :: stdlib_${ci}$tprfs - public :: stdlib_${ci}$tptri - public :: stdlib_${ci}$tptrs - public :: stdlib_${ci}$tpttf - public :: stdlib_${ci}$tpttr - public :: stdlib_${ci}$trcon - public :: stdlib_${ci}$trevc - public :: stdlib_${ci}$trevc3 - public :: stdlib_${ci}$trexc - public :: stdlib_${ci}$trrfs - public :: stdlib_${ci}$trsen - public :: stdlib_${ci}$trsna - public :: stdlib_${ci}$trsyl - public :: stdlib_${ci}$trti2 - public :: stdlib_${ci}$trtri - public :: stdlib_${ci}$trtrs - public :: stdlib_${ci}$trttf - public :: stdlib_${ci}$trttp - public :: stdlib_${ci}$tzrzf - public :: stdlib_${ci}$unbdb - public :: stdlib_${ci}$unbdb1 - public :: stdlib_${ci}$unbdb2 - public :: stdlib_${ci}$unbdb3 - public :: stdlib_${ci}$unbdb4 - public :: stdlib_${ci}$unbdb5 - public :: stdlib_${ci}$unbdb6 - public :: stdlib_${ci}$uncsd - public :: stdlib_${ci}$uncsd2by1 - public :: stdlib_${ci}$ung2l - public :: stdlib_${ci}$ung2r - public :: stdlib_${ci}$ungbr - public :: stdlib_${ci}$unghr - public :: stdlib_${ci}$ungl2 - public :: stdlib_${ci}$unglq - public :: stdlib_${ci}$ungql - public :: stdlib_${ci}$ungqr - public :: stdlib_${ci}$ungr2 - public :: stdlib_${ci}$ungrq - public :: stdlib_${ci}$ungtr - public :: stdlib_${ci}$ungtsqr - public :: stdlib_${ci}$ungtsqr_row - public :: stdlib_${ci}$unhr_col - public :: stdlib_${ci}$unm22 - public :: stdlib_${ci}$unm2l - public :: stdlib_${ci}$unm2r - public :: stdlib_${ci}$unmbr - public :: stdlib_${ci}$unmhr - public :: stdlib_${ci}$unml2 - public :: stdlib_${ci}$unmlq - public :: stdlib_${ci}$unmql - public :: stdlib_${ci}$unmqr - public :: stdlib_${ci}$unmr2 - public :: stdlib_${ci}$unmr3 - public :: stdlib_${ci}$unmrq - public :: stdlib_${ci}$unmrz - public :: stdlib_${ci}$unmtr - public :: stdlib_${ci}$upgtr - public :: stdlib_${ci}$upmtr + public :: sp,dp,${ck}$,lk,ilp,ilp64 + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + public :: stdlib${ii}$_${ci}$lag2w + public :: stdlib${ii}$_${ci}$bbcsd + public :: stdlib${ii}$_${ci}$bdsqr + public :: stdlib${ii}$_${ci}$cgesv + public :: stdlib${ii}$_${ci}$cposv + public :: stdlib${ii}$_${ci}$drscl + public :: stdlib${ii}$_${ci}$gbbrd + public :: stdlib${ii}$_${ci}$gbcon + public :: stdlib${ii}$_${ci}$gbequ + public :: stdlib${ii}$_${ci}$gbequb + public :: stdlib${ii}$_${ci}$gbrfs + public :: stdlib${ii}$_${ci}$gbsv + public :: stdlib${ii}$_${ci}$gbsvx + public :: stdlib${ii}$_${ci}$gbtf2 + public :: stdlib${ii}$_${ci}$gbtrf + public :: stdlib${ii}$_${ci}$gbtrs + public :: stdlib${ii}$_${ci}$gebak + public :: stdlib${ii}$_${ci}$gebal + public :: stdlib${ii}$_${ci}$gebd2 + public :: stdlib${ii}$_${ci}$gebrd + public :: stdlib${ii}$_${ci}$gecon + public :: stdlib${ii}$_${ci}$geequ + public :: stdlib${ii}$_${ci}$geequb + public :: stdlib${ii}$_${ci}$gees + public :: stdlib${ii}$_${ci}$geesx + public :: stdlib${ii}$_${ci}$geev + public :: stdlib${ii}$_${ci}$geevx + public :: stdlib${ii}$_${ci}$gehd2 + public :: stdlib${ii}$_${ci}$gehrd + public :: stdlib${ii}$_${ci}$gejsv + public :: stdlib${ii}$_${ci}$gelq + public :: stdlib${ii}$_${ci}$gelq2 + public :: stdlib${ii}$_${ci}$gelqf + public :: stdlib${ii}$_${ci}$gelqt + public :: stdlib${ii}$_${ci}$gelqt3 + public :: stdlib${ii}$_${ci}$gels + public :: stdlib${ii}$_${ci}$gelsd + public :: stdlib${ii}$_${ci}$gelss + public :: stdlib${ii}$_${ci}$gelsy + public :: stdlib${ii}$_${ci}$gemlq + public :: stdlib${ii}$_${ci}$gemlqt + public :: stdlib${ii}$_${ci}$gemqr + public :: stdlib${ii}$_${ci}$gemqrt + public :: stdlib${ii}$_${ci}$geql2 + public :: stdlib${ii}$_${ci}$geqlf + public :: stdlib${ii}$_${ci}$geqp3 + public :: stdlib${ii}$_${ci}$geqr + public :: stdlib${ii}$_${ci}$geqr2 + public :: stdlib${ii}$_${ci}$geqr2p + public :: stdlib${ii}$_${ci}$geqrf + public :: stdlib${ii}$_${ci}$geqrfp + public :: stdlib${ii}$_${ci}$geqrt + public :: stdlib${ii}$_${ci}$geqrt2 + public :: stdlib${ii}$_${ci}$geqrt3 + public :: stdlib${ii}$_${ci}$gerfs + public :: stdlib${ii}$_${ci}$gerq2 + public :: stdlib${ii}$_${ci}$gerqf + public :: stdlib${ii}$_${ci}$gesc2 + public :: stdlib${ii}$_${ci}$gesdd + public :: stdlib${ii}$_${ci}$gesv + public :: stdlib${ii}$_${ci}$gesvd + public :: stdlib${ii}$_${ci}$gesvdq + public :: stdlib${ii}$_${ci}$gesvj + public :: stdlib${ii}$_${ci}$gesvx + public :: stdlib${ii}$_${ci}$getc2 + public :: stdlib${ii}$_${ci}$getf2 + public :: stdlib${ii}$_${ci}$getrf + public :: stdlib${ii}$_${ci}$getrf2 + public :: stdlib${ii}$_${ci}$getri + public :: stdlib${ii}$_${ci}$getrs + public :: stdlib${ii}$_${ci}$getsls + public :: stdlib${ii}$_${ci}$getsqrhrt + public :: stdlib${ii}$_${ci}$ggbak + public :: stdlib${ii}$_${ci}$ggbal + public :: stdlib${ii}$_${ci}$gges + public :: stdlib${ii}$_${ci}$gges3 + public :: stdlib${ii}$_${ci}$ggesx + public :: stdlib${ii}$_${ci}$ggev + public :: stdlib${ii}$_${ci}$ggev3 + public :: stdlib${ii}$_${ci}$ggevx + public :: stdlib${ii}$_${ci}$ggglm + public :: stdlib${ii}$_${ci}$gghd3 + public :: stdlib${ii}$_${ci}$gghrd + public :: stdlib${ii}$_${ci}$gglse + public :: stdlib${ii}$_${ci}$ggqrf + public :: stdlib${ii}$_${ci}$ggrqf + public :: stdlib${ii}$_${ci}$gsvj0 + public :: stdlib${ii}$_${ci}$gsvj1 + public :: stdlib${ii}$_${ci}$gtcon + public :: stdlib${ii}$_${ci}$gtrfs + public :: stdlib${ii}$_${ci}$gtsv + public :: stdlib${ii}$_${ci}$gtsvx + public :: stdlib${ii}$_${ci}$gttrf + public :: stdlib${ii}$_${ci}$gttrs + public :: stdlib${ii}$_${ci}$gtts2 + public :: stdlib${ii}$_${ci}$hb2st_kernels + public :: stdlib${ii}$_${ci}$hbev + public :: stdlib${ii}$_${ci}$hbevd + public :: stdlib${ii}$_${ci}$hbevx + public :: stdlib${ii}$_${ci}$hbgst + public :: stdlib${ii}$_${ci}$hbgv + public :: stdlib${ii}$_${ci}$hbgvd + public :: stdlib${ii}$_${ci}$hbgvx + public :: stdlib${ii}$_${ci}$hbtrd + public :: stdlib${ii}$_${ci}$hecon + public :: stdlib${ii}$_${ci}$hecon_rook + public :: stdlib${ii}$_${ci}$heequb + public :: stdlib${ii}$_${ci}$heev + public :: stdlib${ii}$_${ci}$heevd + public :: stdlib${ii}$_${ci}$heevr + public :: stdlib${ii}$_${ci}$heevx + public :: stdlib${ii}$_${ci}$hegs2 + public :: stdlib${ii}$_${ci}$hegst + public :: stdlib${ii}$_${ci}$hegv + public :: stdlib${ii}$_${ci}$hegvd + public :: stdlib${ii}$_${ci}$hegvx + public :: stdlib${ii}$_${ci}$herfs + public :: stdlib${ii}$_${ci}$hesv + public :: stdlib${ii}$_${ci}$hesv_aa + public :: stdlib${ii}$_${ci}$hesv_rk + public :: stdlib${ii}$_${ci}$hesv_rook + public :: stdlib${ii}$_${ci}$hesvx + public :: stdlib${ii}$_${ci}$heswapr + public :: stdlib${ii}$_${ci}$hetd2 + public :: stdlib${ii}$_${ci}$hetf2 + public :: stdlib${ii}$_${ci}$hetf2_rk + public :: stdlib${ii}$_${ci}$hetf2_rook + public :: stdlib${ii}$_${ci}$hetrd + public :: stdlib${ii}$_${ci}$hetrd_hb2st + public :: stdlib${ii}$_${ci}$hetrd_he2hb + public :: stdlib${ii}$_${ci}$hetrf + public :: stdlib${ii}$_${ci}$hetrf_aa + public :: stdlib${ii}$_${ci}$hetrf_rk + public :: stdlib${ii}$_${ci}$hetrf_rook + public :: stdlib${ii}$_${ci}$hetri + public :: stdlib${ii}$_${ci}$hetri_rook + public :: stdlib${ii}$_${ci}$hetrs + public :: stdlib${ii}$_${ci}$hetrs2 + public :: stdlib${ii}$_${ci}$hetrs_3 + public :: stdlib${ii}$_${ci}$hetrs_aa + public :: stdlib${ii}$_${ci}$hetrs_rook + public :: stdlib${ii}$_${ci}$hfrk + public :: stdlib${ii}$_${ci}$hgeqz + public :: stdlib${ii}$_${ci}$hpcon + public :: stdlib${ii}$_${ci}$hpev + public :: stdlib${ii}$_${ci}$hpevd + public :: stdlib${ii}$_${ci}$hpevx + public :: stdlib${ii}$_${ci}$hpgst + public :: stdlib${ii}$_${ci}$hpgv + public :: stdlib${ii}$_${ci}$hpgvd + public :: stdlib${ii}$_${ci}$hpgvx + public :: stdlib${ii}$_${ci}$hprfs + public :: stdlib${ii}$_${ci}$hpsv + public :: stdlib${ii}$_${ci}$hpsvx + public :: stdlib${ii}$_${ci}$hptrd + public :: stdlib${ii}$_${ci}$hptrf + public :: stdlib${ii}$_${ci}$hptri + public :: stdlib${ii}$_${ci}$hptrs + public :: stdlib${ii}$_${ci}$hsein + public :: stdlib${ii}$_${ci}$hseqr + public :: stdlib${ii}$_${ci}$la_gbamv + public :: stdlib${ii}$_${ci}$la_gbrcond_c + public :: stdlib${ii}$_${ci}$la_gbrpvgrw + public :: stdlib${ii}$_${ci}$la_geamv + public :: stdlib${ii}$_${ci}$la_gercond_c + public :: stdlib${ii}$_${ci}$la_gerpvgrw + public :: stdlib${ii}$_${ci}$la_heamv + public :: stdlib${ii}$_${ci}$la_hercond_c + public :: stdlib${ii}$_${ci}$la_herpvgrw + public :: stdlib${ii}$_${ci}$la_lin_berr + public :: stdlib${ii}$_${ci}$la_porcond_c + public :: stdlib${ii}$_${ci}$la_porpvgrw + public :: stdlib${ii}$_${ci}$la_syamv + public :: stdlib${ii}$_${ci}$la_syrcond_c + public :: stdlib${ii}$_${ci}$la_syrpvgrw + public :: stdlib${ii}$_${ci}$la_wwaddw + public :: stdlib${ii}$_${ci}$labrd + public :: stdlib${ii}$_${ci}$lacgv + public :: stdlib${ii}$_${ci}$lacn2 + public :: stdlib${ii}$_${ci}$lacon + public :: stdlib${ii}$_${ci}$lacp2 + public :: stdlib${ii}$_${ci}$lacpy + public :: stdlib${ii}$_${ci}$lacrm + public :: stdlib${ii}$_${ci}$lacrt + public :: stdlib${ii}$_${ci}$ladiv + public :: stdlib${ii}$_${ci}$laed0 + public :: stdlib${ii}$_${ci}$laed7 + public :: stdlib${ii}$_${ci}$laed8 + public :: stdlib${ii}$_${ci}$laein + public :: stdlib${ii}$_${ci}$laesy + public :: stdlib${ii}$_${ci}$laev2 + public :: stdlib${ii}$_${ci}$lag2c + public :: stdlib${ii}$_${ci}$lags2 + public :: stdlib${ii}$_${ci}$lagtm + public :: stdlib${ii}$_${ci}$lahef + public :: stdlib${ii}$_${ci}$lahef_aa + public :: stdlib${ii}$_${ci}$lahef_rk + public :: stdlib${ii}$_${ci}$lahef_rook + public :: stdlib${ii}$_${ci}$lahqr + public :: stdlib${ii}$_${ci}$lahr2 + public :: stdlib${ii}$_${ci}$laic1 + public :: stdlib${ii}$_${ci}$lals0 + public :: stdlib${ii}$_${ci}$lalsa + public :: stdlib${ii}$_${ci}$lalsd + public :: stdlib${ii}$_${ci}$lamswlq + public :: stdlib${ii}$_${ci}$lamtsqr + public :: stdlib${ii}$_${ci}$langb + public :: stdlib${ii}$_${ci}$lange + public :: stdlib${ii}$_${ci}$langt + public :: stdlib${ii}$_${ci}$lanhb + public :: stdlib${ii}$_${ci}$lanhe + public :: stdlib${ii}$_${ci}$lanhf + public :: stdlib${ii}$_${ci}$lanhp + public :: stdlib${ii}$_${ci}$lanhs + public :: stdlib${ii}$_${ci}$lanht + public :: stdlib${ii}$_${ci}$lansb + public :: stdlib${ii}$_${ci}$lansp + public :: stdlib${ii}$_${ci}$lansy + public :: stdlib${ii}$_${ci}$lantb + public :: stdlib${ii}$_${ci}$lantp + public :: stdlib${ii}$_${ci}$lantr + public :: stdlib${ii}$_${ci}$lapll + public :: stdlib${ii}$_${ci}$lapmr + public :: stdlib${ii}$_${ci}$lapmt + public :: stdlib${ii}$_${ci}$laqgb + public :: stdlib${ii}$_${ci}$laqge + public :: stdlib${ii}$_${ci}$laqhb + public :: stdlib${ii}$_${ci}$laqhe + public :: stdlib${ii}$_${ci}$laqhp + public :: stdlib${ii}$_${ci}$laqp2 + public :: stdlib${ii}$_${ci}$laqps + public :: stdlib${ii}$_${ci}$laqr0 + public :: stdlib${ii}$_${ci}$laqr1 + public :: stdlib${ii}$_${ci}$laqr2 + public :: stdlib${ii}$_${ci}$laqr3 + public :: stdlib${ii}$_${ci}$laqr4 + public :: stdlib${ii}$_${ci}$laqr5 + public :: stdlib${ii}$_${ci}$laqsb + public :: stdlib${ii}$_${ci}$laqsp + public :: stdlib${ii}$_${ci}$laqsy + public :: stdlib${ii}$_${ci}$laqz0 + public :: stdlib${ii}$_${ci}$laqz1 + public :: stdlib${ii}$_${ci}$laqz2 + public :: stdlib${ii}$_${ci}$laqz3 + public :: stdlib${ii}$_${ci}$lar1v + public :: stdlib${ii}$_${ci}$lar2v + public :: stdlib${ii}$_${ci}$larcm + public :: stdlib${ii}$_${ci}$larf + public :: stdlib${ii}$_${ci}$larfb + public :: stdlib${ii}$_${ci}$larfb_gett + public :: stdlib${ii}$_${ci}$larfg + public :: stdlib${ii}$_${ci}$larfgp + public :: stdlib${ii}$_${ci}$larft + public :: stdlib${ii}$_${ci}$larfx + public :: stdlib${ii}$_${ci}$larfy + public :: stdlib${ii}$_${ci}$largv + public :: stdlib${ii}$_${ci}$larnv + public :: stdlib${ii}$_${ci}$larrv + public :: stdlib${ii}$_${ci}$lartg + public :: stdlib${ii}$_${ci}$lartv + public :: stdlib${ii}$_${ci}$larz + public :: stdlib${ii}$_${ci}$larzb + public :: stdlib${ii}$_${ci}$larzt + public :: stdlib${ii}$_${ci}$lascl + public :: stdlib${ii}$_${ci}$laset + public :: stdlib${ii}$_${ci}$lasr + public :: stdlib${ii}$_${ci}$lassq + public :: stdlib${ii}$_${ci}$laswlq + public :: stdlib${ii}$_${ci}$laswp + public :: stdlib${ii}$_${ci}$lasyf + public :: stdlib${ii}$_${ci}$lasyf_aa + public :: stdlib${ii}$_${ci}$lasyf_rk + public :: stdlib${ii}$_${ci}$lasyf_rook + public :: stdlib${ii}$_${ci}$lat2c + public :: stdlib${ii}$_${ci}$latbs + public :: stdlib${ii}$_${ci}$latdf + public :: stdlib${ii}$_${ci}$latps + public :: stdlib${ii}$_${ci}$latrd + public :: stdlib${ii}$_${ci}$latrs + public :: stdlib${ii}$_${ci}$latrz + public :: stdlib${ii}$_${ci}$latsqr + public :: stdlib${ii}$_${ci}$launhr_col_getrfnp + public :: stdlib${ii}$_${ci}$launhr_col_getrfnp2 + public :: stdlib${ii}$_${ci}$lauu2 + public :: stdlib${ii}$_${ci}$lauum + public :: stdlib${ii}$_${ci}$pbcon + public :: stdlib${ii}$_${ci}$pbequ + public :: stdlib${ii}$_${ci}$pbrfs + public :: stdlib${ii}$_${ci}$pbstf + public :: stdlib${ii}$_${ci}$pbsv + public :: stdlib${ii}$_${ci}$pbsvx + public :: stdlib${ii}$_${ci}$pbtf2 + public :: stdlib${ii}$_${ci}$pbtrf + public :: stdlib${ii}$_${ci}$pbtrs + public :: stdlib${ii}$_${ci}$pftrf + public :: stdlib${ii}$_${ci}$pftri + public :: stdlib${ii}$_${ci}$pftrs + public :: stdlib${ii}$_${ci}$pocon + public :: stdlib${ii}$_${ci}$poequ + public :: stdlib${ii}$_${ci}$poequb + public :: stdlib${ii}$_${ci}$porfs + public :: stdlib${ii}$_${ci}$posv + public :: stdlib${ii}$_${ci}$posvx + public :: stdlib${ii}$_${ci}$potf2 + public :: stdlib${ii}$_${ci}$potrf + public :: stdlib${ii}$_${ci}$potrf2 + public :: stdlib${ii}$_${ci}$potri + public :: stdlib${ii}$_${ci}$potrs + public :: stdlib${ii}$_${ci}$ppcon + public :: stdlib${ii}$_${ci}$ppequ + public :: stdlib${ii}$_${ci}$pprfs + public :: stdlib${ii}$_${ci}$ppsv + public :: stdlib${ii}$_${ci}$ppsvx + public :: stdlib${ii}$_${ci}$pptrf + public :: stdlib${ii}$_${ci}$pptri + public :: stdlib${ii}$_${ci}$pptrs + public :: stdlib${ii}$_${ci}$pstf2 + public :: stdlib${ii}$_${ci}$pstrf + public :: stdlib${ii}$_${ci}$ptcon + public :: stdlib${ii}$_${ci}$pteqr + public :: stdlib${ii}$_${ci}$ptrfs + public :: stdlib${ii}$_${ci}$ptsv + public :: stdlib${ii}$_${ci}$ptsvx + public :: stdlib${ii}$_${ci}$pttrf + public :: stdlib${ii}$_${ci}$pttrs + public :: stdlib${ii}$_${ci}$ptts2 + public :: stdlib${ii}$_${ci}$rot + public :: stdlib${ii}$_${ci}$spcon + public :: stdlib${ii}$_${ci}$spmv + public :: stdlib${ii}$_${ci}$spr + public :: stdlib${ii}$_${ci}$sprfs + public :: stdlib${ii}$_${ci}$spsv + public :: stdlib${ii}$_${ci}$spsvx + public :: stdlib${ii}$_${ci}$sptrf + public :: stdlib${ii}$_${ci}$sptri + public :: stdlib${ii}$_${ci}$sptrs + public :: stdlib${ii}$_${ci}$stedc + public :: stdlib${ii}$_${ci}$stegr + public :: stdlib${ii}$_${ci}$stein + public :: stdlib${ii}$_${ci}$stemr + public :: stdlib${ii}$_${ci}$steqr + public :: stdlib${ii}$_${ci}$sycon + public :: stdlib${ii}$_${ci}$sycon_rook + public :: stdlib${ii}$_${ci}$syconv + public :: stdlib${ii}$_${ci}$syconvf + public :: stdlib${ii}$_${ci}$syconvf_rook + public :: stdlib${ii}$_${ci}$syequb + public :: stdlib${ii}$_${ci}$symv + public :: stdlib${ii}$_${ci}$syr + public :: stdlib${ii}$_${ci}$syrfs + public :: stdlib${ii}$_${ci}$sysv + public :: stdlib${ii}$_${ci}$sysv_aa + public :: stdlib${ii}$_${ci}$sysv_rk + public :: stdlib${ii}$_${ci}$sysv_rook + public :: stdlib${ii}$_${ci}$sysvx + public :: stdlib${ii}$_${ci}$syswapr + public :: stdlib${ii}$_${ci}$sytf2 + public :: stdlib${ii}$_${ci}$sytf2_rk + public :: stdlib${ii}$_${ci}$sytf2_rook + public :: stdlib${ii}$_${ci}$sytrf + public :: stdlib${ii}$_${ci}$sytrf_aa + public :: stdlib${ii}$_${ci}$sytrf_rk + public :: stdlib${ii}$_${ci}$sytrf_rook + public :: stdlib${ii}$_${ci}$sytri + public :: stdlib${ii}$_${ci}$sytri_rook + public :: stdlib${ii}$_${ci}$sytrs + public :: stdlib${ii}$_${ci}$sytrs2 + public :: stdlib${ii}$_${ci}$sytrs_3 + public :: stdlib${ii}$_${ci}$sytrs_aa + public :: stdlib${ii}$_${ci}$sytrs_rook + public :: stdlib${ii}$_${ci}$tbcon + public :: stdlib${ii}$_${ci}$tbrfs + public :: stdlib${ii}$_${ci}$tbtrs + public :: stdlib${ii}$_${ci}$tfsm + public :: stdlib${ii}$_${ci}$tftri + public :: stdlib${ii}$_${ci}$tfttp + public :: stdlib${ii}$_${ci}$tfttr + public :: stdlib${ii}$_${ci}$tgevc + public :: stdlib${ii}$_${ci}$tgex2 + public :: stdlib${ii}$_${ci}$tgexc + public :: stdlib${ii}$_${ci}$tgsen + public :: stdlib${ii}$_${ci}$tgsja + public :: stdlib${ii}$_${ci}$tgsna + public :: stdlib${ii}$_${ci}$tgsy2 + public :: stdlib${ii}$_${ci}$tgsyl + public :: stdlib${ii}$_${ci}$tpcon + public :: stdlib${ii}$_${ci}$tplqt + public :: stdlib${ii}$_${ci}$tplqt2 + public :: stdlib${ii}$_${ci}$tpmlqt + public :: stdlib${ii}$_${ci}$tpmqrt + public :: stdlib${ii}$_${ci}$tpqrt + public :: stdlib${ii}$_${ci}$tpqrt2 + public :: stdlib${ii}$_${ci}$tprfb + public :: stdlib${ii}$_${ci}$tprfs + public :: stdlib${ii}$_${ci}$tptri + public :: stdlib${ii}$_${ci}$tptrs + public :: stdlib${ii}$_${ci}$tpttf + public :: stdlib${ii}$_${ci}$tpttr + public :: stdlib${ii}$_${ci}$trcon + public :: stdlib${ii}$_${ci}$trevc + public :: stdlib${ii}$_${ci}$trevc3 + public :: stdlib${ii}$_${ci}$trexc + public :: stdlib${ii}$_${ci}$trrfs + public :: stdlib${ii}$_${ci}$trsen + public :: stdlib${ii}$_${ci}$trsna + public :: stdlib${ii}$_${ci}$trsyl + public :: stdlib${ii}$_${ci}$trti2 + public :: stdlib${ii}$_${ci}$trtri + public :: stdlib${ii}$_${ci}$trtrs + public :: stdlib${ii}$_${ci}$trttf + public :: stdlib${ii}$_${ci}$trttp + public :: stdlib${ii}$_${ci}$tzrzf + public :: stdlib${ii}$_${ci}$unbdb + public :: stdlib${ii}$_${ci}$unbdb1 + public :: stdlib${ii}$_${ci}$unbdb2 + public :: stdlib${ii}$_${ci}$unbdb3 + public :: stdlib${ii}$_${ci}$unbdb4 + public :: stdlib${ii}$_${ci}$unbdb5 + public :: stdlib${ii}$_${ci}$unbdb6 + public :: stdlib${ii}$_${ci}$uncsd + public :: stdlib${ii}$_${ci}$uncsd2by1 + public :: stdlib${ii}$_${ci}$ung2l + public :: stdlib${ii}$_${ci}$ung2r + public :: stdlib${ii}$_${ci}$ungbr + public :: stdlib${ii}$_${ci}$unghr + public :: stdlib${ii}$_${ci}$ungl2 + public :: stdlib${ii}$_${ci}$unglq + public :: stdlib${ii}$_${ci}$ungql + public :: stdlib${ii}$_${ci}$ungqr + public :: stdlib${ii}$_${ci}$ungr2 + public :: stdlib${ii}$_${ci}$ungrq + public :: stdlib${ii}$_${ci}$ungtr + public :: stdlib${ii}$_${ci}$ungtsqr + public :: stdlib${ii}$_${ci}$ungtsqr_row + public :: stdlib${ii}$_${ci}$unhr_col + public :: stdlib${ii}$_${ci}$unm22 + public :: stdlib${ii}$_${ci}$unm2l + public :: stdlib${ii}$_${ci}$unm2r + public :: stdlib${ii}$_${ci}$unmbr + public :: stdlib${ii}$_${ci}$unmhr + public :: stdlib${ii}$_${ci}$unml2 + public :: stdlib${ii}$_${ci}$unmlq + public :: stdlib${ii}$_${ci}$unmql + public :: stdlib${ii}$_${ci}$unmqr + public :: stdlib${ii}$_${ci}$unmr2 + public :: stdlib${ii}$_${ci}$unmr3 + public :: stdlib${ii}$_${ci}$unmrq + public :: stdlib${ii}$_${ci}$unmrz + public :: stdlib${ii}$_${ci}$unmtr + public :: stdlib${ii}$_${ci}$upgtr + public :: stdlib${ii}$_${ci}$upmtr + #:endfor ! 128-bit real constants real(${ck}$), parameter, private :: negone = -1.00_${ck}$ @@ -491,7 +492,7 @@ module stdlib_linalg_lapack_${ci}$ real(${ck}$), parameter, private :: rradix = real(radix(zero),${ck}$) real(${ck}$), parameter, private :: ulp = epsilon(zero) real(${ck}$), parameter, private :: eps = ulp*half - real(${ck}$), parameter, private :: safmin = rradix**max(minexp-1,1-maxexp) + real(${ck}$), parameter, private :: safmin = rradix**max(minexp-1,1_${ik}$-maxexp) real(${ck}$), parameter, private :: safmax = one/safmin real(${ck}$), parameter, private :: smlnum = safmin/ulp real(${ck}$), parameter, private :: bignum = safmax*ulp @@ -501,15 +502,15 @@ module stdlib_linalg_lapack_${ci}$ ! 128-bit Blue's scaling constants ! ssml>=1/s and sbig==1/S with s,S as defined in https://doi.org/10.1145/355769.355771 real(${ck}$), parameter, private :: tsml = rradix**ceiling((minexp-1)*half) - real(${ck}$), parameter, private :: tbig = rradix**floor((maxexp-digits(zero)+1)*half) + real(${ck}$), parameter, private :: tbig = rradix**floor((maxexp-digits(zero)+1_${ik}$)*half) real(${ck}$), parameter, private :: ssml = rradix**(-floor((minexp-digits(zero))*half)) - real(${ck}$), parameter, private :: sbig = rradix**(-ceiling((maxexp+digits(zero)-1)*half)) + real(${ck}$), parameter, private :: sbig = rradix**(-ceiling((maxexp+digits(zero)-1_${ik}$)*half)) contains - - pure subroutine stdlib_${ci}$lag2w( m, n, sa, ldsa, a, lda, info ) + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + pure subroutine stdlib${ii}$_${ci}$lag2w( m, n, sa, ldsa, a, lda, info ) !! ZLAG2W: converts a COMPLEX matrix, SA, to a COMPLEX*16 matrix, A. !! Note that while it is possible to overflow while converting !! from double to single, it is not possible to overflow when @@ -519,26 +520,26 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(dp), intent(in) :: sa(ldsa,*) complex(${ck}$), 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_${ci}$lag2w + end subroutine stdlib${ii}$_${ci}$lag2w - pure subroutine stdlib_${ci}$bbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, phi, u1, & + pure subroutine stdlib${ii}$_${ci}$bbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, phi, u1, & !! ZBBCSD: computes the CS decomposition of a unitary matrix in !! bidiagonal-block form, !! [ B11 | B12 0 0 ] @@ -567,8 +568,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobu1, jobu2, jobv1t, jobv2t, trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldu1, ldu2, ldv1t, ldv2t, lrwork, m, p, q + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldu1, ldu2, ldv1t, ldv2t, lrwork, m, p, q ! Array Arguments real(${ck}$), intent(out) :: b11d(*), b11e(*), b12d(*), b12e(*), b21d(*), b21e(*), b22d(*),& b22e(*), rwork(*) @@ -577,18 +578,15 @@ module stdlib_linalg_lapack_${ci}$ ! =================================================================== ! Parameters - integer(ilp), parameter :: maxitr = 6 + integer(${ik}$), parameter :: maxitr = 6_${ik}$ real(${ck}$), parameter :: hundred = 100.0_${ck}$ real(${ck}$), parameter :: meighth = -0.125_${ck}$ real(${ck}$), parameter :: piover2 = 1.57079632679489661923132169163975144210_${ck}$ - - - ! Local Scalars logical(lk) :: colmajor, lquery, restart11, restart12, restart21, restart22, wantu1, & wantu2, wantv1t, wantv2t - integer(ilp) :: i, imin, imax, iter, iu1cs, iu1sn, iu2cs, iu2sn, iv1tcs, iv1tsn, & + integer(${ik}$) :: i, imin, imax, iter, iu1cs, iu1sn, iu2cs, iu2sn, iv1tcs, iv1tsn, & iv2tcs, iv2tsn, j, lrworkmin, lrworkopt, maxit, mini real(${ck}$) :: b11bulge, b12bulge, b21bulge, b22bulge, dummy, eps, mu, nu, r, sigma11, & sigma21, temp, thetamax, thetamin, thresh, tol, tolmul, unfl, x1, x2, y1, y2 @@ -596,39 +594,39 @@ module stdlib_linalg_lapack_${ci}$ intrinsic :: abs,atan2,cos,max,min,sin,sqrt ! Executable Statements ! test input arguments - info = 0 - lquery = lrwork == -1 + info = 0_${ik}$ + lquery = lrwork == -1_${ik}$ wantu1 = stdlib_lsame( jobu1, 'Y' ) wantu2 = stdlib_lsame( jobu2, 'Y' ) wantv1t = stdlib_lsame( jobv1t, 'Y' ) wantv2t = stdlib_lsame( jobv2t, 'Y' ) colmajor = .not. stdlib_lsame( trans, 'T' ) - if( m < 0 ) then - info = -6 - else if( p < 0 .or. p > 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 - lrworkmin = 1 - rwork(1) = lrworkmin + if( info == 0_${ik}$ .and. q == 0_${ik}$ ) then + lrworkmin = 1_${ik}$ + rwork(1_${ik}$) = lrworkmin 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 @@ -636,22 +634,22 @@ module stdlib_linalg_lapack_${ci}$ iv1tsn = iv1tcs + q iv2tcs = iv1tsn + q iv2tsn = iv2tcs + q - lrworkopt = iv2tsn + q - 1 + lrworkopt = iv2tsn + q - 1_${ik}$ lrworkmin = lrworkopt - rwork(1) = lrworkopt + rwork(1_${ik}$) = lrworkopt if( lrwork < lrworkmin .and. .not. lquery ) then - info = -28 + info = -28_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'ZBBCSD', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZBBCSD', -info ) return else if( lquery ) then return end if ! get machine constants - eps = stdlib_${c2ri(ci)}$lamch( 'EPSILON' ) - unfl = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'EPSILON' ) + unfl = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) tolmul = max( ten, min( hundred, eps**meighth ) ) tol = tolmul*eps thresh = max( tol, maxitr*q*q*unfl ) @@ -676,18 +674,18 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -707,9 +705,9 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -733,20 +731,20 @@ module stdlib_linalg_lapack_${ci}$ nu = zero else ! compute shifts for b11 and b21 and use the lesser - call stdlib_${c2ri(ci)}$las2( b11d(imax-1), b11e(imax-1), b11d(imax), sigma11,dummy ) + call stdlib${ii}$_${c2ri(ci)}$las2( b11d(imax-1), b11e(imax-1), b11d(imax), sigma11,dummy ) - call stdlib_${c2ri(ci)}$las2( b21d(imax-1), b21e(imax-1), b21d(imax), sigma21,dummy ) + call stdlib${ii}$_${c2ri(ci)}$las2( 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_${ck}$ - nu**2 ) + mu = sqrt( 1.0_${ck}$ - nu**2_${ik}$ ) if( nu < thresh ) then mu = one nu = zero @@ -755,10 +753,10 @@ module stdlib_linalg_lapack_${ci}$ end if ! rotate to produce bulges in b11 and b21 if( mu <= nu ) then - call stdlib_${c2ri(ci)}$lartgs( b11d(imin), b11e(imin), mu,rwork(iv1tcs+imin-1), rwork(& + call stdlib${ii}$_${c2ri(ci)}$lartgs( b11d(imin), b11e(imin), mu,rwork(iv1tcs+imin-1), rwork(& iv1tsn+imin-1) ) else - call stdlib_${c2ri(ci)}$lartgs( b21d(imin), b21e(imin), nu,rwork(iv1tcs+imin-1), rwork(& + call stdlib${ii}$_${c2ri(ci)}$lartgs( b21d(imin), b21e(imin), nu,rwork(iv1tcs+imin-1), rwork(& iv1tsn+imin-1) ) end if temp = rwork(iv1tcs+imin-1)*b11d(imin) +rwork(iv1tsn+imin-1)*b11e(imin) @@ -774,27 +772,27 @@ module stdlib_linalg_lapack_${ci}$ b21bulge = rwork(iv1tsn+imin-1)*b21d(imin+1) b21d(imin+1) = rwork(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_${c2ri(ci)}$lartgp( b11bulge, b11d(imin), rwork(iu1sn+imin-1),rwork(iu1cs+imin-& - 1), r ) + if( b11d(imin)**2_${ik}$+b11bulge**2_${ik}$ > thresh**2_${ik}$ ) then + call stdlib${ii}$_${c2ri(ci)}$lartgp( b11bulge, b11d(imin), rwork(iu1sn+imin-1),rwork(iu1cs+imin-& + 1_${ik}$), r ) else if( mu <= nu ) then - call stdlib_${c2ri(ci)}$lartgs( b11e( imin ), b11d( imin + 1 ), mu,rwork(iu1cs+imin-1), & + call stdlib${ii}$_${c2ri(ci)}$lartgs( b11e( imin ), b11d( imin + 1_${ik}$ ), mu,rwork(iu1cs+imin-1), & rwork(iu1sn+imin-1) ) else - call stdlib_${c2ri(ci)}$lartgs( b12d( imin ), b12e( imin ), nu,rwork(iu1cs+imin-1), rwork(& + call stdlib${ii}$_${c2ri(ci)}$lartgs( b12d( imin ), b12e( imin ), nu,rwork(iu1cs+imin-1), rwork(& iu1sn+imin-1) ) end if - if( b21d(imin)**2+b21bulge**2 > thresh**2 ) then - call stdlib_${c2ri(ci)}$lartgp( b21bulge, b21d(imin), rwork(iu2sn+imin-1),rwork(iu2cs+imin-& - 1), r ) + if( b21d(imin)**2_${ik}$+b21bulge**2_${ik}$ > thresh**2_${ik}$ ) then + call stdlib${ii}$_${c2ri(ci)}$lartgp( b21bulge, b21d(imin), rwork(iu2sn+imin-1),rwork(iu2cs+imin-& + 1_${ik}$), r ) else if( nu < mu ) then - call stdlib_${c2ri(ci)}$lartgs( b21e( imin ), b21d( imin + 1 ), nu,rwork(iu2cs+imin-1), & + call stdlib${ii}$_${c2ri(ci)}$lartgs( b21e( imin ), b21d( imin + 1_${ik}$ ), nu,rwork(iu2cs+imin-1), & rwork(iu2sn+imin-1) ) else - call stdlib_${c2ri(ci)}$lartgs( b22d(imin), b22e(imin), mu,rwork(iu2cs+imin-1), rwork(iu2sn+& + call stdlib${ii}$_${c2ri(ci)}$lartgs( b22d(imin), b22e(imin), mu,rwork(iu2cs+imin-1), rwork(iu2sn+& imin-1) ) end if rwork(iu2cs+imin-1) = -rwork(iu2cs+imin-1) @@ -834,47 +832,47 @@ module stdlib_linalg_lapack_${ci}$ 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_${c2ri(ci)}$lartgp( x2, x1, rwork(iv1tsn+i-1),rwork(iv1tcs+i-1), r ) + call stdlib${ii}$_${c2ri(ci)}$lartgp( x2, x1, rwork(iv1tsn+i-1),rwork(iv1tcs+i-1), r ) else if( .not. restart11 .and. restart21 ) then - call stdlib_${c2ri(ci)}$lartgp( b11bulge, b11e(i-1), rwork(iv1tsn+i-1),rwork(iv1tcs+i-1),& + call stdlib${ii}$_${c2ri(ci)}$lartgp( b11bulge, b11e(i-1), rwork(iv1tsn+i-1),rwork(iv1tcs+i-1),& r ) else if( restart11 .and. .not. restart21 ) then - call stdlib_${c2ri(ci)}$lartgp( b21bulge, b21e(i-1), rwork(iv1tsn+i-1),rwork(iv1tcs+i-1),& + call stdlib${ii}$_${c2ri(ci)}$lartgp( b21bulge, b21e(i-1), rwork(iv1tsn+i-1),rwork(iv1tcs+i-1),& r ) else if( mu <= nu ) then - call stdlib_${c2ri(ci)}$lartgs( b11d(i), b11e(i), mu, rwork(iv1tcs+i-1),rwork(iv1tsn+i-1)& + call stdlib${ii}$_${c2ri(ci)}$lartgs( b11d(i), b11e(i), mu, rwork(iv1tcs+i-1),rwork(iv1tsn+i-1)& ) else - call stdlib_${c2ri(ci)}$lartgs( b21d(i), b21e(i), nu, rwork(iv1tcs+i-1),rwork(iv1tsn+i-1)& + call stdlib${ii}$_${c2ri(ci)}$lartgs( b21d(i), b21e(i), nu, rwork(iv1tcs+i-1),rwork(iv1tsn+i-1)& ) end if rwork(iv1tcs+i-1) = -rwork(iv1tcs+i-1) rwork(iv1tsn+i-1) = -rwork(iv1tsn+i-1) if( .not. restart12 .and. .not. restart22 ) then - call stdlib_${c2ri(ci)}$lartgp( y2, y1, rwork(iv2tsn+i-1-1),rwork(iv2tcs+i-1-1), r ) + call stdlib${ii}$_${c2ri(ci)}$lartgp( y2, y1, rwork(iv2tsn+i-1-1),rwork(iv2tcs+i-1-1), r ) else if( .not. restart12 .and. restart22 ) then - call stdlib_${c2ri(ci)}$lartgp( b12bulge, b12d(i-1), rwork(iv2tsn+i-1-1),rwork(iv2tcs+i-& - 1-1), r ) + call stdlib${ii}$_${c2ri(ci)}$lartgp( b12bulge, b12d(i-1), rwork(iv2tsn+i-1-1),rwork(iv2tcs+i-& + 1_${ik}$-1), r ) else if( restart12 .and. .not. restart22 ) then - call stdlib_${c2ri(ci)}$lartgp( b22bulge, b22d(i-1), rwork(iv2tsn+i-1-1),rwork(iv2tcs+i-& - 1-1), r ) + call stdlib${ii}$_${c2ri(ci)}$lartgp( b22bulge, b22d(i-1), rwork(iv2tsn+i-1-1),rwork(iv2tcs+i-& + 1_${ik}$-1), r ) else if( nu < mu ) then - call stdlib_${c2ri(ci)}$lartgs( b12e(i-1), b12d(i), nu,rwork(iv2tcs+i-1-1), rwork(iv2tsn+& + call stdlib${ii}$_${c2ri(ci)}$lartgs( b12e(i-1), b12d(i), nu,rwork(iv2tcs+i-1-1), rwork(iv2tsn+& i-1-1) ) else - call stdlib_${c2ri(ci)}$lartgs( b22e(i-1), b22d(i), mu,rwork(iv2tcs+i-1-1), rwork(iv2tsn+& + call stdlib${ii}$_${c2ri(ci)}$lartgs( b22e(i-1), b22d(i), mu,rwork(iv2tcs+i-1-1), rwork(iv2tsn+& i-1-1) ) end if temp = rwork(iv1tcs+i-1)*b11d(i) + rwork(iv1tsn+i-1)*b11e(i) @@ -902,44 +900,44 @@ module stdlib_linalg_lapack_${ci}$ 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_${c2ri(ci)}$lartgp( x2, x1, rwork(iu1sn+i-1), rwork(iu1cs+i-1),r ) + call stdlib${ii}$_${c2ri(ci)}$lartgp( x2, x1, rwork(iu1sn+i-1), rwork(iu1cs+i-1),r ) else if( .not. restart11 .and. restart12 ) then - call stdlib_${c2ri(ci)}$lartgp( b11bulge, b11d(i), rwork(iu1sn+i-1),rwork(iu1cs+i-1), r ) + call stdlib${ii}$_${c2ri(ci)}$lartgp( b11bulge, b11d(i), rwork(iu1sn+i-1),rwork(iu1cs+i-1), r ) else if( restart11 .and. .not. restart12 ) then - call stdlib_${c2ri(ci)}$lartgp( b12bulge, b12e(i-1), rwork(iu1sn+i-1),rwork(iu1cs+i-1), & + call stdlib${ii}$_${c2ri(ci)}$lartgp( b12bulge, b12e(i-1), rwork(iu1sn+i-1),rwork(iu1cs+i-1), & r ) else if( mu <= nu ) then - call stdlib_${c2ri(ci)}$lartgs( b11e(i), b11d(i+1), mu, rwork(iu1cs+i-1),rwork(iu1sn+i-1)& + call stdlib${ii}$_${c2ri(ci)}$lartgs( b11e(i), b11d(i+1), mu, rwork(iu1cs+i-1),rwork(iu1sn+i-1)& ) else - call stdlib_${c2ri(ci)}$lartgs( b12d(i), b12e(i), nu, rwork(iu1cs+i-1),rwork(iu1sn+i-1) ) + call stdlib${ii}$_${c2ri(ci)}$lartgs( b12d(i), b12e(i), nu, rwork(iu1cs+i-1),rwork(iu1sn+i-1) ) end if if( .not. restart21 .and. .not. restart22 ) then - call stdlib_${c2ri(ci)}$lartgp( y2, y1, rwork(iu2sn+i-1), rwork(iu2cs+i-1),r ) + call stdlib${ii}$_${c2ri(ci)}$lartgp( y2, y1, rwork(iu2sn+i-1), rwork(iu2cs+i-1),r ) else if( .not. restart21 .and. restart22 ) then - call stdlib_${c2ri(ci)}$lartgp( b21bulge, b21d(i), rwork(iu2sn+i-1),rwork(iu2cs+i-1), r ) + call stdlib${ii}$_${c2ri(ci)}$lartgp( b21bulge, b21d(i), rwork(iu2sn+i-1),rwork(iu2cs+i-1), r ) else if( restart21 .and. .not. restart22 ) then - call stdlib_${c2ri(ci)}$lartgp( b22bulge, b22e(i-1), rwork(iu2sn+i-1),rwork(iu2cs+i-1), & + call stdlib${ii}$_${c2ri(ci)}$lartgp( b22bulge, b22e(i-1), rwork(iu2sn+i-1),rwork(iu2cs+i-1), & r ) else if( nu < mu ) then - call stdlib_${c2ri(ci)}$lartgs( b21e(i), b21e(i+1), nu, rwork(iu2cs+i-1),rwork(iu2sn+i-1)& + call stdlib${ii}$_${c2ri(ci)}$lartgs( b21e(i), b21e(i+1), nu, rwork(iu2cs+i-1),rwork(iu2sn+i-1)& ) else - call stdlib_${c2ri(ci)}$lartgs( b22d(i), b22e(i), mu, rwork(iu2cs+i-1),rwork(iu2sn+i-1) ) + call stdlib${ii}$_${c2ri(ci)}$lartgs( b22d(i), b22e(i), mu, rwork(iu2cs+i-1),rwork(iu2sn+i-1) ) end if rwork(iu2cs+i-1) = -rwork(iu2cs+i-1) @@ -947,14 +945,14 @@ module stdlib_linalg_lapack_${ci}$ temp = rwork(iu1cs+i-1)*b11e(i) + rwork(iu1sn+i-1)*b11d(i+1) b11d(i+1) = rwork(iu1cs+i-1)*b11d(i+1) -rwork(iu1sn+i-1)*b11e(i) b11e(i) = temp - if( i < imax - 1 ) then + if( i < imax - 1_${ik}$ ) then b11bulge = rwork(iu1sn+i-1)*b11e(i+1) b11e(i+1) = rwork(iu1cs+i-1)*b11e(i+1) end if temp = rwork(iu2cs+i-1)*b21e(i) + rwork(iu2sn+i-1)*b21d(i+1) b21d(i+1) = rwork(iu2cs+i-1)*b21d(i+1) -rwork(iu2sn+i-1)*b21e(i) b21e(i) = temp - if( i < imax - 1 ) then + if( i < imax - 1_${ik}$ ) then b21bulge = rwork(iu2sn+i-1)*b21e(i+1) b21e(i+1) = rwork(iu2cs+i-1)*b21e(i+1) end if @@ -973,24 +971,24 @@ module stdlib_linalg_lapack_${ci}$ 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_${c2ri(ci)}$lartgp( y2, y1, rwork(iv2tsn+imax-1-1),rwork(iv2tcs+imax-1-1), r ) + call stdlib${ii}$_${c2ri(ci)}$lartgp( y2, y1, rwork(iv2tsn+imax-1-1),rwork(iv2tcs+imax-1-1), r ) else if( .not. restart12 .and. restart22 ) then - call stdlib_${c2ri(ci)}$lartgp( b12bulge, b12d(imax-1),rwork(iv2tsn+imax-1-1),rwork(iv2tcs+& + call stdlib${ii}$_${c2ri(ci)}$lartgp( b12bulge, b12d(imax-1),rwork(iv2tsn+imax-1-1),rwork(iv2tcs+& imax-1-1), r ) else if( restart12 .and. .not. restart22 ) then - call stdlib_${c2ri(ci)}$lartgp( b22bulge, b22d(imax-1),rwork(iv2tsn+imax-1-1),rwork(iv2tcs+& + call stdlib${ii}$_${c2ri(ci)}$lartgp( b22bulge, b22d(imax-1),rwork(iv2tsn+imax-1-1),rwork(iv2tcs+& imax-1-1), r ) else if( nu < mu ) then - call stdlib_${c2ri(ci)}$lartgs( b12e(imax-1), b12d(imax), nu,rwork(iv2tcs+imax-1-1),rwork(& + call stdlib${ii}$_${c2ri(ci)}$lartgs( b12e(imax-1), b12d(imax), nu,rwork(iv2tcs+imax-1-1),rwork(& iv2tsn+imax-1-1) ) else - call stdlib_${c2ri(ci)}$lartgs( b22e(imax-1), b22d(imax), mu,rwork(iv2tcs+imax-1-1),rwork(& + call stdlib${ii}$_${c2ri(ci)}$lartgs( b22e(imax-1), b22d(imax), mu,rwork(iv2tcs+imax-1-1),rwork(& iv2tsn+imax-1-1) ) end if temp = rwork(iv2tcs+imax-1-1)*b12e(imax-1) +rwork(iv2tsn+imax-1-1)*b12d(imax) @@ -1006,49 +1004,49 @@ module stdlib_linalg_lapack_${ci}$ ! update singular vectors if( wantu1 ) then if( colmajor ) then - call stdlib_${ci}$lasr( 'R', 'V', 'F', p, imax-imin+1,rwork(iu1cs+imin-1), rwork(& - iu1sn+imin-1),u1(1,imin), ldu1 ) + call stdlib${ii}$_${ci}$lasr( 'R', 'V', 'F', p, imax-imin+1,rwork(iu1cs+imin-1), rwork(& + iu1sn+imin-1),u1(1_${ik}$,imin), ldu1 ) else - call stdlib_${ci}$lasr( 'L', 'V', 'F', imax-imin+1, p,rwork(iu1cs+imin-1), rwork(& - iu1sn+imin-1),u1(imin,1), ldu1 ) + call stdlib${ii}$_${ci}$lasr( 'L', 'V', 'F', imax-imin+1, p,rwork(iu1cs+imin-1), rwork(& + iu1sn+imin-1),u1(imin,1_${ik}$), ldu1 ) end if end if if( wantu2 ) then if( colmajor ) then - call stdlib_${ci}$lasr( 'R', 'V', 'F', m-p, imax-imin+1,rwork(iu2cs+imin-1), rwork(& - iu2sn+imin-1),u2(1,imin), ldu2 ) + call stdlib${ii}$_${ci}$lasr( 'R', 'V', 'F', m-p, imax-imin+1,rwork(iu2cs+imin-1), rwork(& + iu2sn+imin-1),u2(1_${ik}$,imin), ldu2 ) else - call stdlib_${ci}$lasr( 'L', 'V', 'F', imax-imin+1, m-p,rwork(iu2cs+imin-1), rwork(& - iu2sn+imin-1),u2(imin,1), ldu2 ) + call stdlib${ii}$_${ci}$lasr( 'L', 'V', 'F', imax-imin+1, m-p,rwork(iu2cs+imin-1), rwork(& + iu2sn+imin-1),u2(imin,1_${ik}$), ldu2 ) end if end if if( wantv1t ) then if( colmajor ) then - call stdlib_${ci}$lasr( 'L', 'V', 'F', imax-imin+1, q,rwork(iv1tcs+imin-1), rwork(& - iv1tsn+imin-1),v1t(imin,1), ldv1t ) + call stdlib${ii}$_${ci}$lasr( 'L', 'V', 'F', imax-imin+1, q,rwork(iv1tcs+imin-1), rwork(& + iv1tsn+imin-1),v1t(imin,1_${ik}$), ldv1t ) else - call stdlib_${ci}$lasr( 'R', 'V', 'F', q, imax-imin+1,rwork(iv1tcs+imin-1), rwork(& - iv1tsn+imin-1),v1t(1,imin), ldv1t ) + call stdlib${ii}$_${ci}$lasr( 'R', 'V', 'F', q, imax-imin+1,rwork(iv1tcs+imin-1), rwork(& + iv1tsn+imin-1),v1t(1_${ik}$,imin), ldv1t ) end if end if if( wantv2t ) then if( colmajor ) then - call stdlib_${ci}$lasr( 'L', 'V', 'F', imax-imin+1, m-q,rwork(iv2tcs+imin-1), & - rwork(iv2tsn+imin-1),v2t(imin,1), ldv2t ) + call stdlib${ii}$_${ci}$lasr( 'L', 'V', 'F', imax-imin+1, m-q,rwork(iv2tcs+imin-1), & + rwork(iv2tsn+imin-1),v2t(imin,1_${ik}$), ldv2t ) else - call stdlib_${ci}$lasr( 'R', 'V', 'F', m-q, imax-imin+1,rwork(iv2tcs+imin-1), & - rwork(iv2tsn+imin-1),v2t(1,imin), ldv2t ) + call stdlib${ii}$_${ci}$lasr( 'R', 'V', 'F', m-q, imax-imin+1,rwork(iv2tcs+imin-1), & + rwork(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_${ci}$scal( q, cnegone, v1t(imax,1), ldv1t ) + call stdlib${ii}$_${ci}$scal( q, cnegone, v1t(imax,1_${ik}$), ldv1t ) else - call stdlib_${ci}$scal( q, cnegone, v1t(1,imax), 1 ) + call stdlib${ii}$_${ci}$scal( q, cnegone, v1t(1_${ik}$,imax), 1_${ik}$ ) end if end if end if @@ -1058,33 +1056,33 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$scal( p, cnegone, u1(1,imax), 1 ) + call stdlib${ii}$_${ci}$scal( p, cnegone, u1(1_${ik}$,imax), 1_${ik}$ ) else - call stdlib_${ci}$scal( p, cnegone, u1(imax,1), ldu1 ) + call stdlib${ii}$_${ci}$scal( p, cnegone, 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_${ci}$scal( m-p, cnegone, u2(1,imax), 1 ) + call stdlib${ii}$_${ci}$scal( m-p, cnegone, u2(1_${ik}$,imax), 1_${ik}$ ) else - call stdlib_${ci}$scal( m-p, cnegone, u2(imax,1), ldu2 ) + call stdlib${ii}$_${ci}$scal( m-p, cnegone, 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_${ci}$scal( m-q, cnegone, v2t(imax,1), ldv2t ) + call stdlib${ii}$_${ci}$scal( m-q, cnegone, v2t(imax,1_${ik}$), ldv2t ) else - call stdlib_${ci}$scal( m-q, cnegone, v2t(1,imax), 1 ) + call stdlib${ii}$_${ci}$scal( m-q, cnegone, v2t(1_${ik}$,imax), 1_${ik}$ ) end if end if end if @@ -1104,16 +1102,16 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -1133,25 +1131,25 @@ module stdlib_linalg_lapack_${ci}$ theta(mini) = theta(i) theta(i) = thetamin if( colmajor ) then - if( wantu1 )call stdlib_${ci}$swap( p, u1(1,i), 1, u1(1,mini), 1 ) - if( wantu2 )call stdlib_${ci}$swap( m-p, u2(1,i), 1, u2(1,mini), 1 ) - if( wantv1t )call stdlib_${ci}$swap( q, v1t(i,1), ldv1t, v1t(mini,1), ldv1t ) + if( wantu1 )call stdlib${ii}$_${ci}$swap( p, u1(1_${ik}$,i), 1_${ik}$, u1(1_${ik}$,mini), 1_${ik}$ ) + if( wantu2 )call stdlib${ii}$_${ci}$swap( m-p, u2(1_${ik}$,i), 1_${ik}$, u2(1_${ik}$,mini), 1_${ik}$ ) + if( wantv1t )call stdlib${ii}$_${ci}$swap( q, v1t(i,1_${ik}$), ldv1t, v1t(mini,1_${ik}$), ldv1t ) - if( wantv2t )call stdlib_${ci}$swap( m-q, v2t(i,1), ldv2t, v2t(mini,1),ldv2t ) + if( wantv2t )call stdlib${ii}$_${ci}$swap( m-q, v2t(i,1_${ik}$), ldv2t, v2t(mini,1_${ik}$),ldv2t ) else - if( wantu1 )call stdlib_${ci}$swap( p, u1(i,1), ldu1, u1(mini,1), ldu1 ) - if( wantu2 )call stdlib_${ci}$swap( m-p, u2(i,1), ldu2, u2(mini,1), ldu2 ) - if( wantv1t )call stdlib_${ci}$swap( q, v1t(1,i), 1, v1t(1,mini), 1 ) - if( wantv2t )call stdlib_${ci}$swap( m-q, v2t(1,i), 1, v2t(1,mini), 1 ) + if( wantu1 )call stdlib${ii}$_${ci}$swap( p, u1(i,1_${ik}$), ldu1, u1(mini,1_${ik}$), ldu1 ) + if( wantu2 )call stdlib${ii}$_${ci}$swap( m-p, u2(i,1_${ik}$), ldu2, u2(mini,1_${ik}$), ldu2 ) + if( wantv1t )call stdlib${ii}$_${ci}$swap( q, v1t(1_${ik}$,i), 1_${ik}$, v1t(1_${ik}$,mini), 1_${ik}$ ) + if( wantv2t )call stdlib${ii}$_${ci}$swap( m-q, v2t(1_${ik}$,i), 1_${ik}$, v2t(1_${ik}$,mini), 1_${ik}$ ) end if end if end do return - end subroutine stdlib_${ci}$bbcsd + end subroutine stdlib${ii}$_${ci}$bbcsd - pure subroutine stdlib_${ci}$bdsqr( uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u,ldu, c, ldc, rwork,& + pure subroutine stdlib${ii}$_${ci}$bdsqr( uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u,ldu, c, ldc, rwork,& !! ZBDSQR: computes the singular values and, optionally, the right and/or !! left singular vectors from the singular value decomposition (SVD) of !! a real N-by-N (upper or lower) bidiagonal matrix B using the implicit @@ -1182,8 +1180,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: ldc, ldu, ldvt, n, ncc, ncvt, nru + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldc, ldu, ldvt, n, ncc, ncvt, nru ! Array Arguments real(${ck}$), intent(inout) :: d(*), e(*) real(${ck}$), intent(out) :: rwork(*) @@ -1193,7 +1191,7 @@ module stdlib_linalg_lapack_${ci}$ real(${ck}$), parameter :: hndrth = 0.01_${ck}$ real(${ck}$), parameter :: hndrd = 100.0_${ck}$ real(${ck}$), parameter :: meigth = -0.125_${ck}$ - integer(ilp), parameter :: maxitr = 6 + integer(${ik}$), parameter :: maxitr = 6_${ik}$ @@ -1204,7 +1202,7 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: lower, rotate - integer(ilp) :: i, idir, isub, iter, j, ll, lll, m, maxit, nm1, nm12, nm13, oldll, & + integer(${ik}$) :: i, idir, isub, iter, j, ll, lll, m, maxit, nm1, nm12, nm13, oldll, & oldm real(${ck}$) :: abse, abss, cosl, cosr, cs, eps, f, g, h, mu, oldcs, oldsn, r, shift, & sigmn, sigmx, sinl, sinr, sll, smax, smin, sminl, sminoa, sn, thresh, tol, tolmul, & @@ -1213,52 +1211,52 @@ module stdlib_linalg_lapack_${ci}$ intrinsic :: abs,real,max,min,sign,sqrt ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ lower = stdlib_lsame( uplo, 'L' ) if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.lower ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( ncvt<0 ) then - info = -3 - else if( nru<0 ) then - info = -4 - else if( ncc<0 ) then - info = -5 - else if( ( ncvt==0 .and. ldvt<1 ) .or.( ncvt>0 .and. ldvt0 .and. ldc0_${ik}$ .and. ldvt0_${ik}$ .and. ldc0 ) .or. ( nru>0 ) .or. ( ncc>0 ) + rotate = ( ncvt>0_${ik}$ ) .or. ( nru>0_${ik}$ ) .or. ( ncc>0_${ik}$ ) ! if no singular vectors desired, use qd algorithm if( .not.rotate ) then - call stdlib_${c2ri(ci)}$lasq1( n, d, e, rwork, info ) + call stdlib${ii}$_${c2ri(ci)}$lasq1( n, d, e, rwork, info ) ! if info equals 2, dqds didn't finish, try to finish if( info /= 2 ) return - info = 0 + info = 0_${ik}$ end if - nm1 = n - 1 + nm1 = n - 1_${ik}$ nm12 = nm1 + nm1 nm13 = nm12 + nm1 - idir = 0 + idir = 0_${ik}$ ! get machine constants - eps = stdlib_${c2ri(ci)}$lamch( 'EPSILON' ) - unfl = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'EPSILON' ) + unfl = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) ! if matrix lower bidiagonal, rotate to be upper bidiagonal ! by applying givens rotations on the left if( lower ) then do i = 1, n - 1 - call stdlib_${c2ri(ci)}$lartg( d( i ), e( i ), cs, sn, r ) + call stdlib${ii}$_${c2ri(ci)}$lartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) @@ -1266,9 +1264,9 @@ module stdlib_linalg_lapack_${ci}$ rwork( nm1+i ) = sn end do ! update singular vectors if desired - if( nru>0 )call stdlib_${ci}$lasr( 'R', 'V', 'F', nru, n, rwork( 1 ), rwork( n ),u, ldu ) + if( nru>0_${ik}$ )call stdlib${ii}$_${ci}$lasr( 'R', 'V', 'F', nru, n, rwork( 1_${ik}$ ), rwork( n ),u, ldu ) - if( ncc>0 )call stdlib_${ci}$lasr( 'L', 'V', 'F', n, ncc, rwork( 1 ), rwork( n ),c, ldc ) + if( ncc>0_${ik}$ )call stdlib${ii}$_${ci}$lasr( 'L', 'V', 'F', n, ncc, rwork( 1_${ik}$ ), rwork( n ),c, ldc ) end if ! compute singular values to relative accuracy tol @@ -1287,7 +1285,7 @@ module stdlib_linalg_lapack_${ci}$ sminl = zero if( tol>=zero ) then ! relative accuracy desired - sminoa = abs( d( 1 ) ) + sminoa = abs( d( 1_${ik}$ ) ) if( sminoa==zero )go to 50 mu = sminoa do i = 2, n @@ -1306,9 +1304,9 @@ module stdlib_linalg_lapack_${ci}$ ! (maxit is the maximum number of passes through the inner ! loop permitted before nonconvergence signalled.) maxit = maxitr*n*n - iter = 0 - oldll = -1 - oldm = -1 + iter = 0_${ik}$ + oldll = -1_${ik}$ + oldm = -1_${ik}$ ! m points to last element of unconverged part of matrix m = n ! begin main iteration loop @@ -1329,34 +1327,34 @@ module stdlib_linalg_lapack_${ci}$ smin = min( smin, abss ) smax = max( smax, abss, abse ) end do - ll = 0 + ll = 0_${ik}$ go to 90 80 continue e( ll ) = zero ! matrix splits since e(ll) = 0 if( ll==m-1 ) then ! convergence of bottom singular value, return to top of loop - m = m - 1 + m = m - 1_${ik}$ go to 60 end if 90 continue - ll = ll + 1 + ll = ll + 1_${ik}$ ! e(ll) through e(m-1) are nonzero, e(ll-1) is zero if( ll==m-1 ) then ! 2 by 2 block, handle separately - call stdlib_${c2ri(ci)}$lasv2( d( m-1 ), e( m-1 ), d( m ), sigmn, sigmx, sinr,cosr, sinl, cosl & + call stdlib${ii}$_${c2ri(ci)}$lasv2( d( m-1 ), e( m-1 ), d( m ), sigmn, sigmx, sinr,cosr, sinl, cosl & ) d( m-1 ) = sigmx e( m-1 ) = zero d( m ) = sigmn ! compute singular vectors, if desired - if( ncvt>0 )call stdlib_${ci}$drot( ncvt, vt( m-1, 1 ), ldvt, vt( m, 1 ), ldvt,cosr, & + if( ncvt>0_${ik}$ )call stdlib${ii}$_${ci}$drot( ncvt, vt( m-1, 1_${ik}$ ), ldvt, vt( m, 1_${ik}$ ), ldvt,cosr, & sinr ) - if( nru>0 )call stdlib_${ci}$drot( nru, u( 1, m-1 ), 1, u( 1, m ), 1, cosl, sinl ) + if( nru>0_${ik}$ )call stdlib${ii}$_${ci}$drot( nru, u( 1_${ik}$, m-1 ), 1_${ik}$, u( 1_${ik}$, m ), 1_${ik}$, cosl, sinl ) - if( ncc>0 )call stdlib_${ci}$drot( ncc, c( m-1, 1 ), ldc, c( m, 1 ), ldc, cosl,sinl ) + if( ncc>0_${ik}$ )call stdlib${ii}$_${ci}$drot( ncc, c( m-1, 1_${ik}$ ), ldc, c( m, 1_${ik}$ ), ldc, cosl,sinl ) - m = m - 2 + m = m - 2_${ik}$ go to 60 end if ! if working on new submatrix, choose shift direction @@ -1364,14 +1362,14 @@ module stdlib_linalg_lapack_${ci}$ if( ll>oldm .or. m=abs( d( m ) ) ) then ! chase bulge from top (big end) to bottom (small end) - idir = 1 + idir = 1_${ik}$ else ! chase bulge from bottom (big end) to top (small end) - idir = 2 + idir = 2_${ik}$ end if end if ! apply convergence tests - if( idir==1 ) then + if( idir==1_${ik}$ ) then ! run convergence test in forward direction ! first apply standard test to bottom of matrix if( abs( e( m-1 ) )<=abs( tol )*abs( d( m ) ) .or.( tolzero ) then - if( ( shift / sll )**2ll )e( i-1 ) = oldsn*r - call stdlib_${c2ri(ci)}$lartg( oldcs*r, d( i+1 )*sn, oldcs, oldsn, d( i ) ) + call stdlib${ii}$_${c2ri(ci)}$lartg( oldcs*r, d( i+1 )*sn, oldcs, oldsn, d( i ) ) rwork( i-ll+1 ) = cs rwork( i-ll+1+nm1 ) = sn rwork( i-ll+1+nm12 ) = oldcs @@ -1459,12 +1457,12 @@ module stdlib_linalg_lapack_${ci}$ d( m ) = h*oldcs e( m-1 ) = h*oldsn ! update singular vectors - if( ncvt>0 )call stdlib_${ci}$lasr( 'L', 'V', 'F', m-ll+1, ncvt, rwork( 1 ),rwork( n )& - , vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_${ci}$lasr( 'R', 'V', 'F', nru, m-ll+1, rwork( nm12+1 ),rwork( & - nm13+1 ), u( 1, ll ), ldu ) - if( ncc>0 )call stdlib_${ci}$lasr( 'L', 'V', 'F', m-ll+1, ncc, rwork( nm12+1 ),rwork( & - nm13+1 ), c( ll, 1 ), ldc ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_${ci}$lasr( 'L', 'V', 'F', m-ll+1, ncvt, rwork( 1_${ik}$ ),rwork( n )& + , vt( ll, 1_${ik}$ ), ldvt ) + if( nru>0_${ik}$ )call stdlib${ii}$_${ci}$lasr( 'R', 'V', 'F', nru, m-ll+1, rwork( nm12+1 ),rwork( & + nm13+1 ), u( 1_${ik}$, ll ), ldu ) + if( ncc>0_${ik}$ )call stdlib${ii}$_${ci}$lasr( 'L', 'V', 'F', m-ll+1, ncc, rwork( nm12+1 ),rwork( & + nm13+1 ), c( ll, 1_${ik}$ ), ldc ) ! test convergence if( abs( e( m-1 ) )<=thresh )e( m-1 ) = zero else @@ -1473,9 +1471,9 @@ module stdlib_linalg_lapack_${ci}$ cs = one oldcs = one do i = m, ll + 1, -1 - call stdlib_${c2ri(ci)}$lartg( d( i )*cs, e( i-1 ), cs, sn, r ) + call stdlib${ii}$_${c2ri(ci)}$lartg( d( i )*cs, e( i-1 ), cs, sn, r ) if( i0 )call stdlib_${ci}$lasr( 'L', 'V', 'B', m-ll+1, ncvt, rwork( nm12+1 ),& - rwork( nm13+1 ), vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_${ci}$lasr( 'R', 'V', 'B', nru, m-ll+1, rwork( 1 ),rwork( n ), & - u( 1, ll ), ldu ) - if( ncc>0 )call stdlib_${ci}$lasr( 'L', 'V', 'B', m-ll+1, ncc, rwork( 1 ),rwork( n ), & - c( ll, 1 ), ldc ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_${ci}$lasr( 'L', 'V', 'B', m-ll+1, ncvt, rwork( nm12+1 ),& + rwork( nm13+1 ), vt( ll, 1_${ik}$ ), ldvt ) + if( nru>0_${ik}$ )call stdlib${ii}$_${ci}$lasr( 'R', 'V', 'B', nru, m-ll+1, rwork( 1_${ik}$ ),rwork( n ), & + u( 1_${ik}$, ll ), ldu ) + if( ncc>0_${ik}$ )call stdlib${ii}$_${ci}$lasr( 'L', 'V', 'B', m-ll+1, ncc, rwork( 1_${ik}$ ),rwork( n ), & + c( ll, 1_${ik}$ ), ldc ) ! test convergence if( abs( e( ll ) )<=thresh )e( ll ) = zero end if else ! use nonzero shift - if( idir==1 ) then + if( idir==1_${ik}$ ) then ! chase bulge from top to bottom ! save cosines and sines for later singular vector updates f = ( abs( d( ll ) )-shift )*( sign( one, d( ll ) )+shift / d( ll ) ) g = e( ll ) do i = ll, m - 1 - call stdlib_${c2ri(ci)}$lartg( f, g, cosr, sinr, r ) + call stdlib${ii}$_${c2ri(ci)}$lartg( f, g, cosr, sinr, r ) if( i>ll )e( i-1 ) = r f = cosr*d( i ) + sinr*e( i ) e( i ) = cosr*e( i ) - sinr*d( i ) g = sinr*d( i+1 ) d( i+1 ) = cosr*d( i+1 ) - call stdlib_${c2ri(ci)}$lartg( f, g, cosl, sinl, r ) + call stdlib${ii}$_${c2ri(ci)}$lartg( f, g, cosl, sinl, r ) d( i ) = r f = cosl*e( i ) + sinl*d( i+1 ) d( i+1 ) = cosl*d( i+1 ) - sinl*e( i ) @@ -1523,12 +1521,12 @@ module stdlib_linalg_lapack_${ci}$ end do e( m-1 ) = f ! update singular vectors - if( ncvt>0 )call stdlib_${ci}$lasr( 'L', 'V', 'F', m-ll+1, ncvt, rwork( 1 ),rwork( n )& - , vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_${ci}$lasr( 'R', 'V', 'F', nru, m-ll+1, rwork( nm12+1 ),rwork( & - nm13+1 ), u( 1, ll ), ldu ) - if( ncc>0 )call stdlib_${ci}$lasr( 'L', 'V', 'F', m-ll+1, ncc, rwork( nm12+1 ),rwork( & - nm13+1 ), c( ll, 1 ), ldc ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_${ci}$lasr( 'L', 'V', 'F', m-ll+1, ncvt, rwork( 1_${ik}$ ),rwork( n )& + , vt( ll, 1_${ik}$ ), ldvt ) + if( nru>0_${ik}$ )call stdlib${ii}$_${ci}$lasr( 'R', 'V', 'F', nru, m-ll+1, rwork( nm12+1 ),rwork( & + nm13+1 ), u( 1_${ik}$, ll ), ldu ) + if( ncc>0_${ik}$ )call stdlib${ii}$_${ci}$lasr( 'L', 'V', 'F', m-ll+1, ncc, rwork( nm12+1 ),rwork( & + nm13+1 ), c( ll, 1_${ik}$ ), ldc ) ! test convergence if( abs( e( m-1 ) )<=thresh )e( m-1 ) = zero else @@ -1537,13 +1535,13 @@ module stdlib_linalg_lapack_${ci}$ f = ( abs( d( m ) )-shift )*( sign( one, d( m ) )+shift /d( m ) ) g = e( m-1 ) do i = m, ll + 1, -1 - call stdlib_${c2ri(ci)}$lartg( f, g, cosr, sinr, r ) + call stdlib${ii}$_${c2ri(ci)}$lartg( f, g, cosr, sinr, r ) if( i0 )call stdlib_${ci}$lasr( 'L', 'V', 'B', m-ll+1, ncvt, rwork( nm12+1 ),& - rwork( nm13+1 ), vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_${ci}$lasr( 'R', 'V', 'B', nru, m-ll+1, rwork( 1 ),rwork( n ), & - u( 1, ll ), ldu ) - if( ncc>0 )call stdlib_${ci}$lasr( 'L', 'V', 'B', m-ll+1, ncc, rwork( 1 ),rwork( n ), & - c( ll, 1 ), ldc ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_${ci}$lasr( 'L', 'V', 'B', m-ll+1, ncvt, rwork( nm12+1 ),& + rwork( nm13+1 ), vt( ll, 1_${ik}$ ), ldvt ) + if( nru>0_${ik}$ )call stdlib${ii}$_${ci}$lasr( 'R', 'V', 'B', nru, m-ll+1, rwork( 1_${ik}$ ),rwork( n ), & + u( 1_${ik}$, ll ), ldu ) + if( ncc>0_${ik}$ )call stdlib${ii}$_${ci}$lasr( 'L', 'V', 'B', m-ll+1, ncc, rwork( 1_${ik}$ ),rwork( n ), & + c( ll, 1_${ik}$ ), ldc ) end if end if ! qr iteration finished, go back and check convergence @@ -1576,15 +1574,15 @@ module stdlib_linalg_lapack_${ci}$ if( d( i )0 )call stdlib_${ci}$dscal( ncvt, negone, vt( i, 1 ), ldvt ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_${ci}$dscal( ncvt, negone, vt( i, 1_${ik}$ ), ldvt ) end if end do ! sort the singular values into decreasing order (insertion sort on ! singular values, but only one transposition per singular vector) do i = 1, n - 1 ! scan for smallest d(i) - isub = 1 - smin = d( 1 ) + isub = 1_${ik}$ + smin = d( 1_${ik}$ ) do j = 2, n + 1 - i if( d( j )<=smin ) then isub = j @@ -1595,26 +1593,26 @@ module stdlib_linalg_lapack_${ci}$ ! swap singular values and vectors d( isub ) = d( n+1-i ) d( n+1-i ) = smin - if( ncvt>0 )call stdlib_${ci}$swap( ncvt, vt( isub, 1 ), ldvt, vt( n+1-i, 1 ),ldvt ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_${ci}$swap( ncvt, vt( isub, 1_${ik}$ ), ldvt, vt( n+1-i, 1_${ik}$ ),ldvt ) - if( nru>0 )call stdlib_${ci}$swap( nru, u( 1, isub ), 1, u( 1, n+1-i ), 1 ) - if( ncc>0 )call stdlib_${ci}$swap( ncc, c( isub, 1 ), ldc, c( n+1-i, 1 ), ldc ) + if( nru>0_${ik}$ )call stdlib${ii}$_${ci}$swap( nru, u( 1_${ik}$, isub ), 1_${ik}$, u( 1_${ik}$, n+1-i ), 1_${ik}$ ) + if( ncc>0_${ik}$ )call stdlib${ii}$_${ci}$swap( ncc, c( isub, 1_${ik}$ ), ldc, c( n+1-i, 1_${ik}$ ), ldc ) end if end do go to 220 ! maximum number of iterations exceeded, failure to converge 200 continue - info = 0 + info = 0_${ik}$ do i = 1, n - 1 - if( e( i )/=zero )info = info + 1 + if( e( i )/=zero )info = info + 1_${ik}$ end do 220 continue return - end subroutine stdlib_${ci}$bdsqr + end subroutine stdlib${ii}$_${ci}$bdsqr - subroutine stdlib_${ci}$cgesv( n, nrhs, a, lda, ipiv, b, ldb, x, ldx, work,swork, rwork, iter, & + subroutine stdlib${ii}$_${ci}$cgesv( n, nrhs, a, lda, ipiv, b, ldb, x, ldx, work,swork, rwork, iter, & !! ZCGESV: computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N matrix and X and B are N-by-NRHS matrices. @@ -1647,10 +1645,10 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, iter - integer(ilp), intent(in) :: lda, ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info, iter + integer(${ik}$), intent(in) :: lda, ldb, ldx, n, nrhs ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) real(${ck}$), intent(out) :: rwork(*) complex(dp), intent(out) :: swork(*) complex(${ck}$), intent(inout) :: a(lda,*) @@ -1659,14 +1657,14 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! Parameters logical(lk), parameter :: doitref = .true. - integer(ilp), parameter :: itermax = 30 + integer(${ik}$), parameter :: itermax = 30_${ik}$ real(${ck}$), parameter :: bwdmax = 1.0e+00_${ck}$ ! Local Scalars - integer(ilp) :: i, iiter, ptsa, ptsx + integer(${ik}$) :: i, iiter, ptsa, ptsx real(${ck}$) :: anrm, cte, eps, rnrm, xnrm complex(${ck}$) :: zdum ! Intrinsic Functions @@ -1676,22 +1674,22 @@ module stdlib_linalg_lapack_${ci}$ ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements - info = 0 - iter = 0 + info = 0_${ik}$ + iter = 0_${ik}$ ! test the input parameters. - if( n<0 ) then - info = -1 - else if( nrhs<0 ) then - info = -2 - else if( ldaxnrm*cte )go to 10 end do ! if we are here, the nrhs normwise backward errors satisfy the ! stopping criterion. we are good to exit. - iter = 0 + iter = 0_${ik}$ return 10 continue loop_30: do iiter = 1, itermax ! convert r (in work) from quad precision to double precision ! and store the result in sx. - call stdlib_${ci}$lag2c( n, nrhs, work, n, swork( ptsx ), n, info ) - if( info/=0 ) then - iter = -2 + call stdlib${ii}$_${ci}$lag2c( n, nrhs, work, n, swork( ptsx ), n, info ) + if( info/=0_${ik}$ ) then + iter = -2_${ik}$ go to 40 end if ! solve the system sa*sx = sr. - call stdlib_zgetrs( 'NO TRANSPOSE', n, nrhs, swork( ptsa ), n, ipiv,swork( ptsx ), & + call stdlib${ii}$_zgetrs( 'NO TRANSPOSE', n, nrhs, swork( ptsa ), n, ipiv,swork( ptsx ), & n, info ) ! convert sx back to quad precision and update the current ! iterate. - call stdlib_${ci}$lag2w( n, nrhs, swork( ptsx ), n, work, n, info ) + call stdlib${ii}$_${ci}$lag2w( n, nrhs, swork( ptsx ), n, work, n, info ) do i = 1, nrhs - call stdlib_${ci}$axpy( n, cone, work( 1, i ), 1, x( 1, i ), 1 ) + call stdlib${ii}$_${ci}$axpy( n, cone, work( 1_${ik}$, i ), 1_${ik}$, x( 1_${ik}$, i ), 1_${ik}$ ) end do ! compute r = b - ax (r is work). - call stdlib_${ci}$lacpy( 'ALL', n, nrhs, b, ldb, work, n ) - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n, nrhs, n, cnegone,a, lda, x, & + call stdlib${ii}$_${ci}$lacpy( 'ALL', n, nrhs, b, ldb, work, n ) + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n, nrhs, n, cnegone,a, lda, x, & ldx, cone, work, n ) ! check whether the nrhs normwise backward errors satisfy the ! stopping criterion. if yes, set iter=iiter>0 and return. do i = 1, nrhs - xnrm = cabs1( x( stdlib_i${ci}$amax( n, x( 1, i ), 1 ), i ) ) - rnrm = cabs1( work( stdlib_i${ci}$amax( n, work( 1, i ), 1 ), i ) ) + xnrm = cabs1( x( stdlib${ii}$_i${ci}$amax( n, x( 1_${ik}$, i ), 1_${ik}$ ), i ) ) + rnrm = cabs1( work( stdlib${ii}$_i${ci}$amax( n, work( 1_${ik}$, i ), 1_${ik}$ ), i ) ) if( rnrm>xnrm*cte )go to 20 end do ! if we are here, the nrhs normwise backward errors satisfy the @@ -1788,19 +1786,19 @@ module stdlib_linalg_lapack_${ci}$ ! performed iter=itermax iterations and never satisfied the stopping ! criterion, set up the iter flag accordingly and follow up on double ! precision routine. - iter = -itermax - 1 + iter = -itermax - 1_${ik}$ 40 continue ! single-precision iterative refinement failed to converge to a ! satisfactory solution, so we resort to quad precision. - call stdlib_${ci}$getrf( n, n, a, lda, ipiv, info ) + call stdlib${ii}$_${ci}$getrf( n, n, a, lda, ipiv, info ) if( info/=0 )return - call stdlib_${ci}$lacpy( 'ALL', n, nrhs, b, ldb, x, ldx ) - call stdlib_${ci}$getrs( 'NO TRANSPOSE', n, nrhs, a, lda, ipiv, x, ldx,info ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_${ci}$getrs( 'NO TRANSPOSE', n, nrhs, a, lda, ipiv, x, ldx,info ) return - end subroutine stdlib_${ci}$cgesv + end subroutine stdlib${ii}$_${ci}$cgesv - subroutine stdlib_${ci}$cposv( uplo, n, nrhs, a, lda, b, ldb, x, ldx, work,swork, rwork, iter, & + subroutine stdlib${ii}$_${ci}$cposv( uplo, n, nrhs, a, lda, b, ldb, x, ldx, work,swork, rwork, iter, & !! ZCPOSV: computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N Hermitian positive definite matrix and X and B @@ -1835,8 +1833,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(out) :: info, iter - integer(ilp), intent(in) :: lda, ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info, iter + integer(${ik}$), intent(in) :: lda, ldb, ldx, n, nrhs ! Array Arguments real(${ck}$), intent(out) :: rwork(*) complex(dp), intent(out) :: swork(*) @@ -1846,14 +1844,14 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! Parameters logical(lk), parameter :: doitref = .true. - integer(ilp), parameter :: itermax = 30 + integer(${ik}$), parameter :: itermax = 30_${ik}$ real(${ck}$), parameter :: bwdmax = 1.0e+00_${ck}$ ! Local Scalars - integer(ilp) :: i, iiter, ptsa, ptsx + integer(${ik}$) :: i, iiter, ptsa, ptsx real(${ck}$) :: anrm, cte, eps, rnrm, xnrm complex(${ck}$) :: zdum ! Intrinsic Functions @@ -1863,24 +1861,24 @@ module stdlib_linalg_lapack_${ci}$ ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements - info = 0 - iter = 0 + info = 0_${ik}$ + iter = 0_${ik}$ ! test the input parameters. if( .not.stdlib_lsame( uplo, 'U' ) .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( ldaxnrm*cte )go to 10 end do ! if we are here, the nrhs normwise backward errors satisfy the ! stopping criterion. we are good to exit. - iter = 0 + iter = 0_${ik}$ return 10 continue loop_30: do iiter = 1, itermax ! convert r (in work) from quad precision to double precision ! and store the result in sx. - call stdlib_${ci}$lag2c( n, nrhs, work, n, swork( ptsx ), n, info ) - if( info/=0 ) then - iter = -2 + call stdlib${ii}$_${ci}$lag2c( n, nrhs, work, n, swork( ptsx ), n, info ) + if( info/=0_${ik}$ ) then + iter = -2_${ik}$ go to 40 end if ! solve the system sa*sx = sr. - call stdlib_zpotrs( uplo, n, nrhs, swork( ptsa ), n, swork( ptsx ), n,info ) + call stdlib${ii}$_zpotrs( uplo, n, nrhs, swork( ptsa ), n, swork( ptsx ), n,info ) ! convert sx back to quad precision and update the current ! iterate. - call stdlib_${ci}$lag2w( n, nrhs, swork( ptsx ), n, work, n, info ) + call stdlib${ii}$_${ci}$lag2w( n, nrhs, swork( ptsx ), n, work, n, info ) do i = 1, nrhs - call stdlib_${ci}$axpy( n, cone, work( 1, i ), 1, x( 1, i ), 1 ) + call stdlib${ii}$_${ci}$axpy( n, cone, work( 1_${ik}$, i ), 1_${ik}$, x( 1_${ik}$, i ), 1_${ik}$ ) end do ! compute r = b - ax (r is work). - call stdlib_${ci}$lacpy( 'ALL', n, nrhs, b, ldb, work, n ) - call stdlib_${ci}$hemm( 'L', uplo, n, nrhs, cnegone, a, lda, x, ldx, cone,work, n ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', n, nrhs, b, ldb, work, n ) + call stdlib${ii}$_${ci}$hemm( 'L', uplo, n, nrhs, cnegone, a, lda, x, ldx, cone,work, n ) ! check whether the nrhs normwise backward errors satisfy the ! stopping criterion. if yes, set iter=iiter>0 and return. do i = 1, nrhs - xnrm = cabs1( x( stdlib_i${ci}$amax( n, x( 1, i ), 1 ), i ) ) - rnrm = cabs1( work( stdlib_i${ci}$amax( n, work( 1, i ), 1 ), i ) ) + xnrm = cabs1( x( stdlib${ii}$_i${ci}$amax( n, x( 1_${ik}$, i ), 1_${ik}$ ), i ) ) + rnrm = cabs1( work( stdlib${ii}$_i${ci}$amax( n, work( 1_${ik}$, i ), 1_${ik}$ ), i ) ) if( rnrm>xnrm*cte )go to 20 end do ! if we are here, the nrhs normwise backward errors satisfy the @@ -1975,19 +1973,19 @@ module stdlib_linalg_lapack_${ci}$ ! performed iter=itermax iterations and never satisfied the ! stopping criterion, set up the iter flag accordingly and follow ! up on quad precision routine. - iter = -itermax - 1 + iter = -itermax - 1_${ik}$ 40 continue ! single-precision iterative refinement failed to converge to a ! satisfactory solution, so we resort to quad precision. - call stdlib_${ci}$potrf( uplo, n, a, lda, info ) + call stdlib${ii}$_${ci}$potrf( uplo, n, a, lda, info ) if( info/=0 )return - call stdlib_${ci}$lacpy( 'ALL', n, nrhs, b, ldb, x, ldx ) - call stdlib_${ci}$potrs( uplo, n, nrhs, a, lda, x, ldx, info ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_${ci}$potrs( uplo, n, nrhs, a, lda, x, ldx, info ) return - end subroutine stdlib_${ci}$cposv + end subroutine stdlib${ii}$_${ci}$cposv - pure subroutine stdlib_${ci}$drscl( n, sa, sx, incx ) + pure subroutine stdlib${ii}$_${ci}$drscl( n, sa, sx, incx ) !! ZDRSCL: multiplies an n-element complex vector x by the real scalar !! 1/a. This is done without overflow or underflow as long as !! the final result x/a does not overflow or underflow. @@ -1995,7 +1993,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(${ck}$), intent(in) :: sa ! Array Arguments complex(${ck}$), intent(inout) :: sx(*) @@ -2010,9 +2008,9 @@ module stdlib_linalg_lapack_${ci}$ ! quick return if possible if( n<=0 )return ! get machine parameters - smlnum = stdlib_${c2ri(ci)}$lamch( 'S' ) + smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' ) bignum = one / smlnum - call stdlib_${c2ri(ci)}$labad( smlnum, bignum ) + call stdlib${ii}$_${c2ri(ci)}$labad( smlnum, bignum ) ! initialize the denominator to sa and the numerator to 1. cden = sa cnum = one @@ -2035,13 +2033,13 @@ module stdlib_linalg_lapack_${ci}$ done = .true. end if ! scale the vector x by mul - call stdlib_${ci}$dscal( n, mul, sx, incx ) + call stdlib${ii}$_${ci}$dscal( n, mul, sx, incx ) if( .not.done )go to 10 return - end subroutine stdlib_${ci}$drscl + end subroutine stdlib${ii}$_${ci}$drscl - pure subroutine stdlib_${ci}$gbbrd( vect, m, n, ncc, kl, ku, ab, ldab, d, e, q,ldq, pt, ldpt, c, & + pure subroutine stdlib${ii}$_${ci}$gbbrd( vect, m, n, ncc, kl, ku, ab, ldab, d, e, q,ldq, pt, ldpt, c, & !! ZGBBRD: reduces a complex general m-by-n band matrix A to real upper !! bidiagonal form B by a unitary transformation: Q**H * A * P = B. !! The routine computes B, and optionally forms Q or P**H, or computes @@ -2052,8 +2050,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: vect - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl, ku, ldab, ldc, ldpt, ldq, m, n, ncc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl, ku, ldab, ldc, ldpt, ldq, m, n, ncc ! Array Arguments real(${ck}$), intent(out) :: d(*), e(*), rwork(*) complex(${ck}$), intent(inout) :: ab(ldab,*), c(ldc,*) @@ -2063,7 +2061,7 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: wantb, wantc, wantpt, wantq - integer(ilp) :: i, inca, j, j1, j2, kb, kb1, kk, klm, klu1, kun, l, minmn, ml, ml0, mu,& + integer(${ik}$) :: i, inca, j, j1, j2, kb, kb1, kk, klm, klu1, kun, l, minmn, ml, ml0, mu,& mu0, nr, nrt real(${ck}$) :: abst, rc complex(${ck}$) :: ra, rb, rs, t @@ -2074,50 +2072,50 @@ module stdlib_linalg_lapack_${ci}$ wantb = stdlib_lsame( vect, 'B' ) wantq = stdlib_lsame( vect, 'Q' ) .or. wantb wantpt = stdlib_lsame( vect, 'P' ) .or. wantb - wantc = ncc>0 - 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 + if( kl+ku>1_${ik}$ ) then ! reduce to upper bidiagonal form if ku > 0; if ku = 0, 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. @@ -2126,107 +2124,107 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$largv( nr, ab( klu1, j1-klm-1 ), inca,work( j1 ), kb1, & + if( nr>0_${ik}$ )call stdlib${ii}$_${ci}$largv( nr, ab( klu1, j1-klm-1 ), inca,work( j1 ), kb1, & rwork( j1 ), kb1 ) ! apply plane rotations from the left do l = 1, kb if( j2-klm+l-1>n ) then - nrt = nr - 1 + nrt = nr - 1_${ik}$ else nrt = nr end if - if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( klu1-l, j1-klm+l-1 ), inca,ab( & + if( nrt>0_${ik}$ )call stdlib${ii}$_${ci}$lartv( nrt, ab( klu1-l, j1-klm+l-1 ), inca,ab( & klu1-l+1, j1-klm+l-1 ), inca,rwork( j1 ), work( j1 ), kb1 ) end do if( ml>ml0 ) then if( ml<=m-i+1 ) then ! generate plane rotation to annihilate a(i+ml-1,i) ! within the band, and apply rotation from the left - call stdlib_${ci}$lartg( ab( ku+ml-1, i ), ab( ku+ml, i ),rwork( i+ml-1 ), & + call stdlib${ii}$_${ci}$lartg( ab( ku+ml-1, i ), ab( ku+ml, i ),rwork( i+ml-1 ), & work( i+ml-1 ), ra ) ab( ku+ml-1, i ) = ra - if( 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 ) = rwork( j )*ab( 1, j+kun ) + work( j+kun ) = work( j )*ab( 1_${ik}$, j+kun ) + ab( 1_${ik}$, j+kun ) = rwork( 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_${ci}$largv( nr, ab( 1, j1+kun-1 ), inca,work( j1+kun ), kb1,& + if( nr>0_${ik}$ )call stdlib${ii}$_${ci}$largv( nr, ab( 1_${ik}$, j1+kun-1 ), inca,work( j1+kun ), kb1,& rwork( 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_${ci}$lartv( nrt, ab( l+1, j1+kun-1 ), inca,ab( l, j1+& + if( nrt>0_${ik}$ )call stdlib${ii}$_${ci}$lartv( nrt, ab( l+1, j1+kun-1 ), inca,ab( l, j1+& kun ), inca,rwork( j1+kun ), work( j1+kun ), kb1 ) end do if( ml==ml0 .and. mu>mu0 ) then if( mu<=n-i+1 ) then ! generate plane rotation to annihilate a(i,i+mu-1) ! within the band, and apply rotation from the right - call stdlib_${ci}$lartg( ab( ku-mu+3, i+mu-2 ),ab( ku-mu+2, i+mu-1 ),rwork( & + call stdlib${ii}$_${ci}$lartg( ab( ku-mu+3, i+mu-2 ),ab( ku-mu+2, i+mu-1 ),rwork( & i+mu-1 ), work( i+mu-1 ), ra ) ab( ku-mu+3, i+mu-2 ) = ra - call stdlib_${ci}$rot( min( kl+mu-2, m-i ),ab( ku-mu+4, i+mu-2 ), 1,ab( ku-& - mu+3, i+mu-1 ), 1,rwork( i+mu-1 ), work( i+mu-1 ) ) + call stdlib${ii}$_${ci}$rot( min( kl+mu-2, m-i ),ab( ku-mu+4, i+mu-2 ), 1_${ik}$,ab( ku-& + mu+3, i+mu-1 ), 1_${ik}$,rwork( 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**h do j = j1, j2, kb1 - call stdlib_${ci}$rot( n, pt( j+kun-1, 1 ), ldpt,pt( j+kun, 1 ), ldpt, rwork(& + call stdlib${ii}$_${ci}$rot( n, pt( j+kun-1, 1_${ik}$ ), ldpt,pt( j+kun, 1_${ik}$ ), ldpt, rwork(& j+kun ),conjg( 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 @@ -2236,52 +2234,52 @@ module stdlib_linalg_lapack_${ci}$ ab( klu1, j+kun ) = rwork( 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 complex lower bidiagonal form ! transform lower bidiagonal form to upper bidiagonal by applying ! plane rotations from the left, overwriting superdiagonal ! elements on subdiagonal elements do i = 1, min( m-1, n ) - call stdlib_${ci}$lartg( ab( 1, i ), ab( 2, i ), rc, rs, ra ) - ab( 1, i ) = ra + call stdlib${ii}$_${ci}$lartg( ab( 1_${ik}$, i ), ab( 2_${ik}$, i ), rc, rs, ra ) + ab( 1_${ik}$, i ) = ra if( i0 .and. m0_${ik}$ .and. m1 ) then + if( i>1_${ik}$ ) then rb = -conjg( rs )*ab( ku, i ) ab( ku, i ) = rc*ab( ku, i ) end if - if( wantpt )call stdlib_${ci}$rot( n, pt( i, 1 ), ldpt, pt( m+1, 1 ), ldpt,rc, & + if( wantpt )call stdlib${ii}$_${ci}$rot( n, pt( i, 1_${ik}$ ), ldpt, pt( m+1, 1_${ik}$ ), ldpt,rc, & conjg( rs ) ) end do end if end if ! make diagonal and superdiagonal elements real, storing them in d ! and e - t = ab( ku+1, 1 ) + t = ab( ku+1, 1_${ik}$ ) loop_120: do i = 1, minmn abst = abs( t ) d( i ) = abst @@ -2290,15 +2288,15 @@ module stdlib_linalg_lapack_${ci}$ else t = cone end if - if( wantq )call stdlib_${ci}$scal( m, t, q( 1, i ), 1 ) - if( wantc )call stdlib_${ci}$scal( ncc, conjg( t ), c( i, 1 ), ldc ) + if( wantq )call stdlib${ii}$_${ci}$scal( m, t, q( 1_${ik}$, i ), 1_${ik}$ ) + if( wantc )call stdlib${ii}$_${ci}$scal( ncc, conjg( t ), c( i, 1_${ik}$ ), ldc ) if( i0 - kase = 0 + kd = kl + ku + 1_${ik}$ + lnoti = kl>0_${ik}$ + kase = 0_${ik}$ 10 continue - call stdlib_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + if( kase/=0_${ik}$ ) then if( kase==kase1 ) then ! multiply by inv(l). if( lnoti ) then @@ -2411,21 +2409,21 @@ module stdlib_linalg_lapack_${ci}$ work( jp ) = work( j ) work( j ) = t end if - call stdlib_${ci}$axpy( lm, -t, ab( kd+1, j ), 1, work( j+1 ), 1 ) + call stdlib${ii}$_${ci}$axpy( lm, -t, ab( kd+1, j ), 1_${ik}$, work( j+1 ), 1_${ik}$ ) end do end if ! multiply by inv(u). - call stdlib_${ci}$latbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, & + call stdlib${ii}$_${ci}$latbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, & ldab, work, scale, rwork, info ) else ! multiply by inv(u**h). - call stdlib_${ci}$latbs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, kl+ku, & + call stdlib${ii}$_${ci}$latbs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, kl+ku, & ab, ldab, work, scale, rwork,info ) ! multiply by inv(l**h). if( lnoti ) then do j = n - 1, 1, -1 lm = min( kl, n-j ) - work( j ) = work( j ) - stdlib_${ci}$dotc( lm, ab( kd+1, j ), 1,work( j+1 ), 1 ) + work( j ) = work( j ) - stdlib${ii}$_${ci}$dotc( lm, ab( kd+1, j ), 1_${ik}$,work( j+1 ), 1_${ik}$ ) jp = ipiv( j ) if( jp/=j ) then @@ -2439,9 +2437,9 @@ module stdlib_linalg_lapack_${ci}$ ! divide x by 1/scale if doing so will not cause overflow. normin = 'Y' if( scale/=one ) then - ix = stdlib_i${ci}$amax( n, work, 1 ) + ix = stdlib${ii}$_i${ci}$amax( 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. @@ -2707,7 +2705,7 @@ module stdlib_linalg_lapack_${ci}$ c( j ) = max( c( j ), cabs1( 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. @@ -2734,10 +2732,10 @@ module stdlib_linalg_lapack_${ci}$ colcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) end if return - end subroutine stdlib_${ci}$gbequb + end subroutine stdlib${ii}$_${ci}$gbequb - pure subroutine stdlib_${ci}$gbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb,ipiv, b, ldb, x, & + pure subroutine stdlib${ii}$_${ci}$gbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb,ipiv, b, ldb, x, & !! ZGBRFS: 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. @@ -2747,17 +2745,17 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(${ik}$), intent(in) :: ipiv(*) real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*) complex(${ck}$), intent(in) :: ab(ldab,*), afb(ldafb,*), b(ldb,*) complex(${ck}$), intent(out) :: work(*) complex(${ck}$), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: itmax = 5 + integer(${ik}$), parameter :: itmax = 5_${ik}$ @@ -2766,11 +2764,11 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: notran character :: transn, transt - integer(ilp) :: count, i, j, k, kase, kk, nz + integer(${ik}$) :: count, i, j, k, kase, kk, nz real(${ck}$) :: eps, lstres, s, safe1, safe2, safmin, xk complex(${ck}$) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,aimag,max,min ! Statement Functions @@ -2779,34 +2777,34 @@ module stdlib_linalg_lapack_${ci}$ cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! 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_${ci}$gbtrs( trans, n, kl, ku, 1, afb, ldafb, ipiv, work, n,info ) - call stdlib_${ci}$axpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_${ci}$gbtrs( trans, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv, work, n,info ) + call stdlib${ii}$_${ci}$axpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -2911,13 +2909,13 @@ module stdlib_linalg_lapack_${ci}$ rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(op(a)**h). - call stdlib_${ci}$gbtrs( transt, n, kl, ku, 1, afb, ldafb, ipiv,work, n, info ) + call stdlib${ii}$_${ci}$gbtrs( transt, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) @@ -2927,7 +2925,7 @@ module stdlib_linalg_lapack_${ci}$ do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_${ci}$gbtrs( transn, n, kl, ku, 1, afb, ldafb, ipiv,work, n, info ) + call stdlib${ii}$_${ci}$gbtrs( transn, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work, n, info ) end if go to 100 @@ -2940,10 +2938,10 @@ module stdlib_linalg_lapack_${ci}$ if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_${ci}$gbrfs + end subroutine stdlib${ii}$_${ci}$gbrfs - pure subroutine stdlib_${ci}$gbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) + pure subroutine stdlib${ii}$_${ci}$gbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) !! ZGBSV: computes the solution to a complex system of linear equations !! A * X = B, where A is a band matrix of order N with KL subdiagonals !! and KU superdiagonals, and X and B are N-by-NRHS matrices. @@ -2956,46 +2954,46 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl, ku, ldab, ldb, n, nrhs ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(${ck}$), intent(inout) :: ab(ldab,*), b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 - if( n<0 ) then - info = -1 - else if( kl<0 ) then - info = -2 - else if( ku<0 ) then - info = -3 - else if( nrhs<0 ) then - info = -4 - else if( ldab<2*kl+ku+1 ) then - info = -6 - else if( ldb0 ) then + info = -13_${ik}$ + else if( n>0_${ik}$ ) then rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) else rowcnd = one end if end if - if( colequ .and. info==0 ) then + if( colequ .and. info==0_${ik}$ ) then rcmin = bignum rcmax = zero do j = 1, n @@ -3090,32 +3088,32 @@ module stdlib_linalg_lapack_${ci}$ rcmax = max( rcmax, c( j ) ) end do if( rcmin<=zero ) then - info = -14 - else if( n>0 ) then + info = -14_${ik}$ + else if( n>0_${ik}$ ) then colcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) else colcnd = one end if end if - if( info==0 ) then - if( ldb0 ) then + if( info>0_${ik}$ ) then ! compute the reciprocal pivot growth factor of the ! leading rank-deficient info columns of a. anorm = zero @@ -3156,14 +3154,14 @@ module stdlib_linalg_lapack_${ci}$ anorm = max( anorm, abs( ab( i, j ) ) ) end do end do - rpvgrw = stdlib_${ci}$lantb( 'M', 'U', 'N', info, min( info-1, kl+ku ),afb( max( 1, & - kl+ku+2-info ), 1 ), ldafb,rwork ) + rpvgrw = stdlib${ii}$_${ci}$lantb( 'M', 'U', 'N', info, min( info-1, kl+ku ),afb( max( 1_${ik}$, & + kl+ku+2-info ), 1_${ik}$ ), ldafb,rwork ) if( rpvgrw==zero ) then rpvgrw = one else rpvgrw = anorm / rpvgrw end if - rwork( 1 ) = rpvgrw + rwork( 1_${ik}$ ) = rpvgrw rcond = zero return end if @@ -3175,22 +3173,22 @@ module stdlib_linalg_lapack_${ci}$ else norm = 'I' end if - anorm = stdlib_${ci}$langb( norm, n, kl, ku, ab, ldab, rwork ) - rpvgrw = stdlib_${ci}$lantb( 'M', 'U', 'N', n, kl+ku, afb, ldafb, rwork ) + anorm = stdlib${ii}$_${ci}$langb( norm, n, kl, ku, ab, ldab, rwork ) + rpvgrw = stdlib${ii}$_${ci}$lantb( 'M', 'U', 'N', n, kl+ku, afb, ldafb, rwork ) if( rpvgrw==zero ) then rpvgrw = one else - rpvgrw = stdlib_${ci}$langb( 'M', n, kl, ku, ab, ldab, rwork ) / rpvgrw + rpvgrw = stdlib${ii}$_${ci}$langb( 'M', n, kl, ku, ab, ldab, rwork ) / rpvgrw end if ! compute the reciprocal of the condition number of a. - call stdlib_${ci}$gbcon( norm, n, kl, ku, afb, ldafb, ipiv, anorm, rcond,work, rwork, info ) + call stdlib${ii}$_${ci}$gbcon( norm, n, kl, ku, afb, ldafb, ipiv, anorm, rcond,work, rwork, info ) ! compute the solution matrix x. - call stdlib_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_${ci}$gbtrs( trans, n, kl, ku, nrhs, afb, ldafb, ipiv, x, ldx,info ) + call stdlib${ii}$_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_${ci}$gbtrs( trans, n, kl, ku, nrhs, afb, ldafb, ipiv, x, ldx,info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_${ci}$gbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv,b, ldb, x, ldx, & + call stdlib${ii}$_${ci}$gbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv,b, ldb, x, ldx, & ferr, berr, work, rwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -3216,13 +3214,13 @@ module stdlib_linalg_lapack_${ci}$ end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond0 ) then + if( jp/=1_${ik}$ )call stdlib${ii}$_${ci}$swap( 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_${ci}$scal( km, cone / ab( kv+1, j ), ab( kv+2, j ), 1 ) + call stdlib${ii}$_${ci}$scal( km, cone / ab( kv+1, j ), ab( kv+2, j ), 1_${ik}$ ) ! update trailing submatrix within the band. - if( ju>j )call stdlib_${ci}$geru( km, ju-j, -cone, ab( kv+2, j ), 1,ab( kv, j+1 ), & + if( ju>j )call stdlib${ii}$_${ci}$geru( km, ju-j, -cone, 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 czero, set info to the index of the pivot ! unless a czero 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_${ci}$gbtf2 + end subroutine stdlib${ii}$_${ci}$gbtf2 - pure subroutine stdlib_${ci}$gbtrf( m, n, kl, ku, ab, ldab, ipiv, info ) + pure subroutine stdlib${ii}$_${ci}$gbtrf( m, n, kl, ku, ab, ldab, ipiv, info ) !! ZGBTRF: computes an LU factorization of a complex m-by-n band matrix A !! using partial pivoting with row interchanges. !! This is the blocked version of the algorithm, calling Level 3 BLAS. @@ -3316,19 +3314,19 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), 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 complex(${ck}$) :: temp ! Local Arrays @@ -3340,32 +3338,32 @@ module stdlib_linalg_lapack_${ci}$ ! 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_${ci}$gbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) + call stdlib${ii}$_${ci}$gbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) else ! use blocked code ! czero the superdiagonal elements of the work array work13 @@ -3389,7 +3387,7 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -3415,57 +3413,57 @@ module stdlib_linalg_lapack_${ci}$ ! find pivot and test for singularity. km is the number of ! subdiagonal elements in the current column. km = min( kl, m-jj ) - jp = stdlib_i${ci}$amax( km+1, ab( kv+1, jj ), 1 ) + jp = stdlib${ii}$_i${ci}$amax( km+1, ab( kv+1, jj ), 1_${ik}$ ) ipiv( jj ) = jp + jj - j if( ab( kv+jp, jj )/=czero ) then ju = max( ju, min( jj+ku+jp-1, n ) ) - if( jp/=1 ) then + if( jp/=1_${ik}$ ) then ! apply interchange to columns j to j+jb-1 if( jp+jj-1jj )call stdlib_${ci}$geru( km, jm-jj, -cone, ab( kv+2, jj ), 1,ab( kv, & + if( jm>jj )call stdlib${ii}$_${ci}$geru( km, jm-jj, -cone, ab( kv+2, jj ), 1_${ik}$,ab( kv, & jj+1 ), ldab-1,ab( kv+1, jj+1 ), ldab-1 ) else ! if pivot is czero, set info to the index of the pivot ! unless a czero 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_${ci}$copy( nw, ab( kv+kl+1-jj+j, jj ), 1,work31( 1, jj-j+1 )& - , 1 ) + if( nw>0_${ik}$ )call stdlib${ii}$_${ci}$copy( 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_${ci}$laswp to apply the row interchanges to a12, a22, and ! a32. - call stdlib_${ci}$laswp( j2, ab( kv+1-jb, j+jb ), ldab-1, 1, jb,ipiv( j ), 1 ) + call stdlib${ii}$_${ci}$laswp( 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 @@ -3478,24 +3476,24 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j2, cone, & + call stdlib${ii}$_${ci}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j2, cone, & ab( kv+1, j ), ldab-1,ab( kv+1-jb, j+jb ), ldab-1 ) - if( i2>0 ) then + if( i2>0_${ik}$ ) then ! update a22 - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j2,jb, -cone, ab(& + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j2,jb, -cone, ab(& kv+1+jb, j ), ldab-1,ab( kv+1-jb, j+jb ), ldab-1, cone,ab( kv+1, j+jb )& , ldab-1 ) end if - if( i3>0 ) then + if( i3>0_${ik}$ ) then ! update a32 - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j2,jb, -cone, & + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j2,jb, -cone, & work31, ldwork,ab( kv+1-jb, j+jb ), ldab-1, cone,ab( kv+kl+1-jb, j+jb ),& ldab-1 ) end if 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 @@ -3504,18 +3502,18 @@ module stdlib_linalg_lapack_${ci}$ end do end do ! update a13 in the work array - call stdlib_${ci}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j3, cone, & + call stdlib${ii}$_${ci}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j3, cone, & ab( kv+1, j ), ldab-1,work13, ldwork ) - if( i2>0 ) then + if( i2>0_${ik}$ ) then ! update a23 - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j3,jb, -cone, ab(& - kv+1+jb, j ), ldab-1,work13, ldwork, cone, ab( 1+jb, j+kv ),ldab-1 ) + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j3,jb, -cone, ab(& + kv+1+jb, j ), ldab-1,work13, ldwork, cone, ab( 1_${ik}$+jb, j+kv ),ldab-1 ) end if - if( i3>0 ) then + if( i3>0_${ik}$ ) then ! update a33 - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j3,jb, -cone, & - work31, ldwork, work13,ldwork, cone, ab( 1+kl, j+kv ), ldab-1 ) + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j3,jb, -cone, & + work31, ldwork, work13,ldwork, cone, ab( 1_${ik}$+kl, j+kv ), ldab-1 ) end if ! copy the lower triangle of a13 back into place do jj = 1, j3 @@ -3527,38 +3525,38 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$copy( nw, work31( 1, jj-j+1 ), 1,ab( kv+kl+1-jj+j, jj )& - , 1 ) + if( nw>0_${ik}$ )call stdlib${ii}$_${ci}$copy( 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_${ci}$gbtrf + end subroutine stdlib${ii}$_${ci}$gbtrf - pure subroutine stdlib_${ci}$gbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info ) + pure subroutine stdlib${ii}$_${ci}$gbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info ) !! ZGBTRS: solves a system of linear equations !! A * X = B, A**T * X = B, or A**H * X = B !! with a general band matrix A using the LU factorization computed @@ -3568,47 +3566,47 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), intent(in) :: ab(ldab,*) complex(${ck}$), 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. @@ -3620,58 +3618,58 @@ module stdlib_linalg_lapack_${ci}$ do j = 1, n - 1 lm = min( kl, n-j ) l = ipiv( j ) - if( l/=j )call stdlib_${ci}$swap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) - call stdlib_${ci}$geru( lm, nrhs, -cone, ab( kd+1, j ), 1, b( j, 1 ),ldb, b( j+1, & - 1 ), ldb ) + if( l/=j )call stdlib${ii}$_${ci}$swap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$geru( lm, nrhs, -cone, 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_${ci}$tbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kl+ku,ab, ldab, b( 1, & - i ), 1 ) + call stdlib${ii}$_${ci}$tbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kl+ku,ab, ldab, b( 1_${ik}$, & + i ), 1_${ik}$ ) end do else if( stdlib_lsame( trans, 'T' ) ) then ! solve a**t * x = b. do i = 1, nrhs ! solve u**t * x = b, overwriting b with x. - call stdlib_${ci}$tbsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, kl+ku, ab,ldab, b( 1, i )& - , 1 ) + call stdlib${ii}$_${ci}$tbsv( '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_${ci}$gemv( 'TRANSPOSE', lm, nrhs, -cone, b( j+1, 1 ),ldb, ab( kd+1, j & - ), 1, cone, b( j, 1 ), ldb ) + call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', lm, nrhs, -cone, b( j+1, 1_${ik}$ ),ldb, ab( kd+1, j & + ), 1_${ik}$, cone, b( j, 1_${ik}$ ), ldb ) l = ipiv( j ) - if( l/=j )call stdlib_${ci}$swap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) + if( l/=j )call stdlib${ii}$_${ci}$swap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb ) end do end if else ! solve a**h * x = b. do i = 1, nrhs ! solve u**h * x = b, overwriting b with x. - call stdlib_${ci}$tbsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,kl+ku, ab, ldab,& - b( 1, i ), 1 ) + call stdlib${ii}$_${ci}$tbsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,kl+ku, ab, ldab,& + b( 1_${ik}$, i ), 1_${ik}$ ) end do ! solve l**h * x = b, overwriting b with x. if( lnoti ) then do j = n - 1, 1, -1 lm = min( kl, n-j ) - call stdlib_${ci}$lacgv( nrhs, b( j, 1 ), ldb ) - call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', lm, nrhs, -cone,b( j+1, 1 ), ldb, & - ab( kd+1, j ), 1, cone,b( j, 1 ), ldb ) - call stdlib_${ci}$lacgv( nrhs, b( j, 1 ), ldb ) + call stdlib${ii}$_${ci}$lacgv( nrhs, b( j, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', lm, nrhs, -cone,b( j+1, 1_${ik}$ ), ldb, & + ab( kd+1, j ), 1_${ik}$, cone,b( j, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$lacgv( nrhs, b( j, 1_${ik}$ ), ldb ) l = ipiv( j ) - if( l/=j )call stdlib_${ci}$swap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) + if( l/=j )call stdlib${ii}$_${ci}$swap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb ) end do end if end if return - end subroutine stdlib_${ci}$gbtrs + end subroutine stdlib${ii}$_${ci}$gbtrs - pure subroutine stdlib_${ci}$gebak( job, side, n, ilo, ihi, scale, m, v, ldv,info ) + pure subroutine stdlib${ii}$_${ci}$gebak( job, side, n, ilo, ihi, scale, m, v, ldv,info ) !! ZGEBAK: forms the right or left eigenvectors of a complex general !! matrix by backward transformation on the computed eigenvectors of the !! balanced matrix output by ZGEBAL. @@ -3680,8 +3678,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(${ck}$), intent(in) :: scale(*) complex(${ck}$), intent(inout) :: v(ldv,*) @@ -3689,7 +3687,7 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: leftv, rightv - integer(ilp) :: i, ii, k + integer(${ik}$) :: i, ii, k real(${ck}$) :: s ! Intrinsic Functions intrinsic :: max,min @@ -3697,25 +3695,25 @@ module stdlib_linalg_lapack_${ci}$ ! 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( ldv=g .or. max( f, c, ca )>=sfmax2 .or.min( r, g, ra )<=sfmin2 )go to 170 - if( stdlib_${c2ri(ci)}$isnan( c+f+ca+r+g+ra ) ) then + if( stdlib${ii}$_${c2ri(ci)}$isnan( c+f+ca+r+g+ra ) ) then ! exit if nan to avoid infinite loop - info = -3 - call stdlib_xerbla( 'ZGEBAL', -info ) + info = -3_${ik}$ + call stdlib${ii}$_xerbla( 'ZGEBAL', -info ) return end if f = f*sclfac @@ -3927,18 +3925,18 @@ module stdlib_linalg_lapack_${ci}$ g = one / f scale( i ) = scale( i )*f noconv = .true. - call stdlib_${ci}$dscal( n-k+1, g, a( i, k ), lda ) - call stdlib_${ci}$dscal( l, f, a( 1, i ), 1 ) + call stdlib${ii}$_${ci}$dscal( n-k+1, g, a( i, k ), lda ) + call stdlib${ii}$_${ci}$dscal( l, f, a( 1_${ik}$, i ), 1_${ik}$ ) end do loop_200 if( noconv )go to 140 210 continue ilo = k ihi = l return - end subroutine stdlib_${ci}$gebal + end subroutine stdlib${ii}$_${ci}$gebal - pure subroutine stdlib_${ci}$gebd2( m, n, a, lda, d, e, tauq, taup, work, info ) + pure subroutine stdlib${ii}$_${ci}$gebd2( m, n, a, lda, d, e, tauq, taup, work, info ) !! ZGEBD2: reduces a complex general m by n matrix A to upper or lower !! real bidiagonal form B by a unitary transformation: Q**H * A * P = B. !! If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. @@ -3946,8 +3944,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(${ck}$), intent(out) :: d(*), e(*) complex(${ck}$), intent(inout) :: a(lda,*) @@ -3955,22 +3953,22 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i complex(${ck}$) :: alpha ! Intrinsic Functions intrinsic :: conjg,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=n ) then @@ -3978,25 +3976,25 @@ module stdlib_linalg_lapack_${ci}$ do i = 1, n ! generate elementary reflector h(i) to annihilate a(i+1:m,i) alpha = a( i, i ) - call stdlib_${ci}$larfg( m-i+1, alpha, a( min( i+1, m ), i ), 1,tauq( i ) ) + call stdlib${ii}$_${ci}$larfg( m-i+1, alpha, a( min( i+1, m ), i ), 1_${ik}$,tauq( i ) ) d( i ) = real( alpha,KIND=${ck}$) a( i, i ) = cone ! apply h(i)**h to a(i:m,i+1:n) from the left - if( i= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. @@ -4044,8 +4042,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, lwork, m, n ! Array Arguments real(${ck}$), intent(out) :: d(*), e(*) complex(${ck}$), intent(inout) :: a(lda,*) @@ -4054,54 +4052,54 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, iinfo, j, ldwrkx, ldwrky, lwkopt, minmn, nb, nbmin, nx, ws + integer(${ik}$) :: i, iinfo, j, ldwrkx, ldwrky, lwkopt, minmn, nb, nbmin, nx, ws ! Intrinsic Functions intrinsic :: real,max,min ! Executable Statements ! test the input parameters - info = 0 - nb = max( 1, stdlib_ilaenv( 1, 'ZGEBRD', ' ', m, n, -1, -1 ) ) + info = 0_${ik}$ + nb = max( 1_${ik}$, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEBRD', ' ', m, n, -1_${ik}$, -1_${ik}$ ) ) lwkopt = ( m+n )*nb - work( 1 ) = real( lwkopt,KIND=${ck}$) - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda1 .and. nb1_${ik}$ .and. nb=( m+n )*nbmin ) then nb = lwork / ( m+n ) else - nb = 1 + nb = 1_${ik}$ nx = minmn end if end if @@ -4113,14 +4111,14 @@ module stdlib_linalg_lapack_${ci}$ ! reduce rows and columns i:i+ib-1 to bidiagonal form and return ! the matrices x and y which are needed to update the unreduced ! part of the matrix - call stdlib_${ci}$labrd( m-i+1, n-i+1, nb, a( i, i ), lda, d( i ), e( i ),tauq( i ), & + call stdlib${ii}$_${ci}$labrd( m-i+1, n-i+1, nb, a( i, i ), lda, d( i ), e( i ),tauq( i ), & taup( i ), work, ldwrkx,work( ldwrkx*nb+1 ), ldwrky ) ! update the trailing submatrix a(i+ib:m,i+ib:n), using ! an update of the form a := a - v*y**h - x*u**h - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m-i-nb+1,n-i-nb+1, nb, -& + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m-i-nb+1,n-i-nb+1, nb, -& cone, a( i+nb, i ), lda,work( ldwrkx*nb+nb+1 ), ldwrky, cone,a( i+nb, i+nb ), lda ) - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-i-nb+1, n-i-nb+1,nb, -cone, & + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-i-nb+1, n-i-nb+1,nb, -cone, & work( nb+1 ), ldwrkx, a( i, i+nb ), lda,cone, a( i+nb, i+nb ), lda ) ! copy diagonal and off-diagonal elements of b back into a if( m>=n ) then @@ -4136,14 +4134,14 @@ module stdlib_linalg_lapack_${ci}$ end if end do ! use unblocked code to reduce the remainder of the matrix - call stdlib_${ci}$gebd2( m-i+1, n-i+1, a( i, i ), lda, d( i ), e( i ),tauq( i ), taup( i ), & + call stdlib${ii}$_${ci}$gebd2( m-i+1, n-i+1, a( i, i ), lda, d( i ), e( i ),tauq( i ), taup( i ), & work, iinfo ) - work( 1 ) = ws + work( 1_${ik}$ ) = ws return - end subroutine stdlib_${ci}$gebrd + end subroutine stdlib${ii}$_${ci}$gebrd - pure subroutine stdlib_${ci}$gecon( norm, n, a, lda, anorm, rcond, work, rwork,info ) + pure subroutine stdlib${ii}$_${ci}$gecon( norm, n, a, lda, anorm, rcond, work, rwork,info ) !! ZGECON: estimates the reciprocal of the condition number of a general !! complex matrix A, in either the 1-norm or the infinity-norm, using !! the LU factorization computed by ZGETRF. @@ -4155,8 +4153,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(${ck}$), intent(in) :: anorm real(${ck}$), intent(out) :: rcond ! Array Arguments @@ -4168,11 +4166,11 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: onenrm character :: normin - integer(ilp) :: ix, kase, kase1 + integer(${ik}$) :: ix, kase, kase1 real(${ck}$) :: ainvnm, scale, sl, smlnum, su complex(${ck}$) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,aimag,max ! Statement Functions @@ -4181,64 +4179,64 @@ module stdlib_linalg_lapack_${ci}$ cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ onenrm = norm=='1' .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. @@ -4491,7 +4489,7 @@ module stdlib_linalg_lapack_${ci}$ c( j ) = max( c( j ), cabs1( 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. @@ -4518,10 +4516,10 @@ module stdlib_linalg_lapack_${ci}$ colcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) end if return - end subroutine stdlib_${ci}$geequb + end subroutine stdlib${ii}$_${ci}$geequb - subroutine stdlib_${ci}$gees( jobvs, sort, select, n, a, lda, sdim, w, vs,ldvs, work, lwork, & + subroutine stdlib${ii}$_${ci}$gees( jobvs, sort, select, n, a, lda, sdim, w, vs,ldvs, work, lwork, & !! ZGEES: computes for an N-by-N complex nonsymmetric matrix A, the !! eigenvalues, the Schur form T, and, optionally, the matrix of Schur !! vectors Z. This gives the Schur factorization A = Z*T*(Z**H). @@ -4536,8 +4534,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvs, sort - integer(ilp), intent(out) :: info, sdim - integer(ilp), intent(in) :: lda, ldvs, lwork, n + integer(${ik}$), intent(out) :: info, sdim + integer(${ik}$), intent(in) :: lda, ldvs, lwork, n ! Array Arguments logical(lk), intent(out) :: bwork(*) real(${ck}$), intent(out) :: rwork(*) @@ -4549,29 +4547,29 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: lquery, scalea, wantst, wantvs - integer(ilp) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, maxwrk, & + integer(${ik}$) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, maxwrk, & minwrk real(${ck}$) :: anrm, bignum, cscale, eps, s, sep, smlnum ! Local Arrays - real(${ck}$) :: dum(1) + real(${ck}$) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) wantvs = stdlib_lsame( jobvs, 'V' ) wantst = stdlib_lsame( sort, 'S' ) if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then - info = -2 - else if( n<0 ) then - info = -4 - else if( ldazero .and. anrm0 )info = ieval + if( ieval>0_${ik}$ )info = ieval ! sort eigenvalues if desired - if( wantst .and. info==0 ) then - if( scalea )call stdlib_${ci}$lascl( 'G', 0, 0, cscale, anrm, n, 1, w, n, ierr ) + if( wantst .and. info==0_${ik}$ ) then + if( scalea )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, w, n, ierr ) do i = 1, n bwork( i ) = select( w( i ) ) end do ! reorder eigenvalues and transform schur vectors ! (cworkspace: none) ! (rworkspace: none) - call stdlib_${ci}$trsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,s, sep, work( & + call stdlib${ii}$_${ci}$trsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,s, sep, work( & iwrk ), lwork-iwrk+1, icond ) end if if( wantvs ) then ! undo balancing ! (cworkspace: none) ! (rworkspace: need n) - call stdlib_${ci}$gebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr ) + call stdlib${ii}$_${ci}$gebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr ) end if if( scalea ) then ! undo scaling for the schur form of a - call stdlib_${ci}$lascl( 'U', 0, 0, cscale, anrm, n, n, a, lda, ierr ) - call stdlib_${ci}$copy( n, a, lda+1, w, 1 ) + call stdlib${ii}$_${ci}$lascl( 'U', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_${ci}$copy( n, a, lda+1, w, 1_${ik}$ ) end if - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_${ci}$gees + end subroutine stdlib${ii}$_${ci}$gees - subroutine stdlib_${ci}$geesx( jobvs, sort, select, sense, n, a, lda, sdim, w,vs, ldvs, rconde, & + subroutine stdlib${ii}$_${ci}$geesx( jobvs, sort, select, sense, n, a, lda, sdim, w,vs, ldvs, rconde, & !! ZGEESX: computes for an N-by-N complex nonsymmetric matrix A, the !! eigenvalues, the Schur form T, and, optionally, the matrix of Schur !! vectors Z. This gives the Schur factorization A = Z*T*(Z**H). @@ -4713,8 +4711,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvs, sense, sort - integer(ilp), intent(out) :: info, sdim - integer(ilp), intent(in) :: lda, ldvs, lwork, n + integer(${ik}$), intent(out) :: info, sdim + integer(${ik}$), intent(in) :: lda, ldvs, lwork, n real(${ck}$), intent(out) :: rconde, rcondv ! Array Arguments logical(lk), intent(out) :: bwork(*) @@ -4727,36 +4725,36 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: lquery, scalea, wantsb, wantse, wantsn, wantst, wantsv, wantvs - integer(ilp) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, lwrk, & + integer(${ik}$) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, lwrk, & maxwrk, minwrk real(${ck}$) :: anrm, bignum, cscale, eps, smlnum ! Local Arrays - real(${ck}$) :: dum(1) + real(${ck}$) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ wantvs = stdlib_lsame( jobvs, 'V' ) wantst = stdlib_lsame( sort, 'S' ) wantsn = stdlib_lsame( sense, 'N' ) wantse = stdlib_lsame( sense, 'E' ) wantsv = stdlib_lsame( sense, 'V' ) wantsb = stdlib_lsame( sense, 'B' ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. & .not.wantsn ) ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( ldazero .and. anrm0 )info = ieval + if( ieval>0_${ik}$ )info = ieval ! sort eigenvalues if desired - if( wantst .and. info==0 ) then - if( scalea )call stdlib_${ci}$lascl( 'G', 0, 0, cscale, anrm, n, 1, w, n, ierr ) + if( wantst .and. info==0_${ik}$ ) then + if( scalea )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, w, n, ierr ) do i = 1, n bwork( i ) = select( w( i ) ) end do @@ -4865,36 +4863,36 @@ module stdlib_linalg_lapack_${ci}$ ! (cworkspace: if sense is not 'n', need 2*sdim*(n-sdim) ! otherwise, need none ) ! (rworkspace: none) - call stdlib_${ci}$trsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,rconde, & + call stdlib${ii}$_${ci}$trsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,rconde, & rcondv, work( iwrk ), lwork-iwrk+1,icond ) - if( .not.wantsn )maxwrk = max( maxwrk, 2*sdim*( n-sdim ) ) - if( icond==-14 ) then + if( .not.wantsn )maxwrk = max( maxwrk, 2_${ik}$*sdim*( n-sdim ) ) + if( icond==-14_${ik}$ ) then ! not enough complex workspace - info = -15 + info = -15_${ik}$ end if end if if( wantvs ) then ! undo balancing ! (cworkspace: none) ! (rworkspace: need n) - call stdlib_${ci}$gebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr ) + call stdlib${ii}$_${ci}$gebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr ) end if if( scalea ) then ! undo scaling for the schur form of a - call stdlib_${ci}$lascl( 'U', 0, 0, cscale, anrm, n, n, a, lda, ierr ) - call stdlib_${ci}$copy( n, a, lda+1, w, 1 ) - if( ( wantsv .or. wantsb ) .and. info==0 ) then - dum( 1 ) = rcondv - call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, cscale, anrm, 1, 1, dum, 1, ierr ) - rcondv = dum( 1 ) + call stdlib${ii}$_${ci}$lascl( 'U', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_${ci}$copy( n, a, lda+1, w, 1_${ik}$ ) + if( ( wantsv .or. wantsb ) .and. info==0_${ik}$ ) then + dum( 1_${ik}$ ) = rcondv + call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr ) + rcondv = dum( 1_${ik}$ ) end if end if - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_${ci}$geesx + end subroutine stdlib${ii}$_${ci}$geesx - subroutine stdlib_${ci}$geev( jobvl, jobvr, n, a, lda, w, vl, ldvl, vr, ldvr,work, lwork, rwork, & + subroutine stdlib${ii}$_${ci}$geev( jobvl, jobvr, n, a, lda, w, vl, ldvl, vr, ldvr,work, lwork, rwork, & !! ZGEEV: computes for an N-by-N complex nonsymmetric matrix A, the !! eigenvalues and, optionally, the left and/or right eigenvectors. !! The right eigenvector v(j) of A satisfies @@ -4911,8 +4909,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvl, jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n ! Array Arguments real(${ck}$), intent(out) :: rwork(*) complex(${ck}$), intent(inout) :: a(lda,*) @@ -4922,33 +4920,33 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: lquery, scalea, wantvl, wantvr character :: side - integer(ilp) :: hswork, i, ibal, ierr, ihi, ilo, irwork, itau, iwrk, k, lwork_trevc, & + integer(${ik}$) :: hswork, i, ibal, ierr, ihi, ilo, irwork, itau, iwrk, k, lwork_trevc, & maxwrk, minwrk, nout real(${ck}$) :: anrm, bignum, cscale, eps, scl, smlnum complex(${ck}$) :: tmp ! Local Arrays - logical(lk) :: select(1) - real(${ck}$) :: dum(1) + logical(lk) :: select(1_${ik}$) + real(${ck}$) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: real,cmplx,conjg,aimag,max,sqrt ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) wantvl = stdlib_lsame( jobvl, 'V' ) wantvr = stdlib_lsame( jobvr, 'V' ) if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldazero .and. anrm0 ) then - call stdlib_${ci}$lascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, w, n, ierr ) + if( info>0_${ik}$ ) then + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, w, n, ierr ) end if end if - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_${ci}$geev + end subroutine stdlib${ii}$_${ci}$geev - subroutine stdlib_${ci}$geevx( balanc, jobvl, jobvr, sense, n, a, lda, w, vl,ldvl, vr, ldvr, ilo, & + subroutine stdlib${ii}$_${ci}$geevx( balanc, jobvl, jobvr, sense, n, a, lda, w, vl,ldvl, vr, ldvr, ilo, & !! ZGEEVX: computes for an N-by-N complex nonsymmetric matrix A, the !! eigenvalues and, optionally, the left and/or right eigenvectors. !! Optionally also, it computes a balancing transformation to improve @@ -5175,8 +5173,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: balanc, jobvl, jobvr, sense - integer(ilp), intent(out) :: ihi, ilo, info - integer(ilp), intent(in) :: lda, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: ihi, ilo, info + integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n real(${ck}$), intent(out) :: abnrm ! Array Arguments real(${ck}$), intent(out) :: rconde(*), rcondv(*), rwork(*), scale(*) @@ -5187,19 +5185,19 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: lquery, scalea, wantvl, wantvr, wntsnb, wntsne, wntsnn, wntsnv character :: job, side - integer(ilp) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, & + integer(${ik}$) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, & nout real(${ck}$) :: anrm, bignum, cscale, eps, scl, smlnum complex(${ck}$) :: tmp ! Local Arrays - logical(lk) :: select(1) - real(${ck}$) :: dum(1) + logical(lk) :: select(1_${ik}$) + real(${ck}$) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: real,cmplx,conjg,aimag,max,sqrt ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) wantvl = stdlib_lsame( jobvl, 'V' ) wantvr = stdlib_lsame( jobvr, 'V' ) wntsnn = stdlib_lsame( sense, 'N' ) @@ -5208,22 +5206,22 @@ module stdlib_linalg_lapack_${ci}$ wntsnb = stdlib_lsame( sense, 'B' ) if( .not.( stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'S' ) & .or.stdlib_lsame( balanc, 'P' ) .or. stdlib_lsame( balanc, 'B' ) ) ) then - info = -1 + info = -1_${ik}$ else if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then - info = -3 + info = -3_${ik}$ else if( .not.( wntsnn .or. wntsne .or. wntsnb .or. wntsnv ) .or.( ( wntsne .or. & wntsnb ) .and. .not.( wantvl .and.wantvr ) ) ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( ldazero .and. anrmmax( 1, n ) ) then - info = -2 + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -1_${ik}$ + else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then + info = -2_${ik}$ else if( ihin ) then - info = -3 - else if( ldamax( 1, n ) ) then - info = -2 + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) + if( n<0_${ik}$ ) then + info = -1_${ik}$ + else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then + info = -2_${ik}$ else if( ihin ) then - info = -3 - else if( lda1 .and. nb1_${ik}$ .and. nb=(n*nbmin + tsize) ) then nb = (lwork-tsize) / n else - nb = 1 + nb = 1_${ik}$ end if end if end if @@ -5590,44 +5588,44 @@ module stdlib_linalg_lapack_${ci}$ i = ilo else ! use blocked code - iwt = 1 + n*nb + iwt = 1_${ik}$ + n*nb do i = ilo, ihi - 1 - nx, nb ib = min( nb, ihi-i ) ! reduce columns i:i+ib-1 to hessenberg form, returning the ! matrices v and t of the block reflector h = i - v*t*v**h ! which performs the reduction, and also the matrix y = a*v*t - call stdlib_${ci}$lahr2( ihi, i, ib, a( 1, i ), lda, tau( i ),work( iwt ), ldt, work, & + call stdlib${ii}$_${ci}$lahr2( ihi, i, ib, a( 1_${ik}$, i ), lda, tau( i ),work( iwt ), ldt, work, & ldwork ) ! apply the block reflector h to a(1:ihi,i+ib:ihi) from the ! right, computing a := a - y * v**h. v(i+ib,ib-1) must be set ! to 1 ei = a( i+ib, i+ib-1 ) a( i+ib, i+ib-1 ) = cone - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',ihi, ihi-i-ib+1,ib, -& - cone, work, ldwork, a( i+ib, i ), lda, cone,a( 1, i+ib ), lda ) + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',ihi, ihi-i-ib+1,ib, -& + cone, work, ldwork, a( i+ib, i ), lda, cone,a( 1_${ik}$, i+ib ), lda ) a( i+ib, i+ib-1 ) = ei ! apply the block reflector h to a(1:i,i+1:i+ib-1) from the ! right - call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', i, ib-1,cone, & + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', i, ib-1,cone, & a( i+1, i ), lda, work, ldwork ) do j = 0, ib-2 - call stdlib_${ci}$axpy( i, -cone, work( ldwork*j+1 ), 1,a( 1, i+j+1 ), 1 ) + call stdlib${ii}$_${ci}$axpy( i, -cone, work( ldwork*j+1 ), 1_${ik}$,a( 1_${ik}$, i+j+1 ), 1_${ik}$ ) end do ! apply the block reflector h to a(i+1:ihi,i+ib:n) from the ! left - call stdlib_${ci}$larfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'FORWARD','COLUMNWISE',ihi-i, & + call stdlib${ii}$_${ci}$larfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'FORWARD','COLUMNWISE',ihi-i, & n-i-ib+1, ib, a( i+1, i ), lda,work( iwt ), ldt, a( i+1, i+ib ), lda,work, & ldwork ) end do end if ! use unblocked code to reduce the rest of the matrix - call stdlib_${ci}$gehd2( n, i, ihi, a, lda, tau, work, iinfo ) - work( 1 ) = lwkopt + call stdlib${ii}$_${ci}$gehd2( n, i, ihi, a, lda, tau, work, iinfo ) + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ci}$gehrd + end subroutine stdlib${ii}$_${ci}$gehrd - pure subroutine stdlib_${ci}$gejsv( joba, jobu, jobv, jobr, jobt, jobp,m, n, a, lda, sva, u, ldu, & + pure subroutine stdlib${ii}$_${ci}$gejsv( joba, jobu, jobv, jobr, jobt, jobp,m, n, a, lda, sva, u, ldu, & !! ZGEJSV: computes the singular value decomposition (SVD) of a complex M-by-N !! matrix [A], where M >= N. The SVD of [A] is written as !! [A] = [U] * [SIGMA] * [V]^*, @@ -5643,13 +5641,13 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, ldu, ldv, lwork, lrwork, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldu, ldv, lwork, lrwork, m, n ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: u(ldu,*), v(ldv,*), cwork(lwork) real(${ck}$), intent(out) :: sva(n), rwork(lrwork) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) character, intent(in) :: joba, jobp, jobr, jobt, jobu, jobv ! =========================================================================== @@ -5658,17 +5656,17 @@ module stdlib_linalg_lapack_${ci}$ complex(${ck}$) :: ctemp real(${ck}$) :: aapp, aaqq, aatmax, aatmin, big, big1, cond_ok, condr1, condr2, entra, & entrat, epsln, maxprj, scalem, sconda, sfmin, small, temp1, uscal1, uscal2, xsc - integer(ilp) :: ierr, n1, nr, numrank, p, q, warning + integer(${ik}$) :: ierr, n1, nr, numrank, p, q, warning logical(lk) :: almort, defr, errest, goscal, jracc, kill, lquery, lsvec, l2aber, & l2kill, l2pert, l2rank, l2tran, noscal, rowpiv, rsvec, transp - integer(ilp) :: optwrk, minwrk, minrwrk, miniwrk - integer(ilp) :: lwcon, lwlqf, lwqp3, lwqrf, lwunmlq, lwunmqr, lwunmqrm, lwsvdj, & + integer(${ik}$) :: optwrk, minwrk, minrwrk, miniwrk + integer(${ik}$) :: lwcon, lwlqf, lwqp3, lwqrf, lwunmlq, lwunmqr, lwunmqrm, lwsvdj, & lwsvdjv, lrwqp3, lrwcon, lrwsvdj, iwoff - integer(ilp) :: lwrk_wgelqf, lwrk_wgeqp3, lwrk_wgeqp3n, lwrk_wgeqrf, lwrk_wgesvj, & + integer(${ik}$) :: lwrk_wgelqf, lwrk_wgeqp3, lwrk_wgeqp3n, lwrk_wgeqrf, lwrk_wgesvj, & lwrk_wgesvjv, lwrk_wgesvju, lwrk_wunmlq, lwrk_wunmqr, lwrk_wunmqrm ! Local Arrays - complex(${ck}$) :: cdummy(1) - real(${ck}$) :: rdummy(1) + complex(${ck}$) :: cdummy(1_${ik}$) + real(${ck}$) :: rdummy(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,cmplx,conjg,log,max,min,real,nint,sqrt ! test the input arguments @@ -5683,88 +5681,88 @@ module stdlib_linalg_lapack_${ci}$ l2kill = stdlib_lsame( jobr, 'R' ) defr = stdlib_lsame( jobr, 'N' ) l2pert = stdlib_lsame( jobp, 'P' ) - lquery = ( lwork == -1 ) .or. ( lrwork == -1 ) + lquery = ( lwork == -1_${ik}$ ) .or. ( lrwork == -1_${ik}$ ) if ( .not.(rowpiv .or. l2rank .or. l2aber .or.errest .or. stdlib_lsame( joba, 'C' ) )) & then - info = - 1 + info = - 1_${ik}$ else if ( .not.( lsvec .or. stdlib_lsame( jobu, 'N' ) .or.( stdlib_lsame( jobu, 'W' ) & .and. rsvec .and. l2tran ) ) ) then - info = - 2 + info = - 2_${ik}$ else if ( .not.( rsvec .or. stdlib_lsame( jobv, 'N' ) .or.( stdlib_lsame( jobv, 'W' ) & .and. lsvec .and. l2tran ) ) ) then - info = - 3 + info = - 3_${ik}$ else if ( .not. ( l2kill .or. defr ) ) then - info = - 4 + info = - 4_${ik}$ else if ( .not. ( stdlib_lsame(jobt,'T') .or. stdlib_lsame(jobt,'N') ) ) then - info = - 5 + info = - 5_${ik}$ else if ( .not. ( l2pert .or. stdlib_lsame( jobp, 'N' ) ) ) then - info = - 6 - else if ( m < 0 ) then - info = - 7 - else if ( ( n < 0 ) .or. ( n > m ) ) then - info = - 8 + info = - 6_${ik}$ + else if ( m < 0_${ik}$ ) then + info = - 7_${ik}$ + else if ( ( n < 0_${ik}$ ) .or. ( n > m ) ) then + info = - 8_${ik}$ else if ( lda < m ) then - info = - 10 + info = - 10_${ik}$ else if ( lsvec .and. ( ldu < m ) ) then - info = - 13 + info = - 13_${ik}$ else if ( rsvec .and. ( ldv < n ) ) then - info = - 15 + info = - 15_${ik}$ else ! #:) - info = 0 + info = 0_${ik}$ end if - if ( info == 0 ) then + if ( info == 0_${ik}$ ) then ! Compute The Minimal And The Optimal Workspace Lengths ! [[the expressions for computing the minimal and the optimal ! values of lcwork, lrwork are written with a lot of redundancy and ! can be simplified. however, this verbose form is useful for ! maintenance and modifications of the code.]] - ! .. minimal workspace length for stdlib_${ci}$geqp3 of an m x n matrix, - ! stdlib_${ci}$geqrf of an n x n matrix, stdlib_${ci}$gelqf of an n x n matrix, - ! stdlib_${ci}$unmlq for computing n x n matrix, stdlib_${ci}$unmqr for computing n x n - ! matrix, stdlib_${ci}$unmqr for computing m x n matrix, respectively. + ! .. minimal workspace length for stdlib${ii}$_${ci}$geqp3 of an m x n matrix, + ! stdlib${ii}$_${ci}$geqrf of an n x n matrix, stdlib${ii}$_${ci}$gelqf of an n x n matrix, + ! stdlib${ii}$_${ci}$unmlq for computing n x n matrix, stdlib${ii}$_${ci}$unmqr for computing n x n + ! matrix, stdlib${ii}$_${ci}$unmqr for computing m x n matrix, respectively. lwqp3 = n+1 - lwqrf = max( 1, n ) - lwlqf = max( 1, n ) - lwunmlq = max( 1, n ) - lwunmqr = max( 1, n ) - lwunmqrm = max( 1, m ) + lwqrf = max( 1_${ik}$, n ) + lwlqf = max( 1_${ik}$, n ) + lwunmlq = max( 1_${ik}$, n ) + lwunmqr = max( 1_${ik}$, n ) + lwunmqrm = max( 1_${ik}$, m ) ! Minimal Workspace Length For Stdlib_Zpocon Of An N X N Matrix - lwcon = 2 * n - ! .. minimal workspace length for stdlib_${ci}$gesvj of an n x n matrix, + lwcon = 2_${ik}$ * n + ! .. minimal workspace length for stdlib${ii}$_${ci}$gesvj of an n x n matrix, ! without and with explicit accumulation of jacobi rotations - lwsvdj = max( 2 * n, 1 ) - lwsvdjv = max( 2 * n, 1 ) - ! .. minimal real workspace length for stdlib_${ci}$geqp3, stdlib_${ci}$pocon, stdlib_${ci}$gesvj - lrwqp3 = 2 * n + lwsvdj = max( 2_${ik}$ * n, 1_${ik}$ ) + lwsvdjv = max( 2_${ik}$ * n, 1_${ik}$ ) + ! .. minimal real workspace length for stdlib${ii}$_${ci}$geqp3, stdlib${ii}$_${ci}$pocon, stdlib${ii}$_${ci}$gesvj + lrwqp3 = 2_${ik}$ * n lrwcon = n lrwsvdj = n if ( lquery ) then - call stdlib_${ci}$geqp3( m, n, a, lda, iwork, cdummy, cdummy, -1,rdummy, ierr ) + call stdlib${ii}$_${ci}$geqp3( m, n, a, lda, iwork, cdummy, cdummy, -1_${ik}$,rdummy, ierr ) - lwrk_wgeqp3 = real( cdummy(1),KIND=${ck}$) - call stdlib_${ci}$geqrf( n, n, a, lda, cdummy, cdummy,-1, ierr ) - lwrk_wgeqrf = real( cdummy(1),KIND=${ck}$) - call stdlib_${ci}$gelqf( n, n, a, lda, cdummy, cdummy,-1, ierr ) - lwrk_wgelqf = real( cdummy(1),KIND=${ck}$) + lwrk_wgeqp3 = real( cdummy(1_${ik}$),KIND=${ck}$) + call stdlib${ii}$_${ci}$geqrf( n, n, a, lda, cdummy, cdummy,-1_${ik}$, ierr ) + lwrk_wgeqrf = real( cdummy(1_${ik}$),KIND=${ck}$) + call stdlib${ii}$_${ci}$gelqf( n, n, a, lda, cdummy, cdummy,-1_${ik}$, ierr ) + lwrk_wgelqf = real( cdummy(1_${ik}$),KIND=${ck}$) end if - minwrk = 2 - optwrk = 2 + minwrk = 2_${ik}$ + optwrk = 2_${ik}$ miniwrk = n if ( .not. (lsvec .or. rsvec ) ) then ! Minimal And Optimal Sizes Of The Complex Workspace If ! only the singular values are requested if ( errest ) then - minwrk = max( n+lwqp3, n**2+lwcon, n+lwqrf, lwsvdj ) + minwrk = max( n+lwqp3, n**2_${ik}$+lwcon, n+lwqrf, lwsvdj ) else minwrk = max( n+lwqp3, n+lwqrf, lwsvdj ) end if if ( lquery ) then - call stdlib_${ci}$gesvj( 'L', 'N', 'N', n, n, a, lda, sva, n, v,ldv, cdummy, -1,& - rdummy, -1, ierr ) - lwrk_wgesvj = real( cdummy(1),KIND=${ck}$) + call stdlib${ii}$_${ci}$gesvj( 'L', 'N', 'N', n, n, a, lda, sva, n, v,ldv, cdummy, -1_${ik}$,& + rdummy, -1_${ik}$, ierr ) + lwrk_wgesvj = real( cdummy(1_${ik}$),KIND=${ck}$) if ( errest ) then - optwrk = max( n+lwrk_wgeqp3, n**2+lwcon,n+lwrk_wgeqrf, lwrk_wgesvj ) + optwrk = max( n+lwrk_wgeqp3, n**2_${ik}$+lwcon,n+lwrk_wgeqrf, lwrk_wgesvj ) else optwrk = max( n+lwrk_wgeqp3, n+lwrk_wgeqrf,lwrk_wgesvj ) @@ -5772,15 +5770,15 @@ module stdlib_linalg_lapack_${ci}$ end if if ( l2tran .or. rowpiv ) then if ( errest ) then - minrwrk = max( 7, 2*m, lrwqp3, lrwcon, lrwsvdj ) + minrwrk = max( 7_${ik}$, 2_${ik}$*m, lrwqp3, lrwcon, lrwsvdj ) else - minrwrk = max( 7, 2*m, lrwqp3, lrwsvdj ) + minrwrk = max( 7_${ik}$, 2_${ik}$*m, lrwqp3, lrwsvdj ) end if else if ( errest ) then - minrwrk = max( 7, lrwqp3, lrwcon, lrwsvdj ) + minrwrk = max( 7_${ik}$, lrwqp3, lrwcon, lrwsvdj ) else - minrwrk = max( 7, lrwqp3, lrwsvdj ) + minrwrk = max( 7_${ik}$, lrwqp3, lrwsvdj ) end if end if if ( rowpiv .or. l2tran ) miniwrk = miniwrk + m @@ -5788,38 +5786,38 @@ module stdlib_linalg_lapack_${ci}$ ! Minimal And Optimal Sizes Of The Complex Workspace If The ! singular values and the right singular vectors are requested if ( errest ) then - minwrk = max( n+lwqp3, lwcon, lwsvdj, n+lwlqf,2*n+lwqrf, n+lwsvdj, n+& + minwrk = max( n+lwqp3, lwcon, lwsvdj, n+lwlqf,2_${ik}$*n+lwqrf, n+lwsvdj, n+& lwunmlq ) else - minwrk = max( n+lwqp3, lwsvdj, n+lwlqf, 2*n+lwqrf,n+lwsvdj, n+lwunmlq ) + minwrk = max( n+lwqp3, lwsvdj, n+lwlqf, 2_${ik}$*n+lwqrf,n+lwsvdj, n+lwunmlq ) end if if ( lquery ) then - call stdlib_${ci}$gesvj( 'L', 'U', 'N', n,n, u, ldu, sva, n, a,lda, cdummy, -1, & - rdummy, -1, ierr ) - lwrk_wgesvj = real( cdummy(1),KIND=${ck}$) - call stdlib_${ci}$unmlq( 'L', 'C', n, n, n, a, lda, cdummy,v, ldv, cdummy, -1, & + call stdlib${ii}$_${ci}$gesvj( 'L', 'U', 'N', n,n, u, ldu, sva, n, a,lda, cdummy, -1_${ik}$, & + rdummy, -1_${ik}$, ierr ) + lwrk_wgesvj = real( cdummy(1_${ik}$),KIND=${ck}$) + call stdlib${ii}$_${ci}$unmlq( 'L', 'C', n, n, n, a, lda, cdummy,v, ldv, cdummy, -1_${ik}$, & ierr ) - lwrk_wunmlq = real( cdummy(1),KIND=${ck}$) + lwrk_wunmlq = real( cdummy(1_${ik}$),KIND=${ck}$) if ( errest ) then - optwrk = max( n+lwrk_wgeqp3, lwcon, lwrk_wgesvj,n+lwrk_wgelqf, 2*n+& + optwrk = max( n+lwrk_wgeqp3, lwcon, lwrk_wgesvj,n+lwrk_wgelqf, 2_${ik}$*n+& lwrk_wgeqrf,n+lwrk_wgesvj, n+lwrk_wunmlq ) else - optwrk = max( n+lwrk_wgeqp3, lwrk_wgesvj,n+lwrk_wgelqf,2*n+lwrk_wgeqrf, n+& + optwrk = max( n+lwrk_wgeqp3, lwrk_wgesvj,n+lwrk_wgelqf,2_${ik}$*n+lwrk_wgeqrf, n+& lwrk_wgesvj,n+lwrk_wunmlq ) end if end if if ( l2tran .or. rowpiv ) then if ( errest ) then - minrwrk = max( 7, 2*m, lrwqp3, lrwsvdj, lrwcon ) + minrwrk = max( 7_${ik}$, 2_${ik}$*m, lrwqp3, lrwsvdj, lrwcon ) else - minrwrk = max( 7, 2*m, lrwqp3, lrwsvdj ) + minrwrk = max( 7_${ik}$, 2_${ik}$*m, lrwqp3, lrwsvdj ) end if else if ( errest ) then - minrwrk = max( 7, lrwqp3, lrwsvdj, lrwcon ) + minrwrk = max( 7_${ik}$, lrwqp3, lrwsvdj, lrwcon ) else - minrwrk = max( 7, lrwqp3, lrwsvdj ) + minrwrk = max( 7_${ik}$, lrwqp3, lrwsvdj ) end if end if if ( rowpiv .or. l2tran ) miniwrk = miniwrk + m @@ -5832,12 +5830,12 @@ module stdlib_linalg_lapack_${ci}$ minwrk = n + max( lwqp3, n+lwqrf, lwsvdj, lwunmqrm ) end if if ( lquery ) then - call stdlib_${ci}$gesvj( 'L', 'U', 'N', n,n, u, ldu, sva, n, a,lda, cdummy, -1, & - rdummy, -1, ierr ) - lwrk_wgesvj = real( cdummy(1),KIND=${ck}$) - call stdlib_${ci}$unmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -1, & + call stdlib${ii}$_${ci}$gesvj( 'L', 'U', 'N', n,n, u, ldu, sva, n, a,lda, cdummy, -1_${ik}$, & + rdummy, -1_${ik}$, ierr ) + lwrk_wgesvj = real( cdummy(1_${ik}$),KIND=${ck}$) + call stdlib${ii}$_${ci}$unmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -1_${ik}$, & ierr ) - lwrk_wunmqrm = real( cdummy(1),KIND=${ck}$) + lwrk_wunmqrm = real( cdummy(1_${ik}$),KIND=${ck}$) if ( errest ) then optwrk = n + max( lwrk_wgeqp3, lwcon, n+lwrk_wgeqrf,lwrk_wgesvj, & lwrk_wunmqrm ) @@ -5848,15 +5846,15 @@ module stdlib_linalg_lapack_${ci}$ end if if ( l2tran .or. rowpiv ) then if ( errest ) then - minrwrk = max( 7, 2*m, lrwqp3, lrwsvdj, lrwcon ) + minrwrk = max( 7_${ik}$, 2_${ik}$*m, lrwqp3, lrwsvdj, lrwcon ) else - minrwrk = max( 7, 2*m, lrwqp3, lrwsvdj ) + minrwrk = max( 7_${ik}$, 2_${ik}$*m, lrwqp3, lrwsvdj ) end if else if ( errest ) then - minrwrk = max( 7, lrwqp3, lrwsvdj, lrwcon ) + minrwrk = max( 7_${ik}$, lrwqp3, lrwsvdj, lrwcon ) else - minrwrk = max( 7, lrwqp3, lrwsvdj ) + minrwrk = max( 7_${ik}$, lrwqp3, lrwsvdj ) end if end if if ( rowpiv .or. l2tran ) miniwrk = miniwrk + m @@ -5865,108 +5863,108 @@ module stdlib_linalg_lapack_${ci}$ ! full svd is requested if ( .not. jracc ) then if ( errest ) then - minwrk = max( n+lwqp3, n+lwcon, 2*n+n**2+lwcon,2*n+lwqrf, 2*n+& - lwqp3,2*n+n**2+n+lwlqf, 2*n+n**2+n+n**2+lwcon,2*n+n**2+n+lwsvdj, 2*n+& - n**2+n+lwsvdjv,2*n+n**2+n+lwunmqr,2*n+n**2+n+lwunmlq,n+n**2+lwsvdj, n+& + minwrk = max( n+lwqp3, n+lwcon, 2_${ik}$*n+n**2_${ik}$+lwcon,2_${ik}$*n+lwqrf, 2_${ik}$*n+& + lwqp3,2_${ik}$*n+n**2_${ik}$+n+lwlqf, 2_${ik}$*n+n**2_${ik}$+n+n**2_${ik}$+lwcon,2_${ik}$*n+n**2_${ik}$+n+lwsvdj, 2_${ik}$*n+& + n**2_${ik}$+n+lwsvdjv,2_${ik}$*n+n**2_${ik}$+n+lwunmqr,2_${ik}$*n+n**2_${ik}$+n+lwunmlq,n+n**2_${ik}$+lwsvdj, n+& lwunmqrm ) else - minwrk = max( n+lwqp3, 2*n+n**2+lwcon,2*n+lwqrf, 2*n+& - lwqp3,2*n+n**2+n+lwlqf, 2*n+n**2+n+n**2+lwcon,2*n+n**2+n+lwsvdj, 2*n+& - n**2+n+lwsvdjv,2*n+n**2+n+lwunmqr,2*n+n**2+n+lwunmlq,n+n**2+lwsvdj, & + minwrk = max( n+lwqp3, 2_${ik}$*n+n**2_${ik}$+lwcon,2_${ik}$*n+lwqrf, 2_${ik}$*n+& + lwqp3,2_${ik}$*n+n**2_${ik}$+n+lwlqf, 2_${ik}$*n+n**2_${ik}$+n+n**2_${ik}$+lwcon,2_${ik}$*n+n**2_${ik}$+n+lwsvdj, 2_${ik}$*n+& + n**2_${ik}$+n+lwsvdjv,2_${ik}$*n+n**2_${ik}$+n+lwunmqr,2_${ik}$*n+n**2_${ik}$+n+lwunmlq,n+n**2_${ik}$+lwsvdj, & n+lwunmqrm ) end if miniwrk = miniwrk + n if ( rowpiv .or. l2tran ) miniwrk = miniwrk + m else if ( errest ) then - minwrk = max( n+lwqp3, n+lwcon, 2*n+lwqrf,2*n+n**2+lwsvdjv, 2*n+n**2+n+& + minwrk = max( n+lwqp3, n+lwcon, 2_${ik}$*n+lwqrf,2_${ik}$*n+n**2_${ik}$+lwsvdjv, 2_${ik}$*n+n**2_${ik}$+n+& lwunmqr,n+lwunmqrm ) else - minwrk = max( n+lwqp3, 2*n+lwqrf,2*n+n**2+lwsvdjv, 2*n+n**2+n+lwunmqr,n+& + minwrk = max( n+lwqp3, 2_${ik}$*n+lwqrf,2_${ik}$*n+n**2_${ik}$+lwsvdjv, 2_${ik}$*n+n**2_${ik}$+n+lwunmqr,n+& lwunmqrm ) end if if ( rowpiv .or. l2tran ) miniwrk = miniwrk + m end if if ( lquery ) then - call stdlib_${ci}$unmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -1, & + call stdlib${ii}$_${ci}$unmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -1_${ik}$, & ierr ) - lwrk_wunmqrm = real( cdummy(1),KIND=${ck}$) - call stdlib_${ci}$unmqr( 'L', 'N', n, n, n, a, lda, cdummy, u,ldu, cdummy, -1, & + lwrk_wunmqrm = real( cdummy(1_${ik}$),KIND=${ck}$) + call stdlib${ii}$_${ci}$unmqr( 'L', 'N', n, n, n, a, lda, cdummy, u,ldu, cdummy, -1_${ik}$, & ierr ) - lwrk_wunmqr = real( cdummy(1),KIND=${ck}$) + lwrk_wunmqr = real( cdummy(1_${ik}$),KIND=${ck}$) if ( .not. jracc ) then - call stdlib_${ci}$geqp3( n,n, a, lda, iwork, cdummy,cdummy, -1,rdummy, ierr ) + call stdlib${ii}$_${ci}$geqp3( n,n, a, lda, iwork, cdummy,cdummy, -1_${ik}$,rdummy, ierr ) - lwrk_wgeqp3n = real( cdummy(1),KIND=${ck}$) - call stdlib_${ci}$gesvj( 'L', 'U', 'N', n, n, u, ldu, sva,n, v, ldv, cdummy, & - -1, rdummy, -1, ierr ) - lwrk_wgesvj = real( cdummy(1),KIND=${ck}$) - call stdlib_${ci}$gesvj( 'U', 'U', 'N', n, n, u, ldu, sva,n, v, ldv, cdummy, & - -1, rdummy, -1, ierr ) - lwrk_wgesvju = real( cdummy(1),KIND=${ck}$) - call stdlib_${ci}$gesvj( 'L', 'U', 'V', n, n, u, ldu, sva,n, v, ldv, cdummy, & - -1, rdummy, -1, ierr ) - lwrk_wgesvjv = real( cdummy(1),KIND=${ck}$) - call stdlib_${ci}$unmlq( 'L', 'C', n, n, n, a, lda, cdummy,v, ldv, cdummy, -& - 1, ierr ) - lwrk_wunmlq = real( cdummy(1),KIND=${ck}$) + lwrk_wgeqp3n = real( cdummy(1_${ik}$),KIND=${ck}$) + call stdlib${ii}$_${ci}$gesvj( 'L', 'U', 'N', n, n, u, ldu, sva,n, v, ldv, cdummy, & + -1_${ik}$, rdummy, -1_${ik}$, ierr ) + lwrk_wgesvj = real( cdummy(1_${ik}$),KIND=${ck}$) + call stdlib${ii}$_${ci}$gesvj( 'U', 'U', 'N', n, n, u, ldu, sva,n, v, ldv, cdummy, & + -1_${ik}$, rdummy, -1_${ik}$, ierr ) + lwrk_wgesvju = real( cdummy(1_${ik}$),KIND=${ck}$) + call stdlib${ii}$_${ci}$gesvj( 'L', 'U', 'V', n, n, u, ldu, sva,n, v, ldv, cdummy, & + -1_${ik}$, rdummy, -1_${ik}$, ierr ) + lwrk_wgesvjv = real( cdummy(1_${ik}$),KIND=${ck}$) + call stdlib${ii}$_${ci}$unmlq( 'L', 'C', n, n, n, a, lda, cdummy,v, ldv, cdummy, -& + 1_${ik}$, ierr ) + lwrk_wunmlq = real( cdummy(1_${ik}$),KIND=${ck}$) if ( errest ) then - optwrk = max( n+lwrk_wgeqp3, n+lwcon,2*n+n**2+lwcon, 2*n+lwrk_wgeqrf,& - 2*n+lwrk_wgeqp3n,2*n+n**2+n+lwrk_wgelqf,2*n+n**2+n+n**2+lwcon,2*n+& - n**2+n+lwrk_wgesvj,2*n+n**2+n+lwrk_wgesvjv,2*n+n**2+n+lwrk_wunmqr,2*n+& - n**2+n+lwrk_wunmlq,n+n**2+lwrk_wgesvju,n+lwrk_wunmqrm ) + optwrk = max( n+lwrk_wgeqp3, n+lwcon,2_${ik}$*n+n**2_${ik}$+lwcon, 2_${ik}$*n+lwrk_wgeqrf,& + 2_${ik}$*n+lwrk_wgeqp3n,2_${ik}$*n+n**2_${ik}$+n+lwrk_wgelqf,2_${ik}$*n+n**2_${ik}$+n+n**2_${ik}$+lwcon,2_${ik}$*n+& + n**2_${ik}$+n+lwrk_wgesvj,2_${ik}$*n+n**2_${ik}$+n+lwrk_wgesvjv,2_${ik}$*n+n**2_${ik}$+n+lwrk_wunmqr,2_${ik}$*n+& + n**2_${ik}$+n+lwrk_wunmlq,n+n**2_${ik}$+lwrk_wgesvju,n+lwrk_wunmqrm ) else - optwrk = max( n+lwrk_wgeqp3,2*n+n**2+lwcon, 2*n+lwrk_wgeqrf,2*n+& - lwrk_wgeqp3n,2*n+n**2+n+lwrk_wgelqf,2*n+n**2+n+n**2+lwcon,2*n+n**2+n+& - lwrk_wgesvj,2*n+n**2+n+lwrk_wgesvjv,2*n+n**2+n+lwrk_wunmqr,2*n+n**2+n+& - lwrk_wunmlq,n+n**2+lwrk_wgesvju,n+lwrk_wunmqrm ) + optwrk = max( n+lwrk_wgeqp3,2_${ik}$*n+n**2_${ik}$+lwcon, 2_${ik}$*n+lwrk_wgeqrf,2_${ik}$*n+& + lwrk_wgeqp3n,2_${ik}$*n+n**2_${ik}$+n+lwrk_wgelqf,2_${ik}$*n+n**2_${ik}$+n+n**2_${ik}$+lwcon,2_${ik}$*n+n**2_${ik}$+n+& + lwrk_wgesvj,2_${ik}$*n+n**2_${ik}$+n+lwrk_wgesvjv,2_${ik}$*n+n**2_${ik}$+n+lwrk_wunmqr,2_${ik}$*n+n**2_${ik}$+n+& + lwrk_wunmlq,n+n**2_${ik}$+lwrk_wgesvju,n+lwrk_wunmqrm ) end if else - call stdlib_${ci}$gesvj( 'L', 'U', 'V', n, n, u, ldu, sva,n, v, ldv, cdummy, & - -1, rdummy, -1, ierr ) - lwrk_wgesvjv = real( cdummy(1),KIND=${ck}$) - call stdlib_${ci}$unmqr( 'L', 'N', n, n, n, cdummy, n, cdummy,v, ldv, cdummy,& - -1, ierr ) - lwrk_wunmqr = real( cdummy(1),KIND=${ck}$) - call stdlib_${ci}$unmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -& - 1, ierr ) - lwrk_wunmqrm = real( cdummy(1),KIND=${ck}$) + call stdlib${ii}$_${ci}$gesvj( 'L', 'U', 'V', n, n, u, ldu, sva,n, v, ldv, cdummy, & + -1_${ik}$, rdummy, -1_${ik}$, ierr ) + lwrk_wgesvjv = real( cdummy(1_${ik}$),KIND=${ck}$) + call stdlib${ii}$_${ci}$unmqr( 'L', 'N', n, n, n, cdummy, n, cdummy,v, ldv, cdummy,& + -1_${ik}$, ierr ) + lwrk_wunmqr = real( cdummy(1_${ik}$),KIND=${ck}$) + call stdlib${ii}$_${ci}$unmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -& + 1_${ik}$, ierr ) + lwrk_wunmqrm = real( cdummy(1_${ik}$),KIND=${ck}$) if ( errest ) then - optwrk = max( n+lwrk_wgeqp3, n+lwcon,2*n+lwrk_wgeqrf, 2*n+n**2,2*n+& - n**2+lwrk_wgesvjv,2*n+n**2+n+lwrk_wunmqr,n+lwrk_wunmqrm ) + optwrk = max( n+lwrk_wgeqp3, n+lwcon,2_${ik}$*n+lwrk_wgeqrf, 2_${ik}$*n+n**2_${ik}$,2_${ik}$*n+& + n**2_${ik}$+lwrk_wgesvjv,2_${ik}$*n+n**2_${ik}$+n+lwrk_wunmqr,n+lwrk_wunmqrm ) else - optwrk = max( n+lwrk_wgeqp3, 2*n+lwrk_wgeqrf,2*n+n**2, 2*n+n**2+& - lwrk_wgesvjv,2*n+n**2+n+lwrk_wunmqr,n+lwrk_wunmqrm ) + optwrk = max( n+lwrk_wgeqp3, 2_${ik}$*n+lwrk_wgeqrf,2_${ik}$*n+n**2_${ik}$, 2_${ik}$*n+n**2_${ik}$+& + lwrk_wgesvjv,2_${ik}$*n+n**2_${ik}$+n+lwrk_wunmqr,n+lwrk_wunmqrm ) end if end if end if if ( l2tran .or. rowpiv ) then - minrwrk = max( 7, 2*m, lrwqp3, lrwsvdj, lrwcon ) + minrwrk = max( 7_${ik}$, 2_${ik}$*m, lrwqp3, lrwsvdj, lrwcon ) else - minrwrk = max( 7, lrwqp3, lrwsvdj, lrwcon ) + minrwrk = max( 7_${ik}$, lrwqp3, lrwsvdj, lrwcon ) end if end if - minwrk = max( 2, minwrk ) + minwrk = max( 2_${ik}$, minwrk ) optwrk = max( minwrk, optwrk ) - if ( lwork < minwrk .and. (.not.lquery) ) info = - 17 - if ( lrwork < minrwrk .and. (.not.lquery) ) info = - 19 + if ( lwork < minwrk .and. (.not.lquery) ) info = - 17_${ik}$ + if ( lrwork < minrwrk .and. (.not.lquery) ) info = - 19_${ik}$ end if - if ( info /= 0 ) then + if ( info /= 0_${ik}$ ) then ! #:( - call stdlib_xerbla( 'ZGEJSV', - info ) + call stdlib${ii}$_xerbla( 'ZGEJSV', - info ) return else if ( lquery ) then - cwork(1) = optwrk - cwork(2) = minwrk - rwork(1) = minrwrk - iwork(1) = max( 4, miniwrk ) + cwork(1_${ik}$) = optwrk + cwork(2_${ik}$) = minwrk + rwork(1_${ik}$) = minrwrk + iwork(1_${ik}$) = max( 4_${ik}$, miniwrk ) return end if ! quick return for void matrix (y3k safe) ! #:) - if ( ( m == 0 ) .or. ( n == 0 ) ) then - iwork(1:4) = 0 - rwork(1:7) = 0 + if ( ( m == 0_${ik}$ ) .or. ( n == 0_${ik}$ ) ) then + iwork(1_${ik}$:4_${ik}$) = 0_${ik}$ + rwork(1_${ik}$:7_${ik}$) = 0_${ik}$ return endif ! determine whether the matrix u should be m x n or m x m @@ -5975,11 +5973,11 @@ module stdlib_linalg_lapack_${ci}$ if ( stdlib_lsame( jobu, 'F' ) ) n1 = m end if ! set numerical parameters - ! ! note: make sure stdlib_${c2ri(ci)}$lamch() does not fail on the target architecture. - epsln = stdlib_${c2ri(ci)}$lamch('EPSILON') - sfmin = stdlib_${c2ri(ci)}$lamch('SAFEMINIMUM') + ! ! note: make sure stdlib${ii}$_${c2ri(ci)}$lamch() does not fail on the target architecture. + epsln = stdlib${ii}$_${c2ri(ci)}$lamch('EPSILON') + sfmin = stdlib${ii}$_${c2ri(ci)}$lamch('SAFEMINIMUM') small = sfmin / epsln - big = stdlib_${c2ri(ci)}$lamch('O') + big = stdlib${ii}$_${c2ri(ci)}$lamch('O') ! big = one / sfmin ! initialize sva(1:n) = diag( ||a e_i||_2 )_1^n ! (!) if necessary, scale sva() to protect the largest norm from @@ -5991,10 +5989,10 @@ module stdlib_linalg_lapack_${ci}$ do p = 1, n aapp = zero aaqq = one - call stdlib_${ci}$lassq( m, a(1,p), 1, aapp, aaqq ) + call stdlib${ii}$_${ci}$lassq( m, a(1_${ik}$,p), 1_${ik}$, aapp, aaqq ) if ( aapp > big ) then - info = - 9 - call stdlib_xerbla( 'ZGEJSV', -info ) + info = - 9_${ik}$ + call stdlib${ii}$_xerbla( 'ZGEJSV', -info ) return end if aaqq = sqrt(aaqq) @@ -6005,7 +6003,7 @@ module stdlib_linalg_lapack_${ci}$ sva(p) = aapp * ( aaqq * scalem ) if ( goscal ) then goscal = .false. - call stdlib_${c2ri(ci)}$scal( p-1, scalem, sva, 1 ) + call stdlib${ii}$_${c2ri(ci)}$scal( p-1, scalem, sva, 1_${ik}$ ) end if end if end do @@ -6019,78 +6017,78 @@ module stdlib_linalg_lapack_${ci}$ ! quick return for zero m x n matrix ! #:) if ( aapp == zero ) then - if ( lsvec ) call stdlib_${ci}$laset( 'G', m, n1, czero, cone, u, ldu ) - if ( rsvec ) call stdlib_${ci}$laset( 'G', n, n, czero, cone, v, ldv ) - rwork(1) = one - rwork(2) = one - if ( errest ) rwork(3) = one + if ( lsvec ) call stdlib${ii}$_${ci}$laset( 'G', m, n1, czero, cone, u, ldu ) + if ( rsvec ) call stdlib${ii}$_${ci}$laset( 'G', n, n, czero, cone, v, ldv ) + rwork(1_${ik}$) = one + rwork(2_${ik}$) = one + if ( errest ) rwork(3_${ik}$) = one if ( lsvec .and. rsvec ) then - rwork(4) = one - rwork(5) = one + rwork(4_${ik}$) = one + rwork(5_${ik}$) = one end if if ( l2tran ) then - rwork(6) = zero - rwork(7) = zero + rwork(6_${ik}$) = zero + rwork(7_${ik}$) = zero end if - iwork(1) = 0 - iwork(2) = 0 - iwork(3) = 0 - iwork(4) = -1 + iwork(1_${ik}$) = 0_${ik}$ + iwork(2_${ik}$) = 0_${ik}$ + iwork(3_${ik}$) = 0_${ik}$ + iwork(4_${ik}$) = -1_${ik}$ return end if ! issue warning if denormalized column norms detected. override the ! high relative accuracy request. issue licence to kill nonzero columns ! (set them to zero) whose norm is less than sigma_max / big (roughly). ! #:( - warning = 0 + warning = 0_${ik}$ if ( aaqq <= sfmin ) then l2rank = .true. l2kill = .true. - warning = 1 + warning = 1_${ik}$ end if ! quick return for one-column matrix ! #:) - if ( n == 1 ) then + if ( n == 1_${ik}$ ) then if ( lsvec ) then - call stdlib_${ci}$lascl( 'G',0,0,sva(1),scalem, m,1,a(1,1),lda,ierr ) - call stdlib_${ci}$lacpy( 'A', m, 1, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$lascl( 'G',0_${ik}$,0_${ik}$,sva(1_${ik}$),scalem, m,1_${ik}$,a(1_${ik}$,1_${ik}$),lda,ierr ) + call stdlib${ii}$_${ci}$lacpy( 'A', m, 1_${ik}$, a, lda, u, ldu ) ! computing all m left singular vectors of the m x 1 matrix if ( n1 /= n ) then - call stdlib_${ci}$geqrf( m, n, u,ldu, cwork, cwork(n+1),lwork-n,ierr ) - call stdlib_${ci}$ungqr( m,n1,1, u,ldu,cwork,cwork(n+1),lwork-n,ierr ) - call stdlib_${ci}$copy( m, a(1,1), 1, u(1,1), 1 ) + call stdlib${ii}$_${ci}$geqrf( m, n, u,ldu, cwork, cwork(n+1),lwork-n,ierr ) + call stdlib${ii}$_${ci}$ungqr( m,n1,1_${ik}$, u,ldu,cwork,cwork(n+1),lwork-n,ierr ) + call stdlib${ii}$_${ci}$copy( m, a(1_${ik}$,1_${ik}$), 1_${ik}$, u(1_${ik}$,1_${ik}$), 1_${ik}$ ) end if end if if ( rsvec ) then - v(1,1) = cone + v(1_${ik}$,1_${ik}$) = cone end if - if ( sva(1) < (big*scalem) ) then - sva(1) = sva(1) / scalem + if ( sva(1_${ik}$) < (big*scalem) ) then + sva(1_${ik}$) = sva(1_${ik}$) / scalem scalem = one end if - rwork(1) = one / scalem - rwork(2) = one - if ( sva(1) /= zero ) then - iwork(1) = 1 - if ( ( sva(1) / scalem) >= sfmin ) then - iwork(2) = 1 + rwork(1_${ik}$) = one / scalem + rwork(2_${ik}$) = one + if ( sva(1_${ik}$) /= zero ) then + iwork(1_${ik}$) = 1_${ik}$ + if ( ( sva(1_${ik}$) / scalem) >= sfmin ) then + iwork(2_${ik}$) = 1_${ik}$ else - iwork(2) = 0 + iwork(2_${ik}$) = 0_${ik}$ end if else - iwork(1) = 0 - iwork(2) = 0 + iwork(1_${ik}$) = 0_${ik}$ + iwork(2_${ik}$) = 0_${ik}$ end if - iwork(3) = 0 - iwork(4) = -1 - if ( errest ) rwork(3) = one + iwork(3_${ik}$) = 0_${ik}$ + iwork(4_${ik}$) = -1_${ik}$ + if ( errest ) rwork(3_${ik}$) = one if ( lsvec .and. rsvec ) then - rwork(4) = one - rwork(5) = one + rwork(4_${ik}$) = one + rwork(5_${ik}$) = one end if if ( l2tran ) then - rwork(6) = zero - rwork(7) = zero + rwork(6_${ik}$) = zero + rwork(7_${ik}$) = zero end if return end if @@ -6106,8 +6104,8 @@ module stdlib_linalg_lapack_${ci}$ do p = 1, m xsc = zero temp1 = one - call stdlib_${ci}$lassq( n, a(p,1), lda, xsc, temp1 ) - ! stdlib_${ci}$lassq gets both the ell_2 and the ell_infinity norm + call stdlib${ii}$_${ci}$lassq( n, a(p,1_${ik}$), lda, xsc, temp1 ) + ! stdlib${ii}$_${ci}$lassq gets both the ell_2 and the ell_infinity norm ! in one pass through the vector rwork(m+p) = xsc * scalem rwork(p) = xsc * (scalem*sqrt(temp1)) @@ -6116,7 +6114,7 @@ module stdlib_linalg_lapack_${ci}$ end do else do p = 1, m - rwork(m+p) = scalem*abs( a(p,stdlib_i${ci}$amax(n,a(p,1),lda)) ) + rwork(m+p) = scalem*abs( a(p,stdlib${ii}$_i${ci}$amax(n,a(p,1_${ik}$),lda)) ) aatmax = max( aatmax, rwork(m+p) ) aatmin = min( aatmin, rwork(m+p) ) end do @@ -6133,11 +6131,11 @@ module stdlib_linalg_lapack_${ci}$ if ( l2tran ) then xsc = zero temp1 = one - call stdlib_${c2ri(ci)}$lassq( n, sva, 1, xsc, temp1 ) + call stdlib${ii}$_${c2ri(ci)}$lassq( n, sva, 1_${ik}$, xsc, temp1 ) temp1 = one / temp1 entra = zero do p = 1, n - big1 = ( ( sva(p) / xsc )**2 ) * temp1 + big1 = ( ( sva(p) / xsc )**2_${ik}$ ) * temp1 if ( big1 /= zero ) entra = entra + big1 * log(big1) end do entra = - entra / log(real(n,KIND=${ck}$)) @@ -6148,7 +6146,7 @@ module stdlib_linalg_lapack_${ci}$ ! same trace. entrat = zero do p = 1, m - big1 = ( ( rwork(p) / xsc )**2 ) * temp1 + big1 = ( ( rwork(p) / xsc )**2_${ik}$ ) * temp1 if ( big1 /= zero ) entrat = entrat + big1 * log(big1) end do entrat = - entrat / log(real(m,KIND=${ck}$)) @@ -6192,25 +6190,25 @@ module stdlib_linalg_lapack_${ci}$ ! scale the matrix so that its maximal singular value remains less ! than sqrt(big) -- the matrix is scaled so that its maximal column ! has euclidean norm equal to sqrt(big/n). the only reason to keep - ! sqrt(big) instead of big is the fact that stdlib_${ci}$gejsv uses lapack and + ! sqrt(big) instead of big is the fact that stdlib${ii}$_${ci}$gejsv uses lapack and ! blas routines that, in some implementations, are not capable of ! working in the full interval [sfmin,big] and that they may provoke ! overflows in the intermediate results. if the singular values spread - ! from sfmin to big, then stdlib_${ci}$gesvj will compute them. so, in that case, - ! one should use stdlib_${ci}$gesvj instead of stdlib_${ci}$gejsv. + ! from sfmin to big, then stdlib${ii}$_${ci}$gesvj will compute them. so, in that case, + ! one should use stdlib_${ci}$gesvj instead of stdlib${ii}$_${ci}$gejsv. ! >> change in the april 2016 update: allow bigger range, i.e. the - ! largest column is allowed up to big/n and stdlib_${ci}$gesvj will do the rest. + ! largest column is allowed up to big/n and stdlib${ii}$_${ci}$gesvj will do the rest. big1 = sqrt( big ) temp1 = sqrt( big / real(n,KIND=${ck}$) ) ! temp1 = big/real(n,KIND=${ck}$) - call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, aapp, temp1, n, 1, sva, n, ierr ) + call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, temp1, n, 1_${ik}$, sva, n, ierr ) if ( aaqq > (aapp * sfmin) ) then aaqq = ( aaqq / aapp ) * temp1 else aaqq = ( aaqq * temp1 ) / aapp end if temp1 = temp1 * scalem - call stdlib_${ci}$lascl( 'G', 0, 0, aapp, temp1, m, n, a, lda, ierr ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, temp1, m, n, a, lda, ierr ) ! to undo scaling at the end of this procedure, multiply the ! computed singular values with uscal2 / uscal1. uscal1 = temp1 @@ -6224,7 +6222,7 @@ module stdlib_linalg_lapack_${ci}$ xsc = small ! now, if the condition number of a is too big, ! sigma_max(a) / sigma_min(a) > sqrt(big/n) * epsln / sfmin, - ! as a precaution measure, the full svd is computed using stdlib_${ci}$gesvj + ! as a precaution measure, the full svd is computed using stdlib${ii}$_${ci}$gesvj ! with accumulated jacobi rotations. this provides numerically ! more robust computation, at the cost of slightly increased run ! time. depending on the concrete implementation of blas and lapack @@ -6237,7 +6235,7 @@ module stdlib_linalg_lapack_${ci}$ if ( aaqq < xsc ) then do p = 1, n if ( sva(p) < xsc ) then - call stdlib_${ci}$laset( 'A', m, 1, czero, czero, a(1,p), lda ) + call stdlib${ii}$_${ci}$laset( 'A', m, 1_${ik}$, czero, czero, a(1_${ik}$,p), lda ) sva(p) = zero end if end do @@ -6250,12 +6248,12 @@ module stdlib_linalg_lapack_${ci}$ ! has similar effect as powell-reid complete pivoting. ! the ell-infinity norms of a are made nonincreasing. if ( ( lsvec .and. rsvec ) .and. .not.( jracc ) ) then - iwoff = 2*n + iwoff = 2_${ik}$*n else iwoff = n end if do p = 1, m - 1 - q = stdlib_i${c2ri(ci)}$amax( m-p+1, rwork(m+p), 1 ) + p - 1 + q = stdlib${ii}$_i${c2ri(ci)}$amax( m-p+1, rwork(m+p), 1_${ik}$ ) + p - 1_${ik}$ iwork(iwoff+p) = q if ( p /= q ) then temp1 = rwork(m+p) @@ -6263,7 +6261,7 @@ module stdlib_linalg_lapack_${ci}$ rwork(m+q) = temp1 end if end do - call stdlib_${ci}$laswp( n, a, lda, 1, m-1, iwork(iwoff+1), 1 ) + call stdlib${ii}$_${ci}$laswp( n, a, lda, 1_${ik}$, m-1, iwork(iwoff+1), 1_${ik}$ ) end if ! end of the preparation phase (scaling, optional sorting and ! transposing, optional flushing of small columns). @@ -6275,47 +6273,45 @@ module stdlib_linalg_lapack_${ci}$ ! (eg speed by replacing global with restricted window pivoting, such ! as in xgeqpx from toms # 782). good results will be obtained using ! xgeqpx with properly (!) chosen numerical parameters. - ! any improvement of stdlib_${ci}$geqp3 improves overall performance of stdlib_${ci}$gejsv. + ! any improvement of stdlib${ii}$_${ci}$geqp3 improves overall performance of stdlib${ii}$_${ci}$gejsv. ! a * p1 = q1 * [ r1^* 0]^*: do p = 1, n ! All Columns Are Free Columns - iwork(p) = 0 + iwork(p) = 0_${ik}$ end do - call stdlib_${ci}$geqp3( m, n, a, lda, iwork, cwork, cwork(n+1), lwork-n,rwork, ierr ) + call stdlib${ii}$_${ci}$geqp3( m, n, a, lda, iwork, cwork, cwork(n+1), lwork-n,rwork, ierr ) ! the upper triangular matrix r1 from the first qrf is inspected for ! rank deficiency and possibilities for deflation, or possible ! ill-conditioning. depending on the user specified flag l2rank, ! the procedure explores possibilities to reduce the numerical ! rank by inspecting the computed upper triangular factor. if - ! l2rank or l2aber are up, then stdlib_${ci}$gejsv will compute the svd of + ! l2rank or l2aber are up, then stdlib${ii}$_${ci}$gejsv will compute the svd of ! a + da, where ||da|| <= f(m,n)*epsln. - nr = 1 + nr = 1_${ik}$ if ( l2aber ) then ! standard absolute error bound suffices. all sigma_i with ! sigma_i < n*epsln*||a|| are flushed to zero. this is an ! aggressive enforcement of lower numerical rank by introducing a ! backward error of the order of n*epsln*||a||. temp1 = sqrt(real(n,KIND=${ck}$))*epsln - do p = 2, n - if ( abs(a(p,p)) >= (temp1*abs(a(1,1))) ) then - nr = nr + 1 + loop_3002: do p = 2, n + if ( abs(a(p,p)) >= (temp1*abs(a(1_${ik}$,1_${ik}$))) ) then + nr = nr + 1_${ik}$ else - go to 3002 + exit loop_3002 end if - end do - 3002 continue + end do loop_3002 else if ( l2rank ) then ! .. similarly as above, only slightly more gentle (less aggressive). ! sudden drop on the diagonal of r1 is used as the criterion for ! close-to-rank-deficient. temp1 = sqrt(sfmin) - do p = 2, n + loop_3402: do p = 2, n if ( ( abs(a(p,p)) < (epsln*abs(a(p-1,p-1))) ) .or.( abs(a(p,p)) < small ) .or.( & - l2kill .and. (abs(a(p,p)) < temp1) ) ) go to 3402 - nr = nr + 1 - end do - 3402 continue + l2kill .and. (abs(a(p,p)) < temp1) ) ) exit loop_3402 + nr = nr + 1_${ik}$ + end do loop_3402 else ! the goal is high relative accuracy. however, if the matrix ! has high scaled condition number the relative accuracy is in @@ -6325,12 +6321,11 @@ module stdlib_linalg_lapack_${ci}$ ! factor. this prevents the situation in which the code is ! working hard to get the accuracy not warranted by the data. temp1 = sqrt(sfmin) - do p = 2, n - if ( ( abs(a(p,p)) < small ) .or.( l2kill .and. (abs(a(p,p)) < temp1) ) ) go to & - 3302 - nr = nr + 1 - end do - 3302 continue + loop_3302: do p = 2, n + if ( ( abs(a(p,p)) < small ) .or.( l2kill .and. (abs(a(p,p)) < temp1) ) ) exit loop_3302 + nr = nr + 1_${ik}$ + end do loop_3302 + end if almort = .false. if ( nr == n ) then @@ -6339,7 +6334,7 @@ module stdlib_linalg_lapack_${ci}$ temp1 = abs(a(p,p)) / sva(iwork(p)) maxprj = min( maxprj, temp1 ) end do - if ( maxprj**2 >= one - real(n,KIND=${ck}$)*epsln ) almort = .true. + if ( maxprj**2_${ik}$ >= one - real(n,KIND=${ck}$)*epsln ) almort = .true. end if sconda = - one condr1 = - one @@ -6348,41 +6343,41 @@ module stdlib_linalg_lapack_${ci}$ if ( n == nr ) then if ( rsvec ) then ! V Is Available As Workspace - call stdlib_${ci}$lacpy( 'U', n, n, a, lda, v, ldv ) + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, a, lda, v, ldv ) do p = 1, n temp1 = sva(iwork(p)) - call stdlib_${ci}$dscal( p, one/temp1, v(1,p), 1 ) + call stdlib${ii}$_${ci}$dscal( p, one/temp1, v(1_${ik}$,p), 1_${ik}$ ) end do if ( lsvec )then - call stdlib_${ci}$pocon( 'U', n, v, ldv, one, temp1,cwork(n+1), rwork, ierr ) + call stdlib${ii}$_${ci}$pocon( 'U', n, v, ldv, one, temp1,cwork(n+1), rwork, ierr ) else - call stdlib_${ci}$pocon( 'U', n, v, ldv, one, temp1,cwork, rwork, ierr ) + call stdlib${ii}$_${ci}$pocon( 'U', n, v, ldv, one, temp1,cwork, rwork, ierr ) end if else if ( lsvec ) then ! U Is Available As Workspace - call stdlib_${ci}$lacpy( 'U', n, n, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, a, lda, u, ldu ) do p = 1, n temp1 = sva(iwork(p)) - call stdlib_${ci}$dscal( p, one/temp1, u(1,p), 1 ) + call stdlib${ii}$_${ci}$dscal( p, one/temp1, u(1_${ik}$,p), 1_${ik}$ ) end do - call stdlib_${ci}$pocon( 'U', n, u, ldu, one, temp1,cwork(n+1), rwork, ierr ) + call stdlib${ii}$_${ci}$pocon( 'U', n, u, ldu, one, temp1,cwork(n+1), rwork, ierr ) else - call stdlib_${ci}$lacpy( 'U', n, n, a, lda, cwork, n ) - ! [] call stdlib_${ci}$lacpy( 'u', n, n, a, lda, cwork(n+1), n ) + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, a, lda, cwork, n ) + ! [] call stdlib${ii}$_${ci}$lacpy( 'u', n, n, a, lda, cwork(n+1), n ) ! change: here index shifted by n to the left, cwork(1:n) ! not needed for sigma only computation do p = 1, n temp1 = sva(iwork(p)) - ! [] call stdlib_${ci}$dscal( p, one/temp1, cwork(n+(p-1)*n+1), 1 ) - call stdlib_${ci}$dscal( p, one/temp1, cwork((p-1)*n+1), 1 ) + ! [] call stdlib${ii}$_${ci}$dscal( p, one/temp1, cwork(n+(p-1)*n+1), 1 ) + call stdlib${ii}$_${ci}$dscal( p, one/temp1, cwork((p-1)*n+1), 1_${ik}$ ) end do ! The Columns Of R Are Scaled To Have Unit Euclidean Lengths - ! [] call stdlib_${ci}$pocon( 'u', n, cwork(n+1), n, one, temp1, + ! [] call stdlib${ii}$_${ci}$pocon( 'u', n, cwork(n+1), n, one, temp1, ! [] $ cwork(n+n*n+1), rwork, ierr ) - call stdlib_${ci}$pocon( 'U', n, cwork, n, one, temp1,cwork(n*n+1), rwork, ierr ) + call stdlib${ii}$_${ci}$pocon( 'U', n, cwork, n, one, temp1,cwork(n*n+1), rwork, ierr ) end if if ( temp1 /= zero ) then @@ -6396,15 +6391,15 @@ module stdlib_linalg_lapack_${ci}$ sconda = - one end if end if - l2pert = l2pert .and. ( abs( a(1,1)/a(nr,nr) ) > sqrt(big1) ) + l2pert = l2pert .and. ( abs( a(1_${ik}$,1_${ik}$)/a(nr,nr) ) > sqrt(big1) ) ! if there is no violent scaling, artificial perturbation is not needed. ! phase 3: if ( .not. ( rsvec .or. lsvec ) ) then ! singular values only ! .. transpose a(1:nr,1:n) do p = 1, min( n-1, nr ) - call stdlib_${ci}$copy( n-p, a(p,p+1), lda, a(p+1,p), 1 ) - call stdlib_${ci}$lacgv( n-p+1, a(p,p), 1 ) + call stdlib${ii}$_${ci}$copy( n-p, a(p,p+1), lda, a(p+1,p), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( n-p+1, a(p,p), 1_${ik}$ ) end do if ( nr == n ) a(n,n) = conjg(a(n,n)) ! the following two do-loops introduce small relative perturbation @@ -6431,14 +6426,14 @@ module stdlib_linalg_lapack_${ci}$ end do end do else - if (nr>1) call stdlib_${ci}$laset( 'U', nr-1,nr-1, czero,czero, a(1,2),lda ) + if (nr>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'U', nr-1,nr-1, czero,czero, a(1_${ik}$,2_${ik}$),lda ) end if ! Second Preconditioning Using The Qr Factorization - call stdlib_${ci}$geqrf( n,nr, a,lda, cwork, cwork(n+1),lwork-n, ierr ) + call stdlib${ii}$_${ci}$geqrf( n,nr, a,lda, cwork, cwork(n+1),lwork-n, ierr ) ! And Transpose Upper To Lower Triangular do p = 1, nr - 1 - call stdlib_${ci}$copy( nr-p, a(p,p+1), lda, a(p+1,p), 1 ) - call stdlib_${ci}$lacgv( nr-p+1, a(p,p), 1 ) + call stdlib${ii}$_${ci}$copy( nr-p, a(p,p+1), lda, a(p+1,p), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( nr-p+1, a(p,p), 1_${ik}$ ) end do end if ! row-cyclic jacobi svd algorithm with column pivoting @@ -6456,107 +6451,107 @@ module stdlib_linalg_lapack_${ci}$ end do end do else - if (nr>1) call stdlib_${ci}$laset( 'U', nr-1, nr-1, czero, czero, a(1,2), lda ) + if (nr>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'U', nr-1, nr-1, czero, czero, a(1_${ik}$,2_${ik}$), lda ) end if ! .. and one-sided jacobi rotations are started on a lower ! triangular matrix (plus perturbation which is ignored in ! the part which destroys triangular form (confusing?!)) - call stdlib_${ci}$gesvj( 'L', 'N', 'N', nr, nr, a, lda, sva,n, v, ldv, cwork, lwork, & + call stdlib${ii}$_${ci}$gesvj( 'L', 'N', 'N', nr, nr, a, lda, sva,n, v, ldv, cwork, lwork, & rwork, lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) else if ( ( rsvec .and. ( .not. lsvec ) .and. ( .not. jracc ) ).or.( jracc .and. ( & .not. lsvec ) .and. ( nr /= n ) ) ) then ! -> singular values and right singular vectors <- if ( almort ) then ! In This Case Nr Equals N do p = 1, nr - call stdlib_${ci}$copy( n-p+1, a(p,p), lda, v(p,p), 1 ) - call stdlib_${ci}$lacgv( n-p+1, v(p,p), 1 ) + call stdlib${ii}$_${ci}$copy( n-p+1, a(p,p), lda, v(p,p), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( n-p+1, v(p,p), 1_${ik}$ ) end do - if (nr>1) call stdlib_${ci}$laset( 'U', nr-1,nr-1, czero, czero, v(1,2), ldv ) - call stdlib_${ci}$gesvj( 'L','U','N', n, nr, v, ldv, sva, nr, a, lda,cwork, lwork, & + if (nr>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'U', nr-1,nr-1, czero, czero, v(1_${ik}$,2_${ik}$), ldv ) + call stdlib${ii}$_${ci}$gesvj( 'L','U','N', n, nr, v, ldv, sva, nr, a, lda,cwork, lwork, & rwork, lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) else ! .. two more qr factorizations ( one qrf is not enough, two require ! accumulated product of jacobi rotations, three are perfect ) - if (nr>1) call stdlib_${ci}$laset( 'L', nr-1,nr-1, czero, czero, a(2,1), lda ) - call stdlib_${ci}$gelqf( nr,n, a, lda, cwork, cwork(n+1), lwork-n, ierr) - call stdlib_${ci}$lacpy( 'L', nr, nr, a, lda, v, ldv ) - if (nr>1) call stdlib_${ci}$laset( 'U', nr-1,nr-1, czero, czero, v(1,2), ldv ) - call stdlib_${ci}$geqrf( nr, nr, v, ldv, cwork(n+1), cwork(2*n+1),lwork-2*n, ierr ) + if (nr>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'L', nr-1,nr-1, czero, czero, a(2_${ik}$,1_${ik}$), lda ) + call stdlib${ii}$_${ci}$gelqf( nr,n, a, lda, cwork, cwork(n+1), lwork-n, ierr) + call stdlib${ii}$_${ci}$lacpy( 'L', nr, nr, a, lda, v, ldv ) + if (nr>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'U', nr-1,nr-1, czero, czero, v(1_${ik}$,2_${ik}$), ldv ) + call stdlib${ii}$_${ci}$geqrf( nr, nr, v, ldv, cwork(n+1), cwork(2_${ik}$*n+1),lwork-2*n, ierr ) do p = 1, nr - call stdlib_${ci}$copy( nr-p+1, v(p,p), ldv, v(p,p), 1 ) - call stdlib_${ci}$lacgv( nr-p+1, v(p,p), 1 ) + call stdlib${ii}$_${ci}$copy( nr-p+1, v(p,p), ldv, v(p,p), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( nr-p+1, v(p,p), 1_${ik}$ ) end do - if (nr>1) call stdlib_${ci}$laset('U', nr-1, nr-1, czero, czero, v(1,2), ldv) - call stdlib_${ci}$gesvj( 'L', 'U','N', nr, nr, v,ldv, sva, nr, u,ldu, cwork(n+1), & + if (nr>1_${ik}$) call stdlib${ii}$_${ci}$laset('U', nr-1, nr-1, czero, czero, v(1_${ik}$,2_${ik}$), ldv) + call stdlib${ii}$_${ci}$gesvj( 'L', 'U','N', nr, nr, v,ldv, sva, nr, u,ldu, cwork(n+1), & lwork-n, rwork, lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) if ( nr < n ) then - call stdlib_${ci}$laset( 'A',n-nr, nr, czero,czero, v(nr+1,1), ldv ) - call stdlib_${ci}$laset( 'A',nr, n-nr, czero,czero, v(1,nr+1), ldv ) - call stdlib_${ci}$laset( 'A',n-nr,n-nr,czero,cone, v(nr+1,nr+1),ldv ) + call stdlib${ii}$_${ci}$laset( 'A',n-nr, nr, czero,czero, v(nr+1,1_${ik}$), ldv ) + call stdlib${ii}$_${ci}$laset( 'A',nr, n-nr, czero,czero, v(1_${ik}$,nr+1), ldv ) + call stdlib${ii}$_${ci}$laset( 'A',n-nr,n-nr,czero,cone, v(nr+1,nr+1),ldv ) end if - call stdlib_${ci}$unmlq( 'L', 'C', n, n, nr, a, lda, cwork,v, ldv, cwork(n+1), lwork-n, & + call stdlib${ii}$_${ci}$unmlq( 'L', 'C', n, n, nr, a, lda, cwork,v, ldv, cwork(n+1), lwork-n, & ierr ) end if ! Permute The Rows Of V ! do 8991 p = 1, n - ! call stdlib_${ci}$copy( n, v(p,1), ldv, a(iwork(p),1), lda ) + ! call stdlib${ii}$_${ci}$copy( n, v(p,1), ldv, a(iwork(p),1), lda ) 8991 continue - ! call stdlib_${ci}$lacpy( 'all', n, n, a, lda, v, ldv ) - call stdlib_${ci}$lapmr( .false., n, n, v, ldv, iwork ) + ! call stdlib${ii}$_${ci}$lacpy( 'all', n, n, a, lda, v, ldv ) + call stdlib${ii}$_${ci}$lapmr( .false., n, n, v, ldv, iwork ) if ( transp ) then - call stdlib_${ci}$lacpy( 'A', n, n, v, ldv, u, ldu ) + call stdlib${ii}$_${ci}$lacpy( 'A', n, n, v, ldv, u, ldu ) end if else if ( jracc .and. (.not. lsvec) .and. ( nr== n ) ) then - if (n>1) call stdlib_${ci}$laset( 'L', n-1,n-1, czero, czero, a(2,1), lda ) - call stdlib_${ci}$gesvj( 'U','N','V', n, n, a, lda, sva, n, v, ldv,cwork, lwork, rwork, & + if (n>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'L', n-1,n-1, czero, czero, a(2_${ik}$,1_${ik}$), lda ) + call stdlib${ii}$_${ci}$gesvj( 'U','N','V', n, n, a, lda, sva, n, v, ldv,cwork, lwork, rwork, & lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) - call stdlib_${ci}$lapmr( .false., n, n, v, ldv, iwork ) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$lapmr( .false., n, n, v, ldv, iwork ) else if ( lsvec .and. ( .not. rsvec ) ) then ! Singular Values And Left Singular Vectors ! Second Preconditioning Step To Avoid Need To Accumulate ! jacobi rotations in the jacobi iterations. do p = 1, nr - call stdlib_${ci}$copy( n-p+1, a(p,p), lda, u(p,p), 1 ) - call stdlib_${ci}$lacgv( n-p+1, u(p,p), 1 ) + call stdlib${ii}$_${ci}$copy( n-p+1, a(p,p), lda, u(p,p), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( n-p+1, u(p,p), 1_${ik}$ ) end do - if (nr>1) call stdlib_${ci}$laset( 'U', nr-1, nr-1, czero, czero, u(1,2), ldu ) - call stdlib_${ci}$geqrf( n, nr, u, ldu, cwork(n+1), cwork(2*n+1),lwork-2*n, ierr ) + if (nr>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'U', nr-1, nr-1, czero, czero, u(1_${ik}$,2_${ik}$), ldu ) + call stdlib${ii}$_${ci}$geqrf( n, nr, u, ldu, cwork(n+1), cwork(2_${ik}$*n+1),lwork-2*n, ierr ) do p = 1, nr - 1 - call stdlib_${ci}$copy( nr-p, u(p,p+1), ldu, u(p+1,p), 1 ) - call stdlib_${ci}$lacgv( n-p+1, u(p,p), 1 ) + call stdlib${ii}$_${ci}$copy( nr-p, u(p,p+1), ldu, u(p+1,p), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( n-p+1, u(p,p), 1_${ik}$ ) end do - if (nr>1) call stdlib_${ci}$laset( 'U', nr-1, nr-1, czero, czero, u(1,2), ldu ) - call stdlib_${ci}$gesvj( 'L', 'U', 'N', nr,nr, u, ldu, sva, nr, a,lda, cwork(n+1), lwork-& + if (nr>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'U', nr-1, nr-1, czero, czero, u(1_${ik}$,2_${ik}$), ldu ) + call stdlib${ii}$_${ci}$gesvj( 'L', 'U', 'N', nr,nr, u, ldu, sva, nr, a,lda, cwork(n+1), lwork-& n, rwork, lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) if ( nr < m ) then - call stdlib_${ci}$laset( 'A', m-nr, nr,czero, czero, u(nr+1,1), ldu ) + call stdlib${ii}$_${ci}$laset( 'A', m-nr, nr,czero, czero, u(nr+1,1_${ik}$), ldu ) if ( nr < n1 ) then - call stdlib_${ci}$laset( 'A',nr, n1-nr, czero, czero, u(1,nr+1),ldu ) - call stdlib_${ci}$laset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1),ldu ) + call stdlib${ii}$_${ci}$laset( 'A',nr, n1-nr, czero, czero, u(1_${ik}$,nr+1),ldu ) + call stdlib${ii}$_${ci}$laset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1),ldu ) end if end if - call stdlib_${ci}$unmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-n, & + call stdlib${ii}$_${ci}$unmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-n, & ierr ) - if ( rowpiv )call stdlib_${ci}$laswp( n1, u, ldu, 1, m-1, iwork(iwoff+1), -1 ) + if ( rowpiv )call stdlib${ii}$_${ci}$laswp( n1, u, ldu, 1_${ik}$, m-1, iwork(iwoff+1), -1_${ik}$ ) do p = 1, n1 - xsc = one / stdlib_${c2ri(ci)}$znrm2( m, u(1,p), 1 ) - call stdlib_${ci}$dscal( m, xsc, u(1,p), 1 ) + xsc = one / stdlib${ii}$_${c2ri(ci)}$znrm2( m, u(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_${ci}$dscal( m, xsc, u(1_${ik}$,p), 1_${ik}$ ) end do if ( transp ) then - call stdlib_${ci}$lacpy( 'A', n, n, u, ldu, v, ldv ) + call stdlib${ii}$_${ci}$lacpy( 'A', n, n, u, ldu, v, ldv ) end if else ! Full Svd @@ -6567,10 +6562,10 @@ module stdlib_linalg_lapack_${ci}$ ! equivalent to an lqf call. since in many libraries the qrf ! seems to be better optimized than the lqf, we do explicit ! transpose and use the qrf. this is subject to changes in an - ! optimized implementation of stdlib_${ci}$gejsv. + ! optimized implementation of stdlib${ii}$_${ci}$gejsv. do p = 1, nr - call stdlib_${ci}$copy( n-p+1, a(p,p), lda, v(p,p), 1 ) - call stdlib_${ci}$lacgv( n-p+1, v(p,p), 1 ) + call stdlib${ii}$_${ci}$copy( n-p+1, a(p,p), lda, v(p,p), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( n-p+1, v(p,p), 1_${ik}$ ) end do ! The Following Two Loops Perturb Small Entries To Avoid ! denormals in the second qr factorization, where they are @@ -6595,17 +6590,17 @@ module stdlib_linalg_lapack_${ci}$ end do end do else - if (nr>1) call stdlib_${ci}$laset( 'U', nr-1, nr-1, czero, czero, v(1,2), ldv ) + if (nr>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'U', nr-1, nr-1, czero, czero, v(1_${ik}$,2_${ik}$), ldv ) end if ! estimate the row scaled condition number of r1 ! (if r1 is rectangular, n > nr, then the condition number ! of the leading nr x nr submatrix is estimated.) - call stdlib_${ci}$lacpy( 'L', nr, nr, v, ldv, cwork(2*n+1), nr ) + call stdlib${ii}$_${ci}$lacpy( 'L', nr, nr, v, ldv, cwork(2_${ik}$*n+1), nr ) do p = 1, nr - temp1 = stdlib_${c2ri(ci)}$znrm2(nr-p+1,cwork(2*n+(p-1)*nr+p),1) - call stdlib_${ci}$dscal(nr-p+1,one/temp1,cwork(2*n+(p-1)*nr+p),1) + temp1 = stdlib${ii}$_${c2ri(ci)}$znrm2(nr-p+1,cwork(2_${ik}$*n+(p-1)*nr+p),1_${ik}$) + call stdlib${ii}$_${ci}$dscal(nr-p+1,one/temp1,cwork(2_${ik}$*n+(p-1)*nr+p),1_${ik}$) end do - call stdlib_${ci}$pocon('L',nr,cwork(2*n+1),nr,one,temp1,cwork(2*n+nr*nr+1),rwork,& + call stdlib${ii}$_${ci}$pocon('L',nr,cwork(2_${ik}$*n+1),nr,one,temp1,cwork(2_${ik}$*n+nr*nr+1),rwork,& ierr) condr1 = one / sqrt(temp1) ! Here Need A Second Opinion On The Condition Number @@ -6619,7 +6614,7 @@ module stdlib_linalg_lapack_${ci}$ ! implementation, this qrf should be implemented as the qrf ! of a lower triangular matrix. ! r1^* = q2 * r2 - call stdlib_${ci}$geqrf( n, nr, v, ldv, cwork(n+1), cwork(2*n+1),lwork-2*n, ierr ) + call stdlib${ii}$_${ci}$geqrf( n, nr, v, ldv, cwork(n+1), cwork(2_${ik}$*n+1),lwork-2*n, ierr ) if ( l2pert ) then xsc = sqrt(small)/epsln @@ -6631,13 +6626,13 @@ module stdlib_linalg_lapack_${ci}$ end do end do end if - if ( nr /= n )call stdlib_${ci}$lacpy( 'A', n, nr, v, ldv, cwork(2*n+1), n ) + if ( nr /= n )call stdlib${ii}$_${ci}$lacpy( 'A', n, nr, v, ldv, cwork(2_${ik}$*n+1), n ) ! .. save ... ! This Transposed Copy Should Be Better Than Naive do p = 1, nr - 1 - call stdlib_${ci}$copy( nr-p, v(p,p+1), ldv, v(p+1,p), 1 ) - call stdlib_${ci}$lacgv(nr-p+1, v(p,p), 1 ) + call stdlib${ii}$_${ci}$copy( nr-p, v(p,p+1), ldv, v(p+1,p), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv(nr-p+1, v(p,p), 1_${ik}$ ) end do v(nr,nr)=conjg(v(nr,nr)) condr2 = condr1 @@ -6645,16 +6640,16 @@ module stdlib_linalg_lapack_${ci}$ ! .. ill-conditioned case: second qrf with pivoting ! note that windowed pivoting would be equally good ! numerically, and more run-time efficient. so, in - ! an optimal implementation, the next call to stdlib_${ci}$geqp3 + ! an optimal implementation, the next call to stdlib${ii}$_${ci}$geqp3 ! should be replaced with eg. call zgeqpx (acm toms #782) ! with properly (carefully) chosen parameters. ! r1^* * p2 = q2 * r2 do p = 1, nr - iwork(n+p) = 0 + iwork(n+p) = 0_${ik}$ end do - call stdlib_${ci}$geqp3( n, nr, v, ldv, iwork(n+1), cwork(n+1),cwork(2*n+1), lwork-& - 2*n, rwork, ierr ) - ! * call stdlib_${ci}$geqrf( n, nr, v, ldv, cwork(n+1), cwork(2*n+1), + call stdlib${ii}$_${ci}$geqp3( n, nr, v, ldv, iwork(n+1), cwork(n+1),cwork(2_${ik}$*n+1), lwork-& + 2_${ik}$*n, rwork, ierr ) + ! * call stdlib${ii}$_${ci}$geqrf( n, nr, v, ldv, cwork(n+1), cwork(2*n+1), ! * $ lwork-2*n, ierr ) if ( l2pert ) then xsc = sqrt(small) @@ -6666,7 +6661,7 @@ module stdlib_linalg_lapack_${ci}$ end do end do end if - call stdlib_${ci}$lacpy( 'A', n, nr, v, ldv, cwork(2*n+1), n ) + call stdlib${ii}$_${ci}$lacpy( 'A', n, nr, v, ldv, cwork(2_${ik}$*n+1), n ) if ( l2pert ) then xsc = sqrt(small) do p = 2, nr @@ -6677,18 +6672,18 @@ module stdlib_linalg_lapack_${ci}$ end do end do else - if (nr>1) call stdlib_${ci}$laset( 'L',nr-1,nr-1,czero,czero,v(2,1),ldv ) + if (nr>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'L',nr-1,nr-1,czero,czero,v(2_${ik}$,1_${ik}$),ldv ) end if ! now, compute r2 = l3 * q3, the lq factorization. - call stdlib_${ci}$gelqf( nr, nr, v, ldv, cwork(2*n+n*nr+1),cwork(2*n+n*nr+nr+1), & + call stdlib${ii}$_${ci}$gelqf( nr, nr, v, ldv, cwork(2_${ik}$*n+n*nr+1),cwork(2_${ik}$*n+n*nr+nr+1), & lwork-2*n-n*nr-nr, ierr ) ! And Estimate The Condition Number - call stdlib_${ci}$lacpy( 'L',nr,nr,v,ldv,cwork(2*n+n*nr+nr+1),nr ) + call stdlib${ii}$_${ci}$lacpy( 'L',nr,nr,v,ldv,cwork(2_${ik}$*n+n*nr+nr+1),nr ) do p = 1, nr - temp1 = stdlib_${c2ri(ci)}$znrm2( p, cwork(2*n+n*nr+nr+p), nr ) - call stdlib_${ci}$dscal( p, one/temp1, cwork(2*n+n*nr+nr+p), nr ) + temp1 = stdlib${ii}$_${c2ri(ci)}$znrm2( p, cwork(2_${ik}$*n+n*nr+nr+p), nr ) + call stdlib${ii}$_${ci}$dscal( p, one/temp1, cwork(2_${ik}$*n+n*nr+nr+p), nr ) end do - call stdlib_${ci}$pocon( 'L',nr,cwork(2*n+n*nr+nr+1),nr,one,temp1,cwork(2*n+n*nr+& + call stdlib${ii}$_${ci}$pocon( 'L',nr,cwork(2_${ik}$*n+n*nr+nr+1),nr,one,temp1,cwork(2_${ik}$*n+n*nr+& nr+nr*nr+1),rwork,ierr ) condr2 = one / sqrt(temp1) if ( condr2 >= cond_ok ) then @@ -6696,7 +6691,7 @@ module stdlib_linalg_lapack_${ci}$ ! (this overwrites the copy of r2, as it will not be ! needed in this branch, but it does not overwritte the ! huseholder vectors of q2.). - call stdlib_${ci}$lacpy( 'U', nr, nr, v, ldv, cwork(2*n+1), n ) + call stdlib${ii}$_${ci}$lacpy( 'U', nr, nr, v, ldv, cwork(2_${ik}$*n+1), n ) ! And The Rest Of The Information On Q3 Is In ! work(2*n+n*nr+1:2*n+n*nr+n) end if @@ -6711,71 +6706,71 @@ module stdlib_linalg_lapack_${ci}$ end do end do else - if (nr>1) call stdlib_${ci}$laset( 'U', nr-1,nr-1, czero,czero, v(1,2), ldv ) + if (nr>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'U', nr-1,nr-1, czero,czero, v(1_${ik}$,2_${ik}$), ldv ) end if ! second preconditioning finished; continue with jacobi svd ! the input matrix is lower trinagular. ! recover the right singular vectors as solution of a well ! conditioned triangular matrix equation. if ( condr1 < cond_ok ) then - call stdlib_${ci}$gesvj( 'L','U','N',nr,nr,v,ldv,sva,nr,u, ldu,cwork(2*n+n*nr+nr+1)& + call stdlib${ii}$_${ci}$gesvj( 'L','U','N',nr,nr,v,ldv,sva,nr,u, ldu,cwork(2_${ik}$*n+n*nr+nr+1)& ,lwork-2*n-n*nr-nr,rwork,lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) do p = 1, nr - call stdlib_${ci}$copy( nr, v(1,p), 1, u(1,p), 1 ) - call stdlib_${ci}$dscal( nr, sva(p), v(1,p), 1 ) + call stdlib${ii}$_${ci}$copy( nr, v(1_${ik}$,p), 1_${ik}$, u(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_${ci}$dscal( nr, sva(p), v(1_${ik}$,p), 1_${ik}$ ) end do ! Pick The Right Matrix Equation And Solve It if ( nr == n ) then ! :)) .. best case, r1 is inverted. the solution of this matrix ! equation is q2*v2 = the product of the jacobi rotations - ! used in stdlib_${ci}$gesvj, premultiplied with the orthogonal matrix + ! used in stdlib${ii}$_${ci}$gesvj, premultiplied with the orthogonal matrix ! from the second qr factorization. - call stdlib_${ci}$trsm('L','U','N','N', nr,nr,cone, a,lda, v,ldv) + call stdlib${ii}$_${ci}$trsm('L','U','N','N', nr,nr,cone, a,lda, v,ldv) else ! .. r1 is well conditioned, but non-square. adjoint of r2 ! is inverted to get the product of the jacobi rotations - ! used in stdlib_${ci}$gesvj. the q-factor from the second qr + ! used in stdlib${ii}$_${ci}$gesvj. the q-factor from the second qr ! factorization is then built in explicitly. - call stdlib_${ci}$trsm('L','U','C','N',nr,nr,cone,cwork(2*n+1),n,v,ldv) + call stdlib${ii}$_${ci}$trsm('L','U','C','N',nr,nr,cone,cwork(2_${ik}$*n+1),n,v,ldv) if ( nr < n ) then - call stdlib_${ci}$laset('A',n-nr,nr,czero,czero,v(nr+1,1),ldv) - call stdlib_${ci}$laset('A',nr,n-nr,czero,czero,v(1,nr+1),ldv) - call stdlib_${ci}$laset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) + call stdlib${ii}$_${ci}$laset('A',n-nr,nr,czero,czero,v(nr+1,1_${ik}$),ldv) + call stdlib${ii}$_${ci}$laset('A',nr,n-nr,czero,czero,v(1_${ik}$,nr+1),ldv) + call stdlib${ii}$_${ci}$laset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) end if - call stdlib_${ci}$unmqr('L','N',n,n,nr,cwork(2*n+1),n,cwork(n+1),v,ldv,cwork(& - 2*n+n*nr+nr+1),lwork-2*n-n*nr-nr,ierr) + call stdlib${ii}$_${ci}$unmqr('L','N',n,n,nr,cwork(2_${ik}$*n+1),n,cwork(n+1),v,ldv,cwork(& + 2_${ik}$*n+n*nr+nr+1),lwork-2*n-n*nr-nr,ierr) end if else if ( condr2 < cond_ok ) then ! the matrix r2 is inverted. the solution of the matrix equation ! is q3^* * v3 = the product of the jacobi rotations (appplied to ! the lower triangular l3 from the lq factorization of ! r2=l3*q3), pre-multiplied with the transposed q3. - call stdlib_${ci}$gesvj( 'L', 'U', 'N', nr, nr, v, ldv, sva, nr, u,ldu, cwork(2*n+& + call stdlib${ii}$_${ci}$gesvj( 'L', 'U', 'N', nr, nr, v, ldv, sva, nr, u,ldu, cwork(2_${ik}$*n+& n*nr+nr+1), lwork-2*n-n*nr-nr,rwork, lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) do p = 1, nr - call stdlib_${ci}$copy( nr, v(1,p), 1, u(1,p), 1 ) - call stdlib_${ci}$dscal( nr, sva(p), u(1,p), 1 ) + call stdlib${ii}$_${ci}$copy( nr, v(1_${ik}$,p), 1_${ik}$, u(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_${ci}$dscal( nr, sva(p), u(1_${ik}$,p), 1_${ik}$ ) end do - call stdlib_${ci}$trsm('L','U','N','N',nr,nr,cone,cwork(2*n+1),n,u,ldu) + call stdlib${ii}$_${ci}$trsm('L','U','N','N',nr,nr,cone,cwork(2_${ik}$*n+1),n,u,ldu) ! Apply The Permutation From The Second Qr Factorization do q = 1, nr do p = 1, nr - cwork(2*n+n*nr+nr+iwork(n+p)) = u(p,q) + cwork(2_${ik}$*n+n*nr+nr+iwork(n+p)) = u(p,q) end do do p = 1, nr - u(p,q) = cwork(2*n+n*nr+nr+p) + u(p,q) = cwork(2_${ik}$*n+n*nr+nr+p) end do end do if ( nr < n ) then - call stdlib_${ci}$laset( 'A',n-nr,nr,czero,czero,v(nr+1,1),ldv ) - call stdlib_${ci}$laset( 'A',nr,n-nr,czero,czero,v(1,nr+1),ldv ) - call stdlib_${ci}$laset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) + call stdlib${ii}$_${ci}$laset( 'A',n-nr,nr,czero,czero,v(nr+1,1_${ik}$),ldv ) + call stdlib${ii}$_${ci}$laset( 'A',nr,n-nr,czero,czero,v(1_${ik}$,nr+1),ldv ) + call stdlib${ii}$_${ci}$laset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) end if - call stdlib_${ci}$unmqr( 'L','N',n,n,nr,cwork(2*n+1),n,cwork(n+1),v,ldv,cwork(2*n+& + call stdlib${ii}$_${ci}$unmqr( 'L','N',n,n,nr,cwork(2_${ik}$*n+1),n,cwork(n+1),v,ldv,cwork(2_${ik}$*n+& n*nr+nr+1),lwork-2*n-n*nr-nr,ierr ) else ! last line of defense. @@ -6786,28 +6781,28 @@ module stdlib_linalg_lapack_${ci}$ ! is set very close to one (which is unnecessary). normally, ! this branch should never be executed, but in rare cases of ! failure of the rrqr or condition estimator, the last line of - ! defense ensures that stdlib_${ci}$gejsv completes the task. - ! compute the full svd of l3 using stdlib_${ci}$gesvj with explicit + ! defense ensures that stdlib${ii}$_${ci}$gejsv completes the task. + ! compute the full svd of l3 using stdlib${ii}$_${ci}$gesvj with explicit ! accumulation of jacobi rotations. - call stdlib_${ci}$gesvj( 'L', 'U', 'V', nr, nr, v, ldv, sva, nr, u,ldu, cwork(2*n+& + call stdlib${ii}$_${ci}$gesvj( 'L', 'U', 'V', nr, nr, v, ldv, sva, nr, u,ldu, cwork(2_${ik}$*n+& n*nr+nr+1), lwork-2*n-n*nr-nr,rwork, lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) if ( nr < n ) then - call stdlib_${ci}$laset( 'A',n-nr,nr,czero,czero,v(nr+1,1),ldv ) - call stdlib_${ci}$laset( 'A',nr,n-nr,czero,czero,v(1,nr+1),ldv ) - call stdlib_${ci}$laset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) + call stdlib${ii}$_${ci}$laset( 'A',n-nr,nr,czero,czero,v(nr+1,1_${ik}$),ldv ) + call stdlib${ii}$_${ci}$laset( 'A',nr,n-nr,czero,czero,v(1_${ik}$,nr+1),ldv ) + call stdlib${ii}$_${ci}$laset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) end if - call stdlib_${ci}$unmqr( 'L','N',n,n,nr,cwork(2*n+1),n,cwork(n+1),v,ldv,cwork(2*n+& + call stdlib${ii}$_${ci}$unmqr( 'L','N',n,n,nr,cwork(2_${ik}$*n+1),n,cwork(n+1),v,ldv,cwork(2_${ik}$*n+& n*nr+nr+1),lwork-2*n-n*nr-nr,ierr ) - call stdlib_${ci}$unmlq( 'L', 'C', nr, nr, nr, cwork(2*n+1), n,cwork(2*n+n*nr+1), & - u, ldu, cwork(2*n+n*nr+nr+1),lwork-2*n-n*nr-nr, ierr ) + call stdlib${ii}$_${ci}$unmlq( 'L', 'C', nr, nr, nr, cwork(2_${ik}$*n+1), n,cwork(2_${ik}$*n+n*nr+1), & + u, ldu, cwork(2_${ik}$*n+n*nr+nr+1),lwork-2*n-n*nr-nr, ierr ) do q = 1, nr do p = 1, nr - cwork(2*n+n*nr+nr+iwork(n+p)) = u(p,q) + cwork(2_${ik}$*n+n*nr+nr+iwork(n+p)) = u(p,q) end do do p = 1, nr - u(p,q) = cwork(2*n+n*nr+nr+p) + u(p,q) = cwork(2_${ik}$*n+n*nr+nr+p) end do end do end if @@ -6817,42 +6812,42 @@ module stdlib_linalg_lapack_${ci}$ temp1 = sqrt(real(n,KIND=${ck}$)) * epsln do q = 1, n do p = 1, n - cwork(2*n+n*nr+nr+iwork(p)) = v(p,q) + cwork(2_${ik}$*n+n*nr+nr+iwork(p)) = v(p,q) end do do p = 1, n - v(p,q) = cwork(2*n+n*nr+nr+p) + v(p,q) = cwork(2_${ik}$*n+n*nr+nr+p) end do - xsc = one / stdlib_${c2ri(ci)}$znrm2( n, v(1,q), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_${ci}$dscal( n, xsc,& - v(1,q), 1 ) + xsc = one / stdlib${ii}$_${c2ri(ci)}$znrm2( n, v(1_${ik}$,q), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_${ci}$dscal( n, xsc,& + v(1_${ik}$,q), 1_${ik}$ ) end do ! at this moment, v contains the right singular vectors of a. ! next, assemble the left singular vector matrix u (m x n). if ( nr < m ) then - call stdlib_${ci}$laset('A', m-nr, nr, czero, czero, u(nr+1,1), ldu) + call stdlib${ii}$_${ci}$laset('A', m-nr, nr, czero, czero, u(nr+1,1_${ik}$), ldu) if ( nr < n1 ) then - call stdlib_${ci}$laset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) - call stdlib_${ci}$laset('A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1),ldu) + call stdlib${ii}$_${ci}$laset('A',nr,n1-nr,czero,czero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_${ci}$laset('A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1),ldu) end if end if ! the q matrix from the first qrf is built into the left singular ! matrix u. this applies to all cases. - call stdlib_${ci}$unmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-& + call stdlib${ii}$_${ci}$unmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-& n, ierr ) ! the columns of u are normalized. the cost is o(m*n) flops. temp1 = sqrt(real(m,KIND=${ck}$)) * epsln do p = 1, nr - xsc = one / stdlib_${c2ri(ci)}$znrm2( m, u(1,p), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_${ci}$dscal( m, xsc,& - u(1,p), 1 ) + xsc = one / stdlib${ii}$_${c2ri(ci)}$znrm2( m, u(1_${ik}$,p), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_${ci}$dscal( m, xsc,& + u(1_${ik}$,p), 1_${ik}$ ) end do ! if the initial qrf is computed with row pivoting, the left ! singular vectors must be adjusted. - if ( rowpiv )call stdlib_${ci}$laswp( n1, u, ldu, 1, m-1, iwork(iwoff+1), -1 ) + if ( rowpiv )call stdlib${ii}$_${ci}$laswp( n1, u, ldu, 1_${ik}$, m-1, iwork(iwoff+1), -1_${ik}$ ) else ! The Initial Matrix A Has Almost Orthogonal Columns And ! the second qrf is not needed - call stdlib_${ci}$lacpy( 'U', n, n, a, lda, cwork(n+1), n ) + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, a, lda, cwork(n+1), n ) if ( l2pert ) then xsc = sqrt(small) do p = 2, n @@ -6864,43 +6859,43 @@ module stdlib_linalg_lapack_${ci}$ end do end do else - call stdlib_${ci}$laset( 'L',n-1,n-1,czero,czero,cwork(n+2),n ) + call stdlib${ii}$_${ci}$laset( 'L',n-1,n-1,czero,czero,cwork(n+2),n ) end if - call stdlib_${ci}$gesvj( 'U', 'U', 'N', n, n, cwork(n+1), n, sva,n, u, ldu, cwork(n+& + call stdlib${ii}$_${ci}$gesvj( 'U', 'U', 'N', n, n, cwork(n+1), n, sva,n, u, ldu, cwork(n+& n*n+1), lwork-n-n*n, rwork, lrwork,info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) do p = 1, n - call stdlib_${ci}$copy( n, cwork(n+(p-1)*n+1), 1, u(1,p), 1 ) - call stdlib_${ci}$dscal( n, sva(p), cwork(n+(p-1)*n+1), 1 ) + call stdlib${ii}$_${ci}$copy( n, cwork(n+(p-1)*n+1), 1_${ik}$, u(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_${ci}$dscal( n, sva(p), cwork(n+(p-1)*n+1), 1_${ik}$ ) end do - call stdlib_${ci}$trsm( 'L', 'U', 'N', 'N', n, n,cone, a, lda, cwork(n+1), n ) + call stdlib${ii}$_${ci}$trsm( 'L', 'U', 'N', 'N', n, n,cone, a, lda, cwork(n+1), n ) do p = 1, n - call stdlib_${ci}$copy( n, cwork(n+p), n, v(iwork(p),1), ldv ) + call stdlib${ii}$_${ci}$copy( n, cwork(n+p), n, v(iwork(p),1_${ik}$), ldv ) end do temp1 = sqrt(real(n,KIND=${ck}$))*epsln do p = 1, n - xsc = one / stdlib_${c2ri(ci)}$znrm2( n, v(1,p), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_${ci}$dscal( n, xsc,& - v(1,p), 1 ) + xsc = one / stdlib${ii}$_${c2ri(ci)}$znrm2( n, v(1_${ik}$,p), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_${ci}$dscal( n, xsc,& + v(1_${ik}$,p), 1_${ik}$ ) end do ! assemble the left singular vector matrix u (m x n). if ( n < m ) then - call stdlib_${ci}$laset( 'A', m-n, n, czero, czero, u(n+1,1), ldu ) + call stdlib${ii}$_${ci}$laset( 'A', m-n, n, czero, czero, u(n+1,1_${ik}$), ldu ) if ( n < n1 ) then - call stdlib_${ci}$laset('A',n, n1-n, czero, czero, u(1,n+1),ldu) - call stdlib_${ci}$laset( 'A',m-n,n1-n, czero, cone,u(n+1,n+1),ldu) + call stdlib${ii}$_${ci}$laset('A',n, n1-n, czero, czero, u(1_${ik}$,n+1),ldu) + call stdlib${ii}$_${ci}$laset( 'A',m-n,n1-n, czero, cone,u(n+1,n+1),ldu) end if end if - call stdlib_${ci}$unmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-& + call stdlib${ii}$_${ci}$unmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-& n, ierr ) temp1 = sqrt(real(m,KIND=${ck}$))*epsln do p = 1, n1 - xsc = one / stdlib_${c2ri(ci)}$znrm2( m, u(1,p), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_${ci}$dscal( m, xsc,& - u(1,p), 1 ) + xsc = one / stdlib${ii}$_${c2ri(ci)}$znrm2( m, u(1_${ik}$,p), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_${ci}$dscal( m, xsc,& + u(1_${ik}$,p), 1_${ik}$ ) end do - if ( rowpiv )call stdlib_${ci}$laswp( n1, u, ldu, 1, m-1, iwork(iwoff+1), -1 ) + if ( rowpiv )call stdlib${ii}$_${ci}$laswp( n1, u, ldu, 1_${ik}$, m-1, iwork(iwoff+1), -1_${ik}$ ) end if ! end of the >> almost orthogonal case << in the full svd else @@ -6915,8 +6910,8 @@ module stdlib_linalg_lapack_${ci}$ ! in presence of extreme values, e.g. when the singular values spread from ! the underflow to the overflow threshold. do p = 1, nr - call stdlib_${ci}$copy( n-p+1, a(p,p), lda, v(p,p), 1 ) - call stdlib_${ci}$lacgv( n-p+1, v(p,p), 1 ) + call stdlib${ii}$_${ci}$copy( n-p+1, a(p,p), lda, v(p,p), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( n-p+1, v(p,p), 1_${ik}$ ) end do if ( l2pert ) then xsc = sqrt(small/epsln) @@ -6930,14 +6925,14 @@ module stdlib_linalg_lapack_${ci}$ end do end do else - if (nr>1) call stdlib_${ci}$laset( 'U', nr-1, nr-1, czero, czero, v(1,2), ldv ) + if (nr>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'U', nr-1, nr-1, czero, czero, v(1_${ik}$,2_${ik}$), ldv ) end if - call stdlib_${ci}$geqrf( n, nr, v, ldv, cwork(n+1), cwork(2*n+1),lwork-2*n, ierr ) + call stdlib${ii}$_${ci}$geqrf( n, nr, v, ldv, cwork(n+1), cwork(2_${ik}$*n+1),lwork-2*n, ierr ) - call stdlib_${ci}$lacpy( 'L', n, nr, v, ldv, cwork(2*n+1), n ) + call stdlib${ii}$_${ci}$lacpy( 'L', n, nr, v, ldv, cwork(2_${ik}$*n+1), n ) do p = 1, nr - call stdlib_${ci}$copy( nr-p+1, v(p,p), ldv, u(p,p), 1 ) - call stdlib_${ci}$lacgv( nr-p+1, u(p,p), 1 ) + call stdlib${ii}$_${ci}$copy( nr-p+1, v(p,p), ldv, u(p,p), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( nr-p+1, u(p,p), 1_${ik}$ ) end do if ( l2pert ) then xsc = sqrt(small/epsln) @@ -6949,18 +6944,18 @@ module stdlib_linalg_lapack_${ci}$ end do end do else - if (nr>1) call stdlib_${ci}$laset('U', nr-1, nr-1, czero, czero, u(1,2), ldu ) + if (nr>1_${ik}$) call stdlib${ii}$_${ci}$laset('U', nr-1, nr-1, czero, czero, u(1_${ik}$,2_${ik}$), ldu ) end if - call stdlib_${ci}$gesvj( 'L', 'U', 'V', nr, nr, u, ldu, sva,n, v, ldv, cwork(2*n+n*nr+1),& + call stdlib${ii}$_${ci}$gesvj( 'L', 'U', 'V', nr, nr, u, ldu, sva,n, v, ldv, cwork(2_${ik}$*n+n*nr+1),& lwork-2*n-n*nr,rwork, lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) if ( nr < n ) then - call stdlib_${ci}$laset( 'A',n-nr,nr,czero,czero,v(nr+1,1),ldv ) - call stdlib_${ci}$laset( 'A',nr,n-nr,czero,czero,v(1,nr+1),ldv ) - call stdlib_${ci}$laset( 'A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv ) + call stdlib${ii}$_${ci}$laset( 'A',n-nr,nr,czero,czero,v(nr+1,1_${ik}$),ldv ) + call stdlib${ii}$_${ci}$laset( 'A',nr,n-nr,czero,czero,v(1_${ik}$,nr+1),ldv ) + call stdlib${ii}$_${ci}$laset( 'A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv ) end if - call stdlib_${ci}$unmqr( 'L','N',n,n,nr,cwork(2*n+1),n,cwork(n+1),v,ldv,cwork(2*n+n*nr+& + call stdlib${ii}$_${ci}$unmqr( 'L','N',n,n,nr,cwork(2_${ik}$*n+1),n,cwork(n+1),v,ldv,cwork(2_${ik}$*n+n*nr+& nr+1),lwork-2*n-n*nr-nr,ierr ) ! permute the rows of v using the (column) permutation from the ! first qrf. also, scale the columns to make them unit in @@ -6968,39 +6963,39 @@ module stdlib_linalg_lapack_${ci}$ temp1 = sqrt(real(n,KIND=${ck}$)) * epsln do q = 1, n do p = 1, n - cwork(2*n+n*nr+nr+iwork(p)) = v(p,q) + cwork(2_${ik}$*n+n*nr+nr+iwork(p)) = v(p,q) end do do p = 1, n - v(p,q) = cwork(2*n+n*nr+nr+p) + v(p,q) = cwork(2_${ik}$*n+n*nr+nr+p) end do - xsc = one / stdlib_${c2ri(ci)}$znrm2( n, v(1,q), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_${ci}$dscal( n, xsc,& - v(1,q), 1 ) + xsc = one / stdlib${ii}$_${c2ri(ci)}$znrm2( n, v(1_${ik}$,q), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_${ci}$dscal( n, xsc,& + v(1_${ik}$,q), 1_${ik}$ ) end do ! at this moment, v contains the right singular vectors of a. ! next, assemble the left singular vector matrix u (m x n). if ( nr < m ) then - call stdlib_${ci}$laset( 'A', m-nr, nr, czero, czero, u(nr+1,1), ldu ) + call stdlib${ii}$_${ci}$laset( 'A', m-nr, nr, czero, czero, u(nr+1,1_${ik}$), ldu ) if ( nr < n1 ) then - call stdlib_${ci}$laset('A',nr, n1-nr, czero, czero, u(1,nr+1),ldu) - call stdlib_${ci}$laset('A',m-nr,n1-nr, czero, cone,u(nr+1,nr+1),ldu) + call stdlib${ii}$_${ci}$laset('A',nr, n1-nr, czero, czero, u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_${ci}$laset('A',m-nr,n1-nr, czero, cone,u(nr+1,nr+1),ldu) end if end if - call stdlib_${ci}$unmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-n, & + call stdlib${ii}$_${ci}$unmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-n, & ierr ) - if ( rowpiv )call stdlib_${ci}$laswp( n1, u, ldu, 1, m-1, iwork(iwoff+1), -1 ) + if ( rowpiv )call stdlib${ii}$_${ci}$laswp( n1, u, ldu, 1_${ik}$, m-1, iwork(iwoff+1), -1_${ik}$ ) end if if ( transp ) then ! .. swap u and v because the procedure worked on a^* do p = 1, n - call stdlib_${ci}$swap( n, u(1,p), 1, v(1,p), 1 ) + call stdlib${ii}$_${ci}$swap( n, u(1_${ik}$,p), 1_${ik}$, v(1_${ik}$,p), 1_${ik}$ ) end do end if end if ! end of the full svd ! undo scaling, if necessary (and possible) - if ( uscal2 <= (big/sva(1))*uscal1 ) then - call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, uscal1, uscal2, nr, 1, sva, n, ierr ) + if ( uscal2 <= (big/sva(1_${ik}$))*uscal1 ) then + call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, uscal1, uscal2, nr, 1_${ik}$, sva, n, ierr ) uscal1 = one uscal2 = one end if @@ -7009,30 +7004,30 @@ module stdlib_linalg_lapack_${ci}$ sva(p) = zero end do end if - rwork(1) = uscal2 * scalem - rwork(2) = uscal1 - if ( errest ) rwork(3) = sconda + rwork(1_${ik}$) = uscal2 * scalem + rwork(2_${ik}$) = uscal1 + if ( errest ) rwork(3_${ik}$) = sconda if ( lsvec .and. rsvec ) then - rwork(4) = condr1 - rwork(5) = condr2 + rwork(4_${ik}$) = condr1 + rwork(5_${ik}$) = condr2 end if if ( l2tran ) then - rwork(6) = entra - rwork(7) = entrat + rwork(6_${ik}$) = entra + rwork(7_${ik}$) = entrat end if - iwork(1) = nr - iwork(2) = numrank - iwork(3) = warning + iwork(1_${ik}$) = nr + iwork(2_${ik}$) = numrank + iwork(3_${ik}$) = warning if ( transp ) then - iwork(4) = 1 + iwork(4_${ik}$) = 1_${ik}$ else - iwork(4) = -1 + iwork(4_${ik}$) = -1_${ik}$ end if return - end subroutine stdlib_${ci}$gejsv + end subroutine stdlib${ii}$_${ci}$gejsv - pure subroutine stdlib_${ci}$gelq( m, n, a, lda, t, tsize, work, lwork,info ) + pure subroutine stdlib${ii}$_${ci}$gelq( m, n, a, lda, t, tsize, work, lwork,info ) !! ZGELQ: computes an LQ factorization of a complex M-by-N matrix A: !! A = ( L 0 ) * Q !! where: @@ -7043,121 +7038,121 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, tsize, lwork + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, tsize, lwork ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: t(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, lminws, mint, minw - integer(ilp) :: mb, nb, mintsz, nblcks, lwmin, lwopt, lwreq + integer(${ik}$) :: mb, nb, mintsz, nblcks, lwmin, lwopt, lwreq ! Intrinsic Functions intrinsic :: max,min,mod ! Executable Statements ! test the input arguments - info = 0 - lquery = ( tsize==-1 .or. tsize==-2 .or.lwork==-1 .or. lwork==-2 ) + info = 0_${ik}$ + lquery = ( tsize==-1_${ik}$ .or. tsize==-2_${ik}$ .or.lwork==-1_${ik}$ .or. lwork==-2_${ik}$ ) mint = .false. minw = .false. - if( tsize==-2 .or. lwork==-2 ) then - if( tsize/=-1 ) mint = .true. - if( lwork/=-1 ) minw = .true. + if( tsize==-2_${ik}$ .or. lwork==-2_${ik}$ ) then + if( tsize/=-1_${ik}$ ) mint = .true. + if( lwork/=-1_${ik}$ ) minw = .true. end if ! determine the block size - if( min( m, n )>0 ) then - mb = stdlib_ilaenv( 1, 'ZGELQ ', ' ', m, n, 1, -1 ) - nb = stdlib_ilaenv( 1, 'ZGELQ ', ' ', m, n, 2, -1 ) + if( min( m, n )>0_${ik}$ ) then + mb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGELQ ', ' ', m, n, 1_${ik}$, -1_${ik}$ ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGELQ ', ' ', m, n, 2_${ik}$, -1_${ik}$ ) else - mb = 1 + mb = 1_${ik}$ nb = n end if - if( mb>min( m, n ) .or. mb<1 ) mb = 1 + if( mb>min( m, n ) .or. mb<1_${ik}$ ) mb = 1_${ik}$ if( nb>n .or. nb<=m ) nb = n - mintsz = m + 5 + mintsz = m + 5_${ik}$ if ( nb>m .and. n>m ) then - if( mod( n - m, nb - m )==0 ) then + if( mod( n - m, nb - m )==0_${ik}$ ) then nblcks = ( n - m ) / ( nb - m ) else - nblcks = ( n - m ) / ( nb - m ) + 1 + nblcks = ( n - m ) / ( nb - m ) + 1_${ik}$ end if else - nblcks = 1 + nblcks = 1_${ik}$ end if ! determine if the workspace size satisfies minimal size if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then - lwmin = max( 1, n ) - lwopt = max( 1, mb*n ) + lwmin = max( 1_${ik}$, n ) + lwopt = max( 1_${ik}$, mb*n ) else - lwmin = max( 1, m ) - lwopt = max( 1, mb*m ) + lwmin = max( 1_${ik}$, m ) + lwopt = max( 1_${ik}$, mb*m ) end if lminws = .false. - if( ( tsize=lwmin ) .and. ( & + if( ( tsize=lwmin ) .and. ( & tsize>=mintsz ).and. ( .not.lquery ) ) then - if( tsize=n ) ) then - lwreq = max( 1, mb*n ) + lwreq = max( 1_${ik}$, mb*n ) else - lwreq = max( 1, mb*m ) - end if - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda=n ) ) then - call stdlib_${ci}$gelqt( m, n, mb, a, lda, t( 6 ), mb, work, info ) + call stdlib${ii}$_${ci}$gelqt( m, n, mb, a, lda, t( 6_${ik}$ ), mb, work, info ) else - call stdlib_${ci}$laswlq( m, n, mb, nb, a, lda, t( 6 ), mb, work,lwork, info ) + call stdlib${ii}$_${ci}$laswlq( m, n, mb, nb, a, lda, t( 6_${ik}$ ), mb, work,lwork, info ) end if - work( 1 ) = lwreq + work( 1_${ik}$ ) = lwreq return - end subroutine stdlib_${ci}$gelq + end subroutine stdlib${ii}$_${ci}$gelq - pure subroutine stdlib_${ci}$gelq2( m, n, a, lda, tau, work, info ) + pure subroutine stdlib${ii}$_${ci}$gelq2( m, n, a, lda, tau, work, info ) !! ZGELQ2: computes an LQ factorization of a complex m-by-n matrix A: !! A = ( L 0 ) * Q !! where: @@ -7168,52 +7163,52 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, k + integer(${ik}$) :: i, k complex(${ck}$) :: alpha ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda1 .and. nb1_${ik}$ .and. nbmin(m,n) .and. min(m,n)>0 ))then - info = -3 - else if( ldamin(m,n) .and. min(m,n)>0_${ik}$ ))then + info = -3_${ik}$ + else if( lda=n ) then - nb = stdlib_ilaenv( 1, 'ZGEQRF', ' ', m, n, -1, -1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) if( tpsd ) then - nb = max( nb, stdlib_ilaenv( 1, 'ZUNMQR', 'LN', m, nrhs, n,-1 ) ) + nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', 'LN', m, nrhs, n,-1_${ik}$ ) ) else - nb = max( nb, stdlib_ilaenv( 1, 'ZUNMQR', 'LC', m, nrhs, n,-1 ) ) + nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', 'LC', m, nrhs, n,-1_${ik}$ ) ) end if else - nb = stdlib_ilaenv( 1, 'ZGELQF', ' ', m, n, -1, -1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGELQF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) if( tpsd ) then - nb = max( nb, stdlib_ilaenv( 1, 'ZUNMLQ', 'LC', n, nrhs, m,-1 ) ) + nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMLQ', 'LC', n, nrhs, m,-1_${ik}$ ) ) else - nb = max( nb, stdlib_ilaenv( 1, 'ZUNMLQ', 'LN', n, nrhs, m,-1 ) ) + nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMLQ', 'LN', n, nrhs, m,-1_${ik}$ ) ) end if end if - wsize = max( 1, mn+max( mn, nrhs )*nb ) - work( 1 ) = real( wsize,KIND=${ck}$) + wsize = max( 1_${ik}$, mn+max( mn, nrhs )*nb ) + work( 1_${ik}$ ) = real( wsize,KIND=${ck}$) end if - if( info/=0 ) then - call stdlib_xerbla( 'ZGELS ', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZGELS ', -info ) return else if( lquery ) then return end if ! quick return if possible - if( min( m, n, nrhs )==0 ) then - call stdlib_${ci}$laset( 'FULL', max( m, n ), nrhs, czero, czero, b, ldb ) + if( min( m, n, nrhs )==0_${ik}$ ) then + call stdlib${ii}$_${ci}$laset( 'FULL', max( m, n ), nrhs, czero, czero, b, ldb ) return end if ! get machine parameters - smlnum = stdlib_${c2ri(ci)}$lamch( 'S' ) / stdlib_${c2ri(ci)}$lamch( 'P' ) + smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' ) / stdlib${ii}$_${c2ri(ci)}$lamch( 'P' ) bignum = one / smlnum - call stdlib_${c2ri(ci)}$labad( smlnum, bignum ) + call stdlib${ii}$_${c2ri(ci)}$labad( smlnum, bignum ) ! scale a, b if max element outside range [smlnum,bignum] - anrm = stdlib_${ci}$lange( 'M', m, n, a, lda, rwork ) - iascl = 0 + anrm = stdlib${ii}$_${ci}$lange( 'M', m, n, a, lda, rwork ) + iascl = 0_${ik}$ if( anrm>zero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_${ci}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_${ci}$laset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) + call stdlib${ii}$_${ci}$laset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) go to 50 end if brow = m if( tpsd )brow = n - bnrm = stdlib_${ci}$lange( 'M', brow, nrhs, b, ldb, rwork ) - ibscl = 0 + bnrm = stdlib${ii}$_${ci}$lange( 'M', brow, nrhs, b, ldb, rwork ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_${ci}$lascl( 'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,info ) - ibscl = 2 + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, brow, nrhs, b, ldb,info ) + ibscl = 2_${ik}$ end if if( m>=n ) then ! compute qr factorization of a - call stdlib_${ci}$geqrf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,info ) + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, work( 1_${ik}$ ), work( mn+1 ), lwork-mn,info ) ! workspace at least n, optimally n*nb if( .not.tpsd ) then ! least-squares problem min || a * x - b || ! b(1:m,1:nrhs) := q**h * b(1:m,1:nrhs) - call stdlib_${ci}$unmqr( 'LEFT', 'CONJUGATE TRANSPOSE', m, nrhs, n, a,lda, work( 1 ), & + call stdlib${ii}$_${ci}$unmqr( 'LEFT', 'CONJUGATE TRANSPOSE', m, nrhs, n, a,lda, work( 1_${ik}$ ), & b, ldb, work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb ! b(1:n,1:nrhs) := inv(r) * b(1:n,1:nrhs) - call stdlib_${ci}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, nrhs,a, lda, b, ldb, & + call stdlib${ii}$_${ci}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, nrhs,a, lda, b, ldb, & info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if scllen = n else ! underdetermined system of equations a**t * x = b ! b(1:n,1:nrhs) := inv(r**h) * b(1:n,1:nrhs) - call stdlib_${ci}$trtrs( 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT',n, nrhs, a, lda, b,& + call stdlib${ii}$_${ci}$trtrs( 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT',n, nrhs, a, lda, b,& ldb, info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if ! b(n+1:m,1:nrhs) = zero @@ -7609,21 +7604,21 @@ module stdlib_linalg_lapack_${ci}$ end do end do ! b(1:m,1:nrhs) := q(1:n,:) * b(1:n,1:nrhs) - call stdlib_${ci}$unmqr( 'LEFT', 'NO TRANSPOSE', m, nrhs, n, a, lda,work( 1 ), b, ldb,& + call stdlib${ii}$_${ci}$unmqr( 'LEFT', 'NO TRANSPOSE', m, nrhs, n, a, lda,work( 1_${ik}$ ), b, ldb,& work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb scllen = m end if else ! compute lq factorization of a - call stdlib_${ci}$gelqf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,info ) + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, work( 1_${ik}$ ), work( mn+1 ), lwork-mn,info ) ! workspace at least m, optimally m*nb. if( .not.tpsd ) then ! underdetermined system of equations a * x = b ! b(1:m,1:nrhs) := inv(l) * b(1:m,1:nrhs) - call stdlib_${ci}$trtrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & + call stdlib${ii}$_${ci}$trtrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if ! b(m+1:n,1:nrhs) = 0 @@ -7633,43 +7628,43 @@ module stdlib_linalg_lapack_${ci}$ end do end do ! b(1:n,1:nrhs) := q(1:n,:)**h * b(1:m,1:nrhs) - call stdlib_${ci}$unmlq( 'LEFT', 'CONJUGATE TRANSPOSE', n, nrhs, m, a,lda, work( 1 ), & + call stdlib${ii}$_${ci}$unmlq( 'LEFT', 'CONJUGATE TRANSPOSE', n, nrhs, m, a,lda, work( 1_${ik}$ ), & b, ldb, work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb scllen = n else ! overdetermined system min || a**h * x - b || ! b(1:n,1:nrhs) := q * b(1:n,1:nrhs) - call stdlib_${ci}$unmlq( 'LEFT', 'NO TRANSPOSE', n, nrhs, m, a, lda,work( 1 ), b, ldb,& + call stdlib${ii}$_${ci}$unmlq( 'LEFT', 'NO TRANSPOSE', n, nrhs, m, a, lda,work( 1_${ik}$ ), b, ldb,& work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb ! b(1:m,1:nrhs) := inv(l**h) * b(1:m,1:nrhs) - call stdlib_${ci}$trtrs( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',m, nrhs, a, lda, & + call stdlib${ii}$_${ci}$trtrs( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',m, nrhs, a, lda, & b, ldb, info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if scllen = m end if end if ! undo scaling - if( iascl==1 ) then - call stdlib_${ci}$lascl( 'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,info ) - else if( iascl==2 ) then - call stdlib_${ci}$lascl( 'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,info ) + if( iascl==1_${ik}$ ) then + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, smlnum, scllen, nrhs, b, ldb,info ) + else if( iascl==2_${ik}$ ) then + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, scllen, nrhs, b, ldb,info ) end if - if( ibscl==1 ) then - call stdlib_${ci}$lascl( 'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,info ) - else if( ibscl==2 ) then - call stdlib_${ci}$lascl( 'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,info ) + if( ibscl==1_${ik}$ ) then + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, bnrm, scllen, nrhs, b, ldb,info ) + else if( ibscl==2_${ik}$ ) then + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bignum, bnrm, scllen, nrhs, b, ldb,info ) end if 50 continue - work( 1 ) = real( wsize,KIND=${ck}$) + work( 1_${ik}$ ) = real( wsize,KIND=${ck}$) return - end subroutine stdlib_${ci}$gels + end subroutine stdlib${ii}$_${ci}$gels - subroutine stdlib_${ci}$gelsd( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, rwork, & + subroutine stdlib${ii}$_${ci}$gelsd( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, rwork, & !! ZGELSD: computes the minimum-norm solution to a real linear least !! squares problem: !! minimize 2-norm(| b - A*x |) @@ -7700,11 +7695,11 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, rank - integer(ilp), intent(in) :: lda, ldb, lwork, m, n, nrhs + integer(${ik}$), intent(out) :: info, rank + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, nrhs real(${ck}$), intent(in) :: rcond ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(${ck}$), intent(out) :: rwork(*), s(*) complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) complex(${ck}$), intent(out) :: work(*) @@ -7713,160 +7708,160 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: lquery - integer(ilp) :: iascl, ibscl, ie, il, itau, itaup, itauq, ldwork, liwork, lrwork, & + integer(${ik}$) :: iascl, ibscl, ie, il, itau, itaup, itauq, ldwork, liwork, lrwork, & maxmn, maxwrk, minmn, minwrk, mm, mnthr, nlvl, nrwork, nwork, smlsiz real(${ck}$) :: anrm, bignum, bnrm, eps, sfmin, smlnum ! Intrinsic Functions intrinsic :: int,log,max,min,real ! Executable Statements ! test the input arguments. - info = 0 + info = 0_${ik}$ minmn = min( m, n ) maxmn = max( m, n ) - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( lda0 ) then - smlsiz = stdlib_ilaenv( 9, 'ZGELSD', ' ', 0, 0, 0, 0 ) - mnthr = stdlib_ilaenv( 6, 'ZGELSD', ' ', m, n, nrhs, -1 ) - nlvl = max( int( log( real( minmn,KIND=${ck}$) / real( smlsiz + 1,KIND=${ck}$) ) /log( & - two ),KIND=ilp) + 1, 0 ) - liwork = 3*minmn*nlvl + 11*minmn + ! following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + liwork = 1_${ik}$ + lrwork = 1_${ik}$ + if( minmn>0_${ik}$ ) then + smlsiz = stdlib${ii}$_ilaenv( 9_${ik}$, 'ZGELSD', ' ', 0_${ik}$, 0_${ik}$, 0_${ik}$, 0_${ik}$ ) + mnthr = stdlib${ii}$_ilaenv( 6_${ik}$, 'ZGELSD', ' ', m, n, nrhs, -1_${ik}$ ) + nlvl = max( int( log( real( minmn,KIND=${ck}$) / real( smlsiz + 1_${ik}$,KIND=${ck}$) ) /log( & + two ),KIND=${ik}$) + 1_${ik}$, 0_${ik}$ ) + liwork = 3_${ik}$*minmn*nlvl + 11_${ik}$*minmn mm = m if( m>=n .and. m>=mnthr ) then ! path 1a - overdetermined, with many more rows than ! columns. mm = n - maxwrk = max( maxwrk, n*stdlib_ilaenv( 1, 'ZGEQRF', ' ', m, n,-1, -1 ) ) + maxwrk = max( maxwrk, n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', m, n,-1_${ik}$, -1_${ik}$ ) ) - maxwrk = max( maxwrk, nrhs*stdlib_ilaenv( 1, 'ZUNMQR', 'LC', m,nrhs, n, -1 ) ) + maxwrk = max( maxwrk, nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', 'LC', m,nrhs, n, -1_${ik}$ ) ) end if if( m>=n ) then ! path 1 - overdetermined or exactly determined. - lrwork = 10*n + 2*n*smlsiz + 8*n*nlvl + 3*smlsiz*nrhs +max( (smlsiz+1)**2, n*(& - 1+nrhs) + 2*nrhs ) - maxwrk = max( maxwrk, 2*n + ( mm + n )*stdlib_ilaenv( 1,'ZGEBRD', ' ', mm, n, & - -1, -1 ) ) - maxwrk = max( maxwrk, 2*n + nrhs*stdlib_ilaenv( 1, 'ZUNMBR','QLC', mm, nrhs, & - n, -1 ) ) - maxwrk = max( maxwrk, 2*n + ( n - 1 )*stdlib_ilaenv( 1,'ZUNMBR', 'PLN', n, & - nrhs, n, -1 ) ) - maxwrk = max( maxwrk, 2*n + n*nrhs ) - minwrk = max( 2*n + mm, 2*n + n*nrhs ) + lrwork = 10_${ik}$*n + 2_${ik}$*n*smlsiz + 8_${ik}$*n*nlvl + 3_${ik}$*smlsiz*nrhs +max( (smlsiz+1)**2_${ik}$, n*(& + 1_${ik}$+nrhs) + 2_${ik}$*nrhs ) + maxwrk = max( maxwrk, 2_${ik}$*n + ( mm + n )*stdlib${ii}$_ilaenv( 1_${ik}$,'ZGEBRD', ' ', mm, n, & + -1_${ik}$, -1_${ik}$ ) ) + maxwrk = max( maxwrk, 2_${ik}$*n + nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMBR','QLC', mm, nrhs, & + n, -1_${ik}$ ) ) + maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'ZUNMBR', 'PLN', n, & + nrhs, n, -1_${ik}$ ) ) + maxwrk = max( maxwrk, 2_${ik}$*n + n*nrhs ) + minwrk = max( 2_${ik}$*n + mm, 2_${ik}$*n + n*nrhs ) end if if( n>m ) then - lrwork = 10*m + 2*m*smlsiz + 8*m*nlvl + 3*smlsiz*nrhs +max( (smlsiz+1)**2, n*(& - 1+nrhs) + 2*nrhs ) + lrwork = 10_${ik}$*m + 2_${ik}$*m*smlsiz + 8_${ik}$*m*nlvl + 3_${ik}$*smlsiz*nrhs +max( (smlsiz+1)**2_${ik}$, n*(& + 1_${ik}$+nrhs) + 2_${ik}$*nrhs ) if( n>=mnthr ) then ! path 2a - underdetermined, with many more columns ! than rows. - maxwrk = m + m*stdlib_ilaenv( 1, 'ZGELQF', ' ', m, n, -1,-1 ) - maxwrk = max( maxwrk, m*m + 4*m + 2*m*stdlib_ilaenv( 1,'ZGEBRD', ' ', m, m,& - -1, -1 ) ) - maxwrk = max( maxwrk, m*m + 4*m + nrhs*stdlib_ilaenv( 1,'ZUNMBR', 'QLC', m,& - nrhs, m, -1 ) ) - maxwrk = max( maxwrk, m*m + 4*m + ( m - 1 )*stdlib_ilaenv( 1,'ZUNMLQ', & - 'LC', n, nrhs, m, -1 ) ) - if( nrhs>1 ) then + maxwrk = m + m*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGELQF', ' ', m, n, -1_${ik}$,-1_${ik}$ ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + 2_${ik}$*m*stdlib${ii}$_ilaenv( 1_${ik}$,'ZGEBRD', ' ', m, m,& + -1_${ik}$, -1_${ik}$ ) ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + nrhs*stdlib${ii}$_ilaenv( 1_${ik}$,'ZUNMBR', 'QLC', m,& + nrhs, m, -1_${ik}$ ) ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + ( m - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'ZUNMLQ', & + 'LC', n, nrhs, m, -1_${ik}$ ) ) + if( nrhs>1_${ik}$ ) then maxwrk = max( maxwrk, m*m + m + m*nrhs ) else - maxwrk = max( maxwrk, m*m + 2*m ) + maxwrk = max( maxwrk, m*m + 2_${ik}$*m ) end if - maxwrk = max( maxwrk, m*m + 4*m + m*nrhs ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + m*nrhs ) ! xxx: ensure the path 2a case below is triggered. the workspace ! calculation should use queries for all routines eventually. - maxwrk = max( maxwrk,4*m+m*m+max( m, 2*m-4, nrhs, n-3*m ) ) + maxwrk = max( maxwrk,4_${ik}$*m+m*m+max( m, 2_${ik}$*m-4, nrhs, n-3*m ) ) else ! path 2 - underdetermined. - maxwrk = 2*m + ( n + m )*stdlib_ilaenv( 1, 'ZGEBRD', ' ', m,n, -1, -1 ) + maxwrk = 2_${ik}$*m + ( n + m )*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEBRD', ' ', m,n, -1_${ik}$, -1_${ik}$ ) - maxwrk = max( maxwrk, 2*m + nrhs*stdlib_ilaenv( 1, 'ZUNMBR','QLC', m, nrhs,& - m, -1 ) ) - maxwrk = max( maxwrk, 2*m + m*stdlib_ilaenv( 1, 'ZUNMBR','PLN', n, nrhs, m,& - -1 ) ) - maxwrk = max( maxwrk, 2*m + m*nrhs ) + maxwrk = max( maxwrk, 2_${ik}$*m + nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMBR','QLC', m, nrhs,& + m, -1_${ik}$ ) ) + maxwrk = max( maxwrk, 2_${ik}$*m + m*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMBR','PLN', n, nrhs, m,& + -1_${ik}$ ) ) + maxwrk = max( maxwrk, 2_${ik}$*m + m*nrhs ) end if - minwrk = max( 2*m + n, 2*m + m*nrhs ) + minwrk = max( 2_${ik}$*m + n, 2_${ik}$*m + m*nrhs ) end if end if minwrk = min( minwrk, maxwrk ) - work( 1 ) = maxwrk - iwork( 1 ) = liwork - rwork( 1 ) = lrwork + work( 1_${ik}$ ) = maxwrk + iwork( 1_${ik}$ ) = liwork + rwork( 1_${ik}$ ) = lrwork if( lworkzero .and. anrmbignum ) then ! scale matrix norm down to bignum. - call stdlib_${ci}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_${ci}$laset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) - call stdlib_${c2ri(ci)}$laset( 'F', minmn, 1, zero, zero, s, 1 ) - rank = 0 + call stdlib${ii}$_${ci}$laset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) + call stdlib${ii}$_${c2ri(ci)}$laset( 'F', minmn, 1_${ik}$, zero, zero, s, 1_${ik}$ ) + rank = 0_${ik}$ go to 10 end if ! scale b if max entry outside range [smlnum,bignum]. - bnrm = stdlib_${ci}$lange( 'M', m, nrhs, b, ldb, rwork ) - ibscl = 0 + bnrm = stdlib${ii}$_${ci}$lange( 'M', m, nrhs, b, ldb, rwork ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum. - call stdlib_${ci}$lascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) - ibscl = 2 + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, m, nrhs, b, ldb, info ) + ibscl = 2_${ik}$ end if ! if m < n make sure b(m+1:n,:) = 0 - if( m=n ) then ! path 1 - overdetermined or exactly determined. @@ -7874,140 +7869,140 @@ module stdlib_linalg_lapack_${ci}$ if( m>=mnthr ) then ! path 1a - overdetermined, with many more rows than columns mm = n - itau = 1 + itau = 1_${ik}$ nwork = itau + n ! compute a=q*r. ! (rworkspace: need n) ! (cworkspace: need n, prefer n*nb) - call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & info ) ! multiply b by transpose(q). ! (rworkspace: need n) ! (cworkspace: need nrhs, prefer nrhs*nb) - call stdlib_${ci}$unmqr( 'L', 'C', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & + call stdlib${ii}$_${ci}$unmqr( 'L', 'C', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & nwork ), lwork-nwork+1, info ) ! zero out below r. - if( n>1 ) then - call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_${ci}$laset( 'L', n-1, n-1, czero, czero, a( 2_${ik}$, 1_${ik}$ ),lda ) end if end if - itauq = 1 + itauq = 1_${ik}$ itaup = itauq + n nwork = itaup + n - ie = 1 + ie = 1_${ik}$ nrwork = ie + n ! bidiagonalize r in a. ! (rworkspace: need n) ! (cworkspace: need 2*n+mm, prefer 2*n+(mm+n)*nb) - call stdlib_${ci}$gebrd( mm, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_${ci}$gebrd( mm, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors of r. ! (cworkspace: need 2*n+nrhs, prefer 2*n+nrhs*nb) - call stdlib_${ci}$unmbr( 'Q', 'L', 'C', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'C', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & nwork ), lwork-nwork+1, info ) ! solve the bidiagonal least squares problem. - call stdlib_${ci}$lalsd( 'U', smlsiz, n, nrhs, s, rwork( ie ), b, ldb,rcond, rank, work( & + call stdlib${ii}$_${ci}$lalsd( 'U', smlsiz, n, nrhs, s, rwork( ie ), b, ldb,rcond, rank, work( & nwork ), rwork( nrwork ),iwork, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then go to 10 end if ! multiply b by right bidiagonalizing vectors of r. - call stdlib_${ci}$unmbr( 'P', 'L', 'N', n, nrhs, n, a, lda, work( itaup ),b, ldb, work( & + call stdlib${ii}$_${ci}$unmbr( 'P', 'L', 'N', n, nrhs, n, a, lda, work( itaup ),b, ldb, work( & nwork ), lwork-nwork+1, info ) - else if( n>=mnthr .and. lwork>=4*m+m*m+max( m, 2*m-4, nrhs, n-3*m ) ) then + else if( n>=mnthr .and. lwork>=4_${ik}$*m+m*m+max( m, 2_${ik}$*m-4, nrhs, n-3*m ) ) then ! path 2a - underdetermined, with many more columns than rows ! and sufficient workspace for an efficient algorithm. ldwork = m - if( lwork>=max( 4*m+m*lda+max( m, 2*m-4, nrhs, n-3*m ),m*lda+m+m*nrhs ) )ldwork = & + if( lwork>=max( 4_${ik}$*m+m*lda+max( m, 2_${ik}$*m-4, nrhs, n-3*m ),m*lda+m+m*nrhs ) )ldwork = & lda - itau = 1 - nwork = m + 1 + itau = 1_${ik}$ + nwork = m + 1_${ik}$ ! compute a=l*q. ! (cworkspace: need 2*m, prefer m+m*nb) - call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, info ) + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, info ) il = nwork ! copy l to work(il), zeroing out above its diagonal. - call stdlib_${ci}$lacpy( 'L', m, m, a, lda, work( il ), ldwork ) - call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero, work( il+ldwork ),ldwork ) + call stdlib${ii}$_${ci}$lacpy( 'L', m, m, a, lda, work( il ), ldwork ) + call stdlib${ii}$_${ci}$laset( 'U', m-1, m-1, czero, czero, work( il+ldwork ),ldwork ) itauq = il + ldwork*m itaup = itauq + m nwork = itaup + m - ie = 1 + ie = 1_${ik}$ nrwork = ie + m ! bidiagonalize l in work(il). ! (rworkspace: need m) ! (cworkspace: need m*m+4*m, prefer m*m+4*m+2*m*nb) - call stdlib_${ci}$gebrd( m, m, work( il ), ldwork, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_${ci}$gebrd( m, m, work( il ), ldwork, s, rwork( ie ),work( itauq ), work( & itaup ), work( nwork ),lwork-nwork+1, info ) ! multiply b by transpose of left bidiagonalizing vectors of l. ! (cworkspace: need m*m+4*m+nrhs, prefer m*m+4*m+nrhs*nb) - call stdlib_${ci}$unmbr( 'Q', 'L', 'C', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'C', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & ldb, work( nwork ),lwork-nwork+1, info ) ! solve the bidiagonal least squares problem. - call stdlib_${ci}$lalsd( 'U', smlsiz, m, nrhs, s, rwork( ie ), b, ldb,rcond, rank, work( & + call stdlib${ii}$_${ci}$lalsd( 'U', smlsiz, m, nrhs, s, rwork( ie ), b, ldb,rcond, rank, work( & nwork ), rwork( nrwork ),iwork, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then go to 10 end if ! multiply b by right bidiagonalizing vectors of l. - call stdlib_${ci}$unmbr( 'P', 'L', 'N', m, nrhs, m, work( il ), ldwork,work( itaup ), b, & + call stdlib${ii}$_${ci}$unmbr( 'P', 'L', 'N', m, nrhs, m, work( il ), ldwork,work( itaup ), b, & ldb, work( nwork ),lwork-nwork+1, info ) ! zero out below first m rows of b. - call stdlib_${ci}$laset( 'F', n-m, nrhs, czero, czero, b( m+1, 1 ), ldb ) + call stdlib${ii}$_${ci}$laset( 'F', n-m, nrhs, czero, czero, b( m+1, 1_${ik}$ ), ldb ) nwork = itau + m ! multiply transpose(q) by b. ! (cworkspace: need nrhs, prefer nrhs*nb) - call stdlib_${ci}$unmlq( 'L', 'C', n, nrhs, m, a, lda, work( itau ), b,ldb, work( nwork )& + call stdlib${ii}$_${ci}$unmlq( 'L', 'C', n, nrhs, m, a, lda, work( itau ), b,ldb, work( nwork )& , lwork-nwork+1, info ) else ! path 2 - remaining underdetermined cases. - itauq = 1 + itauq = 1_${ik}$ itaup = itauq + m nwork = itaup + m - ie = 1 + ie = 1_${ik}$ nrwork = ie + m ! bidiagonalize a. ! (rworkspace: need m) ! (cworkspace: need 2*m+n, prefer 2*m+(m+n)*nb) - call stdlib_${ci}$gebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), work(& + call stdlib${ii}$_${ci}$gebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), work(& nwork ), lwork-nwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors. ! (cworkspace: need 2*m+nrhs, prefer 2*m+nrhs*nb) - call stdlib_${ci}$unmbr( 'Q', 'L', 'C', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'C', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & nwork ), lwork-nwork+1, info ) ! solve the bidiagonal least squares problem. - call stdlib_${ci}$lalsd( 'L', smlsiz, m, nrhs, s, rwork( ie ), b, ldb,rcond, rank, work( & + call stdlib${ii}$_${ci}$lalsd( 'L', smlsiz, m, nrhs, s, rwork( ie ), b, ldb,rcond, rank, work( & nwork ), rwork( nrwork ),iwork, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then go to 10 end if ! multiply b by right bidiagonalizing vectors of a. - call stdlib_${ci}$unmbr( 'P', 'L', 'N', n, nrhs, m, a, lda, work( itaup ),b, ldb, work( & + call stdlib${ii}$_${ci}$unmbr( 'P', 'L', 'N', n, nrhs, m, a, lda, work( itaup ),b, ldb, work( & nwork ), lwork-nwork+1, info ) end if ! undo scaling. - if( iascl==1 ) then - call stdlib_${ci}$lascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info ) - call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn,info ) - else if( iascl==2 ) then - call stdlib_${ci}$lascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info ) - call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,info ) - end if - if( ibscl==1 ) then - call stdlib_${ci}$lascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info ) - else if( ibscl==2 ) then - call stdlib_${ci}$lascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info ) + if( iascl==1_${ik}$ ) then + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, smlnum, n, nrhs, b, ldb, info ) + call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, anrm, minmn, 1_${ik}$, s, minmn,info ) + else if( iascl==2_${ik}$ ) then + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, n, nrhs, b, ldb, info ) + call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn, 1_${ik}$, s, minmn,info ) + end if + if( ibscl==1_${ik}$ ) then + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, bnrm, n, nrhs, b, ldb, info ) + else if( ibscl==2_${ik}$ ) then + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bignum, bnrm, n, nrhs, b, ldb, info ) end if 10 continue - work( 1 ) = maxwrk - iwork( 1 ) = liwork - rwork( 1 ) = lrwork + work( 1_${ik}$ ) = maxwrk + iwork( 1_${ik}$ ) = liwork + rwork( 1_${ik}$ ) = lrwork return - end subroutine stdlib_${ci}$gelsd + end subroutine stdlib${ii}$_${ci}$gelsd - subroutine stdlib_${ci}$gelss( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, rwork, & + subroutine stdlib${ii}$_${ci}$gelss( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, rwork, & !! ZGELSS: computes the minimum norm solution to a complex linear !! least squares problem: !! Minimize 2-norm(| b - A*x |). @@ -8025,8 +8020,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, rank - integer(ilp), intent(in) :: lda, ldb, lwork, m, n, nrhs + integer(${ik}$), intent(out) :: info, rank + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, nrhs real(${ck}$), intent(in) :: rcond ! Array Arguments real(${ck}$), intent(out) :: rwork(*), s(*) @@ -8037,31 +8032,31 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: lquery - integer(ilp) :: bl, chunk, i, iascl, ibscl, ie, il, irwork, itau, itaup, itauq, iwork, & + integer(${ik}$) :: bl, chunk, i, iascl, ibscl, ie, il, irwork, itau, itaup, itauq, iwork, & ldwork, maxmn, maxwrk, minmn, minwrk, mm, mnthr - integer(ilp) :: lwork_wgeqrf, lwork_wunmqr, lwork_wgebrd, lwork_wunmbr, lwork_wungbr, & + integer(${ik}$) :: lwork_wgeqrf, lwork_wunmqr, lwork_wgebrd, lwork_wunmbr, lwork_wungbr, & lwork_wunmlq, lwork_wgelqf real(${ck}$) :: anrm, bignum, bnrm, eps, sfmin, smlnum, thr ! Local Arrays - complex(${ck}$) :: dum(1) + complex(${ck}$) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ minmn = min( m, n ) maxmn = max( m, n ) - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( lda0 ) then + ! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + if( minmn>0_${ik}$ ) then mm = m - mnthr = stdlib_ilaenv( 6, 'ZGELSS', ' ', m, n, nrhs, -1 ) + mnthr = stdlib${ii}$_ilaenv( 6_${ik}$, 'ZGELSS', ' ', m, n, nrhs, -1_${ik}$ ) if( m>=n .and. m>=mnthr ) then ! path 1a - overdetermined, with many more rows than ! columns - ! compute space needed for stdlib_${ci}$geqrf - call stdlib_${ci}$geqrf( m, n, a, lda, dum(1), dum(1), -1, info ) - lwork_wgeqrf = real( dum(1),KIND=${ck}$) - ! compute space needed for stdlib_${ci}$unmqr - call stdlib_${ci}$unmqr( 'L', 'C', m, nrhs, n, a, lda, dum(1), b,ldb, dum(1), -1, & + ! compute space needed for stdlib${ii}$_${ci}$geqrf + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, info ) + lwork_wgeqrf = real( dum(1_${ik}$),KIND=${ck}$) + ! compute space needed for stdlib${ii}$_${ci}$unmqr + call stdlib${ii}$_${ci}$unmqr( 'L', 'C', m, nrhs, n, a, lda, dum(1_${ik}$), b,ldb, dum(1_${ik}$), -1_${ik}$, & info ) - lwork_wunmqr = real( dum(1),KIND=${ck}$) + lwork_wunmqr = real( dum(1_${ik}$),KIND=${ck}$) mm = n - maxwrk = max( maxwrk, n + n*stdlib_ilaenv( 1, 'ZGEQRF', ' ', m,n, -1, -1 ) ) + maxwrk = max( maxwrk, n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', m,n, -1_${ik}$, -1_${ik}$ ) ) - maxwrk = max( maxwrk, n + nrhs*stdlib_ilaenv( 1, 'ZUNMQR', 'LC',m, nrhs, n, -& - 1 ) ) + maxwrk = max( maxwrk, n + nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', 'LC',m, nrhs, n, -& + 1_${ik}$ ) ) end if if( m>=n ) then ! path 1 - overdetermined or exactly determined - ! compute space needed for stdlib_${ci}$gebrd - call stdlib_${ci}$gebrd( mm, n, a, lda, s, s, dum(1), dum(1), dum(1),-1, info ) + ! compute space needed for stdlib${ii}$_${ci}$gebrd + call stdlib${ii}$_${ci}$gebrd( mm, n, a, lda, s, s, dum(1_${ik}$), dum(1_${ik}$), dum(1_${ik}$),-1_${ik}$, info ) - lwork_wgebrd = real( dum(1),KIND=${ck}$) - ! compute space needed for stdlib_${ci}$unmbr - call stdlib_${ci}$unmbr( 'Q', 'L', 'C', mm, nrhs, n, a, lda, dum(1),b, ldb, dum(1),& - -1, info ) - lwork_wunmbr = real( dum(1),KIND=${ck}$) - ! compute space needed for stdlib_${ci}$ungbr - call stdlib_${ci}$ungbr( 'P', n, n, n, a, lda, dum(1),dum(1), -1, info ) - lwork_wungbr = real( dum(1),KIND=${ck}$) + lwork_wgebrd = real( dum(1_${ik}$),KIND=${ck}$) + ! compute space needed for stdlib${ii}$_${ci}$unmbr + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'C', mm, nrhs, n, a, lda, dum(1_${ik}$),b, ldb, dum(1_${ik}$),& + -1_${ik}$, info ) + lwork_wunmbr = real( dum(1_${ik}$),KIND=${ck}$) + ! compute space needed for stdlib${ii}$_${ci}$ungbr + call stdlib${ii}$_${ci}$ungbr( 'P', n, n, n, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, info ) + lwork_wungbr = real( dum(1_${ik}$),KIND=${ck}$) ! compute total workspace needed - maxwrk = max( maxwrk, 2*n + lwork_wgebrd ) - maxwrk = max( maxwrk, 2*n + lwork_wunmbr ) - maxwrk = max( maxwrk, 2*n + lwork_wungbr ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_wgebrd ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_wunmbr ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_wungbr ) maxwrk = max( maxwrk, n*nrhs ) - minwrk = 2*n + max( nrhs, m ) + minwrk = 2_${ik}$*n + max( nrhs, m ) end if if( n>m ) then - minwrk = 2*m + max( nrhs, n ) + minwrk = 2_${ik}$*m + max( nrhs, n ) if( n>=mnthr ) then ! path 2a - underdetermined, with many more columns ! than rows - ! compute space needed for stdlib_${ci}$gelqf - call stdlib_${ci}$gelqf( m, n, a, lda, dum(1), dum(1),-1, info ) - lwork_wgelqf = real( dum(1),KIND=${ck}$) - ! compute space needed for stdlib_${ci}$gebrd - call stdlib_${ci}$gebrd( m, m, a, lda, s, s, dum(1), dum(1),dum(1), -1, info ) + ! compute space needed for stdlib${ii}$_${ci}$gelqf + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, dum(1_${ik}$), dum(1_${ik}$),-1_${ik}$, info ) + lwork_wgelqf = real( dum(1_${ik}$),KIND=${ck}$) + ! compute space needed for stdlib${ii}$_${ci}$gebrd + call stdlib${ii}$_${ci}$gebrd( m, m, a, lda, s, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, info ) - lwork_wgebrd = real( dum(1),KIND=${ck}$) - ! compute space needed for stdlib_${ci}$unmbr - call stdlib_${ci}$unmbr( 'Q', 'L', 'C', m, nrhs, n, a, lda,dum(1), b, ldb, dum(& - 1), -1, info ) - lwork_wunmbr = real( dum(1),KIND=${ck}$) - ! compute space needed for stdlib_${ci}$ungbr - call stdlib_${ci}$ungbr( 'P', m, m, m, a, lda, dum(1),dum(1), -1, info ) - lwork_wungbr = real( dum(1),KIND=${ck}$) - ! compute space needed for stdlib_${ci}$unmlq - call stdlib_${ci}$unmlq( 'L', 'C', n, nrhs, m, a, lda, dum(1),b, ldb, dum(1), -& - 1, info ) - lwork_wunmlq = real( dum(1),KIND=${ck}$) + lwork_wgebrd = real( dum(1_${ik}$),KIND=${ck}$) + ! compute space needed for stdlib${ii}$_${ci}$unmbr + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'C', m, nrhs, n, a, lda,dum(1_${ik}$), b, ldb, dum(& + 1_${ik}$), -1_${ik}$, info ) + lwork_wunmbr = real( dum(1_${ik}$),KIND=${ck}$) + ! compute space needed for stdlib${ii}$_${ci}$ungbr + call stdlib${ii}$_${ci}$ungbr( 'P', m, m, m, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, info ) + lwork_wungbr = real( dum(1_${ik}$),KIND=${ck}$) + ! compute space needed for stdlib${ii}$_${ci}$unmlq + call stdlib${ii}$_${ci}$unmlq( 'L', 'C', n, nrhs, m, a, lda, dum(1_${ik}$),b, ldb, dum(1_${ik}$), -& + 1_${ik}$, info ) + lwork_wunmlq = real( dum(1_${ik}$),KIND=${ck}$) ! compute total workspace needed maxwrk = m + lwork_wgelqf - maxwrk = max( maxwrk, 3*m + m*m + lwork_wgebrd ) - maxwrk = max( maxwrk, 3*m + m*m + lwork_wunmbr ) - maxwrk = max( maxwrk, 3*m + m*m + lwork_wungbr ) - if( nrhs>1 ) then + maxwrk = max( maxwrk, 3_${ik}$*m + m*m + lwork_wgebrd ) + maxwrk = max( maxwrk, 3_${ik}$*m + m*m + lwork_wunmbr ) + maxwrk = max( maxwrk, 3_${ik}$*m + m*m + lwork_wungbr ) + if( nrhs>1_${ik}$ ) then maxwrk = max( maxwrk, m*m + m + m*nrhs ) else - maxwrk = max( maxwrk, m*m + 2*m ) + maxwrk = max( maxwrk, m*m + 2_${ik}$*m ) end if maxwrk = max( maxwrk, m + lwork_wunmlq ) else ! path 2 - underdetermined - ! compute space needed for stdlib_${ci}$gebrd - call stdlib_${ci}$gebrd( m, n, a, lda, s, s, dum(1), dum(1),dum(1), -1, info ) + ! compute space needed for stdlib${ii}$_${ci}$gebrd + call stdlib${ii}$_${ci}$gebrd( m, n, a, lda, s, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, info ) - lwork_wgebrd = real( dum(1),KIND=${ck}$) - ! compute space needed for stdlib_${ci}$unmbr - call stdlib_${ci}$unmbr( 'Q', 'L', 'C', m, nrhs, m, a, lda,dum(1), b, ldb, dum(& - 1), -1, info ) - lwork_wunmbr = real( dum(1),KIND=${ck}$) - ! compute space needed for stdlib_${ci}$ungbr - call stdlib_${ci}$ungbr( 'P', m, n, m, a, lda, dum(1),dum(1), -1, info ) - lwork_wungbr = real( dum(1),KIND=${ck}$) - maxwrk = 2*m + lwork_wgebrd - maxwrk = max( maxwrk, 2*m + lwork_wunmbr ) - maxwrk = max( maxwrk, 2*m + lwork_wungbr ) + lwork_wgebrd = real( dum(1_${ik}$),KIND=${ck}$) + ! compute space needed for stdlib${ii}$_${ci}$unmbr + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'C', m, nrhs, m, a, lda,dum(1_${ik}$), b, ldb, dum(& + 1_${ik}$), -1_${ik}$, info ) + lwork_wunmbr = real( dum(1_${ik}$),KIND=${ck}$) + ! compute space needed for stdlib${ii}$_${ci}$ungbr + call stdlib${ii}$_${ci}$ungbr( 'P', m, n, m, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, info ) + lwork_wungbr = real( dum(1_${ik}$),KIND=${ck}$) + maxwrk = 2_${ik}$*m + lwork_wgebrd + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_wunmbr ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_wungbr ) maxwrk = max( maxwrk, n*nrhs ) end if end if maxwrk = max( minwrk, maxwrk ) end if - work( 1 ) = maxwrk - if( lworkzero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_${ci}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_${ci}$laset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) - call stdlib_${c2ri(ci)}$laset( 'F', minmn, 1, zero, zero, s, minmn ) - rank = 0 + call stdlib${ii}$_${ci}$laset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) + call stdlib${ii}$_${c2ri(ci)}$laset( 'F', minmn, 1_${ik}$, zero, zero, s, minmn ) + rank = 0_${ik}$ go to 70 end if ! scale b if max element outside range [smlnum,bignum] - bnrm = stdlib_${ci}$lange( 'M', m, nrhs, b, ldb, rwork ) - ibscl = 0 + bnrm = stdlib${ii}$_${ci}$lange( 'M', m, nrhs, b, ldb, rwork ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_${ci}$lascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) - ibscl = 2 + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, m, nrhs, b, ldb, info ) + ibscl = 2_${ik}$ end if ! overdetermined case if( m>=n ) then @@ -8224,115 +8219,115 @@ module stdlib_linalg_lapack_${ci}$ if( m>=mnthr ) then ! path 1a - overdetermined, with many more rows than columns mm = n - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: none) - call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & info ) ! multiply b by transpose(q) ! (cworkspace: need n+nrhs, prefer n+nrhs*nb) ! (rworkspace: none) - call stdlib_${ci}$unmqr( 'L', 'C', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & + call stdlib${ii}$_${ci}$unmqr( 'L', 'C', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & iwork ), lwork-iwork+1, info ) ! zero out below r - if( n>1 )call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) + if( n>1_${ik}$ )call stdlib${ii}$_${ci}$laset( 'L', n-1, n-1, czero, czero, a( 2_${ik}$, 1_${ik}$ ),lda ) end if - ie = 1 - itauq = 1 + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + n iwork = itaup + n ! bidiagonalize r in a ! (cworkspace: need 2*n+mm, prefer 2*n+(mm+n)*nb) ! (rworkspace: need n) - call stdlib_${ci}$gebrd( mm, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_${ci}$gebrd( mm, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors of r ! (cworkspace: need 2*n+nrhs, prefer 2*n+nrhs*nb) ! (rworkspace: none) - call stdlib_${ci}$unmbr( 'Q', 'L', 'C', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'C', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & iwork ), lwork-iwork+1, info ) ! generate right bidiagonalizing vectors of r in a ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: none) - call stdlib_${ci}$ungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-iwork+& - 1, info ) + call stdlib${ii}$_${ci}$ungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-iwork+& + 1_${ik}$, info ) irwork = ie + n ! perform bidiagonal qr iteration ! multiply b by transpose of left singular vectors ! compute right singular vectors in a ! (cworkspace: none) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', n, n, 0, nrhs, s, rwork( ie ), a, lda, dum,1, b, ldb, & + call stdlib${ii}$_${ci}$bdsqr( 'U', n, n, 0_${ik}$, nrhs, s, rwork( ie ), a, lda, dum,1_${ik}$, b, ldb, & rwork( irwork ), info ) if( info/=0 )go to 70 ! multiply b by reciprocals of singular values - thr = max( rcond*s( 1 ), sfmin ) - if( rcondthr ) then - call stdlib_${ci}$drscl( nrhs, s( i ), b( i, 1 ), ldb ) - rank = rank + 1 + call stdlib${ii}$_${ci}$drscl( nrhs, s( i ), b( i, 1_${ik}$ ), ldb ) + rank = rank + 1_${ik}$ else - call stdlib_${ci}$laset( 'F', 1, nrhs, czero, czero, b( i, 1 ), ldb ) + call stdlib${ii}$_${ci}$laset( 'F', 1_${ik}$, nrhs, czero, czero, b( i, 1_${ik}$ ), ldb ) end if end do ! multiply b by right singular vectors ! (cworkspace: need n, prefer n*nrhs) ! (rworkspace: none) - if( lwork>=ldb*nrhs .and. nrhs>1 ) then - call stdlib_${ci}$gemm( 'C', 'N', n, nrhs, n, cone, a, lda, b, ldb,czero, work, ldb ) + if( lwork>=ldb*nrhs .and. nrhs>1_${ik}$ ) then + call stdlib${ii}$_${ci}$gemm( 'C', 'N', n, nrhs, n, cone, a, lda, b, ldb,czero, work, ldb ) - call stdlib_${ci}$lacpy( 'G', n, nrhs, work, ldb, b, ldb ) - else if( nrhs>1 ) then + call stdlib${ii}$_${ci}$lacpy( 'G', n, nrhs, work, ldb, b, ldb ) + else if( nrhs>1_${ik}$ ) then chunk = lwork / n do i = 1, nrhs, chunk bl = min( nrhs-i+1, chunk ) - call stdlib_${ci}$gemm( 'C', 'N', n, bl, n, cone, a, lda, b( 1, i ),ldb, czero, & + call stdlib${ii}$_${ci}$gemm( 'C', 'N', n, bl, n, cone, a, lda, b( 1_${ik}$, i ),ldb, czero, & work, n ) - call stdlib_${ci}$lacpy( 'G', n, bl, work, n, b( 1, i ), ldb ) + call stdlib${ii}$_${ci}$lacpy( 'G', n, bl, work, n, b( 1_${ik}$, i ), ldb ) end do else - call stdlib_${ci}$gemv( 'C', n, n, cone, a, lda, b, 1, czero, work, 1 ) - call stdlib_${ci}$copy( n, work, 1, b, 1 ) + call stdlib${ii}$_${ci}$gemv( 'C', n, n, cone, a, lda, b, 1_${ik}$, czero, work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$copy( n, work, 1_${ik}$, b, 1_${ik}$ ) end if - else if( n>=mnthr .and. lwork>=3*m+m*m+max( m, nrhs, n-2*m ) )then + else if( n>=mnthr .and. lwork>=3_${ik}$*m+m*m+max( m, nrhs, n-2*m ) )then ! underdetermined case, m much less than n ! path 2a - underdetermined, with many more columns than rows ! and sufficient workspace for an efficient algorithm ldwork = m - if( lwork>=3*m+m*lda+max( m, nrhs, n-2*m ) )ldwork = lda - itau = 1 - iwork = m + 1 + if( lwork>=3_${ik}$*m+m*lda+max( m, nrhs, n-2*m ) )ldwork = lda + itau = 1_${ik}$ + iwork = m + 1_${ik}$ ! compute a=l*q ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: none) - call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, info ) + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, info ) il = iwork ! copy l to work(il), zeroing out above it - call stdlib_${ci}$lacpy( 'L', m, m, a, lda, work( il ), ldwork ) - call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero, work( il+ldwork ),ldwork ) - ie = 1 + call stdlib${ii}$_${ci}$lacpy( 'L', m, m, a, lda, work( il ), ldwork ) + call stdlib${ii}$_${ci}$laset( 'U', m-1, m-1, czero, czero, work( il+ldwork ),ldwork ) + ie = 1_${ik}$ itauq = il + ldwork*m itaup = itauq + m iwork = itaup + m ! bidiagonalize l in work(il) ! (cworkspace: need m*m+4*m, prefer m*m+3*m+2*m*nb) ! (rworkspace: need m) - call stdlib_${ci}$gebrd( m, m, work( il ), ldwork, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_${ci}$gebrd( m, m, work( il ), ldwork, s, rwork( ie ),work( itauq ), work( & itaup ), work( iwork ),lwork-iwork+1, info ) ! multiply b by transpose of left bidiagonalizing vectors of l ! (cworkspace: need m*m+3*m+nrhs, prefer m*m+3*m+nrhs*nb) ! (rworkspace: none) - call stdlib_${ci}$unmbr( 'Q', 'L', 'C', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'C', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & ldb, work( iwork ),lwork-iwork+1, info ) ! generate right bidiagonalizing vectors of r in work(il) ! (cworkspace: need m*m+4*m-1, prefer m*m+3*m+(m-1)*nb) ! (rworkspace: none) - call stdlib_${ci}$ungbr( 'P', m, m, m, work( il ), ldwork, work( itaup ),work( iwork ), & + call stdlib${ii}$_${ci}$ungbr( 'P', m, m, m, work( il ), ldwork, work( itaup ),work( iwork ), & lwork-iwork+1, info ) irwork = ie + m ! perform bidiagonal qr iteration, computing right singular @@ -8340,132 +8335,132 @@ module stdlib_linalg_lapack_${ci}$ ! left singular vectors ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', m, m, 0, nrhs, s, rwork( ie ), work( il ),ldwork, a, lda, & + call stdlib${ii}$_${ci}$bdsqr( 'U', m, m, 0_${ik}$, nrhs, s, rwork( ie ), work( il ),ldwork, a, lda, & b, ldb, rwork( irwork ), info ) if( info/=0 )go to 70 ! multiply b by reciprocals of singular values - thr = max( rcond*s( 1 ), sfmin ) - if( rcondthr ) then - call stdlib_${ci}$drscl( nrhs, s( i ), b( i, 1 ), ldb ) - rank = rank + 1 + call stdlib${ii}$_${ci}$drscl( nrhs, s( i ), b( i, 1_${ik}$ ), ldb ) + rank = rank + 1_${ik}$ else - call stdlib_${ci}$laset( 'F', 1, nrhs, czero, czero, b( i, 1 ), ldb ) + call stdlib${ii}$_${ci}$laset( 'F', 1_${ik}$, nrhs, czero, czero, b( i, 1_${ik}$ ), ldb ) end if end do iwork = il + m*ldwork ! multiply b by right singular vectors of l in work(il) ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nrhs) ! (rworkspace: none) - if( lwork>=ldb*nrhs+iwork-1 .and. nrhs>1 ) then - call stdlib_${ci}$gemm( 'C', 'N', m, nrhs, m, cone, work( il ), ldwork,b, ldb, czero, & + if( lwork>=ldb*nrhs+iwork-1 .and. nrhs>1_${ik}$ ) then + call stdlib${ii}$_${ci}$gemm( 'C', 'N', m, nrhs, m, cone, work( il ), ldwork,b, ldb, czero, & work( iwork ), ldb ) - call stdlib_${ci}$lacpy( 'G', m, nrhs, work( iwork ), ldb, b, ldb ) - else if( nrhs>1 ) then + call stdlib${ii}$_${ci}$lacpy( 'G', m, nrhs, work( iwork ), ldb, b, ldb ) + else if( nrhs>1_${ik}$ ) then chunk = ( lwork-iwork+1 ) / m do i = 1, nrhs, chunk bl = min( nrhs-i+1, chunk ) - call stdlib_${ci}$gemm( 'C', 'N', m, bl, m, cone, work( il ), ldwork,b( 1, i ), & + call stdlib${ii}$_${ci}$gemm( 'C', 'N', m, bl, m, cone, work( il ), ldwork,b( 1_${ik}$, i ), & ldb, czero, work( iwork ), m ) - call stdlib_${ci}$lacpy( 'G', m, bl, work( iwork ), m, b( 1, i ),ldb ) + call stdlib${ii}$_${ci}$lacpy( 'G', m, bl, work( iwork ), m, b( 1_${ik}$, i ),ldb ) end do else - call stdlib_${ci}$gemv( 'C', m, m, cone, work( il ), ldwork, b( 1, 1 ),1, czero, work(& - iwork ), 1 ) - call stdlib_${ci}$copy( m, work( iwork ), 1, b( 1, 1 ), 1 ) + call stdlib${ii}$_${ci}$gemv( 'C', m, m, cone, work( il ), ldwork, b( 1_${ik}$, 1_${ik}$ ),1_${ik}$, czero, work(& + iwork ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$copy( m, work( iwork ), 1_${ik}$, b( 1_${ik}$, 1_${ik}$ ), 1_${ik}$ ) end if ! zero out below first m rows of b - call stdlib_${ci}$laset( 'F', n-m, nrhs, czero, czero, b( m+1, 1 ), ldb ) + call stdlib${ii}$_${ci}$laset( 'F', n-m, nrhs, czero, czero, b( m+1, 1_${ik}$ ), ldb ) iwork = itau + m ! multiply transpose(q) by b ! (cworkspace: need m+nrhs, prefer m+nhrs*nb) ! (rworkspace: none) - call stdlib_${ci}$unmlq( 'L', 'C', n, nrhs, m, a, lda, work( itau ), b,ldb, work( iwork )& + call stdlib${ii}$_${ci}$unmlq( 'L', 'C', n, nrhs, m, a, lda, work( itau ), b,ldb, work( iwork )& , lwork-iwork+1, info ) else ! path 2 - remaining underdetermined cases - ie = 1 - itauq = 1 + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + m iwork = itaup + m ! bidiagonalize a ! (cworkspace: need 3*m, prefer 2*m+(m+n)*nb) ! (rworkspace: need n) - call stdlib_${ci}$gebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), work(& + call stdlib${ii}$_${ci}$gebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), work(& iwork ), lwork-iwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors ! (cworkspace: need 2*m+nrhs, prefer 2*m+nrhs*nb) ! (rworkspace: none) - call stdlib_${ci}$unmbr( 'Q', 'L', 'C', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'C', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & iwork ), lwork-iwork+1, info ) ! generate right bidiagonalizing vectors in a ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: none) - call stdlib_${ci}$ungbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-iwork+& - 1, info ) + call stdlib${ii}$_${ci}$ungbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-iwork+& + 1_${ik}$, info ) irwork = ie + m ! perform bidiagonal qr iteration, ! computing right singular vectors of a in a and ! multiplying b by transpose of left singular vectors ! (cworkspace: none) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'L', m, n, 0, nrhs, s, rwork( ie ), a, lda, dum,1, b, ldb, & + call stdlib${ii}$_${ci}$bdsqr( 'L', m, n, 0_${ik}$, nrhs, s, rwork( ie ), a, lda, dum,1_${ik}$, b, ldb, & rwork( irwork ), info ) if( info/=0 )go to 70 ! multiply b by reciprocals of singular values - thr = max( rcond*s( 1 ), sfmin ) - if( rcondthr ) then - call stdlib_${ci}$drscl( nrhs, s( i ), b( i, 1 ), ldb ) - rank = rank + 1 + call stdlib${ii}$_${ci}$drscl( nrhs, s( i ), b( i, 1_${ik}$ ), ldb ) + rank = rank + 1_${ik}$ else - call stdlib_${ci}$laset( 'F', 1, nrhs, czero, czero, b( i, 1 ), ldb ) + call stdlib${ii}$_${ci}$laset( 'F', 1_${ik}$, nrhs, czero, czero, b( i, 1_${ik}$ ), ldb ) end if end do ! multiply b by right singular vectors of a ! (cworkspace: need n, prefer n*nrhs) ! (rworkspace: none) - if( lwork>=ldb*nrhs .and. nrhs>1 ) then - call stdlib_${ci}$gemm( 'C', 'N', n, nrhs, m, cone, a, lda, b, ldb,czero, work, ldb ) + if( lwork>=ldb*nrhs .and. nrhs>1_${ik}$ ) then + call stdlib${ii}$_${ci}$gemm( 'C', 'N', n, nrhs, m, cone, a, lda, b, ldb,czero, work, ldb ) - call stdlib_${ci}$lacpy( 'G', n, nrhs, work, ldb, b, ldb ) - else if( nrhs>1 ) then + call stdlib${ii}$_${ci}$lacpy( 'G', n, nrhs, work, ldb, b, ldb ) + else if( nrhs>1_${ik}$ ) then chunk = lwork / n do i = 1, nrhs, chunk bl = min( nrhs-i+1, chunk ) - call stdlib_${ci}$gemm( 'C', 'N', n, bl, m, cone, a, lda, b( 1, i ),ldb, czero, & + call stdlib${ii}$_${ci}$gemm( 'C', 'N', n, bl, m, cone, a, lda, b( 1_${ik}$, i ),ldb, czero, & work, n ) - call stdlib_${ci}$lacpy( 'F', n, bl, work, n, b( 1, i ), ldb ) + call stdlib${ii}$_${ci}$lacpy( 'F', n, bl, work, n, b( 1_${ik}$, i ), ldb ) end do else - call stdlib_${ci}$gemv( 'C', m, n, cone, a, lda, b, 1, czero, work, 1 ) - call stdlib_${ci}$copy( n, work, 1, b, 1 ) + call stdlib${ii}$_${ci}$gemv( 'C', m, n, cone, a, lda, b, 1_${ik}$, czero, work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$copy( n, work, 1_${ik}$, b, 1_${ik}$ ) end if end if ! undo scaling - if( iascl==1 ) then - call stdlib_${ci}$lascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info ) - call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn,info ) - else if( iascl==2 ) then - call stdlib_${ci}$lascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info ) - call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,info ) - end if - if( ibscl==1 ) then - call stdlib_${ci}$lascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info ) - else if( ibscl==2 ) then - call stdlib_${ci}$lascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info ) + if( iascl==1_${ik}$ ) then + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, smlnum, n, nrhs, b, ldb, info ) + call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, anrm, minmn, 1_${ik}$, s, minmn,info ) + else if( iascl==2_${ik}$ ) then + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, n, nrhs, b, ldb, info ) + call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn, 1_${ik}$, s, minmn,info ) + end if + if( ibscl==1_${ik}$ ) then + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, bnrm, n, nrhs, b, ldb, info ) + else if( ibscl==2_${ik}$ ) then + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bignum, bnrm, n, nrhs, b, ldb, info ) end if 70 continue - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_${ci}$gelss + end subroutine stdlib${ii}$_${ci}$gelss - subroutine stdlib_${ci}$gelsy( m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank,work, lwork, rwork, & + subroutine stdlib${ii}$_${ci}$gelsy( m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank,work, lwork, rwork, & !! ZGELSY: computes the minimum-norm solution to a complex linear least !! squares problem: !! minimize || A * X - B || @@ -8503,24 +8498,24 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, rank - integer(ilp), intent(in) :: lda, ldb, lwork, m, n, nrhs + integer(${ik}$), intent(out) :: info, rank + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, nrhs real(${ck}$), intent(in) :: rcond ! Array Arguments - integer(ilp), intent(inout) :: jpvt(*) + integer(${ik}$), intent(inout) :: jpvt(*) real(${ck}$), intent(out) :: rwork(*) complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: imax = 1 - integer(ilp), parameter :: imin = 2 + integer(${ik}$), parameter :: imax = 1_${ik}$ + integer(${ik}$), parameter :: imin = 2_${ik}$ ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, iascl, ibscl, ismax, ismin, j, lwkopt, mn, nb, nb1, nb2, nb3, & + integer(${ik}$) :: i, iascl, ibscl, ismax, ismin, j, lwkopt, mn, nb, nb1, nb2, nb3, & nb4 real(${ck}$) :: anrm, bignum, bnrm, smax, smaxpr, smin, sminpr, smlnum, wsize complex(${ck}$) :: c1, c2, s1, s2 @@ -8528,77 +8523,77 @@ module stdlib_linalg_lapack_${ci}$ intrinsic :: abs,real,cmplx,max,min ! Executable Statements mn = min( m, n ) - ismin = mn + 1 - ismax = 2*mn + 1 + ismin = mn + 1_${ik}$ + ismax = 2_${ik}$*mn + 1_${ik}$ ! test the input arguments. - info = 0 - nb1 = stdlib_ilaenv( 1, 'ZGEQRF', ' ', m, n, -1, -1 ) - nb2 = stdlib_ilaenv( 1, 'ZGERQF', ' ', m, n, -1, -1 ) - nb3 = stdlib_ilaenv( 1, 'ZUNMQR', ' ', m, n, nrhs, -1 ) - nb4 = stdlib_ilaenv( 1, 'ZUNMRQ', ' ', m, n, nrhs, -1 ) + info = 0_${ik}$ + nb1 = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) + nb2 = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGERQF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) + nb3 = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', ' ', m, n, nrhs, -1_${ik}$ ) + nb4 = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMRQ', ' ', m, n, nrhs, -1_${ik}$ ) nb = max( nb1, nb2, nb3, nb4 ) - lwkopt = max( 1, mn+2*n+nb*( n+1 ), 2*mn+nb*nrhs ) - work( 1 ) = cmplx( lwkopt,KIND=${ck}$) - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( ldazero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_${ci}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_${ci}$laset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) - rank = 0 + call stdlib${ii}$_${ci}$laset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) + rank = 0_${ik}$ go to 70 end if - bnrm = stdlib_${ci}$lange( 'M', m, nrhs, b, ldb, rwork ) - ibscl = 0 + bnrm = stdlib${ii}$_${ci}$lange( 'M', m, nrhs, b, ldb, rwork ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_${ci}$lascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) - ibscl = 2 + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, m, nrhs, b, ldb, info ) + ibscl = 2_${ik}$ end if ! compute qr factorization with column pivoting of a: ! a * p = q * r - call stdlib_${ci}$geqp3( m, n, a, lda, jpvt, work( 1 ), work( mn+1 ),lwork-mn, rwork, info ) + call stdlib${ii}$_${ci}$geqp3( m, n, a, lda, jpvt, work( 1_${ik}$ ), work( mn+1 ),lwork-mn, rwork, info ) wsize = mn + real( work( mn+1 ),KIND=${ck}$) ! complex workspace: mn+nb*(n+1). real workspace 2*n. @@ -8606,21 +8601,21 @@ module stdlib_linalg_lapack_${ci}$ ! determine rank using incremental condition estimation work( ismin ) = cone work( ismax ) = cone - smax = abs( a( 1, 1 ) ) + smax = abs( a( 1_${ik}$, 1_${ik}$ ) ) smin = smax - if( abs( a( 1, 1 ) )==zero ) then - rank = 0 - call stdlib_${ci}$laset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) + if( abs( a( 1_${ik}$, 1_${ik}$ ) )==zero ) then + rank = 0_${ik}$ + call stdlib${ii}$_${ci}$laset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) go to 70 else - rank = 1 + rank = 1_${ik}$ end if 10 continue if( rankk ) .and. ( mn>k ) ) then - if( mod( mn - k, nb - k ) == 0 ) then + if( mod( mn - k, nb - k ) == 0_${ik}$ ) then nblcks = ( mn - k ) / ( nb - k ) else - nblcks = ( mn - k ) / ( nb - k ) + 1 + nblcks = ( mn - k ) / ( nb - k ) + 1_${ik}$ end if else - nblcks = 1 + nblcks = 1_${ik}$ end if - info = 0 + info = 0_${ik}$ 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>mn ) then - info = -5 - else if( ldamn ) then + info = -5_${ik}$ + else if( lda=max( m, n, & k ) ) ) then - call stdlib_${ci}$gemlqt( side, trans, m, n, k, mb, a, lda,t( 6 ), mb, c, ldc, work, info & + call stdlib${ii}$_${ci}$gemlqt( side, trans, m, n, k, mb, a, lda,t( 6_${ik}$ ), mb, c, ldc, work, info & ) else - call stdlib_${ci}$lamswlq( side, trans, m, n, k, mb, nb, a, lda, t( 6 ),mb, c, ldc, work, & + call stdlib${ii}$_${ci}$lamswlq( side, trans, m, n, k, mb, nb, a, lda, t( 6_${ik}$ ),mb, c, ldc, work, & lwork, info ) end if - work( 1 ) = lw + work( 1_${ik}$ ) = lw return - end subroutine stdlib_${ci}$gemlq + end subroutine stdlib${ii}$_${ci}$gemlq - pure subroutine stdlib_${ci}$gemlqt( side, trans, m, n, k, mb, v, ldv, t, ldt,c, ldc, work, info ) + pure subroutine stdlib${ii}$_${ci}$gemlqt( side, trans, m, n, k, mb, v, ldv, t, ldt,c, ldc, work, info ) !! ZGEMLQT: overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q C C Q @@ -8803,8 +8798,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(in) :: v(ldv,*), t(ldt,*) complex(${ck}$), intent(inout) :: c(ldc,*) @@ -8812,44 +8807,44 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! 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, 'C' ) 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( ldvk ) .and. ( mn>k ) ) then - if( mod( mn - k, mb - k )==0 ) then + if( mod( mn - k, mb - k )==0_${ik}$ ) then nblcks = ( mn - k ) / ( mb - k ) else - nblcks = ( mn - k ) / ( mb - k ) + 1 + nblcks = ( mn - k ) / ( mb - k ) + 1_${ik}$ end if else - nblcks = 1 + nblcks = 1_${ik}$ end if - info = 0 + info = 0_${ik}$ 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>mn ) then - info = -5 - else if( ldamn ) then + info = -5_${ik}$ + else if( lda=max( m, n, & k ) ) ) then - call stdlib_${ci}$gemqrt( side, trans, m, n, k, nb, a, lda, t( 6 ),nb, c, ldc, work, info & + call stdlib${ii}$_${ci}$gemqrt( side, trans, m, n, k, nb, a, lda, t( 6_${ik}$ ),nb, c, ldc, work, info & ) else - call stdlib_${ci}$lamtsqr( side, trans, m, n, k, mb, nb, a, lda, t( 6 ),nb, c, ldc, work, & + call stdlib${ii}$_${ci}$lamtsqr( side, trans, m, n, k, mb, nb, a, lda, t( 6_${ik}$ ),nb, c, ldc, work, & lwork, info ) end if - work( 1 ) = lw + work( 1_${ik}$ ) = lw return - end subroutine stdlib_${ci}$gemqr + end subroutine stdlib${ii}$_${ci}$gemqr - pure subroutine stdlib_${ci}$gemqrt( side, trans, m, n, k, nb, v, ldv, t, ldt,c, ldc, work, info ) + pure subroutine stdlib${ii}$_${ci}$gemqrt( side, trans, m, n, k, nb, v, ldv, t, ldt,c, ldc, work, info ) !! ZGEMQRT: overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q C C Q @@ -8998,8 +8993,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, nb, ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k, ldv, ldc, m, n, nb, ldt ! Array Arguments complex(${ck}$), intent(in) :: v(ldv,*), t(ldt,*) complex(${ck}$), intent(inout) :: c(ldc,*) @@ -9007,44 +9002,44 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! 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, 'C' ) 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( 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( ldv1 .and. nb1_${ik}$ .and. nb1 ) 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_${ci}$larft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1, n-k+i ), & + call stdlib${ii}$_${ci}$larft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1_${ik}$, n-k+i ), & lda, tau( i ), work, ldwork ) ! apply h**h to a(1:m-k+i+ib-1,1:n-k+i-1) from the left - call stdlib_${ci}$larfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'BACKWARD','COLUMNWISE', m-& - k+i+ib-1, n-k+i-1, ib,a( 1, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), & + call stdlib${ii}$_${ci}$larfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'BACKWARD','COLUMNWISE', m-& + k+i+ib-1, n-k+i-1, ib,a( 1_${ik}$, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), & ldwork ) end if end do - mu = m - k + i + nb - 1 - nu = n - k + i + nb - 1 + mu = m - k + i + nb - 1_${ik}$ + nu = n - k + i + nb - 1_${ik}$ else mu = m nu = n end if ! use unblocked code to factor the last or only block - if( mu>0 .and. nu>0 )call stdlib_${ci}$geql2( mu, nu, a, lda, tau, work, iinfo ) - work( 1 ) = iws + if( mu>0_${ik}$ .and. nu>0_${ik}$ )call stdlib${ii}$_${ci}$geql2( mu, nu, a, lda, tau, work, iinfo ) + work( 1_${ik}$ ) = iws return - end subroutine stdlib_${ci}$geqlf + end subroutine stdlib${ii}$_${ci}$geqlf - pure subroutine stdlib_${ci}$geqp3( m, n, a, lda, jpvt, tau, work, lwork, rwork,info ) + pure subroutine stdlib${ii}$_${ci}$geqp3( m, n, a, lda, jpvt, tau, work, lwork, rwork,info ) !! ZGEQP3: computes a QR factorization with column pivoting of a !! matrix A: A*P = Q*R using Level 3 BLAS. ! -- lapack computational routine -- ! -- 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, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, lwork, m, n ! Array Arguments - integer(ilp), intent(inout) :: jpvt(*) + integer(${ik}$), intent(inout) :: jpvt(*) real(${ck}$), intent(out) :: rwork(*) complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: inb = 1 - integer(ilp), parameter :: inbmin = 2 - integer(ilp), parameter :: ixover = 3 + integer(${ik}$), parameter :: inb = 1_${ik}$ + integer(${ik}$), parameter :: inbmin = 2_${ik}$ + integer(${ik}$), parameter :: ixover = 3_${ik}$ ! Local Scalars logical(lk) :: lquery - integer(ilp) :: fjb, iws, j, jb, lwkopt, minmn, minws, na, nb, nbmin, nfxd, nx, sm, & + integer(${ik}$) :: fjb, iws, j, jb, lwkopt, minmn, minws, na, nb, nbmin, nfxd, nx, sm, & sminmn, sn, topbmn ! Intrinsic Functions intrinsic :: int,max,min ! Executable Statements ! test input arguments ! ==================== - info = 0 - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda0 ) then + if( nfxd>0_${ik}$ ) then na = min( m, nfxd ) - ! cc call stdlib_${ci}$geqr2( m, na, a, lda, tau, work, info ) - call stdlib_${ci}$geqrf( m, na, a, lda, tau, work, lwork, info ) - iws = max( iws, int( work( 1 ),KIND=ilp) ) + ! cc call stdlib${ii}$_${ci}$geqr2( m, na, a, lda, tau, work, info ) + call stdlib${ii}$_${ci}$geqrf( m, na, a, lda, tau, work, lwork, info ) + iws = max( iws, int( work( 1_${ik}$ ),KIND=${ik}$) ) if( na1 ) .and. ( nb1_${ik}$ ) .and. ( nb=nbmin ) .and. ( nb0 ) then - mb = stdlib_ilaenv( 1, 'ZGEQR ', ' ', m, n, 1, -1 ) - nb = stdlib_ilaenv( 1, 'ZGEQR ', ' ', m, n, 2, -1 ) + if( min ( m, n )>0_${ik}$ ) then + mb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQR ', ' ', m, n, 1_${ik}$, -1_${ik}$ ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQR ', ' ', m, n, 2_${ik}$, -1_${ik}$ ) else mb = m - nb = 1 + nb = 1_${ik}$ end if if( mb>m .or. mb<=n ) mb = m - if( nb>min( m, n ) .or. nb<1 ) nb = 1 - mintsz = n + 5 + if( nb>min( m, n ) .or. nb<1_${ik}$ ) nb = 1_${ik}$ + mintsz = n + 5_${ik}$ if( mb>n .and. m>n ) then - if( mod( m - n, mb - n )==0 ) then + if( mod( m - n, mb - n )==0_${ik}$ ) then nblcks = ( m - n ) / ( mb - n ) else - nblcks = ( m - n ) / ( mb - n ) + 1 + nblcks = ( m - n ) / ( mb - n ) + 1_${ik}$ end if else - nblcks = 1 + nblcks = 1_${ik}$ end if ! determine if the workspace size satisfies minimal size lminws = .false. - if( ( tsize=n ) .and. ( & + if( ( tsize=n ) .and. ( & tsize>=mintsz ).and. ( .not.lquery ) ) then - if( tsize=m ) ) then - call stdlib_${ci}$geqrt( m, n, nb, a, lda, t( 6 ), nb, work, info ) + call stdlib${ii}$_${ci}$geqrt( m, n, nb, a, lda, t( 6_${ik}$ ), nb, work, info ) else - call stdlib_${ci}$latsqr( m, n, mb, nb, a, lda, t( 6 ), nb, work,lwork, info ) + call stdlib${ii}$_${ci}$latsqr( m, n, mb, nb, a, lda, t( 6_${ik}$ ), nb, work,lwork, info ) end if - work( 1 ) = max( 1, nb*n ) + work( 1_${ik}$ ) = max( 1_${ik}$, nb*n ) return - end subroutine stdlib_${ci}$geqr + end subroutine stdlib${ii}$_${ci}$geqr - pure subroutine stdlib_${ci}$geqr2( m, n, a, lda, tau, work, info ) + pure subroutine stdlib${ii}$_${ci}$geqr2( m, n, a, lda, tau, work, info ) !! ZGEQR2: computes a QR factorization of a complex m-by-n matrix A: !! A = Q * ( R ), !! ( 0 ) @@ -9514,50 +9509,50 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, k + integer(${ik}$) :: i, k complex(${ck}$) :: alpha ! Intrinsic Functions intrinsic :: conjg,max,min ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda0 .and. lwork0_${ik}$ .and. lwork1 .and. nb1_${ik}$ .and. nb1 .and. nb1_${ik}$ .and. nbmin(m,n) .and. min(m,n)>0 ) )then - info = -3 - else if( ldamin(m,n) .and. min(m,n)>0_${ik}$ ) )then + info = -3_${ik}$ + else if( lda t(i,1) - call stdlib_${ci}$larfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,t( i, 1 ) ) + call stdlib${ii}$_${ci}$larfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,t( i, 1_${ik}$ ) ) if( ieps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_${ci}$getrs( trans, n, 1, af, ldaf, ipiv, work, n, info ) - call stdlib_${ci}$axpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_${ci}$getrs( trans, n, 1_${ik}$, af, ldaf, ipiv, work, n, info ) + call stdlib${ii}$_${ci}$axpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -10194,13 +10189,13 @@ module stdlib_linalg_lapack_${ci}$ rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(op(a)**h). - call stdlib_${ci}$getrs( transt, n, 1, af, ldaf, ipiv, work, n,info ) + call stdlib${ii}$_${ci}$getrs( transt, n, 1_${ik}$, af, ldaf, ipiv, work, n,info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do @@ -10209,7 +10204,7 @@ module stdlib_linalg_lapack_${ci}$ do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_${ci}$getrs( transn, n, 1, af, ldaf, ipiv, work, n,info ) + call stdlib${ii}$_${ci}$getrs( transn, n, 1_${ik}$, af, ldaf, ipiv, work, n,info ) end if go to 100 end if @@ -10221,119 +10216,119 @@ module stdlib_linalg_lapack_${ci}$ if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_${ci}$gerfs + end subroutine stdlib${ii}$_${ci}$gerfs - pure subroutine stdlib_${ci}$gerq2( m, n, a, lda, tau, work, info ) + pure subroutine stdlib${ii}$_${ci}$gerq2( m, n, a, lda, tau, work, info ) !! ZGERQ2: computes an RQ factorization of a complex m by n matrix A: !! A = R * Q. ! -- lapack computational routine -- ! -- 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 complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, k + integer(${ik}$) :: i, k complex(${ck}$) :: alpha ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda0 .and. lwork0_${ik}$ .and. lwork1 .and. nb1_${ik}$ .and. nb1 ) then + if( m-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_${ci}$larft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( m-k+i, 1 ), lda, & + call stdlib${ii}$_${ci}$larft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( m-k+i, 1_${ik}$ ), lda, & tau( i ), work, ldwork ) ! apply h to a(1:m-k+i-1,1:n-k+i+ib-1) from the right - call stdlib_${ci}$larfb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', m-k+i-1, n-& - k+i+ib-1, ib,a( m-k+i, 1 ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork ) + call stdlib${ii}$_${ci}$larfb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', m-k+i-1, n-& + k+i+ib-1, ib,a( m-k+i, 1_${ik}$ ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork ) end if end do - mu = m - k + i + nb - 1 - nu = n - k + i + nb - 1 + mu = m - k + i + nb - 1_${ik}$ + nu = n - k + i + nb - 1_${ik}$ else mu = m nu = n end if ! use unblocked code to factor the last or only block - if( mu>0 .and. nu>0 )call stdlib_${ci}$gerq2( mu, nu, a, lda, tau, work, iinfo ) - work( 1 ) = iws + if( mu>0_${ik}$ .and. nu>0_${ik}$ )call stdlib${ii}$_${ci}$gerq2( mu, nu, a, lda, tau, work, iinfo ) + work( 1_${ik}$ ) = iws return - end subroutine stdlib_${ci}$gerqf + end subroutine stdlib${ii}$_${ci}$gerqf - pure subroutine stdlib_${ci}$gesc2( n, a, lda, rhs, ipiv, jpiv, scale ) + pure subroutine stdlib${ii}$_${ci}$gesc2( n, a, lda, rhs, ipiv, jpiv, scale ) !! ZGESC2: solves a system of linear equations !! A * X = scale* RHS !! with a general N-by-N matrix A using the LU factorization with @@ -10390,28 +10385,28 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, n + integer(${ik}$), intent(in) :: lda, n real(${ck}$), intent(out) :: scale ! Array Arguments - integer(ilp), intent(in) :: ipiv(*), jpiv(*) + integer(${ik}$), intent(in) :: ipiv(*), jpiv(*) complex(${ck}$), intent(in) :: a(lda,*) complex(${ck}$), intent(inout) :: rhs(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(${ck}$) :: bignum, eps, smlnum complex(${ck}$) :: temp ! Intrinsic Functions intrinsic :: abs,real,cmplx ! Executable Statements ! set constant to control overflow - eps = stdlib_${c2ri(ci)}$lamch( 'P' ) - smlnum = stdlib_${c2ri(ci)}$lamch( 'S' ) / eps + eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'P' ) + smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' ) / eps bignum = one / smlnum - call stdlib_${c2ri(ci)}$labad( smlnum, bignum ) + call stdlib${ii}$_${c2ri(ci)}$labad( smlnum, bignum ) ! apply permutations ipiv to rhs - call stdlib_${ci}$laswp( 1, rhs, lda, 1, n-1, ipiv, 1 ) + call stdlib${ii}$_${ci}$laswp( 1_${ik}$, rhs, lda, 1_${ik}$, n-1, ipiv, 1_${ik}$ ) ! solve for l part do i = 1, n - 1 do j = i + 1, n @@ -10421,10 +10416,10 @@ module stdlib_linalg_lapack_${ci}$ ! solve for u part scale = one ! check for scaling - i = stdlib_i${ci}$amax( n, rhs, 1 ) + i = stdlib${ii}$_i${ci}$amax( n, rhs, 1_${ik}$ ) if( two*smlnum*abs( rhs( i ) )>abs( a( n, n ) ) ) then temp = cmplx( one / two, zero,KIND=${ck}$) / abs( rhs( i ) ) - call stdlib_${ci}$scal( n, temp, rhs( 1 ), 1 ) + call stdlib${ii}$_${ci}$scal( n, temp, rhs( 1_${ik}$ ), 1_${ik}$ ) scale = scale*real( temp,KIND=${ck}$) end if do i = n, 1, -1 @@ -10435,12 +10430,12 @@ module stdlib_linalg_lapack_${ci}$ end do end do ! apply permutations jpiv to the solution (rhs) - call stdlib_${ci}$laswp( 1, rhs, lda, 1, n-1, jpiv, -1 ) + call stdlib${ii}$_${ci}$laswp( 1_${ik}$, rhs, lda, 1_${ik}$, n-1, jpiv, -1_${ik}$ ) return - end subroutine stdlib_${ci}$gesc2 + end subroutine stdlib${ii}$_${ci}$gesc2 - subroutine stdlib_${ci}$gesdd( jobz, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, rwork, iwork, & + subroutine stdlib${ii}$_${ci}$gesdd( jobz, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, rwork, iwork, & !! ZGESDD: computes the singular value decomposition (SVD) of a complex !! M-by-N matrix A, optionally computing the left and/or right singular !! vectors, by using divide-and-conquer method. The SVD is written @@ -10464,10 +10459,10 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldu, ldvt, lwork, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldu, ldvt, lwork, m, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(${ck}$), intent(out) :: rwork(*), s(*) complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: u(ldu,*), vt(ldvt,*), work(*) @@ -10476,49 +10471,49 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: lquery, wntqa, wntqas, wntqn, wntqo, wntqs - integer(ilp) :: blk, chunk, i, ie, ierr, il, ir, iru, irvt, iscl, itau, itaup, itauq, & + integer(${ik}$) :: blk, chunk, i, ie, ierr, il, ir, iru, irvt, iscl, itau, itaup, itauq, & iu, ivt, ldwkvt, ldwrkl, ldwrkr, ldwrku, maxwrk, minmn, minwrk, mnthr1, mnthr2, nrwork,& nwork, wrkbl - integer(ilp) :: lwork_wgebrd_mn, lwork_wgebrd_mm, lwork_wgebrd_nn, lwork_wgelqf_mn, & + integer(${ik}$) :: lwork_wgebrd_mn, lwork_wgebrd_mm, lwork_wgebrd_nn, lwork_wgelqf_mn, & lwork_wgeqrf_mn, lwork_wungbr_p_mn, lwork_wungbr_p_nn, lwork_wungbr_q_mn, & lwork_wungbr_q_mm, lwork_wunglq_mn, lwork_wunglq_nn, lwork_wungqr_mm, lwork_wungqr_mn, & lwork_wunmbr_prc_mm, lwork_wunmbr_qln_mm, lwork_wunmbr_prc_mn, lwork_wunmbr_qln_mn, & lwork_wunmbr_prc_nn, lwork_wunmbr_qln_nn real(${ck}$) :: anrm, bignum, eps, smlnum ! Local Arrays - integer(ilp) :: idum(1) - real(${ck}$) :: dum(1) - complex(${ck}$) :: cdum(1) + integer(${ik}$) :: idum(1_${ik}$) + real(${ck}$) :: dum(1_${ik}$) + complex(${ck}$) :: cdum(1_${ik}$) ! Intrinsic Functions intrinsic :: int,max,min,sqrt ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ minmn = min( m, n ) - mnthr1 = int( minmn*17.0_${ck}$ / 9.0_${ck}$,KIND=ilp) - mnthr2 = int( minmn*5.0_${ck}$ / 3.0_${ck}$,KIND=ilp) + mnthr1 = int( minmn*17.0_${ck}$ / 9.0_${ck}$,KIND=${ik}$) + mnthr2 = int( minmn*5.0_${ck}$ / 3.0_${ck}$,KIND=${ik}$) wntqa = stdlib_lsame( jobz, 'A' ) wntqs = stdlib_lsame( jobz, 'S' ) wntqas = wntqa .or. wntqs wntqo = stdlib_lsame( jobz, 'O' ) wntqn = stdlib_lsame( jobz, 'N' ) - lquery = ( lwork==-1 ) - minwrk = 1 - maxwrk = 1 + lquery = ( lwork==-1_${ik}$ ) + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ if( .not.( wntqa .or. wntqs .or. wntqo .or. wntqn ) ) then - info = -1 - else if( m<0 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( lda=n .and. ldvt=n .and. minmn>0 ) then + ! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + if( m>=n .and. minmn>0_${ik}$ ) then ! there is no complex work space needed for bidiagonal svd - ! the realwork space needed for bidiagonal svd (stdlib_${c2ri(ci)}$bdsdc,KIND=${ck}$) is + ! the realwork space needed for bidiagonal svd (stdlib${ii}$_${c2ri(ci)}$bdsdc,KIND=${ck}$) is ! bdspac = 3*n*n + 4*n for singular values and vectors; ! bdspac = 4*n for singular values only; ! not including e, ru, and rvt matrices. ! compute space preferred for each routine - call stdlib_${ci}$gebrd( m, n, cdum(1), m, dum(1), dum(1), cdum(1),cdum(1), cdum(1), -& - 1, ierr ) - lwork_wgebrd_mn = int( cdum(1),KIND=ilp) - call stdlib_${ci}$gebrd( n, n, cdum(1), n, dum(1), dum(1), cdum(1),cdum(1), cdum(1), -& - 1, ierr ) - lwork_wgebrd_nn = int( cdum(1),KIND=ilp) - call stdlib_${ci}$geqrf( m, n, cdum(1), m, cdum(1), cdum(1), -1, ierr ) - lwork_wgeqrf_mn = int( cdum(1),KIND=ilp) - call stdlib_${ci}$ungbr( 'P', n, n, n, cdum(1), n, cdum(1), cdum(1),-1, ierr ) - lwork_wungbr_p_nn = int( cdum(1),KIND=ilp) - call stdlib_${ci}$ungbr( 'Q', m, m, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) - lwork_wungbr_q_mm = int( cdum(1),KIND=ilp) - call stdlib_${ci}$ungbr( 'Q', m, n, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) - lwork_wungbr_q_mn = int( cdum(1),KIND=ilp) - call stdlib_${ci}$ungqr( m, m, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) - lwork_wungqr_mm = int( cdum(1),KIND=ilp) - call stdlib_${ci}$ungqr( m, n, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) - lwork_wungqr_mn = int( cdum(1),KIND=ilp) - call stdlib_${ci}$unmbr( 'P', 'R', 'C', n, n, n, cdum(1), n, cdum(1),cdum(1), n, cdum(& - 1), -1, ierr ) - lwork_wunmbr_prc_nn = int( cdum(1),KIND=ilp) - call stdlib_${ci}$unmbr( 'Q', 'L', 'N', m, m, n, cdum(1), m, cdum(1),cdum(1), m, cdum(& - 1), -1, ierr ) - lwork_wunmbr_qln_mm = int( cdum(1),KIND=ilp) - call stdlib_${ci}$unmbr( 'Q', 'L', 'N', m, n, n, cdum(1), m, cdum(1),cdum(1), m, cdum(& - 1), -1, ierr ) - lwork_wunmbr_qln_mn = int( cdum(1),KIND=ilp) - call stdlib_${ci}$unmbr( 'Q', 'L', 'N', n, n, n, cdum(1), n, cdum(1),cdum(1), n, cdum(& - 1), -1, ierr ) - lwork_wunmbr_qln_nn = int( cdum(1),KIND=ilp) + call stdlib${ii}$_${ci}$gebrd( m, n, cdum(1_${ik}$), m, dum(1_${ik}$), dum(1_${ik}$), cdum(1_${ik}$),cdum(1_${ik}$), cdum(1_${ik}$), -& + 1_${ik}$, ierr ) + lwork_wgebrd_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$gebrd( n, n, cdum(1_${ik}$), n, dum(1_${ik}$), dum(1_${ik}$), cdum(1_${ik}$),cdum(1_${ik}$), cdum(1_${ik}$), -& + 1_${ik}$, ierr ) + lwork_wgebrd_nn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$geqrf( m, n, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_wgeqrf_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$ungbr( 'P', n, n, n, cdum(1_${ik}$), n, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_wungbr_p_nn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$ungbr( 'Q', m, m, n, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_wungbr_q_mm = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$ungbr( 'Q', m, n, n, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_wungbr_q_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$ungqr( m, m, n, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_wungqr_mm = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$ungqr( m, n, n, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_wungqr_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$unmbr( 'P', 'R', 'C', n, n, n, cdum(1_${ik}$), n, cdum(1_${ik}$),cdum(1_${ik}$), n, cdum(& + 1_${ik}$), -1_${ik}$, ierr ) + lwork_wunmbr_prc_nn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'N', m, m, n, cdum(1_${ik}$), m, cdum(1_${ik}$),cdum(1_${ik}$), m, cdum(& + 1_${ik}$), -1_${ik}$, ierr ) + lwork_wunmbr_qln_mm = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'N', m, n, n, cdum(1_${ik}$), m, cdum(1_${ik}$),cdum(1_${ik}$), m, cdum(& + 1_${ik}$), -1_${ik}$, ierr ) + lwork_wunmbr_qln_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'N', n, n, n, cdum(1_${ik}$), n, cdum(1_${ik}$),cdum(1_${ik}$), n, cdum(& + 1_${ik}$), -1_${ik}$, ierr ) + lwork_wunmbr_qln_nn = int( cdum(1_${ik}$),KIND=${ik}$) if( m>=mnthr1 ) then if( wntqn ) then ! path 1 (m >> n, jobz='n') maxwrk = n + lwork_wgeqrf_mn - maxwrk = max( maxwrk, 2*n + lwork_wgebrd_nn ) - minwrk = 3*n + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_wgebrd_nn ) + minwrk = 3_${ik}$*n else if( wntqo ) then ! path 2 (m >> n, jobz='o') wrkbl = n + lwork_wgeqrf_mn wrkbl = max( wrkbl, n + lwork_wungqr_mn ) - wrkbl = max( wrkbl, 2*n + lwork_wgebrd_nn ) - wrkbl = max( wrkbl, 2*n + lwork_wunmbr_qln_nn ) - wrkbl = max( wrkbl, 2*n + lwork_wunmbr_prc_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_wgebrd_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_wunmbr_qln_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_wunmbr_prc_nn ) maxwrk = m*n + n*n + wrkbl - minwrk = 2*n*n + 3*n + minwrk = 2_${ik}$*n*n + 3_${ik}$*n else if( wntqs ) then ! path 3 (m >> n, jobz='s') wrkbl = n + lwork_wgeqrf_mn wrkbl = max( wrkbl, n + lwork_wungqr_mn ) - wrkbl = max( wrkbl, 2*n + lwork_wgebrd_nn ) - wrkbl = max( wrkbl, 2*n + lwork_wunmbr_qln_nn ) - wrkbl = max( wrkbl, 2*n + lwork_wunmbr_prc_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_wgebrd_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_wunmbr_qln_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_wunmbr_prc_nn ) maxwrk = n*n + wrkbl - minwrk = n*n + 3*n + minwrk = n*n + 3_${ik}$*n else if( wntqa ) then ! path 4 (m >> n, jobz='a') wrkbl = n + lwork_wgeqrf_mn wrkbl = max( wrkbl, n + lwork_wungqr_mm ) - wrkbl = max( wrkbl, 2*n + lwork_wgebrd_nn ) - wrkbl = max( wrkbl, 2*n + lwork_wunmbr_qln_nn ) - wrkbl = max( wrkbl, 2*n + lwork_wunmbr_prc_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_wgebrd_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_wunmbr_qln_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_wunmbr_prc_nn ) maxwrk = n*n + wrkbl - minwrk = n*n + max( 3*n, n + m ) + minwrk = n*n + max( 3_${ik}$*n, n + m ) end if else if( m>=mnthr2 ) then ! path 5 (m >> n, but not as much as mnthr1) - maxwrk = 2*n + lwork_wgebrd_mn - minwrk = 2*n + m + maxwrk = 2_${ik}$*n + lwork_wgebrd_mn + minwrk = 2_${ik}$*n + m if( wntqo ) then ! path 5o (m >> n, jobz='o') - maxwrk = max( maxwrk, 2*n + lwork_wungbr_p_nn ) - maxwrk = max( maxwrk, 2*n + lwork_wungbr_q_mn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_wungbr_p_nn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_wungbr_q_mn ) maxwrk = maxwrk + m*n minwrk = minwrk + n*n else if( wntqs ) then ! path 5s (m >> n, jobz='s') - maxwrk = max( maxwrk, 2*n + lwork_wungbr_p_nn ) - maxwrk = max( maxwrk, 2*n + lwork_wungbr_q_mn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_wungbr_p_nn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_wungbr_q_mn ) else if( wntqa ) then ! path 5a (m >> n, jobz='a') - maxwrk = max( maxwrk, 2*n + lwork_wungbr_p_nn ) - maxwrk = max( maxwrk, 2*n + lwork_wungbr_q_mm ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_wungbr_p_nn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_wungbr_q_mm ) end if else ! path 6 (m >= n, but not much larger) - maxwrk = 2*n + lwork_wgebrd_mn - minwrk = 2*n + m + maxwrk = 2_${ik}$*n + lwork_wgebrd_mn + minwrk = 2_${ik}$*n + m if( wntqo ) then ! path 6o (m >= n, jobz='o') - maxwrk = max( maxwrk, 2*n + lwork_wunmbr_prc_nn ) - maxwrk = max( maxwrk, 2*n + lwork_wunmbr_qln_mn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_wunmbr_prc_nn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_wunmbr_qln_mn ) maxwrk = maxwrk + m*n minwrk = minwrk + n*n else if( wntqs ) then ! path 6s (m >= n, jobz='s') - maxwrk = max( maxwrk, 2*n + lwork_wunmbr_qln_mn ) - maxwrk = max( maxwrk, 2*n + lwork_wunmbr_prc_nn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_wunmbr_qln_mn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_wunmbr_prc_nn ) else if( wntqa ) then ! path 6a (m >= n, jobz='a') - maxwrk = max( maxwrk, 2*n + lwork_wunmbr_qln_mm ) - maxwrk = max( maxwrk, 2*n + lwork_wunmbr_prc_nn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_wunmbr_qln_mm ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_wunmbr_prc_nn ) end if end if - else if( minmn>0 ) then + else if( minmn>0_${ik}$ ) then ! there is no complex work space needed for bidiagonal svd - ! the realwork space needed for bidiagonal svd (stdlib_${c2ri(ci)}$bdsdc,KIND=${ck}$) is + ! the realwork space needed for bidiagonal svd (stdlib${ii}$_${c2ri(ci)}$bdsdc,KIND=${ck}$) is ! bdspac = 3*m*m + 4*m for singular values and vectors; ! bdspac = 4*m for singular values only; ! not including e, ru, and rvt matrices. ! compute space preferred for each routine - call stdlib_${ci}$gebrd( m, n, cdum(1), m, dum(1), dum(1), cdum(1),cdum(1), cdum(1), -& - 1, ierr ) - lwork_wgebrd_mn = int( cdum(1),KIND=ilp) - call stdlib_${ci}$gebrd( m, m, cdum(1), m, dum(1), dum(1), cdum(1),cdum(1), cdum(1), -& - 1, ierr ) - lwork_wgebrd_mm = int( cdum(1),KIND=ilp) - call stdlib_${ci}$gelqf( m, n, cdum(1), m, cdum(1), cdum(1), -1, ierr ) - lwork_wgelqf_mn = int( cdum(1),KIND=ilp) - call stdlib_${ci}$ungbr( 'P', m, n, m, cdum(1), m, cdum(1), cdum(1),-1, ierr ) - lwork_wungbr_p_mn = int( cdum(1),KIND=ilp) - call stdlib_${ci}$ungbr( 'P', n, n, m, cdum(1), n, cdum(1), cdum(1),-1, ierr ) - lwork_wungbr_p_nn = int( cdum(1),KIND=ilp) - call stdlib_${ci}$ungbr( 'Q', m, m, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) - lwork_wungbr_q_mm = int( cdum(1),KIND=ilp) - call stdlib_${ci}$unglq( m, n, m, cdum(1), m, cdum(1), cdum(1),-1, ierr ) - lwork_wunglq_mn = int( cdum(1),KIND=ilp) - call stdlib_${ci}$unglq( n, n, m, cdum(1), n, cdum(1), cdum(1),-1, ierr ) - lwork_wunglq_nn = int( cdum(1),KIND=ilp) - call stdlib_${ci}$unmbr( 'P', 'R', 'C', m, m, m, cdum(1), m, cdum(1),cdum(1), m, cdum(& - 1), -1, ierr ) - lwork_wunmbr_prc_mm = int( cdum(1),KIND=ilp) - call stdlib_${ci}$unmbr( 'P', 'R', 'C', m, n, m, cdum(1), m, cdum(1),cdum(1), m, cdum(& - 1), -1, ierr ) - lwork_wunmbr_prc_mn = int( cdum(1),KIND=ilp) - call stdlib_${ci}$unmbr( 'P', 'R', 'C', n, n, m, cdum(1), n, cdum(1),cdum(1), n, cdum(& - 1), -1, ierr ) - lwork_wunmbr_prc_nn = int( cdum(1),KIND=ilp) - call stdlib_${ci}$unmbr( 'Q', 'L', 'N', m, m, m, cdum(1), m, cdum(1),cdum(1), m, cdum(& - 1), -1, ierr ) - lwork_wunmbr_qln_mm = int( cdum(1),KIND=ilp) + call stdlib${ii}$_${ci}$gebrd( m, n, cdum(1_${ik}$), m, dum(1_${ik}$), dum(1_${ik}$), cdum(1_${ik}$),cdum(1_${ik}$), cdum(1_${ik}$), -& + 1_${ik}$, ierr ) + lwork_wgebrd_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$gebrd( m, m, cdum(1_${ik}$), m, dum(1_${ik}$), dum(1_${ik}$), cdum(1_${ik}$),cdum(1_${ik}$), cdum(1_${ik}$), -& + 1_${ik}$, ierr ) + lwork_wgebrd_mm = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$gelqf( m, n, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_wgelqf_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$ungbr( 'P', m, n, m, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_wungbr_p_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$ungbr( 'P', n, n, m, cdum(1_${ik}$), n, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_wungbr_p_nn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$ungbr( 'Q', m, m, n, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_wungbr_q_mm = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$unglq( m, n, m, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_wunglq_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$unglq( n, n, m, cdum(1_${ik}$), n, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_wunglq_nn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$unmbr( 'P', 'R', 'C', m, m, m, cdum(1_${ik}$), m, cdum(1_${ik}$),cdum(1_${ik}$), m, cdum(& + 1_${ik}$), -1_${ik}$, ierr ) + lwork_wunmbr_prc_mm = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$unmbr( 'P', 'R', 'C', m, n, m, cdum(1_${ik}$), m, cdum(1_${ik}$),cdum(1_${ik}$), m, cdum(& + 1_${ik}$), -1_${ik}$, ierr ) + lwork_wunmbr_prc_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$unmbr( 'P', 'R', 'C', n, n, m, cdum(1_${ik}$), n, cdum(1_${ik}$),cdum(1_${ik}$), n, cdum(& + 1_${ik}$), -1_${ik}$, ierr ) + lwork_wunmbr_prc_nn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'N', m, m, m, cdum(1_${ik}$), m, cdum(1_${ik}$),cdum(1_${ik}$), m, cdum(& + 1_${ik}$), -1_${ik}$, ierr ) + lwork_wunmbr_qln_mm = int( cdum(1_${ik}$),KIND=${ik}$) if( n>=mnthr1 ) then if( wntqn ) then ! path 1t (n >> m, jobz='n') maxwrk = m + lwork_wgelqf_mn - maxwrk = max( maxwrk, 2*m + lwork_wgebrd_mm ) - minwrk = 3*m + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_wgebrd_mm ) + minwrk = 3_${ik}$*m else if( wntqo ) then ! path 2t (n >> m, jobz='o') wrkbl = m + lwork_wgelqf_mn wrkbl = max( wrkbl, m + lwork_wunglq_mn ) - wrkbl = max( wrkbl, 2*m + lwork_wgebrd_mm ) - wrkbl = max( wrkbl, 2*m + lwork_wunmbr_qln_mm ) - wrkbl = max( wrkbl, 2*m + lwork_wunmbr_prc_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_wgebrd_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_wunmbr_qln_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_wunmbr_prc_mm ) maxwrk = m*n + m*m + wrkbl - minwrk = 2*m*m + 3*m + minwrk = 2_${ik}$*m*m + 3_${ik}$*m else if( wntqs ) then ! path 3t (n >> m, jobz='s') wrkbl = m + lwork_wgelqf_mn wrkbl = max( wrkbl, m + lwork_wunglq_mn ) - wrkbl = max( wrkbl, 2*m + lwork_wgebrd_mm ) - wrkbl = max( wrkbl, 2*m + lwork_wunmbr_qln_mm ) - wrkbl = max( wrkbl, 2*m + lwork_wunmbr_prc_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_wgebrd_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_wunmbr_qln_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_wunmbr_prc_mm ) maxwrk = m*m + wrkbl - minwrk = m*m + 3*m + minwrk = m*m + 3_${ik}$*m else if( wntqa ) then ! path 4t (n >> m, jobz='a') wrkbl = m + lwork_wgelqf_mn wrkbl = max( wrkbl, m + lwork_wunglq_nn ) - wrkbl = max( wrkbl, 2*m + lwork_wgebrd_mm ) - wrkbl = max( wrkbl, 2*m + lwork_wunmbr_qln_mm ) - wrkbl = max( wrkbl, 2*m + lwork_wunmbr_prc_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_wgebrd_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_wunmbr_qln_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_wunmbr_prc_mm ) maxwrk = m*m + wrkbl - minwrk = m*m + max( 3*m, m + n ) + minwrk = m*m + max( 3_${ik}$*m, m + n ) end if else if( n>=mnthr2 ) then ! path 5t (n >> m, but not as much as mnthr1) - maxwrk = 2*m + lwork_wgebrd_mn - minwrk = 2*m + n + maxwrk = 2_${ik}$*m + lwork_wgebrd_mn + minwrk = 2_${ik}$*m + n if( wntqo ) then ! path 5to (n >> m, jobz='o') - maxwrk = max( maxwrk, 2*m + lwork_wungbr_q_mm ) - maxwrk = max( maxwrk, 2*m + lwork_wungbr_p_mn ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_wungbr_q_mm ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_wungbr_p_mn ) maxwrk = maxwrk + m*n minwrk = minwrk + m*m else if( wntqs ) then ! path 5ts (n >> m, jobz='s') - maxwrk = max( maxwrk, 2*m + lwork_wungbr_q_mm ) - maxwrk = max( maxwrk, 2*m + lwork_wungbr_p_mn ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_wungbr_q_mm ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_wungbr_p_mn ) else if( wntqa ) then ! path 5ta (n >> m, jobz='a') - maxwrk = max( maxwrk, 2*m + lwork_wungbr_q_mm ) - maxwrk = max( maxwrk, 2*m + lwork_wungbr_p_nn ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_wungbr_q_mm ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_wungbr_p_nn ) end if else ! path 6t (n > m, but not much larger) - maxwrk = 2*m + lwork_wgebrd_mn - minwrk = 2*m + n + maxwrk = 2_${ik}$*m + lwork_wgebrd_mn + minwrk = 2_${ik}$*m + n if( wntqo ) then ! path 6to (n > m, jobz='o') - maxwrk = max( maxwrk, 2*m + lwork_wunmbr_qln_mm ) - maxwrk = max( maxwrk, 2*m + lwork_wunmbr_prc_mn ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_wunmbr_qln_mm ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_wunmbr_prc_mn ) maxwrk = maxwrk + m*n minwrk = minwrk + m*m else if( wntqs ) then ! path 6ts (n > m, jobz='s') - maxwrk = max( maxwrk, 2*m + lwork_wunmbr_qln_mm ) - maxwrk = max( maxwrk, 2*m + lwork_wunmbr_prc_mn ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_wunmbr_qln_mm ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_wunmbr_prc_mn ) else if( wntqa ) then ! path 6ta (n > m, jobz='a') - maxwrk = max( maxwrk, 2*m + lwork_wunmbr_qln_mm ) - maxwrk = max( maxwrk, 2*m + lwork_wunmbr_prc_nn ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_wunmbr_qln_mm ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_wunmbr_prc_nn ) end if end if end if maxwrk = max( maxwrk, minwrk ) end if - if( info==0 ) then - work( 1 ) = stdlib_${c2ri(ci)}$roundup_lwork( maxwrk ) + if( info==0_${ik}$ ) then + work( 1_${ik}$ ) = stdlib${ii}$_${c2ri(ci)}$roundup_lwork( maxwrk ) if( lworkzero .and. anrmbignum ) then - iscl = 1 - call stdlib_${ci}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, ierr ) + iscl = 1_${ik}$ + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, ierr ) end if if( m>=n ) then ! a has at least as many rows as columns. if a has sufficiently @@ -10795,45 +10790,45 @@ module stdlib_linalg_lapack_${ci}$ if( wntqn ) then ! path 1 (m >> n, jobz='n') ! no singular vectors to be computed - itau = 1 + itau = 1_${ik}$ nwork = itau + n ! compute a=q*r ! cworkspace: need n [tau] + n [work] ! cworkspace: prefer n [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) ! zero out below r - if (n>1) call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) - ie = 1 - itauq = 1 + if (n>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'L', n-1, n-1, czero, czero, a( 2_${ik}$, 1_${ik}$ ),lda ) + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + n nwork = itaup + n ! bidiagonalize r in a ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + 2*n*nb [work] ! rworkspace: need n [e] - call stdlib_${ci}$gebrd( n, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& + call stdlib${ii}$_${ci}$gebrd( n, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& work( nwork ), lwork-nwork+1,ierr ) nrwork = ie + n ! perform bidiagonal svd, compute singular values only ! cworkspace: need 0 ! rworkspace: need n [e] + bdspac - call stdlib_${c2ri(ci)}$bdsdc( 'U', 'N', n, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& + call stdlib${ii}$_${c2ri(ci)}$bdsdc( 'U', 'N', n, s, rwork( ie ), dum,1_${ik}$,dum,1_${ik}$,dum, idum, rwork(& nrwork ), iwork, info ) else if( wntqo ) then ! path 2 (m >> n, jobz='o') ! n left singular vectors to be overwritten on a and ! n right singular vectors to be computed in vt - iu = 1 + iu = 1_${ik}$ ! work(iu) is n by n ldwrku = n ir = iu + ldwrku*n - if( lwork >= m*n + n*n + 3*n ) then + if( lwork >= m*n + n*n + 3_${ik}$*n ) then ! work(ir) is m by n ldwrkr = m else - ldwrkr = ( lwork - n*n - 3*n ) / n + ldwrkr = ( lwork - n*n - 3_${ik}$*n ) / n end if itau = ir + ldwrkr*n nwork = itau + n @@ -10841,18 +10836,18 @@ module stdlib_linalg_lapack_${ci}$ ! cworkspace: need n*n [u] + n*n [r] + n [tau] + n [work] ! cworkspace: prefer n*n [u] + n*n [r] + n [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) ! copy r to work( ir ), zeroing out below it - call stdlib_${ci}$lacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) - call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero, work( ir+1 ),ldwrkr ) + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) + call stdlib${ii}$_${ci}$laset( 'L', n-1, n-1, czero, czero, work( ir+1 ),ldwrkr ) ! generate q in a ! cworkspace: need n*n [u] + n*n [r] + n [tau] + n [work] ! cworkspace: prefer n*n [u] + n*n [r] + n [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$ungqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork-nwork+& - 1, ierr ) - ie = 1 + call stdlib${ii}$_${ci}$ungqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork-nwork+& + 1_${ik}$, ierr ) + ie = 1_${ik}$ itauq = itau itaup = itauq + n nwork = itaup + n @@ -10860,7 +10855,7 @@ module stdlib_linalg_lapack_${ci}$ ! cworkspace: need n*n [u] + n*n [r] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [u] + n*n [r] + 2*n [tauq, taup] + 2*n*nb [work] ! rworkspace: need n [e] - call stdlib_${ci}$gebrd( n, n, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ), & + call stdlib${ii}$_${ci}$gebrd( n, n, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ), & work( itaup ), work( nwork ),lwork-nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of r in work(iru) and computing right singular vectors @@ -10870,23 +10865,23 @@ module stdlib_linalg_lapack_${ci}$ iru = ie + n irvt = iru + n*n nrwork = irvt + n*n - call stdlib_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=${ck}$) to complex matrix work(iu) ! overwrite work(iu) by the left singular vectors of r ! cworkspace: need n*n [u] + n*n [r] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [u] + n*n [r] + 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$lacp2( 'F', n, n, rwork( iru ), n, work( iu ),ldwrku ) - call stdlib_${ci}$unmbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_${ci}$lacp2( 'F', n, n, rwork( iru ), n, work( iu ),ldwrku ) + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & work( iu ), ldwrku,work( nwork ), lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=${ck}$) to complex matrix vt ! overwrite vt by the right singular vectors of r ! cworkspace: need n*n [u] + n*n [r] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [u] + n*n [r] + 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$lacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) - call stdlib_${ci}$unmbr( 'P', 'R', 'C', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_${ci}$lacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) + call stdlib${ii}$_${ci}$unmbr( 'P', 'R', 'C', n, n, n, work( ir ), ldwrkr,work( itaup ), & vt, ldvt, work( nwork ),lwork-nwork+1, ierr ) ! multiply q in a by left singular vectors of r in ! work(iu), storing result in work(ir) and copying to a @@ -10895,16 +10890,16 @@ module stdlib_linalg_lapack_${ci}$ ! rworkspace: need 0 do i = 1, m, ldwrkr chunk = min( m-i+1, ldwrkr ) - call stdlib_${ci}$gemm( 'N', 'N', chunk, n, n, cone, a( i, 1 ),lda, work( iu ), & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', chunk, n, n, cone, a( i, 1_${ik}$ ),lda, work( iu ), & ldwrku, czero,work( ir ), ldwrkr ) - call stdlib_${ci}$lacpy( 'F', chunk, n, work( ir ), ldwrkr,a( i, 1 ), lda ) + call stdlib${ii}$_${ci}$lacpy( 'F', chunk, n, work( ir ), ldwrkr,a( i, 1_${ik}$ ), lda ) end do else if( wntqs ) then ! path 3 (m >> n, jobz='s') ! n left singular vectors to be computed in u and ! n right singular vectors to be computed in vt - ir = 1 + ir = 1_${ik}$ ! work(ir) is n by n ldwrkr = n itau = ir + ldwrkr*n @@ -10913,18 +10908,18 @@ module stdlib_linalg_lapack_${ci}$ ! cworkspace: need n*n [r] + n [tau] + n [work] ! cworkspace: prefer n*n [r] + n [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) ! copy r to work(ir), zeroing out below it - call stdlib_${ci}$lacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) - call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero, work( ir+1 ),ldwrkr ) + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) + call stdlib${ii}$_${ci}$laset( 'L', n-1, n-1, czero, czero, work( ir+1 ),ldwrkr ) ! generate q in a ! cworkspace: need n*n [r] + n [tau] + n [work] ! cworkspace: prefer n*n [r] + n [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$ungqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork-nwork+& - 1, ierr ) - ie = 1 + call stdlib${ii}$_${ci}$ungqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork-nwork+& + 1_${ik}$, ierr ) + ie = 1_${ik}$ itauq = itau itaup = itauq + n nwork = itaup + n @@ -10932,7 +10927,7 @@ module stdlib_linalg_lapack_${ci}$ ! cworkspace: need n*n [r] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [r] + 2*n [tauq, taup] + 2*n*nb [work] ! rworkspace: need n [e] - call stdlib_${ci}$gebrd( n, n, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ), & + call stdlib${ii}$_${ci}$gebrd( n, n, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ), & work( itaup ), work( nwork ),lwork-nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -10942,36 +10937,36 @@ module stdlib_linalg_lapack_${ci}$ iru = ie + n irvt = iru + n*n nrwork = irvt + n*n - call stdlib_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=${ck}$) to complex matrix u ! overwrite u by left singular vectors of r ! cworkspace: need n*n [r] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [r] + 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$lacp2( 'F', n, n, rwork( iru ), n, u, ldu ) - call stdlib_${ci}$unmbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_${ci}$lacp2( 'F', n, n, rwork( iru ), n, u, ldu ) + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & u, ldu, work( nwork ),lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=${ck}$) to complex matrix vt ! overwrite vt by right singular vectors of r ! cworkspace: need n*n [r] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [r] + 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$lacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) - call stdlib_${ci}$unmbr( 'P', 'R', 'C', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_${ci}$lacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) + call stdlib${ii}$_${ci}$unmbr( 'P', 'R', 'C', n, n, n, work( ir ), ldwrkr,work( itaup ), & vt, ldvt, work( nwork ),lwork-nwork+1, ierr ) ! multiply q in a by left singular vectors of r in ! work(ir), storing result in u ! cworkspace: need n*n [r] ! rworkspace: need 0 - call stdlib_${ci}$lacpy( 'F', n, n, u, ldu, work( ir ), ldwrkr ) - call stdlib_${ci}$gemm( 'N', 'N', m, n, n, cone, a, lda, work( ir ),ldwrkr, czero, & + call stdlib${ii}$_${ci}$lacpy( 'F', n, n, u, ldu, work( ir ), ldwrkr ) + call stdlib${ii}$_${ci}$gemm( 'N', 'N', m, n, n, cone, a, lda, work( ir ),ldwrkr, czero, & u, ldu ) else if( wntqa ) then ! path 4 (m >> n, jobz='a') ! m left singular vectors to be computed in u and ! n right singular vectors to be computed in vt - iu = 1 + iu = 1_${ik}$ ! work(iu) is n by n ldwrku = n itau = iu + ldwrku*n @@ -10980,18 +10975,18 @@ module stdlib_linalg_lapack_${ci}$ ! cworkspace: need n*n [u] + n [tau] + n [work] ! cworkspace: prefer n*n [u] + n [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) - call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! cworkspace: need n*n [u] + n [tau] + m [work] ! cworkspace: prefer n*n [u] + n [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$ungqr( m, m, n, u, ldu, work( itau ),work( nwork ), lwork-nwork+& - 1, ierr ) + call stdlib${ii}$_${ci}$ungqr( m, m, n, u, ldu, work( itau ),work( nwork ), lwork-nwork+& + 1_${ik}$, ierr ) ! produce r in a, zeroing out below it - if (n>1) call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) - ie = 1 + if (n>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'L', n-1, n-1, czero, czero, a( 2_${ik}$, 1_${ik}$ ),lda ) + ie = 1_${ik}$ itauq = itau itaup = itauq + n nwork = itaup + n @@ -10999,7 +10994,7 @@ module stdlib_linalg_lapack_${ci}$ ! cworkspace: need n*n [u] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [u] + 2*n [tauq, taup] + 2*n*nb [work] ! rworkspace: need n [e] - call stdlib_${ci}$gebrd( n, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& + call stdlib${ii}$_${ci}$gebrd( n, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& work( nwork ), lwork-nwork+1,ierr ) iru = ie + n irvt = iru + n*n @@ -11009,55 +11004,55 @@ module stdlib_linalg_lapack_${ci}$ ! singular vectors of bidiagonal matrix in rwork(irvt) ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] + bdspac - call stdlib_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=${ck}$) to complex matrix work(iu) ! overwrite work(iu) by left singular vectors of r ! cworkspace: need n*n [u] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [u] + 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$lacp2( 'F', n, n, rwork( iru ), n, work( iu ),ldwrku ) - call stdlib_${ci}$unmbr( 'Q', 'L', 'N', n, n, n, a, lda,work( itauq ), work( iu ), & + call stdlib${ii}$_${ci}$lacp2( 'F', n, n, rwork( iru ), n, work( iu ),ldwrku ) + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'N', n, n, n, a, lda,work( itauq ), work( iu ), & ldwrku,work( nwork ), lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=${ck}$) to complex matrix vt ! overwrite vt by right singular vectors of r ! cworkspace: need n*n [u] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [u] + 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$lacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) - call stdlib_${ci}$unmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & + call stdlib${ii}$_${ci}$lacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) + call stdlib${ii}$_${ci}$unmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork-nwork+1, ierr ) ! multiply q in u by left singular vectors of r in ! work(iu), storing result in a ! cworkspace: need n*n [u] ! rworkspace: need 0 - call stdlib_${ci}$gemm( 'N', 'N', m, n, n, cone, u, ldu, work( iu ),ldwrku, czero, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', m, n, n, cone, u, ldu, work( iu ),ldwrku, czero, & a, lda ) ! copy left singular vectors of a from a to u - call stdlib_${ci}$lacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, n, a, lda, u, ldu ) end if else if( m>=mnthr2 ) then ! mnthr2 <= m < mnthr1 ! path 5 (m >> n, but not as much as mnthr1) ! reduce to bidiagonal form without qr decomposition, use - ! stdlib_${ci}$ungbr and matrix multiplication to compute singular vectors - ie = 1 + ! stdlib${ii}$_${ci}$ungbr and matrix multiplication to compute singular vectors + ie = 1_${ik}$ nrwork = ie + n - itauq = 1 + itauq = 1_${ik}$ itaup = itauq + n nwork = itaup + n ! bidiagonalize a ! cworkspace: need 2*n [tauq, taup] + m [work] ! cworkspace: prefer 2*n [tauq, taup] + (m+n)*nb [work] ! rworkspace: need n [e] - call stdlib_${ci}$gebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_${ci}$gebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) if( wntqn ) then ! path 5n (m >> n, jobz='n') ! compute singular values only ! cworkspace: need 0 ! rworkspace: need n [e] + bdspac - call stdlib_${c2ri(ci)}$bdsdc( 'U', 'N', n, s, rwork( ie ), dum, 1,dum,1,dum, idum, & + call stdlib${ii}$_${c2ri(ci)}$bdsdc( 'U', 'N', n, s, rwork( ie ), dum, 1_${ik}$,dum,1_${ik}$,dum, idum, & rwork( nrwork ), iwork, info ) else if( wntqo ) then iu = nwork @@ -11069,21 +11064,21 @@ module stdlib_linalg_lapack_${ci}$ ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$lacpy( 'U', n, n, a, lda, vt, ldvt ) - call stdlib_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( nwork ), & + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( nwork ), & lwork-nwork+1, ierr ) ! generate q in a ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$ungbr( 'Q', m, n, n, a, lda, work( itauq ),work( nwork ), lwork-& + call stdlib${ii}$_${ci}$ungbr( 'Q', m, n, n, a, lda, work( itauq ),work( nwork ), lwork-& nwork+1, ierr ) - if( lwork >= m*n + 3*n ) then + if( lwork >= m*n + 3_${ik}$*n ) then ! work( iu ) is m by n ldwrku = m else ! work(iu) is ldwrku by n - ldwrku = ( lwork - 3*n ) / n + ldwrku = ( lwork - 3_${ik}$*n ) / n end if nwork = iu + ldwrku*n ! perform bidiagonal svd, computing left singular vectors @@ -11091,15 +11086,15 @@ module stdlib_linalg_lapack_${ci}$ ! singular vectors of bidiagonal matrix in rwork(irvt) ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] + bdspac - call stdlib_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! multiply realmatrix rwork(irvt,KIND=${ck}$) by p**h in vt, ! storing the result in work(iu), copying to vt ! cworkspace: need 2*n [tauq, taup] + n*n [u] ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] + 2*n*n [rwork] - call stdlib_${ci}$larcm( n, n, rwork( irvt ), n, vt, ldvt,work( iu ), ldwrku, & + call stdlib${ii}$_${ci}$larcm( n, n, rwork( irvt ), n, vt, ldvt,work( iu ), ldwrku, & rwork( nrwork ) ) - call stdlib_${ci}$lacpy( 'F', n, n, work( iu ), ldwrku, vt, ldvt ) + call stdlib${ii}$_${ci}$lacpy( 'F', n, n, work( iu ), ldwrku, vt, ldvt ) ! multiply q in a by realmatrix rwork(iru,KIND=${ck}$), storing the ! result in work(iu), copying to a ! cworkspace: need 2*n [tauq, taup] + n*n [u] @@ -11109,9 +11104,9 @@ module stdlib_linalg_lapack_${ci}$ nrwork = irvt do i = 1, m, ldwrku chunk = min( m-i+1, ldwrku ) - call stdlib_${ci}$lacrm( chunk, n, a( i, 1 ), lda, rwork( iru ),n, work( iu ), & + call stdlib${ii}$_${ci}$lacrm( chunk, n, a( i, 1_${ik}$ ), lda, rwork( iru ),n, work( iu ), & ldwrku, rwork( nrwork ) ) - call stdlib_${ci}$lacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) + call stdlib${ii}$_${ci}$lacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1_${ik}$ ), lda ) end do else if( wntqs ) then @@ -11120,15 +11115,15 @@ module stdlib_linalg_lapack_${ci}$ ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$lacpy( 'U', n, n, a, lda, vt, ldvt ) - call stdlib_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( nwork ), & + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( nwork ), & lwork-nwork+1, ierr ) ! copy a to u, generate q ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) - call stdlib_${ci}$ungbr( 'Q', m, n, n, u, ldu, work( itauq ),work( nwork ), lwork-& + call stdlib${ii}$_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$ungbr( 'Q', m, n, n, u, ldu, work( itauq ),work( nwork ), lwork-& nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -11138,38 +11133,38 @@ module stdlib_linalg_lapack_${ci}$ iru = nrwork irvt = iru + n*n nrwork = irvt + n*n - call stdlib_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! multiply realmatrix rwork(irvt,KIND=${ck}$) by p**h in vt, ! storing the result in a, copying to vt ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] + 2*n*n [rwork] - call stdlib_${ci}$larcm( n, n, rwork( irvt ), n, vt, ldvt, a, lda,rwork( nrwork ) ) + call stdlib${ii}$_${ci}$larcm( n, n, rwork( irvt ), n, vt, ldvt, a, lda,rwork( nrwork ) ) - call stdlib_${ci}$lacpy( 'F', n, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$lacpy( 'F', n, n, a, lda, vt, ldvt ) ! multiply q in u by realmatrix rwork(iru,KIND=${ck}$), storing the ! result in a, copying to u ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + 2*m*n [rwork] < n + 5*n*n since m < 2*n here nrwork = irvt - call stdlib_${ci}$lacrm( m, n, u, ldu, rwork( iru ), n, a, lda,rwork( nrwork ) ) + call stdlib${ii}$_${ci}$lacrm( m, n, u, ldu, rwork( iru ), n, a, lda,rwork( nrwork ) ) - call stdlib_${ci}$lacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, n, a, lda, u, ldu ) else ! path 5a (m >> n, jobz='a') ! copy a to vt, generate p**h ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$lacpy( 'U', n, n, a, lda, vt, ldvt ) - call stdlib_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( nwork ), & + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( nwork ), & lwork-nwork+1, ierr ) ! copy a to u, generate q ! cworkspace: need 2*n [tauq, taup] + m [work] ! cworkspace: prefer 2*n [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) - call stdlib_${ci}$ungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& + call stdlib${ii}$_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$ungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -11179,58 +11174,58 @@ module stdlib_linalg_lapack_${ci}$ iru = nrwork irvt = iru + n*n nrwork = irvt + n*n - call stdlib_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! multiply realmatrix rwork(irvt,KIND=${ck}$) by p**h in vt, ! storing the result in a, copying to vt ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] + 2*n*n [rwork] - call stdlib_${ci}$larcm( n, n, rwork( irvt ), n, vt, ldvt, a, lda,rwork( nrwork ) ) + call stdlib${ii}$_${ci}$larcm( n, n, rwork( irvt ), n, vt, ldvt, a, lda,rwork( nrwork ) ) - call stdlib_${ci}$lacpy( 'F', n, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$lacpy( 'F', n, n, a, lda, vt, ldvt ) ! multiply q in u by realmatrix rwork(iru,KIND=${ck}$), storing the ! result in a, copying to u ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + 2*m*n [rwork] < n + 5*n*n since m < 2*n here nrwork = irvt - call stdlib_${ci}$lacrm( m, n, u, ldu, rwork( iru ), n, a, lda,rwork( nrwork ) ) + call stdlib${ii}$_${ci}$lacrm( m, n, u, ldu, rwork( iru ), n, a, lda,rwork( nrwork ) ) - call stdlib_${ci}$lacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, n, a, lda, u, ldu ) end if else ! m < mnthr2 ! path 6 (m >= n, but not much larger) ! reduce to bidiagonal form without qr decomposition ! use stdlib_${ci}$unmbr to compute singular vectors - ie = 1 + ie = 1_${ik}$ nrwork = ie + n - itauq = 1 + itauq = 1_${ik}$ itaup = itauq + n nwork = itaup + n ! bidiagonalize a ! cworkspace: need 2*n [tauq, taup] + m [work] ! cworkspace: prefer 2*n [tauq, taup] + (m+n)*nb [work] ! rworkspace: need n [e] - call stdlib_${ci}$gebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_${ci}$gebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) if( wntqn ) then ! path 6n (m >= n, jobz='n') ! compute singular values only ! cworkspace: need 0 ! rworkspace: need n [e] + bdspac - call stdlib_${c2ri(ci)}$bdsdc( 'U', 'N', n, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& + call stdlib${ii}$_${c2ri(ci)}$bdsdc( 'U', 'N', n, s, rwork( ie ), dum,1_${ik}$,dum,1_${ik}$,dum, idum, rwork(& nrwork ), iwork, info ) else if( wntqo ) then iu = nwork iru = nrwork irvt = iru + n*n nrwork = irvt + n*n - if( lwork >= m*n + 3*n ) then + if( lwork >= m*n + 3_${ik}$*n ) then ! work( iu ) is m by n ldwrku = m else ! work( iu ) is ldwrku by n - ldwrku = ( lwork - 3*n ) / n + ldwrku = ( lwork - 3_${ik}$*n ) / n end if nwork = iu + ldwrku*n ! path 6o (m >= n, jobz='o') @@ -11239,17 +11234,17 @@ module stdlib_linalg_lapack_${ci}$ ! singular vectors of bidiagonal matrix in rwork(irvt) ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] + bdspac - call stdlib_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(irvt,KIND=${ck}$) to complex matrix vt ! overwrite vt by right singular vectors of a ! cworkspace: need 2*n [tauq, taup] + n*n [u] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*n [u] + n*nb [work] ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] - call stdlib_${ci}$lacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) - call stdlib_${ci}$unmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & + call stdlib${ii}$_${ci}$lacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) + call stdlib${ii}$_${ci}$unmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork-nwork+1, ierr ) - if( lwork >= m*n + 3*n ) then + if( lwork >= m*n + 3_${ik}$*n ) then ! path 6o-fast ! copy realmatrix rwork(iru,KIND=${ck}$) to complex matrix work(iu) ! overwrite work(iu) by left singular vectors of a, copying @@ -11257,18 +11252,18 @@ module stdlib_linalg_lapack_${ci}$ ! cworkspace: need 2*n [tauq, taup] + m*n [u] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + m*n [u] + n*nb [work] ! rworkspace: need n [e] + n*n [ru] - call stdlib_${ci}$laset( 'F', m, n, czero, czero, work( iu ),ldwrku ) - call stdlib_${ci}$lacp2( 'F', n, n, rwork( iru ), n, work( iu ),ldwrku ) - call stdlib_${ci}$unmbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), work( iu & + call stdlib${ii}$_${ci}$laset( 'F', m, n, czero, czero, work( iu ),ldwrku ) + call stdlib${ii}$_${ci}$lacp2( 'F', n, n, rwork( iru ), n, work( iu ),ldwrku ) + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), work( iu & ), ldwrku,work( nwork ), lwork-nwork+1, ierr ) - call stdlib_${ci}$lacpy( 'F', m, n, work( iu ), ldwrku, a, lda ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, n, work( iu ), ldwrku, a, lda ) else ! path 6o-slow ! generate q in a ! cworkspace: need 2*n [tauq, taup] + n*n [u] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*n [u] + n*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$ungbr( 'Q', m, n, n, a, lda, work( itauq ),work( nwork ), & + call stdlib${ii}$_${ci}$ungbr( 'Q', m, n, n, a, lda, work( itauq ),work( nwork ), & lwork-nwork+1, ierr ) ! multiply q in a by realmatrix rwork(iru,KIND=${ck}$), storing the ! result in work(iu), copying to a @@ -11279,9 +11274,9 @@ module stdlib_linalg_lapack_${ci}$ nrwork = irvt do i = 1, m, ldwrku chunk = min( m-i+1, ldwrku ) - call stdlib_${ci}$lacrm( chunk, n, a( i, 1 ), lda,rwork( iru ), n, work( iu )& + call stdlib${ii}$_${ci}$lacrm( chunk, n, a( i, 1_${ik}$ ), lda,rwork( iru ), n, work( iu )& , ldwrku,rwork( nrwork ) ) - call stdlib_${ci}$lacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) + call stdlib${ii}$_${ci}$lacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1_${ik}$ ), lda ) end do end if @@ -11295,24 +11290,24 @@ module stdlib_linalg_lapack_${ci}$ iru = nrwork irvt = iru + n*n nrwork = irvt + n*n - call stdlib_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=${ck}$) to complex matrix u ! overwrite u by left singular vectors of a ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] - call stdlib_${ci}$laset( 'F', m, n, czero, czero, u, ldu ) - call stdlib_${ci}$lacp2( 'F', n, n, rwork( iru ), n, u, ldu ) - call stdlib_${ci}$unmbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), u, ldu, & + call stdlib${ii}$_${ci}$laset( 'F', m, n, czero, czero, u, ldu ) + call stdlib${ii}$_${ci}$lacp2( 'F', n, n, rwork( iru ), n, u, ldu ) + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=${ck}$) to complex matrix vt ! overwrite vt by right singular vectors of a ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] - call stdlib_${ci}$lacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) - call stdlib_${ci}$unmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & + call stdlib${ii}$_${ci}$lacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) + call stdlib${ii}$_${ci}$unmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork-nwork+1, ierr ) else ! path 6a (m >= n, jobz='a') @@ -11324,28 +11319,28 @@ module stdlib_linalg_lapack_${ci}$ iru = nrwork irvt = iru + n*n nrwork = irvt + n*n - call stdlib_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_${c2ri(ci)}$bdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! set the right corner of u to identity matrix - call stdlib_${ci}$laset( 'F', m, m, czero, czero, u, ldu ) + call stdlib${ii}$_${ci}$laset( 'F', m, m, czero, czero, u, ldu ) if( m>n ) then - call stdlib_${ci}$laset( 'F', m-n, m-n, czero, cone,u( n+1, n+1 ), ldu ) + call stdlib${ii}$_${ci}$laset( 'F', m-n, m-n, czero, cone,u( n+1, n+1 ), ldu ) end if ! copy realmatrix rwork(iru,KIND=${ck}$) to complex matrix u ! overwrite u by left singular vectors of a ! cworkspace: need 2*n [tauq, taup] + m [work] ! cworkspace: prefer 2*n [tauq, taup] + m*nb [work] ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] - call stdlib_${ci}$lacp2( 'F', n, n, rwork( iru ), n, u, ldu ) - call stdlib_${ci}$unmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + call stdlib${ii}$_${ci}$lacp2( 'F', n, n, rwork( iru ), n, u, ldu ) + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=${ck}$) to complex matrix vt ! overwrite vt by right singular vectors of a ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] - call stdlib_${ci}$lacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) - call stdlib_${ci}$unmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & + call stdlib${ii}$_${ci}$lacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) + call stdlib${ii}$_${ci}$unmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork-nwork+1, ierr ) end if end if @@ -11357,48 +11352,48 @@ module stdlib_linalg_lapack_${ci}$ if( wntqn ) then ! path 1t (n >> m, jobz='n') ! no singular vectors to be computed - itau = 1 + itau = 1_${ik}$ nwork = itau + m ! compute a=l*q ! cworkspace: need m [tau] + m [work] ! cworkspace: prefer m [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) ! zero out above l - if (m>1) call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero, a( 1, 2 ),lda ) - ie = 1 - itauq = 1 + if (m>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'U', m-1, m-1, czero, czero, a( 1_${ik}$, 2_${ik}$ ),lda ) + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + m nwork = itaup + m ! bidiagonalize l in a ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + 2*m*nb [work] ! rworkspace: need m [e] - call stdlib_${ci}$gebrd( m, m, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& + call stdlib${ii}$_${ci}$gebrd( m, m, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& work( nwork ), lwork-nwork+1,ierr ) nrwork = ie + m ! perform bidiagonal svd, compute singular values only ! cworkspace: need 0 ! rworkspace: need m [e] + bdspac - call stdlib_${c2ri(ci)}$bdsdc( 'U', 'N', m, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& + call stdlib${ii}$_${c2ri(ci)}$bdsdc( 'U', 'N', m, s, rwork( ie ), dum,1_${ik}$,dum,1_${ik}$,dum, idum, rwork(& nrwork ), iwork, info ) else if( wntqo ) then ! path 2t (n >> m, jobz='o') ! m right singular vectors to be overwritten on a and ! m left singular vectors to be computed in u - ivt = 1 + ivt = 1_${ik}$ ldwkvt = m ! work(ivt) is m by m il = ivt + ldwkvt*m - if( lwork >= m*n + m*m + 3*m ) then + if( lwork >= m*n + m*m + 3_${ik}$*m ) then ! work(il) m by n ldwrkl = m chunk = n else ! work(il) is m by chunk ldwrkl = m - chunk = ( lwork - m*m - 3*m ) / m + chunk = ( lwork - m*m - 3_${ik}$*m ) / m end if itau = il + ldwrkl*chunk nwork = itau + m @@ -11406,19 +11401,19 @@ module stdlib_linalg_lapack_${ci}$ ! cworkspace: need m*m [vt] + m*m [l] + m [tau] + m [work] ! cworkspace: prefer m*m [vt] + m*m [l] + m [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) ! copy l to work(il), zeroing about above it - call stdlib_${ci}$lacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) - call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,work( il+ldwrkl ), ldwrkl ) + call stdlib${ii}$_${ci}$lacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) + call stdlib${ii}$_${ci}$laset( 'U', m-1, m-1, czero, czero,work( il+ldwrkl ), ldwrkl ) ! generate q in a ! cworkspace: need m*m [vt] + m*m [l] + m [tau] + m [work] ! cworkspace: prefer m*m [vt] + m*m [l] + m [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$unglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork-nwork+& - 1, ierr ) - ie = 1 + call stdlib${ii}$_${ci}$unglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork-nwork+& + 1_${ik}$, ierr ) + ie = 1_${ik}$ itauq = itau itaup = itauq + m nwork = itaup + m @@ -11426,7 +11421,7 @@ module stdlib_linalg_lapack_${ci}$ ! cworkspace: need m*m [vt] + m*m [l] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [vt] + m*m [l] + 2*m [tauq, taup] + 2*m*nb [work] ! rworkspace: need m [e] - call stdlib_${ci}$gebrd( m, m, work( il ), ldwrkl, s, rwork( ie ),work( itauq ), & + call stdlib${ii}$_${ci}$gebrd( m, m, work( il ), ldwrkl, s, rwork( ie ),work( itauq ), & work( itaup ), work( nwork ),lwork-nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -11436,23 +11431,23 @@ module stdlib_linalg_lapack_${ci}$ iru = ie + m irvt = iru + m*m nrwork = irvt + m*m - call stdlib_${c2ri(ci)}$bdsdc( 'U', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_${c2ri(ci)}$bdsdc( 'U', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=${ck}$) to complex matrix work(iu) ! overwrite work(iu) by the left singular vectors of l ! cworkspace: need m*m [vt] + m*m [l] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [vt] + m*m [l] + 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$lacp2( 'F', m, m, rwork( iru ), m, u, ldu ) - call stdlib_${ci}$unmbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & + call stdlib${ii}$_${ci}$lacp2( 'F', m, m, rwork( iru ), m, u, ldu ) + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & u, ldu, work( nwork ),lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=${ck}$) to complex matrix work(ivt) ! overwrite work(ivt) by the right singular vectors of l ! cworkspace: need m*m [vt] + m*m [l] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [vt] + m*m [l] + 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$lacp2( 'F', m, m, rwork( irvt ), m, work( ivt ),ldwkvt ) - call stdlib_${ci}$unmbr( 'P', 'R', 'C', m, m, m, work( il ), ldwrkl,work( itaup ), & + call stdlib${ii}$_${ci}$lacp2( 'F', m, m, rwork( irvt ), m, work( ivt ),ldwkvt ) + call stdlib${ii}$_${ci}$unmbr( 'P', 'R', 'C', m, m, m, work( il ), ldwrkl,work( itaup ), & work( ivt ), ldwkvt,work( nwork ), lwork-nwork+1, ierr ) ! multiply right singular vectors of l in work(il) by q ! in a, storing result in work(il) and copying to a @@ -11461,16 +11456,16 @@ module stdlib_linalg_lapack_${ci}$ ! rworkspace: need 0 do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_${ci}$gemm( 'N', 'N', m, blk, m, cone, work( ivt ), m,a( 1, i ), & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', m, blk, m, cone, work( ivt ), m,a( 1_${ik}$, i ), & lda, czero, work( il ),ldwrkl ) - call stdlib_${ci}$lacpy( 'F', m, blk, work( il ), ldwrkl,a( 1, i ), lda ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, blk, work( il ), ldwrkl,a( 1_${ik}$, i ), lda ) end do else if( wntqs ) then ! path 3t (n >> m, jobz='s') ! m right singular vectors to be computed in vt and ! m left singular vectors to be computed in u - il = 1 + il = 1_${ik}$ ! work(il) is m by m ldwrkl = m itau = il + ldwrkl*m @@ -11479,19 +11474,19 @@ module stdlib_linalg_lapack_${ci}$ ! cworkspace: need m*m [l] + m [tau] + m [work] ! cworkspace: prefer m*m [l] + m [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) ! copy l to work(il), zeroing out above it - call stdlib_${ci}$lacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) - call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,work( il+ldwrkl ), ldwrkl ) + call stdlib${ii}$_${ci}$lacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) + call stdlib${ii}$_${ci}$laset( 'U', m-1, m-1, czero, czero,work( il+ldwrkl ), ldwrkl ) ! generate q in a ! cworkspace: need m*m [l] + m [tau] + m [work] ! cworkspace: prefer m*m [l] + m [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$unglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork-nwork+& - 1, ierr ) - ie = 1 + call stdlib${ii}$_${ci}$unglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork-nwork+& + 1_${ik}$, ierr ) + ie = 1_${ik}$ itauq = itau itaup = itauq + m nwork = itaup + m @@ -11499,7 +11494,7 @@ module stdlib_linalg_lapack_${ci}$ ! cworkspace: need m*m [l] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [l] + 2*m [tauq, taup] + 2*m*nb [work] ! rworkspace: need m [e] - call stdlib_${ci}$gebrd( m, m, work( il ), ldwrkl, s, rwork( ie ),work( itauq ), & + call stdlib${ii}$_${ci}$gebrd( m, m, work( il ), ldwrkl, s, rwork( ie ),work( itauq ), & work( itaup ), work( nwork ),lwork-nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -11509,36 +11504,36 @@ module stdlib_linalg_lapack_${ci}$ iru = ie + m irvt = iru + m*m nrwork = irvt + m*m - call stdlib_${c2ri(ci)}$bdsdc( 'U', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_${c2ri(ci)}$bdsdc( 'U', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=${ck}$) to complex matrix u ! overwrite u by left singular vectors of l ! cworkspace: need m*m [l] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [l] + 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$lacp2( 'F', m, m, rwork( iru ), m, u, ldu ) - call stdlib_${ci}$unmbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & + call stdlib${ii}$_${ci}$lacp2( 'F', m, m, rwork( iru ), m, u, ldu ) + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & u, ldu, work( nwork ),lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=${ck}$) to complex matrix vt ! overwrite vt by left singular vectors of l ! cworkspace: need m*m [l] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [l] + 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$lacp2( 'F', m, m, rwork( irvt ), m, vt, ldvt ) - call stdlib_${ci}$unmbr( 'P', 'R', 'C', m, m, m, work( il ), ldwrkl,work( itaup ), & + call stdlib${ii}$_${ci}$lacp2( 'F', m, m, rwork( irvt ), m, vt, ldvt ) + call stdlib${ii}$_${ci}$unmbr( 'P', 'R', 'C', m, m, m, work( il ), ldwrkl,work( itaup ), & vt, ldvt, work( nwork ),lwork-nwork+1, ierr ) ! copy vt to work(il), multiply right singular vectors of l ! in work(il) by q in a, storing result in vt ! cworkspace: need m*m [l] ! rworkspace: need 0 - call stdlib_${ci}$lacpy( 'F', m, m, vt, ldvt, work( il ), ldwrkl ) - call stdlib_${ci}$gemm( 'N', 'N', m, n, m, cone, work( il ), ldwrkl,a, lda, czero, & + call stdlib${ii}$_${ci}$lacpy( 'F', m, m, vt, ldvt, work( il ), ldwrkl ) + call stdlib${ii}$_${ci}$gemm( 'N', 'N', m, n, m, cone, work( il ), ldwrkl,a, lda, czero, & vt, ldvt ) else if( wntqa ) then ! path 4t (n >> m, jobz='a') ! n right singular vectors to be computed in vt and ! m left singular vectors to be computed in u - ivt = 1 + ivt = 1_${ik}$ ! work(ivt) is m by m ldwkvt = m itau = ivt + ldwkvt*m @@ -11547,18 +11542,18 @@ module stdlib_linalg_lapack_${ci}$ ! cworkspace: need m*m [vt] + m [tau] + m [work] ! cworkspace: prefer m*m [vt] + m [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) - call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! cworkspace: need m*m [vt] + m [tau] + n [work] ! cworkspace: prefer m*m [vt] + m [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$unglq( n, n, m, vt, ldvt, work( itau ),work( nwork ), lwork-& + call stdlib${ii}$_${ci}$unglq( n, n, m, vt, ldvt, work( itau ),work( nwork ), lwork-& nwork+1, ierr ) ! produce l in a, zeroing out above it - if (m>1) call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero, a( 1, 2 ),lda ) - ie = 1 + if (m>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'U', m-1, m-1, czero, czero, a( 1_${ik}$, 2_${ik}$ ),lda ) + ie = 1_${ik}$ itauq = itau itaup = itauq + m nwork = itaup + m @@ -11566,7 +11561,7 @@ module stdlib_linalg_lapack_${ci}$ ! cworkspace: need m*m [vt] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [vt] + 2*m [tauq, taup] + 2*m*nb [work] ! rworkspace: need m [e] - call stdlib_${ci}$gebrd( m, m, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& + call stdlib${ii}$_${ci}$gebrd( m, m, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& work( nwork ), lwork-nwork+1,ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -11576,55 +11571,55 @@ module stdlib_linalg_lapack_${ci}$ iru = ie + m irvt = iru + m*m nrwork = irvt + m*m - call stdlib_${c2ri(ci)}$bdsdc( 'U', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_${c2ri(ci)}$bdsdc( 'U', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=${ck}$) to complex matrix u ! overwrite u by left singular vectors of l ! cworkspace: need m*m [vt] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [vt] + 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$lacp2( 'F', m, m, rwork( iru ), m, u, ldu ) - call stdlib_${ci}$unmbr( 'Q', 'L', 'N', m, m, m, a, lda,work( itauq ), u, ldu, & + call stdlib${ii}$_${ci}$lacp2( 'F', m, m, rwork( iru ), m, u, ldu ) + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'N', m, m, m, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=${ck}$) to complex matrix work(ivt) ! overwrite work(ivt) by right singular vectors of l ! cworkspace: need m*m [vt] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [vt] + 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$lacp2( 'F', m, m, rwork( irvt ), m, work( ivt ),ldwkvt ) - call stdlib_${ci}$unmbr( 'P', 'R', 'C', m, m, m, a, lda,work( itaup ), work( ivt ),& + call stdlib${ii}$_${ci}$lacp2( 'F', m, m, rwork( irvt ), m, work( ivt ),ldwkvt ) + call stdlib${ii}$_${ci}$unmbr( 'P', 'R', 'C', m, m, m, a, lda,work( itaup ), work( ivt ),& ldwkvt,work( nwork ), lwork-nwork+1, ierr ) ! multiply right singular vectors of l in work(ivt) by ! q in vt, storing result in a ! cworkspace: need m*m [vt] ! rworkspace: need 0 - call stdlib_${ci}$gemm( 'N', 'N', m, n, m, cone, work( ivt ), ldwkvt,vt, ldvt, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', m, n, m, cone, work( ivt ), ldwkvt,vt, ldvt, & czero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_${ci}$lacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, n, a, lda, vt, ldvt ) end if else if( n>=mnthr2 ) then ! mnthr2 <= n < mnthr1 ! path 5t (n >> m, but not as much as mnthr1) ! reduce to bidiagonal form without qr decomposition, use - ! stdlib_${ci}$ungbr and matrix multiplication to compute singular vectors - ie = 1 + ! stdlib${ii}$_${ci}$ungbr and matrix multiplication to compute singular vectors + ie = 1_${ik}$ nrwork = ie + m - itauq = 1 + itauq = 1_${ik}$ itaup = itauq + m nwork = itaup + m ! bidiagonalize a ! cworkspace: need 2*m [tauq, taup] + n [work] ! cworkspace: prefer 2*m [tauq, taup] + (m+n)*nb [work] ! rworkspace: need m [e] - call stdlib_${ci}$gebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_${ci}$gebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) if( wntqn ) then ! path 5tn (n >> m, jobz='n') ! compute singular values only ! cworkspace: need 0 ! rworkspace: need m [e] + bdspac - call stdlib_${c2ri(ci)}$bdsdc( 'L', 'N', m, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& + call stdlib${ii}$_${c2ri(ci)}$bdsdc( 'L', 'N', m, s, rwork( ie ), dum,1_${ik}$,dum,1_${ik}$,dum, idum, rwork(& nrwork ), iwork, info ) else if( wntqo ) then irvt = nrwork @@ -11636,23 +11631,23 @@ module stdlib_linalg_lapack_${ci}$ ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$lacpy( 'L', m, m, a, lda, u, ldu ) - call stdlib_${ci}$ungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& + call stdlib${ii}$_${ci}$lacpy( 'L', m, m, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$ungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& nwork+1, ierr ) ! generate p**h in a ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$ungbr( 'P', m, n, m, a, lda, work( itaup ),work( nwork ), lwork-& + call stdlib${ii}$_${ci}$ungbr( 'P', m, n, m, a, lda, work( itaup ),work( nwork ), lwork-& nwork+1, ierr ) ldwkvt = m - if( lwork >= m*n + 3*m ) then + if( lwork >= m*n + 3_${ik}$*m ) then ! work( ivt ) is m by n nwork = ivt + ldwkvt*n chunk = n else ! work( ivt ) is m by chunk - chunk = ( lwork - 3*m ) / m + chunk = ( lwork - 3_${ik}$*m ) / m nwork = ivt + ldwkvt*chunk end if ! perform bidiagonal svd, computing left singular vectors @@ -11660,15 +11655,15 @@ module stdlib_linalg_lapack_${ci}$ ! singular vectors of bidiagonal matrix in rwork(irvt) ! cworkspace: need 0 ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] + bdspac - call stdlib_${c2ri(ci)}$bdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_${c2ri(ci)}$bdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! multiply q in u by realmatrix rwork(irvt,KIND=${ck}$) ! storing the result in work(ivt), copying to u ! cworkspace: need 2*m [tauq, taup] + m*m [vt] ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] + 2*m*m [rwork] - call stdlib_${ci}$lacrm( m, m, u, ldu, rwork( iru ), m, work( ivt ),ldwkvt, rwork( & + call stdlib${ii}$_${ci}$lacrm( m, m, u, ldu, rwork( iru ), m, work( ivt ),ldwkvt, rwork( & nrwork ) ) - call stdlib_${ci}$lacpy( 'F', m, m, work( ivt ), ldwkvt, u, ldu ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, m, work( ivt ), ldwkvt, u, ldu ) ! multiply rwork(irvt) by p**h in a, storing the ! result in work(ivt), copying to a ! cworkspace: need 2*m [tauq, taup] + m*m [vt] @@ -11678,9 +11673,9 @@ module stdlib_linalg_lapack_${ci}$ nrwork = iru do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_${ci}$larcm( m, blk, rwork( irvt ), m, a( 1, i ), lda,work( ivt ), & + call stdlib${ii}$_${ci}$larcm( m, blk, rwork( irvt ), m, a( 1_${ik}$, i ), lda,work( ivt ), & ldwkvt, rwork( nrwork ) ) - call stdlib_${ci}$lacpy( 'F', m, blk, work( ivt ), ldwkvt,a( 1, i ), lda ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, blk, work( ivt ), ldwkvt,a( 1_${ik}$, i ), lda ) end do else if( wntqs ) then @@ -11689,15 +11684,15 @@ module stdlib_linalg_lapack_${ci}$ ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$lacpy( 'L', m, m, a, lda, u, ldu ) - call stdlib_${ci}$ungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& + call stdlib${ii}$_${ci}$lacpy( 'L', m, m, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$ungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& nwork+1, ierr ) ! copy a to vt, generate p**h ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) - call stdlib_${ci}$ungbr( 'P', m, n, m, vt, ldvt, work( itaup ),work( nwork ), & + call stdlib${ii}$_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$ungbr( 'P', m, n, m, vt, ldvt, work( itaup ),work( nwork ), & lwork-nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -11707,38 +11702,38 @@ module stdlib_linalg_lapack_${ci}$ irvt = nrwork iru = irvt + m*m nrwork = iru + m*m - call stdlib_${c2ri(ci)}$bdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_${c2ri(ci)}$bdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! multiply q in u by realmatrix rwork(iru,KIND=${ck}$), storing the ! result in a, copying to u ! cworkspace: need 0 ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] + 2*m*m [rwork] - call stdlib_${ci}$lacrm( m, m, u, ldu, rwork( iru ), m, a, lda,rwork( nrwork ) ) + call stdlib${ii}$_${ci}$lacrm( m, m, u, ldu, rwork( iru ), m, a, lda,rwork( nrwork ) ) - call stdlib_${ci}$lacpy( 'F', m, m, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, m, a, lda, u, ldu ) ! multiply realmatrix rwork(irvt,KIND=${ck}$) by p**h in vt, ! storing the result in a, copying to vt ! cworkspace: need 0 ! rworkspace: need m [e] + m*m [rvt] + 2*m*n [rwork] < m + 5*m*m since n < 2*m here nrwork = iru - call stdlib_${ci}$larcm( m, n, rwork( irvt ), m, vt, ldvt, a, lda,rwork( nrwork ) ) + call stdlib${ii}$_${ci}$larcm( m, n, rwork( irvt ), m, vt, ldvt, a, lda,rwork( nrwork ) ) - call stdlib_${ci}$lacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, n, a, lda, vt, ldvt ) else ! path 5ta (n >> m, jobz='a') ! copy a to u, generate q ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$lacpy( 'L', m, m, a, lda, u, ldu ) - call stdlib_${ci}$ungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& + call stdlib${ii}$_${ci}$lacpy( 'L', m, m, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$ungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& nwork+1, ierr ) ! copy a to vt, generate p**h ! cworkspace: need 2*m [tauq, taup] + n [work] ! cworkspace: prefer 2*m [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) - call stdlib_${ci}$ungbr( 'P', n, n, m, vt, ldvt, work( itaup ),work( nwork ), & + call stdlib${ii}$_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$ungbr( 'P', n, n, m, vt, ldvt, work( itaup ),work( nwork ), & lwork-nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -11748,58 +11743,58 @@ module stdlib_linalg_lapack_${ci}$ irvt = nrwork iru = irvt + m*m nrwork = iru + m*m - call stdlib_${c2ri(ci)}$bdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_${c2ri(ci)}$bdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! multiply q in u by realmatrix rwork(iru,KIND=${ck}$), storing the ! result in a, copying to u ! cworkspace: need 0 ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] + 2*m*m [rwork] - call stdlib_${ci}$lacrm( m, m, u, ldu, rwork( iru ), m, a, lda,rwork( nrwork ) ) + call stdlib${ii}$_${ci}$lacrm( m, m, u, ldu, rwork( iru ), m, a, lda,rwork( nrwork ) ) - call stdlib_${ci}$lacpy( 'F', m, m, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, m, a, lda, u, ldu ) ! multiply realmatrix rwork(irvt,KIND=${ck}$) by p**h in vt, ! storing the result in a, copying to vt ! cworkspace: need 0 ! rworkspace: need m [e] + m*m [rvt] + 2*m*n [rwork] < m + 5*m*m since n < 2*m here nrwork = iru - call stdlib_${ci}$larcm( m, n, rwork( irvt ), m, vt, ldvt, a, lda,rwork( nrwork ) ) + call stdlib${ii}$_${ci}$larcm( m, n, rwork( irvt ), m, vt, ldvt, a, lda,rwork( nrwork ) ) - call stdlib_${ci}$lacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, n, a, lda, vt, ldvt ) end if else ! n < mnthr2 ! path 6t (n > m, but not much larger) ! reduce to bidiagonal form without lq decomposition ! use stdlib_${ci}$unmbr to compute singular vectors - ie = 1 + ie = 1_${ik}$ nrwork = ie + m - itauq = 1 + itauq = 1_${ik}$ itaup = itauq + m nwork = itaup + m ! bidiagonalize a ! cworkspace: need 2*m [tauq, taup] + n [work] ! cworkspace: prefer 2*m [tauq, taup] + (m+n)*nb [work] ! rworkspace: need m [e] - call stdlib_${ci}$gebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_${ci}$gebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) if( wntqn ) then ! path 6tn (n > m, jobz='n') ! compute singular values only ! cworkspace: need 0 ! rworkspace: need m [e] + bdspac - call stdlib_${c2ri(ci)}$bdsdc( 'L', 'N', m, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& + call stdlib${ii}$_${c2ri(ci)}$bdsdc( 'L', 'N', m, s, rwork( ie ), dum,1_${ik}$,dum,1_${ik}$,dum, idum, rwork(& nrwork ), iwork, info ) else if( wntqo ) then ! path 6to (n > m, jobz='o') ldwkvt = m ivt = nwork - if( lwork >= m*n + 3*m ) then + if( lwork >= m*n + 3_${ik}$*m ) then ! work( ivt ) is m by n - call stdlib_${ci}$laset( 'F', m, n, czero, czero, work( ivt ),ldwkvt ) + call stdlib${ii}$_${ci}$laset( 'F', m, n, czero, czero, work( ivt ),ldwkvt ) nwork = ivt + ldwkvt*n else ! work( ivt ) is m by chunk - chunk = ( lwork - 3*m ) / m + chunk = ( lwork - 3_${ik}$*m ) / m nwork = ivt + ldwkvt*chunk end if ! perform bidiagonal svd, computing left singular vectors @@ -11810,17 +11805,17 @@ module stdlib_linalg_lapack_${ci}$ irvt = nrwork iru = irvt + m*m nrwork = iru + m*m - call stdlib_${c2ri(ci)}$bdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_${c2ri(ci)}$bdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=${ck}$) to complex matrix u ! overwrite u by left singular vectors of a ! cworkspace: need 2*m [tauq, taup] + m*m [vt] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*m [vt] + m*nb [work] ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] - call stdlib_${ci}$lacp2( 'F', m, m, rwork( iru ), m, u, ldu ) - call stdlib_${ci}$unmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + call stdlib${ii}$_${ci}$lacp2( 'F', m, m, rwork( iru ), m, u, ldu ) + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork-nwork+1, ierr ) - if( lwork >= m*n + 3*m ) then + if( lwork >= m*n + 3_${ik}$*m ) then ! path 6to-fast ! copy realmatrix rwork(irvt,KIND=${ck}$) to complex matrix work(ivt) ! overwrite work(ivt) by right singular vectors of a, @@ -11828,18 +11823,18 @@ module stdlib_linalg_lapack_${ci}$ ! cworkspace: need 2*m [tauq, taup] + m*n [vt] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*n [vt] + m*nb [work] ! rworkspace: need m [e] + m*m [rvt] - call stdlib_${ci}$lacp2( 'F', m, m, rwork( irvt ), m, work( ivt ),ldwkvt ) + call stdlib${ii}$_${ci}$lacp2( 'F', m, m, rwork( irvt ), m, work( ivt ),ldwkvt ) - call stdlib_${ci}$unmbr( 'P', 'R', 'C', m, n, m, a, lda,work( itaup ), work( & + call stdlib${ii}$_${ci}$unmbr( 'P', 'R', 'C', m, n, m, a, lda,work( itaup ), work( & ivt ), ldwkvt,work( nwork ), lwork-nwork+1, ierr ) - call stdlib_${ci}$lacpy( 'F', m, n, work( ivt ), ldwkvt, a, lda ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, n, work( ivt ), ldwkvt, a, lda ) else ! path 6to-slow ! generate p**h in a ! cworkspace: need 2*m [tauq, taup] + m*m [vt] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*m [vt] + m*nb [work] ! rworkspace: need 0 - call stdlib_${ci}$ungbr( 'P', m, n, m, a, lda, work( itaup ),work( nwork ), & + call stdlib${ii}$_${ci}$ungbr( 'P', m, n, m, a, lda, work( itaup ),work( nwork ), & lwork-nwork+1, ierr ) ! multiply q in a by realmatrix rwork(iru,KIND=${ck}$), storing the ! result in work(iu), copying to a @@ -11850,9 +11845,9 @@ module stdlib_linalg_lapack_${ci}$ nrwork = iru do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_${ci}$larcm( m, blk, rwork( irvt ), m, a( 1, i ),lda, work( ivt )& + call stdlib${ii}$_${ci}$larcm( m, blk, rwork( irvt ), m, a( 1_${ik}$, i ),lda, work( ivt )& , ldwkvt,rwork( nrwork ) ) - call stdlib_${ci}$lacpy( 'F', m, blk, work( ivt ), ldwkvt,a( 1, i ), lda ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, blk, work( ivt ), ldwkvt,a( 1_${ik}$, i ), lda ) end do end if @@ -11866,24 +11861,24 @@ module stdlib_linalg_lapack_${ci}$ irvt = nrwork iru = irvt + m*m nrwork = iru + m*m - call stdlib_${c2ri(ci)}$bdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_${c2ri(ci)}$bdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=${ck}$) to complex matrix u ! overwrite u by left singular vectors of a ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] - call stdlib_${ci}$lacp2( 'F', m, m, rwork( iru ), m, u, ldu ) - call stdlib_${ci}$unmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + call stdlib${ii}$_${ci}$lacp2( 'F', m, m, rwork( iru ), m, u, ldu ) + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=${ck}$) to complex matrix vt ! overwrite vt by right singular vectors of a ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need m [e] + m*m [rvt] - call stdlib_${ci}$laset( 'F', m, n, czero, czero, vt, ldvt ) - call stdlib_${ci}$lacp2( 'F', m, m, rwork( irvt ), m, vt, ldvt ) - call stdlib_${ci}$unmbr( 'P', 'R', 'C', m, n, m, a, lda,work( itaup ), vt, ldvt, & + call stdlib${ii}$_${ci}$laset( 'F', m, n, czero, czero, vt, ldvt ) + call stdlib${ii}$_${ci}$lacp2( 'F', m, m, rwork( irvt ), m, vt, ldvt ) + call stdlib${ii}$_${ci}$unmbr( 'P', 'R', 'C', m, n, m, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork-nwork+1, ierr ) else ! path 6ta (n > m, jobz='a') @@ -11895,47 +11890,47 @@ module stdlib_linalg_lapack_${ci}$ irvt = nrwork iru = irvt + m*m nrwork = iru + m*m - call stdlib_${c2ri(ci)}$bdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_${c2ri(ci)}$bdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=${ck}$) to complex matrix u ! overwrite u by left singular vectors of a ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] - call stdlib_${ci}$lacp2( 'F', m, m, rwork( iru ), m, u, ldu ) - call stdlib_${ci}$unmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + call stdlib${ii}$_${ci}$lacp2( 'F', m, m, rwork( iru ), m, u, ldu ) + call stdlib${ii}$_${ci}$unmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork-nwork+1, ierr ) ! set all of vt to identity matrix - call stdlib_${ci}$laset( 'F', n, n, czero, cone, vt, ldvt ) + call stdlib${ii}$_${ci}$laset( 'F', n, n, czero, cone, vt, ldvt ) ! copy realmatrix rwork(irvt,KIND=${ck}$) to complex matrix vt ! overwrite vt by right singular vectors of a ! cworkspace: need 2*m [tauq, taup] + n [work] ! cworkspace: prefer 2*m [tauq, taup] + n*nb [work] ! rworkspace: need m [e] + m*m [rvt] - call stdlib_${ci}$lacp2( 'F', m, m, rwork( irvt ), m, vt, ldvt ) - call stdlib_${ci}$unmbr( 'P', 'R', 'C', n, n, m, a, lda,work( itaup ), vt, ldvt, & + call stdlib${ii}$_${ci}$lacp2( 'F', m, m, rwork( irvt ), m, vt, ldvt ) + call stdlib${ii}$_${ci}$unmbr( 'P', 'R', 'C', n, n, m, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork-nwork+1, ierr ) end if end if end if ! undo scaling if necessary - if( iscl==1 ) then - if( anrm>bignum )call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,& + if( iscl==1_${ik}$ ) then + if( anrm>bignum )call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn, 1_${ik}$, s, minmn,& ierr ) - if( info/=0 .and. anrm>bignum )call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, bignum, anrm, minmn-1,& - 1,rwork( ie ), minmn, ierr ) - if( anrmbignum )call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn-1,& + 1_${ik}$,rwork( ie ), minmn, ierr ) + if( anrm=n .and. minmn>0 ) then - ! space needed for stdlib_${ci}$bdsqr is bdspac = 5*n - mnthr = stdlib_ilaenv( 6, 'ZGESVD', jobu // jobvt, m, n, 0, 0 ) - ! compute space needed for stdlib_${ci}$geqrf - call stdlib_${ci}$geqrf( m, n, a, lda, cdum(1), cdum(1), -1, ierr ) - lwork_wgeqrf = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_${ci}$ungqr - call stdlib_${ci}$ungqr( m, n, n, a, lda, cdum(1), cdum(1), -1, ierr ) - lwork_wungqr_n = int( cdum(1),KIND=ilp) - call stdlib_${ci}$ungqr( m, m, n, a, lda, cdum(1), cdum(1), -1, ierr ) - lwork_wungqr_m = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_${ci}$gebrd - call stdlib_${ci}$gebrd( n, n, a, lda, s, dum(1), cdum(1),cdum(1), cdum(1), -1, ierr ) + ! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + if( m>=n .and. minmn>0_${ik}$ ) then + ! space needed for stdlib${ii}$_${ci}$bdsqr is bdspac = 5*n + mnthr = stdlib${ii}$_ilaenv( 6_${ik}$, 'ZGESVD', jobu // jobvt, m, n, 0_${ik}$, 0_${ik}$ ) + ! compute space needed for stdlib${ii}$_${ci}$geqrf + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_wgeqrf = int( cdum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_${ci}$ungqr + call stdlib${ii}$_${ci}$ungqr( m, n, n, a, lda, cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_wungqr_n = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$ungqr( m, m, n, a, lda, cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_wungqr_m = int( cdum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_${ci}$gebrd + call stdlib${ii}$_${ci}$gebrd( n, n, a, lda, s, dum(1_${ik}$), cdum(1_${ik}$),cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) - lwork_wgebrd = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_${ci}$ungbr - call stdlib_${ci}$ungbr( 'P', n, n, n, a, lda, cdum(1),cdum(1), -1, ierr ) - lwork_wungbr_p = int( cdum(1),KIND=ilp) - call stdlib_${ci}$ungbr( 'Q', n, n, n, a, lda, cdum(1),cdum(1), -1, ierr ) - lwork_wungbr_q = int( cdum(1),KIND=ilp) + lwork_wgebrd = int( cdum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_${ci}$ungbr + call stdlib${ii}$_${ci}$ungbr( 'P', n, n, n, a, lda, cdum(1_${ik}$),cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_wungbr_p = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$ungbr( 'Q', n, n, n, a, lda, cdum(1_${ik}$),cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_wungbr_q = int( cdum(1_${ik}$),KIND=${ik}$) if( m>=mnthr ) then if( wntun ) then ! path 1 (m much larger than n, jobu='n') maxwrk = n + lwork_wgeqrf - maxwrk = max( maxwrk, 2*n+lwork_wgebrd ) - if( wntvo .or. wntvas )maxwrk = max( maxwrk, 2*n+lwork_wungbr_p ) - minwrk = 3*n + maxwrk = max( maxwrk, 2_${ik}$*n+lwork_wgebrd ) + if( wntvo .or. wntvas )maxwrk = max( maxwrk, 2_${ik}$*n+lwork_wungbr_p ) + minwrk = 3_${ik}$*n else if( wntuo .and. wntvn ) then ! path 2 (m much larger than n, jobu='o', jobvt='n') wrkbl = n + lwork_wgeqrf wrkbl = max( wrkbl, n+lwork_wungqr_n ) - wrkbl = max( wrkbl, 2*n+lwork_wgebrd ) - wrkbl = max( wrkbl, 2*n+lwork_wungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_wgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_wungbr_q ) maxwrk = max( n*n+wrkbl, n*n+m*n ) - minwrk = 2*n + m + minwrk = 2_${ik}$*n + m else if( wntuo .and. wntvas ) then ! path 3 (m much larger than n, jobu='o', jobvt='s' or ! 'a') wrkbl = n + lwork_wgeqrf wrkbl = max( wrkbl, n+lwork_wungqr_n ) - wrkbl = max( wrkbl, 2*n+lwork_wgebrd ) - wrkbl = max( wrkbl, 2*n+lwork_wungbr_q ) - wrkbl = max( wrkbl, 2*n+lwork_wungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_wgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_wungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_wungbr_p ) maxwrk = max( n*n+wrkbl, n*n+m*n ) - minwrk = 2*n + m + minwrk = 2_${ik}$*n + m else if( wntus .and. wntvn ) then ! path 4 (m much larger than n, jobu='s', jobvt='n') wrkbl = n + lwork_wgeqrf wrkbl = max( wrkbl, n+lwork_wungqr_n ) - wrkbl = max( wrkbl, 2*n+lwork_wgebrd ) - wrkbl = max( wrkbl, 2*n+lwork_wungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_wgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_wungbr_q ) maxwrk = n*n + wrkbl - minwrk = 2*n + m + minwrk = 2_${ik}$*n + m else if( wntus .and. wntvo ) then ! path 5 (m much larger than n, jobu='s', jobvt='o') wrkbl = n + lwork_wgeqrf wrkbl = max( wrkbl, n+lwork_wungqr_n ) - wrkbl = max( wrkbl, 2*n+lwork_wgebrd ) - wrkbl = max( wrkbl, 2*n+lwork_wungbr_q ) - wrkbl = max( wrkbl, 2*n+lwork_wungbr_p ) - maxwrk = 2*n*n + wrkbl - minwrk = 2*n + m + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_wgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_wungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_wungbr_p ) + maxwrk = 2_${ik}$*n*n + wrkbl + minwrk = 2_${ik}$*n + m else if( wntus .and. wntvas ) then ! path 6 (m much larger than n, jobu='s', jobvt='s' or ! 'a') wrkbl = n + lwork_wgeqrf wrkbl = max( wrkbl, n+lwork_wungqr_n ) - wrkbl = max( wrkbl, 2*n+lwork_wgebrd ) - wrkbl = max( wrkbl, 2*n+lwork_wungbr_q ) - wrkbl = max( wrkbl, 2*n+lwork_wungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_wgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_wungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_wungbr_p ) maxwrk = n*n + wrkbl - minwrk = 2*n + m + minwrk = 2_${ik}$*n + m else if( wntua .and. wntvn ) then ! path 7 (m much larger than n, jobu='a', jobvt='n') wrkbl = n + lwork_wgeqrf wrkbl = max( wrkbl, n+lwork_wungqr_m ) - wrkbl = max( wrkbl, 2*n+lwork_wgebrd ) - wrkbl = max( wrkbl, 2*n+lwork_wungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_wgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_wungbr_q ) maxwrk = n*n + wrkbl - minwrk = 2*n + m + minwrk = 2_${ik}$*n + m else if( wntua .and. wntvo ) then ! path 8 (m much larger than n, jobu='a', jobvt='o') wrkbl = n + lwork_wgeqrf wrkbl = max( wrkbl, n+lwork_wungqr_m ) - wrkbl = max( wrkbl, 2*n+lwork_wgebrd ) - wrkbl = max( wrkbl, 2*n+lwork_wungbr_q ) - wrkbl = max( wrkbl, 2*n+lwork_wungbr_p ) - maxwrk = 2*n*n + wrkbl - minwrk = 2*n + m + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_wgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_wungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_wungbr_p ) + maxwrk = 2_${ik}$*n*n + wrkbl + minwrk = 2_${ik}$*n + m else if( wntua .and. wntvas ) then ! path 9 (m much larger than n, jobu='a', jobvt='s' or ! 'a') wrkbl = n + lwork_wgeqrf wrkbl = max( wrkbl, n+lwork_wungqr_m ) - wrkbl = max( wrkbl, 2*n+lwork_wgebrd ) - wrkbl = max( wrkbl, 2*n+lwork_wungbr_q ) - wrkbl = max( wrkbl, 2*n+lwork_wungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_wgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_wungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_wungbr_p ) maxwrk = n*n + wrkbl - minwrk = 2*n + m + minwrk = 2_${ik}$*n + m end if else ! path 10 (m at least n, but not much larger) - call stdlib_${ci}$gebrd( m, n, a, lda, s, dum(1), cdum(1),cdum(1), cdum(1), -1, & + call stdlib${ii}$_${ci}$gebrd( m, n, a, lda, s, dum(1_${ik}$), cdum(1_${ik}$),cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, & ierr ) - lwork_wgebrd = int( cdum(1),KIND=ilp) - maxwrk = 2*n + lwork_wgebrd + lwork_wgebrd = int( cdum(1_${ik}$),KIND=${ik}$) + maxwrk = 2_${ik}$*n + lwork_wgebrd if( wntus .or. wntuo ) then - call stdlib_${ci}$ungbr( 'Q', m, n, n, a, lda, cdum(1),cdum(1), -1, ierr ) + call stdlib${ii}$_${ci}$ungbr( 'Q', m, n, n, a, lda, cdum(1_${ik}$),cdum(1_${ik}$), -1_${ik}$, ierr ) - lwork_wungbr_q = int( cdum(1),KIND=ilp) - maxwrk = max( maxwrk, 2*n+lwork_wungbr_q ) + lwork_wungbr_q = int( cdum(1_${ik}$),KIND=${ik}$) + maxwrk = max( maxwrk, 2_${ik}$*n+lwork_wungbr_q ) end if if( wntua ) then - call stdlib_${ci}$ungbr( 'Q', m, m, n, a, lda, cdum(1),cdum(1), -1, ierr ) + call stdlib${ii}$_${ci}$ungbr( 'Q', m, m, n, a, lda, cdum(1_${ik}$),cdum(1_${ik}$), -1_${ik}$, ierr ) - lwork_wungbr_q = int( cdum(1),KIND=ilp) - maxwrk = max( maxwrk, 2*n+lwork_wungbr_q ) + lwork_wungbr_q = int( cdum(1_${ik}$),KIND=${ik}$) + maxwrk = max( maxwrk, 2_${ik}$*n+lwork_wungbr_q ) end if if( .not.wntvn ) then - maxwrk = max( maxwrk, 2*n+lwork_wungbr_p ) - end if - minwrk = 2*n + m - end if - else if( minmn>0 ) then - ! space needed for stdlib_${ci}$bdsqr is bdspac = 5*m - mnthr = stdlib_ilaenv( 6, 'ZGESVD', jobu // jobvt, m, n, 0, 0 ) - ! compute space needed for stdlib_${ci}$gelqf - call stdlib_${ci}$gelqf( m, n, a, lda, cdum(1), cdum(1), -1, ierr ) - lwork_wgelqf = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_${ci}$unglq - call stdlib_${ci}$unglq( n, n, m, cdum(1), n, cdum(1), cdum(1), -1,ierr ) - lwork_wunglq_n = int( cdum(1),KIND=ilp) - call stdlib_${ci}$unglq( m, n, m, a, lda, cdum(1), cdum(1), -1, ierr ) - lwork_wunglq_m = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_${ci}$gebrd - call stdlib_${ci}$gebrd( m, m, a, lda, s, dum(1), cdum(1),cdum(1), cdum(1), -1, ierr ) + maxwrk = max( maxwrk, 2_${ik}$*n+lwork_wungbr_p ) + end if + minwrk = 2_${ik}$*n + m + end if + else if( minmn>0_${ik}$ ) then + ! space needed for stdlib${ii}$_${ci}$bdsqr is bdspac = 5*m + mnthr = stdlib${ii}$_ilaenv( 6_${ik}$, 'ZGESVD', jobu // jobvt, m, n, 0_${ik}$, 0_${ik}$ ) + ! compute space needed for stdlib${ii}$_${ci}$gelqf + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_wgelqf = int( cdum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_${ci}$unglq + call stdlib${ii}$_${ci}$unglq( n, n, m, cdum(1_${ik}$), n, cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$,ierr ) + lwork_wunglq_n = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_${ci}$unglq( m, n, m, a, lda, cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_wunglq_m = int( cdum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_${ci}$gebrd + call stdlib${ii}$_${ci}$gebrd( m, m, a, lda, s, dum(1_${ik}$), cdum(1_${ik}$),cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) - lwork_wgebrd = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_${ci}$ungbr p - call stdlib_${ci}$ungbr( 'P', m, m, m, a, n, cdum(1),cdum(1), -1, ierr ) - lwork_wungbr_p = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_${ci}$ungbr q - call stdlib_${ci}$ungbr( 'Q', m, m, m, a, n, cdum(1),cdum(1), -1, ierr ) - lwork_wungbr_q = int( cdum(1),KIND=ilp) + lwork_wgebrd = int( cdum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_${ci}$ungbr p + call stdlib${ii}$_${ci}$ungbr( 'P', m, m, m, a, n, cdum(1_${ik}$),cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_wungbr_p = int( cdum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_${ci}$ungbr q + call stdlib${ii}$_${ci}$ungbr( 'Q', m, m, m, a, n, cdum(1_${ik}$),cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_wungbr_q = int( cdum(1_${ik}$),KIND=${ik}$) if( n>=mnthr ) then if( wntvn ) then ! path 1t(n much larger than m, jobvt='n') maxwrk = m + lwork_wgelqf - maxwrk = max( maxwrk, 2*m+lwork_wgebrd ) - if( wntuo .or. wntuas )maxwrk = max( maxwrk, 2*m+lwork_wungbr_q ) - minwrk = 3*m + maxwrk = max( maxwrk, 2_${ik}$*m+lwork_wgebrd ) + if( wntuo .or. wntuas )maxwrk = max( maxwrk, 2_${ik}$*m+lwork_wungbr_q ) + minwrk = 3_${ik}$*m else if( wntvo .and. wntun ) then ! path 2t(n much larger than m, jobu='n', jobvt='o') wrkbl = m + lwork_wgelqf wrkbl = max( wrkbl, m+lwork_wunglq_m ) - wrkbl = max( wrkbl, 2*m+lwork_wgebrd ) - wrkbl = max( wrkbl, 2*m+lwork_wungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_wgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_wungbr_p ) maxwrk = max( m*m+wrkbl, m*m+m*n ) - minwrk = 2*m + n + minwrk = 2_${ik}$*m + n else if( wntvo .and. wntuas ) then ! path 3t(n much larger than m, jobu='s' or 'a', ! jobvt='o') wrkbl = m + lwork_wgelqf wrkbl = max( wrkbl, m+lwork_wunglq_m ) - wrkbl = max( wrkbl, 2*m+lwork_wgebrd ) - wrkbl = max( wrkbl, 2*m+lwork_wungbr_p ) - wrkbl = max( wrkbl, 2*m+lwork_wungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_wgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_wungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_wungbr_q ) maxwrk = max( m*m+wrkbl, m*m+m*n ) - minwrk = 2*m + n + minwrk = 2_${ik}$*m + n else if( wntvs .and. wntun ) then ! path 4t(n much larger than m, jobu='n', jobvt='s') wrkbl = m + lwork_wgelqf wrkbl = max( wrkbl, m+lwork_wunglq_m ) - wrkbl = max( wrkbl, 2*m+lwork_wgebrd ) - wrkbl = max( wrkbl, 2*m+lwork_wungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_wgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_wungbr_p ) maxwrk = m*m + wrkbl - minwrk = 2*m + n + minwrk = 2_${ik}$*m + n else if( wntvs .and. wntuo ) then ! path 5t(n much larger than m, jobu='o', jobvt='s') wrkbl = m + lwork_wgelqf wrkbl = max( wrkbl, m+lwork_wunglq_m ) - wrkbl = max( wrkbl, 2*m+lwork_wgebrd ) - wrkbl = max( wrkbl, 2*m+lwork_wungbr_p ) - wrkbl = max( wrkbl, 2*m+lwork_wungbr_q ) - maxwrk = 2*m*m + wrkbl - minwrk = 2*m + n + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_wgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_wungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_wungbr_q ) + maxwrk = 2_${ik}$*m*m + wrkbl + minwrk = 2_${ik}$*m + n else if( wntvs .and. wntuas ) then ! path 6t(n much larger than m, jobu='s' or 'a', ! jobvt='s') wrkbl = m + lwork_wgelqf wrkbl = max( wrkbl, m+lwork_wunglq_m ) - wrkbl = max( wrkbl, 2*m+lwork_wgebrd ) - wrkbl = max( wrkbl, 2*m+lwork_wungbr_p ) - wrkbl = max( wrkbl, 2*m+lwork_wungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_wgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_wungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_wungbr_q ) maxwrk = m*m + wrkbl - minwrk = 2*m + n + minwrk = 2_${ik}$*m + n else if( wntva .and. wntun ) then ! path 7t(n much larger than m, jobu='n', jobvt='a') wrkbl = m + lwork_wgelqf wrkbl = max( wrkbl, m+lwork_wunglq_n ) - wrkbl = max( wrkbl, 2*m+lwork_wgebrd ) - wrkbl = max( wrkbl, 2*m+lwork_wungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_wgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_wungbr_p ) maxwrk = m*m + wrkbl - minwrk = 2*m + n + minwrk = 2_${ik}$*m + n else if( wntva .and. wntuo ) then ! path 8t(n much larger than m, jobu='o', jobvt='a') wrkbl = m + lwork_wgelqf wrkbl = max( wrkbl, m+lwork_wunglq_n ) - wrkbl = max( wrkbl, 2*m+lwork_wgebrd ) - wrkbl = max( wrkbl, 2*m+lwork_wungbr_p ) - wrkbl = max( wrkbl, 2*m+lwork_wungbr_q ) - maxwrk = 2*m*m + wrkbl - minwrk = 2*m + n + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_wgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_wungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_wungbr_q ) + maxwrk = 2_${ik}$*m*m + wrkbl + minwrk = 2_${ik}$*m + n else if( wntva .and. wntuas ) then ! path 9t(n much larger than m, jobu='s' or 'a', ! jobvt='a') wrkbl = m + lwork_wgelqf wrkbl = max( wrkbl, m+lwork_wunglq_n ) - wrkbl = max( wrkbl, 2*m+lwork_wgebrd ) - wrkbl = max( wrkbl, 2*m+lwork_wungbr_p ) - wrkbl = max( wrkbl, 2*m+lwork_wungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_wgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_wungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_wungbr_q ) maxwrk = m*m + wrkbl - minwrk = 2*m + n + minwrk = 2_${ik}$*m + n end if else ! path 10t(n greater than m, but not much larger) - call stdlib_${ci}$gebrd( m, n, a, lda, s, dum(1), cdum(1),cdum(1), cdum(1), -1, & + call stdlib${ii}$_${ci}$gebrd( m, n, a, lda, s, dum(1_${ik}$), cdum(1_${ik}$),cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, & ierr ) - lwork_wgebrd = int( cdum(1),KIND=ilp) - maxwrk = 2*m + lwork_wgebrd + lwork_wgebrd = int( cdum(1_${ik}$),KIND=${ik}$) + maxwrk = 2_${ik}$*m + lwork_wgebrd if( wntvs .or. wntvo ) then - ! compute space needed for stdlib_${ci}$ungbr p - call stdlib_${ci}$ungbr( 'P', m, n, m, a, n, cdum(1),cdum(1), -1, ierr ) - lwork_wungbr_p = int( cdum(1),KIND=ilp) - maxwrk = max( maxwrk, 2*m+lwork_wungbr_p ) + ! compute space needed for stdlib${ii}$_${ci}$ungbr p + call stdlib${ii}$_${ci}$ungbr( 'P', m, n, m, a, n, cdum(1_${ik}$),cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_wungbr_p = int( cdum(1_${ik}$),KIND=${ik}$) + maxwrk = max( maxwrk, 2_${ik}$*m+lwork_wungbr_p ) end if if( wntva ) then - call stdlib_${ci}$ungbr( 'P', n, n, m, a, n, cdum(1),cdum(1), -1, ierr ) - lwork_wungbr_p = int( cdum(1),KIND=ilp) - maxwrk = max( maxwrk, 2*m+lwork_wungbr_p ) + call stdlib${ii}$_${ci}$ungbr( 'P', n, n, m, a, n, cdum(1_${ik}$),cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_wungbr_p = int( cdum(1_${ik}$),KIND=${ik}$) + maxwrk = max( maxwrk, 2_${ik}$*m+lwork_wungbr_p ) end if if( .not.wntun ) then - maxwrk = max( maxwrk, 2*m+lwork_wungbr_q ) + maxwrk = max( maxwrk, 2_${ik}$*m+lwork_wungbr_q ) end if - minwrk = 2*m + n + minwrk = 2_${ik}$*m + n end if end if maxwrk = max( maxwrk, minwrk ) - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk if( lworkzero .and. anrmbignum ) then - iscl = 1 - call stdlib_${ci}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, ierr ) + iscl = 1_${ik}$ + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, ierr ) end if if( m>=n ) then ! a has at least as many rows as columns. if a has sufficiently @@ -12351,32 +12346,32 @@ module stdlib_linalg_lapack_${ci}$ if( wntun ) then ! path 1 (m much larger than n, jobu='n') ! no left singular vectors to be computed - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: need 0) - call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & ierr ) ! zero out below r - if( n > 1 ) then - call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_${ci}$laset( 'L', n-1, n-1, czero, czero, a( 2_${ik}$, 1_${ik}$ ),lda ) end if - ie = 1 - itauq = 1 + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + n iwork = itaup + n ! bidiagonalize r in a ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_${ci}$gebrd( n, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& + call stdlib${ii}$_${ci}$gebrd( n, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& work( iwork ), lwork-iwork+1,ierr ) - ncvt = 0 + ncvt = 0_${ik}$ if( wntvo .or. wntvas ) then ! if right singular vectors desired, generate p'. ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & + call stdlib${ii}$_${ci}$ungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) ncvt = n end if @@ -12385,17 +12380,17 @@ module stdlib_linalg_lapack_${ci}$ ! singular vectors of a in a if desired ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', n, ncvt, 0, 0, s, rwork( ie ), a, lda,cdum, 1, cdum, & - 1, rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', n, ncvt, 0_${ik}$, 0_${ik}$, s, rwork( ie ), a, lda,cdum, 1_${ik}$, cdum, & + 1_${ik}$, rwork( irwork ), info ) ! if right singular vectors desired in vt, copy them there - if( wntvas )call stdlib_${ci}$lacpy( 'F', n, n, a, lda, vt, ldvt ) + if( wntvas )call stdlib${ii}$_${ci}$lacpy( 'F', n, n, a, lda, vt, ldvt ) else if( wntuo .and. wntvn ) then ! path 2 (m much larger than n, jobu='o', jobvt='n') ! n left singular vectors to be overwritten on a and ! no right singular vectors to be computed if( lwork>=n*n+3*n ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=max( wrkbl, lda*n )+lda*n ) then ! work(iu) is lda by n, work(ir) is lda by n ldwrku = lda @@ -12414,38 +12409,38 @@ module stdlib_linalg_lapack_${ci}$ ! compute a=q*r ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy r to work(ir) and zero out below it - call stdlib_${ci}$lacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) - call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,work( ir+1 ), ldwrkr ) + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) + call stdlib${ii}$_${ci}$laset( 'L', n-1, n-1, czero, czero,work( ir+1 ), ldwrkr ) ! generate q in a ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$ungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_${ci}$gebrd( n, n, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ),& + call stdlib${ii}$_${ci}$gebrd( n, n, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ),& work( itaup ),work( iwork ), lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing r ! (cworkspace: need n*n+3*n, prefer n*n+2*n+n*nb) ! (rworkspace: need 0) - call stdlib_${ci}$ungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & + call stdlib${ii}$_${ci}$ungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) ! (cworkspace: need n*n) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', n, 0, n, 0, s, rwork( ie ), cdum, 1,work( ir ), & - ldwrkr, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', n, 0_${ik}$, n, 0_${ik}$, s, rwork( ie ), cdum, 1_${ik}$,work( ir ), & + ldwrkr, cdum, 1_${ik}$,rwork( irwork ), info ) iu = itauq ! multiply q in a by left singular vectors of r in ! work(ir), storing result in work(iu) and copying to a @@ -12453,34 +12448,34 @@ module stdlib_linalg_lapack_${ci}$ ! (rworkspace: 0) do i = 1, m, ldwrku chunk = min( m-i+1, ldwrku ) - call stdlib_${ci}$gemm( 'N', 'N', chunk, n, n, cone, a( i, 1 ),lda, work( ir & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', chunk, n, n, cone, a( i, 1_${ik}$ ),lda, work( ir & ), ldwrkr, czero,work( iu ), ldwrku ) - call stdlib_${ci}$lacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) + call stdlib${ii}$_${ci}$lacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1_${ik}$ ), lda ) end do else ! insufficient workspace for a fast algorithm - ie = 1 - itauq = 1 + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + n iwork = itaup + n ! bidiagonalize a ! (cworkspace: need 2*n+m, prefer 2*n+(m+n)*nb) ! (rworkspace: n) - call stdlib_${ci}$gebrd( m, n, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_${ci}$gebrd( m, n, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing a ! (cworkspace: need 3*n, prefer 2*n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), & + call stdlib${ii}$_${ci}$ungbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in a ! (cworkspace: need 0) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', n, 0, m, 0, s, rwork( ie ), cdum, 1,a, lda, cdum, & - 1, rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', n, 0_${ik}$, m, 0_${ik}$, s, rwork( ie ), cdum, 1_${ik}$,a, lda, cdum, & + 1_${ik}$, rwork( irwork ), info ) end if else if( wntuo .and. wntvas ) then ! path 3 (m much larger than n, jobu='o', jobvt='s' or 'a') @@ -12488,7 +12483,7 @@ module stdlib_linalg_lapack_${ci}$ ! n right singular vectors to be computed in vt if( lwork>=n*n+3*n ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=max( wrkbl, lda*n )+lda*n ) then ! work(iu) is lda by n and work(ir) is lda by n ldwrku = lda @@ -12507,36 +12502,36 @@ module stdlib_linalg_lapack_${ci}$ ! compute a=q*r ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy r to vt, zeroing out below it - call stdlib_${ci}$lacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,vt( 2, 1 ), ldvt ) + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1_${ik}$ )call stdlib${ii}$_${ci}$laset( 'L', n-1, n-1, czero, czero,vt( 2_${ik}$, 1_${ik}$ ), ldvt ) ! generate q in a ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$ungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in vt, copying result to work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_${ci}$gebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_${ci}$gebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'L', n, n, vt, ldvt, work( ir ), ldwrkr ) + call stdlib${ii}$_${ci}$lacpy( 'L', n, n, vt, ldvt, work( ir ), ldwrkr ) ! generate left vectors bidiagonalizing r in work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & + call stdlib${ii}$_${ci}$ungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing r in vt ! (cworkspace: need n*n+3*n-1, prefer n*n+2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib${ii}$_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -12544,8 +12539,8 @@ module stdlib_linalg_lapack_${ci}$ ! singular vectors of r in vt ! (cworkspace: need n*n) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', n, n, n, 0, s, rwork( ie ), vt,ldvt, work( ir ), & - ldwrkr, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', n, n, n, 0_${ik}$, s, rwork( ie ), vt,ldvt, work( ir ), & + ldwrkr, cdum, 1_${ik}$,rwork( irwork ), info ) iu = itauq ! multiply q in a by left singular vectors of r in ! work(ir), storing result in work(iu) and copying to a @@ -12553,47 +12548,47 @@ module stdlib_linalg_lapack_${ci}$ ! (rworkspace: 0) do i = 1, m, ldwrku chunk = min( m-i+1, ldwrku ) - call stdlib_${ci}$gemm( 'N', 'N', chunk, n, n, cone, a( i, 1 ),lda, work( ir & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', chunk, n, n, cone, a( i, 1_${ik}$ ),lda, work( ir & ), ldwrkr, czero,work( iu ), ldwrku ) - call stdlib_${ci}$lacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) + call stdlib${ii}$_${ci}$lacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1_${ik}$ ), lda ) end do else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy r to vt, zeroing out below it - call stdlib_${ci}$lacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,vt( 2, 1 ), ldvt ) + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1_${ik}$ )call stdlib${ii}$_${ci}$laset( 'L', n-1, n-1, czero, czero,vt( 2_${ik}$, 1_${ik}$ ), ldvt ) ! generate q in a ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$ungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in vt ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: n) - call stdlib_${ci}$gebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_${ci}$gebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in a by left vectors bidiagonalizing r ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$unmbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), a, lda,& + call stdlib${ii}$_${ci}$unmbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), a, lda,& work( iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing r in vt ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib${ii}$_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -12601,8 +12596,8 @@ module stdlib_linalg_lapack_${ci}$ ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', n, n, m, 0, s, rwork( ie ), vt,ldvt, a, lda, cdum,& - 1, rwork( irwork ),info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', n, n, m, 0_${ik}$, s, rwork( ie ), vt,ldvt, a, lda, cdum,& + 1_${ik}$, rwork( irwork ),info ) end if else if( wntus ) then if( wntvn ) then @@ -12611,7 +12606,7 @@ module stdlib_linalg_lapack_${ci}$ ! no right singular vectors to be computed if( lwork>=n*n+3*n ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=wrkbl+lda*n ) then ! work(ir) is lda by n ldwrkr = lda @@ -12624,93 +12619,93 @@ module stdlib_linalg_lapack_${ci}$ ! compute a=q*r ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(ir), zeroing out below it - call stdlib_${ci}$lacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) - call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,work( ir+1 ), ldwrkr ) + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) + call stdlib${ii}$_${ci}$laset( 'L', n-1, n-1, czero, czero,work( ir+1 ), ldwrkr ) ! generate q in a ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$ungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_${ci}$gebrd( n, n, work( ir ), ldwrkr, s,rwork( ie ), work( & + call stdlib${ii}$_${ci}$gebrd( n, n, work( ir ), ldwrkr, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing r in work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_${ci}$ungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) ! (cworkspace: need n*n) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', n, 0, n, 0, s, rwork( ie ), cdum,1, work( ir ),& - ldwrkr, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', n, 0_${ik}$, n, 0_${ik}$, s, rwork( ie ), cdum,1_${ik}$, work( ir ),& + ldwrkr, cdum, 1_${ik}$,rwork( irwork ), info ) ! multiply q in a by left singular vectors of r in ! work(ir), storing result in u ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_${ci}$gemm( 'N', 'N', m, n, n, cone, a, lda,work( ir ), ldwrkr, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', m, n, n, cone, a, lda,work( ir ), ldwrkr, & czero, u, ldu ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$ungqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! zero out below r in a - if( n > 1 ) then - call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,a( 2, 1 ), lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_${ci}$laset( 'L', n-1, n-1, czero, czero,a( 2_${ik}$, 1_${ik}$ ), lda ) end if ! bidiagonalize r in a ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_${ci}$gebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_${ci}$gebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left vectors bidiagonalizing r ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$unmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib${ii}$_${ci}$unmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', n, 0, m, 0, s, rwork( ie ), cdum,1, u, ldu, & - cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', n, 0_${ik}$, m, 0_${ik}$, s, rwork( ie ), cdum,1_${ik}$, u, ldu, & + cdum, 1_${ik}$, rwork( irwork ),info ) end if else if( wntvo ) then ! path 5 (m much larger than n, jobu='s', jobvt='o') ! n left singular vectors to be computed in u and ! n right singular vectors to be overwritten on a - if( lwork>=2*n*n+3*n ) then + if( lwork>=2_${ik}$*n*n+3*n ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+2*lda*n ) then ! work(iu) is lda by n and work(ir) is lda by n ldwrku = lda @@ -12732,18 +12727,18 @@ module stdlib_linalg_lapack_${ci}$ ! compute a=q*r ! (cworkspace: need 2*n*n+2*n, prefer 2*n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_${ci}$lacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_${ci}$laset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) ! generate q in a ! (cworkspace: need 2*n*n+2*n, prefer 2*n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$ungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n @@ -12752,20 +12747,20 @@ module stdlib_linalg_lapack_${ci}$ ! (cworkspace: need 2*n*n+3*n, ! prefer 2*n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_${ci}$gebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib${ii}$_${ci}$gebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate left bidiagonalizing vectors in work(iu) ! (cworkspace: need 2*n*n+3*n, prefer 2*n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib${ii}$_${ci}$ungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in work(ir) ! (cworkspace: need 2*n*n+3*n-1, ! prefer 2*n*n+2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_${ci}$ungbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -12773,56 +12768,56 @@ module stdlib_linalg_lapack_${ci}$ ! right singular vectors of r in work(ir) ! (cworkspace: need 2*n*n) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', n, n, n, 0, s, rwork( ie ),work( ir ), ldwrkr, & - work( iu ),ldwrku, cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', n, n, n, 0_${ik}$, s, rwork( ie ),work( ir ), ldwrkr, & + work( iu ),ldwrku, cdum, 1_${ik}$, rwork( irwork ),info ) ! multiply q in a by left singular vectors of r in ! work(iu), storing result in u ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_${ci}$gemm( 'N', 'N', m, n, n, cone, a, lda,work( iu ), ldwrku, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', m, n, n, cone, a, lda,work( iu ), ldwrku, & czero, u, ldu ) ! copy right singular vectors of r to a ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_${ci}$lacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) + call stdlib${ii}$_${ci}$lacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$ungqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! zero out below r in a - if( n > 1 ) then - call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,a( 2, 1 ), lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_${ci}$laset( 'L', n-1, n-1, czero, czero,a( 2_${ik}$, 1_${ik}$ ), lda ) end if ! bidiagonalize r in a ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_${ci}$gebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_${ci}$gebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left vectors bidiagonalizing r ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$unmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib${ii}$_${ci}$unmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing r in a ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & + call stdlib${ii}$_${ci}$ungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -12830,8 +12825,8 @@ module stdlib_linalg_lapack_${ci}$ ! singular vectors of a in a ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', n, n, m, 0, s, rwork( ie ), a,lda, u, ldu, & - cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', n, n, m, 0_${ik}$, s, rwork( ie ), a,lda, u, ldu, & + cdum, 1_${ik}$, rwork( irwork ),info ) end if else if( wntvas ) then ! path 6 (m much larger than n, jobu='s', jobvt='s' @@ -12840,7 +12835,7 @@ module stdlib_linalg_lapack_${ci}$ ! n right singular vectors to be computed in vt if( lwork>=n*n+3*n ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+lda*n ) then ! work(iu) is lda by n ldwrku = lda @@ -12853,37 +12848,37 @@ module stdlib_linalg_lapack_${ci}$ ! compute a=q*r ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_${ci}$lacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_${ci}$laset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) ! generate q in a ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$ungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in work(iu), copying result to vt ! (cworkspace: need n*n+3*n, prefer n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_${ci}$gebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib${ii}$_${ci}$gebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) ! generate left bidiagonalizing vectors in work(iu) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib${ii}$_${ci}$ungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (cworkspace: need n*n+3*n-1, ! prefer n*n+2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib${ii}$_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -12891,52 +12886,52 @@ module stdlib_linalg_lapack_${ci}$ ! right singular vectors of r in vt ! (cworkspace: need n*n) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', n, n, n, 0, s, rwork( ie ), vt,ldvt, work( iu )& - , ldwrku, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', n, n, n, 0_${ik}$, s, rwork( ie ), vt,ldvt, work( iu )& + , ldwrku, cdum, 1_${ik}$,rwork( irwork ), info ) ! multiply q in a by left singular vectors of r in ! work(iu), storing result in u ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_${ci}$gemm( 'N', 'N', m, n, n, cone, a, lda,work( iu ), ldwrku, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', m, n, n, cone, a, lda,work( iu ), ldwrku, & czero, u, ldu ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$ungqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to vt, zeroing out below it - call stdlib_${ci}$lacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,vt( 2, 1 ), & + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1_${ik}$ )call stdlib${ii}$_${ci}$laset( 'L', n-1, n-1, czero, czero,vt( 2_${ik}$, 1_${ik}$ ), & ldvt ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in vt ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_${ci}$gebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_${ci}$gebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in vt ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$unmbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & + call stdlib${ii}$_${ci}$unmbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib${ii}$_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -12944,8 +12939,8 @@ module stdlib_linalg_lapack_${ci}$ ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', n, n, m, 0, s, rwork( ie ), vt,ldvt, u, ldu, & - cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', n, n, m, 0_${ik}$, s, rwork( ie ), vt,ldvt, u, ldu, & + cdum, 1_${ik}$,rwork( irwork ), info ) end if end if else if( wntua ) then @@ -12953,9 +12948,9 @@ module stdlib_linalg_lapack_${ci}$ ! path 7 (m much larger than n, jobu='a', jobvt='n') ! m left singular vectors to be computed in u and ! no right singular vectors to be computed - if( lwork>=n*n+max( n+m, 3*n ) ) then + if( lwork>=n*n+max( n+m, 3_${ik}$*n ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=wrkbl+lda*n ) then ! work(ir) is lda by n ldwrkr = lda @@ -12968,97 +12963,97 @@ module stdlib_linalg_lapack_${ci}$ ! compute a=q*r, copying result to u ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) ! copy r to work(ir), zeroing out below it - call stdlib_${ci}$lacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) - call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,work( ir+1 ), ldwrkr ) + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) + call stdlib${ii}$_${ci}$laset( 'L', n-1, n-1, czero, czero,work( ir+1 ), ldwrkr ) ! generate q in u ! (cworkspace: need n*n+n+m, prefer n*n+n+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$ungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_${ci}$gebrd( n, n, work( ir ), ldwrkr, s,rwork( ie ), work( & + call stdlib${ii}$_${ci}$gebrd( n, n, work( ir ), ldwrkr, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_${ci}$ungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) ! (cworkspace: need n*n) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', n, 0, n, 0, s, rwork( ie ), cdum,1, work( ir ),& - ldwrkr, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', n, 0_${ik}$, n, 0_${ik}$, s, rwork( ie ), cdum,1_${ik}$, work( ir ),& + ldwrkr, cdum, 1_${ik}$,rwork( irwork ), info ) ! multiply q in u by left singular vectors of r in ! work(ir), storing result in a ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_${ci}$gemm( 'N', 'N', m, n, n, cone, u, ldu,work( ir ), ldwrkr, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', m, n, n, cone, u, ldu,work( ir ), ldwrkr, & czero, a, lda ) ! copy left singular vectors of a from a to u - call stdlib_${ci}$lacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, n, a, lda, u, ldu ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need n+m, prefer n+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$ungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! zero out below r in a - if( n > 1 ) then - call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,a( 2, 1 ), lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_${ci}$laset( 'L', n-1, n-1, czero, czero,a( 2_${ik}$, 1_${ik}$ ), lda ) end if ! bidiagonalize r in a ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_${ci}$gebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_${ci}$gebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in a ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$unmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib${ii}$_${ci}$unmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', n, 0, m, 0, s, rwork( ie ), cdum,1, u, ldu, & - cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', n, 0_${ik}$, m, 0_${ik}$, s, rwork( ie ), cdum,1_${ik}$, u, ldu, & + cdum, 1_${ik}$, rwork( irwork ),info ) end if else if( wntvo ) then ! path 8 (m much larger than n, jobu='a', jobvt='o') ! m left singular vectors to be computed in u and ! n right singular vectors to be overwritten on a - if( lwork>=2*n*n+max( n+m, 3*n ) ) then + if( lwork>=2_${ik}$*n*n+max( n+m, 3_${ik}$*n ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+2*lda*n ) then ! work(iu) is lda by n and work(ir) is lda by n ldwrku = lda @@ -13080,19 +13075,19 @@ module stdlib_linalg_lapack_${ci}$ ! compute a=q*r, copying result to u ! (cworkspace: need 2*n*n+2*n, prefer 2*n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need 2*n*n+n+m, prefer 2*n*n+n+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$ungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_${ci}$lacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_${ci}$laset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n @@ -13101,20 +13096,20 @@ module stdlib_linalg_lapack_${ci}$ ! (cworkspace: need 2*n*n+3*n, ! prefer 2*n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_${ci}$gebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib${ii}$_${ci}$gebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate left bidiagonalizing vectors in work(iu) ! (cworkspace: need 2*n*n+3*n, prefer 2*n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib${ii}$_${ci}$ungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in work(ir) ! (cworkspace: need 2*n*n+3*n-1, ! prefer 2*n*n+2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_${ci}$ungbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -13122,57 +13117,57 @@ module stdlib_linalg_lapack_${ci}$ ! right singular vectors of r in work(ir) ! (cworkspace: need 2*n*n) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', n, n, n, 0, s, rwork( ie ),work( ir ), ldwrkr, & - work( iu ),ldwrku, cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', n, n, n, 0_${ik}$, s, rwork( ie ),work( ir ), ldwrkr, & + work( iu ),ldwrku, cdum, 1_${ik}$, rwork( irwork ),info ) ! multiply q in u by left singular vectors of r in ! work(iu), storing result in a ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_${ci}$gemm( 'N', 'N', m, n, n, cone, u, ldu,work( iu ), ldwrku, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', m, n, n, cone, u, ldu,work( iu ), ldwrku, & czero, a, lda ) ! copy left singular vectors of a from a to u - call stdlib_${ci}$lacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, n, a, lda, u, ldu ) ! copy right singular vectors of r from work(ir) to a - call stdlib_${ci}$lacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) + call stdlib${ii}$_${ci}$lacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need n+m, prefer n+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$ungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! zero out below r in a - if( n > 1 ) then - call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,a( 2, 1 ), lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_${ci}$laset( 'L', n-1, n-1, czero, czero,a( 2_${ik}$, 1_${ik}$ ), lda ) end if ! bidiagonalize r in a ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_${ci}$gebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_${ci}$gebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in a ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$unmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib${ii}$_${ci}$unmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in a ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & + call stdlib${ii}$_${ci}$ungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -13180,17 +13175,17 @@ module stdlib_linalg_lapack_${ci}$ ! singular vectors of a in a ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', n, n, m, 0, s, rwork( ie ), a,lda, u, ldu, & - cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', n, n, m, 0_${ik}$, s, rwork( ie ), a,lda, u, ldu, & + cdum, 1_${ik}$, rwork( irwork ),info ) end if else if( wntvas ) then ! path 9 (m much larger than n, jobu='a', jobvt='s' ! or 'a') ! m left singular vectors to be computed in u and ! n right singular vectors to be computed in vt - if( lwork>=n*n+max( n+m, 3*n ) ) then + if( lwork>=n*n+max( n+m, 3_${ik}$*n ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+lda*n ) then ! work(iu) is lda by n ldwrku = lda @@ -13203,38 +13198,38 @@ module stdlib_linalg_lapack_${ci}$ ! compute a=q*r, copying result to u ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need n*n+n+m, prefer n*n+n+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$ungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_${ci}$lacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_${ci}$laset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in work(iu), copying result to vt ! (cworkspace: need n*n+3*n, prefer n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_${ci}$gebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib${ii}$_${ci}$gebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) ! generate left bidiagonalizing vectors in work(iu) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib${ii}$_${ci}$ungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (cworkspace: need n*n+3*n-1, ! prefer n*n+2*n+(n-1)*nb) ! (rworkspace: need 0) - call stdlib_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib${ii}$_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -13242,54 +13237,54 @@ module stdlib_linalg_lapack_${ci}$ ! right singular vectors of r in vt ! (cworkspace: need n*n) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', n, n, n, 0, s, rwork( ie ), vt,ldvt, work( iu )& - , ldwrku, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', n, n, n, 0_${ik}$, s, rwork( ie ), vt,ldvt, work( iu )& + , ldwrku, cdum, 1_${ik}$,rwork( irwork ), info ) ! multiply q in u by left singular vectors of r in ! work(iu), storing result in a ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_${ci}$gemm( 'N', 'N', m, n, n, cone, u, ldu,work( iu ), ldwrku, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', m, n, n, cone, u, ldu,work( iu ), ldwrku, & czero, a, lda ) ! copy left singular vectors of a from a to u - call stdlib_${ci}$lacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, n, a, lda, u, ldu ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$geqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need n+m, prefer n+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$ungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r from a to vt, zeroing out below it - call stdlib_${ci}$lacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_${ci}$laset( 'L', n-1, n-1, czero, czero,vt( 2, 1 ), & + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1_${ik}$ )call stdlib${ii}$_${ci}$laset( 'L', n-1, n-1, czero, czero,vt( 2_${ik}$, 1_${ik}$ ), & ldvt ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in vt ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_${ci}$gebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_${ci}$gebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in vt ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$unmbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & + call stdlib${ii}$_${ci}$unmbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib${ii}$_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -13297,8 +13292,8 @@ module stdlib_linalg_lapack_${ci}$ ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', n, n, m, 0, s, rwork( ie ), vt,ldvt, u, ldu, & - cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', n, n, m, 0_${ik}$, s, rwork( ie ), vt,ldvt, u, ldu, & + cdum, 1_${ik}$,rwork( irwork ), info ) end if end if end if @@ -13306,24 +13301,24 @@ module stdlib_linalg_lapack_${ci}$ ! m < mnthr ! path 10 (m at least n, but not much larger) ! reduce to bidiagonal form without qr decomposition - ie = 1 - itauq = 1 + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + n iwork = itaup + n ! bidiagonalize a ! (cworkspace: need 2*n+m, prefer 2*n+(m+n)*nb) ! (rworkspace: need n) - call stdlib_${ci}$gebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_${ci}$gebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,ierr ) if( wntuas ) then ! if left singular vectors desired in u, copy result to u ! and generate left bidiagonalizing vectors in u ! (cworkspace: need 2*n+ncu, prefer 2*n+ncu*nb) ! (rworkspace: 0) - call stdlib_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$lacpy( 'L', m, n, a, lda, u, ldu ) if( wntus )ncu = n if( wntua )ncu = m - call stdlib_${ci}$ungbr( 'Q', m, ncu, n, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_${ci}$ungbr( 'Q', m, ncu, n, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) end if if( wntvas ) then @@ -13331,8 +13326,8 @@ module stdlib_linalg_lapack_${ci}$ ! vt and generate right bidiagonalizing vectors in vt ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_${ci}$lacpy( 'U', n, n, a, lda, vt, ldvt ) - call stdlib_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$ungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) end if if( wntuo ) then @@ -13340,7 +13335,7 @@ module stdlib_linalg_lapack_${ci}$ ! bidiagonalizing vectors in a ! (cworkspace: need 3*n, prefer 2*n+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$ungbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), lwork-& iwork+1, ierr ) end if if( wntvo ) then @@ -13348,38 +13343,38 @@ module stdlib_linalg_lapack_${ci}$ ! bidiagonalizing vectors in a ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$ungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-& iwork+1, ierr ) end if irwork = ie + n if( wntuas .or. wntuo )nru = m - if( wntun )nru = 0 + if( wntun )nru = 0_${ik}$ if( wntvas .or. wntvo )ncvt = n - if( wntvn )ncvt = 0 + if( wntvn )ncvt = 0_${ik}$ if( ( .not.wntuo ) .and. ( .not.wntvo ) ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', n, ncvt, nru, 0, s, rwork( ie ), vt,ldvt, u, ldu, & - cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', n, ncvt, nru, 0_${ik}$, s, rwork( ie ), vt,ldvt, u, ldu, & + cdum, 1_${ik}$, rwork( irwork ),info ) else if( ( .not.wntuo ) .and. wntvo ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in a ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', n, ncvt, nru, 0, s, rwork( ie ), a,lda, u, ldu, cdum,& - 1, rwork( irwork ),info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', n, ncvt, nru, 0_${ik}$, s, rwork( ie ), a,lda, u, ldu, cdum,& + 1_${ik}$, rwork( irwork ),info ) else ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in a and computing right singular ! vectors in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', n, ncvt, nru, 0, s, rwork( ie ), vt,ldvt, a, lda, & - cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', n, ncvt, nru, 0_${ik}$, s, rwork( ie ), vt,ldvt, a, lda, & + cdum, 1_${ik}$, rwork( irwork ),info ) end if end if else @@ -13390,49 +13385,49 @@ module stdlib_linalg_lapack_${ci}$ if( wntvn ) then ! path 1t(n much larger than m, jobvt='n') ! no right singular vectors to be computed - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & ierr ) ! zero out above l - if (m>1) call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero, a( 1, 2 ),lda ) - ie = 1 - itauq = 1 + if (m>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'U', m-1, m-1, czero, czero, a( 1_${ik}$, 2_${ik}$ ),lda ) + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + m iwork = itaup + m ! bidiagonalize l in a ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_${ci}$gebrd( m, m, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& + call stdlib${ii}$_${ci}$gebrd( m, m, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& work( iwork ), lwork-iwork+1,ierr ) if( wntuo .or. wntuas ) then ! if left singular vectors desired, generate q ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & + call stdlib${ii}$_${ci}$ungbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) end if irwork = ie + m - nru = 0 + nru = 0_${ik}$ if( wntuo .or. wntuas )nru = m ! perform bidiagonal qr iteration, computing left singular ! vectors of a in a if desired ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', m, 0, nru, 0, s, rwork( ie ), cdum, 1,a, lda, cdum, & - 1, rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', m, 0_${ik}$, nru, 0_${ik}$, s, rwork( ie ), cdum, 1_${ik}$,a, lda, cdum, & + 1_${ik}$, rwork( irwork ), info ) ! if left singular vectors desired in u, copy them there - if( wntuas )call stdlib_${ci}$lacpy( 'F', m, m, a, lda, u, ldu ) + if( wntuas )call stdlib${ii}$_${ci}$lacpy( 'F', m, m, a, lda, u, ldu ) else if( wntvo .and. wntun ) then ! path 2t(n much larger than m, jobu='n', jobvt='o') ! m right singular vectors to be overwritten on a and ! no left singular vectors to be computed if( lwork>=m*m+3*m ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=max( wrkbl, lda*n )+lda*m ) then ! work(iu) is lda by n and work(ir) is lda by m ldwrku = lda @@ -13454,38 +13449,38 @@ module stdlib_linalg_lapack_${ci}$ ! compute a=l*q ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy l to work(ir) and zero out above it - call stdlib_${ci}$lacpy( 'L', m, m, a, lda, work( ir ), ldwrkr ) - call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,work( ir+ldwrkr ), ldwrkr ) + call stdlib${ii}$_${ci}$lacpy( 'L', m, m, a, lda, work( ir ), ldwrkr ) + call stdlib${ii}$_${ci}$laset( 'U', m-1, m-1, czero, czero,work( ir+ldwrkr ), ldwrkr ) ! generate q in a ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$unglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$unglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in work(ir) ! (cworkspace: need m*m+3*m, prefer m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_${ci}$gebrd( m, m, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ),& + call stdlib${ii}$_${ci}$gebrd( m, m, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ),& work( itaup ),work( iwork ), lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing l ! (cworkspace: need m*m+3*m-1, prefer m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & + call stdlib${ii}$_${ci}$ungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & iwork ),lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of l in work(ir) ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', m, m, 0, 0, s, rwork( ie ),work( ir ), ldwrkr, & - cdum, 1, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', m, m, 0_${ik}$, 0_${ik}$, s, rwork( ie ),work( ir ), ldwrkr, & + cdum, 1_${ik}$, cdum, 1_${ik}$,rwork( irwork ), info ) iu = itauq ! multiply right singular vectors of l in work(ir) by q ! in a, storing result in work(iu) and copying to a @@ -13493,34 +13488,34 @@ module stdlib_linalg_lapack_${ci}$ ! (rworkspace: 0) do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_${ci}$gemm( 'N', 'N', m, blk, m, cone, work( ir ),ldwrkr, a( 1, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', m, blk, m, cone, work( ir ),ldwrkr, a( 1_${ik}$, & i ), lda, czero,work( iu ), ldwrku ) - call stdlib_${ci}$lacpy( 'F', m, blk, work( iu ), ldwrku,a( 1, i ), lda ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, blk, work( iu ), ldwrku,a( 1_${ik}$, i ), lda ) end do else ! insufficient workspace for a fast algorithm - ie = 1 - itauq = 1 + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + m iwork = itaup + m ! bidiagonalize a ! (cworkspace: need 2*m+n, prefer 2*m+(m+n)*nb) ! (rworkspace: need m) - call stdlib_${ci}$gebrd( m, n, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_${ci}$gebrd( m, n, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing a ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), & + call stdlib${ii}$_${ci}$ungbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of a in a ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'L', m, n, 0, 0, s, rwork( ie ), a, lda,cdum, 1, cdum, & - 1, rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'L', m, n, 0_${ik}$, 0_${ik}$, s, rwork( ie ), a, lda,cdum, 1_${ik}$, cdum, & + 1_${ik}$, rwork( irwork ), info ) end if else if( wntvo .and. wntuas ) then ! path 3t(n much larger than m, jobu='s' or 'a', jobvt='o') @@ -13528,7 +13523,7 @@ module stdlib_linalg_lapack_${ci}$ ! m left singular vectors to be computed in u if( lwork>=m*m+3*m ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=max( wrkbl, lda*n )+lda*m ) then ! work(iu) is lda by n and work(ir) is lda by m ldwrku = lda @@ -13550,35 +13545,35 @@ module stdlib_linalg_lapack_${ci}$ ! compute a=l*q ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy l to u, zeroing about above it - call stdlib_${ci}$lacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero, u( 1, 2 ),ldu ) + call stdlib${ii}$_${ci}$lacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'U', m-1, m-1, czero, czero, u( 1_${ik}$, 2_${ik}$ ),ldu ) ! generate q in a ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$unglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$unglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in u, copying result to work(ir) ! (cworkspace: need m*m+3*m, prefer m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_${ci}$gebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_${ci}$gebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'U', m, m, u, ldu, work( ir ), ldwrkr ) + call stdlib${ii}$_${ci}$lacpy( 'U', m, m, u, ldu, work( ir ), ldwrkr ) ! generate right vectors bidiagonalizing l in work(ir) ! (cworkspace: need m*m+3*m-1, prefer m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & + call stdlib${ii}$_${ci}$ungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & iwork ),lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing l in u ! (cworkspace: need m*m+3*m, prefer m*m+2*m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_${ci}$ungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -13586,8 +13581,8 @@ module stdlib_linalg_lapack_${ci}$ ! singular vectors of l in work(ir) ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( ir ), ldwrkr, u, & - ldu, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', m, m, m, 0_${ik}$, s, rwork( ie ),work( ir ), ldwrkr, u, & + ldu, cdum, 1_${ik}$,rwork( irwork ), info ) iu = itauq ! multiply right singular vectors of l in work(ir) by q ! in a, storing result in work(iu) and copying to a @@ -13595,46 +13590,46 @@ module stdlib_linalg_lapack_${ci}$ ! (rworkspace: 0) do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_${ci}$gemm( 'N', 'N', m, blk, m, cone, work( ir ),ldwrkr, a( 1, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', m, blk, m, cone, work( ir ),ldwrkr, a( 1_${ik}$, & i ), lda, czero,work( iu ), ldwrku ) - call stdlib_${ci}$lacpy( 'F', m, blk, work( iu ), ldwrku,a( 1, i ), lda ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, blk, work( iu ), ldwrku,a( 1_${ik}$, i ), lda ) end do else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy l to u, zeroing out above it - call stdlib_${ci}$lacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero, u( 1, 2 ),ldu ) + call stdlib${ii}$_${ci}$lacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'U', m-1, m-1, czero, czero, u( 1_${ik}$, 2_${ik}$ ),ldu ) ! generate q in a ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$unglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$unglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in u ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_${ci}$gebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_${ci}$gebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right vectors bidiagonalizing l by q in a ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$unmbr( 'P', 'L', 'C', m, n, m, u, ldu,work( itaup ), a, lda, & + call stdlib${ii}$_${ci}$unmbr( 'P', 'L', 'C', m, n, m, u, ldu,work( itaup ), a, lda, & work( iwork ),lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing l in u ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_${ci}$ungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -13642,8 +13637,8 @@ module stdlib_linalg_lapack_${ci}$ ! singular vectors of a in a ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', m, n, m, 0, s, rwork( ie ), a, lda,u, ldu, cdum, & - 1, rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', m, n, m, 0_${ik}$, s, rwork( ie ), a, lda,u, ldu, cdum, & + 1_${ik}$, rwork( irwork ), info ) end if else if( wntvs ) then if( wntun ) then @@ -13652,7 +13647,7 @@ module stdlib_linalg_lapack_${ci}$ ! no left singular vectors to be computed if( lwork>=m*m+3*m ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=wrkbl+lda*m ) then ! work(ir) is lda by m ldwrkr = lda @@ -13665,92 +13660,92 @@ module stdlib_linalg_lapack_${ci}$ ! compute a=l*q ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy l to work(ir), zeroing out above it - call stdlib_${ci}$lacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) - call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,work( ir+ldwrkr ), & + call stdlib${ii}$_${ci}$lacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) + call stdlib${ii}$_${ci}$laset( 'U', m-1, m-1, czero, czero,work( ir+ldwrkr ), & ldwrkr ) ! generate q in a ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$unglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$unglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in work(ir) ! (cworkspace: need m*m+3*m, prefer m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_${ci}$gebrd( m, m, work( ir ), ldwrkr, s,rwork( ie ), work( & + call stdlib${ii}$_${ci}$gebrd( m, m, work( ir ), ldwrkr, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing l in ! work(ir) ! (cworkspace: need m*m+3*m, prefer m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_${ci}$ungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of l in work(ir) ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', m, m, 0, 0, s, rwork( ie ),work( ir ), ldwrkr, & - cdum, 1, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', m, m, 0_${ik}$, 0_${ik}$, s, rwork( ie ),work( ir ), ldwrkr, & + cdum, 1_${ik}$, cdum, 1_${ik}$,rwork( irwork ), info ) ! multiply right singular vectors of l in work(ir) by ! q in a, storing result in vt ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_${ci}$gemm( 'N', 'N', m, n, m, cone, work( ir ),ldwrkr, a, lda, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', m, n, m, cone, work( ir ),ldwrkr, a, lda, & czero, vt, ldvt ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy result to vt - call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$unglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_${ci}$unglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda ) + if (m>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'U', m-1, m-1, czero, czero,a( 1_${ik}$, 2_${ik}$ ), lda ) ! bidiagonalize l in a ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_${ci}$gebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_${ci}$gebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right vectors bidiagonalizing l by q in vt ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$unmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & + call stdlib${ii}$_${ci}$unmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', m, n, 0, 0, s, rwork( ie ), vt,ldvt, cdum, 1, & - cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', m, n, 0_${ik}$, 0_${ik}$, s, rwork( ie ), vt,ldvt, cdum, 1_${ik}$, & + cdum, 1_${ik}$,rwork( irwork ), info ) end if else if( wntuo ) then ! path 5t(n much larger than m, jobu='o', jobvt='s') ! m right singular vectors to be computed in vt and ! m left singular vectors to be overwritten on a - if( lwork>=2*m*m+3*m ) then + if( lwork>=2_${ik}$*m*m+3*m ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+2*lda*m ) then ! work(iu) is lda by m and work(ir) is lda by m ldwrku = lda @@ -13772,18 +13767,18 @@ module stdlib_linalg_lapack_${ci}$ ! compute a=l*q ! (cworkspace: need 2*m*m+2*m, prefer 2*m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy l to work(iu), zeroing out below it - call stdlib_${ci}$lacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & + call stdlib${ii}$_${ci}$lacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_${ci}$laset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & ldwrku ) ! generate q in a ! (cworkspace: need 2*m*m+2*m, prefer 2*m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$unglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$unglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m @@ -13792,20 +13787,20 @@ module stdlib_linalg_lapack_${ci}$ ! (cworkspace: need 2*m*m+3*m, ! prefer 2*m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_${ci}$gebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib${ii}$_${ci}$gebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib${ii}$_${ci}$lacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate right bidiagonalizing vectors in work(iu) ! (cworkspace: need 2*m*m+3*m-1, ! prefer 2*m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib${ii}$_${ci}$ungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in work(ir) ! (cworkspace: need 2*m*m+3*m, prefer 2*m*m+2*m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_${ci}$ungbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -13813,53 +13808,53 @@ module stdlib_linalg_lapack_${ci}$ ! right singular vectors of l in work(iu) ! (cworkspace: need 2*m*m) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( iu ), ldwrku, & - work( ir ),ldwrkr, cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', m, m, m, 0_${ik}$, s, rwork( ie ),work( iu ), ldwrku, & + work( ir ),ldwrkr, cdum, 1_${ik}$, rwork( irwork ),info ) ! multiply right singular vectors of l in work(iu) by ! q in a, storing result in vt ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_${ci}$gemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, a, lda, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, a, lda, & czero, vt, ldvt ) ! copy left singular vectors of l to a ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_${ci}$lacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$unglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_${ci}$unglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda ) + if (m>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'U', m-1, m-1, czero, czero,a( 1_${ik}$, 2_${ik}$ ), lda ) ! bidiagonalize l in a ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_${ci}$gebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_${ci}$gebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right vectors bidiagonalizing l by q in vt ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$unmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & + call stdlib${ii}$_${ci}$unmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors of l in a ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & + call stdlib${ii}$_${ci}$ungbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -13867,8 +13862,8 @@ module stdlib_linalg_lapack_${ci}$ ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', m, n, m, 0, s, rwork( ie ), vt,ldvt, a, lda, & - cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', m, n, m, 0_${ik}$, s, rwork( ie ), vt,ldvt, a, lda, & + cdum, 1_${ik}$,rwork( irwork ), info ) end if else if( wntuas ) then ! path 6t(n much larger than m, jobu='s' or 'a', @@ -13877,7 +13872,7 @@ module stdlib_linalg_lapack_${ci}$ ! m left singular vectors to be computed in u if( lwork>=m*m+3*m ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+lda*m ) then ! work(iu) is lda by n ldwrku = lda @@ -13890,37 +13885,37 @@ module stdlib_linalg_lapack_${ci}$ ! compute a=l*q ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy l to work(iu), zeroing out above it - call stdlib_${ci}$lacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & + call stdlib${ii}$_${ci}$lacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_${ci}$laset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & ldwrku ) ! generate q in a ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$unglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$unglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in work(iu), copying result to u ! (cworkspace: need m*m+3*m, prefer m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_${ci}$gebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib${ii}$_${ci}$gebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) + call stdlib${ii}$_${ci}$lacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) ! generate right bidiagonalizing vectors in work(iu) ! (cworkspace: need m*m+3*m-1, ! prefer m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib${ii}$_${ci}$ungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (cworkspace: need m*m+3*m, prefer m*m+2*m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_${ci}$ungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -13928,51 +13923,51 @@ module stdlib_linalg_lapack_${ci}$ ! singular vectors of l in work(iu) ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( iu ), ldwrku, & - u, ldu, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', m, m, m, 0_${ik}$, s, rwork( ie ),work( iu ), ldwrku, & + u, ldu, cdum, 1_${ik}$,rwork( irwork ), info ) ! multiply right singular vectors of l in work(iu) by ! q in a, storing result in vt ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_${ci}$gemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, a, lda, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, a, lda, & czero, vt, ldvt ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$unglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_${ci}$unglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to u, zeroing out above it - call stdlib_${ci}$lacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,u( 1, 2 ), ldu ) - ie = 1 + call stdlib${ii}$_${ci}$lacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'U', m-1, m-1, czero, czero,u( 1_${ik}$, 2_${ik}$ ), ldu ) + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in u ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_${ci}$gebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_${ci}$gebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in u by q ! in vt ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$unmbr( 'P', 'L', 'C', m, n, m, u, ldu,work( itaup ), vt, & + call stdlib${ii}$_${ci}$unmbr( 'P', 'L', 'C', m, n, m, u, ldu,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_${ci}$ungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -13980,8 +13975,8 @@ module stdlib_linalg_lapack_${ci}$ ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', m, n, m, 0, s, rwork( ie ), vt,ldvt, u, ldu, & - cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', m, n, m, 0_${ik}$, s, rwork( ie ), vt,ldvt, u, ldu, & + cdum, 1_${ik}$,rwork( irwork ), info ) end if end if else if( wntva ) then @@ -13989,9 +13984,9 @@ module stdlib_linalg_lapack_${ci}$ ! path 7t(n much larger than m, jobu='n', jobvt='a') ! n right singular vectors to be computed in vt and ! no left singular vectors to be computed - if( lwork>=m*m+max( n+m, 3*m ) ) then + if( lwork>=m*m+max( n+m, 3_${ik}$*m ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=wrkbl+lda*m ) then ! work(ir) is lda by m ldwrkr = lda @@ -14004,95 +13999,95 @@ module stdlib_linalg_lapack_${ci}$ ! compute a=l*q, copying result to vt ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! copy l to work(ir), zeroing out above it - call stdlib_${ci}$lacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) - call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,work( ir+ldwrkr ), & + call stdlib${ii}$_${ci}$lacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) + call stdlib${ii}$_${ci}$laset( 'U', m-1, m-1, czero, czero,work( ir+ldwrkr ), & ldwrkr ) ! generate q in vt ! (cworkspace: need m*m+m+n, prefer m*m+m+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$unglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_${ci}$unglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in work(ir) ! (cworkspace: need m*m+3*m, prefer m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_${ci}$gebrd( m, m, work( ir ), ldwrkr, s,rwork( ie ), work( & + call stdlib${ii}$_${ci}$gebrd( m, m, work( ir ), ldwrkr, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in work(ir) ! (cworkspace: need m*m+3*m-1, ! prefer m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_${ci}$ungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of l in work(ir) ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', m, m, 0, 0, s, rwork( ie ),work( ir ), ldwrkr, & - cdum, 1, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', m, m, 0_${ik}$, 0_${ik}$, s, rwork( ie ),work( ir ), ldwrkr, & + cdum, 1_${ik}$, cdum, 1_${ik}$,rwork( irwork ), info ) ! multiply right singular vectors of l in work(ir) by ! q in vt, storing result in a ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_${ci}$gemm( 'N', 'N', m, n, m, cone, work( ir ),ldwrkr, vt, ldvt,& + call stdlib${ii}$_${ci}$gemm( 'N', 'N', m, n, m, cone, work( ir ),ldwrkr, vt, ldvt,& czero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_${ci}$lacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, n, a, lda, vt, ldvt ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need m+n, prefer m+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$unglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_${ci}$unglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda ) + if (m>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'U', m-1, m-1, czero, czero,a( 1_${ik}$, 2_${ik}$ ), lda ) ! bidiagonalize l in a ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_${ci}$gebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_${ci}$gebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in a by q ! in vt ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$unmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & + call stdlib${ii}$_${ci}$unmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', m, n, 0, 0, s, rwork( ie ), vt,ldvt, cdum, 1, & - cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', m, n, 0_${ik}$, 0_${ik}$, s, rwork( ie ), vt,ldvt, cdum, 1_${ik}$, & + cdum, 1_${ik}$,rwork( irwork ), info ) end if else if( wntuo ) then ! path 8t(n much larger than m, jobu='o', jobvt='a') ! n right singular vectors to be computed in vt and ! m left singular vectors to be overwritten on a - if( lwork>=2*m*m+max( n+m, 3*m ) ) then + if( lwork>=2_${ik}$*m*m+max( n+m, 3_${ik}$*m ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+2*lda*m ) then ! work(iu) is lda by m and work(ir) is lda by m ldwrku = lda @@ -14114,19 +14109,19 @@ module stdlib_linalg_lapack_${ci}$ ! compute a=l*q, copying result to vt ! (cworkspace: need 2*m*m+2*m, prefer 2*m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need 2*m*m+m+n, prefer 2*m*m+m+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$unglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_${ci}$unglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to work(iu), zeroing out above it - call stdlib_${ci}$lacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & + call stdlib${ii}$_${ci}$lacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_${ci}$laset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & ldwrku ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m @@ -14135,20 +14130,20 @@ module stdlib_linalg_lapack_${ci}$ ! (cworkspace: need 2*m*m+3*m, ! prefer 2*m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_${ci}$gebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib${ii}$_${ci}$gebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib${ii}$_${ci}$lacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate right bidiagonalizing vectors in work(iu) ! (cworkspace: need 2*m*m+3*m-1, ! prefer 2*m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib${ii}$_${ci}$ungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in work(ir) ! (cworkspace: need 2*m*m+3*m, prefer 2*m*m+2*m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_${ci}$ungbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -14156,54 +14151,54 @@ module stdlib_linalg_lapack_${ci}$ ! right singular vectors of l in work(iu) ! (cworkspace: need 2*m*m) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( iu ), ldwrku, & - work( ir ),ldwrkr, cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', m, m, m, 0_${ik}$, s, rwork( ie ),work( iu ), ldwrku, & + work( ir ),ldwrkr, cdum, 1_${ik}$, rwork( irwork ),info ) ! multiply right singular vectors of l in work(iu) by ! q in vt, storing result in a ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_${ci}$gemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, vt, ldvt,& + call stdlib${ii}$_${ci}$gemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, vt, ldvt,& czero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_${ci}$lacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, n, a, lda, vt, ldvt ) ! copy left singular vectors of a from work(ir) to a - call stdlib_${ci}$lacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need m+n, prefer m+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$unglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_${ci}$unglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda ) + if (m>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'U', m-1, m-1, czero, czero,a( 1_${ik}$, 2_${ik}$ ), lda ) ! bidiagonalize l in a ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_${ci}$gebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_${ci}$gebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in a by q ! in vt ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$unmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & + call stdlib${ii}$_${ci}$unmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in a ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & + call stdlib${ii}$_${ci}$ungbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -14211,17 +14206,17 @@ module stdlib_linalg_lapack_${ci}$ ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', m, n, m, 0, s, rwork( ie ), vt,ldvt, a, lda, & - cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', m, n, m, 0_${ik}$, s, rwork( ie ), vt,ldvt, a, lda, & + cdum, 1_${ik}$,rwork( irwork ), info ) end if else if( wntuas ) then ! path 9t(n much larger than m, jobu='s' or 'a', ! jobvt='a') ! n right singular vectors to be computed in vt and ! m left singular vectors to be computed in u - if( lwork>=m*m+max( n+m, 3*m ) ) then + if( lwork>=m*m+max( n+m, 3_${ik}$*m ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+lda*m ) then ! work(iu) is lda by m ldwrku = lda @@ -14234,37 +14229,37 @@ module stdlib_linalg_lapack_${ci}$ ! compute a=l*q, copying result to vt ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need m*m+m+n, prefer m*m+m+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$unglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_${ci}$unglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to work(iu), zeroing out above it - call stdlib_${ci}$lacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & + call stdlib${ii}$_${ci}$lacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_${ci}$laset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & ldwrku ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in work(iu), copying result to u ! (cworkspace: need m*m+3*m, prefer m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_${ci}$gebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib${ii}$_${ci}$gebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) + call stdlib${ii}$_${ci}$lacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) ! generate right bidiagonalizing vectors in work(iu) ! (cworkspace: need m*m+3*m, prefer m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib${ii}$_${ci}$ungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (cworkspace: need m*m+3*m, prefer m*m+2*m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_${ci}$ungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -14272,53 +14267,53 @@ module stdlib_linalg_lapack_${ci}$ ! singular vectors of l in work(iu) ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( iu ), ldwrku, & - u, ldu, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', m, m, m, 0_${ik}$, s, rwork( ie ),work( iu ), ldwrku, & + u, ldu, cdum, 1_${ik}$,rwork( irwork ), info ) ! multiply right singular vectors of l in work(iu) by ! q in vt, storing result in a ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_${ci}$gemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, vt, ldvt,& + call stdlib${ii}$_${ci}$gemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, vt, ldvt,& czero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_${ci}$lacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, n, a, lda, vt, ldvt ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$gelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need m+n, prefer m+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$unglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_${ci}$unglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to u, zeroing out above it - call stdlib_${ci}$lacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_${ci}$laset( 'U', m-1, m-1, czero, czero,u( 1, 2 ), ldu ) - ie = 1 + call stdlib${ii}$_${ci}$lacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1_${ik}$) call stdlib${ii}$_${ci}$laset( 'U', m-1, m-1, czero, czero,u( 1_${ik}$, 2_${ik}$ ), ldu ) + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in u ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_${ci}$gebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_${ci}$gebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in u by q ! in vt ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_${ci}$unmbr( 'P', 'L', 'C', m, n, m, u, ldu,work( itaup ), vt, & + call stdlib${ii}$_${ci}$unmbr( 'P', 'L', 'C', m, n, m, u, ldu,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_${ci}$ungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -14326,8 +14321,8 @@ module stdlib_linalg_lapack_${ci}$ ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'U', m, n, m, 0, s, rwork( ie ), vt,ldvt, u, ldu, & - cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_${ci}$bdsqr( 'U', m, n, m, 0_${ik}$, s, rwork( ie ), vt,ldvt, u, ldu, & + cdum, 1_${ik}$,rwork( irwork ), info ) end if end if end if @@ -14335,22 +14330,22 @@ module stdlib_linalg_lapack_${ci}$ ! n < mnthr ! path 10t(n greater than m, but not much larger) ! reduce to bidiagonal form without lq decomposition - ie = 1 - itauq = 1 + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + m iwork = itaup + m ! bidiagonalize a ! (cworkspace: need 2*m+n, prefer 2*m+(m+n)*nb) ! (rworkspace: m) - call stdlib_${ci}$gebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_${ci}$gebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,ierr ) if( wntuas ) then ! if left singular vectors desired in u, copy result to u ! and generate left bidiagonalizing vectors in u ! (cworkspace: need 3*m-1, prefer 2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_${ci}$lacpy( 'L', m, m, a, lda, u, ldu ) - call stdlib_${ci}$ungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$lacpy( 'L', m, m, a, lda, u, ldu ) + call stdlib${ii}$_${ci}$ungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( iwork ), lwork-& iwork+1, ierr ) end if if( wntvas ) then @@ -14358,10 +14353,10 @@ module stdlib_linalg_lapack_${ci}$ ! vt and generate right bidiagonalizing vectors in vt ! (cworkspace: need 2*m+nrvt, prefer 2*m+nrvt*nb) ! (rworkspace: 0) - call stdlib_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_${ci}$lacpy( 'U', m, n, a, lda, vt, ldvt ) if( wntva )nrvt = n if( wntvs )nrvt = m - call stdlib_${ci}$ungbr( 'P', nrvt, n, m, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib${ii}$_${ci}$ungbr( 'P', nrvt, n, m, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) end if if( wntuo ) then @@ -14369,7 +14364,7 @@ module stdlib_linalg_lapack_${ci}$ ! bidiagonalizing vectors in a ! (cworkspace: need 3*m-1, prefer 2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'Q', m, m, n, a, lda, work( itauq ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$ungbr( 'Q', m, m, n, a, lda, work( itauq ),work( iwork ), lwork-& iwork+1, ierr ) end if if( wntvo ) then @@ -14377,59 +14372,59 @@ module stdlib_linalg_lapack_${ci}$ ! bidiagonalizing vectors in a ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_${ci}$ungbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-& + call stdlib${ii}$_${ci}$ungbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-& iwork+1, ierr ) end if irwork = ie + m if( wntuas .or. wntuo )nru = m - if( wntun )nru = 0 + if( wntun )nru = 0_${ik}$ if( wntvas .or. wntvo )ncvt = n - if( wntvn )ncvt = 0 + if( wntvn )ncvt = 0_${ik}$ if( ( .not.wntuo ) .and. ( .not.wntvo ) ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'L', m, ncvt, nru, 0, s, rwork( ie ), vt,ldvt, u, ldu, & - cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_${ci}$bdsqr( 'L', m, ncvt, nru, 0_${ik}$, s, rwork( ie ), vt,ldvt, u, ldu, & + cdum, 1_${ik}$, rwork( irwork ),info ) else if( ( .not.wntuo ) .and. wntvo ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in a ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'L', m, ncvt, nru, 0, s, rwork( ie ), a,lda, u, ldu, cdum,& - 1, rwork( irwork ),info ) + call stdlib${ii}$_${ci}$bdsqr( 'L', m, ncvt, nru, 0_${ik}$, s, rwork( ie ), a,lda, u, ldu, cdum,& + 1_${ik}$, rwork( irwork ),info ) else ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in a and computing right singular ! vectors in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_${ci}$bdsqr( 'L', m, ncvt, nru, 0, s, rwork( ie ), vt,ldvt, a, lda, & - cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_${ci}$bdsqr( 'L', m, ncvt, nru, 0_${ik}$, s, rwork( ie ), vt,ldvt, a, lda, & + cdum, 1_${ik}$, rwork( irwork ),info ) end if end if end if ! undo scaling if necessary - if( iscl==1 ) then - if( anrm>bignum )call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,& + if( iscl==1_${ik}$ ) then + if( anrm>bignum )call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn, 1_${ik}$, s, minmn,& ierr ) - if( info/=0 .and. anrm>bignum )call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, bignum, anrm, minmn-1,& - 1,rwork( ie ), minmn, ierr ) - if( anrmbignum )call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn-1,& + 1_${ik}$,rwork( ie ), minmn, ierr ) + if( anrm= N. The SVD of A is written as !! [++] [xx] [x0] [xx] @@ -14442,20 +14437,20 @@ module stdlib_linalg_lapack_${ci}$ numrank, iwork, liwork,cwork, lcwork, rwork, lrwork, info ) ! Scalar Arguments character, intent(in) :: joba, jobp, jobr, jobu, jobv - integer(ilp), intent(in) :: m, n, lda, ldu, ldv, liwork, lrwork - integer(ilp), intent(out) :: numrank, info - integer(ilp), intent(inout) :: lcwork + integer(${ik}$), intent(in) :: m, n, lda, ldu, ldv, liwork, lrwork + integer(${ik}$), intent(out) :: numrank, info + integer(${ik}$), intent(inout) :: lcwork ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: u(ldu,*), v(ldv,*), cwork(*) real(${ck}$), intent(out) :: s(*), rwork(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: ierr, nr, n1, optratio, p, q - integer(ilp) :: lwcon, lwqp3, lwrk_wgelqf, lwrk_wgesvd, lwrk_wgesvd2, lwrk_wgeqp3, & + integer(${ik}$) :: ierr, nr, n1, optratio, p, q + integer(${ik}$) :: lwcon, lwqp3, lwrk_wgelqf, lwrk_wgesvd, lwrk_wgesvd2, lwrk_wgeqp3, & lwrk_wgeqrf, lwrk_wunmlq, lwrk_wunmqr, lwrk_wunmqr2, lwlqf, lwqrf, lwsvd, lwsvd2, & lwunq, lwunq2, lwunlq, minwrk, minwrk2, optwrk, optwrk2, iminwrk, rminwrk logical(lk) :: accla, acclm, acclh, ascaled, conda, dntwu, dntwv, lquery, lsvc0, lsvec,& @@ -14463,8 +14458,8 @@ module stdlib_linalg_lapack_${ci}$ real(${ck}$) :: big, epsln, rtmp, sconda, sfmin complex(${ck}$) :: ctmp ! Local Arrays - complex(${ck}$) :: cdummy(1) - real(${ck}$) :: rdummy(1) + complex(${ck}$) :: cdummy(1_${ik}$) + real(${ck}$) :: rdummy(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,conjg,max,min,real,sqrt ! Executable Statements @@ -14487,40 +14482,40 @@ module stdlib_linalg_lapack_${ci}$ rowprm = stdlib_lsame( jobp, 'P' ) rtrans = stdlib_lsame( jobr, 'T' ) if ( rowprm ) then - iminwrk = max( 1, n + m - 1 ) - rminwrk = max( 2, m, 5*n ) + iminwrk = max( 1_${ik}$, n + m - 1_${ik}$ ) + rminwrk = max( 2_${ik}$, m, 5_${ik}$*n ) else - iminwrk = max( 1, n ) - rminwrk = max( 2, 5*n ) + iminwrk = max( 1_${ik}$, n ) + rminwrk = max( 2_${ik}$, 5_${ik}$*n ) end if - lquery = (liwork == -1 .or. lcwork == -1 .or. lrwork == -1) - info = 0 + lquery = (liwork == -1_${ik}$ .or. lcwork == -1_${ik}$ .or. lrwork == -1_${ik}$) + info = 0_${ik}$ if ( .not. ( accla .or. acclm .or. acclh ) ) then - info = -1 + info = -1_${ik}$ else if ( .not.( rowprm .or. stdlib_lsame( jobp, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if ( .not.( rtrans .or. stdlib_lsame( jobr, 'N' ) ) ) then - info = -3 + info = -3_${ik}$ else if ( .not.( lsvec .or. dntwu ) ) then - info = -4 + info = -4_${ik}$ else if ( wntur .and. wntva ) then - info = -5 + info = -5_${ik}$ else if ( .not.( rsvec .or. dntwv )) then - info = -5 - else if ( m<0 ) then - info = -6 - else if ( ( n<0 ) .or. ( n>m ) ) then - info = -7 - else if ( ldam ) ) then + info = -7_${ik}$ + else if ( lda big / sqrt(real(m,KIND=${ck}$)) ) then + if ( rwork(1_${ik}$) > big / sqrt(real(m,KIND=${ck}$)) ) then ! .. to prevent overflow in the qr factorization, scale the ! matrix by 1/sqrt(m) if too large entry detected - call stdlib_${ci}$lascl('G',0,0,sqrt(real(m,KIND=${ck}$)),one, m,n, a,lda, ierr) + call stdlib${ii}$_${ci}$lascl('G',0_${ik}$,0_${ik}$,sqrt(real(m,KIND=${ck}$)),one, m,n, a,lda, ierr) ascaled = .true. end if - call stdlib_${ci}$laswp( n, a, lda, 1, m-1, iwork(n+1), 1 ) + call stdlib${ii}$_${ci}$laswp( n, a, lda, 1_${ik}$, m-1, iwork(n+1), 1_${ik}$ ) end if ! .. at this stage, preemptive scaling is done only to avoid column ! norms overflows during the qr factorization. the svd procedure should ! have its own scaling to save the singular values from overflows and ! underflows. that depends on the svd procedure. if ( .not.rowprm ) then - rtmp = stdlib_${ci}$lange( 'M', m, n, a, lda, rwork ) + rtmp = stdlib${ii}$_${ci}$lange( 'M', m, n, a, lda, rwork ) if ( ( rtmp /= rtmp ) .or.( (rtmp*zero) /= zero ) ) then - info = -8 - call stdlib_xerbla( 'ZGESVDQ', -info ) + info = -8_${ik}$ + call stdlib${ii}$_xerbla( 'ZGESVDQ', -info ) return end if if ( rtmp > big / sqrt(real(m,KIND=${ck}$)) ) then ! .. to prevent overflow in the qr factorization, scale the ! matrix by 1/sqrt(m) if too large entry detected - call stdlib_${ci}$lascl('G',0,0, sqrt(real(m,KIND=${ck}$)),one, m,n, a,lda, ierr) + call stdlib${ii}$_${ci}$lascl('G',0_${ik}$,0_${ik}$, sqrt(real(m,KIND=${ck}$)),one, m,n, a,lda, ierr) ascaled = .true. end if @@ -14806,15 +14801,15 @@ module stdlib_linalg_lapack_${ci}$ ! [ 0 ] do p = 1, n ! All Columns Are Free Columns - iwork(p) = 0 + iwork(p) = 0_${ik}$ end do - call stdlib_${ci}$geqp3( m, n, a, lda, iwork, cwork, cwork(n+1), lcwork-n,rwork, ierr ) + call stdlib${ii}$_${ci}$geqp3( m, n, a, lda, iwork, cwork, cwork(n+1), lcwork-n,rwork, ierr ) ! if the user requested accuracy level allows truncation in the ! computed upper triangular factor, the matrix r is examined and, ! if possible, replaced with its leading upper trapezoidal part. - epsln = stdlib_${c2ri(ci)}$lamch('E') - sfmin = stdlib_${c2ri(ci)}$lamch('S') + epsln = stdlib${ii}$_${c2ri(ci)}$lamch('E') + sfmin = stdlib${ii}$_${c2ri(ci)}$lamch('S') ! small = sfmin / epsln nr = n if ( accla ) then @@ -14822,57 +14817,54 @@ module stdlib_linalg_lapack_${ci}$ ! sigma_i < n*eps*||a||_f are flushed to zero. this is an ! aggressive enforcement of lower numerical rank by introducing a ! backward error of the order of n*eps*||a||_f. - nr = 1 + nr = 1_${ik}$ rtmp = sqrt(real(n,KIND=${ck}$))*epsln - do p = 2, n - if ( abs(a(p,p)) < (rtmp*abs(a(1,1))) ) go to 3002 - nr = nr + 1 - end do - 3002 continue + loop_3002: do p = 2, n + if ( abs(a(p,p)) < (rtmp*abs(a(1,1))) ) exit loop_3002 + nr = nr + 1_${ik}$ + end do loop_3002 elseif ( acclm ) then ! .. similarly as above, only slightly more gentle (less aggressive). ! sudden drop on the diagonal of r is used as the criterion for being - ! close-to-rank-deficient. the threshold is set to epsln=stdlib_${c2ri(ci)}$lamch('e'). + ! close-to-rank-deficient. the threshold is set to epsln=stdlib${ii}$_${c2ri(ci)}$lamch('e'). ! [[this can be made more flexible by replacing this hard-coded value ! with a user specified threshold.]] also, the values that underflow ! will be truncated. - nr = 1 - do p = 2, n - if ( ( abs(a(p,p)) < (epsln*abs(a(p-1,p-1))) ) .or.( abs(a(p,p)) < sfmin ) ) go & - to 3402 - nr = nr + 1 - end do - 3402 continue + nr = 1_${ik}$ + loop_3402: do p = 2, n + if ( ( abs(a(p,p)) < (epsln*abs(a(p-1,p-1))) ) .or.( abs(a(p,p)) < sfmin ) ) exit loop_3402 + nr = nr + 1_${ik}$ + end do loop_3402 else ! Rrqr Not Authorized To Determine Numerical Rank Except In The ! obvious case of zero pivots. ! .. inspect r for exact zeros on the diagonal; ! r(i,i)=0 => r(i:n,i:n)=0. - nr = 1 - do p = 2, n - if ( abs(a(p,p)) == zero ) go to 3502 - nr = nr + 1 - end do - 3502 continue + nr = 1_${ik}$ + loop_3502: do p = 2, n + if ( abs(a(p,p)) == zero ) exit loop_3502 + nr = nr + 1_${ik}$ + end do loop_3502 + if ( conda ) then ! estimate the scaled condition number of a. use the fact that it is ! the same as the scaled condition number of r. ! V Is Used As Workspace - call stdlib_${ci}$lacpy( 'U', n, n, a, lda, v, ldv ) + call stdlib${ii}$_${ci}$lacpy( 'U', n, n, a, lda, v, ldv ) ! only the leading nr x nr submatrix of the triangular factor ! is considered. only if nr=n will this give a reliable error ! bound. however, even for nr < n, this can be used on an ! expert level and obtain useful information in the sense of ! perturbation theory. do p = 1, nr - rtmp = stdlib_${c2ri(ci)}$znrm2( p, v(1,p), 1 ) - call stdlib_${ci}$dscal( p, one/rtmp, v(1,p), 1 ) + rtmp = stdlib${ii}$_${c2ri(ci)}$znrm2( p, v(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_${ci}$dscal( p, one/rtmp, v(1_${ik}$,p), 1_${ik}$ ) end do if ( .not. ( lsvec .or. rsvec ) ) then - call stdlib_${ci}$pocon( 'U', nr, v, ldv, one, rtmp,cwork, rwork, ierr ) + call stdlib${ii}$_${ci}$pocon( 'U', nr, v, ldv, one, rtmp,cwork, rwork, ierr ) else - call stdlib_${ci}$pocon( 'U', nr, v, ldv, one, rtmp,cwork(n+1), rwork, ierr ) + call stdlib${ii}$_${ci}$pocon( 'U', nr, v, ldv, one, rtmp,cwork(n+1), rwork, ierr ) end if sconda = one / sqrt(rtmp) @@ -14903,13 +14895,13 @@ module stdlib_linalg_lapack_${ci}$ if ( q <= nr ) a(p,q) = czero end do end do - call stdlib_${ci}$gesvd( 'N', 'N', n, nr, a, lda, s, u, ldu,v, ldv, cwork, lcwork, & + call stdlib${ii}$_${ci}$gesvd( 'N', 'N', n, nr, a, lda, s, u, ldu,v, ldv, cwork, lcwork, & rwork, info ) else ! .. compute the singular values of r = [a](1:nr,1:n) - if ( nr > 1 )call stdlib_${ci}$laset( 'L', nr-1,nr-1, czero,czero, a(2,1), lda ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_${ci}$laset( 'L', nr-1,nr-1, czero,czero, a(2_${ik}$,1_${ik}$), lda ) - call stdlib_${ci}$gesvd( 'N', 'N', nr, n, a, lda, s, u, ldu,v, ldv, cwork, lcwork, & + call stdlib${ii}$_${ci}$gesvd( 'N', 'N', nr, n, a, lda, s, u, ldu,v, ldv, cwork, lcwork, & rwork, info ) end if else if ( lsvec .and. ( .not. rsvec) ) then @@ -14917,7 +14909,7 @@ module stdlib_linalg_lapack_${ci}$ ! The Singular Values And The Left Singular Vectors Requested ! ......................................................................."""""""" if ( rtrans ) then - ! .. apply stdlib_${ci}$gesvd to r**h + ! .. apply stdlib${ii}$_${ci}$gesvd to r**h ! .. copy r**h into [u] and overwrite [u] with the right singular ! vectors of r do p = 1, nr @@ -14925,12 +14917,12 @@ module stdlib_linalg_lapack_${ci}$ u(q,p) = conjg(a(p,q)) end do end do - if ( nr > 1 )call stdlib_${ci}$laset( 'U', nr-1,nr-1, czero,czero, u(1,2), ldu ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_${ci}$laset( 'U', nr-1,nr-1, czero,czero, u(1_${ik}$,2_${ik}$), ldu ) ! .. the left singular vectors not computed, the nr right singular ! vectors overwrite [u](1:nr,1:nr) as conjugate transposed. these ! will be pre-multiplied by q to build the left singular vectors of a. - call stdlib_${ci}$gesvd( 'N', 'O', n, nr, u, ldu, s, u, ldu,u, ldu, cwork(n+1), & + call stdlib${ii}$_${ci}$gesvd( 'N', 'O', n, nr, u, ldu, s, u, ldu,u, ldu, cwork(n+1), & lcwork-n, rwork, info ) do p = 1, nr u(p,p) = conjg(u(p,p)) @@ -14943,12 +14935,12 @@ module stdlib_linalg_lapack_${ci}$ else ! Apply Stdlib_Zgesvd To R ! .. copy r into [u] and overwrite [u] with the left singular vectors - call stdlib_${ci}$lacpy( 'U', nr, n, a, lda, u, ldu ) - if ( nr > 1 )call stdlib_${ci}$laset( 'L', nr-1, nr-1, czero, czero, u(2,1), ldu ) + call stdlib${ii}$_${ci}$lacpy( 'U', nr, n, a, lda, u, ldu ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_${ci}$laset( 'L', nr-1, nr-1, czero, czero, u(2_${ik}$,1_${ik}$), ldu ) ! .. the right singular vectors not computed, the nr left singular ! vectors overwrite [u](1:nr,1:nr) - call stdlib_${ci}$gesvd( 'O', 'N', nr, n, u, ldu, s, u, ldu,v, ldv, cwork(n+1), & + call stdlib${ii}$_${ci}$gesvd( 'O', 'N', nr, n, u, ldu, s, u, ldu,v, ldv, cwork(n+1), & lcwork-n, rwork, info ) ! .. now [u](1:nr,1:nr) contains the nr left singular vectors of ! r. these will be pre-multiplied by q to build the left singular @@ -14957,36 +14949,36 @@ module stdlib_linalg_lapack_${ci}$ ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. ( .not.wntuf ) ) then - call stdlib_${ci}$laset('A', m-nr, nr, czero, czero, u(nr+1,1), ldu) + call stdlib${ii}$_${ci}$laset('A', m-nr, nr, czero, czero, u(nr+1,1_${ik}$), ldu) if ( nr < n1 ) then - call stdlib_${ci}$laset( 'A',nr,n1-nr,czero,czero,u(1,nr+1), ldu ) - call stdlib_${ci}$laset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_${ci}$laset( 'A',nr,n1-nr,czero,czero,u(1_${ik}$,nr+1), ldu ) + call stdlib${ii}$_${ci}$laset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) end if end if ! the q matrix from the first qrf is built into the left singular ! vectors matrix u. - if ( .not.wntuf )call stdlib_${ci}$unmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, & + if ( .not.wntuf )call stdlib${ii}$_${ci}$unmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, & cwork(n+1), lcwork-n, ierr ) - if ( rowprm .and. .not.wntuf )call stdlib_${ci}$laswp( n1, u, ldu, 1, m-1, iwork(n+1), -& - 1 ) + if ( rowprm .and. .not.wntuf )call stdlib${ii}$_${ci}$laswp( n1, u, ldu, 1_${ik}$, m-1, iwork(n+1), -& + 1_${ik}$ ) else if ( rsvec .and. ( .not. lsvec ) ) then ! ....................................................................... ! The Singular Values And The Right Singular Vectors Requested ! ....................................................................... if ( rtrans ) then - ! .. apply stdlib_${ci}$gesvd to r**h + ! .. apply stdlib${ii}$_${ci}$gesvd to r**h ! .. copy r**h into v and overwrite v with the left singular vectors do p = 1, nr do q = p, n v(q,p) = conjg(a(p,q)) end do end do - if ( nr > 1 )call stdlib_${ci}$laset( 'U', nr-1,nr-1, czero,czero, v(1,2), ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_${ci}$laset( 'U', nr-1,nr-1, czero,czero, v(1_${ik}$,2_${ik}$), ldv ) ! .. the left singular vectors of r**h overwrite v, the right singular ! vectors not computed if ( wntvr .or. ( nr == n ) ) then - call stdlib_${ci}$gesvd( 'O', 'N', n, nr, v, ldv, s, u, ldu,u, ldu, cwork(n+1), & + call stdlib${ii}$_${ci}$gesvd( 'O', 'N', n, nr, v, ldv, s, u, ldu,u, ldu, cwork(n+1), & lcwork-n, rwork, info ) do p = 1, nr v(p,p) = conjg(v(p,p)) @@ -15003,15 +14995,15 @@ module stdlib_linalg_lapack_${ci}$ end do end do end if - call stdlib_${ci}$lapmt( .false., nr, n, v, ldv, iwork ) + call stdlib${ii}$_${ci}$lapmt( .false., nr, n, v, ldv, iwork ) else ! .. need all n right singular vectors and nr < n ! [!] this is simple implementation that augments [v](1:n,1:nr) ! by padding a zero block. in the case nr << n, a more efficient ! way is to first use the qr factorization. for more details ! how to implement this, see the " full svd " branch. - call stdlib_${ci}$laset('G', n, n-nr, czero, czero, v(1,nr+1), ldv) - call stdlib_${ci}$gesvd( 'O', 'N', n, n, v, ldv, s, u, ldu,u, ldu, cwork(n+1), & + call stdlib${ii}$_${ci}$laset('G', n, n-nr, czero, czero, v(1_${ik}$,nr+1), ldv) + call stdlib${ii}$_${ci}$gesvd( 'O', 'N', n, n, v, ldv, s, u, ldu,u, ldu, cwork(n+1), & lcwork-n, rwork, info ) do p = 1, n v(p,p) = conjg(v(p,p)) @@ -15021,20 +15013,20 @@ module stdlib_linalg_lapack_${ci}$ v(p,q) = ctmp end do end do - call stdlib_${ci}$lapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_${ci}$lapmt( .false., n, n, v, ldv, iwork ) end if else ! Aply Stdlib_Zgesvd To R ! Copy R Into V And Overwrite V With The Right Singular Vectors - call stdlib_${ci}$lacpy( 'U', nr, n, a, lda, v, ldv ) - if ( nr > 1 )call stdlib_${ci}$laset( 'L', nr-1, nr-1, czero, czero, v(2,1), ldv ) + call stdlib${ii}$_${ci}$lacpy( 'U', nr, n, a, lda, v, ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_${ci}$laset( 'L', nr-1, nr-1, czero, czero, v(2_${ik}$,1_${ik}$), ldv ) ! .. the right singular vectors overwrite v, the nr left singular ! vectors stored in u(1:nr,1:nr) if ( wntvr .or. ( nr == n ) ) then - call stdlib_${ci}$gesvd( 'N', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & + call stdlib${ii}$_${ci}$gesvd( 'N', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & lcwork-n, rwork, info ) - call stdlib_${ci}$lapmt( .false., nr, n, v, ldv, iwork ) + call stdlib${ii}$_${ci}$lapmt( .false., nr, n, v, ldv, iwork ) ! .. now [v](1:nr,1:n) contains v(1:n,1:nr)**h else ! .. need all n right singular vectors and nr < n @@ -15042,10 +15034,10 @@ module stdlib_linalg_lapack_${ci}$ ! by padding a zero block. in the case nr << n, a more efficient ! way is to first use the lq factorization. for more details ! how to implement this, see the " full svd " branch. - call stdlib_${ci}$laset('G', n-nr, n, czero,czero, v(nr+1,1), ldv) - call stdlib_${ci}$gesvd( 'N', 'O', n, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & + call stdlib${ii}$_${ci}$laset('G', n-nr, n, czero,czero, v(nr+1,1_${ik}$), ldv) + call stdlib${ii}$_${ci}$gesvd( 'N', 'O', n, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & lcwork-n, rwork, info ) - call stdlib_${ci}$lapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_${ci}$lapmt( .false., n, n, v, ldv, iwork ) end if ! .. now [v] contains the adjoint of the matrix of the right singular ! vectors of a. @@ -15055,7 +15047,7 @@ module stdlib_linalg_lapack_${ci}$ ! Full Svd Requested ! ....................................................................... if ( rtrans ) then - ! .. apply stdlib_${ci}$gesvd to r**h [[this option is left for r + ! .. apply stdlib${ii}$_${ci}$gesvd to r**h [[this option is left for r if ( wntvr .or. ( nr == n ) ) then ! .. copy r**h into [v] and overwrite [v] with the left singular ! vectors of r**h @@ -15064,12 +15056,12 @@ module stdlib_linalg_lapack_${ci}$ v(q,p) = conjg(a(p,q)) end do end do - if ( nr > 1 )call stdlib_${ci}$laset( 'U', nr-1,nr-1, czero,czero, v(1,2), ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_${ci}$laset( 'U', nr-1,nr-1, czero,czero, v(1_${ik}$,2_${ik}$), ldv ) ! .. the left singular vectors of r**h overwrite [v], the nr right ! singular vectors of r**h stored in [u](1:nr,1:nr) as conjugate ! transposed - call stdlib_${ci}$gesvd( 'O', 'A', n, nr, v, ldv, s, v, ldv,u, ldu, cwork(n+1), & + call stdlib${ii}$_${ci}$gesvd( 'O', 'A', n, nr, v, ldv, s, v, ldv,u, ldu, cwork(n+1), & lcwork-n, rwork, info ) ! Assemble V do p = 1, nr @@ -15087,7 +15079,7 @@ module stdlib_linalg_lapack_${ci}$ end do end do end if - call stdlib_${ci}$lapmt( .false., nr, n, v, ldv, iwork ) + call stdlib${ii}$_${ci}$lapmt( .false., nr, n, v, ldv, iwork ) do p = 1, nr u(p,p) = conjg(u(p,p)) do q = p + 1, nr @@ -15097,10 +15089,10 @@ module stdlib_linalg_lapack_${ci}$ end do end do if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_${ci}$laset('A', m-nr,nr, czero,czero, u(nr+1,1), ldu) + call stdlib${ii}$_${ci}$laset('A', m-nr,nr, czero,czero, u(nr+1,1_${ik}$), ldu) if ( nr < n1 ) then - call stdlib_${ci}$laset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) - call stdlib_${ci}$laset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_${ci}$laset('A',nr,n1-nr,czero,czero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_${ci}$laset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) end if end if @@ -15111,19 +15103,19 @@ module stdlib_linalg_lapack_${ci}$ ! [[the optimal ratio n/nr for using qrf instead of padding ! with zeros. here hard coded to 2; it must be at least ! two due to work space constraints.]] - ! optratio = stdlib_ilaenv(6, 'zgesvd', 's' // 'o', nr,n,0,0) + ! optratio = stdlib${ii}$_ilaenv(6, 'zgesvd', 's' // 'o', nr,n,0,0) ! optratio = max( optratio, 2 ) - optratio = 2 + optratio = 2_${ik}$ if ( optratio*nr > n ) then do p = 1, nr do q = p, n v(q,p) = conjg(a(p,q)) end do end do - if ( nr > 1 )call stdlib_${ci}$laset('U',nr-1,nr-1, czero,czero, v(1,2),ldv) + if ( nr > 1_${ik}$ )call stdlib${ii}$_${ci}$laset('U',nr-1,nr-1, czero,czero, v(1_${ik}$,2_${ik}$),ldv) - call stdlib_${ci}$laset('A',n,n-nr,czero,czero,v(1,nr+1),ldv) - call stdlib_${ci}$gesvd( 'O', 'A', n, n, v, ldv, s, v, ldv,u, ldu, cwork(n+1), & + call stdlib${ii}$_${ci}$laset('A',n,n-nr,czero,czero,v(1_${ik}$,nr+1),ldv) + call stdlib${ii}$_${ci}$gesvd( 'O', 'A', n, n, v, ldv, s, v, ldv,u, ldu, cwork(n+1), & lcwork-n, rwork, info ) do p = 1, n v(p,p) = conjg(v(p,p)) @@ -15133,7 +15125,7 @@ module stdlib_linalg_lapack_${ci}$ v(p,q) = ctmp end do end do - call stdlib_${ci}$lapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_${ci}$lapmt( .false., n, n, v, ldv, iwork ) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x n1), i.e. (m x n) or (m x m). do p = 1, n @@ -15145,10 +15137,10 @@ module stdlib_linalg_lapack_${ci}$ end do end do if ( ( n < m ) .and. .not.(wntuf)) then - call stdlib_${ci}$laset('A',m-n,n,czero,czero,u(n+1,1),ldu) + call stdlib${ii}$_${ci}$laset('A',m-n,n,czero,czero,u(n+1,1_${ik}$),ldu) if ( n < n1 ) then - call stdlib_${ci}$laset('A',n,n1-n,czero,czero,u(1,n+1),ldu) - call stdlib_${ci}$laset('A',m-n,n1-n,czero,cone,u(n+1,n+1), ldu ) + call stdlib${ii}$_${ci}$laset('A',n,n1-n,czero,czero,u(1_${ik}$,n+1),ldu) + call stdlib${ii}$_${ci}$laset('A',m-n,n1-n,czero,cone,u(n+1,n+1), ldu ) end if end if else @@ -15159,55 +15151,55 @@ module stdlib_linalg_lapack_${ci}$ u(q,nr+p) = conjg(a(p,q)) end do end do - if ( nr > 1 )call stdlib_${ci}$laset('U',nr-1,nr-1,czero,czero,u(1,nr+2),ldu) + if ( nr > 1_${ik}$ )call stdlib${ii}$_${ci}$laset('U',nr-1,nr-1,czero,czero,u(1_${ik}$,nr+2),ldu) - call stdlib_${ci}$geqrf( n, nr, u(1,nr+1), ldu, cwork(n+1),cwork(n+nr+1), & + call stdlib${ii}$_${ci}$geqrf( n, nr, u(1_${ik}$,nr+1), ldu, cwork(n+1),cwork(n+nr+1), & lcwork-n-nr, ierr ) do p = 1, nr do q = 1, n v(q,p) = conjg(u(p,nr+q)) end do end do - if (nr>1) call stdlib_${ci}$laset('U',nr-1,nr-1,czero,czero,v(1,2),ldv) - call stdlib_${ci}$gesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v,ldv, cwork(n+nr+& - 1),lcwork-n-nr,rwork, info ) - call stdlib_${ci}$laset('A',n-nr,nr,czero,czero,v(nr+1,1),ldv) - call stdlib_${ci}$laset('A',nr,n-nr,czero,czero,v(1,nr+1),ldv) - call stdlib_${ci}$laset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) - call stdlib_${ci}$unmqr('R','C', n, n, nr, u(1,nr+1), ldu,cwork(n+1),v,ldv,& + if (nr>1_${ik}$) call stdlib${ii}$_${ci}$laset('U',nr-1,nr-1,czero,czero,v(1_${ik}$,2_${ik}$),ldv) + call stdlib${ii}$_${ci}$gesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v,ldv, cwork(n+nr+& + 1_${ik}$),lcwork-n-nr,rwork, info ) + call stdlib${ii}$_${ci}$laset('A',n-nr,nr,czero,czero,v(nr+1,1_${ik}$),ldv) + call stdlib${ii}$_${ci}$laset('A',nr,n-nr,czero,czero,v(1_${ik}$,nr+1),ldv) + call stdlib${ii}$_${ci}$laset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) + call stdlib${ii}$_${ci}$unmqr('R','C', n, n, nr, u(1_${ik}$,nr+1), ldu,cwork(n+1),v,ldv,& cwork(n+nr+1),lcwork-n-nr,ierr) - call stdlib_${ci}$lapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_${ci}$lapmt( .false., n, n, v, ldv, iwork ) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_${ci}$laset('A',m-nr,nr,czero,czero,u(nr+1,1),ldu) + call stdlib${ii}$_${ci}$laset('A',m-nr,nr,czero,czero,u(nr+1,1_${ik}$),ldu) if ( nr < n1 ) then - call stdlib_${ci}$laset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) - call stdlib_${ci}$laset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1),ldu) + call stdlib${ii}$_${ci}$laset('A',nr,n1-nr,czero,czero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_${ci}$laset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1),ldu) end if end if end if end if else - ! .. apply stdlib_${ci}$gesvd to r [[this is the recommended option]] + ! .. apply stdlib${ii}$_${ci}$gesvd to r [[this is the recommended option]] if ( wntvr .or. ( nr == n ) ) then ! .. copy r into [v] and overwrite v with the right singular vectors - call stdlib_${ci}$lacpy( 'U', nr, n, a, lda, v, ldv ) - if ( nr > 1 )call stdlib_${ci}$laset( 'L', nr-1,nr-1, czero,czero, v(2,1), ldv ) + call stdlib${ii}$_${ci}$lacpy( 'U', nr, n, a, lda, v, ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_${ci}$laset( 'L', nr-1,nr-1, czero,czero, v(2_${ik}$,1_${ik}$), ldv ) ! .. the right singular vectors of r overwrite [v], the nr left ! singular vectors of r stored in [u](1:nr,1:nr) - call stdlib_${ci}$gesvd( 'S', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & + call stdlib${ii}$_${ci}$gesvd( 'S', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & lcwork-n, rwork, info ) - call stdlib_${ci}$lapmt( .false., nr, n, v, ldv, iwork ) + call stdlib${ii}$_${ci}$lapmt( .false., nr, n, v, ldv, iwork ) ! .. now [v](1:nr,1:n) contains v(1:n,1:nr)**h ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_${ci}$laset('A', m-nr,nr, czero,czero, u(nr+1,1), ldu) + call stdlib${ii}$_${ci}$laset('A', m-nr,nr, czero,czero, u(nr+1,1_${ik}$), ldu) if ( nr < n1 ) then - call stdlib_${ci}$laset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) - call stdlib_${ci}$laset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_${ci}$laset('A',nr,n1-nr,czero,czero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_${ci}$laset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) end if end if @@ -15218,55 +15210,55 @@ module stdlib_linalg_lapack_${ci}$ ! [[the optimal ratio n/nr for using lq instead of padding ! with zeros. here hard coded to 2; it must be at least ! two due to work space constraints.]] - ! optratio = stdlib_ilaenv(6, 'zgesvd', 's' // 'o', nr,n,0,0) + ! optratio = stdlib${ii}$_ilaenv(6, 'zgesvd', 's' // 'o', nr,n,0,0) ! optratio = max( optratio, 2 ) - optratio = 2 + optratio = 2_${ik}$ if ( optratio * nr > n ) then - call stdlib_${ci}$lacpy( 'U', nr, n, a, lda, v, ldv ) - if ( nr > 1 )call stdlib_${ci}$laset('L', nr-1,nr-1, czero,czero, v(2,1),ldv) + call stdlib${ii}$_${ci}$lacpy( 'U', nr, n, a, lda, v, ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_${ci}$laset('L', nr-1,nr-1, czero,czero, v(2_${ik}$,1_${ik}$),ldv) ! .. the right singular vectors of r overwrite [v], the nr left ! singular vectors of r stored in [u](1:nr,1:nr) - call stdlib_${ci}$laset('A', n-nr,n, czero,czero, v(nr+1,1),ldv) - call stdlib_${ci}$gesvd( 'S', 'O', n, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & + call stdlib${ii}$_${ci}$laset('A', n-nr,n, czero,czero, v(nr+1,1_${ik}$),ldv) + call stdlib${ii}$_${ci}$gesvd( 'S', 'O', n, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & lcwork-n, rwork, info ) - call stdlib_${ci}$lapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_${ci}$lapmt( .false., n, n, v, ldv, iwork ) ! .. now [v] contains the adjoint of the matrix of the right ! singular vectors of a. the leading n left singular vectors ! are in [u](1:n,1:n) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x n1), i.e. (m x n) or (m x m). if ( ( n < m ) .and. .not.(wntuf)) then - call stdlib_${ci}$laset('A',m-n,n,czero,czero,u(n+1,1),ldu) + call stdlib${ii}$_${ci}$laset('A',m-n,n,czero,czero,u(n+1,1_${ik}$),ldu) if ( n < n1 ) then - call stdlib_${ci}$laset('A',n,n1-n,czero,czero,u(1,n+1),ldu) - call stdlib_${ci}$laset( 'A',m-n,n1-n,czero,cone,u(n+1,n+1), ldu ) + call stdlib${ii}$_${ci}$laset('A',n,n1-n,czero,czero,u(1_${ik}$,n+1),ldu) + call stdlib${ii}$_${ci}$laset( 'A',m-n,n1-n,czero,cone,u(n+1,n+1), ldu ) end if end if else - call stdlib_${ci}$lacpy( 'U', nr, n, a, lda, u(nr+1,1), ldu ) - if ( nr > 1 )call stdlib_${ci}$laset('L',nr-1,nr-1,czero,czero,u(nr+2,1),ldu) + call stdlib${ii}$_${ci}$lacpy( 'U', nr, n, a, lda, u(nr+1,1_${ik}$), ldu ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_${ci}$laset('L',nr-1,nr-1,czero,czero,u(nr+2,1_${ik}$),ldu) - call stdlib_${ci}$gelqf( nr, n, u(nr+1,1), ldu, cwork(n+1),cwork(n+nr+1), & + call stdlib${ii}$_${ci}$gelqf( nr, n, u(nr+1,1_${ik}$), ldu, cwork(n+1),cwork(n+nr+1), & lcwork-n-nr, ierr ) - call stdlib_${ci}$lacpy('L',nr,nr,u(nr+1,1),ldu,v,ldv) - if ( nr > 1 )call stdlib_${ci}$laset('U',nr-1,nr-1,czero,czero,v(1,2),ldv) + call stdlib${ii}$_${ci}$lacpy('L',nr,nr,u(nr+1,1_${ik}$),ldu,v,ldv) + if ( nr > 1_${ik}$ )call stdlib${ii}$_${ci}$laset('U',nr-1,nr-1,czero,czero,v(1_${ik}$,2_${ik}$),ldv) - call stdlib_${ci}$gesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v, ldv, cwork(n+nr+& - 1), lcwork-n-nr, rwork, info ) - call stdlib_${ci}$laset('A',n-nr,nr,czero,czero,v(nr+1,1),ldv) - call stdlib_${ci}$laset('A',nr,n-nr,czero,czero,v(1,nr+1),ldv) - call stdlib_${ci}$laset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) - call stdlib_${ci}$unmlq('R','N',n,n,nr,u(nr+1,1),ldu,cwork(n+1),v, ldv, cwork(n+& + call stdlib${ii}$_${ci}$gesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v, ldv, cwork(n+nr+& + 1_${ik}$), lcwork-n-nr, rwork, info ) + call stdlib${ii}$_${ci}$laset('A',n-nr,nr,czero,czero,v(nr+1,1_${ik}$),ldv) + call stdlib${ii}$_${ci}$laset('A',nr,n-nr,czero,czero,v(1_${ik}$,nr+1),ldv) + call stdlib${ii}$_${ci}$laset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) + call stdlib${ii}$_${ci}$unmlq('R','N',n,n,nr,u(nr+1,1_${ik}$),ldu,cwork(n+1),v, ldv, cwork(n+& nr+1),lcwork-n-nr,ierr) - call stdlib_${ci}$lapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_${ci}$lapmt( .false., n, n, v, ldv, iwork ) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_${ci}$laset('A',m-nr,nr,czero,czero,u(nr+1,1),ldu) + call stdlib${ii}$_${ci}$laset('A',m-nr,nr,czero,czero,u(nr+1,1_${ik}$),ldu) if ( nr < n1 ) then - call stdlib_${ci}$laset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) - call stdlib_${ci}$laset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_${ci}$laset('A',nr,n1-nr,czero,czero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_${ci}$laset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) end if end if @@ -15276,10 +15268,10 @@ module stdlib_linalg_lapack_${ci}$ end if ! the q matrix from the first qrf is built into the left singular ! vectors matrix u. - if ( .not. wntuf )call stdlib_${ci}$unmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, & + if ( .not. wntuf )call stdlib${ii}$_${ci}$unmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, & cwork(n+1), lcwork-n, ierr ) - if ( rowprm .and. .not.wntuf )call stdlib_${ci}$laswp( n1, u, ldu, 1, m-1, iwork(n+1), -& - 1 ) + if ( rowprm .and. .not.wntuf )call stdlib${ii}$_${ci}$laswp( n1, u, ldu, 1_${ik}$, m-1, iwork(n+1), -& + 1_${ik}$ ) ! ... end of the "full svd" branch end if ! check whether some singular values are returned as zeros, e.g. @@ -15287,27 +15279,27 @@ module stdlib_linalg_lapack_${ci}$ p = nr do q = p, 1, -1 if ( s(q) > zero ) go to 4002 - nr = nr - 1 + nr = nr - 1_${ik}$ end do 4002 continue ! .. if numerical rank deficiency is detected, the truncated ! singular values are set to zero. - if ( nr < n ) call stdlib_${c2ri(ci)}$laset( 'G', n-nr,1, zero,zero, s(nr+1), n ) + if ( nr < n ) call stdlib${ii}$_${c2ri(ci)}$laset( 'G', n-nr,1_${ik}$, zero,zero, s(nr+1), n ) ! .. undo scaling; this may cause overflow in the largest singular ! values. - if ( ascaled )call stdlib_${c2ri(ci)}$lascl( 'G',0,0, one,sqrt(real(m,KIND=${ck}$)), nr,1, s, n, ierr & + if ( ascaled )call stdlib${ii}$_${c2ri(ci)}$lascl( 'G',0_${ik}$,0_${ik}$, one,sqrt(real(m,KIND=${ck}$)), nr,1_${ik}$, s, n, ierr & ) - if ( conda ) rwork(1) = sconda - rwork(2) = p - nr + if ( conda ) rwork(1_${ik}$) = sconda + rwork(2_${ik}$) = p - nr ! .. p-nr is the number of singular values that are computed as - ! exact zeros in stdlib_${ci}$gesvd() applied to the (possibly truncated) + ! exact zeros in stdlib${ii}$_${ci}$gesvd() applied to the (possibly truncated) ! full row rank triangular (trapezoidal) factor of a. numrank = nr return - end subroutine stdlib_${ci}$gesvdq + end subroutine stdlib${ii}$_${ci}$gesvdq - pure subroutine stdlib_${ci}$gesvj( joba, jobu, jobv, m, n, a, lda, sva, mv, v,ldv, cwork, lwork, & + pure subroutine stdlib${ii}$_${ci}$gesvj( joba, jobu, jobv, m, n, a, lda, sva, mv, v,ldv, cwork, lwork, & !! ZGESVJ: computes the singular value decomposition (SVD) of a complex !! M-by-N matrix A, where M >= N. The SVD of A is written as !! [++] [xx] [x0] [xx] @@ -15322,8 +15314,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, ldv, lwork, lrwork, m, mv, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldv, lwork, lrwork, m, mv, n character, intent(in) :: joba, jobu, jobv ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*), v(ldv,*), cwork(lwork) @@ -15331,7 +15323,7 @@ module stdlib_linalg_lapack_${ci}$ real(${ck}$), intent(out) :: sva(n) ! ===================================================================== ! Local Parameters - integer(ilp), parameter :: nsweep = 30 + integer(${ik}$), parameter :: nsweep = 30_${ik}$ @@ -15340,7 +15332,7 @@ module stdlib_linalg_lapack_${ci}$ real(${ck}$) :: aapp, aapp0, aapq1, aaqq, apoaq, aqoap, big, bigtheta, cs, ctol, epsln, & mxaapq, mxsinj, rootbig, rooteps, rootsfmin, roottol, skl, sfmin, small, sn, t, temp1, & theta, thsign, tol - integer(ilp) :: blskip, emptsw, i, ibr, ierr, igl, ijblsk, ir1, iswrot, jbc, jgl, kbl, & + integer(${ik}$) :: blskip, emptsw, i, ibr, ierr, igl, ijblsk, ir1, iswrot, jbc, jgl, kbl, & lkahead, mvl, n2, n34, n4, nbl, notrot, p, pskipped, q, rowskip, swband logical(lk) :: applv, goscale, lower, lquery, lsvec, noscale, rotok, rsvec, uctol, & upper @@ -15356,39 +15348,39 @@ module stdlib_linalg_lapack_${ci}$ applv = stdlib_lsame( jobv, 'A' ) upper = stdlib_lsame( joba, 'U' ) lower = stdlib_lsame( joba, 'L' ) - lquery = ( lwork == -1 ) .or. ( lrwork == -1 ) + lquery = ( lwork == -1_${ik}$ ) .or. ( lrwork == -1_${ik}$ ) if( .not.( upper .or. lower .or. stdlib_lsame( joba, 'G' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( lsvec .or. uctol .or. stdlib_lsame( jobu, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( rsvec .or. applv .or. stdlib_lsame( jobv, 'N' ) ) ) then - info = -3 - else if( m<0 ) then - info = -4 - else if( ( n<0 ) .or. ( n>m ) ) then - info = -5 + info = -3_${ik}$ + else if( m<0_${ik}$ ) then + info = -4_${ik}$ + else if( ( n<0_${ik}$ ) .or. ( n>m ) ) then + info = -5_${ik}$ else if( lda=one ) then - info = -4 - call stdlib_xerbla( 'ZGESVJ', -info ) + info = -4_${ik}$ + call stdlib${ii}$_xerbla( 'ZGESVJ', -info ) return end if ! initialize the right singular vector matrix. if( rsvec ) then mvl = n - call stdlib_${ci}$laset( 'A', mvl, n, czero, cone, v, ldv ) + call stdlib${ii}$_${ci}$laset( 'A', mvl, n, czero, cone, v, ldv ) else if( applv ) then mvl = mv end if @@ -15451,10 +15443,10 @@ module stdlib_linalg_lapack_${ci}$ do p = 1, n aapp = zero aaqq = one - call stdlib_${ci}$lassq( m-p+1, a( p, p ), 1, aapp, aaqq ) + call stdlib${ii}$_${ci}$lassq( m-p+1, a( p, p ), 1_${ik}$, aapp, aaqq ) if( aapp>big ) then - info = -6 - call stdlib_xerbla( 'ZGESVJ', -info ) + info = -6_${ik}$ + call stdlib${ii}$_xerbla( 'ZGESVJ', -info ) return end if aaqq = sqrt( aaqq ) @@ -15476,10 +15468,10 @@ module stdlib_linalg_lapack_${ci}$ do p = 1, n aapp = zero aaqq = one - call stdlib_${ci}$lassq( p, a( 1, p ), 1, aapp, aaqq ) + call stdlib${ii}$_${ci}$lassq( p, a( 1_${ik}$, p ), 1_${ik}$, aapp, aaqq ) if( aapp>big ) then - info = -6 - call stdlib_xerbla( 'ZGESVJ', -info ) + info = -6_${ik}$ + call stdlib${ii}$_xerbla( 'ZGESVJ', -info ) return end if aaqq = sqrt( aaqq ) @@ -15501,10 +15493,10 @@ module stdlib_linalg_lapack_${ci}$ do p = 1, n aapp = zero aaqq = one - call stdlib_${ci}$lassq( m, a( 1, p ), 1, aapp, aaqq ) + call stdlib${ii}$_${ci}$lassq( m, a( 1_${ik}$, p ), 1_${ik}$, aapp, aaqq ) if( aapp>big ) then - info = -6 - call stdlib_xerbla( 'ZGESVJ', -info ) + info = -6_${ik}$ + call stdlib${ii}$_xerbla( 'ZGESVJ', -info ) return end if aaqq = sqrt( aaqq ) @@ -15534,29 +15526,29 @@ module stdlib_linalg_lapack_${ci}$ end do ! #:) quick return for zero matrix if( aapp==zero ) then - if( lsvec )call stdlib_${ci}$laset( 'G', m, n, czero, cone, a, lda ) - rwork( 1 ) = one - rwork( 2 ) = zero - rwork( 3 ) = zero - rwork( 4 ) = zero - rwork( 5 ) = zero - rwork( 6 ) = zero + if( lsvec )call stdlib${ii}$_${ci}$laset( 'G', m, n, czero, cone, a, lda ) + rwork( 1_${ik}$ ) = one + rwork( 2_${ik}$ ) = zero + rwork( 3_${ik}$ ) = zero + rwork( 4_${ik}$ ) = zero + rwork( 5_${ik}$ ) = zero + rwork( 6_${ik}$ ) = zero return end if ! #:) quick return for one-column matrix - if( n==1 ) then - if( lsvec )call stdlib_${ci}$lascl( 'G', 0, 0, sva( 1 ), skl, m, 1,a( 1, 1 ), lda, ierr ) + if( n==1_${ik}$ ) then + if( lsvec )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, sva( 1_${ik}$ ), skl, m, 1_${ik}$,a( 1_${ik}$, 1_${ik}$ ), lda, ierr ) - rwork( 1 ) = one / skl - if( sva( 1 )>=sfmin ) then - rwork( 2 ) = one + rwork( 1_${ik}$ ) = one / skl + if( sva( 1_${ik}$ )>=sfmin ) then + rwork( 2_${ik}$ ) = one else - rwork( 2 ) = zero + rwork( 2_${ik}$ ) = zero end if - rwork( 3 ) = zero - rwork( 4 ) = zero - rwork( 5 ) = zero - rwork( 6 ) = zero + rwork( 3_${ik}$ ) = zero + rwork( 4_${ik}$ ) = zero + rwork( 5_${ik}$ ) = zero + rwork( 6_${ik}$ ) = zero return end if ! protect small singular values from underflow, and try to @@ -15585,53 +15577,53 @@ module stdlib_linalg_lapack_${ci}$ end if ! scale, if necessary if( temp1/=one ) then - call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, one, temp1, n, 1, sva, n, ierr ) + call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, temp1, n, 1_${ik}$, sva, n, ierr ) end if skl = temp1*skl if( skl/=one ) then - call stdlib_${ci}$lascl( joba, 0, 0, one, skl, m, n, a, lda, ierr ) + call stdlib${ii}$_${ci}$lascl( joba, 0_${ik}$, 0_${ik}$, one, skl, m, n, a, lda, ierr ) skl = one / skl end if ! row-cyclic jacobi svd algorithm with column pivoting - emptsw = ( n*( n-1 ) ) / 2 - notrot = 0 + emptsw = ( n*( n-1 ) ) / 2_${ik}$ + notrot = 0_${ik}$ do q = 1, n cwork( q ) = cone end do - swband = 3 + swband = 3_${ik}$ ! [tp] swband is a tuning parameter [tp]. it is meaningful and effective - ! if stdlib_${ci}$gesvj is used as a computational routine in the preconditioned - ! jacobi svd algorithm stdlib_${ci}$gejsv. for sweeps i=1:swband the procedure + ! if stdlib${ii}$_${ci}$gesvj is used as a computational routine in the preconditioned + ! jacobi svd algorithm stdlib${ii}$_${ci}$gejsv. for sweeps i=1:swband the procedure ! works on pivots inside a band-like region around the diagonal. ! the boundaries are determined dynamically, based on the number of ! pivots above a threshold. - kbl = min( 8, n ) + kbl = min( 8_${ik}$, n ) ! [tp] kbl is a tuning parameter that defines the tile size in the ! tiling of the p-q loops of pivot pairs. in general, an optimal ! value of kbl depends on the matrix dimensions and on the ! parameters of the computer's memory. nbl = n / kbl - if( ( nbl*kbl )/=n )nbl = nbl + 1 - blskip = kbl**2 + if( ( nbl*kbl )/=n )nbl = nbl + 1_${ik}$ + blskip = kbl**2_${ik}$ ! [tp] blkskip is a tuning parameter that depends on swband and kbl. - rowskip = min( 5, kbl ) + rowskip = min( 5_${ik}$, kbl ) ! [tp] rowskip is a tuning parameter. - lkahead = 1 + lkahead = 1_${ik}$ ! [tp] lkahead is a tuning parameter. ! quasi block transformations, using the lower (upper) triangular ! structure of the input matrix. the quasi-block-cycling usually ! invokes cubic convergence. big part of this cycle is done inside ! canonical subspaces of dimensions less than m. - if( ( lower .or. upper ) .and. ( n>max( 64, 4*kbl ) ) ) then + if( ( lower .or. upper ) .and. ( n>max( 64_${ik}$, 4_${ik}$*kbl ) ) ) then ! [tp] the number of partition levels and the actual partition are ! tuning parameters. - n4 = n / 4 - n2 = n / 2 - n34 = 3*n4 + n4 = n / 4_${ik}$ + n2 = n / 2_${ik}$ + n34 = 3_${ik}$*n4 if( applv ) then - q = 0 + q = 0_${ik}$ else - q = 1 + q = 1_${ik}$ end if if( lower ) then ! this works very well on lower triangular matrices, in particular @@ -15641,32 +15633,32 @@ module stdlib_linalg_lapack_${ci}$ ! [+ + 0 0] [0 0] ! [+ + x 0] actually work on [x 0] [x 0] ! [+ + x x] [x x]. [x x] - call stdlib_${ci}$gsvj0( jobv, m-n34, n-n34, a( n34+1, n34+1 ), lda,cwork( n34+1 ), & - sva( n34+1 ), mvl,v( n34*q+1, n34+1 ), ldv, epsln, sfmin, tol,2, cwork( n+1 ), & + call stdlib${ii}$_${ci}$gsvj0( jobv, m-n34, n-n34, a( n34+1, n34+1 ), lda,cwork( n34+1 ), & + sva( n34+1 ), mvl,v( n34*q+1, n34+1 ), ldv, epsln, sfmin, tol,2_${ik}$, cwork( n+1 ), & lwork-n, ierr ) - call stdlib_${ci}$gsvj0( jobv, m-n2, n34-n2, a( n2+1, n2+1 ), lda,cwork( n2+1 ), sva( & - n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 2,cwork( n+1 ), lwork-n, & + call stdlib${ii}$_${ci}$gsvj0( jobv, m-n2, n34-n2, a( n2+1, n2+1 ), lda,cwork( n2+1 ), sva( & + n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 2_${ik}$,cwork( n+1 ), lwork-n, & ierr ) - call stdlib_${ci}$gsvj1( jobv, m-n2, n-n2, n4, a( n2+1, n2+1 ), lda,cwork( n2+1 ), & - sva( n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1,cwork( n+1 ), & + call stdlib${ii}$_${ci}$gsvj1( jobv, m-n2, n-n2, n4, a( n2+1, n2+1 ), lda,cwork( n2+1 ), & + sva( n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1_${ik}$,cwork( n+1 ), & lwork-n, ierr ) - call stdlib_${ci}$gsvj0( jobv, m-n4, n2-n4, a( n4+1, n4+1 ), lda,cwork( n4+1 ), sva( & - n4+1 ), mvl,v( n4*q+1, n4+1 ), ldv, epsln, sfmin, tol, 1,cwork( n+1 ), lwork-n, & + call stdlib${ii}$_${ci}$gsvj0( jobv, m-n4, n2-n4, a( n4+1, n4+1 ), lda,cwork( n4+1 ), sva( & + n4+1 ), mvl,v( n4*q+1, n4+1 ), ldv, epsln, sfmin, tol, 1_${ik}$,cwork( n+1 ), lwork-n, & ierr ) - call stdlib_${ci}$gsvj0( jobv, m, n4, a, lda, cwork, sva, mvl, v, ldv,epsln, sfmin, & - tol, 1, cwork( n+1 ), lwork-n,ierr ) - call stdlib_${ci}$gsvj1( jobv, m, n2, n4, a, lda, cwork, sva, mvl, v,ldv, epsln, & - sfmin, tol, 1, cwork( n+1 ),lwork-n, ierr ) + call stdlib${ii}$_${ci}$gsvj0( jobv, m, n4, a, lda, cwork, sva, mvl, v, ldv,epsln, sfmin, & + tol, 1_${ik}$, cwork( n+1 ), lwork-n,ierr ) + call stdlib${ii}$_${ci}$gsvj1( jobv, m, n2, n4, a, lda, cwork, sva, mvl, v,ldv, epsln, & + sfmin, tol, 1_${ik}$, cwork( n+1 ),lwork-n, ierr ) else if( upper ) then - call stdlib_${ci}$gsvj0( jobv, n4, n4, a, lda, cwork, sva, mvl, v, ldv,epsln, sfmin, & - tol, 2, cwork( n+1 ), lwork-n,ierr ) - call stdlib_${ci}$gsvj0( jobv, n2, n4, a( 1, n4+1 ), lda, cwork( n4+1 ),sva( n4+1 ), & - mvl, v( n4*q+1, n4+1 ), ldv,epsln, sfmin, tol, 1, cwork( n+1 ), lwork-n,ierr ) + call stdlib${ii}$_${ci}$gsvj0( jobv, n4, n4, a, lda, cwork, sva, mvl, v, ldv,epsln, sfmin, & + tol, 2_${ik}$, cwork( n+1 ), lwork-n,ierr ) + call stdlib${ii}$_${ci}$gsvj0( jobv, n2, n4, a( 1_${ik}$, n4+1 ), lda, cwork( n4+1 ),sva( n4+1 ), & + mvl, v( n4*q+1, n4+1 ), ldv,epsln, sfmin, tol, 1_${ik}$, cwork( n+1 ), lwork-n,ierr ) - call stdlib_${ci}$gsvj1( jobv, n2, n2, n4, a, lda, cwork, sva, mvl, v,ldv, epsln, & - sfmin, tol, 1, cwork( n+1 ),lwork-n, ierr ) - call stdlib_${ci}$gsvj0( jobv, n2+n4, n4, a( 1, n2+1 ), lda,cwork( n2+1 ), sva( n2+1 )& - , mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1,cwork( n+1 ), lwork-n, ierr ) + call stdlib${ii}$_${ci}$gsvj1( jobv, n2, n2, n4, a, lda, cwork, sva, mvl, v,ldv, epsln, & + sfmin, tol, 1_${ik}$, cwork( n+1 ),lwork-n, ierr ) + call stdlib${ii}$_${ci}$gsvj0( jobv, n2+n4, n4, a( 1_${ik}$, n2+1 ), lda,cwork( n2+1 ), sva( n2+1 )& + , mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1_${ik}$,cwork( n+1 ), lwork-n, ierr ) end if end if @@ -15675,23 +15667,23 @@ module stdlib_linalg_lapack_${ci}$ ! .. go go go ... mxaapq = zero mxsinj = zero - iswrot = 0 - notrot = 0 - pskipped = 0 + iswrot = 0_${ik}$ + notrot = 0_${ik}$ + pskipped = 0_${ik}$ ! each sweep is unrolled using kbl-by-kbl tiles over the pivot pairs ! 1 <= p < q <= n. this is the first step toward a blocked implementation ! of the rotations. new implementation, based on block transformations, ! is under development. loop_2000: do ibr = 1, nbl - igl = ( ibr-1 )*kbl + 1 + igl = ( ibr-1 )*kbl + 1_${ik}$ loop_1002: do ir1 = 0, min( lkahead, nbl-ibr ) igl = igl + ir1*kbl loop_2001: do p = igl, min( igl+kbl-1, n-1 ) ! .. de rijk's pivoting - q = stdlib_i${c2ri(ci)}$amax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib${ii}$_i${c2ri(ci)}$amax( n-p+1, sva( p ), 1_${ik}$ ) + p - 1_${ik}$ if( p/=q ) then - call stdlib_${ci}$swap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_${ci}$swap( mvl, v( 1, p ), 1,v( 1, q ), 1 ) + call stdlib${ii}$_${ci}$swap( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) + if( rsvec )call stdlib${ii}$_${ci}$swap( mvl, v( 1_${ik}$, p ), 1_${ik}$,v( 1_${ik}$, q ), 1_${ik}$ ) temp1 = sva( p ) sva( p ) = sva( q ) sva( q ) = temp1 @@ -15699,24 +15691,24 @@ module stdlib_linalg_lapack_${ci}$ cwork(p) = cwork(q) cwork(q) = aapq end if - if( ir1==0 ) then + if( ir1==0_${ik}$ ) then ! column norms are periodically updated by explicit ! norm computation. ! [!] caveat: - ! unfortunately, some blas implementations compute stdlib_${c2ri(ci)}$znrm2(m,a(1,p),1) - ! as sqrt(s=stdlib_zdotc(m,a(1,p),1,a(1,p),1)), which may cause the result to + ! unfortunately, some blas implementations compute stdlib${ii}$_${c2ri(ci)}$znrm2(m,a(1,p),1) + ! as sqrt(s=stdlib${ii}$_zdotc(m,a(1,p),1,a(1,p),1)), which may cause the result to ! overflow for ||a(:,p)||_2 > sqrt(overflow_threshold), and to ! underflow for ||a(:,p)||_2 < sqrt(underflow_threshold). - ! hence, stdlib_${c2ri(ci)}$znrm2 cannot be trusted, not even in the case when + ! hence, stdlib${ii}$_${c2ri(ci)}$znrm2 cannot be trusted, not even in the case when ! the true norm is far from the under(over)flow boundaries. - ! if properly implemented stdlib_dcnrm2 is available, the if-then-else-end if - ! below should be replaced with "aapp = stdlib_${c2ri(ci)}$znrm2( m, a(1,p), 1 )". + ! if properly implemented stdlib${ii}$_dcnrm2 is available, the if-then-else-end if + ! below should be replaced with "aapp = stdlib${ii}$_${c2ri(ci)}$znrm2( m, a(1,p), 1 )". if( ( sva( p )rootsfmin ) ) then - sva( p ) = stdlib_${c2ri(ci)}$znrm2( m, a( 1, p ), 1 ) + sva( p ) = stdlib${ii}$_${c2ri(ci)}$znrm2( m, a( 1_${ik}$, p ), 1_${ik}$ ) else temp1 = zero aapp = one - call stdlib_${ci}$lassq( m, a( 1, p ), 1, temp1, aapp ) + call stdlib${ii}$_${ci}$lassq( m, a( 1_${ik}$, p ), 1_${ik}$, temp1, aapp ) sva( p ) = temp1*sqrt( aapp ) end if aapp = sva( p ) @@ -15724,7 +15716,7 @@ module stdlib_linalg_lapack_${ci}$ aapp = sva( p ) end if if( aapp>zero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2002: do q = p + 1, min( igl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -15732,25 +15724,25 @@ module stdlib_linalg_lapack_${ci}$ if( aaqq>=one ) then rotok = ( small*aapp )<=aaqq if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_${ci}$dotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib${ii}$_${ci}$dotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq ) / aapp else - call stdlib_${ci}$copy( m, a( 1, p ), 1,cwork(n+1), 1 ) - call stdlib_${ci}$lascl( 'G', 0, 0, aapp, one,m, 1, cwork(n+1), & + call stdlib${ii}$_${ci}$copy( m, a( 1_${ik}$, p ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, cwork(n+1), & lda, ierr ) - aapq = stdlib_${ci}$dotc( m, cwork(n+1), 1,a( 1, q ), 1 ) / & + aapq = stdlib${ii}$_${ci}$dotc( m, cwork(n+1), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq end if else rotok = aapp<=( aaqq / small ) if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_${ci}$dotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib${ii}$_${ci}$dotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aapp ) / aaqq else - call stdlib_${ci}$copy( m, a( 1, q ), 1,cwork(n+1), 1 ) - call stdlib_${ci}$lascl( 'G', 0, 0, aaqq,one, m, 1,cwork(n+1), & + call stdlib${ii}$_${ci}$copy( m, a( 1_${ik}$, q ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq,one, m, 1_${ik}$,cwork(n+1), & lda, ierr ) - aapq = stdlib_${ci}$dotc( m, a(1, p ), 1,cwork(n+1), 1 ) / & + aapq = stdlib${ii}$_${ci}$dotc( m, a(1_${ik}$, p ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) / & aapp end if end if @@ -15762,10 +15754,10 @@ module stdlib_linalg_lapack_${ci}$ ompq = aapq / abs(aapq) ! Rotate ! [rtd] rotated = rotated + one - if( ir1==0 ) then - notrot = 0 - pskipped = 0 - iswrot = iswrot + 1 + if( ir1==0_${ik}$ ) then + notrot = 0_${ik}$ + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ end if if( rotok ) then aqoap = aaqq / aapp @@ -15774,10 +15766,10 @@ module stdlib_linalg_lapack_${ci}$ if( abs( theta )>bigtheta ) then t = half / theta cs = one - call stdlib_${ci}$rot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_${ci}$rot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *t ) if ( rsvec ) then - call stdlib_${ci}$rot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_${ci}$rot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*t ) end if sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) @@ -15795,24 +15787,24 @@ module stdlib_linalg_lapack_${ci}$ sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq1 ) ) - call stdlib_${ci}$rot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_${ci}$rot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *sn ) if ( rsvec ) then - call stdlib_${ci}$rot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_${ci}$rot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*sn ) end if end if cwork(p) = -cwork(q) * ompq else ! .. have to use modified gram-schmidt like transformation - call stdlib_${ci}$copy( m, a( 1, p ), 1,cwork(n+1), 1 ) - call stdlib_${ci}$lascl( 'G', 0, 0, aapp, one, m,1, cwork(n+1), & + call stdlib${ii}$_${ci}$copy( m, a( 1_${ik}$, p ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one, m,1_${ik}$, cwork(n+1), & lda,ierr ) - call stdlib_${ci}$lascl( 'G', 0, 0, aaqq, one, m,1, a( 1, q ), & + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one, m,1_${ik}$, a( 1_${ik}$, q ), & lda, ierr ) - call stdlib_${ci}$axpy( m, -aapq, cwork(n+1), 1,a( 1, q ), 1 ) + call stdlib${ii}$_${ci}$axpy( m, -aapq, cwork(n+1), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) - call stdlib_${ci}$lascl( 'G', 0, 0, one, aaqq, m,1, a( 1, q ), & + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq, m,1_${ik}$, a( 1_${ik}$, q ), & lda, ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq1*aapq1 ) ) mxsinj = max( mxsinj, sfmin ) @@ -15820,41 +15812,41 @@ module stdlib_linalg_lapack_${ci}$ ! end if rotok then ... else ! in the case of cancellation in updating sva(q), sva(p) ! recompute sva(q), sva(p). - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_${c2ri(ci)}$znrm2( m, a( 1, q ), 1 ) + sva( q ) = stdlib${ii}$_${c2ri(ci)}$znrm2( m, a( 1_${ik}$, q ), 1_${ik}$ ) else t = zero aaqq = one - call stdlib_${ci}$lassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_${ci}$lassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq ) end if end if if( ( aapp / aapp0 )<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_${c2ri(ci)}$znrm2( m, a( 1, p ), 1 ) + aapp = stdlib${ii}$_${c2ri(ci)}$znrm2( m, a( 1_${ik}$, p ), 1_${ik}$ ) else t = zero aapp = one - call stdlib_${ci}$lassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_${ci}$lassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp ) end if sva( p ) = aapp end if else ! a(:,p) and a(:,q) already numerically orthogonal - if( ir1==0 )notrot = notrot + 1 + if( ir1==0_${ik}$ )notrot = notrot + 1_${ik}$ ! [rtd] skipped = skipped + 1 - pskipped = pskipped + 1 + pskipped = pskipped + 1_${ik}$ end if else ! a(:,q) is zero column - if( ir1==0 )notrot = notrot + 1 - pskipped = pskipped + 1 + if( ir1==0_${ik}$ )notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then - if( ir1==0 )aapp = -aapp - notrot = 0 + if( ir1==0_${ik}$ )aapp = -aapp + notrot = 0_${ik}$ go to 2103 end if end do loop_2002 @@ -15864,7 +15856,7 @@ module stdlib_linalg_lapack_${ci}$ sva( p ) = aapp else sva( p ) = aapp - if( ( ir1==0 ) .and. ( aapp==zero ) )notrot = notrot + min( igl+kbl-1, & + if( ( ir1==0_${ik}$ ) .and. ( aapp==zero ) )notrot = notrot + min( igl+kbl-1, & n ) - p end if end do loop_2001 @@ -15873,15 +15865,15 @@ module stdlib_linalg_lapack_${ci}$ end do loop_1002 ! end of ir1-loop ! ... go to the off diagonal blocks - igl = ( ibr-1 )*kbl + 1 + igl = ( ibr-1 )*kbl + 1_${ik}$ loop_2010: do jbc = ibr + 1, nbl - jgl = ( jbc-1 )*kbl + 1 + jgl = ( jbc-1 )*kbl + 1_${ik}$ ! doing the block at ( ibr, jbc ) - ijblsk = 0 + ijblsk = 0_${ik}$ loop_2100: do p = igl, min( igl+kbl-1, n ) aapp = sva( p ) if( aapp>zero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2200: do q = jgl, min( jgl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -15895,13 +15887,13 @@ module stdlib_linalg_lapack_${ci}$ rotok = ( small*aaqq )<=aapp end if if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_${ci}$dotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib${ii}$_${ci}$dotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq ) / aapp else - call stdlib_${ci}$copy( m, a( 1, p ), 1,cwork(n+1), 1 ) - call stdlib_${ci}$lascl( 'G', 0, 0, aapp,one, m, 1,cwork(n+1), & + call stdlib${ii}$_${ci}$copy( m, a( 1_${ik}$, p ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp,one, m, 1_${ik}$,cwork(n+1), & lda, ierr ) - aapq = stdlib_${ci}$dotc( m, cwork(n+1), 1,a( 1, q ), 1 ) / & + aapq = stdlib${ii}$_${ci}$dotc( m, cwork(n+1), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq end if else @@ -15911,13 +15903,13 @@ module stdlib_linalg_lapack_${ci}$ rotok = aaqq<=( aapp / small ) end if if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_${ci}$dotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / max(& + aapq = ( stdlib${ii}$_${ci}$dotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / max(& aaqq,aapp) )/ min(aaqq,aapp) else - call stdlib_${ci}$copy( m, a( 1, q ), 1,cwork(n+1), 1 ) - call stdlib_${ci}$lascl( 'G', 0, 0, aaqq,one, m, 1,cwork(n+1), & + call stdlib${ii}$_${ci}$copy( m, a( 1_${ik}$, q ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq,one, m, 1_${ik}$,cwork(n+1), & lda, ierr ) - aapq = stdlib_${ci}$dotc( m, a( 1, p ), 1,cwork(n+1), 1 ) / & + aapq = stdlib${ii}$_${ci}$dotc( m, a( 1_${ik}$, p ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) / & aapp end if end if @@ -15927,10 +15919,10 @@ module stdlib_linalg_lapack_${ci}$ ! to rotate or not to rotate, that is the question ... if( abs( aapq1 )>tol ) then ompq = aapq / abs(aapq) - notrot = 0 + notrot = 0_${ik}$ ! [rtd] rotated = rotated + 1 - pskipped = 0 - iswrot = iswrot + 1 + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ if( rotok ) then aqoap = aaqq / aapp apoaq = aapp / aaqq @@ -15939,10 +15931,10 @@ module stdlib_linalg_lapack_${ci}$ if( abs( theta )>bigtheta ) then t = half / theta cs = one - call stdlib_${ci}$rot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_${ci}$rot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *t ) if( rsvec ) then - call stdlib_${ci}$rot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_${ci}$rot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*t ) end if sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) @@ -15961,10 +15953,10 @@ module stdlib_linalg_lapack_${ci}$ sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq1 ) ) - call stdlib_${ci}$rot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_${ci}$rot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *sn ) if( rsvec ) then - call stdlib_${ci}$rot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_${ci}$rot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*sn ) end if end if @@ -15972,28 +15964,28 @@ module stdlib_linalg_lapack_${ci}$ else ! .. have to use modified gram-schmidt like transformation if( aapp>aaqq ) then - call stdlib_${ci}$copy( m, a( 1, p ), 1,cwork(n+1), 1 ) + call stdlib${ii}$_${ci}$copy( m, a( 1_${ik}$, p ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) - call stdlib_${ci}$lascl( 'G', 0, 0, aapp, one,m, 1, cwork(n+1)& + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, cwork(n+1)& ,lda,ierr ) - call stdlib_${ci}$lascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) - call stdlib_${ci}$axpy( m, -aapq, cwork(n+1),1, a( 1, q ), 1 ) + call stdlib${ii}$_${ci}$axpy( m, -aapq, cwork(n+1),1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) - call stdlib_${ci}$lascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq1*aapq1 ) ) mxsinj = max( mxsinj, sfmin ) else - call stdlib_${ci}$copy( m, a( 1, q ), 1,cwork(n+1), 1 ) - call stdlib_${ci}$lascl( 'G', 0, 0, aaqq, one,m, 1, cwork(n+1)& + call stdlib${ii}$_${ci}$copy( m, a( 1_${ik}$, q ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, cwork(n+1)& ,lda,ierr ) - call stdlib_${ci}$lascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) - call stdlib_${ci}$axpy( m, -conjg(aapq),cwork(n+1), 1, a( 1, & - p ), 1 ) - call stdlib_${ci}$lascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& + call stdlib${ii}$_${ci}$axpy( m, -conjg(aapq),cwork(n+1), 1_${ik}$, a( 1_${ik}$, & + p ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, aapp,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) sva( p ) = aapp*sqrt( max( zero,one-aapq1*aapq1 ) ) @@ -16003,47 +15995,47 @@ module stdlib_linalg_lapack_${ci}$ ! end if rotok then ... else ! in the case of cancellation in updating sva(q), sva(p) ! .. recompute sva(q), sva(p) - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_${c2ri(ci)}$znrm2( m, a( 1, q ), 1) + sva( q ) = stdlib${ii}$_${c2ri(ci)}$znrm2( m, a( 1_${ik}$, q ), 1_${ik}$) else t = zero aaqq = one - call stdlib_${ci}$lassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_${ci}$lassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq ) end if end if - if( ( aapp / aapp0 )**2<=rooteps ) then + if( ( aapp / aapp0 )**2_${ik}$<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_${c2ri(ci)}$znrm2( m, a( 1, p ), 1 ) + aapp = stdlib${ii}$_${c2ri(ci)}$znrm2( m, a( 1_${ik}$, p ), 1_${ik}$ ) else t = zero aapp = one - call stdlib_${ci}$lassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_${ci}$lassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp ) end if sva( p ) = aapp end if ! end of ok rotation else - notrot = notrot + 1 + notrot = notrot + 1_${ik}$ ! [rtd] skipped = skipped + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if else - notrot = notrot + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if if( ( i<=swband ) .and. ( ijblsk>=blskip ) )then sva( p ) = aapp - notrot = 0 + notrot = 0_${ik}$ go to 2011 end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then aapp = -aapp - notrot = 0 + notrot = 0_${ik}$ go to 2203 end if end do loop_2200 @@ -16051,8 +16043,8 @@ module stdlib_linalg_lapack_${ci}$ 2203 continue sva( p ) = aapp else - if( aapp==zero )notrot = notrot +min( jgl+kbl-1, n ) - jgl + 1 - if( aapprootsfmin ) )then - sva( n ) = stdlib_${c2ri(ci)}$znrm2( m, a( 1, n ), 1 ) + sva( n ) = stdlib${ii}$_${c2ri(ci)}$znrm2( m, a( 1_${ik}$, n ), 1_${ik}$ ) else t = zero aapp = one - call stdlib_${ci}$lassq( m, a( 1, n ), 1, t, aapp ) + call stdlib${ii}$_${ci}$lassq( m, a( 1_${ik}$, n ), 1_${ik}$, t, aapp ) sva( n ) = t*sqrt( aapp ) end if ! additional steering devices @@ -16085,81 +16077,81 @@ module stdlib_linalg_lapack_${ci}$ end do loop_1993 ! end i=1:nsweep loop ! #:( reaching this point means that the procedure has not converged. - info = nsweep - 1 + info = nsweep - 1_${ik}$ go to 1995 1994 continue ! #:) reaching this point means numerical convergence after the i-th ! sweep. - info = 0 + info = 0_${ik}$ ! #:) info = 0 confirms successful iterations. 1995 continue ! sort the singular values and find how many are above ! the underflow threshold. - n2 = 0 - n4 = 0 + n2 = 0_${ik}$ + n4 = 0_${ik}$ do p = 1, n - 1 - q = stdlib_i${c2ri(ci)}$amax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib${ii}$_i${c2ri(ci)}$amax( n-p+1, sva( p ), 1_${ik}$ ) + p - 1_${ik}$ if( p/=q ) then temp1 = sva( p ) sva( p ) = sva( q ) sva( q ) = temp1 - call stdlib_${ci}$swap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_${ci}$swap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) + call stdlib${ii}$_${ci}$swap( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) + if( rsvec )call stdlib${ii}$_${ci}$swap( mvl, v( 1_${ik}$, p ), 1_${ik}$, v( 1_${ik}$, q ), 1_${ik}$ ) end if if( sva( p )/=zero ) then - n4 = n4 + 1 - if( sva( p )*skl>sfmin )n2 = n2 + 1 + n4 = n4 + 1_${ik}$ + if( sva( p )*skl>sfmin )n2 = n2 + 1_${ik}$ end if end do if( sva( n )/=zero ) then - n4 = n4 + 1 - if( sva( n )*skl>sfmin )n2 = n2 + 1 + n4 = n4 + 1_${ik}$ + if( sva( n )*skl>sfmin )n2 = n2 + 1_${ik}$ end if ! normalize the left singular vectors. if( lsvec .or. uctol ) then do p = 1, n4 - ! call stdlib_${ci}$dscal( m, one / sva( p ), a( 1, p ), 1 ) - call stdlib_${ci}$lascl( 'G',0,0, sva(p), one, m, 1, a(1,p), m, ierr ) + ! call stdlib${ii}$_${ci}$dscal( m, one / sva( p ), a( 1, p ), 1 ) + call stdlib${ii}$_${ci}$lascl( 'G',0_${ik}$,0_${ik}$, sva(p), one, m, 1_${ik}$, a(1_${ik}$,p), m, ierr ) end do end if ! scale the product of jacobi rotations. if( rsvec ) then do p = 1, n - temp1 = one / stdlib_${c2ri(ci)}$znrm2( mvl, v( 1, p ), 1 ) - call stdlib_${ci}$dscal( mvl, temp1, v( 1, p ), 1 ) + temp1 = one / stdlib${ii}$_${c2ri(ci)}$znrm2( mvl, v( 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$dscal( mvl, temp1, v( 1_${ik}$, p ), 1_${ik}$ ) end do end if ! undo scaling, if necessary (and possible). - if( ( ( skl>one ) .and. ( sva( 1 )<( big / skl ) ) ).or. ( ( skl( sfmin / skl ) ) ) ) then + if( ( ( skl>one ) .and. ( sva( 1_${ik}$ )<( big / skl ) ) ).or. ( ( skl( sfmin / skl ) ) ) ) then do p = 1, n sva( p ) = skl*sva( p ) end do skl = one end if - rwork( 1 ) = skl + rwork( 1_${ik}$ ) = skl ! the singular values of a are skl*sva(1:n). if skl/=one ! then some of the singular values may overflow or underflow and ! the spectrum is given in this factored representation. - rwork( 2 ) = real( n4,KIND=${ck}$) + rwork( 2_${ik}$ ) = real( n4,KIND=${ck}$) ! n4 is the number of computed nonzero singular values of a. - rwork( 3 ) = real( n2,KIND=${ck}$) + rwork( 3_${ik}$ ) = real( n2,KIND=${ck}$) ! n2 is the number of singular values of a greater than sfmin. ! if n20 ) then + info = -11_${ik}$ + else if( n>0_${ik}$ ) then rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) else rowcnd = one end if end if - if( colequ .and. info==0 ) then + if( colequ .and. info==0_${ik}$ ) then rcmin = bignum rcmax = zero do j = 1, n @@ -16247,31 +16239,31 @@ module stdlib_linalg_lapack_${ci}$ rcmax = max( rcmax, c( j ) ) end do if( rcmin<=zero ) then - info = -12 - else if( n>0 ) then + info = -12_${ik}$ + else if( n>0_${ik}$ ) then colcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) else colcnd = one end if end if - if( info==0 ) then - if( ldb0 ) then + if( info>0_${ik}$ ) then ! compute the reciprocal pivot growth factor of the ! leading rank-deficient info columns of a. - rpvgrw = stdlib_${ci}$lantr( 'M', 'U', 'N', info, info, af, ldaf,rwork ) + rpvgrw = stdlib${ii}$_${ci}$lantr( 'M', 'U', 'N', info, info, af, ldaf,rwork ) if( rpvgrw==zero ) then rpvgrw = one else - rpvgrw = stdlib_${ci}$lange( 'M', n, info, a, lda, rwork ) /rpvgrw + rpvgrw = stdlib${ii}$_${ci}$lange( 'M', n, info, a, lda, rwork ) /rpvgrw end if - rwork( 1 ) = rpvgrw + rwork( 1_${ik}$ ) = rpvgrw rcond = zero return end if @@ -16318,21 +16310,21 @@ module stdlib_linalg_lapack_${ci}$ else norm = 'I' end if - anorm = stdlib_${ci}$lange( norm, n, n, a, lda, rwork ) - rpvgrw = stdlib_${ci}$lantr( 'M', 'U', 'N', n, n, af, ldaf, rwork ) + anorm = stdlib${ii}$_${ci}$lange( norm, n, n, a, lda, rwork ) + rpvgrw = stdlib${ii}$_${ci}$lantr( 'M', 'U', 'N', n, n, af, ldaf, rwork ) if( rpvgrw==zero ) then rpvgrw = one else - rpvgrw = stdlib_${ci}$lange( 'M', n, n, a, lda, rwork ) / rpvgrw + rpvgrw = stdlib${ii}$_${ci}$lange( 'M', n, n, a, lda, rwork ) / rpvgrw end if ! compute the reciprocal of the condition number of a. - call stdlib_${ci}$gecon( norm, n, af, ldaf, anorm, rcond, work, rwork, info ) + call stdlib${ii}$_${ci}$gecon( norm, n, af, ldaf, anorm, rcond, work, rwork, info ) ! compute the solution matrix x. - call stdlib_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_${ci}$getrs( trans, n, nrhs, af, ldaf, ipiv, x, ldx, info ) + call stdlib${ii}$_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_${ci}$getrs( trans, n, nrhs, af, ldaf, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_${ci}$gerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & + call stdlib${ii}$_${ci}$gerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & work, rwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -16358,13 +16350,13 @@ module stdlib_linalg_lapack_${ci}$ end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond= sfmin ) then - call stdlib_${ci}$scal( m-j, cone / a( j, j ), a( j+1, j ), 1 ) + call stdlib${ii}$_${ci}$scal( m-j, cone / 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=min( m, n ) ) then + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGETRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=min( m, n ) ) then ! use unblocked code. - call stdlib_${ci}$getrf2( m, n, a, lda, ipiv, info ) + call stdlib${ii}$_${ci}$getrf2( m, n, a, lda, ipiv, info ) else ! use blocked code. do j = 1, min( m, n ), nb jb = min( min( m, n )-j+1, nb ) ! factor diagonal and subdiagonal blocks and test for exact ! singularity. - call stdlib_${ci}$getrf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo ) + call stdlib${ii}$_${ci}$getrf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo ) ! adjust info and the pivot indices. - if( info==0 .and. iinfo>0 )info = iinfo + j - 1 + if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + j - 1_${ik}$ do i = j, min( m, j+jb-1 ) - ipiv( i ) = j - 1 + ipiv( i ) + ipiv( i ) = j - 1_${ik}$ + ipiv( i ) end do ! apply interchanges to columns 1:j-1. - call stdlib_${ci}$laswp( j-1, a, lda, j, j+jb-1, ipiv, 1 ) + call stdlib${ii}$_${ci}$laswp( j-1, a, lda, j, j+jb-1, ipiv, 1_${ik}$ ) if( j+jb<=n ) then ! apply interchanges to columns j+jb:n. - call stdlib_${ci}$laswp( n-j-jb+1, a( 1, j+jb ), lda, j, j+jb-1,ipiv, 1 ) + call stdlib${ii}$_${ci}$laswp( n-j-jb+1, a( 1_${ik}$, j+jb ), lda, j, j+jb-1,ipiv, 1_${ik}$ ) ! compute block row of u. - call stdlib_${ci}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, cone,& + call stdlib${ii}$_${ci}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, cone,& a( j, j ), lda, a( j, j+jb ),lda ) if( j+jb<=m ) then ! update trailing submatrix. - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& cone, a( j+jb, j ), lda,a( j, j+jb ), lda, cone, a( j+jb, j+jb ),lda ) end if @@ -16596,10 +16588,10 @@ module stdlib_linalg_lapack_${ci}$ end do end if return - end subroutine stdlib_${ci}$getrf + end subroutine stdlib${ii}$_${ci}$getrf - pure recursive subroutine stdlib_${ci}$getrf2( m, n, a, lda, ipiv, info ) + pure recursive subroutine stdlib${ii}$_${ci}$getrf2( m, n, a, lda, ipiv, info ) !! ZGETRF2: computes an LU factorization of a general M-by-N matrix A !! using partial pivoting with row interchanges. !! The factorization has the form @@ -16623,99 +16615,99 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars real(${ck}$) :: sfmin complex(${ck}$) :: temp - integer(ilp) :: i, iinfo, n1, n2 + integer(${ik}$) :: i, iinfo, n1, n2 ! 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_${ci}$scal( m-1, cone / a( 1, 1 ), a( 2, 1 ), 1 ) + if( abs(a( 1_${ik}$, 1_${ik}$ )) >= sfmin ) then + call stdlib${ii}$_${ci}$scal( m-1, cone / 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_${ci}$getrf2( m, n1, a, lda, ipiv, iinfo ) - if ( info==0 .and. iinfo>0 )info = iinfo + call stdlib${ii}$_${ci}$getrf2( m, n1, a, lda, ipiv, iinfo ) + if ( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo ! [ a12 ] ! apply interchanges to [ --- ] ! [ a22 ] - call stdlib_${ci}$laswp( n2, a( 1, n1+1 ), lda, 1, n1, ipiv, 1 ) + call stdlib${ii}$_${ci}$laswp( n2, a( 1_${ik}$, n1+1 ), lda, 1_${ik}$, n1, ipiv, 1_${ik}$ ) ! solve a12 - call stdlib_${ci}$trsm( 'L', 'L', 'N', 'U', n1, n2, cone, a, lda,a( 1, n1+1 ), lda ) + call stdlib${ii}$_${ci}$trsm( 'L', 'L', 'N', 'U', n1, n2, cone, a, lda,a( 1_${ik}$, n1+1 ), lda ) ! update a22 - call stdlib_${ci}$gemm( 'N', 'N', m-n1, n2, n1, -cone, a( n1+1, 1 ), lda,a( 1, n1+1 ), & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', m-n1, n2, n1, -cone, a( n1+1, 1_${ik}$ ), lda,a( 1_${ik}$, n1+1 ), & lda, cone, a( n1+1, n1+1 ), lda ) ! factor a22 - call stdlib_${ci}$getrf2( m-n1, n2, a( n1+1, n1+1 ), lda, ipiv( n1+1 ),iinfo ) + call stdlib${ii}$_${ci}$getrf2( m-n1, n2, a( n1+1, n1+1 ), lda, ipiv( n1+1 ),iinfo ) ! adjust info and the pivot indices - if ( info==0 .and. iinfo>0 )info = iinfo + n1 + 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_${ci}$laswp( n1, a( 1, 1 ), lda, n1+1, min( m, n), ipiv, 1 ) + call stdlib${ii}$_${ci}$laswp( n1, a( 1_${ik}$, 1_${ik}$ ), lda, n1+1, min( m, n), ipiv, 1_${ik}$ ) end if return - end subroutine stdlib_${ci}$getrf2 + end subroutine stdlib${ii}$_${ci}$getrf2 - pure subroutine stdlib_${ci}$getri( n, a, lda, ipiv, work, lwork, info ) + pure subroutine stdlib${ii}$_${ci}$getri( n, a, lda, ipiv, work, lwork, info ) !! ZGETRI: computes the inverse of a matrix using the LU factorization !! computed by ZGETRF. !! This method inverts U and then computes inv(A) by solving the system @@ -16724,52 +16716,52 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), 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, 'ZGETRI', ' ', n, -1, -1, -1 ) + info = 0_${ik}$ + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGETRI', ' ', 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_${ci}$trtri, then u is singular, + ! form inv(u). if info > 0 from stdlib${ii}$_${ci}$trtri, then u is singular, ! and the inverse is not computed. - call stdlib_${ci}$trtri( 'UPPER', 'NON-UNIT', n, a, lda, info ) + call stdlib${ii}$_${ci}$trtri( '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. nb=n ) then - call stdlib_${ci}$geqr( m, n, a, lda, tq, -1, workq, -1, info2 ) - tszo = int( tq( 1 ),KIND=ilp) - lwo = int( workq( 1 ),KIND=ilp) - call stdlib_${ci}$gemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszo, b, ldb, workq, -1, & + call stdlib${ii}$_${ci}$geqr( m, n, a, lda, tq, -1_${ik}$, workq, -1_${ik}$, info2 ) + tszo = int( tq( 1_${ik}$ ),KIND=${ik}$) + lwo = int( workq( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_${ci}$gemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszo, b, ldb, workq, -1_${ik}$, & info2 ) - lwo = max( lwo, int( workq( 1 ),KIND=ilp) ) - call stdlib_${ci}$geqr( m, n, a, lda, tq, -2, workq, -2, info2 ) - tszm = int( tq( 1 ),KIND=ilp) - lwm = int( workq( 1 ),KIND=ilp) - call stdlib_${ci}$gemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszm, b, ldb, workq, -1, & + lwo = max( lwo, int( workq( 1_${ik}$ ),KIND=${ik}$) ) + call stdlib${ii}$_${ci}$geqr( m, n, a, lda, tq, -2_${ik}$, workq, -2_${ik}$, info2 ) + tszm = int( tq( 1_${ik}$ ),KIND=${ik}$) + lwm = int( workq( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_${ci}$gemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszm, b, ldb, workq, -1_${ik}$, & info2 ) - lwm = max( lwm, int( workq( 1 ),KIND=ilp) ) + lwm = max( lwm, int( workq( 1_${ik}$ ),KIND=${ik}$) ) wsizeo = tszo + lwo wsizem = tszm + lwm else - call stdlib_${ci}$gelq( m, n, a, lda, tq, -1, workq, -1, info2 ) - tszo = int( tq( 1 ),KIND=ilp) - lwo = int( workq( 1 ),KIND=ilp) - call stdlib_${ci}$gemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszo, b, ldb, workq, -1, & + call stdlib${ii}$_${ci}$gelq( m, n, a, lda, tq, -1_${ik}$, workq, -1_${ik}$, info2 ) + tszo = int( tq( 1_${ik}$ ),KIND=${ik}$) + lwo = int( workq( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_${ci}$gemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszo, b, ldb, workq, -1_${ik}$, & info2 ) - lwo = max( lwo, int( workq( 1 ),KIND=ilp) ) - call stdlib_${ci}$gelq( m, n, a, lda, tq, -2, workq, -2, info2 ) - tszm = int( tq( 1 ),KIND=ilp) - lwm = int( workq( 1 ),KIND=ilp) - call stdlib_${ci}$gemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszm, b, ldb, workq, -1, & + lwo = max( lwo, int( workq( 1_${ik}$ ),KIND=${ik}$) ) + call stdlib${ii}$_${ci}$gelq( m, n, a, lda, tq, -2_${ik}$, workq, -2_${ik}$, info2 ) + tszm = int( tq( 1_${ik}$ ),KIND=${ik}$) + lwm = int( workq( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_${ci}$gemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszm, b, ldb, workq, -1_${ik}$, & info2 ) - lwm = max( lwm, int( workq( 1 ),KIND=ilp) ) + lwm = max( lwm, int( workq( 1_${ik}$ ),KIND=${ik}$) ) wsizeo = tszo + lwo wsizem = tszm + lwm end if if( ( lworkzero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_${ci}$lascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_${ci}$laset( 'F', maxmn, nrhs, czero, czero, b, ldb ) + call stdlib${ii}$_${ci}$laset( 'F', maxmn, nrhs, czero, czero, b, ldb ) go to 50 end if brow = m if ( tran ) then brow = n end if - bnrm = stdlib_${ci}$lange( 'M', brow, nrhs, b, ldb, dum ) - ibscl = 0 + bnrm = stdlib${ii}$_${ci}$lange( 'M', brow, nrhs, b, ldb, dum ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_${ci}$lascl( 'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,info ) - ibscl = 2 + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, brow, nrhs, b, ldb,info ) + ibscl = 2_${ik}$ end if if ( m>=n ) then ! compute qr factorization of a - call stdlib_${ci}$geqr( m, n, a, lda, work( lw2+1 ), lw1,work( 1 ), lw2, info ) + call stdlib${ii}$_${ci}$geqr( m, n, a, lda, work( lw2+1 ), lw1,work( 1_${ik}$ ), lw2, info ) if ( .not.tran ) then ! least-squares problem min || a * x - b || ! b(1:m,1:nrhs) := q**t * b(1:m,1:nrhs) - call stdlib_${ci}$gemqr( 'L' , 'C', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, work(& - 1 ), lw2,info ) + call stdlib${ii}$_${ci}$gemqr( 'L' , 'C', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, work(& + 1_${ik}$ ), lw2,info ) ! b(1:n,1:nrhs) := inv(r) * b(1:n,1:nrhs) - call stdlib_${ci}$trtrs( 'U', 'N', 'N', n, nrhs,a, lda, b, ldb, info ) - if( info>0 ) then + call stdlib${ii}$_${ci}$trtrs( 'U', 'N', 'N', n, nrhs,a, lda, b, ldb, info ) + if( info>0_${ik}$ ) then return end if scllen = n else ! overdetermined system of equations a**t * x = b ! b(1:n,1:nrhs) := inv(r**t) * b(1:n,1:nrhs) - call stdlib_${ci}$trtrs( 'U', 'C', 'N', n, nrhs,a, lda, b, ldb, info ) - if( info>0 ) then + call stdlib${ii}$_${ci}$trtrs( 'U', 'C', 'N', n, nrhs,a, lda, b, ldb, info ) + if( info>0_${ik}$ ) then return end if ! b(n+1:m,1:nrhs) = czero @@ -17066,19 +17058,19 @@ module stdlib_linalg_lapack_${ci}$ end do end do ! b(1:m,1:nrhs) := q(1:n,:) * b(1:n,1:nrhs) - call stdlib_${ci}$gemqr( 'L', 'N', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, & - work( 1 ), lw2,info ) + call stdlib${ii}$_${ci}$gemqr( 'L', 'N', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, & + work( 1_${ik}$ ), lw2,info ) scllen = m end if else ! compute lq factorization of a - call stdlib_${ci}$gelq( m, n, a, lda, work( lw2+1 ), lw1,work( 1 ), lw2, info ) + call stdlib${ii}$_${ci}$gelq( m, n, a, lda, work( lw2+1 ), lw1,work( 1_${ik}$ ), lw2, info ) ! workspace at least m, optimally m*nb. if( .not.tran ) then ! underdetermined system of equations a * x = b ! b(1:m,1:nrhs) := inv(l) * b(1:m,1:nrhs) - call stdlib_${ci}$trtrs( 'L', 'N', 'N', m, nrhs,a, lda, b, ldb, info ) - if( info>0 ) then + call stdlib${ii}$_${ci}$trtrs( 'L', 'N', 'N', m, nrhs,a, lda, b, ldb, info ) + if( info>0_${ik}$ ) then return end if ! b(m+1:n,1:nrhs) = 0 @@ -17088,42 +17080,42 @@ module stdlib_linalg_lapack_${ci}$ end do end do ! b(1:n,1:nrhs) := q(1:n,:)**t * b(1:m,1:nrhs) - call stdlib_${ci}$gemlq( 'L', 'C', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & - work( 1 ), lw2,info ) + call stdlib${ii}$_${ci}$gemlq( 'L', 'C', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & + work( 1_${ik}$ ), lw2,info ) ! workspace at least nrhs, optimally nrhs*nb scllen = n else ! overdetermined system min || a**t * x - b || ! b(1:n,1:nrhs) := q * b(1:n,1:nrhs) - call stdlib_${ci}$gemlq( 'L', 'N', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & - work( 1 ), lw2,info ) + call stdlib${ii}$_${ci}$gemlq( 'L', 'N', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & + work( 1_${ik}$ ), lw2,info ) ! workspace at least nrhs, optimally nrhs*nb ! b(1:m,1:nrhs) := inv(l**t) * b(1:m,1:nrhs) - call stdlib_${ci}$trtrs( 'L', 'C', 'N', m, nrhs,a, lda, b, ldb, info ) - if( info>0 ) then + call stdlib${ii}$_${ci}$trtrs( 'L', 'C', 'N', m, nrhs,a, lda, b, ldb, info ) + if( info>0_${ik}$ ) then return end if scllen = m end if end if ! undo scaling - if( iascl==1 ) then - call stdlib_${ci}$lascl( 'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,info ) - else if( iascl==2 ) then - call stdlib_${ci}$lascl( 'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,info ) + if( iascl==1_${ik}$ ) then + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, smlnum, scllen, nrhs, b, ldb,info ) + else if( iascl==2_${ik}$ ) then + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, scllen, nrhs, b, ldb,info ) end if - if( ibscl==1 ) then - call stdlib_${ci}$lascl( 'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,info ) - else if( ibscl==2 ) then - call stdlib_${ci}$lascl( 'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,info ) + if( ibscl==1_${ik}$ ) then + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, bnrm, scllen, nrhs, b, ldb,info ) + else if( ibscl==2_${ik}$ ) then + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bignum, bnrm, scllen, nrhs, b, ldb,info ) end if 50 continue - work( 1 ) = real( tszo + lwo,KIND=${ck}$) + work( 1_${ik}$ ) = real( tszo + lwo,KIND=${ck}$) return - end subroutine stdlib_${ci}$getsls + end subroutine stdlib${ii}$_${ci}$getsls - pure subroutine stdlib_${ci}$getsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) + pure subroutine stdlib${ii}$_${ci}$getsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) !! ZGETSQRHRT: computes a NB2-sized column blocked QR-factorization !! of a complex M-by-N matrix A with M >= N, !! A = Q * R. @@ -17141,8 +17133,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, nb1, nb2, mb1 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldt, lwork, m, n, nb1, nb2, mb1 ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: t(ldt,*), work(*) @@ -17150,41 +17142,41 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, iinfo, j, lw1, lw2, lwt, ldwt, lworkopt, nb1local, nb2local, & + integer(${ik}$) :: i, iinfo, j, lw1, lw2, lwt, ldwt, lworkopt, nb1local, nb2local, & num_all_row_blocks ! Intrinsic Functions intrinsic :: ceiling,real,cmplx,max,min ! Executable Statements ! test the input arguments - info = 0 - lquery = lwork==-1 - if( m<0 ) then - info = -1 - else if( n<0 .or. m0 .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( ldvzero .and. anrmzero .and. bnrm1 ) then - call stdlib_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& + call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vsl, ldvsl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& , ldvsl ) end if - call stdlib_${ci}$ungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & + call stdlib${ii}$_${ci}$ungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vsr - if( ilvsr )call stdlib_${ci}$laset( 'FULL', n, n, czero, cone, vsr, ldvsr ) + if( ilvsr )call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vsr, ldvsr ) ! reduce to generalized hessenberg form ! (workspace: none needed) - call stdlib_${ci}$gghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& + call stdlib${ii}$_${ci}$gghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& ierr ) - sdim = 0 + sdim = 0_${ik}$ ! perform qz algorithm, computing schur vectors if desired ! (complex workspace: need n) ! (real workspace: need n) iwrk = itau - call stdlib_${ci}$hgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, & + call stdlib${ii}$_${ci}$hgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, & ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 30 end if @@ -17880,52 +17872,52 @@ module stdlib_linalg_lapack_${ci}$ ! (workspace: none needed) if( wantst ) then ! undo scaling on eigenvalues before selecting - if( ilascl )call stdlib_${ci}$lascl( 'G', 0, 0, anrm, anrmto, n, 1, alpha, n, ierr ) + if( ilascl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, 1_${ik}$, alpha, n, ierr ) - if( ilbscl )call stdlib_${ci}$lascl( 'G', 0, 0, bnrm, bnrmto, n, 1, beta, n, ierr ) + if( ilbscl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, 1_${ik}$, beta, n, ierr ) ! select eigenvalues do i = 1, n bwork( i ) = selctg( alpha( i ), beta( i ) ) end do - call stdlib_${ci}$tgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,beta, vsl, & - ldvsl, vsr, ldvsr, sdim, pvsl, pvsr,dif, work( iwrk ), lwork-iwrk+1, idum, 1, ierr ) + call stdlib${ii}$_${ci}$tgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,beta, vsl, & + ldvsl, vsr, ldvsr, sdim, pvsl, pvsr,dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$, ierr ) - if( ierr==1 )info = n + 3 + if( ierr==1_${ik}$ )info = n + 3_${ik}$ end if ! apply back-permutation to vsl and vsr ! (workspace: none needed) - if( ilvsl )call stdlib_${ci}$ggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), & + if( ilvsl )call stdlib${ii}$_${ci}$ggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), & n, vsl, ldvsl, ierr ) - if( ilvsr )call stdlib_${ci}$ggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), & + if( ilvsr )call stdlib${ii}$_${ci}$ggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), & n, vsr, ldvsr, ierr ) ! undo scaling if( ilascl ) then - call stdlib_${ci}$lascl( 'U', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) - call stdlib_${ci}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) + call stdlib${ii}$_${ci}$lascl( 'U', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr ) end if if( ilbscl ) then - call stdlib_${ci}$lascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) - call stdlib_${ci}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + call stdlib${ii}$_${ci}$lascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) end if if( wantst ) then ! check if reordering is correct lastsl = .true. - sdim = 0 + sdim = 0_${ik}$ do i = 1, n cursl = selctg( alpha( i ), beta( i ) ) - if( cursl )sdim = sdim + 1 - if( cursl .and. .not.lastsl )info = n + 2 + if( cursl )sdim = sdim + 1_${ik}$ + if( cursl .and. .not.lastsl )info = n + 2_${ik}$ lastsl = cursl end do end if 30 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ci}$gges + end subroutine stdlib${ii}$_${ci}$gges - subroutine stdlib_${ci}$gges3( jobvsl, jobvsr, sort, selctg, n, a, lda, b,ldb, sdim, alpha, beta, & + subroutine stdlib${ii}$_${ci}$gges3( jobvsl, jobvsr, sort, selctg, n, a, lda, b,ldb, sdim, alpha, beta, & !! ZGGES3: computes for a pair of N-by-N complex nonsymmetric matrices !! (A,B), the generalized eigenvalues, the generalized complex Schur !! form (S, T), and optionally left and/or right Schur vectors (VSL @@ -17952,8 +17944,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvsl, jobvsr, sort - integer(ilp), intent(out) :: info, sdim - integer(ilp), intent(in) :: lda, ldb, ldvsl, ldvsr, lwork, n + integer(${ik}$), intent(out) :: info, sdim + integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, lwork, n ! Array Arguments logical(lk), intent(out) :: bwork(*) real(${ck}$), intent(out) :: rwork(*) @@ -17967,102 +17959,102 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, wantst - integer(ilp) :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, iright, irows, irwrk, & + integer(${ik}$) :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, iright, irows, irwrk, & itau, iwrk, lwkopt real(${ck}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl, pvsr, smlnum ! Local Arrays - integer(ilp) :: idum(1) - real(${ck}$) :: dif(2) + integer(${ik}$) :: idum(1_${ik}$) + real(${ck}$) :: dif(2_${ik}$) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvsl, 'N' ) ) then - ijobvl = 1 + ijobvl = 1_${ik}$ ilvsl = .false. else if( stdlib_lsame( jobvsl, 'V' ) ) then - ijobvl = 2 + ijobvl = 2_${ik}$ ilvsl = .true. else - ijobvl = -1 + ijobvl = -1_${ik}$ ilvsl = .false. end if if( stdlib_lsame( jobvsr, 'N' ) ) then - ijobvr = 1 + ijobvr = 1_${ik}$ ilvsr = .false. else if( stdlib_lsame( jobvsr, 'V' ) ) then - ijobvr = 2 + ijobvr = 2_${ik}$ ilvsr = .true. else - ijobvr = -1 + ijobvr = -1_${ik}$ ilvsr = .false. end if wantst = stdlib_lsame( sort, 'S' ) ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( ijobvl<=0 ) then - info = -1 - else if( ijobvr<=0 ) then - info = -2 + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) + if( ijobvl<=0_${ik}$ ) then + info = -1_${ik}$ + else if( ijobvr<=0_${ik}$ ) then + info = -2_${ik}$ else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then - info = -3 - else if( n<0 ) then - info = -5 - else if( ldazero .and. anrmzero .and. bnrm1 ) then - call stdlib_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& + call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vsl, ldvsl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& , ldvsl ) end if - call stdlib_${ci}$ungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & + call stdlib${ii}$_${ci}$ungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vsr - if( ilvsr )call stdlib_${ci}$laset( 'FULL', n, n, czero, cone, vsr, ldvsr ) + if( ilvsr )call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vsr, ldvsr ) ! reduce to generalized hessenberg form - call stdlib_${ci}$gghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& + call stdlib${ii}$_${ci}$gghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& work( iwrk ), lwork+1-iwrk, ierr ) - sdim = 0 + sdim = 0_${ik}$ ! perform qz algorithm, computing schur vectors if desired iwrk = itau - call stdlib_${ci}$laqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, & - ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), 0, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + call stdlib${ii}$_${ci}$laqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, & + ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), 0_${ik}$, ierr ) + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 30 end if ! sort eigenvalues alpha/beta if desired if( wantst ) then ! undo scaling on eigenvalues before selecting - if( ilascl )call stdlib_${ci}$lascl( 'G', 0, 0, anrm, anrmto, n, 1, alpha, n, ierr ) + if( ilascl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, 1_${ik}$, alpha, n, ierr ) - if( ilbscl )call stdlib_${ci}$lascl( 'G', 0, 0, bnrm, bnrmto, n, 1, beta, n, ierr ) + if( ilbscl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, 1_${ik}$, beta, n, ierr ) ! select eigenvalues do i = 1, n bwork( i ) = selctg( alpha( i ), beta( i ) ) end do - call stdlib_${ci}$tgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,beta, vsl, & - ldvsl, vsr, ldvsr, sdim, pvsl, pvsr,dif, work( iwrk ), lwork-iwrk+1, idum, 1, ierr ) + call stdlib${ii}$_${ci}$tgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,beta, vsl, & + ldvsl, vsr, ldvsr, sdim, pvsl, pvsr,dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$, ierr ) - if( ierr==1 )info = n + 3 + if( ierr==1_${ik}$ )info = n + 3_${ik}$ end if ! apply back-permutation to vsl and vsr - if( ilvsl )call stdlib_${ci}$ggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), & + if( ilvsl )call stdlib${ii}$_${ci}$ggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), & n, vsl, ldvsl, ierr ) - if( ilvsr )call stdlib_${ci}$ggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), & + if( ilvsr )call stdlib${ii}$_${ci}$ggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), & n, vsr, ldvsr, ierr ) ! undo scaling if( ilascl ) then - call stdlib_${ci}$lascl( 'U', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) - call stdlib_${ci}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) + call stdlib${ii}$_${ci}$lascl( 'U', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr ) end if if( ilbscl ) then - call stdlib_${ci}$lascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) - call stdlib_${ci}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + call stdlib${ii}$_${ci}$lascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) end if if( wantst ) then ! check if reordering is correct lastsl = .true. - sdim = 0 + sdim = 0_${ik}$ do i = 1, n cursl = selctg( alpha( i ), beta( i ) ) - if( cursl )sdim = sdim + 1 - if( cursl .and. .not.lastsl )info = n + 2 + if( cursl )sdim = sdim + 1_${ik}$ + if( cursl .and. .not.lastsl )info = n + 2_${ik}$ lastsl = cursl end do end if 30 continue - work( 1 ) = cmplx( lwkopt,KIND=${ck}$) + work( 1_${ik}$ ) = cmplx( lwkopt,KIND=${ck}$) return - end subroutine stdlib_${ci}$gges3 + end subroutine stdlib${ii}$_${ci}$gges3 - subroutine stdlib_${ci}$ggesx( jobvsl, jobvsr, sort, selctg, sense, n, a, lda,b, ldb, sdim, alpha,& + subroutine stdlib${ii}$_${ci}$ggesx( jobvsl, jobvsr, sort, selctg, sense, n, a, lda,b, ldb, sdim, alpha,& !! ZGGESX: computes for a pair of N-by-N complex nonsymmetric matrices !! (A,B), the generalized eigenvalues, the complex Schur form (S,T), !! and, optionally, the left and/or right matrices of Schur vectors (VSL @@ -18206,12 +18198,12 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvsl, jobvsr, sense, sort - integer(ilp), intent(out) :: info, sdim - integer(ilp), intent(in) :: lda, ldb, ldvsl, ldvsr, liwork, lwork, n + integer(${ik}$), intent(out) :: info, sdim + integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, liwork, lwork, n ! Array Arguments logical(lk), intent(out) :: bwork(*) - integer(ilp), intent(out) :: iwork(*) - real(${ck}$), intent(out) :: rconde(2), rcondv(2), rwork(*) + integer(${ik}$), intent(out) :: iwork(*) + real(${ck}$), intent(out) :: rconde(2_${ik}$), rcondv(2_${ik}$), rwork(*) complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) complex(${ck}$), intent(out) :: alpha(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), work(*) @@ -18223,33 +18215,33 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, wantsb, wantse, & wantsn, wantst, wantsv - integer(ilp) :: i, icols, ierr, ihi, ijob, ijobvl, ijobvr, ileft, ilo, iright, irows, & + integer(${ik}$) :: i, icols, ierr, ihi, ijob, ijobvl, ijobvr, ileft, ilo, iright, irows, & irwrk, itau, iwrk, liwmin, lwrk, maxwrk, minwrk real(${ck}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pl, pr, smlnum ! Local Arrays - real(${ck}$) :: dif(2) + real(${ck}$) :: dif(2_${ik}$) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvsl, 'N' ) ) then - ijobvl = 1 + ijobvl = 1_${ik}$ ilvsl = .false. else if( stdlib_lsame( jobvsl, 'V' ) ) then - ijobvl = 2 + ijobvl = 2_${ik}$ ilvsl = .true. else - ijobvl = -1 + ijobvl = -1_${ik}$ ilvsl = .false. end if if( stdlib_lsame( jobvsr, 'N' ) ) then - ijobvr = 1 + ijobvr = 1_${ik}$ ilvsr = .false. else if( stdlib_lsame( jobvsr, 'V' ) ) then - ijobvr = 2 + ijobvr = 2_${ik}$ ilvsr = .true. else - ijobvr = -1 + ijobvr = -1_${ik}$ ilvsr = .false. end if wantst = stdlib_lsame( sort, 'S' ) @@ -18257,94 +18249,94 @@ module stdlib_linalg_lapack_${ci}$ wantse = stdlib_lsame( sense, 'E' ) wantsv = stdlib_lsame( sense, 'V' ) wantsb = stdlib_lsame( sense, 'B' ) - lquery = ( lwork==-1 .or. liwork==-1 ) + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) if( wantsn ) then - ijob = 0 + ijob = 0_${ik}$ else if( wantse ) then - ijob = 1 + ijob = 1_${ik}$ else if( wantsv ) then - ijob = 2 + ijob = 2_${ik}$ else if( wantsb ) then - ijob = 4 + ijob = 4_${ik}$ end if ! test the input arguments - info = 0 - if( ijobvl<=0 ) then - info = -1 - else if( ijobvr<=0 ) then - info = -2 + info = 0_${ik}$ + if( ijobvl<=0_${ik}$ ) then + info = -1_${ik}$ + else if( ijobvr<=0_${ik}$ ) then + info = -2_${ik}$ else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then - info = -3 + info = -3_${ik}$ else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. & .not.wantsn ) ) then - info = -5 - else if( n<0 ) then - info = -6 - else if( lda0) then - minwrk = 2*n - maxwrk = n*(1 + stdlib_ilaenv( 1, 'ZGEQRF', ' ', n, 1, n, 0 ) ) - maxwrk = max( maxwrk, n*( 1 +stdlib_ilaenv( 1, 'ZUNMQR', ' ', n, 1, n, -1 ) ) ) + ! following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + if( n>0_${ik}$) then + minwrk = 2_${ik}$*n + maxwrk = n*(1_${ik}$ + stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) ) + maxwrk = max( maxwrk, n*( 1_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) ) ) if( ilvsl ) then - maxwrk = max( maxwrk, n*( 1 +stdlib_ilaenv( 1, 'ZUNGQR', ' ', n, 1, n, -1 ) ) & + maxwrk = max( maxwrk, n*( 1_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) ) & ) end if lwrk = maxwrk - if( ijob>=1 )lwrk = max( lwrk, n*n/2 ) + if( ijob>=1_${ik}$ )lwrk = max( lwrk, n*n/2_${ik}$ ) else - minwrk = 1 - maxwrk = 1 - lwrk = 1 + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + lwrk = 1_${ik}$ end if - work( 1 ) = lwrk - if( wantsn .or. n==0 ) then - liwmin = 1 + work( 1_${ik}$ ) = lwrk + if( wantsn .or. n==0_${ik}$ ) then + liwmin = 1_${ik}$ else - liwmin = n + 2 + liwmin = n + 2_${ik}$ end if - iwork( 1 ) = liwmin + iwork( 1_${ik}$ ) = liwmin if( lworkzero .and. anrmzero .and. bnrm1 ) then - call stdlib_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& + call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vsl, ldvsl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& , ldvsl ) end if - call stdlib_${ci}$ungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & + call stdlib${ii}$_${ci}$ungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vsr - if( ilvsr )call stdlib_${ci}$laset( 'FULL', n, n, czero, cone, vsr, ldvsr ) + if( ilvsr )call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vsr, ldvsr ) ! reduce to generalized hessenberg form ! (workspace: none needed) - call stdlib_${ci}$gghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& + call stdlib${ii}$_${ci}$gghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& ierr ) - sdim = 0 + sdim = 0_${ik}$ ! perform qz algorithm, computing schur vectors if desired ! (complex workspace: need n) ! (real workspace: need n) iwrk = itau - call stdlib_${ci}$hgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, & + call stdlib${ii}$_${ci}$hgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, & ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 40 end if @@ -18422,9 +18414,9 @@ module stdlib_linalg_lapack_${ci}$ ! condition number(s) if( wantst ) then ! undo scaling on eigenvalues before selctging - if( ilascl )call stdlib_${ci}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) + if( ilascl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr ) - if( ilbscl )call stdlib_${ci}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + if( ilbscl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) ! select eigenvalues do i = 1, n @@ -18434,59 +18426,59 @@ module stdlib_linalg_lapack_${ci}$ ! compute reciprocal condition numbers ! (complex workspace: if ijob >= 1, need max(1, 2*sdim*(n-sdim)) ! otherwise, need 1 ) - call stdlib_${ci}$tgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alpha, beta, vsl, & + call stdlib${ii}$_${ci}$tgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alpha, beta, vsl, & ldvsl, vsr, ldvsr, sdim, pl, pr,dif, work( iwrk ), lwork-iwrk+1, iwork, liwork,ierr & ) - if( ijob>=1 )maxwrk = max( maxwrk, 2*sdim*( n-sdim ) ) - if( ierr==-21 ) then + if( ijob>=1_${ik}$ )maxwrk = max( maxwrk, 2_${ik}$*sdim*( n-sdim ) ) + if( ierr==-21_${ik}$ ) then ! not enough complex workspace - info = -21 + info = -21_${ik}$ else - if( ijob==1 .or. ijob==4 ) then - rconde( 1 ) = pl - rconde( 2 ) = pr + if( ijob==1_${ik}$ .or. ijob==4_${ik}$ ) then + rconde( 1_${ik}$ ) = pl + rconde( 2_${ik}$ ) = pr end if - if( ijob==2 .or. ijob==4 ) then - rcondv( 1 ) = dif( 1 ) - rcondv( 2 ) = dif( 2 ) + if( ijob==2_${ik}$ .or. ijob==4_${ik}$ ) then + rcondv( 1_${ik}$ ) = dif( 1_${ik}$ ) + rcondv( 2_${ik}$ ) = dif( 2_${ik}$ ) end if - if( ierr==1 )info = n + 3 + if( ierr==1_${ik}$ )info = n + 3_${ik}$ end if end if ! apply permutation to vsl and vsr ! (workspace: none needed) - if( ilvsl )call stdlib_${ci}$ggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), & + if( ilvsl )call stdlib${ii}$_${ci}$ggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), & n, vsl, ldvsl, ierr ) - if( ilvsr )call stdlib_${ci}$ggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), & + if( ilvsr )call stdlib${ii}$_${ci}$ggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), & n, vsr, ldvsr, ierr ) ! undo scaling if( ilascl ) then - call stdlib_${ci}$lascl( 'U', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) - call stdlib_${ci}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) + call stdlib${ii}$_${ci}$lascl( 'U', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr ) end if if( ilbscl ) then - call stdlib_${ci}$lascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) - call stdlib_${ci}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + call stdlib${ii}$_${ci}$lascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) end if if( wantst ) then ! check if reordering is correct lastsl = .true. - sdim = 0 + sdim = 0_${ik}$ do i = 1, n cursl = selctg( alpha( i ), beta( i ) ) - if( cursl )sdim = sdim + 1 - if( cursl .and. .not.lastsl )info = n + 2 + if( cursl )sdim = sdim + 1_${ik}$ + if( cursl .and. .not.lastsl )info = n + 2_${ik}$ lastsl = cursl end do end if 40 continue - work( 1 ) = maxwrk - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = maxwrk + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_${ci}$ggesx + end subroutine stdlib${ii}$_${ci}$ggesx - subroutine stdlib_${ci}$ggev( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, & + subroutine stdlib${ii}$_${ci}$ggev( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, & !! ZGGEV: computes for a pair of N-by-N complex nonsymmetric matrices !! (A,B), the generalized eigenvalues, and optionally, the left and/or !! right generalized eigenvectors. @@ -18508,8 +18500,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvl, jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n ! Array Arguments real(${ck}$), intent(out) :: rwork(*) complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) @@ -18520,12 +18512,12 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery character :: chtemp - integer(ilp) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,& + integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,& itau, iwrk, jc, jr, lwkmin, lwkopt real(${ck}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp complex(${ck}$) :: x ! Local Arrays - logical(lk) :: ldumma(1) + logical(lk) :: ldumma(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,aimag,max,sqrt ! Statement Functions @@ -18535,64 +18527,64 @@ module stdlib_linalg_lapack_${ci}$ ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvl, 'N' ) ) then - ijobvl = 1 + ijobvl = 1_${ik}$ ilvl = .false. else if( stdlib_lsame( jobvl, 'V' ) ) then - ijobvl = 2 + ijobvl = 2_${ik}$ ilvl = .true. else - ijobvl = -1 + ijobvl = -1_${ik}$ ilvl = .false. end if if( stdlib_lsame( jobvr, 'N' ) ) then - ijobvr = 1 + ijobvr = 1_${ik}$ ilvr = .false. else if( stdlib_lsame( jobvr, 'V' ) ) then - ijobvr = 2 + ijobvr = 2_${ik}$ ilvr = .true. else - ijobvr = -1 + ijobvr = -1_${ik}$ ilvr = .false. end if ilv = ilvl .or. ilvr ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( ijobvl<=0 ) then - info = -1 - else if( ijobvr<=0 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldazero .and. anrmzero .and. bnrm1 ) then - call stdlib_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& + call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vl, ldvl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& ldvl ) end if - call stdlib_${ci}$ungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & + call stdlib${ii}$_${ci}$ungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vr - if( ilvr )call stdlib_${ci}$laset( 'FULL', n, n, czero, cone, vr, ldvr ) + if( ilvr )call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vr, ldvr ) ! reduce to generalized hessenberg form if( ilv ) then ! eigenvectors requested -- work on whole matrix. - call stdlib_${ci}$gghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib${ii}$_${ci}$gghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & ierr ) else - call stdlib_${ci}$gghrd( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & + call stdlib${ii}$_${ci}$gghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & ldb, vl, ldvl, vr, ldvr, ierr ) end if ! perform qz algorithm (compute eigenvalues, and optionally, the @@ -18683,15 +18675,15 @@ module stdlib_linalg_lapack_${ci}$ else chtemp = 'E' end if - call stdlib_${ci}$hgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, & + call stdlib${ii}$_${ci}$hgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, & ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 70 end if @@ -18708,16 +18700,16 @@ module stdlib_linalg_lapack_${ci}$ else chtemp = 'R' end if - call stdlib_${ci}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & + call stdlib${ii}$_${ci}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & in, work( iwrk ), rwork( irwrk ),ierr ) - if( ierr/=0 ) then - info = n + 2 + if( ierr/=0_${ik}$ ) then + info = n + 2_${ik}$ go to 70 end if ! undo balancing on vl and vr and normalization ! (workspace: none needed) if( ilvl ) then - call stdlib_${ci}$ggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,& + call stdlib${ii}$_${ci}$ggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,& ldvl, ierr ) loop_30: do jc = 1, n temp = zero @@ -18732,7 +18724,7 @@ module stdlib_linalg_lapack_${ci}$ end do loop_30 end if if( ilvr ) then - call stdlib_${ci}$ggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,& + call stdlib${ii}$_${ci}$ggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,& ldvr, ierr ) loop_60: do jc = 1, n temp = zero @@ -18749,14 +18741,14 @@ module stdlib_linalg_lapack_${ci}$ end if ! undo scaling if necessary 70 continue - if( ilascl )call stdlib_${ci}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) - if( ilbscl )call stdlib_${ci}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) - work( 1 ) = lwkopt + if( ilascl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr ) + if( ilbscl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ci}$ggev + end subroutine stdlib${ii}$_${ci}$ggev - subroutine stdlib_${ci}$ggev3( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, & + subroutine stdlib${ii}$_${ci}$ggev3( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, & !! ZGGEV3: computes for a pair of N-by-N complex nonsymmetric matrices !! (A,B), the generalized eigenvalues, and optionally, the left and/or !! right generalized eigenvectors. @@ -18778,8 +18770,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvl, jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n ! Array Arguments real(${ck}$), intent(out) :: rwork(*) complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) @@ -18790,12 +18782,12 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery character :: chtemp - integer(ilp) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,& + integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,& itau, iwrk, jc, jr, lwkopt real(${ck}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp complex(${ck}$) :: x ! Local Arrays - logical(lk) :: ldumma(1) + logical(lk) :: ldumma(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,aimag,max,sqrt ! Statement Functions @@ -18805,75 +18797,75 @@ module stdlib_linalg_lapack_${ci}$ ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvl, 'N' ) ) then - ijobvl = 1 + ijobvl = 1_${ik}$ ilvl = .false. else if( stdlib_lsame( jobvl, 'V' ) ) then - ijobvl = 2 + ijobvl = 2_${ik}$ ilvl = .true. else - ijobvl = -1 + ijobvl = -1_${ik}$ ilvl = .false. end if if( stdlib_lsame( jobvr, 'N' ) ) then - ijobvr = 1 + ijobvr = 1_${ik}$ ilvr = .false. else if( stdlib_lsame( jobvr, 'V' ) ) then - ijobvr = 2 + ijobvr = 2_${ik}$ ilvr = .true. else - ijobvr = -1 + ijobvr = -1_${ik}$ ilvr = .false. end if ilv = ilvl .or. ilvr ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( ijobvl<=0 ) then - info = -1 - else if( ijobvr<=0 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldazero .and. anrmzero .and. bnrm1 ) then - call stdlib_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& + call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vl, ldvl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& ldvl ) end if - call stdlib_${ci}$ungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & + call stdlib${ii}$_${ci}$ungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vr - if( ilvr )call stdlib_${ci}$laset( 'FULL', n, n, czero, cone, vr, ldvr ) + if( ilvr )call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vr, ldvr ) ! reduce to generalized hessenberg form if( ilv ) then ! eigenvectors requested -- work on whole matrix. - call stdlib_${ci}$gghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib${ii}$_${ci}$gghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & work( iwrk ), lwork+1-iwrk, ierr ) else - call stdlib_${ci}$gghd3( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & + call stdlib${ii}$_${ci}$gghd3( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & ldb, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr ) end if ! perform qz algorithm (compute eigenvalues, and optionally, the @@ -18958,15 +18950,15 @@ module stdlib_linalg_lapack_${ci}$ else chtemp = 'E' end if - call stdlib_${ci}$laqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, & - ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), 0, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + call stdlib${ii}$_${ci}$laqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, & + ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), 0_${ik}$, ierr ) + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 70 end if @@ -18981,15 +18973,15 @@ module stdlib_linalg_lapack_${ci}$ else chtemp = 'R' end if - call stdlib_${ci}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & + call stdlib${ii}$_${ci}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & in, work( iwrk ), rwork( irwrk ),ierr ) - if( ierr/=0 ) then - info = n + 2 + if( ierr/=0_${ik}$ ) then + info = n + 2_${ik}$ go to 70 end if ! undo balancing on vl and vr and normalization if( ilvl ) then - call stdlib_${ci}$ggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,& + call stdlib${ii}$_${ci}$ggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,& ldvl, ierr ) loop_30: do jc = 1, n temp = zero @@ -19004,7 +18996,7 @@ module stdlib_linalg_lapack_${ci}$ end do loop_30 end if if( ilvr ) then - call stdlib_${ci}$ggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,& + call stdlib${ii}$_${ci}$ggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,& ldvr, ierr ) loop_60: do jc = 1, n temp = zero @@ -19021,14 +19013,14 @@ module stdlib_linalg_lapack_${ci}$ end if ! undo scaling if necessary 70 continue - if( ilascl )call stdlib_${ci}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) - if( ilbscl )call stdlib_${ci}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) - work( 1 ) = cmplx( lwkopt,KIND=${ck}$) + if( ilascl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr ) + if( ilbscl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) + work( 1_${ik}$ ) = cmplx( lwkopt,KIND=${ck}$) return - end subroutine stdlib_${ci}$ggev3 + end subroutine stdlib${ii}$_${ci}$ggev3 - subroutine stdlib_${ci}$ggevx( balanc, jobvl, jobvr, sense, n, a, lda, b, ldb,alpha, beta, vl, & + subroutine stdlib${ii}$_${ci}$ggevx( balanc, jobvl, jobvr, sense, n, a, lda, b, ldb,alpha, beta, vl, & !! ZGGEVX: computes for a pair of N-by-N complex nonsymmetric matrices !! (A,B) the generalized eigenvalues, and optionally, the left and/or !! right generalized eigenvectors. @@ -19056,12 +19048,12 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: balanc, jobvl, jobvr, sense - integer(ilp), intent(out) :: ihi, ilo, info - integer(ilp), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: ihi, ilo, info + integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n real(${ck}$), intent(out) :: abnrm, bbnrm ! Array Arguments logical(lk), intent(out) :: bwork(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(${ck}$), intent(out) :: lscale(*), rconde(*), rcondv(*), rscale(*), rwork(*) complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) complex(${ck}$), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*) @@ -19072,12 +19064,12 @@ module stdlib_linalg_lapack_${ci}$ logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery, noscl, wantsb, wantse, wantsn, & wantsv character :: chtemp - integer(ilp) :: i, icols, ierr, ijobvl, ijobvr, in, irows, itau, iwrk, iwrk1, j, jc, & + integer(${ik}$) :: i, icols, ierr, ijobvl, ijobvr, in, irows, itau, iwrk, iwrk1, j, jc, & jr, m, maxwrk, minwrk real(${ck}$) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp complex(${ck}$) :: x ! Local Arrays - logical(lk) :: ldumma(1) + logical(lk) :: ldumma(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,aimag,max,sqrt ! Statement Functions @@ -19087,23 +19079,23 @@ module stdlib_linalg_lapack_${ci}$ ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvl, 'N' ) ) then - ijobvl = 1 + ijobvl = 1_${ik}$ ilvl = .false. else if( stdlib_lsame( jobvl, 'V' ) ) then - ijobvl = 2 + ijobvl = 2_${ik}$ ilvl = .true. else - ijobvl = -1 + ijobvl = -1_${ik}$ ilvl = .false. end if if( stdlib_lsame( jobvr, 'N' ) ) then - ijobvr = 1 + ijobvr = 1_${ik}$ ilvr = .false. else if( stdlib_lsame( jobvr, 'V' ) ) then - ijobvr = 2 + ijobvr = 2_${ik}$ ilvr = .true. else - ijobvr = -1 + ijobvr = -1_${ik}$ ilvr = .false. end if ilv = ilvl .or. ilvr @@ -19113,63 +19105,63 @@ module stdlib_linalg_lapack_${ci}$ wantsv = stdlib_lsame( sense, 'V' ) wantsb = stdlib_lsame( sense, 'B' ) ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) if( .not.( noscl .or. stdlib_lsame( balanc,'S' ) .or.stdlib_lsame( balanc, 'B' ) ) ) & then - info = -1 - else if( ijobvl<=0 ) then - info = -2 - else if( ijobvr<=0 ) then - info = -3 + info = -1_${ik}$ + else if( ijobvl<=0_${ik}$ ) then + info = -2_${ik}$ + else if( ijobvr<=0_${ik}$ ) then + info = -3_${ik}$ else if( .not.( wantsn .or. wantse .or. wantsb .or. wantsv ) )then - info = -4 - else if( n<0 ) then - info = -5 - else if( ldazero .and. anrmzero .and. bnrm1 ) then - call stdlib_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& + call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vl, ldvl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& ldvl ) end if - call stdlib_${ci}$ungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & + call stdlib${ii}$_${ci}$ungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if - if( ilvr )call stdlib_${ci}$laset( 'FULL', n, n, czero, cone, vr, ldvr ) + if( ilvr )call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, vr, ldvr ) ! reduce to generalized hessenberg form ! (workspace: none needed) if( ilv .or. .not.wantsn ) then ! eigenvectors requested -- work on whole matrix. - call stdlib_${ci}$gghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib${ii}$_${ci}$gghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & ierr ) else - call stdlib_${ci}$gghrd( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & + call stdlib${ii}$_${ci}$gghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & ldb, vl, ldvl, vr, ldvr, ierr ) end if ! perform qz algorithm (compute eigenvalues, and optionally, the @@ -19270,22 +19262,22 @@ module stdlib_linalg_lapack_${ci}$ else chtemp = 'E' end if - call stdlib_${ci}$hgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, & + call stdlib${ii}$_${ci}$hgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, & ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 90 end if ! compute eigenvectors and estimate condition numbers if desired - ! stdlib_${ci}$tgevc: (complex workspace: need 2*n ) + ! stdlib${ii}$_${ci}$tgevc: (complex workspace: need 2*n ) ! (real workspace: need 2*n ) - ! stdlib_${ci}$tgsna: (complex workspace: need 2*n*n if sense='v' or 'b') + ! stdlib${ii}$_${ci}$tgsna: (complex workspace: need 2*n*n if sense='v' or 'b') ! (integer workspace: need n+2 ) if( ilv .or. .not.wantsn ) then if( ilv ) then @@ -19298,16 +19290,16 @@ module stdlib_linalg_lapack_${ci}$ else chtemp = 'R' end if - call stdlib_${ci}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,& + call stdlib${ii}$_${ci}$tgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,& in, work( iwrk ), rwork,ierr ) - if( ierr/=0 ) then - info = n + 2 + if( ierr/=0_${ik}$ ) then + info = n + 2_${ik}$ go to 90 end if end if if( .not.wantsn ) then - ! compute eigenvectors (stdlib_${ci}$tgevc) and estimate condition - ! numbers (stdlib_${ci}$tgsna). note that the definition of the condition + ! compute eigenvectors (stdlib${ii}$_${ci}$tgevc) and estimate condition + ! numbers (stdlib${ii}$_${ci}$tgsna). note that the definition of the condition ! number is not invariant under transformation (u,v) to ! (q*u, z*v), where (u,v) are eigenvectors of the generalized ! schur form (s,t), q and z are orthogonal matrices. in order @@ -19319,18 +19311,18 @@ module stdlib_linalg_lapack_${ci}$ bwork( j ) = .false. end do bwork( i ) = .true. - iwrk = n + 1 + iwrk = n + 1_${ik}$ iwrk1 = iwrk + n if( wantse .or. wantsb ) then - call stdlib_${ci}$tgevc( 'B', 'S', bwork, n, a, lda, b, ldb,work( 1 ), n, work( & - iwrk ), n, 1, m,work( iwrk1 ), rwork, ierr ) - if( ierr/=0 ) then - info = n + 2 + call stdlib${ii}$_${ci}$tgevc( 'B', 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( & + iwrk ), n, 1_${ik}$, m,work( iwrk1 ), rwork, ierr ) + if( ierr/=0_${ik}$ ) then + info = n + 2_${ik}$ go to 90 end if end if - call stdlib_${ci}$tgsna( sense, 'S', bwork, n, a, lda, b, ldb,work( 1 ), n, work( & - iwrk ), n, rconde( i ),rcondv( i ), 1, m, work( iwrk1 ),lwork-iwrk1+1, iwork, & + call stdlib${ii}$_${ci}$tgsna( sense, 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( & + iwrk ), n, rconde( i ),rcondv( i ), 1_${ik}$, m, work( iwrk1 ),lwork-iwrk1+1, iwork, & ierr ) end do end if @@ -19338,7 +19330,7 @@ module stdlib_linalg_lapack_${ci}$ ! undo balancing on vl and vr and normalization ! (workspace: none needed) if( ilvl ) then - call stdlib_${ci}$ggbak( balanc, 'L', n, ilo, ihi, lscale, rscale, n, vl,ldvl, ierr ) + call stdlib${ii}$_${ci}$ggbak( balanc, 'L', n, ilo, ihi, lscale, rscale, n, vl,ldvl, ierr ) loop_50: do jc = 1, n temp = zero @@ -19353,7 +19345,7 @@ module stdlib_linalg_lapack_${ci}$ end do loop_50 end if if( ilvr ) then - call stdlib_${ci}$ggbak( balanc, 'R', n, ilo, ihi, lscale, rscale, n, vr,ldvr, ierr ) + call stdlib${ii}$_${ci}$ggbak( balanc, 'R', n, ilo, ihi, lscale, rscale, n, vr,ldvr, ierr ) loop_80: do jc = 1, n temp = zero @@ -19369,14 +19361,14 @@ module stdlib_linalg_lapack_${ci}$ end if ! undo scaling if necessary 90 continue - if( ilascl )call stdlib_${ci}$lascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) - if( ilbscl )call stdlib_${ci}$lascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) - work( 1 ) = maxwrk + if( ilascl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr ) + if( ilbscl )call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_${ci}$ggevx + end subroutine stdlib${ii}$_${ci}$ggevx - pure subroutine stdlib_${ci}$ggglm( n, m, p, a, lda, b, ldb, d, x, y, work, lwork,info ) + pure subroutine stdlib${ii}$_${ci}$ggglm( n, m, p, a, lda, b, ldb, d, x, y, work, lwork,info ) !! ZGGGLM: solves a general Gauss-Markov linear model (GLM) problem: !! minimize || y ||_2 subject to d = A*x + B*y !! x @@ -19399,8 +19391,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, ldb, lwork, m, n, p + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, p ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*), d(*) complex(${ck}$), intent(out) :: work(*), x(*), y(*) @@ -19408,52 +19400,52 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, lopt, lwkmin, lwkopt, nb, nb1, nb2, nb3, nb4, np + integer(${ik}$) :: i, lopt, lwkmin, lwkopt, nb, nb1, nb2, nb3, nb4, np ! Intrinsic Functions intrinsic :: int,max,min ! Executable Statements ! test the input parameters - info = 0 + info = 0_${ik}$ np = min( n, p ) - lquery = ( lwork==-1 ) - if( n<0 ) then - info = -1 - else if( m<0 .or. m>n ) then - info = -2 - else if( p<0 .or. pn ) then + info = -2_${ik}$ + else if( p<0_${ik}$ .or. pm ) then - call stdlib_${ci}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', n-m, 1,b( m+1, m+p-n+1 ), & + call stdlib${ii}$_${ci}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', n-m, 1_${ik}$,b( m+1, m+p-n+1 ), & ldb, d( m+1 ), n-m, info ) - if( info>0 ) then - info = 1 + if( info>0_${ik}$ ) then + info = 1_${ik}$ return end if - call stdlib_${ci}$copy( n-m, d( m+1 ), 1, y( m+p-n+1 ), 1 ) + call stdlib${ii}$_${ci}$copy( n-m, d( m+1 ), 1_${ik}$, y( m+p-n+1 ), 1_${ik}$ ) end if ! set y1 = 0 do i = 1, m + p - n y( i ) = czero end do ! update d1 = d1 - t12*y2 - call stdlib_${ci}$gemv( 'NO TRANSPOSE', m, n-m, -cone, b( 1, m+p-n+1 ), ldb,y( m+p-n+1 ), 1,& - cone, d, 1 ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', m, n-m, -cone, b( 1_${ik}$, m+p-n+1 ), ldb,y( m+p-n+1 ), 1_${ik}$,& + cone, d, 1_${ik}$ ) ! solve triangular system: r11*x = d1 - if( m>0 ) then - call stdlib_${ci}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', m, 1, a, lda,d, m, info ) + if( m>0_${ik}$ ) then + call stdlib${ii}$_${ci}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', m, 1_${ik}$, a, lda,d, m, info ) - if( info>0 ) then - info = 2 + if( info>0_${ik}$ ) then + info = 2_${ik}$ return end if ! copy d to x - call stdlib_${ci}$copy( m, d, 1, x, 1 ) + call stdlib${ii}$_${ci}$copy( m, d, 1_${ik}$, x, 1_${ik}$ ) end if ! backward transformation y = z**h *y - call stdlib_${ci}$unmrq( 'LEFT', 'CONJUGATE TRANSPOSE', p, 1, np,b( max( 1, n-p+1 ), 1 ), & - ldb, work( m+1 ), y,max( 1, p ), work( m+np+1 ), lwork-m-np, info ) - work( 1 ) = m + np + max( lopt, int( work( m+np+1 ),KIND=ilp) ) + call stdlib${ii}$_${ci}$unmrq( 'LEFT', 'CONJUGATE TRANSPOSE', p, 1_${ik}$, np,b( max( 1_${ik}$, n-p+1 ), 1_${ik}$ ), & + ldb, work( m+1 ), y,max( 1_${ik}$, p ), work( m+np+1 ), lwork-m-np, info ) + work( 1_${ik}$ ) = m + np + max( lopt, int( work( m+np+1 ),KIND=${ik}$) ) return - end subroutine stdlib_${ci}$ggglm + end subroutine stdlib${ii}$_${ci}$ggglm - pure subroutine stdlib_${ci}$gghd3( compq, compz, n, ilo, ihi, a, lda, b, ldb, q,ldq, z, ldz, & + pure subroutine stdlib${ii}$_${ci}$gghd3( compq, compz, n, ilo, ihi, a, lda, b, ldb, q,ldq, z, ldz, & !! ZGGHD3: reduces a pair of complex matrices (A,B) to generalized upper !! Hessenberg form using unitary transformations, where A is a !! general matrix and B is upper triangular. The form of the @@ -19544,8 +19536,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: compq, compz - integer(ilp), intent(in) :: ihi, ilo, lda, ldb, ldq, ldz, n, lwork - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ilo, lda, ldb, ldq, ldz, n, lwork + integer(${ik}$), intent(out) :: info ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) complex(${ck}$), intent(out) :: work(*) @@ -19554,7 +19546,7 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: blk22, initq, initz, lquery, wantq, wantz character :: compq2, compz2 - integer(ilp) :: cola, i, ierr, j, j0, jcol, jj, jrow, k, kacc22, len, lwkopt, n2nb, nb,& + integer(${ik}$) :: cola, i, ierr, j, j0, jcol, jj, jrow, k, kacc22, len, lwkopt, n2nb, nb,& nblst, nbmin, nh, nnb, nx, ppw, ppwo, pw, top, topq real(${ck}$) :: c complex(${ck}$) :: c1, c2, ctemp, s, s1, s2, temp, temp1, temp2, temp3 @@ -19562,69 +19554,69 @@ module stdlib_linalg_lapack_${ci}$ intrinsic :: real,cmplx,conjg,max ! Executable Statements ! decode and test the input parameters. - info = 0 - nb = stdlib_ilaenv( 1, 'ZGGHD3', ' ', n, ilo, ihi, -1 ) - lwkopt = max( 6*n*nb, 1 ) - work( 1 ) = cmplx( lwkopt,KIND=${ck}$) + info = 0_${ik}$ + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGGHD3', ' ', n, ilo, ihi, -1_${ik}$ ) + lwkopt = max( 6_${ik}$*n*nb, 1_${ik}$ ) + work( 1_${ik}$ ) = cmplx( lwkopt,KIND=${ck}$) initq = stdlib_lsame( compq, 'I' ) wantq = initq .or. stdlib_lsame( compq, 'V' ) initz = stdlib_lsame( compz, 'I' ) wantz = initz .or. stdlib_lsame( compz, 'V' ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) if( .not.stdlib_lsame( compq, 'N' ) .and. .not.wantq ) then - info = -1 + info = -1_${ik}$ else if( .not.stdlib_lsame( compz, 'N' ) .and. .not.wantz ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ilo<1 ) then - info = -4 + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( ilo<1_${ik}$ ) then + info = -4_${ik}$ else if( ihi>n .or. ihi1 )call stdlib_${ci}$laset( 'LOWER', n-1, n-1, czero, czero, b(2, 1), ldb ) + if( n>1_${ik}$ )call stdlib${ii}$_${ci}$laset( 'LOWER', n-1, n-1, czero, czero, b(2_${ik}$, 1_${ik}$), ldb ) ! quick return if possible - nh = ihi - ilo + 1 - if( nh<=1 ) then - work( 1 ) = cone + nh = ihi - ilo + 1_${ik}$ + if( nh<=1_${ik}$ ) then + work( 1_${ik}$ ) = cone return end if ! determine the blocksize. - nbmin = stdlib_ilaenv( 2, 'ZGGHD3', ' ', n, ilo, ihi, -1 ) - if( nb>1 .and. nb1_${ik}$ .and. nb=6*n*nbmin ) then - nb = lwork / ( 6*n ) + nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'ZGGHD3', ' ', n, ilo, ihi,-1_${ik}$ ) ) + if( lwork>=6_${ik}$*n*nbmin ) then + nb = lwork / ( 6_${ik}$*n ) else - nb = 1 + nb = 1_${ik}$ end if end if end if @@ -19634,8 +19626,8 @@ module stdlib_linalg_lapack_${ci}$ jcol = ilo else ! use blocked code - kacc22 = stdlib_ilaenv( 16, 'ZGGHD3', ' ', n, ilo, ihi, -1 ) - blk22 = kacc22==2 + kacc22 = stdlib${ii}$_ilaenv( 16_${ik}$, 'ZGGHD3', ' ', n, ilo, ihi, -1_${ik}$ ) + blk22 = kacc22==2_${ik}$ do jcol = ilo, ihi-2, nb nnb = min( nb, ihi-jcol-1 ) ! initialize small unitary factors that will hold the @@ -19643,14 +19635,14 @@ module stdlib_linalg_lapack_${ci}$ ! n2nb denotes the number of 2*nnb-by-2*nnb factors ! nblst denotes the (possibly smaller) order of the last ! factor. - n2nb = ( ihi-jcol-1 ) / nnb - 1 + n2nb = ( ihi-jcol-1 ) / nnb - 1_${ik}$ nblst = ihi - jcol - n2nb*nnb - call stdlib_${ci}$laset( 'ALL', nblst, nblst, czero, cone, work, nblst ) - pw = nblst * nblst + 1 + call stdlib${ii}$_${ci}$laset( 'ALL', nblst, nblst, czero, cone, work, nblst ) + pw = nblst * nblst + 1_${ik}$ do i = 1, n2nb - call stdlib_${ci}$laset( 'ALL', 2*nnb, 2*nnb, czero, cone,work( pw ), 2*nnb ) + call stdlib${ii}$_${ci}$laset( 'ALL', 2_${ik}$*nnb, 2_${ik}$*nnb, czero, cone,work( pw ), 2_${ik}$*nnb ) - pw = pw + 4*nnb*nnb + pw = pw + 4_${ik}$*nnb*nnb end do ! reduce columns jcol:jcol+nnb-1 of a to hessenberg form. do j = jcol, jcol+nnb-1 @@ -19658,14 +19650,14 @@ module stdlib_linalg_lapack_${ci}$ ! column of a and b, respectively. do i = ihi, j+2, -1 temp = a( i-1, j ) - call stdlib_${ci}$lartg( temp, a( i, j ), c, s, a( i-1, j ) ) + call stdlib${ii}$_${ci}$lartg( temp, a( i, j ), c, s, a( i-1, j ) ) a( i, j ) = cmplx( c,KIND=${ck}$) b( i, j ) = s end do ! accumulate givens rotations into workspace array. - ppw = ( nblst + 1 )*( nblst - 2 ) - j + jcol + 1 - len = 2 + j - jcol - jrow = j + n2nb*nnb + 2 + ppw = ( nblst + 1_${ik}$ )*( nblst - 2_${ik}$ ) - j + jcol + 1_${ik}$ + len = 2_${ik}$ + j - jcol + jrow = j + n2nb*nnb + 2_${ik}$ do i = ihi, jrow, -1 ctemp = a( i, j ) s = b( i, j ) @@ -19674,31 +19666,31 @@ module stdlib_linalg_lapack_${ci}$ work( jj + nblst ) = ctemp*temp - s*work( jj ) work( jj ) = conjg( s )*temp + ctemp*work( jj ) end do - len = len + 1 - ppw = ppw - nblst - 1 + len = len + 1_${ik}$ + ppw = ppw - nblst - 1_${ik}$ end do - ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2*nnb + nnb + ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2_${ik}$*nnb + nnb j0 = jrow - nnb do jrow = j0, j+2, -nnb ppw = ppwo - len = 2 + j - jcol + len = 2_${ik}$ + j - jcol do i = jrow+nnb-1, jrow, -1 ctemp = a( i, j ) s = b( i, j ) do jj = ppw, ppw+len-1 - temp = work( jj + 2*nnb ) - work( jj + 2*nnb ) = ctemp*temp - s*work( jj ) + temp = work( jj + 2_${ik}$*nnb ) + work( jj + 2_${ik}$*nnb ) = ctemp*temp - s*work( jj ) work( jj ) = conjg( s )*temp + ctemp*work( jj ) end do - len = len + 1 - ppw = ppw - 2*nnb - 1 + len = len + 1_${ik}$ + ppw = ppw - 2_${ik}$*nnb - 1_${ik}$ end do - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do ! top denotes the number of top rows in a and b that will ! not be updated during the next steps. - if( jcol<=2 ) then - top = 0 + if( jcol<=2_${ik}$ ) then + top = 0_${ik}$ else top = jcol end if @@ -19716,16 +19708,16 @@ module stdlib_linalg_lapack_${ci}$ ! annihilate b( jj+1, jj ). if( jj0 ) then + if( jj>0_${ik}$ ) then do i = jj, 1, -1 c = real( a( j+1+i, j ),KIND=${ck}$) - call stdlib_${ci}$rot( ihi-top, a( top+1, j+i+1 ), 1,a( top+1, j+i ), 1, c,-& + call stdlib${ii}$_${ci}$rot( ihi-top, a( top+1, j+i+1 ), 1_${ik}$,a( top+1, j+i ), 1_${ik}$, c,-& conjg( b( j+1+i, j ) ) ) end do end if ! update (j+1)th column of a by transformations from left. - if ( j < jcol + nnb - 1 ) then - len = 1 + j - jcol + if ( j < jcol + nnb - 1_${ik}$ ) then + len = 1_${ik}$ + j - jcol ! multiply with the trailing accumulated unitary ! matrix, which takes the form ! [ u11 u12 ] @@ -19763,23 +19755,23 @@ module stdlib_linalg_lapack_${ci}$ ! [ u21 u22 ] ! where u21 is a len-by-len matrix and u12 is lower ! triangular. - jrow = ihi - nblst + 1 - call stdlib_${ci}$gemv( 'CONJUGATE', nblst, len, cone, work,nblst, a( jrow, j+1 & - ), 1, czero,work( pw ), 1 ) + jrow = ihi - nblst + 1_${ik}$ + call stdlib${ii}$_${ci}$gemv( 'CONJUGATE', nblst, len, cone, work,nblst, a( jrow, j+1 & + ), 1_${ik}$, czero,work( pw ), 1_${ik}$ ) ppw = pw + len do i = jrow, jrow+nblst-len-1 work( ppw ) = a( i, j+1 ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do - call stdlib_${ci}$trmv( 'LOWER', 'CONJUGATE', 'NON-UNIT',nblst-len, work( & - len*nblst + 1 ), nblst,work( pw+len ), 1 ) - call stdlib_${ci}$gemv( 'CONJUGATE', len, nblst-len, cone,work( (len+1)*nblst - & - len + 1 ), nblst,a( jrow+nblst-len, j+1 ), 1, cone,work( pw+len ), 1 ) + call stdlib${ii}$_${ci}$trmv( 'LOWER', 'CONJUGATE', 'NON-UNIT',nblst-len, work( & + len*nblst + 1_${ik}$ ), nblst,work( pw+len ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$gemv( 'CONJUGATE', len, nblst-len, cone,work( (len+1)*nblst - & + len + 1_${ik}$ ), nblst,a( jrow+nblst-len, j+1 ), 1_${ik}$, cone,work( pw+len ), 1_${ik}$ ) ppw = pw do i = jrow, jrow+nblst-1 a( i, j+1 ) = work( ppw ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do ! multiply with the other accumulated unitary ! matrices, which take the form @@ -19791,44 +19783,44 @@ module stdlib_linalg_lapack_${ci}$ ! where i denotes the (nnb-len)-by-(nnb-len) identity ! matrix, u21 is a len-by-len upper triangular matrix ! and u12 is an nnb-by-nnb lower triangular matrix. - ppwo = 1 + nblst*nblst + ppwo = 1_${ik}$ + nblst*nblst j0 = jrow - nnb do jrow = j0, jcol+1, -nnb ppw = pw + len do i = jrow, jrow+nnb-1 work( ppw ) = a( i, j+1 ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do ppw = pw do i = jrow+nnb, jrow+nnb+len-1 work( ppw ) = a( i, j+1 ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do - call stdlib_${ci}$trmv( 'UPPER', 'CONJUGATE', 'NON-UNIT', len,work( ppwo + & - nnb ), 2*nnb, work( pw ),1 ) - call stdlib_${ci}$trmv( 'LOWER', 'CONJUGATE', 'NON-UNIT', nnb,work( ppwo + & - 2*len*nnb ),2*nnb, work( pw + len ), 1 ) - call stdlib_${ci}$gemv( 'CONJUGATE', nnb, len, cone,work( ppwo ), 2*nnb, a( & - jrow, j+1 ), 1,cone, work( pw ), 1 ) - call stdlib_${ci}$gemv( 'CONJUGATE', len, nnb, cone,work( ppwo + 2*len*nnb + & - nnb ), 2*nnb,a( jrow+nnb, j+1 ), 1, cone,work( pw+len ), 1 ) + call stdlib${ii}$_${ci}$trmv( 'UPPER', 'CONJUGATE', 'NON-UNIT', len,work( ppwo + & + nnb ), 2_${ik}$*nnb, work( pw ),1_${ik}$ ) + call stdlib${ii}$_${ci}$trmv( 'LOWER', 'CONJUGATE', 'NON-UNIT', nnb,work( ppwo + & + 2_${ik}$*len*nnb ),2_${ik}$*nnb, work( pw + len ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$gemv( 'CONJUGATE', nnb, len, cone,work( ppwo ), 2_${ik}$*nnb, a( & + jrow, j+1 ), 1_${ik}$,cone, work( pw ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$gemv( 'CONJUGATE', len, nnb, cone,work( ppwo + 2_${ik}$*len*nnb + & + nnb ), 2_${ik}$*nnb,a( jrow+nnb, j+1 ), 1_${ik}$, cone,work( pw+len ), 1_${ik}$ ) ppw = pw do i = jrow, jrow+len+nnb-1 a( i, j+1 ) = work( ppw ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end if end do ! apply accumulated unitary matrices to a. - cola = n - jcol - nnb + 1 - j = ihi - nblst + 1 - call stdlib_${ci}$gemm( 'CONJUGATE', 'NO TRANSPOSE', nblst,cola, nblst, cone, work, & + cola = n - jcol - nnb + 1_${ik}$ + j = ihi - nblst + 1_${ik}$ + call stdlib${ii}$_${ci}$gemm( 'CONJUGATE', 'NO TRANSPOSE', nblst,cola, nblst, cone, work, & nblst,a( j, jcol+nnb ), lda, czero, work( pw ),nblst ) - call stdlib_${ci}$lacpy( 'ALL', nblst, cola, work( pw ), nblst,a( j, jcol+nnb ), lda ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', nblst, cola, work( pw ), nblst,a( j, jcol+nnb ), lda ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( blk22 ) then @@ -19838,70 +19830,70 @@ module stdlib_linalg_lapack_${ci}$ ! [ u21 u22 ], ! where all blocks are nnb-by-nnb, u21 is upper ! triangular and u12 is lower triangular. - call stdlib_${ci}$unm22( 'LEFT', 'CONJUGATE', 2*nnb, cola, nnb,nnb, work( ppwo )& - , 2*nnb,a( j, jcol+nnb ), lda, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_${ci}$unm22( 'LEFT', 'CONJUGATE', 2_${ik}$*nnb, cola, nnb,nnb, work( ppwo )& + , 2_${ik}$*nnb,a( j, jcol+nnb ), lda, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_${ci}$gemm( 'CONJUGATE', 'NO TRANSPOSE', 2*nnb,cola, 2*nnb, cone, & - work( ppwo ), 2*nnb,a( j, jcol+nnb ), lda, czero, work( pw ),2*nnb ) + call stdlib${ii}$_${ci}$gemm( 'CONJUGATE', 'NO TRANSPOSE', 2_${ik}$*nnb,cola, 2_${ik}$*nnb, cone, & + work( ppwo ), 2_${ik}$*nnb,a( j, jcol+nnb ), lda, czero, work( pw ),2_${ik}$*nnb ) - call stdlib_${ci}$lacpy( 'ALL', 2*nnb, cola, work( pw ), 2*nnb,a( j, jcol+nnb ),& + call stdlib${ii}$_${ci}$lacpy( 'ALL', 2_${ik}$*nnb, cola, work( pw ), 2_${ik}$*nnb,a( j, jcol+nnb ),& lda ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do ! apply accumulated unitary matrices to q. if( wantq ) then - j = ihi - nblst + 1 + j = ihi - nblst + 1_${ik}$ if ( initq ) then - topq = max( 2, j - jcol + 1 ) - nh = ihi - topq + 1 + topq = max( 2_${ik}$, j - jcol + 1_${ik}$ ) + nh = ihi - topq + 1_${ik}$ else - topq = 1 + topq = 1_${ik}$ nh = n end if - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, cone, q( & + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, cone, q( & topq, j ), ldq,work, nblst, czero, work( pw ), nh ) - call stdlib_${ci}$lacpy( 'ALL', nh, nblst, work( pw ), nh,q( topq, j ), ldq ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', nh, nblst, work( pw ), nh,q( topq, j ), ldq ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( initq ) then - topq = max( 2, j - jcol + 1 ) - nh = ihi - topq + 1 + topq = max( 2_${ik}$, j - jcol + 1_${ik}$ ) + nh = ihi - topq + 1_${ik}$ end if if ( blk22 ) then ! exploit the structure of u. - call stdlib_${ci}$unm22( 'RIGHT', 'NO TRANSPOSE', nh, 2*nnb,nnb, nnb, work( & - ppwo ), 2*nnb,q( topq, j ), ldq, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_${ci}$unm22( 'RIGHT', 'NO TRANSPOSE', nh, 2_${ik}$*nnb,nnb, nnb, work( & + ppwo ), 2_${ik}$*nnb,q( topq, j ), ldq, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2*nnb, 2*nnb, & - cone, q( topq, j ), ldq,work( ppwo ), 2*nnb, czero, work( pw ),nh ) + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2_${ik}$*nnb, 2_${ik}$*nnb, & + cone, q( topq, j ), ldq,work( ppwo ), 2_${ik}$*nnb, czero, work( pw ),nh ) - call stdlib_${ci}$lacpy( 'ALL', nh, 2*nnb, work( pw ), nh,q( topq, j ), ldq ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', nh, 2_${ik}$*nnb, work( pw ), nh,q( topq, j ), ldq ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end if ! accumulate right givens rotations if required. - if ( wantz .or. top>0 ) then + if ( wantz .or. top>0_${ik}$ ) then ! initialize small unitary factors that will hold the ! accumulated givens rotations in workspace. - call stdlib_${ci}$laset( 'ALL', nblst, nblst, czero, cone, work,nblst ) - pw = nblst * nblst + 1 + call stdlib${ii}$_${ci}$laset( 'ALL', nblst, nblst, czero, cone, work,nblst ) + pw = nblst * nblst + 1_${ik}$ do i = 1, n2nb - call stdlib_${ci}$laset( 'ALL', 2*nnb, 2*nnb, czero, cone,work( pw ), 2*nnb ) + call stdlib${ii}$_${ci}$laset( 'ALL', 2_${ik}$*nnb, 2_${ik}$*nnb, czero, cone,work( pw ), 2_${ik}$*nnb ) - pw = pw + 4*nnb*nnb + pw = pw + 4_${ik}$*nnb*nnb end do ! accumulate givens rotations into workspace array. do j = jcol, jcol+nnb-1 - ppw = ( nblst + 1 )*( nblst - 2 ) - j + jcol + 1 - len = 2 + j - jcol - jrow = j + n2nb*nnb + 2 + ppw = ( nblst + 1_${ik}$ )*( nblst - 2_${ik}$ ) - j + jcol + 1_${ik}$ + len = 2_${ik}$ + j - jcol + jrow = j + n2nb*nnb + 2_${ik}$ do i = ihi, jrow, -1 ctemp = a( i, j ) a( i, j ) = czero @@ -19912,117 +19904,117 @@ module stdlib_linalg_lapack_${ci}$ work( jj + nblst ) = ctemp*temp -conjg( s )*work( jj ) work( jj ) = s*temp + ctemp*work( jj ) end do - len = len + 1 - ppw = ppw - nblst - 1 + len = len + 1_${ik}$ + ppw = ppw - nblst - 1_${ik}$ end do - ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2*nnb + nnb + ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2_${ik}$*nnb + nnb j0 = jrow - nnb do jrow = j0, j+2, -nnb ppw = ppwo - len = 2 + j - jcol + len = 2_${ik}$ + j - jcol do i = jrow+nnb-1, jrow, -1 ctemp = a( i, j ) a( i, j ) = czero s = b( i, j ) b( i, j ) = czero do jj = ppw, ppw+len-1 - temp = work( jj + 2*nnb ) - work( jj + 2*nnb ) = ctemp*temp -conjg( s )*work( jj ) + temp = work( jj + 2_${ik}$*nnb ) + work( jj + 2_${ik}$*nnb ) = ctemp*temp -conjg( s )*work( jj ) work( jj ) = s*temp + ctemp*work( jj ) end do - len = len + 1 - ppw = ppw - 2*nnb - 1 + len = len + 1_${ik}$ + ppw = ppw - 2_${ik}$*nnb - 1_${ik}$ end do - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end do else - call stdlib_${ci}$laset( 'LOWER', ihi - jcol - 1, nnb, czero, czero,a( jcol + 2, & + call stdlib${ii}$_${ci}$laset( 'LOWER', ihi - jcol - 1_${ik}$, nnb, czero, czero,a( jcol + 2_${ik}$, & jcol ), lda ) - call stdlib_${ci}$laset( 'LOWER', ihi - jcol - 1, nnb, czero, czero,b( jcol + 2, & + call stdlib${ii}$_${ci}$laset( 'LOWER', ihi - jcol - 1_${ik}$, nnb, czero, czero,b( jcol + 2_${ik}$, & jcol ), ldb ) end if ! apply accumulated unitary matrices to a and b. - if ( top>0 ) then - j = ihi - nblst + 1 - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, cone, a( & - 1, j ), lda,work, nblst, czero, work( pw ), top ) - call stdlib_${ci}$lacpy( 'ALL', top, nblst, work( pw ), top,a( 1, j ), lda ) + if ( top>0_${ik}$ ) then + j = ihi - nblst + 1_${ik}$ + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, cone, a( & + 1_${ik}$, j ), lda,work, nblst, czero, work( pw ), top ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', top, nblst, work( pw ), top,a( 1_${ik}$, j ), lda ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( blk22 ) then ! exploit the structure of u. - call stdlib_${ci}$unm22( 'RIGHT', 'NO TRANSPOSE', top, 2*nnb,nnb, nnb, work( & - ppwo ), 2*nnb,a( 1, j ), lda, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_${ci}$unm22( 'RIGHT', 'NO TRANSPOSE', top, 2_${ik}$*nnb,nnb, nnb, work( & + ppwo ), 2_${ik}$*nnb,a( 1_${ik}$, j ), lda, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2*nnb, 2*nnb, & - cone, a( 1, j ), lda,work( ppwo ), 2*nnb, czero,work( pw ), top ) + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2_${ik}$*nnb, 2_${ik}$*nnb, & + cone, a( 1_${ik}$, j ), lda,work( ppwo ), 2_${ik}$*nnb, czero,work( pw ), top ) - call stdlib_${ci}$lacpy( 'ALL', top, 2*nnb, work( pw ), top,a( 1, j ), lda ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', top, 2_${ik}$*nnb, work( pw ), top,a( 1_${ik}$, j ), lda ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do - j = ihi - nblst + 1 - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, cone, b( & - 1, j ), ldb,work, nblst, czero, work( pw ), top ) - call stdlib_${ci}$lacpy( 'ALL', top, nblst, work( pw ), top,b( 1, j ), ldb ) + j = ihi - nblst + 1_${ik}$ + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, cone, b( & + 1_${ik}$, j ), ldb,work, nblst, czero, work( pw ), top ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', top, nblst, work( pw ), top,b( 1_${ik}$, j ), ldb ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( blk22 ) then ! exploit the structure of u. - call stdlib_${ci}$unm22( 'RIGHT', 'NO TRANSPOSE', top, 2*nnb,nnb, nnb, work( & - ppwo ), 2*nnb,b( 1, j ), ldb, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_${ci}$unm22( 'RIGHT', 'NO TRANSPOSE', top, 2_${ik}$*nnb,nnb, nnb, work( & + ppwo ), 2_${ik}$*nnb,b( 1_${ik}$, j ), ldb, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2*nnb, 2*nnb, & - cone, b( 1, j ), ldb,work( ppwo ), 2*nnb, czero,work( pw ), top ) + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2_${ik}$*nnb, 2_${ik}$*nnb, & + cone, b( 1_${ik}$, j ), ldb,work( ppwo ), 2_${ik}$*nnb, czero,work( pw ), top ) - call stdlib_${ci}$lacpy( 'ALL', top, 2*nnb, work( pw ), top,b( 1, j ), ldb ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', top, 2_${ik}$*nnb, work( pw ), top,b( 1_${ik}$, j ), ldb ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end if ! apply accumulated unitary matrices to z. if( wantz ) then - j = ihi - nblst + 1 + j = ihi - nblst + 1_${ik}$ if ( initq ) then - topq = max( 2, j - jcol + 1 ) - nh = ihi - topq + 1 + topq = max( 2_${ik}$, j - jcol + 1_${ik}$ ) + nh = ihi - topq + 1_${ik}$ else - topq = 1 + topq = 1_${ik}$ nh = n end if - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, cone, z( & + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, cone, z( & topq, j ), ldz,work, nblst, czero, work( pw ), nh ) - call stdlib_${ci}$lacpy( 'ALL', nh, nblst, work( pw ), nh,z( topq, j ), ldz ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', nh, nblst, work( pw ), nh,z( topq, j ), ldz ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( initq ) then - topq = max( 2, j - jcol + 1 ) - nh = ihi - topq + 1 + topq = max( 2_${ik}$, j - jcol + 1_${ik}$ ) + nh = ihi - topq + 1_${ik}$ end if if ( blk22 ) then ! exploit the structure of u. - call stdlib_${ci}$unm22( 'RIGHT', 'NO TRANSPOSE', nh, 2*nnb,nnb, nnb, work( & - ppwo ), 2*nnb,z( topq, j ), ldz, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_${ci}$unm22( 'RIGHT', 'NO TRANSPOSE', nh, 2_${ik}$*nnb,nnb, nnb, work( & + ppwo ), 2_${ik}$*nnb,z( topq, j ), ldz, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2*nnb, 2*nnb, & - cone, z( topq, j ), ldz,work( ppwo ), 2*nnb, czero, work( pw ),nh ) + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2_${ik}$*nnb, 2_${ik}$*nnb, & + cone, z( topq, j ), ldz,work( ppwo ), 2_${ik}$*nnb, czero, work( pw ),nh ) - call stdlib_${ci}$lacpy( 'ALL', nh, 2*nnb, work( pw ), nh,z( topq, j ), ldz ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', nh, 2_${ik}$*nnb, work( pw ), nh,z( topq, j ), ldz ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end if end do @@ -20035,14 +20027,14 @@ module stdlib_linalg_lapack_${ci}$ if ( wantq )compq2 = 'V' if ( wantz )compz2 = 'V' end if - if ( jcoln .or. ihin .or. pn .or. p0 ) then - call stdlib_${ci}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', p, 1,b( 1, n-p+1 ), ldb, d,& + if( p>0_${ik}$ ) then + call stdlib${ii}$_${ci}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', p, 1_${ik}$,b( 1_${ik}$, n-p+1 ), ldb, d,& p, info ) - if( info>0 ) then - info = 1 + if( info>0_${ik}$ ) then + info = 1_${ik}$ return end if ! put the solution in x - call stdlib_${ci}$copy( p, d, 1, x( n-p+1 ), 1 ) + call stdlib${ii}$_${ci}$copy( p, d, 1_${ik}$, x( n-p+1 ), 1_${ik}$ ) ! update c1 - call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-p, p, -cone, a( 1, n-p+1 ), lda,d, 1, cone, c, & - 1 ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-p, p, -cone, a( 1_${ik}$, n-p+1 ), lda,d, 1_${ik}$, cone, c, & + 1_${ik}$ ) end if ! solve r11*x1 = c1 for x1 if( n>p ) then - call stdlib_${ci}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n-p, 1,a, lda, c, n-p, & + call stdlib${ii}$_${ci}$trtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n-p, 1_${ik}$,a, lda, c, n-p, & info ) - if( info>0 ) then - info = 2 + if( info>0_${ik}$ ) then + info = 2_${ik}$ return end if ! put the solutions in x - call stdlib_${ci}$copy( n-p, c, 1, x, 1 ) + call stdlib${ii}$_${ci}$copy( n-p, c, 1_${ik}$, x, 1_${ik}$ ) end if ! compute the residual vector: if( m0 )call stdlib_${ci}$gemv( 'NO TRANSPOSE', nr, n-m, -cone, a( n-p+1, m+1 ),lda, d(& - nr+1 ), 1, cone, c( n-p+1 ), 1 ) + if( nr>0_${ik}$ )call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', nr, n-m, -cone, a( n-p+1, m+1 ),lda, d(& + nr+1 ), 1_${ik}$, cone, c( n-p+1 ), 1_${ik}$ ) else nr = p end if - if( nr>0 ) then - call stdlib_${ci}$trmv( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', nr,a( n-p+1, n-p+1 ), lda, & - d, 1 ) - call stdlib_${ci}$axpy( nr, -cone, d, 1, c( n-p+1 ), 1 ) + if( nr>0_${ik}$ ) then + call stdlib${ii}$_${ci}$trmv( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', nr,a( n-p+1, n-p+1 ), lda, & + d, 1_${ik}$ ) + call stdlib${ii}$_${ci}$axpy( nr, -cone, d, 1_${ik}$, c( n-p+1 ), 1_${ik}$ ) end if ! backward transformation x = q**h*x - call stdlib_${ci}$unmrq( 'LEFT', 'CONJUGATE TRANSPOSE', n, 1, p, b, ldb,work( 1 ), x, n, & + call stdlib${ii}$_${ci}$unmrq( 'LEFT', 'CONJUGATE TRANSPOSE', n, 1_${ik}$, p, b, ldb,work( 1_${ik}$ ), x, n, & work( p+mn+1 ), lwork-p-mn, info ) - work( 1 ) = p + mn + max( lopt, int( work( p+mn+1 ),KIND=ilp) ) + work( 1_${ik}$ ) = p + mn + max( lopt, int( work( p+mn+1 ),KIND=${ik}$) ) return - end subroutine stdlib_${ci}$gglse + end subroutine stdlib${ii}$_${ci}$gglse - pure subroutine stdlib_${ci}$ggqrf( n, m, p, a, lda, taua, b, ldb, taub, work,lwork, info ) + pure subroutine stdlib${ii}$_${ci}$ggqrf( n, m, p, a, lda, taua, b, ldb, taub, work,lwork, info ) !! ZGGQRF: computes a generalized QR factorization of an N-by-M matrix A !! and an N-by-P matrix B: !! A = Q*R, B = Q*T*Z, @@ -20330,61 +20322,61 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, ldb, lwork, m, n, p + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, p ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) complex(${ck}$), intent(out) :: taua(*), taub(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: lopt, lwkopt, nb, nb1, nb2, nb3 + integer(${ik}$) :: lopt, lwkopt, nb, nb1, nb2, nb3 ! Intrinsic Functions intrinsic :: int,max,min ! Executable Statements ! test the input parameters - info = 0 - nb1 = stdlib_ilaenv( 1, 'ZGEQRF', ' ', n, m, -1, -1 ) - nb2 = stdlib_ilaenv( 1, 'ZGERQF', ' ', n, p, -1, -1 ) - nb3 = stdlib_ilaenv( 1, 'ZUNMQR', ' ', n, m, p, -1 ) + info = 0_${ik}$ + nb1 = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', n, m, -1_${ik}$, -1_${ik}$ ) + nb2 = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGERQF', ' ', n, p, -1_${ik}$, -1_${ik}$ ) + nb3 = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', ' ', n, m, p, -1_${ik}$ ) nb = max( nb1, nb2, nb3 ) lwkopt = max( n, m, p )*nb - work( 1 ) = lwkopt - lquery = ( lwork==-1 ) - if( n<0 ) then - info = -1 - else if( m<0 ) then - info = -2 - else if( p<0 ) then - info = -3 - else if( ldam ) ) then - info = -3 + info = -1_${ik}$ + else if( m<0_${ik}$ ) then + info = -2_${ik}$ + else if( ( n<0_${ik}$ ) .or. ( n>m ) ) then + info = -3_${ik}$ else if( lda sqrt(overflow_threshold), and to ! underflow for ||a(:,p)||_2 < sqrt(underflow_threshold). - ! hence, stdlib_${c2ri(ci)}$znrm2 cannot be trusted, not even in the case when + ! hence, stdlib${ii}$_${c2ri(ci)}$znrm2 cannot be trusted, not even in the case when ! the true norm is far from the under(over)flow boundaries. - ! if properly implemented stdlib_${c2ri(ci)}$znrm2 is available, the if-then-else-end if - ! below should be replaced with "aapp = stdlib_${c2ri(ci)}$znrm2( m, a(1,p), 1 )". + ! if properly implemented stdlib${ii}$_${c2ri(ci)}$znrm2 is available, the if-then-else-end if + ! below should be replaced with "aapp = stdlib${ii}$_${c2ri(ci)}$znrm2( m, a(1,p), 1 )". if( ( sva( p )rootsfmin ) ) then - sva( p ) = stdlib_${c2ri(ci)}$znrm2( m, a( 1, p ), 1 ) + sva( p ) = stdlib${ii}$_${c2ri(ci)}$znrm2( m, a( 1_${ik}$, p ), 1_${ik}$ ) else temp1 = zero aapp = one - call stdlib_${ci}$lassq( m, a( 1, p ), 1, temp1, aapp ) + call stdlib${ii}$_${ci}$lassq( m, a( 1_${ik}$, p ), 1_${ik}$, temp1, aapp ) sva( p ) = temp1*sqrt( aapp ) end if aapp = sva( p ) @@ -20618,7 +20610,7 @@ module stdlib_linalg_lapack_${ci}$ aapp = sva( p ) end if if( aapp>zero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2002: do q = p + 1, min( igl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -20626,25 +20618,25 @@ module stdlib_linalg_lapack_${ci}$ if( aaqq>=one ) then rotok = ( small*aapp )<=aaqq if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_${ci}$dotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib${ii}$_${ci}$dotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq ) / aapp else - call stdlib_${ci}$copy( m, a( 1, p ), 1,work, 1 ) - call stdlib_${ci}$lascl( 'G', 0, 0, aapp, one,m, 1, work, lda, & + call stdlib${ii}$_${ci}$copy( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, work, lda, & ierr ) - aapq = stdlib_${ci}$dotc( m, work, 1,a( 1, q ), 1 ) / & + aapq = stdlib${ii}$_${ci}$dotc( m, work, 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq end if else rotok = aapp<=( aaqq / small ) if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_${ci}$dotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib${ii}$_${ci}$dotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aapp ) / aaqq else - call stdlib_${ci}$copy( m, a( 1, q ), 1,work, 1 ) - call stdlib_${ci}$lascl( 'G', 0, 0, aaqq,one, m, 1,work, lda, & + call stdlib${ii}$_${ci}$copy( m, a( 1_${ik}$, q ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq,one, m, 1_${ik}$,work, lda, & ierr ) - aapq = stdlib_${ci}$dotc( m, a( 1, p ), 1,work, 1 ) / & + aapq = stdlib${ii}$_${ci}$dotc( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) / & aapp end if end if @@ -20656,10 +20648,10 @@ module stdlib_linalg_lapack_${ci}$ ompq = aapq / abs(aapq) ! Rotate ! [rtd] rotated = rotated + one - if( ir1==0 ) then - notrot = 0 - pskipped = 0 - iswrot = iswrot + 1 + if( ir1==0_${ik}$ ) then + notrot = 0_${ik}$ + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ end if if( rotok ) then aqoap = aaqq / aapp @@ -20668,10 +20660,10 @@ module stdlib_linalg_lapack_${ci}$ if( abs( theta )>bigtheta ) then t = half / theta cs = one - call stdlib_${ci}$rot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_${ci}$rot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *t ) if ( rsvec ) then - call stdlib_${ci}$rot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_${ci}$rot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*t ) end if sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) @@ -20689,23 +20681,23 @@ module stdlib_linalg_lapack_${ci}$ sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq1 ) ) - call stdlib_${ci}$rot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_${ci}$rot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *sn ) if ( rsvec ) then - call stdlib_${ci}$rot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_${ci}$rot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*sn ) end if end if d(p) = -d(q) * ompq else ! .. have to use modified gram-schmidt like transformation - call stdlib_${ci}$copy( m, a( 1, p ), 1,work, 1 ) - call stdlib_${ci}$lascl( 'G', 0, 0, aapp, one, m,1, work, lda,& + call stdlib${ii}$_${ci}$copy( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one, m,1_${ik}$, work, lda,& ierr ) - call stdlib_${ci}$lascl( 'G', 0, 0, aaqq, one, m,1, a( 1, q ), & + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one, m,1_${ik}$, a( 1_${ik}$, q ), & lda, ierr ) - call stdlib_${ci}$axpy( m, -aapq, work, 1,a( 1, q ), 1 ) - call stdlib_${ci}$lascl( 'G', 0, 0, one, aaqq, m,1, a( 1, q ), & + call stdlib${ii}$_${ci}$axpy( m, -aapq, work, 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq, m,1_${ik}$, a( 1_${ik}$, q ), & lda, ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq1*aapq1 ) ) mxsinj = max( mxsinj, sfmin ) @@ -20713,41 +20705,41 @@ module stdlib_linalg_lapack_${ci}$ ! end if rotok then ... else ! in the case of cancellation in updating sva(q), sva(p) ! recompute sva(q), sva(p). - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_${c2ri(ci)}$znrm2( m, a( 1, q ), 1 ) + sva( q ) = stdlib${ii}$_${c2ri(ci)}$znrm2( m, a( 1_${ik}$, q ), 1_${ik}$ ) else t = zero aaqq = one - call stdlib_${ci}$lassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_${ci}$lassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq ) end if end if if( ( aapp / aapp0 )<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_${c2ri(ci)}$znrm2( m, a( 1, p ), 1 ) + aapp = stdlib${ii}$_${c2ri(ci)}$znrm2( m, a( 1_${ik}$, p ), 1_${ik}$ ) else t = zero aapp = one - call stdlib_${ci}$lassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_${ci}$lassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp ) end if sva( p ) = aapp end if else ! a(:,p) and a(:,q) already numerically orthogonal - if( ir1==0 )notrot = notrot + 1 + if( ir1==0_${ik}$ )notrot = notrot + 1_${ik}$ ! [rtd] skipped = skipped + 1 - pskipped = pskipped + 1 + pskipped = pskipped + 1_${ik}$ end if else ! a(:,q) is zero column - if( ir1==0 )notrot = notrot + 1 - pskipped = pskipped + 1 + if( ir1==0_${ik}$ )notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then - if( ir1==0 )aapp = -aapp - notrot = 0 + if( ir1==0_${ik}$ )aapp = -aapp + notrot = 0_${ik}$ go to 2103 end if end do loop_2002 @@ -20757,7 +20749,7 @@ module stdlib_linalg_lapack_${ci}$ sva( p ) = aapp else sva( p ) = aapp - if( ( ir1==0 ) .and. ( aapp==zero ) )notrot = notrot + min( igl+kbl-1, & + if( ( ir1==0_${ik}$ ) .and. ( aapp==zero ) )notrot = notrot + min( igl+kbl-1, & n ) - p end if end do loop_2001 @@ -20766,15 +20758,15 @@ module stdlib_linalg_lapack_${ci}$ end do loop_1002 ! end of ir1-loop ! ... go to the off diagonal blocks - igl = ( ibr-1 )*kbl + 1 + igl = ( ibr-1 )*kbl + 1_${ik}$ loop_2010: do jbc = ibr + 1, nbl - jgl = ( jbc-1 )*kbl + 1 + jgl = ( jbc-1 )*kbl + 1_${ik}$ ! doing the block at ( ibr, jbc ) - ijblsk = 0 + ijblsk = 0_${ik}$ loop_2100: do p = igl, min( igl+kbl-1, n ) aapp = sva( p ) if( aapp>zero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2200: do q = jgl, min( jgl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -20788,13 +20780,13 @@ module stdlib_linalg_lapack_${ci}$ rotok = ( small*aaqq )<=aapp end if if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_${ci}$dotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib${ii}$_${ci}$dotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq ) / aapp else - call stdlib_${ci}$copy( m, a( 1, p ), 1,work, 1 ) - call stdlib_${ci}$lascl( 'G', 0, 0, aapp,one, m, 1,work, lda, & + call stdlib${ii}$_${ci}$copy( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp,one, m, 1_${ik}$,work, lda, & ierr ) - aapq = stdlib_${ci}$dotc( m, work, 1,a( 1, q ), 1 ) / & + aapq = stdlib${ii}$_${ci}$dotc( m, work, 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq end if else @@ -20804,13 +20796,13 @@ module stdlib_linalg_lapack_${ci}$ rotok = aaqq<=( aapp / small ) end if if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_${ci}$dotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / max(& + aapq = ( stdlib${ii}$_${ci}$dotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / max(& aaqq,aapp) )/ min(aaqq,aapp) else - call stdlib_${ci}$copy( m, a( 1, q ), 1,work, 1 ) - call stdlib_${ci}$lascl( 'G', 0, 0, aaqq,one, m, 1,work, lda, & + call stdlib${ii}$_${ci}$copy( m, a( 1_${ik}$, q ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq,one, m, 1_${ik}$,work, lda, & ierr ) - aapq = stdlib_${ci}$dotc( m, a( 1, p ), 1,work, 1 ) / & + aapq = stdlib${ii}$_${ci}$dotc( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) / & aapp end if end if @@ -20820,10 +20812,10 @@ module stdlib_linalg_lapack_${ci}$ ! to rotate or not to rotate, that is the question ... if( abs( aapq1 )>tol ) then ompq = aapq / abs(aapq) - notrot = 0 + notrot = 0_${ik}$ ! [rtd] rotated = rotated + 1 - pskipped = 0 - iswrot = iswrot + 1 + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ if( rotok ) then aqoap = aaqq / aapp apoaq = aapp / aaqq @@ -20832,10 +20824,10 @@ module stdlib_linalg_lapack_${ci}$ if( abs( theta )>bigtheta ) then t = half / theta cs = one - call stdlib_${ci}$rot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_${ci}$rot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *t ) if( rsvec ) then - call stdlib_${ci}$rot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_${ci}$rot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*t ) end if sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) @@ -20854,10 +20846,10 @@ module stdlib_linalg_lapack_${ci}$ sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq1 ) ) - call stdlib_${ci}$rot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_${ci}$rot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *sn ) if( rsvec ) then - call stdlib_${ci}$rot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_${ci}$rot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*sn ) end if end if @@ -20865,27 +20857,27 @@ module stdlib_linalg_lapack_${ci}$ else ! .. have to use modified gram-schmidt like transformation if( aapp>aaqq ) then - call stdlib_${ci}$copy( m, a( 1, p ), 1,work, 1 ) - call stdlib_${ci}$lascl( 'G', 0, 0, aapp, one,m, 1, work,lda,& + call stdlib${ii}$_${ci}$copy( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, work,lda,& ierr ) - call stdlib_${ci}$lascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) - call stdlib_${ci}$axpy( m, -aapq, work,1, a( 1, q ), 1 ) + call stdlib${ii}$_${ci}$axpy( m, -aapq, work,1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) - call stdlib_${ci}$lascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq1*aapq1 ) ) mxsinj = max( mxsinj, sfmin ) else - call stdlib_${ci}$copy( m, a( 1, q ), 1,work, 1 ) - call stdlib_${ci}$lascl( 'G', 0, 0, aaqq, one,m, 1, work,lda,& + call stdlib${ii}$_${ci}$copy( m, a( 1_${ik}$, q ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, work,lda,& ierr ) - call stdlib_${ci}$lascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) - call stdlib_${ci}$axpy( m, -conjg(aapq),work, 1, a( 1, p ), 1 & + call stdlib${ii}$_${ci}$axpy( m, -conjg(aapq),work, 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ & ) - call stdlib_${ci}$lascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, aapp,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) sva( p ) = aapp*sqrt( max( zero,one-aapq1*aapq1 ) ) @@ -20895,47 +20887,47 @@ module stdlib_linalg_lapack_${ci}$ ! end if rotok then ... else ! in the case of cancellation in updating sva(q), sva(p) ! .. recompute sva(q), sva(p) - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_${c2ri(ci)}$znrm2( m, a( 1, q ), 1) + sva( q ) = stdlib${ii}$_${c2ri(ci)}$znrm2( m, a( 1_${ik}$, q ), 1_${ik}$) else t = zero aaqq = one - call stdlib_${ci}$lassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_${ci}$lassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq ) end if end if - if( ( aapp / aapp0 )**2<=rooteps ) then + if( ( aapp / aapp0 )**2_${ik}$<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_${c2ri(ci)}$znrm2( m, a( 1, p ), 1 ) + aapp = stdlib${ii}$_${c2ri(ci)}$znrm2( m, a( 1_${ik}$, p ), 1_${ik}$ ) else t = zero aapp = one - call stdlib_${ci}$lassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_${ci}$lassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp ) end if sva( p ) = aapp end if ! end of ok rotation else - notrot = notrot + 1 + notrot = notrot + 1_${ik}$ ! [rtd] skipped = skipped + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if else - notrot = notrot + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if if( ( i<=swband ) .and. ( ijblsk>=blskip ) )then sva( p ) = aapp - notrot = 0 + notrot = 0_${ik}$ go to 2011 end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then aapp = -aapp - notrot = 0 + notrot = 0_${ik}$ go to 2203 end if end do loop_2200 @@ -20943,8 +20935,8 @@ module stdlib_linalg_lapack_${ci}$ 2203 continue sva( p ) = aapp else - if( aapp==zero )notrot = notrot +min( jgl+kbl-1, n ) - jgl + 1 - if( aapprootsfmin ) )then - sva( n ) = stdlib_${c2ri(ci)}$znrm2( m, a( 1, n ), 1 ) + sva( n ) = stdlib${ii}$_${c2ri(ci)}$znrm2( m, a( 1_${ik}$, n ), 1_${ik}$ ) else t = zero aapp = one - call stdlib_${ci}$lassq( m, a( 1, n ), 1, t, aapp ) + call stdlib${ii}$_${ci}$lassq( m, a( 1_${ik}$, n ), 1_${ik}$, t, aapp ) sva( n ) = t*sqrt( aapp ) end if ! additional steering devices @@ -20977,17 +20969,17 @@ module stdlib_linalg_lapack_${ci}$ end do loop_1993 ! end i=1:nsweep loop ! #:( reaching this point means that the procedure has not converged. - info = nsweep - 1 + info = nsweep - 1_${ik}$ go to 1995 1994 continue ! #:) reaching this point means numerical convergence after the i-th ! sweep. - info = 0 + info = 0_${ik}$ ! #:) info = 0 confirms successful iterations. 1995 continue ! sort the vector sva() of column norms. do p = 1, n - 1 - q = stdlib_i${c2ri(ci)}$amax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib${ii}$_i${c2ri(ci)}$amax( n-p+1, sva( p ), 1_${ik}$ ) + p - 1_${ik}$ if( p/=q ) then temp1 = sva( p ) sva( p ) = sva( q ) @@ -20995,15 +20987,15 @@ module stdlib_linalg_lapack_${ci}$ aapq = d( p ) d( p ) = d( q ) d( q ) = aapq - call stdlib_${ci}$swap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_${ci}$swap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) + call stdlib${ii}$_${ci}$swap( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) + if( rsvec )call stdlib${ii}$_${ci}$swap( mvl, v( 1_${ik}$, p ), 1_${ik}$, v( 1_${ik}$, q ), 1_${ik}$ ) end if end do return - end subroutine stdlib_${ci}$gsvj0 + end subroutine stdlib${ii}$_${ci}$gsvj0 - pure subroutine stdlib_${ci}$gsvj1( jobv, m, n, n1, a, lda, d, sva, mv, v, ldv,eps, sfmin, tol, & + pure subroutine stdlib${ii}$_${ci}$gsvj1( jobv, m, n, n1, a, lda, d, sva, mv, v, ldv,eps, sfmin, tol, & !! ZGSVJ1: is called from ZGESVJ as a pre-processor and that is its main !! purpose. It applies Jacobi rotations in the same way as ZGESVJ does, but !! it targets only particular pivots and it does not check convergence @@ -21034,8 +21026,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${ck}$), intent(in) :: eps, sfmin, tol - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldv, lwork, m, mv, n, n1, nsweep + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldv, lwork, m, mv, n, n1, nsweep character, intent(in) :: jobv ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*), d(n), v(ldv,*) @@ -21047,7 +21039,7 @@ module stdlib_linalg_lapack_${ci}$ complex(${ck}$) :: aapq, ompq real(${ck}$) :: aapp, aapp0, aapq1, aaqq, apoaq, aqoap, big, bigtheta, cs, mxaapq, mxsinj, & rootbig, rooteps, rootsfmin, roottol, small, sn, t, temp1, theta, thsign - integer(ilp) :: blskip, emptsw, i, ibr, igl, ierr, ijblsk, iswrot, jbc, jgl, kbl, mvl, & + integer(${ik}$) :: blskip, emptsw, i, ibr, igl, ierr, ijblsk, iswrot, jbc, jgl, kbl, mvl, & notrot, nblc, nblr, p, pskipped, q, rowskip, swband logical(lk) :: applv, rotok, rsvec ! Intrinsic Functions @@ -21058,31 +21050,31 @@ module stdlib_linalg_lapack_${ci}$ applv = stdlib_lsame( jobv, 'A' ) rsvec = stdlib_lsame( jobv, 'V' ) if( .not.( rsvec .or. applv .or. stdlib_lsame( jobv, 'N' ) ) ) then - info = -1 - else if( m<0 ) then - info = -2 - else if( ( n<0 ) .or. ( n>m ) ) then - info = -3 - else if( n1<0 ) then - info = -4 + info = -1_${ik}$ + else if( m<0_${ik}$ ) then + info = -2_${ik}$ + else if( ( n<0_${ik}$ ) .or. ( n>m ) ) then + info = -3_${ik}$ + else if( n1<0_${ik}$ ) then + info = -4_${ik}$ else if( ldazero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2200: do q = jgl, min( jgl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -21161,13 +21153,13 @@ module stdlib_linalg_lapack_${ci}$ rotok = ( small*aaqq )<=aapp end if if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_${ci}$dotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib${ii}$_${ci}$dotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq ) / aapp else - call stdlib_${ci}$copy( m, a( 1, p ), 1,work, 1 ) - call stdlib_${ci}$lascl( 'G', 0, 0, aapp,one, m, 1,work, lda, & + call stdlib${ii}$_${ci}$copy( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp,one, m, 1_${ik}$,work, lda, & ierr ) - aapq = stdlib_${ci}$dotc( m, work, 1,a( 1, q ), 1 ) / & + aapq = stdlib${ii}$_${ci}$dotc( m, work, 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq end if else @@ -21177,13 +21169,13 @@ module stdlib_linalg_lapack_${ci}$ rotok = aaqq<=( aapp / small ) end if if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_${ci}$dotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / max(& + aapq = ( stdlib${ii}$_${ci}$dotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / max(& aaqq,aapp) )/ min(aaqq,aapp) else - call stdlib_${ci}$copy( m, a( 1, q ), 1,work, 1 ) - call stdlib_${ci}$lascl( 'G', 0, 0, aaqq,one, m, 1,work, lda, & + call stdlib${ii}$_${ci}$copy( m, a( 1_${ik}$, q ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq,one, m, 1_${ik}$,work, lda, & ierr ) - aapq = stdlib_${ci}$dotc( m, a( 1, p ), 1,work, 1 ) / & + aapq = stdlib${ii}$_${ci}$dotc( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) / & aapp end if end if @@ -21193,10 +21185,10 @@ module stdlib_linalg_lapack_${ci}$ ! to rotate or not to rotate, that is the question ... if( abs( aapq1 )>tol ) then ompq = aapq / abs(aapq) - notrot = 0 + notrot = 0_${ik}$ ! [rtd] rotated = rotated + 1 - pskipped = 0 - iswrot = iswrot + 1 + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ if( rotok ) then aqoap = aaqq / aapp apoaq = aapp / aaqq @@ -21205,10 +21197,10 @@ module stdlib_linalg_lapack_${ci}$ if( abs( theta )>bigtheta ) then t = half / theta cs = one - call stdlib_${ci}$rot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_${ci}$rot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *t ) if( rsvec ) then - call stdlib_${ci}$rot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_${ci}$rot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*t ) end if sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) @@ -21227,10 +21219,10 @@ module stdlib_linalg_lapack_${ci}$ sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq1 ) ) - call stdlib_${ci}$rot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_${ci}$rot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *sn ) if( rsvec ) then - call stdlib_${ci}$rot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_${ci}$rot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*sn ) end if end if @@ -21238,27 +21230,27 @@ module stdlib_linalg_lapack_${ci}$ else ! .. have to use modified gram-schmidt like transformation if( aapp>aaqq ) then - call stdlib_${ci}$copy( m, a( 1, p ), 1,work, 1 ) - call stdlib_${ci}$lascl( 'G', 0, 0, aapp, one,m, 1, work,lda,& + call stdlib${ii}$_${ci}$copy( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, work,lda,& ierr ) - call stdlib_${ci}$lascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) - call stdlib_${ci}$axpy( m, -aapq, work,1, a( 1, q ), 1 ) + call stdlib${ii}$_${ci}$axpy( m, -aapq, work,1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) - call stdlib_${ci}$lascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq1*aapq1 ) ) mxsinj = max( mxsinj, sfmin ) else - call stdlib_${ci}$copy( m, a( 1, q ), 1,work, 1 ) - call stdlib_${ci}$lascl( 'G', 0, 0, aaqq, one,m, 1, work,lda,& + call stdlib${ii}$_${ci}$copy( m, a( 1_${ik}$, q ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, work,lda,& ierr ) - call stdlib_${ci}$lascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) - call stdlib_${ci}$axpy( m, -conjg(aapq),work, 1, a( 1, p ), 1 & + call stdlib${ii}$_${ci}$axpy( m, -conjg(aapq),work, 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ & ) - call stdlib_${ci}$lascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, aapp,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) sva( p ) = aapp*sqrt( max( zero,one-aapq1*aapq1 ) ) @@ -21268,47 +21260,47 @@ module stdlib_linalg_lapack_${ci}$ ! end if rotok then ... else ! in the case of cancellation in updating sva(q), sva(p) ! .. recompute sva(q), sva(p) - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_${c2ri(ci)}$znrm2( m, a( 1, q ), 1) + sva( q ) = stdlib${ii}$_${c2ri(ci)}$znrm2( m, a( 1_${ik}$, q ), 1_${ik}$) else t = zero aaqq = one - call stdlib_${ci}$lassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_${ci}$lassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq ) end if end if - if( ( aapp / aapp0 )**2<=rooteps ) then + if( ( aapp / aapp0 )**2_${ik}$<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_${c2ri(ci)}$znrm2( m, a( 1, p ), 1 ) + aapp = stdlib${ii}$_${c2ri(ci)}$znrm2( m, a( 1_${ik}$, p ), 1_${ik}$ ) else t = zero aapp = one - call stdlib_${ci}$lassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_${ci}$lassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp ) end if sva( p ) = aapp end if ! end of ok rotation else - notrot = notrot + 1 + notrot = notrot + 1_${ik}$ ! [rtd] skipped = skipped + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if else - notrot = notrot + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if if( ( i<=swband ) .and. ( ijblsk>=blskip ) )then sva( p ) = aapp - notrot = 0 + notrot = 0_${ik}$ go to 2011 end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then aapp = -aapp - notrot = 0 + notrot = 0_${ik}$ go to 2203 end if end do loop_2200 @@ -21316,8 +21308,8 @@ module stdlib_linalg_lapack_${ci}$ 2203 continue sva( p ) = aapp else - if( aapp==zero )notrot = notrot +min( jgl+kbl-1, n ) - jgl + 1 - if( aapprootsfmin ) )then - sva( n ) = stdlib_${c2ri(ci)}$znrm2( m, a( 1, n ), 1 ) + sva( n ) = stdlib${ii}$_${c2ri(ci)}$znrm2( m, a( 1_${ik}$, n ), 1_${ik}$ ) else t = zero aapp = one - call stdlib_${ci}$lassq( m, a( 1, n ), 1, t, aapp ) + call stdlib${ii}$_${ci}$lassq( m, a( 1_${ik}$, n ), 1_${ik}$, t, aapp ) sva( n ) = t*sqrt( aapp ) end if ! additional steering devices @@ -21350,17 +21342,17 @@ module stdlib_linalg_lapack_${ci}$ end do loop_1993 ! end i=1:nsweep loop ! #:( reaching this point means that the procedure has not converged. - info = nsweep - 1 + info = nsweep - 1_${ik}$ go to 1995 1994 continue ! #:) reaching this point means numerical convergence after the i-th ! sweep. - info = 0 + info = 0_${ik}$ ! #:) info = 0 confirms successful iterations. 1995 continue ! sort the vector sva() of column norms. do p = 1, n - 1 - q = stdlib_i${c2ri(ci)}$amax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib${ii}$_i${c2ri(ci)}$amax( n-p+1, sva( p ), 1_${ik}$ ) + p - 1_${ik}$ if( p/=q ) then temp1 = sva( p ) sva( p ) = sva( q ) @@ -21368,15 +21360,15 @@ module stdlib_linalg_lapack_${ci}$ aapq = d( p ) d( p ) = d( q ) d( q ) = aapq - call stdlib_${ci}$swap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_${ci}$swap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) + call stdlib${ii}$_${ci}$swap( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) + if( rsvec )call stdlib${ii}$_${ci}$swap( mvl, v( 1_${ik}$, p ), 1_${ik}$, v( 1_${ik}$, q ), 1_${ik}$ ) end if end do return - end subroutine stdlib_${ci}$gsvj1 + end subroutine stdlib${ii}$_${ci}$gsvj1 - pure subroutine stdlib_${ci}$gtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond,work, info ) + pure subroutine stdlib${ii}$_${ci}$gtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond,work, info ) !! ZGTCON: estimates the reciprocal of the condition number of a complex !! tridiagonal matrix A using the LU factorization as computed by !! ZGTTRF. @@ -21388,42 +21380,42 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(${ck}$), intent(in) :: anorm real(${ck}$), intent(out) :: rcond ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) complex(${ck}$), intent(in) :: d(*), dl(*), du(*), du2(*) complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: onenrm - integer(ilp) :: i, kase, kase1 + integer(${ik}$) :: i, kase, kase1 real(${ck}$) :: ainvnm ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: cmplx ! Executable Statements ! test the input arguments. - info = 0 + info = 0_${ik}$ onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' ) if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then - info = -1 - else if( n<0 ) then - info = -2 + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ else if( anormeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_${ci}$gttrs( trans, n, 1, dlf, df, duf, du2, ipiv, work, n,info ) - call stdlib_${ci}$axpy( n, cmplx( one,KIND=${ck}$), work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_${ci}$gttrs( trans, n, 1_${ik}$, dlf, df, duf, du2, ipiv, work, n,info ) + call stdlib${ii}$_${ci}$axpy( n, cmplx( one,KIND=${ck}$), work, 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 @@ -21635,13 +21627,13 @@ module stdlib_linalg_lapack_${ci}$ rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 70 continue - call stdlib_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(op(a)**h). - call stdlib_${ci}$gttrs( transt, n, 1, dlf, df, duf, du2, ipiv, work,n, info ) + call stdlib${ii}$_${ci}$gttrs( transt, n, 1_${ik}$, dlf, df, duf, du2, ipiv, work,n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) @@ -21651,7 +21643,7 @@ module stdlib_linalg_lapack_${ci}$ do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_${ci}$gttrs( transn, n, 1, dlf, df, duf, du2, ipiv, work,n, info ) + call stdlib${ii}$_${ci}$gttrs( transn, n, 1_${ik}$, dlf, df, duf, du2, ipiv, work,n, info ) end if go to 70 @@ -21664,10 +21656,10 @@ module stdlib_linalg_lapack_${ci}$ if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_110 return - end subroutine stdlib_${ci}$gtrfs + end subroutine stdlib${ii}$_${ci}$gtrfs - pure subroutine stdlib_${ci}$gtsv( n, nrhs, dl, d, du, b, ldb, info ) + pure subroutine stdlib${ii}$_${ci}$gtsv( n, nrhs, dl, d, du, b, ldb, info ) !! ZGTSV: solves the equation !! A*X = B, !! where A is an N-by-N tridiagonal matrix, by Gaussian elimination with @@ -21678,14 +21670,14 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments complex(${ck}$), intent(inout) :: b(ldb,*), d(*), dl(*), du(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: j, k + integer(${ik}$) :: j, k complex(${ck}$) :: mult, temp, zdum ! Intrinsic Functions intrinsic :: abs,real,aimag,max @@ -21694,16 +21686,16 @@ module stdlib_linalg_lapack_${ci}$ ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements - info = 0 - if( n<0 ) then - info = -1 - else if( nrhs<0 ) then - info = -2 - else if( ldb1 )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 k = n - 2, 1, -1 b( k, j ) = ( b( k, j )-du( k )*b( k+1, j )-dl( k )*b( k+2, j ) ) / d( k ) end do end do return - end subroutine stdlib_${ci}$gtsv + end subroutine stdlib${ii}$_${ci}$gtsv - pure subroutine stdlib_${ci}$gtsvx( fact, trans, n, nrhs, dl, d, du, dlf, df, duf,du2, ipiv, b, & + pure subroutine stdlib${ii}$_${ci}$gtsvx( fact, trans, n, nrhs, dl, d, du, dlf, df, duf,du2, ipiv, b, & !! ZGTSVX: uses the LU factorization to compute the solution to a complex !! system of linear equations A * X = B, A**T * X = B, or A**H * X = B, !! where A is a tridiagonal matrix of order N and X and B are N-by-NRHS @@ -21772,11 +21764,11 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: fact, trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs real(${ck}$), intent(out) :: rcond ! Array Arguments - integer(ilp), intent(inout) :: ipiv(*) + integer(${ik}$), intent(inout) :: ipiv(*) real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*) complex(${ck}$), intent(in) :: b(ldb,*), d(*), dl(*), du(*) complex(${ck}$), intent(inout) :: df(*), dlf(*), du2(*), duf(*) @@ -21790,37 +21782,37 @@ module stdlib_linalg_lapack_${ci}$ ! Intrinsic Functions intrinsic :: max ! Executable Statements - info = 0 + info = 0_${ik}$ nofact = stdlib_lsame( fact, 'N' ) notran = stdlib_lsame( trans, 'N' ) if( .not.nofact .and. .not.stdlib_lsame( fact, 'F' ) ) 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 - else if( n<0 ) then - info = -3 - else if( nrhs<0 ) then - info = -4 - else if( ldb1 ) then - call stdlib_${ci}$copy( n-1, dl, 1, dlf, 1 ) - call stdlib_${ci}$copy( n-1, du, 1, duf, 1 ) + call stdlib${ii}$_${ci}$copy( n, d, 1_${ik}$, df, 1_${ik}$ ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_${ci}$copy( n-1, dl, 1_${ik}$, dlf, 1_${ik}$ ) + call stdlib${ii}$_${ci}$copy( n-1, du, 1_${ik}$, duf, 1_${ik}$ ) end if - call stdlib_${ci}$gttrf( n, dlf, df, duf, du2, ipiv, info ) + call stdlib${ii}$_${ci}$gttrf( n, dlf, df, duf, du2, ipiv, info ) ! return if info is non-zero. - if( info>0 )then + if( info>0_${ik}$ )then rcond = zero return end if @@ -21831,23 +21823,23 @@ module stdlib_linalg_lapack_${ci}$ else norm = 'I' end if - anorm = stdlib_${ci}$langt( norm, n, dl, d, du ) + anorm = stdlib${ii}$_${ci}$langt( norm, n, dl, d, du ) ! compute the reciprocal of the condition number of a. - call stdlib_${ci}$gtcon( norm, n, dlf, df, duf, du2, ipiv, anorm, rcond, work,info ) + call stdlib${ii}$_${ci}$gtcon( norm, n, dlf, df, duf, du2, ipiv, anorm, rcond, work,info ) ! compute the solution vectors x. - call stdlib_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_${ci}$gttrs( trans, n, nrhs, dlf, df, duf, du2, ipiv, x, ldx,info ) + call stdlib${ii}$_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_${ci}$gttrs( trans, n, nrhs, dlf, df, duf, du2, ipiv, x, ldx,info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_${ci}$gtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv,b, ldb, x, ldx, & + call stdlib${ii}$_${ci}$gtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv,b, ldb, x, ldx, & ferr, berr, work, rwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond1 ) then - i = n - 1 + if( n>1_${ik}$ ) then + i = n - 1_${ik}$ if( cabs1( d( i ) )>=cabs1( dl( i ) ) ) then if( cabs1( d( i ) )/=zero ) then fact = dl( i ) / d( i ) @@ -21928,7 +21920,7 @@ module stdlib_linalg_lapack_${ci}$ 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. @@ -21940,10 +21932,10 @@ module stdlib_linalg_lapack_${ci}$ end do 50 continue return - end subroutine stdlib_${ci}$gttrf + end subroutine stdlib${ii}$_${ci}$gttrf - pure subroutine stdlib_${ci}$gttrs( trans, n, nrhs, dl, d, du, du2, ipiv, b, ldb,info ) + pure subroutine stdlib${ii}$_${ci}$gttrs( trans, n, nrhs, dl, d, du, du2, ipiv, b, ldb,info ) !! ZGTTRS: solves one of the systems of equations !! A * X = B, A**T * X = B, or A**H * X = B, !! with a tridiagonal matrix A using the LU factorization computed @@ -21953,63 +21945,63 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) complex(${ck}$), intent(inout) :: b(ldb,*) complex(${ck}$), intent(in) :: d(*), dl(*), du(*), du2(*) ! ===================================================================== ! Local Scalars logical(lk) :: notran - integer(ilp) :: itrans, j, jb, nb + integer(${ik}$) :: itrans, j, jb, nb ! Intrinsic Functions intrinsic :: max,min ! Executable Statements - info = 0 + info = 0_${ik}$ notran = ( trans=='N' .or. trans=='N' ) if( .not.notran .and. .not.( trans=='T' .or. trans=='T' ) .and. .not.( trans=='C' .or. & trans=='C' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( ldb=nrhs ) then - call stdlib_${ci}$gtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) + call stdlib${ii}$_${ci}$gtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) else do j = 1, nrhs, nb jb = min( nrhs-j+1, nb ) - call stdlib_${ci}$gtts2( itrans, n, jb, dl, d, du, du2, ipiv, b( 1, j ),ldb ) + call stdlib${ii}$_${ci}$gtts2( itrans, n, jb, dl, d, du, du2, ipiv, b( 1_${ik}$, j ),ldb ) end do end if - end subroutine stdlib_${ci}$gttrs + end subroutine stdlib${ii}$_${ci}$gttrs - pure subroutine stdlib_${ci}$gtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) + pure subroutine stdlib${ii}$_${ci}$gtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) !! ZGTTS2: solves one of the systems of equations !! A * X = B, A**T * X = B, or A**H * X = B, !! with a tridiagonal matrix A using the LU factorization computed @@ -22018,25 +22010,25 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), intent(inout) :: b(ldb,*) complex(${ck}$), intent(in) :: d(*), dl(*), du(*), du2(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j complex(${ck}$) :: temp ! Intrinsic Functions intrinsic :: conjg ! 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 @@ -22050,13 +22042,13 @@ module stdlib_linalg_lapack_${ci}$ 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 ) end do end do end if - else if( itrans==1 ) then + else if( itrans==1_${ik}$ ) then ! solve a**t * x = b. - if( nrhs<=1 ) then - j = 1 + if( nrhs<=1_${ik}$ ) then + j = 1_${ik}$ 70 continue ! solve u**t * x = b. - 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 & ) @@ -22103,14 +22095,14 @@ module stdlib_linalg_lapack_${ci}$ end if 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 ) @@ -22129,12 +22121,12 @@ module stdlib_linalg_lapack_${ci}$ end if else ! solve a**h * x = b. - if( nrhs<=1 ) then - j = 1 + if( nrhs<=1_${ik}$ ) then + j = 1_${ik}$ 130 continue ! solve u**h * x = b. - b( 1, j ) = b( 1, j ) / conjg( d( 1 ) ) - if( n>1 )b( 2, j ) = ( b( 2, j )-conjg( du( 1 ) )*b( 1, j ) ) /conjg( d( 2 ) ) + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / conjg( d( 1_${ik}$ ) ) + if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-conjg( du( 1_${ik}$ ) )*b( 1_${ik}$, j ) ) /conjg( d( 2_${ik}$ ) ) do i = 3, n b( i, j ) = ( b( i, j )-conjg( du( i-1 ) )*b( i-1, j )-conjg( du2( i-2 ) )*b( & @@ -22151,14 +22143,14 @@ module stdlib_linalg_lapack_${ci}$ end if end do if( j1 )b( 2, j ) = ( b( 2, j )-conjg( du( 1 ) )*b( 1, j ) )/ conjg( d( 2 ) ) + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / conjg( d( 1_${ik}$ ) ) + if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-conjg( du( 1_${ik}$ ) )*b( 1_${ik}$, j ) )/ conjg( d( 2_${ik}$ ) ) do i = 3, n b( i, j ) = ( b( i, j )-conjg( du( i-1 ) )*b( i-1, j )-conjg( du2( i-2 ) )& @@ -22177,10 +22169,10 @@ module stdlib_linalg_lapack_${ci}$ end do end if end if - end subroutine stdlib_${ci}$gtts2 + end subroutine stdlib${ii}$_${ci}$gtts2 - pure subroutine stdlib_${ci}$hb2st_kernels( uplo, wantz, ttype,st, ed, sweep, n, nb, ib,a, lda, & + pure subroutine stdlib${ii}$_${ci}$hb2st_kernels( uplo, wantz, ttype,st, ed, sweep, n, nb, ib,a, lda, & !! ZHB2ST_KERNELS: is an internal routine used by the ZHETRD_HB2ST !! subroutine. v, tau, ldvt, work) @@ -22190,7 +22182,7 @@ module stdlib_linalg_lapack_${ci}$ ! Scalar Arguments character, intent(in) :: uplo logical(lk), intent(in) :: wantz - integer(ilp), intent(in) :: ttype, st, ed, sweep, n, nb, ib, lda, ldvt + integer(${ik}$), intent(in) :: ttype, st, ed, sweep, n, nb, ib, lda, ldvt ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: v(*), tau(*), work(*) @@ -22198,7 +22190,7 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: upper - integer(ilp) :: i, j1, j2, lm, ln, vpos, taupos, dpos, ofdpos, ajeter + integer(${ik}$) :: i, j1, j2, lm, ln, vpos, taupos, dpos, ofdpos, ajeter complex(${ck}$) :: ctmp ! Intrinsic Functions intrinsic :: conjg,mod @@ -22206,54 +22198,54 @@ module stdlib_linalg_lapack_${ci}$ ajeter = ib + ldvt upper = stdlib_lsame( uplo, 'U' ) if( upper ) then - dpos = 2 * nb + 1 - ofdpos = 2 * nb + dpos = 2_${ik}$ * nb + 1_${ik}$ + ofdpos = 2_${ik}$ * nb else - dpos = 1 - ofdpos = 2 + dpos = 1_${ik}$ + ofdpos = 2_${ik}$ endif ! upper case if( upper ) then if( wantz ) then - vpos = mod( sweep-1, 2 ) * n + st - taupos = mod( sweep-1, 2 ) * n + st + vpos = mod( sweep-1, 2_${ik}$ ) * n + st + taupos = mod( sweep-1, 2_${ik}$ ) * n + st else - vpos = mod( sweep-1, 2 ) * n + st - taupos = mod( sweep-1, 2 ) * n + st + vpos = mod( sweep-1, 2_${ik}$ ) * n + st + taupos = mod( sweep-1, 2_${ik}$ ) * n + st endif - if( ttype==1 ) then - lm = ed - st + 1 + if( ttype==1_${ik}$ ) then + lm = ed - st + 1_${ik}$ v( vpos ) = cone do i = 1, lm-1 v( vpos+i ) = conjg( a( ofdpos-i, st+i ) ) a( ofdpos-i, st+i ) = czero end do ctmp = conjg( a( ofdpos, st ) ) - call stdlib_${ci}$larfg( lm, ctmp, v( vpos+1 ), 1,tau( taupos ) ) + call stdlib${ii}$_${ci}$larfg( lm, ctmp, v( vpos+1 ), 1_${ik}$,tau( taupos ) ) a( ofdpos, st ) = ctmp - lm = ed - st + 1 - call stdlib_${ci}$larfy( uplo, lm, v( vpos ), 1,conjg( tau( taupos ) ),a( dpos, st )& + lm = ed - st + 1_${ik}$ + call stdlib${ii}$_${ci}$larfy( uplo, lm, v( vpos ), 1_${ik}$,conjg( tau( taupos ) ),a( dpos, st )& , lda-1, work) endif - if( ttype==3 ) then - lm = ed - st + 1 - call stdlib_${ci}$larfy( uplo, lm, v( vpos ), 1,conjg( tau( taupos ) ),a( dpos, st )& + if( ttype==3_${ik}$ ) then + lm = ed - st + 1_${ik}$ + call stdlib${ii}$_${ci}$larfy( uplo, lm, v( vpos ), 1_${ik}$,conjg( tau( taupos ) ),a( dpos, st )& , lda-1, work) endif - if( ttype==2 ) then + if( ttype==2_${ik}$ ) then j1 = ed+1 j2 = min( ed+nb, n ) ln = ed-st+1 lm = j2-j1+1 - if( lm>0) then - call stdlib_${ci}$larfx( 'LEFT', ln, lm, v( vpos ),conjg( tau( taupos ) ),a( & + if( lm>0_${ik}$) then + call stdlib${ii}$_${ci}$larfx( 'LEFT', ln, lm, v( vpos ),conjg( tau( taupos ) ),a( & dpos-nb, j1 ), lda-1, work) if( wantz ) then - vpos = mod( sweep-1, 2 ) * n + j1 - taupos = mod( sweep-1, 2 ) * n + j1 + vpos = mod( sweep-1, 2_${ik}$ ) * n + j1 + taupos = mod( sweep-1, 2_${ik}$ ) * n + j1 else - vpos = mod( sweep-1, 2 ) * n + j1 - taupos = mod( sweep-1, 2 ) * n + j1 + vpos = mod( sweep-1, 2_${ik}$ ) * n + j1 + taupos = mod( sweep-1, 2_${ik}$ ) * n + j1 endif v( vpos ) = cone do i = 1, lm-1 @@ -22261,71 +22253,71 @@ module stdlib_linalg_lapack_${ci}$ a( dpos-nb-i, j1+i ) = czero end do ctmp = conjg( a( dpos-nb, j1 ) ) - call stdlib_${ci}$larfg( lm, ctmp, v( vpos+1 ), 1, tau( taupos ) ) + call stdlib${ii}$_${ci}$larfg( lm, ctmp, v( vpos+1 ), 1_${ik}$, tau( taupos ) ) a( dpos-nb, j1 ) = ctmp - call stdlib_${ci}$larfx( 'RIGHT', ln-1, lm, v( vpos ),tau( taupos ),a( dpos-nb+& - 1, j1 ), lda-1, work) + call stdlib${ii}$_${ci}$larfx( 'RIGHT', ln-1, lm, v( vpos ),tau( taupos ),a( dpos-nb+& + 1_${ik}$, j1 ), lda-1, work) endif endif ! lower case else if( wantz ) then - vpos = mod( sweep-1, 2 ) * n + st - taupos = mod( sweep-1, 2 ) * n + st + vpos = mod( sweep-1, 2_${ik}$ ) * n + st + taupos = mod( sweep-1, 2_${ik}$ ) * n + st else - vpos = mod( sweep-1, 2 ) * n + st - taupos = mod( sweep-1, 2 ) * n + st + vpos = mod( sweep-1, 2_${ik}$ ) * n + st + taupos = mod( sweep-1, 2_${ik}$ ) * n + st endif - if( ttype==1 ) then - lm = ed - st + 1 + if( ttype==1_${ik}$ ) then + lm = ed - st + 1_${ik}$ v( vpos ) = cone do i = 1, lm-1 v( vpos+i ) = a( ofdpos+i, st-1 ) a( ofdpos+i, st-1 ) = czero end do - call stdlib_${ci}$larfg( lm, a( ofdpos, st-1 ), v( vpos+1 ), 1,tau( taupos ) ) + call stdlib${ii}$_${ci}$larfg( lm, a( ofdpos, st-1 ), v( vpos+1 ), 1_${ik}$,tau( taupos ) ) - lm = ed - st + 1 - call stdlib_${ci}$larfy( uplo, lm, v( vpos ), 1,conjg( tau( taupos ) ),a( dpos, st )& + lm = ed - st + 1_${ik}$ + call stdlib${ii}$_${ci}$larfy( uplo, lm, v( vpos ), 1_${ik}$,conjg( tau( taupos ) ),a( dpos, st )& , lda-1, work) endif - if( ttype==3 ) then - lm = ed - st + 1 - call stdlib_${ci}$larfy( uplo, lm, v( vpos ), 1,conjg( tau( taupos ) ),a( dpos, st )& + if( ttype==3_${ik}$ ) then + lm = ed - st + 1_${ik}$ + call stdlib${ii}$_${ci}$larfy( uplo, lm, v( vpos ), 1_${ik}$,conjg( tau( taupos ) ),a( dpos, st )& , lda-1, work) endif - if( ttype==2 ) then + if( ttype==2_${ik}$ ) then j1 = ed+1 j2 = min( ed+nb, n ) ln = ed-st+1 lm = j2-j1+1 - if( lm>0) then - call stdlib_${ci}$larfx( 'RIGHT', lm, ln, v( vpos ),tau( taupos ), a( dpos+nb, & + if( lm>0_${ik}$) then + call stdlib${ii}$_${ci}$larfx( 'RIGHT', lm, ln, v( vpos ),tau( taupos ), a( dpos+nb, & st ),lda-1, work) if( wantz ) then - vpos = mod( sweep-1, 2 ) * n + j1 - taupos = mod( sweep-1, 2 ) * n + j1 + vpos = mod( sweep-1, 2_${ik}$ ) * n + j1 + taupos = mod( sweep-1, 2_${ik}$ ) * n + j1 else - vpos = mod( sweep-1, 2 ) * n + j1 - taupos = mod( sweep-1, 2 ) * n + j1 + vpos = mod( sweep-1, 2_${ik}$ ) * n + j1 + taupos = mod( sweep-1, 2_${ik}$ ) * n + j1 endif v( vpos ) = cone do i = 1, lm-1 v( vpos+i ) = a( dpos+nb+i, st ) a( dpos+nb+i, st ) = czero end do - call stdlib_${ci}$larfg( lm, a( dpos+nb, st ), v( vpos+1 ), 1,tau( taupos ) ) + call stdlib${ii}$_${ci}$larfg( lm, a( dpos+nb, st ), v( vpos+1 ), 1_${ik}$,tau( taupos ) ) - call stdlib_${ci}$larfx( 'LEFT', lm, ln-1, v( vpos ),conjg( tau( taupos ) ),a( & + call stdlib${ii}$_${ci}$larfx( 'LEFT', lm, ln-1, v( vpos ),conjg( tau( taupos ) ),a( & dpos+nb-1, st+1 ), lda-1, work) endif endif endif return - end subroutine stdlib_${ci}$hb2st_kernels + end subroutine stdlib${ii}$_${ci}$hb2st_kernels - subroutine stdlib_${ci}$hbev( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,rwork, info ) + subroutine stdlib${ii}$_${ci}$hbev( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,rwork, info ) !! ZHBEV: computes all the eigenvalues and, optionally, eigenvectors of !! a complex Hermitian band matrix A. ! -- lapack driver routine -- @@ -22333,8 +22325,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kd, ldab, ldz, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kd, ldab, ldz, n ! Array Arguments real(${ck}$), intent(out) :: rwork(*), w(*) complex(${ck}$), intent(inout) :: ab(ldab,*) @@ -22343,7 +22335,7 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: lower, wantz - integer(ilp) :: iinfo, imax, inde, indrwk, iscale + integer(${ik}$) :: iinfo, imax, inde, indrwk, iscale real(${ck}$) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! Intrinsic Functions intrinsic :: sqrt @@ -22351,85 +22343,85 @@ module stdlib_linalg_lapack_${ci}$ ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) lower = stdlib_lsame( uplo, 'L' ) - info = 0 + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) 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( ldabzero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then - call stdlib_${ci}$lascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_${ci}$lascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) else - call stdlib_${ci}$lascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_${ci}$lascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) end if end if - ! call stdlib_${ci}$hbtrd to reduce hermitian band matrix to tridiagonal form. - inde = 1 - call stdlib_${ci}$hbtrd( jobz, uplo, n, kd, ab, ldab, w, rwork( inde ), z,ldz, work, iinfo ) + ! call stdlib${ii}$_${ci}$hbtrd to reduce hermitian band matrix to tridiagonal form. + inde = 1_${ik}$ + call stdlib${ii}$_${ci}$hbtrd( jobz, uplo, n, kd, ab, ldab, w, rwork( inde ), z,ldz, work, iinfo ) - ! for eigenvalues only, call stdlib_${c2ri(ci)}$sterf. for eigenvectors, call stdlib_${ci}$steqr. + ! for eigenvalues only, call stdlib${ii}$_${c2ri(ci)}$sterf. for eigenvectors, call stdlib${ii}$_${ci}$steqr. if( .not.wantz ) then - call stdlib_${c2ri(ci)}$sterf( n, w, rwork( inde ), info ) + call stdlib${ii}$_${c2ri(ci)}$sterf( n, w, rwork( inde ), info ) else indrwk = inde + n - call stdlib_${ci}$steqr( jobz, n, w, rwork( inde ), z, ldz,rwork( indrwk ), info ) + call stdlib${ii}$_${ci}$steqr( jobz, n, w, rwork( inde ), z, ldz,rwork( indrwk ), info ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = n else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_${c2ri(ci)}$scal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_${c2ri(ci)}$scal( imax, one / sigma, w, 1_${ik}$ ) end if return - end subroutine stdlib_${ci}$hbev + end subroutine stdlib${ii}$_${ci}$hbev - subroutine stdlib_${ci}$hbevd( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,lwork, rwork, lrwork, & + subroutine stdlib${ii}$_${ci}$hbevd( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,lwork, rwork, lrwork, & !! ZHBEVD: computes all the eigenvalues and, optionally, eigenvectors of !! a complex Hermitian band matrix A. If eigenvectors are desired, it !! uses a divide and conquer algorithm. @@ -22445,10 +22437,10 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kd, ldab, ldz, liwork, lrwork, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kd, ldab, ldz, liwork, lrwork, lwork, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(${ck}$), intent(out) :: rwork(*), w(*) complex(${ck}$), intent(inout) :: ab(ldab,*) complex(${ck}$), intent(out) :: work(*), z(ldz,*) @@ -22457,7 +22449,7 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: lower, lquery, wantz - integer(ilp) :: iinfo, imax, inde, indwk2, indwrk, iscale, liwmin, llrwk, llwk2, & + integer(${ik}$) :: iinfo, imax, inde, indwk2, indwrk, iscale, liwmin, llrwk, llwk2, & lrwmin, lwmin real(${ck}$) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! Intrinsic Functions @@ -22466,120 +22458,120 @@ module stdlib_linalg_lapack_${ci}$ ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) lower = stdlib_lsame( uplo, 'L' ) - lquery = ( lwork==-1 .or. liwork==-1 .or. lrwork==-1 ) - info = 0 - if( n<=1 ) then - lwmin = 1 - lrwmin = 1 - liwmin = 1 + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ .or. lrwork==-1_${ik}$ ) + info = 0_${ik}$ + if( n<=1_${ik}$ ) then + lwmin = 1_${ik}$ + lrwmin = 1_${ik}$ + liwmin = 1_${ik}$ else if( wantz ) then - lwmin = 2*n**2 - lrwmin = 1 + 5*n + 2*n**2 - liwmin = 3 + 5*n + lwmin = 2_${ik}$*n**2_${ik}$ + lrwmin = 1_${ik}$ + 5_${ik}$*n + 2_${ik}$*n**2_${ik}$ + liwmin = 3_${ik}$ + 5_${ik}$*n else lwmin = n lrwmin = n - liwmin = 1 + liwmin = 1_${ik}$ end if end if if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) 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( ldabzero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then - call stdlib_${ci}$lascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_${ci}$lascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) else - call stdlib_${ci}$lascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_${ci}$lascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) end if end if - ! call stdlib_${ci}$hbtrd to reduce hermitian band matrix to tridiagonal form. - inde = 1 + ! call stdlib${ii}$_${ci}$hbtrd to reduce hermitian band matrix to tridiagonal form. + inde = 1_${ik}$ indwrk = inde + n - indwk2 = 1 + n*n - llwk2 = lwork - indwk2 + 1 - llrwk = lrwork - indwrk + 1 - call stdlib_${ci}$hbtrd( jobz, uplo, n, kd, ab, ldab, w, rwork( inde ), z,ldz, work, iinfo ) + indwk2 = 1_${ik}$ + n*n + llwk2 = lwork - indwk2 + 1_${ik}$ + llrwk = lrwork - indwrk + 1_${ik}$ + call stdlib${ii}$_${ci}$hbtrd( jobz, uplo, n, kd, ab, ldab, w, rwork( inde ), z,ldz, work, iinfo ) - ! for eigenvalues only, call stdlib_${c2ri(ci)}$sterf. for eigenvectors, call stdlib_${ci}$stedc. + ! for eigenvalues only, call stdlib${ii}$_${c2ri(ci)}$sterf. for eigenvectors, call stdlib${ii}$_${ci}$stedc. if( .not.wantz ) then - call stdlib_${c2ri(ci)}$sterf( n, w, rwork( inde ), info ) + call stdlib${ii}$_${c2ri(ci)}$sterf( n, w, rwork( inde ), info ) else - call stdlib_${ci}$stedc( 'I', n, w, rwork( inde ), work, n, work( indwk2 ),llwk2, rwork( & + call stdlib${ii}$_${ci}$stedc( 'I', n, w, rwork( inde ), work, n, work( indwk2 ),llwk2, rwork( & indwrk ), llrwk, iwork, liwork,info ) - call stdlib_${ci}$gemm( 'N', 'N', n, n, n, cone, z, ldz, work, n, czero,work( indwk2 ), & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', n, n, n, cone, z, ldz, work, n, czero,work( indwk2 ), & n ) - call stdlib_${ci}$lacpy( 'A', n, n, work( indwk2 ), n, z, ldz ) + call stdlib${ii}$_${ci}$lacpy( 'A', n, n, work( indwk2 ), n, z, ldz ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = n else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_${c2ri(ci)}$scal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_${c2ri(ci)}$scal( imax, one / sigma, w, 1_${ik}$ ) end if - work( 1 ) = lwmin - rwork( 1 ) = lrwmin - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = lwmin + rwork( 1_${ik}$ ) = lrwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_${ci}$hbevd + end subroutine stdlib${ii}$_${ci}$hbevd - subroutine stdlib_${ci}$hbevx( jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl,vu, il, iu, abstol, & + subroutine stdlib${ii}$_${ci}$hbevx( jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl,vu, il, iu, abstol, & !! ZHBEVX: computes selected eigenvalues and, optionally, eigenvectors !! of a complex Hermitian band matrix A. Eigenvalues and eigenvectors !! can be selected by specifying either a range of values or a range of @@ -22590,11 +22582,11 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range, uplo - integer(ilp), intent(in) :: il, iu, kd, ldab, ldq, ldz, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, iu, kd, ldab, ldq, ldz, n + integer(${ik}$), intent(out) :: info, m real(${ck}$), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: ifail(*), iwork(*) + integer(${ik}$), intent(out) :: ifail(*), iwork(*) real(${ck}$), intent(out) :: rwork(*), w(*) complex(${ck}$), intent(inout) :: ab(ldab,*) complex(${ck}$), intent(out) :: q(ldq,*), work(*), z(ldz,*) @@ -22604,7 +22596,7 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: alleig, indeig, lower, test, valeig, wantz character :: order - integer(ilp) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwk, indrwk, & + integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwk, indrwk, & indwrk, iscale, itmp1, j, jj, nsplit real(${ck}$) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, & vuu @@ -22618,68 +22610,68 @@ module stdlib_linalg_lapack_${ci}$ valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) lower = stdlib_lsame( uplo, 'L' ) - info = 0 + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( kd<0 ) then - info = -5 + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( kd<0_${ik}$ ) then + info = -5_${ik}$ else if( ldab0 .and. vu<=vl )info = -11 + if( n>0_${ik}$ .and. vu<=vl )info = -11_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -12 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -12_${ik}$ else if( iun ) then - info = -13 + info = -13_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz=tmp1 ) )m = 0 + if( .not.( vl=tmp1 ) )m = 0_${ik}$ end if - if( m==1 ) then - w( 1 ) = real( ctmp1,KIND=${ck}$) - if( wantz )z( 1, 1 ) = cone + if( m==1_${ik}$ ) then + w( 1_${ik}$ ) = real( ctmp1,KIND=${ck}$) + if( wantz )z( 1_${ik}$, 1_${ik}$ ) = cone end if return end if ! get machine constants. - safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) - eps = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) ) ! scale matrix to allowable range, if necessary. - iscale = 0 + iscale = 0_${ik}$ abstll = abstol if( valeig ) then vll = vl @@ -22688,102 +22680,102 @@ module stdlib_linalg_lapack_${ci}$ vll = zero vuu = zero end if - anrm = stdlib_${ci}$lanhb( 'M', uplo, n, kd, ab, ldab, rwork ) + anrm = stdlib${ii}$_${ci}$lanhb( 'M', uplo, n, kd, ab, ldab, rwork ) if( anrm>zero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then - call stdlib_${ci}$lascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_${ci}$lascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) else - call stdlib_${ci}$lascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_${ci}$lascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) end if - if( abstol>0 )abstll = abstol*sigma + if( abstol>0_${ik}$ )abstll = abstol*sigma if( valeig ) then vll = vl*sigma vuu = vu*sigma end if end if - ! call stdlib_${ci}$hbtrd to reduce hermitian band matrix to tridiagonal form. - indd = 1 + ! call stdlib${ii}$_${ci}$hbtrd to reduce hermitian band matrix to tridiagonal form. + indd = 1_${ik}$ inde = indd + n indrwk = inde + n - indwrk = 1 - call stdlib_${ci}$hbtrd( jobz, uplo, n, kd, ab, ldab, rwork( indd ),rwork( inde ), q, ldq, & + indwrk = 1_${ik}$ + call stdlib${ii}$_${ci}$hbtrd( jobz, uplo, n, kd, ab, ldab, rwork( indd ),rwork( inde ), q, ldq, & work( indwrk ), iinfo ) ! if all eigenvalues are desired and abstol is less than or equal - ! to zero, then call stdlib_${c2ri(ci)}$sterf or stdlib_${ci}$steqr. if this fails for some - ! eigenvalue, then try stdlib_${c2ri(ci)}$stebz. + ! to zero, then call stdlib${ii}$_${c2ri(ci)}$sterf or stdlib${ii}$_${ci}$steqr. if this fails for some + ! eigenvalue, then try stdlib${ii}$_${c2ri(ci)}$stebz. test = .false. if (indeig) then - if (il==1 .and. iu==n) then + if (il==1_${ik}$ .and. iu==n) then test = .true. end if end if if ((alleig .or. test) .and. (abstol<=zero)) then - call stdlib_${c2ri(ci)}$copy( n, rwork( indd ), 1, w, 1 ) - indee = indrwk + 2*n + call stdlib${ii}$_${c2ri(ci)}$copy( n, rwork( indd ), 1_${ik}$, w, 1_${ik}$ ) + indee = indrwk + 2_${ik}$*n if( .not.wantz ) then - call stdlib_${c2ri(ci)}$copy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) - call stdlib_${c2ri(ci)}$sterf( n, w, rwork( indee ), info ) + call stdlib${ii}$_${c2ri(ci)}$copy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ ) + call stdlib${ii}$_${c2ri(ci)}$sterf( n, w, rwork( indee ), info ) else - call stdlib_${ci}$lacpy( 'A', n, n, q, ldq, z, ldz ) - call stdlib_${c2ri(ci)}$copy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) - call stdlib_${ci}$steqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) + call stdlib${ii}$_${ci}$lacpy( 'A', n, n, q, ldq, z, ldz ) + call stdlib${ii}$_${c2ri(ci)}$copy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$steqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) - if( info==0 ) then + if( info==0_${ik}$ ) then do i = 1, n - ifail( i ) = 0 + ifail( i ) = 0_${ik}$ end do end if end if - if( info==0 ) then + if( info==0_${ik}$ ) then m = n go to 30 end if - info = 0 + info = 0_${ik}$ end if - ! otherwise, call stdlib_${c2ri(ci)}$stebz and, if eigenvectors are desired, stdlib_${ci}$stein. + ! otherwise, call stdlib${ii}$_${c2ri(ci)}$stebz and, if eigenvectors are desired, stdlib${ii}$_${ci}$stein. if( wantz ) then order = 'B' else order = 'E' end if - indibl = 1 + indibl = 1_${ik}$ indisp = indibl + n indiwk = indisp + n - call stdlib_${c2ri(ci)}$stebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indd ), rwork( & + call stdlib${ii}$_${c2ri(ci)}$stebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indd ), rwork( & inde ), m, nsplit, w,iwork( indibl ), iwork( indisp ), rwork( indrwk ),iwork( indiwk ),& info ) if( wantz ) then - call stdlib_${ci}$stein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & + call stdlib${ii}$_${ci}$stein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,rwork( indrwk ), iwork( indiwk ), ifail, info ) ! apply unitary matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_${ci}$stein. + ! form to eigenvectors returned by stdlib${ii}$_${ci}$stein. do j = 1, m - call stdlib_${ci}$copy( n, z( 1, j ), 1, work( 1 ), 1 ) - call stdlib_${ci}$gemv( 'N', n, n, cone, q, ldq, work, 1, czero,z( 1, j ), 1 ) + call stdlib${ii}$_${ci}$copy( n, z( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$gemv( 'N', n, n, cone, q, ldq, work, 1_${ik}$, czero,z( 1_${ik}$, j ), 1_${ik}$ ) end do end if ! if matrix was scaled, then rescale eigenvalues appropriately. 30 continue - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = m else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_${c2ri(ci)}$scal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_${c2ri(ci)}$scal( imax, one / sigma, w, 1_${ik}$ ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. if( wantz ) then do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp1 = w( j ) do jj = j + 1, m if( w( jj )ka ) 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_${ci}$gerc( n-m, kbt, -cone, x( m+1, i ), 1,bb( kb1-kbt, i )& - , 1, x( m+1, i-kbt ),ldx ) + call stdlib${ii}$_${ci}$dscal( n-m, one / bii, x( m+1, i ), 1_${ik}$ ) + if( kbt>0_${ik}$ )call stdlib${ii}$_${ci}$gerc( n-m, kbt, -cone, 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 ) @@ -22987,21 +22979,21 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$lartg( ab( k+1, i-k+ka ), ra1,rwork( i-k+ka-m ), work( i-k+ka-& + call stdlib${ii}$_${ci}$lartg( ab( k+1, i-k+ka ), ra1,rwork( i-k+ka-m ), work( i-k+ka-& m ), ra ) ! create nonzero element a(i-k,i-k+ka+1) outside the ! band and store it in work(i-k) t = -bb( kb1-k, i )*ra1 - work( i-k ) = rwork( i-k+ka-m )*t -conjg( work( i-k+ka-m ) )*ab( 1, i-k+ka & + work( i-k ) = rwork( i-k+ka-m )*t -conjg( work( i-k+ka-m ) )*ab( 1_${ik}$, i-k+ka & ) - ab( 1, i-k+ka ) = work( i-k+ka-m )*t +rwork( i-k+ka-m )*ab( 1, i-k+ka ) + ab( 1_${ik}$, i-k+ka ) = work( i-k+ka-m )*t +rwork( 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 @@ -23013,41 +23005,41 @@ module stdlib_linalg_lapack_${ci}$ 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 ) = rwork( j-m )*ab( 1, j+1 ) + work( j-m ) = work( j-m )*ab( 1_${ik}$, j+1 ) + ab( 1_${ik}$, j+1 ) = rwork( j-m )*ab( 1_${ik}$, j+1 ) end do ! generate rotations in 1st set to annihilate elements which ! have been created outside the band - if( nrt>0 )call stdlib_${ci}$largv( nrt, ab( 1, j2t ), inca, work( j2t-m ), ka1,rwork(& + if( nrt>0_${ik}$ )call stdlib${ii}$_${ci}$largv( nrt, ab( 1_${ik}$, j2t ), inca, work( j2t-m ), ka1,rwork(& j2t-m ), ka1 ) - if( nr>0 ) then + if( nr>0_${ik}$ ) then ! apply rotations in 1st set from the right do l = 1, ka - 1 - call stdlib_${ci}$lartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, & + call stdlib${ii}$_${ci}$lartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, & rwork( j2-m ),work( j2-m ), ka1 ) end do ! apply rotations in 1st set from both sides to diagonal ! blocks - call stdlib_${ci}$lar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & + call stdlib${ii}$_${ci}$lar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & rwork( j2-m ),work( j2-m ), ka1 ) - call stdlib_${ci}$lacgv( nr, work( j2-m ), ka1 ) + call stdlib${ii}$_${ci}$lacgv( nr, work( j2-m ), ka1 ) end if ! start applying rotations in 1st set from the left do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & + if( nrt>0_${ik}$ )call stdlib${ii}$_${ci}$lartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & ), inca, rwork( j2-m ),work( j2-m ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 1st set do j = j2, j1, ka1 - call stdlib_${ci}$rot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,rwork( j-m ), & + call stdlib${ii}$_${ci}$rot( n-m, x( m+1, j ), 1_${ik}$, x( m+1, j+1 ), 1_${ik}$,rwork( j-m ), & conjg( 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 @@ -23055,14 +23047,14 @@ module stdlib_linalg_lapack_${ci}$ 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 do l = kb - k, 1, -1 nrt = ( n-j2+ka+l ) / ka1 - if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( l, j2-l+1 ), inca,ab( l+1, j2-l+1 ), & + if( nrt>0_${ik}$ )call stdlib${ii}$_${ci}$lartv( nrt, ab( l, j2-l+1 ), inca,ab( l+1, j2-l+1 ), & inca, rwork( j2-ka ),work( j2-ka ), ka1 ) end do nr = ( n-j2+ka ) / ka1 @@ -23074,57 +23066,57 @@ module stdlib_linalg_lapack_${ci}$ 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 ) = rwork( j )*ab( 1, j+1 ) + work( j ) = work( j )*ab( 1_${ik}$, j+1 ) + ab( 1_${ik}$, j+1 ) = rwork( j )*ab( 1_${ik}$, j+1 ) end do if( update ) then if( i-k0 ) then + if( nr>0_${ik}$ ) then ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band - call stdlib_${ci}$largv( nr, ab( 1, j2 ), inca, work( j2 ), ka1,rwork( j2 ), ka1 ) + call stdlib${ii}$_${ci}$largv( nr, ab( 1_${ik}$, j2 ), inca, work( j2 ), ka1,rwork( j2 ), ka1 ) ! apply rotations in 2nd set from the right do l = 1, ka - 1 - call stdlib_${ci}$lartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, & + call stdlib${ii}$_${ci}$lartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, & rwork( j2 ),work( j2 ), ka1 ) end do ! apply rotations in 2nd set from both sides to diagonal ! blocks - call stdlib_${ci}$lar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & + call stdlib${ii}$_${ci}$lar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & rwork( j2 ),work( j2 ), ka1 ) - call stdlib_${ci}$lacgv( nr, work( j2 ), ka1 ) + call stdlib${ii}$_${ci}$lacgv( nr, work( j2 ), ka1 ) end if ! start applying rotations in 2nd set from the left do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & + if( nrt>0_${ik}$ )call stdlib${ii}$_${ci}$lartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & ), inca, rwork( j2 ),work( j2 ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 2nd set do j = j2, j1, ka1 - call stdlib_${ci}$rot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,rwork( j ), conjg( & + call stdlib${ii}$_${ci}$rot( n-m, x( m+1, j ), 1_${ik}$, x( m+1, j+1 ), 1_${ik}$,rwork( j ), conjg( & 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 + j2 = i - k - 1_${ik}$ + max( 1_${ik}$, k-i0+2 )*ka1 ! finish applying rotations in 1st set from the left do l = kb - k, 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & + if( nrt>0_${ik}$ )call stdlib${ii}$_${ci}$lartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & ), inca, rwork( j2-m ),work( j2-m ), ka1 ) end do end do - if( kb>1 ) then + if( kb>1_${ik}$ ) then do j = n - 1, j2 + ka, -1 rwork( j-m ) = rwork( j-ka-m ) work( j-m ) = work( j-ka-m ) @@ -23134,8 +23126,8 @@ module stdlib_linalg_lapack_${ci}$ ! transform a, working with the lower triangle if( update ) then ! form inv(s(i))**h * a * inv(s(i)) - bii = real( bb( 1, i ),KIND=${ck}$) - ab( 1, i ) = ( real( ab( 1, i ),KIND=${ck}$) / bii ) / bii + bii = real( bb( 1_${ik}$, i ),KIND=${ck}$) + ab( 1_${ik}$, i ) = ( real( ab( 1_${ik}$, i ),KIND=${ck}$) / bii ) / bii do j = i + 1, i1 ab( j-i+1, i ) = ab( j-i+1, i ) / bii end do @@ -23145,8 +23137,8 @@ module stdlib_linalg_lapack_${ci}$ do k = i - kbt, i - 1 do j = i - kbt, k ab( k-j+1, j ) = ab( k-j+1, j ) -bb( i-j+1, j )*conjg( ab( i-k+1,k ) ) - & - conjg( bb( i-k+1, k ) )*ab( i-j+1, j ) + real( ab( 1, i ),KIND=${ck}$)*bb( i-j+& - 1, j )*conjg( bb( i-k+1,k ) ) + conjg( bb( i-k+1, k ) )*ab( i-j+1, j ) + real( ab( 1_${ik}$, i ),KIND=${ck}$)*bb( i-j+& + 1_${ik}$, j )*conjg( 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 ) -conjg( bb( i-k+1, k ) )*ab( i-j+1, j ) @@ -23160,8 +23152,8 @@ module stdlib_linalg_lapack_${ci}$ end do if( wantx ) then ! post-multiply x by inv(s(i)) - call stdlib_${ci}$dscal( n-m, one / bii, x( m+1, i ), 1 ) - if( kbt>0 )call stdlib_${ci}$geru( n-m, kbt, -cone, x( m+1, i ), 1,bb( kbt+1, i-& + call stdlib${ii}$_${ci}$dscal( n-m, one / bii, x( m+1, i ), 1_${ik}$ ) + if( kbt>0_${ik}$ )call stdlib${ii}$_${ci}$geru( n-m, kbt, -cone, 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 @@ -23174,9 +23166,9 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$lartg( ab( ka1-k, i ), ra1, rwork( i-k+ka-m ),work( i-k+ka-m )& + call stdlib${ii}$_${ci}$lartg( ab( ka1-k, i ), ra1, rwork( i-k+ka-m ),work( i-k+ka-m )& , ra ) ! create nonzero element a(i-k+ka+1,i-k) outside the ! band and store it in work(i-k) @@ -23188,7 +23180,7 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -23205,36 +23197,36 @@ module stdlib_linalg_lapack_${ci}$ end do ! generate rotations in 1st set to annihilate elements which ! have been created outside the band - if( nrt>0 )call stdlib_${ci}$largv( nrt, ab( ka1, j2t-ka ), inca, work( j2t-m ),ka1, & + if( nrt>0_${ik}$ )call stdlib${ii}$_${ci}$largv( nrt, ab( ka1, j2t-ka ), inca, work( j2t-m ),ka1, & rwork( j2t-m ), ka1 ) - if( nr>0 ) then + if( nr>0_${ik}$ ) then ! apply rotations in 1st set from the left do l = 1, ka - 1 - call stdlib_${ci}$lartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, rwork(& + call stdlib${ii}$_${ci}$lartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, rwork(& j2-m ),work( j2-m ), ka1 ) end do ! apply rotations in 1st set from both sides to diagonal ! blocks - call stdlib_${ci}$lar2v( nr, ab( 1, j2 ), ab( 1, j2+1 ), ab( 2, j2 ),inca, rwork( & + call stdlib${ii}$_${ci}$lar2v( nr, ab( 1_${ik}$, j2 ), ab( 1_${ik}$, j2+1 ), ab( 2_${ik}$, j2 ),inca, rwork( & j2-m ), work( j2-m ), ka1 ) - call stdlib_${ci}$lacgv( nr, work( j2-m ), ka1 ) + call stdlib${ii}$_${ci}$lacgv( nr, work( j2-m ), ka1 ) end if ! start applying rotations in 1st set from the right do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& + if( nrt>0_${ik}$ )call stdlib${ii}$_${ci}$lartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& inca, rwork( j2-m ),work( j2-m ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 1st set do j = j2, j1, ka1 - call stdlib_${ci}$rot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,rwork( j-m ), work(& + call stdlib${ii}$_${ci}$rot( n-m, x( m+1, j ), 1_${ik}$, x( m+1, j+1 ), 1_${ik}$,rwork( 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 @@ -23242,14 +23234,14 @@ module stdlib_linalg_lapack_${ci}$ 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 do l = kb - k, 1, -1 nrt = ( n-j2+ka+l ) / ka1 - if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( ka1-l+1, j2-ka ), inca,ab( ka1-l, j2-& + if( nrt>0_${ik}$ )call stdlib${ii}$_${ci}$lartv( nrt, ab( ka1-l+1, j2-ka ), inca,ab( ka1-l, j2-& ka+1 ), inca,rwork( j2-ka ), work( j2-ka ), ka1 ) end do nr = ( n-j2+ka ) / ka1 @@ -23269,49 +23261,49 @@ module stdlib_linalg_lapack_${ci}$ 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 + if( nr>0_${ik}$ ) then ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band - call stdlib_${ci}$largv( nr, ab( ka1, j2-ka ), inca, work( j2 ), ka1,rwork( j2 ), & + call stdlib${ii}$_${ci}$largv( nr, ab( ka1, j2-ka ), inca, work( j2 ), ka1,rwork( j2 ), & ka1 ) ! apply rotations in 2nd set from the left do l = 1, ka - 1 - call stdlib_${ci}$lartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, rwork(& + call stdlib${ii}$_${ci}$lartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, rwork(& j2 ),work( j2 ), ka1 ) end do ! apply rotations in 2nd set from both sides to diagonal ! blocks - call stdlib_${ci}$lar2v( nr, ab( 1, j2 ), ab( 1, j2+1 ), ab( 2, j2 ),inca, rwork( & + call stdlib${ii}$_${ci}$lar2v( nr, ab( 1_${ik}$, j2 ), ab( 1_${ik}$, j2+1 ), ab( 2_${ik}$, j2 ),inca, rwork( & j2 ), work( j2 ), ka1 ) - call stdlib_${ci}$lacgv( nr, work( j2 ), ka1 ) + call stdlib${ii}$_${ci}$lacgv( nr, work( j2 ), ka1 ) end if ! start applying rotations in 2nd set from the right do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& + if( nrt>0_${ik}$ )call stdlib${ii}$_${ci}$lartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& inca, rwork( j2 ),work( j2 ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 2nd set do j = j2, j1, ka1 - call stdlib_${ci}$rot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,rwork( j ), work( & + call stdlib${ii}$_${ci}$rot( n-m, x( m+1, j ), 1_${ik}$, x( m+1, j+1 ), 1_${ik}$,rwork( 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 + j2 = i - k - 1_${ik}$ + max( 1_${ik}$, k-i0+2 )*ka1 ! finish applying rotations in 1st set from the right do l = kb - k, 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& + if( nrt>0_${ik}$ )call stdlib${ii}$_${ci}$lartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& inca, rwork( j2-m ),work( j2-m ), ka1 ) end do end do - if( kb>1 ) then + if( kb>1_${ik}$ ) then do j = n - 1, j2 + ka, -1 rwork( j-m ) = rwork( j-ka-m ) work( j-m ) = work( j-ka-m ) @@ -23333,18 +23325,18 @@ module stdlib_linalg_lapack_${ci}$ ! 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 @@ -23388,9 +23380,9 @@ module stdlib_linalg_lapack_${ci}$ end do if( wantx ) then ! post-multiply x by inv(s(i)) - call stdlib_${ci}$dscal( nx, one / bii, x( 1, i ), 1 ) - if( kbt>0 )call stdlib_${ci}$geru( nx, kbt, -cone, x( 1, i ), 1,bb( kb, i+1 ), & - ldbb-1, x( 1, i+1 ), ldx ) + call stdlib${ii}$_${ci}$dscal( nx, one / bii, x( 1_${ik}$, i ), 1_${ik}$ ) + if( kbt>0_${ik}$ )call stdlib${ii}$_${ci}$geru( nx, kbt, -cone, x( 1_${ik}$, i ), 1_${ik}$,bb( kb, i+1 ), & + ldbb-1, 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 ) @@ -23401,20 +23393,20 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$largv( nrt, ab( 1, j1+ka ), inca, work( j1 ), ka1,rwork( & + if( nrt>0_${ik}$ )call stdlib${ii}$_${ci}$largv( nrt, ab( 1_${ik}$, j1+ka ), inca, work( j1 ), ka1,rwork( & j1 ), ka1 ) - if( nr>0 ) then + if( nr>0_${ik}$ ) then ! apply rotations in 1st set from the left do l = 1, ka - 1 - call stdlib_${ci}$lartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca, & + call stdlib${ii}$_${ci}$lartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca, & rwork( j1 ),work( j1 ), ka1 ) end do ! apply rotations in 1st set from both sides to diagonal ! blocks - call stdlib_${ci}$lar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & + call stdlib${ii}$_${ci}$lar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & rwork( j1 ), work( j1 ),ka1 ) - call stdlib_${ci}$lacgv( nr, work( j1 ), ka1 ) + call stdlib${ii}$_${ci}$lacgv( nr, work( j1 ), ka1 ) end if ! start applying rotations in 1st set from the right do l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& + if( nrt>0_${ik}$ )call stdlib${ii}$_${ci}$lartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& rwork( j1t ),work( j1t ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 1st set do j = j1, j2, ka1 - call stdlib_${ci}$rot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,rwork( j ), work( j ) ) + call stdlib${ii}$_${ci}$rot( nx, x( 1_${ik}$, j ), 1_${ik}$, x( 1_${ik}$, j-1 ), 1_${ik}$,rwork( 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 @@ -23469,15 +23461,15 @@ module stdlib_linalg_lapack_${ci}$ 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 do l = kb - k, 1, -1 nrt = ( j2+ka+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( l, j1t+ka ), inca,ab( l+1, j1t+ka-1 ),& + if( nrt>0_${ik}$ )call stdlib${ii}$_${ci}$lartv( nrt, ab( l, j1t+ka ), inca,ab( l+1, j1t+ka-1 ),& inca,rwork( m-kb+j1t+ka ),work( m-kb+j1t+ka ), ka1 ) end do nr = ( j2+ka-1 ) / ka1 @@ -23489,59 +23481,59 @@ module stdlib_linalg_lapack_${ci}$ 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 ) = rwork( 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 ) = rwork( 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 + if( nr>0_${ik}$ ) then ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band - call stdlib_${ci}$largv( nr, ab( 1, j1+ka ), inca, work( m-kb+j1 ),ka1, rwork( m-& + call stdlib${ii}$_${ci}$largv( nr, ab( 1_${ik}$, j1+ka ), inca, work( m-kb+j1 ),ka1, rwork( m-& kb+j1 ), ka1 ) ! apply rotations in 2nd set from the left do l = 1, ka - 1 - call stdlib_${ci}$lartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca, & + call stdlib${ii}$_${ci}$lartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca, & rwork( m-kb+j1 ),work( m-kb+j1 ), ka1 ) end do ! apply rotations in 2nd set from both sides to diagonal ! blocks - call stdlib_${ci}$lar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & + call stdlib${ii}$_${ci}$lar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & rwork( m-kb+j1 ),work( m-kb+j1 ), ka1 ) - call stdlib_${ci}$lacgv( nr, work( m-kb+j1 ), ka1 ) + call stdlib${ii}$_${ci}$lacgv( nr, work( m-kb+j1 ), ka1 ) end if ! start applying rotations in 2nd set from the right do l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& + if( nrt>0_${ik}$ )call stdlib${ii}$_${ci}$lartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& rwork( m-kb+j1t ), work( m-kb+j1t ),ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 2nd set do j = j1, j2, ka1 - call stdlib_${ci}$rot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,rwork( m-kb+j ), work( & + call stdlib${ii}$_${ci}$rot( nx, x( 1_${ik}$, j ), 1_${ik}$, x( 1_${ik}$, j-1 ), 1_${ik}$,rwork( 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 + j2 = i + k + 1_${ik}$ - max( 1_${ik}$, k+i0-m+1 )*ka1 ! finish applying rotations in 1st 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_${ci}$lartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& + if( nrt>0_${ik}$ )call stdlib${ii}$_${ci}$lartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& rwork( j1t ),work( j1t ), ka1 ) end do end do - if( kb>1 ) then + if( kb>1_${ik}$ ) then do j = 2, i2 - ka rwork( j ) = rwork( j+ka ) work( j ) = work( j+ka ) @@ -23551,8 +23543,8 @@ module stdlib_linalg_lapack_${ci}$ ! transform a, working with the lower triangle if( update ) then ! form inv(s(i))**h * a * inv(s(i)) - bii = real( bb( 1, i ),KIND=${ck}$) - ab( 1, i ) = ( real( ab( 1, i ),KIND=${ck}$) / bii ) / bii + bii = real( bb( 1_${ik}$, i ),KIND=${ck}$) + ab( 1_${ik}$, i ) = ( real( ab( 1_${ik}$, i ),KIND=${ck}$) / bii ) / bii do j = i1, i - 1 ab( i-j+1, j ) = ab( i-j+1, j ) / bii end do @@ -23562,8 +23554,8 @@ module stdlib_linalg_lapack_${ci}$ do k = i + 1, i + kbt do j = k, i + kbt ab( j-k+1, k ) = ab( j-k+1, k ) -bb( j-i+1, i )*conjg( ab( k-i+1,i ) ) - & - conjg( bb( k-i+1, i ) )*ab( j-i+1, i ) + real( ab( 1, i ),KIND=${ck}$)*bb( j-i+& - 1, i )*conjg( bb( k-i+1,i ) ) + conjg( bb( k-i+1, i ) )*ab( j-i+1, i ) + real( ab( 1_${ik}$, i ),KIND=${ck}$)*bb( j-i+& + 1_${ik}$, i )*conjg( 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 ) -conjg( bb( k-i+1, i ) )*ab( j-i+1, i ) @@ -23577,9 +23569,9 @@ module stdlib_linalg_lapack_${ci}$ end do if( wantx ) then ! post-multiply x by inv(s(i)) - call stdlib_${ci}$dscal( nx, one / bii, x( 1, i ), 1 ) - if( kbt>0 )call stdlib_${ci}$gerc( nx, kbt, -cone, x( 1, i ), 1, bb( 2, i ),1, x( & - 1, i+1 ), ldx ) + call stdlib${ii}$_${ci}$dscal( nx, one / bii, x( 1_${ik}$, i ), 1_${ik}$ ) + if( kbt>0_${ik}$ )call stdlib${ii}$_${ci}$gerc( nx, kbt, -cone, 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 ra1 = ab( i-i1+1, i1 ) @@ -23590,9 +23582,9 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$largv( nrt, ab( ka1, j1 ), inca, work( j1 ), ka1,rwork( & + if( nrt>0_${ik}$ )call stdlib${ii}$_${ci}$largv( nrt, ab( ka1, j1 ), inca, work( j1 ), ka1,rwork( & j1 ), ka1 ) - if( nr>0 ) then + if( nr>0_${ik}$ ) then ! apply rotations in 1st set from the right do l = 1, ka - 1 - call stdlib_${ci}$lartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, rwork( & + call stdlib${ii}$_${ci}$lartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, rwork( & j1 ), work( j1 ), ka1 ) end do ! apply rotations in 1st set from both sides to diagonal ! blocks - call stdlib_${ci}$lar2v( nr, ab( 1, j1 ), ab( 1, j1-1 ),ab( 2, j1-1 ), inca, rwork(& + call stdlib${ii}$_${ci}$lar2v( nr, ab( 1_${ik}$, j1 ), ab( 1_${ik}$, j1-1 ),ab( 2_${ik}$, j1-1 ), inca, rwork(& j1 ),work( j1 ), ka1 ) - call stdlib_${ci}$lacgv( nr, work( j1 ), ka1 ) + call stdlib${ii}$_${ci}$lacgv( nr, work( j1 ), ka1 ) end if ! start applying rotations in 1st set from the left do l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & + if( nrt>0_${ik}$ )call stdlib${ii}$_${ci}$lartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & j1t-ka1+l ), inca,rwork( j1t ), work( j1t ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 1st set do j = j1, j2, ka1 - call stdlib_${ci}$rot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,rwork( j ), conjg( work(& + call stdlib${ii}$_${ci}$rot( nx, x( 1_${ik}$, j ), 1_${ik}$, x( 1_${ik}$, j-1 ), 1_${ik}$,rwork( j ), conjg( 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 @@ -23659,15 +23651,15 @@ module stdlib_linalg_lapack_${ci}$ 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 do l = kb - k, 1, -1 nrt = ( j2+ka+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( ka1-l+1, j1t+l-1 ), inca,ab( ka1-l, & + if( nrt>0_${ik}$ )call stdlib${ii}$_${ci}$lartv( nrt, ab( ka1-l+1, j1t+l-1 ), inca,ab( ka1-l, & j1t+l-1 ), inca,rwork( m-kb+j1t+ka ),work( m-kb+j1t+ka ), ka1 ) end do nr = ( j2+ka-1 ) / ka1 @@ -23687,51 +23679,51 @@ module stdlib_linalg_lapack_${ci}$ 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 + if( nr>0_${ik}$ ) then ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band - call stdlib_${ci}$largv( nr, ab( ka1, j1 ), inca, work( m-kb+j1 ),ka1, rwork( m-kb+& + call stdlib${ii}$_${ci}$largv( nr, ab( ka1, j1 ), inca, work( m-kb+j1 ),ka1, rwork( m-kb+& j1 ), ka1 ) ! apply rotations in 2nd set from the right do l = 1, ka - 1 - call stdlib_${ci}$lartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, rwork( & + call stdlib${ii}$_${ci}$lartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, rwork( & m-kb+j1 ), work( m-kb+j1 ),ka1 ) end do ! apply rotations in 2nd set from both sides to diagonal ! blocks - call stdlib_${ci}$lar2v( nr, ab( 1, j1 ), ab( 1, j1-1 ),ab( 2, j1-1 ), inca, rwork(& + call stdlib${ii}$_${ci}$lar2v( nr, ab( 1_${ik}$, j1 ), ab( 1_${ik}$, j1-1 ),ab( 2_${ik}$, j1-1 ), inca, rwork(& m-kb+j1 ),work( m-kb+j1 ), ka1 ) - call stdlib_${ci}$lacgv( nr, work( m-kb+j1 ), ka1 ) + call stdlib${ii}$_${ci}$lacgv( nr, work( m-kb+j1 ), ka1 ) end if ! start applying rotations in 2nd set from the left do l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & + if( nrt>0_${ik}$ )call stdlib${ii}$_${ci}$lartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & j1t-ka1+l ), inca,rwork( m-kb+j1t ), work( m-kb+j1t ),ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 2nd set do j = j1, j2, ka1 - call stdlib_${ci}$rot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,rwork( m-kb+j ), conjg( & + call stdlib${ii}$_${ci}$rot( nx, x( 1_${ik}$, j ), 1_${ik}$, x( 1_${ik}$, j-1 ), 1_${ik}$,rwork( m-kb+j ), conjg( & 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 + j2 = i + k + 1_${ik}$ - max( 1_${ik}$, k+i0-m+1 )*ka1 ! finish applying rotations in 1st 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_${ci}$lartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & + if( nrt>0_${ik}$ )call stdlib${ii}$_${ci}$lartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & j1t-ka1+l ), inca,rwork( j1t ), work( j1t ), ka1 ) end do end do - if( kb>1 ) then + if( kb>1_${ik}$ ) then do j = 2, i2 - ka rwork( j ) = rwork( j+ka ) work( j ) = work( j+ka ) @@ -23739,10 +23731,10 @@ module stdlib_linalg_lapack_${ci}$ end if end if go to 490 - end subroutine stdlib_${ci}$hbgst + end subroutine stdlib${ii}$_${ci}$hbgst - pure subroutine stdlib_${ci}$hbgv( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z,ldz, work, & + pure subroutine stdlib${ii}$_${ci}$hbgv( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z,ldz, work, & !! ZHBGV: computes all the eigenvalues, and optionally, the eigenvectors !! of a complex generalized Hermitian-definite banded eigenproblem, of !! the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian @@ -23753,8 +23745,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ka, kb, ldab, ldbb, ldz, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ka, kb, ldab, ldbb, ldz, n ! Array Arguments real(${ck}$), intent(out) :: rwork(*), w(*) complex(${ck}$), intent(inout) :: ab(ldab,*), bb(ldbb,*) @@ -23763,45 +23755,45 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: upper, wantz character :: vect - integer(ilp) :: iinfo, inde, indwrk + integer(${ik}$) :: iinfo, inde, indwrk ! Executable Statements ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) upper = stdlib_lsame( uplo, 'U' ) - info = 0 + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ka<0 ) then - info = -4 - else if( kb<0 .or. kb>ka ) 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( ldabka ) 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( ldabka ) then - info = -6 + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( ka<0_${ik}$ ) then + info = -5_${ik}$ + else if( kb<0_${ik}$ .or. kb>ka ) then + info = -6_${ik}$ else if( ldab0 .and. vu<=vl )info = -14 + if( n>0_${ik}$ .and. vu<=vl )info = -14_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -15 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -15_${ik}$ else if ( iun ) then - info = -16 + info = -16_${ik}$ end if end if end if - if( info==0) then - if( ldz<1 .or. ( wantz .and. ldz1 ) then + if( kd>1_${ik}$ ) then ! reduce to complex hermitian tridiagonal form, working with ! the upper triangle - nr = 0 - j1 = kdn + 2 - j2 = 1 - ab( kd1, 1 ) = real( ab( kd1, 1 ),KIND=${ck}$) + nr = 0_${ik}$ + j1 = kdn + 2_${ik}$ + j2 = 1_${ik}$ + ab( kd1, 1_${ik}$ ) = real( ab( kd1, 1_${ik}$ ),KIND=${ck}$) loop_90: do i = 1, n - 2 ! reduce i-th row of matrix to tridiagonal form loop_80: do k = kdn + 1, 2, -1 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_${ci}$largv( nr, ab( 1, j1-1 ), inca, work( j1 ),kd1, d( j1 ), & + call stdlib${ii}$_${ci}$largv( 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_${ci}$lartv or stdlib_${ci}$rot is used - if( nr>=2*kd-1 ) then + ! stdlib${ii}$_${ci}$lartv or stdlib${ii}$_${ci}$rot is used + if( nr>=2_${ik}$*kd-1 ) then do l = 1, kd - 1 - call stdlib_${ci}$lartv( nr, ab( l+1, j1-1 ), inca,ab( l, j1 ), inca, & + call stdlib${ii}$_${ci}$lartv( nr, ab( l+1, j1-1 ), inca,ab( l, j1 ), inca, & d( j1 ),work( j1 ), kd1 ) end do else jend = j1 + ( nr-1 )*kd1 do jinc = j1, jend, kd1 - call stdlib_${ci}$rot( kdm1, ab( 2, jinc-1 ), 1,ab( 1, jinc ), 1, d( & + call stdlib${ii}$_${ci}$rot( 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_${ci}$lartg( ab( kd-k+3, i+k-2 ),ab( kd-k+2, i+k-1 ), d( i+k-& - 1 ),work( i+k-1 ), temp ) + call stdlib${ii}$_${ci}$lartg( 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_${ci}$rot( k-3, ab( kd-k+4, i+k-2 ), 1,ab( kd-k+3, i+k-1 ), 1,& + call stdlib${ii}$_${ci}$rot( 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_${ci}$lar2v( nr, ab( kd1, j1-1 ), ab( kd1, j1 ),ab( kd, & + if( nr>0_${ik}$ )call stdlib${ii}$_${ci}$lar2v( nr, ab( kd1, j1-1 ), ab( kd1, j1 ),ab( kd, & j1 ), inca, d( j1 ),work( j1 ), kd1 ) ! apply plane rotations from the left - if( nr>0 ) then - call stdlib_${ci}$lacgv( nr, work( j1 ), kd1 ) - if( 2*kd-10_${ik}$ ) then + call stdlib${ii}$_${ci}$lacgv( nr, work( j1 ), kd1 ) + if( 2_${ik}$*kd-1n ) then - nrt = nr - 1 + nrt = nr - 1_${ik}$ else nrt = nr end if - if( nrt>0 )call stdlib_${ci}$lartv( nrt, ab( kd-l, j1+l ), inca,ab( kd-& + if( nrt>0_${ik}$ )call stdlib${ii}$_${ci}$lartv( nrt, ab( kd-l, j1+l ), inca,ab( kd-& l+1, j1+l ), inca,d( j1 ), work( j1 ), kd1 ) end do else j1end = j1 + kd1*( nr-2 ) if( j1end>=j1 ) then do jin = j1, j1end, kd1 - call stdlib_${ci}$rot( kd-1, ab( kd-1, jin+1 ), incx,ab( kd, jin+1 )& + call stdlib${ii}$_${ci}$rot( kd-1, ab( kd-1, jin+1 ), incx,ab( kd, jin+1 )& , incx,d( jin ), work( jin ) ) end do end if lend = min( kdm1, n-j2 ) last = j1end + kd1 - if( lend>0 )call stdlib_${ci}$rot( lend, ab( kd-1, last+1 ), incx,ab( kd, & + if( lend>0_${ik}$ )call stdlib${ii}$_${ci}$rot( lend, ab( kd-1, last+1 ), incx,ab( kd, & last+1 ), incx, d( last ),work( last ) ) end if end if @@ -24288,41 +24280,41 @@ module stdlib_linalg_lapack_${ci}$ ! 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_${ci}$rot( nq, q( iqb, j-1 ), 1, q( iqb, j ),1, d( j ), & + call stdlib${ii}$_${ci}$rot( nq, q( iqb, j-1 ), 1_${ik}$, q( iqb, j ),1_${ik}$, d( j ), & conjg( work( j ) ) ) end do else do j = j1, j2, kd1 - call stdlib_${ci}$rot( n, q( 1, j-1 ), 1, q( 1, j ), 1,d( j ), conjg( & + call stdlib${ii}$_${ci}$rot( n, q( 1_${ik}$, j-1 ), 1_${ik}$, q( 1_${ik}$, j ), 1_${ik}$,d( j ), conjg( & 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 ! make off-diagonal elements real and copy them to e do i = 1, n - 1 t = ab( kd, i+1 ) @@ -24336,7 +24328,7 @@ module stdlib_linalg_lapack_${ci}$ end if if( i1 ) then + if( kd>1_${ik}$ ) then ! reduce to complex hermitian tridiagonal form, working with ! the lower triangle - nr = 0 - j1 = kdn + 2 - j2 = 1 - ab( 1, 1 ) = real( ab( 1, 1 ),KIND=${ck}$) + nr = 0_${ik}$ + j1 = kdn + 2_${ik}$ + j2 = 1_${ik}$ + ab( 1_${ik}$, 1_${ik}$ ) = real( ab( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$) loop_210: do i = 1, n - 2 ! reduce i-th column of matrix to tridiagonal form loop_200: do k = kdn + 1, 2, -1 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_${ci}$largv( nr, ab( kd1, j1-kd1 ), inca,work( j1 ), kd1, d( j1 )& + call stdlib${ii}$_${ci}$largv( nr, ab( kd1, j1-kd1 ), inca,work( j1 ), kd1, d( j1 )& , kd1 ) ! apply plane rotations from one side ! dependent on the the number of diagonals either - ! stdlib_${ci}$lartv or stdlib_${ci}$rot is used - if( nr>2*kd-1 ) then + ! stdlib${ii}$_${ci}$lartv or stdlib${ii}$_${ci}$rot is used + if( nr>2_${ik}$*kd-1 ) then do l = 1, kd - 1 - call stdlib_${ci}$lartv( nr, ab( kd1-l, j1-kd1+l ), inca,ab( kd1-l+1, & + call stdlib${ii}$_${ci}$lartv( nr, ab( kd1-l, j1-kd1+l ), inca,ab( kd1-l+1, & j1-kd1+l ), inca,d( j1 ), work( j1 ), kd1 ) end do else jend = j1 + kd1*( nr-1 ) do jinc = j1, jend, kd1 - call stdlib_${ci}$rot( kdm1, ab( kd, jinc-kd ), incx,ab( kd1, jinc-kd )& + call stdlib${ii}$_${ci}$rot( 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_${ci}$lartg( ab( k-1, i ), ab( k, i ),d( i+k-1 ), work( i+k-1 & + call stdlib${ii}$_${ci}$lartg( ab( k-1, i ), ab( k, i ),d( i+k-1 ), work( i+k-1 & ), temp ) ab( k-1, i ) = temp ! apply rotation from the left - call stdlib_${ci}$rot( k-3, ab( k-2, i+1 ), ldab-1,ab( k-1, i+1 ), ldab-1,& + call stdlib${ii}$_${ci}$rot( k-3, ab( k-2, i+1 ), ldab-1,ab( k-1, i+1 ), ldab-1,& d( i+k-1 ),work( i+k-1 ) ) end if - nr = nr + 1 - 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_${ci}$lar2v( nr, ab( 1, j1-1 ), ab( 1, j1 ),ab( 2, j1-1 ),& + if( nr>0_${ik}$ )call stdlib${ii}$_${ci}$lar2v( 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_${ci}$lartv or stdlib_${ci}$rot is used - if( nr>0 ) then - call stdlib_${ci}$lacgv( nr, work( j1 ), kd1 ) - if( nr>2*kd-1 ) then + ! stdlib${ii}$_${ci}$lartv or stdlib${ii}$_${ci}$rot is used + if( nr>0_${ik}$ ) then + call stdlib${ii}$_${ci}$lacgv( nr, work( j1 ), kd1 ) + 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_${ci}$lartv( nrt, ab( l+2, j1-1 ), inca,ab( l+1,& + if( nrt>0_${ik}$ )call stdlib${ii}$_${ci}$lartv( nrt, ab( l+2, j1-1 ), inca,ab( l+1,& j1 ), inca, d( j1 ),work( j1 ), kd1 ) end do else j1end = j1 + kd1*( nr-2 ) if( j1end>=j1 ) then do j1inc = j1, j1end, kd1 - call stdlib_${ci}$rot( kdm1, ab( 3, j1inc-1 ), 1,ab( 2, j1inc ), 1, & + call stdlib${ii}$_${ci}$rot( 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_${ci}$rot( lend, ab( 3, last-1 ), 1,ab( 2, last ),& - 1, d( last ),work( last ) ) + if( lend>0_${ik}$ )call stdlib${ii}$_${ci}$rot( 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 @@ -24436,30 +24428,30 @@ module stdlib_linalg_lapack_${ci}$ ! 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_${ci}$rot( nq, q( iqb, j-1 ), 1, q( iqb, j ),1, d( j ), & + call stdlib${ii}$_${ci}$rot( 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_${ci}$rot( n, q( 1, j-1 ), 1, q( 1, j ), 1,d( j ), work( j & + call stdlib${ii}$_${ci}$rot( 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 @@ -24470,21 +24462,21 @@ module stdlib_linalg_lapack_${ci}$ end do loop_200 end do loop_210 end if - if( kd>0 ) then + if( kd>0_${ik}$ ) then ! make off-diagonal elements real and copy them to e do i = 1, n - 1 - t = ab( 2, i ) + t = ab( 2_${ik}$, i ) abst = abs( t ) - ab( 2, i ) = abst + ab( 2_${ik}$, i ) = abst e( i ) = abst if( abst/=zero ) then t = t / abst else t = cone end if - if( izero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 )call stdlib_${ci}$lascl( uplo, 0, 0, one, sigma, n, n, a, lda, info ) - ! call stdlib_${ci}$hetrd to reduce hermitian matrix to tridiagonal form. - inde = 1 - indtau = 1 + if( iscale==1_${ik}$ )call stdlib${ii}$_${ci}$lascl( uplo, 0_${ik}$, 0_${ik}$, one, sigma, n, n, a, lda, info ) + ! call stdlib${ii}$_${ci}$hetrd to reduce hermitian matrix to tridiagonal form. + inde = 1_${ik}$ + indtau = 1_${ik}$ indwrk = indtau + n - llwork = lwork - indwrk + 1 - call stdlib_${ci}$hetrd( uplo, n, a, lda, w, rwork( inde ), work( indtau ),work( indwrk ), & + llwork = lwork - indwrk + 1_${ik}$ + call stdlib${ii}$_${ci}$hetrd( uplo, n, a, lda, w, rwork( inde ), work( indtau ),work( indwrk ), & llwork, iinfo ) - ! for eigenvalues only, call stdlib_${c2ri(ci)}$sterf. for eigenvectors, first call - ! stdlib_${ci}$ungtr to generate the unitary matrix, then call stdlib_${ci}$steqr. + ! for eigenvalues only, call stdlib${ii}$_${c2ri(ci)}$sterf. for eigenvectors, first call + ! stdlib${ii}$_${ci}$ungtr to generate the unitary matrix, then call stdlib${ii}$_${ci}$steqr. if( .not.wantz ) then - call stdlib_${c2ri(ci)}$sterf( n, w, rwork( inde ), info ) + call stdlib${ii}$_${c2ri(ci)}$sterf( n, w, rwork( inde ), info ) else - call stdlib_${ci}$ungtr( uplo, n, a, lda, work( indtau ), work( indwrk ),llwork, iinfo ) + call stdlib${ii}$_${ci}$ungtr( uplo, n, a, lda, work( indtau ), work( indwrk ),llwork, iinfo ) indwrk = inde + n - call stdlib_${ci}$steqr( jobz, n, w, rwork( inde ), a, lda,rwork( indwrk ), info ) + call stdlib${ii}$_${ci}$steqr( jobz, n, w, rwork( inde ), a, lda,rwork( indwrk ), info ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = n else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_${c2ri(ci)}$scal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_${c2ri(ci)}$scal( imax, one / sigma, w, 1_${ik}$ ) end if ! set work(1) to optimal complex workspace size. - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ci}$heev + end subroutine stdlib${ii}$_${ci}$heev - subroutine stdlib_${ci}$heevd( jobz, uplo, n, a, lda, w, work, lwork, rwork,lrwork, iwork, liwork,& + subroutine stdlib${ii}$_${ci}$heevd( jobz, uplo, n, a, lda, w, work, lwork, rwork,lrwork, iwork, liwork,& !! ZHEEVD: computes all eigenvalues and, optionally, eigenvectors of a !! complex Hermitian matrix A. If eigenvectors are desired, it uses a !! divide and conquer algorithm. @@ -24973,10 +24965,10 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, liwork, lrwork, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, liwork, lrwork, lwork, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(${ck}$), intent(out) :: rwork(*), w(*) complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: work(*) @@ -24985,7 +24977,7 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: lower, lquery, wantz - integer(ilp) :: iinfo, imax, inde, indrwk, indtau, indwk2, indwrk, iscale, liopt, & + integer(${ik}$) :: iinfo, imax, inde, indrwk, indtau, indwk2, indwrk, iscale, liopt, & liwmin, llrwk, llwork, llwrk2, lopt, lropt, lrwmin, lwmin real(${ck}$) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! Intrinsic Functions @@ -24994,123 +24986,123 @@ module stdlib_linalg_lapack_${ci}$ ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) lower = stdlib_lsame( uplo, 'L' ) - lquery = ( lwork==-1 .or. lrwork==-1 .or. liwork==-1 ) - info = 0 + lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldazero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 )call stdlib_${ci}$lascl( uplo, 0, 0, one, sigma, n, n, a, lda, info ) - ! call stdlib_${ci}$hetrd to reduce hermitian matrix to tridiagonal form. - inde = 1 - indtau = 1 + if( iscale==1_${ik}$ )call stdlib${ii}$_${ci}$lascl( uplo, 0_${ik}$, 0_${ik}$, one, sigma, n, n, a, lda, info ) + ! call stdlib${ii}$_${ci}$hetrd to reduce hermitian matrix to tridiagonal form. + inde = 1_${ik}$ + indtau = 1_${ik}$ indwrk = indtau + n indrwk = inde + n indwk2 = indwrk + n*n - llwork = lwork - indwrk + 1 - llwrk2 = lwork - indwk2 + 1 - llrwk = lrwork - indrwk + 1 - call stdlib_${ci}$hetrd( uplo, n, a, lda, w, rwork( inde ), work( indtau ),work( indwrk ), & + llwork = lwork - indwrk + 1_${ik}$ + llwrk2 = lwork - indwk2 + 1_${ik}$ + llrwk = lrwork - indrwk + 1_${ik}$ + call stdlib${ii}$_${ci}$hetrd( uplo, n, a, lda, w, rwork( inde ), work( indtau ),work( indwrk ), & llwork, iinfo ) - ! for eigenvalues only, call stdlib_${c2ri(ci)}$sterf. for eigenvectors, first call - ! stdlib_${ci}$stedc to generate the eigenvector matrix, work(indwrk), of the - ! tridiagonal matrix, then call stdlib_${ci}$unmtr to multiply it to the + ! for eigenvalues only, call stdlib${ii}$_${c2ri(ci)}$sterf. for eigenvectors, first call + ! stdlib${ii}$_${ci}$stedc to generate the eigenvector matrix, work(indwrk), of the + ! tridiagonal matrix, then call stdlib${ii}$_${ci}$unmtr to multiply it to the ! householder transformations represented as householder vectors in ! a. if( .not.wantz ) then - call stdlib_${c2ri(ci)}$sterf( n, w, rwork( inde ), info ) + call stdlib${ii}$_${c2ri(ci)}$sterf( n, w, rwork( inde ), info ) else - call stdlib_${ci}$stedc( 'I', n, w, rwork( inde ), work( indwrk ), n,work( indwk2 ), & + call stdlib${ii}$_${ci}$stedc( 'I', n, w, rwork( inde ), work( indwrk ), n,work( indwk2 ), & llwrk2, rwork( indrwk ), llrwk,iwork, liwork, info ) - call stdlib_${ci}$unmtr( 'L', uplo, 'N', n, n, a, lda, work( indtau ),work( indwrk ), n, & + call stdlib${ii}$_${ci}$unmtr( 'L', uplo, 'N', n, n, a, lda, work( indtau ),work( indwrk ), n, & work( indwk2 ), llwrk2, iinfo ) - call stdlib_${ci}$lacpy( 'A', n, n, work( indwrk ), n, a, lda ) + call stdlib${ii}$_${ci}$lacpy( 'A', n, n, work( indwrk ), n, a, lda ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = n else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_${c2ri(ci)}$scal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_${c2ri(ci)}$scal( imax, one / sigma, w, 1_${ik}$ ) end if - work( 1 ) = lopt - rwork( 1 ) = lropt - iwork( 1 ) = liopt + work( 1_${ik}$ ) = lopt + rwork( 1_${ik}$ ) = lropt + iwork( 1_${ik}$ ) = liopt return - end subroutine stdlib_${ci}$heevd + end subroutine stdlib${ii}$_${ci}$heevd - subroutine stdlib_${ci}$heevr( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, & + subroutine stdlib${ii}$_${ci}$heevr( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, & !! ZHEEVR: computes selected eigenvalues and, optionally, eigenvectors !! of a complex Hermitian matrix A. Eigenvalues and eigenvectors can !! be selected by specifying either a range of values or a range of @@ -25167,11 +25159,11 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range, uplo - integer(ilp), intent(in) :: il, iu, lda, ldz, liwork, lrwork, lwork, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, iu, lda, ldz, liwork, lrwork, lwork, n + integer(${ik}$), intent(out) :: info, m real(${ck}$), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: isuppz(*), iwork(*) + integer(${ik}$), intent(out) :: isuppz(*), iwork(*) real(${ck}$), intent(out) :: rwork(*), w(*) complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: work(*), z(ldz,*) @@ -25180,7 +25172,7 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: alleig, indeig, lower, lquery, test, valeig, wantz, tryrac character :: order - integer(ilp) :: i, ieeeok, iinfo, imax, indibl, indifl, indisp, indiwo, indrd, indrdd, & + integer(${ik}$) :: i, ieeeok, iinfo, imax, indibl, indifl, indisp, indiwo, indrd, indrdd, & indre, indree, indrwk, indtau, indwk, indwkn, iscale, itmp1, j, jj, liwmin, llwork, & llrwork, llwrkn, lrwmin, lwkopt, lwmin, nb, nsplit real(${ck}$) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, & @@ -25189,241 +25181,241 @@ module stdlib_linalg_lapack_${ci}$ intrinsic :: real,max,min,sqrt ! Executable Statements ! test the input parameters. - ieeeok = stdlib_ilaenv( 10, 'ZHEEVR', 'N', 1, 2, 3, 4 ) + ieeeok = stdlib${ii}$_ilaenv( 10_${ik}$, 'ZHEEVR', 'N', 1_${ik}$, 2_${ik}$, 3_${ik}$, 4_${ik}$ ) lower = stdlib_lsame( uplo, 'L' ) wantz = stdlib_lsame( jobz, 'V' ) alleig = stdlib_lsame( range, 'A' ) valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) - lquery = ( ( lwork==-1 ) .or. ( lrwork==-1 ) .or.( liwork==-1 ) ) - lrwmin = max( 1, 24*n ) - liwmin = max( 1, 10*n ) - lwmin = max( 1, 2*n ) - info = 0 + lquery = ( ( lwork==-1_${ik}$ ) .or. ( lrwork==-1_${ik}$ ) .or.( liwork==-1_${ik}$ ) ) + lrwmin = max( 1_${ik}$, 24_${ik}$*n ) + liwmin = max( 1_${ik}$, 10_${ik}$*n ) + lwmin = max( 1_${ik}$, 2_${ik}$*n ) + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( lda0 .and. vu<=vl )info = -8 + if( n>0_${ik}$ .and. vu<=vl )info = -8_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -9 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -9_${ik}$ else if( iun ) then - info = -10 + info = -10_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz=real( a( 1, 1 ),KIND=${ck}$) )then - m = 1 - w( 1 ) = real( a( 1, 1 ),KIND=${ck}$) + if( vl=real( a( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$) )then + m = 1_${ik}$ + w( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$) end if end if if( wantz ) then - z( 1, 1 ) = one - isuppz( 1 ) = 1 - isuppz( 2 ) = 1 + z( 1_${ik}$, 1_${ik}$ ) = one + isuppz( 1_${ik}$ ) = 1_${ik}$ + isuppz( 2_${ik}$ ) = 1_${ik}$ end if return end if ! get machine constants. - safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) - eps = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) ) ! scale matrix to allowable range, if necessary. - iscale = 0 + iscale = 0_${ik}$ abstll = abstol if (valeig) then vll = vl vuu = vu end if - anrm = stdlib_${ci}$lansy( 'M', uplo, n, a, lda, rwork ) + anrm = stdlib${ii}$_${ci}$lansy( 'M', uplo, n, a, lda, rwork ) if( anrm>zero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then do j = 1, n - call stdlib_${ci}$dscal( n-j+1, sigma, a( j, j ), 1 ) + call stdlib${ii}$_${ci}$dscal( n-j+1, sigma, a( j, j ), 1_${ik}$ ) end do else do j = 1, n - call stdlib_${ci}$dscal( j, sigma, a( 1, j ), 1 ) + call stdlib${ii}$_${ci}$dscal( j, sigma, a( 1_${ik}$, j ), 1_${ik}$ ) end do end if - if( abstol>0 )abstll = abstol*sigma + if( abstol>0_${ik}$ )abstll = abstol*sigma if( valeig ) then vll = vl*sigma vuu = vu*sigma end if end if ! initialize indices into workspaces. note: the iwork indices are - ! used only if stdlib_${c2ri(ci)}$sterf or stdlib_${ci}$stemr fail. + ! used only if stdlib${ii}$_${c2ri(ci)}$sterf or stdlib${ii}$_${ci}$stemr fail. ! work(indtau:indtau+n-1) stores the complex scalar factors of the - ! elementary reflectors used in stdlib_${ci}$hetrd. - indtau = 1 + ! elementary reflectors used in stdlib${ii}$_${ci}$hetrd. + indtau = 1_${ik}$ ! indwk is the starting offset of the remaining complex workspace, ! and llwork is the remaining complex workspace size. indwk = indtau + n - llwork = lwork - indwk + 1 + llwork = lwork - indwk + 1_${ik}$ ! rwork(indrd:indrd+n-1) stores the real tridiagonal's diagonal ! entries. - indrd = 1 + indrd = 1_${ik}$ ! rwork(indre:indre+n-1) stores the off-diagonal entries of the - ! tridiagonal matrix from stdlib_${ci}$hetrd. + ! tridiagonal matrix from stdlib${ii}$_${ci}$hetrd. indre = indrd + n ! rwork(indrdd:indrdd+n-1) is a copy of the diagonal entries over - ! -written by stdlib_${ci}$stemr (the stdlib_${c2ri(ci)}$sterf path copies the diagonal to w). + ! -written by stdlib${ii}$_${ci}$stemr (the stdlib${ii}$_${c2ri(ci)}$sterf path copies the diagonal to w). indrdd = indre + n ! rwork(indree:indree+n-1) is a copy of the off-diagonal entries over - ! -written while computing the eigenvalues in stdlib_${c2ri(ci)}$sterf and stdlib_${ci}$stemr. + ! -written while computing the eigenvalues in stdlib${ii}$_${c2ri(ci)}$sterf and stdlib${ii}$_${ci}$stemr. indree = indrdd + n ! indrwk is the starting offset of the left-over real workspace, and ! llrwork is the remaining workspace size. indrwk = indree + n - llrwork = lrwork - indrwk + 1 - ! iwork(indibl:indibl+m-1) corresponds to iblock in stdlib_${c2ri(ci)}$stebz and + llrwork = lrwork - indrwk + 1_${ik}$ + ! iwork(indibl:indibl+m-1) corresponds to iblock in stdlib${ii}$_${c2ri(ci)}$stebz and ! stores the block indices of each of the m<=n eigenvalues. - indibl = 1 - ! iwork(indisp:indisp+nsplit-1) corresponds to isplit in stdlib_${c2ri(ci)}$stebz and + indibl = 1_${ik}$ + ! iwork(indisp:indisp+nsplit-1) corresponds to isplit in stdlib${ii}$_${c2ri(ci)}$stebz and ! stores the starting and finishing indices of each block. indisp = indibl + n ! iwork(indifl:indifl+n-1) stores the indices of eigenvectors ! that corresponding to eigenvectors that fail to converge in - ! stdlib_${c2ri(ci)}$stein. this information is discarded; if any fail, the driver + ! stdlib${ii}$_${c2ri(ci)}$stein. this information is discarded; if any fail, the driver ! returns info > 0. indifl = indisp + n ! indiwo is the offset of the remaining integer workspace. indiwo = indifl + n - ! call stdlib_${ci}$hetrd to reduce hermitian matrix to tridiagonal form. - call stdlib_${ci}$hetrd( uplo, n, a, lda, rwork( indrd ), rwork( indre ),work( indtau ), & + ! call stdlib${ii}$_${ci}$hetrd to reduce hermitian matrix to tridiagonal form. + call stdlib${ii}$_${ci}$hetrd( uplo, n, a, lda, rwork( indrd ), rwork( indre ),work( indtau ), & work( indwk ), llwork, iinfo ) ! if all eigenvalues are desired - ! then call stdlib_${c2ri(ci)}$sterf or stdlib_${ci}$stemr and stdlib_${ci}$unmtr. + ! then call stdlib${ii}$_${c2ri(ci)}$sterf or stdlib${ii}$_${ci}$stemr and stdlib${ii}$_${ci}$unmtr. test = .false. if( indeig ) then - if( il==1 .and. iu==n ) then + if( il==1_${ik}$ .and. iu==n ) then test = .true. end if end if - if( ( alleig.or.test ) .and. ( ieeeok==1 ) ) then + if( ( alleig.or.test ) .and. ( ieeeok==1_${ik}$ ) ) then if( .not.wantz ) then - call stdlib_${c2ri(ci)}$copy( n, rwork( indrd ), 1, w, 1 ) - call stdlib_${c2ri(ci)}$copy( n-1, rwork( indre ), 1, rwork( indree ), 1 ) - call stdlib_${c2ri(ci)}$sterf( n, w, rwork( indree ), info ) + call stdlib${ii}$_${c2ri(ci)}$copy( n, rwork( indrd ), 1_${ik}$, w, 1_${ik}$ ) + call stdlib${ii}$_${c2ri(ci)}$copy( n-1, rwork( indre ), 1_${ik}$, rwork( indree ), 1_${ik}$ ) + call stdlib${ii}$_${c2ri(ci)}$sterf( n, w, rwork( indree ), info ) else - call stdlib_${c2ri(ci)}$copy( n-1, rwork( indre ), 1, rwork( indree ), 1 ) - call stdlib_${c2ri(ci)}$copy( n, rwork( indrd ), 1, rwork( indrdd ), 1 ) + call stdlib${ii}$_${c2ri(ci)}$copy( n-1, rwork( indre ), 1_${ik}$, rwork( indree ), 1_${ik}$ ) + call stdlib${ii}$_${c2ri(ci)}$copy( n, rwork( indrd ), 1_${ik}$, rwork( indrdd ), 1_${ik}$ ) if (abstol <= two*n*eps) then tryrac = .true. else tryrac = .false. end if - call stdlib_${ci}$stemr( jobz, 'A', n, rwork( indrdd ),rwork( indree ), vl, vu, il, & + call stdlib${ii}$_${ci}$stemr( jobz, 'A', n, rwork( indrdd ),rwork( indree ), vl, vu, il, & iu, m, w,z, ldz, n, isuppz, tryrac,rwork( indrwk ), llrwork,iwork, liwork, info ) ! apply unitary matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_${ci}$stemr. - if( wantz .and. info==0 ) then + ! form to eigenvectors returned by stdlib${ii}$_${ci}$stemr. + if( wantz .and. info==0_${ik}$ ) then indwkn = indwk - llwrkn = lwork - indwkn + 1 - call stdlib_${ci}$unmtr( 'L', uplo, 'N', n, m, a, lda,work( indtau ), z, ldz, work(& + llwrkn = lwork - indwkn + 1_${ik}$ + call stdlib${ii}$_${ci}$unmtr( 'L', uplo, 'N', n, m, a, lda,work( indtau ), z, ldz, work(& indwkn ),llwrkn, iinfo ) end if end if - if( info==0 ) then + if( info==0_${ik}$ ) then m = n go to 30 end if - info = 0 + info = 0_${ik}$ end if - ! otherwise, call stdlib_${c2ri(ci)}$stebz and, if eigenvectors are desired, stdlib_${ci}$stein. - ! also call stdlib_${c2ri(ci)}$stebz and stdlib_${ci}$stein if stdlib_${ci}$stemr fails. + ! otherwise, call stdlib${ii}$_${c2ri(ci)}$stebz and, if eigenvectors are desired, stdlib${ii}$_${ci}$stein. + ! also call stdlib${ii}$_${c2ri(ci)}$stebz and stdlib${ii}$_${ci}$stein if stdlib${ii}$_${ci}$stemr fails. if( wantz ) then order = 'B' else order = 'E' end if - call stdlib_${c2ri(ci)}$stebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indrd ), rwork( & + call stdlib${ii}$_${c2ri(ci)}$stebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indrd ), rwork( & indre ), m, nsplit, w,iwork( indibl ), iwork( indisp ), rwork( indrwk ),iwork( indiwo )& , info ) if( wantz ) then - call stdlib_${ci}$stein( n, rwork( indrd ), rwork( indre ), m, w,iwork( indibl ), iwork( & + call stdlib${ii}$_${ci}$stein( n, rwork( indrd ), rwork( indre ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,rwork( indrwk ), iwork( indiwo ), iwork( indifl ),info ) ! apply unitary matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_${ci}$stein. + ! form to eigenvectors returned by stdlib${ii}$_${ci}$stein. indwkn = indwk - llwrkn = lwork - indwkn + 1 - call stdlib_${ci}$unmtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & + llwrkn = lwork - indwkn + 1_${ik}$ + call stdlib${ii}$_${ci}$unmtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & indwkn ), llwrkn, iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. 30 continue - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = m else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_${c2ri(ci)}$scal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_${c2ri(ci)}$scal( imax, one / sigma, w, 1_${ik}$ ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. if( wantz ) then do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp1 = w( j ) do jj = j + 1, m if( w( jj )0 .and. vu<=vl )info = -8 + if( n>0_${ik}$ .and. vu<=vl )info = -8_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -9 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -9_${ik}$ else if( iun ) then - info = -10 + info = -10_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz=real( a( 1, 1 ),KIND=${ck}$) )then - m = 1 - w( 1 ) = real( a( 1, 1 ),KIND=${ck}$) + if( vl=real( a( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$) )then + m = 1_${ik}$ + w( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=${ck}$) end if end if - if( wantz )z( 1, 1 ) = cone + if( wantz )z( 1_${ik}$, 1_${ik}$ ) = cone return end if ! get machine constants. - safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) - eps = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) ) ! scale matrix to allowable range, if necessary. - iscale = 0 + iscale = 0_${ik}$ abstll = abstol if( valeig ) then vll = vl vuu = vu end if - anrm = stdlib_${ci}$lanhe( 'M', uplo, n, a, lda, rwork ) + anrm = stdlib${ii}$_${ci}$lanhe( 'M', uplo, n, a, lda, rwork ) if( anrm>zero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then do j = 1, n - call stdlib_${ci}$dscal( n-j+1, sigma, a( j, j ), 1 ) + call stdlib${ii}$_${ci}$dscal( n-j+1, sigma, a( j, j ), 1_${ik}$ ) end do else do j = 1, n - call stdlib_${ci}$dscal( j, sigma, a( 1, j ), 1 ) + call stdlib${ii}$_${ci}$dscal( j, sigma, a( 1_${ik}$, j ), 1_${ik}$ ) end do end if - if( abstol>0 )abstll = abstol*sigma + if( abstol>0_${ik}$ )abstll = abstol*sigma if( valeig ) then vll = vl*sigma vuu = vu*sigma end if end if - ! call stdlib_${ci}$hetrd to reduce hermitian matrix to tridiagonal form. - indd = 1 + ! call stdlib${ii}$_${ci}$hetrd to reduce hermitian matrix to tridiagonal form. + indd = 1_${ik}$ inde = indd + n indrwk = inde + n - indtau = 1 + indtau = 1_${ik}$ indwrk = indtau + n - llwork = lwork - indwrk + 1 - call stdlib_${ci}$hetrd( uplo, n, a, lda, rwork( indd ), rwork( inde ),work( indtau ), work(& + llwork = lwork - indwrk + 1_${ik}$ + call stdlib${ii}$_${ci}$hetrd( uplo, n, a, lda, rwork( indd ), rwork( inde ),work( indtau ), work(& indwrk ), llwork, iinfo ) ! if all eigenvalues are desired and abstol is less than or equal to - ! zero, then call stdlib_${c2ri(ci)}$sterf or stdlib_${ci}$ungtr and stdlib_${ci}$steqr. if this fails for - ! some eigenvalue, then try stdlib_${c2ri(ci)}$stebz. + ! zero, then call stdlib${ii}$_${c2ri(ci)}$sterf or stdlib${ii}$_${ci}$ungtr and stdlib${ii}$_${ci}$steqr. if this fails for + ! some eigenvalue, then try stdlib${ii}$_${c2ri(ci)}$stebz. test = .false. if( indeig ) then - if( il==1 .and. iu==n ) then + if( il==1_${ik}$ .and. iu==n ) then test = .true. end if end if if( ( alleig .or. test ) .and. ( abstol<=zero ) ) then - call stdlib_${c2ri(ci)}$copy( n, rwork( indd ), 1, w, 1 ) - indee = indrwk + 2*n + call stdlib${ii}$_${c2ri(ci)}$copy( n, rwork( indd ), 1_${ik}$, w, 1_${ik}$ ) + indee = indrwk + 2_${ik}$*n if( .not.wantz ) then - call stdlib_${c2ri(ci)}$copy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) - call stdlib_${c2ri(ci)}$sterf( n, w, rwork( indee ), info ) + call stdlib${ii}$_${c2ri(ci)}$copy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ ) + call stdlib${ii}$_${c2ri(ci)}$sterf( n, w, rwork( indee ), info ) else - call stdlib_${ci}$lacpy( 'A', n, n, a, lda, z, ldz ) - call stdlib_${ci}$ungtr( uplo, n, z, ldz, work( indtau ),work( indwrk ), llwork, & + call stdlib${ii}$_${ci}$lacpy( 'A', n, n, a, lda, z, ldz ) + call stdlib${ii}$_${ci}$ungtr( uplo, n, z, ldz, work( indtau ),work( indwrk ), llwork, & iinfo ) - call stdlib_${c2ri(ci)}$copy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) - call stdlib_${ci}$steqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) + call stdlib${ii}$_${c2ri(ci)}$copy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$steqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) - if( info==0 ) then + if( info==0_${ik}$ ) then do i = 1, n - ifail( i ) = 0 + ifail( i ) = 0_${ik}$ end do end if end if - if( info==0 ) then + if( info==0_${ik}$ ) then m = n go to 40 end if - info = 0 + info = 0_${ik}$ end if - ! otherwise, call stdlib_${c2ri(ci)}$stebz and, if eigenvectors are desired, stdlib_${ci}$stein. + ! otherwise, call stdlib${ii}$_${c2ri(ci)}$stebz and, if eigenvectors are desired, stdlib${ii}$_${ci}$stein. if( wantz ) then order = 'B' else order = 'E' end if - indibl = 1 + indibl = 1_${ik}$ indisp = indibl + n indiwk = indisp + n - call stdlib_${c2ri(ci)}$stebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indd ), rwork( & + call stdlib${ii}$_${c2ri(ci)}$stebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indd ), rwork( & inde ), m, nsplit, w,iwork( indibl ), iwork( indisp ), rwork( indrwk ),iwork( indiwk ),& info ) if( wantz ) then - call stdlib_${ci}$stein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & + call stdlib${ii}$_${ci}$stein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,rwork( indrwk ), iwork( indiwk ), ifail, info ) ! apply unitary matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_${ci}$stein. - call stdlib_${ci}$unmtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & + ! form to eigenvectors returned by stdlib${ii}$_${ci}$stein. + call stdlib${ii}$_${ci}$unmtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & indwrk ), llwork, iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. 40 continue - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = m else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_${c2ri(ci)}$scal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_${c2ri(ci)}$scal( imax, one / sigma, w, 1_${ik}$ ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. if( wantz ) then do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp1 = w( j ) do jj = j + 1, m if( w( jj )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}$, 'ZHEGST', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code - call stdlib_${ci}$hegs2( itype, uplo, n, a, lda, b, ldb, info ) + call stdlib${ii}$_${ci}$hegs2( 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**h)*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_${ci}$hegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib${ii}$_${ci}$hegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) if( k+kb<=n ) then - call stdlib_${ci}$trsm( 'LEFT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', kb, & + call stdlib${ii}$_${ci}$trsm( 'LEFT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', kb, & n-k-kb+1, cone,b( k, k ), ldb, a( k, k+kb ), lda ) - call stdlib_${ci}$hemm( 'LEFT', uplo, kb, n-k-kb+1, -chalf,a( k, k ), lda, b(& + call stdlib${ii}$_${ci}$hemm( 'LEFT', uplo, kb, n-k-kb+1, -chalf,a( k, k ), lda, b(& k, k+kb ), ldb,cone, a( k, k+kb ), lda ) - call stdlib_${ci}$her2k( uplo, 'CONJUGATE TRANSPOSE', n-k-kb+1,kb, -cone, a( & + call stdlib${ii}$_${ci}$her2k( uplo, 'CONJUGATE TRANSPOSE', n-k-kb+1,kb, -cone, a( & k, k+kb ), lda,b( k, k+kb ), ldb, one,a( k+kb, k+kb ), lda ) - call stdlib_${ci}$hemm( 'LEFT', uplo, kb, n-k-kb+1, -chalf,a( k, k ), lda, b(& + call stdlib${ii}$_${ci}$hemm( 'LEFT', uplo, kb, n-k-kb+1, -chalf,a( k, k ), lda, b(& k, k+kb ), ldb,cone, a( k, k+kb ), lda ) - call stdlib_${ci}$trsm( 'RIGHT', uplo, 'NO TRANSPOSE','NON-UNIT', kb, n-k-kb+& - 1, cone,b( k+kb, k+kb ), ldb, a( k, k+kb ),lda ) + call stdlib${ii}$_${ci}$trsm( 'RIGHT', uplo, 'NO TRANSPOSE','NON-UNIT', kb, n-k-kb+& + 1_${ik}$, cone,b( k+kb, k+kb ), ldb, a( k, k+kb ),lda ) end if end do else @@ -25908,18 +25900,18 @@ module stdlib_linalg_lapack_${ci}$ do k = 1, n, nb kb = min( n-k+1, nb ) ! update the lower triangle of a(k:n,k:n) - call stdlib_${ci}$hegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib${ii}$_${ci}$hegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) if( k+kb<=n ) then - call stdlib_${ci}$trsm( 'RIGHT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', n-k-& + call stdlib${ii}$_${ci}$trsm( 'RIGHT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', n-k-& kb+1, kb, cone,b( k, k ), ldb, a( k+kb, k ), lda ) - call stdlib_${ci}$hemm( 'RIGHT', uplo, n-k-kb+1, kb, -chalf,a( k, k ), lda, & + call stdlib${ii}$_${ci}$hemm( 'RIGHT', uplo, n-k-kb+1, kb, -chalf,a( k, k ), lda, & b( k+kb, k ), ldb,cone, a( k+kb, k ), lda ) - call stdlib_${ci}$her2k( uplo, 'NO TRANSPOSE', n-k-kb+1, kb,-cone, a( k+kb, & + call stdlib${ii}$_${ci}$her2k( uplo, 'NO TRANSPOSE', n-k-kb+1, kb,-cone, a( k+kb, & k ), lda,b( k+kb, k ), ldb, one,a( k+kb, k+kb ), lda ) - call stdlib_${ci}$hemm( 'RIGHT', uplo, n-k-kb+1, kb, -chalf,a( k, k ), lda, & + call stdlib${ii}$_${ci}$hemm( 'RIGHT', uplo, n-k-kb+1, kb, -chalf,a( k, k ), lda, & b( k+kb, k ), ldb,cone, a( k+kb, k ), lda ) - call stdlib_${ci}$trsm( 'LEFT', uplo, 'NO TRANSPOSE','NON-UNIT', n-k-kb+1, & + call stdlib${ii}$_${ci}$trsm( 'LEFT', uplo, 'NO TRANSPOSE','NON-UNIT', n-k-kb+1, & kb, cone,b( k+kb, k+kb ), ldb, a( k+kb, k ),lda ) end if end do @@ -25930,17 +25922,17 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$trmm( 'LEFT', uplo, 'NO TRANSPOSE', 'NON-UNIT',k-1, kb, cone, & - b, ldb, a( 1, k ), lda ) - call stdlib_${ci}$hemm( 'RIGHT', uplo, k-1, kb, chalf, a( k, k ),lda, b( 1, k ),& - ldb, cone, a( 1, k ),lda ) - call stdlib_${ci}$her2k( uplo, 'NO TRANSPOSE', k-1, kb, cone,a( 1, k ), lda, b( & - 1, k ), ldb, one, a,lda ) - call stdlib_${ci}$hemm( 'RIGHT', uplo, k-1, kb, chalf, a( k, k ),lda, b( 1, k ),& - ldb, cone, a( 1, k ),lda ) - call stdlib_${ci}$trmm( 'RIGHT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', k-1, & - kb, cone, b( k, k ), ldb,a( 1, k ), lda ) - call stdlib_${ci}$hegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib${ii}$_${ci}$trmm( 'LEFT', uplo, 'NO TRANSPOSE', 'NON-UNIT',k-1, kb, cone, & + b, ldb, a( 1_${ik}$, k ), lda ) + call stdlib${ii}$_${ci}$hemm( 'RIGHT', uplo, k-1, kb, chalf, a( k, k ),lda, b( 1_${ik}$, k ),& + ldb, cone, a( 1_${ik}$, k ),lda ) + call stdlib${ii}$_${ci}$her2k( uplo, 'NO TRANSPOSE', k-1, kb, cone,a( 1_${ik}$, k ), lda, b( & + 1_${ik}$, k ), ldb, one, a,lda ) + call stdlib${ii}$_${ci}$hemm( 'RIGHT', uplo, k-1, kb, chalf, a( k, k ),lda, b( 1_${ik}$, k ),& + ldb, cone, a( 1_${ik}$, k ),lda ) + call stdlib${ii}$_${ci}$trmm( 'RIGHT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', k-1, & + kb, cone, b( k, k ), ldb,a( 1_${ik}$, k ), lda ) + call stdlib${ii}$_${ci}$hegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) end do else @@ -25948,27 +25940,27 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$trmm( 'RIGHT', uplo, 'NO TRANSPOSE', 'NON-UNIT',kb, k-1, cone,& - b, ldb, a( k, 1 ), lda ) - call stdlib_${ci}$hemm( 'LEFT', uplo, kb, k-1, chalf, a( k, k ),lda, b( k, 1 ), & - ldb, cone, a( k, 1 ),lda ) - call stdlib_${ci}$her2k( uplo, 'CONJUGATE TRANSPOSE', k-1, kb,cone, a( k, 1 ), & - lda, b( k, 1 ), ldb,one, a, lda ) - call stdlib_${ci}$hemm( 'LEFT', uplo, kb, k-1, chalf, a( k, k ),lda, b( k, 1 ), & - ldb, cone, a( k, 1 ),lda ) - call stdlib_${ci}$trmm( 'LEFT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', kb, k-1,& - cone, b( k, k ), ldb,a( k, 1 ), lda ) - call stdlib_${ci}$hegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib${ii}$_${ci}$trmm( 'RIGHT', uplo, 'NO TRANSPOSE', 'NON-UNIT',kb, k-1, cone,& + b, ldb, a( k, 1_${ik}$ ), lda ) + call stdlib${ii}$_${ci}$hemm( 'LEFT', uplo, kb, k-1, chalf, a( k, k ),lda, b( k, 1_${ik}$ ), & + ldb, cone, a( k, 1_${ik}$ ),lda ) + call stdlib${ii}$_${ci}$her2k( uplo, 'CONJUGATE TRANSPOSE', k-1, kb,cone, a( k, 1_${ik}$ ), & + lda, b( k, 1_${ik}$ ), ldb,one, a, lda ) + call stdlib${ii}$_${ci}$hemm( 'LEFT', uplo, kb, k-1, chalf, a( k, k ),lda, b( k, 1_${ik}$ ), & + ldb, cone, a( k, 1_${ik}$ ),lda ) + call stdlib${ii}$_${ci}$trmm( 'LEFT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', kb, k-1,& + cone, b( k, k ), ldb,a( k, 1_${ik}$ ), lda ) + call stdlib${ii}$_${ci}$hegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) end do end if end if end if return - end subroutine stdlib_${ci}$hegst + end subroutine stdlib${ii}$_${ci}$hegst - subroutine stdlib_${ci}$hegv( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, rwork, info ) + subroutine stdlib${ii}$_${ci}$hegv( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, rwork, info ) !! ZHEGV: computes all the eigenvalues, and optionally, the eigenvectors !! of a complex generalized Hermitian-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. @@ -25980,8 +25972,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: itype, lda, ldb, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: itype, lda, ldb, lwork, n ! Array Arguments real(${ck}$), intent(out) :: rwork(*), w(*) complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) @@ -25991,38 +25983,38 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: lquery, upper, wantz character :: trans - integer(ilp) :: lwkopt, nb, neig + integer(${ik}$) :: lwkopt, nb, neig ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) upper = stdlib_lsame( uplo, 'U' ) - lquery = ( lwork==-1 ) - info = 0 - if( itype<1 .or. itype>3 ) then - info = -1 + lquery = ( lwork==-1_${ik}$ ) + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( lda0 )neig = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )neig = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y if( upper ) then @@ -26050,9 +26042,9 @@ module stdlib_linalg_lapack_${ci}$ else trans = 'C' end if - call stdlib_${ci}$trsm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, cone,b, ldb, a, lda & + call stdlib${ii}$_${ci}$trsm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, cone,b, ldb, a, lda & ) - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**h *y if( upper ) then @@ -26060,16 +26052,16 @@ module stdlib_linalg_lapack_${ci}$ else trans = 'N' end if - call stdlib_${ci}$trmm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, cone,b, ldb, a, lda & + call stdlib${ii}$_${ci}$trmm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, cone,b, ldb, a, lda & ) end if end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ci}$hegv + end subroutine stdlib${ii}$_${ci}$hegv - subroutine stdlib_${ci}$hegvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, rwork, lrwork,& + subroutine stdlib${ii}$_${ci}$hegvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, rwork, lrwork,& !! ZHEGVD: computes all the eigenvalues, and optionally, the eigenvectors !! of a complex generalized Hermitian-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and @@ -26087,10 +26079,10 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: itype, lda, ldb, liwork, lrwork, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: itype, lda, ldb, liwork, lrwork, lwork, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(${ck}$), intent(out) :: rwork(*), w(*) complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) complex(${ck}$), intent(out) :: work(*) @@ -26099,58 +26091,58 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: lquery, upper, wantz character :: trans - integer(ilp) :: liopt, liwmin, lopt, lropt, lrwmin, lwmin + integer(${ik}$) :: liopt, liwmin, lopt, lropt, lrwmin, lwmin ! Intrinsic Functions intrinsic :: real,max ! Executable Statements ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) upper = stdlib_lsame( uplo, 'U' ) - lquery = ( lwork==-1 .or. lrwork==-1 .or. liwork==-1 ) - info = 0 - if( n<=1 ) then - lwmin = 1 - lrwmin = 1 - liwmin = 1 + lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) + info = 0_${ik}$ + if( n<=1_${ik}$ ) then + lwmin = 1_${ik}$ + lrwmin = 1_${ik}$ + liwmin = 1_${ik}$ else if( wantz ) then - lwmin = 2*n + n*n - lrwmin = 1 + 5*n + 2*n*n - liwmin = 3 + 5*n + lwmin = 2_${ik}$*n + n*n + lrwmin = 1_${ik}$ + 5_${ik}$*n + 2_${ik}$*n*n + liwmin = 3_${ik}$ + 5_${ik}$*n else - lwmin = n + 1 + lwmin = n + 1_${ik}$ lrwmin = n - liwmin = 1 + liwmin = 1_${ik}$ end if lopt = lwmin lropt = lrwmin liopt = liwmin - if( itype<1 .or. itype>3 ) then - info = -1 + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( lda3 ) then - info = -1 + lquery = ( lwork==-1_${ik}$ ) + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -3 + info = -3_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( lda0 .and. vu<=vl )info = -11 + if( n>0_${ik}$ .and. vu<=vl )info = -11_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -12 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -12_${ik}$ else if( iun ) then - info = -13 + info = -13_${ik}$ end if end if end if - if (info==0) then - if (ldz<1 .or. (wantz .and. ldz0 )m = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )m = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y if( upper ) then @@ -26309,9 +26301,9 @@ module stdlib_linalg_lapack_${ci}$ else trans = 'C' end if - call stdlib_${ci}$trsm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, cone, b,ldb, z, ldz ) + call stdlib${ii}$_${ci}$trsm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, cone, b,ldb, z, ldz ) - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**h *y if( upper ) then @@ -26319,17 +26311,17 @@ module stdlib_linalg_lapack_${ci}$ else trans = 'N' end if - call stdlib_${ci}$trmm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, cone, b,ldb, z, ldz ) + call stdlib${ii}$_${ci}$trmm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, cone, b,ldb, z, ldz ) end if end if ! set work(1) to optimal complex workspace size. - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ci}$hegvx + end subroutine stdlib${ii}$_${ci}$hegvx - pure subroutine stdlib_${ci}$herfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr, & + pure subroutine stdlib${ii}$_${ci}$herfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr, & !! ZHERFS: improves the computed solution to a system of linear !! equations when the coefficient matrix is Hermitian indefinite, and !! provides error bounds and backward error estimates for the solution. @@ -26339,17 +26331,17 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, ldaf, ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*) complex(${ck}$), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*) complex(${ck}$), intent(out) :: work(*) complex(${ck}$), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: itmax = 5 + integer(${ik}$), parameter :: itmax = 5_${ik}$ @@ -26357,11 +26349,11 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: upper - integer(ilp) :: count, i, j, k, kase, nz + integer(${ik}$) :: count, i, j, k, kase, nz real(${ck}$) :: eps, lstres, s, safe1, safe2, safmin, xk complex(${ck}$) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,aimag,max ! Statement Functions @@ -26370,29 +26362,29 @@ module stdlib_linalg_lapack_${ci}$ cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! 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( nrhs<0 ) then - info = -3 - else if( ldaeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_${ci}$hetrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) - call stdlib_${ci}$axpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_${ci}$hetrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info ) + call stdlib${ii}$_${ci}$axpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -26492,22 +26484,22 @@ module stdlib_linalg_lapack_${ci}$ rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**h). - call stdlib_${ci}$hetrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) + call stdlib${ii}$_${ci}$hetrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do - else if( kase==2 ) then + else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_${ci}$hetrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) + call stdlib${ii}$_${ci}$hetrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info ) end if go to 100 end if @@ -26519,10 +26511,10 @@ module stdlib_linalg_lapack_${ci}$ if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_${ci}$herfs + end subroutine stdlib${ii}$_${ci}$herfs - pure subroutine stdlib_${ci}$hesv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) + pure subroutine stdlib${ii}$_${ci}$hesv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) !! ZHESV: computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS @@ -26539,68 +26531,68 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, lwork, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, lwork, n, nrhs ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: lwkopt, nb + integer(${ik}$) :: lwkopt, nb ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) if( .not.stdlib_lsame( uplo, 'U' ) .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 + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_${ci}$lanhe( 'I', uplo, n, a, lda, rwork ) + anorm = stdlib${ii}$_${ci}$lanhe( 'I', uplo, n, a, lda, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_${ci}$hecon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, info ) + call stdlib${ii}$_${ci}$hecon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, info ) ! compute the solution vectors x. - call stdlib_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_${ci}$hetrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info ) + call stdlib${ii}$_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_${ci}$hetrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_${ci}$herfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & + call stdlib${ii}$_${ci}$herfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & work, rwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond1 ) then - imax = stdlib_i${ci}$amax( k-1, a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_i${ci}$amax( k-1, a( 1_${ik}$, k ), 1_${ik}$ ) colmax = cabs1( a( imax, k ) ) else colmax = zero end if - if( (max( absakk, colmax )==zero) .or. stdlib_${c2ri(ci)}$isnan(absakk) ) then + if( (max( absakk, colmax )==zero) .or. stdlib${ii}$_${c2ri(ci)}$isnan(absakk) ) then ! column k is zero or underflow, or contains a nan: ! set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k a( k, k ) = real( a( k, k ),KIND=${ck}$) else @@ -27189,10 +27181,10 @@ module stdlib_linalg_lapack_${ci}$ ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value. ! determine only rowmax. - jmax = imax + stdlib_i${ci}$amax( k-imax, a( imax, imax+1 ), lda ) + jmax = imax + stdlib${ii}$_i${ci}$amax( k-imax, a( imax, imax+1 ), lda ) rowmax = cabs1( a( imax, jmax ) ) - if( imax>1 ) then - jmax = stdlib_i${ci}$amax( imax-1, a( 1, imax ), 1 ) + if( imax>1_${ik}$ ) then + jmax = stdlib${ii}$_i${ci}$amax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ ) rowmax = max( rowmax, cabs1( a( jmax, imax ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then @@ -27206,15 +27198,15 @@ module stdlib_linalg_lapack_${ci}$ ! interchange rows and columns k-1 and imax, use 2-by-2 ! pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ end if end if ! ============================================================ - 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) - call stdlib_${ci}$swap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_${ci}$swap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) do j = kp + 1, kk - 1 t = conjg( a( j, kk ) ) a( j, kk ) = conjg( a( kp, j ) ) @@ -27224,7 +27216,7 @@ module stdlib_linalg_lapack_${ci}$ r1 = real( a( kk, kk ),KIND=${ck}$) a( kk, kk ) = real( a( kp, kp ),KIND=${ck}$) a( kp, kp ) = r1 - if( kstep==2 ) then + if( kstep==2_${ik}$ ) then a( k, k ) = real( a( k, k ),KIND=${ck}$) t = a( k-1, k ) a( k-1, k ) = a( kp, k ) @@ -27232,19 +27224,19 @@ module stdlib_linalg_lapack_${ci}$ end if else a( k, k ) = real( a( k, k ),KIND=${ck}$) - if( kstep==2 )a( k-1, k-1 ) = real( a( k-1, k-1 ),KIND=${ck}$) + if( kstep==2_${ik}$ )a( k-1, k-1 ) = real( a( k-1, k-1 ),KIND=${ck}$) end if ! update the leading submatrix - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u ! perform a rank-1 update of a(1:k-1,1:k-1) as ! a := a - u(k)*d(k)*u(k)**h = a - w(k)*1/d(k)*w(k)**h r1 = one / real( a( k, k ),KIND=${ck}$) - call stdlib_${ci}$her( uplo, k-1, -r1, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_${ci}$her( uplo, k-1, -r1, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) ! store u(k) in column k - call stdlib_${ci}$dscal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_${ci}$dscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) else ! 2-by-2 pivot block d(k): columns k and k-1 now hold ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k) @@ -27253,8 +27245,8 @@ module stdlib_linalg_lapack_${ci}$ ! perform a rank-2 update of a(1:k-2,1:k-2) as ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**h ! = a - ( w(k-1) w(k) )*inv(d(k))*( w(k-1) w(k) )**h - if( k>2 ) then - d = stdlib_${c2ri(ci)}$lapy2( real( a( k-1, k ),KIND=${ck}$),aimag( a( k-1, k ) ) ) + if( k>2_${ik}$ ) then + d = stdlib${ii}$_${c2ri(ci)}$lapy2( real( a( k-1, k ),KIND=${ck}$),aimag( a( k-1, k ) ) ) d22 = real( a( k-1, k-1 ),KIND=${ck}$) / d d11 = real( a( k, k ),KIND=${ck}$) / d @@ -27276,7 +27268,7 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -27289,11 +27281,11 @@ module stdlib_linalg_lapack_${ci}$ ! factorize a as l*d*l**h using the lower triangle of a ! k is the main loop index, increasing from 1 to n in steps of ! 1 or 2 - k = 1 + k = 1_${ik}$ 50 continue ! if k > n, exit from loop if( k>n )go to 90 - 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 absakk = abs( real( a( k, k ),KIND=${ck}$) ) @@ -27301,15 +27293,15 @@ module stdlib_linalg_lapack_${ci}$ ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k=alpha*colmax*( colmax / rowmax ) ) then @@ -27339,15 +27331,15 @@ module stdlib_linalg_lapack_${ci}$ ! interchange rows and columns k+1 and imax, use 2-by-2 ! pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ end if end if ! ============================================================ - 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( kp1 ) then - imax = stdlib_i${ci}$amax( k-1, a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_i${ci}$amax( k-1, a( 1_${ik}$, k ), 1_${ik}$ ) colmax = cabs1( a( imax, k ) ) else colmax = zero end if if( ( max( absakk, colmax )==zero ) ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k a( k, k ) = real( a( k, k ),KIND=${ck}$) ! set e( k ) to zero - if( k>1 )e( k ) = czero + if( k>1_${ik}$ )e( k ) = czero else ! ============================================================ ! begin pivot search @@ -27534,13 +27526,13 @@ module stdlib_linalg_lapack_${ci}$ ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = imax + stdlib_i${ci}$amax( k-imax, a( imax, imax+1 ),lda ) + jmax = imax + stdlib${ii}$_i${ci}$amax( k-imax, a( imax, imax+1 ),lda ) rowmax = cabs1( a( imax, jmax ) ) else rowmax = zero end if - if( imax>1 ) then - itemp = stdlib_i${ci}$amax( imax-1, a( 1, imax ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_i${ci}$amax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ ) dtemp = cabs1( a( itemp, imax ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -27564,7 +27556,7 @@ module stdlib_linalg_lapack_${ci}$ ! interchange rows and columns k-1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. ! case(4) else @@ -27579,12 +27571,12 @@ module stdlib_linalg_lapack_${ci}$ ! end pivot search ! ============================================================ ! kk is the column of a where pivoting step stopped - kk = k - kstep + 1 + kk = k - kstep + 1_${ik}$ ! for only a 2x2 pivot, interchange rows and columns k and p ! in the leading submatrix a(1:k,1:k) - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! (1) swap columnar parts - if( p>1 )call stdlib_${ci}$swap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) + if( p>1_${ik}$ )call stdlib${ii}$_${ci}$swap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) ! (2) swap and conjugate middle parts do j = p + 1, k - 1 t = conjg( a( j, k ) ) @@ -27599,13 +27591,13 @@ module stdlib_linalg_lapack_${ci}$ a( p, p ) = r1 ! convert upper triangle of a into u form by applying ! the interchanges in columns k+1:n. - if( k1 )call stdlib_${ci}$swap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + if( kp>1_${ik}$ )call stdlib${ii}$_${ci}$swap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) ! (2) swap and conjugate middle parts do j = kp + 1, kk - 1 t = conjg( a( j, kk ) ) @@ -27618,7 +27610,7 @@ module stdlib_linalg_lapack_${ci}$ r1 = real( a( kk, kk ),KIND=${ck}$) a( kk, kk ) = real( a( kp, kp ),KIND=${ck}$) a( kp, kp ) = r1 - if( kstep==2 ) then + if( kstep==2_${ik}$ ) then ! (*) make sure that diagonal element of pivot is real a( k, k ) = real( a( k, k ),KIND=${ck}$) ! (5) swap row elements @@ -27628,18 +27620,18 @@ module stdlib_linalg_lapack_${ci}$ end if ! convert upper triangle of a into u form by applying ! the interchanges in columns k+1:n. - if( k1 ) then + if( k>1_${ik}$ ) then ! perform a rank-1 update of a(1:k-1,1:k-1) and ! store u(k) in column k if( abs( real( a( k, k ),KIND=${ck}$) )>=sfmin ) then @@ -27647,9 +27639,9 @@ module stdlib_linalg_lapack_${ci}$ ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*1/d(k)*w(k)**t d11 = one / real( a( k, k ),KIND=${ck}$) - call stdlib_${ci}$her( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_${ci}$her( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) ! store u(k) in column k - call stdlib_${ci}$dscal( k-1, d11, a( 1, k ), 1 ) + call stdlib${ii}$_${ci}$dscal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = real( a( k, k ),KIND=${ck}$) @@ -27660,7 +27652,7 @@ module stdlib_linalg_lapack_${ci}$ ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_${ci}$her( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_${ci}$her( 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 ) = czero @@ -27674,9 +27666,9 @@ module stdlib_linalg_lapack_${ci}$ ! 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 ! d = |a12| - d = stdlib_${c2ri(ci)}$lapy2( real( a( k-1, k ),KIND=${ck}$),aimag( a( k-1, k ) ) ) + d = stdlib${ii}$_${c2ri(ci)}$lapy2( real( a( k-1, k ),KIND=${ck}$),aimag( a( k-1, k ) ) ) d11 = real( a( k, k ) / d,KIND=${ck}$) d22 = real( a( k-1, k-1 ) / d,KIND=${ck}$) @@ -27707,7 +27699,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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 @@ -27723,11 +27715,11 @@ module stdlib_linalg_lapack_${ci}$ e( n ) = czero ! k is the main loop index, increasing from 1 to n in steps of ! 1 or 2 - k = 1 + 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 @@ -27736,14 +27728,14 @@ module stdlib_linalg_lapack_${ci}$ ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( krowmax ) then rowmax = dtemp @@ -27796,7 +27788,7 @@ module stdlib_linalg_lapack_${ci}$ ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. ! case(4) else @@ -27811,12 +27803,12 @@ module stdlib_linalg_lapack_${ci}$ ! end pivot search ! ============================================================ ! kk is the column of a where pivoting step stopped - kk = k + kstep - 1 + kk = k + kstep - 1_${ik}$ ! for only a 2x2 pivot, interchange rows and columns k and p ! in the trailing submatrix a(k:n,k:n) - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! (1) swap columnar parts - if( p1 )call stdlib_${ci}$swap( k-1, a( k, 1 ), lda, a( p, 1 ), lda ) + if ( k>1_${ik}$ )call stdlib${ii}$_${ci}$swap( k-1, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda ) end if ! for both 1x1 and 2x2 pivots, interchange rows and ! columns kk and kp in the trailing submatrix a(k:n,k:n) if( kp/=kk ) then ! (1) swap columnar parts - if( kp1 )call stdlib_${ci}$swap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) + if ( k>1_${ik}$ )call stdlib${ii}$_${ci}$swap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) else ! (*) make sure that diagonal element of pivot is real a( k, k ) = real( a( k, k ),KIND=${ck}$) - if( kstep==2 )a( k+1, k+1 ) = real( a( k+1, k+1 ),KIND=${ck}$) + if( kstep==2_${ik}$ )a( k+1, k+1 ) = real( a( k+1, k+1 ),KIND=${ck}$) end if ! update the trailing submatrix - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of a now holds ! w(k) = l(k)*d(k), ! where l(k) is the k-th column of l @@ -27881,10 +27873,10 @@ module stdlib_linalg_lapack_${ci}$ ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t d11 = one / real( a( k, k ),KIND=${ck}$) - call stdlib_${ci}$her( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_${ci}$her( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda ) ! store l(k) in column k - call stdlib_${ci}$dscal( n-k, d11, a( k+1, k ), 1 ) + call stdlib${ii}$_${ci}$dscal( n-k, d11, a( k+1, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = real( a( k, k ),KIND=${ck}$) @@ -27895,7 +27887,7 @@ module stdlib_linalg_lapack_${ci}$ ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_${ci}$her( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_${ci}$her( 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 @@ -27912,7 +27904,7 @@ module stdlib_linalg_lapack_${ci}$ ! and store l(k) and l(k+1) in columns k and k+1 if( k1 ) then - imax = stdlib_i${ci}$amax( k-1, a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_i${ci}$amax( k-1, a( 1_${ik}$, k ), 1_${ik}$ ) colmax = cabs1( a( imax, k ) ) else colmax = zero end if if( ( max( absakk, colmax )==zero ) ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k a( k, k ) = real( a( k, k ),KIND=${ck}$) else @@ -28056,13 +28048,13 @@ module stdlib_linalg_lapack_${ci}$ ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = imax + stdlib_i${ci}$amax( k-imax, a( imax, imax+1 ),lda ) + jmax = imax + stdlib${ii}$_i${ci}$amax( k-imax, a( imax, imax+1 ),lda ) rowmax = cabs1( a( imax, jmax ) ) else rowmax = zero end if - if( imax>1 ) then - itemp = stdlib_i${ci}$amax( imax-1, a( 1, imax ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_i${ci}$amax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ ) dtemp = cabs1( a( itemp, imax ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -28086,7 +28078,7 @@ module stdlib_linalg_lapack_${ci}$ ! interchange rows and columns k-1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. ! case(4) else @@ -28101,12 +28093,12 @@ module stdlib_linalg_lapack_${ci}$ ! end pivot search ! ============================================================ ! kk is the column of a where pivoting step stopped - kk = k - kstep + 1 + kk = k - kstep + 1_${ik}$ ! for only a 2x2 pivot, interchange rows and columns k and p ! in the leading submatrix a(1:k,1:k) - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! (1) swap columnar parts - if( p>1 )call stdlib_${ci}$swap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) + if( p>1_${ik}$ )call stdlib${ii}$_${ci}$swap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) ! (2) swap and conjugate middle parts do j = p + 1, k - 1 t = conjg( a( j, k ) ) @@ -28124,7 +28116,7 @@ module stdlib_linalg_lapack_${ci}$ ! columns kk and kp in the leading submatrix a(1:k,1:k) if( kp/=kk ) then ! (1) swap columnar parts - if( kp>1 )call stdlib_${ci}$swap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + if( kp>1_${ik}$ )call stdlib${ii}$_${ci}$swap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) ! (2) swap and conjugate middle parts do j = kp + 1, kk - 1 t = conjg( a( j, kk ) ) @@ -28137,7 +28129,7 @@ module stdlib_linalg_lapack_${ci}$ r1 = real( a( kk, kk ),KIND=${ck}$) a( kk, kk ) = real( a( kp, kp ),KIND=${ck}$) a( kp, kp ) = r1 - if( kstep==2 ) then + if( kstep==2_${ik}$ ) then ! (*) make sure that diagonal element of pivot is real a( k, k ) = real( a( k, k ),KIND=${ck}$) ! (5) swap row elements @@ -28148,14 +28140,14 @@ module stdlib_linalg_lapack_${ci}$ else ! (*) make sure that diagonal element of pivot is real a( k, k ) = real( a( k, k ),KIND=${ck}$) - if( kstep==2 )a( k-1, k-1 ) = real( a( k-1, k-1 ),KIND=${ck}$) + if( kstep==2_${ik}$ )a( k-1, k-1 ) = real( a( k-1, k-1 ),KIND=${ck}$) end if ! update the leading submatrix - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u - if( k>1 ) then + if( k>1_${ik}$ ) then ! perform a rank-1 update of a(1:k-1,1:k-1) and ! store u(k) in column k if( abs( real( a( k, k ),KIND=${ck}$) )>=sfmin ) then @@ -28163,9 +28155,9 @@ module stdlib_linalg_lapack_${ci}$ ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*1/d(k)*w(k)**t d11 = one / real( a( k, k ),KIND=${ck}$) - call stdlib_${ci}$her( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_${ci}$her( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) ! store u(k) in column k - call stdlib_${ci}$dscal( k-1, d11, a( 1, k ), 1 ) + call stdlib${ii}$_${ci}$dscal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = real( a( k, k ),KIND=${ck}$) @@ -28176,7 +28168,7 @@ module stdlib_linalg_lapack_${ci}$ ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_${ci}$her( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_${ci}$her( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) end if end if else @@ -28188,9 +28180,9 @@ module stdlib_linalg_lapack_${ci}$ ! 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 ! d = |a12| - d = stdlib_${c2ri(ci)}$lapy2( real( a( k-1, k ),KIND=${ck}$),aimag( a( k-1, k ) ) ) + d = stdlib${ii}$_${c2ri(ci)}$lapy2( real( a( k-1, k ),KIND=${ck}$),aimag( a( k-1, k ) ) ) d11 = real( a( k, k ) / d,KIND=${ck}$) d22 = real( a( k-1, k-1 ) / d,KIND=${ck}$) @@ -28215,7 +28207,7 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -28228,11 +28220,11 @@ module stdlib_linalg_lapack_${ci}$ ! factorize a as l*d*l**h using the lower triangle of a ! k is the main loop index, increasing from 1 to n in steps of ! 1 or 2 - k = 1 + 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 @@ -28241,14 +28233,14 @@ module stdlib_linalg_lapack_${ci}$ ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( krowmax ) then rowmax = dtemp @@ -28299,7 +28291,7 @@ module stdlib_linalg_lapack_${ci}$ ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. ! case(4) else @@ -28314,12 +28306,12 @@ module stdlib_linalg_lapack_${ci}$ ! end pivot search ! ============================================================ ! kk is the column of a where pivoting step stopped - kk = k + kstep - 1 + kk = k + kstep - 1_${ik}$ ! for only a 2x2 pivot, interchange rows and columns k and p ! in the trailing submatrix a(k:n,k:n) - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! (1) swap columnar parts - if( p1 .and. nb1_${ik}$ .and. nbed ) exit @@ -28776,24 +28768,24 @@ module stdlib_linalg_lapack_${ci}$ loop_130: do sweepid = st, ed loop_140: do k = 1, grsiz myid = (i-sweepid)*(stepercol*grsiz)+ (m-1)*grsiz + k - if ( myid==1 ) then - ttype = 1 + if ( myid==1_${ik}$ ) then + ttype = 1_${ik}$ else - ttype = mod( myid, 2 ) + 2 + ttype = mod( myid, 2_${ik}$ ) + 2_${ik}$ endif - if( ttype==2 ) then - colpt = (myid/2)*kd + sweepid + if( ttype==2_${ik}$ ) then + colpt = (myid/2_${ik}$)*kd + sweepid stind = colpt-kd+1 edind = min(colpt,n) blklastind = colpt else - colpt = ((myid+1)/2)*kd + sweepid + colpt = ((myid+1)/2_${ik}$)*kd + sweepid stind = colpt-kd+1 edind = min(colpt,n) if( ( stind>=edind-1 ).and.( edind==n ) ) then blklastind = n else - blklastind = 0 + blklastind = 0_${ik}$ endif endif ! call the kernel @@ -28802,7 +28794,7 @@ module stdlib_linalg_lapack_${ci}$ !$OMP& DEPEND(in:WORK(MYID-1)) & !$OMP& DEPEND(out:WORK(MYID)) !$ tid = omp_get_thread_num() - !$ call stdlib_${ci}$hb2st_kernels( uplo, wantq, ttype,stind, edind, & + !$ call stdlib${ii}$_${ci}$hb2st_kernels( uplo, wantq, ttype,stind, edind, & !$ sweepid, n, kd, ib,work ( inda ), lda,hous( indv ), hous( & !$ indtau ), ldv,work( indw + tid*kd ) ) !$OMP END TASK @@ -28810,13 +28802,13 @@ module stdlib_linalg_lapack_${ci}$ !$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) & !$OMP& DEPEND(out:WORK(MYID)) !$ tid = omp_get_thread_num() - call stdlib_${ci}$hb2st_kernels( uplo, wantq, ttype,stind, edind, & + call stdlib${ii}$_${ci}$hb2st_kernels( uplo, wantq, ttype,stind, edind, & sweepid, n, kd, ib,work ( inda ), lda,hous( indv ), hous( & indtau ), ldv,work( indw + tid*kd ) ) !$OMP END TASK !$ endif if ( blklastind>=(n-1) ) then - stt = stt + 1 + stt = stt + 1_${ik}$ exit endif end do loop_140 @@ -28842,13 +28834,13 @@ module stdlib_linalg_lapack_${ci}$ e( i ) = real( work( ofdpos+(i-1)*lda ),KIND=${ck}$) end do endif - hous( 1 ) = lhmin - work( 1 ) = lwmin + hous( 1_${ik}$ ) = lhmin + work( 1_${ik}$ ) = lwmin return - end subroutine stdlib_${ci}$hetrd_hb2st + end subroutine stdlib${ii}$_${ci}$hetrd_hb2st - subroutine stdlib_${ci}$hetrd_he2hb( uplo, n, kd, a, lda, ab, ldab, tau,work, lwork, info ) + subroutine stdlib${ii}$_${ci}$hetrd_he2hb( uplo, n, kd, a, lda, ab, ldab, tau,work, lwork, info ) !! ZHETRD_HE2HB: reduces a complex Hermitian matrix A to complex Hermitian !! band-diagonal form AB by a unitary similarity transformation: !! Q**H * A * Q = AB. @@ -28858,8 +28850,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, ldab, lwork, n, kd + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldab, lwork, n, kd ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: ab(ldab,*), tau(*), work(*) @@ -28870,35 +28862,35 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: lquery, upper - integer(ilp) :: i, j, iinfo, lwmin, pn, pk, llk, ldt, ldw, lds2, lds1, ls2, ls1, lw, lt,& + integer(${ik}$) :: i, j, iinfo, lwmin, pn, pk, llk, ldt, ldw, lds2, lds1, ls2, ls1, lw, lt,& tpos, wpos, s2pos, s1pos ! Intrinsic Functions intrinsic :: min,max ! Executable Statements ! determine the minimal workspace size required ! and test the input parameters - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) - lquery = ( lwork==-1 ) - lwmin = stdlib_ilaenv2stage( 4, 'ZHETRD_HE2HB', '', n, kd, -1, -1 ) + lquery = ( lwork==-1_${ik}$ ) + lwmin = stdlib${ii}$_ilaenv2stage( 4_${ik}$, 'ZHETRD_HE2HB', '', n, kd, -1_${ik}$, -1_${ik}$ ) 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( 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_${ci}$lahef( uplo, k, nb, kb, a, lda, ipiv, work, n, iinfo ) + call stdlib${ii}$_${ci}$lahef( uplo, k, nb, kb, a, lda, ipiv, work, n, iinfo ) else ! use unblocked code to factorize columns 1:k of a - call stdlib_${ci}$hetf2( uplo, k, a, lda, ipiv, iinfo ) + call stdlib${ii}$_${ci}$hetf2( 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 ! decrease k and return to the start of the main loop k = k - kb go to 10 else ! factorize a as l*d*l**h using the lower triangle of a ! k is the main loop index, increasing from 1 to n in steps of - ! kb, where kb is the number of columns factorized by stdlib_${ci}$lahef; + ! kb, where kb is the number of columns factorized by stdlib${ii}$_${ci}$lahef; ! 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_${ci}$lahef( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, n, & + call stdlib${ii}$_${ci}$lahef( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, n, & iinfo ) else ! use unblocked code to factorize columns k:n of a - call stdlib_${ci}$hetf2( uplo, n-k+1, a( k, k ), lda, ipiv( k ), iinfo ) - kb = n - k + 1 + call stdlib${ii}$_${ci}$hetf2( 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 @@ -29145,12 +29137,12 @@ module stdlib_linalg_lapack_${ci}$ go to 20 end if 40 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ci}$hetrf + end subroutine stdlib${ii}$_${ci}$hetrf - pure subroutine stdlib_${ci}$hetrf_aa( uplo, n, a, lda, ipiv, work, lwork, info) + pure subroutine stdlib${ii}$_${ci}$hetrf_aa( uplo, n, a, lda, ipiv, work, lwork, info) !! ZHETRF_AA: computes the factorization of a complex hermitian matrix A !! using the Aasen's algorithm. The form of the factorization is !! A = U**H*T*U or A = L*T*L**H @@ -29162,58 +29154,58 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: n, lda, lwork - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n, lda, lwork + integer(${ik}$), intent(out) :: info ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, upper - integer(ilp) :: j, lwkopt - integer(ilp) :: nb, mj, nj, k1, k2, j1, j2, j3, jb + integer(${ik}$) :: j, lwkopt + integer(${ik}$) :: nb, mj, nj, k1, k2, j1, j2, j3, jb complex(${ck}$) :: alpha ! Intrinsic Functions intrinsic :: real,conjg,max ! Executable Statements ! determine the block size - nb = stdlib_ilaenv( 1, 'ZHETRF_AA', uplo, n, -1, -1, -1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZHETRF_AA', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) ! 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( lda=n )go to 20 ! each step of the main loop @@ -29234,17 +29226,17 @@ module stdlib_linalg_lapack_${ci}$ ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=1 for the first panel, and ! k1=0 for the rest - j1 = j + 1 + j1 = j + 1_${ik}$ jb = min( n-j1+1, nb ) - k1 = max(1, j)-j + k1 = max(1_${ik}$, j)-j ! panel factorization - call stdlib_${ci}$lahef_aa( uplo, 2-k1, n-j, jb,a( max(1, j), j+1 ), lda,ipiv( j+1 ), & + call stdlib${ii}$_${ci}$lahef_aa( uplo, 2_${ik}$-k1, n-j, jb,a( max(1_${ik}$, j), j+1 ), lda,ipiv( j+1 ), & work, n, work( n*nb+1 ) ) ! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot) do j2 = j+2, min(n, j+jb+1) ipiv( j2 ) = ipiv( j2 ) + j - if( (j2/=ipiv(j2)) .and. ((j1-k1)>2) ) then - call stdlib_${ci}$swap( j1-k1-2, a( 1, j2 ), 1,a( 1, ipiv(j2) ), 1 ) + if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then + call stdlib${ii}$_${ci}$swap( j1-k1-2, a( 1_${ik}$, j2 ), 1_${ik}$,a( 1_${ik}$, ipiv(j2) ), 1_${ik}$ ) end if end do j = j + jb @@ -29253,37 +29245,37 @@ module stdlib_linalg_lapack_${ci}$ ! work stores the current block of the auxiriarly matrix h if( j1 .or. jb>1 ) then + if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then ! merge rank-1 update with blas-3 update alpha = conjg( a( j, j+1 ) ) a( j, j+1 ) = cone - call stdlib_${ci}$copy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib${ii}$_${ci}$copy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) - call stdlib_${ci}$scal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib${ii}$_${ci}$scal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=0 and k2=1 for the first panel, ! and k1=1 and k2=0 for the rest - if( j1>1 ) then + if( j1>1_${ik}$ ) then ! not first panel - k2 = 1 + k2 = 1_${ik}$ else ! first panel - k2 = 0 + k2 = 0_${ik}$ ! first update skips the first column - jb = jb - 1 + jb = jb - 1_${ik}$ end if do j2 = j+1, n, nb nj = min( nb, n-j2+1 ) - ! update (j2, j2) diagonal block with stdlib_${ci}$gemv + ! update (j2, j2) diagonal block with stdlib${ii}$_${ci}$gemv j3 = j2 do mj = nj-1, 1, -1 - call stdlib_${ci}$gemm( 'CONJUGATE TRANSPOSE', 'TRANSPOSE',1, mj, jb+1,-cone,& + call stdlib${ii}$_${ci}$gemm( 'CONJUGATE TRANSPOSE', 'TRANSPOSE',1_${ik}$, mj, jb+1,-cone,& a( j1-k2, j3 ), lda,work( (j3-j1+1)+k1*n ), n,cone, a( j3, j3 ), lda ) - j3 = j3 + 1 + j3 = j3 + 1_${ik}$ end do - ! update off-diagonal block of j2-th block row with stdlib_${ci}$gemm - call stdlib_${ci}$gemm( 'CONJUGATE TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-& + ! update off-diagonal block of j2-th block row with stdlib${ii}$_${ci}$gemm + call stdlib${ii}$_${ci}$gemm( 'CONJUGATE TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-& cone, a( j1-k2, j2 ), lda,work( (j3-j1+1)+k1*n ), n,cone, a( j2, j3 ), lda & ) end do @@ -29291,7 +29283,7 @@ module stdlib_linalg_lapack_${ci}$ a( j, j+1 ) = conjg( alpha ) end if ! work(j+1, 1) stores h(j+1, 1) - call stdlib_${ci}$copy( n-j, a( j+1, j+1 ), lda, work( 1 ), 1 ) + call stdlib${ii}$_${ci}$copy( n-j, a( j+1, j+1 ), lda, work( 1_${ik}$ ), 1_${ik}$ ) end if go to 10 else @@ -29300,11 +29292,11 @@ module stdlib_linalg_lapack_${ci}$ ! ..................................................... ! copy first column a(1:n, 1) into h(1:n, 1) ! (stored in work(1:n)) - call stdlib_${ci}$copy( n, a( 1, 1 ), 1, work( 1 ), 1 ) + call stdlib${ii}$_${ci}$copy( n, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) ! j is the main loop index, increasing from 1 to n in steps of - ! jb, where jb is the number of columns factorized by stdlib_${ci}$lahef; + ! jb, where jb is the number of columns factorized by stdlib${ii}$_${ci}$lahef; ! jb is either nb, or n-j+1 for the last block - j = 0 + j = 0_${ik}$ 11 continue if( j>=n )go to 20 ! each step of the main loop @@ -29315,15 +29307,15 @@ module stdlib_linalg_lapack_${ci}$ ! k1=0 for the rest j1 = j+1 jb = min( n-j1+1, nb ) - k1 = max(1, j)-j + k1 = max(1_${ik}$, j)-j ! panel factorization - call stdlib_${ci}$lahef_aa( uplo, 2-k1, n-j, jb,a( j+1, max(1, j) ), lda,ipiv( j+1 ), & + call stdlib${ii}$_${ci}$lahef_aa( uplo, 2_${ik}$-k1, n-j, jb,a( j+1, max(1_${ik}$, j) ), lda,ipiv( j+1 ), & work, n, work( n*nb+1 ) ) ! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot) do j2 = j+2, min(n, j+jb+1) ipiv( j2 ) = ipiv( j2 ) + j - if( (j2/=ipiv(j2)) .and. ((j1-k1)>2) ) then - call stdlib_${ci}$swap( j1-k1-2, a( j2, 1 ), lda,a( ipiv(j2), 1 ), lda ) + if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then + call stdlib${ii}$_${ci}$swap( j1-k1-2, a( j2, 1_${ik}$ ), lda,a( ipiv(j2), 1_${ik}$ ), lda ) end if end do j = j + jb @@ -29332,36 +29324,36 @@ module stdlib_linalg_lapack_${ci}$ ! work(j2+1, 1) stores h(j2+1, 1) if( j1 .or. jb>1 ) then + if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then ! merge rank-1 update with blas-3 update alpha = conjg( a( j+1, j ) ) a( j+1, j ) = cone - call stdlib_${ci}$copy( n-j, a( j+1, j-1 ), 1,work( (j+1-j1+1)+jb*n ), 1 ) - call stdlib_${ci}$scal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib${ii}$_${ci}$copy( n-j, a( j+1, j-1 ), 1_${ik}$,work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$scal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=0 and k2=1 for the first panel, ! and k1=1 and k2=0 for the rest - if( j1>1 ) then + if( j1>1_${ik}$ ) then ! not first panel - k2 = 1 + k2 = 1_${ik}$ else ! first panel - k2 = 0 + k2 = 0_${ik}$ ! first update skips the first column - jb = jb - 1 + jb = jb - 1_${ik}$ end if do j2 = j+1, n, nb nj = min( nb, n-j2+1 ) - ! update (j2, j2) diagonal block with stdlib_${ci}$gemv + ! update (j2, j2) diagonal block with stdlib${ii}$_${ci}$gemv j3 = j2 do mj = nj-1, 1, -1 - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',mj, 1, jb+1,-& + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',mj, 1_${ik}$, jb+1,-& cone, work( (j3-j1+1)+k1*n ), n,a( j3, j1-k2 ), lda,cone, a( j3, j3 ), & lda ) - j3 = j3 + 1 + j3 = j3 + 1_${ik}$ end do - ! update off-diagonal block of j2-th block column with stdlib_${ci}$gemm - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',n-j3+1, nj, jb+1,-& + ! update off-diagonal block of j2-th block column with stdlib${ii}$_${ci}$gemm + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',n-j3+1, nj, jb+1,-& cone, work( (j3-j1+1)+k1*n ), n,a( j2, j1-k2 ), lda,cone, a( j3, j2 ), lda & ) end do @@ -29369,17 +29361,17 @@ module stdlib_linalg_lapack_${ci}$ a( j+1, j ) = conjg( alpha ) end if ! work(j+1, 1) stores h(j+1, 1) - call stdlib_${ci}$copy( n-j, a( j+1, j+1 ), 1, work( 1 ), 1 ) + call stdlib${ii}$_${ci}$copy( n-j, a( j+1, j+1 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) end if go to 11 end if 20 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ci}$hetrf_aa + end subroutine stdlib${ii}$_${ci}$hetrf_aa - pure subroutine stdlib_${ci}$hetrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) + pure subroutine stdlib${ii}$_${ci}$hetrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) !! ZHETRF_RK: computes the factorization of a complex Hermitian matrix A !! using the bounded Bunch-Kaufman (rook) diagonal pivoting method: !! A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T), @@ -29394,60 +29386,60 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), 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_${ci}$lahef_rk( uplo, k, nb, kb, a, lda, e,ipiv, work, ldwork, iinfo ) + call stdlib${ii}$_${ci}$lahef_rk( uplo, k, nb, kb, a, lda, e,ipiv, work, ldwork, iinfo ) else ! use unblocked code to factorize columns 1:k of a - call stdlib_${ci}$hetf2_rk( uplo, k, a, lda, e, ipiv, iinfo ) + call stdlib${ii}$_${ci}$hetf2_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 ! read ipiv from the last block factored, i.e. @@ -29477,7 +29469,7 @@ module stdlib_linalg_lapack_${ci}$ do i = k, ( k - kb + 1 ), -1 ip = abs( ipiv( i ) ) if( ip/=i ) then - call stdlib_${ci}$swap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda ) + call stdlib${ii}$_${ci}$swap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda ) end if end do end if @@ -29490,31 +29482,31 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$lahef_rk; + ! kb, where kb is the number of columns factorized by stdlib${ii}$_${ci}$lahef_rk; ! 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 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_${ci}$lahef_rk( uplo, n-k+1, nb, kb, a( k, k ), lda, e( k ),ipiv( k ), & + call stdlib${ii}$_${ci}$lahef_rk( uplo, n-k+1, nb, kb, a( k, k ), lda, e( k ),ipiv( k ), & work, ldwork, iinfo ) else ! use unblocked code to factorize columns k:n of a - call stdlib_${ci}$hetf2_rk( uplo, n-k+1, a( k, k ), lda, e( k ),ipiv( k ), iinfo ) + call stdlib${ii}$_${ci}$hetf2_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 @@ -29524,11 +29516,11 @@ module stdlib_linalg_lapack_${ci}$ ! (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 + if( k>1_${ik}$ ) then do i = k, ( k + kb - 1 ), 1 ip = abs( ipiv( i ) ) if( ip/=i ) then - call stdlib_${ci}$swap( k-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_${ci}$swap( k-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda ) end if end do end if @@ -29540,12 +29532,12 @@ module stdlib_linalg_lapack_${ci}$ 35 continue ! end lower end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ci}$hetrf_rk + end subroutine stdlib${ii}$_${ci}$hetrf_rk - pure subroutine stdlib_${ci}$hetrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) + pure subroutine stdlib${ii}$_${ci}$hetrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) !! ZHETRF_ROOK: computes the factorization of a complex Hermitian matrix A !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. !! The form of the factorization is @@ -29559,60 +29551,60 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), 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_${ci}$lahef_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo ) + call stdlib${ii}$_${ci}$lahef_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo ) else ! use unblocked code to factorize columns 1:k of a - call stdlib_${ci}$hetf2_rook( uplo, k, a, lda, ipiv, iinfo ) + call stdlib${ii}$_${ci}$hetf2_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 @@ -29637,30 +29629,30 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$lahef_rook; + ! kb, where kb is the number of columns factorized by stdlib${ii}$_${ci}$lahef_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_${ci}$lahef_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, & + call stdlib${ii}$_${ci}$lahef_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, & ldwork, iinfo ) else ! use unblocked code to factorize columns k:n of a - call stdlib_${ci}$hetf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo ) - kb = n - k + 1 + call stdlib${ii}$_${ci}$hetf2_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 @@ -29668,12 +29660,12 @@ module stdlib_linalg_lapack_${ci}$ go to 20 end if 40 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ci}$hetrf_rook + end subroutine stdlib${ii}$_${ci}$hetrf_rook - pure subroutine stdlib_${ci}$hetri( uplo, n, a, lda, ipiv, work, info ) + pure subroutine stdlib${ii}$_${ci}$hetri( uplo, n, a, lda, ipiv, work, info ) !! ZHETRI: computes the inverse of a complex Hermitian indefinite matrix !! A using the factorization A = U*D*U**H or A = L*D*L**H computed by !! ZHETRF. @@ -29682,10 +29674,10 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: work(*) ! ===================================================================== @@ -29693,24 +29685,24 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: upper - integer(ilp) :: j, k, kp, kstep + integer(${ik}$) :: j, k, kp, kstep real(${ck}$) :: ak, akp1, d, t complex(${ck}$) :: akkp1, temp ! Intrinsic Functions intrinsic :: abs,real,conjg,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 )==czero )return end do end if - info = 0 + info = 0_${ik}$ if( upper ) then ! compute inv(a) from the factorization a = u*d*u**h. ! 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 = 1_${ik}$ 30 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = one / real( a( k, k ),KIND=${ck}$) ! compute column k of the inverse. - if( k>1 ) then - call stdlib_${ci}$copy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_${ci}$hemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_${ci}$copy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$hemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - real( stdlib_${ci}$dotc( k-1, work, 1, a( 1,k ), 1 ),& + a( k, k ) = a( k, k ) - real( stdlib${ii}$_${ci}$dotc( k-1, work, 1_${ik}$, a( 1_${ik}$,k ), 1_${ik}$ ),& KIND=${ck}$) end if - kstep = 1 + kstep = 1_${ik}$ else ! 2 x 2 diagonal block ! invert the diagonal block. @@ -29761,27 +29753,27 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$copy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_${ci}$hemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_${ci}$copy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$hemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - real( stdlib_${ci}$dotc( k-1, work, 1, a( 1,k ), 1 ),& + a( k, k ) = a( k, k ) - real( stdlib${ii}$_${ci}$dotc( k-1, work, 1_${ik}$, a( 1_${ik}$,k ), 1_${ik}$ ),& KIND=${ck}$) - a( k, k+1 ) = a( k, k+1 ) -stdlib_${ci}$dotc( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) + a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_${ci}$dotc( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) - call stdlib_${ci}$copy( k-1, a( 1, k+1 ), 1, work, 1 ) - call stdlib_${ci}$hemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k+1 ), 1 ) + call stdlib${ii}$_${ci}$copy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$hemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k+1 ), 1_${ik}$ ) - a( k+1, k+1 ) = a( k+1, k+1 ) -real( stdlib_${ci}$dotc( k-1, work, 1, a( 1, k+1 ),& - 1 ),KIND=${ck}$) + a( k+1, k+1 ) = a( k+1, k+1 ) -real( stdlib${ii}$_${ci}$dotc( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ),& + 1_${ik}$ ),KIND=${ck}$) 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_${ci}$swap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_${ci}$swap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) do j = kp + 1, k - 1 temp = conjg( a( j, k ) ) a( j, k ) = conjg( a( kp, j ) ) @@ -29791,7 +29783,7 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -29808,19 +29800,19 @@ module stdlib_linalg_lapack_${ci}$ 60 continue ! if k < 1, exit from loop. if( k<1 )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = one / real( a( k, k ),KIND=${ck}$) ! compute column k of the inverse. if( k0 .and. a( info, info )==czero )return end do end if - info = 0 + info = 0_${ik}$ if( upper ) then ! compute inv(a) from the factorization a = u*d*u**h. ! 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 = 1_${ik}$ 30 continue ! if k > n, exit from loop. if( k>n )go to 70 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = one / real( a( k, k ),KIND=${ck}$) ! compute column k of the inverse. - if( k>1 ) then - call stdlib_${ci}$copy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_${ci}$hemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_${ci}$copy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$hemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - real( stdlib_${ci}$dotc( k-1, work, 1, a( 1,k ), 1 ),& + a( k, k ) = a( k, k ) - real( stdlib${ii}$_${ci}$dotc( k-1, work, 1_${ik}$, a( 1_${ik}$,k ), 1_${ik}$ ),& KIND=${ck}$) end if - kstep = 1 + kstep = 1_${ik}$ else ! 2 x 2 diagonal block ! invert the diagonal block. @@ -29965,28 +29957,28 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$copy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_${ci}$hemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_${ci}$copy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$hemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - real( stdlib_${ci}$dotc( k-1, work, 1, a( 1,k ), 1 ),& + a( k, k ) = a( k, k ) - real( stdlib${ii}$_${ci}$dotc( k-1, work, 1_${ik}$, a( 1_${ik}$,k ), 1_${ik}$ ),& KIND=${ck}$) - a( k, k+1 ) = a( k, k+1 ) -stdlib_${ci}$dotc( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) + a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_${ci}$dotc( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) - call stdlib_${ci}$copy( k-1, a( 1, k+1 ), 1, work, 1 ) - call stdlib_${ci}$hemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k+1 ), 1 ) + call stdlib${ii}$_${ci}$copy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$hemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k+1 ), 1_${ik}$ ) - a( k+1, k+1 ) = a( k+1, k+1 ) -real( stdlib_${ci}$dotc( k-1, work, 1, a( 1, k+1 ),& - 1 ),KIND=${ck}$) + a( k+1, k+1 ) = a( k+1, k+1 ) -real( stdlib${ii}$_${ci}$dotc( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ),& + 1_${ik}$ ),KIND=${ck}$) 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:k) kp = ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_${ci}$swap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) + if( kp>1_${ik}$ )call stdlib${ii}$_${ci}$swap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) do j = kp + 1, k - 1 temp = conjg( a( j, k ) ) a( j, k ) = conjg( a( kp, j ) ) @@ -30003,7 +29995,7 @@ module stdlib_linalg_lapack_${ci}$ ! (1) interchange rows and columns k and -ipiv(k) kp = -ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_${ci}$swap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) + if( kp>1_${ik}$ )call stdlib${ii}$_${ci}$swap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) do j = kp + 1, k - 1 temp = conjg( a( j, k ) ) a( j, k ) = conjg( a( kp, j ) ) @@ -30018,10 +30010,10 @@ module stdlib_linalg_lapack_${ci}$ a( kp, k+1 ) = temp end if ! (2) interchange rows and columns k+1 and -ipiv(k+1) - k = k + 1 + k = k + 1_${ik}$ kp = -ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_${ci}$swap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) + if( kp>1_${ik}$ )call stdlib${ii}$_${ci}$swap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) do j = kp + 1, k - 1 temp = conjg( a( j, k ) ) a( j, k ) = conjg( a( kp, j ) ) @@ -30033,7 +30025,7 @@ module stdlib_linalg_lapack_${ci}$ a( kp, kp ) = temp end if end if - k = k + 1 + k = k + 1_${ik}$ go to 30 70 continue else @@ -30044,19 +30036,19 @@ module stdlib_linalg_lapack_${ci}$ 80 continue ! if k < 1, exit from loop. if( k<1 )go to 120 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = one / real( a( k, k ),KIND=${ck}$) ! compute column k of the inverse. if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_${ci}$geru( k-1, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & + call stdlib${ii}$_${ci}$geru( k-1, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb & ) ! multiply by the inverse of the diagonal block. s = real( cone,KIND=${ck}$) / real( a( k, k ),KIND=${ck}$) - call stdlib_${ci}$dscal( nrhs, s, b( k, 1 ), ldb ) - k = k - 1 + call stdlib${ii}$_${ci}$dscal( nrhs, s, b( k, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( kp/=k-1 )call stdlib_${ci}$swap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib${ii}$_${ci}$swap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - call stdlib_${ci}$geru( k-2, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & + call stdlib${ii}$_${ci}$geru( k-2, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb & ) - call stdlib_${ci}$geru( k-2, nrhs, -cone, a( 1, k-1 ), 1, b( k-1, 1 ),ldb, b( 1, 1 ), & + call stdlib${ii}$_${ci}$geru( k-2, nrhs, -cone, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), & ldb ) ! multiply by the inverse of the diagonal block. akm1k = a( k-1, k ) @@ -30233,49 +30225,49 @@ module stdlib_linalg_lapack_${ci}$ 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**h *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 = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(u**h(k)), where u(k) is the transformation ! stored in column k of a. - if( k>1 ) then - call stdlib_${ci}$lacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), & - 1, cone, b( k, 1 ), ldb ) - call stdlib_${ci}$lacgv( nrhs, b( k, 1 ), ldb ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), & + 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb ) end if ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 1 + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 1_${ik}$ else ! 2 x 2 diagonal block ! multiply by inv(u**h(k+1)), where u(k+1) is the transformation ! stored in columns k and k+1 of a. - if( k>1 ) then - call stdlib_${ci}$lacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), & - 1, cone, b( k, 1 ), ldb ) - call stdlib_${ci}$lacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_${ci}$lacgv( nrhs, b( k+1, 1 ), ldb ) - call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k+1 )& - , 1, cone, b( k+1, 1 ), ldb ) - call stdlib_${ci}$lacgv( nrhs, b( k+1, 1 ), ldb ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), & + 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$lacgv( nrhs, b( k+1, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k+1 )& + , 1_${ik}$, cone, b( k+1, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$lacgv( nrhs, b( k+1, 1_${ik}$ ), ldb ) end if ! interchange rows k and -ipiv(k). kp = -ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 2 + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 2_${ik}$ end if go to 40 50 continue @@ -30284,35 +30276,35 @@ module stdlib_linalg_lapack_${ci}$ ! 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 = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(l**h(k)), where l(k) is the transformation ! stored in column k of a. if( k= 1 ) - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k-1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( kp==-ipiv( k-1 ) )call stdlib_${ci}$swap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb & + if( kp==-ipiv( k-1 ) )call stdlib${ii}$_${ci}$swap( 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_${ci}$trsm('L','U','N','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib${ii}$_${ci}$trsm('L','U','N','U',n,nrhs,cone,a,lda,b,ldb) ! compute d \ b -> b [ d \ (u \p**t * b) ] i=n do while ( i >= 1 ) - if( ipiv(i) > 0 ) then + if( ipiv(i) > 0_${ik}$ ) then s = real( cone,KIND=${ck}$) / real( a( i, i ),KIND=${ck}$) - call stdlib_${ci}$dscal( nrhs, s, b( i, 1 ), ldb ) - elseif ( i > 1) then + call stdlib${ii}$_${ci}$dscal( nrhs, s, 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 @@ -30462,59 +30454,59 @@ module stdlib_linalg_lapack_${ci}$ 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**h \ b) -> b [ u**h \ (d \ (u \p**t * b) ) ] - call stdlib_${ci}$trsm('L','U','C','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib${ii}$_${ci}$trsm('L','U','C','U',n,nrhs,cone,a,lda,b,ldb) ! p * b [ p * (u**h \ (d \ (u \p**t * b) )) ] - k=1 + k=1_${ik}$ do while ( k <= n ) - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k+1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( k < n .and. kp==-ipiv( k+1 ) )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp,& - 1 ), ldb ) + if( k < n .and. kp==-ipiv( k+1 ) )call stdlib${ii}$_${ci}$swap( 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**h. ! p**t * b - k=1 + k=1_${ik}$ do while ( k <= n ) - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k+1 else ! 2 x 2 diagonal block ! interchange rows k and -ipiv(k+1). kp = -ipiv( k+1 ) - if( kp==-ipiv( k ) )call stdlib_${ci}$swap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp==-ipiv( k ) )call stdlib${ii}$_${ci}$swap( 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_${ci}$trsm('L','L','N','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib${ii}$_${ci}$trsm('L','L','N','U',n,nrhs,cone,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 + if( ipiv(i) > 0_${ik}$ ) then s = real( cone,KIND=${ck}$) / real( a( i, i ),KIND=${ck}$) - call stdlib_${ci}$dscal( nrhs, s, b( i, 1 ), ldb ) + call stdlib${ii}$_${ci}$dscal( nrhs, s, b( i, 1_${ik}$ ), ldb ) else akm1k = work(i) akm1 = a( i, i ) / conjg( akm1k ) @@ -30526,38 +30518,38 @@ module stdlib_linalg_lapack_${ci}$ 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**h \ b) -> b [ l**h \ (d \ (l \p**t * b) ) ] - call stdlib_${ci}$trsm('L','L','C','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib${ii}$_${ci}$trsm('L','L','C','U',n,nrhs,cone,a,lda,b,ldb) ! p * b [ p * (l**h \ (d \ (l \p**t * b) )) ] k=n do while ( k >= 1 ) - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k-1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( k>1 .and. kp==-ipiv( k-1 ) )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, & - 1 ), ldb ) + if( k>1_${ik}$ .and. kp==-ipiv( k-1 ) )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, & + 1_${ik}$ ), ldb ) k=k-2 endif end do end if ! revert a - call stdlib_${ci}$syconv( uplo, 'R', n, a, lda, ipiv, work, iinfo ) + call stdlib${ii}$_${ci}$syconv( uplo, 'R', n, a, lda, ipiv, work, iinfo ) return - end subroutine stdlib_${ci}$hetrs2 + end subroutine stdlib${ii}$_${ci}$hetrs2 - pure subroutine stdlib_${ci}$hetrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) + pure subroutine stdlib${ii}$_${ci}$hetrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) !! ZHETRS_3: solves a system of linear equations A * X = B with a complex !! Hermitian matrix A using the factorization computed !! by ZHETRF_RK or ZHETRF_BK: @@ -30572,37 +30564,37 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), intent(in) :: a(lda,*), e(*) complex(${ck}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: i, j, k, kp + integer(${ik}$) :: i, j, k, kp real(${ck}$) :: s complex(${ck}$) :: ak, akm1, akm1k, bk, bkm1, denom ! Intrinsic Functions intrinsic :: abs,real,conjg,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_${ci}$trsm( 'L', 'U', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib${ii}$_${ci}$trsm( 'L', 'U', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) ! compute d \ b -> b [ d \ (u \p**t * b) ] i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then + if( ipiv( i )>0_${ik}$ ) then s = real( cone,KIND=${ck}$) / real( a( i, i ),KIND=${ck}$) - call stdlib_${ci}$dscal( nrhs, s, b( i, 1 ), ldb ) - else if ( i>1 ) then + call stdlib${ii}$_${ci}$dscal( nrhs, s, 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 ) / conjg( akm1k ) @@ -30641,12 +30633,12 @@ module stdlib_linalg_lapack_${ci}$ 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**h \ b) -> b [ u**h \ (d \ (u \p**t * b) ) ] - call stdlib_${ci}$trsm( 'L', 'U', 'C', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib${ii}$_${ci}$trsm( 'L', 'U', 'C', 'U', n, nrhs, cone, a, lda, b, ldb ) ! p * b [ p * (u**h \ (d \ (u \p**t * b) )) ] ! interchange rows k and ipiv(k) of matrix b in reverse order ! from the formation order of ipiv(i) vector for upper case. @@ -30656,7 +30648,7 @@ module stdlib_linalg_lapack_${ci}$ do k = 1, n, 1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end if end do else @@ -30671,17 +30663,17 @@ module stdlib_linalg_lapack_${ci}$ do k = 1, n, 1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib${ii}$_${ci}$swap( 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_${ci}$trsm( 'L', 'L', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib${ii}$_${ci}$trsm( 'L', 'L', 'N', 'U', n, nrhs, cone, 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 + if( ipiv( i )>0_${ik}$ ) then s = real( cone,KIND=${ck}$) / real( a( i, i ),KIND=${ck}$) - call stdlib_${ci}$dscal( nrhs, s, b( i, 1 ), ldb ) + call stdlib${ii}$_${ci}$dscal( nrhs, s, b( i, 1_${ik}$ ), ldb ) else if( i b [ l**h \ (d \ (l \p**t * b) ) ] - call stdlib_${ci}$trsm('L', 'L', 'C', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib${ii}$_${ci}$trsm('L', 'L', 'C', 'U', n, nrhs, cone, a, lda, b, ldb ) ! p * b [ p * (l**h \ (d \ (l \p**t * b) )) ] ! interchange rows k and ipiv(k) of matrix b in reverse order ! from the formation order of ipiv(i) vector for lower case. @@ -30708,16 +30700,16 @@ module stdlib_linalg_lapack_${ci}$ do k = n, 1, -1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end if end do ! end lower end if return - end subroutine stdlib_${ci}$hetrs_3 + end subroutine stdlib${ii}$_${ci}$hetrs_3 - pure subroutine stdlib_${ci}$hetrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) + pure subroutine stdlib${ii}$_${ci}$hetrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) !! ZHETRS_AA: solves a system of linear equations A*X = B with a complex !! hermitian matrix A using the factorization A = U**H*T*U or !! A = L*T*L**H computed by ZHETRF_AA. @@ -30727,42 +30719,42 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), intent(in) :: a(lda,*) complex(${ck}$), intent(inout) :: b(ldb,*) complex(${ck}$), 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 + if( n>1_${ik}$ ) then ! pivot, p**t * b -> b do k = 1, n kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end do ! compute u**h \ b -> b [ (u**h \p**t * b) ] - call stdlib_${ci}$trsm( 'L', 'U', 'C', 'U', n-1, nrhs, cone, a( 1, 2 ),lda, b( 2, 1 ),& + call stdlib${ii}$_${ci}$trsm( 'L', 'U', 'C', 'U', n-1, nrhs, cone, a( 1_${ik}$, 2_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),& ldb ) end if ! 2) solve with triangular matrix t ! compute t \ b -> b [ t \ (u**h \p**t * b) ] - call stdlib_${ci}$lacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1 ) - if( n>1 ) then - call stdlib_${ci}$lacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 2*n ), 1) - call stdlib_${ci}$lacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 1 ), 1 ) - call stdlib_${ci}$lacgv( n-1, work( 1 ), 1 ) + call stdlib${ii}$_${ci}$lacpy( 'F', 1_${ik}$, n, a(1_${ik}$, 1_${ik}$), lda+1, work(n), 1_${ik}$ ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'F', 1_${ik}$, n-1, a( 1_${ik}$, 2_${ik}$ ), lda+1, work( 2_${ik}$*n ), 1_${ik}$) + call stdlib${ii}$_${ci}$lacpy( 'F', 1_${ik}$, n-1, a( 1_${ik}$, 2_${ik}$ ), lda+1, work( 1_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( n-1, work( 1_${ik}$ ), 1_${ik}$ ) end if - call stdlib_${ci}$gtsv( n, nrhs, work(1), work(n), work(2*n), b, ldb,info ) + call stdlib${ii}$_${ci}$gtsv( n, nrhs, work(1_${ik}$), work(n), work(2_${ik}$*n), b, ldb,info ) ! 3) backward substitution with u - if( n>1 ) then + if( n>1_${ik}$ ) then ! compute u \ b -> b [ u \ (t \ (u**h \p**t * b) ) ] - call stdlib_${ci}$trsm( 'L', 'U', 'N', 'U', n-1, nrhs, cone, a( 1, 2 ),lda, b(2, 1), & + call stdlib${ii}$_${ci}$trsm( 'L', 'U', 'N', 'U', n-1, nrhs, cone, a( 1_${ik}$, 2_${ik}$ ),lda, b(2_${ik}$, 1_${ik}$), & ldb) ! pivot, p * b [ p * (u**h \ (t \ (u \p**t * b) )) ] do k = n, 1, -1 kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end do end if else ! solve a*x = b, where a = l*t*l**h. ! 1) forward substitution with l - if( n>1 ) then + if( n>1_${ik}$ ) then ! pivot, p**t * b -> b do k = 1, n kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end do ! compute l \ b -> b [ (l \p**t * b) ] - call stdlib_${ci}$trsm( 'L', 'L', 'N', 'U', n-1, nrhs, cone, a( 2, 1 ),lda, b(2, 1), & + call stdlib${ii}$_${ci}$trsm( 'L', 'L', 'N', 'U', n-1, nrhs, cone, a( 2_${ik}$, 1_${ik}$ ),lda, b(2_${ik}$, 1_${ik}$), & ldb) end if ! 2) solve with triangular matrix t ! compute t \ b -> b [ t \ (l \p**t * b) ] - call stdlib_${ci}$lacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1) - if( n>1 ) then - call stdlib_${ci}$lacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 1 ), 1) - call stdlib_${ci}$lacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 2*n ), 1) - call stdlib_${ci}$lacgv( n-1, work( 2*n ), 1 ) + call stdlib${ii}$_${ci}$lacpy( 'F', 1_${ik}$, n, a(1_${ik}$, 1_${ik}$), lda+1, work(n), 1_${ik}$) + if( n>1_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'F', 1_${ik}$, n-1, a( 2_${ik}$, 1_${ik}$ ), lda+1, work( 1_${ik}$ ), 1_${ik}$) + call stdlib${ii}$_${ci}$lacpy( 'F', 1_${ik}$, n-1, a( 2_${ik}$, 1_${ik}$ ), lda+1, work( 2_${ik}$*n ), 1_${ik}$) + call stdlib${ii}$_${ci}$lacgv( n-1, work( 2_${ik}$*n ), 1_${ik}$ ) end if - call stdlib_${ci}$gtsv(n, nrhs, work(1), work(n), work(2*n), b, ldb,info) + call stdlib${ii}$_${ci}$gtsv(n, nrhs, work(1_${ik}$), work(n), work(2_${ik}$*n), b, ldb,info) ! 3) backward substitution with l**h - if( n>1 ) then + if( n>1_${ik}$ ) then ! compute l**h \ b -> b [ l**h \ (t \ (l \p**t * b) ) ] - call stdlib_${ci}$trsm( 'L', 'L', 'C', 'U', n-1, nrhs, cone, a( 2, 1 ),lda, b( 2, 1 ),& + call stdlib${ii}$_${ci}$trsm( 'L', 'L', 'C', 'U', n-1, nrhs, cone, a( 2_${ik}$, 1_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),& ldb) ! pivot, p * b [ p * (l**h \ (t \ (l \p**t * b) )) ] do k = n, 1, -1 kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end do end if end if return - end subroutine stdlib_${ci}$hetrs_aa + end subroutine stdlib${ii}$_${ci}$hetrs_aa - pure subroutine stdlib_${ci}$hetrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) + pure subroutine stdlib${ii}$_${ci}$hetrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) !! ZHETRS_ROOK: solves a system of linear equations A*X = B with a complex !! Hermitian matrix A using the factorization A = U*D*U**H or !! A = L*D*L**H computed by ZHETRF_ROOK. @@ -30847,37 +30839,37 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), intent(in) :: a(lda,*) complex(${ck}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: j, k, kp + integer(${ik}$) :: j, k, kp real(${ck}$) :: s complex(${ck}$) :: ak, akm1, akm1k, bk, bkm1, denom ! Intrinsic Functions intrinsic :: conjg,max,real ! 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_${ci}$geru( k-1, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & + call stdlib${ii}$_${ci}$geru( k-1, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb & ) ! multiply by the inverse of the diagonal block. s = real( cone,KIND=${ck}$) / real( a( k, k ),KIND=${ck}$) - call stdlib_${ci}$dscal( nrhs, s, b( k, 1 ), ldb ) - k = k - 1 + call stdlib${ii}$_${ci}$dscal( nrhs, s, b( k, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ else ! 2 x 2 diagonal block ! interchange rows k and -ipiv(k), then k-1 and -ipiv(k-1) kp = -ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) kp = -ipiv( k-1) - if( kp/=k-1 )call stdlib_${ci}$swap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib${ii}$_${ci}$swap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - call stdlib_${ci}$geru( k-2, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & + call stdlib${ii}$_${ci}$geru( k-2, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb & ) - call stdlib_${ci}$geru( k-2, nrhs, -cone, a( 1, k-1 ), 1, b( k-1, 1 ),ldb, b( 1, 1 ), & + call stdlib${ii}$_${ci}$geru( k-2, nrhs, -cone, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), & ldb ) ! multiply by the inverse of the diagonal block. akm1k = a( k-1, k ) @@ -30928,51 +30920,51 @@ module stdlib_linalg_lapack_${ci}$ 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**h *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 = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(u**h(k)), where u(k) is the transformation ! stored in column k of a. - if( k>1 ) then - call stdlib_${ci}$lacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), & - 1, cone, b( k, 1 ), ldb ) - call stdlib_${ci}$lacgv( nrhs, b( k, 1 ), ldb ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), & + 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb ) end if ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 1 + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 1_${ik}$ else ! 2 x 2 diagonal block ! multiply by inv(u**h(k+1)), where u(k+1) is the transformation ! stored in columns k and k+1 of a. - if( k>1 ) then - call stdlib_${ci}$lacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), & - 1, cone, b( k, 1 ), ldb ) - call stdlib_${ci}$lacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_${ci}$lacgv( nrhs, b( k+1, 1 ), ldb ) - call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k+1 )& - , 1, cone, b( k+1, 1 ), ldb ) - call stdlib_${ci}$lacgv( nrhs, b( k+1, 1 ), ldb ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), & + 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$lacgv( nrhs, b( k+1, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k+1 )& + , 1_${ik}$, cone, b( k+1, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$lacgv( nrhs, 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_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) kp = -ipiv( k+1 ) - if( kp/=k+1 )call stdlib_${ci}$swap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 2 + if( kp/=k+1 )call stdlib${ii}$_${ci}$swap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 2_${ik}$ end if go to 40 50 continue @@ -30981,37 +30973,37 @@ module stdlib_linalg_lapack_${ci}$ ! 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 = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(l**h(k)), where l(k) is the transformation ! stored in column k of a. if( kn .or. ihimaxit )go to 180 @@ -31551,7 +31543,7 @@ module stdlib_linalg_lapack_${ci}$ go to 60 end if end if - if( abs( t( ilast, ilast ) )<=max( safmin, ulp*(abs( t( ilast - 1, ilast ) ) + abs( & + if( abs( t( ilast, ilast ) )<=max( safmin, ulp*(abs( t( ilast - 1_${ik}$, ilast ) ) + abs( & t( ilast-1, ilast-1 )) ) ) ) then t( ilast, ilast ) = czero go to 50 @@ -31571,8 +31563,8 @@ module stdlib_linalg_lapack_${ci}$ end if end if ! test 2: for t(j,j)=0 - temp = abs ( t( j, j + 1 ) ) - if ( j > ilo )temp = temp + abs ( t( j - 1, j ) ) + temp = abs ( t( j, j + 1_${ik}$ ) ) + if ( j > ilo )temp = temp + abs ( t( j - 1_${ik}$, j ) ) if( abs( t( j, j ) )=ilast ) then go to 60 else - ifirst = jch + 1 + ifirst = jch + 1_${ik}$ go to 70 end if end if @@ -31615,24 +31607,24 @@ module stdlib_linalg_lapack_${ci}$ ! then process as in the case t(ilast,ilast)=0 do jch = j, ilast - 1 ctemp = t( jch, jch+1 ) - call stdlib_${ci}$lartg( ctemp, t( jch+1, jch+1 ), c, s,t( jch, jch+1 ) ) + call stdlib${ii}$_${ci}$lartg( ctemp, t( jch+1, jch+1 ), c, s,t( jch, jch+1 ) ) t( jch+1, jch+1 ) = czero - if( jchzero ) then if( real( x / temp2,KIND=${ck}$)*real( y,KIND=${ck}$)+aimag( x / temp2 )*aimag( y )& safmin ) & + if( ( iiter / 20_${ik}$ )*20_${ik}$==iiter .and.bscale*abs1(t( ilast, ilast ))>safmin ) & then eshift = eshift + ( ascale*h( ilast,ilast ) )/( bscale*t( ilast, ilast ) ) @@ -31757,12 +31749,12 @@ module stdlib_linalg_lapack_${ci}$ ! do an implicit-shift qz sweep. ! initial q ctemp2 = ascale*h( istart+1, istart ) - call stdlib_${ci}$lartg( ctemp, ctemp2, c, s, ctemp3 ) + call stdlib${ii}$_${ci}$lartg( ctemp, ctemp2, c, s, ctemp3 ) ! sweep loop_150: do j = istart, ilast - 1 if( j>istart ) then ctemp = h( j, j-1 ) - call stdlib_${ci}$lartg( ctemp, h( j+1, j-1 ), c, s, h( j, j-1 ) ) + call stdlib${ii}$_${ci}$lartg( ctemp, h( j+1, j-1 ), c, s, h( j, j-1 ) ) h( j+1, j-1 ) = czero end if do jc = j, ilastm @@ -31781,7 +31773,7 @@ module stdlib_linalg_lapack_${ci}$ end do end if ctemp = t( j+1, j+1 ) - call stdlib_${ci}$lartg( ctemp, t( j+1, j ), c, s, t( j+1, j+1 ) ) + call stdlib${ii}$_${ci}$lartg( ctemp, t( j+1, j ), c, s, t( j+1, j+1 ) ) t( j+1, j ) = czero do jr = ifrstm, min( j+2, ilast ) ctemp = c*h( jr, j+1 ) + s*h( jr, j ) @@ -31816,12 +31808,12 @@ module stdlib_linalg_lapack_${ci}$ signbc = conjg( t( j, j ) / absb ) t( j, j ) = absb if( ilschr ) then - call stdlib_${ci}$scal( j-1, signbc, t( 1, j ), 1 ) - call stdlib_${ci}$scal( j, signbc, h( 1, j ), 1 ) + call stdlib${ii}$_${ci}$scal( j-1, signbc, t( 1_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$scal( j, signbc, h( 1_${ik}$, j ), 1_${ik}$ ) else - call stdlib_${ci}$scal( 1, signbc, h( j, j ), 1 ) + call stdlib${ii}$_${ci}$scal( 1_${ik}$, signbc, h( j, j ), 1_${ik}$ ) end if - if( ilz )call stdlib_${ci}$scal( n, signbc, z( 1, j ), 1 ) + if( ilz )call stdlib${ii}$_${ci}$scal( n, signbc, z( 1_${ik}$, j ), 1_${ik}$ ) else t( j, j ) = czero end if @@ -31829,15 +31821,15 @@ module stdlib_linalg_lapack_${ci}$ beta( j ) = t( j, j ) end do ! normal termination - info = 0 + info = 0_${ik}$ ! exit (other than argument error) -- return optimal workspace size 210 continue - work( 1 ) = cmplx( n,KIND=${ck}$) + work( 1_${ik}$ ) = cmplx( n,KIND=${ck}$) return - end subroutine stdlib_${ci}$hgeqz + end subroutine stdlib${ii}$_${ci}$hgeqz - pure subroutine stdlib_${ci}$hpcon( uplo, n, ap, ipiv, anorm, rcond, work, info ) + pure subroutine stdlib${ii}$_${ci}$hpcon( uplo, n, ap, ipiv, anorm, rcond, work, info ) !! ZHPCON: estimates the reciprocal of the condition number of a complex !! Hermitian packed matrix A using the factorization A = U*D*U**H or !! A = L*D*L**H computed by ZHPTRF. @@ -31848,40 +31840,40 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(${ck}$), intent(in) :: anorm real(${ck}$), intent(out) :: rcond ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) complex(${ck}$), intent(in) :: ap(*) complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: i, ip, kase + integer(${ik}$) :: i, ip, kase real(${ck}$) :: ainvnm ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! 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 + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ else if( anorm0 .and. ap( ip )==zero )return ip = ip - i end do else ! lower triangular storage: examine d from top to bottom. - ip = 1 + ip = 1_${ik}$ do i = 1, n if( ipiv( i )>0 .and. ap( ip )==zero )return - ip = ip + n - i + 1 + ip = ip + n - i + 1_${ik}$ end do end if ! estimate the 1-norm of the inverse. - kase = 0 + kase = 0_${ik}$ 30 continue - call stdlib_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + if( kase/=0_${ik}$ ) then ! multiply by inv(l*d*l**h) or inv(u*d*u**h). - call stdlib_${ci}$hptrs( uplo, n, 1, ap, ipiv, work, n, info ) + call stdlib${ii}$_${ci}$hptrs( uplo, n, 1_${ik}$, ap, ipiv, work, n, info ) go to 30 end if ! compute the estimate of the reciprocal condition number. if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm return - end subroutine stdlib_${ci}$hpcon + end subroutine stdlib${ii}$_${ci}$hpcon - subroutine stdlib_${ci}$hpev( jobz, uplo, n, ap, w, z, ldz, work, rwork,info ) + subroutine stdlib${ii}$_${ci}$hpev( jobz, uplo, n, ap, w, z, ldz, work, rwork,info ) !! ZHPEV: computes all the eigenvalues and, optionally, eigenvectors of a !! complex Hermitian matrix in packed storage. ! -- lapack driver routine -- @@ -31926,8 +31918,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldz, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldz, n ! Array Arguments real(${ck}$), intent(out) :: rwork(*), w(*) complex(${ck}$), intent(inout) :: ap(*) @@ -31936,86 +31928,86 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: wantz - integer(ilp) :: iinfo, imax, inde, indrwk, indtau, indwrk, iscale + integer(${ik}$) :: iinfo, imax, inde, indrwk, indtau, indwrk, iscale real(${ck}$) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! Intrinsic Functions intrinsic :: sqrt ! Executable Statements ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) - info = 0 + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( stdlib_lsame( uplo, 'L' ) .or. stdlib_lsame( uplo, 'U' ) ) )& then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldz<1 .or. ( wantz .and. ldzzero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then - call stdlib_${ci}$dscal( ( n*( n+1 ) ) / 2, sigma, ap, 1 ) + if( iscale==1_${ik}$ ) then + call stdlib${ii}$_${ci}$dscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ ) end if - ! call stdlib_${ci}$hptrd to reduce hermitian packed matrix to tridiagonal form. - inde = 1 - indtau = 1 - call stdlib_${ci}$hptrd( uplo, n, ap, w, rwork( inde ), work( indtau ),iinfo ) - ! for eigenvalues only, call stdlib_${c2ri(ci)}$sterf. for eigenvectors, first call - ! stdlib_${ci}$upgtr to generate the orthogonal matrix, then call stdlib_${ci}$steqr. + ! call stdlib${ii}$_${ci}$hptrd to reduce hermitian packed matrix to tridiagonal form. + inde = 1_${ik}$ + indtau = 1_${ik}$ + call stdlib${ii}$_${ci}$hptrd( uplo, n, ap, w, rwork( inde ), work( indtau ),iinfo ) + ! for eigenvalues only, call stdlib${ii}$_${c2ri(ci)}$sterf. for eigenvectors, first call + ! stdlib${ii}$_${ci}$upgtr to generate the orthogonal matrix, then call stdlib${ii}$_${ci}$steqr. if( .not.wantz ) then - call stdlib_${c2ri(ci)}$sterf( n, w, rwork( inde ), info ) + call stdlib${ii}$_${c2ri(ci)}$sterf( n, w, rwork( inde ), info ) else indwrk = indtau + n - call stdlib_${ci}$upgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo ) + call stdlib${ii}$_${ci}$upgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo ) indrwk = inde + n - call stdlib_${ci}$steqr( jobz, n, w, rwork( inde ), z, ldz,rwork( indrwk ), info ) + call stdlib${ii}$_${ci}$steqr( jobz, n, w, rwork( inde ), z, ldz,rwork( indrwk ), info ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = n else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_${c2ri(ci)}$scal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_${c2ri(ci)}$scal( imax, one / sigma, w, 1_${ik}$ ) end if return - end subroutine stdlib_${ci}$hpev + end subroutine stdlib${ii}$_${ci}$hpev - subroutine stdlib_${ci}$hpevd( jobz, uplo, n, ap, w, z, ldz, work, lwork,rwork, lrwork, iwork, & + subroutine stdlib${ii}$_${ci}$hpevd( jobz, uplo, n, ap, w, z, ldz, work, lwork,rwork, lrwork, iwork, & !! ZHPEVD: computes all the eigenvalues and, optionally, eigenvectors of !! a complex Hermitian matrix A in packed storage. If eigenvectors are !! desired, it uses a divide and conquer algorithm. @@ -32031,10 +32023,10 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldz, liwork, lrwork, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldz, liwork, lrwork, lwork, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(${ck}$), intent(out) :: rwork(*), w(*) complex(${ck}$), intent(inout) :: ap(*) complex(${ck}$), intent(out) :: work(*), z(ldz,*) @@ -32043,7 +32035,7 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: lquery, wantz - integer(ilp) :: iinfo, imax, inde, indrwk, indtau, indwrk, iscale, liwmin, llrwk, & + integer(${ik}$) :: iinfo, imax, inde, indrwk, indtau, indwrk, iscale, liwmin, llrwk, & llwrk, lrwmin, lwmin real(${ck}$) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! Intrinsic Functions @@ -32051,113 +32043,113 @@ module stdlib_linalg_lapack_${ci}$ ! Executable Statements ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) - lquery = ( lwork==-1 .or. lrwork==-1 .or. liwork==-1 ) - info = 0 + lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( stdlib_lsame( uplo, 'L' ) .or. stdlib_lsame( uplo, 'U' ) ) )& then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldz<1 .or. ( wantz .and. ldzzero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then - call stdlib_${ci}$dscal( ( n*( n+1 ) ) / 2, sigma, ap, 1 ) + if( iscale==1_${ik}$ ) then + call stdlib${ii}$_${ci}$dscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ ) end if - ! call stdlib_${ci}$hptrd to reduce hermitian packed matrix to tridiagonal form. - inde = 1 - indtau = 1 + ! call stdlib${ii}$_${ci}$hptrd to reduce hermitian packed matrix to tridiagonal form. + inde = 1_${ik}$ + indtau = 1_${ik}$ indrwk = inde + n indwrk = indtau + n - llwrk = lwork - indwrk + 1 - llrwk = lrwork - indrwk + 1 - call stdlib_${ci}$hptrd( uplo, n, ap, w, rwork( inde ), work( indtau ),iinfo ) - ! for eigenvalues only, call stdlib_${c2ri(ci)}$sterf. for eigenvectors, first call - ! stdlib_${ci}$upgtr to generate the orthogonal matrix, then call stdlib_${ci}$stedc. + llwrk = lwork - indwrk + 1_${ik}$ + llrwk = lrwork - indrwk + 1_${ik}$ + call stdlib${ii}$_${ci}$hptrd( uplo, n, ap, w, rwork( inde ), work( indtau ),iinfo ) + ! for eigenvalues only, call stdlib${ii}$_${c2ri(ci)}$sterf. for eigenvectors, first call + ! stdlib${ii}$_${ci}$upgtr to generate the orthogonal matrix, then call stdlib${ii}$_${ci}$stedc. if( .not.wantz ) then - call stdlib_${c2ri(ci)}$sterf( n, w, rwork( inde ), info ) + call stdlib${ii}$_${c2ri(ci)}$sterf( n, w, rwork( inde ), info ) else - call stdlib_${ci}$stedc( 'I', n, w, rwork( inde ), z, ldz, work( indwrk ),llwrk, rwork( & + call stdlib${ii}$_${ci}$stedc( 'I', n, w, rwork( inde ), z, ldz, work( indwrk ),llwrk, rwork( & indrwk ), llrwk, iwork, liwork,info ) - call stdlib_${ci}$upmtr( 'L', uplo, 'N', n, n, ap, work( indtau ), z, ldz,work( indwrk ),& + call stdlib${ii}$_${ci}$upmtr( 'L', uplo, 'N', n, n, ap, work( indtau ), z, ldz,work( indwrk ),& iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = n else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_${c2ri(ci)}$scal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_${c2ri(ci)}$scal( imax, one / sigma, w, 1_${ik}$ ) end if - work( 1 ) = lwmin - rwork( 1 ) = lrwmin - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = lwmin + rwork( 1_${ik}$ ) = lrwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_${ci}$hpevd + end subroutine stdlib${ii}$_${ci}$hpevd - subroutine stdlib_${ci}$hpevx( jobz, range, uplo, n, ap, vl, vu, il, iu,abstol, m, w, z, ldz, & + subroutine stdlib${ii}$_${ci}$hpevx( jobz, range, uplo, n, ap, vl, vu, il, iu,abstol, m, w, z, ldz, & !! ZHPEVX: computes selected eigenvalues and, optionally, eigenvectors !! of a complex Hermitian matrix A in packed storage. !! Eigenvalues/vectors can be selected by specifying either a range of @@ -32168,11 +32160,11 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range, uplo - integer(ilp), intent(in) :: il, iu, ldz, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, iu, ldz, n + integer(${ik}$), intent(out) :: info, m real(${ck}$), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: ifail(*), iwork(*) + integer(${ik}$), intent(out) :: ifail(*), iwork(*) real(${ck}$), intent(out) :: rwork(*), w(*) complex(${ck}$), intent(inout) :: ap(*) complex(${ck}$), intent(out) :: work(*), z(ldz,*) @@ -32182,7 +32174,7 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: alleig, indeig, test, valeig, wantz character :: order - integer(ilp) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwk, indrwk, & + integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwk, indrwk, & indtau, indwrk, iscale, itmp1, j, jj, nsplit real(${ck}$) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, & vuu @@ -32194,59 +32186,59 @@ module stdlib_linalg_lapack_${ci}$ alleig = stdlib_lsame( range, 'A' ) valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) - info = 0 + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( stdlib_lsame( uplo, 'L' ) .or. stdlib_lsame( uplo, 'U' ) ) )& then - info = -3 - else if( n<0 ) then - info = -4 + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ else if( valeig ) then - if( n>0 .and. vu<=vl )info = -7 + if( n>0_${ik}$ .and. vu<=vl )info = -7_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -8 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -8_${ik}$ else if( iun ) then - info = -9 + info = -9_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz=real( ap( 1 ),KIND=${ck}$) ) then - m = 1 - w( 1 ) = real( ap( 1 ),KIND=${ck}$) + if( vl=real( ap( 1_${ik}$ ),KIND=${ck}$) ) then + m = 1_${ik}$ + w( 1_${ik}$ ) = real( ap( 1_${ik}$ ),KIND=${ck}$) end if end if - if( wantz )z( 1, 1 ) = cone + if( wantz )z( 1_${ik}$, 1_${ik}$ ) = cone return end if ! get machine constants. - safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) - eps = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) ) ! scale matrix to allowable range, if necessary. - iscale = 0 + iscale = 0_${ik}$ abstll = abstol if( valeig ) then vll = vl @@ -32255,99 +32247,99 @@ module stdlib_linalg_lapack_${ci}$ vll = zero vuu = zero end if - anrm = stdlib_${ci}$lanhp( 'M', uplo, n, ap, rwork ) + anrm = stdlib${ii}$_${ci}$lanhp( 'M', uplo, n, ap, rwork ) if( anrm>zero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then - call stdlib_${ci}$dscal( ( n*( n+1 ) ) / 2, sigma, ap, 1 ) - if( abstol>0 )abstll = abstol*sigma + if( iscale==1_${ik}$ ) then + call stdlib${ii}$_${ci}$dscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ ) + if( abstol>0_${ik}$ )abstll = abstol*sigma if( valeig ) then vll = vl*sigma vuu = vu*sigma end if end if - ! call stdlib_${ci}$hptrd to reduce hermitian packed matrix to tridiagonal form. - indd = 1 + ! call stdlib${ii}$_${ci}$hptrd to reduce hermitian packed matrix to tridiagonal form. + indd = 1_${ik}$ inde = indd + n indrwk = inde + n - indtau = 1 + indtau = 1_${ik}$ indwrk = indtau + n - call stdlib_${ci}$hptrd( uplo, n, ap, rwork( indd ), rwork( inde ),work( indtau ), iinfo ) + call stdlib${ii}$_${ci}$hptrd( uplo, n, ap, rwork( indd ), rwork( inde ),work( indtau ), iinfo ) ! if all eigenvalues are desired and abstol is less than or equal - ! to zero, then call stdlib_${c2ri(ci)}$sterf or stdlib_${ci}$upgtr and stdlib_${ci}$steqr. if this fails - ! for some eigenvalue, then try stdlib_${c2ri(ci)}$stebz. + ! to zero, then call stdlib${ii}$_${c2ri(ci)}$sterf or stdlib${ii}$_${ci}$upgtr and stdlib${ii}$_${ci}$steqr. if this fails + ! for some eigenvalue, then try stdlib${ii}$_${c2ri(ci)}$stebz. test = .false. if (indeig) then - if (il==1 .and. iu==n) then + if (il==1_${ik}$ .and. iu==n) then test = .true. end if end if if ((alleig .or. test) .and. (abstol<=zero)) then - call stdlib_${c2ri(ci)}$copy( n, rwork( indd ), 1, w, 1 ) - indee = indrwk + 2*n + call stdlib${ii}$_${c2ri(ci)}$copy( n, rwork( indd ), 1_${ik}$, w, 1_${ik}$ ) + indee = indrwk + 2_${ik}$*n if( .not.wantz ) then - call stdlib_${c2ri(ci)}$copy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) - call stdlib_${c2ri(ci)}$sterf( n, w, rwork( indee ), info ) + call stdlib${ii}$_${c2ri(ci)}$copy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ ) + call stdlib${ii}$_${c2ri(ci)}$sterf( n, w, rwork( indee ), info ) else - call stdlib_${ci}$upgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo ) + call stdlib${ii}$_${ci}$upgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo ) - call stdlib_${c2ri(ci)}$copy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) - call stdlib_${ci}$steqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) + call stdlib${ii}$_${c2ri(ci)}$copy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$steqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) - if( info==0 ) then + if( info==0_${ik}$ ) then do i = 1, n - ifail( i ) = 0 + ifail( i ) = 0_${ik}$ end do end if end if - if( info==0 ) then + if( info==0_${ik}$ ) then m = n go to 20 end if - info = 0 + info = 0_${ik}$ end if - ! otherwise, call stdlib_${c2ri(ci)}$stebz and, if eigenvectors are desired, stdlib_${ci}$stein. + ! otherwise, call stdlib${ii}$_${c2ri(ci)}$stebz and, if eigenvectors are desired, stdlib${ii}$_${ci}$stein. if( wantz ) then order = 'B' else order = 'E' end if - indibl = 1 + indibl = 1_${ik}$ indisp = indibl + n indiwk = indisp + n - call stdlib_${c2ri(ci)}$stebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indd ), rwork( & + call stdlib${ii}$_${c2ri(ci)}$stebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indd ), rwork( & inde ), m, nsplit, w,iwork( indibl ), iwork( indisp ), rwork( indrwk ),iwork( indiwk ),& info ) if( wantz ) then - call stdlib_${ci}$stein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & + call stdlib${ii}$_${ci}$stein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,rwork( indrwk ), iwork( indiwk ), ifail, info ) ! apply unitary matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_${ci}$stein. + ! form to eigenvectors returned by stdlib${ii}$_${ci}$stein. indwrk = indtau + n - call stdlib_${ci}$upmtr( 'L', uplo, 'N', n, m, ap, work( indtau ), z, ldz,work( indwrk ),& + call stdlib${ii}$_${ci}$upmtr( 'L', uplo, 'N', n, m, ap, work( indtau ), z, ldz,work( indwrk ),& iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. 20 continue - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = m else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_${c2ri(ci)}$scal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_${c2ri(ci)}$scal( imax, one / sigma, w, 1_${ik}$ ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. if( wantz ) then do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp1 = w( j ) do jj = j + 1, m if( w( jj )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 + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'ZHPGST', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZHPGST', -info ) return end if - if( itype==1 ) then + if( itype==1_${ik}$ ) then if( upper ) then ! compute inv(u**h)*a*inv(u) ! j1 and jj are the indices of a(1,j) and a(j,j) - jj = 0 + 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 ap( jj ) = real( ap( jj ),KIND=${ck}$) bjj = real( bp( jj ),KIND=${ck}$) - call stdlib_${ci}$tpsv( uplo, 'CONJUGATE TRANSPOSE', 'NON-UNIT', j,bp, ap( j1 ), 1 & + call stdlib${ii}$_${ci}$tpsv( uplo, 'CONJUGATE TRANSPOSE', 'NON-UNIT', j,bp, ap( j1 ), 1_${ik}$ & ) - call stdlib_${ci}$hpmv( uplo, j-1, -cone, ap, bp( j1 ), 1, cone,ap( j1 ), 1 ) + call stdlib${ii}$_${ci}$hpmv( uplo, j-1, -cone, ap, bp( j1 ), 1_${ik}$, cone,ap( j1 ), 1_${ik}$ ) - call stdlib_${ci}$dscal( j-1, one / bjj, ap( j1 ), 1 ) - ap( jj ) = ( ap( jj )-stdlib_${ci}$dotc( j-1, ap( j1 ), 1, bp( j1 ),1 ) ) / & + call stdlib${ii}$_${ci}$dscal( j-1, one / bjj, ap( j1 ), 1_${ik}$ ) + ap( jj ) = ( ap( jj )-stdlib${ii}$_${ci}$dotc( j-1, ap( j1 ), 1_${ik}$, bp( j1 ),1_${ik}$ ) ) / & bjj end do else ! compute inv(l)*a*inv(l**h) ! 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 = real( ap( kk ),KIND=${ck}$) bkk = real( bp( kk ),KIND=${ck}$) - akk = akk / bkk**2 + akk = akk / bkk**2_${ik}$ ap( kk ) = akk if( k3 ) then - info = -1 + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( ldz<1 .or. ( wantz .and. ldz0 )neig = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )neig = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y if( upper ) then @@ -32569,9 +32561,9 @@ module stdlib_linalg_lapack_${ci}$ trans = 'C' end if do j = 1, neig - call stdlib_${ci}$tpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_${ci}$tpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**h *y if( upper ) then @@ -32580,15 +32572,15 @@ module stdlib_linalg_lapack_${ci}$ trans = 'N' end if do j = 1, neig - call stdlib_${ci}$tpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_${ci}$tpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do end if end if return - end subroutine stdlib_${ci}$hpgv + end subroutine stdlib${ii}$_${ci}$hpgv - subroutine stdlib_${ci}$hpgvd( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,lwork, rwork, lrwork,& + subroutine stdlib${ii}$_${ci}$hpgvd( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,lwork, rwork, lrwork,& !! ZHPGVD: computes all the eigenvalues and, optionally, the eigenvectors !! of a complex generalized Hermitian-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and @@ -32607,10 +32599,10 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: itype, ldz, liwork, lrwork, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: itype, ldz, liwork, lrwork, lwork, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(${ck}$), intent(out) :: rwork(*), w(*) complex(${ck}$), intent(inout) :: ap(*), bp(*) complex(${ck}$), intent(out) :: work(*), z(ldz,*) @@ -32618,55 +32610,55 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: lquery, upper, wantz character :: trans - integer(ilp) :: j, liwmin, lrwmin, lwmin, neig + integer(${ik}$) :: j, liwmin, lrwmin, lwmin, neig ! Intrinsic Functions intrinsic :: real,max ! Executable Statements ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) upper = stdlib_lsame( uplo, 'U' ) - lquery = ( lwork==-1 .or. lrwork==-1 .or. liwork==-1 ) - info = 0 - if( itype<1 .or. itype>3 ) then - info = -1 + lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( ldz<1 .or. ( wantz .and. ldz0 )neig = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )neig = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y if( upper ) then @@ -32699,9 +32691,9 @@ module stdlib_linalg_lapack_${ci}$ trans = 'C' end if do j = 1, neig - call stdlib_${ci}$tpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_${ci}$tpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**h *y if( upper ) then @@ -32710,18 +32702,18 @@ module stdlib_linalg_lapack_${ci}$ trans = 'N' end if do j = 1, neig - call stdlib_${ci}$tpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_${ci}$tpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do end if end if - work( 1 ) = lwmin - rwork( 1 ) = lrwmin - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = lwmin + rwork( 1_${ik}$ ) = lrwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_${ci}$hpgvd + end subroutine stdlib${ii}$_${ci}$hpgvd - subroutine stdlib_${ci}$hpgvx( itype, jobz, range, uplo, n, ap, bp, vl, vu,il, iu, abstol, m, w, & + subroutine stdlib${ii}$_${ci}$hpgvx( itype, jobz, range, uplo, n, ap, bp, vl, vu,il, iu, abstol, m, w, & !! ZHPGVX: computes selected eigenvalues and, optionally, eigenvectors !! of a complex generalized Hermitian-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and @@ -32735,11 +32727,11 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range, uplo - integer(ilp), intent(in) :: il, itype, iu, ldz, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, itype, iu, ldz, n + integer(${ik}$), intent(out) :: info, m real(${ck}$), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: ifail(*), iwork(*) + integer(${ik}$), intent(out) :: ifail(*), iwork(*) real(${ck}$), intent(out) :: rwork(*), w(*) complex(${ck}$), intent(inout) :: ap(*), bp(*) complex(${ck}$), intent(out) :: work(*), z(ldz,*) @@ -32747,7 +32739,7 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: alleig, indeig, upper, valeig, wantz character :: trans - integer(ilp) :: j + integer(${ik}$) :: j ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -32757,55 +32749,55 @@ module stdlib_linalg_lapack_${ci}$ alleig = stdlib_lsame( range, 'A' ) valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) - info = 0 - if( itype<1 .or. itype>3 ) then - info = -1 + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -3 + info = -3_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -4 - else if( n<0 ) then - info = -5 + info = -4_${ik}$ + else if( n<0_${ik}$ ) then + info = -5_${ik}$ else if( valeig ) then - if( n>0 .and. vu<=vl ) then - info = -9 + if( n>0_${ik}$ .and. vu<=vl ) then + info = -9_${ik}$ end if else if( indeig ) then - if( il<1 ) then - info = -10 + if( il<1_${ik}$ ) then + info = -10_${ik}$ else if( iun ) then - info = -11 + info = -11_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz0 )m = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )m = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y if( upper ) then @@ -32814,9 +32806,9 @@ module stdlib_linalg_lapack_${ci}$ trans = 'C' end if do j = 1, m - call stdlib_${ci}$tpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_${ci}$tpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**h *y if( upper ) then @@ -32825,15 +32817,15 @@ module stdlib_linalg_lapack_${ci}$ trans = 'N' end if do j = 1, m - call stdlib_${ci}$tpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_${ci}$tpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do end if end if return - end subroutine stdlib_${ci}$hpgvx + end subroutine stdlib${ii}$_${ci}$hpgvx - pure subroutine stdlib_${ci}$hprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,& + pure subroutine stdlib${ii}$_${ci}$hprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,& !! ZHPRFS: improves the computed solution to a system of linear !! equations when the coefficient matrix is Hermitian indefinite !! and packed, and provides error bounds and backward error estimates @@ -32844,17 +32836,17 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*) complex(${ck}$), intent(in) :: afp(*), ap(*), b(ldb,*) complex(${ck}$), intent(out) :: work(*) complex(${ck}$), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: itmax = 5 + integer(${ik}$), parameter :: itmax = 5_${ik}$ @@ -32862,11 +32854,11 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: upper - integer(ilp) :: count, i, ik, j, k, kase, kk, nz + integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz real(${ck}$) :: eps, lstres, s, safe1, safe2, safmin, xk complex(${ck}$) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,aimag,max ! Statement Functions @@ -32875,25 +32867,25 @@ module stdlib_linalg_lapack_${ci}$ cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! 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( nrhs<0 ) then - info = -3 - else if( ldbeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_${ci}$hptrs( uplo, n, 1, afp, ipiv, work, n, info ) - call stdlib_${ci}$axpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_${ci}$hptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info ) + call stdlib${ii}$_${ci}$axpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -33000,22 +32992,22 @@ module stdlib_linalg_lapack_${ci}$ rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**h). - call stdlib_${ci}$hptrs( uplo, n, 1, afp, ipiv, work, n, info ) + call stdlib${ii}$_${ci}$hptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do - else if( kase==2 ) then + else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_${ci}$hptrs( uplo, n, 1, afp, ipiv, work, n, info ) + call stdlib${ii}$_${ci}$hptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info ) end if go to 100 end if @@ -33027,10 +33019,10 @@ module stdlib_linalg_lapack_${ci}$ if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_${ci}$hprfs + end subroutine stdlib${ii}$_${ci}$hprfs - pure subroutine stdlib_${ci}$hpsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) + pure subroutine stdlib${ii}$_${ci}$hpsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) !! ZHPSV: computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N Hermitian matrix stored in packed format and X @@ -33047,41 +33039,41 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(${ck}$), intent(inout) :: ap(*), b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .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( ldb0 )then + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_${ci}$lanhp( 'I', uplo, n, ap, rwork ) + anorm = stdlib${ii}$_${ci}$lanhp( 'I', uplo, n, ap, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_${ci}$hpcon( uplo, n, afp, ipiv, anorm, rcond, work, info ) + call stdlib${ii}$_${ci}$hpcon( uplo, n, afp, ipiv, anorm, rcond, work, info ) ! compute the solution vectors x. - call stdlib_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_${ci}$hptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info ) + call stdlib${ii}$_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_${ci}$hptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_${ci}$hprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, & + call stdlib${ii}$_${ci}$hprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, & rwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond1 ) then - imax = stdlib_i${ci}$amax( k-1, ap( kc ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_i${ci}$amax( k-1, ap( kc ), 1_${ik}$ ) colmax = cabs1( 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 ap( kc+k-1 ) = real( ap( kc+k-1 ),KIND=${ck}$) else @@ -33347,7 +33339,7 @@ module stdlib_linalg_lapack_${ci}$ ! element in row imax, and rowmax is its absolute value rowmax = zero jmax = imax - kx = imax*( imax+1 ) / 2 + imax + kx = imax*( imax+1 ) / 2_${ik}$ + imax do j = imax + 1, k if( cabs1( ap( kx ) )>rowmax ) then rowmax = cabs1( ap( kx ) ) @@ -33355,9 +33347,9 @@ module stdlib_linalg_lapack_${ci}$ end if kx = kx + j end do - kpc = ( imax-1 )*imax / 2 + 1 - if( imax>1 ) then - jmax = stdlib_i${ci}$amax( imax-1, ap( kpc ), 1 ) + kpc = ( imax-1 )*imax / 2_${ik}$ + 1_${ik}$ + if( imax>1_${ik}$ ) then + jmax = stdlib${ii}$_i${ci}$amax( imax-1, ap( kpc ), 1_${ik}$ ) rowmax = max( rowmax, cabs1( ap( kpc+jmax-1 ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then @@ -33371,18 +33363,18 @@ module stdlib_linalg_lapack_${ci}$ ! interchange rows and columns k-1 and imax, use 2-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_${ci}$swap( kp-1, ap( knc ), 1, ap( kpc ), 1 ) - kx = kpc + kp - 1 + call stdlib${ii}$_${ci}$swap( 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 = conjg( ap( knc+j-1 ) ) ap( knc+j-1 ) = conjg( ap( kx ) ) ap( kx ) = t @@ -33391,7 +33383,7 @@ module stdlib_linalg_lapack_${ci}$ r1 = real( ap( knc+kk-1 ),KIND=${ck}$) ap( knc+kk-1 ) = real( ap( kpc+kp-1 ),KIND=${ck}$) ap( kpc+kp-1 ) = r1 - if( kstep==2 ) then + if( kstep==2_${ik}$ ) then ap( kc+k-1 ) = real( ap( kc+k-1 ),KIND=${ck}$) t = ap( kc+k-2 ) ap( kc+k-2 ) = ap( kc+kp-1 ) @@ -33399,19 +33391,19 @@ module stdlib_linalg_lapack_${ci}$ end if else ap( kc+k-1 ) = real( ap( kc+k-1 ),KIND=${ck}$) - if( kstep==2 )ap( kc-1 ) = real( ap( kc-1 ),KIND=${ck}$) + if( kstep==2_${ik}$ )ap( kc-1 ) = real( ap( kc-1 ),KIND=${ck}$) end if ! update the leading submatrix - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u ! perform a rank-1 update of a(1:k-1,1:k-1) as ! a := a - u(k)*d(k)*u(k)**h = a - w(k)*1/d(k)*w(k)**h r1 = one / real( ap( kc+k-1 ),KIND=${ck}$) - call stdlib_${ci}$hpr( uplo, k-1, -r1, ap( kc ), 1, ap ) + call stdlib${ii}$_${ci}$hpr( uplo, k-1, -r1, ap( kc ), 1_${ik}$, ap ) ! store u(k) in column k - call stdlib_${ci}$dscal( k-1, r1, ap( kc ), 1 ) + call stdlib${ii}$_${ci}$dscal( k-1, r1, ap( kc ), 1_${ik}$ ) else ! 2-by-2 pivot block d(k): columns k and k-1 now hold ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k) @@ -33420,33 +33412,33 @@ module stdlib_linalg_lapack_${ci}$ ! perform a rank-2 update of a(1:k-2,1:k-2) as ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**h ! = a - ( w(k-1) w(k) )*inv(d(k))*( w(k-1) w(k) )**h - if( k>2 ) then - d = stdlib_${c2ri(ci)}$lapy2( real( ap( k-1+( k-1 )*k / 2 ),KIND=${ck}$),aimag( ap( k-1+( & - k-1 )*k / 2 ) ) ) - d22 = real( ap( k-1+( k-2 )*( k-1 ) / 2 ),KIND=${ck}$) / d - d11 = real( ap( k+( k-1 )*k / 2 ),KIND=${ck}$) / d + if( k>2_${ik}$ ) then + d = stdlib${ii}$_${c2ri(ci)}$lapy2( real( ap( k-1+( k-1 )*k / 2_${ik}$ ),KIND=${ck}$),aimag( ap( k-1+( & + k-1 )*k / 2_${ik}$ ) ) ) + d22 = real( ap( k-1+( k-2 )*( k-1 ) / 2_${ik}$ ),KIND=${ck}$) / d + d11 = real( ap( k+( k-1 )*k / 2_${ik}$ ),KIND=${ck}$) / d tt = one / ( d11*d22-one ) - d12 = ap( k-1+( k-1 )*k / 2 ) / d + d12 = ap( k-1+( k-1 )*k / 2_${ik}$ ) / d d = tt / d do j = k - 2, 1, -1 - wkm1 = d*( d11*ap( j+( k-2 )*( k-1 ) / 2 )-conjg( d12 )*ap( j+( k-1 )*k & - / 2 ) ) - wk = d*( d22*ap( j+( k-1 )*k / 2 )-d12*ap( j+( k-2 )*( k-1 ) / 2 ) ) + wkm1 = d*( d11*ap( j+( k-2 )*( k-1 ) / 2_${ik}$ )-conjg( d12 )*ap( j+( k-1 )*k & + / 2_${ik}$ ) ) + wk = d*( d22*ap( j+( k-1 )*k / 2_${ik}$ )-d12*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 )& - *conjg( wk ) -ap( i+( k-2 )*( k-1 ) / 2 )*conjg( wkm1 ) + ap( i+( j-1 )*j / 2_${ik}$ ) = ap( i+( j-1 )*j / 2_${ik}$ ) -ap( i+( k-1 )*k / 2_${ik}$ )& + *conjg( wk ) -ap( i+( k-2 )*( k-1 ) / 2_${ik}$ )*conjg( wkm1 ) end do - ap( j+( k-1 )*k / 2 ) = wk - ap( j+( k-2 )*( k-1 ) / 2 ) = wkm1 - ap( j+( j-1 )*j / 2 ) = cmplx( real( ap( j+( j-1 )*j / 2 ),KIND=${ck}$), & + ap( j+( k-1 )*k / 2_${ik}$ ) = wk + ap( j+( k-2 )*( k-1 ) / 2_${ik}$ ) = wkm1 + ap( j+( j-1 )*j / 2_${ik}$ ) = cmplx( real( ap( j+( j-1 )*j / 2_${ik}$ ),KIND=${ck}$), & zero,KIND=${ck}$) 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 @@ -33460,28 +33452,28 @@ module stdlib_linalg_lapack_${ci}$ ! factorize a as l*d*l**h using the lower triangle of a ! k is the main loop index, increasing from 1 to n in steps of ! 1 or 2 - k = 1 - kc = 1 - npp = n*( n+1 ) / 2 + 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 absakk = abs( real( ap( kc ),KIND=${ck}$) ) ! imax is the row-index of the largest off-diagonal element in ! column k, and colmax is its absolute value if( k=alpha*colmax*( colmax / rowmax ) ) then @@ -33516,19 +33508,19 @@ module stdlib_linalg_lapack_${ci}$ ! interchange rows and columns k+1 and imax, use 2-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 )==czero )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 )==czero )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**h. ! 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 = 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. ap( kc+k-1 ) = one / real( ap( kc+k-1 ),KIND=${ck}$) ! compute column k of the inverse. - if( k>1 ) then - call stdlib_${ci}$copy( k-1, ap( kc ), 1, work, 1 ) - call stdlib_${ci}$hpmv( uplo, k-1, -cone, ap, work, 1, czero,ap( kc ), 1 ) - ap( kc+k-1 ) = ap( kc+k-1 ) -real( stdlib_${ci}$dotc( k-1, work, 1, ap( kc ), 1 ),& + if( k>1_${ik}$ ) then + call stdlib${ii}$_${ci}$copy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$hpmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kc ), 1_${ik}$ ) + ap( kc+k-1 ) = ap( kc+k-1 ) -real( stdlib${ii}$_${ci}$dotc( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ ),& KIND=${ck}$) end if - kstep = 1 + kstep = 1_${ik}$ else ! 2 x 2 diagonal block ! invert the diagonal block. @@ -33704,31 +33696,31 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$copy( k-1, ap( kc ), 1, work, 1 ) - call stdlib_${ci}$hpmv( uplo, k-1, -cone, ap, work, 1, czero,ap( kc ), 1 ) - ap( kc+k-1 ) = ap( kc+k-1 ) -real( stdlib_${ci}$dotc( k-1, work, 1, ap( kc ), 1 ),& + if( k>1_${ik}$ ) then + call stdlib${ii}$_${ci}$copy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$hpmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kc ), 1_${ik}$ ) + ap( kc+k-1 ) = ap( kc+k-1 ) -real( stdlib${ii}$_${ci}$dotc( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ ),& KIND=${ck}$) - ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib_${ci}$dotc( k-1, ap( kc ), 1, ap( & - kcnext ),1 ) - call stdlib_${ci}$copy( k-1, ap( kcnext ), 1, work, 1 ) - call stdlib_${ci}$hpmv( uplo, k-1, -cone, ap, work, 1, czero,ap( kcnext ), 1 ) + ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib${ii}$_${ci}$dotc( k-1, ap( kc ), 1_${ik}$, ap( & + kcnext ),1_${ik}$ ) + call stdlib${ii}$_${ci}$copy( k-1, ap( kcnext ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$hpmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kcnext ), 1_${ik}$ ) - ap( kcnext+k ) = ap( kcnext+k ) -real( stdlib_${ci}$dotc( k-1, work, 1, ap( kcnext & - ),1 ),KIND=${ck}$) + ap( kcnext+k ) = ap( kcnext+k ) -real( stdlib${ii}$_${ci}$dotc( k-1, work, 1_${ik}$, ap( kcnext & + ),1_${ik}$ ),KIND=${ck}$) 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_${ci}$swap( kp-1, ap( kc ), 1, ap( kpc ), 1 ) - kx = kpc + kp - 1 + kpc = ( kp-1 )*kp / 2_${ik}$ + 1_${ik}$ + call stdlib${ii}$_${ci}$swap( kp-1, ap( kc ), 1_${ik}$, ap( kpc ), 1_${ik}$ ) + kx = kpc + kp - 1_${ik}$ do j = kp + 1, k - 1 - kx = kx + j - 1 + kx = kx + j - 1_${ik}$ temp = conjg( ap( kc+j-1 ) ) ap( kc+j-1 ) = conjg( ap( kx ) ) ap( kx ) = temp @@ -33737,7 +33729,7 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -33751,26 +33743,26 @@ module stdlib_linalg_lapack_${ci}$ ! compute inv(a) from the factorization a = l*d*l**h. ! 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 + 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. ap( kc ) = one / real( ap( kc ),KIND=${ck}$) ! compute column k of the inverse. if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_${ci}$geru( k-1, nrhs, -cone, ap( kc ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb ) + call stdlib${ii}$_${ci}$geru( k-1, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb ) ! multiply by the inverse of the diagonal block. s = real( cone,KIND=${ck}$) / real( ap( kc+k-1 ),KIND=${ck}$) - call stdlib_${ci}$dscal( nrhs, s, b( k, 1 ), ldb ) - k = k - 1 + call stdlib${ii}$_${ci}$dscal( nrhs, s, b( k, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( kp/=k-1 )call stdlib_${ci}$swap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib${ii}$_${ci}$swap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - call stdlib_${ci}$geru( k-2, nrhs, -cone, ap( kc ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb ) + call stdlib${ii}$_${ci}$geru( k-2, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb ) - call stdlib_${ci}$geru( k-2, nrhs, -cone, ap( kc-( k-1 ) ), 1,b( k-1, 1 ), ldb, b( 1, & - 1 ), ldb ) + call stdlib${ii}$_${ci}$geru( k-2, nrhs, -cone, ap( kc-( k-1 ) ), 1_${ik}$,b( k-1, 1_${ik}$ ), ldb, b( 1_${ik}$, & + 1_${ik}$ ), ldb ) ! multiply by the inverse of the diagonal block. akm1k = ap( kc+k-2 ) akm1 = ap( kc-1 ) / akm1k @@ -33920,53 +33912,53 @@ module stdlib_linalg_lapack_${ci}$ 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**h *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 = 1_${ik}$ + kc = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(u**h(k)), where u(k) is the transformation ! stored in column k of a. - if( k>1 ) then - call stdlib_${ci}$lacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc ), & - 1, cone, b( k, 1 ), ldb ) - call stdlib_${ci}$lacgv( nrhs, b( k, 1 ), ldb ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc ), & + 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb ) end if ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) kc = kc + k - k = k + 1 + k = k + 1_${ik}$ else ! 2 x 2 diagonal block ! multiply by inv(u**h(k+1)), where u(k+1) is the transformation ! stored in columns k and k+1 of a. - if( k>1 ) then - call stdlib_${ci}$lacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc ), & - 1, cone, b( k, 1 ), ldb ) - call stdlib_${ci}$lacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_${ci}$lacgv( nrhs, b( k+1, 1 ), ldb ) - call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc+k ),& - 1, cone, b( k+1, 1 ), ldb ) - call stdlib_${ci}$lacgv( nrhs, b( k+1, 1 ), ldb ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc ), & + 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$lacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$lacgv( nrhs, b( k+1, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc+k ),& + 1_${ik}$, cone, b( k+1, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$lacgv( nrhs, b( k+1, 1_${ik}$ ), ldb ) end if ! interchange rows k and -ipiv(k). kp = -ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - kc = kc + 2*k + 1 - k = k + 2 + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + kc = kc + 2_${ik}$*k + 1_${ik}$ + k = k + 2_${ik}$ end if go to 40 50 continue @@ -33975,37 +33967,37 @@ module stdlib_linalg_lapack_${ci}$ ! 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 = 1_${ik}$ + kc = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(l**h(k)), where l(k) is the transformation ! stored in column k of a. if( krzero ) then eps3 = hnorm*ulp @@ -34214,13 +34206,13 @@ module stdlib_linalg_lapack_${ci}$ w( k ) = wk if( leftv ) then ! compute left eigenvector. - call stdlib_${ci}$laein( .false., noinit, n-kl+1, h( kl, kl ), ldh,wk, vl( kl, ks )& + call stdlib${ii}$_${ci}$laein( .false., noinit, n-kl+1, h( kl, kl ), ldh,wk, vl( kl, ks )& , work, ldwork, rwork, eps3,smlnum, iinfo ) - if( iinfo>0 ) then - info = info + 1 + if( iinfo>0_${ik}$ ) then + info = info + 1_${ik}$ ifaill( ks ) = k else - ifaill( ks ) = 0 + ifaill( ks ) = 0_${ik}$ end if do i = 1, kl - 1 vl( i, ks ) = czero @@ -34228,26 +34220,26 @@ module stdlib_linalg_lapack_${ci}$ end if if( rightv ) then ! compute right eigenvector. - call stdlib_${ci}$laein( .true., noinit, kr, h, ldh, wk, vr( 1, ks ),work, ldwork, & + call stdlib${ii}$_${ci}$laein( .true., noinit, kr, h, ldh, wk, vr( 1_${ik}$, ks ),work, ldwork, & rwork, eps3, smlnum, iinfo ) - if( iinfo>0 ) then - info = info + 1 + if( iinfo>0_${ik}$ ) then + info = info + 1_${ik}$ ifailr( ks ) = k else - ifailr( ks ) = 0 + ifailr( ks ) = 0_${ik}$ end if do i = kr + 1, n vr( i, ks ) = czero end do end if - ks = ks + 1 + ks = ks + 1_${ik}$ end if end do loop_100 return - end subroutine stdlib_${ci}$hsein + end subroutine stdlib${ii}$_${ci}$hsein - pure subroutine stdlib_${ci}$hseqr( job, compz, n, ilo, ihi, h, ldh, w, z, ldz,work, lwork, info ) + pure subroutine stdlib${ii}$_${ci}$hseqr( job, compz, n, ilo, ihi, h, ldh, w, z, ldz,work, lwork, info ) !! ZHSEQR: computes the eigenvalues of a Hessenberg matrix H !! and, optionally, the matrices T and Z from the Schur decomposition !! H = Z T Z**H, where T is an upper triangular matrix (the @@ -34261,24 +34253,24 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, ldh, ldz, lwork, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ilo, ldh, ldz, lwork, n + integer(${ik}$), intent(out) :: info character, intent(in) :: compz, job ! Array Arguments complex(${ck}$), intent(inout) :: h(ldh,*), z(ldz,*) complex(${ck}$), intent(out) :: w(*), work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: ntiny = 15 - integer(ilp), parameter :: nl = 49 + integer(${ik}$), parameter :: ntiny = 15_${ik}$ + integer(${ik}$), parameter :: nl = 49_${ik}$ real(${ck}$), parameter :: rzero = 0.0_${ck}$ ! ==== matrices of order ntiny or smaller must be processed by - ! . stdlib_${ci}$lahqr because of insufficient subdiagonal scratch space. + ! . stdlib${ii}$_${ci}$lahqr because of insufficient subdiagonal scratch space. ! . (this is a hard limit.) ==== ! ==== nl allocates some local workspace to help small matrices - ! . through a rare stdlib_${ci}$lahqr failure. nl > ntiny = 15 is - ! . required and nl <= nmin = stdlib_ilaenv(ispec=12,...) is recom- + ! . through a rare stdlib${ii}$_${ci}$lahqr failure. nl > ntiny = 15 is + ! . required and nl <= nmin = stdlib${ii}$_ilaenv(ispec=12,...) is recom- ! . mended. (the default value of nmin is 75.) using nl = 49 ! . allows up to six simultaneous shifts and a 16-by-16 ! . deflation window. ==== @@ -34288,7 +34280,7 @@ module stdlib_linalg_lapack_${ci}$ ! Local Arrays complex(${ck}$) :: hl(nl,nl), workl(nl) ! Local Scalars - integer(ilp) :: kbot, nmin + integer(${ik}$) :: kbot, nmin logical(lk) :: initz, lquery, wantt, wantz ! Intrinsic Functions intrinsic :: real,cmplx,max,min @@ -34297,102 +34289,102 @@ module stdlib_linalg_lapack_${ci}$ wantt = stdlib_lsame( job, 'S' ) initz = stdlib_lsame( compz, 'I' ) wantz = initz .or. stdlib_lsame( compz, 'V' ) - work( 1 ) = cmplx( real( max( 1, n ),KIND=${ck}$), rzero,KIND=${ck}$) - lquery = lwork==-1 - info = 0 + work( 1_${ik}$ ) = cmplx( real( max( 1_${ik}$, n ),KIND=${ck}$), rzero,KIND=${ck}$) + lquery = lwork==-1_${ik}$ + info = 0_${ik}$ if( .not.stdlib_lsame( job, 'E' ) .and. .not.wantt ) then - info = -1 + info = -1_${ik}$ else if( .not.stdlib_lsame( compz, 'N' ) .and. .not.wantz ) 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( ldh1 )call stdlib_${ci}$copy( ilo-1, h, ldh+1, w, 1 ) - if( ihi1_${ik}$ )call stdlib${ii}$_${ci}$copy( ilo-1, h, ldh+1, w, 1_${ik}$ ) + if( ihinmin ) then - call stdlib_${ci}$laqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,z, ldz, work, & + call stdlib${ii}$_${ci}$laqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,z, ldz, work, & lwork, info ) else ! ==== small matrix ==== - call stdlib_${ci}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,z, ldz, info ) + call stdlib${ii}$_${ci}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,z, ldz, info ) - if( info>0 ) then - ! ==== a rare stdlib_${ci}$lahqr failure! stdlib_${ci}$laqr0 sometimes succeeds - ! . when stdlib_${ci}$lahqr fails. ==== + if( info>0_${ik}$ ) then + ! ==== a rare stdlib${ii}$_${ci}$lahqr failure! stdlib${ii}$_${ci}$laqr0 sometimes succeeds + ! . when stdlib${ii}$_${ci}$lahqr fails. ==== kbot = info if( n>=nl ) then ! ==== larger matrices have enough subdiagonal scratch - ! . space to call stdlib_${ci}$laqr0 directly. ==== - call stdlib_${ci}$laqr0( wantt, wantz, n, ilo, kbot, h, ldh, w,ilo, ihi, z, ldz,& + ! . space to call stdlib${ii}$_${ci}$laqr0 directly. ==== + call stdlib${ii}$_${ci}$laqr0( wantt, wantz, n, ilo, kbot, h, ldh, w,ilo, ihi, z, ldz,& work, lwork, info ) else ! ==== tiny matrices don't have enough subdiagonal - ! . scratch space to benefit from stdlib_${ci}$laqr0. hence, + ! . scratch space to benefit from stdlib${ii}$_${ci}$laqr0. hence, ! . tiny matrices must be copied into a larger - ! . array before calling stdlib_${ci}$laqr0. ==== - call stdlib_${ci}$lacpy( 'A', n, n, h, ldh, hl, nl ) + ! . array before calling stdlib${ii}$_${ci}$laqr0. ==== + call stdlib${ii}$_${ci}$lacpy( 'A', n, n, h, ldh, hl, nl ) hl( n+1, n ) = czero - call stdlib_${ci}$laset( 'A', nl, nl-n, czero, czero, hl( 1, n+1 ),nl ) - call stdlib_${ci}$laqr0( wantt, wantz, nl, ilo, kbot, hl, nl, w,ilo, ihi, z, & + call stdlib${ii}$_${ci}$laset( 'A', nl, nl-n, czero, czero, hl( 1_${ik}$, n+1 ),nl ) + call stdlib${ii}$_${ci}$laqr0( wantt, wantz, nl, ilo, kbot, hl, nl, w,ilo, ihi, z, & ldz, workl, nl, info ) - if( wantt .or. info/=0 )call stdlib_${ci}$lacpy( 'A', n, n, hl, nl, h, ldh ) + if( wantt .or. info/=0_${ik}$ )call stdlib${ii}$_${ci}$lacpy( 'A', n, n, hl, nl, h, ldh ) end if end if end if ! ==== clear out the trash, if necessary. ==== - if( ( wantt .or. info/=0 ) .and. n>2 )call stdlib_${ci}$laset( 'L', n-2, n-2, czero, & - czero, h( 3, 1 ), ldh ) + if( ( wantt .or. info/=0_${ik}$ ) .and. n>2_${ik}$ )call stdlib${ii}$_${ci}$laset( 'L', n-2, n-2, czero, & + czero, h( 3_${ik}$, 1_${ik}$ ), ldh ) ! ==== ensure reported workspace size is backward-compatible with ! . previous lapack versions. ==== - work( 1 ) = cmplx( max( real( max( 1, n ),KIND=${ck}$),real( work( 1 ),KIND=${ck}$) ), & + work( 1_${ik}$ ) = cmplx( max( real( max( 1_${ik}$, n ),KIND=${ck}$),real( work( 1_${ik}$ ),KIND=${ck}$) ), & rzero,KIND=${ck}$) end if - end subroutine stdlib_${ci}$hseqr + end subroutine stdlib${ii}$_${ci}$hseqr - subroutine stdlib_${ci}$la_gbamv( trans, m, n, kl, ku, alpha, ab, ldab, x,incx, beta, y, incy ) + subroutine stdlib${ii}$_${ci}$la_gbamv( trans, m, n, kl, ku, alpha, ab, ldab, x,incx, beta, y, incy ) !! ZLA_GBAMV: performs one of the matrix-vector operations !! y := alpha*abs(A)*abs(x) + beta*abs(y), !! or y := alpha*abs(A)**T*abs(x) + beta*abs(y), @@ -34412,7 +34404,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(${ck}$), 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 complex(${ck}$), intent(in) :: ab(ldab,*), x(*) real(${ck}$), intent(inout) :: y(*) @@ -34421,7 +34413,7 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: symb_wero real(${ck}$) :: 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 complex(${ck}$) :: cdum ! Intrinsic Functions intrinsic :: max,abs,real,aimag,sign @@ -34431,63 +34423,63 @@ module stdlib_linalg_lapack_${ci}$ cabs1( cdum ) = abs( real( cdum,KIND=${ck}$) ) + abs( aimag( cdum ) ) ! 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_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + safe1 = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safe1 = (n+1)*safe1 ! form y := alpha*abs(a)*abs(x) + beta*abs(y). ! the o(m*n) symb_wero tests could be replaced by o(n) queries to ! 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 == czero ) then symb_wero = .true. @@ -34533,7 +34525,7 @@ module stdlib_linalg_lapack_${ci}$ end do end if else - if( trans==stdlib_ilatrans( 'N' ) )then + if( trans==stdlib${ii}$_ilatrans( 'N' ) )then do i = 1, leny if ( beta == czero ) then symb_wero = .true. @@ -34584,10 +34576,10 @@ module stdlib_linalg_lapack_${ci}$ end if end if return - end subroutine stdlib_${ci}$la_gbamv + end subroutine stdlib${ii}$_${ci}$la_gbamv - real(${ck}$) function stdlib_${ci}$la_gbrcond_c( trans, n, kl, ku, ab,ldab, afb, ldafb, ipiv,c, & + real(${ck}$) function stdlib${ii}$_${ci}$la_gbrcond_c( trans, n, kl, ku, ab,ldab, afb, ldafb, ipiv,c, & !! ZLA_GBRCOND_C: Computes the infinity norm condition number of !! op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector. capply, info, work,rwork ) @@ -34597,11 +34589,11 @@ module stdlib_linalg_lapack_${ci}$ ! Scalar Arguments character, intent(in) :: trans logical(lk), intent(in) :: capply - integer(ilp), intent(in) :: n, kl, ku, ldab, ldafb - integer(ilp) :: kd, ke - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n, kl, ku, ldab, ldafb + integer(${ik}$) :: kd, ke + integer(${ik}$), intent(out) :: info ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) complex(${ck}$), intent(in) :: ab(ldab,*), afb(ldafb,*) complex(${ck}$), intent(out) :: work(*) real(${ck}$), intent(in) :: c(*) @@ -34609,11 +34601,11 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! Local Scalars logical(lk) :: notrans - integer(ilp) :: kase, i, j + integer(${ik}$) :: kase, i, j real(${ck}$) :: ainvnm, anorm, tmp complex(${ck}$) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,max ! Statement Functions @@ -34621,31 +34613,31 @@ module stdlib_linalg_lapack_${ci}$ ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements - stdlib_${ci}$la_gbrcond_c = zero - info = 0 + stdlib${ii}$_${ci}$la_gbrcond_c = 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_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + safe1 = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safe1 = (n+1)*safe1 ! form y := alpha*abs(a)*abs(x) + beta*abs(y). ! the o(m*n) symb_wero tests could be replaced by o(n) queries to ! 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 == czero ) then symb_wero = .true. @@ -34915,7 +34907,7 @@ module stdlib_linalg_lapack_${ci}$ end do end if else - if( trans==stdlib_ilatrans( 'N' ) )then + if( trans==stdlib${ii}$_ilatrans( 'N' ) )then do i = 1, leny if ( beta == czero ) then symb_wero = .true. @@ -34966,10 +34958,10 @@ module stdlib_linalg_lapack_${ci}$ end if end if return - end subroutine stdlib_${ci}$la_geamv + end subroutine stdlib${ii}$_${ci}$la_geamv - real(${ck}$) function stdlib_${ci}$la_gercond_c( trans, n, a, lda, af,ldaf, ipiv, c, capply,info, & + real(${ck}$) function stdlib${ii}$_${ci}$la_gercond_c( trans, n, a, lda, af,ldaf, ipiv, c, capply,info, & !! ZLA_GERCOND_C: computes the infinity norm condition number of !! op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector. work, rwork ) @@ -34979,10 +34971,10 @@ module stdlib_linalg_lapack_${ci}$ ! Scalar Arguments character, intent(in) :: trans logical(lk), intent(in) :: capply - integer(ilp), intent(in) :: n, lda, ldaf - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n, lda, ldaf + integer(${ik}$), intent(out) :: info ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) complex(${ck}$), intent(in) :: a(lda,*), af(ldaf,*) complex(${ck}$), intent(out) :: work(*) real(${ck}$), intent(in) :: c(*) @@ -34990,11 +34982,11 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! Local Scalars logical(lk) :: notrans - integer(ilp) :: kase, i, j + integer(${ik}$) :: kase, i, j real(${ck}$) :: ainvnm, anorm, tmp complex(${ck}$) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,real,aimag ! Statement Functions @@ -35002,21 +34994,21 @@ module stdlib_linalg_lapack_${ci}$ ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements - stdlib_${ci}$la_gercond_c = zero - info = 0 + stdlib${ii}$_${ci}$la_gercond_c = 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_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + safe1 = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safe1 = (n+1)*safe1 ! form y := alpha*abs(a)*abs(x) + beta*abs(y). ! the o(n^2) symb_wero tests could be replaced by o(n) queries to ! 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_wero = .true. @@ -35284,7 +35276,7 @@ module stdlib_linalg_lapack_${ci}$ 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_wero = .true. @@ -35345,10 +35337,10 @@ module stdlib_linalg_lapack_${ci}$ end if end if return - end subroutine stdlib_${ci}$la_heamv + end subroutine stdlib${ii}$_${ci}$la_heamv - real(${ck}$) function stdlib_${ci}$la_hercond_c( uplo, n, a, lda, af,ldaf, ipiv, c, capply,info, work,& + real(${ck}$) function stdlib${ii}$_${ci}$la_hercond_c( uplo, n, a, lda, af,ldaf, ipiv, c, capply,info, work,& !! ZLA_HERCOND_C: computes the infinity norm condition number of !! op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector. rwork ) @@ -35358,22 +35350,22 @@ module stdlib_linalg_lapack_${ci}$ ! Scalar Arguments character, intent(in) :: uplo logical(lk), intent(in) :: capply - integer(ilp), intent(in) :: n, lda, ldaf - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n, lda, ldaf + integer(${ik}$), intent(out) :: info ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) complex(${ck}$), intent(in) :: a(lda,*), af(ldaf,*) complex(${ck}$), intent(out) :: work(*) real(${ck}$), intent(in) :: c(*) real(${ck}$), intent(out) :: rwork(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: kase, i, j + integer(${ik}$) :: kase, i, j real(${ck}$) :: ainvnm, anorm, tmp logical(lk) :: up, upper complex(${ck}$) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,max ! Statement Functions @@ -35381,20 +35373,20 @@ module stdlib_linalg_lapack_${ci}$ ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements - stdlib_${ci}$la_hercond_c = zero - info = 0 + stdlib${ii}$_${ci}$la_hercond_c = zero + 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 ) - if ( ipiv( k )>0 ) then + if ( ipiv( k )>0_${ik}$ ) then ! 1x1 pivot kp = ipiv( k ) if ( kp /= k ) then @@ -35579,7 +35571,7 @@ module stdlib_linalg_lapack_${ci}$ do i = 1, k work( k ) = max( cabs1( af( i, k ) ), work( k ) ) end do - k = k - 1 + k = k - 1_${ik}$ else ! 2x2 pivot kp = -ipiv( k ) @@ -35591,31 +35583,31 @@ module stdlib_linalg_lapack_${ci}$ work( k-1 ) =max( cabs1( af( i, k-1 ) ), work( k-1 ) ) end do work( k ) = max( cabs1( 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 + if ( ipiv( k )>0_${ik}$ ) then ! 1x1 pivot kp = ipiv( k ) if ( kp /= k ) then @@ -35626,7 +35618,7 @@ module stdlib_linalg_lapack_${ci}$ do i = k, n work( k ) = max( cabs1( af( i, k ) ), work( k ) ) end do - k = k + 1 + k = k + 1_${ik}$ else ! 2x2 pivot kp = -ipiv( k ) @@ -35638,25 +35630,25 @@ module stdlib_linalg_lapack_${ci}$ work( k+1 ) =max( cabs1( af( i, k+1 ) ) , work( k+1 ) ) end do work(k) = max( cabs1( 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 @@ -35683,11 +35675,11 @@ module stdlib_linalg_lapack_${ci}$ end if end do end if - stdlib_${ci}$la_herpvgrw = rpvgrw - end function stdlib_${ci}$la_herpvgrw + stdlib${ii}$_${ci}$la_herpvgrw = rpvgrw + end function stdlib${ii}$_${ci}$la_herpvgrw - pure subroutine stdlib_${ci}$la_lin_berr( n, nz, nrhs, res, ayb, berr ) + pure subroutine stdlib${ii}$_${ci}$la_lin_berr( n, nz, nrhs, res, ayb, berr ) !! ZLA_LIN_BERR: computes componentwise relative backward error from !! the formula !! max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) @@ -35697,7 +35689,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, nz, nrhs + integer(${ik}$), intent(in) :: n, nz, nrhs ! Array Arguments real(${ck}$), intent(in) :: ayb(n,nrhs) real(${ck}$), intent(out) :: berr(nrhs) @@ -35705,7 +35697,7 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! Local Scalars real(${ck}$) :: tmp,safe1 - integer(ilp) :: i, j + integer(${ik}$) :: i, j complex(${ck}$) :: cdum ! Intrinsic Functions intrinsic :: abs,real,aimag,max @@ -35717,7 +35709,7 @@ module stdlib_linalg_lapack_${ci}$ ! adding safe1 to the numerator guards against spuriously zero ! residuals. a similar safeguard is in the cla_yyamv routine used ! to compute ayb. - safe1 = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + safe1 = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safe1 = (nz+1)*safe1 do j = 1, nrhs berr(j) = zero @@ -35730,10 +35722,10 @@ module stdlib_linalg_lapack_${ci}$ ! the true residual also must be exactly zero. end do end do - end subroutine stdlib_${ci}$la_lin_berr + end subroutine stdlib${ii}$_${ci}$la_lin_berr - real(${ck}$) function stdlib_${ci}$la_porcond_c( uplo, n, a, lda, af,ldaf, c, capply, info,work, & + real(${ck}$) function stdlib${ii}$_${ci}$la_porcond_c( uplo, n, a, lda, af,ldaf, c, capply, info,work, & !! ZLA_PORCOND_C: Computes the infinity norm condition number of !! op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector rwork ) @@ -35743,8 +35735,8 @@ module stdlib_linalg_lapack_${ci}$ ! Scalar Arguments character, intent(in) :: uplo logical(lk), intent(in) :: capply - integer(ilp), intent(in) :: n, lda, ldaf - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n, lda, ldaf + integer(${ik}$), intent(out) :: info ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*), af(ldaf,*) complex(${ck}$), intent(out) :: work(*) @@ -35752,13 +35744,13 @@ module stdlib_linalg_lapack_${ci}$ real(${ck}$), intent(out) :: rwork(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: kase + integer(${ik}$) :: kase real(${ck}$) :: ainvnm, anorm, tmp - integer(ilp) :: i, j + integer(${ik}$) :: i, j logical(lk) :: up, upper complex(${ck}$) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,real,aimag ! Statement Functions @@ -35766,20 +35758,20 @@ module stdlib_linalg_lapack_${ci}$ ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements - stdlib_${ci}$la_porcond_c = zero - info = 0 + stdlib${ii}$_${ci}$la_porcond_c = zero + 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 )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_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + safe1 = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safe1 = (n+1)*safe1 ! form y := alpha*abs(a)*abs(x) + beta*abs(y). ! the o(n^2) symb_wero tests could be replaced by o(n) queries to ! 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_wero = .true. @@ -36107,7 +36099,7 @@ module stdlib_linalg_lapack_${ci}$ 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_wero = .true. @@ -36168,10 +36160,10 @@ module stdlib_linalg_lapack_${ci}$ end if end if return - end subroutine stdlib_${ci}$la_syamv + end subroutine stdlib${ii}$_${ci}$la_syamv - real(${ck}$) function stdlib_${ci}$la_syrcond_c( uplo, n, a, lda, af,ldaf, ipiv, c, capply,info, work,& + real(${ck}$) function stdlib${ii}$_${ci}$la_syrcond_c( uplo, n, a, lda, af,ldaf, ipiv, c, capply,info, work,& !! ZLA_SYRCOND_C: Computes the infinity norm condition number of !! op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector. rwork ) @@ -36181,23 +36173,23 @@ module stdlib_linalg_lapack_${ci}$ ! Scalar Arguments character, intent(in) :: uplo logical(lk), intent(in) :: capply - integer(ilp), intent(in) :: n, lda, ldaf - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n, lda, ldaf + integer(${ik}$), intent(out) :: info ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) complex(${ck}$), intent(in) :: a(lda,*), af(ldaf,*) complex(${ck}$), intent(out) :: work(*) real(${ck}$), intent(in) :: c(*) real(${ck}$), intent(out) :: rwork(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: kase + integer(${ik}$) :: kase real(${ck}$) :: ainvnm, anorm, tmp - integer(ilp) :: i, j + integer(${ik}$) :: i, j logical(lk) :: up, upper complex(${ck}$) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,max ! Statement Functions @@ -36205,20 +36197,20 @@ module stdlib_linalg_lapack_${ci}$ ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! Executable Statements - stdlib_${ci}$la_syrcond_c = zero - info = 0 + stdlib${ii}$_${ci}$la_syrcond_c = zero + 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 ) - if ( ipiv( k )>0 ) then + if ( ipiv( k )>0_${ik}$ ) then ! 1x1 pivot kp = ipiv( k ) if ( kp /= k ) then @@ -36403,7 +36395,7 @@ module stdlib_linalg_lapack_${ci}$ do i = 1, k work( k ) = max( cabs1( af( i, k ) ), work( k ) ) end do - k = k - 1 + k = k - 1_${ik}$ else ! 2x2 pivot kp = -ipiv( k ) @@ -36415,31 +36407,31 @@ module stdlib_linalg_lapack_${ci}$ work( k-1 ) =max( cabs1( af( i, k-1 ) ), work( k-1 ) ) end do work( k ) = max( cabs1( 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 + if ( ipiv( k )>0_${ik}$ ) then ! 1x1 pivot kp = ipiv( k ) if ( kp /= k ) then @@ -36450,7 +36442,7 @@ module stdlib_linalg_lapack_${ci}$ do i = k, n work( k ) = max( cabs1( af( i, k ) ), work( k ) ) end do - k = k + 1 + k = k + 1_${ik}$ else ! 2x2 pivot kp = -ipiv( k ) @@ -36462,25 +36454,25 @@ module stdlib_linalg_lapack_${ci}$ work( k+1 ) =max( cabs1( af( i, k+1 ) ), work( k+1 ) ) end do work( k ) = max( cabs1( 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 @@ -36507,11 +36499,11 @@ module stdlib_linalg_lapack_${ci}$ end if end do end if - stdlib_${ci}$la_syrpvgrw = rpvgrw - end function stdlib_${ci}$la_syrpvgrw + stdlib${ii}$_${ci}$la_syrpvgrw = rpvgrw + end function stdlib${ii}$_${ci}$la_syrpvgrw - pure subroutine stdlib_${ci}$la_wwaddw( n, x, y, w ) + pure subroutine stdlib${ii}$_${ci}$la_wwaddw( n, x, y, w ) !! ZLA_WWADDW: adds a vector W into a doubled-single vector (X, Y). !! This works for all extant IBM's hex and binary floating point !! arithmetic, but not for decimal. @@ -36519,14 +36511,14 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: x(*), y(*) complex(${ck}$), intent(in) :: w(*) ! ===================================================================== ! Local Scalars complex(${ck}$) :: s - integer(ilp) :: i + integer(${ik}$) :: i ! Executable Statements do 10 i = 1, n s = x(i) + w(i) @@ -36535,10 +36527,10 @@ module stdlib_linalg_lapack_${ci}$ x(i) = s 10 continue return - end subroutine stdlib_${ci}$la_wwaddw + end subroutine stdlib${ii}$_${ci}$la_wwaddw - pure subroutine stdlib_${ci}$labrd( m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y,ldy ) + pure subroutine stdlib${ii}$_${ci}$labrd( m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y,ldy ) !! ZLABRD: reduces the first NB rows and columns of a complex general !! m by n matrix A to upper or lower real bidiagonal form by a unitary !! transformation Q**H * A * P, and returns the matrices X and Y which @@ -36550,7 +36542,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, ldx, ldy, m, n, nb + integer(${ik}$), intent(in) :: lda, ldx, ldy, m, n, nb ! Array Arguments real(${ck}$), intent(out) :: d(*), e(*) complex(${ck}$), intent(inout) :: a(lda,*) @@ -36558,7 +36550,7 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i complex(${ck}$) :: alpha ! Intrinsic Functions intrinsic :: min @@ -36569,202 +36561,202 @@ module stdlib_linalg_lapack_${ci}$ ! reduce to upper bidiagonal form loop_10: do i = 1, nb ! update a(i:m,i) - call stdlib_${ci}$lacgv( i-1, y( i, 1 ), ldy ) - call stdlib_${ci}$gemv( 'NO TRANSPOSE', m-i+1, i-1, -cone, a( i, 1 ),lda, y( i, 1 ), & - ldy, cone, a( i, i ), 1 ) - call stdlib_${ci}$lacgv( i-1, y( i, 1 ), ldy ) - call stdlib_${ci}$gemv( 'NO TRANSPOSE', m-i+1, i-1, -cone, x( i, 1 ),ldx, a( 1, i ), & - 1, cone, a( i, i ), 1 ) + call stdlib${ii}$_${ci}$lacgv( i-1, y( i, 1_${ik}$ ), ldy ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', m-i+1, i-1, -cone, a( i, 1_${ik}$ ),lda, y( i, 1_${ik}$ ), & + ldy, cone, a( i, i ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( i-1, y( i, 1_${ik}$ ), ldy ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', m-i+1, i-1, -cone, x( i, 1_${ik}$ ),ldx, a( 1_${ik}$, i ), & + 1_${ik}$, cone, a( i, i ), 1_${ik}$ ) ! generate reflection q(i) to annihilate a(i+1:m,i) alpha = a( i, i ) - call stdlib_${ci}$larfg( m-i+1, alpha, a( min( i+1, m ), i ), 1,tauq( i ) ) + call stdlib${ii}$_${ci}$larfg( m-i+1, alpha, a( min( i+1, m ), i ), 1_${ik}$,tauq( i ) ) d( i ) = real( alpha,KIND=${ck}$) if( isafmin ) then @@ -36774,29 +36766,29 @@ module stdlib_linalg_lapack_${ci}$ x( i ) = cone end if end do - kase = 2 - isave( 1 ) = 2 + kase = 2_${ik}$ + isave( 1_${ik}$ ) = 2_${ik}$ return ! ................ entry (isave( 1 ) = 2) ! first iteration. x has been overwritten by ctrans(a)*x. 40 continue - isave( 2 ) = stdlib_i${ci}$max1( n, x, 1 ) - isave( 3 ) = 2 + isave( 2_${ik}$ ) = stdlib${ii}$_i${ci}$max1( n, x, 1_${ik}$ ) + isave( 3_${ik}$ ) = 2_${ik}$ ! main loop - iterations 2,3,...,itmax. 50 continue do i = 1, n x( i ) = czero end do - x( isave( 2 ) ) = cone - kase = 1 - isave( 1 ) = 3 + x( isave( 2_${ik}$ ) ) = cone + kase = 1_${ik}$ + isave( 1_${ik}$ ) = 3_${ik}$ return ! ................ entry (isave( 1 ) = 3) ! x has been overwritten by a*x. 70 continue - call stdlib_${ci}$copy( n, x, 1, v, 1 ) + call stdlib${ii}$_${ci}$copy( n, x, 1_${ik}$, v, 1_${ik}$ ) estold = est - est = stdlib_${c2ri(ci)}$zsum1( n, v, 1 ) + est = stdlib${ii}$_${c2ri(ci)}$zsum1( n, v, 1_${ik}$ ) ! test for cycling. if( est<=estold )go to 100 do i = 1, n @@ -36808,17 +36800,17 @@ module stdlib_linalg_lapack_${ci}$ x( i ) = cone end if end do - kase = 2 - isave( 1 ) = 4 + kase = 2_${ik}$ + isave( 1_${ik}$ ) = 4_${ik}$ return ! ................ entry (isave( 1 ) = 4) ! x has been overwritten by ctrans(a)*x. 90 continue - jlast = isave( 2 ) - isave( 2 ) = stdlib_i${ci}$max1( n, x, 1 ) - if( ( abs( x( jlast ) )/=abs( x( isave( 2 ) ) ) ) .and.( isave( 3 )est ) then - call stdlib_${ci}$copy( n, x, 1, v, 1 ) + call stdlib${ii}$_${ci}$copy( n, x, 1_${ik}$, v, 1_${ik}$ ) est = temp end if 130 continue - kase = 0 + kase = 0_${ik}$ return - end subroutine stdlib_${ci}$lacn2 + end subroutine stdlib${ii}$_${ci}$lacn2 - subroutine stdlib_${ci}$lacon( n, v, x, est, kase ) + subroutine stdlib${ii}$_${ci}$lacon( n, v, x, est, kase ) !! ZLACON: estimates the 1-norm of a square, complex matrix A. !! Reverse communication is used for evaluating matrix-vector products. ! -- lapack auxiliary routine -- ! -- 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(${ck}$), intent(inout) :: est ! Array Arguments complex(${ck}$), intent(out) :: v(n) complex(${ck}$), intent(inout) :: x(n) ! ===================================================================== ! 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(${ck}$) :: absxi, altsgn, estold, safmin, temp ! Intrinsic Functions intrinsic :: abs,real,cmplx,aimag ! Save Statement save ! Executable Statements - safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) - if( kase==0 ) then + safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + if( kase==0_${ik}$ ) then do i = 1, n x( i ) = cmplx( one / real( n,KIND=${ck}$),KIND=${ck}$) end do - kase = 1 - jump = 1 + kase = 1_${ik}$ + jump = 1_${ik}$ return end if go to ( 20, 40, 70, 90, 120 )jump ! ................ entry (jump = 1) ! 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 130 end if - est = stdlib_${c2ri(ci)}$zsum1( n, x, 1 ) + est = stdlib${ii}$_${c2ri(ci)}$zsum1( n, x, 1_${ik}$ ) do i = 1, n absxi = abs( x( i ) ) if( absxi>safmin ) then @@ -36902,29 +36894,29 @@ module stdlib_linalg_lapack_${ci}$ x( i ) = cone end if end do - kase = 2 - jump = 2 + kase = 2_${ik}$ + jump = 2_${ik}$ return ! ................ entry (jump = 2) ! first iteration. x has been overwritten by ctrans(a)*x. 40 continue - j = stdlib_i${ci}$max1( n, x, 1 ) - iter = 2 + j = stdlib${ii}$_i${ci}$max1( n, x, 1_${ik}$ ) + iter = 2_${ik}$ ! main loop - iterations 2,3,...,itmax. 50 continue do i = 1, n x( i ) = czero end do x( j ) = cone - kase = 1 - jump = 3 + kase = 1_${ik}$ + jump = 3_${ik}$ return ! ................ entry (jump = 3) ! x has been overwritten by a*x. 70 continue - call stdlib_${ci}$copy( n, x, 1, v, 1 ) + call stdlib${ii}$_${ci}$copy( n, x, 1_${ik}$, v, 1_${ik}$ ) estold = est - est = stdlib_${c2ri(ci)}$zsum1( n, v, 1 ) + est = stdlib${ii}$_${c2ri(ci)}$zsum1( n, v, 1_${ik}$ ) ! test for cycling. if( est<=estold )go to 100 do i = 1, n @@ -36936,16 +36928,16 @@ module stdlib_linalg_lapack_${ci}$ x( i ) = cone end if end do - kase = 2 - jump = 4 + kase = 2_${ik}$ + jump = 4_${ik}$ return ! ................ entry (jump = 4) ! x has been overwritten by ctrans(a)*x. 90 continue jlast = j - j = stdlib_i${ci}$max1( n, x, 1 ) + j = stdlib${ii}$_i${ci}$max1( n, x, 1_${ik}$ ) if( ( abs( x( jlast ) )/=abs( x( j ) ) ) .and.( iterest ) then - call stdlib_${ci}$copy( n, x, 1, v, 1 ) + call stdlib${ii}$_${ci}$copy( n, x, 1_${ik}$, v, 1_${ik}$ ) est = temp end if 130 continue - kase = 0 + kase = 0_${ik}$ return - end subroutine stdlib_${ci}$lacon + end subroutine stdlib${ii}$_${ci}$lacon - pure subroutine stdlib_${ci}$lacp2( uplo, m, n, a, lda, b, ldb ) + pure subroutine stdlib${ii}$_${ci}$lacp2( uplo, m, n, a, lda, b, ldb ) !! ZLACP2: copies all or part of a real two-dimensional matrix A to a !! complex matrix B. ! -- lapack auxiliary routine -- @@ -36981,13 +36973,13 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(${ck}$), intent(in) :: a(lda,*) complex(${ck}$), intent(out) :: b(ldb,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -37011,10 +37003,10 @@ module stdlib_linalg_lapack_${ci}$ end do end if return - end subroutine stdlib_${ci}$lacp2 + end subroutine stdlib${ii}$_${ci}$lacp2 - pure subroutine stdlib_${ci}$lacpy( uplo, m, n, a, lda, b, ldb ) + pure subroutine stdlib${ii}$_${ci}$lacpy( uplo, m, n, a, lda, b, ldb ) !! ZLACPY: copies all or part of a two-dimensional matrix A to another !! matrix B. ! -- lapack auxiliary routine -- @@ -37022,13 +37014,13 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(in) :: a(lda,*) complex(${ck}$), intent(out) :: b(ldb,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -37052,10 +37044,10 @@ module stdlib_linalg_lapack_${ci}$ end do end if return - end subroutine stdlib_${ci}$lacpy + end subroutine stdlib${ii}$_${ci}$lacpy - pure subroutine stdlib_${ci}$lacrm( m, n, a, lda, b, ldb, c, ldc, rwork ) + pure subroutine stdlib${ii}$_${ci}$lacrm( m, n, a, lda, b, ldb, c, ldc, rwork ) !! ZLACRM: performs a very simple matrix-matrix multiplication: !! C := A * B, !! where A is M by N and complex; B is N by N and real; @@ -37064,7 +37056,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, ldc, m, n + integer(${ik}$), intent(in) :: lda, ldb, ldc, m, n ! Array Arguments real(${ck}$), intent(in) :: b(ldb,*) real(${ck}$), intent(out) :: rwork(*) @@ -37073,7 +37065,7 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, l + integer(${ik}$) :: i, j, l ! Intrinsic Functions intrinsic :: real,cmplx,aimag ! Executable Statements @@ -37084,8 +37076,8 @@ module stdlib_linalg_lapack_${ci}$ rwork( ( j-1 )*m+i ) = real( a( i, j ),KIND=${ck}$) end do end do - l = m*n + 1 - call stdlib_${c2ri(ci)}$gemm( 'N', 'N', m, n, n, one, rwork, m, b, ldb, zero,rwork( l ), m ) + l = m*n + 1_${ik}$ + call stdlib${ii}$_${c2ri(ci)}$gemm( 'N', 'N', m, n, n, one, rwork, m, b, ldb, zero,rwork( l ), m ) do j = 1, n do i = 1, m @@ -37097,7 +37089,7 @@ module stdlib_linalg_lapack_${ci}$ rwork( ( j-1 )*m+i ) = aimag( a( i, j ) ) end do end do - call stdlib_${c2ri(ci)}$gemm( 'N', 'N', m, n, n, one, rwork, m, b, ldb, zero,rwork( l ), m ) + call stdlib${ii}$_${c2ri(ci)}$gemm( 'N', 'N', m, n, n, one, rwork, m, b, ldb, zero,rwork( l ), m ) do j = 1, n do i = 1, m @@ -37106,10 +37098,10 @@ module stdlib_linalg_lapack_${ci}$ end do end do return - end subroutine stdlib_${ci}$lacrm + end subroutine stdlib${ii}$_${ci}$lacrm - pure subroutine stdlib_${ci}$lacrt( n, cx, incx, cy, incy, c, s ) + pure subroutine stdlib${ii}$_${ci}$lacrt( n, cx, incx, cy, incy, c, s ) !! ZLACRT: performs the operation !! ( c s )( x ) ==> ( x ) !! ( -s c )( y ) ( y ) @@ -37118,22 +37110,22 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n complex(${ck}$), intent(in) :: c, s ! Array Arguments complex(${ck}$), intent(inout) :: cx(*), cy(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ix, iy + integer(${ik}$) :: i, ix, iy complex(${ck}$) :: ctemp ! Executable Statements if( n<=0 )return if( incx==1 .and. incy==1 )go to 20 ! code for unequal increments or equal increments not equal to 1 - ix = 1 - iy = 1 - if( incx<0 )ix = ( -n+1 )*incx + 1 - if( incy<0 )iy = ( -n+1 )*incy + 1 + ix = 1_${ik}$ + iy = 1_${ik}$ + if( incx<0_${ik}$ )ix = ( -n+1 )*incx + 1_${ik}$ + if( incy<0_${ik}$ )iy = ( -n+1 )*incy + 1_${ik}$ do i = 1, n ctemp = c*cx( ix ) + s*cy( iy ) cy( iy ) = c*cy( iy ) - s*cx( ix ) @@ -37150,10 +37142,10 @@ module stdlib_linalg_lapack_${ci}$ cx( i ) = ctemp end do return - end subroutine stdlib_${ci}$lacrt + end subroutine stdlib${ii}$_${ci}$lacrt - pure complex(${ck}$) function stdlib_${ci}$ladiv( x, y ) + pure complex(${ck}$) function stdlib${ii}$_${ci}$ladiv( x, y ) !! ZLADIV: := X / Y, where X and Y are complex. The computation of X / Y !! will not overflow on an intermediary step unless the results !! overflows. @@ -37168,14 +37160,14 @@ module stdlib_linalg_lapack_${ci}$ ! Intrinsic Functions intrinsic :: real,cmplx,aimag ! Executable Statements - call stdlib_${c2ri(ci)}$ladiv( real( x,KIND=${ck}$), aimag( x ), real( y,KIND=${ck}$), aimag( y ), zr,zi ) + call stdlib${ii}$_${c2ri(ci)}$ladiv( real( x,KIND=${ck}$), aimag( x ), real( y,KIND=${ck}$), aimag( y ), zr,zi ) - stdlib_${ci}$ladiv = cmplx( zr, zi,KIND=${ck}$) + stdlib${ii}$_${ci}$ladiv = cmplx( zr, zi,KIND=${ck}$) return - end function stdlib_${ci}$ladiv + end function stdlib${ii}$_${ci}$ladiv - pure subroutine stdlib_${ci}$laed0( qsiz, n, d, e, q, ldq, qstore, ldqs, rwork,iwork, info ) + pure subroutine stdlib${ii}$_${ci}$laed0( qsiz, n, d, e, q, ldq, qstore, ldqs, rwork,iwork, info ) !! Using the divide and conquer method, ZLAED0: computes all eigenvalues !! of a symmetric tridiagonal matrix which is one diagonal block of !! those from reducing a dense or band Hermitian matrix and @@ -37185,10 +37177,10 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: ldq, ldqs, n, qsiz + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldq, ldqs, n, qsiz ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(${ck}$), intent(inout) :: d(*), e(*) real(${ck}$), intent(out) :: rwork(*) complex(${ck}$), intent(inout) :: q(ldq,*) @@ -37197,7 +37189,7 @@ module stdlib_linalg_lapack_${ci}$ ! warning: n could be as big as qsiz! ! Local Scalars - integer(ilp) :: curlvl, curprb, curr, i, igivcl, igivnm, igivpt, indxq, iperm, iprmpt, & + integer(${ik}$) :: curlvl, curprb, curr, i, igivcl, igivnm, igivpt, indxq, iperm, iprmpt, & iq, iqptr, iwrem, j, k, lgn, ll, matsiz, msd2, smlsiz, smm1, spm1, spm2, submat, & subpbs, tlvls real(${ck}$) :: temp @@ -37205,40 +37197,40 @@ module stdlib_linalg_lapack_${ci}$ intrinsic :: abs,real,int,log,max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ ! if( icompq < 0 .or. icompq > 2 ) then ! info = -1 ! else if( ( icompq == 1 ) .and. ( qsiz < max( 0, n ) ) ) ! $ then - if( qsizsmlsiz ) then do j = subpbs, 1, -1 - iwork( 2*j ) = ( iwork( j )+1 ) / 2 - iwork( 2*j-1 ) = iwork( j ) / 2 + iwork( 2_${ik}$*j ) = ( iwork( j )+1_${ik}$ ) / 2_${ik}$ + iwork( 2_${ik}$*j-1 ) = iwork( j ) / 2_${ik}$ end do - tlvls = tlvls + 1 - subpbs = 2*subpbs + tlvls = tlvls + 1_${ik}$ + subpbs = 2_${ik}$*subpbs go to 10 end if do j = 2, subpbs @@ -37246,98 +37238,98 @@ module stdlib_linalg_lapack_${ci}$ end do ! divide the matrix into subpbs submatrices of size at most smlsiz+1 ! using rank-1 modifications (cuts). - spm1 = subpbs - 1 + spm1 = subpbs - 1_${ik}$ do i = 1, spm1 - submat = iwork( i ) + 1 - smm1 = submat - 1 + submat = iwork( i ) + 1_${ik}$ + smm1 = submat - 1_${ik}$ d( smm1 ) = d( smm1 ) - abs( e( smm1 ) ) d( submat ) = d( submat ) - abs( e( smm1 ) ) end do - indxq = 4*n + 3 + indxq = 4_${ik}$*n + 3_${ik}$ ! set up workspaces for eigenvalues only/accumulate new vectors ! routine temp = log( real( n,KIND=${ck}$) ) / log( two ) - lgn = int( temp,KIND=ilp) - if( 2**lgn0 ) then - info = submat*( n+1 ) + submat + matsiz - 1 + call stdlib${ii}$_${ci}$lacrm( qsiz, matsiz, q( 1_${ik}$, submat ), ldq, rwork( ll ),matsiz, qstore( & + 1_${ik}$, submat ), ldqs,rwork( iwrem ) ) + iwork( iqptr+curr+1 ) = iwork( iqptr+curr ) + matsiz**2_${ik}$ + curr = curr + 1_${ik}$ + if( info>0_${ik}$ ) then + info = submat*( n+1 ) + submat + matsiz - 1_${ik}$ return end if - k = 1 + k = 1_${ik}$ do j = submat, iwork( i+1 ) iwork( indxq+j ) = k - k = k + 1 + k = k + 1_${ik}$ end do end do ! successively merge eigensystems of adjacent submatrices ! into eigensystem for the corresponding larger matrix. ! while ( subpbs > 1 ) - curlvl = 1 + curlvl = 1_${ik}$ 80 continue - if( subpbs>1 ) then - spm2 = subpbs - 2 + if( subpbs>1_${ik}$ ) then + spm2 = subpbs - 2_${ik}$ do i = 0, spm2, 2 - if( i==0 ) then - submat = 1 - matsiz = iwork( 2 ) - msd2 = iwork( 1 ) - curprb = 0 + if( i==0_${ik}$ ) then + submat = 1_${ik}$ + matsiz = iwork( 2_${ik}$ ) + msd2 = iwork( 1_${ik}$ ) + curprb = 0_${ik}$ else - submat = iwork( i ) + 1 + submat = iwork( i ) + 1_${ik}$ matsiz = iwork( i+2 ) - iwork( i ) - msd2 = matsiz / 2 - curprb = curprb + 1 + msd2 = matsiz / 2_${ik}$ + curprb = curprb + 1_${ik}$ end if ! merge lower order eigensystems (of size msd2 and matsiz - msd2) - ! into an eigensystem of size matsiz. stdlib_${ci}$laed7 handles the case + ! into an eigensystem of size matsiz. stdlib${ii}$_${ci}$laed7 handles the case ! when the eigenvectors of a full or band hermitian matrix (which ! was reduced to tridiagonal form) are desired. ! i am free to use q as a valuable working space until loop 150. - call stdlib_${ci}$laed7( matsiz, msd2, qsiz, tlvls, curlvl, curprb,d( submat ), & - qstore( 1, submat ), ldqs,e( submat+msd2-1 ), iwork( indxq+submat ),rwork( iq ), & + call stdlib${ii}$_${ci}$laed7( matsiz, msd2, qsiz, tlvls, curlvl, curprb,d( submat ), & + qstore( 1_${ik}$, submat ), ldqs,e( submat+msd2-1 ), iwork( indxq+submat ),rwork( iq ), & iwork( iqptr ), iwork( iprmpt ),iwork( iperm ), iwork( igivpt ),iwork( igivcl ), & - rwork( igivnm ),q( 1, submat ), rwork( iwrem ),iwork( subpbs+1 ), info ) - if( info>0 ) then - info = submat*( n+1 ) + submat + matsiz - 1 + rwork( igivnm ),q( 1_${ik}$, submat ), rwork( iwrem ),iwork( subpbs+1 ), info ) + if( info>0_${ik}$ ) then + info = submat*( n+1 ) + submat + matsiz - 1_${ik}$ return end if - iwork( i / 2+1 ) = iwork( i+2 ) + iwork( i / 2_${ik}$+1 ) = iwork( i+2 ) end do - subpbs = subpbs / 2 - curlvl = curlvl + 1 + subpbs = subpbs / 2_${ik}$ + curlvl = curlvl + 1_${ik}$ go to 80 end if ! end while @@ -37346,14 +37338,14 @@ module stdlib_linalg_lapack_${ci}$ do i = 1, n j = iwork( indxq+i ) rwork( i ) = d( j ) - call stdlib_${ci}$copy( qsiz, qstore( 1, j ), 1, q( 1, i ), 1 ) + call stdlib${ii}$_${ci}$copy( qsiz, qstore( 1_${ik}$, j ), 1_${ik}$, q( 1_${ik}$, i ), 1_${ik}$ ) end do - call stdlib_${c2ri(ci)}$copy( n, rwork, 1, d, 1 ) + call stdlib${ii}$_${c2ri(ci)}$copy( n, rwork, 1_${ik}$, d, 1_${ik}$ ) return - end subroutine stdlib_${ci}$laed0 + end subroutine stdlib${ii}$_${ci}$laed0 - pure subroutine stdlib_${ci}$laed7( n, cutpnt, qsiz, tlvls, curlvl, curpbm, d, q,ldq, rho, indxq, & + pure subroutine stdlib${ii}$_${ci}$laed7( n, cutpnt, qsiz, tlvls, curlvl, curpbm, d, q,ldq, rho, indxq, & !! ZLAED7: computes the updated eigensystem of a diagonal !! matrix after modification by a rank-one symmetric matrix. This !! routine is used only for the eigenproblem which requires all @@ -37383,93 +37375,93 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, cutpnt, ldq, n, qsiz, tlvls - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: curlvl, curpbm, cutpnt, ldq, n, qsiz, tlvls + integer(${ik}$), intent(out) :: info real(${ck}$), intent(inout) :: rho ! Array Arguments - integer(ilp), intent(inout) :: givcol(2,*), givptr(*), perm(*), prmptr(*), qptr(*) + integer(${ik}$), intent(inout) :: givcol(2_${ik}$,*), givptr(*), perm(*), prmptr(*), qptr(*) - integer(ilp), intent(out) :: indxq(*), iwork(*) - real(${ck}$), intent(inout) :: d(*), givnum(2,*), qstore(*) + integer(${ik}$), intent(out) :: indxq(*), iwork(*) + real(${ck}$), intent(inout) :: d(*), givnum(2_${ik}$,*), qstore(*) real(${ck}$), intent(out) :: rwork(*) complex(${ck}$), intent(inout) :: q(ldq,*) complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: coltyp, curr, i, idlmda, indx, indxc, indxp, iq, iw, iz, k, n1, n2, & + integer(${ik}$) :: coltyp, curr, i, idlmda, indx, indxc, indxp, iq, iw, iz, k, n1, n2, & ptr ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ ! if( icompq<0 .or. icompq>1 ) then ! info = -1 ! else if( n<0 ) then - if( n<0 ) then - info = -1 - else if( min( 1, n )>cutpnt .or. ncutpnt .or. nn ) then - info = -8 - else if( ldq2n ) then + info = -8_${ik}$ + else if( ldq2n )go to 90 if( rho*abs( z( j ) )<=tol ) then ! deflate due to small z component. - k2 = k2 - 1 + k2 = k2 - 1_${ik}$ indxp( k2 ) = j else ! check if eigenvalues are close enough to allow deflation. @@ -37612,7 +37604,7 @@ module stdlib_linalg_lapack_${ci}$ c = z( j ) ! find sqrt(a**2+b**2) without overflow or ! destructive underflow. - tau = stdlib_${c2ri(ci)}$lapy2( c, s ) + tau = stdlib${ii}$_${c2ri(ci)}$lapy2( c, s ) t = d( j ) - d( jlam ) c = c / tau s = -s / tau @@ -37621,24 +37613,24 @@ module stdlib_linalg_lapack_${ci}$ z( j ) = tau z( jlam ) = zero ! record the appropriate givens rotation - givptr = givptr + 1 - givcol( 1, givptr ) = indxq( indx( jlam ) ) - givcol( 2, givptr ) = indxq( indx( j ) ) - givnum( 1, givptr ) = c - givnum( 2, givptr ) = s - call stdlib_${ci}$drot( qsiz, q( 1, indxq( indx( jlam ) ) ), 1,q( 1, indxq( indx( j ) & - ) ), 1, c, s ) + givptr = givptr + 1_${ik}$ + givcol( 1_${ik}$, givptr ) = indxq( indx( jlam ) ) + givcol( 2_${ik}$, givptr ) = indxq( indx( j ) ) + givnum( 1_${ik}$, givptr ) = c + givnum( 2_${ik}$, givptr ) = s + call stdlib${ii}$_${ci}$drot( qsiz, q( 1_${ik}$, indxq( indx( jlam ) ) ), 1_${ik}$,q( 1_${ik}$, indxq( indx( j ) & + ) ), 1_${ik}$, c, s ) t = d( jlam )*c*c + d( j )*s*s d( j ) = d( jlam )*s*s + d( j )*c*c d( jlam ) = t - k2 = k2 - 1 - i = 1 + k2 = k2 - 1_${ik}$ + i = 1_${ik}$ 80 continue if( k2+i<=n ) then if( d( jlam )=growto*scale )go to 120 ! choose new orthogonal starting vector and try again. rtemp = eps3 / ( rootn+one ) - v( 1 ) = eps3 + v( 1_${ik}$ ) = eps3 do i = 2, n v( i ) = rtemp end do v( n-its+1 ) = v( n-its+1 ) - eps3*rootn end do ! failure to find eigenvector in n iterations. - info = 1 + info = 1_${ik}$ 120 continue ! normalize eigenvector. - i = stdlib_i${ci}$amax( n, v, 1 ) - call stdlib_${ci}$dscal( n, one / cabs1( v( i ) ), v, 1 ) + i = stdlib${ii}$_i${ci}$amax( n, v, 1_${ik}$ ) + call stdlib${ii}$_${ci}$dscal( n, one / cabs1( v( i ) ), v, 1_${ik}$ ) return - end subroutine stdlib_${ci}$laein + end subroutine stdlib${ii}$_${ci}$laein - pure subroutine stdlib_${ci}$laesy( a, b, c, rt1, rt2, evscal, cs1, sn1 ) + pure subroutine stdlib${ii}$_${ci}$laesy( a, b, c, rt1, rt2, evscal, cs1, sn1 ) !! ZLAESY: computes the eigendecomposition of a 2-by-2 symmetric matrix !! ( ( A, B );( B, C ) ) !! provided the norm of the matrix of eigenvectors is larger than @@ -37883,7 +37875,7 @@ module stdlib_linalg_lapack_${ci}$ babs = abs( b ) tabs = abs( t ) z = max( babs, tabs ) - if( z>zero )t = z*sqrt( ( t / z )**2+( b / z )**2 ) + if( z>zero )t = z*sqrt( ( t / z )**2_${ik}$+( b / z )**2_${ik}$ ) ! compute the two eigenvalues. rt1 and rt2 are exchanged ! if necessary so that rt1 will have the greater magnitude. rt1 = s + t @@ -37900,7 +37892,7 @@ module stdlib_linalg_lapack_${ci}$ sn1 = ( rt1-a ) / b tabs = abs( sn1 ) if( tabs>one ) then - t = tabs*sqrt( ( one / tabs )**2+( sn1 / tabs )**2 ) + t = tabs*sqrt( ( one / tabs )**2_${ik}$+( sn1 / tabs )**2_${ik}$ ) else t = sqrt( cone+sn1*sn1 ) end if @@ -37914,10 +37906,10 @@ module stdlib_linalg_lapack_${ci}$ end if end if return - end subroutine stdlib_${ci}$laesy + end subroutine stdlib${ii}$_${ci}$laesy - pure subroutine stdlib_${ci}$laev2( a, b, c, rt1, rt2, cs1, sn1 ) + pure subroutine stdlib${ii}$_${ci}$laev2( a, b, c, rt1, rt2, cs1, sn1 ) !! ZLAEV2: computes the eigendecomposition of a 2-by-2 Hermitian matrix !! [ A B ] !! [ CONJG(B) C ]. @@ -37947,14 +37939,14 @@ module stdlib_linalg_lapack_${ci}$ else w = conjg( b ) / abs( b ) end if - call stdlib_${c2ri(ci)}$laev2( real( a,KIND=${ck}$), abs( b ), real( c,KIND=${ck}$), rt1, rt2, cs1, t ) + call stdlib${ii}$_${c2ri(ci)}$laev2( real( a,KIND=${ck}$), abs( b ), real( c,KIND=${ck}$), rt1, rt2, cs1, t ) sn1 = w*t return - end subroutine stdlib_${ci}$laev2 + end subroutine stdlib${ii}$_${ci}$laev2 - pure subroutine stdlib_${ci}$lag2c( m, n, a, lda, sa, ldsa, info ) + pure subroutine stdlib${ii}$_${ci}$lag2c( m, n, a, lda, sa, ldsa, info ) !! ZLAG2C: converts a COMPLEX*16 matrix, SA, to a COMPLEX matrix, A. !! RMAX is the overflow for the SINGLE PRECISION arithmetic !! ZLAG2C checks that all the entries of A are between -RMAX and @@ -37964,36 +37956,36 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(dp), intent(out) :: sa(ldsa,*) complex(${ck}$), intent(in) :: a(lda,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(${ck}$) :: rmax ! Intrinsic Functions intrinsic :: real,aimag ! Executable Statements - rmax = stdlib_dlamch( 'O' ) + rmax = stdlib${ii}$_dlamch( 'O' ) do j = 1, n do i = 1, m if( ( real( a( i, j ),KIND=${ck}$)<-rmax ) .or.( real( a( i, j ),KIND=${ck}$)>rmax ) & .or.( aimag( a( i, j ) )<-rmax ) .or.( aimag( a( i, j ) )>rmax ) ) then - info = 1 + info = 1_${ik}$ go to 30 end if sa( i, j ) = a( i, j ) end do end do - info = 0 + info = 0_${ik}$ 30 continue return - end subroutine stdlib_${ci}$lag2c + end subroutine stdlib${ii}$_${ci}$lag2c - pure subroutine stdlib_${ci}$lags2( upper, a1, a2, a3, b1, b2, b3, csu, snu, csv,snv, csq, snq ) + pure subroutine stdlib${ii}$_${ci}$lags2( upper, a1, a2, a3, b1, b2, b3, csu, snu, csv,snv, csq, snq ) !! ZLAGS2: computes 2-by-2 unitary matrices U, V and Q, such !! that if ( UPPER ) then !! U**H *A*Q = U**H *( A1 A2 )*Q = ( x 0 ) @@ -38056,7 +38048,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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_${c2ri(ci)}$lasv2( a, fb, d, s1, s2, snr, csr, snl, csl ) + call stdlib${ii}$_${c2ri(ci)}$lasv2( a, fb, d, s1, s2, snr, csr, snl, csl ) if( abs( csl )>=abs( snl ) .or. abs( csr )>=abs( snr ) )then ! compute the (1,1) and (1,2) elements of u**h *a and v**h *b, ! and (1,2) element of |u|**h *|a| and |v|**h *|b|. @@ -38068,17 +38060,17 @@ module stdlib_linalg_lapack_${ci}$ avb12 = abs( csr )*abs1( b2 ) + abs( snr )*abs( b3 ) ! zero (1,2) elements of u**h *a and v**h *b if( ( abs( ua11r )+abs1( ua12 ) )==zero ) then - call stdlib_${ci}$lartg( -cmplx( vb11r,KIND=${ck}$), conjg( vb12 ), csq, snq,r ) + call stdlib${ii}$_${ci}$lartg( -cmplx( vb11r,KIND=${ck}$), conjg( vb12 ), csq, snq,r ) else if( ( abs( vb11r )+abs1( vb12 ) )==zero ) then - call stdlib_${ci}$lartg( -cmplx( ua11r,KIND=${ck}$), conjg( ua12 ), csq, snq,r ) + call stdlib${ii}$_${ci}$lartg( -cmplx( ua11r,KIND=${ck}$), conjg( ua12 ), csq, snq,r ) else if( aua12 / ( abs( ua11r )+abs1( ua12 ) )<=avb12 /( abs( vb11r )+abs1( vb12 & ) ) ) then - call stdlib_${ci}$lartg( -cmplx( ua11r,KIND=${ck}$), conjg( ua12 ), csq, snq,r ) + call stdlib${ii}$_${ci}$lartg( -cmplx( ua11r,KIND=${ck}$), conjg( ua12 ), csq, snq,r ) else - call stdlib_${ci}$lartg( -cmplx( vb11r,KIND=${ck}$), conjg( vb12 ), csq, snq,r ) + call stdlib${ii}$_${ci}$lartg( -cmplx( vb11r,KIND=${ck}$), conjg( vb12 ), csq, snq,r ) end if csu = csl @@ -38096,14 +38088,14 @@ module stdlib_linalg_lapack_${ci}$ avb22 = abs( snr )*abs1( b2 ) + abs( csr )*abs( b3 ) ! zero (2,2) elements of u**h *a and v**h *b, and then swap. if( ( abs1( ua21 )+abs1( ua22 ) )==zero ) then - call stdlib_${ci}$lartg( -conjg( vb21 ), conjg( vb22 ), csq, snq,r ) + call stdlib${ii}$_${ci}$lartg( -conjg( vb21 ), conjg( vb22 ), csq, snq,r ) else if( ( abs1( vb21 )+abs( vb22 ) )==zero ) then - call stdlib_${ci}$lartg( -conjg( ua21 ), conjg( ua22 ), csq, snq,r ) + call stdlib${ii}$_${ci}$lartg( -conjg( ua21 ), conjg( ua22 ), csq, snq,r ) else if( aua22 / ( abs1( ua21 )+abs1( ua22 ) )<=avb22 /( abs1( vb21 )+abs1( vb22 & ) ) ) then - call stdlib_${ci}$lartg( -conjg( ua21 ), conjg( ua22 ), csq, snq,r ) + call stdlib${ii}$_${ci}$lartg( -conjg( ua21 ), conjg( ua22 ), csq, snq,r ) else - call stdlib_${ci}$lartg( -conjg( vb21 ), conjg( vb22 ), csq, snq,r ) + call stdlib${ii}$_${ci}$lartg( -conjg( vb21 ), conjg( vb22 ), csq, snq,r ) end if csu = snl snu = d1*csl @@ -38125,7 +38117,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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_${c2ri(ci)}$lasv2( a, fc, d, s1, s2, snr, csr, snl, csl ) + call stdlib${ii}$_${c2ri(ci)}$lasv2( a, fc, d, s1, s2, snr, csr, snl, csl ) if( abs( csr )>=abs( snr ) .or. abs( csl )>=abs( snl ) )then ! compute the (2,1) and (2,2) elements of u**h *a and v**h *b, ! and (2,1) element of |u|**h *|a| and |v|**h *|b|. @@ -38137,14 +38129,14 @@ module stdlib_linalg_lapack_${ci}$ avb21 = abs( snl )*abs( b1 ) + abs( csl )*abs1( b2 ) ! zero (2,1) elements of u**h *a and v**h *b. if( ( abs1( ua21 )+abs( ua22r ) )==zero ) then - call stdlib_${ci}$lartg( cmplx( vb22r,KIND=${ck}$), vb21, csq, snq, r ) + call stdlib${ii}$_${ci}$lartg( cmplx( vb22r,KIND=${ck}$), vb21, csq, snq, r ) else if( ( abs1( vb21 )+abs( vb22r ) )==zero ) then - call stdlib_${ci}$lartg( cmplx( ua22r,KIND=${ck}$), ua21, csq, snq, r ) + call stdlib${ii}$_${ci}$lartg( cmplx( ua22r,KIND=${ck}$), ua21, csq, snq, r ) else if( aua21 / ( abs1( ua21 )+abs( ua22r ) )<=avb21 /( abs1( vb21 )+abs( vb22r & ) ) ) then - call stdlib_${ci}$lartg( cmplx( ua22r,KIND=${ck}$), ua21, csq, snq, r ) + call stdlib${ii}$_${ci}$lartg( cmplx( ua22r,KIND=${ck}$), ua21, csq, snq, r ) else - call stdlib_${ci}$lartg( cmplx( vb22r,KIND=${ck}$), vb21, csq, snq, r ) + call stdlib${ii}$_${ci}$lartg( cmplx( vb22r,KIND=${ck}$), vb21, csq, snq, r ) end if csu = csr snu = -conjg( d1 )*snr @@ -38161,14 +38153,14 @@ module stdlib_linalg_lapack_${ci}$ avb11 = abs( csl )*abs( b1 ) + abs( snl )*abs1( b2 ) ! zero (1,1) elements of u**h *a and v**h *b, and then swap. if( ( abs1( ua11 )+abs1( ua12 ) )==zero ) then - call stdlib_${ci}$lartg( vb12, vb11, csq, snq, r ) + call stdlib${ii}$_${ci}$lartg( vb12, vb11, csq, snq, r ) else if( ( abs1( vb11 )+abs1( vb12 ) )==zero ) then - call stdlib_${ci}$lartg( ua12, ua11, csq, snq, r ) + call stdlib${ii}$_${ci}$lartg( ua12, ua11, csq, snq, r ) else if( aua11 / ( abs1( ua11 )+abs1( ua12 ) )<=avb11 /( abs1( vb11 )+abs1( vb12 & ) ) ) then - call stdlib_${ci}$lartg( ua12, ua11, csq, snq, r ) + call stdlib${ii}$_${ci}$lartg( ua12, ua11, csq, snq, r ) else - call stdlib_${ci}$lartg( vb12, vb11, csq, snq, r ) + call stdlib${ii}$_${ci}$lartg( vb12, vb11, csq, snq, r ) end if csu = snr snu = conjg( d1 )*csr @@ -38177,10 +38169,10 @@ module stdlib_linalg_lapack_${ci}$ end if end if return - end subroutine stdlib_${ci}$lags2 + end subroutine stdlib${ii}$_${ci}$lags2 - pure subroutine stdlib_${ci}$lagtm( trans, n, nrhs, alpha, dl, d, du, x, ldx, beta,b, ldb ) + pure subroutine stdlib${ii}$_${ci}$lagtm( trans, n, nrhs, alpha, dl, d, du, x, ldx, beta,b, ldb ) !! ZLAGTM: performs a matrix-vector product of the form !! B := alpha * A * X + beta * B !! where A is a tridiagonal matrix of order N, B and X are N by NRHS @@ -38192,7 +38184,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(${ck}$), intent(in) :: alpha, beta ! Array Arguments complex(${ck}$), intent(inout) :: b(ldb,*) @@ -38200,7 +38192,7 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Intrinsic Functions intrinsic :: conjg ! Executable Statements @@ -38223,10 +38215,10 @@ module stdlib_linalg_lapack_${ci}$ 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 & @@ -38237,10 +38229,10 @@ module stdlib_linalg_lapack_${ci}$ else if( stdlib_lsame( trans, 'T' ) ) then ! 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 & @@ -38251,10 +38243,10 @@ module stdlib_linalg_lapack_${ci}$ else if( stdlib_lsame( trans, 'C' ) ) then ! compute b := b + a**h * x do j = 1, nrhs - if( n==1 ) then - b( 1, j ) = b( 1, j ) + conjg( d( 1 ) )*x( 1, j ) + if( n==1_${ik}$ ) then + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) + conjg( d( 1_${ik}$ ) )*x( 1_${ik}$, j ) else - b( 1, j ) = b( 1, j ) + conjg( d( 1 ) )*x( 1, j ) +conjg( dl( 1 ) )*x( 2, & + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) + conjg( d( 1_${ik}$ ) )*x( 1_${ik}$, j ) +conjg( dl( 1_${ik}$ ) )*x( 2_${ik}$, & j ) b( n, j ) = b( n, j ) + conjg( du( n-1 ) )*x( n-1, j ) + conjg( d( n ) )*x(& n, j ) @@ -38269,10 +38261,10 @@ module stdlib_linalg_lapack_${ci}$ 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 & @@ -38283,10 +38275,10 @@ module stdlib_linalg_lapack_${ci}$ else if( stdlib_lsame( trans, 'T' ) ) then ! 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 & @@ -38297,10 +38289,10 @@ module stdlib_linalg_lapack_${ci}$ else if( stdlib_lsame( trans, 'C' ) ) then ! compute b := b - a**h *x do j = 1, nrhs - if( n==1 ) then - b( 1, j ) = b( 1, j ) - conjg( d( 1 ) )*x( 1, j ) + if( n==1_${ik}$ ) then + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) - conjg( d( 1_${ik}$ ) )*x( 1_${ik}$, j ) else - b( 1, j ) = b( 1, j ) - conjg( d( 1 ) )*x( 1, j ) -conjg( dl( 1 ) )*x( 2, & + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) - conjg( d( 1_${ik}$ ) )*x( 1_${ik}$, j ) -conjg( dl( 1_${ik}$ ) )*x( 2_${ik}$, & j ) b( n, j ) = b( n, j ) - conjg( du( n-1 ) )*x( n-1, j ) - conjg( d( n ) )*x(& n, j ) @@ -38313,10 +38305,10 @@ module stdlib_linalg_lapack_${ci}$ end if end if return - end subroutine stdlib_${ci}$lagtm + end subroutine stdlib${ii}$_${ci}$lagtm - pure subroutine stdlib_${ci}$lahef( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) + pure subroutine stdlib${ii}$_${ci}$lahef( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) !! ZLAHEF: computes a partial factorization of a complex Hermitian !! matrix A using the Bunch-Kaufman diagonal pivoting method. The !! partial factorization has the form: @@ -38335,10 +38327,10 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: w(ldw,*) ! ===================================================================== @@ -38348,7 +38340,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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(${ck}$) :: absakk, alpha, colmax, r1, rowmax, t complex(${ck}$) :: d11, d21, d22, z ! Intrinsic Functions @@ -38358,7 +38350,7 @@ module stdlib_linalg_lapack_${ci}$ ! Statement Function Definitions cabs1( z ) = abs( real( z,KIND=${ck}$) ) + abs( aimag( z ) ) ! 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 @@ -38372,13 +38364,13 @@ module stdlib_linalg_lapack_${ci}$ kw = nb + k - n ! exit from loop if( ( k<=n-nb+1 .and. nb1 ) then - imax = stdlib_i${ci}$amax( k-1, w( 1, kw ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_i${ci}$amax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) colmax = cabs1( w( imax, kw ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k a( k, k ) = real( a( k, k ),KIND=${ck}$) else @@ -38408,23 +38400,23 @@ module stdlib_linalg_lapack_${ci}$ else ! begin pivot search along imax row ! copy column imax to column kw-1 of w and update it - call stdlib_${ci}$copy( imax-1, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) + call stdlib${ii}$_${ci}$copy( imax-1, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) w( imax, kw-1 ) = real( a( imax, imax ),KIND=${ck}$) - call stdlib_${ci}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_${ci}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ ) - call stdlib_${ci}$lacgv( k-imax, w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_${ci}$lacgv( k-imax, w( imax+1, kw-1 ), 1_${ik}$ ) if( k1 ) then - jmax = stdlib_i${ci}$amax( imax-1, w( 1, kw-1 ), 1 ) + if( imax>1_${ik}$ ) then + jmax = stdlib${ii}$_i${ci}$amax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) rowmax = max( rowmax, cabs1( w( jmax, kw-1 ) ) ) end if ! case(2) @@ -38437,20 +38429,20 @@ module stdlib_linalg_lapack_${ci}$ ! pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_${ci}$copy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) ! case(4) else ! interchange rows and columns k-1 and imax, use 2-by-2 ! pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ end if ! end pivot search along imax row end if ! end pivot search ! ============================================================ ! 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. @@ -38461,17 +38453,17 @@ module stdlib_linalg_lapack_${ci}$ ! (or k and k-1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = real( a( kk, kk ),KIND=${ck}$) - call stdlib_${ci}$copy( kk-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - call stdlib_${ci}$lacgv( kk-1-kp, a( kp, kp+1 ), lda ) - if( kp>1 )call stdlib_${ci}$copy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_${ci}$copy( kk-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) + call stdlib${ii}$_${ci}$lacgv( kk-1-kp, a( kp, kp+1 ), lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_${ci}$copy( 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 ! later overwritten). interchange rows kk and kp ! in last kkw to nb columns of w. - if( k1 ) then + call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) + if( k>1_${ik}$ ) then ! (note: no need to check if a(k,k) is not zero, ! since that was ensured earlier in pivot search: ! case a(k,k) = 0 falls into 2x2 pivot case(4)) r1 = one / real( a( k, k ),KIND=${ck}$) - call stdlib_${ci}$dscal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_${ci}$dscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) ! (2) conjugate column w(kw) - call stdlib_${ci}$lacgv( k-1, w( 1, kw ), 1 ) + call stdlib${ii}$_${ci}$lacgv( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) end if else ! 2-by-2 pivot block d(k): columns kw and kw-1 of w now hold @@ -38506,7 +38498,7 @@ module stdlib_linalg_lapack_${ci}$ ! a(k-1:k,k-1:k) := d(k-1:k,k-1:k) = w(k-1:k,kw-1:kw) ! a(1:k-2,k-1:k) := u(1:k-2,k:k-1:k) = ! = w(1:k-2,kw-1:kw) * ( d(k-1:k,k-1:k)**(-1) ) - if( k>2 ) then + if( k>2_${ik}$ ) then ! factor out the columns of the inverse of 2-by-2 pivot ! block d, so that each column contains 1, to reduce the ! number of flops when we multiply panel @@ -38555,12 +38547,12 @@ module stdlib_linalg_lapack_${ci}$ a( k-1, k ) = w( k-1, kw ) a( k, k ) = w( k, kw ) ! (2) conjugate columns w(kw) and w(kw-1) - call stdlib_${ci}$lacgv( k-1, w( 1, kw ), 1 ) - call stdlib_${ci}$lacgv( k-2, w( 1, kw-1 ), 1 ) + call stdlib${ii}$_${ci}$lacgv( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( k-2, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) 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 @@ -38579,32 +38571,32 @@ module stdlib_linalg_lapack_${ci}$ ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 a( jj, jj ) = real( a( jj, jj ),KIND=${ck}$) - call stdlib_${ci}$gemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& - kw+1 ), ldw, cone,a( j, jj ), 1 ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& + kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ ) a( jj, jj ) = real( a( jj, jj ),KIND=${ck}$) end do ! update the rectangular superdiagonal block - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( 1, k+1 ), & - lda, w( j, kw+1 ), ldw,cone, a( 1, j ), lda ) + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( 1_${ik}$, k+1 ), & + lda, w( j, kw+1 ), ldw,cone, a( 1_${ik}$, j ), lda ) end do ! put u12 in standard form by partially undoing the interchanges ! in columns k+1:n 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_${ci}$swap( n-j+1, a( jp, j ), lda, a( jj, j ), & + j = j + 1_${ik}$ + if( jp/=jj .and. j<=n )call stdlib${ii}$_${ci}$swap( n-j+1, a( jp, j ), lda, a( jj, j ), & lda ) if( j=nb .and. nbn )go to 90 - kstep = 1 + kstep = 1_${ik}$ ! copy column k of a to column k of w and update it w( k, k ) = real( a( k, k ),KIND=${ck}$) - if( k1 )call stdlib_${ci}$swap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_${ci}$swap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + if( k>1_${ik}$ )call stdlib${ii}$_${ci}$swap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) + call stdlib${ii}$_${ci}$swap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of w now holds ! w(k) = l(k)*d(k), ! where l(k) is the k-th column of l @@ -38725,15 +38717,15 @@ module stdlib_linalg_lapack_${ci}$ ! (note: no need to use for hermitian matrix ! a( k, k ) = real( w( k, k),KIND=${ck}$) to separately copy diagonal ! element d(k,k) from w (potentially saves only one load)) - call stdlib_${ci}$copy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib${ii}$_${ci}$copy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ ) if( k=1 )call stdlib_${ci}$swap( j, a( jp, 1 ), lda, a( jj, 1 ), lda ) + j = j - 1_${ik}$ + if( jp/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_${ci}$swap( 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_${ci}$lahef + end subroutine stdlib${ii}$_${ci}$lahef - pure subroutine stdlib_${ci}$lahef_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) + pure subroutine stdlib${ii}$_${ci}$lahef_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) !! DLAHEF_AA factorizes a panel of a complex hermitian matrix A using !! the Aasen's algorithm. The panel consists of a set of NB rows of A !! when UPLO is U, or a set of NB columns when UPLO is L. @@ -38871,23 +38863,23 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: m, nb, j1, lda, ldh + integer(${ik}$), intent(in) :: m, nb, j1, lda, ldh ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(${ck}$), intent(inout) :: a(lda,*), h(ldh,*) complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: j, k, k1, i1, i2, mj + integer(${ik}$) :: j, k, k1, i1, i2, mj complex(${ck}$) :: piv, alpha ! Intrinsic Functions intrinsic :: real,conjg,max ! Executable Statements - j = 1 + j = 1_${ik}$ ! k1 is the first column of the panel to be factorized ! i.e., k1 is 2 for the first block column, and 1 for the rest of the blocks - k1 = (2-j1)+1 + k1 = (2_${ik}$-j1)+1_${ik}$ if( stdlib_lsame( uplo, 'U' ) ) then ! ..................................................... ! factorize a as u**t*d*u using the upper triangle of a @@ -38895,100 +38887,100 @@ module stdlib_linalg_lapack_${ci}$ 10 continue if ( j>min(m, nb) )go to 20 ! k is the column to be factorized - ! when being called from stdlib_${ci}$hetrf_aa, + ! when being called from stdlib${ii}$_${ci}$hetrf_aa, ! > for the first block column, j1 is 1, hence j1+j-1 is j, ! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1, k = j1+j-1 if( j==m ) then ! only need to compute t(j, j) - mj = 1 + mj = 1_${ik}$ else mj = m-j+1 end if ! h(j:n, j) := a(j, j:n) - h(j:n, 1:(j-1)) * l(j1:(j-1), j), ! where h(j:n, j) has been initialized to be a(j, j:n) - if( k>2 ) then + if( k>2_${ik}$ ) then ! k is the column to be factorized ! > for the first block column, k is j, skipping the first two ! columns ! > for the rest of the columns, k is j+1, skipping only the ! first column - call stdlib_${ci}$lacgv( j-k1, a( 1, j ), 1 ) - call stdlib_${ci}$gemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( 1, j ), 1,& - cone, h( j, j ), 1 ) - call stdlib_${ci}$lacgv( j-k1, a( 1, j ), 1 ) + call stdlib${ii}$_${ci}$lacgv( j-k1, a( 1_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( 1_${ik}$, j ), 1_${ik}$,& + cone, h( j, j ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( j-k1, a( 1_${ik}$, j ), 1_${ik}$ ) end if ! copy h(i:n, i) into work - call stdlib_${ci}$copy( mj, h( j, j ), 1, work( 1 ), 1 ) + call stdlib${ii}$_${ci}$copy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) if( j>k1 ) then ! compute work := work - l(j-1, j:n) * t(j-1,j), ! where a(j-1, j) stores t(j-1, j) and a(j-2, j:n) stores u(j-1, j:n) alpha = -conjg( a( k-1, j ) ) - call stdlib_${ci}$axpy( mj, alpha, a( k-2, j ), lda, work( 1 ), 1 ) + call stdlib${ii}$_${ci}$axpy( mj, alpha, a( k-2, j ), lda, work( 1_${ik}$ ), 1_${ik}$ ) end if ! set a(j, j) = t(j, j) - a( k, j ) = real( work( 1 ),KIND=${ck}$) + a( k, j ) = real( work( 1_${ik}$ ),KIND=${ck}$) if( j1 ) then + if( k>1_${ik}$ ) then alpha = -a( k, j ) - call stdlib_${ci}$axpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2 ), 1 ) + call stdlib${ii}$_${ci}$axpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2_${ik}$ ), 1_${ik}$ ) endif ! find max(|work(2:n)|) - i2 = stdlib_i${ci}$amax( m-j, work( 2 ), 1 ) + 1 + i2 = stdlib${ii}$_i${ci}$amax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$ piv = work( i2 ) ! apply hermitian pivot - if( (i2/=2) .and. (piv/=0) ) then + if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then ! swap work(i1) and work(i2) - i1 = 2 + i1 = 2_${ik}$ work( i2 ) = work( i1 ) work( i1 ) = piv ! swap a(i1, i1+1:n) with a(i1+1:n, i2) i1 = i1+j-1 i2 = i2+j-1 - call stdlib_${ci}$swap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1 ) + call stdlib${ii}$_${ci}$swap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1_${ik}$ ) - call stdlib_${ci}$lacgv( i2-i1, a( j1+i1-1, i1+1 ), lda ) - call stdlib_${ci}$lacgv( i2-i1-1, a( j1+i1, i2 ), 1 ) + call stdlib${ii}$_${ci}$lacgv( i2-i1, a( j1+i1-1, i1+1 ), lda ) + call stdlib${ii}$_${ci}$lacgv( i2-i1-1, a( j1+i1, i2 ), 1_${ik}$ ) ! swap a(i1, i2+1:n) with a(i2, i2+1:n) - if( i2(k1-1) ) then ! swap l(1:i1-1, i1) with l(1:i1-1, i2), ! skipping the first column - call stdlib_${ci}$swap( i1-k1+1, a( 1, i1 ), 1,a( 1, i2 ), 1 ) + call stdlib${ii}$_${ci}$swap( i1-k1+1, a( 1_${ik}$, i1 ), 1_${ik}$,a( 1_${ik}$, i2 ), 1_${ik}$ ) end if else ipiv( j+1 ) = j+1 endif ! set a(j, j+1) = t(j, j+1) - a( k, j+1 ) = work( 2 ) + a( k, j+1 ) = work( 2_${ik}$ ) if( jmin( m, nb ) )go to 40 ! k is the column to be factorized - ! when being called from stdlib_${ci}$hetrf_aa, + ! when being called from stdlib${ii}$_${ci}$hetrf_aa, ! > for the first block column, j1 is 1, hence j1+j-1 is j, ! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1, k = j1+j-1 if( j==m ) then ! only need to compute t(j, j) - mj = 1 + mj = 1_${ik}$ else mj = m-j+1 end if ! h(j:n, j) := a(j:n, j) - h(j:n, 1:(j-1)) * l(j, j1:(j-1))^t, ! where h(j:n, j) has been initialized to be a(j:n, j) - if( k>2 ) then + if( k>2_${ik}$ ) then ! k is the column to be factorized ! > for the first block column, k is j, skipping the first two ! columns ! > for the rest of the columns, k is j+1, skipping only the ! first column - call stdlib_${ci}$lacgv( j-k1, a( j, 1 ), lda ) - call stdlib_${ci}$gemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( j, 1 ), & - lda,cone, h( j, j ), 1 ) - call stdlib_${ci}$lacgv( j-k1, a( j, 1 ), lda ) + call stdlib${ii}$_${ci}$lacgv( j-k1, a( j, 1_${ik}$ ), lda ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( j, 1_${ik}$ ), & + lda,cone, h( j, j ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( j-k1, a( j, 1_${ik}$ ), lda ) end if ! copy h(j:n, j) into work - call stdlib_${ci}$copy( mj, h( j, j ), 1, work( 1 ), 1 ) + call stdlib${ii}$_${ci}$copy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) if( j>k1 ) then ! compute work := work - l(j:n, j-1) * t(j-1,j), ! where a(j-1, j) = t(j-1, j) and a(j, j-2) = l(j, j-1) alpha = -conjg( a( j, k-1 ) ) - call stdlib_${ci}$axpy( mj, alpha, a( j, k-2 ), 1, work( 1 ), 1 ) + call stdlib${ii}$_${ci}$axpy( mj, alpha, a( j, k-2 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) end if ! set a(j, j) = t(j, j) - a( j, k ) = real( work( 1 ),KIND=${ck}$) + a( j, k ) = real( work( 1_${ik}$ ),KIND=${ck}$) if( j1 ) then + if( k>1_${ik}$ ) then alpha = -a( j, k ) - call stdlib_${ci}$axpy( m-j, alpha, a( j+1, k-1 ), 1,work( 2 ), 1 ) + call stdlib${ii}$_${ci}$axpy( m-j, alpha, a( j+1, k-1 ), 1_${ik}$,work( 2_${ik}$ ), 1_${ik}$ ) endif ! find max(|work(2:n)|) - i2 = stdlib_i${ci}$amax( m-j, work( 2 ), 1 ) + 1 + i2 = stdlib${ii}$_i${ci}$amax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$ piv = work( i2 ) ! apply hermitian pivot - if( (i2/=2) .and. (piv/=0) ) then + if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then ! swap work(i1) and work(i2) - i1 = 2 + i1 = 2_${ik}$ work( i2 ) = work( i1 ) work( i1 ) = piv ! swap a(i1+1:n, i1) with a(i2, i1+1:n) i1 = i1+j-1 i2 = i2+j-1 - call stdlib_${ci}$swap( i2-i1-1, a( i1+1, j1+i1-1 ), 1,a( i2, j1+i1 ), lda ) + call stdlib${ii}$_${ci}$swap( i2-i1-1, a( i1+1, j1+i1-1 ), 1_${ik}$,a( i2, j1+i1 ), lda ) - call stdlib_${ci}$lacgv( i2-i1, a( i1+1, j1+i1-1 ), 1 ) - call stdlib_${ci}$lacgv( i2-i1-1, a( i2, j1+i1 ), lda ) + call stdlib${ii}$_${ci}$lacgv( i2-i1, a( i1+1, j1+i1-1 ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( i2-i1-1, a( i2, j1+i1 ), lda ) ! swap a(i2+1:n, i1) with a(i2+1:n, i2) - if( i2(k1-1) ) then ! swap l(1:i1-1, i1) with l(1:i1-1, i2), ! skipping the first column - call stdlib_${ci}$swap( i1-k1+1, a( i1, 1 ), lda,a( i2, 1 ), lda ) + call stdlib${ii}$_${ci}$swap( i1-k1+1, a( i1, 1_${ik}$ ), lda,a( i2, 1_${ik}$ ), lda ) end if else ipiv( j+1 ) = j+1 endif ! set a(j+1, j) = t(j+1, j) - a( j+1, k ) = work( 2 ) + a( j+1, k ) = work( 2_${ik}$ ) if( j1 )call stdlib_${ci}$copy( k-1, a( 1, k ), 1, w( 1, kw ), 1 ) + if( k>1_${ik}$ )call stdlib${ii}$_${ci}$copy( k-1, a( 1_${ik}$, k ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) w( k, kw ) = real( a( k, k ),KIND=${ck}$) if( k1 ) then - imax = stdlib_i${ci}$amax( k-1, w( 1, kw ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_i${ci}$amax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) colmax = cabs1( w( imax, kw ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k a( k, k ) = real( w( k, kw ),KIND=${ck}$) - if( k>1 )call stdlib_${ci}$copy( k-1, w( 1, kw ), 1, a( 1, k ), 1 ) + if( k>1_${ik}$ )call stdlib${ii}$_${ci}$copy( k-1, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) ! set e( k ) to zero - if( k>1 )e( k ) = czero + if( k>1_${ik}$ )e( k ) = czero else ! ============================================================ ! begin pivot search @@ -39206,28 +39198,28 @@ module stdlib_linalg_lapack_${ci}$ 12 continue ! begin pivot search loop body ! copy column imax to column kw-1 of w and update it - if( imax>1 )call stdlib_${ci}$copy( imax-1, a( 1, imax ), 1, w( 1, kw-1 ),1 ) + if( imax>1_${ik}$ )call stdlib${ii}$_${ci}$copy( imax-1, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ),1_${ik}$ ) w( imax, kw-1 ) = real( a( imax, imax ),KIND=${ck}$) - call stdlib_${ci}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_${ci}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ ) - call stdlib_${ci}$lacgv( k-imax, w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_${ci}$lacgv( k-imax, w( imax+1, kw-1 ), 1_${ik}$ ) if( k1 ) then - itemp = stdlib_i${ci}$amax( imax-1, w( 1, kw-1 ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_i${ci}$amax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) dtemp = cabs1( w( itemp, kw-1 ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -39244,7 +39236,7 @@ module stdlib_linalg_lapack_${ci}$ ! use 1-by-1 pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_${ci}$copy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) done = .true. ! case(3) ! equivalent to testing for rowmax==colmax, @@ -39253,7 +39245,7 @@ module stdlib_linalg_lapack_${ci}$ ! interchange rows and columns k-1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. ! case(4) else @@ -39262,7 +39254,7 @@ module stdlib_linalg_lapack_${ci}$ colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_${ci}$copy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) end if ! end pivot search loop body if( .not.done ) goto 12 @@ -39270,26 +39262,26 @@ module stdlib_linalg_lapack_${ci}$ ! end pivot search ! ============================================================ ! 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 p and k. ! updated column p is already stored in column kw of w. - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p of submatrix a ! at step k. no need to copy element into columns ! k and k-1 of a for 2-by-2 pivot, since these columns ! will be later overwritten. a( p, p ) = real( a( k, k ),KIND=${ck}$) - call stdlib_${ci}$copy( k-1-p, a( p+1, k ), 1, a( p, p+1 ),lda ) - call stdlib_${ci}$lacgv( k-1-p, a( p, p+1 ), lda ) - if( p>1 )call stdlib_${ci}$copy( p-1, a( 1, k ), 1, a( 1, p ), 1 ) + call stdlib${ii}$_${ci}$copy( k-1-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda ) + call stdlib${ii}$_${ci}$lacgv( k-1-p, a( p, p+1 ), lda ) + if( p>1_${ik}$ )call stdlib${ii}$_${ci}$copy( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) ! interchange rows k and p in the last k+1 to n columns of a ! (columns k and k-1 of a for 2-by-2 pivot will be ! later overwritten). interchange rows k and p ! in last kkw to nb columns of w. - if( k1 )call stdlib_${ci}$copy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_${ci}$copy( kk-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) + call stdlib${ii}$_${ci}$lacgv( kk-1-kp, a( kp, kp+1 ), lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_${ci}$copy( 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 ! later overwritten). interchange rows kk and kp ! in last kkw to nb columns of w. - if( k1 ) then + call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) + if( k>1_${ik}$ ) then ! (note: no need to check if a(k,k) is not zero, ! since that was ensured earlier in pivot search: ! case a(k,k) = 0 falls into 2x2 pivot case(3)) @@ -39331,14 +39323,14 @@ module stdlib_linalg_lapack_${ci}$ t = real( a( k, k ),KIND=${ck}$) if( abs( t )>=sfmin ) then r1 = one / t - call stdlib_${ci}$dscal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_${ci}$dscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) else do ii = 1, k-1 a( ii, k ) = a( ii, k ) / t end do end if ! (2) conjugate column w(kw) - call stdlib_${ci}$lacgv( k-1, w( 1, kw ), 1 ) + call stdlib${ii}$_${ci}$lacgv( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) ! store the superdiagonal element of d in array e e( k ) = czero end if @@ -39354,7 +39346,7 @@ module stdlib_linalg_lapack_${ci}$ ! a(k-1:k,k-1:k) := d(k-1:k,k-1:k) = w(k-1:k,kw-1:kw) ! a(1:k-2,k-1:k) := u(1:k-2,k:k-1:k) = ! = w(1:k-2,kw-1:kw) * ( d(k-1:k,k-1:k)**(-1) ) - if( k>2 ) then + if( k>2_${ik}$ ) then ! factor out the columns of the inverse of 2-by-2 pivot ! block d, so that each column contains 1, to reduce the ! number of flops when we multiply panel @@ -39408,13 +39400,13 @@ module stdlib_linalg_lapack_${ci}$ e( k ) = w( k-1, kw ) e( k-1 ) = czero ! (2) conjugate columns w(kw) and w(kw-1) - call stdlib_${ci}$lacgv( k-1, w( 1, kw ), 1 ) - call stdlib_${ci}$lacgv( k-2, w( 1, kw-1 ), 1 ) + call stdlib${ii}$_${ci}$lacgv( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( k-2, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) end if ! 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 @@ -39433,13 +39425,13 @@ module stdlib_linalg_lapack_${ci}$ ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 a( jj, jj ) = real( a( jj, jj ),KIND=${ck}$) - call stdlib_${ci}$gemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& - kw+1 ), ldw, cone,a( j, jj ), 1 ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& + kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ ) a( jj, jj ) = real( a( jj, jj ),KIND=${ck}$) end do ! update the rectangular superdiagonal block - if( j>=2 )call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( & - 1, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1, j ), lda ) + if( j>=2_${ik}$ )call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( & + 1_${ik}$, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1_${ik}$, j ), lda ) end do ! set kb to the number of columns factorized kb = n - k @@ -39450,18 +39442,18 @@ module stdlib_linalg_lapack_${ci}$ ! initialize the unused last entry of the subdiagonal array e. e( n ) = czero ! k is the main loop index, increasing from 1 in steps of 1 or 2 - k = 1 + 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 column k of w w( k, k ) = real( a( k, k ),KIND=${ck}$) - if( k1 ) then - call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ),lda, w( k, 1 ), & - ldw, cone, w( k, k ), 1 ) + if( k1_${ik}$ ) then + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ),lda, w( k, 1_${ik}$ ), & + ldw, cone, w( k, k ), 1_${ik}$ ) w( k, k ) = real( w( k, k ),KIND=${ck}$) end if ! determine rows and columns to be interchanged and whether @@ -39471,17 +39463,17 @@ module stdlib_linalg_lapack_${ci}$ ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k1 ) then - call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1 ), lda, w( & - imax, 1 ), ldw,cone, w( k, k+1 ), 1 ) + if( imax1_${ik}$ ) then + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1_${ik}$ ), lda, w( & + imax, 1_${ik}$ ), ldw,cone, w( k, k+1 ), 1_${ik}$ ) w( imax, k+1 ) = real( w( imax, k+1 ),KIND=${ck}$) end if ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = k - 1 + stdlib_i${ci}$amax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1_${ik}$ + stdlib${ii}$_i${ci}$amax( imax-k, w( k, k+1 ), 1_${ik}$ ) rowmax = cabs1( w( jmax, k+1 ) ) else rowmax = zero end if if( imaxrowmax ) then rowmax = dtemp @@ -39536,7 +39528,7 @@ module stdlib_linalg_lapack_${ci}$ ! use 1-by-1 pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_${ci}$copy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_${ci}$copy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) done = .true. ! case(3) ! equivalent to testing for rowmax==colmax, @@ -39545,7 +39537,7 @@ module stdlib_linalg_lapack_${ci}$ ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. ! case(4) else @@ -39554,7 +39546,7 @@ module stdlib_linalg_lapack_${ci}$ colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_${ci}$copy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_${ci}$copy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) end if ! end pivot search loop body if( .not.done ) goto 72 @@ -39562,24 +39554,24 @@ module stdlib_linalg_lapack_${ci}$ ! end pivot search ! ============================================================ ! kk is the column of a where pivoting step stopped - kk = k + kstep - 1 + kk = k + kstep - 1_${ik}$ ! interchange rows and columns p and k (only for 2-by-2 pivot). ! updated column p is already stored in column k of w. - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column kk-1 to column p of submatrix a ! at step k. no need to copy element into columns ! k and k+1 of a for 2-by-2 pivot, since these columns ! will be later overwritten. a( p, p ) = real( a( k, k ),KIND=${ck}$) - call stdlib_${ci}$copy( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) - call stdlib_${ci}$lacgv( p-k-1, a( p, k+1 ), lda ) - if( p1 )call stdlib_${ci}$swap( k-1, a( k, 1 ), lda, a( p, 1 ), lda ) - call stdlib_${ci}$swap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw ) + if( k>1_${ik}$ )call stdlib${ii}$_${ci}$swap( k-1, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda ) + call stdlib${ii}$_${ci}$swap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw ) end if ! interchange rows and columns kp and kk. ! updated column kp is already stored in column kk of w. @@ -39589,18 +39581,18 @@ module stdlib_linalg_lapack_${ci}$ ! (or k and k+1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = real( a( kk, kk ),KIND=${ck}$) - call stdlib_${ci}$copy( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),lda ) - call stdlib_${ci}$lacgv( kp-kk-1, a( kp, kk+1 ), lda ) - if( kp1 )call stdlib_${ci}$swap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_${ci}$swap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + if( k>1_${ik}$ )call stdlib${ii}$_${ci}$swap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) + call stdlib${ii}$_${ci}$swap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of w now holds ! w(k) = l(k)*d(k), ! where l(k) is the k-th column of l @@ -39613,7 +39605,7 @@ module stdlib_linalg_lapack_${ci}$ ! (note: no need to use for hermitian matrix ! a( k, k ) = real( w( k, k),KIND=${ck}$) to separately copy diagonal ! element d(k,k) from w (potentially saves only one load)) - call stdlib_${ci}$copy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib${ii}$_${ci}$copy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ ) if( k=sfmin ) then r1 = one / t - call stdlib_${ci}$dscal( n-k, r1, a( k+1, k ), 1 ) + call stdlib${ii}$_${ci}$dscal( n-k, r1, a( k+1, k ), 1_${ik}$ ) else do ii = k + 1, n a( ii, k ) = a( ii, k ) / t end do end if ! (2) conjugate column w(k) - call stdlib_${ci}$lacgv( n-k, w( k+1, k ), 1 ) + call stdlib${ii}$_${ci}$lacgv( n-k, w( k+1, k ), 1_${ik}$ ) ! store the subdiagonal element of d in array e e( k ) = czero end if @@ -39699,13 +39691,13 @@ module stdlib_linalg_lapack_${ci}$ e( k ) = w( k+1, k ) e( k+1 ) = czero ! (2) conjugate columns w(k) and w(k+1) - call stdlib_${ci}$lacgv( n-k, w( k+1, k ), 1 ) - call stdlib_${ci}$lacgv( n-k-1, w( k+2, k+1 ), 1 ) + call stdlib${ii}$_${ci}$lacgv( n-k, w( k+1, k ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( n-k-1, w( k+2, k+1 ), 1_${ik}$ ) end if ! 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 @@ -39724,22 +39716,22 @@ module stdlib_linalg_lapack_${ci}$ ! update the lower triangle of the diagonal block do jj = j, j + jb - 1 a( jj, jj ) = real( a( jj, jj ),KIND=${ck}$) - call stdlib_${ci}$gemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1 ), lda, w( jj,& - 1 ), ldw, cone,a( jj, jj ), 1 ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1_${ik}$ ), lda, w( jj,& + 1_${ik}$ ), ldw, cone,a( jj, jj ), 1_${ik}$ ) a( jj, jj ) = real( a( jj, jj ),KIND=${ck}$) end do ! update the rectangular subdiagonal block - if( j+jb<=n )call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& - cone, a( j+jb, 1 ), lda, w( j, 1 ),ldw, cone, a( j+jb, j ), lda ) + if( j+jb<=n )call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& + cone, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ),ldw, cone, a( j+jb, j ), lda ) end do ! set kb to the number of columns factorized - kb = k - 1 + kb = k - 1_${ik}$ end if return - end subroutine stdlib_${ci}$lahef_rk + end subroutine stdlib${ii}$_${ci}$lahef_rk - pure subroutine stdlib_${ci}$lahef_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) + pure subroutine stdlib${ii}$_${ci}$lahef_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) !! ZLAHEF_ROOK: computes a partial factorization of a complex Hermitian !! matrix A using the bounded Bunch-Kaufman ("rook") diagonal pivoting !! method. The partial factorization has the form: @@ -39758,10 +39750,10 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: w(ldw,*) ! ===================================================================== @@ -39772,7 +39764,7 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: done - integer(ilp) :: imax, itemp, ii, j, jb, jj, jmax, jp1, jp2, k, kk, kkw, kp, kstep, kw, & + integer(${ik}$) :: imax, itemp, ii, j, jb, jj, jmax, jp1, jp2, k, kk, kkw, kp, kstep, kw, & p real(${ck}$) :: absakk, alpha, colmax, dtemp, r1, rowmax, t, sfmin complex(${ck}$) :: d11, d21, d22, z @@ -39783,11 +39775,11 @@ module stdlib_linalg_lapack_${ci}$ ! Statement Function Definitions cabs1( z ) = abs( real( z,KIND=${ck}$) ) + abs( aimag( z ) ) ! 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_${c2ri(ci)}$lamch( 'S' ) + sfmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' ) if( stdlib_lsame( uplo, 'U' ) ) then ! factorize the trailing columns of a using the upper triangle ! of a and working backwards, and compute the matrix w = u12*d @@ -39799,14 +39791,14 @@ module stdlib_linalg_lapack_${ci}$ kw = nb + k - n ! exit from loop if( ( k<=n-nb+1 .and. nb1 )call stdlib_${ci}$copy( k-1, a( 1, k ), 1, w( 1, kw ), 1 ) + if( k>1_${ik}$ )call stdlib${ii}$_${ci}$copy( k-1, a( 1_${ik}$, k ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) w( k, kw ) = real( a( k, k ),KIND=${ck}$) if( k1 ) then - imax = stdlib_i${ci}$amax( k-1, w( 1, kw ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_i${ci}$amax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) colmax = cabs1( w( imax, kw ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k a( k, k ) = real( w( k, kw ),KIND=${ck}$) - if( k>1 )call stdlib_${ci}$copy( k-1, w( 1, kw ), 1, a( 1, k ), 1 ) + if( k>1_${ik}$ )call stdlib${ii}$_${ci}$copy( k-1, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) else ! ============================================================ ! begin pivot search @@ -39842,28 +39834,28 @@ module stdlib_linalg_lapack_${ci}$ 12 continue ! begin pivot search loop body ! copy column imax to column kw-1 of w and update it - if( imax>1 )call stdlib_${ci}$copy( imax-1, a( 1, imax ), 1, w( 1, kw-1 ),1 ) + if( imax>1_${ik}$ )call stdlib${ii}$_${ci}$copy( imax-1, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ),1_${ik}$ ) w( imax, kw-1 ) = real( a( imax, imax ),KIND=${ck}$) - call stdlib_${ci}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_${ci}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ ) - call stdlib_${ci}$lacgv( k-imax, w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_${ci}$lacgv( k-imax, w( imax+1, kw-1 ), 1_${ik}$ ) if( k1 ) then - itemp = stdlib_i${ci}$amax( imax-1, w( 1, kw-1 ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_i${ci}$amax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) dtemp = cabs1( w( itemp, kw-1 ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -39880,7 +39872,7 @@ module stdlib_linalg_lapack_${ci}$ ! use 1-by-1 pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_${ci}$copy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) done = .true. ! case(3) ! equivalent to testing for rowmax==colmax, @@ -39889,7 +39881,7 @@ module stdlib_linalg_lapack_${ci}$ ! interchange rows and columns k-1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. ! case(4) else @@ -39898,7 +39890,7 @@ module stdlib_linalg_lapack_${ci}$ colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_${ci}$copy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) end if ! end pivot search loop body if( .not.done ) goto 12 @@ -39906,26 +39898,26 @@ module stdlib_linalg_lapack_${ci}$ ! end pivot search ! ============================================================ ! 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 p and k. ! updated column p is already stored in column kw of w. - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p of submatrix a ! at step k. no need to copy element into columns ! k and k-1 of a for 2-by-2 pivot, since these columns ! will be later overwritten. a( p, p ) = real( a( k, k ),KIND=${ck}$) - call stdlib_${ci}$copy( k-1-p, a( p+1, k ), 1, a( p, p+1 ),lda ) - call stdlib_${ci}$lacgv( k-1-p, a( p, p+1 ), lda ) - if( p>1 )call stdlib_${ci}$copy( p-1, a( 1, k ), 1, a( 1, p ), 1 ) + call stdlib${ii}$_${ci}$copy( k-1-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda ) + call stdlib${ii}$_${ci}$lacgv( k-1-p, a( p, p+1 ), lda ) + if( p>1_${ik}$ )call stdlib${ii}$_${ci}$copy( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) ! interchange rows k and p in the last k+1 to n columns of a ! (columns k and k-1 of a for 2-by-2 pivot will be ! later overwritten). interchange rows k and p ! in last kkw to nb columns of w. - if( k1 )call stdlib_${ci}$copy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_${ci}$copy( kk-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) + call stdlib${ii}$_${ci}$lacgv( kk-1-kp, a( kp, kp+1 ), lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_${ci}$copy( 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 ! later overwritten). interchange rows kk and kp ! in last kkw to nb columns of w. - if( k1 ) then + call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) + if( k>1_${ik}$ ) then ! (note: no need to check if a(k,k) is not zero, ! since that was ensured earlier in pivot search: ! case a(k,k) = 0 falls into 2x2 pivot case(3)) @@ -39967,14 +39959,14 @@ module stdlib_linalg_lapack_${ci}$ t = real( a( k, k ),KIND=${ck}$) if( abs( t )>=sfmin ) then r1 = one / t - call stdlib_${ci}$dscal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_${ci}$dscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) else do ii = 1, k-1 a( ii, k ) = a( ii, k ) / t end do end if ! (2) conjugate column w(kw) - call stdlib_${ci}$lacgv( k-1, w( 1, kw ), 1 ) + call stdlib${ii}$_${ci}$lacgv( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) end if else ! 2-by-2 pivot block d(k): columns kw and kw-1 of w now hold @@ -39988,7 +39980,7 @@ module stdlib_linalg_lapack_${ci}$ ! a(k-1:k,k-1:k) := d(k-1:k,k-1:k) = w(k-1:k,kw-1:kw) ! a(1:k-2,k-1:k) := u(1:k-2,k:k-1:k) = ! = w(1:k-2,kw-1:kw) * ( d(k-1:k,k-1:k)**(-1) ) - if( k>2 ) then + if( k>2_${ik}$ ) then ! factor out the columns of the inverse of 2-by-2 pivot ! block d, so that each column contains 1, to reduce the ! number of flops when we multiply panel @@ -40038,12 +40030,12 @@ module stdlib_linalg_lapack_${ci}$ a( k-1, k ) = w( k-1, kw ) a( k, k ) = w( k, kw ) ! (2) conjugate columns w(kw) and w(kw-1) - call stdlib_${ci}$lacgv( k-1, w( 1, kw ), 1 ) - call stdlib_${ci}$lacgv( k-2, w( 1, kw-1 ), 1 ) + call stdlib${ii}$_${ci}$lacgv( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( k-2, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) 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 @@ -40062,39 +40054,39 @@ module stdlib_linalg_lapack_${ci}$ ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 a( jj, jj ) = real( a( jj, jj ),KIND=${ck}$) - call stdlib_${ci}$gemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& - kw+1 ), ldw, cone,a( j, jj ), 1 ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& + kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ ) a( jj, jj ) = real( a( jj, jj ),KIND=${ck}$) end do ! update the rectangular superdiagonal block - if( j>=2 )call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( & - 1, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1, j ), lda ) + if( j>=2_${ik}$ )call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( & + 1_${ik}$, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1_${ik}$, j ), lda ) end do ! put u12 in standard form by partially undoing the interchanges ! in of rows 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 j and jp2 ! (or j and jp2, and j+1 and jp1) at each step j - kstep = 1 - jp1 = 1 + kstep = 1_${ik}$ + jp1 = 1_${ik}$ ! (here, j is a diagonal index) jj = j jp2 = ipiv( j ) - if( jp2<0 ) then + if( jp2<0_${ik}$ ) then jp2 = -jp2 ! (here, j is a diagonal index) - j = j + 1 + j = j + 1_${ik}$ jp1 = -ipiv( j ) - kstep = 2 + kstep = 2_${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( jp2/=jj .and. j<=n )call stdlib_${ci}$swap( n-j+1, a( jp2, j ), lda, a( jj, j ), & + j = j + 1_${ik}$ + if( jp2/=jj .and. j<=n )call stdlib${ii}$_${ci}$swap( n-j+1, a( jp2, j ), lda, a( jj, j ), & lda ) - jj = jj + 1 - if( kstep==2 .and. jp1/=jj .and. j<=n )call stdlib_${ci}$swap( n-j+1, a( jp1, j ), & + jj = jj + 1_${ik}$ + if( kstep==2_${ik}$ .and. jp1/=jj .and. j<=n )call stdlib${ii}$_${ci}$swap( n-j+1, a( jp1, j ), & lda, a( jj, j ), lda ) if( j=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 column k of w w( k, k ) = real( a( k, k ),KIND=${ck}$) - if( k1 ) then - call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ),lda, w( k, 1 ), & - ldw, cone, w( k, k ), 1 ) + if( k1_${ik}$ ) then + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ),lda, w( k, 1_${ik}$ ), & + ldw, cone, w( k, k ), 1_${ik}$ ) w( k, k ) = real( w( k, k ),KIND=${ck}$) end if ! determine rows and columns to be interchanged and whether @@ -40125,17 +40117,17 @@ module stdlib_linalg_lapack_${ci}$ ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k1 ) then - call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1 ), lda, w( & - imax, 1 ), ldw,cone, w( k, k+1 ), 1 ) + if( imax1_${ik}$ ) then + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1_${ik}$ ), lda, w( & + imax, 1_${ik}$ ), ldw,cone, w( k, k+1 ), 1_${ik}$ ) w( imax, k+1 ) = real( w( imax, k+1 ),KIND=${ck}$) end if ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = k - 1 + stdlib_i${ci}$amax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1_${ik}$ + stdlib${ii}$_i${ci}$amax( imax-k, w( k, k+1 ), 1_${ik}$ ) rowmax = cabs1( w( jmax, k+1 ) ) else rowmax = zero end if if( imaxrowmax ) then rowmax = dtemp @@ -40188,7 +40180,7 @@ module stdlib_linalg_lapack_${ci}$ ! use 1-by-1 pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_${ci}$copy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_${ci}$copy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) done = .true. ! case(3) ! equivalent to testing for rowmax==colmax, @@ -40197,7 +40189,7 @@ module stdlib_linalg_lapack_${ci}$ ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. ! case(4) else @@ -40206,7 +40198,7 @@ module stdlib_linalg_lapack_${ci}$ colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_${ci}$copy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_${ci}$copy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) end if ! end pivot search loop body if( .not.done ) goto 72 @@ -40214,24 +40206,24 @@ module stdlib_linalg_lapack_${ci}$ ! end pivot search ! ============================================================ ! kk is the column of a where pivoting step stopped - kk = k + kstep - 1 + kk = k + kstep - 1_${ik}$ ! interchange rows and columns p and k (only for 2-by-2 pivot). ! updated column p is already stored in column k of w. - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column kk-1 to column p of submatrix a ! at step k. no need to copy element into columns ! k and k+1 of a for 2-by-2 pivot, since these columns ! will be later overwritten. a( p, p ) = real( a( k, k ),KIND=${ck}$) - call stdlib_${ci}$copy( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) - call stdlib_${ci}$lacgv( p-k-1, a( p, k+1 ), lda ) - if( p1 )call stdlib_${ci}$swap( k-1, a( k, 1 ), lda, a( p, 1 ), lda ) - call stdlib_${ci}$swap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw ) + if( k>1_${ik}$ )call stdlib${ii}$_${ci}$swap( k-1, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda ) + call stdlib${ii}$_${ci}$swap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw ) end if ! interchange rows and columns kp and kk. ! updated column kp is already stored in column kk of w. @@ -40241,18 +40233,18 @@ module stdlib_linalg_lapack_${ci}$ ! (or k and k+1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = real( a( kk, kk ),KIND=${ck}$) - call stdlib_${ci}$copy( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),lda ) - call stdlib_${ci}$lacgv( kp-kk-1, a( kp, kk+1 ), lda ) - if( kp1 )call stdlib_${ci}$swap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_${ci}$swap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + if( k>1_${ik}$ )call stdlib${ii}$_${ci}$swap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) + call stdlib${ii}$_${ci}$swap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of w now holds ! w(k) = l(k)*d(k), ! where l(k) is the k-th column of l @@ -40265,7 +40257,7 @@ module stdlib_linalg_lapack_${ci}$ ! (note: no need to use for hermitian matrix ! a( k, k ) = real( w( k, k),KIND=${ck}$) to separately copy diagonal ! element d(k,k) from w (potentially saves only one load)) - call stdlib_${ci}$copy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib${ii}$_${ci}$copy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ ) if( k=sfmin ) then r1 = one / t - call stdlib_${ci}$dscal( n-k, r1, a( k+1, k ), 1 ) + call stdlib${ii}$_${ci}$dscal( n-k, r1, a( k+1, k ), 1_${ik}$ ) else do ii = k + 1, n a( ii, k ) = a( ii, k ) / t end do end if ! (2) conjugate column w(k) - call stdlib_${ci}$lacgv( n-k, w( k+1, k ), 1 ) + call stdlib${ii}$_${ci}$lacgv( n-k, w( k+1, k ), 1_${ik}$ ) end if else ! 2-by-2 pivot block d(k): columns k and k+1 of w now hold @@ -40345,12 +40337,12 @@ module stdlib_linalg_lapack_${ci}$ a( k+1, k ) = w( k+1, k ) a( k+1, k+1 ) = w( k+1, k+1 ) ! (2) conjugate columns w(k) and w(k+1) - call stdlib_${ci}$lacgv( n-k, w( k+1, k ), 1 ) - call stdlib_${ci}$lacgv( n-k-1, w( k+2, k+1 ), 1 ) + call stdlib${ii}$_${ci}$lacgv( n-k, w( k+1, k ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( n-k-1, w( k+2, k+1 ), 1_${ik}$ ) 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 @@ -40369,49 +40361,49 @@ module stdlib_linalg_lapack_${ci}$ ! update the lower triangle of the diagonal block do jj = j, j + jb - 1 a( jj, jj ) = real( a( jj, jj ),KIND=${ck}$) - call stdlib_${ci}$gemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1 ), lda, w( jj,& - 1 ), ldw, cone,a( jj, jj ), 1 ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1_${ik}$ ), lda, w( jj,& + 1_${ik}$ ), ldw, cone,a( jj, jj ), 1_${ik}$ ) a( jj, jj ) = real( a( jj, jj ),KIND=${ck}$) end do ! update the rectangular subdiagonal block - if( j+jb<=n )call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& - cone, a( j+jb, 1 ), lda, w( j, 1 ),ldw, cone, a( j+jb, j ), lda ) + if( j+jb<=n )call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& + cone, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ),ldw, cone, a( j+jb, j ), lda ) end do ! put l21 in standard form by partially undoing the interchanges ! of rows in columns 1:k-1 looping backwards from k-1 to 1 - j = k - 1 + j = k - 1_${ik}$ 120 continue ! undo the interchanges (if any) of rows j and jp2 ! (or j and jp2, and j-1 and jp1) at each step j - kstep = 1 - jp1 = 1 + kstep = 1_${ik}$ + jp1 = 1_${ik}$ ! (here, j is a diagonal index) jj = j jp2 = ipiv( j ) - if( jp2<0 ) then + if( jp2<0_${ik}$ ) then jp2 = -jp2 ! (here, j is a diagonal index) - j = j - 1 + j = j - 1_${ik}$ jp1 = -ipiv( j ) - kstep = 2 + kstep = 2_${ik}$ end if ! (note: here, j is used to determine row length. length j ! of the rows to swap back doesn't include diagonal element) - j = j - 1 - if( jp2/=jj .and. j>=1 )call stdlib_${ci}$swap( j, a( jp2, 1 ), lda, a( jj, 1 ), lda ) + j = j - 1_${ik}$ + if( jp2/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_${ci}$swap( j, a( jp2, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda ) - jj = jj -1 - if( kstep==2 .and. jp1/=jj .and. j>=1 )call stdlib_${ci}$swap( j, a( jp1, 1 ), lda, a(& - jj, 1 ), lda ) + jj = jj -1_${ik}$ + if( kstep==2_${ik}$ .and. jp1/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_${ci}$swap( j, a( jp1, 1_${ik}$ ), lda, a(& + jj, 1_${ik}$ ), lda ) if( j>1 )go to 120 ! set kb to the number of columns factorized - kb = k - 1 + kb = k - 1_${ik}$ end if return - end subroutine stdlib_${ci}$lahef_rook + end subroutine stdlib${ii}$_${ci}$lahef_rook - pure subroutine stdlib_${ci}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, info & + pure subroutine stdlib${ii}$_${ci}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, info & !! ZLAHQR: is an auxiliary routine called by CHSEQR to update the !! eigenvalues and Schur decomposition already computed by CHSEQR, by !! dealing with the Hessenberg submatrix in rows and columns ILO to @@ -40421,8 +40413,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, ihiz, ilo, iloz, ldh, ldz, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ihiz, ilo, iloz, ldh, ldz, n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt, wantz ! Array Arguments complex(${ck}$), intent(inout) :: h(ldh,*), z(ldz,*) @@ -40432,7 +40424,7 @@ module stdlib_linalg_lapack_${ci}$ real(${ck}$), parameter :: rzero = 0.0_${ck}$ real(${ck}$), parameter :: rone = 1.0_${ck}$ real(${ck}$), parameter :: dat1 = 3.0_${ck}$/4.0_${ck}$ - integer(ilp), parameter :: kexsh = 10 + integer(${ik}$), parameter :: kexsh = 10_${ik}$ @@ -40441,9 +40433,9 @@ module stdlib_linalg_lapack_${ci}$ complex(${ck}$) :: cdum, h11, h11s, h22, sc, sum, t, t1, temp, u, v2, x, y real(${ck}$) :: aa, ab, ba, bb, h10, h21, rtemp, s, safmax, safmin, smlnum, sx, t2, tst, & ulp - integer(ilp) :: i, i1, i2, its, itmax, j, jhi, jlo, k, l, m, nh, nz, kdefl + integer(${ik}$) :: i, i1, i2, its, itmax, j, jhi, jlo, k, l, m, nh, nz, kdefl ! Local Arrays - complex(${ck}$) :: v(2) + complex(${ck}$) :: v(2_${ik}$) ! Statement Functions real(${ck}$) :: cabs1 ! Intrinsic Functions @@ -40451,7 +40443,7 @@ module stdlib_linalg_lapack_${ci}$ ! Statement Function Definitions cabs1( cdum ) = abs( real( cdum,KIND=${ck}$) ) + abs( aimag( cdum ) ) ! Executable Statements - info = 0 + info = 0_${ik}$ ! quick return if possible if( n==0 )return if( ilo==ihi ) then @@ -40466,7 +40458,7 @@ module stdlib_linalg_lapack_${ci}$ if( ilo<=ihi-2 )h( ihi, ihi-2 ) = czero ! ==== ensure that subdiagonal entries are real ==== if( wantt ) then - jlo = 1 + jlo = 1_${ik}$ jhi = n else jlo = ilo @@ -40480,30 +40472,30 @@ module stdlib_linalg_lapack_${ci}$ sc = h( i, i-1 ) / cabs1( h( i, i-1 ) ) sc = conjg( sc ) / abs( sc ) h( i, i-1 ) = abs( h( i, i-1 ) ) - call stdlib_${ci}$scal( jhi-i+1, sc, h( i, i ), ldh ) - call stdlib_${ci}$scal( min( jhi, i+1 )-jlo+1, conjg( sc ),h( jlo, i ), 1 ) - if( wantz )call stdlib_${ci}$scal( ihiz-iloz+1, conjg( sc ), z( iloz, i ), 1 ) + call stdlib${ii}$_${ci}$scal( jhi-i+1, sc, h( i, i ), ldh ) + call stdlib${ii}$_${ci}$scal( min( jhi, i+1 )-jlo+1, conjg( sc ),h( jlo, i ), 1_${ik}$ ) + if( wantz )call stdlib${ii}$_${ci}$scal( ihiz-iloz+1, conjg( sc ), z( iloz, i ), 1_${ik}$ ) end if end do - nh = ihi - ilo + 1 - nz = ihiz - iloz + 1 + nh = ihi - ilo + 1_${ik}$ + nz = ihiz - iloz + 1_${ik}$ ! set machine-dependent constants for the stopping criterion. - safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safmax = rone / safmin - call stdlib_${c2ri(ci)}$labad( safmin, safmax ) - ulp = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + call stdlib${ii}$_${c2ri(ci)}$labad( safmin, safmax ) + ulp = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' ) smlnum = safmin*( real( nh,KIND=${ck}$) / ulp ) ! i1 and i2 are the indices of the first row and last column of h ! to which transformations must be applied. if eigenvalues only are ! being computed, i1 and i2 are set inside the main loop. if( wantt ) then - i1 = 1 + i1 = 1_${ik}$ i2 = n end if ! itmax is the total number of qr iterations allowed. - itmax = 30 * max( 10, nh ) + itmax = 30_${ik}$ * max( 10_${ik}$, nh ) ! kdefl counts the number of iterations since a deflation - kdefl = 0 + kdefl = 0_${ik}$ ! the main loop begins here. i is the loop index and decreases from ! ihi to ilo in steps of 1. each iteration of the loop works ! with the active submatrix in rows and columns l to i. @@ -40546,7 +40538,7 @@ module stdlib_linalg_lapack_${ci}$ end if ! exit from loop if a submatrix of order 1 has split off. if( l>=i )go to 140 - kdefl = kdefl + 1 + kdefl = kdefl + 1_${ik}$ ! now the active submatrix is in rows and columns l to i. if ! eigenvalues only are being computed, only the active submatrix ! need be transformed. @@ -40554,11 +40546,11 @@ module stdlib_linalg_lapack_${ci}$ i1 = l i2 = i end if - if( mod(kdefl,2*kexsh)==0 ) then + if( mod(kdefl,2_${ik}$*kexsh)==0_${ik}$ ) then ! exceptional shift. s = dat1*abs( real( h( i, i-1 ),KIND=${ck}$) ) t = s + h( i, i ) - else if( mod(kdefl,kexsh)==0 ) then + else if( mod(kdefl,kexsh)==0_${ik}$ ) then ! exceptional shift. s = dat1*abs( real( h( l+1, l ),KIND=${ck}$) ) t = s + h( l, l ) @@ -40571,12 +40563,12 @@ module stdlib_linalg_lapack_${ci}$ x = half*( h( i-1, i-1 )-t ) sx = cabs1( x ) s = max( s, cabs1( x ) ) - y = s*sqrt( ( x / s )**2+( u / s )**2 ) + y = s*sqrt( ( x / s )**2_${ik}$+( u / s )**2_${ik}$ ) if( sx>rzero ) then if( real( x / sx,KIND=${ck}$)*real( y,KIND=${ck}$)+aimag( x / sx )*aimag( y )& m )call stdlib_${ci}$copy( 2, h( k, k-1 ), 1, v, 1 ) - call stdlib_${ci}$larfg( 2, v( 1 ), v( 2 ), 1, t1 ) + if( k>m )call stdlib${ii}$_${ci}$copy( 2_${ik}$, h( k, k-1 ), 1_${ik}$, v, 1_${ik}$ ) + call stdlib${ii}$_${ci}$larfg( 2_${ik}$, v( 1_${ik}$ ), v( 2_${ik}$ ), 1_${ik}$, t1 ) if( k>m ) then - h( k, k-1 ) = v( 1 ) + h( k, k-1 ) = v( 1_${ik}$ ) h( k+1, k-1 ) = czero end if - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = real( t1*v2,KIND=${ck}$) ! apply g from the left to transform the rows of the matrix ! in columns k to i2. @@ -40659,10 +40651,10 @@ module stdlib_linalg_lapack_${ci}$ if( m+2<=i )h( m+2, m+1 ) = h( m+2, m+1 )*temp do j = m, i if( j/=m+1 ) then - if( i2>j )call stdlib_${ci}$scal( i2-j, temp, h( j, j+1 ), ldh ) - call stdlib_${ci}$scal( j-i1, conjg( temp ), h( i1, j ), 1 ) + if( i2>j )call stdlib${ii}$_${ci}$scal( i2-j, temp, h( j, j+1 ), ldh ) + call stdlib${ii}$_${ci}$scal( j-i1, conjg( temp ), h( i1, j ), 1_${ik}$ ) if( wantz ) then - call stdlib_${ci}$scal( nz, conjg( temp ), z( iloz, j ),1 ) + call stdlib${ii}$_${ci}$scal( nz, conjg( temp ), z( iloz, j ),1_${ik}$ ) end if end if end do @@ -40674,10 +40666,10 @@ module stdlib_linalg_lapack_${ci}$ rtemp = abs( temp ) h( i, i-1 ) = rtemp temp = temp / rtemp - if( i2>i )call stdlib_${ci}$scal( i2-i, conjg( temp ), h( i, i+1 ), ldh ) - call stdlib_${ci}$scal( i-i1, temp, h( i1, i ), 1 ) + if( i2>i )call stdlib${ii}$_${ci}$scal( i2-i, conjg( temp ), h( i, i+1 ), ldh ) + call stdlib${ii}$_${ci}$scal( i-i1, temp, h( i1, i ), 1_${ik}$ ) if( wantz ) then - call stdlib_${ci}$scal( nz, temp, z( iloz, i ), 1 ) + call stdlib${ii}$_${ci}$scal( nz, temp, z( iloz, i ), 1_${ik}$ ) end if end if end do loop_130 @@ -40688,16 +40680,16 @@ module stdlib_linalg_lapack_${ci}$ ! h(i,i-1) is negligible: cone eigenvalue has converged. w( i ) = h( i, i ) ! reset deflation counter - kdefl = 0 + kdefl = 0_${ik}$ ! return to start of the main loop with new value of i. - i = l - 1 + i = l - 1_${ik}$ go to 30 150 continue return - end subroutine stdlib_${ci}$lahqr + end subroutine stdlib${ii}$_${ci}$lahqr - pure subroutine stdlib_${ci}$lahr2( n, k, nb, a, lda, tau, t, ldt, y, ldy ) + pure subroutine stdlib${ii}$_${ci}$lahr2( n, k, nb, a, lda, tau, t, ldt, y, ldy ) !! ZLAHR2: reduces the first NB columns of A complex general n-BY-(n-k+1) !! matrix A so that elements below the k-th subdiagonal are zero. The !! reduction is performed by an unitary similarity transformation @@ -40708,14 +40700,14 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: k, lda, ldt, ldy, n, nb + integer(${ik}$), intent(in) :: k, lda, ldt, ldy, n, nb ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: t(ldt,nb), tau(nb), y(ldy,nb) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i complex(${ck}$) :: ei ! Intrinsic Functions intrinsic :: min @@ -40723,71 +40715,71 @@ module stdlib_linalg_lapack_${ci}$ ! quick return if possible if( n<=1 )return loop_10: do i = 1, nb - if( i>1 ) then + if( i>1_${ik}$ ) then ! update a(k+1:n,i) ! update i-th column of a - y * v**h - call stdlib_${ci}$lacgv( i-1, a( k+i-1, 1 ), lda ) - call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k, i-1, -cone, y(k+1,1), ldy,a( k+i-1, 1 ), & - lda, cone, a( k+1, i ), 1 ) - call stdlib_${ci}$lacgv( i-1, a( k+i-1, 1 ), lda ) + call stdlib${ii}$_${ci}$lacgv( i-1, a( k+i-1, 1_${ik}$ ), lda ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-k, i-1, -cone, y(k+1,1_${ik}$), ldy,a( k+i-1, 1_${ik}$ ), & + lda, cone, a( k+1, i ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( i-1, a( k+i-1, 1_${ik}$ ), lda ) ! apply i - v * t**h * v**h to this column (call it b) from the ! left, using the last column of t as workspace ! let v = ( v1 ) and b = ( b1 ) (first i-1 rows) ! ( v2 ) ( b2 ) ! where v1 is unit lower triangular ! w := v1**h * b1 - call stdlib_${ci}$copy( i-1, a( k+1, i ), 1, t( 1, nb ), 1 ) - call stdlib_${ci}$trmv( 'LOWER', 'CONJUGATE TRANSPOSE', 'UNIT',i-1, a( k+1, 1 ),lda, & - t( 1, nb ), 1 ) + call stdlib${ii}$_${ci}$copy( i-1, a( k+1, i ), 1_${ik}$, t( 1_${ik}$, nb ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$trmv( 'LOWER', 'CONJUGATE TRANSPOSE', 'UNIT',i-1, a( k+1, 1_${ik}$ ),lda, & + t( 1_${ik}$, nb ), 1_${ik}$ ) ! w := w + v2**h * b2 - call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', n-k-i+1, i-1,cone, a( k+i, 1 ),lda, a( & - k+i, i ), 1, cone, t( 1, nb ), 1 ) + call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', n-k-i+1, i-1,cone, a( k+i, 1_${ik}$ ),lda, a( & + k+i, i ), 1_${ik}$, cone, t( 1_${ik}$, nb ), 1_${ik}$ ) ! w := t**h * w - call stdlib_${ci}$trmv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1, & - nb ), 1 ) + call stdlib${ii}$_${ci}$trmv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1_${ik}$, & + nb ), 1_${ik}$ ) ! b2 := b2 - v2*w - call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k-i+1, i-1, -cone,a( k+i, 1 ),lda, t( 1, nb & - ), 1, cone, a( k+i, i ), 1 ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-k-i+1, i-1, -cone,a( k+i, 1_${ik}$ ),lda, t( 1_${ik}$, nb & + ), 1_${ik}$, cone, a( k+i, i ), 1_${ik}$ ) ! b1 := b1 - v1*w - call stdlib_${ci}$trmv( 'LOWER', 'NO TRANSPOSE','UNIT', i-1,a( k+1, 1 ), lda, t( 1, & - nb ), 1 ) - call stdlib_${ci}$axpy( i-1, -cone, t( 1, nb ), 1, a( k+1, i ), 1 ) + call stdlib${ii}$_${ci}$trmv( 'LOWER', 'NO TRANSPOSE','UNIT', i-1,a( k+1, 1_${ik}$ ), lda, t( 1_${ik}$, & + nb ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$axpy( i-1, -cone, t( 1_${ik}$, nb ), 1_${ik}$, a( k+1, i ), 1_${ik}$ ) a( k+i-1, i-1 ) = ei end if ! generate the elementary reflector h(i) to annihilate ! a(k+i+1:n,i) - call stdlib_${ci}$larfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1,tau( i ) ) + call stdlib${ii}$_${ci}$larfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1_${ik}$,tau( i ) ) ei = a( k+i, i ) a( k+i, i ) = cone ! compute y(k+1:n,i) - call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k, n-k-i+1,cone, a( k+1, i+1 ),lda, a( k+i, i )& - , 1, czero, y( k+1, i ), 1 ) - call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', n-k-i+1, i-1,cone, a( k+i, 1 ), lda,a( k+& - i, i ), 1, czero, t( 1, i ), 1 ) - call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k, i-1, -cone,y( k+1, 1 ), ldy,t( 1, i ), 1, & - cone, y( k+1, i ), 1 ) - call stdlib_${ci}$scal( n-k, tau( i ), y( k+1, i ), 1 ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-k, n-k-i+1,cone, a( k+1, i+1 ),lda, a( k+i, i )& + , 1_${ik}$, czero, y( k+1, i ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', n-k-i+1, i-1,cone, a( k+i, 1_${ik}$ ), lda,a( k+& + i, i ), 1_${ik}$, czero, t( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-k, i-1, -cone,y( k+1, 1_${ik}$ ), ldy,t( 1_${ik}$, i ), 1_${ik}$, & + cone, y( k+1, i ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$scal( n-k, tau( i ), y( k+1, i ), 1_${ik}$ ) ! compute t(1:i,i) - call stdlib_${ci}$scal( i-1, -tau( i ), t( 1, i ), 1 ) - call stdlib_${ci}$trmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1, i ), 1 ) + call stdlib${ii}$_${ci}$scal( i-1, -tau( i ), t( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$trmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1_${ik}$, i ), 1_${ik}$ ) t( i, i ) = tau( i ) end do loop_10 a( k+nb, nb ) = ei ! compute y(1:k,1:nb) - call stdlib_${ci}$lacpy( 'ALL', k, nb, a( 1, 2 ), lda, y, ldy ) - call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE','UNIT', k, nb,cone, a( k+1, 1 ), & + call stdlib${ii}$_${ci}$lacpy( 'ALL', k, nb, a( 1_${ik}$, 2_${ik}$ ), lda, y, ldy ) + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE','UNIT', k, nb,cone, a( k+1, 1_${ik}$ ), & lda, y, ldy ) - if( n>k+nb )call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,nb, n-k-nb, cone,a( 1,& - 2+nb ), lda, a( k+1+nb, 1 ), lda, cone, y,ldy ) - call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE','NON-UNIT', k, nb,cone, t, ldt, y, & + if( n>k+nb )call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,nb, n-k-nb, cone,a( 1_${ik}$,& + 2_${ik}$+nb ), lda, a( k+1+nb, 1_${ik}$ ), lda, cone, y,ldy ) + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE','NON-UNIT', k, nb,cone, t, ldt, y, & ldy ) return - end subroutine stdlib_${ci}$lahr2 + end subroutine stdlib${ii}$_${ci}$lahr2 - pure subroutine stdlib_${ci}$laic1( job, j, x, sest, w, gamma, sestpr, s, c ) + pure subroutine stdlib${ii}$_${ci}$laic1( job, j, x, sest, w, gamma, sestpr, s, c ) !! ZLAIC1: applies one step of incremental condition estimation in !! its simplest version: !! Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j @@ -40812,7 +40804,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(${ck}$), intent(in) :: sest real(${ck}$), intent(out) :: sestpr complex(${ck}$), intent(out) :: c, s @@ -40829,12 +40821,12 @@ module stdlib_linalg_lapack_${ci}$ ! Intrinsic Functions intrinsic :: abs,conjg,max,sqrt ! Executable Statements - eps = stdlib_${c2ri(ci)}$lamch( 'EPSILON' ) - alpha = stdlib_${ci}$dotc( j, x, 1, w, 1 ) + eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'EPSILON' ) + alpha = stdlib${ii}$_${ci}$dotc( 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 @@ -40910,7 +40902,7 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -41000,10 +40992,10 @@ module stdlib_linalg_lapack_${ci}$ end if end if return - end subroutine stdlib_${ci}$laic1 + end subroutine stdlib${ii}$_${ci}$laic1 - pure subroutine stdlib_${ci}$lals0( icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx,perm, givptr, & + pure subroutine stdlib${ii}$_${ci}$lals0( icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx,perm, givptr, & !! ZLALS0: applies back the multiplying factors of either the left or the !! right singular vector matrix of a diagonal matrix appended by a row !! to the right hand side matrix B in solving the least squares problem @@ -41029,12 +41021,12 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: givptr, icompq, k, ldb, ldbx, ldgcol, ldgnum, nl, nr, nrhs,& + integer(${ik}$), intent(in) :: givptr, icompq, k, ldb, ldbx, ldgcol, ldgnum, nl, nr, nrhs,& sqre - integer(ilp), intent(out) :: info + integer(${ik}$), intent(out) :: info real(${ck}$), intent(in) :: c, s ! Array Arguments - integer(ilp), intent(in) :: givcol(ldgcol,*), perm(*) + integer(${ik}$), intent(in) :: givcol(ldgcol,*), perm(*) real(${ck}$), intent(in) :: difl(*), difr(ldgnum,*), givnum(ldgnum,*), poles(ldgnum,*), z(& *) real(${ck}$), intent(out) :: rwork(*) @@ -41043,179 +41035,179 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, jcol, jrow, m, n, nlp1 + integer(${ik}$) :: i, j, jcol, jrow, m, n, nlp1 real(${ck}$) :: diflj, difrj, dj, dsigj, dsigjp, temp ! Intrinsic Functions intrinsic :: real,cmplx,aimag,max ! Executable Statements ! test the input parameters. - info = 0 - n = nl + nr + 1 - 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 - else if( nrhs<1 ) then - info = -5 + info = 0_${ik}$ + n = nl + nr + 1_${ik}$ + 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( nrhs<1_${ik}$ ) then + info = -5_${ik}$ else if( ldb1 ) ) then - info = -1 - else if( smlsiz<3 ) then - info = -2 + info = 0_${ik}$ + if( ( icompq<0_${ik}$ ) .or. ( icompq>1_${ik}$ ) ) then + info = -1_${ik}$ + else if( smlsiz<3_${ik}$ ) then + info = -2_${ik}$ else if( n=one ) ) then rcnd = eps else rcnd = rcond end if - rank = 0 + rank = 0_${ik}$ ! quick return if possible. - if( n==0 ) then + if( n==0_${ik}$ ) then return - else if( n==1 ) then - if( d( 1 )==zero ) then - call stdlib_${ci}$laset( 'A', 1, nrhs, czero, czero, b, ldb ) + else if( n==1_${ik}$ ) then + if( d( 1_${ik}$ )==zero ) then + call stdlib${ii}$_${ci}$laset( 'A', 1_${ik}$, nrhs, czero, czero, b, ldb ) else - rank = 1 - call stdlib_${ci}$lascl( 'G', 0, 0, d( 1 ), one, 1, nrhs, b, ldb, info ) - d( 1 ) = abs( d( 1 ) ) + rank = 1_${ik}$ + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, d( 1_${ik}$ ), one, 1_${ik}$, nrhs, b, ldb, info ) + d( 1_${ik}$ ) = abs( d( 1_${ik}$ ) ) end if return end if ! rotate the matrix if it is lower bidiagonal. if( uplo=='L' ) then do i = 1, n - 1 - call stdlib_${c2ri(ci)}$lartg( d( i ), e( i ), cs, sn, r ) + call stdlib${ii}$_${c2ri(ci)}$lartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) - if( nrhs==1 ) then - call stdlib_${ci}$drot( 1, b( i, 1 ), 1, b( i+1, 1 ), 1, cs, sn ) + if( nrhs==1_${ik}$ ) then + call stdlib${ii}$_${ci}$drot( 1_${ik}$, b( i, 1_${ik}$ ), 1_${ik}$, b( i+1, 1_${ik}$ ), 1_${ik}$, cs, sn ) else - rwork( i*2-1 ) = cs - rwork( i*2 ) = sn + rwork( i*2_${ik}$-1 ) = cs + rwork( i*2_${ik}$ ) = sn end if end do - if( nrhs>1 ) then + if( nrhs>1_${ik}$ ) then do i = 1, nrhs do j = 1, n - 1 - cs = rwork( j*2-1 ) - sn = rwork( j*2 ) - call stdlib_${ci}$drot( 1, b( j, i ), 1, b( j+1, i ), 1, cs, sn ) + cs = rwork( j*2_${ik}$-1 ) + sn = rwork( j*2_${ik}$ ) + call stdlib${ii}$_${ci}$drot( 1_${ik}$, b( j, i ), 1_${ik}$, b( j+1, i ), 1_${ik}$, cs, sn ) end do end do end if end if ! scale. - nm1 = n - 1 - orgnrm = stdlib_${c2ri(ci)}$lanst( 'M', n, d, e ) + nm1 = n - 1_${ik}$ + orgnrm = stdlib${ii}$_${c2ri(ci)}$lanst( 'M', n, d, e ) if( orgnrm==zero ) then - call stdlib_${ci}$laset( 'A', n, nrhs, czero, czero, b, ldb ) + call stdlib${ii}$_${ci}$laset( 'A', n, nrhs, czero, czero, b, ldb ) return end if - call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info ) - call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, orgnrm, one, nm1, 1, e, nm1, info ) + call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, n, 1_${ik}$, d, n, info ) + call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, nm1, 1_${ik}$, e, nm1, info ) ! if n is smaller than the minimum divide size smlsiz, then solve ! the problem with another solver. if( n<=smlsiz ) then - irwu = 1 + irwu = 1_${ik}$ irwvt = irwu + n*n irwwrk = irwvt + n*n irwrb = irwwrk irwib = irwrb + n*nrhs irwb = irwib + n*nrhs - call stdlib_${c2ri(ci)}$laset( 'A', n, n, zero, one, rwork( irwu ), n ) - call stdlib_${c2ri(ci)}$laset( 'A', n, n, zero, one, rwork( irwvt ), n ) - call stdlib_${c2ri(ci)}$lasdq( 'U', 0, n, n, n, 0, d, e, rwork( irwvt ), n,rwork( irwu ), n, & - rwork( irwwrk ), 1,rwork( irwwrk ), info ) - if( info/=0 ) then + call stdlib${ii}$_${c2ri(ci)}$laset( 'A', n, n, zero, one, rwork( irwu ), n ) + call stdlib${ii}$_${c2ri(ci)}$laset( 'A', n, n, zero, one, rwork( irwvt ), n ) + call stdlib${ii}$_${c2ri(ci)}$lasdq( 'U', 0_${ik}$, n, n, n, 0_${ik}$, d, e, rwork( irwvt ), n,rwork( irwu ), n, & + rwork( irwwrk ), 1_${ik}$,rwork( irwwrk ), info ) + if( info/=0_${ik}$ ) then return end if - ! in the real version, b is passed to stdlib_${c2ri(ci)}$lasdq and multiplied + ! in the real version, b is passed to stdlib${ii}$_${c2ri(ci)}$lasdq and multiplied ! internally by q**h. here b is complex and that product is ! computed below in two steps (real and imaginary parts). - j = irwb - 1 + j = irwb - 1_${ik}$ do jcol = 1, nrhs do jrow = 1, n - j = j + 1 + j = j + 1_${ik}$ rwork( j ) = real( b( jrow, jcol ),KIND=${ck}$) end do end do - call stdlib_${c2ri(ci)}$gemm( 'T', 'N', n, nrhs, n, one, rwork( irwu ), n,rwork( irwb ), n, & + call stdlib${ii}$_${c2ri(ci)}$gemm( 'T', 'N', n, nrhs, n, one, rwork( irwu ), n,rwork( irwb ), n, & zero, rwork( irwrb ), n ) - j = irwb - 1 + j = irwb - 1_${ik}$ do jcol = 1, nrhs do jrow = 1, n - j = j + 1 + j = j + 1_${ik}$ rwork( j ) = aimag( b( jrow, jcol ) ) end do end do - call stdlib_${c2ri(ci)}$gemm( 'T', 'N', n, nrhs, n, one, rwork( irwu ), n,rwork( irwb ), n, & + call stdlib${ii}$_${c2ri(ci)}$gemm( 'T', 'N', n, nrhs, n, one, rwork( irwu ), n,rwork( irwb ), n, & zero, rwork( irwib ), n ) - jreal = irwrb - 1 - jimag = irwib - 1 + jreal = irwrb - 1_${ik}$ + jimag = irwib - 1_${ik}$ do jcol = 1, nrhs do jrow = 1, n - jreal = jreal + 1 - jimag = jimag + 1 + jreal = jreal + 1_${ik}$ + jimag = jimag + 1_${ik}$ b( jrow, jcol ) = cmplx( rwork( jreal ),rwork( jimag ),KIND=${ck}$) end do end do - tol = rcnd*abs( d( stdlib_i${c2ri(ci)}$amax( n, d, 1 ) ) ) + tol = rcnd*abs( d( stdlib${ii}$_i${c2ri(ci)}$amax( n, d, 1_${ik}$ ) ) ) do i = 1, n if( d( i )<=tol ) then - call stdlib_${ci}$laset( 'A', 1, nrhs, czero, czero, b( i, 1 ), ldb ) + call stdlib${ii}$_${ci}$laset( 'A', 1_${ik}$, nrhs, czero, czero, b( i, 1_${ik}$ ), ldb ) else - call stdlib_${ci}$lascl( 'G', 0, 0, d( i ), one, 1, nrhs, b( i, 1 ),ldb, info ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, d( i ), one, 1_${ik}$, nrhs, b( i, 1_${ik}$ ),ldb, info ) - rank = rank + 1 + rank = rank + 1_${ik}$ end if end do - ! since b is complex, the following call to stdlib_${c2ri(ci)}$gemm is performed + ! since b is complex, the following call to stdlib${ii}$_${c2ri(ci)}$gemm is performed ! in two steps (real and imaginary parts). that is for v * b ! (in the real version of the code v**h is stored in work). - ! call stdlib_${c2ri(ci)}$gemm( 't', 'n', n, nrhs, n, one, work, n, b, ldb, zero, + ! call stdlib${ii}$_${c2ri(ci)}$gemm( 't', 'n', n, nrhs, n, one, work, n, b, ldb, zero, ! $ work( nwork ), n ) - j = irwb - 1 + j = irwb - 1_${ik}$ do jcol = 1, nrhs do jrow = 1, n - j = j + 1 + j = j + 1_${ik}$ rwork( j ) = real( b( jrow, jcol ),KIND=${ck}$) end do end do - call stdlib_${c2ri(ci)}$gemm( 'T', 'N', n, nrhs, n, one, rwork( irwvt ), n,rwork( irwb ), n, & + call stdlib${ii}$_${c2ri(ci)}$gemm( 'T', 'N', n, nrhs, n, one, rwork( irwvt ), n,rwork( irwb ), n, & zero, rwork( irwrb ), n ) - j = irwb - 1 + j = irwb - 1_${ik}$ do jcol = 1, nrhs do jrow = 1, n - j = j + 1 + j = j + 1_${ik}$ rwork( j ) = aimag( b( jrow, jcol ) ) end do end do - call stdlib_${c2ri(ci)}$gemm( 'T', 'N', n, nrhs, n, one, rwork( irwvt ), n,rwork( irwb ), n, & + call stdlib${ii}$_${c2ri(ci)}$gemm( 'T', 'N', n, nrhs, n, one, rwork( irwvt ), n,rwork( irwb ), n, & zero, rwork( irwib ), n ) - jreal = irwrb - 1 - jimag = irwib - 1 + jreal = irwrb - 1_${ik}$ + jimag = irwib - 1_${ik}$ do jcol = 1, nrhs do jrow = 1, n - jreal = jreal + 1 - jimag = jimag + 1 + jreal = jreal + 1_${ik}$ + jimag = jimag + 1_${ik}$ b( jrow, jcol ) = cmplx( rwork( jreal ),rwork( jimag ),KIND=${ck}$) end do end do ! unscale. - call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) - call stdlib_${c2ri(ci)}$lasrt( 'D', n, d, info ) - call stdlib_${ci}$lascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info ) + call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, n, 1_${ik}$, d, n, info ) + call stdlib${ii}$_${c2ri(ci)}$lasrt( 'D', n, d, info ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, n, nrhs, b, ldb, info ) return end if ! book-keeping and setting up some constants. - nlvl = int( log( real( n,KIND=${ck}$) / real( smlsiz+1,KIND=${ck}$) ) / log( two ),KIND=ilp) + & - 1 - smlszp = smlsiz + 1 - u = 1 - vt = 1 + smlsiz*n + nlvl = int( log( real( n,KIND=${ck}$) / real( smlsiz+1,KIND=${ck}$) ) / log( two ),KIND=${ik}$) + & + 1_${ik}$ + smlszp = smlsiz + 1_${ik}$ + u = 1_${ik}$ + vt = 1_${ik}$ + smlsiz*n difl = vt + smlszp*n difr = difl + nlvl*n - z = difr + nlvl*n*2 + z = difr + nlvl*n*2_${ik}$ c = z + nlvl*n s = c + n poles = s + n - givnum = poles + 2*nlvl*n - nrwork = givnum + 2*nlvl*n - bx = 1 + givnum = poles + 2_${ik}$*nlvl*n + nrwork = givnum + 2_${ik}$*nlvl*n + bx = 1_${ik}$ irwrb = nrwork irwib = irwrb + smlsiz*nrhs irwb = irwib + smlsiz*nrhs - sizei = 1 + n + sizei = 1_${ik}$ + n k = sizei + n givptr = k + n perm = givptr + n givcol = perm + nlvl*n - iwk = givcol + nlvl*n*2 - st = 1 - sqre = 0 - icmpq1 = 1 - icmpq2 = 0 - nsub = 0 + iwk = givcol + nlvl*n*2_${ik}$ + st = 1_${ik}$ + sqre = 0_${ik}$ + icmpq1 = 1_${ik}$ + icmpq2 = 0_${ik}$ + nsub = 0_${ik}$ do i = 1, n if( abs( d( i ) )=eps ) then ! a subproblem with e(nm1) not too small but i = nm1. - nsize = n - st + 1 + nsize = n - st + 1_${ik}$ iwork( sizei+nsub-1 ) = nsize else ! a subproblem with e(nm1) small. this implies an ! 1-by-1 subproblem at d(n), which is not solved ! explicitly. - nsize = i - st + 1 + nsize = i - st + 1_${ik}$ iwork( sizei+nsub-1 ) = nsize - nsub = nsub + 1 + nsub = nsub + 1_${ik}$ iwork( nsub ) = n - iwork( sizei+nsub-1 ) = 1 - call stdlib_${ci}$copy( nrhs, b( n, 1 ), ldb, work( bx+nm1 ), n ) + iwork( sizei+nsub-1 ) = 1_${ik}$ + call stdlib${ii}$_${ci}$copy( nrhs, b( n, 1_${ik}$ ), ldb, work( bx+nm1 ), n ) end if - st1 = st - 1 - if( nsize==1 ) then + st1 = st - 1_${ik}$ + if( nsize==1_${ik}$ ) then ! this is a 1-by-1 subproblem and is not solved ! explicitly. - call stdlib_${ci}$copy( nrhs, b( st, 1 ), ldb, work( bx+st1 ), n ) + call stdlib${ii}$_${ci}$copy( nrhs, b( st, 1_${ik}$ ), ldb, work( bx+st1 ), n ) else if( nsize<=smlsiz ) then - ! this is a small subproblem and is solved by stdlib_${c2ri(ci)}$lasdq. - call stdlib_${c2ri(ci)}$laset( 'A', nsize, nsize, zero, one,rwork( vt+st1 ), n ) - call stdlib_${c2ri(ci)}$laset( 'A', nsize, nsize, zero, one,rwork( u+st1 ), n ) - call stdlib_${c2ri(ci)}$lasdq( 'U', 0, nsize, nsize, nsize, 0, d( st ),e( st ), rwork( & - vt+st1 ), n, rwork( u+st1 ),n, rwork( nrwork ), 1, rwork( nrwork ),info ) + ! this is a small subproblem and is solved by stdlib${ii}$_${c2ri(ci)}$lasdq. + call stdlib${ii}$_${c2ri(ci)}$laset( 'A', nsize, nsize, zero, one,rwork( vt+st1 ), n ) + call stdlib${ii}$_${c2ri(ci)}$laset( 'A', nsize, nsize, zero, one,rwork( u+st1 ), n ) + call stdlib${ii}$_${c2ri(ci)}$lasdq( 'U', 0_${ik}$, nsize, nsize, nsize, 0_${ik}$, d( st ),e( st ), rwork( & + vt+st1 ), n, rwork( u+st1 ),n, rwork( nrwork ), 1_${ik}$, rwork( nrwork ),info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if - ! in the real version, b is passed to stdlib_${c2ri(ci)}$lasdq and multiplied + ! in the real version, b is passed to stdlib${ii}$_${c2ri(ci)}$lasdq and multiplied ! internally by q**h. here b is complex and that product is ! computed below in two steps (real and imaginary parts). - j = irwb - 1 + j = irwb - 1_${ik}$ do jcol = 1, nrhs do jrow = st, st + nsize - 1 - j = j + 1 + j = j + 1_${ik}$ rwork( j ) = real( b( jrow, jcol ),KIND=${ck}$) end do end do - call stdlib_${c2ri(ci)}$gemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( u+st1 ), n, rwork(& + call stdlib${ii}$_${c2ri(ci)}$gemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( u+st1 ), n, rwork(& irwb ), nsize,zero, rwork( irwrb ), nsize ) - j = irwb - 1 + j = irwb - 1_${ik}$ do jcol = 1, nrhs do jrow = st, st + nsize - 1 - j = j + 1 + j = j + 1_${ik}$ rwork( j ) = aimag( b( jrow, jcol ) ) end do end do - call stdlib_${c2ri(ci)}$gemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( u+st1 ), n, rwork(& + call stdlib${ii}$_${c2ri(ci)}$gemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( u+st1 ), n, rwork(& irwb ), nsize,zero, rwork( irwib ), nsize ) - jreal = irwrb - 1 - jimag = irwib - 1 + jreal = irwrb - 1_${ik}$ + jimag = irwib - 1_${ik}$ do jcol = 1, nrhs do jrow = st, st + nsize - 1 - jreal = jreal + 1 - jimag = jimag + 1 + jreal = jreal + 1_${ik}$ + jimag = jimag + 1_${ik}$ b( jrow, jcol ) = cmplx( rwork( jreal ),rwork( jimag ),KIND=${ck}$) end do end do - call stdlib_${ci}$lacpy( 'A', nsize, nrhs, b( st, 1 ), ldb,work( bx+st1 ), n ) + call stdlib${ii}$_${ci}$lacpy( 'A', nsize, nrhs, b( st, 1_${ik}$ ), ldb,work( bx+st1 ), n ) else ! a large problem. solve it using divide and conquer. - call stdlib_${c2ri(ci)}$lasda( icmpq1, smlsiz, nsize, sqre, d( st ),e( st ), rwork( u+& + call stdlib${ii}$_${c2ri(ci)}$lasda( icmpq1, smlsiz, nsize, sqre, d( st ),e( st ), rwork( u+& st1 ), n, rwork( vt+st1 ),iwork( k+st1 ), rwork( difl+st1 ),rwork( difr+st1 ),& rwork( z+st1 ),rwork( poles+st1 ), iwork( givptr+st1 ),iwork( givcol+st1 ), & n, iwork( perm+st1 ),rwork( givnum+st1 ), rwork( c+st1 ),rwork( s+st1 ), & rwork( nrwork ),iwork( iwk ), info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if bxst = bx + st1 - call stdlib_${ci}$lalsa( icmpq2, smlsiz, nsize, nrhs, b( st, 1 ),ldb, work( bxst ),& + call stdlib${ii}$_${ci}$lalsa( icmpq2, smlsiz, nsize, nrhs, b( st, 1_${ik}$ ),ldb, work( bxst ),& n, rwork( u+st1 ), n,rwork( vt+st1 ), iwork( k+st1 ),rwork( difl+st1 ), & rwork( difr+st1 ),rwork( z+st1 ), rwork( poles+st1 ),iwork( givptr+st1 ), & iwork( givcol+st1 ), n,iwork( perm+st1 ), rwork( givnum+st1 ),rwork( c+st1 ),& rwork( s+st1 ),rwork( nrwork ), iwork( iwk ), info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if end if - st = i + 1 + st = i + 1_${ik}$ end if end do loop_240 ! apply the singular values and treat the tiny ones as zero. - tol = rcnd*abs( d( stdlib_i${c2ri(ci)}$amax( n, d, 1 ) ) ) + tol = rcnd*abs( d( stdlib${ii}$_i${c2ri(ci)}$amax( n, d, 1_${ik}$ ) ) ) do i = 1, n ! some of the elements in d can be negative because 1-by-1 ! subproblems were not solved explicitly. if( abs( d( i ) )<=tol ) then - call stdlib_${ci}$laset( 'A', 1, nrhs, czero, czero, work( bx+i-1 ), n ) + call stdlib${ii}$_${ci}$laset( 'A', 1_${ik}$, nrhs, czero, czero, work( bx+i-1 ), n ) else - rank = rank + 1 - call stdlib_${ci}$lascl( 'G', 0, 0, d( i ), one, 1, nrhs,work( bx+i-1 ), n, info ) + rank = rank + 1_${ik}$ + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, d( i ), one, 1_${ik}$, nrhs,work( bx+i-1 ), n, info ) end if d( i ) = abs( d( i ) ) end do ! now apply back the right singular vectors. - icmpq2 = 1 + icmpq2 = 1_${ik}$ loop_320: do i = 1, nsub st = iwork( i ) - st1 = st - 1 + st1 = st - 1_${ik}$ nsize = iwork( sizei+i-1 ) bxst = bx + st1 - if( nsize==1 ) then - call stdlib_${ci}$copy( nrhs, work( bxst ), n, b( st, 1 ), ldb ) + if( nsize==1_${ik}$ ) then + call stdlib${ii}$_${ci}$copy( nrhs, work( bxst ), n, b( st, 1_${ik}$ ), ldb ) else if( nsize<=smlsiz ) then - ! since b and bx are complex, the following call to stdlib_${c2ri(ci)}$gemm + ! since b and bx are complex, the following call to stdlib${ii}$_${c2ri(ci)}$gemm ! is performed in two steps (real and imaginary parts). - ! call stdlib_${c2ri(ci)}$gemm( 't', 'n', nsize, nrhs, nsize, one, + ! call stdlib${ii}$_${c2ri(ci)}$gemm( 't', 'n', nsize, nrhs, nsize, one, ! $ rwork( vt+st1 ), n, rwork( bxst ), n, zero, ! $ b( st, 1 ), ldb ) - j = bxst - n - 1 - jreal = irwb - 1 + j = bxst - n - 1_${ik}$ + jreal = irwb - 1_${ik}$ do jcol = 1, nrhs j = j + n do jrow = 1, nsize - jreal = jreal + 1 + jreal = jreal + 1_${ik}$ rwork( jreal ) = real( work( j+jrow ),KIND=${ck}$) end do end do - call stdlib_${c2ri(ci)}$gemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( vt+st1 ), n, rwork( & + call stdlib${ii}$_${c2ri(ci)}$gemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( vt+st1 ), n, rwork( & irwb ), nsize, zero,rwork( irwrb ), nsize ) - j = bxst - n - 1 - jimag = irwb - 1 + j = bxst - n - 1_${ik}$ + jimag = irwb - 1_${ik}$ do jcol = 1, nrhs j = j + n do jrow = 1, nsize - jimag = jimag + 1 + jimag = jimag + 1_${ik}$ rwork( jimag ) = aimag( work( j+jrow ) ) end do end do - call stdlib_${c2ri(ci)}$gemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( vt+st1 ), n, rwork( & + call stdlib${ii}$_${c2ri(ci)}$gemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( vt+st1 ), n, rwork( & irwb ), nsize, zero,rwork( irwib ), nsize ) - jreal = irwrb - 1 - jimag = irwib - 1 + jreal = irwrb - 1_${ik}$ + jimag = irwib - 1_${ik}$ do jcol = 1, nrhs do jrow = st, st + nsize - 1 - jreal = jreal + 1 - jimag = jimag + 1 + jreal = jreal + 1_${ik}$ + jimag = jimag + 1_${ik}$ b( jrow, jcol ) = cmplx( rwork( jreal ),rwork( jimag ),KIND=${ck}$) end do end do else - call stdlib_${ci}$lalsa( icmpq2, smlsiz, nsize, nrhs, work( bxst ), n,b( st, 1 ), ldb,& + call stdlib${ii}$_${ci}$lalsa( icmpq2, smlsiz, nsize, nrhs, work( bxst ), n,b( st, 1_${ik}$ ), ldb,& rwork( u+st1 ), n,rwork( vt+st1 ), iwork( k+st1 ),rwork( difl+st1 ), rwork( & difr+st1 ),rwork( z+st1 ), rwork( poles+st1 ),iwork( givptr+st1 ), iwork( & givcol+st1 ), n,iwork( perm+st1 ), rwork( givnum+st1 ),rwork( c+st1 ), rwork( s+& st1 ),rwork( nrwork ), iwork( iwk ), info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if end if end do loop_320 ! unscale and sort the singular values. - call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) - call stdlib_${c2ri(ci)}$lasrt( 'D', n, d, info ) - call stdlib_${ci}$lascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info ) + call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, n, 1_${ik}$, d, n, info ) + call stdlib${ii}$_${c2ri(ci)}$lasrt( 'D', n, d, info ) + call stdlib${ii}$_${ci}$lascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, n, nrhs, b, ldb, info ) return - end subroutine stdlib_${ci}$lalsd + end subroutine stdlib${ii}$_${ci}$lalsd - pure subroutine stdlib_${ci}$lamswlq( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & + pure subroutine stdlib${ii}$_${ci}$lamswlq( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & !! ZLAMSWLQ: overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -41976,8 +41968,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: lda, m, n, k, mb, nb, ldt, lwork, ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, k, mb, nb, ldt, lwork, ldc ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*), t(ldt,*) complex(${ck}$), intent(out) :: work(*) @@ -41985,11 +41977,11 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran, lquery - integer(ilp) :: i, ii, kk, lw, ctr + integer(${ik}$) :: i, ii, kk, lw, ctr ! External Subroutines ! Executable Statements ! test the input arguments - lquery = lwork<0 + lquery = lwork<0_${ik}$ notran = stdlib_lsame( trans, 'N' ) tran = stdlib_lsame( trans, 'C' ) left = stdlib_lsame( side, 'L' ) @@ -41999,42 +41991,42 @@ module stdlib_linalg_lapack_${ci}$ else lw = m * mb end if - info = 0 + info = 0_${ik}$ if( .not.left .and. .not.right ) then - info = -1 + info = -1_${ik}$ else if( .not.tran .and. .not.notran ) then - info = -2 - else if( k<0 ) then - info = -5 + info = -2_${ik}$ + else if( k<0_${ik}$ ) then + info = -5_${ik}$ else if( m=max(m,n,k))) then - call stdlib_${ci}$gemlqt( side, trans, m, n, k, mb, a, lda,t, ldt, c, ldc, work, info) + call stdlib${ii}$_${ci}$gemlqt( side, trans, m, n, k, mb, a, lda,t, ldt, c, ldc, work, info) return end if @@ -42042,85 +42034,85 @@ module stdlib_linalg_lapack_${ci}$ ! multiply q to the last block of c kk = mod((m-k),(nb-k)) ctr = (m-k)/(nb-k) - if (kk>0) then + if (kk>0_${ik}$) then ii=m-kk+1 - call stdlib_${ci}$tpmlqt('L','C',kk , n, k, 0, mb, a(1,ii), lda,t(1,ctr*k+1), ldt, c(& - 1,1), ldc,c(ii,1), ldc, work, info ) + call stdlib${ii}$_${ci}$tpmlqt('L','C',kk , n, k, 0_${ik}$, mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1), ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) else ii=m+1 end if do i=ii-(nb-k),nb+1,-(nb-k) ! multiply q to the current block of c (1:m,i:i+nb) - ctr = ctr - 1 - call stdlib_${ci}$tpmlqt('L','C',nb-k , n, k, 0,mb, a(1,i), lda,t(1,ctr*k+1),ldt, c(1,& - 1), ldc,c(i,1), ldc, work, info ) + ctr = ctr - 1_${ik}$ + call stdlib${ii}$_${ci}$tpmlqt('L','C',nb-k , n, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$,ctr*k+1),ldt, c(1_${ik}$,& + 1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info ) end do ! multiply q to the first block of c (1:m,1:nb) - call stdlib_${ci}$gemlqt('L','C',nb , n, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_${ci}$gemlqt('L','C',nb , n, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (left.and.notran) then ! multiply q to the first block of c kk = mod((m-k),(nb-k)) ii=m-kk+1 - ctr = 1 - call stdlib_${ci}$gemlqt('L','N',nb , n, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + ctr = 1_${ik}$ + call stdlib${ii}$_${ci}$gemlqt('L','N',nb , n, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=nb+1,ii-nb+k,(nb-k) ! multiply q to the current block of c (i:i+nb,1:n) - call stdlib_${ci}$tpmlqt('L','N',nb-k , n, k, 0,mb, a(1,i), lda,t(1, ctr * k + 1), ldt, & - c(1,1), ldc,c(i,1), ldc, work, info ) - ctr = ctr + 1 + call stdlib${ii}$_${ci}$tpmlqt('L','N',nb-k , n, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$, ctr * k + 1_${ik}$), ldt, & + c(1_${ik}$,1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info ) + ctr = ctr + 1_${ik}$ end do if(ii<=m) then ! multiply q to the last block of c - call stdlib_${ci}$tpmlqt('L','N',kk , n, k, 0, mb, a(1,ii), lda,t(1, ctr * k + 1), ldt, & - c(1,1), ldc,c(ii,1), ldc, work, info ) + call stdlib${ii}$_${ci}$tpmlqt('L','N',kk , n, k, 0_${ik}$, mb, a(1_${ik}$,ii), lda,t(1_${ik}$, ctr * k + 1_${ik}$), ldt, & + c(1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) end if else if(right.and.notran) then ! multiply q to the last block of c kk = mod((n-k),(nb-k)) ctr = (n-k)/(nb-k) - if (kk>0) then + if (kk>0_${ik}$) then ii=n-kk+1 - call stdlib_${ci}$tpmlqt('R','N',m , kk, k, 0, mb, a(1, ii), lda,t(1, ctr * k + 1), & - ldt, c(1,1), ldc,c(1,ii), ldc, work, info ) + call stdlib${ii}$_${ci}$tpmlqt('R','N',m , kk, k, 0_${ik}$, mb, a(1_${ik}$, ii), lda,t(1_${ik}$, ctr * k + 1_${ik}$), & + ldt, c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info ) else ii=n+1 end if do i=ii-(nb-k),nb+1,-(nb-k) ! multiply q to the current block of c (1:m,i:i+mb) - ctr = ctr - 1 - call stdlib_${ci}$tpmlqt('R','N', m, nb-k, k, 0, mb, a(1, i), lda,t(1, ctr * k + 1), & - ldt, c(1,1), ldc,c(1,i), ldc, work, info ) + ctr = ctr - 1_${ik}$ + call stdlib${ii}$_${ci}$tpmlqt('R','N', m, nb-k, k, 0_${ik}$, mb, a(1_${ik}$, i), lda,t(1_${ik}$, ctr * k + 1_${ik}$), & + ldt, c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info ) end do ! multiply q to the first block of c (1:m,1:mb) - call stdlib_${ci}$gemlqt('R','N',m , nb, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_${ci}$gemlqt('R','N',m , nb, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (right.and.tran) then ! multiply q to the first block of c kk = mod((n-k),(nb-k)) ii=n-kk+1 - call stdlib_${ci}$gemlqt('R','C',m , nb, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_${ci}$gemlqt('R','C',m , nb, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) - ctr = 1 + ctr = 1_${ik}$ do i=nb+1,ii-nb+k,(nb-k) ! multiply q to the current block of c (1:m,i:i+mb) - call stdlib_${ci}$tpmlqt('R','C',m , nb-k, k, 0,mb, a(1,i), lda,t(1,ctr *k+1), ldt, c(1,& - 1), ldc,c(1,i), ldc, work, info ) - ctr = ctr + 1 + call stdlib${ii}$_${ci}$tpmlqt('R','C',m , nb-k, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$,ctr *k+1), ldt, c(1_${ik}$,& + 1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info ) + ctr = ctr + 1_${ik}$ end do if(ii<=n) then ! multiply q to the last block of c - call stdlib_${ci}$tpmlqt('R','C',m , kk, k, 0,mb, a(1,ii), lda,t(1, ctr * k + 1),ldt, c(& - 1,1), ldc,c(1,ii), ldc, work, info ) + call stdlib${ii}$_${ci}$tpmlqt('R','C',m , kk, k, 0_${ik}$,mb, a(1_${ik}$,ii), lda,t(1_${ik}$, ctr * k + 1_${ik}$),ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info ) end if end if - work(1) = lw + work(1_${ik}$) = lw return - end subroutine stdlib_${ci}$lamswlq + end subroutine stdlib${ii}$_${ci}$lamswlq - pure subroutine stdlib_${ci}$lamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & + pure subroutine stdlib${ii}$_${ci}$lamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & !! ZLAMTSQR: overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -42134,8 +42126,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: lda, m, n, k, mb, nb, ldt, lwork, ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, k, mb, nb, ldt, lwork, ldc ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*), t(ldt,*) complex(${ck}$), intent(out) :: work(*) @@ -42143,11 +42135,11 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran, lquery - integer(ilp) :: i, ii, kk, lw, ctr, q + integer(${ik}$) :: i, ii, kk, lw, ctr, q ! External Subroutines ! Executable Statements ! test the input arguments - lquery = lwork<0 + lquery = lwork<0_${ik}$ notran = stdlib_lsame( trans, 'N' ) tran = stdlib_lsame( trans, 'C' ) left = stdlib_lsame( side, 'L' ) @@ -42159,44 +42151,44 @@ module stdlib_linalg_lapack_${ci}$ lw = m * nb q = n end if - info = 0 + info = 0_${ik}$ if( .not.left .and. .not.right ) then - info = -1 + info = -1_${ik}$ else if( .not.tran .and. .not.notran ) then - info = -2 + info = -2_${ik}$ else if( m=max(m,n,k))) then - call stdlib_${ci}$gemqrt( side, trans, m, n, k, nb, a, lda,t, ldt, c, ldc, work, info) + call stdlib${ii}$_${ci}$gemqrt( side, trans, m, n, k, nb, a, lda,t, ldt, c, ldc, work, info) return end if @@ -42204,85 +42196,85 @@ module stdlib_linalg_lapack_${ci}$ ! multiply q to the last block of c kk = mod((m-k),(mb-k)) ctr = (m-k)/(mb-k) - if (kk>0) then + if (kk>0_${ik}$) then ii=m-kk+1 - call stdlib_${ci}$tpmqrt('L','N',kk , n, k, 0, nb, a(ii,1), lda,t(1, ctr * k + 1),ldt ,& - c(1,1), ldc,c(ii,1), ldc, work, info ) + call stdlib${ii}$_${ci}$tpmqrt('L','N',kk , n, k, 0_${ik}$, nb, a(ii,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$),ldt ,& + c(1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) else ii=m+1 end if do i=ii-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) - ctr = ctr - 1 - call stdlib_${ci}$tpmqrt('L','N',mb-k , n, k, 0,nb, a(i,1), lda,t(1,ctr * k + 1),ldt, & - c(1,1), ldc,c(i,1), ldc, work, info ) + ctr = ctr - 1_${ik}$ + call stdlib${ii}$_${ci}$tpmqrt('L','N',mb-k , n, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$,ctr * k + 1_${ik}$),ldt, & + c(1_${ik}$,1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info ) end do ! multiply q to the first block of c (1:mb,1:n) - call stdlib_${ci}$gemqrt('L','N',mb , n, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_${ci}$gemqrt('L','N',mb , n, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (left.and.tran) then ! multiply q to the first block of c kk = mod((m-k),(mb-k)) ii=m-kk+1 - ctr = 1 - call stdlib_${ci}$gemqrt('L','C',mb , n, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + ctr = 1_${ik}$ + call stdlib${ii}$_${ci}$gemqrt('L','C',mb , n, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) - call stdlib_${ci}$tpmqrt('L','C',mb-k , n, k, 0,nb, a(i,1), lda,t(1,ctr * k + 1),ldt, c(& - 1,1), ldc,c(i,1), ldc, work, info ) - ctr = ctr + 1 + call stdlib${ii}$_${ci}$tpmqrt('L','C',mb-k , n, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$,ctr * k + 1_${ik}$),ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info ) + ctr = ctr + 1_${ik}$ end do if(ii<=m) then ! multiply q to the last block of c - call stdlib_${ci}$tpmqrt('L','C',kk , n, k, 0,nb, a(ii,1), lda,t(1, ctr * k + 1), ldt, & - c(1,1), ldc,c(ii,1), ldc, work, info ) + call stdlib${ii}$_${ci}$tpmqrt('L','C',kk , n, k, 0_${ik}$,nb, a(ii,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$), ldt, & + c(1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) end if else if(right.and.tran) then ! multiply q to the last block of c kk = mod((n-k),(mb-k)) ctr = (n-k)/(mb-k) - if (kk>0) then + if (kk>0_${ik}$) then ii=n-kk+1 - call stdlib_${ci}$tpmqrt('R','C',m , kk, k, 0, nb, a(ii,1), lda,t(1,ctr * k + 1), ldt,& - c(1,1), ldc,c(1,ii), ldc, work, info ) + call stdlib${ii}$_${ci}$tpmqrt('R','C',m , kk, k, 0_${ik}$, nb, a(ii,1_${ik}$), lda,t(1_${ik}$,ctr * k + 1_${ik}$), ldt,& + c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info ) else ii=n+1 end if do i=ii-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) - ctr = ctr - 1 - call stdlib_${ci}$tpmqrt('R','C',m , mb-k, k, 0,nb, a(i,1), lda,t(1, ctr * k + 1), & - ldt, c(1,1), ldc,c(1,i), ldc, work, info ) + ctr = ctr - 1_${ik}$ + call stdlib${ii}$_${ci}$tpmqrt('R','C',m , mb-k, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$), & + ldt, c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info ) end do ! multiply q to the first block of c (1:m,1:mb) - call stdlib_${ci}$gemqrt('R','C',m , mb, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_${ci}$gemqrt('R','C',m , mb, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (right.and.notran) then ! multiply q to the first block of c kk = mod((n-k),(mb-k)) ii=n-kk+1 - ctr = 1 - call stdlib_${ci}$gemqrt('R','N', m, mb , k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + ctr = 1_${ik}$ + call stdlib${ii}$_${ci}$gemqrt('R','N', m, mb , k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) - call stdlib_${ci}$tpmqrt('R','N', m, mb-k, k, 0,nb, a(i,1), lda,t(1, ctr * k + 1),ldt, & - c(1,1), ldc,c(1,i), ldc, work, info ) - ctr = ctr + 1 + call stdlib${ii}$_${ci}$tpmqrt('R','N', m, mb-k, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$),ldt, & + c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info ) + ctr = ctr + 1_${ik}$ end do if(ii<=n) then ! multiply q to the last block of c - call stdlib_${ci}$tpmqrt('R','N', m, kk , k, 0,nb, a(ii,1), lda,t(1,ctr * k + 1),ldt, c(& - 1,1), ldc,c(1,ii), ldc, work, info ) + call stdlib${ii}$_${ci}$tpmqrt('R','N', m, kk , k, 0_${ik}$,nb, a(ii,1_${ik}$), lda,t(1_${ik}$,ctr * k + 1_${ik}$),ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info ) end if end if - work(1) = lw + work(1_${ik}$) = lw return - end subroutine stdlib_${ci}$lamtsqr + end subroutine stdlib${ii}$_${ci}$lamtsqr - real(${ck}$) function stdlib_${ci}$langb( norm, n, kl, ku, ab, ldab,work ) + real(${ck}$) function stdlib${ii}$_${ci}$langb( norm, n, kl, ku, ab, ldab,work ) !! ZLANGB: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of an !! n by n band matrix A, with kl sub-diagonals and ku super-diagonals. @@ -42291,19 +42283,19 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: norm - integer(ilp), intent(in) :: kl, ku, ldab, n + integer(${ik}$), intent(in) :: kl, ku, ldab, n ! Array Arguments real(${ck}$), intent(out) :: work(*) complex(${ck}$), intent(in) :: ab(ldab,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, k, l + integer(${ik}$) :: i, j, k, l real(${ck}$) :: scale, sum, value, temp ! 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))). @@ -42311,7 +42303,7 @@ module stdlib_linalg_lapack_${ci}$ do j = 1, n do i = max( ku+2-j, 1 ), min( n+ku+1-j, kl+ku+1 ) temp = abs( ab( i, j ) ) - if( value1 ) then - call stdlib_${ci}$lassq( n-1, dl, 1, scale, sum ) - call stdlib_${ci}$lassq( n-1, du, 1, scale, sum ) + call stdlib${ii}$_${ci}$lassq( n, d, 1_${ik}$, scale, sum ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_${ci}$lassq( n-1, dl, 1_${ik}$, scale, sum ) + call stdlib${ii}$_${ci}$lassq( n-1, du, 1_${ik}$, scale, sum ) end if anorm = scale*sqrt( sum ) end if - stdlib_${ci}$langt = anorm + stdlib${ii}$_${ci}$langt = anorm return - end function stdlib_${ci}$langt + end function stdlib${ii}$_${ci}$langt - real(${ck}$) function stdlib_${ci}$lanhb( norm, uplo, n, k, ab, ldab,work ) + real(${ck}$) function stdlib${ii}$_${ci}$lanhb( norm, uplo, n, k, ab, ldab,work ) !! ZLANHB: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of an !! n by n hermitian band matrix A, with k super-diagonals. @@ -42514,19 +42506,19 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(${ck}$), intent(out) :: work(*) complex(${ck}$), intent(in) :: ab(ldab,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, l + integer(${ik}$) :: i, j, l real(${ck}$) :: absa, scale, sum, value ! Intrinsic Functions intrinsic :: abs,real,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))). @@ -42535,18 +42527,18 @@ module stdlib_linalg_lapack_${ci}$ do j = 1, n do i = max( k+2-j, 1 ), k sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum end do sum = abs( real( ab( k+1, j ),KIND=${ck}$) ) - if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum end do else do j = 1, n - sum = abs( real( ab( 1, j ),KIND=${ck}$) ) - if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum + sum = abs( real( ab( 1_${ik}$, j ),KIND=${ck}$) ) + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum do i = 2, min( n+1-j, k+1 ) sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum end do end do end if @@ -42557,7 +42549,7 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -42567,21 +42559,21 @@ module stdlib_linalg_lapack_${ci}$ end do do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum end do else do i = 1, n work( i ) = zero end do do j = 1, n - sum = work( j ) + abs( real( ab( 1, j ),KIND=${ck}$) ) - l = 1 - j + sum = work( j ) + abs( real( ab( 1_${ik}$, j ),KIND=${ck}$) ) + 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_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum end do end if else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & @@ -42589,42 +42581,42 @@ module stdlib_linalg_lapack_${ci}$ ! 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_${ci}$lassq( min( j-1, k ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) + call stdlib${ii}$_${ci}$lassq( 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_${ci}$lassq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) + call stdlib${ii}$_${ci}$lassq( 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 do j = 1, n if( real( ab( l, j ),KIND=${ck}$)/=zero ) then absa = abs( real( ab( l, j ),KIND=${ck}$) ) if( scale l(0,0) temp = abs( real( a( j+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp do i = 1, n - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do do j = 1, k - 1 do i = 0, j - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do - i = j - 1 + i = j - 1_${ik}$ ! l(k+j,k+j) temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp i = j ! -> l(j,j) temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp do i = j + 1, n - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do end do else @@ -42826,65 +42818,65 @@ module stdlib_linalg_lapack_${ci}$ do j = 0, k - 2 do i = 0, k + j - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do - i = k + j - 1 + i = k + j - 1_${ik}$ ! -> u(i,i) temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp - i = i + 1 + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp + i = i + 1_${ik}$ ! =k+j; i -> u(j,j) temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp do i = k + j + 1, n - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do end do do i = 0, n - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp ! j=k-1 end do ! i=n-1 -> u(n-1,n-1) temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end if else ! xpose case; a is k by n - if( ilu==1 ) then + if( ilu==1_${ik}$ ) then ! uplo ='l' do j = 0, k - 2 do i = 0, j - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do i = j ! l(i,i) temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp - i = j + 1 + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp + i = j + 1_${ik}$ ! l(j+k,j+k) temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp do i = j + 2, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do end do - j = k - 1 + j = k - 1_${ik}$ do i = 0, k - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do - i = k - 1 + i = k - 1_${ik}$ ! -> l(i,i) is at a(i,j) temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp do j = k, n - 1 do i = 0, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do end do else @@ -42892,69 +42884,69 @@ module stdlib_linalg_lapack_${ci}$ do j = 0, k - 2 do i = 0, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do end do - j = k - 1 + j = k - 1_${ik}$ ! -> u(j,j) is at a(0,j) - temp = abs( real( a( 0+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + temp = abs( real( a( 0_${ik}$+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp do i = 1, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do do j = k, n - 1 do i = 0, j - k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do i = j - k ! -> u(i,i) at a(i,j) temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp - i = j - k + 1 + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp + i = j - k + 1_${ik}$ ! u(j,j) temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp do i = j - k + 2, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do end do end if end if else ! n is even - if( ifm==1 ) then + if( ifm==1_${ik}$ ) then ! a is n+1 by k - if( ilu==1 ) then + if( ilu==1_${ik}$ ) then ! uplo ='l' - j = 0 + j = 0_${ik}$ ! -> l(k,k) temp = abs( real( a( j+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp temp = abs( real( a( j+1+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp do i = 2, n temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do do j = 1, k - 1 do i = 0, j - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do i = j ! l(k+j,k+j) temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp - i = j + 1 + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp + i = j + 1_${ik}$ ! -> l(j,j) temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp do i = j + 2, n temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do end do else @@ -42962,77 +42954,77 @@ module stdlib_linalg_lapack_${ci}$ do j = 0, k - 2 do i = 0, k + j - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do i = k + j ! -> u(i,i) temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp - i = i + 1 + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp + i = i + 1_${ik}$ ! =k+j+1; i -> u(j,j) temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp do i = k + j + 2, n temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do end do do i = 0, n - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp ! j=k-1 end do ! i=n-1 -> u(n-1,n-1) temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp i = n ! -> u(k-1,k-1) temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end if else ! xpose case; a is k by n+1 - if( ilu==1 ) then + if( ilu==1_${ik}$ ) then ! uplo ='l' - j = 0 + j = 0_${ik}$ ! -> l(k,k) at a(0,0) temp = abs( real( a( j+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp do i = 1, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do do j = 1, k - 1 do i = 0, j - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do - i = j - 1 + i = j - 1_${ik}$ ! l(i,i) temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp i = j ! l(j+k,j+k) temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp do i = j + 1, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do end do j = k do i = 0, k - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do - i = k - 1 + i = k - 1_${ik}$ ! -> l(i,i) is at a(i,j) temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp do j = k + 1, n do i = 0, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do end do else @@ -43040,56 +43032,56 @@ module stdlib_linalg_lapack_${ci}$ do j = 0, k - 1 do i = 0, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do end do j = k ! -> u(j,j) is at a(0,j) - temp = abs( real( a( 0+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + temp = abs( real( a( 0_${ik}$+j*lda ),KIND=${ck}$) ) + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp do i = 1, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do do j = k + 1, n - 1 do i = 0, j - k - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do - i = j - k - 1 + i = j - k - 1_${ik}$ ! -> u(i,i) at a(i,j) temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp i = j - k ! u(j,j) temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp do i = j - k + 1, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do end do j = n do i = 0, k - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do - i = k - 1 + i = k - 1_${ik}$ ! u(k,k) at a(i,j) temp = abs( real( a( i+j*lda ),KIND=${ck}$) ) - if( value < temp .or. stdlib_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end if end if end if else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( & norm=='1' ) ) then ! find normi(a) ( = norm1(a), since a is hermitian). - if( ifm==1 ) then + if( ifm==1_${ik}$ ) then ! a is 'n' - k = n / 2 - if( noe==1 ) then + k = n / 2_${ik}$ + if( noe==1_${ik}$ ) then ! n is odd - if( ilu==0 ) then + if( ilu==0_${ik}$ ) then ! uplo = 'u' do i = 0, k - 1 work( i ) = zero @@ -43106,13 +43098,13 @@ module stdlib_linalg_lapack_${ci}$ ! -> 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( real( a( i+j*lda ),KIND=${ck}$) ) ! -> 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 @@ -43121,14 +43113,14 @@ module stdlib_linalg_lapack_${ci}$ 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_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do else ! ilu = 1 - k = k + 1 + k = k + 1_${ik}$ ! k=(n+1)/2 for n odd and ilu=1 do i = k, n - 1 work( i ) = zero @@ -43141,20 +43133,20 @@ module stdlib_linalg_lapack_${ci}$ s = s + aa work( i+k ) = work( i+k ) + aa end do - if( j>0 ) then + if( j>0_${ik}$ ) then aa = abs( real( a( i+j*lda ),KIND=${ck}$) ) ! -> a(j+k,j+k) s = s + aa work( i+k ) = work( i+k ) + s ! i=j - i = i + 1 + i = i + 1_${ik}$ end if aa = abs( real( a( i+j*lda ),KIND=${ck}$) ) ! -> 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 @@ -43162,15 +43154,15 @@ module stdlib_linalg_lapack_${ci}$ 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_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do end if else ! n is even - if( ilu==0 ) then + if( ilu==0_${ik}$ ) then ! uplo = 'u' do i = 0, k - 1 work( i ) = zero @@ -43186,13 +43178,13 @@ module stdlib_linalg_lapack_${ci}$ aa = abs( real( a( i+j*lda ),KIND=${ck}$) ) ! -> a(j+k,j+k) work( j+k ) = s + aa - i = i + 1 + i = i + 1_${ik}$ aa = abs( real( a( i+j*lda ),KIND=${ck}$) ) ! -> 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 @@ -43200,10 +43192,10 @@ module stdlib_linalg_lapack_${ci}$ 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_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do else ! ilu = 1 @@ -43223,13 +43215,13 @@ module stdlib_linalg_lapack_${ci}$ s = s + aa work( i+k ) = work( i+k ) + s ! i=j - i = i + 1 + i = i + 1_${ik}$ aa = abs( real( a( i+j*lda ),KIND=${ck}$) ) ! -> 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 @@ -43237,23 +43229,23 @@ module stdlib_linalg_lapack_${ci}$ 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_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do end if end if else ! ifm=0 - k = n / 2 - if( noe==1 ) then + k = n / 2_${ik}$ + if( noe==1_${ik}$ ) then ! n is odd - if( ilu==0 ) then + if( ilu==0_${ik}$ ) then ! uplo = 'u' n1 = k ! n/2 - k = k + 1 + k = k + 1_${ik}$ ! k is the row size and lda do i = n1, n - 1 work( i ) = zero @@ -43269,7 +43261,7 @@ module stdlib_linalg_lapack_${ci}$ work( j ) = s end do ! j=n1=k-1 is special - s = abs( real( a( 0+j*lda ),KIND=${ck}$) ) + s = abs( real( a( 0_${ik}$+j*lda ),KIND=${ck}$) ) ! a(k-1,k-1) do i = 1, k - 1 aa = abs( a( i+j*lda ) ) @@ -43291,11 +43283,11 @@ module stdlib_linalg_lapack_${ci}$ ! a(j-k,j-k) s = s + aa work( j-k ) = work( j-k ) + s - i = i + 1 + i = i + 1_${ik}$ s = abs( real( a( i+j*lda ),KIND=${ck}$) ) ! 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 @@ -43303,14 +43295,14 @@ module stdlib_linalg_lapack_${ci}$ 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_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do else ! ilu=1 - k = k + 1 + k = k + 1_${ik}$ ! k=(n+1)/2 for n odd and ilu=1 do i = k, n - 1 work( i ) = zero @@ -43329,12 +43321,12 @@ module stdlib_linalg_lapack_${ci}$ 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( real( a( i+j*lda ),KIND=${ck}$) ) 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 @@ -43367,15 +43359,15 @@ module stdlib_linalg_lapack_${ci}$ 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_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do end if else ! n is even - if( ilu==0 ) then + if( ilu==0_${ik}$ ) then ! uplo = 'u' do i = k, n - 1 work( i ) = zero @@ -43391,7 +43383,7 @@ module stdlib_linalg_lapack_${ci}$ work( j ) = s end do ! j=k - aa = abs( real( a( 0+j*lda ),KIND=${ck}$) ) + aa = abs( real( a( 0_${ik}$+j*lda ),KIND=${ck}$) ) ! a(k,k) s = aa do i = 1, k - 1 @@ -43414,12 +43406,12 @@ module stdlib_linalg_lapack_${ci}$ ! 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( real( a( i+j*lda ),KIND=${ck}$) ) ! 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 @@ -43440,10 +43432,10 @@ module stdlib_linalg_lapack_${ci}$ ! 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_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do else ! ilu=1 @@ -43451,7 +43443,7 @@ module stdlib_linalg_lapack_${ci}$ work( i ) = zero end do ! j=0 is special :process col a(k:n-1,k) - s = abs( real( a( 0 ),KIND=${ck}$) ) + s = abs( real( a( 0_${ik}$ ),KIND=${ck}$) ) ! a(k,k) do i = 1, k - 1 aa = abs( a( i ) ) @@ -43474,12 +43466,12 @@ module stdlib_linalg_lapack_${ci}$ 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( real( a( i+j*lda ),KIND=${ck}$) ) 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 @@ -43512,10 +43504,10 @@ module stdlib_linalg_lapack_${ci}$ 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_${c2ri(ci)}$isnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_${c2ri(ci)}$isnan( temp ) )value = temp end do end if end if @@ -43523,80 +43515,80 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$lassq( k-j-2, a( k+j+1+j*lda ), 1, scale, s ) + call stdlib${ii}$_${ci}$lassq( k-j-2, a( k+j+1+j*lda ), 1_${ik}$, scale, s ) ! l at a(k,0) end do do j = 0, k - 1 - call stdlib_${ci}$lassq( k+j-1, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_${ci}$lassq( k+j-1, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! trap u at a(0,0) end do s = s + s ! double s for the off diagonal elements - l = k - 1 + l = k - 1_${ik}$ ! -> u(k,k) at a(k-1,0) do i = 0, k - 2 aa = real( a( l ),KIND=${ck}$) ! u(k+i,k+i) if( aa/=zero ) then if( scale u(k-1,k-1) at a(0,k-1) aa = real( a( l ),KIND=${ck}$) ! u(k-1,k-1) if( aa/=zero ) then if( scale u(j-k,j-k) if( aa/=zero ) then if( scale u(j,j) if( aa/=zero ) then if( scale l(0,0) at a(0,0) do i = 0, k - 2 aa = real( a( l ),KIND=${ck}$) ! l(i,i) if( aa/=zero ) then if( scale k-1 + (k-1)*lda or l(k-1,k-1) at a(k-1,k-1) aa = real( a( l ),KIND=${ck}$) ! l(k-1,k-1) at a(k-1,k-1) if( aa/=zero ) then if( scale l(k,k) at a(0,0) do i = 0, k - 1 aa = real( a( l ),KIND=${ck}$) ! l(k-1+i,k-1+i) if( aa/=zero ) then if( scale u(k,k) at a(0,k) aa = real( a( l ),KIND=${ck}$) ! u(k,k) if( aa/=zero ) then if( scale u(j-k-1,j-k-1) if( aa/=zero ) then if( scale u(j,j) if( aa/=zero ) then if( scale u(k-1,k-1) at a(k-1,n) @@ -43874,38 +43866,38 @@ module stdlib_linalg_lapack_${ci}$ ! u(k,k) if( aa/=zero ) then if( scale l(k,k) at a(0,0) aa = real( a( l ),KIND=${ck}$) ! l(k,k) at a(0,0) if( aa/=zero ) then if( scale k - 1 + k*lda or l(k-1,k-1) at a(k-1,k) aa = real( a( l ),KIND=${ck}$) ! l(k-1,k-1) at a(k-1,k) if( aa/=zero ) then if( scale1 ) then - call stdlib_${ci}$lassq( n-1, e, 1, scale, sum ) - sum = 2*sum + if( n>1_${ik}$ ) then + call stdlib${ii}$_${ci}$lassq( n-1, e, 1_${ik}$, scale, sum ) + sum = 2_${ik}$*sum end if - call stdlib_${c2ri(ci)}$lassq( n, d, 1, scale, sum ) + call stdlib${ii}$_${c2ri(ci)}$lassq( n, d, 1_${ik}$, scale, sum ) anorm = scale*sqrt( sum ) end if - stdlib_${ci}$lanht = anorm + stdlib${ii}$_${ci}$lanht = anorm return - end function stdlib_${ci}$lanht + end function stdlib${ii}$_${ci}$lanht - real(${ck}$) function stdlib_${ci}$lansb( norm, uplo, n, k, ab, ldab,work ) + real(${ck}$) function stdlib${ii}$_${ci}$lansb( norm, uplo, n, k, ab, ldab,work ) !! ZLANSB: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of an !! n by n symmetric band matrix A, with k super-diagonals. @@ -44226,19 +44218,19 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(${ck}$), intent(out) :: work(*) complex(${ck}$), intent(in) :: ab(ldab,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, l + integer(${ik}$) :: i, j, l real(${ck}$) :: 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))). @@ -44247,14 +44239,14 @@ module stdlib_linalg_lapack_${ci}$ do j = 1, n do i = max( k+2-j, 1 ), k + 1 sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum end do end do else do j = 1, n do i = 1, min( n+1-j, k+1 ) sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum end do end do end if @@ -44265,7 +44257,7 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -44275,21 +44267,21 @@ module stdlib_linalg_lapack_${ci}$ end do do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum end do else do i = 1, n work( i ) = zero end do do j = 1, n - sum = work( j ) + abs( 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_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum end do end if else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & @@ -44297,32 +44289,32 @@ module stdlib_linalg_lapack_${ci}$ ! 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_${ci}$lassq( min( j-1, k ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) + call stdlib${ii}$_${ci}$lassq( 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_${ci}$lassq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) + call stdlib${ii}$_${ci}$lassq( 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_${ci}$lassq( n, ab( l, 1 ), ldab, scale, sum ) + call stdlib${ii}$_${ci}$lassq( n, ab( l, 1_${ik}$ ), ldab, scale, sum ) value = scale*sqrt( sum ) end if - stdlib_${ci}$lansb = value + stdlib${ii}$_${ci}$lansb = value return - end function stdlib_${ci}$lansb + end function stdlib${ii}$_${ci}$lansb - real(${ck}$) function stdlib_${ci}$lansp( norm, uplo, n, ap, work ) + real(${ck}$) function stdlib${ii}$_${ci}$lansp( norm, uplo, n, ap, work ) !! ZLANSP: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! complex symmetric matrix A, supplied in packed form. @@ -44331,47 +44323,47 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(${ck}$), intent(out) :: work(*) complex(${ck}$), intent(in) :: ap(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, k + integer(${ik}$) :: i, j, k real(${ck}$) :: absa, scale, sum, value ! Intrinsic Functions intrinsic :: abs,real,aimag,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_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( 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_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( 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 ! 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 @@ -44379,14 +44371,14 @@ module stdlib_linalg_lapack_${ci}$ 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_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum end do else do i = 1, n @@ -44394,14 +44386,14 @@ module stdlib_linalg_lapack_${ci}$ 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_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum end do end if else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & @@ -44409,53 +44401,53 @@ module stdlib_linalg_lapack_${ci}$ ! find normf(a). scale = zero sum = one - k = 2 + k = 2_${ik}$ if( stdlib_lsame( uplo, 'U' ) ) then do j = 2, n - call stdlib_${ci}$lassq( j-1, ap( k ), 1, scale, sum ) + call stdlib${ii}$_${ci}$lassq( j-1, ap( k ), 1_${ik}$, scale, sum ) k = k + j end do else do j = 1, n - 1 - call stdlib_${ci}$lassq( n-j, ap( k ), 1, scale, sum ) - k = k + n - j + 1 + call stdlib${ii}$_${ci}$lassq( 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( real( ap( k ),KIND=${ck}$)/=zero ) then absa = abs( real( ap( k ),KIND=${ck}$) ) if( scale0 ) then + if( k>0_${ik}$ ) then do j = 2, n - call stdlib_${ci}$lassq( min( j-1, k ),ab( max( k+2-j, 1 ), j ), 1, scale,& + call stdlib${ii}$_${ci}$lassq( min( j-1, k ),ab( max( k+2-j, 1_${ik}$ ), j ), 1_${ik}$, scale,& sum ) end do end if @@ -44716,7 +44708,7 @@ module stdlib_linalg_lapack_${ci}$ scale = zero sum = one do j = 1, n - call stdlib_${ci}$lassq( min( j, k+1 ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) + call stdlib${ii}$_${ci}$lassq( min( j, k+1 ), ab( max( k+2-j, 1_${ik}$ ), j ),1_${ik}$, scale, sum ) end do end if @@ -44724,27 +44716,27 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$lassq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) + call stdlib${ii}$_${ci}$lassq( 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_${ci}$lassq( min( n-j+1, k+1 ), ab( 1, j ), 1, scale,sum ) + call stdlib${ii}$_${ci}$lassq( 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_${ci}$lantb = value + stdlib${ii}$_${ci}$lantb = value return - end function stdlib_${ci}$lantb + end function stdlib${ii}$_${ci}$lantb - real(${ck}$) function stdlib_${ci}$lantp( norm, uplo, diag, n, ap, work ) + real(${ck}$) function stdlib${ii}$_${ci}$lantp( norm, uplo, diag, n, ap, work ) !! ZLANTP: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! triangular matrix A, supplied in packed form. @@ -44753,7 +44745,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(${ck}$), intent(out) :: work(*) complex(${ck}$), intent(in) :: ap(*) @@ -44761,23 +44753,23 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: udiag - integer(ilp) :: i, j, k + integer(${ik}$) :: i, j, k real(${ck}$) :: 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_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum end do k = k + j end do @@ -44785,9 +44777,9 @@ module stdlib_linalg_lapack_${ci}$ do j = 1, n do i = k + 1, k + n - j sum = abs( ap( i ) ) - if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum end do - k = k + n - j + 1 + k = k + n - j + 1_${ik}$ end do end if else @@ -44796,7 +44788,7 @@ module stdlib_linalg_lapack_${ci}$ do j = 1, n do i = k, k + j - 1 sum = abs( ap( i ) ) - if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum end do k = k + j end do @@ -44804,16 +44796,16 @@ module stdlib_linalg_lapack_${ci}$ do j = 1, n do i = k, k + n - j sum = abs( ap( i ) ) - if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( 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 ! 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 @@ -44829,7 +44821,7 @@ module stdlib_linalg_lapack_${ci}$ end do end if k = k + j - if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum end do else do j = 1, n @@ -44844,13 +44836,13 @@ module stdlib_linalg_lapack_${ci}$ sum = sum + abs( ap( i ) ) end do end if - k = k + n - j + 1 - if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum + k = k + n - j + 1_${ik}$ + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( 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 @@ -44859,9 +44851,9 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -44870,7 +44862,7 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -44880,10 +44872,10 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -44893,7 +44885,7 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -44901,7 +44893,7 @@ module stdlib_linalg_lapack_${ci}$ value = zero do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum end do else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & then @@ -44910,17 +44902,17 @@ module stdlib_linalg_lapack_${ci}$ if( stdlib_lsame( diag, 'U' ) ) then scale = one sum = n - k = 2 + k = 2_${ik}$ do j = 2, n - call stdlib_${ci}$lassq( j-1, ap( k ), 1, scale, sum ) + call stdlib${ii}$_${ci}$lassq( 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_${ci}$lassq( j, ap( k ), 1, scale, sum ) + call stdlib${ii}$_${ci}$lassq( j, ap( k ), 1_${ik}$, scale, sum ) k = k + j end do end if @@ -44928,29 +44920,29 @@ module stdlib_linalg_lapack_${ci}$ if( stdlib_lsame( diag, 'U' ) ) then scale = one sum = n - k = 2 + k = 2_${ik}$ do j = 1, n - 1 - call stdlib_${ci}$lassq( n-j, ap( k ), 1, scale, sum ) - k = k + n - j + 1 + call stdlib${ii}$_${ci}$lassq( 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_${ci}$lassq( n-j+1, ap( k ), 1, scale, sum ) - k = k + n - j + 1 + call stdlib${ii}$_${ci}$lassq( 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_${ci}$lantp = value + stdlib${ii}$_${ci}$lantp = value return - end function stdlib_${ci}$lantp + end function stdlib${ii}$_${ci}$lantp - real(${ck}$) function stdlib_${ci}$lantr( norm, uplo, diag, m, n, a, lda,work ) + real(${ck}$) function stdlib${ii}$_${ci}$lantr( norm, uplo, diag, m, n, a, lda,work ) !! ZLANTR: returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! trapezoidal or triangular matrix A. @@ -44959,7 +44951,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(${ck}$), intent(out) :: work(*) complex(${ck}$), intent(in) :: a(lda,*) @@ -44967,12 +44959,12 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: udiag - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(${ck}$) :: 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))). @@ -44982,14 +44974,14 @@ module stdlib_linalg_lapack_${ci}$ do j = 1, n do i = 1, min( m, j-1 ) sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum end do end do else do j = 1, n do i = j + 1, m sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum end do end do end if @@ -44999,14 +44991,14 @@ module stdlib_linalg_lapack_${ci}$ do j = 1, n do i = 1, min( m, j ) sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum end do end do else do j = 1, n do i = j, m sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum end do end do end if @@ -45028,7 +45020,7 @@ module stdlib_linalg_lapack_${ci}$ sum = sum + abs( a( i, j ) ) end do end if - if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum end do else do j = 1, n @@ -45043,7 +45035,7 @@ module stdlib_linalg_lapack_${ci}$ sum = sum + abs( a( i, j ) ) end do end if - if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum end do end if else if( stdlib_lsame( norm, 'I' ) ) then @@ -45095,7 +45087,7 @@ module stdlib_linalg_lapack_${ci}$ value = zero do i = 1, m sum = work( i ) - if( value < sum .or. stdlib_${c2ri(ci)}$isnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_${c2ri(ci)}$isnan( sum ) ) value = sum end do else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & then @@ -45105,13 +45097,13 @@ module stdlib_linalg_lapack_${ci}$ scale = one sum = min( m, n ) do j = 2, n - call stdlib_${ci}$lassq( min( m, j-1 ), a( 1, j ), 1, scale, sum ) + call stdlib${ii}$_${ci}$lassq( 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_${ci}$lassq( min( m, j ), a( 1, j ), 1, scale, sum ) + call stdlib${ii}$_${ci}$lassq( min( m, j ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum ) end do end if else @@ -45119,24 +45111,24 @@ module stdlib_linalg_lapack_${ci}$ scale = one sum = min( m, n ) do j = 1, n - call stdlib_${ci}$lassq( m-j, a( min( m, j+1 ), j ), 1, scale,sum ) + call stdlib${ii}$_${ci}$lassq( 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_${ci}$lassq( m-j+1, a( j, j ), 1, scale, sum ) + call stdlib${ii}$_${ci}$lassq( m-j+1, a( j, j ), 1_${ik}$, scale, sum ) end do end if end if value = scale*sqrt( sum ) end if - stdlib_${ci}$lantr = value + stdlib${ii}$_${ci}$lantr = value return - end function stdlib_${ci}$lantr + end function stdlib${ii}$_${ci}$lantr - pure subroutine stdlib_${ci}$lapll( n, x, incx, y, incy, ssmin ) + pure subroutine stdlib${ii}$_${ci}$lapll( n, x, incx, y, incy, ssmin ) !! Given two column vectors X and Y, let !! A = ( X Y ). !! The subroutine first computes the QR factorization of A = Q*R, @@ -45147,7 +45139,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n real(${ck}$), intent(out) :: ssmin ! Array Arguments complex(${ck}$), intent(inout) :: x(*), y(*) @@ -45161,26 +45153,26 @@ module stdlib_linalg_lapack_${ci}$ intrinsic :: abs,conjg ! Executable Statements ! quick return if possible - if( n<=1 ) then + if( n<=1_${ik}$ ) then ssmin = zero return end if ! compute the qr factorization of the n-by-2 matrix ( x y ) - call stdlib_${ci}$larfg( n, x( 1 ), x( 1+incx ), incx, tau ) - a11 = x( 1 ) - x( 1 ) = cone - c = -conjg( tau )*stdlib_${ci}$dotc( n, x, incx, y, incy ) - call stdlib_${ci}$axpy( n, c, x, incx, y, incy ) - call stdlib_${ci}$larfg( n-1, y( 1+incy ), y( 1+2*incy ), incy, tau ) - a12 = y( 1 ) - a22 = y( 1+incy ) + call stdlib${ii}$_${ci}$larfg( n, x( 1_${ik}$ ), x( 1_${ik}$+incx ), incx, tau ) + a11 = x( 1_${ik}$ ) + x( 1_${ik}$ ) = cone + c = -conjg( tau )*stdlib${ii}$_${ci}$dotc( n, x, incx, y, incy ) + call stdlib${ii}$_${ci}$axpy( n, c, x, incx, y, incy ) + call stdlib${ii}$_${ci}$larfg( n-1, y( 1_${ik}$+incy ), y( 1_${ik}$+2*incy ), incy, tau ) + a12 = y( 1_${ik}$ ) + a22 = y( 1_${ik}$+incy ) ! compute the svd of 2-by-2 upper triangular matrix. - call stdlib_${c2ri(ci)}$las2( abs( a11 ), abs( a12 ), abs( a22 ), ssmin, ssmax ) + call stdlib${ii}$_${c2ri(ci)}$las2( abs( a11 ), abs( a12 ), abs( a22 ), ssmin, ssmax ) return - end subroutine stdlib_${ci}$lapll + end subroutine stdlib${ii}$_${ci}$lapll - pure subroutine stdlib_${ci}$lapmr( forwrd, m, n, x, ldx, k ) + pure subroutine stdlib${ii}$_${ci}$lapmr( forwrd, m, n, x, ldx, k ) !! ZLAPMR: rearranges the rows of the M by N matrix X as specified !! by the permutation K(1),K(2),...,K(M) of the integers 1,...,M. !! If FORWRD = .TRUE., forward permutation: @@ -45192,13 +45184,13 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), intent(inout) :: x(ldx,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, in, j, jj + integer(${ik}$) :: i, in, j, jj complex(${ck}$) :: temp ! Executable Statements if( m<=1 )return @@ -45245,10 +45237,10 @@ module stdlib_linalg_lapack_${ci}$ end do end if return - end subroutine stdlib_${ci}$lapmr + end subroutine stdlib${ii}$_${ci}$lapmr - pure subroutine stdlib_${ci}$lapmt( forwrd, m, n, x, ldx, k ) + pure subroutine stdlib${ii}$_${ci}$lapmt( forwrd, m, n, x, ldx, k ) !! ZLAPMT: rearranges the columns of the M by N matrix X as specified !! by the permutation K(1),K(2),...,K(N) of the integers 1,...,N. !! If FORWRD = .TRUE., forward permutation: @@ -45260,13 +45252,13 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), intent(inout) :: x(ldx,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ii, in, j + integer(${ik}$) :: i, ii, in, j complex(${ck}$) :: temp ! Executable Statements if( n<=1 )return @@ -45313,10 +45305,10 @@ module stdlib_linalg_lapack_${ci}$ end do end if return - end subroutine stdlib_${ci}$lapmt + end subroutine stdlib${ii}$_${ci}$lapmt - pure subroutine stdlib_${ci}$laqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) + pure subroutine stdlib${ii}$_${ci}$laqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) !! ZLAQGB: equilibrates a general M by N band matrix A with KL !! subdiagonals and KU superdiagonals using the row and scaling factors !! in the vectors R and C. @@ -45326,7 +45318,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(${ck}$), intent(in) :: amax, colcnd, rowcnd ! Array Arguments real(${ck}$), intent(in) :: c(*), r(*) @@ -45336,18 +45328,18 @@ module stdlib_linalg_lapack_${ci}$ real(${ck}$), parameter :: thresh = 0.1e+0_${ck}$ ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(${ck}$) :: 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_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + small = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' ) large = one / small if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then ! no row scaling @@ -45383,10 +45375,10 @@ module stdlib_linalg_lapack_${ci}$ equed = 'B' end if return - end subroutine stdlib_${ci}$laqgb + end subroutine stdlib${ii}$_${ci}$laqgb - pure subroutine stdlib_${ci}$laqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed ) + pure subroutine stdlib${ii}$_${ci}$laqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed ) !! ZLAQGE: equilibrates a general M by N matrix A using the row and !! column scaling factors in the vectors R and C. ! -- lapack auxiliary routine -- @@ -45394,7 +45386,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(${ck}$), intent(in) :: amax, colcnd, rowcnd ! Array Arguments real(${ck}$), intent(in) :: c(*), r(*) @@ -45404,16 +45396,16 @@ module stdlib_linalg_lapack_${ci}$ real(${ck}$), parameter :: thresh = 0.1e+0_${ck}$ ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(${ck}$) :: 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_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + small = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' ) large = one / small if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then ! no row scaling @@ -45449,10 +45441,10 @@ module stdlib_linalg_lapack_${ci}$ equed = 'B' end if return - end subroutine stdlib_${ci}$laqge + end subroutine stdlib${ii}$_${ci}$laqge - pure subroutine stdlib_${ci}$laqhb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_${ci}$laqhb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) !! ZLAQHB: equilibrates a Hermitian band matrix A !! using the scaling factors in the vector S. ! -- lapack auxiliary routine -- @@ -45461,7 +45453,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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(${ck}$), intent(in) :: amax, scond ! Array Arguments real(${ck}$), intent(out) :: s(*) @@ -45471,18 +45463,18 @@ module stdlib_linalg_lapack_${ci}$ real(${ck}$), parameter :: thresh = 0.1e+0_${ck}$ ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(${ck}$) :: cj, large, small ! Intrinsic Functions intrinsic :: real,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_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + small = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -45502,19 +45494,19 @@ module stdlib_linalg_lapack_${ci}$ ! lower triangle of a is stored. do j = 1, n cj = s( j ) - ab( 1, j ) = cj*cj*real( ab( 1, j ),KIND=${ck}$) + ab( 1_${ik}$, j ) = cj*cj*real( ab( 1_${ik}$, j ),KIND=${ck}$) do i = j + 1, 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_${ci}$laqhb + end subroutine stdlib${ii}$_${ci}$laqhb - pure subroutine stdlib_${ci}$laqhe( uplo, n, a, lda, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_${ci}$laqhe( uplo, n, a, lda, s, scond, amax, equed ) !! ZLAQHE: equilibrates a Hermitian matrix A using the scaling factors !! in the vector S. ! -- lapack auxiliary routine -- @@ -45523,7 +45515,7 @@ module stdlib_linalg_lapack_${ci}$ ! Scalar Arguments character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: lda, n + integer(${ik}$), intent(in) :: lda, n real(${ck}$), intent(in) :: amax, scond ! Array Arguments real(${ck}$), intent(in) :: s(*) @@ -45533,18 +45525,18 @@ module stdlib_linalg_lapack_${ci}$ real(${ck}$), parameter :: thresh = 0.1e+0_${ck}$ ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(${ck}$) :: cj, large, small ! Intrinsic Functions intrinsic :: real ! 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_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + small = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -45573,10 +45565,10 @@ module stdlib_linalg_lapack_${ci}$ equed = 'Y' end if return - end subroutine stdlib_${ci}$laqhe + end subroutine stdlib${ii}$_${ci}$laqhe - pure subroutine stdlib_${ci}$laqhp( uplo, n, ap, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_${ci}$laqhp( uplo, n, ap, s, scond, amax, equed ) !! ZLAQHP: equilibrates a Hermitian matrix A using the scaling factors !! in the vector S. ! -- lapack auxiliary routine -- @@ -45585,7 +45577,7 @@ module stdlib_linalg_lapack_${ci}$ ! Scalar Arguments character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(${ck}$), intent(in) :: amax, scond ! Array Arguments real(${ck}$), intent(in) :: s(*) @@ -45595,18 +45587,18 @@ module stdlib_linalg_lapack_${ci}$ real(${ck}$), parameter :: thresh = 0.1e+0_${ck}$ ! Local Scalars - integer(ilp) :: i, j, jc + integer(${ik}$) :: i, j, jc real(${ck}$) :: cj, large, small ! Intrinsic Functions intrinsic :: real ! 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_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + small = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -45615,7 +45607,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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 - 1 @@ -45626,23 +45618,23 @@ module stdlib_linalg_lapack_${ci}$ end do else ! lower triangle of a is stored. - jc = 1 + jc = 1_${ik}$ do j = 1, n cj = s( j ) ap( jc ) = cj*cj*real( ap( jc ),KIND=${ck}$) do i = j + 1, n ap( jc+i-j ) = cj*s( i )*ap( jc+i-j ) end do - jc = jc + n - j + 1 + jc = jc + n - j + 1_${ik}$ end do end if equed = 'Y' end if return - end subroutine stdlib_${ci}$laqhp + end subroutine stdlib${ii}$_${ci}$laqhp - pure subroutine stdlib_${ci}$laqp2( m, n, offset, a, lda, jpvt, tau, vn1, vn2,work ) + pure subroutine stdlib${ii}$_${ci}$laqp2( m, n, offset, a, lda, jpvt, tau, vn1, vn2,work ) !! ZLAQP2: computes a QR factorization with column pivoting of !! the block A(OFFSET+1:M,1:N). !! The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. @@ -45650,9 +45642,9 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, m, n, offset + integer(${ik}$), intent(in) :: lda, m, n, offset ! Array Arguments - integer(ilp), intent(inout) :: jpvt(*) + integer(${ik}$), intent(inout) :: jpvt(*) real(${ck}$), intent(inout) :: vn1(*), vn2(*) complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: tau(*), work(*) @@ -45660,21 +45652,21 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars - integer(ilp) :: i, itemp, j, mn, offpi, pvt + integer(${ik}$) :: i, itemp, j, mn, offpi, pvt real(${ck}$) :: temp, temp2, tol3z complex(${ck}$) :: aii ! Intrinsic Functions intrinsic :: abs,conjg,max,min,sqrt ! Executable Statements mn = min( m-offset, n ) - tol3z = sqrt(stdlib_${c2ri(ci)}$lamch('EPSILON')) + tol3z = sqrt(stdlib${ii}$_${c2ri(ci)}$lamch('EPSILON')) ! compute factorization. loop_20: do i = 1, mn offpi = offset + i ! determine ith pivot column and swap if necessary. - pvt = ( i-1 ) + stdlib_i${c2ri(ci)}$amax( n-i+1, vn1( i ), 1 ) + pvt = ( i-1 ) + stdlib${ii}$_i${c2ri(ci)}$amax( n-i+1, vn1( i ), 1_${ik}$ ) if( pvt/=i ) then - call stdlib_${ci}$swap( m, a( 1, pvt ), 1, a( 1, i ), 1 ) + call stdlib${ii}$_${ci}$swap( m, a( 1_${ik}$, pvt ), 1_${ik}$, a( 1_${ik}$, i ), 1_${ik}$ ) itemp = jpvt( pvt ) jpvt( pvt ) = jpvt( i ) jpvt( i ) = itemp @@ -45683,17 +45675,17 @@ module stdlib_linalg_lapack_${ci}$ end if ! generate elementary reflector h(i). if( offpi1 ) then + if( k>1_${ik}$ ) then do j = 1, k - 1 f( k, j ) = conjg( f( k, j ) ) end do - call stdlib_${ci}$gemv( 'NO TRANSPOSE', m-rk+1, k-1, -cone, a( rk, 1 ),lda, f( k, 1 ),& - ldf, cone, a( rk, k ), 1 ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', m-rk+1, k-1, -cone, a( rk, 1_${ik}$ ),lda, f( k, 1_${ik}$ ),& + ldf, cone, a( rk, k ), 1_${ik}$ ) do j = 1, k - 1 f( k, j ) = conjg( f( k, j ) ) end do end if ! generate elementary reflector h(k). if( rk1 ) then - call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', m-rk+1, k-1, -tau( k ),a( rk, 1 ), lda,& - a( rk, k ), 1, czero,auxv( 1 ), 1 ) - call stdlib_${ci}$gemv( 'NO TRANSPOSE', n, k-1, cone, f( 1, 1 ), ldf,auxv( 1 ), 1, & - cone, f( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', m-rk+1, k-1, -tau( k ),a( rk, 1_${ik}$ ), lda,& + a( rk, k ), 1_${ik}$, czero,auxv( 1_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n, k-1, cone, f( 1_${ik}$, 1_${ik}$ ), ldf,auxv( 1_${ik}$ ), 1_${ik}$, & + cone, f( 1_${ik}$, k ), 1_${ik}$ ) end if ! update the current row of a: ! a(rk,k+1:n) := a(rk,k+1:n) - a(rk,1:k)*f(k+1:n,1:k)**h. if( k0 ) then - itemp = nint( vn2( lsticc ),KIND=ilp) - vn1( lsticc ) = stdlib_${c2ri(ci)}$znrm2( m-rk, a( rk+1, lsticc ), 1 ) + if( lsticc>0_${ik}$ ) then + itemp = nint( vn2( lsticc ),KIND=${ik}$) + vn1( lsticc ) = stdlib${ii}$_${c2ri(ci)}$znrm2( m-rk, a( rk+1, lsticc ), 1_${ik}$ ) ! note: the computation of vn1( lsticc ) relies on the fact that - ! stdlib_dnrm2 does not fail on vectors with norm below the value of - ! sqrt(stdlib_${c2ri(ci)}$lamch('s')) + ! stdlib${ii}$_dnrm2 does not fail on vectors with norm below the value of + ! sqrt(stdlib${ii}$_${c2ri(ci)}$lamch('s')) vn2( lsticc ) = vn1( lsticc ) lsticc = itemp go to 60 end if return - end subroutine stdlib_${ci}$laqps + end subroutine stdlib${ii}$_${ci}$laqps - pure subroutine stdlib_${ci}$laqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, work,& + pure subroutine stdlib${ii}$_${ci}$laqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, work,& !! ZLAQR0: computes the eigenvalues of a Hessenberg matrix H !! and, optionally, the matrices T and Z from the Schur decomposition !! H = Z T Z**H, where T is an upper triangular matrix (the @@ -45879,20 +45871,20 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, ihiz, ilo, iloz, ldh, ldz, lwork, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ihiz, ilo, iloz, ldh, ldz, lwork, n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt, wantz ! Array Arguments complex(${ck}$), intent(inout) :: h(ldh,*), z(ldz,*) complex(${ck}$), intent(out) :: w(*), work(*) ! ================================================================ ! Parameters - integer(ilp), parameter :: ntiny = 15 - integer(ilp), parameter :: kexnw = 5 - integer(ilp), parameter :: kexsh = 6 + integer(${ik}$), parameter :: ntiny = 15_${ik}$ + integer(${ik}$), parameter :: kexnw = 5_${ik}$ + integer(${ik}$), parameter :: kexsh = 6_${ik}$ real(${ck}$), parameter :: wilk1 = 0.75_${ck}$ ! ==== matrices of order ntiny or smaller must be processed by - ! . stdlib_${ci}$lahqr because of insufficient subdiagonal scratch space. + ! . stdlib${ii}$_${ci}$lahqr because of insufficient subdiagonal scratch space. ! . (this is a hard limit.) ==== ! ==== exceptional deflation windows: try to cure rare @@ -45911,13 +45903,13 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars complex(${ck}$) :: aa, bb, cc, cdum, dd, det, rtdisc, swap, tr2 real(${ck}$) :: s - integer(ilp) :: i, inf, it, itmax, k, kacc22, kbot, kdu, ks, kt, ktop, ku, kv, kwh, & + integer(${ik}$) :: i, inf, it, itmax, k, kacc22, kbot, kdu, ks, kt, ktop, ku, kv, kwh, & kwtop, kwv, ld, ls, lwkopt, ndec, ndfl, nh, nho, nibble, nmin, ns, nsmax, nsr, nve, nw,& nwmax, nwr, nwupbd logical(lk) :: sorted - character :: jbcmpz*2 + character(len=2) :: jbcmpz ! Local Arrays - complex(${ck}$) :: zdum(1,1) + complex(${ck}$) :: zdum(1_${ik}$,1_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,cmplx,aimag,int,max,min,mod,sqrt ! Statement Functions @@ -45925,82 +45917,82 @@ module stdlib_linalg_lapack_${ci}$ ! Statement Function Definitions cabs1( cdum ) = abs( real( cdum,KIND=${ck}$) ) + abs( aimag( cdum ) ) ! Executable Statements - info = 0 + info = 0_${ik}$ ! ==== quick return for n = 0: nothing to do. ==== - if( n==0 ) then - work( 1 ) = cone + if( n==0_${ik}$ ) then + work( 1_${ik}$ ) = cone return end if if( n<=ntiny ) then ! ==== tiny matrices must use stdlib_${ci}$lahqr. ==== - lwkopt = 1 - if( lwork/=-1 )call stdlib_${ci}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, & + lwkopt = 1_${ik}$ + if( lwork/=-1_${ik}$ )call stdlib${ii}$_${ci}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, & z, ldz, info ) else ! ==== use small bulge multi-shift qr with aggressive early ! . deflation on larger-than-tiny matrices. ==== ! ==== hope for the best. ==== - info = 0 - ! ==== set up job flags for stdlib_ilaenv. ==== + info = 0_${ik}$ + ! ==== set up job flags for stdlib${ii}$_ilaenv. ==== if( wantt ) then - jbcmpz( 1: 1 ) = 'S' + jbcmpz( 1_${ik}$: 1_${ik}$ ) = 'S' else - jbcmpz( 1: 1 ) = 'E' + jbcmpz( 1_${ik}$: 1_${ik}$ ) = 'E' end if if( wantz ) then - jbcmpz( 2: 2 ) = 'V' + jbcmpz( 2_${ik}$: 2_${ik}$ ) = 'V' else - jbcmpz( 2: 2 ) = 'N' + jbcmpz( 2_${ik}$: 2_${ik}$ ) = 'N' end if ! ==== nwr = recommended deflation window size. at this ! . point, n > ntiny = 15, so there is enough ! . subdiagonal workspace for nwr>=2 as required. ! . (in fact, there is enough subdiagonal space for ! . nwr>=4.) ==== - nwr = stdlib_ilaenv( 13, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) - nwr = max( 2, nwr ) - nwr = min( ihi-ilo+1, ( n-1 ) / 3, nwr ) + nwr = stdlib${ii}$_ilaenv( 13_${ik}$, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) + nwr = max( 2_${ik}$, nwr ) + nwr = min( ihi-ilo+1, ( n-1 ) / 3_${ik}$, nwr ) ! ==== nsr = recommended number of simultaneous shifts. ! . at this point n > ntiny = 15, so there is at ! . enough subdiagonal workspace for nsr to be even ! . and greater than or equal to two as required. ==== - nsr = stdlib_ilaenv( 15, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) - nsr = min( nsr, ( n-3 ) / 6, ihi-ilo ) - nsr = max( 2, nsr-mod( nsr, 2 ) ) + nsr = stdlib${ii}$_ilaenv( 15_${ik}$, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) + nsr = min( nsr, ( n-3 ) / 6_${ik}$, ihi-ilo ) + nsr = max( 2_${ik}$, nsr-mod( nsr, 2_${ik}$ ) ) ! ==== estimate optimal workspace ==== - ! ==== workspace query call to stdlib_${ci}$laqr3 ==== - call stdlib_${ci}$laqr3( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& - ld, w, h, ldh, n, h, ldh, n, h,ldh, work, -1 ) - ! ==== optimal workspace = max(stdlib_${ci}$laqr5, stdlib_${ci}$laqr3) ==== - lwkopt = max( 3*nsr / 2, int( work( 1 ),KIND=ilp) ) + ! ==== workspace query call to stdlib${ii}$_${ci}$laqr3 ==== + call stdlib${ii}$_${ci}$laqr3( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& + ld, w, h, ldh, n, h, ldh, n, h,ldh, work, -1_${ik}$ ) + ! ==== optimal workspace = max(stdlib${ii}$_${ci}$laqr5, stdlib${ii}$_${ci}$laqr3) ==== + lwkopt = max( 3_${ik}$*nsr / 2_${ik}$, int( work( 1_${ik}$ ),KIND=${ik}$) ) ! ==== quick return in case of workspace query. ==== - if( lwork==-1 ) then - work( 1 ) = cmplx( lwkopt, 0,KIND=${ck}$) + if( lwork==-1_${ik}$ ) then + work( 1_${ik}$ ) = cmplx( lwkopt, 0_${ik}$,KIND=${ck}$) return end if - ! ==== stdlib_${ci}$lahqr/stdlib_${ci}$laqr0 crossover point ==== - nmin = stdlib_ilaenv( 12, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) + ! ==== stdlib${ii}$_${ci}$lahqr/stdlib${ii}$_${ci}$laqr0 crossover point ==== + nmin = stdlib${ii}$_ilaenv( 12_${ik}$, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) nmin = max( ntiny, nmin ) ! ==== nibble crossover point ==== - nibble = stdlib_ilaenv( 14, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) - nibble = max( 0, nibble ) + nibble = stdlib${ii}$_ilaenv( 14_${ik}$, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) + nibble = max( 0_${ik}$, nibble ) ! ==== accumulate reflections during ttswp? use block ! . 2-by-2 structure during matrix-matrix multiply? ==== - kacc22 = stdlib_ilaenv( 16, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) - kacc22 = max( 0, kacc22 ) - kacc22 = min( 2, kacc22 ) + kacc22 = stdlib${ii}$_ilaenv( 16_${ik}$, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) + kacc22 = max( 0_${ik}$, kacc22 ) + kacc22 = min( 2_${ik}$, kacc22 ) ! ==== nwmax = the largest possible deflation window for ! . which there is sufficient workspace. ==== - nwmax = min( ( n-1 ) / 3, lwork / 2 ) + nwmax = min( ( n-1 ) / 3_${ik}$, lwork / 2_${ik}$ ) nw = nwmax ! ==== nsmax = the largest number of simultaneous shifts ! . for which there is sufficient workspace. ==== - nsmax = min( ( n-3 ) / 6, 2*lwork / 3 ) - nsmax = nsmax - mod( nsmax, 2 ) + nsmax = min( ( n-3 ) / 6_${ik}$, 2_${ik}$*lwork / 3_${ik}$ ) + nsmax = nsmax - mod( nsmax, 2_${ik}$ ) ! ==== ndfl: an iteration count restarted at deflation. ==== - ndfl = 1 + ndfl = 1_${ik}$ ! ==== itmax = iteration limit ==== - itmax = max( 30, 2*kexsh )*max( 10, ( ihi-ilo+1 ) ) + itmax = max( 30_${ik}$, 2_${ik}$*kexsh )*max( 10_${ik}$, ( ihi-ilo+1 ) ) ! ==== last row and column in the active block ==== kbot = ihi ! ==== main loop ==== @@ -46028,27 +46020,27 @@ module stdlib_linalg_lapack_${ci}$ ! . in general, more powerful than smaller ones, ! . rapidly increase the window to the maximum possible. ! . then, gradually reduce the window size. ==== - nh = kbot - ktop + 1 + nh = kbot - ktop + 1_${ik}$ nwupbd = min( nh, nwmax ) if( ndfl=nh-1 ) then nw = nh else - kwtop = kbot - nw + 1 + kwtop = kbot - nw + 1_${ik}$ if( cabs1( h( kwtop, kwtop-1 ) )>cabs1( h( kwtop-1, kwtop-2 ) ) )nw = nw + & - 1 + 1_${ik}$ end if end if if( ndfl=0 .or. nw>=nwupbd ) then - ndec = ndec + 1 - if( nw-ndec<2 )ndec = 0 + ndec = -1_${ik}$ + else if( ndec>=0_${ik}$ .or. nw>=nwupbd ) then + ndec = ndec + 1_${ik}$ + if( nw-ndec<2_${ik}$ )ndec = 0_${ik}$ nw = nw - ndec end if ! ==== aggressive early deflation: @@ -46061,60 +46053,60 @@ module stdlib_linalg_lapack_${ci}$ ! . - an at-least-nw-but-more-is-better (nhv-by-nw) ! . vertical work array along the left-hand-edge. ! . ==== - kv = n - nw + 1 - kt = nw + 1 - nho = ( n-nw-1 ) - kt + 1 - kwv = nw + 2 - nve = ( n-nw ) - kwv + 1 + kv = n - nw + 1_${ik}$ + kt = nw + 1_${ik}$ + nho = ( n-nw-1 ) - kt + 1_${ik}$ + kwv = nw + 2_${ik}$ + nve = ( n-nw ) - kwv + 1_${ik}$ ! ==== aggressive early deflation ==== - call stdlib_${ci}$laqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & - ls, ld, w, h( kv, 1 ), ldh, nho,h( kv, kt ), ldh, nve, h( kwv, 1 ), ldh, work,& + call stdlib${ii}$_${ci}$laqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & + ls, ld, w, h( kv, 1_${ik}$ ), ldh, nho,h( kv, kt ), ldh, nve, h( kwv, 1_${ik}$ ), ldh, work,& lwork ) ! ==== adjust kbot accounting for new deflations. ==== kbot = kbot - ld ! ==== ks points to the shifts. ==== - ks = kbot - ls + 1 + ks = kbot - ls + 1_${ik}$ ! ==== skip an expensive qr sweep if there is a (partly ! . heuristic) reason to expect that many eigenvalues ! . will deflate without it. here, the qr sweep is ! . skipped if many eigenvalues have just been deflated ! . or if the remaining active block is small. - if( ( ld==0 ) .or. ( ( 100*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& + if( ( ld==0_${ik}$ ) .or. ( ( 100_${ik}$*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& ) ) ) then ! ==== ns = nominal number of simultaneous shifts. - ! . this may be lowered (slightly) if stdlib_${ci}$laqr3 + ! . this may be lowered (slightly) if stdlib${ii}$_${ci}$laqr3 ! . did not provide that many shifts. ==== - ns = min( nsmax, nsr, max( 2, kbot-ktop ) ) - ns = ns - mod( ns, 2 ) + ns = min( nsmax, nsr, max( 2_${ik}$, kbot-ktop ) ) + ns = ns - mod( ns, 2_${ik}$ ) ! ==== if there have been no deflations ! . in a multiple of kexsh iterations, ! . then try exceptional shifts. ! . otherwise use shifts provided by - ! . stdlib_${ci}$laqr3 above or from the eigenvalues + ! . stdlib${ii}$_${ci}$laqr3 above or from the eigenvalues ! . of a trailing principal submatrix. ==== - if( mod( ndfl, kexsh )==0 ) then - ks = kbot - ns + 1 + if( mod( ndfl, kexsh )==0_${ik}$ ) then + ks = kbot - ns + 1_${ik}$ do i = kbot, ks + 1, -2 w( i ) = h( i, i ) + wilk1*cabs1( h( i, i-1 ) ) w( i-1 ) = w( i ) end do else ! ==== got ns/2 or fewer shifts? use stdlib_${ci}$laqr4 or - ! . stdlib_${ci}$lahqr on a trailing principal submatrix to + ! . stdlib${ii}$_${ci}$lahqr on a trailing principal submatrix to ! . get more. (since ns<=nsmax<=(n-3)/6, ! . there is enough space below the subdiagonal ! . to fit an ns-by-ns scratch array.) ==== - if( kbot-ks+1<=ns / 2 ) then - ks = kbot - ns + 1 - kt = n - ns + 1 - call stdlib_${ci}$lacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1 ), ldh ) + if( kbot-ks+1<=ns / 2_${ik}$ ) then + ks = kbot - ns + 1_${ik}$ + kt = n - ns + 1_${ik}$ + call stdlib${ii}$_${ci}$lacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1_${ik}$ ), ldh ) if( ns>nmin ) then - call stdlib_${ci}$laqr4( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, w( & - ks ), 1, 1,zdum, 1, work, lwork, inf ) + call stdlib${ii}$_${ci}$laqr4( .false., .false., ns, 1_${ik}$, ns,h( kt, 1_${ik}$ ), ldh, w( & + ks ), 1_${ik}$, 1_${ik}$,zdum, 1_${ik}$, work, lwork, inf ) else - call stdlib_${ci}$lahqr( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, w( & - ks ), 1, 1,zdum, 1, inf ) + call stdlib${ii}$_${ci}$lahqr( .false., .false., ns, 1_${ik}$, ns,h( kt, 1_${ik}$ ), ldh, w( & + ks ), 1_${ik}$, 1_${ik}$,zdum, 1_${ik}$, inf ) end if ks = ks + inf ! ==== in case of a rare qr failure use @@ -46135,7 +46127,7 @@ module stdlib_linalg_lapack_${ci}$ rtdisc = sqrt( -det ) w( kbot-1 ) = ( tr2+rtdisc )*s w( kbot ) = ( tr2-rtdisc )*s - ks = kbot - 1 + ks = kbot - 1_${ik}$ end if end if if( kbot-ks+1>ns ) then @@ -46158,7 +46150,7 @@ module stdlib_linalg_lapack_${ci}$ end if ! ==== if there are only two shifts, then use ! . only cone. ==== - if( kbot-ks+1==2 ) then + if( kbot-ks+1==2_${ik}$ ) then if( cabs1( w( kbot )-h( kbot, kbot ) )0 ) then - ndfl = 1 + if( ld>0_${ik}$ ) then + ndfl = 1_${ik}$ else - ndfl = ndfl + 1 + ndfl = ndfl + 1_${ik}$ end if ! ==== end of main loop ==== end do loop_70 @@ -46208,11 +46200,11 @@ module stdlib_linalg_lapack_${ci}$ 80 continue end if ! ==== return the optimal value of lwork. ==== - work( 1 ) = cmplx( lwkopt, 0,KIND=${ck}$) - end subroutine stdlib_${ci}$laqr0 + work( 1_${ik}$ ) = cmplx( lwkopt, 0_${ik}$,KIND=${ck}$) + end subroutine stdlib${ii}$_${ci}$laqr0 - pure subroutine stdlib_${ci}$laqr1( n, h, ldh, s1, s2, v ) + pure subroutine stdlib${ii}$_${ci}$laqr1( n, h, ldh, s1, s2, v ) !! Given a 2-by-2 or 3-by-3 matrix H, ZLAQR1: sets v to a !! scalar multiple of the first column of the product !! (*) K = (H - s1*I)*(H - s2*I) @@ -46224,7 +46216,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(${ck}$), intent(in) :: s1, s2 - integer(ilp), intent(in) :: ldh, n + integer(${ik}$), intent(in) :: ldh, n ! Array Arguments complex(${ck}$), intent(in) :: h(ldh,*) complex(${ck}$), intent(out) :: v(*) @@ -46244,38 +46236,38 @@ module stdlib_linalg_lapack_${ci}$ cabs1( cdum ) = abs( real( cdum,KIND=${ck}$) ) + abs( aimag( cdum ) ) ! 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 = cabs1( h( 1, 1 )-s2 ) + cabs1( h( 2, 1 ) ) + if( n==2_${ik}$ ) then + s = cabs1( h( 1_${ik}$, 1_${ik}$ )-s2 ) + cabs1( h( 2_${ik}$, 1_${ik}$ ) ) if( s==rzero ) then - v( 1 ) = czero - v( 2 ) = czero + v( 1_${ik}$ ) = czero + v( 2_${ik}$ ) = czero else - h21s = h( 2, 1 ) / s - v( 1 ) = h21s*h( 1, 2 ) + ( h( 1, 1 )-s1 )*( ( h( 1, 1 )-s2 ) / s ) - v( 2 ) = h21s*( h( 1, 1 )+h( 2, 2 )-s1-s2 ) + h21s = h( 2_${ik}$, 1_${ik}$ ) / s + v( 1_${ik}$ ) = h21s*h( 1_${ik}$, 2_${ik}$ ) + ( h( 1_${ik}$, 1_${ik}$ )-s1 )*( ( h( 1_${ik}$, 1_${ik}$ )-s2 ) / s ) + v( 2_${ik}$ ) = h21s*( h( 1_${ik}$, 1_${ik}$ )+h( 2_${ik}$, 2_${ik}$ )-s1-s2 ) end if else - s = cabs1( h( 1, 1 )-s2 ) + cabs1( h( 2, 1 ) ) +cabs1( h( 3, 1 ) ) + s = cabs1( h( 1_${ik}$, 1_${ik}$ )-s2 ) + cabs1( h( 2_${ik}$, 1_${ik}$ ) ) +cabs1( h( 3_${ik}$, 1_${ik}$ ) ) if( s==czero ) then - v( 1 ) = czero - v( 2 ) = czero - v( 3 ) = czero + v( 1_${ik}$ ) = czero + v( 2_${ik}$ ) = czero + v( 3_${ik}$ ) = czero else - h21s = h( 2, 1 ) / s - h31s = h( 3, 1 ) / s - v( 1 ) = ( h( 1, 1 )-s1 )*( ( h( 1, 1 )-s2 ) / s ) +h( 1, 2 )*h21s + h( 1, 3 )& + h21s = h( 2_${ik}$, 1_${ik}$ ) / s + h31s = h( 3_${ik}$, 1_${ik}$ ) / s + v( 1_${ik}$ ) = ( h( 1_${ik}$, 1_${ik}$ )-s1 )*( ( h( 1_${ik}$, 1_${ik}$ )-s2 ) / s ) +h( 1_${ik}$, 2_${ik}$ )*h21s + h( 1_${ik}$, 3_${ik}$ )& *h31s - v( 2 ) = h21s*( h( 1, 1 )+h( 2, 2 )-s1-s2 ) + h( 2, 3 )*h31s - v( 3 ) = h31s*( h( 1, 1 )+h( 3, 3 )-s1-s2 ) + h21s*h( 3, 2 ) + v( 2_${ik}$ ) = h21s*( h( 1_${ik}$, 1_${ik}$ )+h( 2_${ik}$, 2_${ik}$ )-s1-s2 ) + h( 2_${ik}$, 3_${ik}$ )*h31s + v( 3_${ik}$ ) = h31s*( h( 1_${ik}$, 1_${ik}$ )+h( 3_${ik}$, 3_${ik}$ )-s1-s2 ) + h21s*h( 3_${ik}$, 2_${ik}$ ) end if end if - end subroutine stdlib_${ci}$laqr1 + end subroutine stdlib${ii}$_${ci}$laqr1 - pure subroutine stdlib_${ci}$laqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & + pure subroutine stdlib${ii}$_${ci}$laqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & !! ZLAQR2: is identical to ZLAQR3 except that it avoids !! recursion by calling ZLAHQR instead of ZLAQR4. !! Aggressive early deflation: @@ -46292,9 +46284,9 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: ihiz, iloz, kbot, ktop, ldh, ldt, ldv, ldwv, ldz, lwork, n,& + integer(${ik}$), intent(in) :: ihiz, iloz, kbot, ktop, ldh, ldt, ldv, ldwv, ldz, lwork, n,& nh, nv, nw - integer(ilp), intent(out) :: nd, ns + integer(${ik}$), intent(out) :: nd, ns logical(lk), intent(in) :: wantt, wantz ! Array Arguments complex(${ck}$), intent(inout) :: h(ldh,*), z(ldz,*) @@ -46308,7 +46300,7 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars complex(${ck}$) :: beta, cdum, s, tau real(${ck}$) :: foo, safmax, safmin, smlnum, ulp - integer(ilp) :: i, ifst, ilst, info, infqr, j, jw, kcol, kln, knt, krow, kwtop, ltop, & + integer(${ik}$) :: i, ifst, ilst, info, infqr, j, jw, kcol, kln, knt, krow, kwtop, ltop, & lwk1, lwk2, lwkopt ! Intrinsic Functions intrinsic :: abs,real,cmplx,conjg,aimag,int,max,min @@ -46319,41 +46311,41 @@ module stdlib_linalg_lapack_${ci}$ ! Executable Statements ! ==== estimate optimal workspace. ==== jw = min( nw, kbot-ktop+1 ) - if( jw<=2 ) then - lwkopt = 1 + if( jw<=2_${ik}$ ) then + lwkopt = 1_${ik}$ else - ! ==== workspace query call to stdlib_${ci}$gehrd ==== - call stdlib_${ci}$gehrd( jw, 1, jw-1, t, ldt, work, work, -1, info ) - lwk1 = int( work( 1 ),KIND=ilp) - ! ==== workspace query call to stdlib_${ci}$unmhr ==== - call stdlib_${ci}$unmhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv,work, -1, info ) + ! ==== workspace query call to stdlib${ii}$_${ci}$gehrd ==== + call stdlib${ii}$_${ci}$gehrd( jw, 1_${ik}$, jw-1, t, ldt, work, work, -1_${ik}$, info ) + lwk1 = int( work( 1_${ik}$ ),KIND=${ik}$) + ! ==== workspace query call to stdlib${ii}$_${ci}$unmhr ==== + call stdlib${ii}$_${ci}$unmhr( 'R', 'N', jw, jw, 1_${ik}$, jw-1, t, ldt, work, v, ldv,work, -1_${ik}$, info ) - lwk2 = int( work( 1 ),KIND=ilp) + lwk2 = int( work( 1_${ik}$ ),KIND=${ik}$) ! ==== optimal workspace ==== lwkopt = jw + max( lwk1, lwk2 ) end if ! ==== quick return in case of workspace query. ==== - if( lwork==-1 ) then - work( 1 ) = cmplx( lwkopt, 0,KIND=${ck}$) + if( lwork==-1_${ik}$ ) then + work( 1_${ik}$ ) = cmplx( lwkopt, 0_${ik}$,KIND=${ck}$) return end if ! ==== nothing to do ... ! ... for an empty active block ... ==== - ns = 0 - nd = 0 - work( 1 ) = cone + ns = 0_${ik}$ + nd = 0_${ik}$ + work( 1_${ik}$ ) = cone if( ktop>kbot )return ! ... nor for an empty deflation window. ==== if( nw<1 )return ! ==== machine constants ==== - safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safmax = rone / safmin - call stdlib_${c2ri(ci)}$labad( safmin, safmax ) - ulp = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + call stdlib${ii}$_${c2ri(ci)}$labad( safmin, safmax ) + ulp = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=${ck}$) / ulp ) ! ==== setup deflation window ==== jw = min( nw, kbot-ktop+1 ) - kwtop = kbot - jw + 1 + kwtop = kbot - jw + 1_${ik}$ if( kwtop==ktop ) then s = czero else @@ -46362,14 +46354,14 @@ module stdlib_linalg_lapack_${ci}$ if( kbot==kwtop ) then ! ==== 1-by-1 deflation window: not much to do ==== sh( kwtop ) = h( kwtop, kwtop ) - ns = 1 - nd = 0 + ns = 1_${ik}$ + nd = 0_${ik}$ if( cabs1( s )<=max( smlnum, ulp*cabs1( h( kwtop,kwtop ) ) ) ) then - ns = 0 - nd = 1 + ns = 0_${ik}$ + nd = 1_${ik}$ if( kwtop>ktop )h( kwtop, kwtop-1 ) = czero end if - work( 1 ) = cone + work( 1_${ik}$ ) = cone return end if ! ==== convert to spike-triangular form. (in case of a @@ -46377,31 +46369,31 @@ module stdlib_linalg_lapack_${ci}$ ! . aggressive early deflation using that part of ! . the deflation window that converged using infqr ! . here and there to keep track.) ==== - call stdlib_${ci}$lacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) - call stdlib_${ci}$copy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 ) - call stdlib_${ci}$laset( 'A', jw, jw, czero, cone, v, ldv ) - call stdlib_${ci}$lahqr( .true., .true., jw, 1, jw, t, ldt, sh( kwtop ), 1,jw, v, ldv, & + call stdlib${ii}$_${ci}$lacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) + call stdlib${ii}$_${ci}$copy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2_${ik}$, 1_${ik}$ ), ldt+1 ) + call stdlib${ii}$_${ci}$laset( 'A', jw, jw, czero, cone, v, ldv ) + call stdlib${ii}$_${ci}$lahqr( .true., .true., jw, 1_${ik}$, jw, t, ldt, sh( kwtop ), 1_${ik}$,jw, v, ldv, & infqr ) ! ==== deflation detection loop ==== ns = jw - ilst = infqr + 1 + ilst = infqr + 1_${ik}$ do knt = infqr + 1, jw ! ==== small spike tip deflation test ==== foo = cabs1( t( ns, ns ) ) if( foo==rzero )foo = cabs1( s ) - if( cabs1( s )*cabs1( v( 1, ns ) )<=max( smlnum, ulp*foo ) )then + if( cabs1( s )*cabs1( v( 1_${ik}$, ns ) )<=max( smlnum, ulp*foo ) )then ! ==== cone more converged eigenvalue ==== - ns = ns - 1 + ns = ns - 1_${ik}$ else ! ==== cone undeflatable eigenvalue. move it up out of the - ! . way. (stdlib_${ci}$trexc can not fail in this case.) ==== + ! . way. (stdlib${ii}$_${ci}$trexc can not fail in this case.) ==== ifst = ns - call stdlib_${ci}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) - ilst = ilst + 1 + call stdlib${ii}$_${ci}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) + ilst = ilst + 1_${ik}$ end if end do ! ==== return to hessenberg form ==== - if( ns==0 )s = czero + if( ns==0_${ik}$ )s = czero if( nscabs1( t( ifst, ifst ) ) )ifst = j end do ilst = i - if( ifst/=ilst )call stdlib_${ci}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) + if( ifst/=ilst )call stdlib${ii}$_${ci}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) end do end if @@ -46420,59 +46412,59 @@ module stdlib_linalg_lapack_${ci}$ sh( kwtop+i-1 ) = t( i, i ) end do if( ns1 .and. s/=czero ) then + if( ns>1_${ik}$ .and. s/=czero ) then ! ==== reflect spike back into lower triangle ==== - call stdlib_${ci}$copy( ns, v, ldv, work, 1 ) + call stdlib${ii}$_${ci}$copy( ns, v, ldv, work, 1_${ik}$ ) do i = 1, ns work( i ) = conjg( work( i ) ) end do - beta = work( 1 ) - call stdlib_${ci}$larfg( ns, beta, work( 2 ), 1, tau ) - work( 1 ) = cone - call stdlib_${ci}$laset( 'L', jw-2, jw-2, czero, czero, t( 3, 1 ), ldt ) - call stdlib_${ci}$larf( 'L', ns, jw, work, 1, conjg( tau ), t, ldt,work( jw+1 ) ) + beta = work( 1_${ik}$ ) + call stdlib${ii}$_${ci}$larfg( ns, beta, work( 2_${ik}$ ), 1_${ik}$, tau ) + work( 1_${ik}$ ) = cone + call stdlib${ii}$_${ci}$laset( 'L', jw-2, jw-2, czero, czero, t( 3_${ik}$, 1_${ik}$ ), ldt ) + call stdlib${ii}$_${ci}$larf( 'L', ns, jw, work, 1_${ik}$, conjg( tau ), t, ldt,work( jw+1 ) ) - call stdlib_${ci}$larf( 'R', ns, ns, work, 1, tau, t, ldt,work( jw+1 ) ) - call stdlib_${ci}$larf( 'R', jw, ns, work, 1, tau, v, ldv,work( jw+1 ) ) - call stdlib_${ci}$gehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) + call stdlib${ii}$_${ci}$larf( 'R', ns, ns, work, 1_${ik}$, tau, t, ldt,work( jw+1 ) ) + call stdlib${ii}$_${ci}$larf( 'R', jw, ns, work, 1_${ik}$, tau, v, ldv,work( jw+1 ) ) + call stdlib${ii}$_${ci}$gehrd( jw, 1_${ik}$, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) end if ! ==== copy updated reduced window into place ==== - if( kwtop>1 )h( kwtop, kwtop-1 ) = s*conjg( v( 1, 1 ) ) - call stdlib_${ci}$lacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) - call stdlib_${ci}$copy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) + if( kwtop>1_${ik}$ )h( kwtop, kwtop-1 ) = s*conjg( v( 1_${ik}$, 1_${ik}$ ) ) + call stdlib${ii}$_${ci}$lacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) + call stdlib${ii}$_${ci}$copy( jw-1, t( 2_${ik}$, 1_${ik}$ ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) ! ==== accumulate orthogonal matrix in order update ! . h and z, if requested. ==== - if( ns>1 .and. s/=czero )call stdlib_${ci}$unmhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, & + if( ns>1_${ik}$ .and. s/=czero )call stdlib${ii}$_${ci}$unmhr( 'R', 'N', jw, ns, 1_${ik}$, ns, t, ldt, work, & v, ldv,work( jw+1 ), lwork-jw, info ) ! ==== update vertical slab in h ==== if( wantt ) then - ltop = 1 + ltop = 1_${ik}$ else ltop = ktop end if do krow = ltop, kwtop - 1, nv kln = min( nv, kwtop-krow ) - call stdlib_${ci}$gemm( 'N', 'N', kln, jw, jw, cone, h( krow, kwtop ),ldh, v, ldv, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', kln, jw, jw, cone, h( krow, kwtop ),ldh, v, ldv, & czero, wv, ldwv ) - call stdlib_${ci}$lacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) + call stdlib${ii}$_${ci}$lacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) end do ! ==== update horizontal slab in h ==== if( wantt ) then do kcol = kbot + 1, n, nh kln = min( nh, n-kcol+1 ) - call stdlib_${ci}$gemm( 'C', 'N', jw, kln, jw, cone, v, ldv,h( kwtop, kcol ), ldh, & + call stdlib${ii}$_${ci}$gemm( 'C', 'N', jw, kln, jw, cone, v, ldv,h( kwtop, kcol ), ldh, & czero, t, ldt ) - call stdlib_${ci}$lacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) + call stdlib${ii}$_${ci}$lacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) end do end if ! ==== update vertical slab in z ==== if( wantz ) then do krow = iloz, ihiz, nv kln = min( nv, ihiz-krow+1 ) - call stdlib_${ci}$gemm( 'N', 'N', kln, jw, jw, cone, z( krow, kwtop ),ldz, v, ldv, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', kln, jw, jw, cone, z( krow, kwtop ),ldz, v, ldv, & czero, wv, ldwv ) - call stdlib_${ci}$lacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) + call stdlib${ii}$_${ci}$lacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) end do end if end if @@ -46485,11 +46477,11 @@ module stdlib_linalg_lapack_${ci}$ ! . window.) ==== ns = ns - infqr ! ==== return optimal workspace. ==== - work( 1 ) = cmplx( lwkopt, 0,KIND=${ck}$) - end subroutine stdlib_${ci}$laqr2 + work( 1_${ik}$ ) = cmplx( lwkopt, 0_${ik}$,KIND=${ck}$) + end subroutine stdlib${ii}$_${ci}$laqr2 - pure subroutine stdlib_${ci}$laqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & + pure subroutine stdlib${ii}$_${ci}$laqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & !! Aggressive early deflation: !! ZLAQR3: accepts as input an upper Hessenberg matrix !! H and performs an unitary similarity transformation @@ -46504,9 +46496,9 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: ihiz, iloz, kbot, ktop, ldh, ldt, ldv, ldwv, ldz, lwork, n,& + integer(${ik}$), intent(in) :: ihiz, iloz, kbot, ktop, ldh, ldt, ldv, ldwv, ldz, lwork, n,& nh, nv, nw - integer(ilp), intent(out) :: nd, ns + integer(${ik}$), intent(out) :: nd, ns logical(lk), intent(in) :: wantt, wantz ! Array Arguments complex(${ck}$), intent(inout) :: h(ldh,*), z(ldz,*) @@ -46520,7 +46512,7 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars complex(${ck}$) :: beta, cdum, s, tau real(${ck}$) :: foo, safmax, safmin, smlnum, ulp - integer(ilp) :: i, ifst, ilst, info, infqr, j, jw, kcol, kln, knt, krow, kwtop, ltop, & + integer(${ik}$) :: i, ifst, ilst, info, infqr, j, jw, kcol, kln, knt, krow, kwtop, ltop, & lwk1, lwk2, lwk3, lwkopt, nmin ! Intrinsic Functions intrinsic :: abs,real,cmplx,conjg,aimag,int,max,min @@ -46531,45 +46523,45 @@ module stdlib_linalg_lapack_${ci}$ ! Executable Statements ! ==== estimate optimal workspace. ==== jw = min( nw, kbot-ktop+1 ) - if( jw<=2 ) then - lwkopt = 1 + if( jw<=2_${ik}$ ) then + lwkopt = 1_${ik}$ else - ! ==== workspace query call to stdlib_${ci}$gehrd ==== - call stdlib_${ci}$gehrd( jw, 1, jw-1, t, ldt, work, work, -1, info ) - lwk1 = int( work( 1 ),KIND=ilp) - ! ==== workspace query call to stdlib_${ci}$unmhr ==== - call stdlib_${ci}$unmhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv,work, -1, info ) + ! ==== workspace query call to stdlib${ii}$_${ci}$gehrd ==== + call stdlib${ii}$_${ci}$gehrd( jw, 1_${ik}$, jw-1, t, ldt, work, work, -1_${ik}$, info ) + lwk1 = int( work( 1_${ik}$ ),KIND=${ik}$) + ! ==== workspace query call to stdlib${ii}$_${ci}$unmhr ==== + call stdlib${ii}$_${ci}$unmhr( 'R', 'N', jw, jw, 1_${ik}$, jw-1, t, ldt, work, v, ldv,work, -1_${ik}$, info ) - lwk2 = int( work( 1 ),KIND=ilp) - ! ==== workspace query call to stdlib_${ci}$laqr4 ==== - call stdlib_${ci}$laqr4( .true., .true., jw, 1, jw, t, ldt, sh, 1, jw, v,ldv, work, -1, & + lwk2 = int( work( 1_${ik}$ ),KIND=${ik}$) + ! ==== workspace query call to stdlib${ii}$_${ci}$laqr4 ==== + call stdlib${ii}$_${ci}$laqr4( .true., .true., jw, 1_${ik}$, jw, t, ldt, sh, 1_${ik}$, jw, v,ldv, work, -1_${ik}$, & infqr ) - lwk3 = int( work( 1 ),KIND=ilp) + lwk3 = int( work( 1_${ik}$ ),KIND=${ik}$) ! ==== optimal workspace ==== lwkopt = max( jw+max( lwk1, lwk2 ), lwk3 ) end if ! ==== quick return in case of workspace query. ==== - if( lwork==-1 ) then - work( 1 ) = cmplx( lwkopt, 0,KIND=${ck}$) + if( lwork==-1_${ik}$ ) then + work( 1_${ik}$ ) = cmplx( lwkopt, 0_${ik}$,KIND=${ck}$) return end if ! ==== nothing to do ... ! ... for an empty active block ... ==== - ns = 0 - nd = 0 - work( 1 ) = cone + ns = 0_${ik}$ + nd = 0_${ik}$ + work( 1_${ik}$ ) = cone if( ktop>kbot )return ! ... nor for an empty deflation window. ==== if( nw<1 )return ! ==== machine constants ==== - safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safmax = rone / safmin - call stdlib_${c2ri(ci)}$labad( safmin, safmax ) - ulp = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + call stdlib${ii}$_${c2ri(ci)}$labad( safmin, safmax ) + ulp = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=${ck}$) / ulp ) ! ==== setup deflation window ==== jw = min( nw, kbot-ktop+1 ) - kwtop = kbot - jw + 1 + kwtop = kbot - jw + 1_${ik}$ if( kwtop==ktop ) then s = czero else @@ -46578,14 +46570,14 @@ module stdlib_linalg_lapack_${ci}$ if( kbot==kwtop ) then ! ==== 1-by-1 deflation window: not much to do ==== sh( kwtop ) = h( kwtop, kwtop ) - ns = 1 - nd = 0 + ns = 1_${ik}$ + nd = 0_${ik}$ if( cabs1( s )<=max( smlnum, ulp*cabs1( h( kwtop,kwtop ) ) ) ) then - ns = 0 - nd = 1 + ns = 0_${ik}$ + nd = 1_${ik}$ if( kwtop>ktop )h( kwtop, kwtop-1 ) = czero end if - work( 1 ) = cone + work( 1_${ik}$ ) = cone return end if ! ==== convert to spike-triangular form. (in case of a @@ -46593,37 +46585,37 @@ module stdlib_linalg_lapack_${ci}$ ! . aggressive early deflation using that part of ! . the deflation window that converged using infqr ! . here and there to keep track.) ==== - call stdlib_${ci}$lacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) - call stdlib_${ci}$copy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 ) - call stdlib_${ci}$laset( 'A', jw, jw, czero, cone, v, ldv ) - nmin = stdlib_ilaenv( 12, 'ZLAQR3', 'SV', jw, 1, jw, lwork ) + call stdlib${ii}$_${ci}$lacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) + call stdlib${ii}$_${ci}$copy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2_${ik}$, 1_${ik}$ ), ldt+1 ) + call stdlib${ii}$_${ci}$laset( 'A', jw, jw, czero, cone, v, ldv ) + nmin = stdlib${ii}$_ilaenv( 12_${ik}$, 'ZLAQR3', 'SV', jw, 1_${ik}$, jw, lwork ) if( jw>nmin ) then - call stdlib_${ci}$laqr4( .true., .true., jw, 1, jw, t, ldt, sh( kwtop ), 1,jw, v, ldv, & + call stdlib${ii}$_${ci}$laqr4( .true., .true., jw, 1_${ik}$, jw, t, ldt, sh( kwtop ), 1_${ik}$,jw, v, ldv, & work, lwork, infqr ) else - call stdlib_${ci}$lahqr( .true., .true., jw, 1, jw, t, ldt, sh( kwtop ), 1,jw, v, ldv, & + call stdlib${ii}$_${ci}$lahqr( .true., .true., jw, 1_${ik}$, jw, t, ldt, sh( kwtop ), 1_${ik}$,jw, v, ldv, & infqr ) end if ! ==== deflation detection loop ==== ns = jw - ilst = infqr + 1 + ilst = infqr + 1_${ik}$ do knt = infqr + 1, jw ! ==== small spike tip deflation test ==== foo = cabs1( t( ns, ns ) ) if( foo==rzero )foo = cabs1( s ) - if( cabs1( s )*cabs1( v( 1, ns ) )<=max( smlnum, ulp*foo ) )then + if( cabs1( s )*cabs1( v( 1_${ik}$, ns ) )<=max( smlnum, ulp*foo ) )then ! ==== cone more converged eigenvalue ==== - ns = ns - 1 + ns = ns - 1_${ik}$ else ! ==== cone undeflatable eigenvalue. move it up out of the - ! . way. (stdlib_${ci}$trexc can not fail in this case.) ==== + ! . way. (stdlib${ii}$_${ci}$trexc can not fail in this case.) ==== ifst = ns - call stdlib_${ci}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) - ilst = ilst + 1 + call stdlib${ii}$_${ci}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) + ilst = ilst + 1_${ik}$ end if end do ! ==== return to hessenberg form ==== - if( ns==0 )s = czero + if( ns==0_${ik}$ )s = czero if( nscabs1( t( ifst, ifst ) ) )ifst = j end do ilst = i - if( ifst/=ilst )call stdlib_${ci}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) + if( ifst/=ilst )call stdlib${ii}$_${ci}$trexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) end do end if @@ -46642,59 +46634,59 @@ module stdlib_linalg_lapack_${ci}$ sh( kwtop+i-1 ) = t( i, i ) end do if( ns1 .and. s/=czero ) then + if( ns>1_${ik}$ .and. s/=czero ) then ! ==== reflect spike back into lower triangle ==== - call stdlib_${ci}$copy( ns, v, ldv, work, 1 ) + call stdlib${ii}$_${ci}$copy( ns, v, ldv, work, 1_${ik}$ ) do i = 1, ns work( i ) = conjg( work( i ) ) end do - beta = work( 1 ) - call stdlib_${ci}$larfg( ns, beta, work( 2 ), 1, tau ) - work( 1 ) = cone - call stdlib_${ci}$laset( 'L', jw-2, jw-2, czero, czero, t( 3, 1 ), ldt ) - call stdlib_${ci}$larf( 'L', ns, jw, work, 1, conjg( tau ), t, ldt,work( jw+1 ) ) + beta = work( 1_${ik}$ ) + call stdlib${ii}$_${ci}$larfg( ns, beta, work( 2_${ik}$ ), 1_${ik}$, tau ) + work( 1_${ik}$ ) = cone + call stdlib${ii}$_${ci}$laset( 'L', jw-2, jw-2, czero, czero, t( 3_${ik}$, 1_${ik}$ ), ldt ) + call stdlib${ii}$_${ci}$larf( 'L', ns, jw, work, 1_${ik}$, conjg( tau ), t, ldt,work( jw+1 ) ) - call stdlib_${ci}$larf( 'R', ns, ns, work, 1, tau, t, ldt,work( jw+1 ) ) - call stdlib_${ci}$larf( 'R', jw, ns, work, 1, tau, v, ldv,work( jw+1 ) ) - call stdlib_${ci}$gehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) + call stdlib${ii}$_${ci}$larf( 'R', ns, ns, work, 1_${ik}$, tau, t, ldt,work( jw+1 ) ) + call stdlib${ii}$_${ci}$larf( 'R', jw, ns, work, 1_${ik}$, tau, v, ldv,work( jw+1 ) ) + call stdlib${ii}$_${ci}$gehrd( jw, 1_${ik}$, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) end if ! ==== copy updated reduced window into place ==== - if( kwtop>1 )h( kwtop, kwtop-1 ) = s*conjg( v( 1, 1 ) ) - call stdlib_${ci}$lacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) - call stdlib_${ci}$copy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) + if( kwtop>1_${ik}$ )h( kwtop, kwtop-1 ) = s*conjg( v( 1_${ik}$, 1_${ik}$ ) ) + call stdlib${ii}$_${ci}$lacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) + call stdlib${ii}$_${ci}$copy( jw-1, t( 2_${ik}$, 1_${ik}$ ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) ! ==== accumulate orthogonal matrix in order update ! . h and z, if requested. ==== - if( ns>1 .and. s/=czero )call stdlib_${ci}$unmhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, & + if( ns>1_${ik}$ .and. s/=czero )call stdlib${ii}$_${ci}$unmhr( 'R', 'N', jw, ns, 1_${ik}$, ns, t, ldt, work, & v, ldv,work( jw+1 ), lwork-jw, info ) ! ==== update vertical slab in h ==== if( wantt ) then - ltop = 1 + ltop = 1_${ik}$ else ltop = ktop end if do krow = ltop, kwtop - 1, nv kln = min( nv, kwtop-krow ) - call stdlib_${ci}$gemm( 'N', 'N', kln, jw, jw, cone, h( krow, kwtop ),ldh, v, ldv, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', kln, jw, jw, cone, h( krow, kwtop ),ldh, v, ldv, & czero, wv, ldwv ) - call stdlib_${ci}$lacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) + call stdlib${ii}$_${ci}$lacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) end do ! ==== update horizontal slab in h ==== if( wantt ) then do kcol = kbot + 1, n, nh kln = min( nh, n-kcol+1 ) - call stdlib_${ci}$gemm( 'C', 'N', jw, kln, jw, cone, v, ldv,h( kwtop, kcol ), ldh, & + call stdlib${ii}$_${ci}$gemm( 'C', 'N', jw, kln, jw, cone, v, ldv,h( kwtop, kcol ), ldh, & czero, t, ldt ) - call stdlib_${ci}$lacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) + call stdlib${ii}$_${ci}$lacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) end do end if ! ==== update vertical slab in z ==== if( wantz ) then do krow = iloz, ihiz, nv kln = min( nv, ihiz-krow+1 ) - call stdlib_${ci}$gemm( 'N', 'N', kln, jw, jw, cone, z( krow, kwtop ),ldz, v, ldv, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', kln, jw, jw, cone, z( krow, kwtop ),ldz, v, ldv, & czero, wv, ldwv ) - call stdlib_${ci}$lacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) + call stdlib${ii}$_${ci}$lacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) end do end if end if @@ -46707,11 +46699,11 @@ module stdlib_linalg_lapack_${ci}$ ! . window.) ==== ns = ns - infqr ! ==== return optimal workspace. ==== - work( 1 ) = cmplx( lwkopt, 0,KIND=${ck}$) - end subroutine stdlib_${ci}$laqr3 + work( 1_${ik}$ ) = cmplx( lwkopt, 0_${ik}$,KIND=${ck}$) + end subroutine stdlib${ii}$_${ci}$laqr3 - pure subroutine stdlib_${ci}$laqr4( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, work,& + pure subroutine stdlib${ii}$_${ci}$laqr4( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, work,& !! ZLAQR4: implements one level of recursion for ZLAQR0. !! It is a complete implementation of the small bulge multi-shift !! QR algorithm. It may be called by ZLAQR0 and, for large enough @@ -46731,20 +46723,20 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, ihiz, ilo, iloz, ldh, ldz, lwork, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ihiz, ilo, iloz, ldh, ldz, lwork, n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt, wantz ! Array Arguments complex(${ck}$), intent(inout) :: h(ldh,*), z(ldz,*) complex(${ck}$), intent(out) :: w(*), work(*) ! ================================================================ ! Parameters - integer(ilp), parameter :: ntiny = 15 - integer(ilp), parameter :: kexnw = 5 - integer(ilp), parameter :: kexsh = 6 + integer(${ik}$), parameter :: ntiny = 15_${ik}$ + integer(${ik}$), parameter :: kexnw = 5_${ik}$ + integer(${ik}$), parameter :: kexsh = 6_${ik}$ real(${ck}$), parameter :: wilk1 = 0.75_${ck}$ ! ==== matrices of order ntiny or smaller must be processed by - ! . stdlib_${ci}$lahqr because of insufficient subdiagonal scratch space. + ! . stdlib${ii}$_${ci}$lahqr because of insufficient subdiagonal scratch space. ! . (this is a hard limit.) ==== ! ==== exceptional deflation windows: try to cure rare @@ -46763,13 +46755,13 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars complex(${ck}$) :: aa, bb, cc, cdum, dd, det, rtdisc, swap, tr2 real(${ck}$) :: s - integer(ilp) :: i, inf, it, itmax, k, kacc22, kbot, kdu, ks, kt, ktop, ku, kv, kwh, & + integer(${ik}$) :: i, inf, it, itmax, k, kacc22, kbot, kdu, ks, kt, ktop, ku, kv, kwh, & kwtop, kwv, ld, ls, lwkopt, ndec, ndfl, nh, nho, nibble, nmin, ns, nsmax, nsr, nve, nw,& nwmax, nwr, nwupbd logical(lk) :: sorted - character :: jbcmpz*2 + character(len=2) :: jbcmpz ! Local Arrays - complex(${ck}$) :: zdum(1,1) + complex(${ck}$) :: zdum(1_${ik}$,1_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,cmplx,aimag,int,max,min,mod,sqrt ! Statement Functions @@ -46777,82 +46769,82 @@ module stdlib_linalg_lapack_${ci}$ ! Statement Function Definitions cabs1( cdum ) = abs( real( cdum,KIND=${ck}$) ) + abs( aimag( cdum ) ) ! Executable Statements - info = 0 + info = 0_${ik}$ ! ==== quick return for n = 0: nothing to do. ==== - if( n==0 ) then - work( 1 ) = cone + if( n==0_${ik}$ ) then + work( 1_${ik}$ ) = cone return end if if( n<=ntiny ) then ! ==== tiny matrices must use stdlib_${ci}$lahqr. ==== - lwkopt = 1 - if( lwork/=-1 )call stdlib_${ci}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, & + lwkopt = 1_${ik}$ + if( lwork/=-1_${ik}$ )call stdlib${ii}$_${ci}$lahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, & z, ldz, info ) else ! ==== use small bulge multi-shift qr with aggressive early ! . deflation on larger-than-tiny matrices. ==== ! ==== hope for the best. ==== - info = 0 - ! ==== set up job flags for stdlib_ilaenv. ==== + info = 0_${ik}$ + ! ==== set up job flags for stdlib${ii}$_ilaenv. ==== if( wantt ) then - jbcmpz( 1: 1 ) = 'S' + jbcmpz( 1_${ik}$: 1_${ik}$ ) = 'S' else - jbcmpz( 1: 1 ) = 'E' + jbcmpz( 1_${ik}$: 1_${ik}$ ) = 'E' end if if( wantz ) then - jbcmpz( 2: 2 ) = 'V' + jbcmpz( 2_${ik}$: 2_${ik}$ ) = 'V' else - jbcmpz( 2: 2 ) = 'N' + jbcmpz( 2_${ik}$: 2_${ik}$ ) = 'N' end if ! ==== nwr = recommended deflation window size. at this ! . point, n > ntiny = 15, so there is enough ! . subdiagonal workspace for nwr>=2 as required. ! . (in fact, there is enough subdiagonal space for ! . nwr>=4.) ==== - nwr = stdlib_ilaenv( 13, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) - nwr = max( 2, nwr ) - nwr = min( ihi-ilo+1, ( n-1 ) / 3, nwr ) + nwr = stdlib${ii}$_ilaenv( 13_${ik}$, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) + nwr = max( 2_${ik}$, nwr ) + nwr = min( ihi-ilo+1, ( n-1 ) / 3_${ik}$, nwr ) ! ==== nsr = recommended number of simultaneous shifts. ! . at this point n > ntiny = 15, so there is at ! . enough subdiagonal workspace for nsr to be even ! . and greater than or equal to two as required. ==== - nsr = stdlib_ilaenv( 15, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) - nsr = min( nsr, ( n-3 ) / 6, ihi-ilo ) - nsr = max( 2, nsr-mod( nsr, 2 ) ) + nsr = stdlib${ii}$_ilaenv( 15_${ik}$, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) + nsr = min( nsr, ( n-3 ) / 6_${ik}$, ihi-ilo ) + nsr = max( 2_${ik}$, nsr-mod( nsr, 2_${ik}$ ) ) ! ==== estimate optimal workspace ==== - ! ==== workspace query call to stdlib_${ci}$laqr2 ==== - call stdlib_${ci}$laqr2( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& - ld, w, h, ldh, n, h, ldh, n, h,ldh, work, -1 ) - ! ==== optimal workspace = max(stdlib_${ci}$laqr5, stdlib_${ci}$laqr2) ==== - lwkopt = max( 3*nsr / 2, int( work( 1 ),KIND=ilp) ) + ! ==== workspace query call to stdlib${ii}$_${ci}$laqr2 ==== + call stdlib${ii}$_${ci}$laqr2( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& + ld, w, h, ldh, n, h, ldh, n, h,ldh, work, -1_${ik}$ ) + ! ==== optimal workspace = max(stdlib${ii}$_${ci}$laqr5, stdlib${ii}$_${ci}$laqr2) ==== + lwkopt = max( 3_${ik}$*nsr / 2_${ik}$, int( work( 1_${ik}$ ),KIND=${ik}$) ) ! ==== quick return in case of workspace query. ==== - if( lwork==-1 ) then - work( 1 ) = cmplx( lwkopt, 0,KIND=${ck}$) + if( lwork==-1_${ik}$ ) then + work( 1_${ik}$ ) = cmplx( lwkopt, 0_${ik}$,KIND=${ck}$) return end if - ! ==== stdlib_${ci}$lahqr/stdlib_${ci}$laqr0 crossover point ==== - nmin = stdlib_ilaenv( 12, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) + ! ==== stdlib${ii}$_${ci}$lahqr/stdlib${ii}$_${ci}$laqr0 crossover point ==== + nmin = stdlib${ii}$_ilaenv( 12_${ik}$, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) nmin = max( ntiny, nmin ) ! ==== nibble crossover point ==== - nibble = stdlib_ilaenv( 14, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) - nibble = max( 0, nibble ) + nibble = stdlib${ii}$_ilaenv( 14_${ik}$, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) + nibble = max( 0_${ik}$, nibble ) ! ==== accumulate reflections during ttswp? use block ! . 2-by-2 structure during matrix-matrix multiply? ==== - kacc22 = stdlib_ilaenv( 16, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) - kacc22 = max( 0, kacc22 ) - kacc22 = min( 2, kacc22 ) + kacc22 = stdlib${ii}$_ilaenv( 16_${ik}$, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) + kacc22 = max( 0_${ik}$, kacc22 ) + kacc22 = min( 2_${ik}$, kacc22 ) ! ==== nwmax = the largest possible deflation window for ! . which there is sufficient workspace. ==== - nwmax = min( ( n-1 ) / 3, lwork / 2 ) + nwmax = min( ( n-1 ) / 3_${ik}$, lwork / 2_${ik}$ ) nw = nwmax ! ==== nsmax = the largest number of simultaneous shifts ! . for which there is sufficient workspace. ==== - nsmax = min( ( n-3 ) / 6, 2*lwork / 3 ) - nsmax = nsmax - mod( nsmax, 2 ) + nsmax = min( ( n-3 ) / 6_${ik}$, 2_${ik}$*lwork / 3_${ik}$ ) + nsmax = nsmax - mod( nsmax, 2_${ik}$ ) ! ==== ndfl: an iteration count restarted at deflation. ==== - ndfl = 1 + ndfl = 1_${ik}$ ! ==== itmax = iteration limit ==== - itmax = max( 30, 2*kexsh )*max( 10, ( ihi-ilo+1 ) ) + itmax = max( 30_${ik}$, 2_${ik}$*kexsh )*max( 10_${ik}$, ( ihi-ilo+1 ) ) ! ==== last row and column in the active block ==== kbot = ihi ! ==== main loop ==== @@ -46880,27 +46872,27 @@ module stdlib_linalg_lapack_${ci}$ ! . in general, more powerful than smaller ones, ! . rapidly increase the window to the maximum possible. ! . then, gradually reduce the window size. ==== - nh = kbot - ktop + 1 + nh = kbot - ktop + 1_${ik}$ nwupbd = min( nh, nwmax ) if( ndfl=nh-1 ) then nw = nh else - kwtop = kbot - nw + 1 + kwtop = kbot - nw + 1_${ik}$ if( cabs1( h( kwtop, kwtop-1 ) )>cabs1( h( kwtop-1, kwtop-2 ) ) )nw = nw + & - 1 + 1_${ik}$ end if end if if( ndfl=0 .or. nw>=nwupbd ) then - ndec = ndec + 1 - if( nw-ndec<2 )ndec = 0 + ndec = -1_${ik}$ + else if( ndec>=0_${ik}$ .or. nw>=nwupbd ) then + ndec = ndec + 1_${ik}$ + if( nw-ndec<2_${ik}$ )ndec = 0_${ik}$ nw = nw - ndec end if ! ==== aggressive early deflation: @@ -46913,39 +46905,39 @@ module stdlib_linalg_lapack_${ci}$ ! . - an at-least-nw-but-more-is-better (nhv-by-nw) ! . vertical work array along the left-hand-edge. ! . ==== - kv = n - nw + 1 - kt = nw + 1 - nho = ( n-nw-1 ) - kt + 1 - kwv = nw + 2 - nve = ( n-nw ) - kwv + 1 + kv = n - nw + 1_${ik}$ + kt = nw + 1_${ik}$ + nho = ( n-nw-1 ) - kt + 1_${ik}$ + kwv = nw + 2_${ik}$ + nve = ( n-nw ) - kwv + 1_${ik}$ ! ==== aggressive early deflation ==== - call stdlib_${ci}$laqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & - ls, ld, w, h( kv, 1 ), ldh, nho,h( kv, kt ), ldh, nve, h( kwv, 1 ), ldh, work,& + call stdlib${ii}$_${ci}$laqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & + ls, ld, w, h( kv, 1_${ik}$ ), ldh, nho,h( kv, kt ), ldh, nve, h( kwv, 1_${ik}$ ), ldh, work,& lwork ) ! ==== adjust kbot accounting for new deflations. ==== kbot = kbot - ld ! ==== ks points to the shifts. ==== - ks = kbot - ls + 1 + ks = kbot - ls + 1_${ik}$ ! ==== skip an expensive qr sweep if there is a (partly ! . heuristic) reason to expect that many eigenvalues ! . will deflate without it. here, the qr sweep is ! . skipped if many eigenvalues have just been deflated ! . or if the remaining active block is small. - if( ( ld==0 ) .or. ( ( 100*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& + if( ( ld==0_${ik}$ ) .or. ( ( 100_${ik}$*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& ) ) ) then ! ==== ns = nominal number of simultaneous shifts. - ! . this may be lowered (slightly) if stdlib_${ci}$laqr2 + ! . this may be lowered (slightly) if stdlib${ii}$_${ci}$laqr2 ! . did not provide that many shifts. ==== - ns = min( nsmax, nsr, max( 2, kbot-ktop ) ) - ns = ns - mod( ns, 2 ) + ns = min( nsmax, nsr, max( 2_${ik}$, kbot-ktop ) ) + ns = ns - mod( ns, 2_${ik}$ ) ! ==== if there have been no deflations ! . in a multiple of kexsh iterations, ! . then try exceptional shifts. ! . otherwise use shifts provided by - ! . stdlib_${ci}$laqr2 above or from the eigenvalues + ! . stdlib${ii}$_${ci}$laqr2 above or from the eigenvalues ! . of a trailing principal submatrix. ==== - if( mod( ndfl, kexsh )==0 ) then - ks = kbot - ns + 1 + if( mod( ndfl, kexsh )==0_${ik}$ ) then + ks = kbot - ns + 1_${ik}$ do i = kbot, ks + 1, -2 w( i ) = h( i, i ) + wilk1*cabs1( h( i, i-1 ) ) w( i-1 ) = w( i ) @@ -46956,13 +46948,13 @@ module stdlib_linalg_lapack_${ci}$ ! . get more. (since ns<=nsmax<=(n-3)/6, ! . there is enough space below the subdiagonal ! . to fit an ns-by-ns scratch array.) ==== - if( kbot-ks+1<=ns / 2 ) then - ks = kbot - ns + 1 - kt = n - ns + 1 - call stdlib_${ci}$lacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1 ), ldh ) + if( kbot-ks+1<=ns / 2_${ik}$ ) then + ks = kbot - ns + 1_${ik}$ + kt = n - ns + 1_${ik}$ + call stdlib${ii}$_${ci}$lacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1_${ik}$ ), ldh ) - call stdlib_${ci}$lahqr( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, w( ks )& - , 1, 1, zdum,1, inf ) + call stdlib${ii}$_${ci}$lahqr( .false., .false., ns, 1_${ik}$, ns,h( kt, 1_${ik}$ ), ldh, w( ks )& + , 1_${ik}$, 1_${ik}$, zdum,1_${ik}$, inf ) ks = ks + inf ! ==== in case of a rare qr failure use ! . eigenvalues of the trailing 2-by-2 @@ -46982,7 +46974,7 @@ module stdlib_linalg_lapack_${ci}$ rtdisc = sqrt( -det ) w( kbot-1 ) = ( tr2+rtdisc )*s w( kbot ) = ( tr2-rtdisc )*s - ks = kbot - 1 + ks = kbot - 1_${ik}$ end if end if if( kbot-ks+1>ns ) then @@ -47005,7 +46997,7 @@ module stdlib_linalg_lapack_${ci}$ end if ! ==== if there are only two shifts, then use ! . only cone. ==== - if( kbot-ks+1==2 ) then + if( kbot-ks+1==2_${ik}$ ) then if( cabs1( w( kbot )-h( kbot, kbot ) )0 ) then - ndfl = 1 + if( ld>0_${ik}$ ) then + ndfl = 1_${ik}$ else - ndfl = ndfl + 1 + ndfl = ndfl + 1_${ik}$ end if ! ==== end of main loop ==== end do loop_70 @@ -47055,11 +47047,11 @@ module stdlib_linalg_lapack_${ci}$ 80 continue end if ! ==== return the optimal value of lwork. ==== - work( 1 ) = cmplx( lwkopt, 0,KIND=${ck}$) - end subroutine stdlib_${ci}$laqr4 + work( 1_${ik}$ ) = cmplx( lwkopt, 0_${ik}$,KIND=${ck}$) + end subroutine stdlib${ii}$_${ci}$laqr4 - pure subroutine stdlib_${ci}$laqr5( wantt, wantz, kacc22, n, ktop, kbot, nshfts, s,h, ldh, iloz, & + pure subroutine stdlib${ii}$_${ci}$laqr5( wantt, wantz, kacc22, n, ktop, kbot, nshfts, s,h, ldh, iloz, & !! ZLAQR5:, called by ZLAQR0, performs a !! single small-bulge multi-shift QR sweep. ihiz, z, ldz, v, ldv, u, ldu, nv,wv, ldwv, nh, wh, ldwh ) @@ -47067,7 +47059,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: ihiz, iloz, kacc22, kbot, ktop, ldh, ldu, ldv, ldwh, ldwv, & + integer(${ik}$), intent(in) :: ihiz, iloz, kacc22, kbot, ktop, ldh, ldu, ldv, ldwh, ldwv, & ldz, n, nh, nshfts, nv logical(lk), intent(in) :: wantt, wantz ! Array Arguments @@ -47082,13 +47074,13 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars complex(${ck}$) :: alpha, beta, cdum, refsum real(${ck}$) :: h11, h12, h21, h22, safmax, safmin, scl, smlnum, tst1, tst2, ulp - integer(ilp) :: i2, i4, incol, j, jbot, jcol, jlen, jrow, jtop, k, k1, kdu, kms, krcol,& + integer(${ik}$) :: i2, i4, incol, j, jbot, jcol, jlen, jrow, jtop, k, k1, kdu, kms, krcol,& m, m22, mbot, mtop, nbmps, ndcol, ns, nu logical(lk) :: accum, bmp22 ! Intrinsic Functions intrinsic :: abs,real,conjg,aimag,max,min,mod ! Local Arrays - complex(${ck}$) :: vt(3) + complex(${ck}$) :: vt(3_${ik}$) ! Statement Functions real(${ck}$) :: cabs1 ! Statement Function Definitions @@ -47101,34 +47093,34 @@ module stdlib_linalg_lapack_${ci}$ if( ktop>=kbot )return ! ==== nshfts is supposed to be even, but if it is odd, ! . then simply reduce it by cone. ==== - ns = nshfts - mod( nshfts, 2 ) + ns = nshfts - mod( nshfts, 2_${ik}$ ) ! ==== machine constants for deflation ==== - safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safmax = rone / safmin - call stdlib_${c2ri(ci)}$labad( safmin, safmax ) - ulp = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + call stdlib${ii}$_${c2ri(ci)}$labad( safmin, safmax ) + ulp = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=${ck}$) / ulp ) ! ==== use accumulated reflections to update far-from-diagonal ! . entries ? ==== - accum = ( kacc22==1 ) .or. ( kacc22==2 ) + accum = ( kacc22==1_${ik}$ ) .or. ( kacc22==2_${ik}$ ) ! ==== clear trash ==== if( ktop+2<=kbot )h( ktop+2, ktop ) = czero ! ==== nbmps = number of 2-shift bulges in the chain ==== - nbmps = ns / 2 + nbmps = ns / 2_${ik}$ ! ==== kdu = width of slab ==== - kdu = 4*nbmps + kdu = 4_${ik}$*nbmps ! ==== create and chase chains of nbmps bulges ==== loop_180: do incol = ktop - 2*nbmps + 1, kbot - 2, 2*nbmps ! jtop = index from which updates from the right start. if( accum ) then jtop = max( ktop, incol ) else if( wantt ) then - jtop = 1 + jtop = 1_${ik}$ else jtop = ktop end if ndcol = incol + kdu - if( accum )call stdlib_${ci}$laset( 'ALL', kdu, kdu, czero, cone, u, ldu ) + if( accum )call stdlib${ii}$_${ci}$laset( 'ALL', kdu, kdu, czero, cone, u, ldu ) ! ==== near-the-diagonal bulge chase. the following loop ! . performs the near-the-diagonal part of a small bulge ! . multi-shift qr sweep. each 4*nbmps column diagonal @@ -47147,34 +47139,34 @@ module stdlib_linalg_lapack_${ci}$ ! . (if any) must wait until the active bulges have moved ! . down the diagonal to make room. the phantom matrix ! . paradigm described above helps keep track. ==== - mtop = max( 1, ( ktop-krcol ) / 2+1 ) - mbot = min( nbmps, ( kbot-krcol-1 ) / 2 ) - m22 = mbot + 1 + mtop = max( 1_${ik}$, ( ktop-krcol ) / 2_${ik}$+1 ) + mbot = min( nbmps, ( kbot-krcol-1 ) / 2_${ik}$ ) + m22 = mbot + 1_${ik}$ bmp22 = ( mbotulp*( & + if( cabs1( h( k+2, k )-refsum*vt( 2_${ik}$ ) )+cabs1( refsum*vt( 3_${ik}$ ) )>ulp*( & cabs1( h( k, k ) )+cabs1( h( k+1,k+1 ) )+cabs1( h( k+2, k+2 ) ) ) ) & then ! ==== starting a new bulge here would @@ -47301,9 +47293,9 @@ module stdlib_linalg_lapack_${ci}$ h( k+1, k ) = h( k+1, k ) - refsum h( k+2, k ) = czero h( k+3, k ) = czero - v( 1, m ) = vt( 1 ) - v( 2, m ) = vt( 2 ) - v( 3, m ) = vt( 3 ) + v( 1_${ik}$, m ) = vt( 1_${ik}$ ) + v( 2_${ik}$, m ) = vt( 2_${ik}$ ) + v( 3_${ik}$, m ) = vt( 3_${ik}$ ) end if end if end if @@ -47313,19 +47305,19 @@ module stdlib_linalg_lapack_${ci}$ ! . deflation check. we still delay most of the ! . updates from the left for efficiency. ==== do j = jtop, min( kbot, k+3 ) - refsum = v( 1, m )*( h( j, k+1 )+v( 2, m )*h( j, k+2 )+v( 3, m )*h( j, k+3 & + refsum = v( 1_${ik}$, m )*( h( j, k+1 )+v( 2_${ik}$, m )*h( j, k+2 )+v( 3_${ik}$, m )*h( j, k+3 & ) ) h( j, k+1 ) = h( j, k+1 ) - refsum - h( j, k+2 ) = h( j, k+2 ) -refsum*conjg( v( 2, m ) ) - h( j, k+3 ) = h( j, k+3 ) -refsum*conjg( v( 3, m ) ) + h( j, k+2 ) = h( j, k+2 ) -refsum*conjg( v( 2_${ik}$, m ) ) + h( j, k+3 ) = h( j, k+3 ) -refsum*conjg( v( 3_${ik}$, m ) ) end do ! ==== perform update from left for subsequent ! . column. ==== - refsum = conjg( v( 1, m ) )*( h( k+1, k+1 )+conjg( v( 2, m ) )*h( k+2, k+1 )+& - conjg( v( 3, m ) )*h( k+3, k+1 ) ) + refsum = conjg( v( 1_${ik}$, m ) )*( h( k+1, k+1 )+conjg( v( 2_${ik}$, m ) )*h( k+2, k+1 )+& + conjg( v( 3_${ik}$, m ) )*h( k+3, k+1 ) ) h( k+1, k+1 ) = h( k+1, k+1 ) - refsum - h( k+2, k+1 ) = h( k+2, k+1 ) - refsum*v( 2, m ) - h( k+3, k+1 ) = h( k+3, k+1 ) - refsum*v( 3, m ) + h( k+2, k+1 ) = h( k+2, k+1 ) - refsum*v( 2_${ik}$, m ) + h( k+3, k+1 ) = h( k+3, k+1 ) - refsum*v( 3_${ik}$, m ) ! ==== the following convergence test requires that ! . the tradition small-compared-to-nearby-diagonals ! . criterion and the ahues @@ -47368,13 +47360,13 @@ module stdlib_linalg_lapack_${ci}$ jbot = kbot end if do m = mbot, mtop, -1 - k = krcol + 2*( m-1 ) + k = krcol + 2_${ik}$*( m-1 ) do j = max( ktop, krcol + 2*m ), jbot - refsum = conjg( v( 1, m ) )*( h( k+1, j )+conjg( v( 2, m ) )*h( k+2, j )+& - conjg( v( 3, m ) )*h( k+3, j ) ) + refsum = conjg( v( 1_${ik}$, m ) )*( h( k+1, j )+conjg( v( 2_${ik}$, m ) )*h( k+2, j )+& + conjg( v( 3_${ik}$, m ) )*h( k+3, j ) ) h( k+1, j ) = h( k+1, j ) - refsum - h( k+2, j ) = h( k+2, j ) - refsum*v( 2, m ) - h( k+3, j ) = h( k+3, j ) - refsum*v( 3, m ) + h( k+2, j ) = h( k+2, j ) - refsum*v( 2_${ik}$, m ) + h( k+3, j ) = h( k+3, j ) - refsum*v( 3_${ik}$, m ) end do end do ! ==== accumulate orthogonal transformations. ==== @@ -47383,17 +47375,17 @@ module stdlib_linalg_lapack_${ci}$ ! . with an efficient matrix-matrix ! . multiply.) ==== do m = mbot, mtop, -1 - k = krcol + 2*( m-1 ) + k = krcol + 2_${ik}$*( m-1 ) kms = k - incol - i2 = max( 1, ktop-incol ) - i2 = max( i2, kms-(krcol-incol)+1 ) - i4 = min( kdu, krcol + 2*( mbot-1 ) - incol + 5 ) + i2 = max( 1_${ik}$, ktop-incol ) + i2 = max( i2, kms-(krcol-incol)+1_${ik}$ ) + i4 = min( kdu, krcol + 2_${ik}$*( mbot-1 ) - incol + 5_${ik}$ ) do j = i2, i4 - refsum = v( 1, m )*( u( j, kms+1 )+v( 2, m )*u( j, kms+2 )+v( 3, m )*u( & + refsum = v( 1_${ik}$, m )*( u( j, kms+1 )+v( 2_${ik}$, m )*u( j, kms+2 )+v( 3_${ik}$, m )*u( & j, kms+3 ) ) u( j, kms+1 ) = u( j, kms+1 ) - refsum - u( j, kms+2 ) = u( j, kms+2 ) -refsum*conjg( v( 2, m ) ) - u( j, kms+3 ) = u( j, kms+3 ) -refsum*conjg( v( 3, m ) ) + u( j, kms+2 ) = u( j, kms+2 ) -refsum*conjg( v( 2_${ik}$, m ) ) + u( j, kms+3 ) = u( j, kms+3 ) -refsum*conjg( v( 3_${ik}$, m ) ) end do end do else if( wantz ) then @@ -47401,13 +47393,13 @@ module stdlib_linalg_lapack_${ci}$ ! . now by multiplying by reflections ! . from the right. ==== do m = mbot, mtop, -1 - k = krcol + 2*( m-1 ) + k = krcol + 2_${ik}$*( m-1 ) do j = iloz, ihiz - refsum = v( 1, m )*( z( j, k+1 )+v( 2, m )*z( j, k+2 )+v( 3, m )*z( j, & + refsum = v( 1_${ik}$, m )*( z( j, k+1 )+v( 2_${ik}$, m )*z( j, k+2 )+v( 3_${ik}$, m )*z( j, & k+3 ) ) z( j, k+1 ) = z( j, k+1 ) - refsum - z( j, k+2 ) = z( j, k+2 ) -refsum*conjg( v( 2, m ) ) - z( j, k+3 ) = z( j, k+3 ) -refsum*conjg( v( 3, m ) ) + z( j, k+2 ) = z( j, k+2 ) -refsum*conjg( v( 2_${ik}$, m ) ) + z( j, k+3 ) = z( j, k+3 ) -refsum*conjg( v( 3_${ik}$, m ) ) end do end do end if @@ -47418,46 +47410,46 @@ module stdlib_linalg_lapack_${ci}$ ! . well. ==== if( accum ) then if( wantt ) then - jtop = 1 + jtop = 1_${ik}$ jbot = n else jtop = ktop jbot = kbot end if - k1 = max( 1, ktop-incol ) - nu = ( kdu-max( 0, ndcol-kbot ) ) - k1 + 1 + k1 = max( 1_${ik}$, ktop-incol ) + nu = ( kdu-max( 0_${ik}$, ndcol-kbot ) ) - k1 + 1_${ik}$ ! ==== horizontal multiply ==== do jcol = min( ndcol, kbot ) + 1, jbot, nh jlen = min( nh, jbot-jcol+1 ) - call stdlib_${ci}$gemm( 'C', 'N', nu, jlen, nu, cone, u( k1, k1 ),ldu, h( incol+k1,& + call stdlib${ii}$_${ci}$gemm( 'C', 'N', nu, jlen, nu, cone, u( k1, k1 ),ldu, h( incol+k1,& jcol ), ldh, czero, wh,ldwh ) - call stdlib_${ci}$lacpy( 'ALL', nu, jlen, wh, ldwh,h( incol+k1, jcol ), ldh ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', nu, jlen, wh, ldwh,h( incol+k1, jcol ), ldh ) end do ! ==== vertical multiply ==== do jrow = jtop, max( ktop, incol ) - 1, nv jlen = min( nv, max( ktop, incol )-jrow ) - call stdlib_${ci}$gemm( 'N', 'N', jlen, nu, nu, cone,h( jrow, incol+k1 ), ldh, u( & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', jlen, nu, nu, cone,h( jrow, incol+k1 ), ldh, u( & k1, k1 ),ldu, czero, wv, ldwv ) - call stdlib_${ci}$lacpy( 'ALL', jlen, nu, wv, ldwv,h( jrow, incol+k1 ), ldh ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', jlen, nu, wv, ldwv,h( jrow, incol+k1 ), ldh ) end do ! ==== z multiply (also vertical) ==== if( wantz ) then do jrow = iloz, ihiz, nv jlen = min( nv, ihiz-jrow+1 ) - call stdlib_${ci}$gemm( 'N', 'N', jlen, nu, nu, cone,z( jrow, incol+k1 ), ldz, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', jlen, nu, nu, cone,z( jrow, incol+k1 ), ldz, & u( k1, k1 ),ldu, czero, wv, ldwv ) - call stdlib_${ci}$lacpy( 'ALL', jlen, nu, wv, ldwv,z( jrow, incol+k1 ), ldz ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', jlen, nu, wv, ldwv,z( jrow, incol+k1 ), ldz ) end do end if end if end do loop_180 - end subroutine stdlib_${ci}$laqr5 + end subroutine stdlib${ii}$_${ci}$laqr5 - pure subroutine stdlib_${ci}$laqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_${ci}$laqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) !! ZLAQSB: equilibrates a symmetric band matrix A using the scaling !! factors in the vector S. ! -- lapack auxiliary routine -- @@ -47466,7 +47458,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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(${ck}$), intent(in) :: amax, scond ! Array Arguments real(${ck}$), intent(in) :: s(*) @@ -47476,18 +47468,18 @@ module stdlib_linalg_lapack_${ci}$ real(${ck}$), parameter :: thresh = 0.1e+0_${ck}$ ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(${ck}$) :: 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_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + small = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -47507,17 +47499,17 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$laqsb + end subroutine stdlib${ii}$_${ci}$laqsb - pure subroutine stdlib_${ci}$laqsp( uplo, n, ap, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_${ci}$laqsp( uplo, n, ap, s, scond, amax, equed ) !! ZLAQSP: equilibrates a symmetric matrix A using the scaling factors !! in the vector S. ! -- lapack auxiliary routine -- @@ -47526,7 +47518,7 @@ module stdlib_linalg_lapack_${ci}$ ! Scalar Arguments character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(${ck}$), intent(in) :: amax, scond ! Array Arguments real(${ck}$), intent(in) :: s(*) @@ -47536,16 +47528,16 @@ module stdlib_linalg_lapack_${ci}$ real(${ck}$), parameter :: thresh = 0.1e+0_${ck}$ ! Local Scalars - integer(ilp) :: i, j, jc + integer(${ik}$) :: i, j, jc real(${ck}$) :: 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_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + small = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -47554,7 +47546,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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 @@ -47564,22 +47556,22 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$laqsp + end subroutine stdlib${ii}$_${ci}$laqsp - pure subroutine stdlib_${ci}$laqsy( uplo, n, a, lda, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_${ci}$laqsy( uplo, n, a, lda, s, scond, amax, equed ) !! ZLAQSY: equilibrates a symmetric matrix A using the scaling factors !! in the vector S. ! -- lapack auxiliary routine -- @@ -47588,7 +47580,7 @@ module stdlib_linalg_lapack_${ci}$ ! Scalar Arguments character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: lda, n + integer(${ik}$), intent(in) :: lda, n real(${ck}$), intent(in) :: amax, scond ! Array Arguments real(${ck}$), intent(in) :: s(*) @@ -47598,16 +47590,16 @@ module stdlib_linalg_lapack_${ci}$ real(${ck}$), parameter :: thresh = 0.1e+0_${ck}$ ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(${ck}$) :: 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_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + small = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) / stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -47634,10 +47626,10 @@ module stdlib_linalg_lapack_${ci}$ equed = 'Y' end if return - end subroutine stdlib_${ci}$laqsy + end subroutine stdlib${ii}$_${ci}$laqsy - recursive subroutine stdlib_${ci}$laqz0( wants, wantq, wantz, n, ilo, ihi, a,lda, b, ldb, alpha, & + recursive subroutine stdlib${ii}$_${ci}$laqz0( wants, wantq, wantz, n, ilo, ihi, a,lda, b, ldb, alpha, & !! ZLAQZ0: computes the eigenvalues of a real matrix pair (H,T), !! where H is an upper Hessenberg matrix and T is upper triangular, !! using the double-shift QZ method. @@ -47681,8 +47673,8 @@ module stdlib_linalg_lapack_${ci}$ beta, q, ldq, z,ldz, work, lwork, rwork, rec,info ) ! arguments character, intent( in ) :: wants, wantq, wantz - integer(ilp), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,rec - integer(ilp), intent( out ) :: info + integer(${ik}$), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,rec + integer(${ik}$), intent( out ) :: info complex(${ck}$), intent( inout ) :: a( lda, * ), b( ldb, * ), q( ldq,* ), z( ldz, * ), & alpha( * ), beta( * ), work( * ) real(${ck}$), intent( out ) :: rwork( * ) @@ -47691,133 +47683,133 @@ module stdlib_linalg_lapack_${ci}$ ! local scalars real(${ck}$) :: smlnum, ulp, safmin, safmax, c1, tempr complex(${ck}$) :: eshift, s1, temp - integer(ilp) :: istart, istop, iiter, maxit, istart2, k, ld, nshifts, nblock, nw, nmin,& + integer(${ik}$) :: istart, istop, iiter, maxit, istart2, k, ld, nshifts, nblock, nw, nmin,& nibble, n_undeflated, n_qeflated, ns, sweep_info, shiftpos, lworkreq, k2, istartm, & istopm, iwants, iwantq, iwantz, norm_info, aed_info, nwr, nbr, nsr, itemp1, itemp2, & rcost logical(lk) :: ilschur, ilq, ilz - character :: jbcmpz*3 + character(len=3) :: jbcmpz if( stdlib_lsame( wants, 'E' ) ) then ilschur = .false. - iwants = 1 + iwants = 1_${ik}$ else if( stdlib_lsame( wants, 'S' ) ) then ilschur = .true. - iwants = 2 + iwants = 2_${ik}$ else - iwants = 0 + iwants = 0_${ik}$ end if if( stdlib_lsame( wantq, 'N' ) ) then ilq = .false. - iwantq = 1 + iwantq = 1_${ik}$ else if( stdlib_lsame( wantq, 'V' ) ) then ilq = .true. - iwantq = 2 + iwantq = 2_${ik}$ else if( stdlib_lsame( wantq, 'I' ) ) then ilq = .true. - iwantq = 3 + iwantq = 3_${ik}$ else - iwantq = 0 + iwantq = 0_${ik}$ end if if( stdlib_lsame( wantz, 'N' ) ) then ilz = .false. - iwantz = 1 + iwantz = 1_${ik}$ else if( stdlib_lsame( wantz, 'V' ) ) then ilz = .true. - iwantz = 2 + iwantz = 2_${ik}$ else if( stdlib_lsame( wantz, 'I' ) ) then ilz = .true. - iwantz = 3 + iwantz = 3_${ik}$ else - iwantz = 0 + iwantz = 0_${ik}$ end if ! check argument values - info = 0 - if( iwants==0 ) then - info = -1 - else if( iwantq==0 ) then - info = -2 - else if( iwantz==0 ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( ilo<1 ) then - info = -5 + info = 0_${ik}$ + if( iwants==0_${ik}$ ) then + info = -1_${ik}$ + else if( iwantq==0_${ik}$ ) then + info = -2_${ik}$ + else if( iwantz==0_${ik}$ ) then + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( ilo<1_${ik}$ ) then + info = -5_${ik}$ else if( ihi>n .or. ihi= 2 ) then - call stdlib_${ci}$hgeqz( wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb,alpha, beta, q,& + if( n < nmin .or. rec >= 2_${ik}$ ) then + call stdlib${ii}$_${ci}$hgeqz( wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb,alpha, beta, q,& ldq, z, ldz, work, lwork, rwork,info ) return end if ! find out required workspace - ! workspace query to stdlib_${ci}$laqz2 + ! workspace query to stdlib${ii}$_${ci}$laqz2 nw = max( nwr, nmin ) - call stdlib_${ci}$laqz2( ilschur, ilq, ilz, n, ilo, ihi, nw, a, lda, b, ldb,q, ldq, z, ldz, & - n_undeflated, n_qeflated, alpha,beta, work, nw, work, nw, work, -1, rwork, rec,& + call stdlib${ii}$_${ci}$laqz2( ilschur, ilq, ilz, n, ilo, ihi, nw, a, lda, b, ldb,q, ldq, z, ldz, & + n_undeflated, n_qeflated, alpha,beta, work, nw, work, nw, work, -1_${ik}$, rwork, rec,& aed_info ) - itemp1 = int( work( 1 ),KIND=ilp) - ! workspace query to stdlib_${ci}$laqz3 - call stdlib_${ci}$laqz3( ilschur, ilq, ilz, n, ilo, ihi, nsr, nbr, alpha,beta, a, lda, b, & - ldb, q, ldq, z, ldz, work, nbr,work, nbr, work, -1, sweep_info ) - itemp2 = int( work( 1 ),KIND=ilp) - lworkreq = max( itemp1+2*nw**2, itemp2+2*nbr**2 ) - if ( lwork ==-1 ) then - work( 1 ) = real( lworkreq,KIND=${ck}$) + itemp1 = int( work( 1_${ik}$ ),KIND=${ik}$) + ! workspace query to stdlib${ii}$_${ci}$laqz3 + call stdlib${ii}$_${ci}$laqz3( ilschur, ilq, ilz, n, ilo, ihi, nsr, nbr, alpha,beta, a, lda, b, & + ldb, q, ldq, z, ldz, work, nbr,work, nbr, work, -1_${ik}$, sweep_info ) + itemp2 = int( work( 1_${ik}$ ),KIND=${ik}$) + lworkreq = max( itemp1+2*nw**2_${ik}$, itemp2+2*nbr**2_${ik}$ ) + if ( lwork ==-1_${ik}$ ) then + work( 1_${ik}$ ) = real( lworkreq,KIND=${ck}$) return else if ( lwork < lworkreq ) then - info = -19 + info = -19_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'ZLAQZ0', info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZLAQZ0', info ) return end if ! initialize q and z - if( iwantq==3 ) call stdlib_${ci}$laset( 'FULL', n, n, czero, cone, q,ldq ) - if( iwantz==3 ) call stdlib_${ci}$laset( 'FULL', n, n, czero, cone, z,ldz ) + if( iwantq==3_${ik}$ ) call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, q,ldq ) + if( iwantz==3_${ik}$ ) call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, z,ldz ) ! get machine constants - safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safmax = one/safmin - call stdlib_${c2ri(ci)}$labad( safmin, safmax ) - ulp = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + call stdlib${ii}$_${c2ri(ci)}$labad( safmin, safmax ) + ulp = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=${ck}$)/ulp ) istart = ilo istop = ihi - maxit = 30*( ihi-ilo+1 ) - ld = 0 + maxit = 30_${ik}$*( ihi-ilo+1 ) + ld = 0_${ik}$ do iiter = 1, maxit if( iiter >= maxit ) then info = istop+1 @@ -47832,7 +47824,7 @@ module stdlib_linalg_lapack_${ci}$ a( istop-1,istop-1 ) ) ) ) ) then a( istop, istop-1 ) = czero istop = istop-1 - ld = 0 + ld = 0_${ik}$ eshift = czero end if ! check deflations at the start @@ -47840,7 +47832,7 @@ module stdlib_linalg_lapack_${ci}$ abs( a( istart+1,istart+1 ) ) ) ) ) then a( istart+1, istart ) = czero istart = istart+1 - ld = 0 + ld = 0_${ik}$ eshift = czero end if if ( istart+1 >= istop ) then @@ -47858,7 +47850,7 @@ module stdlib_linalg_lapack_${ci}$ end do ! get range to apply rotations to if ( ilschur ) then - istartm = 1 + istartm = 1_${ik}$ istopm = n else istartm = istart2 @@ -47879,42 +47871,42 @@ module stdlib_linalg_lapack_${ci}$ ! a diagonal element of b is negligable, move it ! to the top and deflate it do k2 = k, istart2+1, -1 - call stdlib_${ci}$lartg( b( k2-1, k2 ), b( k2-1, k2-1 ), c1, s1,temp ) + call stdlib${ii}$_${ci}$lartg( b( k2-1, k2 ), b( k2-1, k2-1 ), c1, s1,temp ) b( k2-1, k2 ) = temp b( k2-1, k2-1 ) = czero - call stdlib_${ci}$rot( k2-2-istartm+1, b( istartm, k2 ), 1,b( istartm, k2-1 ), & - 1, c1, s1 ) - call stdlib_${ci}$rot( min( k2+1, istop )-istartm+1, a( istartm,k2 ), 1, a( & - istartm, k2-1 ), 1, c1, s1 ) + call stdlib${ii}$_${ci}$rot( k2-2-istartm+1, b( istartm, k2 ), 1_${ik}$,b( istartm, k2-1 ), & + 1_${ik}$, c1, s1 ) + call stdlib${ii}$_${ci}$rot( min( k2+1, istop )-istartm+1, a( istartm,k2 ), 1_${ik}$, a( & + istartm, k2-1 ), 1_${ik}$, c1, s1 ) if ( ilz ) then - call stdlib_${ci}$rot( n, z( 1, k2 ), 1, z( 1, k2-1 ), 1, c1,s1 ) + call stdlib${ii}$_${ci}$rot( n, z( 1_${ik}$, k2 ), 1_${ik}$, z( 1_${ik}$, k2-1 ), 1_${ik}$, c1,s1 ) end if if( k2= istop ) then istop = istart2-1 - ld = 0 + ld = 0_${ik}$ eshift = czero cycle end if @@ -47945,15 +47937,15 @@ module stdlib_linalg_lapack_${ci}$ end if end if ! time for aed - call stdlib_${ci}$laqz2( ilschur, ilq, ilz, n, istart2, istop, nw, a, lda,b, ldb, q, ldq,& - z, ldz, n_undeflated, n_qeflated,alpha, beta, work, nw, work( nw**2+1 ), nw,work( & - 2*nw**2+1 ), lwork-2*nw**2, rwork, rec,aed_info ) - if ( n_qeflated > 0 ) then + call stdlib${ii}$_${ci}$laqz2( ilschur, ilq, ilz, n, istart2, istop, nw, a, lda,b, ldb, q, ldq,& + z, ldz, n_undeflated, n_qeflated,alpha, beta, work, nw, work( nw**2_${ik}$+1 ), nw,work( & + 2_${ik}$*nw**2_${ik}$+1 ), lwork-2*nw**2_${ik}$, rwork, rec,aed_info ) + if ( n_qeflated > 0_${ik}$ ) then istop = istop-n_qeflated - ld = 0 + ld = 0_${ik}$ eshift = czero end if - if ( 100*n_qeflated > nibble*( n_qeflated+n_undeflated ) .or.istop-istart2+1 < nmin & + if ( 100_${ik}$*n_qeflated > nibble*( n_qeflated+n_undeflated ) .or.istop-istart2+1 < nmin & ) then ! aed has uncovered many eigenvalues. skip a qz sweep and run ! aed again. @@ -47963,7 +47955,7 @@ module stdlib_linalg_lapack_${ci}$ ns = min( nshifts, istop-istart2 ) ns = min( ns, n_undeflated ) shiftpos = istop-n_qeflated-n_undeflated+1 - if ( mod( ld, 6 ) == 0 ) then + if ( mod( ld, 6_${ik}$ ) == 0_${ik}$ ) then ! exceptional shift. chosen for no particularly good reason. if( ( real( maxit,KIND=${ck}$)*safmin )*abs( a( istop,istop-1 ) ) ilo ) then a( kwtop, kwtop-1 ) = czero end if end if end if ! store window in case of convergence failure - call stdlib_${ci}$lacpy( 'ALL', jw, jw, a( kwtop, kwtop ), lda, work, jw ) - call stdlib_${ci}$lacpy( 'ALL', jw, jw, b( kwtop, kwtop ), ldb, work( jw**2+1 ), jw ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', jw, jw, a( kwtop, kwtop ), lda, work, jw ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', jw, jw, b( kwtop, kwtop ), ldb, work( jw**2_${ik}$+1 ), jw ) ! transform window to real schur form - call stdlib_${ci}$laset( 'FULL', jw, jw, czero, cone, qc, ldqc ) - call stdlib_${ci}$laset( 'FULL', jw, jw, czero, cone, zc, ldzc ) - call stdlib_${ci}$laqz0( 'S', 'V', 'V', jw, 1, jw, a( kwtop, kwtop ), lda,b( kwtop, kwtop ),& - ldb, alpha, beta, qc, ldqc, zc,ldzc, work( 2*jw**2+1 ), lwork-2*jw**2, rwork,rec+1, & + call stdlib${ii}$_${ci}$laset( 'FULL', jw, jw, czero, cone, qc, ldqc ) + call stdlib${ii}$_${ci}$laset( 'FULL', jw, jw, czero, cone, zc, ldzc ) + call stdlib${ii}$_${ci}$laqz0( 'S', 'V', 'V', jw, 1_${ik}$, jw, a( kwtop, kwtop ), lda,b( kwtop, kwtop ),& + ldb, alpha, beta, qc, ldqc, zc,ldzc, work( 2_${ik}$*jw**2_${ik}$+1 ), lwork-2*jw**2_${ik}$, rwork,rec+1, & qz_small_info ) - if( qz_small_info /= 0 ) then + if( qz_small_info /= 0_${ik}$ ) then ! convergence failure, restore the window and exit - nd = 0 + nd = 0_${ik}$ ns = jw-qz_small_info - call stdlib_${ci}$lacpy( 'ALL', jw, jw, work, jw, a( kwtop, kwtop ), lda ) - call stdlib_${ci}$lacpy( 'ALL', jw, jw, work( jw**2+1 ), jw, b( kwtop,kwtop ), ldb ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', jw, jw, work, jw, a( kwtop, kwtop ), lda ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', jw, jw, work( jw**2_${ik}$+1 ), jw, b( kwtop,kwtop ), ldb ) return end if @@ -48135,15 +48126,15 @@ module stdlib_linalg_lapack_${ci}$ kwbot = kwtop-1 else kwbot = ihi - k = 1 - k2 = 1 + k = 1_${ik}$ + k2 = 1_${ik}$ do while ( k <= jw ) ! try to deflate eigenvalue tempr = abs( a( kwbot, kwbot ) ) if( tempr == zero ) then tempr = abs( s ) end if - if ( ( abs( s*qc( 1, kwbot-kwtop+1 ) ) ) <= max( ulp*tempr, smlnum ) ) & + if ( ( abs( s*qc( 1_${ik}$, kwbot-kwtop+1 ) ) ) <= max( ulp*tempr, smlnum ) ) & then ! deflatable kwbot = kwbot-1 @@ -48151,7 +48142,7 @@ module stdlib_linalg_lapack_${ci}$ ! not deflatable, move out of the way ifst = kwbot-kwtop+1 ilst = k2 - call stdlib_${ci}$tgexc( .true., .true., jw, a( kwtop, kwtop ),lda, b( kwtop, & + call stdlib${ii}$_${ci}$tgexc( .true., .true., jw, a( kwtop, kwtop ),lda, b( kwtop, & kwtop ), ldb, qc, ldqc,zc, ldzc, ifst, ilst, ztgexc_info ) k2 = k2+1 end if @@ -48169,16 +48160,16 @@ module stdlib_linalg_lapack_${ci}$ end do if ( kwtop /= ilo .and. s /= czero ) then ! reflect spike back, this will create optimally packed bulges - a( kwtop:kwbot, kwtop-1 ) = a( kwtop, kwtop-1 ) *conjg( qc( 1,1:jw-nd ) ) + a( kwtop:kwbot, kwtop-1 ) = a( kwtop, kwtop-1 ) *conjg( qc( 1_${ik}$,1_${ik}$:jw-nd ) ) do k = kwbot-1, kwtop, -1 - call stdlib_${ci}$lartg( a( k, kwtop-1 ), a( k+1, kwtop-1 ), c1, s1,temp ) + call stdlib${ii}$_${ci}$lartg( a( k, kwtop-1 ), a( k+1, kwtop-1 ), c1, s1,temp ) a( k, kwtop-1 ) = temp a( k+1, kwtop-1 ) = czero k2 = max( kwtop, k-1 ) - call stdlib_${ci}$rot( ihi-k2+1, a( k, k2 ), lda, a( k+1, k2 ), lda, c1,s1 ) - call stdlib_${ci}$rot( ihi-( k-1 )+1, b( k, k-1 ), ldb, b( k+1, k-1 ),ldb, c1, s1 ) + call stdlib${ii}$_${ci}$rot( ihi-k2+1, a( k, k2 ), lda, a( k+1, k2 ), lda, c1,s1 ) + call stdlib${ii}$_${ci}$rot( ihi-( k-1 )+1_${ik}$, b( k, k-1 ), ldb, b( k+1, k-1 ),ldb, c1, s1 ) - call stdlib_${ci}$rot( jw, qc( 1, k-kwtop+1 ), 1, qc( 1, k+1-kwtop+1 ),1, c1, conjg( & + call stdlib${ii}$_${ci}$rot( jw, qc( 1_${ik}$, k-kwtop+1 ), 1_${ik}$, qc( 1_${ik}$, k+1-kwtop+1 ),1_${ik}$, c1, conjg( & s1 ) ) end do ! chase bulges down @@ -48188,7 +48179,7 @@ module stdlib_linalg_lapack_${ci}$ do while ( k >= kwtop ) ! move bulge down and remove it do k2 = k, kwbot-1 - call stdlib_${ci}$laqz1( .true., .true., k2, kwtop, kwtop+jw-1,kwbot, a, lda, b, & + call stdlib${ii}$_${ci}$laqz1( .true., .true., k2, kwtop, kwtop+jw-1,kwbot, a, lda, b, & ldb, jw, kwtop, qc, ldqc,jw, kwtop, zc, ldzc ) end do k = k-1 @@ -48196,98 +48187,98 @@ module stdlib_linalg_lapack_${ci}$ end if ! apply qc and zc to rest of the matrix if ( ilschur ) then - istartm = 1 + istartm = 1_${ik}$ istopm = n else istartm = ilo istopm = ihi end if - if ( istopm-ihi > 0 ) then - call stdlib_${ci}$gemm( 'C', 'N', jw, istopm-ihi, jw, cone, qc, ldqc,a( kwtop, ihi+1 ), & + if ( istopm-ihi > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$gemm( 'C', 'N', jw, istopm-ihi, jw, cone, qc, ldqc,a( kwtop, ihi+1 ), & lda, czero, work, jw ) - call stdlib_${ci}$lacpy( 'ALL', jw, istopm-ihi, work, jw, a( kwtop,ihi+1 ), lda ) - call stdlib_${ci}$gemm( 'C', 'N', jw, istopm-ihi, jw, cone, qc, ldqc,b( kwtop, ihi+1 ), & + call stdlib${ii}$_${ci}$lacpy( 'ALL', jw, istopm-ihi, work, jw, a( kwtop,ihi+1 ), lda ) + call stdlib${ii}$_${ci}$gemm( 'C', 'N', jw, istopm-ihi, jw, cone, qc, ldqc,b( kwtop, ihi+1 ), & ldb, czero, work, jw ) - call stdlib_${ci}$lacpy( 'ALL', jw, istopm-ihi, work, jw, b( kwtop,ihi+1 ), ldb ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', jw, istopm-ihi, work, jw, b( kwtop,ihi+1 ), ldb ) end if if ( ilq ) then - call stdlib_${ci}$gemm( 'N', 'N', n, jw, jw, cone, q( 1, kwtop ), ldq, qc,ldqc, czero, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', n, jw, jw, cone, q( 1_${ik}$, kwtop ), ldq, qc,ldqc, czero, & work, n ) - call stdlib_${ci}$lacpy( 'ALL', n, jw, work, n, q( 1, kwtop ), ldq ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', n, jw, work, n, q( 1_${ik}$, kwtop ), ldq ) end if - if ( kwtop-1-istartm+1 > 0 ) then - call stdlib_${ci}$gemm( 'N', 'N', kwtop-istartm, jw, jw, cone, a( istartm,kwtop ), lda, & + if ( kwtop-1-istartm+1 > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$gemm( 'N', 'N', kwtop-istartm, jw, jw, cone, a( istartm,kwtop ), lda, & zc, ldzc, czero, work,kwtop-istartm ) - call stdlib_${ci}$lacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,a( istartm, kwtop )& + call stdlib${ii}$_${ci}$lacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,a( istartm, kwtop )& , lda ) - call stdlib_${ci}$gemm( 'N', 'N', kwtop-istartm, jw, jw, cone, b( istartm,kwtop ), ldb, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', kwtop-istartm, jw, jw, cone, b( istartm,kwtop ), ldb, & zc, ldzc, czero, work,kwtop-istartm ) - call stdlib_${ci}$lacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,b( istartm, kwtop )& + call stdlib${ii}$_${ci}$lacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,b( istartm, kwtop )& , ldb ) end if if ( ilz ) then - call stdlib_${ci}$gemm( 'N', 'N', n, jw, jw, cone, z( 1, kwtop ), ldz, zc,ldzc, czero, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', n, jw, jw, cone, z( 1_${ik}$, kwtop ), ldz, zc,ldzc, czero, & work, n ) - call stdlib_${ci}$lacpy( 'ALL', n, jw, work, n, z( 1, kwtop ), ldz ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', n, jw, work, n, z( 1_${ik}$, kwtop ), ldz ) end if - end subroutine stdlib_${ci}$laqz2 + end subroutine stdlib${ii}$_${ci}$laqz2 - pure subroutine stdlib_${ci}$laqz3( ilschur, ilq, ilz, n, ilo, ihi, nshifts,nblock_qesired, alpha,& + pure subroutine stdlib${ii}$_${ci}$laqz3( ilschur, ilq, ilz, n, ilo, ihi, nshifts,nblock_qesired, alpha,& !! ZLAQZ3: Executes a single multishift QZ sweep beta, a, lda, b, ldb,q, ldq, z, ldz, qc, ldqc, zc, ldzc, work,lwork, info ) ! function arguments logical(lk), intent( in ) :: ilschur, ilq, ilz - integer(ilp), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,nshifts, & + integer(${ik}$), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,nshifts, & nblock_qesired, ldqc, ldzc complex(${ck}$), intent( inout ) :: a( lda, * ), b( ldb, * ), q( ldq,* ), z( ldz, * ), qc( & ldqc, * ), zc( ldzc, * ), work( * ),alpha( * ), beta( * ) - 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(${ck}$) :: safmin, safmax, c, scale complex(${ck}$) :: temp, temp2, temp3, s - info = 0 + info = 0_${ik}$ if ( nblock_qesired < 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_qesired + work( 1_${ik}$ ) = n*nblock_qesired return else if ( lwork < n*nblock_qesired ) then - info = -25 + info = -25_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'ZLAQZ3', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZLAQZ3', -info ) return end if ! executable statements ! get machine constants - safmin = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) safmax = one/safmin - call stdlib_${c2ri(ci)}$labad( safmin, safmax ) + call stdlib${ii}$_${c2ri(ci)}$labad( safmin, safmax ) if ( ilo >= ihi ) then return end if if ( ilschur ) then - istartm = 1 + istartm = 1_${ik}$ istopm = n else istartm = ilo istopm = ihi end if ns = nshifts - npos = max( nblock_qesired-ns, 1 ) + npos = max( nblock_qesired-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_${ci}$laset( 'FULL', ns+1, ns+1, czero, cone, qc, ldqc ) - call stdlib_${ci}$laset( 'FULL', ns, ns, czero, cone, zc, ldzc ) + call stdlib${ii}$_${ci}$laset( 'FULL', ns+1, ns+1, czero, cone, qc, ldqc ) + call stdlib${ii}$_${ci}$laset( 'FULL', ns, ns, czero, cone, zc, ldzc ) do i = 1, ns ! introduce the shift scale = sqrt( abs( alpha( i ) ) ) * sqrt( abs( beta( i ) ) ) @@ -48301,54 +48292,54 @@ module stdlib_linalg_lapack_${ci}$ temp2 = cone temp3 = czero end if - call stdlib_${ci}$lartg( temp2, temp3, c, s, temp ) - call stdlib_${ci}$rot( ns, a( ilo, ilo ), lda, a( ilo+1, ilo ), lda, c,s ) - call stdlib_${ci}$rot( ns, b( ilo, ilo ), ldb, b( ilo+1, ilo ), ldb, c,s ) - call stdlib_${ci}$rot( ns+1, qc( 1, 1 ), 1, qc( 1, 2 ), 1, c,conjg( s ) ) + call stdlib${ii}$_${ci}$lartg( temp2, temp3, c, s, temp ) + call stdlib${ii}$_${ci}$rot( ns, a( ilo, ilo ), lda, a( ilo+1, ilo ), lda, c,s ) + call stdlib${ii}$_${ci}$rot( ns, b( ilo, ilo ), ldb, b( ilo+1, ilo ), ldb, c,s ) + call stdlib${ii}$_${ci}$rot( ns+1, qc( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, qc( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, c,conjg( s ) ) ! chase the shift down do j = 1, ns-i - call stdlib_${ci}$laqz1( .true., .true., j, 1, ns, ihi-ilo+1, a( ilo,ilo ), lda, b( & - ilo, ilo ), ldb, ns+1, 1, qc,ldqc, ns, 1, zc, ldzc ) + call stdlib${ii}$_${ci}$laqz1( .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)' sheight = ns+1 - swidth = istopm-( ilo+ns )+1 - if ( swidth > 0 ) then - call stdlib_${ci}$gemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,a( ilo, ilo+& + swidth = istopm-( ilo+ns )+1_${ik}$ + if ( swidth > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$gemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,a( ilo, ilo+& ns ), lda, czero, work, sheight ) - call stdlib_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight, a( ilo,ilo+ns ), lda ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight, a( ilo,ilo+ns ), lda ) - call stdlib_${ci}$gemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,b( ilo, ilo+& + call stdlib${ii}$_${ci}$gemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,b( ilo, ilo+& ns ), ldb, czero, work, sheight ) - call stdlib_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight, b( ilo,ilo+ns ), ldb ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight, b( ilo,ilo+ns ), ldb ) end if if ( ilq ) then - call stdlib_${ci}$gemm( 'N', 'N', n, sheight, sheight, cone, q( 1, ilo ),ldq, qc, ldqc, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', n, sheight, sheight, cone, q( 1_${ik}$, ilo ),ldq, qc, ldqc, & czero, work, n ) - call stdlib_${ci}$lacpy( 'ALL', n, sheight, work, n, q( 1, ilo ), ldq ) + call stdlib${ii}$_${ci}$lacpy( '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) sheight = ilo-1-istartm+1 swidth = ns - if ( sheight > 0 ) then - call stdlib_${ci}$gemm( 'N', 'N', sheight, swidth, swidth, cone,a( istartm, ilo ), lda, & + if ( sheight > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$gemm( 'N', 'N', sheight, swidth, swidth, cone,a( istartm, ilo ), lda, & zc, ldzc, czero, work,sheight ) - call stdlib_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ilo ), lda ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ilo ), lda ) - call stdlib_${ci}$gemm( 'N', 'N', sheight, swidth, swidth, cone,b( istartm, ilo ), ldb, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', sheight, swidth, swidth, cone,b( istartm, ilo ), ldb, & zc, ldzc, czero, work,sheight ) - call stdlib_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ilo ), ldb ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ilo ), ldb ) end if if ( ilz ) then - call stdlib_${ci}$gemm( 'N', 'N', n, swidth, swidth, cone, z( 1, ilo ),ldz, zc, ldzc, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', n, swidth, swidth, cone, z( 1_${ik}$, ilo ),ldz, zc, ldzc, & czero, work, n ) - call stdlib_${ci}$lacpy( 'ALL', n, swidth, work, n, z( 1, ilo ), ldz ) + call stdlib${ii}$_${ci}$lacpy( '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 @@ -48362,15 +48353,15 @@ module stdlib_linalg_lapack_${ci}$ istartb = k+1 ! istopb points to the last column we will be updating istopb = k+nblock-1 - call stdlib_${ci}$laset( 'FULL', ns+np, ns+np, czero, cone, qc, ldqc ) - call stdlib_${ci}$laset( 'FULL', ns+np, ns+np, czero, cone, zc, ldzc ) + call stdlib${ii}$_${ci}$laset( 'FULL', ns+np, ns+np, czero, cone, qc, ldqc ) + call stdlib${ii}$_${ci}$laset( 'FULL', ns+np, ns+np, czero, cone, zc, ldzc ) ! near the diagonal shift chase do i = ns-1, 0, -1 do j = 0, np-1 ! move down the block with index k+i+j, updating ! the (ns+np x ns+np) block: ! (k:k+ns+np,k:k+ns+np-1) - call stdlib_${ci}$laqz1( .true., .true., k+i+j, istartb, istopb, ihi,a, lda, b, & + call stdlib${ii}$_${ci}$laqz1( .true., .true., k+i+j, istartb, istopb, ihi,a, lda, b, & ldb, nblock, k+1, qc, ldqc,nblock, k, zc, ldzc ) end do end do @@ -48379,47 +48370,47 @@ module stdlib_linalg_lapack_${ci}$ ! b(k+1:k+ns+np, k+ns+np:istopm) ! from the left with qc(1:ns+np,1:ns+np)' sheight = ns+np - swidth = istopm-( k+ns+np )+1 - if ( swidth > 0 ) then - call stdlib_${ci}$gemm( 'C', 'N', sheight, swidth, sheight, cone, qc,ldqc, a( k+1, k+& + swidth = istopm-( k+ns+np )+1_${ik}$ + if ( swidth > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$gemm( 'C', 'N', sheight, swidth, sheight, cone, qc,ldqc, a( k+1, k+& ns+np ), lda, czero, work,sheight ) - call stdlib_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight, a( k+1,k+ns+np ), lda & + call stdlib${ii}$_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight, a( k+1,k+ns+np ), lda & ) - call stdlib_${ci}$gemm( 'C', 'N', sheight, swidth, sheight, cone, qc,ldqc, b( k+1, k+& + call stdlib${ii}$_${ci}$gemm( 'C', 'N', sheight, swidth, sheight, cone, qc,ldqc, b( k+1, k+& ns+np ), ldb, czero, work,sheight ) - call stdlib_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight, b( k+1,k+ns+np ), ldb & + call stdlib${ii}$_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight, b( k+1,k+ns+np ), ldb & ) end if if ( ilq ) then - call stdlib_${ci}$gemm( 'N', 'N', n, nblock, nblock, cone, q( 1, k+1 ),ldq, qc, ldqc, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', n, nblock, nblock, cone, q( 1_${ik}$, k+1 ),ldq, qc, ldqc, & czero, work, n ) - call stdlib_${ci}$lacpy( 'ALL', n, nblock, work, n, q( 1, k+1 ), ldq ) + call stdlib${ii}$_${ci}$lacpy( '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) sheight = k-istartm+1 swidth = nblock - if ( sheight > 0 ) then - call stdlib_${ci}$gemm( 'N', 'N', sheight, swidth, swidth, cone,a( istartm, k ), lda, & + if ( sheight > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$gemm( 'N', 'N', sheight, swidth, swidth, cone,a( istartm, k ), lda, & zc, ldzc, czero, work,sheight ) - call stdlib_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight,a( istartm, k ), lda ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight,a( istartm, k ), lda ) - call stdlib_${ci}$gemm( 'N', 'N', sheight, swidth, swidth, cone,b( istartm, k ), ldb, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', sheight, swidth, swidth, cone,b( istartm, k ), ldb, & zc, ldzc, czero, work,sheight ) - call stdlib_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight,b( istartm, k ), ldb ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight,b( istartm, k ), ldb ) end if if ( ilz ) then - call stdlib_${ci}$gemm( 'N', 'N', n, nblock, nblock, cone, z( 1, k ),ldz, zc, ldzc, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', n, nblock, nblock, cone, z( 1_${ik}$, k ),ldz, zc, ldzc, & czero, work, n ) - call stdlib_${ci}$lacpy( 'ALL', n, nblock, work, n, z( 1, k ), ldz ) + call stdlib${ii}$_${ci}$lacpy( '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_${ci}$laset( 'FULL', ns, ns, czero, cone, qc, ldqc ) - call stdlib_${ci}$laset( 'FULL', ns+1, ns+1, czero, cone, zc, ldzc ) + call stdlib${ii}$_${ci}$laset( 'FULL', ns, ns, czero, cone, qc, ldqc ) + call stdlib${ii}$_${ci}$laset( 'FULL', ns+1, ns+1, czero, cone, zc, ldzc ) ! istartb points to the first row we will be updating istartb = ihi-ns+1 ! istopb points to the last column we will be updating @@ -48427,7 +48418,7 @@ module stdlib_linalg_lapack_${ci}$ do i = 1, ns ! chase the shift down to the bottom right corner do ishift = ihi-i, ihi-1 - call stdlib_${ci}$laqz1( .true., .true., ishift, istartb, istopb, ihi,a, lda, b, ldb, & + call stdlib${ii}$_${ci}$laqz1( .true., .true., ishift, istartb, istopb, ihi,a, lda, b, ldb, & ns, ihi-ns+1, qc, ldqc, ns+1,ihi-ns, zc, ldzc ) end do end do @@ -48435,45 +48426,45 @@ module stdlib_linalg_lapack_${ci}$ ! update a(ihi-ns+1:ihi, ihi+1:istopm) ! from the left with qc(1:ns,1:ns)' sheight = ns - swidth = istopm-( ihi+1 )+1 - if ( swidth > 0 ) then - call stdlib_${ci}$gemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,a( ihi-ns+1, & + swidth = istopm-( ihi+1 )+1_${ik}$ + if ( swidth > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$gemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,a( ihi-ns+1, & ihi+1 ), lda, czero, work, sheight ) - call stdlib_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight,a( ihi-ns+1, ihi+1 ), lda & + call stdlib${ii}$_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight,a( ihi-ns+1, ihi+1 ), lda & ) - call stdlib_${ci}$gemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,b( ihi-ns+1, & + call stdlib${ii}$_${ci}$gemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,b( ihi-ns+1, & ihi+1 ), ldb, czero, work, sheight ) - call stdlib_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight,b( ihi-ns+1, ihi+1 ), ldb & + call stdlib${ii}$_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight,b( ihi-ns+1, ihi+1 ), ldb & ) end if if ( ilq ) then - call stdlib_${ci}$gemm( 'N', 'N', n, ns, ns, cone, q( 1, ihi-ns+1 ), ldq,qc, ldqc, czero,& + call stdlib${ii}$_${ci}$gemm( 'N', 'N', n, ns, ns, cone, q( 1_${ik}$, ihi-ns+1 ), ldq,qc, ldqc, czero,& work, n ) - call stdlib_${ci}$lacpy( 'ALL', n, ns, work, n, q( 1, ihi-ns+1 ), ldq ) + call stdlib${ii}$_${ci}$lacpy( '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) sheight = ihi-ns-istartm+1 swidth = ns+1 - if ( sheight > 0 ) then - call stdlib_${ci}$gemm( 'N', 'N', sheight, swidth, swidth, cone,a( istartm, ihi-ns ), & + if ( sheight > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$gemm( 'N', 'N', sheight, swidth, swidth, cone,a( istartm, ihi-ns ), & lda, zc, ldzc, czero, work,sheight ) - call stdlib_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ihi-ns ), lda & + call stdlib${ii}$_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ihi-ns ), lda & ) - call stdlib_${ci}$gemm( 'N', 'N', sheight, swidth, swidth, cone,b( istartm, ihi-ns ), & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', sheight, swidth, swidth, cone,b( istartm, ihi-ns ), & ldb, zc, ldzc, czero, work,sheight ) - call stdlib_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ihi-ns ), ldb & + call stdlib${ii}$_${ci}$lacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ihi-ns ), ldb & ) end if if ( ilz ) then - call stdlib_${ci}$gemm( 'N', 'N', n, ns+1, ns+1, cone, z( 1, ihi-ns ), ldz,zc, ldzc, & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', n, ns+1, ns+1, cone, z( 1_${ik}$, ihi-ns ), ldz,zc, ldzc, & czero, work, n ) - call stdlib_${ci}$lacpy( 'ALL', n, ns+1, work, n, z( 1, ihi-ns ), ldz ) + call stdlib${ii}$_${ci}$lacpy( 'ALL', n, ns+1, work, n, z( 1_${ik}$, ihi-ns ), ldz ) end if - end subroutine stdlib_${ci}$laqz3 + end subroutine stdlib${ii}$_${ci}$laqz3 - pure subroutine stdlib_${ci}$lar1v( n, b1, bn, lambda, d, l, ld, lld,pivmin, gaptol, z, wantnc, & + pure subroutine stdlib${ii}$_${ci}$lar1v( n, b1, bn, lambda, d, l, ld, lld,pivmin, gaptol, z, wantnc, & !! ZLAR1V: computes the (scaled) r-th column of the inverse of !! the sumbmatrix in rows B1 through BN of the tridiagonal matrix !! L D L**T - sigma I. When sigma is close to an eigenvalue, the @@ -48495,13 +48486,13 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(${ck}$), intent(in) :: gaptol, lambda, pivmin real(${ck}$), intent(out) :: mingma, nrminv, resid, rqcorr, ztz ! Array Arguments - integer(ilp), intent(out) :: isuppz(*) + integer(${ik}$), intent(out) :: isuppz(*) real(${ck}$), intent(in) :: d(*), l(*), ld(*), lld(*) real(${ck}$), intent(out) :: work(*) complex(${ck}$), intent(inout) :: z(*) @@ -48510,13 +48501,13 @@ module stdlib_linalg_lapack_${ci}$ ! 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(${ck}$) :: dminus, dplus, eps, s, tmp ! Intrinsic Functions intrinsic :: abs,real ! Executable Statements - eps = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) - if( r==0 ) then + eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' ) + if( r==0_${ik}$ ) then r1 = b1 r2 = bn else @@ -48524,12 +48515,12 @@ module stdlib_linalg_lapack_${ci}$ 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 ) @@ -48537,16 +48528,16 @@ module stdlib_linalg_lapack_${ci}$ ! 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(dplus0 ) 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-czero row in v. do while( lastv>0 .and. v( i )==czero ) - lastv = lastv - 1 + lastv = lastv - 1_${ik}$ i = i - incv end do if( applyleft ) then ! scan for the last non-czero column in c(1:lastv,:). - lastc = stdlib_ila${ci}$lc(lastv, n, c, ldc) + lastc = stdlib${ii}$_ila${ci}$lc(lastv, n, c, ldc) else ! scan for the last non-czero row in c(:,1:lastv). - lastc = stdlib_ila${ci}$lr(m, lastv, c, ldc) + lastc = stdlib${ii}$_ila${ci}$lr(m, lastv, c, ldc) end if end if ! note that lastc.eq.0_${ck}$ renders the blas operations null; no special ! case is needed at this level. if( applyleft ) then ! form h * c - if( lastv>0 ) then + if( lastv>0_${ik}$ ) then ! w(1:lastc,1) := c(1:lastv,1:lastc)**h * v(1:lastv,1) - call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', lastv, lastc, cone,c, ldc, v, incv, & - czero, work, 1 ) + call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', lastv, lastc, cone,c, ldc, v, incv, & + czero, work, 1_${ik}$ ) ! c(1:lastv,1:lastc) := c(...) - v(1:lastv,1) * w(1:lastc,1)**h - call stdlib_${ci}$gerc( lastv, lastc, -tau, v, incv, work, 1, c, ldc ) + call stdlib${ii}$_${ci}$gerc( lastv, lastc, -tau, v, incv, work, 1_${ik}$, c, ldc ) end if else ! form c * h - if( lastv>0 ) then + if( lastv>0_${ik}$ ) then ! w(1:lastc,1) := c(1:lastc,1:lastv) * v(1:lastv,1) - call stdlib_${ci}$gemv( 'NO TRANSPOSE', lastc, lastv, cone, c, ldc,v, incv, czero, & - work, 1 ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', lastc, lastv, cone, c, ldc,v, incv, czero, & + work, 1_${ik}$ ) ! c(1:lastc,1:lastv) := c(...) - w(1:lastc,1) * v(1:lastv,1)**h - call stdlib_${ci}$gerc( lastc, lastv, -tau, work, 1, v, incv, c, ldc ) + call stdlib${ii}$_${ci}$gerc( lastc, lastv, -tau, work, 1_${ik}$, v, incv, c, ldc ) end if end if return - end subroutine stdlib_${ci}$larf + end subroutine stdlib${ii}$_${ci}$larf - pure subroutine stdlib_${ci}$larfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, ldc, & + pure subroutine stdlib${ii}$_${ci}$larfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, ldc, & !! ZLARFB: applies a complex block reflector H or its transpose H**H to a !! complex M-by-N matrix C, from either the left or the right. work, ldwork ) @@ -48893,7 +48884,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: c(ldc,*) complex(${ck}$), intent(in) :: t(ldt,*), v(ldv,*) @@ -48902,7 +48893,7 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars character :: transt - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Intrinsic Functions intrinsic :: conjg ! Executable Statements @@ -48924,28 +48915,28 @@ module stdlib_linalg_lapack_${ci}$ ! w := c**h * v = (c1**h * v1 + c2**h * v2) (stored in work) ! w := c1**h do j = 1, k - call stdlib_${ci}$copy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) - call stdlib_${ci}$lacgv( n, work( 1, j ), 1 ) + call stdlib${ii}$_${ci}$copy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( n, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v1 - call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v, & + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v, & ldv, work, ldwork ) if( m>k ) then ! w := w + c2**h * v2 - call stdlib_${ci}$gemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', n,k, m-k, cone, & - c( k+1, 1 ), ldc,v( k+1, 1 ), ldv, cone, work, ldwork ) + call stdlib${ii}$_${ci}$gemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', n,k, m-k, cone, & + c( k+1, 1_${ik}$ ), ldc,v( k+1, 1_${ik}$ ), ldv, cone, work, ldwork ) end if ! w := w * t**h or w * t - call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,cone, t, ldt, & + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,cone, t, ldt, & work, ldwork ) ! c := c - v * w**h if( m>k ) then ! c2 := c2 - v2 * w**h - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',m-k, n, k, -cone, & - v( k+1, 1 ), ldv, work,ldwork, cone, c( k+1, 1 ), ldc ) + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',m-k, n, k, -cone, & + v( k+1, 1_${ik}$ ), ldv, work,ldwork, cone, c( k+1, 1_${ik}$ ), ldc ) end if ! w := w * v1**h - call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& v, ldv, work, ldwork ) ! c1 := c1 - w**h do j = 1, k @@ -48958,27 +48949,27 @@ module stdlib_linalg_lapack_${ci}$ ! w := c * v = (c1*v1 + c2*v2) (stored in work) ! w := c1 do j = 1, k - call stdlib_${ci}$copy( m, c( 1, j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_${ci}$copy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v1 - call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v, & + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v, & ldv, work, ldwork ) if( n>k ) then ! w := w + c2 * v2 - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,cone, c( 1, k+& - 1 ), ldc, v( k+1, 1 ), ldv,cone, work, ldwork ) + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,cone, c( 1_${ik}$, k+& + 1_${ik}$ ), ldc, v( k+1, 1_${ik}$ ), ldv,cone, work, ldwork ) end if ! w := w * t or w * t**h - call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,cone, t, ldt, & + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,cone, t, ldt, & work, ldwork ) ! c := c - w * v**h if( n>k ) then ! c2 := c2 - w * v2**h - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,n-k, k, -cone, & - work, ldwork, v( k+1, 1 ),ldv, cone, c( 1, k+1 ), ldc ) + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,n-k, k, -cone, & + work, ldwork, v( k+1, 1_${ik}$ ),ldv, cone, c( 1_${ik}$, k+1 ), ldc ) end if ! w := w * v1**h - call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& v, ldv, work, ldwork ) ! c1 := c1 - w do j = 1, k @@ -48997,29 +48988,29 @@ module stdlib_linalg_lapack_${ci}$ ! w := c**h * v = (c1**h * v1 + c2**h * v2) (stored in work) ! w := c2**h do j = 1, k - call stdlib_${ci}$copy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 ) - call stdlib_${ci}$lacgv( n, work( 1, j ), 1 ) + call stdlib${ii}$_${ci}$copy( n, c( m-k+j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( n, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v2 - call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v( m-& - k+1, 1 ), ldv, work, ldwork ) + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v( m-& + k+1, 1_${ik}$ ), ldv, work, ldwork ) if( m>k ) then ! w := w + c1**h * v1 - call stdlib_${ci}$gemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', n,k, m-k, cone, & + call stdlib${ii}$_${ci}$gemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', n,k, m-k, cone, & c, ldc, v, ldv, cone, work,ldwork ) end if ! w := w * t**h or w * t - call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,cone, t, ldt, & + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,cone, t, ldt, & work, ldwork ) ! c := c - v * w**h if( m>k ) then ! c1 := c1 - v1 * w**h - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',m-k, n, k, -cone, & + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',m-k, n, k, -cone, & v, ldv, work, ldwork,cone, c, ldc ) end if ! w := w * v2**h - call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& - v( m-k+1, 1 ), ldv, work,ldwork ) + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& + v( m-k+1, 1_${ik}$ ), ldv, work,ldwork ) ! c2 := c2 - w**h do j = 1, k do i = 1, n @@ -49031,28 +49022,28 @@ module stdlib_linalg_lapack_${ci}$ ! w := c * v = (c1*v1 + c2*v2) (stored in work) ! w := c2 do j = 1, k - call stdlib_${ci}$copy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_${ci}$copy( m, c( 1_${ik}$, n-k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v2 - call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v( n-& - k+1, 1 ), ldv, work, ldwork ) + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v( n-& + k+1, 1_${ik}$ ), ldv, work, ldwork ) if( n>k ) then ! w := w + c1 * v1 - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,cone, c, ldc, & + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,cone, c, ldc, & v, ldv, cone, work, ldwork ) end if ! w := w * t or w * t**h - call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,cone, t, ldt, & + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,cone, t, ldt, & work, ldwork ) ! c := c - w * v**h if( n>k ) then ! c1 := c1 - w * v1**h - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,n-k, k, -cone, & + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,n-k, k, -cone, & work, ldwork, v, ldv, cone,c, ldc ) end if ! w := w * v2**h - call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& - v( n-k+1, 1 ), ldv, work,ldwork ) + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& + v( n-k+1, 1_${ik}$ ), ldv, work,ldwork ) ! c2 := c2 - w do j = 1, k do i = 1, m @@ -49071,28 +49062,28 @@ module stdlib_linalg_lapack_${ci}$ ! w := c**h * v**h = (c1**h * v1**h + c2**h * v2**h) (stored in work) ! w := c1**h do j = 1, k - call stdlib_${ci}$copy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) - call stdlib_${ci}$lacgv( n, work( 1, j ), 1 ) + call stdlib${ii}$_${ci}$copy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( n, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v1**h - call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& v, ldv, work, ldwork ) if( m>k ) then ! w := w + c2**h * v2**h - call stdlib_${ci}$gemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', n, k, m-k, & - cone,c( k+1, 1 ), ldc, v( 1, k+1 ), ldv, cone,work, ldwork ) + call stdlib${ii}$_${ci}$gemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', n, k, m-k, & + cone,c( k+1, 1_${ik}$ ), ldc, v( 1_${ik}$, k+1 ), ldv, cone,work, ldwork ) end if ! w := w * t**h or w * t - call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,cone, t, ldt, & + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,cone, t, ldt, & work, ldwork ) ! c := c - v**h * w**h if( m>k ) then ! c2 := c2 - v2**h * w**h - call stdlib_${ci}$gemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', m-k, n, k, & - -cone,v( 1, k+1 ), ldv, work, ldwork, cone,c( k+1, 1 ), ldc ) + call stdlib${ii}$_${ci}$gemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', m-k, n, k, & + -cone,v( 1_${ik}$, k+1 ), ldv, work, ldwork, cone,c( k+1, 1_${ik}$ ), ldc ) end if ! w := w * v1 - call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v, & + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v, & ldv, work, ldwork ) ! c1 := c1 - w**h do j = 1, k @@ -49105,27 +49096,27 @@ module stdlib_linalg_lapack_${ci}$ ! w := c * v**h = (c1*v1**h + c2*v2**h) (stored in work) ! w := c1 do j = 1, k - call stdlib_${ci}$copy( m, c( 1, j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_${ci}$copy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v1**h - call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& v, ldv, work, ldwork ) if( n>k ) then ! w := w + c2 * v2**h - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,k, n-k, cone, & - c( 1, k+1 ), ldc,v( 1, k+1 ), ldv, cone, work, ldwork ) + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,k, n-k, cone, & + c( 1_${ik}$, k+1 ), ldc,v( 1_${ik}$, k+1 ), ldv, cone, work, ldwork ) end if ! w := w * t or w * t**h - call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,cone, t, ldt, & + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,cone, t, ldt, & work, ldwork ) ! c := c - w * v if( n>k ) then ! c2 := c2 - w * v2 - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-cone, work, & - ldwork, v( 1, k+1 ), ldv, cone,c( 1, k+1 ), ldc ) + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-cone, work, & + ldwork, v( 1_${ik}$, k+1 ), ldv, cone,c( 1_${ik}$, k+1 ), ldc ) end if ! w := w * v1 - call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v, & + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v, & ldv, work, ldwork ) ! c1 := c1 - w do j = 1, k @@ -49143,28 +49134,28 @@ module stdlib_linalg_lapack_${ci}$ ! w := c**h * v**h = (c1**h * v1**h + c2**h * v2**h) (stored in work) ! w := c2**h do j = 1, k - call stdlib_${ci}$copy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 ) - call stdlib_${ci}$lacgv( n, work( 1, j ), 1 ) + call stdlib${ii}$_${ci}$copy( n, c( m-k+j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( n, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v2**h - call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& - v( 1, m-k+1 ), ldv, work,ldwork ) + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& + v( 1_${ik}$, m-k+1 ), ldv, work,ldwork ) if( m>k ) then ! w := w + c1**h * v1**h - call stdlib_${ci}$gemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', n, k, m-k, & + call stdlib${ii}$_${ci}$gemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', n, k, m-k, & cone, c,ldc, v, ldv, cone, work, ldwork ) end if ! w := w * t**h or w * t - call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,cone, t, ldt, & + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,cone, t, ldt, & work, ldwork ) ! c := c - v**h * w**h if( m>k ) then ! c1 := c1 - v1**h * w**h - call stdlib_${ci}$gemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', m-k, n, k, & + call stdlib${ii}$_${ci}$gemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', m-k, n, k, & -cone, v,ldv, work, ldwork, cone, c, ldc ) end if ! w := w * v2 - call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v( 1, & + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v( 1_${ik}$, & m-k+1 ), ldv, work, ldwork ) ! c2 := c2 - w**h do j = 1, k @@ -49177,27 +49168,27 @@ module stdlib_linalg_lapack_${ci}$ ! w := c * v**h = (c1*v1**h + c2*v2**h) (stored in work) ! w := c2 do j = 1, k - call stdlib_${ci}$copy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_${ci}$copy( m, c( 1_${ik}$, n-k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v2**h - call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& - v( 1, n-k+1 ), ldv, work,ldwork ) + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& + v( 1_${ik}$, n-k+1 ), ldv, work,ldwork ) if( n>k ) then ! w := w + c1 * v1**h - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,k, n-k, cone, & + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,k, n-k, cone, & c, ldc, v, ldv, cone, work,ldwork ) end if ! w := w * t or w * t**h - call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,cone, t, ldt, & + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,cone, t, ldt, & work, ldwork ) ! c := c - w * v if( n>k ) then ! c1 := c1 - w * v1 - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-cone, work, & + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-cone, work, & ldwork, v, ldv, cone, c, ldc ) end if ! w := w * v2 - call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v( 1, & + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v( 1_${ik}$, & n-k+1 ), ldv, work, ldwork ) ! c1 := c1 - w do j = 1, k @@ -49209,10 +49200,10 @@ module stdlib_linalg_lapack_${ci}$ end if end if return - end subroutine stdlib_${ci}$larfb + end subroutine stdlib${ii}$_${ci}$larfb - pure subroutine stdlib_${ci}$larfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) + pure subroutine stdlib${ii}$_${ci}$larfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) !! ZLARFB_GETT: applies a complex Householder block reflector H from the !! left to a complex (K+M)-by-N "triangular-pentagonal" matrix !! composed of two block matrices: an upper trapezoidal K-by-N matrix A @@ -49226,7 +49217,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) complex(${ck}$), intent(in) :: t(ldt,*) @@ -49235,7 +49226,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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 @@ -49249,35 +49240,35 @@ module stdlib_linalg_lapack_${ci}$ ! col2_(1) compute w2: = a2. therefore, copy a2 = a(1:k, k+1:n) ! into w2=work(1:k, 1:n-k) column-by-column. do j = 1, n-k - call stdlib_${ci}$copy( k, a( 1, k+j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_${ci}$copy( k, a( 1_${ik}$, k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do if( lnotident ) then ! col2_(2) compute w2: = (v1**h) * w2 = (a1**h) * w2, ! v1 is not an identy matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored). - call stdlib_${ci}$trmm( 'L', 'L', 'C', 'U', k, n-k, cone, a, lda,work, ldwork ) + call stdlib${ii}$_${ci}$trmm( 'L', 'L', 'C', 'U', k, n-k, cone, a, lda,work, ldwork ) end if ! col2_(3) compute w2: = w2 + (v2**h) * b2 = w2 + (b1**h) * b2 ! v2 stored in b1. - if( m>0 ) then - call stdlib_${ci}$gemm( 'C', 'N', k, n-k, m, cone, b, ldb,b( 1, k+1 ), ldb, cone, & + if( m>0_${ik}$ ) then + call stdlib${ii}$_${ci}$gemm( 'C', 'N', k, n-k, m, cone, b, ldb,b( 1_${ik}$, k+1 ), ldb, cone, & work, ldwork ) end if ! col2_(4) compute w2: = t * w2, ! t is upper-triangular. - call stdlib_${ci}$trmm( 'L', 'U', 'N', 'N', k, n-k, cone, t, ldt,work, ldwork ) + call stdlib${ii}$_${ci}$trmm( 'L', 'U', 'N', 'N', k, n-k, cone, t, ldt,work, ldwork ) ! col2_(5) compute b2: = b2 - v2 * w2 = b2 - b1 * w2, ! v2 stored in b1. - if( m>0 ) then - call stdlib_${ci}$gemm( 'N', 'N', m, n-k, k, -cone, b, ldb,work, ldwork, cone, b( 1, & + if( m>0_${ik}$ ) then + call stdlib${ii}$_${ci}$gemm( 'N', 'N', m, n-k, k, -cone, b, ldb,work, ldwork, cone, b( 1_${ik}$, & k+1 ), ldb ) end if if( lnotident ) then ! col2_(6) compute w2: = v1 * w2 = a1 * w2, ! v1 is not an identity matrix, but unit lower-triangular, ! v1 stored in a1 (diagonal ones are not stored). - call stdlib_${ci}$trmm( 'L', 'L', 'N', 'U', k, n-k, cone, a, lda,work, ldwork ) + call stdlib${ii}$_${ci}$trmm( 'L', 'L', 'N', 'U', k, n-k, cone, a, lda,work, ldwork ) end if ! col2_(7) compute a2: = a2 - w2 = @@ -49298,7 +49289,7 @@ module stdlib_linalg_lapack_${ci}$ ! a1 = a(1:k, 1:k) into the upper-triangular ! w1 = work(1:k, 1:k) column-by-column. do j = 1, k - call stdlib_${ci}$copy( j, a( 1, j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_${ci}$copy( 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 @@ -49311,16 +49302,16 @@ module stdlib_linalg_lapack_${ci}$ ! 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_${ci}$trmm( 'L', 'L', 'C', 'U', k, k, cone, a, lda,work, ldwork ) + call stdlib${ii}$_${ci}$trmm( 'L', 'L', 'C', 'U', k, k, cone, a, lda,work, ldwork ) end if ! col1_(3) compute w1: = t * w1, ! t is upper-triangular, ! w1 is upper-triangular with zeroes below the diagonal. - call stdlib_${ci}$trmm( 'L', 'U', 'N', 'N', k, k, cone, t, ldt,work, ldwork ) + call stdlib${ii}$_${ci}$trmm( 'L', 'U', 'N', 'N', k, k, cone, t, ldt,work, ldwork ) ! col1_(4) compute b1: = - v2 * w1 = - b1 * w1, ! v2 = b1, w1 is upper-triangular with zeroes below the diagonal. - if( m>0 ) then - call stdlib_${ci}$trmm( 'R', 'U', 'N', 'N', m, k, -cone, work, ldwork,b, ldb ) + if( m>0_${ik}$ ) then + call stdlib${ii}$_${ci}$trmm( 'R', 'U', 'N', 'N', m, k, -cone, work, ldwork,b, ldb ) end if if( lnotident ) then ! col1_(5) compute w1: = v1 * w1 = a1 * w1, @@ -49328,7 +49319,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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_${ci}$trmm( 'L', 'L', 'N', 'U', k, k, cone, a, lda,work, ldwork ) + call stdlib${ii}$_${ci}$trmm( 'L', 'L', 'N', 'U', k, k, cone, a, lda,work, ldwork ) ! col1_(6) compute a1: = a1 - w1 = a(1:k, 1:k) - work(1:k, 1:k) ! column-by-column. a1 is upper-triangular on input. ! if ident, a1 is square on output, and w1 is square, @@ -49348,10 +49339,10 @@ module stdlib_linalg_lapack_${ci}$ end do end do return - end subroutine stdlib_${ci}$larfb_gett + end subroutine stdlib${ii}$_${ci}$larfb_gett - pure subroutine stdlib_${ci}$larfg( n, alpha, x, incx, tau ) + pure subroutine stdlib${ii}$_${ci}$larfg( n, alpha, x, incx, tau ) !! ZLARFG: generates a complex elementary reflector H of order n, such !! that !! H**H * ( alpha ) = ( beta ), H**H * H = I. @@ -49369,7 +49360,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: alpha complex(${ck}$), intent(out) :: tau ! Array Arguments @@ -49377,16 +49368,16 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! Local Scalars - integer(ilp) :: j, knt + integer(${ik}$) :: j, knt real(${ck}$) :: alphi, alphr, beta, rsafmn, safmin, xnorm ! Intrinsic Functions intrinsic :: abs,real,cmplx,aimag,sign ! Executable Statements - if( n<=0 ) then + if( n<=0_${ik}$ ) then tau = zero return end if - xnorm = stdlib_${c2ri(ci)}$znrm2( n-1, x, incx ) + xnorm = stdlib${ii}$_${c2ri(ci)}$znrm2( n-1, x, incx ) alphr = real( alpha,KIND=${ck}$) alphi = aimag( alpha ) if( xnorm==zero .and. alphi==zero ) then @@ -49394,27 +49385,27 @@ module stdlib_linalg_lapack_${ci}$ tau = zero else ! general case - beta = -sign( stdlib_${c2ri(ci)}$lapy3( alphr, alphi, xnorm ), alphr ) - safmin = stdlib_${c2ri(ci)}$lamch( 'S' ) / stdlib_${c2ri(ci)}$lamch( 'E' ) + beta = -sign( stdlib${ii}$_${c2ri(ci)}$lapy3( alphr, alphi, xnorm ), alphr ) + safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' ) / stdlib${ii}$_${c2ri(ci)}$lamch( 'E' ) rsafmn = one / safmin - knt = 0 + knt = 0_${ik}$ if( abs( beta )1 ) then + if( i>1_${ik}$ ) then prevlastv = max( prevlastv, lastv ) else prevlastv = lastv @@ -49636,7 +49627,7 @@ module stdlib_linalg_lapack_${ci}$ end if end do else - prevlastv = 1 + prevlastv = 1_${ik}$ do i = k, 1, -1 if( tau( i )==czero ) then ! h(i) = i @@ -49656,8 +49647,8 @@ module stdlib_linalg_lapack_${ci}$ end do j = max( lastv, prevlastv ) ! t(i+1:k,i) = -tau(i) * v(j:n-k+i,i+1:k)**h * v(j:n-k+i,i) - call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', n-k+i-j, k-i,-tau( i ), v( j, & - i+1 ), ldv, v( j, i ),1, cone, t( i+1, i ), 1 ) + call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', n-k+i-j, k-i,-tau( i ), v( j, & + i+1 ), ldv, v( j, i ),1_${ik}$, cone, t( i+1, i ), 1_${ik}$ ) else ! skip any leading zeros. do lastv = 1, i-1 @@ -49668,13 +49659,13 @@ module stdlib_linalg_lapack_${ci}$ end do j = max( lastv, prevlastv ) ! t(i+1:k,i) = -tau(i) * v(i+1:k,j:n-k+i) * v(i,j:n-k+i)**h - call stdlib_${ci}$gemm( 'N', 'C', k-i, 1, n-k+i-j, -tau( i ),v( i+1, j ), & + call stdlib${ii}$_${ci}$gemm( 'N', 'C', k-i, 1_${ik}$, n-k+i-j, -tau( i ),v( i+1, j ), & ldv, v( i, j ), ldv,cone, t( i+1, i ), ldt ) end if ! t(i+1:k,i) := t(i+1:k,i+1:k) * t(i+1:k,i) - call stdlib_${ci}$trmv( '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}$_${ci}$trmv( '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 @@ -49685,10 +49676,10 @@ module stdlib_linalg_lapack_${ci}$ end do end if return - end subroutine stdlib_${ci}$larft + end subroutine stdlib${ii}$_${ci}$larft - pure subroutine stdlib_${ci}$larfx( side, m, n, v, tau, c, ldc, work ) + pure subroutine stdlib${ii}$_${ci}$larfx( side, m, n, v, tau, c, ldc, work ) !! ZLARFX: applies a complex elementary reflector H to a complex m by n !! matrix C, from either the left or the right. H is represented in the !! form @@ -49701,7 +49692,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(in) :: tau ! Array Arguments complex(${ck}$), intent(inout) :: c(ldc,*) @@ -49710,7 +49701,7 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! Local Scalars - integer(ilp) :: j + integer(${ik}$) :: j complex(${ck}$) :: sum, t1, t10, t2, t3, t4, t5, t6, t7, t8, t9, v1, v10, v2, v3, v4, v5, & v6, v7, v8, v9 ! Intrinsic Functions @@ -49721,479 +49712,479 @@ module stdlib_linalg_lapack_${ci}$ ! 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_${ci}$larf( side, m, n, v, 1, tau, c, ldc, work ) + call stdlib${ii}$_${ci}$larf( side, m, n, v, 1_${ik}$, tau, c, ldc, work ) go to 410 10 continue ! special code for 1 x 1 householder - t1 = cone - tau*v( 1 )*conjg( v( 1 ) ) + t1 = cone - tau*v( 1_${ik}$ )*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( v2 ) - v3 = conjg( v( 3 ) ) + v3 = conjg( v( 3_${ik}$ ) ) t3 = tau*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( v2 ) - v3 = conjg( v( 3 ) ) + v3 = conjg( v( 3_${ik}$ ) ) t3 = tau*conjg( v3 ) - v4 = conjg( v( 4 ) ) + v4 = conjg( v( 4_${ik}$ ) ) t4 = tau*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( v2 ) - v3 = conjg( v( 3 ) ) + v3 = conjg( v( 3_${ik}$ ) ) t3 = tau*conjg( v3 ) - v4 = conjg( v( 4 ) ) + v4 = conjg( v( 4_${ik}$ ) ) t4 = tau*conjg( v4 ) - v5 = conjg( v( 5 ) ) + v5 = conjg( v( 5_${ik}$ ) ) t5 = tau*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( v2 ) - v3 = conjg( v( 3 ) ) + v3 = conjg( v( 3_${ik}$ ) ) t3 = tau*conjg( v3 ) - v4 = conjg( v( 4 ) ) + v4 = conjg( v( 4_${ik}$ ) ) t4 = tau*conjg( v4 ) - v5 = conjg( v( 5 ) ) + v5 = conjg( v( 5_${ik}$ ) ) t5 = tau*conjg( v5 ) - v6 = conjg( v( 6 ) ) + v6 = conjg( v( 6_${ik}$ ) ) t6 = tau*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( v2 ) - v3 = conjg( v( 3 ) ) + v3 = conjg( v( 3_${ik}$ ) ) t3 = tau*conjg( v3 ) - v4 = conjg( v( 4 ) ) + v4 = conjg( v( 4_${ik}$ ) ) t4 = tau*conjg( v4 ) - v5 = conjg( v( 5 ) ) + v5 = conjg( v( 5_${ik}$ ) ) t5 = tau*conjg( v5 ) - v6 = conjg( v( 6 ) ) + v6 = conjg( v( 6_${ik}$ ) ) t6 = tau*conjg( v6 ) - v7 = conjg( v( 7 ) ) + v7 = conjg( v( 7_${ik}$ ) ) t7 = tau*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( v2 ) - v3 = conjg( v( 3 ) ) + v3 = conjg( v( 3_${ik}$ ) ) t3 = tau*conjg( v3 ) - v4 = conjg( v( 4 ) ) + v4 = conjg( v( 4_${ik}$ ) ) t4 = tau*conjg( v4 ) - v5 = conjg( v( 5 ) ) + v5 = conjg( v( 5_${ik}$ ) ) t5 = tau*conjg( v5 ) - v6 = conjg( v( 6 ) ) + v6 = conjg( v( 6_${ik}$ ) ) t6 = tau*conjg( v6 ) - v7 = conjg( v( 7 ) ) + v7 = conjg( v( 7_${ik}$ ) ) t7 = tau*conjg( v7 ) - v8 = conjg( v( 8 ) ) + v8 = conjg( v( 8_${ik}$ ) ) t8 = tau*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( v2 ) - v3 = conjg( v( 3 ) ) + v3 = conjg( v( 3_${ik}$ ) ) t3 = tau*conjg( v3 ) - v4 = conjg( v( 4 ) ) + v4 = conjg( v( 4_${ik}$ ) ) t4 = tau*conjg( v4 ) - v5 = conjg( v( 5 ) ) + v5 = conjg( v( 5_${ik}$ ) ) t5 = tau*conjg( v5 ) - v6 = conjg( v( 6 ) ) + v6 = conjg( v( 6_${ik}$ ) ) t6 = tau*conjg( v6 ) - v7 = conjg( v( 7 ) ) + v7 = conjg( v( 7_${ik}$ ) ) t7 = tau*conjg( v7 ) - v8 = conjg( v( 8 ) ) + v8 = conjg( v( 8_${ik}$ ) ) t8 = tau*conjg( v8 ) - v9 = conjg( v( 9 ) ) + v9 = conjg( v( 9_${ik}$ ) ) t9 = tau*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( v2 ) - v3 = conjg( v( 3 ) ) + v3 = conjg( v( 3_${ik}$ ) ) t3 = tau*conjg( v3 ) - v4 = conjg( v( 4 ) ) + v4 = conjg( v( 4_${ik}$ ) ) t4 = tau*conjg( v4 ) - v5 = conjg( v( 5 ) ) + v5 = conjg( v( 5_${ik}$ ) ) t5 = tau*conjg( v5 ) - v6 = conjg( v( 6 ) ) + v6 = conjg( v( 6_${ik}$ ) ) t6 = tau*conjg( v6 ) - v7 = conjg( v( 7 ) ) + v7 = conjg( v( 7_${ik}$ ) ) t7 = tau*conjg( v7 ) - v8 = conjg( v( 8 ) ) + v8 = conjg( v( 8_${ik}$ ) ) t8 = tau*conjg( v8 ) - v9 = conjg( v( 9 ) ) + v9 = conjg( v( 9_${ik}$ ) ) t9 = tau*conjg( v9 ) - v10 = conjg( v( 10 ) ) + v10 = conjg( v( 10_${ik}$ ) ) t10 = tau*conjg( 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_${ci}$larf( side, m, n, v, 1, tau, c, ldc, work ) + call stdlib${ii}$_${ci}$larf( side, m, n, v, 1_${ik}$, tau, c, ldc, work ) go to 410 210 continue ! special code for 1 x 1 householder - t1 = cone - tau*v( 1 )*conjg( v( 1 ) ) + t1 = cone - tau*v( 1_${ik}$ )*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( v2 ) - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( v2 ) - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*conjg( v3 ) - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( v2 ) - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*conjg( v3 ) - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*conjg( v4 ) - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( v2 ) - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*conjg( v3 ) - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*conjg( v4 ) - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*conjg( v5 ) - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( v2 ) - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*conjg( v3 ) - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*conjg( v4 ) - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*conjg( v5 ) - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*conjg( v6 ) - v7 = v( 7 ) + v7 = v( 7_${ik}$ ) t7 = tau*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( v2 ) - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*conjg( v3 ) - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*conjg( v4 ) - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*conjg( v5 ) - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*conjg( v6 ) - v7 = v( 7 ) + v7 = v( 7_${ik}$ ) t7 = tau*conjg( v7 ) - v8 = v( 8 ) + v8 = v( 8_${ik}$ ) t8 = tau*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( v2 ) - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*conjg( v3 ) - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*conjg( v4 ) - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*conjg( v5 ) - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*conjg( v6 ) - v7 = v( 7 ) + v7 = v( 7_${ik}$ ) t7 = tau*conjg( v7 ) - v8 = v( 8 ) + v8 = v( 8_${ik}$ ) t8 = tau*conjg( v8 ) - v9 = v( 9 ) + v9 = v( 9_${ik}$ ) t9 = tau*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( v2 ) - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*conjg( v3 ) - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*conjg( v4 ) - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*conjg( v5 ) - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*conjg( v6 ) - v7 = v( 7 ) + v7 = v( 7_${ik}$ ) t7 = tau*conjg( v7 ) - v8 = v( 8 ) + v8 = v( 8_${ik}$ ) t8 = tau*conjg( v8 ) - v9 = v( 9 ) + v9 = v( 9_${ik}$ ) t9 = tau*conjg( v9 ) - v10 = v( 10 ) + v10 = v( 10_${ik}$ ) t10 = tau*conjg( 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 continue return - end subroutine stdlib_${ci}$larfx + end subroutine stdlib${ii}$_${ci}$larfx - pure subroutine stdlib_${ci}$larfy( uplo, n, v, incv, tau, c, ldc, work ) + pure subroutine stdlib${ii}$_${ci}$larfy( uplo, n, v, incv, tau, c, ldc, work ) !! ZLARFY: applies an elementary reflector, or Householder matrix, H, !! to an n x n Hermitian matrix C, from both the left and the right. !! H is represented in the form @@ -50205,7 +50196,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(in) :: tau ! Array Arguments complex(${ck}$), intent(inout) :: c(ldc,*) @@ -50218,16 +50209,16 @@ module stdlib_linalg_lapack_${ci}$ ! Executable Statements if( tau==czero )return ! form w:= c * v - call stdlib_${ci}$hemv( uplo, n, cone, c, ldc, v, incv, czero, work, 1 ) - alpha = -chalf*tau*stdlib_${ci}$dotc( n, work, 1, v, incv ) - call stdlib_${ci}$axpy( n, alpha, v, incv, work, 1 ) + call stdlib${ii}$_${ci}$hemv( uplo, n, cone, c, ldc, v, incv, czero, work, 1_${ik}$ ) + alpha = -chalf*tau*stdlib${ii}$_${ci}$dotc( n, work, 1_${ik}$, v, incv ) + call stdlib${ii}$_${ci}$axpy( n, alpha, v, incv, work, 1_${ik}$ ) ! c := c - v * w' - w * v' - call stdlib_${ci}$her2( uplo, n, -tau, v, incv, work, 1, c, ldc ) + call stdlib${ii}$_${ci}$her2( uplo, n, -tau, v, incv, work, 1_${ik}$, c, ldc ) return - end subroutine stdlib_${ci}$larfy + end subroutine stdlib${ii}$_${ci}$larfy - pure subroutine stdlib_${ci}$largv( n, x, incx, y, incy, c, incc ) + pure subroutine stdlib${ii}$_${ci}$largv( n, x, incx, y, incy, c, incc ) !! ZLARGV: generates a vector of complex plane rotations with real !! cosines, determined by elements of the complex vectors x and y. !! For i = 1,2,...,n @@ -50242,7 +50233,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(${ck}$), intent(out) :: c(*) complex(${ck}$), intent(inout) :: x(*), y(*) @@ -50251,7 +50242,7 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars ! logical first - integer(ilp) :: count, i, ic, ix, iy, j + integer(${ik}$) :: count, i, ic, ix, iy, j real(${ck}$) :: cs, d, di, dr, eps, f2, f2s, g2, g2s, safmin, safmn2, safmx2, scale complex(${ck}$) :: f, ff, fs, g, gs, r, sn ! Intrinsic Functions @@ -50264,30 +50255,30 @@ module stdlib_linalg_lapack_${ci}$ ! data first / .true. / ! Statement Function Definitions abs1( ff ) = max( abs( real( ff,KIND=${ck}$) ), abs( aimag( ff ) ) ) - abssq( ff ) = real( ff,KIND=${ck}$)**2 + aimag( ff )**2 + abssq( ff ) = real( ff,KIND=${ck}$)**2_${ik}$ + aimag( ff )**2_${ik}$ ! Executable Statements ! if( first ) then ! first = .false. - safmin = stdlib_${c2ri(ci)}$lamch( 'S' ) - eps = stdlib_${c2ri(ci)}$lamch( 'E' ) - safmn2 = stdlib_${c2ri(ci)}$lamch( 'B' )**int( log( safmin / eps ) /log( stdlib_${c2ri(ci)}$lamch( 'B' ) )& - / two,KIND=ilp) + safmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' ) + eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'E' ) + safmn2 = stdlib${ii}$_${c2ri(ci)}$lamch( 'B' )**int( log( safmin / eps ) /log( stdlib${ii}$_${c2ri(ci)}$lamch( 'B' ) )& + / two,KIND=${ik}$) safmx2 = one / safmn2 ! end if - ix = 1 - iy = 1 - ic = 1 + ix = 1_${ik}$ + iy = 1_${ik}$ + ic = 1_${ik}$ loop_60: do i = 1, n f = x( ix ) g = y( iy ) - ! use identical algorithm as in stdlib_${ci}$lartg + ! use identical algorithm as in stdlib${ii}$_${ci}$lartg scale = max( abs1( f ), abs1( g ) ) fs = f gs = g - count = 0 + count = 0_${ik}$ if( scale>=safmx2 ) then 10 continue - count = count + 1 + count = count + 1_${ik}$ fs = fs*safmn2 gs = gs*safmn2 scale = scale*safmn2 @@ -50300,7 +50291,7 @@ module stdlib_linalg_lapack_${ci}$ go to 50 end if 20 continue - count = count - 1 + count = count - 1_${ik}$ fs = fs*safmx2 gs = gs*safmx2 scale = scale*safmx2 @@ -50312,14 +50303,14 @@ module stdlib_linalg_lapack_${ci}$ ! this is a rare case: f is very small. if( f==czero ) then cs = zero - r = stdlib_${c2ri(ci)}$lapy2( real( g,KIND=${ck}$), aimag( g ) ) + r = stdlib${ii}$_${c2ri(ci)}$lapy2( real( g,KIND=${ck}$), aimag( g ) ) ! do complex/real division explicitly with two real ! divisions - d = stdlib_${c2ri(ci)}$lapy2( real( gs,KIND=${ck}$), aimag( gs ) ) + d = stdlib${ii}$_${c2ri(ci)}$lapy2( real( gs,KIND=${ck}$), aimag( gs ) ) sn = cmplx( real( gs,KIND=${ck}$) / d, -aimag( gs ) / d,KIND=${ck}$) go to 50 end if - f2s = stdlib_${c2ri(ci)}$lapy2( real( fs,KIND=${ck}$), aimag( fs ) ) + f2s = stdlib${ii}$_${c2ri(ci)}$lapy2( real( fs,KIND=${ck}$), aimag( fs ) ) ! g2 and g2s are accurate ! g2 is at least safmin, and g2s is at least safmn2 g2s = sqrt( g2 ) @@ -50334,12 +50325,12 @@ module stdlib_linalg_lapack_${ci}$ ! make sure abs(ff) = 1 ! do complex/real division explicitly with 2 real divisions if( abs1( f )>one ) then - d = stdlib_${c2ri(ci)}$lapy2( real( f,KIND=${ck}$), aimag( f ) ) + d = stdlib${ii}$_${c2ri(ci)}$lapy2( real( f,KIND=${ck}$), aimag( f ) ) ff = cmplx( real( f,KIND=${ck}$) / d, aimag( f ) / d,KIND=${ck}$) else dr = safmx2*real( f,KIND=${ck}$) di = safmx2*aimag( f ) - d = stdlib_${c2ri(ci)}$lapy2( dr, di ) + d = stdlib${ii}$_${c2ri(ci)}$lapy2( dr, di ) ff = cmplx( dr / d, di / d,KIND=${ck}$) end if sn = ff*cmplx( real( gs,KIND=${ck}$) / g2s, -aimag( gs ) / g2s,KIND=${ck}$) @@ -50357,8 +50348,8 @@ module stdlib_linalg_lapack_${ci}$ ! do complex/real division explicitly with two real divisions sn = cmplx( real( r,KIND=${ck}$) / d, aimag( r ) / d,KIND=${ck}$) sn = sn*conjg( gs ) - if( count/=0 ) then - if( count>0 ) then + if( count/=0_${ik}$ ) then + if( count>0_${ik}$ ) then do j = 1, count r = r*safmx2 end do @@ -50378,75 +50369,75 @@ module stdlib_linalg_lapack_${ci}$ ix = ix + incx end do loop_60 return - end subroutine stdlib_${ci}$largv + end subroutine stdlib${ii}$_${ci}$largv - pure subroutine stdlib_${ci}$larnv( idist, iseed, n, x ) + pure subroutine stdlib${ii}$_${ci}$larnv( idist, iseed, n, x ) !! ZLARNV: returns a vector of n random complex 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}$) complex(${ck}$), intent(out) :: x(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: lv = 128 + integer(${ik}$), parameter :: lv = 128_${ik}$ real(${ck}$), parameter :: twopi = 6.28318530717958647692528676655900576839e+0_${ck}$ ! Local Scalars - integer(ilp) :: i, il, iv + integer(${ik}$) :: i, il, iv ! Local Arrays real(${ck}$) :: u(lv) ! Intrinsic Functions intrinsic :: cmplx,exp,log,min,sqrt ! Executable Statements do 60 iv = 1, n, lv / 2 - il = min( lv / 2, n-iv+1 ) - ! call stdlib_${c2ri(ci)}$laruv to generate 2*il realnumbers from a uniform (0,1,KIND=${ck}$) + il = min( lv / 2_${ik}$, n-iv+1 ) + ! call stdlib${ii}$_${c2ri(ci)}$laruv to generate 2*il realnumbers from a uniform (0,1,KIND=${ck}$) ! distribution (2*il <= lv) - call stdlib_${c2ri(ci)}$laruv( iseed, 2*il, u ) - if( idist==1 ) then + call stdlib${ii}$_${c2ri(ci)}$laruv( iseed, 2_${ik}$*il, u ) + if( idist==1_${ik}$ ) then ! copy generated numbers do i = 1, il - x( iv+i-1 ) = cmplx( u( 2*i-1 ), u( 2*i ),KIND=${ck}$) + x( iv+i-1 ) = cmplx( u( 2_${ik}$*i-1 ), u( 2_${ik}$*i ),KIND=${ck}$) end do - else if( idist==2 ) then + else if( idist==2_${ik}$ ) then ! convert generated numbers to uniform (-1,1) distribution do i = 1, il - x( iv+i-1 ) = cmplx( two*u( 2*i-1 )-one,two*u( 2*i )-one,KIND=${ck}$) + x( iv+i-1 ) = cmplx( two*u( 2_${ik}$*i-1 )-one,two*u( 2_${ik}$*i )-one,KIND=${ck}$) end do - else if( idist==3 ) then + else if( idist==3_${ik}$ ) then ! convert generated numbers to normal (0,1) distribution do i = 1, il - x( iv+i-1 ) = sqrt( -two*log( u( 2*i-1 ) ) )*exp( cmplx( zero, twopi*u( 2*i ),& + x( iv+i-1 ) = sqrt( -two*log( u( 2_${ik}$*i-1 ) ) )*exp( cmplx( zero, twopi*u( 2_${ik}$*i ),& KIND=${ck}$) ) end do - else if( idist==4 ) then + else if( idist==4_${ik}$ ) then ! convert generated numbers to complex numbers uniformly ! distributed on the unit disk do i = 1, il - x( iv+i-1 ) = sqrt( u( 2*i-1 ) )*exp( cmplx( zero, twopi*u( 2*i ),KIND=${ck}$) ) + x( iv+i-1 ) = sqrt( u( 2_${ik}$*i-1 ) )*exp( cmplx( zero, twopi*u( 2_${ik}$*i ),KIND=${ck}$) ) end do - else if( idist==5 ) then + else if( idist==5_${ik}$ ) then ! convert generated numbers to complex numbers uniformly ! distributed on the unit circle do i = 1, il - x( iv+i-1 ) = exp( cmplx( zero, twopi*u( 2*i ),KIND=${ck}$) ) + x( iv+i-1 ) = exp( cmplx( zero, twopi*u( 2_${ik}$*i ),KIND=${ck}$) ) end do end if 60 continue return - end subroutine stdlib_${ci}$larnv + end subroutine stdlib${ii}$_${ci}$larnv - pure subroutine stdlib_${ci}$larrv( n, vl, vu, d, l, pivmin,isplit, m, dol, dou, minrgp,rtol1, & + pure subroutine stdlib${ii}$_${ci}$larrv( n, vl, vu, d, l, pivmin,isplit, m, dol, dou, minrgp,rtol1, & !! ZLARRV: computes the eigenvectors of the tridiagonal matrix !! T = L D L**T given L, D and APPROXIMATIONS to the eigenvalues of L D L**T. !! The input eigenvalues should have been computed by DLARRE. @@ -50455,31 +50446,31 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: dol, dou, ldz, m, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: dol, dou, ldz, m, n + integer(${ik}$), intent(out) :: info real(${ck}$), intent(in) :: minrgp, pivmin, vl, vu real(${ck}$), intent(inout) :: rtol1, rtol2 ! Array Arguments - integer(ilp), intent(in) :: iblock(*), indexw(*), isplit(*) - integer(ilp), intent(out) :: isuppz(*), iwork(*) + integer(${ik}$), intent(in) :: iblock(*), indexw(*), isplit(*) + integer(${ik}$), intent(out) :: isuppz(*), iwork(*) real(${ck}$), intent(inout) :: d(*), l(*), w(*), werr(*), wgap(*) real(${ck}$), intent(in) :: gers(*) real(${ck}$), intent(out) :: work(*) complex(${ck}$), intent(out) :: z(ldz,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: maxitr = 10 + integer(${ik}$), parameter :: maxitr = 10_${ik}$ ! Local Scalars logical(lk) :: eskip, needbs, stp2ii, tryrqc, usedbs, usedrq - integer(ilp) :: done, i, ibegin, idone, iend, ii, iindc1, iindc2, iindr, iindwk, iinfo,& + integer(${ik}$) :: done, i, ibegin, idone, iend, ii, iindc1, iindc2, iindr, iindwk, iinfo,& im, in, indeig, indld, indlld, indwrk, isupmn, isupmx, iter, itmp1, j, jblk, k, & miniwsize, minwsize, nclus, ndepth, negcnt, newcls, newfst, newftt, newlst, newsiz, & offset, oldcls, oldfst, oldien, oldlst, oldncl, p, parity, q, wbegin, wend, windex, & windmn, windpl, zfrom, zto, zusedl, zusedu, zusedw - integer(ilp) :: indin1, indin2 + integer(${ik}$) :: indin1, indin2 real(${ck}$) :: bstres, bstw, eps, fudge, gap, gaptol, gl, gu, lambda, left, lgap, mingma, & nrminv, resid, rgap, right, rqcorr, rqtol, savgap, sgndef, sigma, spdiam, ssigma, tau, & tmp, tol, ztz @@ -50487,35 +50478,35 @@ module stdlib_linalg_lapack_${ci}$ intrinsic :: abs,real,max,min intrinsic :: cmplx ! Executable Statements - info = 0 + info = 0_${ik}$ ! quick return if possible - if( (n<=0).or.(m<=0) ) then + if( (n<=0_${ik}$).or.(m<=0_${ik}$) ) then return end if ! the first n entries of work are reserved for the eigenvalues indld = n+1 - indlld= 2*n+1 - indin1 = 3*n + 1 - indin2 = 4*n + 1 - indwrk = 5*n + 1 - minwsize = 12 * n + indlld= 2_${ik}$*n+1 + indin1 = 3_${ik}$*n + 1_${ik}$ + indin2 = 4_${ik}$*n + 1_${ik}$ + indwrk = 5_${ik}$*n + 1_${ik}$ + minwsize = 12_${ik}$ * n do i= 1,minwsize work( i ) = zero end do ! iwork(iindr+1:iindr+n) hold the twist indices r for the ! factorization used to compute the fp vector - iindr = 0 + iindr = 0_${ik}$ ! iwork(iindc1+1:iinc2+n) are used to store the clusters of the current ! layer and the one above. iindc1 = n - iindc2 = 2*n - iindwk = 3*n + 1 - miniwsize = 7 * n + iindc2 = 2_${ik}$*n + iindwk = 3_${ik}$*n + 1_${ik}$ + miniwsize = 7_${ik}$ * n do i= 1,miniwsize - iwork( i ) = 0 + iwork( i ) = 0_${ik}$ end do - zusedl = 1 - if(dol>1) then + zusedl = 1_${ik}$ + if(dol>1_${ik}$) then ! set lower bound for use of z zusedl = dol-1 endif @@ -50525,13 +50516,13 @@ module stdlib_linalg_lapack_${ci}$ zusedu = dou+1 endif ! the width of the part of z that is used - zusedw = zusedu - zusedl + 1 - call stdlib_${ci}$laset( 'FULL', n, zusedw, czero, czero,z(1,zusedl), ldz ) - eps = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + zusedw = zusedu - zusedl + 1_${ik}$ + call stdlib${ii}$_${ci}$laset( 'FULL', n, zusedw, czero, czero,z(1_${ik}$,zusedl), ldz ) + eps = stdlib${ii}$_${c2ri(ci)}$lamch( '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 @@ -50545,54 +50536,54 @@ module stdlib_linalg_lapack_${ci}$ ! 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 + im = wend - wbegin + 1_${ik}$ ! this is for a 1x1 block if( ibegin==iend ) then done = done+1 z( ibegin, wbegin ) = cmplx( one, zero,KIND=${ck}$) - 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) @@ -50601,24 +50592,24 @@ module stdlib_linalg_lapack_${ci}$ ! the eigenvalue approximations will be refined when necessary as ! high relative accuracy is required for the computation of the ! corresponding eigenvectors. - call stdlib_${c2ri(ci)}$copy( im, w( wbegin ), 1,work( wbegin ), 1 ) + call stdlib${ii}$_${c2ri(ci)}$copy( 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 + ndepth = 0_${ik}$ ! parity is either 1 or 0 - parity = 1 + 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 + 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 @@ -50644,30 +50635,30 @@ module stdlib_linalg_lapack_${ci}$ 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 ! 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 do k = 1, in - 1 @@ -50677,7 +50668,7 @@ module stdlib_linalg_lapack_${ci}$ d( iend ) = real( z( iend, j ),KIND=${ck}$) sigma = real( z( iend, j+1 ),KIND=${ck}$) ! set the corresponding entries in z to zero - call stdlib_${ci}$laset( 'FULL', in, 2, czero, czero,z( ibegin, j), ldz ) + call stdlib${ii}$_${ci}$laset( 'FULL', in, 2_${ik}$, czero, czero,z( ibegin, j), ldz ) end if ! compute dl and dll of current rrr @@ -50686,7 +50677,7 @@ module stdlib_linalg_lapack_${ci}$ 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 ) @@ -50694,29 +50685,29 @@ module stdlib_linalg_lapack_${ci}$ ! 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_${c2ri(ci)}$larrb( in, d( ibegin ),work(indlld+ibegin-1),p, q, rtol1, & + call stdlib${ii}$_${c2ri(ci)}$larrb( in, d( ibegin ),work(indlld+ibegin-1),p, q, rtol1, & rtol2, offset,work(wbegin),wgap(wbegin),werr(wbegin),work( indwrk ), iwork(& iindwk ),pivmin, spdiam, in, iinfo ) - if( iinfo/=0 ) then - 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_${c2ri(ci)}$larrb. + ! wbegin-1+oldlst are correctly computed in stdlib${ii}$_${c2ri(ci)}$larrb. ! however, we only allow the gaps to become greater since ! this is what should happen when we decrease werr - if( oldfst>1) then + 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 @@ -50733,7 +50724,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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 @@ -50744,25 +50735,25 @@ module stdlib_linalg_lapack_${ci}$ 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. @@ -50773,7 +50764,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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 ) @@ -50784,13 +50775,13 @@ module stdlib_linalg_lapack_${ci}$ ! 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_${c2ri(ci)}$larrb( in, d(ibegin),work( indlld+ibegin-1 ),p,p,rqtol, & + offset = indexw( wbegin ) - 1_${ik}$ + call stdlib${ii}$_${c2ri(ci)}$larrb( in, d(ibegin),work( indlld+ibegin-1 ),p,p,rqtol, & rqtol, offset,work(wbegin),wgap(wbegin),werr(wbegin),work( indwrk ),& iwork( iindwk ), pivmin, spdiam,in, iinfo ) end do @@ -50801,17 +50792,17 @@ module stdlib_linalg_lapack_${ci}$ ! 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_${c2ri(ci)}$larrf needs lwork = 2*n - call stdlib_${c2ri(ci)}$larrf( in, d( ibegin ), l( ibegin ),work(indld+ibegin-1),& + ! stdlib${ii}$_${c2ri(ci)}$larrf needs lwork = 2*n + call stdlib${ii}$_${c2ri(ci)}$larrf( in, d( ibegin ), l( ibegin ),work(indld+ibegin-1),& newfst, newlst, work(wbegin),wgap(wbegin), werr(wbegin),spdiam, lgap, & rgap, pivmin, tau,work( indin1 ), work( indin2 ),work( indwrk ), iinfo ) - ! in the complex case, stdlib_${c2ri(ci)}$larrf cannot write + ! in the complex case, stdlib${ii}$_${c2ri(ci)}$larrf cannot write ! the new rrr directly into z and needs an intermediate ! workspace do k = 1, in-1 @@ -50821,8 +50812,8 @@ module stdlib_linalg_lapack_${ci}$ end do z( iend, newftt ) =cmplx( work( indin1+in-1 ), zero,KIND=${ck}$) - if( iinfo==0 ) then - ! a new rrr for the cluster was found by stdlib_${c2ri(ci)}$larrf + if( iinfo==0_${ik}$ ) then + ! a new rrr for the cluster was found by stdlib${ii}$_${c2ri(ci)}$larrf ! update shift and store it ssigma = sigma + tau z( iend, newftt+1 ) = cmplx( ssigma, zero,KIND=${ck}$) @@ -50830,10 +50821,10 @@ module stdlib_linalg_lapack_${ci}$ ! 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 @@ -50842,24 +50833,24 @@ module stdlib_linalg_lapack_${ci}$ ! 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=${ck}$)) * 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. @@ -50876,7 +50867,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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 ) @@ -50898,7 +50889,7 @@ module stdlib_linalg_lapack_${ci}$ 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. @@ -50907,7 +50898,7 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -50931,34 +50922,34 @@ module stdlib_linalg_lapack_${ci}$ ! take the bisection as new iterate usedbs = .true. itmp1 = iwork( iindr+windex ) - offset = indexw( wbegin ) - 1 - call stdlib_${c2ri(ci)}$larrb( in, d(ibegin),work(indlld+ibegin-1),indeig,& + offset = indexw( wbegin ) - 1_${ik}$ + call stdlib${ii}$_${c2ri(ci)}$larrb( in, d(ibegin),work(indlld+ibegin-1),indeig,& indeig,zero, two*eps, offset,work(wbegin),wgap(wbegin),werr(wbegin),& work( indwrk ),iwork( iindwk ), pivmin, spdiam,itmp1, iinfo ) - if( iinfo/=0 ) then - 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_${ci}$lar1v( in, 1, in, lambda, d( ibegin ),l( ibegin ), work(& + call stdlib${ii}$_${ci}$lar1v( 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 @@ -51078,25 +51069,25 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$larrv + end subroutine stdlib${ii}$_${ci}$larrv - pure subroutine stdlib_${ci}$lartg( f, g, c, s, r ) + pure subroutine stdlib${ii}$_${ci}$lartg( f, g, c, s, r ) !! ZLARTG: generates a plane rotation so that !! [ C S ] . [ F ] = [ R ] !! [ -conjg(S) C ] [ G ] [ 0 ] @@ -51135,7 +51126,7 @@ module stdlib_linalg_lapack_${ci}$ ! Statement Functions real(${ck}$) :: abssq ! Statement Function Definitions - abssq( t ) = real( t,KIND=${ck}$)**2 + aimag( t )**2 + abssq( t ) = real( t,KIND=${ck}$)**2_${ik}$ + aimag( t )**2_${ik}$ ! Executable Statements if( g == czero ) then c = one @@ -51173,7 +51164,7 @@ module stdlib_linalg_lapack_${ci}$ else d = sqrt( f2 )*sqrt( h2 ) end if - p = 1 / d + p = 1_${ik}$ / d c = f2*p s = conjg( g )*( f*p ) r = f*( h2*p ) @@ -51191,7 +51182,7 @@ module stdlib_linalg_lapack_${ci}$ w = v * uu fs = f*vv f2 = abssq( fs ) - h2 = f2*w**2 + g2 + h2 = f2*w**2_${ik}$ + g2 else ! otherwise use the same scaling for f and g. w = one @@ -51204,17 +51195,17 @@ module stdlib_linalg_lapack_${ci}$ else d = sqrt( f2 )*sqrt( h2 ) end if - p = 1 / d + p = 1_${ik}$ / d c = ( f2*p )*w s = conjg( gs )*( fs*p ) r = ( fs*( h2*p ) )*u end if end if return - end subroutine stdlib_${ci}$lartg + end subroutine stdlib${ii}$_${ci}$lartg - pure subroutine stdlib_${ci}$lartv( n, x, incx, y, incy, c, s, incc ) + pure subroutine stdlib${ii}$_${ci}$lartv( n, x, incx, y, incy, c, s, incc ) !! ZLARTV: applies a vector of complex plane rotations with real cosines !! to elements of the complex vectors x and y. For i = 1,2,...,n !! ( x(i) ) := ( c(i) s(i) ) ( x(i) ) @@ -51223,21 +51214,21 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(${ck}$), intent(in) :: c(*) complex(${ck}$), intent(in) :: s(*) complex(${ck}$), intent(inout) :: x(*), y(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ic, ix, iy + integer(${ik}$) :: i, ic, ix, iy complex(${ck}$) :: xi, yi ! Intrinsic Functions intrinsic :: conjg ! 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 ) @@ -51248,10 +51239,10 @@ module stdlib_linalg_lapack_${ci}$ ic = ic + incc end do return - end subroutine stdlib_${ci}$lartv + end subroutine stdlib${ii}$_${ci}$lartv - pure subroutine stdlib_${ci}$larz( side, m, n, l, v, incv, tau, c, ldc, work ) + pure subroutine stdlib${ii}$_${ci}$larz( side, m, n, l, v, incv, tau, c, ldc, work ) !! ZLARZ: applies a complex elementary reflector H to a complex !! M-by-N matrix C, from either the left or the right. H is represented !! in the form @@ -51266,7 +51257,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(in) :: tau ! Array Arguments complex(${ck}$), intent(inout) :: c(ldc,*) @@ -51279,38 +51270,38 @@ module stdlib_linalg_lapack_${ci}$ ! form h * c if( tau/=czero ) then ! w( 1:n ) = conjg( c( 1, 1:n ) ) - call stdlib_${ci}$copy( n, c, ldc, work, 1 ) - call stdlib_${ci}$lacgv( n, work, 1 ) + call stdlib${ii}$_${ci}$copy( n, c, ldc, work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( n, work, 1_${ik}$ ) ! w( 1:n ) = conjg( w( 1:n ) + c( m-l+1:m, 1:n )**h * v( 1:l ) ) - call stdlib_${ci}$gemv( 'CONJUGATE TRANSPOSE', l, n, cone, c( m-l+1, 1 ),ldc, v, incv,& - cone, work, 1 ) - call stdlib_${ci}$lacgv( n, work, 1 ) + call stdlib${ii}$_${ci}$gemv( 'CONJUGATE TRANSPOSE', l, n, cone, c( m-l+1, 1_${ik}$ ),ldc, v, incv,& + cone, work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacgv( n, work, 1_${ik}$ ) ! c( 1, 1:n ) = c( 1, 1:n ) - tau * w( 1:n ) - call stdlib_${ci}$axpy( n, -tau, work, 1, c, ldc ) + call stdlib${ii}$_${ci}$axpy( n, -tau, work, 1_${ik}$, c, ldc ) ! c( m-l+1:m, 1:n ) = c( m-l+1:m, 1:n ) - ... ! tau * v( 1:l ) * w( 1:n )**h - call stdlib_${ci}$geru( l, n, -tau, v, incv, work, 1, c( m-l+1, 1 ),ldc ) + call stdlib${ii}$_${ci}$geru( l, n, -tau, v, incv, work, 1_${ik}$, c( m-l+1, 1_${ik}$ ),ldc ) end if else ! form c * h if( tau/=czero ) then ! w( 1:m ) = c( 1:m, 1 ) - call stdlib_${ci}$copy( m, c, 1, work, 1 ) + call stdlib${ii}$_${ci}$copy( m, c, 1_${ik}$, work, 1_${ik}$ ) ! w( 1:m ) = w( 1:m ) + c( 1:m, n-l+1:n, 1:n ) * v( 1:l ) - call stdlib_${ci}$gemv( 'NO TRANSPOSE', m, l, cone, c( 1, n-l+1 ), ldc,v, incv, cone, & - work, 1 ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', m, l, cone, c( 1_${ik}$, n-l+1 ), ldc,v, incv, cone, & + work, 1_${ik}$ ) ! c( 1:m, 1 ) = c( 1:m, 1 ) - tau * w( 1:m ) - call stdlib_${ci}$axpy( m, -tau, work, 1, c, 1 ) + call stdlib${ii}$_${ci}$axpy( m, -tau, work, 1_${ik}$, c, 1_${ik}$ ) ! c( 1:m, n-l+1:n ) = c( 1:m, n-l+1:n ) - ... ! tau * w( 1:m ) * v( 1:l )**h - call stdlib_${ci}$gerc( m, l, -tau, work, 1, v, incv, c( 1, n-l+1 ),ldc ) + call stdlib${ii}$_${ci}$gerc( m, l, -tau, work, 1_${ik}$, v, incv, c( 1_${ik}$, n-l+1 ),ldc ) end if end if return - end subroutine stdlib_${ci}$larz + end subroutine stdlib${ii}$_${ci}$larz - pure subroutine stdlib_${ci}$larzb( side, trans, direct, storev, m, n, k, l, v,ldv, t, ldt, c, & + pure subroutine stdlib${ii}$_${ci}$larzb( side, trans, direct, storev, m, n, k, l, v,ldv, t, ldt, c, & !! ZLARZB: applies a complex block reflector H or its transpose H**H !! to a complex distributed M-by-N C from the left or the right. !! Currently, only STOREV = 'R' and DIRECT = 'B' are supported. @@ -51320,7 +51311,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: c(ldc,*), t(ldt,*), v(ldv,*) complex(${ck}$), intent(out) :: work(ldwork,*) @@ -51328,19 +51319,19 @@ module stdlib_linalg_lapack_${ci}$ ! 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( 'ZLARZB', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZLARZB', -info ) return end if if( stdlib_lsame( trans, 'N' ) ) then @@ -51352,14 +51343,14 @@ module stdlib_linalg_lapack_${ci}$ ! form h * c or h**h * c ! w( 1:n, 1:k ) = c( 1:k, 1:n )**h do j = 1, k - call stdlib_${ci}$copy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib${ii}$_${ci}$copy( 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 )**h * v( 1:k, 1:l )**t - if( l>0 )call stdlib_${ci}$gemm( 'TRANSPOSE', 'CONJUGATE TRANSPOSE', n, k, l,cone, c( m-& - l+1, 1 ), ldc, v, ldv, cone, work,ldwork ) + if( l>0_${ik}$ )call stdlib${ii}$_${ci}$gemm( 'TRANSPOSE', 'CONJUGATE TRANSPOSE', n, k, l,cone, c( m-& + l+1, 1_${ik}$ ), ldc, v, ldv, cone, work,ldwork ) ! w( 1:n, 1:k ) = w( 1:n, 1:k ) * t**t or w( 1:m, 1:k ) * t - call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k, cone, t,ldt, work, & + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k, cone, t,ldt, work, & ldwork ) ! c( 1:k, 1:n ) = c( 1:k, 1:n ) - w( 1:n, 1:k )**h do j = 1, n @@ -51369,27 +51360,27 @@ module stdlib_linalg_lapack_${ci}$ end do ! c( m-l+1:m, 1:n ) = c( m-l+1:m, 1:n ) - ... ! v( 1:k, 1:l )**h * w( 1:n, 1:k )**h - if( l>0 )call stdlib_${ci}$gemm( 'TRANSPOSE', 'TRANSPOSE', l, n, k, -cone, v, ldv,work, & - ldwork, cone, c( m-l+1, 1 ), ldc ) + if( l>0_${ik}$ )call stdlib${ii}$_${ci}$gemm( 'TRANSPOSE', 'TRANSPOSE', l, n, k, -cone, v, ldv,work, & + ldwork, cone, c( m-l+1, 1_${ik}$ ), ldc ) else if( stdlib_lsame( side, 'R' ) ) then ! form c * h or c * h**h ! w( 1:m, 1:k ) = c( 1:m, 1:k ) do j = 1, k - call stdlib_${ci}$copy( m, c( 1, j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_${ci}$copy( 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 )**h - if( l>0 )call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, l, cone,c( 1, n-l+1 )& + if( l>0_${ik}$ )call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, l, cone,c( 1_${ik}$, n-l+1 )& , ldc, v, ldv, cone, work, ldwork ) ! w( 1:m, 1:k ) = w( 1:m, 1:k ) * conjg( t ) or ! w( 1:m, 1:k ) * t**h do j = 1, k - call stdlib_${ci}$lacgv( k-j+1, t( j, j ), 1 ) + call stdlib${ii}$_${ci}$lacgv( k-j+1, t( j, j ), 1_${ik}$ ) end do - call stdlib_${ci}$trmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k, cone, t,ldt, work, & + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k, cone, t,ldt, work, & ldwork ) do j = 1, k - call stdlib_${ci}$lacgv( k-j+1, t( j, j ), 1 ) + call stdlib${ii}$_${ci}$lacgv( k-j+1, t( j, j ), 1_${ik}$ ) end do ! c( 1:m, 1:k ) = c( 1:m, 1:k ) - w( 1:m, 1:k ) do j = 1, k @@ -51400,19 +51391,19 @@ module stdlib_linalg_lapack_${ci}$ ! c( 1:m, n-l+1:n ) = c( 1:m, n-l+1:n ) - ... ! w( 1:m, 1:k ) * conjg( v( 1:k, 1:l ) ) do j = 1, l - call stdlib_${ci}$lacgv( k, v( 1, j ), 1 ) + call stdlib${ii}$_${ci}$lacgv( k, v( 1_${ik}$, j ), 1_${ik}$ ) end do - if( l>0 )call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, l, k, -cone,work, & - ldwork, v, ldv, cone, c( 1, n-l+1 ), ldc ) + if( l>0_${ik}$ )call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, l, k, -cone,work, & + ldwork, v, ldv, cone, c( 1_${ik}$, n-l+1 ), ldc ) do j = 1, l - call stdlib_${ci}$lacgv( k, v( 1, j ), 1 ) + call stdlib${ii}$_${ci}$lacgv( k, v( 1_${ik}$, j ), 1_${ik}$ ) end do end if return - end subroutine stdlib_${ci}$larzb + end subroutine stdlib${ii}$_${ci}$larzb - pure subroutine stdlib_${ci}$larzt( direct, storev, n, k, v, ldv, tau, t, ldt ) + pure subroutine stdlib${ii}$_${ci}$larzt( direct, storev, n, k, v, ldv, tau, t, ldt ) !! ZLARZT: forms the triangular factor T of a complex block reflector !! H of order > n, which is defined as a product of k elementary !! reflectors. @@ -51430,7 +51421,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(out) :: t(ldt,*) complex(${ck}$), intent(in) :: tau(*) @@ -51438,17 +51429,17 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! 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( 'ZLARZT', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZLARZT', -info ) return end if do i = k, 1, -1 @@ -51461,22 +51452,22 @@ module stdlib_linalg_lapack_${ci}$ ! general case if( i=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 = -1_${ik}$ + end if + if( itype==-1_${ik}$ ) then + info = -1_${ik}$ + else if( cfrom==zero .or. stdlib${ii}$_${c2ri(ci)}$isnan(cfrom) ) then + info = -4_${ik}$ + else if( stdlib${ii}$_${c2ri(ci)}$isnan(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 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 ax = abs(aimag(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 @@ -52042,12 +52033,12 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -52072,7 +52063,7 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -52083,10 +52074,10 @@ module stdlib_linalg_lapack_${ci}$ sumsq = amed end if return - end subroutine stdlib_${ci}$lassq + end subroutine stdlib${ii}$_${ci}$lassq - pure subroutine stdlib_${ci}$laswlq( m, n, mb, nb, a, lda, t, ldt, work, lwork,info) + pure subroutine stdlib${ii}$_${ci}$laswlq( m, n, mb, nb, a, lda, t, ldt, work, lwork,info) !! ZLASWLQ: computes a blocked Tall-Skinny LQ factorization of !! a complexx M-by-N matrix A for M <= N: !! A = ( L 0 ) * Q, @@ -52101,108 +52092,108 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, mb, nb, lwork, ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, mb, nb, lwork, ldt ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: work(*), t(ldt,*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, ii, kk, ctr + integer(${ik}$) :: i, ii, kk, ctr ! External Subroutines intrinsic :: max,min,mod ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 .or. nm .and. m>0 )) then - info = -3 - else if( nb<=0 ) then - info = -4 - else if( ldam .and. m>0_${ik}$ )) then + info = -3_${ik}$ + else if( nb<=0_${ik}$ ) then + info = -4_${ik}$ + else if( lda=n).or.(nb<=m).or.(nb>=n)) then - call stdlib_${ci}$gelqt( m, n, mb, a, lda, t, ldt, work, info) + call stdlib${ii}$_${ci}$gelqt( m, n, mb, a, lda, t, ldt, work, info) return end if kk = mod((n-m),(nb-m)) ii=n-kk+1 ! compute the lq factorization of the first block a(1:m,1:nb) - call stdlib_${ci}$gelqt( m, nb, mb, a(1,1), lda, t, ldt, work, info) - ctr = 1 + call stdlib${ii}$_${ci}$gelqt( m, nb, mb, a(1_${ik}$,1_${ik}$), lda, t, ldt, work, info) + ctr = 1_${ik}$ do i = nb+1, ii-nb+m , (nb-m) ! compute the qr factorization of the current block a(1:m,i:i+nb-m) - call stdlib_${ci}$tplqt( m, nb-m, 0, mb, a(1,1), lda, a( 1, i ),lda, t(1, ctr * m + 1),& + call stdlib${ii}$_${ci}$tplqt( m, nb-m, 0_${ik}$, mb, a(1_${ik}$,1_${ik}$), lda, a( 1_${ik}$, i ),lda, t(1_${ik}$, ctr * m + 1_${ik}$),& ldt, work, info ) - ctr = ctr + 1 + ctr = ctr + 1_${ik}$ end do ! compute the qr factorization of the last block a(1:m,ii:n) if (ii<=n) then - call stdlib_${ci}$tplqt( m, kk, 0, mb, a(1,1), lda, a( 1, ii ),lda, t(1, ctr * m + 1), & + call stdlib${ii}$_${ci}$tplqt( m, kk, 0_${ik}$, mb, a(1_${ik}$,1_${ik}$), lda, a( 1_${ik}$, ii ),lda, t(1_${ik}$, ctr * m + 1_${ik}$), & ldt,work, info ) end if - work( 1 ) = m * mb + work( 1_${ik}$ ) = m * mb return - end subroutine stdlib_${ci}$laswlq + end subroutine stdlib${ii}$_${ci}$laswlq - pure subroutine stdlib_${ci}$laswp( n, a, lda, k1, k2, ipiv, incx ) + pure subroutine stdlib${ii}$_${ci}$laswp( n, a, lda, k1, k2, ipiv, incx ) !! ZLASWP: performs a series of row interchanges on the matrix A. !! One row interchange is initiated for each of rows K1 through K2 of A. ! -- lapack auxiliary routine -- ! -- 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, k1, k2, lda, n + integer(${ik}$), intent(in) :: incx, k1, k2, lda, n ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) complex(${ck}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, i1, i2, inc, ip, ix, ix0, j, k, n32 + integer(${ik}$) :: i, i1, i2, inc, ip, ix, ix0, j, k, n32 complex(${ck}$) :: temp ! Executable Statements ! interchange row i with row ipiv(k1+(i-k1)*abs(incx)) for each of rows ! k1 through k2. - if( incx>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 @@ -52219,7 +52210,7 @@ module stdlib_linalg_lapack_${ci}$ 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 ) @@ -52234,10 +52225,10 @@ module stdlib_linalg_lapack_${ci}$ end do end if return - end subroutine stdlib_${ci}$laswp + end subroutine stdlib${ii}$_${ci}$laswp - pure subroutine stdlib_${ci}$lasyf( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) + pure subroutine stdlib${ii}$_${ci}$lasyf( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) !! ZLASYF: computes a partial factorization of a complex symmetric matrix !! A using the Bunch-Kaufman diagonal pivoting method. The partial !! factorization has the form: @@ -52256,10 +52247,10 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: w(ldw,*) ! ===================================================================== @@ -52269,7 +52260,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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(${ck}$) :: absakk, alpha, colmax, rowmax complex(${ck}$) :: d11, d21, d22, r1, t, z ! Intrinsic Functions @@ -52279,7 +52270,7 @@ module stdlib_linalg_lapack_${ci}$ ! Statement Function Definitions cabs1( z ) = abs( real( z,KIND=${ck}$) ) + abs( aimag( z ) ) ! 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 @@ -52294,23 +52285,23 @@ module stdlib_linalg_lapack_${ci}$ ! exit from loop if( ( k<=n-nb+1 .and. nb1 ) then - imax = stdlib_i${ci}$amax( k-1, w( 1, kw ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_i${ci}$amax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) colmax = cabs1( w( imax, kw ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k else if( absakk>=alpha*colmax ) then @@ -52318,17 +52309,17 @@ module stdlib_linalg_lapack_${ci}$ kp = k else ! copy column imax to column kw-1 of w and update it - call stdlib_${ci}$copy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) - call stdlib_${ci}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_${ci}$copy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ ) - if( k1 ) then - jmax = stdlib_i${ci}$amax( imax-1, w( 1, kw-1 ), 1 ) + if( imax>1_${ik}$ ) then + jmax = stdlib${ii}$_i${ci}$amax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) rowmax = max( rowmax, cabs1( w( jmax, kw-1 ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then @@ -52339,17 +52330,17 @@ module stdlib_linalg_lapack_${ci}$ ! pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_${ci}$copy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_${ci}$copy( 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 ! 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. @@ -52360,16 +52351,16 @@ module stdlib_linalg_lapack_${ci}$ ! (or k and k-1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = a( kk, kk ) - call stdlib_${ci}$copy( kk-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - if( kp>1 )call stdlib_${ci}$copy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_${ci}$copy( kk-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_${ci}$copy( 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 ! later overwritten). interchange rows kk and kp ! in last kkw to nb columns of w. - if( k2 ) then + if( k>2_${ik}$ ) then ! compose the columns of the inverse of 2-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 @@ -52432,7 +52423,7 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -52449,31 +52440,31 @@ module stdlib_linalg_lapack_${ci}$ jb = min( nb, k-j+1 ) ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_${ci}$gemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& - kw+1 ), ldw, cone,a( j, jj ), 1 ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& + kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ ) end do ! update the rectangular superdiagonal block - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( 1, k+1 ), & - lda, w( j, kw+1 ), ldw,cone, a( 1, j ), lda ) + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( 1_${ik}$, k+1 ), & + lda, w( j, kw+1 ), ldw,cone, a( 1_${ik}$, j ), lda ) end do ! put u12 in standard form by partially undoing the interchanges ! in columns k+1:n 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_${ci}$swap( n-j+1, a( jp, j ), lda, a( jj, j ), & + j = j + 1_${ik}$ + if( jp/=jj .and. j<=n )call stdlib${ii}$_${ci}$swap( 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_${ci}$copy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) - call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ), lda,w( k, 1 ), ldw,& - cone, w( k, k ), 1 ) - kstep = 1 + call stdlib${ii}$_${ci}$copy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ), lda,w( k, 1_${ik}$ ), ldw,& + cone, w( k, k ), 1_${ik}$ ) + 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 absakk = cabs1( w( k, k ) ) ! imax is the row-index of the largest off-diagonal element in if( k=alpha*colmax ) then @@ -52512,16 +52503,16 @@ module stdlib_linalg_lapack_${ci}$ kp = k else ! copy column imax to column k+1 of w and update it - call stdlib_${ci}$copy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1 ) - call stdlib_${ci}$copy( n-imax+1, a( imax, imax ), 1, w( imax, k+1 ),1 ) - call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ),lda, w( imax, & - 1 ), ldw, cone, w( k, k+1 ),1 ) + call stdlib${ii}$_${ci}$copy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$copy( n-imax+1, a( imax, imax ), 1_${ik}$, w( imax, k+1 ),1_${ik}$ ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ),lda, w( imax, & + 1_${ik}$ ), ldw, cone, w( k, k+1 ),1_${ik}$ ) ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value - jmax = k - 1 + stdlib_i${ci}$amax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1_${ik}$ + stdlib${ii}$_i${ci}$amax( imax-k, w( k, k+1 ), 1_${ik}$ ) rowmax = cabs1( w( jmax, k+1 ) ) if( imax=alpha*colmax*( colmax / rowmax ) ) then @@ -52532,17 +52523,17 @@ module stdlib_linalg_lapack_${ci}$ ! pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_${ci}$copy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_${ci}$copy( 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 ! 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 @@ -52551,17 +52542,17 @@ module stdlib_linalg_lapack_${ci}$ ! (or k and k+1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = a( kk, kk ) - call stdlib_${ci}$copy( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),lda ) - if( kp1 )call stdlib_${ci}$swap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_${ci}$swap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + if( k>1_${ik}$ )call stdlib${ii}$_${ci}$swap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) + call stdlib${ii}$_${ci}$swap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of w now holds ! w(k) = l(k)*d(k), ! where l(k) is the k-th column of l @@ -52571,10 +52562,10 @@ module stdlib_linalg_lapack_${ci}$ ! 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_${ci}$copy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib${ii}$_${ci}$copy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ ) if( k=1 )call stdlib_${ci}$swap( j, a( jp, 1 ), lda, a( jj, 1 ), lda ) + j = j - 1_${ik}$ + if( jp/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_${ci}$swap( 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_${ci}$lasyf + end subroutine stdlib${ii}$_${ci}$lasyf - pure subroutine stdlib_${ci}$lasyf_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) + pure subroutine stdlib${ii}$_${ci}$lasyf_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) !! DLATRF_AA factorizes a panel of a complex symmetric matrix A using !! the Aasen's algorithm. The panel consists of a set of NB rows of A !! when UPLO is U, or a set of NB columns when UPLO is L. @@ -52693,23 +52684,23 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: m, nb, j1, lda, ldh + integer(${ik}$), intent(in) :: m, nb, j1, lda, ldh ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(${ck}$), intent(inout) :: a(lda,*), h(ldh,*) complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: j, k, k1, i1, i2, mj + integer(${ik}$) :: j, k, k1, i1, i2, mj complex(${ck}$) :: piv, alpha ! Intrinsic Functions intrinsic :: max ! Executable Statements - j = 1 + j = 1_${ik}$ ! k1 is the first column of the panel to be factorized ! i.e., k1 is 2 for the first block column, and 1 for the rest of the blocks - k1 = (2-j1)+1 + k1 = (2_${ik}$-j1)+1_${ik}$ if( stdlib_lsame( uplo, 'U' ) ) then ! ..................................................... ! factorize a as u**t*d*u using the upper triangle of a @@ -52717,96 +52708,96 @@ module stdlib_linalg_lapack_${ci}$ 10 continue if ( j>min(m, nb) )go to 20 ! k is the column to be factorized - ! when being called from stdlib_${ci}$sytrf_aa, + ! when being called from stdlib${ii}$_${ci}$sytrf_aa, ! > for the first block column, j1 is 1, hence j1+j-1 is j, ! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1, k = j1+j-1 if( j==m ) then ! only need to compute t(j, j) - mj = 1 + mj = 1_${ik}$ else mj = m-j+1 end if ! h(j:m, j) := a(j, j:m) - h(j:m, 1:(j-1)) * l(j1:(j-1), j), ! where h(j:m, j) has been initialized to be a(j, j:m) - if( k>2 ) then + if( k>2_${ik}$ ) then ! k is the column to be factorized ! > for the first block column, k is j, skipping the first two ! columns ! > for the rest of the columns, k is j+1, skipping only the ! first column - call stdlib_${ci}$gemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( 1, j ), 1,& - cone, h( j, j ), 1 ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( 1_${ik}$, j ), 1_${ik}$,& + cone, h( j, j ), 1_${ik}$ ) end if ! copy h(i:m, i) into work - call stdlib_${ci}$copy( mj, h( j, j ), 1, work( 1 ), 1 ) + call stdlib${ii}$_${ci}$copy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) if( j>k1 ) then ! compute work := work - l(j-1, j:m) * t(j-1,j), ! where a(j-1, j) stores t(j-1, j) and a(j-2, j:m) stores u(j-1, j:m) alpha = -a( k-1, j ) - call stdlib_${ci}$axpy( mj, alpha, a( k-2, j ), lda, work( 1 ), 1 ) + call stdlib${ii}$_${ci}$axpy( mj, alpha, a( k-2, j ), lda, work( 1_${ik}$ ), 1_${ik}$ ) end if ! set a(j, j) = t(j, j) - a( k, j ) = work( 1 ) + a( k, j ) = work( 1_${ik}$ ) if( j1 ) then + if( k>1_${ik}$ ) then alpha = -a( k, j ) - call stdlib_${ci}$axpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2 ), 1 ) + call stdlib${ii}$_${ci}$axpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2_${ik}$ ), 1_${ik}$ ) endif ! find max(|work(2:m)|) - i2 = stdlib_i${ci}$amax( m-j, work( 2 ), 1 ) + 1 + i2 = stdlib${ii}$_i${ci}$amax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$ piv = work( i2 ) ! apply symmetric pivot - if( (i2/=2) .and. (piv/=0) ) then + if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then ! swap work(i1) and work(i2) - i1 = 2 + i1 = 2_${ik}$ work( i2 ) = work( i1 ) work( i1 ) = piv ! swap a(i1, i1+1:m) with a(i1+1:m, i2) i1 = i1+j-1 i2 = i2+j-1 - call stdlib_${ci}$swap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1 ) + call stdlib${ii}$_${ci}$swap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1_${ik}$ ) ! swap a(i1, i2+1:m) with a(i2, i2+1:m) - if( i2(k1-1) ) then ! swap l(1:i1-1, i1) with l(1:i1-1, i2), ! skipping the first column - call stdlib_${ci}$swap( i1-k1+1, a( 1, i1 ), 1,a( 1, i2 ), 1 ) + call stdlib${ii}$_${ci}$swap( i1-k1+1, a( 1_${ik}$, i1 ), 1_${ik}$,a( 1_${ik}$, i2 ), 1_${ik}$ ) end if else ipiv( j+1 ) = j+1 endif ! set a(j, j+1) = t(j, j+1) - a( k, j+1 ) = work( 2 ) + a( k, j+1 ) = work( 2_${ik}$ ) if( jmin( m, nb ) )go to 40 ! k is the column to be factorized - ! when being called from stdlib_${ci}$sytrf_aa, + ! when being called from stdlib${ii}$_${ci}$sytrf_aa, ! > for the first block column, j1 is 1, hence j1+j-1 is j, ! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1, k = j1+j-1 if( j==m ) then ! only need to compute t(j, j) - mj = 1 + mj = 1_${ik}$ else mj = m-j+1 end if ! h(j:m, j) := a(j:m, j) - h(j:m, 1:(j-1)) * l(j, j1:(j-1))^t, ! where h(j:m, j) has been initialized to be a(j:m, j) - if( k>2 ) then + if( k>2_${ik}$ ) then ! k is the column to be factorized ! > for the first block column, k is j, skipping the first two ! columns ! > for the rest of the columns, k is j+1, skipping only the ! first column - call stdlib_${ci}$gemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( j, 1 ), & - lda,cone, h( j, j ), 1 ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( j, 1_${ik}$ ), & + lda,cone, h( j, j ), 1_${ik}$ ) end if ! copy h(j:m, j) into work - call stdlib_${ci}$copy( mj, h( j, j ), 1, work( 1 ), 1 ) + call stdlib${ii}$_${ci}$copy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) if( j>k1 ) then ! compute work := work - l(j:m, j-1) * t(j-1,j), ! where a(j-1, j) = t(j-1, j) and a(j, j-2) = l(j, j-1) alpha = -a( j, k-1 ) - call stdlib_${ci}$axpy( mj, alpha, a( j, k-2 ), 1, work( 1 ), 1 ) + call stdlib${ii}$_${ci}$axpy( mj, alpha, a( j, k-2 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) end if ! set a(j, j) = t(j, j) - a( j, k ) = work( 1 ) + a( j, k ) = work( 1_${ik}$ ) if( j1 ) then + if( k>1_${ik}$ ) then alpha = -a( j, k ) - call stdlib_${ci}$axpy( m-j, alpha, a( j+1, k-1 ), 1,work( 2 ), 1 ) + call stdlib${ii}$_${ci}$axpy( m-j, alpha, a( j+1, k-1 ), 1_${ik}$,work( 2_${ik}$ ), 1_${ik}$ ) endif ! find max(|work(2:m)|) - i2 = stdlib_i${ci}$amax( m-j, work( 2 ), 1 ) + 1 + i2 = stdlib${ii}$_i${ci}$amax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$ piv = work( i2 ) ! apply symmetric pivot - if( (i2/=2) .and. (piv/=0) ) then + if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then ! swap work(i1) and work(i2) - i1 = 2 + i1 = 2_${ik}$ work( i2 ) = work( i1 ) work( i1 ) = piv ! swap a(i1+1:m, i1) with a(i2, i1+1:m) i1 = i1+j-1 i2 = i2+j-1 - call stdlib_${ci}$swap( i2-i1-1, a( i1+1, j1+i1-1 ), 1,a( i2, j1+i1 ), lda ) + call stdlib${ii}$_${ci}$swap( i2-i1-1, a( i1+1, j1+i1-1 ), 1_${ik}$,a( i2, j1+i1 ), lda ) ! swap a(i2+1:m, i1) with a(i2+1:m, i2) - if( i2(k1-1) ) then ! swap l(1:i1-1, i1) with l(1:i1-1, i2), ! skipping the first column - call stdlib_${ci}$swap( i1-k1+1, a( i1, 1 ), lda,a( i2, 1 ), lda ) + call stdlib${ii}$_${ci}$swap( i1-k1+1, a( i1, 1_${ik}$ ), lda,a( i2, 1_${ik}$ ), lda ) end if else ipiv( j+1 ) = j+1 endif ! set a(j+1, j) = t(j+1, j) - a( j+1, k ) = work( 2 ) + a( j+1, k ) = work( 2_${ik}$ ) if( j1 ) then - imax = stdlib_i${ci}$amax( k-1, w( 1, kw ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_i${ci}$amax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) colmax = cabs1( w( imax, kw ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k - call stdlib_${ci}$copy( k, w( 1, kw ), 1, a( 1, k ), 1 ) + call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) ! set e( k ) to zero - if( k>1 )e( k ) = czero + if( k>1_${ik}$ )e( k ) = czero else ! ============================================================ ! test for interchange @@ -53013,22 +53004,22 @@ module stdlib_linalg_lapack_${ci}$ 12 continue ! begin pivot search loop body ! copy column imax to column kw-1 of w and update it - call stdlib_${ci}$copy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) - call stdlib_${ci}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_${ci}$copy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ ) - if( k1 ) then - itemp = stdlib_i${ci}$amax( imax-1, w( 1, kw-1 ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_i${ci}$amax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) dtemp = cabs1( w( itemp, kw-1 ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -53043,7 +53034,7 @@ module stdlib_linalg_lapack_${ci}$ ! use 1-by-1 pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_${ci}$copy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -53051,7 +53042,7 @@ module stdlib_linalg_lapack_${ci}$ ! interchange rows and columns k-1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found: set params and repeat @@ -53059,45 +53050,45 @@ module stdlib_linalg_lapack_${ci}$ colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_${ci}$copy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) end if ! end pivot search loop body if( .not. done ) goto 12 end if ! ============================================================ - kk = k - kstep + 1 + kk = k - kstep + 1_${ik}$ ! kkw is the column of w which corresponds to column kk of a kkw = nb + kk - n - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_${ci}$copy( k-p, a( p+1, k ), 1, a( p, p+1 ), lda ) - call stdlib_${ci}$copy( p, a( 1, k ), 1, a( 1, p ), 1 ) + call stdlib${ii}$_${ci}$copy( k-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ), lda ) + call stdlib${ii}$_${ci}$copy( p, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) ! interchange rows k and p in last n-k+1 columns of a ! and last n-k+2 columns of w - call stdlib_${ci}$swap( n-k+1, a( k, k ), lda, a( p, k ), lda ) - call stdlib_${ci}$swap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw ) + call stdlib${ii}$_${ci}$swap( n-k+1, a( k, k ), lda, a( p, k ), lda ) + call stdlib${ii}$_${ci}$swap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw ) end if ! updated column kp is already stored in column kkw of w if( kp/=kk ) then ! copy non-updated column kk to column kp a( kp, k ) = a( kk, k ) - call stdlib_${ci}$copy( k-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - call stdlib_${ci}$copy( kp, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_${ci}$copy( k-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) + call stdlib${ii}$_${ci}$copy( kp, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) ! interchange rows kk and kp in last n-kk+1 columns ! of a and w - call stdlib_${ci}$swap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) - call stdlib_${ci}$swap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) + call stdlib${ii}$_${ci}$swap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) + call stdlib${ii}$_${ci}$swap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column kw of w now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u ! store u(k) in column k of a - call stdlib_${ci}$copy( k, w( 1, kw ), 1, a( 1, k ), 1 ) - if( k>1 ) then + call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) + if( k>1_${ik}$ ) then if( cabs1( a( k, k ) )>=sfmin ) then r1 = cone / a( k, k ) - call stdlib_${ci}$scal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_${ci}$scal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) else if( a( k, k )/=czero ) then do ii = 1, k - 1 a( ii, k ) = a( ii, k ) / a( k, k ) @@ -53112,7 +53103,7 @@ module stdlib_linalg_lapack_${ci}$ ! ( 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 @@ -53135,7 +53126,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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 @@ -53152,12 +53143,12 @@ module stdlib_linalg_lapack_${ci}$ jb = min( nb, k-j+1 ) ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_${ci}$gemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& - kw+1 ), ldw, cone,a( j, jj ), 1 ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& + kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ ) end do ! update the rectangular superdiagonal block - if( j>=2 )call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -cone, a( & - 1, k+1 ), lda, w( j, kw+1 ),ldw, cone, a( 1, j ), lda ) + if( j>=2_${ik}$ )call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -cone, a( & + 1_${ik}$, k+1 ), lda, w( j, kw+1 ),ldw, cone, a( 1_${ik}$, j ), lda ) end do ! set kb to the number of columns factorized kb = n - k @@ -53168,16 +53159,16 @@ module stdlib_linalg_lapack_${ci}$ ! initialize the unused last entry of the subdiagonal array e. e( n ) = czero ! k is the main loop index, increasing from 1 in steps of 1 or 2 - k = 1 + 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_${ci}$copy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) - if( k>1 )call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ),lda, w( k, & - 1 ), ldw, cone, w( k, k ), 1 ) + call stdlib${ii}$_${ci}$copy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ ) + if( k>1_${ik}$ )call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ),lda, w( k, & + 1_${ik}$ ), ldw, cone, w( k, k ), 1_${ik}$ ) ! determine rows and columns to be interchanged and whether ! a 1-by-1 or 2-by-2 pivot block will be used absakk = cabs1( w( k, k ) ) @@ -53185,16 +53176,16 @@ module stdlib_linalg_lapack_${ci}$ ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k1 )call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1 ), & - lda, w( imax, 1 ), ldw,cone, w( k, k+1 ), 1 ) + call stdlib${ii}$_${ci}$copy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$) + call stdlib${ii}$_${ci}$copy( n-imax+1, a( imax, imax ), 1_${ik}$,w( imax, k+1 ), 1_${ik}$ ) + if( k>1_${ik}$ )call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1_${ik}$ ), & + lda, w( imax, 1_${ik}$ ), ldw,cone, w( k, k+1 ), 1_${ik}$ ) ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = k - 1 + stdlib_i${ci}$amax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1_${ik}$ + stdlib${ii}$_i${ci}$amax( imax-k, w( k, k+1 ), 1_${ik}$ ) rowmax = cabs1( w( jmax, k+1 ) ) else rowmax = zero end if if( imaxrowmax ) then rowmax = dtemp @@ -53240,7 +53231,7 @@ module stdlib_linalg_lapack_${ci}$ ! use 1-by-1 pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_${ci}$copy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_${ci}$copy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -53248,7 +53239,7 @@ module stdlib_linalg_lapack_${ci}$ ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found: set params and repeat @@ -53256,42 +53247,42 @@ module stdlib_linalg_lapack_${ci}$ colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_${ci}$copy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_${ci}$copy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) end if ! end pivot search loop body if( .not. done ) goto 72 end if ! ============================================================ - kk = k + kstep - 1 - if( ( kstep==2 ) .and. ( p/=k ) ) then + kk = k + kstep - 1_${ik}$ + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_${ci}$copy( p-k, a( k, k ), 1, a( p, k ), lda ) - call stdlib_${ci}$copy( n-p+1, a( p, k ), 1, a( p, p ), 1 ) + call stdlib${ii}$_${ci}$copy( p-k, a( k, k ), 1_${ik}$, a( p, k ), lda ) + call stdlib${ii}$_${ci}$copy( n-p+1, a( p, k ), 1_${ik}$, a( p, p ), 1_${ik}$ ) ! interchange rows k and p in first k columns of a ! and first k+1 columns of w - call stdlib_${ci}$swap( k, a( k, 1 ), lda, a( p, 1 ), lda ) - call stdlib_${ci}$swap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw ) + call stdlib${ii}$_${ci}$swap( k, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda ) + call stdlib${ii}$_${ci}$swap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw ) end if ! updated column kp is already stored in column kk of w if( kp/=kk ) then ! copy non-updated column kk to column kp a( kp, k ) = a( kk, k ) - call stdlib_${ci}$copy( kp-k-1, a( k+1, kk ), 1, a( kp, k+1 ), lda ) - call stdlib_${ci}$copy( n-kp+1, a( kp, kk ), 1, a( kp, kp ), 1 ) + call stdlib${ii}$_${ci}$copy( kp-k-1, a( k+1, kk ), 1_${ik}$, a( kp, k+1 ), lda ) + call stdlib${ii}$_${ci}$copy( n-kp+1, a( kp, kk ), 1_${ik}$, a( kp, kp ), 1_${ik}$ ) ! interchange rows kk and kp in first kk columns of a and w - call stdlib_${ci}$swap( kk, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_${ci}$swap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + call stdlib${ii}$_${ci}$swap( kk, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) + call stdlib${ii}$_${ci}$swap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of w now holds ! w(k) = l(k)*d(k) ! where l(k) is the k-th column of l ! store l(k) in column k of a - call stdlib_${ci}$copy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib${ii}$_${ci}$copy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ ) if( k=sfmin ) then r1 = cone / a( k, k ) - call stdlib_${ci}$scal( n-k, r1, a( k+1, k ), 1 ) + call stdlib${ii}$_${ci}$scal( n-k, r1, a( k+1, k ), 1_${ik}$ ) else if( a( k, k )/=czero ) then do ii = k + 1, n a( ii, k ) = a( ii, k ) / a( k, k ) @@ -53328,7 +53319,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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 @@ -53345,21 +53336,21 @@ module stdlib_linalg_lapack_${ci}$ jb = min( nb, n-j+1 ) ! update the lower triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_${ci}$gemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1 ), lda, w( jj,& - 1 ), ldw, cone,a( jj, jj ), 1 ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1_${ik}$ ), lda, w( jj,& + 1_${ik}$ ), ldw, cone,a( jj, jj ), 1_${ik}$ ) end do ! update the rectangular subdiagonal block - if( j+jb<=n )call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& - cone, a( j+jb, 1 ), lda, w( j, 1 ),ldw, cone, a( j+jb, j ), lda ) + if( j+jb<=n )call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& + cone, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ),ldw, cone, a( j+jb, j ), lda ) end do ! set kb to the number of columns factorized - kb = k - 1 + kb = k - 1_${ik}$ end if return - end subroutine stdlib_${ci}$lasyf_rk + end subroutine stdlib${ii}$_${ci}$lasyf_rk - pure subroutine stdlib_${ci}$lasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) + pure subroutine stdlib${ii}$_${ci}$lasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) !! ZLASYF_ROOK: computes a partial factorization of a complex symmetric !! matrix A using the bounded Bunch-Kaufman ("rook") diagonal !! pivoting method. The partial factorization has the form: @@ -53377,10 +53368,10 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: w(ldw,*) ! ===================================================================== @@ -53391,7 +53382,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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(${ck}$) :: absakk, alpha, colmax, rowmax, dtemp, sfmin complex(${ck}$) :: d11, d12, d21, d22, r1, t, z @@ -53402,11 +53393,11 @@ module stdlib_linalg_lapack_${ci}$ ! Statement Function Definitions cabs1( z ) = abs( real( z,KIND=${ck}$) ) + abs( aimag( z ) ) ! 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_${c2ri(ci)}$lamch( 'S' ) + sfmin = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' ) if( stdlib_lsame( uplo, 'U' ) ) then ! factorize the trailing columns of a using the upper triangle ! of a and working backwards, and compute the matrix w = u12*d @@ -53418,29 +53409,29 @@ module stdlib_linalg_lapack_${ci}$ kw = nb + k - n ! exit from loop if( ( k<=n-nb+1 .and. nb1 ) then - imax = stdlib_i${ci}$amax( k-1, w( 1, kw ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_i${ci}$amax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) colmax = cabs1( w( imax, kw ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k - call stdlib_${ci}$copy( k, w( 1, kw ), 1, a( 1, k ), 1 ) + call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) else ! ============================================================ ! test for interchange @@ -53455,22 +53446,22 @@ module stdlib_linalg_lapack_${ci}$ 12 continue ! begin pivot search loop body ! copy column imax to column kw-1 of w and update it - call stdlib_${ci}$copy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) - call stdlib_${ci}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_${ci}$copy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$copy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ ) - if( k1 ) then - itemp = stdlib_i${ci}$amax( imax-1, w( 1, kw-1 ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_i${ci}$amax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) dtemp = cabs1( w( itemp, kw-1 ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -53485,7 +53476,7 @@ module stdlib_linalg_lapack_${ci}$ ! use 1-by-1 pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_${ci}$copy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -53493,7 +53484,7 @@ module stdlib_linalg_lapack_${ci}$ ! interchange rows and columns k-1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found: set params and repeat @@ -53501,45 +53492,45 @@ module stdlib_linalg_lapack_${ci}$ colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_${ci}$copy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) end if ! end pivot search loop body if( .not. done ) goto 12 end if ! ============================================================ - kk = k - kstep + 1 + kk = k - kstep + 1_${ik}$ ! kkw is the column of w which corresponds to column kk of a kkw = nb + kk - n - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_${ci}$copy( k-p, a( p+1, k ), 1, a( p, p+1 ), lda ) - call stdlib_${ci}$copy( p, a( 1, k ), 1, a( 1, p ), 1 ) + call stdlib${ii}$_${ci}$copy( k-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ), lda ) + call stdlib${ii}$_${ci}$copy( p, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) ! interchange rows k and p in last n-k+1 columns of a ! and last n-k+2 columns of w - call stdlib_${ci}$swap( n-k+1, a( k, k ), lda, a( p, k ), lda ) - call stdlib_${ci}$swap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw ) + call stdlib${ii}$_${ci}$swap( n-k+1, a( k, k ), lda, a( p, k ), lda ) + call stdlib${ii}$_${ci}$swap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw ) end if ! updated column kp is already stored in column kkw of w if( kp/=kk ) then ! copy non-updated column kk to column kp a( kp, k ) = a( kk, k ) - call stdlib_${ci}$copy( k-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - call stdlib_${ci}$copy( kp, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_${ci}$copy( k-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) + call stdlib${ii}$_${ci}$copy( kp, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) ! interchange rows kk and kp in last n-kk+1 columns ! of a and w - call stdlib_${ci}$swap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) - call stdlib_${ci}$swap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) + call stdlib${ii}$_${ci}$swap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) + call stdlib${ii}$_${ci}$swap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column kw of w now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u ! store u(k) in column k of a - call stdlib_${ci}$copy( k, w( 1, kw ), 1, a( 1, k ), 1 ) - if( k>1 ) then + call stdlib${ii}$_${ci}$copy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) + if( k>1_${ik}$ ) then if( cabs1( a( k, k ) )>=sfmin ) then r1 = cone / a( k, k ) - call stdlib_${ci}$scal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_${ci}$scal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) else if( a( k, k )/=czero ) then do ii = 1, k - 1 a( ii, k ) = a( ii, k ) / a( k, k ) @@ -53552,7 +53543,7 @@ module stdlib_linalg_lapack_${ci}$ ! ( 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 @@ -53570,7 +53561,7 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -53587,32 +53578,32 @@ module stdlib_linalg_lapack_${ci}$ jb = min( nb, k-j+1 ) ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_${ci}$gemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& - kw+1 ), ldw, cone,a( j, jj ), 1 ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& + kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ ) end do ! update the rectangular superdiagonal block - if( j>=2 )call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -cone, a( & - 1, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1, j ), lda ) + if( j>=2_${ik}$ )call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -cone, a( & + 1_${ik}$, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1_${ik}$, j ), lda ) end do ! put u12 in standard form by partially undoing the interchanges ! in columns k+1:n - j = k + 1 + 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_${ci}$swap( n-j+1, a( jp2, j ), lda, a( jj, j ), & + j = j + 1_${ik}$ + if( jp2/=jj .and. j<=n )call stdlib${ii}$_${ci}$swap( n-j+1, a( jp2, j ), lda, a( jj, j ), & lda ) - jj = j - 1 - if( jp1/=jj .and. kstep==2 )call stdlib_${ci}$swap( n-j+1, a( jp1, j ), lda, a( jj, j & + jj = j - 1_${ik}$ + if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_${ci}$swap( n-j+1, a( jp1, j ), lda, a( jj, j & ), lda ) if( j<=n )go to 60 ! set kb to the number of columns factorized @@ -53622,16 +53613,16 @@ module stdlib_linalg_lapack_${ci}$ ! 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 = 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_${ci}$copy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) - if( k>1 )call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ),lda, w( k, & - 1 ), ldw, cone, w( k, k ), 1 ) + call stdlib${ii}$_${ci}$copy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ ) + if( k>1_${ik}$ )call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ),lda, w( k, & + 1_${ik}$ ), ldw, cone, w( k, k ), 1_${ik}$ ) ! determine rows and columns to be interchanged and whether ! a 1-by-1 or 2-by-2 pivot block will be used absakk = cabs1( w( k, k ) ) @@ -53639,16 +53630,16 @@ module stdlib_linalg_lapack_${ci}$ ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k1 )call stdlib_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1 ), & - lda, w( imax, 1 ), ldw,cone, w( k, k+1 ), 1 ) + call stdlib${ii}$_${ci}$copy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$) + call stdlib${ii}$_${ci}$copy( n-imax+1, a( imax, imax ), 1_${ik}$,w( imax, k+1 ), 1_${ik}$ ) + if( k>1_${ik}$ )call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1_${ik}$ ), & + lda, w( imax, 1_${ik}$ ), ldw,cone, w( k, k+1 ), 1_${ik}$ ) ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = k - 1 + stdlib_i${ci}$amax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1_${ik}$ + stdlib${ii}$_i${ci}$amax( imax-k, w( k, k+1 ), 1_${ik}$ ) rowmax = cabs1( w( jmax, k+1 ) ) else rowmax = zero end if if( imaxrowmax ) then rowmax = dtemp @@ -53692,7 +53683,7 @@ module stdlib_linalg_lapack_${ci}$ ! use 1-by-1 pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_${ci}$copy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_${ci}$copy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -53700,7 +53691,7 @@ module stdlib_linalg_lapack_${ci}$ ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found: set params and repeat @@ -53708,42 +53699,42 @@ module stdlib_linalg_lapack_${ci}$ colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_${ci}$copy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_${ci}$copy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) end if ! end pivot search loop body if( .not. done ) goto 72 end if ! ============================================================ - kk = k + kstep - 1 - if( ( kstep==2 ) .and. ( p/=k ) ) then + kk = k + kstep - 1_${ik}$ + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_${ci}$copy( p-k, a( k, k ), 1, a( p, k ), lda ) - call stdlib_${ci}$copy( n-p+1, a( p, k ), 1, a( p, p ), 1 ) + call stdlib${ii}$_${ci}$copy( p-k, a( k, k ), 1_${ik}$, a( p, k ), lda ) + call stdlib${ii}$_${ci}$copy( n-p+1, a( p, k ), 1_${ik}$, a( p, p ), 1_${ik}$ ) ! interchange rows k and p in first k columns of a ! and first k+1 columns of w - call stdlib_${ci}$swap( k, a( k, 1 ), lda, a( p, 1 ), lda ) - call stdlib_${ci}$swap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw ) + call stdlib${ii}$_${ci}$swap( k, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda ) + call stdlib${ii}$_${ci}$swap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw ) end if ! updated column kp is already stored in column kk of w if( kp/=kk ) then ! copy non-updated column kk to column kp a( kp, k ) = a( kk, k ) - call stdlib_${ci}$copy( kp-k-1, a( k+1, kk ), 1, a( kp, k+1 ), lda ) - call stdlib_${ci}$copy( n-kp+1, a( kp, kk ), 1, a( kp, kp ), 1 ) + call stdlib${ii}$_${ci}$copy( kp-k-1, a( k+1, kk ), 1_${ik}$, a( kp, k+1 ), lda ) + call stdlib${ii}$_${ci}$copy( n-kp+1, a( kp, kk ), 1_${ik}$, a( kp, kp ), 1_${ik}$ ) ! interchange rows kk and kp in first kk columns of a and w - call stdlib_${ci}$swap( kk, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_${ci}$swap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + call stdlib${ii}$_${ci}$swap( kk, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) + call stdlib${ii}$_${ci}$swap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of w now holds ! w(k) = l(k)*d(k) ! where l(k) is the k-th column of l ! store l(k) in column k of a - call stdlib_${ci}$copy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib${ii}$_${ci}$copy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ ) if( k=sfmin ) then r1 = cone / a( k, k ) - call stdlib_${ci}$scal( n-k, r1, a( k+1, k ), 1 ) + call stdlib${ii}$_${ci}$scal( n-k, r1, a( k+1, k ), 1_${ik}$ ) else if( a( k, k )/=czero ) then do ii = k + 1, n a( ii, k ) = a( ii, k ) / a( k, k ) @@ -53773,7 +53764,7 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -53790,42 +53781,42 @@ module stdlib_linalg_lapack_${ci}$ jb = min( nb, n-j+1 ) ! update the lower triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_${ci}$gemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1 ), lda, w( jj,& - 1 ), ldw, cone,a( jj, jj ), 1 ) + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1_${ik}$ ), lda, w( jj,& + 1_${ik}$ ), ldw, cone,a( jj, jj ), 1_${ik}$ ) end do ! update the rectangular subdiagonal block - if( j+jb<=n )call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& - cone, a( j+jb, 1 ), lda, w( j, 1 ), ldw,cone, a( j+jb, j ), lda ) + if( j+jb<=n )call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& + cone, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ), ldw,cone, a( j+jb, j ), lda ) end do ! put l21 in standard form by partially undoing the interchanges ! in columns 1:k-1 - j = k - 1 + 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_${ci}$swap( j, a( jp2, 1 ), lda, a( jj, 1 ), lda ) + j = j - 1_${ik}$ + if( jp2/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_${ci}$swap( j, a( jp2, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda ) - jj = j + 1 - if( jp1/=jj .and. kstep==2 )call stdlib_${ci}$swap( j, a( jp1, 1 ), lda, a( jj, 1 ), & + jj = j + 1_${ik}$ + if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_${ci}$swap( j, a( jp1, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), & lda ) if( j>=1 )go to 120 ! set kb to the number of columns factorized - kb = k - 1 + kb = k - 1_${ik}$ end if return - end subroutine stdlib_${ci}$lasyf_rook + end subroutine stdlib${ii}$_${ci}$lasyf_rook - pure subroutine stdlib_${ci}$lat2c( uplo, n, a, lda, sa, ldsa, info ) + pure subroutine stdlib${ii}$_${ci}$lat2c( uplo, n, a, lda, sa, ldsa, info ) !! ZLAT2C: converts a COMPLEX*16 triangular matrix, SA, to a COMPLEX !! triangular matrix, A. !! RMAX is the overflow for the SINGLE PRECISION arithmetic @@ -53837,20 +53828,20 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, ldsa, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldsa, n ! Array Arguments complex(dp), intent(out) :: sa(ldsa,*) complex(${ck}$), intent(in) :: a(lda,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(${ck}$) :: rmax logical(lk) :: upper ! Intrinsic Functions intrinsic :: real,aimag ! Executable Statements - rmax = stdlib_dlamch( 'O' ) + rmax = stdlib${ii}$_dlamch( 'O' ) upper = stdlib_lsame( uplo, 'U' ) if( upper ) then do j = 1, n @@ -53858,7 +53849,7 @@ module stdlib_linalg_lapack_${ci}$ if( ( real( a( i, j ),KIND=${ck}$)<-rmax ) .or.( real( a( i, j ),KIND=${ck}$)>rmax ) & .or.( aimag( a( i, j ) )<-rmax ) .or.( aimag( a( i, j ) )>rmax ) ) & then - info = 1 + info = 1_${ik}$ go to 50 end if sa( i, j ) = a( i, j ) @@ -53870,7 +53861,7 @@ module stdlib_linalg_lapack_${ci}$ if( ( real( a( i, j ),KIND=${ck}$)<-rmax ) .or.( real( a( i, j ),KIND=${ck}$)>rmax ) & .or.( aimag( a( i, j ) )<-rmax ) .or.( aimag( a( i, j ) )>rmax ) ) & then - info = 1 + info = 1_${ik}$ go to 50 end if sa( i, j ) = a( i, j ) @@ -53879,10 +53870,10 @@ module stdlib_linalg_lapack_${ci}$ end if 50 continue return - end subroutine stdlib_${ci}$lat2c + end subroutine stdlib${ii}$_${ci}$lat2c - pure subroutine stdlib_${ci}$latbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm, & + pure subroutine stdlib${ii}$_${ci}$latbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm, & !! ZLATBS: solves one of the triangular systems !! A * x = s*b, A**T * x = s*b, or A**H * x = s*b, !! with scaling to prevent overflow, where A is an upper or lower @@ -53899,8 +53890,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(${ck}$), intent(out) :: scale ! Array Arguments real(${ck}$), intent(inout) :: cnorm(*) @@ -53910,7 +53901,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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(${ck}$) :: bignum, grow, rec, smlnum, tjj, tmax, tscal, xbnd, xj, xmax complex(${ck}$) :: csumj, tjjs, uscal, zdum ! Intrinsic Functions @@ -53922,39 +53913,39 @@ module stdlib_linalg_lapack_${ci}$ cabs2( zdum ) = abs( real( zdum,KIND=${ck}$) / 2._${ck}$ ) +abs( aimag( zdum ) / 2._${ck}$ ) ! 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_${c2ri(ci)}$zasum( jlen, ab( 2, j ), 1 ) + if( jlen>0_${ik}$ ) then + cnorm( j ) = stdlib${ii}$_${c2ri(ci)}$zasum( jlen, ab( 2_${ik}$, j ), 1_${ik}$ ) else cnorm( j ) = zero end if @@ -53979,16 +53970,16 @@ module stdlib_linalg_lapack_${ci}$ end if ! scale the column norms by tscal if the maximum element in cnorm is ! greater than bignum/2. - imax = stdlib_i${c2ri(ci)}$amax( n, cnorm, 1 ) + imax = stdlib${ii}$_i${c2ri(ci)}$amax( n, cnorm, 1_${ik}$ ) tmax = cnorm( imax ) if( tmax<=bignum*half ) then tscal = one else tscal = half / ( smlnum*tmax ) - call stdlib_${c2ri(ci)}$scal( n, tscal, cnorm, 1 ) + call stdlib${ii}$_${c2ri(ci)}$scal( n, tscal, cnorm, 1_${ik}$ ) end if ! compute a bound on the computed solution vector to see if the - ! level 2 blas routine stdlib_${ci}$tbsv can be used. + ! level 2 blas routine stdlib${ii}$_${ci}$tbsv can be used. xmax = zero do j = 1, n xmax = max( xmax, cabs2( x( j ) ) ) @@ -53998,14 +53989,14 @@ module stdlib_linalg_lapack_${ci}$ ! 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 @@ -54053,15 +54044,15 @@ module stdlib_linalg_lapack_${ci}$ else ! compute the growth in a**t * x = b or a**h * 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 @@ -54107,14 +54098,14 @@ module stdlib_linalg_lapack_${ci}$ if( ( grow*tscal )>smlnum ) then ! use the level 2 blas solve if the reciprocal of the bound on ! elements of x is not too small. - call stdlib_${ci}$tbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1 ) + call stdlib${ii}$_${ci}$tbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1_${ik}$ ) else ! use a level 1 blas solve, scaling intermediate results. if( xmax>bignum*half ) then ! scale x so that its components are less than or equal to ! bignum in absolute value. scale = ( bignum*half ) / xmax - call stdlib_${ci}$dscal( n, scale, x, 1 ) + call stdlib${ii}$_${ci}$dscal( n, scale, x, 1_${ik}$ ) xmax = bignum else xmax = xmax*two @@ -54137,12 +54128,12 @@ module stdlib_linalg_lapack_${ci}$ if( xj>tjj*bignum ) then ! scale x by 1/b(j). rec = one / xj - call stdlib_${ci}$dscal( n, rec, x, 1 ) + call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) xj = cabs1( x( j ) ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: @@ -54155,11 +54146,11 @@ module stdlib_linalg_lapack_${ci}$ ! multiplying x(j) times column j. rec = rec / cnorm( j ) end if - call stdlib_${ci}$dscal( n, rec, x, 1 ) + call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) xj = cabs1( x( j ) ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and @@ -54180,23 +54171,23 @@ module stdlib_linalg_lapack_${ci}$ if( cnorm( j )>( bignum-xmax )*rec ) then ! scale x by 1/(2*abs(x(j))). rec = rec*half - call stdlib_${ci}$dscal( n, rec, x, 1 ) + call stdlib${ii}$_${ci}$dscal( 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_${ci}$dscal( n, half, x, 1 ) + call stdlib${ii}$_${ci}$dscal( 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) jlen = min( kd, j-1 ) - call stdlib_${ci}$axpy( jlen, -x( j )*tscal,ab( kd+1-jlen, j ), 1, x( j-jlen & - ), 1 ) - i = stdlib_i${ci}$amax( j-1, x, 1 ) + call stdlib${ii}$_${ci}$axpy( jlen, -x( j )*tscal,ab( kd+1-jlen, j ), 1_${ik}$, x( j-jlen & + ), 1_${ik}$ ) + i = stdlib${ii}$_i${ci}$amax( j-1, x, 1_${ik}$ ) xmax = cabs1( x( i ) ) end if else if( j0 )call stdlib_${ci}$axpy( jlen, -x( j )*tscal, ab( 2, j ), 1,x( j+1 ),& - 1 ) - i = j + stdlib_i${ci}$amax( n-j, x( j+1 ), 1 ) + if( jlen>0_${ik}$ )call stdlib${ii}$_${ci}$axpy( jlen, -x( j )*tscal, ab( 2_${ik}$, j ), 1_${ik}$,x( j+1 ),& + 1_${ik}$ ) + i = j + stdlib${ii}$_i${ci}$amax( n-j, x( j+1 ), 1_${ik}$ ) xmax = cabs1( x( i ) ) end if end do loop_120 @@ -54230,10 +54221,10 @@ module stdlib_linalg_lapack_${ci}$ if( tjj>one ) then ! divide by a(j,j) when scaling x if a(j,j) > 1. rec = min( one, rec*tjj ) - uscal = stdlib_${ci}$ladiv( uscal, tjjs ) + uscal = stdlib${ii}$_${ci}$ladiv( uscal, tjjs ) end if if( rec1 )csumj = stdlib_${ci}$dotu( jlen, ab( 2, j ), 1, x( j+1 ),1 ) + if( jlen>1_${ik}$ )csumj = stdlib${ii}$_${ci}$dotu( jlen, ab( 2_${ik}$, j ), 1_${ik}$, x( j+1 ),1_${ik}$ ) end if else @@ -54284,22 +54275,22 @@ module stdlib_linalg_lapack_${ci}$ if( xj>tjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_${ci}$dscal( n, rec, x, 1 ) + call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_${ci}$dscal( n, rec, x, 1 ) + call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and ! scale = 0 and compute a solution to a**t *x = 0. @@ -54314,7 +54305,7 @@ module stdlib_linalg_lapack_${ci}$ else ! compute x(j) := x(j) / a(j,j) - csumj if the dot ! product has already been divided by 1/a(j,j). - x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) - csumj + x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) - csumj end if xmax = max( xmax, cabs1( x( j ) ) ) end do loop_170 @@ -54338,10 +54329,10 @@ module stdlib_linalg_lapack_${ci}$ if( tjj>one ) then ! divide by a(j,j) when scaling x if a(j,j) > 1. rec = min( one, rec*tjj ) - uscal = stdlib_${ci}$ladiv( uscal, tjjs ) + uscal = stdlib${ii}$_${ci}$ladiv( uscal, tjjs ) end if if( rec1 )csumj = stdlib_${ci}$dotc( jlen, ab( 2, j ), 1, x( j+1 ),1 ) + if( jlen>1_${ik}$ )csumj = stdlib${ii}$_${ci}$dotc( jlen, ab( 2_${ik}$, j ), 1_${ik}$, x( j+1 ),1_${ik}$ ) end if else @@ -54393,22 +54384,22 @@ module stdlib_linalg_lapack_${ci}$ if( xj>tjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_${ci}$dscal( n, rec, x, 1 ) + call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_${ci}$dscal( n, rec, x, 1 ) + call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and ! scale = 0 and compute a solution to a**h *x = 0. @@ -54423,7 +54414,7 @@ module stdlib_linalg_lapack_${ci}$ else ! compute x(j) := x(j) / a(j,j) - csumj if the dot ! product has already been divided by 1/a(j,j). - x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) - csumj + x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) - csumj end if xmax = max( xmax, cabs1( x( j ) ) ) end do loop_220 @@ -54432,13 +54423,13 @@ module stdlib_linalg_lapack_${ci}$ end if ! scale the column norms by 1/tscal for return. if( tscal/=one ) then - call stdlib_${c2ri(ci)}$scal( n, one / tscal, cnorm, 1 ) + call stdlib${ii}$_${c2ri(ci)}$scal( n, one / tscal, cnorm, 1_${ik}$ ) end if return - end subroutine stdlib_${ci}$latbs + end subroutine stdlib${ii}$_${ci}$latbs - pure subroutine stdlib_${ci}$latdf( ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv,jpiv ) + pure subroutine stdlib${ii}$_${ci}$latdf( ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv,jpiv ) !! ZLATDF: computes the contribution to the reciprocal Dif-estimate !! by solving for x in Z * x = b, where b is chosen such that the norm !! of x is as large as possible. It is assumed that LU decomposition @@ -54451,30 +54442,30 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: ijob, ldz, n + integer(${ik}$), intent(in) :: ijob, ldz, n real(${ck}$), intent(inout) :: rdscal, rdsum ! Array Arguments - integer(ilp), intent(in) :: ipiv(*), jpiv(*) + integer(${ik}$), intent(in) :: ipiv(*), jpiv(*) complex(${ck}$), intent(inout) :: rhs(*), z(ldz,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: maxdim = 2 + integer(${ik}$), parameter :: maxdim = 2_${ik}$ ! Local Scalars - integer(ilp) :: i, info, j, k + integer(${ik}$) :: i, info, j, k real(${ck}$) :: rtemp, scale, sminu, splus complex(${ck}$) :: bm, bp, pmone, temp ! Local Arrays real(${ck}$) :: rwork(maxdim) - complex(${ck}$) :: work(4*maxdim), xm(maxdim), xp(maxdim) + complex(${ck}$) :: work(4_${ik}$*maxdim), xm(maxdim), xp(maxdim) ! Intrinsic Functions intrinsic :: abs,real,sqrt ! Executable Statements - if( ijob/=2 ) then + if( ijob/=2_${ik}$ ) then ! apply permutations ipiv to rhs - call stdlib_${ci}$laswp( 1, rhs, ldz, 1, n-1, ipiv, 1 ) + call stdlib${ii}$_${ci}$laswp( 1_${ik}$, rhs, ldz, 1_${ik}$, n-1, ipiv, 1_${ik}$ ) ! solve for l-part choosing rhs either to +1 or -1. pmone = -cone loop_10: do j = 1, n - 1 @@ -54483,9 +54474,9 @@ module stdlib_linalg_lapack_${ci}$ splus = one ! lockahead for l- part rhs(1:n-1) = +-1 ! splus and smin computed more efficiently than in bsolve[1]. - splus = splus + real( stdlib_${ci}$dotc( n-j, z( j+1, j ), 1, z( j+1,j ), 1 ),KIND=${ck}$) + splus = splus + real( stdlib${ii}$_${ci}$dotc( n-j, z( j+1, j ), 1_${ik}$, z( j+1,j ), 1_${ik}$ ),KIND=${ck}$) - sminu = real( stdlib_${ci}$dotc( n-j, z( j+1, j ), 1, rhs( j+1 ), 1 ),KIND=${ck}$) + sminu = real( stdlib${ii}$_${ci}$dotc( n-j, z( j+1, j ), 1_${ik}$, rhs( j+1 ), 1_${ik}$ ),KIND=${ck}$) splus = splus*real( rhs( j ),KIND=${ck}$) if( splus>sminu ) then rhs( j ) = bp @@ -54502,13 +54493,13 @@ module stdlib_linalg_lapack_${ci}$ end if ! compute the remaining r.h.s. temp = -rhs( j ) - call stdlib_${ci}$axpy( n-j, temp, z( j+1, j ), 1, rhs( j+1 ), 1 ) + call stdlib${ii}$_${ci}$axpy( n-j, temp, z( j+1, j ), 1_${ik}$, rhs( j+1 ), 1_${ik}$ ) end do loop_10 ! solve for u- part, lockahead for rhs(n) = +-1. this is not done ! in bsolve and will hopefully give us a better estimate because ! any ill-conditioning of the original matrix is transferred to u ! and not to l. u(n, n) is an approximation to sigma_min(lu). - call stdlib_${ci}$copy( n-1, rhs, 1, work, 1 ) + call stdlib${ii}$_${ci}$copy( n-1, rhs, 1_${ik}$, work, 1_${ik}$ ) work( n ) = rhs( n ) + cone rhs( n ) = rhs( n ) - cone splus = zero @@ -54524,35 +54515,35 @@ module stdlib_linalg_lapack_${ci}$ splus = splus + abs( work( i ) ) sminu = sminu + abs( rhs( i ) ) end do - if( splus>sminu )call stdlib_${ci}$copy( n, work, 1, rhs, 1 ) + if( splus>sminu )call stdlib${ii}$_${ci}$copy( n, work, 1_${ik}$, rhs, 1_${ik}$ ) ! apply the permutations jpiv to the computed solution (rhs) - call stdlib_${ci}$laswp( 1, rhs, ldz, 1, n-1, jpiv, -1 ) + call stdlib${ii}$_${ci}$laswp( 1_${ik}$, rhs, ldz, 1_${ik}$, n-1, jpiv, -1_${ik}$ ) ! compute the sum of squares - call stdlib_${ci}$lassq( n, rhs, 1, rdscal, rdsum ) + call stdlib${ii}$_${ci}$lassq( n, rhs, 1_${ik}$, rdscal, rdsum ) return end if ! entry ijob = 2 ! compute approximate nullvector xm of z - call stdlib_${ci}$gecon( 'I', n, z, ldz, one, rtemp, work, rwork, info ) - call stdlib_${ci}$copy( n, work( n+1 ), 1, xm, 1 ) + call stdlib${ii}$_${ci}$gecon( 'I', n, z, ldz, one, rtemp, work, rwork, info ) + call stdlib${ii}$_${ci}$copy( n, work( n+1 ), 1_${ik}$, xm, 1_${ik}$ ) ! compute rhs - call stdlib_${ci}$laswp( 1, xm, ldz, 1, n-1, ipiv, -1 ) - temp = cone / sqrt( stdlib_${ci}$dotc( n, xm, 1, xm, 1 ) ) - call stdlib_${ci}$scal( n, temp, xm, 1 ) - call stdlib_${ci}$copy( n, xm, 1, xp, 1 ) - call stdlib_${ci}$axpy( n, cone, rhs, 1, xp, 1 ) - call stdlib_${ci}$axpy( n, -cone, xm, 1, rhs, 1 ) - call stdlib_${ci}$gesc2( n, z, ldz, rhs, ipiv, jpiv, scale ) - call stdlib_${ci}$gesc2( n, z, ldz, xp, ipiv, jpiv, scale ) - if( stdlib_${c2ri(ci)}$zasum( n, xp, 1 )>stdlib_${c2ri(ci)}$zasum( n, rhs, 1 ) )call stdlib_${ci}$copy( n, xp, 1, & - rhs, 1 ) + call stdlib${ii}$_${ci}$laswp( 1_${ik}$, xm, ldz, 1_${ik}$, n-1, ipiv, -1_${ik}$ ) + temp = cone / sqrt( stdlib${ii}$_${ci}$dotc( n, xm, 1_${ik}$, xm, 1_${ik}$ ) ) + call stdlib${ii}$_${ci}$scal( n, temp, xm, 1_${ik}$ ) + call stdlib${ii}$_${ci}$copy( n, xm, 1_${ik}$, xp, 1_${ik}$ ) + call stdlib${ii}$_${ci}$axpy( n, cone, rhs, 1_${ik}$, xp, 1_${ik}$ ) + call stdlib${ii}$_${ci}$axpy( n, -cone, xm, 1_${ik}$, rhs, 1_${ik}$ ) + call stdlib${ii}$_${ci}$gesc2( n, z, ldz, rhs, ipiv, jpiv, scale ) + call stdlib${ii}$_${ci}$gesc2( n, z, ldz, xp, ipiv, jpiv, scale ) + if( stdlib${ii}$_${c2ri(ci)}$zasum( n, xp, 1_${ik}$ )>stdlib${ii}$_${c2ri(ci)}$zasum( n, rhs, 1_${ik}$ ) )call stdlib${ii}$_${ci}$copy( n, xp, 1_${ik}$, & + rhs, 1_${ik}$ ) ! compute the sum of squares - call stdlib_${ci}$lassq( n, rhs, 1, rdscal, rdsum ) + call stdlib${ii}$_${ci}$lassq( n, rhs, 1_${ik}$, rdscal, rdsum ) return - end subroutine stdlib_${ci}$latdf + end subroutine stdlib${ii}$_${ci}$latdf - pure subroutine stdlib_${ci}$latps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info ) + pure subroutine stdlib${ii}$_${ci}$latps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info ) !! ZLATPS: solves one of the triangular systems !! A * x = s*b, A**T * x = s*b, or A**H * x = s*b, !! with scaling to prevent overflow, where A is an upper or lower @@ -54570,8 +54561,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(${ck}$), intent(out) :: scale ! Array Arguments real(${ck}$), intent(inout) :: cnorm(*) @@ -54581,7 +54572,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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(${ck}$) :: bignum, grow, rec, smlnum, tjj, tmax, tscal, xbnd, xj, xmax complex(${ck}$) :: csumj, tjjs, uscal, zdum ! Intrinsic Functions @@ -54593,68 +54584,68 @@ module stdlib_linalg_lapack_${ci}$ cabs2( zdum ) = abs( real( zdum,KIND=${ck}$) / 2._${ck}$ ) +abs( aimag( zdum ) / 2._${ck}$ ) ! 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( 'ZLATPS', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZLATPS', -info ) return end if ! quick return if possible if( n==0 )return ! determine machine dependent parameters to control overflow. - smlnum = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) bignum = one / smlnum - call stdlib_${c2ri(ci)}$labad( smlnum, bignum ) - smlnum = smlnum / stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + call stdlib${ii}$_${c2ri(ci)}$labad( smlnum, bignum ) + smlnum = smlnum / stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' ) bignum = one / smlnum scale = one if( stdlib_lsame( normin, 'N' ) ) then ! compute the 1-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_${c2ri(ci)}$zasum( j-1, ap( ip ), 1 ) + cnorm( j ) = stdlib${ii}$_${c2ri(ci)}$zasum( 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_${c2ri(ci)}$zasum( n-j, ap( ip+1 ), 1 ) - ip = ip + n - j + 1 + cnorm( j ) = stdlib${ii}$_${c2ri(ci)}$zasum( 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/2. - imax = stdlib_i${c2ri(ci)}$amax( n, cnorm, 1 ) + imax = stdlib${ii}$_i${c2ri(ci)}$amax( n, cnorm, 1_${ik}$ ) tmax = cnorm( imax ) if( tmax<=bignum*half ) then tscal = one else tscal = half / ( smlnum*tmax ) - call stdlib_${c2ri(ci)}$scal( n, tscal, cnorm, 1 ) + call stdlib${ii}$_${c2ri(ci)}$scal( n, tscal, cnorm, 1_${ik}$ ) end if ! compute a bound on the computed solution vector to see if the - ! level 2 blas routine stdlib_${ci}$tpsv can be used. + ! level 2 blas routine stdlib${ii}$_${ci}$tpsv can be used. xmax = zero do j = 1, n xmax = max( xmax, cabs2( x( j ) ) ) @@ -54664,12 +54655,12 @@ module stdlib_linalg_lapack_${ci}$ ! 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 @@ -54681,7 +54672,7 @@ module stdlib_linalg_lapack_${ci}$ ! initially, g(0) = max{x(i), i=1,...,n}. grow = half / 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. @@ -54703,7 +54694,7 @@ module stdlib_linalg_lapack_${ci}$ grow = zero end if ip = ip + jinc*jlen - jlen = jlen - 1 + jlen = jlen - 1_${ik}$ end do grow = xbnd else @@ -54721,13 +54712,13 @@ module stdlib_linalg_lapack_${ci}$ else ! compute the growth in a**t * x = b or a**h * 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 @@ -54739,8 +54730,8 @@ module stdlib_linalg_lapack_${ci}$ ! initially, m(0) = max{x(i), i=1,...,n}. grow = half / 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 90 @@ -54756,7 +54747,7 @@ module stdlib_linalg_lapack_${ci}$ ! m(j) could overflow, set xbnd to 0. xbnd = zero end if - jlen = jlen + 1 + jlen = jlen + 1_${ik}$ ip = ip + jinc*jlen end do grow = min( grow, xbnd ) @@ -54777,21 +54768,21 @@ module stdlib_linalg_lapack_${ci}$ if( ( grow*tscal )>smlnum ) then ! use the level 2 blas solve if the reciprocal of the bound on ! elements of x is not too small. - call stdlib_${ci}$tpsv( uplo, trans, diag, n, ap, x, 1 ) + call stdlib${ii}$_${ci}$tpsv( uplo, trans, diag, n, ap, x, 1_${ik}$ ) else ! use a level 1 blas solve, scaling intermediate results. if( xmax>bignum*half ) then ! scale x so that its components are less than or equal to ! bignum in absolute value. scale = ( bignum*half ) / xmax - call stdlib_${ci}$dscal( n, scale, x, 1 ) + call stdlib${ii}$_${ci}$dscal( n, scale, x, 1_${ik}$ ) xmax = bignum else xmax = xmax*two end if if( notran ) then ! solve a * x = b - ip = jfirst*( jfirst+1 ) / 2 + ip = jfirst*( jfirst+1 ) / 2_${ik}$ loop_120: do j = jfirst, jlast, jinc ! compute x(j) = b(j) / a(j,j), scaling x if necessary. xj = cabs1( x( j ) ) @@ -54808,12 +54799,12 @@ module stdlib_linalg_lapack_${ci}$ if( xj>tjj*bignum ) then ! scale x by 1/b(j). rec = one / xj - call stdlib_${ci}$dscal( n, rec, x, 1 ) + call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) xj = cabs1( x( j ) ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: @@ -54826,11 +54817,11 @@ module stdlib_linalg_lapack_${ci}$ ! multiplying x(j) times column j. rec = rec / cnorm( j ) end if - call stdlib_${ci}$dscal( n, rec, x, 1 ) + call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) xj = cabs1( x( j ) ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and @@ -54851,20 +54842,20 @@ module stdlib_linalg_lapack_${ci}$ if( cnorm( j )>( bignum-xmax )*rec ) then ! scale x by 1/(2*abs(x(j))). rec = rec*half - call stdlib_${ci}$dscal( n, rec, x, 1 ) + call stdlib${ii}$_${ci}$dscal( 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_${ci}$dscal( n, half, x, 1 ) + call stdlib${ii}$_${ci}$dscal( 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_${ci}$axpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1, x,1 ) - i = stdlib_i${ci}$amax( j-1, x, 1 ) + call stdlib${ii}$_${ci}$axpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1_${ik}$, x,1_${ik}$ ) + i = stdlib${ii}$_i${ci}$amax( j-1, x, 1_${ik}$ ) xmax = cabs1( x( i ) ) end if ip = ip - j @@ -54872,18 +54863,18 @@ module stdlib_linalg_lapack_${ci}$ if( jj @@ -54902,10 +54893,10 @@ module stdlib_linalg_lapack_${ci}$ if( tjj>one ) then ! divide by a(j,j) when scaling x if a(j,j) > 1. rec = min( one, rec*tjj ) - uscal = stdlib_${ci}$ladiv( uscal, tjjs ) + uscal = stdlib${ii}$_${ci}$ladiv( uscal, tjjs ) end if if( rectjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_${ci}$dscal( n, rec, x, 1 ) + call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_${ci}$dscal( n, rec, x, 1 ) + call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and ! scale = 0 and compute a solution to a**t *x = 0. @@ -54980,16 +54971,16 @@ module stdlib_linalg_lapack_${ci}$ else ! compute x(j) := x(j) / a(j,j) - csumj if the dot ! product has already been divided by 1/a(j,j). - x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) - csumj + x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) - csumj end if xmax = max( xmax, cabs1( x( j ) ) ) - jlen = jlen + 1 + jlen = jlen + 1_${ik}$ ip = ip + jinc*jlen end do loop_170 else ! solve a**h * x = b - ip = jfirst*( jfirst+1 ) / 2 - jlen = 1 + ip = jfirst*( jfirst+1 ) / 2_${ik}$ + jlen = 1_${ik}$ loop_220: do j = jfirst, jlast, jinc ! compute x(j) = b(j) - sum a(k,j)*x(k). ! k<>j @@ -55008,10 +54999,10 @@ module stdlib_linalg_lapack_${ci}$ if( tjj>one ) then ! divide by a(j,j) when scaling x if a(j,j) > 1. rec = min( one, rec*tjj ) - uscal = stdlib_${ci}$ladiv( uscal, tjjs ) + uscal = stdlib${ii}$_${ci}$ladiv( uscal, tjjs ) end if if( rectjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_${ci}$dscal( n, rec, x, 1 ) + call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_${ci}$dscal( n, rec, x, 1 ) + call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and ! scale = 0 and compute a solution to a**h *x = 0. @@ -55086,10 +55077,10 @@ module stdlib_linalg_lapack_${ci}$ else ! compute x(j) := x(j) / a(j,j) - csumj if the dot ! product has already been divided by 1/a(j,j). - x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) - csumj + x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) - csumj end if xmax = max( xmax, cabs1( x( j ) ) ) - jlen = jlen + 1 + jlen = jlen + 1_${ik}$ ip = ip + jinc*jlen end do loop_220 end if @@ -55097,13 +55088,13 @@ module stdlib_linalg_lapack_${ci}$ end if ! scale the column norms by 1/tscal for return. if( tscal/=one ) then - call stdlib_${c2ri(ci)}$scal( n, one / tscal, cnorm, 1 ) + call stdlib${ii}$_${c2ri(ci)}$scal( n, one / tscal, cnorm, 1_${ik}$ ) end if return - end subroutine stdlib_${ci}$latps + end subroutine stdlib${ii}$_${ci}$latps - pure subroutine stdlib_${ci}$latrd( uplo, n, nb, a, lda, e, tau, w, ldw ) + pure subroutine stdlib${ii}$_${ci}$latrd( uplo, n, nb, a, lda, e, tau, w, ldw ) !! ZLATRD: reduces NB rows and columns of a complex Hermitian matrix A to !! Hermitian tridiagonal form by a unitary similarity !! transformation Q**H * A * Q, and returns the matrices V and W which are @@ -55118,7 +55109,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: lda, ldw, n, nb + integer(${ik}$), intent(in) :: lda, ldw, n, nb ! Array Arguments real(${ck}$), intent(out) :: e(*) complex(${ck}$), intent(inout) :: a(lda,*) @@ -55126,7 +55117,7 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! Local Scalars - integer(ilp) :: i, iw + integer(${ik}$) :: i, iw complex(${ck}$) :: alpha ! Intrinsic Functions intrinsic :: real,min @@ -55140,40 +55131,40 @@ module stdlib_linalg_lapack_${ci}$ if( i1 ) then + if( i>1_${ik}$ ) then ! generate elementary reflector h(i) to annihilate ! a(1:i-2,i) alpha = a( i-1, i ) - call stdlib_${ci}$larfg( i-1, alpha, a( 1, i ), 1, tau( i-1 ) ) + call stdlib${ii}$_${ci}$larfg( i-1, alpha, a( 1_${ik}$, i ), 1_${ik}$, tau( i-1 ) ) e( i-1 ) = real( alpha,KIND=${ck}$) a( i-1, i ) = cone ! compute w(1:i-1,i) - call stdlib_${ci}$hemv( 'UPPER', i-1, cone, a, lda, a( 1, i ), 1,czero, w( 1, iw ),& - 1 ) + call stdlib${ii}$_${ci}$hemv( 'UPPER', i-1, cone, a, lda, a( 1_${ik}$, i ), 1_${ik}$,czero, w( 1_${ik}$, iw ),& + 1_${ik}$ ) if( ismlnum ) then ! use the level 2 blas solve if the reciprocal of the bound on ! elements of x is not too small. - call stdlib_${ci}$trsv( uplo, trans, diag, n, a, lda, x, 1 ) + call stdlib${ii}$_${ci}$trsv( uplo, trans, diag, n, a, lda, x, 1_${ik}$ ) else ! use a level 1 blas solve, scaling intermediate results. if( xmax>bignum*half ) then ! scale x so that its components are less than or equal to ! bignum in absolute value. scale = ( bignum*half ) / xmax - call stdlib_${ci}$dscal( n, scale, x, 1 ) + call stdlib${ii}$_${ci}$dscal( n, scale, x, 1_${ik}$ ) xmax = bignum else xmax = xmax*two @@ -55463,12 +55454,12 @@ module stdlib_linalg_lapack_${ci}$ if( xj>tjj*bignum ) then ! scale x by 1/b(j). rec = one / xj - call stdlib_${ci}$dscal( n, rec, x, 1 ) + call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) xj = cabs1( x( j ) ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: @@ -55481,11 +55472,11 @@ module stdlib_linalg_lapack_${ci}$ ! multiplying x(j) times column j. rec = rec / cnorm( j ) end if - call stdlib_${ci}$dscal( n, rec, x, 1 ) + call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) xj = cabs1( x( j ) ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and @@ -55506,29 +55497,29 @@ module stdlib_linalg_lapack_${ci}$ if( cnorm( j )>( bignum-xmax )*rec ) then ! scale x by 1/(2*abs(x(j))). rec = rec*half - call stdlib_${ci}$dscal( n, rec, x, 1 ) + call stdlib${ii}$_${ci}$dscal( 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_${ci}$dscal( n, half, x, 1 ) + call stdlib${ii}$_${ci}$dscal( 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_${ci}$axpy( j-1, -x( j )*tscal, a( 1, j ), 1, x,1 ) - i = stdlib_i${ci}$amax( j-1, x, 1 ) + call stdlib${ii}$_${ci}$axpy( j-1, -x( j )*tscal, a( 1_${ik}$, j ), 1_${ik}$, x,1_${ik}$ ) + i = stdlib${ii}$_i${ci}$amax( j-1, x, 1_${ik}$ ) xmax = cabs1( x( i ) ) end if else if( jone ) then ! divide by a(j,j) when scaling x if a(j,j) > 1. rec = min( one, rec*tjj ) - uscal = stdlib_${ci}$ladiv( uscal, tjjs ) + uscal = stdlib${ii}$_${ci}$ladiv( uscal, tjjs ) end if if( rectjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_${ci}$dscal( n, rec, x, 1 ) + call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_${ci}$dscal( n, rec, x, 1 ) + call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and ! scale = 0 and compute a solution to a**t *x = 0. @@ -55631,7 +55622,7 @@ module stdlib_linalg_lapack_${ci}$ else ! compute x(j) := x(j) / a(j,j) - csumj if the dot ! product has already been divided by 1/a(j,j). - x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) - csumj + x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) - csumj end if xmax = max( xmax, cabs1( x( j ) ) ) end do loop_170 @@ -55655,10 +55646,10 @@ module stdlib_linalg_lapack_${ci}$ if( tjj>one ) then ! divide by a(j,j) when scaling x if a(j,j) > 1. rec = min( one, rec*tjj ) - uscal = stdlib_${ci}$ladiv( uscal, tjjs ) + uscal = stdlib${ii}$_${ci}$ladiv( uscal, tjjs ) end if if( rectjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_${ci}$dscal( n, rec, x, 1 ) + call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_${ci}$dscal( n, rec, x, 1 ) + call stdlib${ii}$_${ci}$dscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and ! scale = 0 and compute a solution to a**h *x = 0. @@ -55733,7 +55724,7 @@ module stdlib_linalg_lapack_${ci}$ else ! compute x(j) := x(j) / a(j,j) - csumj if the dot ! product has already been divided by 1/a(j,j). - x( j ) = stdlib_${ci}$ladiv( x( j ), tjjs ) - csumj + x( j ) = stdlib${ii}$_${ci}$ladiv( x( j ), tjjs ) - csumj end if xmax = max( xmax, cabs1( x( j ) ) ) end do loop_220 @@ -55742,13 +55733,13 @@ module stdlib_linalg_lapack_${ci}$ end if ! scale the column norms by 1/tscal for return. if( tscal/=one ) then - call stdlib_${c2ri(ci)}$scal( n, one / tscal, cnorm, 1 ) + call stdlib${ii}$_${c2ri(ci)}$scal( n, one / tscal, cnorm, 1_${ik}$ ) end if return - end subroutine stdlib_${ci}$latrs + end subroutine stdlib${ii}$_${ci}$latrs - pure subroutine stdlib_${ci}$latrz( m, n, l, a, lda, tau, work ) + pure subroutine stdlib${ii}$_${ci}$latrz( m, n, l, a, lda, tau, work ) !! ZLATRZ: factors the M-by-(M+L) complex upper trapezoidal matrix !! [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z by means !! of unitary transformations, where Z is an (M+L)-by-(M+L) unitary @@ -55757,20 +55748,20 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: l, lda, m, n + integer(${ik}$), intent(in) :: l, lda, m, n ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i complex(${ck}$) :: alpha ! Intrinsic Functions intrinsic :: conjg ! Executable Statements ! quick return if possible - if( m==0 ) then + if( m==0_${ik}$ ) then return else if( m==n ) then do i = 1, n @@ -55781,20 +55772,20 @@ module stdlib_linalg_lapack_${ci}$ do i = m, 1, -1 ! generate elementary reflector h(i) to annihilate ! [ a(i,i) a(i,n-l+1:n) ] - call stdlib_${ci}$lacgv( l, a( i, n-l+1 ), lda ) + call stdlib${ii}$_${ci}$lacgv( l, a( i, n-l+1 ), lda ) alpha = conjg( a( i, i ) ) - call stdlib_${ci}$larfg( l+1, alpha, a( i, n-l+1 ), lda, tau( i ) ) + call stdlib${ii}$_${ci}$larfg( l+1, alpha, a( i, n-l+1 ), lda, tau( i ) ) tau( i ) = conjg( tau( i ) ) ! apply h(i) to a(1:i-1,i:n) from the right - call stdlib_${ci}$larz( 'RIGHT', i-1, n-i+1, l, a( i, n-l+1 ), lda,conjg( tau( i ) ), a( & - 1, i ), lda, work ) + call stdlib${ii}$_${ci}$larz( 'RIGHT', i-1, n-i+1, l, a( i, n-l+1 ), lda,conjg( tau( i ) ), a( & + 1_${ik}$, i ), lda, work ) a( i, i ) = conjg( alpha ) end do return - end subroutine stdlib_${ci}$latrz + end subroutine stdlib${ii}$_${ci}$latrz - pure subroutine stdlib_${ci}$latsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) + pure subroutine stdlib${ii}$_${ci}$latsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) !! ZLATSQR: computes a blocked Tall-Skinny QR factorization of !! a complex M-by-N matrix A for M >= N: !! A = Q * ( R ), @@ -55810,76 +55801,76 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, mb, nb, ldt, lwork + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, mb, nb, ldt, lwork ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: work(*), t(ldt,*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, ii, kk, ctr + integer(${ik}$) :: i, ii, kk, ctr ! External Subroutines intrinsic :: max,min,mod ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 .or. mn .and. n>0 )) then - info = -4 - else if( ldan .and. n>0_${ik}$ )) then + info = -4_${ik}$ + else if( lda=m)) then - call stdlib_${ci}$geqrt( m, n, nb, a, lda, t, ldt, work, info) + call stdlib${ii}$_${ci}$geqrt( m, n, nb, a, lda, t, ldt, work, info) return end if kk = mod((m-n),(mb-n)) ii=m-kk+1 ! compute the qr factorization of the first block a(1:mb,1:n) - call stdlib_${ci}$geqrt( mb, n, nb, a(1,1), lda, t, ldt, work, info ) - ctr = 1 + call stdlib${ii}$_${ci}$geqrt( mb, n, nb, a(1_${ik}$,1_${ik}$), lda, t, ldt, work, info ) + ctr = 1_${ik}$ do i = mb+1, ii-mb+n , (mb-n) ! compute the qr factorization of the current block a(i:i+mb-n,1:n) - call stdlib_${ci}$tpqrt( mb-n, n, 0, nb, a(1,1), lda, a( i, 1 ), lda,t(1, ctr * n + 1),& + call stdlib${ii}$_${ci}$tpqrt( mb-n, n, 0_${ik}$, nb, a(1_${ik}$,1_${ik}$), lda, a( i, 1_${ik}$ ), lda,t(1_${ik}$, ctr * n + 1_${ik}$),& ldt, work, info ) - ctr = ctr + 1 + ctr = ctr + 1_${ik}$ end do ! compute the qr factorization of the last block a(ii:m,1:n) if (ii<=m) then - call stdlib_${ci}$tpqrt( kk, n, 0, nb, a(1,1), lda, a( ii, 1 ), lda,t(1,ctr * n + 1), & + call stdlib${ii}$_${ci}$tpqrt( kk, n, 0_${ik}$, nb, a(1_${ik}$,1_${ik}$), lda, a( ii, 1_${ik}$ ), lda,t(1_${ik}$,ctr * n + 1_${ik}$), & ldt,work, info ) end if - work( 1 ) = n*nb + work( 1_${ik}$ ) = n*nb return - end subroutine stdlib_${ci}$latsqr + end subroutine stdlib${ii}$_${ci}$latsqr - pure subroutine stdlib_${ci}$launhr_col_getrfnp( m, n, a, lda, d, info ) + pure subroutine stdlib${ii}$_${ci}$launhr_col_getrfnp( m, n, a, lda, d, info ) !! ZLAUNHR_COL_GETRFNP: computes the modified LU factorization without !! pivoting of a complex general M-by-N matrix A. The factorization has !! the form: @@ -55917,52 +55908,52 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), 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}$, 'ZLAUNHR_COL_GETRFNP', ' ', m, n, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=min( m, n ) ) then ! use unblocked code. - call stdlib_${ci}$launhr_col_getrfnp2( m, n, a, lda, d, info ) + call stdlib${ii}$_${ci}$launhr_col_getrfnp2( m, n, a, lda, d, info ) else ! use blocked code. do j = 1, min( m, n ), nb jb = min( min( m, n )-j+1, nb ) ! factor diagonal and subdiagonal blocks. - call stdlib_${ci}$launhr_col_getrfnp2( m-j+1, jb, a( j, j ), lda,d( j ), iinfo ) + call stdlib${ii}$_${ci}$launhr_col_getrfnp2( m-j+1, jb, a( j, j ), lda,d( j ), iinfo ) if( j+jb<=n ) then ! compute block row of u. - call stdlib_${ci}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, cone,& + call stdlib${ii}$_${ci}$trsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, cone,& a( j, j ), lda, a( j, j+jb ),lda ) if( j+jb<=m ) then ! update trailing submatrix. - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& cone, a( j+jb, j ), lda,a( j, j+jb ), lda, cone, a( j+jb, j+jb ),lda ) end if @@ -55970,10 +55961,10 @@ module stdlib_linalg_lapack_${ci}$ end do end if return - end subroutine stdlib_${ci}$launhr_col_getrfnp + end subroutine stdlib${ii}$_${ci}$launhr_col_getrfnp - pure recursive subroutine stdlib_${ci}$launhr_col_getrfnp2( m, n, a, lda, d, info ) + pure recursive subroutine stdlib${ii}$_${ci}$launhr_col_getrfnp2( m, n, a, lda, d, info ) !! ZLAUNHR_COL_GETRFNP2: computes the modified LU factorization without !! pivoting of a complex general M-by-N matrix A. The factorization has !! the form: @@ -56026,8 +56017,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: d(*) @@ -56036,7 +56027,7 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars real(${ck}$) :: sfmin - integer(ilp) :: i, iinfo, n1, n2 + integer(${ik}$) :: i, iinfo, n1, n2 complex(${ck}$) :: z ! Intrinsic Functions intrinsic :: abs,real,cmplx,aimag,sign,max,min @@ -56046,70 +56037,70 @@ module stdlib_linalg_lapack_${ci}$ cabs1( z ) = abs( real( z,KIND=${ck}$) ) + abs( aimag( z ) ) ! 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_${ci}$scal( m-1, cone / a( 1, 1 ), a( 2, 1 ), 1 ) + if( cabs1( a( 1_${ik}$, 1_${ik}$ ) ) >= sfmin ) then + call stdlib${ii}$_${ci}$scal( m-1, cone / 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_${ci}$launhr_col_getrfnp2( n1, n1, a, lda, d, iinfo ) + call stdlib${ii}$_${ci}$launhr_col_getrfnp2( n1, n1, a, lda, d, iinfo ) ! solve for b21 - call stdlib_${ci}$trsm( 'R', 'U', 'N', 'N', m-n1, n1, cone, a, lda,a( n1+1, 1 ), lda ) + call stdlib${ii}$_${ci}$trsm( 'R', 'U', 'N', 'N', m-n1, n1, cone, a, lda,a( n1+1, 1_${ik}$ ), lda ) ! solve for b12 - call stdlib_${ci}$trsm( 'L', 'L', 'N', 'U', n1, n2, cone, a, lda,a( 1, n1+1 ), lda ) + call stdlib${ii}$_${ci}$trsm( 'L', 'L', 'N', 'U', n1, n2, cone, a, lda,a( 1_${ik}$, n1+1 ), lda ) ! update b22, i.e. compute the schur complement ! b22 := b22 - b21*b12 - call stdlib_${ci}$gemm( 'N', 'N', m-n1, n2, n1, -cone, a( n1+1, 1 ), lda,a( 1, n1+1 ), & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', m-n1, n2, n1, -cone, a( n1+1, 1_${ik}$ ), lda,a( 1_${ik}$, n1+1 ), & lda, cone, a( n1+1, n1+1 ), lda ) ! factor b22, recursive call - call stdlib_${ci}$launhr_col_getrfnp2( m-n1, n2, a( n1+1, n1+1 ), lda,d( n1+1 ), iinfo ) + call stdlib${ii}$_${ci}$launhr_col_getrfnp2( m-n1, n2, a( n1+1, n1+1 ), lda,d( n1+1 ), iinfo ) end if return - end subroutine stdlib_${ci}$launhr_col_getrfnp2 + end subroutine stdlib${ii}$_${ci}$launhr_col_getrfnp2 - pure subroutine stdlib_${ci}$lauu2( uplo, n, a, lda, info ) + pure subroutine stdlib${ii}$_${ci}$lauu2( uplo, n, a, lda, info ) !! ZLAUU2: computes the product U * U**H or L**H * L, where the triangular !! factor U or L is stored in the upper or lower triangular part of !! the array A. @@ -56123,31 +56114,31 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: i + integer(${ik}$) :: i real(${ck}$) :: aii ! Intrinsic Functions intrinsic :: real,cmplx,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}$, 'ZLAUUM', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code - call stdlib_${ci}$lauu2( uplo, n, a, lda, info ) + call stdlib${ii}$_${ci}$lauu2( uplo, n, a, lda, info ) else ! use blocked code if( upper ) then ! compute the product u * u**h. do i = 1, n, nb ib = min( nb, n-i+1 ) - call stdlib_${ci}$trmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', i-1, & - ib, cone, a( i, i ), lda,a( 1, i ), lda ) - call stdlib_${ci}$lauu2( 'UPPER', ib, a( i, i ), lda, info ) + call stdlib${ii}$_${ci}$trmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', i-1, & + ib, cone, a( i, i ), lda,a( 1_${ik}$, i ), lda ) + call stdlib${ii}$_${ci}$lauu2( 'UPPER', ib, a( i, i ), lda, info ) if( i+ib<=n ) then - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',i-1, ib, n-i-ib+1,& - cone, a( 1, i+ib ),lda, a( i, i+ib ), lda, cone, a( 1, i ),lda ) - call stdlib_${ci}$herk( 'UPPER', 'NO TRANSPOSE', ib, n-i-ib+1,one, a( i, i+ib ),& + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',i-1, ib, n-i-ib+1,& + cone, a( 1_${ik}$, i+ib ),lda, a( i, i+ib ), lda, cone, a( 1_${ik}$, i ),lda ) + call stdlib${ii}$_${ci}$herk( 'UPPER', 'NO TRANSPOSE', ib, n-i-ib+1,one, a( i, i+ib ),& lda, one, a( i, i ),lda ) end if end do @@ -56255,23 +56246,23 @@ module stdlib_linalg_lapack_${ci}$ ! compute the product l**h * l. do i = 1, n, nb ib = min( nb, n-i+1 ) - call stdlib_${ci}$trmm( 'LEFT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', ib, i-1,& - cone, a( i, i ), lda,a( i, 1 ), lda ) - call stdlib_${ci}$lauu2( 'LOWER', ib, a( i, i ), lda, info ) + call stdlib${ii}$_${ci}$trmm( 'LEFT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', ib, i-1,& + cone, a( i, i ), lda,a( i, 1_${ik}$ ), lda ) + call stdlib${ii}$_${ci}$lauu2( 'LOWER', ib, a( i, i ), lda, info ) if( i+ib<=n ) then - call stdlib_${ci}$gemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', ib,i-1, n-i-ib+1,& - cone, a( i+ib, i ), lda,a( i+ib, 1 ), lda, cone, a( i, 1 ), lda ) - call stdlib_${ci}$herk( 'LOWER', 'CONJUGATE TRANSPOSE', ib,n-i-ib+1, one, a( i+& + call stdlib${ii}$_${ci}$gemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', ib,i-1, n-i-ib+1,& + cone, a( i+ib, i ), lda,a( i+ib, 1_${ik}$ ), lda, cone, a( i, 1_${ik}$ ), lda ) + call stdlib${ii}$_${ci}$herk( 'LOWER', 'CONJUGATE TRANSPOSE', ib,n-i-ib+1, one, a( i+& ib, i ), lda, one,a( i, i ), lda ) end if end do end if end if return - end subroutine stdlib_${ci}$lauum + end subroutine stdlib${ii}$_${ci}$lauum - pure subroutine stdlib_${ci}$pbcon( uplo, n, kd, ab, ldab, anorm, rcond, work,rwork, info ) + pure subroutine stdlib${ii}$_${ci}$pbcon( uplo, n, kd, ab, ldab, anorm, rcond, work,rwork, info ) !! ZPBCON: estimates the reciprocal of the condition number (in the !! 1-norm) of a complex Hermitian positive definite band matrix using !! the Cholesky factorization A = U**H*U or A = L*L**H computed by @@ -56284,8 +56275,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(${ck}$), intent(in) :: anorm real(${ck}$), intent(out) :: rcond ! Array Arguments @@ -56297,11 +56288,11 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: upper character :: normin - integer(ilp) :: ix, kase + integer(${ik}$) :: ix, kase real(${ck}$) :: ainvnm, scale, scalel, scaleu, smlnum complex(${ck}$) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,aimag ! Statement Functions @@ -56310,61 +56301,61 @@ module stdlib_linalg_lapack_${ci}$ cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! 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( ldabeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_${ci}$pbtrs( uplo, n, kd, 1, afb, ldafb, work, n, info ) - call stdlib_${ci}$axpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_${ci}$pbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work, n, info ) + call stdlib${ii}$_${ci}$axpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -56630,22 +56621,22 @@ module stdlib_linalg_lapack_${ci}$ rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**h). - call stdlib_${ci}$pbtrs( uplo, n, kd, 1, afb, ldafb, work, n, info ) + call stdlib${ii}$_${ci}$pbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do - else if( kase==2 ) then + else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_${ci}$pbtrs( uplo, n, kd, 1, afb, ldafb, work, n, info ) + call stdlib${ii}$_${ci}$pbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work, n, info ) end if go to 100 end if @@ -56657,10 +56648,10 @@ module stdlib_linalg_lapack_${ci}$ if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_${ci}$pbrfs + end subroutine stdlib${ii}$_${ci}$pbrfs - pure subroutine stdlib_${ci}$pbstf( uplo, n, kd, ab, ldab, info ) + pure subroutine stdlib${ii}$_${ci}$pbstf( uplo, n, kd, ab, ldab, info ) !! ZPBSTF: computes a split Cholesky factorization of a complex !! Hermitian positive definite band matrix A. !! This routine is designed to be used in conjunction with ZHBGST. @@ -56675,40 +56666,40 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: ab(ldab,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: j, kld, km, m + integer(${ik}$) :: j, kld, km, m real(${ck}$) :: ajj ! Intrinsic Functions intrinsic :: real,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_${ci}$dscal( km, one / ajj, ab( kd, j+1 ), kld ) - call stdlib_${ci}$lacgv( km, ab( kd, j+1 ), kld ) - call stdlib_${ci}$her( 'UPPER', km, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) + if( km>0_${ik}$ ) then + call stdlib${ii}$_${ci}$dscal( km, one / ajj, ab( kd, j+1 ), kld ) + call stdlib${ii}$_${ci}$lacgv( km, ab( kd, j+1 ), kld ) + call stdlib${ii}$_${ci}$her( 'UPPER', km, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) - call stdlib_${ci}$lacgv( km, ab( kd, j+1 ), kld ) + call stdlib${ii}$_${ci}$lacgv( km, ab( kd, j+1 ), kld ) end if end do else ! factorize a(m+1:n,m+1:n) as l**h*l, and update a(1:m,1:m). do j = n, m + 1, -1 ! compute s(j,j) and test for non-positive-definiteness. - ajj = real( ab( 1, j ),KIND=${ck}$) + ajj = real( ab( 1_${ik}$, j ),KIND=${ck}$) if( ajj<=zero ) then - ab( 1, j ) = ajj + ab( 1_${ik}$, j ) = ajj go to 50 end if 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_${ci}$dscal( km, one / ajj, ab( km+1, j-km ), kld ) - call stdlib_${ci}$lacgv( km, ab( km+1, j-km ), kld ) - call stdlib_${ci}$her( 'LOWER', km, -one, ab( km+1, j-km ), kld,ab( 1, j-km ), kld ) + call stdlib${ii}$_${ci}$dscal( km, one / ajj, ab( km+1, j-km ), kld ) + call stdlib${ii}$_${ci}$lacgv( km, ab( km+1, j-km ), kld ) + call stdlib${ii}$_${ci}$her( 'LOWER', km, -one, ab( km+1, j-km ), kld,ab( 1_${ik}$, j-km ), kld ) - call stdlib_${ci}$lacgv( km, ab( km+1, j-km ), kld ) + call stdlib${ii}$_${ci}$lacgv( km, ab( km+1, j-km ), kld ) end do ! factorize the updated submatrix a(1:m,1:m) as u**h*u. do j = 1, m ! compute s(j,j) and test for non-positive-definiteness. - ajj = real( ab( 1, j ),KIND=${ck}$) + ajj = real( ab( 1_${ik}$, j ),KIND=${ck}$) if( ajj<=zero ) then - ab( 1, j ) = ajj + ab( 1_${ik}$, j ) = ajj go to 50 end if 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_${ci}$dscal( km, one / ajj, ab( 2, j ), 1 ) - call stdlib_${ci}$her( 'LOWER', km, -one, ab( 2, j ), 1,ab( 1, j+1 ), kld ) + if( km>0_${ik}$ ) then + call stdlib${ii}$_${ci}$dscal( km, one / ajj, ab( 2_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$her( 'LOWER', km, -one, ab( 2_${ik}$, j ), 1_${ik}$,ab( 1_${ik}$, j+1 ), kld ) end if end do end if @@ -56791,10 +56782,10 @@ module stdlib_linalg_lapack_${ci}$ 50 continue info = j return - end subroutine stdlib_${ci}$pbstf + end subroutine stdlib${ii}$_${ci}$pbstf - pure subroutine stdlib_${ci}$pbsv( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) + pure subroutine stdlib${ii}$_${ci}$pbsv( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) !! ZPBSV: computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N Hermitian positive definite band matrix and X @@ -56811,8 +56802,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: ab(ldab,*), b(ldb,*) ! ===================================================================== @@ -56820,35 +56811,35 @@ module stdlib_linalg_lapack_${ci}$ intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .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( ldab0 ) then + info = -11_${ik}$ + else if( n>0_${ik}$ ) then scond = max( smin, smlnum ) / min( smax, bignum ) else scond = one end if end if - if( info==0 ) then - if( ldb0 )then + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_${ci}$lanhb( '1', uplo, n, kd, ab, ldab, rwork ) + anorm = stdlib${ii}$_${ci}$lanhb( '1', uplo, n, kd, ab, ldab, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_${ci}$pbcon( uplo, n, kd, afb, ldafb, anorm, rcond, work, rwork,info ) + call stdlib${ii}$_${ci}$pbcon( uplo, n, kd, afb, ldafb, anorm, rcond, work, rwork,info ) ! compute the solution matrix x. - call stdlib_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_${ci}$pbtrs( uplo, n, kd, nrhs, afb, ldafb, x, ldx, info ) + call stdlib${ii}$_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_${ci}$pbtrs( uplo, n, kd, nrhs, afb, ldafb, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_${ci}$pbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b, ldb, x,ldx, ferr, berr,& + call stdlib${ii}$_${ci}$pbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b, ldb, x,ldx, ferr, berr,& work, rwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -57000,12 +56991,12 @@ module stdlib_linalg_lapack_${ci}$ end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond0 ) then - call stdlib_${ci}$dscal( kn, one / ajj, ab( kd, j+1 ), kld ) - call stdlib_${ci}$lacgv( kn, ab( kd, j+1 ), kld ) - call stdlib_${ci}$her( 'UPPER', kn, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) + if( kn>0_${ik}$ ) then + call stdlib${ii}$_${ci}$dscal( kn, one / ajj, ab( kd, j+1 ), kld ) + call stdlib${ii}$_${ci}$lacgv( kn, ab( kd, j+1 ), kld ) + call stdlib${ii}$_${ci}$her( 'UPPER', kn, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) - call stdlib_${ci}$lacgv( kn, ab( kd, j+1 ), kld ) + call stdlib${ii}$_${ci}$lacgv( kn, ab( kd, j+1 ), kld ) end if end do else ! compute the cholesky factorization a = l*l**h. do j = 1, n ! compute l(j,j) and test for non-positive-definiteness. - ajj = real( ab( 1, j ),KIND=${ck}$) + ajj = real( ab( 1_${ik}$, j ),KIND=${ck}$) if( ajj<=zero ) then - ab( 1, j ) = ajj + ab( 1_${ik}$, j ) = ajj go to 30 end if 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_${ci}$dscal( kn, one / ajj, ab( 2, j ), 1 ) - call stdlib_${ci}$her( 'LOWER', kn, -one, ab( 2, j ), 1,ab( 1, j+1 ), kld ) + if( kn>0_${ik}$ ) then + call stdlib${ii}$_${ci}$dscal( kn, one / ajj, ab( 2_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$her( 'LOWER', kn, -one, ab( 2_${ik}$, j ), 1_${ik}$,ab( 1_${ik}$, j+1 ), kld ) end if end do end if @@ -57097,10 +57088,10 @@ module stdlib_linalg_lapack_${ci}$ 30 continue info = j return - end subroutine stdlib_${ci}$pbtf2 + end subroutine stdlib${ii}$_${ci}$pbtf2 - pure subroutine stdlib_${ci}$pbtrf( uplo, n, kd, ab, ldab, info ) + pure subroutine stdlib${ii}$_${ci}$pbtrf( uplo, n, kd, ab, ldab, info ) !! ZPBTRF: computes the Cholesky factorization of a complex Hermitian !! positive definite band matrix A. !! The factorization has the form @@ -57112,50 +57103,50 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: ab(ldab,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: nbmax = 32 - integer(ilp), parameter :: ldwork = nbmax+1 + integer(${ik}$), parameter :: nbmax = 32_${ik}$ + integer(${ik}$), parameter :: ldwork = nbmax+1 ! Local Scalars - integer(ilp) :: i, i2, i3, ib, ii, j, jj, nb + integer(${ik}$) :: i, i2, i3, ib, ii, j, jj, nb ! Local Arrays complex(${ck}$) :: work(ldwork,nbmax) ! Intrinsic Functions intrinsic :: min ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( ( .not.stdlib_lsame( uplo, 'U' ) ) .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( ldabkd ) then + if( nb<=1_${ik}$ .or. nb>kd ) then ! use unblocked code - call stdlib_${ci}$pbtf2( uplo, n, kd, ab, ldab, info ) + call stdlib${ii}$_${ci}$pbtf2( uplo, n, kd, ab, ldab, info ) else ! use blocked code if( stdlib_lsame( uplo, 'U' ) ) then @@ -57172,9 +57163,9 @@ module stdlib_linalg_lapack_${ci}$ loop_70: do i = 1, n, nb ib = min( nb, n-i+1 ) ! factorize the diagonal block - call stdlib_${ci}$potf2( uplo, ib, ab( kd+1, i ), ldab-1, ii ) - if( ii/=0 ) then - info = i + ii - 1 + call stdlib${ii}$_${ci}$potf2( uplo, ib, ab( kd+1, i ), ldab-1, ii ) + if( ii/=0_${ik}$ ) then + info = i + ii - 1_${ik}$ go to 150 end if if( i+ib<=n ) then @@ -57191,15 +57182,15 @@ module stdlib_linalg_lapack_${ci}$ ! lies outside the band. i2 = min( kd-ib, n-i-ib+1 ) i3 = min( ib, n-i-kd+1 ) - if( i2>0 ) then + if( i2>0_${ik}$ ) then ! update a12 - call stdlib_${ci}$trsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', & + call stdlib${ii}$_${ci}$trsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', & ib, i2, cone,ab( kd+1, i ), ldab-1,ab( kd+1-ib, i+ib ), ldab-1 ) ! update a22 - call stdlib_${ci}$herk( 'UPPER', 'CONJUGATE TRANSPOSE', i2, ib,-one, ab( kd+& - 1-ib, i+ib ), ldab-1, one,ab( kd+1, i+ib ), ldab-1 ) + call stdlib${ii}$_${ci}$herk( 'UPPER', 'CONJUGATE TRANSPOSE', i2, ib,-one, ab( kd+& + 1_${ik}$-ib, i+ib ), ldab-1, one,ab( kd+1, i+ib ), ldab-1 ) end if - if( i3>0 ) then + if( i3>0_${ik}$ ) then ! copy the lower triangle of a13 into the work array. do jj = 1, i3 do ii = jj, ib @@ -57207,14 +57198,14 @@ module stdlib_linalg_lapack_${ci}$ end do end do ! update a13 (in the work array). - call stdlib_${ci}$trsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', & + call stdlib${ii}$_${ci}$trsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', & ib, i3, cone,ab( kd+1, i ), ldab-1, work, ldwork ) ! update a23 - if( i2>0 )call stdlib_${ci}$gemm( 'CONJUGATE TRANSPOSE','NO TRANSPOSE', i2, & - i3, ib, -cone,ab( kd+1-ib, i+ib ), ldab-1, work,ldwork, cone, ab( 1+ib, & + if( i2>0_${ik}$ )call stdlib${ii}$_${ci}$gemm( 'CONJUGATE TRANSPOSE','NO TRANSPOSE', i2, & + i3, ib, -cone,ab( kd+1-ib, i+ib ), ldab-1, work,ldwork, cone, ab( 1_${ik}$+ib, & i+kd ),ldab-1 ) ! update a33 - call stdlib_${ci}$herk( 'UPPER', 'CONJUGATE TRANSPOSE', i3, ib,-one, work, & + call stdlib${ii}$_${ci}$herk( 'UPPER', 'CONJUGATE TRANSPOSE', i3, ib,-one, work, & ldwork, one,ab( kd+1, i+kd ), ldab-1 ) ! copy the lower triangle of a13 back into place. do jj = 1, i3 @@ -57239,9 +57230,9 @@ module stdlib_linalg_lapack_${ci}$ loop_140: do i = 1, n, nb ib = min( nb, n-i+1 ) ! factorize the diagonal block - call stdlib_${ci}$potf2( uplo, ib, ab( 1, i ), ldab-1, ii ) - if( ii/=0 ) then - info = i + ii - 1 + call stdlib${ii}$_${ci}$potf2( uplo, ib, ab( 1_${ik}$, i ), ldab-1, ii ) + if( ii/=0_${ik}$ ) then + info = i + ii - 1_${ik}$ go to 150 end if if( i+ib<=n ) then @@ -57258,15 +57249,15 @@ module stdlib_linalg_lapack_${ci}$ ! lies outside the band. i2 = min( kd-ib, n-i-ib+1 ) i3 = min( ib, n-i-kd+1 ) - if( i2>0 ) then + if( i2>0_${ik}$ ) then ! update a21 - call stdlib_${ci}$trsm( 'RIGHT', 'LOWER','CONJUGATE TRANSPOSE', 'NON-UNIT', & - i2,ib, cone, ab( 1, i ), ldab-1,ab( 1+ib, i ), ldab-1 ) + call stdlib${ii}$_${ci}$trsm( 'RIGHT', 'LOWER','CONJUGATE TRANSPOSE', 'NON-UNIT', & + i2,ib, cone, ab( 1_${ik}$, i ), ldab-1,ab( 1_${ik}$+ib, i ), ldab-1 ) ! update a22 - call stdlib_${ci}$herk( 'LOWER', 'NO TRANSPOSE', i2, ib, -one,ab( 1+ib, i ), & - ldab-1, one,ab( 1, i+ib ), ldab-1 ) + call stdlib${ii}$_${ci}$herk( 'LOWER', 'NO TRANSPOSE', i2, ib, -one,ab( 1_${ik}$+ib, i ), & + ldab-1, one,ab( 1_${ik}$, i+ib ), ldab-1 ) end if - if( i3>0 ) then + if( i3>0_${ik}$ ) then ! copy the upper triangle of a31 into the work array. do jj = 1, ib do ii = 1, min( jj, i3 ) @@ -57274,15 +57265,15 @@ module stdlib_linalg_lapack_${ci}$ end do end do ! update a31 (in the work array). - call stdlib_${ci}$trsm( 'RIGHT', 'LOWER','CONJUGATE TRANSPOSE', 'NON-UNIT', & - i3,ib, cone, ab( 1, i ), ldab-1, work,ldwork ) + call stdlib${ii}$_${ci}$trsm( 'RIGHT', 'LOWER','CONJUGATE TRANSPOSE', 'NON-UNIT', & + i3,ib, cone, ab( 1_${ik}$, i ), ldab-1, work,ldwork ) ! update a32 - if( i2>0 )call stdlib_${ci}$gemm( 'NO TRANSPOSE','CONJUGATE TRANSPOSE', i3, & - i2, ib,-cone, work, ldwork, ab( 1+ib, i ),ldab-1, cone, ab( 1+kd-ib, i+& + if( i2>0_${ik}$ )call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE','CONJUGATE TRANSPOSE', i3, & + i2, ib,-cone, work, ldwork, ab( 1_${ik}$+ib, i ),ldab-1, cone, ab( 1_${ik}$+kd-ib, i+& ib ),ldab-1 ) ! update a33 - call stdlib_${ci}$herk( 'LOWER', 'NO TRANSPOSE', i3, ib, -one,work, ldwork, & - one, ab( 1, i+kd ),ldab-1 ) + call stdlib${ii}$_${ci}$herk( 'LOWER', 'NO TRANSPOSE', i3, ib, -one,work, ldwork, & + one, ab( 1_${ik}$, i+kd ),ldab-1 ) ! copy the upper triangle of a31 back into place. do jj = 1, ib do ii = 1, min( jj, i3 ) @@ -57297,10 +57288,10 @@ module stdlib_linalg_lapack_${ci}$ return 150 continue return - end subroutine stdlib_${ci}$pbtrf + end subroutine stdlib${ii}$_${ci}$pbtrf - pure subroutine stdlib_${ci}$pbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) + pure subroutine stdlib${ii}$_${ci}$pbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) !! ZPBTRS: solves a system of linear equations A*X = B with a Hermitian !! positive definite band matrix A using the Cholesky factorization !! A = U**H *U or A = L*L**H computed by ZPBTRF. @@ -57309,36 +57300,36 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(in) :: ab(ldab,*) complex(${ck}$), 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( ldab a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) - call stdlib_${ci}$potrf( 'L', n1, a( 0 ), n, info ) + call stdlib${ii}$_${ci}$potrf( 'L', n1, a( 0_${ik}$ ), n, info ) if( info>0 )return - call stdlib_${ci}$trsm( 'R', 'L', 'C', 'N', n2, n1, cone, a( 0 ), n,a( n1 ), n ) + call stdlib${ii}$_${ci}$trsm( 'R', 'L', 'C', 'N', n2, n1, cone, a( 0_${ik}$ ), n,a( n1 ), n ) - call stdlib_${ci}$herk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n ) - call stdlib_${ci}$potrf( 'U', n2, a( n ), n, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_${ci}$herk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n ) + call stdlib${ii}$_${ci}$potrf( 'U', n2, a( n ), n, info ) + if( info>0_${ik}$ )info = info + n1 else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) - call stdlib_${ci}$potrf( 'L', n1, a( n2 ), n, info ) + call stdlib${ii}$_${ci}$potrf( 'L', n1, a( n2 ), n, info ) if( info>0 )return - call stdlib_${ci}$trsm( 'L', 'L', 'N', 'N', n1, n2, cone, a( n2 ), n,a( 0 ), n ) + call stdlib${ii}$_${ci}$trsm( 'L', 'L', 'N', 'N', n1, n2, cone, a( n2 ), n,a( 0_${ik}$ ), n ) - call stdlib_${ci}$herk( 'U', 'C', n2, n1, -one, a( 0 ), n, one,a( n1 ), n ) - call stdlib_${ci}$potrf( 'U', n2, a( n1 ), n, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_${ci}$herk( 'U', 'C', n2, n1, -one, a( 0_${ik}$ ), n, one,a( n1 ), n ) + call stdlib${ii}$_${ci}$potrf( 'U', n2, a( n1 ), n, info ) + if( info>0_${ik}$ )info = info + n1 end if else ! n is odd and transr = 'c' @@ -57461,26 +57452,26 @@ module stdlib_linalg_lapack_${ci}$ ! srpa for lower, transpose and n is odd ! t1 -> a(0,0) , t2 -> a(1,0) , s -> a(0,n1) ! t1 -> a(0+0) , t2 -> a(1+0) , s -> a(0+n1*n1); lda=n1 - call stdlib_${ci}$potrf( 'U', n1, a( 0 ), n1, info ) + call stdlib${ii}$_${ci}$potrf( 'U', n1, a( 0_${ik}$ ), n1, info ) if( info>0 )return - call stdlib_${ci}$trsm( 'L', 'U', 'C', 'N', n1, n2, cone, a( 0 ), n1,a( n1*n1 ), & + call stdlib${ii}$_${ci}$trsm( 'L', 'U', 'C', 'N', n1, n2, cone, a( 0_${ik}$ ), n1,a( n1*n1 ), & n1 ) - call stdlib_${ci}$herk( 'L', 'C', n2, n1, -one, a( n1*n1 ), n1, one,a( 1 ), n1 ) + call stdlib${ii}$_${ci}$herk( 'L', 'C', n2, n1, -one, a( n1*n1 ), n1, one,a( 1_${ik}$ ), n1 ) - call stdlib_${ci}$potrf( 'L', n2, a( 1 ), n1, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_${ci}$potrf( 'L', n2, a( 1_${ik}$ ), n1, info ) + if( info>0_${ik}$ )info = info + n1 else ! srpa for upper, transpose and n is odd ! t1 -> a(0,n1+1), t2 -> a(0,n1), s -> a(0,0) ! t1 -> a(n2*n2), t2 -> a(n1*n2), s -> a(0); lda = n2 - call stdlib_${ci}$potrf( 'U', n1, a( n2*n2 ), n2, info ) + call stdlib${ii}$_${ci}$potrf( 'U', n1, a( n2*n2 ), n2, info ) if( info>0 )return - call stdlib_${ci}$trsm( 'R', 'U', 'N', 'N', n2, n1, cone, a( n2*n2 ),n2, a( 0 ), & + call stdlib${ii}$_${ci}$trsm( 'R', 'U', 'N', 'N', n2, n1, cone, a( n2*n2 ),n2, a( 0_${ik}$ ), & n2 ) - call stdlib_${ci}$herk( 'L', 'N', n2, n1, -one, a( 0 ), n2, one,a( n1*n2 ), n2 ) + call stdlib${ii}$_${ci}$herk( 'L', 'N', n2, n1, -one, a( 0_${ik}$ ), n2, one,a( n1*n2 ), n2 ) - call stdlib_${ci}$potrf( 'L', n2, a( n1*n2 ), n2, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_${ci}$potrf( 'L', n2, a( n1*n2 ), n2, info ) + if( info>0_${ik}$ )info = info + n1 end if end if else @@ -57491,26 +57482,26 @@ module stdlib_linalg_lapack_${ci}$ ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) - call stdlib_${ci}$potrf( 'L', k, a( 1 ), n+1, info ) + call stdlib${ii}$_${ci}$potrf( 'L', k, a( 1_${ik}$ ), n+1, info ) if( info>0 )return - call stdlib_${ci}$trsm( 'R', 'L', 'C', 'N', k, k, cone, a( 1 ), n+1,a( k+1 ), n+1 ) + call stdlib${ii}$_${ci}$trsm( 'R', 'L', 'C', 'N', k, k, cone, a( 1_${ik}$ ), n+1,a( k+1 ), n+1 ) - call stdlib_${ci}$herk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0 ), n+1 ) + call stdlib${ii}$_${ci}$herk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0_${ik}$ ), n+1 ) - call stdlib_${ci}$potrf( 'U', k, a( 0 ), n+1, info ) - if( info>0 )info = info + k + call stdlib${ii}$_${ci}$potrf( 'U', k, a( 0_${ik}$ ), n+1, info ) + if( info>0_${ik}$ )info = info + k else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) - call stdlib_${ci}$potrf( 'L', k, a( k+1 ), n+1, info ) + call stdlib${ii}$_${ci}$potrf( 'L', k, a( k+1 ), n+1, info ) if( info>0 )return - call stdlib_${ci}$trsm( 'L', 'L', 'N', 'N', k, k, cone, a( k+1 ),n+1, a( 0 ), n+1 ) + call stdlib${ii}$_${ci}$trsm( 'L', 'L', 'N', 'N', k, k, cone, a( k+1 ),n+1, a( 0_${ik}$ ), n+1 ) - call stdlib_${ci}$herk( 'U', 'C', k, k, -one, a( 0 ), n+1, one,a( k ), n+1 ) + call stdlib${ii}$_${ci}$herk( 'U', 'C', k, k, -one, a( 0_${ik}$ ), n+1, one,a( k ), n+1 ) - call stdlib_${ci}$potrf( 'U', k, a( k ), n+1, info ) - if( info>0 )info = info + k + call stdlib${ii}$_${ci}$potrf( 'U', k, a( k ), n+1, info ) + if( info>0_${ik}$ )info = info + k end if else ! n is even and transr = 'c' @@ -57518,33 +57509,33 @@ module stdlib_linalg_lapack_${ci}$ ! srpa for lower, transpose and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1) ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k - call stdlib_${ci}$potrf( 'U', k, a( 0+k ), k, info ) + call stdlib${ii}$_${ci}$potrf( 'U', k, a( 0_${ik}$+k ), k, info ) if( info>0 )return - call stdlib_${ci}$trsm( 'L', 'U', 'C', 'N', k, k, cone, a( k ), n1,a( k*( k+1 ) ), & + call stdlib${ii}$_${ci}$trsm( 'L', 'U', 'C', 'N', k, k, cone, a( k ), n1,a( k*( k+1 ) ), & k ) - call stdlib_${ci}$herk( 'L', 'C', k, k, -one, a( k*( k+1 ) ), k, one,a( 0 ), k ) + call stdlib${ii}$_${ci}$herk( 'L', 'C', k, k, -one, a( k*( k+1 ) ), k, one,a( 0_${ik}$ ), k ) - call stdlib_${ci}$potrf( 'L', k, a( 0 ), k, info ) - if( info>0 )info = info + k + call stdlib${ii}$_${ci}$potrf( 'L', k, a( 0_${ik}$ ), k, info ) + if( info>0_${ik}$ )info = info + k else ! srpa for upper, transpose and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0) ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k - call stdlib_${ci}$potrf( 'U', k, a( k*( k+1 ) ), k, info ) + call stdlib${ii}$_${ci}$potrf( 'U', k, a( k*( k+1 ) ), k, info ) if( info>0 )return - call stdlib_${ci}$trsm( 'R', 'U', 'N', 'N', k, k, cone,a( k*( k+1 ) ), k, a( 0 ), & + call stdlib${ii}$_${ci}$trsm( 'R', 'U', 'N', 'N', k, k, cone,a( k*( k+1 ) ), k, a( 0_${ik}$ ), & k ) - call stdlib_${ci}$herk( 'L', 'N', k, k, -one, a( 0 ), k, one,a( k*k ), k ) - call stdlib_${ci}$potrf( 'L', k, a( k*k ), k, info ) - if( info>0 )info = info + k + call stdlib${ii}$_${ci}$herk( 'L', 'N', k, k, -one, a( 0_${ik}$ ), k, one,a( k*k ), k ) + call stdlib${ii}$_${ci}$potrf( 'L', k, a( k*k ), k, info ) + if( info>0_${ik}$ )info = info + k end if end if end if return - end subroutine stdlib_${ci}$pftrf + end subroutine stdlib${ii}$_${ci}$pftrf - pure subroutine stdlib_${ci}$pftri( transr, uplo, n, a, info ) + pure subroutine stdlib${ii}$_${ci}$pftri( transr, uplo, n, a, info ) !! ZPFTRI: computes the inverse of a complex Hermitian positive definite !! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H !! computed by ZPFTRF. @@ -57553,53 +57544,53 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n ! Array Arguments - complex(${ck}$), intent(inout) :: a(0:*) + complex(${ck}$), intent(inout) :: a(0_${ik}$:*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, nisodd, normaltransr - integer(ilp) :: n1, n2, k + integer(${ik}$) :: n1, n2, k ! Intrinsic Functions intrinsic :: 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, 'C' ) ) 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 + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'ZPFTRI', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZPFTRI', -info ) return end if ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. - call stdlib_${ci}$tftri( transr, uplo, 'N', n, a, info ) + call stdlib${ii}$_${ci}$tftri( transr, uplo, 'N', n, a, info ) if( info>0 )return ! if n is odd, set nisodd = .true. ! if n is even, set k = n/2 and nisodd = .false. - if( mod( n, 2 )==0 ) then - k = n / 2 + if( mod( n, 2_${ik}$ )==0_${ik}$ ) then + k = n / 2_${ik}$ nisodd = .false. else nisodd = .true. end if ! set n1 and n2 depending on lower if( lower ) then - n2 = n / 2 + n2 = n / 2_${ik}$ n1 = n - n2 else - n1 = n / 2 + n1 = n / 2_${ik}$ n2 = n - n1 end if ! start execution of triangular matrix multiply: inv(u)*inv(u)^c or @@ -57612,41 +57603,41 @@ module stdlib_linalg_lapack_${ci}$ ! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) ) ! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) - call stdlib_${ci}$lauum( 'L', n1, a( 0 ), n, info ) - call stdlib_${ci}$herk( 'L', 'C', n1, n2, one, a( n1 ), n, one,a( 0 ), n ) - call stdlib_${ci}$trmm( 'L', 'U', 'N', 'N', n2, n1, cone, a( n ), n,a( n1 ), n ) + call stdlib${ii}$_${ci}$lauum( 'L', n1, a( 0_${ik}$ ), n, info ) + call stdlib${ii}$_${ci}$herk( 'L', 'C', n1, n2, one, a( n1 ), n, one,a( 0_${ik}$ ), n ) + call stdlib${ii}$_${ci}$trmm( 'L', 'U', 'N', 'N', n2, n1, cone, a( n ), n,a( n1 ), n ) - call stdlib_${ci}$lauum( 'U', n2, a( n ), n, info ) + call stdlib${ii}$_${ci}$lauum( 'U', n2, a( n ), n, info ) else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) - call stdlib_${ci}$lauum( 'L', n1, a( n2 ), n, info ) - call stdlib_${ci}$herk( 'L', 'N', n1, n2, one, a( 0 ), n, one,a( n2 ), n ) - call stdlib_${ci}$trmm( 'R', 'U', 'C', 'N', n1, n2, cone, a( n1 ), n,a( 0 ), n ) + call stdlib${ii}$_${ci}$lauum( 'L', n1, a( n2 ), n, info ) + call stdlib${ii}$_${ci}$herk( 'L', 'N', n1, n2, one, a( 0_${ik}$ ), n, one,a( n2 ), n ) + call stdlib${ii}$_${ci}$trmm( 'R', 'U', 'C', 'N', n1, n2, cone, a( n1 ), n,a( 0_${ik}$ ), n ) - call stdlib_${ci}$lauum( 'U', n2, a( n1 ), n, info ) + call stdlib${ii}$_${ci}$lauum( 'U', n2, a( n1 ), n, info ) end if else ! n is odd and transr = 'c' if( lower ) then ! srpa for lower, transpose, and n is odd ! t1 -> a(0), t2 -> a(1), s -> a(0+n1*n1) - call stdlib_${ci}$lauum( 'U', n1, a( 0 ), n1, info ) - call stdlib_${ci}$herk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0 ), n1 ) + call stdlib${ii}$_${ci}$lauum( 'U', n1, a( 0_${ik}$ ), n1, info ) + call stdlib${ii}$_${ci}$herk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0_${ik}$ ), n1 ) - call stdlib_${ci}$trmm( 'R', 'L', 'N', 'N', n1, n2, cone, a( 1 ), n1,a( n1*n1 ), & + call stdlib${ii}$_${ci}$trmm( 'R', 'L', 'N', 'N', n1, n2, cone, a( 1_${ik}$ ), n1,a( n1*n1 ), & n1 ) - call stdlib_${ci}$lauum( 'L', n2, a( 1 ), n1, info ) + call stdlib${ii}$_${ci}$lauum( 'L', n2, a( 1_${ik}$ ), n1, info ) else ! srpa for upper, transpose, and n is odd ! t1 -> a(0+n2*n2), t2 -> a(0+n1*n2), s -> a(0) - call stdlib_${ci}$lauum( 'U', n1, a( n2*n2 ), n2, info ) - call stdlib_${ci}$herk( 'U', 'C', n1, n2, one, a( 0 ), n2, one,a( n2*n2 ), n2 ) + call stdlib${ii}$_${ci}$lauum( 'U', n1, a( n2*n2 ), n2, info ) + call stdlib${ii}$_${ci}$herk( 'U', 'C', n1, n2, one, a( 0_${ik}$ ), n2, one,a( n2*n2 ), n2 ) - call stdlib_${ci}$trmm( 'L', 'L', 'C', 'N', n2, n1, cone, a( n1*n2 ),n2, a( 0 ), & + call stdlib${ii}$_${ci}$trmm( 'L', 'L', 'C', 'N', n2, n1, cone, a( n1*n2 ),n2, a( 0_${ik}$ ), & n2 ) - call stdlib_${ci}$lauum( 'L', n2, a( n1*n2 ), n2, info ) + call stdlib${ii}$_${ci}$lauum( 'L', n2, a( n1*n2 ), n2, info ) end if end if else @@ -57657,22 +57648,22 @@ module stdlib_linalg_lapack_${ci}$ ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) - call stdlib_${ci}$lauum( 'L', k, a( 1 ), n+1, info ) - call stdlib_${ci}$herk( 'L', 'C', k, k, one, a( k+1 ), n+1, one,a( 1 ), n+1 ) + call stdlib${ii}$_${ci}$lauum( 'L', k, a( 1_${ik}$ ), n+1, info ) + call stdlib${ii}$_${ci}$herk( 'L', 'C', k, k, one, a( k+1 ), n+1, one,a( 1_${ik}$ ), n+1 ) - call stdlib_${ci}$trmm( 'L', 'U', 'N', 'N', k, k, cone, a( 0 ), n+1,a( k+1 ), n+1 ) + call stdlib${ii}$_${ci}$trmm( 'L', 'U', 'N', 'N', k, k, cone, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 ) - call stdlib_${ci}$lauum( 'U', k, a( 0 ), n+1, info ) + call stdlib${ii}$_${ci}$lauum( 'U', k, a( 0_${ik}$ ), n+1, info ) else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) - call stdlib_${ci}$lauum( 'L', k, a( k+1 ), n+1, info ) - call stdlib_${ci}$herk( 'L', 'N', k, k, one, a( 0 ), n+1, one,a( k+1 ), n+1 ) + call stdlib${ii}$_${ci}$lauum( 'L', k, a( k+1 ), n+1, info ) + call stdlib${ii}$_${ci}$herk( 'L', 'N', k, k, one, a( 0_${ik}$ ), n+1, one,a( k+1 ), n+1 ) - call stdlib_${ci}$trmm( 'R', 'U', 'C', 'N', k, k, cone, a( k ), n+1,a( 0 ), n+1 ) + call stdlib${ii}$_${ci}$trmm( 'R', 'U', 'C', 'N', k, k, cone, a( k ), n+1,a( 0_${ik}$ ), n+1 ) - call stdlib_${ci}$lauum( 'U', k, a( k ), n+1, info ) + call stdlib${ii}$_${ci}$lauum( 'U', k, a( k ), n+1, info ) end if else ! n is even and transr = 'c' @@ -57680,30 +57671,30 @@ module stdlib_linalg_lapack_${ci}$ ! srpa for lower, transpose, and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1), ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k - call stdlib_${ci}$lauum( 'U', k, a( k ), k, info ) - call stdlib_${ci}$herk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k ) + call stdlib${ii}$_${ci}$lauum( 'U', k, a( k ), k, info ) + call stdlib${ii}$_${ci}$herk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k ) - call stdlib_${ci}$trmm( 'R', 'L', 'N', 'N', k, k, cone, a( 0 ), k,a( k*( k+1 ) ), & + call stdlib${ii}$_${ci}$trmm( 'R', 'L', 'N', 'N', k, k, cone, a( 0_${ik}$ ), k,a( k*( k+1 ) ), & k ) - call stdlib_${ci}$lauum( 'L', k, a( 0 ), k, info ) + call stdlib${ii}$_${ci}$lauum( 'L', k, a( 0_${ik}$ ), k, info ) else ! srpa for upper, transpose, and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0), ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k - call stdlib_${ci}$lauum( 'U', k, a( k*( k+1 ) ), k, info ) - call stdlib_${ci}$herk( 'U', 'C', k, k, one, a( 0 ), k, one,a( k*( k+1 ) ), k ) + call stdlib${ii}$_${ci}$lauum( 'U', k, a( k*( k+1 ) ), k, info ) + call stdlib${ii}$_${ci}$herk( 'U', 'C', k, k, one, a( 0_${ik}$ ), k, one,a( k*( k+1 ) ), k ) - call stdlib_${ci}$trmm( 'L', 'L', 'C', 'N', k, k, cone, a( k*k ), k,a( 0 ), k ) + call stdlib${ii}$_${ci}$trmm( 'L', 'L', 'C', 'N', k, k, cone, a( k*k ), k,a( 0_${ik}$ ), k ) - call stdlib_${ci}$lauum( 'L', k, a( k*k ), k, info ) + call stdlib${ii}$_${ci}$lauum( 'L', k, a( k*k ), k, info ) end if end if end if return - end subroutine stdlib_${ci}$pftri + end subroutine stdlib${ii}$_${ci}$pftri - pure subroutine stdlib_${ci}$pftrs( transr, uplo, n, nrhs, a, b, ldb, info ) + pure subroutine stdlib${ii}$_${ci}$pftrs( transr, uplo, n, nrhs, a, b, ldb, info ) !! ZPFTRS: solves a system of linear equations A*X = B with a Hermitian !! positive definite matrix A using the Cholesky factorization !! A = U**H*U or A = L*L**H computed by ZPFTRF. @@ -57712,10 +57703,10 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments - complex(${ck}$), intent(in) :: a(0:*) + complex(${ck}$), intent(in) :: a(0_${ik}$:*) complex(${ck}$), intent(inout) :: b(ldb,*) ! ===================================================================== @@ -57725,39 +57716,39 @@ module stdlib_linalg_lapack_${ci}$ intrinsic :: max ! 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, 'C' ) ) 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( nrhs<0 ) then - info = -4 - else if( ldbeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_${ci}$potrs( uplo, n, 1, af, ldaf, work, n, info ) - call stdlib_${ci}$axpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_${ci}$potrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info ) + call stdlib${ii}$_${ci}$axpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -58176,22 +58167,22 @@ module stdlib_linalg_lapack_${ci}$ rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**h). - call stdlib_${ci}$potrs( uplo, n, 1, af, ldaf, work, n, info ) + call stdlib${ii}$_${ci}$potrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do - else if( kase==2 ) then + else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_${ci}$potrs( uplo, n, 1, af, ldaf, work, n, info ) + call stdlib${ii}$_${ci}$potrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info ) end if go to 100 end if @@ -58203,10 +58194,10 @@ module stdlib_linalg_lapack_${ci}$ if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_${ci}$porfs + end subroutine stdlib${ii}$_${ci}$porfs - pure subroutine stdlib_${ci}$posv( uplo, n, nrhs, a, lda, b, ldb, info ) + pure subroutine stdlib${ii}$_${ci}$posv( uplo, n, nrhs, a, lda, b, ldb, info ) !! ZPOSV: computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N Hermitian positive definite matrix and X and B @@ -58222,8 +58213,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) ! ===================================================================== @@ -58231,33 +58222,33 @@ module stdlib_linalg_lapack_${ci}$ intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .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 + info = -10_${ik}$ + else if( n>0_${ik}$ ) then scond = max( smin, smlnum ) / min( smax, bignum ) else scond = one end if end if - if( info==0 ) then - if( ldb0 )then + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_${ci}$lanhe( '1', uplo, n, a, lda, rwork ) + anorm = stdlib${ii}$_${ci}$lanhe( '1', uplo, n, a, lda, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_${ci}$pocon( uplo, n, af, ldaf, anorm, rcond, work, rwork, info ) + call stdlib${ii}$_${ci}$pocon( uplo, n, af, ldaf, anorm, rcond, work, rwork, info ) ! compute the solution matrix x. - call stdlib_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_${ci}$potrs( uplo, n, nrhs, af, ldaf, x, ldx, info ) + call stdlib${ii}$_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_${ci}$potrs( uplo, n, nrhs, af, ldaf, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_${ci}$porfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x, ldx,ferr, berr, work, & + call stdlib${ii}$_${ci}$porfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x, ldx,ferr, berr, work, & rwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -58396,12 +58387,12 @@ module stdlib_linalg_lapack_${ci}$ end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond=n ) then + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code. - call stdlib_${ci}$potrf2( uplo, n, a, lda, info ) + call stdlib${ii}$_${ci}$potrf2( uplo, n, a, lda, info ) else ! use blocked code. if( upper ) then @@ -58550,15 +58541,15 @@ module stdlib_linalg_lapack_${ci}$ ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) - call stdlib_${ci}$herk( 'UPPER', 'CONJUGATE TRANSPOSE', jb, j-1,-one, a( 1, j ), & + call stdlib${ii}$_${ci}$herk( 'UPPER', 'CONJUGATE TRANSPOSE', jb, j-1,-one, a( 1_${ik}$, j ), & lda, one, a( j, j ), lda ) - call stdlib_${ci}$potrf2( 'UPPER', jb, a( j, j ), lda, info ) + call stdlib${ii}$_${ci}$potrf2( 'UPPER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block row. - call stdlib_${ci}$gemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', jb,n-j-jb+1, j-1,& - -cone, a( 1, j ), lda,a( 1, j+jb ), lda, cone, a( j, j+jb ),lda ) - call stdlib_${ci}$trsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', jb, & + call stdlib${ii}$_${ci}$gemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', jb,n-j-jb+1, j-1,& + -cone, a( 1_${ik}$, j ), lda,a( 1_${ik}$, j+jb ), lda, cone, a( j, j+jb ),lda ) + call stdlib${ii}$_${ci}$trsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', jb, & n-j-jb+1, cone, a( j, j ),lda, a( j, j+jb ), lda ) end if end do @@ -58568,15 +58559,15 @@ module stdlib_linalg_lapack_${ci}$ ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) - call stdlib_${ci}$herk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1 ), lda, one,& + call stdlib${ii}$_${ci}$herk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1_${ik}$ ), lda, one,& a( j, j ), lda ) - call stdlib_${ci}$potrf2( 'LOWER', jb, a( j, j ), lda, info ) + call stdlib${ii}$_${ci}$potrf2( 'LOWER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block column. - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',n-j-jb+1, jb, j-1,& - -cone, a( j+jb, 1 ),lda, a( j, 1 ), lda, cone, a( j+jb, j ),lda ) - call stdlib_${ci}$trsm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', n-j-& + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',n-j-jb+1, jb, j-1,& + -cone, a( j+jb, 1_${ik}$ ),lda, a( j, 1_${ik}$ ), lda, cone, a( j+jb, j ),lda ) + call stdlib${ii}$_${ci}$trsm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', n-j-& jb+1, jb, cone, a( j, j ),lda, a( j+jb, j ), lda ) end if end do @@ -58584,13 +58575,13 @@ module stdlib_linalg_lapack_${ci}$ end if go to 40 30 continue - info = info + j - 1 + info = info + j - 1_${ik}$ 40 continue return - end subroutine stdlib_${ci}$potrf + end subroutine stdlib${ii}$_${ci}$potrf - pure recursive subroutine stdlib_${ci}$potrf2( uplo, n, a, lda, info ) + pure recursive subroutine stdlib${ii}$_${ci}$potrf2( uplo, n, a, lda, info ) !! ZPOTRF2: computes the Cholesky factorization of a Hermitian !! positive definite matrix A using the recursive algorithm. !! The factorization has the form @@ -58609,8 +58600,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: a(lda,*) ! ===================================================================== @@ -58618,80 +58609,80 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: upper - integer(ilp) :: n1, n2, iinfo + integer(${ik}$) :: n1, n2, iinfo real(${ck}$) :: ajj ! Intrinsic Functions intrinsic :: max,real,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( lda0 )return ! form inv(u) * inv(u)**h or inv(l)**h * inv(l). - call stdlib_${ci}$lauum( uplo, n, a, lda, info ) + call stdlib${ii}$_${ci}$lauum( uplo, n, a, lda, info ) return - end subroutine stdlib_${ci}$potri + end subroutine stdlib${ii}$_${ci}$potri - pure subroutine stdlib_${ci}$potrs( uplo, n, nrhs, a, lda, b, ldb, info ) + pure subroutine stdlib${ii}$_${ci}$potrs( uplo, n, nrhs, a, lda, b, ldb, info ) !! ZPOTRS: solves a system of linear equations A*X = B with a Hermitian !! positive definite matrix A using the Cholesky factorization !! A = U**H * U or A = L * L**H computed by ZPOTRF. @@ -58741,8 +58732,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(in) :: a(lda,*) complex(${ck}$), intent(inout) :: b(ldb,*) @@ -58754,21 +58745,21 @@ module stdlib_linalg_lapack_${ci}$ 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( nrhs<0 ) then - info = -3 - else if( ldaeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_${ci}$pptrs( uplo, n, 1, afp, work, n, info ) - call stdlib_${ci}$axpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_${ci}$pptrs( uplo, n, 1_${ik}$, afp, work, n, info ) + call stdlib${ii}$_${ci}$axpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -59152,22 +59143,22 @@ module stdlib_linalg_lapack_${ci}$ rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**h). - call stdlib_${ci}$pptrs( uplo, n, 1, afp, work, n, info ) + call stdlib${ii}$_${ci}$pptrs( uplo, n, 1_${ik}$, afp, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do - else if( kase==2 ) then + else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_${ci}$pptrs( uplo, n, 1, afp, work, n, info ) + call stdlib${ii}$_${ci}$pptrs( uplo, n, 1_${ik}$, afp, work, n, info ) end if go to 100 end if @@ -59179,10 +59170,10 @@ module stdlib_linalg_lapack_${ci}$ if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_${ci}$pprfs + end subroutine stdlib${ii}$_${ci}$pprfs - pure subroutine stdlib_${ci}$ppsv( uplo, n, nrhs, ap, b, ldb, info ) + pure subroutine stdlib${ii}$_${ci}$ppsv( uplo, n, nrhs, ap, b, ldb, info ) !! ZPPSV: computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N Hermitian positive definite matrix stored in @@ -59198,8 +59189,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments complex(${ck}$), intent(inout) :: ap(*), b(ldb,*) ! ===================================================================== @@ -59207,31 +59198,31 @@ module stdlib_linalg_lapack_${ci}$ intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .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( ldb0 ) then + info = -8_${ik}$ + else if( n>0_${ik}$ ) then scond = max( smin, smlnum ) / min( smax, bignum ) else scond = one end if end if - if( info==0 ) then - if( ldb0 )then + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_${ci}$lanhp( 'I', uplo, n, ap, rwork ) + anorm = stdlib${ii}$_${ci}$lanhp( 'I', uplo, n, ap, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_${ci}$ppcon( uplo, n, afp, anorm, rcond, work, rwork, info ) + call stdlib${ii}$_${ci}$ppcon( uplo, n, afp, anorm, rcond, work, rwork, info ) ! compute the solution matrix x. - call stdlib_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_${ci}$pptrs( uplo, n, nrhs, afp, x, ldx, info ) + call stdlib${ii}$_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_${ci}$pptrs( uplo, n, nrhs, afp, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_${ci}$pprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr, berr,work, rwork, & + call stdlib${ii}$_${ci}$pprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr, berr,work, rwork, & info ) ! transform the solution matrix x to a solution of the original ! system. @@ -59366,12 +59357,12 @@ module stdlib_linalg_lapack_${ci}$ end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond1 )call stdlib_${ci}$tpsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',j-1, ap, & - ap( jc ), 1 ) + if( j>1_${ik}$ )call stdlib${ii}$_${ci}$tpsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',j-1, ap, & + ap( jc ), 1_${ik}$ ) ! compute u(j,j) and test for non-positive-definiteness. - ajj = real( ap( jj ),KIND=${ck}$) - real( stdlib_${ci}$dotc( j-1,ap( jc ), 1, ap( jc ), 1 & + ajj = real( ap( jj ),KIND=${ck}$) - real( stdlib${ii}$_${ci}$dotc( j-1,ap( jc ), 1_${ik}$, ap( jc ), 1_${ik}$ & ),KIND=${ck}$) if( ajj<=zero ) then ap( jj ) = ajj @@ -59430,7 +59421,7 @@ module stdlib_linalg_lapack_${ci}$ end do else ! compute the cholesky factorization a = l * l**h. - jj = 1 + jj = 1_${ik}$ do j = 1, n ! compute l(j,j) and test for non-positive-definiteness. ajj = real( ap( jj ),KIND=${ck}$) @@ -59443,9 +59434,9 @@ module stdlib_linalg_lapack_${ci}$ ! compute elements j+1:n of column j and update the trailing ! submatrix. if( j0 )return if( upper ) then ! compute the product inv(u) * inv(u)**h. - jj = 0 + jj = 0_${ik}$ do j = 1, n - jc = jj + 1 + jc = jj + 1_${ik}$ jj = jj + j - if( j>1 )call stdlib_${ci}$hpr( 'UPPER', j-1, one, ap( jc ), 1, ap ) + if( j>1_${ik}$ )call stdlib${ii}$_${ci}$hpr( 'UPPER', j-1, one, ap( jc ), 1_${ik}$, ap ) ajj = real( ap( jj ),KIND=${ck}$) - call stdlib_${ci}$dscal( j, ajj, ap( jc ), 1 ) + call stdlib${ii}$_${ci}$dscal( j, ajj, ap( jc ), 1_${ik}$ ) end do else ! compute the product inv(l)**h * inv(l). - jj = 1 + jj = 1_${ik}$ do j = 1, n - jjn = jj + n - j + 1 - ap( jj ) = real( stdlib_${ci}$dotc( n-j+1, ap( jj ), 1, ap( jj ), 1 ),KIND=${ck}$) - if( j1 ) then + if( j>1_${ik}$ ) then work( i ) = work( i ) +real( conjg( a( j-1, i ) )*a( j-1, i ),KIND=${ck}$) end if work( n+i ) = real( a( i, i ),KIND=${ck}$) - work( i ) end do - if( j>1 ) then - itemp = maxloc( work( (n+j):(2*n) ), 1 ) - pvt = itemp + j - 1 + if( j>1_${ik}$ ) then + itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) + pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) - if( ajj<=dstop.or.stdlib_${c2ri(ci)}$isnan( ajj ) ) then + if( ajj<=dstop.or.stdlib${ii}$_${c2ri(ci)}$isnan( ajj ) ) then a( j, j ) = ajj go to 190 end if @@ -59684,8 +59675,8 @@ module stdlib_linalg_lapack_${ci}$ if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) - call stdlib_${ci}$swap( j-1, a( 1, j ), 1, a( 1, pvt ), 1 ) - if( pvt1 ) then + if( j>1_${ik}$ ) then work( i ) = work( i ) +real( conjg( a( i, j-1 ) )*a( i, j-1 ),KIND=${ck}$) end if work( n+i ) = real( a( i, i ),KIND=${ck}$) - work( i ) end do - if( j>1 ) then - itemp = maxloc( work( (n+j):(2*n) ), 1 ) - pvt = itemp + j - 1 + if( j>1_${ik}$ ) then + itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) + pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) - if( ajj<=dstop.or.stdlib_${c2ri(ci)}$isnan( ajj ) ) then + if( ajj<=dstop.or.stdlib${ii}$_${c2ri(ci)}$isnan( ajj ) ) then a( j, j ) = ajj go to 190 end if @@ -59737,8 +59728,8 @@ module stdlib_linalg_lapack_${ci}$ if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) - call stdlib_${ci}$swap( j-1, a( j, 1 ), lda, a( pvt, 1 ), lda ) - if( pvt=n ) then + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code - call stdlib_${ci}$pstf2( uplo, n, a( 1, 1 ), lda, piv, rank, tol, work,info ) + call stdlib${ii}$_${ci}$pstf2( uplo, n, a( 1_${ik}$, 1_${ik}$ ), lda, piv, rank, tol, work,info ) go to 230 else ! initialize piv @@ -59843,16 +59834,16 @@ module stdlib_linalg_lapack_${ci}$ do i = 1, n work( i ) = real( a( i, i ),KIND=${ck}$) end do - pvt = maxloc( work( 1:n ), 1 ) + pvt = maxloc( work( 1_${ik}$:n ), 1_${ik}$ ) ajj = real( a( pvt, pvt ),KIND=${ck}$) - if( ajj<=zero.or.stdlib_${c2ri(ci)}$isnan( ajj ) ) then - rank = 0 - info = 1 + if( ajj<=zero.or.stdlib${ii}$_${c2ri(ci)}$isnan( ajj ) ) then + rank = 0_${ik}$ + info = 1_${ik}$ go to 230 end if ! compute stopping value if not supplied if( tol1 ) then - itemp = maxloc( work( (n+j):(2*n) ), 1 ) - pvt = itemp + j - 1 + if( j>1_${ik}$ ) then + itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) + pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) - if( ajj<=dstop.or.stdlib_${c2ri(ci)}$isnan( ajj ) ) then + if( ajj<=dstop.or.stdlib${ii}$_${c2ri(ci)}$isnan( ajj ) ) then a( j, j ) = ajj go to 220 end if @@ -59889,8 +59880,8 @@ module stdlib_linalg_lapack_${ci}$ if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) - call stdlib_${ci}$swap( j-1, a( 1, j ), 1, a( 1, pvt ), 1 ) - if( pvt1 ) then - itemp = maxloc( work( (n+j):(2*n) ), 1 ) - pvt = itemp + j - 1 + if( j>1_${ik}$ ) then + itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) + pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) - if( ajj<=dstop.or.stdlib_${c2ri(ci)}$isnan( ajj ) ) then + if( ajj<=dstop.or.stdlib${ii}$_${c2ri(ci)}$isnan( ajj ) ) then a( j, j ) = ajj go to 220 end if @@ -59956,9 +59947,9 @@ module stdlib_linalg_lapack_${ci}$ if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) - call stdlib_${ci}$swap( j-1, a( j, 1 ), lda, a( pvt, 1 ), lda ) - if( pvt0 .and. ldz0_${ik}$ .and. ldz0 )z( 1, 1 ) = cone + if( n==1_${ik}$ ) then + if( icompz>0_${ik}$ )z( 1_${ik}$, 1_${ik}$ ) = cone return end if - if( icompz==2 )call stdlib_${ci}$laset( 'FULL', n, n, czero, cone, z, ldz ) - ! call stdlib_${c2ri(ci)}$pttrf to factor the matrix. - call stdlib_${c2ri(ci)}$pttrf( n, d, e, info ) + if( icompz==2_${ik}$ )call stdlib${ii}$_${ci}$laset( 'FULL', n, n, czero, cone, z, ldz ) + ! call stdlib${ii}$_${c2ri(ci)}$pttrf to factor the matrix. + call stdlib${ii}$_${c2ri(ci)}$pttrf( n, d, e, info ) if( info/=0 )return do i = 1, n d( i ) = sqrt( d( i ) ) @@ -60153,17 +60144,17 @@ module stdlib_linalg_lapack_${ci}$ do i = 1, n - 1 e( i ) = e( i )*d( i ) end do - ! call stdlib_${ci}$bdsqr to compute the singular values/vectors of the + ! call stdlib${ii}$_${ci}$bdsqr to compute the singular values/vectors of the ! bidiagonal factor. - if( icompz>0 ) then + if( icompz>0_${ik}$ ) then nru = n else - nru = 0 + nru = 0_${ik}$ end if - call stdlib_${ci}$bdsqr( 'LOWER', n, 0, nru, 0, d, e, vt, 1, z, ldz, c, 1,work, info ) + call stdlib${ii}$_${ci}$bdsqr( 'LOWER', n, 0_${ik}$, nru, 0_${ik}$, d, e, vt, 1_${ik}$, z, ldz, c, 1_${ik}$,work, info ) ! square the singular values. - if( info==0 ) then + if( info==0_${ik}$ ) then do i = 1, n d( i ) = d( i )*d( i ) end do @@ -60171,10 +60162,10 @@ module stdlib_linalg_lapack_${ci}$ info = n + info end if return - end subroutine stdlib_${ci}$pteqr + end subroutine stdlib${ii}$_${ci}$pteqr - pure subroutine stdlib_${ci}$ptrfs( uplo, n, nrhs, d, e, df, ef, b, ldb, x, ldx,ferr, berr, work, & + pure subroutine stdlib${ii}$_${ci}$ptrfs( uplo, n, nrhs, d, e, df, ef, b, ldb, x, ldx,ferr, berr, work, & !! ZPTRFS: improves the computed solution to a system of linear !! equations when the coefficient matrix is Hermitian positive definite !! and tridiagonal, and provides error bounds and backward error @@ -60185,8 +60176,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs ! Array Arguments real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*) real(${ck}$), intent(in) :: d(*), df(*) @@ -60195,7 +60186,7 @@ module stdlib_linalg_lapack_${ci}$ complex(${ck}$), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: itmax = 5 + integer(${ik}$), parameter :: itmax = 5_${ik}$ @@ -60203,7 +60194,7 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: upper - integer(ilp) :: count, i, ix, j, nz + integer(${ik}$) :: count, i, ix, j, nz real(${ck}$) :: eps, lstres, s, safe1, safe2, safmin complex(${ck}$) :: bi, cx, dx, ex, zdum ! Intrinsic Functions @@ -60214,25 +60205,25 @@ module stdlib_linalg_lapack_${ci}$ cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! 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( nrhs<0 ) then - info = -3 - else if( ldbeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_${ci}$pttrs( uplo, n, 1, df, ef, work, n, info ) - call stdlib_${ci}$axpy( n, cmplx( one,KIND=${ck}$), work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_${ci}$pttrs( uplo, n, 1_${ik}$, df, ef, work, n, info ) + call stdlib${ii}$_${ci}$axpy( n, cmplx( one,KIND=${ck}$), work, 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 @@ -60361,7 +60352,7 @@ module stdlib_linalg_lapack_${ci}$ rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - ix = stdlib_i${c2ri(ci)}$amax( n, rwork, 1 ) + ix = stdlib${ii}$_i${c2ri(ci)}$amax( n, rwork, 1_${ik}$ ) ferr( j ) = rwork( ix ) ! estimate the norm of inv(a). ! solve m(a) * x = e, where m(a) = (m(i,j)) is given by @@ -60369,7 +60360,7 @@ module stdlib_linalg_lapack_${ci}$ ! m(i,j) = -abs(a(i,j)), i .ne. j, ! and e = [ 1, 1, ..., 1 ]**t. note m(a) = m(l)*d*m(l)**h. ! solve m(l) * x = e. - rwork( 1 ) = one + rwork( 1_${ik}$ ) = one do i = 2, n rwork( i ) = one + rwork( i-1 )*abs( ef( i-1 ) ) end do @@ -60379,7 +60370,7 @@ module stdlib_linalg_lapack_${ci}$ rwork( i ) = rwork( i ) / df( i ) +rwork( i+1 )*abs( ef( i ) ) end do ! compute norm(inv(a)) = max(x(i)), 1<=i<=n. - ix = stdlib_i${c2ri(ci)}$amax( n, rwork, 1 ) + ix = stdlib${ii}$_i${c2ri(ci)}$amax( n, rwork, 1_${ik}$ ) ferr( j ) = ferr( j )*abs( rwork( ix ) ) ! normalize error. lstres = zero @@ -60389,10 +60380,10 @@ module stdlib_linalg_lapack_${ci}$ if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_100 return - end subroutine stdlib_${ci}$ptrfs + end subroutine stdlib${ii}$_${ci}$ptrfs - pure subroutine stdlib_${ci}$ptsv( n, nrhs, d, e, b, ldb, info ) + pure subroutine stdlib${ii}$_${ci}$ptsv( n, nrhs, d, e, b, ldb, info ) !! ZPTSV: computes the solution to a complex system of linear equations !! A*X = B, where A is an N-by-N Hermitian positive definite tridiagonal !! matrix, and X and B are N-by-NRHS matrices. @@ -60402,8 +60393,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments real(${ck}$), intent(inout) :: d(*) complex(${ck}$), intent(inout) :: b(ldb,*), e(*) @@ -60412,29 +60403,29 @@ module stdlib_linalg_lapack_${ci}$ intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 - if( n<0 ) then - info = -1 - else if( nrhs<0 ) then - info = -2 - else if( ldb1 )call stdlib_${ci}$copy( n-1, e, 1, ef, 1 ) - call stdlib_${ci}$pttrf( n, df, ef, info ) + call stdlib${ii}$_${c2ri(ci)}$copy( n, d, 1_${ik}$, df, 1_${ik}$ ) + if( n>1_${ik}$ )call stdlib${ii}$_${ci}$copy( n-1, e, 1_${ik}$, ef, 1_${ik}$ ) + call stdlib${ii}$_${ci}$pttrf( n, df, ef, info ) ! return if info is non-zero. - if( info>0 )then + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_${ci}$lanht( '1', n, d, e ) + anorm = stdlib${ii}$_${ci}$lanht( '1', n, d, e ) ! compute the reciprocal of the condition number of a. - call stdlib_${ci}$ptcon( n, df, ef, anorm, rcond, rwork, info ) + call stdlib${ii}$_${ci}$ptcon( n, df, ef, anorm, rcond, rwork, info ) ! compute the solution vectors x. - call stdlib_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_${ci}$pttrs( 'LOWER', n, nrhs, df, ef, x, ldx, info ) + call stdlib${ii}$_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_${ci}$pttrs( 'LOWER', n, nrhs, df, ef, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_${ci}$ptrfs( 'LOWER', n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr,berr, work, & + call stdlib${ii}$_${ci}$ptrfs( 'LOWER', n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr,berr, work, & rwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond=nrhs ) then - call stdlib_${ci}$ptts2( iuplo, n, nrhs, d, e, b, ldb ) + call stdlib${ii}$_${ci}$ptts2( iuplo, n, nrhs, d, e, b, ldb ) else do j = 1, nrhs, nb jb = min( nrhs-j+1, nb ) - call stdlib_${ci}$ptts2( iuplo, n, jb, d, e, b( 1, j ), ldb ) + call stdlib${ii}$_${ci}$ptts2( iuplo, n, jb, d, e, b( 1_${ik}$, j ), ldb ) end do end if return - end subroutine stdlib_${ci}$pttrs + end subroutine stdlib${ii}$_${ci}$pttrs - pure subroutine stdlib_${ci}$ptts2( iuplo, n, nrhs, d, e, b, ldb ) + pure subroutine stdlib${ii}$_${ci}$ptts2( iuplo, n, nrhs, d, e, b, ldb ) !! ZPTTS2: solves a tridiagonal system of the form !! A * X = B !! using the factorization A = U**H *D*U or A = L*D*L**H computed by ZPTTRF. @@ -60688,27 +60679,27 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: iuplo, ldb, n, nrhs + integer(${ik}$), intent(in) :: iuplo, ldb, n, nrhs ! Array Arguments real(${ck}$), intent(in) :: d(*) complex(${ck}$), intent(inout) :: b(ldb,*) complex(${ck}$), intent(in) :: e(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Intrinsic Functions intrinsic :: conjg ! Executable Statements ! quick return if possible - if( n<=1 ) then - if( n==1 )call stdlib_${ci}$dscal( nrhs, 1._${ck}$ / d( 1 ), b, ldb ) + if( n<=1_${ik}$ ) then + if( n==1_${ik}$ )call stdlib${ii}$_${ci}$dscal( nrhs, 1._${ck}$ / d( 1_${ik}$ ), b, ldb ) return end if - if( iuplo==1 ) then + if( iuplo==1_${ik}$ ) then ! solve a * x = b using the factorization a = u**h *d*u, ! overwriting each right hand side vector with its solution. - if( nrhs<=2 ) then - j = 1 + if( nrhs<=2_${ik}$ ) then + j = 1_${ik}$ 10 continue ! solve u**h * x = b. do i = 2, n @@ -60722,7 +60713,7 @@ module stdlib_linalg_lapack_${ci}$ b( i, j ) = b( i, j ) - b( i+1, j )*e( i ) end do if( j0 .and. ap( ip )==zero )return ip = ip - i end do else ! lower triangular storage: examine d from top to bottom. - ip = 1 + ip = 1_${ik}$ do i = 1, n if( ipiv( i )>0 .and. ap( ip )==zero )return - ip = ip + n - i + 1 + ip = ip + n - i + 1_${ik}$ end do end if ! estimate the 1-norm of the inverse. - kase = 0 + kase = 0_${ik}$ 30 continue - call stdlib_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + if( kase/=0_${ik}$ ) then ! multiply by inv(l*d*l**t) or inv(u*d*u**t). - call stdlib_${ci}$sptrs( uplo, n, 1, ap, ipiv, work, n, info ) + call stdlib${ii}$_${ci}$sptrs( uplo, n, 1_${ik}$, ap, ipiv, work, n, info ) go to 30 end if ! compute the estimate of the reciprocal condition number. if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm return - end subroutine stdlib_${ci}$spcon + end subroutine stdlib${ii}$_${ci}$spcon - pure subroutine stdlib_${ci}$spmv( uplo, n, alpha, ap, x, incx, beta, y, incy ) + pure subroutine stdlib${ii}$_${ci}$spmv( uplo, n, alpha, ap, x, incx, beta, y, incy ) !! ZSPMV: performs the matrix-vector operation !! y := alpha*A*x + beta*y, !! where alpha and beta are scalars, x and y are n element vectors and @@ -60913,7 +60904,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: incx, incy, n + integer(${ik}$), intent(in) :: incx, incy, n complex(${ck}$), intent(in) :: alpha, beta ! Array Arguments complex(${ck}$), intent(in) :: ap(*), x(*) @@ -60922,42 +60913,42 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars - 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 complex(${ck}$) :: temp1, temp2 ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = 1 - else if( n<0 ) then - info = 2 - else if( incx==0 ) then - info = 6 - else if( incy==0 ) then - info = 9 + info = 1_${ik}$ + else if( n<0_${ik}$ ) then + info = 2_${ik}$ + else if( incx==0_${ik}$ ) then + info = 6_${ik}$ + else if( incy==0_${ik}$ ) then + info = 9_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'ZSPMV ', info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZSPMV ', info ) return end if ! quick return if possible. if( ( n==0 ) .or. ( ( alpha==czero ) .and. ( beta==cone ) ) )return ! set up the start points in x and y. - if( incx>0 ) then - kx = 1 + if( incx>0_${ik}$ ) then + kx = 1_${ik}$ else - kx = 1 - ( n-1 )*incx + kx = 1_${ik}$ - ( n-1 )*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 )*incy end if ! start the operations. in this version the elements of the array ap ! are accessed sequentially with cone pass through ap. ! first form y := beta*y. if( beta/=cone ) then - if( incy==1 ) then + if( incy==1_${ik}$ ) then if( beta==czero ) then do i = 1, n y( i ) = czero @@ -60983,10 +60974,10 @@ module stdlib_linalg_lapack_${ci}$ end if end if if( alpha==czero )return - kk = 1 + kk = 1_${ik}$ if( stdlib_lsame( uplo, 'U' ) ) then ! form y when ap contains the upper triangle. - if( ( incx==1 ) .and. ( incy==1 ) ) then + if( ( incx==1_${ik}$ ) .and. ( incy==1_${ik}$ ) ) then do j = 1, n temp1 = alpha*x( j ) temp2 = czero @@ -60994,7 +60985,7 @@ module stdlib_linalg_lapack_${ci}$ do i = 1, j - 1 y( i ) = y( i ) + temp1*ap( k ) temp2 = temp2 + ap( k )*x( i ) - k = k + 1 + k = k + 1_${ik}$ end do y( j ) = y( j ) + temp1*ap( kk+j-1 ) + alpha*temp2 kk = kk + j @@ -61021,16 +61012,16 @@ module stdlib_linalg_lapack_${ci}$ end if else ! form y when ap contains the lower triangle. - if( ( incx==1 ) .and. ( incy==1 ) ) then + if( ( incx==1_${ik}$ ) .and. ( incy==1_${ik}$ ) ) then do j = 1, n temp1 = alpha*x( j ) temp2 = czero y( j ) = y( j ) + temp1*ap( kk ) - k = kk + 1 + k = kk + 1_${ik}$ do i = j + 1, n y( i ) = y( i ) + temp1*ap( k ) temp2 = temp2 + ap( k )*x( i ) - k = k + 1 + k = k + 1_${ik}$ end do y( j ) = y( j ) + alpha*temp2 kk = kk + ( n-j+1 ) @@ -61058,10 +61049,10 @@ module stdlib_linalg_lapack_${ci}$ end if end if return - end subroutine stdlib_${ci}$spmv + end subroutine stdlib${ii}$_${ci}$spmv - pure subroutine stdlib_${ci}$spr( uplo, n, alpha, x, incx, ap ) + pure subroutine stdlib${ii}$_${ci}$spr( uplo, n, alpha, x, incx, ap ) !! ZSPR: performs the symmetric rank 1 operation !! A := alpha*x*x**H + A, !! where alpha is a complex scalar, x is an n element vector and A is an @@ -61071,7 +61062,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n complex(${ck}$), intent(in) :: alpha ! Array Arguments complex(${ck}$), intent(inout) :: ap(*) @@ -61079,43 +61070,43 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! Local Scalars - integer(ilp) :: i, info, ix, j, jx, k, kk, kx + integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx complex(${ck}$) :: temp ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = 1 - else if( n<0 ) then - info = 2 - else if( incx==0 ) then - info = 5 + info = 1_${ik}$ + else if( n<0_${ik}$ ) then + info = 2_${ik}$ + else if( incx==0_${ik}$ ) then + info = 5_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'ZSPR ', info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZSPR ', info ) return end if ! quick return if possible. if( ( n==0 ) .or. ( alpha==czero ) )return ! set the start point in x if the increment is not unity. - if( incx<=0 ) then - kx = 1 - ( n-1 )*incx - else if( incx/=1 ) then - kx = 1 + if( incx<=0_${ik}$ ) then + kx = 1_${ik}$ - ( n-1 )*incx + else if( incx/=1_${ik}$ ) then + kx = 1_${ik}$ end if ! start the operations. in this version the elements of the array ap ! are accessed sequentially with cone pass through ap. - kk = 1 + kk = 1_${ik}$ if( stdlib_lsame( uplo, 'U' ) ) then ! form a when upper triangle is stored in ap. - if( incx==1 ) then + if( incx==1_${ik}$ ) then do j = 1, n if( x( j )/=czero ) then temp = alpha*x( j ) k = kk do i = 1, j - 1 ap( k ) = ap( k ) + x( i )*temp - k = k + 1 + k = k + 1_${ik}$ end do ap( kk+j-1 ) = ap( kk+j-1 ) + x( j )*temp else @@ -61143,20 +61134,20 @@ module stdlib_linalg_lapack_${ci}$ end if else ! form a when lower triangle is stored in ap. - if( incx==1 ) then + if( incx==1_${ik}$ ) then do j = 1, n if( x( j )/=czero ) then temp = alpha*x( j ) ap( kk ) = ap( kk ) + temp*x( j ) - k = kk + 1 + k = kk + 1_${ik}$ do i = j + 1, n ap( k ) = ap( k ) + x( i )*temp - k = k + 1 + k = k + 1_${ik}$ end do else ap( kk ) = ap( kk ) end if - kk = kk + n - j + 1 + kk = kk + n - j + 1_${ik}$ end do else jx = kx @@ -61173,15 +61164,15 @@ module stdlib_linalg_lapack_${ci}$ ap( kk ) = ap( kk ) end if jx = jx + incx - kk = kk + n - j + 1 + kk = kk + n - j + 1_${ik}$ end do end if end if return - end subroutine stdlib_${ci}$spr + end subroutine stdlib${ii}$_${ci}$spr - pure subroutine stdlib_${ci}$sprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,& + pure subroutine stdlib${ii}$_${ci}$sprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,& !! ZSPRFS: improves the computed solution to a system of linear !! equations when the coefficient matrix is symmetric indefinite !! and packed, and provides error bounds and backward error estimates @@ -61192,17 +61183,17 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) real(${ck}$), intent(out) :: berr(*), ferr(*), rwork(*) complex(${ck}$), intent(in) :: afp(*), ap(*), b(ldb,*) complex(${ck}$), intent(out) :: work(*) complex(${ck}$), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: itmax = 5 + integer(${ik}$), parameter :: itmax = 5_${ik}$ @@ -61210,11 +61201,11 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: upper - integer(ilp) :: count, i, ik, j, k, kase, kk, nz + integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz real(${ck}$) :: eps, lstres, s, safe1, safe2, safmin, xk complex(${ck}$) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,aimag,max ! Statement Functions @@ -61223,25 +61214,25 @@ module stdlib_linalg_lapack_${ci}$ cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! 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( nrhs<0 ) then - info = -3 - else if( ldbeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_${ci}$sptrs( uplo, n, 1, afp, ipiv, work, n, info ) - call stdlib_${ci}$axpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_${ci}$sptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info ) + call stdlib${ii}$_${ci}$axpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -61348,22 +61339,22 @@ module stdlib_linalg_lapack_${ci}$ rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**t). - call stdlib_${ci}$sptrs( uplo, n, 1, afp, ipiv, work, n, info ) + call stdlib${ii}$_${ci}$sptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do - else if( kase==2 ) then + else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_${ci}$sptrs( uplo, n, 1, afp, ipiv, work, n, info ) + call stdlib${ii}$_${ci}$sptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info ) end if go to 100 end if @@ -61375,10 +61366,10 @@ module stdlib_linalg_lapack_${ci}$ if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_${ci}$sprfs + end subroutine stdlib${ii}$_${ci}$sprfs - pure subroutine stdlib_${ci}$spsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) + pure subroutine stdlib${ii}$_${ci}$spsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) !! ZSPSV: computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N symmetric matrix stored in packed format and X @@ -61395,41 +61386,41 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(${ck}$), intent(inout) :: ap(*), b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .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( ldb0 )then + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_${ci}$lansp( 'I', uplo, n, ap, rwork ) + anorm = stdlib${ii}$_${ci}$lansp( 'I', uplo, n, ap, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_${ci}$spcon( uplo, n, afp, ipiv, anorm, rcond, work, info ) + call stdlib${ii}$_${ci}$spcon( uplo, n, afp, ipiv, anorm, rcond, work, info ) ! compute the solution vectors x. - call stdlib_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_${ci}$sptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info ) + call stdlib${ii}$_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_${ci}$sptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_${ci}$sprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, & + call stdlib${ii}$_${ci}$sprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, & rwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond1 ) then - imax = stdlib_i${ci}$amax( k-1, ap( kc ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_i${ci}$amax( k-1, ap( kc ), 1_${ik}$ ) colmax = cabs1( 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 @@ -61590,7 +61581,7 @@ module stdlib_linalg_lapack_${ci}$ else rowmax = zero jmax = imax - kx = imax*( imax+1 ) / 2 + imax + kx = imax*( imax+1 ) / 2_${ik}$ + imax do j = imax + 1, k if( cabs1( ap( kx ) )>rowmax ) then rowmax = cabs1( ap( kx ) ) @@ -61598,9 +61589,9 @@ module stdlib_linalg_lapack_${ci}$ end if kx = kx + j end do - kpc = ( imax-1 )*imax / 2 + 1 - if( imax>1 ) then - jmax = stdlib_i${ci}$amax( imax-1, ap( kpc ), 1 ) + kpc = ( imax-1 )*imax / 2_${ik}$ + 1_${ik}$ + if( imax>1_${ik}$ ) then + jmax = stdlib${ii}$_i${ci}$amax( imax-1, ap( kpc ), 1_${ik}$ ) rowmax = max( rowmax, cabs1( ap( kpc+jmax-1 ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then @@ -61614,18 +61605,18 @@ module stdlib_linalg_lapack_${ci}$ ! interchange rows and columns k-1 and imax, use 2-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_${ci}$swap( kp-1, ap( knc ), 1, ap( kpc ), 1 ) - kx = kpc + kp - 1 + call stdlib${ii}$_${ci}$swap( 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 @@ -61633,23 +61624,23 @@ module stdlib_linalg_lapack_${ci}$ 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 + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u ! perform a rank-1 update of a(1:k-1,1:k-1) as ! a := a - u(k)*d(k)*u(k)**t = a - w(k)*1/d(k)*w(k)**t r1 = cone / ap( kc+k-1 ) - call stdlib_${ci}$spr( uplo, k-1, -r1, ap( kc ), 1, ap ) + call stdlib${ii}$_${ci}$spr( uplo, k-1, -r1, ap( kc ), 1_${ik}$, ap ) ! store u(k) in column k - call stdlib_${ci}$scal( k-1, r1, ap( kc ), 1 ) + call stdlib${ii}$_${ci}$scal( k-1, r1, ap( kc ), 1_${ik}$ ) else ! 2-by-2 pivot block d(k): columns k and k-1 now hold ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k) @@ -61658,29 +61649,29 @@ module stdlib_linalg_lapack_${ci}$ ! perform a rank-2 update of a(1:k-2,1:k-2) as ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**t ! = a - ( 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 = cone / ( d11*d22-cone ) 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 @@ -61694,28 +61685,28 @@ module stdlib_linalg_lapack_${ci}$ ! 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 = 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 absakk = cabs1( 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 @@ -61733,9 +61724,9 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -61749,19 +61740,19 @@ module stdlib_linalg_lapack_${ci}$ ! interchange rows and columns k+1 and imax, use 2-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 )==czero )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 )==czero )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 = 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. ap( kc+k-1 ) = cone / ap( kc+k-1 ) ! compute column k of the inverse. - if( k>1 ) then - call stdlib_${ci}$copy( k-1, ap( kc ), 1, work, 1 ) - call stdlib_${ci}$spmv( uplo, k-1, -cone, ap, work, 1, czero, ap( kc ),1 ) - ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib_${ci}$dotu( k-1, work, 1, ap( kc ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_${ci}$copy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$spmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero, ap( kc ),1_${ik}$ ) + ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_${ci}$dotu( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ ) end if - kstep = 1 + kstep = 1_${ik}$ else ! 2 x 2 diagonal block ! invert the diagonal block. @@ -61924,30 +61915,30 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$copy( k-1, ap( kc ), 1, work, 1 ) - call stdlib_${ci}$spmv( uplo, k-1, -cone, ap, work, 1, czero, ap( kc ),1 ) - ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib_${ci}$dotu( k-1, work, 1, ap( kc ), 1 ) - ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib_${ci}$dotu( k-1, ap( kc ), 1, ap( & - kcnext ),1 ) - call stdlib_${ci}$copy( k-1, ap( kcnext ), 1, work, 1 ) - call stdlib_${ci}$spmv( uplo, k-1, -cone, ap, work, 1, czero,ap( kcnext ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_${ci}$copy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$spmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero, ap( kc ),1_${ik}$ ) + ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_${ci}$dotu( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ ) + ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib${ii}$_${ci}$dotu( k-1, ap( kc ), 1_${ik}$, ap( & + kcnext ),1_${ik}$ ) + call stdlib${ii}$_${ci}$copy( k-1, ap( kcnext ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$spmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kcnext ), 1_${ik}$ ) - ap( kcnext+k ) = ap( kcnext+k ) -stdlib_${ci}$dotu( k-1, work, 1, ap( kcnext ), 1 ) + ap( kcnext+k ) = ap( kcnext+k ) -stdlib${ii}$_${ci}$dotu( 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_${ci}$swap( kp-1, ap( kc ), 1, ap( kpc ), 1 ) - kx = kpc + kp - 1 + kpc = ( kp-1 )*kp / 2_${ik}$ + 1_${ik}$ + call stdlib${ii}$_${ci}$swap( kp-1, ap( kc ), 1_${ik}$, ap( kpc ), 1_${ik}$ ) + kx = kpc + kp - 1_${ik}$ do j = kp + 1, k - 1 - kx = kx + j - 1 + kx = kx + j - 1_${ik}$ temp = ap( kc+j-1 ) ap( kc+j-1 ) = ap( kx ) ap( kx ) = temp @@ -61955,7 +61946,7 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -61969,25 +61960,25 @@ module stdlib_linalg_lapack_${ci}$ ! 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 + 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. ap( kc ) = cone / ap( kc ) ! compute column k of the inverse. if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_${ci}$geru( k-1, nrhs, -cone, ap( kc ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb ) + call stdlib${ii}$_${ci}$geru( k-1, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb ) ! multiply by the inverse of the diagonal block. - call stdlib_${ci}$scal( nrhs, cone / ap( kc+k-1 ), b( k, 1 ), ldb ) - k = k - 1 + call stdlib${ii}$_${ci}$scal( nrhs, cone / ap( kc+k-1 ), b( k, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( kp/=k-1 )call stdlib_${ci}$swap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib${ii}$_${ci}$swap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - call stdlib_${ci}$geru( k-2, nrhs, -cone, ap( kc ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb ) + call stdlib${ii}$_${ci}$geru( k-2, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb ) - call stdlib_${ci}$geru( k-2, nrhs, -cone, ap( kc-( k-1 ) ), 1,b( k-1, 1 ), ldb, b( 1, & - 1 ), ldb ) + call stdlib${ii}$_${ci}$geru( k-2, nrhs, -cone, ap( kc-( k-1 ) ), 1_${ik}$,b( k-1, 1_${ik}$ ), ldb, b( 1_${ik}$, & + 1_${ik}$ ), ldb ) ! multiply by the inverse of the diagonal block. akm1k = ap( kc+k-2 ) akm1 = ap( kc-1 ) / akm1k @@ -62133,43 +62124,43 @@ module stdlib_linalg_lapack_${ci}$ 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 = 1_${ik}$ + kc = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(u**t(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, ap( kc ),1, cone, b( k,& - 1 ), ldb ) + call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, ap( kc ),1_${ik}$, cone, b( k,& + 1_${ik}$ ), ldb ) ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) kc = kc + k - k = k + 1 + k = k + 1_${ik}$ else ! 2 x 2 diagonal block ! multiply by inv(u**t(k+1)), where u(k+1) is the transformation ! stored in columns k and k+1 of a. - call stdlib_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, ap( kc ),1, cone, b( k,& - 1 ), ldb ) - call stdlib_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb,ap( kc+k ), 1, cone, b( & - k+1, 1 ), ldb ) + call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, ap( kc ),1_${ik}$, cone, b( k,& + 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb,ap( kc+k ), 1_${ik}$, cone, b( & + k+1, 1_${ik}$ ), ldb ) ! interchange rows k and -ipiv(k). kp = -ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - kc = kc + 2*k + 1 - k = k + 2 + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + kc = kc + 2_${ik}$*k + 1_${ik}$ + k = k + 2_${ik}$ end if go to 40 50 continue @@ -62178,36 +62169,36 @@ module stdlib_linalg_lapack_${ci}$ ! 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 = 1_${ik}$ + kc = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(l**t(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 .and. ldz0_${ik}$ .and. ldztiny ) then - finish = finish + 1 + finish = finish + 1_${ik}$ go to 40 end if end if ! (sub) problem determined. compute its size and solve it. - m = finish - start + 1 + m = finish - start + 1_${ik}$ if( m>smlsiz ) then ! scale. - orgnrm = stdlib_${c2ri(ci)}$lanst( 'M', m, d( start ), e( start ) ) - call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, orgnrm, one, m, 1, d( start ), m,info ) - call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, orgnrm, one, m-1, 1, e( start ),m-1, info ) + orgnrm = stdlib${ii}$_${c2ri(ci)}$lanst( 'M', m, d( start ), e( start ) ) + call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, m, 1_${ik}$, d( start ), m,info ) + call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, m-1, 1_${ik}$, e( start ),m-1, info ) - call stdlib_${ci}$laed0( n, m, d( start ), e( start ), z( 1, start ),ldz, work, n, & + call stdlib${ii}$_${ci}$laed0( n, m, d( start ), e( start ), z( 1_${ik}$, start ),ldz, work, n, & rwork, iwork, info ) - if( info>0 ) then + if( info>0_${ik}$ ) then info = ( info / ( m+1 )+start-1 )*( n+1 ) +mod( info, ( m+1 ) ) + start - & - 1 + 1_${ik}$ go to 70 end if ! scale back. - call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, one, orgnrm, m, 1, d( start ), m,info ) + call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, m, 1_${ik}$, d( start ), m,info ) else - call stdlib_${c2ri(ci)}$steqr( 'I', m, d( start ), e( start ), rwork, m,rwork( m*m+1 ), & + call stdlib${ii}$_${c2ri(ci)}$steqr( 'I', m, d( start ), e( start ), rwork, m,rwork( m*m+1 ), & info ) - call stdlib_${ci}$lacrm( n, m, z( 1, start ), ldz, rwork, m, work, n,rwork( m*m+1 )& + call stdlib${ii}$_${ci}$lacrm( n, m, z( 1_${ik}$, start ), ldz, rwork, m, work, n,rwork( m*m+1 )& ) - call stdlib_${ci}$lacpy( 'A', n, m, work, n, z( 1, start ), ldz ) - if( info>0 ) then + call stdlib${ii}$_${ci}$lacpy( 'A', n, m, work, n, z( 1_${ik}$, start ), ldz ) + if( info>0_${ik}$ ) then info = start*( n+1 ) + finish go to 70 end if end if - start = finish + 1 + start = finish + 1_${ik}$ go to 30 end if ! endwhile ! use selection sort to minimize swaps of eigenvectors do ii = 2, n - i = ii - 1 + i = ii - 1_${ik}$ k = i p = d( i ) do j = ii, n @@ -62469,19 +62460,19 @@ module stdlib_linalg_lapack_${ci}$ if( k/=i ) then d( k ) = d( i ) d( i ) = p - call stdlib_${ci}$swap( n, z( 1, i ), 1, z( 1, k ), 1 ) + call stdlib${ii}$_${ci}$swap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, k ), 1_${ik}$ ) end if end do end if 70 continue - work( 1 ) = lwmin - rwork( 1 ) = lrwmin - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = lwmin + rwork( 1_${ik}$ ) = lrwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_${ci}$stedc + end subroutine stdlib${ii}$_${ci}$stedc - pure subroutine stdlib_${ci}$stegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, & + pure subroutine stdlib${ii}$_${ci}$stegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, & !! ZSTEGR: computes selected eigenvalues and, optionally, eigenvectors !! of a real symmetric tridiagonal matrix T. Any such unreduced matrix has !! a well defined set of pairwise different real eigenvalues, the corresponding @@ -62504,11 +62495,11 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range - integer(ilp), intent(in) :: il, iu, ldz, liwork, lwork, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, iu, ldz, liwork, lwork, n + integer(${ik}$), intent(out) :: info, m real(${ck}$), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: isuppz(*), iwork(*) + integer(${ik}$), intent(out) :: isuppz(*), iwork(*) real(${ck}$), intent(inout) :: d(*), e(*) real(${ck}$), intent(out) :: w(*), work(*) complex(${ck}$), intent(out) :: z(ldz,*) @@ -62516,14 +62507,14 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: tryrac ! Executable Statements - info = 0 + info = 0_${ik}$ tryrac = .false. - call stdlib_${ci}$stemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, n, isuppz, & + call stdlib${ii}$_${ci}$stemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, n, isuppz, & tryrac, work, lwork,iwork, liwork, info ) - end subroutine stdlib_${ci}$stegr + end subroutine stdlib${ii}$_${ci}$stegr - pure subroutine stdlib_${ci}$stein( n, d, e, m, w, iblock, isplit, z, ldz, work,iwork, ifail, & + pure subroutine stdlib${ii}$_${ci}$stein( n, d, e, m, w, iblock, isplit, z, ldz, work,iwork, ifail, & !! ZSTEIN: computes the eigenvectors of a real symmetric tridiagonal !! matrix T corresponding to specified eigenvalues, using inverse !! iteration. @@ -62538,11 +62529,11 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: ldz, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldz, m, n ! Array Arguments - integer(ilp), intent(in) :: iblock(*), isplit(*) - integer(ilp), intent(out) :: ifail(*), iwork(*) + integer(${ik}$), intent(in) :: iblock(*), isplit(*) + integer(${ik}$), intent(out) :: ifail(*), iwork(*) real(${ck}$), intent(in) :: d(*), e(*), w(*) real(${ck}$), intent(out) :: work(*) complex(${ck}$), intent(out) :: z(ldz,*) @@ -62550,79 +62541,79 @@ module stdlib_linalg_lapack_${ci}$ ! Parameters real(${ck}$), parameter :: odm3 = 1.0e-3_${ck}$ real(${ck}$), parameter :: odm1 = 1.0e-1_${ck}$ - integer(ilp), parameter :: maxits = 5 - integer(ilp), parameter :: extra = 2 + integer(${ik}$), parameter :: maxits = 5_${ik}$ + integer(${ik}$), parameter :: extra = 2_${ik}$ ! Local Scalars - integer(ilp) :: b1, blksiz, bn, gpind, i, iinfo, indrv1, indrv2, indrv3, indrv4, & + integer(${ik}$) :: b1, blksiz, bn, gpind, i, iinfo, indrv1, indrv2, indrv3, indrv4, & indrv5, its, j, j1, jblk, jmax, jr, nblk, nrmchk real(${ck}$) :: dtpcrt, eps, eps1, nrm, onenrm, ortol, pertol, scl, sep, tol, xj, xjm, & ztr ! Local Arrays - integer(ilp) :: iseed(4) + integer(${ik}$) :: iseed(4_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,cmplx,max,sqrt ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ do i = 1, m - ifail( i ) = 0 + ifail( i ) = 0_${ik}$ end do - if( n<0 ) then - info = -1 - else if( m<0 .or. m>n ) then - info = -4 - else if( ldzn ) then + info = -4_${ik}$ + else if( ldz1 ) then + if( jblk>1_${ik}$ ) then eps1 = abs( eps*xj ) pertol = ten*eps1 sep = xj - xjm if( sepmaxits )go to 120 ! normalize and scale the righthand side vector pb. - jmax = stdlib_i${c2ri(ci)}$amax( blksiz, work( indrv1+1 ), 1 ) + jmax = stdlib${ii}$_i${c2ri(ci)}$amax( blksiz, work( indrv1+1 ), 1_${ik}$ ) scl = blksiz*onenrm*max( eps,abs( work( indrv4+blksiz ) ) ) /abs( work( indrv1+& jmax ) ) - call stdlib_${c2ri(ci)}$scal( blksiz, scl, work( indrv1+1 ), 1 ) + call stdlib${ii}$_${c2ri(ci)}$scal( blksiz, scl, work( indrv1+1 ), 1_${ik}$ ) ! solve the system lu = pb. - call stdlib_${c2ri(ci)}$lagts( -1, blksiz, work( indrv4+1 ), work( indrv2+2 ),work( indrv3+& - 1 ), work( indrv5+1 ), iwork,work( indrv1+1 ), tol, iinfo ) + call stdlib${ii}$_${c2ri(ci)}$lagts( -1_${ik}$, blksiz, work( indrv4+1 ), work( indrv2+2 ),work( indrv3+& + 1_${ik}$ ), work( indrv5+1 ), iwork,work( indrv1+1 ), tol, iinfo ) ! reorthogonalize by modified gram-schmidt if eigenvalues are ! close enough. if( jblk==1 )go to 110 @@ -62698,25 +62689,25 @@ module stdlib_linalg_lapack_${ci}$ end if ! check the infinity norm of the iterate. 110 continue - jmax = stdlib_i${c2ri(ci)}$amax( blksiz, work( indrv1+1 ), 1 ) + jmax = stdlib${ii}$_i${c2ri(ci)}$amax( blksiz, work( indrv1+1 ), 1_${ik}$ ) nrm = abs( work( indrv1+jmax ) ) ! continue for additional iterations after norm reaches ! stopping criterion. if( nrm0 .and. wu<=wl ) then - info = -7 - else if( indeig .and. ( iil<1 .or. iil>n ) ) then - info = -8 + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( valeig .and. n>0_${ik}$ .and. wu<=wl ) then + info = -7_${ik}$ + else if( indeig .and. ( iil<1_${ik}$ .or. iil>n ) ) then + info = -8_${ik}$ else if( indeig .and. ( iiun ) ) then - info = -9 - else if( ldz<1 .or. ( wantz .and. ldz=d( 1 ) ) then - m = 1 - w( 1 ) = d( 1 ) + if( wl=d( 1_${ik}$ ) ) then + m = 1_${ik}$ + w( 1_${ik}$ ) = d( 1_${ik}$ ) end if end if if( wantz.and.(.not.zquery) ) then - z( 1, 1 ) = one - isuppz(1) = 1 - isuppz(2) = 1 + z( 1_${ik}$, 1_${ik}$ ) = one + isuppz(1_${ik}$) = 1_${ik}$ + isuppz(2_${ik}$) = 1_${ik}$ end if return end if - if( n==2 ) then + if( n==2_${ik}$ ) then if( .not.wantz ) then - call stdlib_${c2ri(ci)}$lae2( d(1), e(1), d(2), r1, r2 ) + call stdlib${ii}$_${c2ri(ci)}$lae2( d(1_${ik}$), e(1_${ik}$), d(2_${ik}$), r1, r2 ) else if( wantz.and.(.not.zquery) ) then - call stdlib_${c2ri(ci)}$laev2( d(1), e(1), d(2), r1, r2, cs, sn ) + call stdlib${ii}$_${c2ri(ci)}$laev2( d(1_${ik}$), e(1_${ik}$), d(2_${ik}$), r1, r2, cs, sn ) end if - if( alleig.or.(valeig.and.(r2>wl).and.(r2<=wu)).or.(indeig.and.(iil==1)) ) & + if( alleig.or.(valeig.and.(r2>wl).and.(r2<=wu)).or.(indeig.and.(iil==1_${ik}$)) ) & then m = m+1 w( m ) = r2 if( wantz.and.(.not.zquery) ) then - z( 1, m ) = -sn - z( 2, m ) = cs + z( 1_${ik}$, m ) = -sn + z( 2_${ik}$, m ) = cs ! note: at most one of sn and cs can be zero. if (sn/=zero) then if (cs/=zero) then - isuppz(2*m-1) = 1 - isuppz(2*m) = 2 + isuppz(2_${ik}$*m-1) = 1_${ik}$ + isuppz(2_${ik}$*m) = 2_${ik}$ else - isuppz(2*m-1) = 1 - isuppz(2*m) = 1 + isuppz(2_${ik}$*m-1) = 1_${ik}$ + isuppz(2_${ik}$*m) = 1_${ik}$ end if else - isuppz(2*m-1) = 2 - isuppz(2*m) = 2 + isuppz(2_${ik}$*m-1) = 2_${ik}$ + isuppz(2_${ik}$*m) = 2_${ik}$ end if endif endif - if( alleig.or.(valeig.and.(r1>wl).and.(r1<=wu)).or.(indeig.and.(iiu==2)) ) & + if( alleig.or.(valeig.and.(r1>wl).and.(r1<=wu)).or.(indeig.and.(iiu==2_${ik}$)) ) & then m = m+1 w( m ) = r1 if( wantz.and.(.not.zquery) ) then - z( 1, m ) = cs - z( 2, m ) = sn + z( 1_${ik}$, m ) = cs + z( 2_${ik}$, m ) = sn ! note: at most one of sn and cs can be zero. if (sn/=zero) then if (cs/=zero) then - isuppz(2*m-1) = 1 - isuppz(2*m) = 2 + isuppz(2_${ik}$*m-1) = 1_${ik}$ + isuppz(2_${ik}$*m) = 2_${ik}$ else - isuppz(2*m-1) = 1 - isuppz(2*m) = 1 + isuppz(2_${ik}$*m-1) = 1_${ik}$ + isuppz(2_${ik}$*m) = 1_${ik}$ end if else - isuppz(2*m-1) = 2 - isuppz(2*m) = 2 + isuppz(2_${ik}$*m-1) = 2_${ik}$ + isuppz(2_${ik}$*m) = 2_${ik}$ end if endif endif else ! continue with general n - indgrs = 1 - inderr = 2*n + 1 - indgp = 3*n + 1 - indd = 4*n + 1 - inde2 = 5*n + 1 - indwrk = 6*n + 1 - iinspl = 1 - iindbl = n + 1 - iindw = 2*n + 1 - iindwk = 3*n + 1 + indgrs = 1_${ik}$ + inderr = 2_${ik}$*n + 1_${ik}$ + indgp = 3_${ik}$*n + 1_${ik}$ + indd = 4_${ik}$*n + 1_${ik}$ + inde2 = 5_${ik}$*n + 1_${ik}$ + indwrk = 6_${ik}$*n + 1_${ik}$ + iinspl = 1_${ik}$ + iindbl = n + 1_${ik}$ + iindw = 2_${ik}$*n + 1_${ik}$ + iindwk = 3_${ik}$*n + 1_${ik}$ ! scale matrix to allowable range, if necessary. ! the allowable range is related to the pivmin parameter; see the - ! comments in stdlib_${c2ri(ci)}$larrd. the preference for scaling small values + ! comments in stdlib${ii}$_${c2ri(ci)}$larrd. the preference for scaling small values ! up is heuristic; we expect users' matrices not to be close to the ! rmax threshold. scale = one - tnrm = stdlib_${c2ri(ci)}$lanst( 'M', n, d, e ) + tnrm = stdlib${ii}$_${c2ri(ci)}$lanst( 'M', n, d, e ) if( tnrm>zero .and. tnrmrmax ) then scale = rmax / tnrm end if if( scale/=one ) then - call stdlib_${c2ri(ci)}$scal( n, scale, d, 1 ) - call stdlib_${c2ri(ci)}$scal( n-1, scale, e, 1 ) + call stdlib${ii}$_${c2ri(ci)}$scal( n, scale, d, 1_${ik}$ ) + call stdlib${ii}$_${c2ri(ci)}$scal( n-1, scale, e, 1_${ik}$ ) tnrm = tnrm*scale if( valeig ) then ! if eigenvalues in interval have to be found, @@ -63017,19 +63008,19 @@ module stdlib_linalg_lapack_${ci}$ ! compute the desired eigenvalues of the tridiagonal after splitting ! into smaller subblocks if the corresponding off-diagonal elements ! are small - ! thresh is the splitting parameter for stdlib_${c2ri(ci)}$larre + ! thresh is the splitting parameter for stdlib${ii}$_${c2ri(ci)}$larre ! a negative thresh forces the old splitting criterion based on the ! size of the off-diagonal. a positive thresh switches to splitting ! which preserves relative accuracy. if( tryrac ) then ! test whether the matrix warrants the more expensive relative approach. - call stdlib_${c2ri(ci)}$larrr( n, d, e, iinfo ) + call stdlib${ii}$_${c2ri(ci)}$larrr( n, d, e, iinfo ) else ! the user does not care about relative accurately eigenvalues - iinfo = -1 + iinfo = -1_${ik}$ endif ! set the splitting criterion - if (iinfo==0) then + if (iinfo==0_${ik}$) then thresh = eps else thresh = -eps @@ -63038,51 +63029,51 @@ module stdlib_linalg_lapack_${ci}$ endif if( tryrac ) then ! copy original diagonal, needed to guarantee relative accuracy - call stdlib_${c2ri(ci)}$copy(n,d,1,work(indd),1) + call stdlib${ii}$_${c2ri(ci)}$copy(n,d,1_${ik}$,work(indd),1_${ik}$) endif ! store the squares of the offdiagonal values of t do j = 1, n-1 - work( inde2+j-1 ) = e(j)**2 + work( inde2+j-1 ) = e(j)**2_${ik}$ end do ! set the tolerance parameters for bisection if( .not.wantz ) then - ! stdlib_${c2ri(ci)}$larre computes the eigenvalues to full precision. + ! stdlib${ii}$_${c2ri(ci)}$larre computes the eigenvalues to full precision. rtol1 = four * eps rtol2 = four * eps else - ! stdlib_${c2ri(ci)}$larre computes the eigenvalues to less than full precision. - ! stdlib_${ci}$larrv will refine the eigenvalue approximations, and we only - ! need less accurate initial bisection in stdlib_${c2ri(ci)}$larre. - ! note: these settings do only affect the subset case and stdlib_${c2ri(ci)}$larre + ! stdlib${ii}$_${c2ri(ci)}$larre computes the eigenvalues to less than full precision. + ! stdlib${ii}$_${ci}$larrv will refine the eigenvalue approximations, and we only + ! need less accurate initial bisection in stdlib${ii}$_${c2ri(ci)}$larre. + ! note: these settings do only affect the subset case and stdlib${ii}$_${c2ri(ci)}$larre rtol1 = sqrt(eps) rtol2 = max( sqrt(eps)*5.0e-3_${ck}$, four * eps ) endif - call stdlib_${c2ri(ci)}$larre( range, n, wl, wu, iil, iiu, d, e,work(inde2), rtol1, rtol2, & + call stdlib${ii}$_${c2ri(ci)}$larre( range, n, wl, wu, iil, iiu, d, e,work(inde2), rtol1, rtol2, & thresh, nsplit,iwork( iinspl ), m, w, work( inderr ),work( indgp ), iwork( iindbl ),& iwork( iindw ), work( indgrs ), pivmin,work( indwrk ), iwork( iindwk ), iinfo ) - if( iinfo/=0 ) then - info = 10 + abs( iinfo ) + if( iinfo/=0_${ik}$ ) then + info = 10_${ik}$ + abs( iinfo ) return end if - ! note that if range /= 'v', stdlib_${c2ri(ci)}$larre computes bounds on the desired + ! note that if range /= 'v', stdlib${ii}$_${c2ri(ci)}$larre computes bounds on the desired ! part of the spectrum. all desired eigenvalues are contained in ! (wl,wu] if( wantz ) then ! compute the desired eigenvectors corresponding to the computed ! eigenvalues - call stdlib_${ci}$larrv( n, wl, wu, d, e,pivmin, iwork( iinspl ), m,1, m, minrgp, & + call stdlib${ii}$_${ci}$larrv( n, wl, wu, d, e,pivmin, iwork( iinspl ), m,1_${ik}$, m, minrgp, & rtol1, rtol2,w, work( inderr ), work( indgp ), iwork( iindbl ),iwork( iindw ), & work( indgrs ), z, ldz,isuppz, work( indwrk ), iwork( iindwk ), iinfo ) - if( iinfo/=0 ) then - info = 20 + abs( iinfo ) + if( iinfo/=0_${ik}$ ) then + info = 20_${ik}$ + abs( iinfo ) return end if else - ! stdlib_${c2ri(ci)}$larre computes eigenvalues of the (shifted) root representation - ! stdlib_${ci}$larrv returns the eigenvalues of the unshifted matrix. + ! stdlib${ii}$_${c2ri(ci)}$larre computes eigenvalues of the (shifted) root representation + ! stdlib${ii}$_${ci}$larrv returns the eigenvalues of the unshifted matrix. ! however, if the eigenvectors are not desired by the user, we need - ! to apply the corresponding shifts from stdlib_${c2ri(ci)}$larre to obtain the + ! to apply the corresponding shifts from stdlib${ii}$_${c2ri(ci)}$larre to obtain the ! eigenvalues of the original matrix. do j = 1, m itmp = iwork( iindbl+j-1 ) @@ -63092,52 +63083,52 @@ module stdlib_linalg_lapack_${ci}$ if ( tryrac ) then ! refine computed eigenvalues so that they are relatively accurate ! with respect to the original matrix t. - ibegin = 1 - wbegin = 1 + ibegin = 1_${ik}$ + wbegin = 1_${ik}$ loop_39: do jblk = 1, iwork( iindbl+m-1 ) iend = iwork( iinspl+jblk-1 ) - in = iend - ibegin + 1 - wend = wbegin - 1 + in = iend - ibegin + 1_${ik}$ + wend = wbegin - 1_${ik}$ ! check if any eigenvalues have to be refined in this block 36 continue if( wend1 .or. n==2 ) then + if( nsplit>1_${ik}$ .or. n==2_${ik}$ ) then if( .not. wantz ) then - call stdlib_${c2ri(ci)}$lasrt( 'I', m, w, iinfo ) - if( iinfo/=0 ) then - info = 3 + call stdlib${ii}$_${c2ri(ci)}$lasrt( 'I', m, w, iinfo ) + if( iinfo/=0_${ik}$ ) then + info = 3_${ik}$ return end if else do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp = w( j ) do jj = j + 1, m if( w( jj )0 .and. ldz0_${ik}$ .and. ldzn )go to 160 - if( l1>1 )e( l1-1 ) = zero + if( l1>1_${ik}$ )e( l1-1 ) = zero if( l1<=nm1 ) then do m = l1, nm1 tst = abs( e( m ) ) @@ -63262,20 +63253,20 @@ module stdlib_linalg_lapack_${ci}$ lsv = l lend = m lendsv = lend - l1 = m + 1 + l1 = m + 1_${ik}$ if( lend==l )go to 10 ! scale submatrix in rows and columns l to lend - anorm = stdlib_${c2ri(ci)}$lanst( 'I', lend-l+1, d( l ), e( l ) ) - iscale = 0 + anorm = stdlib${ii}$_${c2ri(ci)}$lanst( 'I', lend-l+1, d( l ), e( l ) ) + iscale = 0_${ik}$ if( anorm==zero )go to 10 if( anorm>ssfmax ) then - iscale = 1 - call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n,info ) - call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n,info ) + iscale = 1_${ik}$ + call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmax, lend-l+1, 1_${ik}$, d( l ), n,info ) + call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmax, lend-l, 1_${ik}$, e( l ), n,info ) else if( anorm0 ) then - call stdlib_${c2ri(ci)}$laev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s ) + if( icompz>0_${ik}$ ) then + call stdlib${ii}$_${c2ri(ci)}$laev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s ) work( l ) = c work( n-1+l ) = s - call stdlib_${ci}$lasr( 'R', 'V', 'B', n, 2, work( l ),work( n-1+l ), z( 1, l ), & + call stdlib${ii}$_${ci}$lasr( 'R', 'V', 'B', n, 2_${ik}$, work( l ),work( n-1+l ), z( 1_${ik}$, l ), & ldz ) else - call stdlib_${c2ri(ci)}$lae2( d( l ), e( l ), d( l+1 ), rt1, rt2 ) + call stdlib${ii}$_${c2ri(ci)}$lae2( d( l ), e( l ), d( l+1 ), rt1, rt2 ) end if d( l ) = rt1 d( l+1 ) = rt2 e( l ) = zero - l = l + 2 + l = l + 2_${ik}$ if( l<=lend )go to 40 go to 140 end if if( jtot==nmaxit )go to 140 - jtot = jtot + 1 + jtot = jtot + 1_${ik}$ ! form shift. g = ( d( l+1 )-p ) / ( two*e( l ) ) - r = stdlib_${c2ri(ci)}$lapy2( g, one ) + r = stdlib${ii}$_${c2ri(ci)}$lapy2( g, one ) g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) ) s = one c = one p = zero ! inner loop - mm1 = m - 1 + mm1 = m - 1_${ik}$ do i = mm1, l, -1 f = s*e( i ) b = c*e( i ) - call stdlib_${c2ri(ci)}$lartg( g, f, c, s, r ) + call stdlib${ii}$_${c2ri(ci)}$lartg( g, f, c, s, r ) if( i/=m-1 )e( i+1 ) = r g = d( i+1 ) - p r = ( d( i )-g )*s + two*c*b @@ -63339,15 +63330,15 @@ module stdlib_linalg_lapack_${ci}$ d( i+1 ) = g + p g = c*r - b ! if eigenvectors are desired, then save rotations. - if( icompz>0 ) then + if( icompz>0_${ik}$ ) then work( i ) = c work( n-1+i ) = -s end if end do ! if eigenvectors are desired, then apply saved rotations. - if( icompz>0 ) then - mm = m - l + 1 - call stdlib_${ci}$lasr( 'R', 'V', 'B', n, mm, work( l ), work( n-1+l ),z( 1, l ), ldz & + if( icompz>0_${ik}$ ) then + mm = m - l + 1_${ik}$ + call stdlib${ii}$_${ci}$lasr( 'R', 'V', 'B', n, mm, work( l ), work( n-1+l ),z( 1_${ik}$, l ), ldz & ) end if d( l ) = d( l ) - p @@ -63356,7 +63347,7 @@ module stdlib_linalg_lapack_${ci}$ ! eigenvalue found. 80 continue d( l ) = p - l = l + 1 + l = l + 1_${ik}$ if( l<=lend )go to 40 go to 140 else @@ -63364,9 +63355,9 @@ module stdlib_linalg_lapack_${ci}$ ! look for small superdiagonal element. 90 continue if( l/=lend ) then - lendp1 = lend + 1 + lendp1 = lend + 1_${ik}$ do m = l, lendp1, -1 - tst = abs( e( m-1 ) )**2 + tst = abs( e( m-1 ) )**2_${ik}$ if( tst<=( eps2*abs( d( m ) ) )*abs( d( m-1 ) )+safmin )go to 110 end do end if @@ -63375,40 +63366,40 @@ module stdlib_linalg_lapack_${ci}$ if( m>lend )e( m-1 ) = zero p = d( l ) if( m==l )go to 130 - ! if remaining matrix is 2-by-2, use stdlib_${c2ri(ci)}$lae2 or stdlib_dlaev2 + ! if remaining matrix is 2-by-2, use stdlib_${c2ri(ci)}$lae2 or stdlib${ii}$_dlaev2 ! to compute its eigensystem. if( m==l-1 ) then - if( icompz>0 ) then - call stdlib_${c2ri(ci)}$laev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s ) + if( icompz>0_${ik}$ ) then + call stdlib${ii}$_${c2ri(ci)}$laev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s ) work( m ) = c work( n-1+m ) = s - call stdlib_${ci}$lasr( 'R', 'V', 'F', n, 2, work( m ),work( n-1+m ), z( 1, l-1 ), & + call stdlib${ii}$_${ci}$lasr( 'R', 'V', 'F', n, 2_${ik}$, work( m ),work( n-1+m ), z( 1_${ik}$, l-1 ), & ldz ) else - call stdlib_${c2ri(ci)}$lae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 ) + call stdlib${ii}$_${c2ri(ci)}$lae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 ) end if d( l-1 ) = rt1 d( l ) = rt2 e( l-1 ) = zero - l = l - 2 + l = l - 2_${ik}$ if( l>=lend )go to 90 go to 140 end if if( jtot==nmaxit )go to 140 - jtot = jtot + 1 + jtot = jtot + 1_${ik}$ ! form shift. g = ( d( l-1 )-p ) / ( two*e( l-1 ) ) - r = stdlib_${c2ri(ci)}$lapy2( g, one ) + r = stdlib${ii}$_${c2ri(ci)}$lapy2( g, one ) g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) ) s = one c = one p = zero ! inner loop - lm1 = l - 1 + lm1 = l - 1_${ik}$ do i = m, lm1 f = s*e( i ) b = c*e( i ) - call stdlib_${c2ri(ci)}$lartg( g, f, c, s, r ) + call stdlib${ii}$_${c2ri(ci)}$lartg( g, f, c, s, r ) if( i/=m )e( i-1 ) = r g = d( i ) - p r = ( d( i+1 )-g )*s + two*c*b @@ -63416,15 +63407,15 @@ module stdlib_linalg_lapack_${ci}$ d( i ) = g + p g = c*r - b ! if eigenvectors are desired, then save rotations. - if( icompz>0 ) then + if( icompz>0_${ik}$ ) then work( i ) = c work( n-1+i ) = s end if end do ! if eigenvectors are desired, then apply saved rotations. - if( icompz>0 ) then - mm = l - m + 1 - call stdlib_${ci}$lasr( 'R', 'V', 'F', n, mm, work( m ), work( n-1+m ),z( 1, m ), ldz & + if( icompz>0_${ik}$ ) then + mm = l - m + 1_${ik}$ + call stdlib${ii}$_${ci}$lasr( 'R', 'V', 'F', n, mm, work( m ), work( n-1+m ),z( 1_${ik}$, m ), ldz & ) end if d( l ) = d( l ) - p @@ -63433,41 +63424,41 @@ module stdlib_linalg_lapack_${ci}$ ! eigenvalue found. 130 continue d( l ) = p - l = l - 1 + l = l - 1_${ik}$ if( l>=lend )go to 90 go to 140 end if ! undo scaling if necessary 140 continue - if( iscale==1 ) then - call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1,d( lsv ), n, info ) + if( iscale==1_${ik}$ ) then + call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, ssfmax, anorm, lendsv-lsv+1, 1_${ik}$,d( lsv ), n, info ) - call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv, 1, e( lsv ),n, info ) + call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, ssfmax, anorm, lendsv-lsv, 1_${ik}$, e( lsv ),n, info ) - else if( iscale==2 ) then - call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1,d( lsv ), n, info ) + else if( iscale==2_${ik}$ ) then + call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, ssfmin, anorm, lendsv-lsv+1, 1_${ik}$,d( lsv ), n, info ) - call stdlib_${c2ri(ci)}$lascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv, 1, e( lsv ),n, info ) + call stdlib${ii}$_${c2ri(ci)}$lascl( 'G', 0_${ik}$, 0_${ik}$, ssfmin, anorm, lendsv-lsv, 1_${ik}$, e( lsv ),n, info ) end if ! check for no convergence to an eigenvalue after a total ! of n*maxit iterations. if( jtot==nmaxit ) then do i = 1, n - 1 - if( e( i )/=zero )info = info + 1 + if( e( i )/=zero )info = info + 1_${ik}$ end do return end if go to 10 ! order eigenvalues and eigenvectors. 160 continue - if( icompz==0 ) then + if( icompz==0_${ik}$ ) then ! use quick sort - call stdlib_${c2ri(ci)}$lasrt( 'I', n, d, info ) + call stdlib${ii}$_${c2ri(ci)}$lasrt( 'I', n, d, info ) else ! use selection sort to minimize swaps of eigenvectors do ii = 2, n - i = ii - 1 + i = ii - 1_${ik}$ k = i p = d( i ) do j = ii, n @@ -63479,15 +63470,15 @@ module stdlib_linalg_lapack_${ci}$ if( k/=i ) then d( k ) = d( i ) d( i ) = p - call stdlib_${ci}$swap( n, z( 1, i ), 1, z( 1, k ), 1 ) + call stdlib${ii}$_${ci}$swap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, k ), 1_${ik}$ ) end if end do end if return - end subroutine stdlib_${ci}$steqr + end subroutine stdlib${ii}$_${ci}$steqr - pure subroutine stdlib_${ci}$sycon( uplo, n, a, lda, ipiv, anorm, rcond, work,info ) + pure subroutine stdlib${ii}$_${ci}$sycon( uplo, n, a, lda, ipiv, anorm, rcond, work,info ) !! ZSYCON: estimates the reciprocal of the condition number (in the !! 1-norm) of a complex symmetric matrix A using the factorization !! A = U*D*U**T or A = L*D*L**T computed by ZSYTRF. @@ -63498,44 +63489,44 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 real(${ck}$), intent(in) :: anorm real(${ck}$), intent(out) :: rcond ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) complex(${ck}$), intent(in) :: a(lda,*) complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: i, kase + integer(${ik}$) :: i, kase real(${ck}$) :: ainvnm ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! 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 1 ) - if( ipiv(i) < 0 ) then + if( ipiv(i) < 0_${ik}$ ) then e(i)=a(i-1,i) e(i-1)=czero a(i-1,i)=czero @@ -63711,7 +63702,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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 @@ -63736,9 +63727,9 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -63763,7 +63754,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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 @@ -63775,10 +63766,10 @@ module stdlib_linalg_lapack_${ci}$ if ( convert ) then ! convert a (a is lower) ! convert value - i=1 + i=1_${ik}$ e(n)=czero 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) @@ -63802,7 +63793,7 @@ module stdlib_linalg_lapack_${ci}$ 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) @@ -63818,9 +63809,9 @@ module stdlib_linalg_lapack_${ci}$ ! 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) @@ -63830,7 +63821,7 @@ module stdlib_linalg_lapack_${ci}$ 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) @@ -63841,9 +63832,9 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -63852,10 +63843,10 @@ module stdlib_linalg_lapack_${ci}$ end if end if return - end subroutine stdlib_${ci}$syconv + end subroutine stdlib${ii}$_${ci}$syconv - pure subroutine stdlib_${ci}$syconvf( uplo, way, n, a, lda, e, ipiv, info ) + pure subroutine stdlib${ii}$_${ci}$syconvf( uplo, way, n, a, lda, e, ipiv, info ) !! If parameter WAY = 'C': !! ZSYCONVF: converts the factorization output format used in !! ZSYTRF provided on entry in parameter A into the factorization @@ -63878,31 +63869,31 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), 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 ) = czero a( i-1, i ) = czero - i = i - 1 + i = i - 1_${ik}$ else e( i ) = czero 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 i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(1:i,n-i:n) ip = ipiv( i ) if( i0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(1: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 @@ -64015,40 +64006,40 @@ module stdlib_linalg_lapack_${ci}$ ! convert value ! assign subdiagonal entries of d to array e and czero out ! corresponding entries in input storage a - i = 1 + i = 1_${ik}$ e( n ) = czero do while ( i<=n ) - if( i0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(i:n,1:i-1) ip = ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_${ci}$swap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_${ci}$swap( 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) ip = -ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=(i+1) ) then - call stdlib_${ci}$swap( i-1, a( i+1, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_${ci}$swap( i-1, a( i+1, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda ) end if end if ! convert ipiv @@ -64056,9 +64047,9 @@ module stdlib_linalg_lapack_${ci}$ ! 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) @@ -64067,23 +64058,23 @@ module stdlib_linalg_lapack_${ci}$ ! in reverse factorization order where i decreases from n to 1 i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(i:n,1:i-1) ip = ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_${ci}$swap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) + call stdlib${ii}$_${ci}$swap( 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 + i = i - 1_${ik}$ ip = -ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=(i+1) ) then - call stdlib_${ci}$swap( i-1, a( ip, 1 ), lda,a( i+1, 1 ), lda ) + call stdlib${ii}$_${ci}$swap( i-1, a( ip, 1_${ik}$ ), lda,a( i+1, 1_${ik}$ ), lda ) end if end if ! convert ipiv @@ -64092,27 +64083,27 @@ module stdlib_linalg_lapack_${ci}$ ! 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_${ci}$syconvf + end subroutine stdlib${ii}$_${ci}$syconvf - pure subroutine stdlib_${ci}$syconvf_rook( uplo, way, n, a, lda, e, ipiv, info ) + pure subroutine stdlib${ii}$_${ci}$syconvf_rook( uplo, way, n, a, lda, e, ipiv, info ) !! If parameter WAY = 'C': !! ZSYCONVF_ROOK: converts the factorization output format used in !! ZSYTRF_ROOK provided on entry in parameter A into the factorization @@ -64133,31 +64124,31 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), 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 ) = czero a( i-1, i ) = czero - i = i - 1 + i = i - 1_${ik}$ else e( i ) = czero 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 i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(1:i,n-i:n) ip = ipiv( i ) if( i0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(1: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 @@ -64270,31 +64261,31 @@ module stdlib_linalg_lapack_${ci}$ ! convert value ! assign subdiagonal entries of d to array e and czero out ! corresponding entries in input storage a - i = 1 + i = 1_${ik}$ e( n ) = czero do while ( i<=n ) - if( i0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(i:n,1:i-1) ip = ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_${ci}$swap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_${ci}$swap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda ) end if end if else @@ -64303,17 +64294,17 @@ module stdlib_linalg_lapack_${ci}$ ! in a(i:n,1:i-1) ip = -ipiv( i ) ip2 = -ipiv( i+1 ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_${ci}$swap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_${ci}$swap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda ) end if if( ip2/=(i+1) ) then - call stdlib_${ci}$swap( i-1, a( i+1, 1 ), lda,a( ip2, 1 ), lda ) + call stdlib${ii}$_${ci}$swap( 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) @@ -64322,52 +64313,52 @@ module stdlib_linalg_lapack_${ci}$ ! in reverse factorization order where i decreases from n to 1 i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(i:n,1:i-1) ip = ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_${ci}$swap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) + call stdlib${ii}$_${ci}$swap( 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+1) and i and ipiv(i) ! in a(i:n,1:i-1) - i = 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_${ci}$swap( i-1, a( ip2, 1 ), lda,a( i+1, 1 ), lda ) + call stdlib${ii}$_${ci}$swap( i-1, a( ip2, 1_${ik}$ ), lda,a( i+1, 1_${ik}$ ), lda ) end if if( ip/=i ) then - call stdlib_${ci}$swap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) + call stdlib${ii}$_${ci}$swap( 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_${ci}$syconvf_rook + end subroutine stdlib${ii}$_${ci}$syconvf_rook - pure subroutine stdlib_${ci}$syequb( uplo, n, a, lda, s, scond, amax, work, info ) + pure subroutine stdlib${ii}$_${ci}$syequb( uplo, n, a, lda, s, scond, amax, work, info ) !! ZSYEQUB: computes row and column scalings intended to equilibrate a !! symmetric matrix A (with respect to the Euclidean norm) and reduce !! its condition number. The scale factors S are computed by the BIN @@ -64379,8 +64370,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(${ck}$), intent(out) :: amax, scond character, intent(in) :: uplo ! Array Arguments @@ -64389,11 +64380,11 @@ module stdlib_linalg_lapack_${ci}$ real(${ck}$), intent(out) :: s(*) ! ===================================================================== ! 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(${ck}$) :: avg, std, tol, c0, c1, c2, t, u, si, d, base, smin, smax, smlnum, bignum, & scale, sumsq logical(lk) :: up @@ -64406,22 +64397,22 @@ module stdlib_linalg_lapack_${ci}$ cabs1( zdum ) = abs( real( zdum,KIND=${ck}$) ) + abs( aimag( zdum ) ) ! 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( 'ZSYEQUB', -info ) + if ( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZSYEQUB', -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 @@ -64488,7 +64479,7 @@ module stdlib_linalg_lapack_${ci}$ do i = n+1, 2*n work( i ) = s( i-n ) * work( i-n ) - avg end do - call stdlib_${ci}$lassq( n, work( n+1 ), 1, scale, sumsq ) + call stdlib${ii}$_${ci}$lassq( n, work( n+1 ), 1_${ik}$, scale, sumsq ) std = scale * sqrt( sumsq / n ) if ( std < tol * avg ) goto 999 do i = 1, n @@ -64496,13 +64487,13 @@ module stdlib_linalg_lapack_${ci}$ si = s( i ) c2 = ( n-1 ) * t c1 = ( n-2 ) * ( real( work( i ),KIND=${ck}$) - t*si ) - c0 = -(t*si)*si + 2 * real( work( i ),KIND=${ck}$) * si - n*avg - d = c1*c1 - 4*c0*c2 - if ( d <= 0 ) then - info = -1 + c0 = -(t*si)*si + 2_${ik}$ * real( work( i ),KIND=${ck}$) * 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 @@ -64533,23 +64524,23 @@ module stdlib_linalg_lapack_${ci}$ end do end do 999 continue - smlnum = stdlib_${c2ri(ci)}$lamch( 'SAFEMIN' ) + smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFEMIN' ) bignum = one / smlnum smin = bignum smax = zero t = one / sqrt( avg ) - base = stdlib_${c2ri(ci)}$lamch( 'B' ) + base = stdlib${ii}$_${c2ri(ci)}$lamch( '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_${ci}$syequb + end subroutine stdlib${ii}$_${ci}$syequb - pure subroutine stdlib_${ci}$symv( uplo, n, alpha, a, lda, x, incx, beta, y, incy ) + pure subroutine stdlib${ii}$_${ci}$symv( uplo, n, alpha, a, lda, x, incx, beta, y, incy ) !! ZSYMV: performs the matrix-vector operation !! y := alpha*A*x + beta*y, !! where alpha and beta are scalars, x and y are n element vectors and @@ -64559,7 +64550,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: incx, incy, lda, n + integer(${ik}$), intent(in) :: incx, incy, lda, n complex(${ck}$), intent(in) :: alpha, beta ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*), x(*) @@ -64568,47 +64559,47 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars - integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky complex(${ck}$) :: temp1, temp2 ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) 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 )*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 )*incy end if ! start the operations. in this version the elements of a are ! accessed sequentially with cone pass through the triangular part ! of a. ! first form y := beta*y. if( beta/=cone ) then - if( incy==1 ) then + if( incy==1_${ik}$ ) then if( beta==czero ) then do i = 1, n y( i ) = czero @@ -64636,7 +64627,7 @@ module stdlib_linalg_lapack_${ci}$ if( alpha==czero )return if( stdlib_lsame( uplo, 'U' ) ) then ! form y when a is stored in upper triangle. - if( ( incx==1 ) .and. ( incy==1 ) ) then + if( ( incx==1_${ik}$ ) .and. ( incy==1_${ik}$ ) ) then do j = 1, n temp1 = alpha*x( j ) temp2 = czero @@ -64667,7 +64658,7 @@ module stdlib_linalg_lapack_${ci}$ end if else ! form y when a is stored in lower triangle. - if( ( incx==1 ) .and. ( incy==1 ) ) then + if( ( incx==1_${ik}$ ) .and. ( incy==1_${ik}$ ) ) then do j = 1, n temp1 = alpha*x( j ) temp2 = czero @@ -64700,10 +64691,10 @@ module stdlib_linalg_lapack_${ci}$ end if end if return - end subroutine stdlib_${ci}$symv + end subroutine stdlib${ii}$_${ci}$symv - pure subroutine stdlib_${ci}$syr( uplo, n, alpha, x, incx, a, lda ) + pure subroutine stdlib${ii}$_${ci}$syr( uplo, n, alpha, x, incx, a, lda ) !! ZSYR: performs the symmetric rank 1 operation !! A := alpha*x*x**H + A, !! where alpha is a complex scalar, x is an n element vector and A is an @@ -64713,7 +64704,7 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: incx, lda, n + integer(${ik}$), intent(in) :: incx, lda, n complex(${ck}$), intent(in) :: alpha ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) @@ -64721,40 +64712,40 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! Local Scalars - integer(ilp) :: i, info, ix, j, jx, kx + integer(${ik}$) :: i, info, ix, j, jx, kx complex(${ck}$) :: temp ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = 1 - else if( n<0 ) then - info = 2 - else if( incx==0 ) then - info = 5 - else if( ldaeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_${ci}$sytrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) - call stdlib_${ci}$axpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_${ci}$sytrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info ) + call stdlib${ii}$_${ci}$axpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -64970,22 +64961,22 @@ module stdlib_linalg_lapack_${ci}$ rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**t). - call stdlib_${ci}$sytrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) + call stdlib${ii}$_${ci}$sytrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do - else if( kase==2 ) then + else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_${ci}$sytrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) + call stdlib${ii}$_${ci}$sytrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info ) end if go to 100 end if @@ -64997,10 +64988,10 @@ module stdlib_linalg_lapack_${ci}$ if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_${ci}$syrfs + end subroutine stdlib${ii}$_${ci}$syrfs - pure subroutine stdlib_${ci}$sysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) + pure subroutine stdlib${ii}$_${ci}$sysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) !! ZSYSV: computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS @@ -65017,68 +65008,68 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, lwork, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, lwork, n, nrhs ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: lwkopt + integer(${ik}$) :: lwkopt ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) if( .not.stdlib_lsame( uplo, 'U' ) .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 + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_${ci}$lansy( 'I', uplo, n, a, lda, rwork ) + anorm = stdlib${ii}$_${ci}$lansy( 'I', uplo, n, a, lda, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_${ci}$sycon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, info ) + call stdlib${ii}$_${ci}$sycon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, info ) ! compute the solution vectors x. - call stdlib_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_${ci}$sytrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info ) + call stdlib${ii}$_${ci}$lacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_${ci}$sytrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_${ci}$syrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & + call stdlib${ii}$_${ci}$syrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & work, rwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond1 ) then - imax = stdlib_i${ci}$amax( k-1, a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_i${ci}$amax( k-1, a( 1_${ik}$, k ), 1_${ik}$ ) colmax = cabs1( a( imax, k ) ) else colmax = zero end if - if( max( absakk, colmax )==zero .or. stdlib_${c2ri(ci)}$isnan(absakk) ) then + if( max( absakk, colmax )==zero .or. stdlib${ii}$_${c2ri(ci)}$isnan(absakk) ) then ! column k is zero or underflow, or contains a nan: ! set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k else if( absakk>=alpha*colmax ) then @@ -65556,10 +65547,10 @@ module stdlib_linalg_lapack_${ci}$ else ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value - jmax = imax + stdlib_i${ci}$amax( k-imax, a( imax, imax+1 ), lda ) + jmax = imax + stdlib${ii}$_i${ci}$amax( k-imax, a( imax, imax+1 ), lda ) rowmax = cabs1( a( imax, jmax ) ) - if( imax>1 ) then - jmax = stdlib_i${ci}$amax( imax-1, a( 1, imax ), 1 ) + if( imax>1_${ik}$ ) then + jmax = stdlib${ii}$_i${ci}$amax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ ) rowmax = max( rowmax, cabs1( a( jmax, imax ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then @@ -65573,35 +65564,35 @@ module stdlib_linalg_lapack_${ci}$ ! interchange rows and columns k-1 and imax, use 2-by-2 ! pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ end if end if - 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) - call stdlib_${ci}$swap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) - call stdlib_${ci}$swap( kk-kp-1, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) + call stdlib${ii}$_${ci}$swap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$swap( kk-kp-1, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t - if( kstep==2 ) 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 + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u ! perform a rank-1 update of a(1:k-1,1:k-1) as ! a := a - u(k)*d(k)*u(k)**t = a - w(k)*1/d(k)*w(k)**t r1 = cone / a( k, k ) - call stdlib_${ci}$syr( uplo, k-1, -r1, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_${ci}$syr( uplo, k-1, -r1, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) ! store u(k) in column k - call stdlib_${ci}$scal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_${ci}$scal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) else ! 2-by-2 pivot block d(k): columns k and k-1 now hold ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k) @@ -65610,7 +65601,7 @@ module stdlib_linalg_lapack_${ci}$ ! perform a rank-2 update of a(1:k-2,1:k-2) as ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**t ! = a - ( w(k-1) w(k) )*inv(d(k))*( w(k-1) w(k) )**t - 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 @@ -65629,7 +65620,7 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -65642,11 +65633,11 @@ module stdlib_linalg_lapack_${ci}$ ! 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 = 1_${ik}$ 40 continue ! if k > n, exit from loop if( k>n )go to 70 - 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 absakk = cabs1( a( k, k ) ) @@ -65654,15 +65645,15 @@ module stdlib_linalg_lapack_${ci}$ ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k=alpha*colmax ) then @@ -65671,10 +65662,10 @@ module stdlib_linalg_lapack_${ci}$ else ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value - jmax = k - 1 + stdlib_i${ci}$amax( imax-k, a( imax, k ), lda ) + jmax = k - 1_${ik}$ + stdlib${ii}$_i${ci}$amax( imax-k, a( imax, k ), lda ) rowmax = cabs1( a( imax, jmax ) ) if( imax=alpha*colmax*( colmax / rowmax ) ) then @@ -65688,27 +65679,27 @@ module stdlib_linalg_lapack_${ci}$ ! interchange rows and columns k+1 and imax, use 2-by-2 ! pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ end if end if - 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( kp1 ) then - imax = stdlib_i${ci}$amax( k-1, a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_i${ci}$amax( k-1, a( 1_${ik}$, k ), 1_${ik}$ ) colmax = cabs1( a( imax, k ) ) else colmax = zero end if if( (max( absakk, colmax )==zero) ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k ! set e( k ) to zero - if( k>1 )e( k ) = czero + if( k>1_${ik}$ )e( k ) = czero else ! test for interchange ! equivalent to testing for (used to handle nan and inf) @@ -65867,13 +65858,13 @@ module stdlib_linalg_lapack_${ci}$ ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = imax + stdlib_i${ci}$amax( k-imax, a( imax, imax+1 ),lda ) + jmax = imax + stdlib${ii}$_i${ci}$amax( k-imax, a( imax, imax+1 ),lda ) rowmax = cabs1( a( imax, jmax ) ) else rowmax = zero end if - if( imax>1 ) then - itemp = stdlib_i${ci}$amax( imax-1, a( 1, imax ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_i${ci}$amax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ ) dtemp = cabs1( a( itemp, imax ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -65893,7 +65884,7 @@ module stdlib_linalg_lapack_${ci}$ ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found, set variables and repeat @@ -65906,45 +65897,45 @@ module stdlib_linalg_lapack_${ci}$ end if ! swap two rows and two columns ! first swap - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! interchange rows and column k and p in the leading ! submatrix a(1:k,1:k) if we have a 2-by-2 pivot - if( p>1 )call stdlib_${ci}$swap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) - if( p<(k-1) )call stdlib_${ci}$swap( k-p-1, a( p+1, k ), 1, a( p, p+1 ),lda ) + if( p>1_${ik}$ )call stdlib${ii}$_${ci}$swap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) + if( p<(k-1) )call stdlib${ii}$_${ci}$swap( k-p-1, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda ) t = a( k, k ) a( k, k ) = a( p, p ) a( p, p ) = t ! convert upper triangle of a into u form by applying ! the interchanges in columns k+1:n. - if( k1 )call stdlib_${ci}$swap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) - if( ( kk>1 ) .and. ( kp<(kk-1) ) )call stdlib_${ci}$swap( kk-kp-1, a( kp+1, kk ), & - 1, a( kp, kp+1 ),lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_${ci}$swap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + if( ( kk>1_${ik}$ ) .and. ( kp<(kk-1) ) )call stdlib${ii}$_${ci}$swap( kk-kp-1, a( kp+1, kk ), & + 1_${ik}$, a( kp, kp+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t - if( kstep==2 ) 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 + if( k>1_${ik}$ ) then ! perform a rank-1 update of a(1:k-1,1:k-1) and ! store u(k) in column k if( cabs1( a( k, k ) )>=sfmin ) then @@ -65952,9 +65943,9 @@ module stdlib_linalg_lapack_${ci}$ ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*1/d(k)*w(k)**t d11 = cone / a( k, k ) - call stdlib_${ci}$syr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_${ci}$syr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) ! store u(k) in column k - call stdlib_${ci}$scal( k-1, d11, a( 1, k ), 1 ) + call stdlib${ii}$_${ci}$scal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = a( k, k ) @@ -65965,7 +65956,7 @@ module stdlib_linalg_lapack_${ci}$ ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_${ci}$syr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_${ci}$syr( 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 ) = czero @@ -65979,7 +65970,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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 @@ -66005,7 +65996,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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 @@ -66021,11 +66012,11 @@ module stdlib_linalg_lapack_${ci}$ e( n ) = czero ! k is the main loop index, increasing from 1 to n in steps of ! 1 or 2 - k = 1 + 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 @@ -66034,14 +66025,14 @@ module stdlib_linalg_lapack_${ci}$ ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( krowmax ) then rowmax = dtemp @@ -66087,7 +66078,7 @@ module stdlib_linalg_lapack_${ci}$ ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found, set variables and repeat @@ -66100,42 +66091,42 @@ module stdlib_linalg_lapack_${ci}$ end if ! swap two rows and two columns ! first swap - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! interchange rows and column k and p in the trailing ! submatrix a(k:n,k:n) if we have a 2-by-2 pivot - if( p(k+1) )call stdlib_${ci}$swap( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) + if( p(k+1) )call stdlib${ii}$_${ci}$swap( p-k-1, a( k+1, k ), 1_${ik}$, a( p, k+1 ), lda ) t = a( k, k ) a( k, k ) = a( p, p ) a( p, p ) = t ! convert lower triangle of a into l form by applying ! the interchanges in columns 1:k-1. - if ( k>1 )call stdlib_${ci}$swap( k-1, a( k, 1 ), lda, a( p, 1 ), lda ) + if ( k>1_${ik}$ )call stdlib${ii}$_${ci}$swap( 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_${ci}$swap( kp-kk-1, a( kk+1, kk ), & - 1, a( kp, kk+1 ),lda ) + if( ( kk(kk+1) ) )call stdlib${ii}$_${ci}$swap( kp-kk-1, a( kk+1, kk ), & + 1_${ik}$, a( kp, kk+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t - if( kstep==2 ) 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_${ci}$swap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) + if ( k>1_${ik}$ )call stdlib${ii}$_${ci}$swap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) end if ! update the trailing submatrix - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = l(k)*d(k) ! where l(k) is the k-th column of l @@ -66147,10 +66138,10 @@ module stdlib_linalg_lapack_${ci}$ ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t d11 = cone / a( k, k ) - call stdlib_${ci}$syr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_${ci}$syr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda ) ! store l(k) in column k - call stdlib_${ci}$scal( n-k, d11, a( k+1, k ), 1 ) + call stdlib${ii}$_${ci}$scal( n-k, d11, a( k+1, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = a( k, k ) @@ -66161,7 +66152,7 @@ module stdlib_linalg_lapack_${ci}$ ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_${ci}$syr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_${ci}$syr( 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 @@ -66204,7 +66195,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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 @@ -66216,10 +66207,10 @@ module stdlib_linalg_lapack_${ci}$ 64 continue end if return - end subroutine stdlib_${ci}$sytf2_rk + end subroutine stdlib${ii}$_${ci}$sytf2_rk - pure subroutine stdlib_${ci}$sytf2_rook( uplo, n, a, lda, ipiv, info ) + pure subroutine stdlib${ii}$_${ci}$sytf2_rook( uplo, n, a, lda, ipiv, info ) !! ZSYTF2_ROOK: computes the factorization of a complex symmetric matrix A !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method: !! A = U*D*U**T or A = L*D*L**T @@ -66232,10 +66223,10 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Parameters @@ -66245,7 +66236,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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(${ck}$) :: absakk, alpha, colmax, rowmax, dtemp, sfmin complex(${ck}$) :: d11, d12, d21, d22, t, wk, wkm1, wkp1, z ! Intrinsic Functions @@ -66256,23 +66247,23 @@ module stdlib_linalg_lapack_${ci}$ cabs1( z ) = abs( real( z,KIND=${ck}$) ) + abs( aimag( z ) ) ! 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_i${ci}$amax( k-1, a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_i${ci}$amax( k-1, a( 1_${ik}$, k ), 1_${ik}$ ) colmax = cabs1( a( imax, k ) ) else colmax = zero end if if( (max( absakk, colmax )==zero) ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k else ! test for interchange @@ -66316,13 +66307,13 @@ module stdlib_linalg_lapack_${ci}$ ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = imax + stdlib_i${ci}$amax( k-imax, a( imax, imax+1 ),lda ) + jmax = imax + stdlib${ii}$_i${ci}$amax( k-imax, a( imax, imax+1 ),lda ) rowmax = cabs1( a( imax, jmax ) ) else rowmax = zero end if - if( imax>1 ) then - itemp = stdlib_i${ci}$amax( imax-1, a( 1, imax ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_i${ci}$amax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ ) dtemp = cabs1( a( itemp, imax ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -66342,7 +66333,7 @@ module stdlib_linalg_lapack_${ci}$ ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found, set variables and repeat @@ -66355,39 +66346,39 @@ module stdlib_linalg_lapack_${ci}$ end if ! swap two rows and two columns ! first swap - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! interchange rows and column k and p in the leading ! submatrix a(1:k,1:k) if we have a 2-by-2 pivot - if( p>1 )call stdlib_${ci}$swap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) - if( p<(k-1) )call stdlib_${ci}$swap( k-p-1, a( p+1, k ), 1, a( p, p+1 ),lda ) + if( p>1_${ik}$ )call stdlib${ii}$_${ci}$swap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) + if( p<(k-1) )call stdlib${ii}$_${ci}$swap( k-p-1, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda ) t = a( k, k ) a( k, k ) = a( p, p ) a( p, p ) = t end if ! second swap - kk = k - kstep + 1 + 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_${ci}$swap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) - if( ( kk>1 ) .and. ( kp<(kk-1) ) )call stdlib_${ci}$swap( kk-kp-1, a( kp+1, kk ), & - 1, a( kp, kp+1 ),lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_${ci}$swap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + if( ( kk>1_${ik}$ ) .and. ( kp<(kk-1) ) )call stdlib${ii}$_${ci}$swap( kk-kp-1, a( kp+1, kk ), & + 1_${ik}$, a( kp, kp+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t - if( kstep==2 ) 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 + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u - if( k>1 ) then + if( k>1_${ik}$ ) then ! perform a rank-1 update of a(1:k-1,1:k-1) and ! store u(k) in column k if( cabs1( a( k, k ) )>=sfmin ) then @@ -66395,9 +66386,9 @@ module stdlib_linalg_lapack_${ci}$ ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*1/d(k)*w(k)**t d11 = cone / a( k, k ) - call stdlib_${ci}$syr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_${ci}$syr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) ! store u(k) in column k - call stdlib_${ci}$scal( k-1, d11, a( 1, k ), 1 ) + call stdlib${ii}$_${ci}$scal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = a( k, k ) @@ -66408,7 +66399,7 @@ module stdlib_linalg_lapack_${ci}$ ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_${ci}$syr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_${ci}$syr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) end if end if else @@ -66420,7 +66411,7 @@ module stdlib_linalg_lapack_${ci}$ ! 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 @@ -66440,7 +66431,7 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -66453,11 +66444,11 @@ module stdlib_linalg_lapack_${ci}$ ! 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 = 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 @@ -66466,14 +66457,14 @@ module stdlib_linalg_lapack_${ci}$ ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( krowmax ) then rowmax = dtemp @@ -66517,7 +66508,7 @@ module stdlib_linalg_lapack_${ci}$ ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found, set variables and repeat @@ -66530,36 +66521,36 @@ module stdlib_linalg_lapack_${ci}$ end if ! swap two rows and two columns ! first swap - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! interchange rows and column k and p in the trailing ! submatrix a(k:n,k:n) if we have a 2-by-2 pivot - if( p(k+1) )call stdlib_${ci}$swap( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) + if( p(k+1) )call stdlib${ii}$_${ci}$swap( p-k-1, a( k+1, k ), 1_${ik}$, a( p, k+1 ), lda ) t = a( k, k ) a( k, k ) = a( p, p ) a( p, p ) = t end if ! second swap - kk = k + kstep - 1 + 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_${ci}$swap( kp-kk-1, a( kk+1, kk ), & - 1, a( kp, kk+1 ),lda ) + if( ( kk(kk+1) ) )call stdlib${ii}$_${ci}$swap( kp-kk-1, a( kk+1, kk ), & + 1_${ik}$, a( kp, kk+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t - if( kstep==2 ) 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 + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = l(k)*d(k) ! where l(k) is the k-th column of l @@ -66571,10 +66562,10 @@ module stdlib_linalg_lapack_${ci}$ ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t d11 = cone / a( k, k ) - call stdlib_${ci}$syr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_${ci}$syr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda ) ! store l(k) in column k - call stdlib_${ci}$scal( n-k, d11, a( k+1, k ), 1 ) + call stdlib${ii}$_${ci}$scal( n-k, d11, a( k+1, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = a( k, k ) @@ -66585,7 +66576,7 @@ module stdlib_linalg_lapack_${ci}$ ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_${ci}$syr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_${ci}$syr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda ) end if end if @@ -66620,7 +66611,7 @@ module stdlib_linalg_lapack_${ci}$ 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 @@ -66632,10 +66623,10 @@ module stdlib_linalg_lapack_${ci}$ end if 70 continue return - end subroutine stdlib_${ci}$sytf2_rook + end subroutine stdlib${ii}$_${ci}$sytf2_rook - pure subroutine stdlib_${ci}$sytrf( uplo, n, a, lda, ipiv, work, lwork, info ) + pure subroutine stdlib${ii}$_${ci}$sytrf( uplo, n, a, lda, ipiv, work, lwork, info ) !! ZSYTRF: computes the factorization of a complex symmetric matrix A !! using the Bunch-Kaufman diagonal pivoting method. The form of the !! factorization is @@ -66649,60 +66640,60 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), 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_${ci}$lasyf( uplo, k, nb, kb, a, lda, ipiv, work, n, iinfo ) + call stdlib${ii}$_${ci}$lasyf( uplo, k, nb, kb, a, lda, ipiv, work, n, iinfo ) else ! use unblocked code to factorize columns 1:k of a - call stdlib_${ci}$sytf2( uplo, k, a, lda, ipiv, iinfo ) + call stdlib${ii}$_${ci}$sytf2( 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 ! 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_${ci}$lasyf; + ! kb, where kb is the number of columns factorized by stdlib${ii}$_${ci}$lasyf; ! 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_${ci}$lasyf( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, n, & + call stdlib${ii}$_${ci}$lasyf( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, n, & iinfo ) else ! use unblocked code to factorize columns k:n of a - call stdlib_${ci}$sytf2( uplo, n-k+1, a( k, k ), lda, ipiv( k ), iinfo ) - kb = n - k + 1 + call stdlib${ii}$_${ci}$sytf2( 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 @@ -66756,12 +66747,12 @@ module stdlib_linalg_lapack_${ci}$ go to 20 end if 40 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ci}$sytrf + end subroutine stdlib${ii}$_${ci}$sytrf - pure subroutine stdlib_${ci}$sytrf_aa( uplo, n, a, lda, ipiv, work, lwork, info) + pure subroutine stdlib${ii}$_${ci}$sytrf_aa( uplo, n, a, lda, ipiv, work, lwork, info) !! ZSYTRF_AA: computes the factorization of a complex symmetric matrix A !! using the Aasen's algorithm. The form of the factorization is !! A = U**T*T*U or A = L*T*L**T @@ -66773,57 +66764,57 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: n, lda, lwork - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n, lda, lwork + integer(${ik}$), intent(out) :: info ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, upper - integer(ilp) :: j, lwkopt - integer(ilp) :: nb, mj, nj, k1, k2, j1, j2, j3, jb + integer(${ik}$) :: j, lwkopt + integer(${ik}$) :: nb, mj, nj, k1, k2, j1, j2, j3, jb complex(${ck}$) :: alpha ! Intrinsic Functions intrinsic :: max ! Executable Statements ! determine the block size - nb = stdlib_ilaenv( 1, 'ZSYTRF_AA', uplo, n, -1, -1, -1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZSYTRF_AA', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) ! 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( lda=n )go to 20 ! each step of the main loop @@ -66844,17 +66835,17 @@ module stdlib_linalg_lapack_${ci}$ ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=1 for the first panel, and ! k1=0 for the rest - j1 = j + 1 + j1 = j + 1_${ik}$ jb = min( n-j1+1, nb ) - k1 = max(1, j)-j + k1 = max(1_${ik}$, j)-j ! panel factorization - call stdlib_${ci}$lasyf_aa( uplo, 2-k1, n-j, jb,a( max(1, j), j+1 ), lda,ipiv( j+1 ), & + call stdlib${ii}$_${ci}$lasyf_aa( uplo, 2_${ik}$-k1, n-j, jb,a( max(1_${ik}$, j), j+1 ), lda,ipiv( j+1 ), & work, n, work( n*nb+1 ) ) ! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot) do j2 = j+2, min(n, j+jb+1) ipiv( j2 ) = ipiv( j2 ) + j - if( (j2/=ipiv(j2)) .and. ((j1-k1)>2) ) then - call stdlib_${ci}$swap( j1-k1-2, a( 1, j2 ), 1,a( 1, ipiv(j2) ), 1 ) + if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then + call stdlib${ii}$_${ci}$swap( j1-k1-2, a( 1_${ik}$, j2 ), 1_${ik}$,a( 1_${ik}$, ipiv(j2) ), 1_${ik}$ ) end if end do j = j + jb @@ -66863,43 +66854,43 @@ module stdlib_linalg_lapack_${ci}$ ! work stores the current block of the auxiriarly matrix h if( j1 .or. jb>1 ) then + if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then ! merge rank-1 update with blas-3 update alpha = a( j, j+1 ) a( j, j+1 ) = cone - call stdlib_${ci}$copy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib${ii}$_${ci}$copy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) - call stdlib_${ci}$scal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib${ii}$_${ci}$scal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=1 and k2= 0 for the first panel, ! while k1=0 and k2=1 for the rest - if( j1>1 ) then + if( j1>1_${ik}$ ) then ! not first panel - k2 = 1 + k2 = 1_${ik}$ else ! first panel - k2 = 0 + k2 = 0_${ik}$ ! first update skips the first column - jb = jb - 1 + jb = jb - 1_${ik}$ end if do j2 = j+1, n, nb nj = min( nb, n-j2+1 ) - ! update (j2, j2) diagonal block with stdlib_${ci}$gemv + ! update (j2, j2) diagonal block with stdlib${ii}$_${ci}$gemv j3 = j2 do mj = nj-1, 1, -1 - call stdlib_${ci}$gemv( 'NO TRANSPOSE', mj, jb+1,-cone, work( j3-j1+1+k1*n ),& - n,a( j1-k2, j3 ), 1,cone, a( j3, j3 ), lda ) - j3 = j3 + 1 + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', mj, jb+1,-cone, work( j3-j1+1+k1*n ),& + n,a( j1-k2, j3 ), 1_${ik}$,cone, a( j3, j3 ), lda ) + j3 = j3 + 1_${ik}$ end do - ! update off-diagonal block of j2-th block row with stdlib_${ci}$gemm - call stdlib_${ci}$gemm( 'TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-cone, a( j1-& + ! update off-diagonal block of j2-th block row with stdlib${ii}$_${ci}$gemm + call stdlib${ii}$_${ci}$gemm( 'TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-cone, a( j1-& k2, j2 ), lda,work( j3-j1+1+k1*n ), n,cone, a( j2, j3 ), lda ) end do ! recover t( j, j+1 ) a( j, j+1 ) = alpha end if ! work(j+1, 1) stores h(j+1, 1) - call stdlib_${ci}$copy( n-j, a( j+1, j+1 ), lda, work( 1 ), 1 ) + call stdlib${ii}$_${ci}$copy( n-j, a( j+1, j+1 ), lda, work( 1_${ik}$ ), 1_${ik}$ ) end if go to 10 else @@ -66908,11 +66899,11 @@ module stdlib_linalg_lapack_${ci}$ ! ..................................................... ! copy first column a(1:n, 1) into h(1:n, 1) ! (stored in work(1:n)) - call stdlib_${ci}$copy( n, a( 1, 1 ), 1, work( 1 ), 1 ) + call stdlib${ii}$_${ci}$copy( n, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) ! j is the main loop index, increasing from 1 to n in steps of - ! jb, where jb is the number of columns factorized by stdlib_${ci}$lasyf; + ! jb, where jb is the number of columns factorized by stdlib${ii}$_${ci}$lasyf; ! jb is either nb, or n-j+1 for the last block - j = 0 + j = 0_${ik}$ 11 continue if( j>=n )go to 20 ! each step of the main loop @@ -66923,15 +66914,15 @@ module stdlib_linalg_lapack_${ci}$ ! k1=0 for the rest j1 = j+1 jb = min( n-j1+1, nb ) - k1 = max(1, j)-j + k1 = max(1_${ik}$, j)-j ! panel factorization - call stdlib_${ci}$lasyf_aa( uplo, 2-k1, n-j, jb,a( j+1, max(1, j) ), lda,ipiv( j+1 ), & + call stdlib${ii}$_${ci}$lasyf_aa( uplo, 2_${ik}$-k1, n-j, jb,a( j+1, max(1_${ik}$, j) ), lda,ipiv( j+1 ), & work, n, work( n*nb+1 ) ) ! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot) do j2 = j+2, min(n, j+jb+1) ipiv( j2 ) = ipiv( j2 ) + j - if( (j2/=ipiv(j2)) .and. ((j1-k1)>2) ) then - call stdlib_${ci}$swap( j1-k1-2, a( j2, 1 ), lda,a( ipiv(j2), 1 ), lda ) + if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then + call stdlib${ii}$_${ci}$swap( j1-k1-2, a( j2, 1_${ik}$ ), lda,a( ipiv(j2), 1_${ik}$ ), lda ) end if end do j = j + jb @@ -66940,35 +66931,35 @@ module stdlib_linalg_lapack_${ci}$ ! work(j2+1, 1) stores h(j2+1, 1) if( j1 .or. jb>1 ) then + if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then ! merge rank-1 update with blas-3 update alpha = a( j+1, j ) a( j+1, j ) = cone - call stdlib_${ci}$copy( n-j, a( j+1, j-1 ), 1,work( (j+1-j1+1)+jb*n ), 1 ) - call stdlib_${ci}$scal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib${ii}$_${ci}$copy( n-j, a( j+1, j-1 ), 1_${ik}$,work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$scal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=1 and k2= 0 for the first panel, ! while k1=0 and k2=1 for the rest - if( j1>1 ) then + if( j1>1_${ik}$ ) then ! not first panel - k2 = 1 + k2 = 1_${ik}$ else ! first panel - k2 = 0 + k2 = 0_${ik}$ ! first update skips the first column - jb = jb - 1 + jb = jb - 1_${ik}$ end if do j2 = j+1, n, nb nj = min( nb, n-j2+1 ) - ! update (j2, j2) diagonal block with stdlib_${ci}$gemv + ! update (j2, j2) diagonal block with stdlib${ii}$_${ci}$gemv j3 = j2 do mj = nj-1, 1, -1 - call stdlib_${ci}$gemv( 'NO TRANSPOSE', mj, jb+1,-cone, work( j3-j1+1+k1*n ),& - n,a( j3, j1-k2 ), lda,cone, a( j3, j3 ), 1 ) - j3 = j3 + 1 + call stdlib${ii}$_${ci}$gemv( 'NO TRANSPOSE', mj, jb+1,-cone, work( j3-j1+1+k1*n ),& + n,a( j3, j1-k2 ), lda,cone, a( j3, j3 ), 1_${ik}$ ) + j3 = j3 + 1_${ik}$ end do - ! update off-diagonal block in j2-th block column with stdlib_${ci}$gemm - call stdlib_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE',n-j3+1, nj, jb+1,-cone, & + ! update off-diagonal block in j2-th block column with stdlib${ii}$_${ci}$gemm + call stdlib${ii}$_${ci}$gemm( 'NO TRANSPOSE', 'TRANSPOSE',n-j3+1, nj, jb+1,-cone, & work( j3-j1+1+k1*n ), n,a( j2, j1-k2 ), lda,cone, a( j3, j2 ), lda ) end do @@ -66976,17 +66967,17 @@ module stdlib_linalg_lapack_${ci}$ a( j+1, j ) = alpha end if ! work(j+1, 1) stores h(j+1, 1) - call stdlib_${ci}$copy( n-j, a( j+1, j+1 ), 1, work( 1 ), 1 ) + call stdlib${ii}$_${ci}$copy( n-j, a( j+1, j+1 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) end if go to 11 end if 20 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ci}$sytrf_aa + end subroutine stdlib${ii}$_${ci}$sytrf_aa - pure subroutine stdlib_${ci}$sytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) + pure subroutine stdlib${ii}$_${ci}$sytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) !! ZSYTRF_RK: computes the factorization of a complex symmetric matrix A !! using the bounded Bunch-Kaufman (rook) diagonal pivoting method: !! A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), @@ -67001,60 +66992,60 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), 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_${ci}$lasyf_rk( uplo, k, nb, kb, a, lda, e,ipiv, work, ldwork, iinfo ) + call stdlib${ii}$_${ci}$lasyf_rk( uplo, k, nb, kb, a, lda, e,ipiv, work, ldwork, iinfo ) else ! use unblocked code to factorize columns 1:k of a - call stdlib_${ci}$sytf2_rk( uplo, k, a, lda, e, ipiv, iinfo ) + call stdlib${ii}$_${ci}$sytf2_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 ! read ipiv from the last block factored, i.e. @@ -67084,7 +67075,7 @@ module stdlib_linalg_lapack_${ci}$ do i = k, ( k - kb + 1 ), -1 ip = abs( ipiv( i ) ) if( ip/=i ) then - call stdlib_${ci}$swap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda ) + call stdlib${ii}$_${ci}$swap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda ) end if end do end if @@ -67097,31 +67088,31 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$lasyf_rk; + ! kb, where kb is the number of columns factorized by stdlib${ii}$_${ci}$lasyf_rk; ! 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 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_${ci}$lasyf_rk( uplo, n-k+1, nb, kb, a( k, k ), lda, e( k ),ipiv( k ), & + call stdlib${ii}$_${ci}$lasyf_rk( uplo, n-k+1, nb, kb, a( k, k ), lda, e( k ),ipiv( k ), & work, ldwork, iinfo ) else ! use unblocked code to factorize columns k:n of a - call stdlib_${ci}$sytf2_rk( uplo, n-k+1, a( k, k ), lda, e( k ),ipiv( k ), iinfo ) + call stdlib${ii}$_${ci}$sytf2_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 @@ -67131,11 +67122,11 @@ module stdlib_linalg_lapack_${ci}$ ! (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 + if( k>1_${ik}$ ) then do i = k, ( k + kb - 1 ), 1 ip = abs( ipiv( i ) ) if( ip/=i ) then - call stdlib_${ci}$swap( k-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_${ci}$swap( k-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda ) end if end do end if @@ -67147,12 +67138,12 @@ module stdlib_linalg_lapack_${ci}$ 35 continue ! end lower end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ci}$sytrf_rk + end subroutine stdlib${ii}$_${ci}$sytrf_rk - pure subroutine stdlib_${ci}$sytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) + pure subroutine stdlib${ii}$_${ci}$sytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) !! ZSYTRF_ROOK: computes the factorization of a complex symmetric matrix A !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. !! The form of the factorization is @@ -67166,60 +67157,60 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), 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_${ci}$lasyf_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo ) + call stdlib${ii}$_${ci}$lasyf_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo ) else ! use unblocked code to factorize columns 1:k of a - call stdlib_${ci}$sytf2_rook( uplo, k, a, lda, ipiv, iinfo ) + call stdlib${ii}$_${ci}$sytf2_rook( uplo, k, a, lda, ipiv, iinfo ) kb = k end if ! set info on the first occurrence of a zero pivot - if( info==0 .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 @@ -67244,30 +67235,30 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$lasyf_rook; + ! kb, where kb is the number of columns factorized by stdlib${ii}$_${ci}$lasyf_rook; ! kb is either nb or nb-1, or n-k+1 for the last block - k = 1 + 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_${ci}$lasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, & + call stdlib${ii}$_${ci}$lasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, & ldwork, iinfo ) else ! use unblocked code to factorize columns k:n of a - call stdlib_${ci}$sytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo ) - kb = n - k + 1 + call stdlib${ii}$_${ci}$sytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo ) + kb = n - k + 1_${ik}$ end if ! set info on the first occurrence of a zero pivot - if( info==0 .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 @@ -67275,12 +67266,12 @@ module stdlib_linalg_lapack_${ci}$ go to 20 end if 40 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ci}$sytrf_rook + end subroutine stdlib${ii}$_${ci}$sytrf_rook - pure subroutine stdlib_${ci}$sytri( uplo, n, a, lda, ipiv, work, info ) + pure subroutine stdlib${ii}$_${ci}$sytri( uplo, n, a, lda, ipiv, work, info ) !! ZSYTRI: computes the inverse of a complex symmetric indefinite matrix !! A using the factorization A = U*D*U**T or A = L*D*L**T computed by !! ZSYTRF. @@ -67289,33 +67280,33 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: k, kp, kstep + integer(${ik}$) :: k, kp, kstep complex(${ck}$) :: 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 )==czero )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 = 1_${ik}$ 30 continue ! if k > n, exit from loop. if( k>n )go to 40 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = cone / a( k, k ) ! compute column k of the inverse. - if( k>1 ) then - call stdlib_${ci}$copy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_${ci}$symv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_${ci}$copy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$symv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - stdlib_${ci}$dotu( k-1, work, 1, a( 1, k ),1 ) + a( k, k ) = a( k, k ) - stdlib${ii}$_${ci}$dotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ ) end if - kstep = 1 + kstep = 1_${ik}$ else ! 2 x 2 diagonal block ! invert the diagonal block. @@ -67365,31 +67356,31 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$copy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_${ci}$symv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_${ci}$copy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$symv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - stdlib_${ci}$dotu( k-1, work, 1, a( 1, k ),1 ) - a( k, k+1 ) = a( k, k+1 ) -stdlib_${ci}$dotu( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) + a( k, k ) = a( k, k ) - stdlib${ii}$_${ci}$dotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ ) + a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_${ci}$dotu( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) - call stdlib_${ci}$copy( k-1, a( 1, k+1 ), 1, work, 1 ) - call stdlib_${ci}$symv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k+1 ), 1 ) + call stdlib${ii}$_${ci}$copy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$symv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k+1 ), 1_${ik}$ ) - a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib_${ci}$dotu( k-1, work, 1, a( 1, k+1 ), 1 ) + a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib${ii}$_${ci}$dotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) end if - kstep = 2 + 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_${ci}$swap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_${ci}$swap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + call stdlib${ii}$_${ci}$swap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$swap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp - 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 @@ -67406,18 +67397,18 @@ module stdlib_linalg_lapack_${ci}$ 50 continue ! if k < 1, exit from loop. if( k<1 )go to 60 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = cone / a( k, k ) ! compute column k of the inverse. if( k0 .and. a( info, info )==czero )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 = 1_${ik}$ 30 continue ! if k > n, exit from loop. if( k>n )go to 40 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = cone / a( k, k ) ! compute column k of the inverse. - if( k>1 ) then - call stdlib_${ci}$copy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_${ci}$symv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_${ci}$copy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$symv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - stdlib_${ci}$dotu( k-1, work, 1, a( 1, k ),1 ) + a( k, k ) = a( k, k ) - stdlib${ii}$_${ci}$dotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ ) end if - kstep = 1 + kstep = 1_${ik}$ else ! 2 x 2 diagonal block ! invert the diagonal block. @@ -67553,28 +67544,28 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$copy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_${ci}$symv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_${ci}$copy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$symv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - stdlib_${ci}$dotu( k-1, work, 1, a( 1, k ),1 ) - a( k, k+1 ) = a( k, k+1 ) -stdlib_${ci}$dotu( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) + a( k, k ) = a( k, k ) - stdlib${ii}$_${ci}$dotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ ) + a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_${ci}$dotu( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) - call stdlib_${ci}$copy( k-1, a( 1, k+1 ), 1, work, 1 ) - call stdlib_${ci}$symv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k+1 ), 1 ) + call stdlib${ii}$_${ci}$copy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$symv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k+1 ), 1_${ik}$ ) - a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib_${ci}$dotu( k-1, work, 1, a( 1, k+1 ), 1 ) + a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib${ii}$_${ci}$dotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) end if - kstep = 2 + 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) kp = ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_${ci}$swap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_${ci}$swap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_${ci}$swap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$swap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp @@ -67584,8 +67575,8 @@ module stdlib_linalg_lapack_${ci}$ ! -ipiv(k+1)in the leading submatrix a(1:k+1,1:k+1) kp = -ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_${ci}$swap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_${ci}$swap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_${ci}$swap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$swap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp @@ -67593,17 +67584,17 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$swap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_${ci}$swap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_${ci}$swap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$swap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp end if end if - k = k + 1 + k = k + 1_${ik}$ go to 30 40 continue else @@ -67614,18 +67605,18 @@ module stdlib_linalg_lapack_${ci}$ 50 continue ! if k < 1, exit from loop. if( k<1 )go to 60 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = cone / a( k, k ) ! compute column k of the inverse. if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_${ci}$geru( k-1, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & + call stdlib${ii}$_${ci}$geru( k-1, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb & ) ! multiply by the inverse of the diagonal block. - call stdlib_${ci}$scal( nrhs, cone / a( k, k ), b( k, 1 ), ldb ) - k = k - 1 + call stdlib${ii}$_${ci}$scal( nrhs, cone / a( k, k ), b( k, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( kp/=k-1 )call stdlib_${ci}$swap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib${ii}$_${ci}$swap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - call stdlib_${ci}$geru( k-2, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & + call stdlib${ii}$_${ci}$geru( k-2, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb & ) - call stdlib_${ci}$geru( k-2, nrhs, -cone, a( 1, k-1 ), 1, b( k-1, 1 ),ldb, b( 1, 1 ), & + call stdlib${ii}$_${ci}$geru( k-2, nrhs, -cone, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), & ldb ) ! multiply by the inverse of the diagonal block. akm1k = a( k-1, k ) @@ -67782,39 +67773,39 @@ module stdlib_linalg_lapack_${ci}$ 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 = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(u**t(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, a( 1, k ),1, cone, b( & - k, 1 ), ldb ) + call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, a( 1_${ik}$, k ),1_${ik}$, cone, b( & + k, 1_${ik}$ ), ldb ) ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 1 + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 1_${ik}$ else ! 2 x 2 diagonal block ! multiply by inv(u**t(k+1)), where u(k+1) is the transformation ! stored in columns k and k+1 of a. - call stdlib_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, a( 1, k ),1, cone, b( & - k, 1 ), ldb ) - call stdlib_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb,a( 1, k+1 ), 1, cone, b(& - k+1, 1 ), ldb ) + call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, a( 1_${ik}$, k ),1_${ik}$, cone, b( & + k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb,a( 1_${ik}$, k+1 ), 1_${ik}$, cone, b(& + k+1, 1_${ik}$ ), ldb ) ! interchange rows k and -ipiv(k). kp = -ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 2 + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 2_${ik}$ end if go to 40 50 continue @@ -67823,34 +67814,34 @@ module stdlib_linalg_lapack_${ci}$ ! 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 = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(l**t(k)), where l(k) is the transformation ! stored in column k of a. - if( k= 1 ) - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k-1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( kp==-ipiv( k-1 ) )call stdlib_${ci}$swap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb & + if( kp==-ipiv( k-1 ) )call stdlib${ii}$_${ci}$swap( 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_${ci}$trsm('L','U','N','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib${ii}$_${ci}$trsm('L','U','N','U',n,nrhs,cone,a,lda,b,ldb) ! compute d \ b -> b [ d \ (u \p**t * b) ] i=n do while ( i >= 1 ) - if( ipiv(i) > 0 ) then - call stdlib_${ci}$scal( nrhs, cone / a( i, i ), b( i, 1 ), ldb ) - elseif ( i > 1) then + if( ipiv(i) > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$scal( nrhs, cone / 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 @@ -67990,58 +67981,58 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$trsm('L','U','T','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib${ii}$_${ci}$trsm('L','U','T','U',n,nrhs,cone,a,lda,b,ldb) ! p * b [ p * (u**t \ (d \ (u \p**t * b) )) ] - k=1 + k=1_${ik}$ do while ( k <= n ) - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k+1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( k < n .and. kp==-ipiv( k+1 ) )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp,& - 1 ), ldb ) + if( k < n .and. kp==-ipiv( k+1 ) )call stdlib${ii}$_${ci}$swap( 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k+1 else ! 2 x 2 diagonal block ! interchange rows k and -ipiv(k+1). kp = -ipiv( k+1 ) - if( kp==-ipiv( k ) )call stdlib_${ci}$swap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp==-ipiv( k ) )call stdlib${ii}$_${ci}$swap( 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_${ci}$trsm('L','L','N','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib${ii}$_${ci}$trsm('L','L','N','U',n,nrhs,cone,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_${ci}$scal( nrhs, cone / a( i, i ), b( i, 1 ), ldb ) + if( ipiv(i) > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$scal( nrhs, cone / a( i, i ), b( i, 1_${ik}$ ), ldb ) else akm1k = work(i) akm1 = a( i, i ) / akm1k @@ -68053,38 +68044,38 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$trsm('L','L','T','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib${ii}$_${ci}$trsm('L','L','T','U',n,nrhs,cone,a,lda,b,ldb) ! p * b [ p * (l**t \ (d \ (l \p**t * b) )) ] k=n do while ( k >= 1 ) - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k-1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( k>1 .and. kp==-ipiv( k-1 ) )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, & - 1 ), ldb ) + if( k>1_${ik}$ .and. kp==-ipiv( k-1 ) )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, & + 1_${ik}$ ), ldb ) k=k-2 endif end do end if ! revert a - call stdlib_${ci}$syconv( uplo, 'R', n, a, lda, ipiv, work, iinfo ) + call stdlib${ii}$_${ci}$syconv( uplo, 'R', n, a, lda, ipiv, work, iinfo ) return - end subroutine stdlib_${ci}$sytrs2 + end subroutine stdlib${ii}$_${ci}$sytrs2 - pure subroutine stdlib_${ci}$sytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) + pure subroutine stdlib${ii}$_${ci}$sytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) !! ZSYTRS_3: solves a system of linear equations A * X = B with a complex !! symmetric matrix A using the factorization computed !! by ZSYTRF_RK or ZSYTRF_BK: @@ -68099,36 +68090,36 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), intent(in) :: a(lda,*), e(*) complex(${ck}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: i, j, k, kp + integer(${ik}$) :: i, j, k, kp complex(${ck}$) :: 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_${ci}$trsm( 'L', 'U', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib${ii}$_${ci}$trsm( 'L', 'U', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) ! compute d \ b -> b [ d \ (u \p**t * b) ] i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then - call stdlib_${ci}$scal( nrhs, cone / a( i, i ), b( i, 1 ), ldb ) - else if ( i>1 ) then + if( ipiv( i )>0_${ik}$ ) then + call stdlib${ii}$_${ci}$scal( nrhs, cone / 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 @@ -68166,12 +68157,12 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$trsm( 'L', 'U', 'T', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib${ii}$_${ci}$trsm( 'L', 'U', 'T', 'U', n, nrhs, cone, a, lda, b, ldb ) ! p * b [ p * (u**t \ (d \ (u \p**t * b) )) ] ! interchange rows k and ipiv(k) of matrix b in reverse order ! from the formation order of ipiv(i) vector for upper case. @@ -68181,7 +68172,7 @@ module stdlib_linalg_lapack_${ci}$ do k = 1, n, 1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end if end do else @@ -68196,16 +68187,16 @@ module stdlib_linalg_lapack_${ci}$ do k = 1, n, 1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib${ii}$_${ci}$swap( 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_${ci}$trsm( 'L', 'L', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib${ii}$_${ci}$trsm( 'L', 'L', 'N', 'U', n, nrhs, cone, 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_${ci}$scal( nrhs, cone / a( i, i ), b( i, 1 ), ldb ) + if( ipiv( i )>0_${ik}$ ) then + call stdlib${ii}$_${ci}$scal( nrhs, cone / a( i, i ), b( i, 1_${ik}$ ), ldb ) else if( i b [ l**t \ (d \ (l \p**t * b) ) ] - call stdlib_${ci}$trsm('L', 'L', 'T', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib${ii}$_${ci}$trsm('L', 'L', 'T', 'U', n, nrhs, cone, a, lda, b, ldb ) ! p * b [ p * (l**t \ (d \ (l \p**t * b) )) ] ! interchange rows k and ipiv(k) of matrix b in reverse order ! from the formation order of ipiv(i) vector for lower case. @@ -68232,16 +68223,16 @@ module stdlib_linalg_lapack_${ci}$ do k = n, 1, -1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end if end do ! end lower end if return - end subroutine stdlib_${ci}$sytrs_3 + end subroutine stdlib${ii}$_${ci}$sytrs_3 - pure subroutine stdlib_${ci}$sytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) + pure subroutine stdlib${ii}$_${ci}$sytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) !! ZSYTRS_AA: solves a system of linear equations A*X = B with a complex !! symmetric matrix A using the factorization A = U**T*T*U or !! A = L*T*L**T computed by ZSYTRF_AA. @@ -68251,42 +68242,42 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), intent(in) :: a(lda,*) complex(${ck}$), intent(inout) :: b(ldb,*) complex(${ck}$), 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 + if( n>1_${ik}$ ) then ! pivot, p**t * b -> b do k = 1, n kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end do ! compute u**t \ b -> b [ (u**t \p**t * b) ] - call stdlib_${ci}$trsm( 'L', 'U', 'T', 'U', n-1, nrhs, cone, a( 1, 2 ),lda, b( 2, 1 ),& + call stdlib${ii}$_${ci}$trsm( 'L', 'U', 'T', 'U', n-1, nrhs, cone, a( 1_${ik}$, 2_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),& ldb) end if ! 2) solve with triangular matrix t ! compute t \ b -> b [ t \ (u**t \p**t * b) ] - call stdlib_${ci}$lacpy( 'F', 1, n, a( 1, 1 ), lda+1, work( n ), 1) - if( n>1 ) then - call stdlib_${ci}$lacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 1 ), 1 ) - call stdlib_${ci}$lacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 2*n ), 1 ) + call stdlib${ii}$_${ci}$lacpy( 'F', 1_${ik}$, n, a( 1_${ik}$, 1_${ik}$ ), lda+1, work( n ), 1_${ik}$) + if( n>1_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'F', 1_${ik}$, n-1, a( 1_${ik}$, 2_${ik}$ ), lda+1, work( 1_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacpy( 'F', 1_${ik}$, n-1, a( 1_${ik}$, 2_${ik}$ ), lda+1, work( 2_${ik}$*n ), 1_${ik}$ ) end if - call stdlib_${ci}$gtsv( n, nrhs, work( 1 ), work( n ), work( 2*n ), b, ldb,info ) + call stdlib${ii}$_${ci}$gtsv( n, nrhs, work( 1_${ik}$ ), work( n ), work( 2_${ik}$*n ), b, ldb,info ) ! 3) backward substitution with u - if( n>1 ) then + if( n>1_${ik}$ ) then ! compute u \ b -> b [ u \ (t \ (u**t \p**t * b) ) ] - call stdlib_${ci}$trsm( 'L', 'U', 'N', 'U', n-1, nrhs, cone, a( 1, 2 ),lda, b( 2, 1 ),& + call stdlib${ii}$_${ci}$trsm( 'L', 'U', 'N', 'U', n-1, nrhs, cone, a( 1_${ik}$, 2_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),& ldb) ! pivot, p * b -> b [ p * (u \ (t \ (u**t \p**t * b) )) ] do k = n, 1, -1 kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end do end if else ! solve a*x = b, where a = l*t*l**t. ! 1) forward substitution with l - if( n>1 ) then + if( n>1_${ik}$ ) then ! pivot, p**t * b -> b do k = 1, n kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end do ! compute l \ b -> b [ (l \p**t * b) ] - call stdlib_${ci}$trsm( 'L', 'L', 'N', 'U', n-1, nrhs, cone, a( 2, 1 ),lda, b( 2, 1 ),& + call stdlib${ii}$_${ci}$trsm( 'L', 'L', 'N', 'U', n-1, nrhs, cone, a( 2_${ik}$, 1_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),& ldb) end if ! 2) solve with triangular matrix t ! compute t \ b -> b [ t \ (l \p**t * b) ] - call stdlib_${ci}$lacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1) - if( n>1 ) then - call stdlib_${ci}$lacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 1 ), 1 ) - call stdlib_${ci}$lacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 2*n ), 1 ) + call stdlib${ii}$_${ci}$lacpy( 'F', 1_${ik}$, n, a(1_${ik}$, 1_${ik}$), lda+1, work(n), 1_${ik}$) + if( n>1_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'F', 1_${ik}$, n-1, a( 2_${ik}$, 1_${ik}$ ), lda+1, work( 1_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$lacpy( 'F', 1_${ik}$, n-1, a( 2_${ik}$, 1_${ik}$ ), lda+1, work( 2_${ik}$*n ), 1_${ik}$ ) end if - call stdlib_${ci}$gtsv( n, nrhs, work( 1 ), work(n), work( 2*n ), b, ldb,info) + call stdlib${ii}$_${ci}$gtsv( n, nrhs, work( 1_${ik}$ ), work(n), work( 2_${ik}$*n ), b, ldb,info) ! 3) backward substitution with l**t - if( n>1 ) then + if( n>1_${ik}$ ) then ! compute (l**t \ b) -> b [ l**t \ (t \ (l \p**t * b) ) ] - call stdlib_${ci}$trsm( 'L', 'L', 'T', 'U', n-1, nrhs, cone, a( 2, 1 ),lda, b( 2, 1 ),& + call stdlib${ii}$_${ci}$trsm( 'L', 'L', 'T', 'U', n-1, nrhs, cone, a( 2_${ik}$, 1_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),& ldb) ! pivot, p * b -> b [ p * (l**t \ (t \ (l \p**t * b) )) ] do k = n, 1, -1 kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end do end if end if return - end subroutine stdlib_${ci}$sytrs_aa + end subroutine stdlib${ii}$_${ci}$sytrs_aa - pure subroutine stdlib_${ci}$sytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) + pure subroutine stdlib${ii}$_${ci}$sytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) !! ZSYTRS_ROOK: solves a system of linear equations A*X = B with !! a complex symmetric matrix A using the factorization A = U*D*U**T or !! A = L*D*L**T computed by ZSYTRF_ROOK. @@ -68369,36 +68360,36 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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(*) complex(${ck}$), intent(in) :: a(lda,*) complex(${ck}$), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: j, k, kp + integer(${ik}$) :: j, k, kp complex(${ck}$) :: 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_${ci}$geru( k-1, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & + call stdlib${ii}$_${ci}$geru( k-1, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb & ) ! multiply by the inverse of the diagonal block. - call stdlib_${ci}$scal( nrhs, cone / a( k, k ), b( k, 1 ), ldb ) - k = k - 1 + call stdlib${ii}$_${ci}$scal( nrhs, cone / a( k, k ), b( k, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ else ! 2 x 2 diagonal block ! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1) kp = -ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) kp = -ipiv( k-1 ) - if( kp/=k-1 )call stdlib_${ci}$swap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib${ii}$_${ci}$swap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - if( k>2 ) then - call stdlib_${ci}$geru( k-2, nrhs,-cone, a( 1, k ), 1, b( k, 1 ),ldb, b( 1, 1 ), & + if( k>2_${ik}$ ) then + call stdlib${ii}$_${ci}$geru( k-2, nrhs,-cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), & ldb ) - call stdlib_${ci}$geru( k-2, nrhs,-cone, a( 1, k-1 ), 1, b( k-1, 1 ),ldb, b( 1, 1 )& + call stdlib${ii}$_${ci}$geru( k-2, nrhs,-cone, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ )& , ldb ) end if ! multiply by the inverse of the diagonal block. @@ -68450,43 +68441,43 @@ module stdlib_linalg_lapack_${ci}$ 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 = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(u**t(k)), where u(k) is the transformation ! stored in column k of a. - if( k>1 )call stdlib_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), 1, & - cone, b( k, 1 ), ldb ) + if( k>1_${ik}$ )call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, & + cone, b( k, 1_${ik}$ ), ldb ) ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 1 + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 1_${ik}$ else ! 2 x 2 diagonal block ! multiply by inv(u**t(k+1)), where u(k+1) is the transformation ! stored in columns k and k+1 of a. - if( k>1 ) then - call stdlib_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), 1, cone, & - b( k, 1 ), ldb ) - call stdlib_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k+1 ), 1, cone,& - b( k+1, 1 ), ldb ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, cone, & + b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_${ci}$gemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k+1 ), 1_${ik}$, cone,& + b( k+1, 1_${ik}$ ), ldb ) end if ! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1). kp = -ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) kp = -ipiv( k+1 ) - if( kp/=k+1 )call stdlib_${ci}$swap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 2 + if( kp/=k+1 )call stdlib${ii}$_${ci}$swap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 2_${ik}$ end if go to 40 50 continue @@ -68495,36 +68486,36 @@ module stdlib_linalg_lapack_${ci}$ ! 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 = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_${ci}$swap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_${ci}$swap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(l**t(k)), where l(k) is the transformation ! stored in column k of a. - if( k 0. if( anorm>zero ) then ! estimate the 1-norm of the inverse of a. ainvnm = zero normin = 'N' if( onenrm ) then - kase1 = 1 + kase1 = 1_${ik}$ else - kase1 = 2 + kase1 = 2_${ik}$ end if - kase = 0 + kase = 0_${ik}$ 10 continue - call stdlib_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + if( kase/=0_${ik}$ ) then if( kase==kase1 ) then ! multiply by inv(a). - call stdlib_${ci}$latbs( uplo, 'NO TRANSPOSE', diag, normin, n, kd,ab, ldab, work, & + call stdlib${ii}$_${ci}$latbs( uplo, 'NO TRANSPOSE', diag, normin, n, kd,ab, ldab, work, & scale, rwork, info ) else ! multiply by inv(a**h). - call stdlib_${ci}$latbs( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, kd, ab, ldab,& + call stdlib${ii}$_${ci}$latbs( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, kd, ab, ldab,& work, scale, rwork, info ) end if normin = 'Y' ! multiply by 1/scale if doing so will not cause overflow. if( scale/=one ) then - ix = stdlib_i${ci}$amax( n, work, 1 ) + ix = stdlib${ii}$_i${ci}$amax( n, work, 1_${ik}$ ) xnorm = cabs1( work( ix ) ) if( scale a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) - call stdlib_${ci}$trtri( 'L', diag, n1, a( 0 ), n, info ) + call stdlib${ii}$_${ci}$trtri( 'L', diag, n1, a( 0_${ik}$ ), n, info ) if( info>0 )return - call stdlib_${ci}$trmm( 'R', 'L', 'N', diag, n2, n1, -cone, a( 0 ),n, a( n1 ), n ) + call stdlib${ii}$_${ci}$trmm( 'R', 'L', 'N', diag, n2, n1, -cone, a( 0_${ik}$ ),n, a( n1 ), n ) - call stdlib_${ci}$trtri( 'U', diag, n2, a( n ), n, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_${ci}$trtri( 'U', diag, n2, a( n ), n, info ) + if( info>0_${ik}$ )info = info + n1 if( info>0 )return - call stdlib_${ci}$trmm( 'L', 'U', 'C', diag, n2, n1, cone, a( n ), n,a( n1 ), n ) + call stdlib${ii}$_${ci}$trmm( 'L', 'U', 'C', diag, n2, n1, cone, a( n ), n,a( n1 ), n ) else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) - call stdlib_${ci}$trtri( 'L', diag, n1, a( n2 ), n, info ) + call stdlib${ii}$_${ci}$trtri( 'L', diag, n1, a( n2 ), n, info ) if( info>0 )return - call stdlib_${ci}$trmm( 'L', 'L', 'C', diag, n1, n2, -cone, a( n2 ),n, a( 0 ), n ) + call stdlib${ii}$_${ci}$trmm( 'L', 'L', 'C', diag, n1, n2, -cone, a( n2 ),n, a( 0_${ik}$ ), n ) - call stdlib_${ci}$trtri( 'U', diag, n2, a( n1 ), n, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_${ci}$trtri( 'U', diag, n2, a( n1 ), n, info ) + if( info>0_${ik}$ )info = info + n1 if( info>0 )return - call stdlib_${ci}$trmm( 'R', 'U', 'N', diag, n1, n2, cone, a( n1 ),n, a( 0 ), n ) + call stdlib${ii}$_${ci}$trmm( 'R', 'U', 'N', diag, n1, n2, cone, a( n1 ),n, a( 0_${ik}$ ), n ) end if else @@ -69603,26 +69594,26 @@ module stdlib_linalg_lapack_${ci}$ if( lower ) then ! srpa for lower, transpose and n is odd ! t1 -> a(0), t2 -> a(1), s -> a(0+n1*n1) - call stdlib_${ci}$trtri( 'U', diag, n1, a( 0 ), n1, info ) + call stdlib${ii}$_${ci}$trtri( 'U', diag, n1, a( 0_${ik}$ ), n1, info ) if( info>0 )return - call stdlib_${ci}$trmm( 'L', 'U', 'N', diag, n1, n2, -cone, a( 0 ),n1, a( n1*n1 ), & + call stdlib${ii}$_${ci}$trmm( 'L', 'U', 'N', diag, n1, n2, -cone, a( 0_${ik}$ ),n1, a( n1*n1 ), & n1 ) - call stdlib_${ci}$trtri( 'L', diag, n2, a( 1 ), n1, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_${ci}$trtri( 'L', diag, n2, a( 1_${ik}$ ), n1, info ) + if( info>0_${ik}$ )info = info + n1 if( info>0 )return - call stdlib_${ci}$trmm( 'R', 'L', 'C', diag, n1, n2, cone, a( 1 ),n1, a( n1*n1 ), & + call stdlib${ii}$_${ci}$trmm( 'R', 'L', 'C', diag, n1, n2, cone, a( 1_${ik}$ ),n1, a( n1*n1 ), & n1 ) else ! srpa for upper, transpose and n is odd ! t1 -> a(0+n2*n2), t2 -> a(0+n1*n2), s -> a(0) - call stdlib_${ci}$trtri( 'U', diag, n1, a( n2*n2 ), n2, info ) + call stdlib${ii}$_${ci}$trtri( 'U', diag, n1, a( n2*n2 ), n2, info ) if( info>0 )return - call stdlib_${ci}$trmm( 'R', 'U', 'C', diag, n2, n1, -cone,a( n2*n2 ), n2, a( 0 ), & + call stdlib${ii}$_${ci}$trmm( 'R', 'U', 'C', diag, n2, n1, -cone,a( n2*n2 ), n2, a( 0_${ik}$ ), & n2 ) - call stdlib_${ci}$trtri( 'L', diag, n2, a( n1*n2 ), n2, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_${ci}$trtri( 'L', diag, n2, a( n1*n2 ), n2, info ) + if( info>0_${ik}$ )info = info + n1 if( info>0 )return - call stdlib_${ci}$trmm( 'L', 'L', 'N', diag, n2, n1, cone,a( n1*n2 ), n2, a( 0 ), & + call stdlib${ii}$_${ci}$trmm( 'L', 'L', 'N', diag, n2, n1, cone,a( n1*n2 ), n2, a( 0_${ik}$ ), & n2 ) end if end if @@ -69634,27 +69625,27 @@ module stdlib_linalg_lapack_${ci}$ ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) - call stdlib_${ci}$trtri( 'L', diag, k, a( 1 ), n+1, info ) + call stdlib${ii}$_${ci}$trtri( 'L', diag, k, a( 1_${ik}$ ), n+1, info ) if( info>0 )return - call stdlib_${ci}$trmm( 'R', 'L', 'N', diag, k, k, -cone, a( 1 ),n+1, a( k+1 ), n+& - 1 ) - call stdlib_${ci}$trtri( 'U', diag, k, a( 0 ), n+1, info ) - if( info>0 )info = info + k + call stdlib${ii}$_${ci}$trmm( 'R', 'L', 'N', diag, k, k, -cone, a( 1_${ik}$ ),n+1, a( k+1 ), n+& + 1_${ik}$ ) + call stdlib${ii}$_${ci}$trtri( 'U', diag, k, a( 0_${ik}$ ), n+1, info ) + if( info>0_${ik}$ )info = info + k if( info>0 )return - call stdlib_${ci}$trmm( 'L', 'U', 'C', diag, k, k, cone, a( 0 ), n+1,a( k+1 ), n+1 & + call stdlib${ii}$_${ci}$trmm( 'L', 'U', 'C', diag, k, k, cone, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 & ) else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) - call stdlib_${ci}$trtri( 'L', diag, k, a( k+1 ), n+1, info ) + call stdlib${ii}$_${ci}$trtri( 'L', diag, k, a( k+1 ), n+1, info ) if( info>0 )return - call stdlib_${ci}$trmm( 'L', 'L', 'C', diag, k, k, -cone, a( k+1 ),n+1, a( 0 ), n+& - 1 ) - call stdlib_${ci}$trtri( 'U', diag, k, a( k ), n+1, info ) - if( info>0 )info = info + k + call stdlib${ii}$_${ci}$trmm( 'L', 'L', 'C', diag, k, k, -cone, a( k+1 ),n+1, a( 0_${ik}$ ), n+& + 1_${ik}$ ) + call stdlib${ii}$_${ci}$trtri( 'U', diag, k, a( k ), n+1, info ) + if( info>0_${ik}$ )info = info + k if( info>0 )return - call stdlib_${ci}$trmm( 'R', 'U', 'N', diag, k, k, cone, a( k ), n+1,a( 0 ), n+1 ) + call stdlib${ii}$_${ci}$trmm( 'R', 'U', 'N', diag, k, k, cone, a( k ), n+1,a( 0_${ik}$ ), n+1 ) end if else @@ -69663,36 +69654,36 @@ module stdlib_linalg_lapack_${ci}$ ! srpa for lower, transpose and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1) ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k - call stdlib_${ci}$trtri( 'U', diag, k, a( k ), k, info ) + call stdlib${ii}$_${ci}$trtri( 'U', diag, k, a( k ), k, info ) if( info>0 )return - call stdlib_${ci}$trmm( 'L', 'U', 'N', diag, k, k, -cone, a( k ), k,a( k*( k+1 ) ),& + call stdlib${ii}$_${ci}$trmm( 'L', 'U', 'N', diag, k, k, -cone, a( k ), k,a( k*( k+1 ) ),& k ) - call stdlib_${ci}$trtri( 'L', diag, k, a( 0 ), k, info ) - if( info>0 )info = info + k + call stdlib${ii}$_${ci}$trtri( 'L', diag, k, a( 0_${ik}$ ), k, info ) + if( info>0_${ik}$ )info = info + k if( info>0 )return - call stdlib_${ci}$trmm( 'R', 'L', 'C', diag, k, k, cone, a( 0 ), k,a( k*( k+1 ) ), & + call stdlib${ii}$_${ci}$trmm( 'R', 'L', 'C', diag, k, k, cone, a( 0_${ik}$ ), k,a( k*( k+1 ) ), & k ) else ! srpa for upper, transpose and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0) ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k - call stdlib_${ci}$trtri( 'U', diag, k, a( k*( k+1 ) ), k, info ) + call stdlib${ii}$_${ci}$trtri( 'U', diag, k, a( k*( k+1 ) ), k, info ) if( info>0 )return - call stdlib_${ci}$trmm( 'R', 'U', 'C', diag, k, k, -cone,a( k*( k+1 ) ), k, a( 0 ),& + call stdlib${ii}$_${ci}$trmm( 'R', 'U', 'C', diag, k, k, -cone,a( k*( k+1 ) ), k, a( 0_${ik}$ ),& k ) - call stdlib_${ci}$trtri( 'L', diag, k, a( k*k ), k, info ) - if( info>0 )info = info + k + call stdlib${ii}$_${ci}$trtri( 'L', diag, k, a( k*k ), k, info ) + if( info>0_${ik}$ )info = info + k if( info>0 )return - call stdlib_${ci}$trmm( 'L', 'L', 'N', diag, k, k, cone, a( k*k ), k,a( 0 ), k ) + call stdlib${ii}$_${ci}$trmm( 'L', 'L', 'N', diag, k, k, cone, a( k*k ), k,a( 0_${ik}$ ), k ) end if end if end if return - end subroutine stdlib_${ci}$tftri + end subroutine stdlib${ii}$_${ci}$tftri - pure subroutine stdlib_${ci}$tfttp( transr, uplo, n, arf, ap, info ) + pure subroutine stdlib${ii}$_${ci}$tfttp( transr, uplo, n, arf, ap, info ) !! ZTFTTP: copies a triangular matrix A from rectangular full packed !! format (TF) to standard packed format (TP). ! -- lapack computational routine -- @@ -69700,71 +69691,71 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n ! Array Arguments - complex(${ck}$), intent(out) :: ap(0:*) - complex(${ck}$), intent(in) :: arf(0:*) + complex(${ck}$), intent(out) :: ap(0_${ik}$:*) + complex(${ck}$), intent(in) :: arf(0_${ik}$:*) ! ===================================================================== ! Parameters ! Local Scalars logical(lk) :: lower, nisodd, normaltransr - integer(ilp) :: n1, n2, k, nt - integer(ilp) :: i, j, ij - integer(ilp) :: ijp, jp, lda, js + integer(${ik}$) :: n1, n2, k, nt + integer(${ik}$) :: i, j, ij + integer(${ik}$) :: ijp, jp, lda, js ! Intrinsic Functions intrinsic :: conjg ! Intrinsic Functions ! 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, 'C' ) ) 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 + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'ZTFTTP', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZTFTTP', -info ) return end if ! quick return if possible if( n==0 )return - if( n==1 ) then + if( n==1_${ik}$ ) then if( normaltransr ) then - ap( 0 ) = arf( 0 ) + ap( 0_${ik}$ ) = arf( 0_${ik}$ ) else - ap( 0 ) = conjg( arf( 0 ) ) + ap( 0_${ik}$ ) = conjg( arf( 0_${ik}$ ) ) end if return end if ! size of array arf(0:nt-1) - nt = n*( n+1 ) / 2 + nt = n*( n+1 ) / 2_${ik}$ ! set n1 and n2 depending on lower if( lower ) then - n2 = n / 2 + n2 = n / 2_${ik}$ n1 = n - n2 else - n1 = n / 2 + n1 = n / 2_${ik}$ n2 = n - n1 end if ! if n is odd, set nisodd = .true. ! if n is even, set k = n/2 and nisodd = .false. ! set lda of arf^c; arf^c is (0:(n+1)/2-1,0:n-noe) ! where noe = 0 if n is even, noe = 1 if n is odd - if( mod( n, 2 )==0 ) then - k = n / 2 + if( mod( n, 2_${ik}$ )==0_${ik}$ ) then + k = n / 2_${ik}$ nisodd = .false. - lda = n + 1 + lda = n + 1_${ik}$ else nisodd = .true. lda = n end if ! arf^c has lda rows and n+1-noe cols - if( .not.normaltransr )lda = ( n+1 ) / 2 + if( .not.normaltransr )lda = ( n+1 ) / 2_${ik}$ ! start execution: there are eight cases if( nisodd ) then ! n is odd @@ -69774,13 +69765,13 @@ module stdlib_linalg_lapack_${ci}$ ! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) ) ! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1); lda = n - ijp = 0 - jp = 0 + 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 @@ -69788,28 +69779,28 @@ module stdlib_linalg_lapack_${ci}$ do j = 1 + i, n2 ij = i + j*lda ap( ijp ) = conjg( 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 + ijp = 0_${ik}$ do j = 0, n1 - 1 ij = n2 + j do i = 0, j ap( ijp ) = conjg( 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 @@ -69820,38 +69811,38 @@ module stdlib_linalg_lapack_${ci}$ ! 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 + ijp = 0_${ik}$ do i = 0, n2 do ij = i*( lda+1 ), n*lda - 1, lda ap( ijp ) = conjg( 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 + 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 ) = conjg( arf( ij ) ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do end do end if @@ -69864,13 +69855,13 @@ module stdlib_linalg_lapack_${ci}$ ! 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 + 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 @@ -69878,28 +69869,28 @@ module stdlib_linalg_lapack_${ci}$ do j = i, k - 1 ij = i + j*lda ap( ijp ) = conjg( 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 + ijp = 0_${ik}$ do j = 0, k - 1 - ij = k + 1 + j + ij = k + 1_${ik}$ + j do i = 0, j ap( ijp ) = conjg( 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 @@ -69910,48 +69901,48 @@ module stdlib_linalg_lapack_${ci}$ ! 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 + ijp = 0_${ik}$ do i = 0, k - 1 do ij = i + ( i+1 )*lda, ( n+1 )*lda - 1, lda ap( ijp ) = conjg( 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 + 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 ) = conjg( arf( ij ) ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do end do end if end if end if return - end subroutine stdlib_${ci}$tfttp + end subroutine stdlib${ii}$_${ci}$tfttp - pure subroutine stdlib_${ci}$tfttr( transr, uplo, n, arf, a, lda, info ) + pure subroutine stdlib${ii}$_${ci}$tfttr( transr, uplo, n, arf, a, lda, info ) !! ZTFTTR: copies a triangular matrix A from rectangular full packed !! format (TF) to standard full format (TR). ! -- lapack computational routine -- @@ -69959,65 +69950,65 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 - complex(${ck}$), intent(out) :: a(0:lda-1,0:*) - complex(${ck}$), intent(in) :: arf(0:*) + complex(${ck}$), intent(out) :: a(0_${ik}$:lda-1,0_${ik}$:*) + complex(${ck}$), intent(in) :: arf(0_${ik}$:*) ! ===================================================================== ! Parameters ! 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 :: conjg,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, 'C' ) ) 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 a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1); lda=n - ij = 0 + ij = 0_${ik}$ do j = 0, n2 do i = n1, n2 + j a( n2+j, i ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do i = j, n - 1 a( i, j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do else @@ -70049,11 +70040,11 @@ module stdlib_linalg_lapack_${ci}$ do j = n - 1, n1, -1 do i = 0, j a( i, j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do l = j - n1, n1 - 1 a( j-n1, l ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do ij = ij - nx2 end do @@ -70064,42 +70055,42 @@ module stdlib_linalg_lapack_${ci}$ ! 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 - ij = 0 + ij = 0_${ik}$ do j = 0, n2 - 1 do i = 0, j a( j, i ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do i = n1 + j, n - 1 a( i, n1+j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do do j = n2, n - 1 do i = 0, n1 - 1 a( j, i ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do 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 - ij = 0 + ij = 0_${ik}$ do j = 0, n1 do i = n1, n - 1 a( j, i ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do do j = 0, n1 - 1 do i = 0, j a( i, j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do l = n2 + j, n - 1 a( n2+j, l ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do end if @@ -70112,30 +70103,30 @@ module stdlib_linalg_lapack_${ci}$ ! 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); lda=n+1 - ij = 0 + ij = 0_${ik}$ do j = 0, k - 1 do i = k, k + j a( k+j, i ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do i = j, n - 1 a( i, j ) = arf( ij ) - ij = ij + 1 + ij = ij + 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); lda=n+1 - ij = nt - n - 1 + ij = nt - n - 1_${ik}$ do j = n - 1, k, -1 do i = 0, j a( i, j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do l = j - k, k - 1 a( j-k, l ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do ij = ij - np1x2 end do @@ -70146,62 +70137,62 @@ module stdlib_linalg_lapack_${ci}$ ! srpa for lower, transpose and n is even (see paper, a=b) ! t1 -> a(0,1) , t2 -> a(0,0) , s -> a(0,k+1) : ! t1 -> a(0+k) , t2 -> a(0+0) , s -> a(0+k*(k+1)); lda=k - ij = 0 + ij = 0_${ik}$ j = k do i = k, n - 1 a( i, j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do j = 0, k - 2 do i = 0, j a( j, i ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do i = k + 1 + j, n - 1 a( i, k+1+j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do do j = k - 1, n - 1 do i = 0, k - 1 a( j, i ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do else ! srpa for upper, transpose and n is even (see paper, a=b) ! t1 -> a(0,k+1) , t2 -> a(0,k) , s -> a(0,0) ! t1 -> a(0+k*(k+1)) , t2 -> a(0+k*k) , s -> a(0+0)); lda=k - ij = 0 + ij = 0_${ik}$ do j = 0, k do i = k, n - 1 a( j, i ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do do j = 0, k - 2 do i = 0, j a( i, j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do l = k + 1 + j, n - 1 a( k+1+j, l ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do ! note that here j = k-1 do i = 0, j a( i, j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end if end if end if return - end subroutine stdlib_${ci}$tfttr + end subroutine stdlib${ii}$_${ci}$tfttr - pure subroutine stdlib_${ci}$tgevc( side, howmny, select, n, s, lds, p, ldp, vl,ldvl, vr, ldvr, & + pure subroutine stdlib${ii}$_${ci}$tgevc( side, howmny, select, n, s, lds, p, ldp, vl,ldvl, vr, ldvr, & !! ZTGEVC: computes some or all of the right and/or left eigenvectors of !! a pair of complex matrices (S,P), where S and P are upper triangular. !! Matrix pairs of this type are produced by the generalized Schur @@ -70226,8 +70217,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: howmny, side - integer(ilp), intent(out) :: info, m - integer(ilp), intent(in) :: ldp, lds, ldvl, ldvr, mm, n + integer(${ik}$), intent(out) :: info, m + integer(${ik}$), intent(in) :: ldp, lds, ldvl, ldvr, mm, n ! Array Arguments logical(lk), intent(in) :: select(*) real(${ck}$), intent(out) :: rwork(*) @@ -70239,7 +70230,7 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: compl, compr, ilall, ilback, ilbbad, ilcomp, lsa, lsb - integer(ilp) :: i, ibeg, ieig, iend, ihwmny, im, iside, isrc, j, je, jr + integer(${ik}$) :: i, ibeg, ieig, iend, ihwmny, im, iside, isrc, j, je, jr real(${ck}$) :: acoefa, acoeff, anorm, ascale, bcoefa, big, bignum, bnorm, bscale, dmin, & safmin, sbeta, scale, small, temp, ulp, xmax complex(${ck}$) :: bcoeff, ca, cb, d, salpha, sum, suma, sumb, x @@ -70252,56 +70243,56 @@ module stdlib_linalg_lapack_${ci}$ ! Executable Statements ! decode and test the input parameters if( stdlib_lsame( howmny, 'A' ) ) then - ihwmny = 1 + ihwmny = 1_${ik}$ ilall = .true. ilback = .false. else if( stdlib_lsame( howmny, 'S' ) ) then - ihwmny = 2 + ihwmny = 2_${ik}$ ilall = .false. ilback = .false. else if( stdlib_lsame( howmny, 'B' ) ) then - ihwmny = 3 + ihwmny = 3_${ik}$ ilall = .true. ilback = .true. else - ihwmny = -1 + ihwmny = -1_${ik}$ end if if( stdlib_lsame( side, 'R' ) ) then - iside = 1 + iside = 1_${ik}$ compl = .false. compr = .true. else if( stdlib_lsame( side, 'L' ) ) then - iside = 2 + iside = 2_${ik}$ compl = .true. compr = .false. else if( stdlib_lsame( side, 'B' ) ) then - iside = 3 + iside = 3_${ik}$ compl = .true. compr = .true. else - iside = -1 + iside = -1_${ik}$ end if - info = 0 - if( iside<0 ) then - info = -1 - else if( ihwmny<0 ) then - info = -2 - else if( n<0 ) then - info = -4 - else if( lds1 ) then + work( j ) = stdlib${ii}$_${ci}$ladiv( -work( j ), d ) + if( j>1_${ik}$ ) then ! w = w + x(j)*(a s(*,j) - b p(*,j) ) with scaling if( abs1( work( j ) )>one ) then temp = one / abs1( work( j ) ) @@ -70583,12 +70574,12 @@ module stdlib_linalg_lapack_${ci}$ end do loop_210 ! back transform eigenvector if howmny='b'. if( ilback ) then - call stdlib_${ci}$gemv( 'N', n, je, cone, vr, ldvr, work, 1,czero, work( n+1 ), & - 1 ) - isrc = 2 + call stdlib${ii}$_${ci}$gemv( 'N', n, je, cone, vr, ldvr, work, 1_${ik}$,czero, work( n+1 ), & + 1_${ik}$ ) + isrc = 2_${ik}$ iend = n else - isrc = 1 + isrc = 1_${ik}$ iend = je end if ! copy and scale eigenvector into column of vr @@ -70602,7 +70593,7 @@ module stdlib_linalg_lapack_${ci}$ vr( jr, ieig ) = temp*work( ( isrc-1 )*n+jr ) end do else - iend = 0 + iend = 0_${ik}$ end if do jr = iend + 1, n vr( jr, ieig ) = czero @@ -70611,10 +70602,10 @@ module stdlib_linalg_lapack_${ci}$ end do loop_250 end if return - end subroutine stdlib_${ci}$tgevc + end subroutine stdlib${ii}$_${ci}$tgevc - pure subroutine stdlib_${ci}$tgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, j1, info ) + pure subroutine stdlib${ii}$_${ci}$tgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, j1, info ) !! ZTGEX2: swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22) !! in an upper triangular matrix pair (A, B) by an unitary equivalence !! transformation. @@ -70630,14 +70621,14 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: wantq, wantz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: j1, lda, ldb, ldq, ldz, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: j1, lda, ldb, ldq, ldz, n ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) ! ===================================================================== ! Parameters real(${ck}$), parameter :: twenty = 2.0e+1_${ck}$ - integer(ilp), parameter :: ldst = 2 + integer(${ik}$), parameter :: ldst = 2_${ik}$ logical(lk), parameter :: wands = .true. @@ -70645,35 +70636,35 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: strong, weak - integer(ilp) :: i, m + integer(${ik}$) :: i, m real(${ck}$) :: cq, cz, eps, sa, sb, scale, smlnum, sum, thresha, threshb complex(${ck}$) :: cdum, f, g, sq, sz ! Local Arrays - complex(${ck}$) :: s(ldst,ldst), t(ldst,ldst), work(8) + complex(${ck}$) :: s(ldst,ldst), t(ldst,ldst), work(8_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,conjg,max,sqrt ! Executable Statements - info = 0 + info = 0_${ik}$ ! quick return if possible if( n<=1 )return m = ldst weak = .false. strong = .false. ! make a local copy of selected block in (a, b) - call stdlib_${ci}$lacpy( 'FULL', m, m, a( j1, j1 ), lda, s, ldst ) - call stdlib_${ci}$lacpy( 'FULL', m, m, b( j1, j1 ), ldb, t, ldst ) + call stdlib${ii}$_${ci}$lacpy( 'FULL', m, m, a( j1, j1 ), lda, s, ldst ) + call stdlib${ii}$_${ci}$lacpy( 'FULL', m, m, b( j1, j1 ), ldb, t, ldst ) ! compute the threshold for testing the acceptance of swapping. - eps = stdlib_${c2ri(ci)}$lamch( 'P' ) - smlnum = stdlib_${c2ri(ci)}$lamch( 'S' ) / eps + eps = stdlib${ii}$_${c2ri(ci)}$lamch( 'P' ) + smlnum = stdlib${ii}$_${c2ri(ci)}$lamch( 'S' ) / eps scale = real( czero,KIND=${ck}$) sum = real( cone,KIND=${ck}$) - call stdlib_${ci}$lacpy( 'FULL', m, m, s, ldst, work, m ) - call stdlib_${ci}$lacpy( 'FULL', m, m, t, ldst, work( m*m+1 ), m ) - call stdlib_${ci}$lassq( m*m, work, 1, scale, sum ) + call stdlib${ii}$_${ci}$lacpy( 'FULL', m, m, s, ldst, work, m ) + call stdlib${ii}$_${ci}$lacpy( 'FULL', m, m, t, ldst, work( m*m+1 ), m ) + call stdlib${ii}$_${ci}$lassq( m*m, work, 1_${ik}$, scale, sum ) sa = scale*sqrt( sum ) scale = real( czero,KIND=${ck}$) sum = real( cone,KIND=${ck}$) - call stdlib_${ci}$lassq( m*m, work(m*m+1), 1, scale, sum ) + call stdlib${ii}$_${ci}$lassq( m*m, work(m*m+1), 1_${ik}$, scale, sum ) sb = scale*sqrt( sum ) ! thres has been changed from ! thresh = max( ten*eps*sa, smlnum ) @@ -70686,36 +70677,36 @@ module stdlib_linalg_lapack_${ci}$ threshb = max( twenty*eps*sb, smlnum ) ! compute unitary ql and rq that swap 1-by-1 and 1-by-1 blocks ! using givens rotations and perform the swap tentatively. - f = s( 2, 2 )*t( 1, 1 ) - t( 2, 2 )*s( 1, 1 ) - g = s( 2, 2 )*t( 1, 2 ) - t( 2, 2 )*s( 1, 2 ) - sa = abs( s( 2, 2 ) ) * abs( t( 1, 1 ) ) - sb = abs( s( 1, 1 ) ) * abs( t( 2, 2 ) ) - call stdlib_${ci}$lartg( g, f, cz, sz, cdum ) + f = s( 2_${ik}$, 2_${ik}$ )*t( 1_${ik}$, 1_${ik}$ ) - t( 2_${ik}$, 2_${ik}$ )*s( 1_${ik}$, 1_${ik}$ ) + g = s( 2_${ik}$, 2_${ik}$ )*t( 1_${ik}$, 2_${ik}$ ) - t( 2_${ik}$, 2_${ik}$ )*s( 1_${ik}$, 2_${ik}$ ) + sa = abs( s( 2_${ik}$, 2_${ik}$ ) ) * abs( t( 1_${ik}$, 1_${ik}$ ) ) + sb = abs( s( 1_${ik}$, 1_${ik}$ ) ) * abs( t( 2_${ik}$, 2_${ik}$ ) ) + call stdlib${ii}$_${ci}$lartg( g, f, cz, sz, cdum ) sz = -sz - call stdlib_${ci}$rot( 2, s( 1, 1 ), 1, s( 1, 2 ), 1, cz, conjg( sz ) ) - call stdlib_${ci}$rot( 2, t( 1, 1 ), 1, t( 1, 2 ), 1, cz, conjg( sz ) ) + call stdlib${ii}$_${ci}$rot( 2_${ik}$, s( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, s( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, cz, conjg( sz ) ) + call stdlib${ii}$_${ci}$rot( 2_${ik}$, t( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, t( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, cz, conjg( sz ) ) if( sa>=sb ) then - call stdlib_${ci}$lartg( s( 1, 1 ), s( 2, 1 ), cq, sq, cdum ) + call stdlib${ii}$_${ci}$lartg( s( 1_${ik}$, 1_${ik}$ ), s( 2_${ik}$, 1_${ik}$ ), cq, sq, cdum ) else - call stdlib_${ci}$lartg( t( 1, 1 ), t( 2, 1 ), cq, sq, cdum ) + call stdlib${ii}$_${ci}$lartg( t( 1_${ik}$, 1_${ik}$ ), t( 2_${ik}$, 1_${ik}$ ), cq, sq, cdum ) end if - call stdlib_${ci}$rot( 2, s( 1, 1 ), ldst, s( 2, 1 ), ldst, cq, sq ) - call stdlib_${ci}$rot( 2, t( 1, 1 ), ldst, t( 2, 1 ), ldst, cq, sq ) + call stdlib${ii}$_${ci}$rot( 2_${ik}$, s( 1_${ik}$, 1_${ik}$ ), ldst, s( 2_${ik}$, 1_${ik}$ ), ldst, cq, sq ) + call stdlib${ii}$_${ci}$rot( 2_${ik}$, t( 1_${ik}$, 1_${ik}$ ), ldst, t( 2_${ik}$, 1_${ik}$ ), ldst, cq, sq ) ! weak stability test: |s21| <= o(eps f-norm((a))) ! and |t21| <= o(eps f-norm((b))) - weak = abs( s( 2, 1 ) )<=thresha .and.abs( t( 2, 1 ) )<=threshb + weak = abs( s( 2_${ik}$, 1_${ik}$ ) )<=thresha .and.abs( t( 2_${ik}$, 1_${ik}$ ) )<=threshb if( .not.weak )go to 20 if( wands ) then ! strong stability test: ! f-norm((a-ql**h*s*qr)) <= o(eps*f-norm((a))) ! and ! f-norm((b-ql**h*t*qr)) <= o(eps*f-norm((b))) - call stdlib_${ci}$lacpy( 'FULL', m, m, s, ldst, work, m ) - call stdlib_${ci}$lacpy( 'FULL', m, m, t, ldst, work( m*m+1 ), m ) - call stdlib_${ci}$rot( 2, work, 1, work( 3 ), 1, cz, -conjg( sz ) ) - call stdlib_${ci}$rot( 2, work( 5 ), 1, work( 7 ), 1, cz, -conjg( sz ) ) - call stdlib_${ci}$rot( 2, work, 2, work( 2 ), 2, cq, -sq ) - call stdlib_${ci}$rot( 2, work( 5 ), 2, work( 6 ), 2, cq, -sq ) + call stdlib${ii}$_${ci}$lacpy( 'FULL', m, m, s, ldst, work, m ) + call stdlib${ii}$_${ci}$lacpy( 'FULL', m, m, t, ldst, work( m*m+1 ), m ) + call stdlib${ii}$_${ci}$rot( 2_${ik}$, work, 1_${ik}$, work( 3_${ik}$ ), 1_${ik}$, cz, -conjg( sz ) ) + call stdlib${ii}$_${ci}$rot( 2_${ik}$, work( 5_${ik}$ ), 1_${ik}$, work( 7_${ik}$ ), 1_${ik}$, cz, -conjg( sz ) ) + call stdlib${ii}$_${ci}$rot( 2_${ik}$, work, 2_${ik}$, work( 2_${ik}$ ), 2_${ik}$, cq, -sq ) + call stdlib${ii}$_${ci}$rot( 2_${ik}$, work( 5_${ik}$ ), 2_${ik}$, work( 6_${ik}$ ), 2_${ik}$, cq, -sq ) do i = 1, 2 work( i ) = work( i ) - a( j1+i-1, j1 ) work( i+2 ) = work( i+2 ) - a( j1+i-1, j1+1 ) @@ -70724,39 +70715,39 @@ module stdlib_linalg_lapack_${ci}$ end do scale = real( czero,KIND=${ck}$) sum = real( cone,KIND=${ck}$) - call stdlib_${ci}$lassq( m*m, work, 1, scale, sum ) + call stdlib${ii}$_${ci}$lassq( m*m, work, 1_${ik}$, scale, sum ) sa = scale*sqrt( sum ) scale = real( czero,KIND=${ck}$) sum = real( cone,KIND=${ck}$) - call stdlib_${ci}$lassq( m*m, work(m*m+1), 1, scale, sum ) + call stdlib${ii}$_${ci}$lassq( m*m, work(m*m+1), 1_${ik}$, scale, sum ) sb = scale*sqrt( sum ) strong = sa<=thresha .and. sb<=threshb if( .not.strong )go to 20 end if ! if the swap is accepted ("weakly" and "strongly"), apply the ! equivalence transformations to the original matrix pair (a,b) - call stdlib_${ci}$rot( j1+1, a( 1, j1 ), 1, a( 1, j1+1 ), 1, cz,conjg( sz ) ) - call stdlib_${ci}$rot( j1+1, b( 1, j1 ), 1, b( 1, j1+1 ), 1, cz,conjg( sz ) ) - call stdlib_${ci}$rot( n-j1+1, a( j1, j1 ), lda, a( j1+1, j1 ), lda, cq, sq ) - call stdlib_${ci}$rot( n-j1+1, b( j1, j1 ), ldb, b( j1+1, j1 ), ldb, cq, sq ) + call stdlib${ii}$_${ci}$rot( j1+1, a( 1_${ik}$, j1 ), 1_${ik}$, a( 1_${ik}$, j1+1 ), 1_${ik}$, cz,conjg( sz ) ) + call stdlib${ii}$_${ci}$rot( j1+1, b( 1_${ik}$, j1 ), 1_${ik}$, b( 1_${ik}$, j1+1 ), 1_${ik}$, cz,conjg( sz ) ) + call stdlib${ii}$_${ci}$rot( n-j1+1, a( j1, j1 ), lda, a( j1+1, j1 ), lda, cq, sq ) + call stdlib${ii}$_${ci}$rot( n-j1+1, b( j1, j1 ), ldb, b( j1+1, j1 ), ldb, cq, sq ) ! set n1 by n2 (2,1) blocks to 0 a( j1+1, j1 ) = czero b( j1+1, j1 ) = czero ! accumulate transformations into q and z if requested. - if( wantz )call stdlib_${ci}$rot( n, z( 1, j1 ), 1, z( 1, j1+1 ), 1, cz,conjg( sz ) ) + if( wantz )call stdlib${ii}$_${ci}$rot( n, z( 1_${ik}$, j1 ), 1_${ik}$, z( 1_${ik}$, j1+1 ), 1_${ik}$, cz,conjg( sz ) ) - if( wantq )call stdlib_${ci}$rot( n, q( 1, j1 ), 1, q( 1, j1+1 ), 1, cq,conjg( sq ) ) + if( wantq )call stdlib${ii}$_${ci}$rot( n, q( 1_${ik}$, j1 ), 1_${ik}$, q( 1_${ik}$, j1+1 ), 1_${ik}$, cq,conjg( sq ) ) ! exit with info = 0 if swap was successfully performed. return ! exit with info = 1 if swap was rejected. 20 continue - info = 1 + info = 1_${ik}$ return - end subroutine stdlib_${ci}$tgex2 + end subroutine stdlib${ii}$_${ci}$tgex2 - pure subroutine stdlib_${ci}$tgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, ifst, ilst, & + pure subroutine stdlib${ii}$_${ci}$tgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, ifst, ilst, & !! ZTGEXC: reorders the generalized Schur decomposition of a complex !! matrix pair (A,B), using an unitary equivalence transformation !! (A, B) := Q * (A, B) * Z**H, so that the diagonal block of (A, B) with @@ -70773,36 +70764,36 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: wantq, wantz - integer(ilp), intent(in) :: ifst, lda, ldb, ldq, ldz, n - integer(ilp), intent(inout) :: ilst - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ifst, lda, ldb, ldq, ldz, n + integer(${ik}$), intent(inout) :: ilst + integer(${ik}$), intent(out) :: info ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: here + integer(${ik}$) :: here ! Intrinsic Functions intrinsic :: max ! Executable Statements ! decode and test input arguments. - info = 0 - if( n<0 ) then - info = -3 - else if( ldan ) then - info = -12 - else if( ilst<1 .or. ilst>n ) then - info = -13 - end if - if( info/=0 ) then - call stdlib_xerbla( 'ZTGEXC', -info ) + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( ldan ) then + info = -12_${ik}$ + else if( ilst<1_${ik}$ .or. ilst>n ) then + info = -13_${ik}$ + end if + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZTGEXC', -info ) return end if ! quick return if possible @@ -70812,35 +70803,35 @@ module stdlib_linalg_lapack_${ci}$ here = ifst 10 continue ! swap with next one below - call stdlib_${ci}$tgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz,here, info ) + call stdlib${ii}$_${ci}$tgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz,here, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then ilst = here return end if - here = here + 1 + here = here + 1_${ik}$ if( here=ilst )go to 20 - here = here + 1 + here = here + 1_${ik}$ end if ilst = here return - end subroutine stdlib_${ci}$tgexc + end subroutine stdlib${ii}$_${ci}$tgexc - pure subroutine stdlib_${ci}$tgsen( ijob, wantq, wantz, select, n, a, lda, b, ldb,alpha, beta, q, & + pure subroutine stdlib${ii}$_${ci}$tgsen( ijob, wantq, wantz, select, n, a, lda, b, ldb,alpha, beta, q, & !! ZTGSEN: reorders the generalized Schur decomposition of a complex !! matrix pair (A, B) (in terms of an unitary equivalence trans- !! formation Q**H * (A, B) * Z), so that a selected cluster of eigenvalues @@ -70865,94 +70856,94 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: wantq, wantz - integer(ilp), intent(in) :: ijob, lda, ldb, ldq, ldz, liwork, lwork, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: ijob, lda, ldb, ldq, ldz, liwork, lwork, n + integer(${ik}$), intent(out) :: info, m real(${ck}$), intent(out) :: pl, pr ! Array Arguments logical(lk), intent(in) :: select(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(${ck}$), intent(out) :: dif(*) complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) complex(${ck}$), intent(out) :: alpha(*), beta(*), work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: idifjb = 3 + integer(${ik}$), parameter :: idifjb = 3_${ik}$ ! Local Scalars logical(lk) :: lquery, swap, wantd, wantd1, wantd2, wantp - integer(ilp) :: i, ierr, ijb, k, kase, ks, liwmin, lwmin, mn2, n1, n2 + integer(${ik}$) :: i, ierr, ijb, k, kase, ks, liwmin, lwmin, mn2, n1, n2 real(${ck}$) :: dscale, dsum, rdscal, safmin complex(${ck}$) :: temp1, temp2 ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,cmplx,conjg,max,sqrt ! Executable Statements ! decode and test the input parameters - info = 0 - lquery = ( lwork==-1 .or. liwork==-1 ) - if( ijob<0 .or. ijob>5 ) then - info = -1 - else if( n<0 ) then - info = -5 - else if( lda=4 - wantd1 = ijob==2 .or. ijob==4 - wantd2 = ijob==3 .or. ijob==5 + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) + if( ijob<0_${ik}$ .or. ijob>5_${ik}$ ) then + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -5_${ik}$ + else if( lda=4_${ik}$ + wantd1 = ijob==2_${ik}$ .or. ijob==4_${ik}$ + wantd2 = ijob==3_${ik}$ .or. ijob==5_${ik}$ wantd = wantd1 .or. wantd2 ! set m to the dimension of the specified pair of deflating ! subspaces. - m = 0 - if( .not.lquery .or. ijob/=0 ) then + m = 0_${ik}$ + if( .not.lquery .or. ijob/=0_${ik}$ ) then do k = 1, n alpha( k ) = a( k, k ) beta( k ) = b( k, k ) if( k0 ) then + if( ierr>0_${ik}$ ) then ! swap is rejected: exit. - info = 1 + info = 1_${ik}$ if( wantp ) then pl = zero pr = zero end if if( wantd ) then - dif( 1 ) = zero - dif( 2 ) = zero + dif( 1_${ik}$ ) = zero + dif( 2_${ik}$ ) = zero end if go to 70 end if @@ -71002,18 +70993,18 @@ module stdlib_linalg_lapack_${ci}$ ! b11 * r - l * b22 = b12 n1 = m n2 = n - m - i = n1 + 1 - call stdlib_${ci}$lacpy( 'FULL', n1, n2, a( 1, i ), lda, work, n1 ) - call stdlib_${ci}$lacpy( 'FULL', n1, n2, b( 1, i ), ldb, work( n1*n2+1 ),n1 ) - ijb = 0 - call stdlib_${ci}$tgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b( i,& - i ), ldb, work( n1*n2+1 ), n1,dscale, dif( 1 ), work( n1*n2*2+1 ),lwork-2*n1*n2, & + i = n1 + 1_${ik}$ + call stdlib${ii}$_${ci}$lacpy( 'FULL', n1, n2, a( 1_${ik}$, i ), lda, work, n1 ) + call stdlib${ii}$_${ci}$lacpy( 'FULL', n1, n2, b( 1_${ik}$, i ), ldb, work( n1*n2+1 ),n1 ) + ijb = 0_${ik}$ + call stdlib${ii}$_${ci}$tgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b( i,& + i ), ldb, work( n1*n2+1 ), n1,dscale, dif( 1_${ik}$ ), work( n1*n2*2_${ik}$+1 ),lwork-2*n1*n2, & iwork, ierr ) ! estimate the reciprocal of norms of "projections" onto ! left and right eigenspaces rdscal = zero dsum = one - call stdlib_${ci}$lassq( n1*n2, work, 1, rdscal, dsum ) + call stdlib${ii}$_${ci}$lassq( n1*n2, work, 1_${ik}$, rdscal, dsum ) pl = rdscal*sqrt( dsum ) if( pl==zero ) then pl = one @@ -71022,7 +71013,7 @@ module stdlib_linalg_lapack_${ci}$ end if rdscal = zero dsum = one - call stdlib_${ci}$lassq( n1*n2, work( n1*n2+1 ), 1, rdscal, dsum ) + call stdlib${ii}$_${ci}$lassq( n1*n2, work( n1*n2+1 ), 1_${ik}$, rdscal, dsum ) pr = rdscal*sqrt( dsum ) if( pr==zero ) then pr = one @@ -71035,63 +71026,63 @@ module stdlib_linalg_lapack_${ci}$ if( wantd1 ) then n1 = m n2 = n - m - i = n1 + 1 + i = n1 + 1_${ik}$ ijb = idifjb ! frobenius norm-based difu estimate. - call stdlib_${ci}$tgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b(& - i, i ), ldb, work( n1*n2+1 ),n1, dscale, dif( 1 ), work( n1*n2*2+1 ),lwork-& - 2*n1*n2, iwork, ierr ) + call stdlib${ii}$_${ci}$tgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b(& + i, i ), ldb, work( n1*n2+1 ),n1, dscale, dif( 1_${ik}$ ), work( n1*n2*2_${ik}$+1 ),lwork-& + 2_${ik}$*n1*n2, iwork, ierr ) ! frobenius norm-based difl estimate. - call stdlib_${ci}$tgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda, work,n2, b( i, i ),& - ldb, b, ldb, work( n1*n2+1 ),n2, dscale, dif( 2 ), work( n1*n2*2+1 ),lwork-& - 2*n1*n2, iwork, ierr ) + call stdlib${ii}$_${ci}$tgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda, work,n2, b( i, i ),& + ldb, b, ldb, work( n1*n2+1 ),n2, dscale, dif( 2_${ik}$ ), work( n1*n2*2_${ik}$+1 ),lwork-& + 2_${ik}$*n1*n2, iwork, ierr ) else ! compute 1-norm-based estimates of difu and difl using - ! reversed communication with stdlib_${ci}$lacn2. in each step a + ! reversed communication with stdlib${ii}$_${ci}$lacn2. in each step a ! generalized sylvester equation or a transposed variant ! is solved. - kase = 0 + kase = 0_${ik}$ n1 = m n2 = n - m - i = n1 + 1 - ijb = 0 - mn2 = 2*n1*n2 + i = n1 + 1_${ik}$ + ijb = 0_${ik}$ + mn2 = 2_${ik}$*n1*n2 ! 1-norm-based estimate of difu. 40 continue - call stdlib_${ci}$lacn2( mn2, work( mn2+1 ), work, dif( 1 ), kase,isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_${ci}$lacn2( mn2, work( mn2+1 ), work, dif( 1_${ik}$ ), kase,isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! solve generalized sylvester equation - call stdlib_${ci}$tgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & - ldb, b( i, i ), ldb,work( n1*n2+1 ), n1, dscale, dif( 1 ),work( n1*n2*2+1 )& + call stdlib${ii}$_${ci}$tgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & + ldb, b( i, i ), ldb,work( n1*n2+1 ), n1, dscale, dif( 1_${ik}$ ),work( n1*n2*2_${ik}$+1 )& , lwork-2*n1*n2, iwork,ierr ) else ! solve the transposed variant. - call stdlib_${ci}$tgsyl( 'C', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & - ldb, b( i, i ), ldb,work( n1*n2+1 ), n1, dscale, dif( 1 ),work( n1*n2*2+1 )& + call stdlib${ii}$_${ci}$tgsyl( 'C', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & + ldb, b( i, i ), ldb,work( n1*n2+1 ), n1, dscale, dif( 1_${ik}$ ),work( n1*n2*2_${ik}$+1 )& , lwork-2*n1*n2, iwork,ierr ) end if go to 40 end if - dif( 1 ) = dscale / dif( 1 ) + dif( 1_${ik}$ ) = dscale / dif( 1_${ik}$ ) ! 1-norm-based estimate of difl. 50 continue - call stdlib_${ci}$lacn2( mn2, work( mn2+1 ), work, dif( 2 ), kase,isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_${ci}$lacn2( mn2, work( mn2+1 ), work, dif( 2_${ik}$ ), kase,isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! solve generalized sylvester equation - call stdlib_${ci}$tgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b( & - i, i ), ldb, b, ldb,work( n1*n2+1 ), n2, dscale, dif( 2 ),work( n1*n2*2+1 )& + call stdlib${ii}$_${ci}$tgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b( & + i, i ), ldb, b, ldb,work( n1*n2+1 ), n2, dscale, dif( 2_${ik}$ ),work( n1*n2*2_${ik}$+1 )& , lwork-2*n1*n2, iwork,ierr ) else ! solve the transposed variant. - call stdlib_${ci}$tgsyl( 'C', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b, & - ldb, b( i, i ), ldb,work( n1*n2+1 ), n2, dscale, dif( 2 ),work( n1*n2*2+1 )& + call stdlib${ii}$_${ci}$tgsyl( 'C', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b, & + ldb, b( i, i ), ldb,work( n1*n2+1 ), n2, dscale, dif( 2_${ik}$ ),work( n1*n2*2_${ik}$+1 )& , lwork-2*n1*n2, iwork,ierr ) end if go to 50 end if - dif( 2 ) = dscale / dif( 2 ) + dif( 2_${ik}$ ) = dscale / dif( 2_${ik}$ ) end if end if ! if b(k,k) is complex, make it real and positive (normalization @@ -71103,9 +71094,9 @@ module stdlib_linalg_lapack_${ci}$ temp1 = conjg( b( k, k ) / dscale ) temp2 = b( k, k ) / dscale b( k, k ) = dscale - call stdlib_${ci}$scal( n-k, temp1, b( k, k+1 ), ldb ) - call stdlib_${ci}$scal( n-k+1, temp1, a( k, k ), lda ) - if( wantq )call stdlib_${ci}$scal( n, temp2, q( 1, k ), 1 ) + call stdlib${ii}$_${ci}$scal( n-k, temp1, b( k, k+1 ), ldb ) + call stdlib${ii}$_${ci}$scal( n-k+1, temp1, a( k, k ), lda ) + if( wantq )call stdlib${ii}$_${ci}$scal( n, temp2, q( 1_${ik}$, k ), 1_${ik}$ ) else b( k, k ) = cmplx( zero, zero,KIND=${ck}$) end if @@ -71113,13 +71104,13 @@ module stdlib_linalg_lapack_${ci}$ beta( k ) = b( k, k ) end do 70 continue - work( 1 ) = lwmin - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = lwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_${ci}$tgsen + end subroutine stdlib${ii}$_${ci}$tgsen - pure subroutine stdlib_${ci}$tgsja( jobu, jobv, jobq, m, p, n, k, l, a, lda, b,ldb, tola, tolb, & + pure subroutine stdlib${ii}$_${ci}$tgsja( jobu, jobv, jobq, m, p, n, k, l, a, lda, b,ldb, tola, tolb, & !! ZTGSJA: computes the generalized singular value decomposition (GSVD) !! of two complex upper triangular (or trapezoidal) matrices A and B. !! On entry, it is assumed that matrices A and B have the following @@ -71188,8 +71179,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobq, jobu, jobv - integer(ilp), intent(out) :: info, ncycle - integer(ilp), intent(in) :: k, l, lda, ldb, ldq, ldu, ldv, m, n, p + integer(${ik}$), intent(out) :: info, ncycle + integer(${ik}$), intent(in) :: k, l, lda, ldb, ldq, ldu, ldv, m, n, p real(${ck}$), intent(in) :: tola, tolb ! Array Arguments real(${ck}$), intent(out) :: alpha(*), beta(*) @@ -71197,14 +71188,14 @@ module stdlib_linalg_lapack_${ci}$ complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: maxit = 40 + integer(${ik}$), parameter :: maxit = 40_${ik}$ real(${ck}$), parameter :: hugenum = huge(zero) ! Local Scalars logical(lk) :: initq, initu, initv, upper, wantq, wantu, wantv - integer(ilp) :: i, j, kcycle + integer(${ik}$) :: i, j, kcycle real(${ck}$) :: a1, a3, b1, b3, csq, csu, csv, error, gamma, rwk, ssmin complex(${ck}$) :: a2, b2, snq, snu, snv ! Intrinsic Functions @@ -71217,38 +71208,38 @@ module stdlib_linalg_lapack_${ci}$ wantv = initv .or. stdlib_lsame( jobv, 'V' ) initq = stdlib_lsame( jobq, 'I' ) wantq = initq .or. stdlib_lsame( jobq, 'Q' ) - info = 0 + info = 0_${ik}$ if( .not.( initu .or. wantu .or. stdlib_lsame( jobu, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( initv .or. wantv .or. stdlib_lsame( jobv, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( initq .or. wantq .or. stdlib_lsame( jobq, 'N' ) ) ) then - info = -3 - else if( m<0 ) then - info = -4 - else if( p<0 ) then - info = -5 - else if( n<0 ) then - info = -6 - else if( lda=-hugenum) ) then if( gamma=beta( k+i ) ) then - call stdlib_${ci}$dscal( l-i+1, one / alpha( k+i ), a( k+i, n-l+i ),lda ) + call stdlib${ii}$_${ci}$dscal( l-i+1, one / alpha( k+i ), a( k+i, n-l+i ),lda ) else - call stdlib_${ci}$dscal( l-i+1, one / beta( k+i ), b( i, n-l+i ),ldb ) - call stdlib_${ci}$copy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) + call stdlib${ii}$_${ci}$dscal( l-i+1, one / beta( k+i ), b( i, n-l+i ),ldb ) + call stdlib${ii}$_${ci}$copy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) end if else alpha( k+i ) = zero beta( k+i ) = one - call stdlib_${ci}$copy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) + call stdlib${ii}$_${ci}$copy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) end if end do ! post-assignment @@ -71365,10 +71356,10 @@ module stdlib_linalg_lapack_${ci}$ 100 continue ncycle = kcycle return - end subroutine stdlib_${ci}$tgsja + end subroutine stdlib${ii}$_${ci}$tgsja - pure subroutine stdlib_${ci}$tgsna( job, howmny, select, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, s, & + pure subroutine stdlib${ii}$_${ci}$tgsna( job, howmny, select, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, s, & !! ZTGSNA: estimates reciprocal condition numbers for specified !! eigenvalues and/or eigenvectors of a matrix pair (A, B). !! (A, B) must be in generalized Schur canonical form, that is, A and @@ -71379,26 +71370,26 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: howmny, job - integer(ilp), intent(out) :: info, m - integer(ilp), intent(in) :: lda, ldb, ldvl, ldvr, lwork, mm, n + integer(${ik}$), intent(out) :: info, m + integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, mm, n ! Array Arguments logical(lk), intent(in) :: select(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(${ck}$), intent(out) :: dif(*), s(*) complex(${ck}$), intent(in) :: a(lda,*), b(ldb,*), vl(ldvl,*), vr(ldvr,*) complex(${ck}$), intent(out) :: work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: idifjb = 3 + integer(${ik}$), parameter :: idifjb = 3_${ik}$ ! Local Scalars logical(lk) :: lquery, somcon, wantbh, wantdf, wants - integer(ilp) :: i, ierr, ifst, ilst, k, ks, lwmin, n1, n2 + integer(${ik}$) :: i, ierr, ifst, ilst, k, ks, lwmin, n1, n2 real(${ck}$) :: bignum, cond, eps, lnrm, rnrm, scale, smlnum complex(${ck}$) :: yhax, yhbx ! Local Arrays - complex(${ck}$) :: dummy(1), dummy1(1) + complex(${ck}$) :: dummy(1_${ik}$), dummy1(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,cmplx,max ! Executable Statements @@ -71407,49 +71398,49 @@ module stdlib_linalg_lapack_${ci}$ wants = stdlib_lsame( job, 'E' ) .or. wantbh wantdf = stdlib_lsame( job, 'V' ) .or. wantbh somcon = stdlib_lsame( howmny, 'S' ) - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) if( .not.wants .and. .not.wantdf ) then - info = -1 + info = -1_${ik}$ else if( .not.stdlib_lsame( howmny, 'A' ) .and. .not.somcon ) then - info = -2 - else if( n<0 ) then - info = -4 - else if( lda0 ) then + ilst = 1_${ik}$ + call stdlib${ii}$_${ci}$tgexc( .false., .false., n, work, n, work( n*n+1 ),n, dummy, 1_${ik}$, & + dummy1, 1_${ik}$, ifst, ilst, ierr ) + if( ierr>0_${ik}$ ) then ! ill-conditioned problem - swap rejected. dif( ks ) = zero else @@ -71510,22 +71501,22 @@ module stdlib_linalg_lapack_${ci}$ ! a22 * r - l * a11 = a12 ! b22 * r - l * b11 = b12, ! and compute estimate of difl[(a11,b11), (a22, b22)]. - n1 = 1 + n1 = 1_${ik}$ n2 = n - n1 - i = n*n + 1 - call stdlib_${ci}$tgsyl( 'N', idifjb, n2, n1, work( n*n1+n1+1 ),n, work, n, & + i = n*n + 1_${ik}$ + call stdlib${ii}$_${ci}$tgsyl( 'N', idifjb, n2, n1, work( n*n1+n1+1 ),n, work, n, & work( n1+1 ), n,work( n*n1+n1+i ), n, work( i ), n,work( n1+i ), n, scale, & - dif( ks ), dummy,1, iwork, ierr ) + dif( ks ), dummy,1_${ik}$, iwork, ierr ) end if end if end if end do loop_20 - work( 1 ) = lwmin + work( 1_${ik}$ ) = lwmin return - end subroutine stdlib_${ci}$tgsna + end subroutine stdlib${ii}$_${ci}$tgsna - pure subroutine stdlib_${ci}$tgsy2( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f, & + pure subroutine stdlib${ii}$_${ci}$tgsy2( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f, & !! ZTGSY2: solves the generalized Sylvester equation !! A * R - L * B = scale * C (1) !! D * R - L * E = scale * F @@ -71557,8 +71548,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: trans - integer(ilp), intent(in) :: ijob, lda, ldb, ldc, ldd, lde, ldf, m, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ijob, lda, ldb, ldc, ldd, lde, ldf, m, n + integer(${ik}$), intent(out) :: info real(${ck}$), intent(inout) :: rdscal, rdsum real(${ck}$), intent(out) :: scale ! Array Arguments @@ -71566,52 +71557,52 @@ module stdlib_linalg_lapack_${ci}$ complex(${ck}$), intent(inout) :: c(ldc,*), f(ldf,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: ldz = 2 + integer(${ik}$), parameter :: ldz = 2_${ik}$ ! Local Scalars logical(lk) :: notran - integer(ilp) :: i, ierr, j, k + integer(${ik}$) :: i, ierr, j, k real(${ck}$) :: scaloc complex(${ck}$) :: alpha ! Local Arrays - integer(ilp) :: ipiv(ldz), jpiv(ldz) + integer(${ik}$) :: ipiv(ldz), jpiv(ldz) complex(${ck}$) :: rhs(ldz), z(ldz,ldz) ! Intrinsic Functions intrinsic :: cmplx,conjg,max ! Executable Statements ! decode and test input parameters - info = 0 - ierr = 0 + info = 0_${ik}$ + ierr = 0_${ik}$ notran = stdlib_lsame( trans, 'N' ) if( .not.notran .and. .not.stdlib_lsame( trans, 'C' ) ) then - info = -1 + info = -1_${ik}$ else if( notran ) then - if( ( ijob<0 ) .or. ( ijob>2 ) ) then - info = -2 + if( ( ijob<0_${ik}$ ) .or. ( ijob>2_${ik}$ ) ) then + info = -2_${ik}$ end if end if - if( info==0 ) then - if( m<=0 ) then - info = -3 - else if( n<=0 ) then - info = -4 - else if( lda0 )info = ierr - if( ijob==0 ) then - call stdlib_${ci}$gesc2( ldz, z, ldz, rhs, ipiv, jpiv, scaloc ) + call stdlib${ii}$_${ci}$getc2( ldz, z, ldz, ipiv, jpiv, ierr ) + if( ierr>0_${ik}$ )info = ierr + if( ijob==0_${ik}$ ) then + call stdlib${ii}$_${ci}$gesc2( ldz, z, ldz, rhs, ipiv, jpiv, scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$),c( 1, k ), 1 ) + call stdlib${ii}$_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$),c( 1_${ik}$, k ), 1_${ik}$ ) - call stdlib_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$),f( 1, k ), 1 ) + call stdlib${ii}$_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$),f( 1_${ik}$, k ), 1_${ik}$ ) end do scale = scale*scaloc end if else - call stdlib_${ci}$latdf( ijob, ldz, z, ldz, rhs, rdsum, rdscal,ipiv, jpiv ) + call stdlib${ii}$_${ci}$latdf( ijob, ldz, z, ldz, rhs, rdsum, rdscal,ipiv, jpiv ) end if ! unpack solution vector(s) - c( i, j ) = rhs( 1 ) - f( i, j ) = rhs( 2 ) + c( i, j ) = rhs( 1_${ik}$ ) + f( i, j ) = rhs( 2_${ik}$ ) ! substitute r(i, j) and l(i, j) into remaining equation. - if( i>1 ) then - alpha = -rhs( 1 ) - call stdlib_${ci}$axpy( i-1, alpha, a( 1, i ), 1, c( 1, j ), 1 ) - call stdlib_${ci}$axpy( i-1, alpha, d( 1, i ), 1, f( 1, j ), 1 ) + if( i>1_${ik}$ ) then + alpha = -rhs( 1_${ik}$ ) + call stdlib${ii}$_${ci}$axpy( i-1, alpha, a( 1_${ik}$, i ), 1_${ik}$, c( 1_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_${ci}$axpy( i-1, alpha, d( 1_${ik}$, i ), 1_${ik}$, f( 1_${ik}$, j ), 1_${ik}$ ) end if if( j0 )info = ierr - call stdlib_${ci}$gesc2( ldz, z, ldz, rhs, ipiv, jpiv, scaloc ) + call stdlib${ii}$_${ci}$getc2( ldz, z, ldz, ipiv, jpiv, ierr ) + if( ierr>0_${ik}$ )info = ierr + call stdlib${ii}$_${ci}$gesc2( ldz, z, ldz, rhs, ipiv, jpiv, scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$), c( 1, k ),1 ) + call stdlib${ii}$_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$), c( 1_${ik}$, k ),1_${ik}$ ) - call stdlib_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$), f( 1, k ),1 ) + call stdlib${ii}$_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$), f( 1_${ik}$, k ),1_${ik}$ ) end do scale = scale*scaloc end if ! unpack solution vector(s) - c( i, j ) = rhs( 1 ) - f( i, j ) = rhs( 2 ) + c( i, j ) = rhs( 1_${ik}$ ) + f( i, j ) = rhs( 2_${ik}$ ) ! substitute r(i, j) and l(i, j) into remaining equation. do k = 1, j - 1 - f( i, k ) = f( i, k ) + rhs( 1 )*conjg( b( k, j ) ) +rhs( 2 )*conjg( e( k, & + f( i, k ) = f( i, k ) + rhs( 1_${ik}$ )*conjg( b( k, j ) ) +rhs( 2_${ik}$ )*conjg( e( k, & j ) ) end do do k = i + 1, m - c( k, j ) = c( k, j ) - conjg( a( i, k ) )*rhs( 1 ) -conjg( d( i, k ) )& - *rhs( 2 ) + c( k, j ) = c( k, j ) - conjg( a( i, k ) )*rhs( 1_${ik}$ ) -conjg( d( i, k ) )& + *rhs( 2_${ik}$ ) end do end do loop_70 end do loop_80 end if return - end subroutine stdlib_${ci}$tgsy2 + end subroutine stdlib${ii}$_${ci}$tgsy2 - pure subroutine stdlib_${ci}$tgsyl( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f, & + pure subroutine stdlib${ii}$_${ci}$tgsyl( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f, & !! ZTGSYL: solves the generalized Sylvester equation: !! A * R - L * B = scale * C (1) !! D * R - L * E = scale * F @@ -71749,249 +71740,249 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: trans - integer(ilp), intent(in) :: ijob, lda, ldb, ldc, ldd, lde, ldf, lwork, m, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ijob, lda, ldb, ldc, ldd, lde, ldf, lwork, m, n + integer(${ik}$), intent(out) :: info real(${ck}$), intent(out) :: dif, scale ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) complex(${ck}$), intent(in) :: a(lda,*), b(ldb,*), d(ldd,*), e(lde,*) complex(${ck}$), intent(inout) :: c(ldc,*), f(ldf,*) complex(${ck}$), intent(out) :: work(*) ! ===================================================================== - ! replaced various illegal calls to stdlib_zcopy by calls to stdlib_zlaset. + ! replaced various illegal calls to stdlib${ii}$_zcopy by calls to stdlib${ii}$_zlaset. ! sven hammarling, 1/5/02. ! Local Scalars logical(lk) :: lquery, notran - integer(ilp) :: i, ie, ifunc, iround, is, isolve, j, je, js, k, linfo, lwmin, mb, nb, & + integer(${ik}$) :: i, ie, ifunc, iround, is, isolve, j, je, js, k, linfo, lwmin, mb, nb, & p, pq, q real(${ck}$) :: dscale, dsum, scale2, scaloc ! Intrinsic Functions intrinsic :: real,cmplx,max,sqrt ! Executable Statements ! decode and test input parameters - info = 0 + info = 0_${ik}$ notran = stdlib_lsame( trans, 'N' ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) if( .not.notran .and. .not.stdlib_lsame( trans, 'C' ) ) then - info = -1 + info = -1_${ik}$ else if( notran ) then - if( ( ijob<0 ) .or. ( ijob>4 ) ) then - info = -2 - end if - end if - if( info==0 ) then - if( m<=0 ) then - info = -3 - else if( n<=0 ) then - info = -4 - else if( lda4_${ik}$ ) ) then + info = -2_${ik}$ + end if + end if + if( info==0_${ik}$ ) then + if( m<=0_${ik}$ ) then + info = -3_${ik}$ + else if( n<=0_${ik}$ ) then + info = -4_${ik}$ + else if( lda=3 ) then - ifunc = ijob - 2 - call stdlib_${ci}$laset( 'F', m, n, czero, czero, c, ldc ) - call stdlib_${ci}$laset( 'F', m, n, czero, czero, f, ldf ) - else if( ijob>=1 .and. notran ) then - isolve = 2 + if( ijob>=3_${ik}$ ) then + ifunc = ijob - 2_${ik}$ + call stdlib${ii}$_${ci}$laset( 'F', m, n, czero, czero, c, ldc ) + call stdlib${ii}$_${ci}$laset( 'F', m, n, czero, czero, f, ldf ) + else if( ijob>=1_${ik}$ .and. notran ) then + isolve = 2_${ik}$ end if end if - if( ( mb<=1 .and. nb<=1 ) .or. ( mb>=m .and. nb>=n ) )then + if( ( mb<=1_${ik}$ .and. nb<=1_${ik}$ ) .or. ( mb>=m .and. nb>=n ) )then ! use unblocked level 2 solver loop_30: do iround = 1, isolve scale = one dscale = zero dsum = one pq = m*n - call stdlib_${ci}$tgsy2( trans, ifunc, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f,& + call stdlib${ii}$_${ci}$tgsy2( trans, ifunc, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f,& ldf, scale, dsum, dscale,info ) if( dscale/=zero ) then - if( ijob==1 .or. ijob==3 ) then - dif = sqrt( real( 2*m*n,KIND=${ck}$) ) / ( dscale*sqrt( dsum ) ) + if( ijob==1_${ik}$ .or. ijob==3_${ik}$ ) then + dif = sqrt( real( 2_${ik}$*m*n,KIND=${ck}$) ) / ( dscale*sqrt( dsum ) ) else dif = sqrt( real( pq,KIND=${ck}$) ) / ( dscale*sqrt( dsum ) ) end if end if - if( isolve==2 .and. iround==1 ) then + if( isolve==2_${ik}$ .and. iround==1_${ik}$ ) then if( notran ) then ifunc = ijob end if scale2 = scale - call stdlib_${ci}$lacpy( 'F', m, n, c, ldc, work, m ) - call stdlib_${ci}$lacpy( 'F', m, n, f, ldf, work( m*n+1 ), m ) - call stdlib_${ci}$laset( 'F', m, n, czero, czero, c, ldc ) - call stdlib_${ci}$laset( 'F', m, n, czero, czero, f, ldf ) - else if( isolve==2 .and. iround==2 ) then - call stdlib_${ci}$lacpy( 'F', m, n, work, m, c, ldc ) - call stdlib_${ci}$lacpy( 'F', m, n, work( m*n+1 ), m, f, ldf ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, n, c, ldc, work, m ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, n, f, ldf, work( m*n+1 ), m ) + call stdlib${ii}$_${ci}$laset( 'F', m, n, czero, czero, c, ldc ) + call stdlib${ii}$_${ci}$laset( 'F', m, n, czero, czero, f, ldf ) + else if( isolve==2_${ik}$ .and. iround==2_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'F', m, n, work, m, c, ldc ) + call stdlib${ii}$_${ci}$lacpy( 'F', m, n, work( m*n+1 ), m, f, ldf ) scale = scale2 end if end do loop_30 return end if ! determine block structure of a - p = 0 - i = 1 + p = 0_${ik}$ + i = 1_${ik}$ 40 continue if( i>m )go to 50 - p = p + 1 + p = p + 1_${ik}$ iwork( p ) = i i = i + mb if( i>=m )go to 50 go to 40 50 continue - iwork( p+1 ) = m + 1 - if( iwork( p )==iwork( p+1 ) )p = p - 1 + iwork( p+1 ) = m + 1_${ik}$ + if( iwork( p )==iwork( p+1 ) )p = p - 1_${ik}$ ! determine block structure of b - q = p + 1 - j = 1 + q = p + 1_${ik}$ + j = 1_${ik}$ 60 continue if( j>n )go to 70 - q = q + 1 + q = q + 1_${ik}$ iwork( q ) = j j = j + nb if( j>=n )go to 70 go to 60 70 continue - iwork( q+1 ) = n + 1 - if( iwork( q )==iwork( q+1 ) )q = q - 1 + iwork( q+1 ) = n + 1_${ik}$ + if( iwork( q )==iwork( q+1 ) )q = q - 1_${ik}$ if( notran ) then loop_150: do iround = 1, isolve ! solve (i, j) - subsystem ! a(i, i) * r(i, j) - l(i, j) * b(j, j) = c(i, j) ! d(i, i) * r(i, j) - l(i, j) * e(j, j) = f(i, j) ! for i = p, p - 1, ..., 1; j = 1, 2, ..., q - pq = 0 + pq = 0_${ik}$ scale = one dscale = zero dsum = one loop_130: do j = p + 2, q js = iwork( j ) - je = iwork( j+1 ) - 1 - nb = je - js + 1 + je = iwork( j+1 ) - 1_${ik}$ + nb = je - js + 1_${ik}$ loop_120: do i = p, 1, -1 is = iwork( i ) - ie = iwork( i+1 ) - 1 - mb = ie - is + 1 - call stdlib_${ci}$tgsy2( trans, ifunc, mb, nb, a( is, is ), lda,b( js, js ), & + ie = iwork( i+1 ) - 1_${ik}$ + mb = ie - is + 1_${ik}$ + call stdlib${ii}$_${ci}$tgsy2( trans, ifunc, mb, nb, a( is, is ), lda,b( js, js ), & ldb, c( is, js ), ldc,d( is, is ), ldd, e( js, js ), lde,f( is, js ), ldf, & scaloc, dsum, dscale,linfo ) - if( linfo>0 )info = linfo + if( linfo>0_${ik}$ )info = linfo pq = pq + mb*nb if( scaloc/=one ) then do k = 1, js - 1 - call stdlib_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$),c( 1, k ), 1 ) + call stdlib${ii}$_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$),c( 1_${ik}$, k ), 1_${ik}$ ) - call stdlib_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$),f( 1, k ), 1 ) + call stdlib${ii}$_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$),f( 1_${ik}$, k ), 1_${ik}$ ) end do do k = js, je - call stdlib_${ci}$scal( is-1, cmplx( scaloc, zero,KIND=${ck}$),c( 1, k ), 1 ) + call stdlib${ii}$_${ci}$scal( is-1, cmplx( scaloc, zero,KIND=${ck}$),c( 1_${ik}$, k ), 1_${ik}$ ) - call stdlib_${ci}$scal( is-1, cmplx( scaloc, zero,KIND=${ck}$),f( 1, k ), 1 ) + call stdlib${ii}$_${ci}$scal( is-1, cmplx( scaloc, zero,KIND=${ck}$),f( 1_${ik}$, k ), 1_${ik}$ ) end do do k = js, je - call stdlib_${ci}$scal( m-ie, cmplx( scaloc, zero,KIND=${ck}$),c( ie+1, k ), & - 1 ) - call stdlib_${ci}$scal( m-ie, cmplx( scaloc, zero,KIND=${ck}$),f( ie+1, k ), & - 1 ) + call stdlib${ii}$_${ci}$scal( m-ie, cmplx( scaloc, zero,KIND=${ck}$),c( ie+1, k ), & + 1_${ik}$ ) + call stdlib${ii}$_${ci}$scal( m-ie, cmplx( scaloc, zero,KIND=${ck}$),f( ie+1, k ), & + 1_${ik}$ ) end do do k = je + 1, n - call stdlib_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$),c( 1, k ), 1 ) + call stdlib${ii}$_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$),c( 1_${ik}$, k ), 1_${ik}$ ) - call stdlib_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$),f( 1, k ), 1 ) + call stdlib${ii}$_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$),f( 1_${ik}$, k ), 1_${ik}$ ) end do scale = scale*scaloc end if ! substitute r(i,j) and l(i,j) into remaining equation. - if( i>1 ) then - call stdlib_${ci}$gemm( 'N', 'N', is-1, nb, mb,cmplx( -one, zero,KIND=${ck}$), a(& - 1, is ), lda,c( is, js ), ldc, cmplx( one, zero,KIND=${ck}$),c( 1, js ), & + if( i>1_${ik}$ ) then + call stdlib${ii}$_${ci}$gemm( 'N', 'N', is-1, nb, mb,cmplx( -one, zero,KIND=${ck}$), a(& + 1_${ik}$, is ), lda,c( is, js ), ldc, cmplx( one, zero,KIND=${ck}$),c( 1_${ik}$, js ), & ldc ) - call stdlib_${ci}$gemm( 'N', 'N', is-1, nb, mb,cmplx( -one, zero,KIND=${ck}$), d(& - 1, is ), ldd,c( is, js ), ldc, cmplx( one, zero,KIND=${ck}$),f( 1, js ), & + call stdlib${ii}$_${ci}$gemm( 'N', 'N', is-1, nb, mb,cmplx( -one, zero,KIND=${ck}$), d(& + 1_${ik}$, is ), ldd,c( is, js ), ldc, cmplx( one, zero,KIND=${ck}$),f( 1_${ik}$, js ), & ldf ) end if if( j0 )info = linfo + if( linfo>0_${ik}$ )info = linfo if( scaloc/=one ) then do k = 1, js - 1 - call stdlib_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$), c( 1, k ),1 ) + call stdlib${ii}$_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$), c( 1_${ik}$, k ),1_${ik}$ ) - call stdlib_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$), f( 1, k ),1 ) + call stdlib${ii}$_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$), f( 1_${ik}$, k ),1_${ik}$ ) end do do k = js, je - call stdlib_${ci}$scal( is-1, cmplx( scaloc, zero,KIND=${ck}$),c( 1, k ), 1 ) + call stdlib${ii}$_${ci}$scal( is-1, cmplx( scaloc, zero,KIND=${ck}$),c( 1_${ik}$, k ), 1_${ik}$ ) - call stdlib_${ci}$scal( is-1, cmplx( scaloc, zero,KIND=${ck}$),f( 1, k ), 1 ) + call stdlib${ii}$_${ci}$scal( is-1, cmplx( scaloc, zero,KIND=${ck}$),f( 1_${ik}$, k ), 1_${ik}$ ) end do do k = js, je - call stdlib_${ci}$scal( m-ie, cmplx( scaloc, zero,KIND=${ck}$),c( ie+1, k ), 1 ) + call stdlib${ii}$_${ci}$scal( m-ie, cmplx( scaloc, zero,KIND=${ck}$),c( ie+1, k ), 1_${ik}$ ) - call stdlib_${ci}$scal( m-ie, cmplx( scaloc, zero,KIND=${ck}$),f( ie+1, k ), 1 ) + call stdlib${ii}$_${ci}$scal( m-ie, cmplx( scaloc, zero,KIND=${ck}$),f( ie+1, k ), 1_${ik}$ ) end do do k = je + 1, n - call stdlib_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$), c( 1, k ),1 ) + call stdlib${ii}$_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$), c( 1_${ik}$, k ),1_${ik}$ ) - call stdlib_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$), f( 1, k ),1 ) + call stdlib${ii}$_${ci}$scal( m, cmplx( scaloc, zero,KIND=${ck}$), f( 1_${ik}$, k ),1_${ik}$ ) end do scale = scale*scaloc end if ! substitute r(i,j) and l(i,j) into remaining equation. if( j>p+2 ) then - call stdlib_${ci}$gemm( 'N', 'C', mb, js-1, nb,cmplx( one, zero,KIND=${ck}$), c( is,& - js ), ldc,b( 1, js ), ldb, cmplx( one, zero,KIND=${ck}$),f( is, 1 ), ldf ) + call stdlib${ii}$_${ci}$gemm( 'N', 'C', mb, js-1, nb,cmplx( one, zero,KIND=${ck}$), c( is,& + js ), ldc,b( 1_${ik}$, js ), ldb, cmplx( one, zero,KIND=${ck}$),f( is, 1_${ik}$ ), ldf ) - call stdlib_${ci}$gemm( 'N', 'C', mb, js-1, nb,cmplx( one, zero,KIND=${ck}$), f( is,& - js ), ldf,e( 1, js ), lde, cmplx( one, zero,KIND=${ck}$),f( is, 1 ), ldf ) + call stdlib${ii}$_${ci}$gemm( 'N', 'C', mb, js-1, nb,cmplx( one, zero,KIND=${ck}$), f( is,& + js ), ldf,e( 1_${ik}$, js ), lde, cmplx( one, zero,KIND=${ck}$),f( is, 1_${ik}$ ), ldf ) end if if( i

0. if( anorm>zero ) then ! estimate the norm of the inverse of a. ainvnm = zero normin = 'N' if( onenrm ) then - kase1 = 1 + kase1 = 1_${ik}$ else - kase1 = 2 + kase1 = 2_${ik}$ end if - kase = 0 + kase = 0_${ik}$ 10 continue - call stdlib_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + if( kase/=0_${ik}$ ) then if( kase==kase1 ) then ! multiply by inv(a). - call stdlib_${ci}$latps( uplo, 'NO TRANSPOSE', diag, normin, n, ap,work, scale, & + call stdlib${ii}$_${ci}$latps( uplo, 'NO TRANSPOSE', diag, normin, n, ap,work, scale, & rwork, info ) else ! multiply by inv(a**h). - call stdlib_${ci}$latps( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, ap, work, & + call stdlib${ii}$_${ci}$latps( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, ap, work, & scale, rwork, info ) end if normin = 'Y' ! multiply by 1/scale if doing so will not cause overflow. if( scale/=one ) then - ix = stdlib_i${ci}$amax( n, work, 1 ) + ix = stdlib${ii}$_i${ci}$amax( n, work, 1_${ik}$ ) xnorm = cabs1( work( ix ) ) if( scalemin(m,n) .and. min(m,n)>=0)) then - info = -3 - else if( mb<1 .or. (mb>m .and. m>0)) then - info = -4 - else if( ldamin(m,n) .and. min(m,n)>=0_${ik}$)) then + info = -3_${ik}$ + else if( mb<1_${ik}$ .or. (mb>m .and. m>0_${ik}$)) then + info = -4_${ik}$ + else if( lda=l ) then - lb = 0 + lb = 0_${ik}$ else lb = nb-n+l-i+1 end if - call stdlib_${ci}$tplqt2( ib, nb, lb, a(i,i), lda, b( i, 1 ), ldb,t(1, i ), ldt, iinfo ) + call stdlib${ii}$_${ci}$tplqt2( ib, nb, lb, a(i,i), lda, b( i, 1_${ik}$ ), ldb,t(1_${ik}$, i ), ldt, iinfo ) ! update by applying h**t to b(i+ib:m,:) from the right if( i+ib<=m ) then - call stdlib_${ci}$tprfb( 'R', 'N', 'F', 'R', m-i-ib+1, nb, ib, lb,b( i, 1 ), ldb, t( & - 1, i ), ldt,a( i+ib, i ), lda, b( i+ib, 1 ), ldb,work, m-i-ib+1) + call stdlib${ii}$_${ci}$tprfb( 'R', 'N', 'F', 'R', m-i-ib+1, nb, ib, lb,b( i, 1_${ik}$ ), ldb, t( & + 1_${ik}$, i ), ldt,a( i+ib, i ), lda, b( i+ib, 1_${ik}$ ), ldb,work, m-i-ib+1) end if end do return - end subroutine stdlib_${ci}$tplqt + end subroutine stdlib${ii}$_${ci}$tplqt - pure subroutine stdlib_${ci}$tplqt2( m, n, l, a, lda, b, ldb, t, ldt, info ) + pure subroutine stdlib${ii}$_${ci}$tplqt2( m, n, l, a, lda, b, ldb, t, ldt, info ) !! ZTPLQT2: computes a LQ a factorization of a complex "triangular-pentagonal" !! matrix C, which is composed of a triangular block A and pentagonal block B, !! using the compact WY representation for Q. @@ -72239,36 +72230,36 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, ldb, ldt, n, m, l + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) complex(${ck}$), intent(out) :: t(ldt,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, p, mp, np + integer(${ik}$) :: i, j, p, mp, np complex(${ck}$) :: alpha ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( l<0 .or. l>min(m,n) ) then - info = -3 - else if( ldamin(m,n) ) then + info = -3_${ik}$ + else if( ldak ) then - info = -6 - else if( mb<1 .or. (mb>k .and. k>0) ) then - info = -7 + info = -2_${ik}$ + else if( m<0_${ik}$ ) then + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( k<0_${ik}$ ) then + info = -5_${ik}$ + else if( l<0_${ik}$ .or. l>k ) then + info = -6_${ik}$ + else if( mb<1_${ik}$ .or. (mb>k .and. k>0_${ik}$) ) then + info = -7_${ik}$ else if( ldv=l ) then - lb = 0 + lb = 0_${ik}$ else - lb = 0 + lb = 0_${ik}$ end if - call stdlib_${ci}$tprfb( 'L', 'C', 'F', 'R', nb, n, ib, lb,v( i, 1 ), ldv, t( 1, i ), & - ldt,a( i, 1 ), lda, b, ldb, work, ib ) + call stdlib${ii}$_${ci}$tprfb( 'L', 'C', 'F', 'R', nb, n, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), & + ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib ) end do else if( right .and. tran ) then do i = 1, k, mb ib = min( mb, k-i+1 ) nb = min( n-l+i+ib-1, n ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = nb-n+l-i+1 end if - call stdlib_${ci}$tprfb( 'R', 'N', 'F', 'R', m, nb, ib, lb,v( i, 1 ), ldv, t( 1, i ), & - ldt,a( 1, i ), lda, b, ldb, work, m ) + call stdlib${ii}$_${ci}$tprfb( 'R', 'N', 'F', 'R', m, nb, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), & + ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m ) end do else if( left .and. tran ) then kf = ((k-1)/mb)*mb+1 @@ -72440,12 +72431,12 @@ module stdlib_linalg_lapack_${ci}$ ib = min( mb, k-i+1 ) nb = min( m-l+i+ib-1, m ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else - lb = 0 + lb = 0_${ik}$ end if - call stdlib_${ci}$tprfb( 'L', 'N', 'F', 'R', nb, n, ib, lb,v( i, 1 ), ldv, t( 1, i ), & - ldt,a( i, 1 ), lda, b, ldb, work, ib ) + call stdlib${ii}$_${ci}$tprfb( 'L', 'N', 'F', 'R', nb, n, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), & + ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib ) end do else if( right .and. notran ) then kf = ((k-1)/mb)*mb+1 @@ -72453,19 +72444,19 @@ module stdlib_linalg_lapack_${ci}$ ib = min( mb, k-i+1 ) nb = min( n-l+i+ib-1, n ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = nb-n+l-i+1 end if - call stdlib_${ci}$tprfb( 'R', 'C', 'F', 'R', m, nb, ib, lb,v( i, 1 ), ldv, t( 1, i ), & - ldt,a( 1, i ), lda, b, ldb, work, m ) + call stdlib${ii}$_${ci}$tprfb( 'R', 'C', 'F', 'R', m, nb, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), & + ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m ) end do end if return - end subroutine stdlib_${ci}$tpmlqt + end subroutine stdlib${ii}$_${ci}$tpmlqt - pure subroutine stdlib_${ci}$tpmqrt( side, trans, m, n, k, l, nb, v, ldv, t, ldt,a, lda, b, ldb, & + pure subroutine stdlib${ii}$_${ci}$tpmqrt( side, trans, m, n, k, l, nb, v, ldv, t, ldt,a, lda, b, ldb, & !! ZTPMQRT: applies a complex orthogonal matrix Q obtained from a !! "triangular-pentagonal" complex block reflector H to a general !! complex matrix C, which consists of two blocks A and B. @@ -72475,8 +72466,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, lda, ldb, m, n, l, nb, ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k, ldv, lda, ldb, m, n, l, nb, ldt ! Array Arguments complex(${ck}$), intent(in) :: v(ldv,*), t(ldt,*) complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) @@ -72484,48 +72475,48 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran - integer(ilp) :: i, ib, mb, lb, kf, ldaq, ldvq + integer(${ik}$) :: i, ib, mb, lb, kf, ldaq, ldvq ! 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, 'C' ) notran = stdlib_lsame( trans, 'N' ) if ( left ) then - ldvq = max( 1, m ) - ldaq = max( 1, k ) + ldvq = max( 1_${ik}$, m ) + ldaq = max( 1_${ik}$, k ) else if ( right ) then - ldvq = max( 1, n ) - ldaq = max( 1, m ) + ldvq = max( 1_${ik}$, n ) + ldaq = max( 1_${ik}$, m ) 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 ) then - info = -5 - else if( l<0 .or. l>k ) then - info = -6 - else if( nb<1 .or. (nb>k .and. k>0) ) then - info = -7 + info = -2_${ik}$ + else if( m<0_${ik}$ ) then + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( k<0_${ik}$ ) then + info = -5_${ik}$ + else if( l<0_${ik}$ .or. l>k ) then + info = -6_${ik}$ + else if( nb<1_${ik}$ .or. (nb>k .and. k>0_${ik}$) ) then + info = -7_${ik}$ else if( ldv=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-m+l-i+1 end if - call stdlib_${ci}$tprfb( 'L', 'C', 'F', 'C', mb, n, ib, lb,v( 1, i ), ldv, t( 1, i ), & - ldt,a( i, 1 ), lda, b, ldb, work, ib ) + call stdlib${ii}$_${ci}$tprfb( 'L', 'C', 'F', 'C', mb, n, ib, lb,v( 1_${ik}$, i ), ldv, t( 1_${ik}$, i ), & + ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib ) end do else if( right .and. notran ) then do i = 1, k, nb ib = min( nb, k-i+1 ) mb = min( n-l+i+ib-1, n ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-n+l-i+1 end if - call stdlib_${ci}$tprfb( 'R', 'N', 'F', 'C', m, mb, ib, lb,v( 1, i ), ldv, t( 1, i ), & - ldt,a( 1, i ), lda, b, ldb, work, m ) + call stdlib${ii}$_${ci}$tprfb( 'R', 'N', 'F', 'C', m, mb, ib, lb,v( 1_${ik}$, i ), ldv, t( 1_${ik}$, i ), & + ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m ) end do else if( left .and. notran ) then kf = ((k-1)/nb)*nb+1 @@ -72560,12 +72551,12 @@ module stdlib_linalg_lapack_${ci}$ ib = min( nb, k-i+1 ) mb = min( m-l+i+ib-1, m ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-m+l-i+1 end if - call stdlib_${ci}$tprfb( 'L', 'N', 'F', 'C', mb, n, ib, lb,v( 1, i ), ldv, t( 1, i ), & - ldt,a( i, 1 ), lda, b, ldb, work, ib ) + call stdlib${ii}$_${ci}$tprfb( 'L', 'N', 'F', 'C', mb, n, ib, lb,v( 1_${ik}$, i ), ldv, t( 1_${ik}$, i ), & + ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib ) end do else if( right .and. tran ) then kf = ((k-1)/nb)*nb+1 @@ -72573,19 +72564,19 @@ module stdlib_linalg_lapack_${ci}$ ib = min( nb, k-i+1 ) mb = min( n-l+i+ib-1, n ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-n+l-i+1 end if - call stdlib_${ci}$tprfb( 'R', 'C', 'F', 'C', m, mb, ib, lb,v( 1, i ), ldv, t( 1, i ), & - ldt,a( 1, i ), lda, b, ldb, work, m ) + call stdlib${ii}$_${ci}$tprfb( 'R', 'C', 'F', 'C', m, mb, ib, lb,v( 1_${ik}$, i ), ldv, t( 1_${ik}$, i ), & + ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m ) end do end if return - end subroutine stdlib_${ci}$tpmqrt + end subroutine stdlib${ii}$_${ci}$tpmqrt - pure subroutine stdlib_${ci}$tpqrt( m, n, l, nb, a, lda, b, ldb, t, ldt, work,info ) + pure subroutine stdlib${ii}$_${ci}$tpqrt( m, n, l, nb, a, lda, b, ldb, t, ldt, work,info ) !! ZTPQRT: computes a blocked QR factorization of a complex !! "triangular-pentagonal" matrix C, which is composed of a !! triangular block A and pentagonal block B, using the compact @@ -72594,34 +72585,34 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, ldb, ldt, n, m, l, nb + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l, nb ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) complex(${ck}$), intent(out) :: t(ldt,*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ib, lb, mb, iinfo + integer(${ik}$) :: i, ib, lb, mb, iinfo ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( l<0 .or. (l>min(m,n) .and. min(m,n)>=0)) then - info = -3 - else if( nb<1 .or. (nb>n .and. n>0)) then - info = -4 - else if( ldamin(m,n) .and. min(m,n)>=0_${ik}$)) then + info = -3_${ik}$ + else if( nb<1_${ik}$ .or. (nb>n .and. n>0_${ik}$)) then + info = -4_${ik}$ + else if( lda=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-m+l-i+1 end if - call stdlib_${ci}$tpqrt2( mb, ib, lb, a(i,i), lda, b( 1, i ), ldb,t(1, i ), ldt, iinfo ) + call stdlib${ii}$_${ci}$tpqrt2( mb, ib, lb, a(i,i), lda, b( 1_${ik}$, i ), ldb,t(1_${ik}$, i ), ldt, iinfo ) ! update by applying h**h to b(:,i+ib:n) from the left if( i+ib<=n ) then - call stdlib_${ci}$tprfb( 'L', 'C', 'F', 'C', mb, n-i-ib+1, ib, lb,b( 1, i ), ldb, t( & - 1, i ), ldt,a( i, i+ib ), lda, b( 1, i+ib ), ldb,work, ib ) + call stdlib${ii}$_${ci}$tprfb( 'L', 'C', 'F', 'C', mb, n-i-ib+1, ib, lb,b( 1_${ik}$, i ), ldb, t( & + 1_${ik}$, i ), ldt,a( i, i+ib ), lda, b( 1_${ik}$, i+ib ), ldb,work, ib ) end if end do return - end subroutine stdlib_${ci}$tpqrt + end subroutine stdlib${ii}$_${ci}$tpqrt - pure subroutine stdlib_${ci}$tpqrt2( m, n, l, a, lda, b, ldb, t, ldt, info ) + pure subroutine stdlib${ii}$_${ci}$tpqrt2( m, n, l, a, lda, b, ldb, t, ldt, info ) !! ZTPQRT2: computes a QR factorization of a complex "triangular-pentagonal" !! matrix C, which is composed of a triangular block A and pentagonal block B, !! using the compact WY representation for Q. @@ -72655,36 +72646,36 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, ldb, ldt, n, m, l + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*), b(ldb,*) complex(${ck}$), intent(out) :: t(ldt,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, p, mp, np + integer(${ik}$) :: i, j, p, mp, np complex(${ck}$) :: alpha ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( l<0 .or. l>min(m,n) ) then - info = -3 - else if( ldamin(m,n) ) then + info = -3_${ik}$ + else if( lda 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 + ijp = 0_${ik}$ + jp = 0_${ik}$ do j = 0, n2 do i = j, n - 1 ij = i + jp arf( ij ) = ap( ijp ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do jp = jp + lda end do @@ -73667,28 +73658,28 @@ module stdlib_linalg_lapack_${ci}$ do j = 1 + i, n2 ij = i + j*lda arf( ij ) = conjg( ap( ijp ) ) - 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 + ijp = 0_${ik}$ do j = 0, n1 - 1 ij = n2 + j do i = 0, j arf( ij ) = conjg( ap( ijp ) ) - 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 arf( ij ) = ap( ijp ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do js = js + lda end do @@ -73699,38 +73690,38 @@ module stdlib_linalg_lapack_${ci}$ ! 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 + ijp = 0_${ik}$ do i = 0, n2 do ij = i*( lda+1 ), n*lda - 1, lda arf( ij ) = conjg( ap( ijp ) ) - 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 arf( ij ) = ap( ijp ) - 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 + ijp = 0_${ik}$ js = n2*lda do j = 0, n1 - 1 do ij = js, js + j arf( ij ) = ap( ijp ) - 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 arf( ij ) = conjg( ap( ijp ) ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do end do end if @@ -73743,13 +73734,13 @@ module stdlib_linalg_lapack_${ci}$ ! 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 + 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 arf( ij ) = ap( ijp ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do jp = jp + lda end do @@ -73757,28 +73748,28 @@ module stdlib_linalg_lapack_${ci}$ do j = i, k - 1 ij = i + j*lda arf( ij ) = conjg( ap( ijp ) ) - 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 + ijp = 0_${ik}$ do j = 0, k - 1 - ij = k + 1 + j + ij = k + 1_${ik}$ + j do i = 0, j arf( ij ) = conjg( ap( ijp ) ) - 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 arf( ij ) = ap( ijp ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do js = js + lda end do @@ -73789,48 +73780,48 @@ module stdlib_linalg_lapack_${ci}$ ! 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 + ijp = 0_${ik}$ do i = 0, k - 1 do ij = i + ( i+1 )*lda, ( n+1 )*lda - 1, lda arf( ij ) = conjg( ap( ijp ) ) - 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 arf( ij ) = ap( ijp ) - 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 + ijp = 0_${ik}$ js = ( k+1 )*lda do j = 0, k - 1 do ij = js, js + j arf( ij ) = ap( ijp ) - 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 arf( ij ) = conjg( ap( ijp ) ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do end do end if end if end if return - end subroutine stdlib_${ci}$tpttf + end subroutine stdlib${ii}$_${ci}$tpttf - pure subroutine stdlib_${ci}$tpttr( uplo, n, ap, a, lda, info ) + pure subroutine stdlib${ii}$_${ci}$tpttr( uplo, n, ap, a, lda, info ) !! ZTPTTR: copies a triangular matrix A from standard packed format (TP) !! to standard full format (TR). ! -- lapack computational routine -- @@ -73838,8 +73829,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: n, lda + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n, lda ! Array Arguments complex(${ck}$), intent(out) :: a(lda,*) complex(${ck}$), intent(in) :: ap(*) @@ -73847,44 +73838,44 @@ module stdlib_linalg_lapack_${ci}$ ! Parameters ! Local Scalars logical(lk) :: lower - integer(ilp) :: i, j, k + integer(${ik}$) :: i, j, k ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ lower = stdlib_lsame( uplo, 'L' ) if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda 0. if( anorm>zero ) then ! estimate the norm of the inverse of a. ainvnm = zero normin = 'N' if( onenrm ) then - kase1 = 1 + kase1 = 1_${ik}$ else - kase1 = 2 + kase1 = 2_${ik}$ end if - kase = 0 + kase = 0_${ik}$ 10 continue - call stdlib_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_${ci}$lacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + if( kase/=0_${ik}$ ) then if( kase==kase1 ) then ! multiply by inv(a). - call stdlib_${ci}$latrs( uplo, 'NO TRANSPOSE', diag, normin, n, a,lda, work, scale,& + call stdlib${ii}$_${ci}$latrs( uplo, 'NO TRANSPOSE', diag, normin, n, a,lda, work, scale,& rwork, info ) else ! multiply by inv(a**h). - call stdlib_${ci}$latrs( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, a, lda, work,& + call stdlib${ii}$_${ci}$latrs( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, a, lda, work,& scale, rwork, info ) end if normin = 'Y' ! multiply by 1/scale if doing so will not cause overflow. if( scale/=one ) then - ix = stdlib_i${ci}$amax( n, work, 1 ) + ix = stdlib${ii}$_i${ci}$amax( n, work, 1_${ik}$ ) xnorm = cabs1( work( ix ) ) if( scale1 ) then - call stdlib_${ci}$latrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', 'Y',ki-1, t, ldt, & - work( 1 ), scale, rwork,info ) + if( ki>1_${ik}$ ) then + call stdlib${ii}$_${ci}$latrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', 'Y',ki-1, t, ldt, & + work( 1_${ik}$ ), scale, rwork,info ) work( ki ) = scale end if ! copy the vector x or q*x to vr and normalize. if( .not.over ) then - call stdlib_${ci}$copy( ki, work( 1 ), 1, vr( 1, is ), 1 ) - ii = stdlib_i${ci}$amax( ki, vr( 1, is ), 1 ) + call stdlib${ii}$_${ci}$copy( ki, work( 1_${ik}$ ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ ) + ii = stdlib${ii}$_i${ci}$amax( ki, vr( 1_${ik}$, is ), 1_${ik}$ ) remax = one / cabs1( vr( ii, is ) ) - call stdlib_${ci}$dscal( ki, remax, vr( 1, is ), 1 ) + call stdlib${ii}$_${ci}$dscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ ) do k = ki + 1, n vr( k, is ) = cmzero end do else - if( ki>1 )call stdlib_${ci}$gemv( 'N', n, ki-1, cmone, vr, ldvr, work( 1 ),1, & - cmplx( scale,KIND=${ck}$), vr( 1, ki ), 1 ) - ii = stdlib_i${ci}$amax( n, vr( 1, ki ), 1 ) + if( ki>1_${ik}$ )call stdlib${ii}$_${ci}$gemv( 'N', n, ki-1, cmone, vr, ldvr, work( 1_${ik}$ ),1_${ik}$, & + cmplx( scale,KIND=${ck}$), vr( 1_${ik}$, ki ), 1_${ik}$ ) + ii = stdlib${ii}$_i${ci}$amax( n, vr( 1_${ik}$, ki ), 1_${ik}$ ) remax = one / cabs1( vr( ii, ki ) ) - call stdlib_${ci}$dscal( n, remax, vr( 1, ki ), 1 ) + call stdlib${ii}$_${ci}$dscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ ) end if ! set back the original diagonal elements of t. do k = 1, ki - 1 t( k, k ) = work( k+n ) end do - is = is - 1 + is = is - 1_${ik}$ end do loop_80 end if if( leftv ) then ! compute left eigenvectors. - is = 1 + is = 1_${ik}$ loop_130: do ki = 1, n if( somev ) then if( .not.select( ki ) )cycle loop_130 @@ -74159,38 +74150,38 @@ module stdlib_linalg_lapack_${ci}$ if( cabs1( t( k, k ) )= n + 2*n*nbmin ) then - nb = (lwork - n) / (2*n) + if( over .and. lwork >= n + 2_${ik}$*n*nbmin ) then + nb = (lwork - n) / (2_${ik}$*n) nb = min( nb, nbmax ) - call stdlib_${ci}$laset( 'F', n, 1+2*nb, czero, czero, work, n ) + call stdlib${ii}$_${ci}$laset( 'F', n, 1_${ik}$+2*nb, czero, czero, work, n ) else - nb = 1 + nb = 1_${ik}$ end if ! set the constants to control overflow. - unfl = stdlib_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) + unfl = stdlib${ii}$_${c2ri(ci)}$lamch( 'SAFE MINIMUM' ) ovfl = one / unfl - call stdlib_${c2ri(ci)}$labad( unfl, ovfl ) - ulp = stdlib_${c2ri(ci)}$lamch( 'PRECISION' ) + call stdlib${ii}$_${c2ri(ci)}$labad( unfl, ovfl ) + ulp = stdlib${ii}$_${c2ri(ci)}$lamch( 'PRECISION' ) smlnum = unfl*( n / ulp ) ! store the diagonal elements of t in working array work. do i = 1, n @@ -74310,9 +74301,9 @@ module stdlib_linalg_lapack_${ci}$ end do ! compute 1-norm of each column of strictly upper triangular ! part of t to control overflow in triangular solver. - rwork( 1 ) = zero + rwork( 1_${ik}$ ) = zero do j = 2, n - rwork( j ) = stdlib_${c2ri(ci)}$zasum( j-1, t( 1, j ), 1 ) + rwork( j ) = stdlib${ii}$_${c2ri(ci)}$zasum( j-1, t( 1_${ik}$, j ), 1_${ik}$ ) end do if( rightv ) then ! ============================================================ @@ -74341,30 +74332,30 @@ module stdlib_linalg_lapack_${ci}$ t( k, k ) = t( k, k ) - t( ki, ki ) if( cabs1( t( k, k ) )1 ) then - call stdlib_${ci}$latrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', 'Y',ki-1, t, ldt, & - work( 1 + iv*n ), scale,rwork, info ) + if( ki>1_${ik}$ ) then + call stdlib${ii}$_${ci}$latrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', 'Y',ki-1, t, ldt, & + work( 1_${ik}$ + iv*n ), scale,rwork, info ) work( ki + iv*n ) = scale end if ! copy the vector x or q*x to vr and normalize. if( .not.over ) then ! ------------------------------ ! no back-transform: copy x to vr and normalize. - call stdlib_${ci}$copy( ki, work( 1 + iv*n ), 1, vr( 1, is ), 1 ) - ii = stdlib_i${ci}$amax( ki, vr( 1, is ), 1 ) + call stdlib${ii}$_${ci}$copy( ki, work( 1_${ik}$ + iv*n ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ ) + ii = stdlib${ii}$_i${ci}$amax( ki, vr( 1_${ik}$, is ), 1_${ik}$ ) remax = one / cabs1( vr( ii, is ) ) - call stdlib_${ci}$dscal( ki, remax, vr( 1, is ), 1 ) + call stdlib${ii}$_${ci}$dscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ ) do k = ki + 1, n vr( k, is ) = czero end do - else if( nb==1 ) then + else if( nb==1_${ik}$ ) then ! ------------------------------ ! version 1: back-transform each vector with gemv, q*x. - if( ki>1 )call stdlib_${ci}$gemv( 'N', n, ki-1, cone, vr, ldvr,work( 1 + iv*n ), 1,& - cmplx( scale,KIND=${ck}$),vr( 1, ki ), 1 ) - ii = stdlib_i${ci}$amax( n, vr( 1, ki ), 1 ) + if( ki>1_${ik}$ )call stdlib${ii}$_${ci}$gemv( 'N', n, ki-1, cone, vr, ldvr,work( 1_${ik}$ + iv*n ), 1_${ik}$,& + cmplx( scale,KIND=${ck}$),vr( 1_${ik}$, ki ), 1_${ik}$ ) + ii = stdlib${ii}$_i${ci}$amax( n, vr( 1_${ik}$, ki ), 1_${ik}$ ) remax = one / cabs1( vr( ii, ki ) ) - call stdlib_${ci}$dscal( n, remax, vr( 1, ki ), 1 ) + call stdlib${ii}$_${ci}$dscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ ) else ! ------------------------------ ! version 2: back-transform block of vectors with gemm @@ -74375,27 +74366,27 @@ module stdlib_linalg_lapack_${ci}$ ! columns iv:nb of work are valid vectors. ! when the number of vectors stored reaches nb, ! or if this was last vector, do the gemm - if( (iv==1) .or. (ki==1) ) then - call stdlib_${ci}$gemm( 'N', 'N', n, nb-iv+1, ki+nb-iv, cone,vr, ldvr,work( 1 + & - (iv)*n ), n,czero,work( 1 + (nb+iv)*n ), n ) + if( (iv==1_${ik}$) .or. (ki==1_${ik}$) ) then + call stdlib${ii}$_${ci}$gemm( 'N', 'N', n, nb-iv+1, ki+nb-iv, cone,vr, ldvr,work( 1_${ik}$ + & + (iv)*n ), n,czero,work( 1_${ik}$ + (nb+iv)*n ), n ) ! normalize vectors do k = iv, nb - ii = stdlib_i${ci}$amax( n, work( 1 + (nb+k)*n ), 1 ) + ii = stdlib${ii}$_i${ci}$amax( n, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ ) remax = one / cabs1( work( ii + (nb+k)*n ) ) - call stdlib_${ci}$dscal( n, remax, work( 1 + (nb+k)*n ), 1 ) + call stdlib${ii}$_${ci}$dscal( n, remax, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ ) end do - call stdlib_${ci}$lacpy( 'F', n, nb-iv+1,work( 1 + (nb+iv)*n ), n,vr( 1, ki ), & + call stdlib${ii}$_${ci}$lacpy( 'F', n, nb-iv+1,work( 1_${ik}$ + (nb+iv)*n ), n,vr( 1_${ik}$, ki ), & ldvr ) iv = nb else - iv = iv - 1 + iv = iv - 1_${ik}$ end if end if ! restore the original diagonal elements of t. do k = 1, ki - 1 t( k, k ) = work( k ) end do - is = is - 1 + is = is - 1_${ik}$ end do loop_80 end if if( leftv ) then @@ -74405,8 +74396,8 @@ module stdlib_linalg_lapack_${ci}$ ! non-blocked version always uses iv=1; ! blocked version starts with iv=1, goes up to nb. ! (note the "0-th" column is used to store the original diagonal.) - iv = 1 - is = 1 + iv = 1_${ik}$ + is = 1_${ik}$ loop_130: do ki = 1, n if( somev ) then if( .not.select( ki ) )cycle loop_130 @@ -74426,7 +74417,7 @@ module stdlib_linalg_lapack_${ci}$ if( cabs1( t( k, k ) )n ).and.( n>0 )) then - info = -7 - else if(( ilst<1 .or. ilst>n ).and.( n>0 )) then - info = -8 - end if - if( info/=0 ) then - call stdlib_xerbla( 'ZTREXC', -info ) + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ + else if( ldtn ).and.( n>0_${ik}$ )) then + info = -7_${ik}$ + else if(( ilst<1_${ik}$ .or. ilst>n ).and.( n>0_${ik}$ )) then + info = -8_${ik}$ + end if + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZTREXC', -info ) return end if ! quick return if possible if( n<=1 .or. ifst==ilst )return if( ifstone ) then if( db>bignum*da11 )scaloc = one / db end if - x11 = stdlib_${ci}$ladiv( vec*cmplx( scaloc,KIND=${ck}$), a11 ) + x11 = stdlib${ii}$_${ci}$ladiv( vec*cmplx( scaloc,KIND=${ck}$), a11 ) if( scaloc/=one ) then do j = 1, n - call stdlib_${ci}$dscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_${ci}$dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if @@ -75211,8 +75202,8 @@ module stdlib_linalg_lapack_${ci}$ ! i=1 j=1 loop_60: do l = 1, n do k = 1, m - suml = stdlib_${ci}$dotc( k-1, a( 1, k ), 1, c( 1, l ), 1 ) - sumr = stdlib_${ci}$dotu( l-1, c( k, 1 ), ldc, b( 1, l ), 1 ) + suml = stdlib${ii}$_${ci}$dotc( k-1, a( 1_${ik}$, k ), 1_${ik}$, c( 1_${ik}$, l ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ci}$dotu( l-1, c( k, 1_${ik}$ ), ldc, b( 1_${ik}$, l ), 1_${ik}$ ) vec = c( k, l ) - ( suml+sgn*sumr ) scaloc = one a11 = conjg( a( k, k ) ) + sgn*b( l, l ) @@ -75220,16 +75211,16 @@ module stdlib_linalg_lapack_${ci}$ if( da11<=smin ) then a11 = smin da11 = smin - info = 1 + info = 1_${ik}$ end if db = abs( real( vec,KIND=${ck}$) ) + abs( aimag( vec ) ) if( da11one ) then if( db>bignum*da11 )scaloc = one / db end if - x11 = stdlib_${ci}$ladiv( vec*cmplx( scaloc,KIND=${ck}$), a11 ) + x11 = stdlib${ii}$_${ci}$ladiv( vec*cmplx( scaloc,KIND=${ck}$), a11 ) if( scaloc/=one ) then do j = 1, n - call stdlib_${ci}$dscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_${ci}$dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if @@ -75250,8 +75241,8 @@ module stdlib_linalg_lapack_${ci}$ ! j=l+1 loop_90: do l = n, 1, -1 do k = 1, m - suml = stdlib_${ci}$dotc( k-1, a( 1, k ), 1, c( 1, l ), 1 ) - sumr = stdlib_${ci}$dotc( n-l, c( k, min( l+1, n ) ), ldc,b( l, min( l+1, n ) ), & + suml = stdlib${ii}$_${ci}$dotc( k-1, a( 1_${ik}$, k ), 1_${ik}$, c( 1_${ik}$, l ), 1_${ik}$ ) + sumr = stdlib${ii}$_${ci}$dotc( n-l, c( k, min( l+1, n ) ), ldc,b( l, min( l+1, n ) ), & ldb ) vec = c( k, l ) - ( suml+sgn*conjg( sumr ) ) scaloc = one @@ -75260,16 +75251,16 @@ module stdlib_linalg_lapack_${ci}$ if( da11<=smin ) then a11 = smin da11 = smin - info = 1 + info = 1_${ik}$ end if db = abs( real( vec,KIND=${ck}$) ) + abs( aimag( vec ) ) if( da11one ) then if( db>bignum*da11 )scaloc = one / db end if - x11 = stdlib_${ci}$ladiv( vec*cmplx( scaloc,KIND=${ck}$), a11 ) + x11 = stdlib${ii}$_${ci}$ladiv( vec*cmplx( scaloc,KIND=${ck}$), a11 ) if( scaloc/=one ) then do j = 1, n - call stdlib_${ci}$dscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_${ci}$dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if @@ -75287,9 +75278,9 @@ module stdlib_linalg_lapack_${ci}$ ! i=k+1 j=l+1 loop_120: do l = n, 1, -1 do k = m, 1, -1 - suml = stdlib_${ci}$dotu( m-k, a( k, min( k+1, m ) ), lda,c( min( k+1, m ), l ), 1 & + suml = stdlib${ii}$_${ci}$dotu( m-k, a( k, min( k+1, m ) ), lda,c( min( k+1, m ), l ), 1_${ik}$ & ) - sumr = stdlib_${ci}$dotc( n-l, c( k, min( l+1, n ) ), ldc,b( l, min( l+1, n ) ), & + sumr = stdlib${ii}$_${ci}$dotc( n-l, c( k, min( l+1, n ) ), ldc,b( l, min( l+1, n ) ), & ldb ) vec = c( k, l ) - ( suml+sgn*conjg( sumr ) ) scaloc = one @@ -75298,16 +75289,16 @@ module stdlib_linalg_lapack_${ci}$ if( da11<=smin ) then a11 = smin da11 = smin - info = 1 + info = 1_${ik}$ end if db = abs( real( vec,KIND=${ck}$) ) + abs( aimag( vec ) ) if( da11one ) then if( db>bignum*da11 )scaloc = one / db end if - x11 = stdlib_${ci}$ladiv( vec*cmplx( scaloc,KIND=${ck}$), a11 ) + x11 = stdlib${ii}$_${ci}$ladiv( vec*cmplx( scaloc,KIND=${ck}$), a11 ) if( scaloc/=one ) then do j = 1, n - call stdlib_${ci}$dscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_${ci}$dscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if @@ -75316,10 +75307,10 @@ module stdlib_linalg_lapack_${ci}$ end do loop_120 end if return - end subroutine stdlib_${ci}$trsyl + end subroutine stdlib${ii}$_${ci}$trsyl - pure subroutine stdlib_${ci}$trti2( uplo, diag, n, a, lda, info ) + pure subroutine stdlib${ii}$_${ci}$trti2( uplo, diag, n, a, lda, info ) !! ZTRTI2: computes the inverse of a complex upper or lower triangular !! matrix. !! This is the Level 2 BLAS version of the algorithm. @@ -75328,34 +75319,34 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: diag, 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 complex(${ck}$), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: nounit, upper - integer(ilp) :: j + integer(${ik}$) :: j complex(${ck}$) :: ajj ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) nounit = stdlib_lsame( diag, 'N' ) if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.nounit .and. .not.stdlib_lsame( diag, 'U' ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( lda=n ) then + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZTRTRI', uplo // diag, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code - call stdlib_${ci}$trti2( uplo, diag, n, a, lda, info ) + call stdlib${ii}$_${ci}$trti2( uplo, diag, n, a, lda, info ) else ! use blocked code if( upper ) then @@ -75452,35 +75443,35 @@ module stdlib_linalg_lapack_${ci}$ do j = 1, n, nb jb = min( nb, n-j+1 ) ! compute rows 1:j-1 of current block column - call stdlib_${ci}$trmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, cone, a, & - lda, a( 1, j ), lda ) - call stdlib_${ci}$trsm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, -cone, a( & - j, j ), lda, a( 1, j ), lda ) + call stdlib${ii}$_${ci}$trmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, cone, a, & + lda, a( 1_${ik}$, j ), lda ) + call stdlib${ii}$_${ci}$trsm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, -cone, a( & + j, j ), lda, a( 1_${ik}$, j ), lda ) ! compute inverse of current diagonal block - call stdlib_${ci}$trti2( 'UPPER', diag, jb, a( j, j ), lda, info ) + call stdlib${ii}$_${ci}$trti2( '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_${ci}$trmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, & + call stdlib${ii}$_${ci}$trmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, & cone, a( j+jb, j+jb ), lda,a( j+jb, j ), lda ) - call stdlib_${ci}$trsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, -& + call stdlib${ii}$_${ci}$trsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, -& cone, a( j, j ), lda,a( j+jb, j ), lda ) end if ! compute inverse of current diagonal block - call stdlib_${ci}$trti2( 'LOWER', diag, jb, a( j, j ), lda, info ) + call stdlib${ii}$_${ci}$trti2( 'LOWER', diag, jb, a( j, j ), lda, info ) end do end if end if return - end subroutine stdlib_${ci}$trtri + end subroutine stdlib${ii}$_${ci}$trtri - pure subroutine stdlib_${ci}$trtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info ) + pure subroutine stdlib${ii}$_${ci}$trtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info ) !! ZTRTRS: solves a triangular system of the form !! A * X = B, A**T * X = B, or A**H * X = B, !! where A is a triangular matrix of order N, and B is an N-by-NRHS @@ -75490,8 +75481,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(in) :: a(lda,*) complex(${ck}$), intent(inout) :: b(ldb,*) @@ -75503,26 +75494,26 @@ module stdlib_linalg_lapack_${ci}$ 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 a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1); lda=n - ij = 0 + ij = 0_${ik}$ do j = 0, n2 do i = n1, n2 + j arf( ij ) = conjg( a( n2+j, i ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do i = j, n - 1 arf( ij ) = a( i, j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do else @@ -75637,11 +75628,11 @@ module stdlib_linalg_lapack_${ci}$ do j = n - 1, n1, -1 do i = 0, j arf( ij ) = a( i, j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do l = j - n1, n1 - 1 arf( ij ) = conjg( a( j-n1, l ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do ij = ij - nx2 end do @@ -75652,42 +75643,42 @@ module stdlib_linalg_lapack_${ci}$ ! 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 - ij = 0 + ij = 0_${ik}$ do j = 0, n2 - 1 do i = 0, j arf( ij ) = conjg( a( j, i ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do i = n1 + j, n - 1 arf( ij ) = a( i, n1+j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do do j = n2, n - 1 do i = 0, n1 - 1 arf( ij ) = conjg( a( j, i ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do 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 - ij = 0 + ij = 0_${ik}$ do j = 0, n1 do i = n1, n - 1 arf( ij ) = conjg( a( j, i ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do do j = 0, n1 - 1 do i = 0, j arf( ij ) = a( i, j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do l = n2 + j, n - 1 arf( ij ) = conjg( a( n2+j, l ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do end if @@ -75700,30 +75691,30 @@ module stdlib_linalg_lapack_${ci}$ ! 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); lda=n+1 - ij = 0 + ij = 0_${ik}$ do j = 0, k - 1 do i = k, k + j arf( ij ) = conjg( a( k+j, i ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do i = j, n - 1 arf( ij ) = a( i, j ) - ij = ij + 1 + ij = ij + 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); lda=n+1 - ij = nt - n - 1 + ij = nt - n - 1_${ik}$ do j = n - 1, k, -1 do i = 0, j arf( ij ) = a( i, j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do l = j - k, k - 1 arf( ij ) = conjg( a( j-k, l ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do ij = ij - np1x2 end do @@ -75734,62 +75725,62 @@ module stdlib_linalg_lapack_${ci}$ ! srpa for lower, transpose and n is even (see paper, a=b) ! t1 -> a(0,1) , t2 -> a(0,0) , s -> a(0,k+1) : ! t1 -> a(0+k) , t2 -> a(0+0) , s -> a(0+k*(k+1)); lda=k - ij = 0 + ij = 0_${ik}$ j = k do i = k, n - 1 arf( ij ) = a( i, j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do j = 0, k - 2 do i = 0, j arf( ij ) = conjg( a( j, i ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do i = k + 1 + j, n - 1 arf( ij ) = a( i, k+1+j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do do j = k - 1, n - 1 do i = 0, k - 1 arf( ij ) = conjg( a( j, i ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do else ! srpa for upper, transpose and n is even (see paper, a=b) ! t1 -> a(0,k+1) , t2 -> a(0,k) , s -> a(0,0) ! t1 -> a(0+k*(k+1)) , t2 -> a(0+k*k) , s -> a(0+0)); lda=k - ij = 0 + ij = 0_${ik}$ do j = 0, k do i = k, n - 1 arf( ij ) = conjg( a( j, i ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do do j = 0, k - 2 do i = 0, j arf( ij ) = a( i, j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do l = k + 1 + j, n - 1 arf( ij ) = conjg( a( k+1+j, l ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do ! note that here j = k-1 do i = 0, j arf( ij ) = a( i, j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end if end if end if return - end subroutine stdlib_${ci}$trttf + end subroutine stdlib${ii}$_${ci}$trttf - pure subroutine stdlib_${ci}$trttp( uplo, n, a, lda, ap, info ) + pure subroutine stdlib${ii}$_${ci}$trttp( uplo, n, a, lda, ap, info ) !! ZTRTTP: copies a triangular matrix A from full format (TR) to standard !! packed format (TP). ! -- lapack computational routine -- @@ -75797,8 +75788,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: n, lda + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n, lda ! Array Arguments complex(${ck}$), intent(in) :: a(lda,*) complex(${ck}$), intent(out) :: ap(*) @@ -75806,44 +75797,44 @@ module stdlib_linalg_lapack_${ci}$ ! Parameters ! Local Scalars logical(lk) :: lower - integer(ilp) :: i, j, k + integer(${ik}$) :: i, j, k ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ lower = stdlib_lsame( uplo, 'L' ) if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda1 .and. nb1_${ik}$ .and. nb1 ) then + call stdlib${ii}$_${ci}$latrz( ib, n-i+1, n-m, a( i, i ), lda, tau( i ),work ) + if( i>1_${ik}$ ) then ! form the triangular factor of the block reflector ! h = h(i+ib-1) . . . h(i+1) h(i) - call stdlib_${ci}$larzt( 'BACKWARD', 'ROWWISE', n-m, ib, a( i, m1 ),lda, tau( i ), & + call stdlib${ii}$_${ci}$larzt( 'BACKWARD', 'ROWWISE', n-m, ib, a( i, m1 ),lda, tau( i ), & work, ldwork ) ! apply h to a(1:i-1,i:n) from the right - call stdlib_${ci}$larzb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', i-1, n-i+1,& - ib, n-m, a( i, m1 ),lda, work, ldwork, a( 1, i ), lda,work( ib+1 ), ldwork ) + call stdlib${ii}$_${ci}$larzb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', i-1, n-i+1,& + ib, n-m, a( i, m1 ),lda, work, ldwork, a( 1_${ik}$, i ), lda,work( ib+1 ), ldwork ) end if end do - mu = i + nb - 1 + mu = i + nb - 1_${ik}$ else mu = m end if ! use unblocked code to factor the last or only block - if( mu>0 )call stdlib_${ci}$latrz( mu, n, n-m, a, lda, tau, work ) - work( 1 ) = lwkopt + if( mu>0_${ik}$ )call stdlib${ii}$_${ci}$latrz( mu, n, n-m, a, lda, tau, work ) + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ci}$tzrzf + end subroutine stdlib${ii}$_${ci}$tzrzf - subroutine stdlib_${ci}$unbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & + subroutine stdlib${ii}$_${ci}$unbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & !! ZUNBDB: simultaneously bidiagonalizes the blocks of an M-by-M !! partitioned unitary matrix X: !! [ B11 | B12 0 0 ] @@ -75982,8 +75973,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: signs, trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldx11, ldx12, ldx21, ldx22, lwork, m, p, q + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldx11, ldx12, ldx21, ldx22, lwork, m, p, q ! Array Arguments real(${ck}$), intent(out) :: phi(*), theta(*) complex(${ck}$), intent(out) :: taup1(*), taup2(*), tauq1(*), tauq2(*), work(*) @@ -75996,14 +75987,14 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: colmajor, lquery - integer(ilp) :: i, lworkmin, lworkopt + integer(${ik}$) :: i, lworkmin, lworkopt real(${ck}$) :: z1, z2, z3, z4 ! Intrinsic Functions intrinsic :: atan2,cos,max,min,sin intrinsic :: cmplx,conjg ! Executable Statements ! test input arguments - info = 0 + info = 0_${ik}$ colmajor = .not. stdlib_lsame( trans, 'T' ) if( .not. stdlib_lsame( signs, 'O' ) ) then z1 = realone @@ -76016,41 +76007,41 @@ module stdlib_linalg_lapack_${ci}$ z3 = realone z4 = -realone end if - lquery = lwork == -1 - if( m < 0 ) then - info = -3 - else if( p < 0 .or. p > m ) then - info = -4 - else if( q < 0 .or. q > p .or. q > m-p .or.q > m-q ) then - info = -5 - else if( colmajor .and. ldx11 < max( 1, p ) ) then - info = -7 - else if( .not.colmajor .and. ldx11 < max( 1, q ) ) then - info = -7 - else if( colmajor .and. ldx12 < max( 1, p ) ) then - info = -9 - else if( .not.colmajor .and. ldx12 < max( 1, m-q ) ) then - info = -9 - else if( colmajor .and. ldx21 < max( 1, m-p ) ) then - info = -11 - else if( .not.colmajor .and. ldx21 < max( 1, q ) ) then - info = -11 - else if( colmajor .and. ldx22 < max( 1, m-p ) ) then - info = -13 - else if( .not.colmajor .and. ldx22 < max( 1, m-q ) ) then - info = -13 + lquery = lwork == -1_${ik}$ + if( m < 0_${ik}$ ) then + info = -3_${ik}$ + else if( p < 0_${ik}$ .or. p > m ) then + info = -4_${ik}$ + else if( q < 0_${ik}$ .or. q > p .or. q > m-p .or.q > m-q ) then + info = -5_${ik}$ + else if( colmajor .and. ldx11 < max( 1_${ik}$, p ) ) then + info = -7_${ik}$ + else if( .not.colmajor .and. ldx11 < max( 1_${ik}$, q ) ) then + info = -7_${ik}$ + else if( colmajor .and. ldx12 < max( 1_${ik}$, p ) ) then + info = -9_${ik}$ + else if( .not.colmajor .and. ldx12 < max( 1_${ik}$, m-q ) ) then + info = -9_${ik}$ + else if( colmajor .and. ldx21 < max( 1_${ik}$, m-p ) ) then + info = -11_${ik}$ + else if( .not.colmajor .and. ldx21 < max( 1_${ik}$, q ) ) then + info = -11_${ik}$ + else if( colmajor .and. ldx22 < max( 1_${ik}$, m-p ) ) then + info = -13_${ik}$ + else if( .not.colmajor .and. ldx22 < max( 1_${ik}$, m-q ) ) then + info = -13_${ik}$ end if ! compute workspace - if( info == 0 ) then + if( info == 0_${ik}$ ) then lworkopt = m - q lworkmin = m - q - work(1) = lworkopt + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not. lquery ) then - info = -21 + info = -21_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'XORBDB', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'XORBDB', -info ) return else if( lquery ) then return @@ -76059,230 +76050,230 @@ module stdlib_linalg_lapack_${ci}$ if( colmajor ) then ! reduce columns 1, ..., q of x11, x12, x21, and x22 do i = 1, q - if( i == 1 ) then - call stdlib_${ci}$scal( p-i+1, cmplx( z1, 0.0_${ck}$,KIND=${ck}$), x11(i,i), 1 ) + if( i == 1_${ik}$ ) then + call stdlib${ii}$_${ci}$scal( p-i+1, cmplx( z1, 0.0_${ck}$,KIND=${ck}$), x11(i,i), 1_${ik}$ ) else - call stdlib_${ci}$scal( p-i+1, cmplx( z1*cos(phi(i-1)), 0.0_${ck}$,KIND=${ck}$),x11(i,i), & - 1 ) - call stdlib_${ci}$axpy( p-i+1, cmplx( -z1*z3*z4*sin(phi(i-1)),0.0_${ck}$,KIND=${ck}$), x12(& - i,i-1), 1, x11(i,i), 1 ) + call stdlib${ii}$_${ci}$scal( p-i+1, cmplx( z1*cos(phi(i-1)), 0.0_${ck}$,KIND=${ck}$),x11(i,i), & + 1_${ik}$ ) + call stdlib${ii}$_${ci}$axpy( p-i+1, cmplx( -z1*z3*z4*sin(phi(i-1)),0.0_${ck}$,KIND=${ck}$), x12(& + i,i-1), 1_${ik}$, x11(i,i), 1_${ik}$ ) end if - if( i == 1 ) then - call stdlib_${ci}$scal( m-p-i+1, cmplx( z2, 0.0_${ck}$,KIND=${ck}$), x21(i,i), 1 ) + if( i == 1_${ik}$ ) then + call stdlib${ii}$_${ci}$scal( m-p-i+1, cmplx( z2, 0.0_${ck}$,KIND=${ck}$), x21(i,i), 1_${ik}$ ) else - call stdlib_${ci}$scal( m-p-i+1, cmplx( z2*cos(phi(i-1)), 0.0_${ck}$,KIND=${ck}$),x21(i,i),& - 1 ) - call stdlib_${ci}$axpy( m-p-i+1, cmplx( -z2*z3*z4*sin(phi(i-1)),0.0_${ck}$,KIND=${ck}$), & - x22(i,i-1), 1, x21(i,i), 1 ) + call stdlib${ii}$_${ci}$scal( m-p-i+1, cmplx( z2*cos(phi(i-1)), 0.0_${ck}$,KIND=${ck}$),x21(i,i),& + 1_${ik}$ ) + call stdlib${ii}$_${ci}$axpy( m-p-i+1, cmplx( -z2*z3*z4*sin(phi(i-1)),0.0_${ck}$,KIND=${ck}$), & + x22(i,i-1), 1_${ik}$, x21(i,i), 1_${ik}$ ) end if - theta(i) = atan2( stdlib_${c2ri(ci)}$znrm2( m-p-i+1, x21(i,i), 1 ),stdlib_${c2ri(ci)}$znrm2( p-i+1, & - x11(i,i), 1 ) ) + theta(i) = atan2( stdlib${ii}$_${c2ri(ci)}$znrm2( m-p-i+1, x21(i,i), 1_${ik}$ ),stdlib${ii}$_${c2ri(ci)}$znrm2( p-i+1, & + x11(i,i), 1_${ik}$ ) ) if( p > i ) then - call stdlib_${ci}$larfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) + call stdlib${ii}$_${ci}$larfgp( p-i+1, x11(i,i), x11(i+1,i), 1_${ik}$, taup1(i) ) else if ( p == i ) then - call stdlib_${ci}$larfgp( p-i+1, x11(i,i), x11(i,i), 1, taup1(i) ) + call stdlib${ii}$_${ci}$larfgp( p-i+1, x11(i,i), x11(i,i), 1_${ik}$, taup1(i) ) end if x11(i,i) = cone if ( m-p > i ) then - call stdlib_${ci}$larfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1,taup2(i) ) + call stdlib${ii}$_${ci}$larfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1_${ik}$,taup2(i) ) else if ( m-p == i ) then - call stdlib_${ci}$larfgp( m-p-i+1, x21(i,i), x21(i,i), 1,taup2(i) ) + call stdlib${ii}$_${ci}$larfgp( m-p-i+1, x21(i,i), x21(i,i), 1_${ik}$,taup2(i) ) end if x21(i,i) = cone if ( q > i ) then - call stdlib_${ci}$larf( 'L', p-i+1, q-i, x11(i,i), 1,conjg(taup1(i)), x11(i,i+1), & + call stdlib${ii}$_${ci}$larf( 'L', p-i+1, q-i, x11(i,i), 1_${ik}$,conjg(taup1(i)), x11(i,i+1), & ldx11, work ) - call stdlib_${ci}$larf( 'L', m-p-i+1, q-i, x21(i,i), 1,conjg(taup2(i)), x21(i,i+1),& + call stdlib${ii}$_${ci}$larf( 'L', m-p-i+1, q-i, x21(i,i), 1_${ik}$,conjg(taup2(i)), x21(i,i+1),& ldx21, work ) end if if ( m-q+1 > i ) then - call stdlib_${ci}$larf( 'L', p-i+1, m-q-i+1, x11(i,i), 1,conjg(taup1(i)), x12(i,i),& + call stdlib${ii}$_${ci}$larf( 'L', p-i+1, m-q-i+1, x11(i,i), 1_${ik}$,conjg(taup1(i)), x12(i,i),& ldx12, work ) - call stdlib_${ci}$larf( 'L', m-p-i+1, m-q-i+1, x21(i,i), 1,conjg(taup2(i)), x22(i,& + call stdlib${ii}$_${ci}$larf( 'L', m-p-i+1, m-q-i+1, x21(i,i), 1_${ik}$,conjg(taup2(i)), x22(i,& i), ldx22, work ) end if if( i < q ) then - call stdlib_${ci}$scal( q-i, cmplx( -z1*z3*sin(theta(i)), 0.0_${ck}$,KIND=${ck}$),x11(i,i+& - 1), ldx11 ) - call stdlib_${ci}$axpy( q-i, cmplx( z2*z3*cos(theta(i)), 0.0_${ck}$,KIND=${ck}$),x21(i,i+1)& + call stdlib${ii}$_${ci}$scal( q-i, cmplx( -z1*z3*sin(theta(i)), 0.0_${ck}$,KIND=${ck}$),x11(i,i+& + 1_${ik}$), ldx11 ) + call stdlib${ii}$_${ci}$axpy( q-i, cmplx( z2*z3*cos(theta(i)), 0.0_${ck}$,KIND=${ck}$),x21(i,i+1)& , ldx21, x11(i,i+1), ldx11 ) end if - call stdlib_${ci}$scal( m-q-i+1, cmplx( -z1*z4*sin(theta(i)), 0.0_${ck}$,KIND=${ck}$),x12(i,i)& + call stdlib${ii}$_${ci}$scal( m-q-i+1, cmplx( -z1*z4*sin(theta(i)), 0.0_${ck}$,KIND=${ck}$),x12(i,i)& , ldx12 ) - call stdlib_${ci}$axpy( m-q-i+1, cmplx( z2*z4*cos(theta(i)), 0.0_${ck}$,KIND=${ck}$),x22(i,i),& + call stdlib${ii}$_${ci}$axpy( m-q-i+1, cmplx( z2*z4*cos(theta(i)), 0.0_${ck}$,KIND=${ck}$),x22(i,i),& ldx22, x12(i,i), ldx12 ) - if( i < q )phi(i) = atan2( stdlib_${c2ri(ci)}$znrm2( q-i, x11(i,i+1), ldx11 ),stdlib_${c2ri(ci)}$znrm2(& + if( i < q )phi(i) = atan2( stdlib${ii}$_${c2ri(ci)}$znrm2( q-i, x11(i,i+1), ldx11 ),stdlib${ii}$_${c2ri(ci)}$znrm2(& m-q-i+1, x12(i,i), ldx12 ) ) if( i < q ) then - call stdlib_${ci}$lacgv( q-i, x11(i,i+1), ldx11 ) + call stdlib${ii}$_${ci}$lacgv( q-i, x11(i,i+1), ldx11 ) if ( i == q-1 ) then - call stdlib_${ci}$larfgp( q-i, x11(i,i+1), x11(i,i+1), ldx11,tauq1(i) ) + call stdlib${ii}$_${ci}$larfgp( q-i, x11(i,i+1), x11(i,i+1), ldx11,tauq1(i) ) else - call stdlib_${ci}$larfgp( q-i, x11(i,i+1), x11(i,i+2), ldx11,tauq1(i) ) + call stdlib${ii}$_${ci}$larfgp( q-i, x11(i,i+1), x11(i,i+2), ldx11,tauq1(i) ) end if x11(i,i+1) = cone end if if ( m-q+1 > i ) then - call stdlib_${ci}$lacgv( m-q-i+1, x12(i,i), ldx12 ) + call stdlib${ii}$_${ci}$lacgv( m-q-i+1, x12(i,i), ldx12 ) if ( m-q == i ) then - call stdlib_${ci}$larfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,tauq2(i) ) + call stdlib${ii}$_${ci}$larfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,tauq2(i) ) else - call stdlib_${ci}$larfgp( m-q-i+1, x12(i,i), x12(i,i+1), ldx12,tauq2(i) ) + call stdlib${ii}$_${ci}$larfgp( m-q-i+1, x12(i,i), x12(i,i+1), ldx12,tauq2(i) ) end if end if x12(i,i) = cone if( i < q ) then - call stdlib_${ci}$larf( 'R', p-i, q-i, x11(i,i+1), ldx11, tauq1(i),x11(i+1,i+1), & + call stdlib${ii}$_${ci}$larf( 'R', p-i, q-i, x11(i,i+1), ldx11, tauq1(i),x11(i+1,i+1), & ldx11, work ) - call stdlib_${ci}$larf( 'R', m-p-i, q-i, x11(i,i+1), ldx11, tauq1(i),x21(i+1,i+1), & + call stdlib${ii}$_${ci}$larf( 'R', m-p-i, q-i, x11(i,i+1), ldx11, tauq1(i),x21(i+1,i+1), & ldx21, work ) end if if ( p > i ) then - call stdlib_${ci}$larf( 'R', p-i, m-q-i+1, x12(i,i), ldx12, tauq2(i),x12(i+1,i), & + call stdlib${ii}$_${ci}$larf( 'R', p-i, m-q-i+1, x12(i,i), ldx12, tauq2(i),x12(i+1,i), & ldx12, work ) end if if ( m-p > i ) then - call stdlib_${ci}$larf( 'R', m-p-i, m-q-i+1, x12(i,i), ldx12,tauq2(i), x22(i+1,i), & + call stdlib${ii}$_${ci}$larf( 'R', m-p-i, m-q-i+1, x12(i,i), ldx12,tauq2(i), x22(i+1,i), & ldx22, work ) end if - if( i < q )call stdlib_${ci}$lacgv( q-i, x11(i,i+1), ldx11 ) - call stdlib_${ci}$lacgv( m-q-i+1, x12(i,i), ldx12 ) + if( i < q )call stdlib${ii}$_${ci}$lacgv( q-i, x11(i,i+1), ldx11 ) + call stdlib${ii}$_${ci}$lacgv( m-q-i+1, x12(i,i), ldx12 ) end do ! reduce columns q + 1, ..., p of x12, x22 do i = q + 1, p - call stdlib_${ci}$scal( m-q-i+1, cmplx( -z1*z4, 0.0_${ck}$,KIND=${ck}$), x12(i,i),ldx12 ) + call stdlib${ii}$_${ci}$scal( m-q-i+1, cmplx( -z1*z4, 0.0_${ck}$,KIND=${ck}$), x12(i,i),ldx12 ) - call stdlib_${ci}$lacgv( m-q-i+1, x12(i,i), ldx12 ) + call stdlib${ii}$_${ci}$lacgv( m-q-i+1, x12(i,i), ldx12 ) if ( i >= m-q ) then - call stdlib_${ci}$larfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,tauq2(i) ) + call stdlib${ii}$_${ci}$larfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,tauq2(i) ) else - call stdlib_${ci}$larfgp( m-q-i+1, x12(i,i), x12(i,i+1), ldx12,tauq2(i) ) + call stdlib${ii}$_${ci}$larfgp( m-q-i+1, x12(i,i), x12(i,i+1), ldx12,tauq2(i) ) end if x12(i,i) = cone if ( p > i ) then - call stdlib_${ci}$larf( 'R', p-i, m-q-i+1, x12(i,i), ldx12, tauq2(i),x12(i+1,i), & + call stdlib${ii}$_${ci}$larf( 'R', p-i, m-q-i+1, x12(i,i), ldx12, tauq2(i),x12(i+1,i), & ldx12, work ) end if - if( m-p-q >= 1 )call stdlib_${ci}$larf( 'R', m-p-q, m-q-i+1, x12(i,i), ldx12,tauq2(i),& + if( m-p-q >= 1_${ik}$ )call stdlib${ii}$_${ci}$larf( 'R', m-p-q, m-q-i+1, x12(i,i), ldx12,tauq2(i),& x22(q+1,i), ldx22, work ) - call stdlib_${ci}$lacgv( m-q-i+1, x12(i,i), ldx12 ) + call stdlib${ii}$_${ci}$lacgv( m-q-i+1, x12(i,i), ldx12 ) end do ! reduce columns p + 1, ..., m - q of x12, x22 do i = 1, m - p - q - call stdlib_${ci}$scal( m-p-q-i+1, cmplx( z2*z4, 0.0_${ck}$,KIND=${ck}$),x22(q+i,p+i), ldx22 ) + call stdlib${ii}$_${ci}$scal( m-p-q-i+1, cmplx( z2*z4, 0.0_${ck}$,KIND=${ck}$),x22(q+i,p+i), ldx22 ) - call stdlib_${ci}$lacgv( m-p-q-i+1, x22(q+i,p+i), ldx22 ) - call stdlib_${ci}$larfgp( m-p-q-i+1, x22(q+i,p+i), x22(q+i,p+i+1),ldx22, tauq2(p+i) ) + call stdlib${ii}$_${ci}$lacgv( m-p-q-i+1, x22(q+i,p+i), ldx22 ) + call stdlib${ii}$_${ci}$larfgp( m-p-q-i+1, x22(q+i,p+i), x22(q+i,p+i+1),ldx22, tauq2(p+i) ) x22(q+i,p+i) = cone - call stdlib_${ci}$larf( 'R', m-p-q-i, m-p-q-i+1, x22(q+i,p+i), ldx22,tauq2(p+i), x22(& + call stdlib${ii}$_${ci}$larf( 'R', m-p-q-i, m-p-q-i+1, x22(q+i,p+i), ldx22,tauq2(p+i), x22(& q+i+1,p+i), ldx22, work ) - call stdlib_${ci}$lacgv( m-p-q-i+1, x22(q+i,p+i), ldx22 ) + call stdlib${ii}$_${ci}$lacgv( m-p-q-i+1, x22(q+i,p+i), ldx22 ) end do else ! reduce columns 1, ..., q of x11, x12, x21, x22 do i = 1, q - if( i == 1 ) then - call stdlib_${ci}$scal( p-i+1, cmplx( z1, 0.0_${ck}$,KIND=${ck}$), x11(i,i),ldx11 ) + if( i == 1_${ik}$ ) then + call stdlib${ii}$_${ci}$scal( p-i+1, cmplx( z1, 0.0_${ck}$,KIND=${ck}$), x11(i,i),ldx11 ) else - call stdlib_${ci}$scal( p-i+1, cmplx( z1*cos(phi(i-1)), 0.0_${ck}$,KIND=${ck}$),x11(i,i), & + call stdlib${ii}$_${ci}$scal( p-i+1, cmplx( z1*cos(phi(i-1)), 0.0_${ck}$,KIND=${ck}$),x11(i,i), & ldx11 ) - call stdlib_${ci}$axpy( p-i+1, cmplx( -z1*z3*z4*sin(phi(i-1)),0.0_${ck}$,KIND=${ck}$), x12(& + call stdlib${ii}$_${ci}$axpy( p-i+1, cmplx( -z1*z3*z4*sin(phi(i-1)),0.0_${ck}$,KIND=${ck}$), x12(& i-1,i), ldx12, x11(i,i), ldx11 ) end if - if( i == 1 ) then - call stdlib_${ci}$scal( m-p-i+1, cmplx( z2, 0.0_${ck}$,KIND=${ck}$), x21(i,i),ldx21 ) + if( i == 1_${ik}$ ) then + call stdlib${ii}$_${ci}$scal( m-p-i+1, cmplx( z2, 0.0_${ck}$,KIND=${ck}$), x21(i,i),ldx21 ) else - call stdlib_${ci}$scal( m-p-i+1, cmplx( z2*cos(phi(i-1)), 0.0_${ck}$,KIND=${ck}$),x21(i,i),& + call stdlib${ii}$_${ci}$scal( m-p-i+1, cmplx( z2*cos(phi(i-1)), 0.0_${ck}$,KIND=${ck}$),x21(i,i),& ldx21 ) - call stdlib_${ci}$axpy( m-p-i+1, cmplx( -z2*z3*z4*sin(phi(i-1)),0.0_${ck}$,KIND=${ck}$), & + call stdlib${ii}$_${ci}$axpy( m-p-i+1, cmplx( -z2*z3*z4*sin(phi(i-1)),0.0_${ck}$,KIND=${ck}$), & x22(i-1,i), ldx22, x21(i,i), ldx21 ) end if - theta(i) = atan2( stdlib_${c2ri(ci)}$znrm2( m-p-i+1, x21(i,i), ldx21 ),stdlib_${c2ri(ci)}$znrm2( p-i+1,& + theta(i) = atan2( stdlib${ii}$_${c2ri(ci)}$znrm2( m-p-i+1, x21(i,i), ldx21 ),stdlib${ii}$_${c2ri(ci)}$znrm2( p-i+1,& x11(i,i), ldx11 ) ) - call stdlib_${ci}$lacgv( p-i+1, x11(i,i), ldx11 ) - call stdlib_${ci}$lacgv( m-p-i+1, x21(i,i), ldx21 ) - call stdlib_${ci}$larfgp( p-i+1, x11(i,i), x11(i,i+1), ldx11, taup1(i) ) + call stdlib${ii}$_${ci}$lacgv( p-i+1, x11(i,i), ldx11 ) + call stdlib${ii}$_${ci}$lacgv( m-p-i+1, x21(i,i), ldx21 ) + call stdlib${ii}$_${ci}$larfgp( p-i+1, x11(i,i), x11(i,i+1), ldx11, taup1(i) ) x11(i,i) = cone if ( i == m-p ) then - call stdlib_${ci}$larfgp( m-p-i+1, x21(i,i), x21(i,i), ldx21,taup2(i) ) + call stdlib${ii}$_${ci}$larfgp( m-p-i+1, x21(i,i), x21(i,i), ldx21,taup2(i) ) else - call stdlib_${ci}$larfgp( m-p-i+1, x21(i,i), x21(i,i+1), ldx21,taup2(i) ) + call stdlib${ii}$_${ci}$larfgp( m-p-i+1, x21(i,i), x21(i,i+1), ldx21,taup2(i) ) end if x21(i,i) = cone - call stdlib_${ci}$larf( 'R', q-i, p-i+1, x11(i,i), ldx11, taup1(i),x11(i+1,i), ldx11, & + call stdlib${ii}$_${ci}$larf( 'R', q-i, p-i+1, x11(i,i), ldx11, taup1(i),x11(i+1,i), ldx11, & work ) - call stdlib_${ci}$larf( 'R', m-q-i+1, p-i+1, x11(i,i), ldx11, taup1(i),x12(i,i), & + call stdlib${ii}$_${ci}$larf( 'R', m-q-i+1, p-i+1, x11(i,i), ldx11, taup1(i),x12(i,i), & ldx12, work ) - call stdlib_${ci}$larf( 'R', q-i, m-p-i+1, x21(i,i), ldx21, taup2(i),x21(i+1,i), & + call stdlib${ii}$_${ci}$larf( 'R', q-i, m-p-i+1, x21(i,i), ldx21, taup2(i),x21(i+1,i), & ldx21, work ) - call stdlib_${ci}$larf( 'R', m-q-i+1, m-p-i+1, x21(i,i), ldx21,taup2(i), x22(i,i), & + call stdlib${ii}$_${ci}$larf( 'R', m-q-i+1, m-p-i+1, x21(i,i), ldx21,taup2(i), x22(i,i), & ldx22, work ) - call stdlib_${ci}$lacgv( p-i+1, x11(i,i), ldx11 ) - call stdlib_${ci}$lacgv( m-p-i+1, x21(i,i), ldx21 ) + call stdlib${ii}$_${ci}$lacgv( p-i+1, x11(i,i), ldx11 ) + call stdlib${ii}$_${ci}$lacgv( m-p-i+1, x21(i,i), ldx21 ) if( i < q ) then - call stdlib_${ci}$scal( q-i, cmplx( -z1*z3*sin(theta(i)), 0.0_${ck}$,KIND=${ck}$),x11(i+1,& - i), 1 ) - call stdlib_${ci}$axpy( q-i, cmplx( z2*z3*cos(theta(i)), 0.0_${ck}$,KIND=${ck}$),x21(i+1,i)& - , 1, x11(i+1,i), 1 ) - end if - call stdlib_${ci}$scal( m-q-i+1, cmplx( -z1*z4*sin(theta(i)), 0.0_${ck}$,KIND=${ck}$),x12(i,i)& - , 1 ) - call stdlib_${ci}$axpy( m-q-i+1, cmplx( z2*z4*cos(theta(i)), 0.0_${ck}$,KIND=${ck}$),x22(i,i),& - 1, x12(i,i), 1 ) - if( i < q )phi(i) = atan2( stdlib_${c2ri(ci)}$znrm2( q-i, x11(i+1,i), 1 ),stdlib_${c2ri(ci)}$znrm2( m-& - q-i+1, x12(i,i), 1 ) ) + call stdlib${ii}$_${ci}$scal( q-i, cmplx( -z1*z3*sin(theta(i)), 0.0_${ck}$,KIND=${ck}$),x11(i+1,& + i), 1_${ik}$ ) + call stdlib${ii}$_${ci}$axpy( q-i, cmplx( z2*z3*cos(theta(i)), 0.0_${ck}$,KIND=${ck}$),x21(i+1,i)& + , 1_${ik}$, x11(i+1,i), 1_${ik}$ ) + end if + call stdlib${ii}$_${ci}$scal( m-q-i+1, cmplx( -z1*z4*sin(theta(i)), 0.0_${ck}$,KIND=${ck}$),x12(i,i)& + , 1_${ik}$ ) + call stdlib${ii}$_${ci}$axpy( m-q-i+1, cmplx( z2*z4*cos(theta(i)), 0.0_${ck}$,KIND=${ck}$),x22(i,i),& + 1_${ik}$, x12(i,i), 1_${ik}$ ) + if( i < q )phi(i) = atan2( stdlib${ii}$_${c2ri(ci)}$znrm2( q-i, x11(i+1,i), 1_${ik}$ ),stdlib${ii}$_${c2ri(ci)}$znrm2( m-& + q-i+1, x12(i,i), 1_${ik}$ ) ) if( i < q ) then - call stdlib_${ci}$larfgp( q-i, x11(i+1,i), x11(i+2,i), 1, tauq1(i) ) + call stdlib${ii}$_${ci}$larfgp( q-i, x11(i+1,i), x11(i+2,i), 1_${ik}$, tauq1(i) ) x11(i+1,i) = cone end if - call stdlib_${ci}$larfgp( m-q-i+1, x12(i,i), x12(i+1,i), 1, tauq2(i) ) + call stdlib${ii}$_${ci}$larfgp( m-q-i+1, x12(i,i), x12(i+1,i), 1_${ik}$, tauq2(i) ) x12(i,i) = cone if( i < q ) then - call stdlib_${ci}$larf( 'L', q-i, p-i, x11(i+1,i), 1,conjg(tauq1(i)), x11(i+1,i+1),& + call stdlib${ii}$_${ci}$larf( 'L', q-i, p-i, x11(i+1,i), 1_${ik}$,conjg(tauq1(i)), x11(i+1,i+1),& ldx11, work ) - call stdlib_${ci}$larf( 'L', q-i, m-p-i, x11(i+1,i), 1,conjg(tauq1(i)), x21(i+1,i+& - 1), ldx21, work ) + call stdlib${ii}$_${ci}$larf( 'L', q-i, m-p-i, x11(i+1,i), 1_${ik}$,conjg(tauq1(i)), x21(i+1,i+& + 1_${ik}$), ldx21, work ) end if - call stdlib_${ci}$larf( 'L', m-q-i+1, p-i, x12(i,i), 1,conjg(tauq2(i)), x12(i,i+1), & + call stdlib${ii}$_${ci}$larf( 'L', m-q-i+1, p-i, x12(i,i), 1_${ik}$,conjg(tauq2(i)), x12(i,i+1), & ldx12, work ) if ( m-p > i ) then - call stdlib_${ci}$larf( 'L', m-q-i+1, m-p-i, x12(i,i), 1,conjg(tauq2(i)), x22(i,i+& - 1), ldx22, work ) + call stdlib${ii}$_${ci}$larf( 'L', m-q-i+1, m-p-i, x12(i,i), 1_${ik}$,conjg(tauq2(i)), x22(i,i+& + 1_${ik}$), ldx22, work ) end if end do ! reduce columns q + 1, ..., p of x12, x22 do i = q + 1, p - call stdlib_${ci}$scal( m-q-i+1, cmplx( -z1*z4, 0.0_${ck}$,KIND=${ck}$), x12(i,i), 1 ) - call stdlib_${ci}$larfgp( m-q-i+1, x12(i,i), x12(i+1,i), 1, tauq2(i) ) + call stdlib${ii}$_${ci}$scal( m-q-i+1, cmplx( -z1*z4, 0.0_${ck}$,KIND=${ck}$), x12(i,i), 1_${ik}$ ) + call stdlib${ii}$_${ci}$larfgp( m-q-i+1, x12(i,i), x12(i+1,i), 1_${ik}$, tauq2(i) ) x12(i,i) = cone if ( p > i ) then - call stdlib_${ci}$larf( 'L', m-q-i+1, p-i, x12(i,i), 1,conjg(tauq2(i)), x12(i,i+1),& + call stdlib${ii}$_${ci}$larf( 'L', m-q-i+1, p-i, x12(i,i), 1_${ik}$,conjg(tauq2(i)), x12(i,i+1),& ldx12, work ) end if - if( m-p-q >= 1 )call stdlib_${ci}$larf( 'L', m-q-i+1, m-p-q, x12(i,i), 1,conjg(tauq2(& + if( m-p-q >= 1_${ik}$ )call stdlib${ii}$_${ci}$larf( 'L', m-q-i+1, m-p-q, x12(i,i), 1_${ik}$,conjg(tauq2(& i)), x22(i,q+1), ldx22, work ) end do ! reduce columns p + 1, ..., m - q of x12, x22 do i = 1, m - p - q - call stdlib_${ci}$scal( m-p-q-i+1, cmplx( z2*z4, 0.0_${ck}$,KIND=${ck}$),x22(p+i,q+i), 1 ) + call stdlib${ii}$_${ci}$scal( m-p-q-i+1, cmplx( z2*z4, 0.0_${ck}$,KIND=${ck}$),x22(p+i,q+i), 1_${ik}$ ) - call stdlib_${ci}$larfgp( m-p-q-i+1, x22(p+i,q+i), x22(p+i+1,q+i), 1,tauq2(p+i) ) + call stdlib${ii}$_${ci}$larfgp( m-p-q-i+1, x22(p+i,q+i), x22(p+i+1,q+i), 1_${ik}$,tauq2(p+i) ) x22(p+i,q+i) = cone if ( m-p-q /= i ) then - call stdlib_${ci}$larf( 'L', m-p-q-i+1, m-p-q-i, x22(p+i,q+i), 1,conjg(tauq2(p+i)),& + call stdlib${ii}$_${ci}$larf( 'L', m-p-q-i+1, m-p-q-i, x22(p+i,q+i), 1_${ik}$,conjg(tauq2(p+i)),& x22(p+i,q+i+1), ldx22,work ) end if end do end if return - end subroutine stdlib_${ci}$unbdb + end subroutine stdlib${ii}$_${ci}$unbdb - subroutine stdlib_${ci}$unbdb1( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & + subroutine stdlib${ii}$_${ci}$unbdb1( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & !! ZUNBDB1: simultaneously bidiagonalizes the blocks of a tall and skinny !! matrix X with orthonomal columns: !! [ B11 ] @@ -76303,8 +76294,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: lwork, m, p, q, ldx11, ldx21 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork, m, p, q, ldx11, ldx21 ! Array Arguments real(${ck}$), intent(out) :: phi(*), theta(*) complex(${ck}$), intent(out) :: taup1(*), taup2(*), tauq1(*), work(*) @@ -76313,81 +76304,81 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars real(${ck}$) :: c, s - integer(ilp) :: childinfo, i, ilarf, iorbdb5, llarf, lorbdb5, lworkmin, & + integer(${ik}$) :: childinfo, i, ilarf, iorbdb5, llarf, lorbdb5, lworkmin, & lworkopt logical(lk) :: lquery ! Intrinsic Function intrinsic :: atan2,cos,max,sin,sqrt ! Executable Statements ! test input arguments - info = 0 - lquery = lwork == -1 - if( m < 0 ) then - info = -1 + info = 0_${ik}$ + lquery = lwork == -1_${ik}$ + if( m < 0_${ik}$ ) then + info = -1_${ik}$ else if( p < q .or. m-p < q ) then - info = -2 - else if( q < 0 .or. m-q < q ) then - info = -3 - else if( ldx11 < max( 1, p ) ) then - info = -5 - else if( ldx21 < max( 1, m-p ) ) then - info = -7 + info = -2_${ik}$ + else if( q < 0_${ik}$ .or. m-q < q ) then + info = -3_${ik}$ + else if( ldx11 < max( 1_${ik}$, p ) ) then + info = -5_${ik}$ + else if( ldx21 < max( 1_${ik}$, m-p ) ) then + info = -7_${ik}$ end if ! compute workspace - if( info == 0 ) then - ilarf = 2 + if( info == 0_${ik}$ ) then + ilarf = 2_${ik}$ llarf = max( p-1, m-p-1, q-1 ) - iorbdb5 = 2 + iorbdb5 = 2_${ik}$ lorbdb5 = q-2 lworkopt = max( ilarf+llarf-1, iorbdb5+lorbdb5-1 ) lworkmin = lworkopt - work(1) = lworkopt + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not.lquery ) then - info = -14 + info = -14_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'ZUNBDB1', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZUNBDB1', -info ) return else if( lquery ) then return end if ! reduce columns 1, ..., q of x11 and x21 do i = 1, q - call stdlib_${ci}$larfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) - call stdlib_${ci}$larfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) ) + call stdlib${ii}$_${ci}$larfgp( p-i+1, x11(i,i), x11(i+1,i), 1_${ik}$, taup1(i) ) + call stdlib${ii}$_${ci}$larfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1_${ik}$, taup2(i) ) theta(i) = atan2( real( x21(i,i),KIND=${ck}$), real( x11(i,i),KIND=${ck}$) ) c = cos( theta(i) ) s = sin( theta(i) ) x11(i,i) = cone x21(i,i) = cone - call stdlib_${ci}$larf( 'L', p-i+1, q-i, x11(i,i), 1, conjg(taup1(i)),x11(i,i+1), ldx11, & + call stdlib${ii}$_${ci}$larf( 'L', p-i+1, q-i, x11(i,i), 1_${ik}$, conjg(taup1(i)),x11(i,i+1), ldx11, & work(ilarf) ) - call stdlib_${ci}$larf( 'L', m-p-i+1, q-i, x21(i,i), 1, conjg(taup2(i)),x21(i,i+1), & + call stdlib${ii}$_${ci}$larf( 'L', m-p-i+1, q-i, x21(i,i), 1_${ik}$, conjg(taup2(i)),x21(i,i+1), & ldx21, work(ilarf) ) if( i < q ) then - call stdlib_${ci}$drot( q-i, x11(i,i+1), ldx11, x21(i,i+1), ldx21, c,s ) - call stdlib_${ci}$lacgv( q-i, x21(i,i+1), ldx21 ) - call stdlib_${ci}$larfgp( q-i, x21(i,i+1), x21(i,i+2), ldx21, tauq1(i) ) + call stdlib${ii}$_${ci}$drot( q-i, x11(i,i+1), ldx11, x21(i,i+1), ldx21, c,s ) + call stdlib${ii}$_${ci}$lacgv( q-i, x21(i,i+1), ldx21 ) + call stdlib${ii}$_${ci}$larfgp( q-i, x21(i,i+1), x21(i,i+2), ldx21, tauq1(i) ) s = real( x21(i,i+1),KIND=${ck}$) x21(i,i+1) = cone - call stdlib_${ci}$larf( 'R', p-i, q-i, x21(i,i+1), ldx21, tauq1(i),x11(i+1,i+1), & + call stdlib${ii}$_${ci}$larf( 'R', p-i, q-i, x21(i,i+1), ldx21, tauq1(i),x11(i+1,i+1), & ldx11, work(ilarf) ) - call stdlib_${ci}$larf( 'R', m-p-i, q-i, x21(i,i+1), ldx21, tauq1(i),x21(i+1,i+1), & + call stdlib${ii}$_${ci}$larf( 'R', m-p-i, q-i, x21(i,i+1), ldx21, tauq1(i),x21(i+1,i+1), & ldx21, work(ilarf) ) - call stdlib_${ci}$lacgv( q-i, x21(i,i+1), ldx21 ) - c = sqrt( stdlib_${c2ri(ci)}$znrm2( p-i, x11(i+1,i+1), 1 )**2+ stdlib_${c2ri(ci)}$znrm2( m-p-i, x21(i+& - 1,i+1), 1 )**2 ) + call stdlib${ii}$_${ci}$lacgv( q-i, x21(i,i+1), ldx21 ) + c = sqrt( stdlib${ii}$_${c2ri(ci)}$znrm2( p-i, x11(i+1,i+1), 1_${ik}$ )**2_${ik}$+ stdlib${ii}$_${c2ri(ci)}$znrm2( m-p-i, x21(i+& + 1_${ik}$,i+1), 1_${ik}$ )**2_${ik}$ ) phi(i) = atan2( s, c ) - call stdlib_${ci}$unbdb5( p-i, m-p-i, q-i-1, x11(i+1,i+1), 1,x21(i+1,i+1), 1, x11(i+1,& + call stdlib${ii}$_${ci}$unbdb5( p-i, m-p-i, q-i-1, x11(i+1,i+1), 1_${ik}$,x21(i+1,i+1), 1_${ik}$, x11(i+1,& i+2), ldx11,x21(i+1,i+2), ldx21, work(iorbdb5), lorbdb5,childinfo ) end if end do return - end subroutine stdlib_${ci}$unbdb1 + end subroutine stdlib${ii}$_${ci}$unbdb1 - subroutine stdlib_${ci}$unbdb2( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & + subroutine stdlib${ii}$_${ci}$unbdb2( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & !! ZUNBDB2: simultaneously bidiagonalizes the blocks of a tall and skinny !! matrix X with orthonomal columns: !! [ B11 ] @@ -76408,8 +76399,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: lwork, m, p, q, ldx11, ldx21 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork, m, p, q, ldx11, ldx21 ! Array Arguments real(${ck}$), intent(out) :: phi(*), theta(*) complex(${ck}$), intent(out) :: taup1(*), taup2(*), tauq1(*), work(*) @@ -76418,91 +76409,91 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars real(${ck}$) :: c, s - integer(ilp) :: childinfo, i, ilarf, iorbdb5, llarf, lorbdb5, lworkmin, & + integer(${ik}$) :: childinfo, i, ilarf, iorbdb5, llarf, lorbdb5, lworkmin, & lworkopt logical(lk) :: lquery ! Intrinsic Function intrinsic :: atan2,cos,max,sin,sqrt ! Executable Statements ! test input arguments - info = 0 - lquery = lwork == -1 - if( m < 0 ) then - info = -1 - else if( p < 0 .or. p > m-p ) then - info = -2 - else if( q < 0 .or. q < p .or. m-q < p ) then - info = -3 - else if( ldx11 < max( 1, p ) ) then - info = -5 - else if( ldx21 < max( 1, m-p ) ) then - info = -7 + info = 0_${ik}$ + lquery = lwork == -1_${ik}$ + if( m < 0_${ik}$ ) then + info = -1_${ik}$ + else if( p < 0_${ik}$ .or. p > m-p ) then + info = -2_${ik}$ + else if( q < 0_${ik}$ .or. q < p .or. m-q < p ) then + info = -3_${ik}$ + else if( ldx11 < max( 1_${ik}$, p ) ) then + info = -5_${ik}$ + else if( ldx21 < max( 1_${ik}$, m-p ) ) then + info = -7_${ik}$ end if ! compute workspace - if( info == 0 ) then - ilarf = 2 + if( info == 0_${ik}$ ) then + ilarf = 2_${ik}$ llarf = max( p-1, m-p, q-1 ) - iorbdb5 = 2 + iorbdb5 = 2_${ik}$ lorbdb5 = q-1 lworkopt = max( ilarf+llarf-1, iorbdb5+lorbdb5-1 ) lworkmin = lworkopt - work(1) = lworkopt + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not.lquery ) then - info = -14 + info = -14_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'ZUNBDB2', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZUNBDB2', -info ) return else if( lquery ) then return end if ! reduce rows 1, ..., p of x11 and x21 do i = 1, p - if( i > 1 ) then - call stdlib_${ci}$drot( q-i+1, x11(i,i), ldx11, x21(i-1,i), ldx21, c,s ) + if( i > 1_${ik}$ ) then + call stdlib${ii}$_${ci}$drot( q-i+1, x11(i,i), ldx11, x21(i-1,i), ldx21, c,s ) end if - call stdlib_${ci}$lacgv( q-i+1, x11(i,i), ldx11 ) - call stdlib_${ci}$larfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) + call stdlib${ii}$_${ci}$lacgv( q-i+1, x11(i,i), ldx11 ) + call stdlib${ii}$_${ci}$larfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) c = real( x11(i,i),KIND=${ck}$) x11(i,i) = cone - call stdlib_${ci}$larf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & + call stdlib${ii}$_${ci}$larf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & work(ilarf) ) - call stdlib_${ci}$larf( 'R', m-p-i+1, q-i+1, x11(i,i), ldx11, tauq1(i),x21(i,i), ldx21, & + call stdlib${ii}$_${ci}$larf( 'R', m-p-i+1, q-i+1, x11(i,i), ldx11, tauq1(i),x21(i,i), ldx21, & work(ilarf) ) - call stdlib_${ci}$lacgv( q-i+1, x11(i,i), ldx11 ) - s = sqrt( stdlib_${c2ri(ci)}$znrm2( p-i, x11(i+1,i), 1 )**2+ stdlib_${c2ri(ci)}$znrm2( m-p-i+1, x21(i,i), & - 1 )**2 ) + call stdlib${ii}$_${ci}$lacgv( q-i+1, x11(i,i), ldx11 ) + s = sqrt( stdlib${ii}$_${c2ri(ci)}$znrm2( p-i, x11(i+1,i), 1_${ik}$ )**2_${ik}$+ stdlib${ii}$_${c2ri(ci)}$znrm2( m-p-i+1, x21(i,i), & + 1_${ik}$ )**2_${ik}$ ) theta(i) = atan2( s, c ) - call stdlib_${ci}$unbdb5( p-i, m-p-i+1, q-i, x11(i+1,i), 1, x21(i,i), 1,x11(i+1,i+1), & + call stdlib${ii}$_${ci}$unbdb5( p-i, m-p-i+1, q-i, x11(i+1,i), 1_${ik}$, x21(i,i), 1_${ik}$,x11(i+1,i+1), & ldx11, x21(i,i+1), ldx21,work(iorbdb5), lorbdb5, childinfo ) - call stdlib_${ci}$scal( p-i, cnegone, x11(i+1,i), 1 ) - call stdlib_${ci}$larfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) ) + call stdlib${ii}$_${ci}$scal( p-i, cnegone, x11(i+1,i), 1_${ik}$ ) + call stdlib${ii}$_${ci}$larfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1_${ik}$, taup2(i) ) if( i < p ) then - call stdlib_${ci}$larfgp( p-i, x11(i+1,i), x11(i+2,i), 1, taup1(i) ) + call stdlib${ii}$_${ci}$larfgp( p-i, x11(i+1,i), x11(i+2,i), 1_${ik}$, taup1(i) ) phi(i) = atan2( real( x11(i+1,i),KIND=${ck}$), real( x21(i,i),KIND=${ck}$) ) c = cos( phi(i) ) s = sin( phi(i) ) x11(i+1,i) = cone - call stdlib_${ci}$larf( 'L', p-i, q-i, x11(i+1,i), 1, conjg(taup1(i)),x11(i+1,i+1), & + call stdlib${ii}$_${ci}$larf( 'L', p-i, q-i, x11(i+1,i), 1_${ik}$, conjg(taup1(i)),x11(i+1,i+1), & ldx11, work(ilarf) ) end if x21(i,i) = cone - call stdlib_${ci}$larf( 'L', m-p-i+1, q-i, x21(i,i), 1, conjg(taup2(i)),x21(i,i+1), & + call stdlib${ii}$_${ci}$larf( 'L', m-p-i+1, q-i, x21(i,i), 1_${ik}$, conjg(taup2(i)),x21(i,i+1), & ldx21, work(ilarf) ) end do ! reduce the bottom-right portion of x21 to the identity matrix do i = p + 1, q - call stdlib_${ci}$larfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) ) + call stdlib${ii}$_${ci}$larfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1_${ik}$, taup2(i) ) x21(i,i) = cone - call stdlib_${ci}$larf( 'L', m-p-i+1, q-i, x21(i,i), 1, conjg(taup2(i)),x21(i,i+1), & + call stdlib${ii}$_${ci}$larf( 'L', m-p-i+1, q-i, x21(i,i), 1_${ik}$, conjg(taup2(i)),x21(i,i+1), & ldx21, work(ilarf) ) end do return - end subroutine stdlib_${ci}$unbdb2 + end subroutine stdlib${ii}$_${ci}$unbdb2 - subroutine stdlib_${ci}$unbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & + subroutine stdlib${ii}$_${ci}$unbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & !! ZUNBDB3: simultaneously bidiagonalizes the blocks of a tall and skinny !! matrix X with orthonomal columns: !! [ B11 ] @@ -76523,8 +76514,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: lwork, m, p, q, ldx11, ldx21 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork, m, p, q, ldx11, ldx21 ! Array Arguments real(${ck}$), intent(out) :: phi(*), theta(*) complex(${ck}$), intent(out) :: taup1(*), taup2(*), tauq1(*), work(*) @@ -76533,90 +76524,90 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars real(${ck}$) :: c, s - integer(ilp) :: childinfo, i, ilarf, iorbdb5, llarf, lorbdb5, lworkmin, & + integer(${ik}$) :: childinfo, i, ilarf, iorbdb5, llarf, lorbdb5, lworkmin, & lworkopt logical(lk) :: lquery ! Intrinsic Function intrinsic :: atan2,cos,max,sin,sqrt ! Executable Statements ! test input arguments - info = 0 - lquery = lwork == -1 - if( m < 0 ) then - info = -1 - else if( 2*p < m .or. p > m ) then - info = -2 + info = 0_${ik}$ + lquery = lwork == -1_${ik}$ + if( m < 0_${ik}$ ) then + info = -1_${ik}$ + else if( 2_${ik}$*p < m .or. p > m ) then + info = -2_${ik}$ else if( q < m-p .or. m-q < m-p ) then - info = -3 - else if( ldx11 < max( 1, p ) ) then - info = -5 - else if( ldx21 < max( 1, m-p ) ) then - info = -7 + info = -3_${ik}$ + else if( ldx11 < max( 1_${ik}$, p ) ) then + info = -5_${ik}$ + else if( ldx21 < max( 1_${ik}$, m-p ) ) then + info = -7_${ik}$ end if ! compute workspace - if( info == 0 ) then - ilarf = 2 + if( info == 0_${ik}$ ) then + ilarf = 2_${ik}$ llarf = max( p, m-p-1, q-1 ) - iorbdb5 = 2 + iorbdb5 = 2_${ik}$ lorbdb5 = q-1 lworkopt = max( ilarf+llarf-1, iorbdb5+lorbdb5-1 ) lworkmin = lworkopt - work(1) = lworkopt + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not.lquery ) then - info = -14 + info = -14_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'ZUNBDB3', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZUNBDB3', -info ) return else if( lquery ) then return end if ! reduce rows 1, ..., m-p of x11 and x21 do i = 1, m-p - if( i > 1 ) then - call stdlib_${ci}$drot( q-i+1, x11(i-1,i), ldx11, x21(i,i), ldx11, c,s ) + if( i > 1_${ik}$ ) then + call stdlib${ii}$_${ci}$drot( q-i+1, x11(i-1,i), ldx11, x21(i,i), ldx11, c,s ) end if - call stdlib_${ci}$lacgv( q-i+1, x21(i,i), ldx21 ) - call stdlib_${ci}$larfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) + call stdlib${ii}$_${ci}$lacgv( q-i+1, x21(i,i), ldx21 ) + call stdlib${ii}$_${ci}$larfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) s = real( x21(i,i),KIND=${ck}$) x21(i,i) = cone - call stdlib_${ci}$larf( 'R', p-i+1, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i,i), ldx11, & + call stdlib${ii}$_${ci}$larf( 'R', p-i+1, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i,i), ldx11, & work(ilarf) ) - call stdlib_${ci}$larf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & + call stdlib${ii}$_${ci}$larf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & work(ilarf) ) - call stdlib_${ci}$lacgv( q-i+1, x21(i,i), ldx21 ) - c = sqrt( stdlib_${c2ri(ci)}$znrm2( p-i+1, x11(i,i), 1 )**2+ stdlib_${c2ri(ci)}$znrm2( m-p-i, x21(i+1,i), & - 1 )**2 ) + call stdlib${ii}$_${ci}$lacgv( q-i+1, x21(i,i), ldx21 ) + c = sqrt( stdlib${ii}$_${c2ri(ci)}$znrm2( p-i+1, x11(i,i), 1_${ik}$ )**2_${ik}$+ stdlib${ii}$_${c2ri(ci)}$znrm2( m-p-i, x21(i+1,i), & + 1_${ik}$ )**2_${ik}$ ) theta(i) = atan2( s, c ) - call stdlib_${ci}$unbdb5( p-i+1, m-p-i, q-i, x11(i,i), 1, x21(i+1,i), 1,x11(i,i+1), & + call stdlib${ii}$_${ci}$unbdb5( p-i+1, m-p-i, q-i, x11(i,i), 1_${ik}$, x21(i+1,i), 1_${ik}$,x11(i,i+1), & ldx11, x21(i+1,i+1), ldx21,work(iorbdb5), lorbdb5, childinfo ) - call stdlib_${ci}$larfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) + call stdlib${ii}$_${ci}$larfgp( p-i+1, x11(i,i), x11(i+1,i), 1_${ik}$, taup1(i) ) if( i < m-p ) then - call stdlib_${ci}$larfgp( m-p-i, x21(i+1,i), x21(i+2,i), 1, taup2(i) ) + call stdlib${ii}$_${ci}$larfgp( m-p-i, x21(i+1,i), x21(i+2,i), 1_${ik}$, taup2(i) ) phi(i) = atan2( real( x21(i+1,i),KIND=${ck}$), real( x11(i,i),KIND=${ck}$) ) c = cos( phi(i) ) s = sin( phi(i) ) x21(i+1,i) = cone - call stdlib_${ci}$larf( 'L', m-p-i, q-i, x21(i+1,i), 1,conjg(taup2(i)), x21(i+1,i+1), & + call stdlib${ii}$_${ci}$larf( 'L', m-p-i, q-i, x21(i+1,i), 1_${ik}$,conjg(taup2(i)), x21(i+1,i+1), & ldx21,work(ilarf) ) end if x11(i,i) = cone - call stdlib_${ci}$larf( 'L', p-i+1, q-i, x11(i,i), 1, conjg(taup1(i)),x11(i,i+1), ldx11, & + call stdlib${ii}$_${ci}$larf( 'L', p-i+1, q-i, x11(i,i), 1_${ik}$, conjg(taup1(i)),x11(i,i+1), ldx11, & work(ilarf) ) end do ! reduce the bottom-right portion of x11 to the identity matrix do i = m-p + 1, q - call stdlib_${ci}$larfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) + call stdlib${ii}$_${ci}$larfgp( p-i+1, x11(i,i), x11(i+1,i), 1_${ik}$, taup1(i) ) x11(i,i) = cone - call stdlib_${ci}$larf( 'L', p-i+1, q-i, x11(i,i), 1, conjg(taup1(i)),x11(i,i+1), ldx11, & + call stdlib${ii}$_${ci}$larf( 'L', p-i+1, q-i, x11(i,i), 1_${ik}$, conjg(taup1(i)),x11(i,i+1), ldx11, & work(ilarf) ) end do return - end subroutine stdlib_${ci}$unbdb3 + end subroutine stdlib${ii}$_${ci}$unbdb3 - subroutine stdlib_${ci}$unbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & + subroutine stdlib${ii}$_${ci}$unbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & !! ZUNBDB4: simultaneously bidiagonalizes the blocks of a tall and skinny !! matrix X with orthonomal columns: !! [ B11 ] @@ -76637,8 +76628,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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) :: lwork, m, p, q, ldx11, ldx21 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork, m, p, q, ldx11, ldx21 ! Array Arguments real(${ck}$), intent(out) :: phi(*), theta(*) complex(${ck}$), intent(out) :: phantom(*), taup1(*), taup2(*), tauq1(*), work(*) @@ -76647,125 +76638,125 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars real(${ck}$) :: c, s - integer(ilp) :: childinfo, i, ilarf, iorbdb5, j, llarf, lorbdb5, lworkmin, & + integer(${ik}$) :: childinfo, i, ilarf, iorbdb5, j, llarf, lorbdb5, lworkmin, & lworkopt logical(lk) :: lquery ! Intrinsic Function intrinsic :: atan2,cos,max,sin,sqrt ! Executable Statements ! test input arguments - info = 0 - lquery = lwork == -1 - if( m < 0 ) then - info = -1 + info = 0_${ik}$ + lquery = lwork == -1_${ik}$ + if( m < 0_${ik}$ ) then + info = -1_${ik}$ else if( p < m-q .or. m-p < m-q ) then - info = -2 + info = -2_${ik}$ else if( q < m-q .or. q > m ) then - info = -3 - else if( ldx11 < max( 1, p ) ) then - info = -5 - else if( ldx21 < max( 1, m-p ) ) then - info = -7 + info = -3_${ik}$ + else if( ldx11 < max( 1_${ik}$, p ) ) then + info = -5_${ik}$ + else if( ldx21 < max( 1_${ik}$, m-p ) ) then + info = -7_${ik}$ end if ! compute workspace - if( info == 0 ) then - ilarf = 2 + if( info == 0_${ik}$ ) then + ilarf = 2_${ik}$ llarf = max( q-1, p-1, m-p-1 ) - iorbdb5 = 2 + iorbdb5 = 2_${ik}$ lorbdb5 = q - lworkopt = ilarf + llarf - 1 - lworkopt = max( lworkopt, iorbdb5 + lorbdb5 - 1 ) + lworkopt = ilarf + llarf - 1_${ik}$ + lworkopt = max( lworkopt, iorbdb5 + lorbdb5 - 1_${ik}$ ) lworkmin = lworkopt - work(1) = lworkopt + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not.lquery ) then - info = -14 + info = -14_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'ZUNBDB4', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZUNBDB4', -info ) return else if( lquery ) then return end if ! reduce columns 1, ..., m-q of x11 and x21 do i = 1, m-q - if( i == 1 ) then + if( i == 1_${ik}$ ) then do j = 1, m phantom(j) = czero end do - call stdlib_${ci}$unbdb5( p, m-p, q, phantom(1), 1, phantom(p+1), 1,x11, ldx11, x21, & + call stdlib${ii}$_${ci}$unbdb5( p, m-p, q, phantom(1_${ik}$), 1_${ik}$, phantom(p+1), 1_${ik}$,x11, ldx11, x21, & ldx21, work(iorbdb5),lorbdb5, childinfo ) - call stdlib_${ci}$scal( p, cnegone, phantom(1), 1 ) - call stdlib_${ci}$larfgp( p, phantom(1), phantom(2), 1, taup1(1) ) - call stdlib_${ci}$larfgp( m-p, phantom(p+1), phantom(p+2), 1, taup2(1) ) - theta(i) = atan2( real( phantom(1),KIND=${ck}$), real( phantom(p+1),KIND=${ck}$) ) + call stdlib${ii}$_${ci}$scal( p, cnegone, phantom(1_${ik}$), 1_${ik}$ ) + call stdlib${ii}$_${ci}$larfgp( p, phantom(1_${ik}$), phantom(2_${ik}$), 1_${ik}$, taup1(1_${ik}$) ) + call stdlib${ii}$_${ci}$larfgp( m-p, phantom(p+1), phantom(p+2), 1_${ik}$, taup2(1_${ik}$) ) + theta(i) = atan2( real( phantom(1_${ik}$),KIND=${ck}$), real( phantom(p+1),KIND=${ck}$) ) c = cos( theta(i) ) s = sin( theta(i) ) - phantom(1) = cone + phantom(1_${ik}$) = cone phantom(p+1) = cone - call stdlib_${ci}$larf( 'L', p, q, phantom(1), 1, conjg(taup1(1)), x11,ldx11, work(& + call stdlib${ii}$_${ci}$larf( 'L', p, q, phantom(1_${ik}$), 1_${ik}$, conjg(taup1(1_${ik}$)), x11,ldx11, work(& ilarf) ) - call stdlib_${ci}$larf( 'L', m-p, q, phantom(p+1), 1, conjg(taup2(1)),x21, ldx21, & + call stdlib${ii}$_${ci}$larf( 'L', m-p, q, phantom(p+1), 1_${ik}$, conjg(taup2(1_${ik}$)),x21, ldx21, & work(ilarf) ) else - call stdlib_${ci}$unbdb5( p-i+1, m-p-i+1, q-i+1, x11(i,i-1), 1,x21(i,i-1), 1, x11(i,i)& + call stdlib${ii}$_${ci}$unbdb5( p-i+1, m-p-i+1, q-i+1, x11(i,i-1), 1_${ik}$,x21(i,i-1), 1_${ik}$, x11(i,i)& , ldx11, x21(i,i),ldx21, work(iorbdb5), lorbdb5, childinfo ) - call stdlib_${ci}$scal( p-i+1, cnegone, x11(i,i-1), 1 ) - call stdlib_${ci}$larfgp( p-i+1, x11(i,i-1), x11(i+1,i-1), 1, taup1(i) ) - call stdlib_${ci}$larfgp( m-p-i+1, x21(i,i-1), x21(i+1,i-1), 1,taup2(i) ) + call stdlib${ii}$_${ci}$scal( p-i+1, cnegone, x11(i,i-1), 1_${ik}$ ) + call stdlib${ii}$_${ci}$larfgp( p-i+1, x11(i,i-1), x11(i+1,i-1), 1_${ik}$, taup1(i) ) + call stdlib${ii}$_${ci}$larfgp( m-p-i+1, x21(i,i-1), x21(i+1,i-1), 1_${ik}$,taup2(i) ) theta(i) = atan2( real( x11(i,i-1),KIND=${ck}$), real( x21(i,i-1),KIND=${ck}$) ) c = cos( theta(i) ) s = sin( theta(i) ) x11(i,i-1) = cone x21(i,i-1) = cone - call stdlib_${ci}$larf( 'L', p-i+1, q-i+1, x11(i,i-1), 1,conjg(taup1(i)), x11(i,i), & + call stdlib${ii}$_${ci}$larf( 'L', p-i+1, q-i+1, x11(i,i-1), 1_${ik}$,conjg(taup1(i)), x11(i,i), & ldx11, work(ilarf) ) - call stdlib_${ci}$larf( 'L', m-p-i+1, q-i+1, x21(i,i-1), 1,conjg(taup2(i)), x21(i,i), & + call stdlib${ii}$_${ci}$larf( 'L', m-p-i+1, q-i+1, x21(i,i-1), 1_${ik}$,conjg(taup2(i)), x21(i,i), & ldx21, work(ilarf) ) end if - call stdlib_${ci}$drot( q-i+1, x11(i,i), ldx11, x21(i,i), ldx21, s, -c ) - call stdlib_${ci}$lacgv( q-i+1, x21(i,i), ldx21 ) - call stdlib_${ci}$larfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) + call stdlib${ii}$_${ci}$drot( q-i+1, x11(i,i), ldx11, x21(i,i), ldx21, s, -c ) + call stdlib${ii}$_${ci}$lacgv( q-i+1, x21(i,i), ldx21 ) + call stdlib${ii}$_${ci}$larfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) c = real( x21(i,i),KIND=${ck}$) x21(i,i) = cone - call stdlib_${ci}$larf( 'R', p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i+1,i), ldx11, & + call stdlib${ii}$_${ci}$larf( 'R', p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i+1,i), ldx11, & work(ilarf) ) - call stdlib_${ci}$larf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & + call stdlib${ii}$_${ci}$larf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & work(ilarf) ) - call stdlib_${ci}$lacgv( q-i+1, x21(i,i), ldx21 ) + call stdlib${ii}$_${ci}$lacgv( q-i+1, x21(i,i), ldx21 ) if( i < m-q ) then - s = sqrt( stdlib_${c2ri(ci)}$znrm2( p-i, x11(i+1,i), 1 )**2+ stdlib_${c2ri(ci)}$znrm2( m-p-i, x21(i+1,& - i), 1 )**2 ) + s = sqrt( stdlib${ii}$_${c2ri(ci)}$znrm2( p-i, x11(i+1,i), 1_${ik}$ )**2_${ik}$+ stdlib${ii}$_${c2ri(ci)}$znrm2( m-p-i, x21(i+1,& + i), 1_${ik}$ )**2_${ik}$ ) phi(i) = atan2( s, c ) end if end do ! reduce the bottom-right portion of x11 to [ i 0 ] do i = m - q + 1, p - call stdlib_${ci}$lacgv( q-i+1, x11(i,i), ldx11 ) - call stdlib_${ci}$larfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) + call stdlib${ii}$_${ci}$lacgv( q-i+1, x11(i,i), ldx11 ) + call stdlib${ii}$_${ci}$larfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) x11(i,i) = cone - call stdlib_${ci}$larf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & + call stdlib${ii}$_${ci}$larf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & work(ilarf) ) - call stdlib_${ci}$larf( 'R', q-p, q-i+1, x11(i,i), ldx11, tauq1(i),x21(m-q+1,i), ldx21, & + call stdlib${ii}$_${ci}$larf( 'R', q-p, q-i+1, x11(i,i), ldx11, tauq1(i),x21(m-q+1,i), ldx21, & work(ilarf) ) - call stdlib_${ci}$lacgv( q-i+1, x11(i,i), ldx11 ) + call stdlib${ii}$_${ci}$lacgv( q-i+1, x11(i,i), ldx11 ) end do ! reduce the bottom-right portion of x21 to [ 0 i ] do i = p + 1, q - call stdlib_${ci}$lacgv( q-i+1, x21(m-q+i-p,i), ldx21 ) - call stdlib_${ci}$larfgp( q-i+1, x21(m-q+i-p,i), x21(m-q+i-p,i+1), ldx21,tauq1(i) ) + call stdlib${ii}$_${ci}$lacgv( q-i+1, x21(m-q+i-p,i), ldx21 ) + call stdlib${ii}$_${ci}$larfgp( q-i+1, x21(m-q+i-p,i), x21(m-q+i-p,i+1), ldx21,tauq1(i) ) x21(m-q+i-p,i) = cone - call stdlib_${ci}$larf( 'R', q-i, q-i+1, x21(m-q+i-p,i), ldx21, tauq1(i),x21(m-q+i-p+1,i)& + call stdlib${ii}$_${ci}$larf( 'R', q-i, q-i+1, x21(m-q+i-p,i), ldx21, tauq1(i),x21(m-q+i-p+1,i)& , ldx21, work(ilarf) ) - call stdlib_${ci}$lacgv( q-i+1, x21(m-q+i-p,i), ldx21 ) + call stdlib${ii}$_${ci}$lacgv( q-i+1, x21(m-q+i-p,i), ldx21 ) end do return - end subroutine stdlib_${ci}$unbdb4 + end subroutine stdlib${ii}$_${ci}$unbdb4 - pure subroutine stdlib_${ci}$unbdb5( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & + pure subroutine stdlib${ii}$_${ci}$unbdb5( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & !! ZUNBDB5: orthogonalizes the column vector !! X = [ X1 ] !! [ X2 ] @@ -76782,8 +76773,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(in) :: q1(ldq1,*), q2(ldq2,*) complex(${ck}$), intent(out) :: work(*) @@ -76791,38 +76782,38 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! Local Scalars - integer(ilp) :: childinfo, i, j + integer(${ik}$) :: childinfo, i, j ! 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( 'ZUNBDB5', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZUNBDB5', -info ) return end if ! project x onto the orthogonal complement of q - call stdlib_${ci}$unbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2,work, lwork, & + call stdlib${ii}$_${ci}$unbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2,work, lwork, & childinfo ) ! if the projection is nonzero, then return - if( stdlib_${c2ri(ci)}$znrm2(m1,x1,incx1) /= czero.or. stdlib_${c2ri(ci)}$znrm2(m2,x2,incx2) /= czero ) & + if( stdlib${ii}$_${c2ri(ci)}$znrm2(m1,x1,incx1) /= czero.or. stdlib${ii}$_${c2ri(ci)}$znrm2(m2,x2,incx2) /= czero ) & then return end if @@ -76836,9 +76827,9 @@ module stdlib_linalg_lapack_${ci}$ do j = 1, m2 x2(j) = czero end do - call stdlib_${ci}$unbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & + call stdlib${ii}$_${ci}$unbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & lwork, childinfo ) - if( stdlib_${c2ri(ci)}$znrm2(m1,x1,incx1) /= czero.or. stdlib_${c2ri(ci)}$znrm2(m2,x2,incx2) /= czero ) & + if( stdlib${ii}$_${c2ri(ci)}$znrm2(m1,x1,incx1) /= czero.or. stdlib${ii}$_${c2ri(ci)}$znrm2(m2,x2,incx2) /= czero ) & then return end if @@ -76853,18 +76844,18 @@ module stdlib_linalg_lapack_${ci}$ x2(j) = czero end do x2(i) = cone - call stdlib_${ci}$unbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & + call stdlib${ii}$_${ci}$unbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & lwork, childinfo ) - if( stdlib_${c2ri(ci)}$znrm2(m1,x1,incx1) /= czero.or. stdlib_${c2ri(ci)}$znrm2(m2,x2,incx2) /= czero ) & + if( stdlib${ii}$_${c2ri(ci)}$znrm2(m1,x1,incx1) /= czero.or. stdlib${ii}$_${c2ri(ci)}$znrm2(m2,x2,incx2) /= czero ) & then return end if end do return - end subroutine stdlib_${ci}$unbdb5 + end subroutine stdlib${ii}$_${ci}$unbdb5 - pure subroutine stdlib_${ci}$unbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & + pure subroutine stdlib${ii}$_${ci}$unbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & !! ZUNBDB6: orthogonalizes the column vector !! X = [ X1 ] !! [ X2 ] @@ -76879,8 +76870,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(in) :: q1(ldq1,*), q2(ldq2,*) complex(${ck}$), intent(out) :: work(*) @@ -76893,60 +76884,60 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i real(${ck}$) :: 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( 'ZUNBDB6', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZUNBDB6', -info ) return end if ! first, project x onto the orthogonal complement of q's column ! space scl1 = realzero ssq1 = realone - call stdlib_${ci}$lassq( m1, x1, incx1, scl1, ssq1 ) + call stdlib${ii}$_${ci}$lassq( m1, x1, incx1, scl1, ssq1 ) scl2 = realzero ssq2 = realone - call stdlib_${ci}$lassq( m2, x2, incx2, scl2, ssq2 ) - normsq1 = scl1**2*ssq1 + scl2**2*ssq2 - if( m1 == 0 ) then + call stdlib${ii}$_${ci}$lassq( 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) = czero end do else - call stdlib_${ci}$gemv( 'C', m1, n, cone, q1, ldq1, x1, incx1, czero, work,1 ) + call stdlib${ii}$_${ci}$gemv( 'C', m1, n, cone, q1, ldq1, x1, incx1, czero, work,1_${ik}$ ) end if - call stdlib_${ci}$gemv( 'C', m2, n, cone, q2, ldq2, x2, incx2, cone, work, 1 ) - call stdlib_${ci}$gemv( 'N', m1, n, cnegone, q1, ldq1, work, 1, cone, x1,incx1 ) - call stdlib_${ci}$gemv( 'N', m2, n, cnegone, q2, ldq2, work, 1, cone, x2,incx2 ) + call stdlib${ii}$_${ci}$gemv( 'C', m2, n, cone, q2, ldq2, x2, incx2, cone, work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$gemv( 'N', m1, n, cnegone, q1, ldq1, work, 1_${ik}$, cone, x1,incx1 ) + call stdlib${ii}$_${ci}$gemv( 'N', m2, n, cnegone, q2, ldq2, work, 1_${ik}$, cone, x2,incx2 ) scl1 = realzero ssq1 = realone - call stdlib_${ci}$lassq( m1, x1, incx1, scl1, ssq1 ) + call stdlib${ii}$_${ci}$lassq( m1, x1, incx1, scl1, ssq1 ) scl2 = realzero ssq2 = realone - call stdlib_${ci}$lassq( m2, x2, incx2, scl2, ssq2 ) - normsq2 = scl1**2*ssq1 + scl2**2*ssq2 + call stdlib${ii}$_${ci}$lassq( 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 czero, then stop. ! otherwise, project again. @@ -76960,23 +76951,23 @@ module stdlib_linalg_lapack_${ci}$ do i = 1, n work(i) = czero end do - if( m1 == 0 ) then + if( m1 == 0_${ik}$ ) then do i = 1, n work(i) = czero end do else - call stdlib_${ci}$gemv( 'C', m1, n, cone, q1, ldq1, x1, incx1, czero, work,1 ) + call stdlib${ii}$_${ci}$gemv( 'C', m1, n, cone, q1, ldq1, x1, incx1, czero, work,1_${ik}$ ) end if - call stdlib_${ci}$gemv( 'C', m2, n, cone, q2, ldq2, x2, incx2, cone, work, 1 ) - call stdlib_${ci}$gemv( 'N', m1, n, cnegone, q1, ldq1, work, 1, cone, x1,incx1 ) - call stdlib_${ci}$gemv( 'N', m2, n, cnegone, q2, ldq2, work, 1, cone, x2,incx2 ) + call stdlib${ii}$_${ci}$gemv( 'C', m2, n, cone, q2, ldq2, x2, incx2, cone, work, 1_${ik}$ ) + call stdlib${ii}$_${ci}$gemv( 'N', m1, n, cnegone, q1, ldq1, work, 1_${ik}$, cone, x1,incx1 ) + call stdlib${ii}$_${ci}$gemv( 'N', m2, n, cnegone, q2, ldq2, work, 1_${ik}$, cone, x2,incx2 ) scl1 = realzero ssq1 = realone - call stdlib_${ci}$lassq( m1, x1, incx1, scl1, ssq1 ) + call stdlib${ii}$_${ci}$lassq( m1, x1, incx1, scl1, ssq1 ) scl2 = realzero ssq2 = realone - call stdlib_${ci}$lassq( m1, x1, incx1, scl1, ssq1 ) - normsq2 = scl1**2*ssq1 + scl2**2*ssq2 + call stdlib${ii}$_${ci}$lassq( 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 czero. @@ -76989,10 +76980,10 @@ module stdlib_linalg_lapack_${ci}$ end do end if return - end subroutine stdlib_${ci}$unbdb6 + end subroutine stdlib${ii}$_${ci}$unbdb6 - recursive subroutine stdlib_${ci}$uncsd( jobu1, jobu2, jobv1t, jobv2t, trans,signs, m, p, q, x11, & + recursive subroutine stdlib${ii}$_${ci}$uncsd( jobu1, jobu2, jobv1t, jobv2t, trans,signs, m, p, q, x11, & !! ZUNCSD: computes the CS decomposition of an M-by-M partitioned !! unitary matrix X: !! [ I 0 0 | 0 0 0 ] @@ -77013,11 +77004,11 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobu1, jobu2, jobv1t, jobv2t, signs, trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldu1, ldu2, ldv1t, ldv2t, ldx11, ldx12, ldx21, ldx22, & + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldu1, ldu2, ldv1t, ldv2t, ldx11, ldx12, ldx21, ldx22, & lrwork, lwork, m, p, q ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(${ck}$), intent(out) :: theta(*) real(${ck}$), intent(out) :: rwork(*) complex(${ck}$), intent(out) :: u1(ldu1,*), u2(ldu2,*), v1t(ldv1t,*), v2t(ldv2t,*), work(*) @@ -77028,60 +77019,60 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars character :: transt, signst - integer(ilp) :: childinfo, i, ib11d, ib11e, ib12d, ib12e, ib21d, ib21e, ib22d, ib22e, & + integer(${ik}$) :: childinfo, i, ib11d, ib11e, ib12d, ib12e, ib21d, ib21e, ib22d, ib22e, & ibbcsd, iorbdb, iorglq, iorgqr, iphi, itaup1, itaup2, itauq1, itauq2, j, lbbcsdwork, & lbbcsdworkmin, lbbcsdworkopt, lorbdbwork, lorbdbworkmin, lorbdbworkopt, lorglqwork, & lorglqworkmin, lorglqworkopt, lorgqrwork, lorgqrworkmin, lorgqrworkopt, lworkmin, & lworkopt, p1, q1 logical(lk) :: colmajor, defaultsigns, lquery, wantu1, wantu2, wantv1t, wantv2t - integer(ilp) :: lrworkmin, lrworkopt + integer(${ik}$) :: lrworkmin, lrworkopt logical(lk) :: lrquery ! Intrinsic Functions intrinsic :: int,max,min ! Executable Statements ! test input arguments - info = 0 + info = 0_${ik}$ wantu1 = stdlib_lsame( jobu1, 'Y' ) wantu2 = stdlib_lsame( jobu2, 'Y' ) wantv1t = stdlib_lsame( jobv1t, 'Y' ) wantv2t = stdlib_lsame( jobv2t, 'Y' ) colmajor = .not. stdlib_lsame( trans, 'T' ) defaultsigns = .not. stdlib_lsame( signs, 'O' ) - lquery = lwork == -1 - lrquery = lrwork == -1 - if( m < 0 ) then - info = -7 - else if( p < 0 .or. p > m ) then - info = -8 - else if( q < 0 .or. q > m ) then - info = -9 - else if ( colmajor .and. ldx11 < max( 1, p ) ) then - info = -11 - else if (.not. colmajor .and. ldx11 < max( 1, q ) ) then - info = -11 - else if (colmajor .and. ldx12 < max( 1, p ) ) then - info = -13 - else if (.not. colmajor .and. ldx12 < max( 1, m-q ) ) then - info = -13 - else if (colmajor .and. ldx21 < max( 1, m-p ) ) then - info = -15 - else if (.not. colmajor .and. ldx21 < max( 1, q ) ) then - info = -15 - else if (colmajor .and. ldx22 < max( 1, m-p ) ) then - info = -17 - else if (.not. colmajor .and. ldx22 < max( 1, m-q ) ) then - info = -17 + lquery = lwork == -1_${ik}$ + lrquery = lrwork == -1_${ik}$ + if( m < 0_${ik}$ ) then + info = -7_${ik}$ + else if( p < 0_${ik}$ .or. p > m ) then + info = -8_${ik}$ + else if( q < 0_${ik}$ .or. q > m ) then + info = -9_${ik}$ + else if ( colmajor .and. ldx11 < max( 1_${ik}$, p ) ) then + info = -11_${ik}$ + else if (.not. colmajor .and. ldx11 < max( 1_${ik}$, q ) ) then + info = -11_${ik}$ + else if (colmajor .and. ldx12 < max( 1_${ik}$, p ) ) then + info = -13_${ik}$ + else if (.not. colmajor .and. ldx12 < max( 1_${ik}$, m-q ) ) then + info = -13_${ik}$ + else if (colmajor .and. ldx21 < max( 1_${ik}$, m-p ) ) then + info = -15_${ik}$ + else if (.not. colmajor .and. ldx21 < max( 1_${ik}$, q ) ) then + info = -15_${ik}$ + else if (colmajor .and. ldx22 < max( 1_${ik}$, m-p ) ) then + info = -17_${ik}$ + else if (.not. colmajor .and. ldx22 < max( 1_${ik}$, m-q ) ) then + info = -17_${ik}$ else if( wantu1 .and. ldu1 < p ) then - info = -20 + info = -20_${ik}$ else if( wantu2 .and. ldu2 < m-p ) then - info = -22 + info = -22_${ik}$ else if( wantv1t .and. ldv1t < q ) then - info = -24 + info = -24_${ik}$ else if( wantv2t .and. ldv2t < m-q ) then - info = -26 + info = -26_${ik}$ end if ! work with transpose if convenient - if( info == 0 .and. min( p, m-p ) < min( q, m-q ) ) then + if( info == 0_${ik}$ .and. min( p, m-p ) < min( q, m-q ) ) then if( colmajor ) then transt = 'T' else @@ -77092,158 +77083,158 @@ module stdlib_linalg_lapack_${ci}$ else signst = 'D' end if - call stdlib_${ci}$uncsd( jobv1t, jobv2t, jobu1, jobu2, transt, signst, m,q, p, x11, & + call stdlib${ii}$_${ci}$uncsd( jobv1t, jobv2t, jobu1, jobu2, transt, signst, m,q, p, x11, & ldx11, x21, ldx21, x12, ldx12, x22,ldx22, theta, v1t, ldv1t, v2t, ldv2t, u1, ldu1,& u2, ldu2, work, lwork, rwork, lrwork, iwork,info ) return end if ! work with permutation [ 0 i; i 0 ] * x * [ 0 i; i 0 ] if ! convenient - if( info == 0 .and. m-q < q ) then + if( info == 0_${ik}$ .and. m-q < q ) then if( defaultsigns ) then signst = 'O' else signst = 'D' end if - call stdlib_${ci}$uncsd( jobu2, jobu1, jobv2t, jobv1t, trans, signst, m,m-p, m-q, x22, & + call stdlib${ii}$_${ci}$uncsd( jobu2, jobu1, jobv2t, jobv1t, trans, signst, m,m-p, m-q, x22, & ldx22, x21, ldx21, x12, ldx12, x11,ldx11, theta, u2, ldu2, u1, ldu1, v2t, ldv2t, & v1t,ldv1t, work, lwork, rwork, lrwork, iwork, info ) return end if ! compute workspace - if( info == 0 ) then + if( info == 0_${ik}$ ) then ! real workspace - iphi = 2 - ib11d = iphi + max( 1, q - 1 ) - ib11e = ib11d + max( 1, q ) - ib12d = ib11e + max( 1, q - 1 ) - ib12e = ib12d + max( 1, q ) - ib21d = ib12e + max( 1, q - 1 ) - ib21e = ib21d + max( 1, q ) - ib22d = ib21e + max( 1, q - 1 ) - ib22e = ib22d + max( 1, q ) - ibbcsd = ib22e + max( 1, q - 1 ) - call stdlib_${ci}$bbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, theta, u1, & + iphi = 2_${ik}$ + ib11d = iphi + max( 1_${ik}$, q - 1_${ik}$ ) + ib11e = ib11d + max( 1_${ik}$, q ) + ib12d = ib11e + max( 1_${ik}$, q - 1_${ik}$ ) + ib12e = ib12d + max( 1_${ik}$, q ) + ib21d = ib12e + max( 1_${ik}$, q - 1_${ik}$ ) + ib21e = ib21d + max( 1_${ik}$, q ) + ib22d = ib21e + max( 1_${ik}$, q - 1_${ik}$ ) + ib22e = ib22d + max( 1_${ik}$, q ) + ibbcsd = ib22e + max( 1_${ik}$, q - 1_${ik}$ ) + call stdlib${ii}$_${ci}$bbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, theta, u1, & ldu1, u2, ldu2, v1t, ldv1t,v2t, ldv2t, theta, theta, theta, theta, theta,theta, & - theta, theta, rwork, -1, childinfo ) - lbbcsdworkopt = int( rwork(1),KIND=ilp) + theta, theta, rwork, -1_${ik}$, childinfo ) + lbbcsdworkopt = int( rwork(1_${ik}$),KIND=${ik}$) lbbcsdworkmin = lbbcsdworkopt - lrworkopt = ibbcsd + lbbcsdworkopt - 1 - lrworkmin = ibbcsd + lbbcsdworkmin - 1 - rwork(1) = lrworkopt + lrworkopt = ibbcsd + lbbcsdworkopt - 1_${ik}$ + lrworkmin = ibbcsd + lbbcsdworkmin - 1_${ik}$ + rwork(1_${ik}$) = lrworkopt ! complex workspace - itaup1 = 2 - itaup2 = itaup1 + max( 1, p ) - itauq1 = itaup2 + max( 1, m - p ) - itauq2 = itauq1 + max( 1, q ) - iorgqr = itauq2 + max( 1, m - q ) - call stdlib_${ci}$ungqr( m-q, m-q, m-q, u1, max(1,m-q), u1, work, -1,childinfo ) - lorgqrworkopt = int( work(1),KIND=ilp) - lorgqrworkmin = max( 1, m - q ) - iorglq = itauq2 + max( 1, m - q ) - call stdlib_${ci}$unglq( m-q, m-q, m-q, u1, max(1,m-q), u1, work, -1,childinfo ) - lorglqworkopt = int( work(1),KIND=ilp) - lorglqworkmin = max( 1, m - q ) - iorbdb = itauq2 + max( 1, m - q ) - call stdlib_${ci}$unbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & - ldx22, theta, theta, u1, u2,v1t, v2t, work, -1, childinfo ) - lorbdbworkopt = int( work(1),KIND=ilp) + itaup1 = 2_${ik}$ + itaup2 = itaup1 + max( 1_${ik}$, p ) + itauq1 = itaup2 + max( 1_${ik}$, m - p ) + itauq2 = itauq1 + max( 1_${ik}$, q ) + iorgqr = itauq2 + max( 1_${ik}$, m - q ) + call stdlib${ii}$_${ci}$ungqr( m-q, m-q, m-q, u1, max(1_${ik}$,m-q), u1, work, -1_${ik}$,childinfo ) + lorgqrworkopt = int( work(1_${ik}$),KIND=${ik}$) + lorgqrworkmin = max( 1_${ik}$, m - q ) + iorglq = itauq2 + max( 1_${ik}$, m - q ) + call stdlib${ii}$_${ci}$unglq( m-q, m-q, m-q, u1, max(1_${ik}$,m-q), u1, work, -1_${ik}$,childinfo ) + lorglqworkopt = int( work(1_${ik}$),KIND=${ik}$) + lorglqworkmin = max( 1_${ik}$, m - q ) + iorbdb = itauq2 + max( 1_${ik}$, m - q ) + call stdlib${ii}$_${ci}$unbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & + ldx22, theta, theta, u1, u2,v1t, v2t, work, -1_${ik}$, childinfo ) + lorbdbworkopt = int( work(1_${ik}$),KIND=${ik}$) lorbdbworkmin = lorbdbworkopt lworkopt = max( iorgqr + lorgqrworkopt, iorglq + lorglqworkopt,iorbdb + & - lorbdbworkopt ) - 1 + lorbdbworkopt ) - 1_${ik}$ lworkmin = max( iorgqr + lorgqrworkmin, iorglq + lorglqworkmin,iorbdb + & - lorbdbworkmin ) - 1 - work(1) = max(lworkopt,lworkmin) + lorbdbworkmin ) - 1_${ik}$ + work(1_${ik}$) = max(lworkopt,lworkmin) if( lwork < lworkmin.and. .not. ( lquery .or. lrquery ) ) then - info = -22 + info = -22_${ik}$ else if( lrwork < lrworkmin.and. .not. ( lquery .or. lrquery ) ) then - info = -24 + info = -24_${ik}$ else - lorgqrwork = lwork - iorgqr + 1 - lorglqwork = lwork - iorglq + 1 - lorbdbwork = lwork - iorbdb + 1 - lbbcsdwork = lrwork - ibbcsd + 1 + lorgqrwork = lwork - iorgqr + 1_${ik}$ + lorglqwork = lwork - iorglq + 1_${ik}$ + lorbdbwork = lwork - iorbdb + 1_${ik}$ + lbbcsdwork = lrwork - ibbcsd + 1_${ik}$ end if end if ! abort if any illegal arguments - if( info /= 0 ) then - call stdlib_xerbla( 'ZUNCSD', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZUNCSD', -info ) return else if( lquery .or. lrquery ) then return end if ! transform to bidiagonal block form - call stdlib_${ci}$unbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12, x21,ldx21, x22, & + call stdlib${ii}$_${ci}$unbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12, x21,ldx21, x22, & ldx22, theta, rwork(iphi), work(itaup1),work(itaup2), work(itauq1), work(itauq2),work(& iorbdb), lorbdbwork, childinfo ) ! accumulate householder reflectors if( colmajor ) then - if( wantu1 .and. p > 0 ) then - call stdlib_${ci}$lacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) - call stdlib_${ci}$ungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqrwork, & + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) + call stdlib${ii}$_${ci}$ungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqrwork, & info) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_${ci}$lacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) - call stdlib_${ci}$ungqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqrwork,& + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) + call stdlib${ii}$_${ci}$ungqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqrwork,& info ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_${ci}$lacpy( 'U', q-1, q-1, x11(1,2), ldx11, v1t(2,2),ldv1t ) - v1t(1, 1) = cone + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'U', q-1, q-1, x11(1_${ik}$,2_${ik}$), ldx11, v1t(2_${ik}$,2_${ik}$),ldv1t ) + v1t(1_${ik}$, 1_${ik}$) = cone do j = 2, q - v1t(1,j) = czero - v1t(j,1) = czero + v1t(1_${ik}$,j) = czero + v1t(j,1_${ik}$) = czero end do - call stdlib_${ci}$unglq( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),work(iorglq), & + call stdlib${ii}$_${ci}$unglq( q-1, q-1, q-1, v1t(2_${ik}$,2_${ik}$), ldv1t, work(itauq1),work(iorglq), & lorglqwork, info ) end if - if( wantv2t .and. m-q > 0 ) then - call stdlib_${ci}$lacpy( 'U', p, m-q, x12, ldx12, v2t, ldv2t ) + if( wantv2t .and. m-q > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'U', p, m-q, x12, ldx12, v2t, ldv2t ) if( m-p > q) then - call stdlib_${ci}$lacpy( 'U', m-p-q, m-p-q, x22(q+1,p+1), ldx22,v2t(p+1,p+1), & + call stdlib${ii}$_${ci}$lacpy( 'U', m-p-q, m-p-q, x22(q+1,p+1), ldx22,v2t(p+1,p+1), & ldv2t ) end if if( m > q ) then - call stdlib_${ci}$unglq( m-q, m-q, m-q, v2t, ldv2t, work(itauq2),work(iorglq), & + call stdlib${ii}$_${ci}$unglq( m-q, m-q, m-q, v2t, ldv2t, work(itauq2),work(iorglq), & lorglqwork, info ) end if end if else - if( wantu1 .and. p > 0 ) then - call stdlib_${ci}$lacpy( 'U', q, p, x11, ldx11, u1, ldu1 ) - call stdlib_${ci}$unglq( p, p, q, u1, ldu1, work(itaup1), work(iorglq),lorglqwork, & + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'U', q, p, x11, ldx11, u1, ldu1 ) + call stdlib${ii}$_${ci}$unglq( p, p, q, u1, ldu1, work(itaup1), work(iorglq),lorglqwork, & info) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_${ci}$lacpy( 'U', q, m-p, x21, ldx21, u2, ldu2 ) - call stdlib_${ci}$unglq( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorglq), lorglqwork,& + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'U', q, m-p, x21, ldx21, u2, ldu2 ) + call stdlib${ii}$_${ci}$unglq( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorglq), lorglqwork,& info ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_${ci}$lacpy( 'L', q-1, q-1, x11(2,1), ldx11, v1t(2,2),ldv1t ) - v1t(1, 1) = cone + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'L', q-1, q-1, x11(2_${ik}$,1_${ik}$), ldx11, v1t(2_${ik}$,2_${ik}$),ldv1t ) + v1t(1_${ik}$, 1_${ik}$) = cone do j = 2, q - v1t(1,j) = czero - v1t(j,1) = czero + v1t(1_${ik}$,j) = czero + v1t(j,1_${ik}$) = czero end do - call stdlib_${ci}$ungqr( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),work(iorgqr), & + call stdlib${ii}$_${ci}$ungqr( q-1, q-1, q-1, v1t(2_${ik}$,2_${ik}$), ldv1t, work(itauq1),work(iorgqr), & lorgqrwork, info ) end if - if( wantv2t .and. m-q > 0 ) then + if( wantv2t .and. m-q > 0_${ik}$ ) then p1 = min( p+1, m ) q1 = min( q+1, m ) - call stdlib_${ci}$lacpy( 'L', m-q, p, x12, ldx12, v2t, ldv2t ) + call stdlib${ii}$_${ci}$lacpy( 'L', m-q, p, x12, ldx12, v2t, ldv2t ) if( m > p+q ) then - call stdlib_${ci}$lacpy( 'L', m-p-q, m-p-q, x22(p1,q1), ldx22,v2t(p+1,p+1), ldv2t ) + call stdlib${ii}$_${ci}$lacpy( 'L', m-p-q, m-p-q, x22(p1,q1), ldx22,v2t(p+1,p+1), ldv2t ) end if - call stdlib_${ci}$ungqr( m-q, m-q, m-q, v2t, ldv2t, work(itauq2),work(iorgqr), & + call stdlib${ii}$_${ci}$ungqr( m-q, m-q, m-q, v2t, ldv2t, work(itauq2),work(iorgqr), & lorgqrwork, info ) end if end if ! compute the csd of the matrix in bidiagonal-block form - call stdlib_${ci}$bbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q, theta,rwork(iphi), & + call stdlib${ii}$_${ci}$bbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q, theta,rwork(iphi), & u1, ldu1, u2, ldu2, v1t, ldv1t, v2t,ldv2t, rwork(ib11d), rwork(ib11e), rwork(ib12d),& rwork(ib12e), rwork(ib21d), rwork(ib21e),rwork(ib22d), rwork(ib22e), rwork(ibbcsd),& lbbcsdwork, info ) @@ -77251,7 +77242,7 @@ module stdlib_linalg_lapack_${ci}$ ! left corner of (1,1)-block and/or bottom-right corner of (1,2)- ! block and/or bottom-right corner of (2,1)-block and/or top-left ! corner of (2,2)-block - if( q > 0 .and. wantu2 ) then + if( q > 0_${ik}$ .and. wantu2 ) then do i = 1, q iwork(i) = m - p - q + i end do @@ -77259,12 +77250,12 @@ module stdlib_linalg_lapack_${ci}$ iwork(i) = i - q end do if( colmajor ) then - call stdlib_${ci}$lapmt( .false., m-p, m-p, u2, ldu2, iwork ) + call stdlib${ii}$_${ci}$lapmt( .false., m-p, m-p, u2, ldu2, iwork ) else - call stdlib_${ci}$lapmr( .false., m-p, m-p, u2, ldu2, iwork ) + call stdlib${ii}$_${ci}$lapmr( .false., m-p, m-p, u2, ldu2, iwork ) end if end if - if( m > 0 .and. wantv2t ) then + if( m > 0_${ik}$ .and. wantv2t ) then do i = 1, p iwork(i) = m - p - q + i end do @@ -77272,17 +77263,17 @@ module stdlib_linalg_lapack_${ci}$ iwork(i) = i - p end do if( .not. colmajor ) then - call stdlib_${ci}$lapmt( .false., m-q, m-q, v2t, ldv2t, iwork ) + call stdlib${ii}$_${ci}$lapmt( .false., m-q, m-q, v2t, ldv2t, iwork ) else - call stdlib_${ci}$lapmr( .false., m-q, m-q, v2t, ldv2t, iwork ) + call stdlib${ii}$_${ci}$lapmr( .false., m-q, m-q, v2t, ldv2t, iwork ) end if end if return - ! end stdlib_${ci}$uncsd - end subroutine stdlib_${ci}$uncsd + ! end stdlib${ii}$_${ci}$uncsd + end subroutine stdlib${ii}$_${ci}$uncsd - subroutine stdlib_${ci}$uncsd2by1( jobu1, jobu2, jobv1t, m, p, q, x11, ldx11,x21, ldx21, theta, & + subroutine stdlib${ii}$_${ci}$uncsd2by1( jobu1, jobu2, jobv1t, m, p, q, x11, ldx11,x21, ldx21, theta, & !! ZUNCSD2BY1: computes the CS decomposition of an M-by-Q matrix X with !! orthonormal columns that has been partitioned into a 2-by-1 block !! structure: @@ -77304,52 +77295,52 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobu1, jobu2, jobv1t - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldu1, ldu2, ldv1t, lwork, ldx11, ldx21, m, p, q - integer(ilp), intent(in) :: lrwork - integer(ilp) :: lrworkmin, lrworkopt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldu1, ldu2, ldv1t, lwork, ldx11, ldx21, m, p, q + integer(${ik}$), intent(in) :: lrwork + integer(${ik}$) :: lrworkmin, lrworkopt ! Array Arguments real(${ck}$), intent(out) :: rwork(*) real(${ck}$), intent(out) :: theta(*) complex(${ck}$), intent(out) :: u1(ldu1,*), u2(ldu2,*), v1t(ldv1t,*), work(*) complex(${ck}$), intent(inout) :: x11(ldx11,*), x21(ldx21,*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: childinfo, i, ib11d, ib11e, ib12d, ib12e, ib21d, ib21e, ib22d, ib22e, & + integer(${ik}$) :: childinfo, i, ib11d, ib11e, ib12d, ib12e, ib21d, ib21e, ib22d, ib22e, & ibbcsd, iorbdb, iorglq, iorgqr, iphi, itaup1, itaup2, itauq1, j, lbbcsd, lorbdb, & lorglq, lorglqmin, lorglqopt, lorgqr, lorgqrmin, lorgqropt, lworkmin, lworkopt, & r logical(lk) :: lquery, wantu1, wantu2, wantv1t ! Local Arrays - real(${ck}$) :: dum(1) - complex(${ck}$) :: cdum(1,1) + real(${ck}$) :: dum(1_${ik}$) + complex(${ck}$) :: cdum(1_${ik}$,1_${ik}$) ! Intrinsic Function intrinsic :: int,max,min ! Executable Statements ! test input arguments - info = 0 + info = 0_${ik}$ wantu1 = stdlib_lsame( jobu1, 'Y' ) wantu2 = stdlib_lsame( jobu2, 'Y' ) wantv1t = stdlib_lsame( jobv1t, 'Y' ) - lquery = ( lwork==-1 ) .or. ( lrwork==-1 ) - if( m < 0 ) then - info = -4 - else if( p < 0 .or. p > m ) then - info = -5 - else if( q < 0 .or. q > m ) then - info = -6 - else if( ldx11 < max( 1, p ) ) then - info = -8 - else if( ldx21 < max( 1, m-p ) ) then - info = -10 - else if( wantu1 .and. ldu1 < max( 1, p ) ) then - info = -13 - else if( wantu2 .and. ldu2 < max( 1, m - p ) ) then - info = -15 - else if( wantv1t .and. ldv1t < max( 1, q ) ) then - info = -17 + lquery = ( lwork==-1_${ik}$ ) .or. ( lrwork==-1_${ik}$ ) + if( m < 0_${ik}$ ) then + info = -4_${ik}$ + else if( p < 0_${ik}$ .or. p > m ) then + info = -5_${ik}$ + else if( q < 0_${ik}$ .or. q > m ) then + info = -6_${ik}$ + else if( ldx11 < max( 1_${ik}$, p ) ) then + info = -8_${ik}$ + else if( ldx21 < max( 1_${ik}$, m-p ) ) then + info = -10_${ik}$ + else if( wantu1 .and. ldu1 < max( 1_${ik}$, p ) ) then + info = -13_${ik}$ + else if( wantu2 .and. ldu2 < max( 1_${ik}$, m - p ) ) then + info = -15_${ik}$ + else if( wantv1t .and. ldv1t < max( 1_${ik}$, q ) ) then + info = -17_${ik}$ end if r = min( p, m-p, q, m-q ) ! compute workspace @@ -77361,7 +77352,7 @@ module stdlib_linalg_lapack_${ci}$ ! | taup2 (max(1,m-p)) | ! | tauq1 (max(1,q)) | ! |-----------------------------------------| - ! | stdlib_${ci}$unbdb work | stdlib_${ci}$ungqr work | stdlib_${ci}$unglq work | + ! | stdlib${ii}$_${ci}$unbdb work | stdlib${ii}$_${ci}$ungqr work | stdlib${ii}$_${ci}$unglq work | ! | | | | ! | | | | ! | | | | @@ -77381,143 +77372,143 @@ module stdlib_linalg_lapack_${ci}$ ! | b21e (r-1) | ! | b22d (r) | ! | b22e (r-1) | - ! | stdlib_${ci}$bbcsd rwork | + ! | stdlib${ii}$_${ci}$bbcsd rwork | ! |------------------| - if( info == 0 ) then - iphi = 2 - ib11d = iphi + max( 1, r-1 ) - ib11e = ib11d + max( 1, r ) - ib12d = ib11e + max( 1, r - 1 ) - ib12e = ib12d + max( 1, r ) - ib21d = ib12e + max( 1, r - 1 ) - ib21e = ib21d + max( 1, r ) - ib22d = ib21e + max( 1, r - 1 ) - ib22e = ib22d + max( 1, r ) - ibbcsd = ib22e + max( 1, r - 1 ) - itaup1 = 2 - itaup2 = itaup1 + max( 1, p ) - itauq1 = itaup2 + max( 1, m-p ) - iorbdb = itauq1 + max( 1, q ) - iorgqr = itauq1 + max( 1, q ) - iorglq = itauq1 + max( 1, q ) - lorgqrmin = 1 - lorgqropt = 1 - lorglqmin = 1 - lorglqopt = 1 + if( info == 0_${ik}$ ) then + iphi = 2_${ik}$ + ib11d = iphi + max( 1_${ik}$, r-1 ) + ib11e = ib11d + max( 1_${ik}$, r ) + ib12d = ib11e + max( 1_${ik}$, r - 1_${ik}$ ) + ib12e = ib12d + max( 1_${ik}$, r ) + ib21d = ib12e + max( 1_${ik}$, r - 1_${ik}$ ) + ib21e = ib21d + max( 1_${ik}$, r ) + ib22d = ib21e + max( 1_${ik}$, r - 1_${ik}$ ) + ib22e = ib22d + max( 1_${ik}$, r ) + ibbcsd = ib22e + max( 1_${ik}$, r - 1_${ik}$ ) + itaup1 = 2_${ik}$ + itaup2 = itaup1 + max( 1_${ik}$, p ) + itauq1 = itaup2 + max( 1_${ik}$, m-p ) + iorbdb = itauq1 + max( 1_${ik}$, q ) + iorgqr = itauq1 + max( 1_${ik}$, q ) + iorglq = itauq1 + max( 1_${ik}$, q ) + lorgqrmin = 1_${ik}$ + lorgqropt = 1_${ik}$ + lorglqmin = 1_${ik}$ + lorglqopt = 1_${ik}$ if( r == q ) then - call stdlib_${ci}$unbdb1( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & - cdum, work, -1, childinfo ) - lorbdb = int( work(1),KIND=ilp) - if( wantu1 .and. p > 0 ) then - call stdlib_${ci}$ungqr( p, p, q, u1, ldu1, cdum, work(1), -1,childinfo ) + call stdlib${ii}$_${ci}$unbdb1( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & + cdum, work, -1_${ik}$, childinfo ) + lorbdb = int( work(1_${ik}$),KIND=${ik}$) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$ungqr( p, p, q, u1, ldu1, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) endif - if( wantu2 .and. m-p > 0 ) then - call stdlib_${ci}$ungqr( m-p, m-p, q, u2, ldu2, cdum, work(1), -1,childinfo ) + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$ungqr( m-p, m-p, q, u2, ldu2, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, m-p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_${ci}$unglq( q-1, q-1, q-1, v1t, ldv1t,cdum, work(1), -1, childinfo ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$unglq( q-1, q-1, q-1, v1t, ldv1t,cdum, work(1_${ik}$), -1_${ik}$, childinfo ) lorglqmin = max( lorglqmin, q-1 ) - lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) + lorglqopt = max( lorglqopt, int( work(1_${ik}$),KIND=${ik}$) ) end if - call stdlib_${ci}$bbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,dum, u1, ldu1,& - u2, ldu2, v1t, ldv1t, cdum, 1,dum, dum, dum, dum, dum, dum, dum, dum,rwork(1), -& - 1, childinfo ) - lbbcsd = int( rwork(1),KIND=ilp) + call stdlib${ii}$_${ci}$bbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,dum, u1, ldu1,& + u2, ldu2, v1t, ldv1t, cdum, 1_${ik}$,dum, dum, dum, dum, dum, dum, dum, dum,rwork(1_${ik}$), -& + 1_${ik}$, childinfo ) + lbbcsd = int( rwork(1_${ik}$),KIND=${ik}$) else if( r == p ) then - call stdlib_${ci}$unbdb2( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & - cdum, work(1), -1, childinfo ) - lorbdb = int( work(1),KIND=ilp) - if( wantu1 .and. p > 0 ) then - call stdlib_${ci}$ungqr( p-1, p-1, p-1, u1(2,2), ldu1, cdum, work(1),-1, childinfo & + call stdlib${ii}$_${ci}$unbdb2( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & + cdum, work(1_${ik}$), -1_${ik}$, childinfo ) + lorbdb = int( work(1_${ik}$),KIND=${ik}$) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$ungqr( p-1, p-1, p-1, u1(2_${ik}$,2_${ik}$), ldu1, cdum, work(1_${ik}$),-1_${ik}$, childinfo & ) lorgqrmin = max( lorgqrmin, p-1 ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_${ci}$ungqr( m-p, m-p, q, u2, ldu2, cdum, work(1), -1,childinfo ) + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$ungqr( m-p, m-p, q, u2, ldu2, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, m-p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_${ci}$unglq( q, q, r, v1t, ldv1t, cdum, work(1), -1,childinfo ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$unglq( q, q, r, v1t, ldv1t, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorglqmin = max( lorglqmin, q ) - lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) + lorglqopt = max( lorglqopt, int( work(1_${ik}$),KIND=${ik}$) ) end if - call stdlib_${ci}$bbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,dum, v1t, & - ldv1t, cdum, 1, u1, ldu1, u2, ldu2,dum, dum, dum, dum, dum, dum, dum, dum,rwork(& - 1), -1, childinfo ) - lbbcsd = int( rwork(1),KIND=ilp) + call stdlib${ii}$_${ci}$bbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,dum, v1t, & + ldv1t, cdum, 1_${ik}$, u1, ldu1, u2, ldu2,dum, dum, dum, dum, dum, dum, dum, dum,rwork(& + 1_${ik}$), -1_${ik}$, childinfo ) + lbbcsd = int( rwork(1_${ik}$),KIND=${ik}$) else if( r == m-p ) then - call stdlib_${ci}$unbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & - cdum, work(1), -1, childinfo ) - lorbdb = int( work(1),KIND=ilp) - if( wantu1 .and. p > 0 ) then - call stdlib_${ci}$ungqr( p, p, q, u1, ldu1, cdum, work(1), -1,childinfo ) + call stdlib${ii}$_${ci}$unbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & + cdum, work(1_${ik}$), -1_${ik}$, childinfo ) + lorbdb = int( work(1_${ik}$),KIND=${ik}$) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$ungqr( p, p, q, u1, ldu1, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_${ci}$ungqr( m-p-1, m-p-1, m-p-1, u2(2,2), ldu2, cdum,work(1), -1, & + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$ungqr( m-p-1, m-p-1, m-p-1, u2(2_${ik}$,2_${ik}$), ldu2, cdum,work(1_${ik}$), -1_${ik}$, & childinfo ) lorgqrmin = max( lorgqrmin, m-p-1 ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_${ci}$unglq( q, q, r, v1t, ldv1t, cdum, work(1), -1,childinfo ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$unglq( q, q, r, v1t, ldv1t, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorglqmin = max( lorglqmin, q ) - lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) - end if - call stdlib_${ci}$bbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, dum, cdum,& - 1, v1t, ldv1t, u2, ldu2, u1,ldu1, dum, dum, dum, dum, dum, dum, dum, dum,rwork(& - 1), -1, childinfo ) - lbbcsd = int( rwork(1),KIND=ilp) - else - call stdlib_${ci}$unbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & - cdum, cdum, work(1), -1, childinfo) - lorbdb = m + int( work(1),KIND=ilp) - if( wantu1 .and. p > 0 ) then - call stdlib_${ci}$ungqr( p, p, m-q, u1, ldu1, cdum, work(1), -1,childinfo ) + lorglqopt = max( lorglqopt, int( work(1_${ik}$),KIND=${ik}$) ) + end if + call stdlib${ii}$_${ci}$bbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, dum, cdum,& + 1_${ik}$, v1t, ldv1t, u2, ldu2, u1,ldu1, dum, dum, dum, dum, dum, dum, dum, dum,rwork(& + 1_${ik}$), -1_${ik}$, childinfo ) + lbbcsd = int( rwork(1_${ik}$),KIND=${ik}$) + else + call stdlib${ii}$_${ci}$unbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & + cdum, cdum, work(1_${ik}$), -1_${ik}$, childinfo) + lorbdb = m + int( work(1_${ik}$),KIND=${ik}$) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$ungqr( p, p, m-q, u1, ldu1, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_${ci}$ungqr( m-p, m-p, m-q, u2, ldu2, cdum, work(1), -1,childinfo ) + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$ungqr( m-p, m-p, m-q, u2, ldu2, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, m-p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_${ci}$unglq( q, q, q, v1t, ldv1t, cdum, work(1), -1,childinfo ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$unglq( q, q, q, v1t, ldv1t, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorglqmin = max( lorglqmin, q ) - lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) + lorglqopt = max( lorglqopt, int( work(1_${ik}$),KIND=${ik}$) ) end if - call stdlib_${ci}$bbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, dum, u2, & - ldu2, u1, ldu1, cdum, 1, v1t,ldv1t, dum, dum, dum, dum, dum, dum, dum, dum,rwork(& - 1), -1, childinfo ) - lbbcsd = int( rwork(1),KIND=ilp) + call stdlib${ii}$_${ci}$bbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, dum, u2, & + ldu2, u1, ldu1, cdum, 1_${ik}$, v1t,ldv1t, dum, dum, dum, dum, dum, dum, dum, dum,rwork(& + 1_${ik}$), -1_${ik}$, childinfo ) + lbbcsd = int( rwork(1_${ik}$),KIND=${ik}$) end if lrworkmin = ibbcsd+lbbcsd-1 lrworkopt = lrworkmin - rwork(1) = lrworkopt + rwork(1_${ik}$) = lrworkopt lworkmin = max( iorbdb+lorbdb-1,iorgqr+lorgqrmin-1,iorglq+lorglqmin-1 ) lworkopt = max( iorbdb+lorbdb-1,iorgqr+lorgqropt-1,iorglq+lorglqopt-1 ) - work(1) = lworkopt + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not.lquery ) then - info = -19 + info = -19_${ik}$ end if if( lrwork < lrworkmin .and. .not.lquery ) then - info = -21 + info = -21_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'ZUNCSD2BY1', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZUNCSD2BY1', -info ) return else if( lquery ) then return @@ -77529,116 +77520,116 @@ module stdlib_linalg_lapack_${ci}$ if( r == q ) then ! case 1: r = q ! simultaneously bidiagonalize x11 and x21 - call stdlib_${ci}$unbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& + call stdlib${ii}$_${ci}$unbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& itaup1), work(itaup2),work(itauq1), work(iorbdb), lorbdb, childinfo ) ! accumulate householder reflectors - if( wantu1 .and. p > 0 ) then - call stdlib_${ci}$lacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) - call stdlib_${ci}$ungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) + call stdlib${ii}$_${ci}$ungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & childinfo ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_${ci}$lacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) - call stdlib_${ci}$ungqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) + call stdlib${ii}$_${ci}$ungqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & childinfo ) end if - if( wantv1t .and. q > 0 ) then - v1t(1,1) = cone + if( wantv1t .and. q > 0_${ik}$ ) then + v1t(1_${ik}$,1_${ik}$) = cone do j = 2, q - v1t(1,j) = czero - v1t(j,1) = czero + v1t(1_${ik}$,j) = czero + v1t(j,1_${ik}$) = czero end do - call stdlib_${ci}$lacpy( 'U', q-1, q-1, x21(1,2), ldx21, v1t(2,2),ldv1t ) - call stdlib_${ci}$unglq( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),work(iorglq), & + call stdlib${ii}$_${ci}$lacpy( 'U', q-1, q-1, x21(1_${ik}$,2_${ik}$), ldx21, v1t(2_${ik}$,2_${ik}$),ldv1t ) + call stdlib${ii}$_${ci}$unglq( q-1, q-1, q-1, v1t(2_${ik}$,2_${ik}$), ldv1t, work(itauq1),work(iorglq), & lorglq, childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_${ci}$bbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,rwork(iphi), u1, & - ldu1, u2, ldu2, v1t, ldv1t, cdum,1, rwork(ib11d), rwork(ib11e), rwork(ib12d),rwork(& + call stdlib${ii}$_${ci}$bbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,rwork(iphi), u1, & + ldu1, u2, ldu2, v1t, ldv1t, cdum,1_${ik}$, rwork(ib11d), rwork(ib11e), rwork(ib12d),rwork(& ib12e), rwork(ib21d), rwork(ib21e),rwork(ib22d), rwork(ib22e), rwork(ibbcsd),lrwork-& ibbcsd+1, childinfo ) ! permute rows and columns to place czero submatrices in ! preferred positions - if( q > 0 .and. wantu2 ) then + if( q > 0_${ik}$ .and. wantu2 ) then do i = 1, q iwork(i) = m - p - q + i end do do i = q + 1, m - p iwork(i) = i - q end do - call stdlib_${ci}$lapmt( .false., m-p, m-p, u2, ldu2, iwork ) + call stdlib${ii}$_${ci}$lapmt( .false., m-p, m-p, u2, ldu2, iwork ) end if else if( r == p ) then ! case 2: r = p ! simultaneously bidiagonalize x11 and x21 - call stdlib_${ci}$unbdb2( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& + call stdlib${ii}$_${ci}$unbdb2( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& itaup1), work(itaup2),work(itauq1), work(iorbdb), lorbdb, childinfo ) ! accumulate householder reflectors - if( wantu1 .and. p > 0 ) then - u1(1,1) = cone + if( wantu1 .and. p > 0_${ik}$ ) then + u1(1_${ik}$,1_${ik}$) = cone do j = 2, p - u1(1,j) = czero - u1(j,1) = czero + u1(1_${ik}$,j) = czero + u1(j,1_${ik}$) = czero end do - call stdlib_${ci}$lacpy( 'L', p-1, p-1, x11(2,1), ldx11, u1(2,2), ldu1 ) - call stdlib_${ci}$ungqr( p-1, p-1, p-1, u1(2,2), ldu1, work(itaup1),work(iorgqr), & + call stdlib${ii}$_${ci}$lacpy( 'L', p-1, p-1, x11(2_${ik}$,1_${ik}$), ldx11, u1(2_${ik}$,2_${ik}$), ldu1 ) + call stdlib${ii}$_${ci}$ungqr( p-1, p-1, p-1, u1(2_${ik}$,2_${ik}$), ldu1, work(itaup1),work(iorgqr), & lorgqr, childinfo ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_${ci}$lacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) - call stdlib_${ci}$ungqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) + call stdlib${ii}$_${ci}$ungqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & childinfo ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_${ci}$lacpy( 'U', p, q, x11, ldx11, v1t, ldv1t ) - call stdlib_${ci}$unglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'U', p, q, x11, ldx11, v1t, ldv1t ) + call stdlib${ii}$_${ci}$unglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_${ci}$bbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,rwork(iphi), v1t,& - ldv1t, cdum, 1, u1, ldu1, u2,ldu2, rwork(ib11d), rwork(ib11e), rwork(ib12d),rwork(& + call stdlib${ii}$_${ci}$bbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,rwork(iphi), v1t,& + ldv1t, cdum, 1_${ik}$, u1, ldu1, u2,ldu2, rwork(ib11d), rwork(ib11e), rwork(ib12d),rwork(& ib12e), rwork(ib21d), rwork(ib21e),rwork(ib22d), rwork(ib22e), rwork(ibbcsd), & lbbcsd,childinfo ) ! permute rows and columns to place identity submatrices in ! preferred positions - if( q > 0 .and. wantu2 ) then + if( q > 0_${ik}$ .and. wantu2 ) then do i = 1, q iwork(i) = m - p - q + i end do do i = q + 1, m - p iwork(i) = i - q end do - call stdlib_${ci}$lapmt( .false., m-p, m-p, u2, ldu2, iwork ) + call stdlib${ii}$_${ci}$lapmt( .false., m-p, m-p, u2, ldu2, iwork ) end if else if( r == m-p ) then ! case 3: r = m-p ! simultaneously bidiagonalize x11 and x21 - call stdlib_${ci}$unbdb3( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& + call stdlib${ii}$_${ci}$unbdb3( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& itaup1), work(itaup2),work(itauq1), work(iorbdb), lorbdb, childinfo ) ! accumulate householder reflectors - if( wantu1 .and. p > 0 ) then - call stdlib_${ci}$lacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) - call stdlib_${ci}$ungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) + call stdlib${ii}$_${ci}$ungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & childinfo ) end if - if( wantu2 .and. m-p > 0 ) then - u2(1,1) = cone + if( wantu2 .and. m-p > 0_${ik}$ ) then + u2(1_${ik}$,1_${ik}$) = cone do j = 2, m-p - u2(1,j) = czero - u2(j,1) = czero + u2(1_${ik}$,j) = czero + u2(j,1_${ik}$) = czero end do - call stdlib_${ci}$lacpy( 'L', m-p-1, m-p-1, x21(2,1), ldx21, u2(2,2),ldu2 ) - call stdlib_${ci}$ungqr( m-p-1, m-p-1, m-p-1, u2(2,2), ldu2,work(itaup2), work(iorgqr)& + call stdlib${ii}$_${ci}$lacpy( 'L', m-p-1, m-p-1, x21(2_${ik}$,1_${ik}$), ldx21, u2(2_${ik}$,2_${ik}$),ldu2 ) + call stdlib${ii}$_${ci}$ungqr( m-p-1, m-p-1, m-p-1, u2(2_${ik}$,2_${ik}$), ldu2,work(itaup2), work(iorgqr)& , lorgqr, childinfo ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_${ci}$lacpy( 'U', m-p, q, x21, ldx21, v1t, ldv1t ) - call stdlib_${ci}$unglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'U', m-p, q, x21, ldx21, v1t, ldv1t ) + call stdlib${ii}$_${ci}$unglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_${ci}$bbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, rwork(iphi), & - cdum, 1, v1t, ldv1t, u2, ldu2,u1, ldu1, rwork(ib11d), rwork(ib11e),rwork(ib12d), & + call stdlib${ii}$_${ci}$bbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, rwork(iphi), & + cdum, 1_${ik}$, v1t, ldv1t, u2, ldu2,u1, ldu1, rwork(ib11d), rwork(ib11e),rwork(ib12d), & rwork(ib12e), rwork(ib21d),rwork(ib21e), rwork(ib22d), rwork(ib22e),rwork(ibbcsd), & lbbcsd, childinfo ) ! permute rows and columns to place identity submatrices in @@ -77651,51 +77642,51 @@ module stdlib_linalg_lapack_${ci}$ iwork(i) = i - r end do if( wantu1 ) then - call stdlib_${ci}$lapmt( .false., p, q, u1, ldu1, iwork ) + call stdlib${ii}$_${ci}$lapmt( .false., p, q, u1, ldu1, iwork ) end if if( wantv1t ) then - call stdlib_${ci}$lapmr( .false., q, q, v1t, ldv1t, iwork ) + call stdlib${ii}$_${ci}$lapmr( .false., q, q, v1t, ldv1t, iwork ) end if end if else ! case 4: r = m-q ! simultaneously bidiagonalize x11 and x21 - call stdlib_${ci}$unbdb4( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& + call stdlib${ii}$_${ci}$unbdb4( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& itaup1), work(itaup2),work(itauq1), work(iorbdb), work(iorbdb+m),lorbdb-m, & childinfo ) ! accumulate householder reflectors - if( wantu2 .and. m-p > 0 ) then - call stdlib_${ci}$copy( m-p, work(iorbdb+p), 1, u2, 1 ) + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$copy( m-p, work(iorbdb+p), 1_${ik}$, u2, 1_${ik}$ ) end if - if( wantu1 .and. p > 0 ) then - call stdlib_${ci}$copy( p, work(iorbdb), 1, u1, 1 ) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$copy( p, work(iorbdb), 1_${ik}$, u1, 1_${ik}$ ) do j = 2, p - u1(1,j) = czero + u1(1_${ik}$,j) = czero end do - call stdlib_${ci}$lacpy( 'L', p-1, m-q-1, x11(2,1), ldx11, u1(2,2),ldu1 ) - call stdlib_${ci}$ungqr( p, p, m-q, u1, ldu1, work(itaup1),work(iorgqr), lorgqr, & + call stdlib${ii}$_${ci}$lacpy( 'L', p-1, m-q-1, x11(2_${ik}$,1_${ik}$), ldx11, u1(2_${ik}$,2_${ik}$),ldu1 ) + call stdlib${ii}$_${ci}$ungqr( p, p, m-q, u1, ldu1, work(itaup1),work(iorgqr), lorgqr, & childinfo ) end if - if( wantu2 .and. m-p > 0 ) then + if( wantu2 .and. m-p > 0_${ik}$ ) then do j = 2, m-p - u2(1,j) = czero + u2(1_${ik}$,j) = czero end do - call stdlib_${ci}$lacpy( 'L', m-p-1, m-q-1, x21(2,1), ldx21, u2(2,2),ldu2 ) - call stdlib_${ci}$ungqr( m-p, m-p, m-q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & + call stdlib${ii}$_${ci}$lacpy( 'L', m-p-1, m-q-1, x21(2_${ik}$,1_${ik}$), ldx21, u2(2_${ik}$,2_${ik}$),ldu2 ) + call stdlib${ii}$_${ci}$ungqr( m-p, m-p, m-q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & childinfo ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_${ci}$lacpy( 'U', m-q, q, x21, ldx21, v1t, ldv1t ) - call stdlib_${ci}$lacpy( 'U', p-(m-q), q-(m-q), x11(m-q+1,m-q+1), ldx11,v1t(m-q+1,m-q+& - 1), ldv1t ) - call stdlib_${ci}$lacpy( 'U', -p+q, q-p, x21(m-q+1,p+1), ldx21,v1t(p+1,p+1), ldv1t ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_${ci}$lacpy( 'U', m-q, q, x21, ldx21, v1t, ldv1t ) + call stdlib${ii}$_${ci}$lacpy( 'U', p-(m-q), q-(m-q), x11(m-q+1,m-q+1), ldx11,v1t(m-q+1,m-q+& + 1_${ik}$), ldv1t ) + call stdlib${ii}$_${ci}$lacpy( 'U', -p+q, q-p, x21(m-q+1,p+1), ldx21,v1t(p+1,p+1), ldv1t ) - call stdlib_${ci}$unglq( q, q, q, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & + call stdlib${ii}$_${ci}$unglq( q, q, q, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_${ci}$bbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, rwork(iphi), & - u2, ldu2, u1, ldu1, cdum, 1,v1t, ldv1t, rwork(ib11d), rwork(ib11e),rwork(ib12d), & + call stdlib${ii}$_${ci}$bbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, rwork(iphi), & + u2, ldu2, u1, ldu1, cdum, 1_${ik}$,v1t, ldv1t, rwork(ib11d), rwork(ib11e),rwork(ib12d), & rwork(ib12e), rwork(ib21d),rwork(ib21e), rwork(ib22d), rwork(ib22e),rwork(ibbcsd), & lbbcsd, childinfo ) ! permute rows and columns to place identity submatrices in @@ -77708,18 +77699,18 @@ module stdlib_linalg_lapack_${ci}$ iwork(i) = i - r end do if( wantu1 ) then - call stdlib_${ci}$lapmt( .false., p, p, u1, ldu1, iwork ) + call stdlib${ii}$_${ci}$lapmt( .false., p, p, u1, ldu1, iwork ) end if if( wantv1t ) then - call stdlib_${ci}$lapmr( .false., p, q, v1t, ldv1t, iwork ) + call stdlib${ii}$_${ci}$lapmr( .false., p, q, v1t, ldv1t, iwork ) end if end if end if return - end subroutine stdlib_${ci}$uncsd2by1 + end subroutine stdlib${ii}$_${ci}$uncsd2by1 - pure subroutine stdlib_${ci}$ung2l( m, n, k, a, lda, tau, work, info ) + pure subroutine stdlib${ii}$_${ci}$ung2l( m, n, k, a, lda, tau, work, info ) !! ZUNG2L: generates an m by n complex matrix Q with orthonormal columns, !! which is defined as the last n columns of a product of k elementary !! reflectors of order m @@ -77729,8 +77720,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(in) :: tau(*) @@ -77738,23 +77729,23 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! 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 .or. nm .or. nn .or. m=k ) then - call stdlib_${ci}$ungqr( m, n, k, a, lda, tau, work, -1, iinfo ) + call stdlib${ii}$_${ci}$ungqr( m, n, k, a, lda, tau, work, -1_${ik}$, iinfo ) else - if( m>1 ) then - call stdlib_${ci}$ungqr( m-1, m-1, m-1, a, lda, tau, work, -1,iinfo ) + if( m>1_${ik}$ ) then + call stdlib${ii}$_${ci}$ungqr( m-1, m-1, m-1, a, lda, tau, work, -1_${ik}$,iinfo ) end if end if else if( k1 ) then - call stdlib_${ci}$unglq( n-1, n-1, n-1, a, lda, tau, work, -1,iinfo ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_${ci}$unglq( n-1, n-1, n-1, a, lda, tau, work, -1_${ik}$,iinfo ) end if end if end if - lwkopt = real( work( 1 ),KIND=${ck}$) + lwkopt = real( work( 1_${ik}$ ),KIND=${ck}$) lwkopt = max (lwkopt, mn) end if - if( info/=0 ) then - call stdlib_xerbla( 'ZUNGBR', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZUNGBR', -info ) return else if( lquery ) then - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return end if ! quick return if possible - if( m==0 .or. n==0 ) then - work( 1 ) = 1 + if( m==0_${ik}$ .or. n==0_${ik}$ ) then + work( 1_${ik}$ ) = 1_${ik}$ return end if if( wantq ) then - ! form q, determined by a call to stdlib_${ci}$gebrd to reduce an m-by-k + ! form q, determined by a call to stdlib${ii}$_${ci}$gebrd to reduce an m-by-k ! matrix if( m>=k ) then ! if m >= k, assume m >= n >= k - call stdlib_${ci}$ungqr( m, n, k, a, lda, tau, work, lwork, iinfo ) + call stdlib${ii}$_${ci}$ungqr( m, n, k, a, lda, tau, work, lwork, iinfo ) else ! if m < k, assume m = n ! shift the vectors which define the elementary reflectors cone ! column to the right, and set the first row and column of q ! to those of the unit matrix do j = m, 2, -1 - a( 1, j ) = czero + a( 1_${ik}$, j ) = czero do i = j + 1, m a( i, j ) = a( i, j-1 ) end do end do - a( 1, 1 ) = cone + a( 1_${ik}$, 1_${ik}$ ) = cone do i = 2, m - a( i, 1 ) = czero + a( i, 1_${ik}$ ) = czero end do - if( m>1 ) then + if( m>1_${ik}$ ) then ! form q(2:m,2:m) - call stdlib_${ci}$ungqr( m-1, m-1, m-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) + call stdlib${ii}$_${ci}$ungqr( m-1, m-1, m-1, a( 2_${ik}$, 2_${ik}$ ), lda, tau, work,lwork, iinfo ) end if end if else - ! form p**h, determined by a call to stdlib_${ci}$gebrd to reduce a k-by-n + ! form p**h, determined by a call to stdlib${ii}$_${ci}$gebrd to reduce a k-by-n ! matrix if( k= n, assume m = n ! shift the vectors which define the elementary reflectors cone ! row downward, and set the first row and column of p**h to ! those of the unit matrix - a( 1, 1 ) = cone + a( 1_${ik}$, 1_${ik}$ ) = cone do i = 2, n - a( i, 1 ) = czero + a( i, 1_${ik}$ ) = czero end do do j = 2, n do i = j - 1, 2, -1 a( i, j ) = a( i-1, j ) end do - a( 1, j ) = czero + a( 1_${ik}$, j ) = czero end do - if( n>1 ) then + if( n>1_${ik}$ ) then ! form p**h(2:n,2:n) - call stdlib_${ci}$unglq( n-1, n-1, n-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) + call stdlib${ii}$_${ci}$unglq( n-1, n-1, n-1, a( 2_${ik}$, 2_${ik}$ ), lda, tau, work,lwork, iinfo ) end if end if end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ci}$ungbr + end subroutine stdlib${ii}$_${ci}$ungbr - pure subroutine stdlib_${ci}$unghr( n, ilo, ihi, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_${ci}$unghr( n, ilo, ihi, a, lda, tau, work, lwork, info ) !! ZUNGHR: generates a complex unitary matrix Q which is defined as the !! product of IHI-ILO elementary reflectors of order N, as returned by !! ZGEHRD: @@ -78006,8 +77997,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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, lda, lwork, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ilo, lda, lwork, n + integer(${ik}$), intent(out) :: info ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(in) :: tau(*) @@ -78016,39 +78007,39 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, iinfo, j, lwkopt, nb, nh + integer(${ik}$) :: i, iinfo, j, lwkopt, nb, nh ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ nh = ihi - ilo - lquery = ( lwork==-1 ) - if( n<0 ) then - info = -1 - else if( ilo<1 .or. ilo>max( 1, n ) ) then - info = -2 + lquery = ( lwork==-1_${ik}$ ) + if( n<0_${ik}$ ) then + info = -1_${ik}$ + else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then + info = -2_${ik}$ else if( ihin ) then - info = -3 - else if( lda0 ) then + if( nh>0_${ik}$ ) then ! generate q(ilo+1:ihi,ilo+1:ihi) - call stdlib_${ci}$ungqr( nh, nh, nh, a( ilo+1, ilo+1 ), lda, tau( ilo ),work, lwork, & + call stdlib${ii}$_${ci}$ungqr( nh, nh, nh, a( ilo+1, ilo+1 ), lda, tau( ilo ),work, lwork, & iinfo ) end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ci}$unghr + end subroutine stdlib${ii}$_${ci}$unghr - pure subroutine stdlib_${ci}$ungl2( m, n, k, a, lda, tau, work, info ) + pure subroutine stdlib${ii}$_${ci}$ungl2( m, n, k, a, lda, tau, work, info ) !! ZUNGL2: generates an m-by-n complex matrix Q with orthonormal rows, !! which is defined as the first m rows of a product of k elementary !! reflectors of order n @@ -78097,8 +78088,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(in) :: tau(*) @@ -78106,23 +78097,23 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, l + integer(${ik}$) :: i, j, l ! Intrinsic Functions intrinsic :: conjg,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 + 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_${ci}$larft( 'FORWARD', 'ROWWISE', n-i+1, ib, a( i, i ),lda, tau( i ), & + call stdlib${ii}$_${ci}$larft( 'FORWARD', 'ROWWISE', n-i+1, ib, a( i, i ),lda, tau( i ), & work, ldwork ) ! apply h**h to a(i+ib:m,i:n) from the right - call stdlib_${ci}$larfb( 'RIGHT', 'CONJUGATE TRANSPOSE', 'FORWARD','ROWWISE', m-i-& + call stdlib${ii}$_${ci}$larfb( 'RIGHT', 'CONJUGATE TRANSPOSE', 'FORWARD','ROWWISE', m-i-& ib+1, n-i+1, ib, a( i, i ),lda, work, ldwork, a( i+ib, i ), lda,work( ib+1 ), & ldwork ) end if ! apply h**h to columns i:n of current block - call stdlib_${ci}$ungl2( ib, n-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) + call stdlib${ii}$_${ci}$ungl2( ib, n-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) ! set columns 1:i-1 of current block to czero do j = 1, i - 1 do l = i, i + ib - 1 @@ -78269,12 +78260,12 @@ module stdlib_linalg_lapack_${ci}$ end do end do end if - work( 1 ) = iws + work( 1_${ik}$ ) = iws return - end subroutine stdlib_${ci}$unglq + end subroutine stdlib${ii}$_${ci}$unglq - pure subroutine stdlib_${ci}$ungql( m, n, k, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_${ci}$ungql( m, n, k, a, lda, tau, work, lwork, info ) !! ZUNGQL: generates an M-by-N complex matrix Q with orthonormal columns, !! which is defined as the last N columns of a product of K elementary !! reflectors of order M @@ -78284,8 +78275,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(in) :: tau(*) @@ -78294,50 +78285,50 @@ module stdlib_linalg_lapack_${ci}$ ! 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}$_${ci}$ung2l( 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_${ci}$larft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1, n-k+i ), & + call stdlib${ii}$_${ci}$larft( '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_${ci}$larfb( 'LEFT', 'NO TRANSPOSE', 'BACKWARD','COLUMNWISE', m-k+i+ib-& - 1, n-k+i-1, ib,a( 1, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork ) + call stdlib${ii}$_${ci}$larfb( '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_${ci}$ung2l( m-k+i+ib-1, ib, ib, a( 1, n-k+i ), lda,tau( i ), work, iinfo & + call stdlib${ii}$_${ci}$ung2l( 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 czero do j = n - k + i, n - k + i + ib - 1 @@ -78390,12 +78381,12 @@ module stdlib_linalg_lapack_${ci}$ end do end do end if - work( 1 ) = iws + work( 1_${ik}$ ) = iws return - end subroutine stdlib_${ci}$ungql + end subroutine stdlib${ii}$_${ci}$ungql - pure subroutine stdlib_${ci}$ungqr( m, n, k, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_${ci}$ungqr( m, n, k, a, lda, tau, work, lwork, info ) !! ZUNGQR: generates an M-by-N complex matrix Q with orthonormal columns, !! which is defined as the first N columns of a product of K elementary !! reflectors of order M @@ -78405,8 +78396,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(in) :: tau(*) @@ -78415,44 +78406,44 @@ module stdlib_linalg_lapack_${ci}$ ! 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, 'ZUNGQR', ' ', 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_${ci}$larft( 'FORWARD', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & + call stdlib${ii}$_${ci}$larft( 'FORWARD', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & ), work, ldwork ) ! apply h to a(i:m,i+ib:n) from the left - call stdlib_${ci}$larfb( 'LEFT', 'NO TRANSPOSE', 'FORWARD','COLUMNWISE', m-i+1, n-& + call stdlib${ii}$_${ci}$larfb( 'LEFT', 'NO TRANSPOSE', 'FORWARD','COLUMNWISE', m-i+1, n-& i-ib+1, ib,a( i, i ), lda, work, ldwork, a( i, i+ib ),lda, work( ib+1 ), & ldwork ) end if ! apply h to rows i:m of current block - call stdlib_${ci}$ung2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work,iinfo ) + call stdlib${ii}$_${ci}$ung2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work,iinfo ) ! set rows 1:i-1 of current block to czero do j = i, i + ib - 1 do l = 1, i - 1 @@ -78506,12 +78497,12 @@ module stdlib_linalg_lapack_${ci}$ end do end do end if - work( 1 ) = iws + work( 1_${ik}$ ) = iws return - end subroutine stdlib_${ci}$ungqr + end subroutine stdlib${ii}$_${ci}$ungqr - pure subroutine stdlib_${ci}$ungr2( m, n, k, a, lda, tau, work, info ) + pure subroutine stdlib${ii}$_${ci}$ungr2( m, n, k, a, lda, tau, work, info ) !! ZUNGR2: generates an m by n complex matrix Q with orthonormal rows, !! which is defined as the last m rows of a product of k elementary !! reflectors of order n @@ -78521,8 +78512,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(in) :: tau(*) @@ -78530,23 +78521,23 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ii, j, l + integer(${ik}$) :: i, ii, j, l ! Intrinsic Functions intrinsic :: conjg,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}$_${ci}$ungr2( 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_${ci}$larft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( ii, 1 ), lda, & + call stdlib${ii}$_${ci}$larft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( ii, 1_${ik}$ ), lda, & tau( i ), work, ldwork ) ! apply h**h to a(1:m-k+i-1,1:n-k+i+ib-1) from the right - call stdlib_${ci}$larfb( 'RIGHT', 'CONJUGATE TRANSPOSE', 'BACKWARD','ROWWISE', ii-& - 1, n-k+i+ib-1, ib, a( ii, 1 ),lda, work, ldwork, a, lda, work( ib+1 ),ldwork ) + call stdlib${ii}$_${ci}$larfb( 'RIGHT', 'CONJUGATE TRANSPOSE', 'BACKWARD','ROWWISE', ii-& + 1_${ik}$, n-k+i+ib-1, ib, a( ii, 1_${ik}$ ),lda, work, ldwork, a, lda, work( ib+1 ),ldwork ) end if ! apply h**h to columns 1:n-k+i+ib-1 of current block - call stdlib_${ci}$ungr2( ib, n-k+i+ib-1, ib, a( ii, 1 ), lda, tau( i ),work, iinfo ) + call stdlib${ii}$_${ci}$ungr2( 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 czero do l = n - k + i + ib, n @@ -78696,12 +78687,12 @@ module stdlib_linalg_lapack_${ci}$ end do end do end if - work( 1 ) = iws + work( 1_${ik}$ ) = iws return - end subroutine stdlib_${ci}$ungrq + end subroutine stdlib${ii}$_${ci}$ungrq - pure subroutine stdlib_${ci}$ungtr( uplo, n, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_${ci}$ungtr( uplo, n, a, lda, tau, work, lwork, info ) !! ZUNGTR: generates a complex unitary matrix Q which is defined as the !! product of n-1 elementary reflectors of order N, as returned by !! ZHETRD: @@ -78712,8 +78703,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(in) :: tau(*) @@ -78722,45 +78713,45 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: lquery, upper - integer(ilp) :: i, iinfo, j, lwkopt, nb + integer(${ik}$) :: i, iinfo, j, lwkopt, nb ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${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 + if( n>1_${ik}$ ) then ! generate q(2:n,2:n) - call stdlib_${ci}$ungqr( n-1, n-1, n-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) + call stdlib${ii}$_${ci}$ungqr( n-1, n-1, n-1, a( 2_${ik}$, 2_${ik}$ ), lda, tau, work,lwork, iinfo ) end if end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ci}$ungtr + end subroutine stdlib${ii}$_${ci}$ungtr - pure subroutine stdlib_${ci}$ungtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) + pure subroutine stdlib${ii}$_${ci}$ungtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) !! ZUNGTSQR: generates an M-by-N complex matrix Q_out with orthonormal !! columns, which are the first N columns of a product of comlpex unitary !! matrices of order M which are returned by ZLATSQR @@ -78812,8 +78803,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: a(lda,*) complex(${ck}$), intent(in) :: t(ldt,*) @@ -78822,85 +78813,85 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: lquery - integer(ilp) :: iinfo, ldc, lworkopt, lc, lw, nblocal, j + integer(${ik}$) :: iinfo, ldc, lworkopt, lc, lw, nblocal, j ! Intrinsic Functions intrinsic :: cmplx,max,min ! Executable Statements ! test the input parameters - lquery = lwork==-1 - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 .or. m=m, then the loop is never executed. if ( mbm ) then - info = -2 - else if( nb<1 ) then - info = -3 - else if( ldam ) then + info = -2_${ik}$ + else if( nb<1_${ik}$ ) then + info = -3_${ik}$ + else if( ldan ) then - call stdlib_${ci}$trsm( 'R', 'U', 'N', 'N', m-n, n, cone, a, lda,a( n+1, 1 ), lda ) + call stdlib${ii}$_${ci}$trsm( 'R', 'U', 'N', 'N', m-n, n, cone, a, lda,a( n+1, 1_${ik}$ ), lda ) end if ! (2) reconstruct the block reflector t stored in t(1:nb, 1:n) @@ -79111,7 +79102,7 @@ module stdlib_linalg_lapack_${ci}$ ! loop over the column blocks of size nb of the array a(1:m,1:n) ! and the array t(1:nb,1:n), jb is the column index of a column ! block, jnb is the column block size at each step jb. - nplusone = n + 1 + nplusone = n + 1_${ik}$ do jb = 1, n, nb ! (2-0) determine the column block size jnb. jnb = min( nplusone-jb, nb ) @@ -79120,9 +79111,9 @@ module stdlib_linalg_lapack_${ci}$ ! in a(jb:jb+jnb-1,jb:jb+jnb-1) into the upper-triangular part ! of the current jnb-by-jnb block t(1:jnb,jb:jb+jnb-1) ! column-by-column, total jnb*(jnb+1)/2 elements. - jbtemp1 = jb - 1 + jbtemp1 = jb - 1_${ik}$ do j = jb, jb+jnb-1 - call stdlib_${ci}$copy( j-jbtemp1, a( jb, j ), 1, t( 1, j ), 1 ) + call stdlib${ii}$_${ci}$copy( j-jbtemp1, a( jb, j ), 1_${ik}$, t( 1_${ik}$, j ), 1_${ik}$ ) end do ! (2-2) perform on the upper-triangular part of the current ! jnb-by-jnb diagonal block u(jb) (of the n-by-n matrix u) stored @@ -79136,7 +79127,7 @@ module stdlib_linalg_lapack_${ci}$ ! s(jb), i.e. s(j,j) that is stored in the array element d(j). do j = jb, jb+jnb-1 if( d( j )==cone ) then - call stdlib_${ci}$scal( j-jbtemp1, -cone, t( 1, j ), 1 ) + call stdlib${ii}$_${ci}$scal( j-jbtemp1, -cone, t( 1_${ik}$, j ), 1_${ik}$ ) end if end do ! (2-3) perform the triangular solve for the current block @@ -79160,35 +79151,35 @@ module stdlib_linalg_lapack_${ci}$ ! upper-triangular block t(jb): ! t(jb) * (v1(jb)**t) = (-1)*u(jb)*s(jb). ! even though the blocks x(jb) and b(jb) are upper- - ! triangular, the routine stdlib_${ci}$trsm will access all jnb**2 + ! triangular, the routine stdlib${ii}$_${ci}$trsm will access all jnb**2 ! elements of the square t(1:jnb,jb:jb+jnb-1). therefore, ! we need to set to zero the elements of the block ! t(1:jnb,jb:jb+jnb-1) below the diagonal before the call - ! to stdlib_${ci}$trsm. + ! to stdlib${ii}$_${ci}$trsm. ! (2-3a) set the elements to zero. - jbtemp2 = jb - 2 + jbtemp2 = jb - 2_${ik}$ do j = jb, jb+jnb-2 do i = j-jbtemp2, nb t( i, j ) = czero end do end do ! (2-3b) perform the triangular solve. - call stdlib_${ci}$trsm( 'R', 'L', 'C', 'U', jnb, jnb, cone,a( jb, jb ), lda, t( 1, jb ), & + call stdlib${ii}$_${ci}$trsm( 'R', 'L', 'C', 'U', jnb, jnb, cone,a( jb, jb ), lda, t( 1_${ik}$, jb ), & ldt ) end do return - end subroutine stdlib_${ci}$unhr_col + end subroutine stdlib${ii}$_${ci}$unhr_col - pure subroutine stdlib_${ci}$unm22( side, trans, m, n, n1, n2, q, ldq, c, ldc,work, lwork, info ) + pure subroutine stdlib${ii}$_${ci}$unm22( side, trans, m, n, n1, n2, q, ldq, c, ldc,work, lwork, info ) ! -- lapack computational routine -- ! -- lapack is a software package provided by univ. of tennessee, -- ! -- 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 complex(${ck}$), intent(in) :: q(ldq,*) complex(${ck}$), intent(inout) :: c(ldc,*) @@ -79197,15 +79188,15 @@ module stdlib_linalg_lapack_${ci}$ ! 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 :: cmplx,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 @@ -79214,100 +79205,100 @@ module stdlib_linalg_lapack_${ci}$ 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, 'C' ) )& 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( lda0 .and. n>0 ) then + if( info==0_${ik}$ ) then + if( m>0_${ik}$ .and. n>0_${ik}$ ) then if( applyq ) then if( left ) then - nb = stdlib_ilaenv( 1, 'ZUNMQR', side // trans, m-1, n, m-1,-1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', side // trans, m-1, n, m-1,-1_${ik}$ ) else - nb = stdlib_ilaenv( 1, 'ZUNMQR', side // trans, m, n-1, n-1,-1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', side // trans, m, n-1, n-1,-1_${ik}$ ) end if else if( left ) then - nb = stdlib_ilaenv( 1, 'ZUNMLQ', side // trans, m-1, n, m-1,-1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMLQ', side // trans, m-1, n, m-1,-1_${ik}$ ) else - nb = stdlib_ilaenv( 1, 'ZUNMLQ', side // trans, m, n-1, n-1,-1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMLQ', side // trans, m, n-1, n-1,-1_${ik}$ ) end if end if lwkopt = nw*nb else - lwkopt = 1 + lwkopt = 1_${ik}$ end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt end if - if( info/=0 ) then - call stdlib_xerbla( 'ZUNMBR', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZUNMBR', -info ) return else if( lquery ) then return @@ -79673,23 +79664,23 @@ module stdlib_linalg_lapack_${ci}$ if( applyq ) then ! apply q if( nq>=k ) then - ! q was determined by a call to stdlib_${ci}$gebrd with nq >= k - call stdlib_${ci}$unmqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, iinfo & + ! q was determined by a call to stdlib${ii}$_${ci}$gebrd with nq >= k + call stdlib${ii}$_${ci}$unmqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, iinfo & ) - else if( nq>1 ) then - ! q was determined by a call to stdlib_${ci}$gebrd with nq < k + else if( nq>1_${ik}$ ) then + ! q was determined by a call to stdlib${ii}$_${ci}$gebrd with nq < k if( left ) then - mi = m - 1 + mi = m - 1_${ik}$ ni = n - i1 = 2 - i2 = 1 + i1 = 2_${ik}$ + i2 = 1_${ik}$ else mi = m - ni = n - 1 - i1 = 1 - i2 = 2 + ni = n - 1_${ik}$ + i1 = 1_${ik}$ + i2 = 2_${ik}$ end if - call stdlib_${ci}$unmqr( side, trans, mi, ni, nq-1, a( 2, 1 ), lda, tau,c( i1, i2 ), & + call stdlib${ii}$_${ci}$unmqr( side, trans, mi, ni, nq-1, a( 2_${ik}$, 1_${ik}$ ), lda, tau,c( i1, i2 ), & ldc, work, lwork, iinfo ) end if else @@ -79700,32 +79691,32 @@ module stdlib_linalg_lapack_${ci}$ transt = 'N' end if if( nq>k ) then - ! p was determined by a call to stdlib_${ci}$gebrd with nq > k - call stdlib_${ci}$unmlq( side, transt, m, n, k, a, lda, tau, c, ldc,work, lwork, & + ! p was determined by a call to stdlib${ii}$_${ci}$gebrd with nq > k + call stdlib${ii}$_${ci}$unmlq( side, transt, m, n, k, a, lda, tau, c, ldc,work, lwork, & iinfo ) - else if( nq>1 ) then - ! p was determined by a call to stdlib_${ci}$gebrd with nq <= k + else if( nq>1_${ik}$ ) then + ! p was determined by a call to stdlib${ii}$_${ci}$gebrd with nq <= k if( left ) then - mi = m - 1 + mi = m - 1_${ik}$ ni = n - i1 = 2 - i2 = 1 + i1 = 2_${ik}$ + i2 = 1_${ik}$ else mi = m - ni = n - 1 - i1 = 1 - i2 = 2 + ni = n - 1_${ik}$ + i1 = 1_${ik}$ + i2 = 2_${ik}$ end if - call stdlib_${ci}$unmlq( side, transt, mi, ni, nq-1, a( 1, 2 ), lda,tau, c( i1, i2 ), & + call stdlib${ii}$_${ci}$unmlq( side, transt, mi, ni, nq-1, a( 1_${ik}$, 2_${ik}$ ), lda,tau, c( i1, i2 ), & ldc, work, lwork, iinfo ) end if end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ci}$unmbr + end subroutine stdlib${ii}$_${ci}$unmbr - pure subroutine stdlib_${ci}$unmhr( side, trans, m, n, ilo, ihi, a, lda, tau, c,ldc, work, lwork, & + pure subroutine stdlib${ii}$_${ci}$unmhr( side, trans, m, n, ilo, ihi, a, lda, tau, c,ldc, work, lwork, & !! ZUNMHR: overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -79740,8 +79731,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: side, trans - integer(ilp), intent(in) :: ihi, ilo, lda, ldc, lwork, m, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ilo, lda, ldc, lwork, m, n + integer(${ik}$), intent(out) :: info ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*), c(ldc,*) complex(${ck}$), intent(in) :: tau(*) @@ -79749,82 +79740,82 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! Local Scalars logical(lk) :: left, lquery - integer(ilp) :: i1, i2, iinfo, lwkopt, mi, nb, nh, ni, nq, nw + integer(${ik}$) :: i1, i2, iinfo, lwkopt, mi, nb, nh, ni, nq, nw ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ nh = ihi - ilo left = stdlib_lsame( side, 'L' ) - 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.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'C' ) )& then - info = -2 - else if( m<0 ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( ilo<1 .or. ilo>max( 1, nq ) ) then - info = -5 + info = -2_${ik}$ + else if( m<0_${ik}$ ) then + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, nq ) ) then + info = -5_${ik}$ else if( ihinq ) then - info = -6 - 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_${ci}$unml2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib${ii}$_${ci}$unml2( 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 = 'C' @@ -80052,28 +80043,28 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$larft( 'FORWARD', 'ROWWISE', nq-i+1, ib, a( i, i ),lda, tau( i ), & + call stdlib${ii}$_${ci}$larft( 'FORWARD', 'ROWWISE', nq-i+1, ib, a( i, i ),lda, tau( i ), & work( iwt ), ldt ) if( left ) then ! h or h**h is applied to c(i:m,1:n) - mi = m - i + 1 + mi = m - i + 1_${ik}$ ic = i else ! h or h**h is applied to c(1:m,i:n) - ni = n - i + 1 + ni = n - i + 1_${ik}$ jc = i end if ! apply h or h**h - call stdlib_${ci}$larfb( side, transt, 'FORWARD', 'ROWWISE', mi, ni, ib,a( i, i ), & + call stdlib${ii}$_${ci}$larfb( side, transt, 'FORWARD', 'ROWWISE', mi, ni, ib,a( i, i ), & lda, work( iwt ), ldt,c( ic, jc ), ldc, work, ldwork ) end do end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ci}$unmlq + end subroutine stdlib${ii}$_${ci}$unmlq - pure subroutine stdlib_${ci}$unmql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) + pure subroutine stdlib${ii}$_${ci}$unmql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) !! ZUNMQL: overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -80089,97 +80080,97 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: a(lda,*), c(ldc,*) complex(${ck}$), intent(in) :: tau(*) complex(${ck}$), 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, 'C' ) ) 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_${ci}$unm2l( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib${ii}$_${ci}$unm2l( 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 @@ -80191,26 +80182,26 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$larft( 'BACKWARD', 'COLUMNWISE', nq-k+i+ib-1, ib,a( 1, i ), lda, & + call stdlib${ii}$_${ci}$larft( 'BACKWARD', 'COLUMNWISE', nq-k+i+ib-1, ib,a( 1_${ik}$, i ), lda, & tau( i ), work( iwt ), ldt ) if( left ) then ! h or h**h is applied to c(1:m-k+i+ib-1,1:n) - mi = m - k + i + ib - 1 + mi = m - k + i + ib - 1_${ik}$ else ! h or h**h is applied to c(1:m,1:n-k+i+ib-1) - ni = n - k + i + ib - 1 + ni = n - k + i + ib - 1_${ik}$ end if ! apply h or h**h - call stdlib_${ci}$larfb( side, trans, 'BACKWARD', 'COLUMNWISE', mi, ni,ib, a( 1, i ), & + call stdlib${ii}$_${ci}$larfb( 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_${ci}$unmql + end subroutine stdlib${ii}$_${ci}$unmql - pure subroutine stdlib_${ci}$unmqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) + pure subroutine stdlib${ii}$_${ci}$unmqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) !! ZUNMQR: overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -80226,128 +80217,128 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: a(lda,*), c(ldc,*) complex(${ck}$), intent(in) :: tau(*) complex(${ck}$), 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, 'C' ) ) 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_${ci}$unm2r( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib${ii}$_${ci}$unm2r( 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_${ci}$larft( 'FORWARD', 'COLUMNWISE', nq-i+1, ib, a( i, i ),lda, tau( i ),& + call stdlib${ii}$_${ci}$larft( 'FORWARD', 'COLUMNWISE', nq-i+1, ib, a( i, i ),lda, tau( i ),& work( iwt ), ldt ) if( left ) then ! h or h**h is applied to c(i:m,1:n) - mi = m - i + 1 + mi = m - i + 1_${ik}$ ic = i else ! h or h**h is applied to c(1:m,i:n) - ni = n - i + 1 + ni = n - i + 1_${ik}$ jc = i end if ! apply h or h**h - call stdlib_${ci}$larfb( side, trans, 'FORWARD', 'COLUMNWISE', mi, ni,ib, a( i, i ), & + call stdlib${ii}$_${ci}$larfb( side, trans, 'FORWARD', 'COLUMNWISE', mi, ni,ib, a( i, i ), & lda, work( iwt ), ldt,c( ic, jc ), ldc, work, ldwork ) end do end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ci}$unmqr + end subroutine stdlib${ii}$_${ci}$unmqr - pure subroutine stdlib_${ci}$unmr2( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) + pure subroutine stdlib${ii}$_${ci}$unmr2( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) !! ZUNMR2: overwrites the general complex m-by-n matrix C with !! Q * C if SIDE = 'L' and TRANS = 'N', or !! Q**H* C if SIDE = 'L' and TRANS = 'C', or @@ -80363,8 +80354,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: a(lda,*), c(ldc,*) complex(${ck}$), intent(in) :: tau(*) @@ -80373,13 +80364,13 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: left, notran - integer(ilp) :: i, i1, i2, i3, mi, ni, nq + integer(${ik}$) :: i, i1, i2, i3, mi, ni, nq complex(${ck}$) :: aii, taui ! Intrinsic Functions intrinsic :: conjg,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 @@ -80389,34 +80380,34 @@ module stdlib_linalg_lapack_${ci}$ 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, 'C' ) ) 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_${ci}$unmr2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib${ii}$_${ci}$unmr2( 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 @@ -80677,26 +80668,26 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$larft( 'BACKWARD', 'ROWWISE', nq-k+i+ib-1, ib,a( i, 1 ), lda, tau( & + call stdlib${ii}$_${ci}$larft( 'BACKWARD', 'ROWWISE', nq-k+i+ib-1, ib,a( i, 1_${ik}$ ), lda, tau( & i ), work( iwt ), ldt ) if( left ) then ! h or h**h is applied to c(1:m-k+i+ib-1,1:n) - mi = m - k + i + ib - 1 + mi = m - k + i + ib - 1_${ik}$ else ! h or h**h is applied to c(1:m,1:n-k+i+ib-1) - ni = n - k + i + ib - 1 + ni = n - k + i + ib - 1_${ik}$ end if ! apply h or h**h - call stdlib_${ci}$larfb( side, transt, 'BACKWARD', 'ROWWISE', mi, ni,ib, a( i, 1 ), & + call stdlib${ii}$_${ci}$larfb( 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_${ci}$unmrq + end subroutine stdlib${ii}$_${ci}$unmrq - pure subroutine stdlib_${ci}$unmrz( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, lwork, & + pure subroutine stdlib${ii}$_${ci}$unmrz( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, lwork, & !! ZUNMRZ: overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -80712,114 +80703,114 @@ module stdlib_linalg_lapack_${ci}$ ! -- 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 complex(${ck}$), intent(inout) :: a(lda,*), c(ldc,*) complex(${ck}$), intent(in) :: tau(*) complex(${ck}$), 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, 'C' ) ) 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_${ci}$unmr3( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, iinfo ) + call stdlib${ii}$_${ci}$unmr3( 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 = 'C' @@ -80830,28 +80821,28 @@ module stdlib_linalg_lapack_${ci}$ 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_${ci}$larzt( 'BACKWARD', 'ROWWISE', l, ib, a( i, ja ), lda,tau( i ), work(& + call stdlib${ii}$_${ci}$larzt( 'BACKWARD', 'ROWWISE', l, ib, a( i, ja ), lda,tau( i ), work(& iwt ), ldt ) if( left ) then ! h or h**h is applied to c(i:m,1:n) - mi = m - i + 1 + mi = m - i + 1_${ik}$ ic = i else ! h or h**h is applied to c(1:m,i:n) - ni = n - i + 1 + ni = n - i + 1_${ik}$ jc = i end if ! apply h or h**h - call stdlib_${ci}$larzb( side, transt, 'BACKWARD', 'ROWWISE', mi, ni,ib, l, a( i, ja )& + call stdlib${ii}$_${ci}$larzb( side, transt, 'BACKWARD', 'ROWWISE', mi, ni,ib, l, a( i, ja )& , lda, work( iwt ), ldt,c( ic, jc ), ldc, work, ldwork ) end do end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_${ci}$unmrz + end subroutine stdlib${ii}$_${ci}$unmrz - pure subroutine stdlib_${ci}$unmtr( side, uplo, trans, m, n, a, lda, tau, c, ldc,work, lwork, & + pure subroutine stdlib${ii}$_${ci}$unmtr( side, uplo, trans, m, n, a, lda, tau, c, ldc,work, lwork, & !! ZUNMTR: overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -80867,8 +80858,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: side, trans, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldc, lwork, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldc, lwork, m, n ! Array Arguments complex(${ck}$), intent(inout) :: a(lda,*), c(ldc,*) complex(${ck}$), intent(in) :: tau(*) @@ -80876,98 +80867,98 @@ module stdlib_linalg_lapack_${ci}$ ! ===================================================================== ! Local Scalars logical(lk) :: left, lquery, upper - integer(ilp) :: i1, i2, iinfo, lwkopt, mi, nb, ni, nq, nw + integer(${ik}$) :: i1, i2, iinfo, lwkopt, mi, nb, ni, nq, nw ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ left = stdlib_lsame( side, 'L' ) upper = stdlib_lsame( uplo, 'U' ) - 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.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -2 + info = -2_${ik}$ else if( .not.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'C' ) )& then - info = -3 - else if( m<0 ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( lda1 ) then + if( n>1_${ik}$ ) then ! generate q(2:n,2:n) - call stdlib_${ci}$ung2r( n-1, n-1, n-1, q( 2, 2 ), ldq, tau, work,iinfo ) + call stdlib${ii}$_${ci}$ung2r( n-1, n-1, n-1, q( 2_${ik}$, 2_${ik}$ ), ldq, tau, work,iinfo ) end if end if return - end subroutine stdlib_${ci}$upgtr + end subroutine stdlib${ii}$_${ci}$upgtr - pure subroutine stdlib_${ci}$upmtr( side, uplo, trans, m, n, ap, tau, c, ldc, work,info ) + pure subroutine stdlib${ii}$_${ci}$upmtr( side, uplo, trans, m, n, ap, tau, c, ldc, work,info ) !! ZUPMTR: overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -81070,8 +81061,8 @@ module stdlib_linalg_lapack_${ci}$ ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: side, trans, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldc, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldc, m, n ! Array Arguments complex(${ck}$), intent(inout) :: ap(*), c(ldc,*) complex(${ck}$), intent(in) :: tau(*) @@ -81080,13 +81071,13 @@ module stdlib_linalg_lapack_${ci}$ ! Local Scalars logical(lk) :: forwrd, left, notran, upper - integer(ilp) :: i, i1, i2, i3, ic, ii, jc, mi, ni, nq + integer(${ik}$) :: i, i1, i2, i3, ic, ii, jc, mi, ni, nq complex(${ck}$) :: aii, taui ! Intrinsic Functions intrinsic :: conjg,max ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ left = stdlib_lsame( side, 'L' ) notran = stdlib_lsame( trans, 'N' ) upper = stdlib_lsame( uplo, 'U' ) @@ -81097,37 +81088,37 @@ module stdlib_linalg_lapack_${ci}$ nq = n end if if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -2 + info = -2_${ik}$ else if( .not.notran .and. .not.stdlib_lsame( trans, 'C' ) ) then - info = -3 - else if( m<0 ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( ldc=1/s and sbig==1/S with s,S as defined in https://doi.org/10.1145/355769.355771 real(dp), parameter, private :: tsml = rradix**ceiling((minexp-1)*half) - real(dp), parameter, private :: tbig = rradix**floor((maxexp-digits(zero)+1)*half) + real(dp), parameter, private :: tbig = rradix**floor((maxexp-digits(zero)+1_${ik}$)*half) real(dp), parameter, private :: ssml = rradix**(-floor((minexp-digits(zero))*half)) - real(dp), parameter, private :: sbig = rradix**(-ceiling((maxexp+digits(zero)-1)*half)) + real(dp), parameter, private :: sbig = rradix**(-ceiling((maxexp+digits(zero)-1_${ik}$)*half)) contains + #:for ik,it,ii in LINALG_INT_KINDS_TYPES + #:if WITH_QP - - pure subroutine stdlib_zlag2w( m, n, sa, ldsa, a, lda, info ) + pure subroutine stdlib${ii}$_zlag2w( m, n, sa, ldsa, a, lda, info ) !! ZLAG2W converts a COMPLEX matrix, SA, to a COMPLEX*16 matrix, A. !! Note that while it is possible to overflow while converting !! from double to single, it is not possible to overflow when @@ -517,27 +520,27 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(in) :: sa(ldsa,*) complex(qp), 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_zlag2w + end subroutine stdlib${ii}$_zlag2w #:endif - pure subroutine stdlib_zdrscl( n, sa, sx, incx ) + pure subroutine stdlib${ii}$_zdrscl( n, sa, sx, incx ) !! ZDRSCL multiplies an n-element complex vector x by the real scalar !! 1/a. This is done without overflow or underflow as long as !! the final result x/a does not overflow or underflow. @@ -545,7 +548,7 @@ module stdlib_linalg_lapack_z ! -- 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(dp), intent(in) :: sa ! Array Arguments complex(dp), intent(inout) :: sx(*) @@ -560,9 +563,9 @@ module stdlib_linalg_lapack_z ! quick return if possible if( n<=0 )return ! get machine parameters - smlnum = stdlib_dlamch( 'S' ) + smlnum = stdlib${ii}$_dlamch( 'S' ) bignum = one / smlnum - call stdlib_dlabad( smlnum, bignum ) + call stdlib${ii}$_dlabad( smlnum, bignum ) ! initialize the denominator to sa and the numerator to 1. cden = sa cnum = one @@ -585,13 +588,13 @@ module stdlib_linalg_lapack_z done = .true. end if ! scale the vector x by mul - call stdlib_zdscal( n, mul, sx, incx ) + call stdlib${ii}$_zdscal( n, mul, sx, incx ) if( .not.done )go to 10 return - end subroutine stdlib_zdrscl + end subroutine stdlib${ii}$_zdrscl - pure subroutine stdlib_zgbequ( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info ) + pure subroutine stdlib${ii}$_zgbequ( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, info ) !! ZGBEQU computes row and column scalings intended to equilibrate an !! M-by-N band matrix A and reduce its condition number. R returns the !! row scale factors and C the column scale factors, chosen to try to @@ -606,8 +609,8 @@ module stdlib_linalg_lapack_z ! -- 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 real(dp), intent(out) :: amax, colcnd, rowcnd ! Array Arguments real(dp), intent(out) :: c(*), r(*) @@ -615,7 +618,7 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, kd + integer(${ik}$) :: i, j, kd real(dp) :: bignum, rcmax, rcmin, smlnum complex(dp) :: zdum ! Intrinsic Functions @@ -626,38 +629,38 @@ module stdlib_linalg_lapack_z cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) ) ! Executable Statements ! 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( ldabzero ) 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. @@ -846,7 +849,7 @@ module stdlib_linalg_lapack_z c( j ) = max( c( j ), cabs1( 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. @@ -873,10 +876,10 @@ module stdlib_linalg_lapack_z colcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) end if return - end subroutine stdlib_zgbequb + end subroutine stdlib${ii}$_zgbequb - pure subroutine stdlib_zgbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) + pure subroutine stdlib${ii}$_zgbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) !! ZGBTF2 computes an LU factorization of a complex m-by-n band matrix !! A using partial pivoting with row interchanges. !! This is the unblocked version of the algorithm, calling Level 2 BLAS. @@ -884,15 +887,15 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), 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 @@ -900,20 +903,20 @@ module stdlib_linalg_lapack_z ! 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}$_zswap( 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_zscal( km, cone / ab( kv+1, j ), ab( kv+2, j ), 1 ) + call stdlib${ii}$_zscal( km, cone / ab( kv+1, j ), ab( kv+2, j ), 1_${ik}$ ) ! update trailing submatrix within the band. - if( ju>j )call stdlib_zgeru( km, ju-j, -cone, ab( kv+2, j ), 1,ab( kv, j+1 ), & + if( ju>j )call stdlib${ii}$_zgeru( km, ju-j, -cone, 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 czero, set info to the index of the pivot ! unless a czero 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_zgbtf2 + end subroutine stdlib${ii}$_zgbtf2 - pure subroutine stdlib_zgebak( job, side, n, ilo, ihi, scale, m, v, ldv,info ) + pure subroutine stdlib${ii}$_zgebak( job, side, n, ilo, ihi, scale, m, v, ldv,info ) !! ZGEBAK forms the right or left eigenvectors of a complex general !! matrix by backward transformation on the computed eigenvectors of the !! balanced matrix output by ZGEBAL. @@ -971,8 +974,8 @@ module stdlib_linalg_lapack_z ! -- 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(dp), intent(in) :: scale(*) complex(dp), intent(inout) :: v(ldv,*) @@ -980,7 +983,7 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: leftv, rightv - integer(ilp) :: i, ii, k + integer(${ik}$) :: i, ii, k real(dp) :: s ! Intrinsic Functions intrinsic :: max,min @@ -988,25 +991,25 @@ module stdlib_linalg_lapack_z ! 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( ldv=g .or. max( f, c, ca )>=sfmax2 .or.min( r, g, ra )<=sfmin2 )go to 170 - if( stdlib_disnan( c+f+ca+r+g+ra ) ) then + if( stdlib${ii}$_disnan( c+f+ca+r+g+ra ) ) then ! exit if nan to avoid infinite loop - info = -3 - call stdlib_xerbla( 'ZGEBAL', -info ) + info = -3_${ik}$ + call stdlib${ii}$_xerbla( 'ZGEBAL', -info ) return end if f = f*sclfac @@ -1218,18 +1221,18 @@ module stdlib_linalg_lapack_z g = one / f scale( i ) = scale( i )*f noconv = .true. - call stdlib_zdscal( n-k+1, g, a( i, k ), lda ) - call stdlib_zdscal( l, f, a( 1, i ), 1 ) + call stdlib${ii}$_zdscal( n-k+1, g, a( i, k ), lda ) + call stdlib${ii}$_zdscal( l, f, a( 1_${ik}$, i ), 1_${ik}$ ) end do loop_200 if( noconv )go to 140 210 continue ilo = k ihi = l return - end subroutine stdlib_zgebal + end subroutine stdlib${ii}$_zgebal - pure subroutine stdlib_zgeequ( m, n, a, lda, r, c, rowcnd, colcnd, amax,info ) + pure subroutine stdlib${ii}$_zgeequ( m, n, a, lda, r, c, rowcnd, colcnd, amax,info ) !! ZGEEQU computes row and column scalings intended to equilibrate an !! M-by-N matrix A and reduce its condition number. R returns the row !! scale factors and C the column scale factors, chosen to try to make @@ -1243,8 +1246,8 @@ module stdlib_linalg_lapack_z ! -- 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 real(dp), intent(out) :: amax, colcnd, rowcnd ! Array Arguments real(dp), intent(out) :: c(*), r(*) @@ -1252,7 +1255,7 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: bignum, rcmax, rcmin, smlnum complex(dp) :: zdum ! Intrinsic Functions @@ -1263,27 +1266,27 @@ module stdlib_linalg_lapack_z cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. - info = 0 - if( m<0 ) 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. @@ -1471,7 +1474,7 @@ module stdlib_linalg_lapack_z c( j ) = max( c( j ), cabs1( 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. @@ -1498,10 +1501,10 @@ module stdlib_linalg_lapack_z colcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) end if return - end subroutine stdlib_zgeequb + end subroutine stdlib${ii}$_zgeequb - pure subroutine stdlib_zgetc2( n, a, lda, ipiv, jpiv, info ) + pure subroutine stdlib${ii}$_zgetc2( n, a, lda, ipiv, jpiv, info ) !! ZGETC2 computes an LU factorization, using 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 @@ -1511,34 +1514,34 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ip, ipv, j, jp, jpv + integer(${ik}$) :: i, ip, ipv, j, jp, jpv real(dp) :: bignum, eps, smin, smlnum, xmax ! Intrinsic Functions intrinsic :: abs,cmplx,max ! Executable Statements - info = 0 + info = 0_${ik}$ ! quick return if possible if( n==0 )return ! set constants to control overflow - eps = stdlib_dlamch( 'P' ) - smlnum = stdlib_dlamch( 'S' ) / eps + eps = stdlib${ii}$_dlamch( 'P' ) + smlnum = stdlib${ii}$_dlamch( 'S' ) / eps bignum = one / smlnum - call stdlib_dlabad( smlnum, bignum ) + call stdlib${ii}$_dlabad( smlnum, bignum ) ! handle the case n=1 by itself - if( n==1 ) then - ipiv( 1 ) = 1 - jpiv( 1 ) = 1 - if( abs( a( 1, 1 ) )= sfmin ) then - call stdlib_zscal( m-j, cone / a( j, j ), a( j+1, j ), 1 ) + call stdlib${ii}$_zscal( m-j, cone / 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( j0 .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( ldv1 )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 k = n - 2, 1, -1 b( k, j ) = ( b( k, j )-du( k )*b( k+1, j )-dl( k )*b( k+2, j ) ) / d( k ) end do end do return - end subroutine stdlib_zgtsv + end subroutine stdlib${ii}$_zgtsv - pure subroutine stdlib_zgttrf( n, dl, d, du, du2, ipiv, info ) + pure subroutine stdlib${ii}$_zgttrf( n, dl, d, du, du2, ipiv, info ) !! ZGTTRF computes an LU factorization of a complex tridiagonal matrix A !! using elimination with partial pivoting and row interchanges. !! The factorization has the form @@ -2179,16 +2182,16 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(inout) :: d(*), dl(*), du(*) complex(dp), intent(out) :: du2(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i complex(dp) :: fact, temp, zdum ! Intrinsic Functions intrinsic :: abs,real,aimag @@ -2197,10 +2200,10 @@ module stdlib_linalg_lapack_z ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) ) ! Executable Statements - info = 0 - if( n<0 ) then - info = -1 - call stdlib_xerbla( 'ZGTTRF', -info ) + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -1_${ik}$ + call stdlib${ii}$_xerbla( 'ZGTTRF', -info ) return end if ! quick return if possible @@ -2230,11 +2233,11 @@ module stdlib_linalg_lapack_z 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( cabs1( d( i ) )>=cabs1( dl( i ) ) ) then if( cabs1( d( i ) )/=zero ) then fact = dl( i ) / d( i ) @@ -2248,7 +2251,7 @@ module stdlib_linalg_lapack_z 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. @@ -2260,10 +2263,10 @@ module stdlib_linalg_lapack_z end do 50 continue return - end subroutine stdlib_zgttrf + end subroutine stdlib${ii}$_zgttrf - pure subroutine stdlib_zgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) + pure subroutine stdlib${ii}$_zgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) !! ZGTTS2 solves one of the systems of equations !! A * X = B, A**T * X = B, or A**H * X = B, !! with a tridiagonal matrix A using the LU factorization computed @@ -2272,25 +2275,25 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(inout) :: b(ldb,*) complex(dp), intent(in) :: d(*), dl(*), du(*), du2(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j complex(dp) :: temp ! Intrinsic Functions intrinsic :: conjg ! 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 @@ -2304,13 +2307,13 @@ module stdlib_linalg_lapack_z 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 ) end do end do end if - else if( itrans==1 ) then + else if( itrans==1_${ik}$ ) then ! solve a**t * x = b. - if( nrhs<=1 ) then - j = 1 + if( nrhs<=1_${ik}$ ) then + j = 1_${ik}$ 70 continue ! solve u**t * x = b. - 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 & ) @@ -2357,14 +2360,14 @@ module stdlib_linalg_lapack_z end if 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 ) @@ -2383,12 +2386,12 @@ module stdlib_linalg_lapack_z end if else ! solve a**h * x = b. - if( nrhs<=1 ) then - j = 1 + if( nrhs<=1_${ik}$ ) then + j = 1_${ik}$ 130 continue ! solve u**h * x = b. - b( 1, j ) = b( 1, j ) / conjg( d( 1 ) ) - if( n>1 )b( 2, j ) = ( b( 2, j )-conjg( du( 1 ) )*b( 1, j ) ) /conjg( d( 2 ) ) + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / conjg( d( 1_${ik}$ ) ) + if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-conjg( du( 1_${ik}$ ) )*b( 1_${ik}$, j ) ) /conjg( d( 2_${ik}$ ) ) do i = 3, n b( i, j ) = ( b( i, j )-conjg( du( i-1 ) )*b( i-1, j )-conjg( du2( i-2 ) )*b( & @@ -2405,14 +2408,14 @@ module stdlib_linalg_lapack_z end if end do if( j1 )b( 2, j ) = ( b( 2, j )-conjg( du( 1 ) )*b( 1, j ) )/ conjg( d( 2 ) ) + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) / conjg( d( 1_${ik}$ ) ) + if( n>1_${ik}$ )b( 2_${ik}$, j ) = ( b( 2_${ik}$, j )-conjg( du( 1_${ik}$ ) )*b( 1_${ik}$, j ) )/ conjg( d( 2_${ik}$ ) ) do i = 3, n b( i, j ) = ( b( i, j )-conjg( du( i-1 ) )*b( i-1, j )-conjg( du2( i-2 ) )& @@ -2431,10 +2434,10 @@ module stdlib_linalg_lapack_z end do end if end if - end subroutine stdlib_zgtts2 + end subroutine stdlib${ii}$_zgtts2 - pure subroutine stdlib_zheswapr( uplo, n, a, lda, i1, i2) + pure subroutine stdlib${ii}$_zheswapr( uplo, n, a, lda, i1, i2) !! ZHESWAPR applies an elementary permutation on the rows and the columns of !! a hermitian matrix. ! -- lapack auxiliary routine -- @@ -2442,13 +2445,13 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: a(lda,n) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: i + integer(${ik}$) :: i complex(dp) :: tmp ! Executable Statements upper = stdlib_lsame( uplo, 'U' ) @@ -2456,7 +2459,7 @@ module stdlib_linalg_lapack_z ! upper ! first swap ! - swap column i1 and i2 from i1 to i1-1 - call stdlib_zswap( i1-1, a(1,i1), 1, a(1,i2), 1 ) + call stdlib${ii}$_zswap( 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 @@ -2481,7 +2484,7 @@ module stdlib_linalg_lapack_z ! lower ! first swap ! - swap row i1 and i2 from 1 to i1-1 - call stdlib_zswap ( i1-1, a(i1,1), lda, a(i2,1), lda ) + call stdlib${ii}$_zswap ( 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 @@ -2503,10 +2506,10 @@ module stdlib_linalg_lapack_z a(i,i2)=tmp end do endif - end subroutine stdlib_zheswapr + end subroutine stdlib${ii}$_zheswapr - pure subroutine stdlib_zhetf2( uplo, n, a, lda, ipiv, info ) + pure subroutine stdlib${ii}$_zhetf2( uplo, n, a, lda, ipiv, info ) !! ZHETF2 computes the factorization of a complex Hermitian matrix A !! using the Bunch-Kaufman diagonal pivoting method: !! A = U*D*U**H or A = L*D*L**H @@ -2519,10 +2522,10 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(inout) :: a(lda,*) ! ===================================================================== ! Parameters @@ -2531,7 +2534,7 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: upper - integer(ilp) :: i, imax, j, jmax, k, kk, kp, kstep + integer(${ik}$) :: i, imax, j, jmax, k, kk, kp, kstep real(dp) :: absakk, alpha, colmax, d, d11, d22, r1, rowmax, tt complex(dp) :: d12, d21, t, wk, wkm1, wkp1, zdum ! Intrinsic Functions @@ -2542,17 +2545,17 @@ module stdlib_linalg_lapack_z cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) ) ! 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_izamax( k-1, a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_izamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ ) colmax = cabs1( a( imax, k ) ) else colmax = zero end if - if( (max( absakk, colmax )==zero) .or. stdlib_disnan(absakk) ) then + if( (max( absakk, colmax )==zero) .or. stdlib${ii}$_disnan(absakk) ) then ! column k is zero or underflow, or contains a nan: ! set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k a( k, k ) = real( a( k, k ),KIND=dp) else @@ -2594,10 +2597,10 @@ module stdlib_linalg_lapack_z ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value. ! determine only rowmax. - jmax = imax + stdlib_izamax( k-imax, a( imax, imax+1 ), lda ) + jmax = imax + stdlib${ii}$_izamax( k-imax, a( imax, imax+1 ), lda ) rowmax = cabs1( a( imax, jmax ) ) - if( imax>1 ) then - jmax = stdlib_izamax( imax-1, a( 1, imax ), 1 ) + if( imax>1_${ik}$ ) then + jmax = stdlib${ii}$_izamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ ) rowmax = max( rowmax, cabs1( a( jmax, imax ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then @@ -2611,15 +2614,15 @@ module stdlib_linalg_lapack_z ! interchange rows and columns k-1 and imax, use 2-by-2 ! pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ end if end if ! ============================================================ - 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) - call stdlib_zswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_zswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) do j = kp + 1, kk - 1 t = conjg( a( j, kk ) ) a( j, kk ) = conjg( a( kp, j ) ) @@ -2629,7 +2632,7 @@ module stdlib_linalg_lapack_z r1 = real( a( kk, kk ),KIND=dp) a( kk, kk ) = real( a( kp, kp ),KIND=dp) a( kp, kp ) = r1 - if( kstep==2 ) then + if( kstep==2_${ik}$ ) then a( k, k ) = real( a( k, k ),KIND=dp) t = a( k-1, k ) a( k-1, k ) = a( kp, k ) @@ -2637,19 +2640,19 @@ module stdlib_linalg_lapack_z end if else a( k, k ) = real( a( k, k ),KIND=dp) - if( kstep==2 )a( k-1, k-1 ) = real( a( k-1, k-1 ),KIND=dp) + if( kstep==2_${ik}$ )a( k-1, k-1 ) = real( a( k-1, k-1 ),KIND=dp) end if ! update the leading submatrix - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u ! perform a rank-1 update of a(1:k-1,1:k-1) as ! a := a - u(k)*d(k)*u(k)**h = a - w(k)*1/d(k)*w(k)**h r1 = one / real( a( k, k ),KIND=dp) - call stdlib_zher( uplo, k-1, -r1, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_zher( uplo, k-1, -r1, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) ! store u(k) in column k - call stdlib_zdscal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_zdscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) else ! 2-by-2 pivot block d(k): columns k and k-1 now hold ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k) @@ -2658,8 +2661,8 @@ module stdlib_linalg_lapack_z ! perform a rank-2 update of a(1:k-2,1:k-2) as ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**h ! = a - ( w(k-1) w(k) )*inv(d(k))*( w(k-1) w(k) )**h - if( k>2 ) then - d = stdlib_dlapy2( real( a( k-1, k ),KIND=dp),aimag( a( k-1, k ) ) ) + if( k>2_${ik}$ ) then + d = stdlib${ii}$_dlapy2( real( a( k-1, k ),KIND=dp),aimag( a( k-1, k ) ) ) d22 = real( a( k-1, k-1 ),KIND=dp) / d d11 = real( a( k, k ),KIND=dp) / d @@ -2681,7 +2684,7 @@ module stdlib_linalg_lapack_z 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 @@ -2694,11 +2697,11 @@ module stdlib_linalg_lapack_z ! factorize a as l*d*l**h using the lower triangle of a ! k is the main loop index, increasing from 1 to n in steps of ! 1 or 2 - k = 1 + k = 1_${ik}$ 50 continue ! if k > n, exit from loop if( k>n )go to 90 - 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 absakk = abs( real( a( k, k ),KIND=dp) ) @@ -2706,15 +2709,15 @@ module stdlib_linalg_lapack_z ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k=alpha*colmax*( colmax / rowmax ) ) then @@ -2744,15 +2747,15 @@ module stdlib_linalg_lapack_z ! interchange rows and columns k+1 and imax, use 2-by-2 ! pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ end if end if ! ============================================================ - 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( kp1 ) then - imax = stdlib_izamax( k-1, a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_izamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ ) colmax = cabs1( a( imax, k ) ) else colmax = zero end if if( ( max( absakk, colmax )==zero ) ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k a( k, k ) = real( a( k, k ),KIND=dp) ! set e( k ) to zero - if( k>1 )e( k ) = czero + if( k>1_${ik}$ )e( k ) = czero else ! ============================================================ ! begin pivot search @@ -2939,13 +2942,13 @@ module stdlib_linalg_lapack_z ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = imax + stdlib_izamax( k-imax, a( imax, imax+1 ),lda ) + jmax = imax + stdlib${ii}$_izamax( k-imax, a( imax, imax+1 ),lda ) rowmax = cabs1( a( imax, jmax ) ) else rowmax = zero end if - if( imax>1 ) then - itemp = stdlib_izamax( imax-1, a( 1, imax ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_izamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ ) dtemp = cabs1( a( itemp, imax ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -2969,7 +2972,7 @@ module stdlib_linalg_lapack_z ! interchange rows and columns k-1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. ! case(4) else @@ -2984,12 +2987,12 @@ module stdlib_linalg_lapack_z ! end pivot search ! ============================================================ ! kk is the column of a where pivoting step stopped - kk = k - kstep + 1 + kk = k - kstep + 1_${ik}$ ! for only a 2x2 pivot, interchange rows and columns k and p ! in the leading submatrix a(1:k,1:k) - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! (1) swap columnar parts - if( p>1 )call stdlib_zswap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) + if( p>1_${ik}$ )call stdlib${ii}$_zswap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) ! (2) swap and conjugate middle parts do j = p + 1, k - 1 t = conjg( a( j, k ) ) @@ -3004,13 +3007,13 @@ module stdlib_linalg_lapack_z a( p, p ) = r1 ! convert upper triangle of a into u form by applying ! the interchanges in columns k+1:n. - if( k1 )call stdlib_zswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + if( kp>1_${ik}$ )call stdlib${ii}$_zswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) ! (2) swap and conjugate middle parts do j = kp + 1, kk - 1 t = conjg( a( j, kk ) ) @@ -3023,7 +3026,7 @@ module stdlib_linalg_lapack_z r1 = real( a( kk, kk ),KIND=dp) a( kk, kk ) = real( a( kp, kp ),KIND=dp) a( kp, kp ) = r1 - if( kstep==2 ) then + if( kstep==2_${ik}$ ) then ! (*) make sure that diagonal element of pivot is real a( k, k ) = real( a( k, k ),KIND=dp) ! (5) swap row elements @@ -3033,18 +3036,18 @@ module stdlib_linalg_lapack_z end if ! convert upper triangle of a into u form by applying ! the interchanges in columns k+1:n. - if( k1 ) then + if( k>1_${ik}$ ) then ! perform a rank-1 update of a(1:k-1,1:k-1) and ! store u(k) in column k if( abs( real( a( k, k ),KIND=dp) )>=sfmin ) then @@ -3052,9 +3055,9 @@ module stdlib_linalg_lapack_z ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*1/d(k)*w(k)**t d11 = one / real( a( k, k ),KIND=dp) - call stdlib_zher( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_zher( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) ! store u(k) in column k - call stdlib_zdscal( k-1, d11, a( 1, k ), 1 ) + call stdlib${ii}$_zdscal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = real( a( k, k ),KIND=dp) @@ -3065,7 +3068,7 @@ module stdlib_linalg_lapack_z ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_zher( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_zher( 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 ) = czero @@ -3079,9 +3082,9 @@ module stdlib_linalg_lapack_z ! 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 ! d = |a12| - d = stdlib_dlapy2( real( a( k-1, k ),KIND=dp),aimag( a( k-1, k ) ) ) + d = stdlib${ii}$_dlapy2( real( a( k-1, k ),KIND=dp),aimag( a( k-1, k ) ) ) d11 = real( a( k, k ) / d,KIND=dp) d22 = real( a( k-1, k-1 ) / d,KIND=dp) @@ -3112,7 +3115,7 @@ module stdlib_linalg_lapack_z ! 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 @@ -3128,11 +3131,11 @@ module stdlib_linalg_lapack_z e( n ) = czero ! k is the main loop index, increasing from 1 to n in steps of ! 1 or 2 - k = 1 + 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 @@ -3141,14 +3144,14 @@ module stdlib_linalg_lapack_z ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( krowmax ) then rowmax = dtemp @@ -3201,7 +3204,7 @@ module stdlib_linalg_lapack_z ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. ! case(4) else @@ -3216,12 +3219,12 @@ module stdlib_linalg_lapack_z ! end pivot search ! ============================================================ ! kk is the column of a where pivoting step stopped - kk = k + kstep - 1 + kk = k + kstep - 1_${ik}$ ! for only a 2x2 pivot, interchange rows and columns k and p ! in the trailing submatrix a(k:n,k:n) - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! (1) swap columnar parts - if( p1 )call stdlib_zswap( k-1, a( k, 1 ), lda, a( p, 1 ), lda ) + if ( k>1_${ik}$ )call stdlib${ii}$_zswap( k-1, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda ) end if ! for both 1x1 and 2x2 pivots, interchange rows and ! columns kk and kp in the trailing submatrix a(k:n,k:n) if( kp/=kk ) then ! (1) swap columnar parts - if( kp1 )call stdlib_zswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) + if ( k>1_${ik}$ )call stdlib${ii}$_zswap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) else ! (*) make sure that diagonal element of pivot is real a( k, k ) = real( a( k, k ),KIND=dp) - if( kstep==2 )a( k+1, k+1 ) = real( a( k+1, k+1 ),KIND=dp) + if( kstep==2_${ik}$ )a( k+1, k+1 ) = real( a( k+1, k+1 ),KIND=dp) end if ! update the trailing submatrix - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of a now holds ! w(k) = l(k)*d(k), ! where l(k) is the k-th column of l @@ -3286,10 +3289,10 @@ module stdlib_linalg_lapack_z ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t d11 = one / real( a( k, k ),KIND=dp) - call stdlib_zher( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_zher( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda ) ! store l(k) in column k - call stdlib_zdscal( n-k, d11, a( k+1, k ), 1 ) + call stdlib${ii}$_zdscal( n-k, d11, a( k+1, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = real( a( k, k ),KIND=dp) @@ -3300,7 +3303,7 @@ module stdlib_linalg_lapack_z ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_zher( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_zher( 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 @@ -3317,7 +3320,7 @@ module stdlib_linalg_lapack_z ! and store l(k) and l(k+1) in columns k and k+1 if( k1 ) then - imax = stdlib_izamax( k-1, a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_izamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ ) colmax = cabs1( a( imax, k ) ) else colmax = zero end if if( ( max( absakk, colmax )==zero ) ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k a( k, k ) = real( a( k, k ),KIND=dp) else @@ -3461,13 +3464,13 @@ module stdlib_linalg_lapack_z ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = imax + stdlib_izamax( k-imax, a( imax, imax+1 ),lda ) + jmax = imax + stdlib${ii}$_izamax( k-imax, a( imax, imax+1 ),lda ) rowmax = cabs1( a( imax, jmax ) ) else rowmax = zero end if - if( imax>1 ) then - itemp = stdlib_izamax( imax-1, a( 1, imax ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_izamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ ) dtemp = cabs1( a( itemp, imax ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -3491,7 +3494,7 @@ module stdlib_linalg_lapack_z ! interchange rows and columns k-1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. ! case(4) else @@ -3506,12 +3509,12 @@ module stdlib_linalg_lapack_z ! end pivot search ! ============================================================ ! kk is the column of a where pivoting step stopped - kk = k - kstep + 1 + kk = k - kstep + 1_${ik}$ ! for only a 2x2 pivot, interchange rows and columns k and p ! in the leading submatrix a(1:k,1:k) - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! (1) swap columnar parts - if( p>1 )call stdlib_zswap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) + if( p>1_${ik}$ )call stdlib${ii}$_zswap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) ! (2) swap and conjugate middle parts do j = p + 1, k - 1 t = conjg( a( j, k ) ) @@ -3529,7 +3532,7 @@ module stdlib_linalg_lapack_z ! columns kk and kp in the leading submatrix a(1:k,1:k) if( kp/=kk ) then ! (1) swap columnar parts - if( kp>1 )call stdlib_zswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + if( kp>1_${ik}$ )call stdlib${ii}$_zswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) ! (2) swap and conjugate middle parts do j = kp + 1, kk - 1 t = conjg( a( j, kk ) ) @@ -3542,7 +3545,7 @@ module stdlib_linalg_lapack_z r1 = real( a( kk, kk ),KIND=dp) a( kk, kk ) = real( a( kp, kp ),KIND=dp) a( kp, kp ) = r1 - if( kstep==2 ) then + if( kstep==2_${ik}$ ) then ! (*) make sure that diagonal element of pivot is real a( k, k ) = real( a( k, k ),KIND=dp) ! (5) swap row elements @@ -3553,14 +3556,14 @@ module stdlib_linalg_lapack_z else ! (*) make sure that diagonal element of pivot is real a( k, k ) = real( a( k, k ),KIND=dp) - if( kstep==2 )a( k-1, k-1 ) = real( a( k-1, k-1 ),KIND=dp) + if( kstep==2_${ik}$ )a( k-1, k-1 ) = real( a( k-1, k-1 ),KIND=dp) end if ! update the leading submatrix - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u - if( k>1 ) then + if( k>1_${ik}$ ) then ! perform a rank-1 update of a(1:k-1,1:k-1) and ! store u(k) in column k if( abs( real( a( k, k ),KIND=dp) )>=sfmin ) then @@ -3568,9 +3571,9 @@ module stdlib_linalg_lapack_z ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*1/d(k)*w(k)**t d11 = one / real( a( k, k ),KIND=dp) - call stdlib_zher( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_zher( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) ! store u(k) in column k - call stdlib_zdscal( k-1, d11, a( 1, k ), 1 ) + call stdlib${ii}$_zdscal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = real( a( k, k ),KIND=dp) @@ -3581,7 +3584,7 @@ module stdlib_linalg_lapack_z ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_zher( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_zher( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) end if end if else @@ -3593,9 +3596,9 @@ module stdlib_linalg_lapack_z ! 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 ! d = |a12| - d = stdlib_dlapy2( real( a( k-1, k ),KIND=dp),aimag( a( k-1, k ) ) ) + d = stdlib${ii}$_dlapy2( real( a( k-1, k ),KIND=dp),aimag( a( k-1, k ) ) ) d11 = real( a( k, k ) / d,KIND=dp) d22 = real( a( k-1, k-1 ) / d,KIND=dp) @@ -3620,7 +3623,7 @@ module stdlib_linalg_lapack_z 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 @@ -3633,11 +3636,11 @@ module stdlib_linalg_lapack_z ! factorize a as l*d*l**h using the lower triangle of a ! k is the main loop index, increasing from 1 to n in steps of ! 1 or 2 - k = 1 + 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 @@ -3646,14 +3649,14 @@ module stdlib_linalg_lapack_z ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( krowmax ) then rowmax = dtemp @@ -3704,7 +3707,7 @@ module stdlib_linalg_lapack_z ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. ! case(4) else @@ -3719,12 +3722,12 @@ module stdlib_linalg_lapack_z ! end pivot search ! ============================================================ ! kk is the column of a where pivoting step stopped - kk = k + kstep - 1 + kk = k + kstep - 1_${ik}$ ! for only a 2x2 pivot, interchange rows and columns k and p ! in the trailing submatrix a(k:n,k:n) - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! (1) swap columnar parts - if( p0 .and. a( info, info )==czero )return end do end if - info = 0 + info = 0_${ik}$ if( upper ) then ! compute inv(a) from the factorization a = u*d*u**h. ! 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 = 1_${ik}$ 30 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = one / real( a( k, k ),KIND=dp) ! compute column k of the inverse. - if( k>1 ) then - call stdlib_zcopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_zhemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_zcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_zhemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - real( stdlib_zdotc( k-1, work, 1, a( 1,k ), 1 ),& + a( k, k ) = a( k, k ) - real( stdlib${ii}$_zdotc( k-1, work, 1_${ik}$, a( 1_${ik}$,k ), 1_${ik}$ ),& KIND=dp) end if - kstep = 1 + kstep = 1_${ik}$ else ! 2 x 2 diagonal block ! invert the diagonal block. @@ -3940,27 +3943,27 @@ module stdlib_linalg_lapack_z 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_zcopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_zhemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_zcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_zhemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - real( stdlib_zdotc( k-1, work, 1, a( 1,k ), 1 ),& + a( k, k ) = a( k, k ) - real( stdlib${ii}$_zdotc( k-1, work, 1_${ik}$, a( 1_${ik}$,k ), 1_${ik}$ ),& KIND=dp) - a( k, k+1 ) = a( k, k+1 ) -stdlib_zdotc( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) + a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_zdotc( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) - call stdlib_zcopy( k-1, a( 1, k+1 ), 1, work, 1 ) - call stdlib_zhemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k+1 ), 1 ) + call stdlib${ii}$_zcopy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_zhemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k+1 ), 1_${ik}$ ) - a( k+1, k+1 ) = a( k+1, k+1 ) -real( stdlib_zdotc( k-1, work, 1, a( 1, k+1 ),& - 1 ),KIND=dp) + a( k+1, k+1 ) = a( k+1, k+1 ) -real( stdlib${ii}$_zdotc( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ),& + 1_${ik}$ ),KIND=dp) 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_zswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_zswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) do j = kp + 1, k - 1 temp = conjg( a( j, k ) ) a( j, k ) = conjg( a( kp, j ) ) @@ -3970,7 +3973,7 @@ module stdlib_linalg_lapack_z 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 @@ -3987,19 +3990,19 @@ module stdlib_linalg_lapack_z 60 continue ! if k < 1, exit from loop. if( k<1 )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = one / real( a( k, k ),KIND=dp) ! compute column k of the inverse. if( k0 .and. a( info, info )==czero )return end do end if - info = 0 + info = 0_${ik}$ if( upper ) then ! compute inv(a) from the factorization a = u*d*u**h. ! 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 = 1_${ik}$ 30 continue ! if k > n, exit from loop. if( k>n )go to 70 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = one / real( a( k, k ),KIND=dp) ! compute column k of the inverse. - if( k>1 ) then - call stdlib_zcopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_zhemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_zcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_zhemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - real( stdlib_zdotc( k-1, work, 1, a( 1,k ), 1 ),& + a( k, k ) = a( k, k ) - real( stdlib${ii}$_zdotc( k-1, work, 1_${ik}$, a( 1_${ik}$,k ), 1_${ik}$ ),& KIND=dp) end if - kstep = 1 + kstep = 1_${ik}$ else ! 2 x 2 diagonal block ! invert the diagonal block. @@ -4144,28 +4147,28 @@ module stdlib_linalg_lapack_z 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_zcopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_zhemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_zcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_zhemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - real( stdlib_zdotc( k-1, work, 1, a( 1,k ), 1 ),& + a( k, k ) = a( k, k ) - real( stdlib${ii}$_zdotc( k-1, work, 1_${ik}$, a( 1_${ik}$,k ), 1_${ik}$ ),& KIND=dp) - a( k, k+1 ) = a( k, k+1 ) -stdlib_zdotc( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) + a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_zdotc( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) - call stdlib_zcopy( k-1, a( 1, k+1 ), 1, work, 1 ) - call stdlib_zhemv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k+1 ), 1 ) + call stdlib${ii}$_zcopy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_zhemv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k+1 ), 1_${ik}$ ) - a( k+1, k+1 ) = a( k+1, k+1 ) -real( stdlib_zdotc( k-1, work, 1, a( 1, k+1 ),& - 1 ),KIND=dp) + a( k+1, k+1 ) = a( k+1, k+1 ) -real( stdlib${ii}$_zdotc( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ),& + 1_${ik}$ ),KIND=dp) 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:k) kp = ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_zswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) + if( kp>1_${ik}$ )call stdlib${ii}$_zswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) do j = kp + 1, k - 1 temp = conjg( a( j, k ) ) a( j, k ) = conjg( a( kp, j ) ) @@ -4182,7 +4185,7 @@ module stdlib_linalg_lapack_z ! (1) interchange rows and columns k and -ipiv(k) kp = -ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_zswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) + if( kp>1_${ik}$ )call stdlib${ii}$_zswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) do j = kp + 1, k - 1 temp = conjg( a( j, k ) ) a( j, k ) = conjg( a( kp, j ) ) @@ -4197,10 +4200,10 @@ module stdlib_linalg_lapack_z a( kp, k+1 ) = temp end if ! (2) interchange rows and columns k+1 and -ipiv(k+1) - k = k + 1 + k = k + 1_${ik}$ kp = -ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_zswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) + if( kp>1_${ik}$ )call stdlib${ii}$_zswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) do j = kp + 1, k - 1 temp = conjg( a( j, k ) ) a( j, k ) = conjg( a( kp, j ) ) @@ -4212,7 +4215,7 @@ module stdlib_linalg_lapack_z a( kp, kp ) = temp end if end if - k = k + 1 + k = k + 1_${ik}$ go to 30 70 continue else @@ -4223,19 +4226,19 @@ module stdlib_linalg_lapack_z 80 continue ! if k < 1, exit from loop. if( k<1 )go to 120 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = one / real( a( k, k ),KIND=dp) ! compute column k of the inverse. if( k b [ (u \p**t * b) ] - call stdlib_ztrsm( 'L', 'U', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib${ii}$_ztrsm( 'L', 'U', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) ! compute d \ b -> b [ d \ (u \p**t * b) ] i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then + if( ipiv( i )>0_${ik}$ ) then s = real( cone,KIND=dp) / real( a( i, i ),KIND=dp) - call stdlib_zdscal( nrhs, s, b( i, 1 ), ldb ) - else if ( i>1 ) then + call stdlib${ii}$_zdscal( nrhs, s, 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 ) / conjg( akm1k ) @@ -4408,12 +4411,12 @@ module stdlib_linalg_lapack_z 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**h \ b) -> b [ u**h \ (d \ (u \p**t * b) ) ] - call stdlib_ztrsm( 'L', 'U', 'C', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib${ii}$_ztrsm( 'L', 'U', 'C', 'U', n, nrhs, cone, a, lda, b, ldb ) ! p * b [ p * (u**h \ (d \ (u \p**t * b) )) ] ! interchange rows k and ipiv(k) of matrix b in reverse order ! from the formation order of ipiv(i) vector for upper case. @@ -4423,7 +4426,7 @@ module stdlib_linalg_lapack_z do k = 1, n, 1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end if end do else @@ -4438,17 +4441,17 @@ module stdlib_linalg_lapack_z do k = 1, n, 1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib${ii}$_zswap( 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_ztrsm( 'L', 'L', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib${ii}$_ztrsm( 'L', 'L', 'N', 'U', n, nrhs, cone, 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 + if( ipiv( i )>0_${ik}$ ) then s = real( cone,KIND=dp) / real( a( i, i ),KIND=dp) - call stdlib_zdscal( nrhs, s, b( i, 1 ), ldb ) + call stdlib${ii}$_zdscal( nrhs, s, b( i, 1_${ik}$ ), ldb ) else if( i b [ l**h \ (d \ (l \p**t * b) ) ] - call stdlib_ztrsm('L', 'L', 'C', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib${ii}$_ztrsm('L', 'L', 'C', 'U', n, nrhs, cone, a, lda, b, ldb ) ! p * b [ p * (l**h \ (d \ (l \p**t * b) )) ] ! interchange rows k and ipiv(k) of matrix b in reverse order ! from the formation order of ipiv(i) vector for lower case. @@ -4475,16 +4478,16 @@ module stdlib_linalg_lapack_z do k = n, 1, -1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end if end do ! end lower end if return - end subroutine stdlib_zhetrs_3 + end subroutine stdlib${ii}$_zhetrs_3 - pure subroutine stdlib_zhfrk( transr, uplo, trans, n, k, alpha, a, lda, beta,c ) + pure subroutine stdlib${ii}$_zhfrk( transr, uplo, trans, n, k, alpha, a, lda, beta,c ) !! Level 3 BLAS like routine for C in RFP Format. !! ZHFRK performs one of the Hermitian rank--k operations !! C := alpha*A*A**H + beta*C, @@ -4498,7 +4501,7 @@ module stdlib_linalg_lapack_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, n + integer(${ik}$), intent(in) :: k, lda, n character, intent(in) :: trans, transr, uplo ! Array Arguments complex(dp), intent(in) :: a(lda,*) @@ -4508,13 +4511,13 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: lower, normaltransr, nisodd, notrans - integer(ilp) :: info, nrowa, j, nk, n1, n2 + integer(${ik}$) :: info, nrowa, j, nk, n1, n2 complex(dp) :: calpha, cbeta ! Intrinsic Functions intrinsic :: max,cmplx ! 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' ) @@ -4524,26 +4527,26 @@ module stdlib_linalg_lapack_z nrowa = k end if if( .not.normaltransr .and. .not.stdlib_lsame( transr, 'C' ) ) 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, 'C' ) ) 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( 'ZHPGST', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZHPGST', -info ) return end if - if( itype==1 ) then + if( itype==1_${ik}$ ) then if( upper ) then ! compute inv(u**h)*a*inv(u) ! j1 and jj are the indices of a(1,j) and a(j,j) - jj = 0 + 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 ap( jj ) = real( ap( jj ),KIND=dp) bjj = real( bp( jj ),KIND=dp) - call stdlib_ztpsv( uplo, 'CONJUGATE TRANSPOSE', 'NON-UNIT', j,bp, ap( j1 ), 1 & + call stdlib${ii}$_ztpsv( uplo, 'CONJUGATE TRANSPOSE', 'NON-UNIT', j,bp, ap( j1 ), 1_${ik}$ & ) - call stdlib_zhpmv( uplo, j-1, -cone, ap, bp( j1 ), 1, cone,ap( j1 ), 1 ) + call stdlib${ii}$_zhpmv( uplo, j-1, -cone, ap, bp( j1 ), 1_${ik}$, cone,ap( j1 ), 1_${ik}$ ) - call stdlib_zdscal( j-1, one / bjj, ap( j1 ), 1 ) - ap( jj ) = ( ap( jj )-stdlib_zdotc( j-1, ap( j1 ), 1, bp( j1 ),1 ) ) / & + call stdlib${ii}$_zdscal( j-1, one / bjj, ap( j1 ), 1_${ik}$ ) + ap( jj ) = ( ap( jj )-stdlib${ii}$_zdotc( j-1, ap( j1 ), 1_${ik}$, bp( j1 ),1_${ik}$ ) ) / & bjj end do else ! compute inv(l)*a*inv(l**h) ! 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 = real( ap( kk ),KIND=dp) bkk = real( bp( kk ),KIND=dp) - akk = akk / bkk**2 + akk = akk / bkk**2_${ik}$ ap( kk ) = akk if( k1 ) then - imax = stdlib_izamax( k-1, ap( kc ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_izamax( k-1, ap( kc ), 1_${ik}$ ) colmax = cabs1( 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 ap( kc+k-1 ) = real( ap( kc+k-1 ),KIND=dp) else @@ -4957,7 +4960,7 @@ module stdlib_linalg_lapack_z ! element in row imax, and rowmax is its absolute value rowmax = zero jmax = imax - kx = imax*( imax+1 ) / 2 + imax + kx = imax*( imax+1 ) / 2_${ik}$ + imax do j = imax + 1, k if( cabs1( ap( kx ) )>rowmax ) then rowmax = cabs1( ap( kx ) ) @@ -4965,9 +4968,9 @@ module stdlib_linalg_lapack_z end if kx = kx + j end do - kpc = ( imax-1 )*imax / 2 + 1 - if( imax>1 ) then - jmax = stdlib_izamax( imax-1, ap( kpc ), 1 ) + kpc = ( imax-1 )*imax / 2_${ik}$ + 1_${ik}$ + if( imax>1_${ik}$ ) then + jmax = stdlib${ii}$_izamax( imax-1, ap( kpc ), 1_${ik}$ ) rowmax = max( rowmax, cabs1( ap( kpc+jmax-1 ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then @@ -4981,18 +4984,18 @@ module stdlib_linalg_lapack_z ! interchange rows and columns k-1 and imax, use 2-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_zswap( kp-1, ap( knc ), 1, ap( kpc ), 1 ) - kx = kpc + kp - 1 + call stdlib${ii}$_zswap( 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 = conjg( ap( knc+j-1 ) ) ap( knc+j-1 ) = conjg( ap( kx ) ) ap( kx ) = t @@ -5001,7 +5004,7 @@ module stdlib_linalg_lapack_z r1 = real( ap( knc+kk-1 ),KIND=dp) ap( knc+kk-1 ) = real( ap( kpc+kp-1 ),KIND=dp) ap( kpc+kp-1 ) = r1 - if( kstep==2 ) then + if( kstep==2_${ik}$ ) then ap( kc+k-1 ) = real( ap( kc+k-1 ),KIND=dp) t = ap( kc+k-2 ) ap( kc+k-2 ) = ap( kc+kp-1 ) @@ -5009,19 +5012,19 @@ module stdlib_linalg_lapack_z end if else ap( kc+k-1 ) = real( ap( kc+k-1 ),KIND=dp) - if( kstep==2 )ap( kc-1 ) = real( ap( kc-1 ),KIND=dp) + if( kstep==2_${ik}$ )ap( kc-1 ) = real( ap( kc-1 ),KIND=dp) end if ! update the leading submatrix - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u ! perform a rank-1 update of a(1:k-1,1:k-1) as ! a := a - u(k)*d(k)*u(k)**h = a - w(k)*1/d(k)*w(k)**h r1 = one / real( ap( kc+k-1 ),KIND=dp) - call stdlib_zhpr( uplo, k-1, -r1, ap( kc ), 1, ap ) + call stdlib${ii}$_zhpr( uplo, k-1, -r1, ap( kc ), 1_${ik}$, ap ) ! store u(k) in column k - call stdlib_zdscal( k-1, r1, ap( kc ), 1 ) + call stdlib${ii}$_zdscal( k-1, r1, ap( kc ), 1_${ik}$ ) else ! 2-by-2 pivot block d(k): columns k and k-1 now hold ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k) @@ -5030,33 +5033,33 @@ module stdlib_linalg_lapack_z ! perform a rank-2 update of a(1:k-2,1:k-2) as ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**h ! = a - ( w(k-1) w(k) )*inv(d(k))*( w(k-1) w(k) )**h - if( k>2 ) then - d = stdlib_dlapy2( real( ap( k-1+( k-1 )*k / 2 ),KIND=dp),aimag( ap( k-1+( & - k-1 )*k / 2 ) ) ) - d22 = real( ap( k-1+( k-2 )*( k-1 ) / 2 ),KIND=dp) / d - d11 = real( ap( k+( k-1 )*k / 2 ),KIND=dp) / d + if( k>2_${ik}$ ) then + d = stdlib${ii}$_dlapy2( real( ap( k-1+( k-1 )*k / 2_${ik}$ ),KIND=dp),aimag( ap( k-1+( & + k-1 )*k / 2_${ik}$ ) ) ) + d22 = real( ap( k-1+( k-2 )*( k-1 ) / 2_${ik}$ ),KIND=dp) / d + d11 = real( ap( k+( k-1 )*k / 2_${ik}$ ),KIND=dp) / d tt = one / ( d11*d22-one ) - d12 = ap( k-1+( k-1 )*k / 2 ) / d + d12 = ap( k-1+( k-1 )*k / 2_${ik}$ ) / d d = tt / d do j = k - 2, 1, -1 - wkm1 = d*( d11*ap( j+( k-2 )*( k-1 ) / 2 )-conjg( d12 )*ap( j+( k-1 )*k & - / 2 ) ) - wk = d*( d22*ap( j+( k-1 )*k / 2 )-d12*ap( j+( k-2 )*( k-1 ) / 2 ) ) + wkm1 = d*( d11*ap( j+( k-2 )*( k-1 ) / 2_${ik}$ )-conjg( d12 )*ap( j+( k-1 )*k & + / 2_${ik}$ ) ) + wk = d*( d22*ap( j+( k-1 )*k / 2_${ik}$ )-d12*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 )& - *conjg( wk ) -ap( i+( k-2 )*( k-1 ) / 2 )*conjg( wkm1 ) + ap( i+( j-1 )*j / 2_${ik}$ ) = ap( i+( j-1 )*j / 2_${ik}$ ) -ap( i+( k-1 )*k / 2_${ik}$ )& + *conjg( wk ) -ap( i+( k-2 )*( k-1 ) / 2_${ik}$ )*conjg( wkm1 ) end do - ap( j+( k-1 )*k / 2 ) = wk - ap( j+( k-2 )*( k-1 ) / 2 ) = wkm1 - ap( j+( j-1 )*j / 2 ) = cmplx( real( ap( j+( j-1 )*j / 2 ),KIND=dp), & + ap( j+( k-1 )*k / 2_${ik}$ ) = wk + ap( j+( k-2 )*( k-1 ) / 2_${ik}$ ) = wkm1 + ap( j+( j-1 )*j / 2_${ik}$ ) = cmplx( real( ap( j+( j-1 )*j / 2_${ik}$ ),KIND=dp), & zero,KIND=dp) 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 @@ -5070,28 +5073,28 @@ module stdlib_linalg_lapack_z ! factorize a as l*d*l**h using the lower triangle of a ! k is the main loop index, increasing from 1 to n in steps of ! 1 or 2 - k = 1 - kc = 1 - npp = n*( n+1 ) / 2 + 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 absakk = abs( real( ap( kc ),KIND=dp) ) ! imax is the row-index of the largest off-diagonal element in ! column k, and colmax is its absolute value if( k=alpha*colmax*( colmax / rowmax ) ) then @@ -5126,19 +5129,19 @@ module stdlib_linalg_lapack_z ! interchange rows and columns k+1 and imax, use 2-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 )==czero )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 )==czero )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**h. ! 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 = 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. ap( kc+k-1 ) = one / real( ap( kc+k-1 ),KIND=dp) ! compute column k of the inverse. - if( k>1 ) then - call stdlib_zcopy( k-1, ap( kc ), 1, work, 1 ) - call stdlib_zhpmv( uplo, k-1, -cone, ap, work, 1, czero,ap( kc ), 1 ) - ap( kc+k-1 ) = ap( kc+k-1 ) -real( stdlib_zdotc( k-1, work, 1, ap( kc ), 1 ),& + if( k>1_${ik}$ ) then + call stdlib${ii}$_zcopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_zhpmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kc ), 1_${ik}$ ) + ap( kc+k-1 ) = ap( kc+k-1 ) -real( stdlib${ii}$_zdotc( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ ),& KIND=dp) end if - kstep = 1 + kstep = 1_${ik}$ else ! 2 x 2 diagonal block ! invert the diagonal block. @@ -5314,31 +5317,31 @@ module stdlib_linalg_lapack_z 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_zcopy( k-1, ap( kc ), 1, work, 1 ) - call stdlib_zhpmv( uplo, k-1, -cone, ap, work, 1, czero,ap( kc ), 1 ) - ap( kc+k-1 ) = ap( kc+k-1 ) -real( stdlib_zdotc( k-1, work, 1, ap( kc ), 1 ),& + if( k>1_${ik}$ ) then + call stdlib${ii}$_zcopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_zhpmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kc ), 1_${ik}$ ) + ap( kc+k-1 ) = ap( kc+k-1 ) -real( stdlib${ii}$_zdotc( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ ),& KIND=dp) - ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib_zdotc( k-1, ap( kc ), 1, ap( & - kcnext ),1 ) - call stdlib_zcopy( k-1, ap( kcnext ), 1, work, 1 ) - call stdlib_zhpmv( uplo, k-1, -cone, ap, work, 1, czero,ap( kcnext ), 1 ) + ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib${ii}$_zdotc( k-1, ap( kc ), 1_${ik}$, ap( & + kcnext ),1_${ik}$ ) + call stdlib${ii}$_zcopy( k-1, ap( kcnext ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_zhpmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kcnext ), 1_${ik}$ ) - ap( kcnext+k ) = ap( kcnext+k ) -real( stdlib_zdotc( k-1, work, 1, ap( kcnext & - ),1 ),KIND=dp) + ap( kcnext+k ) = ap( kcnext+k ) -real( stdlib${ii}$_zdotc( k-1, work, 1_${ik}$, ap( kcnext & + ),1_${ik}$ ),KIND=dp) 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_zswap( kp-1, ap( kc ), 1, ap( kpc ), 1 ) - kx = kpc + kp - 1 + kpc = ( kp-1 )*kp / 2_${ik}$ + 1_${ik}$ + call stdlib${ii}$_zswap( kp-1, ap( kc ), 1_${ik}$, ap( kpc ), 1_${ik}$ ) + kx = kpc + kp - 1_${ik}$ do j = kp + 1, k - 1 - kx = kx + j - 1 + kx = kx + j - 1_${ik}$ temp = conjg( ap( kc+j-1 ) ) ap( kc+j-1 ) = conjg( ap( kx ) ) ap( kx ) = temp @@ -5347,7 +5350,7 @@ module stdlib_linalg_lapack_z 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 @@ -5361,26 +5364,26 @@ module stdlib_linalg_lapack_z ! compute inv(a) from the factorization a = l*d*l**h. ! 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 + 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. ap( kc ) = one / real( ap( kc ),KIND=dp) ! compute column k of the inverse. if( km-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_dlamch( 'SAFE MINIMUM' ) + safe1 = stdlib${ii}$_dlamch( '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 == czero ) then symb_zero = .true. @@ -5583,7 +5586,7 @@ module stdlib_linalg_lapack_z end do end if else - if( trans==stdlib_ilatrans( 'N' ) )then + if( trans==stdlib${ii}$_ilatrans( 'N' ) )then do i = 1, leny if ( beta == czero ) then symb_zero = .true. @@ -5634,10 +5637,10 @@ module stdlib_linalg_lapack_z end if end if return - end subroutine stdlib_zla_gbamv + end subroutine stdlib${ii}$_zla_gbamv - pure real(dp) function stdlib_zla_gbrpvgrw( n, kl, ku, ncols, ab,ldab, afb, ldafb ) + pure real(dp) function stdlib${ii}$_zla_gbrpvgrw( n, kl, ku, ncols, ab,ldab, afb, ldafb ) !! ZLA_GBRPVGRW computes the reciprocal pivot growth factor !! norm(A)/norm(U). The "max absolute element" norm is used. If this is !! much less than 1, the stability of the LU factorization of the @@ -5648,12 +5651,12 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(in) :: ab(ldab,*), afb(ldafb,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, kd + integer(${ik}$) :: i, j, kd real(dp) :: amax, umax, rpvgrw complex(dp) :: zdum ! Intrinsic Functions @@ -5664,7 +5667,7 @@ module stdlib_linalg_lapack_z cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) ) ! Executable Statements rpvgrw = one - kd = ku + 1 + kd = ku + 1_${ik}$ do j = 1, ncols amax = zero umax = zero @@ -5678,11 +5681,11 @@ module stdlib_linalg_lapack_z rpvgrw = min( amax / umax, rpvgrw ) end if end do - stdlib_zla_gbrpvgrw = rpvgrw - end function stdlib_zla_gbrpvgrw + stdlib${ii}$_zla_gbrpvgrw = rpvgrw + end function stdlib${ii}$_zla_gbrpvgrw - subroutine stdlib_zla_geamv( trans, m, n, alpha, a, lda, x, incx, beta,y, incy ) + subroutine stdlib${ii}$_zla_geamv( trans, m, n, alpha, a, lda, x, incx, beta,y, incy ) !! ZLA_GEAMV performs one of the matrix-vector operations !! y := alpha*abs(A)*abs(x) + beta*abs(y), !! or y := alpha*abs(A)**T*abs(x) + beta*abs(y), @@ -5701,8 +5704,8 @@ module stdlib_linalg_lapack_z ! -- 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(ilp), intent(in) :: trans + integer(${ik}$), intent(in) :: incx, incy, lda, m, n + integer(${ik}$), intent(in) :: trans ! Array Arguments complex(dp), intent(in) :: a(lda,*), x(*) real(dp), intent(inout) :: y(*) @@ -5711,7 +5714,7 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: symb_zero real(dp) :: temp, safe1 - integer(ilp) :: i, info, iy, j, jx, kx, ky, lenx, leny + integer(${ik}$) :: i, info, iy, j, jx, kx, ky, lenx, leny complex(dp) :: cdum ! Intrinsic Functions intrinsic :: max,abs,real,aimag,sign @@ -5721,57 +5724,57 @@ module stdlib_linalg_lapack_z cabs1( cdum ) = abs( real( cdum,KIND=dp) ) + abs( aimag( cdum ) ) ! 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( lda0 )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_dlamch( 'SAFE MINIMUM' ) + safe1 = stdlib${ii}$_dlamch( '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 == czero ) then symb_zero = .true. @@ -5817,7 +5820,7 @@ module stdlib_linalg_lapack_z end do end if else - if( trans==stdlib_ilatrans( 'N' ) )then + if( trans==stdlib${ii}$_ilatrans( 'N' ) )then do i = 1, leny if ( beta == czero ) then symb_zero = .true. @@ -5868,10 +5871,10 @@ module stdlib_linalg_lapack_z end if end if return - end subroutine stdlib_zla_geamv + end subroutine stdlib${ii}$_zla_geamv - pure real(dp) function stdlib_zla_gerpvgrw( n, ncols, a, lda, af,ldaf ) + pure real(dp) function stdlib${ii}$_zla_gerpvgrw( n, ncols, a, lda, af,ldaf ) !! ZLA_GERPVGRW computes the reciprocal pivot growth factor !! norm(A)/norm(U). The "max absolute element" norm is used. If this is !! much less than 1, the stability of the LU factorization of the @@ -5882,12 +5885,12 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(in) :: a(lda,*), af(ldaf,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: amax, umax, rpvgrw complex(dp) :: zdum ! Intrinsic Functions @@ -5911,11 +5914,11 @@ module stdlib_linalg_lapack_z rpvgrw = min( amax / umax, rpvgrw ) end if end do - stdlib_zla_gerpvgrw = rpvgrw - end function stdlib_zla_gerpvgrw + stdlib${ii}$_zla_gerpvgrw = rpvgrw + end function stdlib${ii}$_zla_gerpvgrw - subroutine stdlib_zla_heamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy ) + subroutine stdlib${ii}$_zla_heamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy ) !! ZLA_SYAMV performs the matrix-vector operation !! y := alpha*abs(A)*abs(x) + beta*abs(y), !! where alpha and beta are scalars, x and y are vectors and A is an @@ -5933,7 +5936,7 @@ module stdlib_linalg_lapack_z ! -- 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, uplo + integer(${ik}$), intent(in) :: incx, incy, lda, n, uplo ! Array Arguments complex(dp), intent(in) :: a(lda,*), x(*) real(dp), intent(inout) :: y(*) @@ -5942,7 +5945,7 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: symb_zero real(dp) :: temp, safe1 - integer(ilp) :: i, info, iy, j, jx, kx, ky + integer(${ik}$) :: i, info, iy, j, jx, kx, ky complex(dp) :: zdum ! Intrinsic Functions intrinsic :: max,abs,sign,real,aimag @@ -5952,46 +5955,46 @@ module stdlib_linalg_lapack_z cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag ( zdum ) ) ! Executable Statements ! test the input parameters. - info = 0 - if ( uplo/=stdlib_ilauplo( 'U' ) .and.uplo/=stdlib_ilauplo( 'L' ) )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_dlamch( 'SAFE MINIMUM' ) + safe1 = stdlib${ii}$_dlamch( '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 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. @@ -6045,7 +6048,7 @@ module stdlib_linalg_lapack_z 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. @@ -6106,10 +6109,10 @@ module stdlib_linalg_lapack_z end if end if return - end subroutine stdlib_zla_heamv + end subroutine stdlib${ii}$_zla_heamv - pure subroutine stdlib_zla_lin_berr( n, nz, nrhs, res, ayb, berr ) + pure subroutine stdlib${ii}$_zla_lin_berr( n, nz, nrhs, res, ayb, berr ) !! ZLA_LIN_BERR computes componentwise relative backward error from !! the formula !! max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) @@ -6119,7 +6122,7 @@ module stdlib_linalg_lapack_z ! -- 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, nz, nrhs + integer(${ik}$), intent(in) :: n, nz, nrhs ! Array Arguments real(dp), intent(in) :: ayb(n,nrhs) real(dp), intent(out) :: berr(nrhs) @@ -6127,7 +6130,7 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! Local Scalars real(dp) :: tmp,safe1 - integer(ilp) :: i, j + integer(${ik}$) :: i, j complex(dp) :: cdum ! Intrinsic Functions intrinsic :: abs,real,aimag,max @@ -6139,7 +6142,7 @@ module stdlib_linalg_lapack_z ! adding safe1 to the numerator guards against spuriously zero ! residuals. a similar safeguard is in the cla_yyamv routine used ! to compute ayb. - safe1 = stdlib_dlamch( 'SAFE MINIMUM' ) + safe1 = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) safe1 = (nz+1)*safe1 do j = 1, nrhs berr(j) = zero @@ -6152,10 +6155,10 @@ module stdlib_linalg_lapack_z ! the true residual also must be exactly zero. end do end do - end subroutine stdlib_zla_lin_berr + end subroutine stdlib${ii}$_zla_lin_berr - real(dp) function stdlib_zla_porpvgrw( uplo, ncols, a, lda, af,ldaf, work ) + real(dp) function stdlib${ii}$_zla_porpvgrw( uplo, ncols, a, lda, af,ldaf, work ) !! ZLA_PORPVGRW computes the reciprocal pivot growth factor !! norm(A)/norm(U). The "max absolute element" norm is used. If this is !! much less than 1, the stability of the LU factorization of the @@ -6167,13 +6170,13 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: ncols, lda, ldaf + integer(${ik}$), intent(in) :: ncols, lda, ldaf ! Array Arguments complex(dp), intent(in) :: a(lda,*), af(ldaf,*) real(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: amax, umax, rpvgrw logical(lk) :: upper complex(dp) :: zdum @@ -6185,7 +6188,7 @@ module stdlib_linalg_lapack_z cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) ) ! Executable Statements upper = stdlib_lsame( 'UPPER', uplo ) - ! stdlib_dpotrf will have factored only the ncolsxncols leading minor, so + ! stdlib${ii}$_dpotrf will have factored only the ncolsxncols leading minor, so ! we restrict the growth search to that minor and use only the first ! 2*ncols workspace entries. rpvgrw = one @@ -6244,11 +6247,11 @@ module stdlib_linalg_lapack_z end if end do end if - stdlib_zla_porpvgrw = rpvgrw - end function stdlib_zla_porpvgrw + stdlib${ii}$_zla_porpvgrw = rpvgrw + end function stdlib${ii}$_zla_porpvgrw - subroutine stdlib_zla_syamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy ) + subroutine stdlib${ii}$_zla_syamv( uplo, n, alpha, a, lda, x, incx, beta, y,incy ) !! ZLA_SYAMV performs the matrix-vector operation !! y := alpha*abs(A)*abs(x) + beta*abs(y), !! where alpha and beta are scalars, x and y are vectors and A is an @@ -6266,8 +6269,8 @@ module stdlib_linalg_lapack_z ! -- 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(ilp), intent(in) :: uplo + integer(${ik}$), intent(in) :: incx, incy, lda, n + integer(${ik}$), intent(in) :: uplo ! Array Arguments complex(dp), intent(in) :: a(lda,*), x(*) real(dp), intent(inout) :: y(*) @@ -6276,7 +6279,7 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: symb_zero real(dp) :: temp, safe1 - integer(ilp) :: i, info, iy, j, jx, kx, ky + integer(${ik}$) :: i, info, iy, j, jx, kx, ky complex(dp) :: zdum ! Intrinsic Functions intrinsic :: max,abs,sign,real,aimag @@ -6286,46 +6289,46 @@ module stdlib_linalg_lapack_z cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag ( zdum ) ) ! Executable Statements ! test the input parameters. - info = 0 - if ( uplo/=stdlib_ilauplo( 'U' ) .and.uplo/=stdlib_ilauplo( 'L' ) )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_dlamch( 'SAFE MINIMUM' ) + safe1 = stdlib${ii}$_dlamch( '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 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. @@ -6379,7 +6382,7 @@ module stdlib_linalg_lapack_z 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. @@ -6440,10 +6443,10 @@ module stdlib_linalg_lapack_z end if end if return - end subroutine stdlib_zla_syamv + end subroutine stdlib${ii}$_zla_syamv - pure subroutine stdlib_zla_wwaddw( n, x, y, w ) + pure subroutine stdlib${ii}$_zla_wwaddw( n, x, y, w ) !! ZLA_WWADDW adds a vector W into a doubled-single vector (X, Y). !! This works for all extant IBM's hex and binary floating point !! arithmetic, but not for decimal. @@ -6451,14 +6454,14 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: x(*), y(*) complex(dp), intent(in) :: w(*) ! ===================================================================== ! Local Scalars complex(dp) :: s - integer(ilp) :: i + integer(${ik}$) :: i ! Executable Statements do 10 i = 1, n s = x(i) + w(i) @@ -6467,86 +6470,86 @@ module stdlib_linalg_lapack_z x(i) = s 10 continue return - end subroutine stdlib_zla_wwaddw + end subroutine stdlib${ii}$_zla_wwaddw - pure subroutine stdlib_zlacgv( n, x, incx ) + pure subroutine stdlib${ii}$_zlacgv( n, x, incx ) !! ZLACGV conjugates a complex vector of length 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 - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n ! Array Arguments complex(dp), intent(inout) :: x(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ioff + integer(${ik}$) :: i, ioff ! Intrinsic Functions intrinsic :: conjg ! Executable Statements - if( incx==1 ) then + if( incx==1_${ik}$ ) then do i = 1, n x( i ) = conjg( x( i ) ) end do else - ioff = 1 - if( incx<0 )ioff = 1 - ( n-1 )*incx + ioff = 1_${ik}$ + if( incx<0_${ik}$ )ioff = 1_${ik}$ - ( n-1 )*incx do i = 1, n x( ioff ) = conjg( x( ioff ) ) ioff = ioff + incx end do end if return - end subroutine stdlib_zlacgv + end subroutine stdlib${ii}$_zlacgv - pure subroutine stdlib_zlacn2( n, v, x, est, kase, isave ) + pure subroutine stdlib${ii}$_zlacn2( n, v, x, est, kase, isave ) !! ZLACN2 estimates the 1-norm of a square, complex 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(dp), intent(inout) :: est ! Array Arguments - integer(ilp), intent(inout) :: isave(3) + integer(${ik}$), intent(inout) :: isave(3_${ik}$) complex(dp), intent(out) :: v(*) complex(dp), 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(dp) :: absxi, altsgn, estold, safmin, temp ! Intrinsic Functions intrinsic :: abs,real,cmplx,aimag ! Executable Statements - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) - if( kase==0 ) then + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) + if( kase==0_${ik}$ ) then do i = 1, n x( i ) = cmplx( one / real( n,KIND=dp),KIND=dp) end do - kase = 1 - isave( 1 ) = 1 + kase = 1_${ik}$ + isave( 1_${ik}$ ) = 1_${ik}$ return end if go to ( 20, 40, 70, 90, 120 )isave( 1 ) ! ................ entry (isave( 1 ) = 1) ! 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 130 end if - est = stdlib_dzsum1( n, x, 1 ) + est = stdlib${ii}$_dzsum1( n, x, 1_${ik}$ ) do i = 1, n absxi = abs( x( i ) ) if( absxi>safmin ) then @@ -6556,29 +6559,29 @@ module stdlib_linalg_lapack_z x( i ) = cone end if end do - kase = 2 - isave( 1 ) = 2 + kase = 2_${ik}$ + isave( 1_${ik}$ ) = 2_${ik}$ return ! ................ entry (isave( 1 ) = 2) ! first iteration. x has been overwritten by ctrans(a)*x. 40 continue - isave( 2 ) = stdlib_izmax1( n, x, 1 ) - isave( 3 ) = 2 + isave( 2_${ik}$ ) = stdlib${ii}$_izmax1( n, x, 1_${ik}$ ) + isave( 3_${ik}$ ) = 2_${ik}$ ! main loop - iterations 2,3,...,itmax. 50 continue do i = 1, n x( i ) = czero end do - x( isave( 2 ) ) = cone - kase = 1 - isave( 1 ) = 3 + x( isave( 2_${ik}$ ) ) = cone + kase = 1_${ik}$ + isave( 1_${ik}$ ) = 3_${ik}$ return ! ................ entry (isave( 1 ) = 3) ! x has been overwritten by a*x. 70 continue - call stdlib_zcopy( n, x, 1, v, 1 ) + call stdlib${ii}$_zcopy( n, x, 1_${ik}$, v, 1_${ik}$ ) estold = est - est = stdlib_dzsum1( n, v, 1 ) + est = stdlib${ii}$_dzsum1( n, v, 1_${ik}$ ) ! test for cycling. if( est<=estold )go to 100 do i = 1, n @@ -6590,17 +6593,17 @@ module stdlib_linalg_lapack_z x( i ) = cone end if end do - kase = 2 - isave( 1 ) = 4 + kase = 2_${ik}$ + isave( 1_${ik}$ ) = 4_${ik}$ return ! ................ entry (isave( 1 ) = 4) ! x has been overwritten by ctrans(a)*x. 90 continue - jlast = isave( 2 ) - isave( 2 ) = stdlib_izmax1( n, x, 1 ) - if( ( abs( x( jlast ) )/=abs( x( isave( 2 ) ) ) ) .and.( isave( 3 )est ) then - call stdlib_zcopy( n, x, 1, v, 1 ) + call stdlib${ii}$_zcopy( n, x, 1_${ik}$, v, 1_${ik}$ ) est = temp end if 130 continue - kase = 0 + kase = 0_${ik}$ return - end subroutine stdlib_zlacn2 + end subroutine stdlib${ii}$_zlacn2 - subroutine stdlib_zlacon( n, v, x, est, kase ) + subroutine stdlib${ii}$_zlacon( n, v, x, est, kase ) !! ZLACON estimates the 1-norm of a square, complex matrix A. !! Reverse communication is used for evaluating matrix-vector products. ! -- lapack auxiliary routine -- ! -- 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(dp), intent(inout) :: est ! Array Arguments complex(dp), intent(out) :: v(n) complex(dp), intent(inout) :: x(n) ! ===================================================================== ! 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(dp) :: absxi, altsgn, estold, safmin, temp ! Intrinsic Functions intrinsic :: abs,real,cmplx,aimag ! Save Statement save ! Executable Statements - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) - if( kase==0 ) then + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) + if( kase==0_${ik}$ ) then do i = 1, n x( i ) = cmplx( one / real( n,KIND=dp),KIND=dp) end do - kase = 1 - jump = 1 + kase = 1_${ik}$ + jump = 1_${ik}$ return end if go to ( 20, 40, 70, 90, 120 )jump ! ................ entry (jump = 1) ! 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 130 end if - est = stdlib_dzsum1( n, x, 1 ) + est = stdlib${ii}$_dzsum1( n, x, 1_${ik}$ ) do i = 1, n absxi = abs( x( i ) ) if( absxi>safmin ) then @@ -6684,29 +6687,29 @@ module stdlib_linalg_lapack_z x( i ) = cone end if end do - kase = 2 - jump = 2 + kase = 2_${ik}$ + jump = 2_${ik}$ return ! ................ entry (jump = 2) ! first iteration. x has been overwritten by ctrans(a)*x. 40 continue - j = stdlib_izmax1( n, x, 1 ) - iter = 2 + j = stdlib${ii}$_izmax1( n, x, 1_${ik}$ ) + iter = 2_${ik}$ ! main loop - iterations 2,3,...,itmax. 50 continue do i = 1, n x( i ) = czero end do x( j ) = cone - kase = 1 - jump = 3 + kase = 1_${ik}$ + jump = 3_${ik}$ return ! ................ entry (jump = 3) ! x has been overwritten by a*x. 70 continue - call stdlib_zcopy( n, x, 1, v, 1 ) + call stdlib${ii}$_zcopy( n, x, 1_${ik}$, v, 1_${ik}$ ) estold = est - est = stdlib_dzsum1( n, v, 1 ) + est = stdlib${ii}$_dzsum1( n, v, 1_${ik}$ ) ! test for cycling. if( est<=estold )go to 100 do i = 1, n @@ -6718,16 +6721,16 @@ module stdlib_linalg_lapack_z x( i ) = cone end if end do - kase = 2 - jump = 4 + kase = 2_${ik}$ + jump = 4_${ik}$ return ! ................ entry (jump = 4) ! x has been overwritten by ctrans(a)*x. 90 continue jlast = j - j = stdlib_izmax1( n, x, 1 ) + j = stdlib${ii}$_izmax1( n, x, 1_${ik}$ ) if( ( abs( x( jlast ) )/=abs( x( j ) ) ) .and.( iterest ) then - call stdlib_zcopy( n, x, 1, v, 1 ) + call stdlib${ii}$_zcopy( n, x, 1_${ik}$, v, 1_${ik}$ ) est = temp end if 130 continue - kase = 0 + kase = 0_${ik}$ return - end subroutine stdlib_zlacon + end subroutine stdlib${ii}$_zlacon - pure subroutine stdlib_zlacp2( uplo, m, n, a, lda, b, ldb ) + pure subroutine stdlib${ii}$_zlacp2( uplo, m, n, a, lda, b, ldb ) !! ZLACP2 copies all or part of a real two-dimensional matrix A to a !! complex matrix B. ! -- lapack auxiliary routine -- @@ -6763,13 +6766,13 @@ module stdlib_linalg_lapack_z ! -- 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(dp), intent(in) :: a(lda,*) complex(dp), intent(out) :: b(ldb,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -6793,10 +6796,10 @@ module stdlib_linalg_lapack_z end do end if return - end subroutine stdlib_zlacp2 + end subroutine stdlib${ii}$_zlacp2 - pure subroutine stdlib_zlacpy( uplo, m, n, a, lda, b, ldb ) + pure subroutine stdlib${ii}$_zlacpy( uplo, m, n, a, lda, b, ldb ) !! ZLACPY copies all or part of a two-dimensional matrix A to another !! matrix B. ! -- lapack auxiliary routine -- @@ -6804,13 +6807,13 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(in) :: a(lda,*) complex(dp), intent(out) :: b(ldb,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -6834,10 +6837,10 @@ module stdlib_linalg_lapack_z end do end if return - end subroutine stdlib_zlacpy + end subroutine stdlib${ii}$_zlacpy - pure subroutine stdlib_zlacrm( m, n, a, lda, b, ldb, c, ldc, rwork ) + pure subroutine stdlib${ii}$_zlacrm( m, n, a, lda, b, ldb, c, ldc, rwork ) !! ZLACRM performs a very simple matrix-matrix multiplication: !! C := A * B, !! where A is M by N and complex; B is N by N and real; @@ -6846,7 +6849,7 @@ module stdlib_linalg_lapack_z ! -- 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, ldc, m, n + integer(${ik}$), intent(in) :: lda, ldb, ldc, m, n ! Array Arguments real(dp), intent(in) :: b(ldb,*) real(dp), intent(out) :: rwork(*) @@ -6855,7 +6858,7 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, l + integer(${ik}$) :: i, j, l ! Intrinsic Functions intrinsic :: real,cmplx,aimag ! Executable Statements @@ -6866,8 +6869,8 @@ module stdlib_linalg_lapack_z rwork( ( j-1 )*m+i ) = real( a( i, j ),KIND=dp) end do end do - l = m*n + 1 - call stdlib_dgemm( 'N', 'N', m, n, n, one, rwork, m, b, ldb, zero,rwork( l ), m ) + l = m*n + 1_${ik}$ + call stdlib${ii}$_dgemm( 'N', 'N', m, n, n, one, rwork, m, b, ldb, zero,rwork( l ), m ) do j = 1, n do i = 1, m @@ -6879,7 +6882,7 @@ module stdlib_linalg_lapack_z rwork( ( j-1 )*m+i ) = aimag( a( i, j ) ) end do end do - call stdlib_dgemm( 'N', 'N', m, n, n, one, rwork, m, b, ldb, zero,rwork( l ), m ) + call stdlib${ii}$_dgemm( 'N', 'N', m, n, n, one, rwork, m, b, ldb, zero,rwork( l ), m ) do j = 1, n do i = 1, m @@ -6888,10 +6891,10 @@ module stdlib_linalg_lapack_z end do end do return - end subroutine stdlib_zlacrm + end subroutine stdlib${ii}$_zlacrm - pure subroutine stdlib_zlacrt( n, cx, incx, cy, incy, c, s ) + pure subroutine stdlib${ii}$_zlacrt( n, cx, incx, cy, incy, c, s ) !! ZLACRT performs the operation !! ( c s )( x ) ==> ( x ) !! ( -s c )( y ) ( y ) @@ -6900,22 +6903,22 @@ module stdlib_linalg_lapack_z ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n complex(dp), intent(in) :: c, s ! Array Arguments complex(dp), intent(inout) :: cx(*), cy(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ix, iy + integer(${ik}$) :: i, ix, iy complex(dp) :: ctemp ! Executable Statements if( n<=0 )return if( incx==1 .and. incy==1 )go to 20 ! code for unequal increments or equal increments not equal to 1 - ix = 1 - iy = 1 - if( incx<0 )ix = ( -n+1 )*incx + 1 - if( incy<0 )iy = ( -n+1 )*incy + 1 + ix = 1_${ik}$ + iy = 1_${ik}$ + if( incx<0_${ik}$ )ix = ( -n+1 )*incx + 1_${ik}$ + if( incy<0_${ik}$ )iy = ( -n+1 )*incy + 1_${ik}$ do i = 1, n ctemp = c*cx( ix ) + s*cy( iy ) cy( iy ) = c*cy( iy ) - s*cx( ix ) @@ -6932,10 +6935,10 @@ module stdlib_linalg_lapack_z cx( i ) = ctemp end do return - end subroutine stdlib_zlacrt + end subroutine stdlib${ii}$_zlacrt - pure complex(dp) function stdlib_zladiv( x, y ) + pure complex(dp) function stdlib${ii}$_zladiv( x, y ) !! ZLADIV := X / Y, where X and Y are complex. The computation of X / Y !! will not overflow on an intermediary step unless the results !! overflows. @@ -6950,14 +6953,14 @@ module stdlib_linalg_lapack_z ! Intrinsic Functions intrinsic :: real,cmplx,aimag ! Executable Statements - call stdlib_dladiv( real( x,KIND=dp), aimag( x ), real( y,KIND=dp), aimag( y ), zr,zi ) + call stdlib${ii}$_dladiv( real( x,KIND=dp), aimag( x ), real( y,KIND=dp), aimag( y ), zr,zi ) - stdlib_zladiv = cmplx( zr, zi,KIND=dp) + stdlib${ii}$_zladiv = cmplx( zr, zi,KIND=dp) return - end function stdlib_zladiv + end function stdlib${ii}$_zladiv - pure subroutine stdlib_zlaed8( k, n, qsiz, q, ldq, d, rho, cutpnt, z, dlamda,q2, ldq2, w, & + pure subroutine stdlib${ii}$_zlaed8( k, n, qsiz, q, ldq, d, rho, cutpnt, z, dlamda,q2, ldq2, w, & !! ZLAED8 merges the two sets of eigenvalues 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 @@ -6969,14 +6972,14 @@ module stdlib_linalg_lapack_z ! -- 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) :: cutpnt, ldq, ldq2, n, qsiz - integer(ilp), intent(out) :: givptr, info, k + integer(${ik}$), intent(in) :: cutpnt, ldq, ldq2, n, qsiz + integer(${ik}$), intent(out) :: givptr, info, k real(dp), intent(inout) :: rho ! Array Arguments - integer(ilp), intent(out) :: givcol(2,*), indx(*), indxp(*), perm(*) - integer(ilp), intent(inout) :: indxq(*) + integer(${ik}$), intent(out) :: givcol(2_${ik}$,*), indx(*), indxp(*), perm(*) + integer(${ik}$), intent(inout) :: indxq(*) real(dp), intent(inout) :: d(*), z(*) - real(dp), intent(out) :: dlamda(*), givnum(2,*), w(*) + real(dp), intent(out) :: dlamda(*), givnum(2_${ik}$,*), w(*) complex(dp), intent(inout) :: q(ldq,*) complex(dp), intent(out) :: q2(ldq2,*) ! ===================================================================== @@ -6984,47 +6987,47 @@ module stdlib_linalg_lapack_z real(dp), parameter :: mone = -1.0_dp ! Local Scalars - integer(ilp) :: i, imax, j, jlam, jmax, jp, k2, n1, n1p1, n2 + integer(${ik}$) :: i, imax, j, jlam, jmax, jp, k2, n1, n1p1, n2 real(dp) :: c, eps, s, t, tau, tol ! Intrinsic Functions intrinsic :: abs,max,min,sqrt ! Executable Statements ! test the input parameters. - info = 0 - if( n<0 ) then - info = -2 + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -2_${ik}$ else if( qsizn ) then - info = -8 - else if( ldq2n ) then + info = -8_${ik}$ + else if( ldq2n )go to 90 if( rho*abs( z( j ) )<=tol ) then ! deflate due to small z component. - k2 = k2 - 1 + k2 = k2 - 1_${ik}$ indxp( k2 ) = j else ! check if eigenvalues are close enough to allow deflation. @@ -7089,7 +7092,7 @@ module stdlib_linalg_lapack_z c = z( j ) ! find sqrt(a**2+b**2) without overflow or ! destructive underflow. - tau = stdlib_dlapy2( c, s ) + tau = stdlib${ii}$_dlapy2( c, s ) t = d( j ) - d( jlam ) c = c / tau s = -s / tau @@ -7098,24 +7101,24 @@ module stdlib_linalg_lapack_z z( j ) = tau z( jlam ) = zero ! record the appropriate givens rotation - givptr = givptr + 1 - givcol( 1, givptr ) = indxq( indx( jlam ) ) - givcol( 2, givptr ) = indxq( indx( j ) ) - givnum( 1, givptr ) = c - givnum( 2, givptr ) = s - call stdlib_zdrot( qsiz, q( 1, indxq( indx( jlam ) ) ), 1,q( 1, indxq( indx( j ) & - ) ), 1, c, s ) + givptr = givptr + 1_${ik}$ + givcol( 1_${ik}$, givptr ) = indxq( indx( jlam ) ) + givcol( 2_${ik}$, givptr ) = indxq( indx( j ) ) + givnum( 1_${ik}$, givptr ) = c + givnum( 2_${ik}$, givptr ) = s + call stdlib${ii}$_zdrot( qsiz, q( 1_${ik}$, indxq( indx( jlam ) ) ), 1_${ik}$,q( 1_${ik}$, indxq( indx( j ) & + ) ), 1_${ik}$, c, s ) t = d( jlam )*c*c + d( j )*s*s d( j ) = d( jlam )*s*s + d( j )*c*c d( jlam ) = t - k2 = k2 - 1 - i = 1 + k2 = k2 - 1_${ik}$ + i = 1_${ik}$ 80 continue if( k2+i<=n ) then if( d( jlam )zero )t = z*sqrt( ( t / z )**2+( b / z )**2 ) + if( z>zero )t = z*sqrt( ( t / z )**2_${ik}$+( b / z )**2_${ik}$ ) ! compute the two eigenvalues. rt1 and rt2 are exchanged ! if necessary so that rt1 will have the greater magnitude. rt1 = s + t @@ -7233,7 +7236,7 @@ module stdlib_linalg_lapack_z sn1 = ( rt1-a ) / b tabs = abs( sn1 ) if( tabs>one ) then - t = tabs*sqrt( ( one / tabs )**2+( sn1 / tabs )**2 ) + t = tabs*sqrt( ( one / tabs )**2_${ik}$+( sn1 / tabs )**2_${ik}$ ) else t = sqrt( cone+sn1*sn1 ) end if @@ -7247,10 +7250,10 @@ module stdlib_linalg_lapack_z end if end if return - end subroutine stdlib_zlaesy + end subroutine stdlib${ii}$_zlaesy - pure subroutine stdlib_zlaev2( a, b, c, rt1, rt2, cs1, sn1 ) + pure subroutine stdlib${ii}$_zlaev2( a, b, c, rt1, rt2, cs1, sn1 ) !! ZLAEV2 computes the eigendecomposition of a 2-by-2 Hermitian matrix !! [ A B ] !! [ CONJG(B) C ]. @@ -7280,14 +7283,14 @@ module stdlib_linalg_lapack_z else w = conjg( b ) / abs( b ) end if - call stdlib_dlaev2( real( a,KIND=dp), abs( b ), real( c,KIND=dp), rt1, rt2, cs1, t ) + call stdlib${ii}$_dlaev2( real( a,KIND=dp), abs( b ), real( c,KIND=dp), rt1, rt2, cs1, t ) sn1 = w*t return - end subroutine stdlib_zlaev2 + end subroutine stdlib${ii}$_zlaev2 - pure subroutine stdlib_zlag2c( m, n, a, lda, sa, ldsa, info ) + pure subroutine stdlib${ii}$_zlag2c( m, n, a, lda, sa, ldsa, info ) !! ZLAG2C converts a COMPLEX*16 matrix, SA, to a COMPLEX matrix, A. !! RMAX is the overflow for the SINGLE PRECISION arithmetic !! ZLAG2C checks that all the entries of A are between -RMAX and @@ -7297,36 +7300,36 @@ module stdlib_linalg_lapack_z ! -- 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 complex(sp), intent(out) :: sa(ldsa,*) complex(dp), intent(in) :: a(lda,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: rmax ! Intrinsic Functions intrinsic :: real,aimag ! Executable Statements - rmax = stdlib_slamch( 'O' ) + rmax = stdlib${ii}$_slamch( 'O' ) do j = 1, n do i = 1, m if( ( real( a( i, j ),KIND=dp)<-rmax ) .or.( real( a( i, j ),KIND=dp)>rmax ) & .or.( aimag( a( i, j ) )<-rmax ) .or.( aimag( a( i, j ) )>rmax ) ) then - info = 1 + info = 1_${ik}$ go to 30 end if sa( i, j ) = a( i, j ) end do end do - info = 0 + info = 0_${ik}$ 30 continue return - end subroutine stdlib_zlag2c + end subroutine stdlib${ii}$_zlag2c - pure subroutine stdlib_zlagtm( trans, n, nrhs, alpha, dl, d, du, x, ldx, beta,b, ldb ) + pure subroutine stdlib${ii}$_zlagtm( trans, n, nrhs, alpha, dl, d, du, x, ldx, beta,b, ldb ) !! ZLAGTM performs a matrix-vector product of the form !! B := alpha * A * X + beta * B !! where A is a tridiagonal matrix of order N, B and X are N by NRHS @@ -7338,7 +7341,7 @@ module stdlib_linalg_lapack_z ! -- 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(dp), intent(in) :: alpha, beta ! Array Arguments complex(dp), intent(inout) :: b(ldb,*) @@ -7346,7 +7349,7 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Intrinsic Functions intrinsic :: conjg ! Executable Statements @@ -7369,10 +7372,10 @@ module stdlib_linalg_lapack_z 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 & @@ -7383,10 +7386,10 @@ module stdlib_linalg_lapack_z else if( stdlib_lsame( trans, 'T' ) ) then ! 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 & @@ -7397,10 +7400,10 @@ module stdlib_linalg_lapack_z else if( stdlib_lsame( trans, 'C' ) ) then ! compute b := b + a**h * x do j = 1, nrhs - if( n==1 ) then - b( 1, j ) = b( 1, j ) + conjg( d( 1 ) )*x( 1, j ) + if( n==1_${ik}$ ) then + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) + conjg( d( 1_${ik}$ ) )*x( 1_${ik}$, j ) else - b( 1, j ) = b( 1, j ) + conjg( d( 1 ) )*x( 1, j ) +conjg( dl( 1 ) )*x( 2, & + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) + conjg( d( 1_${ik}$ ) )*x( 1_${ik}$, j ) +conjg( dl( 1_${ik}$ ) )*x( 2_${ik}$, & j ) b( n, j ) = b( n, j ) + conjg( du( n-1 ) )*x( n-1, j ) + conjg( d( n ) )*x(& n, j ) @@ -7415,10 +7418,10 @@ module stdlib_linalg_lapack_z 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 & @@ -7429,10 +7432,10 @@ module stdlib_linalg_lapack_z else if( stdlib_lsame( trans, 'T' ) ) then ! 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 & @@ -7443,10 +7446,10 @@ module stdlib_linalg_lapack_z else if( stdlib_lsame( trans, 'C' ) ) then ! compute b := b - a**h *x do j = 1, nrhs - if( n==1 ) then - b( 1, j ) = b( 1, j ) - conjg( d( 1 ) )*x( 1, j ) + if( n==1_${ik}$ ) then + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) - conjg( d( 1_${ik}$ ) )*x( 1_${ik}$, j ) else - b( 1, j ) = b( 1, j ) - conjg( d( 1 ) )*x( 1, j ) -conjg( dl( 1 ) )*x( 2, & + b( 1_${ik}$, j ) = b( 1_${ik}$, j ) - conjg( d( 1_${ik}$ ) )*x( 1_${ik}$, j ) -conjg( dl( 1_${ik}$ ) )*x( 2_${ik}$, & j ) b( n, j ) = b( n, j ) - conjg( du( n-1 ) )*x( n-1, j ) - conjg( d( n ) )*x(& n, j ) @@ -7459,10 +7462,10 @@ module stdlib_linalg_lapack_z end if end if return - end subroutine stdlib_zlagtm + end subroutine stdlib${ii}$_zlagtm - pure subroutine stdlib_zlahef( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) + pure subroutine stdlib${ii}$_zlahef( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) !! ZLAHEF computes a partial factorization of a complex Hermitian !! matrix A using the Bunch-Kaufman diagonal pivoting method. The !! partial factorization has the form: @@ -7481,10 +7484,10 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: w(ldw,*) ! ===================================================================== @@ -7494,7 +7497,7 @@ module stdlib_linalg_lapack_z ! 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(dp) :: absakk, alpha, colmax, r1, rowmax, t complex(dp) :: d11, d21, d22, z ! Intrinsic Functions @@ -7504,7 +7507,7 @@ module stdlib_linalg_lapack_z ! Statement Function Definitions cabs1( z ) = abs( real( z,KIND=dp) ) + abs( aimag( z ) ) ! 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 @@ -7518,13 +7521,13 @@ module stdlib_linalg_lapack_z kw = nb + k - n ! exit from loop if( ( k<=n-nb+1 .and. nb1 ) then - imax = stdlib_izamax( k-1, w( 1, kw ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_izamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) colmax = cabs1( w( imax, kw ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k a( k, k ) = real( a( k, k ),KIND=dp) else @@ -7554,23 +7557,23 @@ module stdlib_linalg_lapack_z else ! begin pivot search along imax row ! copy column imax to column kw-1 of w and update it - call stdlib_zcopy( imax-1, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) + call stdlib${ii}$_zcopy( imax-1, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) w( imax, kw-1 ) = real( a( imax, imax ),KIND=dp) - call stdlib_zcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_zcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ ) - call stdlib_zlacgv( k-imax, w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_zlacgv( k-imax, w( imax+1, kw-1 ), 1_${ik}$ ) if( k1 ) then - jmax = stdlib_izamax( imax-1, w( 1, kw-1 ), 1 ) + if( imax>1_${ik}$ ) then + jmax = stdlib${ii}$_izamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) rowmax = max( rowmax, cabs1( w( jmax, kw-1 ) ) ) end if ! case(2) @@ -7583,20 +7586,20 @@ module stdlib_linalg_lapack_z ! pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_zcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) ! case(4) else ! interchange rows and columns k-1 and imax, use 2-by-2 ! pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ end if ! end pivot search along imax row end if ! end pivot search ! ============================================================ ! 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. @@ -7607,17 +7610,17 @@ module stdlib_linalg_lapack_z ! (or k and k-1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = real( a( kk, kk ),KIND=dp) - call stdlib_zcopy( kk-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - call stdlib_zlacgv( kk-1-kp, a( kp, kp+1 ), lda ) - if( kp>1 )call stdlib_zcopy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_zcopy( kk-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) + call stdlib${ii}$_zlacgv( kk-1-kp, a( kp, kp+1 ), lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_zcopy( 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 ! later overwritten). interchange rows kk and kp ! in last kkw to nb columns of w. - if( k1 ) then + call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) + if( k>1_${ik}$ ) then ! (note: no need to check if a(k,k) is not zero, ! since that was ensured earlier in pivot search: ! case a(k,k) = 0 falls into 2x2 pivot case(4)) r1 = one / real( a( k, k ),KIND=dp) - call stdlib_zdscal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_zdscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) ! (2) conjugate column w(kw) - call stdlib_zlacgv( k-1, w( 1, kw ), 1 ) + call stdlib${ii}$_zlacgv( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) end if else ! 2-by-2 pivot block d(k): columns kw and kw-1 of w now hold @@ -7652,7 +7655,7 @@ module stdlib_linalg_lapack_z ! a(k-1:k,k-1:k) := d(k-1:k,k-1:k) = w(k-1:k,kw-1:kw) ! a(1:k-2,k-1:k) := u(1:k-2,k:k-1:k) = ! = w(1:k-2,kw-1:kw) * ( d(k-1:k,k-1:k)**(-1) ) - if( k>2 ) then + if( k>2_${ik}$ ) then ! factor out the columns of the inverse of 2-by-2 pivot ! block d, so that each column contains 1, to reduce the ! number of flops when we multiply panel @@ -7701,12 +7704,12 @@ module stdlib_linalg_lapack_z a( k-1, k ) = w( k-1, kw ) a( k, k ) = w( k, kw ) ! (2) conjugate columns w(kw) and w(kw-1) - call stdlib_zlacgv( k-1, w( 1, kw ), 1 ) - call stdlib_zlacgv( k-2, w( 1, kw-1 ), 1 ) + call stdlib${ii}$_zlacgv( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) + call stdlib${ii}$_zlacgv( k-2, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) 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 @@ -7725,32 +7728,32 @@ module stdlib_linalg_lapack_z ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 a( jj, jj ) = real( a( jj, jj ),KIND=dp) - call stdlib_zgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& - kw+1 ), ldw, cone,a( j, jj ), 1 ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& + kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ ) a( jj, jj ) = real( a( jj, jj ),KIND=dp) end do ! update the rectangular superdiagonal block - call stdlib_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( 1, k+1 ), & - lda, w( j, kw+1 ), ldw,cone, a( 1, j ), lda ) + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( 1_${ik}$, k+1 ), & + lda, w( j, kw+1 ), ldw,cone, a( 1_${ik}$, j ), lda ) end do ! put u12 in standard form by partially undoing the interchanges ! in columns k+1:n 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_zswap( n-j+1, a( jp, j ), lda, a( jj, j ), & + j = j + 1_${ik}$ + if( jp/=jj .and. j<=n )call stdlib${ii}$_zswap( n-j+1, a( jp, j ), lda, a( jj, j ), & lda ) if( j=nb .and. nbn )go to 90 - kstep = 1 + kstep = 1_${ik}$ ! copy column k of a to column k of w and update it w( k, k ) = real( a( k, k ),KIND=dp) - if( k1 )call stdlib_zswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_zswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + if( k>1_${ik}$ )call stdlib${ii}$_zswap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) + call stdlib${ii}$_zswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of w now holds ! w(k) = l(k)*d(k), ! where l(k) is the k-th column of l @@ -7871,15 +7874,15 @@ module stdlib_linalg_lapack_z ! (note: no need to use for hermitian matrix ! a( k, k ) = real( w( k, k),KIND=dp) to separately copy diagonal ! element d(k,k) from w (potentially saves only one load)) - call stdlib_zcopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib${ii}$_zcopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ ) if( k=1 )call stdlib_zswap( j, a( jp, 1 ), lda, a( jj, 1 ), lda ) + j = j - 1_${ik}$ + if( jp/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_zswap( 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_zlahef + end subroutine stdlib${ii}$_zlahef - pure subroutine stdlib_zlahef_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info ) + pure subroutine stdlib${ii}$_zlahef_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info ) !! ZLAHEF_RK computes a partial factorization of a complex Hermitian !! matrix A using the bounded Bunch-Kaufman (rook) diagonal !! pivoting method. The partial factorization has the form: @@ -8019,10 +8022,10 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: w(ldw,*), e(*) ! ===================================================================== @@ -8034,7 +8037,7 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: done - integer(ilp) :: imax, itemp, ii, j, jb, jj, jmax, k, kk, kkw, kp, kstep, kw, p + integer(${ik}$) :: imax, itemp, ii, j, jb, jj, jmax, k, kk, kkw, kp, kstep, kw, p real(dp) :: absakk, alpha, colmax, dtemp, r1, rowmax, t, sfmin complex(dp) :: d11, d21, d22, z ! Intrinsic Functions @@ -8044,18 +8047,18 @@ module stdlib_linalg_lapack_z ! Statement Function Definitions cabs1( z ) = abs( real( z,KIND=dp) ) + abs( aimag( z ) ) ! 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_dlamch( 'S' ) + sfmin = stdlib${ii}$_dlamch( 'S' ) if( stdlib_lsame( uplo, 'U' ) ) then ! factorize the trailing columns of a using the upper triangle ! of a and working backwards, and compute the matrix w = u12*d ! for use in updating a11 (note that conjg(w) is actually stored) ! initialize the first entry of array e, where superdiagonal ! elements of d are stored - e( 1 ) = czero + e( 1_${ik}$ ) = czero ! k is the main loop index, decreasing from n in steps of 1 or 2 k = n 10 continue @@ -8063,14 +8066,14 @@ module stdlib_linalg_lapack_z kw = nb + k - n ! exit from loop if( ( k<=n-nb+1 .and. nb1 )call stdlib_zcopy( k-1, a( 1, k ), 1, w( 1, kw ), 1 ) + if( k>1_${ik}$ )call stdlib${ii}$_zcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) w( k, kw ) = real( a( k, k ),KIND=dp) if( k1 ) then - imax = stdlib_izamax( k-1, w( 1, kw ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_izamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) colmax = cabs1( w( imax, kw ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k a( k, k ) = real( w( k, kw ),KIND=dp) - if( k>1 )call stdlib_zcopy( k-1, w( 1, kw ), 1, a( 1, k ), 1 ) + if( k>1_${ik}$ )call stdlib${ii}$_zcopy( k-1, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) ! set e( k ) to zero - if( k>1 )e( k ) = czero + if( k>1_${ik}$ )e( k ) = czero else ! ============================================================ ! begin pivot search @@ -8108,28 +8111,28 @@ module stdlib_linalg_lapack_z 12 continue ! begin pivot search loop body ! copy column imax to column kw-1 of w and update it - if( imax>1 )call stdlib_zcopy( imax-1, a( 1, imax ), 1, w( 1, kw-1 ),1 ) + if( imax>1_${ik}$ )call stdlib${ii}$_zcopy( imax-1, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ),1_${ik}$ ) w( imax, kw-1 ) = real( a( imax, imax ),KIND=dp) - call stdlib_zcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_zcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ ) - call stdlib_zlacgv( k-imax, w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_zlacgv( k-imax, w( imax+1, kw-1 ), 1_${ik}$ ) if( k1 ) then - itemp = stdlib_izamax( imax-1, w( 1, kw-1 ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_izamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) dtemp = cabs1( w( itemp, kw-1 ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -8146,7 +8149,7 @@ module stdlib_linalg_lapack_z ! use 1-by-1 pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_zcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) done = .true. ! case(3) ! equivalent to testing for rowmax==colmax, @@ -8155,7 +8158,7 @@ module stdlib_linalg_lapack_z ! interchange rows and columns k-1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. ! case(4) else @@ -8164,7 +8167,7 @@ module stdlib_linalg_lapack_z colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_zcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) end if ! end pivot search loop body if( .not.done ) goto 12 @@ -8172,26 +8175,26 @@ module stdlib_linalg_lapack_z ! end pivot search ! ============================================================ ! 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 p and k. ! updated column p is already stored in column kw of w. - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p of submatrix a ! at step k. no need to copy element into columns ! k and k-1 of a for 2-by-2 pivot, since these columns ! will be later overwritten. a( p, p ) = real( a( k, k ),KIND=dp) - call stdlib_zcopy( k-1-p, a( p+1, k ), 1, a( p, p+1 ),lda ) - call stdlib_zlacgv( k-1-p, a( p, p+1 ), lda ) - if( p>1 )call stdlib_zcopy( p-1, a( 1, k ), 1, a( 1, p ), 1 ) + call stdlib${ii}$_zcopy( k-1-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda ) + call stdlib${ii}$_zlacgv( k-1-p, a( p, p+1 ), lda ) + if( p>1_${ik}$ )call stdlib${ii}$_zcopy( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) ! interchange rows k and p in the last k+1 to n columns of a ! (columns k and k-1 of a for 2-by-2 pivot will be ! later overwritten). interchange rows k and p ! in last kkw to nb columns of w. - if( k1 )call stdlib_zcopy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_zcopy( kk-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) + call stdlib${ii}$_zlacgv( kk-1-kp, a( kp, kp+1 ), lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_zcopy( 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 ! later overwritten). interchange rows kk and kp ! in last kkw to nb columns of w. - if( k1 ) then + call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) + if( k>1_${ik}$ ) then ! (note: no need to check if a(k,k) is not zero, ! since that was ensured earlier in pivot search: ! case a(k,k) = 0 falls into 2x2 pivot case(3)) @@ -8233,14 +8236,14 @@ module stdlib_linalg_lapack_z t = real( a( k, k ),KIND=dp) if( abs( t )>=sfmin ) then r1 = one / t - call stdlib_zdscal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_zdscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) else do ii = 1, k-1 a( ii, k ) = a( ii, k ) / t end do end if ! (2) conjugate column w(kw) - call stdlib_zlacgv( k-1, w( 1, kw ), 1 ) + call stdlib${ii}$_zlacgv( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) ! store the superdiagonal element of d in array e e( k ) = czero end if @@ -8256,7 +8259,7 @@ module stdlib_linalg_lapack_z ! a(k-1:k,k-1:k) := d(k-1:k,k-1:k) = w(k-1:k,kw-1:kw) ! a(1:k-2,k-1:k) := u(1:k-2,k:k-1:k) = ! = w(1:k-2,kw-1:kw) * ( d(k-1:k,k-1:k)**(-1) ) - if( k>2 ) then + if( k>2_${ik}$ ) then ! factor out the columns of the inverse of 2-by-2 pivot ! block d, so that each column contains 1, to reduce the ! number of flops when we multiply panel @@ -8310,13 +8313,13 @@ module stdlib_linalg_lapack_z e( k ) = w( k-1, kw ) e( k-1 ) = czero ! (2) conjugate columns w(kw) and w(kw-1) - call stdlib_zlacgv( k-1, w( 1, kw ), 1 ) - call stdlib_zlacgv( k-2, w( 1, kw-1 ), 1 ) + call stdlib${ii}$_zlacgv( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) + call stdlib${ii}$_zlacgv( k-2, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) end if ! 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 @@ -8335,13 +8338,13 @@ module stdlib_linalg_lapack_z ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 a( jj, jj ) = real( a( jj, jj ),KIND=dp) - call stdlib_zgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& - kw+1 ), ldw, cone,a( j, jj ), 1 ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& + kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ ) a( jj, jj ) = real( a( jj, jj ),KIND=dp) end do ! update the rectangular superdiagonal block - if( j>=2 )call stdlib_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( & - 1, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1, j ), lda ) + if( j>=2_${ik}$ )call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( & + 1_${ik}$, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1_${ik}$, j ), lda ) end do ! set kb to the number of columns factorized kb = n - k @@ -8352,18 +8355,18 @@ module stdlib_linalg_lapack_z ! initialize the unused last entry of the subdiagonal array e. e( n ) = czero ! k is the main loop index, increasing from 1 in steps of 1 or 2 - k = 1 + 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 column k of w w( k, k ) = real( a( k, k ),KIND=dp) - if( k1 ) then - call stdlib_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ),lda, w( k, 1 ), & - ldw, cone, w( k, k ), 1 ) + if( k1_${ik}$ ) then + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ),lda, w( k, 1_${ik}$ ), & + ldw, cone, w( k, k ), 1_${ik}$ ) w( k, k ) = real( w( k, k ),KIND=dp) end if ! determine rows and columns to be interchanged and whether @@ -8373,17 +8376,17 @@ module stdlib_linalg_lapack_z ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k1 ) then - call stdlib_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1 ), lda, w( & - imax, 1 ), ldw,cone, w( k, k+1 ), 1 ) + if( imax1_${ik}$ ) then + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1_${ik}$ ), lda, w( & + imax, 1_${ik}$ ), ldw,cone, w( k, k+1 ), 1_${ik}$ ) w( imax, k+1 ) = real( w( imax, k+1 ),KIND=dp) end if ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = k - 1 + stdlib_izamax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1_${ik}$ + stdlib${ii}$_izamax( imax-k, w( k, k+1 ), 1_${ik}$ ) rowmax = cabs1( w( jmax, k+1 ) ) else rowmax = zero end if if( imaxrowmax ) then rowmax = dtemp @@ -8438,7 +8441,7 @@ module stdlib_linalg_lapack_z ! use 1-by-1 pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_zcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_zcopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) done = .true. ! case(3) ! equivalent to testing for rowmax==colmax, @@ -8447,7 +8450,7 @@ module stdlib_linalg_lapack_z ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. ! case(4) else @@ -8456,7 +8459,7 @@ module stdlib_linalg_lapack_z colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_zcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_zcopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) end if ! end pivot search loop body if( .not.done ) goto 72 @@ -8464,24 +8467,24 @@ module stdlib_linalg_lapack_z ! end pivot search ! ============================================================ ! kk is the column of a where pivoting step stopped - kk = k + kstep - 1 + kk = k + kstep - 1_${ik}$ ! interchange rows and columns p and k (only for 2-by-2 pivot). ! updated column p is already stored in column k of w. - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column kk-1 to column p of submatrix a ! at step k. no need to copy element into columns ! k and k+1 of a for 2-by-2 pivot, since these columns ! will be later overwritten. a( p, p ) = real( a( k, k ),KIND=dp) - call stdlib_zcopy( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) - call stdlib_zlacgv( p-k-1, a( p, k+1 ), lda ) - if( p1 )call stdlib_zswap( k-1, a( k, 1 ), lda, a( p, 1 ), lda ) - call stdlib_zswap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw ) + if( k>1_${ik}$ )call stdlib${ii}$_zswap( k-1, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda ) + call stdlib${ii}$_zswap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw ) end if ! interchange rows and columns kp and kk. ! updated column kp is already stored in column kk of w. @@ -8491,18 +8494,18 @@ module stdlib_linalg_lapack_z ! (or k and k+1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = real( a( kk, kk ),KIND=dp) - call stdlib_zcopy( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),lda ) - call stdlib_zlacgv( kp-kk-1, a( kp, kk+1 ), lda ) - if( kp1 )call stdlib_zswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_zswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + if( k>1_${ik}$ )call stdlib${ii}$_zswap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) + call stdlib${ii}$_zswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of w now holds ! w(k) = l(k)*d(k), ! where l(k) is the k-th column of l @@ -8515,7 +8518,7 @@ module stdlib_linalg_lapack_z ! (note: no need to use for hermitian matrix ! a( k, k ) = real( w( k, k),KIND=dp) to separately copy diagonal ! element d(k,k) from w (potentially saves only one load)) - call stdlib_zcopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib${ii}$_zcopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ ) if( k=sfmin ) then r1 = one / t - call stdlib_zdscal( n-k, r1, a( k+1, k ), 1 ) + call stdlib${ii}$_zdscal( n-k, r1, a( k+1, k ), 1_${ik}$ ) else do ii = k + 1, n a( ii, k ) = a( ii, k ) / t end do end if ! (2) conjugate column w(k) - call stdlib_zlacgv( n-k, w( k+1, k ), 1 ) + call stdlib${ii}$_zlacgv( n-k, w( k+1, k ), 1_${ik}$ ) ! store the subdiagonal element of d in array e e( k ) = czero end if @@ -8601,13 +8604,13 @@ module stdlib_linalg_lapack_z e( k ) = w( k+1, k ) e( k+1 ) = czero ! (2) conjugate columns w(k) and w(k+1) - call stdlib_zlacgv( n-k, w( k+1, k ), 1 ) - call stdlib_zlacgv( n-k-1, w( k+2, k+1 ), 1 ) + call stdlib${ii}$_zlacgv( n-k, w( k+1, k ), 1_${ik}$ ) + call stdlib${ii}$_zlacgv( n-k-1, w( k+2, k+1 ), 1_${ik}$ ) end if ! 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 @@ -8626,22 +8629,22 @@ module stdlib_linalg_lapack_z ! update the lower triangle of the diagonal block do jj = j, j + jb - 1 a( jj, jj ) = real( a( jj, jj ),KIND=dp) - call stdlib_zgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1 ), lda, w( jj,& - 1 ), ldw, cone,a( jj, jj ), 1 ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1_${ik}$ ), lda, w( jj,& + 1_${ik}$ ), ldw, cone,a( jj, jj ), 1_${ik}$ ) a( jj, jj ) = real( a( jj, jj ),KIND=dp) end do ! update the rectangular subdiagonal block - if( j+jb<=n )call stdlib_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& - cone, a( j+jb, 1 ), lda, w( j, 1 ),ldw, cone, a( j+jb, j ), lda ) + if( j+jb<=n )call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& + cone, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ),ldw, cone, a( j+jb, j ), lda ) end do ! set kb to the number of columns factorized - kb = k - 1 + kb = k - 1_${ik}$ end if return - end subroutine stdlib_zlahef_rk + end subroutine stdlib${ii}$_zlahef_rk - pure subroutine stdlib_zlahef_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) + pure subroutine stdlib${ii}$_zlahef_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) !! ZLAHEF_ROOK computes a partial factorization of a complex Hermitian !! matrix A using the bounded Bunch-Kaufman ("rook") diagonal pivoting !! method. The partial factorization has the form: @@ -8660,10 +8663,10 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: w(ldw,*) ! ===================================================================== @@ -8674,7 +8677,7 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: done - integer(ilp) :: imax, itemp, ii, j, jb, jj, jmax, jp1, jp2, k, kk, kkw, kp, kstep, kw, & + integer(${ik}$) :: imax, itemp, ii, j, jb, jj, jmax, jp1, jp2, k, kk, kkw, kp, kstep, kw, & p real(dp) :: absakk, alpha, colmax, dtemp, r1, rowmax, t, sfmin complex(dp) :: d11, d21, d22, z @@ -8685,11 +8688,11 @@ module stdlib_linalg_lapack_z ! Statement Function Definitions cabs1( z ) = abs( real( z,KIND=dp) ) + abs( aimag( z ) ) ! 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_dlamch( 'S' ) + sfmin = stdlib${ii}$_dlamch( 'S' ) if( stdlib_lsame( uplo, 'U' ) ) then ! factorize the trailing columns of a using the upper triangle ! of a and working backwards, and compute the matrix w = u12*d @@ -8701,14 +8704,14 @@ module stdlib_linalg_lapack_z kw = nb + k - n ! exit from loop if( ( k<=n-nb+1 .and. nb1 )call stdlib_zcopy( k-1, a( 1, k ), 1, w( 1, kw ), 1 ) + if( k>1_${ik}$ )call stdlib${ii}$_zcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) w( k, kw ) = real( a( k, k ),KIND=dp) if( k1 ) then - imax = stdlib_izamax( k-1, w( 1, kw ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_izamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) colmax = cabs1( w( imax, kw ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k a( k, k ) = real( w( k, kw ),KIND=dp) - if( k>1 )call stdlib_zcopy( k-1, w( 1, kw ), 1, a( 1, k ), 1 ) + if( k>1_${ik}$ )call stdlib${ii}$_zcopy( k-1, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) else ! ============================================================ ! begin pivot search @@ -8744,28 +8747,28 @@ module stdlib_linalg_lapack_z 12 continue ! begin pivot search loop body ! copy column imax to column kw-1 of w and update it - if( imax>1 )call stdlib_zcopy( imax-1, a( 1, imax ), 1, w( 1, kw-1 ),1 ) + if( imax>1_${ik}$ )call stdlib${ii}$_zcopy( imax-1, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ),1_${ik}$ ) w( imax, kw-1 ) = real( a( imax, imax ),KIND=dp) - call stdlib_zcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_zcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ ) - call stdlib_zlacgv( k-imax, w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_zlacgv( k-imax, w( imax+1, kw-1 ), 1_${ik}$ ) if( k1 ) then - itemp = stdlib_izamax( imax-1, w( 1, kw-1 ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_izamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) dtemp = cabs1( w( itemp, kw-1 ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -8782,7 +8785,7 @@ module stdlib_linalg_lapack_z ! use 1-by-1 pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_zcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) done = .true. ! case(3) ! equivalent to testing for rowmax==colmax, @@ -8791,7 +8794,7 @@ module stdlib_linalg_lapack_z ! interchange rows and columns k-1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. ! case(4) else @@ -8800,7 +8803,7 @@ module stdlib_linalg_lapack_z colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_zcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) end if ! end pivot search loop body if( .not.done ) goto 12 @@ -8808,26 +8811,26 @@ module stdlib_linalg_lapack_z ! end pivot search ! ============================================================ ! 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 p and k. ! updated column p is already stored in column kw of w. - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p of submatrix a ! at step k. no need to copy element into columns ! k and k-1 of a for 2-by-2 pivot, since these columns ! will be later overwritten. a( p, p ) = real( a( k, k ),KIND=dp) - call stdlib_zcopy( k-1-p, a( p+1, k ), 1, a( p, p+1 ),lda ) - call stdlib_zlacgv( k-1-p, a( p, p+1 ), lda ) - if( p>1 )call stdlib_zcopy( p-1, a( 1, k ), 1, a( 1, p ), 1 ) + call stdlib${ii}$_zcopy( k-1-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda ) + call stdlib${ii}$_zlacgv( k-1-p, a( p, p+1 ), lda ) + if( p>1_${ik}$ )call stdlib${ii}$_zcopy( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) ! interchange rows k and p in the last k+1 to n columns of a ! (columns k and k-1 of a for 2-by-2 pivot will be ! later overwritten). interchange rows k and p ! in last kkw to nb columns of w. - if( k1 )call stdlib_zcopy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_zcopy( kk-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) + call stdlib${ii}$_zlacgv( kk-1-kp, a( kp, kp+1 ), lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_zcopy( 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 ! later overwritten). interchange rows kk and kp ! in last kkw to nb columns of w. - if( k1 ) then + call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) + if( k>1_${ik}$ ) then ! (note: no need to check if a(k,k) is not zero, ! since that was ensured earlier in pivot search: ! case a(k,k) = 0 falls into 2x2 pivot case(3)) @@ -8869,14 +8872,14 @@ module stdlib_linalg_lapack_z t = real( a( k, k ),KIND=dp) if( abs( t )>=sfmin ) then r1 = one / t - call stdlib_zdscal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_zdscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) else do ii = 1, k-1 a( ii, k ) = a( ii, k ) / t end do end if ! (2) conjugate column w(kw) - call stdlib_zlacgv( k-1, w( 1, kw ), 1 ) + call stdlib${ii}$_zlacgv( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) end if else ! 2-by-2 pivot block d(k): columns kw and kw-1 of w now hold @@ -8890,7 +8893,7 @@ module stdlib_linalg_lapack_z ! a(k-1:k,k-1:k) := d(k-1:k,k-1:k) = w(k-1:k,kw-1:kw) ! a(1:k-2,k-1:k) := u(1:k-2,k:k-1:k) = ! = w(1:k-2,kw-1:kw) * ( d(k-1:k,k-1:k)**(-1) ) - if( k>2 ) then + if( k>2_${ik}$ ) then ! factor out the columns of the inverse of 2-by-2 pivot ! block d, so that each column contains 1, to reduce the ! number of flops when we multiply panel @@ -8940,12 +8943,12 @@ module stdlib_linalg_lapack_z a( k-1, k ) = w( k-1, kw ) a( k, k ) = w( k, kw ) ! (2) conjugate columns w(kw) and w(kw-1) - call stdlib_zlacgv( k-1, w( 1, kw ), 1 ) - call stdlib_zlacgv( k-2, w( 1, kw-1 ), 1 ) + call stdlib${ii}$_zlacgv( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) + call stdlib${ii}$_zlacgv( k-2, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) 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 @@ -8964,39 +8967,39 @@ module stdlib_linalg_lapack_z ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 a( jj, jj ) = real( a( jj, jj ),KIND=dp) - call stdlib_zgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& - kw+1 ), ldw, cone,a( j, jj ), 1 ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& + kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ ) a( jj, jj ) = real( a( jj, jj ),KIND=dp) end do ! update the rectangular superdiagonal block - if( j>=2 )call stdlib_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( & - 1, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1, j ), lda ) + if( j>=2_${ik}$ )call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( & + 1_${ik}$, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1_${ik}$, j ), lda ) end do ! put u12 in standard form by partially undoing the interchanges ! in of rows 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 j and jp2 ! (or j and jp2, and j+1 and jp1) at each step j - kstep = 1 - jp1 = 1 + kstep = 1_${ik}$ + jp1 = 1_${ik}$ ! (here, j is a diagonal index) jj = j jp2 = ipiv( j ) - if( jp2<0 ) then + if( jp2<0_${ik}$ ) then jp2 = -jp2 ! (here, j is a diagonal index) - j = j + 1 + j = j + 1_${ik}$ jp1 = -ipiv( j ) - kstep = 2 + kstep = 2_${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( jp2/=jj .and. j<=n )call stdlib_zswap( n-j+1, a( jp2, j ), lda, a( jj, j ), & + j = j + 1_${ik}$ + if( jp2/=jj .and. j<=n )call stdlib${ii}$_zswap( n-j+1, a( jp2, j ), lda, a( jj, j ), & lda ) - jj = jj + 1 - if( kstep==2 .and. jp1/=jj .and. j<=n )call stdlib_zswap( n-j+1, a( jp1, j ), & + jj = jj + 1_${ik}$ + if( kstep==2_${ik}$ .and. jp1/=jj .and. j<=n )call stdlib${ii}$_zswap( n-j+1, a( jp1, j ), & lda, a( jj, j ), lda ) if( j=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 column k of w w( k, k ) = real( a( k, k ),KIND=dp) - if( k1 ) then - call stdlib_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ),lda, w( k, 1 ), & - ldw, cone, w( k, k ), 1 ) + if( k1_${ik}$ ) then + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ),lda, w( k, 1_${ik}$ ), & + ldw, cone, w( k, k ), 1_${ik}$ ) w( k, k ) = real( w( k, k ),KIND=dp) end if ! determine rows and columns to be interchanged and whether @@ -9027,17 +9030,17 @@ module stdlib_linalg_lapack_z ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k1 ) then - call stdlib_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1 ), lda, w( & - imax, 1 ), ldw,cone, w( k, k+1 ), 1 ) + if( imax1_${ik}$ ) then + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1_${ik}$ ), lda, w( & + imax, 1_${ik}$ ), ldw,cone, w( k, k+1 ), 1_${ik}$ ) w( imax, k+1 ) = real( w( imax, k+1 ),KIND=dp) end if ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = k - 1 + stdlib_izamax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1_${ik}$ + stdlib${ii}$_izamax( imax-k, w( k, k+1 ), 1_${ik}$ ) rowmax = cabs1( w( jmax, k+1 ) ) else rowmax = zero end if if( imaxrowmax ) then rowmax = dtemp @@ -9090,7 +9093,7 @@ module stdlib_linalg_lapack_z ! use 1-by-1 pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_zcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_zcopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) done = .true. ! case(3) ! equivalent to testing for rowmax==colmax, @@ -9099,7 +9102,7 @@ module stdlib_linalg_lapack_z ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. ! case(4) else @@ -9108,7 +9111,7 @@ module stdlib_linalg_lapack_z colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_zcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_zcopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) end if ! end pivot search loop body if( .not.done ) goto 72 @@ -9116,24 +9119,24 @@ module stdlib_linalg_lapack_z ! end pivot search ! ============================================================ ! kk is the column of a where pivoting step stopped - kk = k + kstep - 1 + kk = k + kstep - 1_${ik}$ ! interchange rows and columns p and k (only for 2-by-2 pivot). ! updated column p is already stored in column k of w. - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column kk-1 to column p of submatrix a ! at step k. no need to copy element into columns ! k and k+1 of a for 2-by-2 pivot, since these columns ! will be later overwritten. a( p, p ) = real( a( k, k ),KIND=dp) - call stdlib_zcopy( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) - call stdlib_zlacgv( p-k-1, a( p, k+1 ), lda ) - if( p1 )call stdlib_zswap( k-1, a( k, 1 ), lda, a( p, 1 ), lda ) - call stdlib_zswap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw ) + if( k>1_${ik}$ )call stdlib${ii}$_zswap( k-1, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda ) + call stdlib${ii}$_zswap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw ) end if ! interchange rows and columns kp and kk. ! updated column kp is already stored in column kk of w. @@ -9143,18 +9146,18 @@ module stdlib_linalg_lapack_z ! (or k and k+1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = real( a( kk, kk ),KIND=dp) - call stdlib_zcopy( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),lda ) - call stdlib_zlacgv( kp-kk-1, a( kp, kk+1 ), lda ) - if( kp1 )call stdlib_zswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_zswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + if( k>1_${ik}$ )call stdlib${ii}$_zswap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) + call stdlib${ii}$_zswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of w now holds ! w(k) = l(k)*d(k), ! where l(k) is the k-th column of l @@ -9167,7 +9170,7 @@ module stdlib_linalg_lapack_z ! (note: no need to use for hermitian matrix ! a( k, k ) = real( w( k, k),KIND=dp) to separately copy diagonal ! element d(k,k) from w (potentially saves only one load)) - call stdlib_zcopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib${ii}$_zcopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ ) if( k=sfmin ) then r1 = one / t - call stdlib_zdscal( n-k, r1, a( k+1, k ), 1 ) + call stdlib${ii}$_zdscal( n-k, r1, a( k+1, k ), 1_${ik}$ ) else do ii = k + 1, n a( ii, k ) = a( ii, k ) / t end do end if ! (2) conjugate column w(k) - call stdlib_zlacgv( n-k, w( k+1, k ), 1 ) + call stdlib${ii}$_zlacgv( n-k, w( k+1, k ), 1_${ik}$ ) end if else ! 2-by-2 pivot block d(k): columns k and k+1 of w now hold @@ -9247,12 +9250,12 @@ module stdlib_linalg_lapack_z a( k+1, k ) = w( k+1, k ) a( k+1, k+1 ) = w( k+1, k+1 ) ! (2) conjugate columns w(k) and w(k+1) - call stdlib_zlacgv( n-k, w( k+1, k ), 1 ) - call stdlib_zlacgv( n-k-1, w( k+2, k+1 ), 1 ) + call stdlib${ii}$_zlacgv( n-k, w( k+1, k ), 1_${ik}$ ) + call stdlib${ii}$_zlacgv( n-k-1, w( k+2, k+1 ), 1_${ik}$ ) 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 @@ -9271,49 +9274,49 @@ module stdlib_linalg_lapack_z ! update the lower triangle of the diagonal block do jj = j, j + jb - 1 a( jj, jj ) = real( a( jj, jj ),KIND=dp) - call stdlib_zgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1 ), lda, w( jj,& - 1 ), ldw, cone,a( jj, jj ), 1 ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1_${ik}$ ), lda, w( jj,& + 1_${ik}$ ), ldw, cone,a( jj, jj ), 1_${ik}$ ) a( jj, jj ) = real( a( jj, jj ),KIND=dp) end do ! update the rectangular subdiagonal block - if( j+jb<=n )call stdlib_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& - cone, a( j+jb, 1 ), lda, w( j, 1 ),ldw, cone, a( j+jb, j ), lda ) + if( j+jb<=n )call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& + cone, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ),ldw, cone, a( j+jb, j ), lda ) end do ! put l21 in standard form by partially undoing the interchanges ! of rows in columns 1:k-1 looping backwards from k-1 to 1 - j = k - 1 + j = k - 1_${ik}$ 120 continue ! undo the interchanges (if any) of rows j and jp2 ! (or j and jp2, and j-1 and jp1) at each step j - kstep = 1 - jp1 = 1 + kstep = 1_${ik}$ + jp1 = 1_${ik}$ ! (here, j is a diagonal index) jj = j jp2 = ipiv( j ) - if( jp2<0 ) then + if( jp2<0_${ik}$ ) then jp2 = -jp2 ! (here, j is a diagonal index) - j = j - 1 + j = j - 1_${ik}$ jp1 = -ipiv( j ) - kstep = 2 + kstep = 2_${ik}$ end if ! (note: here, j is used to determine row length. length j ! of the rows to swap back doesn't include diagonal element) - j = j - 1 - if( jp2/=jj .and. j>=1 )call stdlib_zswap( j, a( jp2, 1 ), lda, a( jj, 1 ), lda ) + j = j - 1_${ik}$ + if( jp2/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_zswap( j, a( jp2, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda ) - jj = jj -1 - if( kstep==2 .and. jp1/=jj .and. j>=1 )call stdlib_zswap( j, a( jp1, 1 ), lda, a(& - jj, 1 ), lda ) + jj = jj -1_${ik}$ + if( kstep==2_${ik}$ .and. jp1/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_zswap( j, a( jp1, 1_${ik}$ ), lda, a(& + jj, 1_${ik}$ ), lda ) if( j>1 )go to 120 ! set kb to the number of columns factorized - kb = k - 1 + kb = k - 1_${ik}$ end if return - end subroutine stdlib_zlahef_rook + end subroutine stdlib${ii}$_zlahef_rook - pure subroutine stdlib_zlaic1( job, j, x, sest, w, gamma, sestpr, s, c ) + pure subroutine stdlib${ii}$_zlaic1( job, j, x, sest, w, gamma, sestpr, s, c ) !! ZLAIC1 applies one step of incremental condition estimation in !! its simplest version: !! Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j @@ -9338,7 +9341,7 @@ module stdlib_linalg_lapack_z ! -- 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(dp), intent(in) :: sest real(dp), intent(out) :: sestpr complex(dp), intent(out) :: c, s @@ -9355,12 +9358,12 @@ module stdlib_linalg_lapack_z ! Intrinsic Functions intrinsic :: abs,conjg,max,sqrt ! Executable Statements - eps = stdlib_dlamch( 'EPSILON' ) - alpha = stdlib_zdotc( j, x, 1, w, 1 ) + eps = stdlib${ii}$_dlamch( 'EPSILON' ) + alpha = stdlib${ii}$_zdotc( 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 @@ -9436,7 +9439,7 @@ module stdlib_linalg_lapack_z 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 @@ -9526,10 +9529,10 @@ module stdlib_linalg_lapack_z end if end if return - end subroutine stdlib_zlaic1 + end subroutine stdlib${ii}$_zlaic1 - pure subroutine stdlib_zlapmr( forwrd, m, n, x, ldx, k ) + pure subroutine stdlib${ii}$_zlapmr( forwrd, m, n, x, ldx, k ) !! ZLAPMR rearranges the rows of the M by N matrix X as specified !! by the permutation K(1),K(2),...,K(M) of the integers 1,...,M. !! If FORWRD = .TRUE., forward permutation: @@ -9541,13 +9544,13 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(inout) :: x(ldx,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, in, j, jj + integer(${ik}$) :: i, in, j, jj complex(dp) :: temp ! Executable Statements if( m<=1 )return @@ -9594,10 +9597,10 @@ module stdlib_linalg_lapack_z end do end if return - end subroutine stdlib_zlapmr + end subroutine stdlib${ii}$_zlapmr - pure subroutine stdlib_zlapmt( forwrd, m, n, x, ldx, k ) + pure subroutine stdlib${ii}$_zlapmt( forwrd, m, n, x, ldx, k ) !! ZLAPMT rearranges the columns of the M by N matrix X as specified !! by the permutation K(1),K(2),...,K(N) of the integers 1,...,N. !! If FORWRD = .TRUE., forward permutation: @@ -9609,13 +9612,13 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(inout) :: x(ldx,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ii, in, j + integer(${ik}$) :: i, ii, in, j complex(dp) :: temp ! Executable Statements if( n<=1 )return @@ -9662,10 +9665,10 @@ module stdlib_linalg_lapack_z end do end if return - end subroutine stdlib_zlapmt + end subroutine stdlib${ii}$_zlapmt - pure subroutine stdlib_zlaqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) + pure subroutine stdlib${ii}$_zlaqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,amax, equed ) !! ZLAQGB equilibrates a general M by N band matrix A with KL !! subdiagonals and KU superdiagonals using the row and scaling factors !! in the vectors R and C. @@ -9675,7 +9678,7 @@ module stdlib_linalg_lapack_z ! -- 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(dp), intent(in) :: amax, colcnd, rowcnd ! Array Arguments real(dp), intent(in) :: c(*), r(*) @@ -9685,18 +9688,18 @@ module stdlib_linalg_lapack_z real(dp), parameter :: thresh = 0.1e+0_dp ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: 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_dlamch( 'SAFE MINIMUM' ) / stdlib_dlamch( 'PRECISION' ) + small = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' ) large = one / small if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then ! no row scaling @@ -9732,10 +9735,10 @@ module stdlib_linalg_lapack_z equed = 'B' end if return - end subroutine stdlib_zlaqgb + end subroutine stdlib${ii}$_zlaqgb - pure subroutine stdlib_zlaqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed ) + pure subroutine stdlib${ii}$_zlaqge( m, n, a, lda, r, c, rowcnd, colcnd, amax,equed ) !! ZLAQGE equilibrates a general M by N matrix A using the row and !! column scaling factors in the vectors R and C. ! -- lapack auxiliary routine -- @@ -9743,7 +9746,7 @@ module stdlib_linalg_lapack_z ! -- 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(dp), intent(in) :: amax, colcnd, rowcnd ! Array Arguments real(dp), intent(in) :: c(*), r(*) @@ -9753,16 +9756,16 @@ module stdlib_linalg_lapack_z real(dp), parameter :: thresh = 0.1e+0_dp ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: 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_dlamch( 'SAFE MINIMUM' ) / stdlib_dlamch( 'PRECISION' ) + small = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' ) large = one / small if( rowcnd>=thresh .and. amax>=small .and. amax<=large )then ! no row scaling @@ -9798,10 +9801,10 @@ module stdlib_linalg_lapack_z equed = 'B' end if return - end subroutine stdlib_zlaqge + end subroutine stdlib${ii}$_zlaqge - pure subroutine stdlib_zlaqhb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_zlaqhb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) !! ZLAQHB equilibrates a Hermitian band matrix A !! using the scaling factors in the vector S. ! -- lapack auxiliary routine -- @@ -9810,7 +9813,7 @@ module stdlib_linalg_lapack_z ! 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(dp), intent(in) :: amax, scond ! Array Arguments real(dp), intent(out) :: s(*) @@ -9820,18 +9823,18 @@ module stdlib_linalg_lapack_z real(dp), parameter :: thresh = 0.1e+0_dp ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: cj, large, small ! Intrinsic Functions intrinsic :: real,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_dlamch( 'SAFE MINIMUM' ) / stdlib_dlamch( 'PRECISION' ) + small = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -9851,19 +9854,19 @@ module stdlib_linalg_lapack_z ! lower triangle of a is stored. do j = 1, n cj = s( j ) - ab( 1, j ) = cj*cj*real( ab( 1, j ),KIND=dp) + ab( 1_${ik}$, j ) = cj*cj*real( ab( 1_${ik}$, j ),KIND=dp) do i = j + 1, 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_zlaqhb + end subroutine stdlib${ii}$_zlaqhb - pure subroutine stdlib_zlaqhe( uplo, n, a, lda, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_zlaqhe( uplo, n, a, lda, s, scond, amax, equed ) !! ZLAQHE equilibrates a Hermitian matrix A using the scaling factors !! in the vector S. ! -- lapack auxiliary routine -- @@ -9872,7 +9875,7 @@ module stdlib_linalg_lapack_z ! Scalar Arguments character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: lda, n + integer(${ik}$), intent(in) :: lda, n real(dp), intent(in) :: amax, scond ! Array Arguments real(dp), intent(in) :: s(*) @@ -9882,18 +9885,18 @@ module stdlib_linalg_lapack_z real(dp), parameter :: thresh = 0.1e+0_dp ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: cj, large, small ! Intrinsic Functions intrinsic :: real ! 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_dlamch( 'SAFE MINIMUM' ) / stdlib_dlamch( 'PRECISION' ) + small = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -9922,10 +9925,10 @@ module stdlib_linalg_lapack_z equed = 'Y' end if return - end subroutine stdlib_zlaqhe + end subroutine stdlib${ii}$_zlaqhe - pure subroutine stdlib_zlaqhp( uplo, n, ap, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_zlaqhp( uplo, n, ap, s, scond, amax, equed ) !! ZLAQHP equilibrates a Hermitian matrix A using the scaling factors !! in the vector S. ! -- lapack auxiliary routine -- @@ -9934,7 +9937,7 @@ module stdlib_linalg_lapack_z ! Scalar Arguments character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(dp), intent(in) :: amax, scond ! Array Arguments real(dp), intent(in) :: s(*) @@ -9944,18 +9947,18 @@ module stdlib_linalg_lapack_z real(dp), parameter :: thresh = 0.1e+0_dp ! Local Scalars - integer(ilp) :: i, j, jc + integer(${ik}$) :: i, j, jc real(dp) :: cj, large, small ! Intrinsic Functions intrinsic :: real ! 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_dlamch( 'SAFE MINIMUM' ) / stdlib_dlamch( 'PRECISION' ) + small = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -9964,7 +9967,7 @@ module stdlib_linalg_lapack_z ! 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 - 1 @@ -9975,23 +9978,23 @@ module stdlib_linalg_lapack_z end do else ! lower triangle of a is stored. - jc = 1 + jc = 1_${ik}$ do j = 1, n cj = s( j ) ap( jc ) = cj*cj*real( ap( jc ),KIND=dp) do i = j + 1, n ap( jc+i-j ) = cj*s( i )*ap( jc+i-j ) end do - jc = jc + n - j + 1 + jc = jc + n - j + 1_${ik}$ end do end if equed = 'Y' end if return - end subroutine stdlib_zlaqhp + end subroutine stdlib${ii}$_zlaqhp - pure subroutine stdlib_zlaqr1( n, h, ldh, s1, s2, v ) + pure subroutine stdlib${ii}$_zlaqr1( n, h, ldh, s1, s2, v ) !! Given a 2-by-2 or 3-by-3 matrix H, ZLAQR1: sets v to a !! scalar multiple of the first column of the product !! (*) K = (H - s1*I)*(H - s2*I) @@ -10003,7 +10006,7 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments complex(dp), intent(in) :: s1, s2 - integer(ilp), intent(in) :: ldh, n + integer(${ik}$), intent(in) :: ldh, n ! Array Arguments complex(dp), intent(in) :: h(ldh,*) complex(dp), intent(out) :: v(*) @@ -10023,38 +10026,38 @@ module stdlib_linalg_lapack_z cabs1( cdum ) = abs( real( cdum,KIND=dp) ) + abs( aimag( cdum ) ) ! 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 = cabs1( h( 1, 1 )-s2 ) + cabs1( h( 2, 1 ) ) + if( n==2_${ik}$ ) then + s = cabs1( h( 1_${ik}$, 1_${ik}$ )-s2 ) + cabs1( h( 2_${ik}$, 1_${ik}$ ) ) if( s==rzero ) then - v( 1 ) = czero - v( 2 ) = czero + v( 1_${ik}$ ) = czero + v( 2_${ik}$ ) = czero else - h21s = h( 2, 1 ) / s - v( 1 ) = h21s*h( 1, 2 ) + ( h( 1, 1 )-s1 )*( ( h( 1, 1 )-s2 ) / s ) - v( 2 ) = h21s*( h( 1, 1 )+h( 2, 2 )-s1-s2 ) + h21s = h( 2_${ik}$, 1_${ik}$ ) / s + v( 1_${ik}$ ) = h21s*h( 1_${ik}$, 2_${ik}$ ) + ( h( 1_${ik}$, 1_${ik}$ )-s1 )*( ( h( 1_${ik}$, 1_${ik}$ )-s2 ) / s ) + v( 2_${ik}$ ) = h21s*( h( 1_${ik}$, 1_${ik}$ )+h( 2_${ik}$, 2_${ik}$ )-s1-s2 ) end if else - s = cabs1( h( 1, 1 )-s2 ) + cabs1( h( 2, 1 ) ) +cabs1( h( 3, 1 ) ) + s = cabs1( h( 1_${ik}$, 1_${ik}$ )-s2 ) + cabs1( h( 2_${ik}$, 1_${ik}$ ) ) +cabs1( h( 3_${ik}$, 1_${ik}$ ) ) if( s==czero ) then - v( 1 ) = czero - v( 2 ) = czero - v( 3 ) = czero + v( 1_${ik}$ ) = czero + v( 2_${ik}$ ) = czero + v( 3_${ik}$ ) = czero else - h21s = h( 2, 1 ) / s - h31s = h( 3, 1 ) / s - v( 1 ) = ( h( 1, 1 )-s1 )*( ( h( 1, 1 )-s2 ) / s ) +h( 1, 2 )*h21s + h( 1, 3 )& + h21s = h( 2_${ik}$, 1_${ik}$ ) / s + h31s = h( 3_${ik}$, 1_${ik}$ ) / s + v( 1_${ik}$ ) = ( h( 1_${ik}$, 1_${ik}$ )-s1 )*( ( h( 1_${ik}$, 1_${ik}$ )-s2 ) / s ) +h( 1_${ik}$, 2_${ik}$ )*h21s + h( 1_${ik}$, 3_${ik}$ )& *h31s - v( 2 ) = h21s*( h( 1, 1 )+h( 2, 2 )-s1-s2 ) + h( 2, 3 )*h31s - v( 3 ) = h31s*( h( 1, 1 )+h( 3, 3 )-s1-s2 ) + h21s*h( 3, 2 ) + v( 2_${ik}$ ) = h21s*( h( 1_${ik}$, 1_${ik}$ )+h( 2_${ik}$, 2_${ik}$ )-s1-s2 ) + h( 2_${ik}$, 3_${ik}$ )*h31s + v( 3_${ik}$ ) = h31s*( h( 1_${ik}$, 1_${ik}$ )+h( 3_${ik}$, 3_${ik}$ )-s1-s2 ) + h21s*h( 3_${ik}$, 2_${ik}$ ) end if end if - end subroutine stdlib_zlaqr1 + end subroutine stdlib${ii}$_zlaqr1 - pure subroutine stdlib_zlaqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_zlaqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) !! ZLAQSB equilibrates a symmetric band matrix A using the scaling !! factors in the vector S. ! -- lapack auxiliary routine -- @@ -10063,7 +10066,7 @@ module stdlib_linalg_lapack_z ! 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(dp), intent(in) :: amax, scond ! Array Arguments real(dp), intent(in) :: s(*) @@ -10073,18 +10076,18 @@ module stdlib_linalg_lapack_z real(dp), parameter :: thresh = 0.1e+0_dp ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: 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_dlamch( 'SAFE MINIMUM' ) / stdlib_dlamch( 'PRECISION' ) + small = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -10104,17 +10107,17 @@ module stdlib_linalg_lapack_z 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_zlaqsb + end subroutine stdlib${ii}$_zlaqsb - pure subroutine stdlib_zlaqsp( uplo, n, ap, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_zlaqsp( uplo, n, ap, s, scond, amax, equed ) !! ZLAQSP equilibrates a symmetric matrix A using the scaling factors !! in the vector S. ! -- lapack auxiliary routine -- @@ -10123,7 +10126,7 @@ module stdlib_linalg_lapack_z ! Scalar Arguments character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: n + integer(${ik}$), intent(in) :: n real(dp), intent(in) :: amax, scond ! Array Arguments real(dp), intent(in) :: s(*) @@ -10133,16 +10136,16 @@ module stdlib_linalg_lapack_z real(dp), parameter :: thresh = 0.1e+0_dp ! Local Scalars - integer(ilp) :: i, j, jc + integer(${ik}$) :: i, j, jc real(dp) :: 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_dlamch( 'SAFE MINIMUM' ) / stdlib_dlamch( 'PRECISION' ) + small = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -10151,7 +10154,7 @@ module stdlib_linalg_lapack_z ! 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 @@ -10161,22 +10164,22 @@ module stdlib_linalg_lapack_z 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_zlaqsp + end subroutine stdlib${ii}$_zlaqsp - pure subroutine stdlib_zlaqsy( uplo, n, a, lda, s, scond, amax, equed ) + pure subroutine stdlib${ii}$_zlaqsy( uplo, n, a, lda, s, scond, amax, equed ) !! ZLAQSY equilibrates a symmetric matrix A using the scaling factors !! in the vector S. ! -- lapack auxiliary routine -- @@ -10185,7 +10188,7 @@ module stdlib_linalg_lapack_z ! Scalar Arguments character, intent(out) :: equed character, intent(in) :: uplo - integer(ilp), intent(in) :: lda, n + integer(${ik}$), intent(in) :: lda, n real(dp), intent(in) :: amax, scond ! Array Arguments real(dp), intent(in) :: s(*) @@ -10195,16 +10198,16 @@ module stdlib_linalg_lapack_z real(dp), parameter :: thresh = 0.1e+0_dp ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: 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_dlamch( 'SAFE MINIMUM' ) / stdlib_dlamch( 'PRECISION' ) + small = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) / stdlib${ii}$_dlamch( 'PRECISION' ) large = one / small if( scond>=thresh .and. amax>=small .and. amax<=large ) then ! no equilibration @@ -10231,10 +10234,10 @@ module stdlib_linalg_lapack_z equed = 'Y' end if return - end subroutine stdlib_zlaqsy + end subroutine stdlib${ii}$_zlaqsy - pure subroutine stdlib_zlar1v( n, b1, bn, lambda, d, l, ld, lld,pivmin, gaptol, z, wantnc, & + pure subroutine stdlib${ii}$_zlar1v( n, b1, bn, lambda, d, l, ld, lld,pivmin, gaptol, z, wantnc, & !! ZLAR1V computes the (scaled) r-th column of the inverse of !! the sumbmatrix in rows B1 through BN of the tridiagonal matrix !! L D L**T - sigma I. When sigma is close to an eigenvalue, the @@ -10256,13 +10259,13 @@ module stdlib_linalg_lapack_z ! -- 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(dp), intent(in) :: gaptol, lambda, pivmin real(dp), intent(out) :: mingma, nrminv, resid, rqcorr, ztz ! Array Arguments - integer(ilp), intent(out) :: isuppz(*) + integer(${ik}$), intent(out) :: isuppz(*) real(dp), intent(in) :: d(*), l(*), ld(*), lld(*) real(dp), intent(out) :: work(*) complex(dp), intent(inout) :: z(*) @@ -10271,13 +10274,13 @@ module stdlib_linalg_lapack_z ! 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(dp) :: dminus, dplus, eps, s, tmp ! Intrinsic Functions intrinsic :: abs,real ! Executable Statements - eps = stdlib_dlamch( 'PRECISION' ) - if( r==0 ) then + eps = stdlib${ii}$_dlamch( 'PRECISION' ) + if( r==0_${ik}$ ) then r1 = b1 r2 = bn else @@ -10285,12 +10288,12 @@ module stdlib_linalg_lapack_z 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 ) @@ -10298,16 +10301,16 @@ module stdlib_linalg_lapack_z ! 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(dplus0 ) 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-czero row in v. do while( lastv>0 .and. v( i )==czero ) - lastv = lastv - 1 + lastv = lastv - 1_${ik}$ i = i - incv end do if( applyleft ) then ! scan for the last non-czero column in c(1:lastv,:). - lastc = stdlib_ilazlc(lastv, n, c, ldc) + lastc = stdlib${ii}$_ilazlc(lastv, n, c, ldc) else ! scan for the last non-czero row in c(:,1:lastv). - lastc = stdlib_ilazlr(m, lastv, c, ldc) + lastc = stdlib${ii}$_ilazlr(m, lastv, c, ldc) end if end if ! note that lastc.eq.0_dp renders the blas operations null; no special ! case is needed at this level. if( applyleft ) then ! form h * c - if( lastv>0 ) then + if( lastv>0_${ik}$ ) then ! w(1:lastc,1) := c(1:lastv,1:lastc)**h * v(1:lastv,1) - call stdlib_zgemv( 'CONJUGATE TRANSPOSE', lastv, lastc, cone,c, ldc, v, incv, & - czero, work, 1 ) + call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', lastv, lastc, cone,c, ldc, v, incv, & + czero, work, 1_${ik}$ ) ! c(1:lastv,1:lastc) := c(...) - v(1:lastv,1) * w(1:lastc,1)**h - call stdlib_zgerc( lastv, lastc, -tau, v, incv, work, 1, c, ldc ) + call stdlib${ii}$_zgerc( lastv, lastc, -tau, v, incv, work, 1_${ik}$, c, ldc ) end if else ! form c * h - if( lastv>0 ) then + if( lastv>0_${ik}$ ) then ! w(1:lastc,1) := c(1:lastc,1:lastv) * v(1:lastv,1) - call stdlib_zgemv( 'NO TRANSPOSE', lastc, lastv, cone, c, ldc,v, incv, czero, & - work, 1 ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', lastc, lastv, cone, c, ldc,v, incv, czero, & + work, 1_${ik}$ ) ! c(1:lastc,1:lastv) := c(...) - w(1:lastc,1) * v(1:lastv,1)**h - call stdlib_zgerc( lastc, lastv, -tau, work, 1, v, incv, c, ldc ) + call stdlib${ii}$_zgerc( lastc, lastv, -tau, work, 1_${ik}$, v, incv, c, ldc ) end if end if return - end subroutine stdlib_zlarf + end subroutine stdlib${ii}$_zlarf - pure subroutine stdlib_zlarfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, ldc, & + pure subroutine stdlib${ii}$_zlarfb( side, trans, direct, storev, m, n, k, v, ldv,t, ldt, c, ldc, & !! ZLARFB applies a complex block reflector H or its transpose H**H to a !! complex M-by-N matrix C, from either the left or the right. work, ldwork ) @@ -10654,7 +10657,7 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: c(ldc,*) complex(dp), intent(in) :: t(ldt,*), v(ldv,*) @@ -10663,7 +10666,7 @@ module stdlib_linalg_lapack_z ! Local Scalars character :: transt - integer(ilp) :: i, j + integer(${ik}$) :: i, j ! Intrinsic Functions intrinsic :: conjg ! Executable Statements @@ -10685,28 +10688,28 @@ module stdlib_linalg_lapack_z ! w := c**h * v = (c1**h * v1 + c2**h * v2) (stored in work) ! w := c1**h do j = 1, k - call stdlib_zcopy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) - call stdlib_zlacgv( n, work( 1, j ), 1 ) + call stdlib${ii}$_zcopy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_zlacgv( n, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v1 - call stdlib_ztrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v, & + call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v, & ldv, work, ldwork ) if( m>k ) then ! w := w + c2**h * v2 - call stdlib_zgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', n,k, m-k, cone, & - c( k+1, 1 ), ldc,v( k+1, 1 ), ldv, cone, work, ldwork ) + call stdlib${ii}$_zgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', n,k, m-k, cone, & + c( k+1, 1_${ik}$ ), ldc,v( k+1, 1_${ik}$ ), ldv, cone, work, ldwork ) end if ! w := w * t**h or w * t - call stdlib_ztrmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,cone, t, ldt, & + call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,cone, t, ldt, & work, ldwork ) ! c := c - v * w**h if( m>k ) then ! c2 := c2 - v2 * w**h - call stdlib_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',m-k, n, k, -cone, & - v( k+1, 1 ), ldv, work,ldwork, cone, c( k+1, 1 ), ldc ) + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',m-k, n, k, -cone, & + v( k+1, 1_${ik}$ ), ldv, work,ldwork, cone, c( k+1, 1_${ik}$ ), ldc ) end if ! w := w * v1**h - call stdlib_ztrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& + call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& v, ldv, work, ldwork ) ! c1 := c1 - w**h do j = 1, k @@ -10719,27 +10722,27 @@ module stdlib_linalg_lapack_z ! w := c * v = (c1*v1 + c2*v2) (stored in work) ! w := c1 do j = 1, k - call stdlib_zcopy( m, c( 1, j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_zcopy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v1 - call stdlib_ztrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v, & + call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v, & ldv, work, ldwork ) if( n>k ) then ! w := w + c2 * v2 - call stdlib_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,cone, c( 1, k+& - 1 ), ldc, v( k+1, 1 ), ldv,cone, work, ldwork ) + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,cone, c( 1_${ik}$, k+& + 1_${ik}$ ), ldc, v( k+1, 1_${ik}$ ), ldv,cone, work, ldwork ) end if ! w := w * t or w * t**h - call stdlib_ztrmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,cone, t, ldt, & + call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,cone, t, ldt, & work, ldwork ) ! c := c - w * v**h if( n>k ) then ! c2 := c2 - w * v2**h - call stdlib_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,n-k, k, -cone, & - work, ldwork, v( k+1, 1 ),ldv, cone, c( 1, k+1 ), ldc ) + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,n-k, k, -cone, & + work, ldwork, v( k+1, 1_${ik}$ ),ldv, cone, c( 1_${ik}$, k+1 ), ldc ) end if ! w := w * v1**h - call stdlib_ztrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& + call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& v, ldv, work, ldwork ) ! c1 := c1 - w do j = 1, k @@ -10758,29 +10761,29 @@ module stdlib_linalg_lapack_z ! w := c**h * v = (c1**h * v1 + c2**h * v2) (stored in work) ! w := c2**h do j = 1, k - call stdlib_zcopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 ) - call stdlib_zlacgv( n, work( 1, j ), 1 ) + call stdlib${ii}$_zcopy( n, c( m-k+j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_zlacgv( n, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v2 - call stdlib_ztrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v( m-& - k+1, 1 ), ldv, work, ldwork ) + call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v( m-& + k+1, 1_${ik}$ ), ldv, work, ldwork ) if( m>k ) then ! w := w + c1**h * v1 - call stdlib_zgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', n,k, m-k, cone, & + call stdlib${ii}$_zgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', n,k, m-k, cone, & c, ldc, v, ldv, cone, work,ldwork ) end if ! w := w * t**h or w * t - call stdlib_ztrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,cone, t, ldt, & + call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,cone, t, ldt, & work, ldwork ) ! c := c - v * w**h if( m>k ) then ! c1 := c1 - v1 * w**h - call stdlib_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',m-k, n, k, -cone, & + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',m-k, n, k, -cone, & v, ldv, work, ldwork,cone, c, ldc ) end if ! w := w * v2**h - call stdlib_ztrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& - v( m-k+1, 1 ), ldv, work,ldwork ) + call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& + v( m-k+1, 1_${ik}$ ), ldv, work,ldwork ) ! c2 := c2 - w**h do j = 1, k do i = 1, n @@ -10792,28 +10795,28 @@ module stdlib_linalg_lapack_z ! w := c * v = (c1*v1 + c2*v2) (stored in work) ! w := c2 do j = 1, k - call stdlib_zcopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_zcopy( m, c( 1_${ik}$, n-k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v2 - call stdlib_ztrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v( n-& - k+1, 1 ), ldv, work, ldwork ) + call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v( n-& + k+1, 1_${ik}$ ), ldv, work, ldwork ) if( n>k ) then ! w := w + c1 * v1 - call stdlib_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,cone, c, ldc, & + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, k, n-k,cone, c, ldc, & v, ldv, cone, work, ldwork ) end if ! w := w * t or w * t**h - call stdlib_ztrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,cone, t, ldt, & + call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,cone, t, ldt, & work, ldwork ) ! c := c - w * v**h if( n>k ) then ! c1 := c1 - w * v1**h - call stdlib_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,n-k, k, -cone, & + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,n-k, k, -cone, & work, ldwork, v, ldv, cone,c, ldc ) end if ! w := w * v2**h - call stdlib_ztrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& - v( n-k+1, 1 ), ldv, work,ldwork ) + call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& + v( n-k+1, 1_${ik}$ ), ldv, work,ldwork ) ! c2 := c2 - w do j = 1, k do i = 1, m @@ -10832,28 +10835,28 @@ module stdlib_linalg_lapack_z ! w := c**h * v**h = (c1**h * v1**h + c2**h * v2**h) (stored in work) ! w := c1**h do j = 1, k - call stdlib_zcopy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) - call stdlib_zlacgv( n, work( 1, j ), 1 ) + call stdlib${ii}$_zcopy( n, c( j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_zlacgv( n, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v1**h - call stdlib_ztrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& + call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& v, ldv, work, ldwork ) if( m>k ) then ! w := w + c2**h * v2**h - call stdlib_zgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', n, k, m-k, & - cone,c( k+1, 1 ), ldc, v( 1, k+1 ), ldv, cone,work, ldwork ) + call stdlib${ii}$_zgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', n, k, m-k, & + cone,c( k+1, 1_${ik}$ ), ldc, v( 1_${ik}$, k+1 ), ldv, cone,work, ldwork ) end if ! w := w * t**h or w * t - call stdlib_ztrmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,cone, t, ldt, & + call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', transt, 'NON-UNIT', n, k,cone, t, ldt, & work, ldwork ) ! c := c - v**h * w**h if( m>k ) then ! c2 := c2 - v2**h * w**h - call stdlib_zgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', m-k, n, k, & - -cone,v( 1, k+1 ), ldv, work, ldwork, cone,c( k+1, 1 ), ldc ) + call stdlib${ii}$_zgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', m-k, n, k, & + -cone,v( 1_${ik}$, k+1 ), ldv, work, ldwork, cone,c( k+1, 1_${ik}$ ), ldc ) end if ! w := w * v1 - call stdlib_ztrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v, & + call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v, & ldv, work, ldwork ) ! c1 := c1 - w**h do j = 1, k @@ -10866,27 +10869,27 @@ module stdlib_linalg_lapack_z ! w := c * v**h = (c1*v1**h + c2*v2**h) (stored in work) ! w := c1 do j = 1, k - call stdlib_zcopy( m, c( 1, j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_zcopy( m, c( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v1**h - call stdlib_ztrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& + call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& v, ldv, work, ldwork ) if( n>k ) then ! w := w + c2 * v2**h - call stdlib_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,k, n-k, cone, & - c( 1, k+1 ), ldc,v( 1, k+1 ), ldv, cone, work, ldwork ) + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,k, n-k, cone, & + c( 1_${ik}$, k+1 ), ldc,v( 1_${ik}$, k+1 ), ldv, cone, work, ldwork ) end if ! w := w * t or w * t**h - call stdlib_ztrmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,cone, t, ldt, & + call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', trans, 'NON-UNIT', m, k,cone, t, ldt, & work, ldwork ) ! c := c - w * v if( n>k ) then ! c2 := c2 - w * v2 - call stdlib_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-cone, work, & - ldwork, v( 1, k+1 ), ldv, cone,c( 1, k+1 ), ldc ) + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-cone, work, & + ldwork, v( 1_${ik}$, k+1 ), ldv, cone,c( 1_${ik}$, k+1 ), ldc ) end if ! w := w * v1 - call stdlib_ztrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v, & + call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v, & ldv, work, ldwork ) ! c1 := c1 - w do j = 1, k @@ -10904,28 +10907,28 @@ module stdlib_linalg_lapack_z ! w := c**h * v**h = (c1**h * v1**h + c2**h * v2**h) (stored in work) ! w := c2**h do j = 1, k - call stdlib_zcopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 ) - call stdlib_zlacgv( n, work( 1, j ), 1 ) + call stdlib${ii}$_zcopy( n, c( m-k+j, 1_${ik}$ ), ldc, work( 1_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_zlacgv( n, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v2**h - call stdlib_ztrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& - v( 1, m-k+1 ), ldv, work,ldwork ) + call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', n, k, cone,& + v( 1_${ik}$, m-k+1 ), ldv, work,ldwork ) if( m>k ) then ! w := w + c1**h * v1**h - call stdlib_zgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', n, k, m-k, & + call stdlib${ii}$_zgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', n, k, m-k, & cone, c,ldc, v, ldv, cone, work, ldwork ) end if ! w := w * t**h or w * t - call stdlib_ztrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,cone, t, ldt, & + call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k,cone, t, ldt, & work, ldwork ) ! c := c - v**h * w**h if( m>k ) then ! c1 := c1 - v1**h * w**h - call stdlib_zgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', m-k, n, k, & + call stdlib${ii}$_zgemm( 'CONJUGATE TRANSPOSE','CONJUGATE TRANSPOSE', m-k, n, k, & -cone, v,ldv, work, ldwork, cone, c, ldc ) end if ! w := w * v2 - call stdlib_ztrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v( 1, & + call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', n,k, cone, v( 1_${ik}$, & m-k+1 ), ldv, work, ldwork ) ! c2 := c2 - w**h do j = 1, k @@ -10938,27 +10941,27 @@ module stdlib_linalg_lapack_z ! w := c * v**h = (c1*v1**h + c2*v2**h) (stored in work) ! w := c2 do j = 1, k - call stdlib_zcopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_zcopy( m, c( 1_${ik}$, n-k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do ! w := w * v2**h - call stdlib_ztrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& - v( 1, n-k+1 ), ldv, work,ldwork ) + call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', m, k, cone,& + v( 1_${ik}$, n-k+1 ), ldv, work,ldwork ) if( n>k ) then ! w := w + c1 * v1**h - call stdlib_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,k, n-k, cone, & + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m,k, n-k, cone, & c, ldc, v, ldv, cone, work,ldwork ) end if ! w := w * t or w * t**h - call stdlib_ztrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,cone, t, ldt, & + call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k,cone, t, ldt, & work, ldwork ) ! c := c - w * v if( n>k ) then ! c1 := c1 - w * v1 - call stdlib_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-cone, work, & + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, n-k, k,-cone, work, & ldwork, v, ldv, cone, c, ldc ) end if ! w := w * v2 - call stdlib_ztrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v( 1, & + call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', m,k, cone, v( 1_${ik}$, & n-k+1 ), ldv, work, ldwork ) ! c1 := c1 - w do j = 1, k @@ -10970,10 +10973,10 @@ module stdlib_linalg_lapack_z end if end if return - end subroutine stdlib_zlarfb + end subroutine stdlib${ii}$_zlarfb - pure subroutine stdlib_zlarfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) + pure subroutine stdlib${ii}$_zlarfb_gett( ident, m, n, k, t, ldt, a, lda, b, ldb,work, ldwork ) !! ZLARFB_GETT applies a complex Householder block reflector H from the !! left to a complex (K+M)-by-N "triangular-pentagonal" matrix !! composed of two block matrices: an upper trapezoidal K-by-N matrix A @@ -10987,7 +10990,7 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: a(lda,*), b(ldb,*) complex(dp), intent(in) :: t(ldt,*) @@ -10996,7 +10999,7 @@ module stdlib_linalg_lapack_z ! 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 @@ -11010,35 +11013,35 @@ module stdlib_linalg_lapack_z ! col2_(1) compute w2: = a2. therefore, copy a2 = a(1:k, k+1:n) ! into w2=work(1:k, 1:n-k) column-by-column. do j = 1, n-k - call stdlib_zcopy( k, a( 1, k+j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_zcopy( k, a( 1_${ik}$, k+j ), 1_${ik}$, work( 1_${ik}$, j ), 1_${ik}$ ) end do if( lnotident ) then ! col2_(2) compute w2: = (v1**h) * w2 = (a1**h) * w2, ! v1 is not an identy matrix, but unit lower-triangular ! v1 stored in a1 (diagonal ones are not stored). - call stdlib_ztrmm( 'L', 'L', 'C', 'U', k, n-k, cone, a, lda,work, ldwork ) + call stdlib${ii}$_ztrmm( 'L', 'L', 'C', 'U', k, n-k, cone, a, lda,work, ldwork ) end if ! col2_(3) compute w2: = w2 + (v2**h) * b2 = w2 + (b1**h) * b2 ! v2 stored in b1. - if( m>0 ) then - call stdlib_zgemm( 'C', 'N', k, n-k, m, cone, b, ldb,b( 1, k+1 ), ldb, cone, & + if( m>0_${ik}$ ) then + call stdlib${ii}$_zgemm( 'C', 'N', k, n-k, m, cone, b, ldb,b( 1_${ik}$, k+1 ), ldb, cone, & work, ldwork ) end if ! col2_(4) compute w2: = t * w2, ! t is upper-triangular. - call stdlib_ztrmm( 'L', 'U', 'N', 'N', k, n-k, cone, t, ldt,work, ldwork ) + call stdlib${ii}$_ztrmm( 'L', 'U', 'N', 'N', k, n-k, cone, t, ldt,work, ldwork ) ! col2_(5) compute b2: = b2 - v2 * w2 = b2 - b1 * w2, ! v2 stored in b1. - if( m>0 ) then - call stdlib_zgemm( 'N', 'N', m, n-k, k, -cone, b, ldb,work, ldwork, cone, b( 1, & + if( m>0_${ik}$ ) then + call stdlib${ii}$_zgemm( 'N', 'N', m, n-k, k, -cone, b, ldb,work, ldwork, cone, b( 1_${ik}$, & k+1 ), ldb ) end if if( lnotident ) then ! col2_(6) compute w2: = v1 * w2 = a1 * w2, ! v1 is not an identity matrix, but unit lower-triangular, ! v1 stored in a1 (diagonal ones are not stored). - call stdlib_ztrmm( 'L', 'L', 'N', 'U', k, n-k, cone, a, lda,work, ldwork ) + call stdlib${ii}$_ztrmm( 'L', 'L', 'N', 'U', k, n-k, cone, a, lda,work, ldwork ) end if ! col2_(7) compute a2: = a2 - w2 = @@ -11059,7 +11062,7 @@ module stdlib_linalg_lapack_z ! a1 = a(1:k, 1:k) into the upper-triangular ! w1 = work(1:k, 1:k) column-by-column. do j = 1, k - call stdlib_zcopy( j, a( 1, j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_zcopy( 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 @@ -11072,16 +11075,16 @@ module stdlib_linalg_lapack_z ! 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_ztrmm( 'L', 'L', 'C', 'U', k, k, cone, a, lda,work, ldwork ) + call stdlib${ii}$_ztrmm( 'L', 'L', 'C', 'U', k, k, cone, a, lda,work, ldwork ) end if ! col1_(3) compute w1: = t * w1, ! t is upper-triangular, ! w1 is upper-triangular with zeroes below the diagonal. - call stdlib_ztrmm( 'L', 'U', 'N', 'N', k, k, cone, t, ldt,work, ldwork ) + call stdlib${ii}$_ztrmm( 'L', 'U', 'N', 'N', k, k, cone, t, ldt,work, ldwork ) ! col1_(4) compute b1: = - v2 * w1 = - b1 * w1, ! v2 = b1, w1 is upper-triangular with zeroes below the diagonal. - if( m>0 ) then - call stdlib_ztrmm( 'R', 'U', 'N', 'N', m, k, -cone, work, ldwork,b, ldb ) + if( m>0_${ik}$ ) then + call stdlib${ii}$_ztrmm( 'R', 'U', 'N', 'N', m, k, -cone, work, ldwork,b, ldb ) end if if( lnotident ) then ! col1_(5) compute w1: = v1 * w1 = a1 * w1, @@ -11089,7 +11092,7 @@ module stdlib_linalg_lapack_z ! 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_ztrmm( 'L', 'L', 'N', 'U', k, k, cone, a, lda,work, ldwork ) + call stdlib${ii}$_ztrmm( 'L', 'L', 'N', 'U', k, k, cone, a, lda,work, ldwork ) ! col1_(6) compute a1: = a1 - w1 = a(1:k, 1:k) - work(1:k, 1:k) ! column-by-column. a1 is upper-triangular on input. ! if ident, a1 is square on output, and w1 is square, @@ -11109,10 +11112,10 @@ module stdlib_linalg_lapack_z end do end do return - end subroutine stdlib_zlarfb_gett + end subroutine stdlib${ii}$_zlarfb_gett - pure subroutine stdlib_zlarfg( n, alpha, x, incx, tau ) + pure subroutine stdlib${ii}$_zlarfg( n, alpha, x, incx, tau ) !! ZLARFG generates a complex elementary reflector H of order n, such !! that !! H**H * ( alpha ) = ( beta ), H**H * H = I. @@ -11130,7 +11133,7 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: alpha complex(dp), intent(out) :: tau ! Array Arguments @@ -11138,16 +11141,16 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! Local Scalars - integer(ilp) :: j, knt + integer(${ik}$) :: j, knt real(dp) :: alphi, alphr, beta, rsafmn, safmin, xnorm ! Intrinsic Functions intrinsic :: abs,real,cmplx,aimag,sign ! Executable Statements - if( n<=0 ) then + if( n<=0_${ik}$ ) then tau = zero return end if - xnorm = stdlib_dznrm2( n-1, x, incx ) + xnorm = stdlib${ii}$_dznrm2( n-1, x, incx ) alphr = real( alpha,KIND=dp) alphi = aimag( alpha ) if( xnorm==zero .and. alphi==zero ) then @@ -11155,27 +11158,27 @@ module stdlib_linalg_lapack_z tau = zero else ! general case - beta = -sign( stdlib_dlapy3( alphr, alphi, xnorm ), alphr ) - safmin = stdlib_dlamch( 'S' ) / stdlib_dlamch( 'E' ) + beta = -sign( stdlib${ii}$_dlapy3( alphr, alphi, xnorm ), alphr ) + safmin = stdlib${ii}$_dlamch( 'S' ) / stdlib${ii}$_dlamch( 'E' ) rsafmn = one / safmin - knt = 0 + knt = 0_${ik}$ if( abs( beta )1 ) then + if( i>1_${ik}$ ) then prevlastv = max( prevlastv, lastv ) else prevlastv = lastv @@ -11397,7 +11400,7 @@ module stdlib_linalg_lapack_z end if end do else - prevlastv = 1 + prevlastv = 1_${ik}$ do i = k, 1, -1 if( tau( i )==czero ) then ! h(i) = i @@ -11417,8 +11420,8 @@ module stdlib_linalg_lapack_z end do j = max( lastv, prevlastv ) ! t(i+1:k,i) = -tau(i) * v(j:n-k+i,i+1:k)**h * v(j:n-k+i,i) - call stdlib_zgemv( 'CONJUGATE TRANSPOSE', n-k+i-j, k-i,-tau( i ), v( j, & - i+1 ), ldv, v( j, i ),1, cone, t( i+1, i ), 1 ) + call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', n-k+i-j, k-i,-tau( i ), v( j, & + i+1 ), ldv, v( j, i ),1_${ik}$, cone, t( i+1, i ), 1_${ik}$ ) else ! skip any leading zeros. do lastv = 1, i-1 @@ -11429,13 +11432,13 @@ module stdlib_linalg_lapack_z end do j = max( lastv, prevlastv ) ! t(i+1:k,i) = -tau(i) * v(i+1:k,j:n-k+i) * v(i,j:n-k+i)**h - call stdlib_zgemm( 'N', 'C', k-i, 1, n-k+i-j, -tau( i ),v( i+1, j ), & + call stdlib${ii}$_zgemm( 'N', 'C', k-i, 1_${ik}$, n-k+i-j, -tau( i ),v( i+1, j ), & ldv, v( i, j ), ldv,cone, t( i+1, i ), ldt ) end if ! t(i+1:k,i) := t(i+1:k,i+1:k) * t(i+1:k,i) - call stdlib_ztrmv( '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}$_ztrmv( '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 @@ -11446,10 +11449,10 @@ module stdlib_linalg_lapack_z end do end if return - end subroutine stdlib_zlarft + end subroutine stdlib${ii}$_zlarft - pure subroutine stdlib_zlarfx( side, m, n, v, tau, c, ldc, work ) + pure subroutine stdlib${ii}$_zlarfx( side, m, n, v, tau, c, ldc, work ) !! ZLARFX applies a complex elementary reflector H to a complex m by n !! matrix C, from either the left or the right. H is represented in the !! form @@ -11462,7 +11465,7 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(in) :: tau ! Array Arguments complex(dp), intent(inout) :: c(ldc,*) @@ -11471,7 +11474,7 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! Local Scalars - integer(ilp) :: j + integer(${ik}$) :: j complex(dp) :: sum, t1, t10, t2, t3, t4, t5, t6, t7, t8, t9, v1, v10, v2, v3, v4, v5, & v6, v7, v8, v9 ! Intrinsic Functions @@ -11482,479 +11485,479 @@ module stdlib_linalg_lapack_z ! 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_zlarf( side, m, n, v, 1, tau, c, ldc, work ) + call stdlib${ii}$_zlarf( side, m, n, v, 1_${ik}$, tau, c, ldc, work ) go to 410 10 continue ! special code for 1 x 1 householder - t1 = cone - tau*v( 1 )*conjg( v( 1 ) ) + t1 = cone - tau*v( 1_${ik}$ )*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( v2 ) - v3 = conjg( v( 3 ) ) + v3 = conjg( v( 3_${ik}$ ) ) t3 = tau*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( v2 ) - v3 = conjg( v( 3 ) ) + v3 = conjg( v( 3_${ik}$ ) ) t3 = tau*conjg( v3 ) - v4 = conjg( v( 4 ) ) + v4 = conjg( v( 4_${ik}$ ) ) t4 = tau*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( v2 ) - v3 = conjg( v( 3 ) ) + v3 = conjg( v( 3_${ik}$ ) ) t3 = tau*conjg( v3 ) - v4 = conjg( v( 4 ) ) + v4 = conjg( v( 4_${ik}$ ) ) t4 = tau*conjg( v4 ) - v5 = conjg( v( 5 ) ) + v5 = conjg( v( 5_${ik}$ ) ) t5 = tau*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( v2 ) - v3 = conjg( v( 3 ) ) + v3 = conjg( v( 3_${ik}$ ) ) t3 = tau*conjg( v3 ) - v4 = conjg( v( 4 ) ) + v4 = conjg( v( 4_${ik}$ ) ) t4 = tau*conjg( v4 ) - v5 = conjg( v( 5 ) ) + v5 = conjg( v( 5_${ik}$ ) ) t5 = tau*conjg( v5 ) - v6 = conjg( v( 6 ) ) + v6 = conjg( v( 6_${ik}$ ) ) t6 = tau*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( v2 ) - v3 = conjg( v( 3 ) ) + v3 = conjg( v( 3_${ik}$ ) ) t3 = tau*conjg( v3 ) - v4 = conjg( v( 4 ) ) + v4 = conjg( v( 4_${ik}$ ) ) t4 = tau*conjg( v4 ) - v5 = conjg( v( 5 ) ) + v5 = conjg( v( 5_${ik}$ ) ) t5 = tau*conjg( v5 ) - v6 = conjg( v( 6 ) ) + v6 = conjg( v( 6_${ik}$ ) ) t6 = tau*conjg( v6 ) - v7 = conjg( v( 7 ) ) + v7 = conjg( v( 7_${ik}$ ) ) t7 = tau*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( v2 ) - v3 = conjg( v( 3 ) ) + v3 = conjg( v( 3_${ik}$ ) ) t3 = tau*conjg( v3 ) - v4 = conjg( v( 4 ) ) + v4 = conjg( v( 4_${ik}$ ) ) t4 = tau*conjg( v4 ) - v5 = conjg( v( 5 ) ) + v5 = conjg( v( 5_${ik}$ ) ) t5 = tau*conjg( v5 ) - v6 = conjg( v( 6 ) ) + v6 = conjg( v( 6_${ik}$ ) ) t6 = tau*conjg( v6 ) - v7 = conjg( v( 7 ) ) + v7 = conjg( v( 7_${ik}$ ) ) t7 = tau*conjg( v7 ) - v8 = conjg( v( 8 ) ) + v8 = conjg( v( 8_${ik}$ ) ) t8 = tau*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( v2 ) - v3 = conjg( v( 3 ) ) + v3 = conjg( v( 3_${ik}$ ) ) t3 = tau*conjg( v3 ) - v4 = conjg( v( 4 ) ) + v4 = conjg( v( 4_${ik}$ ) ) t4 = tau*conjg( v4 ) - v5 = conjg( v( 5 ) ) + v5 = conjg( v( 5_${ik}$ ) ) t5 = tau*conjg( v5 ) - v6 = conjg( v( 6 ) ) + v6 = conjg( v( 6_${ik}$ ) ) t6 = tau*conjg( v6 ) - v7 = conjg( v( 7 ) ) + v7 = conjg( v( 7_${ik}$ ) ) t7 = tau*conjg( v7 ) - v8 = conjg( v( 8 ) ) + v8 = conjg( v( 8_${ik}$ ) ) t8 = tau*conjg( v8 ) - v9 = conjg( v( 9 ) ) + v9 = conjg( v( 9_${ik}$ ) ) t9 = tau*conjg( 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 = conjg( v( 1 ) ) + v1 = conjg( v( 1_${ik}$ ) ) t1 = tau*conjg( v1 ) - v2 = conjg( v( 2 ) ) + v2 = conjg( v( 2_${ik}$ ) ) t2 = tau*conjg( v2 ) - v3 = conjg( v( 3 ) ) + v3 = conjg( v( 3_${ik}$ ) ) t3 = tau*conjg( v3 ) - v4 = conjg( v( 4 ) ) + v4 = conjg( v( 4_${ik}$ ) ) t4 = tau*conjg( v4 ) - v5 = conjg( v( 5 ) ) + v5 = conjg( v( 5_${ik}$ ) ) t5 = tau*conjg( v5 ) - v6 = conjg( v( 6 ) ) + v6 = conjg( v( 6_${ik}$ ) ) t6 = tau*conjg( v6 ) - v7 = conjg( v( 7 ) ) + v7 = conjg( v( 7_${ik}$ ) ) t7 = tau*conjg( v7 ) - v8 = conjg( v( 8 ) ) + v8 = conjg( v( 8_${ik}$ ) ) t8 = tau*conjg( v8 ) - v9 = conjg( v( 9 ) ) + v9 = conjg( v( 9_${ik}$ ) ) t9 = tau*conjg( v9 ) - v10 = conjg( v( 10 ) ) + v10 = conjg( v( 10_${ik}$ ) ) t10 = tau*conjg( 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_zlarf( side, m, n, v, 1, tau, c, ldc, work ) + call stdlib${ii}$_zlarf( side, m, n, v, 1_${ik}$, tau, c, ldc, work ) go to 410 210 continue ! special code for 1 x 1 householder - t1 = cone - tau*v( 1 )*conjg( v( 1 ) ) + t1 = cone - tau*v( 1_${ik}$ )*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( v2 ) - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( v2 ) - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*conjg( v3 ) - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( v2 ) - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*conjg( v3 ) - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*conjg( v4 ) - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( v2 ) - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*conjg( v3 ) - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*conjg( v4 ) - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*conjg( v5 ) - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( v2 ) - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*conjg( v3 ) - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*conjg( v4 ) - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*conjg( v5 ) - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*conjg( v6 ) - v7 = v( 7 ) + v7 = v( 7_${ik}$ ) t7 = tau*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( v2 ) - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*conjg( v3 ) - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*conjg( v4 ) - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*conjg( v5 ) - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*conjg( v6 ) - v7 = v( 7 ) + v7 = v( 7_${ik}$ ) t7 = tau*conjg( v7 ) - v8 = v( 8 ) + v8 = v( 8_${ik}$ ) t8 = tau*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( v2 ) - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*conjg( v3 ) - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*conjg( v4 ) - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*conjg( v5 ) - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*conjg( v6 ) - v7 = v( 7 ) + v7 = v( 7_${ik}$ ) t7 = tau*conjg( v7 ) - v8 = v( 8 ) + v8 = v( 8_${ik}$ ) t8 = tau*conjg( v8 ) - v9 = v( 9 ) + v9 = v( 9_${ik}$ ) t9 = tau*conjg( 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 ) + v1 = v( 1_${ik}$ ) t1 = tau*conjg( v1 ) - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = tau*conjg( v2 ) - v3 = v( 3 ) + v3 = v( 3_${ik}$ ) t3 = tau*conjg( v3 ) - v4 = v( 4 ) + v4 = v( 4_${ik}$ ) t4 = tau*conjg( v4 ) - v5 = v( 5 ) + v5 = v( 5_${ik}$ ) t5 = tau*conjg( v5 ) - v6 = v( 6 ) + v6 = v( 6_${ik}$ ) t6 = tau*conjg( v6 ) - v7 = v( 7 ) + v7 = v( 7_${ik}$ ) t7 = tau*conjg( v7 ) - v8 = v( 8 ) + v8 = v( 8_${ik}$ ) t8 = tau*conjg( v8 ) - v9 = v( 9 ) + v9 = v( 9_${ik}$ ) t9 = tau*conjg( v9 ) - v10 = v( 10 ) + v10 = v( 10_${ik}$ ) t10 = tau*conjg( 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 continue return - end subroutine stdlib_zlarfx + end subroutine stdlib${ii}$_zlarfx - pure subroutine stdlib_zlarfy( uplo, n, v, incv, tau, c, ldc, work ) + pure subroutine stdlib${ii}$_zlarfy( uplo, n, v, incv, tau, c, ldc, work ) !! ZLARFY applies an elementary reflector, or Householder matrix, H, !! to an n x n Hermitian matrix C, from both the left and the right. !! H is represented in the form @@ -11966,7 +11969,7 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(in) :: tau ! Array Arguments complex(dp), intent(inout) :: c(ldc,*) @@ -11979,81 +11982,81 @@ module stdlib_linalg_lapack_z ! Executable Statements if( tau==czero )return ! form w:= c * v - call stdlib_zhemv( uplo, n, cone, c, ldc, v, incv, czero, work, 1 ) - alpha = -chalf*tau*stdlib_zdotc( n, work, 1, v, incv ) - call stdlib_zaxpy( n, alpha, v, incv, work, 1 ) + call stdlib${ii}$_zhemv( uplo, n, cone, c, ldc, v, incv, czero, work, 1_${ik}$ ) + alpha = -chalf*tau*stdlib${ii}$_zdotc( n, work, 1_${ik}$, v, incv ) + call stdlib${ii}$_zaxpy( n, alpha, v, incv, work, 1_${ik}$ ) ! c := c - v * w' - w * v' - call stdlib_zher2( uplo, n, -tau, v, incv, work, 1, c, ldc ) + call stdlib${ii}$_zher2( uplo, n, -tau, v, incv, work, 1_${ik}$, c, ldc ) return - end subroutine stdlib_zlarfy + end subroutine stdlib${ii}$_zlarfy - pure subroutine stdlib_zlarnv( idist, iseed, n, x ) + pure subroutine stdlib${ii}$_zlarnv( idist, iseed, n, x ) !! ZLARNV returns a vector of n random complex 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}$) complex(dp), intent(out) :: x(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: lv = 128 + integer(${ik}$), parameter :: lv = 128_${ik}$ real(dp), parameter :: twopi = 6.28318530717958647692528676655900576839e+0_dp ! Local Scalars - integer(ilp) :: i, il, iv + integer(${ik}$) :: i, il, iv ! Local Arrays real(dp) :: u(lv) ! Intrinsic Functions intrinsic :: cmplx,exp,log,min,sqrt ! Executable Statements do 60 iv = 1, n, lv / 2 - il = min( lv / 2, n-iv+1 ) - ! call stdlib_dlaruv to generate 2*il realnumbers from a uniform (0,1,KIND=dp) + il = min( lv / 2_${ik}$, n-iv+1 ) + ! call stdlib${ii}$_dlaruv to generate 2*il realnumbers from a uniform (0,1,KIND=dp) ! distribution (2*il <= lv) - call stdlib_dlaruv( iseed, 2*il, u ) - if( idist==1 ) then + call stdlib${ii}$_dlaruv( iseed, 2_${ik}$*il, u ) + if( idist==1_${ik}$ ) then ! copy generated numbers do i = 1, il - x( iv+i-1 ) = cmplx( u( 2*i-1 ), u( 2*i ),KIND=dp) + x( iv+i-1 ) = cmplx( u( 2_${ik}$*i-1 ), u( 2_${ik}$*i ),KIND=dp) end do - else if( idist==2 ) then + else if( idist==2_${ik}$ ) then ! convert generated numbers to uniform (-1,1) distribution do i = 1, il - x( iv+i-1 ) = cmplx( two*u( 2*i-1 )-one,two*u( 2*i )-one,KIND=dp) + x( iv+i-1 ) = cmplx( two*u( 2_${ik}$*i-1 )-one,two*u( 2_${ik}$*i )-one,KIND=dp) end do - else if( idist==3 ) then + else if( idist==3_${ik}$ ) then ! convert generated numbers to normal (0,1) distribution do i = 1, il - x( iv+i-1 ) = sqrt( -two*log( u( 2*i-1 ) ) )*exp( cmplx( zero, twopi*u( 2*i ),& + x( iv+i-1 ) = sqrt( -two*log( u( 2_${ik}$*i-1 ) ) )*exp( cmplx( zero, twopi*u( 2_${ik}$*i ),& KIND=dp) ) end do - else if( idist==4 ) then + else if( idist==4_${ik}$ ) then ! convert generated numbers to complex numbers uniformly ! distributed on the unit disk do i = 1, il - x( iv+i-1 ) = sqrt( u( 2*i-1 ) )*exp( cmplx( zero, twopi*u( 2*i ),KIND=dp) ) + x( iv+i-1 ) = sqrt( u( 2_${ik}$*i-1 ) )*exp( cmplx( zero, twopi*u( 2_${ik}$*i ),KIND=dp) ) end do - else if( idist==5 ) then + else if( idist==5_${ik}$ ) then ! convert generated numbers to complex numbers uniformly ! distributed on the unit circle do i = 1, il - x( iv+i-1 ) = exp( cmplx( zero, twopi*u( 2*i ),KIND=dp) ) + x( iv+i-1 ) = exp( cmplx( zero, twopi*u( 2_${ik}$*i ),KIND=dp) ) end do end if 60 continue return - end subroutine stdlib_zlarnv + end subroutine stdlib${ii}$_zlarnv - pure subroutine stdlib_zlartg( f, g, c, s, r ) + pure subroutine stdlib${ii}$_zlartg( f, g, c, s, r ) !! ZLARTG generates a plane rotation so that !! [ C S ] . [ F ] = [ R ] !! [ -conjg(S) C ] [ G ] [ 0 ] @@ -12092,7 +12095,7 @@ module stdlib_linalg_lapack_z ! Statement Functions real(dp) :: abssq ! Statement Function Definitions - abssq( t ) = real( t,KIND=dp)**2 + aimag( t )**2 + abssq( t ) = real( t,KIND=dp)**2_${ik}$ + aimag( t )**2_${ik}$ ! Executable Statements if( g == czero ) then c = one @@ -12130,7 +12133,7 @@ module stdlib_linalg_lapack_z else d = sqrt( f2 )*sqrt( h2 ) end if - p = 1 / d + p = 1_${ik}$ / d c = f2*p s = conjg( g )*( f*p ) r = f*( h2*p ) @@ -12148,7 +12151,7 @@ module stdlib_linalg_lapack_z w = v * uu fs = f*vv f2 = abssq( fs ) - h2 = f2*w**2 + g2 + h2 = f2*w**2_${ik}$ + g2 else ! otherwise use the same scaling for f and g. w = one @@ -12161,17 +12164,17 @@ module stdlib_linalg_lapack_z else d = sqrt( f2 )*sqrt( h2 ) end if - p = 1 / d + p = 1_${ik}$ / d c = ( f2*p )*w s = conjg( gs )*( fs*p ) r = ( fs*( h2*p ) )*u end if end if return - end subroutine stdlib_zlartg + end subroutine stdlib${ii}$_zlartg - pure subroutine stdlib_zlartv( n, x, incx, y, incy, c, s, incc ) + pure subroutine stdlib${ii}$_zlartv( n, x, incx, y, incy, c, s, incc ) !! ZLARTV applies a vector of complex plane rotations with real cosines !! to elements of the complex vectors x and y. For i = 1,2,...,n !! ( x(i) ) := ( c(i) s(i) ) ( x(i) ) @@ -12180,21 +12183,21 @@ module stdlib_linalg_lapack_z ! -- 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(dp), intent(in) :: c(*) complex(dp), intent(in) :: s(*) complex(dp), intent(inout) :: x(*), y(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ic, ix, iy + integer(${ik}$) :: i, ic, ix, iy complex(dp) :: xi, yi ! Intrinsic Functions intrinsic :: conjg ! 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 ) @@ -12205,10 +12208,10 @@ module stdlib_linalg_lapack_z ic = ic + incc end do return - end subroutine stdlib_zlartv + end subroutine stdlib${ii}$_zlartv - pure subroutine stdlib_zlarz( side, m, n, l, v, incv, tau, c, ldc, work ) + pure subroutine stdlib${ii}$_zlarz( side, m, n, l, v, incv, tau, c, ldc, work ) !! ZLARZ applies a complex elementary reflector H to a complex !! M-by-N matrix C, from either the left or the right. H is represented !! in the form @@ -12223,7 +12226,7 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(in) :: tau ! Array Arguments complex(dp), intent(inout) :: c(ldc,*) @@ -12236,38 +12239,38 @@ module stdlib_linalg_lapack_z ! form h * c if( tau/=czero ) then ! w( 1:n ) = conjg( c( 1, 1:n ) ) - call stdlib_zcopy( n, c, ldc, work, 1 ) - call stdlib_zlacgv( n, work, 1 ) + call stdlib${ii}$_zcopy( n, c, ldc, work, 1_${ik}$ ) + call stdlib${ii}$_zlacgv( n, work, 1_${ik}$ ) ! w( 1:n ) = conjg( w( 1:n ) + c( m-l+1:m, 1:n )**h * v( 1:l ) ) - call stdlib_zgemv( 'CONJUGATE TRANSPOSE', l, n, cone, c( m-l+1, 1 ),ldc, v, incv,& - cone, work, 1 ) - call stdlib_zlacgv( n, work, 1 ) + call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', l, n, cone, c( m-l+1, 1_${ik}$ ),ldc, v, incv,& + cone, work, 1_${ik}$ ) + call stdlib${ii}$_zlacgv( n, work, 1_${ik}$ ) ! c( 1, 1:n ) = c( 1, 1:n ) - tau * w( 1:n ) - call stdlib_zaxpy( n, -tau, work, 1, c, ldc ) + call stdlib${ii}$_zaxpy( n, -tau, work, 1_${ik}$, c, ldc ) ! c( m-l+1:m, 1:n ) = c( m-l+1:m, 1:n ) - ... ! tau * v( 1:l ) * w( 1:n )**h - call stdlib_zgeru( l, n, -tau, v, incv, work, 1, c( m-l+1, 1 ),ldc ) + call stdlib${ii}$_zgeru( l, n, -tau, v, incv, work, 1_${ik}$, c( m-l+1, 1_${ik}$ ),ldc ) end if else ! form c * h if( tau/=czero ) then ! w( 1:m ) = c( 1:m, 1 ) - call stdlib_zcopy( m, c, 1, work, 1 ) + call stdlib${ii}$_zcopy( m, c, 1_${ik}$, work, 1_${ik}$ ) ! w( 1:m ) = w( 1:m ) + c( 1:m, n-l+1:n, 1:n ) * v( 1:l ) - call stdlib_zgemv( 'NO TRANSPOSE', m, l, cone, c( 1, n-l+1 ), ldc,v, incv, cone, & - work, 1 ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', m, l, cone, c( 1_${ik}$, n-l+1 ), ldc,v, incv, cone, & + work, 1_${ik}$ ) ! c( 1:m, 1 ) = c( 1:m, 1 ) - tau * w( 1:m ) - call stdlib_zaxpy( m, -tau, work, 1, c, 1 ) + call stdlib${ii}$_zaxpy( m, -tau, work, 1_${ik}$, c, 1_${ik}$ ) ! c( 1:m, n-l+1:n ) = c( 1:m, n-l+1:n ) - ... ! tau * w( 1:m ) * v( 1:l )**h - call stdlib_zgerc( m, l, -tau, work, 1, v, incv, c( 1, n-l+1 ),ldc ) + call stdlib${ii}$_zgerc( m, l, -tau, work, 1_${ik}$, v, incv, c( 1_${ik}$, n-l+1 ),ldc ) end if end if return - end subroutine stdlib_zlarz + end subroutine stdlib${ii}$_zlarz - pure subroutine stdlib_zlarzb( side, trans, direct, storev, m, n, k, l, v,ldv, t, ldt, c, & + pure subroutine stdlib${ii}$_zlarzb( side, trans, direct, storev, m, n, k, l, v,ldv, t, ldt, c, & !! ZLARZB applies a complex block reflector H or its transpose H**H !! to a complex distributed M-by-N C from the left or the right. !! Currently, only STOREV = 'R' and DIRECT = 'B' are supported. @@ -12277,7 +12280,7 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: c(ldc,*), t(ldt,*), v(ldv,*) complex(dp), intent(out) :: work(ldwork,*) @@ -12285,19 +12288,19 @@ module stdlib_linalg_lapack_z ! 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( 'ZLARZB', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZLARZB', -info ) return end if if( stdlib_lsame( trans, 'N' ) ) then @@ -12309,14 +12312,14 @@ module stdlib_linalg_lapack_z ! form h * c or h**h * c ! w( 1:n, 1:k ) = c( 1:k, 1:n )**h do j = 1, k - call stdlib_zcopy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) + call stdlib${ii}$_zcopy( 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 )**h * v( 1:k, 1:l )**t - if( l>0 )call stdlib_zgemm( 'TRANSPOSE', 'CONJUGATE TRANSPOSE', n, k, l,cone, c( m-& - l+1, 1 ), ldc, v, ldv, cone, work,ldwork ) + if( l>0_${ik}$ )call stdlib${ii}$_zgemm( 'TRANSPOSE', 'CONJUGATE TRANSPOSE', n, k, l,cone, c( m-& + l+1, 1_${ik}$ ), ldc, v, ldv, cone, work,ldwork ) ! w( 1:n, 1:k ) = w( 1:n, 1:k ) * t**t or w( 1:m, 1:k ) * t - call stdlib_ztrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k, cone, t,ldt, work, & + call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', transt, 'NON-UNIT', n, k, cone, t,ldt, work, & ldwork ) ! c( 1:k, 1:n ) = c( 1:k, 1:n ) - w( 1:n, 1:k )**h do j = 1, n @@ -12326,27 +12329,27 @@ module stdlib_linalg_lapack_z end do ! c( m-l+1:m, 1:n ) = c( m-l+1:m, 1:n ) - ... ! v( 1:k, 1:l )**h * w( 1:n, 1:k )**h - if( l>0 )call stdlib_zgemm( 'TRANSPOSE', 'TRANSPOSE', l, n, k, -cone, v, ldv,work, & - ldwork, cone, c( m-l+1, 1 ), ldc ) + if( l>0_${ik}$ )call stdlib${ii}$_zgemm( 'TRANSPOSE', 'TRANSPOSE', l, n, k, -cone, v, ldv,work, & + ldwork, cone, c( m-l+1, 1_${ik}$ ), ldc ) else if( stdlib_lsame( side, 'R' ) ) then ! form c * h or c * h**h ! w( 1:m, 1:k ) = c( 1:m, 1:k ) do j = 1, k - call stdlib_zcopy( m, c( 1, j ), 1, work( 1, j ), 1 ) + call stdlib${ii}$_zcopy( 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 )**h - if( l>0 )call stdlib_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, l, cone,c( 1, n-l+1 )& + if( l>0_${ik}$ )call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', m, k, l, cone,c( 1_${ik}$, n-l+1 )& , ldc, v, ldv, cone, work, ldwork ) ! w( 1:m, 1:k ) = w( 1:m, 1:k ) * conjg( t ) or ! w( 1:m, 1:k ) * t**h do j = 1, k - call stdlib_zlacgv( k-j+1, t( j, j ), 1 ) + call stdlib${ii}$_zlacgv( k-j+1, t( j, j ), 1_${ik}$ ) end do - call stdlib_ztrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k, cone, t,ldt, work, & + call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', trans, 'NON-UNIT', m, k, cone, t,ldt, work, & ldwork ) do j = 1, k - call stdlib_zlacgv( k-j+1, t( j, j ), 1 ) + call stdlib${ii}$_zlacgv( k-j+1, t( j, j ), 1_${ik}$ ) end do ! c( 1:m, 1:k ) = c( 1:m, 1:k ) - w( 1:m, 1:k ) do j = 1, k @@ -12357,19 +12360,19 @@ module stdlib_linalg_lapack_z ! c( 1:m, n-l+1:n ) = c( 1:m, n-l+1:n ) - ... ! w( 1:m, 1:k ) * conjg( v( 1:k, 1:l ) ) do j = 1, l - call stdlib_zlacgv( k, v( 1, j ), 1 ) + call stdlib${ii}$_zlacgv( k, v( 1_${ik}$, j ), 1_${ik}$ ) end do - if( l>0 )call stdlib_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, l, k, -cone,work, & - ldwork, v, ldv, cone, c( 1, n-l+1 ), ldc ) + if( l>0_${ik}$ )call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m, l, k, -cone,work, & + ldwork, v, ldv, cone, c( 1_${ik}$, n-l+1 ), ldc ) do j = 1, l - call stdlib_zlacgv( k, v( 1, j ), 1 ) + call stdlib${ii}$_zlacgv( k, v( 1_${ik}$, j ), 1_${ik}$ ) end do end if return - end subroutine stdlib_zlarzb + end subroutine stdlib${ii}$_zlarzb - pure subroutine stdlib_zlarzt( direct, storev, n, k, v, ldv, tau, t, ldt ) + pure subroutine stdlib${ii}$_zlarzt( direct, storev, n, k, v, ldv, tau, t, ldt ) !! ZLARZT forms the triangular factor T of a complex block reflector !! H of order > n, which is defined as a product of k elementary !! reflectors. @@ -12387,7 +12390,7 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(out) :: t(ldt,*) complex(dp), intent(in) :: tau(*) @@ -12395,17 +12398,17 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! 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( 'ZLARZT', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZLARZT', -info ) return end if do i = k, 1, -1 @@ -12418,22 +12421,22 @@ module stdlib_linalg_lapack_z ! general case if( i=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 = -1_${ik}$ + end if + if( itype==-1_${ik}$ ) then + info = -1_${ik}$ + else if( cfrom==zero .or. stdlib${ii}$_disnan(cfrom) ) then + info = -4_${ik}$ + else if( stdlib${ii}$_disnan(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 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 ax = abs(aimag(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 @@ -12999,12 +13002,12 @@ module stdlib_linalg_lapack_z 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 @@ -13029,7 +13032,7 @@ module stdlib_linalg_lapack_z 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 @@ -13040,42 +13043,42 @@ module stdlib_linalg_lapack_z sumsq = amed end if return - end subroutine stdlib_zlassq + end subroutine stdlib${ii}$_zlassq - pure subroutine stdlib_zlaswp( n, a, lda, k1, k2, ipiv, incx ) + pure subroutine stdlib${ii}$_zlaswp( n, a, lda, k1, k2, ipiv, incx ) !! ZLASWP performs a series of row interchanges on the matrix A. !! One row interchange is initiated for each of rows K1 through K2 of A. ! -- lapack auxiliary routine -- ! -- 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, k1, k2, lda, n + integer(${ik}$), intent(in) :: incx, k1, k2, lda, n ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) complex(dp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, i1, i2, inc, ip, ix, ix0, j, k, n32 + integer(${ik}$) :: i, i1, i2, inc, ip, ix, ix0, j, k, n32 complex(dp) :: temp ! Executable Statements ! interchange row i with row ipiv(k1+(i-k1)*abs(incx)) for each of rows ! k1 through k2. - if( incx>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 @@ -13092,7 +13095,7 @@ module stdlib_linalg_lapack_z 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 ) @@ -13107,10 +13110,10 @@ module stdlib_linalg_lapack_z end do end if return - end subroutine stdlib_zlaswp + end subroutine stdlib${ii}$_zlaswp - pure subroutine stdlib_zlasyf( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) + pure subroutine stdlib${ii}$_zlasyf( uplo, n, nb, kb, a, lda, ipiv, w, ldw, info ) !! ZLASYF computes a partial factorization of a complex symmetric matrix !! A using the Bunch-Kaufman diagonal pivoting method. The partial !! factorization has the form: @@ -13129,10 +13132,10 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: w(ldw,*) ! ===================================================================== @@ -13142,7 +13145,7 @@ module stdlib_linalg_lapack_z ! 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(dp) :: absakk, alpha, colmax, rowmax complex(dp) :: d11, d21, d22, r1, t, z ! Intrinsic Functions @@ -13152,7 +13155,7 @@ module stdlib_linalg_lapack_z ! Statement Function Definitions cabs1( z ) = abs( real( z,KIND=dp) ) + abs( aimag( z ) ) ! 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 @@ -13167,23 +13170,23 @@ module stdlib_linalg_lapack_z ! exit from loop if( ( k<=n-nb+1 .and. nb1 ) then - imax = stdlib_izamax( k-1, w( 1, kw ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_izamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) colmax = cabs1( w( imax, kw ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k else if( absakk>=alpha*colmax ) then @@ -13191,17 +13194,17 @@ module stdlib_linalg_lapack_z kp = k else ! copy column imax to column kw-1 of w and update it - call stdlib_zcopy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) - call stdlib_zcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_zcopy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) + call stdlib${ii}$_zcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ ) - if( k1 ) then - jmax = stdlib_izamax( imax-1, w( 1, kw-1 ), 1 ) + if( imax>1_${ik}$ ) then + jmax = stdlib${ii}$_izamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) rowmax = max( rowmax, cabs1( w( jmax, kw-1 ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then @@ -13212,17 +13215,17 @@ module stdlib_linalg_lapack_z ! pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_zcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_zcopy( 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 ! 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. @@ -13233,16 +13236,16 @@ module stdlib_linalg_lapack_z ! (or k and k-1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = a( kk, kk ) - call stdlib_zcopy( kk-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - if( kp>1 )call stdlib_zcopy( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_zcopy( kk-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_zcopy( 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 ! later overwritten). interchange rows kk and kp ! in last kkw to nb columns of w. - if( k2 ) then + if( k>2_${ik}$ ) then ! compose the columns of the inverse of 2-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 @@ -13305,7 +13308,7 @@ module stdlib_linalg_lapack_z 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 @@ -13322,31 +13325,31 @@ module stdlib_linalg_lapack_z jb = min( nb, k-j+1 ) ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_zgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& - kw+1 ), ldw, cone,a( j, jj ), 1 ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& + kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ ) end do ! update the rectangular superdiagonal block - call stdlib_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( 1, k+1 ), & - lda, w( j, kw+1 ), ldw,cone, a( 1, j ), lda ) + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb, n-k,-cone, a( 1_${ik}$, k+1 ), & + lda, w( j, kw+1 ), ldw,cone, a( 1_${ik}$, j ), lda ) end do ! put u12 in standard form by partially undoing the interchanges ! in columns k+1:n 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_zswap( n-j+1, a( jp, j ), lda, a( jj, j ), & + j = j + 1_${ik}$ + if( jp/=jj .and. j<=n )call stdlib${ii}$_zswap( 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_zcopy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) - call stdlib_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ), lda,w( k, 1 ), ldw,& - cone, w( k, k ), 1 ) - kstep = 1 + call stdlib${ii}$_zcopy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ), lda,w( k, 1_${ik}$ ), ldw,& + cone, w( k, k ), 1_${ik}$ ) + 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 absakk = cabs1( w( k, k ) ) ! imax is the row-index of the largest off-diagonal element in if( k=alpha*colmax ) then @@ -13385,16 +13388,16 @@ module stdlib_linalg_lapack_z kp = k else ! copy column imax to column k+1 of w and update it - call stdlib_zcopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1 ) - call stdlib_zcopy( n-imax+1, a( imax, imax ), 1, w( imax, k+1 ),1 ) - call stdlib_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ),lda, w( imax, & - 1 ), ldw, cone, w( k, k+1 ),1 ) + call stdlib${ii}$_zcopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$ ) + call stdlib${ii}$_zcopy( n-imax+1, a( imax, imax ), 1_${ik}$, w( imax, k+1 ),1_${ik}$ ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ),lda, w( imax, & + 1_${ik}$ ), ldw, cone, w( k, k+1 ),1_${ik}$ ) ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value - jmax = k - 1 + stdlib_izamax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1_${ik}$ + stdlib${ii}$_izamax( imax-k, w( k, k+1 ), 1_${ik}$ ) rowmax = cabs1( w( jmax, k+1 ) ) if( imax=alpha*colmax*( colmax / rowmax ) ) then @@ -13405,17 +13408,17 @@ module stdlib_linalg_lapack_z ! pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_zcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_zcopy( 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 ! 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 @@ -13424,17 +13427,17 @@ module stdlib_linalg_lapack_z ! (or k and k+1 for 2-by-2 pivot) of a, since these columns ! will be later overwritten. a( kp, kp ) = a( kk, kk ) - call stdlib_zcopy( kp-kk-1, a( kk+1, kk ), 1, a( kp, kk+1 ),lda ) - if( kp1 )call stdlib_zswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_zswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + if( k>1_${ik}$ )call stdlib${ii}$_zswap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) + call stdlib${ii}$_zswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of w now holds ! w(k) = l(k)*d(k), ! where l(k) is the k-th column of l @@ -13444,10 +13447,10 @@ module stdlib_linalg_lapack_z ! 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_zcopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib${ii}$_zcopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ ) if( k=1 )call stdlib_zswap( j, a( jp, 1 ), lda, a( jj, 1 ), lda ) + j = j - 1_${ik}$ + if( jp/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_zswap( 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_zlasyf + end subroutine stdlib${ii}$_zlasyf - pure subroutine stdlib_zlasyf_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info ) + pure subroutine stdlib${ii}$_zlasyf_rk( uplo, n, nb, kb, a, lda, e, ipiv, w, ldw,info ) !! ZLASYF_RK computes a partial factorization of a complex symmetric !! matrix A using the bounded Bunch-Kaufman (rook) diagonal !! pivoting method. The partial factorization has the form: @@ -13568,10 +13571,10 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: e(*), w(ldw,*) ! ===================================================================== @@ -13582,7 +13585,7 @@ module stdlib_linalg_lapack_z ! 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(dp) :: absakk, alpha, colmax, rowmax, sfmin, dtemp complex(dp) :: d11, d12, d21, d22, r1, t, z ! Intrinsic Functions @@ -13592,18 +13595,18 @@ module stdlib_linalg_lapack_z ! Statement Function Definitions cabs1( z ) = abs( real( z,KIND=dp) ) + abs( aimag( z ) ) ! 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_dlamch( 'S' ) + sfmin = stdlib${ii}$_dlamch( 'S' ) if( stdlib_lsame( uplo, 'U' ) ) then ! factorize the trailing columns of a using the upper triangle ! of a and working backwards, and compute the matrix w = u12*d ! for use in updating a11 ! initialize the first entry of array e, where superdiagonal ! elements of d are stored - e( 1 ) = czero + e( 1_${ik}$ ) = czero ! k is the main loop index, decreasing from n in steps of 1 or 2 k = n 10 continue @@ -13611,31 +13614,31 @@ module stdlib_linalg_lapack_z kw = nb + k - n ! exit from loop if( ( k<=n-nb+1 .and. nb1 ) then - imax = stdlib_izamax( k-1, w( 1, kw ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_izamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) colmax = cabs1( w( imax, kw ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k - call stdlib_zcopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) + call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) ! set e( k ) to zero - if( k>1 )e( k ) = czero + if( k>1_${ik}$ )e( k ) = czero else ! ============================================================ ! test for interchange @@ -13650,22 +13653,22 @@ module stdlib_linalg_lapack_z 12 continue ! begin pivot search loop body ! copy column imax to column kw-1 of w and update it - call stdlib_zcopy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) - call stdlib_zcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_zcopy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) + call stdlib${ii}$_zcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ ) - if( k1 ) then - itemp = stdlib_izamax( imax-1, w( 1, kw-1 ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_izamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) dtemp = cabs1( w( itemp, kw-1 ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -13680,7 +13683,7 @@ module stdlib_linalg_lapack_z ! use 1-by-1 pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_zcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -13688,7 +13691,7 @@ module stdlib_linalg_lapack_z ! interchange rows and columns k-1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found: set params and repeat @@ -13696,45 +13699,45 @@ module stdlib_linalg_lapack_z colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_zcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) end if ! end pivot search loop body if( .not. done ) goto 12 end if ! ============================================================ - kk = k - kstep + 1 + kk = k - kstep + 1_${ik}$ ! kkw is the column of w which corresponds to column kk of a kkw = nb + kk - n - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_zcopy( k-p, a( p+1, k ), 1, a( p, p+1 ), lda ) - call stdlib_zcopy( p, a( 1, k ), 1, a( 1, p ), 1 ) + call stdlib${ii}$_zcopy( k-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ), lda ) + call stdlib${ii}$_zcopy( p, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) ! interchange rows k and p in last n-k+1 columns of a ! and last n-k+2 columns of w - call stdlib_zswap( n-k+1, a( k, k ), lda, a( p, k ), lda ) - call stdlib_zswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw ) + call stdlib${ii}$_zswap( n-k+1, a( k, k ), lda, a( p, k ), lda ) + call stdlib${ii}$_zswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw ) end if ! updated column kp is already stored in column kkw of w if( kp/=kk ) then ! copy non-updated column kk to column kp a( kp, k ) = a( kk, k ) - call stdlib_zcopy( k-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - call stdlib_zcopy( kp, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_zcopy( k-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) + call stdlib${ii}$_zcopy( kp, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) ! interchange rows kk and kp in last n-kk+1 columns ! of a and w - call stdlib_zswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) - call stdlib_zswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) + call stdlib${ii}$_zswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) + call stdlib${ii}$_zswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column kw of w now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u ! store u(k) in column k of a - call stdlib_zcopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) - if( k>1 ) then + call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) + if( k>1_${ik}$ ) then if( cabs1( a( k, k ) )>=sfmin ) then r1 = cone / a( k, k ) - call stdlib_zscal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_zscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) else if( a( k, k )/=czero ) then do ii = 1, k - 1 a( ii, k ) = a( ii, k ) / a( k, k ) @@ -13749,7 +13752,7 @@ module stdlib_linalg_lapack_z ! ( 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 @@ -13772,7 +13775,7 @@ module stdlib_linalg_lapack_z ! 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 @@ -13789,12 +13792,12 @@ module stdlib_linalg_lapack_z jb = min( nb, k-j+1 ) ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_zgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& - kw+1 ), ldw, cone,a( j, jj ), 1 ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& + kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ ) end do ! update the rectangular superdiagonal block - if( j>=2 )call stdlib_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -cone, a( & - 1, k+1 ), lda, w( j, kw+1 ),ldw, cone, a( 1, j ), lda ) + if( j>=2_${ik}$ )call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -cone, a( & + 1_${ik}$, k+1 ), lda, w( j, kw+1 ),ldw, cone, a( 1_${ik}$, j ), lda ) end do ! set kb to the number of columns factorized kb = n - k @@ -13805,16 +13808,16 @@ module stdlib_linalg_lapack_z ! initialize the unused last entry of the subdiagonal array e. e( n ) = czero ! k is the main loop index, increasing from 1 in steps of 1 or 2 - k = 1 + 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_zcopy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) - if( k>1 )call stdlib_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ),lda, w( k, & - 1 ), ldw, cone, w( k, k ), 1 ) + call stdlib${ii}$_zcopy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ ) + if( k>1_${ik}$ )call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ),lda, w( k, & + 1_${ik}$ ), ldw, cone, w( k, k ), 1_${ik}$ ) ! determine rows and columns to be interchanged and whether ! a 1-by-1 or 2-by-2 pivot block will be used absakk = cabs1( w( k, k ) ) @@ -13822,16 +13825,16 @@ module stdlib_linalg_lapack_z ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k1 )call stdlib_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1 ), & - lda, w( imax, 1 ), ldw,cone, w( k, k+1 ), 1 ) + call stdlib${ii}$_zcopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$) + call stdlib${ii}$_zcopy( n-imax+1, a( imax, imax ), 1_${ik}$,w( imax, k+1 ), 1_${ik}$ ) + if( k>1_${ik}$ )call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1_${ik}$ ), & + lda, w( imax, 1_${ik}$ ), ldw,cone, w( k, k+1 ), 1_${ik}$ ) ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = k - 1 + stdlib_izamax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1_${ik}$ + stdlib${ii}$_izamax( imax-k, w( k, k+1 ), 1_${ik}$ ) rowmax = cabs1( w( jmax, k+1 ) ) else rowmax = zero end if if( imaxrowmax ) then rowmax = dtemp @@ -13877,7 +13880,7 @@ module stdlib_linalg_lapack_z ! use 1-by-1 pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_zcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_zcopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -13885,7 +13888,7 @@ module stdlib_linalg_lapack_z ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found: set params and repeat @@ -13893,42 +13896,42 @@ module stdlib_linalg_lapack_z colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_zcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_zcopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) end if ! end pivot search loop body if( .not. done ) goto 72 end if ! ============================================================ - kk = k + kstep - 1 - if( ( kstep==2 ) .and. ( p/=k ) ) then + kk = k + kstep - 1_${ik}$ + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_zcopy( p-k, a( k, k ), 1, a( p, k ), lda ) - call stdlib_zcopy( n-p+1, a( p, k ), 1, a( p, p ), 1 ) + call stdlib${ii}$_zcopy( p-k, a( k, k ), 1_${ik}$, a( p, k ), lda ) + call stdlib${ii}$_zcopy( n-p+1, a( p, k ), 1_${ik}$, a( p, p ), 1_${ik}$ ) ! interchange rows k and p in first k columns of a ! and first k+1 columns of w - call stdlib_zswap( k, a( k, 1 ), lda, a( p, 1 ), lda ) - call stdlib_zswap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw ) + call stdlib${ii}$_zswap( k, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda ) + call stdlib${ii}$_zswap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw ) end if ! updated column kp is already stored in column kk of w if( kp/=kk ) then ! copy non-updated column kk to column kp a( kp, k ) = a( kk, k ) - call stdlib_zcopy( kp-k-1, a( k+1, kk ), 1, a( kp, k+1 ), lda ) - call stdlib_zcopy( n-kp+1, a( kp, kk ), 1, a( kp, kp ), 1 ) + call stdlib${ii}$_zcopy( kp-k-1, a( k+1, kk ), 1_${ik}$, a( kp, k+1 ), lda ) + call stdlib${ii}$_zcopy( n-kp+1, a( kp, kk ), 1_${ik}$, a( kp, kp ), 1_${ik}$ ) ! interchange rows kk and kp in first kk columns of a and w - call stdlib_zswap( kk, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_zswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + call stdlib${ii}$_zswap( kk, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) + call stdlib${ii}$_zswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of w now holds ! w(k) = l(k)*d(k) ! where l(k) is the k-th column of l ! store l(k) in column k of a - call stdlib_zcopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib${ii}$_zcopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ ) if( k=sfmin ) then r1 = cone / a( k, k ) - call stdlib_zscal( n-k, r1, a( k+1, k ), 1 ) + call stdlib${ii}$_zscal( n-k, r1, a( k+1, k ), 1_${ik}$ ) else if( a( k, k )/=czero ) then do ii = k + 1, n a( ii, k ) = a( ii, k ) / a( k, k ) @@ -13965,7 +13968,7 @@ module stdlib_linalg_lapack_z ! 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 @@ -13982,21 +13985,21 @@ module stdlib_linalg_lapack_z jb = min( nb, n-j+1 ) ! update the lower triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_zgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1 ), lda, w( jj,& - 1 ), ldw, cone,a( jj, jj ), 1 ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1_${ik}$ ), lda, w( jj,& + 1_${ik}$ ), ldw, cone,a( jj, jj ), 1_${ik}$ ) end do ! update the rectangular subdiagonal block - if( j+jb<=n )call stdlib_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& - cone, a( j+jb, 1 ), lda, w( j, 1 ),ldw, cone, a( j+jb, j ), lda ) + if( j+jb<=n )call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& + cone, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ),ldw, cone, a( j+jb, j ), lda ) end do ! set kb to the number of columns factorized - kb = k - 1 + kb = k - 1_${ik}$ end if return - end subroutine stdlib_zlasyf_rk + end subroutine stdlib${ii}$_zlasyf_rk - pure subroutine stdlib_zlasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) + pure subroutine stdlib${ii}$_zlasyf_rook( uplo, n, nb, kb, a, lda, ipiv, w, ldw,info ) !! ZLASYF_ROOK computes a partial factorization of a complex symmetric !! matrix A using the bounded Bunch-Kaufman ("rook") diagonal !! pivoting method. The partial factorization has the form: @@ -14014,10 +14017,10 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: w(ldw,*) ! ===================================================================== @@ -14028,7 +14031,7 @@ module stdlib_linalg_lapack_z ! 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(dp) :: absakk, alpha, colmax, rowmax, dtemp, sfmin complex(dp) :: d11, d12, d21, d22, r1, t, z @@ -14039,11 +14042,11 @@ module stdlib_linalg_lapack_z ! Statement Function Definitions cabs1( z ) = abs( real( z,KIND=dp) ) + abs( aimag( z ) ) ! 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_dlamch( 'S' ) + sfmin = stdlib${ii}$_dlamch( 'S' ) if( stdlib_lsame( uplo, 'U' ) ) then ! factorize the trailing columns of a using the upper triangle ! of a and working backwards, and compute the matrix w = u12*d @@ -14055,29 +14058,29 @@ module stdlib_linalg_lapack_z kw = nb + k - n ! exit from loop if( ( k<=n-nb+1 .and. nb1 ) then - imax = stdlib_izamax( k-1, w( 1, kw ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_izamax( k-1, w( 1_${ik}$, kw ), 1_${ik}$ ) colmax = cabs1( w( imax, kw ) ) else colmax = zero end if if( max( absakk, colmax )==zero ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k - call stdlib_zcopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) + call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) else ! ============================================================ ! test for interchange @@ -14092,22 +14095,22 @@ module stdlib_linalg_lapack_z 12 continue ! begin pivot search loop body ! copy column imax to column kw-1 of w and update it - call stdlib_zcopy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) - call stdlib_zcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1 ) + call stdlib${ii}$_zcopy( imax, a( 1_${ik}$, imax ), 1_${ik}$, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) + call stdlib${ii}$_zcopy( k-imax, a( imax, imax+1 ), lda,w( imax+1, kw-1 ), 1_${ik}$ ) - if( k1 ) then - itemp = stdlib_izamax( imax-1, w( 1, kw-1 ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_izamax( imax-1, w( 1_${ik}$, kw-1 ), 1_${ik}$ ) dtemp = cabs1( w( itemp, kw-1 ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -14122,7 +14125,7 @@ module stdlib_linalg_lapack_z ! use 1-by-1 pivot block kp = imax ! copy column kw-1 of w to column kw of w - call stdlib_zcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -14130,7 +14133,7 @@ module stdlib_linalg_lapack_z ! interchange rows and columns k-1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found: set params and repeat @@ -14138,45 +14141,45 @@ module stdlib_linalg_lapack_z colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_zcopy( k, w( 1, kw-1 ), 1, w( 1, kw ), 1 ) + call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw-1 ), 1_${ik}$, w( 1_${ik}$, kw ), 1_${ik}$ ) end if ! end pivot search loop body if( .not. done ) goto 12 end if ! ============================================================ - kk = k - kstep + 1 + kk = k - kstep + 1_${ik}$ ! kkw is the column of w which corresponds to column kk of a kkw = nb + kk - n - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_zcopy( k-p, a( p+1, k ), 1, a( p, p+1 ), lda ) - call stdlib_zcopy( p, a( 1, k ), 1, a( 1, p ), 1 ) + call stdlib${ii}$_zcopy( k-p, a( p+1, k ), 1_${ik}$, a( p, p+1 ), lda ) + call stdlib${ii}$_zcopy( p, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) ! interchange rows k and p in last n-k+1 columns of a ! and last n-k+2 columns of w - call stdlib_zswap( n-k+1, a( k, k ), lda, a( p, k ), lda ) - call stdlib_zswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw ) + call stdlib${ii}$_zswap( n-k+1, a( k, k ), lda, a( p, k ), lda ) + call stdlib${ii}$_zswap( n-kk+1, w( k, kkw ), ldw, w( p, kkw ), ldw ) end if ! updated column kp is already stored in column kkw of w if( kp/=kk ) then ! copy non-updated column kk to column kp a( kp, k ) = a( kk, k ) - call stdlib_zcopy( k-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) - call stdlib_zcopy( kp, a( 1, kk ), 1, a( 1, kp ), 1 ) + call stdlib${ii}$_zcopy( k-1-kp, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) + call stdlib${ii}$_zcopy( kp, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) ! interchange rows kk and kp in last n-kk+1 columns ! of a and w - call stdlib_zswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) - call stdlib_zswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) + call stdlib${ii}$_zswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) + call stdlib${ii}$_zswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ),ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column kw of w now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u ! store u(k) in column k of a - call stdlib_zcopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) - if( k>1 ) then + call stdlib${ii}$_zcopy( k, w( 1_${ik}$, kw ), 1_${ik}$, a( 1_${ik}$, k ), 1_${ik}$ ) + if( k>1_${ik}$ ) then if( cabs1( a( k, k ) )>=sfmin ) then r1 = cone / a( k, k ) - call stdlib_zscal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_zscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) else if( a( k, k )/=czero ) then do ii = 1, k - 1 a( ii, k ) = a( ii, k ) / a( k, k ) @@ -14189,7 +14192,7 @@ module stdlib_linalg_lapack_z ! ( 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 @@ -14207,7 +14210,7 @@ module stdlib_linalg_lapack_z 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 @@ -14224,32 +14227,32 @@ module stdlib_linalg_lapack_z jb = min( nb, k-j+1 ) ! update the upper triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_zgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& - kw+1 ), ldw, cone,a( j, jj ), 1 ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', jj-j+1, n-k, -cone,a( j, k+1 ), lda, w( jj,& + kw+1 ), ldw, cone,a( j, jj ), 1_${ik}$ ) end do ! update the rectangular superdiagonal block - if( j>=2 )call stdlib_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -cone, a( & - 1, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1, j ), lda ) + if( j>=2_${ik}$ )call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', j-1, jb,n-k, -cone, a( & + 1_${ik}$, k+1 ), lda, w( j, kw+1 ), ldw,cone, a( 1_${ik}$, j ), lda ) end do ! put u12 in standard form by partially undoing the interchanges ! in columns k+1:n - j = k + 1 + 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_zswap( n-j+1, a( jp2, j ), lda, a( jj, j ), & + j = j + 1_${ik}$ + if( jp2/=jj .and. j<=n )call stdlib${ii}$_zswap( n-j+1, a( jp2, j ), lda, a( jj, j ), & lda ) - jj = j - 1 - if( jp1/=jj .and. kstep==2 )call stdlib_zswap( n-j+1, a( jp1, j ), lda, a( jj, j & + jj = j - 1_${ik}$ + if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_zswap( n-j+1, a( jp1, j ), lda, a( jj, j & ), lda ) if( j<=n )go to 60 ! set kb to the number of columns factorized @@ -14259,16 +14262,16 @@ module stdlib_linalg_lapack_z ! 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 = 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_zcopy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) - if( k>1 )call stdlib_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1 ),lda, w( k, & - 1 ), ldw, cone, w( k, k ), 1 ) + call stdlib${ii}$_zcopy( n-k+1, a( k, k ), 1_${ik}$, w( k, k ), 1_${ik}$ ) + if( k>1_${ik}$ )call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone, a( k, 1_${ik}$ ),lda, w( k, & + 1_${ik}$ ), ldw, cone, w( k, k ), 1_${ik}$ ) ! determine rows and columns to be interchanged and whether ! a 1-by-1 or 2-by-2 pivot block will be used absakk = cabs1( w( k, k ) ) @@ -14276,16 +14279,16 @@ module stdlib_linalg_lapack_z ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k1 )call stdlib_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1 ), & - lda, w( imax, 1 ), ldw,cone, w( k, k+1 ), 1 ) + call stdlib${ii}$_zcopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1_${ik}$) + call stdlib${ii}$_zcopy( n-imax+1, a( imax, imax ), 1_${ik}$,w( imax, k+1 ), 1_${ik}$ ) + if( k>1_${ik}$ )call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-k+1, k-1, -cone,a( k, 1_${ik}$ ), & + lda, w( imax, 1_${ik}$ ), ldw,cone, w( k, k+1 ), 1_${ik}$ ) ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = k - 1 + stdlib_izamax( imax-k, w( k, k+1 ), 1 ) + jmax = k - 1_${ik}$ + stdlib${ii}$_izamax( imax-k, w( k, k+1 ), 1_${ik}$ ) rowmax = cabs1( w( jmax, k+1 ) ) else rowmax = zero end if if( imaxrowmax ) then rowmax = dtemp @@ -14329,7 +14332,7 @@ module stdlib_linalg_lapack_z ! use 1-by-1 pivot block kp = imax ! copy column k+1 of w to column k of w - call stdlib_zcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_zcopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) done = .true. ! equivalent to testing for rowmax==colmax, ! (used to handle nan and inf) @@ -14337,7 +14340,7 @@ module stdlib_linalg_lapack_z ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found: set params and repeat @@ -14345,42 +14348,42 @@ module stdlib_linalg_lapack_z colmax = rowmax imax = jmax ! copy updated jmaxth (next imaxth) column to kth of w - call stdlib_zcopy( n-k+1, w( k, k+1 ), 1, w( k, k ), 1 ) + call stdlib${ii}$_zcopy( n-k+1, w( k, k+1 ), 1_${ik}$, w( k, k ), 1_${ik}$ ) end if ! end pivot search loop body if( .not. done ) goto 72 end if ! ============================================================ - kk = k + kstep - 1 - if( ( kstep==2 ) .and. ( p/=k ) ) then + kk = k + kstep - 1_${ik}$ + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! copy non-updated column k to column p - call stdlib_zcopy( p-k, a( k, k ), 1, a( p, k ), lda ) - call stdlib_zcopy( n-p+1, a( p, k ), 1, a( p, p ), 1 ) + call stdlib${ii}$_zcopy( p-k, a( k, k ), 1_${ik}$, a( p, k ), lda ) + call stdlib${ii}$_zcopy( n-p+1, a( p, k ), 1_${ik}$, a( p, p ), 1_${ik}$ ) ! interchange rows k and p in first k columns of a ! and first k+1 columns of w - call stdlib_zswap( k, a( k, 1 ), lda, a( p, 1 ), lda ) - call stdlib_zswap( kk, w( k, 1 ), ldw, w( p, 1 ), ldw ) + call stdlib${ii}$_zswap( k, a( k, 1_${ik}$ ), lda, a( p, 1_${ik}$ ), lda ) + call stdlib${ii}$_zswap( kk, w( k, 1_${ik}$ ), ldw, w( p, 1_${ik}$ ), ldw ) end if ! updated column kp is already stored in column kk of w if( kp/=kk ) then ! copy non-updated column kk to column kp a( kp, k ) = a( kk, k ) - call stdlib_zcopy( kp-k-1, a( k+1, kk ), 1, a( kp, k+1 ), lda ) - call stdlib_zcopy( n-kp+1, a( kp, kk ), 1, a( kp, kp ), 1 ) + call stdlib${ii}$_zcopy( kp-k-1, a( k+1, kk ), 1_${ik}$, a( kp, k+1 ), lda ) + call stdlib${ii}$_zcopy( n-kp+1, a( kp, kk ), 1_${ik}$, a( kp, kp ), 1_${ik}$ ) ! interchange rows kk and kp in first kk columns of a and w - call stdlib_zswap( kk, a( kk, 1 ), lda, a( kp, 1 ), lda ) - call stdlib_zswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) + call stdlib${ii}$_zswap( kk, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) + call stdlib${ii}$_zswap( kk, w( kk, 1_${ik}$ ), ldw, w( kp, 1_${ik}$ ), ldw ) end if - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k of w now holds ! w(k) = l(k)*d(k) ! where l(k) is the k-th column of l ! store l(k) in column k of a - call stdlib_zcopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) + call stdlib${ii}$_zcopy( n-k+1, w( k, k ), 1_${ik}$, a( k, k ), 1_${ik}$ ) if( k=sfmin ) then r1 = cone / a( k, k ) - call stdlib_zscal( n-k, r1, a( k+1, k ), 1 ) + call stdlib${ii}$_zscal( n-k, r1, a( k+1, k ), 1_${ik}$ ) else if( a( k, k )/=czero ) then do ii = k + 1, n a( ii, k ) = a( ii, k ) / a( k, k ) @@ -14410,7 +14413,7 @@ module stdlib_linalg_lapack_z 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 @@ -14427,42 +14430,42 @@ module stdlib_linalg_lapack_z jb = min( nb, n-j+1 ) ! update the lower triangle of the diagonal block do jj = j, j + jb - 1 - call stdlib_zgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1 ), lda, w( jj,& - 1 ), ldw, cone,a( jj, jj ), 1 ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', j+jb-jj, k-1, -cone,a( jj, 1_${ik}$ ), lda, w( jj,& + 1_${ik}$ ), ldw, cone,a( jj, jj ), 1_${ik}$ ) end do ! update the rectangular subdiagonal block - if( j+jb<=n )call stdlib_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& - cone, a( j+jb, 1 ), lda, w( j, 1 ), ldw,cone, a( j+jb, j ), lda ) + if( j+jb<=n )call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'TRANSPOSE', n-j-jb+1, jb,k-1, -& + cone, a( j+jb, 1_${ik}$ ), lda, w( j, 1_${ik}$ ), ldw,cone, a( j+jb, j ), lda ) end do ! put l21 in standard form by partially undoing the interchanges ! in columns 1:k-1 - j = k - 1 + 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_zswap( j, a( jp2, 1 ), lda, a( jj, 1 ), lda ) + j = j - 1_${ik}$ + if( jp2/=jj .and. j>=1_${ik}$ )call stdlib${ii}$_zswap( j, a( jp2, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), lda ) - jj = j + 1 - if( jp1/=jj .and. kstep==2 )call stdlib_zswap( j, a( jp1, 1 ), lda, a( jj, 1 ), & + jj = j + 1_${ik}$ + if( jp1/=jj .and. kstep==2_${ik}$ )call stdlib${ii}$_zswap( j, a( jp1, 1_${ik}$ ), lda, a( jj, 1_${ik}$ ), & lda ) if( j>=1 )go to 120 ! set kb to the number of columns factorized - kb = k - 1 + kb = k - 1_${ik}$ end if return - end subroutine stdlib_zlasyf_rook + end subroutine stdlib${ii}$_zlasyf_rook - pure subroutine stdlib_zlat2c( uplo, n, a, lda, sa, ldsa, info ) + pure subroutine stdlib${ii}$_zlat2c( uplo, n, a, lda, sa, ldsa, info ) !! ZLAT2C converts a COMPLEX*16 triangular matrix, SA, to a COMPLEX !! triangular matrix, A. !! RMAX is the overflow for the SINGLE PRECISION arithmetic @@ -14474,20 +14477,20 @@ module stdlib_linalg_lapack_z ! -- 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, ldsa, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldsa, n ! Array Arguments complex(sp), intent(out) :: sa(ldsa,*) complex(dp), intent(in) :: a(lda,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: rmax logical(lk) :: upper ! Intrinsic Functions intrinsic :: real,aimag ! Executable Statements - rmax = stdlib_slamch( 'O' ) + rmax = stdlib${ii}$_slamch( 'O' ) upper = stdlib_lsame( uplo, 'U' ) if( upper ) then do j = 1, n @@ -14495,7 +14498,7 @@ module stdlib_linalg_lapack_z if( ( real( a( i, j ),KIND=dp)<-rmax ) .or.( real( a( i, j ),KIND=dp)>rmax ) & .or.( aimag( a( i, j ) )<-rmax ) .or.( aimag( a( i, j ) )>rmax ) ) & then - info = 1 + info = 1_${ik}$ go to 50 end if sa( i, j ) = a( i, j ) @@ -14507,7 +14510,7 @@ module stdlib_linalg_lapack_z if( ( real( a( i, j ),KIND=dp)<-rmax ) .or.( real( a( i, j ),KIND=dp)>rmax ) & .or.( aimag( a( i, j ) )<-rmax ) .or.( aimag( a( i, j ) )>rmax ) ) & then - info = 1 + info = 1_${ik}$ go to 50 end if sa( i, j ) = a( i, j ) @@ -14516,10 +14519,10 @@ module stdlib_linalg_lapack_z end if 50 continue return - end subroutine stdlib_zlat2c + end subroutine stdlib${ii}$_zlat2c - pure subroutine stdlib_zlatbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm, & + pure subroutine stdlib${ii}$_zlatbs( uplo, trans, diag, normin, n, kd, ab, ldab, x,scale, cnorm, & !! ZLATBS solves one of the triangular systems !! A * x = s*b, A**T * x = s*b, or A**H * x = s*b, !! with scaling to prevent overflow, where A is an upper or lower @@ -14536,8 +14539,8 @@ module stdlib_linalg_lapack_z ! -- 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(dp), intent(out) :: scale ! Array Arguments real(dp), intent(inout) :: cnorm(*) @@ -14547,7 +14550,7 @@ module stdlib_linalg_lapack_z ! 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(dp) :: bignum, grow, rec, smlnum, tjj, tmax, tscal, xbnd, xj, xmax complex(dp) :: csumj, tjjs, uscal, zdum ! Intrinsic Functions @@ -14559,39 +14562,39 @@ module stdlib_linalg_lapack_z cabs2( zdum ) = abs( real( zdum,KIND=dp) / 2._dp ) +abs( aimag( zdum ) / 2._dp ) ! 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_dzasum( jlen, ab( 2, j ), 1 ) + if( jlen>0_${ik}$ ) then + cnorm( j ) = stdlib${ii}$_dzasum( jlen, ab( 2_${ik}$, j ), 1_${ik}$ ) else cnorm( j ) = zero end if @@ -14616,16 +14619,16 @@ module stdlib_linalg_lapack_z end if ! scale the column norms by tscal if the maximum element in cnorm is ! greater than bignum/2. - imax = stdlib_idamax( n, cnorm, 1 ) + imax = stdlib${ii}$_idamax( n, cnorm, 1_${ik}$ ) tmax = cnorm( imax ) if( tmax<=bignum*half ) then tscal = one else tscal = half / ( smlnum*tmax ) - call stdlib_dscal( n, tscal, cnorm, 1 ) + call stdlib${ii}$_dscal( n, tscal, cnorm, 1_${ik}$ ) end if ! compute a bound on the computed solution vector to see if the - ! level 2 blas routine stdlib_ztbsv can be used. + ! level 2 blas routine stdlib${ii}$_ztbsv can be used. xmax = zero do j = 1, n xmax = max( xmax, cabs2( x( j ) ) ) @@ -14635,14 +14638,14 @@ module stdlib_linalg_lapack_z ! 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 @@ -14690,15 +14693,15 @@ module stdlib_linalg_lapack_z else ! compute the growth in a**t * x = b or a**h * 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 @@ -14744,14 +14747,14 @@ module stdlib_linalg_lapack_z if( ( grow*tscal )>smlnum ) then ! use the level 2 blas solve if the reciprocal of the bound on ! elements of x is not too small. - call stdlib_ztbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1 ) + call stdlib${ii}$_ztbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1_${ik}$ ) else ! use a level 1 blas solve, scaling intermediate results. if( xmax>bignum*half ) then ! scale x so that its components are less than or equal to ! bignum in absolute value. scale = ( bignum*half ) / xmax - call stdlib_zdscal( n, scale, x, 1 ) + call stdlib${ii}$_zdscal( n, scale, x, 1_${ik}$ ) xmax = bignum else xmax = xmax*two @@ -14774,12 +14777,12 @@ module stdlib_linalg_lapack_z if( xj>tjj*bignum ) then ! scale x by 1/b(j). rec = one / xj - call stdlib_zdscal( n, rec, x, 1 ) + call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_zladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) xj = cabs1( x( j ) ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: @@ -14792,11 +14795,11 @@ module stdlib_linalg_lapack_z ! multiplying x(j) times column j. rec = rec / cnorm( j ) end if - call stdlib_zdscal( n, rec, x, 1 ) + call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_zladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) xj = cabs1( x( j ) ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and @@ -14817,23 +14820,23 @@ module stdlib_linalg_lapack_z if( cnorm( j )>( bignum-xmax )*rec ) then ! scale x by 1/(2*abs(x(j))). rec = rec*half - call stdlib_zdscal( n, rec, x, 1 ) + call stdlib${ii}$_zdscal( 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_zdscal( n, half, x, 1 ) + call stdlib${ii}$_zdscal( 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) jlen = min( kd, j-1 ) - call stdlib_zaxpy( jlen, -x( j )*tscal,ab( kd+1-jlen, j ), 1, x( j-jlen & - ), 1 ) - i = stdlib_izamax( j-1, x, 1 ) + call stdlib${ii}$_zaxpy( jlen, -x( j )*tscal,ab( kd+1-jlen, j ), 1_${ik}$, x( j-jlen & + ), 1_${ik}$ ) + i = stdlib${ii}$_izamax( j-1, x, 1_${ik}$ ) xmax = cabs1( x( i ) ) end if else if( j0 )call stdlib_zaxpy( jlen, -x( j )*tscal, ab( 2, j ), 1,x( j+1 ),& - 1 ) - i = j + stdlib_izamax( n-j, x( j+1 ), 1 ) + if( jlen>0_${ik}$ )call stdlib${ii}$_zaxpy( jlen, -x( j )*tscal, ab( 2_${ik}$, j ), 1_${ik}$,x( j+1 ),& + 1_${ik}$ ) + i = j + stdlib${ii}$_izamax( n-j, x( j+1 ), 1_${ik}$ ) xmax = cabs1( x( i ) ) end if end do loop_120 @@ -14867,10 +14870,10 @@ module stdlib_linalg_lapack_z if( tjj>one ) then ! divide by a(j,j) when scaling x if a(j,j) > 1. rec = min( one, rec*tjj ) - uscal = stdlib_zladiv( uscal, tjjs ) + uscal = stdlib${ii}$_zladiv( uscal, tjjs ) end if if( rec1 )csumj = stdlib_zdotu( jlen, ab( 2, j ), 1, x( j+1 ),1 ) + if( jlen>1_${ik}$ )csumj = stdlib${ii}$_zdotu( jlen, ab( 2_${ik}$, j ), 1_${ik}$, x( j+1 ),1_${ik}$ ) end if else @@ -14921,22 +14924,22 @@ module stdlib_linalg_lapack_z if( xj>tjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_zdscal( n, rec, x, 1 ) + call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_zladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_zdscal( n, rec, x, 1 ) + call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_zladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_zladiv( 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. @@ -14951,7 +14954,7 @@ module stdlib_linalg_lapack_z else ! compute x(j) := x(j) / a(j,j) - csumj if the dot ! product has already been divided by 1/a(j,j). - x( j ) = stdlib_zladiv( x( j ), tjjs ) - csumj + x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) - csumj end if xmax = max( xmax, cabs1( x( j ) ) ) end do loop_170 @@ -14975,10 +14978,10 @@ module stdlib_linalg_lapack_z if( tjj>one ) then ! divide by a(j,j) when scaling x if a(j,j) > 1. rec = min( one, rec*tjj ) - uscal = stdlib_zladiv( uscal, tjjs ) + uscal = stdlib${ii}$_zladiv( uscal, tjjs ) end if if( rec1 )csumj = stdlib_zdotc( jlen, ab( 2, j ), 1, x( j+1 ),1 ) + if( jlen>1_${ik}$ )csumj = stdlib${ii}$_zdotc( jlen, ab( 2_${ik}$, j ), 1_${ik}$, x( j+1 ),1_${ik}$ ) end if else @@ -15030,22 +15033,22 @@ module stdlib_linalg_lapack_z if( xj>tjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_zdscal( n, rec, x, 1 ) + call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_zladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_zdscal( n, rec, x, 1 ) + call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_zladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and ! scale = 0 and compute a solution to a**h *x = 0. @@ -15060,7 +15063,7 @@ module stdlib_linalg_lapack_z else ! compute x(j) := x(j) / a(j,j) - csumj if the dot ! product has already been divided by 1/a(j,j). - x( j ) = stdlib_zladiv( x( j ), tjjs ) - csumj + x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) - csumj end if xmax = max( xmax, cabs1( x( j ) ) ) end do loop_220 @@ -15069,13 +15072,13 @@ module stdlib_linalg_lapack_z end if ! scale the column norms by 1/tscal for return. if( tscal/=one ) then - call stdlib_dscal( n, one / tscal, cnorm, 1 ) + call stdlib${ii}$_dscal( n, one / tscal, cnorm, 1_${ik}$ ) end if return - end subroutine stdlib_zlatbs + end subroutine stdlib${ii}$_zlatbs - pure subroutine stdlib_zlatps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info ) + pure subroutine stdlib${ii}$_zlatps( uplo, trans, diag, normin, n, ap, x, scale,cnorm, info ) !! ZLATPS solves one of the triangular systems !! A * x = s*b, A**T * x = s*b, or A**H * x = s*b, !! with scaling to prevent overflow, where A is an upper or lower @@ -15093,8 +15096,8 @@ module stdlib_linalg_lapack_z ! -- 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(dp), intent(out) :: scale ! Array Arguments real(dp), intent(inout) :: cnorm(*) @@ -15104,7 +15107,7 @@ module stdlib_linalg_lapack_z ! 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(dp) :: bignum, grow, rec, smlnum, tjj, tmax, tscal, xbnd, xj, xmax complex(dp) :: csumj, tjjs, uscal, zdum ! Intrinsic Functions @@ -15116,68 +15119,68 @@ module stdlib_linalg_lapack_z cabs2( zdum ) = abs( real( zdum,KIND=dp) / 2._dp ) +abs( aimag( zdum ) / 2._dp ) ! 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( 'ZLATPS', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZLATPS', -info ) return end if ! quick return if possible if( n==0 )return ! determine machine dependent parameters to control overflow. - smlnum = stdlib_dlamch( 'SAFE MINIMUM' ) + smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) bignum = one / smlnum - call stdlib_dlabad( smlnum, bignum ) - smlnum = smlnum / stdlib_dlamch( 'PRECISION' ) + call stdlib${ii}$_dlabad( smlnum, bignum ) + smlnum = smlnum / stdlib${ii}$_dlamch( 'PRECISION' ) bignum = one / smlnum scale = one if( stdlib_lsame( normin, 'N' ) ) then ! compute the 1-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_dzasum( j-1, ap( ip ), 1 ) + cnorm( j ) = stdlib${ii}$_dzasum( 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_dzasum( n-j, ap( ip+1 ), 1 ) - ip = ip + n - j + 1 + cnorm( j ) = stdlib${ii}$_dzasum( 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/2. - imax = stdlib_idamax( n, cnorm, 1 ) + imax = stdlib${ii}$_idamax( n, cnorm, 1_${ik}$ ) tmax = cnorm( imax ) if( tmax<=bignum*half ) then tscal = one else tscal = half / ( smlnum*tmax ) - call stdlib_dscal( n, tscal, cnorm, 1 ) + call stdlib${ii}$_dscal( n, tscal, cnorm, 1_${ik}$ ) end if ! compute a bound on the computed solution vector to see if the - ! level 2 blas routine stdlib_ztpsv can be used. + ! level 2 blas routine stdlib${ii}$_ztpsv can be used. xmax = zero do j = 1, n xmax = max( xmax, cabs2( x( j ) ) ) @@ -15187,12 +15190,12 @@ module stdlib_linalg_lapack_z ! 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 @@ -15204,7 +15207,7 @@ module stdlib_linalg_lapack_z ! initially, g(0) = max{x(i), i=1,...,n}. grow = half / 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. @@ -15226,7 +15229,7 @@ module stdlib_linalg_lapack_z grow = zero end if ip = ip + jinc*jlen - jlen = jlen - 1 + jlen = jlen - 1_${ik}$ end do grow = xbnd else @@ -15244,13 +15247,13 @@ module stdlib_linalg_lapack_z else ! compute the growth in a**t * x = b or a**h * 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 @@ -15262,8 +15265,8 @@ module stdlib_linalg_lapack_z ! initially, m(0) = max{x(i), i=1,...,n}. grow = half / 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 90 @@ -15279,7 +15282,7 @@ module stdlib_linalg_lapack_z ! m(j) could overflow, set xbnd to 0. xbnd = zero end if - jlen = jlen + 1 + jlen = jlen + 1_${ik}$ ip = ip + jinc*jlen end do grow = min( grow, xbnd ) @@ -15300,21 +15303,21 @@ module stdlib_linalg_lapack_z if( ( grow*tscal )>smlnum ) then ! use the level 2 blas solve if the reciprocal of the bound on ! elements of x is not too small. - call stdlib_ztpsv( uplo, trans, diag, n, ap, x, 1 ) + call stdlib${ii}$_ztpsv( uplo, trans, diag, n, ap, x, 1_${ik}$ ) else ! use a level 1 blas solve, scaling intermediate results. if( xmax>bignum*half ) then ! scale x so that its components are less than or equal to ! bignum in absolute value. scale = ( bignum*half ) / xmax - call stdlib_zdscal( n, scale, x, 1 ) + call stdlib${ii}$_zdscal( n, scale, x, 1_${ik}$ ) xmax = bignum else xmax = xmax*two end if if( notran ) then ! solve a * x = b - ip = jfirst*( jfirst+1 ) / 2 + ip = jfirst*( jfirst+1 ) / 2_${ik}$ loop_120: do j = jfirst, jlast, jinc ! compute x(j) = b(j) / a(j,j), scaling x if necessary. xj = cabs1( x( j ) ) @@ -15331,12 +15334,12 @@ module stdlib_linalg_lapack_z if( xj>tjj*bignum ) then ! scale x by 1/b(j). rec = one / xj - call stdlib_zdscal( n, rec, x, 1 ) + call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_zladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) xj = cabs1( x( j ) ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: @@ -15349,11 +15352,11 @@ module stdlib_linalg_lapack_z ! multiplying x(j) times column j. rec = rec / cnorm( j ) end if - call stdlib_zdscal( n, rec, x, 1 ) + call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_zladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) xj = cabs1( x( j ) ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and @@ -15374,20 +15377,20 @@ module stdlib_linalg_lapack_z if( cnorm( j )>( bignum-xmax )*rec ) then ! scale x by 1/(2*abs(x(j))). rec = rec*half - call stdlib_zdscal( n, rec, x, 1 ) + call stdlib${ii}$_zdscal( 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_zdscal( n, half, x, 1 ) + call stdlib${ii}$_zdscal( 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_zaxpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1, x,1 ) - i = stdlib_izamax( j-1, x, 1 ) + call stdlib${ii}$_zaxpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1_${ik}$, x,1_${ik}$ ) + i = stdlib${ii}$_izamax( j-1, x, 1_${ik}$ ) xmax = cabs1( x( i ) ) end if ip = ip - j @@ -15395,18 +15398,18 @@ module stdlib_linalg_lapack_z if( jj @@ -15425,10 +15428,10 @@ module stdlib_linalg_lapack_z if( tjj>one ) then ! divide by a(j,j) when scaling x if a(j,j) > 1. rec = min( one, rec*tjj ) - uscal = stdlib_zladiv( uscal, tjjs ) + uscal = stdlib${ii}$_zladiv( uscal, tjjs ) end if if( rectjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_zdscal( n, rec, x, 1 ) + call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_zladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_zdscal( n, rec, x, 1 ) + call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_zladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_zladiv( 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. @@ -15503,16 +15506,16 @@ module stdlib_linalg_lapack_z else ! compute x(j) := x(j) / a(j,j) - csumj if the dot ! product has already been divided by 1/a(j,j). - x( j ) = stdlib_zladiv( x( j ), tjjs ) - csumj + x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) - csumj end if xmax = max( xmax, cabs1( x( j ) ) ) - jlen = jlen + 1 + jlen = jlen + 1_${ik}$ ip = ip + jinc*jlen end do loop_170 else ! solve a**h * x = b - ip = jfirst*( jfirst+1 ) / 2 - jlen = 1 + ip = jfirst*( jfirst+1 ) / 2_${ik}$ + jlen = 1_${ik}$ loop_220: do j = jfirst, jlast, jinc ! compute x(j) = b(j) - sum a(k,j)*x(k). ! k<>j @@ -15531,10 +15534,10 @@ module stdlib_linalg_lapack_z if( tjj>one ) then ! divide by a(j,j) when scaling x if a(j,j) > 1. rec = min( one, rec*tjj ) - uscal = stdlib_zladiv( uscal, tjjs ) + uscal = stdlib${ii}$_zladiv( uscal, tjjs ) end if if( rectjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_zdscal( n, rec, x, 1 ) + call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_zladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_zdscal( n, rec, x, 1 ) + call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_zladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and ! scale = 0 and compute a solution to a**h *x = 0. @@ -15609,10 +15612,10 @@ module stdlib_linalg_lapack_z else ! compute x(j) := x(j) / a(j,j) - csumj if the dot ! product has already been divided by 1/a(j,j). - x( j ) = stdlib_zladiv( x( j ), tjjs ) - csumj + x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) - csumj end if xmax = max( xmax, cabs1( x( j ) ) ) - jlen = jlen + 1 + jlen = jlen + 1_${ik}$ ip = ip + jinc*jlen end do loop_220 end if @@ -15620,13 +15623,13 @@ module stdlib_linalg_lapack_z end if ! scale the column norms by 1/tscal for return. if( tscal/=one ) then - call stdlib_dscal( n, one / tscal, cnorm, 1 ) + call stdlib${ii}$_dscal( n, one / tscal, cnorm, 1_${ik}$ ) end if return - end subroutine stdlib_zlatps + end subroutine stdlib${ii}$_zlatps - pure subroutine stdlib_zlatrd( uplo, n, nb, a, lda, e, tau, w, ldw ) + pure subroutine stdlib${ii}$_zlatrd( uplo, n, nb, a, lda, e, tau, w, ldw ) !! ZLATRD reduces NB rows and columns of a complex Hermitian matrix A to !! Hermitian tridiagonal form by a unitary similarity !! transformation Q**H * A * Q, and returns the matrices V and W which are @@ -15641,7 +15644,7 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: lda, ldw, n, nb + integer(${ik}$), intent(in) :: lda, ldw, n, nb ! Array Arguments real(dp), intent(out) :: e(*) complex(dp), intent(inout) :: a(lda,*) @@ -15649,7 +15652,7 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! Local Scalars - integer(ilp) :: i, iw + integer(${ik}$) :: i, iw complex(dp) :: alpha ! Intrinsic Functions intrinsic :: real,min @@ -15663,40 +15666,40 @@ module stdlib_linalg_lapack_z if( i1 ) then + if( i>1_${ik}$ ) then ! generate elementary reflector h(i) to annihilate ! a(1:i-2,i) alpha = a( i-1, i ) - call stdlib_zlarfg( i-1, alpha, a( 1, i ), 1, tau( i-1 ) ) + call stdlib${ii}$_zlarfg( i-1, alpha, a( 1_${ik}$, i ), 1_${ik}$, tau( i-1 ) ) e( i-1 ) = real( alpha,KIND=dp) a( i-1, i ) = cone ! compute w(1:i-1,i) - call stdlib_zhemv( 'UPPER', i-1, cone, a, lda, a( 1, i ), 1,czero, w( 1, iw ),& - 1 ) + call stdlib${ii}$_zhemv( 'UPPER', i-1, cone, a, lda, a( 1_${ik}$, i ), 1_${ik}$,czero, w( 1_${ik}$, iw ),& + 1_${ik}$ ) if( ismlnum ) then ! use the level 2 blas solve if the reciprocal of the bound on ! elements of x is not too small. - call stdlib_ztrsv( uplo, trans, diag, n, a, lda, x, 1 ) + call stdlib${ii}$_ztrsv( uplo, trans, diag, n, a, lda, x, 1_${ik}$ ) else ! use a level 1 blas solve, scaling intermediate results. if( xmax>bignum*half ) then ! scale x so that its components are less than or equal to ! bignum in absolute value. scale = ( bignum*half ) / xmax - call stdlib_zdscal( n, scale, x, 1 ) + call stdlib${ii}$_zdscal( n, scale, x, 1_${ik}$ ) xmax = bignum else xmax = xmax*two @@ -15986,12 +15989,12 @@ module stdlib_linalg_lapack_z if( xj>tjj*bignum ) then ! scale x by 1/b(j). rec = one / xj - call stdlib_zdscal( n, rec, x, 1 ) + call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_zladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) xj = cabs1( x( j ) ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: @@ -16004,11 +16007,11 @@ module stdlib_linalg_lapack_z ! multiplying x(j) times column j. rec = rec / cnorm( j ) end if - call stdlib_zdscal( n, rec, x, 1 ) + call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_zladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) xj = cabs1( x( j ) ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and @@ -16029,29 +16032,29 @@ module stdlib_linalg_lapack_z if( cnorm( j )>( bignum-xmax )*rec ) then ! scale x by 1/(2*abs(x(j))). rec = rec*half - call stdlib_zdscal( n, rec, x, 1 ) + call stdlib${ii}$_zdscal( 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_zdscal( n, half, x, 1 ) + call stdlib${ii}$_zdscal( 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_zaxpy( j-1, -x( j )*tscal, a( 1, j ), 1, x,1 ) - i = stdlib_izamax( j-1, x, 1 ) + call stdlib${ii}$_zaxpy( j-1, -x( j )*tscal, a( 1_${ik}$, j ), 1_${ik}$, x,1_${ik}$ ) + i = stdlib${ii}$_izamax( j-1, x, 1_${ik}$ ) xmax = cabs1( x( i ) ) end if else if( jone ) then ! divide by a(j,j) when scaling x if a(j,j) > 1. rec = min( one, rec*tjj ) - uscal = stdlib_zladiv( uscal, tjjs ) + uscal = stdlib${ii}$_zladiv( uscal, tjjs ) end if if( rectjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_zdscal( n, rec, x, 1 ) + call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_zladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_zdscal( n, rec, x, 1 ) + call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_zladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_zladiv( 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. @@ -16154,7 +16157,7 @@ module stdlib_linalg_lapack_z else ! compute x(j) := x(j) / a(j,j) - csumj if the dot ! product has already been divided by 1/a(j,j). - x( j ) = stdlib_zladiv( x( j ), tjjs ) - csumj + x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) - csumj end if xmax = max( xmax, cabs1( x( j ) ) ) end do loop_170 @@ -16178,10 +16181,10 @@ module stdlib_linalg_lapack_z if( tjj>one ) then ! divide by a(j,j) when scaling x if a(j,j) > 1. rec = min( one, rec*tjj ) - uscal = stdlib_zladiv( uscal, tjjs ) + uscal = stdlib${ii}$_zladiv( uscal, tjjs ) end if if( rectjj*bignum ) then ! scale x by 1/abs(x(j)). rec = one / xj - call stdlib_zdscal( n, rec, x, 1 ) + call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if end if - x( j ) = stdlib_zladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) else if( tjj>zero ) then ! 0 < abs(a(j,j)) <= smlnum: if( xj>tjj*bignum ) then ! scale x by (1/abs(x(j)))*abs(a(j,j))*bignum. rec = ( tjj*bignum ) / xj - call stdlib_zdscal( n, rec, x, 1 ) + call stdlib${ii}$_zdscal( n, rec, x, 1_${ik}$ ) scale = scale*rec xmax = xmax*rec end if - x( j ) = stdlib_zladiv( x( j ), tjjs ) + x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) else ! a(j,j) = 0: set x(1:n) = 0, x(j) = 1, and ! scale = 0 and compute a solution to a**h *x = 0. @@ -16256,7 +16259,7 @@ module stdlib_linalg_lapack_z else ! compute x(j) := x(j) / a(j,j) - csumj if the dot ! product has already been divided by 1/a(j,j). - x( j ) = stdlib_zladiv( x( j ), tjjs ) - csumj + x( j ) = stdlib${ii}$_zladiv( x( j ), tjjs ) - csumj end if xmax = max( xmax, cabs1( x( j ) ) ) end do loop_220 @@ -16265,13 +16268,13 @@ module stdlib_linalg_lapack_z end if ! scale the column norms by 1/tscal for return. if( tscal/=one ) then - call stdlib_dscal( n, one / tscal, cnorm, 1 ) + call stdlib${ii}$_dscal( n, one / tscal, cnorm, 1_${ik}$ ) end if return - end subroutine stdlib_zlatrs + end subroutine stdlib${ii}$_zlatrs - pure subroutine stdlib_zlatrz( m, n, l, a, lda, tau, work ) + pure subroutine stdlib${ii}$_zlatrz( m, n, l, a, lda, tau, work ) !! ZLATRZ factors the M-by-(M+L) complex upper trapezoidal matrix !! [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z by means !! of unitary transformations, where Z is an (M+L)-by-(M+L) unitary @@ -16280,20 +16283,20 @@ module stdlib_linalg_lapack_z ! -- 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) :: l, lda, m, n + integer(${ik}$), intent(in) :: l, lda, m, n ! Array Arguments complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i complex(dp) :: alpha ! Intrinsic Functions intrinsic :: conjg ! Executable Statements ! quick return if possible - if( m==0 ) then + if( m==0_${ik}$ ) then return else if( m==n ) then do i = 1, n @@ -16304,20 +16307,20 @@ module stdlib_linalg_lapack_z do i = m, 1, -1 ! generate elementary reflector h(i) to annihilate ! [ a(i,i) a(i,n-l+1:n) ] - call stdlib_zlacgv( l, a( i, n-l+1 ), lda ) + call stdlib${ii}$_zlacgv( l, a( i, n-l+1 ), lda ) alpha = conjg( a( i, i ) ) - call stdlib_zlarfg( l+1, alpha, a( i, n-l+1 ), lda, tau( i ) ) + call stdlib${ii}$_zlarfg( l+1, alpha, a( i, n-l+1 ), lda, tau( i ) ) tau( i ) = conjg( tau( i ) ) ! apply h(i) to a(1:i-1,i:n) from the right - call stdlib_zlarz( 'RIGHT', i-1, n-i+1, l, a( i, n-l+1 ), lda,conjg( tau( i ) ), a( & - 1, i ), lda, work ) + call stdlib${ii}$_zlarz( 'RIGHT', i-1, n-i+1, l, a( i, n-l+1 ), lda,conjg( tau( i ) ), a( & + 1_${ik}$, i ), lda, work ) a( i, i ) = conjg( alpha ) end do return - end subroutine stdlib_zlatrz + end subroutine stdlib${ii}$_zlatrz - pure recursive subroutine stdlib_zlaunhr_col_getrfnp2( m, n, a, lda, d, info ) + pure recursive subroutine stdlib${ii}$_zlaunhr_col_getrfnp2( m, n, a, lda, d, info ) !! ZLAUNHR_COL_GETRFNP2 computes the modified LU factorization without !! pivoting of a complex general M-by-N matrix A. The factorization has !! the form: @@ -16370,8 +16373,8 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: d(*) @@ -16380,7 +16383,7 @@ module stdlib_linalg_lapack_z ! Local Scalars real(dp) :: sfmin - integer(ilp) :: i, iinfo, n1, n2 + integer(${ik}$) :: i, iinfo, n1, n2 complex(dp) :: z ! Intrinsic Functions intrinsic :: abs,real,cmplx,aimag,sign,max,min @@ -16390,70 +16393,70 @@ module stdlib_linalg_lapack_z cabs1( z ) = abs( real( z,KIND=dp) ) + abs( aimag( z ) ) ! 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_zscal( m-1, cone / a( 1, 1 ), a( 2, 1 ), 1 ) + if( cabs1( a( 1_${ik}$, 1_${ik}$ ) ) >= sfmin ) then + call stdlib${ii}$_zscal( m-1, cone / 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_zlaunhr_col_getrfnp2( n1, n1, a, lda, d, iinfo ) + call stdlib${ii}$_zlaunhr_col_getrfnp2( n1, n1, a, lda, d, iinfo ) ! solve for b21 - call stdlib_ztrsm( 'R', 'U', 'N', 'N', m-n1, n1, cone, a, lda,a( n1+1, 1 ), lda ) + call stdlib${ii}$_ztrsm( 'R', 'U', 'N', 'N', m-n1, n1, cone, a, lda,a( n1+1, 1_${ik}$ ), lda ) ! solve for b12 - call stdlib_ztrsm( 'L', 'L', 'N', 'U', n1, n2, cone, a, lda,a( 1, n1+1 ), lda ) + call stdlib${ii}$_ztrsm( 'L', 'L', 'N', 'U', n1, n2, cone, a, lda,a( 1_${ik}$, n1+1 ), lda ) ! update b22, i.e. compute the schur complement ! b22 := b22 - b21*b12 - call stdlib_zgemm( 'N', 'N', m-n1, n2, n1, -cone, a( n1+1, 1 ), lda,a( 1, n1+1 ), & + call stdlib${ii}$_zgemm( 'N', 'N', m-n1, n2, n1, -cone, a( n1+1, 1_${ik}$ ), lda,a( 1_${ik}$, n1+1 ), & lda, cone, a( n1+1, n1+1 ), lda ) ! factor b22, recursive call - call stdlib_zlaunhr_col_getrfnp2( m-n1, n2, a( n1+1, n1+1 ), lda,d( n1+1 ), iinfo ) + call stdlib${ii}$_zlaunhr_col_getrfnp2( m-n1, n2, a( n1+1, n1+1 ), lda,d( n1+1 ), iinfo ) end if return - end subroutine stdlib_zlaunhr_col_getrfnp2 + end subroutine stdlib${ii}$_zlaunhr_col_getrfnp2 - pure subroutine stdlib_zlauu2( uplo, n, a, lda, info ) + pure subroutine stdlib${ii}$_zlauu2( uplo, n, a, lda, info ) !! ZLAUU2 computes the product U * U**H or L**H * L, where the triangular !! factor U or L is stored in the upper or lower triangular part of !! the array A. @@ -16467,31 +16470,31 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: i + integer(${ik}$) :: i real(dp) :: aii ! Intrinsic Functions intrinsic :: real,cmplx,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}$, 'ZLAUUM', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code - call stdlib_zlauu2( uplo, n, a, lda, info ) + call stdlib${ii}$_zlauu2( uplo, n, a, lda, info ) else ! use blocked code if( upper ) then ! compute the product u * u**h. do i = 1, n, nb ib = min( nb, n-i+1 ) - call stdlib_ztrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', i-1, & - ib, cone, a( i, i ), lda,a( 1, i ), lda ) - call stdlib_zlauu2( 'UPPER', ib, a( i, i ), lda, info ) + call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', i-1, & + ib, cone, a( i, i ), lda,a( 1_${ik}$, i ), lda ) + call stdlib${ii}$_zlauu2( 'UPPER', ib, a( i, i ), lda, info ) if( i+ib<=n ) then - call stdlib_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',i-1, ib, n-i-ib+1,& - cone, a( 1, i+ib ),lda, a( i, i+ib ), lda, cone, a( 1, i ),lda ) - call stdlib_zherk( 'UPPER', 'NO TRANSPOSE', ib, n-i-ib+1,one, a( i, i+ib ),& + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',i-1, ib, n-i-ib+1,& + cone, a( 1_${ik}$, i+ib ),lda, a( i, i+ib ), lda, cone, a( 1_${ik}$, i ),lda ) + call stdlib${ii}$_zherk( 'UPPER', 'NO TRANSPOSE', ib, n-i-ib+1,one, a( i, i+ib ),& lda, one, a( i, i ),lda ) end if end do @@ -16599,23 +16602,23 @@ module stdlib_linalg_lapack_z ! compute the product l**h * l. do i = 1, n, nb ib = min( nb, n-i+1 ) - call stdlib_ztrmm( 'LEFT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', ib, i-1,& - cone, a( i, i ), lda,a( i, 1 ), lda ) - call stdlib_zlauu2( 'LOWER', ib, a( i, i ), lda, info ) + call stdlib${ii}$_ztrmm( 'LEFT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', ib, i-1,& + cone, a( i, i ), lda,a( i, 1_${ik}$ ), lda ) + call stdlib${ii}$_zlauu2( 'LOWER', ib, a( i, i ), lda, info ) if( i+ib<=n ) then - call stdlib_zgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', ib,i-1, n-i-ib+1,& - cone, a( i+ib, i ), lda,a( i+ib, 1 ), lda, cone, a( i, 1 ), lda ) - call stdlib_zherk( 'LOWER', 'CONJUGATE TRANSPOSE', ib,n-i-ib+1, one, a( i+& + call stdlib${ii}$_zgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', ib,i-1, n-i-ib+1,& + cone, a( i+ib, i ), lda,a( i+ib, 1_${ik}$ ), lda, cone, a( i, 1_${ik}$ ), lda ) + call stdlib${ii}$_zherk( 'LOWER', 'CONJUGATE TRANSPOSE', ib,n-i-ib+1, one, a( i+& ib, i ), lda, one,a( i, i ), lda ) end if end do end if end if return - end subroutine stdlib_zlauum + end subroutine stdlib${ii}$_zlauum - pure subroutine stdlib_zpbcon( uplo, n, kd, ab, ldab, anorm, rcond, work,rwork, info ) + pure subroutine stdlib${ii}$_zpbcon( uplo, n, kd, ab, ldab, anorm, rcond, work,rwork, info ) !! ZPBCON estimates the reciprocal of the condition number (in the !! 1-norm) of a complex Hermitian positive definite band matrix using !! the Cholesky factorization A = U**H*U or A = L*L**H computed by @@ -16628,8 +16631,8 @@ module stdlib_linalg_lapack_z ! -- 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(dp), intent(in) :: anorm real(dp), intent(out) :: rcond ! Array Arguments @@ -16641,11 +16644,11 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: upper character :: normin - integer(ilp) :: ix, kase + integer(${ik}$) :: ix, kase real(dp) :: ainvnm, scale, scalel, scaleu, smlnum complex(dp) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,aimag ! Statement Functions @@ -16654,61 +16657,61 @@ module stdlib_linalg_lapack_z cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) ) ! 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_zdscal( km, one / ajj, ab( kd, j+1 ), kld ) - call stdlib_zlacgv( km, ab( kd, j+1 ), kld ) - call stdlib_zher( 'UPPER', km, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) + if( km>0_${ik}$ ) then + call stdlib${ii}$_zdscal( km, one / ajj, ab( kd, j+1 ), kld ) + call stdlib${ii}$_zlacgv( km, ab( kd, j+1 ), kld ) + call stdlib${ii}$_zher( 'UPPER', km, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) - call stdlib_zlacgv( km, ab( kd, j+1 ), kld ) + call stdlib${ii}$_zlacgv( km, ab( kd, j+1 ), kld ) end if end do else ! factorize a(m+1:n,m+1:n) as l**h*l, and update a(1:m,1:m). do j = n, m + 1, -1 ! compute s(j,j) and test for non-positive-definiteness. - ajj = real( ab( 1, j ),KIND=dp) + ajj = real( ab( 1_${ik}$, j ),KIND=dp) if( ajj<=zero ) then - ab( 1, j ) = ajj + ab( 1_${ik}$, j ) = ajj go to 50 end if 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_zdscal( km, one / ajj, ab( km+1, j-km ), kld ) - call stdlib_zlacgv( km, ab( km+1, j-km ), kld ) - call stdlib_zher( 'LOWER', km, -one, ab( km+1, j-km ), kld,ab( 1, j-km ), kld ) + call stdlib${ii}$_zdscal( km, one / ajj, ab( km+1, j-km ), kld ) + call stdlib${ii}$_zlacgv( km, ab( km+1, j-km ), kld ) + call stdlib${ii}$_zher( 'LOWER', km, -one, ab( km+1, j-km ), kld,ab( 1_${ik}$, j-km ), kld ) - call stdlib_zlacgv( km, ab( km+1, j-km ), kld ) + call stdlib${ii}$_zlacgv( km, ab( km+1, j-km ), kld ) end do ! factorize the updated submatrix a(1:m,1:m) as u**h*u. do j = 1, m ! compute s(j,j) and test for non-positive-definiteness. - ajj = real( ab( 1, j ),KIND=dp) + ajj = real( ab( 1_${ik}$, j ),KIND=dp) if( ajj<=zero ) then - ab( 1, j ) = ajj + ab( 1_${ik}$, j ) = ajj go to 50 end if 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_zdscal( km, one / ajj, ab( 2, j ), 1 ) - call stdlib_zher( 'LOWER', km, -one, ab( 2, j ), 1,ab( 1, j+1 ), kld ) + if( km>0_${ik}$ ) then + call stdlib${ii}$_zdscal( km, one / ajj, ab( 2_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_zher( 'LOWER', km, -one, ab( 2_${ik}$, j ), 1_${ik}$,ab( 1_${ik}$, j+1 ), kld ) end if end do end if @@ -16937,10 +16940,10 @@ module stdlib_linalg_lapack_z 50 continue info = j return - end subroutine stdlib_zpbstf + end subroutine stdlib${ii}$_zpbstf - pure subroutine stdlib_zpbtf2( uplo, n, kd, ab, ldab, info ) + pure subroutine stdlib${ii}$_zpbtf2( uplo, n, kd, ab, ldab, info ) !! ZPBTF2 computes the Cholesky factorization of a complex Hermitian !! positive definite band matrix A. !! The factorization has the form @@ -16954,38 +16957,38 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: ab(ldab,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: j, kld, kn + integer(${ik}$) :: j, kld, kn real(dp) :: ajj ! Intrinsic Functions intrinsic :: real,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_zdscal( kn, one / ajj, ab( kd, j+1 ), kld ) - call stdlib_zlacgv( kn, ab( kd, j+1 ), kld ) - call stdlib_zher( 'UPPER', kn, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) + if( kn>0_${ik}$ ) then + call stdlib${ii}$_zdscal( kn, one / ajj, ab( kd, j+1 ), kld ) + call stdlib${ii}$_zlacgv( kn, ab( kd, j+1 ), kld ) + call stdlib${ii}$_zher( 'UPPER', kn, -one, ab( kd, j+1 ), kld,ab( kd+1, j+1 ), kld ) - call stdlib_zlacgv( kn, ab( kd, j+1 ), kld ) + call stdlib${ii}$_zlacgv( kn, ab( kd, j+1 ), kld ) end if end do else ! compute the cholesky factorization a = l*l**h. do j = 1, n ! compute l(j,j) and test for non-positive-definiteness. - ajj = real( ab( 1, j ),KIND=dp) + ajj = real( ab( 1_${ik}$, j ),KIND=dp) if( ajj<=zero ) then - ab( 1, j ) = ajj + ab( 1_${ik}$, j ) = ajj go to 30 end if 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_zdscal( kn, one / ajj, ab( 2, j ), 1 ) - call stdlib_zher( 'LOWER', kn, -one, ab( 2, j ), 1,ab( 1, j+1 ), kld ) + if( kn>0_${ik}$ ) then + call stdlib${ii}$_zdscal( kn, one / ajj, ab( 2_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_zher( 'LOWER', kn, -one, ab( 2_${ik}$, j ), 1_${ik}$,ab( 1_${ik}$, j+1 ), kld ) end if end do end if @@ -17032,10 +17035,10 @@ module stdlib_linalg_lapack_z 30 continue info = j return - end subroutine stdlib_zpbtf2 + end subroutine stdlib${ii}$_zpbtf2 - pure subroutine stdlib_zpbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) + pure subroutine stdlib${ii}$_zpbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) !! ZPBTRS solves a system of linear equations A*X = B with a Hermitian !! positive definite band matrix A using the Cholesky factorization !! A = U**H *U or A = L*L**H computed by ZPBTRF. @@ -17044,36 +17047,36 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(in) :: ab(ldab,*) complex(dp), 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_ztpsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',j-1, ap, & - ap( jc ), 1 ) + if( j>1_${ik}$ )call stdlib${ii}$_ztpsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',j-1, ap, & + ap( jc ), 1_${ik}$ ) ! compute u(j,j) and test for non-positive-definiteness. - ajj = real( ap( jj ),KIND=dp) - real( stdlib_zdotc( j-1,ap( jc ), 1, ap( jc ), 1 & + ajj = real( ap( jj ),KIND=dp) - real( stdlib${ii}$_zdotc( j-1,ap( jc ), 1_${ik}$, ap( jc ), 1_${ik}$ & ),KIND=dp) if( ajj<=zero ) then ap( jj ) = ajj @@ -17867,7 +17870,7 @@ module stdlib_linalg_lapack_z end do else ! compute the cholesky factorization a = l * l**h. - jj = 1 + jj = 1_${ik}$ do j = 1, n ! compute l(j,j) and test for non-positive-definiteness. ajj = real( ap( jj ),KIND=dp) @@ -17880,9 +17883,9 @@ module stdlib_linalg_lapack_z ! compute elements j+1:n of column j and update the trailing ! submatrix. if( j1 ) then + if( j>1_${ik}$ ) then work( i ) = work( i ) +real( conjg( a( j-1, i ) )*a( j-1, i ),KIND=dp) end if work( n+i ) = real( a( i, i ),KIND=dp) - work( i ) end do - if( j>1 ) then - itemp = maxloc( work( (n+j):(2*n) ), 1 ) - pvt = itemp + j - 1 + if( j>1_${ik}$ ) then + itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) + pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) - if( ajj<=dstop.or.stdlib_disnan( ajj ) ) then + if( ajj<=dstop.or.stdlib${ii}$_disnan( ajj ) ) then a( j, j ) = ajj go to 190 end if @@ -18057,8 +18060,8 @@ module stdlib_linalg_lapack_z if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) - call stdlib_zswap( j-1, a( 1, j ), 1, a( 1, pvt ), 1 ) - if( pvt1 ) then + if( j>1_${ik}$ ) then work( i ) = work( i ) +real( conjg( a( i, j-1 ) )*a( i, j-1 ),KIND=dp) end if work( n+i ) = real( a( i, i ),KIND=dp) - work( i ) end do - if( j>1 ) then - itemp = maxloc( work( (n+j):(2*n) ), 1 ) - pvt = itemp + j - 1 + if( j>1_${ik}$ ) then + itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) + pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) - if( ajj<=dstop.or.stdlib_disnan( ajj ) ) then + if( ajj<=dstop.or.stdlib${ii}$_disnan( ajj ) ) then a( j, j ) = ajj go to 190 end if @@ -18110,8 +18113,8 @@ module stdlib_linalg_lapack_z if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) - call stdlib_zswap( j-1, a( j, 1 ), lda, a( pvt, 1 ), lda ) - if( pvt=n ) then + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code - call stdlib_zpstf2( uplo, n, a( 1, 1 ), lda, piv, rank, tol, work,info ) + call stdlib${ii}$_zpstf2( uplo, n, a( 1_${ik}$, 1_${ik}$ ), lda, piv, rank, tol, work,info ) go to 230 else ! initialize piv @@ -18216,16 +18219,16 @@ module stdlib_linalg_lapack_z do i = 1, n work( i ) = real( a( i, i ),KIND=dp) end do - pvt = maxloc( work( 1:n ), 1 ) + pvt = maxloc( work( 1_${ik}$:n ), 1_${ik}$ ) ajj = real( a( pvt, pvt ),KIND=dp) - if( ajj<=zero.or.stdlib_disnan( ajj ) ) then - rank = 0 - info = 1 + if( ajj<=zero.or.stdlib${ii}$_disnan( ajj ) ) then + rank = 0_${ik}$ + info = 1_${ik}$ go to 230 end if ! compute stopping value if not supplied if( tol1 ) then - itemp = maxloc( work( (n+j):(2*n) ), 1 ) - pvt = itemp + j - 1 + if( j>1_${ik}$ ) then + itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) + pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) - if( ajj<=dstop.or.stdlib_disnan( ajj ) ) then + if( ajj<=dstop.or.stdlib${ii}$_disnan( ajj ) ) then a( j, j ) = ajj go to 220 end if @@ -18262,8 +18265,8 @@ module stdlib_linalg_lapack_z if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) - call stdlib_zswap( j-1, a( 1, j ), 1, a( 1, pvt ), 1 ) - if( pvt1 ) then - itemp = maxloc( work( (n+j):(2*n) ), 1 ) - pvt = itemp + j - 1 + if( j>1_${ik}$ ) then + itemp = maxloc( work( (n+j):(2_${ik}$*n) ), 1_${ik}$ ) + pvt = itemp + j - 1_${ik}$ ajj = work( n+pvt ) - if( ajj<=dstop.or.stdlib_disnan( ajj ) ) then + if( ajj<=dstop.or.stdlib${ii}$_disnan( ajj ) ) then a( j, j ) = ajj go to 220 end if @@ -18329,9 +18332,9 @@ module stdlib_linalg_lapack_z if( j/=pvt ) then ! pivot ok, so can now swap pivot rows and columns a( pvt, pvt ) = a( j, j ) - call stdlib_zswap( j-1, a( j, 1 ), lda, a( pvt, 1 ), lda ) - if( pvt0 ) then - kx = 1 + if( incx>0_${ik}$ ) then + kx = 1_${ik}$ else - kx = 1 - ( n-1 )*incx + kx = 1_${ik}$ - ( n-1 )*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 )*incy end if ! start the operations. in this version the elements of the array ap ! are accessed sequentially with cone pass through ap. ! first form y := beta*y. if( beta/=cone ) then - if( incy==1 ) then + if( incy==1_${ik}$ ) then if( beta==czero ) then do i = 1, n y( i ) = czero @@ -18776,10 +18779,10 @@ module stdlib_linalg_lapack_z end if end if if( alpha==czero )return - kk = 1 + kk = 1_${ik}$ if( stdlib_lsame( uplo, 'U' ) ) then ! form y when ap contains the upper triangle. - if( ( incx==1 ) .and. ( incy==1 ) ) then + if( ( incx==1_${ik}$ ) .and. ( incy==1_${ik}$ ) ) then do j = 1, n temp1 = alpha*x( j ) temp2 = czero @@ -18787,7 +18790,7 @@ module stdlib_linalg_lapack_z do i = 1, j - 1 y( i ) = y( i ) + temp1*ap( k ) temp2 = temp2 + ap( k )*x( i ) - k = k + 1 + k = k + 1_${ik}$ end do y( j ) = y( j ) + temp1*ap( kk+j-1 ) + alpha*temp2 kk = kk + j @@ -18814,16 +18817,16 @@ module stdlib_linalg_lapack_z end if else ! form y when ap contains the lower triangle. - if( ( incx==1 ) .and. ( incy==1 ) ) then + if( ( incx==1_${ik}$ ) .and. ( incy==1_${ik}$ ) ) then do j = 1, n temp1 = alpha*x( j ) temp2 = czero y( j ) = y( j ) + temp1*ap( kk ) - k = kk + 1 + k = kk + 1_${ik}$ do i = j + 1, n y( i ) = y( i ) + temp1*ap( k ) temp2 = temp2 + ap( k )*x( i ) - k = k + 1 + k = k + 1_${ik}$ end do y( j ) = y( j ) + alpha*temp2 kk = kk + ( n-j+1 ) @@ -18851,10 +18854,10 @@ module stdlib_linalg_lapack_z end if end if return - end subroutine stdlib_zspmv + end subroutine stdlib${ii}$_zspmv - pure subroutine stdlib_zspr( uplo, n, alpha, x, incx, ap ) + pure subroutine stdlib${ii}$_zspr( uplo, n, alpha, x, incx, ap ) !! ZSPR performs the symmetric rank 1 operation !! A := alpha*x*x**H + A, !! where alpha is a complex scalar, x is an n element vector and A is an @@ -18864,7 +18867,7 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: incx, n + integer(${ik}$), intent(in) :: incx, n complex(dp), intent(in) :: alpha ! Array Arguments complex(dp), intent(inout) :: ap(*) @@ -18872,43 +18875,43 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! Local Scalars - integer(ilp) :: i, info, ix, j, jx, k, kk, kx + integer(${ik}$) :: i, info, ix, j, jx, k, kk, kx complex(dp) :: temp ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = 1 - else if( n<0 ) then - info = 2 - else if( incx==0 ) then - info = 5 + info = 1_${ik}$ + else if( n<0_${ik}$ ) then + info = 2_${ik}$ + else if( incx==0_${ik}$ ) then + info = 5_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'ZSPR ', info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZSPR ', info ) return end if ! quick return if possible. if( ( n==0 ) .or. ( alpha==czero ) )return ! set the start point in x if the increment is not unity. - if( incx<=0 ) then - kx = 1 - ( n-1 )*incx - else if( incx/=1 ) then - kx = 1 + if( incx<=0_${ik}$ ) then + kx = 1_${ik}$ - ( n-1 )*incx + else if( incx/=1_${ik}$ ) then + kx = 1_${ik}$ end if ! start the operations. in this version the elements of the array ap ! are accessed sequentially with cone pass through ap. - kk = 1 + kk = 1_${ik}$ if( stdlib_lsame( uplo, 'U' ) ) then ! form a when upper triangle is stored in ap. - if( incx==1 ) then + if( incx==1_${ik}$ ) then do j = 1, n if( x( j )/=czero ) then temp = alpha*x( j ) k = kk do i = 1, j - 1 ap( k ) = ap( k ) + x( i )*temp - k = k + 1 + k = k + 1_${ik}$ end do ap( kk+j-1 ) = ap( kk+j-1 ) + x( j )*temp else @@ -18936,20 +18939,20 @@ module stdlib_linalg_lapack_z end if else ! form a when lower triangle is stored in ap. - if( incx==1 ) then + if( incx==1_${ik}$ ) then do j = 1, n if( x( j )/=czero ) then temp = alpha*x( j ) ap( kk ) = ap( kk ) + temp*x( j ) - k = kk + 1 + k = kk + 1_${ik}$ do i = j + 1, n ap( k ) = ap( k ) + x( i )*temp - k = k + 1 + k = k + 1_${ik}$ end do else ap( kk ) = ap( kk ) end if - kk = kk + n - j + 1 + kk = kk + n - j + 1_${ik}$ end do else jx = kx @@ -18966,15 +18969,15 @@ module stdlib_linalg_lapack_z ap( kk ) = ap( kk ) end if jx = jx + incx - kk = kk + n - j + 1 + kk = kk + n - j + 1_${ik}$ end do end if end if return - end subroutine stdlib_zspr + end subroutine stdlib${ii}$_zspr - pure subroutine stdlib_zsptrf( uplo, n, ap, ipiv, info ) + pure subroutine stdlib${ii}$_zsptrf( uplo, n, ap, ipiv, info ) !! ZSPTRF computes the factorization of a complex symmetric matrix A !! stored in packed format using the Bunch-Kaufman diagonal pivoting !! method: @@ -18987,10 +18990,10 @@ module stdlib_linalg_lapack_z ! -- 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) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(dp), intent(inout) :: ap(*) ! ===================================================================== ! Parameters @@ -19000,7 +19003,7 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: upper - integer(ilp) :: i, imax, j, jmax, k, kc, kk, knc, kp, kpc, kstep, kx, npp + integer(${ik}$) :: i, imax, j, jmax, k, kc, kk, knc, kp, kpc, kstep, kx, npp real(dp) :: absakk, alpha, colmax, rowmax complex(dp) :: d11, d12, d21, d22, r1, t, wk, wkm1, wkp1, zdum ! Intrinsic Functions @@ -19011,15 +19014,15 @@ module stdlib_linalg_lapack_z cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) ) ! 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 + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'ZSPTRF', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZSPTRF', -info ) return end if ! initialize alpha for use in choosing pivot block size. @@ -19029,26 +19032,26 @@ module stdlib_linalg_lapack_z ! k is the main loop index, decreasing from n to 1 in steps of ! 1 or 2 k = n - kc = ( n-1 )*n / 2 + 1 + kc = ( n-1 )*n / 2_${ik}$ + 1_${ik}$ 10 continue knc = kc ! if k < 1, exit from loop if( k<1 )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 absakk = cabs1( ap( kc+k-1 ) ) ! imax is the row-index of the largest off-diagonal element in ! column k, and colmax is its absolute value - if( k>1 ) then - imax = stdlib_izamax( k-1, ap( kc ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_izamax( k-1, ap( kc ), 1_${ik}$ ) colmax = cabs1( 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 @@ -19057,7 +19060,7 @@ module stdlib_linalg_lapack_z else rowmax = zero jmax = imax - kx = imax*( imax+1 ) / 2 + imax + kx = imax*( imax+1 ) / 2_${ik}$ + imax do j = imax + 1, k if( cabs1( ap( kx ) )>rowmax ) then rowmax = cabs1( ap( kx ) ) @@ -19065,9 +19068,9 @@ module stdlib_linalg_lapack_z end if kx = kx + j end do - kpc = ( imax-1 )*imax / 2 + 1 - if( imax>1 ) then - jmax = stdlib_izamax( imax-1, ap( kpc ), 1 ) + kpc = ( imax-1 )*imax / 2_${ik}$ + 1_${ik}$ + if( imax>1_${ik}$ ) then + jmax = stdlib${ii}$_izamax( imax-1, ap( kpc ), 1_${ik}$ ) rowmax = max( rowmax, cabs1( ap( kpc+jmax-1 ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then @@ -19081,18 +19084,18 @@ module stdlib_linalg_lapack_z ! interchange rows and columns k-1 and imax, use 2-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_zswap( kp-1, ap( knc ), 1, ap( kpc ), 1 ) - kx = kpc + kp - 1 + call stdlib${ii}$_zswap( 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 @@ -19100,23 +19103,23 @@ module stdlib_linalg_lapack_z 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 + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u ! perform a rank-1 update of a(1:k-1,1:k-1) as ! a := a - u(k)*d(k)*u(k)**t = a - w(k)*1/d(k)*w(k)**t r1 = cone / ap( kc+k-1 ) - call stdlib_zspr( uplo, k-1, -r1, ap( kc ), 1, ap ) + call stdlib${ii}$_zspr( uplo, k-1, -r1, ap( kc ), 1_${ik}$, ap ) ! store u(k) in column k - call stdlib_zscal( k-1, r1, ap( kc ), 1 ) + call stdlib${ii}$_zscal( k-1, r1, ap( kc ), 1_${ik}$ ) else ! 2-by-2 pivot block d(k): columns k and k-1 now hold ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k) @@ -19125,29 +19128,29 @@ module stdlib_linalg_lapack_z ! perform a rank-2 update of a(1:k-2,1:k-2) as ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**t ! = a - ( 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 = cone / ( d11*d22-cone ) 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 @@ -19161,28 +19164,28 @@ module stdlib_linalg_lapack_z ! 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 = 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 absakk = cabs1( 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 @@ -19200,9 +19203,9 @@ module stdlib_linalg_lapack_z 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 @@ -19216,19 +19219,19 @@ module stdlib_linalg_lapack_z ! interchange rows and columns k+1 and imax, use 2-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 )==czero )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 )==czero )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 = 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. ap( kc+k-1 ) = cone / ap( kc+k-1 ) ! compute column k of the inverse. - if( k>1 ) then - call stdlib_zcopy( k-1, ap( kc ), 1, work, 1 ) - call stdlib_zspmv( uplo, k-1, -cone, ap, work, 1, czero, ap( kc ),1 ) - ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib_zdotu( k-1, work, 1, ap( kc ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_zcopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_zspmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero, ap( kc ),1_${ik}$ ) + ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_zdotu( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ ) end if - kstep = 1 + kstep = 1_${ik}$ else ! 2 x 2 diagonal block ! invert the diagonal block. @@ -19391,30 +19394,30 @@ module stdlib_linalg_lapack_z 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_zcopy( k-1, ap( kc ), 1, work, 1 ) - call stdlib_zspmv( uplo, k-1, -cone, ap, work, 1, czero, ap( kc ),1 ) - ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib_zdotu( k-1, work, 1, ap( kc ), 1 ) - ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib_zdotu( k-1, ap( kc ), 1, ap( & - kcnext ),1 ) - call stdlib_zcopy( k-1, ap( kcnext ), 1, work, 1 ) - call stdlib_zspmv( uplo, k-1, -cone, ap, work, 1, czero,ap( kcnext ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_zcopy( k-1, ap( kc ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_zspmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero, ap( kc ),1_${ik}$ ) + ap( kc+k-1 ) = ap( kc+k-1 ) -stdlib${ii}$_zdotu( k-1, work, 1_${ik}$, ap( kc ), 1_${ik}$ ) + ap( kcnext+k-1 ) = ap( kcnext+k-1 ) -stdlib${ii}$_zdotu( k-1, ap( kc ), 1_${ik}$, ap( & + kcnext ),1_${ik}$ ) + call stdlib${ii}$_zcopy( k-1, ap( kcnext ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_zspmv( uplo, k-1, -cone, ap, work, 1_${ik}$, czero,ap( kcnext ), 1_${ik}$ ) - ap( kcnext+k ) = ap( kcnext+k ) -stdlib_zdotu( k-1, work, 1, ap( kcnext ), 1 ) + ap( kcnext+k ) = ap( kcnext+k ) -stdlib${ii}$_zdotu( 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_zswap( kp-1, ap( kc ), 1, ap( kpc ), 1 ) - kx = kpc + kp - 1 + kpc = ( kp-1 )*kp / 2_${ik}$ + 1_${ik}$ + call stdlib${ii}$_zswap( kp-1, ap( kc ), 1_${ik}$, ap( kpc ), 1_${ik}$ ) + kx = kpc + kp - 1_${ik}$ do j = kp + 1, k - 1 - kx = kx + j - 1 + kx = kx + j - 1_${ik}$ temp = ap( kc+j-1 ) ap( kc+j-1 ) = ap( kx ) ap( kx ) = temp @@ -19422,7 +19425,7 @@ module stdlib_linalg_lapack_z 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 @@ -19436,25 +19439,25 @@ module stdlib_linalg_lapack_z ! 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 + 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. ap( kc ) = cone / ap( kc ) ! compute column k of the inverse. if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_zgeru( k-1, nrhs, -cone, ap( kc ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb ) + call stdlib${ii}$_zgeru( k-1, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb ) ! multiply by the inverse of the diagonal block. - call stdlib_zscal( nrhs, cone / ap( kc+k-1 ), b( k, 1 ), ldb ) - k = k - 1 + call stdlib${ii}$_zscal( nrhs, cone / ap( kc+k-1 ), b( k, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( kp/=k-1 )call stdlib_zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib${ii}$_zswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - call stdlib_zgeru( k-2, nrhs, -cone, ap( kc ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb ) + call stdlib${ii}$_zgeru( k-2, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb ) - call stdlib_zgeru( k-2, nrhs, -cone, ap( kc-( k-1 ) ), 1,b( k-1, 1 ), ldb, b( 1, & - 1 ), ldb ) + call stdlib${ii}$_zgeru( k-2, nrhs, -cone, ap( kc-( k-1 ) ), 1_${ik}$,b( k-1, 1_${ik}$ ), ldb, b( 1_${ik}$, & + 1_${ik}$ ), ldb ) ! multiply by the inverse of the diagonal block. akm1k = ap( kc+k-2 ) akm1 = ap( kc-1 ) / akm1k @@ -19600,43 +19603,43 @@ module stdlib_linalg_lapack_z 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 = 1_${ik}$ + kc = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(u**t(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, ap( kc ),1, cone, b( k,& - 1 ), ldb ) + call stdlib${ii}$_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, ap( kc ),1_${ik}$, cone, b( k,& + 1_${ik}$ ), ldb ) ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( 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 ! 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_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, ap( kc ),1, cone, b( k,& - 1 ), ldb ) - call stdlib_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb,ap( kc+k ), 1, cone, b( & - k+1, 1 ), ldb ) + call stdlib${ii}$_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, ap( kc ),1_${ik}$, cone, b( k,& + 1_${ik}$ ), ldb ) + call stdlib${ii}$_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb,ap( kc+k ), 1_${ik}$, cone, b( & + k+1, 1_${ik}$ ), ldb ) ! interchange rows k and -ipiv(k). kp = -ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - kc = kc + 2*k + 1 - k = k + 2 + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + kc = kc + 2_${ik}$*k + 1_${ik}$ + k = k + 2_${ik}$ end if go to 40 50 continue @@ -19645,36 +19648,36 @@ module stdlib_linalg_lapack_z ! 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 = 1_${ik}$ + kc = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(l**t(k)), where l(k) is the transformation ! stored in column k of a. - if( kn ) then - info = -4 - else if( ldzn ) then + info = -4_${ik}$ + else if( ldz1 ) then + if( jblk>1_${ik}$ ) then eps1 = abs( eps*xj ) pertol = ten*eps1 sep = xj - xjm if( sepmaxits )go to 120 ! normalize and scale the righthand side vector pb. - jmax = stdlib_idamax( blksiz, work( indrv1+1 ), 1 ) + jmax = stdlib${ii}$_idamax( blksiz, work( indrv1+1 ), 1_${ik}$ ) scl = blksiz*onenrm*max( eps,abs( work( indrv4+blksiz ) ) ) /abs( work( indrv1+& jmax ) ) - call stdlib_dscal( blksiz, scl, work( indrv1+1 ), 1 ) + call stdlib${ii}$_dscal( blksiz, scl, work( indrv1+1 ), 1_${ik}$ ) ! solve the system lu = pb. - call stdlib_dlagts( -1, blksiz, work( indrv4+1 ), work( indrv2+2 ),work( indrv3+& - 1 ), work( indrv5+1 ), iwork,work( indrv1+1 ), tol, iinfo ) + call stdlib${ii}$_dlagts( -1_${ik}$, blksiz, work( indrv4+1 ), work( indrv2+2 ),work( indrv3+& + 1_${ik}$ ), work( indrv5+1 ), iwork,work( indrv1+1 ), tol, iinfo ) ! reorthogonalize by modified gram-schmidt if eigenvalues are ! close enough. if( jblk==1 )go to 110 @@ -19909,25 +19912,25 @@ module stdlib_linalg_lapack_z end if ! check the infinity norm of the iterate. 110 continue - jmax = stdlib_idamax( blksiz, work( indrv1+1 ), 1 ) + jmax = stdlib${ii}$_idamax( blksiz, work( indrv1+1 ), 1_${ik}$ ) nrm = abs( work( indrv1+jmax ) ) ! continue for additional iterations after norm reaches ! stopping criterion. if( nrm0 .and. ldz0_${ik}$ .and. ldzn )go to 160 - if( l1>1 )e( l1-1 ) = zero + if( l1>1_${ik}$ )e( l1-1 ) = zero if( l1<=nm1 ) then do m = l1, nm1 tst = abs( e( m ) ) @@ -20039,20 +20042,20 @@ module stdlib_linalg_lapack_z lsv = l lend = m lendsv = lend - l1 = m + 1 + l1 = m + 1_${ik}$ if( lend==l )go to 10 ! scale submatrix in rows and columns l to lend - anorm = stdlib_dlanst( 'I', lend-l+1, d( l ), e( l ) ) - iscale = 0 + anorm = stdlib${ii}$_dlanst( 'I', lend-l+1, d( l ), e( l ) ) + iscale = 0_${ik}$ if( anorm==zero )go to 10 if( anorm>ssfmax ) then - iscale = 1 - call stdlib_dlascl( 'G', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n,info ) - call stdlib_dlascl( 'G', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n,info ) + iscale = 1_${ik}$ + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmax, lend-l+1, 1_${ik}$, d( l ), n,info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, anorm, ssfmax, lend-l, 1_${ik}$, e( l ), n,info ) else if( anorm0 ) then - call stdlib_dlaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s ) + if( icompz>0_${ik}$ ) then + call stdlib${ii}$_dlaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s ) work( l ) = c work( n-1+l ) = s - call stdlib_zlasr( 'R', 'V', 'B', n, 2, work( l ),work( n-1+l ), z( 1, l ), & + call stdlib${ii}$_zlasr( 'R', 'V', 'B', n, 2_${ik}$, work( l ),work( n-1+l ), z( 1_${ik}$, l ), & ldz ) else - call stdlib_dlae2( d( l ), e( l ), d( l+1 ), rt1, rt2 ) + call stdlib${ii}$_dlae2( d( l ), e( l ), d( l+1 ), rt1, rt2 ) end if d( l ) = rt1 d( l+1 ) = rt2 e( l ) = zero - l = l + 2 + l = l + 2_${ik}$ if( l<=lend )go to 40 go to 140 end if if( jtot==nmaxit )go to 140 - jtot = jtot + 1 + jtot = jtot + 1_${ik}$ ! form shift. g = ( d( l+1 )-p ) / ( two*e( l ) ) - r = stdlib_dlapy2( g, one ) + r = stdlib${ii}$_dlapy2( g, one ) g = d( m ) - p + ( e( l ) / ( g+sign( r, g ) ) ) s = one c = one p = zero ! inner loop - mm1 = m - 1 + mm1 = m - 1_${ik}$ do i = mm1, l, -1 f = s*e( i ) b = c*e( i ) - call stdlib_dlartg( g, f, c, s, r ) + call stdlib${ii}$_dlartg( g, f, c, s, r ) if( i/=m-1 )e( i+1 ) = r g = d( i+1 ) - p r = ( d( i )-g )*s + two*c*b @@ -20116,15 +20119,15 @@ module stdlib_linalg_lapack_z d( i+1 ) = g + p g = c*r - b ! if eigenvectors are desired, then save rotations. - if( icompz>0 ) then + if( icompz>0_${ik}$ ) then work( i ) = c work( n-1+i ) = -s end if end do ! if eigenvectors are desired, then apply saved rotations. - if( icompz>0 ) then - mm = m - l + 1 - call stdlib_zlasr( 'R', 'V', 'B', n, mm, work( l ), work( n-1+l ),z( 1, l ), ldz & + if( icompz>0_${ik}$ ) then + mm = m - l + 1_${ik}$ + call stdlib${ii}$_zlasr( 'R', 'V', 'B', n, mm, work( l ), work( n-1+l ),z( 1_${ik}$, l ), ldz & ) end if d( l ) = d( l ) - p @@ -20133,7 +20136,7 @@ module stdlib_linalg_lapack_z ! eigenvalue found. 80 continue d( l ) = p - l = l + 1 + l = l + 1_${ik}$ if( l<=lend )go to 40 go to 140 else @@ -20141,9 +20144,9 @@ module stdlib_linalg_lapack_z ! look for small superdiagonal element. 90 continue if( l/=lend ) then - lendp1 = lend + 1 + lendp1 = lend + 1_${ik}$ do m = l, lendp1, -1 - tst = abs( e( m-1 ) )**2 + tst = abs( e( m-1 ) )**2_${ik}$ if( tst<=( eps2*abs( d( m ) ) )*abs( d( m-1 ) )+safmin )go to 110 end do end if @@ -20152,40 +20155,40 @@ module stdlib_linalg_lapack_z if( m>lend )e( m-1 ) = zero p = d( l ) if( m==l )go to 130 - ! if remaining matrix is 2-by-2, use stdlib_dlae2 or stdlib_slaev2 + ! if remaining matrix is 2-by-2, use stdlib_dlae2 or stdlib${ii}$_slaev2 ! to compute its eigensystem. if( m==l-1 ) then - if( icompz>0 ) then - call stdlib_dlaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s ) + if( icompz>0_${ik}$ ) then + call stdlib${ii}$_dlaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s ) work( m ) = c work( n-1+m ) = s - call stdlib_zlasr( 'R', 'V', 'F', n, 2, work( m ),work( n-1+m ), z( 1, l-1 ), & + call stdlib${ii}$_zlasr( 'R', 'V', 'F', n, 2_${ik}$, work( m ),work( n-1+m ), z( 1_${ik}$, l-1 ), & ldz ) else - call stdlib_dlae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 ) + call stdlib${ii}$_dlae2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2 ) end if d( l-1 ) = rt1 d( l ) = rt2 e( l-1 ) = zero - l = l - 2 + l = l - 2_${ik}$ if( l>=lend )go to 90 go to 140 end if if( jtot==nmaxit )go to 140 - jtot = jtot + 1 + jtot = jtot + 1_${ik}$ ! form shift. g = ( d( l-1 )-p ) / ( two*e( l-1 ) ) - r = stdlib_dlapy2( g, one ) + r = stdlib${ii}$_dlapy2( g, one ) g = d( m ) - p + ( e( l-1 ) / ( g+sign( r, g ) ) ) s = one c = one p = zero ! inner loop - lm1 = l - 1 + lm1 = l - 1_${ik}$ do i = m, lm1 f = s*e( i ) b = c*e( i ) - call stdlib_dlartg( g, f, c, s, r ) + call stdlib${ii}$_dlartg( g, f, c, s, r ) if( i/=m )e( i-1 ) = r g = d( i ) - p r = ( d( i+1 )-g )*s + two*c*b @@ -20193,15 +20196,15 @@ module stdlib_linalg_lapack_z d( i ) = g + p g = c*r - b ! if eigenvectors are desired, then save rotations. - if( icompz>0 ) then + if( icompz>0_${ik}$ ) then work( i ) = c work( n-1+i ) = s end if end do ! if eigenvectors are desired, then apply saved rotations. - if( icompz>0 ) then - mm = l - m + 1 - call stdlib_zlasr( 'R', 'V', 'F', n, mm, work( m ), work( n-1+m ),z( 1, m ), ldz & + if( icompz>0_${ik}$ ) then + mm = l - m + 1_${ik}$ + call stdlib${ii}$_zlasr( 'R', 'V', 'F', n, mm, work( m ), work( n-1+m ),z( 1_${ik}$, m ), ldz & ) end if d( l ) = d( l ) - p @@ -20210,41 +20213,41 @@ module stdlib_linalg_lapack_z ! eigenvalue found. 130 continue d( l ) = p - l = l - 1 + l = l - 1_${ik}$ if( l>=lend )go to 90 go to 140 end if ! undo scaling if necessary 140 continue - if( iscale==1 ) then - call stdlib_dlascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1,d( lsv ), n, info ) + if( iscale==1_${ik}$ ) then + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, ssfmax, anorm, lendsv-lsv+1, 1_${ik}$,d( lsv ), n, info ) - call stdlib_dlascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv, 1, e( lsv ),n, info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, ssfmax, anorm, lendsv-lsv, 1_${ik}$, e( lsv ),n, info ) - else if( iscale==2 ) then - call stdlib_dlascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1,d( lsv ), n, info ) + else if( iscale==2_${ik}$ ) then + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, ssfmin, anorm, lendsv-lsv+1, 1_${ik}$,d( lsv ), n, info ) - call stdlib_dlascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv, 1, e( lsv ),n, info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, ssfmin, anorm, lendsv-lsv, 1_${ik}$, e( lsv ),n, info ) end if ! check for no convergence to an eigenvalue after a total ! of n*maxit iterations. if( jtot==nmaxit ) then do i = 1, n - 1 - if( e( i )/=zero )info = info + 1 + if( e( i )/=zero )info = info + 1_${ik}$ end do return end if go to 10 ! order eigenvalues and eigenvectors. 160 continue - if( icompz==0 ) then + if( icompz==0_${ik}$ ) then ! use quick sort - call stdlib_dlasrt( 'I', n, d, info ) + call stdlib${ii}$_dlasrt( 'I', n, d, info ) else ! use selection sort to minimize swaps of eigenvectors do ii = 2, n - i = ii - 1 + i = ii - 1_${ik}$ k = i p = d( i ) do j = ii, n @@ -20256,15 +20259,15 @@ module stdlib_linalg_lapack_z if( k/=i ) then d( k ) = d( i ) d( i ) = p - call stdlib_zswap( n, z( 1, i ), 1, z( 1, k ), 1 ) + call stdlib${ii}$_zswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, k ), 1_${ik}$ ) end if end do end if return - end subroutine stdlib_zsteqr + end subroutine stdlib${ii}$_zsteqr - pure subroutine stdlib_zsyconv( uplo, way, n, a, lda, ipiv, e, info ) + pure subroutine stdlib${ii}$_zsyconv( uplo, way, n, a, lda, ipiv, e, info ) !! ZSYCONV converts A given by ZHETRF into L and D or vice-versa. !! Get nondiagonal elements of D (returned in workspace) and !! apply or reverse permutation done in TRF. @@ -20273,33 +20276,33 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: e(*) ! ===================================================================== ! External Subroutines logical(lk) :: upper, convert - integer(ilp) :: i, ip, j + integer(${ik}$) :: i, ip, j complex(dp) :: temp ! 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( lda 1 ) - if( ipiv(i) < 0 ) then + if( ipiv(i) < 0_${ik}$ ) then e(i)=a(i-1,i) e(i-1)=czero a(i-1,i)=czero @@ -20325,7 +20328,7 @@ module stdlib_linalg_lapack_z ! 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 @@ -20350,9 +20353,9 @@ module stdlib_linalg_lapack_z 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 @@ -20377,7 +20380,7 @@ module stdlib_linalg_lapack_z ! 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 @@ -20389,10 +20392,10 @@ module stdlib_linalg_lapack_z if ( convert ) then ! convert a (a is lower) ! convert value - i=1 + i=1_${ik}$ e(n)=czero 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) @@ -20416,7 +20419,7 @@ module stdlib_linalg_lapack_z 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) @@ -20432,9 +20435,9 @@ module stdlib_linalg_lapack_z ! 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) @@ -20444,7 +20447,7 @@ module stdlib_linalg_lapack_z 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) @@ -20455,9 +20458,9 @@ module stdlib_linalg_lapack_z 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 @@ -20466,10 +20469,10 @@ module stdlib_linalg_lapack_z end if end if return - end subroutine stdlib_zsyconv + end subroutine stdlib${ii}$_zsyconv - pure subroutine stdlib_zsyconvf( uplo, way, n, a, lda, e, ipiv, info ) + pure subroutine stdlib${ii}$_zsyconvf( uplo, way, n, a, lda, e, ipiv, info ) !! If parameter WAY = 'C': !! ZSYCONVF converts the factorization output format used in !! ZSYTRF provided on entry in parameter A into the factorization @@ -20492,31 +20495,31 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), 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 ) = czero a( i-1, i ) = czero - i = i - 1 + i = i - 1_${ik}$ else e( i ) = czero 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 i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(1:i,n-i:n) ip = ipiv( i ) if( i0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(1: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 @@ -20629,40 +20632,40 @@ module stdlib_linalg_lapack_z ! convert value ! assign subdiagonal entries of d to array e and czero out ! corresponding entries in input storage a - i = 1 + i = 1_${ik}$ e( n ) = czero do while ( i<=n ) - if( i0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(i:n,1:i-1) ip = ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_zswap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_zswap( 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) ip = -ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=(i+1) ) then - call stdlib_zswap( i-1, a( i+1, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_zswap( i-1, a( i+1, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda ) end if end if ! convert ipiv @@ -20670,9 +20673,9 @@ module stdlib_linalg_lapack_z ! 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) @@ -20681,23 +20684,23 @@ module stdlib_linalg_lapack_z ! in reverse factorization order where i decreases from n to 1 i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(i:n,1:i-1) ip = ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_zswap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) + call stdlib${ii}$_zswap( 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 + i = i - 1_${ik}$ ip = -ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=(i+1) ) then - call stdlib_zswap( i-1, a( ip, 1 ), lda,a( i+1, 1 ), lda ) + call stdlib${ii}$_zswap( i-1, a( ip, 1_${ik}$ ), lda,a( i+1, 1_${ik}$ ), lda ) end if end if ! convert ipiv @@ -20706,27 +20709,27 @@ module stdlib_linalg_lapack_z ! 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_zsyconvf + end subroutine stdlib${ii}$_zsyconvf - pure subroutine stdlib_zsyconvf_rook( uplo, way, n, a, lda, e, ipiv, info ) + pure subroutine stdlib${ii}$_zsyconvf_rook( uplo, way, n, a, lda, e, ipiv, info ) !! If parameter WAY = 'C': !! ZSYCONVF_ROOK converts the factorization output format used in !! ZSYTRF_ROOK provided on entry in parameter A into the factorization @@ -20747,31 +20750,31 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), 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 ) = czero a( i-1, i ) = czero - i = i - 1 + i = i - 1_${ik}$ else e( i ) = czero 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 i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(1:i,n-i:n) ip = ipiv( i ) if( i0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(1: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 @@ -20884,31 +20887,31 @@ module stdlib_linalg_lapack_z ! convert value ! assign subdiagonal entries of d to array e and czero out ! corresponding entries in input storage a - i = 1 + i = 1_${ik}$ e( n ) = czero do while ( i<=n ) - if( i0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(i:n,1:i-1) ip = ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_zswap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_zswap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda ) end if end if else @@ -20917,17 +20920,17 @@ module stdlib_linalg_lapack_z ! in a(i:n,1:i-1) ip = -ipiv( i ) ip2 = -ipiv( i+1 ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_zswap( i-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_zswap( i-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda ) end if if( ip2/=(i+1) ) then - call stdlib_zswap( i-1, a( i+1, 1 ), lda,a( ip2, 1 ), lda ) + call stdlib${ii}$_zswap( 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) @@ -20936,52 +20939,52 @@ module stdlib_linalg_lapack_z ! in reverse factorization order where i decreases from n to 1 i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then + if( ipiv( i )>0_${ik}$ ) then ! 1-by-1 pivot interchange ! swap rows i and ipiv(i) in a(i:n,1:i-1) ip = ipiv( i ) - if ( i>1 ) then + if ( i>1_${ik}$ ) then if( ip/=i ) then - call stdlib_zswap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) + call stdlib${ii}$_zswap( 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+1) and i and ipiv(i) ! in a(i:n,1:i-1) - i = 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_zswap( i-1, a( ip2, 1 ), lda,a( i+1, 1 ), lda ) + call stdlib${ii}$_zswap( i-1, a( ip2, 1_${ik}$ ), lda,a( i+1, 1_${ik}$ ), lda ) end if if( ip/=i ) then - call stdlib_zswap( i-1, a( ip, 1 ), lda,a( i, 1 ), lda ) + call stdlib${ii}$_zswap( 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_zsyconvf_rook + end subroutine stdlib${ii}$_zsyconvf_rook - pure subroutine stdlib_zsyequb( uplo, n, a, lda, s, scond, amax, work, info ) + pure subroutine stdlib${ii}$_zsyequb( uplo, n, a, lda, s, scond, amax, work, info ) !! ZSYEQUB computes row and column scalings intended to equilibrate a !! symmetric matrix A (with respect to the Euclidean norm) and reduce !! its condition number. The scale factors S are computed by the BIN @@ -20993,8 +20996,8 @@ module stdlib_linalg_lapack_z ! -- 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(dp), intent(out) :: amax, scond character, intent(in) :: uplo ! Array Arguments @@ -21003,11 +21006,11 @@ module stdlib_linalg_lapack_z real(dp), intent(out) :: s(*) ! ===================================================================== ! 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(dp) :: avg, std, tol, c0, c1, c2, t, u, si, d, base, smin, smax, smlnum, bignum, & scale, sumsq logical(lk) :: up @@ -21020,22 +21023,22 @@ module stdlib_linalg_lapack_z cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) ) ! 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( 'ZSYEQUB', -info ) + if ( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZSYEQUB', -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 @@ -21102,7 +21105,7 @@ module stdlib_linalg_lapack_z do i = n+1, 2*n work( i ) = s( i-n ) * work( i-n ) - avg end do - call stdlib_zlassq( n, work( n+1 ), 1, scale, sumsq ) + call stdlib${ii}$_zlassq( n, work( n+1 ), 1_${ik}$, scale, sumsq ) std = scale * sqrt( sumsq / n ) if ( std < tol * avg ) goto 999 do i = 1, n @@ -21110,13 +21113,13 @@ module stdlib_linalg_lapack_z si = s( i ) c2 = ( n-1 ) * t c1 = ( n-2 ) * ( real( work( i ),KIND=dp) - t*si ) - c0 = -(t*si)*si + 2 * real( work( i ),KIND=dp) * si - n*avg - d = c1*c1 - 4*c0*c2 - if ( d <= 0 ) then - info = -1 + c0 = -(t*si)*si + 2_${ik}$ * real( work( i ),KIND=dp) * 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 @@ -21147,23 +21150,23 @@ module stdlib_linalg_lapack_z end do end do 999 continue - smlnum = stdlib_dlamch( 'SAFEMIN' ) + smlnum = stdlib${ii}$_dlamch( 'SAFEMIN' ) bignum = one / smlnum smin = bignum smax = zero t = one / sqrt( avg ) - base = stdlib_dlamch( 'B' ) + base = stdlib${ii}$_dlamch( '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_zsyequb + end subroutine stdlib${ii}$_zsyequb - pure subroutine stdlib_zsymv( uplo, n, alpha, a, lda, x, incx, beta, y, incy ) + pure subroutine stdlib${ii}$_zsymv( uplo, n, alpha, a, lda, x, incx, beta, y, incy ) !! ZSYMV performs the matrix-vector operation !! y := alpha*A*x + beta*y, !! where alpha and beta are scalars, x and y are n element vectors and @@ -21173,7 +21176,7 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: incx, incy, lda, n + integer(${ik}$), intent(in) :: incx, incy, lda, n complex(dp), intent(in) :: alpha, beta ! Array Arguments complex(dp), intent(in) :: a(lda,*), x(*) @@ -21182,47 +21185,47 @@ module stdlib_linalg_lapack_z ! Local Scalars - integer(ilp) :: i, info, ix, iy, j, jx, jy, kx, ky + integer(${ik}$) :: i, info, ix, iy, j, jx, jy, kx, ky complex(dp) :: temp1, temp2 ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) 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 )*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 )*incy end if ! start the operations. in this version the elements of a are ! accessed sequentially with cone pass through the triangular part ! of a. ! first form y := beta*y. if( beta/=cone ) then - if( incy==1 ) then + if( incy==1_${ik}$ ) then if( beta==czero ) then do i = 1, n y( i ) = czero @@ -21250,7 +21253,7 @@ module stdlib_linalg_lapack_z if( alpha==czero )return if( stdlib_lsame( uplo, 'U' ) ) then ! form y when a is stored in upper triangle. - if( ( incx==1 ) .and. ( incy==1 ) ) then + if( ( incx==1_${ik}$ ) .and. ( incy==1_${ik}$ ) ) then do j = 1, n temp1 = alpha*x( j ) temp2 = czero @@ -21281,7 +21284,7 @@ module stdlib_linalg_lapack_z end if else ! form y when a is stored in lower triangle. - if( ( incx==1 ) .and. ( incy==1 ) ) then + if( ( incx==1_${ik}$ ) .and. ( incy==1_${ik}$ ) ) then do j = 1, n temp1 = alpha*x( j ) temp2 = czero @@ -21314,10 +21317,10 @@ module stdlib_linalg_lapack_z end if end if return - end subroutine stdlib_zsymv + end subroutine stdlib${ii}$_zsymv - pure subroutine stdlib_zsyr( uplo, n, alpha, x, incx, a, lda ) + pure subroutine stdlib${ii}$_zsyr( uplo, n, alpha, x, incx, a, lda ) !! ZSYR performs the symmetric rank 1 operation !! A := alpha*x*x**H + A, !! where alpha is a complex scalar, x is an n element vector and A is an @@ -21327,7 +21330,7 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: incx, lda, n + integer(${ik}$), intent(in) :: incx, lda, n complex(dp), intent(in) :: alpha ! Array Arguments complex(dp), intent(inout) :: a(lda,*) @@ -21335,40 +21338,40 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! Local Scalars - integer(ilp) :: i, info, ix, j, jx, kx + integer(${ik}$) :: i, info, ix, j, jx, kx complex(dp) :: temp ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = 1 - else if( n<0 ) then - info = 2 - else if( incx==0 ) then - info = 5 - else if( lda1 ) then - imax = stdlib_izamax( k-1, a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_izamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ ) colmax = cabs1( a( imax, k ) ) else colmax = zero end if - if( max( absakk, colmax )==zero .or. stdlib_disnan(absakk) ) then + if( max( absakk, colmax )==zero .or. stdlib${ii}$_disnan(absakk) ) then ! column k is zero or underflow, or contains a nan: ! set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k else if( absakk>=alpha*colmax ) then @@ -21574,10 +21577,10 @@ module stdlib_linalg_lapack_z else ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value - jmax = imax + stdlib_izamax( k-imax, a( imax, imax+1 ), lda ) + jmax = imax + stdlib${ii}$_izamax( k-imax, a( imax, imax+1 ), lda ) rowmax = cabs1( a( imax, jmax ) ) - if( imax>1 ) then - jmax = stdlib_izamax( imax-1, a( 1, imax ), 1 ) + if( imax>1_${ik}$ ) then + jmax = stdlib${ii}$_izamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ ) rowmax = max( rowmax, cabs1( a( jmax, imax ) ) ) end if if( absakk>=alpha*colmax*( colmax / rowmax ) ) then @@ -21591,35 +21594,35 @@ module stdlib_linalg_lapack_z ! interchange rows and columns k-1 and imax, use 2-by-2 ! pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ end if end if - 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) - call stdlib_zswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) - call stdlib_zswap( kk-kp-1, a( kp+1, kk ), 1, a( kp, kp+1 ),lda ) + call stdlib${ii}$_zswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + call stdlib${ii}$_zswap( kk-kp-1, a( kp+1, kk ), 1_${ik}$, a( kp, kp+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t - if( kstep==2 ) 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 + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u ! perform a rank-1 update of a(1:k-1,1:k-1) as ! a := a - u(k)*d(k)*u(k)**t = a - w(k)*1/d(k)*w(k)**t r1 = cone / a( k, k ) - call stdlib_zsyr( uplo, k-1, -r1, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_zsyr( uplo, k-1, -r1, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) ! store u(k) in column k - call stdlib_zscal( k-1, r1, a( 1, k ), 1 ) + call stdlib${ii}$_zscal( k-1, r1, a( 1_${ik}$, k ), 1_${ik}$ ) else ! 2-by-2 pivot block d(k): columns k and k-1 now hold ! ( w(k-1) w(k) ) = ( u(k-1) u(k) )*d(k) @@ -21628,7 +21631,7 @@ module stdlib_linalg_lapack_z ! perform a rank-2 update of a(1:k-2,1:k-2) as ! a := a - ( u(k-1) u(k) )*d(k)*( u(k-1) u(k) )**t ! = a - ( w(k-1) w(k) )*inv(d(k))*( w(k-1) w(k) )**t - 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 @@ -21647,7 +21650,7 @@ module stdlib_linalg_lapack_z 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 @@ -21660,11 +21663,11 @@ module stdlib_linalg_lapack_z ! 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 = 1_${ik}$ 40 continue ! if k > n, exit from loop if( k>n )go to 70 - 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 absakk = cabs1( a( k, k ) ) @@ -21672,15 +21675,15 @@ module stdlib_linalg_lapack_z ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( k=alpha*colmax ) then @@ -21689,10 +21692,10 @@ module stdlib_linalg_lapack_z else ! jmax is the column-index of the largest off-diagonal ! element in row imax, and rowmax is its absolute value - jmax = k - 1 + stdlib_izamax( imax-k, a( imax, k ), lda ) + jmax = k - 1_${ik}$ + stdlib${ii}$_izamax( imax-k, a( imax, k ), lda ) rowmax = cabs1( a( imax, jmax ) ) if( imax=alpha*colmax*( colmax / rowmax ) ) then @@ -21706,27 +21709,27 @@ module stdlib_linalg_lapack_z ! interchange rows and columns k+1 and imax, use 2-by-2 ! pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ end if end if - 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( kp1 ) then - imax = stdlib_izamax( k-1, a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_izamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ ) colmax = cabs1( a( imax, k ) ) else colmax = zero end if if( (max( absakk, colmax )==zero) ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k ! set e( k ) to zero - if( k>1 )e( k ) = czero + if( k>1_${ik}$ )e( k ) = czero else ! test for interchange ! equivalent to testing for (used to handle nan and inf) @@ -21885,13 +21888,13 @@ module stdlib_linalg_lapack_z ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = imax + stdlib_izamax( k-imax, a( imax, imax+1 ),lda ) + jmax = imax + stdlib${ii}$_izamax( k-imax, a( imax, imax+1 ),lda ) rowmax = cabs1( a( imax, jmax ) ) else rowmax = zero end if - if( imax>1 ) then - itemp = stdlib_izamax( imax-1, a( 1, imax ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_izamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ ) dtemp = cabs1( a( itemp, imax ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -21911,7 +21914,7 @@ module stdlib_linalg_lapack_z ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found, set variables and repeat @@ -21924,45 +21927,45 @@ module stdlib_linalg_lapack_z end if ! swap two rows and two columns ! first swap - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! interchange rows and column k and p in the leading ! submatrix a(1:k,1:k) if we have a 2-by-2 pivot - if( p>1 )call stdlib_zswap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) - if( p<(k-1) )call stdlib_zswap( k-p-1, a( p+1, k ), 1, a( p, p+1 ),lda ) + if( p>1_${ik}$ )call stdlib${ii}$_zswap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) + if( p<(k-1) )call stdlib${ii}$_zswap( k-p-1, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda ) t = a( k, k ) a( k, k ) = a( p, p ) a( p, p ) = t ! convert upper triangle of a into u form by applying ! the interchanges in columns k+1:n. - if( k1 )call stdlib_zswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) - if( ( kk>1 ) .and. ( kp<(kk-1) ) )call stdlib_zswap( kk-kp-1, a( kp+1, kk ), & - 1, a( kp, kp+1 ),lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_zswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + if( ( kk>1_${ik}$ ) .and. ( kp<(kk-1) ) )call stdlib${ii}$_zswap( kk-kp-1, a( kp+1, kk ), & + 1_${ik}$, a( kp, kp+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t - if( kstep==2 ) 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 + if( k>1_${ik}$ ) then ! perform a rank-1 update of a(1:k-1,1:k-1) and ! store u(k) in column k if( cabs1( a( k, k ) )>=sfmin ) then @@ -21970,9 +21973,9 @@ module stdlib_linalg_lapack_z ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*1/d(k)*w(k)**t d11 = cone / a( k, k ) - call stdlib_zsyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_zsyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) ! store u(k) in column k - call stdlib_zscal( k-1, d11, a( 1, k ), 1 ) + call stdlib${ii}$_zscal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = a( k, k ) @@ -21983,7 +21986,7 @@ module stdlib_linalg_lapack_z ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_zsyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_zsyr( 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 ) = czero @@ -21997,7 +22000,7 @@ module stdlib_linalg_lapack_z ! 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 @@ -22023,7 +22026,7 @@ module stdlib_linalg_lapack_z ! 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 @@ -22039,11 +22042,11 @@ module stdlib_linalg_lapack_z e( n ) = czero ! k is the main loop index, increasing from 1 to n in steps of ! 1 or 2 - k = 1 + 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 @@ -22052,14 +22055,14 @@ module stdlib_linalg_lapack_z ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( krowmax ) then rowmax = dtemp @@ -22105,7 +22108,7 @@ module stdlib_linalg_lapack_z ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found, set variables and repeat @@ -22118,42 +22121,42 @@ module stdlib_linalg_lapack_z end if ! swap two rows and two columns ! first swap - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! interchange rows and column k and p in the trailing ! submatrix a(k:n,k:n) if we have a 2-by-2 pivot - if( p(k+1) )call stdlib_zswap( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) + if( p(k+1) )call stdlib${ii}$_zswap( p-k-1, a( k+1, k ), 1_${ik}$, a( p, k+1 ), lda ) t = a( k, k ) a( k, k ) = a( p, p ) a( p, p ) = t ! convert lower triangle of a into l form by applying ! the interchanges in columns 1:k-1. - if ( k>1 )call stdlib_zswap( k-1, a( k, 1 ), lda, a( p, 1 ), lda ) + if ( k>1_${ik}$ )call stdlib${ii}$_zswap( 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_zswap( kp-kk-1, a( kk+1, kk ), & - 1, a( kp, kk+1 ),lda ) + if( ( kk(kk+1) ) )call stdlib${ii}$_zswap( kp-kk-1, a( kk+1, kk ), & + 1_${ik}$, a( kp, kk+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t - if( kstep==2 ) 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_zswap( k-1, a( kk, 1 ), lda, a( kp, 1 ), lda ) + if ( k>1_${ik}$ )call stdlib${ii}$_zswap( k-1, a( kk, 1_${ik}$ ), lda, a( kp, 1_${ik}$ ), lda ) end if ! update the trailing submatrix - if( kstep==1 ) then + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = l(k)*d(k) ! where l(k) is the k-th column of l @@ -22165,10 +22168,10 @@ module stdlib_linalg_lapack_z ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t d11 = cone / a( k, k ) - call stdlib_zsyr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_zsyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda ) ! store l(k) in column k - call stdlib_zscal( n-k, d11, a( k+1, k ), 1 ) + call stdlib${ii}$_zscal( n-k, d11, a( k+1, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = a( k, k ) @@ -22179,7 +22182,7 @@ module stdlib_linalg_lapack_z ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_zsyr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_zsyr( 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 @@ -22222,7 +22225,7 @@ module stdlib_linalg_lapack_z ! 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 @@ -22234,10 +22237,10 @@ module stdlib_linalg_lapack_z 64 continue end if return - end subroutine stdlib_zsytf2_rk + end subroutine stdlib${ii}$_zsytf2_rk - pure subroutine stdlib_zsytf2_rook( uplo, n, a, lda, ipiv, info ) + pure subroutine stdlib${ii}$_zsytf2_rook( uplo, n, a, lda, ipiv, info ) !! ZSYTF2_ROOK computes the factorization of a complex symmetric matrix A !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method: !! A = U*D*U**T or A = L*D*L**T @@ -22250,10 +22253,10 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(inout) :: a(lda,*) ! ===================================================================== ! Parameters @@ -22263,7 +22266,7 @@ module stdlib_linalg_lapack_z ! 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(dp) :: absakk, alpha, colmax, rowmax, dtemp, sfmin complex(dp) :: d11, d12, d21, d22, t, wk, wkm1, wkp1, z ! Intrinsic Functions @@ -22274,23 +22277,23 @@ module stdlib_linalg_lapack_z cabs1( z ) = abs( real( z,KIND=dp) ) + abs( aimag( z ) ) ! 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_izamax( k-1, a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + imax = stdlib${ii}$_izamax( k-1, a( 1_${ik}$, k ), 1_${ik}$ ) colmax = cabs1( a( imax, k ) ) else colmax = zero end if if( (max( absakk, colmax )==zero) ) then ! column k is zero or underflow: set info and continue - if( info==0 )info = k + if( info==0_${ik}$ )info = k kp = k else ! test for interchange @@ -22334,13 +22337,13 @@ module stdlib_linalg_lapack_z ! element in row imax, and rowmax is its absolute value. ! determine both rowmax and jmax. if( imax/=k ) then - jmax = imax + stdlib_izamax( k-imax, a( imax, imax+1 ),lda ) + jmax = imax + stdlib${ii}$_izamax( k-imax, a( imax, imax+1 ),lda ) rowmax = cabs1( a( imax, jmax ) ) else rowmax = zero end if - if( imax>1 ) then - itemp = stdlib_izamax( imax-1, a( 1, imax ), 1 ) + if( imax>1_${ik}$ ) then + itemp = stdlib${ii}$_izamax( imax-1, a( 1_${ik}$, imax ), 1_${ik}$ ) dtemp = cabs1( a( itemp, imax ) ) if( dtemp>rowmax ) then rowmax = dtemp @@ -22360,7 +22363,7 @@ module stdlib_linalg_lapack_z ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found, set variables and repeat @@ -22373,39 +22376,39 @@ module stdlib_linalg_lapack_z end if ! swap two rows and two columns ! first swap - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! interchange rows and column k and p in the leading ! submatrix a(1:k,1:k) if we have a 2-by-2 pivot - if( p>1 )call stdlib_zswap( p-1, a( 1, k ), 1, a( 1, p ), 1 ) - if( p<(k-1) )call stdlib_zswap( k-p-1, a( p+1, k ), 1, a( p, p+1 ),lda ) + if( p>1_${ik}$ )call stdlib${ii}$_zswap( p-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ ) + if( p<(k-1) )call stdlib${ii}$_zswap( k-p-1, a( p+1, k ), 1_${ik}$, a( p, p+1 ),lda ) t = a( k, k ) a( k, k ) = a( p, p ) a( p, p ) = t end if ! second swap - kk = k - kstep + 1 + 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_zswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) - if( ( kk>1 ) .and. ( kp<(kk-1) ) )call stdlib_zswap( kk-kp-1, a( kp+1, kk ), & - 1, a( kp, kp+1 ),lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_zswap( kp-1, a( 1_${ik}$, kk ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + if( ( kk>1_${ik}$ ) .and. ( kp<(kk-1) ) )call stdlib${ii}$_zswap( kk-kp-1, a( kp+1, kk ), & + 1_${ik}$, a( kp, kp+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t - if( kstep==2 ) 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 + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = u(k)*d(k) ! where u(k) is the k-th column of u - if( k>1 ) then + if( k>1_${ik}$ ) then ! perform a rank-1 update of a(1:k-1,1:k-1) and ! store u(k) in column k if( cabs1( a( k, k ) )>=sfmin ) then @@ -22413,9 +22416,9 @@ module stdlib_linalg_lapack_z ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*1/d(k)*w(k)**t d11 = cone / a( k, k ) - call stdlib_zsyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_zsyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) ! store u(k) in column k - call stdlib_zscal( k-1, d11, a( 1, k ), 1 ) + call stdlib${ii}$_zscal( k-1, d11, a( 1_${ik}$, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = a( k, k ) @@ -22426,7 +22429,7 @@ module stdlib_linalg_lapack_z ! a := a - u(k)*d(k)*u(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_zsyr( uplo, k-1, -d11, a( 1, k ), 1, a, lda ) + call stdlib${ii}$_zsyr( uplo, k-1, -d11, a( 1_${ik}$, k ), 1_${ik}$, a, lda ) end if end if else @@ -22438,7 +22441,7 @@ module stdlib_linalg_lapack_z ! 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 @@ -22458,7 +22461,7 @@ module stdlib_linalg_lapack_z 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 @@ -22471,11 +22474,11 @@ module stdlib_linalg_lapack_z ! 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 = 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 @@ -22484,14 +22487,14 @@ module stdlib_linalg_lapack_z ! column k, and colmax is its absolute value. ! determine both colmax and imax. if( krowmax ) then rowmax = dtemp @@ -22535,7 +22538,7 @@ module stdlib_linalg_lapack_z ! interchange rows and columns k+1 and imax, ! use 2-by-2 pivot block kp = imax - kstep = 2 + kstep = 2_${ik}$ done = .true. else ! pivot not found, set variables and repeat @@ -22548,36 +22551,36 @@ module stdlib_linalg_lapack_z end if ! swap two rows and two columns ! first swap - if( ( kstep==2 ) .and. ( p/=k ) ) then + if( ( kstep==2_${ik}$ ) .and. ( p/=k ) ) then ! interchange rows and column k and p in the trailing ! submatrix a(k:n,k:n) if we have a 2-by-2 pivot - if( p(k+1) )call stdlib_zswap( p-k-1, a( k+1, k ), 1, a( p, k+1 ), lda ) + if( p(k+1) )call stdlib${ii}$_zswap( p-k-1, a( k+1, k ), 1_${ik}$, a( p, k+1 ), lda ) t = a( k, k ) a( k, k ) = a( p, p ) a( p, p ) = t end if ! second swap - kk = k + kstep - 1 + 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_zswap( kp-kk-1, a( kk+1, kk ), & - 1, a( kp, kk+1 ),lda ) + if( ( kk(kk+1) ) )call stdlib${ii}$_zswap( kp-kk-1, a( kk+1, kk ), & + 1_${ik}$, a( kp, kk+1 ),lda ) t = a( kk, kk ) a( kk, kk ) = a( kp, kp ) a( kp, kp ) = t - if( kstep==2 ) 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 + if( kstep==1_${ik}$ ) then ! 1-by-1 pivot block d(k): column k now holds ! w(k) = l(k)*d(k) ! where l(k) is the k-th column of l @@ -22589,10 +22592,10 @@ module stdlib_linalg_lapack_z ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t d11 = cone / a( k, k ) - call stdlib_zsyr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_zsyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda ) ! store l(k) in column k - call stdlib_zscal( n-k, d11, a( k+1, k ), 1 ) + call stdlib${ii}$_zscal( n-k, d11, a( k+1, k ), 1_${ik}$ ) else ! store l(k) in column k d11 = a( k, k ) @@ -22603,7 +22606,7 @@ module stdlib_linalg_lapack_z ! a := a - l(k)*d(k)*l(k)**t ! = a - w(k)*(1/d(k))*w(k)**t ! = a - (w(k)/d(k))*(d(k))*(w(k)/d(k))**t - call stdlib_zsyr( uplo, n-k, -d11, a( k+1, k ), 1,a( k+1, k+1 ), lda ) + call stdlib${ii}$_zsyr( uplo, n-k, -d11, a( k+1, k ), 1_${ik}$,a( k+1, k+1 ), lda ) end if end if @@ -22638,7 +22641,7 @@ module stdlib_linalg_lapack_z 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 @@ -22650,10 +22653,10 @@ module stdlib_linalg_lapack_z end if 70 continue return - end subroutine stdlib_zsytf2_rook + end subroutine stdlib${ii}$_zsytf2_rook - pure subroutine stdlib_zsytrf( uplo, n, a, lda, ipiv, work, lwork, info ) + pure subroutine stdlib${ii}$_zsytrf( uplo, n, a, lda, ipiv, work, lwork, info ) !! ZSYTRF computes the factorization of a complex symmetric matrix A !! using the Bunch-Kaufman diagonal pivoting method. The form of the !! factorization is @@ -22667,60 +22670,60 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), 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_zlasyf( uplo, k, nb, kb, a, lda, ipiv, work, n, iinfo ) + call stdlib${ii}$_zlasyf( uplo, k, nb, kb, a, lda, ipiv, work, n, iinfo ) else ! use unblocked code to factorize columns 1:k of a - call stdlib_zsytf2( uplo, k, a, lda, ipiv, iinfo ) + call stdlib${ii}$_zsytf2( 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 ! 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_zlasyf; + ! kb, where kb is the number of columns factorized by stdlib${ii}$_zlasyf; ! 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_zlasyf( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, n, & + call stdlib${ii}$_zlasyf( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, n, & iinfo ) else ! use unblocked code to factorize columns k:n of a - call stdlib_zsytf2( uplo, n-k+1, a( k, k ), lda, ipiv( k ), iinfo ) - kb = n - k + 1 + call stdlib${ii}$_zsytf2( 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 @@ -22774,12 +22777,12 @@ module stdlib_linalg_lapack_z go to 20 end if 40 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_zsytrf + end subroutine stdlib${ii}$_zsytrf - pure subroutine stdlib_zsytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) + pure subroutine stdlib${ii}$_zsytrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) !! ZSYTRF_RK computes the factorization of a complex symmetric matrix A !! using the bounded Bunch-Kaufman (rook) diagonal pivoting method: !! A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), @@ -22794,60 +22797,60 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), 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_zlasyf_rk( uplo, k, nb, kb, a, lda, e,ipiv, work, ldwork, iinfo ) + call stdlib${ii}$_zlasyf_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_zsytf2_rk( uplo, k, a, lda, e, ipiv, iinfo ) + call stdlib${ii}$_zsytf2_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 ! read ipiv from the last block factored, i.e. @@ -22877,7 +22880,7 @@ module stdlib_linalg_lapack_z do i = k, ( k - kb + 1 ), -1 ip = abs( ipiv( i ) ) if( ip/=i ) then - call stdlib_zswap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda ) + call stdlib${ii}$_zswap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda ) end if end do end if @@ -22890,31 +22893,31 @@ module stdlib_linalg_lapack_z 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_zlasyf_rk; + ! kb, where kb is the number of columns factorized by stdlib${ii}$_zlasyf_rk; ! 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 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_zlasyf_rk( uplo, n-k+1, nb, kb, a( k, k ), lda, e( k ),ipiv( k ), & + call stdlib${ii}$_zlasyf_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_zsytf2_rk( uplo, n-k+1, a( k, k ), lda, e( k ),ipiv( k ), iinfo ) + call stdlib${ii}$_zsytf2_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 @@ -22924,11 +22927,11 @@ module stdlib_linalg_lapack_z ! (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 + if( k>1_${ik}$ ) then do i = k, ( k + kb - 1 ), 1 ip = abs( ipiv( i ) ) if( ip/=i ) then - call stdlib_zswap( k-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_zswap( k-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda ) end if end do end if @@ -22940,12 +22943,12 @@ module stdlib_linalg_lapack_z 35 continue ! end lower end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_zsytrf_rk + end subroutine stdlib${ii}$_zsytrf_rk - pure subroutine stdlib_zsytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) + pure subroutine stdlib${ii}$_zsytrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) !! ZSYTRF_ROOK computes the factorization of a complex symmetric matrix A !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. !! The form of the factorization is @@ -22959,60 +22962,60 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), 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_zlasyf_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo ) + call stdlib${ii}$_zlasyf_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo ) else ! use unblocked code to factorize columns 1:k of a - call stdlib_zsytf2_rook( uplo, k, a, lda, ipiv, iinfo ) + call stdlib${ii}$_zsytf2_rook( uplo, k, a, lda, ipiv, iinfo ) kb = k end if ! set info on the first occurrence of a zero pivot - if( info==0 .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 @@ -23037,30 +23040,30 @@ module stdlib_linalg_lapack_z 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_zlasyf_rook; + ! kb, where kb is the number of columns factorized by stdlib${ii}$_zlasyf_rook; ! kb is either nb or nb-1, or n-k+1 for the last block - k = 1 + 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_zlasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, & + call stdlib${ii}$_zlasyf_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, & ldwork, iinfo ) else ! use unblocked code to factorize columns k:n of a - call stdlib_zsytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo ) - kb = n - k + 1 + call stdlib${ii}$_zsytf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo ) + kb = n - k + 1_${ik}$ end if ! set info on the first occurrence of a zero pivot - if( info==0 .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 @@ -23068,12 +23071,12 @@ module stdlib_linalg_lapack_z go to 20 end if 40 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_zsytrf_rook + end subroutine stdlib${ii}$_zsytrf_rook - pure subroutine stdlib_zsytri( uplo, n, a, lda, ipiv, work, info ) + pure subroutine stdlib${ii}$_zsytri( uplo, n, a, lda, ipiv, work, info ) !! ZSYTRI computes the inverse of a complex symmetric indefinite matrix !! A using the factorization A = U*D*U**T or A = L*D*L**T computed by !! ZSYTRF. @@ -23082,33 +23085,33 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: k, kp, kstep + integer(${ik}$) :: k, kp, kstep complex(dp) :: 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 )==czero )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 = 1_${ik}$ 30 continue ! if k > n, exit from loop. if( k>n )go to 40 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = cone / a( k, k ) ! compute column k of the inverse. - if( k>1 ) then - call stdlib_zcopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_zsymv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_zcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_zsymv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - stdlib_zdotu( k-1, work, 1, a( 1, k ),1 ) + a( k, k ) = a( k, k ) - stdlib${ii}$_zdotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ ) end if - kstep = 1 + kstep = 1_${ik}$ else ! 2 x 2 diagonal block ! invert the diagonal block. @@ -23158,31 +23161,31 @@ module stdlib_linalg_lapack_z 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_zcopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_zsymv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_zcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_zsymv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - stdlib_zdotu( k-1, work, 1, a( 1, k ),1 ) - a( k, k+1 ) = a( k, k+1 ) -stdlib_zdotu( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) + a( k, k ) = a( k, k ) - stdlib${ii}$_zdotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ ) + a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_zdotu( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) - call stdlib_zcopy( k-1, a( 1, k+1 ), 1, work, 1 ) - call stdlib_zsymv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k+1 ), 1 ) + call stdlib${ii}$_zcopy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_zsymv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k+1 ), 1_${ik}$ ) - a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib_zdotu( k-1, work, 1, a( 1, k+1 ), 1 ) + a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib${ii}$_zdotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) end if - kstep = 2 + 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_zswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_zswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + call stdlib${ii}$_zswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + call stdlib${ii}$_zswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp - 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 @@ -23199,18 +23202,18 @@ module stdlib_linalg_lapack_z 50 continue ! if k < 1, exit from loop. if( k<1 )go to 60 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = cone / a( k, k ) ! compute column k of the inverse. if( k0 .and. a( info, info )==czero )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 = 1_${ik}$ 30 continue ! if k > n, exit from loop. if( k>n )go to 40 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = cone / a( k, k ) ! compute column k of the inverse. - if( k>1 ) then - call stdlib_zcopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_zsymv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_zcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_zsymv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - stdlib_zdotu( k-1, work, 1, a( 1, k ),1 ) + a( k, k ) = a( k, k ) - stdlib${ii}$_zdotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ ) end if - kstep = 1 + kstep = 1_${ik}$ else ! 2 x 2 diagonal block ! invert the diagonal block. @@ -23346,28 +23349,28 @@ module stdlib_linalg_lapack_z 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_zcopy( k-1, a( 1, k ), 1, work, 1 ) - call stdlib_zsymv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_zcopy( k-1, a( 1_${ik}$, k ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_zsymv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k ), 1_${ik}$ ) - a( k, k ) = a( k, k ) - stdlib_zdotu( k-1, work, 1, a( 1, k ),1 ) - a( k, k+1 ) = a( k, k+1 ) -stdlib_zdotu( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) + a( k, k ) = a( k, k ) - stdlib${ii}$_zdotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k ),1_${ik}$ ) + a( k, k+1 ) = a( k, k+1 ) -stdlib${ii}$_zdotu( k-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) - call stdlib_zcopy( k-1, a( 1, k+1 ), 1, work, 1 ) - call stdlib_zsymv( uplo, k-1, -cone, a, lda, work, 1, czero,a( 1, k+1 ), 1 ) + call stdlib${ii}$_zcopy( k-1, a( 1_${ik}$, k+1 ), 1_${ik}$, work, 1_${ik}$ ) + call stdlib${ii}$_zsymv( uplo, k-1, -cone, a, lda, work, 1_${ik}$, czero,a( 1_${ik}$, k+1 ), 1_${ik}$ ) - a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib_zdotu( k-1, work, 1, a( 1, k+1 ), 1 ) + a( k+1, k+1 ) = a( k+1, k+1 ) -stdlib${ii}$_zdotu( k-1, work, 1_${ik}$, a( 1_${ik}$, k+1 ), 1_${ik}$ ) end if - kstep = 2 + 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) kp = ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_zswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_zswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_zswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + call stdlib${ii}$_zswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp @@ -23377,8 +23380,8 @@ module stdlib_linalg_lapack_z ! -ipiv(k+1)in the leading submatrix a(1:k+1,1:k+1) kp = -ipiv( k ) if( kp/=k ) then - if( kp>1 )call stdlib_zswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_zswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_zswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + call stdlib${ii}$_zswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp @@ -23386,17 +23389,17 @@ module stdlib_linalg_lapack_z 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_zswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) - call stdlib_zswap( k-kp-1, a( kp+1, k ), 1, a( kp, kp+1 ), lda ) + if( kp>1_${ik}$ )call stdlib${ii}$_zswap( kp-1, a( 1_${ik}$, k ), 1_${ik}$, a( 1_${ik}$, kp ), 1_${ik}$ ) + call stdlib${ii}$_zswap( k-kp-1, a( kp+1, k ), 1_${ik}$, a( kp, kp+1 ), lda ) temp = a( k, k ) a( k, k ) = a( kp, kp ) a( kp, kp ) = temp end if end if - k = k + 1 + k = k + 1_${ik}$ go to 30 40 continue else @@ -23407,18 +23410,18 @@ module stdlib_linalg_lapack_z 50 continue ! if k < 1, exit from loop. if( k<1 )go to 60 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! invert the diagonal block. a( k, k ) = cone / a( k, k ) ! compute column k of the inverse. if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_zgeru( k-1, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & + call stdlib${ii}$_zgeru( k-1, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb & ) ! multiply by the inverse of the diagonal block. - call stdlib_zscal( nrhs, cone / a( k, k ), b( k, 1 ), ldb ) - k = k - 1 + call stdlib${ii}$_zscal( nrhs, cone / a( k, k ), b( k, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( kp/=k-1 )call stdlib_zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib${ii}$_zswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - call stdlib_zgeru( k-2, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & + call stdlib${ii}$_zgeru( k-2, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb & ) - call stdlib_zgeru( k-2, nrhs, -cone, a( 1, k-1 ), 1, b( k-1, 1 ),ldb, b( 1, 1 ), & + call stdlib${ii}$_zgeru( k-2, nrhs, -cone, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), & ldb ) ! multiply by the inverse of the diagonal block. akm1k = a( k-1, k ) @@ -23575,39 +23578,39 @@ module stdlib_linalg_lapack_z 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 = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(u**t(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, a( 1, k ),1, cone, b( & - k, 1 ), ldb ) + call stdlib${ii}$_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, a( 1_${ik}$, k ),1_${ik}$, cone, b( & + k, 1_${ik}$ ), ldb ) ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 1 + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 1_${ik}$ else ! 2 x 2 diagonal block ! multiply by inv(u**t(k+1)), where u(k+1) is the transformation ! stored in columns k and k+1 of a. - call stdlib_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, a( 1, k ),1, cone, b( & - k, 1 ), ldb ) - call stdlib_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb,a( 1, k+1 ), 1, cone, b(& - k+1, 1 ), ldb ) + call stdlib${ii}$_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb, a( 1_${ik}$, k ),1_${ik}$, cone, b( & + k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b, ldb,a( 1_${ik}$, k+1 ), 1_${ik}$, cone, b(& + k+1, 1_${ik}$ ), ldb ) ! interchange rows k and -ipiv(k). kp = -ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 2 + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 2_${ik}$ end if go to 40 50 continue @@ -23616,34 +23619,34 @@ module stdlib_linalg_lapack_z ! 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 = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(l**t(k)), where l(k) is the transformation ! stored in column k of a. - if( k= 1 ) - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k-1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( kp==-ipiv( k-1 ) )call stdlib_zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb & + if( kp==-ipiv( k-1 ) )call stdlib${ii}$_zswap( 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_ztrsm('L','U','N','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib${ii}$_ztrsm('L','U','N','U',n,nrhs,cone,a,lda,b,ldb) ! compute d \ b -> b [ d \ (u \p**t * b) ] i=n do while ( i >= 1 ) - if( ipiv(i) > 0 ) then - call stdlib_zscal( nrhs, cone / a( i, i ), b( i, 1 ), ldb ) - elseif ( i > 1) then + if( ipiv(i) > 0_${ik}$ ) then + call stdlib${ii}$_zscal( nrhs, cone / 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 @@ -23783,58 +23786,58 @@ module stdlib_linalg_lapack_z 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_ztrsm('L','U','T','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib${ii}$_ztrsm('L','U','T','U',n,nrhs,cone,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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k+1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( k < n .and. kp==-ipiv( k+1 ) )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp,& - 1 ), ldb ) + if( k < n .and. kp==-ipiv( k+1 ) )call stdlib${ii}$_zswap( 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k+1 else ! 2 x 2 diagonal block ! interchange rows k and -ipiv(k+1). kp = -ipiv( k+1 ) - if( kp==-ipiv( k ) )call stdlib_zswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp==-ipiv( k ) )call stdlib${ii}$_zswap( 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_ztrsm('L','L','N','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib${ii}$_ztrsm('L','L','N','U',n,nrhs,cone,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_zscal( nrhs, cone / a( i, i ), b( i, 1 ), ldb ) + if( ipiv(i) > 0_${ik}$ ) then + call stdlib${ii}$_zscal( nrhs, cone / a( i, i ), b( i, 1_${ik}$ ), ldb ) else akm1k = work(i) akm1 = a( i, i ) / akm1k @@ -23846,38 +23849,38 @@ module stdlib_linalg_lapack_z 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_ztrsm('L','L','T','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib${ii}$_ztrsm('L','L','T','U',n,nrhs,cone,a,lda,b,ldb) ! p * b [ p * (l**t \ (d \ (l \p**t * b) )) ] k=n do while ( k >= 1 ) - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k-1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( k>1 .and. kp==-ipiv( k-1 ) )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, & - 1 ), ldb ) + if( k>1_${ik}$ .and. kp==-ipiv( k-1 ) )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, & + 1_${ik}$ ), ldb ) k=k-2 endif end do end if ! revert a - call stdlib_zsyconv( uplo, 'R', n, a, lda, ipiv, work, iinfo ) + call stdlib${ii}$_zsyconv( uplo, 'R', n, a, lda, ipiv, work, iinfo ) return - end subroutine stdlib_zsytrs2 + end subroutine stdlib${ii}$_zsytrs2 - pure subroutine stdlib_zsytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) + pure subroutine stdlib${ii}$_zsytrs_3( uplo, n, nrhs, a, lda, e, ipiv, b, ldb,info ) !! ZSYTRS_3 solves a system of linear equations A * X = B with a complex !! symmetric matrix A using the factorization computed !! by ZSYTRF_RK or ZSYTRF_BK: @@ -23892,36 +23895,36 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(in) :: a(lda,*), e(*) complex(dp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: i, j, k, kp + integer(${ik}$) :: i, j, k, kp complex(dp) :: 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_ztrsm( 'L', 'U', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib${ii}$_ztrsm( 'L', 'U', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) ! compute d \ b -> b [ d \ (u \p**t * b) ] i = n do while ( i>=1 ) - if( ipiv( i )>0 ) then - call stdlib_zscal( nrhs, cone / a( i, i ), b( i, 1 ), ldb ) - else if ( i>1 ) then + if( ipiv( i )>0_${ik}$ ) then + call stdlib${ii}$_zscal( nrhs, cone / 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 @@ -23959,12 +23962,12 @@ module stdlib_linalg_lapack_z 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_ztrsm( 'L', 'U', 'T', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib${ii}$_ztrsm( 'L', 'U', 'T', 'U', n, nrhs, cone, a, lda, b, ldb ) ! p * b [ p * (u**t \ (d \ (u \p**t * b) )) ] ! interchange rows k and ipiv(k) of matrix b in reverse order ! from the formation order of ipiv(i) vector for upper case. @@ -23974,7 +23977,7 @@ module stdlib_linalg_lapack_z do k = 1, n, 1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end if end do else @@ -23989,16 +23992,16 @@ module stdlib_linalg_lapack_z do k = 1, n, 1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib${ii}$_zswap( 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_ztrsm( 'L', 'L', 'N', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib${ii}$_ztrsm( 'L', 'L', 'N', 'U', n, nrhs, cone, 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_zscal( nrhs, cone / a( i, i ), b( i, 1 ), ldb ) + if( ipiv( i )>0_${ik}$ ) then + call stdlib${ii}$_zscal( nrhs, cone / a( i, i ), b( i, 1_${ik}$ ), ldb ) else if( i b [ l**t \ (d \ (l \p**t * b) ) ] - call stdlib_ztrsm('L', 'L', 'T', 'U', n, nrhs, cone, a, lda, b, ldb ) + call stdlib${ii}$_ztrsm('L', 'L', 'T', 'U', n, nrhs, cone, a, lda, b, ldb ) ! p * b [ p * (l**t \ (d \ (l \p**t * b) )) ] ! interchange rows k and ipiv(k) of matrix b in reverse order ! from the formation order of ipiv(i) vector for lower case. @@ -24025,16 +24028,16 @@ module stdlib_linalg_lapack_z do k = n, 1, -1 kp = abs( ipiv( k ) ) if( kp/=k ) then - call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end if end do ! end lower end if return - end subroutine stdlib_zsytrs_3 + end subroutine stdlib${ii}$_zsytrs_3 - pure subroutine stdlib_zsytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) + pure subroutine stdlib${ii}$_zsytrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) !! ZSYTRS_AA solves a system of linear equations A*X = B with a complex !! symmetric matrix A using the factorization A = U**T*T*U or !! A = L*T*L**T computed by ZSYTRF_AA. @@ -24044,42 +24047,42 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(in) :: a(lda,*) complex(dp), intent(inout) :: b(ldb,*) complex(dp), 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 + if( n>1_${ik}$ ) then ! pivot, p**t * b -> b do k = 1, n kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end do ! compute u**t \ b -> b [ (u**t \p**t * b) ] - call stdlib_ztrsm( 'L', 'U', 'T', 'U', n-1, nrhs, cone, a( 1, 2 ),lda, b( 2, 1 ),& + call stdlib${ii}$_ztrsm( 'L', 'U', 'T', 'U', n-1, nrhs, cone, a( 1_${ik}$, 2_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),& ldb) end if ! 2) solve with triangular matrix t ! compute t \ b -> b [ t \ (u**t \p**t * b) ] - call stdlib_zlacpy( 'F', 1, n, a( 1, 1 ), lda+1, work( n ), 1) - if( n>1 ) then - call stdlib_zlacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 1 ), 1 ) - call stdlib_zlacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 2*n ), 1 ) + call stdlib${ii}$_zlacpy( 'F', 1_${ik}$, n, a( 1_${ik}$, 1_${ik}$ ), lda+1, work( n ), 1_${ik}$) + if( n>1_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'F', 1_${ik}$, n-1, a( 1_${ik}$, 2_${ik}$ ), lda+1, work( 1_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_zlacpy( 'F', 1_${ik}$, n-1, a( 1_${ik}$, 2_${ik}$ ), lda+1, work( 2_${ik}$*n ), 1_${ik}$ ) end if - call stdlib_zgtsv( n, nrhs, work( 1 ), work( n ), work( 2*n ), b, ldb,info ) + call stdlib${ii}$_zgtsv( n, nrhs, work( 1_${ik}$ ), work( n ), work( 2_${ik}$*n ), b, ldb,info ) ! 3) backward substitution with u - if( n>1 ) then + if( n>1_${ik}$ ) then ! compute u \ b -> b [ u \ (t \ (u**t \p**t * b) ) ] - call stdlib_ztrsm( 'L', 'U', 'N', 'U', n-1, nrhs, cone, a( 1, 2 ),lda, b( 2, 1 ),& + call stdlib${ii}$_ztrsm( 'L', 'U', 'N', 'U', n-1, nrhs, cone, a( 1_${ik}$, 2_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),& ldb) ! pivot, p * b -> b [ p * (u \ (t \ (u**t \p**t * b) )) ] do k = n, 1, -1 kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end do end if else ! solve a*x = b, where a = l*t*l**t. ! 1) forward substitution with l - if( n>1 ) then + if( n>1_${ik}$ ) then ! pivot, p**t * b -> b do k = 1, n kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end do ! compute l \ b -> b [ (l \p**t * b) ] - call stdlib_ztrsm( 'L', 'L', 'N', 'U', n-1, nrhs, cone, a( 2, 1 ),lda, b( 2, 1 ),& + call stdlib${ii}$_ztrsm( 'L', 'L', 'N', 'U', n-1, nrhs, cone, a( 2_${ik}$, 1_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),& ldb) end if ! 2) solve with triangular matrix t ! compute t \ b -> b [ t \ (l \p**t * b) ] - call stdlib_zlacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1) - if( n>1 ) then - call stdlib_zlacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 1 ), 1 ) - call stdlib_zlacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 2*n ), 1 ) + call stdlib${ii}$_zlacpy( 'F', 1_${ik}$, n, a(1_${ik}$, 1_${ik}$), lda+1, work(n), 1_${ik}$) + if( n>1_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'F', 1_${ik}$, n-1, a( 2_${ik}$, 1_${ik}$ ), lda+1, work( 1_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_zlacpy( 'F', 1_${ik}$, n-1, a( 2_${ik}$, 1_${ik}$ ), lda+1, work( 2_${ik}$*n ), 1_${ik}$ ) end if - call stdlib_zgtsv( n, nrhs, work( 1 ), work(n), work( 2*n ), b, ldb,info) + call stdlib${ii}$_zgtsv( n, nrhs, work( 1_${ik}$ ), work(n), work( 2_${ik}$*n ), b, ldb,info) ! 3) backward substitution with l**t - if( n>1 ) then + if( n>1_${ik}$ ) then ! compute (l**t \ b) -> b [ l**t \ (t \ (l \p**t * b) ) ] - call stdlib_ztrsm( 'L', 'L', 'T', 'U', n-1, nrhs, cone, a( 2, 1 ),lda, b( 2, 1 ),& + call stdlib${ii}$_ztrsm( 'L', 'L', 'T', 'U', n-1, nrhs, cone, a( 2_${ik}$, 1_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),& ldb) ! pivot, p * b -> b [ p * (l**t \ (t \ (l \p**t * b) )) ] do k = n, 1, -1 kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end do end if end if return - end subroutine stdlib_zsytrs_aa + end subroutine stdlib${ii}$_zsytrs_aa - pure subroutine stdlib_zsytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) + pure subroutine stdlib${ii}$_zsytrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) !! ZSYTRS_ROOK solves a system of linear equations A*X = B with !! a complex symmetric matrix A using the factorization A = U*D*U**T or !! A = L*D*L**T computed by ZSYTRF_ROOK. @@ -24162,36 +24165,36 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(in) :: a(lda,*) complex(dp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: j, k, kp + integer(${ik}$) :: j, k, kp complex(dp) :: 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_zgeru( k-1, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & + call stdlib${ii}$_zgeru( k-1, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb & ) ! multiply by the inverse of the diagonal block. - call stdlib_zscal( nrhs, cone / a( k, k ), b( k, 1 ), ldb ) - k = k - 1 + call stdlib${ii}$_zscal( nrhs, cone / a( k, k ), b( k, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ else ! 2 x 2 diagonal block ! interchange rows k and -ipiv(k) then k-1 and -ipiv(k-1) kp = -ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) kp = -ipiv( k-1 ) - if( kp/=k-1 )call stdlib_zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib${ii}$_zswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - if( k>2 ) then - call stdlib_zgeru( k-2, nrhs,-cone, a( 1, k ), 1, b( k, 1 ),ldb, b( 1, 1 ), & + if( k>2_${ik}$ ) then + call stdlib${ii}$_zgeru( k-2, nrhs,-cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), & ldb ) - call stdlib_zgeru( k-2, nrhs,-cone, a( 1, k-1 ), 1, b( k-1, 1 ),ldb, b( 1, 1 )& + call stdlib${ii}$_zgeru( k-2, nrhs,-cone, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ )& , ldb ) end if ! multiply by the inverse of the diagonal block. @@ -24243,43 +24246,43 @@ module stdlib_linalg_lapack_z 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 = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(u**t(k)), where u(k) is the transformation ! stored in column k of a. - if( k>1 )call stdlib_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), 1, & - cone, b( k, 1 ), ldb ) + if( k>1_${ik}$ )call stdlib${ii}$_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, & + cone, b( k, 1_${ik}$ ), ldb ) ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 1 + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 1_${ik}$ else ! 2 x 2 diagonal block ! multiply by inv(u**t(k+1)), where u(k+1) is the transformation ! stored in columns k and k+1 of a. - if( k>1 ) then - call stdlib_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), 1, cone, & - b( k, 1 ), ldb ) - call stdlib_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k+1 ), 1, cone,& - b( k+1, 1 ), ldb ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), 1_${ik}$, cone, & + b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zgemv( 'TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k+1 ), 1_${ik}$, cone,& + b( k+1, 1_${ik}$ ), ldb ) end if ! interchange rows k and -ipiv(k) then k+1 and -ipiv(k+1). kp = -ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) kp = -ipiv( k+1 ) - if( kp/=k+1 )call stdlib_zswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 2 + if( kp/=k+1 )call stdlib${ii}$_zswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 2_${ik}$ end if go to 40 50 continue @@ -24288,36 +24291,36 @@ module stdlib_linalg_lapack_z ! 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 = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(l**t(k)), where l(k) is the transformation ! stored in column k of a. - if( k 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 + 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 @@ -25289,28 +25292,28 @@ module stdlib_linalg_lapack_z do j = 1 + i, n2 ij = i + j*lda ap( ijp ) = conjg( 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 + ijp = 0_${ik}$ do j = 0, n1 - 1 ij = n2 + j do i = 0, j ap( ijp ) = conjg( 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 @@ -25321,38 +25324,38 @@ module stdlib_linalg_lapack_z ! 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 + ijp = 0_${ik}$ do i = 0, n2 do ij = i*( lda+1 ), n*lda - 1, lda ap( ijp ) = conjg( 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 + 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 ) = conjg( arf( ij ) ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do end do end if @@ -25365,13 +25368,13 @@ module stdlib_linalg_lapack_z ! 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 + 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 @@ -25379,28 +25382,28 @@ module stdlib_linalg_lapack_z do j = i, k - 1 ij = i + j*lda ap( ijp ) = conjg( 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 + ijp = 0_${ik}$ do j = 0, k - 1 - ij = k + 1 + j + ij = k + 1_${ik}$ + j do i = 0, j ap( ijp ) = conjg( 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 @@ -25411,48 +25414,48 @@ module stdlib_linalg_lapack_z ! 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 + ijp = 0_${ik}$ do i = 0, k - 1 do ij = i + ( i+1 )*lda, ( n+1 )*lda - 1, lda ap( ijp ) = conjg( 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 + 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 ) = conjg( arf( ij ) ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do end do end if end if end if return - end subroutine stdlib_ztfttp + end subroutine stdlib${ii}$_ztfttp - pure subroutine stdlib_ztfttr( transr, uplo, n, arf, a, lda, info ) + pure subroutine stdlib${ii}$_ztfttr( transr, uplo, n, arf, a, lda, info ) !! ZTFTTR copies a triangular matrix A from rectangular full packed !! format (TF) to standard full format (TR). ! -- lapack computational routine -- @@ -25460,65 +25463,65 @@ module stdlib_linalg_lapack_z ! -- 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 - complex(dp), intent(out) :: a(0:lda-1,0:*) - complex(dp), intent(in) :: arf(0:*) + complex(dp), intent(out) :: a(0_${ik}$:lda-1,0_${ik}$:*) + complex(dp), intent(in) :: arf(0_${ik}$:*) ! ===================================================================== ! Parameters ! 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 :: conjg,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, 'C' ) ) 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 a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1); lda=n - ij = 0 + ij = 0_${ik}$ do j = 0, n2 do i = n1, n2 + j a( n2+j, i ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do i = j, n - 1 a( i, j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do else @@ -25550,11 +25553,11 @@ module stdlib_linalg_lapack_z do j = n - 1, n1, -1 do i = 0, j a( i, j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do l = j - n1, n1 - 1 a( j-n1, l ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do ij = ij - nx2 end do @@ -25565,42 +25568,42 @@ module stdlib_linalg_lapack_z ! 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 - ij = 0 + ij = 0_${ik}$ do j = 0, n2 - 1 do i = 0, j a( j, i ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do i = n1 + j, n - 1 a( i, n1+j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do do j = n2, n - 1 do i = 0, n1 - 1 a( j, i ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do 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 - ij = 0 + ij = 0_${ik}$ do j = 0, n1 do i = n1, n - 1 a( j, i ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do do j = 0, n1 - 1 do i = 0, j a( i, j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do l = n2 + j, n - 1 a( n2+j, l ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do end if @@ -25613,30 +25616,30 @@ module stdlib_linalg_lapack_z ! 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); lda=n+1 - ij = 0 + ij = 0_${ik}$ do j = 0, k - 1 do i = k, k + j a( k+j, i ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do i = j, n - 1 a( i, j ) = arf( ij ) - ij = ij + 1 + ij = ij + 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); lda=n+1 - ij = nt - n - 1 + ij = nt - n - 1_${ik}$ do j = n - 1, k, -1 do i = 0, j a( i, j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do l = j - k, k - 1 a( j-k, l ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do ij = ij - np1x2 end do @@ -25647,62 +25650,62 @@ module stdlib_linalg_lapack_z ! srpa for lower, transpose and n is even (see paper, a=b) ! t1 -> a(0,1) , t2 -> a(0,0) , s -> a(0,k+1) : ! t1 -> a(0+k) , t2 -> a(0+0) , s -> a(0+k*(k+1)); lda=k - ij = 0 + ij = 0_${ik}$ j = k do i = k, n - 1 a( i, j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do j = 0, k - 2 do i = 0, j a( j, i ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do i = k + 1 + j, n - 1 a( i, k+1+j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do do j = k - 1, n - 1 do i = 0, k - 1 a( j, i ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do else ! srpa for upper, transpose and n is even (see paper, a=b) ! t1 -> a(0,k+1) , t2 -> a(0,k) , s -> a(0,0) ! t1 -> a(0+k*(k+1)) , t2 -> a(0+k*k) , s -> a(0+0)); lda=k - ij = 0 + ij = 0_${ik}$ do j = 0, k do i = k, n - 1 a( j, i ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do do j = 0, k - 2 do i = 0, j a( i, j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do l = k + 1 + j, n - 1 a( k+1+j, l ) = conjg( arf( ij ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do ! note that here j = k-1 do i = 0, j a( i, j ) = arf( ij ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end if end if end if return - end subroutine stdlib_ztfttr + end subroutine stdlib${ii}$_ztfttr - pure subroutine stdlib_ztgevc( side, howmny, select, n, s, lds, p, ldp, vl,ldvl, vr, ldvr, & + pure subroutine stdlib${ii}$_ztgevc( side, howmny, select, n, s, lds, p, ldp, vl,ldvl, vr, ldvr, & !! ZTGEVC computes some or all of the right and/or left eigenvectors of !! a pair of complex matrices (S,P), where S and P are upper triangular. !! Matrix pairs of this type are produced by the generalized Schur @@ -25727,8 +25730,8 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: howmny, side - integer(ilp), intent(out) :: info, m - integer(ilp), intent(in) :: ldp, lds, ldvl, ldvr, mm, n + integer(${ik}$), intent(out) :: info, m + integer(${ik}$), intent(in) :: ldp, lds, ldvl, ldvr, mm, n ! Array Arguments logical(lk), intent(in) :: select(*) real(dp), intent(out) :: rwork(*) @@ -25740,7 +25743,7 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: compl, compr, ilall, ilback, ilbbad, ilcomp, lsa, lsb - integer(ilp) :: i, ibeg, ieig, iend, ihwmny, im, iside, isrc, j, je, jr + integer(${ik}$) :: i, ibeg, ieig, iend, ihwmny, im, iside, isrc, j, je, jr real(dp) :: acoefa, acoeff, anorm, ascale, bcoefa, big, bignum, bnorm, bscale, dmin, & safmin, sbeta, scale, small, temp, ulp, xmax complex(dp) :: bcoeff, ca, cb, d, salpha, sum, suma, sumb, x @@ -25753,56 +25756,56 @@ module stdlib_linalg_lapack_z ! Executable Statements ! decode and test the input parameters if( stdlib_lsame( howmny, 'A' ) ) then - ihwmny = 1 + ihwmny = 1_${ik}$ ilall = .true. ilback = .false. else if( stdlib_lsame( howmny, 'S' ) ) then - ihwmny = 2 + ihwmny = 2_${ik}$ ilall = .false. ilback = .false. else if( stdlib_lsame( howmny, 'B' ) ) then - ihwmny = 3 + ihwmny = 3_${ik}$ ilall = .true. ilback = .true. else - ihwmny = -1 + ihwmny = -1_${ik}$ end if if( stdlib_lsame( side, 'R' ) ) then - iside = 1 + iside = 1_${ik}$ compl = .false. compr = .true. else if( stdlib_lsame( side, 'L' ) ) then - iside = 2 + iside = 2_${ik}$ compl = .true. compr = .false. else if( stdlib_lsame( side, 'B' ) ) then - iside = 3 + iside = 3_${ik}$ compl = .true. compr = .true. else - iside = -1 + iside = -1_${ik}$ end if - info = 0 - if( iside<0 ) then - info = -1 - else if( ihwmny<0 ) then - info = -2 - else if( n<0 ) then - info = -4 - else if( lds1 ) then + work( j ) = stdlib${ii}$_zladiv( -work( j ), d ) + if( j>1_${ik}$ ) then ! w = w + x(j)*(a s(*,j) - b p(*,j) ) with scaling if( abs1( work( j ) )>one ) then temp = one / abs1( work( j ) ) @@ -26084,12 +26087,12 @@ module stdlib_linalg_lapack_z end do loop_210 ! back transform eigenvector if howmny='b'. if( ilback ) then - call stdlib_zgemv( 'N', n, je, cone, vr, ldvr, work, 1,czero, work( n+1 ), & - 1 ) - isrc = 2 + call stdlib${ii}$_zgemv( 'N', n, je, cone, vr, ldvr, work, 1_${ik}$,czero, work( n+1 ), & + 1_${ik}$ ) + isrc = 2_${ik}$ iend = n else - isrc = 1 + isrc = 1_${ik}$ iend = je end if ! copy and scale eigenvector into column of vr @@ -26103,7 +26106,7 @@ module stdlib_linalg_lapack_z vr( jr, ieig ) = temp*work( ( isrc-1 )*n+jr ) end do else - iend = 0 + iend = 0_${ik}$ end if do jr = iend + 1, n vr( jr, ieig ) = czero @@ -26112,10 +26115,10 @@ module stdlib_linalg_lapack_z end do loop_250 end if return - end subroutine stdlib_ztgevc + end subroutine stdlib${ii}$_ztgevc - pure subroutine stdlib_ztgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, j1, info ) + pure subroutine stdlib${ii}$_ztgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, j1, info ) !! ZTGEX2 swaps adjacent diagonal 1 by 1 blocks (A11,B11) and (A22,B22) !! in an upper triangular matrix pair (A, B) by an unitary equivalence !! transformation. @@ -26131,14 +26134,14 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: wantq, wantz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: j1, lda, ldb, ldq, ldz, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: j1, lda, ldb, ldq, ldz, n ! Array Arguments complex(dp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) ! ===================================================================== ! Parameters real(dp), parameter :: twenty = 2.0e+1_dp - integer(ilp), parameter :: ldst = 2 + integer(${ik}$), parameter :: ldst = 2_${ik}$ logical(lk), parameter :: wands = .true. @@ -26146,35 +26149,35 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: strong, weak - integer(ilp) :: i, m + integer(${ik}$) :: i, m real(dp) :: cq, cz, eps, sa, sb, scale, smlnum, sum, thresha, threshb complex(dp) :: cdum, f, g, sq, sz ! Local Arrays - complex(dp) :: s(ldst,ldst), t(ldst,ldst), work(8) + complex(dp) :: s(ldst,ldst), t(ldst,ldst), work(8_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,conjg,max,sqrt ! Executable Statements - info = 0 + info = 0_${ik}$ ! quick return if possible if( n<=1 )return m = ldst weak = .false. strong = .false. ! make a local copy of selected block in (a, b) - call stdlib_zlacpy( 'FULL', m, m, a( j1, j1 ), lda, s, ldst ) - call stdlib_zlacpy( 'FULL', m, m, b( j1, j1 ), ldb, t, ldst ) + call stdlib${ii}$_zlacpy( 'FULL', m, m, a( j1, j1 ), lda, s, ldst ) + call stdlib${ii}$_zlacpy( 'FULL', m, m, b( j1, j1 ), ldb, t, ldst ) ! compute the threshold for testing the acceptance of swapping. - eps = stdlib_dlamch( 'P' ) - smlnum = stdlib_dlamch( 'S' ) / eps + eps = stdlib${ii}$_dlamch( 'P' ) + smlnum = stdlib${ii}$_dlamch( 'S' ) / eps scale = real( czero,KIND=dp) sum = real( cone,KIND=dp) - call stdlib_zlacpy( 'FULL', m, m, s, ldst, work, m ) - call stdlib_zlacpy( 'FULL', m, m, t, ldst, work( m*m+1 ), m ) - call stdlib_zlassq( m*m, work, 1, scale, sum ) + call stdlib${ii}$_zlacpy( 'FULL', m, m, s, ldst, work, m ) + call stdlib${ii}$_zlacpy( 'FULL', m, m, t, ldst, work( m*m+1 ), m ) + call stdlib${ii}$_zlassq( m*m, work, 1_${ik}$, scale, sum ) sa = scale*sqrt( sum ) scale = real( czero,KIND=dp) sum = real( cone,KIND=dp) - call stdlib_zlassq( m*m, work(m*m+1), 1, scale, sum ) + call stdlib${ii}$_zlassq( m*m, work(m*m+1), 1_${ik}$, scale, sum ) sb = scale*sqrt( sum ) ! thres has been changed from ! thresh = max( ten*eps*sa, smlnum ) @@ -26187,36 +26190,36 @@ module stdlib_linalg_lapack_z threshb = max( twenty*eps*sb, smlnum ) ! compute unitary ql and rq that swap 1-by-1 and 1-by-1 blocks ! using givens rotations and perform the swap tentatively. - f = s( 2, 2 )*t( 1, 1 ) - t( 2, 2 )*s( 1, 1 ) - g = s( 2, 2 )*t( 1, 2 ) - t( 2, 2 )*s( 1, 2 ) - sa = abs( s( 2, 2 ) ) * abs( t( 1, 1 ) ) - sb = abs( s( 1, 1 ) ) * abs( t( 2, 2 ) ) - call stdlib_zlartg( g, f, cz, sz, cdum ) + f = s( 2_${ik}$, 2_${ik}$ )*t( 1_${ik}$, 1_${ik}$ ) - t( 2_${ik}$, 2_${ik}$ )*s( 1_${ik}$, 1_${ik}$ ) + g = s( 2_${ik}$, 2_${ik}$ )*t( 1_${ik}$, 2_${ik}$ ) - t( 2_${ik}$, 2_${ik}$ )*s( 1_${ik}$, 2_${ik}$ ) + sa = abs( s( 2_${ik}$, 2_${ik}$ ) ) * abs( t( 1_${ik}$, 1_${ik}$ ) ) + sb = abs( s( 1_${ik}$, 1_${ik}$ ) ) * abs( t( 2_${ik}$, 2_${ik}$ ) ) + call stdlib${ii}$_zlartg( g, f, cz, sz, cdum ) sz = -sz - call stdlib_zrot( 2, s( 1, 1 ), 1, s( 1, 2 ), 1, cz, conjg( sz ) ) - call stdlib_zrot( 2, t( 1, 1 ), 1, t( 1, 2 ), 1, cz, conjg( sz ) ) + call stdlib${ii}$_zrot( 2_${ik}$, s( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, s( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, cz, conjg( sz ) ) + call stdlib${ii}$_zrot( 2_${ik}$, t( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, t( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, cz, conjg( sz ) ) if( sa>=sb ) then - call stdlib_zlartg( s( 1, 1 ), s( 2, 1 ), cq, sq, cdum ) + call stdlib${ii}$_zlartg( s( 1_${ik}$, 1_${ik}$ ), s( 2_${ik}$, 1_${ik}$ ), cq, sq, cdum ) else - call stdlib_zlartg( t( 1, 1 ), t( 2, 1 ), cq, sq, cdum ) + call stdlib${ii}$_zlartg( t( 1_${ik}$, 1_${ik}$ ), t( 2_${ik}$, 1_${ik}$ ), cq, sq, cdum ) end if - call stdlib_zrot( 2, s( 1, 1 ), ldst, s( 2, 1 ), ldst, cq, sq ) - call stdlib_zrot( 2, t( 1, 1 ), ldst, t( 2, 1 ), ldst, cq, sq ) + call stdlib${ii}$_zrot( 2_${ik}$, s( 1_${ik}$, 1_${ik}$ ), ldst, s( 2_${ik}$, 1_${ik}$ ), ldst, cq, sq ) + call stdlib${ii}$_zrot( 2_${ik}$, t( 1_${ik}$, 1_${ik}$ ), ldst, t( 2_${ik}$, 1_${ik}$ ), ldst, cq, sq ) ! weak stability test: |s21| <= o(eps f-norm((a))) ! and |t21| <= o(eps f-norm((b))) - weak = abs( s( 2, 1 ) )<=thresha .and.abs( t( 2, 1 ) )<=threshb + weak = abs( s( 2_${ik}$, 1_${ik}$ ) )<=thresha .and.abs( t( 2_${ik}$, 1_${ik}$ ) )<=threshb if( .not.weak )go to 20 if( wands ) then ! strong stability test: ! f-norm((a-ql**h*s*qr)) <= o(eps*f-norm((a))) ! and ! f-norm((b-ql**h*t*qr)) <= o(eps*f-norm((b))) - call stdlib_zlacpy( 'FULL', m, m, s, ldst, work, m ) - call stdlib_zlacpy( 'FULL', m, m, t, ldst, work( m*m+1 ), m ) - call stdlib_zrot( 2, work, 1, work( 3 ), 1, cz, -conjg( sz ) ) - call stdlib_zrot( 2, work( 5 ), 1, work( 7 ), 1, cz, -conjg( sz ) ) - call stdlib_zrot( 2, work, 2, work( 2 ), 2, cq, -sq ) - call stdlib_zrot( 2, work( 5 ), 2, work( 6 ), 2, cq, -sq ) + call stdlib${ii}$_zlacpy( 'FULL', m, m, s, ldst, work, m ) + call stdlib${ii}$_zlacpy( 'FULL', m, m, t, ldst, work( m*m+1 ), m ) + call stdlib${ii}$_zrot( 2_${ik}$, work, 1_${ik}$, work( 3_${ik}$ ), 1_${ik}$, cz, -conjg( sz ) ) + call stdlib${ii}$_zrot( 2_${ik}$, work( 5_${ik}$ ), 1_${ik}$, work( 7_${ik}$ ), 1_${ik}$, cz, -conjg( sz ) ) + call stdlib${ii}$_zrot( 2_${ik}$, work, 2_${ik}$, work( 2_${ik}$ ), 2_${ik}$, cq, -sq ) + call stdlib${ii}$_zrot( 2_${ik}$, work( 5_${ik}$ ), 2_${ik}$, work( 6_${ik}$ ), 2_${ik}$, cq, -sq ) do i = 1, 2 work( i ) = work( i ) - a( j1+i-1, j1 ) work( i+2 ) = work( i+2 ) - a( j1+i-1, j1+1 ) @@ -26225,39 +26228,39 @@ module stdlib_linalg_lapack_z end do scale = real( czero,KIND=dp) sum = real( cone,KIND=dp) - call stdlib_zlassq( m*m, work, 1, scale, sum ) + call stdlib${ii}$_zlassq( m*m, work, 1_${ik}$, scale, sum ) sa = scale*sqrt( sum ) scale = real( czero,KIND=dp) sum = real( cone,KIND=dp) - call stdlib_zlassq( m*m, work(m*m+1), 1, scale, sum ) + call stdlib${ii}$_zlassq( m*m, work(m*m+1), 1_${ik}$, scale, sum ) sb = scale*sqrt( sum ) strong = sa<=thresha .and. sb<=threshb if( .not.strong )go to 20 end if ! if the swap is accepted ("weakly" and "strongly"), apply the ! equivalence transformations to the original matrix pair (a,b) - call stdlib_zrot( j1+1, a( 1, j1 ), 1, a( 1, j1+1 ), 1, cz,conjg( sz ) ) - call stdlib_zrot( j1+1, b( 1, j1 ), 1, b( 1, j1+1 ), 1, cz,conjg( sz ) ) - call stdlib_zrot( n-j1+1, a( j1, j1 ), lda, a( j1+1, j1 ), lda, cq, sq ) - call stdlib_zrot( n-j1+1, b( j1, j1 ), ldb, b( j1+1, j1 ), ldb, cq, sq ) + call stdlib${ii}$_zrot( j1+1, a( 1_${ik}$, j1 ), 1_${ik}$, a( 1_${ik}$, j1+1 ), 1_${ik}$, cz,conjg( sz ) ) + call stdlib${ii}$_zrot( j1+1, b( 1_${ik}$, j1 ), 1_${ik}$, b( 1_${ik}$, j1+1 ), 1_${ik}$, cz,conjg( sz ) ) + call stdlib${ii}$_zrot( n-j1+1, a( j1, j1 ), lda, a( j1+1, j1 ), lda, cq, sq ) + call stdlib${ii}$_zrot( n-j1+1, b( j1, j1 ), ldb, b( j1+1, j1 ), ldb, cq, sq ) ! set n1 by n2 (2,1) blocks to 0 a( j1+1, j1 ) = czero b( j1+1, j1 ) = czero ! accumulate transformations into q and z if requested. - if( wantz )call stdlib_zrot( n, z( 1, j1 ), 1, z( 1, j1+1 ), 1, cz,conjg( sz ) ) + if( wantz )call stdlib${ii}$_zrot( n, z( 1_${ik}$, j1 ), 1_${ik}$, z( 1_${ik}$, j1+1 ), 1_${ik}$, cz,conjg( sz ) ) - if( wantq )call stdlib_zrot( n, q( 1, j1 ), 1, q( 1, j1+1 ), 1, cq,conjg( sq ) ) + if( wantq )call stdlib${ii}$_zrot( n, q( 1_${ik}$, j1 ), 1_${ik}$, q( 1_${ik}$, j1+1 ), 1_${ik}$, cq,conjg( sq ) ) ! exit with info = 0 if swap was successfully performed. return ! exit with info = 1 if swap was rejected. 20 continue - info = 1 + info = 1_${ik}$ return - end subroutine stdlib_ztgex2 + end subroutine stdlib${ii}$_ztgex2 - pure subroutine stdlib_ztgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, ifst, ilst, & + pure subroutine stdlib${ii}$_ztgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, z,ldz, ifst, ilst, & !! ZTGEXC reorders the generalized Schur decomposition of a complex !! matrix pair (A,B), using an unitary equivalence transformation !! (A, B) := Q * (A, B) * Z**H, so that the diagonal block of (A, B) with @@ -26274,36 +26277,36 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: wantq, wantz - integer(ilp), intent(in) :: ifst, lda, ldb, ldq, ldz, n - integer(ilp), intent(inout) :: ilst - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ifst, lda, ldb, ldq, ldz, n + integer(${ik}$), intent(inout) :: ilst + integer(${ik}$), intent(out) :: info ! Array Arguments complex(dp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: here + integer(${ik}$) :: here ! Intrinsic Functions intrinsic :: max ! Executable Statements ! decode and test input arguments. - info = 0 - if( n<0 ) then - info = -3 - else if( ldan ) then - info = -12 - else if( ilst<1 .or. ilst>n ) then - info = -13 - end if - if( info/=0 ) then - call stdlib_xerbla( 'ZTGEXC', -info ) + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( ldan ) then + info = -12_${ik}$ + else if( ilst<1_${ik}$ .or. ilst>n ) then + info = -13_${ik}$ + end if + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZTGEXC', -info ) return end if ! quick return if possible @@ -26313,35 +26316,35 @@ module stdlib_linalg_lapack_z here = ifst 10 continue ! swap with next one below - call stdlib_ztgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz,here, info ) + call stdlib${ii}$_ztgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz,here, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then ilst = here return end if - here = here + 1 + here = here + 1_${ik}$ if( here=ilst )go to 20 - here = here + 1 + here = here + 1_${ik}$ end if ilst = here return - end subroutine stdlib_ztgexc + end subroutine stdlib${ii}$_ztgexc - pure subroutine stdlib_ztplqt2( m, n, l, a, lda, b, ldb, t, ldt, info ) + pure subroutine stdlib${ii}$_ztplqt2( m, n, l, a, lda, b, ldb, t, ldt, info ) !! ZTPLQT2 computes a LQ a factorization of a complex "triangular-pentagonal" !! matrix C, which is composed of a triangular block A and pentagonal block B, !! using the compact WY representation for Q. @@ -26349,36 +26352,36 @@ module stdlib_linalg_lapack_z ! -- 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, ldb, ldt, n, m, l + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l ! Array Arguments complex(dp), intent(inout) :: a(lda,*), b(ldb,*) complex(dp), intent(out) :: t(ldt,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, p, mp, np + integer(${ik}$) :: i, j, p, mp, np complex(dp) :: alpha ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( l<0 .or. l>min(m,n) ) then - info = -3 - else if( ldamin(m,n) ) then + info = -3_${ik}$ + else if( ldamin(m,n) ) then - info = -3 - else if( ldamin(m,n) ) then + info = -3_${ik}$ + else if( lda 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 + ijp = 0_${ik}$ + jp = 0_${ik}$ do j = 0, n2 do i = j, n - 1 ij = i + jp arf( ij ) = ap( ijp ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do jp = jp + lda end do @@ -27477,28 +27480,28 @@ module stdlib_linalg_lapack_z do j = 1 + i, n2 ij = i + j*lda arf( ij ) = conjg( ap( ijp ) ) - 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 + ijp = 0_${ik}$ do j = 0, n1 - 1 ij = n2 + j do i = 0, j arf( ij ) = conjg( ap( ijp ) ) - 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 arf( ij ) = ap( ijp ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do js = js + lda end do @@ -27509,38 +27512,38 @@ module stdlib_linalg_lapack_z ! 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 + ijp = 0_${ik}$ do i = 0, n2 do ij = i*( lda+1 ), n*lda - 1, lda arf( ij ) = conjg( ap( ijp ) ) - 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 arf( ij ) = ap( ijp ) - 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 + ijp = 0_${ik}$ js = n2*lda do j = 0, n1 - 1 do ij = js, js + j arf( ij ) = ap( ijp ) - 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 arf( ij ) = conjg( ap( ijp ) ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do end do end if @@ -27553,13 +27556,13 @@ module stdlib_linalg_lapack_z ! 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 + 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 arf( ij ) = ap( ijp ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do jp = jp + lda end do @@ -27567,28 +27570,28 @@ module stdlib_linalg_lapack_z do j = i, k - 1 ij = i + j*lda arf( ij ) = conjg( ap( ijp ) ) - 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 + ijp = 0_${ik}$ do j = 0, k - 1 - ij = k + 1 + j + ij = k + 1_${ik}$ + j do i = 0, j arf( ij ) = conjg( ap( ijp ) ) - 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 arf( ij ) = ap( ijp ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do js = js + lda end do @@ -27599,48 +27602,48 @@ module stdlib_linalg_lapack_z ! 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 + ijp = 0_${ik}$ do i = 0, k - 1 do ij = i + ( i+1 )*lda, ( n+1 )*lda - 1, lda arf( ij ) = conjg( ap( ijp ) ) - 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 arf( ij ) = ap( ijp ) - 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 + ijp = 0_${ik}$ js = ( k+1 )*lda do j = 0, k - 1 do ij = js, js + j arf( ij ) = ap( ijp ) - 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 arf( ij ) = conjg( ap( ijp ) ) - ijp = ijp + 1 + ijp = ijp + 1_${ik}$ end do end do end if end if end if return - end subroutine stdlib_ztpttf + end subroutine stdlib${ii}$_ztpttf - pure subroutine stdlib_ztpttr( uplo, n, ap, a, lda, info ) + pure subroutine stdlib${ii}$_ztpttr( uplo, n, ap, a, lda, info ) !! ZTPTTR copies a triangular matrix A from standard packed format (TP) !! to standard full format (TR). ! -- lapack computational routine -- @@ -27648,8 +27651,8 @@ module stdlib_linalg_lapack_z ! -- 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) :: n, lda + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n, lda ! Array Arguments complex(dp), intent(out) :: a(lda,*) complex(dp), intent(in) :: ap(*) @@ -27657,44 +27660,44 @@ module stdlib_linalg_lapack_z ! Parameters ! Local Scalars logical(lk) :: lower - integer(ilp) :: i, j, k + integer(${ik}$) :: i, j, k ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ lower = stdlib_lsame( uplo, 'L' ) if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda1 ) then - call stdlib_zlatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', 'Y',ki-1, t, ldt, & - work( 1 ), scale, rwork,info ) + if( ki>1_${ik}$ ) then + call stdlib${ii}$_zlatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', 'Y',ki-1, t, ldt, & + work( 1_${ik}$ ), scale, rwork,info ) work( ki ) = scale end if ! copy the vector x or q*x to vr and normalize. if( .not.over ) then - call stdlib_zcopy( ki, work( 1 ), 1, vr( 1, is ), 1 ) - ii = stdlib_izamax( ki, vr( 1, is ), 1 ) + call stdlib${ii}$_zcopy( ki, work( 1_${ik}$ ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ ) + ii = stdlib${ii}$_izamax( ki, vr( 1_${ik}$, is ), 1_${ik}$ ) remax = one / cabs1( vr( ii, is ) ) - call stdlib_zdscal( ki, remax, vr( 1, is ), 1 ) + call stdlib${ii}$_zdscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ ) do k = ki + 1, n vr( k, is ) = cmzero end do else - if( ki>1 )call stdlib_zgemv( 'N', n, ki-1, cmone, vr, ldvr, work( 1 ),1, & - cmplx( scale,KIND=dp), vr( 1, ki ), 1 ) - ii = stdlib_izamax( n, vr( 1, ki ), 1 ) + if( ki>1_${ik}$ )call stdlib${ii}$_zgemv( 'N', n, ki-1, cmone, vr, ldvr, work( 1_${ik}$ ),1_${ik}$, & + cmplx( scale,KIND=dp), vr( 1_${ik}$, ki ), 1_${ik}$ ) + ii = stdlib${ii}$_izamax( n, vr( 1_${ik}$, ki ), 1_${ik}$ ) remax = one / cabs1( vr( ii, ki ) ) - call stdlib_zdscal( n, remax, vr( 1, ki ), 1 ) + call stdlib${ii}$_zdscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ ) end if ! set back the original diagonal elements of t. do k = 1, ki - 1 t( k, k ) = work( k+n ) end do - is = is - 1 + is = is - 1_${ik}$ end do loop_80 end if if( leftv ) then ! compute left eigenvectors. - is = 1 + is = 1_${ik}$ loop_130: do ki = 1, n if( somev ) then if( .not.select( ki ) )cycle loop_130 @@ -27863,38 +27866,38 @@ module stdlib_linalg_lapack_z if( cabs1( t( k, k ) )= n + 2*n*nbmin ) then - nb = (lwork - n) / (2*n) + if( over .and. lwork >= n + 2_${ik}$*n*nbmin ) then + nb = (lwork - n) / (2_${ik}$*n) nb = min( nb, nbmax ) - call stdlib_zlaset( 'F', n, 1+2*nb, czero, czero, work, n ) + call stdlib${ii}$_zlaset( 'F', n, 1_${ik}$+2*nb, czero, czero, work, n ) else - nb = 1 + nb = 1_${ik}$ end if ! set the constants to control overflow. - unfl = stdlib_dlamch( 'SAFE MINIMUM' ) + unfl = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) ovfl = one / unfl - call stdlib_dlabad( unfl, ovfl ) - ulp = stdlib_dlamch( 'PRECISION' ) + call stdlib${ii}$_dlabad( unfl, ovfl ) + ulp = stdlib${ii}$_dlamch( 'PRECISION' ) smlnum = unfl*( n / ulp ) ! store the diagonal elements of t in working array work. do i = 1, n @@ -28014,9 +28017,9 @@ module stdlib_linalg_lapack_z end do ! compute 1-norm of each column of strictly upper triangular ! part of t to control overflow in triangular solver. - rwork( 1 ) = zero + rwork( 1_${ik}$ ) = zero do j = 2, n - rwork( j ) = stdlib_dzasum( j-1, t( 1, j ), 1 ) + rwork( j ) = stdlib${ii}$_dzasum( j-1, t( 1_${ik}$, j ), 1_${ik}$ ) end do if( rightv ) then ! ============================================================ @@ -28045,30 +28048,30 @@ module stdlib_linalg_lapack_z t( k, k ) = t( k, k ) - t( ki, ki ) if( cabs1( t( k, k ) )1 ) then - call stdlib_zlatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', 'Y',ki-1, t, ldt, & - work( 1 + iv*n ), scale,rwork, info ) + if( ki>1_${ik}$ ) then + call stdlib${ii}$_zlatrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', 'Y',ki-1, t, ldt, & + work( 1_${ik}$ + iv*n ), scale,rwork, info ) work( ki + iv*n ) = scale end if ! copy the vector x or q*x to vr and normalize. if( .not.over ) then ! ------------------------------ ! no back-transform: copy x to vr and normalize. - call stdlib_zcopy( ki, work( 1 + iv*n ), 1, vr( 1, is ), 1 ) - ii = stdlib_izamax( ki, vr( 1, is ), 1 ) + call stdlib${ii}$_zcopy( ki, work( 1_${ik}$ + iv*n ), 1_${ik}$, vr( 1_${ik}$, is ), 1_${ik}$ ) + ii = stdlib${ii}$_izamax( ki, vr( 1_${ik}$, is ), 1_${ik}$ ) remax = one / cabs1( vr( ii, is ) ) - call stdlib_zdscal( ki, remax, vr( 1, is ), 1 ) + call stdlib${ii}$_zdscal( ki, remax, vr( 1_${ik}$, is ), 1_${ik}$ ) do k = ki + 1, n vr( k, is ) = czero end do - else if( nb==1 ) then + else if( nb==1_${ik}$ ) then ! ------------------------------ ! version 1: back-transform each vector with gemv, q*x. - if( ki>1 )call stdlib_zgemv( 'N', n, ki-1, cone, vr, ldvr,work( 1 + iv*n ), 1,& - cmplx( scale,KIND=dp),vr( 1, ki ), 1 ) - ii = stdlib_izamax( n, vr( 1, ki ), 1 ) + if( ki>1_${ik}$ )call stdlib${ii}$_zgemv( 'N', n, ki-1, cone, vr, ldvr,work( 1_${ik}$ + iv*n ), 1_${ik}$,& + cmplx( scale,KIND=dp),vr( 1_${ik}$, ki ), 1_${ik}$ ) + ii = stdlib${ii}$_izamax( n, vr( 1_${ik}$, ki ), 1_${ik}$ ) remax = one / cabs1( vr( ii, ki ) ) - call stdlib_zdscal( n, remax, vr( 1, ki ), 1 ) + call stdlib${ii}$_zdscal( n, remax, vr( 1_${ik}$, ki ), 1_${ik}$ ) else ! ------------------------------ ! version 2: back-transform block of vectors with gemm @@ -28079,27 +28082,27 @@ module stdlib_linalg_lapack_z ! columns iv:nb of work are valid vectors. ! when the number of vectors stored reaches nb, ! or if this was last vector, do the gemm - if( (iv==1) .or. (ki==1) ) then - call stdlib_zgemm( 'N', 'N', n, nb-iv+1, ki+nb-iv, cone,vr, ldvr,work( 1 + & - (iv)*n ), n,czero,work( 1 + (nb+iv)*n ), n ) + if( (iv==1_${ik}$) .or. (ki==1_${ik}$) ) then + call stdlib${ii}$_zgemm( 'N', 'N', n, nb-iv+1, ki+nb-iv, cone,vr, ldvr,work( 1_${ik}$ + & + (iv)*n ), n,czero,work( 1_${ik}$ + (nb+iv)*n ), n ) ! normalize vectors do k = iv, nb - ii = stdlib_izamax( n, work( 1 + (nb+k)*n ), 1 ) + ii = stdlib${ii}$_izamax( n, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ ) remax = one / cabs1( work( ii + (nb+k)*n ) ) - call stdlib_zdscal( n, remax, work( 1 + (nb+k)*n ), 1 ) + call stdlib${ii}$_zdscal( n, remax, work( 1_${ik}$ + (nb+k)*n ), 1_${ik}$ ) end do - call stdlib_zlacpy( 'F', n, nb-iv+1,work( 1 + (nb+iv)*n ), n,vr( 1, ki ), & + call stdlib${ii}$_zlacpy( 'F', n, nb-iv+1,work( 1_${ik}$ + (nb+iv)*n ), n,vr( 1_${ik}$, ki ), & ldvr ) iv = nb else - iv = iv - 1 + iv = iv - 1_${ik}$ end if end if ! restore the original diagonal elements of t. do k = 1, ki - 1 t( k, k ) = work( k ) end do - is = is - 1 + is = is - 1_${ik}$ end do loop_80 end if if( leftv ) then @@ -28109,8 +28112,8 @@ module stdlib_linalg_lapack_z ! non-blocked version always uses iv=1; ! blocked version starts with iv=1, goes up to nb. ! (note the "0-th" column is used to store the original diagonal.) - iv = 1 - is = 1 + iv = 1_${ik}$ + is = 1_${ik}$ loop_130: do ki = 1, n if( somev ) then if( .not.select( ki ) )cycle loop_130 @@ -28130,7 +28133,7 @@ module stdlib_linalg_lapack_z if( cabs1( t( k, k ) )n ).and.( n>0 )) then - info = -7 - else if(( ilst<1 .or. ilst>n ).and.( n>0 )) then - info = -8 - end if - if( info/=0 ) then - call stdlib_xerbla( 'ZTREXC', -info ) + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ + else if( ldtn ).and.( n>0_${ik}$ )) then + info = -7_${ik}$ + else if(( ilst<1_${ik}$ .or. ilst>n ).and.( n>0_${ik}$ )) then + info = -8_${ik}$ + end if + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZTREXC', -info ) return end if ! quick return if possible if( n<=1 .or. ifst==ilst )return if( ifst=n ) then + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZTRTRI', uplo // diag, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code - call stdlib_ztrti2( uplo, diag, n, a, lda, info ) + call stdlib${ii}$_ztrti2( uplo, diag, n, a, lda, info ) else ! use blocked code if( upper ) then @@ -28793,35 +28796,35 @@ module stdlib_linalg_lapack_z do j = 1, n, nb jb = min( nb, n-j+1 ) ! compute rows 1:j-1 of current block column - call stdlib_ztrmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, cone, a, & - lda, a( 1, j ), lda ) - call stdlib_ztrsm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, -cone, a( & - j, j ), lda, a( 1, j ), lda ) + call stdlib${ii}$_ztrmm( 'LEFT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, cone, a, & + lda, a( 1_${ik}$, j ), lda ) + call stdlib${ii}$_ztrsm( 'RIGHT', 'UPPER', 'NO TRANSPOSE', diag, j-1,jb, -cone, a( & + j, j ), lda, a( 1_${ik}$, j ), lda ) ! compute inverse of current diagonal block - call stdlib_ztrti2( 'UPPER', diag, jb, a( j, j ), lda, info ) + call stdlib${ii}$_ztrti2( '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_ztrmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, & + call stdlib${ii}$_ztrmm( 'LEFT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, & cone, a( j+jb, j+jb ), lda,a( j+jb, j ), lda ) - call stdlib_ztrsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, -& + call stdlib${ii}$_ztrsm( 'RIGHT', 'LOWER', 'NO TRANSPOSE', diag,n-j-jb+1, jb, -& cone, a( j, j ), lda,a( j+jb, j ), lda ) end if ! compute inverse of current diagonal block - call stdlib_ztrti2( 'LOWER', diag, jb, a( j, j ), lda, info ) + call stdlib${ii}$_ztrti2( 'LOWER', diag, jb, a( j, j ), lda, info ) end do end if end if return - end subroutine stdlib_ztrtri + end subroutine stdlib${ii}$_ztrtri - pure subroutine stdlib_ztrtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info ) + pure subroutine stdlib${ii}$_ztrtrs( uplo, trans, diag, n, nrhs, a, lda, b, ldb,info ) !! ZTRTRS solves a triangular system of the form !! A * X = B, A**T * X = B, or A**H * X = B, !! where A is a triangular matrix of order N, and B is an N-by-NRHS @@ -28831,8 +28834,8 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(in) :: a(lda,*) complex(dp), intent(inout) :: b(ldb,*) @@ -28844,26 +28847,26 @@ module stdlib_linalg_lapack_z 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 a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1); lda=n - ij = 0 + ij = 0_${ik}$ do j = 0, n2 do i = n1, n2 + j arf( ij ) = conjg( a( n2+j, i ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do i = j, n - 1 arf( ij ) = a( i, j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do else @@ -28978,11 +28981,11 @@ module stdlib_linalg_lapack_z do j = n - 1, n1, -1 do i = 0, j arf( ij ) = a( i, j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do l = j - n1, n1 - 1 arf( ij ) = conjg( a( j-n1, l ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do ij = ij - nx2 end do @@ -28993,42 +28996,42 @@ module stdlib_linalg_lapack_z ! 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 - ij = 0 + ij = 0_${ik}$ do j = 0, n2 - 1 do i = 0, j arf( ij ) = conjg( a( j, i ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do i = n1 + j, n - 1 arf( ij ) = a( i, n1+j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do do j = n2, n - 1 do i = 0, n1 - 1 arf( ij ) = conjg( a( j, i ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do 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 - ij = 0 + ij = 0_${ik}$ do j = 0, n1 do i = n1, n - 1 arf( ij ) = conjg( a( j, i ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do do j = 0, n1 - 1 do i = 0, j arf( ij ) = a( i, j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do l = n2 + j, n - 1 arf( ij ) = conjg( a( n2+j, l ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do end if @@ -29041,30 +29044,30 @@ module stdlib_linalg_lapack_z ! 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); lda=n+1 - ij = 0 + ij = 0_${ik}$ do j = 0, k - 1 do i = k, k + j arf( ij ) = conjg( a( k+j, i ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do i = j, n - 1 arf( ij ) = a( i, j ) - ij = ij + 1 + ij = ij + 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); lda=n+1 - ij = nt - n - 1 + ij = nt - n - 1_${ik}$ do j = n - 1, k, -1 do i = 0, j arf( ij ) = a( i, j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do l = j - k, k - 1 arf( ij ) = conjg( a( j-k, l ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do ij = ij - np1x2 end do @@ -29075,62 +29078,62 @@ module stdlib_linalg_lapack_z ! srpa for lower, transpose and n is even (see paper, a=b) ! t1 -> a(0,1) , t2 -> a(0,0) , s -> a(0,k+1) : ! t1 -> a(0+k) , t2 -> a(0+0) , s -> a(0+k*(k+1)); lda=k - ij = 0 + ij = 0_${ik}$ j = k do i = k, n - 1 arf( ij ) = a( i, j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do j = 0, k - 2 do i = 0, j arf( ij ) = conjg( a( j, i ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do i = k + 1 + j, n - 1 arf( ij ) = a( i, k+1+j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do do j = k - 1, n - 1 do i = 0, k - 1 arf( ij ) = conjg( a( j, i ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do else ! srpa for upper, transpose and n is even (see paper, a=b) ! t1 -> a(0,k+1) , t2 -> a(0,k) , s -> a(0,0) ! t1 -> a(0+k*(k+1)) , t2 -> a(0+k*k) , s -> a(0+0)); lda=k - ij = 0 + ij = 0_${ik}$ do j = 0, k do i = k, n - 1 arf( ij ) = conjg( a( j, i ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do do j = 0, k - 2 do i = 0, j arf( ij ) = a( i, j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do do l = k + 1 + j, n - 1 arf( ij ) = conjg( a( k+1+j, l ) ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end do ! note that here j = k-1 do i = 0, j arf( ij ) = a( i, j ) - ij = ij + 1 + ij = ij + 1_${ik}$ end do end if end if end if return - end subroutine stdlib_ztrttf + end subroutine stdlib${ii}$_ztrttf - pure subroutine stdlib_ztrttp( uplo, n, a, lda, ap, info ) + pure subroutine stdlib${ii}$_ztrttp( uplo, n, a, lda, ap, info ) !! ZTRTTP copies a triangular matrix A from full format (TR) to standard !! packed format (TP). ! -- lapack computational routine -- @@ -29138,8 +29141,8 @@ module stdlib_linalg_lapack_z ! -- 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) :: n, lda + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n, lda ! Array Arguments complex(dp), intent(in) :: a(lda,*) complex(dp), intent(out) :: ap(*) @@ -29147,44 +29150,44 @@ module stdlib_linalg_lapack_z ! Parameters ! Local Scalars logical(lk) :: lower - integer(ilp) :: i, j, k + integer(${ik}$) :: i, j, k ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ lower = stdlib_lsame( uplo, 'L' ) if( .not.lower .and. .not.stdlib_lsame( uplo, 'U' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda1 .and. nb1_${ik}$ .and. nb1 ) then + call stdlib${ii}$_zlatrz( ib, n-i+1, n-m, a( i, i ), lda, tau( i ),work ) + if( i>1_${ik}$ ) then ! form the triangular factor of the block reflector ! h = h(i+ib-1) . . . h(i+1) h(i) - call stdlib_zlarzt( 'BACKWARD', 'ROWWISE', n-m, ib, a( i, m1 ),lda, tau( i ), & + call stdlib${ii}$_zlarzt( 'BACKWARD', 'ROWWISE', n-m, ib, a( i, m1 ),lda, tau( i ), & work, ldwork ) ! apply h to a(1:i-1,i:n) from the right - call stdlib_zlarzb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', i-1, n-i+1,& - ib, n-m, a( i, m1 ),lda, work, ldwork, a( 1, i ), lda,work( ib+1 ), ldwork ) + call stdlib${ii}$_zlarzb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', i-1, n-i+1,& + ib, n-m, a( i, m1 ),lda, work, ldwork, a( 1_${ik}$, i ), lda,work( ib+1 ), ldwork ) end if end do - mu = i + nb - 1 + mu = i + nb - 1_${ik}$ else mu = m end if ! use unblocked code to factor the last or only block - if( mu>0 )call stdlib_zlatrz( mu, n, n-m, a, lda, tau, work ) - work( 1 ) = lwkopt + if( mu>0_${ik}$ )call stdlib${ii}$_zlatrz( mu, n, n-m, a, lda, tau, work ) + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_ztzrzf + end subroutine stdlib${ii}$_ztzrzf - subroutine stdlib_zunbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & + subroutine stdlib${ii}$_zunbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & !! ZUNBDB simultaneously bidiagonalizes the blocks of an M-by-M !! partitioned unitary matrix X: !! [ B11 | B12 0 0 ] @@ -29323,8 +29326,8 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: signs, trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldx11, ldx12, ldx21, ldx22, lwork, m, p, q + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldx11, ldx12, ldx21, ldx22, lwork, m, p, q ! Array Arguments real(dp), intent(out) :: phi(*), theta(*) complex(dp), intent(out) :: taup1(*), taup2(*), tauq1(*), tauq2(*), work(*) @@ -29337,14 +29340,14 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: colmajor, lquery - integer(ilp) :: i, lworkmin, lworkopt + integer(${ik}$) :: i, lworkmin, lworkopt real(dp) :: z1, z2, z3, z4 ! Intrinsic Functions intrinsic :: atan2,cos,max,min,sin intrinsic :: cmplx,conjg ! Executable Statements ! test input arguments - info = 0 + info = 0_${ik}$ colmajor = .not. stdlib_lsame( trans, 'T' ) if( .not. stdlib_lsame( signs, 'O' ) ) then z1 = realone @@ -29357,41 +29360,41 @@ module stdlib_linalg_lapack_z z3 = realone z4 = -realone end if - lquery = lwork == -1 - if( m < 0 ) then - info = -3 - else if( p < 0 .or. p > m ) then - info = -4 - else if( q < 0 .or. q > p .or. q > m-p .or.q > m-q ) then - info = -5 - else if( colmajor .and. ldx11 < max( 1, p ) ) then - info = -7 - else if( .not.colmajor .and. ldx11 < max( 1, q ) ) then - info = -7 - else if( colmajor .and. ldx12 < max( 1, p ) ) then - info = -9 - else if( .not.colmajor .and. ldx12 < max( 1, m-q ) ) then - info = -9 - else if( colmajor .and. ldx21 < max( 1, m-p ) ) then - info = -11 - else if( .not.colmajor .and. ldx21 < max( 1, q ) ) then - info = -11 - else if( colmajor .and. ldx22 < max( 1, m-p ) ) then - info = -13 - else if( .not.colmajor .and. ldx22 < max( 1, m-q ) ) then - info = -13 + lquery = lwork == -1_${ik}$ + if( m < 0_${ik}$ ) then + info = -3_${ik}$ + else if( p < 0_${ik}$ .or. p > m ) then + info = -4_${ik}$ + else if( q < 0_${ik}$ .or. q > p .or. q > m-p .or.q > m-q ) then + info = -5_${ik}$ + else if( colmajor .and. ldx11 < max( 1_${ik}$, p ) ) then + info = -7_${ik}$ + else if( .not.colmajor .and. ldx11 < max( 1_${ik}$, q ) ) then + info = -7_${ik}$ + else if( colmajor .and. ldx12 < max( 1_${ik}$, p ) ) then + info = -9_${ik}$ + else if( .not.colmajor .and. ldx12 < max( 1_${ik}$, m-q ) ) then + info = -9_${ik}$ + else if( colmajor .and. ldx21 < max( 1_${ik}$, m-p ) ) then + info = -11_${ik}$ + else if( .not.colmajor .and. ldx21 < max( 1_${ik}$, q ) ) then + info = -11_${ik}$ + else if( colmajor .and. ldx22 < max( 1_${ik}$, m-p ) ) then + info = -13_${ik}$ + else if( .not.colmajor .and. ldx22 < max( 1_${ik}$, m-q ) ) then + info = -13_${ik}$ end if ! compute workspace - if( info == 0 ) then + if( info == 0_${ik}$ ) then lworkopt = m - q lworkmin = m - q - work(1) = lworkopt + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not. lquery ) then - info = -21 + info = -21_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'XORBDB', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'XORBDB', -info ) return else if( lquery ) then return @@ -29400,230 +29403,230 @@ module stdlib_linalg_lapack_z if( colmajor ) then ! reduce columns 1, ..., q of x11, x12, x21, and x22 do i = 1, q - if( i == 1 ) then - call stdlib_zscal( p-i+1, cmplx( z1, 0.0_dp,KIND=dp), x11(i,i), 1 ) + if( i == 1_${ik}$ ) then + call stdlib${ii}$_zscal( p-i+1, cmplx( z1, 0.0_dp,KIND=dp), x11(i,i), 1_${ik}$ ) else - call stdlib_zscal( p-i+1, cmplx( z1*cos(phi(i-1)), 0.0_dp,KIND=dp),x11(i,i), & - 1 ) - call stdlib_zaxpy( p-i+1, cmplx( -z1*z3*z4*sin(phi(i-1)),0.0_dp,KIND=dp), x12(& - i,i-1), 1, x11(i,i), 1 ) + call stdlib${ii}$_zscal( p-i+1, cmplx( z1*cos(phi(i-1)), 0.0_dp,KIND=dp),x11(i,i), & + 1_${ik}$ ) + call stdlib${ii}$_zaxpy( p-i+1, cmplx( -z1*z3*z4*sin(phi(i-1)),0.0_dp,KIND=dp), x12(& + i,i-1), 1_${ik}$, x11(i,i), 1_${ik}$ ) end if - if( i == 1 ) then - call stdlib_zscal( m-p-i+1, cmplx( z2, 0.0_dp,KIND=dp), x21(i,i), 1 ) + if( i == 1_${ik}$ ) then + call stdlib${ii}$_zscal( m-p-i+1, cmplx( z2, 0.0_dp,KIND=dp), x21(i,i), 1_${ik}$ ) else - call stdlib_zscal( m-p-i+1, cmplx( z2*cos(phi(i-1)), 0.0_dp,KIND=dp),x21(i,i),& - 1 ) - call stdlib_zaxpy( m-p-i+1, cmplx( -z2*z3*z4*sin(phi(i-1)),0.0_dp,KIND=dp), & - x22(i,i-1), 1, x21(i,i), 1 ) + call stdlib${ii}$_zscal( m-p-i+1, cmplx( z2*cos(phi(i-1)), 0.0_dp,KIND=dp),x21(i,i),& + 1_${ik}$ ) + call stdlib${ii}$_zaxpy( m-p-i+1, cmplx( -z2*z3*z4*sin(phi(i-1)),0.0_dp,KIND=dp), & + x22(i,i-1), 1_${ik}$, x21(i,i), 1_${ik}$ ) end if - theta(i) = atan2( stdlib_dznrm2( m-p-i+1, x21(i,i), 1 ),stdlib_dznrm2( p-i+1, & - x11(i,i), 1 ) ) + theta(i) = atan2( stdlib${ii}$_dznrm2( m-p-i+1, x21(i,i), 1_${ik}$ ),stdlib${ii}$_dznrm2( p-i+1, & + x11(i,i), 1_${ik}$ ) ) if( p > i ) then - call stdlib_zlarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) + call stdlib${ii}$_zlarfgp( p-i+1, x11(i,i), x11(i+1,i), 1_${ik}$, taup1(i) ) else if ( p == i ) then - call stdlib_zlarfgp( p-i+1, x11(i,i), x11(i,i), 1, taup1(i) ) + call stdlib${ii}$_zlarfgp( p-i+1, x11(i,i), x11(i,i), 1_${ik}$, taup1(i) ) end if x11(i,i) = cone if ( m-p > i ) then - call stdlib_zlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1,taup2(i) ) + call stdlib${ii}$_zlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1_${ik}$,taup2(i) ) else if ( m-p == i ) then - call stdlib_zlarfgp( m-p-i+1, x21(i,i), x21(i,i), 1,taup2(i) ) + call stdlib${ii}$_zlarfgp( m-p-i+1, x21(i,i), x21(i,i), 1_${ik}$,taup2(i) ) end if x21(i,i) = cone if ( q > i ) then - call stdlib_zlarf( 'L', p-i+1, q-i, x11(i,i), 1,conjg(taup1(i)), x11(i,i+1), & + call stdlib${ii}$_zlarf( 'L', p-i+1, q-i, x11(i,i), 1_${ik}$,conjg(taup1(i)), x11(i,i+1), & ldx11, work ) - call stdlib_zlarf( 'L', m-p-i+1, q-i, x21(i,i), 1,conjg(taup2(i)), x21(i,i+1),& + call stdlib${ii}$_zlarf( 'L', m-p-i+1, q-i, x21(i,i), 1_${ik}$,conjg(taup2(i)), x21(i,i+1),& ldx21, work ) end if if ( m-q+1 > i ) then - call stdlib_zlarf( 'L', p-i+1, m-q-i+1, x11(i,i), 1,conjg(taup1(i)), x12(i,i),& + call stdlib${ii}$_zlarf( 'L', p-i+1, m-q-i+1, x11(i,i), 1_${ik}$,conjg(taup1(i)), x12(i,i),& ldx12, work ) - call stdlib_zlarf( 'L', m-p-i+1, m-q-i+1, x21(i,i), 1,conjg(taup2(i)), x22(i,& + call stdlib${ii}$_zlarf( 'L', m-p-i+1, m-q-i+1, x21(i,i), 1_${ik}$,conjg(taup2(i)), x22(i,& i), ldx22, work ) end if if( i < q ) then - call stdlib_zscal( q-i, cmplx( -z1*z3*sin(theta(i)), 0.0_dp,KIND=dp),x11(i,i+& - 1), ldx11 ) - call stdlib_zaxpy( q-i, cmplx( z2*z3*cos(theta(i)), 0.0_dp,KIND=dp),x21(i,i+1)& + call stdlib${ii}$_zscal( q-i, cmplx( -z1*z3*sin(theta(i)), 0.0_dp,KIND=dp),x11(i,i+& + 1_${ik}$), ldx11 ) + call stdlib${ii}$_zaxpy( q-i, cmplx( z2*z3*cos(theta(i)), 0.0_dp,KIND=dp),x21(i,i+1)& , ldx21, x11(i,i+1), ldx11 ) end if - call stdlib_zscal( m-q-i+1, cmplx( -z1*z4*sin(theta(i)), 0.0_dp,KIND=dp),x12(i,i)& + call stdlib${ii}$_zscal( m-q-i+1, cmplx( -z1*z4*sin(theta(i)), 0.0_dp,KIND=dp),x12(i,i)& , ldx12 ) - call stdlib_zaxpy( m-q-i+1, cmplx( z2*z4*cos(theta(i)), 0.0_dp,KIND=dp),x22(i,i),& + call stdlib${ii}$_zaxpy( m-q-i+1, cmplx( z2*z4*cos(theta(i)), 0.0_dp,KIND=dp),x22(i,i),& ldx22, x12(i,i), ldx12 ) - if( i < q )phi(i) = atan2( stdlib_dznrm2( q-i, x11(i,i+1), ldx11 ),stdlib_dznrm2(& + if( i < q )phi(i) = atan2( stdlib${ii}$_dznrm2( q-i, x11(i,i+1), ldx11 ),stdlib${ii}$_dznrm2(& m-q-i+1, x12(i,i), ldx12 ) ) if( i < q ) then - call stdlib_zlacgv( q-i, x11(i,i+1), ldx11 ) + call stdlib${ii}$_zlacgv( q-i, x11(i,i+1), ldx11 ) if ( i == q-1 ) then - call stdlib_zlarfgp( q-i, x11(i,i+1), x11(i,i+1), ldx11,tauq1(i) ) + call stdlib${ii}$_zlarfgp( q-i, x11(i,i+1), x11(i,i+1), ldx11,tauq1(i) ) else - call stdlib_zlarfgp( q-i, x11(i,i+1), x11(i,i+2), ldx11,tauq1(i) ) + call stdlib${ii}$_zlarfgp( q-i, x11(i,i+1), x11(i,i+2), ldx11,tauq1(i) ) end if x11(i,i+1) = cone end if if ( m-q+1 > i ) then - call stdlib_zlacgv( m-q-i+1, x12(i,i), ldx12 ) + call stdlib${ii}$_zlacgv( m-q-i+1, x12(i,i), ldx12 ) if ( m-q == i ) then - call stdlib_zlarfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,tauq2(i) ) + call stdlib${ii}$_zlarfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,tauq2(i) ) else - call stdlib_zlarfgp( m-q-i+1, x12(i,i), x12(i,i+1), ldx12,tauq2(i) ) + call stdlib${ii}$_zlarfgp( m-q-i+1, x12(i,i), x12(i,i+1), ldx12,tauq2(i) ) end if end if x12(i,i) = cone if( i < q ) then - call stdlib_zlarf( 'R', p-i, q-i, x11(i,i+1), ldx11, tauq1(i),x11(i+1,i+1), & + call stdlib${ii}$_zlarf( 'R', p-i, q-i, x11(i,i+1), ldx11, tauq1(i),x11(i+1,i+1), & ldx11, work ) - call stdlib_zlarf( 'R', m-p-i, q-i, x11(i,i+1), ldx11, tauq1(i),x21(i+1,i+1), & + call stdlib${ii}$_zlarf( 'R', m-p-i, q-i, x11(i,i+1), ldx11, tauq1(i),x21(i+1,i+1), & ldx21, work ) end if if ( p > i ) then - call stdlib_zlarf( 'R', p-i, m-q-i+1, x12(i,i), ldx12, tauq2(i),x12(i+1,i), & + call stdlib${ii}$_zlarf( 'R', p-i, m-q-i+1, x12(i,i), ldx12, tauq2(i),x12(i+1,i), & ldx12, work ) end if if ( m-p > i ) then - call stdlib_zlarf( 'R', m-p-i, m-q-i+1, x12(i,i), ldx12,tauq2(i), x22(i+1,i), & + call stdlib${ii}$_zlarf( 'R', m-p-i, m-q-i+1, x12(i,i), ldx12,tauq2(i), x22(i+1,i), & ldx22, work ) end if - if( i < q )call stdlib_zlacgv( q-i, x11(i,i+1), ldx11 ) - call stdlib_zlacgv( m-q-i+1, x12(i,i), ldx12 ) + if( i < q )call stdlib${ii}$_zlacgv( q-i, x11(i,i+1), ldx11 ) + call stdlib${ii}$_zlacgv( m-q-i+1, x12(i,i), ldx12 ) end do ! reduce columns q + 1, ..., p of x12, x22 do i = q + 1, p - call stdlib_zscal( m-q-i+1, cmplx( -z1*z4, 0.0_dp,KIND=dp), x12(i,i),ldx12 ) + call stdlib${ii}$_zscal( m-q-i+1, cmplx( -z1*z4, 0.0_dp,KIND=dp), x12(i,i),ldx12 ) - call stdlib_zlacgv( m-q-i+1, x12(i,i), ldx12 ) + call stdlib${ii}$_zlacgv( m-q-i+1, x12(i,i), ldx12 ) if ( i >= m-q ) then - call stdlib_zlarfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,tauq2(i) ) + call stdlib${ii}$_zlarfgp( m-q-i+1, x12(i,i), x12(i,i), ldx12,tauq2(i) ) else - call stdlib_zlarfgp( m-q-i+1, x12(i,i), x12(i,i+1), ldx12,tauq2(i) ) + call stdlib${ii}$_zlarfgp( m-q-i+1, x12(i,i), x12(i,i+1), ldx12,tauq2(i) ) end if x12(i,i) = cone if ( p > i ) then - call stdlib_zlarf( 'R', p-i, m-q-i+1, x12(i,i), ldx12, tauq2(i),x12(i+1,i), & + call stdlib${ii}$_zlarf( 'R', p-i, m-q-i+1, x12(i,i), ldx12, tauq2(i),x12(i+1,i), & ldx12, work ) end if - if( m-p-q >= 1 )call stdlib_zlarf( 'R', m-p-q, m-q-i+1, x12(i,i), ldx12,tauq2(i),& + if( m-p-q >= 1_${ik}$ )call stdlib${ii}$_zlarf( 'R', m-p-q, m-q-i+1, x12(i,i), ldx12,tauq2(i),& x22(q+1,i), ldx22, work ) - call stdlib_zlacgv( m-q-i+1, x12(i,i), ldx12 ) + call stdlib${ii}$_zlacgv( m-q-i+1, x12(i,i), ldx12 ) end do ! reduce columns p + 1, ..., m - q of x12, x22 do i = 1, m - p - q - call stdlib_zscal( m-p-q-i+1, cmplx( z2*z4, 0.0_dp,KIND=dp),x22(q+i,p+i), ldx22 ) + call stdlib${ii}$_zscal( m-p-q-i+1, cmplx( z2*z4, 0.0_dp,KIND=dp),x22(q+i,p+i), ldx22 ) - call stdlib_zlacgv( m-p-q-i+1, x22(q+i,p+i), ldx22 ) - call stdlib_zlarfgp( m-p-q-i+1, x22(q+i,p+i), x22(q+i,p+i+1),ldx22, tauq2(p+i) ) + call stdlib${ii}$_zlacgv( m-p-q-i+1, x22(q+i,p+i), ldx22 ) + call stdlib${ii}$_zlarfgp( m-p-q-i+1, x22(q+i,p+i), x22(q+i,p+i+1),ldx22, tauq2(p+i) ) x22(q+i,p+i) = cone - call stdlib_zlarf( 'R', m-p-q-i, m-p-q-i+1, x22(q+i,p+i), ldx22,tauq2(p+i), x22(& + call stdlib${ii}$_zlarf( 'R', m-p-q-i, m-p-q-i+1, x22(q+i,p+i), ldx22,tauq2(p+i), x22(& q+i+1,p+i), ldx22, work ) - call stdlib_zlacgv( m-p-q-i+1, x22(q+i,p+i), ldx22 ) + call stdlib${ii}$_zlacgv( m-p-q-i+1, x22(q+i,p+i), ldx22 ) end do else ! reduce columns 1, ..., q of x11, x12, x21, x22 do i = 1, q - if( i == 1 ) then - call stdlib_zscal( p-i+1, cmplx( z1, 0.0_dp,KIND=dp), x11(i,i),ldx11 ) + if( i == 1_${ik}$ ) then + call stdlib${ii}$_zscal( p-i+1, cmplx( z1, 0.0_dp,KIND=dp), x11(i,i),ldx11 ) else - call stdlib_zscal( p-i+1, cmplx( z1*cos(phi(i-1)), 0.0_dp,KIND=dp),x11(i,i), & + call stdlib${ii}$_zscal( p-i+1, cmplx( z1*cos(phi(i-1)), 0.0_dp,KIND=dp),x11(i,i), & ldx11 ) - call stdlib_zaxpy( p-i+1, cmplx( -z1*z3*z4*sin(phi(i-1)),0.0_dp,KIND=dp), x12(& + call stdlib${ii}$_zaxpy( p-i+1, cmplx( -z1*z3*z4*sin(phi(i-1)),0.0_dp,KIND=dp), x12(& i-1,i), ldx12, x11(i,i), ldx11 ) end if - if( i == 1 ) then - call stdlib_zscal( m-p-i+1, cmplx( z2, 0.0_dp,KIND=dp), x21(i,i),ldx21 ) + if( i == 1_${ik}$ ) then + call stdlib${ii}$_zscal( m-p-i+1, cmplx( z2, 0.0_dp,KIND=dp), x21(i,i),ldx21 ) else - call stdlib_zscal( m-p-i+1, cmplx( z2*cos(phi(i-1)), 0.0_dp,KIND=dp),x21(i,i),& + call stdlib${ii}$_zscal( m-p-i+1, cmplx( z2*cos(phi(i-1)), 0.0_dp,KIND=dp),x21(i,i),& ldx21 ) - call stdlib_zaxpy( m-p-i+1, cmplx( -z2*z3*z4*sin(phi(i-1)),0.0_dp,KIND=dp), & + call stdlib${ii}$_zaxpy( m-p-i+1, cmplx( -z2*z3*z4*sin(phi(i-1)),0.0_dp,KIND=dp), & x22(i-1,i), ldx22, x21(i,i), ldx21 ) end if - theta(i) = atan2( stdlib_dznrm2( m-p-i+1, x21(i,i), ldx21 ),stdlib_dznrm2( p-i+1,& + theta(i) = atan2( stdlib${ii}$_dznrm2( m-p-i+1, x21(i,i), ldx21 ),stdlib${ii}$_dznrm2( p-i+1,& x11(i,i), ldx11 ) ) - call stdlib_zlacgv( p-i+1, x11(i,i), ldx11 ) - call stdlib_zlacgv( m-p-i+1, x21(i,i), ldx21 ) - call stdlib_zlarfgp( p-i+1, x11(i,i), x11(i,i+1), ldx11, taup1(i) ) + call stdlib${ii}$_zlacgv( p-i+1, x11(i,i), ldx11 ) + call stdlib${ii}$_zlacgv( m-p-i+1, x21(i,i), ldx21 ) + call stdlib${ii}$_zlarfgp( p-i+1, x11(i,i), x11(i,i+1), ldx11, taup1(i) ) x11(i,i) = cone if ( i == m-p ) then - call stdlib_zlarfgp( m-p-i+1, x21(i,i), x21(i,i), ldx21,taup2(i) ) + call stdlib${ii}$_zlarfgp( m-p-i+1, x21(i,i), x21(i,i), ldx21,taup2(i) ) else - call stdlib_zlarfgp( m-p-i+1, x21(i,i), x21(i,i+1), ldx21,taup2(i) ) + call stdlib${ii}$_zlarfgp( m-p-i+1, x21(i,i), x21(i,i+1), ldx21,taup2(i) ) end if x21(i,i) = cone - call stdlib_zlarf( 'R', q-i, p-i+1, x11(i,i), ldx11, taup1(i),x11(i+1,i), ldx11, & + call stdlib${ii}$_zlarf( 'R', q-i, p-i+1, x11(i,i), ldx11, taup1(i),x11(i+1,i), ldx11, & work ) - call stdlib_zlarf( 'R', m-q-i+1, p-i+1, x11(i,i), ldx11, taup1(i),x12(i,i), & + call stdlib${ii}$_zlarf( 'R', m-q-i+1, p-i+1, x11(i,i), ldx11, taup1(i),x12(i,i), & ldx12, work ) - call stdlib_zlarf( 'R', q-i, m-p-i+1, x21(i,i), ldx21, taup2(i),x21(i+1,i), & + call stdlib${ii}$_zlarf( 'R', q-i, m-p-i+1, x21(i,i), ldx21, taup2(i),x21(i+1,i), & ldx21, work ) - call stdlib_zlarf( 'R', m-q-i+1, m-p-i+1, x21(i,i), ldx21,taup2(i), x22(i,i), & + call stdlib${ii}$_zlarf( 'R', m-q-i+1, m-p-i+1, x21(i,i), ldx21,taup2(i), x22(i,i), & ldx22, work ) - call stdlib_zlacgv( p-i+1, x11(i,i), ldx11 ) - call stdlib_zlacgv( m-p-i+1, x21(i,i), ldx21 ) + call stdlib${ii}$_zlacgv( p-i+1, x11(i,i), ldx11 ) + call stdlib${ii}$_zlacgv( m-p-i+1, x21(i,i), ldx21 ) if( i < q ) then - call stdlib_zscal( q-i, cmplx( -z1*z3*sin(theta(i)), 0.0_dp,KIND=dp),x11(i+1,& - i), 1 ) - call stdlib_zaxpy( q-i, cmplx( z2*z3*cos(theta(i)), 0.0_dp,KIND=dp),x21(i+1,i)& - , 1, x11(i+1,i), 1 ) - end if - call stdlib_zscal( m-q-i+1, cmplx( -z1*z4*sin(theta(i)), 0.0_dp,KIND=dp),x12(i,i)& - , 1 ) - call stdlib_zaxpy( m-q-i+1, cmplx( z2*z4*cos(theta(i)), 0.0_dp,KIND=dp),x22(i,i),& - 1, x12(i,i), 1 ) - if( i < q )phi(i) = atan2( stdlib_dznrm2( q-i, x11(i+1,i), 1 ),stdlib_dznrm2( m-& - q-i+1, x12(i,i), 1 ) ) + call stdlib${ii}$_zscal( q-i, cmplx( -z1*z3*sin(theta(i)), 0.0_dp,KIND=dp),x11(i+1,& + i), 1_${ik}$ ) + call stdlib${ii}$_zaxpy( q-i, cmplx( z2*z3*cos(theta(i)), 0.0_dp,KIND=dp),x21(i+1,i)& + , 1_${ik}$, x11(i+1,i), 1_${ik}$ ) + end if + call stdlib${ii}$_zscal( m-q-i+1, cmplx( -z1*z4*sin(theta(i)), 0.0_dp,KIND=dp),x12(i,i)& + , 1_${ik}$ ) + call stdlib${ii}$_zaxpy( m-q-i+1, cmplx( z2*z4*cos(theta(i)), 0.0_dp,KIND=dp),x22(i,i),& + 1_${ik}$, x12(i,i), 1_${ik}$ ) + if( i < q )phi(i) = atan2( stdlib${ii}$_dznrm2( q-i, x11(i+1,i), 1_${ik}$ ),stdlib${ii}$_dznrm2( m-& + q-i+1, x12(i,i), 1_${ik}$ ) ) if( i < q ) then - call stdlib_zlarfgp( q-i, x11(i+1,i), x11(i+2,i), 1, tauq1(i) ) + call stdlib${ii}$_zlarfgp( q-i, x11(i+1,i), x11(i+2,i), 1_${ik}$, tauq1(i) ) x11(i+1,i) = cone end if - call stdlib_zlarfgp( m-q-i+1, x12(i,i), x12(i+1,i), 1, tauq2(i) ) + call stdlib${ii}$_zlarfgp( m-q-i+1, x12(i,i), x12(i+1,i), 1_${ik}$, tauq2(i) ) x12(i,i) = cone if( i < q ) then - call stdlib_zlarf( 'L', q-i, p-i, x11(i+1,i), 1,conjg(tauq1(i)), x11(i+1,i+1),& + call stdlib${ii}$_zlarf( 'L', q-i, p-i, x11(i+1,i), 1_${ik}$,conjg(tauq1(i)), x11(i+1,i+1),& ldx11, work ) - call stdlib_zlarf( 'L', q-i, m-p-i, x11(i+1,i), 1,conjg(tauq1(i)), x21(i+1,i+& - 1), ldx21, work ) + call stdlib${ii}$_zlarf( 'L', q-i, m-p-i, x11(i+1,i), 1_${ik}$,conjg(tauq1(i)), x21(i+1,i+& + 1_${ik}$), ldx21, work ) end if - call stdlib_zlarf( 'L', m-q-i+1, p-i, x12(i,i), 1,conjg(tauq2(i)), x12(i,i+1), & + call stdlib${ii}$_zlarf( 'L', m-q-i+1, p-i, x12(i,i), 1_${ik}$,conjg(tauq2(i)), x12(i,i+1), & ldx12, work ) if ( m-p > i ) then - call stdlib_zlarf( 'L', m-q-i+1, m-p-i, x12(i,i), 1,conjg(tauq2(i)), x22(i,i+& - 1), ldx22, work ) + call stdlib${ii}$_zlarf( 'L', m-q-i+1, m-p-i, x12(i,i), 1_${ik}$,conjg(tauq2(i)), x22(i,i+& + 1_${ik}$), ldx22, work ) end if end do ! reduce columns q + 1, ..., p of x12, x22 do i = q + 1, p - call stdlib_zscal( m-q-i+1, cmplx( -z1*z4, 0.0_dp,KIND=dp), x12(i,i), 1 ) - call stdlib_zlarfgp( m-q-i+1, x12(i,i), x12(i+1,i), 1, tauq2(i) ) + call stdlib${ii}$_zscal( m-q-i+1, cmplx( -z1*z4, 0.0_dp,KIND=dp), x12(i,i), 1_${ik}$ ) + call stdlib${ii}$_zlarfgp( m-q-i+1, x12(i,i), x12(i+1,i), 1_${ik}$, tauq2(i) ) x12(i,i) = cone if ( p > i ) then - call stdlib_zlarf( 'L', m-q-i+1, p-i, x12(i,i), 1,conjg(tauq2(i)), x12(i,i+1),& + call stdlib${ii}$_zlarf( 'L', m-q-i+1, p-i, x12(i,i), 1_${ik}$,conjg(tauq2(i)), x12(i,i+1),& ldx12, work ) end if - if( m-p-q >= 1 )call stdlib_zlarf( 'L', m-q-i+1, m-p-q, x12(i,i), 1,conjg(tauq2(& + if( m-p-q >= 1_${ik}$ )call stdlib${ii}$_zlarf( 'L', m-q-i+1, m-p-q, x12(i,i), 1_${ik}$,conjg(tauq2(& i)), x22(i,q+1), ldx22, work ) end do ! reduce columns p + 1, ..., m - q of x12, x22 do i = 1, m - p - q - call stdlib_zscal( m-p-q-i+1, cmplx( z2*z4, 0.0_dp,KIND=dp),x22(p+i,q+i), 1 ) + call stdlib${ii}$_zscal( m-p-q-i+1, cmplx( z2*z4, 0.0_dp,KIND=dp),x22(p+i,q+i), 1_${ik}$ ) - call stdlib_zlarfgp( m-p-q-i+1, x22(p+i,q+i), x22(p+i+1,q+i), 1,tauq2(p+i) ) + call stdlib${ii}$_zlarfgp( m-p-q-i+1, x22(p+i,q+i), x22(p+i+1,q+i), 1_${ik}$,tauq2(p+i) ) x22(p+i,q+i) = cone if ( m-p-q /= i ) then - call stdlib_zlarf( 'L', m-p-q-i+1, m-p-q-i, x22(p+i,q+i), 1,conjg(tauq2(p+i)),& + call stdlib${ii}$_zlarf( 'L', m-p-q-i+1, m-p-q-i, x22(p+i,q+i), 1_${ik}$,conjg(tauq2(p+i)),& x22(p+i,q+i+1), ldx22,work ) end if end do end if return - end subroutine stdlib_zunbdb + end subroutine stdlib${ii}$_zunbdb - pure subroutine stdlib_zunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & + pure subroutine stdlib${ii}$_zunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & !! ZUNBDB6 orthogonalizes the column vector !! X = [ X1 ] !! [ X2 ] @@ -29638,8 +29641,8 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(in) :: q1(ldq1,*), q2(ldq2,*) complex(dp), intent(out) :: work(*) @@ -29652,60 +29655,60 @@ module stdlib_linalg_lapack_z ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i real(dp) :: 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( 'ZUNBDB6', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZUNBDB6', -info ) return end if ! first, project x onto the orthogonal complement of q's column ! space scl1 = realzero ssq1 = realone - call stdlib_zlassq( m1, x1, incx1, scl1, ssq1 ) + call stdlib${ii}$_zlassq( m1, x1, incx1, scl1, ssq1 ) scl2 = realzero ssq2 = realone - call stdlib_zlassq( m2, x2, incx2, scl2, ssq2 ) - normsq1 = scl1**2*ssq1 + scl2**2*ssq2 - if( m1 == 0 ) then + call stdlib${ii}$_zlassq( 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) = czero end do else - call stdlib_zgemv( 'C', m1, n, cone, q1, ldq1, x1, incx1, czero, work,1 ) + call stdlib${ii}$_zgemv( 'C', m1, n, cone, q1, ldq1, x1, incx1, czero, work,1_${ik}$ ) end if - call stdlib_zgemv( 'C', m2, n, cone, q2, ldq2, x2, incx2, cone, work, 1 ) - call stdlib_zgemv( 'N', m1, n, cnegone, q1, ldq1, work, 1, cone, x1,incx1 ) - call stdlib_zgemv( 'N', m2, n, cnegone, q2, ldq2, work, 1, cone, x2,incx2 ) + call stdlib${ii}$_zgemv( 'C', m2, n, cone, q2, ldq2, x2, incx2, cone, work, 1_${ik}$ ) + call stdlib${ii}$_zgemv( 'N', m1, n, cnegone, q1, ldq1, work, 1_${ik}$, cone, x1,incx1 ) + call stdlib${ii}$_zgemv( 'N', m2, n, cnegone, q2, ldq2, work, 1_${ik}$, cone, x2,incx2 ) scl1 = realzero ssq1 = realone - call stdlib_zlassq( m1, x1, incx1, scl1, ssq1 ) + call stdlib${ii}$_zlassq( m1, x1, incx1, scl1, ssq1 ) scl2 = realzero ssq2 = realone - call stdlib_zlassq( m2, x2, incx2, scl2, ssq2 ) - normsq2 = scl1**2*ssq1 + scl2**2*ssq2 + call stdlib${ii}$_zlassq( 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 czero, then stop. ! otherwise, project again. @@ -29719,23 +29722,23 @@ module stdlib_linalg_lapack_z do i = 1, n work(i) = czero end do - if( m1 == 0 ) then + if( m1 == 0_${ik}$ ) then do i = 1, n work(i) = czero end do else - call stdlib_zgemv( 'C', m1, n, cone, q1, ldq1, x1, incx1, czero, work,1 ) + call stdlib${ii}$_zgemv( 'C', m1, n, cone, q1, ldq1, x1, incx1, czero, work,1_${ik}$ ) end if - call stdlib_zgemv( 'C', m2, n, cone, q2, ldq2, x2, incx2, cone, work, 1 ) - call stdlib_zgemv( 'N', m1, n, cnegone, q1, ldq1, work, 1, cone, x1,incx1 ) - call stdlib_zgemv( 'N', m2, n, cnegone, q2, ldq2, work, 1, cone, x2,incx2 ) + call stdlib${ii}$_zgemv( 'C', m2, n, cone, q2, ldq2, x2, incx2, cone, work, 1_${ik}$ ) + call stdlib${ii}$_zgemv( 'N', m1, n, cnegone, q1, ldq1, work, 1_${ik}$, cone, x1,incx1 ) + call stdlib${ii}$_zgemv( 'N', m2, n, cnegone, q2, ldq2, work, 1_${ik}$, cone, x2,incx2 ) scl1 = realzero ssq1 = realone - call stdlib_zlassq( m1, x1, incx1, scl1, ssq1 ) + call stdlib${ii}$_zlassq( m1, x1, incx1, scl1, ssq1 ) scl2 = realzero ssq2 = realone - call stdlib_zlassq( m1, x1, incx1, scl1, ssq1 ) - normsq2 = scl1**2*ssq1 + scl2**2*ssq2 + call stdlib${ii}$_zlassq( 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 czero. @@ -29748,10 +29751,10 @@ module stdlib_linalg_lapack_z end do end if return - end subroutine stdlib_zunbdb6 + end subroutine stdlib${ii}$_zunbdb6 - pure subroutine stdlib_zung2l( m, n, k, a, lda, tau, work, info ) + pure subroutine stdlib${ii}$_zung2l( m, n, k, a, lda, tau, work, info ) !! ZUNG2L generates an m by n complex matrix Q with orthonormal columns, !! which is defined as the last n columns of a product of k elementary !! reflectors of order m @@ -29761,8 +29764,8 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: tau(*) @@ -29770,23 +29773,23 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! 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_zlarft( 'FORWARD', 'ROWWISE', n-i+1, ib, a( i, i ),lda, tau( i ), & + call stdlib${ii}$_zlarft( 'FORWARD', 'ROWWISE', n-i+1, ib, a( i, i ),lda, tau( i ), & work, ldwork ) ! apply h**h to a(i+ib:m,i:n) from the right - call stdlib_zlarfb( 'RIGHT', 'CONJUGATE TRANSPOSE', 'FORWARD','ROWWISE', m-i-& + call stdlib${ii}$_zlarfb( 'RIGHT', 'CONJUGATE TRANSPOSE', 'FORWARD','ROWWISE', m-i-& ib+1, n-i+1, ib, a( i, i ),lda, work, ldwork, a( i+ib, i ), lda,work( ib+1 ), & ldwork ) end if ! apply h**h to columns i:n of current block - call stdlib_zungl2( ib, n-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) + call stdlib${ii}$_zungl2( ib, n-i+1, ib, a( i, i ), lda, tau( i ), work,iinfo ) ! set columns 1:i-1 of current block to czero do j = 1, i - 1 do l = i, i + ib - 1 @@ -30062,12 +30065,12 @@ module stdlib_linalg_lapack_z end do end do end if - work( 1 ) = iws + work( 1_${ik}$ ) = iws return - end subroutine stdlib_zunglq + end subroutine stdlib${ii}$_zunglq - pure subroutine stdlib_zungql( m, n, k, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_zungql( m, n, k, a, lda, tau, work, lwork, info ) !! ZUNGQL generates an M-by-N complex matrix Q with orthonormal columns, !! which is defined as the last N columns of a product of K elementary !! reflectors of order M @@ -30077,8 +30080,8 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: tau(*) @@ -30087,50 +30090,50 @@ module stdlib_linalg_lapack_z ! 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}$_zung2l( 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_zlarft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1, n-k+i ), & + call stdlib${ii}$_zlarft( '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_zlarfb( '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 ) + call stdlib${ii}$_zlarfb( '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_zung2l( m-k+i+ib-1, ib, ib, a( 1, n-k+i ), lda,tau( i ), work, iinfo & + call stdlib${ii}$_zung2l( 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 czero do j = n - k + i, n - k + i + ib - 1 @@ -30183,12 +30186,12 @@ module stdlib_linalg_lapack_z end do end do end if - work( 1 ) = iws + work( 1_${ik}$ ) = iws return - end subroutine stdlib_zungql + end subroutine stdlib${ii}$_zungql - pure subroutine stdlib_zungqr( m, n, k, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_zungqr( m, n, k, a, lda, tau, work, lwork, info ) !! ZUNGQR generates an M-by-N complex matrix Q with orthonormal columns, !! which is defined as the first N columns of a product of K elementary !! reflectors of order M @@ -30198,8 +30201,8 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: tau(*) @@ -30208,44 +30211,44 @@ module stdlib_linalg_lapack_z ! 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, 'ZUNGQR', ' ', 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_zlarft( 'FORWARD', 'COLUMNWISE', m-i+1, ib,a( i, i ), lda, tau( i & + call stdlib${ii}$_zlarft( '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_zlarfb( 'LEFT', 'NO TRANSPOSE', 'FORWARD','COLUMNWISE', m-i+1, n-& + call stdlib${ii}$_zlarfb( '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_zung2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work,iinfo ) + call stdlib${ii}$_zung2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work,iinfo ) ! set rows 1:i-1 of current block to czero do j = i, i + ib - 1 do l = 1, i - 1 @@ -30299,12 +30302,12 @@ module stdlib_linalg_lapack_z end do end do end if - work( 1 ) = iws + work( 1_${ik}$ ) = iws return - end subroutine stdlib_zungqr + end subroutine stdlib${ii}$_zungqr - pure subroutine stdlib_zungr2( m, n, k, a, lda, tau, work, info ) + pure subroutine stdlib${ii}$_zungr2( m, n, k, a, lda, tau, work, info ) !! ZUNGR2 generates an m by n complex matrix Q with orthonormal rows, !! which is defined as the last m rows of a product of k elementary !! reflectors of order n @@ -30314,8 +30317,8 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: tau(*) @@ -30323,23 +30326,23 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ii, j, l + integer(${ik}$) :: i, ii, j, l ! Intrinsic Functions intrinsic :: conjg,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}$_zungr2( 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_zlarft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( ii, 1 ), lda, & + call stdlib${ii}$_zlarft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( ii, 1_${ik}$ ), lda, & tau( i ), work, ldwork ) ! apply h**h to a(1:m-k+i-1,1:n-k+i+ib-1) from the right - call stdlib_zlarfb( 'RIGHT', 'CONJUGATE TRANSPOSE', 'BACKWARD','ROWWISE', ii-& - 1, n-k+i+ib-1, ib, a( ii, 1 ),lda, work, ldwork, a, lda, work( ib+1 ),ldwork ) + call stdlib${ii}$_zlarfb( 'RIGHT', 'CONJUGATE TRANSPOSE', 'BACKWARD','ROWWISE', ii-& + 1_${ik}$, n-k+i+ib-1, ib, a( ii, 1_${ik}$ ),lda, work, ldwork, a, lda, work( ib+1 ),ldwork ) end if ! apply h**h to columns 1:n-k+i+ib-1 of current block - call stdlib_zungr2( ib, n-k+i+ib-1, ib, a( ii, 1 ), lda, tau( i ),work, iinfo ) + call stdlib${ii}$_zungr2( 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 czero do l = n - k + i + ib, n @@ -30489,12 +30492,12 @@ module stdlib_linalg_lapack_z end do end do end if - work( 1 ) = iws + work( 1_${ik}$ ) = iws return - end subroutine stdlib_zungrq + end subroutine stdlib${ii}$_zungrq - pure subroutine stdlib_zungtsqr_row( m, n, mb, nb, a, lda, t, ldt, work,lwork, info ) + pure subroutine stdlib${ii}$_zungtsqr_row( m, n, mb, nb, a, lda, t, ldt, work,lwork, info ) !! ZUNGTSQR_ROW generates an M-by-N complex matrix Q_out with !! orthonormal columns from the output of ZLATSQR. These N orthonormal !! columns are the first N columns of a product of complex unitary @@ -30514,8 +30517,8 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: t(ldt,*) @@ -30524,55 +30527,55 @@ module stdlib_linalg_lapack_z ! 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 - complex(dp) :: dummy(1,1) + complex(dp) :: dummy(1_${ik}$,1_${ik}$) ! Intrinsic Functions intrinsic :: cmplx,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 ( mbnq ) 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_zunml2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib${ii}$_zunml2( 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 = 'C' @@ -31249,28 +31252,28 @@ module stdlib_linalg_lapack_z 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_zlarft( 'FORWARD', 'ROWWISE', nq-i+1, ib, a( i, i ),lda, tau( i ), & + call stdlib${ii}$_zlarft( 'FORWARD', 'ROWWISE', nq-i+1, ib, a( i, i ),lda, tau( i ), & work( iwt ), ldt ) if( left ) then ! h or h**h is applied to c(i:m,1:n) - mi = m - i + 1 + mi = m - i + 1_${ik}$ ic = i else ! h or h**h is applied to c(1:m,i:n) - ni = n - i + 1 + ni = n - i + 1_${ik}$ jc = i end if ! apply h or h**h - call stdlib_zlarfb( side, transt, 'FORWARD', 'ROWWISE', mi, ni, ib,a( i, i ), & + call stdlib${ii}$_zlarfb( 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_zunmlq + end subroutine stdlib${ii}$_zunmlq - pure subroutine stdlib_zunmql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) + pure subroutine stdlib${ii}$_zunmql( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) !! ZUNMQL overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -31286,97 +31289,97 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: a(lda,*), c(ldc,*) complex(dp), intent(in) :: tau(*) complex(dp), 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, 'C' ) ) 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_zunm2l( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib${ii}$_zunm2l( 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 @@ -31388,26 +31391,26 @@ module stdlib_linalg_lapack_z 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_zlarft( 'BACKWARD', 'COLUMNWISE', nq-k+i+ib-1, ib,a( 1, i ), lda, & + call stdlib${ii}$_zlarft( 'BACKWARD', 'COLUMNWISE', nq-k+i+ib-1, ib,a( 1_${ik}$, i ), lda, & tau( i ), work( iwt ), ldt ) if( left ) then ! h or h**h is applied to c(1:m-k+i+ib-1,1:n) - mi = m - k + i + ib - 1 + mi = m - k + i + ib - 1_${ik}$ else ! h or h**h is applied to c(1:m,1:n-k+i+ib-1) - ni = n - k + i + ib - 1 + ni = n - k + i + ib - 1_${ik}$ end if ! apply h or h**h - call stdlib_zlarfb( side, trans, 'BACKWARD', 'COLUMNWISE', mi, ni,ib, a( 1, i ), & + call stdlib${ii}$_zlarfb( 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_zunmql + end subroutine stdlib${ii}$_zunmql - pure subroutine stdlib_zunmqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) + pure subroutine stdlib${ii}$_zunmqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, info ) !! ZUNMQR overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -31423,128 +31426,128 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: a(lda,*), c(ldc,*) complex(dp), intent(in) :: tau(*) complex(dp), 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, 'C' ) ) 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_zunm2r( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib${ii}$_zunm2r( 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_zlarft( 'FORWARD', 'COLUMNWISE', nq-i+1, ib, a( i, i ),lda, tau( i ),& + call stdlib${ii}$_zlarft( 'FORWARD', 'COLUMNWISE', nq-i+1, ib, a( i, i ),lda, tau( i ),& work( iwt ), ldt ) if( left ) then ! h or h**h is applied to c(i:m,1:n) - mi = m - i + 1 + mi = m - i + 1_${ik}$ ic = i else ! h or h**h is applied to c(1:m,i:n) - ni = n - i + 1 + ni = n - i + 1_${ik}$ jc = i end if ! apply h or h**h - call stdlib_zlarfb( side, trans, 'FORWARD', 'COLUMNWISE', mi, ni,ib, a( i, i ), & + call stdlib${ii}$_zlarfb( 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_zunmqr + end subroutine stdlib${ii}$_zunmqr - pure subroutine stdlib_zunmr2( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) + pure subroutine stdlib${ii}$_zunmr2( side, trans, m, n, k, a, lda, tau, c, ldc,work, info ) !! ZUNMR2 overwrites the general complex m-by-n matrix C with !! Q * C if SIDE = 'L' and TRANS = 'N', or !! Q**H* C if SIDE = 'L' and TRANS = 'C', or @@ -31560,8 +31563,8 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: a(lda,*), c(ldc,*) complex(dp), intent(in) :: tau(*) @@ -31570,13 +31573,13 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: left, notran - integer(ilp) :: i, i1, i2, i3, mi, ni, nq + integer(${ik}$) :: i, i1, i2, i3, mi, ni, nq complex(dp) :: aii, taui ! Intrinsic Functions intrinsic :: conjg,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 @@ -31586,34 +31589,34 @@ module stdlib_linalg_lapack_z 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, 'C' ) ) 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_zunmr2( side, trans, m, n, k, a, lda, tau, c, ldc, work,iinfo ) + call stdlib${ii}$_zunmr2( 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 @@ -31874,26 +31877,26 @@ module stdlib_linalg_lapack_z 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_zlarft( 'BACKWARD', 'ROWWISE', nq-k+i+ib-1, ib,a( i, 1 ), lda, tau( & + call stdlib${ii}$_zlarft( 'BACKWARD', 'ROWWISE', nq-k+i+ib-1, ib,a( i, 1_${ik}$ ), lda, tau( & i ), work( iwt ), ldt ) if( left ) then ! h or h**h is applied to c(1:m-k+i+ib-1,1:n) - mi = m - k + i + ib - 1 + mi = m - k + i + ib - 1_${ik}$ else ! h or h**h is applied to c(1:m,1:n-k+i+ib-1) - ni = n - k + i + ib - 1 + ni = n - k + i + ib - 1_${ik}$ end if ! apply h or h**h - call stdlib_zlarfb( side, transt, 'BACKWARD', 'ROWWISE', mi, ni,ib, a( i, 1 ), & + call stdlib${ii}$_zlarfb( 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_zunmrq + end subroutine stdlib${ii}$_zunmrq - pure subroutine stdlib_zunmrz( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, lwork, & + pure subroutine stdlib${ii}$_zunmrz( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, lwork, & !! ZUNMRZ overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -31909,114 +31912,114 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: a(lda,*), c(ldc,*) complex(dp), intent(in) :: tau(*) complex(dp), 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, 'C' ) ) 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_zunmr3( side, trans, m, n, k, l, a, lda, tau, c, ldc,work, iinfo ) + call stdlib${ii}$_zunmr3( 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 = 'C' @@ -32027,28 +32030,28 @@ module stdlib_linalg_lapack_z 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_zlarzt( 'BACKWARD', 'ROWWISE', l, ib, a( i, ja ), lda,tau( i ), work(& + call stdlib${ii}$_zlarzt( 'BACKWARD', 'ROWWISE', l, ib, a( i, ja ), lda,tau( i ), work(& iwt ), ldt ) if( left ) then ! h or h**h is applied to c(i:m,1:n) - mi = m - i + 1 + mi = m - i + 1_${ik}$ ic = i else ! h or h**h is applied to c(1:m,i:n) - ni = n - i + 1 + ni = n - i + 1_${ik}$ jc = i end if ! apply h or h**h - call stdlib_zlarzb( side, transt, 'BACKWARD', 'ROWWISE', mi, ni,ib, l, a( i, ja )& + call stdlib${ii}$_zlarzb( 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_zunmrz + end subroutine stdlib${ii}$_zunmrz - pure subroutine stdlib_zbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, phi, u1, & + pure subroutine stdlib${ii}$_zbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, phi, u1, & !! ZBBCSD computes the CS decomposition of a unitary matrix in !! bidiagonal-block form, !! [ B11 | B12 0 0 ] @@ -32077,8 +32080,8 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobu1, jobu2, jobv1t, jobv2t, trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldu1, ldu2, ldv1t, ldv2t, lrwork, m, p, q + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldu1, ldu2, ldv1t, ldv2t, lrwork, m, p, q ! Array Arguments real(dp), intent(out) :: b11d(*), b11e(*), b12d(*), b12e(*), b21d(*), b21e(*), b22d(*),& b22e(*), rwork(*) @@ -32087,7 +32090,7 @@ module stdlib_linalg_lapack_z ! =================================================================== ! Parameters - integer(ilp), parameter :: maxitr = 6 + integer(${ik}$), parameter :: maxitr = 6_${ik}$ real(dp), parameter :: hundred = 100.0_dp real(dp), parameter :: meighth = -0.125_dp real(dp), parameter :: piover2 = 1.57079632679489661923132169163975144210_dp @@ -32098,7 +32101,7 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: colmajor, lquery, restart11, restart12, restart21, restart22, wantu1, & wantu2, wantv1t, wantv2t - integer(ilp) :: i, imin, imax, iter, iu1cs, iu1sn, iu2cs, iu2sn, iv1tcs, iv1tsn, & + integer(${ik}$) :: i, imin, imax, iter, iu1cs, iu1sn, iu2cs, iu2sn, iv1tcs, iv1tsn, & iv2tcs, iv2tsn, j, lrworkmin, lrworkopt, maxit, mini real(dp) :: b11bulge, b12bulge, b21bulge, b22bulge, dummy, eps, mu, nu, r, sigma11, & sigma21, temp, thetamax, thetamin, thresh, tol, tolmul, unfl, x1, x2, y1, y2 @@ -32106,39 +32109,39 @@ module stdlib_linalg_lapack_z intrinsic :: abs,atan2,cos,max,min,sin,sqrt ! Executable Statements ! test input arguments - info = 0 - lquery = lrwork == -1 + info = 0_${ik}$ + lquery = lrwork == -1_${ik}$ wantu1 = stdlib_lsame( jobu1, 'Y' ) wantu2 = stdlib_lsame( jobu2, 'Y' ) wantv1t = stdlib_lsame( jobv1t, 'Y' ) wantv2t = stdlib_lsame( jobv2t, 'Y' ) colmajor = .not. stdlib_lsame( trans, 'T' ) - if( m < 0 ) then - info = -6 - else if( p < 0 .or. p > 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 - lrworkmin = 1 - rwork(1) = lrworkmin + if( info == 0_${ik}$ .and. q == 0_${ik}$ ) then + lrworkmin = 1_${ik}$ + rwork(1_${ik}$) = lrworkmin 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 @@ -32146,22 +32149,22 @@ module stdlib_linalg_lapack_z iv1tsn = iv1tcs + q iv2tcs = iv1tsn + q iv2tsn = iv2tcs + q - lrworkopt = iv2tsn + q - 1 + lrworkopt = iv2tsn + q - 1_${ik}$ lrworkmin = lrworkopt - rwork(1) = lrworkopt + rwork(1_${ik}$) = lrworkopt if( lrwork < lrworkmin .and. .not. lquery ) then - info = -28 + info = -28_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'ZBBCSD', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZBBCSD', -info ) return else if( lquery ) then return end if ! get machine constants - eps = stdlib_dlamch( 'EPSILON' ) - unfl = stdlib_dlamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_dlamch( 'EPSILON' ) + unfl = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) tolmul = max( ten, min( hundred, eps**meighth ) ) tol = tolmul*eps thresh = max( tol, maxitr*q*q*unfl ) @@ -32186,18 +32189,18 @@ module stdlib_linalg_lapack_z 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 @@ -32217,9 +32220,9 @@ module stdlib_linalg_lapack_z 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 @@ -32243,20 +32246,20 @@ module stdlib_linalg_lapack_z nu = zero else ! compute shifts for b11 and b21 and use the lesser - call stdlib_dlas2( b11d(imax-1), b11e(imax-1), b11d(imax), sigma11,dummy ) + call stdlib${ii}$_dlas2( b11d(imax-1), b11e(imax-1), b11d(imax), sigma11,dummy ) - call stdlib_dlas2( b21d(imax-1), b21e(imax-1), b21d(imax), sigma21,dummy ) + call stdlib${ii}$_dlas2( 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_dp - nu**2 ) + mu = sqrt( 1.0_dp - nu**2_${ik}$ ) if( nu < thresh ) then mu = one nu = zero @@ -32265,10 +32268,10 @@ module stdlib_linalg_lapack_z end if ! rotate to produce bulges in b11 and b21 if( mu <= nu ) then - call stdlib_dlartgs( b11d(imin), b11e(imin), mu,rwork(iv1tcs+imin-1), rwork(& + call stdlib${ii}$_dlartgs( b11d(imin), b11e(imin), mu,rwork(iv1tcs+imin-1), rwork(& iv1tsn+imin-1) ) else - call stdlib_dlartgs( b21d(imin), b21e(imin), nu,rwork(iv1tcs+imin-1), rwork(& + call stdlib${ii}$_dlartgs( b21d(imin), b21e(imin), nu,rwork(iv1tcs+imin-1), rwork(& iv1tsn+imin-1) ) end if temp = rwork(iv1tcs+imin-1)*b11d(imin) +rwork(iv1tsn+imin-1)*b11e(imin) @@ -32284,27 +32287,27 @@ module stdlib_linalg_lapack_z b21bulge = rwork(iv1tsn+imin-1)*b21d(imin+1) b21d(imin+1) = rwork(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_dlartgp( b11bulge, b11d(imin), rwork(iu1sn+imin-1),rwork(iu1cs+imin-& - 1), r ) + if( b11d(imin)**2_${ik}$+b11bulge**2_${ik}$ > thresh**2_${ik}$ ) then + call stdlib${ii}$_dlartgp( b11bulge, b11d(imin), rwork(iu1sn+imin-1),rwork(iu1cs+imin-& + 1_${ik}$), r ) else if( mu <= nu ) then - call stdlib_dlartgs( b11e( imin ), b11d( imin + 1 ), mu,rwork(iu1cs+imin-1), & + call stdlib${ii}$_dlartgs( b11e( imin ), b11d( imin + 1_${ik}$ ), mu,rwork(iu1cs+imin-1), & rwork(iu1sn+imin-1) ) else - call stdlib_dlartgs( b12d( imin ), b12e( imin ), nu,rwork(iu1cs+imin-1), rwork(& + call stdlib${ii}$_dlartgs( b12d( imin ), b12e( imin ), nu,rwork(iu1cs+imin-1), rwork(& iu1sn+imin-1) ) end if - if( b21d(imin)**2+b21bulge**2 > thresh**2 ) then - call stdlib_dlartgp( b21bulge, b21d(imin), rwork(iu2sn+imin-1),rwork(iu2cs+imin-& - 1), r ) + if( b21d(imin)**2_${ik}$+b21bulge**2_${ik}$ > thresh**2_${ik}$ ) then + call stdlib${ii}$_dlartgp( b21bulge, b21d(imin), rwork(iu2sn+imin-1),rwork(iu2cs+imin-& + 1_${ik}$), r ) else if( nu < mu ) then - call stdlib_dlartgs( b21e( imin ), b21d( imin + 1 ), nu,rwork(iu2cs+imin-1), & + call stdlib${ii}$_dlartgs( b21e( imin ), b21d( imin + 1_${ik}$ ), nu,rwork(iu2cs+imin-1), & rwork(iu2sn+imin-1) ) else - call stdlib_dlartgs( b22d(imin), b22e(imin), mu,rwork(iu2cs+imin-1), rwork(iu2sn+& + call stdlib${ii}$_dlartgs( b22d(imin), b22e(imin), mu,rwork(iu2cs+imin-1), rwork(iu2sn+& imin-1) ) end if rwork(iu2cs+imin-1) = -rwork(iu2cs+imin-1) @@ -32344,47 +32347,47 @@ module stdlib_linalg_lapack_z 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_dlartgp( x2, x1, rwork(iv1tsn+i-1),rwork(iv1tcs+i-1), r ) + call stdlib${ii}$_dlartgp( x2, x1, rwork(iv1tsn+i-1),rwork(iv1tcs+i-1), r ) else if( .not. restart11 .and. restart21 ) then - call stdlib_dlartgp( b11bulge, b11e(i-1), rwork(iv1tsn+i-1),rwork(iv1tcs+i-1),& + call stdlib${ii}$_dlartgp( b11bulge, b11e(i-1), rwork(iv1tsn+i-1),rwork(iv1tcs+i-1),& r ) else if( restart11 .and. .not. restart21 ) then - call stdlib_dlartgp( b21bulge, b21e(i-1), rwork(iv1tsn+i-1),rwork(iv1tcs+i-1),& + call stdlib${ii}$_dlartgp( b21bulge, b21e(i-1), rwork(iv1tsn+i-1),rwork(iv1tcs+i-1),& r ) else if( mu <= nu ) then - call stdlib_dlartgs( b11d(i), b11e(i), mu, rwork(iv1tcs+i-1),rwork(iv1tsn+i-1)& + call stdlib${ii}$_dlartgs( b11d(i), b11e(i), mu, rwork(iv1tcs+i-1),rwork(iv1tsn+i-1)& ) else - call stdlib_dlartgs( b21d(i), b21e(i), nu, rwork(iv1tcs+i-1),rwork(iv1tsn+i-1)& + call stdlib${ii}$_dlartgs( b21d(i), b21e(i), nu, rwork(iv1tcs+i-1),rwork(iv1tsn+i-1)& ) end if rwork(iv1tcs+i-1) = -rwork(iv1tcs+i-1) rwork(iv1tsn+i-1) = -rwork(iv1tsn+i-1) if( .not. restart12 .and. .not. restart22 ) then - call stdlib_dlartgp( y2, y1, rwork(iv2tsn+i-1-1),rwork(iv2tcs+i-1-1), r ) + call stdlib${ii}$_dlartgp( y2, y1, rwork(iv2tsn+i-1-1),rwork(iv2tcs+i-1-1), r ) else if( .not. restart12 .and. restart22 ) then - call stdlib_dlartgp( b12bulge, b12d(i-1), rwork(iv2tsn+i-1-1),rwork(iv2tcs+i-& - 1-1), r ) + call stdlib${ii}$_dlartgp( b12bulge, b12d(i-1), rwork(iv2tsn+i-1-1),rwork(iv2tcs+i-& + 1_${ik}$-1), r ) else if( restart12 .and. .not. restart22 ) then - call stdlib_dlartgp( b22bulge, b22d(i-1), rwork(iv2tsn+i-1-1),rwork(iv2tcs+i-& - 1-1), r ) + call stdlib${ii}$_dlartgp( b22bulge, b22d(i-1), rwork(iv2tsn+i-1-1),rwork(iv2tcs+i-& + 1_${ik}$-1), r ) else if( nu < mu ) then - call stdlib_dlartgs( b12e(i-1), b12d(i), nu,rwork(iv2tcs+i-1-1), rwork(iv2tsn+& + call stdlib${ii}$_dlartgs( b12e(i-1), b12d(i), nu,rwork(iv2tcs+i-1-1), rwork(iv2tsn+& i-1-1) ) else - call stdlib_dlartgs( b22e(i-1), b22d(i), mu,rwork(iv2tcs+i-1-1), rwork(iv2tsn+& + call stdlib${ii}$_dlartgs( b22e(i-1), b22d(i), mu,rwork(iv2tcs+i-1-1), rwork(iv2tsn+& i-1-1) ) end if temp = rwork(iv1tcs+i-1)*b11d(i) + rwork(iv1tsn+i-1)*b11e(i) @@ -32412,44 +32415,44 @@ module stdlib_linalg_lapack_z 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_dlartgp( x2, x1, rwork(iu1sn+i-1), rwork(iu1cs+i-1),r ) + call stdlib${ii}$_dlartgp( x2, x1, rwork(iu1sn+i-1), rwork(iu1cs+i-1),r ) else if( .not. restart11 .and. restart12 ) then - call stdlib_dlartgp( b11bulge, b11d(i), rwork(iu1sn+i-1),rwork(iu1cs+i-1), r ) + call stdlib${ii}$_dlartgp( b11bulge, b11d(i), rwork(iu1sn+i-1),rwork(iu1cs+i-1), r ) else if( restart11 .and. .not. restart12 ) then - call stdlib_dlartgp( b12bulge, b12e(i-1), rwork(iu1sn+i-1),rwork(iu1cs+i-1), & + call stdlib${ii}$_dlartgp( b12bulge, b12e(i-1), rwork(iu1sn+i-1),rwork(iu1cs+i-1), & r ) else if( mu <= nu ) then - call stdlib_dlartgs( b11e(i), b11d(i+1), mu, rwork(iu1cs+i-1),rwork(iu1sn+i-1)& + call stdlib${ii}$_dlartgs( b11e(i), b11d(i+1), mu, rwork(iu1cs+i-1),rwork(iu1sn+i-1)& ) else - call stdlib_dlartgs( b12d(i), b12e(i), nu, rwork(iu1cs+i-1),rwork(iu1sn+i-1) ) + call stdlib${ii}$_dlartgs( b12d(i), b12e(i), nu, rwork(iu1cs+i-1),rwork(iu1sn+i-1) ) end if if( .not. restart21 .and. .not. restart22 ) then - call stdlib_dlartgp( y2, y1, rwork(iu2sn+i-1), rwork(iu2cs+i-1),r ) + call stdlib${ii}$_dlartgp( y2, y1, rwork(iu2sn+i-1), rwork(iu2cs+i-1),r ) else if( .not. restart21 .and. restart22 ) then - call stdlib_dlartgp( b21bulge, b21d(i), rwork(iu2sn+i-1),rwork(iu2cs+i-1), r ) + call stdlib${ii}$_dlartgp( b21bulge, b21d(i), rwork(iu2sn+i-1),rwork(iu2cs+i-1), r ) else if( restart21 .and. .not. restart22 ) then - call stdlib_dlartgp( b22bulge, b22e(i-1), rwork(iu2sn+i-1),rwork(iu2cs+i-1), & + call stdlib${ii}$_dlartgp( b22bulge, b22e(i-1), rwork(iu2sn+i-1),rwork(iu2cs+i-1), & r ) else if( nu < mu ) then - call stdlib_dlartgs( b21e(i), b21e(i+1), nu, rwork(iu2cs+i-1),rwork(iu2sn+i-1)& + call stdlib${ii}$_dlartgs( b21e(i), b21e(i+1), nu, rwork(iu2cs+i-1),rwork(iu2sn+i-1)& ) else - call stdlib_dlartgs( b22d(i), b22e(i), mu, rwork(iu2cs+i-1),rwork(iu2sn+i-1) ) + call stdlib${ii}$_dlartgs( b22d(i), b22e(i), mu, rwork(iu2cs+i-1),rwork(iu2sn+i-1) ) end if rwork(iu2cs+i-1) = -rwork(iu2cs+i-1) @@ -32457,14 +32460,14 @@ module stdlib_linalg_lapack_z temp = rwork(iu1cs+i-1)*b11e(i) + rwork(iu1sn+i-1)*b11d(i+1) b11d(i+1) = rwork(iu1cs+i-1)*b11d(i+1) -rwork(iu1sn+i-1)*b11e(i) b11e(i) = temp - if( i < imax - 1 ) then + if( i < imax - 1_${ik}$ ) then b11bulge = rwork(iu1sn+i-1)*b11e(i+1) b11e(i+1) = rwork(iu1cs+i-1)*b11e(i+1) end if temp = rwork(iu2cs+i-1)*b21e(i) + rwork(iu2sn+i-1)*b21d(i+1) b21d(i+1) = rwork(iu2cs+i-1)*b21d(i+1) -rwork(iu2sn+i-1)*b21e(i) b21e(i) = temp - if( i < imax - 1 ) then + if( i < imax - 1_${ik}$ ) then b21bulge = rwork(iu2sn+i-1)*b21e(i+1) b21e(i+1) = rwork(iu2cs+i-1)*b21e(i+1) end if @@ -32483,24 +32486,24 @@ module stdlib_linalg_lapack_z 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_dlartgp( y2, y1, rwork(iv2tsn+imax-1-1),rwork(iv2tcs+imax-1-1), r ) + call stdlib${ii}$_dlartgp( y2, y1, rwork(iv2tsn+imax-1-1),rwork(iv2tcs+imax-1-1), r ) else if( .not. restart12 .and. restart22 ) then - call stdlib_dlartgp( b12bulge, b12d(imax-1),rwork(iv2tsn+imax-1-1),rwork(iv2tcs+& + call stdlib${ii}$_dlartgp( b12bulge, b12d(imax-1),rwork(iv2tsn+imax-1-1),rwork(iv2tcs+& imax-1-1), r ) else if( restart12 .and. .not. restart22 ) then - call stdlib_dlartgp( b22bulge, b22d(imax-1),rwork(iv2tsn+imax-1-1),rwork(iv2tcs+& + call stdlib${ii}$_dlartgp( b22bulge, b22d(imax-1),rwork(iv2tsn+imax-1-1),rwork(iv2tcs+& imax-1-1), r ) else if( nu < mu ) then - call stdlib_dlartgs( b12e(imax-1), b12d(imax), nu,rwork(iv2tcs+imax-1-1),rwork(& + call stdlib${ii}$_dlartgs( b12e(imax-1), b12d(imax), nu,rwork(iv2tcs+imax-1-1),rwork(& iv2tsn+imax-1-1) ) else - call stdlib_dlartgs( b22e(imax-1), b22d(imax), mu,rwork(iv2tcs+imax-1-1),rwork(& + call stdlib${ii}$_dlartgs( b22e(imax-1), b22d(imax), mu,rwork(iv2tcs+imax-1-1),rwork(& iv2tsn+imax-1-1) ) end if temp = rwork(iv2tcs+imax-1-1)*b12e(imax-1) +rwork(iv2tsn+imax-1-1)*b12d(imax) @@ -32516,49 +32519,49 @@ module stdlib_linalg_lapack_z ! update singular vectors if( wantu1 ) then if( colmajor ) then - call stdlib_zlasr( 'R', 'V', 'F', p, imax-imin+1,rwork(iu1cs+imin-1), rwork(& - iu1sn+imin-1),u1(1,imin), ldu1 ) + call stdlib${ii}$_zlasr( 'R', 'V', 'F', p, imax-imin+1,rwork(iu1cs+imin-1), rwork(& + iu1sn+imin-1),u1(1_${ik}$,imin), ldu1 ) else - call stdlib_zlasr( 'L', 'V', 'F', imax-imin+1, p,rwork(iu1cs+imin-1), rwork(& - iu1sn+imin-1),u1(imin,1), ldu1 ) + call stdlib${ii}$_zlasr( 'L', 'V', 'F', imax-imin+1, p,rwork(iu1cs+imin-1), rwork(& + iu1sn+imin-1),u1(imin,1_${ik}$), ldu1 ) end if end if if( wantu2 ) then if( colmajor ) then - call stdlib_zlasr( 'R', 'V', 'F', m-p, imax-imin+1,rwork(iu2cs+imin-1), rwork(& - iu2sn+imin-1),u2(1,imin), ldu2 ) + call stdlib${ii}$_zlasr( 'R', 'V', 'F', m-p, imax-imin+1,rwork(iu2cs+imin-1), rwork(& + iu2sn+imin-1),u2(1_${ik}$,imin), ldu2 ) else - call stdlib_zlasr( 'L', 'V', 'F', imax-imin+1, m-p,rwork(iu2cs+imin-1), rwork(& - iu2sn+imin-1),u2(imin,1), ldu2 ) + call stdlib${ii}$_zlasr( 'L', 'V', 'F', imax-imin+1, m-p,rwork(iu2cs+imin-1), rwork(& + iu2sn+imin-1),u2(imin,1_${ik}$), ldu2 ) end if end if if( wantv1t ) then if( colmajor ) then - call stdlib_zlasr( 'L', 'V', 'F', imax-imin+1, q,rwork(iv1tcs+imin-1), rwork(& - iv1tsn+imin-1),v1t(imin,1), ldv1t ) + call stdlib${ii}$_zlasr( 'L', 'V', 'F', imax-imin+1, q,rwork(iv1tcs+imin-1), rwork(& + iv1tsn+imin-1),v1t(imin,1_${ik}$), ldv1t ) else - call stdlib_zlasr( 'R', 'V', 'F', q, imax-imin+1,rwork(iv1tcs+imin-1), rwork(& - iv1tsn+imin-1),v1t(1,imin), ldv1t ) + call stdlib${ii}$_zlasr( 'R', 'V', 'F', q, imax-imin+1,rwork(iv1tcs+imin-1), rwork(& + iv1tsn+imin-1),v1t(1_${ik}$,imin), ldv1t ) end if end if if( wantv2t ) then if( colmajor ) then - call stdlib_zlasr( 'L', 'V', 'F', imax-imin+1, m-q,rwork(iv2tcs+imin-1), & - rwork(iv2tsn+imin-1),v2t(imin,1), ldv2t ) + call stdlib${ii}$_zlasr( 'L', 'V', 'F', imax-imin+1, m-q,rwork(iv2tcs+imin-1), & + rwork(iv2tsn+imin-1),v2t(imin,1_${ik}$), ldv2t ) else - call stdlib_zlasr( 'R', 'V', 'F', m-q, imax-imin+1,rwork(iv2tcs+imin-1), & - rwork(iv2tsn+imin-1),v2t(1,imin), ldv2t ) + call stdlib${ii}$_zlasr( 'R', 'V', 'F', m-q, imax-imin+1,rwork(iv2tcs+imin-1), & + rwork(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_zscal( q, cnegone, v1t(imax,1), ldv1t ) + call stdlib${ii}$_zscal( q, cnegone, v1t(imax,1_${ik}$), ldv1t ) else - call stdlib_zscal( q, cnegone, v1t(1,imax), 1 ) + call stdlib${ii}$_zscal( q, cnegone, v1t(1_${ik}$,imax), 1_${ik}$ ) end if end if end if @@ -32568,33 +32571,33 @@ module stdlib_linalg_lapack_z 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_zscal( p, cnegone, u1(1,imax), 1 ) + call stdlib${ii}$_zscal( p, cnegone, u1(1_${ik}$,imax), 1_${ik}$ ) else - call stdlib_zscal( p, cnegone, u1(imax,1), ldu1 ) + call stdlib${ii}$_zscal( p, cnegone, 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_zscal( m-p, cnegone, u2(1,imax), 1 ) + call stdlib${ii}$_zscal( m-p, cnegone, u2(1_${ik}$,imax), 1_${ik}$ ) else - call stdlib_zscal( m-p, cnegone, u2(imax,1), ldu2 ) + call stdlib${ii}$_zscal( m-p, cnegone, 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_zscal( m-q, cnegone, v2t(imax,1), ldv2t ) + call stdlib${ii}$_zscal( m-q, cnegone, v2t(imax,1_${ik}$), ldv2t ) else - call stdlib_zscal( m-q, cnegone, v2t(1,imax), 1 ) + call stdlib${ii}$_zscal( m-q, cnegone, v2t(1_${ik}$,imax), 1_${ik}$ ) end if end if end if @@ -32614,16 +32617,16 @@ module stdlib_linalg_lapack_z 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 @@ -32643,25 +32646,25 @@ module stdlib_linalg_lapack_z theta(mini) = theta(i) theta(i) = thetamin if( colmajor ) then - if( wantu1 )call stdlib_zswap( p, u1(1,i), 1, u1(1,mini), 1 ) - if( wantu2 )call stdlib_zswap( m-p, u2(1,i), 1, u2(1,mini), 1 ) - if( wantv1t )call stdlib_zswap( q, v1t(i,1), ldv1t, v1t(mini,1), ldv1t ) + if( wantu1 )call stdlib${ii}$_zswap( p, u1(1_${ik}$,i), 1_${ik}$, u1(1_${ik}$,mini), 1_${ik}$ ) + if( wantu2 )call stdlib${ii}$_zswap( m-p, u2(1_${ik}$,i), 1_${ik}$, u2(1_${ik}$,mini), 1_${ik}$ ) + if( wantv1t )call stdlib${ii}$_zswap( q, v1t(i,1_${ik}$), ldv1t, v1t(mini,1_${ik}$), ldv1t ) - if( wantv2t )call stdlib_zswap( m-q, v2t(i,1), ldv2t, v2t(mini,1),ldv2t ) + if( wantv2t )call stdlib${ii}$_zswap( m-q, v2t(i,1_${ik}$), ldv2t, v2t(mini,1_${ik}$),ldv2t ) else - if( wantu1 )call stdlib_zswap( p, u1(i,1), ldu1, u1(mini,1), ldu1 ) - if( wantu2 )call stdlib_zswap( m-p, u2(i,1), ldu2, u2(mini,1), ldu2 ) - if( wantv1t )call stdlib_zswap( q, v1t(1,i), 1, v1t(1,mini), 1 ) - if( wantv2t )call stdlib_zswap( m-q, v2t(1,i), 1, v2t(1,mini), 1 ) + if( wantu1 )call stdlib${ii}$_zswap( p, u1(i,1_${ik}$), ldu1, u1(mini,1_${ik}$), ldu1 ) + if( wantu2 )call stdlib${ii}$_zswap( m-p, u2(i,1_${ik}$), ldu2, u2(mini,1_${ik}$), ldu2 ) + if( wantv1t )call stdlib${ii}$_zswap( q, v1t(1_${ik}$,i), 1_${ik}$, v1t(1_${ik}$,mini), 1_${ik}$ ) + if( wantv2t )call stdlib${ii}$_zswap( m-q, v2t(1_${ik}$,i), 1_${ik}$, v2t(1_${ik}$,mini), 1_${ik}$ ) end if end if end do return - end subroutine stdlib_zbbcsd + end subroutine stdlib${ii}$_zbbcsd - pure subroutine stdlib_zbdsqr( uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u,ldu, c, ldc, rwork,& + pure subroutine stdlib${ii}$_zbdsqr( uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u,ldu, c, ldc, rwork,& !! ZBDSQR computes the singular values and, optionally, the right and/or !! left singular vectors from the singular value decomposition (SVD) of !! a real N-by-N (upper or lower) bidiagonal matrix B using the implicit @@ -32692,8 +32695,8 @@ module stdlib_linalg_lapack_z ! -- 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) :: ldc, ldu, ldvt, n, ncc, ncvt, nru + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldc, ldu, ldvt, n, ncc, ncvt, nru ! Array Arguments real(dp), intent(inout) :: d(*), e(*) real(dp), intent(out) :: rwork(*) @@ -32703,7 +32706,7 @@ module stdlib_linalg_lapack_z real(dp), parameter :: hndrth = 0.01_dp real(dp), parameter :: hndrd = 100.0_dp real(dp), parameter :: meigth = -0.125_dp - integer(ilp), parameter :: maxitr = 6 + integer(${ik}$), parameter :: maxitr = 6_${ik}$ @@ -32714,7 +32717,7 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: lower, rotate - integer(ilp) :: i, idir, isub, iter, j, ll, lll, m, maxit, nm1, nm12, nm13, oldll, & + integer(${ik}$) :: i, idir, isub, iter, j, ll, lll, m, maxit, nm1, nm12, nm13, oldll, & oldm real(dp) :: abse, abss, cosl, cosr, cs, eps, f, g, h, mu, oldcs, oldsn, r, shift, & sigmn, sigmx, sinl, sinr, sll, smax, smin, sminl, sminoa, sn, thresh, tol, tolmul, & @@ -32723,52 +32726,52 @@ module stdlib_linalg_lapack_z intrinsic :: abs,real,max,min,sign,sqrt ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ lower = stdlib_lsame( uplo, 'L' ) if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.lower ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( ncvt<0 ) then - info = -3 - else if( nru<0 ) then - info = -4 - else if( ncc<0 ) then - info = -5 - else if( ( ncvt==0 .and. ldvt<1 ) .or.( ncvt>0 .and. ldvt0 .and. ldc0_${ik}$ .and. ldvt0_${ik}$ .and. ldc0 ) .or. ( nru>0 ) .or. ( ncc>0 ) + rotate = ( ncvt>0_${ik}$ ) .or. ( nru>0_${ik}$ ) .or. ( ncc>0_${ik}$ ) ! if no singular vectors desired, use qd algorithm if( .not.rotate ) then - call stdlib_dlasq1( n, d, e, rwork, info ) + call stdlib${ii}$_dlasq1( n, d, e, rwork, info ) ! if info equals 2, dqds didn't finish, try to finish if( info /= 2 ) return - info = 0 + info = 0_${ik}$ end if - nm1 = n - 1 + nm1 = n - 1_${ik}$ nm12 = nm1 + nm1 nm13 = nm12 + nm1 - idir = 0 + idir = 0_${ik}$ ! get machine constants - eps = stdlib_dlamch( 'EPSILON' ) - unfl = stdlib_dlamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_dlamch( 'EPSILON' ) + unfl = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) ! if matrix lower bidiagonal, rotate to be upper bidiagonal ! by applying givens rotations on the left if( lower ) then do i = 1, n - 1 - call stdlib_dlartg( d( i ), e( i ), cs, sn, r ) + call stdlib${ii}$_dlartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) @@ -32776,9 +32779,9 @@ module stdlib_linalg_lapack_z rwork( nm1+i ) = sn end do ! update singular vectors if desired - if( nru>0 )call stdlib_zlasr( 'R', 'V', 'F', nru, n, rwork( 1 ), rwork( n ),u, ldu ) + if( nru>0_${ik}$ )call stdlib${ii}$_zlasr( 'R', 'V', 'F', nru, n, rwork( 1_${ik}$ ), rwork( n ),u, ldu ) - if( ncc>0 )call stdlib_zlasr( 'L', 'V', 'F', n, ncc, rwork( 1 ), rwork( n ),c, ldc ) + if( ncc>0_${ik}$ )call stdlib${ii}$_zlasr( 'L', 'V', 'F', n, ncc, rwork( 1_${ik}$ ), rwork( n ),c, ldc ) end if ! compute singular values to relative accuracy tol @@ -32797,7 +32800,7 @@ module stdlib_linalg_lapack_z sminl = zero if( tol>=zero ) then ! relative accuracy desired - sminoa = abs( d( 1 ) ) + sminoa = abs( d( 1_${ik}$ ) ) if( sminoa==zero )go to 50 mu = sminoa do i = 2, n @@ -32816,9 +32819,9 @@ module stdlib_linalg_lapack_z ! (maxit is the maximum number of passes through the inner ! loop permitted before nonconvergence signalled.) maxit = maxitr*n*n - iter = 0 - oldll = -1 - oldm = -1 + iter = 0_${ik}$ + oldll = -1_${ik}$ + oldm = -1_${ik}$ ! m points to last element of unconverged part of matrix m = n ! begin main iteration loop @@ -32839,34 +32842,34 @@ module stdlib_linalg_lapack_z smin = min( smin, abss ) smax = max( smax, abss, abse ) end do - ll = 0 + ll = 0_${ik}$ go to 90 80 continue e( ll ) = zero ! matrix splits since e(ll) = 0 if( ll==m-1 ) then ! convergence of bottom singular value, return to top of loop - m = m - 1 + m = m - 1_${ik}$ go to 60 end if 90 continue - ll = ll + 1 + ll = ll + 1_${ik}$ ! e(ll) through e(m-1) are nonzero, e(ll-1) is zero if( ll==m-1 ) then ! 2 by 2 block, handle separately - call stdlib_dlasv2( d( m-1 ), e( m-1 ), d( m ), sigmn, sigmx, sinr,cosr, sinl, cosl & + call stdlib${ii}$_dlasv2( d( m-1 ), e( m-1 ), d( m ), sigmn, sigmx, sinr,cosr, sinl, cosl & ) d( m-1 ) = sigmx e( m-1 ) = zero d( m ) = sigmn ! compute singular vectors, if desired - if( ncvt>0 )call stdlib_zdrot( ncvt, vt( m-1, 1 ), ldvt, vt( m, 1 ), ldvt,cosr, & + if( ncvt>0_${ik}$ )call stdlib${ii}$_zdrot( ncvt, vt( m-1, 1_${ik}$ ), ldvt, vt( m, 1_${ik}$ ), ldvt,cosr, & sinr ) - if( nru>0 )call stdlib_zdrot( nru, u( 1, m-1 ), 1, u( 1, m ), 1, cosl, sinl ) + if( nru>0_${ik}$ )call stdlib${ii}$_zdrot( nru, u( 1_${ik}$, m-1 ), 1_${ik}$, u( 1_${ik}$, m ), 1_${ik}$, cosl, sinl ) - if( ncc>0 )call stdlib_zdrot( ncc, c( m-1, 1 ), ldc, c( m, 1 ), ldc, cosl,sinl ) + if( ncc>0_${ik}$ )call stdlib${ii}$_zdrot( ncc, c( m-1, 1_${ik}$ ), ldc, c( m, 1_${ik}$ ), ldc, cosl,sinl ) - m = m - 2 + m = m - 2_${ik}$ go to 60 end if ! if working on new submatrix, choose shift direction @@ -32874,14 +32877,14 @@ module stdlib_linalg_lapack_z if( ll>oldm .or. m=abs( d( m ) ) ) then ! chase bulge from top (big end) to bottom (small end) - idir = 1 + idir = 1_${ik}$ else ! chase bulge from bottom (big end) to top (small end) - idir = 2 + idir = 2_${ik}$ end if end if ! apply convergence tests - if( idir==1 ) then + if( idir==1_${ik}$ ) then ! run convergence test in forward direction ! first apply standard test to bottom of matrix if( abs( e( m-1 ) )<=abs( tol )*abs( d( m ) ) .or.( tolzero ) then - if( ( shift / sll )**2ll )e( i-1 ) = oldsn*r - call stdlib_dlartg( oldcs*r, d( i+1 )*sn, oldcs, oldsn, d( i ) ) + call stdlib${ii}$_dlartg( oldcs*r, d( i+1 )*sn, oldcs, oldsn, d( i ) ) rwork( i-ll+1 ) = cs rwork( i-ll+1+nm1 ) = sn rwork( i-ll+1+nm12 ) = oldcs @@ -32969,12 +32972,12 @@ module stdlib_linalg_lapack_z d( m ) = h*oldcs e( m-1 ) = h*oldsn ! update singular vectors - if( ncvt>0 )call stdlib_zlasr( 'L', 'V', 'F', m-ll+1, ncvt, rwork( 1 ),rwork( n )& - , vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_zlasr( 'R', 'V', 'F', nru, m-ll+1, rwork( nm12+1 ),rwork( & - nm13+1 ), u( 1, ll ), ldu ) - if( ncc>0 )call stdlib_zlasr( 'L', 'V', 'F', m-ll+1, ncc, rwork( nm12+1 ),rwork( & - nm13+1 ), c( ll, 1 ), ldc ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_zlasr( 'L', 'V', 'F', m-ll+1, ncvt, rwork( 1_${ik}$ ),rwork( n )& + , vt( ll, 1_${ik}$ ), ldvt ) + if( nru>0_${ik}$ )call stdlib${ii}$_zlasr( 'R', 'V', 'F', nru, m-ll+1, rwork( nm12+1 ),rwork( & + nm13+1 ), u( 1_${ik}$, ll ), ldu ) + if( ncc>0_${ik}$ )call stdlib${ii}$_zlasr( 'L', 'V', 'F', m-ll+1, ncc, rwork( nm12+1 ),rwork( & + nm13+1 ), c( ll, 1_${ik}$ ), ldc ) ! test convergence if( abs( e( m-1 ) )<=thresh )e( m-1 ) = zero else @@ -32983,9 +32986,9 @@ module stdlib_linalg_lapack_z cs = one oldcs = one do i = m, ll + 1, -1 - call stdlib_dlartg( d( i )*cs, e( i-1 ), cs, sn, r ) + call stdlib${ii}$_dlartg( d( i )*cs, e( i-1 ), cs, sn, r ) if( i0 )call stdlib_zlasr( 'L', 'V', 'B', m-ll+1, ncvt, rwork( nm12+1 ),& - rwork( nm13+1 ), vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_zlasr( 'R', 'V', 'B', nru, m-ll+1, rwork( 1 ),rwork( n ), & - u( 1, ll ), ldu ) - if( ncc>0 )call stdlib_zlasr( 'L', 'V', 'B', m-ll+1, ncc, rwork( 1 ),rwork( n ), & - c( ll, 1 ), ldc ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_zlasr( 'L', 'V', 'B', m-ll+1, ncvt, rwork( nm12+1 ),& + rwork( nm13+1 ), vt( ll, 1_${ik}$ ), ldvt ) + if( nru>0_${ik}$ )call stdlib${ii}$_zlasr( 'R', 'V', 'B', nru, m-ll+1, rwork( 1_${ik}$ ),rwork( n ), & + u( 1_${ik}$, ll ), ldu ) + if( ncc>0_${ik}$ )call stdlib${ii}$_zlasr( 'L', 'V', 'B', m-ll+1, ncc, rwork( 1_${ik}$ ),rwork( n ), & + c( ll, 1_${ik}$ ), ldc ) ! test convergence if( abs( e( ll ) )<=thresh )e( ll ) = zero end if else ! use nonzero shift - if( idir==1 ) then + if( idir==1_${ik}$ ) then ! chase bulge from top to bottom ! save cosines and sines for later singular vector updates f = ( abs( d( ll ) )-shift )*( sign( one, d( ll ) )+shift / d( ll ) ) g = e( ll ) do i = ll, m - 1 - call stdlib_dlartg( f, g, cosr, sinr, r ) + call stdlib${ii}$_dlartg( f, g, cosr, sinr, r ) if( i>ll )e( i-1 ) = r f = cosr*d( i ) + sinr*e( i ) e( i ) = cosr*e( i ) - sinr*d( i ) g = sinr*d( i+1 ) d( i+1 ) = cosr*d( i+1 ) - call stdlib_dlartg( f, g, cosl, sinl, r ) + call stdlib${ii}$_dlartg( f, g, cosl, sinl, r ) d( i ) = r f = cosl*e( i ) + sinl*d( i+1 ) d( i+1 ) = cosl*d( i+1 ) - sinl*e( i ) @@ -33033,12 +33036,12 @@ module stdlib_linalg_lapack_z end do e( m-1 ) = f ! update singular vectors - if( ncvt>0 )call stdlib_zlasr( 'L', 'V', 'F', m-ll+1, ncvt, rwork( 1 ),rwork( n )& - , vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_zlasr( 'R', 'V', 'F', nru, m-ll+1, rwork( nm12+1 ),rwork( & - nm13+1 ), u( 1, ll ), ldu ) - if( ncc>0 )call stdlib_zlasr( 'L', 'V', 'F', m-ll+1, ncc, rwork( nm12+1 ),rwork( & - nm13+1 ), c( ll, 1 ), ldc ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_zlasr( 'L', 'V', 'F', m-ll+1, ncvt, rwork( 1_${ik}$ ),rwork( n )& + , vt( ll, 1_${ik}$ ), ldvt ) + if( nru>0_${ik}$ )call stdlib${ii}$_zlasr( 'R', 'V', 'F', nru, m-ll+1, rwork( nm12+1 ),rwork( & + nm13+1 ), u( 1_${ik}$, ll ), ldu ) + if( ncc>0_${ik}$ )call stdlib${ii}$_zlasr( 'L', 'V', 'F', m-ll+1, ncc, rwork( nm12+1 ),rwork( & + nm13+1 ), c( ll, 1_${ik}$ ), ldc ) ! test convergence if( abs( e( m-1 ) )<=thresh )e( m-1 ) = zero else @@ -33047,13 +33050,13 @@ module stdlib_linalg_lapack_z f = ( abs( d( m ) )-shift )*( sign( one, d( m ) )+shift /d( m ) ) g = e( m-1 ) do i = m, ll + 1, -1 - call stdlib_dlartg( f, g, cosr, sinr, r ) + call stdlib${ii}$_dlartg( f, g, cosr, sinr, r ) if( i0 )call stdlib_zlasr( 'L', 'V', 'B', m-ll+1, ncvt, rwork( nm12+1 ),& - rwork( nm13+1 ), vt( ll, 1 ), ldvt ) - if( nru>0 )call stdlib_zlasr( 'R', 'V', 'B', nru, m-ll+1, rwork( 1 ),rwork( n ), & - u( 1, ll ), ldu ) - if( ncc>0 )call stdlib_zlasr( 'L', 'V', 'B', m-ll+1, ncc, rwork( 1 ),rwork( n ), & - c( ll, 1 ), ldc ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_zlasr( 'L', 'V', 'B', m-ll+1, ncvt, rwork( nm12+1 ),& + rwork( nm13+1 ), vt( ll, 1_${ik}$ ), ldvt ) + if( nru>0_${ik}$ )call stdlib${ii}$_zlasr( 'R', 'V', 'B', nru, m-ll+1, rwork( 1_${ik}$ ),rwork( n ), & + u( 1_${ik}$, ll ), ldu ) + if( ncc>0_${ik}$ )call stdlib${ii}$_zlasr( 'L', 'V', 'B', m-ll+1, ncc, rwork( 1_${ik}$ ),rwork( n ), & + c( ll, 1_${ik}$ ), ldc ) end if end if ! qr iteration finished, go back and check convergence @@ -33086,15 +33089,15 @@ module stdlib_linalg_lapack_z if( d( i )0 )call stdlib_zdscal( ncvt, negone, vt( i, 1 ), ldvt ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_zdscal( ncvt, negone, vt( i, 1_${ik}$ ), ldvt ) end if end do ! sort the singular values into decreasing order (insertion sort on ! singular values, but only one transposition per singular vector) do i = 1, n - 1 ! scan for smallest d(i) - isub = 1 - smin = d( 1 ) + isub = 1_${ik}$ + smin = d( 1_${ik}$ ) do j = 2, n + 1 - i if( d( j )<=smin ) then isub = j @@ -33105,26 +33108,26 @@ module stdlib_linalg_lapack_z ! swap singular values and vectors d( isub ) = d( n+1-i ) d( n+1-i ) = smin - if( ncvt>0 )call stdlib_zswap( ncvt, vt( isub, 1 ), ldvt, vt( n+1-i, 1 ),ldvt ) + if( ncvt>0_${ik}$ )call stdlib${ii}$_zswap( ncvt, vt( isub, 1_${ik}$ ), ldvt, vt( n+1-i, 1_${ik}$ ),ldvt ) - if( nru>0 )call stdlib_zswap( nru, u( 1, isub ), 1, u( 1, n+1-i ), 1 ) - if( ncc>0 )call stdlib_zswap( ncc, c( isub, 1 ), ldc, c( n+1-i, 1 ), ldc ) + if( nru>0_${ik}$ )call stdlib${ii}$_zswap( nru, u( 1_${ik}$, isub ), 1_${ik}$, u( 1_${ik}$, n+1-i ), 1_${ik}$ ) + if( ncc>0_${ik}$ )call stdlib${ii}$_zswap( ncc, c( isub, 1_${ik}$ ), ldc, c( n+1-i, 1_${ik}$ ), ldc ) end if end do go to 220 ! maximum number of iterations exceeded, failure to converge 200 continue - info = 0 + info = 0_${ik}$ do i = 1, n - 1 - if( e( i )/=zero )info = info + 1 + if( e( i )/=zero )info = info + 1_${ik}$ end do 220 continue return - end subroutine stdlib_zbdsqr + end subroutine stdlib${ii}$_zbdsqr - pure subroutine stdlib_zgbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond,work, rwork, & + pure subroutine stdlib${ii}$_zgbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond,work, rwork, & !! ZGBCON estimates the reciprocal of the condition number of a complex !! general band matrix A, in either the 1-norm or the infinity-norm, !! using the LU factorization computed by ZGBTRF. @@ -33137,12 +33140,12 @@ module stdlib_linalg_lapack_z ! -- 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(dp), intent(in) :: anorm real(dp), intent(out) :: rcond ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) real(dp), intent(out) :: rwork(*) complex(dp), intent(in) :: ab(ldab,*) complex(dp), intent(out) :: work(*) @@ -33151,11 +33154,11 @@ module stdlib_linalg_lapack_z ! 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(dp) :: ainvnm, scale, smlnum complex(dp) :: t, zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,aimag,min ! Statement Functions @@ -33164,48 +33167,48 @@ module stdlib_linalg_lapack_z cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ onenrm = norm=='1' .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_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + if( kase/=0_${ik}$ ) then if( kase==kase1 ) then ! multiply by inv(l). if( lnoti ) then @@ -33217,21 +33220,21 @@ module stdlib_linalg_lapack_z work( jp ) = work( j ) work( j ) = t end if - call stdlib_zaxpy( lm, -t, ab( kd+1, j ), 1, work( j+1 ), 1 ) + call stdlib${ii}$_zaxpy( lm, -t, ab( kd+1, j ), 1_${ik}$, work( j+1 ), 1_${ik}$ ) end do end if ! multiply by inv(u). - call stdlib_zlatbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, & + call stdlib${ii}$_zlatbs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', normin, n,kl+ku, ab, & ldab, work, scale, rwork, info ) else ! multiply by inv(u**h). - call stdlib_zlatbs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, kl+ku, & + call stdlib${ii}$_zlatbs( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',normin, n, kl+ku, & ab, ldab, work, scale, rwork,info ) ! multiply by inv(l**h). if( lnoti ) then do j = n - 1, 1, -1 lm = min( kl, n-j ) - work( j ) = work( j ) - stdlib_zdotc( lm, ab( kd+1, j ), 1,work( j+1 ), 1 ) + work( j ) = work( j ) - stdlib${ii}$_zdotc( lm, ab( kd+1, j ), 1_${ik}$,work( j+1 ), 1_${ik}$ ) jp = ipiv( j ) if( jp/=j ) then @@ -33245,9 +33248,9 @@ module stdlib_linalg_lapack_z ! divide x by 1/scale if doing so will not cause overflow. normin = 'Y' if( scale/=one ) then - ix = stdlib_izamax( n, work, 1 ) + ix = stdlib${ii}$_izamax( n, work, 1_${ik}$ ) if( scalekl ) then + if( nb<=1_${ik}$ .or. nb>kl ) then ! use unblocked code - call stdlib_zgbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) + call stdlib${ii}$_zgbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) else ! use blocked code ! czero the superdiagonal elements of the work array work13 @@ -33339,7 +33342,7 @@ module stdlib_linalg_lapack_z 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 @@ -33365,57 +33368,57 @@ module stdlib_linalg_lapack_z ! find pivot and test for singularity. km is the number of ! subdiagonal elements in the current column. km = min( kl, m-jj ) - jp = stdlib_izamax( km+1, ab( kv+1, jj ), 1 ) + jp = stdlib${ii}$_izamax( km+1, ab( kv+1, jj ), 1_${ik}$ ) ipiv( jj ) = jp + jj - j if( ab( kv+jp, jj )/=czero ) then ju = max( ju, min( jj+ku+jp-1, n ) ) - if( jp/=1 ) then + if( jp/=1_${ik}$ ) then ! apply interchange to columns j to j+jb-1 if( jp+jj-1jj )call stdlib_zgeru( km, jm-jj, -cone, ab( kv+2, jj ), 1,ab( kv, & + if( jm>jj )call stdlib${ii}$_zgeru( km, jm-jj, -cone, ab( kv+2, jj ), 1_${ik}$,ab( kv, & jj+1 ), ldab-1,ab( kv+1, jj+1 ), ldab-1 ) else ! if pivot is czero, set info to the index of the pivot ! unless a czero 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_zcopy( nw, ab( kv+kl+1-jj+j, jj ), 1,work31( 1, jj-j+1 )& - , 1 ) + if( nw>0_${ik}$ )call stdlib${ii}$_zcopy( 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_zlaswp to apply the row interchanges to a12, a22, and ! a32. - call stdlib_zlaswp( j2, ab( kv+1-jb, j+jb ), ldab-1, 1, jb,ipiv( j ), 1 ) + call stdlib${ii}$_zlaswp( 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 @@ -33428,24 +33431,24 @@ module stdlib_linalg_lapack_z 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_ztrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j2, cone, & + call stdlib${ii}$_ztrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j2, cone, & ab( kv+1, j ), ldab-1,ab( kv+1-jb, j+jb ), ldab-1 ) - if( i2>0 ) then + if( i2>0_${ik}$ ) then ! update a22 - call stdlib_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j2,jb, -cone, ab(& + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j2,jb, -cone, ab(& kv+1+jb, j ), ldab-1,ab( kv+1-jb, j+jb ), ldab-1, cone,ab( kv+1, j+jb )& , ldab-1 ) end if - if( i3>0 ) then + if( i3>0_${ik}$ ) then ! update a32 - call stdlib_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j2,jb, -cone, & + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j2,jb, -cone, & work31, ldwork,ab( kv+1-jb, j+jb ), ldab-1, cone,ab( kv+kl+1-jb, j+jb ),& ldab-1 ) end if 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 @@ -33454,18 +33457,18 @@ module stdlib_linalg_lapack_z end do end do ! update a13 in the work array - call stdlib_ztrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j3, cone, & + call stdlib${ii}$_ztrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT',jb, j3, cone, & ab( kv+1, j ), ldab-1,work13, ldwork ) - if( i2>0 ) then + if( i2>0_${ik}$ ) then ! update a23 - call stdlib_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j3,jb, -cone, ab(& - kv+1+jb, j ), ldab-1,work13, ldwork, cone, ab( 1+jb, j+kv ),ldab-1 ) + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i2, j3,jb, -cone, ab(& + kv+1+jb, j ), ldab-1,work13, ldwork, cone, ab( 1_${ik}$+jb, j+kv ),ldab-1 ) end if - if( i3>0 ) then + if( i3>0_${ik}$ ) then ! update a33 - call stdlib_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j3,jb, -cone, & - work31, ldwork, work13,ldwork, cone, ab( 1+kl, j+kv ), ldab-1 ) + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', i3, j3,jb, -cone, & + work31, ldwork, work13,ldwork, cone, ab( 1_${ik}$+kl, j+kv ), ldab-1 ) end if ! copy the lower triangle of a13 back into place do jj = 1, j3 @@ -33477,38 +33480,38 @@ module stdlib_linalg_lapack_z 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_zcopy( nw, work31( 1, jj-j+1 ), 1,ab( kv+kl+1-jj+j, jj )& - , 1 ) + if( nw>0_${ik}$ )call stdlib${ii}$_zcopy( 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_zgbtrf + end subroutine stdlib${ii}$_zgbtrf - pure subroutine stdlib_zgbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info ) + pure subroutine stdlib${ii}$_zgbtrs( trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb,info ) !! ZGBTRS solves a system of linear equations !! A * X = B, A**T * X = B, or A**H * X = B !! with a general band matrix A using the LU factorization computed @@ -33518,47 +33521,47 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(in) :: ab(ldab,*) complex(dp), 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. @@ -33570,58 +33573,58 @@ module stdlib_linalg_lapack_z do j = 1, n - 1 lm = min( kl, n-j ) l = ipiv( j ) - if( l/=j )call stdlib_zswap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) - call stdlib_zgeru( lm, nrhs, -cone, ab( kd+1, j ), 1, b( j, 1 ),ldb, b( j+1, & - 1 ), ldb ) + if( l/=j )call stdlib${ii}$_zswap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zgeru( lm, nrhs, -cone, 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_ztbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kl+ku,ab, ldab, b( 1, & - i ), 1 ) + call stdlib${ii}$_ztbsv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, kl+ku,ab, ldab, b( 1_${ik}$, & + i ), 1_${ik}$ ) end do else if( stdlib_lsame( trans, 'T' ) ) then ! solve a**t * x = b. do i = 1, nrhs ! solve u**t * x = b, overwriting b with x. - call stdlib_ztbsv( 'UPPER', 'TRANSPOSE', 'NON-UNIT', n, kl+ku, ab,ldab, b( 1, i )& - , 1 ) + call stdlib${ii}$_ztbsv( '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_zgemv( 'TRANSPOSE', lm, nrhs, -cone, b( j+1, 1 ),ldb, ab( kd+1, j & - ), 1, cone, b( j, 1 ), ldb ) + call stdlib${ii}$_zgemv( 'TRANSPOSE', lm, nrhs, -cone, b( j+1, 1_${ik}$ ),ldb, ab( kd+1, j & + ), 1_${ik}$, cone, b( j, 1_${ik}$ ), ldb ) l = ipiv( j ) - if( l/=j )call stdlib_zswap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) + if( l/=j )call stdlib${ii}$_zswap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb ) end do end if else ! solve a**h * x = b. do i = 1, nrhs ! solve u**h * x = b, overwriting b with x. - call stdlib_ztbsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,kl+ku, ab, ldab,& - b( 1, i ), 1 ) + call stdlib${ii}$_ztbsv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT', n,kl+ku, ab, ldab,& + b( 1_${ik}$, i ), 1_${ik}$ ) end do ! solve l**h * x = b, overwriting b with x. if( lnoti ) then do j = n - 1, 1, -1 lm = min( kl, n-j ) - call stdlib_zlacgv( nrhs, b( j, 1 ), ldb ) - call stdlib_zgemv( 'CONJUGATE TRANSPOSE', lm, nrhs, -cone,b( j+1, 1 ), ldb, & - ab( kd+1, j ), 1, cone,b( j, 1 ), ldb ) - call stdlib_zlacgv( nrhs, b( j, 1 ), ldb ) + call stdlib${ii}$_zlacgv( nrhs, b( j, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', lm, nrhs, -cone,b( j+1, 1_${ik}$ ), ldb, & + ab( kd+1, j ), 1_${ik}$, cone,b( j, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zlacgv( nrhs, b( j, 1_${ik}$ ), ldb ) l = ipiv( j ) - if( l/=j )call stdlib_zswap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) + if( l/=j )call stdlib${ii}$_zswap( nrhs, b( l, 1_${ik}$ ), ldb, b( j, 1_${ik}$ ), ldb ) end do end if end if return - end subroutine stdlib_zgbtrs + end subroutine stdlib${ii}$_zgbtrs - pure subroutine stdlib_zgebd2( m, n, a, lda, d, e, tauq, taup, work, info ) + pure subroutine stdlib${ii}$_zgebd2( m, n, a, lda, d, e, tauq, taup, work, info ) !! ZGEBD2 reduces a complex general m by n matrix A to upper or lower !! real bidiagonal form B by a unitary transformation: Q**H * A * P = B. !! If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. @@ -33629,8 +33632,8 @@ module stdlib_linalg_lapack_z ! -- 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(dp), intent(out) :: d(*), e(*) complex(dp), intent(inout) :: a(lda,*) @@ -33638,22 +33641,22 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i complex(dp) :: alpha ! Intrinsic Functions intrinsic :: conjg,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=n ) then @@ -33661,25 +33664,25 @@ module stdlib_linalg_lapack_z do i = 1, n ! generate elementary reflector h(i) to annihilate a(i+1:m,i) alpha = a( i, i ) - call stdlib_zlarfg( m-i+1, alpha, a( min( i+1, m ), i ), 1,tauq( i ) ) + call stdlib${ii}$_zlarfg( m-i+1, alpha, a( min( i+1, m ), i ), 1_${ik}$,tauq( i ) ) d( i ) = real( alpha,KIND=dp) a( i, i ) = cone ! apply h(i)**h to a(i:m,i+1:n) from the left - if( imax( 1, n ) ) then - info = -2 + info = 0_${ik}$ + if( n<0_${ik}$ ) then + info = -1_${ik}$ + else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then + info = -2_${ik}$ else if( ihin ) then - info = -3 - else if( lda1 .and. nb1_${ik}$ .and. nbq ) 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( ldv1 .and. nb1_${ik}$ .and. nb1 ) 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_zlarft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1, n-k+i ), & + call stdlib${ii}$_zlarft( 'BACKWARD', 'COLUMNWISE', m-k+i+ib-1, ib,a( 1_${ik}$, n-k+i ), & lda, tau( i ), work, ldwork ) ! apply h**h to a(1:m-k+i+ib-1,1:n-k+i-1) from the left - call stdlib_zlarfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'BACKWARD','COLUMNWISE', m-& - k+i+ib-1, n-k+i-1, ib,a( 1, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), & + call stdlib${ii}$_zlarfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'BACKWARD','COLUMNWISE', m-& + k+i+ib-1, n-k+i-1, ib,a( 1_${ik}$, n-k+i ), lda, work, ldwork, a, lda,work( ib+1 ), & ldwork ) end if end do - mu = m - k + i + nb - 1 - nu = n - k + i + nb - 1 + mu = m - k + i + nb - 1_${ik}$ + nu = n - k + i + nb - 1_${ik}$ else mu = m nu = n end if ! use unblocked code to factor the last or only block - if( mu>0 .and. nu>0 )call stdlib_zgeql2( mu, nu, a, lda, tau, work, iinfo ) - work( 1 ) = iws + if( mu>0_${ik}$ .and. nu>0_${ik}$ )call stdlib${ii}$_zgeql2( mu, nu, a, lda, tau, work, iinfo ) + work( 1_${ik}$ ) = iws return - end subroutine stdlib_zgeqlf + end subroutine stdlib${ii}$_zgeqlf - pure subroutine stdlib_zgeqr2( m, n, a, lda, tau, work, info ) + pure subroutine stdlib${ii}$_zgeqr2( m, n, a, lda, tau, work, info ) !! ZGEQR2 computes a QR factorization of a complex m-by-n matrix A: !! A = Q * ( R ), !! ( 0 ) @@ -34483,50 +34486,50 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: tau(*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, k + integer(${ik}$) :: i, k complex(dp) :: alpha ! Intrinsic Functions intrinsic :: conjg,max,min ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda0 .and. lwork0_${ik}$ .and. lwork1 .and. nb1_${ik}$ .and. nb1 .and. nb1_${ik}$ .and. nb t(i,1) - call stdlib_zlarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,t( i, 1 ) ) + call stdlib${ii}$_zlarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1_${ik}$,t( i, 1_${ik}$ ) ) if( i0 .and. lwork0_${ik}$ .and. lwork1 .and. nb1_${ik}$ .and. nb1 ) then + if( m-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_zlarft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( m-k+i, 1 ), lda, & + call stdlib${ii}$_zlarft( 'BACKWARD', 'ROWWISE', n-k+i+ib-1, ib,a( m-k+i, 1_${ik}$ ), lda, & tau( i ), work, ldwork ) ! apply h to a(1:m-k+i-1,1:n-k+i+ib-1) from the right - call stdlib_zlarfb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', m-k+i-1, n-& - k+i+ib-1, ib,a( m-k+i, 1 ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork ) + call stdlib${ii}$_zlarfb( 'RIGHT', 'NO TRANSPOSE', 'BACKWARD','ROWWISE', m-k+i-1, n-& + k+i+ib-1, ib,a( m-k+i, 1_${ik}$ ), lda, work, ldwork, a, lda,work( ib+1 ), ldwork ) end if end do - mu = m - k + i + nb - 1 - nu = n - k + i + nb - 1 + mu = m - k + i + nb - 1_${ik}$ + nu = n - k + i + nb - 1_${ik}$ else mu = m nu = n end if ! use unblocked code to factor the last or only block - if( mu>0 .and. nu>0 )call stdlib_zgerq2( mu, nu, a, lda, tau, work, iinfo ) - work( 1 ) = iws + if( mu>0_${ik}$ .and. nu>0_${ik}$ )call stdlib${ii}$_zgerq2( mu, nu, a, lda, tau, work, iinfo ) + work( 1_${ik}$ ) = iws return - end subroutine stdlib_zgerqf + end subroutine stdlib${ii}$_zgerqf - pure subroutine stdlib_zgesc2( n, a, lda, rhs, ipiv, jpiv, scale ) + pure subroutine stdlib${ii}$_zgesc2( n, a, lda, rhs, ipiv, jpiv, scale ) !! ZGESC2 solves a system of linear equations !! A * X = scale* RHS !! with a general N-by-N matrix A using the LU factorization with @@ -35105,28 +35108,28 @@ module stdlib_linalg_lapack_z ! -- 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, n + integer(${ik}$), intent(in) :: lda, n real(dp), intent(out) :: scale ! Array Arguments - integer(ilp), intent(in) :: ipiv(*), jpiv(*) + integer(${ik}$), intent(in) :: ipiv(*), jpiv(*) complex(dp), intent(in) :: a(lda,*) complex(dp), intent(inout) :: rhs(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: bignum, eps, smlnum complex(dp) :: temp ! Intrinsic Functions intrinsic :: abs,real,cmplx ! Executable Statements ! set constant to control overflow - eps = stdlib_dlamch( 'P' ) - smlnum = stdlib_dlamch( 'S' ) / eps + eps = stdlib${ii}$_dlamch( 'P' ) + smlnum = stdlib${ii}$_dlamch( 'S' ) / eps bignum = one / smlnum - call stdlib_dlabad( smlnum, bignum ) + call stdlib${ii}$_dlabad( smlnum, bignum ) ! apply permutations ipiv to rhs - call stdlib_zlaswp( 1, rhs, lda, 1, n-1, ipiv, 1 ) + call stdlib${ii}$_zlaswp( 1_${ik}$, rhs, lda, 1_${ik}$, n-1, ipiv, 1_${ik}$ ) ! solve for l part do i = 1, n - 1 do j = i + 1, n @@ -35136,10 +35139,10 @@ module stdlib_linalg_lapack_z ! solve for u part scale = one ! check for scaling - i = stdlib_izamax( n, rhs, 1 ) + i = stdlib${ii}$_izamax( n, rhs, 1_${ik}$ ) if( two*smlnum*abs( rhs( i ) )>abs( a( n, n ) ) ) then temp = cmplx( one / two, zero,KIND=dp) / abs( rhs( i ) ) - call stdlib_zscal( n, temp, rhs( 1 ), 1 ) + call stdlib${ii}$_zscal( n, temp, rhs( 1_${ik}$ ), 1_${ik}$ ) scale = scale*real( temp,KIND=dp) end if do i = n, 1, -1 @@ -35150,12 +35153,12 @@ module stdlib_linalg_lapack_z end do end do ! apply permutations jpiv to the solution (rhs) - call stdlib_zlaswp( 1, rhs, lda, 1, n-1, jpiv, -1 ) + call stdlib${ii}$_zlaswp( 1_${ik}$, rhs, lda, 1_${ik}$, n-1, jpiv, -1_${ik}$ ) return - end subroutine stdlib_zgesc2 + end subroutine stdlib${ii}$_zgesc2 - pure recursive subroutine stdlib_zgetrf2( m, n, a, lda, ipiv, info ) + pure recursive subroutine stdlib${ii}$_zgetrf2( m, n, a, lda, ipiv, info ) !! ZGETRF2 computes an LU factorization of a general M-by-N matrix A !! using partial pivoting with row interchanges. !! The factorization has the form @@ -35179,99 +35182,99 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars real(dp) :: sfmin complex(dp) :: temp - integer(ilp) :: i, iinfo, n1, n2 + integer(${ik}$) :: i, iinfo, n1, n2 ! 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_zscal( m-1, cone / a( 1, 1 ), a( 2, 1 ), 1 ) + if( abs(a( 1_${ik}$, 1_${ik}$ )) >= sfmin ) then + call stdlib${ii}$_zscal( m-1, cone / 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_zgetrf2( m, n1, a, lda, ipiv, iinfo ) - if ( info==0 .and. iinfo>0 )info = iinfo + call stdlib${ii}$_zgetrf2( m, n1, a, lda, ipiv, iinfo ) + if ( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo ! [ a12 ] ! apply interchanges to [ --- ] ! [ a22 ] - call stdlib_zlaswp( n2, a( 1, n1+1 ), lda, 1, n1, ipiv, 1 ) + call stdlib${ii}$_zlaswp( n2, a( 1_${ik}$, n1+1 ), lda, 1_${ik}$, n1, ipiv, 1_${ik}$ ) ! solve a12 - call stdlib_ztrsm( 'L', 'L', 'N', 'U', n1, n2, cone, a, lda,a( 1, n1+1 ), lda ) + call stdlib${ii}$_ztrsm( 'L', 'L', 'N', 'U', n1, n2, cone, a, lda,a( 1_${ik}$, n1+1 ), lda ) ! update a22 - call stdlib_zgemm( 'N', 'N', m-n1, n2, n1, -cone, a( n1+1, 1 ), lda,a( 1, n1+1 ), & + call stdlib${ii}$_zgemm( 'N', 'N', m-n1, n2, n1, -cone, a( n1+1, 1_${ik}$ ), lda,a( 1_${ik}$, n1+1 ), & lda, cone, a( n1+1, n1+1 ), lda ) ! factor a22 - call stdlib_zgetrf2( m-n1, n2, a( n1+1, n1+1 ), lda, ipiv( n1+1 ),iinfo ) + call stdlib${ii}$_zgetrf2( 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_zlaswp( n1, a( 1, 1 ), lda, n1+1, min( m, n), ipiv, 1 ) + call stdlib${ii}$_zlaswp( n1, a( 1_${ik}$, 1_${ik}$ ), lda, n1+1, min( m, n), ipiv, 1_${ik}$ ) end if return - end subroutine stdlib_zgetrf2 + end subroutine stdlib${ii}$_zgetrf2 - pure subroutine stdlib_zgetri( n, a, lda, ipiv, work, lwork, info ) + pure subroutine stdlib${ii}$_zgetri( n, a, lda, ipiv, work, lwork, info ) !! ZGETRI computes the inverse of a matrix using the LU factorization !! computed by ZGETRF. !! This method inverts U and then computes inv(A) by solving the system @@ -35280,52 +35283,52 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), 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, 'ZGETRI', ' ', n, -1, -1, -1 ) + info = 0_${ik}$ + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGETRI', ' ', 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_ztrtri, then u is singular, + ! form inv(u). if info > 0 from stdlib${ii}$_ztrtri, then u is singular, ! and the inverse is not computed. - call stdlib_ztrtri( 'UPPER', 'NON-UNIT', n, a, lda, info ) + call stdlib${ii}$_ztrtri( '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_zgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) + call stdlib${ii}$_zgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) else do j = 1, nrhs, nb jb = min( nrhs-j+1, nb ) - call stdlib_zgtts2( itrans, n, jb, dl, d, du, du2, ipiv, b( 1, j ),ldb ) + call stdlib${ii}$_zgtts2( itrans, n, jb, dl, d, du, du2, ipiv, b( 1_${ik}$, j ),ldb ) end do end if - end subroutine stdlib_zgttrs + end subroutine stdlib${ii}$_zgttrs - pure subroutine stdlib_zhb2st_kernels( uplo, wantz, ttype,st, ed, sweep, n, nb, ib,a, lda, & + pure subroutine stdlib${ii}$_zhb2st_kernels( uplo, wantz, ttype,st, ed, sweep, n, nb, ib,a, lda, & !! ZHB2ST_KERNELS is an internal routine used by the ZHETRD_HB2ST !! subroutine. v, tau, ldvt, work) @@ -35806,7 +35809,7 @@ module stdlib_linalg_lapack_z ! Scalar Arguments character, intent(in) :: uplo logical(lk), intent(in) :: wantz - integer(ilp), intent(in) :: ttype, st, ed, sweep, n, nb, ib, lda, ldvt + integer(${ik}$), intent(in) :: ttype, st, ed, sweep, n, nb, ib, lda, ldvt ! Array Arguments complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: v(*), tau(*), work(*) @@ -35814,7 +35817,7 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: upper - integer(ilp) :: i, j1, j2, lm, ln, vpos, taupos, dpos, ofdpos, ajeter + integer(${ik}$) :: i, j1, j2, lm, ln, vpos, taupos, dpos, ofdpos, ajeter complex(dp) :: ctmp ! Intrinsic Functions intrinsic :: conjg,mod @@ -35822,54 +35825,54 @@ module stdlib_linalg_lapack_z ajeter = ib + ldvt upper = stdlib_lsame( uplo, 'U' ) if( upper ) then - dpos = 2 * nb + 1 - ofdpos = 2 * nb + dpos = 2_${ik}$ * nb + 1_${ik}$ + ofdpos = 2_${ik}$ * nb else - dpos = 1 - ofdpos = 2 + dpos = 1_${ik}$ + ofdpos = 2_${ik}$ endif ! upper case if( upper ) then if( wantz ) then - vpos = mod( sweep-1, 2 ) * n + st - taupos = mod( sweep-1, 2 ) * n + st + vpos = mod( sweep-1, 2_${ik}$ ) * n + st + taupos = mod( sweep-1, 2_${ik}$ ) * n + st else - vpos = mod( sweep-1, 2 ) * n + st - taupos = mod( sweep-1, 2 ) * n + st + vpos = mod( sweep-1, 2_${ik}$ ) * n + st + taupos = mod( sweep-1, 2_${ik}$ ) * n + st endif - if( ttype==1 ) then - lm = ed - st + 1 + if( ttype==1_${ik}$ ) then + lm = ed - st + 1_${ik}$ v( vpos ) = cone do i = 1, lm-1 v( vpos+i ) = conjg( a( ofdpos-i, st+i ) ) a( ofdpos-i, st+i ) = czero end do ctmp = conjg( a( ofdpos, st ) ) - call stdlib_zlarfg( lm, ctmp, v( vpos+1 ), 1,tau( taupos ) ) + call stdlib${ii}$_zlarfg( lm, ctmp, v( vpos+1 ), 1_${ik}$,tau( taupos ) ) a( ofdpos, st ) = ctmp - lm = ed - st + 1 - call stdlib_zlarfy( uplo, lm, v( vpos ), 1,conjg( tau( taupos ) ),a( dpos, st )& + lm = ed - st + 1_${ik}$ + call stdlib${ii}$_zlarfy( uplo, lm, v( vpos ), 1_${ik}$,conjg( tau( taupos ) ),a( dpos, st )& , lda-1, work) endif - if( ttype==3 ) then - lm = ed - st + 1 - call stdlib_zlarfy( uplo, lm, v( vpos ), 1,conjg( tau( taupos ) ),a( dpos, st )& + if( ttype==3_${ik}$ ) then + lm = ed - st + 1_${ik}$ + call stdlib${ii}$_zlarfy( uplo, lm, v( vpos ), 1_${ik}$,conjg( tau( taupos ) ),a( dpos, st )& , lda-1, work) endif - if( ttype==2 ) then + if( ttype==2_${ik}$ ) then j1 = ed+1 j2 = min( ed+nb, n ) ln = ed-st+1 lm = j2-j1+1 - if( lm>0) then - call stdlib_zlarfx( 'LEFT', ln, lm, v( vpos ),conjg( tau( taupos ) ),a( & + if( lm>0_${ik}$) then + call stdlib${ii}$_zlarfx( 'LEFT', ln, lm, v( vpos ),conjg( tau( taupos ) ),a( & dpos-nb, j1 ), lda-1, work) if( wantz ) then - vpos = mod( sweep-1, 2 ) * n + j1 - taupos = mod( sweep-1, 2 ) * n + j1 + vpos = mod( sweep-1, 2_${ik}$ ) * n + j1 + taupos = mod( sweep-1, 2_${ik}$ ) * n + j1 else - vpos = mod( sweep-1, 2 ) * n + j1 - taupos = mod( sweep-1, 2 ) * n + j1 + vpos = mod( sweep-1, 2_${ik}$ ) * n + j1 + taupos = mod( sweep-1, 2_${ik}$ ) * n + j1 endif v( vpos ) = cone do i = 1, lm-1 @@ -35877,71 +35880,71 @@ module stdlib_linalg_lapack_z a( dpos-nb-i, j1+i ) = czero end do ctmp = conjg( a( dpos-nb, j1 ) ) - call stdlib_zlarfg( lm, ctmp, v( vpos+1 ), 1, tau( taupos ) ) + call stdlib${ii}$_zlarfg( lm, ctmp, v( vpos+1 ), 1_${ik}$, tau( taupos ) ) a( dpos-nb, j1 ) = ctmp - call stdlib_zlarfx( 'RIGHT', ln-1, lm, v( vpos ),tau( taupos ),a( dpos-nb+& - 1, j1 ), lda-1, work) + call stdlib${ii}$_zlarfx( 'RIGHT', ln-1, lm, v( vpos ),tau( taupos ),a( dpos-nb+& + 1_${ik}$, j1 ), lda-1, work) endif endif ! lower case else if( wantz ) then - vpos = mod( sweep-1, 2 ) * n + st - taupos = mod( sweep-1, 2 ) * n + st + vpos = mod( sweep-1, 2_${ik}$ ) * n + st + taupos = mod( sweep-1, 2_${ik}$ ) * n + st else - vpos = mod( sweep-1, 2 ) * n + st - taupos = mod( sweep-1, 2 ) * n + st + vpos = mod( sweep-1, 2_${ik}$ ) * n + st + taupos = mod( sweep-1, 2_${ik}$ ) * n + st endif - if( ttype==1 ) then - lm = ed - st + 1 + if( ttype==1_${ik}$ ) then + lm = ed - st + 1_${ik}$ v( vpos ) = cone do i = 1, lm-1 v( vpos+i ) = a( ofdpos+i, st-1 ) a( ofdpos+i, st-1 ) = czero end do - call stdlib_zlarfg( lm, a( ofdpos, st-1 ), v( vpos+1 ), 1,tau( taupos ) ) + call stdlib${ii}$_zlarfg( lm, a( ofdpos, st-1 ), v( vpos+1 ), 1_${ik}$,tau( taupos ) ) - lm = ed - st + 1 - call stdlib_zlarfy( uplo, lm, v( vpos ), 1,conjg( tau( taupos ) ),a( dpos, st )& + lm = ed - st + 1_${ik}$ + call stdlib${ii}$_zlarfy( uplo, lm, v( vpos ), 1_${ik}$,conjg( tau( taupos ) ),a( dpos, st )& , lda-1, work) endif - if( ttype==3 ) then - lm = ed - st + 1 - call stdlib_zlarfy( uplo, lm, v( vpos ), 1,conjg( tau( taupos ) ),a( dpos, st )& + if( ttype==3_${ik}$ ) then + lm = ed - st + 1_${ik}$ + call stdlib${ii}$_zlarfy( uplo, lm, v( vpos ), 1_${ik}$,conjg( tau( taupos ) ),a( dpos, st )& , lda-1, work) endif - if( ttype==2 ) then + if( ttype==2_${ik}$ ) then j1 = ed+1 j2 = min( ed+nb, n ) ln = ed-st+1 lm = j2-j1+1 - if( lm>0) then - call stdlib_zlarfx( 'RIGHT', lm, ln, v( vpos ),tau( taupos ), a( dpos+nb, & + if( lm>0_${ik}$) then + call stdlib${ii}$_zlarfx( 'RIGHT', lm, ln, v( vpos ),tau( taupos ), a( dpos+nb, & st ),lda-1, work) if( wantz ) then - vpos = mod( sweep-1, 2 ) * n + j1 - taupos = mod( sweep-1, 2 ) * n + j1 + vpos = mod( sweep-1, 2_${ik}$ ) * n + j1 + taupos = mod( sweep-1, 2_${ik}$ ) * n + j1 else - vpos = mod( sweep-1, 2 ) * n + j1 - taupos = mod( sweep-1, 2 ) * n + j1 + vpos = mod( sweep-1, 2_${ik}$ ) * n + j1 + taupos = mod( sweep-1, 2_${ik}$ ) * n + j1 endif v( vpos ) = cone do i = 1, lm-1 v( vpos+i ) = a( dpos+nb+i, st ) a( dpos+nb+i, st ) = czero end do - call stdlib_zlarfg( lm, a( dpos+nb, st ), v( vpos+1 ), 1,tau( taupos ) ) + call stdlib${ii}$_zlarfg( lm, a( dpos+nb, st ), v( vpos+1 ), 1_${ik}$,tau( taupos ) ) - call stdlib_zlarfx( 'LEFT', lm, ln-1, v( vpos ),conjg( tau( taupos ) ),a( & + call stdlib${ii}$_zlarfx( 'LEFT', lm, ln-1, v( vpos ),conjg( tau( taupos ) ),a( & dpos+nb-1, st+1 ), lda-1, work) endif endif endif return - end subroutine stdlib_zhb2st_kernels + end subroutine stdlib${ii}$_zhb2st_kernels - pure subroutine stdlib_zheequb( uplo, n, a, lda, s, scond, amax, work, info ) + pure subroutine stdlib${ii}$_zheequb( uplo, n, a, lda, s, scond, amax, work, info ) !! ZHEEQUB computes row and column scalings intended to equilibrate a !! Hermitian matrix A (with respect to the Euclidean norm) and reduce !! its condition number. The scale factors S are computed by the BIN @@ -35953,8 +35956,8 @@ module stdlib_linalg_lapack_z ! -- 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(dp), intent(out) :: amax, scond character, intent(in) :: uplo ! Array Arguments @@ -35963,11 +35966,11 @@ module stdlib_linalg_lapack_z real(dp), intent(out) :: s(*) ! ===================================================================== ! 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(dp) :: avg, std, tol, c0, c1, c2, t, u, si, d, base, smin, smax, smlnum, bignum, & scale, sumsq logical(lk) :: up @@ -35980,22 +35983,22 @@ module stdlib_linalg_lapack_z cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) ) ! 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( 'ZHEEQUB', -info ) + if ( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZHEEQUB', -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 @@ -36062,7 +36065,7 @@ module stdlib_linalg_lapack_z do i = n+1, 2*n work( i ) = s( i-n ) * work( i-n ) - avg end do - call stdlib_zlassq( n, work( n+1 ), 1, scale, sumsq ) + call stdlib${ii}$_zlassq( n, work( n+1 ), 1_${ik}$, scale, sumsq ) std = scale * sqrt( sumsq / n ) if ( std < tol * avg ) goto 999 do i = 1, n @@ -36070,13 +36073,13 @@ module stdlib_linalg_lapack_z si = s( i ) c2 = ( n-1 ) * t c1 = ( n-2 ) * ( real( work( i ),KIND=dp) - t*si ) - c0 = -(t*si)*si + 2 * real( work( i ),KIND=dp) * si - n*avg - d = c1*c1 - 4*c0*c2 - if ( d <= 0 ) then - info = -1 + c0 = -(t*si)*si + 2_${ik}$ * real( work( i ),KIND=dp) * 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 @@ -36107,23 +36110,23 @@ module stdlib_linalg_lapack_z end do end do 999 continue - smlnum = stdlib_dlamch( 'SAFEMIN' ) + smlnum = stdlib${ii}$_dlamch( 'SAFEMIN' ) bignum = one / smlnum smin = bignum smax = zero t = one / sqrt( avg ) - base = stdlib_dlamch( 'B' ) + base = stdlib${ii}$_dlamch( '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_zheequb + end subroutine stdlib${ii}$_zheequb - pure subroutine stdlib_zhegs2( itype, uplo, n, a, lda, b, ldb, info ) + pure subroutine stdlib${ii}$_zhegs2( itype, uplo, n, a, lda, b, ldb, info ) !! ZHEGS2 reduces a complex Hermitian-definite generalized !! eigenproblem to standard form. !! If ITYPE = 1, the problem is A*x = lambda*B*x, @@ -36136,8 +36139,8 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: a(lda,*), b(ldb,*) ! ===================================================================== @@ -36145,52 +36148,52 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: upper - integer(ilp) :: k + integer(${ik}$) :: k real(dp) :: akk, bkk complex(dp) :: 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}$, 'ZHEGST', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code - call stdlib_zhegs2( itype, uplo, n, a, lda, b, ldb, info ) + call stdlib${ii}$_zhegs2( 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**h)*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_zhegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib${ii}$_zhegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) if( k+kb<=n ) then - call stdlib_ztrsm( 'LEFT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', kb, & + call stdlib${ii}$_ztrsm( 'LEFT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', kb, & n-k-kb+1, cone,b( k, k ), ldb, a( k, k+kb ), lda ) - call stdlib_zhemm( 'LEFT', uplo, kb, n-k-kb+1, -chalf,a( k, k ), lda, b(& + call stdlib${ii}$_zhemm( 'LEFT', uplo, kb, n-k-kb+1, -chalf,a( k, k ), lda, b(& k, k+kb ), ldb,cone, a( k, k+kb ), lda ) - call stdlib_zher2k( uplo, 'CONJUGATE TRANSPOSE', n-k-kb+1,kb, -cone, a( & + call stdlib${ii}$_zher2k( uplo, 'CONJUGATE TRANSPOSE', n-k-kb+1,kb, -cone, a( & k, k+kb ), lda,b( k, k+kb ), ldb, one,a( k+kb, k+kb ), lda ) - call stdlib_zhemm( 'LEFT', uplo, kb, n-k-kb+1, -chalf,a( k, k ), lda, b(& + call stdlib${ii}$_zhemm( 'LEFT', uplo, kb, n-k-kb+1, -chalf,a( k, k ), lda, b(& k, k+kb ), ldb,cone, a( k, k+kb ), lda ) - call stdlib_ztrsm( 'RIGHT', uplo, 'NO TRANSPOSE','NON-UNIT', kb, n-k-kb+& - 1, cone,b( k+kb, k+kb ), ldb, a( k, k+kb ),lda ) + call stdlib${ii}$_ztrsm( 'RIGHT', uplo, 'NO TRANSPOSE','NON-UNIT', kb, n-k-kb+& + 1_${ik}$, cone,b( k+kb, k+kb ), ldb, a( k, k+kb ),lda ) end if end do else @@ -36335,18 +36338,18 @@ module stdlib_linalg_lapack_z do k = 1, n, nb kb = min( n-k+1, nb ) ! update the lower triangle of a(k:n,k:n) - call stdlib_zhegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib${ii}$_zhegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) if( k+kb<=n ) then - call stdlib_ztrsm( 'RIGHT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', n-k-& + call stdlib${ii}$_ztrsm( 'RIGHT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', n-k-& kb+1, kb, cone,b( k, k ), ldb, a( k+kb, k ), lda ) - call stdlib_zhemm( 'RIGHT', uplo, n-k-kb+1, kb, -chalf,a( k, k ), lda, & + call stdlib${ii}$_zhemm( 'RIGHT', uplo, n-k-kb+1, kb, -chalf,a( k, k ), lda, & b( k+kb, k ), ldb,cone, a( k+kb, k ), lda ) - call stdlib_zher2k( uplo, 'NO TRANSPOSE', n-k-kb+1, kb,-cone, a( k+kb, & + call stdlib${ii}$_zher2k( uplo, 'NO TRANSPOSE', n-k-kb+1, kb,-cone, a( k+kb, & k ), lda,b( k+kb, k ), ldb, one,a( k+kb, k+kb ), lda ) - call stdlib_zhemm( 'RIGHT', uplo, n-k-kb+1, kb, -chalf,a( k, k ), lda, & + call stdlib${ii}$_zhemm( 'RIGHT', uplo, n-k-kb+1, kb, -chalf,a( k, k ), lda, & b( k+kb, k ), ldb,cone, a( k+kb, k ), lda ) - call stdlib_ztrsm( 'LEFT', uplo, 'NO TRANSPOSE','NON-UNIT', n-k-kb+1, & + call stdlib${ii}$_ztrsm( 'LEFT', uplo, 'NO TRANSPOSE','NON-UNIT', n-k-kb+1, & kb, cone,b( k+kb, k+kb ), ldb, a( k+kb, k ),lda ) end if end do @@ -36357,17 +36360,17 @@ module stdlib_linalg_lapack_z 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_ztrmm( 'LEFT', uplo, 'NO TRANSPOSE', 'NON-UNIT',k-1, kb, cone, & - b, ldb, a( 1, k ), lda ) - call stdlib_zhemm( 'RIGHT', uplo, k-1, kb, chalf, a( k, k ),lda, b( 1, k ),& - ldb, cone, a( 1, k ),lda ) - call stdlib_zher2k( uplo, 'NO TRANSPOSE', k-1, kb, cone,a( 1, k ), lda, b( & - 1, k ), ldb, one, a,lda ) - call stdlib_zhemm( 'RIGHT', uplo, k-1, kb, chalf, a( k, k ),lda, b( 1, k ),& - ldb, cone, a( 1, k ),lda ) - call stdlib_ztrmm( 'RIGHT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', k-1, & - kb, cone, b( k, k ), ldb,a( 1, k ), lda ) - call stdlib_zhegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib${ii}$_ztrmm( 'LEFT', uplo, 'NO TRANSPOSE', 'NON-UNIT',k-1, kb, cone, & + b, ldb, a( 1_${ik}$, k ), lda ) + call stdlib${ii}$_zhemm( 'RIGHT', uplo, k-1, kb, chalf, a( k, k ),lda, b( 1_${ik}$, k ),& + ldb, cone, a( 1_${ik}$, k ),lda ) + call stdlib${ii}$_zher2k( uplo, 'NO TRANSPOSE', k-1, kb, cone,a( 1_${ik}$, k ), lda, b( & + 1_${ik}$, k ), ldb, one, a,lda ) + call stdlib${ii}$_zhemm( 'RIGHT', uplo, k-1, kb, chalf, a( k, k ),lda, b( 1_${ik}$, k ),& + ldb, cone, a( 1_${ik}$, k ),lda ) + call stdlib${ii}$_ztrmm( 'RIGHT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', k-1, & + kb, cone, b( k, k ), ldb,a( 1_${ik}$, k ), lda ) + call stdlib${ii}$_zhegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) end do else @@ -36375,27 +36378,27 @@ module stdlib_linalg_lapack_z 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_ztrmm( 'RIGHT', uplo, 'NO TRANSPOSE', 'NON-UNIT',kb, k-1, cone,& - b, ldb, a( k, 1 ), lda ) - call stdlib_zhemm( 'LEFT', uplo, kb, k-1, chalf, a( k, k ),lda, b( k, 1 ), & - ldb, cone, a( k, 1 ),lda ) - call stdlib_zher2k( uplo, 'CONJUGATE TRANSPOSE', k-1, kb,cone, a( k, 1 ), & - lda, b( k, 1 ), ldb,one, a, lda ) - call stdlib_zhemm( 'LEFT', uplo, kb, k-1, chalf, a( k, k ),lda, b( k, 1 ), & - ldb, cone, a( k, 1 ),lda ) - call stdlib_ztrmm( 'LEFT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', kb, k-1,& - cone, b( k, k ), ldb,a( k, 1 ), lda ) - call stdlib_zhegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) + call stdlib${ii}$_ztrmm( 'RIGHT', uplo, 'NO TRANSPOSE', 'NON-UNIT',kb, k-1, cone,& + b, ldb, a( k, 1_${ik}$ ), lda ) + call stdlib${ii}$_zhemm( 'LEFT', uplo, kb, k-1, chalf, a( k, k ),lda, b( k, 1_${ik}$ ), & + ldb, cone, a( k, 1_${ik}$ ),lda ) + call stdlib${ii}$_zher2k( uplo, 'CONJUGATE TRANSPOSE', k-1, kb,cone, a( k, 1_${ik}$ ), & + lda, b( k, 1_${ik}$ ), ldb,one, a, lda ) + call stdlib${ii}$_zhemm( 'LEFT', uplo, kb, k-1, chalf, a( k, k ),lda, b( k, 1_${ik}$ ), & + ldb, cone, a( k, 1_${ik}$ ),lda ) + call stdlib${ii}$_ztrmm( 'LEFT', uplo, 'CONJUGATE TRANSPOSE','NON-UNIT', kb, k-1,& + cone, b( k, k ), ldb,a( k, 1_${ik}$ ), lda ) + call stdlib${ii}$_zhegs2( itype, uplo, kb, a( k, k ), lda,b( k, k ), ldb, info ) end do end if end if end if return - end subroutine stdlib_zhegst + end subroutine stdlib${ii}$_zhegst - pure subroutine stdlib_zhetd2( uplo, n, a, lda, d, e, tau, info ) + pure subroutine stdlib${ii}$_zhetd2( uplo, n, a, lda, d, e, tau, info ) !! ZHETD2 reduces a complex Hermitian matrix A to real symmetric !! tridiagonal form T by a unitary similarity transformation: !! Q**H * A * Q = T. @@ -36404,8 +36407,8 @@ module stdlib_linalg_lapack_z ! -- 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(dp), intent(out) :: d(*), e(*) complex(dp), intent(inout) :: a(lda,*) @@ -36414,23 +36417,23 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: upper - integer(ilp) :: i + integer(${ik}$) :: i complex(dp) :: alpha, taui ! Intrinsic Functions intrinsic :: real,max,min ! 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 .and. nb1_${ik}$ .and. nbed ) exit @@ -36828,24 +36831,24 @@ module stdlib_linalg_lapack_z loop_130: do sweepid = st, ed loop_140: do k = 1, grsiz myid = (i-sweepid)*(stepercol*grsiz)+ (m-1)*grsiz + k - if ( myid==1 ) then - ttype = 1 + if ( myid==1_${ik}$ ) then + ttype = 1_${ik}$ else - ttype = mod( myid, 2 ) + 2 + ttype = mod( myid, 2_${ik}$ ) + 2_${ik}$ endif - if( ttype==2 ) then - colpt = (myid/2)*kd + sweepid + if( ttype==2_${ik}$ ) then + colpt = (myid/2_${ik}$)*kd + sweepid stind = colpt-kd+1 edind = min(colpt,n) blklastind = colpt else - colpt = ((myid+1)/2)*kd + sweepid + colpt = ((myid+1)/2_${ik}$)*kd + sweepid stind = colpt-kd+1 edind = min(colpt,n) if( ( stind>=edind-1 ).and.( edind==n ) ) then blklastind = n else - blklastind = 0 + blklastind = 0_${ik}$ endif endif ! call the kernel @@ -36854,7 +36857,7 @@ module stdlib_linalg_lapack_z !$OMP& DEPEND(in:WORK(MYID-1)) & !$OMP& DEPEND(out:WORK(MYID)) !$ tid = omp_get_thread_num() - !$ call stdlib_zhb2st_kernels( uplo, wantq, ttype,stind, edind, & + !$ call stdlib${ii}$_zhb2st_kernels( uplo, wantq, ttype,stind, edind, & !$ sweepid, n, kd, ib,work ( inda ), lda,hous( indv ), hous( & !$ indtau ), ldv,work( indw + tid*kd ) ) !$OMP END TASK @@ -36862,13 +36865,13 @@ module stdlib_linalg_lapack_z !$OMP TASK DEPEND(in:WORK(MYID+SHIFT-1)) & !$OMP& DEPEND(out:WORK(MYID)) !$ tid = omp_get_thread_num() - call stdlib_zhb2st_kernels( uplo, wantq, ttype,stind, edind, & + call stdlib${ii}$_zhb2st_kernels( uplo, wantq, ttype,stind, edind, & sweepid, n, kd, ib,work ( inda ), lda,hous( indv ), hous( & indtau ), ldv,work( indw + tid*kd ) ) !$OMP END TASK !$ endif if ( blklastind>=(n-1) ) then - stt = stt + 1 + stt = stt + 1_${ik}$ exit endif end do loop_140 @@ -36894,13 +36897,13 @@ module stdlib_linalg_lapack_z e( i ) = real( work( ofdpos+(i-1)*lda ),KIND=dp) end do endif - hous( 1 ) = lhmin - work( 1 ) = lwmin + hous( 1_${ik}$ ) = lhmin + work( 1_${ik}$ ) = lwmin return - end subroutine stdlib_zhetrd_hb2st + end subroutine stdlib${ii}$_zhetrd_hb2st - subroutine stdlib_zhetrd_he2hb( uplo, n, kd, a, lda, ab, ldab, tau,work, lwork, info ) + subroutine stdlib${ii}$_zhetrd_he2hb( uplo, n, kd, a, lda, ab, ldab, tau,work, lwork, info ) !! ZHETRD_HE2HB reduces a complex Hermitian matrix A to complex Hermitian !! band-diagonal form AB by a unitary similarity transformation: !! Q**H * A * Q = AB. @@ -36910,8 +36913,8 @@ module stdlib_linalg_lapack_z ! -- 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, ldab, lwork, n, kd + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldab, lwork, n, kd ! Array Arguments complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: ab(ldab,*), tau(*), work(*) @@ -36922,35 +36925,35 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: lquery, upper - integer(ilp) :: i, j, iinfo, lwmin, pn, pk, llk, ldt, ldw, lds2, lds1, ls2, ls1, lw, lt,& + integer(${ik}$) :: i, j, iinfo, lwmin, pn, pk, llk, ldt, ldw, lds2, lds1, ls2, ls1, lw, lt,& tpos, wpos, s2pos, s1pos ! Intrinsic Functions intrinsic :: min,max ! Executable Statements ! determine the minimal workspace size required ! and test the input parameters - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) - lquery = ( lwork==-1 ) - lwmin = stdlib_ilaenv2stage( 4, 'ZHETRD_HE2HB', '', n, kd, -1, -1 ) + lquery = ( lwork==-1_${ik}$ ) + lwmin = stdlib${ii}$_ilaenv2stage( 4_${ik}$, 'ZHETRD_HE2HB', '', n, kd, -1_${ik}$, -1_${ik}$ ) 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( 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_zlahef( uplo, k, nb, kb, a, lda, ipiv, work, n, iinfo ) + call stdlib${ii}$_zlahef( uplo, k, nb, kb, a, lda, ipiv, work, n, iinfo ) else ! use unblocked code to factorize columns 1:k of a - call stdlib_zhetf2( uplo, k, a, lda, ipiv, iinfo ) + call stdlib${ii}$_zhetf2( 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 ! decrease k and return to the start of the main loop k = k - kb go to 10 else ! factorize a as l*d*l**h using the lower triangle of a ! k is the main loop index, increasing from 1 to n in steps of - ! kb, where kb is the number of columns factorized by stdlib_zlahef; + ! kb, where kb is the number of columns factorized by stdlib${ii}$_zlahef; ! 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_zlahef( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, n, & + call stdlib${ii}$_zlahef( uplo, n-k+1, nb, kb, a( k, k ), lda, ipiv( k ),work, n, & iinfo ) else ! use unblocked code to factorize columns k:n of a - call stdlib_zhetf2( uplo, n-k+1, a( k, k ), lda, ipiv( k ), iinfo ) - kb = n - k + 1 + call stdlib${ii}$_zhetf2( 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 @@ -37197,12 +37200,12 @@ module stdlib_linalg_lapack_z go to 20 end if 40 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_zhetrf + end subroutine stdlib${ii}$_zhetrf - pure subroutine stdlib_zhetrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) + pure subroutine stdlib${ii}$_zhetrf_rk( uplo, n, a, lda, e, ipiv, work, lwork,info ) !! ZHETRF_RK computes the factorization of a complex Hermitian matrix A !! using the bounded Bunch-Kaufman (rook) diagonal pivoting method: !! A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T), @@ -37217,60 +37220,60 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), 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_zlahef_rk( uplo, k, nb, kb, a, lda, e,ipiv, work, ldwork, iinfo ) + call stdlib${ii}$_zlahef_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_zhetf2_rk( uplo, k, a, lda, e, ipiv, iinfo ) + call stdlib${ii}$_zhetf2_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 ! read ipiv from the last block factored, i.e. @@ -37300,7 +37303,7 @@ module stdlib_linalg_lapack_z do i = k, ( k - kb + 1 ), -1 ip = abs( ipiv( i ) ) if( ip/=i ) then - call stdlib_zswap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda ) + call stdlib${ii}$_zswap( n-k, a( i, k+1 ), lda,a( ip, k+1 ), lda ) end if end do end if @@ -37313,31 +37316,31 @@ module stdlib_linalg_lapack_z 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_zlahef_rk; + ! kb, where kb is the number of columns factorized by stdlib${ii}$_zlahef_rk; ! 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 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_zlahef_rk( uplo, n-k+1, nb, kb, a( k, k ), lda, e( k ),ipiv( k ), & + call stdlib${ii}$_zlahef_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_zhetf2_rk( uplo, n-k+1, a( k, k ), lda, e( k ),ipiv( k ), iinfo ) + call stdlib${ii}$_zhetf2_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 @@ -37347,11 +37350,11 @@ module stdlib_linalg_lapack_z ! (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 + if( k>1_${ik}$ ) then do i = k, ( k + kb - 1 ), 1 ip = abs( ipiv( i ) ) if( ip/=i ) then - call stdlib_zswap( k-1, a( i, 1 ), lda,a( ip, 1 ), lda ) + call stdlib${ii}$_zswap( k-1, a( i, 1_${ik}$ ), lda,a( ip, 1_${ik}$ ), lda ) end if end do end if @@ -37363,12 +37366,12 @@ module stdlib_linalg_lapack_z 35 continue ! end lower end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_zhetrf_rk + end subroutine stdlib${ii}$_zhetrf_rk - pure subroutine stdlib_zhetrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) + pure subroutine stdlib${ii}$_zhetrf_rook( uplo, n, a, lda, ipiv, work, lwork, info ) !! ZHETRF_ROOK computes the factorization of a complex Hermitian matrix A !! using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. !! The form of the factorization is @@ -37382,60 +37385,60 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), 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_zlahef_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo ) + call stdlib${ii}$_zlahef_rook( uplo, k, nb, kb, a, lda,ipiv, work, ldwork, iinfo ) else ! use unblocked code to factorize columns 1:k of a - call stdlib_zhetf2_rook( uplo, k, a, lda, ipiv, iinfo ) + call stdlib${ii}$_zhetf2_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 @@ -37460,30 +37463,30 @@ module stdlib_linalg_lapack_z 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_zlahef_rook; + ! kb, where kb is the number of columns factorized by stdlib${ii}$_zlahef_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_zlahef_rook( uplo, n-k+1, nb, kb, a( k, k ), lda,ipiv( k ), work, & + call stdlib${ii}$_zlahef_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_zhetf2_rook( uplo, n-k+1, a( k, k ), lda, ipiv( k ),iinfo ) - kb = n - k + 1 + call stdlib${ii}$_zhetf2_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 @@ -37491,12 +37494,12 @@ module stdlib_linalg_lapack_z go to 20 end if 40 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_zhetrf_rook + end subroutine stdlib${ii}$_zhetrf_rook - pure subroutine stdlib_zhetrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info ) + pure subroutine stdlib${ii}$_zhetrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info ) !! ZHETRS solves a system of linear equations A*X = B with a complex !! Hermitian matrix A using the factorization A = U*D*U**H or !! A = L*D*L**H computed by ZHETRF. @@ -37505,37 +37508,37 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(in) :: a(lda,*) complex(dp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: j, k, kp + integer(${ik}$) :: j, k, kp real(dp) :: s complex(dp) :: ak, akm1, akm1k, bk, bkm1, denom ! Intrinsic Functions intrinsic :: real,conjg,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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_zgeru( k-1, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & + call stdlib${ii}$_zgeru( k-1, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb & ) ! multiply by the inverse of the diagonal block. s = real( cone,KIND=dp) / real( a( k, k ),KIND=dp) - call stdlib_zdscal( nrhs, s, b( k, 1 ), ldb ) - k = k - 1 + call stdlib${ii}$_zdscal( nrhs, s, b( k, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( kp/=k-1 )call stdlib_zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib${ii}$_zswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - call stdlib_zgeru( k-2, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & + call stdlib${ii}$_zgeru( k-2, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb & ) - call stdlib_zgeru( k-2, nrhs, -cone, a( 1, k-1 ), 1, b( k-1, 1 ),ldb, b( 1, 1 ), & + call stdlib${ii}$_zgeru( k-2, nrhs, -cone, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), & ldb ) ! multiply by the inverse of the diagonal block. akm1k = a( k-1, k ) @@ -37584,49 +37587,49 @@ module stdlib_linalg_lapack_z 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**h *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 = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(u**h(k)), where u(k) is the transformation ! stored in column k of a. - if( k>1 ) then - call stdlib_zlacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_zgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), & - 1, cone, b( k, 1 ), ldb ) - call stdlib_zlacgv( nrhs, b( k, 1 ), ldb ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), & + 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb ) end if ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 1 + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 1_${ik}$ else ! 2 x 2 diagonal block ! multiply by inv(u**h(k+1)), where u(k+1) is the transformation ! stored in columns k and k+1 of a. - if( k>1 ) then - call stdlib_zlacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_zgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), & - 1, cone, b( k, 1 ), ldb ) - call stdlib_zlacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_zlacgv( nrhs, b( k+1, 1 ), ldb ) - call stdlib_zgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k+1 )& - , 1, cone, b( k+1, 1 ), ldb ) - call stdlib_zlacgv( nrhs, b( k+1, 1 ), ldb ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), & + 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zlacgv( nrhs, b( k+1, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k+1 )& + , 1_${ik}$, cone, b( k+1, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zlacgv( nrhs, b( k+1, 1_${ik}$ ), ldb ) end if ! interchange rows k and -ipiv(k). kp = -ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 2 + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 2_${ik}$ end if go to 40 50 continue @@ -37635,35 +37638,35 @@ module stdlib_linalg_lapack_z ! 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 = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(l**h(k)), where l(k) is the transformation ! stored in column k of a. if( k= 1 ) - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k-1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( kp==-ipiv( k-1 ) )call stdlib_zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb & + if( kp==-ipiv( k-1 ) )call stdlib${ii}$_zswap( 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_ztrsm('L','U','N','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib${ii}$_ztrsm('L','U','N','U',n,nrhs,cone,a,lda,b,ldb) ! compute d \ b -> b [ d \ (u \p**t * b) ] i=n do while ( i >= 1 ) - if( ipiv(i) > 0 ) then + if( ipiv(i) > 0_${ik}$ ) then s = real( cone,KIND=dp) / real( a( i, i ),KIND=dp) - call stdlib_zdscal( nrhs, s, b( i, 1 ), ldb ) - elseif ( i > 1) then + call stdlib${ii}$_zdscal( nrhs, s, 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 @@ -37813,59 +37816,59 @@ module stdlib_linalg_lapack_z 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**h \ b) -> b [ u**h \ (d \ (u \p**t * b) ) ] - call stdlib_ztrsm('L','U','C','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib${ii}$_ztrsm('L','U','C','U',n,nrhs,cone,a,lda,b,ldb) ! p * b [ p * (u**h \ (d \ (u \p**t * b) )) ] - k=1 + k=1_${ik}$ do while ( k <= n ) - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k+1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( k < n .and. kp==-ipiv( k+1 ) )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp,& - 1 ), ldb ) + if( k < n .and. kp==-ipiv( k+1 ) )call stdlib${ii}$_zswap( 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**h. ! p**t * b - k=1 + k=1_${ik}$ do while ( k <= n ) - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k+1 else ! 2 x 2 diagonal block ! interchange rows k and -ipiv(k+1). kp = -ipiv( k+1 ) - if( kp==-ipiv( k ) )call stdlib_zswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp==-ipiv( k ) )call stdlib${ii}$_zswap( 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_ztrsm('L','L','N','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib${ii}$_ztrsm('L','L','N','U',n,nrhs,cone,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 + if( ipiv(i) > 0_${ik}$ ) then s = real( cone,KIND=dp) / real( a( i, i ),KIND=dp) - call stdlib_zdscal( nrhs, s, b( i, 1 ), ldb ) + call stdlib${ii}$_zdscal( nrhs, s, b( i, 1_${ik}$ ), ldb ) else akm1k = work(i) akm1 = a( i, i ) / conjg( akm1k ) @@ -37877,38 +37880,38 @@ module stdlib_linalg_lapack_z 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**h \ b) -> b [ l**h \ (d \ (l \p**t * b) ) ] - call stdlib_ztrsm('L','L','C','U',n,nrhs,cone,a,lda,b,ldb) + call stdlib${ii}$_ztrsm('L','L','C','U',n,nrhs,cone,a,lda,b,ldb) ! p * b [ p * (l**h \ (d \ (l \p**t * b) )) ] k=n do while ( k >= 1 ) - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) k=k-1 else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( k>1 .and. kp==-ipiv( k-1 ) )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, & - 1 ), ldb ) + if( k>1_${ik}$ .and. kp==-ipiv( k-1 ) )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, & + 1_${ik}$ ), ldb ) k=k-2 endif end do end if ! revert a - call stdlib_zsyconv( uplo, 'R', n, a, lda, ipiv, work, iinfo ) + call stdlib${ii}$_zsyconv( uplo, 'R', n, a, lda, ipiv, work, iinfo ) return - end subroutine stdlib_zhetrs2 + end subroutine stdlib${ii}$_zhetrs2 - pure subroutine stdlib_zhetrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) + pure subroutine stdlib${ii}$_zhetrs_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb,work, lwork, info ) !! ZHETRS_AA solves a system of linear equations A*X = B with a complex !! hermitian matrix A using the factorization A = U**H*T*U or !! A = L*T*L**H computed by ZHETRF_AA. @@ -37918,42 +37921,42 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(in) :: a(lda,*) complex(dp), intent(inout) :: b(ldb,*) complex(dp), 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 + if( n>1_${ik}$ ) then ! pivot, p**t * b -> b do k = 1, n kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end do ! compute u**h \ b -> b [ (u**h \p**t * b) ] - call stdlib_ztrsm( 'L', 'U', 'C', 'U', n-1, nrhs, cone, a( 1, 2 ),lda, b( 2, 1 ),& + call stdlib${ii}$_ztrsm( 'L', 'U', 'C', 'U', n-1, nrhs, cone, a( 1_${ik}$, 2_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),& ldb ) end if ! 2) solve with triangular matrix t ! compute t \ b -> b [ t \ (u**h \p**t * b) ] - call stdlib_zlacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1 ) - if( n>1 ) then - call stdlib_zlacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 2*n ), 1) - call stdlib_zlacpy( 'F', 1, n-1, a( 1, 2 ), lda+1, work( 1 ), 1 ) - call stdlib_zlacgv( n-1, work( 1 ), 1 ) + call stdlib${ii}$_zlacpy( 'F', 1_${ik}$, n, a(1_${ik}$, 1_${ik}$), lda+1, work(n), 1_${ik}$ ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'F', 1_${ik}$, n-1, a( 1_${ik}$, 2_${ik}$ ), lda+1, work( 2_${ik}$*n ), 1_${ik}$) + call stdlib${ii}$_zlacpy( 'F', 1_${ik}$, n-1, a( 1_${ik}$, 2_${ik}$ ), lda+1, work( 1_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_zlacgv( n-1, work( 1_${ik}$ ), 1_${ik}$ ) end if - call stdlib_zgtsv( n, nrhs, work(1), work(n), work(2*n), b, ldb,info ) + call stdlib${ii}$_zgtsv( n, nrhs, work(1_${ik}$), work(n), work(2_${ik}$*n), b, ldb,info ) ! 3) backward substitution with u - if( n>1 ) then + if( n>1_${ik}$ ) then ! compute u \ b -> b [ u \ (t \ (u**h \p**t * b) ) ] - call stdlib_ztrsm( 'L', 'U', 'N', 'U', n-1, nrhs, cone, a( 1, 2 ),lda, b(2, 1), & + call stdlib${ii}$_ztrsm( 'L', 'U', 'N', 'U', n-1, nrhs, cone, a( 1_${ik}$, 2_${ik}$ ),lda, b(2_${ik}$, 1_${ik}$), & ldb) ! pivot, p * b [ p * (u**h \ (t \ (u \p**t * b) )) ] do k = n, 1, -1 kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end do end if else ! solve a*x = b, where a = l*t*l**h. ! 1) forward substitution with l - if( n>1 ) then + if( n>1_${ik}$ ) then ! pivot, p**t * b -> b do k = 1, n kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end do ! compute l \ b -> b [ (l \p**t * b) ] - call stdlib_ztrsm( 'L', 'L', 'N', 'U', n-1, nrhs, cone, a( 2, 1 ),lda, b(2, 1), & + call stdlib${ii}$_ztrsm( 'L', 'L', 'N', 'U', n-1, nrhs, cone, a( 2_${ik}$, 1_${ik}$ ),lda, b(2_${ik}$, 1_${ik}$), & ldb) end if ! 2) solve with triangular matrix t ! compute t \ b -> b [ t \ (l \p**t * b) ] - call stdlib_zlacpy( 'F', 1, n, a(1, 1), lda+1, work(n), 1) - if( n>1 ) then - call stdlib_zlacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 1 ), 1) - call stdlib_zlacpy( 'F', 1, n-1, a( 2, 1 ), lda+1, work( 2*n ), 1) - call stdlib_zlacgv( n-1, work( 2*n ), 1 ) + call stdlib${ii}$_zlacpy( 'F', 1_${ik}$, n, a(1_${ik}$, 1_${ik}$), lda+1, work(n), 1_${ik}$) + if( n>1_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'F', 1_${ik}$, n-1, a( 2_${ik}$, 1_${ik}$ ), lda+1, work( 1_${ik}$ ), 1_${ik}$) + call stdlib${ii}$_zlacpy( 'F', 1_${ik}$, n-1, a( 2_${ik}$, 1_${ik}$ ), lda+1, work( 2_${ik}$*n ), 1_${ik}$) + call stdlib${ii}$_zlacgv( n-1, work( 2_${ik}$*n ), 1_${ik}$ ) end if - call stdlib_zgtsv(n, nrhs, work(1), work(n), work(2*n), b, ldb,info) + call stdlib${ii}$_zgtsv(n, nrhs, work(1_${ik}$), work(n), work(2_${ik}$*n), b, ldb,info) ! 3) backward substitution with l**h - if( n>1 ) then + if( n>1_${ik}$ ) then ! compute l**h \ b -> b [ l**h \ (t \ (l \p**t * b) ) ] - call stdlib_ztrsm( 'L', 'L', 'C', 'U', n-1, nrhs, cone, a( 2, 1 ),lda, b( 2, 1 ),& + call stdlib${ii}$_ztrsm( 'L', 'L', 'C', 'U', n-1, nrhs, cone, a( 2_${ik}$, 1_${ik}$ ),lda, b( 2_${ik}$, 1_${ik}$ ),& ldb) ! pivot, p * b [ p * (l**h \ (t \ (l \p**t * b) )) ] do k = n, 1, -1 kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) end do end if end if return - end subroutine stdlib_zhetrs_aa + end subroutine stdlib${ii}$_zhetrs_aa - pure subroutine stdlib_zhetrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) + pure subroutine stdlib${ii}$_zhetrs_rook( uplo, n, nrhs, a, lda, ipiv, b, ldb,info ) !! ZHETRS_ROOK solves a system of linear equations A*X = B with a complex !! Hermitian matrix A using the factorization A = U*D*U**H or !! A = L*D*L**H computed by ZHETRF_ROOK. @@ -38038,37 +38041,37 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(in) :: a(lda,*) complex(dp), intent(inout) :: b(ldb,*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: j, k, kp + integer(${ik}$) :: j, k, kp real(dp) :: s complex(dp) :: ak, akm1, akm1k, bk, bkm1, denom ! Intrinsic Functions intrinsic :: conjg,max,real ! 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 + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_zgeru( k-1, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & + call stdlib${ii}$_zgeru( k-1, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb & ) ! multiply by the inverse of the diagonal block. s = real( cone,KIND=dp) / real( a( k, k ),KIND=dp) - call stdlib_zdscal( nrhs, s, b( k, 1 ), ldb ) - k = k - 1 + call stdlib${ii}$_zdscal( nrhs, s, b( k, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ else ! 2 x 2 diagonal block ! interchange rows k and -ipiv(k), then k-1 and -ipiv(k-1) kp = -ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) kp = -ipiv( k-1) - if( kp/=k-1 )call stdlib_zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib${ii}$_zswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - call stdlib_zgeru( k-2, nrhs, -cone, a( 1, k ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb & + call stdlib${ii}$_zgeru( k-2, nrhs, -cone, a( 1_${ik}$, k ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb & ) - call stdlib_zgeru( k-2, nrhs, -cone, a( 1, k-1 ), 1, b( k-1, 1 ),ldb, b( 1, 1 ), & + call stdlib${ii}$_zgeru( k-2, nrhs, -cone, a( 1_${ik}$, k-1 ), 1_${ik}$, b( k-1, 1_${ik}$ ),ldb, b( 1_${ik}$, 1_${ik}$ ), & ldb ) ! multiply by the inverse of the diagonal block. akm1k = a( k-1, k ) @@ -38119,51 +38122,51 @@ module stdlib_linalg_lapack_z 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**h *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 = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(u**h(k)), where u(k) is the transformation ! stored in column k of a. - if( k>1 ) then - call stdlib_zlacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_zgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), & - 1, cone, b( k, 1 ), ldb ) - call stdlib_zlacgv( nrhs, b( k, 1 ), ldb ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), & + 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb ) end if ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 1 + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 1_${ik}$ else ! 2 x 2 diagonal block ! multiply by inv(u**h(k+1)), where u(k+1) is the transformation ! stored in columns k and k+1 of a. - if( k>1 ) then - call stdlib_zlacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_zgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k ), & - 1, cone, b( k, 1 ), ldb ) - call stdlib_zlacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_zlacgv( nrhs, b( k+1, 1 ), ldb ) - call stdlib_zgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1, k+1 )& - , 1, cone, b( k+1, 1 ), ldb ) - call stdlib_zlacgv( nrhs, b( k+1, 1 ), ldb ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k ), & + 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zlacgv( nrhs, b( k+1, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, a( 1_${ik}$, k+1 )& + , 1_${ik}$, cone, b( k+1, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zlacgv( nrhs, 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_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) kp = -ipiv( k+1 ) - if( kp/=k+1 )call stdlib_zswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ), ldb ) - k = k + 2 + if( kp/=k+1 )call stdlib${ii}$_zswap( nrhs, b( k+1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + k = k + 2_${ik}$ end if go to 40 50 continue @@ -38172,37 +38175,37 @@ module stdlib_linalg_lapack_z ! 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 = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(l**h(k)), where l(k) is the transformation ! stored in column k of a. if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in column k of a. - call stdlib_zgeru( k-1, nrhs, -cone, ap( kc ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb ) + call stdlib${ii}$_zgeru( k-1, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb ) ! multiply by the inverse of the diagonal block. s = real( cone,KIND=dp) / real( ap( kc+k-1 ),KIND=dp) - call stdlib_zdscal( nrhs, s, b( k, 1 ), ldb ) - k = k - 1 + call stdlib${ii}$_zdscal( nrhs, s, b( k, 1_${ik}$ ), ldb ) + k = k - 1_${ik}$ else ! 2 x 2 diagonal block ! interchange rows k-1 and -ipiv(k). kp = -ipiv( k ) - if( kp/=k-1 )call stdlib_zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k-1 )call stdlib${ii}$_zswap( nrhs, b( k-1, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(u(k)), where u(k) is the transformation ! stored in columns k-1 and k of a. - call stdlib_zgeru( k-2, nrhs, -cone, ap( kc ), 1, b( k, 1 ), ldb,b( 1, 1 ), ldb ) + call stdlib${ii}$_zgeru( k-2, nrhs, -cone, ap( kc ), 1_${ik}$, b( k, 1_${ik}$ ), ldb,b( 1_${ik}$, 1_${ik}$ ), ldb ) - call stdlib_zgeru( k-2, nrhs, -cone, ap( kc-( k-1 ) ), 1,b( k-1, 1 ), ldb, b( 1, & - 1 ), ldb ) + call stdlib${ii}$_zgeru( k-2, nrhs, -cone, ap( kc-( k-1 ) ), 1_${ik}$,b( k-1, 1_${ik}$ ), ldb, b( 1_${ik}$, & + 1_${ik}$ ), ldb ) ! multiply by the inverse of the diagonal block. akm1k = ap( kc+k-2 ) akm1 = ap( kc-1 ) / akm1k @@ -38460,53 +38463,53 @@ module stdlib_linalg_lapack_z 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**h *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 = 1_${ik}$ + kc = 1_${ik}$ 40 continue ! if k > n, exit from loop. if( k>n )go to 50 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(u**h(k)), where u(k) is the transformation ! stored in column k of a. - if( k>1 ) then - call stdlib_zlacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_zgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc ), & - 1, cone, b( k, 1 ), ldb ) - call stdlib_zlacgv( nrhs, b( k, 1 ), ldb ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc ), & + 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb ) end if ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( 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 ! multiply by inv(u**h(k+1)), where u(k+1) is the transformation ! stored in columns k and k+1 of a. - if( k>1 ) then - call stdlib_zlacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_zgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc ), & - 1, cone, b( k, 1 ), ldb ) - call stdlib_zlacgv( nrhs, b( k, 1 ), ldb ) - call stdlib_zlacgv( nrhs, b( k+1, 1 ), ldb ) - call stdlib_zgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc+k ),& - 1, cone, b( k+1, 1 ), ldb ) - call stdlib_zlacgv( nrhs, b( k+1, 1 ), ldb ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc ), & + 1_${ik}$, cone, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zlacgv( nrhs, b( k, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zlacgv( nrhs, b( k+1, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', k-1, nrhs, -cone, b,ldb, ap( kc+k ),& + 1_${ik}$, cone, b( k+1, 1_${ik}$ ), ldb ) + call stdlib${ii}$_zlacgv( nrhs, b( k+1, 1_${ik}$ ), ldb ) end if ! interchange rows k and -ipiv(k). kp = -ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) - kc = kc + 2*k + 1 - k = k + 2 + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) + kc = kc + 2_${ik}$*k + 1_${ik}$ + k = k + 2_${ik}$ end if go to 40 50 continue @@ -38515,37 +38518,37 @@ module stdlib_linalg_lapack_z ! 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 = 1_${ik}$ + kc = 1_${ik}$ 60 continue ! if k > n, exit from loop. if( k>n )go to 80 - if( ipiv( k )>0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! interchange rows k and ipiv(k). kp = ipiv( k ) - if( kp/=k )call stdlib_zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) + if( kp/=k )call stdlib${ii}$_zswap( nrhs, b( k, 1_${ik}$ ), ldb, b( kp, 1_${ik}$ ), ldb ) ! multiply by inv(l(k)), where l(k) is the transformation ! stored in column k of a. - if( k0 ) then + if( ipiv( k )>0_${ik}$ ) then ! 1 x 1 diagonal block ! multiply by inv(l**h(k)), where l(k) is the transformation ! stored in column k of a. if( kn-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 ) - if ( ipiv( k )>0 ) then + if ( ipiv( k )>0_${ik}$ ) then ! 1x1 pivot kp = ipiv( k ) if ( kp /= k ) then @@ -39133,7 +39136,7 @@ module stdlib_linalg_lapack_z do i = 1, k work( k ) = max( cabs1( af( i, k ) ), work( k ) ) end do - k = k - 1 + k = k - 1_${ik}$ else ! 2x2 pivot kp = -ipiv( k ) @@ -39145,31 +39148,31 @@ module stdlib_linalg_lapack_z work( k-1 ) =max( cabs1( af( i, k-1 ) ), work( k-1 ) ) end do work( k ) = max( cabs1( 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 + if ( ipiv( k )>0_${ik}$ ) then ! 1x1 pivot kp = ipiv( k ) if ( kp /= k ) then @@ -39180,7 +39183,7 @@ module stdlib_linalg_lapack_z do i = k, n work( k ) = max( cabs1( af( i, k ) ), work( k ) ) end do - k = k + 1 + k = k + 1_${ik}$ else ! 2x2 pivot kp = -ipiv( k ) @@ -39192,25 +39195,25 @@ module stdlib_linalg_lapack_z work( k+1 ) =max( cabs1( af( i, k+1 ) ) , work( k+1 ) ) end do work(k) = max( cabs1( 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 @@ -39237,11 +39240,11 @@ module stdlib_linalg_lapack_z end if end do end if - stdlib_zla_herpvgrw = rpvgrw - end function stdlib_zla_herpvgrw + stdlib${ii}$_zla_herpvgrw = rpvgrw + end function stdlib${ii}$_zla_herpvgrw - real(dp) function stdlib_zla_porcond_c( uplo, n, a, lda, af,ldaf, c, capply, info,work, & + real(dp) function stdlib${ii}$_zla_porcond_c( uplo, n, a, lda, af,ldaf, c, capply, info,work, & !! ZLA_PORCOND_C Computes the infinity norm condition number of !! op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector rwork ) @@ -39251,8 +39254,8 @@ module stdlib_linalg_lapack_z ! Scalar Arguments character, intent(in) :: uplo logical(lk), intent(in) :: capply - integer(ilp), intent(in) :: n, lda, ldaf - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: n, lda, ldaf + integer(${ik}$), intent(out) :: info ! Array Arguments complex(dp), intent(in) :: a(lda,*), af(ldaf,*) complex(dp), intent(out) :: work(*) @@ -39260,13 +39263,13 @@ module stdlib_linalg_lapack_z real(dp), intent(out) :: rwork(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: kase + integer(${ik}$) :: kase real(dp) :: ainvnm, anorm, tmp - integer(ilp) :: i, j + integer(${ik}$) :: i, j logical(lk) :: up, upper complex(dp) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,max,real,aimag ! Statement Functions @@ -39274,20 +39277,20 @@ module stdlib_linalg_lapack_z ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) ) ! Executable Statements - stdlib_zla_porcond_c = zero - info = 0 + stdlib${ii}$_zla_porcond_c = zero + 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 ) - if ( ipiv( k )>0 ) then + if ( ipiv( k )>0_${ik}$ ) then ! 1x1 pivot kp = ipiv( k ) if ( kp /= k ) then @@ -39623,7 +39626,7 @@ module stdlib_linalg_lapack_z do i = 1, k work( k ) = max( cabs1( af( i, k ) ), work( k ) ) end do - k = k - 1 + k = k - 1_${ik}$ else ! 2x2 pivot kp = -ipiv( k ) @@ -39635,31 +39638,31 @@ module stdlib_linalg_lapack_z work( k-1 ) =max( cabs1( af( i, k-1 ) ), work( k-1 ) ) end do work( k ) = max( cabs1( 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 + if ( ipiv( k )>0_${ik}$ ) then ! 1x1 pivot kp = ipiv( k ) if ( kp /= k ) then @@ -39670,7 +39673,7 @@ module stdlib_linalg_lapack_z do i = k, n work( k ) = max( cabs1( af( i, k ) ), work( k ) ) end do - k = k + 1 + k = k + 1_${ik}$ else ! 2x2 pivot kp = -ipiv( k ) @@ -39682,25 +39685,25 @@ module stdlib_linalg_lapack_z work( k+1 ) =max( cabs1( af( i, k+1 ) ), work( k+1 ) ) end do work( k ) = max( cabs1( 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 @@ -39727,11 +39730,11 @@ module stdlib_linalg_lapack_z end if end do end if - stdlib_zla_syrpvgrw = rpvgrw - end function stdlib_zla_syrpvgrw + stdlib${ii}$_zla_syrpvgrw = rpvgrw + end function stdlib${ii}$_zla_syrpvgrw - pure subroutine stdlib_zlabrd( m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y,ldy ) + pure subroutine stdlib${ii}$_zlabrd( m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y,ldy ) !! ZLABRD reduces the first NB rows and columns of a complex general !! m by n matrix A to upper or lower real bidiagonal form by a unitary !! transformation Q**H * A * P, and returns the matrices X and Y which @@ -39743,7 +39746,7 @@ module stdlib_linalg_lapack_z ! -- 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, ldx, ldy, m, n, nb + integer(${ik}$), intent(in) :: lda, ldx, ldy, m, n, nb ! Array Arguments real(dp), intent(out) :: d(*), e(*) complex(dp), intent(inout) :: a(lda,*) @@ -39751,7 +39754,7 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i complex(dp) :: alpha ! Intrinsic Functions intrinsic :: min @@ -39762,126 +39765,126 @@ module stdlib_linalg_lapack_z ! reduce to upper bidiagonal form loop_10: do i = 1, nb ! update a(i:m,i) - call stdlib_zlacgv( i-1, y( i, 1 ), ldy ) - call stdlib_zgemv( 'NO TRANSPOSE', m-i+1, i-1, -cone, a( i, 1 ),lda, y( i, 1 ), & - ldy, cone, a( i, i ), 1 ) - call stdlib_zlacgv( i-1, y( i, 1 ), ldy ) - call stdlib_zgemv( 'NO TRANSPOSE', m-i+1, i-1, -cone, x( i, 1 ),ldx, a( 1, i ), & - 1, cone, a( i, i ), 1 ) + call stdlib${ii}$_zlacgv( i-1, y( i, 1_${ik}$ ), ldy ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', m-i+1, i-1, -cone, a( i, 1_${ik}$ ),lda, y( i, 1_${ik}$ ), & + ldy, cone, a( i, i ), 1_${ik}$ ) + call stdlib${ii}$_zlacgv( i-1, y( i, 1_${ik}$ ), ldy ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', m-i+1, i-1, -cone, x( i, 1_${ik}$ ),ldx, a( 1_${ik}$, i ), & + 1_${ik}$, cone, a( i, i ), 1_${ik}$ ) ! generate reflection q(i) to annihilate a(i+1:m,i) alpha = a( i, i ) - call stdlib_zlarfg( m-i+1, alpha, a( min( i+1, m ), i ), 1,tauq( i ) ) + call stdlib${ii}$_zlarfg( m-i+1, alpha, a( min( i+1, m ), i ), 1_${ik}$,tauq( i ) ) d( i ) = real( alpha,KIND=dp) if( i1 ) then ! info = -1 ! else if( n<0 ) then - if( n<0 ) then - info = -1 - else if( min( 1, n )>cutpnt .or. ncutpnt .or. n=growto*scale )go to 120 ! choose new orthogonal starting vector and try again. rtemp = eps3 / ( rootn+one ) - v( 1 ) = eps3 + v( 1_${ik}$ ) = eps3 do i = 2, n v( i ) = rtemp end do v( n-its+1 ) = v( n-its+1 ) - eps3*rootn end do ! failure to find eigenvector in n iterations. - info = 1 + info = 1_${ik}$ 120 continue ! normalize eigenvector. - i = stdlib_izamax( n, v, 1 ) - call stdlib_zdscal( n, one / cabs1( v( i ) ), v, 1 ) + i = stdlib${ii}$_izamax( n, v, 1_${ik}$ ) + call stdlib${ii}$_zdscal( n, one / cabs1( v( i ) ), v, 1_${ik}$ ) return - end subroutine stdlib_zlaein + end subroutine stdlib${ii}$_zlaein - pure subroutine stdlib_zlags2( upper, a1, a2, a3, b1, b2, b3, csu, snu, csv,snv, csq, snq ) + pure subroutine stdlib${ii}$_zlags2( upper, a1, a2, a3, b1, b2, b3, csu, snu, csv,snv, csq, snq ) !! ZLAGS2 computes 2-by-2 unitary matrices U, V and Q, such !! that if ( UPPER ) then !! U**H *A*Q = U**H *( A1 A2 )*Q = ( x 0 ) @@ -40215,7 +40218,7 @@ module stdlib_linalg_lapack_z ! 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_dlasv2( a, fb, d, s1, s2, snr, csr, snl, csl ) + call stdlib${ii}$_dlasv2( a, fb, d, s1, s2, snr, csr, snl, csl ) if( abs( csl )>=abs( snl ) .or. abs( csr )>=abs( snr ) )then ! compute the (1,1) and (1,2) elements of u**h *a and v**h *b, ! and (1,2) element of |u|**h *|a| and |v|**h *|b|. @@ -40227,17 +40230,17 @@ module stdlib_linalg_lapack_z avb12 = abs( csr )*abs1( b2 ) + abs( snr )*abs( b3 ) ! zero (1,2) elements of u**h *a and v**h *b if( ( abs( ua11r )+abs1( ua12 ) )==zero ) then - call stdlib_zlartg( -cmplx( vb11r,KIND=dp), conjg( vb12 ), csq, snq,r ) + call stdlib${ii}$_zlartg( -cmplx( vb11r,KIND=dp), conjg( vb12 ), csq, snq,r ) else if( ( abs( vb11r )+abs1( vb12 ) )==zero ) then - call stdlib_zlartg( -cmplx( ua11r,KIND=dp), conjg( ua12 ), csq, snq,r ) + call stdlib${ii}$_zlartg( -cmplx( ua11r,KIND=dp), conjg( ua12 ), csq, snq,r ) else if( aua12 / ( abs( ua11r )+abs1( ua12 ) )<=avb12 /( abs( vb11r )+abs1( vb12 & ) ) ) then - call stdlib_zlartg( -cmplx( ua11r,KIND=dp), conjg( ua12 ), csq, snq,r ) + call stdlib${ii}$_zlartg( -cmplx( ua11r,KIND=dp), conjg( ua12 ), csq, snq,r ) else - call stdlib_zlartg( -cmplx( vb11r,KIND=dp), conjg( vb12 ), csq, snq,r ) + call stdlib${ii}$_zlartg( -cmplx( vb11r,KIND=dp), conjg( vb12 ), csq, snq,r ) end if csu = csl @@ -40255,14 +40258,14 @@ module stdlib_linalg_lapack_z avb22 = abs( snr )*abs1( b2 ) + abs( csr )*abs( b3 ) ! zero (2,2) elements of u**h *a and v**h *b, and then swap. if( ( abs1( ua21 )+abs1( ua22 ) )==zero ) then - call stdlib_zlartg( -conjg( vb21 ), conjg( vb22 ), csq, snq,r ) + call stdlib${ii}$_zlartg( -conjg( vb21 ), conjg( vb22 ), csq, snq,r ) else if( ( abs1( vb21 )+abs( vb22 ) )==zero ) then - call stdlib_zlartg( -conjg( ua21 ), conjg( ua22 ), csq, snq,r ) + call stdlib${ii}$_zlartg( -conjg( ua21 ), conjg( ua22 ), csq, snq,r ) else if( aua22 / ( abs1( ua21 )+abs1( ua22 ) )<=avb22 /( abs1( vb21 )+abs1( vb22 & ) ) ) then - call stdlib_zlartg( -conjg( ua21 ), conjg( ua22 ), csq, snq,r ) + call stdlib${ii}$_zlartg( -conjg( ua21 ), conjg( ua22 ), csq, snq,r ) else - call stdlib_zlartg( -conjg( vb21 ), conjg( vb22 ), csq, snq,r ) + call stdlib${ii}$_zlartg( -conjg( vb21 ), conjg( vb22 ), csq, snq,r ) end if csu = snl snu = d1*csl @@ -40284,7 +40287,7 @@ module stdlib_linalg_lapack_z ! 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_dlasv2( a, fc, d, s1, s2, snr, csr, snl, csl ) + call stdlib${ii}$_dlasv2( a, fc, d, s1, s2, snr, csr, snl, csl ) if( abs( csr )>=abs( snr ) .or. abs( csl )>=abs( snl ) )then ! compute the (2,1) and (2,2) elements of u**h *a and v**h *b, ! and (2,1) element of |u|**h *|a| and |v|**h *|b|. @@ -40296,14 +40299,14 @@ module stdlib_linalg_lapack_z avb21 = abs( snl )*abs( b1 ) + abs( csl )*abs1( b2 ) ! zero (2,1) elements of u**h *a and v**h *b. if( ( abs1( ua21 )+abs( ua22r ) )==zero ) then - call stdlib_zlartg( cmplx( vb22r,KIND=dp), vb21, csq, snq, r ) + call stdlib${ii}$_zlartg( cmplx( vb22r,KIND=dp), vb21, csq, snq, r ) else if( ( abs1( vb21 )+abs( vb22r ) )==zero ) then - call stdlib_zlartg( cmplx( ua22r,KIND=dp), ua21, csq, snq, r ) + call stdlib${ii}$_zlartg( cmplx( ua22r,KIND=dp), ua21, csq, snq, r ) else if( aua21 / ( abs1( ua21 )+abs( ua22r ) )<=avb21 /( abs1( vb21 )+abs( vb22r & ) ) ) then - call stdlib_zlartg( cmplx( ua22r,KIND=dp), ua21, csq, snq, r ) + call stdlib${ii}$_zlartg( cmplx( ua22r,KIND=dp), ua21, csq, snq, r ) else - call stdlib_zlartg( cmplx( vb22r,KIND=dp), vb21, csq, snq, r ) + call stdlib${ii}$_zlartg( cmplx( vb22r,KIND=dp), vb21, csq, snq, r ) end if csu = csr snu = -conjg( d1 )*snr @@ -40320,14 +40323,14 @@ module stdlib_linalg_lapack_z avb11 = abs( csl )*abs( b1 ) + abs( snl )*abs1( b2 ) ! zero (1,1) elements of u**h *a and v**h *b, and then swap. if( ( abs1( ua11 )+abs1( ua12 ) )==zero ) then - call stdlib_zlartg( vb12, vb11, csq, snq, r ) + call stdlib${ii}$_zlartg( vb12, vb11, csq, snq, r ) else if( ( abs1( vb11 )+abs1( vb12 ) )==zero ) then - call stdlib_zlartg( ua12, ua11, csq, snq, r ) + call stdlib${ii}$_zlartg( ua12, ua11, csq, snq, r ) else if( aua11 / ( abs1( ua11 )+abs1( ua12 ) )<=avb11 /( abs1( vb11 )+abs1( vb12 & ) ) ) then - call stdlib_zlartg( ua12, ua11, csq, snq, r ) + call stdlib${ii}$_zlartg( ua12, ua11, csq, snq, r ) else - call stdlib_zlartg( vb12, vb11, csq, snq, r ) + call stdlib${ii}$_zlartg( vb12, vb11, csq, snq, r ) end if csu = snr snu = conjg( d1 )*csr @@ -40336,10 +40339,10 @@ module stdlib_linalg_lapack_z end if end if return - end subroutine stdlib_zlags2 + end subroutine stdlib${ii}$_zlags2 - pure subroutine stdlib_zlahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, info & + pure subroutine stdlib${ii}$_zlahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, info & !! ZLAHQR is an auxiliary routine called by CHSEQR to update the !! eigenvalues and Schur decomposition already computed by CHSEQR, by !! dealing with the Hessenberg submatrix in rows and columns ILO to @@ -40349,8 +40352,8 @@ module stdlib_linalg_lapack_z ! -- 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, ihiz, ilo, iloz, ldh, ldz, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ihiz, ilo, iloz, ldh, ldz, n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt, wantz ! Array Arguments complex(dp), intent(inout) :: h(ldh,*), z(ldz,*) @@ -40360,7 +40363,7 @@ module stdlib_linalg_lapack_z real(dp), parameter :: rzero = 0.0_dp real(dp), parameter :: rone = 1.0_dp real(dp), parameter :: dat1 = 3.0_dp/4.0_dp - integer(ilp), parameter :: kexsh = 10 + integer(${ik}$), parameter :: kexsh = 10_${ik}$ @@ -40369,9 +40372,9 @@ module stdlib_linalg_lapack_z complex(dp) :: cdum, h11, h11s, h22, sc, sum, t, t1, temp, u, v2, x, y real(dp) :: aa, ab, ba, bb, h10, h21, rtemp, s, safmax, safmin, smlnum, sx, t2, tst, & ulp - integer(ilp) :: i, i1, i2, its, itmax, j, jhi, jlo, k, l, m, nh, nz, kdefl + integer(${ik}$) :: i, i1, i2, its, itmax, j, jhi, jlo, k, l, m, nh, nz, kdefl ! Local Arrays - complex(dp) :: v(2) + complex(dp) :: v(2_${ik}$) ! Statement Functions real(dp) :: cabs1 ! Intrinsic Functions @@ -40379,7 +40382,7 @@ module stdlib_linalg_lapack_z ! Statement Function Definitions cabs1( cdum ) = abs( real( cdum,KIND=dp) ) + abs( aimag( cdum ) ) ! Executable Statements - info = 0 + info = 0_${ik}$ ! quick return if possible if( n==0 )return if( ilo==ihi ) then @@ -40394,7 +40397,7 @@ module stdlib_linalg_lapack_z if( ilo<=ihi-2 )h( ihi, ihi-2 ) = czero ! ==== ensure that subdiagonal entries are real ==== if( wantt ) then - jlo = 1 + jlo = 1_${ik}$ jhi = n else jlo = ilo @@ -40408,30 +40411,30 @@ module stdlib_linalg_lapack_z sc = h( i, i-1 ) / cabs1( h( i, i-1 ) ) sc = conjg( sc ) / abs( sc ) h( i, i-1 ) = abs( h( i, i-1 ) ) - call stdlib_zscal( jhi-i+1, sc, h( i, i ), ldh ) - call stdlib_zscal( min( jhi, i+1 )-jlo+1, conjg( sc ),h( jlo, i ), 1 ) - if( wantz )call stdlib_zscal( ihiz-iloz+1, conjg( sc ), z( iloz, i ), 1 ) + call stdlib${ii}$_zscal( jhi-i+1, sc, h( i, i ), ldh ) + call stdlib${ii}$_zscal( min( jhi, i+1 )-jlo+1, conjg( sc ),h( jlo, i ), 1_${ik}$ ) + if( wantz )call stdlib${ii}$_zscal( ihiz-iloz+1, conjg( sc ), z( iloz, i ), 1_${ik}$ ) end if end do - nh = ihi - ilo + 1 - nz = ihiz - iloz + 1 + nh = ihi - ilo + 1_${ik}$ + nz = ihiz - iloz + 1_${ik}$ ! set machine-dependent constants for the stopping criterion. - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) safmax = rone / safmin - call stdlib_dlabad( safmin, safmax ) - ulp = stdlib_dlamch( 'PRECISION' ) + call stdlib${ii}$_dlabad( safmin, safmax ) + ulp = stdlib${ii}$_dlamch( 'PRECISION' ) smlnum = safmin*( real( nh,KIND=dp) / ulp ) ! i1 and i2 are the indices of the first row and last column of h ! to which transformations must be applied. if eigenvalues only are ! being computed, i1 and i2 are set inside the main loop. if( wantt ) then - i1 = 1 + i1 = 1_${ik}$ i2 = n end if ! itmax is the total number of qr iterations allowed. - itmax = 30 * max( 10, nh ) + itmax = 30_${ik}$ * max( 10_${ik}$, nh ) ! kdefl counts the number of iterations since a deflation - kdefl = 0 + kdefl = 0_${ik}$ ! the main loop begins here. i is the loop index and decreases from ! ihi to ilo in steps of 1. each iteration of the loop works ! with the active submatrix in rows and columns l to i. @@ -40474,7 +40477,7 @@ module stdlib_linalg_lapack_z end if ! exit from loop if a submatrix of order 1 has split off. if( l>=i )go to 140 - kdefl = kdefl + 1 + kdefl = kdefl + 1_${ik}$ ! now the active submatrix is in rows and columns l to i. if ! eigenvalues only are being computed, only the active submatrix ! need be transformed. @@ -40482,11 +40485,11 @@ module stdlib_linalg_lapack_z i1 = l i2 = i end if - if( mod(kdefl,2*kexsh)==0 ) then + if( mod(kdefl,2_${ik}$*kexsh)==0_${ik}$ ) then ! exceptional shift. s = dat1*abs( real( h( i, i-1 ),KIND=dp) ) t = s + h( i, i ) - else if( mod(kdefl,kexsh)==0 ) then + else if( mod(kdefl,kexsh)==0_${ik}$ ) then ! exceptional shift. s = dat1*abs( real( h( l+1, l ),KIND=dp) ) t = s + h( l, l ) @@ -40499,12 +40502,12 @@ module stdlib_linalg_lapack_z x = half*( h( i-1, i-1 )-t ) sx = cabs1( x ) s = max( s, cabs1( x ) ) - y = s*sqrt( ( x / s )**2+( u / s )**2 ) + y = s*sqrt( ( x / s )**2_${ik}$+( u / s )**2_${ik}$ ) if( sx>rzero ) then if( real( x / sx,KIND=dp)*real( y,KIND=dp)+aimag( x / sx )*aimag( y )& m )call stdlib_zcopy( 2, h( k, k-1 ), 1, v, 1 ) - call stdlib_zlarfg( 2, v( 1 ), v( 2 ), 1, t1 ) + if( k>m )call stdlib${ii}$_zcopy( 2_${ik}$, h( k, k-1 ), 1_${ik}$, v, 1_${ik}$ ) + call stdlib${ii}$_zlarfg( 2_${ik}$, v( 1_${ik}$ ), v( 2_${ik}$ ), 1_${ik}$, t1 ) if( k>m ) then - h( k, k-1 ) = v( 1 ) + h( k, k-1 ) = v( 1_${ik}$ ) h( k+1, k-1 ) = czero end if - v2 = v( 2 ) + v2 = v( 2_${ik}$ ) t2 = real( t1*v2,KIND=dp) ! apply g from the left to transform the rows of the matrix ! in columns k to i2. @@ -40587,10 +40590,10 @@ module stdlib_linalg_lapack_z if( m+2<=i )h( m+2, m+1 ) = h( m+2, m+1 )*temp do j = m, i if( j/=m+1 ) then - if( i2>j )call stdlib_zscal( i2-j, temp, h( j, j+1 ), ldh ) - call stdlib_zscal( j-i1, conjg( temp ), h( i1, j ), 1 ) + if( i2>j )call stdlib${ii}$_zscal( i2-j, temp, h( j, j+1 ), ldh ) + call stdlib${ii}$_zscal( j-i1, conjg( temp ), h( i1, j ), 1_${ik}$ ) if( wantz ) then - call stdlib_zscal( nz, conjg( temp ), z( iloz, j ),1 ) + call stdlib${ii}$_zscal( nz, conjg( temp ), z( iloz, j ),1_${ik}$ ) end if end if end do @@ -40602,10 +40605,10 @@ module stdlib_linalg_lapack_z rtemp = abs( temp ) h( i, i-1 ) = rtemp temp = temp / rtemp - if( i2>i )call stdlib_zscal( i2-i, conjg( temp ), h( i, i+1 ), ldh ) - call stdlib_zscal( i-i1, temp, h( i1, i ), 1 ) + if( i2>i )call stdlib${ii}$_zscal( i2-i, conjg( temp ), h( i, i+1 ), ldh ) + call stdlib${ii}$_zscal( i-i1, temp, h( i1, i ), 1_${ik}$ ) if( wantz ) then - call stdlib_zscal( nz, temp, z( iloz, i ), 1 ) + call stdlib${ii}$_zscal( nz, temp, z( iloz, i ), 1_${ik}$ ) end if end if end do loop_130 @@ -40616,16 +40619,16 @@ module stdlib_linalg_lapack_z ! h(i,i-1) is negligible: cone eigenvalue has converged. w( i ) = h( i, i ) ! reset deflation counter - kdefl = 0 + kdefl = 0_${ik}$ ! return to start of the main loop with new value of i. - i = l - 1 + i = l - 1_${ik}$ go to 30 150 continue return - end subroutine stdlib_zlahqr + end subroutine stdlib${ii}$_zlahqr - pure subroutine stdlib_zlahr2( n, k, nb, a, lda, tau, t, ldt, y, ldy ) + pure subroutine stdlib${ii}$_zlahr2( n, k, nb, a, lda, tau, t, ldt, y, ldy ) !! ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1) !! matrix A so that elements below the k-th subdiagonal are zero. The !! reduction is performed by an unitary similarity transformation @@ -40636,14 +40639,14 @@ module stdlib_linalg_lapack_z ! -- 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) :: k, lda, ldt, ldy, n, nb + integer(${ik}$), intent(in) :: k, lda, ldt, ldy, n, nb ! Array Arguments complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: t(ldt,nb), tau(nb), y(ldy,nb) ! ===================================================================== ! Local Scalars - integer(ilp) :: i + integer(${ik}$) :: i complex(dp) :: ei ! Intrinsic Functions intrinsic :: min @@ -40651,71 +40654,71 @@ module stdlib_linalg_lapack_z ! quick return if possible if( n<=1 )return loop_10: do i = 1, nb - if( i>1 ) then + if( i>1_${ik}$ ) then ! update a(k+1:n,i) ! update i-th column of a - y * v**h - call stdlib_zlacgv( i-1, a( k+i-1, 1 ), lda ) - call stdlib_zgemv( 'NO TRANSPOSE', n-k, i-1, -cone, y(k+1,1), ldy,a( k+i-1, 1 ), & - lda, cone, a( k+1, i ), 1 ) - call stdlib_zlacgv( i-1, a( k+i-1, 1 ), lda ) + call stdlib${ii}$_zlacgv( i-1, a( k+i-1, 1_${ik}$ ), lda ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-k, i-1, -cone, y(k+1,1_${ik}$), ldy,a( k+i-1, 1_${ik}$ ), & + lda, cone, a( k+1, i ), 1_${ik}$ ) + call stdlib${ii}$_zlacgv( i-1, a( k+i-1, 1_${ik}$ ), lda ) ! apply i - v * t**h * v**h to this column (call it b) from the ! left, using the last column of t as workspace ! let v = ( v1 ) and b = ( b1 ) (first i-1 rows) ! ( v2 ) ( b2 ) ! where v1 is unit lower triangular ! w := v1**h * b1 - call stdlib_zcopy( i-1, a( k+1, i ), 1, t( 1, nb ), 1 ) - call stdlib_ztrmv( 'LOWER', 'CONJUGATE TRANSPOSE', 'UNIT',i-1, a( k+1, 1 ),lda, & - t( 1, nb ), 1 ) + call stdlib${ii}$_zcopy( i-1, a( k+1, i ), 1_${ik}$, t( 1_${ik}$, nb ), 1_${ik}$ ) + call stdlib${ii}$_ztrmv( 'LOWER', 'CONJUGATE TRANSPOSE', 'UNIT',i-1, a( k+1, 1_${ik}$ ),lda, & + t( 1_${ik}$, nb ), 1_${ik}$ ) ! w := w + v2**h * b2 - call stdlib_zgemv( 'CONJUGATE TRANSPOSE', n-k-i+1, i-1,cone, a( k+i, 1 ),lda, a( & - k+i, i ), 1, cone, t( 1, nb ), 1 ) + call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', n-k-i+1, i-1,cone, a( k+i, 1_${ik}$ ),lda, a( & + k+i, i ), 1_${ik}$, cone, t( 1_${ik}$, nb ), 1_${ik}$ ) ! w := t**h * w - call stdlib_ztrmv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1, & - nb ), 1 ) + call stdlib${ii}$_ztrmv( 'UPPER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1_${ik}$, & + nb ), 1_${ik}$ ) ! b2 := b2 - v2*w - call stdlib_zgemv( 'NO TRANSPOSE', n-k-i+1, i-1, -cone,a( k+i, 1 ),lda, t( 1, nb & - ), 1, cone, a( k+i, i ), 1 ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-k-i+1, i-1, -cone,a( k+i, 1_${ik}$ ),lda, t( 1_${ik}$, nb & + ), 1_${ik}$, cone, a( k+i, i ), 1_${ik}$ ) ! b1 := b1 - v1*w - call stdlib_ztrmv( 'LOWER', 'NO TRANSPOSE','UNIT', i-1,a( k+1, 1 ), lda, t( 1, & - nb ), 1 ) - call stdlib_zaxpy( i-1, -cone, t( 1, nb ), 1, a( k+1, i ), 1 ) + call stdlib${ii}$_ztrmv( 'LOWER', 'NO TRANSPOSE','UNIT', i-1,a( k+1, 1_${ik}$ ), lda, t( 1_${ik}$, & + nb ), 1_${ik}$ ) + call stdlib${ii}$_zaxpy( i-1, -cone, t( 1_${ik}$, nb ), 1_${ik}$, a( k+1, i ), 1_${ik}$ ) a( k+i-1, i-1 ) = ei end if ! generate the elementary reflector h(i) to annihilate ! a(k+i+1:n,i) - call stdlib_zlarfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1,tau( i ) ) + call stdlib${ii}$_zlarfg( n-k-i+1, a( k+i, i ), a( min( k+i+1, n ), i ), 1_${ik}$,tau( i ) ) ei = a( k+i, i ) a( k+i, i ) = cone ! compute y(k+1:n,i) - call stdlib_zgemv( 'NO TRANSPOSE', n-k, n-k-i+1,cone, a( k+1, i+1 ),lda, a( k+i, i )& - , 1, czero, y( k+1, i ), 1 ) - call stdlib_zgemv( 'CONJUGATE TRANSPOSE', n-k-i+1, i-1,cone, a( k+i, 1 ), lda,a( k+& - i, i ), 1, czero, t( 1, i ), 1 ) - call stdlib_zgemv( 'NO TRANSPOSE', n-k, i-1, -cone,y( k+1, 1 ), ldy,t( 1, i ), 1, & - cone, y( k+1, i ), 1 ) - call stdlib_zscal( n-k, tau( i ), y( k+1, i ), 1 ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-k, n-k-i+1,cone, a( k+1, i+1 ),lda, a( k+i, i )& + , 1_${ik}$, czero, y( k+1, i ), 1_${ik}$ ) + call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', n-k-i+1, i-1,cone, a( k+i, 1_${ik}$ ), lda,a( k+& + i, i ), 1_${ik}$, czero, t( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-k, i-1, -cone,y( k+1, 1_${ik}$ ), ldy,t( 1_${ik}$, i ), 1_${ik}$, & + cone, y( k+1, i ), 1_${ik}$ ) + call stdlib${ii}$_zscal( n-k, tau( i ), y( k+1, i ), 1_${ik}$ ) ! compute t(1:i,i) - call stdlib_zscal( i-1, -tau( i ), t( 1, i ), 1 ) - call stdlib_ztrmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1, i ), 1 ) + call stdlib${ii}$_zscal( i-1, -tau( i ), t( 1_${ik}$, i ), 1_${ik}$ ) + call stdlib${ii}$_ztrmv( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT',i-1, t, ldt,t( 1_${ik}$, i ), 1_${ik}$ ) t( i, i ) = tau( i ) end do loop_10 a( k+nb, nb ) = ei ! compute y(1:k,1:nb) - call stdlib_zlacpy( 'ALL', k, nb, a( 1, 2 ), lda, y, ldy ) - call stdlib_ztrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE','UNIT', k, nb,cone, a( k+1, 1 ), & + call stdlib${ii}$_zlacpy( 'ALL', k, nb, a( 1_${ik}$, 2_${ik}$ ), lda, y, ldy ) + call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', 'NO TRANSPOSE','UNIT', k, nb,cone, a( k+1, 1_${ik}$ ), & lda, y, ldy ) - if( n>k+nb )call stdlib_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,nb, n-k-nb, cone,a( 1,& - 2+nb ), lda, a( k+1+nb, 1 ), lda, cone, y,ldy ) - call stdlib_ztrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE','NON-UNIT', k, nb,cone, t, ldt, y, & + if( n>k+nb )call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', k,nb, n-k-nb, cone,a( 1_${ik}$,& + 2_${ik}$+nb ), lda, a( k+1+nb, 1_${ik}$ ), lda, cone, y,ldy ) + call stdlib${ii}$_ztrmm( 'RIGHT', 'UPPER', 'NO TRANSPOSE','NON-UNIT', k, nb,cone, t, ldt, y, & ldy ) return - end subroutine stdlib_zlahr2 + end subroutine stdlib${ii}$_zlahr2 - pure subroutine stdlib_zlals0( icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx,perm, givptr, & + pure subroutine stdlib${ii}$_zlals0( icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx,perm, givptr, & !! ZLALS0 applies back the multiplying factors of either the left or the !! right singular vector matrix of a diagonal matrix appended by a row !! to the right hand side matrix B in solving the least squares problem @@ -40741,12 +40744,12 @@ module stdlib_linalg_lapack_z ! -- 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) :: givptr, icompq, k, ldb, ldbx, ldgcol, ldgnum, nl, nr, nrhs,& + integer(${ik}$), intent(in) :: givptr, icompq, k, ldb, ldbx, ldgcol, ldgnum, nl, nr, nrhs,& sqre - integer(ilp), intent(out) :: info + integer(${ik}$), intent(out) :: info real(dp), intent(in) :: c, s ! Array Arguments - integer(ilp), intent(in) :: givcol(ldgcol,*), perm(*) + integer(${ik}$), intent(in) :: givcol(ldgcol,*), perm(*) real(dp), intent(in) :: difl(*), difr(ldgnum,*), givnum(ldgnum,*), poles(ldgnum,*), z(& *) real(dp), intent(out) :: rwork(*) @@ -40755,179 +40758,179 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, jcol, jrow, m, n, nlp1 + integer(${ik}$) :: i, j, jcol, jrow, m, n, nlp1 real(dp) :: diflj, difrj, dj, dsigj, dsigjp, temp ! Intrinsic Functions intrinsic :: real,cmplx,aimag,max ! Executable Statements ! test the input parameters. - info = 0 - n = nl + nr + 1 - 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 - else if( nrhs<1 ) then - info = -5 + info = 0_${ik}$ + n = nl + nr + 1_${ik}$ + 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( nrhs<1_${ik}$ ) then + info = -5_${ik}$ else if( ldb1 ) ) then - info = -1 - else if( smlsiz<3 ) then - info = -2 + info = 0_${ik}$ + if( ( icompq<0_${ik}$ ) .or. ( icompq>1_${ik}$ ) ) then + info = -1_${ik}$ + else if( smlsiz<3_${ik}$ ) then + info = -2_${ik}$ else if( n=one ) ) then rcnd = eps else rcnd = rcond end if - rank = 0 + rank = 0_${ik}$ ! quick return if possible. - if( n==0 ) then + if( n==0_${ik}$ ) then return - else if( n==1 ) then - if( d( 1 )==zero ) then - call stdlib_zlaset( 'A', 1, nrhs, czero, czero, b, ldb ) + else if( n==1_${ik}$ ) then + if( d( 1_${ik}$ )==zero ) then + call stdlib${ii}$_zlaset( 'A', 1_${ik}$, nrhs, czero, czero, b, ldb ) else - rank = 1 - call stdlib_zlascl( 'G', 0, 0, d( 1 ), one, 1, nrhs, b, ldb, info ) - d( 1 ) = abs( d( 1 ) ) + rank = 1_${ik}$ + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, d( 1_${ik}$ ), one, 1_${ik}$, nrhs, b, ldb, info ) + d( 1_${ik}$ ) = abs( d( 1_${ik}$ ) ) end if return end if ! rotate the matrix if it is lower bidiagonal. if( uplo=='L' ) then do i = 1, n - 1 - call stdlib_dlartg( d( i ), e( i ), cs, sn, r ) + call stdlib${ii}$_dlartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) - if( nrhs==1 ) then - call stdlib_zdrot( 1, b( i, 1 ), 1, b( i+1, 1 ), 1, cs, sn ) + if( nrhs==1_${ik}$ ) then + call stdlib${ii}$_zdrot( 1_${ik}$, b( i, 1_${ik}$ ), 1_${ik}$, b( i+1, 1_${ik}$ ), 1_${ik}$, cs, sn ) else - rwork( i*2-1 ) = cs - rwork( i*2 ) = sn + rwork( i*2_${ik}$-1 ) = cs + rwork( i*2_${ik}$ ) = sn end if end do - if( nrhs>1 ) then + if( nrhs>1_${ik}$ ) then do i = 1, nrhs do j = 1, n - 1 - cs = rwork( j*2-1 ) - sn = rwork( j*2 ) - call stdlib_zdrot( 1, b( j, i ), 1, b( j+1, i ), 1, cs, sn ) + cs = rwork( j*2_${ik}$-1 ) + sn = rwork( j*2_${ik}$ ) + call stdlib${ii}$_zdrot( 1_${ik}$, b( j, i ), 1_${ik}$, b( j+1, i ), 1_${ik}$, cs, sn ) end do end do end if end if ! scale. - nm1 = n - 1 - orgnrm = stdlib_dlanst( 'M', n, d, e ) + nm1 = n - 1_${ik}$ + orgnrm = stdlib${ii}$_dlanst( 'M', n, d, e ) if( orgnrm==zero ) then - call stdlib_zlaset( 'A', n, nrhs, czero, czero, b, ldb ) + call stdlib${ii}$_zlaset( 'A', n, nrhs, czero, czero, b, ldb ) return end if - call stdlib_dlascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info ) - call stdlib_dlascl( 'G', 0, 0, orgnrm, one, nm1, 1, e, nm1, info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, n, 1_${ik}$, d, n, info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, nm1, 1_${ik}$, e, nm1, info ) ! if n is smaller than the minimum divide size smlsiz, then solve ! the problem with another solver. if( n<=smlsiz ) then - irwu = 1 + irwu = 1_${ik}$ irwvt = irwu + n*n irwwrk = irwvt + n*n irwrb = irwwrk irwib = irwrb + n*nrhs irwb = irwib + n*nrhs - call stdlib_dlaset( 'A', n, n, zero, one, rwork( irwu ), n ) - call stdlib_dlaset( 'A', n, n, zero, one, rwork( irwvt ), n ) - call stdlib_dlasdq( 'U', 0, n, n, n, 0, d, e, rwork( irwvt ), n,rwork( irwu ), n, & - rwork( irwwrk ), 1,rwork( irwwrk ), info ) - if( info/=0 ) then + call stdlib${ii}$_dlaset( 'A', n, n, zero, one, rwork( irwu ), n ) + call stdlib${ii}$_dlaset( 'A', n, n, zero, one, rwork( irwvt ), n ) + call stdlib${ii}$_dlasdq( 'U', 0_${ik}$, n, n, n, 0_${ik}$, d, e, rwork( irwvt ), n,rwork( irwu ), n, & + rwork( irwwrk ), 1_${ik}$,rwork( irwwrk ), info ) + if( info/=0_${ik}$ ) then return end if - ! in the real version, b is passed to stdlib_dlasdq and multiplied + ! in the real version, b is passed to stdlib${ii}$_dlasdq and multiplied ! internally by q**h. here b is complex and that product is ! computed below in two steps (real and imaginary parts). - j = irwb - 1 + j = irwb - 1_${ik}$ do jcol = 1, nrhs do jrow = 1, n - j = j + 1 + j = j + 1_${ik}$ rwork( j ) = real( b( jrow, jcol ),KIND=dp) end do end do - call stdlib_dgemm( 'T', 'N', n, nrhs, n, one, rwork( irwu ), n,rwork( irwb ), n, & + call stdlib${ii}$_dgemm( 'T', 'N', n, nrhs, n, one, rwork( irwu ), n,rwork( irwb ), n, & zero, rwork( irwrb ), n ) - j = irwb - 1 + j = irwb - 1_${ik}$ do jcol = 1, nrhs do jrow = 1, n - j = j + 1 + j = j + 1_${ik}$ rwork( j ) = aimag( b( jrow, jcol ) ) end do end do - call stdlib_dgemm( 'T', 'N', n, nrhs, n, one, rwork( irwu ), n,rwork( irwb ), n, & + call stdlib${ii}$_dgemm( 'T', 'N', n, nrhs, n, one, rwork( irwu ), n,rwork( irwb ), n, & zero, rwork( irwib ), n ) - jreal = irwrb - 1 - jimag = irwib - 1 + jreal = irwrb - 1_${ik}$ + jimag = irwib - 1_${ik}$ do jcol = 1, nrhs do jrow = 1, n - jreal = jreal + 1 - jimag = jimag + 1 + jreal = jreal + 1_${ik}$ + jimag = jimag + 1_${ik}$ b( jrow, jcol ) = cmplx( rwork( jreal ),rwork( jimag ),KIND=dp) end do end do - tol = rcnd*abs( d( stdlib_idamax( n, d, 1 ) ) ) + tol = rcnd*abs( d( stdlib${ii}$_idamax( n, d, 1_${ik}$ ) ) ) do i = 1, n if( d( i )<=tol ) then - call stdlib_zlaset( 'A', 1, nrhs, czero, czero, b( i, 1 ), ldb ) + call stdlib${ii}$_zlaset( 'A', 1_${ik}$, nrhs, czero, czero, b( i, 1_${ik}$ ), ldb ) else - call stdlib_zlascl( 'G', 0, 0, d( i ), one, 1, nrhs, b( i, 1 ),ldb, info ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, d( i ), one, 1_${ik}$, nrhs, b( i, 1_${ik}$ ),ldb, info ) - rank = rank + 1 + rank = rank + 1_${ik}$ end if end do - ! since b is complex, the following call to stdlib_dgemm is performed + ! since b is complex, the following call to stdlib${ii}$_dgemm is performed ! in two steps (real and imaginary parts). that is for v * b ! (in the real version of the code v**h is stored in work). - ! call stdlib_dgemm( 't', 'n', n, nrhs, n, one, work, n, b, ldb, zero, + ! call stdlib${ii}$_dgemm( 't', 'n', n, nrhs, n, one, work, n, b, ldb, zero, ! $ work( nwork ), n ) - j = irwb - 1 + j = irwb - 1_${ik}$ do jcol = 1, nrhs do jrow = 1, n - j = j + 1 + j = j + 1_${ik}$ rwork( j ) = real( b( jrow, jcol ),KIND=dp) end do end do - call stdlib_dgemm( 'T', 'N', n, nrhs, n, one, rwork( irwvt ), n,rwork( irwb ), n, & + call stdlib${ii}$_dgemm( 'T', 'N', n, nrhs, n, one, rwork( irwvt ), n,rwork( irwb ), n, & zero, rwork( irwrb ), n ) - j = irwb - 1 + j = irwb - 1_${ik}$ do jcol = 1, nrhs do jrow = 1, n - j = j + 1 + j = j + 1_${ik}$ rwork( j ) = aimag( b( jrow, jcol ) ) end do end do - call stdlib_dgemm( 'T', 'N', n, nrhs, n, one, rwork( irwvt ), n,rwork( irwb ), n, & + call stdlib${ii}$_dgemm( 'T', 'N', n, nrhs, n, one, rwork( irwvt ), n,rwork( irwb ), n, & zero, rwork( irwib ), n ) - jreal = irwrb - 1 - jimag = irwib - 1 + jreal = irwrb - 1_${ik}$ + jimag = irwib - 1_${ik}$ do jcol = 1, nrhs do jrow = 1, n - jreal = jreal + 1 - jimag = jimag + 1 + jreal = jreal + 1_${ik}$ + jimag = jimag + 1_${ik}$ b( jrow, jcol ) = cmplx( rwork( jreal ),rwork( jimag ),KIND=dp) end do end do ! unscale. - call stdlib_dlascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) - call stdlib_dlasrt( 'D', n, d, info ) - call stdlib_zlascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, n, 1_${ik}$, d, n, info ) + call stdlib${ii}$_dlasrt( 'D', n, d, info ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, n, nrhs, b, ldb, info ) return end if ! book-keeping and setting up some constants. - nlvl = int( log( real( n,KIND=dp) / real( smlsiz+1,KIND=dp) ) / log( two ),KIND=ilp) + & - 1 - smlszp = smlsiz + 1 - u = 1 - vt = 1 + smlsiz*n + nlvl = int( log( real( n,KIND=dp) / real( smlsiz+1,KIND=dp) ) / log( two ),KIND=${ik}$) + & + 1_${ik}$ + smlszp = smlsiz + 1_${ik}$ + u = 1_${ik}$ + vt = 1_${ik}$ + smlsiz*n difl = vt + smlszp*n difr = difl + nlvl*n - z = difr + nlvl*n*2 + z = difr + nlvl*n*2_${ik}$ c = z + nlvl*n s = c + n poles = s + n - givnum = poles + 2*nlvl*n - nrwork = givnum + 2*nlvl*n - bx = 1 + givnum = poles + 2_${ik}$*nlvl*n + nrwork = givnum + 2_${ik}$*nlvl*n + bx = 1_${ik}$ irwrb = nrwork irwib = irwrb + smlsiz*nrhs irwb = irwib + smlsiz*nrhs - sizei = 1 + n + sizei = 1_${ik}$ + n k = sizei + n givptr = k + n perm = givptr + n givcol = perm + nlvl*n - iwk = givcol + nlvl*n*2 - st = 1 - sqre = 0 - icmpq1 = 1 - icmpq2 = 0 - nsub = 0 + iwk = givcol + nlvl*n*2_${ik}$ + st = 1_${ik}$ + sqre = 0_${ik}$ + icmpq1 = 1_${ik}$ + icmpq2 = 0_${ik}$ + nsub = 0_${ik}$ do i = 1, n if( abs( d( i ) )=eps ) then ! a subproblem with e(nm1) not too small but i = nm1. - nsize = n - st + 1 + nsize = n - st + 1_${ik}$ iwork( sizei+nsub-1 ) = nsize else ! a subproblem with e(nm1) small. this implies an ! 1-by-1 subproblem at d(n), which is not solved ! explicitly. - nsize = i - st + 1 + nsize = i - st + 1_${ik}$ iwork( sizei+nsub-1 ) = nsize - nsub = nsub + 1 + nsub = nsub + 1_${ik}$ iwork( nsub ) = n - iwork( sizei+nsub-1 ) = 1 - call stdlib_zcopy( nrhs, b( n, 1 ), ldb, work( bx+nm1 ), n ) + iwork( sizei+nsub-1 ) = 1_${ik}$ + call stdlib${ii}$_zcopy( nrhs, b( n, 1_${ik}$ ), ldb, work( bx+nm1 ), n ) end if - st1 = st - 1 - if( nsize==1 ) then + st1 = st - 1_${ik}$ + if( nsize==1_${ik}$ ) then ! this is a 1-by-1 subproblem and is not solved ! explicitly. - call stdlib_zcopy( nrhs, b( st, 1 ), ldb, work( bx+st1 ), n ) + call stdlib${ii}$_zcopy( nrhs, b( st, 1_${ik}$ ), ldb, work( bx+st1 ), n ) else if( nsize<=smlsiz ) then - ! this is a small subproblem and is solved by stdlib_dlasdq. - call stdlib_dlaset( 'A', nsize, nsize, zero, one,rwork( vt+st1 ), n ) - call stdlib_dlaset( 'A', nsize, nsize, zero, one,rwork( u+st1 ), n ) - call stdlib_dlasdq( 'U', 0, nsize, nsize, nsize, 0, d( st ),e( st ), rwork( & - vt+st1 ), n, rwork( u+st1 ),n, rwork( nrwork ), 1, rwork( nrwork ),info ) + ! this is a small subproblem and is solved by stdlib${ii}$_dlasdq. + call stdlib${ii}$_dlaset( 'A', nsize, nsize, zero, one,rwork( vt+st1 ), n ) + call stdlib${ii}$_dlaset( 'A', nsize, nsize, zero, one,rwork( u+st1 ), n ) + call stdlib${ii}$_dlasdq( 'U', 0_${ik}$, nsize, nsize, nsize, 0_${ik}$, d( st ),e( st ), rwork( & + vt+st1 ), n, rwork( u+st1 ),n, rwork( nrwork ), 1_${ik}$, rwork( nrwork ),info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if - ! in the real version, b is passed to stdlib_dlasdq and multiplied + ! in the real version, b is passed to stdlib${ii}$_dlasdq and multiplied ! internally by q**h. here b is complex and that product is ! computed below in two steps (real and imaginary parts). - j = irwb - 1 + j = irwb - 1_${ik}$ do jcol = 1, nrhs do jrow = st, st + nsize - 1 - j = j + 1 + j = j + 1_${ik}$ rwork( j ) = real( b( jrow, jcol ),KIND=dp) end do end do - call stdlib_dgemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( u+st1 ), n, rwork(& + call stdlib${ii}$_dgemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( u+st1 ), n, rwork(& irwb ), nsize,zero, rwork( irwrb ), nsize ) - j = irwb - 1 + j = irwb - 1_${ik}$ do jcol = 1, nrhs do jrow = st, st + nsize - 1 - j = j + 1 + j = j + 1_${ik}$ rwork( j ) = aimag( b( jrow, jcol ) ) end do end do - call stdlib_dgemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( u+st1 ), n, rwork(& + call stdlib${ii}$_dgemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( u+st1 ), n, rwork(& irwb ), nsize,zero, rwork( irwib ), nsize ) - jreal = irwrb - 1 - jimag = irwib - 1 + jreal = irwrb - 1_${ik}$ + jimag = irwib - 1_${ik}$ do jcol = 1, nrhs do jrow = st, st + nsize - 1 - jreal = jreal + 1 - jimag = jimag + 1 + jreal = jreal + 1_${ik}$ + jimag = jimag + 1_${ik}$ b( jrow, jcol ) = cmplx( rwork( jreal ),rwork( jimag ),KIND=dp) end do end do - call stdlib_zlacpy( 'A', nsize, nrhs, b( st, 1 ), ldb,work( bx+st1 ), n ) + call stdlib${ii}$_zlacpy( 'A', nsize, nrhs, b( st, 1_${ik}$ ), ldb,work( bx+st1 ), n ) else ! a large problem. solve it using divide and conquer. - call stdlib_dlasda( icmpq1, smlsiz, nsize, sqre, d( st ),e( st ), rwork( u+& + call stdlib${ii}$_dlasda( icmpq1, smlsiz, nsize, sqre, d( st ),e( st ), rwork( u+& st1 ), n, rwork( vt+st1 ),iwork( k+st1 ), rwork( difl+st1 ),rwork( difr+st1 ),& rwork( z+st1 ),rwork( poles+st1 ), iwork( givptr+st1 ),iwork( givcol+st1 ), & n, iwork( perm+st1 ),rwork( givnum+st1 ), rwork( c+st1 ),rwork( s+st1 ), & rwork( nrwork ),iwork( iwk ), info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if bxst = bx + st1 - call stdlib_zlalsa( icmpq2, smlsiz, nsize, nrhs, b( st, 1 ),ldb, work( bxst ),& + call stdlib${ii}$_zlalsa( icmpq2, smlsiz, nsize, nrhs, b( st, 1_${ik}$ ),ldb, work( bxst ),& n, rwork( u+st1 ), n,rwork( vt+st1 ), iwork( k+st1 ),rwork( difl+st1 ), & rwork( difr+st1 ),rwork( z+st1 ), rwork( poles+st1 ),iwork( givptr+st1 ), & iwork( givcol+st1 ), n,iwork( perm+st1 ), rwork( givnum+st1 ),rwork( c+st1 ),& rwork( s+st1 ),rwork( nrwork ), iwork( iwk ), info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if end if - st = i + 1 + st = i + 1_${ik}$ end if end do loop_240 ! apply the singular values and treat the tiny ones as zero. - tol = rcnd*abs( d( stdlib_idamax( n, d, 1 ) ) ) + tol = rcnd*abs( d( stdlib${ii}$_idamax( n, d, 1_${ik}$ ) ) ) do i = 1, n ! some of the elements in d can be negative because 1-by-1 ! subproblems were not solved explicitly. if( abs( d( i ) )<=tol ) then - call stdlib_zlaset( 'A', 1, nrhs, czero, czero, work( bx+i-1 ), n ) + call stdlib${ii}$_zlaset( 'A', 1_${ik}$, nrhs, czero, czero, work( bx+i-1 ), n ) else - rank = rank + 1 - call stdlib_zlascl( 'G', 0, 0, d( i ), one, 1, nrhs,work( bx+i-1 ), n, info ) + rank = rank + 1_${ik}$ + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, d( i ), one, 1_${ik}$, nrhs,work( bx+i-1 ), n, info ) end if d( i ) = abs( d( i ) ) end do ! now apply back the right singular vectors. - icmpq2 = 1 + icmpq2 = 1_${ik}$ loop_320: do i = 1, nsub st = iwork( i ) - st1 = st - 1 + st1 = st - 1_${ik}$ nsize = iwork( sizei+i-1 ) bxst = bx + st1 - if( nsize==1 ) then - call stdlib_zcopy( nrhs, work( bxst ), n, b( st, 1 ), ldb ) + if( nsize==1_${ik}$ ) then + call stdlib${ii}$_zcopy( nrhs, work( bxst ), n, b( st, 1_${ik}$ ), ldb ) else if( nsize<=smlsiz ) then - ! since b and bx are complex, the following call to stdlib_dgemm + ! since b and bx are complex, the following call to stdlib${ii}$_dgemm ! is performed in two steps (real and imaginary parts). - ! call stdlib_dgemm( 't', 'n', nsize, nrhs, nsize, one, + ! call stdlib${ii}$_dgemm( 't', 'n', nsize, nrhs, nsize, one, ! $ rwork( vt+st1 ), n, rwork( bxst ), n, zero, ! $ b( st, 1 ), ldb ) - j = bxst - n - 1 - jreal = irwb - 1 + j = bxst - n - 1_${ik}$ + jreal = irwb - 1_${ik}$ do jcol = 1, nrhs j = j + n do jrow = 1, nsize - jreal = jreal + 1 + jreal = jreal + 1_${ik}$ rwork( jreal ) = real( work( j+jrow ),KIND=dp) end do end do - call stdlib_dgemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( vt+st1 ), n, rwork( & + call stdlib${ii}$_dgemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( vt+st1 ), n, rwork( & irwb ), nsize, zero,rwork( irwrb ), nsize ) - j = bxst - n - 1 - jimag = irwb - 1 + j = bxst - n - 1_${ik}$ + jimag = irwb - 1_${ik}$ do jcol = 1, nrhs j = j + n do jrow = 1, nsize - jimag = jimag + 1 + jimag = jimag + 1_${ik}$ rwork( jimag ) = aimag( work( j+jrow ) ) end do end do - call stdlib_dgemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( vt+st1 ), n, rwork( & + call stdlib${ii}$_dgemm( 'T', 'N', nsize, nrhs, nsize, one,rwork( vt+st1 ), n, rwork( & irwb ), nsize, zero,rwork( irwib ), nsize ) - jreal = irwrb - 1 - jimag = irwib - 1 + jreal = irwrb - 1_${ik}$ + jimag = irwib - 1_${ik}$ do jcol = 1, nrhs do jrow = st, st + nsize - 1 - jreal = jreal + 1 - jimag = jimag + 1 + jreal = jreal + 1_${ik}$ + jimag = jimag + 1_${ik}$ b( jrow, jcol ) = cmplx( rwork( jreal ),rwork( jimag ),KIND=dp) end do end do else - call stdlib_zlalsa( icmpq2, smlsiz, nsize, nrhs, work( bxst ), n,b( st, 1 ), ldb,& + call stdlib${ii}$_zlalsa( icmpq2, smlsiz, nsize, nrhs, work( bxst ), n,b( st, 1_${ik}$ ), ldb,& rwork( u+st1 ), n,rwork( vt+st1 ), iwork( k+st1 ),rwork( difl+st1 ), rwork( & difr+st1 ),rwork( z+st1 ), rwork( poles+st1 ),iwork( givptr+st1 ), iwork( & givcol+st1 ), n,iwork( perm+st1 ), rwork( givnum+st1 ),rwork( c+st1 ), rwork( s+& st1 ),rwork( nrwork ), iwork( iwk ), info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then return end if end if end do loop_320 ! unscale and sort the singular values. - call stdlib_dlascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) - call stdlib_dlasrt( 'D', n, d, info ) - call stdlib_zlascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, n, 1_${ik}$, d, n, info ) + call stdlib${ii}$_dlasrt( 'D', n, d, info ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, n, nrhs, b, ldb, info ) return - end subroutine stdlib_zlalsd + end subroutine stdlib${ii}$_zlalsd - real(dp) function stdlib_zlangb( norm, n, kl, ku, ab, ldab,work ) + real(dp) function stdlib${ii}$_zlangb( norm, n, kl, ku, ab, ldab,work ) !! ZLANGB returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of an !! n by n band matrix A, with kl sub-diagonals and ku super-diagonals. @@ -41683,19 +41686,19 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: norm - integer(ilp), intent(in) :: kl, ku, ldab, n + integer(${ik}$), intent(in) :: kl, ku, ldab, n ! Array Arguments real(dp), intent(out) :: work(*) complex(dp), intent(in) :: ab(ldab,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, k, l + integer(${ik}$) :: i, j, k, l real(dp) :: scale, sum, value, temp ! 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))). @@ -41703,7 +41706,7 @@ module stdlib_linalg_lapack_z do j = 1, n do i = max( ku+2-j, 1 ), min( n+ku+1-j, kl+ku+1 ) temp = abs( ab( i, j ) ) - if( value1 ) then - call stdlib_zlassq( n-1, dl, 1, scale, sum ) - call stdlib_zlassq( n-1, du, 1, scale, sum ) + call stdlib${ii}$_zlassq( n, d, 1_${ik}$, scale, sum ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_zlassq( n-1, dl, 1_${ik}$, scale, sum ) + call stdlib${ii}$_zlassq( n-1, du, 1_${ik}$, scale, sum ) end if anorm = scale*sqrt( sum ) end if - stdlib_zlangt = anorm + stdlib${ii}$_zlangt = anorm return - end function stdlib_zlangt + end function stdlib${ii}$_zlangt - real(dp) function stdlib_zlanhb( norm, uplo, n, k, ab, ldab,work ) + real(dp) function stdlib${ii}$_zlanhb( norm, uplo, n, k, ab, ldab,work ) !! ZLANHB returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of an !! n by n hermitian band matrix A, with k super-diagonals. @@ -41906,19 +41909,19 @@ module stdlib_linalg_lapack_z ! -- 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(dp), intent(out) :: work(*) complex(dp), intent(in) :: ab(ldab,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, l + integer(${ik}$) :: i, j, l real(dp) :: absa, scale, sum, value ! Intrinsic Functions intrinsic :: abs,real,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))). @@ -41927,18 +41930,18 @@ module stdlib_linalg_lapack_z do j = 1, n do i = max( k+2-j, 1 ), k sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do sum = abs( real( ab( k+1, j ),KIND=dp) ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do else do j = 1, n - sum = abs( real( ab( 1, j ),KIND=dp) ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + sum = abs( real( ab( 1_${ik}$, j ),KIND=dp) ) + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum do i = 2, min( n+1-j, k+1 ) sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do end do end if @@ -41949,7 +41952,7 @@ module stdlib_linalg_lapack_z 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 @@ -41959,21 +41962,21 @@ module stdlib_linalg_lapack_z end do do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do else do i = 1, n work( i ) = zero end do do j = 1, n - sum = work( j ) + abs( real( ab( 1, j ),KIND=dp) ) - l = 1 - j + sum = work( j ) + abs( real( ab( 1_${ik}$, j ),KIND=dp) ) + 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_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do end if else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & @@ -41981,42 +41984,42 @@ module stdlib_linalg_lapack_z ! 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_zlassq( min( j-1, k ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) + call stdlib${ii}$_zlassq( 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_zlassq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) + call stdlib${ii}$_zlassq( 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 do j = 1, n if( real( ab( l, j ),KIND=dp)/=zero ) then absa = abs( real( ab( l, j ),KIND=dp) ) if( scale l(0,0) temp = abs( real( a( j+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp do i = 1, n - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do do j = 1, k - 1 do i = 0, j - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do - i = j - 1 + i = j - 1_${ik}$ ! l(k+j,k+j) temp = abs( real( a( i+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp i = j ! -> l(j,j) temp = abs( real( a( i+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp do i = j + 1, n - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do end do else @@ -42218,65 +42221,65 @@ module stdlib_linalg_lapack_z do j = 0, k - 2 do i = 0, k + j - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do - i = k + j - 1 + i = k + j - 1_${ik}$ ! -> u(i,i) temp = abs( real( a( i+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp - i = i + 1 + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp + i = i + 1_${ik}$ ! =k+j; i -> u(j,j) temp = abs( real( a( i+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp do i = k + j + 1, n - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do end do do i = 0, n - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp ! j=k-1 end do ! i=n-1 -> u(n-1,n-1) temp = abs( real( a( i+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end if else ! xpose case; a is k by n - if( ilu==1 ) then + if( ilu==1_${ik}$ ) then ! uplo ='l' do j = 0, k - 2 do i = 0, j - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do i = j ! l(i,i) temp = abs( real( a( i+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp - i = j + 1 + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp + i = j + 1_${ik}$ ! l(j+k,j+k) temp = abs( real( a( i+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp do i = j + 2, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do end do - j = k - 1 + j = k - 1_${ik}$ do i = 0, k - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do - i = k - 1 + i = k - 1_${ik}$ ! -> l(i,i) is at a(i,j) temp = abs( real( a( i+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp do j = k, n - 1 do i = 0, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do end do else @@ -42284,69 +42287,69 @@ module stdlib_linalg_lapack_z do j = 0, k - 2 do i = 0, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do end do - j = k - 1 + j = k - 1_${ik}$ ! -> u(j,j) is at a(0,j) - temp = abs( real( a( 0+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + temp = abs( real( a( 0_${ik}$+j*lda ),KIND=dp) ) + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp do i = 1, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do do j = k, n - 1 do i = 0, j - k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do i = j - k ! -> u(i,i) at a(i,j) temp = abs( real( a( i+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp - i = j - k + 1 + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp + i = j - k + 1_${ik}$ ! u(j,j) temp = abs( real( a( i+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp do i = j - k + 2, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do end do end if end if else ! n is even - if( ifm==1 ) then + if( ifm==1_${ik}$ ) then ! a is n+1 by k - if( ilu==1 ) then + if( ilu==1_${ik}$ ) then ! uplo ='l' - j = 0 + j = 0_${ik}$ ! -> l(k,k) temp = abs( real( a( j+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp temp = abs( real( a( j+1+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp do i = 2, n temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do do j = 1, k - 1 do i = 0, j - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do i = j ! l(k+j,k+j) temp = abs( real( a( i+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp - i = j + 1 + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp + i = j + 1_${ik}$ ! -> l(j,j) temp = abs( real( a( i+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp do i = j + 2, n temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do end do else @@ -42354,77 +42357,77 @@ module stdlib_linalg_lapack_z do j = 0, k - 2 do i = 0, k + j - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do i = k + j ! -> u(i,i) temp = abs( real( a( i+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp - i = i + 1 + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp + i = i + 1_${ik}$ ! =k+j+1; i -> u(j,j) temp = abs( real( a( i+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp do i = k + j + 2, n temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do end do do i = 0, n - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp ! j=k-1 end do ! i=n-1 -> u(n-1,n-1) temp = abs( real( a( i+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp i = n ! -> u(k-1,k-1) temp = abs( real( a( i+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end if else ! xpose case; a is k by n+1 - if( ilu==1 ) then + if( ilu==1_${ik}$ ) then ! uplo ='l' - j = 0 + j = 0_${ik}$ ! -> l(k,k) at a(0,0) temp = abs( real( a( j+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp do i = 1, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do do j = 1, k - 1 do i = 0, j - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do - i = j - 1 + i = j - 1_${ik}$ ! l(i,i) temp = abs( real( a( i+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp i = j ! l(j+k,j+k) temp = abs( real( a( i+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp do i = j + 1, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do end do j = k do i = 0, k - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do - i = k - 1 + i = k - 1_${ik}$ ! -> l(i,i) is at a(i,j) temp = abs( real( a( i+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp do j = k + 1, n do i = 0, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do end do else @@ -42432,56 +42435,56 @@ module stdlib_linalg_lapack_z do j = 0, k - 1 do i = 0, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do end do j = k ! -> u(j,j) is at a(0,j) - temp = abs( real( a( 0+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + temp = abs( real( a( 0_${ik}$+j*lda ),KIND=dp) ) + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp do i = 1, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do do j = k + 1, n - 1 do i = 0, j - k - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do - i = j - k - 1 + i = j - k - 1_${ik}$ ! -> u(i,i) at a(i,j) temp = abs( real( a( i+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp i = j - k ! u(j,j) temp = abs( real( a( i+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp do i = j - k + 1, k - 1 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do end do j = n do i = 0, k - 2 temp = abs( a( i+j*lda ) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do - i = k - 1 + i = k - 1_${ik}$ ! u(k,k) at a(i,j) temp = abs( real( a( i+j*lda ),KIND=dp) ) - if( value < temp .or. stdlib_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end if end if end if else if( ( stdlib_lsame( norm, 'I' ) ) .or. ( stdlib_lsame( norm, 'O' ) ) .or.( & norm=='1' ) ) then ! find normi(a) ( = norm1(a), since a is hermitian). - if( ifm==1 ) then + if( ifm==1_${ik}$ ) then ! a is 'n' - k = n / 2 - if( noe==1 ) then + k = n / 2_${ik}$ + if( noe==1_${ik}$ ) then ! n is odd - if( ilu==0 ) then + if( ilu==0_${ik}$ ) then ! uplo = 'u' do i = 0, k - 1 work( i ) = zero @@ -42498,13 +42501,13 @@ module stdlib_linalg_lapack_z ! -> 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( real( a( i+j*lda ),KIND=dp) ) ! -> 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 @@ -42513,14 +42516,14 @@ module stdlib_linalg_lapack_z 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_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do else ! ilu = 1 - k = k + 1 + k = k + 1_${ik}$ ! k=(n+1)/2 for n odd and ilu=1 do i = k, n - 1 work( i ) = zero @@ -42533,20 +42536,20 @@ module stdlib_linalg_lapack_z s = s + aa work( i+k ) = work( i+k ) + aa end do - if( j>0 ) then + if( j>0_${ik}$ ) then aa = abs( real( a( i+j*lda ),KIND=dp) ) ! -> 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( real( a( i+j*lda ),KIND=dp) ) ! -> 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 @@ -42554,15 +42557,15 @@ module stdlib_linalg_lapack_z 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_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do end if else ! n is even - if( ilu==0 ) then + if( ilu==0_${ik}$ ) then ! uplo = 'u' do i = 0, k - 1 work( i ) = zero @@ -42578,13 +42581,13 @@ module stdlib_linalg_lapack_z aa = abs( real( a( i+j*lda ),KIND=dp) ) ! -> a(j+k,j+k) work( j+k ) = s + aa - i = i + 1 + i = i + 1_${ik}$ aa = abs( real( a( i+j*lda ),KIND=dp) ) ! -> 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 @@ -42592,10 +42595,10 @@ module stdlib_linalg_lapack_z 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_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do else ! ilu = 1 @@ -42615,13 +42618,13 @@ module stdlib_linalg_lapack_z s = s + aa work( i+k ) = work( i+k ) + s ! i=j - i = i + 1 + i = i + 1_${ik}$ aa = abs( real( a( i+j*lda ),KIND=dp) ) ! -> 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 @@ -42629,23 +42632,23 @@ module stdlib_linalg_lapack_z 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_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do end if end if else ! ifm=0 - k = n / 2 - if( noe==1 ) then + k = n / 2_${ik}$ + if( noe==1_${ik}$ ) then ! n is odd - if( ilu==0 ) then + if( ilu==0_${ik}$ ) then ! uplo = 'u' n1 = k ! n/2 - k = k + 1 + k = k + 1_${ik}$ ! k is the row size and lda do i = n1, n - 1 work( i ) = zero @@ -42661,7 +42664,7 @@ module stdlib_linalg_lapack_z work( j ) = s end do ! j=n1=k-1 is special - s = abs( real( a( 0+j*lda ),KIND=dp) ) + s = abs( real( a( 0_${ik}$+j*lda ),KIND=dp) ) ! a(k-1,k-1) do i = 1, k - 1 aa = abs( a( i+j*lda ) ) @@ -42683,11 +42686,11 @@ module stdlib_linalg_lapack_z ! a(j-k,j-k) s = s + aa work( j-k ) = work( j-k ) + s - i = i + 1 + i = i + 1_${ik}$ s = abs( real( a( i+j*lda ),KIND=dp) ) ! 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 @@ -42695,14 +42698,14 @@ module stdlib_linalg_lapack_z 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_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do else ! ilu=1 - k = k + 1 + k = k + 1_${ik}$ ! k=(n+1)/2 for n odd and ilu=1 do i = k, n - 1 work( i ) = zero @@ -42721,12 +42724,12 @@ module stdlib_linalg_lapack_z 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( real( a( i+j*lda ),KIND=dp) ) 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 @@ -42759,15 +42762,15 @@ module stdlib_linalg_lapack_z 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_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do end if else ! n is even - if( ilu==0 ) then + if( ilu==0_${ik}$ ) then ! uplo = 'u' do i = k, n - 1 work( i ) = zero @@ -42783,7 +42786,7 @@ module stdlib_linalg_lapack_z work( j ) = s end do ! j=k - aa = abs( real( a( 0+j*lda ),KIND=dp) ) + aa = abs( real( a( 0_${ik}$+j*lda ),KIND=dp) ) ! a(k,k) s = aa do i = 1, k - 1 @@ -42806,12 +42809,12 @@ module stdlib_linalg_lapack_z ! 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( real( a( i+j*lda ),KIND=dp) ) ! 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 @@ -42832,10 +42835,10 @@ module stdlib_linalg_lapack_z ! 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_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do else ! ilu=1 @@ -42843,7 +42846,7 @@ module stdlib_linalg_lapack_z work( i ) = zero end do ! j=0 is special :process col a(k:n-1,k) - s = abs( real( a( 0 ),KIND=dp) ) + s = abs( real( a( 0_${ik}$ ),KIND=dp) ) ! a(k,k) do i = 1, k - 1 aa = abs( a( i ) ) @@ -42866,12 +42869,12 @@ module stdlib_linalg_lapack_z 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( real( a( i+j*lda ),KIND=dp) ) 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 @@ -42904,10 +42907,10 @@ module stdlib_linalg_lapack_z 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_disnan( temp ) )value = temp + if( value < temp .or. stdlib${ii}$_disnan( temp ) )value = temp end do end if end if @@ -42915,80 +42918,80 @@ module stdlib_linalg_lapack_z 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_zlassq( k-j-2, a( k+j+1+j*lda ), 1, scale, s ) + call stdlib${ii}$_zlassq( k-j-2, a( k+j+1+j*lda ), 1_${ik}$, scale, s ) ! l at a(k,0) end do do j = 0, k - 1 - call stdlib_zlassq( k+j-1, a( 0+j*lda ), 1, scale, s ) + call stdlib${ii}$_zlassq( k+j-1, a( 0_${ik}$+j*lda ), 1_${ik}$, scale, s ) ! trap u at a(0,0) end do s = s + s ! double s for the off diagonal elements - l = k - 1 + l = k - 1_${ik}$ ! -> u(k,k) at a(k-1,0) do i = 0, k - 2 aa = real( a( l ),KIND=dp) ! u(k+i,k+i) if( aa/=zero ) then if( scale u(k-1,k-1) at a(0,k-1) aa = real( a( l ),KIND=dp) ! u(k-1,k-1) if( aa/=zero ) then if( scale u(j-k,j-k) if( aa/=zero ) then if( scale u(j,j) if( aa/=zero ) then if( scale l(0,0) at a(0,0) do i = 0, k - 2 aa = real( a( l ),KIND=dp) ! l(i,i) if( aa/=zero ) then if( scale k-1 + (k-1)*lda or l(k-1,k-1) at a(k-1,k-1) aa = real( a( l ),KIND=dp) ! l(k-1,k-1) at a(k-1,k-1) if( aa/=zero ) then if( scale l(k,k) at a(0,0) do i = 0, k - 1 aa = real( a( l ),KIND=dp) ! l(k-1+i,k-1+i) if( aa/=zero ) then if( scale u(k,k) at a(0,k) aa = real( a( l ),KIND=dp) ! u(k,k) if( aa/=zero ) then if( scale u(j-k-1,j-k-1) if( aa/=zero ) then if( scale u(j,j) if( aa/=zero ) then if( scale u(k-1,k-1) at a(k-1,n) @@ -43266,38 +43269,38 @@ module stdlib_linalg_lapack_z ! u(k,k) if( aa/=zero ) then if( scale l(k,k) at a(0,0) aa = real( a( l ),KIND=dp) ! l(k,k) at a(0,0) if( aa/=zero ) then if( scale k - 1 + k*lda or l(k-1,k-1) at a(k-1,k) aa = real( a( l ),KIND=dp) ! l(k-1,k-1) at a(k-1,k) if( aa/=zero ) then if( scale1 ) then - call stdlib_zlassq( n-1, e, 1, scale, sum ) - sum = 2*sum + if( n>1_${ik}$ ) then + call stdlib${ii}$_zlassq( n-1, e, 1_${ik}$, scale, sum ) + sum = 2_${ik}$*sum end if - call stdlib_dlassq( n, d, 1, scale, sum ) + call stdlib${ii}$_dlassq( n, d, 1_${ik}$, scale, sum ) anorm = scale*sqrt( sum ) end if - stdlib_zlanht = anorm + stdlib${ii}$_zlanht = anorm return - end function stdlib_zlanht + end function stdlib${ii}$_zlanht - real(dp) function stdlib_zlansb( norm, uplo, n, k, ab, ldab,work ) + real(dp) function stdlib${ii}$_zlansb( norm, uplo, n, k, ab, ldab,work ) !! ZLANSB returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of an !! n by n symmetric band matrix A, with k super-diagonals. @@ -43618,19 +43621,19 @@ module stdlib_linalg_lapack_z ! -- 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(dp), intent(out) :: work(*) complex(dp), intent(in) :: ab(ldab,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, l + integer(${ik}$) :: i, j, l real(dp) :: 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))). @@ -43639,14 +43642,14 @@ module stdlib_linalg_lapack_z do j = 1, n do i = max( k+2-j, 1 ), k + 1 sum = abs( ab( i, j ) ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( 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_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do end do end if @@ -43657,7 +43660,7 @@ module stdlib_linalg_lapack_z 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 @@ -43667,21 +43670,21 @@ module stdlib_linalg_lapack_z end do do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( 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_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do end if else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & @@ -43689,32 +43692,32 @@ module stdlib_linalg_lapack_z ! 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_zlassq( min( j-1, k ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) + call stdlib${ii}$_zlassq( 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_zlassq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) + call stdlib${ii}$_zlassq( 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_zlassq( n, ab( l, 1 ), ldab, scale, sum ) + call stdlib${ii}$_zlassq( n, ab( l, 1_${ik}$ ), ldab, scale, sum ) value = scale*sqrt( sum ) end if - stdlib_zlansb = value + stdlib${ii}$_zlansb = value return - end function stdlib_zlansb + end function stdlib${ii}$_zlansb - real(dp) function stdlib_zlansp( norm, uplo, n, ap, work ) + real(dp) function stdlib${ii}$_zlansp( norm, uplo, n, ap, work ) !! ZLANSP returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! complex symmetric matrix A, supplied in packed form. @@ -43723,47 +43726,47 @@ module stdlib_linalg_lapack_z ! -- 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(dp), intent(out) :: work(*) complex(dp), intent(in) :: ap(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, j, k + integer(${ik}$) :: i, j, k real(dp) :: absa, scale, sum, value ! Intrinsic Functions intrinsic :: abs,real,aimag,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_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( 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_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( 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 ! 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 @@ -43771,14 +43774,14 @@ module stdlib_linalg_lapack_z 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_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do else do i = 1, n @@ -43786,14 +43789,14 @@ module stdlib_linalg_lapack_z 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_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do end if else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & @@ -43801,53 +43804,53 @@ module stdlib_linalg_lapack_z ! find normf(a). scale = zero sum = one - k = 2 + k = 2_${ik}$ if( stdlib_lsame( uplo, 'U' ) ) then do j = 2, n - call stdlib_zlassq( j-1, ap( k ), 1, scale, sum ) + call stdlib${ii}$_zlassq( j-1, ap( k ), 1_${ik}$, scale, sum ) k = k + j end do else do j = 1, n - 1 - call stdlib_zlassq( n-j, ap( k ), 1, scale, sum ) - k = k + n - j + 1 + call stdlib${ii}$_zlassq( 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( real( ap( k ),KIND=dp)/=zero ) then absa = abs( real( ap( k ),KIND=dp) ) if( scale0 ) then + if( k>0_${ik}$ ) then do j = 2, n - call stdlib_zlassq( min( j-1, k ),ab( max( k+2-j, 1 ), j ), 1, scale,& + call stdlib${ii}$_zlassq( min( j-1, k ),ab( max( k+2-j, 1_${ik}$ ), j ), 1_${ik}$, scale,& sum ) end do end if @@ -44108,7 +44111,7 @@ module stdlib_linalg_lapack_z scale = zero sum = one do j = 1, n - call stdlib_zlassq( min( j, k+1 ), ab( max( k+2-j, 1 ), j ),1, scale, sum ) + call stdlib${ii}$_zlassq( min( j, k+1 ), ab( max( k+2-j, 1_${ik}$ ), j ),1_${ik}$, scale, sum ) end do end if @@ -44116,27 +44119,27 @@ module stdlib_linalg_lapack_z 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_zlassq( min( n-j, k ), ab( 2, j ), 1, scale,sum ) + call stdlib${ii}$_zlassq( 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_zlassq( min( n-j+1, k+1 ), ab( 1, j ), 1, scale,sum ) + call stdlib${ii}$_zlassq( 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_zlantb = value + stdlib${ii}$_zlantb = value return - end function stdlib_zlantb + end function stdlib${ii}$_zlantb - real(dp) function stdlib_zlantp( norm, uplo, diag, n, ap, work ) + real(dp) function stdlib${ii}$_zlantp( norm, uplo, diag, n, ap, work ) !! ZLANTP returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! triangular matrix A, supplied in packed form. @@ -44145,7 +44148,7 @@ module stdlib_linalg_lapack_z ! -- 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(dp), intent(out) :: work(*) complex(dp), intent(in) :: ap(*) @@ -44153,23 +44156,23 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: udiag - integer(ilp) :: i, j, k + integer(${ik}$) :: i, j, k real(dp) :: 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_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do k = k + j end do @@ -44177,9 +44180,9 @@ module stdlib_linalg_lapack_z do j = 1, n do i = k + 1, k + n - j sum = abs( ap( i ) ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do - k = k + n - j + 1 + k = k + n - j + 1_${ik}$ end do end if else @@ -44188,7 +44191,7 @@ module stdlib_linalg_lapack_z do j = 1, n do i = k, k + j - 1 sum = abs( ap( i ) ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do k = k + j end do @@ -44196,16 +44199,16 @@ module stdlib_linalg_lapack_z do j = 1, n do i = k, k + n - j sum = abs( ap( i ) ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( 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 ! 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 @@ -44221,7 +44224,7 @@ module stdlib_linalg_lapack_z end do end if k = k + j - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do else do j = 1, n @@ -44236,13 +44239,13 @@ module stdlib_linalg_lapack_z sum = sum + abs( ap( i ) ) end do end if - k = k + n - j + 1 - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + k = k + n - j + 1_${ik}$ + if( value < sum .or. stdlib${ii}$_disnan( 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 @@ -44251,9 +44254,9 @@ module stdlib_linalg_lapack_z 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 @@ -44262,7 +44265,7 @@ module stdlib_linalg_lapack_z 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 @@ -44272,10 +44275,10 @@ module stdlib_linalg_lapack_z 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 @@ -44285,7 +44288,7 @@ module stdlib_linalg_lapack_z 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 @@ -44293,7 +44296,7 @@ module stdlib_linalg_lapack_z value = zero do i = 1, n sum = work( i ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & then @@ -44302,17 +44305,17 @@ module stdlib_linalg_lapack_z if( stdlib_lsame( diag, 'U' ) ) then scale = one sum = n - k = 2 + k = 2_${ik}$ do j = 2, n - call stdlib_zlassq( j-1, ap( k ), 1, scale, sum ) + call stdlib${ii}$_zlassq( 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_zlassq( j, ap( k ), 1, scale, sum ) + call stdlib${ii}$_zlassq( j, ap( k ), 1_${ik}$, scale, sum ) k = k + j end do end if @@ -44320,29 +44323,29 @@ module stdlib_linalg_lapack_z if( stdlib_lsame( diag, 'U' ) ) then scale = one sum = n - k = 2 + k = 2_${ik}$ do j = 1, n - 1 - call stdlib_zlassq( n-j, ap( k ), 1, scale, sum ) - k = k + n - j + 1 + call stdlib${ii}$_zlassq( 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_zlassq( n-j+1, ap( k ), 1, scale, sum ) - k = k + n - j + 1 + call stdlib${ii}$_zlassq( 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_zlantp = value + stdlib${ii}$_zlantp = value return - end function stdlib_zlantp + end function stdlib${ii}$_zlantp - real(dp) function stdlib_zlantr( norm, uplo, diag, m, n, a, lda,work ) + real(dp) function stdlib${ii}$_zlantr( norm, uplo, diag, m, n, a, lda,work ) !! ZLANTR returns the value of the one norm, or the Frobenius norm, or !! the infinity norm, or the element of largest absolute value of a !! trapezoidal or triangular matrix A. @@ -44351,7 +44354,7 @@ module stdlib_linalg_lapack_z ! -- 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(dp), intent(out) :: work(*) complex(dp), intent(in) :: a(lda,*) @@ -44359,12 +44362,12 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: udiag - integer(ilp) :: i, j + integer(${ik}$) :: i, j real(dp) :: 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))). @@ -44374,14 +44377,14 @@ module stdlib_linalg_lapack_z do j = 1, n do i = 1, min( m, j-1 ) sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( 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_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do end do end if @@ -44391,14 +44394,14 @@ module stdlib_linalg_lapack_z do j = 1, n do i = 1, min( m, j ) sum = abs( a( i, j ) ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( 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_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do end do end if @@ -44420,7 +44423,7 @@ module stdlib_linalg_lapack_z sum = sum + abs( a( i, j ) ) end do end if - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do else do j = 1, n @@ -44435,7 +44438,7 @@ module stdlib_linalg_lapack_z sum = sum + abs( a( i, j ) ) end do end if - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do end if else if( stdlib_lsame( norm, 'I' ) ) then @@ -44487,7 +44490,7 @@ module stdlib_linalg_lapack_z value = zero do i = 1, m sum = work( i ) - if( value < sum .or. stdlib_disnan( sum ) ) value = sum + if( value < sum .or. stdlib${ii}$_disnan( sum ) ) value = sum end do else if( ( stdlib_lsame( norm, 'F' ) ) .or. ( stdlib_lsame( norm, 'E' ) ) ) & then @@ -44497,13 +44500,13 @@ module stdlib_linalg_lapack_z scale = one sum = min( m, n ) do j = 2, n - call stdlib_zlassq( min( m, j-1 ), a( 1, j ), 1, scale, sum ) + call stdlib${ii}$_zlassq( 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_zlassq( min( m, j ), a( 1, j ), 1, scale, sum ) + call stdlib${ii}$_zlassq( min( m, j ), a( 1_${ik}$, j ), 1_${ik}$, scale, sum ) end do end if else @@ -44511,24 +44514,24 @@ module stdlib_linalg_lapack_z scale = one sum = min( m, n ) do j = 1, n - call stdlib_zlassq( m-j, a( min( m, j+1 ), j ), 1, scale,sum ) + call stdlib${ii}$_zlassq( 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_zlassq( m-j+1, a( j, j ), 1, scale, sum ) + call stdlib${ii}$_zlassq( m-j+1, a( j, j ), 1_${ik}$, scale, sum ) end do end if end if value = scale*sqrt( sum ) end if - stdlib_zlantr = value + stdlib${ii}$_zlantr = value return - end function stdlib_zlantr + end function stdlib${ii}$_zlantr - pure subroutine stdlib_zlapll( n, x, incx, y, incy, ssmin ) + pure subroutine stdlib${ii}$_zlapll( n, x, incx, y, incy, ssmin ) !! Given two column vectors X and Y, let !! A = ( X Y ). !! The subroutine first computes the QR factorization of A = Q*R, @@ -44539,7 +44542,7 @@ module stdlib_linalg_lapack_z ! -- 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, incy, n + integer(${ik}$), intent(in) :: incx, incy, n real(dp), intent(out) :: ssmin ! Array Arguments complex(dp), intent(inout) :: x(*), y(*) @@ -44553,26 +44556,26 @@ module stdlib_linalg_lapack_z intrinsic :: abs,conjg ! Executable Statements ! quick return if possible - if( n<=1 ) then + if( n<=1_${ik}$ ) then ssmin = zero return end if ! compute the qr factorization of the n-by-2 matrix ( x y ) - call stdlib_zlarfg( n, x( 1 ), x( 1+incx ), incx, tau ) - a11 = x( 1 ) - x( 1 ) = cone - c = -conjg( tau )*stdlib_zdotc( n, x, incx, y, incy ) - call stdlib_zaxpy( n, c, x, incx, y, incy ) - call stdlib_zlarfg( n-1, y( 1+incy ), y( 1+2*incy ), incy, tau ) - a12 = y( 1 ) - a22 = y( 1+incy ) + call stdlib${ii}$_zlarfg( n, x( 1_${ik}$ ), x( 1_${ik}$+incx ), incx, tau ) + a11 = x( 1_${ik}$ ) + x( 1_${ik}$ ) = cone + c = -conjg( tau )*stdlib${ii}$_zdotc( n, x, incx, y, incy ) + call stdlib${ii}$_zaxpy( n, c, x, incx, y, incy ) + call stdlib${ii}$_zlarfg( n-1, y( 1_${ik}$+incy ), y( 1_${ik}$+2*incy ), incy, tau ) + a12 = y( 1_${ik}$ ) + a22 = y( 1_${ik}$+incy ) ! compute the svd of 2-by-2 upper triangular matrix. - call stdlib_dlas2( abs( a11 ), abs( a12 ), abs( a22 ), ssmin, ssmax ) + call stdlib${ii}$_dlas2( abs( a11 ), abs( a12 ), abs( a22 ), ssmin, ssmax ) return - end subroutine stdlib_zlapll + end subroutine stdlib${ii}$_zlapll - pure subroutine stdlib_zlaqp2( m, n, offset, a, lda, jpvt, tau, vn1, vn2,work ) + pure subroutine stdlib${ii}$_zlaqp2( m, n, offset, a, lda, jpvt, tau, vn1, vn2,work ) !! ZLAQP2 computes a QR factorization with column pivoting of !! the block A(OFFSET+1:M,1:N). !! The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. @@ -44580,9 +44583,9 @@ module stdlib_linalg_lapack_z ! -- 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, m, n, offset + integer(${ik}$), intent(in) :: lda, m, n, offset ! Array Arguments - integer(ilp), intent(inout) :: jpvt(*) + integer(${ik}$), intent(inout) :: jpvt(*) real(dp), intent(inout) :: vn1(*), vn2(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: tau(*), work(*) @@ -44590,21 +44593,21 @@ module stdlib_linalg_lapack_z ! Local Scalars - integer(ilp) :: i, itemp, j, mn, offpi, pvt + integer(${ik}$) :: i, itemp, j, mn, offpi, pvt real(dp) :: temp, temp2, tol3z complex(dp) :: aii ! Intrinsic Functions intrinsic :: abs,conjg,max,min,sqrt ! Executable Statements mn = min( m-offset, n ) - tol3z = sqrt(stdlib_dlamch('EPSILON')) + tol3z = sqrt(stdlib${ii}$_dlamch('EPSILON')) ! compute factorization. loop_20: do i = 1, mn offpi = offset + i ! determine ith pivot column and swap if necessary. - pvt = ( i-1 ) + stdlib_idamax( n-i+1, vn1( i ), 1 ) + pvt = ( i-1 ) + stdlib${ii}$_idamax( n-i+1, vn1( i ), 1_${ik}$ ) if( pvt/=i ) then - call stdlib_zswap( m, a( 1, pvt ), 1, a( 1, i ), 1 ) + call stdlib${ii}$_zswap( m, a( 1_${ik}$, pvt ), 1_${ik}$, a( 1_${ik}$, i ), 1_${ik}$ ) itemp = jpvt( pvt ) jpvt( pvt ) = jpvt( i ) jpvt( i ) = itemp @@ -44613,17 +44616,17 @@ module stdlib_linalg_lapack_z end if ! generate elementary reflector h(i). if( offpi1 ) then + if( k>1_${ik}$ ) then do j = 1, k - 1 f( k, j ) = conjg( f( k, j ) ) end do - call stdlib_zgemv( 'NO TRANSPOSE', m-rk+1, k-1, -cone, a( rk, 1 ),lda, f( k, 1 ),& - ldf, cone, a( rk, k ), 1 ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', m-rk+1, k-1, -cone, a( rk, 1_${ik}$ ),lda, f( k, 1_${ik}$ ),& + ldf, cone, a( rk, k ), 1_${ik}$ ) do j = 1, k - 1 f( k, j ) = conjg( f( k, j ) ) end do end if ! generate elementary reflector h(k). if( rk1 ) then - call stdlib_zgemv( 'CONJUGATE TRANSPOSE', m-rk+1, k-1, -tau( k ),a( rk, 1 ), lda,& - a( rk, k ), 1, czero,auxv( 1 ), 1 ) - call stdlib_zgemv( 'NO TRANSPOSE', n, k-1, cone, f( 1, 1 ), ldf,auxv( 1 ), 1, & - cone, f( 1, k ), 1 ) + if( k>1_${ik}$ ) then + call stdlib${ii}$_zgemv( 'CONJUGATE TRANSPOSE', m-rk+1, k-1, -tau( k ),a( rk, 1_${ik}$ ), lda,& + a( rk, k ), 1_${ik}$, czero,auxv( 1_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n, k-1, cone, f( 1_${ik}$, 1_${ik}$ ), ldf,auxv( 1_${ik}$ ), 1_${ik}$, & + cone, f( 1_${ik}$, k ), 1_${ik}$ ) end if ! update the current row of a: ! a(rk,k+1:n) := a(rk,k+1:n) - a(rk,1:k)*f(k+1:n,1:k)**h. if( k0 ) then - itemp = nint( vn2( lsticc ),KIND=ilp) - vn1( lsticc ) = stdlib_dznrm2( m-rk, a( rk+1, lsticc ), 1 ) + if( lsticc>0_${ik}$ ) then + itemp = nint( vn2( lsticc ),KIND=${ik}$) + vn1( lsticc ) = stdlib${ii}$_dznrm2( m-rk, a( rk+1, lsticc ), 1_${ik}$ ) ! note: the computation of vn1( lsticc ) relies on the fact that - ! stdlib_snrm2 does not fail on vectors with norm below the value of - ! sqrt(stdlib_dlamch('s')) + ! stdlib${ii}$_snrm2 does not fail on vectors with norm below the value of + ! sqrt(stdlib${ii}$_dlamch('s')) vn2( lsticc ) = vn1( lsticc ) lsticc = itemp go to 60 end if return - end subroutine stdlib_zlaqps + end subroutine stdlib${ii}$_zlaqps - pure subroutine stdlib_zlaqr5( wantt, wantz, kacc22, n, ktop, kbot, nshfts, s,h, ldh, iloz, & + pure subroutine stdlib${ii}$_zlaqr5( wantt, wantz, kacc22, n, ktop, kbot, nshfts, s,h, ldh, iloz, & !! ZLAQR5 , called by ZLAQR0, performs a !! single small-bulge multi-shift QR sweep. ihiz, z, ldz, v, ldv, u, ldu, nv,wv, ldwv, nh, wh, ldwh ) @@ -44803,7 +44806,7 @@ module stdlib_linalg_lapack_z ! -- 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) :: ihiz, iloz, kacc22, kbot, ktop, ldh, ldu, ldv, ldwh, ldwv, & + integer(${ik}$), intent(in) :: ihiz, iloz, kacc22, kbot, ktop, ldh, ldu, ldv, ldwh, ldwv, & ldz, n, nh, nshfts, nv logical(lk), intent(in) :: wantt, wantz ! Array Arguments @@ -44818,13 +44821,13 @@ module stdlib_linalg_lapack_z ! Local Scalars complex(dp) :: alpha, beta, cdum, refsum real(dp) :: h11, h12, h21, h22, safmax, safmin, scl, smlnum, tst1, tst2, ulp - integer(ilp) :: i2, i4, incol, j, jbot, jcol, jlen, jrow, jtop, k, k1, kdu, kms, krcol,& + integer(${ik}$) :: i2, i4, incol, j, jbot, jcol, jlen, jrow, jtop, k, k1, kdu, kms, krcol,& m, m22, mbot, mtop, nbmps, ndcol, ns, nu logical(lk) :: accum, bmp22 ! Intrinsic Functions intrinsic :: abs,real,conjg,aimag,max,min,mod ! Local Arrays - complex(dp) :: vt(3) + complex(dp) :: vt(3_${ik}$) ! Statement Functions real(dp) :: cabs1 ! Statement Function Definitions @@ -44837,34 +44840,34 @@ module stdlib_linalg_lapack_z if( ktop>=kbot )return ! ==== nshfts is supposed to be even, but if it is odd, ! . then simply reduce it by cone. ==== - ns = nshfts - mod( nshfts, 2 ) + ns = nshfts - mod( nshfts, 2_${ik}$ ) ! ==== machine constants for deflation ==== - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) safmax = rone / safmin - call stdlib_dlabad( safmin, safmax ) - ulp = stdlib_dlamch( 'PRECISION' ) + call stdlib${ii}$_dlabad( safmin, safmax ) + ulp = stdlib${ii}$_dlamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=dp) / ulp ) ! ==== use accumulated reflections to update far-from-diagonal ! . entries ? ==== - accum = ( kacc22==1 ) .or. ( kacc22==2 ) + accum = ( kacc22==1_${ik}$ ) .or. ( kacc22==2_${ik}$ ) ! ==== clear trash ==== if( ktop+2<=kbot )h( ktop+2, ktop ) = czero ! ==== nbmps = number of 2-shift bulges in the chain ==== - nbmps = ns / 2 + nbmps = ns / 2_${ik}$ ! ==== kdu = width of slab ==== - kdu = 4*nbmps + kdu = 4_${ik}$*nbmps ! ==== create and chase chains of nbmps bulges ==== loop_180: do incol = ktop - 2*nbmps + 1, kbot - 2, 2*nbmps ! jtop = index from which updates from the right start. if( accum ) then jtop = max( ktop, incol ) else if( wantt ) then - jtop = 1 + jtop = 1_${ik}$ else jtop = ktop end if ndcol = incol + kdu - if( accum )call stdlib_zlaset( 'ALL', kdu, kdu, czero, cone, u, ldu ) + if( accum )call stdlib${ii}$_zlaset( 'ALL', kdu, kdu, czero, cone, u, ldu ) ! ==== near-the-diagonal bulge chase. the following loop ! . performs the near-the-diagonal part of a small bulge ! . multi-shift qr sweep. each 4*nbmps column diagonal @@ -44883,34 +44886,34 @@ module stdlib_linalg_lapack_z ! . (if any) must wait until the active bulges have moved ! . down the diagonal to make room. the phantom matrix ! . paradigm described above helps keep track. ==== - mtop = max( 1, ( ktop-krcol ) / 2+1 ) - mbot = min( nbmps, ( kbot-krcol-1 ) / 2 ) - m22 = mbot + 1 + mtop = max( 1_${ik}$, ( ktop-krcol ) / 2_${ik}$+1 ) + mbot = min( nbmps, ( kbot-krcol-1 ) / 2_${ik}$ ) + m22 = mbot + 1_${ik}$ bmp22 = ( mbotulp*( & + if( cabs1( h( k+2, k )-refsum*vt( 2_${ik}$ ) )+cabs1( refsum*vt( 3_${ik}$ ) )>ulp*( & cabs1( h( k, k ) )+cabs1( h( k+1,k+1 ) )+cabs1( h( k+2, k+2 ) ) ) ) & then ! ==== starting a new bulge here would @@ -45037,9 +45040,9 @@ module stdlib_linalg_lapack_z h( k+1, k ) = h( k+1, k ) - refsum h( k+2, k ) = czero h( k+3, k ) = czero - v( 1, m ) = vt( 1 ) - v( 2, m ) = vt( 2 ) - v( 3, m ) = vt( 3 ) + v( 1_${ik}$, m ) = vt( 1_${ik}$ ) + v( 2_${ik}$, m ) = vt( 2_${ik}$ ) + v( 3_${ik}$, m ) = vt( 3_${ik}$ ) end if end if end if @@ -45049,19 +45052,19 @@ module stdlib_linalg_lapack_z ! . deflation check. we still delay most of the ! . updates from the left for efficiency. ==== do j = jtop, min( kbot, k+3 ) - refsum = v( 1, m )*( h( j, k+1 )+v( 2, m )*h( j, k+2 )+v( 3, m )*h( j, k+3 & + refsum = v( 1_${ik}$, m )*( h( j, k+1 )+v( 2_${ik}$, m )*h( j, k+2 )+v( 3_${ik}$, m )*h( j, k+3 & ) ) h( j, k+1 ) = h( j, k+1 ) - refsum - h( j, k+2 ) = h( j, k+2 ) -refsum*conjg( v( 2, m ) ) - h( j, k+3 ) = h( j, k+3 ) -refsum*conjg( v( 3, m ) ) + h( j, k+2 ) = h( j, k+2 ) -refsum*conjg( v( 2_${ik}$, m ) ) + h( j, k+3 ) = h( j, k+3 ) -refsum*conjg( v( 3_${ik}$, m ) ) end do ! ==== perform update from left for subsequent ! . column. ==== - refsum = conjg( v( 1, m ) )*( h( k+1, k+1 )+conjg( v( 2, m ) )*h( k+2, k+1 )+& - conjg( v( 3, m ) )*h( k+3, k+1 ) ) + refsum = conjg( v( 1_${ik}$, m ) )*( h( k+1, k+1 )+conjg( v( 2_${ik}$, m ) )*h( k+2, k+1 )+& + conjg( v( 3_${ik}$, m ) )*h( k+3, k+1 ) ) h( k+1, k+1 ) = h( k+1, k+1 ) - refsum - h( k+2, k+1 ) = h( k+2, k+1 ) - refsum*v( 2, m ) - h( k+3, k+1 ) = h( k+3, k+1 ) - refsum*v( 3, m ) + h( k+2, k+1 ) = h( k+2, k+1 ) - refsum*v( 2_${ik}$, m ) + h( k+3, k+1 ) = h( k+3, k+1 ) - refsum*v( 3_${ik}$, m ) ! ==== the following convergence test requires that ! . the tradition small-compared-to-nearby-diagonals ! . criterion and the ahues @@ -45104,13 +45107,13 @@ module stdlib_linalg_lapack_z jbot = kbot end if do m = mbot, mtop, -1 - k = krcol + 2*( m-1 ) + k = krcol + 2_${ik}$*( m-1 ) do j = max( ktop, krcol + 2*m ), jbot - refsum = conjg( v( 1, m ) )*( h( k+1, j )+conjg( v( 2, m ) )*h( k+2, j )+& - conjg( v( 3, m ) )*h( k+3, j ) ) + refsum = conjg( v( 1_${ik}$, m ) )*( h( k+1, j )+conjg( v( 2_${ik}$, m ) )*h( k+2, j )+& + conjg( v( 3_${ik}$, m ) )*h( k+3, j ) ) h( k+1, j ) = h( k+1, j ) - refsum - h( k+2, j ) = h( k+2, j ) - refsum*v( 2, m ) - h( k+3, j ) = h( k+3, j ) - refsum*v( 3, m ) + h( k+2, j ) = h( k+2, j ) - refsum*v( 2_${ik}$, m ) + h( k+3, j ) = h( k+3, j ) - refsum*v( 3_${ik}$, m ) end do end do ! ==== accumulate orthogonal transformations. ==== @@ -45119,17 +45122,17 @@ module stdlib_linalg_lapack_z ! . with an efficient matrix-matrix ! . multiply.) ==== do m = mbot, mtop, -1 - k = krcol + 2*( m-1 ) + k = krcol + 2_${ik}$*( m-1 ) kms = k - incol - i2 = max( 1, ktop-incol ) - i2 = max( i2, kms-(krcol-incol)+1 ) - i4 = min( kdu, krcol + 2*( mbot-1 ) - incol + 5 ) + i2 = max( 1_${ik}$, ktop-incol ) + i2 = max( i2, kms-(krcol-incol)+1_${ik}$ ) + i4 = min( kdu, krcol + 2_${ik}$*( mbot-1 ) - incol + 5_${ik}$ ) do j = i2, i4 - refsum = v( 1, m )*( u( j, kms+1 )+v( 2, m )*u( j, kms+2 )+v( 3, m )*u( & + refsum = v( 1_${ik}$, m )*( u( j, kms+1 )+v( 2_${ik}$, m )*u( j, kms+2 )+v( 3_${ik}$, m )*u( & j, kms+3 ) ) u( j, kms+1 ) = u( j, kms+1 ) - refsum - u( j, kms+2 ) = u( j, kms+2 ) -refsum*conjg( v( 2, m ) ) - u( j, kms+3 ) = u( j, kms+3 ) -refsum*conjg( v( 3, m ) ) + u( j, kms+2 ) = u( j, kms+2 ) -refsum*conjg( v( 2_${ik}$, m ) ) + u( j, kms+3 ) = u( j, kms+3 ) -refsum*conjg( v( 3_${ik}$, m ) ) end do end do else if( wantz ) then @@ -45137,13 +45140,13 @@ module stdlib_linalg_lapack_z ! . now by multiplying by reflections ! . from the right. ==== do m = mbot, mtop, -1 - k = krcol + 2*( m-1 ) + k = krcol + 2_${ik}$*( m-1 ) do j = iloz, ihiz - refsum = v( 1, m )*( z( j, k+1 )+v( 2, m )*z( j, k+2 )+v( 3, m )*z( j, & + refsum = v( 1_${ik}$, m )*( z( j, k+1 )+v( 2_${ik}$, m )*z( j, k+2 )+v( 3_${ik}$, m )*z( j, & k+3 ) ) z( j, k+1 ) = z( j, k+1 ) - refsum - z( j, k+2 ) = z( j, k+2 ) -refsum*conjg( v( 2, m ) ) - z( j, k+3 ) = z( j, k+3 ) -refsum*conjg( v( 3, m ) ) + z( j, k+2 ) = z( j, k+2 ) -refsum*conjg( v( 2_${ik}$, m ) ) + z( j, k+3 ) = z( j, k+3 ) -refsum*conjg( v( 3_${ik}$, m ) ) end do end do end if @@ -45154,51 +45157,51 @@ module stdlib_linalg_lapack_z ! . well. ==== if( accum ) then if( wantt ) then - jtop = 1 + jtop = 1_${ik}$ jbot = n else jtop = ktop jbot = kbot end if - k1 = max( 1, ktop-incol ) - nu = ( kdu-max( 0, ndcol-kbot ) ) - k1 + 1 + k1 = max( 1_${ik}$, ktop-incol ) + nu = ( kdu-max( 0_${ik}$, ndcol-kbot ) ) - k1 + 1_${ik}$ ! ==== horizontal multiply ==== do jcol = min( ndcol, kbot ) + 1, jbot, nh jlen = min( nh, jbot-jcol+1 ) - call stdlib_zgemm( 'C', 'N', nu, jlen, nu, cone, u( k1, k1 ),ldu, h( incol+k1,& + call stdlib${ii}$_zgemm( 'C', 'N', nu, jlen, nu, cone, u( k1, k1 ),ldu, h( incol+k1,& jcol ), ldh, czero, wh,ldwh ) - call stdlib_zlacpy( 'ALL', nu, jlen, wh, ldwh,h( incol+k1, jcol ), ldh ) + call stdlib${ii}$_zlacpy( 'ALL', nu, jlen, wh, ldwh,h( incol+k1, jcol ), ldh ) end do ! ==== vertical multiply ==== do jrow = jtop, max( ktop, incol ) - 1, nv jlen = min( nv, max( ktop, incol )-jrow ) - call stdlib_zgemm( 'N', 'N', jlen, nu, nu, cone,h( jrow, incol+k1 ), ldh, u( & + call stdlib${ii}$_zgemm( 'N', 'N', jlen, nu, nu, cone,h( jrow, incol+k1 ), ldh, u( & k1, k1 ),ldu, czero, wv, ldwv ) - call stdlib_zlacpy( 'ALL', jlen, nu, wv, ldwv,h( jrow, incol+k1 ), ldh ) + call stdlib${ii}$_zlacpy( 'ALL', jlen, nu, wv, ldwv,h( jrow, incol+k1 ), ldh ) end do ! ==== z multiply (also vertical) ==== if( wantz ) then do jrow = iloz, ihiz, nv jlen = min( nv, ihiz-jrow+1 ) - call stdlib_zgemm( 'N', 'N', jlen, nu, nu, cone,z( jrow, incol+k1 ), ldz, & + call stdlib${ii}$_zgemm( 'N', 'N', jlen, nu, nu, cone,z( jrow, incol+k1 ), ldz, & u( k1, k1 ),ldu, czero, wv, ldwv ) - call stdlib_zlacpy( 'ALL', jlen, nu, wv, ldwv,z( jrow, incol+k1 ), ldz ) + call stdlib${ii}$_zlacpy( 'ALL', jlen, nu, wv, ldwv,z( jrow, incol+k1 ), ldz ) end do end if end if end do loop_180 - end subroutine stdlib_zlaqr5 + end subroutine stdlib${ii}$_zlaqr5 - pure subroutine stdlib_zlaqz1( ilq, ilz, k, istartm, istopm, ihi, a, lda, b,ldb, nq, qstart, & + pure subroutine stdlib${ii}$_zlaqz1( ilq, ilz, k, istartm, istopm, ihi, a, lda, b,ldb, nq, qstart, & !! ZLAQZ1 chases a 1x1 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 complex(dp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) @@ -45208,100 +45211,100 @@ module stdlib_linalg_lapack_z complex(dp) :: s, temp if( k+1 == ihi ) then ! shift is located on the edge of the matrix, remove it - call stdlib_zlartg( b( ihi, ihi ), b( ihi, ihi-1 ), c, s, temp ) + call stdlib${ii}$_zlartg( b( ihi, ihi ), b( ihi, ihi-1 ), c, s, temp ) b( ihi, ihi ) = temp b( ihi, ihi-1 ) = czero - call stdlib_zrot( ihi-istartm, b( istartm, ihi ), 1, b( istartm,ihi-1 ), 1, c, s ) + call stdlib${ii}$_zrot( ihi-istartm, b( istartm, ihi ), 1_${ik}$, b( istartm,ihi-1 ), 1_${ik}$, c, s ) - call stdlib_zrot( ihi-istartm+1, a( istartm, ihi ), 1, a( istartm,ihi-1 ), 1, c, s ) + call stdlib${ii}$_zrot( ihi-istartm+1, a( istartm, ihi ), 1_${ik}$, a( istartm,ihi-1 ), 1_${ik}$, c, s ) if ( ilz ) then - call stdlib_zrot( nz, z( 1, ihi-zstart+1 ), 1, z( 1, ihi-1-zstart+1 ), 1, c, s ) + call stdlib${ii}$_zrot( nz, z( 1_${ik}$, ihi-zstart+1 ), 1_${ik}$, z( 1_${ik}$, ihi-1-zstart+1 ), 1_${ik}$, c, s ) end if else ! normal operation, move bulge down ! apply transformation from the right - call stdlib_zlartg( b( k+1, k+1 ), b( k+1, k ), c, s, temp ) + call stdlib${ii}$_zlartg( b( k+1, k+1 ), b( k+1, k ), c, s, temp ) b( k+1, k+1 ) = temp b( k+1, k ) = czero - call stdlib_zrot( k+2-istartm+1, a( istartm, k+1 ), 1, a( istartm,k ), 1, c, s ) + call stdlib${ii}$_zrot( k+2-istartm+1, a( istartm, k+1 ), 1_${ik}$, a( istartm,k ), 1_${ik}$, c, s ) - call stdlib_zrot( k-istartm+1, b( istartm, k+1 ), 1, b( istartm, k ),1, c, s ) + call stdlib${ii}$_zrot( k-istartm+1, b( istartm, k+1 ), 1_${ik}$, b( istartm, k ),1_${ik}$, c, s ) if ( ilz ) then - call stdlib_zrot( nz, z( 1, k+1-zstart+1 ), 1, z( 1, k-zstart+1 ),1, c, s ) + call stdlib${ii}$_zrot( nz, z( 1_${ik}$, k+1-zstart+1 ), 1_${ik}$, z( 1_${ik}$, k-zstart+1 ),1_${ik}$, c, s ) end if ! apply transformation from the left - call stdlib_zlartg( a( k+1, k ), a( k+2, k ), c, s, temp ) + call stdlib${ii}$_zlartg( a( k+1, k ), a( k+2, k ), c, s, temp ) a( k+1, k ) = temp a( k+2, k ) = czero - call stdlib_zrot( istopm-k, a( k+1, k+1 ), lda, a( k+2, k+1 ), lda, c,s ) - call stdlib_zrot( istopm-k, b( k+1, k+1 ), ldb, b( k+2, k+1 ), ldb, c,s ) + call stdlib${ii}$_zrot( istopm-k, a( k+1, k+1 ), lda, a( k+2, k+1 ), lda, c,s ) + call stdlib${ii}$_zrot( istopm-k, b( k+1, k+1 ), ldb, b( k+2, k+1 ), ldb, c,s ) if ( ilq ) then - call stdlib_zrot( nq, q( 1, k+1-qstart+1 ), 1, q( 1, k+2-qstart+1 ), 1, c, conjg(& + call stdlib${ii}$_zrot( nq, q( 1_${ik}$, k+1-qstart+1 ), 1_${ik}$, q( 1_${ik}$, k+2-qstart+1 ), 1_${ik}$, c, conjg(& s ) ) end if end if - end subroutine stdlib_zlaqz1 + end subroutine stdlib${ii}$_zlaqz1 - pure subroutine stdlib_zlaqz3( ilschur, ilq, ilz, n, ilo, ihi, nshifts,nblock_desired, alpha,& + pure subroutine stdlib${ii}$_zlaqz3( ilschur, ilq, ilz, n, ilo, ihi, nshifts,nblock_desired, alpha,& !! ZLAQZ3 Executes a single multishift QZ sweep beta, a, lda, b, ldb,q, ldq, z, ldz, qc, ldqc, zc, ldzc, work,lwork, info ) ! function arguments logical(lk), intent( in ) :: ilschur, ilq, ilz - integer(ilp), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,nshifts, & + integer(${ik}$), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,nshifts, & nblock_desired, ldqc, ldzc complex(dp), intent( inout ) :: a( lda, * ), b( ldb, * ), q( ldq,* ), z( ldz, * ), qc( & ldqc, * ), zc( ldzc, * ), work( * ),alpha( * ), beta( * ) - 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(dp) :: safmin, safmax, c, scale complex(dp) :: temp, temp2, temp3, s - info = 0 + 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( 'ZLAQZ3', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZLAQZ3', -info ) return end if ! executable statements ! get machine constants - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) safmax = one/safmin - call stdlib_dlabad( safmin, safmax ) + call stdlib${ii}$_dlabad( safmin, safmax ) if ( ilo >= ihi ) then return end if if ( ilschur ) then - istartm = 1 + istartm = 1_${ik}$ istopm = n else istartm = ilo istopm = ihi end if ns = nshifts - npos = max( nblock_desired-ns, 1 ) + 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_zlaset( 'FULL', ns+1, ns+1, czero, cone, qc, ldqc ) - call stdlib_zlaset( 'FULL', ns, ns, czero, cone, zc, ldzc ) + call stdlib${ii}$_zlaset( 'FULL', ns+1, ns+1, czero, cone, qc, ldqc ) + call stdlib${ii}$_zlaset( 'FULL', ns, ns, czero, cone, zc, ldzc ) do i = 1, ns ! introduce the shift scale = sqrt( abs( alpha( i ) ) ) * sqrt( abs( beta( i ) ) ) @@ -45315,54 +45318,54 @@ module stdlib_linalg_lapack_z temp2 = cone temp3 = czero end if - call stdlib_zlartg( temp2, temp3, c, s, temp ) - call stdlib_zrot( ns, a( ilo, ilo ), lda, a( ilo+1, ilo ), lda, c,s ) - call stdlib_zrot( ns, b( ilo, ilo ), ldb, b( ilo+1, ilo ), ldb, c,s ) - call stdlib_zrot( ns+1, qc( 1, 1 ), 1, qc( 1, 2 ), 1, c,conjg( s ) ) + call stdlib${ii}$_zlartg( temp2, temp3, c, s, temp ) + call stdlib${ii}$_zrot( ns, a( ilo, ilo ), lda, a( ilo+1, ilo ), lda, c,s ) + call stdlib${ii}$_zrot( ns, b( ilo, ilo ), ldb, b( ilo+1, ilo ), ldb, c,s ) + call stdlib${ii}$_zrot( ns+1, qc( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, qc( 1_${ik}$, 2_${ik}$ ), 1_${ik}$, c,conjg( s ) ) ! chase the shift down do j = 1, ns-i - call stdlib_zlaqz1( .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}$_zlaqz1( .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)' sheight = ns+1 - swidth = istopm-( ilo+ns )+1 - if ( swidth > 0 ) then - call stdlib_zgemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,a( ilo, ilo+& + swidth = istopm-( ilo+ns )+1_${ik}$ + if ( swidth > 0_${ik}$ ) then + call stdlib${ii}$_zgemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,a( ilo, ilo+& ns ), lda, czero, work, sheight ) - call stdlib_zlacpy( 'ALL', sheight, swidth, work, sheight, a( ilo,ilo+ns ), lda ) + call stdlib${ii}$_zlacpy( 'ALL', sheight, swidth, work, sheight, a( ilo,ilo+ns ), lda ) - call stdlib_zgemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,b( ilo, ilo+& + call stdlib${ii}$_zgemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,b( ilo, ilo+& ns ), ldb, czero, work, sheight ) - call stdlib_zlacpy( 'ALL', sheight, swidth, work, sheight, b( ilo,ilo+ns ), ldb ) + call stdlib${ii}$_zlacpy( 'ALL', sheight, swidth, work, sheight, b( ilo,ilo+ns ), ldb ) end if if ( ilq ) then - call stdlib_zgemm( 'N', 'N', n, sheight, sheight, cone, q( 1, ilo ),ldq, qc, ldqc, & + call stdlib${ii}$_zgemm( 'N', 'N', n, sheight, sheight, cone, q( 1_${ik}$, ilo ),ldq, qc, ldqc, & czero, work, n ) - call stdlib_zlacpy( 'ALL', n, sheight, work, n, q( 1, ilo ), ldq ) + call stdlib${ii}$_zlacpy( '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) sheight = ilo-1-istartm+1 swidth = ns - if ( sheight > 0 ) then - call stdlib_zgemm( 'N', 'N', sheight, swidth, swidth, cone,a( istartm, ilo ), lda, & + if ( sheight > 0_${ik}$ ) then + call stdlib${ii}$_zgemm( 'N', 'N', sheight, swidth, swidth, cone,a( istartm, ilo ), lda, & zc, ldzc, czero, work,sheight ) - call stdlib_zlacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ilo ), lda ) + call stdlib${ii}$_zlacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ilo ), lda ) - call stdlib_zgemm( 'N', 'N', sheight, swidth, swidth, cone,b( istartm, ilo ), ldb, & + call stdlib${ii}$_zgemm( 'N', 'N', sheight, swidth, swidth, cone,b( istartm, ilo ), ldb, & zc, ldzc, czero, work,sheight ) - call stdlib_zlacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ilo ), ldb ) + call stdlib${ii}$_zlacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ilo ), ldb ) end if if ( ilz ) then - call stdlib_zgemm( 'N', 'N', n, swidth, swidth, cone, z( 1, ilo ),ldz, zc, ldzc, & + call stdlib${ii}$_zgemm( 'N', 'N', n, swidth, swidth, cone, z( 1_${ik}$, ilo ),ldz, zc, ldzc, & czero, work, n ) - call stdlib_zlacpy( 'ALL', n, swidth, work, n, z( 1, ilo ), ldz ) + call stdlib${ii}$_zlacpy( '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 @@ -45376,15 +45379,15 @@ module stdlib_linalg_lapack_z istartb = k+1 ! istopb points to the last column we will be updating istopb = k+nblock-1 - call stdlib_zlaset( 'FULL', ns+np, ns+np, czero, cone, qc, ldqc ) - call stdlib_zlaset( 'FULL', ns+np, ns+np, czero, cone, zc, ldzc ) + call stdlib${ii}$_zlaset( 'FULL', ns+np, ns+np, czero, cone, qc, ldqc ) + call stdlib${ii}$_zlaset( 'FULL', ns+np, ns+np, czero, cone, zc, ldzc ) ! near the diagonal shift chase do i = ns-1, 0, -1 do j = 0, np-1 ! move down the block with index k+i+j, updating ! the (ns+np x ns+np) block: ! (k:k+ns+np,k:k+ns+np-1) - call stdlib_zlaqz1( .true., .true., k+i+j, istartb, istopb, ihi,a, lda, b, & + call stdlib${ii}$_zlaqz1( .true., .true., k+i+j, istartb, istopb, ihi,a, lda, b, & ldb, nblock, k+1, qc, ldqc,nblock, k, zc, ldzc ) end do end do @@ -45393,47 +45396,47 @@ module stdlib_linalg_lapack_z ! b(k+1:k+ns+np, k+ns+np:istopm) ! from the left with qc(1:ns+np,1:ns+np)' sheight = ns+np - swidth = istopm-( k+ns+np )+1 - if ( swidth > 0 ) then - call stdlib_zgemm( 'C', 'N', sheight, swidth, sheight, cone, qc,ldqc, a( k+1, k+& + swidth = istopm-( k+ns+np )+1_${ik}$ + if ( swidth > 0_${ik}$ ) then + call stdlib${ii}$_zgemm( 'C', 'N', sheight, swidth, sheight, cone, qc,ldqc, a( k+1, k+& ns+np ), lda, czero, work,sheight ) - call stdlib_zlacpy( 'ALL', sheight, swidth, work, sheight, a( k+1,k+ns+np ), lda & + call stdlib${ii}$_zlacpy( 'ALL', sheight, swidth, work, sheight, a( k+1,k+ns+np ), lda & ) - call stdlib_zgemm( 'C', 'N', sheight, swidth, sheight, cone, qc,ldqc, b( k+1, k+& + call stdlib${ii}$_zgemm( 'C', 'N', sheight, swidth, sheight, cone, qc,ldqc, b( k+1, k+& ns+np ), ldb, czero, work,sheight ) - call stdlib_zlacpy( 'ALL', sheight, swidth, work, sheight, b( k+1,k+ns+np ), ldb & + call stdlib${ii}$_zlacpy( 'ALL', sheight, swidth, work, sheight, b( k+1,k+ns+np ), ldb & ) end if if ( ilq ) then - call stdlib_zgemm( 'N', 'N', n, nblock, nblock, cone, q( 1, k+1 ),ldq, qc, ldqc, & + call stdlib${ii}$_zgemm( 'N', 'N', n, nblock, nblock, cone, q( 1_${ik}$, k+1 ),ldq, qc, ldqc, & czero, work, n ) - call stdlib_zlacpy( 'ALL', n, nblock, work, n, q( 1, k+1 ), ldq ) + call stdlib${ii}$_zlacpy( '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) sheight = k-istartm+1 swidth = nblock - if ( sheight > 0 ) then - call stdlib_zgemm( 'N', 'N', sheight, swidth, swidth, cone,a( istartm, k ), lda, & + if ( sheight > 0_${ik}$ ) then + call stdlib${ii}$_zgemm( 'N', 'N', sheight, swidth, swidth, cone,a( istartm, k ), lda, & zc, ldzc, czero, work,sheight ) - call stdlib_zlacpy( 'ALL', sheight, swidth, work, sheight,a( istartm, k ), lda ) + call stdlib${ii}$_zlacpy( 'ALL', sheight, swidth, work, sheight,a( istartm, k ), lda ) - call stdlib_zgemm( 'N', 'N', sheight, swidth, swidth, cone,b( istartm, k ), ldb, & + call stdlib${ii}$_zgemm( 'N', 'N', sheight, swidth, swidth, cone,b( istartm, k ), ldb, & zc, ldzc, czero, work,sheight ) - call stdlib_zlacpy( 'ALL', sheight, swidth, work, sheight,b( istartm, k ), ldb ) + call stdlib${ii}$_zlacpy( 'ALL', sheight, swidth, work, sheight,b( istartm, k ), ldb ) end if if ( ilz ) then - call stdlib_zgemm( 'N', 'N', n, nblock, nblock, cone, z( 1, k ),ldz, zc, ldzc, & + call stdlib${ii}$_zgemm( 'N', 'N', n, nblock, nblock, cone, z( 1_${ik}$, k ),ldz, zc, ldzc, & czero, work, n ) - call stdlib_zlacpy( 'ALL', n, nblock, work, n, z( 1, k ), ldz ) + call stdlib${ii}$_zlacpy( '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_zlaset( 'FULL', ns, ns, czero, cone, qc, ldqc ) - call stdlib_zlaset( 'FULL', ns+1, ns+1, czero, cone, zc, ldzc ) + call stdlib${ii}$_zlaset( 'FULL', ns, ns, czero, cone, qc, ldqc ) + call stdlib${ii}$_zlaset( 'FULL', ns+1, ns+1, czero, cone, zc, ldzc ) ! istartb points to the first row we will be updating istartb = ihi-ns+1 ! istopb points to the last column we will be updating @@ -45441,7 +45444,7 @@ module stdlib_linalg_lapack_z do i = 1, ns ! chase the shift down to the bottom right corner do ishift = ihi-i, ihi-1 - call stdlib_zlaqz1( .true., .true., ishift, istartb, istopb, ihi,a, lda, b, ldb, & + call stdlib${ii}$_zlaqz1( .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 @@ -45449,45 +45452,45 @@ module stdlib_linalg_lapack_z ! update a(ihi-ns+1:ihi, ihi+1:istopm) ! from the left with qc(1:ns,1:ns)' sheight = ns - swidth = istopm-( ihi+1 )+1 - if ( swidth > 0 ) then - call stdlib_zgemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,a( ihi-ns+1, & + swidth = istopm-( ihi+1 )+1_${ik}$ + if ( swidth > 0_${ik}$ ) then + call stdlib${ii}$_zgemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,a( ihi-ns+1, & ihi+1 ), lda, czero, work, sheight ) - call stdlib_zlacpy( 'ALL', sheight, swidth, work, sheight,a( ihi-ns+1, ihi+1 ), lda & + call stdlib${ii}$_zlacpy( 'ALL', sheight, swidth, work, sheight,a( ihi-ns+1, ihi+1 ), lda & ) - call stdlib_zgemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,b( ihi-ns+1, & + call stdlib${ii}$_zgemm( 'C', 'N', sheight, swidth, sheight, cone, qc, ldqc,b( ihi-ns+1, & ihi+1 ), ldb, czero, work, sheight ) - call stdlib_zlacpy( 'ALL', sheight, swidth, work, sheight,b( ihi-ns+1, ihi+1 ), ldb & + call stdlib${ii}$_zlacpy( 'ALL', sheight, swidth, work, sheight,b( ihi-ns+1, ihi+1 ), ldb & ) end if if ( ilq ) then - call stdlib_zgemm( 'N', 'N', n, ns, ns, cone, q( 1, ihi-ns+1 ), ldq,qc, ldqc, czero,& + call stdlib${ii}$_zgemm( 'N', 'N', n, ns, ns, cone, q( 1_${ik}$, ihi-ns+1 ), ldq,qc, ldqc, czero,& work, n ) - call stdlib_zlacpy( 'ALL', n, ns, work, n, q( 1, ihi-ns+1 ), ldq ) + call stdlib${ii}$_zlacpy( '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) sheight = ihi-ns-istartm+1 swidth = ns+1 - if ( sheight > 0 ) then - call stdlib_zgemm( 'N', 'N', sheight, swidth, swidth, cone,a( istartm, ihi-ns ), & + if ( sheight > 0_${ik}$ ) then + call stdlib${ii}$_zgemm( 'N', 'N', sheight, swidth, swidth, cone,a( istartm, ihi-ns ), & lda, zc, ldzc, czero, work,sheight ) - call stdlib_zlacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ihi-ns ), lda & + call stdlib${ii}$_zlacpy( 'ALL', sheight, swidth, work, sheight, a( istartm,ihi-ns ), lda & ) - call stdlib_zgemm( 'N', 'N', sheight, swidth, swidth, cone,b( istartm, ihi-ns ), & + call stdlib${ii}$_zgemm( 'N', 'N', sheight, swidth, swidth, cone,b( istartm, ihi-ns ), & ldb, zc, ldzc, czero, work,sheight ) - call stdlib_zlacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ihi-ns ), ldb & + call stdlib${ii}$_zlacpy( 'ALL', sheight, swidth, work, sheight, b( istartm,ihi-ns ), ldb & ) end if if ( ilz ) then - call stdlib_zgemm( 'N', 'N', n, ns+1, ns+1, cone, z( 1, ihi-ns ), ldz,zc, ldzc, & + call stdlib${ii}$_zgemm( 'N', 'N', n, ns+1, ns+1, cone, z( 1_${ik}$, ihi-ns ), ldz,zc, ldzc, & czero, work, n ) - call stdlib_zlacpy( 'ALL', n, ns+1, work, n, z( 1, ihi-ns ), ldz ) + call stdlib${ii}$_zlacpy( 'ALL', n, ns+1, work, n, z( 1_${ik}$, ihi-ns ), ldz ) end if - end subroutine stdlib_zlaqz3 + end subroutine stdlib${ii}$_zlaqz3 - pure subroutine stdlib_zlargv( n, x, incx, y, incy, c, incc ) + pure subroutine stdlib${ii}$_zlargv( n, x, incx, y, incy, c, incc ) !! ZLARGV generates a vector of complex plane rotations with real !! cosines, determined by elements of the complex vectors x and y. !! For i = 1,2,...,n @@ -45502,7 +45505,7 @@ module stdlib_linalg_lapack_z ! -- 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(dp), intent(out) :: c(*) complex(dp), intent(inout) :: x(*), y(*) @@ -45511,7 +45514,7 @@ module stdlib_linalg_lapack_z ! Local Scalars ! logical first - integer(ilp) :: count, i, ic, ix, iy, j + integer(${ik}$) :: count, i, ic, ix, iy, j real(dp) :: cs, d, di, dr, eps, f2, f2s, g2, g2s, safmin, safmn2, safmx2, scale complex(dp) :: f, ff, fs, g, gs, r, sn ! Intrinsic Functions @@ -45524,30 +45527,30 @@ module stdlib_linalg_lapack_z ! data first / .true. / ! Statement Function Definitions abs1( ff ) = max( abs( real( ff,KIND=dp) ), abs( aimag( ff ) ) ) - abssq( ff ) = real( ff,KIND=dp)**2 + aimag( ff )**2 + abssq( ff ) = real( ff,KIND=dp)**2_${ik}$ + aimag( ff )**2_${ik}$ ! Executable Statements ! if( first ) then ! first = .false. - safmin = stdlib_dlamch( 'S' ) - eps = stdlib_dlamch( 'E' ) - safmn2 = stdlib_dlamch( 'B' )**int( log( safmin / eps ) /log( stdlib_dlamch( 'B' ) )& - / two,KIND=ilp) + safmin = stdlib${ii}$_dlamch( 'S' ) + eps = stdlib${ii}$_dlamch( 'E' ) + safmn2 = stdlib${ii}$_dlamch( 'B' )**int( log( safmin / eps ) /log( stdlib${ii}$_dlamch( 'B' ) )& + / two,KIND=${ik}$) safmx2 = one / safmn2 ! end if - ix = 1 - iy = 1 - ic = 1 + ix = 1_${ik}$ + iy = 1_${ik}$ + ic = 1_${ik}$ loop_60: do i = 1, n f = x( ix ) g = y( iy ) - ! use identical algorithm as in stdlib_zlartg + ! use identical algorithm as in stdlib${ii}$_zlartg scale = max( abs1( f ), abs1( g ) ) fs = f gs = g - count = 0 + count = 0_${ik}$ if( scale>=safmx2 ) then 10 continue - count = count + 1 + count = count + 1_${ik}$ fs = fs*safmn2 gs = gs*safmn2 scale = scale*safmn2 @@ -45560,7 +45563,7 @@ module stdlib_linalg_lapack_z go to 50 end if 20 continue - count = count - 1 + count = count - 1_${ik}$ fs = fs*safmx2 gs = gs*safmx2 scale = scale*safmx2 @@ -45572,14 +45575,14 @@ module stdlib_linalg_lapack_z ! this is a rare case: f is very small. if( f==czero ) then cs = zero - r = stdlib_dlapy2( real( g,KIND=dp), aimag( g ) ) + r = stdlib${ii}$_dlapy2( real( g,KIND=dp), aimag( g ) ) ! do complex/real division explicitly with two real ! divisions - d = stdlib_dlapy2( real( gs,KIND=dp), aimag( gs ) ) + d = stdlib${ii}$_dlapy2( real( gs,KIND=dp), aimag( gs ) ) sn = cmplx( real( gs,KIND=dp) / d, -aimag( gs ) / d,KIND=dp) go to 50 end if - f2s = stdlib_dlapy2( real( fs,KIND=dp), aimag( fs ) ) + f2s = stdlib${ii}$_dlapy2( real( fs,KIND=dp), aimag( fs ) ) ! g2 and g2s are accurate ! g2 is at least safmin, and g2s is at least safmn2 g2s = sqrt( g2 ) @@ -45594,12 +45597,12 @@ module stdlib_linalg_lapack_z ! make sure abs(ff) = 1 ! do complex/real division explicitly with 2 real divisions if( abs1( f )>one ) then - d = stdlib_dlapy2( real( f,KIND=dp), aimag( f ) ) + d = stdlib${ii}$_dlapy2( real( f,KIND=dp), aimag( f ) ) ff = cmplx( real( f,KIND=dp) / d, aimag( f ) / d,KIND=dp) else dr = safmx2*real( f,KIND=dp) di = safmx2*aimag( f ) - d = stdlib_dlapy2( dr, di ) + d = stdlib${ii}$_dlapy2( dr, di ) ff = cmplx( dr / d, di / d,KIND=dp) end if sn = ff*cmplx( real( gs,KIND=dp) / g2s, -aimag( gs ) / g2s,KIND=dp) @@ -45617,8 +45620,8 @@ module stdlib_linalg_lapack_z ! do complex/real division explicitly with two real divisions sn = cmplx( real( r,KIND=dp) / d, aimag( r ) / d,KIND=dp) sn = sn*conjg( gs ) - if( count/=0 ) then - if( count>0 ) then + if( count/=0_${ik}$ ) then + if( count>0_${ik}$ ) then do j = 1, count r = r*safmx2 end do @@ -45638,10 +45641,10 @@ module stdlib_linalg_lapack_z ix = ix + incx end do loop_60 return - end subroutine stdlib_zlargv + end subroutine stdlib${ii}$_zlargv - pure subroutine stdlib_zlarrv( n, vl, vu, d, l, pivmin,isplit, m, dol, dou, minrgp,rtol1, & + pure subroutine stdlib${ii}$_zlarrv( n, vl, vu, d, l, pivmin,isplit, m, dol, dou, minrgp,rtol1, & !! ZLARRV computes the eigenvectors of the tridiagonal matrix !! T = L D L**T given L, D and APPROXIMATIONS to the eigenvalues of L D L**T. !! The input eigenvalues should have been computed by DLARRE. @@ -45650,31 +45653,31 @@ module stdlib_linalg_lapack_z ! -- 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) :: dol, dou, ldz, m, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: dol, dou, ldz, m, n + integer(${ik}$), intent(out) :: info real(dp), intent(in) :: minrgp, pivmin, vl, vu real(dp), intent(inout) :: rtol1, rtol2 ! Array Arguments - integer(ilp), intent(in) :: iblock(*), indexw(*), isplit(*) - integer(ilp), intent(out) :: isuppz(*), iwork(*) + integer(${ik}$), intent(in) :: iblock(*), indexw(*), isplit(*) + integer(${ik}$), intent(out) :: isuppz(*), iwork(*) real(dp), intent(inout) :: d(*), l(*), w(*), werr(*), wgap(*) real(dp), intent(in) :: gers(*) real(dp), intent(out) :: work(*) complex(dp), intent(out) :: z(ldz,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: maxitr = 10 + integer(${ik}$), parameter :: maxitr = 10_${ik}$ ! Local Scalars logical(lk) :: eskip, needbs, stp2ii, tryrqc, usedbs, usedrq - integer(ilp) :: done, i, ibegin, idone, iend, ii, iindc1, iindc2, iindr, iindwk, iinfo,& + integer(${ik}$) :: done, i, ibegin, idone, iend, ii, iindc1, iindc2, iindr, iindwk, iinfo,& im, in, indeig, indld, indlld, indwrk, isupmn, isupmx, iter, itmp1, j, jblk, k, & miniwsize, minwsize, nclus, ndepth, negcnt, newcls, newfst, newftt, newlst, newsiz, & offset, oldcls, oldfst, oldien, oldlst, oldncl, p, parity, q, wbegin, wend, windex, & windmn, windpl, zfrom, zto, zusedl, zusedu, zusedw - integer(ilp) :: indin1, indin2 + integer(${ik}$) :: indin1, indin2 real(dp) :: bstres, bstw, eps, fudge, gap, gaptol, gl, gu, lambda, left, lgap, mingma, & nrminv, resid, rgap, right, rqcorr, rqtol, savgap, sgndef, sigma, spdiam, ssigma, tau, & tmp, tol, ztz @@ -45682,35 +45685,35 @@ module stdlib_linalg_lapack_z intrinsic :: abs,real,max,min intrinsic :: cmplx ! Executable Statements - info = 0 + info = 0_${ik}$ ! quick return if possible - if( (n<=0).or.(m<=0) ) then + if( (n<=0_${ik}$).or.(m<=0_${ik}$) ) then return end if ! the first n entries of work are reserved for the eigenvalues indld = n+1 - indlld= 2*n+1 - indin1 = 3*n + 1 - indin2 = 4*n + 1 - indwrk = 5*n + 1 - minwsize = 12 * n + indlld= 2_${ik}$*n+1 + indin1 = 3_${ik}$*n + 1_${ik}$ + indin2 = 4_${ik}$*n + 1_${ik}$ + indwrk = 5_${ik}$*n + 1_${ik}$ + minwsize = 12_${ik}$ * n do i= 1,minwsize work( i ) = zero end do ! iwork(iindr+1:iindr+n) hold the twist indices r for the ! factorization used to compute the fp vector - iindr = 0 + iindr = 0_${ik}$ ! iwork(iindc1+1:iinc2+n) are used to store the clusters of the current ! layer and the one above. iindc1 = n - iindc2 = 2*n - iindwk = 3*n + 1 - miniwsize = 7 * n + iindc2 = 2_${ik}$*n + iindwk = 3_${ik}$*n + 1_${ik}$ + miniwsize = 7_${ik}$ * n do i= 1,miniwsize - iwork( i ) = 0 + iwork( i ) = 0_${ik}$ end do - zusedl = 1 - if(dol>1) then + zusedl = 1_${ik}$ + if(dol>1_${ik}$) then ! set lower bound for use of z zusedl = dol-1 endif @@ -45720,13 +45723,13 @@ module stdlib_linalg_lapack_z zusedu = dou+1 endif ! the width of the part of z that is used - zusedw = zusedu - zusedl + 1 - call stdlib_zlaset( 'FULL', n, zusedw, czero, czero,z(1,zusedl), ldz ) - eps = stdlib_dlamch( 'PRECISION' ) + zusedw = zusedu - zusedl + 1_${ik}$ + call stdlib${ii}$_zlaset( 'FULL', n, zusedw, czero, czero,z(1_${ik}$,zusedl), ldz ) + eps = stdlib${ii}$_dlamch( '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 @@ -45740,54 +45743,54 @@ module stdlib_linalg_lapack_z ! 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 + im = wend - wbegin + 1_${ik}$ ! this is for a 1x1 block if( ibegin==iend ) then done = done+1 z( ibegin, wbegin ) = cmplx( one, zero,KIND=dp) - 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) @@ -45796,24 +45799,24 @@ module stdlib_linalg_lapack_z ! the eigenvalue approximations will be refined when necessary as ! high relative accuracy is required for the computation of the ! corresponding eigenvectors. - call stdlib_dcopy( im, w( wbegin ), 1,work( wbegin ), 1 ) + call stdlib${ii}$_dcopy( 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 + ndepth = 0_${ik}$ ! parity is either 1 or 0 - parity = 1 + 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 + 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 @@ -45839,30 +45842,30 @@ module stdlib_linalg_lapack_z 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 ! 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 do k = 1, in - 1 @@ -45872,7 +45875,7 @@ module stdlib_linalg_lapack_z d( iend ) = real( z( iend, j ),KIND=dp) sigma = real( z( iend, j+1 ),KIND=dp) ! set the corresponding entries in z to zero - call stdlib_zlaset( 'FULL', in, 2, czero, czero,z( ibegin, j), ldz ) + call stdlib${ii}$_zlaset( 'FULL', in, 2_${ik}$, czero, czero,z( ibegin, j), ldz ) end if ! compute dl and dll of current rrr @@ -45881,7 +45884,7 @@ module stdlib_linalg_lapack_z 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 ) @@ -45889,29 +45892,29 @@ module stdlib_linalg_lapack_z ! 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_dlarrb( in, d( ibegin ),work(indlld+ibegin-1),p, q, rtol1, & + call stdlib${ii}$_dlarrb( 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_dlarrb. + ! wbegin-1+oldlst are correctly computed in stdlib${ii}$_dlarrb. ! 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 @@ -45928,7 +45931,7 @@ module stdlib_linalg_lapack_z ! 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 @@ -45939,25 +45942,25 @@ module stdlib_linalg_lapack_z 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. @@ -45968,7 +45971,7 @@ module stdlib_linalg_lapack_z ! 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 ) @@ -45979,13 +45982,13 @@ module stdlib_linalg_lapack_z ! 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_dlarrb( in, d(ibegin),work( indlld+ibegin-1 ),p,p,rqtol, & + offset = indexw( wbegin ) - 1_${ik}$ + call stdlib${ii}$_dlarrb( 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 @@ -45996,17 +45999,17 @@ module stdlib_linalg_lapack_z ! 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_dlarrf needs lwork = 2*n - call stdlib_dlarrf( in, d( ibegin ), l( ibegin ),work(indld+ibegin-1),& + ! stdlib${ii}$_dlarrf needs lwork = 2*n + call stdlib${ii}$_dlarrf( in, d( ibegin ), l( ibegin ),work(indld+ibegin-1),& newfst, newlst, work(wbegin),wgap(wbegin), werr(wbegin),spdiam, lgap, & rgap, pivmin, tau,work( indin1 ), work( indin2 ),work( indwrk ), iinfo ) - ! in the complex case, stdlib_dlarrf cannot write + ! in the complex case, stdlib${ii}$_dlarrf cannot write ! the new rrr directly into z and needs an intermediate ! workspace do k = 1, in-1 @@ -46016,8 +46019,8 @@ module stdlib_linalg_lapack_z end do z( iend, newftt ) =cmplx( work( indin1+in-1 ), zero,KIND=dp) - if( iinfo==0 ) then - ! a new rrr for the cluster was found by stdlib_dlarrf + if( iinfo==0_${ik}$ ) then + ! a new rrr for the cluster was found by stdlib${ii}$_dlarrf ! update shift and store it ssigma = sigma + tau z( iend, newftt+1 ) = cmplx( ssigma, zero,KIND=dp) @@ -46025,10 +46028,10 @@ module stdlib_linalg_lapack_z ! 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 @@ -46037,24 +46040,24 @@ module stdlib_linalg_lapack_z ! 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=dp)) * 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. @@ -46071,7 +46074,7 @@ module stdlib_linalg_lapack_z ! 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 ) @@ -46093,7 +46096,7 @@ module stdlib_linalg_lapack_z 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. @@ -46102,7 +46105,7 @@ module stdlib_linalg_lapack_z 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 @@ -46126,34 +46129,34 @@ module stdlib_linalg_lapack_z ! take the bisection as new iterate usedbs = .true. itmp1 = iwork( iindr+windex ) - offset = indexw( wbegin ) - 1 - call stdlib_dlarrb( in, d(ibegin),work(indlld+ibegin-1),indeig,& + offset = indexw( wbegin ) - 1_${ik}$ + call stdlib${ii}$_dlarrb( 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_zlar1v( in, 1, in, lambda, d( ibegin ),l( ibegin ), work(& + call stdlib${ii}$_zlar1v( 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 @@ -46273,25 +46276,25 @@ module stdlib_linalg_lapack_z 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_zlarrv + end subroutine stdlib${ii}$_zlarrv - pure subroutine stdlib_zlatdf( ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv,jpiv ) + pure subroutine stdlib${ii}$_zlatdf( ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv,jpiv ) !! ZLATDF computes the contribution to the reciprocal Dif-estimate !! by solving for x in Z * x = b, where b is chosen such that the norm !! of x is as large as possible. It is assumed that LU decomposition @@ -46304,30 +46307,30 @@ module stdlib_linalg_lapack_z ! -- 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) :: ijob, ldz, n + integer(${ik}$), intent(in) :: ijob, ldz, n real(dp), intent(inout) :: rdscal, rdsum ! Array Arguments - integer(ilp), intent(in) :: ipiv(*), jpiv(*) + integer(${ik}$), intent(in) :: ipiv(*), jpiv(*) complex(dp), intent(inout) :: rhs(*), z(ldz,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: maxdim = 2 + integer(${ik}$), parameter :: maxdim = 2_${ik}$ ! Local Scalars - integer(ilp) :: i, info, j, k + integer(${ik}$) :: i, info, j, k real(dp) :: rtemp, scale, sminu, splus complex(dp) :: bm, bp, pmone, temp ! Local Arrays real(dp) :: rwork(maxdim) - complex(dp) :: work(4*maxdim), xm(maxdim), xp(maxdim) + complex(dp) :: work(4_${ik}$*maxdim), xm(maxdim), xp(maxdim) ! Intrinsic Functions intrinsic :: abs,real,sqrt ! Executable Statements - if( ijob/=2 ) then + if( ijob/=2_${ik}$ ) then ! apply permutations ipiv to rhs - call stdlib_zlaswp( 1, rhs, ldz, 1, n-1, ipiv, 1 ) + call stdlib${ii}$_zlaswp( 1_${ik}$, rhs, ldz, 1_${ik}$, n-1, ipiv, 1_${ik}$ ) ! solve for l-part choosing rhs either to +1 or -1. pmone = -cone loop_10: do j = 1, n - 1 @@ -46336,9 +46339,9 @@ module stdlib_linalg_lapack_z splus = one ! lockahead for l- part rhs(1:n-1) = +-1 ! splus and smin computed more efficiently than in bsolve[1]. - splus = splus + real( stdlib_zdotc( n-j, z( j+1, j ), 1, z( j+1,j ), 1 ),KIND=dp) + splus = splus + real( stdlib${ii}$_zdotc( n-j, z( j+1, j ), 1_${ik}$, z( j+1,j ), 1_${ik}$ ),KIND=dp) - sminu = real( stdlib_zdotc( n-j, z( j+1, j ), 1, rhs( j+1 ), 1 ),KIND=dp) + sminu = real( stdlib${ii}$_zdotc( n-j, z( j+1, j ), 1_${ik}$, rhs( j+1 ), 1_${ik}$ ),KIND=dp) splus = splus*real( rhs( j ),KIND=dp) if( splus>sminu ) then rhs( j ) = bp @@ -46355,13 +46358,13 @@ module stdlib_linalg_lapack_z end if ! compute the remaining r.h.s. temp = -rhs( j ) - call stdlib_zaxpy( n-j, temp, z( j+1, j ), 1, rhs( j+1 ), 1 ) + call stdlib${ii}$_zaxpy( n-j, temp, z( j+1, j ), 1_${ik}$, rhs( j+1 ), 1_${ik}$ ) end do loop_10 ! solve for u- part, lockahead for rhs(n) = +-1. this is not done ! in bsolve and will hopefully give us a better estimate because ! any ill-conditioning of the original matrix is transferred to u ! and not to l. u(n, n) is an approximation to sigma_min(lu). - call stdlib_zcopy( n-1, rhs, 1, work, 1 ) + call stdlib${ii}$_zcopy( n-1, rhs, 1_${ik}$, work, 1_${ik}$ ) work( n ) = rhs( n ) + cone rhs( n ) = rhs( n ) - cone splus = zero @@ -46377,35 +46380,35 @@ module stdlib_linalg_lapack_z splus = splus + abs( work( i ) ) sminu = sminu + abs( rhs( i ) ) end do - if( splus>sminu )call stdlib_zcopy( n, work, 1, rhs, 1 ) + if( splus>sminu )call stdlib${ii}$_zcopy( n, work, 1_${ik}$, rhs, 1_${ik}$ ) ! apply the permutations jpiv to the computed solution (rhs) - call stdlib_zlaswp( 1, rhs, ldz, 1, n-1, jpiv, -1 ) + call stdlib${ii}$_zlaswp( 1_${ik}$, rhs, ldz, 1_${ik}$, n-1, jpiv, -1_${ik}$ ) ! compute the sum of squares - call stdlib_zlassq( n, rhs, 1, rdscal, rdsum ) + call stdlib${ii}$_zlassq( n, rhs, 1_${ik}$, rdscal, rdsum ) return end if ! entry ijob = 2 ! compute approximate nullvector xm of z - call stdlib_zgecon( 'I', n, z, ldz, one, rtemp, work, rwork, info ) - call stdlib_zcopy( n, work( n+1 ), 1, xm, 1 ) + call stdlib${ii}$_zgecon( 'I', n, z, ldz, one, rtemp, work, rwork, info ) + call stdlib${ii}$_zcopy( n, work( n+1 ), 1_${ik}$, xm, 1_${ik}$ ) ! compute rhs - call stdlib_zlaswp( 1, xm, ldz, 1, n-1, ipiv, -1 ) - temp = cone / sqrt( stdlib_zdotc( n, xm, 1, xm, 1 ) ) - call stdlib_zscal( n, temp, xm, 1 ) - call stdlib_zcopy( n, xm, 1, xp, 1 ) - call stdlib_zaxpy( n, cone, rhs, 1, xp, 1 ) - call stdlib_zaxpy( n, -cone, xm, 1, rhs, 1 ) - call stdlib_zgesc2( n, z, ldz, rhs, ipiv, jpiv, scale ) - call stdlib_zgesc2( n, z, ldz, xp, ipiv, jpiv, scale ) - if( stdlib_dzasum( n, xp, 1 )>stdlib_dzasum( n, rhs, 1 ) )call stdlib_zcopy( n, xp, 1, & - rhs, 1 ) + call stdlib${ii}$_zlaswp( 1_${ik}$, xm, ldz, 1_${ik}$, n-1, ipiv, -1_${ik}$ ) + temp = cone / sqrt( stdlib${ii}$_zdotc( n, xm, 1_${ik}$, xm, 1_${ik}$ ) ) + call stdlib${ii}$_zscal( n, temp, xm, 1_${ik}$ ) + call stdlib${ii}$_zcopy( n, xm, 1_${ik}$, xp, 1_${ik}$ ) + call stdlib${ii}$_zaxpy( n, cone, rhs, 1_${ik}$, xp, 1_${ik}$ ) + call stdlib${ii}$_zaxpy( n, -cone, xm, 1_${ik}$, rhs, 1_${ik}$ ) + call stdlib${ii}$_zgesc2( n, z, ldz, rhs, ipiv, jpiv, scale ) + call stdlib${ii}$_zgesc2( n, z, ldz, xp, ipiv, jpiv, scale ) + if( stdlib${ii}$_dzasum( n, xp, 1_${ik}$ )>stdlib${ii}$_dzasum( n, rhs, 1_${ik}$ ) )call stdlib${ii}$_zcopy( n, xp, 1_${ik}$, & + rhs, 1_${ik}$ ) ! compute the sum of squares - call stdlib_zlassq( n, rhs, 1, rdscal, rdsum ) + call stdlib${ii}$_zlassq( n, rhs, 1_${ik}$, rdscal, rdsum ) return - end subroutine stdlib_zlatdf + end subroutine stdlib${ii}$_zlatdf - pure subroutine stdlib_zlaunhr_col_getrfnp( m, n, a, lda, d, info ) + pure subroutine stdlib${ii}$_zlaunhr_col_getrfnp( m, n, a, lda, d, info ) !! ZLAUNHR_COL_GETRFNP computes the modified LU factorization without !! pivoting of a complex general M-by-N matrix A. The factorization has !! the form: @@ -46443,52 +46446,52 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: a(lda,*) complex(dp), 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}$, 'ZLAUNHR_COL_GETRFNP', ' ', m, n, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=min( m, n ) ) then ! use unblocked code. - call stdlib_zlaunhr_col_getrfnp2( m, n, a, lda, d, info ) + call stdlib${ii}$_zlaunhr_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_zlaunhr_col_getrfnp2( m-j+1, jb, a( j, j ), lda,d( j ), iinfo ) + call stdlib${ii}$_zlaunhr_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_ztrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, cone,& + call stdlib${ii}$_ztrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, cone,& a( j, j ), lda, a( j, j+jb ),lda ) if( j+jb<=m ) then ! update trailing submatrix. - call stdlib_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& cone, a( j+jb, j ), lda,a( j, j+jb ), lda, cone, a( j+jb, j+jb ),lda ) end if @@ -46496,10 +46499,10 @@ module stdlib_linalg_lapack_z end do end if return - end subroutine stdlib_zlaunhr_col_getrfnp + end subroutine stdlib${ii}$_zlaunhr_col_getrfnp - pure subroutine stdlib_zpbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b,ldb, x, ldx, ferr, & + pure subroutine stdlib${ii}$_zpbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b,ldb, x, ldx, ferr, & !! ZPBRFS improves the computed solution to a system of linear !! equations when the coefficient matrix is Hermitian positive definite !! and banded, and provides error bounds and backward error estimates @@ -46510,8 +46513,8 @@ module stdlib_linalg_lapack_z ! -- 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, ldafb, ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kd, ldab, ldafb, ldb, ldx, n, nrhs ! Array Arguments real(dp), intent(out) :: berr(*), ferr(*), rwork(*) complex(dp), intent(in) :: ab(ldab,*), afb(ldafb,*), b(ldb,*) @@ -46519,7 +46522,7 @@ module stdlib_linalg_lapack_z complex(dp), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: itmax = 5 + integer(${ik}$), parameter :: itmax = 5_${ik}$ @@ -46527,11 +46530,11 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: upper - integer(ilp) :: count, i, j, k, kase, l, nz + integer(${ik}$) :: count, i, j, k, kase, l, nz real(dp) :: eps, lstres, s, safe1, safe2, safmin, xk complex(dp) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,aimag,max,min ! Statement Functions @@ -46540,31 +46543,31 @@ module stdlib_linalg_lapack_z cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) ) ! 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( ldabeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_zpbtrs( uplo, n, kd, 1, afb, ldafb, work, n, info ) - call stdlib_zaxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_zpbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work, n, info ) + call stdlib${ii}$_zaxpy( n, cone, work, 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 @@ -46667,22 +46670,22 @@ module stdlib_linalg_lapack_z rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**h). - call stdlib_zpbtrs( uplo, n, kd, 1, afb, ldafb, work, n, info ) + call stdlib${ii}$_zpbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do - else if( kase==2 ) then + else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_zpbtrs( uplo, n, kd, 1, afb, ldafb, work, n, info ) + call stdlib${ii}$_zpbtrs( uplo, n, kd, 1_${ik}$, afb, ldafb, work, n, info ) end if go to 100 end if @@ -46694,10 +46697,10 @@ module stdlib_linalg_lapack_z if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_zpbrfs + end subroutine stdlib${ii}$_zpbrfs - pure subroutine stdlib_zpbtrf( uplo, n, kd, ab, ldab, info ) + pure subroutine stdlib${ii}$_zpbtrf( uplo, n, kd, ab, ldab, info ) !! ZPBTRF computes the Cholesky factorization of a complex Hermitian !! positive definite band matrix A. !! The factorization has the form @@ -46709,50 +46712,50 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: ab(ldab,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: nbmax = 32 - integer(ilp), parameter :: ldwork = nbmax+1 + integer(${ik}$), parameter :: nbmax = 32_${ik}$ + integer(${ik}$), parameter :: ldwork = nbmax+1 ! Local Scalars - integer(ilp) :: i, i2, i3, ib, ii, j, jj, nb + integer(${ik}$) :: i, i2, i3, ib, ii, j, jj, nb ! Local Arrays complex(dp) :: work(ldwork,nbmax) ! Intrinsic Functions intrinsic :: min ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( ( .not.stdlib_lsame( uplo, 'U' ) ) .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( ldabkd ) then + if( nb<=1_${ik}$ .or. nb>kd ) then ! use unblocked code - call stdlib_zpbtf2( uplo, n, kd, ab, ldab, info ) + call stdlib${ii}$_zpbtf2( uplo, n, kd, ab, ldab, info ) else ! use blocked code if( stdlib_lsame( uplo, 'U' ) ) then @@ -46769,9 +46772,9 @@ module stdlib_linalg_lapack_z loop_70: do i = 1, n, nb ib = min( nb, n-i+1 ) ! factorize the diagonal block - call stdlib_zpotf2( uplo, ib, ab( kd+1, i ), ldab-1, ii ) - if( ii/=0 ) then - info = i + ii - 1 + call stdlib${ii}$_zpotf2( uplo, ib, ab( kd+1, i ), ldab-1, ii ) + if( ii/=0_${ik}$ ) then + info = i + ii - 1_${ik}$ go to 150 end if if( i+ib<=n ) then @@ -46788,15 +46791,15 @@ module stdlib_linalg_lapack_z ! lies outside the band. i2 = min( kd-ib, n-i-ib+1 ) i3 = min( ib, n-i-kd+1 ) - if( i2>0 ) then + if( i2>0_${ik}$ ) then ! update a12 - call stdlib_ztrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', & + call stdlib${ii}$_ztrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', & ib, i2, cone,ab( kd+1, i ), ldab-1,ab( kd+1-ib, i+ib ), ldab-1 ) ! update a22 - call stdlib_zherk( 'UPPER', 'CONJUGATE TRANSPOSE', i2, ib,-one, ab( kd+& - 1-ib, i+ib ), ldab-1, one,ab( kd+1, i+ib ), ldab-1 ) + call stdlib${ii}$_zherk( 'UPPER', 'CONJUGATE TRANSPOSE', i2, ib,-one, ab( kd+& + 1_${ik}$-ib, i+ib ), ldab-1, one,ab( kd+1, i+ib ), ldab-1 ) end if - if( i3>0 ) then + if( i3>0_${ik}$ ) then ! copy the lower triangle of a13 into the work array. do jj = 1, i3 do ii = jj, ib @@ -46804,14 +46807,14 @@ module stdlib_linalg_lapack_z end do end do ! update a13 (in the work array). - call stdlib_ztrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', & + call stdlib${ii}$_ztrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', & ib, i3, cone,ab( kd+1, i ), ldab-1, work, ldwork ) ! update a23 - if( i2>0 )call stdlib_zgemm( 'CONJUGATE TRANSPOSE','NO TRANSPOSE', i2, & - i3, ib, -cone,ab( kd+1-ib, i+ib ), ldab-1, work,ldwork, cone, ab( 1+ib, & + if( i2>0_${ik}$ )call stdlib${ii}$_zgemm( 'CONJUGATE TRANSPOSE','NO TRANSPOSE', i2, & + i3, ib, -cone,ab( kd+1-ib, i+ib ), ldab-1, work,ldwork, cone, ab( 1_${ik}$+ib, & i+kd ),ldab-1 ) ! update a33 - call stdlib_zherk( 'UPPER', 'CONJUGATE TRANSPOSE', i3, ib,-one, work, & + call stdlib${ii}$_zherk( 'UPPER', 'CONJUGATE TRANSPOSE', i3, ib,-one, work, & ldwork, one,ab( kd+1, i+kd ), ldab-1 ) ! copy the lower triangle of a13 back into place. do jj = 1, i3 @@ -46836,9 +46839,9 @@ module stdlib_linalg_lapack_z loop_140: do i = 1, n, nb ib = min( nb, n-i+1 ) ! factorize the diagonal block - call stdlib_zpotf2( uplo, ib, ab( 1, i ), ldab-1, ii ) - if( ii/=0 ) then - info = i + ii - 1 + call stdlib${ii}$_zpotf2( uplo, ib, ab( 1_${ik}$, i ), ldab-1, ii ) + if( ii/=0_${ik}$ ) then + info = i + ii - 1_${ik}$ go to 150 end if if( i+ib<=n ) then @@ -46855,15 +46858,15 @@ module stdlib_linalg_lapack_z ! lies outside the band. i2 = min( kd-ib, n-i-ib+1 ) i3 = min( ib, n-i-kd+1 ) - if( i2>0 ) then + if( i2>0_${ik}$ ) then ! update a21 - call stdlib_ztrsm( 'RIGHT', 'LOWER','CONJUGATE TRANSPOSE', 'NON-UNIT', & - i2,ib, cone, ab( 1, i ), ldab-1,ab( 1+ib, i ), ldab-1 ) + call stdlib${ii}$_ztrsm( 'RIGHT', 'LOWER','CONJUGATE TRANSPOSE', 'NON-UNIT', & + i2,ib, cone, ab( 1_${ik}$, i ), ldab-1,ab( 1_${ik}$+ib, i ), ldab-1 ) ! update a22 - call stdlib_zherk( 'LOWER', 'NO TRANSPOSE', i2, ib, -one,ab( 1+ib, i ), & - ldab-1, one,ab( 1, i+ib ), ldab-1 ) + call stdlib${ii}$_zherk( 'LOWER', 'NO TRANSPOSE', i2, ib, -one,ab( 1_${ik}$+ib, i ), & + ldab-1, one,ab( 1_${ik}$, i+ib ), ldab-1 ) end if - if( i3>0 ) then + if( i3>0_${ik}$ ) then ! copy the upper triangle of a31 into the work array. do jj = 1, ib do ii = 1, min( jj, i3 ) @@ -46871,15 +46874,15 @@ module stdlib_linalg_lapack_z end do end do ! update a31 (in the work array). - call stdlib_ztrsm( 'RIGHT', 'LOWER','CONJUGATE TRANSPOSE', 'NON-UNIT', & - i3,ib, cone, ab( 1, i ), ldab-1, work,ldwork ) + call stdlib${ii}$_ztrsm( 'RIGHT', 'LOWER','CONJUGATE TRANSPOSE', 'NON-UNIT', & + i3,ib, cone, ab( 1_${ik}$, i ), ldab-1, work,ldwork ) ! update a32 - if( i2>0 )call stdlib_zgemm( 'NO TRANSPOSE','CONJUGATE TRANSPOSE', i3, & - i2, ib,-cone, work, ldwork, ab( 1+ib, i ),ldab-1, cone, ab( 1+kd-ib, i+& + if( i2>0_${ik}$ )call stdlib${ii}$_zgemm( 'NO TRANSPOSE','CONJUGATE TRANSPOSE', i3, & + i2, ib,-cone, work, ldwork, ab( 1_${ik}$+ib, i ),ldab-1, cone, ab( 1_${ik}$+kd-ib, i+& ib ),ldab-1 ) ! update a33 - call stdlib_zherk( 'LOWER', 'NO TRANSPOSE', i3, ib, -one,work, ldwork, & - one, ab( 1, i+kd ),ldab-1 ) + call stdlib${ii}$_zherk( 'LOWER', 'NO TRANSPOSE', i3, ib, -one,work, ldwork, & + one, ab( 1_${ik}$, i+kd ),ldab-1 ) ! copy the upper triangle of a31 back into place. do jj = 1, ib do ii = 1, min( jj, i3 ) @@ -46894,10 +46897,10 @@ module stdlib_linalg_lapack_z return 150 continue return - end subroutine stdlib_zpbtrf + end subroutine stdlib${ii}$_zpbtrf - pure subroutine stdlib_zpftrs( transr, uplo, n, nrhs, a, b, ldb, info ) + pure subroutine stdlib${ii}$_zpftrs( transr, uplo, n, nrhs, a, b, ldb, info ) !! ZPFTRS solves a system of linear equations A*X = B with a Hermitian !! positive definite matrix A using the Cholesky factorization !! A = U**H*U or A = L*L**H computed by ZPFTRF. @@ -46906,10 +46909,10 @@ module stdlib_linalg_lapack_z ! -- 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) :: ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments - complex(dp), intent(in) :: a(0:*) + complex(dp), intent(in) :: a(0_${ik}$:*) complex(dp), intent(inout) :: b(ldb,*) ! ===================================================================== @@ -46919,39 +46922,39 @@ module stdlib_linalg_lapack_z intrinsic :: max ! 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, 'C' ) ) 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( nrhs<0 ) then - info = -4 - else if( ldbeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_zpotrs( uplo, n, 1, af, ldaf, work, n, info ) - call stdlib_zaxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_zpotrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info ) + call stdlib${ii}$_zaxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -47114,22 +47117,22 @@ module stdlib_linalg_lapack_z rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**h). - call stdlib_zpotrs( uplo, n, 1, af, ldaf, work, n, info ) + call stdlib${ii}$_zpotrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do - else if( kase==2 ) then + else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_zpotrs( uplo, n, 1, af, ldaf, work, n, info ) + call stdlib${ii}$_zpotrs( uplo, n, 1_${ik}$, af, ldaf, work, n, info ) end if go to 100 end if @@ -47141,10 +47144,10 @@ module stdlib_linalg_lapack_z if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_zporfs + end subroutine stdlib${ii}$_zporfs - pure subroutine stdlib_zpotrf( uplo, n, a, lda, info ) + pure subroutine stdlib${ii}$_zpotrf( uplo, n, a, lda, info ) !! ZPOTRF computes the Cholesky factorization of a complex Hermitian !! positive definite matrix A. !! The factorization has the form @@ -47157,8 +47160,8 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: a(lda,*) ! ===================================================================== @@ -47166,31 +47169,31 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: upper - integer(ilp) :: j, jb, nb + integer(${ik}$) :: j, jb, nb ! Intrinsic Functions intrinsic :: max,min ! 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}$, 'ZPOTRF', uplo, n, -1_${ik}$, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=n ) then ! use unblocked code. - call stdlib_zpotrf2( uplo, n, a, lda, info ) + call stdlib${ii}$_zpotrf2( uplo, n, a, lda, info ) else ! use blocked code. if( upper ) then @@ -47199,15 +47202,15 @@ module stdlib_linalg_lapack_z ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) - call stdlib_zherk( 'UPPER', 'CONJUGATE TRANSPOSE', jb, j-1,-one, a( 1, j ), & + call stdlib${ii}$_zherk( 'UPPER', 'CONJUGATE TRANSPOSE', jb, j-1,-one, a( 1_${ik}$, j ), & lda, one, a( j, j ), lda ) - call stdlib_zpotrf2( 'UPPER', jb, a( j, j ), lda, info ) + call stdlib${ii}$_zpotrf2( 'UPPER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block row. - call stdlib_zgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', jb,n-j-jb+1, j-1,& - -cone, a( 1, j ), lda,a( 1, j+jb ), lda, cone, a( j, j+jb ),lda ) - call stdlib_ztrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', jb, & + call stdlib${ii}$_zgemm( 'CONJUGATE TRANSPOSE', 'NO TRANSPOSE', jb,n-j-jb+1, j-1,& + -cone, a( 1_${ik}$, j ), lda,a( 1_${ik}$, j+jb ), lda, cone, a( j, j+jb ),lda ) + call stdlib${ii}$_ztrsm( 'LEFT', 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT', jb, & n-j-jb+1, cone, a( j, j ),lda, a( j, j+jb ), lda ) end if end do @@ -47217,15 +47220,15 @@ module stdlib_linalg_lapack_z ! update and factorize the current diagonal block and test ! for non-positive-definiteness. jb = min( nb, n-j+1 ) - call stdlib_zherk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1 ), lda, one,& + call stdlib${ii}$_zherk( 'LOWER', 'NO TRANSPOSE', jb, j-1, -one,a( j, 1_${ik}$ ), lda, one,& a( j, j ), lda ) - call stdlib_zpotrf2( 'LOWER', jb, a( j, j ), lda, info ) + call stdlib${ii}$_zpotrf2( 'LOWER', jb, a( j, j ), lda, info ) if( info/=0 )go to 30 if( j+jb<=n ) then ! compute the current block column. - call stdlib_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',n-j-jb+1, jb, j-1,& - -cone, a( j+jb, 1 ),lda, a( j, 1 ), lda, cone, a( j+jb, j ),lda ) - call stdlib_ztrsm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', n-j-& + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',n-j-jb+1, jb, j-1,& + -cone, a( j+jb, 1_${ik}$ ),lda, a( j, 1_${ik}$ ), lda, cone, a( j+jb, j ),lda ) + call stdlib${ii}$_ztrsm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','NON-UNIT', n-j-& jb+1, jb, cone, a( j, j ),lda, a( j+jb, j ), lda ) end if end do @@ -47233,13 +47236,13 @@ module stdlib_linalg_lapack_z end if go to 40 30 continue - info = info + j - 1 + info = info + j - 1_${ik}$ 40 continue return - end subroutine stdlib_zpotrf + end subroutine stdlib${ii}$_zpotrf - pure subroutine stdlib_zpotri( uplo, n, a, lda, info ) + pure subroutine stdlib${ii}$_zpotri( uplo, n, a, lda, info ) !! ZPOTRI computes the inverse of a complex Hermitian positive definite !! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H !! computed by ZPOTRF. @@ -47248,8 +47251,8 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: a(lda,*) ! ===================================================================== @@ -47257,30 +47260,30 @@ module stdlib_linalg_lapack_z intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda0 )return ! form inv(u) * inv(u)**h or inv(l)**h * inv(l). - call stdlib_zlauum( uplo, n, a, lda, info ) + call stdlib${ii}$_zlauum( uplo, n, a, lda, info ) return - end subroutine stdlib_zpotri + end subroutine stdlib${ii}$_zpotri - pure subroutine stdlib_zpprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr,berr, work, & + pure subroutine stdlib${ii}$_zpprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr,berr, work, & !! ZPPRFS improves the computed solution to a system of linear !! equations when the coefficient matrix is Hermitian positive definite !! and packed, and provides error bounds and backward error estimates @@ -47291,8 +47294,8 @@ module stdlib_linalg_lapack_z ! -- 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) :: ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs ! Array Arguments real(dp), intent(out) :: berr(*), ferr(*), rwork(*) complex(dp), intent(in) :: afp(*), ap(*), b(ldb,*) @@ -47300,7 +47303,7 @@ module stdlib_linalg_lapack_z complex(dp), intent(inout) :: x(ldx,*) ! ==================================================================== ! Parameters - integer(ilp), parameter :: itmax = 5 + integer(${ik}$), parameter :: itmax = 5_${ik}$ @@ -47308,11 +47311,11 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: upper - integer(ilp) :: count, i, ik, j, k, kase, kk, nz + integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz real(dp) :: eps, lstres, s, safe1, safe2, safmin, xk complex(dp) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,aimag,max ! Statement Functions @@ -47321,25 +47324,25 @@ module stdlib_linalg_lapack_z cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) ) ! 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( nrhs<0 ) then - info = -3 - else if( ldbeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_zpptrs( uplo, n, 1, afp, work, n, info ) - call stdlib_zaxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_zpptrs( uplo, n, 1_${ik}$, afp, work, n, info ) + call stdlib${ii}$_zaxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -47446,22 +47449,22 @@ module stdlib_linalg_lapack_z rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**h). - call stdlib_zpptrs( uplo, n, 1, afp, work, n, info ) + call stdlib${ii}$_zpptrs( uplo, n, 1_${ik}$, afp, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do - else if( kase==2 ) then + else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_zpptrs( uplo, n, 1, afp, work, n, info ) + call stdlib${ii}$_zpptrs( uplo, n, 1_${ik}$, afp, work, n, info ) end if go to 100 end if @@ -47473,10 +47476,10 @@ module stdlib_linalg_lapack_z if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_zpprfs + end subroutine stdlib${ii}$_zpprfs - pure subroutine stdlib_zppsv( uplo, n, nrhs, ap, b, ldb, info ) + pure subroutine stdlib${ii}$_zppsv( uplo, n, nrhs, ap, b, ldb, info ) !! ZPPSV computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N Hermitian positive definite matrix stored in @@ -47492,8 +47495,8 @@ module stdlib_linalg_lapack_z ! -- 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) :: ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments complex(dp), intent(inout) :: ap(*), b(ldb,*) ! ===================================================================== @@ -47501,31 +47504,31 @@ module stdlib_linalg_lapack_z intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .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( ldb0 ) then + info = -8_${ik}$ + else if( n>0_${ik}$ ) then scond = max( smin, smlnum ) / min( smax, bignum ) else scond = one end if end if - if( info==0 ) then - if( ldb0 )then + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_zlanhp( 'I', uplo, n, ap, rwork ) + anorm = stdlib${ii}$_zlanhp( 'I', uplo, n, ap, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_zppcon( uplo, n, afp, anorm, rcond, work, rwork, info ) + call stdlib${ii}$_zppcon( uplo, n, afp, anorm, rcond, work, rwork, info ) ! compute the solution matrix x. - call stdlib_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_zpptrs( uplo, n, nrhs, afp, x, ldx, info ) + call stdlib${ii}$_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_zpptrs( uplo, n, nrhs, afp, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_zpprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr, berr,work, rwork, & + call stdlib${ii}$_zpprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr, berr,work, rwork, & info ) ! transform the solution matrix x to a solution of the original ! system. @@ -47660,12 +47663,12 @@ module stdlib_linalg_lapack_z end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond0 )return if( upper ) then ! compute the product inv(u) * inv(u)**h. - jj = 0 + jj = 0_${ik}$ do j = 1, n - jc = jj + 1 + jc = jj + 1_${ik}$ jj = jj + j - if( j>1 )call stdlib_zhpr( 'UPPER', j-1, one, ap( jc ), 1, ap ) + if( j>1_${ik}$ )call stdlib${ii}$_zhpr( 'UPPER', j-1, one, ap( jc ), 1_${ik}$, ap ) ajj = real( ap( jj ),KIND=dp) - call stdlib_zdscal( j, ajj, ap( jc ), 1 ) + call stdlib${ii}$_zdscal( j, ajj, ap( jc ), 1_${ik}$ ) end do else ! compute the product inv(l)**h * inv(l). - jj = 1 + jj = 1_${ik}$ do j = 1, n - jjn = jj + n - j + 1 - ap( jj ) = real( stdlib_zdotc( n-j+1, ap( jj ), 1, ap( jj ), 1 ),KIND=dp) - if( j0 .and. ldz0_${ik}$ .and. ldz0 )z( 1, 1 ) = cone + if( n==1_${ik}$ ) then + if( icompz>0_${ik}$ )z( 1_${ik}$, 1_${ik}$ ) = cone return end if - if( icompz==2 )call stdlib_zlaset( 'FULL', n, n, czero, cone, z, ldz ) - ! call stdlib_dpttrf to factor the matrix. - call stdlib_dpttrf( n, d, e, info ) + if( icompz==2_${ik}$ )call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, z, ldz ) + ! call stdlib${ii}$_dpttrf to factor the matrix. + call stdlib${ii}$_dpttrf( n, d, e, info ) if( info/=0 )return do i = 1, n d( i ) = sqrt( d( i ) ) @@ -47803,17 +47806,17 @@ module stdlib_linalg_lapack_z do i = 1, n - 1 e( i ) = e( i )*d( i ) end do - ! call stdlib_zbdsqr to compute the singular values/vectors of the + ! call stdlib${ii}$_zbdsqr to compute the singular values/vectors of the ! bidiagonal factor. - if( icompz>0 ) then + if( icompz>0_${ik}$ ) then nru = n else - nru = 0 + nru = 0_${ik}$ end if - call stdlib_zbdsqr( 'LOWER', n, 0, nru, 0, d, e, vt, 1, z, ldz, c, 1,work, info ) + call stdlib${ii}$_zbdsqr( 'LOWER', n, 0_${ik}$, nru, 0_${ik}$, d, e, vt, 1_${ik}$, z, ldz, c, 1_${ik}$,work, info ) ! square the singular values. - if( info==0 ) then + if( info==0_${ik}$ ) then do i = 1, n d( i ) = d( i )*d( i ) end do @@ -47821,10 +47824,10 @@ module stdlib_linalg_lapack_z info = n + info end if return - end subroutine stdlib_zpteqr + end subroutine stdlib${ii}$_zpteqr - pure subroutine stdlib_zpttrs( uplo, n, nrhs, d, e, b, ldb, info ) + pure subroutine stdlib${ii}$_zpttrs( uplo, n, nrhs, d, e, b, ldb, info ) !! ZPTTRS solves a tridiagonal system of the form !! A * X = B !! using the factorization A = U**H *D* U or A = L*D*L**H computed by ZPTTRF. @@ -47836,8 +47839,8 @@ module stdlib_linalg_lapack_z ! -- 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) :: ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments real(dp), intent(in) :: d(*) complex(dp), intent(inout) :: b(ldb,*) @@ -47845,53 +47848,53 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: iuplo, j, jb, nb + integer(${ik}$) :: iuplo, j, jb, nb ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments. - info = 0 + info = 0_${ik}$ upper = ( uplo=='U' .or. uplo=='U' ) if( .not.upper .and. .not.( uplo=='L' .or. uplo=='L' ) ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( ldb=nrhs ) then - call stdlib_zptts2( iuplo, n, nrhs, d, e, b, ldb ) + call stdlib${ii}$_zptts2( iuplo, n, nrhs, d, e, b, ldb ) else do j = 1, nrhs, nb jb = min( nrhs-j+1, nb ) - call stdlib_zptts2( iuplo, n, jb, d, e, b( 1, j ), ldb ) + call stdlib${ii}$_zptts2( iuplo, n, jb, d, e, b( 1_${ik}$, j ), ldb ) end do end if return - end subroutine stdlib_zpttrs + end subroutine stdlib${ii}$_zpttrs - pure subroutine stdlib_zspcon( uplo, n, ap, ipiv, anorm, rcond, work, info ) + pure subroutine stdlib${ii}$_zspcon( uplo, n, ap, ipiv, anorm, rcond, work, info ) !! ZSPCON estimates the reciprocal of the condition number (in the !! 1-norm) of a complex symmetric packed matrix A using the !! factorization A = U*D*U**T or A = L*D*L**T computed by ZSPTRF. @@ -47902,40 +47905,40 @@ module stdlib_linalg_lapack_z ! -- 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) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(dp), intent(in) :: anorm real(dp), intent(out) :: rcond ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) complex(dp), intent(in) :: ap(*) complex(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: i, ip, kase + integer(${ik}$) :: i, ip, kase real(dp) :: ainvnm ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! 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 + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ else if( anorm0 .and. ap( ip )==zero )return ip = ip - i end do else ! lower triangular storage: examine d from top to bottom. - ip = 1 + ip = 1_${ik}$ do i = 1, n if( ipiv( i )>0 .and. ap( ip )==zero )return - ip = ip + n - i + 1 + ip = ip + n - i + 1_${ik}$ end do end if ! estimate the 1-norm of the inverse. - kase = 0 + kase = 0_${ik}$ 30 continue - call stdlib_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + if( kase/=0_${ik}$ ) then ! multiply by inv(l*d*l**t) or inv(u*d*u**t). - call stdlib_zsptrs( uplo, n, 1, ap, ipiv, work, n, info ) + call stdlib${ii}$_zsptrs( uplo, n, 1_${ik}$, ap, ipiv, work, n, info ) go to 30 end if ! compute the estimate of the reciprocal condition number. if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm return - end subroutine stdlib_zspcon + end subroutine stdlib${ii}$_zspcon - pure subroutine stdlib_zsprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,& + pure subroutine stdlib${ii}$_zsprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,& !! ZSPRFS improves the computed solution to a system of linear !! equations when the coefficient matrix is symmetric indefinite !! and packed, and provides error bounds and backward error estimates @@ -47983,17 +47986,17 @@ module stdlib_linalg_lapack_z ! -- 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) :: ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) real(dp), intent(out) :: berr(*), ferr(*), rwork(*) complex(dp), intent(in) :: afp(*), ap(*), b(ldb,*) complex(dp), intent(out) :: work(*) complex(dp), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: itmax = 5 + integer(${ik}$), parameter :: itmax = 5_${ik}$ @@ -48001,11 +48004,11 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: upper - integer(ilp) :: count, i, ik, j, k, kase, kk, nz + integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz real(dp) :: eps, lstres, s, safe1, safe2, safmin, xk complex(dp) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,aimag,max ! Statement Functions @@ -48014,25 +48017,25 @@ module stdlib_linalg_lapack_z cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) ) ! 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( nrhs<0 ) then - info = -3 - else if( ldbeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_zsptrs( uplo, n, 1, afp, ipiv, work, n, info ) - call stdlib_zaxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_zsptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info ) + call stdlib${ii}$_zaxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -48139,22 +48142,22 @@ module stdlib_linalg_lapack_z rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**t). - call stdlib_zsptrs( uplo, n, 1, afp, ipiv, work, n, info ) + call stdlib${ii}$_zsptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do - else if( kase==2 ) then + else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_zsptrs( uplo, n, 1, afp, ipiv, work, n, info ) + call stdlib${ii}$_zsptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info ) end if go to 100 end if @@ -48166,10 +48169,10 @@ module stdlib_linalg_lapack_z if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_zsprfs + end subroutine stdlib${ii}$_zsprfs - pure subroutine stdlib_zspsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) + pure subroutine stdlib${ii}$_zspsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) !! ZSPSV computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N symmetric matrix stored in packed format and X @@ -48186,41 +48189,41 @@ module stdlib_linalg_lapack_z ! -- 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) :: ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(dp), intent(inout) :: ap(*), b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .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( ldb0 )then + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_zlansp( 'I', uplo, n, ap, rwork ) + anorm = stdlib${ii}$_zlansp( 'I', uplo, n, ap, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_zspcon( uplo, n, afp, ipiv, anorm, rcond, work, info ) + call stdlib${ii}$_zspcon( uplo, n, afp, ipiv, anorm, rcond, work, info ) ! compute the solution vectors x. - call stdlib_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_zsptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info ) + call stdlib${ii}$_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_zsptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_zsprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, & + call stdlib${ii}$_zsprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, & rwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond0 .and. wu<=wl ) then - info = -7 - else if( indeig .and. ( iil<1 .or. iil>n ) ) then - info = -8 + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( valeig .and. n>0_${ik}$ .and. wu<=wl ) then + info = -7_${ik}$ + else if( indeig .and. ( iil<1_${ik}$ .or. iil>n ) ) then + info = -8_${ik}$ else if( indeig .and. ( iiun ) ) then - info = -9 - else if( ldz<1 .or. ( wantz .and. ldz=d( 1 ) ) then - m = 1 - w( 1 ) = d( 1 ) + if( wl=d( 1_${ik}$ ) ) then + m = 1_${ik}$ + w( 1_${ik}$ ) = d( 1_${ik}$ ) end if end if if( wantz.and.(.not.zquery) ) then - z( 1, 1 ) = one - isuppz(1) = 1 - isuppz(2) = 1 + z( 1_${ik}$, 1_${ik}$ ) = one + isuppz(1_${ik}$) = 1_${ik}$ + isuppz(2_${ik}$) = 1_${ik}$ end if return end if - if( n==2 ) then + if( n==2_${ik}$ ) then if( .not.wantz ) then - call stdlib_dlae2( d(1), e(1), d(2), r1, r2 ) + call stdlib${ii}$_dlae2( d(1_${ik}$), e(1_${ik}$), d(2_${ik}$), r1, r2 ) else if( wantz.and.(.not.zquery) ) then - call stdlib_dlaev2( d(1), e(1), d(2), r1, r2, cs, sn ) + call stdlib${ii}$_dlaev2( d(1_${ik}$), e(1_${ik}$), d(2_${ik}$), r1, r2, cs, sn ) end if - if( alleig.or.(valeig.and.(r2>wl).and.(r2<=wu)).or.(indeig.and.(iil==1)) ) & + if( alleig.or.(valeig.and.(r2>wl).and.(r2<=wu)).or.(indeig.and.(iil==1_${ik}$)) ) & then m = m+1 w( m ) = r2 if( wantz.and.(.not.zquery) ) then - z( 1, m ) = -sn - z( 2, m ) = cs + z( 1_${ik}$, m ) = -sn + z( 2_${ik}$, m ) = cs ! note: at most one of sn and cs can be zero. if (sn/=zero) then if (cs/=zero) then - isuppz(2*m-1) = 1 - isuppz(2*m) = 2 + isuppz(2_${ik}$*m-1) = 1_${ik}$ + isuppz(2_${ik}$*m) = 2_${ik}$ else - isuppz(2*m-1) = 1 - isuppz(2*m) = 1 + isuppz(2_${ik}$*m-1) = 1_${ik}$ + isuppz(2_${ik}$*m) = 1_${ik}$ end if else - isuppz(2*m-1) = 2 - isuppz(2*m) = 2 + isuppz(2_${ik}$*m-1) = 2_${ik}$ + isuppz(2_${ik}$*m) = 2_${ik}$ end if endif endif - if( alleig.or.(valeig.and.(r1>wl).and.(r1<=wu)).or.(indeig.and.(iiu==2)) ) & + if( alleig.or.(valeig.and.(r1>wl).and.(r1<=wu)).or.(indeig.and.(iiu==2_${ik}$)) ) & then m = m+1 w( m ) = r1 if( wantz.and.(.not.zquery) ) then - z( 1, m ) = cs - z( 2, m ) = sn + z( 1_${ik}$, m ) = cs + z( 2_${ik}$, m ) = sn ! note: at most one of sn and cs can be zero. if (sn/=zero) then if (cs/=zero) then - isuppz(2*m-1) = 1 - isuppz(2*m) = 2 + isuppz(2_${ik}$*m-1) = 1_${ik}$ + isuppz(2_${ik}$*m) = 2_${ik}$ else - isuppz(2*m-1) = 1 - isuppz(2*m) = 1 + isuppz(2_${ik}$*m-1) = 1_${ik}$ + isuppz(2_${ik}$*m) = 1_${ik}$ end if else - isuppz(2*m-1) = 2 - isuppz(2*m) = 2 + isuppz(2_${ik}$*m-1) = 2_${ik}$ + isuppz(2_${ik}$*m) = 2_${ik}$ end if endif endif else ! continue with general n - indgrs = 1 - inderr = 2*n + 1 - indgp = 3*n + 1 - indd = 4*n + 1 - inde2 = 5*n + 1 - indwrk = 6*n + 1 - iinspl = 1 - iindbl = n + 1 - iindw = 2*n + 1 - iindwk = 3*n + 1 + indgrs = 1_${ik}$ + inderr = 2_${ik}$*n + 1_${ik}$ + indgp = 3_${ik}$*n + 1_${ik}$ + indd = 4_${ik}$*n + 1_${ik}$ + inde2 = 5_${ik}$*n + 1_${ik}$ + indwrk = 6_${ik}$*n + 1_${ik}$ + iinspl = 1_${ik}$ + iindbl = n + 1_${ik}$ + iindw = 2_${ik}$*n + 1_${ik}$ + iindwk = 3_${ik}$*n + 1_${ik}$ ! scale matrix to allowable range, if necessary. ! the allowable range is related to the pivmin parameter; see the - ! comments in stdlib_dlarrd. the preference for scaling small values + ! comments in stdlib${ii}$_dlarrd. the preference for scaling small values ! up is heuristic; we expect users' matrices not to be close to the ! rmax threshold. scale = one - tnrm = stdlib_dlanst( 'M', n, d, e ) + tnrm = stdlib${ii}$_dlanst( 'M', n, d, e ) if( tnrm>zero .and. tnrmrmax ) then scale = rmax / tnrm end if if( scale/=one ) then - call stdlib_dscal( n, scale, d, 1 ) - call stdlib_dscal( n-1, scale, e, 1 ) + call stdlib${ii}$_dscal( n, scale, d, 1_${ik}$ ) + call stdlib${ii}$_dscal( n-1, scale, e, 1_${ik}$ ) tnrm = tnrm*scale if( valeig ) then ! if eigenvalues in interval have to be found, @@ -48582,19 +48585,19 @@ module stdlib_linalg_lapack_z ! compute the desired eigenvalues of the tridiagonal after splitting ! into smaller subblocks if the corresponding off-diagonal elements ! are small - ! thresh is the splitting parameter for stdlib_dlarre + ! thresh is the splitting parameter for stdlib${ii}$_dlarre ! a negative thresh forces the old splitting criterion based on the ! size of the off-diagonal. a positive thresh switches to splitting ! which preserves relative accuracy. if( tryrac ) then ! test whether the matrix warrants the more expensive relative approach. - call stdlib_dlarrr( n, d, e, iinfo ) + call stdlib${ii}$_dlarrr( n, d, e, iinfo ) else ! the user does not care about relative accurately eigenvalues - iinfo = -1 + iinfo = -1_${ik}$ endif ! set the splitting criterion - if (iinfo==0) then + if (iinfo==0_${ik}$) then thresh = eps else thresh = -eps @@ -48603,51 +48606,51 @@ module stdlib_linalg_lapack_z endif if( tryrac ) then ! copy original diagonal, needed to guarantee relative accuracy - call stdlib_dcopy(n,d,1,work(indd),1) + call stdlib${ii}$_dcopy(n,d,1_${ik}$,work(indd),1_${ik}$) endif ! store the squares of the offdiagonal values of t do j = 1, n-1 - work( inde2+j-1 ) = e(j)**2 + work( inde2+j-1 ) = e(j)**2_${ik}$ end do ! set the tolerance parameters for bisection if( .not.wantz ) then - ! stdlib_dlarre computes the eigenvalues to full precision. + ! stdlib${ii}$_dlarre computes the eigenvalues to full precision. rtol1 = four * eps rtol2 = four * eps else - ! stdlib_dlarre computes the eigenvalues to less than full precision. - ! stdlib_zlarrv will refine the eigenvalue approximations, and we only - ! need less accurate initial bisection in stdlib_dlarre. - ! note: these settings do only affect the subset case and stdlib_dlarre + ! stdlib${ii}$_dlarre computes the eigenvalues to less than full precision. + ! stdlib${ii}$_zlarrv will refine the eigenvalue approximations, and we only + ! need less accurate initial bisection in stdlib${ii}$_dlarre. + ! note: these settings do only affect the subset case and stdlib${ii}$_dlarre rtol1 = sqrt(eps) rtol2 = max( sqrt(eps)*5.0e-3_dp, four * eps ) endif - call stdlib_dlarre( range, n, wl, wu, iil, iiu, d, e,work(inde2), rtol1, rtol2, & + call stdlib${ii}$_dlarre( range, n, wl, wu, iil, iiu, d, e,work(inde2), rtol1, rtol2, & thresh, nsplit,iwork( iinspl ), m, w, work( inderr ),work( indgp ), iwork( iindbl ),& iwork( iindw ), work( indgrs ), pivmin,work( indwrk ), iwork( iindwk ), iinfo ) - if( iinfo/=0 ) then - info = 10 + abs( iinfo ) + if( iinfo/=0_${ik}$ ) then + info = 10_${ik}$ + abs( iinfo ) return end if - ! note that if range /= 'v', stdlib_dlarre computes bounds on the desired + ! note that if range /= 'v', stdlib${ii}$_dlarre computes bounds on the desired ! part of the spectrum. all desired eigenvalues are contained in ! (wl,wu] if( wantz ) then ! compute the desired eigenvectors corresponding to the computed ! eigenvalues - call stdlib_zlarrv( n, wl, wu, d, e,pivmin, iwork( iinspl ), m,1, m, minrgp, & + call stdlib${ii}$_zlarrv( n, wl, wu, d, e,pivmin, iwork( iinspl ), m,1_${ik}$, m, minrgp, & rtol1, rtol2,w, work( inderr ), work( indgp ), iwork( iindbl ),iwork( iindw ), & work( indgrs ), z, ldz,isuppz, work( indwrk ), iwork( iindwk ), iinfo ) - if( iinfo/=0 ) then - info = 20 + abs( iinfo ) + if( iinfo/=0_${ik}$ ) then + info = 20_${ik}$ + abs( iinfo ) return end if else - ! stdlib_dlarre computes eigenvalues of the (shifted) root representation - ! stdlib_zlarrv returns the eigenvalues of the unshifted matrix. + ! stdlib${ii}$_dlarre computes eigenvalues of the (shifted) root representation + ! stdlib${ii}$_zlarrv returns the eigenvalues of the unshifted matrix. ! however, if the eigenvectors are not desired by the user, we need - ! to apply the corresponding shifts from stdlib_dlarre to obtain the + ! to apply the corresponding shifts from stdlib${ii}$_dlarre to obtain the ! eigenvalues of the original matrix. do j = 1, m itmp = iwork( iindbl+j-1 ) @@ -48657,52 +48660,52 @@ module stdlib_linalg_lapack_z if ( tryrac ) then ! refine computed eigenvalues so that they are relatively accurate ! with respect to the original matrix t. - ibegin = 1 - wbegin = 1 + ibegin = 1_${ik}$ + wbegin = 1_${ik}$ loop_39: do jblk = 1, iwork( iindbl+m-1 ) iend = iwork( iinspl+jblk-1 ) - in = iend - ibegin + 1 - wend = wbegin - 1 + in = iend - ibegin + 1_${ik}$ + wend = wbegin - 1_${ik}$ ! check if any eigenvalues have to be refined in this block 36 continue if( wend1 .or. n==2 ) then + if( nsplit>1_${ik}$ .or. n==2_${ik}$ ) then if( .not. wantz ) then - call stdlib_dlasrt( 'I', m, w, iinfo ) - if( iinfo/=0 ) then - info = 3 + call stdlib${ii}$_dlasrt( 'I', m, w, iinfo ) + if( iinfo/=0_${ik}$ ) then + info = 3_${ik}$ return end if else do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp = w( j ) do jj = j + 1, m if( w( jj )eps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_zsytrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) - call stdlib_zaxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_zsytrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info ) + call stdlib${ii}$_zaxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -49058,22 +49061,22 @@ module stdlib_linalg_lapack_z rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**t). - call stdlib_zsytrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) + call stdlib${ii}$_zsytrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do - else if( kase==2 ) then + else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_zsytrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) + call stdlib${ii}$_zsytrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info ) end if go to 100 end if @@ -49085,10 +49088,10 @@ module stdlib_linalg_lapack_z if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_zsyrfs + end subroutine stdlib${ii}$_zsyrfs - pure subroutine stdlib_zsysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) + pure subroutine stdlib${ii}$_zsysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) !! ZSYSV computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS @@ -49105,68 +49108,68 @@ module stdlib_linalg_lapack_z ! -- 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, lwork, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, lwork, n, nrhs ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(dp), intent(inout) :: a(lda,*), b(ldb,*) complex(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: lwkopt + integer(${ik}$) :: lwkopt ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) if( .not.stdlib_lsame( uplo, 'U' ) .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 + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_zlansy( 'I', uplo, n, a, lda, rwork ) + anorm = stdlib${ii}$_zlansy( 'I', uplo, n, a, lda, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_zsycon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, info ) + call stdlib${ii}$_zsycon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, info ) ! compute the solution vectors x. - call stdlib_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_zsytrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info ) + call stdlib${ii}$_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_zsytrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_zsyrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & + call stdlib${ii}$_zsyrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & work, rwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond 0. if( anorm>zero ) then ! estimate the 1-norm of the inverse of a. ainvnm = zero normin = 'N' if( onenrm ) then - kase1 = 1 + kase1 = 1_${ik}$ else - kase1 = 2 + kase1 = 2_${ik}$ end if - kase = 0 + kase = 0_${ik}$ 10 continue - call stdlib_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + if( kase/=0_${ik}$ ) then if( kase==kase1 ) then ! multiply by inv(a). - call stdlib_zlatbs( uplo, 'NO TRANSPOSE', diag, normin, n, kd,ab, ldab, work, & + call stdlib${ii}$_zlatbs( uplo, 'NO TRANSPOSE', diag, normin, n, kd,ab, ldab, work, & scale, rwork, info ) else ! multiply by inv(a**h). - call stdlib_zlatbs( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, kd, ab, ldab,& + call stdlib${ii}$_zlatbs( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, kd, ab, ldab,& work, scale, rwork, info ) end if normin = 'Y' ! multiply by 1/scale if doing so will not cause overflow. if( scale/=one ) then - ix = stdlib_izamax( n, work, 1 ) + ix = stdlib${ii}$_izamax( n, work, 1_${ik}$ ) xnorm = cabs1( work( ix ) ) if( scale a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) - call stdlib_ztrtri( 'L', diag, n1, a( 0 ), n, info ) + call stdlib${ii}$_ztrtri( 'L', diag, n1, a( 0_${ik}$ ), n, info ) if( info>0 )return - call stdlib_ztrmm( 'R', 'L', 'N', diag, n2, n1, -cone, a( 0 ),n, a( n1 ), n ) + call stdlib${ii}$_ztrmm( 'R', 'L', 'N', diag, n2, n1, -cone, a( 0_${ik}$ ),n, a( n1 ), n ) - call stdlib_ztrtri( 'U', diag, n2, a( n ), n, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_ztrtri( 'U', diag, n2, a( n ), n, info ) + if( info>0_${ik}$ )info = info + n1 if( info>0 )return - call stdlib_ztrmm( 'L', 'U', 'C', diag, n2, n1, cone, a( n ), n,a( n1 ), n ) + call stdlib${ii}$_ztrmm( 'L', 'U', 'C', diag, n2, n1, cone, a( n ), n,a( n1 ), n ) else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) - call stdlib_ztrtri( 'L', diag, n1, a( n2 ), n, info ) + call stdlib${ii}$_ztrtri( 'L', diag, n1, a( n2 ), n, info ) if( info>0 )return - call stdlib_ztrmm( 'L', 'L', 'C', diag, n1, n2, -cone, a( n2 ),n, a( 0 ), n ) + call stdlib${ii}$_ztrmm( 'L', 'L', 'C', diag, n1, n2, -cone, a( n2 ),n, a( 0_${ik}$ ), n ) - call stdlib_ztrtri( 'U', diag, n2, a( n1 ), n, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_ztrtri( 'U', diag, n2, a( n1 ), n, info ) + if( info>0_${ik}$ )info = info + n1 if( info>0 )return - call stdlib_ztrmm( 'R', 'U', 'N', diag, n1, n2, cone, a( n1 ),n, a( 0 ), n ) + call stdlib${ii}$_ztrmm( 'R', 'U', 'N', diag, n1, n2, cone, a( n1 ),n, a( 0_${ik}$ ), n ) end if else @@ -49622,26 +49625,26 @@ module stdlib_linalg_lapack_z if( lower ) then ! srpa for lower, transpose and n is odd ! t1 -> a(0), t2 -> a(1), s -> a(0+n1*n1) - call stdlib_ztrtri( 'U', diag, n1, a( 0 ), n1, info ) + call stdlib${ii}$_ztrtri( 'U', diag, n1, a( 0_${ik}$ ), n1, info ) if( info>0 )return - call stdlib_ztrmm( 'L', 'U', 'N', diag, n1, n2, -cone, a( 0 ),n1, a( n1*n1 ), & + call stdlib${ii}$_ztrmm( 'L', 'U', 'N', diag, n1, n2, -cone, a( 0_${ik}$ ),n1, a( n1*n1 ), & n1 ) - call stdlib_ztrtri( 'L', diag, n2, a( 1 ), n1, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_ztrtri( 'L', diag, n2, a( 1_${ik}$ ), n1, info ) + if( info>0_${ik}$ )info = info + n1 if( info>0 )return - call stdlib_ztrmm( 'R', 'L', 'C', diag, n1, n2, cone, a( 1 ),n1, a( n1*n1 ), & + call stdlib${ii}$_ztrmm( 'R', 'L', 'C', diag, n1, n2, cone, a( 1_${ik}$ ),n1, a( n1*n1 ), & n1 ) else ! srpa for upper, transpose and n is odd ! t1 -> a(0+n2*n2), t2 -> a(0+n1*n2), s -> a(0) - call stdlib_ztrtri( 'U', diag, n1, a( n2*n2 ), n2, info ) + call stdlib${ii}$_ztrtri( 'U', diag, n1, a( n2*n2 ), n2, info ) if( info>0 )return - call stdlib_ztrmm( 'R', 'U', 'C', diag, n2, n1, -cone,a( n2*n2 ), n2, a( 0 ), & + call stdlib${ii}$_ztrmm( 'R', 'U', 'C', diag, n2, n1, -cone,a( n2*n2 ), n2, a( 0_${ik}$ ), & n2 ) - call stdlib_ztrtri( 'L', diag, n2, a( n1*n2 ), n2, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_ztrtri( 'L', diag, n2, a( n1*n2 ), n2, info ) + if( info>0_${ik}$ )info = info + n1 if( info>0 )return - call stdlib_ztrmm( 'L', 'L', 'N', diag, n2, n1, cone,a( n1*n2 ), n2, a( 0 ), & + call stdlib${ii}$_ztrmm( 'L', 'L', 'N', diag, n2, n1, cone,a( n1*n2 ), n2, a( 0_${ik}$ ), & n2 ) end if end if @@ -49653,27 +49656,27 @@ module stdlib_linalg_lapack_z ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) - call stdlib_ztrtri( 'L', diag, k, a( 1 ), n+1, info ) + call stdlib${ii}$_ztrtri( 'L', diag, k, a( 1_${ik}$ ), n+1, info ) if( info>0 )return - call stdlib_ztrmm( 'R', 'L', 'N', diag, k, k, -cone, a( 1 ),n+1, a( k+1 ), n+& - 1 ) - call stdlib_ztrtri( 'U', diag, k, a( 0 ), n+1, info ) - if( info>0 )info = info + k + call stdlib${ii}$_ztrmm( 'R', 'L', 'N', diag, k, k, -cone, a( 1_${ik}$ ),n+1, a( k+1 ), n+& + 1_${ik}$ ) + call stdlib${ii}$_ztrtri( 'U', diag, k, a( 0_${ik}$ ), n+1, info ) + if( info>0_${ik}$ )info = info + k if( info>0 )return - call stdlib_ztrmm( 'L', 'U', 'C', diag, k, k, cone, a( 0 ), n+1,a( k+1 ), n+1 & + call stdlib${ii}$_ztrmm( 'L', 'U', 'C', diag, k, k, cone, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 & ) else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) - call stdlib_ztrtri( 'L', diag, k, a( k+1 ), n+1, info ) + call stdlib${ii}$_ztrtri( 'L', diag, k, a( k+1 ), n+1, info ) if( info>0 )return - call stdlib_ztrmm( 'L', 'L', 'C', diag, k, k, -cone, a( k+1 ),n+1, a( 0 ), n+& - 1 ) - call stdlib_ztrtri( 'U', diag, k, a( k ), n+1, info ) - if( info>0 )info = info + k + call stdlib${ii}$_ztrmm( 'L', 'L', 'C', diag, k, k, -cone, a( k+1 ),n+1, a( 0_${ik}$ ), n+& + 1_${ik}$ ) + call stdlib${ii}$_ztrtri( 'U', diag, k, a( k ), n+1, info ) + if( info>0_${ik}$ )info = info + k if( info>0 )return - call stdlib_ztrmm( 'R', 'U', 'N', diag, k, k, cone, a( k ), n+1,a( 0 ), n+1 ) + call stdlib${ii}$_ztrmm( 'R', 'U', 'N', diag, k, k, cone, a( k ), n+1,a( 0_${ik}$ ), n+1 ) end if else @@ -49682,36 +49685,36 @@ module stdlib_linalg_lapack_z ! srpa for lower, transpose and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1) ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k - call stdlib_ztrtri( 'U', diag, k, a( k ), k, info ) + call stdlib${ii}$_ztrtri( 'U', diag, k, a( k ), k, info ) if( info>0 )return - call stdlib_ztrmm( 'L', 'U', 'N', diag, k, k, -cone, a( k ), k,a( k*( k+1 ) ),& + call stdlib${ii}$_ztrmm( 'L', 'U', 'N', diag, k, k, -cone, a( k ), k,a( k*( k+1 ) ),& k ) - call stdlib_ztrtri( 'L', diag, k, a( 0 ), k, info ) - if( info>0 )info = info + k + call stdlib${ii}$_ztrtri( 'L', diag, k, a( 0_${ik}$ ), k, info ) + if( info>0_${ik}$ )info = info + k if( info>0 )return - call stdlib_ztrmm( 'R', 'L', 'C', diag, k, k, cone, a( 0 ), k,a( k*( k+1 ) ), & + call stdlib${ii}$_ztrmm( 'R', 'L', 'C', diag, k, k, cone, a( 0_${ik}$ ), k,a( k*( k+1 ) ), & k ) else ! srpa for upper, transpose and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0) ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k - call stdlib_ztrtri( 'U', diag, k, a( k*( k+1 ) ), k, info ) + call stdlib${ii}$_ztrtri( 'U', diag, k, a( k*( k+1 ) ), k, info ) if( info>0 )return - call stdlib_ztrmm( 'R', 'U', 'C', diag, k, k, -cone,a( k*( k+1 ) ), k, a( 0 ),& + call stdlib${ii}$_ztrmm( 'R', 'U', 'C', diag, k, k, -cone,a( k*( k+1 ) ), k, a( 0_${ik}$ ),& k ) - call stdlib_ztrtri( 'L', diag, k, a( k*k ), k, info ) - if( info>0 )info = info + k + call stdlib${ii}$_ztrtri( 'L', diag, k, a( k*k ), k, info ) + if( info>0_${ik}$ )info = info + k if( info>0 )return - call stdlib_ztrmm( 'L', 'L', 'N', diag, k, k, cone, a( k*k ), k,a( 0 ), k ) + call stdlib${ii}$_ztrmm( 'L', 'L', 'N', diag, k, k, cone, a( k*k ), k,a( 0_${ik}$ ), k ) end if end if end if return - end subroutine stdlib_ztftri + end subroutine stdlib${ii}$_ztftri - pure subroutine stdlib_ztgsja( jobu, jobv, jobq, m, p, n, k, l, a, lda, b,ldb, tola, tolb, & + pure subroutine stdlib${ii}$_ztgsja( jobu, jobv, jobq, m, p, n, k, l, a, lda, b,ldb, tola, tolb, & !! ZTGSJA computes the generalized singular value decomposition (GSVD) !! of two complex upper triangular (or trapezoidal) matrices A and B. !! On entry, it is assumed that matrices A and B have the following @@ -49780,8 +49783,8 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobq, jobu, jobv - integer(ilp), intent(out) :: info, ncycle - integer(ilp), intent(in) :: k, l, lda, ldb, ldq, ldu, ldv, m, n, p + integer(${ik}$), intent(out) :: info, ncycle + integer(${ik}$), intent(in) :: k, l, lda, ldb, ldq, ldu, ldv, m, n, p real(dp), intent(in) :: tola, tolb ! Array Arguments real(dp), intent(out) :: alpha(*), beta(*) @@ -49789,14 +49792,14 @@ module stdlib_linalg_lapack_z complex(dp), intent(out) :: work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: maxit = 40 + integer(${ik}$), parameter :: maxit = 40_${ik}$ real(dp), parameter :: hugenum = huge(zero) ! Local Scalars logical(lk) :: initq, initu, initv, upper, wantq, wantu, wantv - integer(ilp) :: i, j, kcycle + integer(${ik}$) :: i, j, kcycle real(dp) :: a1, a3, b1, b3, csq, csu, csv, error, gamma, rwk, ssmin complex(dp) :: a2, b2, snq, snu, snv ! Intrinsic Functions @@ -49809,38 +49812,38 @@ module stdlib_linalg_lapack_z wantv = initv .or. stdlib_lsame( jobv, 'V' ) initq = stdlib_lsame( jobq, 'I' ) wantq = initq .or. stdlib_lsame( jobq, 'Q' ) - info = 0 + info = 0_${ik}$ if( .not.( initu .or. wantu .or. stdlib_lsame( jobu, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( initv .or. wantv .or. stdlib_lsame( jobv, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( initq .or. wantq .or. stdlib_lsame( jobq, 'N' ) ) ) then - info = -3 - else if( m<0 ) then - info = -4 - else if( p<0 ) then - info = -5 - else if( n<0 ) then - info = -6 - else if( lda=-hugenum) ) then if( gamma=beta( k+i ) ) then - call stdlib_zdscal( l-i+1, one / alpha( k+i ), a( k+i, n-l+i ),lda ) + call stdlib${ii}$_zdscal( l-i+1, one / alpha( k+i ), a( k+i, n-l+i ),lda ) else - call stdlib_zdscal( l-i+1, one / beta( k+i ), b( i, n-l+i ),ldb ) - call stdlib_zcopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) + call stdlib${ii}$_zdscal( l-i+1, one / beta( k+i ), b( i, n-l+i ),ldb ) + call stdlib${ii}$_zcopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) end if else alpha( k+i ) = zero beta( k+i ) = one - call stdlib_zcopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) + call stdlib${ii}$_zcopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),lda ) end if end do ! post-assignment @@ -49957,10 +49960,10 @@ module stdlib_linalg_lapack_z 100 continue ncycle = kcycle return - end subroutine stdlib_ztgsja + end subroutine stdlib${ii}$_ztgsja - pure subroutine stdlib_ztgsy2( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f, & + pure subroutine stdlib${ii}$_ztgsy2( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f, & !! ZTGSY2 solves the generalized Sylvester equation !! A * R - L * B = scale * C (1) !! D * R - L * E = scale * F @@ -49992,8 +49995,8 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: trans - integer(ilp), intent(in) :: ijob, lda, ldb, ldc, ldd, lde, ldf, m, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ijob, lda, ldb, ldc, ldd, lde, ldf, m, n + integer(${ik}$), intent(out) :: info real(dp), intent(inout) :: rdscal, rdsum real(dp), intent(out) :: scale ! Array Arguments @@ -50001,52 +50004,52 @@ module stdlib_linalg_lapack_z complex(dp), intent(inout) :: c(ldc,*), f(ldf,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: ldz = 2 + integer(${ik}$), parameter :: ldz = 2_${ik}$ ! Local Scalars logical(lk) :: notran - integer(ilp) :: i, ierr, j, k + integer(${ik}$) :: i, ierr, j, k real(dp) :: scaloc complex(dp) :: alpha ! Local Arrays - integer(ilp) :: ipiv(ldz), jpiv(ldz) + integer(${ik}$) :: ipiv(ldz), jpiv(ldz) complex(dp) :: rhs(ldz), z(ldz,ldz) ! Intrinsic Functions intrinsic :: cmplx,conjg,max ! Executable Statements ! decode and test input parameters - info = 0 - ierr = 0 + info = 0_${ik}$ + ierr = 0_${ik}$ notran = stdlib_lsame( trans, 'N' ) if( .not.notran .and. .not.stdlib_lsame( trans, 'C' ) ) then - info = -1 + info = -1_${ik}$ else if( notran ) then - if( ( ijob<0 ) .or. ( ijob>2 ) ) then - info = -2 + if( ( ijob<0_${ik}$ ) .or. ( ijob>2_${ik}$ ) ) then + info = -2_${ik}$ end if end if - if( info==0 ) then - if( m<=0 ) then - info = -3 - else if( n<=0 ) then - info = -4 - else if( lda0 )info = ierr - if( ijob==0 ) then - call stdlib_zgesc2( ldz, z, ldz, rhs, ipiv, jpiv, scaloc ) + call stdlib${ii}$_zgetc2( ldz, z, ldz, ipiv, jpiv, ierr ) + if( ierr>0_${ik}$ )info = ierr + if( ijob==0_${ik}$ ) then + call stdlib${ii}$_zgesc2( ldz, z, ldz, rhs, ipiv, jpiv, scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_zscal( m, cmplx( scaloc, zero,KIND=dp),c( 1, k ), 1 ) + call stdlib${ii}$_zscal( m, cmplx( scaloc, zero,KIND=dp),c( 1_${ik}$, k ), 1_${ik}$ ) - call stdlib_zscal( m, cmplx( scaloc, zero,KIND=dp),f( 1, k ), 1 ) + call stdlib${ii}$_zscal( m, cmplx( scaloc, zero,KIND=dp),f( 1_${ik}$, k ), 1_${ik}$ ) end do scale = scale*scaloc end if else - call stdlib_zlatdf( ijob, ldz, z, ldz, rhs, rdsum, rdscal,ipiv, jpiv ) + call stdlib${ii}$_zlatdf( ijob, ldz, z, ldz, rhs, rdsum, rdscal,ipiv, jpiv ) end if ! unpack solution vector(s) - c( i, j ) = rhs( 1 ) - f( i, j ) = rhs( 2 ) + c( i, j ) = rhs( 1_${ik}$ ) + f( i, j ) = rhs( 2_${ik}$ ) ! substitute r(i, j) and l(i, j) into remaining equation. - if( i>1 ) then - alpha = -rhs( 1 ) - call stdlib_zaxpy( i-1, alpha, a( 1, i ), 1, c( 1, j ), 1 ) - call stdlib_zaxpy( i-1, alpha, d( 1, i ), 1, f( 1, j ), 1 ) + if( i>1_${ik}$ ) then + alpha = -rhs( 1_${ik}$ ) + call stdlib${ii}$_zaxpy( i-1, alpha, a( 1_${ik}$, i ), 1_${ik}$, c( 1_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_zaxpy( i-1, alpha, d( 1_${ik}$, i ), 1_${ik}$, f( 1_${ik}$, j ), 1_${ik}$ ) end if if( j0 )info = ierr - call stdlib_zgesc2( ldz, z, ldz, rhs, ipiv, jpiv, scaloc ) + call stdlib${ii}$_zgetc2( ldz, z, ldz, ipiv, jpiv, ierr ) + if( ierr>0_${ik}$ )info = ierr + call stdlib${ii}$_zgesc2( ldz, z, ldz, rhs, ipiv, jpiv, scaloc ) if( scaloc/=one ) then do k = 1, n - call stdlib_zscal( m, cmplx( scaloc, zero,KIND=dp), c( 1, k ),1 ) + call stdlib${ii}$_zscal( m, cmplx( scaloc, zero,KIND=dp), c( 1_${ik}$, k ),1_${ik}$ ) - call stdlib_zscal( m, cmplx( scaloc, zero,KIND=dp), f( 1, k ),1 ) + call stdlib${ii}$_zscal( m, cmplx( scaloc, zero,KIND=dp), f( 1_${ik}$, k ),1_${ik}$ ) end do scale = scale*scaloc end if ! unpack solution vector(s) - c( i, j ) = rhs( 1 ) - f( i, j ) = rhs( 2 ) + c( i, j ) = rhs( 1_${ik}$ ) + f( i, j ) = rhs( 2_${ik}$ ) ! substitute r(i, j) and l(i, j) into remaining equation. do k = 1, j - 1 - f( i, k ) = f( i, k ) + rhs( 1 )*conjg( b( k, j ) ) +rhs( 2 )*conjg( e( k, & + f( i, k ) = f( i, k ) + rhs( 1_${ik}$ )*conjg( b( k, j ) ) +rhs( 2_${ik}$ )*conjg( e( k, & j ) ) end do do k = i + 1, m - c( k, j ) = c( k, j ) - conjg( a( i, k ) )*rhs( 1 ) -conjg( d( i, k ) )& - *rhs( 2 ) + c( k, j ) = c( k, j ) - conjg( a( i, k ) )*rhs( 1_${ik}$ ) -conjg( d( i, k ) )& + *rhs( 2_${ik}$ ) end do end do loop_70 end do loop_80 end if return - end subroutine stdlib_ztgsy2 + end subroutine stdlib${ii}$_ztgsy2 - pure subroutine stdlib_ztgsyl( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f, & + pure subroutine stdlib${ii}$_ztgsyl( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f, & !! ZTGSYL solves the generalized Sylvester equation: !! A * R - L * B = scale * C (1) !! D * R - L * E = scale * F @@ -50184,249 +50187,249 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: trans - integer(ilp), intent(in) :: ijob, lda, ldb, ldc, ldd, lde, ldf, lwork, m, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ijob, lda, ldb, ldc, ldd, lde, ldf, lwork, m, n + integer(${ik}$), intent(out) :: info real(dp), intent(out) :: dif, scale ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) complex(dp), intent(in) :: a(lda,*), b(ldb,*), d(ldd,*), e(lde,*) complex(dp), intent(inout) :: c(ldc,*), f(ldf,*) complex(dp), intent(out) :: work(*) ! ===================================================================== - ! replaced various illegal calls to stdlib_ccopy by calls to stdlib_claset. + ! replaced various illegal calls to stdlib${ii}$_ccopy by calls to stdlib${ii}$_claset. ! sven hammarling, 1/5/02. ! Local Scalars logical(lk) :: lquery, notran - integer(ilp) :: i, ie, ifunc, iround, is, isolve, j, je, js, k, linfo, lwmin, mb, nb, & + integer(${ik}$) :: i, ie, ifunc, iround, is, isolve, j, je, js, k, linfo, lwmin, mb, nb, & p, pq, q real(dp) :: dscale, dsum, scale2, scaloc ! Intrinsic Functions intrinsic :: real,cmplx,max,sqrt ! Executable Statements ! decode and test input parameters - info = 0 + info = 0_${ik}$ notran = stdlib_lsame( trans, 'N' ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) if( .not.notran .and. .not.stdlib_lsame( trans, 'C' ) ) then - info = -1 + info = -1_${ik}$ else if( notran ) then - if( ( ijob<0 ) .or. ( ijob>4 ) ) then - info = -2 - end if - end if - if( info==0 ) then - if( m<=0 ) then - info = -3 - else if( n<=0 ) then - info = -4 - else if( lda4_${ik}$ ) ) then + info = -2_${ik}$ + end if + end if + if( info==0_${ik}$ ) then + if( m<=0_${ik}$ ) then + info = -3_${ik}$ + else if( n<=0_${ik}$ ) then + info = -4_${ik}$ + else if( lda=3 ) then - ifunc = ijob - 2 - call stdlib_zlaset( 'F', m, n, czero, czero, c, ldc ) - call stdlib_zlaset( 'F', m, n, czero, czero, f, ldf ) - else if( ijob>=1 .and. notran ) then - isolve = 2 + if( ijob>=3_${ik}$ ) then + ifunc = ijob - 2_${ik}$ + call stdlib${ii}$_zlaset( 'F', m, n, czero, czero, c, ldc ) + call stdlib${ii}$_zlaset( 'F', m, n, czero, czero, f, ldf ) + else if( ijob>=1_${ik}$ .and. notran ) then + isolve = 2_${ik}$ end if end if - if( ( mb<=1 .and. nb<=1 ) .or. ( mb>=m .and. nb>=n ) )then + if( ( mb<=1_${ik}$ .and. nb<=1_${ik}$ ) .or. ( mb>=m .and. nb>=n ) )then ! use unblocked level 2 solver loop_30: do iround = 1, isolve scale = one dscale = zero dsum = one pq = m*n - call stdlib_ztgsy2( trans, ifunc, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f,& + call stdlib${ii}$_ztgsy2( trans, ifunc, m, n, a, lda, b, ldb, c, ldc, d,ldd, e, lde, f,& ldf, scale, dsum, dscale,info ) if( dscale/=zero ) then - if( ijob==1 .or. ijob==3 ) then - dif = sqrt( real( 2*m*n,KIND=dp) ) / ( dscale*sqrt( dsum ) ) + if( ijob==1_${ik}$ .or. ijob==3_${ik}$ ) then + dif = sqrt( real( 2_${ik}$*m*n,KIND=dp) ) / ( dscale*sqrt( dsum ) ) else dif = sqrt( real( pq,KIND=dp) ) / ( dscale*sqrt( dsum ) ) end if end if - if( isolve==2 .and. iround==1 ) then + if( isolve==2_${ik}$ .and. iround==1_${ik}$ ) then if( notran ) then ifunc = ijob end if scale2 = scale - call stdlib_zlacpy( 'F', m, n, c, ldc, work, m ) - call stdlib_zlacpy( 'F', m, n, f, ldf, work( m*n+1 ), m ) - call stdlib_zlaset( 'F', m, n, czero, czero, c, ldc ) - call stdlib_zlaset( 'F', m, n, czero, czero, f, ldf ) - else if( isolve==2 .and. iround==2 ) then - call stdlib_zlacpy( 'F', m, n, work, m, c, ldc ) - call stdlib_zlacpy( 'F', m, n, work( m*n+1 ), m, f, ldf ) + call stdlib${ii}$_zlacpy( 'F', m, n, c, ldc, work, m ) + call stdlib${ii}$_zlacpy( 'F', m, n, f, ldf, work( m*n+1 ), m ) + call stdlib${ii}$_zlaset( 'F', m, n, czero, czero, c, ldc ) + call stdlib${ii}$_zlaset( 'F', m, n, czero, czero, f, ldf ) + else if( isolve==2_${ik}$ .and. iround==2_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'F', m, n, work, m, c, ldc ) + call stdlib${ii}$_zlacpy( 'F', m, n, work( m*n+1 ), m, f, ldf ) scale = scale2 end if end do loop_30 return end if ! determine block structure of a - p = 0 - i = 1 + p = 0_${ik}$ + i = 1_${ik}$ 40 continue if( i>m )go to 50 - p = p + 1 + p = p + 1_${ik}$ iwork( p ) = i i = i + mb if( i>=m )go to 50 go to 40 50 continue - iwork( p+1 ) = m + 1 - if( iwork( p )==iwork( p+1 ) )p = p - 1 + iwork( p+1 ) = m + 1_${ik}$ + if( iwork( p )==iwork( p+1 ) )p = p - 1_${ik}$ ! determine block structure of b - q = p + 1 - j = 1 + q = p + 1_${ik}$ + j = 1_${ik}$ 60 continue if( j>n )go to 70 - q = q + 1 + q = q + 1_${ik}$ iwork( q ) = j j = j + nb if( j>=n )go to 70 go to 60 70 continue - iwork( q+1 ) = n + 1 - if( iwork( q )==iwork( q+1 ) )q = q - 1 + iwork( q+1 ) = n + 1_${ik}$ + if( iwork( q )==iwork( q+1 ) )q = q - 1_${ik}$ if( notran ) then loop_150: do iround = 1, isolve ! solve (i, j) - subsystem ! a(i, i) * r(i, j) - l(i, j) * b(j, j) = c(i, j) ! d(i, i) * r(i, j) - l(i, j) * e(j, j) = f(i, j) ! for i = p, p - 1, ..., 1; j = 1, 2, ..., q - pq = 0 + pq = 0_${ik}$ scale = one dscale = zero dsum = one loop_130: do j = p + 2, q js = iwork( j ) - je = iwork( j+1 ) - 1 - nb = je - js + 1 + je = iwork( j+1 ) - 1_${ik}$ + nb = je - js + 1_${ik}$ loop_120: do i = p, 1, -1 is = iwork( i ) - ie = iwork( i+1 ) - 1 - mb = ie - is + 1 - call stdlib_ztgsy2( trans, ifunc, mb, nb, a( is, is ), lda,b( js, js ), & + ie = iwork( i+1 ) - 1_${ik}$ + mb = ie - is + 1_${ik}$ + call stdlib${ii}$_ztgsy2( trans, ifunc, mb, nb, a( is, is ), lda,b( js, js ), & ldb, c( is, js ), ldc,d( is, is ), ldd, e( js, js ), lde,f( is, js ), ldf, & scaloc, dsum, dscale,linfo ) - if( linfo>0 )info = linfo + if( linfo>0_${ik}$ )info = linfo pq = pq + mb*nb if( scaloc/=one ) then do k = 1, js - 1 - call stdlib_zscal( m, cmplx( scaloc, zero,KIND=dp),c( 1, k ), 1 ) + call stdlib${ii}$_zscal( m, cmplx( scaloc, zero,KIND=dp),c( 1_${ik}$, k ), 1_${ik}$ ) - call stdlib_zscal( m, cmplx( scaloc, zero,KIND=dp),f( 1, k ), 1 ) + call stdlib${ii}$_zscal( m, cmplx( scaloc, zero,KIND=dp),f( 1_${ik}$, k ), 1_${ik}$ ) end do do k = js, je - call stdlib_zscal( is-1, cmplx( scaloc, zero,KIND=dp),c( 1, k ), 1 ) + call stdlib${ii}$_zscal( is-1, cmplx( scaloc, zero,KIND=dp),c( 1_${ik}$, k ), 1_${ik}$ ) - call stdlib_zscal( is-1, cmplx( scaloc, zero,KIND=dp),f( 1, k ), 1 ) + call stdlib${ii}$_zscal( is-1, cmplx( scaloc, zero,KIND=dp),f( 1_${ik}$, k ), 1_${ik}$ ) end do do k = js, je - call stdlib_zscal( m-ie, cmplx( scaloc, zero,KIND=dp),c( ie+1, k ), & - 1 ) - call stdlib_zscal( m-ie, cmplx( scaloc, zero,KIND=dp),f( ie+1, k ), & - 1 ) + call stdlib${ii}$_zscal( m-ie, cmplx( scaloc, zero,KIND=dp),c( ie+1, k ), & + 1_${ik}$ ) + call stdlib${ii}$_zscal( m-ie, cmplx( scaloc, zero,KIND=dp),f( ie+1, k ), & + 1_${ik}$ ) end do do k = je + 1, n - call stdlib_zscal( m, cmplx( scaloc, zero,KIND=dp),c( 1, k ), 1 ) + call stdlib${ii}$_zscal( m, cmplx( scaloc, zero,KIND=dp),c( 1_${ik}$, k ), 1_${ik}$ ) - call stdlib_zscal( m, cmplx( scaloc, zero,KIND=dp),f( 1, k ), 1 ) + call stdlib${ii}$_zscal( m, cmplx( scaloc, zero,KIND=dp),f( 1_${ik}$, k ), 1_${ik}$ ) end do scale = scale*scaloc end if ! substitute r(i,j) and l(i,j) into remaining equation. - if( i>1 ) then - call stdlib_zgemm( 'N', 'N', is-1, nb, mb,cmplx( -one, zero,KIND=dp), a(& - 1, is ), lda,c( is, js ), ldc, cmplx( one, zero,KIND=dp),c( 1, js ), & + if( i>1_${ik}$ ) then + call stdlib${ii}$_zgemm( 'N', 'N', is-1, nb, mb,cmplx( -one, zero,KIND=dp), a(& + 1_${ik}$, is ), lda,c( is, js ), ldc, cmplx( one, zero,KIND=dp),c( 1_${ik}$, js ), & ldc ) - call stdlib_zgemm( 'N', 'N', is-1, nb, mb,cmplx( -one, zero,KIND=dp), d(& - 1, is ), ldd,c( is, js ), ldc, cmplx( one, zero,KIND=dp),f( 1, js ), & + call stdlib${ii}$_zgemm( 'N', 'N', is-1, nb, mb,cmplx( -one, zero,KIND=dp), d(& + 1_${ik}$, is ), ldd,c( is, js ), ldc, cmplx( one, zero,KIND=dp),f( 1_${ik}$, js ), & ldf ) end if if( j0 )info = linfo + if( linfo>0_${ik}$ )info = linfo if( scaloc/=one ) then do k = 1, js - 1 - call stdlib_zscal( m, cmplx( scaloc, zero,KIND=dp), c( 1, k ),1 ) + call stdlib${ii}$_zscal( m, cmplx( scaloc, zero,KIND=dp), c( 1_${ik}$, k ),1_${ik}$ ) - call stdlib_zscal( m, cmplx( scaloc, zero,KIND=dp), f( 1, k ),1 ) + call stdlib${ii}$_zscal( m, cmplx( scaloc, zero,KIND=dp), f( 1_${ik}$, k ),1_${ik}$ ) end do do k = js, je - call stdlib_zscal( is-1, cmplx( scaloc, zero,KIND=dp),c( 1, k ), 1 ) + call stdlib${ii}$_zscal( is-1, cmplx( scaloc, zero,KIND=dp),c( 1_${ik}$, k ), 1_${ik}$ ) - call stdlib_zscal( is-1, cmplx( scaloc, zero,KIND=dp),f( 1, k ), 1 ) + call stdlib${ii}$_zscal( is-1, cmplx( scaloc, zero,KIND=dp),f( 1_${ik}$, k ), 1_${ik}$ ) end do do k = js, je - call stdlib_zscal( m-ie, cmplx( scaloc, zero,KIND=dp),c( ie+1, k ), 1 ) + call stdlib${ii}$_zscal( m-ie, cmplx( scaloc, zero,KIND=dp),c( ie+1, k ), 1_${ik}$ ) - call stdlib_zscal( m-ie, cmplx( scaloc, zero,KIND=dp),f( ie+1, k ), 1 ) + call stdlib${ii}$_zscal( m-ie, cmplx( scaloc, zero,KIND=dp),f( ie+1, k ), 1_${ik}$ ) end do do k = je + 1, n - call stdlib_zscal( m, cmplx( scaloc, zero,KIND=dp), c( 1, k ),1 ) + call stdlib${ii}$_zscal( m, cmplx( scaloc, zero,KIND=dp), c( 1_${ik}$, k ),1_${ik}$ ) - call stdlib_zscal( m, cmplx( scaloc, zero,KIND=dp), f( 1, k ),1 ) + call stdlib${ii}$_zscal( m, cmplx( scaloc, zero,KIND=dp), f( 1_${ik}$, k ),1_${ik}$ ) end do scale = scale*scaloc end if ! substitute r(i,j) and l(i,j) into remaining equation. if( j>p+2 ) then - call stdlib_zgemm( 'N', 'C', mb, js-1, nb,cmplx( one, zero,KIND=dp), c( is,& - js ), ldc,b( 1, js ), ldb, cmplx( one, zero,KIND=dp),f( is, 1 ), ldf ) + call stdlib${ii}$_zgemm( 'N', 'C', mb, js-1, nb,cmplx( one, zero,KIND=dp), c( is,& + js ), ldc,b( 1_${ik}$, js ), ldb, cmplx( one, zero,KIND=dp),f( is, 1_${ik}$ ), ldf ) - call stdlib_zgemm( 'N', 'C', mb, js-1, nb,cmplx( one, zero,KIND=dp), f( is,& - js ), ldf,e( 1, js ), lde, cmplx( one, zero,KIND=dp),f( is, 1 ), ldf ) + call stdlib${ii}$_zgemm( 'N', 'C', mb, js-1, nb,cmplx( one, zero,KIND=dp), f( is,& + js ), ldf,e( 1_${ik}$, js ), lde, cmplx( one, zero,KIND=dp),f( is, 1_${ik}$ ), ldf ) end if if( i

0. if( anorm>zero ) then ! estimate the norm of the inverse of a. ainvnm = zero normin = 'N' if( onenrm ) then - kase1 = 1 + kase1 = 1_${ik}$ else - kase1 = 2 + kase1 = 2_${ik}$ end if - kase = 0 + kase = 0_${ik}$ 10 continue - call stdlib_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + if( kase/=0_${ik}$ ) then if( kase==kase1 ) then ! multiply by inv(a). - call stdlib_zlatps( uplo, 'NO TRANSPOSE', diag, normin, n, ap,work, scale, & + call stdlib${ii}$_zlatps( uplo, 'NO TRANSPOSE', diag, normin, n, ap,work, scale, & rwork, info ) else ! multiply by inv(a**h). - call stdlib_zlatps( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, ap, work, & + call stdlib${ii}$_zlatps( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, ap, work, & scale, rwork, info ) end if normin = 'Y' ! multiply by 1/scale if doing so will not cause overflow. if( scale/=one ) then - ix = stdlib_izamax( n, work, 1 ) + ix = stdlib${ii}$_izamax( n, work, 1_${ik}$ ) xnorm = cabs1( work( ix ) ) if( scalemin(m,n) .and. min(m,n)>=0)) then - info = -3 - else if( mb<1 .or. (mb>m .and. m>0)) then - info = -4 - else if( ldamin(m,n) .and. min(m,n)>=0_${ik}$)) then + info = -3_${ik}$ + else if( mb<1_${ik}$ .or. (mb>m .and. m>0_${ik}$)) then + info = -4_${ik}$ + else if( lda=l ) then - lb = 0 + lb = 0_${ik}$ else lb = nb-n+l-i+1 end if - call stdlib_ztplqt2( ib, nb, lb, a(i,i), lda, b( i, 1 ), ldb,t(1, i ), ldt, iinfo ) + call stdlib${ii}$_ztplqt2( ib, nb, lb, a(i,i), lda, b( i, 1_${ik}$ ), ldb,t(1_${ik}$, i ), ldt, iinfo ) ! update by applying h**t to b(i+ib:m,:) from the right if( i+ib<=m ) then - call stdlib_ztprfb( 'R', 'N', 'F', 'R', m-i-ib+1, nb, ib, lb,b( i, 1 ), ldb, t( & - 1, i ), ldt,a( i+ib, i ), lda, b( i+ib, 1 ), ldb,work, m-i-ib+1) + call stdlib${ii}$_ztprfb( 'R', 'N', 'F', 'R', m-i-ib+1, nb, ib, lb,b( i, 1_${ik}$ ), ldb, t( & + 1_${ik}$, i ), ldt,a( i+ib, i ), lda, b( i+ib, 1_${ik}$ ), ldb,work, m-i-ib+1) end if end do return - end subroutine stdlib_ztplqt + end subroutine stdlib${ii}$_ztplqt - pure subroutine stdlib_ztpmlqt( side, trans, m, n, k, l, mb, v, ldv, t, ldt,a, lda, b, ldb, & + pure subroutine stdlib${ii}$_ztpmlqt( side, trans, m, n, k, l, mb, v, ldv, t, ldt,a, lda, b, ldb, & !! ZTPMLQT applies a complex unitary matrix Q obtained from a !! "triangular-pentagonal" complex block reflector H to a general !! complex matrix C, which consists of two blocks A and B. @@ -50676,8 +50679,8 @@ module stdlib_linalg_lapack_z ! -- 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, lda, ldb, m, n, l, mb, ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k, ldv, lda, ldb, m, n, l, mb, ldt ! Array Arguments complex(dp), intent(in) :: v(ldv,*), t(ldt,*) complex(dp), intent(inout) :: a(lda,*), b(ldb,*) @@ -50685,46 +50688,46 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran - integer(ilp) :: i, ib, nb, lb, kf, ldaq + integer(${ik}$) :: i, ib, nb, lb, kf, ldaq ! 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, 'C' ) notran = stdlib_lsame( trans, 'N' ) if ( left ) then - ldaq = max( 1, k ) + ldaq = max( 1_${ik}$, k ) else if ( right ) then - ldaq = max( 1, m ) + ldaq = max( 1_${ik}$, m ) 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 ) then - info = -5 - else if( l<0 .or. l>k ) then - info = -6 - else if( mb<1 .or. (mb>k .and. k>0) ) then - info = -7 + info = -2_${ik}$ + else if( m<0_${ik}$ ) then + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( k<0_${ik}$ ) then + info = -5_${ik}$ + else if( l<0_${ik}$ .or. l>k ) then + info = -6_${ik}$ + else if( mb<1_${ik}$ .or. (mb>k .and. k>0_${ik}$) ) then + info = -7_${ik}$ else if( ldv=l ) then - lb = 0 + lb = 0_${ik}$ else - lb = 0 + lb = 0_${ik}$ end if - call stdlib_ztprfb( 'L', 'C', 'F', 'R', nb, n, ib, lb,v( i, 1 ), ldv, t( 1, i ), & - ldt,a( i, 1 ), lda, b, ldb, work, ib ) + call stdlib${ii}$_ztprfb( 'L', 'C', 'F', 'R', nb, n, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), & + ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib ) end do else if( right .and. tran ) then do i = 1, k, mb ib = min( mb, k-i+1 ) nb = min( n-l+i+ib-1, n ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = nb-n+l-i+1 end if - call stdlib_ztprfb( 'R', 'N', 'F', 'R', m, nb, ib, lb,v( i, 1 ), ldv, t( 1, i ), & - ldt,a( 1, i ), lda, b, ldb, work, m ) + call stdlib${ii}$_ztprfb( 'R', 'N', 'F', 'R', m, nb, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), & + ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m ) end do else if( left .and. tran ) then kf = ((k-1)/mb)*mb+1 @@ -50759,12 +50762,12 @@ module stdlib_linalg_lapack_z ib = min( mb, k-i+1 ) nb = min( m-l+i+ib-1, m ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else - lb = 0 + lb = 0_${ik}$ end if - call stdlib_ztprfb( 'L', 'N', 'F', 'R', nb, n, ib, lb,v( i, 1 ), ldv, t( 1, i ), & - ldt,a( i, 1 ), lda, b, ldb, work, ib ) + call stdlib${ii}$_ztprfb( 'L', 'N', 'F', 'R', nb, n, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), & + ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib ) end do else if( right .and. notran ) then kf = ((k-1)/mb)*mb+1 @@ -50772,19 +50775,19 @@ module stdlib_linalg_lapack_z ib = min( mb, k-i+1 ) nb = min( n-l+i+ib-1, n ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = nb-n+l-i+1 end if - call stdlib_ztprfb( 'R', 'C', 'F', 'R', m, nb, ib, lb,v( i, 1 ), ldv, t( 1, i ), & - ldt,a( 1, i ), lda, b, ldb, work, m ) + call stdlib${ii}$_ztprfb( 'R', 'C', 'F', 'R', m, nb, ib, lb,v( i, 1_${ik}$ ), ldv, t( 1_${ik}$, i ), & + ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m ) end do end if return - end subroutine stdlib_ztpmlqt + end subroutine stdlib${ii}$_ztpmlqt - pure subroutine stdlib_ztpmqrt( side, trans, m, n, k, l, nb, v, ldv, t, ldt,a, lda, b, ldb, & + pure subroutine stdlib${ii}$_ztpmqrt( side, trans, m, n, k, l, nb, v, ldv, t, ldt,a, lda, b, ldb, & !! ZTPMQRT applies a complex orthogonal matrix Q obtained from a !! "triangular-pentagonal" complex block reflector H to a general !! complex matrix C, which consists of two blocks A and B. @@ -50794,8 +50797,8 @@ module stdlib_linalg_lapack_z ! -- 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, lda, ldb, m, n, l, nb, ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: k, ldv, lda, ldb, m, n, l, nb, ldt ! Array Arguments complex(dp), intent(in) :: v(ldv,*), t(ldt,*) complex(dp), intent(inout) :: a(lda,*), b(ldb,*) @@ -50803,48 +50806,48 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran - integer(ilp) :: i, ib, mb, lb, kf, ldaq, ldvq + integer(${ik}$) :: i, ib, mb, lb, kf, ldaq, ldvq ! 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, 'C' ) notran = stdlib_lsame( trans, 'N' ) if ( left ) then - ldvq = max( 1, m ) - ldaq = max( 1, k ) + ldvq = max( 1_${ik}$, m ) + ldaq = max( 1_${ik}$, k ) else if ( right ) then - ldvq = max( 1, n ) - ldaq = max( 1, m ) + ldvq = max( 1_${ik}$, n ) + ldaq = max( 1_${ik}$, m ) 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 ) then - info = -5 - else if( l<0 .or. l>k ) then - info = -6 - else if( nb<1 .or. (nb>k .and. k>0) ) then - info = -7 + info = -2_${ik}$ + else if( m<0_${ik}$ ) then + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( k<0_${ik}$ ) then + info = -5_${ik}$ + else if( l<0_${ik}$ .or. l>k ) then + info = -6_${ik}$ + else if( nb<1_${ik}$ .or. (nb>k .and. k>0_${ik}$) ) then + info = -7_${ik}$ else if( ldv=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-m+l-i+1 end if - call stdlib_ztprfb( 'L', 'C', 'F', 'C', mb, n, ib, lb,v( 1, i ), ldv, t( 1, i ), & - ldt,a( i, 1 ), lda, b, ldb, work, ib ) + call stdlib${ii}$_ztprfb( 'L', 'C', 'F', 'C', mb, n, ib, lb,v( 1_${ik}$, i ), ldv, t( 1_${ik}$, i ), & + ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib ) end do else if( right .and. notran ) then do i = 1, k, nb ib = min( nb, k-i+1 ) mb = min( n-l+i+ib-1, n ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-n+l-i+1 end if - call stdlib_ztprfb( 'R', 'N', 'F', 'C', m, mb, ib, lb,v( 1, i ), ldv, t( 1, i ), & - ldt,a( 1, i ), lda, b, ldb, work, m ) + call stdlib${ii}$_ztprfb( 'R', 'N', 'F', 'C', m, mb, ib, lb,v( 1_${ik}$, i ), ldv, t( 1_${ik}$, i ), & + ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m ) end do else if( left .and. notran ) then kf = ((k-1)/nb)*nb+1 @@ -50879,12 +50882,12 @@ module stdlib_linalg_lapack_z ib = min( nb, k-i+1 ) mb = min( m-l+i+ib-1, m ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-m+l-i+1 end if - call stdlib_ztprfb( 'L', 'N', 'F', 'C', mb, n, ib, lb,v( 1, i ), ldv, t( 1, i ), & - ldt,a( i, 1 ), lda, b, ldb, work, ib ) + call stdlib${ii}$_ztprfb( 'L', 'N', 'F', 'C', mb, n, ib, lb,v( 1_${ik}$, i ), ldv, t( 1_${ik}$, i ), & + ldt,a( i, 1_${ik}$ ), lda, b, ldb, work, ib ) end do else if( right .and. tran ) then kf = ((k-1)/nb)*nb+1 @@ -50892,19 +50895,19 @@ module stdlib_linalg_lapack_z ib = min( nb, k-i+1 ) mb = min( n-l+i+ib-1, n ) if( i>=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-n+l-i+1 end if - call stdlib_ztprfb( 'R', 'C', 'F', 'C', m, mb, ib, lb,v( 1, i ), ldv, t( 1, i ), & - ldt,a( 1, i ), lda, b, ldb, work, m ) + call stdlib${ii}$_ztprfb( 'R', 'C', 'F', 'C', m, mb, ib, lb,v( 1_${ik}$, i ), ldv, t( 1_${ik}$, i ), & + ldt,a( 1_${ik}$, i ), lda, b, ldb, work, m ) end do end if return - end subroutine stdlib_ztpmqrt + end subroutine stdlib${ii}$_ztpmqrt - pure subroutine stdlib_ztpqrt( m, n, l, nb, a, lda, b, ldb, t, ldt, work,info ) + pure subroutine stdlib${ii}$_ztpqrt( m, n, l, nb, a, lda, b, ldb, t, ldt, work,info ) !! ZTPQRT computes a blocked QR factorization of a complex !! "triangular-pentagonal" matrix C, which is composed of a !! triangular block A and pentagonal block B, using the compact @@ -50913,34 +50916,34 @@ module stdlib_linalg_lapack_z ! -- 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, ldb, ldt, n, m, l, nb + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldt, n, m, l, nb ! Array Arguments complex(dp), intent(inout) :: a(lda,*), b(ldb,*) complex(dp), intent(out) :: t(ldt,*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ib, lb, mb, iinfo + integer(${ik}$) :: i, ib, lb, mb, iinfo ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( l<0 .or. (l>min(m,n) .and. min(m,n)>=0)) then - info = -3 - else if( nb<1 .or. (nb>n .and. n>0)) then - info = -4 - else if( ldamin(m,n) .and. min(m,n)>=0_${ik}$)) then + info = -3_${ik}$ + else if( nb<1_${ik}$ .or. (nb>n .and. n>0_${ik}$)) then + info = -4_${ik}$ + else if( lda=l ) then - lb = 0 + lb = 0_${ik}$ else lb = mb-m+l-i+1 end if - call stdlib_ztpqrt2( mb, ib, lb, a(i,i), lda, b( 1, i ), ldb,t(1, i ), ldt, iinfo ) + call stdlib${ii}$_ztpqrt2( mb, ib, lb, a(i,i), lda, b( 1_${ik}$, i ), ldb,t(1_${ik}$, i ), ldt, iinfo ) ! update by applying h**h to b(:,i+ib:n) from the left if( i+ib<=n ) then - call stdlib_ztprfb( 'L', 'C', 'F', 'C', mb, n-i-ib+1, ib, lb,b( 1, i ), ldb, t( & - 1, i ), ldt,a( i, i+ib ), lda, b( 1, i+ib ), ldb,work, ib ) + call stdlib${ii}$_ztprfb( 'L', 'C', 'F', 'C', mb, n-i-ib+1, ib, lb,b( 1_${ik}$, i ), ldb, t( & + 1_${ik}$, i ), ldt,a( i, i+ib ), lda, b( 1_${ik}$, i+ib ), ldb,work, ib ) end if end do return - end subroutine stdlib_ztpqrt + end subroutine stdlib${ii}$_ztpqrt - subroutine stdlib_ztrcon( norm, uplo, diag, n, a, lda, rcond, work,rwork, info ) + subroutine stdlib${ii}$_ztrcon( norm, uplo, diag, n, a, lda, rcond, work,rwork, info ) !! ZTRCON estimates the reciprocal of the condition number of a !! triangular matrix A, in either the 1-norm or the infinity-norm. !! The norm of A is computed and an estimate is obtained for @@ -50978,8 +50981,8 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: diag, norm, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, n real(dp), intent(out) :: rcond ! Array Arguments real(dp), intent(out) :: rwork(*) @@ -50990,11 +50993,11 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: nounit, onenrm, upper character :: normin - integer(ilp) :: ix, kase, kase1 + integer(${ik}$) :: ix, kase, kase1 real(dp) :: ainvnm, anorm, scale, smlnum, xnorm complex(dp) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,aimag,max ! Statement Functions @@ -51003,64 +51006,64 @@ module stdlib_linalg_lapack_z cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) ) ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ upper = stdlib_lsame( uplo, 'U' ) onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' ) nounit = stdlib_lsame( diag, 'N' ) if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) 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( lda 0. if( anorm>zero ) then ! estimate the norm of the inverse of a. ainvnm = zero normin = 'N' if( onenrm ) then - kase1 = 1 + kase1 = 1_${ik}$ else - kase1 = 2 + kase1 = 2_${ik}$ end if - kase = 0 + kase = 0_${ik}$ 10 continue - call stdlib_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + if( kase/=0_${ik}$ ) then if( kase==kase1 ) then ! multiply by inv(a). - call stdlib_zlatrs( uplo, 'NO TRANSPOSE', diag, normin, n, a,lda, work, scale,& + call stdlib${ii}$_zlatrs( uplo, 'NO TRANSPOSE', diag, normin, n, a,lda, work, scale,& rwork, info ) else ! multiply by inv(a**h). - call stdlib_zlatrs( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, a, lda, work,& + call stdlib${ii}$_zlatrs( uplo, 'CONJUGATE TRANSPOSE', diag, normin,n, a, lda, work,& scale, rwork, info ) end if normin = 'Y' ! multiply by 1/scale if doing so will not cause overflow. if( scale/=one ) then - ix = stdlib_izamax( n, work, 1 ) + ix = stdlib${ii}$_izamax( n, work, 1_${ik}$ ) xnorm = cabs1( work( ix ) ) if( scaleone ) then if( db>bignum*da11 )scaloc = one / db end if - x11 = stdlib_zladiv( vec*cmplx( scaloc,KIND=dp), a11 ) + x11 = stdlib${ii}$_zladiv( vec*cmplx( scaloc,KIND=dp), a11 ) if( scaloc/=one ) then do j = 1, n - call stdlib_zdscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_zdscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if @@ -51190,8 +51193,8 @@ module stdlib_linalg_lapack_z ! i=1 j=1 loop_60: do l = 1, n do k = 1, m - suml = stdlib_zdotc( k-1, a( 1, k ), 1, c( 1, l ), 1 ) - sumr = stdlib_zdotu( l-1, c( k, 1 ), ldc, b( 1, l ), 1 ) + suml = stdlib${ii}$_zdotc( k-1, a( 1_${ik}$, k ), 1_${ik}$, c( 1_${ik}$, l ), 1_${ik}$ ) + sumr = stdlib${ii}$_zdotu( l-1, c( k, 1_${ik}$ ), ldc, b( 1_${ik}$, l ), 1_${ik}$ ) vec = c( k, l ) - ( suml+sgn*sumr ) scaloc = one a11 = conjg( a( k, k ) ) + sgn*b( l, l ) @@ -51199,16 +51202,16 @@ module stdlib_linalg_lapack_z if( da11<=smin ) then a11 = smin da11 = smin - info = 1 + info = 1_${ik}$ end if db = abs( real( vec,KIND=dp) ) + abs( aimag( vec ) ) if( da11one ) then if( db>bignum*da11 )scaloc = one / db end if - x11 = stdlib_zladiv( vec*cmplx( scaloc,KIND=dp), a11 ) + x11 = stdlib${ii}$_zladiv( vec*cmplx( scaloc,KIND=dp), a11 ) if( scaloc/=one ) then do j = 1, n - call stdlib_zdscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_zdscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if @@ -51229,8 +51232,8 @@ module stdlib_linalg_lapack_z ! j=l+1 loop_90: do l = n, 1, -1 do k = 1, m - suml = stdlib_zdotc( k-1, a( 1, k ), 1, c( 1, l ), 1 ) - sumr = stdlib_zdotc( n-l, c( k, min( l+1, n ) ), ldc,b( l, min( l+1, n ) ), & + suml = stdlib${ii}$_zdotc( k-1, a( 1_${ik}$, k ), 1_${ik}$, c( 1_${ik}$, l ), 1_${ik}$ ) + sumr = stdlib${ii}$_zdotc( n-l, c( k, min( l+1, n ) ), ldc,b( l, min( l+1, n ) ), & ldb ) vec = c( k, l ) - ( suml+sgn*conjg( sumr ) ) scaloc = one @@ -51239,16 +51242,16 @@ module stdlib_linalg_lapack_z if( da11<=smin ) then a11 = smin da11 = smin - info = 1 + info = 1_${ik}$ end if db = abs( real( vec,KIND=dp) ) + abs( aimag( vec ) ) if( da11one ) then if( db>bignum*da11 )scaloc = one / db end if - x11 = stdlib_zladiv( vec*cmplx( scaloc,KIND=dp), a11 ) + x11 = stdlib${ii}$_zladiv( vec*cmplx( scaloc,KIND=dp), a11 ) if( scaloc/=one ) then do j = 1, n - call stdlib_zdscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_zdscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if @@ -51266,9 +51269,9 @@ module stdlib_linalg_lapack_z ! i=k+1 j=l+1 loop_120: do l = n, 1, -1 do k = m, 1, -1 - suml = stdlib_zdotu( m-k, a( k, min( k+1, m ) ), lda,c( min( k+1, m ), l ), 1 & + suml = stdlib${ii}$_zdotu( m-k, a( k, min( k+1, m ) ), lda,c( min( k+1, m ), l ), 1_${ik}$ & ) - sumr = stdlib_zdotc( n-l, c( k, min( l+1, n ) ), ldc,b( l, min( l+1, n ) ), & + sumr = stdlib${ii}$_zdotc( n-l, c( k, min( l+1, n ) ), ldc,b( l, min( l+1, n ) ), & ldb ) vec = c( k, l ) - ( suml+sgn*conjg( sumr ) ) scaloc = one @@ -51277,16 +51280,16 @@ module stdlib_linalg_lapack_z if( da11<=smin ) then a11 = smin da11 = smin - info = 1 + info = 1_${ik}$ end if db = abs( real( vec,KIND=dp) ) + abs( aimag( vec ) ) if( da11one ) then if( db>bignum*da11 )scaloc = one / db end if - x11 = stdlib_zladiv( vec*cmplx( scaloc,KIND=dp), a11 ) + x11 = stdlib${ii}$_zladiv( vec*cmplx( scaloc,KIND=dp), a11 ) if( scaloc/=one ) then do j = 1, n - call stdlib_zdscal( m, scaloc, c( 1, j ), 1 ) + call stdlib${ii}$_zdscal( m, scaloc, c( 1_${ik}$, j ), 1_${ik}$ ) end do scale = scale*scaloc end if @@ -51295,10 +51298,10 @@ module stdlib_linalg_lapack_z end do loop_120 end if return - end subroutine stdlib_ztrsyl + end subroutine stdlib${ii}$_ztrsyl - pure subroutine stdlib_zunbdb5( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & + pure subroutine stdlib${ii}$_zunbdb5( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & !! ZUNBDB5 orthogonalizes the column vector !! X = [ X1 ] !! [ X2 ] @@ -51315,8 +51318,8 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(in) :: q1(ldq1,*), q2(ldq2,*) complex(dp), intent(out) :: work(*) @@ -51324,38 +51327,38 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! Local Scalars - integer(ilp) :: childinfo, i, j + integer(${ik}$) :: childinfo, i, j ! 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( 'ZUNBDB5', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZUNBDB5', -info ) return end if ! project x onto the orthogonal complement of q - call stdlib_zunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2,work, lwork, & + call stdlib${ii}$_zunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2, ldq2,work, lwork, & childinfo ) ! if the projection is nonzero, then return - if( stdlib_dznrm2(m1,x1,incx1) /= czero.or. stdlib_dznrm2(m2,x2,incx2) /= czero ) & + if( stdlib${ii}$_dznrm2(m1,x1,incx1) /= czero.or. stdlib${ii}$_dznrm2(m2,x2,incx2) /= czero ) & then return end if @@ -51369,9 +51372,9 @@ module stdlib_linalg_lapack_z do j = 1, m2 x2(j) = czero end do - call stdlib_zunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & + call stdlib${ii}$_zunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & lwork, childinfo ) - if( stdlib_dznrm2(m1,x1,incx1) /= czero.or. stdlib_dznrm2(m2,x2,incx2) /= czero ) & + if( stdlib${ii}$_dznrm2(m1,x1,incx1) /= czero.or. stdlib${ii}$_dznrm2(m2,x2,incx2) /= czero ) & then return end if @@ -51386,18 +51389,18 @@ module stdlib_linalg_lapack_z x2(j) = czero end do x2(i) = cone - call stdlib_zunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & + call stdlib${ii}$_zunbdb6( m1, m2, n, x1, incx1, x2, incx2, q1, ldq1, q2,ldq2, work, & lwork, childinfo ) - if( stdlib_dznrm2(m1,x1,incx1) /= czero.or. stdlib_dznrm2(m2,x2,incx2) /= czero ) & + if( stdlib${ii}$_dznrm2(m1,x1,incx1) /= czero.or. stdlib${ii}$_dznrm2(m2,x2,incx2) /= czero ) & then return end if end do return - end subroutine stdlib_zunbdb5 + end subroutine stdlib${ii}$_zunbdb5 - recursive subroutine stdlib_zuncsd( jobu1, jobu2, jobv1t, jobv2t, trans,signs, m, p, q, x11, & + recursive subroutine stdlib${ii}$_zuncsd( jobu1, jobu2, jobv1t, jobv2t, trans,signs, m, p, q, x11, & !! ZUNCSD computes the CS decomposition of an M-by-M partitioned !! unitary matrix X: !! [ I 0 0 | 0 0 0 ] @@ -51418,11 +51421,11 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobu1, jobu2, jobv1t, jobv2t, signs, trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldu1, ldu2, ldv1t, ldv2t, ldx11, ldx12, ldx21, ldx22, & + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldu1, ldu2, ldv1t, ldv2t, ldx11, ldx12, ldx21, ldx22, & lrwork, lwork, m, p, q ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(out) :: theta(*) real(dp), intent(out) :: rwork(*) complex(dp), intent(out) :: u1(ldu1,*), u2(ldu2,*), v1t(ldv1t,*), v2t(ldv2t,*), work(*) @@ -51433,60 +51436,60 @@ module stdlib_linalg_lapack_z ! Local Scalars character :: transt, signst - integer(ilp) :: childinfo, i, ib11d, ib11e, ib12d, ib12e, ib21d, ib21e, ib22d, ib22e, & + integer(${ik}$) :: childinfo, i, ib11d, ib11e, ib12d, ib12e, ib21d, ib21e, ib22d, ib22e, & ibbcsd, iorbdb, iorglq, iorgqr, iphi, itaup1, itaup2, itauq1, itauq2, j, lbbcsdwork, & lbbcsdworkmin, lbbcsdworkopt, lorbdbwork, lorbdbworkmin, lorbdbworkopt, lorglqwork, & lorglqworkmin, lorglqworkopt, lorgqrwork, lorgqrworkmin, lorgqrworkopt, lworkmin, & lworkopt, p1, q1 logical(lk) :: colmajor, defaultsigns, lquery, wantu1, wantu2, wantv1t, wantv2t - integer(ilp) :: lrworkmin, lrworkopt + integer(${ik}$) :: lrworkmin, lrworkopt logical(lk) :: lrquery ! Intrinsic Functions intrinsic :: int,max,min ! Executable Statements ! test input arguments - info = 0 + info = 0_${ik}$ wantu1 = stdlib_lsame( jobu1, 'Y' ) wantu2 = stdlib_lsame( jobu2, 'Y' ) wantv1t = stdlib_lsame( jobv1t, 'Y' ) wantv2t = stdlib_lsame( jobv2t, 'Y' ) colmajor = .not. stdlib_lsame( trans, 'T' ) defaultsigns = .not. stdlib_lsame( signs, 'O' ) - lquery = lwork == -1 - lrquery = lrwork == -1 - if( m < 0 ) then - info = -7 - else if( p < 0 .or. p > m ) then - info = -8 - else if( q < 0 .or. q > m ) then - info = -9 - else if ( colmajor .and. ldx11 < max( 1, p ) ) then - info = -11 - else if (.not. colmajor .and. ldx11 < max( 1, q ) ) then - info = -11 - else if (colmajor .and. ldx12 < max( 1, p ) ) then - info = -13 - else if (.not. colmajor .and. ldx12 < max( 1, m-q ) ) then - info = -13 - else if (colmajor .and. ldx21 < max( 1, m-p ) ) then - info = -15 - else if (.not. colmajor .and. ldx21 < max( 1, q ) ) then - info = -15 - else if (colmajor .and. ldx22 < max( 1, m-p ) ) then - info = -17 - else if (.not. colmajor .and. ldx22 < max( 1, m-q ) ) then - info = -17 + lquery = lwork == -1_${ik}$ + lrquery = lrwork == -1_${ik}$ + if( m < 0_${ik}$ ) then + info = -7_${ik}$ + else if( p < 0_${ik}$ .or. p > m ) then + info = -8_${ik}$ + else if( q < 0_${ik}$ .or. q > m ) then + info = -9_${ik}$ + else if ( colmajor .and. ldx11 < max( 1_${ik}$, p ) ) then + info = -11_${ik}$ + else if (.not. colmajor .and. ldx11 < max( 1_${ik}$, q ) ) then + info = -11_${ik}$ + else if (colmajor .and. ldx12 < max( 1_${ik}$, p ) ) then + info = -13_${ik}$ + else if (.not. colmajor .and. ldx12 < max( 1_${ik}$, m-q ) ) then + info = -13_${ik}$ + else if (colmajor .and. ldx21 < max( 1_${ik}$, m-p ) ) then + info = -15_${ik}$ + else if (.not. colmajor .and. ldx21 < max( 1_${ik}$, q ) ) then + info = -15_${ik}$ + else if (colmajor .and. ldx22 < max( 1_${ik}$, m-p ) ) then + info = -17_${ik}$ + else if (.not. colmajor .and. ldx22 < max( 1_${ik}$, m-q ) ) then + info = -17_${ik}$ else if( wantu1 .and. ldu1 < p ) then - info = -20 + info = -20_${ik}$ else if( wantu2 .and. ldu2 < m-p ) then - info = -22 + info = -22_${ik}$ else if( wantv1t .and. ldv1t < q ) then - info = -24 + info = -24_${ik}$ else if( wantv2t .and. ldv2t < m-q ) then - info = -26 + info = -26_${ik}$ end if ! work with transpose if convenient - if( info == 0 .and. min( p, m-p ) < min( q, m-q ) ) then + if( info == 0_${ik}$ .and. min( p, m-p ) < min( q, m-q ) ) then if( colmajor ) then transt = 'T' else @@ -51497,158 +51500,158 @@ module stdlib_linalg_lapack_z else signst = 'D' end if - call stdlib_zuncsd( jobv1t, jobv2t, jobu1, jobu2, transt, signst, m,q, p, x11, & + call stdlib${ii}$_zuncsd( jobv1t, jobv2t, jobu1, jobu2, transt, signst, m,q, p, x11, & ldx11, x21, ldx21, x12, ldx12, x22,ldx22, theta, v1t, ldv1t, v2t, ldv2t, u1, ldu1,& u2, ldu2, work, lwork, rwork, lrwork, iwork,info ) return end if ! work with permutation [ 0 i; i 0 ] * x * [ 0 i; i 0 ] if ! convenient - if( info == 0 .and. m-q < q ) then + if( info == 0_${ik}$ .and. m-q < q ) then if( defaultsigns ) then signst = 'O' else signst = 'D' end if - call stdlib_zuncsd( jobu2, jobu1, jobv2t, jobv1t, trans, signst, m,m-p, m-q, x22, & + call stdlib${ii}$_zuncsd( jobu2, jobu1, jobv2t, jobv1t, trans, signst, m,m-p, m-q, x22, & ldx22, x21, ldx21, x12, ldx12, x11,ldx11, theta, u2, ldu2, u1, ldu1, v2t, ldv2t, & v1t,ldv1t, work, lwork, rwork, lrwork, iwork, info ) return end if ! compute workspace - if( info == 0 ) then + if( info == 0_${ik}$ ) then ! real workspace - iphi = 2 - ib11d = iphi + max( 1, q - 1 ) - ib11e = ib11d + max( 1, q ) - ib12d = ib11e + max( 1, q - 1 ) - ib12e = ib12d + max( 1, q ) - ib21d = ib12e + max( 1, q - 1 ) - ib21e = ib21d + max( 1, q ) - ib22d = ib21e + max( 1, q - 1 ) - ib22e = ib22d + max( 1, q ) - ibbcsd = ib22e + max( 1, q - 1 ) - call stdlib_zbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, theta, u1, & + iphi = 2_${ik}$ + ib11d = iphi + max( 1_${ik}$, q - 1_${ik}$ ) + ib11e = ib11d + max( 1_${ik}$, q ) + ib12d = ib11e + max( 1_${ik}$, q - 1_${ik}$ ) + ib12e = ib12d + max( 1_${ik}$, q ) + ib21d = ib12e + max( 1_${ik}$, q - 1_${ik}$ ) + ib21e = ib21d + max( 1_${ik}$, q ) + ib22d = ib21e + max( 1_${ik}$, q - 1_${ik}$ ) + ib22e = ib22d + max( 1_${ik}$, q ) + ibbcsd = ib22e + max( 1_${ik}$, q - 1_${ik}$ ) + call stdlib${ii}$_zbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q,theta, theta, u1, & ldu1, u2, ldu2, v1t, ldv1t,v2t, ldv2t, theta, theta, theta, theta, theta,theta, & - theta, theta, rwork, -1, childinfo ) - lbbcsdworkopt = int( rwork(1),KIND=ilp) + theta, theta, rwork, -1_${ik}$, childinfo ) + lbbcsdworkopt = int( rwork(1_${ik}$),KIND=${ik}$) lbbcsdworkmin = lbbcsdworkopt - lrworkopt = ibbcsd + lbbcsdworkopt - 1 - lrworkmin = ibbcsd + lbbcsdworkmin - 1 - rwork(1) = lrworkopt + lrworkopt = ibbcsd + lbbcsdworkopt - 1_${ik}$ + lrworkmin = ibbcsd + lbbcsdworkmin - 1_${ik}$ + rwork(1_${ik}$) = lrworkopt ! complex workspace - itaup1 = 2 - itaup2 = itaup1 + max( 1, p ) - itauq1 = itaup2 + max( 1, m - p ) - itauq2 = itauq1 + max( 1, q ) - iorgqr = itauq2 + max( 1, m - q ) - call stdlib_zungqr( m-q, m-q, m-q, u1, max(1,m-q), u1, work, -1,childinfo ) - lorgqrworkopt = int( work(1),KIND=ilp) - lorgqrworkmin = max( 1, m - q ) - iorglq = itauq2 + max( 1, m - q ) - call stdlib_zunglq( m-q, m-q, m-q, u1, max(1,m-q), u1, work, -1,childinfo ) - lorglqworkopt = int( work(1),KIND=ilp) - lorglqworkmin = max( 1, m - q ) - iorbdb = itauq2 + max( 1, m - q ) - call stdlib_zunbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & - ldx22, theta, theta, u1, u2,v1t, v2t, work, -1, childinfo ) - lorbdbworkopt = int( work(1),KIND=ilp) + itaup1 = 2_${ik}$ + itaup2 = itaup1 + max( 1_${ik}$, p ) + itauq1 = itaup2 + max( 1_${ik}$, m - p ) + itauq2 = itauq1 + max( 1_${ik}$, q ) + iorgqr = itauq2 + max( 1_${ik}$, m - q ) + call stdlib${ii}$_zungqr( m-q, m-q, m-q, u1, max(1_${ik}$,m-q), u1, work, -1_${ik}$,childinfo ) + lorgqrworkopt = int( work(1_${ik}$),KIND=${ik}$) + lorgqrworkmin = max( 1_${ik}$, m - q ) + iorglq = itauq2 + max( 1_${ik}$, m - q ) + call stdlib${ii}$_zunglq( m-q, m-q, m-q, u1, max(1_${ik}$,m-q), u1, work, -1_${ik}$,childinfo ) + lorglqworkopt = int( work(1_${ik}$),KIND=${ik}$) + lorglqworkmin = max( 1_${ik}$, m - q ) + iorbdb = itauq2 + max( 1_${ik}$, m - q ) + call stdlib${ii}$_zunbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12,x21, ldx21, x22, & + ldx22, theta, theta, u1, u2,v1t, v2t, work, -1_${ik}$, childinfo ) + lorbdbworkopt = int( work(1_${ik}$),KIND=${ik}$) lorbdbworkmin = lorbdbworkopt lworkopt = max( iorgqr + lorgqrworkopt, iorglq + lorglqworkopt,iorbdb + & - lorbdbworkopt ) - 1 + lorbdbworkopt ) - 1_${ik}$ lworkmin = max( iorgqr + lorgqrworkmin, iorglq + lorglqworkmin,iorbdb + & - lorbdbworkmin ) - 1 - work(1) = max(lworkopt,lworkmin) + lorbdbworkmin ) - 1_${ik}$ + work(1_${ik}$) = max(lworkopt,lworkmin) if( lwork < lworkmin.and. .not. ( lquery .or. lrquery ) ) then - info = -22 + info = -22_${ik}$ else if( lrwork < lrworkmin.and. .not. ( lquery .or. lrquery ) ) then - info = -24 + info = -24_${ik}$ else - lorgqrwork = lwork - iorgqr + 1 - lorglqwork = lwork - iorglq + 1 - lorbdbwork = lwork - iorbdb + 1 - lbbcsdwork = lrwork - ibbcsd + 1 + lorgqrwork = lwork - iorgqr + 1_${ik}$ + lorglqwork = lwork - iorglq + 1_${ik}$ + lorbdbwork = lwork - iorbdb + 1_${ik}$ + lbbcsdwork = lrwork - ibbcsd + 1_${ik}$ end if end if ! abort if any illegal arguments - if( info /= 0 ) then - call stdlib_xerbla( 'ZUNCSD', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZUNCSD', -info ) return else if( lquery .or. lrquery ) then return end if ! transform to bidiagonal block form - call stdlib_zunbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12, x21,ldx21, x22, & + call stdlib${ii}$_zunbdb( trans, signs, m, p, q, x11, ldx11, x12, ldx12, x21,ldx21, x22, & ldx22, theta, rwork(iphi), work(itaup1),work(itaup2), work(itauq1), work(itauq2),work(& iorbdb), lorbdbwork, childinfo ) ! accumulate householder reflectors if( colmajor ) then - if( wantu1 .and. p > 0 ) then - call stdlib_zlacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) - call stdlib_zungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqrwork, & + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) + call stdlib${ii}$_zungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqrwork, & info) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_zlacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) - call stdlib_zungqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqrwork,& + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) + call stdlib${ii}$_zungqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqrwork,& info ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_zlacpy( 'U', q-1, q-1, x11(1,2), ldx11, v1t(2,2),ldv1t ) - v1t(1, 1) = cone + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'U', q-1, q-1, x11(1_${ik}$,2_${ik}$), ldx11, v1t(2_${ik}$,2_${ik}$),ldv1t ) + v1t(1_${ik}$, 1_${ik}$) = cone do j = 2, q - v1t(1,j) = czero - v1t(j,1) = czero + v1t(1_${ik}$,j) = czero + v1t(j,1_${ik}$) = czero end do - call stdlib_zunglq( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),work(iorglq), & + call stdlib${ii}$_zunglq( q-1, q-1, q-1, v1t(2_${ik}$,2_${ik}$), ldv1t, work(itauq1),work(iorglq), & lorglqwork, info ) end if - if( wantv2t .and. m-q > 0 ) then - call stdlib_zlacpy( 'U', p, m-q, x12, ldx12, v2t, ldv2t ) + if( wantv2t .and. m-q > 0_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'U', p, m-q, x12, ldx12, v2t, ldv2t ) if( m-p > q) then - call stdlib_zlacpy( 'U', m-p-q, m-p-q, x22(q+1,p+1), ldx22,v2t(p+1,p+1), & + call stdlib${ii}$_zlacpy( 'U', m-p-q, m-p-q, x22(q+1,p+1), ldx22,v2t(p+1,p+1), & ldv2t ) end if if( m > q ) then - call stdlib_zunglq( m-q, m-q, m-q, v2t, ldv2t, work(itauq2),work(iorglq), & + call stdlib${ii}$_zunglq( m-q, m-q, m-q, v2t, ldv2t, work(itauq2),work(iorglq), & lorglqwork, info ) end if end if else - if( wantu1 .and. p > 0 ) then - call stdlib_zlacpy( 'U', q, p, x11, ldx11, u1, ldu1 ) - call stdlib_zunglq( p, p, q, u1, ldu1, work(itaup1), work(iorglq),lorglqwork, & + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'U', q, p, x11, ldx11, u1, ldu1 ) + call stdlib${ii}$_zunglq( p, p, q, u1, ldu1, work(itaup1), work(iorglq),lorglqwork, & info) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_zlacpy( 'U', q, m-p, x21, ldx21, u2, ldu2 ) - call stdlib_zunglq( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorglq), lorglqwork,& + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'U', q, m-p, x21, ldx21, u2, ldu2 ) + call stdlib${ii}$_zunglq( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorglq), lorglqwork,& info ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_zlacpy( 'L', q-1, q-1, x11(2,1), ldx11, v1t(2,2),ldv1t ) - v1t(1, 1) = cone + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'L', q-1, q-1, x11(2_${ik}$,1_${ik}$), ldx11, v1t(2_${ik}$,2_${ik}$),ldv1t ) + v1t(1_${ik}$, 1_${ik}$) = cone do j = 2, q - v1t(1,j) = czero - v1t(j,1) = czero + v1t(1_${ik}$,j) = czero + v1t(j,1_${ik}$) = czero end do - call stdlib_zungqr( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),work(iorgqr), & + call stdlib${ii}$_zungqr( q-1, q-1, q-1, v1t(2_${ik}$,2_${ik}$), ldv1t, work(itauq1),work(iorgqr), & lorgqrwork, info ) end if - if( wantv2t .and. m-q > 0 ) then + if( wantv2t .and. m-q > 0_${ik}$ ) then p1 = min( p+1, m ) q1 = min( q+1, m ) - call stdlib_zlacpy( 'L', m-q, p, x12, ldx12, v2t, ldv2t ) + call stdlib${ii}$_zlacpy( 'L', m-q, p, x12, ldx12, v2t, ldv2t ) if( m > p+q ) then - call stdlib_zlacpy( 'L', m-p-q, m-p-q, x22(p1,q1), ldx22,v2t(p+1,p+1), ldv2t ) + call stdlib${ii}$_zlacpy( 'L', m-p-q, m-p-q, x22(p1,q1), ldx22,v2t(p+1,p+1), ldv2t ) end if - call stdlib_zungqr( m-q, m-q, m-q, v2t, ldv2t, work(itauq2),work(iorgqr), & + call stdlib${ii}$_zungqr( m-q, m-q, m-q, v2t, ldv2t, work(itauq2),work(iorgqr), & lorgqrwork, info ) end if end if ! compute the csd of the matrix in bidiagonal-block form - call stdlib_zbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q, theta,rwork(iphi), & + call stdlib${ii}$_zbbcsd( jobu1, jobu2, jobv1t, jobv2t, trans, m, p, q, theta,rwork(iphi), & u1, ldu1, u2, ldu2, v1t, ldv1t, v2t,ldv2t, rwork(ib11d), rwork(ib11e), rwork(ib12d),& rwork(ib12e), rwork(ib21d), rwork(ib21e),rwork(ib22d), rwork(ib22e), rwork(ibbcsd),& lbbcsdwork, info ) @@ -51656,7 +51659,7 @@ module stdlib_linalg_lapack_z ! left corner of (1,1)-block and/or bottom-right corner of (1,2)- ! block and/or bottom-right corner of (2,1)-block and/or top-left ! corner of (2,2)-block - if( q > 0 .and. wantu2 ) then + if( q > 0_${ik}$ .and. wantu2 ) then do i = 1, q iwork(i) = m - p - q + i end do @@ -51664,12 +51667,12 @@ module stdlib_linalg_lapack_z iwork(i) = i - q end do if( colmajor ) then - call stdlib_zlapmt( .false., m-p, m-p, u2, ldu2, iwork ) + call stdlib${ii}$_zlapmt( .false., m-p, m-p, u2, ldu2, iwork ) else - call stdlib_zlapmr( .false., m-p, m-p, u2, ldu2, iwork ) + call stdlib${ii}$_zlapmr( .false., m-p, m-p, u2, ldu2, iwork ) end if end if - if( m > 0 .and. wantv2t ) then + if( m > 0_${ik}$ .and. wantv2t ) then do i = 1, p iwork(i) = m - p - q + i end do @@ -51677,17 +51680,17 @@ module stdlib_linalg_lapack_z iwork(i) = i - p end do if( .not. colmajor ) then - call stdlib_zlapmt( .false., m-q, m-q, v2t, ldv2t, iwork ) + call stdlib${ii}$_zlapmt( .false., m-q, m-q, v2t, ldv2t, iwork ) else - call stdlib_zlapmr( .false., m-q, m-q, v2t, ldv2t, iwork ) + call stdlib${ii}$_zlapmr( .false., m-q, m-q, v2t, ldv2t, iwork ) end if end if return - ! end stdlib_zuncsd - end subroutine stdlib_zuncsd + ! end stdlib${ii}$_zuncsd + end subroutine stdlib${ii}$_zuncsd - pure subroutine stdlib_zunghr( n, ilo, ihi, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_zunghr( n, ilo, ihi, a, lda, tau, work, lwork, info ) !! ZUNGHR generates a complex unitary matrix Q which is defined as the !! product of IHI-ILO elementary reflectors of order N, as returned by !! ZGEHRD: @@ -51696,8 +51699,8 @@ module stdlib_linalg_lapack_z ! -- 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, lda, lwork, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ilo, lda, lwork, n + integer(${ik}$), intent(out) :: info ! Array Arguments complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: tau(*) @@ -51706,39 +51709,39 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, iinfo, j, lwkopt, nb, nh + integer(${ik}$) :: i, iinfo, j, lwkopt, nb, nh ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ nh = ihi - ilo - lquery = ( lwork==-1 ) - if( n<0 ) then - info = -1 - else if( ilo<1 .or. ilo>max( 1, n ) ) then - info = -2 + lquery = ( lwork==-1_${ik}$ ) + if( n<0_${ik}$ ) then + info = -1_${ik}$ + else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then + info = -2_${ik}$ else if( ihin ) then - info = -3 - else if( lda0 ) then + if( nh>0_${ik}$ ) then ! generate q(ilo+1:ihi,ilo+1:ihi) - call stdlib_zungqr( nh, nh, nh, a( ilo+1, ilo+1 ), lda, tau( ilo ),work, lwork, & + call stdlib${ii}$_zungqr( nh, nh, nh, a( ilo+1, ilo+1 ), lda, tau( ilo ),work, lwork, & iinfo ) end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_zunghr + end subroutine stdlib${ii}$_zunghr - pure subroutine stdlib_zungtr( uplo, n, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_zungtr( uplo, n, a, lda, tau, work, lwork, info ) !! ZUNGTR generates a complex unitary matrix Q which is defined as the !! product of n-1 elementary reflectors of order N, as returned by !! ZHETRD: @@ -51788,8 +51791,8 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: tau(*) @@ -51798,45 +51801,45 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: lquery, upper - integer(ilp) :: i, iinfo, j, lwkopt, nb + integer(${ik}$) :: i, iinfo, j, lwkopt, nb ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${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 + if( n>1_${ik}$ ) then ! generate q(2:n,2:n) - call stdlib_zungqr( n-1, n-1, n-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) + call stdlib${ii}$_zungqr( n-1, n-1, n-1, a( 2_${ik}$, 2_${ik}$ ), lda, tau, work,lwork, iinfo ) end if end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_zungtr + end subroutine stdlib${ii}$_zungtr - pure subroutine stdlib_zunhr_col( m, n, nb, a, lda, t, ldt, d, info ) + pure subroutine stdlib${ii}$_zunhr_col( m, n, nb, a, lda, t, ldt, d, info ) !! ZUNHR_COL takes an M-by-N complex matrix Q_in with orthonormal columns !! as input, stored in A, and performs Householder Reconstruction (HR), !! i.e. reconstructs Householder vectors V(i) implicitly representing @@ -51892,38 +51895,38 @@ module stdlib_linalg_lapack_z ! -- 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, m, n, nb + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldt, m, n, nb ! Array Arguments complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: d(*), t(ldt,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, iinfo, j, jb, jbtemp1, jbtemp2, jnb, nplusone + integer(${ik}$) :: i, iinfo, j, jb, jbtemp1, jbtemp2, jnb, nplusone ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input parameters - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 .or. n>m ) then - info = -2 - else if( nb<1 ) then - info = -3 - else if( ldam ) then + info = -2_${ik}$ + else if( nb<1_${ik}$ ) then + info = -3_${ik}$ + else if( ldan ) then - call stdlib_ztrsm( 'R', 'U', 'N', 'N', m-n, n, cone, a, lda,a( n+1, 1 ), lda ) + call stdlib${ii}$_ztrsm( 'R', 'U', 'N', 'N', m-n, n, cone, a, lda,a( n+1, 1_${ik}$ ), lda ) end if ! (2) reconstruct the block reflector t stored in t(1:nb, 1:n) @@ -51946,7 +51949,7 @@ module stdlib_linalg_lapack_z ! loop over the column blocks of size nb of the array a(1:m,1:n) ! and the array t(1:nb,1:n), jb is the column index of a column ! block, jnb is the column block size at each step jb. - nplusone = n + 1 + nplusone = n + 1_${ik}$ do jb = 1, n, nb ! (2-0) determine the column block size jnb. jnb = min( nplusone-jb, nb ) @@ -51955,9 +51958,9 @@ module stdlib_linalg_lapack_z ! in a(jb:jb+jnb-1,jb:jb+jnb-1) into the upper-triangular part ! of the current jnb-by-jnb block t(1:jnb,jb:jb+jnb-1) ! column-by-column, total jnb*(jnb+1)/2 elements. - jbtemp1 = jb - 1 + jbtemp1 = jb - 1_${ik}$ do j = jb, jb+jnb-1 - call stdlib_zcopy( j-jbtemp1, a( jb, j ), 1, t( 1, j ), 1 ) + call stdlib${ii}$_zcopy( j-jbtemp1, a( jb, j ), 1_${ik}$, t( 1_${ik}$, j ), 1_${ik}$ ) end do ! (2-2) perform on the upper-triangular part of the current ! jnb-by-jnb diagonal block u(jb) (of the n-by-n matrix u) stored @@ -51971,7 +51974,7 @@ module stdlib_linalg_lapack_z ! s(jb), i.e. s(j,j) that is stored in the array element d(j). do j = jb, jb+jnb-1 if( d( j )==cone ) then - call stdlib_zscal( j-jbtemp1, -cone, t( 1, j ), 1 ) + call stdlib${ii}$_zscal( j-jbtemp1, -cone, t( 1_${ik}$, j ), 1_${ik}$ ) end if end do ! (2-3) perform the triangular solve for the current block @@ -51995,27 +51998,27 @@ module stdlib_linalg_lapack_z ! upper-triangular block t(jb): ! t(jb) * (v1(jb)**t) = (-1)*u(jb)*s(jb). ! even though the blocks x(jb) and b(jb) are upper- - ! triangular, the routine stdlib_ztrsm will access all jnb**2 + ! triangular, the routine stdlib${ii}$_ztrsm will access all jnb**2 ! elements of the square t(1:jnb,jb:jb+jnb-1). therefore, ! we need to set to zero the elements of the block ! t(1:jnb,jb:jb+jnb-1) below the diagonal before the call - ! to stdlib_ztrsm. + ! to stdlib${ii}$_ztrsm. ! (2-3a) set the elements to zero. - jbtemp2 = jb - 2 + jbtemp2 = jb - 2_${ik}$ do j = jb, jb+jnb-2 do i = j-jbtemp2, nb t( i, j ) = czero end do end do ! (2-3b) perform the triangular solve. - call stdlib_ztrsm( 'R', 'L', 'C', 'U', jnb, jnb, cone,a( jb, jb ), lda, t( 1, jb ), & + call stdlib${ii}$_ztrsm( 'R', 'L', 'C', 'U', jnb, jnb, cone,a( jb, jb ), lda, t( 1_${ik}$, jb ), & ldt ) end do return - end subroutine stdlib_zunhr_col + end subroutine stdlib${ii}$_zunhr_col - pure subroutine stdlib_zunmhr( side, trans, m, n, ilo, ihi, a, lda, tau, c,ldc, work, lwork, & + pure subroutine stdlib${ii}$_zunmhr( side, trans, m, n, ilo, ihi, a, lda, tau, c,ldc, work, lwork, & !! ZUNMHR overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -52030,8 +52033,8 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: side, trans - integer(ilp), intent(in) :: ihi, ilo, lda, ldc, lwork, m, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ilo, lda, ldc, lwork, m, n + integer(${ik}$), intent(out) :: info ! Array Arguments complex(dp), intent(inout) :: a(lda,*), c(ldc,*) complex(dp), intent(in) :: tau(*) @@ -52039,82 +52042,82 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! Local Scalars logical(lk) :: left, lquery - integer(ilp) :: i1, i2, iinfo, lwkopt, mi, nb, nh, ni, nq, nw + integer(${ik}$) :: i1, i2, iinfo, lwkopt, mi, nb, nh, ni, nq, nw ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ nh = ihi - ilo left = stdlib_lsame( side, 'L' ) - 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.stdlib_lsame( trans, 'N' ) .and. .not.stdlib_lsame( trans, 'C' ) )& then - info = -2 - else if( m<0 ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( ilo<1 .or. ilo>max( 1, nq ) ) then - info = -5 + info = -2_${ik}$ + else if( m<0_${ik}$ ) then + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, nq ) ) then + info = -5_${ik}$ else if( ihinq ) then - info = -6 - else if( lda1 ) then + if( n>1_${ik}$ ) then ! generate q(2:n,2:n) - call stdlib_zung2r( n-1, n-1, n-1, q( 2, 2 ), ldq, tau, work,iinfo ) + call stdlib${ii}$_zung2r( n-1, n-1, n-1, q( 2_${ik}$, 2_${ik}$ ), ldq, tau, work,iinfo ) end if end if return - end subroutine stdlib_zupgtr + end subroutine stdlib${ii}$_zupgtr - pure subroutine stdlib_zupmtr( side, uplo, trans, m, n, ap, tau, c, ldc, work,info ) + pure subroutine stdlib${ii}$_zupmtr( side, uplo, trans, m, n, ap, tau, c, ldc, work,info ) !! ZUPMTR overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -52333,8 +52336,8 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: side, trans, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldc, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldc, m, n ! Array Arguments complex(dp), intent(inout) :: ap(*), c(ldc,*) complex(dp), intent(in) :: tau(*) @@ -52343,13 +52346,13 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: forwrd, left, notran, upper - integer(ilp) :: i, i1, i2, i3, ic, ii, jc, mi, ni, nq + integer(${ik}$) :: i, i1, i2, i3, ic, ii, jc, mi, ni, nq complex(dp) :: aii, taui ! Intrinsic Functions intrinsic :: conjg,max ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ left = stdlib_lsame( side, 'L' ) notran = stdlib_lsame( trans, 'N' ) upper = stdlib_lsame( uplo, 'U' ) @@ -52360,37 +52363,37 @@ module stdlib_linalg_lapack_z nq = n end if if( .not.left .and. .not.stdlib_lsame( side, 'R' ) ) then - info = -1 + info = -1_${ik}$ else if( .not.upper .and. .not.stdlib_lsame( uplo, 'L' ) ) then - info = -2 + info = -2_${ik}$ else if( .not.notran .and. .not.stdlib_lsame( trans, 'C' ) ) then - info = -3 - else if( m<0 ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( ldcxnrm*cte )go to 10 end do ! if we are here, the nrhs normwise backward errors satisfy the ! stopping criterion. we are good to exit. - iter = 0 + iter = 0_${ik}$ return 10 continue loop_30: do iiter = 1, itermax ! convert r (in work) from double precision to single precision ! and store the result in sx. - call stdlib_zlag2c( n, nrhs, work, n, swork( ptsx ), n, info ) - if( info/=0 ) then - iter = -2 + call stdlib${ii}$_zlag2c( n, nrhs, work, n, swork( ptsx ), n, info ) + if( info/=0_${ik}$ ) then + iter = -2_${ik}$ go to 40 end if ! solve the system sa*sx = sr. - call stdlib_cpotrs( uplo, n, nrhs, swork( ptsa ), n, swork( ptsx ), n,info ) + call stdlib${ii}$_cpotrs( uplo, n, nrhs, swork( ptsa ), n, swork( ptsx ), n,info ) ! convert sx back to double precision and update the current ! iterate. - call stdlib_clag2z( n, nrhs, swork( ptsx ), n, work, n, info ) + call stdlib${ii}$_clag2z( n, nrhs, swork( ptsx ), n, work, n, info ) do i = 1, nrhs - call stdlib_zaxpy( n, cone, work( 1, i ), 1, x( 1, i ), 1 ) + call stdlib${ii}$_zaxpy( n, cone, work( 1_${ik}$, i ), 1_${ik}$, x( 1_${ik}$, i ), 1_${ik}$ ) end do ! compute r = b - ax (r is work). - call stdlib_zlacpy( 'ALL', n, nrhs, b, ldb, work, n ) - call stdlib_zhemm( 'L', uplo, n, nrhs, cnegone, a, lda, x, ldx, cone,work, n ) + call stdlib${ii}$_zlacpy( 'ALL', n, nrhs, b, ldb, work, n ) + call stdlib${ii}$_zhemm( 'L', uplo, n, nrhs, cnegone, a, lda, x, ldx, cone,work, n ) ! check whether the nrhs normwise backward errors satisfy the ! stopping criterion. if yes, set iter=iiter>0 and return. do i = 1, nrhs - xnrm = cabs1( x( stdlib_izamax( n, x( 1, i ), 1 ), i ) ) - rnrm = cabs1( work( stdlib_izamax( n, work( 1, i ), 1 ), i ) ) + xnrm = cabs1( x( stdlib${ii}$_izamax( n, x( 1_${ik}$, i ), 1_${ik}$ ), i ) ) + rnrm = cabs1( work( stdlib${ii}$_izamax( n, work( 1_${ik}$, i ), 1_${ik}$ ), i ) ) if( rnrm>xnrm*cte )go to 20 end do ! if we are here, the nrhs normwise backward errors satisfy the @@ -52649,19 +52652,19 @@ module stdlib_linalg_lapack_z ! performed iter=itermax iterations and never satisfied the ! stopping criterion, set up the iter flag accordingly and follow ! up on double precision routine. - iter = -itermax - 1 + iter = -itermax - 1_${ik}$ 40 continue ! single-precision iterative refinement failed to converge to a ! satisfactory solution, so we resort to double precision. - call stdlib_zpotrf( uplo, n, a, lda, info ) + call stdlib${ii}$_zpotrf( uplo, n, a, lda, info ) if( info/=0 )return - call stdlib_zlacpy( 'ALL', n, nrhs, b, ldb, x, ldx ) - call stdlib_zpotrs( uplo, n, nrhs, a, lda, x, ldx, info ) + call stdlib${ii}$_zlacpy( 'ALL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_zpotrs( uplo, n, nrhs, a, lda, x, ldx, info ) return - end subroutine stdlib_zcposv + end subroutine stdlib${ii}$_zcposv - pure subroutine stdlib_zgbbrd( vect, m, n, ncc, kl, ku, ab, ldab, d, e, q,ldq, pt, ldpt, c, & + pure subroutine stdlib${ii}$_zgbbrd( vect, m, n, ncc, kl, ku, ab, ldab, d, e, q,ldq, pt, ldpt, c, & !! ZGBBRD reduces a complex general m-by-n band matrix A to real upper !! bidiagonal form B by a unitary transformation: Q**H * A * P = B. !! The routine computes B, and optionally forms Q or P**H, or computes @@ -52672,8 +52675,8 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: vect - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kl, ku, ldab, ldc, ldpt, ldq, m, n, ncc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl, ku, ldab, ldc, ldpt, ldq, m, n, ncc ! Array Arguments real(dp), intent(out) :: d(*), e(*), rwork(*) complex(dp), intent(inout) :: ab(ldab,*), c(ldc,*) @@ -52683,7 +52686,7 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: wantb, wantc, wantpt, wantq - integer(ilp) :: i, inca, j, j1, j2, kb, kb1, kk, klm, klu1, kun, l, minmn, ml, ml0, mu,& + integer(${ik}$) :: i, inca, j, j1, j2, kb, kb1, kk, klm, klu1, kun, l, minmn, ml, ml0, mu,& mu0, nr, nrt real(dp) :: abst, rc complex(dp) :: ra, rb, rs, t @@ -52694,50 +52697,50 @@ module stdlib_linalg_lapack_z wantb = stdlib_lsame( vect, 'B' ) wantq = stdlib_lsame( vect, 'Q' ) .or. wantb wantpt = stdlib_lsame( vect, 'P' ) .or. wantb - wantc = ncc>0 - 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 + if( kl+ku>1_${ik}$ ) then ! reduce to upper bidiagonal form if ku > 0; if ku = 0, 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. @@ -52746,107 +52749,107 @@ module stdlib_linalg_lapack_z 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_zlargv( nr, ab( klu1, j1-klm-1 ), inca,work( j1 ), kb1, & + if( nr>0_${ik}$ )call stdlib${ii}$_zlargv( nr, ab( klu1, j1-klm-1 ), inca,work( j1 ), kb1, & rwork( 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_zlartv( nrt, ab( klu1-l, j1-klm+l-1 ), inca,ab( & + if( nrt>0_${ik}$ )call stdlib${ii}$_zlartv( nrt, ab( klu1-l, j1-klm+l-1 ), inca,ab( & klu1-l+1, j1-klm+l-1 ), inca,rwork( j1 ), work( j1 ), kb1 ) end do if( ml>ml0 ) then if( ml<=m-i+1 ) then ! generate plane rotation to annihilate a(i+ml-1,i) ! within the band, and apply rotation from the left - call stdlib_zlartg( ab( ku+ml-1, i ), ab( ku+ml, i ),rwork( i+ml-1 ), & + call stdlib${ii}$_zlartg( ab( ku+ml-1, i ), ab( ku+ml, i ),rwork( i+ml-1 ), & work( i+ml-1 ), ra ) ab( ku+ml-1, i ) = ra - if( 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 ) = rwork( j )*ab( 1, j+kun ) + work( j+kun ) = work( j )*ab( 1_${ik}$, j+kun ) + ab( 1_${ik}$, j+kun ) = rwork( 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_zlargv( nr, ab( 1, j1+kun-1 ), inca,work( j1+kun ), kb1,& + if( nr>0_${ik}$ )call stdlib${ii}$_zlargv( nr, ab( 1_${ik}$, j1+kun-1 ), inca,work( j1+kun ), kb1,& rwork( 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_zlartv( nrt, ab( l+1, j1+kun-1 ), inca,ab( l, j1+& + if( nrt>0_${ik}$ )call stdlib${ii}$_zlartv( nrt, ab( l+1, j1+kun-1 ), inca,ab( l, j1+& kun ), inca,rwork( j1+kun ), work( j1+kun ), kb1 ) end do if( ml==ml0 .and. mu>mu0 ) then if( mu<=n-i+1 ) then ! generate plane rotation to annihilate a(i,i+mu-1) ! within the band, and apply rotation from the right - call stdlib_zlartg( ab( ku-mu+3, i+mu-2 ),ab( ku-mu+2, i+mu-1 ),rwork( & + call stdlib${ii}$_zlartg( ab( ku-mu+3, i+mu-2 ),ab( ku-mu+2, i+mu-1 ),rwork( & i+mu-1 ), work( i+mu-1 ), ra ) ab( ku-mu+3, i+mu-2 ) = ra - call stdlib_zrot( min( kl+mu-2, m-i ),ab( ku-mu+4, i+mu-2 ), 1,ab( ku-& - mu+3, i+mu-1 ), 1,rwork( i+mu-1 ), work( i+mu-1 ) ) + call stdlib${ii}$_zrot( min( kl+mu-2, m-i ),ab( ku-mu+4, i+mu-2 ), 1_${ik}$,ab( ku-& + mu+3, i+mu-1 ), 1_${ik}$,rwork( 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**h do j = j1, j2, kb1 - call stdlib_zrot( n, pt( j+kun-1, 1 ), ldpt,pt( j+kun, 1 ), ldpt, rwork(& + call stdlib${ii}$_zrot( n, pt( j+kun-1, 1_${ik}$ ), ldpt,pt( j+kun, 1_${ik}$ ), ldpt, rwork(& j+kun ),conjg( 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 @@ -52856,52 +52859,52 @@ module stdlib_linalg_lapack_z ab( klu1, j+kun ) = rwork( 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 complex lower bidiagonal form ! transform lower bidiagonal form to upper bidiagonal by applying ! plane rotations from the left, overwriting superdiagonal ! elements on subdiagonal elements do i = 1, min( m-1, n ) - call stdlib_zlartg( ab( 1, i ), ab( 2, i ), rc, rs, ra ) - ab( 1, i ) = ra + call stdlib${ii}$_zlartg( ab( 1_${ik}$, i ), ab( 2_${ik}$, i ), rc, rs, ra ) + ab( 1_${ik}$, i ) = ra if( i0 .and. m0_${ik}$ .and. m1 ) then + if( i>1_${ik}$ ) then rb = -conjg( rs )*ab( ku, i ) ab( ku, i ) = rc*ab( ku, i ) end if - if( wantpt )call stdlib_zrot( n, pt( i, 1 ), ldpt, pt( m+1, 1 ), ldpt,rc, & + if( wantpt )call stdlib${ii}$_zrot( n, pt( i, 1_${ik}$ ), ldpt, pt( m+1, 1_${ik}$ ), ldpt,rc, & conjg( rs ) ) end do end if end if ! make diagonal and superdiagonal elements real, storing them in d ! and e - t = ab( ku+1, 1 ) + t = ab( ku+1, 1_${ik}$ ) loop_120: do i = 1, minmn abst = abs( t ) d( i ) = abst @@ -52910,15 +52913,15 @@ module stdlib_linalg_lapack_z else t = cone end if - if( wantq )call stdlib_zscal( m, t, q( 1, i ), 1 ) - if( wantc )call stdlib_zscal( ncc, conjg( t ), c( i, 1 ), ldc ) + if( wantq )call stdlib${ii}$_zscal( m, t, q( 1_${ik}$, i ), 1_${ik}$ ) + if( wantc )call stdlib${ii}$_zscal( ncc, conjg( t ), c( i, 1_${ik}$ ), ldc ) if( ieps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_zgbtrs( trans, n, kl, ku, 1, afb, ldafb, ipiv, work, n,info ) - call stdlib_zaxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_zgbtrs( trans, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv, work, n,info ) + call stdlib${ii}$_zaxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -53112,13 +53115,13 @@ module stdlib_linalg_lapack_z rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(op(a)**h). - call stdlib_zgbtrs( transt, n, kl, ku, 1, afb, ldafb, ipiv,work, n, info ) + call stdlib${ii}$_zgbtrs( transt, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) @@ -53128,7 +53131,7 @@ module stdlib_linalg_lapack_z do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_zgbtrs( transn, n, kl, ku, 1, afb, ldafb, ipiv,work, n, info ) + call stdlib${ii}$_zgbtrs( transn, n, kl, ku, 1_${ik}$, afb, ldafb, ipiv,work, n, info ) end if go to 100 @@ -53141,10 +53144,10 @@ module stdlib_linalg_lapack_z if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_zgbrfs + end subroutine stdlib${ii}$_zgbrfs - pure subroutine stdlib_zgbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) + pure subroutine stdlib${ii}$_zgbsv( n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) !! ZGBSV computes the solution to a complex system of linear equations !! A * X = B, where A is a band matrix of order N with KL subdiagonals !! and KU superdiagonals, and X and B are N-by-NRHS matrices. @@ -53157,46 +53160,46 @@ module stdlib_linalg_lapack_z ! -- 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, ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kl, ku, ldab, ldb, n, nrhs ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(dp), intent(inout) :: ab(ldab,*), b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 - if( n<0 ) then - info = -1 - else if( kl<0 ) then - info = -2 - else if( ku<0 ) then - info = -3 - else if( nrhs<0 ) then - info = -4 - else if( ldab<2*kl+ku+1 ) then - info = -6 - else if( ldb0 ) then + info = -13_${ik}$ + else if( n>0_${ik}$ ) then rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) else rowcnd = one end if end if - if( colequ .and. info==0 ) then + if( colequ .and. info==0_${ik}$ ) then rcmin = bignum rcmax = zero do j = 1, n @@ -53291,32 +53294,32 @@ module stdlib_linalg_lapack_z rcmax = max( rcmax, c( j ) ) end do if( rcmin<=zero ) then - info = -14 - else if( n>0 ) then + info = -14_${ik}$ + else if( n>0_${ik}$ ) then colcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) else colcnd = one end if end if - if( info==0 ) then - if( ldb0 ) then + if( info>0_${ik}$ ) then ! compute the reciprocal pivot growth factor of the ! leading rank-deficient info columns of a. anorm = zero @@ -53357,14 +53360,14 @@ module stdlib_linalg_lapack_z anorm = max( anorm, abs( ab( i, j ) ) ) end do end do - rpvgrw = stdlib_zlantb( 'M', 'U', 'N', info, min( info-1, kl+ku ),afb( max( 1, & - kl+ku+2-info ), 1 ), ldafb,rwork ) + rpvgrw = stdlib${ii}$_zlantb( 'M', 'U', 'N', info, min( info-1, kl+ku ),afb( max( 1_${ik}$, & + kl+ku+2-info ), 1_${ik}$ ), ldafb,rwork ) if( rpvgrw==zero ) then rpvgrw = one else rpvgrw = anorm / rpvgrw end if - rwork( 1 ) = rpvgrw + rwork( 1_${ik}$ ) = rpvgrw rcond = zero return end if @@ -53376,22 +53379,22 @@ module stdlib_linalg_lapack_z else norm = 'I' end if - anorm = stdlib_zlangb( norm, n, kl, ku, ab, ldab, rwork ) - rpvgrw = stdlib_zlantb( 'M', 'U', 'N', n, kl+ku, afb, ldafb, rwork ) + anorm = stdlib${ii}$_zlangb( norm, n, kl, ku, ab, ldab, rwork ) + rpvgrw = stdlib${ii}$_zlantb( 'M', 'U', 'N', n, kl+ku, afb, ldafb, rwork ) if( rpvgrw==zero ) then rpvgrw = one else - rpvgrw = stdlib_zlangb( 'M', n, kl, ku, ab, ldab, rwork ) / rpvgrw + rpvgrw = stdlib${ii}$_zlangb( 'M', n, kl, ku, ab, ldab, rwork ) / rpvgrw end if ! compute the reciprocal of the condition number of a. - call stdlib_zgbcon( norm, n, kl, ku, afb, ldafb, ipiv, anorm, rcond,work, rwork, info ) + call stdlib${ii}$_zgbcon( norm, n, kl, ku, afb, ldafb, ipiv, anorm, rcond,work, rwork, info ) ! compute the solution matrix x. - call stdlib_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_zgbtrs( trans, n, kl, ku, nrhs, afb, ldafb, ipiv, x, ldx,info ) + call stdlib${ii}$_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_zgbtrs( trans, n, kl, ku, nrhs, afb, ldafb, ipiv, x, ldx,info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_zgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv,b, ldb, x, ldx, & + call stdlib${ii}$_zgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv,b, ldb, x, ldx, & ferr, berr, work, rwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -53417,13 +53420,13 @@ module stdlib_linalg_lapack_z end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. @@ -53431,8 +53434,8 @@ module stdlib_linalg_lapack_z ! -- 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, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, lwork, m, n ! Array Arguments real(dp), intent(out) :: d(*), e(*) complex(dp), intent(inout) :: a(lda,*) @@ -53441,54 +53444,54 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, iinfo, j, ldwrkx, ldwrky, lwkopt, minmn, nb, nbmin, nx, ws + integer(${ik}$) :: i, iinfo, j, ldwrkx, ldwrky, lwkopt, minmn, nb, nbmin, nx, ws ! Intrinsic Functions intrinsic :: real,max,min ! Executable Statements ! test the input parameters - info = 0 - nb = max( 1, stdlib_ilaenv( 1, 'ZGEBRD', ' ', m, n, -1, -1 ) ) + info = 0_${ik}$ + nb = max( 1_${ik}$, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEBRD', ' ', m, n, -1_${ik}$, -1_${ik}$ ) ) lwkopt = ( m+n )*nb - work( 1 ) = real( lwkopt,KIND=dp) - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda1 .and. nb1_${ik}$ .and. nb=( m+n )*nbmin ) then nb = lwork / ( m+n ) else - nb = 1 + nb = 1_${ik}$ nx = minmn end if end if @@ -53500,14 +53503,14 @@ module stdlib_linalg_lapack_z ! reduce rows and columns i:i+ib-1 to bidiagonal form and return ! the matrices x and y which are needed to update the unreduced ! part of the matrix - call stdlib_zlabrd( m-i+1, n-i+1, nb, a( i, i ), lda, d( i ), e( i ),tauq( i ), & + call stdlib${ii}$_zlabrd( m-i+1, n-i+1, nb, a( i, i ), lda, d( i ), e( i ),tauq( i ), & taup( i ), work, ldwrkx,work( ldwrkx*nb+1 ), ldwrky ) ! update the trailing submatrix a(i+ib:m,i+ib:n), using ! an update of the form a := a - v*y**h - x*u**h - call stdlib_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m-i-nb+1,n-i-nb+1, nb, -& + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE', m-i-nb+1,n-i-nb+1, nb, -& cone, a( i+nb, i ), lda,work( ldwrkx*nb+nb+1 ), ldwrky, cone,a( i+nb, i+nb ), lda ) - call stdlib_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-i-nb+1, n-i-nb+1,nb, -cone, & + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-i-nb+1, n-i-nb+1,nb, -cone, & work( nb+1 ), ldwrkx, a( i, i+nb ), lda,cone, a( i+nb, i+nb ), lda ) ! copy diagonal and off-diagonal elements of b back into a if( m>=n ) then @@ -53523,61 +53526,61 @@ module stdlib_linalg_lapack_z end if end do ! use unblocked code to reduce the remainder of the matrix - call stdlib_zgebd2( m-i+1, n-i+1, a( i, i ), lda, d( i ), e( i ),tauq( i ), taup( i ), & + call stdlib${ii}$_zgebd2( m-i+1, n-i+1, a( i, i ), lda, d( i ), e( i ),tauq( i ), taup( i ), & work, iinfo ) - work( 1 ) = ws + work( 1_${ik}$ ) = ws return - end subroutine stdlib_zgebrd + end subroutine stdlib${ii}$_zgebrd - pure subroutine stdlib_zgehrd( n, ilo, ihi, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_zgehrd( n, ilo, ihi, a, lda, tau, work, lwork, info ) !! ZGEHRD reduces a complex general matrix A to upper Hessenberg form H by !! an unitary similarity transformation: Q**H * A * Q = H . ! -- 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) :: ihi, ilo, lda, lwork, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ilo, lda, lwork, n + integer(${ik}$), intent(out) :: info ! Array Arguments complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: tau(*), 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) :: lquery - integer(ilp) :: i, ib, iinfo, iwt, j, ldwork, lwkopt, nb, nbmin, nh, nx + integer(${ik}$) :: i, ib, iinfo, iwt, j, ldwork, lwkopt, nb, nbmin, nh, nx complex(dp) :: ei ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input parameters - info = 0 - lquery = ( lwork==-1 ) - if( n<0 ) then - info = -1 - else if( ilo<1 .or. ilo>max( 1, n ) ) then - info = -2 + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) + if( n<0_${ik}$ ) then + info = -1_${ik}$ + else if( ilo<1_${ik}$ .or. ilo>max( 1_${ik}$, n ) ) then + info = -2_${ik}$ else if( ihin ) then - info = -3 - else if( lda1 .and. nb1_${ik}$ .and. nb=(n*nbmin + tsize) ) then nb = (lwork-tsize) / n else - nb = 1 + nb = 1_${ik}$ end if end if end if @@ -53623,74 +53626,74 @@ module stdlib_linalg_lapack_z i = ilo else ! use blocked code - iwt = 1 + n*nb + iwt = 1_${ik}$ + n*nb do i = ilo, ihi - 1 - nx, nb ib = min( nb, ihi-i ) ! reduce columns i:i+ib-1 to hessenberg form, returning the ! matrices v and t of the block reflector h = i - v*t*v**h ! which performs the reduction, and also the matrix y = a*v*t - call stdlib_zlahr2( ihi, i, ib, a( 1, i ), lda, tau( i ),work( iwt ), ldt, work, & + call stdlib${ii}$_zlahr2( ihi, i, ib, a( 1_${ik}$, i ), lda, tau( i ),work( iwt ), ldt, work, & ldwork ) ! apply the block reflector h to a(1:ihi,i+ib:ihi) from the ! right, computing a := a - y * v**h. v(i+ib,ib-1) must be set ! to 1 ei = a( i+ib, i+ib-1 ) a( i+ib, i+ib-1 ) = cone - call stdlib_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',ihi, ihi-i-ib+1,ib, -& - cone, work, ldwork, a( i+ib, i ), lda, cone,a( 1, i+ib ), lda ) + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',ihi, ihi-i-ib+1,ib, -& + cone, work, ldwork, a( i+ib, i ), lda, cone,a( 1_${ik}$, i+ib ), lda ) a( i+ib, i+ib-1 ) = ei ! apply the block reflector h to a(1:i,i+1:i+ib-1) from the ! right - call stdlib_ztrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', i, ib-1,cone, & + call stdlib${ii}$_ztrmm( 'RIGHT', 'LOWER', 'CONJUGATE TRANSPOSE','UNIT', i, ib-1,cone, & a( i+1, i ), lda, work, ldwork ) do j = 0, ib-2 - call stdlib_zaxpy( i, -cone, work( ldwork*j+1 ), 1,a( 1, i+j+1 ), 1 ) + call stdlib${ii}$_zaxpy( i, -cone, work( ldwork*j+1 ), 1_${ik}$,a( 1_${ik}$, i+j+1 ), 1_${ik}$ ) end do ! apply the block reflector h to a(i+1:ihi,i+ib:n) from the ! left - call stdlib_zlarfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'FORWARD','COLUMNWISE',ihi-i, & + call stdlib${ii}$_zlarfb( 'LEFT', 'CONJUGATE TRANSPOSE', 'FORWARD','COLUMNWISE',ihi-i, & n-i-ib+1, ib, a( i+1, i ), lda,work( iwt ), ldt, a( i+1, i+ib ), lda,work, & ldwork ) end do end if ! use unblocked code to reduce the rest of the matrix - call stdlib_zgehd2( n, i, ihi, a, lda, tau, work, iinfo ) - work( 1 ) = lwkopt + call stdlib${ii}$_zgehd2( n, i, ihi, a, lda, tau, work, iinfo ) + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_zgehrd + end subroutine stdlib${ii}$_zgehrd - pure subroutine stdlib_zgelqt( m, n, mb, a, lda, t, ldt, work, info ) + pure subroutine stdlib${ii}$_zgelqt( m, n, mb, a, lda, t, ldt, work, info ) !! ZGELQT computes a blocked LQ factorization of a complex M-by-N matrix A !! using the compact WY representation of Q. ! -- 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, ldt, m, n, mb + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldt, m, n, mb ! Array Arguments complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: t(ldt,*), work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, ib, iinfo, k + integer(${ik}$) :: i, ib, iinfo, k ! Executable Statements ! test the input arguments - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( mb<1 .or. (mb>min(m,n) .and. min(m,n)>0 ))then - info = -3 - else if( ldamin(m,n) .and. min(m,n)>0_${ik}$ ))then + info = -3_${ik}$ + else if( lda=n ) then - nb = stdlib_ilaenv( 1, 'ZGEQRF', ' ', m, n, -1, -1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) if( tpsd ) then - nb = max( nb, stdlib_ilaenv( 1, 'ZUNMQR', 'LN', m, nrhs, n,-1 ) ) + nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', 'LN', m, nrhs, n,-1_${ik}$ ) ) else - nb = max( nb, stdlib_ilaenv( 1, 'ZUNMQR', 'LC', m, nrhs, n,-1 ) ) + nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', 'LC', m, nrhs, n,-1_${ik}$ ) ) end if else - nb = stdlib_ilaenv( 1, 'ZGELQF', ' ', m, n, -1, -1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGELQF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) if( tpsd ) then - nb = max( nb, stdlib_ilaenv( 1, 'ZUNMLQ', 'LC', n, nrhs, m,-1 ) ) + nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMLQ', 'LC', n, nrhs, m,-1_${ik}$ ) ) else - nb = max( nb, stdlib_ilaenv( 1, 'ZUNMLQ', 'LN', n, nrhs, m,-1 ) ) + nb = max( nb, stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMLQ', 'LN', n, nrhs, m,-1_${ik}$ ) ) end if end if - wsize = max( 1, mn+max( mn, nrhs )*nb ) - work( 1 ) = real( wsize,KIND=dp) + wsize = max( 1_${ik}$, mn+max( mn, nrhs )*nb ) + work( 1_${ik}$ ) = real( wsize,KIND=dp) end if - if( info/=0 ) then - call stdlib_xerbla( 'ZGELS ', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZGELS ', -info ) return else if( lquery ) then return end if ! quick return if possible - if( min( m, n, nrhs )==0 ) then - call stdlib_zlaset( 'FULL', max( m, n ), nrhs, czero, czero, b, ldb ) + if( min( m, n, nrhs )==0_${ik}$ ) then + call stdlib${ii}$_zlaset( 'FULL', max( m, n ), nrhs, czero, czero, b, ldb ) return end if ! get machine parameters - smlnum = stdlib_dlamch( 'S' ) / stdlib_dlamch( 'P' ) + smlnum = stdlib${ii}$_dlamch( 'S' ) / stdlib${ii}$_dlamch( 'P' ) bignum = one / smlnum - call stdlib_dlabad( smlnum, bignum ) + call stdlib${ii}$_dlabad( smlnum, bignum ) ! scale a, b if max element outside range [smlnum,bignum] - anrm = stdlib_zlange( 'M', m, n, a, lda, rwork ) - iascl = 0 + anrm = stdlib${ii}$_zlange( 'M', m, n, a, lda, rwork ) + iascl = 0_${ik}$ if( anrm>zero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_zlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_zlaset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) + call stdlib${ii}$_zlaset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) go to 50 end if brow = m if( tpsd )brow = n - bnrm = stdlib_zlange( 'M', brow, nrhs, b, ldb, rwork ) - ibscl = 0 + bnrm = stdlib${ii}$_zlange( 'M', brow, nrhs, b, ldb, rwork ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_zlascl( 'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,info ) - ibscl = 2 + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, brow, nrhs, b, ldb,info ) + ibscl = 2_${ik}$ end if if( m>=n ) then ! compute qr factorization of a - call stdlib_zgeqrf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,info ) + call stdlib${ii}$_zgeqrf( m, n, a, lda, work( 1_${ik}$ ), work( mn+1 ), lwork-mn,info ) ! workspace at least n, optimally n*nb if( .not.tpsd ) then ! least-squares problem min || a * x - b || ! b(1:m,1:nrhs) := q**h * b(1:m,1:nrhs) - call stdlib_zunmqr( 'LEFT', 'CONJUGATE TRANSPOSE', m, nrhs, n, a,lda, work( 1 ), & + call stdlib${ii}$_zunmqr( 'LEFT', 'CONJUGATE TRANSPOSE', m, nrhs, n, a,lda, work( 1_${ik}$ ), & b, ldb, work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb ! b(1:n,1:nrhs) := inv(r) * b(1:n,1:nrhs) - call stdlib_ztrtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, nrhs,a, lda, b, ldb, & + call stdlib${ii}$_ztrtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n, nrhs,a, lda, b, ldb, & info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if scllen = n else ! underdetermined system of equations a**t * x = b ! b(1:n,1:nrhs) := inv(r**h) * b(1:n,1:nrhs) - call stdlib_ztrtrs( 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT',n, nrhs, a, lda, b,& + call stdlib${ii}$_ztrtrs( 'UPPER', 'CONJUGATE TRANSPOSE','NON-UNIT',n, nrhs, a, lda, b,& ldb, info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if ! b(n+1:m,1:nrhs) = zero @@ -53869,21 +53872,21 @@ module stdlib_linalg_lapack_z end do end do ! b(1:m,1:nrhs) := q(1:n,:) * b(1:n,1:nrhs) - call stdlib_zunmqr( 'LEFT', 'NO TRANSPOSE', m, nrhs, n, a, lda,work( 1 ), b, ldb,& + call stdlib${ii}$_zunmqr( 'LEFT', 'NO TRANSPOSE', m, nrhs, n, a, lda,work( 1_${ik}$ ), b, ldb,& work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb scllen = m end if else ! compute lq factorization of a - call stdlib_zgelqf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn,info ) + call stdlib${ii}$_zgelqf( m, n, a, lda, work( 1_${ik}$ ), work( mn+1 ), lwork-mn,info ) ! workspace at least m, optimally m*nb. if( .not.tpsd ) then ! underdetermined system of equations a * x = b ! b(1:m,1:nrhs) := inv(l) * b(1:m,1:nrhs) - call stdlib_ztrtrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & + call stdlib${ii}$_ztrtrs( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', m, nrhs,a, lda, b, ldb, & info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if ! b(m+1:n,1:nrhs) = 0 @@ -53893,134 +53896,134 @@ module stdlib_linalg_lapack_z end do end do ! b(1:n,1:nrhs) := q(1:n,:)**h * b(1:m,1:nrhs) - call stdlib_zunmlq( 'LEFT', 'CONJUGATE TRANSPOSE', n, nrhs, m, a,lda, work( 1 ), & + call stdlib${ii}$_zunmlq( 'LEFT', 'CONJUGATE TRANSPOSE', n, nrhs, m, a,lda, work( 1_${ik}$ ), & b, ldb, work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb scllen = n else ! overdetermined system min || a**h * x - b || ! b(1:n,1:nrhs) := q * b(1:n,1:nrhs) - call stdlib_zunmlq( 'LEFT', 'NO TRANSPOSE', n, nrhs, m, a, lda,work( 1 ), b, ldb,& + call stdlib${ii}$_zunmlq( 'LEFT', 'NO TRANSPOSE', n, nrhs, m, a, lda,work( 1_${ik}$ ), b, ldb,& work( mn+1 ), lwork-mn,info ) ! workspace at least nrhs, optimally nrhs*nb ! b(1:m,1:nrhs) := inv(l**h) * b(1:m,1:nrhs) - call stdlib_ztrtrs( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',m, nrhs, a, lda, & + call stdlib${ii}$_ztrtrs( 'LOWER', 'CONJUGATE TRANSPOSE', 'NON-UNIT',m, nrhs, a, lda, & b, ldb, info ) - if( info>0 ) then + if( info>0_${ik}$ ) then return end if scllen = m end if end if ! undo scaling - if( iascl==1 ) then - call stdlib_zlascl( 'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,info ) - else if( iascl==2 ) then - call stdlib_zlascl( 'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,info ) + if( iascl==1_${ik}$ ) then + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, smlnum, scllen, nrhs, b, ldb,info ) + else if( iascl==2_${ik}$ ) then + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, scllen, nrhs, b, ldb,info ) end if - if( ibscl==1 ) then - call stdlib_zlascl( 'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,info ) - else if( ibscl==2 ) then - call stdlib_zlascl( 'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,info ) + if( ibscl==1_${ik}$ ) then + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, bnrm, scllen, nrhs, b, ldb,info ) + else if( ibscl==2_${ik}$ ) then + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bignum, bnrm, scllen, nrhs, b, ldb,info ) end if 50 continue - work( 1 ) = real( wsize,KIND=dp) + work( 1_${ik}$ ) = real( wsize,KIND=dp) return - end subroutine stdlib_zgels + end subroutine stdlib${ii}$_zgels - pure subroutine stdlib_zgeqp3( m, n, a, lda, jpvt, tau, work, lwork, rwork,info ) + pure subroutine stdlib${ii}$_zgeqp3( m, n, a, lda, jpvt, tau, work, lwork, rwork,info ) !! ZGEQP3 computes a QR factorization with column pivoting of a !! matrix A: A*P = Q*R using Level 3 BLAS. ! -- lapack computational routine -- ! -- 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, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, lwork, m, n ! Array Arguments - integer(ilp), intent(inout) :: jpvt(*) + integer(${ik}$), intent(inout) :: jpvt(*) real(dp), intent(out) :: rwork(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: tau(*), work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: inb = 1 - integer(ilp), parameter :: inbmin = 2 - integer(ilp), parameter :: ixover = 3 + integer(${ik}$), parameter :: inb = 1_${ik}$ + integer(${ik}$), parameter :: inbmin = 2_${ik}$ + integer(${ik}$), parameter :: ixover = 3_${ik}$ ! Local Scalars logical(lk) :: lquery - integer(ilp) :: fjb, iws, j, jb, lwkopt, minmn, minws, na, nb, nbmin, nfxd, nx, sm, & + integer(${ik}$) :: fjb, iws, j, jb, lwkopt, minmn, minws, na, nb, nbmin, nfxd, nx, sm, & sminmn, sn, topbmn ! Intrinsic Functions intrinsic :: int,max,min ! Executable Statements ! test input arguments ! ==================== - info = 0 - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda0 ) then + if( nfxd>0_${ik}$ ) then na = min( m, nfxd ) - ! cc call stdlib_zgeqr2( m, na, a, lda, tau, work, info ) - call stdlib_zgeqrf( m, na, a, lda, tau, work, lwork, info ) - iws = max( iws, int( work( 1 ),KIND=ilp) ) + ! cc call stdlib${ii}$_zgeqr2( m, na, a, lda, tau, work, info ) + call stdlib${ii}$_zgeqrf( m, na, a, lda, tau, work, lwork, info ) + iws = max( iws, int( work( 1_${ik}$ ),KIND=${ik}$) ) if( na1 ) .and. ( nb1_${ik}$ ) .and. ( nb=nbmin ) .and. ( nbmin(m,n) .and. min(m,n)>0 ) )then - info = -3 - else if( ldamin(m,n) .and. min(m,n)>0_${ik}$ ) )then + info = -3_${ik}$ + else if( ldaeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_zgetrs( trans, n, 1, af, ldaf, ipiv, work, n, info ) - call stdlib_zaxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_zgetrs( trans, n, 1_${ik}$, af, ldaf, ipiv, work, n, info ) + call stdlib${ii}$_zaxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -54305,13 +54308,13 @@ module stdlib_linalg_lapack_z rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(op(a)**h). - call stdlib_zgetrs( transt, n, 1, af, ldaf, ipiv, work, n,info ) + call stdlib${ii}$_zgetrs( transt, n, 1_${ik}$, af, ldaf, ipiv, work, n,info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do @@ -54320,7 +54323,7 @@ module stdlib_linalg_lapack_z do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_zgetrs( transn, n, 1, af, ldaf, ipiv, work, n,info ) + call stdlib${ii}$_zgetrs( transn, n, 1_${ik}$, af, ldaf, ipiv, work, n,info ) end if go to 100 end if @@ -54332,10 +54335,10 @@ module stdlib_linalg_lapack_z if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_zgerfs + end subroutine stdlib${ii}$_zgerfs - pure subroutine stdlib_zgetrf( m, n, a, lda, ipiv, info ) + pure subroutine stdlib${ii}$_zgetrf( m, n, a, lda, ipiv, info ) !! ZGETRF computes an LU factorization of a general M-by-N matrix A !! using partial pivoting with row interchanges. !! The factorization has the form @@ -54348,61 +54351,61 @@ module stdlib_linalg_lapack_z ! -- 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(*) complex(dp), intent(inout) :: a(lda,*) ! ===================================================================== ! Local Scalars - integer(ilp) :: i, iinfo, j, jb, nb + integer(${ik}$) :: i, 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}$, 'ZGETRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) + if( nb<=1_${ik}$ .or. nb>=min( m, n ) ) then ! use unblocked code. - call stdlib_zgetrf2( m, n, a, lda, ipiv, info ) + call stdlib${ii}$_zgetrf2( m, n, a, lda, ipiv, info ) else ! use blocked code. do j = 1, min( m, n ), nb jb = min( min( m, n )-j+1, nb ) ! factor diagonal and subdiagonal blocks and test for exact ! singularity. - call stdlib_zgetrf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo ) + call stdlib${ii}$_zgetrf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo ) ! adjust info and the pivot indices. - if( info==0 .and. iinfo>0 )info = iinfo + j - 1 + if( info==0_${ik}$ .and. iinfo>0_${ik}$ )info = iinfo + j - 1_${ik}$ do i = j, min( m, j+jb-1 ) - ipiv( i ) = j - 1 + ipiv( i ) + ipiv( i ) = j - 1_${ik}$ + ipiv( i ) end do ! apply interchanges to columns 1:j-1. - call stdlib_zlaswp( j-1, a, lda, j, j+jb-1, ipiv, 1 ) + call stdlib${ii}$_zlaswp( j-1, a, lda, j, j+jb-1, ipiv, 1_${ik}$ ) if( j+jb<=n ) then ! apply interchanges to columns j+jb:n. - call stdlib_zlaswp( n-j-jb+1, a( 1, j+jb ), lda, j, j+jb-1,ipiv, 1 ) + call stdlib${ii}$_zlaswp( n-j-jb+1, a( 1_${ik}$, j+jb ), lda, j, j+jb-1,ipiv, 1_${ik}$ ) ! compute block row of u. - call stdlib_ztrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, cone,& + call stdlib${ii}$_ztrsm( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', jb,n-j-jb+1, cone,& a( j, j ), lda, a( j, j+jb ),lda ) if( j+jb<=m ) then ! update trailing submatrix. - call stdlib_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', m-j-jb+1,n-j-jb+1, jb, -& cone, a( j+jb, j ), lda,a( j, j+jb ), lda, cone, a( j+jb, j+jb ),lda ) end if @@ -54410,10 +54413,10 @@ module stdlib_linalg_lapack_z end do end if return - end subroutine stdlib_zgetrf + end subroutine stdlib${ii}$_zgetrf - pure subroutine stdlib_zggglm( n, m, p, a, lda, b, ldb, d, x, y, work, lwork,info ) + pure subroutine stdlib${ii}$_zggglm( n, m, p, a, lda, b, ldb, d, x, y, work, lwork,info ) !! ZGGGLM solves a general Gauss-Markov linear model (GLM) problem: !! minimize || y ||_2 subject to d = A*x + B*y !! x @@ -54436,8 +54439,8 @@ module stdlib_linalg_lapack_z ! -- 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, ldb, lwork, m, n, p + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, p ! Array Arguments complex(dp), intent(inout) :: a(lda,*), b(ldb,*), d(*) complex(dp), intent(out) :: work(*), x(*), y(*) @@ -54445,52 +54448,52 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, lopt, lwkmin, lwkopt, nb, nb1, nb2, nb3, nb4, np + integer(${ik}$) :: i, lopt, lwkmin, lwkopt, nb, nb1, nb2, nb3, nb4, np ! Intrinsic Functions intrinsic :: int,max,min ! Executable Statements ! test the input parameters - info = 0 + info = 0_${ik}$ np = min( n, p ) - lquery = ( lwork==-1 ) - if( n<0 ) then - info = -1 - else if( m<0 .or. m>n ) then - info = -2 - else if( p<0 .or. pn ) then + info = -2_${ik}$ + else if( p<0_${ik}$ .or. pm ) then - call stdlib_ztrtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', n-m, 1,b( m+1, m+p-n+1 ), & + call stdlib${ii}$_ztrtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', n-m, 1_${ik}$,b( m+1, m+p-n+1 ), & ldb, d( m+1 ), n-m, info ) - if( info>0 ) then - info = 1 + if( info>0_${ik}$ ) then + info = 1_${ik}$ return end if - call stdlib_zcopy( n-m, d( m+1 ), 1, y( m+p-n+1 ), 1 ) + call stdlib${ii}$_zcopy( n-m, d( m+1 ), 1_${ik}$, y( m+p-n+1 ), 1_${ik}$ ) end if ! set y1 = 0 do i = 1, m + p - n y( i ) = czero end do ! update d1 = d1 - t12*y2 - call stdlib_zgemv( 'NO TRANSPOSE', m, n-m, -cone, b( 1, m+p-n+1 ), ldb,y( m+p-n+1 ), 1,& - cone, d, 1 ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', m, n-m, -cone, b( 1_${ik}$, m+p-n+1 ), ldb,y( m+p-n+1 ), 1_${ik}$,& + cone, d, 1_${ik}$ ) ! solve triangular system: r11*x = d1 - if( m>0 ) then - call stdlib_ztrtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', m, 1, a, lda,d, m, info ) + if( m>0_${ik}$ ) then + call stdlib${ii}$_ztrtrs( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', m, 1_${ik}$, a, lda,d, m, info ) - if( info>0 ) then - info = 2 + if( info>0_${ik}$ ) then + info = 2_${ik}$ return end if ! copy d to x - call stdlib_zcopy( m, d, 1, x, 1 ) + call stdlib${ii}$_zcopy( m, d, 1_${ik}$, x, 1_${ik}$ ) end if ! backward transformation y = z**h *y - call stdlib_zunmrq( 'LEFT', 'CONJUGATE TRANSPOSE', p, 1, np,b( max( 1, n-p+1 ), 1 ), & - ldb, work( m+1 ), y,max( 1, p ), work( m+np+1 ), lwork-m-np, info ) - work( 1 ) = m + np + max( lopt, int( work( m+np+1 ),KIND=ilp) ) + call stdlib${ii}$_zunmrq( 'LEFT', 'CONJUGATE TRANSPOSE', p, 1_${ik}$, np,b( max( 1_${ik}$, n-p+1 ), 1_${ik}$ ), & + ldb, work( m+1 ), y,max( 1_${ik}$, p ), work( m+np+1 ), lwork-m-np, info ) + work( 1_${ik}$ ) = m + np + max( lopt, int( work( m+np+1 ),KIND=${ik}$) ) return - end subroutine stdlib_zggglm + end subroutine stdlib${ii}$_zggglm - pure subroutine stdlib_zgghd3( compq, compz, n, ilo, ihi, a, lda, b, ldb, q,ldq, z, ldz, & + pure subroutine stdlib${ii}$_zgghd3( compq, compz, n, ilo, ihi, a, lda, b, ldb, q,ldq, z, ldz, & !! ZGGHD3 reduces a pair of complex matrices (A,B) to generalized upper !! Hessenberg form using unitary transformations, where A is a !! general matrix and B is upper triangular. The form of the @@ -54581,8 +54584,8 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: compq, compz - integer(ilp), intent(in) :: ihi, ilo, lda, ldb, ldq, ldz, n, lwork - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ilo, lda, ldb, ldq, ldz, n, lwork + integer(${ik}$), intent(out) :: info ! Array Arguments complex(dp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) complex(dp), intent(out) :: work(*) @@ -54591,7 +54594,7 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: blk22, initq, initz, lquery, wantq, wantz character :: compq2, compz2 - integer(ilp) :: cola, i, ierr, j, j0, jcol, jj, jrow, k, kacc22, len, lwkopt, n2nb, nb,& + integer(${ik}$) :: cola, i, ierr, j, j0, jcol, jj, jrow, k, kacc22, len, lwkopt, n2nb, nb,& nblst, nbmin, nh, nnb, nx, ppw, ppwo, pw, top, topq real(dp) :: c complex(dp) :: c1, c2, ctemp, s, s1, s2, temp, temp1, temp2, temp3 @@ -54599,69 +54602,69 @@ module stdlib_linalg_lapack_z intrinsic :: real,cmplx,conjg,max ! Executable Statements ! decode and test the input parameters. - info = 0 - nb = stdlib_ilaenv( 1, 'ZGGHD3', ' ', n, ilo, ihi, -1 ) - lwkopt = max( 6*n*nb, 1 ) - work( 1 ) = cmplx( lwkopt,KIND=dp) + info = 0_${ik}$ + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGGHD3', ' ', n, ilo, ihi, -1_${ik}$ ) + lwkopt = max( 6_${ik}$*n*nb, 1_${ik}$ ) + work( 1_${ik}$ ) = cmplx( lwkopt,KIND=dp) initq = stdlib_lsame( compq, 'I' ) wantq = initq .or. stdlib_lsame( compq, 'V' ) initz = stdlib_lsame( compz, 'I' ) wantz = initz .or. stdlib_lsame( compz, 'V' ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) if( .not.stdlib_lsame( compq, 'N' ) .and. .not.wantq ) then - info = -1 + info = -1_${ik}$ else if( .not.stdlib_lsame( compz, 'N' ) .and. .not.wantz ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ilo<1 ) then - info = -4 + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ + else if( ilo<1_${ik}$ ) then + info = -4_${ik}$ else if( ihi>n .or. ihi1 )call stdlib_zlaset( 'LOWER', n-1, n-1, czero, czero, b(2, 1), ldb ) + if( n>1_${ik}$ )call stdlib${ii}$_zlaset( 'LOWER', n-1, n-1, czero, czero, b(2_${ik}$, 1_${ik}$), ldb ) ! quick return if possible - nh = ihi - ilo + 1 - if( nh<=1 ) then - work( 1 ) = cone + nh = ihi - ilo + 1_${ik}$ + if( nh<=1_${ik}$ ) then + work( 1_${ik}$ ) = cone return end if ! determine the blocksize. - nbmin = stdlib_ilaenv( 2, 'ZGGHD3', ' ', n, ilo, ihi, -1 ) - if( nb>1 .and. nb1_${ik}$ .and. nb=6*n*nbmin ) then - nb = lwork / ( 6*n ) + nbmin = max( 2_${ik}$, stdlib${ii}$_ilaenv( 2_${ik}$, 'ZGGHD3', ' ', n, ilo, ihi,-1_${ik}$ ) ) + if( lwork>=6_${ik}$*n*nbmin ) then + nb = lwork / ( 6_${ik}$*n ) else - nb = 1 + nb = 1_${ik}$ end if end if end if @@ -54671,8 +54674,8 @@ module stdlib_linalg_lapack_z jcol = ilo else ! use blocked code - kacc22 = stdlib_ilaenv( 16, 'ZGGHD3', ' ', n, ilo, ihi, -1 ) - blk22 = kacc22==2 + kacc22 = stdlib${ii}$_ilaenv( 16_${ik}$, 'ZGGHD3', ' ', n, ilo, ihi, -1_${ik}$ ) + blk22 = kacc22==2_${ik}$ do jcol = ilo, ihi-2, nb nnb = min( nb, ihi-jcol-1 ) ! initialize small unitary factors that will hold the @@ -54680,14 +54683,14 @@ module stdlib_linalg_lapack_z ! n2nb denotes the number of 2*nnb-by-2*nnb factors ! nblst denotes the (possibly smaller) order of the last ! factor. - n2nb = ( ihi-jcol-1 ) / nnb - 1 + n2nb = ( ihi-jcol-1 ) / nnb - 1_${ik}$ nblst = ihi - jcol - n2nb*nnb - call stdlib_zlaset( 'ALL', nblst, nblst, czero, cone, work, nblst ) - pw = nblst * nblst + 1 + call stdlib${ii}$_zlaset( 'ALL', nblst, nblst, czero, cone, work, nblst ) + pw = nblst * nblst + 1_${ik}$ do i = 1, n2nb - call stdlib_zlaset( 'ALL', 2*nnb, 2*nnb, czero, cone,work( pw ), 2*nnb ) + call stdlib${ii}$_zlaset( 'ALL', 2_${ik}$*nnb, 2_${ik}$*nnb, czero, cone,work( pw ), 2_${ik}$*nnb ) - pw = pw + 4*nnb*nnb + pw = pw + 4_${ik}$*nnb*nnb end do ! reduce columns jcol:jcol+nnb-1 of a to hessenberg form. do j = jcol, jcol+nnb-1 @@ -54695,14 +54698,14 @@ module stdlib_linalg_lapack_z ! column of a and b, respectively. do i = ihi, j+2, -1 temp = a( i-1, j ) - call stdlib_zlartg( temp, a( i, j ), c, s, a( i-1, j ) ) + call stdlib${ii}$_zlartg( temp, a( i, j ), c, s, a( i-1, j ) ) a( i, j ) = cmplx( c,KIND=dp) b( i, j ) = s end do ! accumulate givens rotations into workspace array. - ppw = ( nblst + 1 )*( nblst - 2 ) - j + jcol + 1 - len = 2 + j - jcol - jrow = j + n2nb*nnb + 2 + ppw = ( nblst + 1_${ik}$ )*( nblst - 2_${ik}$ ) - j + jcol + 1_${ik}$ + len = 2_${ik}$ + j - jcol + jrow = j + n2nb*nnb + 2_${ik}$ do i = ihi, jrow, -1 ctemp = a( i, j ) s = b( i, j ) @@ -54711,31 +54714,31 @@ module stdlib_linalg_lapack_z work( jj + nblst ) = ctemp*temp - s*work( jj ) work( jj ) = conjg( s )*temp + ctemp*work( jj ) end do - len = len + 1 - ppw = ppw - nblst - 1 + len = len + 1_${ik}$ + ppw = ppw - nblst - 1_${ik}$ end do - ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2*nnb + nnb + ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2_${ik}$*nnb + nnb j0 = jrow - nnb do jrow = j0, j+2, -nnb ppw = ppwo - len = 2 + j - jcol + len = 2_${ik}$ + j - jcol do i = jrow+nnb-1, jrow, -1 ctemp = a( i, j ) s = b( i, j ) do jj = ppw, ppw+len-1 - temp = work( jj + 2*nnb ) - work( jj + 2*nnb ) = ctemp*temp - s*work( jj ) + temp = work( jj + 2_${ik}$*nnb ) + work( jj + 2_${ik}$*nnb ) = ctemp*temp - s*work( jj ) work( jj ) = conjg( s )*temp + ctemp*work( jj ) end do - len = len + 1 - ppw = ppw - 2*nnb - 1 + len = len + 1_${ik}$ + ppw = ppw - 2_${ik}$*nnb - 1_${ik}$ end do - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do ! top denotes the number of top rows in a and b that will ! not be updated during the next steps. - if( jcol<=2 ) then - top = 0 + if( jcol<=2_${ik}$ ) then + top = 0_${ik}$ else top = jcol end if @@ -54753,16 +54756,16 @@ module stdlib_linalg_lapack_z ! annihilate b( jj+1, jj ). if( jj0 ) then + if( jj>0_${ik}$ ) then do i = jj, 1, -1 c = real( a( j+1+i, j ),KIND=dp) - call stdlib_zrot( ihi-top, a( top+1, j+i+1 ), 1,a( top+1, j+i ), 1, c,-& + call stdlib${ii}$_zrot( ihi-top, a( top+1, j+i+1 ), 1_${ik}$,a( top+1, j+i ), 1_${ik}$, c,-& conjg( b( j+1+i, j ) ) ) end do end if ! update (j+1)th column of a by transformations from left. - if ( j < jcol + nnb - 1 ) then - len = 1 + j - jcol + if ( j < jcol + nnb - 1_${ik}$ ) then + len = 1_${ik}$ + j - jcol ! multiply with the trailing accumulated unitary ! matrix, which takes the form ! [ u11 u12 ] @@ -54800,23 +54803,23 @@ module stdlib_linalg_lapack_z ! [ u21 u22 ] ! where u21 is a len-by-len matrix and u12 is lower ! triangular. - jrow = ihi - nblst + 1 - call stdlib_zgemv( 'CONJUGATE', nblst, len, cone, work,nblst, a( jrow, j+1 & - ), 1, czero,work( pw ), 1 ) + jrow = ihi - nblst + 1_${ik}$ + call stdlib${ii}$_zgemv( 'CONJUGATE', nblst, len, cone, work,nblst, a( jrow, j+1 & + ), 1_${ik}$, czero,work( pw ), 1_${ik}$ ) ppw = pw + len do i = jrow, jrow+nblst-len-1 work( ppw ) = a( i, j+1 ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do - call stdlib_ztrmv( 'LOWER', 'CONJUGATE', 'NON-UNIT',nblst-len, work( & - len*nblst + 1 ), nblst,work( pw+len ), 1 ) - call stdlib_zgemv( 'CONJUGATE', len, nblst-len, cone,work( (len+1)*nblst - & - len + 1 ), nblst,a( jrow+nblst-len, j+1 ), 1, cone,work( pw+len ), 1 ) + call stdlib${ii}$_ztrmv( 'LOWER', 'CONJUGATE', 'NON-UNIT',nblst-len, work( & + len*nblst + 1_${ik}$ ), nblst,work( pw+len ), 1_${ik}$ ) + call stdlib${ii}$_zgemv( 'CONJUGATE', len, nblst-len, cone,work( (len+1)*nblst - & + len + 1_${ik}$ ), nblst,a( jrow+nblst-len, j+1 ), 1_${ik}$, cone,work( pw+len ), 1_${ik}$ ) ppw = pw do i = jrow, jrow+nblst-1 a( i, j+1 ) = work( ppw ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do ! multiply with the other accumulated unitary ! matrices, which take the form @@ -54828,44 +54831,44 @@ module stdlib_linalg_lapack_z ! where i denotes the (nnb-len)-by-(nnb-len) identity ! matrix, u21 is a len-by-len upper triangular matrix ! and u12 is an nnb-by-nnb lower triangular matrix. - ppwo = 1 + nblst*nblst + ppwo = 1_${ik}$ + nblst*nblst j0 = jrow - nnb do jrow = j0, jcol+1, -nnb ppw = pw + len do i = jrow, jrow+nnb-1 work( ppw ) = a( i, j+1 ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do ppw = pw do i = jrow+nnb, jrow+nnb+len-1 work( ppw ) = a( i, j+1 ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do - call stdlib_ztrmv( 'UPPER', 'CONJUGATE', 'NON-UNIT', len,work( ppwo + & - nnb ), 2*nnb, work( pw ),1 ) - call stdlib_ztrmv( 'LOWER', 'CONJUGATE', 'NON-UNIT', nnb,work( ppwo + & - 2*len*nnb ),2*nnb, work( pw + len ), 1 ) - call stdlib_zgemv( 'CONJUGATE', nnb, len, cone,work( ppwo ), 2*nnb, a( & - jrow, j+1 ), 1,cone, work( pw ), 1 ) - call stdlib_zgemv( 'CONJUGATE', len, nnb, cone,work( ppwo + 2*len*nnb + & - nnb ), 2*nnb,a( jrow+nnb, j+1 ), 1, cone,work( pw+len ), 1 ) + call stdlib${ii}$_ztrmv( 'UPPER', 'CONJUGATE', 'NON-UNIT', len,work( ppwo + & + nnb ), 2_${ik}$*nnb, work( pw ),1_${ik}$ ) + call stdlib${ii}$_ztrmv( 'LOWER', 'CONJUGATE', 'NON-UNIT', nnb,work( ppwo + & + 2_${ik}$*len*nnb ),2_${ik}$*nnb, work( pw + len ), 1_${ik}$ ) + call stdlib${ii}$_zgemv( 'CONJUGATE', nnb, len, cone,work( ppwo ), 2_${ik}$*nnb, a( & + jrow, j+1 ), 1_${ik}$,cone, work( pw ), 1_${ik}$ ) + call stdlib${ii}$_zgemv( 'CONJUGATE', len, nnb, cone,work( ppwo + 2_${ik}$*len*nnb + & + nnb ), 2_${ik}$*nnb,a( jrow+nnb, j+1 ), 1_${ik}$, cone,work( pw+len ), 1_${ik}$ ) ppw = pw do i = jrow, jrow+len+nnb-1 a( i, j+1 ) = work( ppw ) - ppw = ppw + 1 + ppw = ppw + 1_${ik}$ end do - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end if end do ! apply accumulated unitary matrices to a. - cola = n - jcol - nnb + 1 - j = ihi - nblst + 1 - call stdlib_zgemm( 'CONJUGATE', 'NO TRANSPOSE', nblst,cola, nblst, cone, work, & + cola = n - jcol - nnb + 1_${ik}$ + j = ihi - nblst + 1_${ik}$ + call stdlib${ii}$_zgemm( 'CONJUGATE', 'NO TRANSPOSE', nblst,cola, nblst, cone, work, & nblst,a( j, jcol+nnb ), lda, czero, work( pw ),nblst ) - call stdlib_zlacpy( 'ALL', nblst, cola, work( pw ), nblst,a( j, jcol+nnb ), lda ) + call stdlib${ii}$_zlacpy( 'ALL', nblst, cola, work( pw ), nblst,a( j, jcol+nnb ), lda ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( blk22 ) then @@ -54875,70 +54878,70 @@ module stdlib_linalg_lapack_z ! [ u21 u22 ], ! where all blocks are nnb-by-nnb, u21 is upper ! triangular and u12 is lower triangular. - call stdlib_zunm22( 'LEFT', 'CONJUGATE', 2*nnb, cola, nnb,nnb, work( ppwo )& - , 2*nnb,a( j, jcol+nnb ), lda, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_zunm22( 'LEFT', 'CONJUGATE', 2_${ik}$*nnb, cola, nnb,nnb, work( ppwo )& + , 2_${ik}$*nnb,a( j, jcol+nnb ), lda, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_zgemm( 'CONJUGATE', 'NO TRANSPOSE', 2*nnb,cola, 2*nnb, cone, & - work( ppwo ), 2*nnb,a( j, jcol+nnb ), lda, czero, work( pw ),2*nnb ) + call stdlib${ii}$_zgemm( 'CONJUGATE', 'NO TRANSPOSE', 2_${ik}$*nnb,cola, 2_${ik}$*nnb, cone, & + work( ppwo ), 2_${ik}$*nnb,a( j, jcol+nnb ), lda, czero, work( pw ),2_${ik}$*nnb ) - call stdlib_zlacpy( 'ALL', 2*nnb, cola, work( pw ), 2*nnb,a( j, jcol+nnb ),& + call stdlib${ii}$_zlacpy( 'ALL', 2_${ik}$*nnb, cola, work( pw ), 2_${ik}$*nnb,a( j, jcol+nnb ),& lda ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do ! apply accumulated unitary matrices to q. if( wantq ) then - j = ihi - nblst + 1 + j = ihi - nblst + 1_${ik}$ if ( initq ) then - topq = max( 2, j - jcol + 1 ) - nh = ihi - topq + 1 + topq = max( 2_${ik}$, j - jcol + 1_${ik}$ ) + nh = ihi - topq + 1_${ik}$ else - topq = 1 + topq = 1_${ik}$ nh = n end if - call stdlib_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, cone, q( & + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, cone, q( & topq, j ), ldq,work, nblst, czero, work( pw ), nh ) - call stdlib_zlacpy( 'ALL', nh, nblst, work( pw ), nh,q( topq, j ), ldq ) + call stdlib${ii}$_zlacpy( 'ALL', nh, nblst, work( pw ), nh,q( topq, j ), ldq ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( initq ) then - topq = max( 2, j - jcol + 1 ) - nh = ihi - topq + 1 + topq = max( 2_${ik}$, j - jcol + 1_${ik}$ ) + nh = ihi - topq + 1_${ik}$ end if if ( blk22 ) then ! exploit the structure of u. - call stdlib_zunm22( 'RIGHT', 'NO TRANSPOSE', nh, 2*nnb,nnb, nnb, work( & - ppwo ), 2*nnb,q( topq, j ), ldq, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_zunm22( 'RIGHT', 'NO TRANSPOSE', nh, 2_${ik}$*nnb,nnb, nnb, work( & + ppwo ), 2_${ik}$*nnb,q( topq, j ), ldq, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2*nnb, 2*nnb, & - cone, q( topq, j ), ldq,work( ppwo ), 2*nnb, czero, work( pw ),nh ) + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2_${ik}$*nnb, 2_${ik}$*nnb, & + cone, q( topq, j ), ldq,work( ppwo ), 2_${ik}$*nnb, czero, work( pw ),nh ) - call stdlib_zlacpy( 'ALL', nh, 2*nnb, work( pw ), nh,q( topq, j ), ldq ) + call stdlib${ii}$_zlacpy( 'ALL', nh, 2_${ik}$*nnb, work( pw ), nh,q( topq, j ), ldq ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end if ! accumulate right givens rotations if required. - if ( wantz .or. top>0 ) then + if ( wantz .or. top>0_${ik}$ ) then ! initialize small unitary factors that will hold the ! accumulated givens rotations in workspace. - call stdlib_zlaset( 'ALL', nblst, nblst, czero, cone, work,nblst ) - pw = nblst * nblst + 1 + call stdlib${ii}$_zlaset( 'ALL', nblst, nblst, czero, cone, work,nblst ) + pw = nblst * nblst + 1_${ik}$ do i = 1, n2nb - call stdlib_zlaset( 'ALL', 2*nnb, 2*nnb, czero, cone,work( pw ), 2*nnb ) + call stdlib${ii}$_zlaset( 'ALL', 2_${ik}$*nnb, 2_${ik}$*nnb, czero, cone,work( pw ), 2_${ik}$*nnb ) - pw = pw + 4*nnb*nnb + pw = pw + 4_${ik}$*nnb*nnb end do ! accumulate givens rotations into workspace array. do j = jcol, jcol+nnb-1 - ppw = ( nblst + 1 )*( nblst - 2 ) - j + jcol + 1 - len = 2 + j - jcol - jrow = j + n2nb*nnb + 2 + ppw = ( nblst + 1_${ik}$ )*( nblst - 2_${ik}$ ) - j + jcol + 1_${ik}$ + len = 2_${ik}$ + j - jcol + jrow = j + n2nb*nnb + 2_${ik}$ do i = ihi, jrow, -1 ctemp = a( i, j ) a( i, j ) = czero @@ -54949,117 +54952,117 @@ module stdlib_linalg_lapack_z work( jj + nblst ) = ctemp*temp -conjg( s )*work( jj ) work( jj ) = s*temp + ctemp*work( jj ) end do - len = len + 1 - ppw = ppw - nblst - 1 + len = len + 1_${ik}$ + ppw = ppw - nblst - 1_${ik}$ end do - ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2*nnb + nnb + ppwo = nblst*nblst + ( nnb+j-jcol-1 )*2_${ik}$*nnb + nnb j0 = jrow - nnb do jrow = j0, j+2, -nnb ppw = ppwo - len = 2 + j - jcol + len = 2_${ik}$ + j - jcol do i = jrow+nnb-1, jrow, -1 ctemp = a( i, j ) a( i, j ) = czero s = b( i, j ) b( i, j ) = czero do jj = ppw, ppw+len-1 - temp = work( jj + 2*nnb ) - work( jj + 2*nnb ) = ctemp*temp -conjg( s )*work( jj ) + temp = work( jj + 2_${ik}$*nnb ) + work( jj + 2_${ik}$*nnb ) = ctemp*temp -conjg( s )*work( jj ) work( jj ) = s*temp + ctemp*work( jj ) end do - len = len + 1 - ppw = ppw - 2*nnb - 1 + len = len + 1_${ik}$ + ppw = ppw - 2_${ik}$*nnb - 1_${ik}$ end do - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end do else - call stdlib_zlaset( 'LOWER', ihi - jcol - 1, nnb, czero, czero,a( jcol + 2, & + call stdlib${ii}$_zlaset( 'LOWER', ihi - jcol - 1_${ik}$, nnb, czero, czero,a( jcol + 2_${ik}$, & jcol ), lda ) - call stdlib_zlaset( 'LOWER', ihi - jcol - 1, nnb, czero, czero,b( jcol + 2, & + call stdlib${ii}$_zlaset( 'LOWER', ihi - jcol - 1_${ik}$, nnb, czero, czero,b( jcol + 2_${ik}$, & jcol ), ldb ) end if ! apply accumulated unitary matrices to a and b. - if ( top>0 ) then - j = ihi - nblst + 1 - call stdlib_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, cone, a( & - 1, j ), lda,work, nblst, czero, work( pw ), top ) - call stdlib_zlacpy( 'ALL', top, nblst, work( pw ), top,a( 1, j ), lda ) + if ( top>0_${ik}$ ) then + j = ihi - nblst + 1_${ik}$ + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, cone, a( & + 1_${ik}$, j ), lda,work, nblst, czero, work( pw ), top ) + call stdlib${ii}$_zlacpy( 'ALL', top, nblst, work( pw ), top,a( 1_${ik}$, j ), lda ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( blk22 ) then ! exploit the structure of u. - call stdlib_zunm22( 'RIGHT', 'NO TRANSPOSE', top, 2*nnb,nnb, nnb, work( & - ppwo ), 2*nnb,a( 1, j ), lda, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_zunm22( 'RIGHT', 'NO TRANSPOSE', top, 2_${ik}$*nnb,nnb, nnb, work( & + ppwo ), 2_${ik}$*nnb,a( 1_${ik}$, j ), lda, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2*nnb, 2*nnb, & - cone, a( 1, j ), lda,work( ppwo ), 2*nnb, czero,work( pw ), top ) + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2_${ik}$*nnb, 2_${ik}$*nnb, & + cone, a( 1_${ik}$, j ), lda,work( ppwo ), 2_${ik}$*nnb, czero,work( pw ), top ) - call stdlib_zlacpy( 'ALL', top, 2*nnb, work( pw ), top,a( 1, j ), lda ) + call stdlib${ii}$_zlacpy( 'ALL', top, 2_${ik}$*nnb, work( pw ), top,a( 1_${ik}$, j ), lda ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do - j = ihi - nblst + 1 - call stdlib_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, cone, b( & - 1, j ), ldb,work, nblst, czero, work( pw ), top ) - call stdlib_zlacpy( 'ALL', top, nblst, work( pw ), top,b( 1, j ), ldb ) + j = ihi - nblst + 1_${ik}$ + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,nblst, nblst, cone, b( & + 1_${ik}$, j ), ldb,work, nblst, czero, work( pw ), top ) + call stdlib${ii}$_zlacpy( 'ALL', top, nblst, work( pw ), top,b( 1_${ik}$, j ), ldb ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( blk22 ) then ! exploit the structure of u. - call stdlib_zunm22( 'RIGHT', 'NO TRANSPOSE', top, 2*nnb,nnb, nnb, work( & - ppwo ), 2*nnb,b( 1, j ), ldb, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_zunm22( 'RIGHT', 'NO TRANSPOSE', top, 2_${ik}$*nnb,nnb, nnb, work( & + ppwo ), 2_${ik}$*nnb,b( 1_${ik}$, j ), ldb, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2*nnb, 2*nnb, & - cone, b( 1, j ), ldb,work( ppwo ), 2*nnb, czero,work( pw ), top ) + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', top,2_${ik}$*nnb, 2_${ik}$*nnb, & + cone, b( 1_${ik}$, j ), ldb,work( ppwo ), 2_${ik}$*nnb, czero,work( pw ), top ) - call stdlib_zlacpy( 'ALL', top, 2*nnb, work( pw ), top,b( 1, j ), ldb ) + call stdlib${ii}$_zlacpy( 'ALL', top, 2_${ik}$*nnb, work( pw ), top,b( 1_${ik}$, j ), ldb ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end if ! apply accumulated unitary matrices to z. if( wantz ) then - j = ihi - nblst + 1 + j = ihi - nblst + 1_${ik}$ if ( initq ) then - topq = max( 2, j - jcol + 1 ) - nh = ihi - topq + 1 + topq = max( 2_${ik}$, j - jcol + 1_${ik}$ ) + nh = ihi - topq + 1_${ik}$ else - topq = 1 + topq = 1_${ik}$ nh = n end if - call stdlib_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, cone, z( & + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,nblst, nblst, cone, z( & topq, j ), ldz,work, nblst, czero, work( pw ), nh ) - call stdlib_zlacpy( 'ALL', nh, nblst, work( pw ), nh,z( topq, j ), ldz ) + call stdlib${ii}$_zlacpy( 'ALL', nh, nblst, work( pw ), nh,z( topq, j ), ldz ) - ppwo = nblst*nblst + 1 + ppwo = nblst*nblst + 1_${ik}$ j0 = j - nnb do j = j0, jcol+1, -nnb if ( initq ) then - topq = max( 2, j - jcol + 1 ) - nh = ihi - topq + 1 + topq = max( 2_${ik}$, j - jcol + 1_${ik}$ ) + nh = ihi - topq + 1_${ik}$ end if if ( blk22 ) then ! exploit the structure of u. - call stdlib_zunm22( 'RIGHT', 'NO TRANSPOSE', nh, 2*nnb,nnb, nnb, work( & - ppwo ), 2*nnb,z( topq, j ), ldz, work( pw ),lwork-pw+1, ierr ) + call stdlib${ii}$_zunm22( 'RIGHT', 'NO TRANSPOSE', nh, 2_${ik}$*nnb,nnb, nnb, work( & + ppwo ), 2_${ik}$*nnb,z( topq, j ), ldz, work( pw ),lwork-pw+1, ierr ) else ! ignore the structure of u. - call stdlib_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2*nnb, 2*nnb, & - cone, z( topq, j ), ldz,work( ppwo ), 2*nnb, czero, work( pw ),nh ) + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', nh,2_${ik}$*nnb, 2_${ik}$*nnb, & + cone, z( topq, j ), ldz,work( ppwo ), 2_${ik}$*nnb, czero, work( pw ),nh ) - call stdlib_zlacpy( 'ALL', nh, 2*nnb, work( pw ), nh,z( topq, j ), ldz ) + call stdlib${ii}$_zlacpy( 'ALL', nh, 2_${ik}$*nnb, work( pw ), nh,z( topq, j ), ldz ) end if - ppwo = ppwo + 4*nnb*nnb + ppwo = ppwo + 4_${ik}$*nnb*nnb end do end if end do @@ -55072,14 +55075,14 @@ module stdlib_linalg_lapack_z if ( wantq )compq2 = 'V' if ( wantz )compz2 = 'V' end if - if ( jcoln .or. pn .or. p0 ) then - call stdlib_ztrtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', p, 1,b( 1, n-p+1 ), ldb, d,& + if( p>0_${ik}$ ) then + call stdlib${ii}$_ztrtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', p, 1_${ik}$,b( 1_${ik}$, n-p+1 ), ldb, d,& p, info ) - if( info>0 ) then - info = 1 + if( info>0_${ik}$ ) then + info = 1_${ik}$ return end if ! put the solution in x - call stdlib_zcopy( p, d, 1, x( n-p+1 ), 1 ) + call stdlib${ii}$_zcopy( p, d, 1_${ik}$, x( n-p+1 ), 1_${ik}$ ) ! update c1 - call stdlib_zgemv( 'NO TRANSPOSE', n-p, p, -cone, a( 1, n-p+1 ), lda,d, 1, cone, c, & - 1 ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', n-p, p, -cone, a( 1_${ik}$, n-p+1 ), lda,d, 1_${ik}$, cone, c, & + 1_${ik}$ ) end if ! solve r11*x1 = c1 for x1 if( n>p ) then - call stdlib_ztrtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n-p, 1,a, lda, c, n-p, & + call stdlib${ii}$_ztrtrs( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', n-p, 1_${ik}$,a, lda, c, n-p, & info ) - if( info>0 ) then - info = 2 + if( info>0_${ik}$ ) then + info = 2_${ik}$ return end if ! put the solutions in x - call stdlib_zcopy( n-p, c, 1, x, 1 ) + call stdlib${ii}$_zcopy( n-p, c, 1_${ik}$, x, 1_${ik}$ ) end if ! compute the residual vector: if( m0 )call stdlib_zgemv( 'NO TRANSPOSE', nr, n-m, -cone, a( n-p+1, m+1 ),lda, d(& - nr+1 ), 1, cone, c( n-p+1 ), 1 ) + if( nr>0_${ik}$ )call stdlib${ii}$_zgemv( 'NO TRANSPOSE', nr, n-m, -cone, a( n-p+1, m+1 ),lda, d(& + nr+1 ), 1_${ik}$, cone, c( n-p+1 ), 1_${ik}$ ) else nr = p end if - if( nr>0 ) then - call stdlib_ztrmv( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', nr,a( n-p+1, n-p+1 ), lda, & - d, 1 ) - call stdlib_zaxpy( nr, -cone, d, 1, c( n-p+1 ), 1 ) + if( nr>0_${ik}$ ) then + call stdlib${ii}$_ztrmv( 'UPPER', 'NO TRANSPOSE', 'NON UNIT', nr,a( n-p+1, n-p+1 ), lda, & + d, 1_${ik}$ ) + call stdlib${ii}$_zaxpy( nr, -cone, d, 1_${ik}$, c( n-p+1 ), 1_${ik}$ ) end if ! backward transformation x = q**h*x - call stdlib_zunmrq( 'LEFT', 'CONJUGATE TRANSPOSE', n, 1, p, b, ldb,work( 1 ), x, n, & + call stdlib${ii}$_zunmrq( 'LEFT', 'CONJUGATE TRANSPOSE', n, 1_${ik}$, p, b, ldb,work( 1_${ik}$ ), x, n, & work( p+mn+1 ), lwork-p-mn, info ) - work( 1 ) = p + mn + max( lopt, int( work( p+mn+1 ),KIND=ilp) ) + work( 1_${ik}$ ) = p + mn + max( lopt, int( work( p+mn+1 ),KIND=${ik}$) ) return - end subroutine stdlib_zgglse + end subroutine stdlib${ii}$_zgglse - pure subroutine stdlib_zgtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond,work, info ) + pure subroutine stdlib${ii}$_zgtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond,work, info ) !! ZGTCON estimates the reciprocal of the condition number of a complex !! tridiagonal matrix A using the LU factorization as computed by !! ZGTTRF. @@ -55223,42 +55226,42 @@ module stdlib_linalg_lapack_z ! -- 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) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(dp), intent(in) :: anorm real(dp), intent(out) :: rcond ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) complex(dp), intent(in) :: d(*), dl(*), du(*), du2(*) complex(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: onenrm - integer(ilp) :: i, kase, kase1 + integer(${ik}$) :: i, kase, kase1 real(dp) :: ainvnm ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: cmplx ! Executable Statements ! test the input arguments. - info = 0 + info = 0_${ik}$ onenrm = norm=='1' .or. stdlib_lsame( norm, 'O' ) if( .not.onenrm .and. .not.stdlib_lsame( norm, 'I' ) ) then - info = -1 - else if( n<0 ) then - info = -2 + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ else if( anormeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_zgttrs( trans, n, 1, dlf, df, duf, du2, ipiv, work, n,info ) - call stdlib_zaxpy( n, cmplx( one,KIND=dp), work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_zgttrs( trans, n, 1_${ik}$, dlf, df, duf, du2, ipiv, work, n,info ) + call stdlib${ii}$_zaxpy( n, cmplx( one,KIND=dp), work, 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 @@ -55470,13 +55473,13 @@ module stdlib_linalg_lapack_z rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 70 continue - call stdlib_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(op(a)**h). - call stdlib_zgttrs( transt, n, 1, dlf, df, duf, du2, ipiv, work,n, info ) + call stdlib${ii}$_zgttrs( transt, n, 1_${ik}$, dlf, df, duf, du2, ipiv, work,n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) @@ -55486,7 +55489,7 @@ module stdlib_linalg_lapack_z do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_zgttrs( transn, n, 1, dlf, df, duf, du2, ipiv, work,n, info ) + call stdlib${ii}$_zgttrs( transn, n, 1_${ik}$, dlf, df, duf, du2, ipiv, work,n, info ) end if go to 70 @@ -55499,10 +55502,10 @@ module stdlib_linalg_lapack_z if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_110 return - end subroutine stdlib_zgtrfs + end subroutine stdlib${ii}$_zgtrfs - pure subroutine stdlib_zgtsvx( fact, trans, n, nrhs, dl, d, du, dlf, df, duf,du2, ipiv, b, & + pure subroutine stdlib${ii}$_zgtsvx( fact, trans, n, nrhs, dl, d, du, dlf, df, duf,du2, ipiv, b, & !! ZGTSVX uses the LU factorization to compute the solution to a complex !! system of linear equations A * X = B, A**T * X = B, or A**H * X = B, !! where A is a tridiagonal matrix of order N and X and B are N-by-NRHS @@ -55515,11 +55518,11 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: fact, trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs real(dp), intent(out) :: rcond ! Array Arguments - integer(ilp), intent(inout) :: ipiv(*) + integer(${ik}$), intent(inout) :: ipiv(*) real(dp), intent(out) :: berr(*), ferr(*), rwork(*) complex(dp), intent(in) :: b(ldb,*), d(*), dl(*), du(*) complex(dp), intent(inout) :: df(*), dlf(*), du2(*), duf(*) @@ -55533,37 +55536,37 @@ module stdlib_linalg_lapack_z ! Intrinsic Functions intrinsic :: max ! Executable Statements - info = 0 + info = 0_${ik}$ nofact = stdlib_lsame( fact, 'N' ) notran = stdlib_lsame( trans, 'N' ) if( .not.nofact .and. .not.stdlib_lsame( fact, 'F' ) ) 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 - else if( n<0 ) then - info = -3 - else if( nrhs<0 ) then - info = -4 - else if( ldb1 ) then - call stdlib_zcopy( n-1, dl, 1, dlf, 1 ) - call stdlib_zcopy( n-1, du, 1, duf, 1 ) + call stdlib${ii}$_zcopy( n, d, 1_${ik}$, df, 1_${ik}$ ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_zcopy( n-1, dl, 1_${ik}$, dlf, 1_${ik}$ ) + call stdlib${ii}$_zcopy( n-1, du, 1_${ik}$, duf, 1_${ik}$ ) end if - call stdlib_zgttrf( n, dlf, df, duf, du2, ipiv, info ) + call stdlib${ii}$_zgttrf( n, dlf, df, duf, du2, ipiv, info ) ! return if info is non-zero. - if( info>0 )then + if( info>0_${ik}$ )then rcond = zero return end if @@ -55574,23 +55577,23 @@ module stdlib_linalg_lapack_z else norm = 'I' end if - anorm = stdlib_zlangt( norm, n, dl, d, du ) + anorm = stdlib${ii}$_zlangt( norm, n, dl, d, du ) ! compute the reciprocal of the condition number of a. - call stdlib_zgtcon( norm, n, dlf, df, duf, du2, ipiv, anorm, rcond, work,info ) + call stdlib${ii}$_zgtcon( norm, n, dlf, df, duf, du2, ipiv, anorm, rcond, work,info ) ! compute the solution vectors x. - call stdlib_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_zgttrs( trans, n, nrhs, dlf, df, duf, du2, ipiv, x, ldx,info ) + call stdlib${ii}$_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_zgttrs( trans, n, nrhs, dlf, df, duf, du2, ipiv, x, ldx,info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_zgtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv,b, ldb, x, ldx, & + call stdlib${ii}$_zgtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv,b, ldb, x, ldx, & ferr, berr, work, rwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcondka ) 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_zgerc( n-m, kbt, -cone, x( m+1, i ), 1,bb( kb1-kbt, i )& - , 1, x( m+1, i-kbt ),ldx ) + call stdlib${ii}$_zdscal( n-m, one / bii, x( m+1, i ), 1_${ik}$ ) + if( kbt>0_${ik}$ )call stdlib${ii}$_zgerc( n-m, kbt, -cone, 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 ) @@ -55767,21 +55770,21 @@ module stdlib_linalg_lapack_z 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_zlartg( ab( k+1, i-k+ka ), ra1,rwork( i-k+ka-m ), work( i-k+ka-& + call stdlib${ii}$_zlartg( ab( k+1, i-k+ka ), ra1,rwork( i-k+ka-m ), work( i-k+ka-& m ), ra ) ! create nonzero element a(i-k,i-k+ka+1) outside the ! band and store it in work(i-k) t = -bb( kb1-k, i )*ra1 - work( i-k ) = rwork( i-k+ka-m )*t -conjg( work( i-k+ka-m ) )*ab( 1, i-k+ka & + work( i-k ) = rwork( i-k+ka-m )*t -conjg( work( i-k+ka-m ) )*ab( 1_${ik}$, i-k+ka & ) - ab( 1, i-k+ka ) = work( i-k+ka-m )*t +rwork( i-k+ka-m )*ab( 1, i-k+ka ) + ab( 1_${ik}$, i-k+ka ) = work( i-k+ka-m )*t +rwork( 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 @@ -55793,41 +55796,41 @@ module stdlib_linalg_lapack_z 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 ) = rwork( j-m )*ab( 1, j+1 ) + work( j-m ) = work( j-m )*ab( 1_${ik}$, j+1 ) + ab( 1_${ik}$, j+1 ) = rwork( j-m )*ab( 1_${ik}$, j+1 ) end do ! generate rotations in 1st set to annihilate elements which ! have been created outside the band - if( nrt>0 )call stdlib_zlargv( nrt, ab( 1, j2t ), inca, work( j2t-m ), ka1,rwork(& + if( nrt>0_${ik}$ )call stdlib${ii}$_zlargv( nrt, ab( 1_${ik}$, j2t ), inca, work( j2t-m ), ka1,rwork(& j2t-m ), ka1 ) - if( nr>0 ) then + if( nr>0_${ik}$ ) then ! apply rotations in 1st set from the right do l = 1, ka - 1 - call stdlib_zlartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, & + call stdlib${ii}$_zlartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, & rwork( j2-m ),work( j2-m ), ka1 ) end do ! apply rotations in 1st set from both sides to diagonal ! blocks - call stdlib_zlar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & + call stdlib${ii}$_zlar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & rwork( j2-m ),work( j2-m ), ka1 ) - call stdlib_zlacgv( nr, work( j2-m ), ka1 ) + call stdlib${ii}$_zlacgv( nr, work( j2-m ), ka1 ) end if ! start applying rotations in 1st set from the left do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_zlartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & + if( nrt>0_${ik}$ )call stdlib${ii}$_zlartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & ), inca, rwork( j2-m ),work( j2-m ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 1st set do j = j2, j1, ka1 - call stdlib_zrot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,rwork( j-m ), & + call stdlib${ii}$_zrot( n-m, x( m+1, j ), 1_${ik}$, x( m+1, j+1 ), 1_${ik}$,rwork( j-m ), & conjg( 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 @@ -55835,14 +55838,14 @@ module stdlib_linalg_lapack_z 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 do l = kb - k, 1, -1 nrt = ( n-j2+ka+l ) / ka1 - if( nrt>0 )call stdlib_zlartv( nrt, ab( l, j2-l+1 ), inca,ab( l+1, j2-l+1 ), & + if( nrt>0_${ik}$ )call stdlib${ii}$_zlartv( nrt, ab( l, j2-l+1 ), inca,ab( l+1, j2-l+1 ), & inca, rwork( j2-ka ),work( j2-ka ), ka1 ) end do nr = ( n-j2+ka ) / ka1 @@ -55854,57 +55857,57 @@ module stdlib_linalg_lapack_z 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 ) = rwork( j )*ab( 1, j+1 ) + work( j ) = work( j )*ab( 1_${ik}$, j+1 ) + ab( 1_${ik}$, j+1 ) = rwork( j )*ab( 1_${ik}$, j+1 ) end do if( update ) then if( i-k0 ) then + if( nr>0_${ik}$ ) then ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band - call stdlib_zlargv( nr, ab( 1, j2 ), inca, work( j2 ), ka1,rwork( j2 ), ka1 ) + call stdlib${ii}$_zlargv( nr, ab( 1_${ik}$, j2 ), inca, work( j2 ), ka1,rwork( j2 ), ka1 ) ! apply rotations in 2nd set from the right do l = 1, ka - 1 - call stdlib_zlartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, & + call stdlib${ii}$_zlartv( nr, ab( ka1-l, j2 ), inca,ab( ka-l, j2+1 ), inca, & rwork( j2 ),work( j2 ), ka1 ) end do ! apply rotations in 2nd set from both sides to diagonal ! blocks - call stdlib_zlar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & + call stdlib${ii}$_zlar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ),ab( ka, j2+1 ), inca, & rwork( j2 ),work( j2 ), ka1 ) - call stdlib_zlacgv( nr, work( j2 ), ka1 ) + call stdlib${ii}$_zlacgv( nr, work( j2 ), ka1 ) end if ! start applying rotations in 2nd set from the left do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_zlartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & + if( nrt>0_${ik}$ )call stdlib${ii}$_zlartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & ), inca, rwork( j2 ),work( j2 ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 2nd set do j = j2, j1, ka1 - call stdlib_zrot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,rwork( j ), conjg( & + call stdlib${ii}$_zrot( n-m, x( m+1, j ), 1_${ik}$, x( m+1, j+1 ), 1_${ik}$,rwork( j ), conjg( & 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 + j2 = i - k - 1_${ik}$ + max( 1_${ik}$, k-i0+2 )*ka1 ! finish applying rotations in 1st set from the left do l = kb - k, 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_zlartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & + if( nrt>0_${ik}$ )call stdlib${ii}$_zlartv( nrt, ab( l, j2+ka1-l ), inca,ab( l+1, j2+ka1-l & ), inca, rwork( j2-m ),work( j2-m ), ka1 ) end do end do - if( kb>1 ) then + if( kb>1_${ik}$ ) then do j = n - 1, j2 + ka, -1 rwork( j-m ) = rwork( j-ka-m ) work( j-m ) = work( j-ka-m ) @@ -55914,8 +55917,8 @@ module stdlib_linalg_lapack_z ! transform a, working with the lower triangle if( update ) then ! form inv(s(i))**h * a * inv(s(i)) - bii = real( bb( 1, i ),KIND=dp) - ab( 1, i ) = ( real( ab( 1, i ),KIND=dp) / bii ) / bii + bii = real( bb( 1_${ik}$, i ),KIND=dp) + ab( 1_${ik}$, i ) = ( real( ab( 1_${ik}$, i ),KIND=dp) / bii ) / bii do j = i + 1, i1 ab( j-i+1, i ) = ab( j-i+1, i ) / bii end do @@ -55925,8 +55928,8 @@ module stdlib_linalg_lapack_z do k = i - kbt, i - 1 do j = i - kbt, k ab( k-j+1, j ) = ab( k-j+1, j ) -bb( i-j+1, j )*conjg( ab( i-k+1,k ) ) - & - conjg( bb( i-k+1, k ) )*ab( i-j+1, j ) + real( ab( 1, i ),KIND=dp)*bb( i-j+& - 1, j )*conjg( bb( i-k+1,k ) ) + conjg( bb( i-k+1, k ) )*ab( i-j+1, j ) + real( ab( 1_${ik}$, i ),KIND=dp)*bb( i-j+& + 1_${ik}$, j )*conjg( 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 ) -conjg( bb( i-k+1, k ) )*ab( i-j+1, j ) @@ -55940,8 +55943,8 @@ module stdlib_linalg_lapack_z end do if( wantx ) then ! post-multiply x by inv(s(i)) - call stdlib_zdscal( n-m, one / bii, x( m+1, i ), 1 ) - if( kbt>0 )call stdlib_zgeru( n-m, kbt, -cone, x( m+1, i ), 1,bb( kbt+1, i-& + call stdlib${ii}$_zdscal( n-m, one / bii, x( m+1, i ), 1_${ik}$ ) + if( kbt>0_${ik}$ )call stdlib${ii}$_zgeru( n-m, kbt, -cone, 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 @@ -55954,9 +55957,9 @@ module stdlib_linalg_lapack_z 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_zlartg( ab( ka1-k, i ), ra1, rwork( i-k+ka-m ),work( i-k+ka-m )& + call stdlib${ii}$_zlartg( ab( ka1-k, i ), ra1, rwork( i-k+ka-m ),work( i-k+ka-m )& , ra ) ! create nonzero element a(i-k+ka+1,i-k) outside the ! band and store it in work(i-k) @@ -55968,7 +55971,7 @@ module stdlib_linalg_lapack_z 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 @@ -55985,36 +55988,36 @@ module stdlib_linalg_lapack_z end do ! generate rotations in 1st set to annihilate elements which ! have been created outside the band - if( nrt>0 )call stdlib_zlargv( nrt, ab( ka1, j2t-ka ), inca, work( j2t-m ),ka1, & + if( nrt>0_${ik}$ )call stdlib${ii}$_zlargv( nrt, ab( ka1, j2t-ka ), inca, work( j2t-m ),ka1, & rwork( j2t-m ), ka1 ) - if( nr>0 ) then + if( nr>0_${ik}$ ) then ! apply rotations in 1st set from the left do l = 1, ka - 1 - call stdlib_zlartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, rwork(& + call stdlib${ii}$_zlartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, rwork(& j2-m ),work( j2-m ), ka1 ) end do ! apply rotations in 1st set from both sides to diagonal ! blocks - call stdlib_zlar2v( nr, ab( 1, j2 ), ab( 1, j2+1 ), ab( 2, j2 ),inca, rwork( & + call stdlib${ii}$_zlar2v( nr, ab( 1_${ik}$, j2 ), ab( 1_${ik}$, j2+1 ), ab( 2_${ik}$, j2 ),inca, rwork( & j2-m ), work( j2-m ), ka1 ) - call stdlib_zlacgv( nr, work( j2-m ), ka1 ) + call stdlib${ii}$_zlacgv( nr, work( j2-m ), ka1 ) end if ! start applying rotations in 1st set from the right do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_zlartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& + if( nrt>0_${ik}$ )call stdlib${ii}$_zlartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& inca, rwork( j2-m ),work( j2-m ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 1st set do j = j2, j1, ka1 - call stdlib_zrot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,rwork( j-m ), work(& + call stdlib${ii}$_zrot( n-m, x( m+1, j ), 1_${ik}$, x( m+1, j+1 ), 1_${ik}$,rwork( 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 @@ -56022,14 +56025,14 @@ module stdlib_linalg_lapack_z 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 do l = kb - k, 1, -1 nrt = ( n-j2+ka+l ) / ka1 - if( nrt>0 )call stdlib_zlartv( nrt, ab( ka1-l+1, j2-ka ), inca,ab( ka1-l, j2-& + if( nrt>0_${ik}$ )call stdlib${ii}$_zlartv( nrt, ab( ka1-l+1, j2-ka ), inca,ab( ka1-l, j2-& ka+1 ), inca,rwork( j2-ka ), work( j2-ka ), ka1 ) end do nr = ( n-j2+ka ) / ka1 @@ -56049,49 +56052,49 @@ module stdlib_linalg_lapack_z 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 + if( nr>0_${ik}$ ) then ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band - call stdlib_zlargv( nr, ab( ka1, j2-ka ), inca, work( j2 ), ka1,rwork( j2 ), & + call stdlib${ii}$_zlargv( nr, ab( ka1, j2-ka ), inca, work( j2 ), ka1,rwork( j2 ), & ka1 ) ! apply rotations in 2nd set from the left do l = 1, ka - 1 - call stdlib_zlartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, rwork(& + call stdlib${ii}$_zlartv( nr, ab( l+1, j2-l ), inca,ab( l+2, j2-l ), inca, rwork(& j2 ),work( j2 ), ka1 ) end do ! apply rotations in 2nd set from both sides to diagonal ! blocks - call stdlib_zlar2v( nr, ab( 1, j2 ), ab( 1, j2+1 ), ab( 2, j2 ),inca, rwork( & + call stdlib${ii}$_zlar2v( nr, ab( 1_${ik}$, j2 ), ab( 1_${ik}$, j2+1 ), ab( 2_${ik}$, j2 ),inca, rwork( & j2 ), work( j2 ), ka1 ) - call stdlib_zlacgv( nr, work( j2 ), ka1 ) + call stdlib${ii}$_zlacgv( nr, work( j2 ), ka1 ) end if ! start applying rotations in 2nd set from the right do l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_zlartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& + if( nrt>0_${ik}$ )call stdlib${ii}$_zlartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& inca, rwork( j2 ),work( j2 ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 2nd set do j = j2, j1, ka1 - call stdlib_zrot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1,rwork( j ), work( & + call stdlib${ii}$_zrot( n-m, x( m+1, j ), 1_${ik}$, x( m+1, j+1 ), 1_${ik}$,rwork( 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 + j2 = i - k - 1_${ik}$ + max( 1_${ik}$, k-i0+2 )*ka1 ! finish applying rotations in 1st set from the right do l = kb - k, 1, -1 nrt = ( n-j2+l ) / ka1 - if( nrt>0 )call stdlib_zlartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& + if( nrt>0_${ik}$ )call stdlib${ii}$_zlartv( nrt, ab( ka1-l+1, j2 ), inca,ab( ka1-l, j2+1 ),& inca, rwork( j2-m ),work( j2-m ), ka1 ) end do end do - if( kb>1 ) then + if( kb>1_${ik}$ ) then do j = n - 1, j2 + ka, -1 rwork( j-m ) = rwork( j-ka-m ) work( j-m ) = work( j-ka-m ) @@ -56113,18 +56116,18 @@ module stdlib_linalg_lapack_z ! 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 @@ -56168,9 +56171,9 @@ module stdlib_linalg_lapack_z end do if( wantx ) then ! post-multiply x by inv(s(i)) - call stdlib_zdscal( nx, one / bii, x( 1, i ), 1 ) - if( kbt>0 )call stdlib_zgeru( nx, kbt, -cone, x( 1, i ), 1,bb( kb, i+1 ), & - ldbb-1, x( 1, i+1 ), ldx ) + call stdlib${ii}$_zdscal( nx, one / bii, x( 1_${ik}$, i ), 1_${ik}$ ) + if( kbt>0_${ik}$ )call stdlib${ii}$_zgeru( nx, kbt, -cone, x( 1_${ik}$, i ), 1_${ik}$,bb( kb, i+1 ), & + ldbb-1, 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 ) @@ -56181,20 +56184,20 @@ module stdlib_linalg_lapack_z 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_zlargv( nrt, ab( 1, j1+ka ), inca, work( j1 ), ka1,rwork( & + if( nrt>0_${ik}$ )call stdlib${ii}$_zlargv( nrt, ab( 1_${ik}$, j1+ka ), inca, work( j1 ), ka1,rwork( & j1 ), ka1 ) - if( nr>0 ) then + if( nr>0_${ik}$ ) then ! apply rotations in 1st set from the left do l = 1, ka - 1 - call stdlib_zlartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca, & + call stdlib${ii}$_zlartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca, & rwork( j1 ),work( j1 ), ka1 ) end do ! apply rotations in 1st set from both sides to diagonal ! blocks - call stdlib_zlar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & + call stdlib${ii}$_zlar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & rwork( j1 ), work( j1 ),ka1 ) - call stdlib_zlacgv( nr, work( j1 ), ka1 ) + call stdlib${ii}$_zlacgv( nr, work( j1 ), ka1 ) end if ! start applying rotations in 1st set from the right do l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_zlartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& + if( nrt>0_${ik}$ )call stdlib${ii}$_zlartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& rwork( j1t ),work( j1t ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 1st set do j = j1, j2, ka1 - call stdlib_zrot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,rwork( j ), work( j ) ) + call stdlib${ii}$_zrot( nx, x( 1_${ik}$, j ), 1_${ik}$, x( 1_${ik}$, j-1 ), 1_${ik}$,rwork( 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 @@ -56249,15 +56252,15 @@ module stdlib_linalg_lapack_z 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 do l = kb - k, 1, -1 nrt = ( j2+ka+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_zlartv( nrt, ab( l, j1t+ka ), inca,ab( l+1, j1t+ka-1 ),& + if( nrt>0_${ik}$ )call stdlib${ii}$_zlartv( nrt, ab( l, j1t+ka ), inca,ab( l+1, j1t+ka-1 ),& inca,rwork( m-kb+j1t+ka ),work( m-kb+j1t+ka ), ka1 ) end do nr = ( j2+ka-1 ) / ka1 @@ -56269,59 +56272,59 @@ module stdlib_linalg_lapack_z 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 ) = rwork( 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 ) = rwork( 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 + if( nr>0_${ik}$ ) then ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band - call stdlib_zlargv( nr, ab( 1, j1+ka ), inca, work( m-kb+j1 ),ka1, rwork( m-& + call stdlib${ii}$_zlargv( nr, ab( 1_${ik}$, j1+ka ), inca, work( m-kb+j1 ),ka1, rwork( m-& kb+j1 ), ka1 ) ! apply rotations in 2nd set from the left do l = 1, ka - 1 - call stdlib_zlartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca, & + call stdlib${ii}$_zlartv( nr, ab( ka1-l, j1+l ), inca,ab( ka-l, j1+l ), inca, & rwork( m-kb+j1 ),work( m-kb+j1 ), ka1 ) end do ! apply rotations in 2nd set from both sides to diagonal ! blocks - call stdlib_zlar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & + call stdlib${ii}$_zlar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ),ab( ka, j1 ), inca, & rwork( m-kb+j1 ),work( m-kb+j1 ), ka1 ) - call stdlib_zlacgv( nr, work( m-kb+j1 ), ka1 ) + call stdlib${ii}$_zlacgv( nr, work( m-kb+j1 ), ka1 ) end if ! start applying rotations in 2nd set from the right do l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_zlartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& + if( nrt>0_${ik}$ )call stdlib${ii}$_zlartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& rwork( m-kb+j1t ), work( m-kb+j1t ),ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 2nd set do j = j1, j2, ka1 - call stdlib_zrot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,rwork( m-kb+j ), work( & + call stdlib${ii}$_zrot( nx, x( 1_${ik}$, j ), 1_${ik}$, x( 1_${ik}$, j-1 ), 1_${ik}$,rwork( 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 + j2 = i + k + 1_${ik}$ - max( 1_${ik}$, k+i0-m+1 )*ka1 ! finish applying rotations in 1st 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_zlartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& + if( nrt>0_${ik}$ )call stdlib${ii}$_zlartv( nrt, ab( l, j1t ), inca,ab( l+1, j1t-1 ), inca,& rwork( j1t ),work( j1t ), ka1 ) end do end do - if( kb>1 ) then + if( kb>1_${ik}$ ) then do j = 2, i2 - ka rwork( j ) = rwork( j+ka ) work( j ) = work( j+ka ) @@ -56331,8 +56334,8 @@ module stdlib_linalg_lapack_z ! transform a, working with the lower triangle if( update ) then ! form inv(s(i))**h * a * inv(s(i)) - bii = real( bb( 1, i ),KIND=dp) - ab( 1, i ) = ( real( ab( 1, i ),KIND=dp) / bii ) / bii + bii = real( bb( 1_${ik}$, i ),KIND=dp) + ab( 1_${ik}$, i ) = ( real( ab( 1_${ik}$, i ),KIND=dp) / bii ) / bii do j = i1, i - 1 ab( i-j+1, j ) = ab( i-j+1, j ) / bii end do @@ -56342,8 +56345,8 @@ module stdlib_linalg_lapack_z do k = i + 1, i + kbt do j = k, i + kbt ab( j-k+1, k ) = ab( j-k+1, k ) -bb( j-i+1, i )*conjg( ab( k-i+1,i ) ) - & - conjg( bb( k-i+1, i ) )*ab( j-i+1, i ) + real( ab( 1, i ),KIND=dp)*bb( j-i+& - 1, i )*conjg( bb( k-i+1,i ) ) + conjg( bb( k-i+1, i ) )*ab( j-i+1, i ) + real( ab( 1_${ik}$, i ),KIND=dp)*bb( j-i+& + 1_${ik}$, i )*conjg( 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 ) -conjg( bb( k-i+1, i ) )*ab( j-i+1, i ) @@ -56357,9 +56360,9 @@ module stdlib_linalg_lapack_z end do if( wantx ) then ! post-multiply x by inv(s(i)) - call stdlib_zdscal( nx, one / bii, x( 1, i ), 1 ) - if( kbt>0 )call stdlib_zgerc( nx, kbt, -cone, x( 1, i ), 1, bb( 2, i ),1, x( & - 1, i+1 ), ldx ) + call stdlib${ii}$_zdscal( nx, one / bii, x( 1_${ik}$, i ), 1_${ik}$ ) + if( kbt>0_${ik}$ )call stdlib${ii}$_zgerc( nx, kbt, -cone, 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 ra1 = ab( i-i1+1, i1 ) @@ -56370,9 +56373,9 @@ module stdlib_linalg_lapack_z 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_zlargv( nrt, ab( ka1, j1 ), inca, work( j1 ), ka1,rwork( & + if( nrt>0_${ik}$ )call stdlib${ii}$_zlargv( nrt, ab( ka1, j1 ), inca, work( j1 ), ka1,rwork( & j1 ), ka1 ) - if( nr>0 ) then + if( nr>0_${ik}$ ) then ! apply rotations in 1st set from the right do l = 1, ka - 1 - call stdlib_zlartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, rwork( & + call stdlib${ii}$_zlartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, rwork( & j1 ), work( j1 ), ka1 ) end do ! apply rotations in 1st set from both sides to diagonal ! blocks - call stdlib_zlar2v( nr, ab( 1, j1 ), ab( 1, j1-1 ),ab( 2, j1-1 ), inca, rwork(& + call stdlib${ii}$_zlar2v( nr, ab( 1_${ik}$, j1 ), ab( 1_${ik}$, j1-1 ),ab( 2_${ik}$, j1-1 ), inca, rwork(& j1 ),work( j1 ), ka1 ) - call stdlib_zlacgv( nr, work( j1 ), ka1 ) + call stdlib${ii}$_zlacgv( nr, work( j1 ), ka1 ) end if ! start applying rotations in 1st set from the left do l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_zlartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & + if( nrt>0_${ik}$ )call stdlib${ii}$_zlartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & j1t-ka1+l ), inca,rwork( j1t ), work( j1t ), ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 1st set do j = j1, j2, ka1 - call stdlib_zrot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,rwork( j ), conjg( work(& + call stdlib${ii}$_zrot( nx, x( 1_${ik}$, j ), 1_${ik}$, x( 1_${ik}$, j-1 ), 1_${ik}$,rwork( j ), conjg( 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 @@ -56439,15 +56442,15 @@ module stdlib_linalg_lapack_z 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 do l = kb - k, 1, -1 nrt = ( j2+ka+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_zlartv( nrt, ab( ka1-l+1, j1t+l-1 ), inca,ab( ka1-l, & + if( nrt>0_${ik}$ )call stdlib${ii}$_zlartv( nrt, ab( ka1-l+1, j1t+l-1 ), inca,ab( ka1-l, & j1t+l-1 ), inca,rwork( m-kb+j1t+ka ),work( m-kb+j1t+ka ), ka1 ) end do nr = ( j2+ka-1 ) / ka1 @@ -56467,51 +56470,51 @@ module stdlib_linalg_lapack_z 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 + if( nr>0_${ik}$ ) then ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band - call stdlib_zlargv( nr, ab( ka1, j1 ), inca, work( m-kb+j1 ),ka1, rwork( m-kb+& + call stdlib${ii}$_zlargv( nr, ab( ka1, j1 ), inca, work( m-kb+j1 ),ka1, rwork( m-kb+& j1 ), ka1 ) ! apply rotations in 2nd set from the right do l = 1, ka - 1 - call stdlib_zlartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, rwork( & + call stdlib${ii}$_zlartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ),inca, rwork( & m-kb+j1 ), work( m-kb+j1 ),ka1 ) end do ! apply rotations in 2nd set from both sides to diagonal ! blocks - call stdlib_zlar2v( nr, ab( 1, j1 ), ab( 1, j1-1 ),ab( 2, j1-1 ), inca, rwork(& + call stdlib${ii}$_zlar2v( nr, ab( 1_${ik}$, j1 ), ab( 1_${ik}$, j1-1 ),ab( 2_${ik}$, j1-1 ), inca, rwork(& m-kb+j1 ),work( m-kb+j1 ), ka1 ) - call stdlib_zlacgv( nr, work( m-kb+j1 ), ka1 ) + call stdlib${ii}$_zlacgv( nr, work( m-kb+j1 ), ka1 ) end if ! start applying rotations in 2nd set from the left do l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 - if( nrt>0 )call stdlib_zlartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & + if( nrt>0_${ik}$ )call stdlib${ii}$_zlartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & j1t-ka1+l ), inca,rwork( m-kb+j1t ), work( m-kb+j1t ),ka1 ) end do if( wantx ) then ! post-multiply x by product of rotations in 2nd set do j = j1, j2, ka1 - call stdlib_zrot( nx, x( 1, j ), 1, x( 1, j-1 ), 1,rwork( m-kb+j ), conjg( & + call stdlib${ii}$_zrot( nx, x( 1_${ik}$, j ), 1_${ik}$, x( 1_${ik}$, j-1 ), 1_${ik}$,rwork( m-kb+j ), conjg( & 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 + j2 = i + k + 1_${ik}$ - max( 1_${ik}$, k+i0-m+1 )*ka1 ! finish applying rotations in 1st 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_zlartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & + if( nrt>0_${ik}$ )call stdlib${ii}$_zlartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca,ab( ka1-l, & j1t-ka1+l ), inca,rwork( j1t ), work( j1t ), ka1 ) end do end do - if( kb>1 ) then + if( kb>1_${ik}$ ) then do j = 2, i2 - ka rwork( j ) = rwork( j+ka ) work( j ) = work( j+ka ) @@ -56519,10 +56522,10 @@ module stdlib_linalg_lapack_z end if end if go to 490 - end subroutine stdlib_zhbgst + end subroutine stdlib${ii}$_zhbgst - pure subroutine stdlib_zhbtrd( vect, uplo, n, kd, ab, ldab, d, e, q, ldq,work, info ) + pure subroutine stdlib${ii}$_zhbtrd( vect, uplo, n, kd, ab, ldab, d, e, q, ldq,work, info ) !! ZHBTRD reduces a complex Hermitian band matrix A to real symmetric !! tridiagonal form T by a unitary similarity transformation: !! Q**H * A * Q = T. @@ -56531,8 +56534,8 @@ module stdlib_linalg_lapack_z ! -- 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(dp), intent(out) :: d(*), e(*) complex(dp), intent(inout) :: ab(ldab,*), q(ldq,*) @@ -56542,7 +56545,7 @@ module stdlib_linalg_lapack_z ! 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(dp) :: abst complex(dp) :: t, temp @@ -56553,32 +56556,32 @@ module stdlib_linalg_lapack_z 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 complex hermitian tridiagonal form, working with ! the upper triangle - nr = 0 - j1 = kdn + 2 - j2 = 1 - ab( kd1, 1 ) = real( ab( kd1, 1 ),KIND=dp) + nr = 0_${ik}$ + j1 = kdn + 2_${ik}$ + j2 = 1_${ik}$ + ab( kd1, 1_${ik}$ ) = real( ab( kd1, 1_${ik}$ ),KIND=dp) 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_zlargv( nr, ab( 1, j1-1 ), inca, work( j1 ),kd1, d( j1 ), & + call stdlib${ii}$_zlargv( 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_zlartv or stdlib_zrot is used - if( nr>=2*kd-1 ) then + ! stdlib${ii}$_zlartv or stdlib${ii}$_zrot is used + if( nr>=2_${ik}$*kd-1 ) then do l = 1, kd - 1 - call stdlib_zlartv( nr, ab( l+1, j1-1 ), inca,ab( l, j1 ), inca, & + call stdlib${ii}$_zlartv( 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_zrot( kdm1, ab( 2, jinc-1 ), 1,ab( 1, jinc ), 1, d( & + call stdlib${ii}$_zrot( 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_zlartg( 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}$_zlartg( 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_zrot( k-3, ab( kd-k+4, i+k-2 ), 1,ab( kd-k+3, i+k-1 ), 1,& + call stdlib${ii}$_zrot( 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_zlar2v( nr, ab( kd1, j1-1 ), ab( kd1, j1 ),ab( kd, & + if( nr>0_${ik}$ )call stdlib${ii}$_zlar2v( nr, ab( kd1, j1-1 ), ab( kd1, j1 ),ab( kd, & j1 ), inca, d( j1 ),work( j1 ), kd1 ) ! apply plane rotations from the left - if( nr>0 ) then - call stdlib_zlacgv( nr, work( j1 ), kd1 ) - if( 2*kd-10_${ik}$ ) then + call stdlib${ii}$_zlacgv( nr, work( j1 ), kd1 ) + if( 2_${ik}$*kd-1n ) then - nrt = nr - 1 + nrt = nr - 1_${ik}$ else nrt = nr end if - if( nrt>0 )call stdlib_zlartv( nrt, ab( kd-l, j1+l ), inca,ab( kd-& + if( nrt>0_${ik}$ )call stdlib${ii}$_zlartv( 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_zrot( kd-1, ab( kd-1, jin+1 ), incx,ab( kd, jin+1 )& + call stdlib${ii}$_zrot( 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_zrot( lend, ab( kd-1, last+1 ), incx,ab( kd, & + if( lend>0_${ik}$ )call stdlib${ii}$_zrot( lend, ab( kd-1, last+1 ), incx,ab( kd, & last+1 ), incx, d( last ),work( last ) ) end if end if @@ -56672,41 +56675,41 @@ module stdlib_linalg_lapack_z ! 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_zrot( nq, q( iqb, j-1 ), 1, q( iqb, j ),1, d( j ), & + call stdlib${ii}$_zrot( nq, q( iqb, j-1 ), 1_${ik}$, q( iqb, j ),1_${ik}$, d( j ), & conjg( work( j ) ) ) end do else do j = j1, j2, kd1 - call stdlib_zrot( n, q( 1, j-1 ), 1, q( 1, j ), 1,d( j ), conjg( & + call stdlib${ii}$_zrot( n, q( 1_${ik}$, j-1 ), 1_${ik}$, q( 1_${ik}$, j ), 1_${ik}$,d( j ), conjg( & 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 ! make off-diagonal elements real and copy them to e do i = 1, n - 1 t = ab( kd, i+1 ) @@ -56720,7 +56723,7 @@ module stdlib_linalg_lapack_z end if if( i1 ) then + if( kd>1_${ik}$ ) then ! reduce to complex hermitian tridiagonal form, working with ! the lower triangle - nr = 0 - j1 = kdn + 2 - j2 = 1 - ab( 1, 1 ) = real( ab( 1, 1 ),KIND=dp) + nr = 0_${ik}$ + j1 = kdn + 2_${ik}$ + j2 = 1_${ik}$ + ab( 1_${ik}$, 1_${ik}$ ) = real( ab( 1_${ik}$, 1_${ik}$ ),KIND=dp) 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_zlargv( nr, ab( kd1, j1-kd1 ), inca,work( j1 ), kd1, d( j1 )& + call stdlib${ii}$_zlargv( 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_zlartv or stdlib_zrot is used - if( nr>2*kd-1 ) then + ! stdlib${ii}$_zlartv or stdlib${ii}$_zrot is used + if( nr>2_${ik}$*kd-1 ) then do l = 1, kd - 1 - call stdlib_zlartv( nr, ab( kd1-l, j1-kd1+l ), inca,ab( kd1-l+1, & + call stdlib${ii}$_zlartv( 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_zrot( kdm1, ab( kd, jinc-kd ), incx,ab( kd1, jinc-kd )& + call stdlib${ii}$_zrot( 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_zlartg( ab( k-1, i ), ab( k, i ),d( i+k-1 ), work( i+k-1 & + call stdlib${ii}$_zlartg( 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_zrot( k-3, ab( k-2, i+1 ), ldab-1,ab( k-1, i+1 ), ldab-1,& + call stdlib${ii}$_zrot( 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_zlar2v( nr, ab( 1, j1-1 ), ab( 1, j1 ),ab( 2, j1-1 ),& + if( nr>0_${ik}$ )call stdlib${ii}$_zlar2v( 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_zlartv or stdlib_zrot is used - if( nr>0 ) then - call stdlib_zlacgv( nr, work( j1 ), kd1 ) - if( nr>2*kd-1 ) then + ! stdlib${ii}$_zlartv or stdlib${ii}$_zrot is used + if( nr>0_${ik}$ ) then + call stdlib${ii}$_zlacgv( nr, work( j1 ), kd1 ) + 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_zlartv( nrt, ab( l+2, j1-1 ), inca,ab( l+1,& + if( nrt>0_${ik}$ )call stdlib${ii}$_zlartv( 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_zrot( kdm1, ab( 3, j1inc-1 ), 1,ab( 2, j1inc ), 1, & + call stdlib${ii}$_zrot( 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_zrot( lend, ab( 3, last-1 ), 1,ab( 2, last ),& - 1, d( last ),work( last ) ) + if( lend>0_${ik}$ )call stdlib${ii}$_zrot( 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 @@ -56820,30 +56823,30 @@ module stdlib_linalg_lapack_z ! 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_zrot( nq, q( iqb, j-1 ), 1, q( iqb, j ),1, d( j ), & + call stdlib${ii}$_zrot( 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_zrot( n, q( 1, j-1 ), 1, q( 1, j ), 1,d( j ), work( j & + call stdlib${ii}$_zrot( 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 @@ -56854,21 +56857,21 @@ module stdlib_linalg_lapack_z end do loop_200 end do loop_210 end if - if( kd>0 ) then + if( kd>0_${ik}$ ) then ! make off-diagonal elements real and copy them to e do i = 1, n - 1 - t = ab( 2, i ) + t = ab( 2_${ik}$, i ) abst = abs( t ) - ab( 2, i ) = abst + ab( 2_${ik}$, i ) = abst e( i ) = abst if( abst/=zero ) then t = t / abst else t = cone end if - if( izero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 )call stdlib_zlascl( uplo, 0, 0, one, sigma, n, n, a, lda, info ) - ! call stdlib_zhetrd to reduce hermitian matrix to tridiagonal form. - inde = 1 - indtau = 1 + if( iscale==1_${ik}$ )call stdlib${ii}$_zlascl( uplo, 0_${ik}$, 0_${ik}$, one, sigma, n, n, a, lda, info ) + ! call stdlib${ii}$_zhetrd to reduce hermitian matrix to tridiagonal form. + inde = 1_${ik}$ + indtau = 1_${ik}$ indwrk = indtau + n - llwork = lwork - indwrk + 1 - call stdlib_zhetrd( uplo, n, a, lda, w, rwork( inde ), work( indtau ),work( indwrk ), & + llwork = lwork - indwrk + 1_${ik}$ + call stdlib${ii}$_zhetrd( uplo, n, a, lda, w, rwork( inde ), work( indtau ),work( indwrk ), & llwork, iinfo ) - ! for eigenvalues only, call stdlib_dsterf. for eigenvectors, first call - ! stdlib_zungtr to generate the unitary matrix, then call stdlib_zsteqr. + ! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvectors, first call + ! stdlib${ii}$_zungtr to generate the unitary matrix, then call stdlib${ii}$_zsteqr. if( .not.wantz ) then - call stdlib_dsterf( n, w, rwork( inde ), info ) + call stdlib${ii}$_dsterf( n, w, rwork( inde ), info ) else - call stdlib_zungtr( uplo, n, a, lda, work( indtau ), work( indwrk ),llwork, iinfo ) + call stdlib${ii}$_zungtr( uplo, n, a, lda, work( indtau ), work( indwrk ),llwork, iinfo ) indwrk = inde + n - call stdlib_zsteqr( jobz, n, w, rwork( inde ), a, lda,rwork( indwrk ), info ) + call stdlib${ii}$_zsteqr( jobz, n, w, rwork( inde ), a, lda,rwork( indwrk ), info ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = n else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_dscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ ) end if ! set work(1) to optimal complex workspace size. - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_zheev + end subroutine stdlib${ii}$_zheev - subroutine stdlib_zheevr( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, & + subroutine stdlib${ii}$_zheevr( jobz, range, uplo, n, a, lda, vl, vu, il, iu,abstol, m, w, z, ldz, & !! ZHEEVR computes selected eigenvalues and, optionally, eigenvectors !! of a complex Hermitian matrix A. Eigenvalues and eigenvectors can !! be selected by specifying either a range of values or a range of @@ -57216,11 +57219,11 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range, uplo - integer(ilp), intent(in) :: il, iu, lda, ldz, liwork, lrwork, lwork, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, iu, lda, ldz, liwork, lrwork, lwork, n + integer(${ik}$), intent(out) :: info, m real(dp), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: isuppz(*), iwork(*) + integer(${ik}$), intent(out) :: isuppz(*), iwork(*) real(dp), intent(out) :: rwork(*), w(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: work(*), z(ldz,*) @@ -57229,7 +57232,7 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: alleig, indeig, lower, lquery, test, valeig, wantz, tryrac character :: order - integer(ilp) :: i, ieeeok, iinfo, imax, indibl, indifl, indisp, indiwo, indrd, indrdd, & + integer(${ik}$) :: i, ieeeok, iinfo, imax, indibl, indifl, indisp, indiwo, indrd, indrdd, & indre, indree, indrwk, indtau, indwk, indwkn, iscale, itmp1, j, jj, liwmin, llwork, & llrwork, llwrkn, lrwmin, lwkopt, lwmin, nb, nsplit real(dp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, & @@ -57238,241 +57241,241 @@ module stdlib_linalg_lapack_z intrinsic :: real,max,min,sqrt ! Executable Statements ! test the input parameters. - ieeeok = stdlib_ilaenv( 10, 'ZHEEVR', 'N', 1, 2, 3, 4 ) + ieeeok = stdlib${ii}$_ilaenv( 10_${ik}$, 'ZHEEVR', 'N', 1_${ik}$, 2_${ik}$, 3_${ik}$, 4_${ik}$ ) lower = stdlib_lsame( uplo, 'L' ) wantz = stdlib_lsame( jobz, 'V' ) alleig = stdlib_lsame( range, 'A' ) valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) - lquery = ( ( lwork==-1 ) .or. ( lrwork==-1 ) .or.( liwork==-1 ) ) - lrwmin = max( 1, 24*n ) - liwmin = max( 1, 10*n ) - lwmin = max( 1, 2*n ) - info = 0 + lquery = ( ( lwork==-1_${ik}$ ) .or. ( lrwork==-1_${ik}$ ) .or.( liwork==-1_${ik}$ ) ) + lrwmin = max( 1_${ik}$, 24_${ik}$*n ) + liwmin = max( 1_${ik}$, 10_${ik}$*n ) + lwmin = max( 1_${ik}$, 2_${ik}$*n ) + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( lda0 .and. vu<=vl )info = -8 + if( n>0_${ik}$ .and. vu<=vl )info = -8_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -9 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -9_${ik}$ else if( iun ) then - info = -10 + info = -10_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz=real( a( 1, 1 ),KIND=dp) )then - m = 1 - w( 1 ) = real( a( 1, 1 ),KIND=dp) + if( vl=real( a( 1_${ik}$, 1_${ik}$ ),KIND=dp) )then + m = 1_${ik}$ + w( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=dp) end if end if if( wantz ) then - z( 1, 1 ) = one - isuppz( 1 ) = 1 - isuppz( 2 ) = 1 + z( 1_${ik}$, 1_${ik}$ ) = one + isuppz( 1_${ik}$ ) = 1_${ik}$ + isuppz( 2_${ik}$ ) = 1_${ik}$ end if return end if ! get machine constants. - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) - eps = stdlib_dlamch( 'PRECISION' ) + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_dlamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) ) ! scale matrix to allowable range, if necessary. - iscale = 0 + iscale = 0_${ik}$ abstll = abstol if (valeig) then vll = vl vuu = vu end if - anrm = stdlib_zlansy( 'M', uplo, n, a, lda, rwork ) + anrm = stdlib${ii}$_zlansy( 'M', uplo, n, a, lda, rwork ) if( anrm>zero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then do j = 1, n - call stdlib_zdscal( n-j+1, sigma, a( j, j ), 1 ) + call stdlib${ii}$_zdscal( n-j+1, sigma, a( j, j ), 1_${ik}$ ) end do else do j = 1, n - call stdlib_zdscal( j, sigma, a( 1, j ), 1 ) + call stdlib${ii}$_zdscal( j, sigma, a( 1_${ik}$, j ), 1_${ik}$ ) end do end if - if( abstol>0 )abstll = abstol*sigma + if( abstol>0_${ik}$ )abstll = abstol*sigma if( valeig ) then vll = vl*sigma vuu = vu*sigma end if end if ! initialize indices into workspaces. note: the iwork indices are - ! used only if stdlib_dsterf or stdlib_zstemr fail. + ! used only if stdlib${ii}$_dsterf or stdlib${ii}$_zstemr fail. ! work(indtau:indtau+n-1) stores the complex scalar factors of the - ! elementary reflectors used in stdlib_zhetrd. - indtau = 1 + ! elementary reflectors used in stdlib${ii}$_zhetrd. + indtau = 1_${ik}$ ! indwk is the starting offset of the remaining complex workspace, ! and llwork is the remaining complex workspace size. indwk = indtau + n - llwork = lwork - indwk + 1 + llwork = lwork - indwk + 1_${ik}$ ! rwork(indrd:indrd+n-1) stores the real tridiagonal's diagonal ! entries. - indrd = 1 + indrd = 1_${ik}$ ! rwork(indre:indre+n-1) stores the off-diagonal entries of the - ! tridiagonal matrix from stdlib_zhetrd. + ! tridiagonal matrix from stdlib${ii}$_zhetrd. indre = indrd + n ! rwork(indrdd:indrdd+n-1) is a copy of the diagonal entries over - ! -written by stdlib_zstemr (the stdlib_dsterf path copies the diagonal to w). + ! -written by stdlib${ii}$_zstemr (the stdlib${ii}$_dsterf path copies the diagonal to w). indrdd = indre + n ! rwork(indree:indree+n-1) is a copy of the off-diagonal entries over - ! -written while computing the eigenvalues in stdlib_dsterf and stdlib_zstemr. + ! -written while computing the eigenvalues in stdlib${ii}$_dsterf and stdlib${ii}$_zstemr. indree = indrdd + n ! indrwk is the starting offset of the left-over real workspace, and ! llrwork is the remaining workspace size. indrwk = indree + n - llrwork = lrwork - indrwk + 1 - ! iwork(indibl:indibl+m-1) corresponds to iblock in stdlib_dstebz and + llrwork = lrwork - indrwk + 1_${ik}$ + ! iwork(indibl:indibl+m-1) corresponds to iblock in stdlib${ii}$_dstebz and ! stores the block indices of each of the m<=n eigenvalues. - indibl = 1 - ! iwork(indisp:indisp+nsplit-1) corresponds to isplit in stdlib_dstebz and + indibl = 1_${ik}$ + ! iwork(indisp:indisp+nsplit-1) corresponds to isplit in stdlib${ii}$_dstebz and ! stores the starting and finishing indices of each block. indisp = indibl + n ! iwork(indifl:indifl+n-1) stores the indices of eigenvectors ! that corresponding to eigenvectors that fail to converge in - ! stdlib_dstein. this information is discarded; if any fail, the driver + ! stdlib${ii}$_dstein. this information is discarded; if any fail, the driver ! returns info > 0. indifl = indisp + n ! indiwo is the offset of the remaining integer workspace. indiwo = indifl + n - ! call stdlib_zhetrd to reduce hermitian matrix to tridiagonal form. - call stdlib_zhetrd( uplo, n, a, lda, rwork( indrd ), rwork( indre ),work( indtau ), & + ! call stdlib${ii}$_zhetrd to reduce hermitian matrix to tridiagonal form. + call stdlib${ii}$_zhetrd( uplo, n, a, lda, rwork( indrd ), rwork( indre ),work( indtau ), & work( indwk ), llwork, iinfo ) ! if all eigenvalues are desired - ! then call stdlib_dsterf or stdlib_zstemr and stdlib_zunmtr. + ! then call stdlib${ii}$_dsterf or stdlib${ii}$_zstemr and stdlib${ii}$_zunmtr. test = .false. if( indeig ) then - if( il==1 .and. iu==n ) then + if( il==1_${ik}$ .and. iu==n ) then test = .true. end if end if - if( ( alleig.or.test ) .and. ( ieeeok==1 ) ) then + if( ( alleig.or.test ) .and. ( ieeeok==1_${ik}$ ) ) then if( .not.wantz ) then - call stdlib_dcopy( n, rwork( indrd ), 1, w, 1 ) - call stdlib_dcopy( n-1, rwork( indre ), 1, rwork( indree ), 1 ) - call stdlib_dsterf( n, w, rwork( indree ), info ) + call stdlib${ii}$_dcopy( n, rwork( indrd ), 1_${ik}$, w, 1_${ik}$ ) + call stdlib${ii}$_dcopy( n-1, rwork( indre ), 1_${ik}$, rwork( indree ), 1_${ik}$ ) + call stdlib${ii}$_dsterf( n, w, rwork( indree ), info ) else - call stdlib_dcopy( n-1, rwork( indre ), 1, rwork( indree ), 1 ) - call stdlib_dcopy( n, rwork( indrd ), 1, rwork( indrdd ), 1 ) + call stdlib${ii}$_dcopy( n-1, rwork( indre ), 1_${ik}$, rwork( indree ), 1_${ik}$ ) + call stdlib${ii}$_dcopy( n, rwork( indrd ), 1_${ik}$, rwork( indrdd ), 1_${ik}$ ) if (abstol <= two*n*eps) then tryrac = .true. else tryrac = .false. end if - call stdlib_zstemr( jobz, 'A', n, rwork( indrdd ),rwork( indree ), vl, vu, il, & + call stdlib${ii}$_zstemr( jobz, 'A', n, rwork( indrdd ),rwork( indree ), vl, vu, il, & iu, m, w,z, ldz, n, isuppz, tryrac,rwork( indrwk ), llrwork,iwork, liwork, info ) ! apply unitary matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_zstemr. - if( wantz .and. info==0 ) then + ! form to eigenvectors returned by stdlib${ii}$_zstemr. + if( wantz .and. info==0_${ik}$ ) then indwkn = indwk - llwrkn = lwork - indwkn + 1 - call stdlib_zunmtr( 'L', uplo, 'N', n, m, a, lda,work( indtau ), z, ldz, work(& + llwrkn = lwork - indwkn + 1_${ik}$ + call stdlib${ii}$_zunmtr( 'L', uplo, 'N', n, m, a, lda,work( indtau ), z, ldz, work(& indwkn ),llwrkn, iinfo ) end if end if - if( info==0 ) then + if( info==0_${ik}$ ) then m = n go to 30 end if - info = 0 + info = 0_${ik}$ end if - ! otherwise, call stdlib_dstebz and, if eigenvectors are desired, stdlib_zstein. - ! also call stdlib_dstebz and stdlib_zstein if stdlib_zstemr fails. + ! otherwise, call stdlib${ii}$_dstebz and, if eigenvectors are desired, stdlib${ii}$_zstein. + ! also call stdlib${ii}$_dstebz and stdlib${ii}$_zstein if stdlib${ii}$_zstemr fails. if( wantz ) then order = 'B' else order = 'E' end if - call stdlib_dstebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indrd ), rwork( & + call stdlib${ii}$_dstebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indrd ), rwork( & indre ), m, nsplit, w,iwork( indibl ), iwork( indisp ), rwork( indrwk ),iwork( indiwo )& , info ) if( wantz ) then - call stdlib_zstein( n, rwork( indrd ), rwork( indre ), m, w,iwork( indibl ), iwork( & + call stdlib${ii}$_zstein( n, rwork( indrd ), rwork( indre ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,rwork( indrwk ), iwork( indiwo ), iwork( indifl ),info ) ! apply unitary matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_zstein. + ! form to eigenvectors returned by stdlib${ii}$_zstein. indwkn = indwk - llwrkn = lwork - indwkn + 1 - call stdlib_zunmtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & + llwrkn = lwork - indwkn + 1_${ik}$ + call stdlib${ii}$_zunmtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & indwkn ), llwrkn, iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. 30 continue - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = m else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_dscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. if( wantz ) then do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp1 = w( j ) do jj = j + 1, m if( w( jj )0 .and. vu<=vl )info = -8 + if( n>0_${ik}$ .and. vu<=vl )info = -8_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -9 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -9_${ik}$ else if( iun ) then - info = -10 + info = -10_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz=real( a( 1, 1 ),KIND=dp) )then - m = 1 - w( 1 ) = real( a( 1, 1 ),KIND=dp) + if( vl=real( a( 1_${ik}$, 1_${ik}$ ),KIND=dp) )then + m = 1_${ik}$ + w( 1_${ik}$ ) = real( a( 1_${ik}$, 1_${ik}$ ),KIND=dp) end if end if - if( wantz )z( 1, 1 ) = cone + if( wantz )z( 1_${ik}$, 1_${ik}$ ) = cone return end if ! get machine constants. - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) - eps = stdlib_dlamch( 'PRECISION' ) + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_dlamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) ) ! scale matrix to allowable range, if necessary. - iscale = 0 + iscale = 0_${ik}$ abstll = abstol if( valeig ) then vll = vl vuu = vu end if - anrm = stdlib_zlanhe( 'M', uplo, n, a, lda, rwork ) + anrm = stdlib${ii}$_zlanhe( 'M', uplo, n, a, lda, rwork ) if( anrm>zero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then do j = 1, n - call stdlib_zdscal( n-j+1, sigma, a( j, j ), 1 ) + call stdlib${ii}$_zdscal( n-j+1, sigma, a( j, j ), 1_${ik}$ ) end do else do j = 1, n - call stdlib_zdscal( j, sigma, a( 1, j ), 1 ) + call stdlib${ii}$_zdscal( j, sigma, a( 1_${ik}$, j ), 1_${ik}$ ) end do end if - if( abstol>0 )abstll = abstol*sigma + if( abstol>0_${ik}$ )abstll = abstol*sigma if( valeig ) then vll = vl*sigma vuu = vu*sigma end if end if - ! call stdlib_zhetrd to reduce hermitian matrix to tridiagonal form. - indd = 1 + ! call stdlib${ii}$_zhetrd to reduce hermitian matrix to tridiagonal form. + indd = 1_${ik}$ inde = indd + n indrwk = inde + n - indtau = 1 + indtau = 1_${ik}$ indwrk = indtau + n - llwork = lwork - indwrk + 1 - call stdlib_zhetrd( uplo, n, a, lda, rwork( indd ), rwork( inde ),work( indtau ), work(& + llwork = lwork - indwrk + 1_${ik}$ + call stdlib${ii}$_zhetrd( uplo, n, a, lda, rwork( indd ), rwork( inde ),work( indtau ), work(& indwrk ), llwork, iinfo ) ! if all eigenvalues are desired and abstol is less than or equal to - ! zero, then call stdlib_dsterf or stdlib_zungtr and stdlib_zsteqr. if this fails for - ! some eigenvalue, then try stdlib_dstebz. + ! zero, then call stdlib${ii}$_dsterf or stdlib${ii}$_zungtr and stdlib${ii}$_zsteqr. if this fails for + ! some eigenvalue, then try stdlib${ii}$_dstebz. test = .false. if( indeig ) then - if( il==1 .and. iu==n ) then + if( il==1_${ik}$ .and. iu==n ) then test = .true. end if end if if( ( alleig .or. test ) .and. ( abstol<=zero ) ) then - call stdlib_dcopy( n, rwork( indd ), 1, w, 1 ) - indee = indrwk + 2*n + call stdlib${ii}$_dcopy( n, rwork( indd ), 1_${ik}$, w, 1_${ik}$ ) + indee = indrwk + 2_${ik}$*n if( .not.wantz ) then - call stdlib_dcopy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) - call stdlib_dsterf( n, w, rwork( indee ), info ) + call stdlib${ii}$_dcopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ ) + call stdlib${ii}$_dsterf( n, w, rwork( indee ), info ) else - call stdlib_zlacpy( 'A', n, n, a, lda, z, ldz ) - call stdlib_zungtr( uplo, n, z, ldz, work( indtau ),work( indwrk ), llwork, & + call stdlib${ii}$_zlacpy( 'A', n, n, a, lda, z, ldz ) + call stdlib${ii}$_zungtr( uplo, n, z, ldz, work( indtau ),work( indwrk ), llwork, & iinfo ) - call stdlib_dcopy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) - call stdlib_zsteqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) + call stdlib${ii}$_dcopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ ) + call stdlib${ii}$_zsteqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) - if( info==0 ) then + if( info==0_${ik}$ ) then do i = 1, n - ifail( i ) = 0 + ifail( i ) = 0_${ik}$ end do end if end if - if( info==0 ) then + if( info==0_${ik}$ ) then m = n go to 40 end if - info = 0 + info = 0_${ik}$ end if - ! otherwise, call stdlib_dstebz and, if eigenvectors are desired, stdlib_zstein. + ! otherwise, call stdlib${ii}$_dstebz and, if eigenvectors are desired, stdlib${ii}$_zstein. if( wantz ) then order = 'B' else order = 'E' end if - indibl = 1 + indibl = 1_${ik}$ indisp = indibl + n indiwk = indisp + n - call stdlib_dstebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indd ), rwork( & + call stdlib${ii}$_dstebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indd ), rwork( & inde ), m, nsplit, w,iwork( indibl ), iwork( indisp ), rwork( indrwk ),iwork( indiwk ),& info ) if( wantz ) then - call stdlib_zstein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & + call stdlib${ii}$_zstein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,rwork( indrwk ), iwork( indiwk ), ifail, info ) ! apply unitary matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_zstein. - call stdlib_zunmtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & + ! form to eigenvectors returned by stdlib${ii}$_zstein. + call stdlib${ii}$_zunmtr( 'L', uplo, 'N', n, m, a, lda, work( indtau ), z,ldz, work( & indwrk ), llwork, iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. 40 continue - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = m else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_dscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. if( wantz ) then do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp1 = w( j ) do jj = j + 1, m if( w( jj )3 ) then - info = -1 + lquery = ( lwork==-1_${ik}$ ) + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( lda0 )neig = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )neig = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y if( upper ) then @@ -57827,9 +57830,9 @@ module stdlib_linalg_lapack_z else trans = 'C' end if - call stdlib_ztrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, cone,b, ldb, a, lda & + call stdlib${ii}$_ztrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, cone,b, ldb, a, lda & ) - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**h *y if( upper ) then @@ -57837,16 +57840,16 @@ module stdlib_linalg_lapack_z else trans = 'N' end if - call stdlib_ztrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, cone,b, ldb, a, lda & + call stdlib${ii}$_ztrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, neig, cone,b, ldb, a, lda & ) end if end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_zhegv + end subroutine stdlib${ii}$_zhegv - subroutine stdlib_zhegvx( itype, jobz, range, uplo, n, a, lda, b, ldb,vl, vu, il, iu, abstol,& + subroutine stdlib${ii}$_zhegvx( itype, jobz, range, uplo, n, a, lda, b, ldb,vl, vu, il, iu, abstol,& !! ZHEGVX computes selected eigenvalues, and optionally, eigenvectors !! of a complex generalized Hermitian-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and @@ -57859,11 +57862,11 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range, uplo - integer(ilp), intent(in) :: il, itype, iu, lda, ldb, ldz, lwork, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, itype, iu, lda, ldb, ldz, lwork, n + integer(${ik}$), intent(out) :: info, m real(dp), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: ifail(*), iwork(*) + integer(${ik}$), intent(out) :: ifail(*), iwork(*) real(dp), intent(out) :: rwork(*), w(*) complex(dp), intent(inout) :: a(lda,*), b(ldb,*) complex(dp), intent(out) :: work(*), z(ldz,*) @@ -57872,7 +57875,7 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: alleig, indeig, lquery, upper, valeig, wantz character :: trans - integer(ilp) :: lwkopt, nb + integer(${ik}$) :: lwkopt, nb ! Intrinsic Functions intrinsic :: max,min ! Executable Statements @@ -57882,71 +57885,71 @@ module stdlib_linalg_lapack_z alleig = stdlib_lsame( range, 'A' ) valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) - lquery = ( lwork==-1 ) - info = 0 - if( itype<1 .or. itype>3 ) then - info = -1 + lquery = ( lwork==-1_${ik}$ ) + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -3 + info = -3_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( lda0 .and. vu<=vl )info = -11 + if( n>0_${ik}$ .and. vu<=vl )info = -11_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -12 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -12_${ik}$ else if( iun ) then - info = -13 + info = -13_${ik}$ end if end if end if - if (info==0) then - if (ldz<1 .or. (wantz .and. ldz0 )m = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )m = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y if( upper ) then @@ -57954,9 +57957,9 @@ module stdlib_linalg_lapack_z else trans = 'C' end if - call stdlib_ztrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, cone, b,ldb, z, ldz ) + call stdlib${ii}$_ztrsm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, cone, b,ldb, z, ldz ) - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**h *y if( upper ) then @@ -57964,17 +57967,17 @@ module stdlib_linalg_lapack_z else trans = 'N' end if - call stdlib_ztrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, cone, b,ldb, z, ldz ) + call stdlib${ii}$_ztrmm( 'LEFT', uplo, trans, 'NON-UNIT', n, m, cone, b,ldb, z, ldz ) end if end if ! set work(1) to optimal complex workspace size. - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_zhegvx + end subroutine stdlib${ii}$_zhegvx - pure subroutine stdlib_zherfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr, & + pure subroutine stdlib${ii}$_zherfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb,x, ldx, ferr, & !! ZHERFS improves the computed solution to a system of linear !! equations when the coefficient matrix is Hermitian indefinite, and !! provides error bounds and backward error estimates for the solution. @@ -57984,17 +57987,17 @@ module stdlib_linalg_lapack_z ! -- 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, ldaf, ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) real(dp), intent(out) :: berr(*), ferr(*), rwork(*) complex(dp), intent(in) :: a(lda,*), af(ldaf,*), b(ldb,*) complex(dp), intent(out) :: work(*) complex(dp), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: itmax = 5 + integer(${ik}$), parameter :: itmax = 5_${ik}$ @@ -58002,11 +58005,11 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: upper - integer(ilp) :: count, i, j, k, kase, nz + integer(${ik}$) :: count, i, j, k, kase, nz real(dp) :: eps, lstres, s, safe1, safe2, safmin, xk complex(dp) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,aimag,max ! Statement Functions @@ -58015,29 +58018,29 @@ module stdlib_linalg_lapack_z cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) ) ! 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( nrhs<0 ) then - info = -3 - else if( ldaeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_zhetrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) - call stdlib_zaxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_zhetrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info ) + call stdlib${ii}$_zaxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -58137,22 +58140,22 @@ module stdlib_linalg_lapack_z rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**h). - call stdlib_zhetrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) + call stdlib${ii}$_zhetrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do - else if( kase==2 ) then + else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_zhetrs( uplo, n, 1, af, ldaf, ipiv, work, n, info ) + call stdlib${ii}$_zhetrs( uplo, n, 1_${ik}$, af, ldaf, ipiv, work, n, info ) end if go to 100 end if @@ -58164,10 +58167,10 @@ module stdlib_linalg_lapack_z if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_zherfs + end subroutine stdlib${ii}$_zherfs - pure subroutine stdlib_zhesv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) + pure subroutine stdlib${ii}$_zhesv( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) !! ZHESV computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS @@ -58184,68 +58187,68 @@ module stdlib_linalg_lapack_z ! -- 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, lwork, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, lwork, n, nrhs ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(dp), intent(inout) :: a(lda,*), b(ldb,*) complex(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: lwkopt, nb + integer(${ik}$) :: lwkopt, nb ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) if( .not.stdlib_lsame( uplo, 'U' ) .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 + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_zlanhe( 'I', uplo, n, a, lda, rwork ) + anorm = stdlib${ii}$_zlanhe( 'I', uplo, n, a, lda, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_zhecon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, info ) + call stdlib${ii}$_zhecon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, info ) ! compute the solution vectors x. - call stdlib_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_zhetrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info ) + call stdlib${ii}$_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_zhetrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_zherfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & + call stdlib${ii}$_zherfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & work, rwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcondn .or. ihimaxit )go to 180 @@ -58712,7 +58715,7 @@ module stdlib_linalg_lapack_z go to 60 end if end if - if( abs( t( ilast, ilast ) )<=max( safmin, ulp*(abs( t( ilast - 1, ilast ) ) + abs( & + if( abs( t( ilast, ilast ) )<=max( safmin, ulp*(abs( t( ilast - 1_${ik}$, ilast ) ) + abs( & t( ilast-1, ilast-1 )) ) ) ) then t( ilast, ilast ) = czero go to 50 @@ -58732,8 +58735,8 @@ module stdlib_linalg_lapack_z end if end if ! test 2: for t(j,j)=0 - temp = abs ( t( j, j + 1 ) ) - if ( j > ilo )temp = temp + abs ( t( j - 1, j ) ) + temp = abs ( t( j, j + 1_${ik}$ ) ) + if ( j > ilo )temp = temp + abs ( t( j - 1_${ik}$, j ) ) if( abs( t( j, j ) )=ilast ) then go to 60 else - ifirst = jch + 1 + ifirst = jch + 1_${ik}$ go to 70 end if end if @@ -58776,24 +58779,24 @@ module stdlib_linalg_lapack_z ! then process as in the case t(ilast,ilast)=0 do jch = j, ilast - 1 ctemp = t( jch, jch+1 ) - call stdlib_zlartg( ctemp, t( jch+1, jch+1 ), c, s,t( jch, jch+1 ) ) + call stdlib${ii}$_zlartg( ctemp, t( jch+1, jch+1 ), c, s,t( jch, jch+1 ) ) t( jch+1, jch+1 ) = czero - if( jchzero ) then if( real( x / temp2,KIND=dp)*real( y,KIND=dp)+aimag( x / temp2 )*aimag( y )& safmin ) & + if( ( iiter / 20_${ik}$ )*20_${ik}$==iiter .and.bscale*abs1(t( ilast, ilast ))>safmin ) & then eshift = eshift + ( ascale*h( ilast,ilast ) )/( bscale*t( ilast, ilast ) ) @@ -58918,12 +58921,12 @@ module stdlib_linalg_lapack_z ! do an implicit-shift qz sweep. ! initial q ctemp2 = ascale*h( istart+1, istart ) - call stdlib_zlartg( ctemp, ctemp2, c, s, ctemp3 ) + call stdlib${ii}$_zlartg( ctemp, ctemp2, c, s, ctemp3 ) ! sweep loop_150: do j = istart, ilast - 1 if( j>istart ) then ctemp = h( j, j-1 ) - call stdlib_zlartg( ctemp, h( j+1, j-1 ), c, s, h( j, j-1 ) ) + call stdlib${ii}$_zlartg( ctemp, h( j+1, j-1 ), c, s, h( j, j-1 ) ) h( j+1, j-1 ) = czero end if do jc = j, ilastm @@ -58942,7 +58945,7 @@ module stdlib_linalg_lapack_z end do end if ctemp = t( j+1, j+1 ) - call stdlib_zlartg( ctemp, t( j+1, j ), c, s, t( j+1, j+1 ) ) + call stdlib${ii}$_zlartg( ctemp, t( j+1, j ), c, s, t( j+1, j+1 ) ) t( j+1, j ) = czero do jr = ifrstm, min( j+2, ilast ) ctemp = c*h( jr, j+1 ) + s*h( jr, j ) @@ -58977,12 +58980,12 @@ module stdlib_linalg_lapack_z signbc = conjg( t( j, j ) / absb ) t( j, j ) = absb if( ilschr ) then - call stdlib_zscal( j-1, signbc, t( 1, j ), 1 ) - call stdlib_zscal( j, signbc, h( 1, j ), 1 ) + call stdlib${ii}$_zscal( j-1, signbc, t( 1_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_zscal( j, signbc, h( 1_${ik}$, j ), 1_${ik}$ ) else - call stdlib_zscal( 1, signbc, h( j, j ), 1 ) + call stdlib${ii}$_zscal( 1_${ik}$, signbc, h( j, j ), 1_${ik}$ ) end if - if( ilz )call stdlib_zscal( n, signbc, z( 1, j ), 1 ) + if( ilz )call stdlib${ii}$_zscal( n, signbc, z( 1_${ik}$, j ), 1_${ik}$ ) else t( j, j ) = czero end if @@ -58990,15 +58993,15 @@ module stdlib_linalg_lapack_z beta( j ) = t( j, j ) end do ! normal termination - info = 0 + info = 0_${ik}$ ! exit (other than argument error) -- return optimal workspace size 210 continue - work( 1 ) = cmplx( n,KIND=dp) + work( 1_${ik}$ ) = cmplx( n,KIND=dp) return - end subroutine stdlib_zhgeqz + end subroutine stdlib${ii}$_zhgeqz - pure subroutine stdlib_zhpcon( uplo, n, ap, ipiv, anorm, rcond, work, info ) + pure subroutine stdlib${ii}$_zhpcon( uplo, n, ap, ipiv, anorm, rcond, work, info ) !! ZHPCON estimates the reciprocal of the condition number of a complex !! Hermitian packed matrix A using the factorization A = U*D*U**H or !! A = L*D*L**H computed by ZHPTRF. @@ -59009,40 +59012,40 @@ module stdlib_linalg_lapack_z ! -- 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) :: n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n real(dp), intent(in) :: anorm real(dp), intent(out) :: rcond ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) complex(dp), intent(in) :: ap(*) complex(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: upper - integer(ilp) :: i, ip, kase + integer(${ik}$) :: i, ip, kase real(dp) :: ainvnm ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! 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 + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -2_${ik}$ else if( anorm0 .and. ap( ip )==zero )return ip = ip - i end do else ! lower triangular storage: examine d from top to bottom. - ip = 1 + ip = 1_${ik}$ do i = 1, n if( ipiv( i )>0 .and. ap( ip )==zero )return - ip = ip + n - i + 1 + ip = ip + n - i + 1_${ik}$ end do end if ! estimate the 1-norm of the inverse. - kase = 0 + kase = 0_${ik}$ 30 continue - call stdlib_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) - if( kase/=0 ) then + call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ainvnm, kase, isave ) + if( kase/=0_${ik}$ ) then ! multiply by inv(l*d*l**h) or inv(u*d*u**h). - call stdlib_zhptrs( uplo, n, 1, ap, ipiv, work, n, info ) + call stdlib${ii}$_zhptrs( uplo, n, 1_${ik}$, ap, ipiv, work, n, info ) go to 30 end if ! compute the estimate of the reciprocal condition number. if( ainvnm/=zero )rcond = ( one / ainvnm ) / anorm return - end subroutine stdlib_zhpcon + end subroutine stdlib${ii}$_zhpcon - subroutine stdlib_zhpev( jobz, uplo, n, ap, w, z, ldz, work, rwork,info ) + subroutine stdlib${ii}$_zhpev( jobz, uplo, n, ap, w, z, ldz, work, rwork,info ) !! ZHPEV computes all the eigenvalues and, optionally, eigenvectors of a !! complex Hermitian matrix in packed storage. ! -- lapack driver routine -- @@ -59087,8 +59090,8 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldz, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldz, n ! Array Arguments real(dp), intent(out) :: rwork(*), w(*) complex(dp), intent(inout) :: ap(*) @@ -59097,86 +59100,86 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: wantz - integer(ilp) :: iinfo, imax, inde, indrwk, indtau, indwrk, iscale + integer(${ik}$) :: iinfo, imax, inde, indrwk, indtau, indwrk, iscale real(dp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! Intrinsic Functions intrinsic :: sqrt ! Executable Statements ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) - info = 0 + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( stdlib_lsame( uplo, 'L' ) .or. stdlib_lsame( uplo, 'U' ) ) )& then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldz<1 .or. ( wantz .and. ldzzero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then - call stdlib_zdscal( ( n*( n+1 ) ) / 2, sigma, ap, 1 ) + if( iscale==1_${ik}$ ) then + call stdlib${ii}$_zdscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ ) end if - ! call stdlib_zhptrd to reduce hermitian packed matrix to tridiagonal form. - inde = 1 - indtau = 1 - call stdlib_zhptrd( uplo, n, ap, w, rwork( inde ), work( indtau ),iinfo ) - ! for eigenvalues only, call stdlib_dsterf. for eigenvectors, first call - ! stdlib_zupgtr to generate the orthogonal matrix, then call stdlib_zsteqr. + ! call stdlib${ii}$_zhptrd to reduce hermitian packed matrix to tridiagonal form. + inde = 1_${ik}$ + indtau = 1_${ik}$ + call stdlib${ii}$_zhptrd( uplo, n, ap, w, rwork( inde ), work( indtau ),iinfo ) + ! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvectors, first call + ! stdlib${ii}$_zupgtr to generate the orthogonal matrix, then call stdlib${ii}$_zsteqr. if( .not.wantz ) then - call stdlib_dsterf( n, w, rwork( inde ), info ) + call stdlib${ii}$_dsterf( n, w, rwork( inde ), info ) else indwrk = indtau + n - call stdlib_zupgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo ) + call stdlib${ii}$_zupgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo ) indrwk = inde + n - call stdlib_zsteqr( jobz, n, w, rwork( inde ), z, ldz,rwork( indrwk ), info ) + call stdlib${ii}$_zsteqr( jobz, n, w, rwork( inde ), z, ldz,rwork( indrwk ), info ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = n else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_dscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ ) end if return - end subroutine stdlib_zhpev + end subroutine stdlib${ii}$_zhpev - subroutine stdlib_zhpevx( jobz, range, uplo, n, ap, vl, vu, il, iu,abstol, m, w, z, ldz, & + subroutine stdlib${ii}$_zhpevx( jobz, range, uplo, n, ap, vl, vu, il, iu,abstol, m, w, z, ldz, & !! ZHPEVX computes selected eigenvalues and, optionally, eigenvectors !! of a complex Hermitian matrix A in packed storage. !! Eigenvalues/vectors can be selected by specifying either a range of @@ -59187,11 +59190,11 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range, uplo - integer(ilp), intent(in) :: il, iu, ldz, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, iu, ldz, n + integer(${ik}$), intent(out) :: info, m real(dp), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: ifail(*), iwork(*) + integer(${ik}$), intent(out) :: ifail(*), iwork(*) real(dp), intent(out) :: rwork(*), w(*) complex(dp), intent(inout) :: ap(*) complex(dp), intent(out) :: work(*), z(ldz,*) @@ -59201,7 +59204,7 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: alleig, indeig, test, valeig, wantz character :: order - integer(ilp) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwk, indrwk, & + integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwk, indrwk, & indtau, indwrk, iscale, itmp1, j, jj, nsplit real(dp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, & vuu @@ -59213,59 +59216,59 @@ module stdlib_linalg_lapack_z alleig = stdlib_lsame( range, 'A' ) valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) - info = 0 + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( stdlib_lsame( uplo, 'L' ) .or. stdlib_lsame( uplo, 'U' ) ) )& then - info = -3 - else if( n<0 ) then - info = -4 + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ else if( valeig ) then - if( n>0 .and. vu<=vl )info = -7 + if( n>0_${ik}$ .and. vu<=vl )info = -7_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -8 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -8_${ik}$ else if( iun ) then - info = -9 + info = -9_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz=real( ap( 1 ),KIND=dp) ) then - m = 1 - w( 1 ) = real( ap( 1 ),KIND=dp) + if( vl=real( ap( 1_${ik}$ ),KIND=dp) ) then + m = 1_${ik}$ + w( 1_${ik}$ ) = real( ap( 1_${ik}$ ),KIND=dp) end if end if - if( wantz )z( 1, 1 ) = cone + if( wantz )z( 1_${ik}$, 1_${ik}$ ) = cone return end if ! get machine constants. - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) - eps = stdlib_dlamch( 'PRECISION' ) + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_dlamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) ) ! scale matrix to allowable range, if necessary. - iscale = 0 + iscale = 0_${ik}$ abstll = abstol if( valeig ) then vll = vl @@ -59274,99 +59277,99 @@ module stdlib_linalg_lapack_z vll = zero vuu = zero end if - anrm = stdlib_zlanhp( 'M', uplo, n, ap, rwork ) + anrm = stdlib${ii}$_zlanhp( 'M', uplo, n, ap, rwork ) if( anrm>zero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then - call stdlib_zdscal( ( n*( n+1 ) ) / 2, sigma, ap, 1 ) - if( abstol>0 )abstll = abstol*sigma + if( iscale==1_${ik}$ ) then + call stdlib${ii}$_zdscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ ) + if( abstol>0_${ik}$ )abstll = abstol*sigma if( valeig ) then vll = vl*sigma vuu = vu*sigma end if end if - ! call stdlib_zhptrd to reduce hermitian packed matrix to tridiagonal form. - indd = 1 + ! call stdlib${ii}$_zhptrd to reduce hermitian packed matrix to tridiagonal form. + indd = 1_${ik}$ inde = indd + n indrwk = inde + n - indtau = 1 + indtau = 1_${ik}$ indwrk = indtau + n - call stdlib_zhptrd( uplo, n, ap, rwork( indd ), rwork( inde ),work( indtau ), iinfo ) + call stdlib${ii}$_zhptrd( uplo, n, ap, rwork( indd ), rwork( inde ),work( indtau ), iinfo ) ! if all eigenvalues are desired and abstol is less than or equal - ! to zero, then call stdlib_dsterf or stdlib_zupgtr and stdlib_zsteqr. if this fails - ! for some eigenvalue, then try stdlib_dstebz. + ! to zero, then call stdlib${ii}$_dsterf or stdlib${ii}$_zupgtr and stdlib${ii}$_zsteqr. if this fails + ! for some eigenvalue, then try stdlib${ii}$_dstebz. test = .false. if (indeig) then - if (il==1 .and. iu==n) then + if (il==1_${ik}$ .and. iu==n) then test = .true. end if end if if ((alleig .or. test) .and. (abstol<=zero)) then - call stdlib_dcopy( n, rwork( indd ), 1, w, 1 ) - indee = indrwk + 2*n + call stdlib${ii}$_dcopy( n, rwork( indd ), 1_${ik}$, w, 1_${ik}$ ) + indee = indrwk + 2_${ik}$*n if( .not.wantz ) then - call stdlib_dcopy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) - call stdlib_dsterf( n, w, rwork( indee ), info ) + call stdlib${ii}$_dcopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ ) + call stdlib${ii}$_dsterf( n, w, rwork( indee ), info ) else - call stdlib_zupgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo ) + call stdlib${ii}$_zupgtr( uplo, n, ap, work( indtau ), z, ldz,work( indwrk ), iinfo ) - call stdlib_dcopy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) - call stdlib_zsteqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) + call stdlib${ii}$_dcopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ ) + call stdlib${ii}$_zsteqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) - if( info==0 ) then + if( info==0_${ik}$ ) then do i = 1, n - ifail( i ) = 0 + ifail( i ) = 0_${ik}$ end do end if end if - if( info==0 ) then + if( info==0_${ik}$ ) then m = n go to 20 end if - info = 0 + info = 0_${ik}$ end if - ! otherwise, call stdlib_dstebz and, if eigenvectors are desired, stdlib_zstein. + ! otherwise, call stdlib${ii}$_dstebz and, if eigenvectors are desired, stdlib${ii}$_zstein. if( wantz ) then order = 'B' else order = 'E' end if - indibl = 1 + indibl = 1_${ik}$ indisp = indibl + n indiwk = indisp + n - call stdlib_dstebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indd ), rwork( & + call stdlib${ii}$_dstebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indd ), rwork( & inde ), m, nsplit, w,iwork( indibl ), iwork( indisp ), rwork( indrwk ),iwork( indiwk ),& info ) if( wantz ) then - call stdlib_zstein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & + call stdlib${ii}$_zstein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,rwork( indrwk ), iwork( indiwk ), ifail, info ) ! apply unitary matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_zstein. + ! form to eigenvectors returned by stdlib${ii}$_zstein. indwrk = indtau + n - call stdlib_zupmtr( 'L', uplo, 'N', n, m, ap, work( indtau ), z, ldz,work( indwrk ),& + call stdlib${ii}$_zupmtr( 'L', uplo, 'N', n, m, ap, work( indtau ), z, ldz,work( indwrk ),& iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. 20 continue - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = m else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_dscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. if( wantz ) then do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp1 = w( j ) do jj = j + 1, m if( w( jj )3 ) then - info = -1 + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( ldz<1 .or. ( wantz .and. ldz0 )neig = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )neig = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y if( upper ) then @@ -59459,9 +59462,9 @@ module stdlib_linalg_lapack_z trans = 'C' end if do j = 1, neig - call stdlib_ztpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_ztpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**h *y if( upper ) then @@ -59470,15 +59473,15 @@ module stdlib_linalg_lapack_z trans = 'N' end if do j = 1, neig - call stdlib_ztpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_ztpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do end if end if return - end subroutine stdlib_zhpgv + end subroutine stdlib${ii}$_zhpgv - subroutine stdlib_zhpgvx( itype, jobz, range, uplo, n, ap, bp, vl, vu,il, iu, abstol, m, w, & + subroutine stdlib${ii}$_zhpgvx( itype, jobz, range, uplo, n, ap, bp, vl, vu,il, iu, abstol, m, w, & !! ZHPGVX computes selected eigenvalues and, optionally, eigenvectors !! of a complex generalized Hermitian-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and @@ -59492,11 +59495,11 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range, uplo - integer(ilp), intent(in) :: il, itype, iu, ldz, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, itype, iu, ldz, n + integer(${ik}$), intent(out) :: info, m real(dp), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: ifail(*), iwork(*) + integer(${ik}$), intent(out) :: ifail(*), iwork(*) real(dp), intent(out) :: rwork(*), w(*) complex(dp), intent(inout) :: ap(*), bp(*) complex(dp), intent(out) :: work(*), z(ldz,*) @@ -59504,7 +59507,7 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: alleig, indeig, upper, valeig, wantz character :: trans - integer(ilp) :: j + integer(${ik}$) :: j ! Intrinsic Functions intrinsic :: min ! Executable Statements @@ -59514,55 +59517,55 @@ module stdlib_linalg_lapack_z alleig = stdlib_lsame( range, 'A' ) valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) - info = 0 - if( itype<1 .or. itype>3 ) then - info = -1 + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -3 + info = -3_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -4 - else if( n<0 ) then - info = -5 + info = -4_${ik}$ + else if( n<0_${ik}$ ) then + info = -5_${ik}$ else if( valeig ) then - if( n>0 .and. vu<=vl ) then - info = -9 + if( n>0_${ik}$ .and. vu<=vl ) then + info = -9_${ik}$ end if else if( indeig ) then - if( il<1 ) then - info = -10 + if( il<1_${ik}$ ) then + info = -10_${ik}$ else if( iun ) then - info = -11 + info = -11_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz0 )m = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )m = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y if( upper ) then @@ -59571,9 +59574,9 @@ module stdlib_linalg_lapack_z trans = 'C' end if do j = 1, m - call stdlib_ztpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_ztpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**h *y if( upper ) then @@ -59582,15 +59585,15 @@ module stdlib_linalg_lapack_z trans = 'N' end if do j = 1, m - call stdlib_ztpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_ztpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do end if end if return - end subroutine stdlib_zhpgvx + end subroutine stdlib${ii}$_zhpgvx - pure subroutine stdlib_zhprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,& + pure subroutine stdlib${ii}$_zhprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx,ferr, berr, work,& !! ZHPRFS improves the computed solution to a system of linear !! equations when the coefficient matrix is Hermitian indefinite !! and packed, and provides error bounds and backward error estimates @@ -59601,17 +59604,17 @@ module stdlib_linalg_lapack_z ! -- 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) :: ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, ldx, n, nrhs ! Array Arguments - integer(ilp), intent(in) :: ipiv(*) + integer(${ik}$), intent(in) :: ipiv(*) real(dp), intent(out) :: berr(*), ferr(*), rwork(*) complex(dp), intent(in) :: afp(*), ap(*), b(ldb,*) complex(dp), intent(out) :: work(*) complex(dp), intent(inout) :: x(ldx,*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: itmax = 5 + integer(${ik}$), parameter :: itmax = 5_${ik}$ @@ -59619,11 +59622,11 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: upper - integer(ilp) :: count, i, ik, j, k, kase, kk, nz + integer(${ik}$) :: count, i, ik, j, k, kase, kk, nz real(dp) :: eps, lstres, s, safe1, safe2, safmin, xk complex(dp) :: zdum ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,aimag,max ! Statement Functions @@ -59632,25 +59635,25 @@ module stdlib_linalg_lapack_z cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) ) ! 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( nrhs<0 ) then - info = -3 - else if( ldbeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_zhptrs( uplo, n, 1, afp, ipiv, work, n, info ) - call stdlib_zaxpy( n, cone, work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_zhptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info ) + call stdlib${ii}$_zaxpy( n, cone, work, 1_${ik}$, x( 1_${ik}$, j ), 1_${ik}$ ) lstres = berr( j ) - count = count + 1 + count = count + 1_${ik}$ go to 20 end if ! bound error from formula @@ -59757,22 +59760,22 @@ module stdlib_linalg_lapack_z rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - kase = 0 + kase = 0_${ik}$ 100 continue - call stdlib_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! multiply by diag(w)*inv(a**h). - call stdlib_zhptrs( uplo, n, 1, afp, ipiv, work, n, info ) + call stdlib${ii}$_zhptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info ) do i = 1, n work( i ) = rwork( i )*work( i ) end do - else if( kase==2 ) then + else if( kase==2_${ik}$ ) then ! multiply by inv(a)*diag(w). do i = 1, n work( i ) = rwork( i )*work( i ) end do - call stdlib_zhptrs( uplo, n, 1, afp, ipiv, work, n, info ) + call stdlib${ii}$_zhptrs( uplo, n, 1_${ik}$, afp, ipiv, work, n, info ) end if go to 100 end if @@ -59784,10 +59787,10 @@ module stdlib_linalg_lapack_z if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_140 return - end subroutine stdlib_zhprfs + end subroutine stdlib${ii}$_zhprfs - pure subroutine stdlib_zhpsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) + pure subroutine stdlib${ii}$_zhpsv( uplo, n, nrhs, ap, ipiv, b, ldb, info ) !! ZHPSV computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N Hermitian matrix stored in packed format and X @@ -59804,41 +59807,41 @@ module stdlib_linalg_lapack_z ! -- 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) :: ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(dp), intent(inout) :: ap(*), b(ldb,*) ! ===================================================================== ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .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( ldb0 )then + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_zlanhp( 'I', uplo, n, ap, rwork ) + anorm = stdlib${ii}$_zlanhp( 'I', uplo, n, ap, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_zhpcon( uplo, n, afp, ipiv, anorm, rcond, work, info ) + call stdlib${ii}$_zhpcon( uplo, n, afp, ipiv, anorm, rcond, work, info ) ! compute the solution vectors x. - call stdlib_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_zhptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info ) + call stdlib${ii}$_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_zhptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_zhprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, & + call stdlib${ii}$_zhprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr,berr, work, & rwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcondrzero ) then eps3 = hnorm*ulp @@ -60057,13 +60060,13 @@ module stdlib_linalg_lapack_z w( k ) = wk if( leftv ) then ! compute left eigenvector. - call stdlib_zlaein( .false., noinit, n-kl+1, h( kl, kl ), ldh,wk, vl( kl, ks )& + call stdlib${ii}$_zlaein( .false., noinit, n-kl+1, h( kl, kl ), ldh,wk, vl( kl, ks )& , work, ldwork, rwork, eps3,smlnum, iinfo ) - if( iinfo>0 ) then - info = info + 1 + if( iinfo>0_${ik}$ ) then + info = info + 1_${ik}$ ifaill( ks ) = k else - ifaill( ks ) = 0 + ifaill( ks ) = 0_${ik}$ end if do i = 1, kl - 1 vl( i, ks ) = czero @@ -60071,26 +60074,26 @@ module stdlib_linalg_lapack_z end if if( rightv ) then ! compute right eigenvector. - call stdlib_zlaein( .true., noinit, kr, h, ldh, wk, vr( 1, ks ),work, ldwork, & + call stdlib${ii}$_zlaein( .true., noinit, kr, h, ldh, wk, vr( 1_${ik}$, ks ),work, ldwork, & rwork, eps3, smlnum, iinfo ) - if( iinfo>0 ) then - info = info + 1 + if( iinfo>0_${ik}$ ) then + info = info + 1_${ik}$ ifailr( ks ) = k else - ifailr( ks ) = 0 + ifailr( ks ) = 0_${ik}$ end if do i = kr + 1, n vr( i, ks ) = czero end do end if - ks = ks + 1 + ks = ks + 1_${ik}$ end if end do loop_100 return - end subroutine stdlib_zhsein + end subroutine stdlib${ii}$_zhsein - pure subroutine stdlib_zlaed0( qsiz, n, d, e, q, ldq, qstore, ldqs, rwork,iwork, info ) + pure subroutine stdlib${ii}$_zlaed0( qsiz, n, d, e, q, ldq, qstore, ldqs, rwork,iwork, info ) !! Using the divide and conquer method, ZLAED0: computes all eigenvalues !! of a symmetric tridiagonal matrix which is one diagonal block of !! those from reducing a dense or band Hermitian matrix and @@ -60100,10 +60103,10 @@ module stdlib_linalg_lapack_z ! -- 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) :: ldq, ldqs, n, qsiz + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldq, ldqs, n, qsiz ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(inout) :: d(*), e(*) real(dp), intent(out) :: rwork(*) complex(dp), intent(inout) :: q(ldq,*) @@ -60112,7 +60115,7 @@ module stdlib_linalg_lapack_z ! warning: n could be as big as qsiz! ! Local Scalars - integer(ilp) :: curlvl, curprb, curr, i, igivcl, igivnm, igivpt, indxq, iperm, iprmpt, & + integer(${ik}$) :: curlvl, curprb, curr, i, igivcl, igivnm, igivpt, indxq, iperm, iprmpt, & iq, iqptr, iwrem, j, k, lgn, ll, matsiz, msd2, smlsiz, smm1, spm1, spm2, submat, & subpbs, tlvls real(dp) :: temp @@ -60120,40 +60123,40 @@ module stdlib_linalg_lapack_z intrinsic :: abs,real,int,log,max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ ! if( icompq < 0 .or. icompq > 2 ) then ! info = -1 ! else if( ( icompq == 1 ) .and. ( qsiz < max( 0, n ) ) ) ! $ then - if( qsizsmlsiz ) then do j = subpbs, 1, -1 - iwork( 2*j ) = ( iwork( j )+1 ) / 2 - iwork( 2*j-1 ) = iwork( j ) / 2 + iwork( 2_${ik}$*j ) = ( iwork( j )+1_${ik}$ ) / 2_${ik}$ + iwork( 2_${ik}$*j-1 ) = iwork( j ) / 2_${ik}$ end do - tlvls = tlvls + 1 - subpbs = 2*subpbs + tlvls = tlvls + 1_${ik}$ + subpbs = 2_${ik}$*subpbs go to 10 end if do j = 2, subpbs @@ -60161,98 +60164,98 @@ module stdlib_linalg_lapack_z end do ! divide the matrix into subpbs submatrices of size at most smlsiz+1 ! using rank-1 modifications (cuts). - spm1 = subpbs - 1 + spm1 = subpbs - 1_${ik}$ do i = 1, spm1 - submat = iwork( i ) + 1 - smm1 = submat - 1 + submat = iwork( i ) + 1_${ik}$ + smm1 = submat - 1_${ik}$ d( smm1 ) = d( smm1 ) - abs( e( smm1 ) ) d( submat ) = d( submat ) - abs( e( smm1 ) ) end do - indxq = 4*n + 3 + indxq = 4_${ik}$*n + 3_${ik}$ ! set up workspaces for eigenvalues only/accumulate new vectors ! routine temp = log( real( n,KIND=dp) ) / log( two ) - lgn = int( temp,KIND=ilp) - if( 2**lgn0 ) then - info = submat*( n+1 ) + submat + matsiz - 1 + call stdlib${ii}$_zlacrm( qsiz, matsiz, q( 1_${ik}$, submat ), ldq, rwork( ll ),matsiz, qstore( & + 1_${ik}$, submat ), ldqs,rwork( iwrem ) ) + iwork( iqptr+curr+1 ) = iwork( iqptr+curr ) + matsiz**2_${ik}$ + curr = curr + 1_${ik}$ + if( info>0_${ik}$ ) then + info = submat*( n+1 ) + submat + matsiz - 1_${ik}$ return end if - k = 1 + k = 1_${ik}$ do j = submat, iwork( i+1 ) iwork( indxq+j ) = k - k = k + 1 + k = k + 1_${ik}$ end do end do ! successively merge eigensystems of adjacent submatrices ! into eigensystem for the corresponding larger matrix. ! while ( subpbs > 1 ) - curlvl = 1 + curlvl = 1_${ik}$ 80 continue - if( subpbs>1 ) then - spm2 = subpbs - 2 + if( subpbs>1_${ik}$ ) then + spm2 = subpbs - 2_${ik}$ do i = 0, spm2, 2 - if( i==0 ) then - submat = 1 - matsiz = iwork( 2 ) - msd2 = iwork( 1 ) - curprb = 0 + if( i==0_${ik}$ ) then + submat = 1_${ik}$ + matsiz = iwork( 2_${ik}$ ) + msd2 = iwork( 1_${ik}$ ) + curprb = 0_${ik}$ else - submat = iwork( i ) + 1 + submat = iwork( i ) + 1_${ik}$ matsiz = iwork( i+2 ) - iwork( i ) - msd2 = matsiz / 2 - curprb = curprb + 1 + msd2 = matsiz / 2_${ik}$ + curprb = curprb + 1_${ik}$ end if ! merge lower order eigensystems (of size msd2 and matsiz - msd2) - ! into an eigensystem of size matsiz. stdlib_zlaed7 handles the case + ! into an eigensystem of size matsiz. stdlib${ii}$_zlaed7 handles the case ! when the eigenvectors of a full or band hermitian matrix (which ! was reduced to tridiagonal form) are desired. ! i am free to use q as a valuable working space until loop 150. - call stdlib_zlaed7( matsiz, msd2, qsiz, tlvls, curlvl, curprb,d( submat ), & - qstore( 1, submat ), ldqs,e( submat+msd2-1 ), iwork( indxq+submat ),rwork( iq ), & + call stdlib${ii}$_zlaed7( matsiz, msd2, qsiz, tlvls, curlvl, curprb,d( submat ), & + qstore( 1_${ik}$, submat ), ldqs,e( submat+msd2-1 ), iwork( indxq+submat ),rwork( iq ), & iwork( iqptr ), iwork( iprmpt ),iwork( iperm ), iwork( igivpt ),iwork( igivcl ), & - rwork( igivnm ),q( 1, submat ), rwork( iwrem ),iwork( subpbs+1 ), info ) - if( info>0 ) then - info = submat*( n+1 ) + submat + matsiz - 1 + rwork( igivnm ),q( 1_${ik}$, submat ), rwork( iwrem ),iwork( subpbs+1 ), info ) + if( info>0_${ik}$ ) then + info = submat*( n+1 ) + submat + matsiz - 1_${ik}$ return end if - iwork( i / 2+1 ) = iwork( i+2 ) + iwork( i / 2_${ik}$+1 ) = iwork( i+2 ) end do - subpbs = subpbs / 2 - curlvl = curlvl + 1 + subpbs = subpbs / 2_${ik}$ + curlvl = curlvl + 1_${ik}$ go to 80 end if ! end while @@ -60261,14 +60264,14 @@ module stdlib_linalg_lapack_z do i = 1, n j = iwork( indxq+i ) rwork( i ) = d( j ) - call stdlib_zcopy( qsiz, qstore( 1, j ), 1, q( 1, i ), 1 ) + call stdlib${ii}$_zcopy( qsiz, qstore( 1_${ik}$, j ), 1_${ik}$, q( 1_${ik}$, i ), 1_${ik}$ ) end do - call stdlib_dcopy( n, rwork, 1, d, 1 ) + call stdlib${ii}$_dcopy( n, rwork, 1_${ik}$, d, 1_${ik}$ ) return - end subroutine stdlib_zlaed0 + end subroutine stdlib${ii}$_zlaed0 - pure subroutine stdlib_zlamswlq( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & + pure subroutine stdlib${ii}$_zlamswlq( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & !! ZLAMSWLQ overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -60282,8 +60285,8 @@ module stdlib_linalg_lapack_z ! -- 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) :: lda, m, n, k, mb, nb, ldt, lwork, ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, k, mb, nb, ldt, lwork, ldc ! Array Arguments complex(dp), intent(in) :: a(lda,*), t(ldt,*) complex(dp), intent(out) :: work(*) @@ -60291,11 +60294,11 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran, lquery - integer(ilp) :: i, ii, kk, lw, ctr + integer(${ik}$) :: i, ii, kk, lw, ctr ! External Subroutines ! Executable Statements ! test the input arguments - lquery = lwork<0 + lquery = lwork<0_${ik}$ notran = stdlib_lsame( trans, 'N' ) tran = stdlib_lsame( trans, 'C' ) left = stdlib_lsame( side, 'L' ) @@ -60305,42 +60308,42 @@ module stdlib_linalg_lapack_z else lw = m * mb end if - info = 0 + info = 0_${ik}$ if( .not.left .and. .not.right ) then - info = -1 + info = -1_${ik}$ else if( .not.tran .and. .not.notran ) then - info = -2 - else if( k<0 ) then - info = -5 + info = -2_${ik}$ + else if( k<0_${ik}$ ) then + info = -5_${ik}$ else if( m=max(m,n,k))) then - call stdlib_zgemlqt( side, trans, m, n, k, mb, a, lda,t, ldt, c, ldc, work, info) + call stdlib${ii}$_zgemlqt( side, trans, m, n, k, mb, a, lda,t, ldt, c, ldc, work, info) return end if @@ -60348,85 +60351,85 @@ module stdlib_linalg_lapack_z ! multiply q to the last block of c kk = mod((m-k),(nb-k)) ctr = (m-k)/(nb-k) - if (kk>0) then + if (kk>0_${ik}$) then ii=m-kk+1 - call stdlib_ztpmlqt('L','C',kk , n, k, 0, mb, a(1,ii), lda,t(1,ctr*k+1), ldt, c(& - 1,1), ldc,c(ii,1), ldc, work, info ) + call stdlib${ii}$_ztpmlqt('L','C',kk , n, k, 0_${ik}$, mb, a(1_${ik}$,ii), lda,t(1_${ik}$,ctr*k+1), ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) else ii=m+1 end if do i=ii-(nb-k),nb+1,-(nb-k) ! multiply q to the current block of c (1:m,i:i+nb) - ctr = ctr - 1 - call stdlib_ztpmlqt('L','C',nb-k , n, k, 0,mb, a(1,i), lda,t(1,ctr*k+1),ldt, c(1,& - 1), ldc,c(i,1), ldc, work, info ) + ctr = ctr - 1_${ik}$ + call stdlib${ii}$_ztpmlqt('L','C',nb-k , n, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$,ctr*k+1),ldt, c(1_${ik}$,& + 1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info ) end do ! multiply q to the first block of c (1:m,1:nb) - call stdlib_zgemlqt('L','C',nb , n, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_zgemlqt('L','C',nb , n, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (left.and.notran) then ! multiply q to the first block of c kk = mod((m-k),(nb-k)) ii=m-kk+1 - ctr = 1 - call stdlib_zgemlqt('L','N',nb , n, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + ctr = 1_${ik}$ + call stdlib${ii}$_zgemlqt('L','N',nb , n, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=nb+1,ii-nb+k,(nb-k) ! multiply q to the current block of c (i:i+nb,1:n) - call stdlib_ztpmlqt('L','N',nb-k , n, k, 0,mb, a(1,i), lda,t(1, ctr * k + 1), ldt, & - c(1,1), ldc,c(i,1), ldc, work, info ) - ctr = ctr + 1 + call stdlib${ii}$_ztpmlqt('L','N',nb-k , n, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$, ctr * k + 1_${ik}$), ldt, & + c(1_${ik}$,1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info ) + ctr = ctr + 1_${ik}$ end do if(ii<=m) then ! multiply q to the last block of c - call stdlib_ztpmlqt('L','N',kk , n, k, 0, mb, a(1,ii), lda,t(1, ctr * k + 1), ldt, & - c(1,1), ldc,c(ii,1), ldc, work, info ) + call stdlib${ii}$_ztpmlqt('L','N',kk , n, k, 0_${ik}$, mb, a(1_${ik}$,ii), lda,t(1_${ik}$, ctr * k + 1_${ik}$), ldt, & + c(1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) end if else if(right.and.notran) then ! multiply q to the last block of c kk = mod((n-k),(nb-k)) ctr = (n-k)/(nb-k) - if (kk>0) then + if (kk>0_${ik}$) then ii=n-kk+1 - call stdlib_ztpmlqt('R','N',m , kk, k, 0, mb, a(1, ii), lda,t(1, ctr * k + 1), & - ldt, c(1,1), ldc,c(1,ii), ldc, work, info ) + call stdlib${ii}$_ztpmlqt('R','N',m , kk, k, 0_${ik}$, mb, a(1_${ik}$, ii), lda,t(1_${ik}$, ctr * k + 1_${ik}$), & + ldt, c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info ) else ii=n+1 end if do i=ii-(nb-k),nb+1,-(nb-k) ! multiply q to the current block of c (1:m,i:i+mb) - ctr = ctr - 1 - call stdlib_ztpmlqt('R','N', m, nb-k, k, 0, mb, a(1, i), lda,t(1, ctr * k + 1), & - ldt, c(1,1), ldc,c(1,i), ldc, work, info ) + ctr = ctr - 1_${ik}$ + call stdlib${ii}$_ztpmlqt('R','N', m, nb-k, k, 0_${ik}$, mb, a(1_${ik}$, i), lda,t(1_${ik}$, ctr * k + 1_${ik}$), & + ldt, c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info ) end do ! multiply q to the first block of c (1:m,1:mb) - call stdlib_zgemlqt('R','N',m , nb, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_zgemlqt('R','N',m , nb, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (right.and.tran) then ! multiply q to the first block of c kk = mod((n-k),(nb-k)) ii=n-kk+1 - call stdlib_zgemlqt('R','C',m , nb, k, mb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_zgemlqt('R','C',m , nb, k, mb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) - ctr = 1 + ctr = 1_${ik}$ do i=nb+1,ii-nb+k,(nb-k) ! multiply q to the current block of c (1:m,i:i+mb) - call stdlib_ztpmlqt('R','C',m , nb-k, k, 0,mb, a(1,i), lda,t(1,ctr *k+1), ldt, c(1,& - 1), ldc,c(1,i), ldc, work, info ) - ctr = ctr + 1 + call stdlib${ii}$_ztpmlqt('R','C',m , nb-k, k, 0_${ik}$,mb, a(1_${ik}$,i), lda,t(1_${ik}$,ctr *k+1), ldt, c(1_${ik}$,& + 1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info ) + ctr = ctr + 1_${ik}$ end do if(ii<=n) then ! multiply q to the last block of c - call stdlib_ztpmlqt('R','C',m , kk, k, 0,mb, a(1,ii), lda,t(1, ctr * k + 1),ldt, c(& - 1,1), ldc,c(1,ii), ldc, work, info ) + call stdlib${ii}$_ztpmlqt('R','C',m , kk, k, 0_${ik}$,mb, a(1_${ik}$,ii), lda,t(1_${ik}$, ctr * k + 1_${ik}$),ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info ) end if end if - work(1) = lw + work(1_${ik}$) = lw return - end subroutine stdlib_zlamswlq + end subroutine stdlib${ii}$_zlamswlq - pure subroutine stdlib_zlamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & + pure subroutine stdlib${ii}$_zlamtsqr( side, trans, m, n, k, mb, nb, a, lda, t,ldt, c, ldc, work, & !! ZLAMTSQR overwrites the general complex M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -60440,8 +60443,8 @@ module stdlib_linalg_lapack_z ! -- 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) :: lda, m, n, k, mb, nb, ldt, lwork, ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, k, mb, nb, ldt, lwork, ldc ! Array Arguments complex(dp), intent(in) :: a(lda,*), t(ldt,*) complex(dp), intent(out) :: work(*) @@ -60449,11 +60452,11 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran, lquery - integer(ilp) :: i, ii, kk, lw, ctr, q + integer(${ik}$) :: i, ii, kk, lw, ctr, q ! External Subroutines ! Executable Statements ! test the input arguments - lquery = lwork<0 + lquery = lwork<0_${ik}$ notran = stdlib_lsame( trans, 'N' ) tran = stdlib_lsame( trans, 'C' ) left = stdlib_lsame( side, 'L' ) @@ -60465,44 +60468,44 @@ module stdlib_linalg_lapack_z lw = m * nb q = n end if - info = 0 + info = 0_${ik}$ if( .not.left .and. .not.right ) then - info = -1 + info = -1_${ik}$ else if( .not.tran .and. .not.notran ) then - info = -2 + info = -2_${ik}$ else if( m=max(m,n,k))) then - call stdlib_zgemqrt( side, trans, m, n, k, nb, a, lda,t, ldt, c, ldc, work, info) + call stdlib${ii}$_zgemqrt( side, trans, m, n, k, nb, a, lda,t, ldt, c, ldc, work, info) return end if @@ -60510,85 +60513,85 @@ module stdlib_linalg_lapack_z ! multiply q to the last block of c kk = mod((m-k),(mb-k)) ctr = (m-k)/(mb-k) - if (kk>0) then + if (kk>0_${ik}$) then ii=m-kk+1 - call stdlib_ztpmqrt('L','N',kk , n, k, 0, nb, a(ii,1), lda,t(1, ctr * k + 1),ldt ,& - c(1,1), ldc,c(ii,1), ldc, work, info ) + call stdlib${ii}$_ztpmqrt('L','N',kk , n, k, 0_${ik}$, nb, a(ii,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$),ldt ,& + c(1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) else ii=m+1 end if do i=ii-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) - ctr = ctr - 1 - call stdlib_ztpmqrt('L','N',mb-k , n, k, 0,nb, a(i,1), lda,t(1,ctr * k + 1),ldt, & - c(1,1), ldc,c(i,1), ldc, work, info ) + ctr = ctr - 1_${ik}$ + call stdlib${ii}$_ztpmqrt('L','N',mb-k , n, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$,ctr * k + 1_${ik}$),ldt, & + c(1_${ik}$,1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info ) end do ! multiply q to the first block of c (1:mb,1:n) - call stdlib_zgemqrt('L','N',mb , n, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_zgemqrt('L','N',mb , n, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (left.and.tran) then ! multiply q to the first block of c kk = mod((m-k),(mb-k)) ii=m-kk+1 - ctr = 1 - call stdlib_zgemqrt('L','C',mb , n, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + ctr = 1_${ik}$ + call stdlib${ii}$_zgemqrt('L','C',mb , n, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (i:i+mb,1:n) - call stdlib_ztpmqrt('L','C',mb-k , n, k, 0,nb, a(i,1), lda,t(1,ctr * k + 1),ldt, c(& - 1,1), ldc,c(i,1), ldc, work, info ) - ctr = ctr + 1 + call stdlib${ii}$_ztpmqrt('L','C',mb-k , n, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$,ctr * k + 1_${ik}$),ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(i,1_${ik}$), ldc, work, info ) + ctr = ctr + 1_${ik}$ end do if(ii<=m) then ! multiply q to the last block of c - call stdlib_ztpmqrt('L','C',kk , n, k, 0,nb, a(ii,1), lda,t(1, ctr * k + 1), ldt, & - c(1,1), ldc,c(ii,1), ldc, work, info ) + call stdlib${ii}$_ztpmqrt('L','C',kk , n, k, 0_${ik}$,nb, a(ii,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$), ldt, & + c(1_${ik}$,1_${ik}$), ldc,c(ii,1_${ik}$), ldc, work, info ) end if else if(right.and.tran) then ! multiply q to the last block of c kk = mod((n-k),(mb-k)) ctr = (n-k)/(mb-k) - if (kk>0) then + if (kk>0_${ik}$) then ii=n-kk+1 - call stdlib_ztpmqrt('R','C',m , kk, k, 0, nb, a(ii,1), lda,t(1,ctr * k + 1), ldt,& - c(1,1), ldc,c(1,ii), ldc, work, info ) + call stdlib${ii}$_ztpmqrt('R','C',m , kk, k, 0_${ik}$, nb, a(ii,1_${ik}$), lda,t(1_${ik}$,ctr * k + 1_${ik}$), ldt,& + c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info ) else ii=n+1 end if do i=ii-(mb-k),mb+1,-(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) - ctr = ctr - 1 - call stdlib_ztpmqrt('R','C',m , mb-k, k, 0,nb, a(i,1), lda,t(1, ctr * k + 1), & - ldt, c(1,1), ldc,c(1,i), ldc, work, info ) + ctr = ctr - 1_${ik}$ + call stdlib${ii}$_ztpmqrt('R','C',m , mb-k, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$), & + ldt, c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info ) end do ! multiply q to the first block of c (1:m,1:mb) - call stdlib_zgemqrt('R','C',m , mb, k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + call stdlib${ii}$_zgemqrt('R','C',m , mb, k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) else if (right.and.notran) then ! multiply q to the first block of c kk = mod((n-k),(mb-k)) ii=n-kk+1 - ctr = 1 - call stdlib_zgemqrt('R','N', m, mb , k, nb, a(1,1), lda, t,ldt ,c(1,1), ldc, work, & + ctr = 1_${ik}$ + call stdlib${ii}$_zgemqrt('R','N', m, mb , k, nb, a(1_${ik}$,1_${ik}$), lda, t,ldt ,c(1_${ik}$,1_${ik}$), ldc, work, & info ) do i=mb+1,ii-mb+k,(mb-k) ! multiply q to the current block of c (1:m,i:i+mb) - call stdlib_ztpmqrt('R','N', m, mb-k, k, 0,nb, a(i,1), lda,t(1, ctr * k + 1),ldt, & - c(1,1), ldc,c(1,i), ldc, work, info ) - ctr = ctr + 1 + call stdlib${ii}$_ztpmqrt('R','N', m, mb-k, k, 0_${ik}$,nb, a(i,1_${ik}$), lda,t(1_${ik}$, ctr * k + 1_${ik}$),ldt, & + c(1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,i), ldc, work, info ) + ctr = ctr + 1_${ik}$ end do if(ii<=n) then ! multiply q to the last block of c - call stdlib_ztpmqrt('R','N', m, kk , k, 0,nb, a(ii,1), lda,t(1,ctr * k + 1),ldt, c(& - 1,1), ldc,c(1,ii), ldc, work, info ) + call stdlib${ii}$_ztpmqrt('R','N', m, kk , k, 0_${ik}$,nb, a(ii,1_${ik}$), lda,t(1_${ik}$,ctr * k + 1_${ik}$),ldt, c(& + 1_${ik}$,1_${ik}$), ldc,c(1_${ik}$,ii), ldc, work, info ) end if end if - work(1) = lw + work(1_${ik}$) = lw return - end subroutine stdlib_zlamtsqr + end subroutine stdlib${ii}$_zlamtsqr - pure subroutine stdlib_zlaqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & + pure subroutine stdlib${ii}$_zlaqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & !! ZLAQR2 is identical to ZLAQR3 except that it avoids !! recursion by calling ZLAHQR instead of ZLAQR4. !! Aggressive early deflation: @@ -60605,9 +60608,9 @@ module stdlib_linalg_lapack_z ! -- 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) :: ihiz, iloz, kbot, ktop, ldh, ldt, ldv, ldwv, ldz, lwork, n,& + integer(${ik}$), intent(in) :: ihiz, iloz, kbot, ktop, ldh, ldt, ldv, ldwv, ldz, lwork, n,& nh, nv, nw - integer(ilp), intent(out) :: nd, ns + integer(${ik}$), intent(out) :: nd, ns logical(lk), intent(in) :: wantt, wantz ! Array Arguments complex(dp), intent(inout) :: h(ldh,*), z(ldz,*) @@ -60621,7 +60624,7 @@ module stdlib_linalg_lapack_z ! Local Scalars complex(dp) :: beta, cdum, s, tau real(dp) :: foo, safmax, safmin, smlnum, ulp - integer(ilp) :: i, ifst, ilst, info, infqr, j, jw, kcol, kln, knt, krow, kwtop, ltop, & + integer(${ik}$) :: i, ifst, ilst, info, infqr, j, jw, kcol, kln, knt, krow, kwtop, ltop, & lwk1, lwk2, lwkopt ! Intrinsic Functions intrinsic :: abs,real,cmplx,conjg,aimag,int,max,min @@ -60632,41 +60635,41 @@ module stdlib_linalg_lapack_z ! Executable Statements ! ==== estimate optimal workspace. ==== jw = min( nw, kbot-ktop+1 ) - if( jw<=2 ) then - lwkopt = 1 + if( jw<=2_${ik}$ ) then + lwkopt = 1_${ik}$ else - ! ==== workspace query call to stdlib_zgehrd ==== - call stdlib_zgehrd( jw, 1, jw-1, t, ldt, work, work, -1, info ) - lwk1 = int( work( 1 ),KIND=ilp) - ! ==== workspace query call to stdlib_zunmhr ==== - call stdlib_zunmhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv,work, -1, info ) + ! ==== workspace query call to stdlib${ii}$_zgehrd ==== + call stdlib${ii}$_zgehrd( jw, 1_${ik}$, jw-1, t, ldt, work, work, -1_${ik}$, info ) + lwk1 = int( work( 1_${ik}$ ),KIND=${ik}$) + ! ==== workspace query call to stdlib${ii}$_zunmhr ==== + call stdlib${ii}$_zunmhr( 'R', 'N', jw, jw, 1_${ik}$, jw-1, t, ldt, work, v, ldv,work, -1_${ik}$, info ) - lwk2 = int( work( 1 ),KIND=ilp) + lwk2 = int( work( 1_${ik}$ ),KIND=${ik}$) ! ==== optimal workspace ==== lwkopt = jw + max( lwk1, lwk2 ) end if ! ==== quick return in case of workspace query. ==== - if( lwork==-1 ) then - work( 1 ) = cmplx( lwkopt, 0,KIND=dp) + if( lwork==-1_${ik}$ ) then + work( 1_${ik}$ ) = cmplx( lwkopt, 0_${ik}$,KIND=dp) return end if ! ==== nothing to do ... ! ... for an empty active block ... ==== - ns = 0 - nd = 0 - work( 1 ) = cone + ns = 0_${ik}$ + nd = 0_${ik}$ + work( 1_${ik}$ ) = cone if( ktop>kbot )return ! ... nor for an empty deflation window. ==== if( nw<1 )return ! ==== machine constants ==== - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) safmax = rone / safmin - call stdlib_dlabad( safmin, safmax ) - ulp = stdlib_dlamch( 'PRECISION' ) + call stdlib${ii}$_dlabad( safmin, safmax ) + ulp = stdlib${ii}$_dlamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=dp) / ulp ) ! ==== setup deflation window ==== jw = min( nw, kbot-ktop+1 ) - kwtop = kbot - jw + 1 + kwtop = kbot - jw + 1_${ik}$ if( kwtop==ktop ) then s = czero else @@ -60675,14 +60678,14 @@ module stdlib_linalg_lapack_z if( kbot==kwtop ) then ! ==== 1-by-1 deflation window: not much to do ==== sh( kwtop ) = h( kwtop, kwtop ) - ns = 1 - nd = 0 + ns = 1_${ik}$ + nd = 0_${ik}$ if( cabs1( s )<=max( smlnum, ulp*cabs1( h( kwtop,kwtop ) ) ) ) then - ns = 0 - nd = 1 + ns = 0_${ik}$ + nd = 1_${ik}$ if( kwtop>ktop )h( kwtop, kwtop-1 ) = czero end if - work( 1 ) = cone + work( 1_${ik}$ ) = cone return end if ! ==== convert to spike-triangular form. (in case of a @@ -60690,31 +60693,31 @@ module stdlib_linalg_lapack_z ! . aggressive early deflation using that part of ! . the deflation window that converged using infqr ! . here and there to keep track.) ==== - call stdlib_zlacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) - call stdlib_zcopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 ) - call stdlib_zlaset( 'A', jw, jw, czero, cone, v, ldv ) - call stdlib_zlahqr( .true., .true., jw, 1, jw, t, ldt, sh( kwtop ), 1,jw, v, ldv, & + call stdlib${ii}$_zlacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) + call stdlib${ii}$_zcopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2_${ik}$, 1_${ik}$ ), ldt+1 ) + call stdlib${ii}$_zlaset( 'A', jw, jw, czero, cone, v, ldv ) + call stdlib${ii}$_zlahqr( .true., .true., jw, 1_${ik}$, jw, t, ldt, sh( kwtop ), 1_${ik}$,jw, v, ldv, & infqr ) ! ==== deflation detection loop ==== ns = jw - ilst = infqr + 1 + ilst = infqr + 1_${ik}$ do knt = infqr + 1, jw ! ==== small spike tip deflation test ==== foo = cabs1( t( ns, ns ) ) if( foo==rzero )foo = cabs1( s ) - if( cabs1( s )*cabs1( v( 1, ns ) )<=max( smlnum, ulp*foo ) )then + if( cabs1( s )*cabs1( v( 1_${ik}$, ns ) )<=max( smlnum, ulp*foo ) )then ! ==== cone more converged eigenvalue ==== - ns = ns - 1 + ns = ns - 1_${ik}$ else ! ==== cone undeflatable eigenvalue. move it up out of the - ! . way. (stdlib_ztrexc can not fail in this case.) ==== + ! . way. (stdlib${ii}$_ztrexc can not fail in this case.) ==== ifst = ns - call stdlib_ztrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) - ilst = ilst + 1 + call stdlib${ii}$_ztrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) + ilst = ilst + 1_${ik}$ end if end do ! ==== return to hessenberg form ==== - if( ns==0 )s = czero + if( ns==0_${ik}$ )s = czero if( nscabs1( t( ifst, ifst ) ) )ifst = j end do ilst = i - if( ifst/=ilst )call stdlib_ztrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) + if( ifst/=ilst )call stdlib${ii}$_ztrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) end do end if @@ -60733,59 +60736,59 @@ module stdlib_linalg_lapack_z sh( kwtop+i-1 ) = t( i, i ) end do if( ns1 .and. s/=czero ) then + if( ns>1_${ik}$ .and. s/=czero ) then ! ==== reflect spike back into lower triangle ==== - call stdlib_zcopy( ns, v, ldv, work, 1 ) + call stdlib${ii}$_zcopy( ns, v, ldv, work, 1_${ik}$ ) do i = 1, ns work( i ) = conjg( work( i ) ) end do - beta = work( 1 ) - call stdlib_zlarfg( ns, beta, work( 2 ), 1, tau ) - work( 1 ) = cone - call stdlib_zlaset( 'L', jw-2, jw-2, czero, czero, t( 3, 1 ), ldt ) - call stdlib_zlarf( 'L', ns, jw, work, 1, conjg( tau ), t, ldt,work( jw+1 ) ) + beta = work( 1_${ik}$ ) + call stdlib${ii}$_zlarfg( ns, beta, work( 2_${ik}$ ), 1_${ik}$, tau ) + work( 1_${ik}$ ) = cone + call stdlib${ii}$_zlaset( 'L', jw-2, jw-2, czero, czero, t( 3_${ik}$, 1_${ik}$ ), ldt ) + call stdlib${ii}$_zlarf( 'L', ns, jw, work, 1_${ik}$, conjg( tau ), t, ldt,work( jw+1 ) ) - call stdlib_zlarf( 'R', ns, ns, work, 1, tau, t, ldt,work( jw+1 ) ) - call stdlib_zlarf( 'R', jw, ns, work, 1, tau, v, ldv,work( jw+1 ) ) - call stdlib_zgehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) + call stdlib${ii}$_zlarf( 'R', ns, ns, work, 1_${ik}$, tau, t, ldt,work( jw+1 ) ) + call stdlib${ii}$_zlarf( 'R', jw, ns, work, 1_${ik}$, tau, v, ldv,work( jw+1 ) ) + call stdlib${ii}$_zgehrd( jw, 1_${ik}$, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) end if ! ==== copy updated reduced window into place ==== - if( kwtop>1 )h( kwtop, kwtop-1 ) = s*conjg( v( 1, 1 ) ) - call stdlib_zlacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) - call stdlib_zcopy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) + if( kwtop>1_${ik}$ )h( kwtop, kwtop-1 ) = s*conjg( v( 1_${ik}$, 1_${ik}$ ) ) + call stdlib${ii}$_zlacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) + call stdlib${ii}$_zcopy( jw-1, t( 2_${ik}$, 1_${ik}$ ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) ! ==== accumulate orthogonal matrix in order update ! . h and z, if requested. ==== - if( ns>1 .and. s/=czero )call stdlib_zunmhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, & + if( ns>1_${ik}$ .and. s/=czero )call stdlib${ii}$_zunmhr( 'R', 'N', jw, ns, 1_${ik}$, ns, t, ldt, work, & v, ldv,work( jw+1 ), lwork-jw, info ) ! ==== update vertical slab in h ==== if( wantt ) then - ltop = 1 + ltop = 1_${ik}$ else ltop = ktop end if do krow = ltop, kwtop - 1, nv kln = min( nv, kwtop-krow ) - call stdlib_zgemm( 'N', 'N', kln, jw, jw, cone, h( krow, kwtop ),ldh, v, ldv, & + call stdlib${ii}$_zgemm( 'N', 'N', kln, jw, jw, cone, h( krow, kwtop ),ldh, v, ldv, & czero, wv, ldwv ) - call stdlib_zlacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) + call stdlib${ii}$_zlacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) end do ! ==== update horizontal slab in h ==== if( wantt ) then do kcol = kbot + 1, n, nh kln = min( nh, n-kcol+1 ) - call stdlib_zgemm( 'C', 'N', jw, kln, jw, cone, v, ldv,h( kwtop, kcol ), ldh, & + call stdlib${ii}$_zgemm( 'C', 'N', jw, kln, jw, cone, v, ldv,h( kwtop, kcol ), ldh, & czero, t, ldt ) - call stdlib_zlacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) + call stdlib${ii}$_zlacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) end do end if ! ==== update vertical slab in z ==== if( wantz ) then do krow = iloz, ihiz, nv kln = min( nv, ihiz-krow+1 ) - call stdlib_zgemm( 'N', 'N', kln, jw, jw, cone, z( krow, kwtop ),ldz, v, ldv, & + call stdlib${ii}$_zgemm( 'N', 'N', kln, jw, jw, cone, z( krow, kwtop ),ldz, v, ldv, & czero, wv, ldwv ) - call stdlib_zlacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) + call stdlib${ii}$_zlacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) end do end if end if @@ -60798,11 +60801,11 @@ module stdlib_linalg_lapack_z ! . window.) ==== ns = ns - infqr ! ==== return optimal workspace. ==== - work( 1 ) = cmplx( lwkopt, 0,KIND=dp) - end subroutine stdlib_zlaqr2 + work( 1_${ik}$ ) = cmplx( lwkopt, 0_${ik}$,KIND=dp) + end subroutine stdlib${ii}$_zlaqr2 - pure subroutine stdlib_zlaswlq( m, n, mb, nb, a, lda, t, ldt, work, lwork,info) + pure subroutine stdlib${ii}$_zlaswlq( m, n, mb, nb, a, lda, t, ldt, work, lwork,info) !! ZLASWLQ computes a blocked Tall-Skinny LQ factorization of !! a complexx M-by-N matrix A for M <= N: !! A = ( L 0 ) * Q, @@ -60817,76 +60820,76 @@ module stdlib_linalg_lapack_z ! -- 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, mb, nb, lwork, ldt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, mb, nb, lwork, ldt ! Array Arguments complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: work(*), t(ldt,*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, ii, kk, ctr + integer(${ik}$) :: i, ii, kk, ctr ! External Subroutines intrinsic :: max,min,mod ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 .or. nm .and. m>0 )) then - info = -3 - else if( nb<=0 ) then - info = -4 - else if( ldam .and. m>0_${ik}$ )) then + info = -3_${ik}$ + else if( nb<=0_${ik}$ ) then + info = -4_${ik}$ + else if( lda=n).or.(nb<=m).or.(nb>=n)) then - call stdlib_zgelqt( m, n, mb, a, lda, t, ldt, work, info) + call stdlib${ii}$_zgelqt( m, n, mb, a, lda, t, ldt, work, info) return end if kk = mod((n-m),(nb-m)) ii=n-kk+1 ! compute the lq factorization of the first block a(1:m,1:nb) - call stdlib_zgelqt( m, nb, mb, a(1,1), lda, t, ldt, work, info) - ctr = 1 + call stdlib${ii}$_zgelqt( m, nb, mb, a(1_${ik}$,1_${ik}$), lda, t, ldt, work, info) + ctr = 1_${ik}$ do i = nb+1, ii-nb+m , (nb-m) ! compute the qr factorization of the current block a(1:m,i:i+nb-m) - call stdlib_ztplqt( m, nb-m, 0, mb, a(1,1), lda, a( 1, i ),lda, t(1, ctr * m + 1),& + call stdlib${ii}$_ztplqt( m, nb-m, 0_${ik}$, mb, a(1_${ik}$,1_${ik}$), lda, a( 1_${ik}$, i ),lda, t(1_${ik}$, ctr * m + 1_${ik}$),& ldt, work, info ) - ctr = ctr + 1 + ctr = ctr + 1_${ik}$ end do ! compute the qr factorization of the last block a(1:m,ii:n) if (ii<=n) then - call stdlib_ztplqt( m, kk, 0, mb, a(1,1), lda, a( 1, ii ),lda, t(1, ctr * m + 1), & + call stdlib${ii}$_ztplqt( m, kk, 0_${ik}$, mb, a(1_${ik}$,1_${ik}$), lda, a( 1_${ik}$, ii ),lda, t(1_${ik}$, ctr * m + 1_${ik}$), & ldt,work, info ) end if - work( 1 ) = m * mb + work( 1_${ik}$ ) = m * mb return - end subroutine stdlib_zlaswlq + end subroutine stdlib${ii}$_zlaswlq - pure subroutine stdlib_zlatsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) + pure subroutine stdlib${ii}$_zlatsqr( m, n, mb, nb, a, lda, t, ldt, work,lwork, info) !! ZLATSQR computes a blocked Tall-Skinny QR factorization of !! a complex M-by-N matrix A for M >= N: !! A = Q * ( R ), @@ -60902,76 +60905,76 @@ module stdlib_linalg_lapack_z ! -- 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, mb, nb, ldt, lwork + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, mb, nb, ldt, lwork ! Array Arguments complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: work(*), t(ldt,*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, ii, kk, ctr + integer(${ik}$) :: i, ii, kk, ctr ! External Subroutines intrinsic :: max,min,mod ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 .or. mn .and. n>0 )) then - info = -4 - else if( ldan .and. n>0_${ik}$ )) then + info = -4_${ik}$ + else if( lda=m)) then - call stdlib_zgeqrt( m, n, nb, a, lda, t, ldt, work, info) + call stdlib${ii}$_zgeqrt( m, n, nb, a, lda, t, ldt, work, info) return end if kk = mod((m-n),(mb-n)) ii=m-kk+1 ! compute the qr factorization of the first block a(1:mb,1:n) - call stdlib_zgeqrt( mb, n, nb, a(1,1), lda, t, ldt, work, info ) - ctr = 1 + call stdlib${ii}$_zgeqrt( mb, n, nb, a(1_${ik}$,1_${ik}$), lda, t, ldt, work, info ) + ctr = 1_${ik}$ do i = mb+1, ii-mb+n , (mb-n) ! compute the qr factorization of the current block a(i:i+mb-n,1:n) - call stdlib_ztpqrt( mb-n, n, 0, nb, a(1,1), lda, a( i, 1 ), lda,t(1, ctr * n + 1),& + call stdlib${ii}$_ztpqrt( mb-n, n, 0_${ik}$, nb, a(1_${ik}$,1_${ik}$), lda, a( i, 1_${ik}$ ), lda,t(1_${ik}$, ctr * n + 1_${ik}$),& ldt, work, info ) - ctr = ctr + 1 + ctr = ctr + 1_${ik}$ end do ! compute the qr factorization of the last block a(ii:m,1:n) if (ii<=m) then - call stdlib_ztpqrt( kk, n, 0, nb, a(1,1), lda, a( ii, 1 ), lda,t(1,ctr * n + 1), & + call stdlib${ii}$_ztpqrt( kk, n, 0_${ik}$, nb, a(1_${ik}$,1_${ik}$), lda, a( ii, 1_${ik}$ ), lda,t(1_${ik}$,ctr * n + 1_${ik}$), & ldt,work, info ) end if - work( 1 ) = n*nb + work( 1_${ik}$ ) = n*nb return - end subroutine stdlib_zlatsqr + end subroutine stdlib${ii}$_zlatsqr - pure subroutine stdlib_zpbsv( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) + pure subroutine stdlib${ii}$_zpbsv( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) !! ZPBSV computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N Hermitian positive definite band matrix and X @@ -60988,8 +60991,8 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: ab(ldab,*), b(ldb,*) ! ===================================================================== @@ -60997,35 +61000,35 @@ module stdlib_linalg_lapack_z intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .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( ldab0 ) then + info = -11_${ik}$ + else if( n>0_${ik}$ ) then scond = max( smin, smlnum ) / min( smax, bignum ) else scond = one end if end if - if( info==0 ) then - if( ldb0 )then + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_zlanhb( '1', uplo, n, kd, ab, ldab, rwork ) + anorm = stdlib${ii}$_zlanhb( '1', uplo, n, kd, ab, ldab, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_zpbcon( uplo, n, kd, afb, ldafb, anorm, rcond, work, rwork,info ) + call stdlib${ii}$_zpbcon( uplo, n, kd, afb, ldafb, anorm, rcond, work, rwork,info ) ! compute the solution matrix x. - call stdlib_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_zpbtrs( uplo, n, kd, nrhs, afb, ldafb, x, ldx, info ) + call stdlib${ii}$_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_zpbtrs( uplo, n, kd, nrhs, afb, ldafb, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_zpbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b, ldb, x,ldx, ferr, berr,& + call stdlib${ii}$_zpbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b, ldb, x,ldx, ferr, berr,& work, rwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -61177,12 +61180,12 @@ module stdlib_linalg_lapack_z end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) - call stdlib_zpotrf( 'L', n1, a( 0 ), n, info ) + call stdlib${ii}$_zpotrf( 'L', n1, a( 0_${ik}$ ), n, info ) if( info>0 )return - call stdlib_ztrsm( 'R', 'L', 'C', 'N', n2, n1, cone, a( 0 ), n,a( n1 ), n ) + call stdlib${ii}$_ztrsm( 'R', 'L', 'C', 'N', n2, n1, cone, a( 0_${ik}$ ), n,a( n1 ), n ) - call stdlib_zherk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n ) - call stdlib_zpotrf( 'U', n2, a( n ), n, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_zherk( 'U', 'N', n2, n1, -one, a( n1 ), n, one,a( n ), n ) + call stdlib${ii}$_zpotrf( 'U', n2, a( n ), n, info ) + if( info>0_${ik}$ )info = info + n1 else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) - call stdlib_zpotrf( 'L', n1, a( n2 ), n, info ) + call stdlib${ii}$_zpotrf( 'L', n1, a( n2 ), n, info ) if( info>0 )return - call stdlib_ztrsm( 'L', 'L', 'N', 'N', n1, n2, cone, a( n2 ), n,a( 0 ), n ) + call stdlib${ii}$_ztrsm( 'L', 'L', 'N', 'N', n1, n2, cone, a( n2 ), n,a( 0_${ik}$ ), n ) - call stdlib_zherk( 'U', 'C', n2, n1, -one, a( 0 ), n, one,a( n1 ), n ) - call stdlib_zpotrf( 'U', n2, a( n1 ), n, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_zherk( 'U', 'C', n2, n1, -one, a( 0_${ik}$ ), n, one,a( n1 ), n ) + call stdlib${ii}$_zpotrf( 'U', n2, a( n1 ), n, info ) + if( info>0_${ik}$ )info = info + n1 end if else ! n is odd and transr = 'c' @@ -61275,26 +61278,26 @@ module stdlib_linalg_lapack_z ! srpa for lower, transpose and n is odd ! t1 -> a(0,0) , t2 -> a(1,0) , s -> a(0,n1) ! t1 -> a(0+0) , t2 -> a(1+0) , s -> a(0+n1*n1); lda=n1 - call stdlib_zpotrf( 'U', n1, a( 0 ), n1, info ) + call stdlib${ii}$_zpotrf( 'U', n1, a( 0_${ik}$ ), n1, info ) if( info>0 )return - call stdlib_ztrsm( 'L', 'U', 'C', 'N', n1, n2, cone, a( 0 ), n1,a( n1*n1 ), & + call stdlib${ii}$_ztrsm( 'L', 'U', 'C', 'N', n1, n2, cone, a( 0_${ik}$ ), n1,a( n1*n1 ), & n1 ) - call stdlib_zherk( 'L', 'C', n2, n1, -one, a( n1*n1 ), n1, one,a( 1 ), n1 ) + call stdlib${ii}$_zherk( 'L', 'C', n2, n1, -one, a( n1*n1 ), n1, one,a( 1_${ik}$ ), n1 ) - call stdlib_zpotrf( 'L', n2, a( 1 ), n1, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_zpotrf( 'L', n2, a( 1_${ik}$ ), n1, info ) + if( info>0_${ik}$ )info = info + n1 else ! srpa for upper, transpose and n is odd ! t1 -> a(0,n1+1), t2 -> a(0,n1), s -> a(0,0) ! t1 -> a(n2*n2), t2 -> a(n1*n2), s -> a(0); lda = n2 - call stdlib_zpotrf( 'U', n1, a( n2*n2 ), n2, info ) + call stdlib${ii}$_zpotrf( 'U', n1, a( n2*n2 ), n2, info ) if( info>0 )return - call stdlib_ztrsm( 'R', 'U', 'N', 'N', n2, n1, cone, a( n2*n2 ),n2, a( 0 ), & + call stdlib${ii}$_ztrsm( 'R', 'U', 'N', 'N', n2, n1, cone, a( n2*n2 ),n2, a( 0_${ik}$ ), & n2 ) - call stdlib_zherk( 'L', 'N', n2, n1, -one, a( 0 ), n2, one,a( n1*n2 ), n2 ) + call stdlib${ii}$_zherk( 'L', 'N', n2, n1, -one, a( 0_${ik}$ ), n2, one,a( n1*n2 ), n2 ) - call stdlib_zpotrf( 'L', n2, a( n1*n2 ), n2, info ) - if( info>0 )info = info + n1 + call stdlib${ii}$_zpotrf( 'L', n2, a( n1*n2 ), n2, info ) + if( info>0_${ik}$ )info = info + n1 end if end if else @@ -61305,26 +61308,26 @@ module stdlib_linalg_lapack_z ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) - call stdlib_zpotrf( 'L', k, a( 1 ), n+1, info ) + call stdlib${ii}$_zpotrf( 'L', k, a( 1_${ik}$ ), n+1, info ) if( info>0 )return - call stdlib_ztrsm( 'R', 'L', 'C', 'N', k, k, cone, a( 1 ), n+1,a( k+1 ), n+1 ) + call stdlib${ii}$_ztrsm( 'R', 'L', 'C', 'N', k, k, cone, a( 1_${ik}$ ), n+1,a( k+1 ), n+1 ) - call stdlib_zherk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0 ), n+1 ) + call stdlib${ii}$_zherk( 'U', 'N', k, k, -one, a( k+1 ), n+1, one,a( 0_${ik}$ ), n+1 ) - call stdlib_zpotrf( 'U', k, a( 0 ), n+1, info ) - if( info>0 )info = info + k + call stdlib${ii}$_zpotrf( 'U', k, a( 0_${ik}$ ), n+1, info ) + if( info>0_${ik}$ )info = info + k else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) - call stdlib_zpotrf( 'L', k, a( k+1 ), n+1, info ) + call stdlib${ii}$_zpotrf( 'L', k, a( k+1 ), n+1, info ) if( info>0 )return - call stdlib_ztrsm( 'L', 'L', 'N', 'N', k, k, cone, a( k+1 ),n+1, a( 0 ), n+1 ) + call stdlib${ii}$_ztrsm( 'L', 'L', 'N', 'N', k, k, cone, a( k+1 ),n+1, a( 0_${ik}$ ), n+1 ) - call stdlib_zherk( 'U', 'C', k, k, -one, a( 0 ), n+1, one,a( k ), n+1 ) + call stdlib${ii}$_zherk( 'U', 'C', k, k, -one, a( 0_${ik}$ ), n+1, one,a( k ), n+1 ) - call stdlib_zpotrf( 'U', k, a( k ), n+1, info ) - if( info>0 )info = info + k + call stdlib${ii}$_zpotrf( 'U', k, a( k ), n+1, info ) + if( info>0_${ik}$ )info = info + k end if else ! n is even and transr = 'c' @@ -61332,33 +61335,33 @@ module stdlib_linalg_lapack_z ! srpa for lower, transpose and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1) ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k - call stdlib_zpotrf( 'U', k, a( 0+k ), k, info ) + call stdlib${ii}$_zpotrf( 'U', k, a( 0_${ik}$+k ), k, info ) if( info>0 )return - call stdlib_ztrsm( 'L', 'U', 'C', 'N', k, k, cone, a( k ), n1,a( k*( k+1 ) ), & + call stdlib${ii}$_ztrsm( 'L', 'U', 'C', 'N', k, k, cone, a( k ), n1,a( k*( k+1 ) ), & k ) - call stdlib_zherk( 'L', 'C', k, k, -one, a( k*( k+1 ) ), k, one,a( 0 ), k ) + call stdlib${ii}$_zherk( 'L', 'C', k, k, -one, a( k*( k+1 ) ), k, one,a( 0_${ik}$ ), k ) - call stdlib_zpotrf( 'L', k, a( 0 ), k, info ) - if( info>0 )info = info + k + call stdlib${ii}$_zpotrf( 'L', k, a( 0_${ik}$ ), k, info ) + if( info>0_${ik}$ )info = info + k else ! srpa for upper, transpose and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0) ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k - call stdlib_zpotrf( 'U', k, a( k*( k+1 ) ), k, info ) + call stdlib${ii}$_zpotrf( 'U', k, a( k*( k+1 ) ), k, info ) if( info>0 )return - call stdlib_ztrsm( 'R', 'U', 'N', 'N', k, k, cone,a( k*( k+1 ) ), k, a( 0 ), & + call stdlib${ii}$_ztrsm( 'R', 'U', 'N', 'N', k, k, cone,a( k*( k+1 ) ), k, a( 0_${ik}$ ), & k ) - call stdlib_zherk( 'L', 'N', k, k, -one, a( 0 ), k, one,a( k*k ), k ) - call stdlib_zpotrf( 'L', k, a( k*k ), k, info ) - if( info>0 )info = info + k + call stdlib${ii}$_zherk( 'L', 'N', k, k, -one, a( 0_${ik}$ ), k, one,a( k*k ), k ) + call stdlib${ii}$_zpotrf( 'L', k, a( k*k ), k, info ) + if( info>0_${ik}$ )info = info + k end if end if end if return - end subroutine stdlib_zpftrf + end subroutine stdlib${ii}$_zpftrf - pure subroutine stdlib_zpftri( transr, uplo, n, a, info ) + pure subroutine stdlib${ii}$_zpftri( transr, uplo, n, a, info ) !! ZPFTRI computes the inverse of a complex Hermitian positive definite !! matrix A using the Cholesky factorization A = U**H*U or A = L*L**H !! computed by ZPFTRF. @@ -61367,53 +61370,53 @@ module stdlib_linalg_lapack_z ! -- 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 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: n ! Array Arguments - complex(dp), intent(inout) :: a(0:*) + complex(dp), intent(inout) :: a(0_${ik}$:*) ! ===================================================================== ! Local Scalars logical(lk) :: lower, nisodd, normaltransr - integer(ilp) :: n1, n2, k + integer(${ik}$) :: n1, n2, k ! Intrinsic Functions intrinsic :: 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, 'C' ) ) 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 + info = -2_${ik}$ + else if( n<0_${ik}$ ) then + info = -3_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'ZPFTRI', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZPFTRI', -info ) return end if ! quick return if possible if( n==0 )return ! invert the triangular cholesky factor u or l. - call stdlib_ztftri( transr, uplo, 'N', n, a, info ) + call stdlib${ii}$_ztftri( transr, uplo, 'N', n, a, info ) if( info>0 )return ! if n is odd, set nisodd = .true. ! if n is even, set k = n/2 and nisodd = .false. - if( mod( n, 2 )==0 ) then - k = n / 2 + if( mod( n, 2_${ik}$ )==0_${ik}$ ) then + k = n / 2_${ik}$ nisodd = .false. else nisodd = .true. end if ! set n1 and n2 depending on lower if( lower ) then - n2 = n / 2 + n2 = n / 2_${ik}$ n1 = n - n2 else - n1 = n / 2 + n1 = n / 2_${ik}$ n2 = n - n1 end if ! start execution of triangular matrix multiply: inv(u)*inv(u)^c or @@ -61426,41 +61429,41 @@ module stdlib_linalg_lapack_z ! srpa for lower, normal and n is odd ( a(0:n-1,0:n1-1) ) ! t1 -> a(0,0), t2 -> a(0,1), s -> a(n1,0) ! t1 -> a(0), t2 -> a(n), s -> a(n1) - call stdlib_zlauum( 'L', n1, a( 0 ), n, info ) - call stdlib_zherk( 'L', 'C', n1, n2, one, a( n1 ), n, one,a( 0 ), n ) - call stdlib_ztrmm( 'L', 'U', 'N', 'N', n2, n1, cone, a( n ), n,a( n1 ), n ) + call stdlib${ii}$_zlauum( 'L', n1, a( 0_${ik}$ ), n, info ) + call stdlib${ii}$_zherk( 'L', 'C', n1, n2, one, a( n1 ), n, one,a( 0_${ik}$ ), n ) + call stdlib${ii}$_ztrmm( 'L', 'U', 'N', 'N', n2, n1, cone, a( n ), n,a( n1 ), n ) - call stdlib_zlauum( 'U', n2, a( n ), n, info ) + call stdlib${ii}$_zlauum( 'U', n2, a( n ), n, info ) else ! srpa for upper, normal and n is odd ( a(0:n-1,0:n2-1) ! t1 -> a(n1+1,0), t2 -> a(n1,0), s -> a(0,0) ! t1 -> a(n2), t2 -> a(n1), s -> a(0) - call stdlib_zlauum( 'L', n1, a( n2 ), n, info ) - call stdlib_zherk( 'L', 'N', n1, n2, one, a( 0 ), n, one,a( n2 ), n ) - call stdlib_ztrmm( 'R', 'U', 'C', 'N', n1, n2, cone, a( n1 ), n,a( 0 ), n ) + call stdlib${ii}$_zlauum( 'L', n1, a( n2 ), n, info ) + call stdlib${ii}$_zherk( 'L', 'N', n1, n2, one, a( 0_${ik}$ ), n, one,a( n2 ), n ) + call stdlib${ii}$_ztrmm( 'R', 'U', 'C', 'N', n1, n2, cone, a( n1 ), n,a( 0_${ik}$ ), n ) - call stdlib_zlauum( 'U', n2, a( n1 ), n, info ) + call stdlib${ii}$_zlauum( 'U', n2, a( n1 ), n, info ) end if else ! n is odd and transr = 'c' if( lower ) then ! srpa for lower, transpose, and n is odd ! t1 -> a(0), t2 -> a(1), s -> a(0+n1*n1) - call stdlib_zlauum( 'U', n1, a( 0 ), n1, info ) - call stdlib_zherk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0 ), n1 ) + call stdlib${ii}$_zlauum( 'U', n1, a( 0_${ik}$ ), n1, info ) + call stdlib${ii}$_zherk( 'U', 'N', n1, n2, one, a( n1*n1 ), n1, one,a( 0_${ik}$ ), n1 ) - call stdlib_ztrmm( 'R', 'L', 'N', 'N', n1, n2, cone, a( 1 ), n1,a( n1*n1 ), & + call stdlib${ii}$_ztrmm( 'R', 'L', 'N', 'N', n1, n2, cone, a( 1_${ik}$ ), n1,a( n1*n1 ), & n1 ) - call stdlib_zlauum( 'L', n2, a( 1 ), n1, info ) + call stdlib${ii}$_zlauum( 'L', n2, a( 1_${ik}$ ), n1, info ) else ! srpa for upper, transpose, and n is odd ! t1 -> a(0+n2*n2), t2 -> a(0+n1*n2), s -> a(0) - call stdlib_zlauum( 'U', n1, a( n2*n2 ), n2, info ) - call stdlib_zherk( 'U', 'C', n1, n2, one, a( 0 ), n2, one,a( n2*n2 ), n2 ) + call stdlib${ii}$_zlauum( 'U', n1, a( n2*n2 ), n2, info ) + call stdlib${ii}$_zherk( 'U', 'C', n1, n2, one, a( 0_${ik}$ ), n2, one,a( n2*n2 ), n2 ) - call stdlib_ztrmm( 'L', 'L', 'C', 'N', n2, n1, cone, a( n1*n2 ),n2, a( 0 ), & + call stdlib${ii}$_ztrmm( 'L', 'L', 'C', 'N', n2, n1, cone, a( n1*n2 ),n2, a( 0_${ik}$ ), & n2 ) - call stdlib_zlauum( 'L', n2, a( n1*n2 ), n2, info ) + call stdlib${ii}$_zlauum( 'L', n2, a( n1*n2 ), n2, info ) end if end if else @@ -61471,22 +61474,22 @@ module stdlib_linalg_lapack_z ! srpa for lower, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(1,0), t2 -> a(0,0), s -> a(k+1,0) ! t1 -> a(1), t2 -> a(0), s -> a(k+1) - call stdlib_zlauum( 'L', k, a( 1 ), n+1, info ) - call stdlib_zherk( 'L', 'C', k, k, one, a( k+1 ), n+1, one,a( 1 ), n+1 ) + call stdlib${ii}$_zlauum( 'L', k, a( 1_${ik}$ ), n+1, info ) + call stdlib${ii}$_zherk( 'L', 'C', k, k, one, a( k+1 ), n+1, one,a( 1_${ik}$ ), n+1 ) - call stdlib_ztrmm( 'L', 'U', 'N', 'N', k, k, cone, a( 0 ), n+1,a( k+1 ), n+1 ) + call stdlib${ii}$_ztrmm( 'L', 'U', 'N', 'N', k, k, cone, a( 0_${ik}$ ), n+1,a( k+1 ), n+1 ) - call stdlib_zlauum( 'U', k, a( 0 ), n+1, info ) + call stdlib${ii}$_zlauum( 'U', k, a( 0_${ik}$ ), n+1, info ) else ! srpa for upper, normal, and n is even ( a(0:n,0:k-1) ) ! t1 -> a(k+1,0) , t2 -> a(k,0), s -> a(0,0) ! t1 -> a(k+1), t2 -> a(k), s -> a(0) - call stdlib_zlauum( 'L', k, a( k+1 ), n+1, info ) - call stdlib_zherk( 'L', 'N', k, k, one, a( 0 ), n+1, one,a( k+1 ), n+1 ) + call stdlib${ii}$_zlauum( 'L', k, a( k+1 ), n+1, info ) + call stdlib${ii}$_zherk( 'L', 'N', k, k, one, a( 0_${ik}$ ), n+1, one,a( k+1 ), n+1 ) - call stdlib_ztrmm( 'R', 'U', 'C', 'N', k, k, cone, a( k ), n+1,a( 0 ), n+1 ) + call stdlib${ii}$_ztrmm( 'R', 'U', 'C', 'N', k, k, cone, a( k ), n+1,a( 0_${ik}$ ), n+1 ) - call stdlib_zlauum( 'U', k, a( k ), n+1, info ) + call stdlib${ii}$_zlauum( 'U', k, a( k ), n+1, info ) end if else ! n is even and transr = 'c' @@ -61494,30 +61497,30 @@ module stdlib_linalg_lapack_z ! srpa for lower, transpose, and n is even (see paper) ! t1 -> b(0,1), t2 -> b(0,0), s -> b(0,k+1), ! t1 -> a(0+k), t2 -> a(0+0), s -> a(0+k*(k+1)); lda=k - call stdlib_zlauum( 'U', k, a( k ), k, info ) - call stdlib_zherk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k ) + call stdlib${ii}$_zlauum( 'U', k, a( k ), k, info ) + call stdlib${ii}$_zherk( 'U', 'N', k, k, one, a( k*( k+1 ) ), k, one,a( k ), k ) - call stdlib_ztrmm( 'R', 'L', 'N', 'N', k, k, cone, a( 0 ), k,a( k*( k+1 ) ), & + call stdlib${ii}$_ztrmm( 'R', 'L', 'N', 'N', k, k, cone, a( 0_${ik}$ ), k,a( k*( k+1 ) ), & k ) - call stdlib_zlauum( 'L', k, a( 0 ), k, info ) + call stdlib${ii}$_zlauum( 'L', k, a( 0_${ik}$ ), k, info ) else ! srpa for upper, transpose, and n is even (see paper) ! t1 -> b(0,k+1), t2 -> b(0,k), s -> b(0,0), ! t1 -> a(0+k*(k+1)), t2 -> a(0+k*k), s -> a(0+0)); lda=k - call stdlib_zlauum( 'U', k, a( k*( k+1 ) ), k, info ) - call stdlib_zherk( 'U', 'C', k, k, one, a( 0 ), k, one,a( k*( k+1 ) ), k ) + call stdlib${ii}$_zlauum( 'U', k, a( k*( k+1 ) ), k, info ) + call stdlib${ii}$_zherk( 'U', 'C', k, k, one, a( 0_${ik}$ ), k, one,a( k*( k+1 ) ), k ) - call stdlib_ztrmm( 'L', 'L', 'C', 'N', k, k, cone, a( k*k ), k,a( 0 ), k ) + call stdlib${ii}$_ztrmm( 'L', 'L', 'C', 'N', k, k, cone, a( k*k ), k,a( 0_${ik}$ ), k ) - call stdlib_zlauum( 'L', k, a( k*k ), k, info ) + call stdlib${ii}$_zlauum( 'L', k, a( k*k ), k, info ) end if end if end if return - end subroutine stdlib_zpftri + end subroutine stdlib${ii}$_zpftri - pure subroutine stdlib_zposv( uplo, n, nrhs, a, lda, b, ldb, info ) + pure subroutine stdlib${ii}$_zposv( uplo, n, nrhs, a, lda, b, ldb, info ) !! ZPOSV computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N Hermitian positive definite matrix and X and B @@ -61533,8 +61536,8 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: a(lda,*), b(ldb,*) ! ===================================================================== @@ -61542,33 +61545,33 @@ module stdlib_linalg_lapack_z intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 + info = 0_${ik}$ if( .not.stdlib_lsame( uplo, 'U' ) .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 + info = -10_${ik}$ + else if( n>0_${ik}$ ) then scond = max( smin, smlnum ) / min( smax, bignum ) else scond = one end if end if - if( info==0 ) then - if( ldb0 )then + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_zlanhe( '1', uplo, n, a, lda, rwork ) + anorm = stdlib${ii}$_zlanhe( '1', uplo, n, a, lda, rwork ) ! compute the reciprocal of the condition number of a. - call stdlib_zpocon( uplo, n, af, ldaf, anorm, rcond, work, rwork, info ) + call stdlib${ii}$_zpocon( uplo, n, af, ldaf, anorm, rcond, work, rwork, info ) ! compute the solution matrix x. - call stdlib_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_zpotrs( uplo, n, nrhs, af, ldaf, x, ldx, info ) + call stdlib${ii}$_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_zpotrs( uplo, n, nrhs, af, ldaf, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_zporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x, ldx,ferr, berr, work, & + call stdlib${ii}$_zporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x, ldx,ferr, berr, work, & rwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -61707,12 +61710,12 @@ module stdlib_linalg_lapack_z end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcondeps .and. two*berr( j )<=lstres .and.count<=itmax ) then ! update solution and try again. - call stdlib_zpttrs( uplo, n, 1, df, ef, work, n, info ) - call stdlib_zaxpy( n, cmplx( one,KIND=dp), work, 1, x( 1, j ), 1 ) + call stdlib${ii}$_zpttrs( uplo, n, 1_${ik}$, df, ef, work, n, info ) + call stdlib${ii}$_zaxpy( n, cmplx( one,KIND=dp), work, 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 @@ -61899,7 +61902,7 @@ module stdlib_linalg_lapack_z rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +safe1 end if end do - ix = stdlib_idamax( n, rwork, 1 ) + ix = stdlib${ii}$_idamax( n, rwork, 1_${ik}$ ) ferr( j ) = rwork( ix ) ! estimate the norm of inv(a). ! solve m(a) * x = e, where m(a) = (m(i,j)) is given by @@ -61907,7 +61910,7 @@ module stdlib_linalg_lapack_z ! m(i,j) = -abs(a(i,j)), i .ne. j, ! and e = [ 1, 1, ..., 1 ]**t. note m(a) = m(l)*d*m(l)**h. ! solve m(l) * x = e. - rwork( 1 ) = one + rwork( 1_${ik}$ ) = one do i = 2, n rwork( i ) = one + rwork( i-1 )*abs( ef( i-1 ) ) end do @@ -61917,7 +61920,7 @@ module stdlib_linalg_lapack_z rwork( i ) = rwork( i ) / df( i ) +rwork( i+1 )*abs( ef( i ) ) end do ! compute norm(inv(a)) = max(x(i)), 1<=i<=n. - ix = stdlib_idamax( n, rwork, 1 ) + ix = stdlib${ii}$_idamax( n, rwork, 1_${ik}$ ) ferr( j ) = ferr( j )*abs( rwork( ix ) ) ! normalize error. lstres = zero @@ -61927,10 +61930,10 @@ module stdlib_linalg_lapack_z if( lstres/=zero )ferr( j ) = ferr( j ) / lstres end do loop_100 return - end subroutine stdlib_zptrfs + end subroutine stdlib${ii}$_zptrfs - pure subroutine stdlib_zptsv( n, nrhs, d, e, b, ldb, info ) + pure subroutine stdlib${ii}$_zptsv( n, nrhs, d, e, b, ldb, info ) !! ZPTSV computes the solution to a complex system of linear equations !! A*X = B, where A is an N-by-N Hermitian positive definite tridiagonal !! matrix, and X and B are N-by-NRHS matrices. @@ -61940,8 +61943,8 @@ module stdlib_linalg_lapack_z ! -- 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) :: ldb, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldb, n, nrhs ! Array Arguments real(dp), intent(inout) :: d(*) complex(dp), intent(inout) :: b(ldb,*), e(*) @@ -61950,29 +61953,29 @@ module stdlib_linalg_lapack_z intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 - if( n<0 ) then - info = -1 - else if( nrhs<0 ) then - info = -2 - else if( ldb1 )call stdlib_zcopy( n-1, e, 1, ef, 1 ) - call stdlib_zpttrf( n, df, ef, info ) + call stdlib${ii}$_dcopy( n, d, 1_${ik}$, df, 1_${ik}$ ) + if( n>1_${ik}$ )call stdlib${ii}$_zcopy( n-1, e, 1_${ik}$, ef, 1_${ik}$ ) + call stdlib${ii}$_zpttrf( n, df, ef, info ) ! return if info is non-zero. - if( info>0 )then + if( info>0_${ik}$ )then rcond = zero return end if end if ! compute the norm of the matrix a. - anorm = stdlib_zlanht( '1', n, d, e ) + anorm = stdlib${ii}$_zlanht( '1', n, d, e ) ! compute the reciprocal of the condition number of a. - call stdlib_zptcon( n, df, ef, anorm, rcond, rwork, info ) + call stdlib${ii}$_zptcon( n, df, ef, anorm, rcond, rwork, info ) ! compute the solution vectors x. - call stdlib_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_zpttrs( 'LOWER', n, nrhs, df, ef, x, ldx, info ) + call stdlib${ii}$_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_zpttrs( 'LOWER', n, nrhs, df, ef, x, ldx, info ) ! use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. - call stdlib_zptrfs( 'LOWER', n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr,berr, work, & + call stdlib${ii}$_zptrfs( 'LOWER', n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr,berr, work, & rwork, info ) ! set info = n+1 if the matrix is singular to working precision. - if( rcond0 .and. ldz0_${ik}$ .and. ldztiny ) then - finish = finish + 1 + finish = finish + 1_${ik}$ go to 40 end if end if ! (sub) problem determined. compute its size and solve it. - m = finish - start + 1 + m = finish - start + 1_${ik}$ if( m>smlsiz ) then ! scale. - orgnrm = stdlib_dlanst( 'M', m, d( start ), e( start ) ) - call stdlib_dlascl( 'G', 0, 0, orgnrm, one, m, 1, d( start ), m,info ) - call stdlib_dlascl( 'G', 0, 0, orgnrm, one, m-1, 1, e( start ),m-1, info ) + orgnrm = stdlib${ii}$_dlanst( 'M', m, d( start ), e( start ) ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, m, 1_${ik}$, d( start ), m,info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, orgnrm, one, m-1, 1_${ik}$, e( start ),m-1, info ) - call stdlib_zlaed0( n, m, d( start ), e( start ), z( 1, start ),ldz, work, n, & + call stdlib${ii}$_zlaed0( n, m, d( start ), e( start ), z( 1_${ik}$, start ),ldz, work, n, & rwork, iwork, info ) - if( info>0 ) then + if( info>0_${ik}$ ) then info = ( info / ( m+1 )+start-1 )*( n+1 ) +mod( info, ( m+1 ) ) + start - & - 1 + 1_${ik}$ go to 70 end if ! scale back. - call stdlib_dlascl( 'G', 0, 0, one, orgnrm, m, 1, d( start ), m,info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, one, orgnrm, m, 1_${ik}$, d( start ), m,info ) else - call stdlib_dsteqr( 'I', m, d( start ), e( start ), rwork, m,rwork( m*m+1 ), & + call stdlib${ii}$_dsteqr( 'I', m, d( start ), e( start ), rwork, m,rwork( m*m+1 ), & info ) - call stdlib_zlacrm( n, m, z( 1, start ), ldz, rwork, m, work, n,rwork( m*m+1 )& + call stdlib${ii}$_zlacrm( n, m, z( 1_${ik}$, start ), ldz, rwork, m, work, n,rwork( m*m+1 )& ) - call stdlib_zlacpy( 'A', n, m, work, n, z( 1, start ), ldz ) - if( info>0 ) then + call stdlib${ii}$_zlacpy( 'A', n, m, work, n, z( 1_${ik}$, start ), ldz ) + if( info>0_${ik}$ ) then info = start*( n+1 ) + finish go to 70 end if end if - start = finish + 1 + start = finish + 1_${ik}$ go to 30 end if ! endwhile ! use selection sort to minimize swaps of eigenvectors do ii = 2, n - i = ii - 1 + i = ii - 1_${ik}$ k = i p = d( i ) do j = ii, n @@ -62251,19 +62254,19 @@ module stdlib_linalg_lapack_z if( k/=i ) then d( k ) = d( i ) d( i ) = p - call stdlib_zswap( n, z( 1, i ), 1, z( 1, k ), 1 ) + call stdlib${ii}$_zswap( n, z( 1_${ik}$, i ), 1_${ik}$, z( 1_${ik}$, k ), 1_${ik}$ ) end if end do end if 70 continue - work( 1 ) = lwmin - rwork( 1 ) = lrwmin - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = lwmin + rwork( 1_${ik}$ ) = lrwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_zstedc + end subroutine stdlib${ii}$_zstedc - pure subroutine stdlib_zstegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, & + pure subroutine stdlib${ii}$_zstegr( jobz, range, n, d, e, vl, vu, il, iu,abstol, m, w, z, ldz, & !! ZSTEGR computes selected eigenvalues and, optionally, eigenvectors !! of a real symmetric tridiagonal matrix T. Any such unreduced matrix has !! a well defined set of pairwise different real eigenvalues, the corresponding @@ -62286,11 +62289,11 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range - integer(ilp), intent(in) :: il, iu, ldz, liwork, lwork, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, iu, ldz, liwork, lwork, n + integer(${ik}$), intent(out) :: info, m real(dp), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: isuppz(*), iwork(*) + integer(${ik}$), intent(out) :: isuppz(*), iwork(*) real(dp), intent(inout) :: d(*), e(*) real(dp), intent(out) :: w(*), work(*) complex(dp), intent(out) :: z(ldz,*) @@ -62298,14 +62301,14 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: tryrac ! Executable Statements - info = 0 + info = 0_${ik}$ tryrac = .false. - call stdlib_zstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, n, isuppz, & + call stdlib${ii}$_zstemr( jobz, range, n, d, e, vl, vu, il, iu,m, w, z, ldz, n, isuppz, & tryrac, work, lwork,iwork, liwork, info ) - end subroutine stdlib_zstegr + end subroutine stdlib${ii}$_zstegr - pure subroutine stdlib_ztgsen( ijob, wantq, wantz, select, n, a, lda, b, ldb,alpha, beta, q, & + pure subroutine stdlib${ii}$_ztgsen( ijob, wantq, wantz, select, n, a, lda, b, ldb,alpha, beta, q, & !! ZTGSEN reorders the generalized Schur decomposition of a complex !! matrix pair (A, B) (in terms of an unitary equivalence trans- !! formation Q**H * (A, B) * Z), so that a selected cluster of eigenvalues @@ -62330,94 +62333,94 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments logical(lk), intent(in) :: wantq, wantz - integer(ilp), intent(in) :: ijob, lda, ldb, ldq, ldz, liwork, lwork, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: ijob, lda, ldb, ldq, ldz, liwork, lwork, n + integer(${ik}$), intent(out) :: info, m real(dp), intent(out) :: pl, pr ! Array Arguments logical(lk), intent(in) :: select(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(out) :: dif(*) complex(dp), intent(inout) :: a(lda,*), b(ldb,*), q(ldq,*), z(ldz,*) complex(dp), intent(out) :: alpha(*), beta(*), work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: idifjb = 3 + integer(${ik}$), parameter :: idifjb = 3_${ik}$ ! Local Scalars logical(lk) :: lquery, swap, wantd, wantd1, wantd2, wantp - integer(ilp) :: i, ierr, ijb, k, kase, ks, liwmin, lwmin, mn2, n1, n2 + integer(${ik}$) :: i, ierr, ijb, k, kase, ks, liwmin, lwmin, mn2, n1, n2 real(dp) :: dscale, dsum, rdscal, safmin complex(dp) :: temp1, temp2 ! Local Arrays - integer(ilp) :: isave(3) + integer(${ik}$) :: isave(3_${ik}$) ! Intrinsic Functions intrinsic :: abs,cmplx,conjg,max,sqrt ! Executable Statements ! decode and test the input parameters - info = 0 - lquery = ( lwork==-1 .or. liwork==-1 ) - if( ijob<0 .or. ijob>5 ) then - info = -1 - else if( n<0 ) then - info = -5 - else if( lda=4 - wantd1 = ijob==2 .or. ijob==4 - wantd2 = ijob==3 .or. ijob==5 + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) + if( ijob<0_${ik}$ .or. ijob>5_${ik}$ ) then + info = -1_${ik}$ + else if( n<0_${ik}$ ) then + info = -5_${ik}$ + else if( lda=4_${ik}$ + wantd1 = ijob==2_${ik}$ .or. ijob==4_${ik}$ + wantd2 = ijob==3_${ik}$ .or. ijob==5_${ik}$ wantd = wantd1 .or. wantd2 ! set m to the dimension of the specified pair of deflating ! subspaces. - m = 0 - if( .not.lquery .or. ijob/=0 ) then + m = 0_${ik}$ + if( .not.lquery .or. ijob/=0_${ik}$ ) then do k = 1, n alpha( k ) = a( k, k ) beta( k ) = b( k, k ) if( k0 ) then + if( ierr>0_${ik}$ ) then ! swap is rejected: exit. - info = 1 + info = 1_${ik}$ if( wantp ) then pl = zero pr = zero end if if( wantd ) then - dif( 1 ) = zero - dif( 2 ) = zero + dif( 1_${ik}$ ) = zero + dif( 2_${ik}$ ) = zero end if go to 70 end if @@ -62467,18 +62470,18 @@ module stdlib_linalg_lapack_z ! b11 * r - l * b22 = b12 n1 = m n2 = n - m - i = n1 + 1 - call stdlib_zlacpy( 'FULL', n1, n2, a( 1, i ), lda, work, n1 ) - call stdlib_zlacpy( 'FULL', n1, n2, b( 1, i ), ldb, work( n1*n2+1 ),n1 ) - ijb = 0 - call stdlib_ztgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b( i,& - i ), ldb, work( n1*n2+1 ), n1,dscale, dif( 1 ), work( n1*n2*2+1 ),lwork-2*n1*n2, & + i = n1 + 1_${ik}$ + call stdlib${ii}$_zlacpy( 'FULL', n1, n2, a( 1_${ik}$, i ), lda, work, n1 ) + call stdlib${ii}$_zlacpy( 'FULL', n1, n2, b( 1_${ik}$, i ), ldb, work( n1*n2+1 ),n1 ) + ijb = 0_${ik}$ + call stdlib${ii}$_ztgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b( i,& + i ), ldb, work( n1*n2+1 ), n1,dscale, dif( 1_${ik}$ ), work( n1*n2*2_${ik}$+1 ),lwork-2*n1*n2, & iwork, ierr ) ! estimate the reciprocal of norms of "projections" onto ! left and right eigenspaces rdscal = zero dsum = one - call stdlib_zlassq( n1*n2, work, 1, rdscal, dsum ) + call stdlib${ii}$_zlassq( n1*n2, work, 1_${ik}$, rdscal, dsum ) pl = rdscal*sqrt( dsum ) if( pl==zero ) then pl = one @@ -62487,7 +62490,7 @@ module stdlib_linalg_lapack_z end if rdscal = zero dsum = one - call stdlib_zlassq( n1*n2, work( n1*n2+1 ), 1, rdscal, dsum ) + call stdlib${ii}$_zlassq( n1*n2, work( n1*n2+1 ), 1_${ik}$, rdscal, dsum ) pr = rdscal*sqrt( dsum ) if( pr==zero ) then pr = one @@ -62500,63 +62503,63 @@ module stdlib_linalg_lapack_z if( wantd1 ) then n1 = m n2 = n - m - i = n1 + 1 + i = n1 + 1_${ik}$ ijb = idifjb ! frobenius norm-based difu estimate. - call stdlib_ztgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b(& - i, i ), ldb, work( n1*n2+1 ),n1, dscale, dif( 1 ), work( n1*n2*2+1 ),lwork-& - 2*n1*n2, iwork, ierr ) + call stdlib${ii}$_ztgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work,n1, b, ldb, b(& + i, i ), ldb, work( n1*n2+1 ),n1, dscale, dif( 1_${ik}$ ), work( n1*n2*2_${ik}$+1 ),lwork-& + 2_${ik}$*n1*n2, iwork, ierr ) ! frobenius norm-based difl estimate. - call stdlib_ztgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda, work,n2, b( i, i ),& - ldb, b, ldb, work( n1*n2+1 ),n2, dscale, dif( 2 ), work( n1*n2*2+1 ),lwork-& - 2*n1*n2, iwork, ierr ) + call stdlib${ii}$_ztgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda, work,n2, b( i, i ),& + ldb, b, ldb, work( n1*n2+1 ),n2, dscale, dif( 2_${ik}$ ), work( n1*n2*2_${ik}$+1 ),lwork-& + 2_${ik}$*n1*n2, iwork, ierr ) else ! compute 1-norm-based estimates of difu and difl using - ! reversed communication with stdlib_zlacn2. in each step a + ! reversed communication with stdlib${ii}$_zlacn2. in each step a ! generalized sylvester equation or a transposed variant ! is solved. - kase = 0 + kase = 0_${ik}$ n1 = m n2 = n - m - i = n1 + 1 - ijb = 0 - mn2 = 2*n1*n2 + i = n1 + 1_${ik}$ + ijb = 0_${ik}$ + mn2 = 2_${ik}$*n1*n2 ! 1-norm-based estimate of difu. 40 continue - call stdlib_zlacn2( mn2, work( mn2+1 ), work, dif( 1 ), kase,isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_zlacn2( mn2, work( mn2+1 ), work, dif( 1_${ik}$ ), kase,isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! solve generalized sylvester equation - call stdlib_ztgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & - ldb, b( i, i ), ldb,work( n1*n2+1 ), n1, dscale, dif( 1 ),work( n1*n2*2+1 )& + call stdlib${ii}$_ztgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & + ldb, b( i, i ), ldb,work( n1*n2+1 ), n1, dscale, dif( 1_${ik}$ ),work( n1*n2*2_${ik}$+1 )& , lwork-2*n1*n2, iwork,ierr ) else ! solve the transposed variant. - call stdlib_ztgsyl( 'C', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & - ldb, b( i, i ), ldb,work( n1*n2+1 ), n1, dscale, dif( 1 ),work( n1*n2*2+1 )& + call stdlib${ii}$_ztgsyl( 'C', ijb, n1, n2, a, lda, a( i, i ), lda,work, n1, b, & + ldb, b( i, i ), ldb,work( n1*n2+1 ), n1, dscale, dif( 1_${ik}$ ),work( n1*n2*2_${ik}$+1 )& , lwork-2*n1*n2, iwork,ierr ) end if go to 40 end if - dif( 1 ) = dscale / dif( 1 ) + dif( 1_${ik}$ ) = dscale / dif( 1_${ik}$ ) ! 1-norm-based estimate of difl. 50 continue - call stdlib_zlacn2( mn2, work( mn2+1 ), work, dif( 2 ), kase,isave ) - if( kase/=0 ) then - if( kase==1 ) then + call stdlib${ii}$_zlacn2( mn2, work( mn2+1 ), work, dif( 2_${ik}$ ), kase,isave ) + if( kase/=0_${ik}$ ) then + if( kase==1_${ik}$ ) then ! solve generalized sylvester equation - call stdlib_ztgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b( & - i, i ), ldb, b, ldb,work( n1*n2+1 ), n2, dscale, dif( 2 ),work( n1*n2*2+1 )& + call stdlib${ii}$_ztgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b( & + i, i ), ldb, b, ldb,work( n1*n2+1 ), n2, dscale, dif( 2_${ik}$ ),work( n1*n2*2_${ik}$+1 )& , lwork-2*n1*n2, iwork,ierr ) else ! solve the transposed variant. - call stdlib_ztgsyl( 'C', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b, & - ldb, b( i, i ), ldb,work( n1*n2+1 ), n2, dscale, dif( 2 ),work( n1*n2*2+1 )& + call stdlib${ii}$_ztgsyl( 'C', ijb, n2, n1, a( i, i ), lda, a, lda,work, n2, b, & + ldb, b( i, i ), ldb,work( n1*n2+1 ), n2, dscale, dif( 2_${ik}$ ),work( n1*n2*2_${ik}$+1 )& , lwork-2*n1*n2, iwork,ierr ) end if go to 50 end if - dif( 2 ) = dscale / dif( 2 ) + dif( 2_${ik}$ ) = dscale / dif( 2_${ik}$ ) end if end if ! if b(k,k) is complex, make it real and positive (normalization @@ -62568,9 +62571,9 @@ module stdlib_linalg_lapack_z temp1 = conjg( b( k, k ) / dscale ) temp2 = b( k, k ) / dscale b( k, k ) = dscale - call stdlib_zscal( n-k, temp1, b( k, k+1 ), ldb ) - call stdlib_zscal( n-k+1, temp1, a( k, k ), lda ) - if( wantq )call stdlib_zscal( n, temp2, q( 1, k ), 1 ) + call stdlib${ii}$_zscal( n-k, temp1, b( k, k+1 ), ldb ) + call stdlib${ii}$_zscal( n-k+1, temp1, a( k, k ), lda ) + if( wantq )call stdlib${ii}$_zscal( n, temp2, q( 1_${ik}$, k ), 1_${ik}$ ) else b( k, k ) = cmplx( zero, zero,KIND=dp) end if @@ -62578,13 +62581,13 @@ module stdlib_linalg_lapack_z beta( k ) = b( k, k ) end do 70 continue - work( 1 ) = lwmin - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = lwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_ztgsen + end subroutine stdlib${ii}$_ztgsen - pure subroutine stdlib_ztgsna( job, howmny, select, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, s, & + pure subroutine stdlib${ii}$_ztgsna( job, howmny, select, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, s, & !! ZTGSNA estimates reciprocal condition numbers for specified !! eigenvalues and/or eigenvectors of a matrix pair (A, B). !! (A, B) must be in generalized Schur canonical form, that is, A and @@ -62595,26 +62598,26 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: howmny, job - integer(ilp), intent(out) :: info, m - integer(ilp), intent(in) :: lda, ldb, ldvl, ldvr, lwork, mm, n + integer(${ik}$), intent(out) :: info, m + integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, mm, n ! Array Arguments logical(lk), intent(in) :: select(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(out) :: dif(*), s(*) complex(dp), intent(in) :: a(lda,*), b(ldb,*), vl(ldvl,*), vr(ldvr,*) complex(dp), intent(out) :: work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: idifjb = 3 + integer(${ik}$), parameter :: idifjb = 3_${ik}$ ! Local Scalars logical(lk) :: lquery, somcon, wantbh, wantdf, wants - integer(ilp) :: i, ierr, ifst, ilst, k, ks, lwmin, n1, n2 + integer(${ik}$) :: i, ierr, ifst, ilst, k, ks, lwmin, n1, n2 real(dp) :: bignum, cond, eps, lnrm, rnrm, scale, smlnum complex(dp) :: yhax, yhbx ! Local Arrays - complex(dp) :: dummy(1), dummy1(1) + complex(dp) :: dummy(1_${ik}$), dummy1(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,cmplx,max ! Executable Statements @@ -62623,49 +62626,49 @@ module stdlib_linalg_lapack_z wants = stdlib_lsame( job, 'E' ) .or. wantbh wantdf = stdlib_lsame( job, 'V' ) .or. wantbh somcon = stdlib_lsame( howmny, 'S' ) - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) if( .not.wants .and. .not.wantdf ) then - info = -1 + info = -1_${ik}$ else if( .not.stdlib_lsame( howmny, 'A' ) .and. .not.somcon ) then - info = -2 - else if( n<0 ) then - info = -4 - else if( lda0 ) then + ilst = 1_${ik}$ + call stdlib${ii}$_ztgexc( .false., .false., n, work, n, work( n*n+1 ),n, dummy, 1_${ik}$, & + dummy1, 1_${ik}$, ifst, ilst, ierr ) + if( ierr>0_${ik}$ ) then ! ill-conditioned problem - swap rejected. dif( ks ) = zero else @@ -62726,22 +62729,22 @@ module stdlib_linalg_lapack_z ! a22 * r - l * a11 = a12 ! b22 * r - l * b11 = b12, ! and compute estimate of difl[(a11,b11), (a22, b22)]. - n1 = 1 + n1 = 1_${ik}$ n2 = n - n1 - i = n*n + 1 - call stdlib_ztgsyl( 'N', idifjb, n2, n1, work( n*n1+n1+1 ),n, work, n, & + i = n*n + 1_${ik}$ + call stdlib${ii}$_ztgsyl( 'N', idifjb, n2, n1, work( n*n1+n1+1 ),n, work, n, & work( n1+1 ), n,work( n*n1+n1+i ), n, work( i ), n,work( n1+i ), n, scale, & - dif( ks ), dummy,1, iwork, ierr ) + dif( ks ), dummy,1_${ik}$, iwork, ierr ) end if end if end if end do loop_20 - work( 1 ) = lwmin + work( 1_${ik}$ ) = lwmin return - end subroutine stdlib_ztgsna + end subroutine stdlib${ii}$_ztgsna - subroutine stdlib_ztrsen( job, compq, select, n, t, ldt, q, ldq, w, m, s,sep, work, lwork, & + subroutine stdlib${ii}$_ztrsen( job, compq, select, n, t, ldt, q, ldq, w, m, s,sep, work, lwork, & !! ZTRSEN reorders the Schur factorization of a complex matrix !! A = Q*T*Q**H, so that a selected cluster of eigenvalues appears in !! the leading positions on the diagonal of the upper triangular matrix @@ -62755,8 +62758,8 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: compq, job - integer(ilp), intent(out) :: info, m - integer(ilp), intent(in) :: ldq, ldt, lwork, n + integer(${ik}$), intent(out) :: info, m + integer(${ik}$), intent(in) :: ldq, ldt, lwork, n real(dp), intent(out) :: s, sep ! Array Arguments logical(lk), intent(in) :: select(*) @@ -62766,11 +62769,11 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: lquery, wantbh, wantq, wants, wantsp - integer(ilp) :: ierr, k, kase, ks, lwmin, n1, n2, nn + integer(${ik}$) :: ierr, k, kase, ks, lwmin, n1, n2, nn real(dp) :: est, rnorm, scale ! Local Arrays - integer(ilp) :: isave(3) - real(dp) :: rwork(1) + integer(${ik}$) :: isave(3_${ik}$) + real(dp) :: rwork(1_${ik}$) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements @@ -62780,68 +62783,68 @@ module stdlib_linalg_lapack_z wantsp = stdlib_lsame( job, 'V' ) .or. wantbh wantq = stdlib_lsame( compq, 'V' ) ! set m to the number of selected eigenvalues. - m = 0 + m = 0_${ik}$ do k = 1, n - if( select( k ) )m = m + 1 + if( select( k ) )m = m + 1_${ik}$ end do n1 = m n2 = n - m nn = n1*n2 - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) if( wantsp ) then - lwmin = max( 1, 2*nn ) + lwmin = max( 1_${ik}$, 2_${ik}$*nn ) else if( stdlib_lsame( job, 'N' ) ) then - lwmin = 1 + lwmin = 1_${ik}$ else if( stdlib_lsame( job, 'E' ) ) then - lwmin = max( 1, nn ) + lwmin = max( 1_${ik}$, nn ) end if if( .not.stdlib_lsame( job, 'N' ) .and. .not.wants .and. .not.wantsp )then - info = -1 + info = -1_${ik}$ else if( .not.stdlib_lsame( compq, 'N' ) .and. .not.wantq ) then - info = -2 - else if( n<0 ) then - info = -4 - else if( ldt m-p ) then - info = -2 - else if( q < 0 .or. q < p .or. m-q < p ) then - info = -3 - else if( ldx11 < max( 1, p ) ) then - info = -5 - else if( ldx21 < max( 1, m-p ) ) then - info = -7 + info = 0_${ik}$ + lquery = lwork == -1_${ik}$ + if( m < 0_${ik}$ ) then + info = -1_${ik}$ + else if( p < 0_${ik}$ .or. p > m-p ) then + info = -2_${ik}$ + else if( q < 0_${ik}$ .or. q < p .or. m-q < p ) then + info = -3_${ik}$ + else if( ldx11 < max( 1_${ik}$, p ) ) then + info = -5_${ik}$ + else if( ldx21 < max( 1_${ik}$, m-p ) ) then + info = -7_${ik}$ end if ! compute workspace - if( info == 0 ) then - ilarf = 2 + if( info == 0_${ik}$ ) then + ilarf = 2_${ik}$ llarf = max( p-1, m-p, q-1 ) - iorbdb5 = 2 + iorbdb5 = 2_${ik}$ lorbdb5 = q-1 lworkopt = max( ilarf+llarf-1, iorbdb5+lorbdb5-1 ) lworkmin = lworkopt - work(1) = lworkopt + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not.lquery ) then - info = -14 + info = -14_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'ZUNBDB2', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZUNBDB2', -info ) return else if( lquery ) then return end if ! reduce rows 1, ..., p of x11 and x21 do i = 1, p - if( i > 1 ) then - call stdlib_zdrot( q-i+1, x11(i,i), ldx11, x21(i-1,i), ldx21, c,s ) + if( i > 1_${ik}$ ) then + call stdlib${ii}$_zdrot( q-i+1, x11(i,i), ldx11, x21(i-1,i), ldx21, c,s ) end if - call stdlib_zlacgv( q-i+1, x11(i,i), ldx11 ) - call stdlib_zlarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) + call stdlib${ii}$_zlacgv( q-i+1, x11(i,i), ldx11 ) + call stdlib${ii}$_zlarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) c = real( x11(i,i),KIND=dp) x11(i,i) = cone - call stdlib_zlarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & + call stdlib${ii}$_zlarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & work(ilarf) ) - call stdlib_zlarf( 'R', m-p-i+1, q-i+1, x11(i,i), ldx11, tauq1(i),x21(i,i), ldx21, & + call stdlib${ii}$_zlarf( 'R', m-p-i+1, q-i+1, x11(i,i), ldx11, tauq1(i),x21(i,i), ldx21, & work(ilarf) ) - call stdlib_zlacgv( q-i+1, x11(i,i), ldx11 ) - s = sqrt( stdlib_dznrm2( p-i, x11(i+1,i), 1 )**2+ stdlib_dznrm2( m-p-i+1, x21(i,i), & - 1 )**2 ) + call stdlib${ii}$_zlacgv( q-i+1, x11(i,i), ldx11 ) + s = sqrt( stdlib${ii}$_dznrm2( p-i, x11(i+1,i), 1_${ik}$ )**2_${ik}$+ stdlib${ii}$_dznrm2( m-p-i+1, x21(i,i), & + 1_${ik}$ )**2_${ik}$ ) theta(i) = atan2( s, c ) - call stdlib_zunbdb5( p-i, m-p-i+1, q-i, x11(i+1,i), 1, x21(i,i), 1,x11(i+1,i+1), & + call stdlib${ii}$_zunbdb5( p-i, m-p-i+1, q-i, x11(i+1,i), 1_${ik}$, x21(i,i), 1_${ik}$,x11(i+1,i+1), & ldx11, x21(i,i+1), ldx21,work(iorbdb5), lorbdb5, childinfo ) - call stdlib_zscal( p-i, cnegone, x11(i+1,i), 1 ) - call stdlib_zlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) ) + call stdlib${ii}$_zscal( p-i, cnegone, x11(i+1,i), 1_${ik}$ ) + call stdlib${ii}$_zlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1_${ik}$, taup2(i) ) if( i < p ) then - call stdlib_zlarfgp( p-i, x11(i+1,i), x11(i+2,i), 1, taup1(i) ) + call stdlib${ii}$_zlarfgp( p-i, x11(i+1,i), x11(i+2,i), 1_${ik}$, taup1(i) ) phi(i) = atan2( real( x11(i+1,i),KIND=dp), real( x21(i,i),KIND=dp) ) c = cos( phi(i) ) s = sin( phi(i) ) x11(i+1,i) = cone - call stdlib_zlarf( 'L', p-i, q-i, x11(i+1,i), 1, conjg(taup1(i)),x11(i+1,i+1), & + call stdlib${ii}$_zlarf( 'L', p-i, q-i, x11(i+1,i), 1_${ik}$, conjg(taup1(i)),x11(i+1,i+1), & ldx11, work(ilarf) ) end if x21(i,i) = cone - call stdlib_zlarf( 'L', m-p-i+1, q-i, x21(i,i), 1, conjg(taup2(i)),x21(i,i+1), & + call stdlib${ii}$_zlarf( 'L', m-p-i+1, q-i, x21(i,i), 1_${ik}$, conjg(taup2(i)),x21(i,i+1), & ldx21, work(ilarf) ) end do ! reduce the bottom-right portion of x21 to the identity matrix do i = p + 1, q - call stdlib_zlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1, taup2(i) ) + call stdlib${ii}$_zlarfgp( m-p-i+1, x21(i,i), x21(i+1,i), 1_${ik}$, taup2(i) ) x21(i,i) = cone - call stdlib_zlarf( 'L', m-p-i+1, q-i, x21(i,i), 1, conjg(taup2(i)),x21(i,i+1), & + call stdlib${ii}$_zlarf( 'L', m-p-i+1, q-i, x21(i,i), 1_${ik}$, conjg(taup2(i)),x21(i,i+1), & ldx21, work(ilarf) ) end do return - end subroutine stdlib_zunbdb2 + end subroutine stdlib${ii}$_zunbdb2 - subroutine stdlib_zunbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & + subroutine stdlib${ii}$_zunbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & !! ZUNBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny !! matrix X with orthonomal columns: !! [ B11 ] @@ -63119,8 +63122,8 @@ module stdlib_linalg_lapack_z ! -- 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) :: lwork, m, p, q, ldx11, ldx21 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork, m, p, q, ldx11, ldx21 ! Array Arguments real(dp), intent(out) :: phi(*), theta(*) complex(dp), intent(out) :: taup1(*), taup2(*), tauq1(*), work(*) @@ -63129,90 +63132,90 @@ module stdlib_linalg_lapack_z ! Local Scalars real(dp) :: c, s - integer(ilp) :: childinfo, i, ilarf, iorbdb5, llarf, lorbdb5, lworkmin, & + integer(${ik}$) :: childinfo, i, ilarf, iorbdb5, llarf, lorbdb5, lworkmin, & lworkopt logical(lk) :: lquery ! Intrinsic Function intrinsic :: atan2,cos,max,sin,sqrt ! Executable Statements ! test input arguments - info = 0 - lquery = lwork == -1 - if( m < 0 ) then - info = -1 - else if( 2*p < m .or. p > m ) then - info = -2 + info = 0_${ik}$ + lquery = lwork == -1_${ik}$ + if( m < 0_${ik}$ ) then + info = -1_${ik}$ + else if( 2_${ik}$*p < m .or. p > m ) then + info = -2_${ik}$ else if( q < m-p .or. m-q < m-p ) then - info = -3 - else if( ldx11 < max( 1, p ) ) then - info = -5 - else if( ldx21 < max( 1, m-p ) ) then - info = -7 + info = -3_${ik}$ + else if( ldx11 < max( 1_${ik}$, p ) ) then + info = -5_${ik}$ + else if( ldx21 < max( 1_${ik}$, m-p ) ) then + info = -7_${ik}$ end if ! compute workspace - if( info == 0 ) then - ilarf = 2 + if( info == 0_${ik}$ ) then + ilarf = 2_${ik}$ llarf = max( p, m-p-1, q-1 ) - iorbdb5 = 2 + iorbdb5 = 2_${ik}$ lorbdb5 = q-1 lworkopt = max( ilarf+llarf-1, iorbdb5+lorbdb5-1 ) lworkmin = lworkopt - work(1) = lworkopt + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not.lquery ) then - info = -14 + info = -14_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'ZUNBDB3', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZUNBDB3', -info ) return else if( lquery ) then return end if ! reduce rows 1, ..., m-p of x11 and x21 do i = 1, m-p - if( i > 1 ) then - call stdlib_zdrot( q-i+1, x11(i-1,i), ldx11, x21(i,i), ldx11, c,s ) + if( i > 1_${ik}$ ) then + call stdlib${ii}$_zdrot( q-i+1, x11(i-1,i), ldx11, x21(i,i), ldx11, c,s ) end if - call stdlib_zlacgv( q-i+1, x21(i,i), ldx21 ) - call stdlib_zlarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) + call stdlib${ii}$_zlacgv( q-i+1, x21(i,i), ldx21 ) + call stdlib${ii}$_zlarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) s = real( x21(i,i),KIND=dp) x21(i,i) = cone - call stdlib_zlarf( 'R', p-i+1, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i,i), ldx11, & + call stdlib${ii}$_zlarf( 'R', p-i+1, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i,i), ldx11, & work(ilarf) ) - call stdlib_zlarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & + call stdlib${ii}$_zlarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & work(ilarf) ) - call stdlib_zlacgv( q-i+1, x21(i,i), ldx21 ) - c = sqrt( stdlib_dznrm2( p-i+1, x11(i,i), 1 )**2+ stdlib_dznrm2( m-p-i, x21(i+1,i), & - 1 )**2 ) + call stdlib${ii}$_zlacgv( q-i+1, x21(i,i), ldx21 ) + c = sqrt( stdlib${ii}$_dznrm2( p-i+1, x11(i,i), 1_${ik}$ )**2_${ik}$+ stdlib${ii}$_dznrm2( m-p-i, x21(i+1,i), & + 1_${ik}$ )**2_${ik}$ ) theta(i) = atan2( s, c ) - call stdlib_zunbdb5( p-i+1, m-p-i, q-i, x11(i,i), 1, x21(i+1,i), 1,x11(i,i+1), & + call stdlib${ii}$_zunbdb5( p-i+1, m-p-i, q-i, x11(i,i), 1_${ik}$, x21(i+1,i), 1_${ik}$,x11(i,i+1), & ldx11, x21(i+1,i+1), ldx21,work(iorbdb5), lorbdb5, childinfo ) - call stdlib_zlarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) + call stdlib${ii}$_zlarfgp( p-i+1, x11(i,i), x11(i+1,i), 1_${ik}$, taup1(i) ) if( i < m-p ) then - call stdlib_zlarfgp( m-p-i, x21(i+1,i), x21(i+2,i), 1, taup2(i) ) + call stdlib${ii}$_zlarfgp( m-p-i, x21(i+1,i), x21(i+2,i), 1_${ik}$, taup2(i) ) phi(i) = atan2( real( x21(i+1,i),KIND=dp), real( x11(i,i),KIND=dp) ) c = cos( phi(i) ) s = sin( phi(i) ) x21(i+1,i) = cone - call stdlib_zlarf( 'L', m-p-i, q-i, x21(i+1,i), 1,conjg(taup2(i)), x21(i+1,i+1), & + call stdlib${ii}$_zlarf( 'L', m-p-i, q-i, x21(i+1,i), 1_${ik}$,conjg(taup2(i)), x21(i+1,i+1), & ldx21,work(ilarf) ) end if x11(i,i) = cone - call stdlib_zlarf( 'L', p-i+1, q-i, x11(i,i), 1, conjg(taup1(i)),x11(i,i+1), ldx11, & + call stdlib${ii}$_zlarf( 'L', p-i+1, q-i, x11(i,i), 1_${ik}$, conjg(taup1(i)),x11(i,i+1), ldx11, & work(ilarf) ) end do ! reduce the bottom-right portion of x11 to the identity matrix do i = m-p + 1, q - call stdlib_zlarfgp( p-i+1, x11(i,i), x11(i+1,i), 1, taup1(i) ) + call stdlib${ii}$_zlarfgp( p-i+1, x11(i,i), x11(i+1,i), 1_${ik}$, taup1(i) ) x11(i,i) = cone - call stdlib_zlarf( 'L', p-i+1, q-i, x11(i,i), 1, conjg(taup1(i)),x11(i,i+1), ldx11, & + call stdlib${ii}$_zlarf( 'L', p-i+1, q-i, x11(i,i), 1_${ik}$, conjg(taup1(i)),x11(i,i+1), ldx11, & work(ilarf) ) end do return - end subroutine stdlib_zunbdb3 + end subroutine stdlib${ii}$_zunbdb3 - subroutine stdlib_zunbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & + subroutine stdlib${ii}$_zunbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, phi,taup1, taup2, tauq1, & !! ZUNBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny !! matrix X with orthonomal columns: !! [ B11 ] @@ -63233,8 +63236,8 @@ module stdlib_linalg_lapack_z ! -- 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) :: lwork, m, p, q, ldx11, ldx21 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lwork, m, p, q, ldx11, ldx21 ! Array Arguments real(dp), intent(out) :: phi(*), theta(*) complex(dp), intent(out) :: phantom(*), taup1(*), taup2(*), tauq1(*), work(*) @@ -63243,125 +63246,125 @@ module stdlib_linalg_lapack_z ! Local Scalars real(dp) :: c, s - integer(ilp) :: childinfo, i, ilarf, iorbdb5, j, llarf, lorbdb5, lworkmin, & + integer(${ik}$) :: childinfo, i, ilarf, iorbdb5, j, llarf, lorbdb5, lworkmin, & lworkopt logical(lk) :: lquery ! Intrinsic Function intrinsic :: atan2,cos,max,sin,sqrt ! Executable Statements ! test input arguments - info = 0 - lquery = lwork == -1 - if( m < 0 ) then - info = -1 + info = 0_${ik}$ + lquery = lwork == -1_${ik}$ + if( m < 0_${ik}$ ) then + info = -1_${ik}$ else if( p < m-q .or. m-p < m-q ) then - info = -2 + info = -2_${ik}$ else if( q < m-q .or. q > m ) then - info = -3 - else if( ldx11 < max( 1, p ) ) then - info = -5 - else if( ldx21 < max( 1, m-p ) ) then - info = -7 + info = -3_${ik}$ + else if( ldx11 < max( 1_${ik}$, p ) ) then + info = -5_${ik}$ + else if( ldx21 < max( 1_${ik}$, m-p ) ) then + info = -7_${ik}$ end if ! compute workspace - if( info == 0 ) then - ilarf = 2 + if( info == 0_${ik}$ ) then + ilarf = 2_${ik}$ llarf = max( q-1, p-1, m-p-1 ) - iorbdb5 = 2 + iorbdb5 = 2_${ik}$ lorbdb5 = q - lworkopt = ilarf + llarf - 1 - lworkopt = max( lworkopt, iorbdb5 + lorbdb5 - 1 ) + lworkopt = ilarf + llarf - 1_${ik}$ + lworkopt = max( lworkopt, iorbdb5 + lorbdb5 - 1_${ik}$ ) lworkmin = lworkopt - work(1) = lworkopt + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not.lquery ) then - info = -14 + info = -14_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'ZUNBDB4', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZUNBDB4', -info ) return else if( lquery ) then return end if ! reduce columns 1, ..., m-q of x11 and x21 do i = 1, m-q - if( i == 1 ) then + if( i == 1_${ik}$ ) then do j = 1, m phantom(j) = czero end do - call stdlib_zunbdb5( p, m-p, q, phantom(1), 1, phantom(p+1), 1,x11, ldx11, x21, & + call stdlib${ii}$_zunbdb5( p, m-p, q, phantom(1_${ik}$), 1_${ik}$, phantom(p+1), 1_${ik}$,x11, ldx11, x21, & ldx21, work(iorbdb5),lorbdb5, childinfo ) - call stdlib_zscal( p, cnegone, phantom(1), 1 ) - call stdlib_zlarfgp( p, phantom(1), phantom(2), 1, taup1(1) ) - call stdlib_zlarfgp( m-p, phantom(p+1), phantom(p+2), 1, taup2(1) ) - theta(i) = atan2( real( phantom(1),KIND=dp), real( phantom(p+1),KIND=dp) ) + call stdlib${ii}$_zscal( p, cnegone, phantom(1_${ik}$), 1_${ik}$ ) + call stdlib${ii}$_zlarfgp( p, phantom(1_${ik}$), phantom(2_${ik}$), 1_${ik}$, taup1(1_${ik}$) ) + call stdlib${ii}$_zlarfgp( m-p, phantom(p+1), phantom(p+2), 1_${ik}$, taup2(1_${ik}$) ) + theta(i) = atan2( real( phantom(1_${ik}$),KIND=dp), real( phantom(p+1),KIND=dp) ) c = cos( theta(i) ) s = sin( theta(i) ) - phantom(1) = cone + phantom(1_${ik}$) = cone phantom(p+1) = cone - call stdlib_zlarf( 'L', p, q, phantom(1), 1, conjg(taup1(1)), x11,ldx11, work(& + call stdlib${ii}$_zlarf( 'L', p, q, phantom(1_${ik}$), 1_${ik}$, conjg(taup1(1_${ik}$)), x11,ldx11, work(& ilarf) ) - call stdlib_zlarf( 'L', m-p, q, phantom(p+1), 1, conjg(taup2(1)),x21, ldx21, & + call stdlib${ii}$_zlarf( 'L', m-p, q, phantom(p+1), 1_${ik}$, conjg(taup2(1_${ik}$)),x21, ldx21, & work(ilarf) ) else - call stdlib_zunbdb5( p-i+1, m-p-i+1, q-i+1, x11(i,i-1), 1,x21(i,i-1), 1, x11(i,i)& + call stdlib${ii}$_zunbdb5( p-i+1, m-p-i+1, q-i+1, x11(i,i-1), 1_${ik}$,x21(i,i-1), 1_${ik}$, x11(i,i)& , ldx11, x21(i,i),ldx21, work(iorbdb5), lorbdb5, childinfo ) - call stdlib_zscal( p-i+1, cnegone, x11(i,i-1), 1 ) - call stdlib_zlarfgp( p-i+1, x11(i,i-1), x11(i+1,i-1), 1, taup1(i) ) - call stdlib_zlarfgp( m-p-i+1, x21(i,i-1), x21(i+1,i-1), 1,taup2(i) ) + call stdlib${ii}$_zscal( p-i+1, cnegone, x11(i,i-1), 1_${ik}$ ) + call stdlib${ii}$_zlarfgp( p-i+1, x11(i,i-1), x11(i+1,i-1), 1_${ik}$, taup1(i) ) + call stdlib${ii}$_zlarfgp( m-p-i+1, x21(i,i-1), x21(i+1,i-1), 1_${ik}$,taup2(i) ) theta(i) = atan2( real( x11(i,i-1),KIND=dp), real( x21(i,i-1),KIND=dp) ) c = cos( theta(i) ) s = sin( theta(i) ) x11(i,i-1) = cone x21(i,i-1) = cone - call stdlib_zlarf( 'L', p-i+1, q-i+1, x11(i,i-1), 1,conjg(taup1(i)), x11(i,i), & + call stdlib${ii}$_zlarf( 'L', p-i+1, q-i+1, x11(i,i-1), 1_${ik}$,conjg(taup1(i)), x11(i,i), & ldx11, work(ilarf) ) - call stdlib_zlarf( 'L', m-p-i+1, q-i+1, x21(i,i-1), 1,conjg(taup2(i)), x21(i,i), & + call stdlib${ii}$_zlarf( 'L', m-p-i+1, q-i+1, x21(i,i-1), 1_${ik}$,conjg(taup2(i)), x21(i,i), & ldx21, work(ilarf) ) end if - call stdlib_zdrot( q-i+1, x11(i,i), ldx11, x21(i,i), ldx21, s, -c ) - call stdlib_zlacgv( q-i+1, x21(i,i), ldx21 ) - call stdlib_zlarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) + call stdlib${ii}$_zdrot( q-i+1, x11(i,i), ldx11, x21(i,i), ldx21, s, -c ) + call stdlib${ii}$_zlacgv( q-i+1, x21(i,i), ldx21 ) + call stdlib${ii}$_zlarfgp( q-i+1, x21(i,i), x21(i,i+1), ldx21, tauq1(i) ) c = real( x21(i,i),KIND=dp) x21(i,i) = cone - call stdlib_zlarf( 'R', p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i+1,i), ldx11, & + call stdlib${ii}$_zlarf( 'R', p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x11(i+1,i), ldx11, & work(ilarf) ) - call stdlib_zlarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & + call stdlib${ii}$_zlarf( 'R', m-p-i, q-i+1, x21(i,i), ldx21, tauq1(i),x21(i+1,i), ldx21, & work(ilarf) ) - call stdlib_zlacgv( q-i+1, x21(i,i), ldx21 ) + call stdlib${ii}$_zlacgv( q-i+1, x21(i,i), ldx21 ) if( i < m-q ) then - s = sqrt( stdlib_dznrm2( p-i, x11(i+1,i), 1 )**2+ stdlib_dznrm2( m-p-i, x21(i+1,& - i), 1 )**2 ) + s = sqrt( stdlib${ii}$_dznrm2( p-i, x11(i+1,i), 1_${ik}$ )**2_${ik}$+ stdlib${ii}$_dznrm2( m-p-i, x21(i+1,& + i), 1_${ik}$ )**2_${ik}$ ) phi(i) = atan2( s, c ) end if end do ! reduce the bottom-right portion of x11 to [ i 0 ] do i = m - q + 1, p - call stdlib_zlacgv( q-i+1, x11(i,i), ldx11 ) - call stdlib_zlarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) + call stdlib${ii}$_zlacgv( q-i+1, x11(i,i), ldx11 ) + call stdlib${ii}$_zlarfgp( q-i+1, x11(i,i), x11(i,i+1), ldx11, tauq1(i) ) x11(i,i) = cone - call stdlib_zlarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & + call stdlib${ii}$_zlarf( 'R', p-i, q-i+1, x11(i,i), ldx11, tauq1(i),x11(i+1,i), ldx11, & work(ilarf) ) - call stdlib_zlarf( 'R', q-p, q-i+1, x11(i,i), ldx11, tauq1(i),x21(m-q+1,i), ldx21, & + call stdlib${ii}$_zlarf( 'R', q-p, q-i+1, x11(i,i), ldx11, tauq1(i),x21(m-q+1,i), ldx21, & work(ilarf) ) - call stdlib_zlacgv( q-i+1, x11(i,i), ldx11 ) + call stdlib${ii}$_zlacgv( q-i+1, x11(i,i), ldx11 ) end do ! reduce the bottom-right portion of x21 to [ 0 i ] do i = p + 1, q - call stdlib_zlacgv( q-i+1, x21(m-q+i-p,i), ldx21 ) - call stdlib_zlarfgp( q-i+1, x21(m-q+i-p,i), x21(m-q+i-p,i+1), ldx21,tauq1(i) ) + call stdlib${ii}$_zlacgv( q-i+1, x21(m-q+i-p,i), ldx21 ) + call stdlib${ii}$_zlarfgp( q-i+1, x21(m-q+i-p,i), x21(m-q+i-p,i+1), ldx21,tauq1(i) ) x21(m-q+i-p,i) = cone - call stdlib_zlarf( 'R', q-i, q-i+1, x21(m-q+i-p,i), ldx21, tauq1(i),x21(m-q+i-p+1,i)& + call stdlib${ii}$_zlarf( 'R', q-i, q-i+1, x21(m-q+i-p,i), ldx21, tauq1(i),x21(m-q+i-p+1,i)& , ldx21, work(ilarf) ) - call stdlib_zlacgv( q-i+1, x21(m-q+i-p,i), ldx21 ) + call stdlib${ii}$_zlacgv( q-i+1, x21(m-q+i-p,i), ldx21 ) end do return - end subroutine stdlib_zunbdb4 + end subroutine stdlib${ii}$_zunbdb4 - subroutine stdlib_zuncsd2by1( jobu1, jobu2, jobv1t, m, p, q, x11, ldx11,x21, ldx21, theta, & + subroutine stdlib${ii}$_zuncsd2by1( jobu1, jobu2, jobv1t, m, p, q, x11, ldx11,x21, ldx21, theta, & !! ZUNCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with !! orthonormal columns that has been partitioned into a 2-by-1 block !! structure: @@ -63383,52 +63386,52 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobu1, jobu2, jobv1t - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: ldu1, ldu2, ldv1t, lwork, ldx11, ldx21, m, p, q - integer(ilp), intent(in) :: lrwork - integer(ilp) :: lrworkmin, lrworkopt + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: ldu1, ldu2, ldv1t, lwork, ldx11, ldx21, m, p, q + integer(${ik}$), intent(in) :: lrwork + integer(${ik}$) :: lrworkmin, lrworkopt ! Array Arguments real(dp), intent(out) :: rwork(*) real(dp), intent(out) :: theta(*) complex(dp), intent(out) :: u1(ldu1,*), u2(ldu2,*), v1t(ldv1t,*), work(*) complex(dp), intent(inout) :: x11(ldx11,*), x21(ldx21,*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: childinfo, i, ib11d, ib11e, ib12d, ib12e, ib21d, ib21e, ib22d, ib22e, & + integer(${ik}$) :: childinfo, i, ib11d, ib11e, ib12d, ib12e, ib21d, ib21e, ib22d, ib22e, & ibbcsd, iorbdb, iorglq, iorgqr, iphi, itaup1, itaup2, itauq1, j, lbbcsd, lorbdb, & lorglq, lorglqmin, lorglqopt, lorgqr, lorgqrmin, lorgqropt, lworkmin, lworkopt, & r logical(lk) :: lquery, wantu1, wantu2, wantv1t ! Local Arrays - real(dp) :: dum(1) - complex(dp) :: cdum(1,1) + real(dp) :: dum(1_${ik}$) + complex(dp) :: cdum(1_${ik}$,1_${ik}$) ! Intrinsic Function intrinsic :: int,max,min ! Executable Statements ! test input arguments - info = 0 + info = 0_${ik}$ wantu1 = stdlib_lsame( jobu1, 'Y' ) wantu2 = stdlib_lsame( jobu2, 'Y' ) wantv1t = stdlib_lsame( jobv1t, 'Y' ) - lquery = ( lwork==-1 ) .or. ( lrwork==-1 ) - if( m < 0 ) then - info = -4 - else if( p < 0 .or. p > m ) then - info = -5 - else if( q < 0 .or. q > m ) then - info = -6 - else if( ldx11 < max( 1, p ) ) then - info = -8 - else if( ldx21 < max( 1, m-p ) ) then - info = -10 - else if( wantu1 .and. ldu1 < max( 1, p ) ) then - info = -13 - else if( wantu2 .and. ldu2 < max( 1, m - p ) ) then - info = -15 - else if( wantv1t .and. ldv1t < max( 1, q ) ) then - info = -17 + lquery = ( lwork==-1_${ik}$ ) .or. ( lrwork==-1_${ik}$ ) + if( m < 0_${ik}$ ) then + info = -4_${ik}$ + else if( p < 0_${ik}$ .or. p > m ) then + info = -5_${ik}$ + else if( q < 0_${ik}$ .or. q > m ) then + info = -6_${ik}$ + else if( ldx11 < max( 1_${ik}$, p ) ) then + info = -8_${ik}$ + else if( ldx21 < max( 1_${ik}$, m-p ) ) then + info = -10_${ik}$ + else if( wantu1 .and. ldu1 < max( 1_${ik}$, p ) ) then + info = -13_${ik}$ + else if( wantu2 .and. ldu2 < max( 1_${ik}$, m - p ) ) then + info = -15_${ik}$ + else if( wantv1t .and. ldv1t < max( 1_${ik}$, q ) ) then + info = -17_${ik}$ end if r = min( p, m-p, q, m-q ) ! compute workspace @@ -63440,7 +63443,7 @@ module stdlib_linalg_lapack_z ! | taup2 (max(1,m-p)) | ! | tauq1 (max(1,q)) | ! |-----------------------------------------| - ! | stdlib_zunbdb work | stdlib_zungqr work | stdlib_zunglq work | + ! | stdlib${ii}$_zunbdb work | stdlib${ii}$_zungqr work | stdlib${ii}$_zunglq work | ! | | | | ! | | | | ! | | | | @@ -63460,143 +63463,143 @@ module stdlib_linalg_lapack_z ! | b21e (r-1) | ! | b22d (r) | ! | b22e (r-1) | - ! | stdlib_zbbcsd rwork | + ! | stdlib${ii}$_zbbcsd rwork | ! |------------------| - if( info == 0 ) then - iphi = 2 - ib11d = iphi + max( 1, r-1 ) - ib11e = ib11d + max( 1, r ) - ib12d = ib11e + max( 1, r - 1 ) - ib12e = ib12d + max( 1, r ) - ib21d = ib12e + max( 1, r - 1 ) - ib21e = ib21d + max( 1, r ) - ib22d = ib21e + max( 1, r - 1 ) - ib22e = ib22d + max( 1, r ) - ibbcsd = ib22e + max( 1, r - 1 ) - itaup1 = 2 - itaup2 = itaup1 + max( 1, p ) - itauq1 = itaup2 + max( 1, m-p ) - iorbdb = itauq1 + max( 1, q ) - iorgqr = itauq1 + max( 1, q ) - iorglq = itauq1 + max( 1, q ) - lorgqrmin = 1 - lorgqropt = 1 - lorglqmin = 1 - lorglqopt = 1 + if( info == 0_${ik}$ ) then + iphi = 2_${ik}$ + ib11d = iphi + max( 1_${ik}$, r-1 ) + ib11e = ib11d + max( 1_${ik}$, r ) + ib12d = ib11e + max( 1_${ik}$, r - 1_${ik}$ ) + ib12e = ib12d + max( 1_${ik}$, r ) + ib21d = ib12e + max( 1_${ik}$, r - 1_${ik}$ ) + ib21e = ib21d + max( 1_${ik}$, r ) + ib22d = ib21e + max( 1_${ik}$, r - 1_${ik}$ ) + ib22e = ib22d + max( 1_${ik}$, r ) + ibbcsd = ib22e + max( 1_${ik}$, r - 1_${ik}$ ) + itaup1 = 2_${ik}$ + itaup2 = itaup1 + max( 1_${ik}$, p ) + itauq1 = itaup2 + max( 1_${ik}$, m-p ) + iorbdb = itauq1 + max( 1_${ik}$, q ) + iorgqr = itauq1 + max( 1_${ik}$, q ) + iorglq = itauq1 + max( 1_${ik}$, q ) + lorgqrmin = 1_${ik}$ + lorgqropt = 1_${ik}$ + lorglqmin = 1_${ik}$ + lorglqopt = 1_${ik}$ if( r == q ) then - call stdlib_zunbdb1( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & - cdum, work, -1, childinfo ) - lorbdb = int( work(1),KIND=ilp) - if( wantu1 .and. p > 0 ) then - call stdlib_zungqr( p, p, q, u1, ldu1, cdum, work(1), -1,childinfo ) + call stdlib${ii}$_zunbdb1( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & + cdum, work, -1_${ik}$, childinfo ) + lorbdb = int( work(1_${ik}$),KIND=${ik}$) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_zungqr( p, p, q, u1, ldu1, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) endif - if( wantu2 .and. m-p > 0 ) then - call stdlib_zungqr( m-p, m-p, q, u2, ldu2, cdum, work(1), -1,childinfo ) + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_zungqr( m-p, m-p, q, u2, ldu2, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, m-p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_zunglq( q-1, q-1, q-1, v1t, ldv1t,cdum, work(1), -1, childinfo ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_zunglq( q-1, q-1, q-1, v1t, ldv1t,cdum, work(1_${ik}$), -1_${ik}$, childinfo ) lorglqmin = max( lorglqmin, q-1 ) - lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) + lorglqopt = max( lorglqopt, int( work(1_${ik}$),KIND=${ik}$) ) end if - call stdlib_zbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,dum, u1, ldu1,& - u2, ldu2, v1t, ldv1t, cdum, 1,dum, dum, dum, dum, dum, dum, dum, dum,rwork(1), -& - 1, childinfo ) - lbbcsd = int( rwork(1),KIND=ilp) + call stdlib${ii}$_zbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,dum, u1, ldu1,& + u2, ldu2, v1t, ldv1t, cdum, 1_${ik}$,dum, dum, dum, dum, dum, dum, dum, dum,rwork(1_${ik}$), -& + 1_${ik}$, childinfo ) + lbbcsd = int( rwork(1_${ik}$),KIND=${ik}$) else if( r == p ) then - call stdlib_zunbdb2( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & - cdum, work(1), -1, childinfo ) - lorbdb = int( work(1),KIND=ilp) - if( wantu1 .and. p > 0 ) then - call stdlib_zungqr( p-1, p-1, p-1, u1(2,2), ldu1, cdum, work(1),-1, childinfo & + call stdlib${ii}$_zunbdb2( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & + cdum, work(1_${ik}$), -1_${ik}$, childinfo ) + lorbdb = int( work(1_${ik}$),KIND=${ik}$) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_zungqr( p-1, p-1, p-1, u1(2_${ik}$,2_${ik}$), ldu1, cdum, work(1_${ik}$),-1_${ik}$, childinfo & ) lorgqrmin = max( lorgqrmin, p-1 ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_zungqr( m-p, m-p, q, u2, ldu2, cdum, work(1), -1,childinfo ) + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_zungqr( m-p, m-p, q, u2, ldu2, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, m-p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_zunglq( q, q, r, v1t, ldv1t, cdum, work(1), -1,childinfo ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_zunglq( q, q, r, v1t, ldv1t, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorglqmin = max( lorglqmin, q ) - lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) + lorglqopt = max( lorglqopt, int( work(1_${ik}$),KIND=${ik}$) ) end if - call stdlib_zbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,dum, v1t, & - ldv1t, cdum, 1, u1, ldu1, u2, ldu2,dum, dum, dum, dum, dum, dum, dum, dum,rwork(& - 1), -1, childinfo ) - lbbcsd = int( rwork(1),KIND=ilp) + call stdlib${ii}$_zbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,dum, v1t, & + ldv1t, cdum, 1_${ik}$, u1, ldu1, u2, ldu2,dum, dum, dum, dum, dum, dum, dum, dum,rwork(& + 1_${ik}$), -1_${ik}$, childinfo ) + lbbcsd = int( rwork(1_${ik}$),KIND=${ik}$) else if( r == m-p ) then - call stdlib_zunbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & - cdum, work(1), -1, childinfo ) - lorbdb = int( work(1),KIND=ilp) - if( wantu1 .and. p > 0 ) then - call stdlib_zungqr( p, p, q, u1, ldu1, cdum, work(1), -1,childinfo ) + call stdlib${ii}$_zunbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & + cdum, work(1_${ik}$), -1_${ik}$, childinfo ) + lorbdb = int( work(1_${ik}$),KIND=${ik}$) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_zungqr( p, p, q, u1, ldu1, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_zungqr( m-p-1, m-p-1, m-p-1, u2(2,2), ldu2, cdum,work(1), -1, & + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_zungqr( m-p-1, m-p-1, m-p-1, u2(2_${ik}$,2_${ik}$), ldu2, cdum,work(1_${ik}$), -1_${ik}$, & childinfo ) lorgqrmin = max( lorgqrmin, m-p-1 ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_zunglq( q, q, r, v1t, ldv1t, cdum, work(1), -1,childinfo ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_zunglq( q, q, r, v1t, ldv1t, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorglqmin = max( lorglqmin, q ) - lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) - end if - call stdlib_zbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, dum, cdum,& - 1, v1t, ldv1t, u2, ldu2, u1,ldu1, dum, dum, dum, dum, dum, dum, dum, dum,rwork(& - 1), -1, childinfo ) - lbbcsd = int( rwork(1),KIND=ilp) - else - call stdlib_zunbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & - cdum, cdum, work(1), -1, childinfo) - lorbdb = m + int( work(1),KIND=ilp) - if( wantu1 .and. p > 0 ) then - call stdlib_zungqr( p, p, m-q, u1, ldu1, cdum, work(1), -1,childinfo ) + lorglqopt = max( lorglqopt, int( work(1_${ik}$),KIND=${ik}$) ) + end if + call stdlib${ii}$_zbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, dum, cdum,& + 1_${ik}$, v1t, ldv1t, u2, ldu2, u1,ldu1, dum, dum, dum, dum, dum, dum, dum, dum,rwork(& + 1_${ik}$), -1_${ik}$, childinfo ) + lbbcsd = int( rwork(1_${ik}$),KIND=${ik}$) + else + call stdlib${ii}$_zunbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, dum,cdum, cdum, & + cdum, cdum, work(1_${ik}$), -1_${ik}$, childinfo) + lorbdb = m + int( work(1_${ik}$),KIND=${ik}$) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_zungqr( p, p, m-q, u1, ldu1, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_zungqr( m-p, m-p, m-q, u2, ldu2, cdum, work(1), -1,childinfo ) + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_zungqr( m-p, m-p, m-q, u2, ldu2, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorgqrmin = max( lorgqrmin, m-p ) - lorgqropt = max( lorgqropt, int( work(1),KIND=ilp) ) + lorgqropt = max( lorgqropt, int( work(1_${ik}$),KIND=${ik}$) ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_zunglq( q, q, q, v1t, ldv1t, cdum, work(1), -1,childinfo ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_zunglq( q, q, q, v1t, ldv1t, cdum, work(1_${ik}$), -1_${ik}$,childinfo ) lorglqmin = max( lorglqmin, q ) - lorglqopt = max( lorglqopt, int( work(1),KIND=ilp) ) + lorglqopt = max( lorglqopt, int( work(1_${ik}$),KIND=${ik}$) ) end if - call stdlib_zbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, dum, u2, & - ldu2, u1, ldu1, cdum, 1, v1t,ldv1t, dum, dum, dum, dum, dum, dum, dum, dum,rwork(& - 1), -1, childinfo ) - lbbcsd = int( rwork(1),KIND=ilp) + call stdlib${ii}$_zbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, dum, u2, & + ldu2, u1, ldu1, cdum, 1_${ik}$, v1t,ldv1t, dum, dum, dum, dum, dum, dum, dum, dum,rwork(& + 1_${ik}$), -1_${ik}$, childinfo ) + lbbcsd = int( rwork(1_${ik}$),KIND=${ik}$) end if lrworkmin = ibbcsd+lbbcsd-1 lrworkopt = lrworkmin - rwork(1) = lrworkopt + rwork(1_${ik}$) = lrworkopt lworkmin = max( iorbdb+lorbdb-1,iorgqr+lorgqrmin-1,iorglq+lorglqmin-1 ) lworkopt = max( iorbdb+lorbdb-1,iorgqr+lorgqropt-1,iorglq+lorglqopt-1 ) - work(1) = lworkopt + work(1_${ik}$) = lworkopt if( lwork < lworkmin .and. .not.lquery ) then - info = -19 + info = -19_${ik}$ end if if( lrwork < lrworkmin .and. .not.lquery ) then - info = -21 + info = -21_${ik}$ end if end if - if( info /= 0 ) then - call stdlib_xerbla( 'ZUNCSD2BY1', -info ) + if( info /= 0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZUNCSD2BY1', -info ) return else if( lquery ) then return @@ -63608,116 +63611,116 @@ module stdlib_linalg_lapack_z if( r == q ) then ! case 1: r = q ! simultaneously bidiagonalize x11 and x21 - call stdlib_zunbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& + call stdlib${ii}$_zunbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& itaup1), work(itaup2),work(itauq1), work(iorbdb), lorbdb, childinfo ) ! accumulate householder reflectors - if( wantu1 .and. p > 0 ) then - call stdlib_zlacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) - call stdlib_zungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) + call stdlib${ii}$_zungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & childinfo ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_zlacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) - call stdlib_zungqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) + call stdlib${ii}$_zungqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & childinfo ) end if - if( wantv1t .and. q > 0 ) then - v1t(1,1) = cone + if( wantv1t .and. q > 0_${ik}$ ) then + v1t(1_${ik}$,1_${ik}$) = cone do j = 2, q - v1t(1,j) = czero - v1t(j,1) = czero + v1t(1_${ik}$,j) = czero + v1t(j,1_${ik}$) = czero end do - call stdlib_zlacpy( 'U', q-1, q-1, x21(1,2), ldx21, v1t(2,2),ldv1t ) - call stdlib_zunglq( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),work(iorglq), & + call stdlib${ii}$_zlacpy( 'U', q-1, q-1, x21(1_${ik}$,2_${ik}$), ldx21, v1t(2_${ik}$,2_${ik}$),ldv1t ) + call stdlib${ii}$_zunglq( q-1, q-1, q-1, v1t(2_${ik}$,2_${ik}$), ldv1t, work(itauq1),work(iorglq), & lorglq, childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_zbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,rwork(iphi), u1, & - ldu1, u2, ldu2, v1t, ldv1t, cdum,1, rwork(ib11d), rwork(ib11e), rwork(ib12d),rwork(& + call stdlib${ii}$_zbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,rwork(iphi), u1, & + ldu1, u2, ldu2, v1t, ldv1t, cdum,1_${ik}$, rwork(ib11d), rwork(ib11e), rwork(ib12d),rwork(& ib12e), rwork(ib21d), rwork(ib21e),rwork(ib22d), rwork(ib22e), rwork(ibbcsd),lrwork-& ibbcsd+1, childinfo ) ! permute rows and columns to place czero submatrices in ! preferred positions - if( q > 0 .and. wantu2 ) then + if( q > 0_${ik}$ .and. wantu2 ) then do i = 1, q iwork(i) = m - p - q + i end do do i = q + 1, m - p iwork(i) = i - q end do - call stdlib_zlapmt( .false., m-p, m-p, u2, ldu2, iwork ) + call stdlib${ii}$_zlapmt( .false., m-p, m-p, u2, ldu2, iwork ) end if else if( r == p ) then ! case 2: r = p ! simultaneously bidiagonalize x11 and x21 - call stdlib_zunbdb2( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& + call stdlib${ii}$_zunbdb2( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& itaup1), work(itaup2),work(itauq1), work(iorbdb), lorbdb, childinfo ) ! accumulate householder reflectors - if( wantu1 .and. p > 0 ) then - u1(1,1) = cone + if( wantu1 .and. p > 0_${ik}$ ) then + u1(1_${ik}$,1_${ik}$) = cone do j = 2, p - u1(1,j) = czero - u1(j,1) = czero + u1(1_${ik}$,j) = czero + u1(j,1_${ik}$) = czero end do - call stdlib_zlacpy( 'L', p-1, p-1, x11(2,1), ldx11, u1(2,2), ldu1 ) - call stdlib_zungqr( p-1, p-1, p-1, u1(2,2), ldu1, work(itaup1),work(iorgqr), & + call stdlib${ii}$_zlacpy( 'L', p-1, p-1, x11(2_${ik}$,1_${ik}$), ldx11, u1(2_${ik}$,2_${ik}$), ldu1 ) + call stdlib${ii}$_zungqr( p-1, p-1, p-1, u1(2_${ik}$,2_${ik}$), ldu1, work(itaup1),work(iorgqr), & lorgqr, childinfo ) end if - if( wantu2 .and. m-p > 0 ) then - call stdlib_zlacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) - call stdlib_zungqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 ) + call stdlib${ii}$_zungqr( m-p, m-p, q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & childinfo ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_zlacpy( 'U', p, q, x11, ldx11, v1t, ldv1t ) - call stdlib_zunglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'U', p, q, x11, ldx11, v1t, ldv1t ) + call stdlib${ii}$_zunglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_zbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,rwork(iphi), v1t,& - ldv1t, cdum, 1, u1, ldu1, u2,ldu2, rwork(ib11d), rwork(ib11e), rwork(ib12d),rwork(& + call stdlib${ii}$_zbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,rwork(iphi), v1t,& + ldv1t, cdum, 1_${ik}$, u1, ldu1, u2,ldu2, rwork(ib11d), rwork(ib11e), rwork(ib12d),rwork(& ib12e), rwork(ib21d), rwork(ib21e),rwork(ib22d), rwork(ib22e), rwork(ibbcsd), & lbbcsd,childinfo ) ! permute rows and columns to place identity submatrices in ! preferred positions - if( q > 0 .and. wantu2 ) then + if( q > 0_${ik}$ .and. wantu2 ) then do i = 1, q iwork(i) = m - p - q + i end do do i = q + 1, m - p iwork(i) = i - q end do - call stdlib_zlapmt( .false., m-p, m-p, u2, ldu2, iwork ) + call stdlib${ii}$_zlapmt( .false., m-p, m-p, u2, ldu2, iwork ) end if else if( r == m-p ) then ! case 3: r = m-p ! simultaneously bidiagonalize x11 and x21 - call stdlib_zunbdb3( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& + call stdlib${ii}$_zunbdb3( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& itaup1), work(itaup2),work(itauq1), work(iorbdb), lorbdb, childinfo ) ! accumulate householder reflectors - if( wantu1 .and. p > 0 ) then - call stdlib_zlacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) - call stdlib_zungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'L', p, q, x11, ldx11, u1, ldu1 ) + call stdlib${ii}$_zungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),lorgqr, & childinfo ) end if - if( wantu2 .and. m-p > 0 ) then - u2(1,1) = cone + if( wantu2 .and. m-p > 0_${ik}$ ) then + u2(1_${ik}$,1_${ik}$) = cone do j = 2, m-p - u2(1,j) = czero - u2(j,1) = czero + u2(1_${ik}$,j) = czero + u2(j,1_${ik}$) = czero end do - call stdlib_zlacpy( 'L', m-p-1, m-p-1, x21(2,1), ldx21, u2(2,2),ldu2 ) - call stdlib_zungqr( m-p-1, m-p-1, m-p-1, u2(2,2), ldu2,work(itaup2), work(iorgqr)& + call stdlib${ii}$_zlacpy( 'L', m-p-1, m-p-1, x21(2_${ik}$,1_${ik}$), ldx21, u2(2_${ik}$,2_${ik}$),ldu2 ) + call stdlib${ii}$_zungqr( m-p-1, m-p-1, m-p-1, u2(2_${ik}$,2_${ik}$), ldu2,work(itaup2), work(iorgqr)& , lorgqr, childinfo ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_zlacpy( 'U', m-p, q, x21, ldx21, v1t, ldv1t ) - call stdlib_zunglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'U', m-p, q, x21, ldx21, v1t, ldv1t ) + call stdlib${ii}$_zunglq( q, q, r, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_zbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, rwork(iphi), & - cdum, 1, v1t, ldv1t, u2, ldu2,u1, ldu1, rwork(ib11d), rwork(ib11e),rwork(ib12d), & + call stdlib${ii}$_zbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,theta, rwork(iphi), & + cdum, 1_${ik}$, v1t, ldv1t, u2, ldu2,u1, ldu1, rwork(ib11d), rwork(ib11e),rwork(ib12d), & rwork(ib12e), rwork(ib21d),rwork(ib21e), rwork(ib22d), rwork(ib22e),rwork(ibbcsd), & lbbcsd, childinfo ) ! permute rows and columns to place identity submatrices in @@ -63730,51 +63733,51 @@ module stdlib_linalg_lapack_z iwork(i) = i - r end do if( wantu1 ) then - call stdlib_zlapmt( .false., p, q, u1, ldu1, iwork ) + call stdlib${ii}$_zlapmt( .false., p, q, u1, ldu1, iwork ) end if if( wantv1t ) then - call stdlib_zlapmr( .false., q, q, v1t, ldv1t, iwork ) + call stdlib${ii}$_zlapmr( .false., q, q, v1t, ldv1t, iwork ) end if end if else ! case 4: r = m-q ! simultaneously bidiagonalize x11 and x21 - call stdlib_zunbdb4( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& + call stdlib${ii}$_zunbdb4( m, p, q, x11, ldx11, x21, ldx21, theta,rwork(iphi), work(& itaup1), work(itaup2),work(itauq1), work(iorbdb), work(iorbdb+m),lorbdb-m, & childinfo ) ! accumulate householder reflectors - if( wantu2 .and. m-p > 0 ) then - call stdlib_zcopy( m-p, work(iorbdb+p), 1, u2, 1 ) + if( wantu2 .and. m-p > 0_${ik}$ ) then + call stdlib${ii}$_zcopy( m-p, work(iorbdb+p), 1_${ik}$, u2, 1_${ik}$ ) end if - if( wantu1 .and. p > 0 ) then - call stdlib_zcopy( p, work(iorbdb), 1, u1, 1 ) + if( wantu1 .and. p > 0_${ik}$ ) then + call stdlib${ii}$_zcopy( p, work(iorbdb), 1_${ik}$, u1, 1_${ik}$ ) do j = 2, p - u1(1,j) = czero + u1(1_${ik}$,j) = czero end do - call stdlib_zlacpy( 'L', p-1, m-q-1, x11(2,1), ldx11, u1(2,2),ldu1 ) - call stdlib_zungqr( p, p, m-q, u1, ldu1, work(itaup1),work(iorgqr), lorgqr, & + call stdlib${ii}$_zlacpy( 'L', p-1, m-q-1, x11(2_${ik}$,1_${ik}$), ldx11, u1(2_${ik}$,2_${ik}$),ldu1 ) + call stdlib${ii}$_zungqr( p, p, m-q, u1, ldu1, work(itaup1),work(iorgqr), lorgqr, & childinfo ) end if - if( wantu2 .and. m-p > 0 ) then + if( wantu2 .and. m-p > 0_${ik}$ ) then do j = 2, m-p - u2(1,j) = czero + u2(1_${ik}$,j) = czero end do - call stdlib_zlacpy( 'L', m-p-1, m-q-1, x21(2,1), ldx21, u2(2,2),ldu2 ) - call stdlib_zungqr( m-p, m-p, m-q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & + call stdlib${ii}$_zlacpy( 'L', m-p-1, m-q-1, x21(2_${ik}$,1_${ik}$), ldx21, u2(2_${ik}$,2_${ik}$),ldu2 ) + call stdlib${ii}$_zungqr( m-p, m-p, m-q, u2, ldu2, work(itaup2),work(iorgqr), lorgqr, & childinfo ) end if - if( wantv1t .and. q > 0 ) then - call stdlib_zlacpy( 'U', m-q, q, x21, ldx21, v1t, ldv1t ) - call stdlib_zlacpy( 'U', p-(m-q), q-(m-q), x11(m-q+1,m-q+1), ldx11,v1t(m-q+1,m-q+& - 1), ldv1t ) - call stdlib_zlacpy( 'U', -p+q, q-p, x21(m-q+1,p+1), ldx21,v1t(p+1,p+1), ldv1t ) + if( wantv1t .and. q > 0_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'U', m-q, q, x21, ldx21, v1t, ldv1t ) + call stdlib${ii}$_zlacpy( 'U', p-(m-q), q-(m-q), x11(m-q+1,m-q+1), ldx11,v1t(m-q+1,m-q+& + 1_${ik}$), ldv1t ) + call stdlib${ii}$_zlacpy( 'U', -p+q, q-p, x21(m-q+1,p+1), ldx21,v1t(p+1,p+1), ldv1t ) - call stdlib_zunglq( q, q, q, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & + call stdlib${ii}$_zunglq( q, q, q, v1t, ldv1t, work(itauq1),work(iorglq), lorglq, & childinfo ) end if ! simultaneously diagonalize x11 and x21. - call stdlib_zbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, rwork(iphi), & - u2, ldu2, u1, ldu1, cdum, 1,v1t, ldv1t, rwork(ib11d), rwork(ib11e),rwork(ib12d), & + call stdlib${ii}$_zbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,theta, rwork(iphi), & + u2, ldu2, u1, ldu1, cdum, 1_${ik}$,v1t, ldv1t, rwork(ib11d), rwork(ib11e),rwork(ib12d), & rwork(ib12e), rwork(ib21d),rwork(ib21e), rwork(ib22d), rwork(ib22e),rwork(ibbcsd), & lbbcsd, childinfo ) ! permute rows and columns to place identity submatrices in @@ -63787,18 +63790,18 @@ module stdlib_linalg_lapack_z iwork(i) = i - r end do if( wantu1 ) then - call stdlib_zlapmt( .false., p, p, u1, ldu1, iwork ) + call stdlib${ii}$_zlapmt( .false., p, p, u1, ldu1, iwork ) end if if( wantv1t ) then - call stdlib_zlapmr( .false., p, q, v1t, ldv1t, iwork ) + call stdlib${ii}$_zlapmr( .false., p, q, v1t, ldv1t, iwork ) end if end if end if return - end subroutine stdlib_zuncsd2by1 + end subroutine stdlib${ii}$_zuncsd2by1 - pure subroutine stdlib_zungbr( vect, m, n, k, a, lda, tau, work, lwork, info ) + pure subroutine stdlib${ii}$_zungbr( vect, m, n, k, a, lda, tau, work, lwork, info ) !! ZUNGBR generates one of the complex unitary matrices Q or P**H !! determined by ZGEBRD when reducing a complex matrix A to bidiagonal !! form: A = Q * B * P**H. Q and P**H are defined as products of @@ -63820,8 +63823,8 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: vect - 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 complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: tau(*) @@ -63830,124 +63833,124 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: lquery, wantq - integer(ilp) :: i, iinfo, j, lwkopt, mn + integer(${ik}$) :: i, iinfo, j, lwkopt, mn ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ wantq = stdlib_lsame( vect, 'Q' ) mn = min( m, n ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) if( .not.wantq .and. .not.stdlib_lsame( vect, 'P' ) ) then - info = -1 - else if( m<0 ) then - info = -2 - else if( n<0 .or. ( wantq .and. ( n>m .or. nm .or. nn .or. m=k ) then - call stdlib_zungqr( m, n, k, a, lda, tau, work, -1, iinfo ) + call stdlib${ii}$_zungqr( m, n, k, a, lda, tau, work, -1_${ik}$, iinfo ) else - if( m>1 ) then - call stdlib_zungqr( m-1, m-1, m-1, a, lda, tau, work, -1,iinfo ) + if( m>1_${ik}$ ) then + call stdlib${ii}$_zungqr( m-1, m-1, m-1, a, lda, tau, work, -1_${ik}$,iinfo ) end if end if else if( k1 ) then - call stdlib_zunglq( n-1, n-1, n-1, a, lda, tau, work, -1,iinfo ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_zunglq( n-1, n-1, n-1, a, lda, tau, work, -1_${ik}$,iinfo ) end if end if end if - lwkopt = real( work( 1 ),KIND=dp) + lwkopt = real( work( 1_${ik}$ ),KIND=dp) lwkopt = max (lwkopt, mn) end if - if( info/=0 ) then - call stdlib_xerbla( 'ZUNGBR', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZUNGBR', -info ) return else if( lquery ) then - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return end if ! quick return if possible - if( m==0 .or. n==0 ) then - work( 1 ) = 1 + if( m==0_${ik}$ .or. n==0_${ik}$ ) then + work( 1_${ik}$ ) = 1_${ik}$ return end if if( wantq ) then - ! form q, determined by a call to stdlib_zgebrd to reduce an m-by-k + ! form q, determined by a call to stdlib${ii}$_zgebrd to reduce an m-by-k ! matrix if( m>=k ) then ! if m >= k, assume m >= n >= k - call stdlib_zungqr( m, n, k, a, lda, tau, work, lwork, iinfo ) + call stdlib${ii}$_zungqr( m, n, k, a, lda, tau, work, lwork, iinfo ) else ! if m < k, assume m = n ! shift the vectors which define the elementary reflectors cone ! column to the right, and set the first row and column of q ! to those of the unit matrix do j = m, 2, -1 - a( 1, j ) = czero + a( 1_${ik}$, j ) = czero do i = j + 1, m a( i, j ) = a( i, j-1 ) end do end do - a( 1, 1 ) = cone + a( 1_${ik}$, 1_${ik}$ ) = cone do i = 2, m - a( i, 1 ) = czero + a( i, 1_${ik}$ ) = czero end do - if( m>1 ) then + if( m>1_${ik}$ ) then ! form q(2:m,2:m) - call stdlib_zungqr( m-1, m-1, m-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) + call stdlib${ii}$_zungqr( m-1, m-1, m-1, a( 2_${ik}$, 2_${ik}$ ), lda, tau, work,lwork, iinfo ) end if end if else - ! form p**h, determined by a call to stdlib_zgebrd to reduce a k-by-n + ! form p**h, determined by a call to stdlib${ii}$_zgebrd to reduce a k-by-n ! matrix if( k= n, assume m = n ! shift the vectors which define the elementary reflectors cone ! row downward, and set the first row and column of p**h to ! those of the unit matrix - a( 1, 1 ) = cone + a( 1_${ik}$, 1_${ik}$ ) = cone do i = 2, n - a( i, 1 ) = czero + a( i, 1_${ik}$ ) = czero end do do j = 2, n do i = j - 1, 2, -1 a( i, j ) = a( i-1, j ) end do - a( 1, j ) = czero + a( 1_${ik}$, j ) = czero end do - if( n>1 ) then + if( n>1_${ik}$ ) then ! form p**h(2:n,2:n) - call stdlib_zunglq( n-1, n-1, n-1, a( 2, 2 ), lda, tau, work,lwork, iinfo ) + call stdlib${ii}$_zunglq( n-1, n-1, n-1, a( 2_${ik}$, 2_${ik}$ ), lda, tau, work,lwork, iinfo ) end if end if end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_zungbr + end subroutine stdlib${ii}$_zungbr - pure subroutine stdlib_zungtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) + pure subroutine stdlib${ii}$_zungtsqr( m, n, mb, nb, a, lda, t, ldt, work, lwork,info ) !! ZUNGTSQR generates an M-by-N complex matrix Q_out with orthonormal !! columns, which are the first N columns of a product of comlpex unitary !! matrices of order M which are returned by ZLATSQR @@ -63957,8 +63960,8 @@ module stdlib_linalg_lapack_z ! -- 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 complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(in) :: t(ldt,*) @@ -63967,85 +63970,85 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: lquery - integer(ilp) :: iinfo, ldc, lworkopt, lc, lw, nblocal, j + integer(${ik}$) :: iinfo, ldc, lworkopt, lc, lw, nblocal, j ! Intrinsic Functions intrinsic :: cmplx,max,min ! Executable Statements ! test the input parameters - lquery = lwork==-1 - info = 0 - if( m<0 ) then - info = -1 - else if( n<0 .or. m0 .and. n>0 ) then + if( info==0_${ik}$ ) then + if( m>0_${ik}$ .and. n>0_${ik}$ ) then if( applyq ) then if( left ) then - nb = stdlib_ilaenv( 1, 'ZUNMQR', side // trans, m-1, n, m-1,-1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', side // trans, m-1, n, m-1,-1_${ik}$ ) else - nb = stdlib_ilaenv( 1, 'ZUNMQR', side // trans, m, n-1, n-1,-1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', side // trans, m, n-1, n-1,-1_${ik}$ ) end if else if( left ) then - nb = stdlib_ilaenv( 1, 'ZUNMLQ', side // trans, m-1, n, m-1,-1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMLQ', side // trans, m-1, n, m-1,-1_${ik}$ ) else - nb = stdlib_ilaenv( 1, 'ZUNMLQ', side // trans, m, n-1, n-1,-1 ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMLQ', side // trans, m, n-1, n-1,-1_${ik}$ ) end if end if lwkopt = nw*nb else - lwkopt = 1 + lwkopt = 1_${ik}$ end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt end if - if( info/=0 ) then - call stdlib_xerbla( 'ZUNMBR', -info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZUNMBR', -info ) return else if( lquery ) then return @@ -64154,23 +64157,23 @@ module stdlib_linalg_lapack_z if( applyq ) then ! apply q if( nq>=k ) then - ! q was determined by a call to stdlib_zgebrd with nq >= k - call stdlib_zunmqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, iinfo & + ! q was determined by a call to stdlib${ii}$_zgebrd with nq >= k + call stdlib${ii}$_zunmqr( side, trans, m, n, k, a, lda, tau, c, ldc,work, lwork, iinfo & ) - else if( nq>1 ) then - ! q was determined by a call to stdlib_zgebrd with nq < k + else if( nq>1_${ik}$ ) then + ! q was determined by a call to stdlib${ii}$_zgebrd with nq < k if( left ) then - mi = m - 1 + mi = m - 1_${ik}$ ni = n - i1 = 2 - i2 = 1 + i1 = 2_${ik}$ + i2 = 1_${ik}$ else mi = m - ni = n - 1 - i1 = 1 - i2 = 2 + ni = n - 1_${ik}$ + i1 = 1_${ik}$ + i2 = 2_${ik}$ end if - call stdlib_zunmqr( side, trans, mi, ni, nq-1, a( 2, 1 ), lda, tau,c( i1, i2 ), & + call stdlib${ii}$_zunmqr( side, trans, mi, ni, nq-1, a( 2_${ik}$, 1_${ik}$ ), lda, tau,c( i1, i2 ), & ldc, work, lwork, iinfo ) end if else @@ -64181,32 +64184,32 @@ module stdlib_linalg_lapack_z transt = 'N' end if if( nq>k ) then - ! p was determined by a call to stdlib_zgebrd with nq > k - call stdlib_zunmlq( side, transt, m, n, k, a, lda, tau, c, ldc,work, lwork, & + ! p was determined by a call to stdlib${ii}$_zgebrd with nq > k + call stdlib${ii}$_zunmlq( side, transt, m, n, k, a, lda, tau, c, ldc,work, lwork, & iinfo ) - else if( nq>1 ) then - ! p was determined by a call to stdlib_zgebrd with nq <= k + else if( nq>1_${ik}$ ) then + ! p was determined by a call to stdlib${ii}$_zgebrd with nq <= k if( left ) then - mi = m - 1 + mi = m - 1_${ik}$ ni = n - i1 = 2 - i2 = 1 + i1 = 2_${ik}$ + i2 = 1_${ik}$ else mi = m - ni = n - 1 - i1 = 1 - i2 = 2 + ni = n - 1_${ik}$ + i1 = 1_${ik}$ + i2 = 2_${ik}$ end if - call stdlib_zunmlq( side, transt, mi, ni, nq-1, a( 1, 2 ), lda,tau, c( i1, i2 ), & + call stdlib${ii}$_zunmlq( side, transt, mi, ni, nq-1, a( 1_${ik}$, 2_${ik}$ ), lda,tau, c( i1, i2 ), & ldc, work, lwork, iinfo ) end if end if - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_zunmbr + end subroutine stdlib${ii}$_zunmbr - subroutine stdlib_zcgesv( n, nrhs, a, lda, ipiv, b, ldb, x, ldx, work,swork, rwork, iter, & + subroutine stdlib${ii}$_zcgesv( n, nrhs, a, lda, ipiv, b, ldb, x, ldx, work,swork, rwork, iter, & !! ZCGESV computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N matrix and X and B are N-by-NRHS matrices. @@ -64239,10 +64242,10 @@ module stdlib_linalg_lapack_z ! -- 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, iter - integer(ilp), intent(in) :: lda, ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info, iter + integer(${ik}$), intent(in) :: lda, ldb, ldx, n, nrhs ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) real(dp), intent(out) :: rwork(*) complex(sp), intent(out) :: swork(*) complex(dp), intent(inout) :: a(lda,*) @@ -64251,14 +64254,14 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! Parameters logical(lk), parameter :: doitref = .true. - integer(ilp), parameter :: itermax = 30 + integer(${ik}$), parameter :: itermax = 30_${ik}$ real(dp), parameter :: bwdmax = 1.0e+00_dp ! Local Scalars - integer(ilp) :: i, iiter, ptsa, ptsx + integer(${ik}$) :: i, iiter, ptsa, ptsx real(dp) :: anrm, cte, eps, rnrm, xnrm complex(dp) :: zdum ! Intrinsic Functions @@ -64268,22 +64271,22 @@ module stdlib_linalg_lapack_z ! Statement Function Definitions cabs1( zdum ) = abs( real( zdum,KIND=dp) ) + abs( aimag( zdum ) ) ! Executable Statements - info = 0 - iter = 0 + info = 0_${ik}$ + iter = 0_${ik}$ ! test the input parameters. - if( n<0 ) then - info = -1 - else if( nrhs<0 ) then - info = -2 - else if( ldaxnrm*cte )go to 10 end do ! if we are here, the nrhs normwise backward errors satisfy the ! stopping criterion. we are good to exit. - iter = 0 + iter = 0_${ik}$ return 10 continue loop_30: do iiter = 1, itermax ! convert r (in work) from double precision to single precision ! and store the result in sx. - call stdlib_zlag2c( n, nrhs, work, n, swork( ptsx ), n, info ) - if( info/=0 ) then - iter = -2 + call stdlib${ii}$_zlag2c( n, nrhs, work, n, swork( ptsx ), n, info ) + if( info/=0_${ik}$ ) then + iter = -2_${ik}$ go to 40 end if ! solve the system sa*sx = sr. - call stdlib_cgetrs( 'NO TRANSPOSE', n, nrhs, swork( ptsa ), n, ipiv,swork( ptsx ), & + call stdlib${ii}$_cgetrs( 'NO TRANSPOSE', n, nrhs, swork( ptsa ), n, ipiv,swork( ptsx ), & n, info ) ! convert sx back to double precision and update the current ! iterate. - call stdlib_clag2z( n, nrhs, swork( ptsx ), n, work, n, info ) + call stdlib${ii}$_clag2z( n, nrhs, swork( ptsx ), n, work, n, info ) do i = 1, nrhs - call stdlib_zaxpy( n, cone, work( 1, i ), 1, x( 1, i ), 1 ) + call stdlib${ii}$_zaxpy( n, cone, work( 1_${ik}$, i ), 1_${ik}$, x( 1_${ik}$, i ), 1_${ik}$ ) end do ! compute r = b - ax (r is work). - call stdlib_zlacpy( 'ALL', n, nrhs, b, ldb, work, n ) - call stdlib_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n, nrhs, n, cnegone,a, lda, x, & + call stdlib${ii}$_zlacpy( 'ALL', n, nrhs, b, ldb, work, n ) + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'NO TRANSPOSE', n, nrhs, n, cnegone,a, lda, x, & ldx, cone, work, n ) ! check whether the nrhs normwise backward errors satisfy the ! stopping criterion. if yes, set iter=iiter>0 and return. do i = 1, nrhs - xnrm = cabs1( x( stdlib_izamax( n, x( 1, i ), 1 ), i ) ) - rnrm = cabs1( work( stdlib_izamax( n, work( 1, i ), 1 ), i ) ) + xnrm = cabs1( x( stdlib${ii}$_izamax( n, x( 1_${ik}$, i ), 1_${ik}$ ), i ) ) + rnrm = cabs1( work( stdlib${ii}$_izamax( n, work( 1_${ik}$, i ), 1_${ik}$ ), i ) ) if( rnrm>xnrm*cte )go to 20 end do ! if we are here, the nrhs normwise backward errors satisfy the @@ -64380,19 +64383,19 @@ module stdlib_linalg_lapack_z ! performed iter=itermax iterations and never satisfied the stopping ! criterion, set up the iter flag accordingly and follow up on double ! precision routine. - iter = -itermax - 1 + iter = -itermax - 1_${ik}$ 40 continue ! single-precision iterative refinement failed to converge to a ! satisfactory solution, so we resort to double precision. - call stdlib_zgetrf( n, n, a, lda, ipiv, info ) + call stdlib${ii}$_zgetrf( n, n, a, lda, ipiv, info ) if( info/=0 )return - call stdlib_zlacpy( 'ALL', n, nrhs, b, ldb, x, ldx ) - call stdlib_zgetrs( 'NO TRANSPOSE', n, nrhs, a, lda, ipiv, x, ldx,info ) + call stdlib${ii}$_zlacpy( 'ALL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_zgetrs( 'NO TRANSPOSE', n, nrhs, a, lda, ipiv, x, ldx,info ) return - end subroutine stdlib_zcgesv + end subroutine stdlib${ii}$_zcgesv - pure subroutine stdlib_zgelq( m, n, a, lda, t, tsize, work, lwork,info ) + pure subroutine stdlib${ii}$_zgelq( m, n, a, lda, t, tsize, work, lwork,info ) !! ZGELQ computes an LQ factorization of a complex M-by-N matrix A: !! A = ( L 0 ) * Q !! where: @@ -64403,121 +64406,121 @@ module stdlib_linalg_lapack_z ! -- 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, tsize, lwork + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, tsize, lwork ! Array Arguments complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: t(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, lminws, mint, minw - integer(ilp) :: mb, nb, mintsz, nblcks, lwmin, lwopt, lwreq + integer(${ik}$) :: mb, nb, mintsz, nblcks, lwmin, lwopt, lwreq ! Intrinsic Functions intrinsic :: max,min,mod ! Executable Statements ! test the input arguments - info = 0 - lquery = ( tsize==-1 .or. tsize==-2 .or.lwork==-1 .or. lwork==-2 ) + info = 0_${ik}$ + lquery = ( tsize==-1_${ik}$ .or. tsize==-2_${ik}$ .or.lwork==-1_${ik}$ .or. lwork==-2_${ik}$ ) mint = .false. minw = .false. - if( tsize==-2 .or. lwork==-2 ) then - if( tsize/=-1 ) mint = .true. - if( lwork/=-1 ) minw = .true. + if( tsize==-2_${ik}$ .or. lwork==-2_${ik}$ ) then + if( tsize/=-1_${ik}$ ) mint = .true. + if( lwork/=-1_${ik}$ ) minw = .true. end if ! determine the block size - if( min( m, n )>0 ) then - mb = stdlib_ilaenv( 1, 'ZGELQ ', ' ', m, n, 1, -1 ) - nb = stdlib_ilaenv( 1, 'ZGELQ ', ' ', m, n, 2, -1 ) + if( min( m, n )>0_${ik}$ ) then + mb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGELQ ', ' ', m, n, 1_${ik}$, -1_${ik}$ ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGELQ ', ' ', m, n, 2_${ik}$, -1_${ik}$ ) else - mb = 1 + mb = 1_${ik}$ nb = n end if - if( mb>min( m, n ) .or. mb<1 ) mb = 1 + if( mb>min( m, n ) .or. mb<1_${ik}$ ) mb = 1_${ik}$ if( nb>n .or. nb<=m ) nb = n - mintsz = m + 5 + mintsz = m + 5_${ik}$ if ( nb>m .and. n>m ) then - if( mod( n - m, nb - m )==0 ) then + if( mod( n - m, nb - m )==0_${ik}$ ) then nblcks = ( n - m ) / ( nb - m ) else - nblcks = ( n - m ) / ( nb - m ) + 1 + nblcks = ( n - m ) / ( nb - m ) + 1_${ik}$ end if else - nblcks = 1 + nblcks = 1_${ik}$ end if ! determine if the workspace size satisfies minimal size if( ( n<=m ) .or. ( nb<=m ) .or. ( nb>=n ) ) then - lwmin = max( 1, n ) - lwopt = max( 1, mb*n ) + lwmin = max( 1_${ik}$, n ) + lwopt = max( 1_${ik}$, mb*n ) else - lwmin = max( 1, m ) - lwopt = max( 1, mb*m ) + lwmin = max( 1_${ik}$, m ) + lwopt = max( 1_${ik}$, mb*m ) end if lminws = .false. - if( ( tsize=lwmin ) .and. ( & + if( ( tsize=lwmin ) .and. ( & tsize>=mintsz ).and. ( .not.lquery ) ) then - if( tsize=n ) ) then - lwreq = max( 1, mb*n ) + lwreq = max( 1_${ik}$, mb*n ) else - lwreq = max( 1, mb*m ) - end if - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( lda=n ) ) then - call stdlib_zgelqt( m, n, mb, a, lda, t( 6 ), mb, work, info ) + call stdlib${ii}$_zgelqt( m, n, mb, a, lda, t( 6_${ik}$ ), mb, work, info ) else - call stdlib_zlaswlq( m, n, mb, nb, a, lda, t( 6 ), mb, work,lwork, info ) + call stdlib${ii}$_zlaswlq( m, n, mb, nb, a, lda, t( 6_${ik}$ ), mb, work,lwork, info ) end if - work( 1 ) = lwreq + work( 1_${ik}$ ) = lwreq return - end subroutine stdlib_zgelq + end subroutine stdlib${ii}$_zgelq - subroutine stdlib_zgelsd( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, rwork, & + subroutine stdlib${ii}$_zgelsd( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, rwork, & !! ZGELSD computes the minimum-norm solution to a real linear least !! squares problem: !! minimize 2-norm(| b - A*x |) @@ -64548,11 +64551,11 @@ module stdlib_linalg_lapack_z ! -- 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, rank - integer(ilp), intent(in) :: lda, ldb, lwork, m, n, nrhs + integer(${ik}$), intent(out) :: info, rank + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, nrhs real(dp), intent(in) :: rcond ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(out) :: rwork(*), s(*) complex(dp), intent(inout) :: a(lda,*), b(ldb,*) complex(dp), intent(out) :: work(*) @@ -64561,160 +64564,160 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: lquery - integer(ilp) :: iascl, ibscl, ie, il, itau, itaup, itauq, ldwork, liwork, lrwork, & + integer(${ik}$) :: iascl, ibscl, ie, il, itau, itaup, itauq, ldwork, liwork, lrwork, & maxmn, maxwrk, minmn, minwrk, mm, mnthr, nlvl, nrwork, nwork, smlsiz real(dp) :: anrm, bignum, bnrm, eps, sfmin, smlnum ! Intrinsic Functions intrinsic :: int,log,max,min,real ! Executable Statements ! test the input arguments. - info = 0 + info = 0_${ik}$ minmn = min( m, n ) maxmn = max( m, n ) - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( lda0 ) then - smlsiz = stdlib_ilaenv( 9, 'ZGELSD', ' ', 0, 0, 0, 0 ) - mnthr = stdlib_ilaenv( 6, 'ZGELSD', ' ', m, n, nrhs, -1 ) - nlvl = max( int( log( real( minmn,KIND=dp) / real( smlsiz + 1,KIND=dp) ) /log( & - two ),KIND=ilp) + 1, 0 ) - liwork = 3*minmn*nlvl + 11*minmn + ! following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + liwork = 1_${ik}$ + lrwork = 1_${ik}$ + if( minmn>0_${ik}$ ) then + smlsiz = stdlib${ii}$_ilaenv( 9_${ik}$, 'ZGELSD', ' ', 0_${ik}$, 0_${ik}$, 0_${ik}$, 0_${ik}$ ) + mnthr = stdlib${ii}$_ilaenv( 6_${ik}$, 'ZGELSD', ' ', m, n, nrhs, -1_${ik}$ ) + nlvl = max( int( log( real( minmn,KIND=dp) / real( smlsiz + 1_${ik}$,KIND=dp) ) /log( & + two ),KIND=${ik}$) + 1_${ik}$, 0_${ik}$ ) + liwork = 3_${ik}$*minmn*nlvl + 11_${ik}$*minmn mm = m if( m>=n .and. m>=mnthr ) then ! path 1a - overdetermined, with many more rows than ! columns. mm = n - maxwrk = max( maxwrk, n*stdlib_ilaenv( 1, 'ZGEQRF', ' ', m, n,-1, -1 ) ) + maxwrk = max( maxwrk, n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', m, n,-1_${ik}$, -1_${ik}$ ) ) - maxwrk = max( maxwrk, nrhs*stdlib_ilaenv( 1, 'ZUNMQR', 'LC', m,nrhs, n, -1 ) ) + maxwrk = max( maxwrk, nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', 'LC', m,nrhs, n, -1_${ik}$ ) ) end if if( m>=n ) then ! path 1 - overdetermined or exactly determined. - lrwork = 10*n + 2*n*smlsiz + 8*n*nlvl + 3*smlsiz*nrhs +max( (smlsiz+1)**2, n*(& - 1+nrhs) + 2*nrhs ) - maxwrk = max( maxwrk, 2*n + ( mm + n )*stdlib_ilaenv( 1,'ZGEBRD', ' ', mm, n, & - -1, -1 ) ) - maxwrk = max( maxwrk, 2*n + nrhs*stdlib_ilaenv( 1, 'ZUNMBR','QLC', mm, nrhs, & - n, -1 ) ) - maxwrk = max( maxwrk, 2*n + ( n - 1 )*stdlib_ilaenv( 1,'ZUNMBR', 'PLN', n, & - nrhs, n, -1 ) ) - maxwrk = max( maxwrk, 2*n + n*nrhs ) - minwrk = max( 2*n + mm, 2*n + n*nrhs ) + lrwork = 10_${ik}$*n + 2_${ik}$*n*smlsiz + 8_${ik}$*n*nlvl + 3_${ik}$*smlsiz*nrhs +max( (smlsiz+1)**2_${ik}$, n*(& + 1_${ik}$+nrhs) + 2_${ik}$*nrhs ) + maxwrk = max( maxwrk, 2_${ik}$*n + ( mm + n )*stdlib${ii}$_ilaenv( 1_${ik}$,'ZGEBRD', ' ', mm, n, & + -1_${ik}$, -1_${ik}$ ) ) + maxwrk = max( maxwrk, 2_${ik}$*n + nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMBR','QLC', mm, nrhs, & + n, -1_${ik}$ ) ) + maxwrk = max( maxwrk, 2_${ik}$*n + ( n - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'ZUNMBR', 'PLN', n, & + nrhs, n, -1_${ik}$ ) ) + maxwrk = max( maxwrk, 2_${ik}$*n + n*nrhs ) + minwrk = max( 2_${ik}$*n + mm, 2_${ik}$*n + n*nrhs ) end if if( n>m ) then - lrwork = 10*m + 2*m*smlsiz + 8*m*nlvl + 3*smlsiz*nrhs +max( (smlsiz+1)**2, n*(& - 1+nrhs) + 2*nrhs ) + lrwork = 10_${ik}$*m + 2_${ik}$*m*smlsiz + 8_${ik}$*m*nlvl + 3_${ik}$*smlsiz*nrhs +max( (smlsiz+1)**2_${ik}$, n*(& + 1_${ik}$+nrhs) + 2_${ik}$*nrhs ) if( n>=mnthr ) then ! path 2a - underdetermined, with many more columns ! than rows. - maxwrk = m + m*stdlib_ilaenv( 1, 'ZGELQF', ' ', m, n, -1,-1 ) - maxwrk = max( maxwrk, m*m + 4*m + 2*m*stdlib_ilaenv( 1,'ZGEBRD', ' ', m, m,& - -1, -1 ) ) - maxwrk = max( maxwrk, m*m + 4*m + nrhs*stdlib_ilaenv( 1,'ZUNMBR', 'QLC', m,& - nrhs, m, -1 ) ) - maxwrk = max( maxwrk, m*m + 4*m + ( m - 1 )*stdlib_ilaenv( 1,'ZUNMLQ', & - 'LC', n, nrhs, m, -1 ) ) - if( nrhs>1 ) then + maxwrk = m + m*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGELQF', ' ', m, n, -1_${ik}$,-1_${ik}$ ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + 2_${ik}$*m*stdlib${ii}$_ilaenv( 1_${ik}$,'ZGEBRD', ' ', m, m,& + -1_${ik}$, -1_${ik}$ ) ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + nrhs*stdlib${ii}$_ilaenv( 1_${ik}$,'ZUNMBR', 'QLC', m,& + nrhs, m, -1_${ik}$ ) ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + ( m - 1_${ik}$ )*stdlib${ii}$_ilaenv( 1_${ik}$,'ZUNMLQ', & + 'LC', n, nrhs, m, -1_${ik}$ ) ) + if( nrhs>1_${ik}$ ) then maxwrk = max( maxwrk, m*m + m + m*nrhs ) else - maxwrk = max( maxwrk, m*m + 2*m ) + maxwrk = max( maxwrk, m*m + 2_${ik}$*m ) end if - maxwrk = max( maxwrk, m*m + 4*m + m*nrhs ) + maxwrk = max( maxwrk, m*m + 4_${ik}$*m + m*nrhs ) ! xxx: ensure the path 2a case below is triggered. the workspace ! calculation should use queries for all routines eventually. - maxwrk = max( maxwrk,4*m+m*m+max( m, 2*m-4, nrhs, n-3*m ) ) + maxwrk = max( maxwrk,4_${ik}$*m+m*m+max( m, 2_${ik}$*m-4, nrhs, n-3*m ) ) else ! path 2 - underdetermined. - maxwrk = 2*m + ( n + m )*stdlib_ilaenv( 1, 'ZGEBRD', ' ', m,n, -1, -1 ) + maxwrk = 2_${ik}$*m + ( n + m )*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEBRD', ' ', m,n, -1_${ik}$, -1_${ik}$ ) - maxwrk = max( maxwrk, 2*m + nrhs*stdlib_ilaenv( 1, 'ZUNMBR','QLC', m, nrhs,& - m, -1 ) ) - maxwrk = max( maxwrk, 2*m + m*stdlib_ilaenv( 1, 'ZUNMBR','PLN', n, nrhs, m,& - -1 ) ) - maxwrk = max( maxwrk, 2*m + m*nrhs ) + maxwrk = max( maxwrk, 2_${ik}$*m + nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMBR','QLC', m, nrhs,& + m, -1_${ik}$ ) ) + maxwrk = max( maxwrk, 2_${ik}$*m + m*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMBR','PLN', n, nrhs, m,& + -1_${ik}$ ) ) + maxwrk = max( maxwrk, 2_${ik}$*m + m*nrhs ) end if - minwrk = max( 2*m + n, 2*m + m*nrhs ) + minwrk = max( 2_${ik}$*m + n, 2_${ik}$*m + m*nrhs ) end if end if minwrk = min( minwrk, maxwrk ) - work( 1 ) = maxwrk - iwork( 1 ) = liwork - rwork( 1 ) = lrwork + work( 1_${ik}$ ) = maxwrk + iwork( 1_${ik}$ ) = liwork + rwork( 1_${ik}$ ) = lrwork if( lworkzero .and. anrmbignum ) then ! scale matrix norm down to bignum. - call stdlib_zlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_zlaset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) - call stdlib_dlaset( 'F', minmn, 1, zero, zero, s, 1 ) - rank = 0 + call stdlib${ii}$_zlaset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) + call stdlib${ii}$_dlaset( 'F', minmn, 1_${ik}$, zero, zero, s, 1_${ik}$ ) + rank = 0_${ik}$ go to 10 end if ! scale b if max entry outside range [smlnum,bignum]. - bnrm = stdlib_zlange( 'M', m, nrhs, b, ldb, rwork ) - ibscl = 0 + bnrm = stdlib${ii}$_zlange( 'M', m, nrhs, b, ldb, rwork ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum. - call stdlib_zlascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) - ibscl = 2 + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, m, nrhs, b, ldb, info ) + ibscl = 2_${ik}$ end if ! if m < n make sure b(m+1:n,:) = 0 - if( m=n ) then ! path 1 - overdetermined or exactly determined. @@ -64722,140 +64725,140 @@ module stdlib_linalg_lapack_z if( m>=mnthr ) then ! path 1a - overdetermined, with many more rows than columns mm = n - itau = 1 + itau = 1_${ik}$ nwork = itau + n ! compute a=q*r. ! (rworkspace: need n) ! (cworkspace: need n, prefer n*nb) - call stdlib_zgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_zgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & info ) ! multiply b by transpose(q). ! (rworkspace: need n) ! (cworkspace: need nrhs, prefer nrhs*nb) - call stdlib_zunmqr( 'L', 'C', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & + call stdlib${ii}$_zunmqr( 'L', 'C', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & nwork ), lwork-nwork+1, info ) ! zero out below r. - if( n>1 ) then - call stdlib_zlaset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) + if( n>1_${ik}$ ) then + call stdlib${ii}$_zlaset( 'L', n-1, n-1, czero, czero, a( 2_${ik}$, 1_${ik}$ ),lda ) end if end if - itauq = 1 + itauq = 1_${ik}$ itaup = itauq + n nwork = itaup + n - ie = 1 + ie = 1_${ik}$ nrwork = ie + n ! bidiagonalize r in a. ! (rworkspace: need n) ! (cworkspace: need 2*n+mm, prefer 2*n+(mm+n)*nb) - call stdlib_zgebrd( mm, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_zgebrd( mm, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors of r. ! (cworkspace: need 2*n+nrhs, prefer 2*n+nrhs*nb) - call stdlib_zunmbr( 'Q', 'L', 'C', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib${ii}$_zunmbr( 'Q', 'L', 'C', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & nwork ), lwork-nwork+1, info ) ! solve the bidiagonal least squares problem. - call stdlib_zlalsd( 'U', smlsiz, n, nrhs, s, rwork( ie ), b, ldb,rcond, rank, work( & + call stdlib${ii}$_zlalsd( 'U', smlsiz, n, nrhs, s, rwork( ie ), b, ldb,rcond, rank, work( & nwork ), rwork( nrwork ),iwork, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then go to 10 end if ! multiply b by right bidiagonalizing vectors of r. - call stdlib_zunmbr( 'P', 'L', 'N', n, nrhs, n, a, lda, work( itaup ),b, ldb, work( & + call stdlib${ii}$_zunmbr( 'P', 'L', 'N', n, nrhs, n, a, lda, work( itaup ),b, ldb, work( & nwork ), lwork-nwork+1, info ) - else if( n>=mnthr .and. lwork>=4*m+m*m+max( m, 2*m-4, nrhs, n-3*m ) ) then + else if( n>=mnthr .and. lwork>=4_${ik}$*m+m*m+max( m, 2_${ik}$*m-4, nrhs, n-3*m ) ) then ! path 2a - underdetermined, with many more columns than rows ! and sufficient workspace for an efficient algorithm. ldwork = m - if( lwork>=max( 4*m+m*lda+max( m, 2*m-4, nrhs, n-3*m ),m*lda+m+m*nrhs ) )ldwork = & + if( lwork>=max( 4_${ik}$*m+m*lda+max( m, 2_${ik}$*m-4, nrhs, n-3*m ),m*lda+m+m*nrhs ) )ldwork = & lda - itau = 1 - nwork = m + 1 + itau = 1_${ik}$ + nwork = m + 1_${ik}$ ! compute a=l*q. ! (cworkspace: need 2*m, prefer m+m*nb) - call stdlib_zgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, info ) + call stdlib${ii}$_zgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, info ) il = nwork ! copy l to work(il), zeroing out above its diagonal. - call stdlib_zlacpy( 'L', m, m, a, lda, work( il ), ldwork ) - call stdlib_zlaset( 'U', m-1, m-1, czero, czero, work( il+ldwork ),ldwork ) + call stdlib${ii}$_zlacpy( 'L', m, m, a, lda, work( il ), ldwork ) + call stdlib${ii}$_zlaset( 'U', m-1, m-1, czero, czero, work( il+ldwork ),ldwork ) itauq = il + ldwork*m itaup = itauq + m nwork = itaup + m - ie = 1 + ie = 1_${ik}$ nrwork = ie + m ! bidiagonalize l in work(il). ! (rworkspace: need m) ! (cworkspace: need m*m+4*m, prefer m*m+4*m+2*m*nb) - call stdlib_zgebrd( m, m, work( il ), ldwork, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_zgebrd( m, m, work( il ), ldwork, s, rwork( ie ),work( itauq ), work( & itaup ), work( nwork ),lwork-nwork+1, info ) ! multiply b by transpose of left bidiagonalizing vectors of l. ! (cworkspace: need m*m+4*m+nrhs, prefer m*m+4*m+nrhs*nb) - call stdlib_zunmbr( 'Q', 'L', 'C', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & + call stdlib${ii}$_zunmbr( 'Q', 'L', 'C', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & ldb, work( nwork ),lwork-nwork+1, info ) ! solve the bidiagonal least squares problem. - call stdlib_zlalsd( 'U', smlsiz, m, nrhs, s, rwork( ie ), b, ldb,rcond, rank, work( & + call stdlib${ii}$_zlalsd( 'U', smlsiz, m, nrhs, s, rwork( ie ), b, ldb,rcond, rank, work( & nwork ), rwork( nrwork ),iwork, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then go to 10 end if ! multiply b by right bidiagonalizing vectors of l. - call stdlib_zunmbr( 'P', 'L', 'N', m, nrhs, m, work( il ), ldwork,work( itaup ), b, & + call stdlib${ii}$_zunmbr( 'P', 'L', 'N', m, nrhs, m, work( il ), ldwork,work( itaup ), b, & ldb, work( nwork ),lwork-nwork+1, info ) ! zero out below first m rows of b. - call stdlib_zlaset( 'F', n-m, nrhs, czero, czero, b( m+1, 1 ), ldb ) + call stdlib${ii}$_zlaset( 'F', n-m, nrhs, czero, czero, b( m+1, 1_${ik}$ ), ldb ) nwork = itau + m ! multiply transpose(q) by b. ! (cworkspace: need nrhs, prefer nrhs*nb) - call stdlib_zunmlq( 'L', 'C', n, nrhs, m, a, lda, work( itau ), b,ldb, work( nwork )& + call stdlib${ii}$_zunmlq( 'L', 'C', n, nrhs, m, a, lda, work( itau ), b,ldb, work( nwork )& , lwork-nwork+1, info ) else ! path 2 - remaining underdetermined cases. - itauq = 1 + itauq = 1_${ik}$ itaup = itauq + m nwork = itaup + m - ie = 1 + ie = 1_${ik}$ nrwork = ie + m ! bidiagonalize a. ! (rworkspace: need m) ! (cworkspace: need 2*m+n, prefer 2*m+(m+n)*nb) - call stdlib_zgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), work(& + call stdlib${ii}$_zgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), work(& nwork ), lwork-nwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors. ! (cworkspace: need 2*m+nrhs, prefer 2*m+nrhs*nb) - call stdlib_zunmbr( 'Q', 'L', 'C', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib${ii}$_zunmbr( 'Q', 'L', 'C', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & nwork ), lwork-nwork+1, info ) ! solve the bidiagonal least squares problem. - call stdlib_zlalsd( 'L', smlsiz, m, nrhs, s, rwork( ie ), b, ldb,rcond, rank, work( & + call stdlib${ii}$_zlalsd( 'L', smlsiz, m, nrhs, s, rwork( ie ), b, ldb,rcond, rank, work( & nwork ), rwork( nrwork ),iwork, info ) - if( info/=0 ) then + if( info/=0_${ik}$ ) then go to 10 end if ! multiply b by right bidiagonalizing vectors of a. - call stdlib_zunmbr( 'P', 'L', 'N', n, nrhs, m, a, lda, work( itaup ),b, ldb, work( & + call stdlib${ii}$_zunmbr( 'P', 'L', 'N', n, nrhs, m, a, lda, work( itaup ),b, ldb, work( & nwork ), lwork-nwork+1, info ) end if ! undo scaling. - if( iascl==1 ) then - call stdlib_zlascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info ) - call stdlib_dlascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn,info ) - else if( iascl==2 ) then - call stdlib_zlascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info ) - call stdlib_dlascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,info ) - end if - if( ibscl==1 ) then - call stdlib_zlascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info ) - else if( ibscl==2 ) then - call stdlib_zlascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info ) + if( iascl==1_${ik}$ ) then + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, smlnum, n, nrhs, b, ldb, info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, anrm, minmn, 1_${ik}$, s, minmn,info ) + else if( iascl==2_${ik}$ ) then + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, n, nrhs, b, ldb, info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn, 1_${ik}$, s, minmn,info ) + end if + if( ibscl==1_${ik}$ ) then + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, bnrm, n, nrhs, b, ldb, info ) + else if( ibscl==2_${ik}$ ) then + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bignum, bnrm, n, nrhs, b, ldb, info ) end if 10 continue - work( 1 ) = maxwrk - iwork( 1 ) = liwork - rwork( 1 ) = lrwork + work( 1_${ik}$ ) = maxwrk + iwork( 1_${ik}$ ) = liwork + rwork( 1_${ik}$ ) = lrwork return - end subroutine stdlib_zgelsd + end subroutine stdlib${ii}$_zgelsd - subroutine stdlib_zgelss( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, rwork, & + subroutine stdlib${ii}$_zgelss( m, n, nrhs, a, lda, b, ldb, s, rcond, rank,work, lwork, rwork, & !! ZGELSS computes the minimum norm solution to a complex linear !! least squares problem: !! Minimize 2-norm(| b - A*x |). @@ -64873,8 +64876,8 @@ module stdlib_linalg_lapack_z ! -- 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, rank - integer(ilp), intent(in) :: lda, ldb, lwork, m, n, nrhs + integer(${ik}$), intent(out) :: info, rank + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, nrhs real(dp), intent(in) :: rcond ! Array Arguments real(dp), intent(out) :: rwork(*), s(*) @@ -64885,31 +64888,31 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: lquery - integer(ilp) :: bl, chunk, i, iascl, ibscl, ie, il, irwork, itau, itaup, itauq, iwork, & + integer(${ik}$) :: bl, chunk, i, iascl, ibscl, ie, il, irwork, itau, itaup, itauq, iwork, & ldwork, maxmn, maxwrk, minmn, minwrk, mm, mnthr - integer(ilp) :: lwork_zgeqrf, lwork_zunmqr, lwork_zgebrd, lwork_zunmbr, lwork_zungbr, & + integer(${ik}$) :: lwork_zgeqrf, lwork_zunmqr, lwork_zgebrd, lwork_zunmbr, lwork_zungbr, & lwork_zunmlq, lwork_zgelqf real(dp) :: anrm, bignum, bnrm, eps, sfmin, smlnum, thr ! Local Arrays - complex(dp) :: dum(1) + complex(dp) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: max,min ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ minmn = min( m, n ) maxmn = max( m, n ) - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( lda0 ) then + ! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + if( minmn>0_${ik}$ ) then mm = m - mnthr = stdlib_ilaenv( 6, 'ZGELSS', ' ', m, n, nrhs, -1 ) + mnthr = stdlib${ii}$_ilaenv( 6_${ik}$, 'ZGELSS', ' ', m, n, nrhs, -1_${ik}$ ) if( m>=n .and. m>=mnthr ) then ! path 1a - overdetermined, with many more rows than ! columns - ! compute space needed for stdlib_zgeqrf - call stdlib_zgeqrf( m, n, a, lda, dum(1), dum(1), -1, info ) - lwork_zgeqrf = real( dum(1),KIND=dp) - ! compute space needed for stdlib_zunmqr - call stdlib_zunmqr( 'L', 'C', m, nrhs, n, a, lda, dum(1), b,ldb, dum(1), -1, & + ! compute space needed for stdlib${ii}$_zgeqrf + call stdlib${ii}$_zgeqrf( m, n, a, lda, dum(1_${ik}$), dum(1_${ik}$), -1_${ik}$, info ) + lwork_zgeqrf = real( dum(1_${ik}$),KIND=dp) + ! compute space needed for stdlib${ii}$_zunmqr + call stdlib${ii}$_zunmqr( 'L', 'C', m, nrhs, n, a, lda, dum(1_${ik}$), b,ldb, dum(1_${ik}$), -1_${ik}$, & info ) - lwork_zunmqr = real( dum(1),KIND=dp) + lwork_zunmqr = real( dum(1_${ik}$),KIND=dp) mm = n - maxwrk = max( maxwrk, n + n*stdlib_ilaenv( 1, 'ZGEQRF', ' ', m,n, -1, -1 ) ) + maxwrk = max( maxwrk, n + n*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', m,n, -1_${ik}$, -1_${ik}$ ) ) - maxwrk = max( maxwrk, n + nrhs*stdlib_ilaenv( 1, 'ZUNMQR', 'LC',m, nrhs, n, -& - 1 ) ) + maxwrk = max( maxwrk, n + nrhs*stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', 'LC',m, nrhs, n, -& + 1_${ik}$ ) ) end if if( m>=n ) then ! path 1 - overdetermined or exactly determined - ! compute space needed for stdlib_zgebrd - call stdlib_zgebrd( mm, n, a, lda, s, s, dum(1), dum(1), dum(1),-1, info ) + ! compute space needed for stdlib${ii}$_zgebrd + call stdlib${ii}$_zgebrd( mm, n, a, lda, s, s, dum(1_${ik}$), dum(1_${ik}$), dum(1_${ik}$),-1_${ik}$, info ) - lwork_zgebrd = real( dum(1),KIND=dp) - ! compute space needed for stdlib_zunmbr - call stdlib_zunmbr( 'Q', 'L', 'C', mm, nrhs, n, a, lda, dum(1),b, ldb, dum(1),& - -1, info ) - lwork_zunmbr = real( dum(1),KIND=dp) - ! compute space needed for stdlib_zungbr - call stdlib_zungbr( 'P', n, n, n, a, lda, dum(1),dum(1), -1, info ) - lwork_zungbr = real( dum(1),KIND=dp) + lwork_zgebrd = real( dum(1_${ik}$),KIND=dp) + ! compute space needed for stdlib${ii}$_zunmbr + call stdlib${ii}$_zunmbr( 'Q', 'L', 'C', mm, nrhs, n, a, lda, dum(1_${ik}$),b, ldb, dum(1_${ik}$),& + -1_${ik}$, info ) + lwork_zunmbr = real( dum(1_${ik}$),KIND=dp) + ! compute space needed for stdlib${ii}$_zungbr + call stdlib${ii}$_zungbr( 'P', n, n, n, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, info ) + lwork_zungbr = real( dum(1_${ik}$),KIND=dp) ! compute total workspace needed - maxwrk = max( maxwrk, 2*n + lwork_zgebrd ) - maxwrk = max( maxwrk, 2*n + lwork_zunmbr ) - maxwrk = max( maxwrk, 2*n + lwork_zungbr ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_zgebrd ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_zunmbr ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_zungbr ) maxwrk = max( maxwrk, n*nrhs ) - minwrk = 2*n + max( nrhs, m ) + minwrk = 2_${ik}$*n + max( nrhs, m ) end if if( n>m ) then - minwrk = 2*m + max( nrhs, n ) + minwrk = 2_${ik}$*m + max( nrhs, n ) if( n>=mnthr ) then ! path 2a - underdetermined, with many more columns ! than rows - ! compute space needed for stdlib_zgelqf - call stdlib_zgelqf( m, n, a, lda, dum(1), dum(1),-1, info ) - lwork_zgelqf = real( dum(1),KIND=dp) - ! compute space needed for stdlib_zgebrd - call stdlib_zgebrd( m, m, a, lda, s, s, dum(1), dum(1),dum(1), -1, info ) + ! compute space needed for stdlib${ii}$_zgelqf + call stdlib${ii}$_zgelqf( m, n, a, lda, dum(1_${ik}$), dum(1_${ik}$),-1_${ik}$, info ) + lwork_zgelqf = real( dum(1_${ik}$),KIND=dp) + ! compute space needed for stdlib${ii}$_zgebrd + call stdlib${ii}$_zgebrd( m, m, a, lda, s, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, info ) - lwork_zgebrd = real( dum(1),KIND=dp) - ! compute space needed for stdlib_zunmbr - call stdlib_zunmbr( 'Q', 'L', 'C', m, nrhs, n, a, lda,dum(1), b, ldb, dum(& - 1), -1, info ) - lwork_zunmbr = real( dum(1),KIND=dp) - ! compute space needed for stdlib_zungbr - call stdlib_zungbr( 'P', m, m, m, a, lda, dum(1),dum(1), -1, info ) - lwork_zungbr = real( dum(1),KIND=dp) - ! compute space needed for stdlib_zunmlq - call stdlib_zunmlq( 'L', 'C', n, nrhs, m, a, lda, dum(1),b, ldb, dum(1), -& - 1, info ) - lwork_zunmlq = real( dum(1),KIND=dp) + lwork_zgebrd = real( dum(1_${ik}$),KIND=dp) + ! compute space needed for stdlib${ii}$_zunmbr + call stdlib${ii}$_zunmbr( 'Q', 'L', 'C', m, nrhs, n, a, lda,dum(1_${ik}$), b, ldb, dum(& + 1_${ik}$), -1_${ik}$, info ) + lwork_zunmbr = real( dum(1_${ik}$),KIND=dp) + ! compute space needed for stdlib${ii}$_zungbr + call stdlib${ii}$_zungbr( 'P', m, m, m, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, info ) + lwork_zungbr = real( dum(1_${ik}$),KIND=dp) + ! compute space needed for stdlib${ii}$_zunmlq + call stdlib${ii}$_zunmlq( 'L', 'C', n, nrhs, m, a, lda, dum(1_${ik}$),b, ldb, dum(1_${ik}$), -& + 1_${ik}$, info ) + lwork_zunmlq = real( dum(1_${ik}$),KIND=dp) ! compute total workspace needed maxwrk = m + lwork_zgelqf - maxwrk = max( maxwrk, 3*m + m*m + lwork_zgebrd ) - maxwrk = max( maxwrk, 3*m + m*m + lwork_zunmbr ) - maxwrk = max( maxwrk, 3*m + m*m + lwork_zungbr ) - if( nrhs>1 ) then + maxwrk = max( maxwrk, 3_${ik}$*m + m*m + lwork_zgebrd ) + maxwrk = max( maxwrk, 3_${ik}$*m + m*m + lwork_zunmbr ) + maxwrk = max( maxwrk, 3_${ik}$*m + m*m + lwork_zungbr ) + if( nrhs>1_${ik}$ ) then maxwrk = max( maxwrk, m*m + m + m*nrhs ) else - maxwrk = max( maxwrk, m*m + 2*m ) + maxwrk = max( maxwrk, m*m + 2_${ik}$*m ) end if maxwrk = max( maxwrk, m + lwork_zunmlq ) else ! path 2 - underdetermined - ! compute space needed for stdlib_zgebrd - call stdlib_zgebrd( m, n, a, lda, s, s, dum(1), dum(1),dum(1), -1, info ) + ! compute space needed for stdlib${ii}$_zgebrd + call stdlib${ii}$_zgebrd( m, n, a, lda, s, s, dum(1_${ik}$), dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, info ) - lwork_zgebrd = real( dum(1),KIND=dp) - ! compute space needed for stdlib_zunmbr - call stdlib_zunmbr( 'Q', 'L', 'C', m, nrhs, m, a, lda,dum(1), b, ldb, dum(& - 1), -1, info ) - lwork_zunmbr = real( dum(1),KIND=dp) - ! compute space needed for stdlib_zungbr - call stdlib_zungbr( 'P', m, n, m, a, lda, dum(1),dum(1), -1, info ) - lwork_zungbr = real( dum(1),KIND=dp) - maxwrk = 2*m + lwork_zgebrd - maxwrk = max( maxwrk, 2*m + lwork_zunmbr ) - maxwrk = max( maxwrk, 2*m + lwork_zungbr ) + lwork_zgebrd = real( dum(1_${ik}$),KIND=dp) + ! compute space needed for stdlib${ii}$_zunmbr + call stdlib${ii}$_zunmbr( 'Q', 'L', 'C', m, nrhs, m, a, lda,dum(1_${ik}$), b, ldb, dum(& + 1_${ik}$), -1_${ik}$, info ) + lwork_zunmbr = real( dum(1_${ik}$),KIND=dp) + ! compute space needed for stdlib${ii}$_zungbr + call stdlib${ii}$_zungbr( 'P', m, n, m, a, lda, dum(1_${ik}$),dum(1_${ik}$), -1_${ik}$, info ) + lwork_zungbr = real( dum(1_${ik}$),KIND=dp) + maxwrk = 2_${ik}$*m + lwork_zgebrd + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_zunmbr ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_zungbr ) maxwrk = max( maxwrk, n*nrhs ) end if end if maxwrk = max( minwrk, maxwrk ) end if - work( 1 ) = maxwrk - if( lworkzero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_zlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_zlaset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) - call stdlib_dlaset( 'F', minmn, 1, zero, zero, s, minmn ) - rank = 0 + call stdlib${ii}$_zlaset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) + call stdlib${ii}$_dlaset( 'F', minmn, 1_${ik}$, zero, zero, s, minmn ) + rank = 0_${ik}$ go to 70 end if ! scale b if max element outside range [smlnum,bignum] - bnrm = stdlib_zlange( 'M', m, nrhs, b, ldb, rwork ) - ibscl = 0 + bnrm = stdlib${ii}$_zlange( 'M', m, nrhs, b, ldb, rwork ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_zlascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) - ibscl = 2 + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, m, nrhs, b, ldb, info ) + ibscl = 2_${ik}$ end if ! overdetermined case if( m>=n ) then @@ -65072,115 +65075,115 @@ module stdlib_linalg_lapack_z if( m>=mnthr ) then ! path 1a - overdetermined, with many more rows than columns mm = n - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: none) - call stdlib_zgeqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & + call stdlib${ii}$_zgeqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & info ) ! multiply b by transpose(q) ! (cworkspace: need n+nrhs, prefer n+nrhs*nb) ! (rworkspace: none) - call stdlib_zunmqr( 'L', 'C', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & + call stdlib${ii}$_zunmqr( 'L', 'C', m, nrhs, n, a, lda, work( itau ), b,ldb, work( & iwork ), lwork-iwork+1, info ) ! zero out below r - if( n>1 )call stdlib_zlaset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) + if( n>1_${ik}$ )call stdlib${ii}$_zlaset( 'L', n-1, n-1, czero, czero, a( 2_${ik}$, 1_${ik}$ ),lda ) end if - ie = 1 - itauq = 1 + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + n iwork = itaup + n ! bidiagonalize r in a ! (cworkspace: need 2*n+mm, prefer 2*n+(mm+n)*nb) ! (rworkspace: need n) - call stdlib_zgebrd( mm, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_zgebrd( mm, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors of r ! (cworkspace: need 2*n+nrhs, prefer 2*n+nrhs*nb) ! (rworkspace: none) - call stdlib_zunmbr( 'Q', 'L', 'C', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib${ii}$_zunmbr( 'Q', 'L', 'C', mm, nrhs, n, a, lda, work( itauq ),b, ldb, work( & iwork ), lwork-iwork+1, info ) ! generate right bidiagonalizing vectors of r in a ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: none) - call stdlib_zungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-iwork+& - 1, info ) + call stdlib${ii}$_zungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-iwork+& + 1_${ik}$, info ) irwork = ie + n ! perform bidiagonal qr iteration ! multiply b by transpose of left singular vectors ! compute right singular vectors in a ! (cworkspace: none) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', n, n, 0, nrhs, s, rwork( ie ), a, lda, dum,1, b, ldb, & + call stdlib${ii}$_zbdsqr( 'U', n, n, 0_${ik}$, nrhs, s, rwork( ie ), a, lda, dum,1_${ik}$, b, ldb, & rwork( irwork ), info ) if( info/=0 )go to 70 ! multiply b by reciprocals of singular values - thr = max( rcond*s( 1 ), sfmin ) - if( rcondthr ) then - call stdlib_zdrscl( nrhs, s( i ), b( i, 1 ), ldb ) - rank = rank + 1 + call stdlib${ii}$_zdrscl( nrhs, s( i ), b( i, 1_${ik}$ ), ldb ) + rank = rank + 1_${ik}$ else - call stdlib_zlaset( 'F', 1, nrhs, czero, czero, b( i, 1 ), ldb ) + call stdlib${ii}$_zlaset( 'F', 1_${ik}$, nrhs, czero, czero, b( i, 1_${ik}$ ), ldb ) end if end do ! multiply b by right singular vectors ! (cworkspace: need n, prefer n*nrhs) ! (rworkspace: none) - if( lwork>=ldb*nrhs .and. nrhs>1 ) then - call stdlib_zgemm( 'C', 'N', n, nrhs, n, cone, a, lda, b, ldb,czero, work, ldb ) + if( lwork>=ldb*nrhs .and. nrhs>1_${ik}$ ) then + call stdlib${ii}$_zgemm( 'C', 'N', n, nrhs, n, cone, a, lda, b, ldb,czero, work, ldb ) - call stdlib_zlacpy( 'G', n, nrhs, work, ldb, b, ldb ) - else if( nrhs>1 ) then + call stdlib${ii}$_zlacpy( 'G', n, nrhs, work, ldb, b, ldb ) + else if( nrhs>1_${ik}$ ) then chunk = lwork / n do i = 1, nrhs, chunk bl = min( nrhs-i+1, chunk ) - call stdlib_zgemm( 'C', 'N', n, bl, n, cone, a, lda, b( 1, i ),ldb, czero, & + call stdlib${ii}$_zgemm( 'C', 'N', n, bl, n, cone, a, lda, b( 1_${ik}$, i ),ldb, czero, & work, n ) - call stdlib_zlacpy( 'G', n, bl, work, n, b( 1, i ), ldb ) + call stdlib${ii}$_zlacpy( 'G', n, bl, work, n, b( 1_${ik}$, i ), ldb ) end do else - call stdlib_zgemv( 'C', n, n, cone, a, lda, b, 1, czero, work, 1 ) - call stdlib_zcopy( n, work, 1, b, 1 ) + call stdlib${ii}$_zgemv( 'C', n, n, cone, a, lda, b, 1_${ik}$, czero, work, 1_${ik}$ ) + call stdlib${ii}$_zcopy( n, work, 1_${ik}$, b, 1_${ik}$ ) end if - else if( n>=mnthr .and. lwork>=3*m+m*m+max( m, nrhs, n-2*m ) )then + else if( n>=mnthr .and. lwork>=3_${ik}$*m+m*m+max( m, nrhs, n-2*m ) )then ! underdetermined case, m much less than n ! path 2a - underdetermined, with many more columns than rows ! and sufficient workspace for an efficient algorithm ldwork = m - if( lwork>=3*m+m*lda+max( m, nrhs, n-2*m ) )ldwork = lda - itau = 1 - iwork = m + 1 + if( lwork>=3_${ik}$*m+m*lda+max( m, nrhs, n-2*m ) )ldwork = lda + itau = 1_${ik}$ + iwork = m + 1_${ik}$ ! compute a=l*q ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: none) - call stdlib_zgelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, info ) + call stdlib${ii}$_zgelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, info ) il = iwork ! copy l to work(il), zeroing out above it - call stdlib_zlacpy( 'L', m, m, a, lda, work( il ), ldwork ) - call stdlib_zlaset( 'U', m-1, m-1, czero, czero, work( il+ldwork ),ldwork ) - ie = 1 + call stdlib${ii}$_zlacpy( 'L', m, m, a, lda, work( il ), ldwork ) + call stdlib${ii}$_zlaset( 'U', m-1, m-1, czero, czero, work( il+ldwork ),ldwork ) + ie = 1_${ik}$ itauq = il + ldwork*m itaup = itauq + m iwork = itaup + m ! bidiagonalize l in work(il) ! (cworkspace: need m*m+4*m, prefer m*m+3*m+2*m*nb) ! (rworkspace: need m) - call stdlib_zgebrd( m, m, work( il ), ldwork, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_zgebrd( m, m, work( il ), ldwork, s, rwork( ie ),work( itauq ), work( & itaup ), work( iwork ),lwork-iwork+1, info ) ! multiply b by transpose of left bidiagonalizing vectors of l ! (cworkspace: need m*m+3*m+nrhs, prefer m*m+3*m+nrhs*nb) ! (rworkspace: none) - call stdlib_zunmbr( 'Q', 'L', 'C', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & + call stdlib${ii}$_zunmbr( 'Q', 'L', 'C', m, nrhs, m, work( il ), ldwork,work( itauq ), b, & ldb, work( iwork ),lwork-iwork+1, info ) ! generate right bidiagonalizing vectors of r in work(il) ! (cworkspace: need m*m+4*m-1, prefer m*m+3*m+(m-1)*nb) ! (rworkspace: none) - call stdlib_zungbr( 'P', m, m, m, work( il ), ldwork, work( itaup ),work( iwork ), & + call stdlib${ii}$_zungbr( 'P', m, m, m, work( il ), ldwork, work( itaup ),work( iwork ), & lwork-iwork+1, info ) irwork = ie + m ! perform bidiagonal qr iteration, computing right singular @@ -65188,132 +65191,132 @@ module stdlib_linalg_lapack_z ! left singular vectors ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', m, m, 0, nrhs, s, rwork( ie ), work( il ),ldwork, a, lda, & + call stdlib${ii}$_zbdsqr( 'U', m, m, 0_${ik}$, nrhs, s, rwork( ie ), work( il ),ldwork, a, lda, & b, ldb, rwork( irwork ), info ) if( info/=0 )go to 70 ! multiply b by reciprocals of singular values - thr = max( rcond*s( 1 ), sfmin ) - if( rcondthr ) then - call stdlib_zdrscl( nrhs, s( i ), b( i, 1 ), ldb ) - rank = rank + 1 + call stdlib${ii}$_zdrscl( nrhs, s( i ), b( i, 1_${ik}$ ), ldb ) + rank = rank + 1_${ik}$ else - call stdlib_zlaset( 'F', 1, nrhs, czero, czero, b( i, 1 ), ldb ) + call stdlib${ii}$_zlaset( 'F', 1_${ik}$, nrhs, czero, czero, b( i, 1_${ik}$ ), ldb ) end if end do iwork = il + m*ldwork ! multiply b by right singular vectors of l in work(il) ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nrhs) ! (rworkspace: none) - if( lwork>=ldb*nrhs+iwork-1 .and. nrhs>1 ) then - call stdlib_zgemm( 'C', 'N', m, nrhs, m, cone, work( il ), ldwork,b, ldb, czero, & + if( lwork>=ldb*nrhs+iwork-1 .and. nrhs>1_${ik}$ ) then + call stdlib${ii}$_zgemm( 'C', 'N', m, nrhs, m, cone, work( il ), ldwork,b, ldb, czero, & work( iwork ), ldb ) - call stdlib_zlacpy( 'G', m, nrhs, work( iwork ), ldb, b, ldb ) - else if( nrhs>1 ) then + call stdlib${ii}$_zlacpy( 'G', m, nrhs, work( iwork ), ldb, b, ldb ) + else if( nrhs>1_${ik}$ ) then chunk = ( lwork-iwork+1 ) / m do i = 1, nrhs, chunk bl = min( nrhs-i+1, chunk ) - call stdlib_zgemm( 'C', 'N', m, bl, m, cone, work( il ), ldwork,b( 1, i ), & + call stdlib${ii}$_zgemm( 'C', 'N', m, bl, m, cone, work( il ), ldwork,b( 1_${ik}$, i ), & ldb, czero, work( iwork ), m ) - call stdlib_zlacpy( 'G', m, bl, work( iwork ), m, b( 1, i ),ldb ) + call stdlib${ii}$_zlacpy( 'G', m, bl, work( iwork ), m, b( 1_${ik}$, i ),ldb ) end do else - call stdlib_zgemv( 'C', m, m, cone, work( il ), ldwork, b( 1, 1 ),1, czero, work(& - iwork ), 1 ) - call stdlib_zcopy( m, work( iwork ), 1, b( 1, 1 ), 1 ) + call stdlib${ii}$_zgemv( 'C', m, m, cone, work( il ), ldwork, b( 1_${ik}$, 1_${ik}$ ),1_${ik}$, czero, work(& + iwork ), 1_${ik}$ ) + call stdlib${ii}$_zcopy( m, work( iwork ), 1_${ik}$, b( 1_${ik}$, 1_${ik}$ ), 1_${ik}$ ) end if ! zero out below first m rows of b - call stdlib_zlaset( 'F', n-m, nrhs, czero, czero, b( m+1, 1 ), ldb ) + call stdlib${ii}$_zlaset( 'F', n-m, nrhs, czero, czero, b( m+1, 1_${ik}$ ), ldb ) iwork = itau + m ! multiply transpose(q) by b ! (cworkspace: need m+nrhs, prefer m+nhrs*nb) ! (rworkspace: none) - call stdlib_zunmlq( 'L', 'C', n, nrhs, m, a, lda, work( itau ), b,ldb, work( iwork )& + call stdlib${ii}$_zunmlq( 'L', 'C', n, nrhs, m, a, lda, work( itau ), b,ldb, work( iwork )& , lwork-iwork+1, info ) else ! path 2 - remaining underdetermined cases - ie = 1 - itauq = 1 + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + m iwork = itaup + m ! bidiagonalize a ! (cworkspace: need 3*m, prefer 2*m+(m+n)*nb) ! (rworkspace: need n) - call stdlib_zgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), work(& + call stdlib${ii}$_zgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), work(& iwork ), lwork-iwork+1,info ) ! multiply b by transpose of left bidiagonalizing vectors ! (cworkspace: need 2*m+nrhs, prefer 2*m+nrhs*nb) ! (rworkspace: none) - call stdlib_zunmbr( 'Q', 'L', 'C', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & + call stdlib${ii}$_zunmbr( 'Q', 'L', 'C', m, nrhs, n, a, lda, work( itauq ),b, ldb, work( & iwork ), lwork-iwork+1, info ) ! generate right bidiagonalizing vectors in a ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: none) - call stdlib_zungbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-iwork+& - 1, info ) + call stdlib${ii}$_zungbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-iwork+& + 1_${ik}$, info ) irwork = ie + m ! perform bidiagonal qr iteration, ! computing right singular vectors of a in a and ! multiplying b by transpose of left singular vectors ! (cworkspace: none) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'L', m, n, 0, nrhs, s, rwork( ie ), a, lda, dum,1, b, ldb, & + call stdlib${ii}$_zbdsqr( 'L', m, n, 0_${ik}$, nrhs, s, rwork( ie ), a, lda, dum,1_${ik}$, b, ldb, & rwork( irwork ), info ) if( info/=0 )go to 70 ! multiply b by reciprocals of singular values - thr = max( rcond*s( 1 ), sfmin ) - if( rcondthr ) then - call stdlib_zdrscl( nrhs, s( i ), b( i, 1 ), ldb ) - rank = rank + 1 + call stdlib${ii}$_zdrscl( nrhs, s( i ), b( i, 1_${ik}$ ), ldb ) + rank = rank + 1_${ik}$ else - call stdlib_zlaset( 'F', 1, nrhs, czero, czero, b( i, 1 ), ldb ) + call stdlib${ii}$_zlaset( 'F', 1_${ik}$, nrhs, czero, czero, b( i, 1_${ik}$ ), ldb ) end if end do ! multiply b by right singular vectors of a ! (cworkspace: need n, prefer n*nrhs) ! (rworkspace: none) - if( lwork>=ldb*nrhs .and. nrhs>1 ) then - call stdlib_zgemm( 'C', 'N', n, nrhs, m, cone, a, lda, b, ldb,czero, work, ldb ) + if( lwork>=ldb*nrhs .and. nrhs>1_${ik}$ ) then + call stdlib${ii}$_zgemm( 'C', 'N', n, nrhs, m, cone, a, lda, b, ldb,czero, work, ldb ) - call stdlib_zlacpy( 'G', n, nrhs, work, ldb, b, ldb ) - else if( nrhs>1 ) then + call stdlib${ii}$_zlacpy( 'G', n, nrhs, work, ldb, b, ldb ) + else if( nrhs>1_${ik}$ ) then chunk = lwork / n do i = 1, nrhs, chunk bl = min( nrhs-i+1, chunk ) - call stdlib_zgemm( 'C', 'N', n, bl, m, cone, a, lda, b( 1, i ),ldb, czero, & + call stdlib${ii}$_zgemm( 'C', 'N', n, bl, m, cone, a, lda, b( 1_${ik}$, i ),ldb, czero, & work, n ) - call stdlib_zlacpy( 'F', n, bl, work, n, b( 1, i ), ldb ) + call stdlib${ii}$_zlacpy( 'F', n, bl, work, n, b( 1_${ik}$, i ), ldb ) end do else - call stdlib_zgemv( 'C', m, n, cone, a, lda, b, 1, czero, work, 1 ) - call stdlib_zcopy( n, work, 1, b, 1 ) + call stdlib${ii}$_zgemv( 'C', m, n, cone, a, lda, b, 1_${ik}$, czero, work, 1_${ik}$ ) + call stdlib${ii}$_zcopy( n, work, 1_${ik}$, b, 1_${ik}$ ) end if end if ! undo scaling - if( iascl==1 ) then - call stdlib_zlascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info ) - call stdlib_dlascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn,info ) - else if( iascl==2 ) then - call stdlib_zlascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info ) - call stdlib_dlascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,info ) - end if - if( ibscl==1 ) then - call stdlib_zlascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info ) - else if( ibscl==2 ) then - call stdlib_zlascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info ) + if( iascl==1_${ik}$ ) then + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, smlnum, n, nrhs, b, ldb, info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, anrm, minmn, 1_${ik}$, s, minmn,info ) + else if( iascl==2_${ik}$ ) then + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, n, nrhs, b, ldb, info ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn, 1_${ik}$, s, minmn,info ) + end if + if( ibscl==1_${ik}$ ) then + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, bnrm, n, nrhs, b, ldb, info ) + else if( ibscl==2_${ik}$ ) then + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bignum, bnrm, n, nrhs, b, ldb, info ) end if 70 continue - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_zgelss + end subroutine stdlib${ii}$_zgelss - subroutine stdlib_zgelsy( m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank,work, lwork, rwork, & + subroutine stdlib${ii}$_zgelsy( m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank,work, lwork, rwork, & !! ZGELSY computes the minimum-norm solution to a complex linear least !! squares problem: !! minimize || A * X - B || @@ -65351,24 +65354,24 @@ module stdlib_linalg_lapack_z ! -- 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, rank - integer(ilp), intent(in) :: lda, ldb, lwork, m, n, nrhs + integer(${ik}$), intent(out) :: info, rank + integer(${ik}$), intent(in) :: lda, ldb, lwork, m, n, nrhs real(dp), intent(in) :: rcond ! Array Arguments - integer(ilp), intent(inout) :: jpvt(*) + integer(${ik}$), intent(inout) :: jpvt(*) real(dp), intent(out) :: rwork(*) complex(dp), intent(inout) :: a(lda,*), b(ldb,*) complex(dp), intent(out) :: work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: imax = 1 - integer(ilp), parameter :: imin = 2 + integer(${ik}$), parameter :: imax = 1_${ik}$ + integer(${ik}$), parameter :: imin = 2_${ik}$ ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, iascl, ibscl, ismax, ismin, j, lwkopt, mn, nb, nb1, nb2, nb3, & + integer(${ik}$) :: i, iascl, ibscl, ismax, ismin, j, lwkopt, mn, nb, nb1, nb2, nb3, & nb4 real(dp) :: anrm, bignum, bnrm, smax, smaxpr, smin, sminpr, smlnum, wsize complex(dp) :: c1, c2, s1, s2 @@ -65376,77 +65379,77 @@ module stdlib_linalg_lapack_z intrinsic :: abs,real,cmplx,max,min ! Executable Statements mn = min( m, n ) - ismin = mn + 1 - ismax = 2*mn + 1 + ismin = mn + 1_${ik}$ + ismax = 2_${ik}$*mn + 1_${ik}$ ! test the input arguments. - info = 0 - nb1 = stdlib_ilaenv( 1, 'ZGEQRF', ' ', m, n, -1, -1 ) - nb2 = stdlib_ilaenv( 1, 'ZGERQF', ' ', m, n, -1, -1 ) - nb3 = stdlib_ilaenv( 1, 'ZUNMQR', ' ', m, n, nrhs, -1 ) - nb4 = stdlib_ilaenv( 1, 'ZUNMRQ', ' ', m, n, nrhs, -1 ) + info = 0_${ik}$ + nb1 = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) + nb2 = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGERQF', ' ', m, n, -1_${ik}$, -1_${ik}$ ) + nb3 = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', ' ', m, n, nrhs, -1_${ik}$ ) + nb4 = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMRQ', ' ', m, n, nrhs, -1_${ik}$ ) nb = max( nb1, nb2, nb3, nb4 ) - lwkopt = max( 1, mn+2*n+nb*( n+1 ), 2*mn+nb*nrhs ) - work( 1 ) = cmplx( lwkopt,KIND=dp) - lquery = ( lwork==-1 ) - if( m<0 ) then - info = -1 - else if( n<0 ) then - info = -2 - else if( nrhs<0 ) then - info = -3 - else if( ldazero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_zlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_zlaset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) - rank = 0 + call stdlib${ii}$_zlaset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) + rank = 0_${ik}$ go to 70 end if - bnrm = stdlib_zlange( 'M', m, nrhs, b, ldb, rwork ) - ibscl = 0 + bnrm = stdlib${ii}$_zlange( 'M', m, nrhs, b, ldb, rwork ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_zlascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) - ibscl = 2 + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, m, nrhs, b, ldb, info ) + ibscl = 2_${ik}$ end if ! compute qr factorization with column pivoting of a: ! a * p = q * r - call stdlib_zgeqp3( m, n, a, lda, jpvt, work( 1 ), work( mn+1 ),lwork-mn, rwork, info ) + call stdlib${ii}$_zgeqp3( m, n, a, lda, jpvt, work( 1_${ik}$ ), work( mn+1 ),lwork-mn, rwork, info ) wsize = mn + real( work( mn+1 ),KIND=dp) ! complex workspace: mn+nb*(n+1). real workspace 2*n. @@ -65454,21 +65457,21 @@ module stdlib_linalg_lapack_z ! determine rank using incremental condition estimation work( ismin ) = cone work( ismax ) = cone - smax = abs( a( 1, 1 ) ) + smax = abs( a( 1_${ik}$, 1_${ik}$ ) ) smin = smax - if( abs( a( 1, 1 ) )==zero ) then - rank = 0 - call stdlib_zlaset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) + if( abs( a( 1_${ik}$, 1_${ik}$ ) )==zero ) then + rank = 0_${ik}$ + call stdlib${ii}$_zlaset( 'F', max( m, n ), nrhs, czero, czero, b, ldb ) go to 70 else - rank = 1 + rank = 1_${ik}$ end if 10 continue if( rankk ) .and. ( mn>k ) ) then - if( mod( mn - k, nb - k ) == 0 ) then + if( mod( mn - k, nb - k ) == 0_${ik}$ ) then nblcks = ( mn - k ) / ( nb - k ) else - nblcks = ( mn - k ) / ( nb - k ) + 1 + nblcks = ( mn - k ) / ( nb - k ) + 1_${ik}$ end if else - nblcks = 1 + nblcks = 1_${ik}$ end if - info = 0 + info = 0_${ik}$ 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>mn ) then - info = -5 - else if( ldamn ) then + info = -5_${ik}$ + else if( lda=max( m, n, & k ) ) ) then - call stdlib_zgemlqt( side, trans, m, n, k, mb, a, lda,t( 6 ), mb, c, ldc, work, info & + call stdlib${ii}$_zgemlqt( side, trans, m, n, k, mb, a, lda,t( 6_${ik}$ ), mb, c, ldc, work, info & ) else - call stdlib_zlamswlq( side, trans, m, n, k, mb, nb, a, lda, t( 6 ),mb, c, ldc, work, & + call stdlib${ii}$_zlamswlq( side, trans, m, n, k, mb, nb, a, lda, t( 6_${ik}$ ),mb, c, ldc, work, & lwork, info ) end if - work( 1 ) = lw + work( 1_${ik}$ ) = lw return - end subroutine stdlib_zgemlq + end subroutine stdlib${ii}$_zgemlq - pure subroutine stdlib_zgemqr( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, & + pure subroutine stdlib${ii}$_zgemqr( side, trans, m, n, k, a, lda, t, tsize,c, ldc, work, lwork, & !! ZGEMQR overwrites the general real M-by-N matrix C with !! SIDE = 'L' SIDE = 'R' !! TRANS = 'N': Q * C C * Q @@ -65649,8 +65652,8 @@ module stdlib_linalg_lapack_z ! -- 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) :: lda, m, n, k, tsize, lwork, ldc + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, k, tsize, lwork, ldc ! Array Arguments complex(dp), intent(in) :: a(lda,*), t(*) complex(dp), intent(inout) :: c(ldc,*) @@ -65658,18 +65661,18 @@ module stdlib_linalg_lapack_z ! ===================================================================== ! Local Scalars logical(lk) :: left, right, tran, notran, lquery - integer(ilp) :: mb, nb, lw, nblcks, mn + integer(${ik}$) :: mb, nb, lw, nblcks, mn ! Intrinsic Functions intrinsic :: int,max,min,mod ! Executable Statements ! test the input arguments - lquery = lwork==-1 + lquery = lwork==-1_${ik}$ notran = stdlib_lsame( trans, 'N' ) tran = stdlib_lsame( trans, 'C' ) left = stdlib_lsame( side, 'L' ) right = stdlib_lsame( side, 'R' ) - mb = int( t( 2 ),KIND=ilp) - nb = int( t( 3 ),KIND=ilp) + mb = int( t( 2_${ik}$ ),KIND=${ik}$) + nb = int( t( 3_${ik}$ ),KIND=${ik}$) if( left ) then lw = n * nb mn = m @@ -65678,61 +65681,61 @@ module stdlib_linalg_lapack_z mn = n end if if( ( mb>k ) .and. ( mn>k ) ) then - if( mod( mn - k, mb - k )==0 ) then + if( mod( mn - k, mb - k )==0_${ik}$ ) then nblcks = ( mn - k ) / ( mb - k ) else - nblcks = ( mn - k ) / ( mb - k ) + 1 + nblcks = ( mn - k ) / ( mb - k ) + 1_${ik}$ end if else - nblcks = 1 + nblcks = 1_${ik}$ end if - info = 0 + info = 0_${ik}$ 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>mn ) then - info = -5 - else if( ldamn ) then + info = -5_${ik}$ + else if( lda=max( m, n, & k ) ) ) then - call stdlib_zgemqrt( side, trans, m, n, k, nb, a, lda, t( 6 ),nb, c, ldc, work, info & + call stdlib${ii}$_zgemqrt( side, trans, m, n, k, nb, a, lda, t( 6_${ik}$ ),nb, c, ldc, work, info & ) else - call stdlib_zlamtsqr( side, trans, m, n, k, mb, nb, a, lda, t( 6 ),nb, c, ldc, work, & + call stdlib${ii}$_zlamtsqr( side, trans, m, n, k, mb, nb, a, lda, t( 6_${ik}$ ),nb, c, ldc, work, & lwork, info ) end if - work( 1 ) = lw + work( 1_${ik}$ ) = lw return - end subroutine stdlib_zgemqr + end subroutine stdlib${ii}$_zgemqr - pure subroutine stdlib_zgeqr( m, n, a, lda, t, tsize, work, lwork,info ) + pure subroutine stdlib${ii}$_zgeqr( m, n, a, lda, t, tsize, work, lwork,info ) !! ZGEQR computes a QR factorization of a complex M-by-N matrix A: !! A = Q * ( R ), !! ( 0 ) @@ -65744,110 +65747,110 @@ module stdlib_linalg_lapack_z ! -- 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, tsize, lwork + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, m, n, tsize, lwork ! Array Arguments complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: t(*), work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery, lminws, mint, minw - integer(ilp) :: mb, nb, mintsz, nblcks + integer(${ik}$) :: mb, nb, mintsz, nblcks ! Intrinsic Functions intrinsic :: max,min,mod ! Executable Statements ! test the input arguments - info = 0 - lquery = ( tsize==-1 .or. tsize==-2 .or.lwork==-1 .or. lwork==-2 ) + info = 0_${ik}$ + lquery = ( tsize==-1_${ik}$ .or. tsize==-2_${ik}$ .or.lwork==-1_${ik}$ .or. lwork==-2_${ik}$ ) mint = .false. minw = .false. - if( tsize==-2 .or. lwork==-2 ) then - if( tsize/=-1 ) mint = .true. - if( lwork/=-1 ) minw = .true. + if( tsize==-2_${ik}$ .or. lwork==-2_${ik}$ ) then + if( tsize/=-1_${ik}$ ) mint = .true. + if( lwork/=-1_${ik}$ ) minw = .true. end if ! determine the block size - if( min ( m, n )>0 ) then - mb = stdlib_ilaenv( 1, 'ZGEQR ', ' ', m, n, 1, -1 ) - nb = stdlib_ilaenv( 1, 'ZGEQR ', ' ', m, n, 2, -1 ) + if( min ( m, n )>0_${ik}$ ) then + mb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQR ', ' ', m, n, 1_${ik}$, -1_${ik}$ ) + nb = stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQR ', ' ', m, n, 2_${ik}$, -1_${ik}$ ) else mb = m - nb = 1 + nb = 1_${ik}$ end if if( mb>m .or. mb<=n ) mb = m - if( nb>min( m, n ) .or. nb<1 ) nb = 1 - mintsz = n + 5 + if( nb>min( m, n ) .or. nb<1_${ik}$ ) nb = 1_${ik}$ + mintsz = n + 5_${ik}$ if( mb>n .and. m>n ) then - if( mod( m - n, mb - n )==0 ) then + if( mod( m - n, mb - n )==0_${ik}$ ) then nblcks = ( m - n ) / ( mb - n ) else - nblcks = ( m - n ) / ( mb - n ) + 1 + nblcks = ( m - n ) / ( mb - n ) + 1_${ik}$ end if else - nblcks = 1 + nblcks = 1_${ik}$ end if ! determine if the workspace size satisfies minimal size lminws = .false. - if( ( tsize=n ) .and. ( & + if( ( tsize=n ) .and. ( & tsize>=mintsz ).and. ( .not.lquery ) ) then - if( tsize=m ) ) then - call stdlib_zgeqrt( m, n, nb, a, lda, t( 6 ), nb, work, info ) + call stdlib${ii}$_zgeqrt( m, n, nb, a, lda, t( 6_${ik}$ ), nb, work, info ) else - call stdlib_zlatsqr( m, n, mb, nb, a, lda, t( 6 ), nb, work,lwork, info ) + call stdlib${ii}$_zlatsqr( m, n, mb, nb, a, lda, t( 6_${ik}$ ), nb, work,lwork, info ) end if - work( 1 ) = max( 1, nb*n ) + work( 1_${ik}$ ) = max( 1_${ik}$, nb*n ) return - end subroutine stdlib_zgeqr + end subroutine stdlib${ii}$_zgeqr - subroutine stdlib_zgesdd( jobz, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, rwork, iwork, & + subroutine stdlib${ii}$_zgesdd( jobz, m, n, a, lda, s, u, ldu, vt, ldvt,work, lwork, rwork, iwork, & !! ZGESDD computes the singular value decomposition (SVD) of a complex !! M-by-N matrix A, optionally computing the left and/or right singular !! vectors, by using divide-and-conquer method. The SVD is written @@ -65871,10 +65874,10 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldu, ldvt, lwork, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldu, ldvt, lwork, m, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(out) :: rwork(*), s(*) complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: u(ldu,*), vt(ldvt,*), work(*) @@ -65883,49 +65886,49 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: lquery, wntqa, wntqas, wntqn, wntqo, wntqs - integer(ilp) :: blk, chunk, i, ie, ierr, il, ir, iru, irvt, iscl, itau, itaup, itauq, & + integer(${ik}$) :: blk, chunk, i, ie, ierr, il, ir, iru, irvt, iscl, itau, itaup, itauq, & iu, ivt, ldwkvt, ldwrkl, ldwrkr, ldwrku, maxwrk, minmn, minwrk, mnthr1, mnthr2, nrwork,& nwork, wrkbl - integer(ilp) :: lwork_zgebrd_mn, lwork_zgebrd_mm, lwork_zgebrd_nn, lwork_zgelqf_mn, & + integer(${ik}$) :: lwork_zgebrd_mn, lwork_zgebrd_mm, lwork_zgebrd_nn, lwork_zgelqf_mn, & lwork_zgeqrf_mn, lwork_zungbr_p_mn, lwork_zungbr_p_nn, lwork_zungbr_q_mn, & lwork_zungbr_q_mm, lwork_zunglq_mn, lwork_zunglq_nn, lwork_zungqr_mm, lwork_zungqr_mn, & lwork_zunmbr_prc_mm, lwork_zunmbr_qln_mm, lwork_zunmbr_prc_mn, lwork_zunmbr_qln_mn, & lwork_zunmbr_prc_nn, lwork_zunmbr_qln_nn real(dp) :: anrm, bignum, eps, smlnum ! Local Arrays - integer(ilp) :: idum(1) - real(dp) :: dum(1) - complex(dp) :: cdum(1) + integer(${ik}$) :: idum(1_${ik}$) + real(dp) :: dum(1_${ik}$) + complex(dp) :: cdum(1_${ik}$) ! Intrinsic Functions intrinsic :: int,max,min,sqrt ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ minmn = min( m, n ) - mnthr1 = int( minmn*17.0_dp / 9.0_dp,KIND=ilp) - mnthr2 = int( minmn*5.0_dp / 3.0_dp,KIND=ilp) + mnthr1 = int( minmn*17.0_dp / 9.0_dp,KIND=${ik}$) + mnthr2 = int( minmn*5.0_dp / 3.0_dp,KIND=${ik}$) wntqa = stdlib_lsame( jobz, 'A' ) wntqs = stdlib_lsame( jobz, 'S' ) wntqas = wntqa .or. wntqs wntqo = stdlib_lsame( jobz, 'O' ) wntqn = stdlib_lsame( jobz, 'N' ) - lquery = ( lwork==-1 ) - minwrk = 1 - maxwrk = 1 + lquery = ( lwork==-1_${ik}$ ) + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ if( .not.( wntqa .or. wntqs .or. wntqo .or. wntqn ) ) then - info = -1 - else if( m<0 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( lda=n .and. ldvt=n .and. minmn>0 ) then + ! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + if( m>=n .and. minmn>0_${ik}$ ) then ! there is no complex work space needed for bidiagonal svd - ! the realwork space needed for bidiagonal svd (stdlib_dbdsdc,KIND=dp) is + ! the realwork space needed for bidiagonal svd (stdlib${ii}$_dbdsdc,KIND=dp) is ! bdspac = 3*n*n + 4*n for singular values and vectors; ! bdspac = 4*n for singular values only; ! not including e, ru, and rvt matrices. ! compute space preferred for each routine - call stdlib_zgebrd( m, n, cdum(1), m, dum(1), dum(1), cdum(1),cdum(1), cdum(1), -& - 1, ierr ) - lwork_zgebrd_mn = int( cdum(1),KIND=ilp) - call stdlib_zgebrd( n, n, cdum(1), n, dum(1), dum(1), cdum(1),cdum(1), cdum(1), -& - 1, ierr ) - lwork_zgebrd_nn = int( cdum(1),KIND=ilp) - call stdlib_zgeqrf( m, n, cdum(1), m, cdum(1), cdum(1), -1, ierr ) - lwork_zgeqrf_mn = int( cdum(1),KIND=ilp) - call stdlib_zungbr( 'P', n, n, n, cdum(1), n, cdum(1), cdum(1),-1, ierr ) - lwork_zungbr_p_nn = int( cdum(1),KIND=ilp) - call stdlib_zungbr( 'Q', m, m, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) - lwork_zungbr_q_mm = int( cdum(1),KIND=ilp) - call stdlib_zungbr( 'Q', m, n, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) - lwork_zungbr_q_mn = int( cdum(1),KIND=ilp) - call stdlib_zungqr( m, m, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) - lwork_zungqr_mm = int( cdum(1),KIND=ilp) - call stdlib_zungqr( m, n, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) - lwork_zungqr_mn = int( cdum(1),KIND=ilp) - call stdlib_zunmbr( 'P', 'R', 'C', n, n, n, cdum(1), n, cdum(1),cdum(1), n, cdum(& - 1), -1, ierr ) - lwork_zunmbr_prc_nn = int( cdum(1),KIND=ilp) - call stdlib_zunmbr( 'Q', 'L', 'N', m, m, n, cdum(1), m, cdum(1),cdum(1), m, cdum(& - 1), -1, ierr ) - lwork_zunmbr_qln_mm = int( cdum(1),KIND=ilp) - call stdlib_zunmbr( 'Q', 'L', 'N', m, n, n, cdum(1), m, cdum(1),cdum(1), m, cdum(& - 1), -1, ierr ) - lwork_zunmbr_qln_mn = int( cdum(1),KIND=ilp) - call stdlib_zunmbr( 'Q', 'L', 'N', n, n, n, cdum(1), n, cdum(1),cdum(1), n, cdum(& - 1), -1, ierr ) - lwork_zunmbr_qln_nn = int( cdum(1),KIND=ilp) + call stdlib${ii}$_zgebrd( m, n, cdum(1_${ik}$), m, dum(1_${ik}$), dum(1_${ik}$), cdum(1_${ik}$),cdum(1_${ik}$), cdum(1_${ik}$), -& + 1_${ik}$, ierr ) + lwork_zgebrd_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zgebrd( n, n, cdum(1_${ik}$), n, dum(1_${ik}$), dum(1_${ik}$), cdum(1_${ik}$),cdum(1_${ik}$), cdum(1_${ik}$), -& + 1_${ik}$, ierr ) + lwork_zgebrd_nn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zgeqrf( m, n, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_zgeqrf_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zungbr( 'P', n, n, n, cdum(1_${ik}$), n, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_zungbr_p_nn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zungbr( 'Q', m, m, n, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_zungbr_q_mm = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zungbr( 'Q', m, n, n, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_zungbr_q_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zungqr( m, m, n, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_zungqr_mm = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zungqr( m, n, n, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_zungqr_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zunmbr( 'P', 'R', 'C', n, n, n, cdum(1_${ik}$), n, cdum(1_${ik}$),cdum(1_${ik}$), n, cdum(& + 1_${ik}$), -1_${ik}$, ierr ) + lwork_zunmbr_prc_nn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zunmbr( 'Q', 'L', 'N', m, m, n, cdum(1_${ik}$), m, cdum(1_${ik}$),cdum(1_${ik}$), m, cdum(& + 1_${ik}$), -1_${ik}$, ierr ) + lwork_zunmbr_qln_mm = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zunmbr( 'Q', 'L', 'N', m, n, n, cdum(1_${ik}$), m, cdum(1_${ik}$),cdum(1_${ik}$), m, cdum(& + 1_${ik}$), -1_${ik}$, ierr ) + lwork_zunmbr_qln_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zunmbr( 'Q', 'L', 'N', n, n, n, cdum(1_${ik}$), n, cdum(1_${ik}$),cdum(1_${ik}$), n, cdum(& + 1_${ik}$), -1_${ik}$, ierr ) + lwork_zunmbr_qln_nn = int( cdum(1_${ik}$),KIND=${ik}$) if( m>=mnthr1 ) then if( wntqn ) then ! path 1 (m >> n, jobz='n') maxwrk = n + lwork_zgeqrf_mn - maxwrk = max( maxwrk, 2*n + lwork_zgebrd_nn ) - minwrk = 3*n + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_zgebrd_nn ) + minwrk = 3_${ik}$*n else if( wntqo ) then ! path 2 (m >> n, jobz='o') wrkbl = n + lwork_zgeqrf_mn wrkbl = max( wrkbl, n + lwork_zungqr_mn ) - wrkbl = max( wrkbl, 2*n + lwork_zgebrd_nn ) - wrkbl = max( wrkbl, 2*n + lwork_zunmbr_qln_nn ) - wrkbl = max( wrkbl, 2*n + lwork_zunmbr_prc_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_zgebrd_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_zunmbr_qln_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_zunmbr_prc_nn ) maxwrk = m*n + n*n + wrkbl - minwrk = 2*n*n + 3*n + minwrk = 2_${ik}$*n*n + 3_${ik}$*n else if( wntqs ) then ! path 3 (m >> n, jobz='s') wrkbl = n + lwork_zgeqrf_mn wrkbl = max( wrkbl, n + lwork_zungqr_mn ) - wrkbl = max( wrkbl, 2*n + lwork_zgebrd_nn ) - wrkbl = max( wrkbl, 2*n + lwork_zunmbr_qln_nn ) - wrkbl = max( wrkbl, 2*n + lwork_zunmbr_prc_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_zgebrd_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_zunmbr_qln_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_zunmbr_prc_nn ) maxwrk = n*n + wrkbl - minwrk = n*n + 3*n + minwrk = n*n + 3_${ik}$*n else if( wntqa ) then ! path 4 (m >> n, jobz='a') wrkbl = n + lwork_zgeqrf_mn wrkbl = max( wrkbl, n + lwork_zungqr_mm ) - wrkbl = max( wrkbl, 2*n + lwork_zgebrd_nn ) - wrkbl = max( wrkbl, 2*n + lwork_zunmbr_qln_nn ) - wrkbl = max( wrkbl, 2*n + lwork_zunmbr_prc_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_zgebrd_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_zunmbr_qln_nn ) + wrkbl = max( wrkbl, 2_${ik}$*n + lwork_zunmbr_prc_nn ) maxwrk = n*n + wrkbl - minwrk = n*n + max( 3*n, n + m ) + minwrk = n*n + max( 3_${ik}$*n, n + m ) end if else if( m>=mnthr2 ) then ! path 5 (m >> n, but not as much as mnthr1) - maxwrk = 2*n + lwork_zgebrd_mn - minwrk = 2*n + m + maxwrk = 2_${ik}$*n + lwork_zgebrd_mn + minwrk = 2_${ik}$*n + m if( wntqo ) then ! path 5o (m >> n, jobz='o') - maxwrk = max( maxwrk, 2*n + lwork_zungbr_p_nn ) - maxwrk = max( maxwrk, 2*n + lwork_zungbr_q_mn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_zungbr_p_nn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_zungbr_q_mn ) maxwrk = maxwrk + m*n minwrk = minwrk + n*n else if( wntqs ) then ! path 5s (m >> n, jobz='s') - maxwrk = max( maxwrk, 2*n + lwork_zungbr_p_nn ) - maxwrk = max( maxwrk, 2*n + lwork_zungbr_q_mn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_zungbr_p_nn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_zungbr_q_mn ) else if( wntqa ) then ! path 5a (m >> n, jobz='a') - maxwrk = max( maxwrk, 2*n + lwork_zungbr_p_nn ) - maxwrk = max( maxwrk, 2*n + lwork_zungbr_q_mm ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_zungbr_p_nn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_zungbr_q_mm ) end if else ! path 6 (m >= n, but not much larger) - maxwrk = 2*n + lwork_zgebrd_mn - minwrk = 2*n + m + maxwrk = 2_${ik}$*n + lwork_zgebrd_mn + minwrk = 2_${ik}$*n + m if( wntqo ) then ! path 6o (m >= n, jobz='o') - maxwrk = max( maxwrk, 2*n + lwork_zunmbr_prc_nn ) - maxwrk = max( maxwrk, 2*n + lwork_zunmbr_qln_mn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_zunmbr_prc_nn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_zunmbr_qln_mn ) maxwrk = maxwrk + m*n minwrk = minwrk + n*n else if( wntqs ) then ! path 6s (m >= n, jobz='s') - maxwrk = max( maxwrk, 2*n + lwork_zunmbr_qln_mn ) - maxwrk = max( maxwrk, 2*n + lwork_zunmbr_prc_nn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_zunmbr_qln_mn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_zunmbr_prc_nn ) else if( wntqa ) then ! path 6a (m >= n, jobz='a') - maxwrk = max( maxwrk, 2*n + lwork_zunmbr_qln_mm ) - maxwrk = max( maxwrk, 2*n + lwork_zunmbr_prc_nn ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_zunmbr_qln_mm ) + maxwrk = max( maxwrk, 2_${ik}$*n + lwork_zunmbr_prc_nn ) end if end if - else if( minmn>0 ) then + else if( minmn>0_${ik}$ ) then ! there is no complex work space needed for bidiagonal svd - ! the realwork space needed for bidiagonal svd (stdlib_dbdsdc,KIND=dp) is + ! the realwork space needed for bidiagonal svd (stdlib${ii}$_dbdsdc,KIND=dp) is ! bdspac = 3*m*m + 4*m for singular values and vectors; ! bdspac = 4*m for singular values only; ! not including e, ru, and rvt matrices. ! compute space preferred for each routine - call stdlib_zgebrd( m, n, cdum(1), m, dum(1), dum(1), cdum(1),cdum(1), cdum(1), -& - 1, ierr ) - lwork_zgebrd_mn = int( cdum(1),KIND=ilp) - call stdlib_zgebrd( m, m, cdum(1), m, dum(1), dum(1), cdum(1),cdum(1), cdum(1), -& - 1, ierr ) - lwork_zgebrd_mm = int( cdum(1),KIND=ilp) - call stdlib_zgelqf( m, n, cdum(1), m, cdum(1), cdum(1), -1, ierr ) - lwork_zgelqf_mn = int( cdum(1),KIND=ilp) - call stdlib_zungbr( 'P', m, n, m, cdum(1), m, cdum(1), cdum(1),-1, ierr ) - lwork_zungbr_p_mn = int( cdum(1),KIND=ilp) - call stdlib_zungbr( 'P', n, n, m, cdum(1), n, cdum(1), cdum(1),-1, ierr ) - lwork_zungbr_p_nn = int( cdum(1),KIND=ilp) - call stdlib_zungbr( 'Q', m, m, n, cdum(1), m, cdum(1), cdum(1),-1, ierr ) - lwork_zungbr_q_mm = int( cdum(1),KIND=ilp) - call stdlib_zunglq( m, n, m, cdum(1), m, cdum(1), cdum(1),-1, ierr ) - lwork_zunglq_mn = int( cdum(1),KIND=ilp) - call stdlib_zunglq( n, n, m, cdum(1), n, cdum(1), cdum(1),-1, ierr ) - lwork_zunglq_nn = int( cdum(1),KIND=ilp) - call stdlib_zunmbr( 'P', 'R', 'C', m, m, m, cdum(1), m, cdum(1),cdum(1), m, cdum(& - 1), -1, ierr ) - lwork_zunmbr_prc_mm = int( cdum(1),KIND=ilp) - call stdlib_zunmbr( 'P', 'R', 'C', m, n, m, cdum(1), m, cdum(1),cdum(1), m, cdum(& - 1), -1, ierr ) - lwork_zunmbr_prc_mn = int( cdum(1),KIND=ilp) - call stdlib_zunmbr( 'P', 'R', 'C', n, n, m, cdum(1), n, cdum(1),cdum(1), n, cdum(& - 1), -1, ierr ) - lwork_zunmbr_prc_nn = int( cdum(1),KIND=ilp) - call stdlib_zunmbr( 'Q', 'L', 'N', m, m, m, cdum(1), m, cdum(1),cdum(1), m, cdum(& - 1), -1, ierr ) - lwork_zunmbr_qln_mm = int( cdum(1),KIND=ilp) + call stdlib${ii}$_zgebrd( m, n, cdum(1_${ik}$), m, dum(1_${ik}$), dum(1_${ik}$), cdum(1_${ik}$),cdum(1_${ik}$), cdum(1_${ik}$), -& + 1_${ik}$, ierr ) + lwork_zgebrd_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zgebrd( m, m, cdum(1_${ik}$), m, dum(1_${ik}$), dum(1_${ik}$), cdum(1_${ik}$),cdum(1_${ik}$), cdum(1_${ik}$), -& + 1_${ik}$, ierr ) + lwork_zgebrd_mm = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zgelqf( m, n, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_zgelqf_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zungbr( 'P', m, n, m, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_zungbr_p_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zungbr( 'P', n, n, m, cdum(1_${ik}$), n, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_zungbr_p_nn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zungbr( 'Q', m, m, n, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_zungbr_q_mm = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zunglq( m, n, m, cdum(1_${ik}$), m, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_zunglq_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zunglq( n, n, m, cdum(1_${ik}$), n, cdum(1_${ik}$), cdum(1_${ik}$),-1_${ik}$, ierr ) + lwork_zunglq_nn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zunmbr( 'P', 'R', 'C', m, m, m, cdum(1_${ik}$), m, cdum(1_${ik}$),cdum(1_${ik}$), m, cdum(& + 1_${ik}$), -1_${ik}$, ierr ) + lwork_zunmbr_prc_mm = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zunmbr( 'P', 'R', 'C', m, n, m, cdum(1_${ik}$), m, cdum(1_${ik}$),cdum(1_${ik}$), m, cdum(& + 1_${ik}$), -1_${ik}$, ierr ) + lwork_zunmbr_prc_mn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zunmbr( 'P', 'R', 'C', n, n, m, cdum(1_${ik}$), n, cdum(1_${ik}$),cdum(1_${ik}$), n, cdum(& + 1_${ik}$), -1_${ik}$, ierr ) + lwork_zunmbr_prc_nn = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zunmbr( 'Q', 'L', 'N', m, m, m, cdum(1_${ik}$), m, cdum(1_${ik}$),cdum(1_${ik}$), m, cdum(& + 1_${ik}$), -1_${ik}$, ierr ) + lwork_zunmbr_qln_mm = int( cdum(1_${ik}$),KIND=${ik}$) if( n>=mnthr1 ) then if( wntqn ) then ! path 1t (n >> m, jobz='n') maxwrk = m + lwork_zgelqf_mn - maxwrk = max( maxwrk, 2*m + lwork_zgebrd_mm ) - minwrk = 3*m + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_zgebrd_mm ) + minwrk = 3_${ik}$*m else if( wntqo ) then ! path 2t (n >> m, jobz='o') wrkbl = m + lwork_zgelqf_mn wrkbl = max( wrkbl, m + lwork_zunglq_mn ) - wrkbl = max( wrkbl, 2*m + lwork_zgebrd_mm ) - wrkbl = max( wrkbl, 2*m + lwork_zunmbr_qln_mm ) - wrkbl = max( wrkbl, 2*m + lwork_zunmbr_prc_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_zgebrd_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_zunmbr_qln_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_zunmbr_prc_mm ) maxwrk = m*n + m*m + wrkbl - minwrk = 2*m*m + 3*m + minwrk = 2_${ik}$*m*m + 3_${ik}$*m else if( wntqs ) then ! path 3t (n >> m, jobz='s') wrkbl = m + lwork_zgelqf_mn wrkbl = max( wrkbl, m + lwork_zunglq_mn ) - wrkbl = max( wrkbl, 2*m + lwork_zgebrd_mm ) - wrkbl = max( wrkbl, 2*m + lwork_zunmbr_qln_mm ) - wrkbl = max( wrkbl, 2*m + lwork_zunmbr_prc_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_zgebrd_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_zunmbr_qln_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_zunmbr_prc_mm ) maxwrk = m*m + wrkbl - minwrk = m*m + 3*m + minwrk = m*m + 3_${ik}$*m else if( wntqa ) then ! path 4t (n >> m, jobz='a') wrkbl = m + lwork_zgelqf_mn wrkbl = max( wrkbl, m + lwork_zunglq_nn ) - wrkbl = max( wrkbl, 2*m + lwork_zgebrd_mm ) - wrkbl = max( wrkbl, 2*m + lwork_zunmbr_qln_mm ) - wrkbl = max( wrkbl, 2*m + lwork_zunmbr_prc_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_zgebrd_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_zunmbr_qln_mm ) + wrkbl = max( wrkbl, 2_${ik}$*m + lwork_zunmbr_prc_mm ) maxwrk = m*m + wrkbl - minwrk = m*m + max( 3*m, m + n ) + minwrk = m*m + max( 3_${ik}$*m, m + n ) end if else if( n>=mnthr2 ) then ! path 5t (n >> m, but not as much as mnthr1) - maxwrk = 2*m + lwork_zgebrd_mn - minwrk = 2*m + n + maxwrk = 2_${ik}$*m + lwork_zgebrd_mn + minwrk = 2_${ik}$*m + n if( wntqo ) then ! path 5to (n >> m, jobz='o') - maxwrk = max( maxwrk, 2*m + lwork_zungbr_q_mm ) - maxwrk = max( maxwrk, 2*m + lwork_zungbr_p_mn ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_zungbr_q_mm ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_zungbr_p_mn ) maxwrk = maxwrk + m*n minwrk = minwrk + m*m else if( wntqs ) then ! path 5ts (n >> m, jobz='s') - maxwrk = max( maxwrk, 2*m + lwork_zungbr_q_mm ) - maxwrk = max( maxwrk, 2*m + lwork_zungbr_p_mn ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_zungbr_q_mm ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_zungbr_p_mn ) else if( wntqa ) then ! path 5ta (n >> m, jobz='a') - maxwrk = max( maxwrk, 2*m + lwork_zungbr_q_mm ) - maxwrk = max( maxwrk, 2*m + lwork_zungbr_p_nn ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_zungbr_q_mm ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_zungbr_p_nn ) end if else ! path 6t (n > m, but not much larger) - maxwrk = 2*m + lwork_zgebrd_mn - minwrk = 2*m + n + maxwrk = 2_${ik}$*m + lwork_zgebrd_mn + minwrk = 2_${ik}$*m + n if( wntqo ) then ! path 6to (n > m, jobz='o') - maxwrk = max( maxwrk, 2*m + lwork_zunmbr_qln_mm ) - maxwrk = max( maxwrk, 2*m + lwork_zunmbr_prc_mn ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_zunmbr_qln_mm ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_zunmbr_prc_mn ) maxwrk = maxwrk + m*n minwrk = minwrk + m*m else if( wntqs ) then ! path 6ts (n > m, jobz='s') - maxwrk = max( maxwrk, 2*m + lwork_zunmbr_qln_mm ) - maxwrk = max( maxwrk, 2*m + lwork_zunmbr_prc_mn ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_zunmbr_qln_mm ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_zunmbr_prc_mn ) else if( wntqa ) then ! path 6ta (n > m, jobz='a') - maxwrk = max( maxwrk, 2*m + lwork_zunmbr_qln_mm ) - maxwrk = max( maxwrk, 2*m + lwork_zunmbr_prc_nn ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_zunmbr_qln_mm ) + maxwrk = max( maxwrk, 2_${ik}$*m + lwork_zunmbr_prc_nn ) end if end if end if maxwrk = max( maxwrk, minwrk ) end if - if( info==0 ) then - work( 1 ) = stdlib_droundup_lwork( maxwrk ) + if( info==0_${ik}$ ) then + work( 1_${ik}$ ) = stdlib${ii}$_droundup_lwork( maxwrk ) if( lworkzero .and. anrmbignum ) then - iscl = 1 - call stdlib_zlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, ierr ) + iscl = 1_${ik}$ + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, ierr ) end if if( m>=n ) then ! a has at least as many rows as columns. if a has sufficiently @@ -66202,45 +66205,45 @@ module stdlib_linalg_lapack_z if( wntqn ) then ! path 1 (m >> n, jobz='n') ! no singular vectors to be computed - itau = 1 + itau = 1_${ik}$ nwork = itau + n ! compute a=q*r ! cworkspace: need n [tau] + n [work] ! cworkspace: prefer n [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_zgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_zgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) ! zero out below r - if (n>1) call stdlib_zlaset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) - ie = 1 - itauq = 1 + if (n>1_${ik}$) call stdlib${ii}$_zlaset( 'L', n-1, n-1, czero, czero, a( 2_${ik}$, 1_${ik}$ ),lda ) + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + n nwork = itaup + n ! bidiagonalize r in a ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + 2*n*nb [work] ! rworkspace: need n [e] - call stdlib_zgebrd( n, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& + call stdlib${ii}$_zgebrd( n, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& work( nwork ), lwork-nwork+1,ierr ) nrwork = ie + n ! perform bidiagonal svd, compute singular values only ! cworkspace: need 0 ! rworkspace: need n [e] + bdspac - call stdlib_dbdsdc( 'U', 'N', n, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& + call stdlib${ii}$_dbdsdc( 'U', 'N', n, s, rwork( ie ), dum,1_${ik}$,dum,1_${ik}$,dum, idum, rwork(& nrwork ), iwork, info ) else if( wntqo ) then ! path 2 (m >> n, jobz='o') ! n left singular vectors to be overwritten on a and ! n right singular vectors to be computed in vt - iu = 1 + iu = 1_${ik}$ ! work(iu) is n by n ldwrku = n ir = iu + ldwrku*n - if( lwork >= m*n + n*n + 3*n ) then + if( lwork >= m*n + n*n + 3_${ik}$*n ) then ! work(ir) is m by n ldwrkr = m else - ldwrkr = ( lwork - n*n - 3*n ) / n + ldwrkr = ( lwork - n*n - 3_${ik}$*n ) / n end if itau = ir + ldwrkr*n nwork = itau + n @@ -66248,18 +66251,18 @@ module stdlib_linalg_lapack_z ! cworkspace: need n*n [u] + n*n [r] + n [tau] + n [work] ! cworkspace: prefer n*n [u] + n*n [r] + n [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_zgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_zgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) ! copy r to work( ir ), zeroing out below it - call stdlib_zlacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) - call stdlib_zlaset( 'L', n-1, n-1, czero, czero, work( ir+1 ),ldwrkr ) + call stdlib${ii}$_zlacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) + call stdlib${ii}$_zlaset( 'L', n-1, n-1, czero, czero, work( ir+1 ),ldwrkr ) ! generate q in a ! cworkspace: need n*n [u] + n*n [r] + n [tau] + n [work] ! cworkspace: prefer n*n [u] + n*n [r] + n [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_zungqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork-nwork+& - 1, ierr ) - ie = 1 + call stdlib${ii}$_zungqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork-nwork+& + 1_${ik}$, ierr ) + ie = 1_${ik}$ itauq = itau itaup = itauq + n nwork = itaup + n @@ -66267,7 +66270,7 @@ module stdlib_linalg_lapack_z ! cworkspace: need n*n [u] + n*n [r] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [u] + n*n [r] + 2*n [tauq, taup] + 2*n*nb [work] ! rworkspace: need n [e] - call stdlib_zgebrd( n, n, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ), & + call stdlib${ii}$_zgebrd( n, n, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ), & work( itaup ), work( nwork ),lwork-nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of r in work(iru) and computing right singular vectors @@ -66277,23 +66280,23 @@ module stdlib_linalg_lapack_z iru = ie + n irvt = iru + n*n nrwork = irvt + n*n - call stdlib_dbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_dbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=dp) to complex matrix work(iu) ! overwrite work(iu) by the left singular vectors of r ! cworkspace: need n*n [u] + n*n [r] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [u] + n*n [r] + 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_zlacp2( 'F', n, n, rwork( iru ), n, work( iu ),ldwrku ) - call stdlib_zunmbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_zlacp2( 'F', n, n, rwork( iru ), n, work( iu ),ldwrku ) + call stdlib${ii}$_zunmbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & work( iu ), ldwrku,work( nwork ), lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=dp) to complex matrix vt ! overwrite vt by the right singular vectors of r ! cworkspace: need n*n [u] + n*n [r] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [u] + n*n [r] + 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_zlacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) - call stdlib_zunmbr( 'P', 'R', 'C', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_zlacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) + call stdlib${ii}$_zunmbr( 'P', 'R', 'C', n, n, n, work( ir ), ldwrkr,work( itaup ), & vt, ldvt, work( nwork ),lwork-nwork+1, ierr ) ! multiply q in a by left singular vectors of r in ! work(iu), storing result in work(ir) and copying to a @@ -66302,16 +66305,16 @@ module stdlib_linalg_lapack_z ! rworkspace: need 0 do i = 1, m, ldwrkr chunk = min( m-i+1, ldwrkr ) - call stdlib_zgemm( 'N', 'N', chunk, n, n, cone, a( i, 1 ),lda, work( iu ), & + call stdlib${ii}$_zgemm( 'N', 'N', chunk, n, n, cone, a( i, 1_${ik}$ ),lda, work( iu ), & ldwrku, czero,work( ir ), ldwrkr ) - call stdlib_zlacpy( 'F', chunk, n, work( ir ), ldwrkr,a( i, 1 ), lda ) + call stdlib${ii}$_zlacpy( 'F', chunk, n, work( ir ), ldwrkr,a( i, 1_${ik}$ ), lda ) end do else if( wntqs ) then ! path 3 (m >> n, jobz='s') ! n left singular vectors to be computed in u and ! n right singular vectors to be computed in vt - ir = 1 + ir = 1_${ik}$ ! work(ir) is n by n ldwrkr = n itau = ir + ldwrkr*n @@ -66320,18 +66323,18 @@ module stdlib_linalg_lapack_z ! cworkspace: need n*n [r] + n [tau] + n [work] ! cworkspace: prefer n*n [r] + n [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_zgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_zgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) ! copy r to work(ir), zeroing out below it - call stdlib_zlacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) - call stdlib_zlaset( 'L', n-1, n-1, czero, czero, work( ir+1 ),ldwrkr ) + call stdlib${ii}$_zlacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) + call stdlib${ii}$_zlaset( 'L', n-1, n-1, czero, czero, work( ir+1 ),ldwrkr ) ! generate q in a ! cworkspace: need n*n [r] + n [tau] + n [work] ! cworkspace: prefer n*n [r] + n [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_zungqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork-nwork+& - 1, ierr ) - ie = 1 + call stdlib${ii}$_zungqr( m, n, n, a, lda, work( itau ),work( nwork ), lwork-nwork+& + 1_${ik}$, ierr ) + ie = 1_${ik}$ itauq = itau itaup = itauq + n nwork = itaup + n @@ -66339,7 +66342,7 @@ module stdlib_linalg_lapack_z ! cworkspace: need n*n [r] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [r] + 2*n [tauq, taup] + 2*n*nb [work] ! rworkspace: need n [e] - call stdlib_zgebrd( n, n, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ), & + call stdlib${ii}$_zgebrd( n, n, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ), & work( itaup ), work( nwork ),lwork-nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -66349,36 +66352,36 @@ module stdlib_linalg_lapack_z iru = ie + n irvt = iru + n*n nrwork = irvt + n*n - call stdlib_dbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_dbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=dp) to complex matrix u ! overwrite u by left singular vectors of r ! cworkspace: need n*n [r] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [r] + 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_zlacp2( 'F', n, n, rwork( iru ), n, u, ldu ) - call stdlib_zunmbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_zlacp2( 'F', n, n, rwork( iru ), n, u, ldu ) + call stdlib${ii}$_zunmbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr,work( itauq ), & u, ldu, work( nwork ),lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=dp) to complex matrix vt ! overwrite vt by right singular vectors of r ! cworkspace: need n*n [r] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [r] + 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_zlacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) - call stdlib_zunmbr( 'P', 'R', 'C', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_zlacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) + call stdlib${ii}$_zunmbr( 'P', 'R', 'C', n, n, n, work( ir ), ldwrkr,work( itaup ), & vt, ldvt, work( nwork ),lwork-nwork+1, ierr ) ! multiply q in a by left singular vectors of r in ! work(ir), storing result in u ! cworkspace: need n*n [r] ! rworkspace: need 0 - call stdlib_zlacpy( 'F', n, n, u, ldu, work( ir ), ldwrkr ) - call stdlib_zgemm( 'N', 'N', m, n, n, cone, a, lda, work( ir ),ldwrkr, czero, & + call stdlib${ii}$_zlacpy( 'F', n, n, u, ldu, work( ir ), ldwrkr ) + call stdlib${ii}$_zgemm( 'N', 'N', m, n, n, cone, a, lda, work( ir ),ldwrkr, czero, & u, ldu ) else if( wntqa ) then ! path 4 (m >> n, jobz='a') ! m left singular vectors to be computed in u and ! n right singular vectors to be computed in vt - iu = 1 + iu = 1_${ik}$ ! work(iu) is n by n ldwrku = n itau = iu + ldwrku*n @@ -66387,18 +66390,18 @@ module stdlib_linalg_lapack_z ! cworkspace: need n*n [u] + n [tau] + n [work] ! cworkspace: prefer n*n [u] + n [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_zgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_zgeqrf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) - call stdlib_zlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_zlacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! cworkspace: need n*n [u] + n [tau] + m [work] ! cworkspace: prefer n*n [u] + n [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_zungqr( m, m, n, u, ldu, work( itau ),work( nwork ), lwork-nwork+& - 1, ierr ) + call stdlib${ii}$_zungqr( m, m, n, u, ldu, work( itau ),work( nwork ), lwork-nwork+& + 1_${ik}$, ierr ) ! produce r in a, zeroing out below it - if (n>1) call stdlib_zlaset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) - ie = 1 + if (n>1_${ik}$) call stdlib${ii}$_zlaset( 'L', n-1, n-1, czero, czero, a( 2_${ik}$, 1_${ik}$ ),lda ) + ie = 1_${ik}$ itauq = itau itaup = itauq + n nwork = itaup + n @@ -66406,7 +66409,7 @@ module stdlib_linalg_lapack_z ! cworkspace: need n*n [u] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [u] + 2*n [tauq, taup] + 2*n*nb [work] ! rworkspace: need n [e] - call stdlib_zgebrd( n, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& + call stdlib${ii}$_zgebrd( n, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& work( nwork ), lwork-nwork+1,ierr ) iru = ie + n irvt = iru + n*n @@ -66416,55 +66419,55 @@ module stdlib_linalg_lapack_z ! singular vectors of bidiagonal matrix in rwork(irvt) ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] + bdspac - call stdlib_dbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_dbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=dp) to complex matrix work(iu) ! overwrite work(iu) by left singular vectors of r ! cworkspace: need n*n [u] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [u] + 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_zlacp2( 'F', n, n, rwork( iru ), n, work( iu ),ldwrku ) - call stdlib_zunmbr( 'Q', 'L', 'N', n, n, n, a, lda,work( itauq ), work( iu ), & + call stdlib${ii}$_zlacp2( 'F', n, n, rwork( iru ), n, work( iu ),ldwrku ) + call stdlib${ii}$_zunmbr( 'Q', 'L', 'N', n, n, n, a, lda,work( itauq ), work( iu ), & ldwrku,work( nwork ), lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=dp) to complex matrix vt ! overwrite vt by right singular vectors of r ! cworkspace: need n*n [u] + 2*n [tauq, taup] + n [work] ! cworkspace: prefer n*n [u] + 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_zlacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) - call stdlib_zunmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & + call stdlib${ii}$_zlacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) + call stdlib${ii}$_zunmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork-nwork+1, ierr ) ! multiply q in u by left singular vectors of r in ! work(iu), storing result in a ! cworkspace: need n*n [u] ! rworkspace: need 0 - call stdlib_zgemm( 'N', 'N', m, n, n, cone, u, ldu, work( iu ),ldwrku, czero, & + call stdlib${ii}$_zgemm( 'N', 'N', m, n, n, cone, u, ldu, work( iu ),ldwrku, czero, & a, lda ) ! copy left singular vectors of a from a to u - call stdlib_zlacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_zlacpy( 'F', m, n, a, lda, u, ldu ) end if else if( m>=mnthr2 ) then ! mnthr2 <= m < mnthr1 ! path 5 (m >> n, but not as much as mnthr1) ! reduce to bidiagonal form without qr decomposition, use - ! stdlib_zungbr and matrix multiplication to compute singular vectors - ie = 1 + ! stdlib${ii}$_zungbr and matrix multiplication to compute singular vectors + ie = 1_${ik}$ nrwork = ie + n - itauq = 1 + itauq = 1_${ik}$ itaup = itauq + n nwork = itaup + n ! bidiagonalize a ! cworkspace: need 2*n [tauq, taup] + m [work] ! cworkspace: prefer 2*n [tauq, taup] + (m+n)*nb [work] ! rworkspace: need n [e] - call stdlib_zgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_zgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) if( wntqn ) then ! path 5n (m >> n, jobz='n') ! compute singular values only ! cworkspace: need 0 ! rworkspace: need n [e] + bdspac - call stdlib_dbdsdc( 'U', 'N', n, s, rwork( ie ), dum, 1,dum,1,dum, idum, & + call stdlib${ii}$_dbdsdc( 'U', 'N', n, s, rwork( ie ), dum, 1_${ik}$,dum,1_${ik}$,dum, idum, & rwork( nrwork ), iwork, info ) else if( wntqo ) then iu = nwork @@ -66476,21 +66479,21 @@ module stdlib_linalg_lapack_z ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_zlacpy( 'U', n, n, a, lda, vt, ldvt ) - call stdlib_zungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( nwork ), & + call stdlib${ii}$_zlacpy( 'U', n, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( nwork ), & lwork-nwork+1, ierr ) ! generate q in a ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_zungbr( 'Q', m, n, n, a, lda, work( itauq ),work( nwork ), lwork-& + call stdlib${ii}$_zungbr( 'Q', m, n, n, a, lda, work( itauq ),work( nwork ), lwork-& nwork+1, ierr ) - if( lwork >= m*n + 3*n ) then + if( lwork >= m*n + 3_${ik}$*n ) then ! work( iu ) is m by n ldwrku = m else ! work(iu) is ldwrku by n - ldwrku = ( lwork - 3*n ) / n + ldwrku = ( lwork - 3_${ik}$*n ) / n end if nwork = iu + ldwrku*n ! perform bidiagonal svd, computing left singular vectors @@ -66498,15 +66501,15 @@ module stdlib_linalg_lapack_z ! singular vectors of bidiagonal matrix in rwork(irvt) ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] + bdspac - call stdlib_dbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_dbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! multiply realmatrix rwork(irvt,KIND=dp) by p**h in vt, ! storing the result in work(iu), copying to vt ! cworkspace: need 2*n [tauq, taup] + n*n [u] ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] + 2*n*n [rwork] - call stdlib_zlarcm( n, n, rwork( irvt ), n, vt, ldvt,work( iu ), ldwrku, & + call stdlib${ii}$_zlarcm( n, n, rwork( irvt ), n, vt, ldvt,work( iu ), ldwrku, & rwork( nrwork ) ) - call stdlib_zlacpy( 'F', n, n, work( iu ), ldwrku, vt, ldvt ) + call stdlib${ii}$_zlacpy( 'F', n, n, work( iu ), ldwrku, vt, ldvt ) ! multiply q in a by realmatrix rwork(iru,KIND=dp), storing the ! result in work(iu), copying to a ! cworkspace: need 2*n [tauq, taup] + n*n [u] @@ -66516,9 +66519,9 @@ module stdlib_linalg_lapack_z nrwork = irvt do i = 1, m, ldwrku chunk = min( m-i+1, ldwrku ) - call stdlib_zlacrm( chunk, n, a( i, 1 ), lda, rwork( iru ),n, work( iu ), & + call stdlib${ii}$_zlacrm( chunk, n, a( i, 1_${ik}$ ), lda, rwork( iru ),n, work( iu ), & ldwrku, rwork( nrwork ) ) - call stdlib_zlacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) + call stdlib${ii}$_zlacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1_${ik}$ ), lda ) end do else if( wntqs ) then @@ -66527,15 +66530,15 @@ module stdlib_linalg_lapack_z ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_zlacpy( 'U', n, n, a, lda, vt, ldvt ) - call stdlib_zungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( nwork ), & + call stdlib${ii}$_zlacpy( 'U', n, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( nwork ), & lwork-nwork+1, ierr ) ! copy a to u, generate q ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_zlacpy( 'L', m, n, a, lda, u, ldu ) - call stdlib_zungbr( 'Q', m, n, n, u, ldu, work( itauq ),work( nwork ), lwork-& + call stdlib${ii}$_zlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_zungbr( 'Q', m, n, n, u, ldu, work( itauq ),work( nwork ), lwork-& nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -66545,38 +66548,38 @@ module stdlib_linalg_lapack_z iru = nrwork irvt = iru + n*n nrwork = irvt + n*n - call stdlib_dbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_dbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! multiply realmatrix rwork(irvt,KIND=dp) by p**h in vt, ! storing the result in a, copying to vt ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] + 2*n*n [rwork] - call stdlib_zlarcm( n, n, rwork( irvt ), n, vt, ldvt, a, lda,rwork( nrwork ) ) + call stdlib${ii}$_zlarcm( n, n, rwork( irvt ), n, vt, ldvt, a, lda,rwork( nrwork ) ) - call stdlib_zlacpy( 'F', n, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zlacpy( 'F', n, n, a, lda, vt, ldvt ) ! multiply q in u by realmatrix rwork(iru,KIND=dp), storing the ! result in a, copying to u ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + 2*m*n [rwork] < n + 5*n*n since m < 2*n here nrwork = irvt - call stdlib_zlacrm( m, n, u, ldu, rwork( iru ), n, a, lda,rwork( nrwork ) ) + call stdlib${ii}$_zlacrm( m, n, u, ldu, rwork( iru ), n, a, lda,rwork( nrwork ) ) - call stdlib_zlacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_zlacpy( 'F', m, n, a, lda, u, ldu ) else ! path 5a (m >> n, jobz='a') ! copy a to vt, generate p**h ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_zlacpy( 'U', n, n, a, lda, vt, ldvt ) - call stdlib_zungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( nwork ), & + call stdlib${ii}$_zlacpy( 'U', n, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( nwork ), & lwork-nwork+1, ierr ) ! copy a to u, generate q ! cworkspace: need 2*n [tauq, taup] + m [work] ! cworkspace: prefer 2*n [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_zlacpy( 'L', m, n, a, lda, u, ldu ) - call stdlib_zungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& + call stdlib${ii}$_zlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_zungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -66586,58 +66589,58 @@ module stdlib_linalg_lapack_z iru = nrwork irvt = iru + n*n nrwork = irvt + n*n - call stdlib_dbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_dbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! multiply realmatrix rwork(irvt,KIND=dp) by p**h in vt, ! storing the result in a, copying to vt ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] + 2*n*n [rwork] - call stdlib_zlarcm( n, n, rwork( irvt ), n, vt, ldvt, a, lda,rwork( nrwork ) ) + call stdlib${ii}$_zlarcm( n, n, rwork( irvt ), n, vt, ldvt, a, lda,rwork( nrwork ) ) - call stdlib_zlacpy( 'F', n, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zlacpy( 'F', n, n, a, lda, vt, ldvt ) ! multiply q in u by realmatrix rwork(iru,KIND=dp), storing the ! result in a, copying to u ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + 2*m*n [rwork] < n + 5*n*n since m < 2*n here nrwork = irvt - call stdlib_zlacrm( m, n, u, ldu, rwork( iru ), n, a, lda,rwork( nrwork ) ) + call stdlib${ii}$_zlacrm( m, n, u, ldu, rwork( iru ), n, a, lda,rwork( nrwork ) ) - call stdlib_zlacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_zlacpy( 'F', m, n, a, lda, u, ldu ) end if else ! m < mnthr2 ! path 6 (m >= n, but not much larger) ! reduce to bidiagonal form without qr decomposition ! use stdlib_zunmbr to compute singular vectors - ie = 1 + ie = 1_${ik}$ nrwork = ie + n - itauq = 1 + itauq = 1_${ik}$ itaup = itauq + n nwork = itaup + n ! bidiagonalize a ! cworkspace: need 2*n [tauq, taup] + m [work] ! cworkspace: prefer 2*n [tauq, taup] + (m+n)*nb [work] ! rworkspace: need n [e] - call stdlib_zgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_zgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) if( wntqn ) then ! path 6n (m >= n, jobz='n') ! compute singular values only ! cworkspace: need 0 ! rworkspace: need n [e] + bdspac - call stdlib_dbdsdc( 'U', 'N', n, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& + call stdlib${ii}$_dbdsdc( 'U', 'N', n, s, rwork( ie ), dum,1_${ik}$,dum,1_${ik}$,dum, idum, rwork(& nrwork ), iwork, info ) else if( wntqo ) then iu = nwork iru = nrwork irvt = iru + n*n nrwork = irvt + n*n - if( lwork >= m*n + 3*n ) then + if( lwork >= m*n + 3_${ik}$*n ) then ! work( iu ) is m by n ldwrku = m else ! work( iu ) is ldwrku by n - ldwrku = ( lwork - 3*n ) / n + ldwrku = ( lwork - 3_${ik}$*n ) / n end if nwork = iu + ldwrku*n ! path 6o (m >= n, jobz='o') @@ -66646,17 +66649,17 @@ module stdlib_linalg_lapack_z ! singular vectors of bidiagonal matrix in rwork(irvt) ! cworkspace: need 0 ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] + bdspac - call stdlib_dbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_dbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(irvt,KIND=dp) to complex matrix vt ! overwrite vt by right singular vectors of a ! cworkspace: need 2*n [tauq, taup] + n*n [u] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*n [u] + n*nb [work] ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] - call stdlib_zlacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) - call stdlib_zunmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & + call stdlib${ii}$_zlacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) + call stdlib${ii}$_zunmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork-nwork+1, ierr ) - if( lwork >= m*n + 3*n ) then + if( lwork >= m*n + 3_${ik}$*n ) then ! path 6o-fast ! copy realmatrix rwork(iru,KIND=dp) to complex matrix work(iu) ! overwrite work(iu) by left singular vectors of a, copying @@ -66664,18 +66667,18 @@ module stdlib_linalg_lapack_z ! cworkspace: need 2*n [tauq, taup] + m*n [u] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + m*n [u] + n*nb [work] ! rworkspace: need n [e] + n*n [ru] - call stdlib_zlaset( 'F', m, n, czero, czero, work( iu ),ldwrku ) - call stdlib_zlacp2( 'F', n, n, rwork( iru ), n, work( iu ),ldwrku ) - call stdlib_zunmbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), work( iu & + call stdlib${ii}$_zlaset( 'F', m, n, czero, czero, work( iu ),ldwrku ) + call stdlib${ii}$_zlacp2( 'F', n, n, rwork( iru ), n, work( iu ),ldwrku ) + call stdlib${ii}$_zunmbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), work( iu & ), ldwrku,work( nwork ), lwork-nwork+1, ierr ) - call stdlib_zlacpy( 'F', m, n, work( iu ), ldwrku, a, lda ) + call stdlib${ii}$_zlacpy( 'F', m, n, work( iu ), ldwrku, a, lda ) else ! path 6o-slow ! generate q in a ! cworkspace: need 2*n [tauq, taup] + n*n [u] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*n [u] + n*nb [work] ! rworkspace: need 0 - call stdlib_zungbr( 'Q', m, n, n, a, lda, work( itauq ),work( nwork ), & + call stdlib${ii}$_zungbr( 'Q', m, n, n, a, lda, work( itauq ),work( nwork ), & lwork-nwork+1, ierr ) ! multiply q in a by realmatrix rwork(iru,KIND=dp), storing the ! result in work(iu), copying to a @@ -66686,9 +66689,9 @@ module stdlib_linalg_lapack_z nrwork = irvt do i = 1, m, ldwrku chunk = min( m-i+1, ldwrku ) - call stdlib_zlacrm( chunk, n, a( i, 1 ), lda,rwork( iru ), n, work( iu )& + call stdlib${ii}$_zlacrm( chunk, n, a( i, 1_${ik}$ ), lda,rwork( iru ), n, work( iu )& , ldwrku,rwork( nrwork ) ) - call stdlib_zlacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) + call stdlib${ii}$_zlacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1_${ik}$ ), lda ) end do end if @@ -66702,24 +66705,24 @@ module stdlib_linalg_lapack_z iru = nrwork irvt = iru + n*n nrwork = irvt + n*n - call stdlib_dbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_dbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=dp) to complex matrix u ! overwrite u by left singular vectors of a ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] - call stdlib_zlaset( 'F', m, n, czero, czero, u, ldu ) - call stdlib_zlacp2( 'F', n, n, rwork( iru ), n, u, ldu ) - call stdlib_zunmbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), u, ldu, & + call stdlib${ii}$_zlaset( 'F', m, n, czero, czero, u, ldu ) + call stdlib${ii}$_zlacp2( 'F', n, n, rwork( iru ), n, u, ldu ) + call stdlib${ii}$_zunmbr( 'Q', 'L', 'N', m, n, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=dp) to complex matrix vt ! overwrite vt by right singular vectors of a ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] - call stdlib_zlacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) - call stdlib_zunmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & + call stdlib${ii}$_zlacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) + call stdlib${ii}$_zunmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork-nwork+1, ierr ) else ! path 6a (m >= n, jobz='a') @@ -66731,28 +66734,28 @@ module stdlib_linalg_lapack_z iru = nrwork irvt = iru + n*n nrwork = irvt + n*n - call stdlib_dbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& + call stdlib${ii}$_dbdsdc( 'U', 'I', n, s, rwork( ie ), rwork( iru ),n, rwork( irvt )& , n, dum, idum,rwork( nrwork ), iwork, info ) ! set the right corner of u to identity matrix - call stdlib_zlaset( 'F', m, m, czero, czero, u, ldu ) + call stdlib${ii}$_zlaset( 'F', m, m, czero, czero, u, ldu ) if( m>n ) then - call stdlib_zlaset( 'F', m-n, m-n, czero, cone,u( n+1, n+1 ), ldu ) + call stdlib${ii}$_zlaset( 'F', m-n, m-n, czero, cone,u( n+1, n+1 ), ldu ) end if ! copy realmatrix rwork(iru,KIND=dp) to complex matrix u ! overwrite u by left singular vectors of a ! cworkspace: need 2*n [tauq, taup] + m [work] ! cworkspace: prefer 2*n [tauq, taup] + m*nb [work] ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] - call stdlib_zlacp2( 'F', n, n, rwork( iru ), n, u, ldu ) - call stdlib_zunmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + call stdlib${ii}$_zlacp2( 'F', n, n, rwork( iru ), n, u, ldu ) + call stdlib${ii}$_zunmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=dp) to complex matrix vt ! overwrite vt by right singular vectors of a ! cworkspace: need 2*n [tauq, taup] + n [work] ! cworkspace: prefer 2*n [tauq, taup] + n*nb [work] ! rworkspace: need n [e] + n*n [ru] + n*n [rvt] - call stdlib_zlacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) - call stdlib_zunmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & + call stdlib${ii}$_zlacp2( 'F', n, n, rwork( irvt ), n, vt, ldvt ) + call stdlib${ii}$_zunmbr( 'P', 'R', 'C', n, n, n, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork-nwork+1, ierr ) end if end if @@ -66764,48 +66767,48 @@ module stdlib_linalg_lapack_z if( wntqn ) then ! path 1t (n >> m, jobz='n') ! no singular vectors to be computed - itau = 1 + itau = 1_${ik}$ nwork = itau + m ! compute a=l*q ! cworkspace: need m [tau] + m [work] ! cworkspace: prefer m [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_zgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_zgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) ! zero out above l - if (m>1) call stdlib_zlaset( 'U', m-1, m-1, czero, czero, a( 1, 2 ),lda ) - ie = 1 - itauq = 1 + if (m>1_${ik}$) call stdlib${ii}$_zlaset( 'U', m-1, m-1, czero, czero, a( 1_${ik}$, 2_${ik}$ ),lda ) + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + m nwork = itaup + m ! bidiagonalize l in a ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + 2*m*nb [work] ! rworkspace: need m [e] - call stdlib_zgebrd( m, m, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& + call stdlib${ii}$_zgebrd( m, m, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& work( nwork ), lwork-nwork+1,ierr ) nrwork = ie + m ! perform bidiagonal svd, compute singular values only ! cworkspace: need 0 ! rworkspace: need m [e] + bdspac - call stdlib_dbdsdc( 'U', 'N', m, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& + call stdlib${ii}$_dbdsdc( 'U', 'N', m, s, rwork( ie ), dum,1_${ik}$,dum,1_${ik}$,dum, idum, rwork(& nrwork ), iwork, info ) else if( wntqo ) then ! path 2t (n >> m, jobz='o') ! m right singular vectors to be overwritten on a and ! m left singular vectors to be computed in u - ivt = 1 + ivt = 1_${ik}$ ldwkvt = m ! work(ivt) is m by m il = ivt + ldwkvt*m - if( lwork >= m*n + m*m + 3*m ) then + if( lwork >= m*n + m*m + 3_${ik}$*m ) then ! work(il) m by n ldwrkl = m chunk = n else ! work(il) is m by chunk ldwrkl = m - chunk = ( lwork - m*m - 3*m ) / m + chunk = ( lwork - m*m - 3_${ik}$*m ) / m end if itau = il + ldwrkl*chunk nwork = itau + m @@ -66813,19 +66816,19 @@ module stdlib_linalg_lapack_z ! cworkspace: need m*m [vt] + m*m [l] + m [tau] + m [work] ! cworkspace: prefer m*m [vt] + m*m [l] + m [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_zgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_zgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) ! copy l to work(il), zeroing about above it - call stdlib_zlacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) - call stdlib_zlaset( 'U', m-1, m-1, czero, czero,work( il+ldwrkl ), ldwrkl ) + call stdlib${ii}$_zlacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) + call stdlib${ii}$_zlaset( 'U', m-1, m-1, czero, czero,work( il+ldwrkl ), ldwrkl ) ! generate q in a ! cworkspace: need m*m [vt] + m*m [l] + m [tau] + m [work] ! cworkspace: prefer m*m [vt] + m*m [l] + m [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_zunglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork-nwork+& - 1, ierr ) - ie = 1 + call stdlib${ii}$_zunglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork-nwork+& + 1_${ik}$, ierr ) + ie = 1_${ik}$ itauq = itau itaup = itauq + m nwork = itaup + m @@ -66833,7 +66836,7 @@ module stdlib_linalg_lapack_z ! cworkspace: need m*m [vt] + m*m [l] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [vt] + m*m [l] + 2*m [tauq, taup] + 2*m*nb [work] ! rworkspace: need m [e] - call stdlib_zgebrd( m, m, work( il ), ldwrkl, s, rwork( ie ),work( itauq ), & + call stdlib${ii}$_zgebrd( m, m, work( il ), ldwrkl, s, rwork( ie ),work( itauq ), & work( itaup ), work( nwork ),lwork-nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -66843,23 +66846,23 @@ module stdlib_linalg_lapack_z iru = ie + m irvt = iru + m*m nrwork = irvt + m*m - call stdlib_dbdsdc( 'U', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_dbdsdc( 'U', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=dp) to complex matrix work(iu) ! overwrite work(iu) by the left singular vectors of l ! cworkspace: need m*m [vt] + m*m [l] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [vt] + m*m [l] + 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_zlacp2( 'F', m, m, rwork( iru ), m, u, ldu ) - call stdlib_zunmbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & + call stdlib${ii}$_zlacp2( 'F', m, m, rwork( iru ), m, u, ldu ) + call stdlib${ii}$_zunmbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & u, ldu, work( nwork ),lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=dp) to complex matrix work(ivt) ! overwrite work(ivt) by the right singular vectors of l ! cworkspace: need m*m [vt] + m*m [l] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [vt] + m*m [l] + 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_zlacp2( 'F', m, m, rwork( irvt ), m, work( ivt ),ldwkvt ) - call stdlib_zunmbr( 'P', 'R', 'C', m, m, m, work( il ), ldwrkl,work( itaup ), & + call stdlib${ii}$_zlacp2( 'F', m, m, rwork( irvt ), m, work( ivt ),ldwkvt ) + call stdlib${ii}$_zunmbr( 'P', 'R', 'C', m, m, m, work( il ), ldwrkl,work( itaup ), & work( ivt ), ldwkvt,work( nwork ), lwork-nwork+1, ierr ) ! multiply right singular vectors of l in work(il) by q ! in a, storing result in work(il) and copying to a @@ -66868,16 +66871,16 @@ module stdlib_linalg_lapack_z ! rworkspace: need 0 do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_zgemm( 'N', 'N', m, blk, m, cone, work( ivt ), m,a( 1, i ), & + call stdlib${ii}$_zgemm( 'N', 'N', m, blk, m, cone, work( ivt ), m,a( 1_${ik}$, i ), & lda, czero, work( il ),ldwrkl ) - call stdlib_zlacpy( 'F', m, blk, work( il ), ldwrkl,a( 1, i ), lda ) + call stdlib${ii}$_zlacpy( 'F', m, blk, work( il ), ldwrkl,a( 1_${ik}$, i ), lda ) end do else if( wntqs ) then ! path 3t (n >> m, jobz='s') ! m right singular vectors to be computed in vt and ! m left singular vectors to be computed in u - il = 1 + il = 1_${ik}$ ! work(il) is m by m ldwrkl = m itau = il + ldwrkl*m @@ -66886,19 +66889,19 @@ module stdlib_linalg_lapack_z ! cworkspace: need m*m [l] + m [tau] + m [work] ! cworkspace: prefer m*m [l] + m [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_zgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_zgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) ! copy l to work(il), zeroing out above it - call stdlib_zlacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) - call stdlib_zlaset( 'U', m-1, m-1, czero, czero,work( il+ldwrkl ), ldwrkl ) + call stdlib${ii}$_zlacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) + call stdlib${ii}$_zlaset( 'U', m-1, m-1, czero, czero,work( il+ldwrkl ), ldwrkl ) ! generate q in a ! cworkspace: need m*m [l] + m [tau] + m [work] ! cworkspace: prefer m*m [l] + m [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_zunglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork-nwork+& - 1, ierr ) - ie = 1 + call stdlib${ii}$_zunglq( m, n, m, a, lda, work( itau ),work( nwork ), lwork-nwork+& + 1_${ik}$, ierr ) + ie = 1_${ik}$ itauq = itau itaup = itauq + m nwork = itaup + m @@ -66906,7 +66909,7 @@ module stdlib_linalg_lapack_z ! cworkspace: need m*m [l] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [l] + 2*m [tauq, taup] + 2*m*nb [work] ! rworkspace: need m [e] - call stdlib_zgebrd( m, m, work( il ), ldwrkl, s, rwork( ie ),work( itauq ), & + call stdlib${ii}$_zgebrd( m, m, work( il ), ldwrkl, s, rwork( ie ),work( itauq ), & work( itaup ), work( nwork ),lwork-nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -66916,36 +66919,36 @@ module stdlib_linalg_lapack_z iru = ie + m irvt = iru + m*m nrwork = irvt + m*m - call stdlib_dbdsdc( 'U', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_dbdsdc( 'U', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=dp) to complex matrix u ! overwrite u by left singular vectors of l ! cworkspace: need m*m [l] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [l] + 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_zlacp2( 'F', m, m, rwork( iru ), m, u, ldu ) - call stdlib_zunmbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & + call stdlib${ii}$_zlacp2( 'F', m, m, rwork( iru ), m, u, ldu ) + call stdlib${ii}$_zunmbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl,work( itauq ), & u, ldu, work( nwork ),lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=dp) to complex matrix vt ! overwrite vt by left singular vectors of l ! cworkspace: need m*m [l] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [l] + 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_zlacp2( 'F', m, m, rwork( irvt ), m, vt, ldvt ) - call stdlib_zunmbr( 'P', 'R', 'C', m, m, m, work( il ), ldwrkl,work( itaup ), & + call stdlib${ii}$_zlacp2( 'F', m, m, rwork( irvt ), m, vt, ldvt ) + call stdlib${ii}$_zunmbr( 'P', 'R', 'C', m, m, m, work( il ), ldwrkl,work( itaup ), & vt, ldvt, work( nwork ),lwork-nwork+1, ierr ) ! copy vt to work(il), multiply right singular vectors of l ! in work(il) by q in a, storing result in vt ! cworkspace: need m*m [l] ! rworkspace: need 0 - call stdlib_zlacpy( 'F', m, m, vt, ldvt, work( il ), ldwrkl ) - call stdlib_zgemm( 'N', 'N', m, n, m, cone, work( il ), ldwrkl,a, lda, czero, & + call stdlib${ii}$_zlacpy( 'F', m, m, vt, ldvt, work( il ), ldwrkl ) + call stdlib${ii}$_zgemm( 'N', 'N', m, n, m, cone, work( il ), ldwrkl,a, lda, czero, & vt, ldvt ) else if( wntqa ) then ! path 4t (n >> m, jobz='a') ! n right singular vectors to be computed in vt and ! m left singular vectors to be computed in u - ivt = 1 + ivt = 1_${ik}$ ! work(ivt) is m by m ldwkvt = m itau = ivt + ldwkvt*m @@ -66954,18 +66957,18 @@ module stdlib_linalg_lapack_z ! cworkspace: need m*m [vt] + m [tau] + m [work] ! cworkspace: prefer m*m [vt] + m [tau] + m*nb [work] ! rworkspace: need 0 - call stdlib_zgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & + call stdlib${ii}$_zgelqf( m, n, a, lda, work( itau ), work( nwork ),lwork-nwork+1, & ierr ) - call stdlib_zlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zlacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! cworkspace: need m*m [vt] + m [tau] + n [work] ! cworkspace: prefer m*m [vt] + m [tau] + n*nb [work] ! rworkspace: need 0 - call stdlib_zunglq( n, n, m, vt, ldvt, work( itau ),work( nwork ), lwork-& + call stdlib${ii}$_zunglq( n, n, m, vt, ldvt, work( itau ),work( nwork ), lwork-& nwork+1, ierr ) ! produce l in a, zeroing out above it - if (m>1) call stdlib_zlaset( 'U', m-1, m-1, czero, czero, a( 1, 2 ),lda ) - ie = 1 + if (m>1_${ik}$) call stdlib${ii}$_zlaset( 'U', m-1, m-1, czero, czero, a( 1_${ik}$, 2_${ik}$ ),lda ) + ie = 1_${ik}$ itauq = itau itaup = itauq + m nwork = itaup + m @@ -66973,7 +66976,7 @@ module stdlib_linalg_lapack_z ! cworkspace: need m*m [vt] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [vt] + 2*m [tauq, taup] + 2*m*nb [work] ! rworkspace: need m [e] - call stdlib_zgebrd( m, m, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& + call stdlib${ii}$_zgebrd( m, m, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& work( nwork ), lwork-nwork+1,ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -66983,55 +66986,55 @@ module stdlib_linalg_lapack_z iru = ie + m irvt = iru + m*m nrwork = irvt + m*m - call stdlib_dbdsdc( 'U', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_dbdsdc( 'U', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=dp) to complex matrix u ! overwrite u by left singular vectors of l ! cworkspace: need m*m [vt] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [vt] + 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_zlacp2( 'F', m, m, rwork( iru ), m, u, ldu ) - call stdlib_zunmbr( 'Q', 'L', 'N', m, m, m, a, lda,work( itauq ), u, ldu, & + call stdlib${ii}$_zlacp2( 'F', m, m, rwork( iru ), m, u, ldu ) + call stdlib${ii}$_zunmbr( 'Q', 'L', 'N', m, m, m, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=dp) to complex matrix work(ivt) ! overwrite work(ivt) by right singular vectors of l ! cworkspace: need m*m [vt] + 2*m [tauq, taup] + m [work] ! cworkspace: prefer m*m [vt] + 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_zlacp2( 'F', m, m, rwork( irvt ), m, work( ivt ),ldwkvt ) - call stdlib_zunmbr( 'P', 'R', 'C', m, m, m, a, lda,work( itaup ), work( ivt ),& + call stdlib${ii}$_zlacp2( 'F', m, m, rwork( irvt ), m, work( ivt ),ldwkvt ) + call stdlib${ii}$_zunmbr( 'P', 'R', 'C', m, m, m, a, lda,work( itaup ), work( ivt ),& ldwkvt,work( nwork ), lwork-nwork+1, ierr ) ! multiply right singular vectors of l in work(ivt) by ! q in vt, storing result in a ! cworkspace: need m*m [vt] ! rworkspace: need 0 - call stdlib_zgemm( 'N', 'N', m, n, m, cone, work( ivt ), ldwkvt,vt, ldvt, & + call stdlib${ii}$_zgemm( 'N', 'N', m, n, m, cone, work( ivt ), ldwkvt,vt, ldvt, & czero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_zlacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zlacpy( 'F', m, n, a, lda, vt, ldvt ) end if else if( n>=mnthr2 ) then ! mnthr2 <= n < mnthr1 ! path 5t (n >> m, but not as much as mnthr1) ! reduce to bidiagonal form without qr decomposition, use - ! stdlib_zungbr and matrix multiplication to compute singular vectors - ie = 1 + ! stdlib${ii}$_zungbr and matrix multiplication to compute singular vectors + ie = 1_${ik}$ nrwork = ie + m - itauq = 1 + itauq = 1_${ik}$ itaup = itauq + m nwork = itaup + m ! bidiagonalize a ! cworkspace: need 2*m [tauq, taup] + n [work] ! cworkspace: prefer 2*m [tauq, taup] + (m+n)*nb [work] ! rworkspace: need m [e] - call stdlib_zgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_zgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) if( wntqn ) then ! path 5tn (n >> m, jobz='n') ! compute singular values only ! cworkspace: need 0 ! rworkspace: need m [e] + bdspac - call stdlib_dbdsdc( 'L', 'N', m, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& + call stdlib${ii}$_dbdsdc( 'L', 'N', m, s, rwork( ie ), dum,1_${ik}$,dum,1_${ik}$,dum, idum, rwork(& nrwork ), iwork, info ) else if( wntqo ) then irvt = nrwork @@ -67043,23 +67046,23 @@ module stdlib_linalg_lapack_z ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_zlacpy( 'L', m, m, a, lda, u, ldu ) - call stdlib_zungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& + call stdlib${ii}$_zlacpy( 'L', m, m, a, lda, u, ldu ) + call stdlib${ii}$_zungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& nwork+1, ierr ) ! generate p**h in a ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_zungbr( 'P', m, n, m, a, lda, work( itaup ),work( nwork ), lwork-& + call stdlib${ii}$_zungbr( 'P', m, n, m, a, lda, work( itaup ),work( nwork ), lwork-& nwork+1, ierr ) ldwkvt = m - if( lwork >= m*n + 3*m ) then + if( lwork >= m*n + 3_${ik}$*m ) then ! work( ivt ) is m by n nwork = ivt + ldwkvt*n chunk = n else ! work( ivt ) is m by chunk - chunk = ( lwork - 3*m ) / m + chunk = ( lwork - 3_${ik}$*m ) / m nwork = ivt + ldwkvt*chunk end if ! perform bidiagonal svd, computing left singular vectors @@ -67067,15 +67070,15 @@ module stdlib_linalg_lapack_z ! singular vectors of bidiagonal matrix in rwork(irvt) ! cworkspace: need 0 ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] + bdspac - call stdlib_dbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_dbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! multiply q in u by realmatrix rwork(irvt,KIND=dp) ! storing the result in work(ivt), copying to u ! cworkspace: need 2*m [tauq, taup] + m*m [vt] ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] + 2*m*m [rwork] - call stdlib_zlacrm( m, m, u, ldu, rwork( iru ), m, work( ivt ),ldwkvt, rwork( & + call stdlib${ii}$_zlacrm( m, m, u, ldu, rwork( iru ), m, work( ivt ),ldwkvt, rwork( & nrwork ) ) - call stdlib_zlacpy( 'F', m, m, work( ivt ), ldwkvt, u, ldu ) + call stdlib${ii}$_zlacpy( 'F', m, m, work( ivt ), ldwkvt, u, ldu ) ! multiply rwork(irvt) by p**h in a, storing the ! result in work(ivt), copying to a ! cworkspace: need 2*m [tauq, taup] + m*m [vt] @@ -67085,9 +67088,9 @@ module stdlib_linalg_lapack_z nrwork = iru do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_zlarcm( m, blk, rwork( irvt ), m, a( 1, i ), lda,work( ivt ), & + call stdlib${ii}$_zlarcm( m, blk, rwork( irvt ), m, a( 1_${ik}$, i ), lda,work( ivt ), & ldwkvt, rwork( nrwork ) ) - call stdlib_zlacpy( 'F', m, blk, work( ivt ), ldwkvt,a( 1, i ), lda ) + call stdlib${ii}$_zlacpy( 'F', m, blk, work( ivt ), ldwkvt,a( 1_${ik}$, i ), lda ) end do else if( wntqs ) then @@ -67096,15 +67099,15 @@ module stdlib_linalg_lapack_z ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_zlacpy( 'L', m, m, a, lda, u, ldu ) - call stdlib_zungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& + call stdlib${ii}$_zlacpy( 'L', m, m, a, lda, u, ldu ) + call stdlib${ii}$_zungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& nwork+1, ierr ) ! copy a to vt, generate p**h ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_zlacpy( 'U', m, n, a, lda, vt, ldvt ) - call stdlib_zungbr( 'P', m, n, m, vt, ldvt, work( itaup ),work( nwork ), & + call stdlib${ii}$_zlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zungbr( 'P', m, n, m, vt, ldvt, work( itaup ),work( nwork ), & lwork-nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -67114,38 +67117,38 @@ module stdlib_linalg_lapack_z irvt = nrwork iru = irvt + m*m nrwork = iru + m*m - call stdlib_dbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_dbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! multiply q in u by realmatrix rwork(iru,KIND=dp), storing the ! result in a, copying to u ! cworkspace: need 0 ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] + 2*m*m [rwork] - call stdlib_zlacrm( m, m, u, ldu, rwork( iru ), m, a, lda,rwork( nrwork ) ) + call stdlib${ii}$_zlacrm( m, m, u, ldu, rwork( iru ), m, a, lda,rwork( nrwork ) ) - call stdlib_zlacpy( 'F', m, m, a, lda, u, ldu ) + call stdlib${ii}$_zlacpy( 'F', m, m, a, lda, u, ldu ) ! multiply realmatrix rwork(irvt,KIND=dp) by p**h in vt, ! storing the result in a, copying to vt ! cworkspace: need 0 ! rworkspace: need m [e] + m*m [rvt] + 2*m*n [rwork] < m + 5*m*m since n < 2*m here nrwork = iru - call stdlib_zlarcm( m, n, rwork( irvt ), m, vt, ldvt, a, lda,rwork( nrwork ) ) + call stdlib${ii}$_zlarcm( m, n, rwork( irvt ), m, vt, ldvt, a, lda,rwork( nrwork ) ) - call stdlib_zlacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zlacpy( 'F', m, n, a, lda, vt, ldvt ) else ! path 5ta (n >> m, jobz='a') ! copy a to u, generate q ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need 0 - call stdlib_zlacpy( 'L', m, m, a, lda, u, ldu ) - call stdlib_zungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& + call stdlib${ii}$_zlacpy( 'L', m, m, a, lda, u, ldu ) + call stdlib${ii}$_zungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( nwork ), lwork-& nwork+1, ierr ) ! copy a to vt, generate p**h ! cworkspace: need 2*m [tauq, taup] + n [work] ! cworkspace: prefer 2*m [tauq, taup] + n*nb [work] ! rworkspace: need 0 - call stdlib_zlacpy( 'U', m, n, a, lda, vt, ldvt ) - call stdlib_zungbr( 'P', n, n, m, vt, ldvt, work( itaup ),work( nwork ), & + call stdlib${ii}$_zlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zungbr( 'P', n, n, m, vt, ldvt, work( itaup ),work( nwork ), & lwork-nwork+1, ierr ) ! perform bidiagonal svd, computing left singular vectors ! of bidiagonal matrix in rwork(iru) and computing right @@ -67155,58 +67158,58 @@ module stdlib_linalg_lapack_z irvt = nrwork iru = irvt + m*m nrwork = iru + m*m - call stdlib_dbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_dbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! multiply q in u by realmatrix rwork(iru,KIND=dp), storing the ! result in a, copying to u ! cworkspace: need 0 ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] + 2*m*m [rwork] - call stdlib_zlacrm( m, m, u, ldu, rwork( iru ), m, a, lda,rwork( nrwork ) ) + call stdlib${ii}$_zlacrm( m, m, u, ldu, rwork( iru ), m, a, lda,rwork( nrwork ) ) - call stdlib_zlacpy( 'F', m, m, a, lda, u, ldu ) + call stdlib${ii}$_zlacpy( 'F', m, m, a, lda, u, ldu ) ! multiply realmatrix rwork(irvt,KIND=dp) by p**h in vt, ! storing the result in a, copying to vt ! cworkspace: need 0 ! rworkspace: need m [e] + m*m [rvt] + 2*m*n [rwork] < m + 5*m*m since n < 2*m here nrwork = iru - call stdlib_zlarcm( m, n, rwork( irvt ), m, vt, ldvt, a, lda,rwork( nrwork ) ) + call stdlib${ii}$_zlarcm( m, n, rwork( irvt ), m, vt, ldvt, a, lda,rwork( nrwork ) ) - call stdlib_zlacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zlacpy( 'F', m, n, a, lda, vt, ldvt ) end if else ! n < mnthr2 ! path 6t (n > m, but not much larger) ! reduce to bidiagonal form without lq decomposition ! use stdlib_zunmbr to compute singular vectors - ie = 1 + ie = 1_${ik}$ nrwork = ie + m - itauq = 1 + itauq = 1_${ik}$ itaup = itauq + m nwork = itaup + m ! bidiagonalize a ! cworkspace: need 2*m [tauq, taup] + n [work] ! cworkspace: prefer 2*m [tauq, taup] + (m+n)*nb [work] ! rworkspace: need m [e] - call stdlib_zgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_zgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( nwork ), lwork-nwork+1,ierr ) if( wntqn ) then ! path 6tn (n > m, jobz='n') ! compute singular values only ! cworkspace: need 0 ! rworkspace: need m [e] + bdspac - call stdlib_dbdsdc( 'L', 'N', m, s, rwork( ie ), dum,1,dum,1,dum, idum, rwork(& + call stdlib${ii}$_dbdsdc( 'L', 'N', m, s, rwork( ie ), dum,1_${ik}$,dum,1_${ik}$,dum, idum, rwork(& nrwork ), iwork, info ) else if( wntqo ) then ! path 6to (n > m, jobz='o') ldwkvt = m ivt = nwork - if( lwork >= m*n + 3*m ) then + if( lwork >= m*n + 3_${ik}$*m ) then ! work( ivt ) is m by n - call stdlib_zlaset( 'F', m, n, czero, czero, work( ivt ),ldwkvt ) + call stdlib${ii}$_zlaset( 'F', m, n, czero, czero, work( ivt ),ldwkvt ) nwork = ivt + ldwkvt*n else ! work( ivt ) is m by chunk - chunk = ( lwork - 3*m ) / m + chunk = ( lwork - 3_${ik}$*m ) / m nwork = ivt + ldwkvt*chunk end if ! perform bidiagonal svd, computing left singular vectors @@ -67217,17 +67220,17 @@ module stdlib_linalg_lapack_z irvt = nrwork iru = irvt + m*m nrwork = iru + m*m - call stdlib_dbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_dbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=dp) to complex matrix u ! overwrite u by left singular vectors of a ! cworkspace: need 2*m [tauq, taup] + m*m [vt] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*m [vt] + m*nb [work] ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] - call stdlib_zlacp2( 'F', m, m, rwork( iru ), m, u, ldu ) - call stdlib_zunmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + call stdlib${ii}$_zlacp2( 'F', m, m, rwork( iru ), m, u, ldu ) + call stdlib${ii}$_zunmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork-nwork+1, ierr ) - if( lwork >= m*n + 3*m ) then + if( lwork >= m*n + 3_${ik}$*m ) then ! path 6to-fast ! copy realmatrix rwork(irvt,KIND=dp) to complex matrix work(ivt) ! overwrite work(ivt) by right singular vectors of a, @@ -67235,18 +67238,18 @@ module stdlib_linalg_lapack_z ! cworkspace: need 2*m [tauq, taup] + m*n [vt] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*n [vt] + m*nb [work] ! rworkspace: need m [e] + m*m [rvt] - call stdlib_zlacp2( 'F', m, m, rwork( irvt ), m, work( ivt ),ldwkvt ) + call stdlib${ii}$_zlacp2( 'F', m, m, rwork( irvt ), m, work( ivt ),ldwkvt ) - call stdlib_zunmbr( 'P', 'R', 'C', m, n, m, a, lda,work( itaup ), work( & + call stdlib${ii}$_zunmbr( 'P', 'R', 'C', m, n, m, a, lda,work( itaup ), work( & ivt ), ldwkvt,work( nwork ), lwork-nwork+1, ierr ) - call stdlib_zlacpy( 'F', m, n, work( ivt ), ldwkvt, a, lda ) + call stdlib${ii}$_zlacpy( 'F', m, n, work( ivt ), ldwkvt, a, lda ) else ! path 6to-slow ! generate p**h in a ! cworkspace: need 2*m [tauq, taup] + m*m [vt] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*m [vt] + m*nb [work] ! rworkspace: need 0 - call stdlib_zungbr( 'P', m, n, m, a, lda, work( itaup ),work( nwork ), & + call stdlib${ii}$_zungbr( 'P', m, n, m, a, lda, work( itaup ),work( nwork ), & lwork-nwork+1, ierr ) ! multiply q in a by realmatrix rwork(iru,KIND=dp), storing the ! result in work(iu), copying to a @@ -67257,9 +67260,9 @@ module stdlib_linalg_lapack_z nrwork = iru do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_zlarcm( m, blk, rwork( irvt ), m, a( 1, i ),lda, work( ivt )& + call stdlib${ii}$_zlarcm( m, blk, rwork( irvt ), m, a( 1_${ik}$, i ),lda, work( ivt )& , ldwkvt,rwork( nrwork ) ) - call stdlib_zlacpy( 'F', m, blk, work( ivt ), ldwkvt,a( 1, i ), lda ) + call stdlib${ii}$_zlacpy( 'F', m, blk, work( ivt ), ldwkvt,a( 1_${ik}$, i ), lda ) end do end if @@ -67273,24 +67276,24 @@ module stdlib_linalg_lapack_z irvt = nrwork iru = irvt + m*m nrwork = iru + m*m - call stdlib_dbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_dbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=dp) to complex matrix u ! overwrite u by left singular vectors of a ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] - call stdlib_zlacp2( 'F', m, m, rwork( iru ), m, u, ldu ) - call stdlib_zunmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + call stdlib${ii}$_zlacp2( 'F', m, m, rwork( iru ), m, u, ldu ) + call stdlib${ii}$_zunmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork-nwork+1, ierr ) ! copy realmatrix rwork(irvt,KIND=dp) to complex matrix vt ! overwrite vt by right singular vectors of a ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need m [e] + m*m [rvt] - call stdlib_zlaset( 'F', m, n, czero, czero, vt, ldvt ) - call stdlib_zlacp2( 'F', m, m, rwork( irvt ), m, vt, ldvt ) - call stdlib_zunmbr( 'P', 'R', 'C', m, n, m, a, lda,work( itaup ), vt, ldvt, & + call stdlib${ii}$_zlaset( 'F', m, n, czero, czero, vt, ldvt ) + call stdlib${ii}$_zlacp2( 'F', m, m, rwork( irvt ), m, vt, ldvt ) + call stdlib${ii}$_zunmbr( 'P', 'R', 'C', m, n, m, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork-nwork+1, ierr ) else ! path 6ta (n > m, jobz='a') @@ -67302,47 +67305,47 @@ module stdlib_linalg_lapack_z irvt = nrwork iru = irvt + m*m nrwork = iru + m*m - call stdlib_dbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& + call stdlib${ii}$_dbdsdc( 'L', 'I', m, s, rwork( ie ), rwork( iru ),m, rwork( irvt )& , m, dum, idum,rwork( nrwork ), iwork, info ) ! copy realmatrix rwork(iru,KIND=dp) to complex matrix u ! overwrite u by left singular vectors of a ! cworkspace: need 2*m [tauq, taup] + m [work] ! cworkspace: prefer 2*m [tauq, taup] + m*nb [work] ! rworkspace: need m [e] + m*m [rvt] + m*m [ru] - call stdlib_zlacp2( 'F', m, m, rwork( iru ), m, u, ldu ) - call stdlib_zunmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & + call stdlib${ii}$_zlacp2( 'F', m, m, rwork( iru ), m, u, ldu ) + call stdlib${ii}$_zunmbr( 'Q', 'L', 'N', m, m, n, a, lda,work( itauq ), u, ldu, & work( nwork ),lwork-nwork+1, ierr ) ! set all of vt to identity matrix - call stdlib_zlaset( 'F', n, n, czero, cone, vt, ldvt ) + call stdlib${ii}$_zlaset( 'F', n, n, czero, cone, vt, ldvt ) ! copy realmatrix rwork(irvt,KIND=dp) to complex matrix vt ! overwrite vt by right singular vectors of a ! cworkspace: need 2*m [tauq, taup] + n [work] ! cworkspace: prefer 2*m [tauq, taup] + n*nb [work] ! rworkspace: need m [e] + m*m [rvt] - call stdlib_zlacp2( 'F', m, m, rwork( irvt ), m, vt, ldvt ) - call stdlib_zunmbr( 'P', 'R', 'C', n, n, m, a, lda,work( itaup ), vt, ldvt, & + call stdlib${ii}$_zlacp2( 'F', m, m, rwork( irvt ), m, vt, ldvt ) + call stdlib${ii}$_zunmbr( 'P', 'R', 'C', n, n, m, a, lda,work( itaup ), vt, ldvt, & work( nwork ),lwork-nwork+1, ierr ) end if end if end if ! undo scaling if necessary - if( iscl==1 ) then - if( anrm>bignum )call stdlib_dlascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,& + if( iscl==1_${ik}$ ) then + if( anrm>bignum )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn, 1_${ik}$, s, minmn,& ierr ) - if( info/=0 .and. anrm>bignum )call stdlib_dlascl( 'G', 0, 0, bignum, anrm, minmn-1,& - 1,rwork( ie ), minmn, ierr ) - if( anrmbignum )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn-1,& + 1_${ik}$,rwork( ie ), minmn, ierr ) + if( anrm=n .and. minmn>0 ) then - ! space needed for stdlib_zbdsqr is bdspac = 5*n - mnthr = stdlib_ilaenv( 6, 'ZGESVD', jobu // jobvt, m, n, 0, 0 ) - ! compute space needed for stdlib_zgeqrf - call stdlib_zgeqrf( m, n, a, lda, cdum(1), cdum(1), -1, ierr ) - lwork_zgeqrf = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_zungqr - call stdlib_zungqr( m, n, n, a, lda, cdum(1), cdum(1), -1, ierr ) - lwork_zungqr_n = int( cdum(1),KIND=ilp) - call stdlib_zungqr( m, m, n, a, lda, cdum(1), cdum(1), -1, ierr ) - lwork_zungqr_m = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_zgebrd - call stdlib_zgebrd( n, n, a, lda, s, dum(1), cdum(1),cdum(1), cdum(1), -1, ierr ) + ! immediately following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + if( m>=n .and. minmn>0_${ik}$ ) then + ! space needed for stdlib${ii}$_zbdsqr is bdspac = 5*n + mnthr = stdlib${ii}$_ilaenv( 6_${ik}$, 'ZGESVD', jobu // jobvt, m, n, 0_${ik}$, 0_${ik}$ ) + ! compute space needed for stdlib${ii}$_zgeqrf + call stdlib${ii}$_zgeqrf( m, n, a, lda, cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_zgeqrf = int( cdum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_zungqr + call stdlib${ii}$_zungqr( m, n, n, a, lda, cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_zungqr_n = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zungqr( m, m, n, a, lda, cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_zungqr_m = int( cdum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_zgebrd + call stdlib${ii}$_zgebrd( n, n, a, lda, s, dum(1_${ik}$), cdum(1_${ik}$),cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) - lwork_zgebrd = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_zungbr - call stdlib_zungbr( 'P', n, n, n, a, lda, cdum(1),cdum(1), -1, ierr ) - lwork_zungbr_p = int( cdum(1),KIND=ilp) - call stdlib_zungbr( 'Q', n, n, n, a, lda, cdum(1),cdum(1), -1, ierr ) - lwork_zungbr_q = int( cdum(1),KIND=ilp) + lwork_zgebrd = int( cdum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_zungbr + call stdlib${ii}$_zungbr( 'P', n, n, n, a, lda, cdum(1_${ik}$),cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_zungbr_p = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zungbr( 'Q', n, n, n, a, lda, cdum(1_${ik}$),cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_zungbr_q = int( cdum(1_${ik}$),KIND=${ik}$) if( m>=mnthr ) then if( wntun ) then ! path 1 (m much larger than n, jobu='n') maxwrk = n + lwork_zgeqrf - maxwrk = max( maxwrk, 2*n+lwork_zgebrd ) - if( wntvo .or. wntvas )maxwrk = max( maxwrk, 2*n+lwork_zungbr_p ) - minwrk = 3*n + maxwrk = max( maxwrk, 2_${ik}$*n+lwork_zgebrd ) + if( wntvo .or. wntvas )maxwrk = max( maxwrk, 2_${ik}$*n+lwork_zungbr_p ) + minwrk = 3_${ik}$*n else if( wntuo .and. wntvn ) then ! path 2 (m much larger than n, jobu='o', jobvt='n') wrkbl = n + lwork_zgeqrf wrkbl = max( wrkbl, n+lwork_zungqr_n ) - wrkbl = max( wrkbl, 2*n+lwork_zgebrd ) - wrkbl = max( wrkbl, 2*n+lwork_zungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_zgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_zungbr_q ) maxwrk = max( n*n+wrkbl, n*n+m*n ) - minwrk = 2*n + m + minwrk = 2_${ik}$*n + m else if( wntuo .and. wntvas ) then ! path 3 (m much larger than n, jobu='o', jobvt='s' or ! 'a') wrkbl = n + lwork_zgeqrf wrkbl = max( wrkbl, n+lwork_zungqr_n ) - wrkbl = max( wrkbl, 2*n+lwork_zgebrd ) - wrkbl = max( wrkbl, 2*n+lwork_zungbr_q ) - wrkbl = max( wrkbl, 2*n+lwork_zungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_zgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_zungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_zungbr_p ) maxwrk = max( n*n+wrkbl, n*n+m*n ) - minwrk = 2*n + m + minwrk = 2_${ik}$*n + m else if( wntus .and. wntvn ) then ! path 4 (m much larger than n, jobu='s', jobvt='n') wrkbl = n + lwork_zgeqrf wrkbl = max( wrkbl, n+lwork_zungqr_n ) - wrkbl = max( wrkbl, 2*n+lwork_zgebrd ) - wrkbl = max( wrkbl, 2*n+lwork_zungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_zgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_zungbr_q ) maxwrk = n*n + wrkbl - minwrk = 2*n + m + minwrk = 2_${ik}$*n + m else if( wntus .and. wntvo ) then ! path 5 (m much larger than n, jobu='s', jobvt='o') wrkbl = n + lwork_zgeqrf wrkbl = max( wrkbl, n+lwork_zungqr_n ) - wrkbl = max( wrkbl, 2*n+lwork_zgebrd ) - wrkbl = max( wrkbl, 2*n+lwork_zungbr_q ) - wrkbl = max( wrkbl, 2*n+lwork_zungbr_p ) - maxwrk = 2*n*n + wrkbl - minwrk = 2*n + m + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_zgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_zungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_zungbr_p ) + maxwrk = 2_${ik}$*n*n + wrkbl + minwrk = 2_${ik}$*n + m else if( wntus .and. wntvas ) then ! path 6 (m much larger than n, jobu='s', jobvt='s' or ! 'a') wrkbl = n + lwork_zgeqrf wrkbl = max( wrkbl, n+lwork_zungqr_n ) - wrkbl = max( wrkbl, 2*n+lwork_zgebrd ) - wrkbl = max( wrkbl, 2*n+lwork_zungbr_q ) - wrkbl = max( wrkbl, 2*n+lwork_zungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_zgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_zungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_zungbr_p ) maxwrk = n*n + wrkbl - minwrk = 2*n + m + minwrk = 2_${ik}$*n + m else if( wntua .and. wntvn ) then ! path 7 (m much larger than n, jobu='a', jobvt='n') wrkbl = n + lwork_zgeqrf wrkbl = max( wrkbl, n+lwork_zungqr_m ) - wrkbl = max( wrkbl, 2*n+lwork_zgebrd ) - wrkbl = max( wrkbl, 2*n+lwork_zungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_zgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_zungbr_q ) maxwrk = n*n + wrkbl - minwrk = 2*n + m + minwrk = 2_${ik}$*n + m else if( wntua .and. wntvo ) then ! path 8 (m much larger than n, jobu='a', jobvt='o') wrkbl = n + lwork_zgeqrf wrkbl = max( wrkbl, n+lwork_zungqr_m ) - wrkbl = max( wrkbl, 2*n+lwork_zgebrd ) - wrkbl = max( wrkbl, 2*n+lwork_zungbr_q ) - wrkbl = max( wrkbl, 2*n+lwork_zungbr_p ) - maxwrk = 2*n*n + wrkbl - minwrk = 2*n + m + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_zgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_zungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_zungbr_p ) + maxwrk = 2_${ik}$*n*n + wrkbl + minwrk = 2_${ik}$*n + m else if( wntua .and. wntvas ) then ! path 9 (m much larger than n, jobu='a', jobvt='s' or ! 'a') wrkbl = n + lwork_zgeqrf wrkbl = max( wrkbl, n+lwork_zungqr_m ) - wrkbl = max( wrkbl, 2*n+lwork_zgebrd ) - wrkbl = max( wrkbl, 2*n+lwork_zungbr_q ) - wrkbl = max( wrkbl, 2*n+lwork_zungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_zgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_zungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*n+lwork_zungbr_p ) maxwrk = n*n + wrkbl - minwrk = 2*n + m + minwrk = 2_${ik}$*n + m end if else ! path 10 (m at least n, but not much larger) - call stdlib_zgebrd( m, n, a, lda, s, dum(1), cdum(1),cdum(1), cdum(1), -1, & + call stdlib${ii}$_zgebrd( m, n, a, lda, s, dum(1_${ik}$), cdum(1_${ik}$),cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, & ierr ) - lwork_zgebrd = int( cdum(1),KIND=ilp) - maxwrk = 2*n + lwork_zgebrd + lwork_zgebrd = int( cdum(1_${ik}$),KIND=${ik}$) + maxwrk = 2_${ik}$*n + lwork_zgebrd if( wntus .or. wntuo ) then - call stdlib_zungbr( 'Q', m, n, n, a, lda, cdum(1),cdum(1), -1, ierr ) + call stdlib${ii}$_zungbr( 'Q', m, n, n, a, lda, cdum(1_${ik}$),cdum(1_${ik}$), -1_${ik}$, ierr ) - lwork_zungbr_q = int( cdum(1),KIND=ilp) - maxwrk = max( maxwrk, 2*n+lwork_zungbr_q ) + lwork_zungbr_q = int( cdum(1_${ik}$),KIND=${ik}$) + maxwrk = max( maxwrk, 2_${ik}$*n+lwork_zungbr_q ) end if if( wntua ) then - call stdlib_zungbr( 'Q', m, m, n, a, lda, cdum(1),cdum(1), -1, ierr ) + call stdlib${ii}$_zungbr( 'Q', m, m, n, a, lda, cdum(1_${ik}$),cdum(1_${ik}$), -1_${ik}$, ierr ) - lwork_zungbr_q = int( cdum(1),KIND=ilp) - maxwrk = max( maxwrk, 2*n+lwork_zungbr_q ) + lwork_zungbr_q = int( cdum(1_${ik}$),KIND=${ik}$) + maxwrk = max( maxwrk, 2_${ik}$*n+lwork_zungbr_q ) end if if( .not.wntvn ) then - maxwrk = max( maxwrk, 2*n+lwork_zungbr_p ) - end if - minwrk = 2*n + m - end if - else if( minmn>0 ) then - ! space needed for stdlib_zbdsqr is bdspac = 5*m - mnthr = stdlib_ilaenv( 6, 'ZGESVD', jobu // jobvt, m, n, 0, 0 ) - ! compute space needed for stdlib_zgelqf - call stdlib_zgelqf( m, n, a, lda, cdum(1), cdum(1), -1, ierr ) - lwork_zgelqf = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_zunglq - call stdlib_zunglq( n, n, m, cdum(1), n, cdum(1), cdum(1), -1,ierr ) - lwork_zunglq_n = int( cdum(1),KIND=ilp) - call stdlib_zunglq( m, n, m, a, lda, cdum(1), cdum(1), -1, ierr ) - lwork_zunglq_m = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_zgebrd - call stdlib_zgebrd( m, m, a, lda, s, dum(1), cdum(1),cdum(1), cdum(1), -1, ierr ) + maxwrk = max( maxwrk, 2_${ik}$*n+lwork_zungbr_p ) + end if + minwrk = 2_${ik}$*n + m + end if + else if( minmn>0_${ik}$ ) then + ! space needed for stdlib${ii}$_zbdsqr is bdspac = 5*m + mnthr = stdlib${ii}$_ilaenv( 6_${ik}$, 'ZGESVD', jobu // jobvt, m, n, 0_${ik}$, 0_${ik}$ ) + ! compute space needed for stdlib${ii}$_zgelqf + call stdlib${ii}$_zgelqf( m, n, a, lda, cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_zgelqf = int( cdum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_zunglq + call stdlib${ii}$_zunglq( n, n, m, cdum(1_${ik}$), n, cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$,ierr ) + lwork_zunglq_n = int( cdum(1_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zunglq( m, n, m, a, lda, cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_zunglq_m = int( cdum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_zgebrd + call stdlib${ii}$_zgebrd( m, m, a, lda, s, dum(1_${ik}$), cdum(1_${ik}$),cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, ierr ) - lwork_zgebrd = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_zungbr p - call stdlib_zungbr( 'P', m, m, m, a, n, cdum(1),cdum(1), -1, ierr ) - lwork_zungbr_p = int( cdum(1),KIND=ilp) - ! compute space needed for stdlib_zungbr q - call stdlib_zungbr( 'Q', m, m, m, a, n, cdum(1),cdum(1), -1, ierr ) - lwork_zungbr_q = int( cdum(1),KIND=ilp) + lwork_zgebrd = int( cdum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_zungbr p + call stdlib${ii}$_zungbr( 'P', m, m, m, a, n, cdum(1_${ik}$),cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_zungbr_p = int( cdum(1_${ik}$),KIND=${ik}$) + ! compute space needed for stdlib${ii}$_zungbr q + call stdlib${ii}$_zungbr( 'Q', m, m, m, a, n, cdum(1_${ik}$),cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_zungbr_q = int( cdum(1_${ik}$),KIND=${ik}$) if( n>=mnthr ) then if( wntvn ) then ! path 1t(n much larger than m, jobvt='n') maxwrk = m + lwork_zgelqf - maxwrk = max( maxwrk, 2*m+lwork_zgebrd ) - if( wntuo .or. wntuas )maxwrk = max( maxwrk, 2*m+lwork_zungbr_q ) - minwrk = 3*m + maxwrk = max( maxwrk, 2_${ik}$*m+lwork_zgebrd ) + if( wntuo .or. wntuas )maxwrk = max( maxwrk, 2_${ik}$*m+lwork_zungbr_q ) + minwrk = 3_${ik}$*m else if( wntvo .and. wntun ) then ! path 2t(n much larger than m, jobu='n', jobvt='o') wrkbl = m + lwork_zgelqf wrkbl = max( wrkbl, m+lwork_zunglq_m ) - wrkbl = max( wrkbl, 2*m+lwork_zgebrd ) - wrkbl = max( wrkbl, 2*m+lwork_zungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_zgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_zungbr_p ) maxwrk = max( m*m+wrkbl, m*m+m*n ) - minwrk = 2*m + n + minwrk = 2_${ik}$*m + n else if( wntvo .and. wntuas ) then ! path 3t(n much larger than m, jobu='s' or 'a', ! jobvt='o') wrkbl = m + lwork_zgelqf wrkbl = max( wrkbl, m+lwork_zunglq_m ) - wrkbl = max( wrkbl, 2*m+lwork_zgebrd ) - wrkbl = max( wrkbl, 2*m+lwork_zungbr_p ) - wrkbl = max( wrkbl, 2*m+lwork_zungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_zgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_zungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_zungbr_q ) maxwrk = max( m*m+wrkbl, m*m+m*n ) - minwrk = 2*m + n + minwrk = 2_${ik}$*m + n else if( wntvs .and. wntun ) then ! path 4t(n much larger than m, jobu='n', jobvt='s') wrkbl = m + lwork_zgelqf wrkbl = max( wrkbl, m+lwork_zunglq_m ) - wrkbl = max( wrkbl, 2*m+lwork_zgebrd ) - wrkbl = max( wrkbl, 2*m+lwork_zungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_zgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_zungbr_p ) maxwrk = m*m + wrkbl - minwrk = 2*m + n + minwrk = 2_${ik}$*m + n else if( wntvs .and. wntuo ) then ! path 5t(n much larger than m, jobu='o', jobvt='s') wrkbl = m + lwork_zgelqf wrkbl = max( wrkbl, m+lwork_zunglq_m ) - wrkbl = max( wrkbl, 2*m+lwork_zgebrd ) - wrkbl = max( wrkbl, 2*m+lwork_zungbr_p ) - wrkbl = max( wrkbl, 2*m+lwork_zungbr_q ) - maxwrk = 2*m*m + wrkbl - minwrk = 2*m + n + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_zgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_zungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_zungbr_q ) + maxwrk = 2_${ik}$*m*m + wrkbl + minwrk = 2_${ik}$*m + n else if( wntvs .and. wntuas ) then ! path 6t(n much larger than m, jobu='s' or 'a', ! jobvt='s') wrkbl = m + lwork_zgelqf wrkbl = max( wrkbl, m+lwork_zunglq_m ) - wrkbl = max( wrkbl, 2*m+lwork_zgebrd ) - wrkbl = max( wrkbl, 2*m+lwork_zungbr_p ) - wrkbl = max( wrkbl, 2*m+lwork_zungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_zgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_zungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_zungbr_q ) maxwrk = m*m + wrkbl - minwrk = 2*m + n + minwrk = 2_${ik}$*m + n else if( wntva .and. wntun ) then ! path 7t(n much larger than m, jobu='n', jobvt='a') wrkbl = m + lwork_zgelqf wrkbl = max( wrkbl, m+lwork_zunglq_n ) - wrkbl = max( wrkbl, 2*m+lwork_zgebrd ) - wrkbl = max( wrkbl, 2*m+lwork_zungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_zgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_zungbr_p ) maxwrk = m*m + wrkbl - minwrk = 2*m + n + minwrk = 2_${ik}$*m + n else if( wntva .and. wntuo ) then ! path 8t(n much larger than m, jobu='o', jobvt='a') wrkbl = m + lwork_zgelqf wrkbl = max( wrkbl, m+lwork_zunglq_n ) - wrkbl = max( wrkbl, 2*m+lwork_zgebrd ) - wrkbl = max( wrkbl, 2*m+lwork_zungbr_p ) - wrkbl = max( wrkbl, 2*m+lwork_zungbr_q ) - maxwrk = 2*m*m + wrkbl - minwrk = 2*m + n + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_zgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_zungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_zungbr_q ) + maxwrk = 2_${ik}$*m*m + wrkbl + minwrk = 2_${ik}$*m + n else if( wntva .and. wntuas ) then ! path 9t(n much larger than m, jobu='s' or 'a', ! jobvt='a') wrkbl = m + lwork_zgelqf wrkbl = max( wrkbl, m+lwork_zunglq_n ) - wrkbl = max( wrkbl, 2*m+lwork_zgebrd ) - wrkbl = max( wrkbl, 2*m+lwork_zungbr_p ) - wrkbl = max( wrkbl, 2*m+lwork_zungbr_q ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_zgebrd ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_zungbr_p ) + wrkbl = max( wrkbl, 2_${ik}$*m+lwork_zungbr_q ) maxwrk = m*m + wrkbl - minwrk = 2*m + n + minwrk = 2_${ik}$*m + n end if else ! path 10t(n greater than m, but not much larger) - call stdlib_zgebrd( m, n, a, lda, s, dum(1), cdum(1),cdum(1), cdum(1), -1, & + call stdlib${ii}$_zgebrd( m, n, a, lda, s, dum(1_${ik}$), cdum(1_${ik}$),cdum(1_${ik}$), cdum(1_${ik}$), -1_${ik}$, & ierr ) - lwork_zgebrd = int( cdum(1),KIND=ilp) - maxwrk = 2*m + lwork_zgebrd + lwork_zgebrd = int( cdum(1_${ik}$),KIND=${ik}$) + maxwrk = 2_${ik}$*m + lwork_zgebrd if( wntvs .or. wntvo ) then - ! compute space needed for stdlib_zungbr p - call stdlib_zungbr( 'P', m, n, m, a, n, cdum(1),cdum(1), -1, ierr ) - lwork_zungbr_p = int( cdum(1),KIND=ilp) - maxwrk = max( maxwrk, 2*m+lwork_zungbr_p ) + ! compute space needed for stdlib${ii}$_zungbr p + call stdlib${ii}$_zungbr( 'P', m, n, m, a, n, cdum(1_${ik}$),cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_zungbr_p = int( cdum(1_${ik}$),KIND=${ik}$) + maxwrk = max( maxwrk, 2_${ik}$*m+lwork_zungbr_p ) end if if( wntva ) then - call stdlib_zungbr( 'P', n, n, m, a, n, cdum(1),cdum(1), -1, ierr ) - lwork_zungbr_p = int( cdum(1),KIND=ilp) - maxwrk = max( maxwrk, 2*m+lwork_zungbr_p ) + call stdlib${ii}$_zungbr( 'P', n, n, m, a, n, cdum(1_${ik}$),cdum(1_${ik}$), -1_${ik}$, ierr ) + lwork_zungbr_p = int( cdum(1_${ik}$),KIND=${ik}$) + maxwrk = max( maxwrk, 2_${ik}$*m+lwork_zungbr_p ) end if if( .not.wntun ) then - maxwrk = max( maxwrk, 2*m+lwork_zungbr_q ) + maxwrk = max( maxwrk, 2_${ik}$*m+lwork_zungbr_q ) end if - minwrk = 2*m + n + minwrk = 2_${ik}$*m + n end if end if maxwrk = max( maxwrk, minwrk ) - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk if( lworkzero .and. anrmbignum ) then - iscl = 1 - call stdlib_zlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, ierr ) + iscl = 1_${ik}$ + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, ierr ) end if if( m>=n ) then ! a has at least as many rows as columns. if a has sufficiently @@ -67758,32 +67761,32 @@ module stdlib_linalg_lapack_z if( wntun ) then ! path 1 (m much larger than n, jobu='n') ! no left singular vectors to be computed - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: need 0) - call stdlib_zgeqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & + call stdlib${ii}$_zgeqrf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & ierr ) ! zero out below r - if( n > 1 ) then - call stdlib_zlaset( 'L', n-1, n-1, czero, czero, a( 2, 1 ),lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_zlaset( 'L', n-1, n-1, czero, czero, a( 2_${ik}$, 1_${ik}$ ),lda ) end if - ie = 1 - itauq = 1 + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + n iwork = itaup + n ! bidiagonalize r in a ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_zgebrd( n, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& + call stdlib${ii}$_zgebrd( n, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& work( iwork ), lwork-iwork+1,ierr ) - ncvt = 0 + ncvt = 0_${ik}$ if( wntvo .or. wntvas ) then ! if right singular vectors desired, generate p'. ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & + call stdlib${ii}$_zungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) ncvt = n end if @@ -67792,17 +67795,17 @@ module stdlib_linalg_lapack_z ! singular vectors of a in a if desired ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', n, ncvt, 0, 0, s, rwork( ie ), a, lda,cdum, 1, cdum, & - 1, rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'U', n, ncvt, 0_${ik}$, 0_${ik}$, s, rwork( ie ), a, lda,cdum, 1_${ik}$, cdum, & + 1_${ik}$, rwork( irwork ), info ) ! if right singular vectors desired in vt, copy them there - if( wntvas )call stdlib_zlacpy( 'F', n, n, a, lda, vt, ldvt ) + if( wntvas )call stdlib${ii}$_zlacpy( 'F', n, n, a, lda, vt, ldvt ) else if( wntuo .and. wntvn ) then ! path 2 (m much larger than n, jobu='o', jobvt='n') ! n left singular vectors to be overwritten on a and ! no right singular vectors to be computed if( lwork>=n*n+3*n ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=max( wrkbl, lda*n )+lda*n ) then ! work(iu) is lda by n, work(ir) is lda by n ldwrku = lda @@ -67821,38 +67824,38 @@ module stdlib_linalg_lapack_z ! compute a=q*r ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy r to work(ir) and zero out below it - call stdlib_zlacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) - call stdlib_zlaset( 'L', n-1, n-1, czero, czero,work( ir+1 ), ldwrkr ) + call stdlib${ii}$_zlacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) + call stdlib${ii}$_zlaset( 'L', n-1, n-1, czero, czero,work( ir+1 ), ldwrkr ) ! generate q in a ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_zungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_zgebrd( n, n, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ),& + call stdlib${ii}$_zgebrd( n, n, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ),& work( itaup ),work( iwork ), lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing r ! (cworkspace: need n*n+3*n, prefer n*n+2*n+n*nb) ! (rworkspace: need 0) - call stdlib_zungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & + call stdlib${ii}$_zungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) ! (cworkspace: need n*n) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', n, 0, n, 0, s, rwork( ie ), cdum, 1,work( ir ), & - ldwrkr, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'U', n, 0_${ik}$, n, 0_${ik}$, s, rwork( ie ), cdum, 1_${ik}$,work( ir ), & + ldwrkr, cdum, 1_${ik}$,rwork( irwork ), info ) iu = itauq ! multiply q in a by left singular vectors of r in ! work(ir), storing result in work(iu) and copying to a @@ -67860,34 +67863,34 @@ module stdlib_linalg_lapack_z ! (rworkspace: 0) do i = 1, m, ldwrku chunk = min( m-i+1, ldwrku ) - call stdlib_zgemm( 'N', 'N', chunk, n, n, cone, a( i, 1 ),lda, work( ir & + call stdlib${ii}$_zgemm( 'N', 'N', chunk, n, n, cone, a( i, 1_${ik}$ ),lda, work( ir & ), ldwrkr, czero,work( iu ), ldwrku ) - call stdlib_zlacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) + call stdlib${ii}$_zlacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1_${ik}$ ), lda ) end do else ! insufficient workspace for a fast algorithm - ie = 1 - itauq = 1 + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + n iwork = itaup + n ! bidiagonalize a ! (cworkspace: need 2*n+m, prefer 2*n+(m+n)*nb) ! (rworkspace: n) - call stdlib_zgebrd( m, n, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_zgebrd( m, n, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing a ! (cworkspace: need 3*n, prefer 2*n+n*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), & + call stdlib${ii}$_zungbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in a ! (cworkspace: need 0) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', n, 0, m, 0, s, rwork( ie ), cdum, 1,a, lda, cdum, & - 1, rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'U', n, 0_${ik}$, m, 0_${ik}$, s, rwork( ie ), cdum, 1_${ik}$,a, lda, cdum, & + 1_${ik}$, rwork( irwork ), info ) end if else if( wntuo .and. wntvas ) then ! path 3 (m much larger than n, jobu='o', jobvt='s' or 'a') @@ -67895,7 +67898,7 @@ module stdlib_linalg_lapack_z ! n right singular vectors to be computed in vt if( lwork>=n*n+3*n ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=max( wrkbl, lda*n )+lda*n ) then ! work(iu) is lda by n and work(ir) is lda by n ldwrku = lda @@ -67914,36 +67917,36 @@ module stdlib_linalg_lapack_z ! compute a=q*r ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy r to vt, zeroing out below it - call stdlib_zlacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_zlaset( 'L', n-1, n-1, czero, czero,vt( 2, 1 ), ldvt ) + call stdlib${ii}$_zlacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1_${ik}$ )call stdlib${ii}$_zlaset( 'L', n-1, n-1, czero, czero,vt( 2_${ik}$, 1_${ik}$ ), ldvt ) ! generate q in a ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_zungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in vt, copying result to work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_zgebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_zgebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) - call stdlib_zlacpy( 'L', n, n, vt, ldvt, work( ir ), ldwrkr ) + call stdlib${ii}$_zlacpy( 'L', n, n, vt, ldvt, work( ir ), ldwrkr ) ! generate left vectors bidiagonalizing r in work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & + call stdlib${ii}$_zungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), work( & iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing r in vt ! (cworkspace: need n*n+3*n-1, prefer n*n+2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib${ii}$_zungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -67951,8 +67954,8 @@ module stdlib_linalg_lapack_z ! singular vectors of r in vt ! (cworkspace: need n*n) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', n, n, n, 0, s, rwork( ie ), vt,ldvt, work( ir ), & - ldwrkr, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'U', n, n, n, 0_${ik}$, s, rwork( ie ), vt,ldvt, work( ir ), & + ldwrkr, cdum, 1_${ik}$,rwork( irwork ), info ) iu = itauq ! multiply q in a by left singular vectors of r in ! work(ir), storing result in work(iu) and copying to a @@ -67960,47 +67963,47 @@ module stdlib_linalg_lapack_z ! (rworkspace: 0) do i = 1, m, ldwrku chunk = min( m-i+1, ldwrku ) - call stdlib_zgemm( 'N', 'N', chunk, n, n, cone, a( i, 1 ),lda, work( ir & + call stdlib${ii}$_zgemm( 'N', 'N', chunk, n, n, cone, a( i, 1_${ik}$ ),lda, work( ir & ), ldwrkr, czero,work( iu ), ldwrku ) - call stdlib_zlacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1 ), lda ) + call stdlib${ii}$_zlacpy( 'F', chunk, n, work( iu ), ldwrku,a( i, 1_${ik}$ ), lda ) end do else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy r to vt, zeroing out below it - call stdlib_zlacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_zlaset( 'L', n-1, n-1, czero, czero,vt( 2, 1 ), ldvt ) + call stdlib${ii}$_zlacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1_${ik}$ )call stdlib${ii}$_zlaset( 'L', n-1, n-1, czero, czero,vt( 2_${ik}$, 1_${ik}$ ), ldvt ) ! generate q in a ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_zungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in vt ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: n) - call stdlib_zgebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_zgebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in a by left vectors bidiagonalizing r ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_zunmbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), a, lda,& + call stdlib${ii}$_zunmbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), a, lda,& work( iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing r in vt ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib${ii}$_zungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -68008,8 +68011,8 @@ module stdlib_linalg_lapack_z ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', n, n, m, 0, s, rwork( ie ), vt,ldvt, a, lda, cdum,& - 1, rwork( irwork ),info ) + call stdlib${ii}$_zbdsqr( 'U', n, n, m, 0_${ik}$, s, rwork( ie ), vt,ldvt, a, lda, cdum,& + 1_${ik}$, rwork( irwork ),info ) end if else if( wntus ) then if( wntvn ) then @@ -68018,7 +68021,7 @@ module stdlib_linalg_lapack_z ! no right singular vectors to be computed if( lwork>=n*n+3*n ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=wrkbl+lda*n ) then ! work(ir) is lda by n ldwrkr = lda @@ -68031,93 +68034,93 @@ module stdlib_linalg_lapack_z ! compute a=q*r ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(ir), zeroing out below it - call stdlib_zlacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) - call stdlib_zlaset( 'L', n-1, n-1, czero, czero,work( ir+1 ), ldwrkr ) + call stdlib${ii}$_zlacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) + call stdlib${ii}$_zlaset( 'L', n-1, n-1, czero, czero,work( ir+1 ), ldwrkr ) ! generate q in a ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_zungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_zgebrd( n, n, work( ir ), ldwrkr, s,rwork( ie ), work( & + call stdlib${ii}$_zgebrd( n, n, work( ir ), ldwrkr, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing r in work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_zungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) ! (cworkspace: need n*n) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', n, 0, n, 0, s, rwork( ie ), cdum,1, work( ir ),& - ldwrkr, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'U', n, 0_${ik}$, n, 0_${ik}$, s, rwork( ie ), cdum,1_${ik}$, work( ir ),& + ldwrkr, cdum, 1_${ik}$,rwork( irwork ), info ) ! multiply q in a by left singular vectors of r in ! work(ir), storing result in u ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_zgemm( 'N', 'N', m, n, n, cone, a, lda,work( ir ), ldwrkr, & + call stdlib${ii}$_zgemm( 'N', 'N', m, n, n, cone, a, lda,work( ir ), ldwrkr, & czero, u, ldu ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_zlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_zlacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_zungqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zungqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! zero out below r in a - if( n > 1 ) then - call stdlib_zlaset( 'L', n-1, n-1, czero, czero,a( 2, 1 ), lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_zlaset( 'L', n-1, n-1, czero, czero,a( 2_${ik}$, 1_${ik}$ ), lda ) end if ! bidiagonalize r in a ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_zgebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_zgebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left vectors bidiagonalizing r ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_zunmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib${ii}$_zunmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', n, 0, m, 0, s, rwork( ie ), cdum,1, u, ldu, & - cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_zbdsqr( 'U', n, 0_${ik}$, m, 0_${ik}$, s, rwork( ie ), cdum,1_${ik}$, u, ldu, & + cdum, 1_${ik}$, rwork( irwork ),info ) end if else if( wntvo ) then ! path 5 (m much larger than n, jobu='s', jobvt='o') ! n left singular vectors to be computed in u and ! n right singular vectors to be overwritten on a - if( lwork>=2*n*n+3*n ) then + if( lwork>=2_${ik}$*n*n+3*n ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+2*lda*n ) then ! work(iu) is lda by n and work(ir) is lda by n ldwrku = lda @@ -68139,18 +68142,18 @@ module stdlib_linalg_lapack_z ! compute a=q*r ! (cworkspace: need 2*n*n+2*n, prefer 2*n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_zlacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_zlaset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) + call stdlib${ii}$_zlacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_zlaset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) ! generate q in a ! (cworkspace: need 2*n*n+2*n, prefer 2*n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_zungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n @@ -68159,20 +68162,20 @@ module stdlib_linalg_lapack_z ! (cworkspace: need 2*n*n+3*n, ! prefer 2*n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_zgebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib${ii}$_zgebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_zlacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib${ii}$_zlacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate left bidiagonalizing vectors in work(iu) ! (cworkspace: need 2*n*n+3*n, prefer 2*n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib${ii}$_zungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in work(ir) ! (cworkspace: need 2*n*n+3*n-1, ! prefer 2*n*n+2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_zungbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -68180,56 +68183,56 @@ module stdlib_linalg_lapack_z ! right singular vectors of r in work(ir) ! (cworkspace: need 2*n*n) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', n, n, n, 0, s, rwork( ie ),work( ir ), ldwrkr, & - work( iu ),ldwrku, cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_zbdsqr( 'U', n, n, n, 0_${ik}$, s, rwork( ie ),work( ir ), ldwrkr, & + work( iu ),ldwrku, cdum, 1_${ik}$, rwork( irwork ),info ) ! multiply q in a by left singular vectors of r in ! work(iu), storing result in u ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_zgemm( 'N', 'N', m, n, n, cone, a, lda,work( iu ), ldwrku, & + call stdlib${ii}$_zgemm( 'N', 'N', m, n, n, cone, a, lda,work( iu ), ldwrku, & czero, u, ldu ) ! copy right singular vectors of r to a ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_zlacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) + call stdlib${ii}$_zlacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_zlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_zlacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_zungqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zungqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! zero out below r in a - if( n > 1 ) then - call stdlib_zlaset( 'L', n-1, n-1, czero, czero,a( 2, 1 ), lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_zlaset( 'L', n-1, n-1, czero, czero,a( 2_${ik}$, 1_${ik}$ ), lda ) end if ! bidiagonalize r in a ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_zgebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_zgebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left vectors bidiagonalizing r ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_zunmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib${ii}$_zunmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing r in a ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & + call stdlib${ii}$_zungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -68237,8 +68240,8 @@ module stdlib_linalg_lapack_z ! singular vectors of a in a ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', n, n, m, 0, s, rwork( ie ), a,lda, u, ldu, & - cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_zbdsqr( 'U', n, n, m, 0_${ik}$, s, rwork( ie ), a,lda, u, ldu, & + cdum, 1_${ik}$, rwork( irwork ),info ) end if else if( wntvas ) then ! path 6 (m much larger than n, jobu='s', jobvt='s' @@ -68247,7 +68250,7 @@ module stdlib_linalg_lapack_z ! n right singular vectors to be computed in vt if( lwork>=n*n+3*n ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+lda*n ) then ! work(iu) is lda by n ldwrku = lda @@ -68260,37 +68263,37 @@ module stdlib_linalg_lapack_z ! compute a=q*r ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_zlacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_zlaset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) + call stdlib${ii}$_zlacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_zlaset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) ! generate q in a ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_zungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zungqr( m, n, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in work(iu), copying result to vt ! (cworkspace: need n*n+3*n, prefer n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_zgebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib${ii}$_zgebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_zlacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) + call stdlib${ii}$_zlacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) ! generate left bidiagonalizing vectors in work(iu) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib${ii}$_zungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (cworkspace: need n*n+3*n-1, ! prefer n*n+2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib${ii}$_zungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -68298,52 +68301,52 @@ module stdlib_linalg_lapack_z ! right singular vectors of r in vt ! (cworkspace: need n*n) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', n, n, n, 0, s, rwork( ie ), vt,ldvt, work( iu )& - , ldwrku, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'U', n, n, n, 0_${ik}$, s, rwork( ie ), vt,ldvt, work( iu )& + , ldwrku, cdum, 1_${ik}$,rwork( irwork ), info ) ! multiply q in a by left singular vectors of r in ! work(iu), storing result in u ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_zgemm( 'N', 'N', m, n, n, cone, a, lda,work( iu ), ldwrku, & + call stdlib${ii}$_zgemm( 'N', 'N', m, n, n, cone, a, lda,work( iu ), ldwrku, & czero, u, ldu ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_zlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_zlacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_zungqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zungqr( m, n, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to vt, zeroing out below it - call stdlib_zlacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_zlaset( 'L', n-1, n-1, czero, czero,vt( 2, 1 ), & + call stdlib${ii}$_zlacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1_${ik}$ )call stdlib${ii}$_zlaset( 'L', n-1, n-1, czero, czero,vt( 2_${ik}$, 1_${ik}$ ), & ldvt ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in vt ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_zgebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_zgebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in vt ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_zunmbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & + call stdlib${ii}$_zunmbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib${ii}$_zungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -68351,8 +68354,8 @@ module stdlib_linalg_lapack_z ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', n, n, m, 0, s, rwork( ie ), vt,ldvt, u, ldu, & - cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'U', n, n, m, 0_${ik}$, s, rwork( ie ), vt,ldvt, u, ldu, & + cdum, 1_${ik}$,rwork( irwork ), info ) end if end if else if( wntua ) then @@ -68360,9 +68363,9 @@ module stdlib_linalg_lapack_z ! path 7 (m much larger than n, jobu='a', jobvt='n') ! m left singular vectors to be computed in u and ! no right singular vectors to be computed - if( lwork>=n*n+max( n+m, 3*n ) ) then + if( lwork>=n*n+max( n+m, 3_${ik}$*n ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=wrkbl+lda*n ) then ! work(ir) is lda by n ldwrkr = lda @@ -68375,97 +68378,97 @@ module stdlib_linalg_lapack_z ! compute a=q*r, copying result to u ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_zlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_zlacpy( 'L', m, n, a, lda, u, ldu ) ! copy r to work(ir), zeroing out below it - call stdlib_zlacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) - call stdlib_zlaset( 'L', n-1, n-1, czero, czero,work( ir+1 ), ldwrkr ) + call stdlib${ii}$_zlacpy( 'U', n, n, a, lda, work( ir ),ldwrkr ) + call stdlib${ii}$_zlaset( 'L', n-1, n-1, czero, czero,work( ir+1 ), ldwrkr ) ! generate q in u ! (cworkspace: need n*n+n+m, prefer n*n+n+m*nb) ! (rworkspace: 0) - call stdlib_zungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_zgebrd( n, n, work( ir ), ldwrkr, s,rwork( ie ), work( & + call stdlib${ii}$_zgebrd( n, n, work( ir ), ldwrkr, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in work(ir) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_zungbr( 'Q', n, n, n, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of r in work(ir) ! (cworkspace: need n*n) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', n, 0, n, 0, s, rwork( ie ), cdum,1, work( ir ),& - ldwrkr, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'U', n, 0_${ik}$, n, 0_${ik}$, s, rwork( ie ), cdum,1_${ik}$, work( ir ),& + ldwrkr, cdum, 1_${ik}$,rwork( irwork ), info ) ! multiply q in u by left singular vectors of r in ! work(ir), storing result in a ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_zgemm( 'N', 'N', m, n, n, cone, u, ldu,work( ir ), ldwrkr, & + call stdlib${ii}$_zgemm( 'N', 'N', m, n, n, cone, u, ldu,work( ir ), ldwrkr, & czero, a, lda ) ! copy left singular vectors of a from a to u - call stdlib_zlacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_zlacpy( 'F', m, n, a, lda, u, ldu ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_zlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_zlacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need n+m, prefer n+m*nb) ! (rworkspace: 0) - call stdlib_zungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! zero out below r in a - if( n > 1 ) then - call stdlib_zlaset( 'L', n-1, n-1, czero, czero,a( 2, 1 ), lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_zlaset( 'L', n-1, n-1, czero, czero,a( 2_${ik}$, 1_${ik}$ ), lda ) end if ! bidiagonalize r in a ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_zgebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_zgebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in a ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_zunmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib${ii}$_zunmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left ! singular vectors of a in u ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', n, 0, m, 0, s, rwork( ie ), cdum,1, u, ldu, & - cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_zbdsqr( 'U', n, 0_${ik}$, m, 0_${ik}$, s, rwork( ie ), cdum,1_${ik}$, u, ldu, & + cdum, 1_${ik}$, rwork( irwork ),info ) end if else if( wntvo ) then ! path 8 (m much larger than n, jobu='a', jobvt='o') ! m left singular vectors to be computed in u and ! n right singular vectors to be overwritten on a - if( lwork>=2*n*n+max( n+m, 3*n ) ) then + if( lwork>=2_${ik}$*n*n+max( n+m, 3_${ik}$*n ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+2*lda*n ) then ! work(iu) is lda by n and work(ir) is lda by n ldwrku = lda @@ -68487,19 +68490,19 @@ module stdlib_linalg_lapack_z ! compute a=q*r, copying result to u ! (cworkspace: need 2*n*n+2*n, prefer 2*n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_zlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_zlacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need 2*n*n+n+m, prefer 2*n*n+n+m*nb) ! (rworkspace: 0) - call stdlib_zungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_zlacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_zlaset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) + call stdlib${ii}$_zlacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_zlaset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n @@ -68508,20 +68511,20 @@ module stdlib_linalg_lapack_z ! (cworkspace: need 2*n*n+3*n, ! prefer 2*n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_zgebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib${ii}$_zgebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_zlacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib${ii}$_zlacpy( 'U', n, n, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate left bidiagonalizing vectors in work(iu) ! (cworkspace: need 2*n*n+3*n, prefer 2*n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib${ii}$_zungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in work(ir) ! (cworkspace: need 2*n*n+3*n-1, ! prefer 2*n*n+2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_zungbr( 'P', n, n, n, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -68529,57 +68532,57 @@ module stdlib_linalg_lapack_z ! right singular vectors of r in work(ir) ! (cworkspace: need 2*n*n) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', n, n, n, 0, s, rwork( ie ),work( ir ), ldwrkr, & - work( iu ),ldwrku, cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_zbdsqr( 'U', n, n, n, 0_${ik}$, s, rwork( ie ),work( ir ), ldwrkr, & + work( iu ),ldwrku, cdum, 1_${ik}$, rwork( irwork ),info ) ! multiply q in u by left singular vectors of r in ! work(iu), storing result in a ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_zgemm( 'N', 'N', m, n, n, cone, u, ldu,work( iu ), ldwrku, & + call stdlib${ii}$_zgemm( 'N', 'N', m, n, n, cone, u, ldu,work( iu ), ldwrku, & czero, a, lda ) ! copy left singular vectors of a from a to u - call stdlib_zlacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_zlacpy( 'F', m, n, a, lda, u, ldu ) ! copy right singular vectors of r from work(ir) to a - call stdlib_zlacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) + call stdlib${ii}$_zlacpy( 'F', n, n, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_zlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_zlacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need n+m, prefer n+m*nb) ! (rworkspace: 0) - call stdlib_zungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! zero out below r in a - if( n > 1 ) then - call stdlib_zlaset( 'L', n-1, n-1, czero, czero,a( 2, 1 ), lda ) + if( n > 1_${ik}$ ) then + call stdlib${ii}$_zlaset( 'L', n-1, n-1, czero, czero,a( 2_${ik}$, 1_${ik}$ ), lda ) end if ! bidiagonalize r in a ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_zgebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_zgebrd( n, n, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in a ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_zunmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & + call stdlib${ii}$_zunmbr( 'Q', 'R', 'N', m, n, n, a, lda,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in a ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & + call stdlib${ii}$_zungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -68587,17 +68590,17 @@ module stdlib_linalg_lapack_z ! singular vectors of a in a ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', n, n, m, 0, s, rwork( ie ), a,lda, u, ldu, & - cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_zbdsqr( 'U', n, n, m, 0_${ik}$, s, rwork( ie ), a,lda, u, ldu, & + cdum, 1_${ik}$, rwork( irwork ),info ) end if else if( wntvas ) then ! path 9 (m much larger than n, jobu='a', jobvt='s' ! or 'a') ! m left singular vectors to be computed in u and ! n right singular vectors to be computed in vt - if( lwork>=n*n+max( n+m, 3*n ) ) then + if( lwork>=n*n+max( n+m, 3_${ik}$*n ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+lda*n ) then ! work(iu) is lda by n ldwrku = lda @@ -68610,38 +68613,38 @@ module stdlib_linalg_lapack_z ! compute a=q*r, copying result to u ! (cworkspace: need n*n+2*n, prefer n*n+n+n*nb) ! (rworkspace: 0) - call stdlib_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_zlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_zlacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need n*n+n+m, prefer n*n+n+m*nb) ! (rworkspace: 0) - call stdlib_zungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r to work(iu), zeroing out below it - call stdlib_zlacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) - call stdlib_zlaset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) + call stdlib${ii}$_zlacpy( 'U', n, n, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_zlaset( 'L', n-1, n-1, czero, czero,work( iu+1 ), ldwrku ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in work(iu), copying result to vt ! (cworkspace: need n*n+3*n, prefer n*n+2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_zgebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib${ii}$_zgebrd( n, n, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_zlacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) + call stdlib${ii}$_zlacpy( 'U', n, n, work( iu ), ldwrku, vt,ldvt ) ! generate left bidiagonalizing vectors in work(iu) ! (cworkspace: need n*n+3*n, prefer n*n+2*n+n*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & + call stdlib${ii}$_zungbr( 'Q', n, n, n, work( iu ), ldwrku,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (cworkspace: need n*n+3*n-1, ! prefer n*n+2*n+(n-1)*nb) ! (rworkspace: need 0) - call stdlib_zungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib${ii}$_zungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -68649,54 +68652,54 @@ module stdlib_linalg_lapack_z ! right singular vectors of r in vt ! (cworkspace: need n*n) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', n, n, n, 0, s, rwork( ie ), vt,ldvt, work( iu )& - , ldwrku, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'U', n, n, n, 0_${ik}$, s, rwork( ie ), vt,ldvt, work( iu )& + , ldwrku, cdum, 1_${ik}$,rwork( irwork ), info ) ! multiply q in u by left singular vectors of r in ! work(iu), storing result in a ! (cworkspace: need n*n) ! (rworkspace: 0) - call stdlib_zgemm( 'N', 'N', m, n, n, cone, u, ldu,work( iu ), ldwrku, & + call stdlib${ii}$_zgemm( 'N', 'N', m, n, n, cone, u, ldu,work( iu ), ldwrku, & czero, a, lda ) ! copy left singular vectors of a from a to u - call stdlib_zlacpy( 'F', m, n, a, lda, u, ldu ) + call stdlib${ii}$_zlacpy( 'F', m, n, a, lda, u, ldu ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + n ! compute a=q*r, copying result to u ! (cworkspace: need 2*n, prefer n+n*nb) ! (rworkspace: 0) - call stdlib_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zgeqrf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_zlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_zlacpy( 'L', m, n, a, lda, u, ldu ) ! generate q in u ! (cworkspace: need n+m, prefer n+m*nb) ! (rworkspace: 0) - call stdlib_zungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zungqr( m, m, n, u, ldu, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy r from a to vt, zeroing out below it - call stdlib_zlacpy( 'U', n, n, a, lda, vt, ldvt ) - if( n>1 )call stdlib_zlaset( 'L', n-1, n-1, czero, czero,vt( 2, 1 ), & + call stdlib${ii}$_zlacpy( 'U', n, n, a, lda, vt, ldvt ) + if( n>1_${ik}$ )call stdlib${ii}$_zlaset( 'L', n-1, n-1, czero, czero,vt( 2_${ik}$, 1_${ik}$ ), & ldvt ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + n iwork = itaup + n ! bidiagonalize r in vt ! (cworkspace: need 3*n, prefer 2*n+2*n*nb) ! (rworkspace: need n) - call stdlib_zgebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_zgebrd( n, n, vt, ldvt, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply q in u by left bidiagonalizing vectors ! in vt ! (cworkspace: need 2*n+m, prefer 2*n+m*nb) ! (rworkspace: 0) - call stdlib_zunmbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & + call stdlib${ii}$_zunmbr( 'Q', 'R', 'N', m, n, n, vt, ldvt,work( itauq ), u, & ldu, work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in vt ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& + call stdlib${ii}$_zungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ),& lwork-iwork+1, ierr ) irwork = ie + n ! perform bidiagonal qr iteration, computing left @@ -68704,8 +68707,8 @@ module stdlib_linalg_lapack_z ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', n, n, m, 0, s, rwork( ie ), vt,ldvt, u, ldu, & - cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'U', n, n, m, 0_${ik}$, s, rwork( ie ), vt,ldvt, u, ldu, & + cdum, 1_${ik}$,rwork( irwork ), info ) end if end if end if @@ -68713,24 +68716,24 @@ module stdlib_linalg_lapack_z ! m < mnthr ! path 10 (m at least n, but not much larger) ! reduce to bidiagonal form without qr decomposition - ie = 1 - itauq = 1 + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + n iwork = itaup + n ! bidiagonalize a ! (cworkspace: need 2*n+m, prefer 2*n+(m+n)*nb) ! (rworkspace: need n) - call stdlib_zgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_zgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,ierr ) if( wntuas ) then ! if left singular vectors desired in u, copy result to u ! and generate left bidiagonalizing vectors in u ! (cworkspace: need 2*n+ncu, prefer 2*n+ncu*nb) ! (rworkspace: 0) - call stdlib_zlacpy( 'L', m, n, a, lda, u, ldu ) + call stdlib${ii}$_zlacpy( 'L', m, n, a, lda, u, ldu ) if( wntus )ncu = n if( wntua )ncu = m - call stdlib_zungbr( 'Q', m, ncu, n, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_zungbr( 'Q', m, ncu, n, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) end if if( wntvas ) then @@ -68738,8 +68741,8 @@ module stdlib_linalg_lapack_z ! vt and generate right bidiagonalizing vectors in vt ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_zlacpy( 'U', n, n, a, lda, vt, ldvt ) - call stdlib_zungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib${ii}$_zlacpy( 'U', n, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zungbr( 'P', n, n, n, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) end if if( wntuo ) then @@ -68747,7 +68750,7 @@ module stdlib_linalg_lapack_z ! bidiagonalizing vectors in a ! (cworkspace: need 3*n, prefer 2*n+n*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), lwork-& + call stdlib${ii}$_zungbr( 'Q', m, n, n, a, lda, work( itauq ),work( iwork ), lwork-& iwork+1, ierr ) end if if( wntvo ) then @@ -68755,38 +68758,38 @@ module stdlib_linalg_lapack_z ! bidiagonalizing vectors in a ! (cworkspace: need 3*n-1, prefer 2*n+(n-1)*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-& + call stdlib${ii}$_zungbr( 'P', n, n, n, a, lda, work( itaup ),work( iwork ), lwork-& iwork+1, ierr ) end if irwork = ie + n if( wntuas .or. wntuo )nru = m - if( wntun )nru = 0 + if( wntun )nru = 0_${ik}$ if( wntvas .or. wntvo )ncvt = n - if( wntvn )ncvt = 0 + if( wntvn )ncvt = 0_${ik}$ if( ( .not.wntuo ) .and. ( .not.wntvo ) ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', n, ncvt, nru, 0, s, rwork( ie ), vt,ldvt, u, ldu, & - cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_zbdsqr( 'U', n, ncvt, nru, 0_${ik}$, s, rwork( ie ), vt,ldvt, u, ldu, & + cdum, 1_${ik}$, rwork( irwork ),info ) else if( ( .not.wntuo ) .and. wntvo ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in a ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', n, ncvt, nru, 0, s, rwork( ie ), a,lda, u, ldu, cdum,& - 1, rwork( irwork ),info ) + call stdlib${ii}$_zbdsqr( 'U', n, ncvt, nru, 0_${ik}$, s, rwork( ie ), a,lda, u, ldu, cdum,& + 1_${ik}$, rwork( irwork ),info ) else ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in a and computing right singular ! vectors in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', n, ncvt, nru, 0, s, rwork( ie ), vt,ldvt, a, lda, & - cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_zbdsqr( 'U', n, ncvt, nru, 0_${ik}$, s, rwork( ie ), vt,ldvt, a, lda, & + cdum, 1_${ik}$, rwork( irwork ),info ) end if end if else @@ -68797,49 +68800,49 @@ module stdlib_linalg_lapack_z if( wntvn ) then ! path 1t(n much larger than m, jobvt='n') ! no right singular vectors to be computed - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_zgelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & + call stdlib${ii}$_zgelqf( m, n, a, lda, work( itau ), work( iwork ),lwork-iwork+1, & ierr ) ! zero out above l - if (m>1) call stdlib_zlaset( 'U', m-1, m-1, czero, czero, a( 1, 2 ),lda ) - ie = 1 - itauq = 1 + if (m>1_${ik}$) call stdlib${ii}$_zlaset( 'U', m-1, m-1, czero, czero, a( 1_${ik}$, 2_${ik}$ ),lda ) + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + m iwork = itaup + m ! bidiagonalize l in a ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_zgebrd( m, m, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& + call stdlib${ii}$_zgebrd( m, m, a, lda, s, rwork( ie ), work( itauq ),work( itaup ),& work( iwork ), lwork-iwork+1,ierr ) if( wntuo .or. wntuas ) then ! if left singular vectors desired, generate q ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & + call stdlib${ii}$_zungbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) end if irwork = ie + m - nru = 0 + nru = 0_${ik}$ if( wntuo .or. wntuas )nru = m ! perform bidiagonal qr iteration, computing left singular ! vectors of a in a if desired ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', m, 0, nru, 0, s, rwork( ie ), cdum, 1,a, lda, cdum, & - 1, rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'U', m, 0_${ik}$, nru, 0_${ik}$, s, rwork( ie ), cdum, 1_${ik}$,a, lda, cdum, & + 1_${ik}$, rwork( irwork ), info ) ! if left singular vectors desired in u, copy them there - if( wntuas )call stdlib_zlacpy( 'F', m, m, a, lda, u, ldu ) + if( wntuas )call stdlib${ii}$_zlacpy( 'F', m, m, a, lda, u, ldu ) else if( wntvo .and. wntun ) then ! path 2t(n much larger than m, jobu='n', jobvt='o') ! m right singular vectors to be overwritten on a and ! no left singular vectors to be computed if( lwork>=m*m+3*m ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=max( wrkbl, lda*n )+lda*m ) then ! work(iu) is lda by n and work(ir) is lda by m ldwrku = lda @@ -68861,38 +68864,38 @@ module stdlib_linalg_lapack_z ! compute a=l*q ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy l to work(ir) and zero out above it - call stdlib_zlacpy( 'L', m, m, a, lda, work( ir ), ldwrkr ) - call stdlib_zlaset( 'U', m-1, m-1, czero, czero,work( ir+ldwrkr ), ldwrkr ) + call stdlib${ii}$_zlacpy( 'L', m, m, a, lda, work( ir ), ldwrkr ) + call stdlib${ii}$_zlaset( 'U', m-1, m-1, czero, czero,work( ir+ldwrkr ), ldwrkr ) ! generate q in a ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_zunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in work(ir) ! (cworkspace: need m*m+3*m, prefer m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_zgebrd( m, m, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ),& + call stdlib${ii}$_zgebrd( m, m, work( ir ), ldwrkr, s, rwork( ie ),work( itauq ),& work( itaup ),work( iwork ), lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing l ! (cworkspace: need m*m+3*m-1, prefer m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & + call stdlib${ii}$_zungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & iwork ),lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of l in work(ir) ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', m, m, 0, 0, s, rwork( ie ),work( ir ), ldwrkr, & - cdum, 1, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'U', m, m, 0_${ik}$, 0_${ik}$, s, rwork( ie ),work( ir ), ldwrkr, & + cdum, 1_${ik}$, cdum, 1_${ik}$,rwork( irwork ), info ) iu = itauq ! multiply right singular vectors of l in work(ir) by q ! in a, storing result in work(iu) and copying to a @@ -68900,34 +68903,34 @@ module stdlib_linalg_lapack_z ! (rworkspace: 0) do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_zgemm( 'N', 'N', m, blk, m, cone, work( ir ),ldwrkr, a( 1, & + call stdlib${ii}$_zgemm( 'N', 'N', m, blk, m, cone, work( ir ),ldwrkr, a( 1_${ik}$, & i ), lda, czero,work( iu ), ldwrku ) - call stdlib_zlacpy( 'F', m, blk, work( iu ), ldwrku,a( 1, i ), lda ) + call stdlib${ii}$_zlacpy( 'F', m, blk, work( iu ), ldwrku,a( 1_${ik}$, i ), lda ) end do else ! insufficient workspace for a fast algorithm - ie = 1 - itauq = 1 + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + m iwork = itaup + m ! bidiagonalize a ! (cworkspace: need 2*m+n, prefer 2*m+(m+n)*nb) ! (rworkspace: need m) - call stdlib_zgebrd( m, n, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_zgebrd( m, n, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing a ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), & + call stdlib${ii}$_zungbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of a in a ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'L', m, n, 0, 0, s, rwork( ie ), a, lda,cdum, 1, cdum, & - 1, rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'L', m, n, 0_${ik}$, 0_${ik}$, s, rwork( ie ), a, lda,cdum, 1_${ik}$, cdum, & + 1_${ik}$, rwork( irwork ), info ) end if else if( wntvo .and. wntuas ) then ! path 3t(n much larger than m, jobu='s' or 'a', jobvt='o') @@ -68935,7 +68938,7 @@ module stdlib_linalg_lapack_z ! m left singular vectors to be computed in u if( lwork>=m*m+3*m ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=max( wrkbl, lda*n )+lda*m ) then ! work(iu) is lda by n and work(ir) is lda by m ldwrku = lda @@ -68957,35 +68960,35 @@ module stdlib_linalg_lapack_z ! compute a=l*q ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy l to u, zeroing about above it - call stdlib_zlacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_zlaset( 'U', m-1, m-1, czero, czero, u( 1, 2 ),ldu ) + call stdlib${ii}$_zlacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1_${ik}$) call stdlib${ii}$_zlaset( 'U', m-1, m-1, czero, czero, u( 1_${ik}$, 2_${ik}$ ),ldu ) ! generate q in a ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_zunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in u, copying result to work(ir) ! (cworkspace: need m*m+3*m, prefer m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_zgebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_zgebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) - call stdlib_zlacpy( 'U', m, m, u, ldu, work( ir ), ldwrkr ) + call stdlib${ii}$_zlacpy( 'U', m, m, u, ldu, work( ir ), ldwrkr ) ! generate right vectors bidiagonalizing l in work(ir) ! (cworkspace: need m*m+3*m-1, prefer m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & + call stdlib${ii}$_zungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), work( & iwork ),lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing l in u ! (cworkspace: need m*m+3*m, prefer m*m+2*m+m*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_zungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -68993,8 +68996,8 @@ module stdlib_linalg_lapack_z ! singular vectors of l in work(ir) ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( ir ), ldwrkr, u, & - ldu, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'U', m, m, m, 0_${ik}$, s, rwork( ie ),work( ir ), ldwrkr, u, & + ldu, cdum, 1_${ik}$,rwork( irwork ), info ) iu = itauq ! multiply right singular vectors of l in work(ir) by q ! in a, storing result in work(iu) and copying to a @@ -69002,46 +69005,46 @@ module stdlib_linalg_lapack_z ! (rworkspace: 0) do i = 1, n, chunk blk = min( n-i+1, chunk ) - call stdlib_zgemm( 'N', 'N', m, blk, m, cone, work( ir ),ldwrkr, a( 1, & + call stdlib${ii}$_zgemm( 'N', 'N', m, blk, m, cone, work( ir ),ldwrkr, a( 1_${ik}$, & i ), lda, czero,work( iu ), ldwrku ) - call stdlib_zlacpy( 'F', m, blk, work( iu ), ldwrku,a( 1, i ), lda ) + call stdlib${ii}$_zlacpy( 'F', m, blk, work( iu ), ldwrku,a( 1_${ik}$, i ), lda ) end do else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& - 1, ierr ) + call stdlib${ii}$_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-iwork+& + 1_${ik}$, ierr ) ! copy l to u, zeroing out above it - call stdlib_zlacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_zlaset( 'U', m-1, m-1, czero, czero, u( 1, 2 ),ldu ) + call stdlib${ii}$_zlacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1_${ik}$) call stdlib${ii}$_zlaset( 'U', m-1, m-1, czero, czero, u( 1_${ik}$, 2_${ik}$ ),ldu ) ! generate q in a ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_zunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in u ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_zgebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_zgebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right vectors bidiagonalizing l by q in a ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_zunmbr( 'P', 'L', 'C', m, n, m, u, ldu,work( itaup ), a, lda, & + call stdlib${ii}$_zunmbr( 'P', 'L', 'C', m, n, m, u, ldu,work( itaup ), a, lda, & work( iwork ),lwork-iwork+1, ierr ) ! generate left vectors bidiagonalizing l in u ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_zungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -69049,8 +69052,8 @@ module stdlib_linalg_lapack_z ! singular vectors of a in a ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', m, n, m, 0, s, rwork( ie ), a, lda,u, ldu, cdum, & - 1, rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'U', m, n, m, 0_${ik}$, s, rwork( ie ), a, lda,u, ldu, cdum, & + 1_${ik}$, rwork( irwork ), info ) end if else if( wntvs ) then if( wntun ) then @@ -69059,7 +69062,7 @@ module stdlib_linalg_lapack_z ! no left singular vectors to be computed if( lwork>=m*m+3*m ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=wrkbl+lda*m ) then ! work(ir) is lda by m ldwrkr = lda @@ -69072,92 +69075,92 @@ module stdlib_linalg_lapack_z ! compute a=l*q ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy l to work(ir), zeroing out above it - call stdlib_zlacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) - call stdlib_zlaset( 'U', m-1, m-1, czero, czero,work( ir+ldwrkr ), & + call stdlib${ii}$_zlacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) + call stdlib${ii}$_zlaset( 'U', m-1, m-1, czero, czero,work( ir+ldwrkr ), & ldwrkr ) ! generate q in a ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_zunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in work(ir) ! (cworkspace: need m*m+3*m, prefer m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_zgebrd( m, m, work( ir ), ldwrkr, s,rwork( ie ), work( & + call stdlib${ii}$_zgebrd( m, m, work( ir ), ldwrkr, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate right vectors bidiagonalizing l in ! work(ir) ! (cworkspace: need m*m+3*m, prefer m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_zungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of l in work(ir) ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', m, m, 0, 0, s, rwork( ie ),work( ir ), ldwrkr, & - cdum, 1, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'U', m, m, 0_${ik}$, 0_${ik}$, s, rwork( ie ),work( ir ), ldwrkr, & + cdum, 1_${ik}$, cdum, 1_${ik}$,rwork( irwork ), info ) ! multiply right singular vectors of l in work(ir) by ! q in a, storing result in vt ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_zgemm( 'N', 'N', m, n, m, cone, work( ir ),ldwrkr, a, lda, & + call stdlib${ii}$_zgemm( 'N', 'N', m, n, m, cone, work( ir ),ldwrkr, a, lda, & czero, vt, ldvt ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy result to vt - call stdlib_zlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zlacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_zunglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_zunglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_zlaset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda ) + if (m>1_${ik}$) call stdlib${ii}$_zlaset( 'U', m-1, m-1, czero, czero,a( 1_${ik}$, 2_${ik}$ ), lda ) ! bidiagonalize l in a ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_zgebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_zgebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right vectors bidiagonalizing l by q in vt ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_zunmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & + call stdlib${ii}$_zunmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', m, n, 0, 0, s, rwork( ie ), vt,ldvt, cdum, 1, & - cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'U', m, n, 0_${ik}$, 0_${ik}$, s, rwork( ie ), vt,ldvt, cdum, 1_${ik}$, & + cdum, 1_${ik}$,rwork( irwork ), info ) end if else if( wntuo ) then ! path 5t(n much larger than m, jobu='o', jobvt='s') ! m right singular vectors to be computed in vt and ! m left singular vectors to be overwritten on a - if( lwork>=2*m*m+3*m ) then + if( lwork>=2_${ik}$*m*m+3*m ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+2*lda*m ) then ! work(iu) is lda by m and work(ir) is lda by m ldwrku = lda @@ -69179,18 +69182,18 @@ module stdlib_linalg_lapack_z ! compute a=l*q ! (cworkspace: need 2*m*m+2*m, prefer 2*m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy l to work(iu), zeroing out below it - call stdlib_zlacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_zlaset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & + call stdlib${ii}$_zlacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_zlaset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & ldwrku ) ! generate q in a ! (cworkspace: need 2*m*m+2*m, prefer 2*m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_zunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m @@ -69199,20 +69202,20 @@ module stdlib_linalg_lapack_z ! (cworkspace: need 2*m*m+3*m, ! prefer 2*m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_zgebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib${ii}$_zgebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_zlacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib${ii}$_zlacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate right bidiagonalizing vectors in work(iu) ! (cworkspace: need 2*m*m+3*m-1, ! prefer 2*m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib${ii}$_zungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in work(ir) ! (cworkspace: need 2*m*m+3*m, prefer 2*m*m+2*m+m*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_zungbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -69220,53 +69223,53 @@ module stdlib_linalg_lapack_z ! right singular vectors of l in work(iu) ! (cworkspace: need 2*m*m) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( iu ), ldwrku, & - work( ir ),ldwrkr, cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_zbdsqr( 'U', m, m, m, 0_${ik}$, s, rwork( ie ),work( iu ), ldwrku, & + work( ir ),ldwrkr, cdum, 1_${ik}$, rwork( irwork ),info ) ! multiply right singular vectors of l in work(iu) by ! q in a, storing result in vt ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_zgemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, a, lda, & + call stdlib${ii}$_zgemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, a, lda, & czero, vt, ldvt ) ! copy left singular vectors of l to a ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_zlacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) + call stdlib${ii}$_zlacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_zlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zlacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_zunglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_zunglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_zlaset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda ) + if (m>1_${ik}$) call stdlib${ii}$_zlaset( 'U', m-1, m-1, czero, czero,a( 1_${ik}$, 2_${ik}$ ), lda ) ! bidiagonalize l in a ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_zgebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_zgebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right vectors bidiagonalizing l by q in vt ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_zunmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & + call stdlib${ii}$_zunmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors of l in a ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & + call stdlib${ii}$_zungbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -69274,8 +69277,8 @@ module stdlib_linalg_lapack_z ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', m, n, m, 0, s, rwork( ie ), vt,ldvt, a, lda, & - cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'U', m, n, m, 0_${ik}$, s, rwork( ie ), vt,ldvt, a, lda, & + cdum, 1_${ik}$,rwork( irwork ), info ) end if else if( wntuas ) then ! path 6t(n much larger than m, jobu='s' or 'a', @@ -69284,7 +69287,7 @@ module stdlib_linalg_lapack_z ! m left singular vectors to be computed in u if( lwork>=m*m+3*m ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+lda*m ) then ! work(iu) is lda by n ldwrku = lda @@ -69297,37 +69300,37 @@ module stdlib_linalg_lapack_z ! compute a=l*q ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) ! copy l to work(iu), zeroing out above it - call stdlib_zlacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_zlaset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & + call stdlib${ii}$_zlacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_zlaset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & ldwrku ) ! generate q in a ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_zunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zunglq( m, n, m, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in work(iu), copying result to u ! (cworkspace: need m*m+3*m, prefer m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_zgebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib${ii}$_zgebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_zlacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) + call stdlib${ii}$_zlacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) ! generate right bidiagonalizing vectors in work(iu) ! (cworkspace: need m*m+3*m-1, ! prefer m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib${ii}$_zungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (cworkspace: need m*m+3*m, prefer m*m+2*m+m*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_zungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -69335,51 +69338,51 @@ module stdlib_linalg_lapack_z ! singular vectors of l in work(iu) ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( iu ), ldwrku, & - u, ldu, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'U', m, m, m, 0_${ik}$, s, rwork( ie ),work( iu ), ldwrku, & + u, ldu, cdum, 1_${ik}$,rwork( irwork ), info ) ! multiply right singular vectors of l in work(iu) by ! q in a, storing result in vt ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_zgemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, a, lda, & + call stdlib${ii}$_zgemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, a, lda, & czero, vt, ldvt ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_zlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zlacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_zunglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_zunglq( m, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to u, zeroing out above it - call stdlib_zlacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_zlaset( 'U', m-1, m-1, czero, czero,u( 1, 2 ), ldu ) - ie = 1 + call stdlib${ii}$_zlacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1_${ik}$) call stdlib${ii}$_zlaset( 'U', m-1, m-1, czero, czero,u( 1_${ik}$, 2_${ik}$ ), ldu ) + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in u ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_zgebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_zgebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in u by q ! in vt ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_zunmbr( 'P', 'L', 'C', m, n, m, u, ldu,work( itaup ), vt, & + call stdlib${ii}$_zunmbr( 'P', 'L', 'C', m, n, m, u, ldu,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_zungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -69387,8 +69390,8 @@ module stdlib_linalg_lapack_z ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', m, n, m, 0, s, rwork( ie ), vt,ldvt, u, ldu, & - cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'U', m, n, m, 0_${ik}$, s, rwork( ie ), vt,ldvt, u, ldu, & + cdum, 1_${ik}$,rwork( irwork ), info ) end if end if else if( wntva ) then @@ -69396,9 +69399,9 @@ module stdlib_linalg_lapack_z ! path 7t(n much larger than m, jobu='n', jobvt='a') ! n right singular vectors to be computed in vt and ! no left singular vectors to be computed - if( lwork>=m*m+max( n+m, 3*m ) ) then + if( lwork>=m*m+max( n+m, 3_${ik}$*m ) ) then ! sufficient workspace for a fast algorithm - ir = 1 + ir = 1_${ik}$ if( lwork>=wrkbl+lda*m ) then ! work(ir) is lda by m ldwrkr = lda @@ -69411,95 +69414,95 @@ module stdlib_linalg_lapack_z ! compute a=l*q, copying result to vt ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_zlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zlacpy( 'U', m, n, a, lda, vt, ldvt ) ! copy l to work(ir), zeroing out above it - call stdlib_zlacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) - call stdlib_zlaset( 'U', m-1, m-1, czero, czero,work( ir+ldwrkr ), & + call stdlib${ii}$_zlacpy( 'L', m, m, a, lda, work( ir ),ldwrkr ) + call stdlib${ii}$_zlaset( 'U', m-1, m-1, czero, czero,work( ir+ldwrkr ), & ldwrkr ) ! generate q in vt ! (cworkspace: need m*m+m+n, prefer m*m+m+n*nb) ! (rworkspace: 0) - call stdlib_zunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_zunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in work(ir) ! (cworkspace: need m*m+3*m, prefer m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_zgebrd( m, m, work( ir ), ldwrkr, s,rwork( ie ), work( & + call stdlib${ii}$_zgebrd( m, m, work( ir ), ldwrkr, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) ! generate right bidiagonalizing vectors in work(ir) ! (cworkspace: need m*m+3*m-1, ! prefer m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & + call stdlib${ii}$_zungbr( 'P', m, m, m, work( ir ), ldwrkr,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of l in work(ir) ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', m, m, 0, 0, s, rwork( ie ),work( ir ), ldwrkr, & - cdum, 1, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'U', m, m, 0_${ik}$, 0_${ik}$, s, rwork( ie ),work( ir ), ldwrkr, & + cdum, 1_${ik}$, cdum, 1_${ik}$,rwork( irwork ), info ) ! multiply right singular vectors of l in work(ir) by ! q in vt, storing result in a ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_zgemm( 'N', 'N', m, n, m, cone, work( ir ),ldwrkr, vt, ldvt,& + call stdlib${ii}$_zgemm( 'N', 'N', m, n, m, cone, work( ir ),ldwrkr, vt, ldvt,& czero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_zlacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zlacpy( 'F', m, n, a, lda, vt, ldvt ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_zlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zlacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need m+n, prefer m+n*nb) ! (rworkspace: 0) - call stdlib_zunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_zunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_zlaset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda ) + if (m>1_${ik}$) call stdlib${ii}$_zlaset( 'U', m-1, m-1, czero, czero,a( 1_${ik}$, 2_${ik}$ ), lda ) ! bidiagonalize l in a ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_zgebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_zgebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in a by q ! in vt ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_zunmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & + call stdlib${ii}$_zunmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing right ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', m, n, 0, 0, s, rwork( ie ), vt,ldvt, cdum, 1, & - cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'U', m, n, 0_${ik}$, 0_${ik}$, s, rwork( ie ), vt,ldvt, cdum, 1_${ik}$, & + cdum, 1_${ik}$,rwork( irwork ), info ) end if else if( wntuo ) then ! path 8t(n much larger than m, jobu='o', jobvt='a') ! n right singular vectors to be computed in vt and ! m left singular vectors to be overwritten on a - if( lwork>=2*m*m+max( n+m, 3*m ) ) then + if( lwork>=2_${ik}$*m*m+max( n+m, 3_${ik}$*m ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+2*lda*m ) then ! work(iu) is lda by m and work(ir) is lda by m ldwrku = lda @@ -69521,19 +69524,19 @@ module stdlib_linalg_lapack_z ! compute a=l*q, copying result to vt ! (cworkspace: need 2*m*m+2*m, prefer 2*m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_zlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zlacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need 2*m*m+m+n, prefer 2*m*m+m+n*nb) ! (rworkspace: 0) - call stdlib_zunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_zunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to work(iu), zeroing out above it - call stdlib_zlacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_zlaset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & + call stdlib${ii}$_zlacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_zlaset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & ldwrku ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m @@ -69542,20 +69545,20 @@ module stdlib_linalg_lapack_z ! (cworkspace: need 2*m*m+3*m, ! prefer 2*m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_zgebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib${ii}$_zgebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_zlacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) + call stdlib${ii}$_zlacpy( 'L', m, m, work( iu ), ldwrku,work( ir ), ldwrkr ) ! generate right bidiagonalizing vectors in work(iu) ! (cworkspace: need 2*m*m+3*m-1, ! prefer 2*m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib${ii}$_zungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in work(ir) ! (cworkspace: need 2*m*m+3*m, prefer 2*m*m+2*m+m*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & + call stdlib${ii}$_zungbr( 'Q', m, m, m, work( ir ), ldwrkr,work( itauq ), & work( iwork ),lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -69563,54 +69566,54 @@ module stdlib_linalg_lapack_z ! right singular vectors of l in work(iu) ! (cworkspace: need 2*m*m) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( iu ), ldwrku, & - work( ir ),ldwrkr, cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_zbdsqr( 'U', m, m, m, 0_${ik}$, s, rwork( ie ),work( iu ), ldwrku, & + work( ir ),ldwrkr, cdum, 1_${ik}$, rwork( irwork ),info ) ! multiply right singular vectors of l in work(iu) by ! q in vt, storing result in a ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_zgemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, vt, ldvt,& + call stdlib${ii}$_zgemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, vt, ldvt,& czero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_zlacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zlacpy( 'F', m, n, a, lda, vt, ldvt ) ! copy left singular vectors of a from work(ir) to a - call stdlib_zlacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) + call stdlib${ii}$_zlacpy( 'F', m, m, work( ir ), ldwrkr, a,lda ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_zlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zlacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need m+n, prefer m+n*nb) ! (rworkspace: 0) - call stdlib_zunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_zunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! zero out above l in a - if (m>1) call stdlib_zlaset( 'U', m-1, m-1, czero, czero,a( 1, 2 ), lda ) + if (m>1_${ik}$) call stdlib${ii}$_zlaset( 'U', m-1, m-1, czero, czero,a( 1_${ik}$, 2_${ik}$ ), lda ) ! bidiagonalize l in a ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_zgebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_zgebrd( m, m, a, lda, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in a by q ! in vt ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_zunmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & + call stdlib${ii}$_zunmbr( 'P', 'L', 'C', m, n, m, a, lda,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in a ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & + call stdlib${ii}$_zungbr( 'Q', m, m, m, a, lda, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -69618,17 +69621,17 @@ module stdlib_linalg_lapack_z ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', m, n, m, 0, s, rwork( ie ), vt,ldvt, a, lda, & - cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'U', m, n, m, 0_${ik}$, s, rwork( ie ), vt,ldvt, a, lda, & + cdum, 1_${ik}$,rwork( irwork ), info ) end if else if( wntuas ) then ! path 9t(n much larger than m, jobu='s' or 'a', ! jobvt='a') ! n right singular vectors to be computed in vt and ! m left singular vectors to be computed in u - if( lwork>=m*m+max( n+m, 3*m ) ) then + if( lwork>=m*m+max( n+m, 3_${ik}$*m ) ) then ! sufficient workspace for a fast algorithm - iu = 1 + iu = 1_${ik}$ if( lwork>=wrkbl+lda*m ) then ! work(iu) is lda by m ldwrku = lda @@ -69641,37 +69644,37 @@ module stdlib_linalg_lapack_z ! compute a=l*q, copying result to vt ! (cworkspace: need m*m+2*m, prefer m*m+m+m*nb) ! (rworkspace: 0) - call stdlib_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_zlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zlacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need m*m+m+n, prefer m*m+m+n*nb) ! (rworkspace: 0) - call stdlib_zunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_zunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to work(iu), zeroing out above it - call stdlib_zlacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) - call stdlib_zlaset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & + call stdlib${ii}$_zlacpy( 'L', m, m, a, lda, work( iu ),ldwrku ) + call stdlib${ii}$_zlaset( 'U', m-1, m-1, czero, czero,work( iu+ldwrku ), & ldwrku ) - ie = 1 + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in work(iu), copying result to u ! (cworkspace: need m*m+3*m, prefer m*m+2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_zgebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & + call stdlib${ii}$_zgebrd( m, m, work( iu ), ldwrku, s,rwork( ie ), work( & itauq ),work( itaup ), work( iwork ),lwork-iwork+1, ierr ) - call stdlib_zlacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) + call stdlib${ii}$_zlacpy( 'L', m, m, work( iu ), ldwrku, u,ldu ) ! generate right bidiagonalizing vectors in work(iu) ! (cworkspace: need m*m+3*m, prefer m*m+2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & + call stdlib${ii}$_zungbr( 'P', m, m, m, work( iu ), ldwrku,work( itaup ), & work( iwork ),lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (cworkspace: need m*m+3*m, prefer m*m+2*m+m*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_zungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -69679,53 +69682,53 @@ module stdlib_linalg_lapack_z ! singular vectors of l in work(iu) ! (cworkspace: need m*m) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', m, m, m, 0, s, rwork( ie ),work( iu ), ldwrku, & - u, ldu, cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'U', m, m, m, 0_${ik}$, s, rwork( ie ),work( iu ), ldwrku, & + u, ldu, cdum, 1_${ik}$,rwork( irwork ), info ) ! multiply right singular vectors of l in work(iu) by ! q in vt, storing result in a ! (cworkspace: need m*m) ! (rworkspace: 0) - call stdlib_zgemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, vt, ldvt,& + call stdlib${ii}$_zgemm( 'N', 'N', m, n, m, cone, work( iu ),ldwrku, vt, ldvt,& czero, a, lda ) ! copy right singular vectors of a from a to vt - call stdlib_zlacpy( 'F', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zlacpy( 'F', m, n, a, lda, vt, ldvt ) else ! insufficient workspace for a fast algorithm - itau = 1 + itau = 1_${ik}$ iwork = itau + m ! compute a=l*q, copying result to vt ! (cworkspace: need 2*m, prefer m+m*nb) ! (rworkspace: 0) - call stdlib_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& + call stdlib${ii}$_zgelqf( m, n, a, lda, work( itau ),work( iwork ), lwork-& iwork+1, ierr ) - call stdlib_zlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zlacpy( 'U', m, n, a, lda, vt, ldvt ) ! generate q in vt ! (cworkspace: need m+n, prefer m+n*nb) ! (rworkspace: 0) - call stdlib_zunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & + call stdlib${ii}$_zunglq( n, n, m, vt, ldvt, work( itau ),work( iwork ), & lwork-iwork+1, ierr ) ! copy l to u, zeroing out above it - call stdlib_zlacpy( 'L', m, m, a, lda, u, ldu ) - if (m>1) call stdlib_zlaset( 'U', m-1, m-1, czero, czero,u( 1, 2 ), ldu ) - ie = 1 + call stdlib${ii}$_zlacpy( 'L', m, m, a, lda, u, ldu ) + if (m>1_${ik}$) call stdlib${ii}$_zlaset( 'U', m-1, m-1, czero, czero,u( 1_${ik}$, 2_${ik}$ ), ldu ) + ie = 1_${ik}$ itauq = itau itaup = itauq + m iwork = itaup + m ! bidiagonalize l in u ! (cworkspace: need 3*m, prefer 2*m+2*m*nb) ! (rworkspace: need m) - call stdlib_zgebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & + call stdlib${ii}$_zgebrd( m, m, u, ldu, s, rwork( ie ),work( itauq ), work( & itaup ),work( iwork ), lwork-iwork+1, ierr ) ! multiply right bidiagonalizing vectors in u by q ! in vt ! (cworkspace: need 2*m+n, prefer 2*m+n*nb) ! (rworkspace: 0) - call stdlib_zunmbr( 'P', 'L', 'C', m, n, m, u, ldu,work( itaup ), vt, & + call stdlib${ii}$_zunmbr( 'P', 'L', 'C', m, n, m, u, ldu,work( itaup ), vt, & ldvt,work( iwork ), lwork-iwork+1, ierr ) ! generate left bidiagonalizing vectors in u ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & + call stdlib${ii}$_zungbr( 'Q', m, m, m, u, ldu, work( itauq ),work( iwork ), & lwork-iwork+1, ierr ) irwork = ie + m ! perform bidiagonal qr iteration, computing left @@ -69733,8 +69736,8 @@ module stdlib_linalg_lapack_z ! singular vectors of a in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'U', m, n, m, 0, s, rwork( ie ), vt,ldvt, u, ldu, & - cdum, 1,rwork( irwork ), info ) + call stdlib${ii}$_zbdsqr( 'U', m, n, m, 0_${ik}$, s, rwork( ie ), vt,ldvt, u, ldu, & + cdum, 1_${ik}$,rwork( irwork ), info ) end if end if end if @@ -69742,22 +69745,22 @@ module stdlib_linalg_lapack_z ! n < mnthr ! path 10t(n greater than m, but not much larger) ! reduce to bidiagonal form without lq decomposition - ie = 1 - itauq = 1 + ie = 1_${ik}$ + itauq = 1_${ik}$ itaup = itauq + m iwork = itaup + m ! bidiagonalize a ! (cworkspace: need 2*m+n, prefer 2*m+(m+n)*nb) ! (rworkspace: m) - call stdlib_zgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & + call stdlib${ii}$_zgebrd( m, n, a, lda, s, rwork( ie ), work( itauq ),work( itaup ), & work( iwork ), lwork-iwork+1,ierr ) if( wntuas ) then ! if left singular vectors desired in u, copy result to u ! and generate left bidiagonalizing vectors in u ! (cworkspace: need 3*m-1, prefer 2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_zlacpy( 'L', m, m, a, lda, u, ldu ) - call stdlib_zungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( iwork ), lwork-& + call stdlib${ii}$_zlacpy( 'L', m, m, a, lda, u, ldu ) + call stdlib${ii}$_zungbr( 'Q', m, m, n, u, ldu, work( itauq ),work( iwork ), lwork-& iwork+1, ierr ) end if if( wntvas ) then @@ -69765,10 +69768,10 @@ module stdlib_linalg_lapack_z ! vt and generate right bidiagonalizing vectors in vt ! (cworkspace: need 2*m+nrvt, prefer 2*m+nrvt*nb) ! (rworkspace: 0) - call stdlib_zlacpy( 'U', m, n, a, lda, vt, ldvt ) + call stdlib${ii}$_zlacpy( 'U', m, n, a, lda, vt, ldvt ) if( wntva )nrvt = n if( wntvs )nrvt = m - call stdlib_zungbr( 'P', nrvt, n, m, vt, ldvt, work( itaup ),work( iwork ), & + call stdlib${ii}$_zungbr( 'P', nrvt, n, m, vt, ldvt, work( itaup ),work( iwork ), & lwork-iwork+1, ierr ) end if if( wntuo ) then @@ -69776,7 +69779,7 @@ module stdlib_linalg_lapack_z ! bidiagonalizing vectors in a ! (cworkspace: need 3*m-1, prefer 2*m+(m-1)*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'Q', m, m, n, a, lda, work( itauq ),work( iwork ), lwork-& + call stdlib${ii}$_zungbr( 'Q', m, m, n, a, lda, work( itauq ),work( iwork ), lwork-& iwork+1, ierr ) end if if( wntvo ) then @@ -69784,59 +69787,59 @@ module stdlib_linalg_lapack_z ! bidiagonalizing vectors in a ! (cworkspace: need 3*m, prefer 2*m+m*nb) ! (rworkspace: 0) - call stdlib_zungbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-& + call stdlib${ii}$_zungbr( 'P', m, n, m, a, lda, work( itaup ),work( iwork ), lwork-& iwork+1, ierr ) end if irwork = ie + m if( wntuas .or. wntuo )nru = m - if( wntun )nru = 0 + if( wntun )nru = 0_${ik}$ if( wntvas .or. wntvo )ncvt = n - if( wntvn )ncvt = 0 + if( wntvn )ncvt = 0_${ik}$ if( ( .not.wntuo ) .and. ( .not.wntvo ) ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'L', m, ncvt, nru, 0, s, rwork( ie ), vt,ldvt, u, ldu, & - cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_zbdsqr( 'L', m, ncvt, nru, 0_${ik}$, s, rwork( ie ), vt,ldvt, u, ldu, & + cdum, 1_${ik}$, rwork( irwork ),info ) else if( ( .not.wntuo ) .and. wntvo ) then ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in u and computing right singular ! vectors in a ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'L', m, ncvt, nru, 0, s, rwork( ie ), a,lda, u, ldu, cdum,& - 1, rwork( irwork ),info ) + call stdlib${ii}$_zbdsqr( 'L', m, ncvt, nru, 0_${ik}$, s, rwork( ie ), a,lda, u, ldu, cdum,& + 1_${ik}$, rwork( irwork ),info ) else ! perform bidiagonal qr iteration, if desired, computing ! left singular vectors in a and computing right singular ! vectors in vt ! (cworkspace: 0) ! (rworkspace: need bdspac) - call stdlib_zbdsqr( 'L', m, ncvt, nru, 0, s, rwork( ie ), vt,ldvt, a, lda, & - cdum, 1, rwork( irwork ),info ) + call stdlib${ii}$_zbdsqr( 'L', m, ncvt, nru, 0_${ik}$, s, rwork( ie ), vt,ldvt, a, lda, & + cdum, 1_${ik}$, rwork( irwork ),info ) end if end if end if ! undo scaling if necessary - if( iscl==1 ) then - if( anrm>bignum )call stdlib_dlascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn,& + if( iscl==1_${ik}$ ) then + if( anrm>bignum )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn, 1_${ik}$, s, minmn,& ierr ) - if( info/=0 .and. anrm>bignum )call stdlib_dlascl( 'G', 0, 0, bignum, anrm, minmn-1,& - 1,rwork( ie ), minmn, ierr ) - if( anrmbignum )call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, bignum, anrm, minmn-1,& + 1_${ik}$,rwork( ie ), minmn, ierr ) + if( anrm= N. The SVD of A is written as !! [++] [xx] [x0] [xx] @@ -69849,20 +69852,20 @@ module stdlib_linalg_lapack_z numrank, iwork, liwork,cwork, lcwork, rwork, lrwork, info ) ! Scalar Arguments character, intent(in) :: joba, jobp, jobr, jobu, jobv - integer(ilp), intent(in) :: m, n, lda, ldu, ldv, liwork, lrwork - integer(ilp), intent(out) :: numrank, info - integer(ilp), intent(inout) :: lcwork + integer(${ik}$), intent(in) :: m, n, lda, ldu, ldv, liwork, lrwork + integer(${ik}$), intent(out) :: numrank, info + integer(${ik}$), intent(inout) :: lcwork ! Array Arguments complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: u(ldu,*), v(ldv,*), cwork(*) real(dp), intent(out) :: s(*), rwork(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: ierr, nr, n1, optratio, p, q - integer(ilp) :: lwcon, lwqp3, lwrk_zgelqf, lwrk_zgesvd, lwrk_zgesvd2, lwrk_zgeqp3, & + integer(${ik}$) :: ierr, nr, n1, optratio, p, q + integer(${ik}$) :: lwcon, lwqp3, lwrk_zgelqf, lwrk_zgesvd, lwrk_zgesvd2, lwrk_zgeqp3, & lwrk_zgeqrf, lwrk_zunmlq, lwrk_zunmqr, lwrk_zunmqr2, lwlqf, lwqrf, lwsvd, lwsvd2, & lwunq, lwunq2, lwunlq, minwrk, minwrk2, optwrk, optwrk2, iminwrk, rminwrk logical(lk) :: accla, acclm, acclh, ascaled, conda, dntwu, dntwv, lquery, lsvc0, lsvec,& @@ -69870,8 +69873,8 @@ module stdlib_linalg_lapack_z real(dp) :: big, epsln, rtmp, sconda, sfmin complex(dp) :: ctmp ! Local Arrays - complex(dp) :: cdummy(1) - real(dp) :: rdummy(1) + complex(dp) :: cdummy(1_${ik}$) + real(dp) :: rdummy(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,conjg,max,min,real,sqrt ! Executable Statements @@ -69894,40 +69897,40 @@ module stdlib_linalg_lapack_z rowprm = stdlib_lsame( jobp, 'P' ) rtrans = stdlib_lsame( jobr, 'T' ) if ( rowprm ) then - iminwrk = max( 1, n + m - 1 ) - rminwrk = max( 2, m, 5*n ) + iminwrk = max( 1_${ik}$, n + m - 1_${ik}$ ) + rminwrk = max( 2_${ik}$, m, 5_${ik}$*n ) else - iminwrk = max( 1, n ) - rminwrk = max( 2, 5*n ) + iminwrk = max( 1_${ik}$, n ) + rminwrk = max( 2_${ik}$, 5_${ik}$*n ) end if - lquery = (liwork == -1 .or. lcwork == -1 .or. lrwork == -1) - info = 0 + lquery = (liwork == -1_${ik}$ .or. lcwork == -1_${ik}$ .or. lrwork == -1_${ik}$) + info = 0_${ik}$ if ( .not. ( accla .or. acclm .or. acclh ) ) then - info = -1 + info = -1_${ik}$ else if ( .not.( rowprm .or. stdlib_lsame( jobp, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if ( .not.( rtrans .or. stdlib_lsame( jobr, 'N' ) ) ) then - info = -3 + info = -3_${ik}$ else if ( .not.( lsvec .or. dntwu ) ) then - info = -4 + info = -4_${ik}$ else if ( wntur .and. wntva ) then - info = -5 + info = -5_${ik}$ else if ( .not.( rsvec .or. dntwv )) then - info = -5 - else if ( m<0 ) then - info = -6 - else if ( ( n<0 ) .or. ( n>m ) ) then - info = -7 - else if ( ldam ) ) then + info = -7_${ik}$ + else if ( lda big / sqrt(real(m,KIND=dp)) ) then + if ( rwork(1_${ik}$) > big / sqrt(real(m,KIND=dp)) ) then ! .. to prevent overflow in the qr factorization, scale the ! matrix by 1/sqrt(m) if too large entry detected - call stdlib_zlascl('G',0,0,sqrt(real(m,KIND=dp)),one, m,n, a,lda, ierr) + call stdlib${ii}$_zlascl('G',0_${ik}$,0_${ik}$,sqrt(real(m,KIND=dp)),one, m,n, a,lda, ierr) ascaled = .true. end if - call stdlib_zlaswp( n, a, lda, 1, m-1, iwork(n+1), 1 ) + call stdlib${ii}$_zlaswp( n, a, lda, 1_${ik}$, m-1, iwork(n+1), 1_${ik}$ ) end if ! .. at this stage, preemptive scaling is done only to avoid column ! norms overflows during the qr factorization. the svd procedure should ! have its own scaling to save the singular values from overflows and ! underflows. that depends on the svd procedure. if ( .not.rowprm ) then - rtmp = stdlib_zlange( 'M', m, n, a, lda, rwork ) + rtmp = stdlib${ii}$_zlange( 'M', m, n, a, lda, rwork ) if ( ( rtmp /= rtmp ) .or.( (rtmp*zero) /= zero ) ) then - info = -8 - call stdlib_xerbla( 'ZGESVDQ', -info ) + info = -8_${ik}$ + call stdlib${ii}$_xerbla( 'ZGESVDQ', -info ) return end if if ( rtmp > big / sqrt(real(m,KIND=dp)) ) then ! .. to prevent overflow in the qr factorization, scale the ! matrix by 1/sqrt(m) if too large entry detected - call stdlib_zlascl('G',0,0, sqrt(real(m,KIND=dp)),one, m,n, a,lda, ierr) + call stdlib${ii}$_zlascl('G',0_${ik}$,0_${ik}$, sqrt(real(m,KIND=dp)),one, m,n, a,lda, ierr) ascaled = .true. end if @@ -70213,15 +70216,15 @@ module stdlib_linalg_lapack_z ! [ 0 ] do p = 1, n ! All Columns Are Free Columns - iwork(p) = 0 + iwork(p) = 0_${ik}$ end do - call stdlib_zgeqp3( m, n, a, lda, iwork, cwork, cwork(n+1), lcwork-n,rwork, ierr ) + call stdlib${ii}$_zgeqp3( m, n, a, lda, iwork, cwork, cwork(n+1), lcwork-n,rwork, ierr ) ! if the user requested accuracy level allows truncation in the ! computed upper triangular factor, the matrix r is examined and, ! if possible, replaced with its leading upper trapezoidal part. - epsln = stdlib_dlamch('E') - sfmin = stdlib_dlamch('S') + epsln = stdlib${ii}$_dlamch('E') + sfmin = stdlib${ii}$_dlamch('S') ! small = sfmin / epsln nr = n if ( accla ) then @@ -70229,57 +70232,53 @@ module stdlib_linalg_lapack_z ! sigma_i < n*eps*||a||_f are flushed to zero. this is an ! aggressive enforcement of lower numerical rank by introducing a ! backward error of the order of n*eps*||a||_f. - nr = 1 + nr = 1_${ik}$ rtmp = sqrt(real(n,KIND=dp))*epsln - do p = 2, n - if ( abs(a(p,p)) < (rtmp*abs(a(1,1))) ) go to 3002 - nr = nr + 1 - end do - 3002 continue + loop_3002: do p = 2, n + if ( abs(a(p,p)) < (rtmp*abs(a(1,1))) ) exit loop_3002 + nr = nr + 1_${ik}$ + end do loop_3002 elseif ( acclm ) then ! .. similarly as above, only slightly more gentle (less aggressive). ! sudden drop on the diagonal of r is used as the criterion for being - ! close-to-rank-deficient. the threshold is set to epsln=stdlib_dlamch('e'). + ! close-to-rank-deficient. the threshold is set to epsln=stdlib${ii}$_dlamch('e'). ! [[this can be made more flexible by replacing this hard-coded value ! with a user specified threshold.]] also, the values that underflow ! will be truncated. - nr = 1 - do p = 2, n - if ( ( abs(a(p,p)) < (epsln*abs(a(p-1,p-1))) ) .or.( abs(a(p,p)) < sfmin ) ) go & - to 3402 - nr = nr + 1 - end do - 3402 continue + nr = 1_${ik}$ + loop_3402: do p = 2, n + if ( ( abs(a(p,p)) < (epsln*abs(a(p-1,p-1))) ) .or.( abs(a(p,p)) < sfmin ) ) exit loop_3402 + nr = nr + 1_${ik}$ + end do loop_3402 else ! Rrqr Not Authorized To Determine Numerical Rank Except In The ! obvious case of zero pivots. ! .. inspect r for exact zeros on the diagonal; ! r(i,i)=0 => r(i:n,i:n)=0. - nr = 1 - do p = 2, n - if ( abs(a(p,p)) == zero ) go to 3502 - nr = nr + 1 - end do - 3502 continue + nr = 1_${ik}$ + loop_3502: do p = 2, n + if ( abs(a(p,p)) == zero ) exit loop_3502 + nr = nr + 1_${ik}$ + end do loop_3502 if ( conda ) then ! estimate the scaled condition number of a. use the fact that it is ! the same as the scaled condition number of r. ! V Is Used As Workspace - call stdlib_zlacpy( 'U', n, n, a, lda, v, ldv ) + call stdlib${ii}$_zlacpy( 'U', n, n, a, lda, v, ldv ) ! only the leading nr x nr submatrix of the triangular factor ! is considered. only if nr=n will this give a reliable error ! bound. however, even for nr < n, this can be used on an ! expert level and obtain useful information in the sense of ! perturbation theory. do p = 1, nr - rtmp = stdlib_dznrm2( p, v(1,p), 1 ) - call stdlib_zdscal( p, one/rtmp, v(1,p), 1 ) + rtmp = stdlib${ii}$_dznrm2( p, v(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_zdscal( p, one/rtmp, v(1_${ik}$,p), 1_${ik}$ ) end do if ( .not. ( lsvec .or. rsvec ) ) then - call stdlib_zpocon( 'U', nr, v, ldv, one, rtmp,cwork, rwork, ierr ) + call stdlib${ii}$_zpocon( 'U', nr, v, ldv, one, rtmp,cwork, rwork, ierr ) else - call stdlib_zpocon( 'U', nr, v, ldv, one, rtmp,cwork(n+1), rwork, ierr ) + call stdlib${ii}$_zpocon( 'U', nr, v, ldv, one, rtmp,cwork(n+1), rwork, ierr ) end if sconda = one / sqrt(rtmp) @@ -70310,13 +70309,13 @@ module stdlib_linalg_lapack_z if ( q <= nr ) a(p,q) = czero end do end do - call stdlib_zgesvd( 'N', 'N', n, nr, a, lda, s, u, ldu,v, ldv, cwork, lcwork, & + call stdlib${ii}$_zgesvd( 'N', 'N', n, nr, a, lda, s, u, ldu,v, ldv, cwork, lcwork, & rwork, info ) else ! .. compute the singular values of r = [a](1:nr,1:n) - if ( nr > 1 )call stdlib_zlaset( 'L', nr-1,nr-1, czero,czero, a(2,1), lda ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_zlaset( 'L', nr-1,nr-1, czero,czero, a(2_${ik}$,1_${ik}$), lda ) - call stdlib_zgesvd( 'N', 'N', nr, n, a, lda, s, u, ldu,v, ldv, cwork, lcwork, & + call stdlib${ii}$_zgesvd( 'N', 'N', nr, n, a, lda, s, u, ldu,v, ldv, cwork, lcwork, & rwork, info ) end if else if ( lsvec .and. ( .not. rsvec) ) then @@ -70324,7 +70323,7 @@ module stdlib_linalg_lapack_z ! The Singular Values And The Left Singular Vectors Requested ! ......................................................................."""""""" if ( rtrans ) then - ! .. apply stdlib_zgesvd to r**h + ! .. apply stdlib${ii}$_zgesvd to r**h ! .. copy r**h into [u] and overwrite [u] with the right singular ! vectors of r do p = 1, nr @@ -70332,12 +70331,12 @@ module stdlib_linalg_lapack_z u(q,p) = conjg(a(p,q)) end do end do - if ( nr > 1 )call stdlib_zlaset( 'U', nr-1,nr-1, czero,czero, u(1,2), ldu ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_zlaset( 'U', nr-1,nr-1, czero,czero, u(1_${ik}$,2_${ik}$), ldu ) ! .. the left singular vectors not computed, the nr right singular ! vectors overwrite [u](1:nr,1:nr) as conjugate transposed. these ! will be pre-multiplied by q to build the left singular vectors of a. - call stdlib_zgesvd( 'N', 'O', n, nr, u, ldu, s, u, ldu,u, ldu, cwork(n+1), & + call stdlib${ii}$_zgesvd( 'N', 'O', n, nr, u, ldu, s, u, ldu,u, ldu, cwork(n+1), & lcwork-n, rwork, info ) do p = 1, nr u(p,p) = conjg(u(p,p)) @@ -70350,12 +70349,12 @@ module stdlib_linalg_lapack_z else ! Apply Stdlib_Zgesvd To R ! .. copy r into [u] and overwrite [u] with the left singular vectors - call stdlib_zlacpy( 'U', nr, n, a, lda, u, ldu ) - if ( nr > 1 )call stdlib_zlaset( 'L', nr-1, nr-1, czero, czero, u(2,1), ldu ) + call stdlib${ii}$_zlacpy( 'U', nr, n, a, lda, u, ldu ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_zlaset( 'L', nr-1, nr-1, czero, czero, u(2_${ik}$,1_${ik}$), ldu ) ! .. the right singular vectors not computed, the nr left singular ! vectors overwrite [u](1:nr,1:nr) - call stdlib_zgesvd( 'O', 'N', nr, n, u, ldu, s, u, ldu,v, ldv, cwork(n+1), & + call stdlib${ii}$_zgesvd( 'O', 'N', nr, n, u, ldu, s, u, ldu,v, ldv, cwork(n+1), & lcwork-n, rwork, info ) ! .. now [u](1:nr,1:nr) contains the nr left singular vectors of ! r. these will be pre-multiplied by q to build the left singular @@ -70364,36 +70363,36 @@ module stdlib_linalg_lapack_z ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. ( .not.wntuf ) ) then - call stdlib_zlaset('A', m-nr, nr, czero, czero, u(nr+1,1), ldu) + call stdlib${ii}$_zlaset('A', m-nr, nr, czero, czero, u(nr+1,1_${ik}$), ldu) if ( nr < n1 ) then - call stdlib_zlaset( 'A',nr,n1-nr,czero,czero,u(1,nr+1), ldu ) - call stdlib_zlaset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_zlaset( 'A',nr,n1-nr,czero,czero,u(1_${ik}$,nr+1), ldu ) + call stdlib${ii}$_zlaset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) end if end if ! the q matrix from the first qrf is built into the left singular ! vectors matrix u. - if ( .not.wntuf )call stdlib_zunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, & + if ( .not.wntuf )call stdlib${ii}$_zunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, & cwork(n+1), lcwork-n, ierr ) - if ( rowprm .and. .not.wntuf )call stdlib_zlaswp( n1, u, ldu, 1, m-1, iwork(n+1), -& - 1 ) + if ( rowprm .and. .not.wntuf )call stdlib${ii}$_zlaswp( n1, u, ldu, 1_${ik}$, m-1, iwork(n+1), -& + 1_${ik}$ ) else if ( rsvec .and. ( .not. lsvec ) ) then ! ....................................................................... ! The Singular Values And The Right Singular Vectors Requested ! ....................................................................... if ( rtrans ) then - ! .. apply stdlib_zgesvd to r**h + ! .. apply stdlib${ii}$_zgesvd to r**h ! .. copy r**h into v and overwrite v with the left singular vectors do p = 1, nr do q = p, n v(q,p) = conjg(a(p,q)) end do end do - if ( nr > 1 )call stdlib_zlaset( 'U', nr-1,nr-1, czero,czero, v(1,2), ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_zlaset( 'U', nr-1,nr-1, czero,czero, v(1_${ik}$,2_${ik}$), ldv ) ! .. the left singular vectors of r**h overwrite v, the right singular ! vectors not computed if ( wntvr .or. ( nr == n ) ) then - call stdlib_zgesvd( 'O', 'N', n, nr, v, ldv, s, u, ldu,u, ldu, cwork(n+1), & + call stdlib${ii}$_zgesvd( 'O', 'N', n, nr, v, ldv, s, u, ldu,u, ldu, cwork(n+1), & lcwork-n, rwork, info ) do p = 1, nr v(p,p) = conjg(v(p,p)) @@ -70410,15 +70409,15 @@ module stdlib_linalg_lapack_z end do end do end if - call stdlib_zlapmt( .false., nr, n, v, ldv, iwork ) + call stdlib${ii}$_zlapmt( .false., nr, n, v, ldv, iwork ) else ! .. need all n right singular vectors and nr < n ! [!] this is simple implementation that augments [v](1:n,1:nr) ! by padding a zero block. in the case nr << n, a more efficient ! way is to first use the qr factorization. for more details ! how to implement this, see the " full svd " branch. - call stdlib_zlaset('G', n, n-nr, czero, czero, v(1,nr+1), ldv) - call stdlib_zgesvd( 'O', 'N', n, n, v, ldv, s, u, ldu,u, ldu, cwork(n+1), & + call stdlib${ii}$_zlaset('G', n, n-nr, czero, czero, v(1_${ik}$,nr+1), ldv) + call stdlib${ii}$_zgesvd( 'O', 'N', n, n, v, ldv, s, u, ldu,u, ldu, cwork(n+1), & lcwork-n, rwork, info ) do p = 1, n v(p,p) = conjg(v(p,p)) @@ -70428,20 +70427,20 @@ module stdlib_linalg_lapack_z v(p,q) = ctmp end do end do - call stdlib_zlapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_zlapmt( .false., n, n, v, ldv, iwork ) end if else ! Aply Stdlib_Zgesvd To R ! Copy R Into V And Overwrite V With The Right Singular Vectors - call stdlib_zlacpy( 'U', nr, n, a, lda, v, ldv ) - if ( nr > 1 )call stdlib_zlaset( 'L', nr-1, nr-1, czero, czero, v(2,1), ldv ) + call stdlib${ii}$_zlacpy( 'U', nr, n, a, lda, v, ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_zlaset( 'L', nr-1, nr-1, czero, czero, v(2_${ik}$,1_${ik}$), ldv ) ! .. the right singular vectors overwrite v, the nr left singular ! vectors stored in u(1:nr,1:nr) if ( wntvr .or. ( nr == n ) ) then - call stdlib_zgesvd( 'N', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & + call stdlib${ii}$_zgesvd( 'N', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & lcwork-n, rwork, info ) - call stdlib_zlapmt( .false., nr, n, v, ldv, iwork ) + call stdlib${ii}$_zlapmt( .false., nr, n, v, ldv, iwork ) ! .. now [v](1:nr,1:n) contains v(1:n,1:nr)**h else ! .. need all n right singular vectors and nr < n @@ -70449,10 +70448,10 @@ module stdlib_linalg_lapack_z ! by padding a zero block. in the case nr << n, a more efficient ! way is to first use the lq factorization. for more details ! how to implement this, see the " full svd " branch. - call stdlib_zlaset('G', n-nr, n, czero,czero, v(nr+1,1), ldv) - call stdlib_zgesvd( 'N', 'O', n, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & + call stdlib${ii}$_zlaset('G', n-nr, n, czero,czero, v(nr+1,1_${ik}$), ldv) + call stdlib${ii}$_zgesvd( 'N', 'O', n, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & lcwork-n, rwork, info ) - call stdlib_zlapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_zlapmt( .false., n, n, v, ldv, iwork ) end if ! .. now [v] contains the adjoint of the matrix of the right singular ! vectors of a. @@ -70462,7 +70461,7 @@ module stdlib_linalg_lapack_z ! Full Svd Requested ! ....................................................................... if ( rtrans ) then - ! .. apply stdlib_zgesvd to r**h [[this option is left for r + ! .. apply stdlib${ii}$_zgesvd to r**h [[this option is left for r if ( wntvr .or. ( nr == n ) ) then ! .. copy r**h into [v] and overwrite [v] with the left singular ! vectors of r**h @@ -70471,12 +70470,12 @@ module stdlib_linalg_lapack_z v(q,p) = conjg(a(p,q)) end do end do - if ( nr > 1 )call stdlib_zlaset( 'U', nr-1,nr-1, czero,czero, v(1,2), ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_zlaset( 'U', nr-1,nr-1, czero,czero, v(1_${ik}$,2_${ik}$), ldv ) ! .. the left singular vectors of r**h overwrite [v], the nr right ! singular vectors of r**h stored in [u](1:nr,1:nr) as conjugate ! transposed - call stdlib_zgesvd( 'O', 'A', n, nr, v, ldv, s, v, ldv,u, ldu, cwork(n+1), & + call stdlib${ii}$_zgesvd( 'O', 'A', n, nr, v, ldv, s, v, ldv,u, ldu, cwork(n+1), & lcwork-n, rwork, info ) ! Assemble V do p = 1, nr @@ -70494,7 +70493,7 @@ module stdlib_linalg_lapack_z end do end do end if - call stdlib_zlapmt( .false., nr, n, v, ldv, iwork ) + call stdlib${ii}$_zlapmt( .false., nr, n, v, ldv, iwork ) do p = 1, nr u(p,p) = conjg(u(p,p)) do q = p + 1, nr @@ -70504,10 +70503,10 @@ module stdlib_linalg_lapack_z end do end do if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_zlaset('A', m-nr,nr, czero,czero, u(nr+1,1), ldu) + call stdlib${ii}$_zlaset('A', m-nr,nr, czero,czero, u(nr+1,1_${ik}$), ldu) if ( nr < n1 ) then - call stdlib_zlaset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) - call stdlib_zlaset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_zlaset('A',nr,n1-nr,czero,czero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_zlaset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) end if end if @@ -70518,19 +70517,19 @@ module stdlib_linalg_lapack_z ! [[the optimal ratio n/nr for using qrf instead of padding ! with zeros. here hard coded to 2; it must be at least ! two due to work space constraints.]] - ! optratio = stdlib_ilaenv(6, 'zgesvd', 's' // 'o', nr,n,0,0) + ! optratio = stdlib${ii}$_ilaenv(6, 'zgesvd', 's' // 'o', nr,n,0,0) ! optratio = max( optratio, 2 ) - optratio = 2 + optratio = 2_${ik}$ if ( optratio*nr > n ) then do p = 1, nr do q = p, n v(q,p) = conjg(a(p,q)) end do end do - if ( nr > 1 )call stdlib_zlaset('U',nr-1,nr-1, czero,czero, v(1,2),ldv) + if ( nr > 1_${ik}$ )call stdlib${ii}$_zlaset('U',nr-1,nr-1, czero,czero, v(1_${ik}$,2_${ik}$),ldv) - call stdlib_zlaset('A',n,n-nr,czero,czero,v(1,nr+1),ldv) - call stdlib_zgesvd( 'O', 'A', n, n, v, ldv, s, v, ldv,u, ldu, cwork(n+1), & + call stdlib${ii}$_zlaset('A',n,n-nr,czero,czero,v(1_${ik}$,nr+1),ldv) + call stdlib${ii}$_zgesvd( 'O', 'A', n, n, v, ldv, s, v, ldv,u, ldu, cwork(n+1), & lcwork-n, rwork, info ) do p = 1, n v(p,p) = conjg(v(p,p)) @@ -70540,7 +70539,7 @@ module stdlib_linalg_lapack_z v(p,q) = ctmp end do end do - call stdlib_zlapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_zlapmt( .false., n, n, v, ldv, iwork ) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x n1), i.e. (m x n) or (m x m). do p = 1, n @@ -70552,10 +70551,10 @@ module stdlib_linalg_lapack_z end do end do if ( ( n < m ) .and. .not.(wntuf)) then - call stdlib_zlaset('A',m-n,n,czero,czero,u(n+1,1),ldu) + call stdlib${ii}$_zlaset('A',m-n,n,czero,czero,u(n+1,1_${ik}$),ldu) if ( n < n1 ) then - call stdlib_zlaset('A',n,n1-n,czero,czero,u(1,n+1),ldu) - call stdlib_zlaset('A',m-n,n1-n,czero,cone,u(n+1,n+1), ldu ) + call stdlib${ii}$_zlaset('A',n,n1-n,czero,czero,u(1_${ik}$,n+1),ldu) + call stdlib${ii}$_zlaset('A',m-n,n1-n,czero,cone,u(n+1,n+1), ldu ) end if end if else @@ -70566,55 +70565,55 @@ module stdlib_linalg_lapack_z u(q,nr+p) = conjg(a(p,q)) end do end do - if ( nr > 1 )call stdlib_zlaset('U',nr-1,nr-1,czero,czero,u(1,nr+2),ldu) + if ( nr > 1_${ik}$ )call stdlib${ii}$_zlaset('U',nr-1,nr-1,czero,czero,u(1_${ik}$,nr+2),ldu) - call stdlib_zgeqrf( n, nr, u(1,nr+1), ldu, cwork(n+1),cwork(n+nr+1), & + call stdlib${ii}$_zgeqrf( n, nr, u(1_${ik}$,nr+1), ldu, cwork(n+1),cwork(n+nr+1), & lcwork-n-nr, ierr ) do p = 1, nr do q = 1, n v(q,p) = conjg(u(p,nr+q)) end do end do - if (nr>1) call stdlib_zlaset('U',nr-1,nr-1,czero,czero,v(1,2),ldv) - call stdlib_zgesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v,ldv, cwork(n+nr+& - 1),lcwork-n-nr,rwork, info ) - call stdlib_zlaset('A',n-nr,nr,czero,czero,v(nr+1,1),ldv) - call stdlib_zlaset('A',nr,n-nr,czero,czero,v(1,nr+1),ldv) - call stdlib_zlaset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) - call stdlib_zunmqr('R','C', n, n, nr, u(1,nr+1), ldu,cwork(n+1),v,ldv,& + if (nr>1_${ik}$) call stdlib${ii}$_zlaset('U',nr-1,nr-1,czero,czero,v(1_${ik}$,2_${ik}$),ldv) + call stdlib${ii}$_zgesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v,ldv, cwork(n+nr+& + 1_${ik}$),lcwork-n-nr,rwork, info ) + call stdlib${ii}$_zlaset('A',n-nr,nr,czero,czero,v(nr+1,1_${ik}$),ldv) + call stdlib${ii}$_zlaset('A',nr,n-nr,czero,czero,v(1_${ik}$,nr+1),ldv) + call stdlib${ii}$_zlaset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) + call stdlib${ii}$_zunmqr('R','C', n, n, nr, u(1_${ik}$,nr+1), ldu,cwork(n+1),v,ldv,& cwork(n+nr+1),lcwork-n-nr,ierr) - call stdlib_zlapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_zlapmt( .false., n, n, v, ldv, iwork ) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_zlaset('A',m-nr,nr,czero,czero,u(nr+1,1),ldu) + call stdlib${ii}$_zlaset('A',m-nr,nr,czero,czero,u(nr+1,1_${ik}$),ldu) if ( nr < n1 ) then - call stdlib_zlaset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) - call stdlib_zlaset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1),ldu) + call stdlib${ii}$_zlaset('A',nr,n1-nr,czero,czero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_zlaset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1),ldu) end if end if end if end if else - ! .. apply stdlib_zgesvd to r [[this is the recommended option]] + ! .. apply stdlib${ii}$_zgesvd to r [[this is the recommended option]] if ( wntvr .or. ( nr == n ) ) then ! .. copy r into [v] and overwrite v with the right singular vectors - call stdlib_zlacpy( 'U', nr, n, a, lda, v, ldv ) - if ( nr > 1 )call stdlib_zlaset( 'L', nr-1,nr-1, czero,czero, v(2,1), ldv ) + call stdlib${ii}$_zlacpy( 'U', nr, n, a, lda, v, ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_zlaset( 'L', nr-1,nr-1, czero,czero, v(2_${ik}$,1_${ik}$), ldv ) ! .. the right singular vectors of r overwrite [v], the nr left ! singular vectors of r stored in [u](1:nr,1:nr) - call stdlib_zgesvd( 'S', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & + call stdlib${ii}$_zgesvd( 'S', 'O', nr, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & lcwork-n, rwork, info ) - call stdlib_zlapmt( .false., nr, n, v, ldv, iwork ) + call stdlib${ii}$_zlapmt( .false., nr, n, v, ldv, iwork ) ! .. now [v](1:nr,1:n) contains v(1:n,1:nr)**h ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_zlaset('A', m-nr,nr, czero,czero, u(nr+1,1), ldu) + call stdlib${ii}$_zlaset('A', m-nr,nr, czero,czero, u(nr+1,1_${ik}$), ldu) if ( nr < n1 ) then - call stdlib_zlaset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) - call stdlib_zlaset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_zlaset('A',nr,n1-nr,czero,czero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_zlaset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) end if end if @@ -70625,55 +70624,55 @@ module stdlib_linalg_lapack_z ! [[the optimal ratio n/nr for using lq instead of padding ! with zeros. here hard coded to 2; it must be at least ! two due to work space constraints.]] - ! optratio = stdlib_ilaenv(6, 'zgesvd', 's' // 'o', nr,n,0,0) + ! optratio = stdlib${ii}$_ilaenv(6, 'zgesvd', 's' // 'o', nr,n,0,0) ! optratio = max( optratio, 2 ) - optratio = 2 + optratio = 2_${ik}$ if ( optratio * nr > n ) then - call stdlib_zlacpy( 'U', nr, n, a, lda, v, ldv ) - if ( nr > 1 )call stdlib_zlaset('L', nr-1,nr-1, czero,czero, v(2,1),ldv) + call stdlib${ii}$_zlacpy( 'U', nr, n, a, lda, v, ldv ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_zlaset('L', nr-1,nr-1, czero,czero, v(2_${ik}$,1_${ik}$),ldv) ! .. the right singular vectors of r overwrite [v], the nr left ! singular vectors of r stored in [u](1:nr,1:nr) - call stdlib_zlaset('A', n-nr,n, czero,czero, v(nr+1,1),ldv) - call stdlib_zgesvd( 'S', 'O', n, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & + call stdlib${ii}$_zlaset('A', n-nr,n, czero,czero, v(nr+1,1_${ik}$),ldv) + call stdlib${ii}$_zgesvd( 'S', 'O', n, n, v, ldv, s, u, ldu,v, ldv, cwork(n+1), & lcwork-n, rwork, info ) - call stdlib_zlapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_zlapmt( .false., n, n, v, ldv, iwork ) ! .. now [v] contains the adjoint of the matrix of the right ! singular vectors of a. the leading n left singular vectors ! are in [u](1:n,1:n) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x n1), i.e. (m x n) or (m x m). if ( ( n < m ) .and. .not.(wntuf)) then - call stdlib_zlaset('A',m-n,n,czero,czero,u(n+1,1),ldu) + call stdlib${ii}$_zlaset('A',m-n,n,czero,czero,u(n+1,1_${ik}$),ldu) if ( n < n1 ) then - call stdlib_zlaset('A',n,n1-n,czero,czero,u(1,n+1),ldu) - call stdlib_zlaset( 'A',m-n,n1-n,czero,cone,u(n+1,n+1), ldu ) + call stdlib${ii}$_zlaset('A',n,n1-n,czero,czero,u(1_${ik}$,n+1),ldu) + call stdlib${ii}$_zlaset( 'A',m-n,n1-n,czero,cone,u(n+1,n+1), ldu ) end if end if else - call stdlib_zlacpy( 'U', nr, n, a, lda, u(nr+1,1), ldu ) - if ( nr > 1 )call stdlib_zlaset('L',nr-1,nr-1,czero,czero,u(nr+2,1),ldu) + call stdlib${ii}$_zlacpy( 'U', nr, n, a, lda, u(nr+1,1_${ik}$), ldu ) + if ( nr > 1_${ik}$ )call stdlib${ii}$_zlaset('L',nr-1,nr-1,czero,czero,u(nr+2,1_${ik}$),ldu) - call stdlib_zgelqf( nr, n, u(nr+1,1), ldu, cwork(n+1),cwork(n+nr+1), & + call stdlib${ii}$_zgelqf( nr, n, u(nr+1,1_${ik}$), ldu, cwork(n+1),cwork(n+nr+1), & lcwork-n-nr, ierr ) - call stdlib_zlacpy('L',nr,nr,u(nr+1,1),ldu,v,ldv) - if ( nr > 1 )call stdlib_zlaset('U',nr-1,nr-1,czero,czero,v(1,2),ldv) + call stdlib${ii}$_zlacpy('L',nr,nr,u(nr+1,1_${ik}$),ldu,v,ldv) + if ( nr > 1_${ik}$ )call stdlib${ii}$_zlaset('U',nr-1,nr-1,czero,czero,v(1_${ik}$,2_${ik}$),ldv) - call stdlib_zgesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v, ldv, cwork(n+nr+& - 1), lcwork-n-nr, rwork, info ) - call stdlib_zlaset('A',n-nr,nr,czero,czero,v(nr+1,1),ldv) - call stdlib_zlaset('A',nr,n-nr,czero,czero,v(1,nr+1),ldv) - call stdlib_zlaset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) - call stdlib_zunmlq('R','N',n,n,nr,u(nr+1,1),ldu,cwork(n+1),v, ldv, cwork(n+& + call stdlib${ii}$_zgesvd( 'S', 'O', nr, nr, v, ldv, s, u, ldu,v, ldv, cwork(n+nr+& + 1_${ik}$), lcwork-n-nr, rwork, info ) + call stdlib${ii}$_zlaset('A',n-nr,nr,czero,czero,v(nr+1,1_${ik}$),ldv) + call stdlib${ii}$_zlaset('A',nr,n-nr,czero,czero,v(1_${ik}$,nr+1),ldv) + call stdlib${ii}$_zlaset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) + call stdlib${ii}$_zunmlq('R','N',n,n,nr,u(nr+1,1_${ik}$),ldu,cwork(n+1),v, ldv, cwork(n+& nr+1),lcwork-n-nr,ierr) - call stdlib_zlapmt( .false., n, n, v, ldv, iwork ) + call stdlib${ii}$_zlapmt( .false., n, n, v, ldv, iwork ) ! Assemble The Left Singular Vector Matrix U Of Dimensions ! (m x nr) or (m x n) or (m x m). if ( ( nr < m ) .and. .not.(wntuf)) then - call stdlib_zlaset('A',m-nr,nr,czero,czero,u(nr+1,1),ldu) + call stdlib${ii}$_zlaset('A',m-nr,nr,czero,czero,u(nr+1,1_${ik}$),ldu) if ( nr < n1 ) then - call stdlib_zlaset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) - call stdlib_zlaset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) + call stdlib${ii}$_zlaset('A',nr,n1-nr,czero,czero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_zlaset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1), ldu ) end if end if @@ -70683,10 +70682,10 @@ module stdlib_linalg_lapack_z end if ! the q matrix from the first qrf is built into the left singular ! vectors matrix u. - if ( .not. wntuf )call stdlib_zunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, & + if ( .not. wntuf )call stdlib${ii}$_zunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, & cwork(n+1), lcwork-n, ierr ) - if ( rowprm .and. .not.wntuf )call stdlib_zlaswp( n1, u, ldu, 1, m-1, iwork(n+1), -& - 1 ) + if ( rowprm .and. .not.wntuf )call stdlib${ii}$_zlaswp( n1, u, ldu, 1_${ik}$, m-1, iwork(n+1), -& + 1_${ik}$ ) ! ... end of the "full svd" branch end if ! check whether some singular values are returned as zeros, e.g. @@ -70694,27 +70693,27 @@ module stdlib_linalg_lapack_z p = nr do q = p, 1, -1 if ( s(q) > zero ) go to 4002 - nr = nr - 1 + nr = nr - 1_${ik}$ end do 4002 continue ! .. if numerical rank deficiency is detected, the truncated ! singular values are set to zero. - if ( nr < n ) call stdlib_dlaset( 'G', n-nr,1, zero,zero, s(nr+1), n ) + if ( nr < n ) call stdlib${ii}$_dlaset( 'G', n-nr,1_${ik}$, zero,zero, s(nr+1), n ) ! .. undo scaling; this may cause overflow in the largest singular ! values. - if ( ascaled )call stdlib_dlascl( 'G',0,0, one,sqrt(real(m,KIND=dp)), nr,1, s, n, ierr & + if ( ascaled )call stdlib${ii}$_dlascl( 'G',0_${ik}$,0_${ik}$, one,sqrt(real(m,KIND=dp)), nr,1_${ik}$, s, n, ierr & ) - if ( conda ) rwork(1) = sconda - rwork(2) = p - nr + if ( conda ) rwork(1_${ik}$) = sconda + rwork(2_${ik}$) = p - nr ! .. p-nr is the number of singular values that are computed as - ! exact zeros in stdlib_zgesvd() applied to the (possibly truncated) + ! exact zeros in stdlib${ii}$_zgesvd() applied to the (possibly truncated) ! full row rank triangular (trapezoidal) factor of a. numrank = nr return - end subroutine stdlib_zgesvdq + end subroutine stdlib${ii}$_zgesvdq - subroutine stdlib_zgesvx( fact, trans, n, nrhs, a, lda, af, ldaf, ipiv,equed, r, c, b, ldb, & + subroutine stdlib${ii}$_zgesvx( fact, trans, n, nrhs, a, lda, af, ldaf, ipiv,equed, r, c, b, ldb, & !! ZGESVX uses the LU factorization to compute the solution to a complex !! system of linear equations !! A * X = B, @@ -70728,11 +70727,11 @@ module stdlib_linalg_lapack_z ! Scalar Arguments character, intent(inout) :: equed character, intent(in) :: fact, trans - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldaf, ldb, ldx, n, nrhs real(dp), intent(out) :: rcond ! Array Arguments - integer(ilp), intent(inout) :: ipiv(*) + integer(${ik}$), intent(inout) :: ipiv(*) real(dp), intent(out) :: berr(*), ferr(*), rwork(*) real(dp), intent(inout) :: c(*), r(*) complex(dp), intent(inout) :: a(lda,*), af(ldaf,*), b(ldb,*) @@ -70742,12 +70741,12 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: colequ, equil, nofact, notran, rowequ character :: norm - integer(ilp) :: i, infequ, j + integer(${ik}$) :: i, infequ, j real(dp) :: amax, anorm, bignum, colcnd, rcmax, rcmin, rowcnd, rpvgrw, smlnum ! Intrinsic Functions intrinsic :: max,min ! Executable Statements - info = 0 + info = 0_${ik}$ nofact = stdlib_lsame( fact, 'N' ) equil = stdlib_lsame( fact, 'E' ) notran = stdlib_lsame( trans, 'N' ) @@ -70758,26 +70757,26 @@ module stdlib_linalg_lapack_z else rowequ = stdlib_lsame( equed, 'R' ) .or. stdlib_lsame( equed, 'B' ) colequ = stdlib_lsame( equed, 'C' ) .or. stdlib_lsame( equed, 'B' ) - smlnum = stdlib_dlamch( 'SAFE MINIMUM' ) + smlnum = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) bignum = one / smlnum end if ! test the input parameters. if( .not.nofact .and. .not.equil .and. .not.stdlib_lsame( fact, 'F' ) )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 - else if( n<0 ) then - info = -3 - else if( nrhs<0 ) then - info = -4 - else if( lda0 ) then + info = -11_${ik}$ + else if( n>0_${ik}$ ) then rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) else rowcnd = one end if end if - if( colequ .and. info==0 ) then + if( colequ .and. info==0_${ik}$ ) then rcmin = bignum rcmax = zero do j = 1, n @@ -70802,31 +70801,31 @@ module stdlib_linalg_lapack_z rcmax = max( rcmax, c( j ) ) end do if( rcmin<=zero ) then - info = -12 - else if( n>0 ) then + info = -12_${ik}$ + else if( n>0_${ik}$ ) then colcnd = max( rcmin, smlnum ) / min( rcmax, bignum ) else colcnd = one end if end if - if( info==0 ) then - if( ldb0 ) then + if( info>0_${ik}$ ) then ! compute the reciprocal pivot growth factor of the ! leading rank-deficient info columns of a. - rpvgrw = stdlib_zlantr( 'M', 'U', 'N', info, info, af, ldaf,rwork ) + rpvgrw = stdlib${ii}$_zlantr( 'M', 'U', 'N', info, info, af, ldaf,rwork ) if( rpvgrw==zero ) then rpvgrw = one else - rpvgrw = stdlib_zlange( 'M', n, info, a, lda, rwork ) /rpvgrw + rpvgrw = stdlib${ii}$_zlange( 'M', n, info, a, lda, rwork ) /rpvgrw end if - rwork( 1 ) = rpvgrw + rwork( 1_${ik}$ ) = rpvgrw rcond = zero return end if @@ -70873,21 +70872,21 @@ module stdlib_linalg_lapack_z else norm = 'I' end if - anorm = stdlib_zlange( norm, n, n, a, lda, rwork ) - rpvgrw = stdlib_zlantr( 'M', 'U', 'N', n, n, af, ldaf, rwork ) + anorm = stdlib${ii}$_zlange( norm, n, n, a, lda, rwork ) + rpvgrw = stdlib${ii}$_zlantr( 'M', 'U', 'N', n, n, af, ldaf, rwork ) if( rpvgrw==zero ) then rpvgrw = one else - rpvgrw = stdlib_zlange( 'M', n, n, a, lda, rwork ) / rpvgrw + rpvgrw = stdlib${ii}$_zlange( 'M', n, n, a, lda, rwork ) / rpvgrw end if ! compute the reciprocal of the condition number of a. - call stdlib_zgecon( norm, n, af, ldaf, anorm, rcond, work, rwork, info ) + call stdlib${ii}$_zgecon( norm, n, af, ldaf, anorm, rcond, work, rwork, info ) ! compute the solution matrix x. - call stdlib_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) - call stdlib_zgetrs( trans, n, nrhs, af, ldaf, ipiv, x, ldx, info ) + call stdlib${ii}$_zlacpy( 'FULL', n, nrhs, b, ldb, x, ldx ) + call stdlib${ii}$_zgetrs( trans, n, nrhs, af, ldaf, ipiv, x, ldx, info ) ! use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. - call stdlib_zgerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & + call stdlib${ii}$_zgerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x,ldx, ferr, berr, & work, rwork, info ) ! transform the solution matrix x to a solution of the original ! system. @@ -70913,13 +70912,13 @@ module stdlib_linalg_lapack_z end do end if ! set info = n+1 if the matrix is singular to working precision. - if( rcond=n ) then - call stdlib_zgeqr( m, n, a, lda, tq, -1, workq, -1, info2 ) - tszo = int( tq( 1 ),KIND=ilp) - lwo = int( workq( 1 ),KIND=ilp) - call stdlib_zgemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszo, b, ldb, workq, -1, & + call stdlib${ii}$_zgeqr( m, n, a, lda, tq, -1_${ik}$, workq, -1_${ik}$, info2 ) + tszo = int( tq( 1_${ik}$ ),KIND=${ik}$) + lwo = int( workq( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_zgemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszo, b, ldb, workq, -1_${ik}$, & info2 ) - lwo = max( lwo, int( workq( 1 ),KIND=ilp) ) - call stdlib_zgeqr( m, n, a, lda, tq, -2, workq, -2, info2 ) - tszm = int( tq( 1 ),KIND=ilp) - lwm = int( workq( 1 ),KIND=ilp) - call stdlib_zgemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszm, b, ldb, workq, -1, & + lwo = max( lwo, int( workq( 1_${ik}$ ),KIND=${ik}$) ) + call stdlib${ii}$_zgeqr( m, n, a, lda, tq, -2_${ik}$, workq, -2_${ik}$, info2 ) + tszm = int( tq( 1_${ik}$ ),KIND=${ik}$) + lwm = int( workq( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_zgemqr( 'L', trans, m, nrhs, n, a, lda, tq,tszm, b, ldb, workq, -1_${ik}$, & info2 ) - lwm = max( lwm, int( workq( 1 ),KIND=ilp) ) + lwm = max( lwm, int( workq( 1_${ik}$ ),KIND=${ik}$) ) wsizeo = tszo + lwo wsizem = tszm + lwm else - call stdlib_zgelq( m, n, a, lda, tq, -1, workq, -1, info2 ) - tszo = int( tq( 1 ),KIND=ilp) - lwo = int( workq( 1 ),KIND=ilp) - call stdlib_zgemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszo, b, ldb, workq, -1, & + call stdlib${ii}$_zgelq( m, n, a, lda, tq, -1_${ik}$, workq, -1_${ik}$, info2 ) + tszo = int( tq( 1_${ik}$ ),KIND=${ik}$) + lwo = int( workq( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_zgemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszo, b, ldb, workq, -1_${ik}$, & info2 ) - lwo = max( lwo, int( workq( 1 ),KIND=ilp) ) - call stdlib_zgelq( m, n, a, lda, tq, -2, workq, -2, info2 ) - tszm = int( tq( 1 ),KIND=ilp) - lwm = int( workq( 1 ),KIND=ilp) - call stdlib_zgemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszm, b, ldb, workq, -1, & + lwo = max( lwo, int( workq( 1_${ik}$ ),KIND=${ik}$) ) + call stdlib${ii}$_zgelq( m, n, a, lda, tq, -2_${ik}$, workq, -2_${ik}$, info2 ) + tszm = int( tq( 1_${ik}$ ),KIND=${ik}$) + lwm = int( workq( 1_${ik}$ ),KIND=${ik}$) + call stdlib${ii}$_zgemlq( 'L', trans, n, nrhs, m, a, lda, tq,tszm, b, ldb, workq, -1_${ik}$, & info2 ) - lwm = max( lwm, int( workq( 1 ),KIND=ilp) ) + lwm = max( lwm, int( workq( 1_${ik}$ ),KIND=${ik}$) ) wsizeo = tszo + lwo wsizem = tszm + lwm end if if( ( lworkzero .and. anrmbignum ) then ! scale matrix norm down to bignum - call stdlib_zlascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) - iascl = 2 + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, m, n, a, lda, info ) + iascl = 2_${ik}$ else if( anrm==zero ) then ! matrix all zero. return zero solution. - call stdlib_zlaset( 'F', maxmn, nrhs, czero, czero, b, ldb ) + call stdlib${ii}$_zlaset( 'F', maxmn, nrhs, czero, czero, b, ldb ) go to 50 end if brow = m if ( tran ) then brow = n end if - bnrm = stdlib_zlange( 'M', brow, nrhs, b, ldb, dum ) - ibscl = 0 + bnrm = stdlib${ii}$_zlange( 'M', brow, nrhs, b, ldb, dum ) + ibscl = 0_${ik}$ if( bnrm>zero .and. bnrmbignum ) then ! scale matrix norm down to bignum - call stdlib_zlascl( 'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb,info ) - ibscl = 2 + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bignum, brow, nrhs, b, ldb,info ) + ibscl = 2_${ik}$ end if if ( m>=n ) then ! compute qr factorization of a - call stdlib_zgeqr( m, n, a, lda, work( lw2+1 ), lw1,work( 1 ), lw2, info ) + call stdlib${ii}$_zgeqr( m, n, a, lda, work( lw2+1 ), lw1,work( 1_${ik}$ ), lw2, info ) if ( .not.tran ) then ! least-squares problem min || a * x - b || ! b(1:m,1:nrhs) := q**t * b(1:m,1:nrhs) - call stdlib_zgemqr( 'L' , 'C', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, work(& - 1 ), lw2,info ) + call stdlib${ii}$_zgemqr( 'L' , 'C', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, work(& + 1_${ik}$ ), lw2,info ) ! b(1:n,1:nrhs) := inv(r) * b(1:n,1:nrhs) - call stdlib_ztrtrs( 'U', 'N', 'N', n, nrhs,a, lda, b, ldb, info ) - if( info>0 ) then + call stdlib${ii}$_ztrtrs( 'U', 'N', 'N', n, nrhs,a, lda, b, ldb, info ) + if( info>0_${ik}$ ) then return end if scllen = n else ! overdetermined system of equations a**t * x = b ! b(1:n,1:nrhs) := inv(r**t) * b(1:n,1:nrhs) - call stdlib_ztrtrs( 'U', 'C', 'N', n, nrhs,a, lda, b, ldb, info ) - if( info>0 ) then + call stdlib${ii}$_ztrtrs( 'U', 'C', 'N', n, nrhs,a, lda, b, ldb, info ) + if( info>0_${ik}$ ) then return end if ! b(n+1:m,1:nrhs) = czero @@ -71099,19 +71098,19 @@ module stdlib_linalg_lapack_z end do end do ! b(1:m,1:nrhs) := q(1:n,:) * b(1:n,1:nrhs) - call stdlib_zgemqr( 'L', 'N', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, & - work( 1 ), lw2,info ) + call stdlib${ii}$_zgemqr( 'L', 'N', m, nrhs, n, a, lda,work( lw2+1 ), lw1, b, ldb, & + work( 1_${ik}$ ), lw2,info ) scllen = m end if else ! compute lq factorization of a - call stdlib_zgelq( m, n, a, lda, work( lw2+1 ), lw1,work( 1 ), lw2, info ) + call stdlib${ii}$_zgelq( m, n, a, lda, work( lw2+1 ), lw1,work( 1_${ik}$ ), lw2, info ) ! workspace at least m, optimally m*nb. if( .not.tran ) then ! underdetermined system of equations a * x = b ! b(1:m,1:nrhs) := inv(l) * b(1:m,1:nrhs) - call stdlib_ztrtrs( 'L', 'N', 'N', m, nrhs,a, lda, b, ldb, info ) - if( info>0 ) then + call stdlib${ii}$_ztrtrs( 'L', 'N', 'N', m, nrhs,a, lda, b, ldb, info ) + if( info>0_${ik}$ ) then return end if ! b(m+1:n,1:nrhs) = 0 @@ -71121,42 +71120,42 @@ module stdlib_linalg_lapack_z end do end do ! b(1:n,1:nrhs) := q(1:n,:)**t * b(1:m,1:nrhs) - call stdlib_zgemlq( 'L', 'C', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & - work( 1 ), lw2,info ) + call stdlib${ii}$_zgemlq( 'L', 'C', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & + work( 1_${ik}$ ), lw2,info ) ! workspace at least nrhs, optimally nrhs*nb scllen = n else ! overdetermined system min || a**t * x - b || ! b(1:n,1:nrhs) := q * b(1:n,1:nrhs) - call stdlib_zgemlq( 'L', 'N', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & - work( 1 ), lw2,info ) + call stdlib${ii}$_zgemlq( 'L', 'N', n, nrhs, m, a, lda,work( lw2+1 ), lw1, b, ldb, & + work( 1_${ik}$ ), lw2,info ) ! workspace at least nrhs, optimally nrhs*nb ! b(1:m,1:nrhs) := inv(l**t) * b(1:m,1:nrhs) - call stdlib_ztrtrs( 'L', 'C', 'N', m, nrhs,a, lda, b, ldb, info ) - if( info>0 ) then + call stdlib${ii}$_ztrtrs( 'L', 'C', 'N', m, nrhs,a, lda, b, ldb, info ) + if( info>0_${ik}$ ) then return end if scllen = m end if end if ! undo scaling - if( iascl==1 ) then - call stdlib_zlascl( 'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb,info ) - else if( iascl==2 ) then - call stdlib_zlascl( 'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb,info ) + if( iascl==1_${ik}$ ) then + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, smlnum, scllen, nrhs, b, ldb,info ) + else if( iascl==2_${ik}$ ) then + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, bignum, scllen, nrhs, b, ldb,info ) end if - if( ibscl==1 ) then - call stdlib_zlascl( 'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb,info ) - else if( ibscl==2 ) then - call stdlib_zlascl( 'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb,info ) + if( ibscl==1_${ik}$ ) then + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, smlnum, bnrm, scllen, nrhs, b, ldb,info ) + else if( ibscl==2_${ik}$ ) then + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bignum, bnrm, scllen, nrhs, b, ldb,info ) end if 50 continue - work( 1 ) = real( tszo + lwo,KIND=dp) + work( 1_${ik}$ ) = real( tszo + lwo,KIND=dp) return - end subroutine stdlib_zgetsls + end subroutine stdlib${ii}$_zgetsls - pure subroutine stdlib_zgetsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) + pure subroutine stdlib${ii}$_zgetsqrhrt( m, n, mb1, nb1, nb2, a, lda, t, ldt, work,lwork, info ) !! ZGETSQRHRT computes a NB2-sized column blocked QR-factorization !! of a complex M-by-N matrix A with M >= N, !! A = Q * R. @@ -71174,8 +71173,8 @@ module stdlib_linalg_lapack_z ! -- 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, nb1, nb2, mb1 + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldt, lwork, m, n, nb1, nb2, mb1 ! Array Arguments complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: t(ldt,*), work(*) @@ -71183,41 +71182,41 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: lquery - integer(ilp) :: i, iinfo, j, lw1, lw2, lwt, ldwt, lworkopt, nb1local, nb2local, & + integer(${ik}$) :: i, iinfo, j, lw1, lw2, lwt, ldwt, lworkopt, nb1local, nb2local, & num_all_row_blocks ! Intrinsic Functions intrinsic :: ceiling,real,cmplx,max,min ! Executable Statements ! test the input arguments - info = 0 - lquery = lwork==-1 - if( m<0 ) then - info = -1 - else if( n<0 .or. mzero .and. anrmzero .and. bnrm1 ) then - call stdlib_zlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& + call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vsl, ldvsl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& , ldvsl ) end if - call stdlib_zungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & + call stdlib${ii}$_zungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vsr - if( ilvsr )call stdlib_zlaset( 'FULL', n, n, czero, cone, vsr, ldvsr ) + if( ilvsr )call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vsr, ldvsr ) ! reduce to generalized hessenberg form ! (workspace: none needed) - call stdlib_zgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& + call stdlib${ii}$_zgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& ierr ) - sdim = 0 + sdim = 0_${ik}$ ! perform qz algorithm, computing schur vectors if desired ! (complex workspace: need n) ! (real workspace: need n) iwrk = itau - call stdlib_zhgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, & + call stdlib${ii}$_zhgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, & ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 30 end if @@ -71496,52 +71495,52 @@ module stdlib_linalg_lapack_z ! (workspace: none needed) if( wantst ) then ! undo scaling on eigenvalues before selecting - if( ilascl )call stdlib_zlascl( 'G', 0, 0, anrm, anrmto, n, 1, alpha, n, ierr ) + if( ilascl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, 1_${ik}$, alpha, n, ierr ) - if( ilbscl )call stdlib_zlascl( 'G', 0, 0, bnrm, bnrmto, n, 1, beta, n, ierr ) + if( ilbscl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, 1_${ik}$, beta, n, ierr ) ! select eigenvalues do i = 1, n bwork( i ) = selctg( alpha( i ), beta( i ) ) end do - call stdlib_ztgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,beta, vsl, & - ldvsl, vsr, ldvsr, sdim, pvsl, pvsr,dif, work( iwrk ), lwork-iwrk+1, idum, 1, ierr ) + call stdlib${ii}$_ztgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,beta, vsl, & + ldvsl, vsr, ldvsr, sdim, pvsl, pvsr,dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$, ierr ) - if( ierr==1 )info = n + 3 + if( ierr==1_${ik}$ )info = n + 3_${ik}$ end if ! apply back-permutation to vsl and vsr ! (workspace: none needed) - if( ilvsl )call stdlib_zggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), & + if( ilvsl )call stdlib${ii}$_zggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), & n, vsl, ldvsl, ierr ) - if( ilvsr )call stdlib_zggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), & + if( ilvsr )call stdlib${ii}$_zggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), & n, vsr, ldvsr, ierr ) ! undo scaling if( ilascl ) then - call stdlib_zlascl( 'U', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) - call stdlib_zlascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) + call stdlib${ii}$_zlascl( 'U', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr ) end if if( ilbscl ) then - call stdlib_zlascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) - call stdlib_zlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + call stdlib${ii}$_zlascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) end if if( wantst ) then ! check if reordering is correct lastsl = .true. - sdim = 0 + sdim = 0_${ik}$ do i = 1, n cursl = selctg( alpha( i ), beta( i ) ) - if( cursl )sdim = sdim + 1 - if( cursl .and. .not.lastsl )info = n + 2 + if( cursl )sdim = sdim + 1_${ik}$ + if( cursl .and. .not.lastsl )info = n + 2_${ik}$ lastsl = cursl end do end if 30 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_zgges + end subroutine stdlib${ii}$_zgges - subroutine stdlib_zggesx( jobvsl, jobvsr, sort, selctg, sense, n, a, lda,b, ldb, sdim, alpha,& + subroutine stdlib${ii}$_zggesx( jobvsl, jobvsr, sort, selctg, sense, n, a, lda,b, ldb, sdim, alpha,& !! ZGGESX computes for a pair of N-by-N complex nonsymmetric matrices !! (A,B), the generalized eigenvalues, the complex Schur form (S,T), !! and, optionally, the left and/or right matrices of Schur vectors (VSL @@ -71571,12 +71570,12 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvsl, jobvsr, sense, sort - integer(ilp), intent(out) :: info, sdim - integer(ilp), intent(in) :: lda, ldb, ldvsl, ldvsr, liwork, lwork, n + integer(${ik}$), intent(out) :: info, sdim + integer(${ik}$), intent(in) :: lda, ldb, ldvsl, ldvsr, liwork, lwork, n ! Array Arguments logical(lk), intent(out) :: bwork(*) - integer(ilp), intent(out) :: iwork(*) - real(dp), intent(out) :: rconde(2), rcondv(2), rwork(*) + integer(${ik}$), intent(out) :: iwork(*) + real(dp), intent(out) :: rconde(2_${ik}$), rcondv(2_${ik}$), rwork(*) complex(dp), intent(inout) :: a(lda,*), b(ldb,*) complex(dp), intent(out) :: alpha(*), beta(*), vsl(ldvsl,*), vsr(ldvsr,*), work(*) @@ -71588,33 +71587,33 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, wantsb, wantse, & wantsn, wantst, wantsv - integer(ilp) :: i, icols, ierr, ihi, ijob, ijobvl, ijobvr, ileft, ilo, iright, irows, & + integer(${ik}$) :: i, icols, ierr, ihi, ijob, ijobvl, ijobvr, ileft, ilo, iright, irows, & irwrk, itau, iwrk, liwmin, lwrk, maxwrk, minwrk real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pl, pr, smlnum ! Local Arrays - real(dp) :: dif(2) + real(dp) :: dif(2_${ik}$) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvsl, 'N' ) ) then - ijobvl = 1 + ijobvl = 1_${ik}$ ilvsl = .false. else if( stdlib_lsame( jobvsl, 'V' ) ) then - ijobvl = 2 + ijobvl = 2_${ik}$ ilvsl = .true. else - ijobvl = -1 + ijobvl = -1_${ik}$ ilvsl = .false. end if if( stdlib_lsame( jobvsr, 'N' ) ) then - ijobvr = 1 + ijobvr = 1_${ik}$ ilvsr = .false. else if( stdlib_lsame( jobvsr, 'V' ) ) then - ijobvr = 2 + ijobvr = 2_${ik}$ ilvsr = .true. else - ijobvr = -1 + ijobvr = -1_${ik}$ ilvsr = .false. end if wantst = stdlib_lsame( sort, 'S' ) @@ -71622,94 +71621,94 @@ module stdlib_linalg_lapack_z wantse = stdlib_lsame( sense, 'E' ) wantsv = stdlib_lsame( sense, 'V' ) wantsb = stdlib_lsame( sense, 'B' ) - lquery = ( lwork==-1 .or. liwork==-1 ) + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) if( wantsn ) then - ijob = 0 + ijob = 0_${ik}$ else if( wantse ) then - ijob = 1 + ijob = 1_${ik}$ else if( wantsv ) then - ijob = 2 + ijob = 2_${ik}$ else if( wantsb ) then - ijob = 4 + ijob = 4_${ik}$ end if ! test the input arguments - info = 0 - if( ijobvl<=0 ) then - info = -1 - else if( ijobvr<=0 ) then - info = -2 + info = 0_${ik}$ + if( ijobvl<=0_${ik}$ ) then + info = -1_${ik}$ + else if( ijobvr<=0_${ik}$ ) then + info = -2_${ik}$ else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then - info = -3 + info = -3_${ik}$ else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. & .not.wantsn ) ) then - info = -5 - else if( n<0 ) then - info = -6 - else if( lda0) then - minwrk = 2*n - maxwrk = n*(1 + stdlib_ilaenv( 1, 'ZGEQRF', ' ', n, 1, n, 0 ) ) - maxwrk = max( maxwrk, n*( 1 +stdlib_ilaenv( 1, 'ZUNMQR', ' ', n, 1, n, -1 ) ) ) + ! following subroutine, as returned by stdlib${ii}$_ilaenv.) + if( info==0_${ik}$ ) then + if( n>0_${ik}$) then + minwrk = 2_${ik}$*n + maxwrk = n*(1_${ik}$ + stdlib${ii}$_ilaenv( 1_${ik}$, 'ZGEQRF', ' ', n, 1_${ik}$, n, 0_${ik}$ ) ) + maxwrk = max( maxwrk, n*( 1_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNMQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) ) ) if( ilvsl ) then - maxwrk = max( maxwrk, n*( 1 +stdlib_ilaenv( 1, 'ZUNGQR', ' ', n, 1, n, -1 ) ) & + maxwrk = max( maxwrk, n*( 1_${ik}$ +stdlib${ii}$_ilaenv( 1_${ik}$, 'ZUNGQR', ' ', n, 1_${ik}$, n, -1_${ik}$ ) ) & ) end if lwrk = maxwrk - if( ijob>=1 )lwrk = max( lwrk, n*n/2 ) + if( ijob>=1_${ik}$ )lwrk = max( lwrk, n*n/2_${ik}$ ) else - minwrk = 1 - maxwrk = 1 - lwrk = 1 + minwrk = 1_${ik}$ + maxwrk = 1_${ik}$ + lwrk = 1_${ik}$ end if - work( 1 ) = lwrk - if( wantsn .or. n==0 ) then - liwmin = 1 + work( 1_${ik}$ ) = lwrk + if( wantsn .or. n==0_${ik}$ ) then + liwmin = 1_${ik}$ else - liwmin = n + 2 + liwmin = n + 2_${ik}$ end if - iwork( 1 ) = liwmin + iwork( 1_${ik}$ ) = liwmin if( lworkzero .and. anrmzero .and. bnrm1 ) then - call stdlib_zlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& + call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vsl, ldvsl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& , ldvsl ) end if - call stdlib_zungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & + call stdlib${ii}$_zungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vsr - if( ilvsr )call stdlib_zlaset( 'FULL', n, n, czero, cone, vsr, ldvsr ) + if( ilvsr )call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vsr, ldvsr ) ! reduce to generalized hessenberg form ! (workspace: none needed) - call stdlib_zgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& + call stdlib${ii}$_zgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& ierr ) - sdim = 0 + sdim = 0_${ik}$ ! perform qz algorithm, computing schur vectors if desired ! (complex workspace: need n) ! (real workspace: need n) iwrk = itau - call stdlib_zhgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, & + call stdlib${ii}$_zhgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, & ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 40 end if @@ -71787,9 +71786,9 @@ module stdlib_linalg_lapack_z ! condition number(s) if( wantst ) then ! undo scaling on eigenvalues before selctging - if( ilascl )call stdlib_zlascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) + if( ilascl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr ) - if( ilbscl )call stdlib_zlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + if( ilbscl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) ! select eigenvalues do i = 1, n @@ -71799,59 +71798,59 @@ module stdlib_linalg_lapack_z ! compute reciprocal condition numbers ! (complex workspace: if ijob >= 1, need max(1, 2*sdim*(n-sdim)) ! otherwise, need 1 ) - call stdlib_ztgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alpha, beta, vsl, & + call stdlib${ii}$_ztgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb,alpha, beta, vsl, & ldvsl, vsr, ldvsr, sdim, pl, pr,dif, work( iwrk ), lwork-iwrk+1, iwork, liwork,ierr & ) - if( ijob>=1 )maxwrk = max( maxwrk, 2*sdim*( n-sdim ) ) - if( ierr==-21 ) then + if( ijob>=1_${ik}$ )maxwrk = max( maxwrk, 2_${ik}$*sdim*( n-sdim ) ) + if( ierr==-21_${ik}$ ) then ! not enough complex workspace - info = -21 + info = -21_${ik}$ else - if( ijob==1 .or. ijob==4 ) then - rconde( 1 ) = pl - rconde( 2 ) = pr + if( ijob==1_${ik}$ .or. ijob==4_${ik}$ ) then + rconde( 1_${ik}$ ) = pl + rconde( 2_${ik}$ ) = pr end if - if( ijob==2 .or. ijob==4 ) then - rcondv( 1 ) = dif( 1 ) - rcondv( 2 ) = dif( 2 ) + if( ijob==2_${ik}$ .or. ijob==4_${ik}$ ) then + rcondv( 1_${ik}$ ) = dif( 1_${ik}$ ) + rcondv( 2_${ik}$ ) = dif( 2_${ik}$ ) end if - if( ierr==1 )info = n + 3 + if( ierr==1_${ik}$ )info = n + 3_${ik}$ end if end if ! apply permutation to vsl and vsr ! (workspace: none needed) - if( ilvsl )call stdlib_zggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), & + if( ilvsl )call stdlib${ii}$_zggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), & n, vsl, ldvsl, ierr ) - if( ilvsr )call stdlib_zggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), & + if( ilvsr )call stdlib${ii}$_zggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), & n, vsr, ldvsr, ierr ) ! undo scaling if( ilascl ) then - call stdlib_zlascl( 'U', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) - call stdlib_zlascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) + call stdlib${ii}$_zlascl( 'U', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr ) end if if( ilbscl ) then - call stdlib_zlascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) - call stdlib_zlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + call stdlib${ii}$_zlascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) end if if( wantst ) then ! check if reordering is correct lastsl = .true. - sdim = 0 + sdim = 0_${ik}$ do i = 1, n cursl = selctg( alpha( i ), beta( i ) ) - if( cursl )sdim = sdim + 1 - if( cursl .and. .not.lastsl )info = n + 2 + if( cursl )sdim = sdim + 1_${ik}$ + if( cursl .and. .not.lastsl )info = n + 2_${ik}$ lastsl = cursl end do end if 40 continue - work( 1 ) = maxwrk - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = maxwrk + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_zggesx + end subroutine stdlib${ii}$_zggesx - subroutine stdlib_zggev( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, & + subroutine stdlib${ii}$_zggev( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, & !! ZGGEV computes for a pair of N-by-N complex nonsymmetric matrices !! (A,B), the generalized eigenvalues, and optionally, the left and/or !! right generalized eigenvectors. @@ -71873,8 +71872,8 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvl, jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n ! Array Arguments real(dp), intent(out) :: rwork(*) complex(dp), intent(inout) :: a(lda,*), b(ldb,*) @@ -71885,12 +71884,12 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery character :: chtemp - integer(ilp) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,& + integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,& itau, iwrk, jc, jr, lwkmin, lwkopt real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp complex(dp) :: x ! Local Arrays - logical(lk) :: ldumma(1) + logical(lk) :: ldumma(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,aimag,max,sqrt ! Statement Functions @@ -71900,64 +71899,64 @@ module stdlib_linalg_lapack_z ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvl, 'N' ) ) then - ijobvl = 1 + ijobvl = 1_${ik}$ ilvl = .false. else if( stdlib_lsame( jobvl, 'V' ) ) then - ijobvl = 2 + ijobvl = 2_${ik}$ ilvl = .true. else - ijobvl = -1 + ijobvl = -1_${ik}$ ilvl = .false. end if if( stdlib_lsame( jobvr, 'N' ) ) then - ijobvr = 1 + ijobvr = 1_${ik}$ ilvr = .false. else if( stdlib_lsame( jobvr, 'V' ) ) then - ijobvr = 2 + ijobvr = 2_${ik}$ ilvr = .true. else - ijobvr = -1 + ijobvr = -1_${ik}$ ilvr = .false. end if ilv = ilvl .or. ilvr ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( ijobvl<=0 ) then - info = -1 - else if( ijobvr<=0 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldazero .and. anrmzero .and. bnrm1 ) then - call stdlib_zlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& + call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vl, ldvl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& ldvl ) end if - call stdlib_zungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & + call stdlib${ii}$_zungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vr - if( ilvr )call stdlib_zlaset( 'FULL', n, n, czero, cone, vr, ldvr ) + if( ilvr )call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vr, ldvr ) ! reduce to generalized hessenberg form if( ilv ) then ! eigenvectors requested -- work on whole matrix. - call stdlib_zgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib${ii}$_zgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & ierr ) else - call stdlib_zgghrd( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & + call stdlib${ii}$_zgghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & ldb, vl, ldvl, vr, ldvr, ierr ) end if ! perform qz algorithm (compute eigenvalues, and optionally, the @@ -72048,15 +72047,15 @@ module stdlib_linalg_lapack_z else chtemp = 'E' end if - call stdlib_zhgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, & + call stdlib${ii}$_zhgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, & ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 70 end if @@ -72073,16 +72072,16 @@ module stdlib_linalg_lapack_z else chtemp = 'R' end if - call stdlib_ztgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & + call stdlib${ii}$_ztgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & in, work( iwrk ), rwork( irwrk ),ierr ) - if( ierr/=0 ) then - info = n + 2 + if( ierr/=0_${ik}$ ) then + info = n + 2_${ik}$ go to 70 end if ! undo balancing on vl and vr and normalization ! (workspace: none needed) if( ilvl ) then - call stdlib_zggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,& + call stdlib${ii}$_zggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,& ldvl, ierr ) loop_30: do jc = 1, n temp = zero @@ -72097,7 +72096,7 @@ module stdlib_linalg_lapack_z end do loop_30 end if if( ilvr ) then - call stdlib_zggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,& + call stdlib${ii}$_zggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,& ldvr, ierr ) loop_60: do jc = 1, n temp = zero @@ -72114,14 +72113,14 @@ module stdlib_linalg_lapack_z end if ! undo scaling if necessary 70 continue - if( ilascl )call stdlib_zlascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) - if( ilbscl )call stdlib_zlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) - work( 1 ) = lwkopt + if( ilascl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr ) + if( ilbscl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_zggev + end subroutine stdlib${ii}$_zggev - subroutine stdlib_zggevx( balanc, jobvl, jobvr, sense, n, a, lda, b, ldb,alpha, beta, vl, & + subroutine stdlib${ii}$_zggevx( balanc, jobvl, jobvr, sense, n, a, lda, b, ldb,alpha, beta, vl, & !! ZGGEVX computes for a pair of N-by-N complex nonsymmetric matrices !! (A,B) the generalized eigenvalues, and optionally, the left and/or !! right generalized eigenvectors. @@ -72149,12 +72148,12 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: balanc, jobvl, jobvr, sense - integer(ilp), intent(out) :: ihi, ilo, info - integer(ilp), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: ihi, ilo, info + integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n real(dp), intent(out) :: abnrm, bbnrm ! Array Arguments logical(lk), intent(out) :: bwork(*) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(out) :: lscale(*), rconde(*), rcondv(*), rscale(*), rwork(*) complex(dp), intent(inout) :: a(lda,*), b(ldb,*) complex(dp), intent(out) :: alpha(*), beta(*), vl(ldvl,*), vr(ldvr,*), work(*) @@ -72165,12 +72164,12 @@ module stdlib_linalg_lapack_z logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery, noscl, wantsb, wantse, wantsn, & wantsv character :: chtemp - integer(ilp) :: i, icols, ierr, ijobvl, ijobvr, in, irows, itau, iwrk, iwrk1, j, jc, & + integer(${ik}$) :: i, icols, ierr, ijobvl, ijobvr, in, irows, itau, iwrk, iwrk1, j, jc, & jr, m, maxwrk, minwrk real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp complex(dp) :: x ! Local Arrays - logical(lk) :: ldumma(1) + logical(lk) :: ldumma(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,aimag,max,sqrt ! Statement Functions @@ -72180,23 +72179,23 @@ module stdlib_linalg_lapack_z ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvl, 'N' ) ) then - ijobvl = 1 + ijobvl = 1_${ik}$ ilvl = .false. else if( stdlib_lsame( jobvl, 'V' ) ) then - ijobvl = 2 + ijobvl = 2_${ik}$ ilvl = .true. else - ijobvl = -1 + ijobvl = -1_${ik}$ ilvl = .false. end if if( stdlib_lsame( jobvr, 'N' ) ) then - ijobvr = 1 + ijobvr = 1_${ik}$ ilvr = .false. else if( stdlib_lsame( jobvr, 'V' ) ) then - ijobvr = 2 + ijobvr = 2_${ik}$ ilvr = .true. else - ijobvr = -1 + ijobvr = -1_${ik}$ ilvr = .false. end if ilv = ilvl .or. ilvr @@ -72206,63 +72205,63 @@ module stdlib_linalg_lapack_z wantsv = stdlib_lsame( sense, 'V' ) wantsb = stdlib_lsame( sense, 'B' ) ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) if( .not.( noscl .or. stdlib_lsame( balanc,'S' ) .or.stdlib_lsame( balanc, 'B' ) ) ) & then - info = -1 - else if( ijobvl<=0 ) then - info = -2 - else if( ijobvr<=0 ) then - info = -3 + info = -1_${ik}$ + else if( ijobvl<=0_${ik}$ ) then + info = -2_${ik}$ + else if( ijobvr<=0_${ik}$ ) then + info = -3_${ik}$ else if( .not.( wantsn .or. wantse .or. wantsb .or. wantsv ) )then - info = -4 - else if( n<0 ) then - info = -5 - else if( ldazero .and. anrmzero .and. bnrm1 ) then - call stdlib_zlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& + call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vl, ldvl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& ldvl ) end if - call stdlib_zungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & + call stdlib${ii}$_zungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if - if( ilvr )call stdlib_zlaset( 'FULL', n, n, czero, cone, vr, ldvr ) + if( ilvr )call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vr, ldvr ) ! reduce to generalized hessenberg form ! (workspace: none needed) if( ilv .or. .not.wantsn ) then ! eigenvectors requested -- work on whole matrix. - call stdlib_zgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib${ii}$_zgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & ierr ) else - call stdlib_zgghrd( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & + call stdlib${ii}$_zgghrd( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & ldb, vl, ldvl, vr, ldvr, ierr ) end if ! perform qz algorithm (compute eigenvalues, and optionally, the @@ -72363,22 +72362,22 @@ module stdlib_linalg_lapack_z else chtemp = 'E' end if - call stdlib_zhgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, & + call stdlib${ii}$_zhgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, & ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 90 end if ! compute eigenvectors and estimate condition numbers if desired - ! stdlib_ztgevc: (complex workspace: need 2*n ) + ! stdlib${ii}$_ztgevc: (complex workspace: need 2*n ) ! (real workspace: need 2*n ) - ! stdlib_ztgsna: (complex workspace: need 2*n*n if sense='v' or 'b') + ! stdlib${ii}$_ztgsna: (complex workspace: need 2*n*n if sense='v' or 'b') ! (integer workspace: need n+2 ) if( ilv .or. .not.wantsn ) then if( ilv ) then @@ -72391,16 +72390,16 @@ module stdlib_linalg_lapack_z else chtemp = 'R' end if - call stdlib_ztgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,& + call stdlib${ii}$_ztgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl,ldvl, vr, ldvr, n,& in, work( iwrk ), rwork,ierr ) - if( ierr/=0 ) then - info = n + 2 + if( ierr/=0_${ik}$ ) then + info = n + 2_${ik}$ go to 90 end if end if if( .not.wantsn ) then - ! compute eigenvectors (stdlib_ztgevc) and estimate condition - ! numbers (stdlib_ztgsna). note that the definition of the condition + ! compute eigenvectors (stdlib${ii}$_ztgevc) and estimate condition + ! numbers (stdlib${ii}$_ztgsna). note that the definition of the condition ! number is not invariant under transformation (u,v) to ! (q*u, z*v), where (u,v) are eigenvectors of the generalized ! schur form (s,t), q and z are orthogonal matrices. in order @@ -72412,18 +72411,18 @@ module stdlib_linalg_lapack_z bwork( j ) = .false. end do bwork( i ) = .true. - iwrk = n + 1 + iwrk = n + 1_${ik}$ iwrk1 = iwrk + n if( wantse .or. wantsb ) then - call stdlib_ztgevc( 'B', 'S', bwork, n, a, lda, b, ldb,work( 1 ), n, work( & - iwrk ), n, 1, m,work( iwrk1 ), rwork, ierr ) - if( ierr/=0 ) then - info = n + 2 + call stdlib${ii}$_ztgevc( 'B', 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( & + iwrk ), n, 1_${ik}$, m,work( iwrk1 ), rwork, ierr ) + if( ierr/=0_${ik}$ ) then + info = n + 2_${ik}$ go to 90 end if end if - call stdlib_ztgsna( sense, 'S', bwork, n, a, lda, b, ldb,work( 1 ), n, work( & - iwrk ), n, rconde( i ),rcondv( i ), 1, m, work( iwrk1 ),lwork-iwrk1+1, iwork, & + call stdlib${ii}$_ztgsna( sense, 'S', bwork, n, a, lda, b, ldb,work( 1_${ik}$ ), n, work( & + iwrk ), n, rconde( i ),rcondv( i ), 1_${ik}$, m, work( iwrk1 ),lwork-iwrk1+1, iwork, & ierr ) end do end if @@ -72431,7 +72430,7 @@ module stdlib_linalg_lapack_z ! undo balancing on vl and vr and normalization ! (workspace: none needed) if( ilvl ) then - call stdlib_zggbak( balanc, 'L', n, ilo, ihi, lscale, rscale, n, vl,ldvl, ierr ) + call stdlib${ii}$_zggbak( balanc, 'L', n, ilo, ihi, lscale, rscale, n, vl,ldvl, ierr ) loop_50: do jc = 1, n temp = zero @@ -72446,7 +72445,7 @@ module stdlib_linalg_lapack_z end do loop_50 end if if( ilvr ) then - call stdlib_zggbak( balanc, 'R', n, ilo, ihi, lscale, rscale, n, vr,ldvr, ierr ) + call stdlib${ii}$_zggbak( balanc, 'R', n, ilo, ihi, lscale, rscale, n, vr,ldvr, ierr ) loop_80: do jc = 1, n temp = zero @@ -72462,14 +72461,14 @@ module stdlib_linalg_lapack_z end if ! undo scaling if necessary 90 continue - if( ilascl )call stdlib_zlascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) - if( ilbscl )call stdlib_zlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) - work( 1 ) = maxwrk + if( ilascl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr ) + if( ilbscl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_zggevx + end subroutine stdlib${ii}$_zggevx - subroutine stdlib_zhbev( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,rwork, info ) + subroutine stdlib${ii}$_zhbev( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,rwork, info ) !! ZHBEV computes all the eigenvalues and, optionally, eigenvectors of !! a complex Hermitian band matrix A. ! -- lapack driver routine -- @@ -72477,8 +72476,8 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kd, ldab, ldz, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kd, ldab, ldz, n ! Array Arguments real(dp), intent(out) :: rwork(*), w(*) complex(dp), intent(inout) :: ab(ldab,*) @@ -72487,7 +72486,7 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: lower, wantz - integer(ilp) :: iinfo, imax, inde, indrwk, iscale + integer(${ik}$) :: iinfo, imax, inde, indrwk, iscale real(dp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! Intrinsic Functions intrinsic :: sqrt @@ -72495,85 +72494,85 @@ module stdlib_linalg_lapack_z ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) lower = stdlib_lsame( uplo, 'L' ) - info = 0 + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) 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( ldabzero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then - call stdlib_zlascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_zlascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) else - call stdlib_zlascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_zlascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) end if end if - ! call stdlib_zhbtrd to reduce hermitian band matrix to tridiagonal form. - inde = 1 - call stdlib_zhbtrd( jobz, uplo, n, kd, ab, ldab, w, rwork( inde ), z,ldz, work, iinfo ) + ! call stdlib${ii}$_zhbtrd to reduce hermitian band matrix to tridiagonal form. + inde = 1_${ik}$ + call stdlib${ii}$_zhbtrd( jobz, uplo, n, kd, ab, ldab, w, rwork( inde ), z,ldz, work, iinfo ) - ! for eigenvalues only, call stdlib_dsterf. for eigenvectors, call stdlib_zsteqr. + ! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvectors, call stdlib${ii}$_zsteqr. if( .not.wantz ) then - call stdlib_dsterf( n, w, rwork( inde ), info ) + call stdlib${ii}$_dsterf( n, w, rwork( inde ), info ) else indrwk = inde + n - call stdlib_zsteqr( jobz, n, w, rwork( inde ), z, ldz,rwork( indrwk ), info ) + call stdlib${ii}$_zsteqr( jobz, n, w, rwork( inde ), z, ldz,rwork( indrwk ), info ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = n else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_dscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ ) end if return - end subroutine stdlib_zhbev + end subroutine stdlib${ii}$_zhbev - subroutine stdlib_zhbevd( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,lwork, rwork, lrwork, & + subroutine stdlib${ii}$_zhbevd( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work,lwork, rwork, lrwork, & !! ZHBEVD computes all the eigenvalues and, optionally, eigenvectors of !! a complex Hermitian band matrix A. If eigenvectors are desired, it !! uses a divide and conquer algorithm. @@ -72589,10 +72588,10 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: kd, ldab, ldz, liwork, lrwork, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: kd, ldab, ldz, liwork, lrwork, lwork, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(out) :: rwork(*), w(*) complex(dp), intent(inout) :: ab(ldab,*) complex(dp), intent(out) :: work(*), z(ldz,*) @@ -72601,7 +72600,7 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: lower, lquery, wantz - integer(ilp) :: iinfo, imax, inde, indwk2, indwrk, iscale, liwmin, llrwk, llwk2, & + integer(${ik}$) :: iinfo, imax, inde, indwk2, indwrk, iscale, liwmin, llrwk, llwk2, & lrwmin, lwmin real(dp) :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! Intrinsic Functions @@ -72610,120 +72609,120 @@ module stdlib_linalg_lapack_z ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) lower = stdlib_lsame( uplo, 'L' ) - lquery = ( lwork==-1 .or. liwork==-1 .or. lrwork==-1 ) - info = 0 - if( n<=1 ) then - lwmin = 1 - lrwmin = 1 - liwmin = 1 + lquery = ( lwork==-1_${ik}$ .or. liwork==-1_${ik}$ .or. lrwork==-1_${ik}$ ) + info = 0_${ik}$ + if( n<=1_${ik}$ ) then + lwmin = 1_${ik}$ + lrwmin = 1_${ik}$ + liwmin = 1_${ik}$ else if( wantz ) then - lwmin = 2*n**2 - lrwmin = 1 + 5*n + 2*n**2 - liwmin = 3 + 5*n + lwmin = 2_${ik}$*n**2_${ik}$ + lrwmin = 1_${ik}$ + 5_${ik}$*n + 2_${ik}$*n**2_${ik}$ + liwmin = 3_${ik}$ + 5_${ik}$*n else lwmin = n lrwmin = n - liwmin = 1 + liwmin = 1_${ik}$ end if end if if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) 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( ldabzero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then - call stdlib_zlascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_zlascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) else - call stdlib_zlascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_zlascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) end if end if - ! call stdlib_zhbtrd to reduce hermitian band matrix to tridiagonal form. - inde = 1 + ! call stdlib${ii}$_zhbtrd to reduce hermitian band matrix to tridiagonal form. + inde = 1_${ik}$ indwrk = inde + n - indwk2 = 1 + n*n - llwk2 = lwork - indwk2 + 1 - llrwk = lrwork - indwrk + 1 - call stdlib_zhbtrd( jobz, uplo, n, kd, ab, ldab, w, rwork( inde ), z,ldz, work, iinfo ) + indwk2 = 1_${ik}$ + n*n + llwk2 = lwork - indwk2 + 1_${ik}$ + llrwk = lrwork - indwrk + 1_${ik}$ + call stdlib${ii}$_zhbtrd( jobz, uplo, n, kd, ab, ldab, w, rwork( inde ), z,ldz, work, iinfo ) - ! for eigenvalues only, call stdlib_dsterf. for eigenvectors, call stdlib_zstedc. + ! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvectors, call stdlib${ii}$_zstedc. if( .not.wantz ) then - call stdlib_dsterf( n, w, rwork( inde ), info ) + call stdlib${ii}$_dsterf( n, w, rwork( inde ), info ) else - call stdlib_zstedc( 'I', n, w, rwork( inde ), work, n, work( indwk2 ),llwk2, rwork( & + call stdlib${ii}$_zstedc( 'I', n, w, rwork( inde ), work, n, work( indwk2 ),llwk2, rwork( & indwrk ), llrwk, iwork, liwork,info ) - call stdlib_zgemm( 'N', 'N', n, n, n, cone, z, ldz, work, n, czero,work( indwk2 ), & + call stdlib${ii}$_zgemm( 'N', 'N', n, n, n, cone, z, ldz, work, n, czero,work( indwk2 ), & n ) - call stdlib_zlacpy( 'A', n, n, work( indwk2 ), n, z, ldz ) + call stdlib${ii}$_zlacpy( 'A', n, n, work( indwk2 ), n, z, ldz ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = n else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_dscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ ) end if - work( 1 ) = lwmin - rwork( 1 ) = lrwmin - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = lwmin + rwork( 1_${ik}$ ) = lrwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_zhbevd + end subroutine stdlib${ii}$_zhbevd - subroutine stdlib_zhbevx( jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl,vu, il, iu, abstol, & + subroutine stdlib${ii}$_zhbevx( jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl,vu, il, iu, abstol, & !! ZHBEVX computes selected eigenvalues and, optionally, eigenvectors !! of a complex Hermitian band matrix A. Eigenvalues and eigenvectors !! can be selected by specifying either a range of values or a range of @@ -72734,11 +72733,11 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, range, uplo - integer(ilp), intent(in) :: il, iu, kd, ldab, ldq, ldz, n - integer(ilp), intent(out) :: info, m + integer(${ik}$), intent(in) :: il, iu, kd, ldab, ldq, ldz, n + integer(${ik}$), intent(out) :: info, m real(dp), intent(in) :: abstol, vl, vu ! Array Arguments - integer(ilp), intent(out) :: ifail(*), iwork(*) + integer(${ik}$), intent(out) :: ifail(*), iwork(*) real(dp), intent(out) :: rwork(*), w(*) complex(dp), intent(inout) :: ab(ldab,*) complex(dp), intent(out) :: q(ldq,*), work(*), z(ldz,*) @@ -72748,7 +72747,7 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: alleig, indeig, lower, test, valeig, wantz character :: order - integer(ilp) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwk, indrwk, & + integer(${ik}$) :: i, iinfo, imax, indd, inde, indee, indibl, indisp, indiwk, indrwk, & indwrk, iscale, itmp1, j, jj, nsplit real(dp) :: abstll, anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, vll, & vuu @@ -72762,68 +72761,68 @@ module stdlib_linalg_lapack_z valeig = stdlib_lsame( range, 'V' ) indeig = stdlib_lsame( range, 'I' ) lower = stdlib_lsame( uplo, 'L' ) - info = 0 + info = 0_${ik}$ if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( alleig .or. valeig .or. indeig ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( lower .or. stdlib_lsame( uplo, 'U' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( kd<0 ) then - info = -5 + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( kd<0_${ik}$ ) then + info = -5_${ik}$ else if( ldab0 .and. vu<=vl )info = -11 + if( n>0_${ik}$ .and. vu<=vl )info = -11_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -12 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -12_${ik}$ else if( iun ) then - info = -13 + info = -13_${ik}$ end if end if end if - if( info==0 ) then - if( ldz<1 .or. ( wantz .and. ldz=tmp1 ) )m = 0 + if( .not.( vl=tmp1 ) )m = 0_${ik}$ end if - if( m==1 ) then - w( 1 ) = real( ctmp1,KIND=dp) - if( wantz )z( 1, 1 ) = cone + if( m==1_${ik}$ ) then + w( 1_${ik}$ ) = real( ctmp1,KIND=dp) + if( wantz )z( 1_${ik}$, 1_${ik}$ ) = cone end if return end if ! get machine constants. - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) - eps = stdlib_dlamch( 'PRECISION' ) + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) + eps = stdlib${ii}$_dlamch( 'PRECISION' ) smlnum = safmin / eps bignum = one / smlnum rmin = sqrt( smlnum ) rmax = min( sqrt( bignum ), one / sqrt( sqrt( safmin ) ) ) ! scale matrix to allowable range, if necessary. - iscale = 0 + iscale = 0_${ik}$ abstll = abstol if( valeig ) then vll = vl @@ -72832,102 +72831,102 @@ module stdlib_linalg_lapack_z vll = zero vuu = zero end if - anrm = stdlib_zlanhb( 'M', uplo, n, kd, ab, ldab, rwork ) + anrm = stdlib${ii}$_zlanhb( 'M', uplo, n, kd, ab, ldab, rwork ) if( anrm>zero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then + if( iscale==1_${ik}$ ) then if( lower ) then - call stdlib_zlascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_zlascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) else - call stdlib_zlascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) + call stdlib${ii}$_zlascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) end if - if( abstol>0 )abstll = abstol*sigma + if( abstol>0_${ik}$ )abstll = abstol*sigma if( valeig ) then vll = vl*sigma vuu = vu*sigma end if end if - ! call stdlib_zhbtrd to reduce hermitian band matrix to tridiagonal form. - indd = 1 + ! call stdlib${ii}$_zhbtrd to reduce hermitian band matrix to tridiagonal form. + indd = 1_${ik}$ inde = indd + n indrwk = inde + n - indwrk = 1 - call stdlib_zhbtrd( jobz, uplo, n, kd, ab, ldab, rwork( indd ),rwork( inde ), q, ldq, & + indwrk = 1_${ik}$ + call stdlib${ii}$_zhbtrd( jobz, uplo, n, kd, ab, ldab, rwork( indd ),rwork( inde ), q, ldq, & work( indwrk ), iinfo ) ! if all eigenvalues are desired and abstol is less than or equal - ! to zero, then call stdlib_dsterf or stdlib_zsteqr. if this fails for some - ! eigenvalue, then try stdlib_dstebz. + ! to zero, then call stdlib${ii}$_dsterf or stdlib${ii}$_zsteqr. if this fails for some + ! eigenvalue, then try stdlib${ii}$_dstebz. test = .false. if (indeig) then - if (il==1 .and. iu==n) then + if (il==1_${ik}$ .and. iu==n) then test = .true. end if end if if ((alleig .or. test) .and. (abstol<=zero)) then - call stdlib_dcopy( n, rwork( indd ), 1, w, 1 ) - indee = indrwk + 2*n + call stdlib${ii}$_dcopy( n, rwork( indd ), 1_${ik}$, w, 1_${ik}$ ) + indee = indrwk + 2_${ik}$*n if( .not.wantz ) then - call stdlib_dcopy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) - call stdlib_dsterf( n, w, rwork( indee ), info ) + call stdlib${ii}$_dcopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ ) + call stdlib${ii}$_dsterf( n, w, rwork( indee ), info ) else - call stdlib_zlacpy( 'A', n, n, q, ldq, z, ldz ) - call stdlib_dcopy( n-1, rwork( inde ), 1, rwork( indee ), 1 ) - call stdlib_zsteqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) + call stdlib${ii}$_zlacpy( 'A', n, n, q, ldq, z, ldz ) + call stdlib${ii}$_dcopy( n-1, rwork( inde ), 1_${ik}$, rwork( indee ), 1_${ik}$ ) + call stdlib${ii}$_zsteqr( jobz, n, w, rwork( indee ), z, ldz,rwork( indrwk ), info ) - if( info==0 ) then + if( info==0_${ik}$ ) then do i = 1, n - ifail( i ) = 0 + ifail( i ) = 0_${ik}$ end do end if end if - if( info==0 ) then + if( info==0_${ik}$ ) then m = n go to 30 end if - info = 0 + info = 0_${ik}$ end if - ! otherwise, call stdlib_dstebz and, if eigenvectors are desired, stdlib_zstein. + ! otherwise, call stdlib${ii}$_dstebz and, if eigenvectors are desired, stdlib${ii}$_zstein. if( wantz ) then order = 'B' else order = 'E' end if - indibl = 1 + indibl = 1_${ik}$ indisp = indibl + n indiwk = indisp + n - call stdlib_dstebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indd ), rwork( & + call stdlib${ii}$_dstebz( range, order, n, vll, vuu, il, iu, abstll,rwork( indd ), rwork( & inde ), m, nsplit, w,iwork( indibl ), iwork( indisp ), rwork( indrwk ),iwork( indiwk ),& info ) if( wantz ) then - call stdlib_zstein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & + call stdlib${ii}$_zstein( n, rwork( indd ), rwork( inde ), m, w,iwork( indibl ), iwork( & indisp ), z, ldz,rwork( indrwk ), iwork( indiwk ), ifail, info ) ! apply unitary matrix used in reduction to tridiagonal - ! form to eigenvectors returned by stdlib_zstein. + ! form to eigenvectors returned by stdlib${ii}$_zstein. do j = 1, m - call stdlib_zcopy( n, z( 1, j ), 1, work( 1 ), 1 ) - call stdlib_zgemv( 'N', n, n, cone, q, ldq, work, 1, czero,z( 1, j ), 1 ) + call stdlib${ii}$_zcopy( n, z( 1_${ik}$, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) + call stdlib${ii}$_zgemv( 'N', n, n, cone, q, ldq, work, 1_${ik}$, czero,z( 1_${ik}$, j ), 1_${ik}$ ) end do end if ! if matrix was scaled, then rescale eigenvalues appropriately. 30 continue - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = m else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_dscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ ) end if ! if eigenvalues are not in order, then sort them, along with ! eigenvectors. if( wantz ) then do j = 1, m - 1 - i = 0 + i = 0_${ik}$ tmp1 = w( j ) do jj = j + 1, m if( w( jj )ka ) 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( ldabka ) 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( ldabka ) then - info = -6 + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( ka<0_${ik}$ ) then + info = -5_${ik}$ + else if( kb<0_${ik}$ .or. kb>ka ) then + info = -6_${ik}$ else if( ldab0 .and. vu<=vl )info = -14 + if( n>0_${ik}$ .and. vu<=vl )info = -14_${ik}$ else if( indeig ) then - if( il<1 .or. il>max( 1, n ) ) then - info = -15 + if( il<1_${ik}$ .or. il>max( 1_${ik}$, n ) ) then + info = -15_${ik}$ else if ( iun ) then - info = -16 + info = -16_${ik}$ end if end if end if - if( info==0) then - if( ldz<1 .or. ( wantz .and. ldzzero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 )call stdlib_zlascl( uplo, 0, 0, one, sigma, n, n, a, lda, info ) - ! call stdlib_zhetrd to reduce hermitian matrix to tridiagonal form. - inde = 1 - indtau = 1 + if( iscale==1_${ik}$ )call stdlib${ii}$_zlascl( uplo, 0_${ik}$, 0_${ik}$, one, sigma, n, n, a, lda, info ) + ! call stdlib${ii}$_zhetrd to reduce hermitian matrix to tridiagonal form. + inde = 1_${ik}$ + indtau = 1_${ik}$ indwrk = indtau + n indrwk = inde + n indwk2 = indwrk + n*n - llwork = lwork - indwrk + 1 - llwrk2 = lwork - indwk2 + 1 - llrwk = lrwork - indrwk + 1 - call stdlib_zhetrd( uplo, n, a, lda, w, rwork( inde ), work( indtau ),work( indwrk ), & + llwork = lwork - indwrk + 1_${ik}$ + llwrk2 = lwork - indwk2 + 1_${ik}$ + llrwk = lrwork - indrwk + 1_${ik}$ + call stdlib${ii}$_zhetrd( uplo, n, a, lda, w, rwork( inde ), work( indtau ),work( indwrk ), & llwork, iinfo ) - ! for eigenvalues only, call stdlib_dsterf. for eigenvectors, first call - ! stdlib_zstedc to generate the eigenvector matrix, work(indwrk), of the - ! tridiagonal matrix, then call stdlib_zunmtr to multiply it to the + ! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvectors, first call + ! stdlib${ii}$_zstedc to generate the eigenvector matrix, work(indwrk), of the + ! tridiagonal matrix, then call stdlib${ii}$_zunmtr to multiply it to the ! householder transformations represented as householder vectors in ! a. if( .not.wantz ) then - call stdlib_dsterf( n, w, rwork( inde ), info ) + call stdlib${ii}$_dsterf( n, w, rwork( inde ), info ) else - call stdlib_zstedc( 'I', n, w, rwork( inde ), work( indwrk ), n,work( indwk2 ), & + call stdlib${ii}$_zstedc( 'I', n, w, rwork( inde ), work( indwrk ), n,work( indwk2 ), & llwrk2, rwork( indrwk ), llrwk,iwork, liwork, info ) - call stdlib_zunmtr( 'L', uplo, 'N', n, n, a, lda, work( indtau ),work( indwrk ), n, & + call stdlib${ii}$_zunmtr( 'L', uplo, 'N', n, n, a, lda, work( indtau ),work( indwrk ), n, & work( indwk2 ), llwrk2, iinfo ) - call stdlib_zlacpy( 'A', n, n, work( indwrk ), n, a, lda ) + call stdlib${ii}$_zlacpy( 'A', n, n, work( indwrk ), n, a, lda ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = n else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_dscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ ) end if - work( 1 ) = lopt - rwork( 1 ) = lropt - iwork( 1 ) = liopt + work( 1_${ik}$ ) = lopt + rwork( 1_${ik}$ ) = lropt + iwork( 1_${ik}$ ) = liopt return - end subroutine stdlib_zheevd + end subroutine stdlib${ii}$_zheevd - subroutine stdlib_zhegvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, rwork, lrwork,& + subroutine stdlib${ii}$_zhegvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work,lwork, rwork, lrwork,& !! ZHEGVD computes all the eigenvalues, and optionally, the eigenvectors !! of a complex generalized Hermitian-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and @@ -73521,10 +73520,10 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: itype, lda, ldb, liwork, lrwork, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: itype, lda, ldb, liwork, lrwork, lwork, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(out) :: rwork(*), w(*) complex(dp), intent(inout) :: a(lda,*), b(ldb,*) complex(dp), intent(out) :: work(*) @@ -73533,58 +73532,58 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: lquery, upper, wantz character :: trans - integer(ilp) :: liopt, liwmin, lopt, lropt, lrwmin, lwmin + integer(${ik}$) :: liopt, liwmin, lopt, lropt, lrwmin, lwmin ! Intrinsic Functions intrinsic :: real,max ! Executable Statements ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) upper = stdlib_lsame( uplo, 'U' ) - lquery = ( lwork==-1 .or. lrwork==-1 .or. liwork==-1 ) - info = 0 - if( n<=1 ) then - lwmin = 1 - lrwmin = 1 - liwmin = 1 + lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) + info = 0_${ik}$ + if( n<=1_${ik}$ ) then + lwmin = 1_${ik}$ + lrwmin = 1_${ik}$ + liwmin = 1_${ik}$ else if( wantz ) then - lwmin = 2*n + n*n - lrwmin = 1 + 5*n + 2*n*n - liwmin = 3 + 5*n + lwmin = 2_${ik}$*n + n*n + lrwmin = 1_${ik}$ + 5_${ik}$*n + 2_${ik}$*n*n + liwmin = 3_${ik}$ + 5_${ik}$*n else - lwmin = n + 1 + lwmin = n + 1_${ik}$ lrwmin = n - liwmin = 1 + liwmin = 1_${ik}$ end if lopt = lwmin lropt = lrwmin liopt = liwmin - if( itype<1 .or. itype>3 ) then - info = -1 + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( ldazero .and. anrmrmax ) then - iscale = 1 + iscale = 1_${ik}$ sigma = rmax / anrm end if - if( iscale==1 ) then - call stdlib_zdscal( ( n*( n+1 ) ) / 2, sigma, ap, 1 ) + if( iscale==1_${ik}$ ) then + call stdlib${ii}$_zdscal( ( n*( n+1 ) ) / 2_${ik}$, sigma, ap, 1_${ik}$ ) end if - ! call stdlib_zhptrd to reduce hermitian packed matrix to tridiagonal form. - inde = 1 - indtau = 1 + ! call stdlib${ii}$_zhptrd to reduce hermitian packed matrix to tridiagonal form. + inde = 1_${ik}$ + indtau = 1_${ik}$ indrwk = inde + n indwrk = indtau + n - llwrk = lwork - indwrk + 1 - llrwk = lrwork - indrwk + 1 - call stdlib_zhptrd( uplo, n, ap, w, rwork( inde ), work( indtau ),iinfo ) - ! for eigenvalues only, call stdlib_dsterf. for eigenvectors, first call - ! stdlib_zupgtr to generate the orthogonal matrix, then call stdlib_zstedc. + llwrk = lwork - indwrk + 1_${ik}$ + llrwk = lrwork - indrwk + 1_${ik}$ + call stdlib${ii}$_zhptrd( uplo, n, ap, w, rwork( inde ), work( indtau ),iinfo ) + ! for eigenvalues only, call stdlib${ii}$_dsterf. for eigenvectors, first call + ! stdlib${ii}$_zupgtr to generate the orthogonal matrix, then call stdlib${ii}$_zstedc. if( .not.wantz ) then - call stdlib_dsterf( n, w, rwork( inde ), info ) + call stdlib${ii}$_dsterf( n, w, rwork( inde ), info ) else - call stdlib_zstedc( 'I', n, w, rwork( inde ), z, ldz, work( indwrk ),llwrk, rwork( & + call stdlib${ii}$_zstedc( 'I', n, w, rwork( inde ), z, ldz, work( indwrk ),llwrk, rwork( & indrwk ), llrwk, iwork, liwork,info ) - call stdlib_zupmtr( 'L', uplo, 'N', n, n, ap, work( indtau ), z, ldz,work( indwrk ),& + call stdlib${ii}$_zupmtr( 'L', uplo, 'N', n, n, ap, work( indtau ), z, ldz,work( indwrk ),& iinfo ) end if ! if matrix was scaled, then rescale eigenvalues appropriately. - if( iscale==1 ) then - if( info==0 ) then + if( iscale==1_${ik}$ ) then + if( info==0_${ik}$ ) then imax = n else - imax = info - 1 + imax = info - 1_${ik}$ end if - call stdlib_dscal( imax, one / sigma, w, 1 ) + call stdlib${ii}$_dscal( imax, one / sigma, w, 1_${ik}$ ) end if - work( 1 ) = lwmin - rwork( 1 ) = lrwmin - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = lwmin + rwork( 1_${ik}$ ) = lrwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_zhpevd + end subroutine stdlib${ii}$_zhpevd - subroutine stdlib_zhpgvd( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,lwork, rwork, lrwork,& + subroutine stdlib${ii}$_zhpgvd( itype, jobz, uplo, n, ap, bp, w, z, ldz, work,lwork, rwork, lrwork,& !! ZHPGVD computes all the eigenvalues and, optionally, the eigenvectors !! of a complex generalized Hermitian-definite eigenproblem, of the form !! A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and @@ -73796,10 +73795,10 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobz, uplo - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: itype, ldz, liwork, lrwork, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: itype, ldz, liwork, lrwork, lwork, n ! Array Arguments - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) real(dp), intent(out) :: rwork(*), w(*) complex(dp), intent(inout) :: ap(*), bp(*) complex(dp), intent(out) :: work(*), z(ldz,*) @@ -73807,55 +73806,55 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: lquery, upper, wantz character :: trans - integer(ilp) :: j, liwmin, lrwmin, lwmin, neig + integer(${ik}$) :: j, liwmin, lrwmin, lwmin, neig ! Intrinsic Functions intrinsic :: real,max ! Executable Statements ! test the input parameters. wantz = stdlib_lsame( jobz, 'V' ) upper = stdlib_lsame( uplo, 'U' ) - lquery = ( lwork==-1 .or. lrwork==-1 .or. liwork==-1 ) - info = 0 - if( itype<1 .or. itype>3 ) then - info = -1 + lquery = ( lwork==-1_${ik}$ .or. lrwork==-1_${ik}$ .or. liwork==-1_${ik}$ ) + info = 0_${ik}$ + if( itype<1_${ik}$ .or. itype>3_${ik}$ ) then + info = -1_${ik}$ else if( .not.( wantz .or. stdlib_lsame( jobz, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( upper .or. stdlib_lsame( uplo, 'L' ) ) ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( ldz<1 .or. ( wantz .and. ldz0 )neig = info - 1 - if( itype==1 .or. itype==2 ) then + if( info>0_${ik}$ )neig = info - 1_${ik}$ + if( itype==1_${ik}$ .or. itype==2_${ik}$ ) then ! for a*x=(lambda)*b*x and a*b*x=(lambda)*x; ! backtransform eigenvectors: x = inv(l)**h *y or inv(u)*y if( upper ) then @@ -73888,9 +73887,9 @@ module stdlib_linalg_lapack_z trans = 'C' end if do j = 1, neig - call stdlib_ztpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_ztpsv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do - else if( itype==3 ) then + else if( itype==3_${ik}$ ) then ! for b*a*x=(lambda)*x; ! backtransform eigenvectors: x = l*y or u**h *y if( upper ) then @@ -73899,18 +73898,18 @@ module stdlib_linalg_lapack_z trans = 'N' end if do j = 1, neig - call stdlib_ztpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1, j ),1 ) + call stdlib${ii}$_ztpmv( uplo, trans, 'NON-UNIT', n, bp, z( 1_${ik}$, j ),1_${ik}$ ) end do end if end if - work( 1 ) = lwmin - rwork( 1 ) = lrwmin - iwork( 1 ) = liwmin + work( 1_${ik}$ ) = lwmin + rwork( 1_${ik}$ ) = lrwmin + iwork( 1_${ik}$ ) = liwmin return - end subroutine stdlib_zhpgvd + end subroutine stdlib${ii}$_zhpgvd - subroutine stdlib_zgees( jobvs, sort, select, n, a, lda, sdim, w, vs,ldvs, work, lwork, & + subroutine stdlib${ii}$_zgees( jobvs, sort, select, n, a, lda, sdim, w, vs,ldvs, work, lwork, & !! ZGEES computes for an N-by-N complex nonsymmetric matrix A, the !! eigenvalues, the Schur form T, and, optionally, the matrix of Schur !! vectors Z. This gives the Schur factorization A = Z*T*(Z**H). @@ -73925,8 +73924,8 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvs, sort - integer(ilp), intent(out) :: info, sdim - integer(ilp), intent(in) :: lda, ldvs, lwork, n + integer(${ik}$), intent(out) :: info, sdim + integer(${ik}$), intent(in) :: lda, ldvs, lwork, n ! Array Arguments logical(lk), intent(out) :: bwork(*) real(dp), intent(out) :: rwork(*) @@ -73938,29 +73937,29 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: lquery, scalea, wantst, wantvs - integer(ilp) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, maxwrk, & + integer(${ik}$) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, maxwrk, & minwrk real(dp) :: anrm, bignum, cscale, eps, s, sep, smlnum ! Local Arrays - real(dp) :: dum(1) + real(dp) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) wantvs = stdlib_lsame( jobvs, 'V' ) wantst = stdlib_lsame( sort, 'S' ) if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then - info = -2 - else if( n<0 ) then - info = -4 - else if( ldazero .and. anrm0 )info = ieval + if( ieval>0_${ik}$ )info = ieval ! sort eigenvalues if desired - if( wantst .and. info==0 ) then - if( scalea )call stdlib_zlascl( 'G', 0, 0, cscale, anrm, n, 1, w, n, ierr ) + if( wantst .and. info==0_${ik}$ ) then + if( scalea )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, w, n, ierr ) do i = 1, n bwork( i ) = select( w( i ) ) end do ! reorder eigenvalues and transform schur vectors ! (cworkspace: none) ! (rworkspace: none) - call stdlib_ztrsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,s, sep, work( & + call stdlib${ii}$_ztrsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,s, sep, work( & iwrk ), lwork-iwrk+1, icond ) end if if( wantvs ) then ! undo balancing ! (cworkspace: none) ! (rworkspace: need n) - call stdlib_zgebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr ) + call stdlib${ii}$_zgebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr ) end if if( scalea ) then ! undo scaling for the schur form of a - call stdlib_zlascl( 'U', 0, 0, cscale, anrm, n, n, a, lda, ierr ) - call stdlib_zcopy( n, a, lda+1, w, 1 ) + call stdlib${ii}$_zlascl( 'U', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_zcopy( n, a, lda+1, w, 1_${ik}$ ) end if - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_zgees + end subroutine stdlib${ii}$_zgees - subroutine stdlib_zgeesx( jobvs, sort, select, sense, n, a, lda, sdim, w,vs, ldvs, rconde, & + subroutine stdlib${ii}$_zgeesx( jobvs, sort, select, sense, n, a, lda, sdim, w,vs, ldvs, rconde, & !! ZGEESX computes for an N-by-N complex nonsymmetric matrix A, the !! eigenvalues, the Schur form T, and, optionally, the matrix of Schur !! vectors Z. This gives the Schur factorization A = Z*T*(Z**H). @@ -74102,8 +74101,8 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvs, sense, sort - integer(ilp), intent(out) :: info, sdim - integer(ilp), intent(in) :: lda, ldvs, lwork, n + integer(${ik}$), intent(out) :: info, sdim + integer(${ik}$), intent(in) :: lda, ldvs, lwork, n real(dp), intent(out) :: rconde, rcondv ! Array Arguments logical(lk), intent(out) :: bwork(*) @@ -74116,36 +74115,36 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: lquery, scalea, wantsb, wantse, wantsn, wantst, wantsv, wantvs - integer(ilp) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, lwrk, & + integer(${ik}$) :: hswork, i, ibal, icond, ierr, ieval, ihi, ilo, itau, iwrk, lwrk, & maxwrk, minwrk real(dp) :: anrm, bignum, cscale, eps, smlnum ! Local Arrays - real(dp) :: dum(1) + real(dp) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: max,sqrt ! Executable Statements ! test the input arguments - info = 0 + info = 0_${ik}$ wantvs = stdlib_lsame( jobvs, 'V' ) wantst = stdlib_lsame( sort, 'S' ) wantsn = stdlib_lsame( sense, 'N' ) wantse = stdlib_lsame( sense, 'E' ) wantsv = stdlib_lsame( sense, 'V' ) wantsb = stdlib_lsame( sense, 'B' ) - lquery = ( lwork==-1 ) + lquery = ( lwork==-1_${ik}$ ) if( ( .not.wantvs ) .and. ( .not.stdlib_lsame( jobvs, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( ( .not.wantst ) .and. ( .not.stdlib_lsame( sort, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( wantsn .or. wantse .or. wantsv .or. wantsb ) .or.( .not.wantst .and. & .not.wantsn ) ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( ldazero .and. anrm0 )info = ieval + if( ieval>0_${ik}$ )info = ieval ! sort eigenvalues if desired - if( wantst .and. info==0 ) then - if( scalea )call stdlib_zlascl( 'G', 0, 0, cscale, anrm, n, 1, w, n, ierr ) + if( wantst .and. info==0_${ik}$ ) then + if( scalea )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, n, 1_${ik}$, w, n, ierr ) do i = 1, n bwork( i ) = select( w( i ) ) end do @@ -74254,36 +74253,36 @@ module stdlib_linalg_lapack_z ! (cworkspace: if sense is not 'n', need 2*sdim*(n-sdim) ! otherwise, need none ) ! (rworkspace: none) - call stdlib_ztrsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,rconde, & + call stdlib${ii}$_ztrsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, w, sdim,rconde, & rcondv, work( iwrk ), lwork-iwrk+1,icond ) - if( .not.wantsn )maxwrk = max( maxwrk, 2*sdim*( n-sdim ) ) - if( icond==-14 ) then + if( .not.wantsn )maxwrk = max( maxwrk, 2_${ik}$*sdim*( n-sdim ) ) + if( icond==-14_${ik}$ ) then ! not enough complex workspace - info = -15 + info = -15_${ik}$ end if end if if( wantvs ) then ! undo balancing ! (cworkspace: none) ! (rworkspace: need n) - call stdlib_zgebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr ) + call stdlib${ii}$_zgebak( 'P', 'R', n, ilo, ihi, rwork( ibal ), n, vs, ldvs,ierr ) end if if( scalea ) then ! undo scaling for the schur form of a - call stdlib_zlascl( 'U', 0, 0, cscale, anrm, n, n, a, lda, ierr ) - call stdlib_zcopy( n, a, lda+1, w, 1 ) - if( ( wantsv .or. wantsb ) .and. info==0 ) then - dum( 1 ) = rcondv - call stdlib_dlascl( 'G', 0, 0, cscale, anrm, 1, 1, dum, 1, ierr ) - rcondv = dum( 1 ) + call stdlib${ii}$_zlascl( 'U', 0_${ik}$, 0_${ik}$, cscale, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_zcopy( n, a, lda+1, w, 1_${ik}$ ) + if( ( wantsv .or. wantsb ) .and. info==0_${ik}$ ) then + dum( 1_${ik}$ ) = rcondv + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, 1_${ik}$, 1_${ik}$, dum, 1_${ik}$, ierr ) + rcondv = dum( 1_${ik}$ ) end if end if - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_zgeesx + end subroutine stdlib${ii}$_zgeesx - subroutine stdlib_zgeev( jobvl, jobvr, n, a, lda, w, vl, ldvl, vr, ldvr,work, lwork, rwork, & + subroutine stdlib${ii}$_zgeev( jobvl, jobvr, n, a, lda, w, vl, ldvl, vr, ldvr,work, lwork, rwork, & !! ZGEEV computes for an N-by-N complex nonsymmetric matrix A, the !! eigenvalues and, optionally, the left and/or right eigenvectors. !! The right eigenvector v(j) of A satisfies @@ -74300,8 +74299,8 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvl, jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n ! Array Arguments real(dp), intent(out) :: rwork(*) complex(dp), intent(inout) :: a(lda,*) @@ -74311,33 +74310,33 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: lquery, scalea, wantvl, wantvr character :: side - integer(ilp) :: hswork, i, ibal, ierr, ihi, ilo, irwork, itau, iwrk, k, lwork_trevc, & + integer(${ik}$) :: hswork, i, ibal, ierr, ihi, ilo, irwork, itau, iwrk, k, lwork_trevc, & maxwrk, minwrk, nout real(dp) :: anrm, bignum, cscale, eps, scl, smlnum complex(dp) :: tmp ! Local Arrays - logical(lk) :: select(1) - real(dp) :: dum(1) + logical(lk) :: select(1_${ik}$) + real(dp) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: real,cmplx,conjg,aimag,max,sqrt ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) wantvl = stdlib_lsame( jobvl, 'V' ) wantvr = stdlib_lsame( jobvr, 'V' ) if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then - info = -1 + info = -1_${ik}$ else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldazero .and. anrm0 ) then - call stdlib_zlascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, w, n, ierr ) + if( info>0_${ik}$ ) then + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, cscale, anrm, ilo-1, 1_${ik}$, w, n, ierr ) end if end if - work( 1 ) = maxwrk + work( 1_${ik}$ ) = maxwrk return - end subroutine stdlib_zgeev + end subroutine stdlib${ii}$_zgeev - subroutine stdlib_zgeevx( balanc, jobvl, jobvr, sense, n, a, lda, w, vl,ldvl, vr, ldvr, ilo, & + subroutine stdlib${ii}$_zgeevx( balanc, jobvl, jobvr, sense, n, a, lda, w, vl,ldvl, vr, ldvr, ilo, & !! ZGEEVX computes for an N-by-N complex nonsymmetric matrix A, the !! eigenvalues and, optionally, the left and/or right eigenvectors. !! Optionally also, it computes a balancing transformation to improve @@ -74564,8 +74563,8 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: balanc, jobvl, jobvr, sense - integer(ilp), intent(out) :: ihi, ilo, info - integer(ilp), intent(in) :: lda, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: ihi, ilo, info + integer(${ik}$), intent(in) :: lda, ldvl, ldvr, lwork, n real(dp), intent(out) :: abnrm ! Array Arguments real(dp), intent(out) :: rconde(*), rcondv(*), rwork(*), scale(*) @@ -74576,19 +74575,19 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: lquery, scalea, wantvl, wantvr, wntsnb, wntsne, wntsnn, wntsnv character :: job, side - integer(ilp) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, & + integer(${ik}$) :: hswork, i, icond, ierr, itau, iwrk, k, lwork_trevc, maxwrk, minwrk, & nout real(dp) :: anrm, bignum, cscale, eps, scl, smlnum complex(dp) :: tmp ! Local Arrays - logical(lk) :: select(1) - real(dp) :: dum(1) + logical(lk) :: select(1_${ik}$) + real(dp) :: dum(1_${ik}$) ! Intrinsic Functions intrinsic :: real,cmplx,conjg,aimag,max,sqrt ! Executable Statements ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) wantvl = stdlib_lsame( jobvl, 'V' ) wantvr = stdlib_lsame( jobvr, 'V' ) wntsnn = stdlib_lsame( sense, 'N' ) @@ -74597,22 +74596,22 @@ module stdlib_linalg_lapack_z wntsnb = stdlib_lsame( sense, 'B' ) if( .not.( stdlib_lsame( balanc, 'N' ) .or. stdlib_lsame( balanc, 'S' ) & .or.stdlib_lsame( balanc, 'P' ) .or. stdlib_lsame( balanc, 'B' ) ) ) then - info = -1 + info = -1_${ik}$ else if( ( .not.wantvl ) .and. ( .not.stdlib_lsame( jobvl, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( ( .not.wantvr ) .and. ( .not.stdlib_lsame( jobvr, 'N' ) ) ) then - info = -3 + info = -3_${ik}$ else if( .not.( wntsnn .or. wntsne .or. wntsnb .or. wntsnv ) .or.( ( wntsne .or. & wntsnb ) .and. .not.( wantvl .and.wantvr ) ) ) then - info = -4 - else if( n<0 ) then - info = -5 - else if( ldazero .and. anrm= N. The SVD of [A] is written as !! [A] = [U] * [SIGMA] * [V]^*, @@ -74850,13 +74849,13 @@ module stdlib_linalg_lapack_z ! -- 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, ldu, ldv, lwork, lrwork, m, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldu, ldv, lwork, lrwork, m, n ! Array Arguments complex(dp), intent(inout) :: a(lda,*) complex(dp), intent(out) :: u(ldu,*), v(ldv,*), cwork(lwork) real(dp), intent(out) :: sva(n), rwork(lrwork) - integer(ilp), intent(out) :: iwork(*) + integer(${ik}$), intent(out) :: iwork(*) character, intent(in) :: joba, jobp, jobr, jobt, jobu, jobv ! =========================================================================== @@ -74865,17 +74864,17 @@ module stdlib_linalg_lapack_z complex(dp) :: ctemp real(dp) :: aapp, aaqq, aatmax, aatmin, big, big1, cond_ok, condr1, condr2, entra, & entrat, epsln, maxprj, scalem, sconda, sfmin, small, temp1, uscal1, uscal2, xsc - integer(ilp) :: ierr, n1, nr, numrank, p, q, warning + integer(${ik}$) :: ierr, n1, nr, numrank, p, q, warning logical(lk) :: almort, defr, errest, goscal, jracc, kill, lquery, lsvec, l2aber, & l2kill, l2pert, l2rank, l2tran, noscal, rowpiv, rsvec, transp - integer(ilp) :: optwrk, minwrk, minrwrk, miniwrk - integer(ilp) :: lwcon, lwlqf, lwqp3, lwqrf, lwunmlq, lwunmqr, lwunmqrm, lwsvdj, & + integer(${ik}$) :: optwrk, minwrk, minrwrk, miniwrk + integer(${ik}$) :: lwcon, lwlqf, lwqp3, lwqrf, lwunmlq, lwunmqr, lwunmqrm, lwsvdj, & lwsvdjv, lrwqp3, lrwcon, lrwsvdj, iwoff - integer(ilp) :: lwrk_zgelqf, lwrk_zgeqp3, lwrk_zgeqp3n, lwrk_zgeqrf, lwrk_zgesvj, & + integer(${ik}$) :: lwrk_zgelqf, lwrk_zgeqp3, lwrk_zgeqp3n, lwrk_zgeqrf, lwrk_zgesvj, & lwrk_zgesvjv, lwrk_zgesvju, lwrk_zunmlq, lwrk_zunmqr, lwrk_zunmqrm ! Local Arrays - complex(dp) :: cdummy(1) - real(dp) :: rdummy(1) + complex(dp) :: cdummy(1_${ik}$) + real(dp) :: rdummy(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,cmplx,conjg,log,max,min,real,nint,sqrt ! test the input arguments @@ -74890,88 +74889,88 @@ module stdlib_linalg_lapack_z l2kill = stdlib_lsame( jobr, 'R' ) defr = stdlib_lsame( jobr, 'N' ) l2pert = stdlib_lsame( jobp, 'P' ) - lquery = ( lwork == -1 ) .or. ( lrwork == -1 ) + lquery = ( lwork == -1_${ik}$ ) .or. ( lrwork == -1_${ik}$ ) if ( .not.(rowpiv .or. l2rank .or. l2aber .or.errest .or. stdlib_lsame( joba, 'C' ) )) & then - info = - 1 + info = - 1_${ik}$ else if ( .not.( lsvec .or. stdlib_lsame( jobu, 'N' ) .or.( stdlib_lsame( jobu, 'W' ) & .and. rsvec .and. l2tran ) ) ) then - info = - 2 + info = - 2_${ik}$ else if ( .not.( rsvec .or. stdlib_lsame( jobv, 'N' ) .or.( stdlib_lsame( jobv, 'W' ) & .and. lsvec .and. l2tran ) ) ) then - info = - 3 + info = - 3_${ik}$ else if ( .not. ( l2kill .or. defr ) ) then - info = - 4 + info = - 4_${ik}$ else if ( .not. ( stdlib_lsame(jobt,'T') .or. stdlib_lsame(jobt,'N') ) ) then - info = - 5 + info = - 5_${ik}$ else if ( .not. ( l2pert .or. stdlib_lsame( jobp, 'N' ) ) ) then - info = - 6 - else if ( m < 0 ) then - info = - 7 - else if ( ( n < 0 ) .or. ( n > m ) ) then - info = - 8 + info = - 6_${ik}$ + else if ( m < 0_${ik}$ ) then + info = - 7_${ik}$ + else if ( ( n < 0_${ik}$ ) .or. ( n > m ) ) then + info = - 8_${ik}$ else if ( lda < m ) then - info = - 10 + info = - 10_${ik}$ else if ( lsvec .and. ( ldu < m ) ) then - info = - 13 + info = - 13_${ik}$ else if ( rsvec .and. ( ldv < n ) ) then - info = - 15 + info = - 15_${ik}$ else ! #:) - info = 0 + info = 0_${ik}$ end if - if ( info == 0 ) then + if ( info == 0_${ik}$ ) then ! Compute The Minimal And The Optimal Workspace Lengths ! [[the expressions for computing the minimal and the optimal ! values of lcwork, lrwork are written with a lot of redundancy and ! can be simplified. however, this verbose form is useful for ! maintenance and modifications of the code.]] - ! .. minimal workspace length for stdlib_zgeqp3 of an m x n matrix, - ! stdlib_zgeqrf of an n x n matrix, stdlib_zgelqf of an n x n matrix, - ! stdlib_zunmlq for computing n x n matrix, stdlib_zunmqr for computing n x n - ! matrix, stdlib_zunmqr for computing m x n matrix, respectively. + ! .. minimal workspace length for stdlib${ii}$_zgeqp3 of an m x n matrix, + ! stdlib${ii}$_zgeqrf of an n x n matrix, stdlib${ii}$_zgelqf of an n x n matrix, + ! stdlib${ii}$_zunmlq for computing n x n matrix, stdlib${ii}$_zunmqr for computing n x n + ! matrix, stdlib${ii}$_zunmqr for computing m x n matrix, respectively. lwqp3 = n+1 - lwqrf = max( 1, n ) - lwlqf = max( 1, n ) - lwunmlq = max( 1, n ) - lwunmqr = max( 1, n ) - lwunmqrm = max( 1, m ) + lwqrf = max( 1_${ik}$, n ) + lwlqf = max( 1_${ik}$, n ) + lwunmlq = max( 1_${ik}$, n ) + lwunmqr = max( 1_${ik}$, n ) + lwunmqrm = max( 1_${ik}$, m ) ! Minimal Workspace Length For Stdlib_Zpocon Of An N X N Matrix - lwcon = 2 * n - ! .. minimal workspace length for stdlib_zgesvj of an n x n matrix, + lwcon = 2_${ik}$ * n + ! .. minimal workspace length for stdlib${ii}$_zgesvj of an n x n matrix, ! without and with explicit accumulation of jacobi rotations - lwsvdj = max( 2 * n, 1 ) - lwsvdjv = max( 2 * n, 1 ) - ! .. minimal real workspace length for stdlib_zgeqp3, stdlib_zpocon, stdlib_zgesvj - lrwqp3 = 2 * n + lwsvdj = max( 2_${ik}$ * n, 1_${ik}$ ) + lwsvdjv = max( 2_${ik}$ * n, 1_${ik}$ ) + ! .. minimal real workspace length for stdlib${ii}$_zgeqp3, stdlib${ii}$_zpocon, stdlib${ii}$_zgesvj + lrwqp3 = 2_${ik}$ * n lrwcon = n lrwsvdj = n if ( lquery ) then - call stdlib_zgeqp3( m, n, a, lda, iwork, cdummy, cdummy, -1,rdummy, ierr ) + call stdlib${ii}$_zgeqp3( m, n, a, lda, iwork, cdummy, cdummy, -1_${ik}$,rdummy, ierr ) - lwrk_zgeqp3 = real( cdummy(1),KIND=dp) - call stdlib_zgeqrf( n, n, a, lda, cdummy, cdummy,-1, ierr ) - lwrk_zgeqrf = real( cdummy(1),KIND=dp) - call stdlib_zgelqf( n, n, a, lda, cdummy, cdummy,-1, ierr ) - lwrk_zgelqf = real( cdummy(1),KIND=dp) + lwrk_zgeqp3 = real( cdummy(1_${ik}$),KIND=dp) + call stdlib${ii}$_zgeqrf( n, n, a, lda, cdummy, cdummy,-1_${ik}$, ierr ) + lwrk_zgeqrf = real( cdummy(1_${ik}$),KIND=dp) + call stdlib${ii}$_zgelqf( n, n, a, lda, cdummy, cdummy,-1_${ik}$, ierr ) + lwrk_zgelqf = real( cdummy(1_${ik}$),KIND=dp) end if - minwrk = 2 - optwrk = 2 + minwrk = 2_${ik}$ + optwrk = 2_${ik}$ miniwrk = n if ( .not. (lsvec .or. rsvec ) ) then ! Minimal And Optimal Sizes Of The Complex Workspace If ! only the singular values are requested if ( errest ) then - minwrk = max( n+lwqp3, n**2+lwcon, n+lwqrf, lwsvdj ) + minwrk = max( n+lwqp3, n**2_${ik}$+lwcon, n+lwqrf, lwsvdj ) else minwrk = max( n+lwqp3, n+lwqrf, lwsvdj ) end if if ( lquery ) then - call stdlib_zgesvj( 'L', 'N', 'N', n, n, a, lda, sva, n, v,ldv, cdummy, -1,& - rdummy, -1, ierr ) - lwrk_zgesvj = real( cdummy(1),KIND=dp) + call stdlib${ii}$_zgesvj( 'L', 'N', 'N', n, n, a, lda, sva, n, v,ldv, cdummy, -1_${ik}$,& + rdummy, -1_${ik}$, ierr ) + lwrk_zgesvj = real( cdummy(1_${ik}$),KIND=dp) if ( errest ) then - optwrk = max( n+lwrk_zgeqp3, n**2+lwcon,n+lwrk_zgeqrf, lwrk_zgesvj ) + optwrk = max( n+lwrk_zgeqp3, n**2_${ik}$+lwcon,n+lwrk_zgeqrf, lwrk_zgesvj ) else optwrk = max( n+lwrk_zgeqp3, n+lwrk_zgeqrf,lwrk_zgesvj ) @@ -74979,15 +74978,15 @@ module stdlib_linalg_lapack_z end if if ( l2tran .or. rowpiv ) then if ( errest ) then - minrwrk = max( 7, 2*m, lrwqp3, lrwcon, lrwsvdj ) + minrwrk = max( 7_${ik}$, 2_${ik}$*m, lrwqp3, lrwcon, lrwsvdj ) else - minrwrk = max( 7, 2*m, lrwqp3, lrwsvdj ) + minrwrk = max( 7_${ik}$, 2_${ik}$*m, lrwqp3, lrwsvdj ) end if else if ( errest ) then - minrwrk = max( 7, lrwqp3, lrwcon, lrwsvdj ) + minrwrk = max( 7_${ik}$, lrwqp3, lrwcon, lrwsvdj ) else - minrwrk = max( 7, lrwqp3, lrwsvdj ) + minrwrk = max( 7_${ik}$, lrwqp3, lrwsvdj ) end if end if if ( rowpiv .or. l2tran ) miniwrk = miniwrk + m @@ -74995,38 +74994,38 @@ module stdlib_linalg_lapack_z ! Minimal And Optimal Sizes Of The Complex Workspace If The ! singular values and the right singular vectors are requested if ( errest ) then - minwrk = max( n+lwqp3, lwcon, lwsvdj, n+lwlqf,2*n+lwqrf, n+lwsvdj, n+& + minwrk = max( n+lwqp3, lwcon, lwsvdj, n+lwlqf,2_${ik}$*n+lwqrf, n+lwsvdj, n+& lwunmlq ) else - minwrk = max( n+lwqp3, lwsvdj, n+lwlqf, 2*n+lwqrf,n+lwsvdj, n+lwunmlq ) + minwrk = max( n+lwqp3, lwsvdj, n+lwlqf, 2_${ik}$*n+lwqrf,n+lwsvdj, n+lwunmlq ) end if if ( lquery ) then - call stdlib_zgesvj( 'L', 'U', 'N', n,n, u, ldu, sva, n, a,lda, cdummy, -1, & - rdummy, -1, ierr ) - lwrk_zgesvj = real( cdummy(1),KIND=dp) - call stdlib_zunmlq( 'L', 'C', n, n, n, a, lda, cdummy,v, ldv, cdummy, -1, & + call stdlib${ii}$_zgesvj( 'L', 'U', 'N', n,n, u, ldu, sva, n, a,lda, cdummy, -1_${ik}$, & + rdummy, -1_${ik}$, ierr ) + lwrk_zgesvj = real( cdummy(1_${ik}$),KIND=dp) + call stdlib${ii}$_zunmlq( 'L', 'C', n, n, n, a, lda, cdummy,v, ldv, cdummy, -1_${ik}$, & ierr ) - lwrk_zunmlq = real( cdummy(1),KIND=dp) + lwrk_zunmlq = real( cdummy(1_${ik}$),KIND=dp) if ( errest ) then - optwrk = max( n+lwrk_zgeqp3, lwcon, lwrk_zgesvj,n+lwrk_zgelqf, 2*n+& + optwrk = max( n+lwrk_zgeqp3, lwcon, lwrk_zgesvj,n+lwrk_zgelqf, 2_${ik}$*n+& lwrk_zgeqrf,n+lwrk_zgesvj, n+lwrk_zunmlq ) else - optwrk = max( n+lwrk_zgeqp3, lwrk_zgesvj,n+lwrk_zgelqf,2*n+lwrk_zgeqrf, n+& + optwrk = max( n+lwrk_zgeqp3, lwrk_zgesvj,n+lwrk_zgelqf,2_${ik}$*n+lwrk_zgeqrf, n+& lwrk_zgesvj,n+lwrk_zunmlq ) end if end if if ( l2tran .or. rowpiv ) then if ( errest ) then - minrwrk = max( 7, 2*m, lrwqp3, lrwsvdj, lrwcon ) + minrwrk = max( 7_${ik}$, 2_${ik}$*m, lrwqp3, lrwsvdj, lrwcon ) else - minrwrk = max( 7, 2*m, lrwqp3, lrwsvdj ) + minrwrk = max( 7_${ik}$, 2_${ik}$*m, lrwqp3, lrwsvdj ) end if else if ( errest ) then - minrwrk = max( 7, lrwqp3, lrwsvdj, lrwcon ) + minrwrk = max( 7_${ik}$, lrwqp3, lrwsvdj, lrwcon ) else - minrwrk = max( 7, lrwqp3, lrwsvdj ) + minrwrk = max( 7_${ik}$, lrwqp3, lrwsvdj ) end if end if if ( rowpiv .or. l2tran ) miniwrk = miniwrk + m @@ -75039,12 +75038,12 @@ module stdlib_linalg_lapack_z minwrk = n + max( lwqp3, n+lwqrf, lwsvdj, lwunmqrm ) end if if ( lquery ) then - call stdlib_zgesvj( 'L', 'U', 'N', n,n, u, ldu, sva, n, a,lda, cdummy, -1, & - rdummy, -1, ierr ) - lwrk_zgesvj = real( cdummy(1),KIND=dp) - call stdlib_zunmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -1, & + call stdlib${ii}$_zgesvj( 'L', 'U', 'N', n,n, u, ldu, sva, n, a,lda, cdummy, -1_${ik}$, & + rdummy, -1_${ik}$, ierr ) + lwrk_zgesvj = real( cdummy(1_${ik}$),KIND=dp) + call stdlib${ii}$_zunmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -1_${ik}$, & ierr ) - lwrk_zunmqrm = real( cdummy(1),KIND=dp) + lwrk_zunmqrm = real( cdummy(1_${ik}$),KIND=dp) if ( errest ) then optwrk = n + max( lwrk_zgeqp3, lwcon, n+lwrk_zgeqrf,lwrk_zgesvj, & lwrk_zunmqrm ) @@ -75055,15 +75054,15 @@ module stdlib_linalg_lapack_z end if if ( l2tran .or. rowpiv ) then if ( errest ) then - minrwrk = max( 7, 2*m, lrwqp3, lrwsvdj, lrwcon ) + minrwrk = max( 7_${ik}$, 2_${ik}$*m, lrwqp3, lrwsvdj, lrwcon ) else - minrwrk = max( 7, 2*m, lrwqp3, lrwsvdj ) + minrwrk = max( 7_${ik}$, 2_${ik}$*m, lrwqp3, lrwsvdj ) end if else if ( errest ) then - minrwrk = max( 7, lrwqp3, lrwsvdj, lrwcon ) + minrwrk = max( 7_${ik}$, lrwqp3, lrwsvdj, lrwcon ) else - minrwrk = max( 7, lrwqp3, lrwsvdj ) + minrwrk = max( 7_${ik}$, lrwqp3, lrwsvdj ) end if end if if ( rowpiv .or. l2tran ) miniwrk = miniwrk + m @@ -75072,108 +75071,108 @@ module stdlib_linalg_lapack_z ! full svd is requested if ( .not. jracc ) then if ( errest ) then - minwrk = max( n+lwqp3, n+lwcon, 2*n+n**2+lwcon,2*n+lwqrf, 2*n+& - lwqp3,2*n+n**2+n+lwlqf, 2*n+n**2+n+n**2+lwcon,2*n+n**2+n+lwsvdj, 2*n+& - n**2+n+lwsvdjv,2*n+n**2+n+lwunmqr,2*n+n**2+n+lwunmlq,n+n**2+lwsvdj, n+& + minwrk = max( n+lwqp3, n+lwcon, 2_${ik}$*n+n**2_${ik}$+lwcon,2_${ik}$*n+lwqrf, 2_${ik}$*n+& + lwqp3,2_${ik}$*n+n**2_${ik}$+n+lwlqf, 2_${ik}$*n+n**2_${ik}$+n+n**2_${ik}$+lwcon,2_${ik}$*n+n**2_${ik}$+n+lwsvdj, 2_${ik}$*n+& + n**2_${ik}$+n+lwsvdjv,2_${ik}$*n+n**2_${ik}$+n+lwunmqr,2_${ik}$*n+n**2_${ik}$+n+lwunmlq,n+n**2_${ik}$+lwsvdj, n+& lwunmqrm ) else - minwrk = max( n+lwqp3, 2*n+n**2+lwcon,2*n+lwqrf, 2*n+& - lwqp3,2*n+n**2+n+lwlqf, 2*n+n**2+n+n**2+lwcon,2*n+n**2+n+lwsvdj, 2*n+& - n**2+n+lwsvdjv,2*n+n**2+n+lwunmqr,2*n+n**2+n+lwunmlq,n+n**2+lwsvdj, & + minwrk = max( n+lwqp3, 2_${ik}$*n+n**2_${ik}$+lwcon,2_${ik}$*n+lwqrf, 2_${ik}$*n+& + lwqp3,2_${ik}$*n+n**2_${ik}$+n+lwlqf, 2_${ik}$*n+n**2_${ik}$+n+n**2_${ik}$+lwcon,2_${ik}$*n+n**2_${ik}$+n+lwsvdj, 2_${ik}$*n+& + n**2_${ik}$+n+lwsvdjv,2_${ik}$*n+n**2_${ik}$+n+lwunmqr,2_${ik}$*n+n**2_${ik}$+n+lwunmlq,n+n**2_${ik}$+lwsvdj, & n+lwunmqrm ) end if miniwrk = miniwrk + n if ( rowpiv .or. l2tran ) miniwrk = miniwrk + m else if ( errest ) then - minwrk = max( n+lwqp3, n+lwcon, 2*n+lwqrf,2*n+n**2+lwsvdjv, 2*n+n**2+n+& + minwrk = max( n+lwqp3, n+lwcon, 2_${ik}$*n+lwqrf,2_${ik}$*n+n**2_${ik}$+lwsvdjv, 2_${ik}$*n+n**2_${ik}$+n+& lwunmqr,n+lwunmqrm ) else - minwrk = max( n+lwqp3, 2*n+lwqrf,2*n+n**2+lwsvdjv, 2*n+n**2+n+lwunmqr,n+& + minwrk = max( n+lwqp3, 2_${ik}$*n+lwqrf,2_${ik}$*n+n**2_${ik}$+lwsvdjv, 2_${ik}$*n+n**2_${ik}$+n+lwunmqr,n+& lwunmqrm ) end if if ( rowpiv .or. l2tran ) miniwrk = miniwrk + m end if if ( lquery ) then - call stdlib_zunmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -1, & + call stdlib${ii}$_zunmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -1_${ik}$, & ierr ) - lwrk_zunmqrm = real( cdummy(1),KIND=dp) - call stdlib_zunmqr( 'L', 'N', n, n, n, a, lda, cdummy, u,ldu, cdummy, -1, & + lwrk_zunmqrm = real( cdummy(1_${ik}$),KIND=dp) + call stdlib${ii}$_zunmqr( 'L', 'N', n, n, n, a, lda, cdummy, u,ldu, cdummy, -1_${ik}$, & ierr ) - lwrk_zunmqr = real( cdummy(1),KIND=dp) + lwrk_zunmqr = real( cdummy(1_${ik}$),KIND=dp) if ( .not. jracc ) then - call stdlib_zgeqp3( n,n, a, lda, iwork, cdummy,cdummy, -1,rdummy, ierr ) + call stdlib${ii}$_zgeqp3( n,n, a, lda, iwork, cdummy,cdummy, -1_${ik}$,rdummy, ierr ) - lwrk_zgeqp3n = real( cdummy(1),KIND=dp) - call stdlib_zgesvj( 'L', 'U', 'N', n, n, u, ldu, sva,n, v, ldv, cdummy, & - -1, rdummy, -1, ierr ) - lwrk_zgesvj = real( cdummy(1),KIND=dp) - call stdlib_zgesvj( 'U', 'U', 'N', n, n, u, ldu, sva,n, v, ldv, cdummy, & - -1, rdummy, -1, ierr ) - lwrk_zgesvju = real( cdummy(1),KIND=dp) - call stdlib_zgesvj( 'L', 'U', 'V', n, n, u, ldu, sva,n, v, ldv, cdummy, & - -1, rdummy, -1, ierr ) - lwrk_zgesvjv = real( cdummy(1),KIND=dp) - call stdlib_zunmlq( 'L', 'C', n, n, n, a, lda, cdummy,v, ldv, cdummy, -& - 1, ierr ) - lwrk_zunmlq = real( cdummy(1),KIND=dp) + lwrk_zgeqp3n = real( cdummy(1_${ik}$),KIND=dp) + call stdlib${ii}$_zgesvj( 'L', 'U', 'N', n, n, u, ldu, sva,n, v, ldv, cdummy, & + -1_${ik}$, rdummy, -1_${ik}$, ierr ) + lwrk_zgesvj = real( cdummy(1_${ik}$),KIND=dp) + call stdlib${ii}$_zgesvj( 'U', 'U', 'N', n, n, u, ldu, sva,n, v, ldv, cdummy, & + -1_${ik}$, rdummy, -1_${ik}$, ierr ) + lwrk_zgesvju = real( cdummy(1_${ik}$),KIND=dp) + call stdlib${ii}$_zgesvj( 'L', 'U', 'V', n, n, u, ldu, sva,n, v, ldv, cdummy, & + -1_${ik}$, rdummy, -1_${ik}$, ierr ) + lwrk_zgesvjv = real( cdummy(1_${ik}$),KIND=dp) + call stdlib${ii}$_zunmlq( 'L', 'C', n, n, n, a, lda, cdummy,v, ldv, cdummy, -& + 1_${ik}$, ierr ) + lwrk_zunmlq = real( cdummy(1_${ik}$),KIND=dp) if ( errest ) then - optwrk = max( n+lwrk_zgeqp3, n+lwcon,2*n+n**2+lwcon, 2*n+lwrk_zgeqrf,& - 2*n+lwrk_zgeqp3n,2*n+n**2+n+lwrk_zgelqf,2*n+n**2+n+n**2+lwcon,2*n+& - n**2+n+lwrk_zgesvj,2*n+n**2+n+lwrk_zgesvjv,2*n+n**2+n+lwrk_zunmqr,2*n+& - n**2+n+lwrk_zunmlq,n+n**2+lwrk_zgesvju,n+lwrk_zunmqrm ) + optwrk = max( n+lwrk_zgeqp3, n+lwcon,2_${ik}$*n+n**2_${ik}$+lwcon, 2_${ik}$*n+lwrk_zgeqrf,& + 2_${ik}$*n+lwrk_zgeqp3n,2_${ik}$*n+n**2_${ik}$+n+lwrk_zgelqf,2_${ik}$*n+n**2_${ik}$+n+n**2_${ik}$+lwcon,2_${ik}$*n+& + n**2_${ik}$+n+lwrk_zgesvj,2_${ik}$*n+n**2_${ik}$+n+lwrk_zgesvjv,2_${ik}$*n+n**2_${ik}$+n+lwrk_zunmqr,2_${ik}$*n+& + n**2_${ik}$+n+lwrk_zunmlq,n+n**2_${ik}$+lwrk_zgesvju,n+lwrk_zunmqrm ) else - optwrk = max( n+lwrk_zgeqp3,2*n+n**2+lwcon, 2*n+lwrk_zgeqrf,2*n+& - lwrk_zgeqp3n,2*n+n**2+n+lwrk_zgelqf,2*n+n**2+n+n**2+lwcon,2*n+n**2+n+& - lwrk_zgesvj,2*n+n**2+n+lwrk_zgesvjv,2*n+n**2+n+lwrk_zunmqr,2*n+n**2+n+& - lwrk_zunmlq,n+n**2+lwrk_zgesvju,n+lwrk_zunmqrm ) + optwrk = max( n+lwrk_zgeqp3,2_${ik}$*n+n**2_${ik}$+lwcon, 2_${ik}$*n+lwrk_zgeqrf,2_${ik}$*n+& + lwrk_zgeqp3n,2_${ik}$*n+n**2_${ik}$+n+lwrk_zgelqf,2_${ik}$*n+n**2_${ik}$+n+n**2_${ik}$+lwcon,2_${ik}$*n+n**2_${ik}$+n+& + lwrk_zgesvj,2_${ik}$*n+n**2_${ik}$+n+lwrk_zgesvjv,2_${ik}$*n+n**2_${ik}$+n+lwrk_zunmqr,2_${ik}$*n+n**2_${ik}$+n+& + lwrk_zunmlq,n+n**2_${ik}$+lwrk_zgesvju,n+lwrk_zunmqrm ) end if else - call stdlib_zgesvj( 'L', 'U', 'V', n, n, u, ldu, sva,n, v, ldv, cdummy, & - -1, rdummy, -1, ierr ) - lwrk_zgesvjv = real( cdummy(1),KIND=dp) - call stdlib_zunmqr( 'L', 'N', n, n, n, cdummy, n, cdummy,v, ldv, cdummy,& - -1, ierr ) - lwrk_zunmqr = real( cdummy(1),KIND=dp) - call stdlib_zunmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -& - 1, ierr ) - lwrk_zunmqrm = real( cdummy(1),KIND=dp) + call stdlib${ii}$_zgesvj( 'L', 'U', 'V', n, n, u, ldu, sva,n, v, ldv, cdummy, & + -1_${ik}$, rdummy, -1_${ik}$, ierr ) + lwrk_zgesvjv = real( cdummy(1_${ik}$),KIND=dp) + call stdlib${ii}$_zunmqr( 'L', 'N', n, n, n, cdummy, n, cdummy,v, ldv, cdummy,& + -1_${ik}$, ierr ) + lwrk_zunmqr = real( cdummy(1_${ik}$),KIND=dp) + call stdlib${ii}$_zunmqr( 'L', 'N', m, n, n, a, lda, cdummy, u,ldu, cdummy, -& + 1_${ik}$, ierr ) + lwrk_zunmqrm = real( cdummy(1_${ik}$),KIND=dp) if ( errest ) then - optwrk = max( n+lwrk_zgeqp3, n+lwcon,2*n+lwrk_zgeqrf, 2*n+n**2,2*n+& - n**2+lwrk_zgesvjv,2*n+n**2+n+lwrk_zunmqr,n+lwrk_zunmqrm ) + optwrk = max( n+lwrk_zgeqp3, n+lwcon,2_${ik}$*n+lwrk_zgeqrf, 2_${ik}$*n+n**2_${ik}$,2_${ik}$*n+& + n**2_${ik}$+lwrk_zgesvjv,2_${ik}$*n+n**2_${ik}$+n+lwrk_zunmqr,n+lwrk_zunmqrm ) else - optwrk = max( n+lwrk_zgeqp3, 2*n+lwrk_zgeqrf,2*n+n**2, 2*n+n**2+& - lwrk_zgesvjv,2*n+n**2+n+lwrk_zunmqr,n+lwrk_zunmqrm ) + optwrk = max( n+lwrk_zgeqp3, 2_${ik}$*n+lwrk_zgeqrf,2_${ik}$*n+n**2_${ik}$, 2_${ik}$*n+n**2_${ik}$+& + lwrk_zgesvjv,2_${ik}$*n+n**2_${ik}$+n+lwrk_zunmqr,n+lwrk_zunmqrm ) end if end if end if if ( l2tran .or. rowpiv ) then - minrwrk = max( 7, 2*m, lrwqp3, lrwsvdj, lrwcon ) + minrwrk = max( 7_${ik}$, 2_${ik}$*m, lrwqp3, lrwsvdj, lrwcon ) else - minrwrk = max( 7, lrwqp3, lrwsvdj, lrwcon ) + minrwrk = max( 7_${ik}$, lrwqp3, lrwsvdj, lrwcon ) end if end if - minwrk = max( 2, minwrk ) + minwrk = max( 2_${ik}$, minwrk ) optwrk = max( minwrk, optwrk ) - if ( lwork < minwrk .and. (.not.lquery) ) info = - 17 - if ( lrwork < minrwrk .and. (.not.lquery) ) info = - 19 + if ( lwork < minwrk .and. (.not.lquery) ) info = - 17_${ik}$ + if ( lrwork < minrwrk .and. (.not.lquery) ) info = - 19_${ik}$ end if - if ( info /= 0 ) then + if ( info /= 0_${ik}$ ) then ! #:( - call stdlib_xerbla( 'ZGEJSV', - info ) + call stdlib${ii}$_xerbla( 'ZGEJSV', - info ) return else if ( lquery ) then - cwork(1) = optwrk - cwork(2) = minwrk - rwork(1) = minrwrk - iwork(1) = max( 4, miniwrk ) + cwork(1_${ik}$) = optwrk + cwork(2_${ik}$) = minwrk + rwork(1_${ik}$) = minrwrk + iwork(1_${ik}$) = max( 4_${ik}$, miniwrk ) return end if ! quick return for void matrix (y3k safe) ! #:) - if ( ( m == 0 ) .or. ( n == 0 ) ) then - iwork(1:4) = 0 - rwork(1:7) = 0 + if ( ( m == 0_${ik}$ ) .or. ( n == 0_${ik}$ ) ) then + iwork(1_${ik}$:4_${ik}$) = 0_${ik}$ + rwork(1_${ik}$:7_${ik}$) = 0_${ik}$ return endif ! determine whether the matrix u should be m x n or m x m @@ -75182,11 +75181,11 @@ module stdlib_linalg_lapack_z if ( stdlib_lsame( jobu, 'F' ) ) n1 = m end if ! set numerical parameters - ! ! note: make sure stdlib_dlamch() does not fail on the target architecture. - epsln = stdlib_dlamch('EPSILON') - sfmin = stdlib_dlamch('SAFEMINIMUM') + ! ! note: make sure stdlib${ii}$_dlamch() does not fail on the target architecture. + epsln = stdlib${ii}$_dlamch('EPSILON') + sfmin = stdlib${ii}$_dlamch('SAFEMINIMUM') small = sfmin / epsln - big = stdlib_dlamch('O') + big = stdlib${ii}$_dlamch('O') ! big = one / sfmin ! initialize sva(1:n) = diag( ||a e_i||_2 )_1^n ! (!) if necessary, scale sva() to protect the largest norm from @@ -75198,10 +75197,10 @@ module stdlib_linalg_lapack_z do p = 1, n aapp = zero aaqq = one - call stdlib_zlassq( m, a(1,p), 1, aapp, aaqq ) + call stdlib${ii}$_zlassq( m, a(1_${ik}$,p), 1_${ik}$, aapp, aaqq ) if ( aapp > big ) then - info = - 9 - call stdlib_xerbla( 'ZGEJSV', -info ) + info = - 9_${ik}$ + call stdlib${ii}$_xerbla( 'ZGEJSV', -info ) return end if aaqq = sqrt(aaqq) @@ -75212,7 +75211,7 @@ module stdlib_linalg_lapack_z sva(p) = aapp * ( aaqq * scalem ) if ( goscal ) then goscal = .false. - call stdlib_dscal( p-1, scalem, sva, 1 ) + call stdlib${ii}$_dscal( p-1, scalem, sva, 1_${ik}$ ) end if end if end do @@ -75226,78 +75225,78 @@ module stdlib_linalg_lapack_z ! quick return for zero m x n matrix ! #:) if ( aapp == zero ) then - if ( lsvec ) call stdlib_zlaset( 'G', m, n1, czero, cone, u, ldu ) - if ( rsvec ) call stdlib_zlaset( 'G', n, n, czero, cone, v, ldv ) - rwork(1) = one - rwork(2) = one - if ( errest ) rwork(3) = one + if ( lsvec ) call stdlib${ii}$_zlaset( 'G', m, n1, czero, cone, u, ldu ) + if ( rsvec ) call stdlib${ii}$_zlaset( 'G', n, n, czero, cone, v, ldv ) + rwork(1_${ik}$) = one + rwork(2_${ik}$) = one + if ( errest ) rwork(3_${ik}$) = one if ( lsvec .and. rsvec ) then - rwork(4) = one - rwork(5) = one + rwork(4_${ik}$) = one + rwork(5_${ik}$) = one end if if ( l2tran ) then - rwork(6) = zero - rwork(7) = zero + rwork(6_${ik}$) = zero + rwork(7_${ik}$) = zero end if - iwork(1) = 0 - iwork(2) = 0 - iwork(3) = 0 - iwork(4) = -1 + iwork(1_${ik}$) = 0_${ik}$ + iwork(2_${ik}$) = 0_${ik}$ + iwork(3_${ik}$) = 0_${ik}$ + iwork(4_${ik}$) = -1_${ik}$ return end if ! issue warning if denormalized column norms detected. override the ! high relative accuracy request. issue licence to kill nonzero columns ! (set them to zero) whose norm is less than sigma_max / big (roughly). ! #:( - warning = 0 + warning = 0_${ik}$ if ( aaqq <= sfmin ) then l2rank = .true. l2kill = .true. - warning = 1 + warning = 1_${ik}$ end if ! quick return for one-column matrix ! #:) - if ( n == 1 ) then + if ( n == 1_${ik}$ ) then if ( lsvec ) then - call stdlib_zlascl( 'G',0,0,sva(1),scalem, m,1,a(1,1),lda,ierr ) - call stdlib_zlacpy( 'A', m, 1, a, lda, u, ldu ) + call stdlib${ii}$_zlascl( 'G',0_${ik}$,0_${ik}$,sva(1_${ik}$),scalem, m,1_${ik}$,a(1_${ik}$,1_${ik}$),lda,ierr ) + call stdlib${ii}$_zlacpy( 'A', m, 1_${ik}$, a, lda, u, ldu ) ! computing all m left singular vectors of the m x 1 matrix if ( n1 /= n ) then - call stdlib_zgeqrf( m, n, u,ldu, cwork, cwork(n+1),lwork-n,ierr ) - call stdlib_zungqr( m,n1,1, u,ldu,cwork,cwork(n+1),lwork-n,ierr ) - call stdlib_zcopy( m, a(1,1), 1, u(1,1), 1 ) + call stdlib${ii}$_zgeqrf( m, n, u,ldu, cwork, cwork(n+1),lwork-n,ierr ) + call stdlib${ii}$_zungqr( m,n1,1_${ik}$, u,ldu,cwork,cwork(n+1),lwork-n,ierr ) + call stdlib${ii}$_zcopy( m, a(1_${ik}$,1_${ik}$), 1_${ik}$, u(1_${ik}$,1_${ik}$), 1_${ik}$ ) end if end if if ( rsvec ) then - v(1,1) = cone + v(1_${ik}$,1_${ik}$) = cone end if - if ( sva(1) < (big*scalem) ) then - sva(1) = sva(1) / scalem + if ( sva(1_${ik}$) < (big*scalem) ) then + sva(1_${ik}$) = sva(1_${ik}$) / scalem scalem = one end if - rwork(1) = one / scalem - rwork(2) = one - if ( sva(1) /= zero ) then - iwork(1) = 1 - if ( ( sva(1) / scalem) >= sfmin ) then - iwork(2) = 1 + rwork(1_${ik}$) = one / scalem + rwork(2_${ik}$) = one + if ( sva(1_${ik}$) /= zero ) then + iwork(1_${ik}$) = 1_${ik}$ + if ( ( sva(1_${ik}$) / scalem) >= sfmin ) then + iwork(2_${ik}$) = 1_${ik}$ else - iwork(2) = 0 + iwork(2_${ik}$) = 0_${ik}$ end if else - iwork(1) = 0 - iwork(2) = 0 + iwork(1_${ik}$) = 0_${ik}$ + iwork(2_${ik}$) = 0_${ik}$ end if - iwork(3) = 0 - iwork(4) = -1 - if ( errest ) rwork(3) = one + iwork(3_${ik}$) = 0_${ik}$ + iwork(4_${ik}$) = -1_${ik}$ + if ( errest ) rwork(3_${ik}$) = one if ( lsvec .and. rsvec ) then - rwork(4) = one - rwork(5) = one + rwork(4_${ik}$) = one + rwork(5_${ik}$) = one end if if ( l2tran ) then - rwork(6) = zero - rwork(7) = zero + rwork(6_${ik}$) = zero + rwork(7_${ik}$) = zero end if return end if @@ -75313,8 +75312,8 @@ module stdlib_linalg_lapack_z do p = 1, m xsc = zero temp1 = one - call stdlib_zlassq( n, a(p,1), lda, xsc, temp1 ) - ! stdlib_zlassq gets both the ell_2 and the ell_infinity norm + call stdlib${ii}$_zlassq( n, a(p,1_${ik}$), lda, xsc, temp1 ) + ! stdlib${ii}$_zlassq gets both the ell_2 and the ell_infinity norm ! in one pass through the vector rwork(m+p) = xsc * scalem rwork(p) = xsc * (scalem*sqrt(temp1)) @@ -75323,7 +75322,7 @@ module stdlib_linalg_lapack_z end do else do p = 1, m - rwork(m+p) = scalem*abs( a(p,stdlib_izamax(n,a(p,1),lda)) ) + rwork(m+p) = scalem*abs( a(p,stdlib${ii}$_izamax(n,a(p,1_${ik}$),lda)) ) aatmax = max( aatmax, rwork(m+p) ) aatmin = min( aatmin, rwork(m+p) ) end do @@ -75340,11 +75339,11 @@ module stdlib_linalg_lapack_z if ( l2tran ) then xsc = zero temp1 = one - call stdlib_dlassq( n, sva, 1, xsc, temp1 ) + call stdlib${ii}$_dlassq( n, sva, 1_${ik}$, xsc, temp1 ) temp1 = one / temp1 entra = zero do p = 1, n - big1 = ( ( sva(p) / xsc )**2 ) * temp1 + big1 = ( ( sva(p) / xsc )**2_${ik}$ ) * temp1 if ( big1 /= zero ) entra = entra + big1 * log(big1) end do entra = - entra / log(real(n,KIND=dp)) @@ -75355,7 +75354,7 @@ module stdlib_linalg_lapack_z ! same trace. entrat = zero do p = 1, m - big1 = ( ( rwork(p) / xsc )**2 ) * temp1 + big1 = ( ( rwork(p) / xsc )**2_${ik}$ ) * temp1 if ( big1 /= zero ) entrat = entrat + big1 * log(big1) end do entrat = - entrat / log(real(m,KIND=dp)) @@ -75399,25 +75398,25 @@ module stdlib_linalg_lapack_z ! scale the matrix so that its maximal singular value remains less ! than sqrt(big) -- the matrix is scaled so that its maximal column ! has euclidean norm equal to sqrt(big/n). the only reason to keep - ! sqrt(big) instead of big is the fact that stdlib_zgejsv uses lapack and + ! sqrt(big) instead of big is the fact that stdlib${ii}$_zgejsv uses lapack and ! blas routines that, in some implementations, are not capable of ! working in the full interval [sfmin,big] and that they may provoke ! overflows in the intermediate results. if the singular values spread - ! from sfmin to big, then stdlib_zgesvj will compute them. so, in that case, - ! one should use stdlib_zgesvj instead of stdlib_zgejsv. + ! from sfmin to big, then stdlib${ii}$_zgesvj will compute them. so, in that case, + ! one should use stdlib_zgesvj instead of stdlib${ii}$_zgejsv. ! >> change in the april 2016 update: allow bigger range, i.e. the - ! largest column is allowed up to big/n and stdlib_zgesvj will do the rest. + ! largest column is allowed up to big/n and stdlib${ii}$_zgesvj will do the rest. big1 = sqrt( big ) temp1 = sqrt( big / real(n,KIND=dp) ) ! temp1 = big/real(n,KIND=dp) - call stdlib_dlascl( 'G', 0, 0, aapp, temp1, n, 1, sva, n, ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, temp1, n, 1_${ik}$, sva, n, ierr ) if ( aaqq > (aapp * sfmin) ) then aaqq = ( aaqq / aapp ) * temp1 else aaqq = ( aaqq * temp1 ) / aapp end if temp1 = temp1 * scalem - call stdlib_zlascl( 'G', 0, 0, aapp, temp1, m, n, a, lda, ierr ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, temp1, m, n, a, lda, ierr ) ! to undo scaling at the end of this procedure, multiply the ! computed singular values with uscal2 / uscal1. uscal1 = temp1 @@ -75431,7 +75430,7 @@ module stdlib_linalg_lapack_z xsc = small ! now, if the condition number of a is too big, ! sigma_max(a) / sigma_min(a) > sqrt(big/n) * epsln / sfmin, - ! as a precaution measure, the full svd is computed using stdlib_zgesvj + ! as a precaution measure, the full svd is computed using stdlib${ii}$_zgesvj ! with accumulated jacobi rotations. this provides numerically ! more robust computation, at the cost of slightly increased run ! time. depending on the concrete implementation of blas and lapack @@ -75444,7 +75443,7 @@ module stdlib_linalg_lapack_z if ( aaqq < xsc ) then do p = 1, n if ( sva(p) < xsc ) then - call stdlib_zlaset( 'A', m, 1, czero, czero, a(1,p), lda ) + call stdlib${ii}$_zlaset( 'A', m, 1_${ik}$, czero, czero, a(1_${ik}$,p), lda ) sva(p) = zero end if end do @@ -75457,12 +75456,12 @@ module stdlib_linalg_lapack_z ! has similar effect as powell-reid complete pivoting. ! the ell-infinity norms of a are made nonincreasing. if ( ( lsvec .and. rsvec ) .and. .not.( jracc ) ) then - iwoff = 2*n + iwoff = 2_${ik}$*n else iwoff = n end if do p = 1, m - 1 - q = stdlib_idamax( m-p+1, rwork(m+p), 1 ) + p - 1 + q = stdlib${ii}$_idamax( m-p+1, rwork(m+p), 1_${ik}$ ) + p - 1_${ik}$ iwork(iwoff+p) = q if ( p /= q ) then temp1 = rwork(m+p) @@ -75470,7 +75469,7 @@ module stdlib_linalg_lapack_z rwork(m+q) = temp1 end if end do - call stdlib_zlaswp( n, a, lda, 1, m-1, iwork(iwoff+1), 1 ) + call stdlib${ii}$_zlaswp( n, a, lda, 1_${ik}$, m-1, iwork(iwoff+1), 1_${ik}$ ) end if ! end of the preparation phase (scaling, optional sorting and ! transposing, optional flushing of small columns). @@ -75482,47 +75481,45 @@ module stdlib_linalg_lapack_z ! (eg speed by replacing global with restricted window pivoting, such ! as in xgeqpx from toms # 782). good results will be obtained using ! xgeqpx with properly (!) chosen numerical parameters. - ! any improvement of stdlib_zgeqp3 improves overall performance of stdlib_zgejsv. + ! any improvement of stdlib${ii}$_zgeqp3 improves overall performance of stdlib${ii}$_zgejsv. ! a * p1 = q1 * [ r1^* 0]^*: do p = 1, n ! All Columns Are Free Columns - iwork(p) = 0 + iwork(p) = 0_${ik}$ end do - call stdlib_zgeqp3( m, n, a, lda, iwork, cwork, cwork(n+1), lwork-n,rwork, ierr ) + call stdlib${ii}$_zgeqp3( m, n, a, lda, iwork, cwork, cwork(n+1), lwork-n,rwork, ierr ) ! the upper triangular matrix r1 from the first qrf is inspected for ! rank deficiency and possibilities for deflation, or possible ! ill-conditioning. depending on the user specified flag l2rank, ! the procedure explores possibilities to reduce the numerical ! rank by inspecting the computed upper triangular factor. if - ! l2rank or l2aber are up, then stdlib_zgejsv will compute the svd of + ! l2rank or l2aber are up, then stdlib${ii}$_zgejsv will compute the svd of ! a + da, where ||da|| <= f(m,n)*epsln. - nr = 1 + nr = 1_${ik}$ if ( l2aber ) then ! standard absolute error bound suffices. all sigma_i with ! sigma_i < n*epsln*||a|| are flushed to zero. this is an ! aggressive enforcement of lower numerical rank by introducing a ! backward error of the order of n*epsln*||a||. temp1 = sqrt(real(n,KIND=dp))*epsln - do p = 2, n - if ( abs(a(p,p)) >= (temp1*abs(a(1,1))) ) then - nr = nr + 1 + loop_3002: do p = 2, n + if ( abs(a(p,p)) >= (temp1*abs(a(1_${ik}$,1_${ik}$))) ) then + nr = nr + 1_${ik}$ else - go to 3002 + exit loop_3002 end if - end do - 3002 continue + end do loop_3002 else if ( l2rank ) then ! .. similarly as above, only slightly more gentle (less aggressive). ! sudden drop on the diagonal of r1 is used as the criterion for ! close-to-rank-deficient. temp1 = sqrt(sfmin) - do p = 2, n + loop_3402: do p = 2, n if ( ( abs(a(p,p)) < (epsln*abs(a(p-1,p-1))) ) .or.( abs(a(p,p)) < small ) .or.( & - l2kill .and. (abs(a(p,p)) < temp1) ) ) go to 3402 - nr = nr + 1 - end do - 3402 continue + l2kill .and. (abs(a(p,p)) < temp1) ) ) exit loop_3402 + nr = nr + 1_${ik}$ + end do loop_3402 else ! the goal is high relative accuracy. however, if the matrix ! has high scaled condition number the relative accuracy is in @@ -75532,12 +75529,10 @@ module stdlib_linalg_lapack_z ! factor. this prevents the situation in which the code is ! working hard to get the accuracy not warranted by the data. temp1 = sqrt(sfmin) - do p = 2, n - if ( ( abs(a(p,p)) < small ) .or.( l2kill .and. (abs(a(p,p)) < temp1) ) ) go to & - 3302 - nr = nr + 1 - end do - 3302 continue + loop_3302: do p = 2, n + if ( ( abs(a(p,p)) < small ) .or.( l2kill .and. (abs(a(p,p)) < temp1) ) ) exit loop_3302 + nr = nr + 1_${ik}$ + end do loop_3302 end if almort = .false. if ( nr == n ) then @@ -75546,7 +75541,7 @@ module stdlib_linalg_lapack_z temp1 = abs(a(p,p)) / sva(iwork(p)) maxprj = min( maxprj, temp1 ) end do - if ( maxprj**2 >= one - real(n,KIND=dp)*epsln ) almort = .true. + if ( maxprj**2_${ik}$ >= one - real(n,KIND=dp)*epsln ) almort = .true. end if sconda = - one condr1 = - one @@ -75555,41 +75550,41 @@ module stdlib_linalg_lapack_z if ( n == nr ) then if ( rsvec ) then ! V Is Available As Workspace - call stdlib_zlacpy( 'U', n, n, a, lda, v, ldv ) + call stdlib${ii}$_zlacpy( 'U', n, n, a, lda, v, ldv ) do p = 1, n temp1 = sva(iwork(p)) - call stdlib_zdscal( p, one/temp1, v(1,p), 1 ) + call stdlib${ii}$_zdscal( p, one/temp1, v(1_${ik}$,p), 1_${ik}$ ) end do if ( lsvec )then - call stdlib_zpocon( 'U', n, v, ldv, one, temp1,cwork(n+1), rwork, ierr ) + call stdlib${ii}$_zpocon( 'U', n, v, ldv, one, temp1,cwork(n+1), rwork, ierr ) else - call stdlib_zpocon( 'U', n, v, ldv, one, temp1,cwork, rwork, ierr ) + call stdlib${ii}$_zpocon( 'U', n, v, ldv, one, temp1,cwork, rwork, ierr ) end if else if ( lsvec ) then ! U Is Available As Workspace - call stdlib_zlacpy( 'U', n, n, a, lda, u, ldu ) + call stdlib${ii}$_zlacpy( 'U', n, n, a, lda, u, ldu ) do p = 1, n temp1 = sva(iwork(p)) - call stdlib_zdscal( p, one/temp1, u(1,p), 1 ) + call stdlib${ii}$_zdscal( p, one/temp1, u(1_${ik}$,p), 1_${ik}$ ) end do - call stdlib_zpocon( 'U', n, u, ldu, one, temp1,cwork(n+1), rwork, ierr ) + call stdlib${ii}$_zpocon( 'U', n, u, ldu, one, temp1,cwork(n+1), rwork, ierr ) else - call stdlib_zlacpy( 'U', n, n, a, lda, cwork, n ) - ! [] call stdlib_zlacpy( 'u', n, n, a, lda, cwork(n+1), n ) + call stdlib${ii}$_zlacpy( 'U', n, n, a, lda, cwork, n ) + ! [] call stdlib${ii}$_zlacpy( 'u', n, n, a, lda, cwork(n+1), n ) ! change: here index shifted by n to the left, cwork(1:n) ! not needed for sigma only computation do p = 1, n temp1 = sva(iwork(p)) - ! [] call stdlib_zdscal( p, one/temp1, cwork(n+(p-1)*n+1), 1 ) - call stdlib_zdscal( p, one/temp1, cwork((p-1)*n+1), 1 ) + ! [] call stdlib${ii}$_zdscal( p, one/temp1, cwork(n+(p-1)*n+1), 1 ) + call stdlib${ii}$_zdscal( p, one/temp1, cwork((p-1)*n+1), 1_${ik}$ ) end do ! The Columns Of R Are Scaled To Have Unit Euclidean Lengths - ! [] call stdlib_zpocon( 'u', n, cwork(n+1), n, one, temp1, + ! [] call stdlib${ii}$_zpocon( 'u', n, cwork(n+1), n, one, temp1, ! [] $ cwork(n+n*n+1), rwork, ierr ) - call stdlib_zpocon( 'U', n, cwork, n, one, temp1,cwork(n*n+1), rwork, ierr ) + call stdlib${ii}$_zpocon( 'U', n, cwork, n, one, temp1,cwork(n*n+1), rwork, ierr ) end if if ( temp1 /= zero ) then @@ -75603,15 +75598,15 @@ module stdlib_linalg_lapack_z sconda = - one end if end if - l2pert = l2pert .and. ( abs( a(1,1)/a(nr,nr) ) > sqrt(big1) ) + l2pert = l2pert .and. ( abs( a(1_${ik}$,1_${ik}$)/a(nr,nr) ) > sqrt(big1) ) ! if there is no violent scaling, artificial perturbation is not needed. ! phase 3: if ( .not. ( rsvec .or. lsvec ) ) then ! singular values only ! .. transpose a(1:nr,1:n) do p = 1, min( n-1, nr ) - call stdlib_zcopy( n-p, a(p,p+1), lda, a(p+1,p), 1 ) - call stdlib_zlacgv( n-p+1, a(p,p), 1 ) + call stdlib${ii}$_zcopy( n-p, a(p,p+1), lda, a(p+1,p), 1_${ik}$ ) + call stdlib${ii}$_zlacgv( n-p+1, a(p,p), 1_${ik}$ ) end do if ( nr == n ) a(n,n) = conjg(a(n,n)) ! the following two do-loops introduce small relative perturbation @@ -75638,14 +75633,14 @@ module stdlib_linalg_lapack_z end do end do else - if (nr>1) call stdlib_zlaset( 'U', nr-1,nr-1, czero,czero, a(1,2),lda ) + if (nr>1_${ik}$) call stdlib${ii}$_zlaset( 'U', nr-1,nr-1, czero,czero, a(1_${ik}$,2_${ik}$),lda ) end if ! Second Preconditioning Using The Qr Factorization - call stdlib_zgeqrf( n,nr, a,lda, cwork, cwork(n+1),lwork-n, ierr ) + call stdlib${ii}$_zgeqrf( n,nr, a,lda, cwork, cwork(n+1),lwork-n, ierr ) ! And Transpose Upper To Lower Triangular do p = 1, nr - 1 - call stdlib_zcopy( nr-p, a(p,p+1), lda, a(p+1,p), 1 ) - call stdlib_zlacgv( nr-p+1, a(p,p), 1 ) + call stdlib${ii}$_zcopy( nr-p, a(p,p+1), lda, a(p+1,p), 1_${ik}$ ) + call stdlib${ii}$_zlacgv( nr-p+1, a(p,p), 1_${ik}$ ) end do end if ! row-cyclic jacobi svd algorithm with column pivoting @@ -75663,107 +75658,107 @@ module stdlib_linalg_lapack_z end do end do else - if (nr>1) call stdlib_zlaset( 'U', nr-1, nr-1, czero, czero, a(1,2), lda ) + if (nr>1_${ik}$) call stdlib${ii}$_zlaset( 'U', nr-1, nr-1, czero, czero, a(1_${ik}$,2_${ik}$), lda ) end if ! .. and one-sided jacobi rotations are started on a lower ! triangular matrix (plus perturbation which is ignored in ! the part which destroys triangular form (confusing?!)) - call stdlib_zgesvj( 'L', 'N', 'N', nr, nr, a, lda, sva,n, v, ldv, cwork, lwork, & + call stdlib${ii}$_zgesvj( 'L', 'N', 'N', nr, nr, a, lda, sva,n, v, ldv, cwork, lwork, & rwork, lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) else if ( ( rsvec .and. ( .not. lsvec ) .and. ( .not. jracc ) ).or.( jracc .and. ( & .not. lsvec ) .and. ( nr /= n ) ) ) then ! -> singular values and right singular vectors <- if ( almort ) then ! In This Case Nr Equals N do p = 1, nr - call stdlib_zcopy( n-p+1, a(p,p), lda, v(p,p), 1 ) - call stdlib_zlacgv( n-p+1, v(p,p), 1 ) + call stdlib${ii}$_zcopy( n-p+1, a(p,p), lda, v(p,p), 1_${ik}$ ) + call stdlib${ii}$_zlacgv( n-p+1, v(p,p), 1_${ik}$ ) end do - if (nr>1) call stdlib_zlaset( 'U', nr-1,nr-1, czero, czero, v(1,2), ldv ) - call stdlib_zgesvj( 'L','U','N', n, nr, v, ldv, sva, nr, a, lda,cwork, lwork, & + if (nr>1_${ik}$) call stdlib${ii}$_zlaset( 'U', nr-1,nr-1, czero, czero, v(1_${ik}$,2_${ik}$), ldv ) + call stdlib${ii}$_zgesvj( 'L','U','N', n, nr, v, ldv, sva, nr, a, lda,cwork, lwork, & rwork, lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) else ! .. two more qr factorizations ( one qrf is not enough, two require ! accumulated product of jacobi rotations, three are perfect ) - if (nr>1) call stdlib_zlaset( 'L', nr-1,nr-1, czero, czero, a(2,1), lda ) - call stdlib_zgelqf( nr,n, a, lda, cwork, cwork(n+1), lwork-n, ierr) - call stdlib_zlacpy( 'L', nr, nr, a, lda, v, ldv ) - if (nr>1) call stdlib_zlaset( 'U', nr-1,nr-1, czero, czero, v(1,2), ldv ) - call stdlib_zgeqrf( nr, nr, v, ldv, cwork(n+1), cwork(2*n+1),lwork-2*n, ierr ) + if (nr>1_${ik}$) call stdlib${ii}$_zlaset( 'L', nr-1,nr-1, czero, czero, a(2_${ik}$,1_${ik}$), lda ) + call stdlib${ii}$_zgelqf( nr,n, a, lda, cwork, cwork(n+1), lwork-n, ierr) + call stdlib${ii}$_zlacpy( 'L', nr, nr, a, lda, v, ldv ) + if (nr>1_${ik}$) call stdlib${ii}$_zlaset( 'U', nr-1,nr-1, czero, czero, v(1_${ik}$,2_${ik}$), ldv ) + call stdlib${ii}$_zgeqrf( nr, nr, v, ldv, cwork(n+1), cwork(2_${ik}$*n+1),lwork-2*n, ierr ) do p = 1, nr - call stdlib_zcopy( nr-p+1, v(p,p), ldv, v(p,p), 1 ) - call stdlib_zlacgv( nr-p+1, v(p,p), 1 ) + call stdlib${ii}$_zcopy( nr-p+1, v(p,p), ldv, v(p,p), 1_${ik}$ ) + call stdlib${ii}$_zlacgv( nr-p+1, v(p,p), 1_${ik}$ ) end do - if (nr>1) call stdlib_zlaset('U', nr-1, nr-1, czero, czero, v(1,2), ldv) - call stdlib_zgesvj( 'L', 'U','N', nr, nr, v,ldv, sva, nr, u,ldu, cwork(n+1), & + if (nr>1_${ik}$) call stdlib${ii}$_zlaset('U', nr-1, nr-1, czero, czero, v(1_${ik}$,2_${ik}$), ldv) + call stdlib${ii}$_zgesvj( 'L', 'U','N', nr, nr, v,ldv, sva, nr, u,ldu, cwork(n+1), & lwork-n, rwork, lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) if ( nr < n ) then - call stdlib_zlaset( 'A',n-nr, nr, czero,czero, v(nr+1,1), ldv ) - call stdlib_zlaset( 'A',nr, n-nr, czero,czero, v(1,nr+1), ldv ) - call stdlib_zlaset( 'A',n-nr,n-nr,czero,cone, v(nr+1,nr+1),ldv ) + call stdlib${ii}$_zlaset( 'A',n-nr, nr, czero,czero, v(nr+1,1_${ik}$), ldv ) + call stdlib${ii}$_zlaset( 'A',nr, n-nr, czero,czero, v(1_${ik}$,nr+1), ldv ) + call stdlib${ii}$_zlaset( 'A',n-nr,n-nr,czero,cone, v(nr+1,nr+1),ldv ) end if - call stdlib_zunmlq( 'L', 'C', n, n, nr, a, lda, cwork,v, ldv, cwork(n+1), lwork-n, & + call stdlib${ii}$_zunmlq( 'L', 'C', n, n, nr, a, lda, cwork,v, ldv, cwork(n+1), lwork-n, & ierr ) end if ! Permute The Rows Of V ! do 8991 p = 1, n - ! call stdlib_zcopy( n, v(p,1), ldv, a(iwork(p),1), lda ) + ! call stdlib${ii}$_zcopy( n, v(p,1), ldv, a(iwork(p),1), lda ) 8991 continue - ! call stdlib_zlacpy( 'all', n, n, a, lda, v, ldv ) - call stdlib_zlapmr( .false., n, n, v, ldv, iwork ) + ! call stdlib${ii}$_zlacpy( 'all', n, n, a, lda, v, ldv ) + call stdlib${ii}$_zlapmr( .false., n, n, v, ldv, iwork ) if ( transp ) then - call stdlib_zlacpy( 'A', n, n, v, ldv, u, ldu ) + call stdlib${ii}$_zlacpy( 'A', n, n, v, ldv, u, ldu ) end if else if ( jracc .and. (.not. lsvec) .and. ( nr== n ) ) then - if (n>1) call stdlib_zlaset( 'L', n-1,n-1, czero, czero, a(2,1), lda ) - call stdlib_zgesvj( 'U','N','V', n, n, a, lda, sva, n, v, ldv,cwork, lwork, rwork, & + if (n>1_${ik}$) call stdlib${ii}$_zlaset( 'L', n-1,n-1, czero, czero, a(2_${ik}$,1_${ik}$), lda ) + call stdlib${ii}$_zgesvj( 'U','N','V', n, n, a, lda, sva, n, v, ldv,cwork, lwork, rwork, & lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) - call stdlib_zlapmr( .false., n, n, v, ldv, iwork ) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) + call stdlib${ii}$_zlapmr( .false., n, n, v, ldv, iwork ) else if ( lsvec .and. ( .not. rsvec ) ) then ! Singular Values And Left Singular Vectors ! Second Preconditioning Step To Avoid Need To Accumulate ! jacobi rotations in the jacobi iterations. do p = 1, nr - call stdlib_zcopy( n-p+1, a(p,p), lda, u(p,p), 1 ) - call stdlib_zlacgv( n-p+1, u(p,p), 1 ) + call stdlib${ii}$_zcopy( n-p+1, a(p,p), lda, u(p,p), 1_${ik}$ ) + call stdlib${ii}$_zlacgv( n-p+1, u(p,p), 1_${ik}$ ) end do - if (nr>1) call stdlib_zlaset( 'U', nr-1, nr-1, czero, czero, u(1,2), ldu ) - call stdlib_zgeqrf( n, nr, u, ldu, cwork(n+1), cwork(2*n+1),lwork-2*n, ierr ) + if (nr>1_${ik}$) call stdlib${ii}$_zlaset( 'U', nr-1, nr-1, czero, czero, u(1_${ik}$,2_${ik}$), ldu ) + call stdlib${ii}$_zgeqrf( n, nr, u, ldu, cwork(n+1), cwork(2_${ik}$*n+1),lwork-2*n, ierr ) do p = 1, nr - 1 - call stdlib_zcopy( nr-p, u(p,p+1), ldu, u(p+1,p), 1 ) - call stdlib_zlacgv( n-p+1, u(p,p), 1 ) + call stdlib${ii}$_zcopy( nr-p, u(p,p+1), ldu, u(p+1,p), 1_${ik}$ ) + call stdlib${ii}$_zlacgv( n-p+1, u(p,p), 1_${ik}$ ) end do - if (nr>1) call stdlib_zlaset( 'U', nr-1, nr-1, czero, czero, u(1,2), ldu ) - call stdlib_zgesvj( 'L', 'U', 'N', nr,nr, u, ldu, sva, nr, a,lda, cwork(n+1), lwork-& + if (nr>1_${ik}$) call stdlib${ii}$_zlaset( 'U', nr-1, nr-1, czero, czero, u(1_${ik}$,2_${ik}$), ldu ) + call stdlib${ii}$_zgesvj( 'L', 'U', 'N', nr,nr, u, ldu, sva, nr, a,lda, cwork(n+1), lwork-& n, rwork, lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) if ( nr < m ) then - call stdlib_zlaset( 'A', m-nr, nr,czero, czero, u(nr+1,1), ldu ) + call stdlib${ii}$_zlaset( 'A', m-nr, nr,czero, czero, u(nr+1,1_${ik}$), ldu ) if ( nr < n1 ) then - call stdlib_zlaset( 'A',nr, n1-nr, czero, czero, u(1,nr+1),ldu ) - call stdlib_zlaset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1),ldu ) + call stdlib${ii}$_zlaset( 'A',nr, n1-nr, czero, czero, u(1_${ik}$,nr+1),ldu ) + call stdlib${ii}$_zlaset( 'A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1),ldu ) end if end if - call stdlib_zunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-n, & + call stdlib${ii}$_zunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-n, & ierr ) - if ( rowpiv )call stdlib_zlaswp( n1, u, ldu, 1, m-1, iwork(iwoff+1), -1 ) + if ( rowpiv )call stdlib${ii}$_zlaswp( n1, u, ldu, 1_${ik}$, m-1, iwork(iwoff+1), -1_${ik}$ ) do p = 1, n1 - xsc = one / stdlib_dznrm2( m, u(1,p), 1 ) - call stdlib_zdscal( m, xsc, u(1,p), 1 ) + xsc = one / stdlib${ii}$_dznrm2( m, u(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_zdscal( m, xsc, u(1_${ik}$,p), 1_${ik}$ ) end do if ( transp ) then - call stdlib_zlacpy( 'A', n, n, u, ldu, v, ldv ) + call stdlib${ii}$_zlacpy( 'A', n, n, u, ldu, v, ldv ) end if else ! Full Svd @@ -75774,10 +75769,10 @@ module stdlib_linalg_lapack_z ! equivalent to an lqf call. since in many libraries the qrf ! seems to be better optimized than the lqf, we do explicit ! transpose and use the qrf. this is subject to changes in an - ! optimized implementation of stdlib_zgejsv. + ! optimized implementation of stdlib${ii}$_zgejsv. do p = 1, nr - call stdlib_zcopy( n-p+1, a(p,p), lda, v(p,p), 1 ) - call stdlib_zlacgv( n-p+1, v(p,p), 1 ) + call stdlib${ii}$_zcopy( n-p+1, a(p,p), lda, v(p,p), 1_${ik}$ ) + call stdlib${ii}$_zlacgv( n-p+1, v(p,p), 1_${ik}$ ) end do ! The Following Two Loops Perturb Small Entries To Avoid ! denormals in the second qr factorization, where they are @@ -75802,17 +75797,17 @@ module stdlib_linalg_lapack_z end do end do else - if (nr>1) call stdlib_zlaset( 'U', nr-1, nr-1, czero, czero, v(1,2), ldv ) + if (nr>1_${ik}$) call stdlib${ii}$_zlaset( 'U', nr-1, nr-1, czero, czero, v(1_${ik}$,2_${ik}$), ldv ) end if ! estimate the row scaled condition number of r1 ! (if r1 is rectangular, n > nr, then the condition number ! of the leading nr x nr submatrix is estimated.) - call stdlib_zlacpy( 'L', nr, nr, v, ldv, cwork(2*n+1), nr ) + call stdlib${ii}$_zlacpy( 'L', nr, nr, v, ldv, cwork(2_${ik}$*n+1), nr ) do p = 1, nr - temp1 = stdlib_dznrm2(nr-p+1,cwork(2*n+(p-1)*nr+p),1) - call stdlib_zdscal(nr-p+1,one/temp1,cwork(2*n+(p-1)*nr+p),1) + temp1 = stdlib${ii}$_dznrm2(nr-p+1,cwork(2_${ik}$*n+(p-1)*nr+p),1_${ik}$) + call stdlib${ii}$_zdscal(nr-p+1,one/temp1,cwork(2_${ik}$*n+(p-1)*nr+p),1_${ik}$) end do - call stdlib_zpocon('L',nr,cwork(2*n+1),nr,one,temp1,cwork(2*n+nr*nr+1),rwork,& + call stdlib${ii}$_zpocon('L',nr,cwork(2_${ik}$*n+1),nr,one,temp1,cwork(2_${ik}$*n+nr*nr+1),rwork,& ierr) condr1 = one / sqrt(temp1) ! Here Need A Second Opinion On The Condition Number @@ -75826,7 +75821,7 @@ module stdlib_linalg_lapack_z ! implementation, this qrf should be implemented as the qrf ! of a lower triangular matrix. ! r1^* = q2 * r2 - call stdlib_zgeqrf( n, nr, v, ldv, cwork(n+1), cwork(2*n+1),lwork-2*n, ierr ) + call stdlib${ii}$_zgeqrf( n, nr, v, ldv, cwork(n+1), cwork(2_${ik}$*n+1),lwork-2*n, ierr ) if ( l2pert ) then xsc = sqrt(small)/epsln @@ -75838,13 +75833,13 @@ module stdlib_linalg_lapack_z end do end do end if - if ( nr /= n )call stdlib_zlacpy( 'A', n, nr, v, ldv, cwork(2*n+1), n ) + if ( nr /= n )call stdlib${ii}$_zlacpy( 'A', n, nr, v, ldv, cwork(2_${ik}$*n+1), n ) ! .. save ... ! This Transposed Copy Should Be Better Than Naive do p = 1, nr - 1 - call stdlib_zcopy( nr-p, v(p,p+1), ldv, v(p+1,p), 1 ) - call stdlib_zlacgv(nr-p+1, v(p,p), 1 ) + call stdlib${ii}$_zcopy( nr-p, v(p,p+1), ldv, v(p+1,p), 1_${ik}$ ) + call stdlib${ii}$_zlacgv(nr-p+1, v(p,p), 1_${ik}$ ) end do v(nr,nr)=conjg(v(nr,nr)) condr2 = condr1 @@ -75852,16 +75847,16 @@ module stdlib_linalg_lapack_z ! .. ill-conditioned case: second qrf with pivoting ! note that windowed pivoting would be equally good ! numerically, and more run-time efficient. so, in - ! an optimal implementation, the next call to stdlib_zgeqp3 + ! an optimal implementation, the next call to stdlib${ii}$_zgeqp3 ! should be replaced with eg. call zgeqpx (acm toms #782) ! with properly (carefully) chosen parameters. ! r1^* * p2 = q2 * r2 do p = 1, nr - iwork(n+p) = 0 + iwork(n+p) = 0_${ik}$ end do - call stdlib_zgeqp3( n, nr, v, ldv, iwork(n+1), cwork(n+1),cwork(2*n+1), lwork-& - 2*n, rwork, ierr ) - ! * call stdlib_zgeqrf( n, nr, v, ldv, cwork(n+1), cwork(2*n+1), + call stdlib${ii}$_zgeqp3( n, nr, v, ldv, iwork(n+1), cwork(n+1),cwork(2_${ik}$*n+1), lwork-& + 2_${ik}$*n, rwork, ierr ) + ! * call stdlib${ii}$_zgeqrf( n, nr, v, ldv, cwork(n+1), cwork(2*n+1), ! * $ lwork-2*n, ierr ) if ( l2pert ) then xsc = sqrt(small) @@ -75873,7 +75868,7 @@ module stdlib_linalg_lapack_z end do end do end if - call stdlib_zlacpy( 'A', n, nr, v, ldv, cwork(2*n+1), n ) + call stdlib${ii}$_zlacpy( 'A', n, nr, v, ldv, cwork(2_${ik}$*n+1), n ) if ( l2pert ) then xsc = sqrt(small) do p = 2, nr @@ -75884,18 +75879,18 @@ module stdlib_linalg_lapack_z end do end do else - if (nr>1) call stdlib_zlaset( 'L',nr-1,nr-1,czero,czero,v(2,1),ldv ) + if (nr>1_${ik}$) call stdlib${ii}$_zlaset( 'L',nr-1,nr-1,czero,czero,v(2_${ik}$,1_${ik}$),ldv ) end if ! now, compute r2 = l3 * q3, the lq factorization. - call stdlib_zgelqf( nr, nr, v, ldv, cwork(2*n+n*nr+1),cwork(2*n+n*nr+nr+1), & + call stdlib${ii}$_zgelqf( nr, nr, v, ldv, cwork(2_${ik}$*n+n*nr+1),cwork(2_${ik}$*n+n*nr+nr+1), & lwork-2*n-n*nr-nr, ierr ) ! And Estimate The Condition Number - call stdlib_zlacpy( 'L',nr,nr,v,ldv,cwork(2*n+n*nr+nr+1),nr ) + call stdlib${ii}$_zlacpy( 'L',nr,nr,v,ldv,cwork(2_${ik}$*n+n*nr+nr+1),nr ) do p = 1, nr - temp1 = stdlib_dznrm2( p, cwork(2*n+n*nr+nr+p), nr ) - call stdlib_zdscal( p, one/temp1, cwork(2*n+n*nr+nr+p), nr ) + temp1 = stdlib${ii}$_dznrm2( p, cwork(2_${ik}$*n+n*nr+nr+p), nr ) + call stdlib${ii}$_zdscal( p, one/temp1, cwork(2_${ik}$*n+n*nr+nr+p), nr ) end do - call stdlib_zpocon( 'L',nr,cwork(2*n+n*nr+nr+1),nr,one,temp1,cwork(2*n+n*nr+& + call stdlib${ii}$_zpocon( 'L',nr,cwork(2_${ik}$*n+n*nr+nr+1),nr,one,temp1,cwork(2_${ik}$*n+n*nr+& nr+nr*nr+1),rwork,ierr ) condr2 = one / sqrt(temp1) if ( condr2 >= cond_ok ) then @@ -75903,7 +75898,7 @@ module stdlib_linalg_lapack_z ! (this overwrites the copy of r2, as it will not be ! needed in this branch, but it does not overwritte the ! huseholder vectors of q2.). - call stdlib_zlacpy( 'U', nr, nr, v, ldv, cwork(2*n+1), n ) + call stdlib${ii}$_zlacpy( 'U', nr, nr, v, ldv, cwork(2_${ik}$*n+1), n ) ! And The Rest Of The Information On Q3 Is In ! work(2*n+n*nr+1:2*n+n*nr+n) end if @@ -75918,71 +75913,71 @@ module stdlib_linalg_lapack_z end do end do else - if (nr>1) call stdlib_zlaset( 'U', nr-1,nr-1, czero,czero, v(1,2), ldv ) + if (nr>1_${ik}$) call stdlib${ii}$_zlaset( 'U', nr-1,nr-1, czero,czero, v(1_${ik}$,2_${ik}$), ldv ) end if ! second preconditioning finished; continue with jacobi svd ! the input matrix is lower trinagular. ! recover the right singular vectors as solution of a well ! conditioned triangular matrix equation. if ( condr1 < cond_ok ) then - call stdlib_zgesvj( 'L','U','N',nr,nr,v,ldv,sva,nr,u, ldu,cwork(2*n+n*nr+nr+1)& + call stdlib${ii}$_zgesvj( 'L','U','N',nr,nr,v,ldv,sva,nr,u, ldu,cwork(2_${ik}$*n+n*nr+nr+1)& ,lwork-2*n-n*nr-nr,rwork,lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) do p = 1, nr - call stdlib_zcopy( nr, v(1,p), 1, u(1,p), 1 ) - call stdlib_zdscal( nr, sva(p), v(1,p), 1 ) + call stdlib${ii}$_zcopy( nr, v(1_${ik}$,p), 1_${ik}$, u(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_zdscal( nr, sva(p), v(1_${ik}$,p), 1_${ik}$ ) end do ! Pick The Right Matrix Equation And Solve It if ( nr == n ) then ! :)) .. best case, r1 is inverted. the solution of this matrix ! equation is q2*v2 = the product of the jacobi rotations - ! used in stdlib_zgesvj, premultiplied with the orthogonal matrix + ! used in stdlib${ii}$_zgesvj, premultiplied with the orthogonal matrix ! from the second qr factorization. - call stdlib_ztrsm('L','U','N','N', nr,nr,cone, a,lda, v,ldv) + call stdlib${ii}$_ztrsm('L','U','N','N', nr,nr,cone, a,lda, v,ldv) else ! .. r1 is well conditioned, but non-square. adjoint of r2 ! is inverted to get the product of the jacobi rotations - ! used in stdlib_zgesvj. the q-factor from the second qr + ! used in stdlib${ii}$_zgesvj. the q-factor from the second qr ! factorization is then built in explicitly. - call stdlib_ztrsm('L','U','C','N',nr,nr,cone,cwork(2*n+1),n,v,ldv) + call stdlib${ii}$_ztrsm('L','U','C','N',nr,nr,cone,cwork(2_${ik}$*n+1),n,v,ldv) if ( nr < n ) then - call stdlib_zlaset('A',n-nr,nr,czero,czero,v(nr+1,1),ldv) - call stdlib_zlaset('A',nr,n-nr,czero,czero,v(1,nr+1),ldv) - call stdlib_zlaset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) + call stdlib${ii}$_zlaset('A',n-nr,nr,czero,czero,v(nr+1,1_${ik}$),ldv) + call stdlib${ii}$_zlaset('A',nr,n-nr,czero,czero,v(1_${ik}$,nr+1),ldv) + call stdlib${ii}$_zlaset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) end if - call stdlib_zunmqr('L','N',n,n,nr,cwork(2*n+1),n,cwork(n+1),v,ldv,cwork(& - 2*n+n*nr+nr+1),lwork-2*n-n*nr-nr,ierr) + call stdlib${ii}$_zunmqr('L','N',n,n,nr,cwork(2_${ik}$*n+1),n,cwork(n+1),v,ldv,cwork(& + 2_${ik}$*n+n*nr+nr+1),lwork-2*n-n*nr-nr,ierr) end if else if ( condr2 < cond_ok ) then ! the matrix r2 is inverted. the solution of the matrix equation ! is q3^* * v3 = the product of the jacobi rotations (appplied to ! the lower triangular l3 from the lq factorization of ! r2=l3*q3), pre-multiplied with the transposed q3. - call stdlib_zgesvj( 'L', 'U', 'N', nr, nr, v, ldv, sva, nr, u,ldu, cwork(2*n+& + call stdlib${ii}$_zgesvj( 'L', 'U', 'N', nr, nr, v, ldv, sva, nr, u,ldu, cwork(2_${ik}$*n+& n*nr+nr+1), lwork-2*n-n*nr-nr,rwork, lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) do p = 1, nr - call stdlib_zcopy( nr, v(1,p), 1, u(1,p), 1 ) - call stdlib_zdscal( nr, sva(p), u(1,p), 1 ) + call stdlib${ii}$_zcopy( nr, v(1_${ik}$,p), 1_${ik}$, u(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_zdscal( nr, sva(p), u(1_${ik}$,p), 1_${ik}$ ) end do - call stdlib_ztrsm('L','U','N','N',nr,nr,cone,cwork(2*n+1),n,u,ldu) + call stdlib${ii}$_ztrsm('L','U','N','N',nr,nr,cone,cwork(2_${ik}$*n+1),n,u,ldu) ! Apply The Permutation From The Second Qr Factorization do q = 1, nr do p = 1, nr - cwork(2*n+n*nr+nr+iwork(n+p)) = u(p,q) + cwork(2_${ik}$*n+n*nr+nr+iwork(n+p)) = u(p,q) end do do p = 1, nr - u(p,q) = cwork(2*n+n*nr+nr+p) + u(p,q) = cwork(2_${ik}$*n+n*nr+nr+p) end do end do if ( nr < n ) then - call stdlib_zlaset( 'A',n-nr,nr,czero,czero,v(nr+1,1),ldv ) - call stdlib_zlaset( 'A',nr,n-nr,czero,czero,v(1,nr+1),ldv ) - call stdlib_zlaset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) + call stdlib${ii}$_zlaset( 'A',n-nr,nr,czero,czero,v(nr+1,1_${ik}$),ldv ) + call stdlib${ii}$_zlaset( 'A',nr,n-nr,czero,czero,v(1_${ik}$,nr+1),ldv ) + call stdlib${ii}$_zlaset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) end if - call stdlib_zunmqr( 'L','N',n,n,nr,cwork(2*n+1),n,cwork(n+1),v,ldv,cwork(2*n+& + call stdlib${ii}$_zunmqr( 'L','N',n,n,nr,cwork(2_${ik}$*n+1),n,cwork(n+1),v,ldv,cwork(2_${ik}$*n+& n*nr+nr+1),lwork-2*n-n*nr-nr,ierr ) else ! last line of defense. @@ -75993,28 +75988,28 @@ module stdlib_linalg_lapack_z ! is set very close to one (which is unnecessary). normally, ! this branch should never be executed, but in rare cases of ! failure of the rrqr or condition estimator, the last line of - ! defense ensures that stdlib_zgejsv completes the task. - ! compute the full svd of l3 using stdlib_zgesvj with explicit + ! defense ensures that stdlib${ii}$_zgejsv completes the task. + ! compute the full svd of l3 using stdlib${ii}$_zgesvj with explicit ! accumulation of jacobi rotations. - call stdlib_zgesvj( 'L', 'U', 'V', nr, nr, v, ldv, sva, nr, u,ldu, cwork(2*n+& + call stdlib${ii}$_zgesvj( 'L', 'U', 'V', nr, nr, v, ldv, sva, nr, u,ldu, cwork(2_${ik}$*n+& n*nr+nr+1), lwork-2*n-n*nr-nr,rwork, lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) if ( nr < n ) then - call stdlib_zlaset( 'A',n-nr,nr,czero,czero,v(nr+1,1),ldv ) - call stdlib_zlaset( 'A',nr,n-nr,czero,czero,v(1,nr+1),ldv ) - call stdlib_zlaset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) + call stdlib${ii}$_zlaset( 'A',n-nr,nr,czero,czero,v(nr+1,1_${ik}$),ldv ) + call stdlib${ii}$_zlaset( 'A',nr,n-nr,czero,czero,v(1_${ik}$,nr+1),ldv ) + call stdlib${ii}$_zlaset('A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv) end if - call stdlib_zunmqr( 'L','N',n,n,nr,cwork(2*n+1),n,cwork(n+1),v,ldv,cwork(2*n+& + call stdlib${ii}$_zunmqr( 'L','N',n,n,nr,cwork(2_${ik}$*n+1),n,cwork(n+1),v,ldv,cwork(2_${ik}$*n+& n*nr+nr+1),lwork-2*n-n*nr-nr,ierr ) - call stdlib_zunmlq( 'L', 'C', nr, nr, nr, cwork(2*n+1), n,cwork(2*n+n*nr+1), & - u, ldu, cwork(2*n+n*nr+nr+1),lwork-2*n-n*nr-nr, ierr ) + call stdlib${ii}$_zunmlq( 'L', 'C', nr, nr, nr, cwork(2_${ik}$*n+1), n,cwork(2_${ik}$*n+n*nr+1), & + u, ldu, cwork(2_${ik}$*n+n*nr+nr+1),lwork-2*n-n*nr-nr, ierr ) do q = 1, nr do p = 1, nr - cwork(2*n+n*nr+nr+iwork(n+p)) = u(p,q) + cwork(2_${ik}$*n+n*nr+nr+iwork(n+p)) = u(p,q) end do do p = 1, nr - u(p,q) = cwork(2*n+n*nr+nr+p) + u(p,q) = cwork(2_${ik}$*n+n*nr+nr+p) end do end do end if @@ -76024,42 +76019,42 @@ module stdlib_linalg_lapack_z temp1 = sqrt(real(n,KIND=dp)) * epsln do q = 1, n do p = 1, n - cwork(2*n+n*nr+nr+iwork(p)) = v(p,q) + cwork(2_${ik}$*n+n*nr+nr+iwork(p)) = v(p,q) end do do p = 1, n - v(p,q) = cwork(2*n+n*nr+nr+p) + v(p,q) = cwork(2_${ik}$*n+n*nr+nr+p) end do - xsc = one / stdlib_dznrm2( n, v(1,q), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_zdscal( n, xsc,& - v(1,q), 1 ) + xsc = one / stdlib${ii}$_dznrm2( n, v(1_${ik}$,q), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_zdscal( n, xsc,& + v(1_${ik}$,q), 1_${ik}$ ) end do ! at this moment, v contains the right singular vectors of a. ! next, assemble the left singular vector matrix u (m x n). if ( nr < m ) then - call stdlib_zlaset('A', m-nr, nr, czero, czero, u(nr+1,1), ldu) + call stdlib${ii}$_zlaset('A', m-nr, nr, czero, czero, u(nr+1,1_${ik}$), ldu) if ( nr < n1 ) then - call stdlib_zlaset('A',nr,n1-nr,czero,czero,u(1,nr+1),ldu) - call stdlib_zlaset('A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1),ldu) + call stdlib${ii}$_zlaset('A',nr,n1-nr,czero,czero,u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_zlaset('A',m-nr,n1-nr,czero,cone,u(nr+1,nr+1),ldu) end if end if ! the q matrix from the first qrf is built into the left singular ! matrix u. this applies to all cases. - call stdlib_zunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-& + call stdlib${ii}$_zunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-& n, ierr ) ! the columns of u are normalized. the cost is o(m*n) flops. temp1 = sqrt(real(m,KIND=dp)) * epsln do p = 1, nr - xsc = one / stdlib_dznrm2( m, u(1,p), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_zdscal( m, xsc,& - u(1,p), 1 ) + xsc = one / stdlib${ii}$_dznrm2( m, u(1_${ik}$,p), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_zdscal( m, xsc,& + u(1_${ik}$,p), 1_${ik}$ ) end do ! if the initial qrf is computed with row pivoting, the left ! singular vectors must be adjusted. - if ( rowpiv )call stdlib_zlaswp( n1, u, ldu, 1, m-1, iwork(iwoff+1), -1 ) + if ( rowpiv )call stdlib${ii}$_zlaswp( n1, u, ldu, 1_${ik}$, m-1, iwork(iwoff+1), -1_${ik}$ ) else ! The Initial Matrix A Has Almost Orthogonal Columns And ! the second qrf is not needed - call stdlib_zlacpy( 'U', n, n, a, lda, cwork(n+1), n ) + call stdlib${ii}$_zlacpy( 'U', n, n, a, lda, cwork(n+1), n ) if ( l2pert ) then xsc = sqrt(small) do p = 2, n @@ -76071,43 +76066,43 @@ module stdlib_linalg_lapack_z end do end do else - call stdlib_zlaset( 'L',n-1,n-1,czero,czero,cwork(n+2),n ) + call stdlib${ii}$_zlaset( 'L',n-1,n-1,czero,czero,cwork(n+2),n ) end if - call stdlib_zgesvj( 'U', 'U', 'N', n, n, cwork(n+1), n, sva,n, u, ldu, cwork(n+& + call stdlib${ii}$_zgesvj( 'U', 'U', 'N', n, n, cwork(n+1), n, sva,n, u, ldu, cwork(n+& n*n+1), lwork-n-n*n, rwork, lrwork,info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) do p = 1, n - call stdlib_zcopy( n, cwork(n+(p-1)*n+1), 1, u(1,p), 1 ) - call stdlib_zdscal( n, sva(p), cwork(n+(p-1)*n+1), 1 ) + call stdlib${ii}$_zcopy( n, cwork(n+(p-1)*n+1), 1_${ik}$, u(1_${ik}$,p), 1_${ik}$ ) + call stdlib${ii}$_zdscal( n, sva(p), cwork(n+(p-1)*n+1), 1_${ik}$ ) end do - call stdlib_ztrsm( 'L', 'U', 'N', 'N', n, n,cone, a, lda, cwork(n+1), n ) + call stdlib${ii}$_ztrsm( 'L', 'U', 'N', 'N', n, n,cone, a, lda, cwork(n+1), n ) do p = 1, n - call stdlib_zcopy( n, cwork(n+p), n, v(iwork(p),1), ldv ) + call stdlib${ii}$_zcopy( n, cwork(n+p), n, v(iwork(p),1_${ik}$), ldv ) end do temp1 = sqrt(real(n,KIND=dp))*epsln do p = 1, n - xsc = one / stdlib_dznrm2( n, v(1,p), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_zdscal( n, xsc,& - v(1,p), 1 ) + xsc = one / stdlib${ii}$_dznrm2( n, v(1_${ik}$,p), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_zdscal( n, xsc,& + v(1_${ik}$,p), 1_${ik}$ ) end do ! assemble the left singular vector matrix u (m x n). if ( n < m ) then - call stdlib_zlaset( 'A', m-n, n, czero, czero, u(n+1,1), ldu ) + call stdlib${ii}$_zlaset( 'A', m-n, n, czero, czero, u(n+1,1_${ik}$), ldu ) if ( n < n1 ) then - call stdlib_zlaset('A',n, n1-n, czero, czero, u(1,n+1),ldu) - call stdlib_zlaset( 'A',m-n,n1-n, czero, cone,u(n+1,n+1),ldu) + call stdlib${ii}$_zlaset('A',n, n1-n, czero, czero, u(1_${ik}$,n+1),ldu) + call stdlib${ii}$_zlaset( 'A',m-n,n1-n, czero, cone,u(n+1,n+1),ldu) end if end if - call stdlib_zunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-& + call stdlib${ii}$_zunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-& n, ierr ) temp1 = sqrt(real(m,KIND=dp))*epsln do p = 1, n1 - xsc = one / stdlib_dznrm2( m, u(1,p), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_zdscal( m, xsc,& - u(1,p), 1 ) + xsc = one / stdlib${ii}$_dznrm2( m, u(1_${ik}$,p), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_zdscal( m, xsc,& + u(1_${ik}$,p), 1_${ik}$ ) end do - if ( rowpiv )call stdlib_zlaswp( n1, u, ldu, 1, m-1, iwork(iwoff+1), -1 ) + if ( rowpiv )call stdlib${ii}$_zlaswp( n1, u, ldu, 1_${ik}$, m-1, iwork(iwoff+1), -1_${ik}$ ) end if ! end of the >> almost orthogonal case << in the full svd else @@ -76122,8 +76117,8 @@ module stdlib_linalg_lapack_z ! in presence of extreme values, e.g. when the singular values spread from ! the underflow to the overflow threshold. do p = 1, nr - call stdlib_zcopy( n-p+1, a(p,p), lda, v(p,p), 1 ) - call stdlib_zlacgv( n-p+1, v(p,p), 1 ) + call stdlib${ii}$_zcopy( n-p+1, a(p,p), lda, v(p,p), 1_${ik}$ ) + call stdlib${ii}$_zlacgv( n-p+1, v(p,p), 1_${ik}$ ) end do if ( l2pert ) then xsc = sqrt(small/epsln) @@ -76137,14 +76132,14 @@ module stdlib_linalg_lapack_z end do end do else - if (nr>1) call stdlib_zlaset( 'U', nr-1, nr-1, czero, czero, v(1,2), ldv ) + if (nr>1_${ik}$) call stdlib${ii}$_zlaset( 'U', nr-1, nr-1, czero, czero, v(1_${ik}$,2_${ik}$), ldv ) end if - call stdlib_zgeqrf( n, nr, v, ldv, cwork(n+1), cwork(2*n+1),lwork-2*n, ierr ) + call stdlib${ii}$_zgeqrf( n, nr, v, ldv, cwork(n+1), cwork(2_${ik}$*n+1),lwork-2*n, ierr ) - call stdlib_zlacpy( 'L', n, nr, v, ldv, cwork(2*n+1), n ) + call stdlib${ii}$_zlacpy( 'L', n, nr, v, ldv, cwork(2_${ik}$*n+1), n ) do p = 1, nr - call stdlib_zcopy( nr-p+1, v(p,p), ldv, u(p,p), 1 ) - call stdlib_zlacgv( nr-p+1, u(p,p), 1 ) + call stdlib${ii}$_zcopy( nr-p+1, v(p,p), ldv, u(p,p), 1_${ik}$ ) + call stdlib${ii}$_zlacgv( nr-p+1, u(p,p), 1_${ik}$ ) end do if ( l2pert ) then xsc = sqrt(small/epsln) @@ -76156,18 +76151,18 @@ module stdlib_linalg_lapack_z end do end do else - if (nr>1) call stdlib_zlaset('U', nr-1, nr-1, czero, czero, u(1,2), ldu ) + if (nr>1_${ik}$) call stdlib${ii}$_zlaset('U', nr-1, nr-1, czero, czero, u(1_${ik}$,2_${ik}$), ldu ) end if - call stdlib_zgesvj( 'L', 'U', 'V', nr, nr, u, ldu, sva,n, v, ldv, cwork(2*n+n*nr+1),& + call stdlib${ii}$_zgesvj( 'L', 'U', 'V', nr, nr, u, ldu, sva,n, v, ldv, cwork(2_${ik}$*n+n*nr+1),& lwork-2*n-n*nr,rwork, lrwork, info ) - scalem = rwork(1) - numrank = nint(rwork(2),KIND=ilp) + scalem = rwork(1_${ik}$) + numrank = nint(rwork(2_${ik}$),KIND=${ik}$) if ( nr < n ) then - call stdlib_zlaset( 'A',n-nr,nr,czero,czero,v(nr+1,1),ldv ) - call stdlib_zlaset( 'A',nr,n-nr,czero,czero,v(1,nr+1),ldv ) - call stdlib_zlaset( 'A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv ) + call stdlib${ii}$_zlaset( 'A',n-nr,nr,czero,czero,v(nr+1,1_${ik}$),ldv ) + call stdlib${ii}$_zlaset( 'A',nr,n-nr,czero,czero,v(1_${ik}$,nr+1),ldv ) + call stdlib${ii}$_zlaset( 'A',n-nr,n-nr,czero,cone,v(nr+1,nr+1),ldv ) end if - call stdlib_zunmqr( 'L','N',n,n,nr,cwork(2*n+1),n,cwork(n+1),v,ldv,cwork(2*n+n*nr+& + call stdlib${ii}$_zunmqr( 'L','N',n,n,nr,cwork(2_${ik}$*n+1),n,cwork(n+1),v,ldv,cwork(2_${ik}$*n+n*nr+& nr+1),lwork-2*n-n*nr-nr,ierr ) ! permute the rows of v using the (column) permutation from the ! first qrf. also, scale the columns to make them unit in @@ -76175,39 +76170,39 @@ module stdlib_linalg_lapack_z temp1 = sqrt(real(n,KIND=dp)) * epsln do q = 1, n do p = 1, n - cwork(2*n+n*nr+nr+iwork(p)) = v(p,q) + cwork(2_${ik}$*n+n*nr+nr+iwork(p)) = v(p,q) end do do p = 1, n - v(p,q) = cwork(2*n+n*nr+nr+p) + v(p,q) = cwork(2_${ik}$*n+n*nr+nr+p) end do - xsc = one / stdlib_dznrm2( n, v(1,q), 1 ) - if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib_zdscal( n, xsc,& - v(1,q), 1 ) + xsc = one / stdlib${ii}$_dznrm2( n, v(1_${ik}$,q), 1_${ik}$ ) + if ( (xsc < (one-temp1)) .or. (xsc > (one+temp1)) )call stdlib${ii}$_zdscal( n, xsc,& + v(1_${ik}$,q), 1_${ik}$ ) end do ! at this moment, v contains the right singular vectors of a. ! next, assemble the left singular vector matrix u (m x n). if ( nr < m ) then - call stdlib_zlaset( 'A', m-nr, nr, czero, czero, u(nr+1,1), ldu ) + call stdlib${ii}$_zlaset( 'A', m-nr, nr, czero, czero, u(nr+1,1_${ik}$), ldu ) if ( nr < n1 ) then - call stdlib_zlaset('A',nr, n1-nr, czero, czero, u(1,nr+1),ldu) - call stdlib_zlaset('A',m-nr,n1-nr, czero, cone,u(nr+1,nr+1),ldu) + call stdlib${ii}$_zlaset('A',nr, n1-nr, czero, czero, u(1_${ik}$,nr+1),ldu) + call stdlib${ii}$_zlaset('A',m-nr,n1-nr, czero, cone,u(nr+1,nr+1),ldu) end if end if - call stdlib_zunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-n, & + call stdlib${ii}$_zunmqr( 'L', 'N', m, n1, n, a, lda, cwork, u,ldu, cwork(n+1), lwork-n, & ierr ) - if ( rowpiv )call stdlib_zlaswp( n1, u, ldu, 1, m-1, iwork(iwoff+1), -1 ) + if ( rowpiv )call stdlib${ii}$_zlaswp( n1, u, ldu, 1_${ik}$, m-1, iwork(iwoff+1), -1_${ik}$ ) end if if ( transp ) then ! .. swap u and v because the procedure worked on a^* do p = 1, n - call stdlib_zswap( n, u(1,p), 1, v(1,p), 1 ) + call stdlib${ii}$_zswap( n, u(1_${ik}$,p), 1_${ik}$, v(1_${ik}$,p), 1_${ik}$ ) end do end if end if ! end of the full svd ! undo scaling, if necessary (and possible) - if ( uscal2 <= (big/sva(1))*uscal1 ) then - call stdlib_dlascl( 'G', 0, 0, uscal1, uscal2, nr, 1, sva, n, ierr ) + if ( uscal2 <= (big/sva(1_${ik}$))*uscal1 ) then + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, uscal1, uscal2, nr, 1_${ik}$, sva, n, ierr ) uscal1 = one uscal2 = one end if @@ -76216,30 +76211,30 @@ module stdlib_linalg_lapack_z sva(p) = zero end do end if - rwork(1) = uscal2 * scalem - rwork(2) = uscal1 - if ( errest ) rwork(3) = sconda + rwork(1_${ik}$) = uscal2 * scalem + rwork(2_${ik}$) = uscal1 + if ( errest ) rwork(3_${ik}$) = sconda if ( lsvec .and. rsvec ) then - rwork(4) = condr1 - rwork(5) = condr2 + rwork(4_${ik}$) = condr1 + rwork(5_${ik}$) = condr2 end if if ( l2tran ) then - rwork(6) = entra - rwork(7) = entrat + rwork(6_${ik}$) = entra + rwork(7_${ik}$) = entrat end if - iwork(1) = nr - iwork(2) = numrank - iwork(3) = warning + iwork(1_${ik}$) = nr + iwork(2_${ik}$) = numrank + iwork(3_${ik}$) = warning if ( transp ) then - iwork(4) = 1 + iwork(4_${ik}$) = 1_${ik}$ else - iwork(4) = -1 + iwork(4_${ik}$) = -1_${ik}$ end if return - end subroutine stdlib_zgejsv + end subroutine stdlib${ii}$_zgejsv - pure subroutine stdlib_zgesvj( joba, jobu, jobv, m, n, a, lda, sva, mv, v,ldv, cwork, lwork, & + pure subroutine stdlib${ii}$_zgesvj( joba, jobu, jobv, m, n, a, lda, sva, mv, v,ldv, cwork, lwork, & !! ZGESVJ computes the singular value decomposition (SVD) of a complex !! M-by-N matrix A, where M >= N. The SVD of A is written as !! [++] [xx] [x0] [xx] @@ -76254,8 +76249,8 @@ module stdlib_linalg_lapack_z ! -- 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, ldv, lwork, lrwork, m, mv, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldv, lwork, lrwork, m, mv, n character, intent(in) :: joba, jobu, jobv ! Array Arguments complex(dp), intent(inout) :: a(lda,*), v(ldv,*), cwork(lwork) @@ -76263,7 +76258,7 @@ module stdlib_linalg_lapack_z real(dp), intent(out) :: sva(n) ! ===================================================================== ! Local Parameters - integer(ilp), parameter :: nsweep = 30 + integer(${ik}$), parameter :: nsweep = 30_${ik}$ @@ -76272,7 +76267,7 @@ module stdlib_linalg_lapack_z real(dp) :: aapp, aapp0, aapq1, aaqq, apoaq, aqoap, big, bigtheta, cs, ctol, epsln, & mxaapq, mxsinj, rootbig, rooteps, rootsfmin, roottol, skl, sfmin, small, sn, t, temp1, & theta, thsign, tol - integer(ilp) :: blskip, emptsw, i, ibr, ierr, igl, ijblsk, ir1, iswrot, jbc, jgl, kbl, & + integer(${ik}$) :: blskip, emptsw, i, ibr, ierr, igl, ijblsk, ir1, iswrot, jbc, jgl, kbl, & lkahead, mvl, n2, n34, n4, nbl, notrot, p, pskipped, q, rowskip, swband logical(lk) :: applv, goscale, lower, lquery, lsvec, noscale, rotok, rsvec, uctol, & upper @@ -76288,39 +76283,39 @@ module stdlib_linalg_lapack_z applv = stdlib_lsame( jobv, 'A' ) upper = stdlib_lsame( joba, 'U' ) lower = stdlib_lsame( joba, 'L' ) - lquery = ( lwork == -1 ) .or. ( lrwork == -1 ) + lquery = ( lwork == -1_${ik}$ ) .or. ( lrwork == -1_${ik}$ ) if( .not.( upper .or. lower .or. stdlib_lsame( joba, 'G' ) ) ) then - info = -1 + info = -1_${ik}$ else if( .not.( lsvec .or. uctol .or. stdlib_lsame( jobu, 'N' ) ) ) then - info = -2 + info = -2_${ik}$ else if( .not.( rsvec .or. applv .or. stdlib_lsame( jobv, 'N' ) ) ) then - info = -3 - else if( m<0 ) then - info = -4 - else if( ( n<0 ) .or. ( n>m ) ) then - info = -5 + info = -3_${ik}$ + else if( m<0_${ik}$ ) then + info = -4_${ik}$ + else if( ( n<0_${ik}$ ) .or. ( n>m ) ) then + info = -5_${ik}$ else if( lda=one ) then - info = -4 - call stdlib_xerbla( 'ZGESVJ', -info ) + info = -4_${ik}$ + call stdlib${ii}$_xerbla( 'ZGESVJ', -info ) return end if ! initialize the right singular vector matrix. if( rsvec ) then mvl = n - call stdlib_zlaset( 'A', mvl, n, czero, cone, v, ldv ) + call stdlib${ii}$_zlaset( 'A', mvl, n, czero, cone, v, ldv ) else if( applv ) then mvl = mv end if @@ -76383,10 +76378,10 @@ module stdlib_linalg_lapack_z do p = 1, n aapp = zero aaqq = one - call stdlib_zlassq( m-p+1, a( p, p ), 1, aapp, aaqq ) + call stdlib${ii}$_zlassq( m-p+1, a( p, p ), 1_${ik}$, aapp, aaqq ) if( aapp>big ) then - info = -6 - call stdlib_xerbla( 'ZGESVJ', -info ) + info = -6_${ik}$ + call stdlib${ii}$_xerbla( 'ZGESVJ', -info ) return end if aaqq = sqrt( aaqq ) @@ -76408,10 +76403,10 @@ module stdlib_linalg_lapack_z do p = 1, n aapp = zero aaqq = one - call stdlib_zlassq( p, a( 1, p ), 1, aapp, aaqq ) + call stdlib${ii}$_zlassq( p, a( 1_${ik}$, p ), 1_${ik}$, aapp, aaqq ) if( aapp>big ) then - info = -6 - call stdlib_xerbla( 'ZGESVJ', -info ) + info = -6_${ik}$ + call stdlib${ii}$_xerbla( 'ZGESVJ', -info ) return end if aaqq = sqrt( aaqq ) @@ -76433,10 +76428,10 @@ module stdlib_linalg_lapack_z do p = 1, n aapp = zero aaqq = one - call stdlib_zlassq( m, a( 1, p ), 1, aapp, aaqq ) + call stdlib${ii}$_zlassq( m, a( 1_${ik}$, p ), 1_${ik}$, aapp, aaqq ) if( aapp>big ) then - info = -6 - call stdlib_xerbla( 'ZGESVJ', -info ) + info = -6_${ik}$ + call stdlib${ii}$_xerbla( 'ZGESVJ', -info ) return end if aaqq = sqrt( aaqq ) @@ -76466,29 +76461,29 @@ module stdlib_linalg_lapack_z end do ! #:) quick return for zero matrix if( aapp==zero ) then - if( lsvec )call stdlib_zlaset( 'G', m, n, czero, cone, a, lda ) - rwork( 1 ) = one - rwork( 2 ) = zero - rwork( 3 ) = zero - rwork( 4 ) = zero - rwork( 5 ) = zero - rwork( 6 ) = zero + if( lsvec )call stdlib${ii}$_zlaset( 'G', m, n, czero, cone, a, lda ) + rwork( 1_${ik}$ ) = one + rwork( 2_${ik}$ ) = zero + rwork( 3_${ik}$ ) = zero + rwork( 4_${ik}$ ) = zero + rwork( 5_${ik}$ ) = zero + rwork( 6_${ik}$ ) = zero return end if ! #:) quick return for one-column matrix - if( n==1 ) then - if( lsvec )call stdlib_zlascl( 'G', 0, 0, sva( 1 ), skl, m, 1,a( 1, 1 ), lda, ierr ) + if( n==1_${ik}$ ) then + if( lsvec )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, sva( 1_${ik}$ ), skl, m, 1_${ik}$,a( 1_${ik}$, 1_${ik}$ ), lda, ierr ) - rwork( 1 ) = one / skl - if( sva( 1 )>=sfmin ) then - rwork( 2 ) = one + rwork( 1_${ik}$ ) = one / skl + if( sva( 1_${ik}$ )>=sfmin ) then + rwork( 2_${ik}$ ) = one else - rwork( 2 ) = zero + rwork( 2_${ik}$ ) = zero end if - rwork( 3 ) = zero - rwork( 4 ) = zero - rwork( 5 ) = zero - rwork( 6 ) = zero + rwork( 3_${ik}$ ) = zero + rwork( 4_${ik}$ ) = zero + rwork( 5_${ik}$ ) = zero + rwork( 6_${ik}$ ) = zero return end if ! protect small singular values from underflow, and try to @@ -76517,53 +76512,53 @@ module stdlib_linalg_lapack_z end if ! scale, if necessary if( temp1/=one ) then - call stdlib_dlascl( 'G', 0, 0, one, temp1, n, 1, sva, n, ierr ) + call stdlib${ii}$_dlascl( 'G', 0_${ik}$, 0_${ik}$, one, temp1, n, 1_${ik}$, sva, n, ierr ) end if skl = temp1*skl if( skl/=one ) then - call stdlib_zlascl( joba, 0, 0, one, skl, m, n, a, lda, ierr ) + call stdlib${ii}$_zlascl( joba, 0_${ik}$, 0_${ik}$, one, skl, m, n, a, lda, ierr ) skl = one / skl end if ! row-cyclic jacobi svd algorithm with column pivoting - emptsw = ( n*( n-1 ) ) / 2 - notrot = 0 + emptsw = ( n*( n-1 ) ) / 2_${ik}$ + notrot = 0_${ik}$ do q = 1, n cwork( q ) = cone end do - swband = 3 + swband = 3_${ik}$ ! [tp] swband is a tuning parameter [tp]. it is meaningful and effective - ! if stdlib_zgesvj is used as a computational routine in the preconditioned - ! jacobi svd algorithm stdlib_zgejsv. for sweeps i=1:swband the procedure + ! if stdlib${ii}$_zgesvj is used as a computational routine in the preconditioned + ! jacobi svd algorithm stdlib${ii}$_zgejsv. for sweeps i=1:swband the procedure ! works on pivots inside a band-like region around the diagonal. ! the boundaries are determined dynamically, based on the number of ! pivots above a threshold. - kbl = min( 8, n ) + kbl = min( 8_${ik}$, n ) ! [tp] kbl is a tuning parameter that defines the tile size in the ! tiling of the p-q loops of pivot pairs. in general, an optimal ! value of kbl depends on the matrix dimensions and on the ! parameters of the computer's memory. nbl = n / kbl - if( ( nbl*kbl )/=n )nbl = nbl + 1 - blskip = kbl**2 + if( ( nbl*kbl )/=n )nbl = nbl + 1_${ik}$ + blskip = kbl**2_${ik}$ ! [tp] blkskip is a tuning parameter that depends on swband and kbl. - rowskip = min( 5, kbl ) + rowskip = min( 5_${ik}$, kbl ) ! [tp] rowskip is a tuning parameter. - lkahead = 1 + lkahead = 1_${ik}$ ! [tp] lkahead is a tuning parameter. ! quasi block transformations, using the lower (upper) triangular ! structure of the input matrix. the quasi-block-cycling usually ! invokes cubic convergence. big part of this cycle is done inside ! canonical subspaces of dimensions less than m. - if( ( lower .or. upper ) .and. ( n>max( 64, 4*kbl ) ) ) then + if( ( lower .or. upper ) .and. ( n>max( 64_${ik}$, 4_${ik}$*kbl ) ) ) then ! [tp] the number of partition levels and the actual partition are ! tuning parameters. - n4 = n / 4 - n2 = n / 2 - n34 = 3*n4 + n4 = n / 4_${ik}$ + n2 = n / 2_${ik}$ + n34 = 3_${ik}$*n4 if( applv ) then - q = 0 + q = 0_${ik}$ else - q = 1 + q = 1_${ik}$ end if if( lower ) then ! this works very well on lower triangular matrices, in particular @@ -76573,32 +76568,32 @@ module stdlib_linalg_lapack_z ! [+ + 0 0] [0 0] ! [+ + x 0] actually work on [x 0] [x 0] ! [+ + x x] [x x]. [x x] - call stdlib_zgsvj0( jobv, m-n34, n-n34, a( n34+1, n34+1 ), lda,cwork( n34+1 ), & - sva( n34+1 ), mvl,v( n34*q+1, n34+1 ), ldv, epsln, sfmin, tol,2, cwork( n+1 ), & + call stdlib${ii}$_zgsvj0( jobv, m-n34, n-n34, a( n34+1, n34+1 ), lda,cwork( n34+1 ), & + sva( n34+1 ), mvl,v( n34*q+1, n34+1 ), ldv, epsln, sfmin, tol,2_${ik}$, cwork( n+1 ), & lwork-n, ierr ) - call stdlib_zgsvj0( jobv, m-n2, n34-n2, a( n2+1, n2+1 ), lda,cwork( n2+1 ), sva( & - n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 2,cwork( n+1 ), lwork-n, & + call stdlib${ii}$_zgsvj0( jobv, m-n2, n34-n2, a( n2+1, n2+1 ), lda,cwork( n2+1 ), sva( & + n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 2_${ik}$,cwork( n+1 ), lwork-n, & ierr ) - call stdlib_zgsvj1( jobv, m-n2, n-n2, n4, a( n2+1, n2+1 ), lda,cwork( n2+1 ), & - sva( n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1,cwork( n+1 ), & + call stdlib${ii}$_zgsvj1( jobv, m-n2, n-n2, n4, a( n2+1, n2+1 ), lda,cwork( n2+1 ), & + sva( n2+1 ), mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1_${ik}$,cwork( n+1 ), & lwork-n, ierr ) - call stdlib_zgsvj0( jobv, m-n4, n2-n4, a( n4+1, n4+1 ), lda,cwork( n4+1 ), sva( & - n4+1 ), mvl,v( n4*q+1, n4+1 ), ldv, epsln, sfmin, tol, 1,cwork( n+1 ), lwork-n, & + call stdlib${ii}$_zgsvj0( jobv, m-n4, n2-n4, a( n4+1, n4+1 ), lda,cwork( n4+1 ), sva( & + n4+1 ), mvl,v( n4*q+1, n4+1 ), ldv, epsln, sfmin, tol, 1_${ik}$,cwork( n+1 ), lwork-n, & ierr ) - call stdlib_zgsvj0( jobv, m, n4, a, lda, cwork, sva, mvl, v, ldv,epsln, sfmin, & - tol, 1, cwork( n+1 ), lwork-n,ierr ) - call stdlib_zgsvj1( jobv, m, n2, n4, a, lda, cwork, sva, mvl, v,ldv, epsln, & - sfmin, tol, 1, cwork( n+1 ),lwork-n, ierr ) + call stdlib${ii}$_zgsvj0( jobv, m, n4, a, lda, cwork, sva, mvl, v, ldv,epsln, sfmin, & + tol, 1_${ik}$, cwork( n+1 ), lwork-n,ierr ) + call stdlib${ii}$_zgsvj1( jobv, m, n2, n4, a, lda, cwork, sva, mvl, v,ldv, epsln, & + sfmin, tol, 1_${ik}$, cwork( n+1 ),lwork-n, ierr ) else if( upper ) then - call stdlib_zgsvj0( jobv, n4, n4, a, lda, cwork, sva, mvl, v, ldv,epsln, sfmin, & - tol, 2, cwork( n+1 ), lwork-n,ierr ) - call stdlib_zgsvj0( jobv, n2, n4, a( 1, n4+1 ), lda, cwork( n4+1 ),sva( n4+1 ), & - mvl, v( n4*q+1, n4+1 ), ldv,epsln, sfmin, tol, 1, cwork( n+1 ), lwork-n,ierr ) + call stdlib${ii}$_zgsvj0( jobv, n4, n4, a, lda, cwork, sva, mvl, v, ldv,epsln, sfmin, & + tol, 2_${ik}$, cwork( n+1 ), lwork-n,ierr ) + call stdlib${ii}$_zgsvj0( jobv, n2, n4, a( 1_${ik}$, n4+1 ), lda, cwork( n4+1 ),sva( n4+1 ), & + mvl, v( n4*q+1, n4+1 ), ldv,epsln, sfmin, tol, 1_${ik}$, cwork( n+1 ), lwork-n,ierr ) - call stdlib_zgsvj1( jobv, n2, n2, n4, a, lda, cwork, sva, mvl, v,ldv, epsln, & - sfmin, tol, 1, cwork( n+1 ),lwork-n, ierr ) - call stdlib_zgsvj0( jobv, n2+n4, n4, a( 1, n2+1 ), lda,cwork( n2+1 ), sva( n2+1 )& - , mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1,cwork( n+1 ), lwork-n, ierr ) + call stdlib${ii}$_zgsvj1( jobv, n2, n2, n4, a, lda, cwork, sva, mvl, v,ldv, epsln, & + sfmin, tol, 1_${ik}$, cwork( n+1 ),lwork-n, ierr ) + call stdlib${ii}$_zgsvj0( jobv, n2+n4, n4, a( 1_${ik}$, n2+1 ), lda,cwork( n2+1 ), sva( n2+1 )& + , mvl,v( n2*q+1, n2+1 ), ldv, epsln, sfmin, tol, 1_${ik}$,cwork( n+1 ), lwork-n, ierr ) end if end if @@ -76607,23 +76602,23 @@ module stdlib_linalg_lapack_z ! .. go go go ... mxaapq = zero mxsinj = zero - iswrot = 0 - notrot = 0 - pskipped = 0 + iswrot = 0_${ik}$ + notrot = 0_${ik}$ + pskipped = 0_${ik}$ ! each sweep is unrolled using kbl-by-kbl tiles over the pivot pairs ! 1 <= p < q <= n. this is the first step toward a blocked implementation ! of the rotations. new implementation, based on block transformations, ! is under development. loop_2000: do ibr = 1, nbl - igl = ( ibr-1 )*kbl + 1 + igl = ( ibr-1 )*kbl + 1_${ik}$ loop_1002: do ir1 = 0, min( lkahead, nbl-ibr ) igl = igl + ir1*kbl loop_2001: do p = igl, min( igl+kbl-1, n-1 ) ! .. de rijk's pivoting - q = stdlib_idamax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib${ii}$_idamax( n-p+1, sva( p ), 1_${ik}$ ) + p - 1_${ik}$ if( p/=q ) then - call stdlib_zswap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_zswap( mvl, v( 1, p ), 1,v( 1, q ), 1 ) + call stdlib${ii}$_zswap( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) + if( rsvec )call stdlib${ii}$_zswap( mvl, v( 1_${ik}$, p ), 1_${ik}$,v( 1_${ik}$, q ), 1_${ik}$ ) temp1 = sva( p ) sva( p ) = sva( q ) sva( q ) = temp1 @@ -76631,24 +76626,24 @@ module stdlib_linalg_lapack_z cwork(p) = cwork(q) cwork(q) = aapq end if - if( ir1==0 ) then + if( ir1==0_${ik}$ ) then ! column norms are periodically updated by explicit ! norm computation. ! [!] caveat: - ! unfortunately, some blas implementations compute stdlib_dznrm2(m,a(1,p),1) - ! as sqrt(s=stdlib_cdotc(m,a(1,p),1,a(1,p),1)), which may cause the result to + ! unfortunately, some blas implementations compute stdlib${ii}$_dznrm2(m,a(1,p),1) + ! as sqrt(s=stdlib${ii}$_cdotc(m,a(1,p),1,a(1,p),1)), which may cause the result to ! overflow for ||a(:,p)||_2 > sqrt(overflow_threshold), and to ! underflow for ||a(:,p)||_2 < sqrt(underflow_threshold). - ! hence, stdlib_dznrm2 cannot be trusted, not even in the case when + ! hence, stdlib${ii}$_dznrm2 cannot be trusted, not even in the case when ! the true norm is far from the under(over)flow boundaries. - ! if properly implemented stdlib_scnrm2 is available, the if-then-else-end if - ! below should be replaced with "aapp = stdlib_dznrm2( m, a(1,p), 1 )". + ! if properly implemented stdlib${ii}$_scnrm2 is available, the if-then-else-end if + ! below should be replaced with "aapp = stdlib${ii}$_dznrm2( m, a(1,p), 1 )". if( ( sva( p )rootsfmin ) ) then - sva( p ) = stdlib_dznrm2( m, a( 1, p ), 1 ) + sva( p ) = stdlib${ii}$_dznrm2( m, a( 1_${ik}$, p ), 1_${ik}$ ) else temp1 = zero aapp = one - call stdlib_zlassq( m, a( 1, p ), 1, temp1, aapp ) + call stdlib${ii}$_zlassq( m, a( 1_${ik}$, p ), 1_${ik}$, temp1, aapp ) sva( p ) = temp1*sqrt( aapp ) end if aapp = sva( p ) @@ -76656,7 +76651,7 @@ module stdlib_linalg_lapack_z aapp = sva( p ) end if if( aapp>zero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2002: do q = p + 1, min( igl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -76664,25 +76659,25 @@ module stdlib_linalg_lapack_z if( aaqq>=one ) then rotok = ( small*aapp )<=aaqq if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_zdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib${ii}$_zdotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq ) / aapp else - call stdlib_zcopy( m, a( 1, p ), 1,cwork(n+1), 1 ) - call stdlib_zlascl( 'G', 0, 0, aapp, one,m, 1, cwork(n+1), & + call stdlib${ii}$_zcopy( m, a( 1_${ik}$, p ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, cwork(n+1), & lda, ierr ) - aapq = stdlib_zdotc( m, cwork(n+1), 1,a( 1, q ), 1 ) / & + aapq = stdlib${ii}$_zdotc( m, cwork(n+1), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq end if else rotok = aapp<=( aaqq / small ) if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_zdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib${ii}$_zdotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aapp ) / aaqq else - call stdlib_zcopy( m, a( 1, q ), 1,cwork(n+1), 1 ) - call stdlib_zlascl( 'G', 0, 0, aaqq,one, m, 1,cwork(n+1), & + call stdlib${ii}$_zcopy( m, a( 1_${ik}$, q ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq,one, m, 1_${ik}$,cwork(n+1), & lda, ierr ) - aapq = stdlib_zdotc( m, a(1, p ), 1,cwork(n+1), 1 ) / & + aapq = stdlib${ii}$_zdotc( m, a(1_${ik}$, p ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) / & aapp end if end if @@ -76694,10 +76689,10 @@ module stdlib_linalg_lapack_z ompq = aapq / abs(aapq) ! Rotate ! [rtd] rotated = rotated + one - if( ir1==0 ) then - notrot = 0 - pskipped = 0 - iswrot = iswrot + 1 + if( ir1==0_${ik}$ ) then + notrot = 0_${ik}$ + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ end if if( rotok ) then aqoap = aaqq / aapp @@ -76706,10 +76701,10 @@ module stdlib_linalg_lapack_z if( abs( theta )>bigtheta ) then t = half / theta cs = one - call stdlib_zrot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_zrot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *t ) if ( rsvec ) then - call stdlib_zrot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_zrot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*t ) end if sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) @@ -76727,24 +76722,24 @@ module stdlib_linalg_lapack_z sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq1 ) ) - call stdlib_zrot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_zrot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *sn ) if ( rsvec ) then - call stdlib_zrot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_zrot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*sn ) end if end if cwork(p) = -cwork(q) * ompq else ! .. have to use modified gram-schmidt like transformation - call stdlib_zcopy( m, a( 1, p ), 1,cwork(n+1), 1 ) - call stdlib_zlascl( 'G', 0, 0, aapp, one, m,1, cwork(n+1), & + call stdlib${ii}$_zcopy( m, a( 1_${ik}$, p ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one, m,1_${ik}$, cwork(n+1), & lda,ierr ) - call stdlib_zlascl( 'G', 0, 0, aaqq, one, m,1, a( 1, q ), & + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one, m,1_${ik}$, a( 1_${ik}$, q ), & lda, ierr ) - call stdlib_zaxpy( m, -aapq, cwork(n+1), 1,a( 1, q ), 1 ) + call stdlib${ii}$_zaxpy( m, -aapq, cwork(n+1), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) - call stdlib_zlascl( 'G', 0, 0, one, aaqq, m,1, a( 1, q ), & + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq, m,1_${ik}$, a( 1_${ik}$, q ), & lda, ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq1*aapq1 ) ) mxsinj = max( mxsinj, sfmin ) @@ -76752,41 +76747,41 @@ module stdlib_linalg_lapack_z ! end if rotok then ... else ! in the case of cancellation in updating sva(q), sva(p) ! recompute sva(q), sva(p). - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_dznrm2( m, a( 1, q ), 1 ) + sva( q ) = stdlib${ii}$_dznrm2( m, a( 1_${ik}$, q ), 1_${ik}$ ) else t = zero aaqq = one - call stdlib_zlassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_zlassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq ) end if end if if( ( aapp / aapp0 )<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_dznrm2( m, a( 1, p ), 1 ) + aapp = stdlib${ii}$_dznrm2( m, a( 1_${ik}$, p ), 1_${ik}$ ) else t = zero aapp = one - call stdlib_zlassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_zlassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp ) end if sva( p ) = aapp end if else ! a(:,p) and a(:,q) already numerically orthogonal - if( ir1==0 )notrot = notrot + 1 + if( ir1==0_${ik}$ )notrot = notrot + 1_${ik}$ ! [rtd] skipped = skipped + 1 - pskipped = pskipped + 1 + pskipped = pskipped + 1_${ik}$ end if else ! a(:,q) is zero column - if( ir1==0 )notrot = notrot + 1 - pskipped = pskipped + 1 + if( ir1==0_${ik}$ )notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then - if( ir1==0 )aapp = -aapp - notrot = 0 + if( ir1==0_${ik}$ )aapp = -aapp + notrot = 0_${ik}$ go to 2103 end if end do loop_2002 @@ -76796,7 +76791,7 @@ module stdlib_linalg_lapack_z sva( p ) = aapp else sva( p ) = aapp - if( ( ir1==0 ) .and. ( aapp==zero ) )notrot = notrot + min( igl+kbl-1, & + if( ( ir1==0_${ik}$ ) .and. ( aapp==zero ) )notrot = notrot + min( igl+kbl-1, & n ) - p end if end do loop_2001 @@ -76805,15 +76800,15 @@ module stdlib_linalg_lapack_z end do loop_1002 ! end of ir1-loop ! ... go to the off diagonal blocks - igl = ( ibr-1 )*kbl + 1 + igl = ( ibr-1 )*kbl + 1_${ik}$ loop_2010: do jbc = ibr + 1, nbl - jgl = ( jbc-1 )*kbl + 1 + jgl = ( jbc-1 )*kbl + 1_${ik}$ ! doing the block at ( ibr, jbc ) - ijblsk = 0 + ijblsk = 0_${ik}$ loop_2100: do p = igl, min( igl+kbl-1, n ) aapp = sva( p ) if( aapp>zero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2200: do q = jgl, min( jgl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -76827,13 +76822,13 @@ module stdlib_linalg_lapack_z rotok = ( small*aaqq )<=aapp end if if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_zdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib${ii}$_zdotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq ) / aapp else - call stdlib_zcopy( m, a( 1, p ), 1,cwork(n+1), 1 ) - call stdlib_zlascl( 'G', 0, 0, aapp,one, m, 1,cwork(n+1), & + call stdlib${ii}$_zcopy( m, a( 1_${ik}$, p ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aapp,one, m, 1_${ik}$,cwork(n+1), & lda, ierr ) - aapq = stdlib_zdotc( m, cwork(n+1), 1,a( 1, q ), 1 ) / & + aapq = stdlib${ii}$_zdotc( m, cwork(n+1), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq end if else @@ -76843,13 +76838,13 @@ module stdlib_linalg_lapack_z rotok = aaqq<=( aapp / small ) end if if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_zdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / max(& + aapq = ( stdlib${ii}$_zdotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / max(& aaqq,aapp) )/ min(aaqq,aapp) else - call stdlib_zcopy( m, a( 1, q ), 1,cwork(n+1), 1 ) - call stdlib_zlascl( 'G', 0, 0, aaqq,one, m, 1,cwork(n+1), & + call stdlib${ii}$_zcopy( m, a( 1_${ik}$, q ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq,one, m, 1_${ik}$,cwork(n+1), & lda, ierr ) - aapq = stdlib_zdotc( m, a( 1, p ), 1,cwork(n+1), 1 ) / & + aapq = stdlib${ii}$_zdotc( m, a( 1_${ik}$, p ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) / & aapp end if end if @@ -76859,10 +76854,10 @@ module stdlib_linalg_lapack_z ! to rotate or not to rotate, that is the question ... if( abs( aapq1 )>tol ) then ompq = aapq / abs(aapq) - notrot = 0 + notrot = 0_${ik}$ ! [rtd] rotated = rotated + 1 - pskipped = 0 - iswrot = iswrot + 1 + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ if( rotok ) then aqoap = aaqq / aapp apoaq = aapp / aaqq @@ -76871,10 +76866,10 @@ module stdlib_linalg_lapack_z if( abs( theta )>bigtheta ) then t = half / theta cs = one - call stdlib_zrot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_zrot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *t ) if( rsvec ) then - call stdlib_zrot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_zrot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*t ) end if sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) @@ -76893,10 +76888,10 @@ module stdlib_linalg_lapack_z sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq1 ) ) - call stdlib_zrot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_zrot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *sn ) if( rsvec ) then - call stdlib_zrot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_zrot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*sn ) end if end if @@ -76904,28 +76899,28 @@ module stdlib_linalg_lapack_z else ! .. have to use modified gram-schmidt like transformation if( aapp>aaqq ) then - call stdlib_zcopy( m, a( 1, p ), 1,cwork(n+1), 1 ) + call stdlib${ii}$_zcopy( m, a( 1_${ik}$, p ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) - call stdlib_zlascl( 'G', 0, 0, aapp, one,m, 1, cwork(n+1)& + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, cwork(n+1)& ,lda,ierr ) - call stdlib_zlascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) - call stdlib_zaxpy( m, -aapq, cwork(n+1),1, a( 1, q ), 1 ) + call stdlib${ii}$_zaxpy( m, -aapq, cwork(n+1),1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) - call stdlib_zlascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq1*aapq1 ) ) mxsinj = max( mxsinj, sfmin ) else - call stdlib_zcopy( m, a( 1, q ), 1,cwork(n+1), 1 ) - call stdlib_zlascl( 'G', 0, 0, aaqq, one,m, 1, cwork(n+1)& + call stdlib${ii}$_zcopy( m, a( 1_${ik}$, q ), 1_${ik}$,cwork(n+1), 1_${ik}$ ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, cwork(n+1)& ,lda,ierr ) - call stdlib_zlascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) - call stdlib_zaxpy( m, -conjg(aapq),cwork(n+1), 1, a( 1, & - p ), 1 ) - call stdlib_zlascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& + call stdlib${ii}$_zaxpy( m, -conjg(aapq),cwork(n+1), 1_${ik}$, a( 1_${ik}$, & + p ), 1_${ik}$ ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, one, aapp,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) sva( p ) = aapp*sqrt( max( zero,one-aapq1*aapq1 ) ) @@ -76935,47 +76930,47 @@ module stdlib_linalg_lapack_z ! end if rotok then ... else ! in the case of cancellation in updating sva(q), sva(p) ! .. recompute sva(q), sva(p) - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_dznrm2( m, a( 1, q ), 1) + sva( q ) = stdlib${ii}$_dznrm2( m, a( 1_${ik}$, q ), 1_${ik}$) else t = zero aaqq = one - call stdlib_zlassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_zlassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq ) end if end if - if( ( aapp / aapp0 )**2<=rooteps ) then + if( ( aapp / aapp0 )**2_${ik}$<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_dznrm2( m, a( 1, p ), 1 ) + aapp = stdlib${ii}$_dznrm2( m, a( 1_${ik}$, p ), 1_${ik}$ ) else t = zero aapp = one - call stdlib_zlassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_zlassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp ) end if sva( p ) = aapp end if ! end of ok rotation else - notrot = notrot + 1 + notrot = notrot + 1_${ik}$ ! [rtd] skipped = skipped + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if else - notrot = notrot + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if if( ( i<=swband ) .and. ( ijblsk>=blskip ) )then sva( p ) = aapp - notrot = 0 + notrot = 0_${ik}$ go to 2011 end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then aapp = -aapp - notrot = 0 + notrot = 0_${ik}$ go to 2203 end if end do loop_2200 @@ -76983,8 +76978,8 @@ module stdlib_linalg_lapack_z 2203 continue sva( p ) = aapp else - if( aapp==zero )notrot = notrot +min( jgl+kbl-1, n ) - jgl + 1 - if( aapprootsfmin ) )then - sva( n ) = stdlib_dznrm2( m, a( 1, n ), 1 ) + sva( n ) = stdlib${ii}$_dznrm2( m, a( 1_${ik}$, n ), 1_${ik}$ ) else t = zero aapp = one - call stdlib_zlassq( m, a( 1, n ), 1, t, aapp ) + call stdlib${ii}$_zlassq( m, a( 1_${ik}$, n ), 1_${ik}$, t, aapp ) sva( n ) = t*sqrt( aapp ) end if ! additional steering devices @@ -77017,81 +77012,81 @@ module stdlib_linalg_lapack_z end do loop_1993 ! end i=1:nsweep loop ! #:( reaching this point means that the procedure has not converged. - info = nsweep - 1 + info = nsweep - 1_${ik}$ go to 1995 1994 continue ! #:) reaching this point means numerical convergence after the i-th ! sweep. - info = 0 + info = 0_${ik}$ ! #:) info = 0 confirms successful iterations. 1995 continue ! sort the singular values and find how many are above ! the underflow threshold. - n2 = 0 - n4 = 0 + n2 = 0_${ik}$ + n4 = 0_${ik}$ do p = 1, n - 1 - q = stdlib_idamax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib${ii}$_idamax( n-p+1, sva( p ), 1_${ik}$ ) + p - 1_${ik}$ if( p/=q ) then temp1 = sva( p ) sva( p ) = sva( q ) sva( q ) = temp1 - call stdlib_zswap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_zswap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) + call stdlib${ii}$_zswap( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) + if( rsvec )call stdlib${ii}$_zswap( mvl, v( 1_${ik}$, p ), 1_${ik}$, v( 1_${ik}$, q ), 1_${ik}$ ) end if if( sva( p )/=zero ) then - n4 = n4 + 1 - if( sva( p )*skl>sfmin )n2 = n2 + 1 + n4 = n4 + 1_${ik}$ + if( sva( p )*skl>sfmin )n2 = n2 + 1_${ik}$ end if end do if( sva( n )/=zero ) then - n4 = n4 + 1 - if( sva( n )*skl>sfmin )n2 = n2 + 1 + n4 = n4 + 1_${ik}$ + if( sva( n )*skl>sfmin )n2 = n2 + 1_${ik}$ end if ! normalize the left singular vectors. if( lsvec .or. uctol ) then do p = 1, n4 - ! call stdlib_zdscal( m, one / sva( p ), a( 1, p ), 1 ) - call stdlib_zlascl( 'G',0,0, sva(p), one, m, 1, a(1,p), m, ierr ) + ! call stdlib${ii}$_zdscal( m, one / sva( p ), a( 1, p ), 1 ) + call stdlib${ii}$_zlascl( 'G',0_${ik}$,0_${ik}$, sva(p), one, m, 1_${ik}$, a(1_${ik}$,p), m, ierr ) end do end if ! scale the product of jacobi rotations. if( rsvec ) then do p = 1, n - temp1 = one / stdlib_dznrm2( mvl, v( 1, p ), 1 ) - call stdlib_zdscal( mvl, temp1, v( 1, p ), 1 ) + temp1 = one / stdlib${ii}$_dznrm2( mvl, v( 1_${ik}$, p ), 1_${ik}$ ) + call stdlib${ii}$_zdscal( mvl, temp1, v( 1_${ik}$, p ), 1_${ik}$ ) end do end if ! undo scaling, if necessary (and possible). - if( ( ( skl>one ) .and. ( sva( 1 )<( big / skl ) ) ).or. ( ( skl( sfmin / skl ) ) ) ) then + if( ( ( skl>one ) .and. ( sva( 1_${ik}$ )<( big / skl ) ) ).or. ( ( skl( sfmin / skl ) ) ) ) then do p = 1, n sva( p ) = skl*sva( p ) end do skl = one end if - rwork( 1 ) = skl + rwork( 1_${ik}$ ) = skl ! the singular values of a are skl*sva(1:n). if skl/=one ! then some of the singular values may overflow or underflow and ! the spectrum is given in this factored representation. - rwork( 2 ) = real( n4,KIND=dp) + rwork( 2_${ik}$ ) = real( n4,KIND=dp) ! n4 is the number of computed nonzero singular values of a. - rwork( 3 ) = real( n2,KIND=dp) + rwork( 3_${ik}$ ) = real( n2,KIND=dp) ! n2 is the number of singular values of a greater than sfmin. ! if n2zero .and. anrmzero .and. bnrm1 ) then - call stdlib_zlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& + call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vsl, ldvsl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vsl( ilo+1, ilo )& , ldvsl ) end if - call stdlib_zungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & + call stdlib${ii}$_zungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vsr - if( ilvsr )call stdlib_zlaset( 'FULL', n, n, czero, cone, vsr, ldvsr ) + if( ilvsr )call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vsr, ldvsr ) ! reduce to generalized hessenberg form - call stdlib_zgghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& + call stdlib${ii}$_zgghd3( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl,ldvsl, vsr, ldvsr,& work( iwrk ), lwork+1-iwrk, ierr ) - sdim = 0 + sdim = 0_${ik}$ ! perform qz algorithm, computing schur vectors if desired iwrk = itau - call stdlib_zlaqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, & - ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), 0, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + call stdlib${ii}$_zlaqz0( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vsl, & + ldvsl, vsr, ldvsr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), 0_${ik}$, ierr ) + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 30 end if ! sort eigenvalues alpha/beta if desired if( wantst ) then ! undo scaling on eigenvalues before selecting - if( ilascl )call stdlib_zlascl( 'G', 0, 0, anrm, anrmto, n, 1, alpha, n, ierr ) + if( ilascl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrm, anrmto, n, 1_${ik}$, alpha, n, ierr ) - if( ilbscl )call stdlib_zlascl( 'G', 0, 0, bnrm, bnrmto, n, 1, beta, n, ierr ) + if( ilbscl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrm, bnrmto, n, 1_${ik}$, beta, n, ierr ) ! select eigenvalues do i = 1, n bwork( i ) = selctg( alpha( i ), beta( i ) ) end do - call stdlib_ztgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,beta, vsl, & - ldvsl, vsr, ldvsr, sdim, pvsl, pvsr,dif, work( iwrk ), lwork-iwrk+1, idum, 1, ierr ) + call stdlib${ii}$_ztgsen( 0_${ik}$, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alpha,beta, vsl, & + ldvsl, vsr, ldvsr, sdim, pvsl, pvsr,dif, work( iwrk ), lwork-iwrk+1, idum, 1_${ik}$, ierr ) - if( ierr==1 )info = n + 3 + if( ierr==1_${ik}$ )info = n + 3_${ik}$ end if ! apply back-permutation to vsl and vsr - if( ilvsl )call stdlib_zggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), & + if( ilvsl )call stdlib${ii}$_zggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), & n, vsl, ldvsl, ierr ) - if( ilvsr )call stdlib_zggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), & + if( ilvsr )call stdlib${ii}$_zggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), & n, vsr, ldvsr, ierr ) ! undo scaling if( ilascl ) then - call stdlib_zlascl( 'U', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) - call stdlib_zlascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) + call stdlib${ii}$_zlascl( 'U', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, n, a, lda, ierr ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr ) end if if( ilbscl ) then - call stdlib_zlascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) - call stdlib_zlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) + call stdlib${ii}$_zlascl( 'U', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, n, b, ldb, ierr ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) end if if( wantst ) then ! check if reordering is correct lastsl = .true. - sdim = 0 + sdim = 0_${ik}$ do i = 1, n cursl = selctg( alpha( i ), beta( i ) ) - if( cursl )sdim = sdim + 1 - if( cursl .and. .not.lastsl )info = n + 2 + if( cursl )sdim = sdim + 1_${ik}$ + if( cursl .and. .not.lastsl )info = n + 2_${ik}$ lastsl = cursl end do end if 30 continue - work( 1 ) = cmplx( lwkopt,KIND=dp) + work( 1_${ik}$ ) = cmplx( lwkopt,KIND=dp) return - end subroutine stdlib_zgges3 + end subroutine stdlib${ii}$_zgges3 - subroutine stdlib_zggev3( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, & + subroutine stdlib${ii}$_zggev3( jobvl, jobvr, n, a, lda, b, ldb, alpha, beta,vl, ldvl, vr, ldvr, & !! ZGGEV3 computes for a pair of N-by-N complex nonsymmetric matrices !! (A,B), the generalized eigenvalues, and optionally, the left and/or !! right generalized eigenvectors. @@ -77364,8 +77359,8 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: jobvl, jobvr - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, ldvl, ldvr, lwork, n ! Array Arguments real(dp), intent(out) :: rwork(*) complex(dp), intent(inout) :: a(lda,*), b(ldb,*) @@ -77376,12 +77371,12 @@ module stdlib_linalg_lapack_z ! Local Scalars logical(lk) :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery character :: chtemp - integer(ilp) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,& + integer(${ik}$) :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, in, iright, irows, irwrk,& itau, iwrk, jc, jr, lwkopt real(dp) :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp complex(dp) :: x ! Local Arrays - logical(lk) :: ldumma(1) + logical(lk) :: ldumma(1_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,aimag,max,sqrt ! Statement Functions @@ -77391,75 +77386,75 @@ module stdlib_linalg_lapack_z ! Executable Statements ! decode the input arguments if( stdlib_lsame( jobvl, 'N' ) ) then - ijobvl = 1 + ijobvl = 1_${ik}$ ilvl = .false. else if( stdlib_lsame( jobvl, 'V' ) ) then - ijobvl = 2 + ijobvl = 2_${ik}$ ilvl = .true. else - ijobvl = -1 + ijobvl = -1_${ik}$ ilvl = .false. end if if( stdlib_lsame( jobvr, 'N' ) ) then - ijobvr = 1 + ijobvr = 1_${ik}$ ilvr = .false. else if( stdlib_lsame( jobvr, 'V' ) ) then - ijobvr = 2 + ijobvr = 2_${ik}$ ilvr = .true. else - ijobvr = -1 + ijobvr = -1_${ik}$ ilvr = .false. end if ilv = ilvl .or. ilvr ! test the input arguments - info = 0 - lquery = ( lwork==-1 ) - if( ijobvl<=0 ) then - info = -1 - else if( ijobvr<=0 ) then - info = -2 - else if( n<0 ) then - info = -3 - else if( ldazero .and. anrmzero .and. bnrm1 ) then - call stdlib_zlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& + call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vl, ldvl ) + if( irows>1_${ik}$ ) then + call stdlib${ii}$_zlacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb,vl( ilo+1, ilo ),& ldvl ) end if - call stdlib_zungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & + call stdlib${ii}$_zungqr( irows, irows, irows, vl( ilo, ilo ), ldvl,work( itau ), work( & iwrk ), lwork+1-iwrk, ierr ) end if ! initialize vr - if( ilvr )call stdlib_zlaset( 'FULL', n, n, czero, cone, vr, ldvr ) + if( ilvr )call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, vr, ldvr ) ! reduce to generalized hessenberg form if( ilv ) then ! eigenvectors requested -- work on whole matrix. - call stdlib_zgghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & + call stdlib${ii}$_zgghd3( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl,ldvl, vr, ldvr, & work( iwrk ), lwork+1-iwrk, ierr ) else - call stdlib_zgghd3( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & + call stdlib${ii}$_zgghd3( 'N', 'N', irows, 1_${ik}$, irows, a( ilo, ilo ), lda,b( ilo, ilo ), & ldb, vl, ldvl, vr, ldvr,work( iwrk ), lwork+1-iwrk, ierr ) end if ! perform qz algorithm (compute eigenvalues, and optionally, the @@ -77544,15 +77539,15 @@ module stdlib_linalg_lapack_z else chtemp = 'E' end if - call stdlib_zlaqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, & - ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), 0, ierr ) - if( ierr/=0 ) then - if( ierr>0 .and. ierr<=n ) then + call stdlib${ii}$_zlaqz0( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb,alpha, beta, vl, & + ldvl, vr, ldvr, work( iwrk ),lwork+1-iwrk, rwork( irwrk ), 0_${ik}$, ierr ) + if( ierr/=0_${ik}$ ) then + if( ierr>0_${ik}$ .and. ierr<=n ) then info = ierr - else if( ierr>n .and. ierr<=2*n ) then + else if( ierr>n .and. ierr<=2_${ik}$*n ) then info = ierr - n else - info = n + 1 + info = n + 1_${ik}$ end if go to 70 end if @@ -77567,15 +77562,15 @@ module stdlib_linalg_lapack_z else chtemp = 'R' end if - call stdlib_ztgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & + call stdlib${ii}$_ztgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl,vr, ldvr, n, & in, work( iwrk ), rwork( irwrk ),ierr ) - if( ierr/=0 ) then - info = n + 2 + if( ierr/=0_${ik}$ ) then + info = n + 2_${ik}$ go to 70 end if ! undo balancing on vl and vr and normalization if( ilvl ) then - call stdlib_zggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,& + call stdlib${ii}$_zggbak( 'P', 'L', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vl,& ldvl, ierr ) loop_30: do jc = 1, n temp = zero @@ -77590,7 +77585,7 @@ module stdlib_linalg_lapack_z end do loop_30 end if if( ilvr ) then - call stdlib_zggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,& + call stdlib${ii}$_zggbak( 'P', 'R', n, ilo, ihi, rwork( ileft ),rwork( iright ), n, vr,& ldvr, ierr ) loop_60: do jc = 1, n temp = zero @@ -77607,14 +77602,14 @@ module stdlib_linalg_lapack_z end if ! undo scaling if necessary 70 continue - if( ilascl )call stdlib_zlascl( 'G', 0, 0, anrmto, anrm, n, 1, alpha, n, ierr ) - if( ilbscl )call stdlib_zlascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) - work( 1 ) = cmplx( lwkopt,KIND=dp) + if( ilascl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, anrmto, anrm, n, 1_${ik}$, alpha, n, ierr ) + if( ilbscl )call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, bnrmto, bnrm, n, 1_${ik}$, beta, n, ierr ) + work( 1_${ik}$ ) = cmplx( lwkopt,KIND=dp) return - end subroutine stdlib_zggev3 + end subroutine stdlib${ii}$_zggev3 - pure subroutine stdlib_zgsvj0( jobv, m, n, a, lda, d, sva, mv, v, ldv, eps,sfmin, tol, & + pure subroutine stdlib${ii}$_zgsvj0( jobv, m, n, a, lda, d, sva, mv, v, ldv, eps,sfmin, tol, & !! ZGSVJ0 is called from ZGESVJ as a pre-processor and that is its main !! purpose. It applies Jacobi rotations in the same way as ZGESVJ does, but !! it does not check convergence (stopping criterion). Few tuning @@ -77624,8 +77619,8 @@ module stdlib_linalg_lapack_z ! -- 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, ldv, lwork, m, mv, n, nsweep + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldv, lwork, m, mv, n, nsweep real(dp), intent(in) :: eps, sfmin, tol character, intent(in) :: jobv ! Array Arguments @@ -77639,7 +77634,7 @@ module stdlib_linalg_lapack_z complex(dp) :: aapq, ompq real(dp) :: aapp, aapp0, aapq1, aaqq, apoaq, aqoap, big, bigtheta, cs, mxaapq, mxsinj, & rootbig, rooteps, rootsfmin, roottol, small, sn, t, temp1, theta, thsign - integer(ilp) :: blskip, emptsw, i, ibr, ierr, igl, ijblsk, ir1, iswrot, jbc, jgl, kbl, & + integer(${ik}$) :: blskip, emptsw, i, ibr, ierr, igl, ijblsk, ir1, iswrot, jbc, jgl, kbl, & lkahead, mvl, nbl, notrot, p, pskipped, q, rowskip, swband logical(lk) :: applv, rotok, rsvec ! Intrinsic Functions @@ -77650,29 +77645,29 @@ module stdlib_linalg_lapack_z applv = stdlib_lsame( jobv, 'A' ) rsvec = stdlib_lsame( jobv, 'V' ) if( .not.( rsvec .or. applv .or. stdlib_lsame( jobv, 'N' ) ) ) then - info = -1 - else if( m<0 ) then - info = -2 - else if( ( n<0 ) .or. ( n>m ) ) then - info = -3 + info = -1_${ik}$ + else if( m<0_${ik}$ ) then + info = -2_${ik}$ + else if( ( n<0_${ik}$ ) .or. ( n>m ) ) then + info = -3_${ik}$ else if( lda sqrt(overflow_threshold), and to ! underflow for ||a(:,p)||_2 < sqrt(underflow_threshold). - ! hence, stdlib_dznrm2 cannot be trusted, not even in the case when + ! hence, stdlib${ii}$_dznrm2 cannot be trusted, not even in the case when ! the true norm is far from the under(over)flow boundaries. - ! if properly implemented stdlib_dznrm2 is available, the if-then-else-end if - ! below should be replaced with "aapp = stdlib_dznrm2( m, a(1,p), 1 )". + ! if properly implemented stdlib${ii}$_dznrm2 is available, the if-then-else-end if + ! below should be replaced with "aapp = stdlib${ii}$_dznrm2( m, a(1,p), 1 )". if( ( sva( p )rootsfmin ) ) then - sva( p ) = stdlib_dznrm2( m, a( 1, p ), 1 ) + sva( p ) = stdlib${ii}$_dznrm2( m, a( 1_${ik}$, p ), 1_${ik}$ ) else temp1 = zero aapp = one - call stdlib_zlassq( m, a( 1, p ), 1, temp1, aapp ) + call stdlib${ii}$_zlassq( m, a( 1_${ik}$, p ), 1_${ik}$, temp1, aapp ) sva( p ) = temp1*sqrt( aapp ) end if aapp = sva( p ) @@ -77770,7 +77765,7 @@ module stdlib_linalg_lapack_z aapp = sva( p ) end if if( aapp>zero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2002: do q = p + 1, min( igl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -77778,25 +77773,25 @@ module stdlib_linalg_lapack_z if( aaqq>=one ) then rotok = ( small*aapp )<=aaqq if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_zdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib${ii}$_zdotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq ) / aapp else - call stdlib_zcopy( m, a( 1, p ), 1,work, 1 ) - call stdlib_zlascl( 'G', 0, 0, aapp, one,m, 1, work, lda, & + call stdlib${ii}$_zcopy( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, work, lda, & ierr ) - aapq = stdlib_zdotc( m, work, 1,a( 1, q ), 1 ) / & + aapq = stdlib${ii}$_zdotc( m, work, 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq end if else rotok = aapp<=( aaqq / small ) if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_zdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib${ii}$_zdotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aapp ) / aaqq else - call stdlib_zcopy( m, a( 1, q ), 1,work, 1 ) - call stdlib_zlascl( 'G', 0, 0, aaqq,one, m, 1,work, lda, & + call stdlib${ii}$_zcopy( m, a( 1_${ik}$, q ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq,one, m, 1_${ik}$,work, lda, & ierr ) - aapq = stdlib_zdotc( m, a( 1, p ), 1,work, 1 ) / & + aapq = stdlib${ii}$_zdotc( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) / & aapp end if end if @@ -77808,10 +77803,10 @@ module stdlib_linalg_lapack_z ompq = aapq / abs(aapq) ! Rotate ! [rtd] rotated = rotated + one - if( ir1==0 ) then - notrot = 0 - pskipped = 0 - iswrot = iswrot + 1 + if( ir1==0_${ik}$ ) then + notrot = 0_${ik}$ + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ end if if( rotok ) then aqoap = aaqq / aapp @@ -77820,10 +77815,10 @@ module stdlib_linalg_lapack_z if( abs( theta )>bigtheta ) then t = half / theta cs = one - call stdlib_zrot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_zrot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *t ) if ( rsvec ) then - call stdlib_zrot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_zrot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*t ) end if sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) @@ -77841,23 +77836,23 @@ module stdlib_linalg_lapack_z sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq1 ) ) - call stdlib_zrot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_zrot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *sn ) if ( rsvec ) then - call stdlib_zrot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_zrot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*sn ) end if end if d(p) = -d(q) * ompq else ! .. have to use modified gram-schmidt like transformation - call stdlib_zcopy( m, a( 1, p ), 1,work, 1 ) - call stdlib_zlascl( 'G', 0, 0, aapp, one, m,1, work, lda,& + call stdlib${ii}$_zcopy( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one, m,1_${ik}$, work, lda,& ierr ) - call stdlib_zlascl( 'G', 0, 0, aaqq, one, m,1, a( 1, q ), & + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one, m,1_${ik}$, a( 1_${ik}$, q ), & lda, ierr ) - call stdlib_zaxpy( m, -aapq, work, 1,a( 1, q ), 1 ) - call stdlib_zlascl( 'G', 0, 0, one, aaqq, m,1, a( 1, q ), & + call stdlib${ii}$_zaxpy( m, -aapq, work, 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq, m,1_${ik}$, a( 1_${ik}$, q ), & lda, ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq1*aapq1 ) ) mxsinj = max( mxsinj, sfmin ) @@ -77865,41 +77860,41 @@ module stdlib_linalg_lapack_z ! end if rotok then ... else ! in the case of cancellation in updating sva(q), sva(p) ! recompute sva(q), sva(p). - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_dznrm2( m, a( 1, q ), 1 ) + sva( q ) = stdlib${ii}$_dznrm2( m, a( 1_${ik}$, q ), 1_${ik}$ ) else t = zero aaqq = one - call stdlib_zlassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_zlassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq ) end if end if if( ( aapp / aapp0 )<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_dznrm2( m, a( 1, p ), 1 ) + aapp = stdlib${ii}$_dznrm2( m, a( 1_${ik}$, p ), 1_${ik}$ ) else t = zero aapp = one - call stdlib_zlassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_zlassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp ) end if sva( p ) = aapp end if else ! a(:,p) and a(:,q) already numerically orthogonal - if( ir1==0 )notrot = notrot + 1 + if( ir1==0_${ik}$ )notrot = notrot + 1_${ik}$ ! [rtd] skipped = skipped + 1 - pskipped = pskipped + 1 + pskipped = pskipped + 1_${ik}$ end if else ! a(:,q) is zero column - if( ir1==0 )notrot = notrot + 1 - pskipped = pskipped + 1 + if( ir1==0_${ik}$ )notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then - if( ir1==0 )aapp = -aapp - notrot = 0 + if( ir1==0_${ik}$ )aapp = -aapp + notrot = 0_${ik}$ go to 2103 end if end do loop_2002 @@ -77909,7 +77904,7 @@ module stdlib_linalg_lapack_z sva( p ) = aapp else sva( p ) = aapp - if( ( ir1==0 ) .and. ( aapp==zero ) )notrot = notrot + min( igl+kbl-1, & + if( ( ir1==0_${ik}$ ) .and. ( aapp==zero ) )notrot = notrot + min( igl+kbl-1, & n ) - p end if end do loop_2001 @@ -77918,15 +77913,15 @@ module stdlib_linalg_lapack_z end do loop_1002 ! end of ir1-loop ! ... go to the off diagonal blocks - igl = ( ibr-1 )*kbl + 1 + igl = ( ibr-1 )*kbl + 1_${ik}$ loop_2010: do jbc = ibr + 1, nbl - jgl = ( jbc-1 )*kbl + 1 + jgl = ( jbc-1 )*kbl + 1_${ik}$ ! doing the block at ( ibr, jbc ) - ijblsk = 0 + ijblsk = 0_${ik}$ loop_2100: do p = igl, min( igl+kbl-1, n ) aapp = sva( p ) if( aapp>zero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2200: do q = jgl, min( jgl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -77940,13 +77935,13 @@ module stdlib_linalg_lapack_z rotok = ( small*aaqq )<=aapp end if if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_zdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib${ii}$_zdotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq ) / aapp else - call stdlib_zcopy( m, a( 1, p ), 1,work, 1 ) - call stdlib_zlascl( 'G', 0, 0, aapp,one, m, 1,work, lda, & + call stdlib${ii}$_zcopy( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aapp,one, m, 1_${ik}$,work, lda, & ierr ) - aapq = stdlib_zdotc( m, work, 1,a( 1, q ), 1 ) / & + aapq = stdlib${ii}$_zdotc( m, work, 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq end if else @@ -77956,13 +77951,13 @@ module stdlib_linalg_lapack_z rotok = aaqq<=( aapp / small ) end if if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_zdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / max(& + aapq = ( stdlib${ii}$_zdotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / max(& aaqq,aapp) )/ min(aaqq,aapp) else - call stdlib_zcopy( m, a( 1, q ), 1,work, 1 ) - call stdlib_zlascl( 'G', 0, 0, aaqq,one, m, 1,work, lda, & + call stdlib${ii}$_zcopy( m, a( 1_${ik}$, q ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq,one, m, 1_${ik}$,work, lda, & ierr ) - aapq = stdlib_zdotc( m, a( 1, p ), 1,work, 1 ) / & + aapq = stdlib${ii}$_zdotc( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) / & aapp end if end if @@ -77972,10 +77967,10 @@ module stdlib_linalg_lapack_z ! to rotate or not to rotate, that is the question ... if( abs( aapq1 )>tol ) then ompq = aapq / abs(aapq) - notrot = 0 + notrot = 0_${ik}$ ! [rtd] rotated = rotated + 1 - pskipped = 0 - iswrot = iswrot + 1 + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ if( rotok ) then aqoap = aaqq / aapp apoaq = aapp / aaqq @@ -77984,10 +77979,10 @@ module stdlib_linalg_lapack_z if( abs( theta )>bigtheta ) then t = half / theta cs = one - call stdlib_zrot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_zrot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *t ) if( rsvec ) then - call stdlib_zrot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_zrot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*t ) end if sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) @@ -78006,10 +78001,10 @@ module stdlib_linalg_lapack_z sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq1 ) ) - call stdlib_zrot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_zrot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *sn ) if( rsvec ) then - call stdlib_zrot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_zrot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*sn ) end if end if @@ -78017,27 +78012,27 @@ module stdlib_linalg_lapack_z else ! .. have to use modified gram-schmidt like transformation if( aapp>aaqq ) then - call stdlib_zcopy( m, a( 1, p ), 1,work, 1 ) - call stdlib_zlascl( 'G', 0, 0, aapp, one,m, 1, work,lda,& + call stdlib${ii}$_zcopy( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, work,lda,& ierr ) - call stdlib_zlascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) - call stdlib_zaxpy( m, -aapq, work,1, a( 1, q ), 1 ) + call stdlib${ii}$_zaxpy( m, -aapq, work,1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) - call stdlib_zlascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq1*aapq1 ) ) mxsinj = max( mxsinj, sfmin ) else - call stdlib_zcopy( m, a( 1, q ), 1,work, 1 ) - call stdlib_zlascl( 'G', 0, 0, aaqq, one,m, 1, work,lda,& + call stdlib${ii}$_zcopy( m, a( 1_${ik}$, q ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, work,lda,& ierr ) - call stdlib_zlascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) - call stdlib_zaxpy( m, -conjg(aapq),work, 1, a( 1, p ), 1 & + call stdlib${ii}$_zaxpy( m, -conjg(aapq),work, 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ & ) - call stdlib_zlascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, one, aapp,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) sva( p ) = aapp*sqrt( max( zero,one-aapq1*aapq1 ) ) @@ -78047,47 +78042,47 @@ module stdlib_linalg_lapack_z ! end if rotok then ... else ! in the case of cancellation in updating sva(q), sva(p) ! .. recompute sva(q), sva(p) - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_dznrm2( m, a( 1, q ), 1) + sva( q ) = stdlib${ii}$_dznrm2( m, a( 1_${ik}$, q ), 1_${ik}$) else t = zero aaqq = one - call stdlib_zlassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_zlassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq ) end if end if - if( ( aapp / aapp0 )**2<=rooteps ) then + if( ( aapp / aapp0 )**2_${ik}$<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_dznrm2( m, a( 1, p ), 1 ) + aapp = stdlib${ii}$_dznrm2( m, a( 1_${ik}$, p ), 1_${ik}$ ) else t = zero aapp = one - call stdlib_zlassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_zlassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp ) end if sva( p ) = aapp end if ! end of ok rotation else - notrot = notrot + 1 + notrot = notrot + 1_${ik}$ ! [rtd] skipped = skipped + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if else - notrot = notrot + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if if( ( i<=swband ) .and. ( ijblsk>=blskip ) )then sva( p ) = aapp - notrot = 0 + notrot = 0_${ik}$ go to 2011 end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then aapp = -aapp - notrot = 0 + notrot = 0_${ik}$ go to 2203 end if end do loop_2200 @@ -78095,8 +78090,8 @@ module stdlib_linalg_lapack_z 2203 continue sva( p ) = aapp else - if( aapp==zero )notrot = notrot +min( jgl+kbl-1, n ) - jgl + 1 - if( aapprootsfmin ) )then - sva( n ) = stdlib_dznrm2( m, a( 1, n ), 1 ) + sva( n ) = stdlib${ii}$_dznrm2( m, a( 1_${ik}$, n ), 1_${ik}$ ) else t = zero aapp = one - call stdlib_zlassq( m, a( 1, n ), 1, t, aapp ) + call stdlib${ii}$_zlassq( m, a( 1_${ik}$, n ), 1_${ik}$, t, aapp ) sva( n ) = t*sqrt( aapp ) end if ! additional steering devices @@ -78129,17 +78124,17 @@ module stdlib_linalg_lapack_z end do loop_1993 ! end i=1:nsweep loop ! #:( reaching this point means that the procedure has not converged. - info = nsweep - 1 + info = nsweep - 1_${ik}$ go to 1995 1994 continue ! #:) reaching this point means numerical convergence after the i-th ! sweep. - info = 0 + info = 0_${ik}$ ! #:) info = 0 confirms successful iterations. 1995 continue ! sort the vector sva() of column norms. do p = 1, n - 1 - q = stdlib_idamax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib${ii}$_idamax( n-p+1, sva( p ), 1_${ik}$ ) + p - 1_${ik}$ if( p/=q ) then temp1 = sva( p ) sva( p ) = sva( q ) @@ -78147,15 +78142,15 @@ module stdlib_linalg_lapack_z aapq = d( p ) d( p ) = d( q ) d( q ) = aapq - call stdlib_zswap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_zswap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) + call stdlib${ii}$_zswap( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) + if( rsvec )call stdlib${ii}$_zswap( mvl, v( 1_${ik}$, p ), 1_${ik}$, v( 1_${ik}$, q ), 1_${ik}$ ) end if end do return - end subroutine stdlib_zgsvj0 + end subroutine stdlib${ii}$_zgsvj0 - pure subroutine stdlib_zgsvj1( jobv, m, n, n1, a, lda, d, sva, mv, v, ldv,eps, sfmin, tol, & + pure subroutine stdlib${ii}$_zgsvj1( jobv, m, n, n1, a, lda, d, sva, mv, v, ldv,eps, sfmin, tol, & !! ZGSVJ1 is called from ZGESVJ as a pre-processor and that is its main !! purpose. It applies Jacobi rotations in the same way as ZGESVJ does, but !! it targets only particular pivots and it does not check convergence @@ -78186,8 +78181,8 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments real(dp), intent(in) :: eps, sfmin, tol - integer(ilp), intent(out) :: info - integer(ilp), intent(in) :: lda, ldv, lwork, m, mv, n, n1, nsweep + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldv, lwork, m, mv, n, n1, nsweep character, intent(in) :: jobv ! Array Arguments complex(dp), intent(inout) :: a(lda,*), d(n), v(ldv,*) @@ -78199,7 +78194,7 @@ module stdlib_linalg_lapack_z complex(dp) :: aapq, ompq real(dp) :: aapp, aapp0, aapq1, aaqq, apoaq, aqoap, big, bigtheta, cs, mxaapq, mxsinj, & rootbig, rooteps, rootsfmin, roottol, small, sn, t, temp1, theta, thsign - integer(ilp) :: blskip, emptsw, i, ibr, igl, ierr, ijblsk, iswrot, jbc, jgl, kbl, mvl, & + integer(${ik}$) :: blskip, emptsw, i, ibr, igl, ierr, ijblsk, iswrot, jbc, jgl, kbl, mvl, & notrot, nblc, nblr, p, pskipped, q, rowskip, swband logical(lk) :: applv, rotok, rsvec ! Intrinsic Functions @@ -78210,31 +78205,31 @@ module stdlib_linalg_lapack_z applv = stdlib_lsame( jobv, 'A' ) rsvec = stdlib_lsame( jobv, 'V' ) if( .not.( rsvec .or. applv .or. stdlib_lsame( jobv, 'N' ) ) ) then - info = -1 - else if( m<0 ) then - info = -2 - else if( ( n<0 ) .or. ( n>m ) ) then - info = -3 - else if( n1<0 ) then - info = -4 + info = -1_${ik}$ + else if( m<0_${ik}$ ) then + info = -2_${ik}$ + else if( ( n<0_${ik}$ ) .or. ( n>m ) ) then + info = -3_${ik}$ + else if( n1<0_${ik}$ ) then + info = -4_${ik}$ else if( ldazero ) then - pskipped = 0 + pskipped = 0_${ik}$ loop_2200: do q = jgl, min( jgl+kbl-1, n ) aaqq = sva( q ) if( aaqq>zero ) then @@ -78313,13 +78308,13 @@ module stdlib_linalg_lapack_z rotok = ( small*aaqq )<=aapp end if if( aapp<( big / aaqq ) ) then - aapq = ( stdlib_zdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / & + aapq = ( stdlib${ii}$_zdotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq ) / aapp else - call stdlib_zcopy( m, a( 1, p ), 1,work, 1 ) - call stdlib_zlascl( 'G', 0, 0, aapp,one, m, 1,work, lda, & + call stdlib${ii}$_zcopy( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aapp,one, m, 1_${ik}$,work, lda, & ierr ) - aapq = stdlib_zdotc( m, work, 1,a( 1, q ), 1 ) / & + aapq = stdlib${ii}$_zdotc( m, work, 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / & aaqq end if else @@ -78329,13 +78324,13 @@ module stdlib_linalg_lapack_z rotok = aaqq<=( aapp / small ) end if if( aapp>( small / aaqq ) ) then - aapq = ( stdlib_zdotc( m, a( 1, p ), 1,a( 1, q ), 1 ) / max(& + aapq = ( stdlib${ii}$_zdotc( m, a( 1_${ik}$, p ), 1_${ik}$,a( 1_${ik}$, q ), 1_${ik}$ ) / max(& aaqq,aapp) )/ min(aaqq,aapp) else - call stdlib_zcopy( m, a( 1, q ), 1,work, 1 ) - call stdlib_zlascl( 'G', 0, 0, aaqq,one, m, 1,work, lda, & + call stdlib${ii}$_zcopy( m, a( 1_${ik}$, q ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq,one, m, 1_${ik}$,work, lda, & ierr ) - aapq = stdlib_zdotc( m, a( 1, p ), 1,work, 1 ) / & + aapq = stdlib${ii}$_zdotc( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) / & aapp end if end if @@ -78345,10 +78340,10 @@ module stdlib_linalg_lapack_z ! to rotate or not to rotate, that is the question ... if( abs( aapq1 )>tol ) then ompq = aapq / abs(aapq) - notrot = 0 + notrot = 0_${ik}$ ! [rtd] rotated = rotated + 1 - pskipped = 0 - iswrot = iswrot + 1 + pskipped = 0_${ik}$ + iswrot = iswrot + 1_${ik}$ if( rotok ) then aqoap = aaqq / aapp apoaq = aapp / aaqq @@ -78357,10 +78352,10 @@ module stdlib_linalg_lapack_z if( abs( theta )>bigtheta ) then t = half / theta cs = one - call stdlib_zrot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_zrot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *t ) if( rsvec ) then - call stdlib_zrot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_zrot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*t ) end if sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) @@ -78379,10 +78374,10 @@ module stdlib_linalg_lapack_z sva( q ) = aaqq*sqrt( max( zero,one+t*apoaq*aapq1 ) ) aapp = aapp*sqrt( max( zero,one-t*aqoap*aapq1 ) ) - call stdlib_zrot( m, a(1,p), 1, a(1,q), 1,cs, conjg(ompq)& + call stdlib${ii}$_zrot( m, a(1_${ik}$,p), 1_${ik}$, a(1_${ik}$,q), 1_${ik}$,cs, conjg(ompq)& *sn ) if( rsvec ) then - call stdlib_zrot( mvl, v(1,p), 1,v(1,q), 1, cs, & + call stdlib${ii}$_zrot( mvl, v(1_${ik}$,p), 1_${ik}$,v(1_${ik}$,q), 1_${ik}$, cs, & conjg(ompq)*sn ) end if end if @@ -78390,27 +78385,27 @@ module stdlib_linalg_lapack_z else ! .. have to use modified gram-schmidt like transformation if( aapp>aaqq ) then - call stdlib_zcopy( m, a( 1, p ), 1,work, 1 ) - call stdlib_zlascl( 'G', 0, 0, aapp, one,m, 1, work,lda,& + call stdlib${ii}$_zcopy( m, a( 1_${ik}$, p ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, work,lda,& ierr ) - call stdlib_zlascl( 'G', 0, 0, aaqq, one,m, 1, a( 1, q ),& + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) - call stdlib_zaxpy( m, -aapq, work,1, a( 1, q ), 1 ) + call stdlib${ii}$_zaxpy( m, -aapq, work,1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) - call stdlib_zlascl( 'G', 0, 0, one, aaqq,m, 1, a( 1, q ),& + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, one, aaqq,m, 1_${ik}$, a( 1_${ik}$, q ),& lda,ierr ) sva( q ) = aaqq*sqrt( max( zero,one-aapq1*aapq1 ) ) mxsinj = max( mxsinj, sfmin ) else - call stdlib_zcopy( m, a( 1, q ), 1,work, 1 ) - call stdlib_zlascl( 'G', 0, 0, aaqq, one,m, 1, work,lda,& + call stdlib${ii}$_zcopy( m, a( 1_${ik}$, q ), 1_${ik}$,work, 1_${ik}$ ) + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aaqq, one,m, 1_${ik}$, work,lda,& ierr ) - call stdlib_zlascl( 'G', 0, 0, aapp, one,m, 1, a( 1, p ),& + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, aapp, one,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) - call stdlib_zaxpy( m, -conjg(aapq),work, 1, a( 1, p ), 1 & + call stdlib${ii}$_zaxpy( m, -conjg(aapq),work, 1_${ik}$, a( 1_${ik}$, p ), 1_${ik}$ & ) - call stdlib_zlascl( 'G', 0, 0, one, aapp,m, 1, a( 1, p ),& + call stdlib${ii}$_zlascl( 'G', 0_${ik}$, 0_${ik}$, one, aapp,m, 1_${ik}$, a( 1_${ik}$, p ),& lda,ierr ) sva( p ) = aapp*sqrt( max( zero,one-aapq1*aapq1 ) ) @@ -78420,47 +78415,47 @@ module stdlib_linalg_lapack_z ! end if rotok then ... else ! in the case of cancellation in updating sva(q), sva(p) ! .. recompute sva(q), sva(p) - if( ( sva( q ) / aaqq )**2<=rooteps )then + if( ( sva( q ) / aaqq )**2_${ik}$<=rooteps )then if( ( aaqqrootsfmin ) ) then - sva( q ) = stdlib_dznrm2( m, a( 1, q ), 1) + sva( q ) = stdlib${ii}$_dznrm2( m, a( 1_${ik}$, q ), 1_${ik}$) else t = zero aaqq = one - call stdlib_zlassq( m, a( 1, q ), 1, t,aaqq ) + call stdlib${ii}$_zlassq( m, a( 1_${ik}$, q ), 1_${ik}$, t,aaqq ) sva( q ) = t*sqrt( aaqq ) end if end if - if( ( aapp / aapp0 )**2<=rooteps ) then + if( ( aapp / aapp0 )**2_${ik}$<=rooteps ) then if( ( aapprootsfmin ) ) then - aapp = stdlib_dznrm2( m, a( 1, p ), 1 ) + aapp = stdlib${ii}$_dznrm2( m, a( 1_${ik}$, p ), 1_${ik}$ ) else t = zero aapp = one - call stdlib_zlassq( m, a( 1, p ), 1, t,aapp ) + call stdlib${ii}$_zlassq( m, a( 1_${ik}$, p ), 1_${ik}$, t,aapp ) aapp = t*sqrt( aapp ) end if sva( p ) = aapp end if ! end of ok rotation else - notrot = notrot + 1 + notrot = notrot + 1_${ik}$ ! [rtd] skipped = skipped + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if else - notrot = notrot + 1 - pskipped = pskipped + 1 - ijblsk = ijblsk + 1 + notrot = notrot + 1_${ik}$ + pskipped = pskipped + 1_${ik}$ + ijblsk = ijblsk + 1_${ik}$ end if if( ( i<=swband ) .and. ( ijblsk>=blskip ) )then sva( p ) = aapp - notrot = 0 + notrot = 0_${ik}$ go to 2011 end if if( ( i<=swband ) .and.( pskipped>rowskip ) ) then aapp = -aapp - notrot = 0 + notrot = 0_${ik}$ go to 2203 end if end do loop_2200 @@ -78468,8 +78463,8 @@ module stdlib_linalg_lapack_z 2203 continue sva( p ) = aapp else - if( aapp==zero )notrot = notrot +min( jgl+kbl-1, n ) - jgl + 1 - if( aapprootsfmin ) )then - sva( n ) = stdlib_dznrm2( m, a( 1, n ), 1 ) + sva( n ) = stdlib${ii}$_dznrm2( m, a( 1_${ik}$, n ), 1_${ik}$ ) else t = zero aapp = one - call stdlib_zlassq( m, a( 1, n ), 1, t, aapp ) + call stdlib${ii}$_zlassq( m, a( 1_${ik}$, n ), 1_${ik}$, t, aapp ) sva( n ) = t*sqrt( aapp ) end if ! additional steering devices @@ -78502,17 +78497,17 @@ module stdlib_linalg_lapack_z end do loop_1993 ! end i=1:nsweep loop ! #:( reaching this point means that the procedure has not converged. - info = nsweep - 1 + info = nsweep - 1_${ik}$ go to 1995 1994 continue ! #:) reaching this point means numerical convergence after the i-th ! sweep. - info = 0 + info = 0_${ik}$ ! #:) info = 0 confirms successful iterations. 1995 continue ! sort the vector sva() of column norms. do p = 1, n - 1 - q = stdlib_idamax( n-p+1, sva( p ), 1 ) + p - 1 + q = stdlib${ii}$_idamax( n-p+1, sva( p ), 1_${ik}$ ) + p - 1_${ik}$ if( p/=q ) then temp1 = sva( p ) sva( p ) = sva( q ) @@ -78520,15 +78515,15 @@ module stdlib_linalg_lapack_z aapq = d( p ) d( p ) = d( q ) d( q ) = aapq - call stdlib_zswap( m, a( 1, p ), 1, a( 1, q ), 1 ) - if( rsvec )call stdlib_zswap( mvl, v( 1, p ), 1, v( 1, q ), 1 ) + call stdlib${ii}$_zswap( m, a( 1_${ik}$, p ), 1_${ik}$, a( 1_${ik}$, q ), 1_${ik}$ ) + if( rsvec )call stdlib${ii}$_zswap( mvl, v( 1_${ik}$, p ), 1_${ik}$, v( 1_${ik}$, q ), 1_${ik}$ ) end if end do return - end subroutine stdlib_zgsvj1 + end subroutine stdlib${ii}$_zgsvj1 - pure subroutine stdlib_zhesv_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) + pure subroutine stdlib${ii}$_zhesv_aa( uplo, n, nrhs, a, lda, ipiv, b, ldb, work,lwork, info ) !! ZHESV_AA computes the solution to a complex system of linear equations !! A * X = B, !! where A is an N-by-N Hermitian matrix and X and B are N-by-NRHS @@ -78545,62 +78540,62 @@ module stdlib_linalg_lapack_z ! -- 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, lwork, n, nrhs + integer(${ik}$), intent(out) :: info + integer(${ik}$), intent(in) :: lda, ldb, lwork, n, nrhs ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(dp), intent(inout) :: a(lda,*), b(ldb,*) complex(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars logical(lk) :: lquery - integer(ilp) :: lwkopt, lwkopt_hetrf, lwkopt_hetrs + integer(${ik}$) :: lwkopt, lwkopt_hetrf, lwkopt_hetrs ! Intrinsic Functions intrinsic :: max ! Executable Statements ! test the input parameters. - info = 0 - lquery = ( lwork==-1 ) + info = 0_${ik}$ + lquery = ( lwork==-1_${ik}$ ) if( .not.stdlib_lsame( uplo, 'U' ) .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=n )go to 20 ! each step of the main loop @@ -78684,17 +78679,17 @@ module stdlib_linalg_lapack_z ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=1 for the first panel, and ! k1=0 for the rest - j1 = j + 1 + j1 = j + 1_${ik}$ jb = min( n-j1+1, nb ) - k1 = max(1, j)-j + k1 = max(1_${ik}$, j)-j ! panel factorization - call stdlib_zlahef_aa( uplo, 2-k1, n-j, jb,a( max(1, j), j+1 ), lda,ipiv( j+1 ), & + call stdlib${ii}$_zlahef_aa( uplo, 2_${ik}$-k1, n-j, jb,a( max(1_${ik}$, j), j+1 ), lda,ipiv( j+1 ), & work, n, work( n*nb+1 ) ) ! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot) do j2 = j+2, min(n, j+jb+1) ipiv( j2 ) = ipiv( j2 ) + j - if( (j2/=ipiv(j2)) .and. ((j1-k1)>2) ) then - call stdlib_zswap( j1-k1-2, a( 1, j2 ), 1,a( 1, ipiv(j2) ), 1 ) + if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then + call stdlib${ii}$_zswap( j1-k1-2, a( 1_${ik}$, j2 ), 1_${ik}$,a( 1_${ik}$, ipiv(j2) ), 1_${ik}$ ) end if end do j = j + jb @@ -78703,37 +78698,37 @@ module stdlib_linalg_lapack_z ! work stores the current block of the auxiriarly matrix h if( j1 .or. jb>1 ) then + if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then ! merge rank-1 update with blas-3 update alpha = conjg( a( j, j+1 ) ) a( j, j+1 ) = cone - call stdlib_zcopy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib${ii}$_zcopy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) - call stdlib_zscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib${ii}$_zscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=0 and k2=1 for the first panel, ! and k1=1 and k2=0 for the rest - if( j1>1 ) then + if( j1>1_${ik}$ ) then ! not first panel - k2 = 1 + k2 = 1_${ik}$ else ! first panel - k2 = 0 + k2 = 0_${ik}$ ! first update skips the first column - jb = jb - 1 + jb = jb - 1_${ik}$ end if do j2 = j+1, n, nb nj = min( nb, n-j2+1 ) - ! update (j2, j2) diagonal block with stdlib_zgemv + ! update (j2, j2) diagonal block with stdlib${ii}$_zgemv j3 = j2 do mj = nj-1, 1, -1 - call stdlib_zgemm( 'CONJUGATE TRANSPOSE', 'TRANSPOSE',1, mj, jb+1,-cone,& + call stdlib${ii}$_zgemm( 'CONJUGATE TRANSPOSE', 'TRANSPOSE',1_${ik}$, mj, jb+1,-cone,& a( j1-k2, j3 ), lda,work( (j3-j1+1)+k1*n ), n,cone, a( j3, j3 ), lda ) - j3 = j3 + 1 + j3 = j3 + 1_${ik}$ end do - ! update off-diagonal block of j2-th block row with stdlib_zgemm - call stdlib_zgemm( 'CONJUGATE TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-& + ! update off-diagonal block of j2-th block row with stdlib${ii}$_zgemm + call stdlib${ii}$_zgemm( 'CONJUGATE TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-& cone, a( j1-k2, j2 ), lda,work( (j3-j1+1)+k1*n ), n,cone, a( j2, j3 ), lda & ) end do @@ -78741,7 +78736,7 @@ module stdlib_linalg_lapack_z a( j, j+1 ) = conjg( alpha ) end if ! work(j+1, 1) stores h(j+1, 1) - call stdlib_zcopy( n-j, a( j+1, j+1 ), lda, work( 1 ), 1 ) + call stdlib${ii}$_zcopy( n-j, a( j+1, j+1 ), lda, work( 1_${ik}$ ), 1_${ik}$ ) end if go to 10 else @@ -78750,11 +78745,11 @@ module stdlib_linalg_lapack_z ! ..................................................... ! copy first column a(1:n, 1) into h(1:n, 1) ! (stored in work(1:n)) - call stdlib_zcopy( n, a( 1, 1 ), 1, work( 1 ), 1 ) + call stdlib${ii}$_zcopy( n, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) ! j is the main loop index, increasing from 1 to n in steps of - ! jb, where jb is the number of columns factorized by stdlib_zlahef; + ! jb, where jb is the number of columns factorized by stdlib${ii}$_zlahef; ! jb is either nb, or n-j+1 for the last block - j = 0 + j = 0_${ik}$ 11 continue if( j>=n )go to 20 ! each step of the main loop @@ -78765,15 +78760,15 @@ module stdlib_linalg_lapack_z ! k1=0 for the rest j1 = j+1 jb = min( n-j1+1, nb ) - k1 = max(1, j)-j + k1 = max(1_${ik}$, j)-j ! panel factorization - call stdlib_zlahef_aa( uplo, 2-k1, n-j, jb,a( j+1, max(1, j) ), lda,ipiv( j+1 ), & + call stdlib${ii}$_zlahef_aa( uplo, 2_${ik}$-k1, n-j, jb,a( j+1, max(1_${ik}$, j) ), lda,ipiv( j+1 ), & work, n, work( n*nb+1 ) ) ! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot) do j2 = j+2, min(n, j+jb+1) ipiv( j2 ) = ipiv( j2 ) + j - if( (j2/=ipiv(j2)) .and. ((j1-k1)>2) ) then - call stdlib_zswap( j1-k1-2, a( j2, 1 ), lda,a( ipiv(j2), 1 ), lda ) + if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then + call stdlib${ii}$_zswap( j1-k1-2, a( j2, 1_${ik}$ ), lda,a( ipiv(j2), 1_${ik}$ ), lda ) end if end do j = j + jb @@ -78782,36 +78777,36 @@ module stdlib_linalg_lapack_z ! work(j2+1, 1) stores h(j2+1, 1) if( j1 .or. jb>1 ) then + if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then ! merge rank-1 update with blas-3 update alpha = conjg( a( j+1, j ) ) a( j+1, j ) = cone - call stdlib_zcopy( n-j, a( j+1, j-1 ), 1,work( (j+1-j1+1)+jb*n ), 1 ) - call stdlib_zscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib${ii}$_zcopy( n-j, a( j+1, j-1 ), 1_${ik}$,work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) + call stdlib${ii}$_zscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=0 and k2=1 for the first panel, ! and k1=1 and k2=0 for the rest - if( j1>1 ) then + if( j1>1_${ik}$ ) then ! not first panel - k2 = 1 + k2 = 1_${ik}$ else ! first panel - k2 = 0 + k2 = 0_${ik}$ ! first update skips the first column - jb = jb - 1 + jb = jb - 1_${ik}$ end if do j2 = j+1, n, nb nj = min( nb, n-j2+1 ) - ! update (j2, j2) diagonal block with stdlib_zgemv + ! update (j2, j2) diagonal block with stdlib${ii}$_zgemv j3 = j2 do mj = nj-1, 1, -1 - call stdlib_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',mj, 1, jb+1,-& + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',mj, 1_${ik}$, jb+1,-& cone, work( (j3-j1+1)+k1*n ), n,a( j3, j1-k2 ), lda,cone, a( j3, j3 ), & lda ) - j3 = j3 + 1 + j3 = j3 + 1_${ik}$ end do - ! update off-diagonal block of j2-th block column with stdlib_zgemm - call stdlib_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',n-j3+1, nj, jb+1,-& + ! update off-diagonal block of j2-th block column with stdlib${ii}$_zgemm + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'CONJUGATE TRANSPOSE',n-j3+1, nj, jb+1,-& cone, work( (j3-j1+1)+k1*n ), n,a( j2, j1-k2 ), lda,cone, a( j3, j2 ), lda & ) end do @@ -78819,17 +78814,17 @@ module stdlib_linalg_lapack_z a( j+1, j ) = conjg( alpha ) end if ! work(j+1, 1) stores h(j+1, 1) - call stdlib_zcopy( n-j, a( j+1, j+1 ), 1, work( 1 ), 1 ) + call stdlib${ii}$_zcopy( n-j, a( j+1, j+1 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) end if go to 11 end if 20 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_zhetrf_aa + end subroutine stdlib${ii}$_zhetrf_aa - pure subroutine stdlib_zhseqr( job, compz, n, ilo, ihi, h, ldh, w, z, ldz,work, lwork, info ) + pure subroutine stdlib${ii}$_zhseqr( job, compz, n, ilo, ihi, h, ldh, w, z, ldz,work, lwork, info ) !! ZHSEQR computes the eigenvalues of a Hessenberg matrix H !! and, optionally, the matrices T and Z from the Schur decomposition !! H = Z T Z**H, where T is an upper triangular matrix (the @@ -78843,24 +78838,24 @@ module stdlib_linalg_lapack_z ! -- 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, ldh, ldz, lwork, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ilo, ldh, ldz, lwork, n + integer(${ik}$), intent(out) :: info character, intent(in) :: compz, job ! Array Arguments complex(dp), intent(inout) :: h(ldh,*), z(ldz,*) complex(dp), intent(out) :: w(*), work(*) ! ===================================================================== ! Parameters - integer(ilp), parameter :: ntiny = 15 - integer(ilp), parameter :: nl = 49 + integer(${ik}$), parameter :: ntiny = 15_${ik}$ + integer(${ik}$), parameter :: nl = 49_${ik}$ real(dp), parameter :: rzero = 0.0_dp ! ==== matrices of order ntiny or smaller must be processed by - ! . stdlib_zlahqr because of insufficient subdiagonal scratch space. + ! . stdlib${ii}$_zlahqr because of insufficient subdiagonal scratch space. ! . (this is a hard limit.) ==== ! ==== nl allocates some local workspace to help small matrices - ! . through a rare stdlib_zlahqr failure. nl > ntiny = 15 is - ! . required and nl <= nmin = stdlib_ilaenv(ispec=12,...) is recom- + ! . through a rare stdlib${ii}$_zlahqr failure. nl > ntiny = 15 is + ! . required and nl <= nmin = stdlib${ii}$_ilaenv(ispec=12,...) is recom- ! . mended. (the default value of nmin is 75.) using nl = 49 ! . allows up to six simultaneous shifts and a 16-by-16 ! . deflation window. ==== @@ -78870,7 +78865,7 @@ module stdlib_linalg_lapack_z ! Local Arrays complex(dp) :: hl(nl,nl), workl(nl) ! Local Scalars - integer(ilp) :: kbot, nmin + integer(${ik}$) :: kbot, nmin logical(lk) :: initz, lquery, wantt, wantz ! Intrinsic Functions intrinsic :: real,cmplx,max,min @@ -78879,102 +78874,102 @@ module stdlib_linalg_lapack_z wantt = stdlib_lsame( job, 'S' ) initz = stdlib_lsame( compz, 'I' ) wantz = initz .or. stdlib_lsame( compz, 'V' ) - work( 1 ) = cmplx( real( max( 1, n ),KIND=dp), rzero,KIND=dp) - lquery = lwork==-1 - info = 0 + work( 1_${ik}$ ) = cmplx( real( max( 1_${ik}$, n ),KIND=dp), rzero,KIND=dp) + lquery = lwork==-1_${ik}$ + info = 0_${ik}$ if( .not.stdlib_lsame( job, 'E' ) .and. .not.wantt ) then - info = -1 + info = -1_${ik}$ else if( .not.stdlib_lsame( compz, 'N' ) .and. .not.wantz ) 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( ldh1 )call stdlib_zcopy( ilo-1, h, ldh+1, w, 1 ) - if( ihi1_${ik}$ )call stdlib${ii}$_zcopy( ilo-1, h, ldh+1, w, 1_${ik}$ ) + if( ihinmin ) then - call stdlib_zlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,z, ldz, work, & + call stdlib${ii}$_zlaqr0( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,z, ldz, work, & lwork, info ) else ! ==== small matrix ==== - call stdlib_zlahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,z, ldz, info ) + call stdlib${ii}$_zlahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, ilo, ihi,z, ldz, info ) - if( info>0 ) then - ! ==== a rare stdlib_zlahqr failure! stdlib_zlaqr0 sometimes succeeds - ! . when stdlib_zlahqr fails. ==== + if( info>0_${ik}$ ) then + ! ==== a rare stdlib${ii}$_zlahqr failure! stdlib${ii}$_zlaqr0 sometimes succeeds + ! . when stdlib${ii}$_zlahqr fails. ==== kbot = info if( n>=nl ) then ! ==== larger matrices have enough subdiagonal scratch - ! . space to call stdlib_zlaqr0 directly. ==== - call stdlib_zlaqr0( wantt, wantz, n, ilo, kbot, h, ldh, w,ilo, ihi, z, ldz,& + ! . space to call stdlib${ii}$_zlaqr0 directly. ==== + call stdlib${ii}$_zlaqr0( wantt, wantz, n, ilo, kbot, h, ldh, w,ilo, ihi, z, ldz,& work, lwork, info ) else ! ==== tiny matrices don't have enough subdiagonal - ! . scratch space to benefit from stdlib_zlaqr0. hence, + ! . scratch space to benefit from stdlib${ii}$_zlaqr0. hence, ! . tiny matrices must be copied into a larger - ! . array before calling stdlib_zlaqr0. ==== - call stdlib_zlacpy( 'A', n, n, h, ldh, hl, nl ) + ! . array before calling stdlib${ii}$_zlaqr0. ==== + call stdlib${ii}$_zlacpy( 'A', n, n, h, ldh, hl, nl ) hl( n+1, n ) = czero - call stdlib_zlaset( 'A', nl, nl-n, czero, czero, hl( 1, n+1 ),nl ) - call stdlib_zlaqr0( wantt, wantz, nl, ilo, kbot, hl, nl, w,ilo, ihi, z, & + call stdlib${ii}$_zlaset( 'A', nl, nl-n, czero, czero, hl( 1_${ik}$, n+1 ),nl ) + call stdlib${ii}$_zlaqr0( wantt, wantz, nl, ilo, kbot, hl, nl, w,ilo, ihi, z, & ldz, workl, nl, info ) - if( wantt .or. info/=0 )call stdlib_zlacpy( 'A', n, n, hl, nl, h, ldh ) + if( wantt .or. info/=0_${ik}$ )call stdlib${ii}$_zlacpy( 'A', n, n, hl, nl, h, ldh ) end if end if end if ! ==== clear out the trash, if necessary. ==== - if( ( wantt .or. info/=0 ) .and. n>2 )call stdlib_zlaset( 'L', n-2, n-2, czero, & - czero, h( 3, 1 ), ldh ) + if( ( wantt .or. info/=0_${ik}$ ) .and. n>2_${ik}$ )call stdlib${ii}$_zlaset( 'L', n-2, n-2, czero, & + czero, h( 3_${ik}$, 1_${ik}$ ), ldh ) ! ==== ensure reported workspace size is backward-compatible with ! . previous lapack versions. ==== - work( 1 ) = cmplx( max( real( max( 1, n ),KIND=dp),real( work( 1 ),KIND=dp) ), & + work( 1_${ik}$ ) = cmplx( max( real( max( 1_${ik}$, n ),KIND=dp),real( work( 1_${ik}$ ),KIND=dp) ), & rzero,KIND=dp) end if - end subroutine stdlib_zhseqr + end subroutine stdlib${ii}$_zhseqr - pure subroutine stdlib_zlahef_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) + pure subroutine stdlib${ii}$_zlahef_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) !! DLAHEF_AA factorizes a panel of a complex hermitian matrix A using !! the Aasen's algorithm. The panel consists of a set of NB rows of A !! when UPLO is U, or a set of NB columns when UPLO is L. @@ -78990,23 +78985,23 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: m, nb, j1, lda, ldh + integer(${ik}$), intent(in) :: m, nb, j1, lda, ldh ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(dp), intent(inout) :: a(lda,*), h(ldh,*) complex(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: j, k, k1, i1, i2, mj + integer(${ik}$) :: j, k, k1, i1, i2, mj complex(dp) :: piv, alpha ! Intrinsic Functions intrinsic :: real,conjg,max ! Executable Statements - j = 1 + j = 1_${ik}$ ! k1 is the first column of the panel to be factorized ! i.e., k1 is 2 for the first block column, and 1 for the rest of the blocks - k1 = (2-j1)+1 + k1 = (2_${ik}$-j1)+1_${ik}$ if( stdlib_lsame( uplo, 'U' ) ) then ! ..................................................... ! factorize a as u**t*d*u using the upper triangle of a @@ -79014,100 +79009,100 @@ module stdlib_linalg_lapack_z 10 continue if ( j>min(m, nb) )go to 20 ! k is the column to be factorized - ! when being called from stdlib_zhetrf_aa, + ! when being called from stdlib${ii}$_zhetrf_aa, ! > for the first block column, j1 is 1, hence j1+j-1 is j, ! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1, k = j1+j-1 if( j==m ) then ! only need to compute t(j, j) - mj = 1 + mj = 1_${ik}$ else mj = m-j+1 end if ! h(j:n, j) := a(j, j:n) - h(j:n, 1:(j-1)) * l(j1:(j-1), j), ! where h(j:n, j) has been initialized to be a(j, j:n) - if( k>2 ) then + if( k>2_${ik}$ ) then ! k is the column to be factorized ! > for the first block column, k is j, skipping the first two ! columns ! > for the rest of the columns, k is j+1, skipping only the ! first column - call stdlib_zlacgv( j-k1, a( 1, j ), 1 ) - call stdlib_zgemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( 1, j ), 1,& - cone, h( j, j ), 1 ) - call stdlib_zlacgv( j-k1, a( 1, j ), 1 ) + call stdlib${ii}$_zlacgv( j-k1, a( 1_${ik}$, j ), 1_${ik}$ ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( 1_${ik}$, j ), 1_${ik}$,& + cone, h( j, j ), 1_${ik}$ ) + call stdlib${ii}$_zlacgv( j-k1, a( 1_${ik}$, j ), 1_${ik}$ ) end if ! copy h(i:n, i) into work - call stdlib_zcopy( mj, h( j, j ), 1, work( 1 ), 1 ) + call stdlib${ii}$_zcopy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) if( j>k1 ) then ! compute work := work - l(j-1, j:n) * t(j-1,j), ! where a(j-1, j) stores t(j-1, j) and a(j-2, j:n) stores u(j-1, j:n) alpha = -conjg( a( k-1, j ) ) - call stdlib_zaxpy( mj, alpha, a( k-2, j ), lda, work( 1 ), 1 ) + call stdlib${ii}$_zaxpy( mj, alpha, a( k-2, j ), lda, work( 1_${ik}$ ), 1_${ik}$ ) end if ! set a(j, j) = t(j, j) - a( k, j ) = real( work( 1 ),KIND=dp) + a( k, j ) = real( work( 1_${ik}$ ),KIND=dp) if( j1 ) then + if( k>1_${ik}$ ) then alpha = -a( k, j ) - call stdlib_zaxpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2 ), 1 ) + call stdlib${ii}$_zaxpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2_${ik}$ ), 1_${ik}$ ) endif ! find max(|work(2:n)|) - i2 = stdlib_izamax( m-j, work( 2 ), 1 ) + 1 + i2 = stdlib${ii}$_izamax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$ piv = work( i2 ) ! apply hermitian pivot - if( (i2/=2) .and. (piv/=0) ) then + if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then ! swap work(i1) and work(i2) - i1 = 2 + i1 = 2_${ik}$ work( i2 ) = work( i1 ) work( i1 ) = piv ! swap a(i1, i1+1:n) with a(i1+1:n, i2) i1 = i1+j-1 i2 = i2+j-1 - call stdlib_zswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1 ) + call stdlib${ii}$_zswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1_${ik}$ ) - call stdlib_zlacgv( i2-i1, a( j1+i1-1, i1+1 ), lda ) - call stdlib_zlacgv( i2-i1-1, a( j1+i1, i2 ), 1 ) + call stdlib${ii}$_zlacgv( i2-i1, a( j1+i1-1, i1+1 ), lda ) + call stdlib${ii}$_zlacgv( i2-i1-1, a( j1+i1, i2 ), 1_${ik}$ ) ! swap a(i1, i2+1:n) with a(i2, i2+1:n) - if( i2(k1-1) ) then ! swap l(1:i1-1, i1) with l(1:i1-1, i2), ! skipping the first column - call stdlib_zswap( i1-k1+1, a( 1, i1 ), 1,a( 1, i2 ), 1 ) + call stdlib${ii}$_zswap( i1-k1+1, a( 1_${ik}$, i1 ), 1_${ik}$,a( 1_${ik}$, i2 ), 1_${ik}$ ) end if else ipiv( j+1 ) = j+1 endif ! set a(j, j+1) = t(j, j+1) - a( k, j+1 ) = work( 2 ) + a( k, j+1 ) = work( 2_${ik}$ ) if( jmin( m, nb ) )go to 40 ! k is the column to be factorized - ! when being called from stdlib_zhetrf_aa, + ! when being called from stdlib${ii}$_zhetrf_aa, ! > for the first block column, j1 is 1, hence j1+j-1 is j, ! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1, k = j1+j-1 if( j==m ) then ! only need to compute t(j, j) - mj = 1 + mj = 1_${ik}$ else mj = m-j+1 end if ! h(j:n, j) := a(j:n, j) - h(j:n, 1:(j-1)) * l(j, j1:(j-1))^t, ! where h(j:n, j) has been initialized to be a(j:n, j) - if( k>2 ) then + if( k>2_${ik}$ ) then ! k is the column to be factorized ! > for the first block column, k is j, skipping the first two ! columns ! > for the rest of the columns, k is j+1, skipping only the ! first column - call stdlib_zlacgv( j-k1, a( j, 1 ), lda ) - call stdlib_zgemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( j, 1 ), & - lda,cone, h( j, j ), 1 ) - call stdlib_zlacgv( j-k1, a( j, 1 ), lda ) + call stdlib${ii}$_zlacgv( j-k1, a( j, 1_${ik}$ ), lda ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( j, 1_${ik}$ ), & + lda,cone, h( j, j ), 1_${ik}$ ) + call stdlib${ii}$_zlacgv( j-k1, a( j, 1_${ik}$ ), lda ) end if ! copy h(j:n, j) into work - call stdlib_zcopy( mj, h( j, j ), 1, work( 1 ), 1 ) + call stdlib${ii}$_zcopy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) if( j>k1 ) then ! compute work := work - l(j:n, j-1) * t(j-1,j), ! where a(j-1, j) = t(j-1, j) and a(j, j-2) = l(j, j-1) alpha = -conjg( a( j, k-1 ) ) - call stdlib_zaxpy( mj, alpha, a( j, k-2 ), 1, work( 1 ), 1 ) + call stdlib${ii}$_zaxpy( mj, alpha, a( j, k-2 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) end if ! set a(j, j) = t(j, j) - a( j, k ) = real( work( 1 ),KIND=dp) + a( j, k ) = real( work( 1_${ik}$ ),KIND=dp) if( j1 ) then + if( k>1_${ik}$ ) then alpha = -a( j, k ) - call stdlib_zaxpy( m-j, alpha, a( j+1, k-1 ), 1,work( 2 ), 1 ) + call stdlib${ii}$_zaxpy( m-j, alpha, a( j+1, k-1 ), 1_${ik}$,work( 2_${ik}$ ), 1_${ik}$ ) endif ! find max(|work(2:n)|) - i2 = stdlib_izamax( m-j, work( 2 ), 1 ) + 1 + i2 = stdlib${ii}$_izamax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$ piv = work( i2 ) ! apply hermitian pivot - if( (i2/=2) .and. (piv/=0) ) then + if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then ! swap work(i1) and work(i2) - i1 = 2 + i1 = 2_${ik}$ work( i2 ) = work( i1 ) work( i1 ) = piv ! swap a(i1+1:n, i1) with a(i2, i1+1:n) i1 = i1+j-1 i2 = i2+j-1 - call stdlib_zswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1,a( i2, j1+i1 ), lda ) + call stdlib${ii}$_zswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1_${ik}$,a( i2, j1+i1 ), lda ) - call stdlib_zlacgv( i2-i1, a( i1+1, j1+i1-1 ), 1 ) - call stdlib_zlacgv( i2-i1-1, a( i2, j1+i1 ), lda ) + call stdlib${ii}$_zlacgv( i2-i1, a( i1+1, j1+i1-1 ), 1_${ik}$ ) + call stdlib${ii}$_zlacgv( i2-i1-1, a( i2, j1+i1 ), lda ) ! swap a(i2+1:n, i1) with a(i2+1:n, i2) - if( i2(k1-1) ) then ! swap l(1:i1-1, i1) with l(1:i1-1, i2), ! skipping the first column - call stdlib_zswap( i1-k1+1, a( i1, 1 ), lda,a( i2, 1 ), lda ) + call stdlib${ii}$_zswap( i1-k1+1, a( i1, 1_${ik}$ ), lda,a( i2, 1_${ik}$ ), lda ) end if else ipiv( j+1 ) = j+1 endif ! set a(j+1, j) = t(j+1, j) - a( j+1, k ) = work( 2 ) + a( j+1, k ) = work( 2_${ik}$ ) if( j ntiny = 15, so there is enough ! . subdiagonal workspace for nwr>=2 as required. ! . (in fact, there is enough subdiagonal space for ! . nwr>=4.) ==== - nwr = stdlib_ilaenv( 13, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) - nwr = max( 2, nwr ) - nwr = min( ihi-ilo+1, ( n-1 ) / 3, nwr ) + nwr = stdlib${ii}$_ilaenv( 13_${ik}$, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) + nwr = max( 2_${ik}$, nwr ) + nwr = min( ihi-ilo+1, ( n-1 ) / 3_${ik}$, nwr ) ! ==== nsr = recommended number of simultaneous shifts. ! . at this point n > ntiny = 15, so there is at ! . enough subdiagonal workspace for nsr to be even ! . and greater than or equal to two as required. ==== - nsr = stdlib_ilaenv( 15, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) - nsr = min( nsr, ( n-3 ) / 6, ihi-ilo ) - nsr = max( 2, nsr-mod( nsr, 2 ) ) + nsr = stdlib${ii}$_ilaenv( 15_${ik}$, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) + nsr = min( nsr, ( n-3 ) / 6_${ik}$, ihi-ilo ) + nsr = max( 2_${ik}$, nsr-mod( nsr, 2_${ik}$ ) ) ! ==== estimate optimal workspace ==== - ! ==== workspace query call to stdlib_zlaqr3 ==== - call stdlib_zlaqr3( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& - ld, w, h, ldh, n, h, ldh, n, h,ldh, work, -1 ) - ! ==== optimal workspace = max(stdlib_zlaqr5, stdlib_zlaqr3) ==== - lwkopt = max( 3*nsr / 2, int( work( 1 ),KIND=ilp) ) + ! ==== workspace query call to stdlib${ii}$_zlaqr3 ==== + call stdlib${ii}$_zlaqr3( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& + ld, w, h, ldh, n, h, ldh, n, h,ldh, work, -1_${ik}$ ) + ! ==== optimal workspace = max(stdlib${ii}$_zlaqr5, stdlib${ii}$_zlaqr3) ==== + lwkopt = max( 3_${ik}$*nsr / 2_${ik}$, int( work( 1_${ik}$ ),KIND=${ik}$) ) ! ==== quick return in case of workspace query. ==== - if( lwork==-1 ) then - work( 1 ) = cmplx( lwkopt, 0,KIND=dp) + if( lwork==-1_${ik}$ ) then + work( 1_${ik}$ ) = cmplx( lwkopt, 0_${ik}$,KIND=dp) return end if - ! ==== stdlib_zlahqr/stdlib_zlaqr0 crossover point ==== - nmin = stdlib_ilaenv( 12, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) + ! ==== stdlib${ii}$_zlahqr/stdlib${ii}$_zlaqr0 crossover point ==== + nmin = stdlib${ii}$_ilaenv( 12_${ik}$, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) nmin = max( ntiny, nmin ) ! ==== nibble crossover point ==== - nibble = stdlib_ilaenv( 14, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) - nibble = max( 0, nibble ) + nibble = stdlib${ii}$_ilaenv( 14_${ik}$, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) + nibble = max( 0_${ik}$, nibble ) ! ==== accumulate reflections during ttswp? use block ! . 2-by-2 structure during matrix-matrix multiply? ==== - kacc22 = stdlib_ilaenv( 16, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) - kacc22 = max( 0, kacc22 ) - kacc22 = min( 2, kacc22 ) + kacc22 = stdlib${ii}$_ilaenv( 16_${ik}$, 'ZLAQR0', jbcmpz, n, ilo, ihi, lwork ) + kacc22 = max( 0_${ik}$, kacc22 ) + kacc22 = min( 2_${ik}$, kacc22 ) ! ==== nwmax = the largest possible deflation window for ! . which there is sufficient workspace. ==== - nwmax = min( ( n-1 ) / 3, lwork / 2 ) + nwmax = min( ( n-1 ) / 3_${ik}$, lwork / 2_${ik}$ ) nw = nwmax ! ==== nsmax = the largest number of simultaneous shifts ! . for which there is sufficient workspace. ==== - nsmax = min( ( n-3 ) / 6, 2*lwork / 3 ) - nsmax = nsmax - mod( nsmax, 2 ) + nsmax = min( ( n-3 ) / 6_${ik}$, 2_${ik}$*lwork / 3_${ik}$ ) + nsmax = nsmax - mod( nsmax, 2_${ik}$ ) ! ==== ndfl: an iteration count restarted at deflation. ==== - ndfl = 1 + ndfl = 1_${ik}$ ! ==== itmax = iteration limit ==== - itmax = max( 30, 2*kexsh )*max( 10, ( ihi-ilo+1 ) ) + itmax = max( 30_${ik}$, 2_${ik}$*kexsh )*max( 10_${ik}$, ( ihi-ilo+1 ) ) ! ==== last row and column in the active block ==== kbot = ihi ! ==== main loop ==== @@ -79381,27 +79376,27 @@ module stdlib_linalg_lapack_z ! . in general, more powerful than smaller ones, ! . rapidly increase the window to the maximum possible. ! . then, gradually reduce the window size. ==== - nh = kbot - ktop + 1 + nh = kbot - ktop + 1_${ik}$ nwupbd = min( nh, nwmax ) if( ndfl=nh-1 ) then nw = nh else - kwtop = kbot - nw + 1 + kwtop = kbot - nw + 1_${ik}$ if( cabs1( h( kwtop, kwtop-1 ) )>cabs1( h( kwtop-1, kwtop-2 ) ) )nw = nw + & - 1 + 1_${ik}$ end if end if if( ndfl=0 .or. nw>=nwupbd ) then - ndec = ndec + 1 - if( nw-ndec<2 )ndec = 0 + ndec = -1_${ik}$ + else if( ndec>=0_${ik}$ .or. nw>=nwupbd ) then + ndec = ndec + 1_${ik}$ + if( nw-ndec<2_${ik}$ )ndec = 0_${ik}$ nw = nw - ndec end if ! ==== aggressive early deflation: @@ -79414,60 +79409,60 @@ module stdlib_linalg_lapack_z ! . - an at-least-nw-but-more-is-better (nhv-by-nw) ! . vertical work array along the left-hand-edge. ! . ==== - kv = n - nw + 1 - kt = nw + 1 - nho = ( n-nw-1 ) - kt + 1 - kwv = nw + 2 - nve = ( n-nw ) - kwv + 1 + kv = n - nw + 1_${ik}$ + kt = nw + 1_${ik}$ + nho = ( n-nw-1 ) - kt + 1_${ik}$ + kwv = nw + 2_${ik}$ + nve = ( n-nw ) - kwv + 1_${ik}$ ! ==== aggressive early deflation ==== - call stdlib_zlaqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & - ls, ld, w, h( kv, 1 ), ldh, nho,h( kv, kt ), ldh, nve, h( kwv, 1 ), ldh, work,& + call stdlib${ii}$_zlaqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & + ls, ld, w, h( kv, 1_${ik}$ ), ldh, nho,h( kv, kt ), ldh, nve, h( kwv, 1_${ik}$ ), ldh, work,& lwork ) ! ==== adjust kbot accounting for new deflations. ==== kbot = kbot - ld ! ==== ks points to the shifts. ==== - ks = kbot - ls + 1 + ks = kbot - ls + 1_${ik}$ ! ==== skip an expensive qr sweep if there is a (partly ! . heuristic) reason to expect that many eigenvalues ! . will deflate without it. here, the qr sweep is ! . skipped if many eigenvalues have just been deflated ! . or if the remaining active block is small. - if( ( ld==0 ) .or. ( ( 100*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& + if( ( ld==0_${ik}$ ) .or. ( ( 100_${ik}$*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& ) ) ) then ! ==== ns = nominal number of simultaneous shifts. - ! . this may be lowered (slightly) if stdlib_zlaqr3 + ! . this may be lowered (slightly) if stdlib${ii}$_zlaqr3 ! . did not provide that many shifts. ==== - ns = min( nsmax, nsr, max( 2, kbot-ktop ) ) - ns = ns - mod( ns, 2 ) + ns = min( nsmax, nsr, max( 2_${ik}$, kbot-ktop ) ) + ns = ns - mod( ns, 2_${ik}$ ) ! ==== if there have been no deflations ! . in a multiple of kexsh iterations, ! . then try exceptional shifts. ! . otherwise use shifts provided by - ! . stdlib_zlaqr3 above or from the eigenvalues + ! . stdlib${ii}$_zlaqr3 above or from the eigenvalues ! . of a trailing principal submatrix. ==== - if( mod( ndfl, kexsh )==0 ) then - ks = kbot - ns + 1 + if( mod( ndfl, kexsh )==0_${ik}$ ) then + ks = kbot - ns + 1_${ik}$ do i = kbot, ks + 1, -2 w( i ) = h( i, i ) + wilk1*cabs1( h( i, i-1 ) ) w( i-1 ) = w( i ) end do else ! ==== got ns/2 or fewer shifts? use stdlib_zlaqr4 or - ! . stdlib_zlahqr on a trailing principal submatrix to + ! . stdlib${ii}$_zlahqr on a trailing principal submatrix to ! . get more. (since ns<=nsmax<=(n-3)/6, ! . there is enough space below the subdiagonal ! . to fit an ns-by-ns scratch array.) ==== - if( kbot-ks+1<=ns / 2 ) then - ks = kbot - ns + 1 - kt = n - ns + 1 - call stdlib_zlacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1 ), ldh ) + if( kbot-ks+1<=ns / 2_${ik}$ ) then + ks = kbot - ns + 1_${ik}$ + kt = n - ns + 1_${ik}$ + call stdlib${ii}$_zlacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1_${ik}$ ), ldh ) if( ns>nmin ) then - call stdlib_zlaqr4( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, w( & - ks ), 1, 1,zdum, 1, work, lwork, inf ) + call stdlib${ii}$_zlaqr4( .false., .false., ns, 1_${ik}$, ns,h( kt, 1_${ik}$ ), ldh, w( & + ks ), 1_${ik}$, 1_${ik}$,zdum, 1_${ik}$, work, lwork, inf ) else - call stdlib_zlahqr( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, w( & - ks ), 1, 1,zdum, 1, inf ) + call stdlib${ii}$_zlahqr( .false., .false., ns, 1_${ik}$, ns,h( kt, 1_${ik}$ ), ldh, w( & + ks ), 1_${ik}$, 1_${ik}$,zdum, 1_${ik}$, inf ) end if ks = ks + inf ! ==== in case of a rare qr failure use @@ -79488,7 +79483,7 @@ module stdlib_linalg_lapack_z rtdisc = sqrt( -det ) w( kbot-1 ) = ( tr2+rtdisc )*s w( kbot ) = ( tr2-rtdisc )*s - ks = kbot - 1 + ks = kbot - 1_${ik}$ end if end if if( kbot-ks+1>ns ) then @@ -79511,7 +79506,7 @@ module stdlib_linalg_lapack_z end if ! ==== if there are only two shifts, then use ! . only cone. ==== - if( kbot-ks+1==2 ) then + if( kbot-ks+1==2_${ik}$ ) then if( cabs1( w( kbot )-h( kbot, kbot ) )0 ) then - ndfl = 1 + if( ld>0_${ik}$ ) then + ndfl = 1_${ik}$ else - ndfl = ndfl + 1 + ndfl = ndfl + 1_${ik}$ end if ! ==== end of main loop ==== end do loop_70 @@ -79561,11 +79556,11 @@ module stdlib_linalg_lapack_z 80 continue end if ! ==== return the optimal value of lwork. ==== - work( 1 ) = cmplx( lwkopt, 0,KIND=dp) - end subroutine stdlib_zlaqr0 + work( 1_${ik}$ ) = cmplx( lwkopt, 0_${ik}$,KIND=dp) + end subroutine stdlib${ii}$_zlaqr0 - pure subroutine stdlib_zlaqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & + pure subroutine stdlib${ii}$_zlaqr3( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & !! Aggressive early deflation: !! ZLAQR3 accepts as input an upper Hessenberg matrix !! H and performs an unitary similarity transformation @@ -79580,9 +79575,9 @@ module stdlib_linalg_lapack_z ! -- 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) :: ihiz, iloz, kbot, ktop, ldh, ldt, ldv, ldwv, ldz, lwork, n,& + integer(${ik}$), intent(in) :: ihiz, iloz, kbot, ktop, ldh, ldt, ldv, ldwv, ldz, lwork, n,& nh, nv, nw - integer(ilp), intent(out) :: nd, ns + integer(${ik}$), intent(out) :: nd, ns logical(lk), intent(in) :: wantt, wantz ! Array Arguments complex(dp), intent(inout) :: h(ldh,*), z(ldz,*) @@ -79596,7 +79591,7 @@ module stdlib_linalg_lapack_z ! Local Scalars complex(dp) :: beta, cdum, s, tau real(dp) :: foo, safmax, safmin, smlnum, ulp - integer(ilp) :: i, ifst, ilst, info, infqr, j, jw, kcol, kln, knt, krow, kwtop, ltop, & + integer(${ik}$) :: i, ifst, ilst, info, infqr, j, jw, kcol, kln, knt, krow, kwtop, ltop, & lwk1, lwk2, lwk3, lwkopt, nmin ! Intrinsic Functions intrinsic :: abs,real,cmplx,conjg,aimag,int,max,min @@ -79607,45 +79602,45 @@ module stdlib_linalg_lapack_z ! Executable Statements ! ==== estimate optimal workspace. ==== jw = min( nw, kbot-ktop+1 ) - if( jw<=2 ) then - lwkopt = 1 + if( jw<=2_${ik}$ ) then + lwkopt = 1_${ik}$ else - ! ==== workspace query call to stdlib_zgehrd ==== - call stdlib_zgehrd( jw, 1, jw-1, t, ldt, work, work, -1, info ) - lwk1 = int( work( 1 ),KIND=ilp) - ! ==== workspace query call to stdlib_zunmhr ==== - call stdlib_zunmhr( 'R', 'N', jw, jw, 1, jw-1, t, ldt, work, v, ldv,work, -1, info ) + ! ==== workspace query call to stdlib${ii}$_zgehrd ==== + call stdlib${ii}$_zgehrd( jw, 1_${ik}$, jw-1, t, ldt, work, work, -1_${ik}$, info ) + lwk1 = int( work( 1_${ik}$ ),KIND=${ik}$) + ! ==== workspace query call to stdlib${ii}$_zunmhr ==== + call stdlib${ii}$_zunmhr( 'R', 'N', jw, jw, 1_${ik}$, jw-1, t, ldt, work, v, ldv,work, -1_${ik}$, info ) - lwk2 = int( work( 1 ),KIND=ilp) - ! ==== workspace query call to stdlib_zlaqr4 ==== - call stdlib_zlaqr4( .true., .true., jw, 1, jw, t, ldt, sh, 1, jw, v,ldv, work, -1, & + lwk2 = int( work( 1_${ik}$ ),KIND=${ik}$) + ! ==== workspace query call to stdlib${ii}$_zlaqr4 ==== + call stdlib${ii}$_zlaqr4( .true., .true., jw, 1_${ik}$, jw, t, ldt, sh, 1_${ik}$, jw, v,ldv, work, -1_${ik}$, & infqr ) - lwk3 = int( work( 1 ),KIND=ilp) + lwk3 = int( work( 1_${ik}$ ),KIND=${ik}$) ! ==== optimal workspace ==== lwkopt = max( jw+max( lwk1, lwk2 ), lwk3 ) end if ! ==== quick return in case of workspace query. ==== - if( lwork==-1 ) then - work( 1 ) = cmplx( lwkopt, 0,KIND=dp) + if( lwork==-1_${ik}$ ) then + work( 1_${ik}$ ) = cmplx( lwkopt, 0_${ik}$,KIND=dp) return end if ! ==== nothing to do ... ! ... for an empty active block ... ==== - ns = 0 - nd = 0 - work( 1 ) = cone + ns = 0_${ik}$ + nd = 0_${ik}$ + work( 1_${ik}$ ) = cone if( ktop>kbot )return ! ... nor for an empty deflation window. ==== if( nw<1 )return ! ==== machine constants ==== - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) safmax = rone / safmin - call stdlib_dlabad( safmin, safmax ) - ulp = stdlib_dlamch( 'PRECISION' ) + call stdlib${ii}$_dlabad( safmin, safmax ) + ulp = stdlib${ii}$_dlamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=dp) / ulp ) ! ==== setup deflation window ==== jw = min( nw, kbot-ktop+1 ) - kwtop = kbot - jw + 1 + kwtop = kbot - jw + 1_${ik}$ if( kwtop==ktop ) then s = czero else @@ -79654,14 +79649,14 @@ module stdlib_linalg_lapack_z if( kbot==kwtop ) then ! ==== 1-by-1 deflation window: not much to do ==== sh( kwtop ) = h( kwtop, kwtop ) - ns = 1 - nd = 0 + ns = 1_${ik}$ + nd = 0_${ik}$ if( cabs1( s )<=max( smlnum, ulp*cabs1( h( kwtop,kwtop ) ) ) ) then - ns = 0 - nd = 1 + ns = 0_${ik}$ + nd = 1_${ik}$ if( kwtop>ktop )h( kwtop, kwtop-1 ) = czero end if - work( 1 ) = cone + work( 1_${ik}$ ) = cone return end if ! ==== convert to spike-triangular form. (in case of a @@ -79669,37 +79664,37 @@ module stdlib_linalg_lapack_z ! . aggressive early deflation using that part of ! . the deflation window that converged using infqr ! . here and there to keep track.) ==== - call stdlib_zlacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) - call stdlib_zcopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2, 1 ), ldt+1 ) - call stdlib_zlaset( 'A', jw, jw, czero, cone, v, ldv ) - nmin = stdlib_ilaenv( 12, 'ZLAQR3', 'SV', jw, 1, jw, lwork ) + call stdlib${ii}$_zlacpy( 'U', jw, jw, h( kwtop, kwtop ), ldh, t, ldt ) + call stdlib${ii}$_zcopy( jw-1, h( kwtop+1, kwtop ), ldh+1, t( 2_${ik}$, 1_${ik}$ ), ldt+1 ) + call stdlib${ii}$_zlaset( 'A', jw, jw, czero, cone, v, ldv ) + nmin = stdlib${ii}$_ilaenv( 12_${ik}$, 'ZLAQR3', 'SV', jw, 1_${ik}$, jw, lwork ) if( jw>nmin ) then - call stdlib_zlaqr4( .true., .true., jw, 1, jw, t, ldt, sh( kwtop ), 1,jw, v, ldv, & + call stdlib${ii}$_zlaqr4( .true., .true., jw, 1_${ik}$, jw, t, ldt, sh( kwtop ), 1_${ik}$,jw, v, ldv, & work, lwork, infqr ) else - call stdlib_zlahqr( .true., .true., jw, 1, jw, t, ldt, sh( kwtop ), 1,jw, v, ldv, & + call stdlib${ii}$_zlahqr( .true., .true., jw, 1_${ik}$, jw, t, ldt, sh( kwtop ), 1_${ik}$,jw, v, ldv, & infqr ) end if ! ==== deflation detection loop ==== ns = jw - ilst = infqr + 1 + ilst = infqr + 1_${ik}$ do knt = infqr + 1, jw ! ==== small spike tip deflation test ==== foo = cabs1( t( ns, ns ) ) if( foo==rzero )foo = cabs1( s ) - if( cabs1( s )*cabs1( v( 1, ns ) )<=max( smlnum, ulp*foo ) )then + if( cabs1( s )*cabs1( v( 1_${ik}$, ns ) )<=max( smlnum, ulp*foo ) )then ! ==== cone more converged eigenvalue ==== - ns = ns - 1 + ns = ns - 1_${ik}$ else ! ==== cone undeflatable eigenvalue. move it up out of the - ! . way. (stdlib_ztrexc can not fail in this case.) ==== + ! . way. (stdlib${ii}$_ztrexc can not fail in this case.) ==== ifst = ns - call stdlib_ztrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) - ilst = ilst + 1 + call stdlib${ii}$_ztrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) + ilst = ilst + 1_${ik}$ end if end do ! ==== return to hessenberg form ==== - if( ns==0 )s = czero + if( ns==0_${ik}$ )s = czero if( nscabs1( t( ifst, ifst ) ) )ifst = j end do ilst = i - if( ifst/=ilst )call stdlib_ztrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) + if( ifst/=ilst )call stdlib${ii}$_ztrexc( 'V', jw, t, ldt, v, ldv, ifst, ilst, info ) end do end if @@ -79718,59 +79713,59 @@ module stdlib_linalg_lapack_z sh( kwtop+i-1 ) = t( i, i ) end do if( ns1 .and. s/=czero ) then + if( ns>1_${ik}$ .and. s/=czero ) then ! ==== reflect spike back into lower triangle ==== - call stdlib_zcopy( ns, v, ldv, work, 1 ) + call stdlib${ii}$_zcopy( ns, v, ldv, work, 1_${ik}$ ) do i = 1, ns work( i ) = conjg( work( i ) ) end do - beta = work( 1 ) - call stdlib_zlarfg( ns, beta, work( 2 ), 1, tau ) - work( 1 ) = cone - call stdlib_zlaset( 'L', jw-2, jw-2, czero, czero, t( 3, 1 ), ldt ) - call stdlib_zlarf( 'L', ns, jw, work, 1, conjg( tau ), t, ldt,work( jw+1 ) ) + beta = work( 1_${ik}$ ) + call stdlib${ii}$_zlarfg( ns, beta, work( 2_${ik}$ ), 1_${ik}$, tau ) + work( 1_${ik}$ ) = cone + call stdlib${ii}$_zlaset( 'L', jw-2, jw-2, czero, czero, t( 3_${ik}$, 1_${ik}$ ), ldt ) + call stdlib${ii}$_zlarf( 'L', ns, jw, work, 1_${ik}$, conjg( tau ), t, ldt,work( jw+1 ) ) - call stdlib_zlarf( 'R', ns, ns, work, 1, tau, t, ldt,work( jw+1 ) ) - call stdlib_zlarf( 'R', jw, ns, work, 1, tau, v, ldv,work( jw+1 ) ) - call stdlib_zgehrd( jw, 1, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) + call stdlib${ii}$_zlarf( 'R', ns, ns, work, 1_${ik}$, tau, t, ldt,work( jw+1 ) ) + call stdlib${ii}$_zlarf( 'R', jw, ns, work, 1_${ik}$, tau, v, ldv,work( jw+1 ) ) + call stdlib${ii}$_zgehrd( jw, 1_${ik}$, ns, t, ldt, work, work( jw+1 ),lwork-jw, info ) end if ! ==== copy updated reduced window into place ==== - if( kwtop>1 )h( kwtop, kwtop-1 ) = s*conjg( v( 1, 1 ) ) - call stdlib_zlacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) - call stdlib_zcopy( jw-1, t( 2, 1 ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) + if( kwtop>1_${ik}$ )h( kwtop, kwtop-1 ) = s*conjg( v( 1_${ik}$, 1_${ik}$ ) ) + call stdlib${ii}$_zlacpy( 'U', jw, jw, t, ldt, h( kwtop, kwtop ), ldh ) + call stdlib${ii}$_zcopy( jw-1, t( 2_${ik}$, 1_${ik}$ ), ldt+1, h( kwtop+1, kwtop ),ldh+1 ) ! ==== accumulate orthogonal matrix in order update ! . h and z, if requested. ==== - if( ns>1 .and. s/=czero )call stdlib_zunmhr( 'R', 'N', jw, ns, 1, ns, t, ldt, work, & + if( ns>1_${ik}$ .and. s/=czero )call stdlib${ii}$_zunmhr( 'R', 'N', jw, ns, 1_${ik}$, ns, t, ldt, work, & v, ldv,work( jw+1 ), lwork-jw, info ) ! ==== update vertical slab in h ==== if( wantt ) then - ltop = 1 + ltop = 1_${ik}$ else ltop = ktop end if do krow = ltop, kwtop - 1, nv kln = min( nv, kwtop-krow ) - call stdlib_zgemm( 'N', 'N', kln, jw, jw, cone, h( krow, kwtop ),ldh, v, ldv, & + call stdlib${ii}$_zgemm( 'N', 'N', kln, jw, jw, cone, h( krow, kwtop ),ldh, v, ldv, & czero, wv, ldwv ) - call stdlib_zlacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) + call stdlib${ii}$_zlacpy( 'A', kln, jw, wv, ldwv, h( krow, kwtop ), ldh ) end do ! ==== update horizontal slab in h ==== if( wantt ) then do kcol = kbot + 1, n, nh kln = min( nh, n-kcol+1 ) - call stdlib_zgemm( 'C', 'N', jw, kln, jw, cone, v, ldv,h( kwtop, kcol ), ldh, & + call stdlib${ii}$_zgemm( 'C', 'N', jw, kln, jw, cone, v, ldv,h( kwtop, kcol ), ldh, & czero, t, ldt ) - call stdlib_zlacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) + call stdlib${ii}$_zlacpy( 'A', jw, kln, t, ldt, h( kwtop, kcol ),ldh ) end do end if ! ==== update vertical slab in z ==== if( wantz ) then do krow = iloz, ihiz, nv kln = min( nv, ihiz-krow+1 ) - call stdlib_zgemm( 'N', 'N', kln, jw, jw, cone, z( krow, kwtop ),ldz, v, ldv, & + call stdlib${ii}$_zgemm( 'N', 'N', kln, jw, jw, cone, z( krow, kwtop ),ldz, v, ldv, & czero, wv, ldwv ) - call stdlib_zlacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) + call stdlib${ii}$_zlacpy( 'A', kln, jw, wv, ldwv, z( krow, kwtop ),ldz ) end do end if end if @@ -79783,11 +79778,11 @@ module stdlib_linalg_lapack_z ! . window.) ==== ns = ns - infqr ! ==== return optimal workspace. ==== - work( 1 ) = cmplx( lwkopt, 0,KIND=dp) - end subroutine stdlib_zlaqr3 + work( 1_${ik}$ ) = cmplx( lwkopt, 0_${ik}$,KIND=dp) + end subroutine stdlib${ii}$_zlaqr3 - pure subroutine stdlib_zlaqr4( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, work,& + pure subroutine stdlib${ii}$_zlaqr4( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, z, ldz, work,& !! ZLAQR4 implements one level of recursion for ZLAQR0. !! It is a complete implementation of the small bulge multi-shift !! QR algorithm. It may be called by ZLAQR0 and, for large enough @@ -79807,20 +79802,20 @@ module stdlib_linalg_lapack_z ! -- 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, ihiz, ilo, iloz, ldh, ldz, lwork, n - integer(ilp), intent(out) :: info + integer(${ik}$), intent(in) :: ihi, ihiz, ilo, iloz, ldh, ldz, lwork, n + integer(${ik}$), intent(out) :: info logical(lk), intent(in) :: wantt, wantz ! Array Arguments complex(dp), intent(inout) :: h(ldh,*), z(ldz,*) complex(dp), intent(out) :: w(*), work(*) ! ================================================================ ! Parameters - integer(ilp), parameter :: ntiny = 15 - integer(ilp), parameter :: kexnw = 5 - integer(ilp), parameter :: kexsh = 6 + integer(${ik}$), parameter :: ntiny = 15_${ik}$ + integer(${ik}$), parameter :: kexnw = 5_${ik}$ + integer(${ik}$), parameter :: kexsh = 6_${ik}$ real(dp), parameter :: wilk1 = 0.75_dp ! ==== matrices of order ntiny or smaller must be processed by - ! . stdlib_zlahqr because of insufficient subdiagonal scratch space. + ! . stdlib${ii}$_zlahqr because of insufficient subdiagonal scratch space. ! . (this is a hard limit.) ==== ! ==== exceptional deflation windows: try to cure rare @@ -79839,13 +79834,13 @@ module stdlib_linalg_lapack_z ! Local Scalars complex(dp) :: aa, bb, cc, cdum, dd, det, rtdisc, swap, tr2 real(dp) :: s - integer(ilp) :: i, inf, it, itmax, k, kacc22, kbot, kdu, ks, kt, ktop, ku, kv, kwh, & + integer(${ik}$) :: i, inf, it, itmax, k, kacc22, kbot, kdu, ks, kt, ktop, ku, kv, kwh, & kwtop, kwv, ld, ls, lwkopt, ndec, ndfl, nh, nho, nibble, nmin, ns, nsmax, nsr, nve, nw,& nwmax, nwr, nwupbd logical(lk) :: sorted - character :: jbcmpz*2 + character(len=2) :: jbcmpz ! Local Arrays - complex(dp) :: zdum(1,1) + complex(dp) :: zdum(1_${ik}$,1_${ik}$) ! Intrinsic Functions intrinsic :: abs,real,cmplx,aimag,int,max,min,mod,sqrt ! Statement Functions @@ -79853,82 +79848,82 @@ module stdlib_linalg_lapack_z ! Statement Function Definitions cabs1( cdum ) = abs( real( cdum,KIND=dp) ) + abs( aimag( cdum ) ) ! Executable Statements - info = 0 + info = 0_${ik}$ ! ==== quick return for n = 0: nothing to do. ==== - if( n==0 ) then - work( 1 ) = cone + if( n==0_${ik}$ ) then + work( 1_${ik}$ ) = cone return end if if( n<=ntiny ) then ! ==== tiny matrices must use stdlib_zlahqr. ==== - lwkopt = 1 - if( lwork/=-1 )call stdlib_zlahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, & + lwkopt = 1_${ik}$ + if( lwork/=-1_${ik}$ )call stdlib${ii}$_zlahqr( wantt, wantz, n, ilo, ihi, h, ldh, w, iloz,ihiz, & z, ldz, info ) else ! ==== use small bulge multi-shift qr with aggressive early ! . deflation on larger-than-tiny matrices. ==== ! ==== hope for the best. ==== - info = 0 - ! ==== set up job flags for stdlib_ilaenv. ==== + info = 0_${ik}$ + ! ==== set up job flags for stdlib${ii}$_ilaenv. ==== if( wantt ) then - jbcmpz( 1: 1 ) = 'S' + jbcmpz( 1_${ik}$: 1_${ik}$ ) = 'S' else - jbcmpz( 1: 1 ) = 'E' + jbcmpz( 1_${ik}$: 1_${ik}$ ) = 'E' end if if( wantz ) then - jbcmpz( 2: 2 ) = 'V' + jbcmpz( 2_${ik}$: 2_${ik}$ ) = 'V' else - jbcmpz( 2: 2 ) = 'N' + jbcmpz( 2_${ik}$: 2_${ik}$ ) = 'N' end if ! ==== nwr = recommended deflation window size. at this ! . point, n > ntiny = 15, so there is enough ! . subdiagonal workspace for nwr>=2 as required. ! . (in fact, there is enough subdiagonal space for ! . nwr>=4.) ==== - nwr = stdlib_ilaenv( 13, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) - nwr = max( 2, nwr ) - nwr = min( ihi-ilo+1, ( n-1 ) / 3, nwr ) + nwr = stdlib${ii}$_ilaenv( 13_${ik}$, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) + nwr = max( 2_${ik}$, nwr ) + nwr = min( ihi-ilo+1, ( n-1 ) / 3_${ik}$, nwr ) ! ==== nsr = recommended number of simultaneous shifts. ! . at this point n > ntiny = 15, so there is at ! . enough subdiagonal workspace for nsr to be even ! . and greater than or equal to two as required. ==== - nsr = stdlib_ilaenv( 15, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) - nsr = min( nsr, ( n-3 ) / 6, ihi-ilo ) - nsr = max( 2, nsr-mod( nsr, 2 ) ) + nsr = stdlib${ii}$_ilaenv( 15_${ik}$, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) + nsr = min( nsr, ( n-3 ) / 6_${ik}$, ihi-ilo ) + nsr = max( 2_${ik}$, nsr-mod( nsr, 2_${ik}$ ) ) ! ==== estimate optimal workspace ==== - ! ==== workspace query call to stdlib_zlaqr2 ==== - call stdlib_zlaqr2( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& - ld, w, h, ldh, n, h, ldh, n, h,ldh, work, -1 ) - ! ==== optimal workspace = max(stdlib_zlaqr5, stdlib_zlaqr2) ==== - lwkopt = max( 3*nsr / 2, int( work( 1 ),KIND=ilp) ) + ! ==== workspace query call to stdlib${ii}$_zlaqr2 ==== + call stdlib${ii}$_zlaqr2( wantt, wantz, n, ilo, ihi, nwr+1, h, ldh, iloz,ihiz, z, ldz, ls,& + ld, w, h, ldh, n, h, ldh, n, h,ldh, work, -1_${ik}$ ) + ! ==== optimal workspace = max(stdlib${ii}$_zlaqr5, stdlib${ii}$_zlaqr2) ==== + lwkopt = max( 3_${ik}$*nsr / 2_${ik}$, int( work( 1_${ik}$ ),KIND=${ik}$) ) ! ==== quick return in case of workspace query. ==== - if( lwork==-1 ) then - work( 1 ) = cmplx( lwkopt, 0,KIND=dp) + if( lwork==-1_${ik}$ ) then + work( 1_${ik}$ ) = cmplx( lwkopt, 0_${ik}$,KIND=dp) return end if - ! ==== stdlib_zlahqr/stdlib_zlaqr0 crossover point ==== - nmin = stdlib_ilaenv( 12, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) + ! ==== stdlib${ii}$_zlahqr/stdlib${ii}$_zlaqr0 crossover point ==== + nmin = stdlib${ii}$_ilaenv( 12_${ik}$, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) nmin = max( ntiny, nmin ) ! ==== nibble crossover point ==== - nibble = stdlib_ilaenv( 14, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) - nibble = max( 0, nibble ) + nibble = stdlib${ii}$_ilaenv( 14_${ik}$, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) + nibble = max( 0_${ik}$, nibble ) ! ==== accumulate reflections during ttswp? use block ! . 2-by-2 structure during matrix-matrix multiply? ==== - kacc22 = stdlib_ilaenv( 16, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) - kacc22 = max( 0, kacc22 ) - kacc22 = min( 2, kacc22 ) + kacc22 = stdlib${ii}$_ilaenv( 16_${ik}$, 'ZLAQR4', jbcmpz, n, ilo, ihi, lwork ) + kacc22 = max( 0_${ik}$, kacc22 ) + kacc22 = min( 2_${ik}$, kacc22 ) ! ==== nwmax = the largest possible deflation window for ! . which there is sufficient workspace. ==== - nwmax = min( ( n-1 ) / 3, lwork / 2 ) + nwmax = min( ( n-1 ) / 3_${ik}$, lwork / 2_${ik}$ ) nw = nwmax ! ==== nsmax = the largest number of simultaneous shifts ! . for which there is sufficient workspace. ==== - nsmax = min( ( n-3 ) / 6, 2*lwork / 3 ) - nsmax = nsmax - mod( nsmax, 2 ) + nsmax = min( ( n-3 ) / 6_${ik}$, 2_${ik}$*lwork / 3_${ik}$ ) + nsmax = nsmax - mod( nsmax, 2_${ik}$ ) ! ==== ndfl: an iteration count restarted at deflation. ==== - ndfl = 1 + ndfl = 1_${ik}$ ! ==== itmax = iteration limit ==== - itmax = max( 30, 2*kexsh )*max( 10, ( ihi-ilo+1 ) ) + itmax = max( 30_${ik}$, 2_${ik}$*kexsh )*max( 10_${ik}$, ( ihi-ilo+1 ) ) ! ==== last row and column in the active block ==== kbot = ihi ! ==== main loop ==== @@ -79956,27 +79951,27 @@ module stdlib_linalg_lapack_z ! . in general, more powerful than smaller ones, ! . rapidly increase the window to the maximum possible. ! . then, gradually reduce the window size. ==== - nh = kbot - ktop + 1 + nh = kbot - ktop + 1_${ik}$ nwupbd = min( nh, nwmax ) if( ndfl=nh-1 ) then nw = nh else - kwtop = kbot - nw + 1 + kwtop = kbot - nw + 1_${ik}$ if( cabs1( h( kwtop, kwtop-1 ) )>cabs1( h( kwtop-1, kwtop-2 ) ) )nw = nw + & - 1 + 1_${ik}$ end if end if if( ndfl=0 .or. nw>=nwupbd ) then - ndec = ndec + 1 - if( nw-ndec<2 )ndec = 0 + ndec = -1_${ik}$ + else if( ndec>=0_${ik}$ .or. nw>=nwupbd ) then + ndec = ndec + 1_${ik}$ + if( nw-ndec<2_${ik}$ )ndec = 0_${ik}$ nw = nw - ndec end if ! ==== aggressive early deflation: @@ -79989,39 +79984,39 @@ module stdlib_linalg_lapack_z ! . - an at-least-nw-but-more-is-better (nhv-by-nw) ! . vertical work array along the left-hand-edge. ! . ==== - kv = n - nw + 1 - kt = nw + 1 - nho = ( n-nw-1 ) - kt + 1 - kwv = nw + 2 - nve = ( n-nw ) - kwv + 1 + kv = n - nw + 1_${ik}$ + kt = nw + 1_${ik}$ + nho = ( n-nw-1 ) - kt + 1_${ik}$ + kwv = nw + 2_${ik}$ + nve = ( n-nw ) - kwv + 1_${ik}$ ! ==== aggressive early deflation ==== - call stdlib_zlaqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & - ls, ld, w, h( kv, 1 ), ldh, nho,h( kv, kt ), ldh, nve, h( kwv, 1 ), ldh, work,& + call stdlib${ii}$_zlaqr2( wantt, wantz, n, ktop, kbot, nw, h, ldh, iloz,ihiz, z, ldz, & + ls, ld, w, h( kv, 1_${ik}$ ), ldh, nho,h( kv, kt ), ldh, nve, h( kwv, 1_${ik}$ ), ldh, work,& lwork ) ! ==== adjust kbot accounting for new deflations. ==== kbot = kbot - ld ! ==== ks points to the shifts. ==== - ks = kbot - ls + 1 + ks = kbot - ls + 1_${ik}$ ! ==== skip an expensive qr sweep if there is a (partly ! . heuristic) reason to expect that many eigenvalues ! . will deflate without it. here, the qr sweep is ! . skipped if many eigenvalues have just been deflated ! . or if the remaining active block is small. - if( ( ld==0 ) .or. ( ( 100*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& + if( ( ld==0_${ik}$ ) .or. ( ( 100_${ik}$*ld<=nw*nibble ) .and. ( kbot-ktop+1>min( nmin, nwmax )& ) ) ) then ! ==== ns = nominal number of simultaneous shifts. - ! . this may be lowered (slightly) if stdlib_zlaqr2 + ! . this may be lowered (slightly) if stdlib${ii}$_zlaqr2 ! . did not provide that many shifts. ==== - ns = min( nsmax, nsr, max( 2, kbot-ktop ) ) - ns = ns - mod( ns, 2 ) + ns = min( nsmax, nsr, max( 2_${ik}$, kbot-ktop ) ) + ns = ns - mod( ns, 2_${ik}$ ) ! ==== if there have been no deflations ! . in a multiple of kexsh iterations, ! . then try exceptional shifts. ! . otherwise use shifts provided by - ! . stdlib_zlaqr2 above or from the eigenvalues + ! . stdlib${ii}$_zlaqr2 above or from the eigenvalues ! . of a trailing principal submatrix. ==== - if( mod( ndfl, kexsh )==0 ) then - ks = kbot - ns + 1 + if( mod( ndfl, kexsh )==0_${ik}$ ) then + ks = kbot - ns + 1_${ik}$ do i = kbot, ks + 1, -2 w( i ) = h( i, i ) + wilk1*cabs1( h( i, i-1 ) ) w( i-1 ) = w( i ) @@ -80032,13 +80027,13 @@ module stdlib_linalg_lapack_z ! . get more. (since ns<=nsmax<=(n-3)/6, ! . there is enough space below the subdiagonal ! . to fit an ns-by-ns scratch array.) ==== - if( kbot-ks+1<=ns / 2 ) then - ks = kbot - ns + 1 - kt = n - ns + 1 - call stdlib_zlacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1 ), ldh ) + if( kbot-ks+1<=ns / 2_${ik}$ ) then + ks = kbot - ns + 1_${ik}$ + kt = n - ns + 1_${ik}$ + call stdlib${ii}$_zlacpy( 'A', ns, ns, h( ks, ks ), ldh,h( kt, 1_${ik}$ ), ldh ) - call stdlib_zlahqr( .false., .false., ns, 1, ns,h( kt, 1 ), ldh, w( ks )& - , 1, 1, zdum,1, inf ) + call stdlib${ii}$_zlahqr( .false., .false., ns, 1_${ik}$, ns,h( kt, 1_${ik}$ ), ldh, w( ks )& + , 1_${ik}$, 1_${ik}$, zdum,1_${ik}$, inf ) ks = ks + inf ! ==== in case of a rare qr failure use ! . eigenvalues of the trailing 2-by-2 @@ -80058,7 +80053,7 @@ module stdlib_linalg_lapack_z rtdisc = sqrt( -det ) w( kbot-1 ) = ( tr2+rtdisc )*s w( kbot ) = ( tr2-rtdisc )*s - ks = kbot - 1 + ks = kbot - 1_${ik}$ end if end if if( kbot-ks+1>ns ) then @@ -80081,7 +80076,7 @@ module stdlib_linalg_lapack_z end if ! ==== if there are only two shifts, then use ! . only cone. ==== - if( kbot-ks+1==2 ) then + if( kbot-ks+1==2_${ik}$ ) then if( cabs1( w( kbot )-h( kbot, kbot ) )0 ) then - ndfl = 1 + if( ld>0_${ik}$ ) then + ndfl = 1_${ik}$ else - ndfl = ndfl + 1 + ndfl = ndfl + 1_${ik}$ end if ! ==== end of main loop ==== end do loop_70 @@ -80131,11 +80126,11 @@ module stdlib_linalg_lapack_z 80 continue end if ! ==== return the optimal value of lwork. ==== - work( 1 ) = cmplx( lwkopt, 0,KIND=dp) - end subroutine stdlib_zlaqr4 + work( 1_${ik}$ ) = cmplx( lwkopt, 0_${ik}$,KIND=dp) + end subroutine stdlib${ii}$_zlaqr4 - recursive subroutine stdlib_zlaqz0( wants, wantq, wantz, n, ilo, ihi, a,lda, b, ldb, alpha, & + recursive subroutine stdlib${ii}$_zlaqz0( wants, wantq, wantz, n, ilo, ihi, a,lda, b, ldb, alpha, & !! ZLAQZ0 computes the eigenvalues of a real matrix pair (H,T), !! where H is an upper Hessenberg matrix and T is upper triangular, !! using the double-shift QZ method. @@ -80179,8 +80174,8 @@ module stdlib_linalg_lapack_z beta, q, ldq, z,ldz, work, lwork, rwork, rec,info ) ! arguments character, intent( in ) :: wants, wantq, wantz - integer(ilp), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,rec - integer(ilp), intent( out ) :: info + integer(${ik}$), intent( in ) :: n, ilo, ihi, lda, ldb, ldq, ldz, lwork,rec + integer(${ik}$), intent( out ) :: info complex(dp), intent( inout ) :: a( lda, * ), b( ldb, * ), q( ldq,* ), z( ldz, * ), & alpha( * ), beta( * ), work( * ) real(dp), intent( out ) :: rwork( * ) @@ -80189,133 +80184,133 @@ module stdlib_linalg_lapack_z ! local scalars real(dp) :: smlnum, ulp, safmin, safmax, c1, tempr complex(dp) :: eshift, s1, temp - integer(ilp) :: istart, istop, iiter, maxit, istart2, k, ld, nshifts, nblock, nw, nmin,& + integer(${ik}$) :: istart, istop, iiter, maxit, istart2, k, ld, nshifts, nblock, nw, nmin,& nibble, n_undeflated, n_deflated, ns, sweep_info, shiftpos, lworkreq, k2, istartm, & istopm, iwants, iwantq, iwantz, norm_info, aed_info, nwr, nbr, nsr, itemp1, itemp2, & rcost logical(lk) :: ilschur, ilq, ilz - character :: jbcmpz*3 + character(len=3) :: jbcmpz if( stdlib_lsame( wants, 'E' ) ) then ilschur = .false. - iwants = 1 + iwants = 1_${ik}$ else if( stdlib_lsame( wants, 'S' ) ) then ilschur = .true. - iwants = 2 + iwants = 2_${ik}$ else - iwants = 0 + iwants = 0_${ik}$ end if if( stdlib_lsame( wantq, 'N' ) ) then ilq = .false. - iwantq = 1 + iwantq = 1_${ik}$ else if( stdlib_lsame( wantq, 'V' ) ) then ilq = .true. - iwantq = 2 + iwantq = 2_${ik}$ else if( stdlib_lsame( wantq, 'I' ) ) then ilq = .true. - iwantq = 3 + iwantq = 3_${ik}$ else - iwantq = 0 + iwantq = 0_${ik}$ end if if( stdlib_lsame( wantz, 'N' ) ) then ilz = .false. - iwantz = 1 + iwantz = 1_${ik}$ else if( stdlib_lsame( wantz, 'V' ) ) then ilz = .true. - iwantz = 2 + iwantz = 2_${ik}$ else if( stdlib_lsame( wantz, 'I' ) ) then ilz = .true. - iwantz = 3 + iwantz = 3_${ik}$ else - iwantz = 0 + iwantz = 0_${ik}$ end if ! check argument values - info = 0 - if( iwants==0 ) then - info = -1 - else if( iwantq==0 ) then - info = -2 - else if( iwantz==0 ) then - info = -3 - else if( n<0 ) then - info = -4 - else if( ilo<1 ) then - info = -5 + info = 0_${ik}$ + if( iwants==0_${ik}$ ) then + info = -1_${ik}$ + else if( iwantq==0_${ik}$ ) then + info = -2_${ik}$ + else if( iwantz==0_${ik}$ ) then + info = -3_${ik}$ + else if( n<0_${ik}$ ) then + info = -4_${ik}$ + else if( ilo<1_${ik}$ ) then + info = -5_${ik}$ else if( ihi>n .or. ihi= 2 ) then - call stdlib_zhgeqz( wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb,alpha, beta, q,& + if( n < nmin .or. rec >= 2_${ik}$ ) then + call stdlib${ii}$_zhgeqz( wants, wantq, wantz, n, ilo, ihi, a, lda, b, ldb,alpha, beta, q,& ldq, z, ldz, work, lwork, rwork,info ) return end if ! find out required workspace - ! workspace query to stdlib_zlaqz2 + ! workspace query to stdlib${ii}$_zlaqz2 nw = max( nwr, nmin ) - call stdlib_zlaqz2( ilschur, ilq, ilz, n, ilo, ihi, nw, a, lda, b, ldb,q, ldq, z, ldz, & - n_undeflated, n_deflated, alpha,beta, work, nw, work, nw, work, -1, rwork, rec,& + call stdlib${ii}$_zlaqz2( ilschur, ilq, ilz, n, ilo, ihi, nw, a, lda, b, ldb,q, ldq, z, ldz, & + n_undeflated, n_deflated, alpha,beta, work, nw, work, nw, work, -1_${ik}$, rwork, rec,& aed_info ) - itemp1 = int( work( 1 ),KIND=ilp) - ! workspace query to stdlib_zlaqz3 - call stdlib_zlaqz3( ilschur, ilq, ilz, n, ilo, ihi, nsr, nbr, alpha,beta, a, lda, b, & - ldb, q, ldq, z, ldz, work, nbr,work, nbr, work, -1, sweep_info ) - itemp2 = int( work( 1 ),KIND=ilp) - lworkreq = max( itemp1+2*nw**2, itemp2+2*nbr**2 ) - if ( lwork ==-1 ) then - work( 1 ) = real( lworkreq,KIND=dp) + itemp1 = int( work( 1_${ik}$ ),KIND=${ik}$) + ! workspace query to stdlib${ii}$_zlaqz3 + call stdlib${ii}$_zlaqz3( ilschur, ilq, ilz, n, ilo, ihi, nsr, nbr, alpha,beta, a, lda, b, & + ldb, q, ldq, z, ldz, work, nbr,work, nbr, work, -1_${ik}$, sweep_info ) + itemp2 = int( work( 1_${ik}$ ),KIND=${ik}$) + lworkreq = max( itemp1+2*nw**2_${ik}$, itemp2+2*nbr**2_${ik}$ ) + if ( lwork ==-1_${ik}$ ) then + work( 1_${ik}$ ) = real( lworkreq,KIND=dp) return else if ( lwork < lworkreq ) then - info = -19 + info = -19_${ik}$ end if - if( info/=0 ) then - call stdlib_xerbla( 'ZLAQZ0', info ) + if( info/=0_${ik}$ ) then + call stdlib${ii}$_xerbla( 'ZLAQZ0', info ) return end if ! initialize q and z - if( iwantq==3 ) call stdlib_zlaset( 'FULL', n, n, czero, cone, q,ldq ) - if( iwantz==3 ) call stdlib_zlaset( 'FULL', n, n, czero, cone, z,ldz ) + if( iwantq==3_${ik}$ ) call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, q,ldq ) + if( iwantz==3_${ik}$ ) call stdlib${ii}$_zlaset( 'FULL', n, n, czero, cone, z,ldz ) ! get machine constants - safmin = stdlib_dlamch( 'SAFE MINIMUM' ) + safmin = stdlib${ii}$_dlamch( 'SAFE MINIMUM' ) safmax = one/safmin - call stdlib_dlabad( safmin, safmax ) - ulp = stdlib_dlamch( 'PRECISION' ) + call stdlib${ii}$_dlabad( safmin, safmax ) + ulp = stdlib${ii}$_dlamch( 'PRECISION' ) smlnum = safmin*( real( n,KIND=dp)/ulp ) istart = ilo istop = ihi - maxit = 30*( ihi-ilo+1 ) - ld = 0 + maxit = 30_${ik}$*( ihi-ilo+1 ) + ld = 0_${ik}$ do iiter = 1, maxit if( iiter >= maxit ) then info = istop+1 @@ -80330,7 +80325,7 @@ module stdlib_linalg_lapack_z a( istop-1,istop-1 ) ) ) ) ) then a( istop, istop-1 ) = czero istop = istop-1 - ld = 0 + ld = 0_${ik}$ eshift = czero end if ! check deflations at the start @@ -80338,7 +80333,7 @@ module stdlib_linalg_lapack_z abs( a( istart+1,istart+1 ) ) ) ) ) then a( istart+1, istart ) = czero istart = istart+1 - ld = 0 + ld = 0_${ik}$ eshift = czero end if if ( istart+1 >= istop ) then @@ -80356,7 +80351,7 @@ module stdlib_linalg_lapack_z end do ! get range to apply rotations to if ( ilschur ) then - istartm = 1 + istartm = 1_${ik}$ istopm = n else istartm = istart2 @@ -80377,42 +80372,42 @@ module stdlib_linalg_lapack_z ! a diagonal element of b is negligable, move it ! to the top and deflate it do k2 = k, istart2+1, -1 - call stdlib_zlartg( b( k2-1, k2 ), b( k2-1, k2-1 ), c1, s1,temp ) + call stdlib${ii}$_zlartg( b( k2-1, k2 ), b( k2-1, k2-1 ), c1, s1,temp ) b( k2-1, k2 ) = temp b( k2-1, k2-1 ) = czero - call stdlib_zrot( k2-2-istartm+1, b( istartm, k2 ), 1,b( istartm, k2-1 ), & - 1, c1, s1 ) - call stdlib_zrot( min( k2+1, istop )-istartm+1, a( istartm,k2 ), 1, a( & - istartm, k2-1 ), 1, c1, s1 ) + call stdlib${ii}$_zrot( k2-2-istartm+1, b( istartm, k2 ), 1_${ik}$,b( istartm, k2-1 ), & + 1_${ik}$, c1, s1 ) + call stdlib${ii}$_zrot( min( k2+1, istop )-istartm+1, a( istartm,k2 ), 1_${ik}$, a( & + istartm, k2-1 ), 1_${ik}$, c1, s1 ) if ( ilz ) then - call stdlib_zrot( n, z( 1, k2 ), 1, z( 1, k2-1 ), 1, c1,s1 ) + call stdlib${ii}$_zrot( n, z( 1_${ik}$, k2 ), 1_${ik}$, z( 1_${ik}$, k2-1 ), 1_${ik}$, c1,s1 ) end if if( k2= istop ) then istop = istart2-1 - ld = 0 + ld = 0_${ik}$ eshift = czero cycle end if @@ -80443,15 +80438,15 @@ module stdlib_linalg_lapack_z end if end if ! time for aed - call stdlib_zlaqz2( ilschur, ilq, ilz, n, istart2, istop, nw, a, lda,b, ldb, q, ldq,& - z, ldz, n_undeflated, n_deflated,alpha, beta, work, nw, work( nw**2+1 ), nw,work( & - 2*nw**2+1 ), lwork-2*nw**2, rwork, rec,aed_info ) - if ( n_deflated > 0 ) then + call stdlib${ii}$_zlaqz2( ilschur, ilq, ilz, n, istart2, istop, nw, a, lda,b, ldb, q, ldq,& + z, ldz, n_undeflated, n_deflated,alpha, beta, work, nw, work( nw**2_${ik}$+1 ), nw,work( & + 2_${ik}$*nw**2_${ik}$+1 ), lwork-2*nw**2_${ik}$, rwork, rec,aed_info ) + if ( n_deflated > 0_${ik}$ ) then istop = istop-n_deflated - ld = 0 + ld = 0_${ik}$ eshift = czero end if - if ( 100*n_deflated > nibble*( n_deflated+n_undeflated ) .or.istop-istart2+1 < nmin & + if ( 100_${ik}$*n_deflated > nibble*( n_deflated+n_undeflated ) .or.istop-istart2+1 < nmin & ) then ! aed has uncovered many eigenvalues. skip a qz sweep and run ! aed again. @@ -80461,7 +80456,7 @@ module stdlib_linalg_lapack_z ns = min( nshifts, istop-istart2 ) ns = min( ns, n_undeflated ) shiftpos = istop-n_deflated-n_undeflated+1 - if ( mod( ld, 6 ) == 0 ) then + if ( mod( ld, 6_${ik}$ ) == 0_${ik}$ ) then ! exceptional shift. chosen for no particularly good reason. if( ( real( maxit,KIND=dp)*safmin )*abs( a( istop,istop-1 ) ) ilo ) then a( kwtop, kwtop-1 ) = czero end if end if end if ! store window in case of convergence failure - call stdlib_zlacpy( 'ALL', jw, jw, a( kwtop, kwtop ), lda, work, jw ) - call stdlib_zlacpy( 'ALL', jw, jw, b( kwtop, kwtop ), ldb, work( jw**2+1 ), jw ) + call stdlib${ii}$_zlacpy( 'ALL', jw, jw, a( kwtop, kwtop ), lda, work, jw ) + call stdlib${ii}$_zlacpy( 'ALL', jw, jw, b( kwtop, kwtop ), ldb, work( jw**2_${ik}$+1 ), jw ) ! transform window to real schur form - call stdlib_zlaset( 'FULL', jw, jw, czero, cone, qc, ldqc ) - call stdlib_zlaset( 'FULL', jw, jw, czero, cone, zc, ldzc ) - call stdlib_zlaqz0( 'S', 'V', 'V', jw, 1, jw, a( kwtop, kwtop ), lda,b( kwtop, kwtop ),& - ldb, alpha, beta, qc, ldqc, zc,ldzc, work( 2*jw**2+1 ), lwork-2*jw**2, rwork,rec+1, & + call stdlib${ii}$_zlaset( 'FULL', jw, jw, czero, cone, qc, ldqc ) + call stdlib${ii}$_zlaset( 'FULL', jw, jw, czero, cone, zc, ldzc ) + call stdlib${ii}$_zlaqz0( 'S', 'V', 'V', jw, 1_${ik}$, jw, a( kwtop, kwtop ), lda,b( kwtop, kwtop ),& + ldb, alpha, beta, qc, ldqc, zc,ldzc, work( 2_${ik}$*jw**2_${ik}$+1 ), lwork-2*jw**2_${ik}$, rwork,rec+1, & qz_small_info ) - if( qz_small_info /= 0 ) then + if( qz_small_info /= 0_${ik}$ ) then ! convergence failure, restore the window and exit - nd = 0 + nd = 0_${ik}$ ns = jw-qz_small_info - call stdlib_zlacpy( 'ALL', jw, jw, work, jw, a( kwtop, kwtop ), lda ) - call stdlib_zlacpy( 'ALL', jw, jw, work( jw**2+1 ), jw, b( kwtop,kwtop ), ldb ) + call stdlib${ii}$_zlacpy( 'ALL', jw, jw, work, jw, a( kwtop, kwtop ), lda ) + call stdlib${ii}$_zlacpy( 'ALL', jw, jw, work( jw**2_${ik}$+1 ), jw, b( kwtop,kwtop ), ldb ) return end if @@ -80579,15 +80574,15 @@ module stdlib_linalg_lapack_z kwbot = kwtop-1 else kwbot = ihi - k = 1 - k2 = 1 + k = 1_${ik}$ + k2 = 1_${ik}$ do while ( k <= jw ) ! try to deflate eigenvalue tempr = abs( a( kwbot, kwbot ) ) if( tempr == zero ) then tempr = abs( s ) end if - if ( ( abs( s*qc( 1, kwbot-kwtop+1 ) ) ) <= max( ulp*tempr, smlnum ) ) & + if ( ( abs( s*qc( 1_${ik}$, kwbot-kwtop+1 ) ) ) <= max( ulp*tempr, smlnum ) ) & then ! deflatable kwbot = kwbot-1 @@ -80595,7 +80590,7 @@ module stdlib_linalg_lapack_z ! not deflatable, move out of the way ifst = kwbot-kwtop+1 ilst = k2 - call stdlib_ztgexc( .true., .true., jw, a( kwtop, kwtop ),lda, b( kwtop, & + call stdlib${ii}$_ztgexc( .true., .true., jw, a( kwtop, kwtop ),lda, b( kwtop, & kwtop ), ldb, qc, ldqc,zc, ldzc, ifst, ilst, ztgexc_info ) k2 = k2+1 end if @@ -80613,16 +80608,16 @@ module stdlib_linalg_lapack_z end do if ( kwtop /= ilo .and. s /= czero ) then ! reflect spike back, this will create optimally packed bulges - a( kwtop:kwbot, kwtop-1 ) = a( kwtop, kwtop-1 ) *conjg( qc( 1,1:jw-nd ) ) + a( kwtop:kwbot, kwtop-1 ) = a( kwtop, kwtop-1 ) *conjg( qc( 1_${ik}$,1_${ik}$:jw-nd ) ) do k = kwbot-1, kwtop, -1 - call stdlib_zlartg( a( k, kwtop-1 ), a( k+1, kwtop-1 ), c1, s1,temp ) + call stdlib${ii}$_zlartg( a( k, kwtop-1 ), a( k+1, kwtop-1 ), c1, s1,temp ) a( k, kwtop-1 ) = temp a( k+1, kwtop-1 ) = czero k2 = max( kwtop, k-1 ) - call stdlib_zrot( ihi-k2+1, a( k, k2 ), lda, a( k+1, k2 ), lda, c1,s1 ) - call stdlib_zrot( ihi-( k-1 )+1, b( k, k-1 ), ldb, b( k+1, k-1 ),ldb, c1, s1 ) + call stdlib${ii}$_zrot( ihi-k2+1, a( k, k2 ), lda, a( k+1, k2 ), lda, c1,s1 ) + call stdlib${ii}$_zrot( ihi-( k-1 )+1_${ik}$, b( k, k-1 ), ldb, b( k+1, k-1 ),ldb, c1, s1 ) - call stdlib_zrot( jw, qc( 1, k-kwtop+1 ), 1, qc( 1, k+1-kwtop+1 ),1, c1, conjg( & + call stdlib${ii}$_zrot( jw, qc( 1_${ik}$, k-kwtop+1 ), 1_${ik}$, qc( 1_${ik}$, k+1-kwtop+1 ),1_${ik}$, c1, conjg( & s1 ) ) end do ! chase bulges down @@ -80632,7 +80627,7 @@ module stdlib_linalg_lapack_z do while ( k >= kwtop ) ! move bulge down and remove it do k2 = k, kwbot-1 - call stdlib_zlaqz1( .true., .true., k2, kwtop, kwtop+jw-1,kwbot, a, lda, b, & + call stdlib${ii}$_zlaqz1( .true., .true., k2, kwtop, kwtop+jw-1,kwbot, a, lda, b, & ldb, jw, kwtop, qc, ldqc,jw, kwtop, zc, ldzc ) end do k = k-1 @@ -80640,44 +80635,44 @@ module stdlib_linalg_lapack_z end if ! apply qc and zc to rest of the matrix if ( ilschur ) then - istartm = 1 + istartm = 1_${ik}$ istopm = n else istartm = ilo istopm = ihi end if - if ( istopm-ihi > 0 ) then - call stdlib_zgemm( 'C', 'N', jw, istopm-ihi, jw, cone, qc, ldqc,a( kwtop, ihi+1 ), & + if ( istopm-ihi > 0_${ik}$ ) then + call stdlib${ii}$_zgemm( 'C', 'N', jw, istopm-ihi, jw, cone, qc, ldqc,a( kwtop, ihi+1 ), & lda, czero, work, jw ) - call stdlib_zlacpy( 'ALL', jw, istopm-ihi, work, jw, a( kwtop,ihi+1 ), lda ) - call stdlib_zgemm( 'C', 'N', jw, istopm-ihi, jw, cone, qc, ldqc,b( kwtop, ihi+1 ), & + call stdlib${ii}$_zlacpy( 'ALL', jw, istopm-ihi, work, jw, a( kwtop,ihi+1 ), lda ) + call stdlib${ii}$_zgemm( 'C', 'N', jw, istopm-ihi, jw, cone, qc, ldqc,b( kwtop, ihi+1 ), & ldb, czero, work, jw ) - call stdlib_zlacpy( 'ALL', jw, istopm-ihi, work, jw, b( kwtop,ihi+1 ), ldb ) + call stdlib${ii}$_zlacpy( 'ALL', jw, istopm-ihi, work, jw, b( kwtop,ihi+1 ), ldb ) end if if ( ilq ) then - call stdlib_zgemm( 'N', 'N', n, jw, jw, cone, q( 1, kwtop ), ldq, qc,ldqc, czero, & + call stdlib${ii}$_zgemm( 'N', 'N', n, jw, jw, cone, q( 1_${ik}$, kwtop ), ldq, qc,ldqc, czero, & work, n ) - call stdlib_zlacpy( 'ALL', n, jw, work, n, q( 1, kwtop ), ldq ) + call stdlib${ii}$_zlacpy( 'ALL', n, jw, work, n, q( 1_${ik}$, kwtop ), ldq ) end if - if ( kwtop-1-istartm+1 > 0 ) then - call stdlib_zgemm( 'N', 'N', kwtop-istartm, jw, jw, cone, a( istartm,kwtop ), lda, & + if ( kwtop-1-istartm+1 > 0_${ik}$ ) then + call stdlib${ii}$_zgemm( 'N', 'N', kwtop-istartm, jw, jw, cone, a( istartm,kwtop ), lda, & zc, ldzc, czero, work,kwtop-istartm ) - call stdlib_zlacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,a( istartm, kwtop )& + call stdlib${ii}$_zlacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,a( istartm, kwtop )& , lda ) - call stdlib_zgemm( 'N', 'N', kwtop-istartm, jw, jw, cone, b( istartm,kwtop ), ldb, & + call stdlib${ii}$_zgemm( 'N', 'N', kwtop-istartm, jw, jw, cone, b( istartm,kwtop ), ldb, & zc, ldzc, czero, work,kwtop-istartm ) - call stdlib_zlacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,b( istartm, kwtop )& + call stdlib${ii}$_zlacpy( 'ALL', kwtop-istartm, jw, work, kwtop-istartm,b( istartm, kwtop )& , ldb ) end if if ( ilz ) then - call stdlib_zgemm( 'N', 'N', n, jw, jw, cone, z( 1, kwtop ), ldz, zc,ldzc, czero, & + call stdlib${ii}$_zgemm( 'N', 'N', n, jw, jw, cone, z( 1_${ik}$, kwtop ), ldz, zc,ldzc, czero, & work, n ) - call stdlib_zlacpy( 'ALL', n, jw, work, n, z( 1, kwtop ), ldz ) + call stdlib${ii}$_zlacpy( 'ALL', n, jw, work, n, z( 1_${ik}$, kwtop ), ldz ) end if - end subroutine stdlib_zlaqz2 + end subroutine stdlib${ii}$_zlaqz2 - pure subroutine stdlib_zlasyf_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) + pure subroutine stdlib${ii}$_zlasyf_aa( uplo, j1, m, nb, a, lda, ipiv,h, ldh, work ) !! DLATRF_AA factorizes a panel of a complex symmetric matrix A using !! the Aasen's algorithm. The panel consists of a set of NB rows of A !! when UPLO is U, or a set of NB columns when UPLO is L. @@ -80693,23 +80688,23 @@ module stdlib_linalg_lapack_z ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- ! Scalar Arguments character, intent(in) :: uplo - integer(ilp), intent(in) :: m, nb, j1, lda, ldh + integer(${ik}$), intent(in) :: m, nb, j1, lda, ldh ! Array Arguments - integer(ilp), intent(out) :: ipiv(*) + integer(${ik}$), intent(out) :: ipiv(*) complex(dp), intent(inout) :: a(lda,*), h(ldh,*) complex(dp), intent(out) :: work(*) ! ===================================================================== ! Local Scalars - integer(ilp) :: j, k, k1, i1, i2, mj + integer(${ik}$) :: j, k, k1, i1, i2, mj complex(dp) :: piv, alpha ! Intrinsic Functions intrinsic :: max ! Executable Statements - j = 1 + j = 1_${ik}$ ! k1 is the first column of the panel to be factorized ! i.e., k1 is 2 for the first block column, and 1 for the rest of the blocks - k1 = (2-j1)+1 + k1 = (2_${ik}$-j1)+1_${ik}$ if( stdlib_lsame( uplo, 'U' ) ) then ! ..................................................... ! factorize a as u**t*d*u using the upper triangle of a @@ -80717,96 +80712,96 @@ module stdlib_linalg_lapack_z 10 continue if ( j>min(m, nb) )go to 20 ! k is the column to be factorized - ! when being called from stdlib_zsytrf_aa, + ! when being called from stdlib${ii}$_zsytrf_aa, ! > for the first block column, j1 is 1, hence j1+j-1 is j, ! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1, k = j1+j-1 if( j==m ) then ! only need to compute t(j, j) - mj = 1 + mj = 1_${ik}$ else mj = m-j+1 end if ! h(j:m, j) := a(j, j:m) - h(j:m, 1:(j-1)) * l(j1:(j-1), j), ! where h(j:m, j) has been initialized to be a(j, j:m) - if( k>2 ) then + if( k>2_${ik}$ ) then ! k is the column to be factorized ! > for the first block column, k is j, skipping the first two ! columns ! > for the rest of the columns, k is j+1, skipping only the ! first column - call stdlib_zgemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( 1, j ), 1,& - cone, h( j, j ), 1 ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( 1_${ik}$, j ), 1_${ik}$,& + cone, h( j, j ), 1_${ik}$ ) end if ! copy h(i:m, i) into work - call stdlib_zcopy( mj, h( j, j ), 1, work( 1 ), 1 ) + call stdlib${ii}$_zcopy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) if( j>k1 ) then ! compute work := work - l(j-1, j:m) * t(j-1,j), ! where a(j-1, j) stores t(j-1, j) and a(j-2, j:m) stores u(j-1, j:m) alpha = -a( k-1, j ) - call stdlib_zaxpy( mj, alpha, a( k-2, j ), lda, work( 1 ), 1 ) + call stdlib${ii}$_zaxpy( mj, alpha, a( k-2, j ), lda, work( 1_${ik}$ ), 1_${ik}$ ) end if ! set a(j, j) = t(j, j) - a( k, j ) = work( 1 ) + a( k, j ) = work( 1_${ik}$ ) if( j1 ) then + if( k>1_${ik}$ ) then alpha = -a( k, j ) - call stdlib_zaxpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2 ), 1 ) + call stdlib${ii}$_zaxpy( m-j, alpha, a( k-1, j+1 ), lda,work( 2_${ik}$ ), 1_${ik}$ ) endif ! find max(|work(2:m)|) - i2 = stdlib_izamax( m-j, work( 2 ), 1 ) + 1 + i2 = stdlib${ii}$_izamax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$ piv = work( i2 ) ! apply symmetric pivot - if( (i2/=2) .and. (piv/=0) ) then + if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then ! swap work(i1) and work(i2) - i1 = 2 + i1 = 2_${ik}$ work( i2 ) = work( i1 ) work( i1 ) = piv ! swap a(i1, i1+1:m) with a(i1+1:m, i2) i1 = i1+j-1 i2 = i2+j-1 - call stdlib_zswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1 ) + call stdlib${ii}$_zswap( i2-i1-1, a( j1+i1-1, i1+1 ), lda,a( j1+i1, i2 ), 1_${ik}$ ) ! swap a(i1, i2+1:m) with a(i2, i2+1:m) - if( i2(k1-1) ) then ! swap l(1:i1-1, i1) with l(1:i1-1, i2), ! skipping the first column - call stdlib_zswap( i1-k1+1, a( 1, i1 ), 1,a( 1, i2 ), 1 ) + call stdlib${ii}$_zswap( i1-k1+1, a( 1_${ik}$, i1 ), 1_${ik}$,a( 1_${ik}$, i2 ), 1_${ik}$ ) end if else ipiv( j+1 ) = j+1 endif ! set a(j, j+1) = t(j, j+1) - a( k, j+1 ) = work( 2 ) + a( k, j+1 ) = work( 2_${ik}$ ) if( jmin( m, nb ) )go to 40 ! k is the column to be factorized - ! when being called from stdlib_zsytrf_aa, + ! when being called from stdlib${ii}$_zsytrf_aa, ! > for the first block column, j1 is 1, hence j1+j-1 is j, ! > for the rest of the columns, j1 is 2, and j1+j-1 is j+1, k = j1+j-1 if( j==m ) then ! only need to compute t(j, j) - mj = 1 + mj = 1_${ik}$ else mj = m-j+1 end if ! h(j:m, j) := a(j:m, j) - h(j:m, 1:(j-1)) * l(j, j1:(j-1))^t, ! where h(j:m, j) has been initialized to be a(j:m, j) - if( k>2 ) then + if( k>2_${ik}$ ) then ! k is the column to be factorized ! > for the first block column, k is j, skipping the first two ! columns ! > for the rest of the columns, k is j+1, skipping only the ! first column - call stdlib_zgemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( j, 1 ), & - lda,cone, h( j, j ), 1 ) + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', mj, j-k1,-cone, h( j, k1 ), ldh,a( j, 1_${ik}$ ), & + lda,cone, h( j, j ), 1_${ik}$ ) end if ! copy h(j:m, j) into work - call stdlib_zcopy( mj, h( j, j ), 1, work( 1 ), 1 ) + call stdlib${ii}$_zcopy( mj, h( j, j ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) if( j>k1 ) then ! compute work := work - l(j:m, j-1) * t(j-1,j), ! where a(j-1, j) = t(j-1, j) and a(j, j-2) = l(j, j-1) alpha = -a( j, k-1 ) - call stdlib_zaxpy( mj, alpha, a( j, k-2 ), 1, work( 1 ), 1 ) + call stdlib${ii}$_zaxpy( mj, alpha, a( j, k-2 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) end if ! set a(j, j) = t(j, j) - a( j, k ) = work( 1 ) + a( j, k ) = work( 1_${ik}$ ) if( j1 ) then + if( k>1_${ik}$ ) then alpha = -a( j, k ) - call stdlib_zaxpy( m-j, alpha, a( j+1, k-1 ), 1,work( 2 ), 1 ) + call stdlib${ii}$_zaxpy( m-j, alpha, a( j+1, k-1 ), 1_${ik}$,work( 2_${ik}$ ), 1_${ik}$ ) endif ! find max(|work(2:m)|) - i2 = stdlib_izamax( m-j, work( 2 ), 1 ) + 1 + i2 = stdlib${ii}$_izamax( m-j, work( 2_${ik}$ ), 1_${ik}$ ) + 1_${ik}$ piv = work( i2 ) ! apply symmetric pivot - if( (i2/=2) .and. (piv/=0) ) then + if( (i2/=2_${ik}$) .and. (piv/=0_${ik}$) ) then ! swap work(i1) and work(i2) - i1 = 2 + i1 = 2_${ik}$ work( i2 ) = work( i1 ) work( i1 ) = piv ! swap a(i1+1:m, i1) with a(i2, i1+1:m) i1 = i1+j-1 i2 = i2+j-1 - call stdlib_zswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1,a( i2, j1+i1 ), lda ) + call stdlib${ii}$_zswap( i2-i1-1, a( i1+1, j1+i1-1 ), 1_${ik}$,a( i2, j1+i1 ), lda ) ! swap a(i2+1:m, i1) with a(i2+1:m, i2) - if( i2(k1-1) ) then ! swap l(1:i1-1, i1) with l(1:i1-1, i2), ! skipping the first column - call stdlib_zswap( i1-k1+1, a( i1, 1 ), lda,a( i2, 1 ), lda ) + call stdlib${ii}$_zswap( i1-k1+1, a( i1, 1_${ik}$ ), lda,a( i2, 1_${ik}$ ), lda ) end if else ipiv( j+1 ) = j+1 endif ! set a(j+1, j) = t(j+1, j) - a( j+1, k ) = work( 2 ) + a( j+1, k ) = work( 2_${ik}$ ) if( j=n )go to 20 ! each step of the main loop @@ -81068,17 +81063,17 @@ module stdlib_linalg_lapack_z ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=1 for the first panel, and ! k1=0 for the rest - j1 = j + 1 + j1 = j + 1_${ik}$ jb = min( n-j1+1, nb ) - k1 = max(1, j)-j + k1 = max(1_${ik}$, j)-j ! panel factorization - call stdlib_zlasyf_aa( uplo, 2-k1, n-j, jb,a( max(1, j), j+1 ), lda,ipiv( j+1 ), & + call stdlib${ii}$_zlasyf_aa( uplo, 2_${ik}$-k1, n-j, jb,a( max(1_${ik}$, j), j+1 ), lda,ipiv( j+1 ), & work, n, work( n*nb+1 ) ) ! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot) do j2 = j+2, min(n, j+jb+1) ipiv( j2 ) = ipiv( j2 ) + j - if( (j2/=ipiv(j2)) .and. ((j1-k1)>2) ) then - call stdlib_zswap( j1-k1-2, a( 1, j2 ), 1,a( 1, ipiv(j2) ), 1 ) + if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then + call stdlib${ii}$_zswap( j1-k1-2, a( 1_${ik}$, j2 ), 1_${ik}$,a( 1_${ik}$, ipiv(j2) ), 1_${ik}$ ) end if end do j = j + jb @@ -81087,43 +81082,43 @@ module stdlib_linalg_lapack_z ! work stores the current block of the auxiriarly matrix h if( j1 .or. jb>1 ) then + if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then ! merge rank-1 update with blas-3 update alpha = a( j, j+1 ) a( j, j+1 ) = cone - call stdlib_zcopy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib${ii}$_zcopy( n-j, a( j-1, j+1 ), lda,work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) - call stdlib_zscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib${ii}$_zscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=1 and k2= 0 for the first panel, ! while k1=0 and k2=1 for the rest - if( j1>1 ) then + if( j1>1_${ik}$ ) then ! not first panel - k2 = 1 + k2 = 1_${ik}$ else ! first panel - k2 = 0 + k2 = 0_${ik}$ ! first update skips the first column - jb = jb - 1 + jb = jb - 1_${ik}$ end if do j2 = j+1, n, nb nj = min( nb, n-j2+1 ) - ! update (j2, j2) diagonal block with stdlib_zgemv + ! update (j2, j2) diagonal block with stdlib${ii}$_zgemv j3 = j2 do mj = nj-1, 1, -1 - call stdlib_zgemv( 'NO TRANSPOSE', mj, jb+1,-cone, work( j3-j1+1+k1*n ),& - n,a( j1-k2, j3 ), 1,cone, a( j3, j3 ), lda ) - j3 = j3 + 1 + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', mj, jb+1,-cone, work( j3-j1+1+k1*n ),& + n,a( j1-k2, j3 ), 1_${ik}$,cone, a( j3, j3 ), lda ) + j3 = j3 + 1_${ik}$ end do - ! update off-diagonal block of j2-th block row with stdlib_zgemm - call stdlib_zgemm( 'TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-cone, a( j1-& + ! update off-diagonal block of j2-th block row with stdlib${ii}$_zgemm + call stdlib${ii}$_zgemm( 'TRANSPOSE', 'TRANSPOSE',nj, n-j3+1, jb+1,-cone, a( j1-& k2, j2 ), lda,work( j3-j1+1+k1*n ), n,cone, a( j2, j3 ), lda ) end do ! recover t( j, j+1 ) a( j, j+1 ) = alpha end if ! work(j+1, 1) stores h(j+1, 1) - call stdlib_zcopy( n-j, a( j+1, j+1 ), lda, work( 1 ), 1 ) + call stdlib${ii}$_zcopy( n-j, a( j+1, j+1 ), lda, work( 1_${ik}$ ), 1_${ik}$ ) end if go to 10 else @@ -81132,11 +81127,11 @@ module stdlib_linalg_lapack_z ! ..................................................... ! copy first column a(1:n, 1) into h(1:n, 1) ! (stored in work(1:n)) - call stdlib_zcopy( n, a( 1, 1 ), 1, work( 1 ), 1 ) + call stdlib${ii}$_zcopy( n, a( 1_${ik}$, 1_${ik}$ ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) ! j is the main loop index, increasing from 1 to n in steps of - ! jb, where jb is the number of columns factorized by stdlib_zlasyf; + ! jb, where jb is the number of columns factorized by stdlib${ii}$_zlasyf; ! jb is either nb, or n-j+1 for the last block - j = 0 + j = 0_${ik}$ 11 continue if( j>=n )go to 20 ! each step of the main loop @@ -81147,15 +81142,15 @@ module stdlib_linalg_lapack_z ! k1=0 for the rest j1 = j+1 jb = min( n-j1+1, nb ) - k1 = max(1, j)-j + k1 = max(1_${ik}$, j)-j ! panel factorization - call stdlib_zlasyf_aa( uplo, 2-k1, n-j, jb,a( j+1, max(1, j) ), lda,ipiv( j+1 ), & + call stdlib${ii}$_zlasyf_aa( uplo, 2_${ik}$-k1, n-j, jb,a( j+1, max(1_${ik}$, j) ), lda,ipiv( j+1 ), & work, n, work( n*nb+1 ) ) ! adjust ipiv and apply it back (j-th step picks (j+1)-th pivot) do j2 = j+2, min(n, j+jb+1) ipiv( j2 ) = ipiv( j2 ) + j - if( (j2/=ipiv(j2)) .and. ((j1-k1)>2) ) then - call stdlib_zswap( j1-k1-2, a( j2, 1 ), lda,a( ipiv(j2), 1 ), lda ) + if( (j2/=ipiv(j2)) .and. ((j1-k1)>2_${ik}$) ) then + call stdlib${ii}$_zswap( j1-k1-2, a( j2, 1_${ik}$ ), lda,a( ipiv(j2), 1_${ik}$ ), lda ) end if end do j = j + jb @@ -81164,35 +81159,35 @@ module stdlib_linalg_lapack_z ! work(j2+1, 1) stores h(j2+1, 1) if( j1 .or. jb>1 ) then + if( j1>1_${ik}$ .or. jb>1_${ik}$ ) then ! merge rank-1 update with blas-3 update alpha = a( j+1, j ) a( j+1, j ) = cone - call stdlib_zcopy( n-j, a( j+1, j-1 ), 1,work( (j+1-j1+1)+jb*n ), 1 ) - call stdlib_zscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1 ) + call stdlib${ii}$_zcopy( n-j, a( j+1, j-1 ), 1_${ik}$,work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) + call stdlib${ii}$_zscal( n-j, alpha, work( (j+1-j1+1)+jb*n ), 1_${ik}$ ) ! k1 identifies if the previous column of the panel has been ! explicitly stored, e.g., k1=1 and k2= 0 for the first panel, ! while k1=0 and k2=1 for the rest - if( j1>1 ) then + if( j1>1_${ik}$ ) then ! not first panel - k2 = 1 + k2 = 1_${ik}$ else ! first panel - k2 = 0 + k2 = 0_${ik}$ ! first update skips the first column - jb = jb - 1 + jb = jb - 1_${ik}$ end if do j2 = j+1, n, nb nj = min( nb, n-j2+1 ) - ! update (j2, j2) diagonal block with stdlib_zgemv + ! update (j2, j2) diagonal block with stdlib${ii}$_zgemv j3 = j2 do mj = nj-1, 1, -1 - call stdlib_zgemv( 'NO TRANSPOSE', mj, jb+1,-cone, work( j3-j1+1+k1*n ),& - n,a( j3, j1-k2 ), lda,cone, a( j3, j3 ), 1 ) - j3 = j3 + 1 + call stdlib${ii}$_zgemv( 'NO TRANSPOSE', mj, jb+1,-cone, work( j3-j1+1+k1*n ),& + n,a( j3, j1-k2 ), lda,cone, a( j3, j3 ), 1_${ik}$ ) + j3 = j3 + 1_${ik}$ end do - ! update off-diagonal block in j2-th block column with stdlib_zgemm - call stdlib_zgemm( 'NO TRANSPOSE', 'TRANSPOSE',n-j3+1, nj, jb+1,-cone, & + ! update off-diagonal block in j2-th block column with stdlib${ii}$_zgemm + call stdlib${ii}$_zgemm( 'NO TRANSPOSE', 'TRANSPOSE',n-j3+1, nj, jb+1,-cone, & work( j3-j1+1+k1*n ), n,a( j2, j1-k2 ), lda,cone, a( j3, j2 ), lda ) end do @@ -81200,15 +81195,15 @@ module stdlib_linalg_lapack_z a( j+1, j ) = alpha end if ! work(j+1, 1) stores h(j+1, 1) - call stdlib_zcopy( n-j, a( j+1, j+1 ), 1, work( 1 ), 1 ) + call stdlib${ii}$_zcopy( n-j, a( j+1, j+1 ), 1_${ik}$, work( 1_${ik}$ ), 1_${ik}$ ) end if go to 11 end if 20 continue - work( 1 ) = lwkopt + work( 1_${ik}$ ) = lwkopt return - end subroutine stdlib_zsytrf_aa - + end subroutine stdlib${ii}$_zsytrf_aa + #:endfor end module stdlib_linalg_lapack_z